From b45ec557f814e5b0329bc6612c6bfa377063f805 Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Thu, 3 Dec 2015 15:38:40 +0000 Subject: [PATCH] Import ghc_7.10.3.orig.tar.xz [dgit import orig ghc_7.10.3.orig.tar.xz] --- ANNOUNCE | 126 + GIT_COMMIT_ID | 1 + HACKING.md | 154 + INSTALL.md | 45 + LICENSE | 31 + MAKEHELP.md | 81 + Makefile | 121 + README.md | 129 + VERSION | 1 + aclocal.m4 | 2381 + bindisttest/HelloWorld.lhs | 8 + bindisttest/Makefile | 65 + bindisttest/checkBinaries.sh | 19 + bindisttest/expected_output | 1 + bindisttest/ghc.mk | 55 + boot | 193 + compiler/DEPEND-NOTES | 4 + compiler/HsVersions.h | 53 + compiler/LICENSE | 31 + compiler/Makefile | 24 + compiler/NOTES | 16 + compiler/basicTypes/Avail.hs | 103 + compiler/basicTypes/BasicTypes.hs | 1116 + compiler/basicTypes/ConLike.hs | 81 + compiler/basicTypes/DataCon.hs | 1158 + compiler/basicTypes/DataCon.hs-boot | 18 + compiler/basicTypes/Demand.hs | 1946 + compiler/basicTypes/Id.hs | 820 + compiler/basicTypes/IdInfo.hs | 519 + compiler/basicTypes/IdInfo.hs-boot | 8 + compiler/basicTypes/Lexeme.hs | 261 + compiler/basicTypes/Literal.hs | 493 + compiler/basicTypes/MkId.hs | 1397 + compiler/basicTypes/MkId.hs-boot | 12 + compiler/basicTypes/Module.hs | 512 + compiler/basicTypes/Module.hs-boot | 8 + compiler/basicTypes/Name.hs | 615 + compiler/basicTypes/Name.hs-boot | 7 + compiler/basicTypes/NameEnv.hs | 117 + compiler/basicTypes/NameSet.hs | 195 + compiler/basicTypes/OccName.hs | 893 + compiler/basicTypes/OccName.hs-boot | 3 + compiler/basicTypes/PatSyn.hs | 345 + compiler/basicTypes/PatSyn.hs-boot | 17 + compiler/basicTypes/RdrName.hs | 951 + compiler/basicTypes/SrcLoc.hs | 601 + compiler/basicTypes/UniqSupply.hs | 200 + compiler/basicTypes/Unique.hs | 351 + compiler/basicTypes/Var.hs | 440 + compiler/basicTypes/VarEnv.hs | 450 + compiler/basicTypes/VarSet.hs | 120 + compiler/cbits/genSym.c | 17 + compiler/cmm/Bitmap.hs | 88 + compiler/cmm/BlockId.hs | 71 + compiler/cmm/CLabel.hs | 1209 + compiler/cmm/Cmm.hs | 212 + compiler/cmm/CmmBuildInfoTables.hs | 373 + compiler/cmm/CmmCallConv.hs | 220 + compiler/cmm/CmmCommonBlockElim.hs | 301 + compiler/cmm/CmmContFlowOpt.hs | 402 + compiler/cmm/CmmExpr.hs | 585 + compiler/cmm/CmmInfo.hs | 553 + compiler/cmm/CmmLayoutStack.hs | 1113 + compiler/cmm/CmmLex.hs | 615 + compiler/cmm/CmmLex.x.source | 363 + compiler/cmm/CmmLint.hs | 263 + compiler/cmm/CmmLive.hs | 100 + compiler/cmm/CmmMachOp.hs | 607 + compiler/cmm/CmmNode.hs | 687 + compiler/cmm/CmmOpt.hs | 417 + compiler/cmm/CmmParse.hs | 3198 ++ compiler/cmm/CmmParse.y.source | 1389 + compiler/cmm/CmmPipeline.hs | 359 + compiler/cmm/CmmProcPoint.hs | 480 + compiler/cmm/CmmSink.hs | 791 + compiler/cmm/CmmType.hs | 445 + compiler/cmm/CmmUtils.hs | 619 + compiler/cmm/Debug.hs | 309 + compiler/cmm/Hoopl.hs | 155 + compiler/cmm/Hoopl/Dataflow.hs | 887 + compiler/cmm/MkGraph.hs | 407 + compiler/cmm/PprC.hs | 1271 + compiler/cmm/PprCmm.hs | 295 + compiler/cmm/PprCmmDecl.hs | 167 + compiler/cmm/PprCmmExpr.hs | 278 + compiler/cmm/SMRep.hs | 546 + compiler/cmm/cmm-notes | 285 + compiler/codeGen/CgUtils.hs | 173 + compiler/codeGen/CodeGen/Platform.hs | 117 + compiler/codeGen/CodeGen/Platform/ARM.hs | 8 + compiler/codeGen/CodeGen/Platform/ARM64.hs | 8 + compiler/codeGen/CodeGen/Platform/NoRegs.hs | 7 + compiler/codeGen/CodeGen/Platform/PPC.hs | 8 + .../codeGen/CodeGen/Platform/PPC_Darwin.hs | 9 + compiler/codeGen/CodeGen/Platform/SPARC.hs | 8 + compiler/codeGen/CodeGen/Platform/X86.hs | 8 + compiler/codeGen/CodeGen/Platform/X86_64.hs | 8 + compiler/codeGen/StgCmm.hs | 280 + compiler/codeGen/StgCmmArgRep.hs | 151 + compiler/codeGen/StgCmmBind.hs | 751 + compiler/codeGen/StgCmmBind.hs-boot | 6 + compiler/codeGen/StgCmmClosure.hs | 1036 + compiler/codeGen/StgCmmCon.hs | 269 + compiler/codeGen/StgCmmEnv.hs | 220 + compiler/codeGen/StgCmmExpr.hs | 902 + compiler/codeGen/StgCmmExtCode.hs | 254 + compiler/codeGen/StgCmmForeign.hs | 556 + compiler/codeGen/StgCmmHeap.hs | 688 + compiler/codeGen/StgCmmHpc.hs | 46 + compiler/codeGen/StgCmmLayout.hs | 544 + compiler/codeGen/StgCmmMonad.hs | 876 + compiler/codeGen/StgCmmPrim.hs | 2157 + compiler/codeGen/StgCmmProf.hs | 366 + compiler/codeGen/StgCmmTicky.hs | 659 + compiler/codeGen/StgCmmUtils.hs | 728 + compiler/coreSyn/CoreArity.hs | 1028 + compiler/coreSyn/CoreFVs.hs | 533 + compiler/coreSyn/CoreLint.hs | 1802 + compiler/coreSyn/CorePrep.hs | 1293 + compiler/coreSyn/CoreSubst.hs | 1527 + compiler/coreSyn/CoreSyn.hs | 1718 + compiler/coreSyn/CoreTidy.hs | 272 + compiler/coreSyn/CoreUnfold.hs | 1369 + compiler/coreSyn/CoreUtils.hs | 2099 + compiler/coreSyn/MkCore.hs | 774 + compiler/coreSyn/PprCore.hs | 533 + compiler/coreSyn/TrieMap.hs | 839 + compiler/deSugar/Check.hs | 773 + compiler/deSugar/Coverage.hs | 1274 + compiler/deSugar/Desugar.hs | 486 + compiler/deSugar/DsArrows.hs | 1178 + compiler/deSugar/DsBinds.hs | 1200 + compiler/deSugar/DsCCall.hs | 382 + compiler/deSugar/DsExpr.hs | 979 + compiler/deSugar/DsExpr.hs-boot | 9 + compiler/deSugar/DsForeign.hs | 812 + compiler/deSugar/DsGRHSs.hs | 159 + compiler/deSugar/DsListComp.hs | 871 + compiler/deSugar/DsMeta.hs | 2919 ++ compiler/deSugar/DsMonad.hs | 455 + compiler/deSugar/DsUtils.hs | 825 + compiler/deSugar/Match.hs | 1091 + compiler/deSugar/Match.hs-boot | 33 + compiler/deSugar/MatchCon.hs | 290 + compiler/deSugar/MatchLit.hs | 464 + compiler/deSugar/StaticPtrTable.hs | 97 + compiler/ghc.cabal.in | 579 + compiler/ghc.mk | 746 + compiler/ghci/ByteCodeAsm.hs | 555 + compiler/ghci/ByteCodeGen.hs | 1688 + compiler/ghci/ByteCodeInstr.hs | 327 + compiler/ghci/ByteCodeItbls.hs | 410 + compiler/ghci/ByteCodeLink.hs | 271 + compiler/ghci/Debugger.hs | 233 + compiler/ghci/DebuggerUtils.hs | 139 + compiler/ghci/LibFFI.hsc | 138 + compiler/ghci/Linker.hs | 1323 + compiler/ghci/ObjLink.hs | 118 + compiler/ghci/RtClosureInspect.hs | 1287 + compiler/ghci/keepCAFsForGHCi.c | 15 + compiler/hsSyn/Convert.hs | 1295 + compiler/hsSyn/HsBinds.hs | 929 + compiler/hsSyn/HsDecls.hs | 1754 + compiler/hsSyn/HsDoc.hs | 28 + compiler/hsSyn/HsExpr.hs | 1951 + compiler/hsSyn/HsExpr.hs-boot | 69 + compiler/hsSyn/HsImpExp.hs | 209 + compiler/hsSyn/HsLit.hs | 177 + compiler/hsSyn/HsPat.hs | 522 + compiler/hsSyn/HsPat.hs-boot | 30 + compiler/hsSyn/HsSyn.hs | 145 + compiler/hsSyn/HsTypes.hs | 964 + compiler/hsSyn/HsUtils.hs | 936 + compiler/hsSyn/PlaceHolder.hs | 104 + compiler/iface/BinIface.hs | 419 + compiler/iface/BuildTyCl.hs | 333 + compiler/iface/FlagChecker.hs | 80 + compiler/iface/IfaceEnv.hs | 315 + compiler/iface/IfaceSyn.hs | 1858 + compiler/iface/IfaceType.hs | 973 + compiler/iface/LoadIface.hs | 1093 + compiler/iface/MkIface.hs | 2033 + compiler/iface/TcIface.hs | 1381 + compiler/iface/TcIface.hs-boot | 18 + compiler/llvmGen/Llvm.hs | 61 + compiler/llvmGen/Llvm/AbsSyn.hs | 301 + compiler/llvmGen/Llvm/MetaData.hs | 83 + compiler/llvmGen/Llvm/PpLlvm.hs | 461 + compiler/llvmGen/Llvm/Types.hs | 839 + compiler/llvmGen/LlvmCodeGen.hs | 198 + compiler/llvmGen/LlvmCodeGen/Base.hs | 564 + compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1693 + compiler/llvmGen/LlvmCodeGen/Data.hs | 137 + compiler/llvmGen/LlvmCodeGen/Ppr.hs | 195 + compiler/llvmGen/LlvmCodeGen/Regs.hs | 130 + compiler/llvmGen/LlvmMangler.hs | 181 + compiler/main/Annotations.hs | 124 + compiler/main/BreakArray.hs | 121 + compiler/main/CmdLineParser.hs | 320 + compiler/main/CodeOutput.hs | 253 + compiler/main/Constants.hs | 32 + compiler/main/DriverMkDepend.hs | 408 + compiler/main/DriverPhases.hs | 321 + compiler/main/DriverPipeline.hs | 2317 + compiler/main/DynFlags.hs | 4308 ++ compiler/main/DynFlags.hs-boot | 13 + compiler/main/DynamicLoading.hs | 240 + compiler/main/ErrUtils.hs | 431 + compiler/main/ErrUtils.hs-boot | 17 + compiler/main/Finder.hs | 705 + compiler/main/GHC.hs | 1463 + compiler/main/GhcMake.hs | 2039 + compiler/main/GhcMonad.hs | 207 + compiler/main/GhcPlugins.hs | 84 + compiler/main/HeaderInfo.hs | 318 + compiler/main/Hooks.hs | 85 + compiler/main/Hooks.hs-boot | 5 + compiler/main/HscMain.hs | 1727 + compiler/main/HscStats.hs | 175 + compiler/main/HscTypes.hs | 2825 ++ compiler/main/InteractiveEval.hs | 1055 + compiler/main/InteractiveEvalTypes.hs | 67 + compiler/main/PackageConfig.hs | 164 + compiler/main/Packages.hs | 1399 + compiler/main/Packages.hs-boot | 6 + compiler/main/PipelineMonad.hs | 109 + compiler/main/PlatformConstants.hs | 14 + compiler/main/Plugins.hs | 38 + compiler/main/PprTyThing.hs | 173 + compiler/main/StaticFlags.hs | 243 + compiler/main/StaticFlags.hs-boot | 4 + compiler/main/SysTools.hs | 1760 + compiler/main/TidyPgm.hs | 1463 + compiler/nativeGen/AsmCodeGen.hs | 1136 + compiler/nativeGen/CPrim.hs | 101 + compiler/nativeGen/Dwarf.hs | 166 + compiler/nativeGen/Dwarf/Constants.hs | 197 + compiler/nativeGen/Dwarf/Types.hs | 443 + compiler/nativeGen/Instruction.hs | 200 + compiler/nativeGen/NCG.h | 14 + compiler/nativeGen/NCGMonad.hs | 207 + compiler/nativeGen/NOTES | 41 + compiler/nativeGen/PIC.hs | 782 + compiler/nativeGen/PPC/CodeGen.hs | 1478 + compiler/nativeGen/PPC/Cond.hs | 61 + compiler/nativeGen/PPC/Instr.hs | 617 + compiler/nativeGen/PPC/Ppr.hs | 785 + compiler/nativeGen/PPC/RegInfo.hs | 74 + compiler/nativeGen/PPC/Regs.hs | 325 + compiler/nativeGen/PprBase.hs | 72 + compiler/nativeGen/Reg.hs | 217 + compiler/nativeGen/RegAlloc/Graph/ArchBase.hs | 154 + compiler/nativeGen/RegAlloc/Graph/ArchX86.hs | 146 + compiler/nativeGen/RegAlloc/Graph/Coalesce.hs | 99 + compiler/nativeGen/RegAlloc/Graph/Main.hs | 454 + compiler/nativeGen/RegAlloc/Graph/Spill.hs | 377 + .../nativeGen/RegAlloc/Graph/SpillClean.hs | 613 + .../nativeGen/RegAlloc/Graph/SpillCost.hs | 288 + compiler/nativeGen/RegAlloc/Graph/Stats.hs | 346 + .../nativeGen/RegAlloc/Graph/TrivColorable.hs | 280 + compiler/nativeGen/RegAlloc/Linear/Base.hs | 132 + .../nativeGen/RegAlloc/Linear/FreeRegs.hs | 85 + .../RegAlloc/Linear/JoinToTargets.hs | 357 + compiler/nativeGen/RegAlloc/Linear/Main.hs | 891 + .../nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs | 60 + .../RegAlloc/Linear/SPARC/FreeRegs.hs | 187 + .../nativeGen/RegAlloc/Linear/StackMap.hs | 59 + compiler/nativeGen/RegAlloc/Linear/State.hs | 166 + compiler/nativeGen/RegAlloc/Linear/Stats.hs | 86 + .../nativeGen/RegAlloc/Linear/X86/FreeRegs.hs | 51 + .../RegAlloc/Linear/X86_64/FreeRegs.hs | 52 + compiler/nativeGen/RegAlloc/Liveness.hs | 999 + compiler/nativeGen/RegClass.hs | 33 + compiler/nativeGen/SPARC/AddrMode.hs | 42 + compiler/nativeGen/SPARC/Base.hs | 75 + compiler/nativeGen/SPARC/CodeGen.hs | 679 + compiler/nativeGen/SPARC/CodeGen/Amode.hs | 72 + compiler/nativeGen/SPARC/CodeGen/Base.hs | 117 + compiler/nativeGen/SPARC/CodeGen/CondCode.hs | 108 + compiler/nativeGen/SPARC/CodeGen/Expand.hs | 153 + compiler/nativeGen/SPARC/CodeGen/Gen32.hs | 692 + .../nativeGen/SPARC/CodeGen/Gen32.hs-boot | 16 + compiler/nativeGen/SPARC/CodeGen/Gen64.hs | 199 + compiler/nativeGen/SPARC/CodeGen/Sanity.hs | 67 + compiler/nativeGen/SPARC/Cond.hs | 52 + compiler/nativeGen/SPARC/Imm.hs | 65 + compiler/nativeGen/SPARC/Instr.hs | 484 + compiler/nativeGen/SPARC/Ppr.hs | 634 + compiler/nativeGen/SPARC/Regs.hs | 266 + compiler/nativeGen/SPARC/ShortcutJump.hs | 69 + compiler/nativeGen/SPARC/Stack.hs | 57 + compiler/nativeGen/Size.hs | 105 + compiler/nativeGen/TargetReg.hs | 126 + compiler/nativeGen/X86/CodeGen.hs | 3002 ++ compiler/nativeGen/X86/Cond.hs | 68 + compiler/nativeGen/X86/Instr.hs | 1051 + compiler/nativeGen/X86/Ppr.hs | 1279 + compiler/nativeGen/X86/RegInfo.hs | 67 + compiler/nativeGen/X86/Regs.hs | 452 + compiler/parser/ApiAnnotation.hs | 297 + compiler/parser/Ctype.hs | 216 + compiler/parser/HaddockUtils.hs | 32 + compiler/parser/Lexer.hs | 2674 ++ compiler/parser/Lexer.x.source | 2671 ++ compiler/parser/Parser.hs | 10300 +++++ compiler/parser/Parser.y.source | 3196 ++ compiler/parser/RdrHsSyn.hs | 1518 + compiler/parser/cutils.c | 53 + compiler/parser/cutils.h | 16 + compiler/prelude/ForeignCall.hs | 345 + compiler/prelude/PrelInfo.hs | 155 + compiler/prelude/PrelNames.hs | 1956 + compiler/prelude/PrelNames.hs-boot | 7 + compiler/prelude/PrelRules.hs | 1345 + compiler/prelude/PrimOp.hs | 636 + compiler/prelude/PrimOp.hs-boot | 3 + compiler/prelude/TysPrim.hs | 787 + compiler/prelude/TysWiredIn.hs | 859 + compiler/prelude/TysWiredIn.hs-boot | 9 + compiler/prelude/primops.txt.pp | 3034 ++ compiler/profiling/CostCentre.hs | 326 + compiler/profiling/NOTES | 301 + compiler/profiling/ProfInit.hs | 46 + compiler/profiling/SCCfinal.hs | 284 + compiler/rename/RnBinds.hs | 1121 + compiler/rename/RnEnv.hs | 1935 + compiler/rename/RnExpr.hs | 1360 + compiler/rename/RnExpr.hs-boot | 18 + compiler/rename/RnHsDoc.hs | 23 + compiler/rename/RnNames.hs | 1805 + compiler/rename/RnPat.hs | 754 + compiler/rename/RnSource.hs | 1584 + compiler/rename/RnSplice.hs | 610 + compiler/rename/RnSplice.hs-boot | 15 + compiler/rename/RnTypes.hs | 1091 + compiler/rename/rename.tex | 18 + compiler/simplCore/CSE.hs | 336 + compiler/simplCore/CallArity.hs | 729 + compiler/simplCore/CoreMonad.hs | 880 + compiler/simplCore/FloatIn.hs | 561 + compiler/simplCore/FloatOut.hs | 592 + compiler/simplCore/LiberateCase.hs | 408 + compiler/simplCore/OccurAnal.hs | 1871 + compiler/simplCore/SAT.hs | 431 + compiler/simplCore/SetLevels.hs | 1114 + compiler/simplCore/SimplCore.hs | 946 + compiler/simplCore/SimplEnv.hs | 768 + compiler/simplCore/SimplMonad.hs | 218 + compiler/simplCore/SimplUtils.hs | 2004 + compiler/simplCore/Simplify.hs | 2977 ++ compiler/simplCore/simplifier.tib | 771 + compiler/simplStg/SimplStg.hs | 89 + compiler/simplStg/StgStats.hs | 173 + compiler/simplStg/UnariseStg.hs | 220 + compiler/specialise/Rules.hs | 1192 + compiler/specialise/SpecConstr.hs | 2054 + compiler/specialise/Specialise.hs | 2143 + compiler/stgSyn/CoreToStg.hs | 1189 + compiler/stgSyn/StgLint.hs | 533 + compiler/stgSyn/StgSyn.hs | 808 + compiler/stranal/DmdAnal.hs | 1210 + compiler/stranal/WorkWrap.hs | 478 + compiler/stranal/WwLib.hs | 770 + compiler/typecheck/FamInst.hs | 401 + compiler/typecheck/Flattening-notes | 32 + compiler/typecheck/FunDeps.hs | 621 + compiler/typecheck/Inst.hs | 617 + compiler/typecheck/TcAnnotations.hs | 69 + compiler/typecheck/TcArrows.hs | 422 + compiler/typecheck/TcBinds.hs | 1636 + compiler/typecheck/TcCanonical.hs | 1723 + compiler/typecheck/TcClassDcl.hs | 425 + compiler/typecheck/TcDefaults.hs | 98 + compiler/typecheck/TcDeriv.hs | 2123 + compiler/typecheck/TcEnv.hs | 918 + compiler/typecheck/TcEnv.hs-boot | 6 + compiler/typecheck/TcErrors.hs | 1611 + compiler/typecheck/TcEvidence.hs | 1118 + compiler/typecheck/TcExpr.hs | 1584 + compiler/typecheck/TcExpr.hs-boot | 26 + compiler/typecheck/TcFlatten.hs | 1590 + compiler/typecheck/TcForeign.hs | 548 + compiler/typecheck/TcGenDeriv.hs | 2280 + compiler/typecheck/TcGenGenerics.hs | 883 + compiler/typecheck/TcHsSyn.hs | 1535 + compiler/typecheck/TcHsType.hs | 1669 + compiler/typecheck/TcInstDcls.hs | 1531 + compiler/typecheck/TcInteract.hs | 2249 + compiler/typecheck/TcMType.hs | 1022 + compiler/typecheck/TcMatches.hs | 860 + compiler/typecheck/TcMatches.hs-boot | 16 + compiler/typecheck/TcPat.hs | 1178 + compiler/typecheck/TcPatSyn.hs | 585 + compiler/typecheck/TcPatSyn.hs-boot | 18 + compiler/typecheck/TcPluginM.hs | 138 + compiler/typecheck/TcRnDriver.hs | 2171 + compiler/typecheck/TcRnMonad.hs | 1444 + compiler/typecheck/TcRnTypes.hs | 2161 + compiler/typecheck/TcRules.hs | 237 + compiler/typecheck/TcSMonad.hs | 1808 + compiler/typecheck/TcSimplify.hs | 1464 + compiler/typecheck/TcSplice.hs | 1754 + compiler/typecheck/TcSplice.hs-boot | 58 + compiler/typecheck/TcTyClsDecls.hs | 2315 + compiler/typecheck/TcTyDecls.hs | 849 + compiler/typecheck/TcType.hs | 1770 + compiler/typecheck/TcType.hs-boot | 7 + compiler/typecheck/TcTypeNats.hs | 691 + compiler/typecheck/TcTypeNats.hs-boot | 5 + compiler/typecheck/TcUnify.hs | 1327 + compiler/typecheck/TcUnify.hs-boot | 9 + compiler/typecheck/TcValidity.hs | 1359 + compiler/types/Class.hs | 299 + compiler/types/CoAxiom.hs | 532 + compiler/types/Coercion.hs | 2012 + compiler/types/FamInstEnv.hs | 1074 + compiler/types/InstEnv.hs | 1034 + compiler/types/Kind.hs | 301 + compiler/types/OptCoercion.hs | 741 + compiler/types/TyCon.hs | 1851 + compiler/types/TyCon.hs-boot | 12 + compiler/types/Type.hs | 1749 + compiler/types/Type.hs-boot | 9 + compiler/types/TypeRep.hs | 943 + compiler/types/TypeRep.hs-boot | 12 + compiler/types/Unify.hs | 744 + compiler/utils/Bag.hs | 266 + compiler/utils/Binary.hs | 938 + compiler/utils/BooleanFormula.hs | 215 + compiler/utils/BufWrite.hs | 119 + compiler/utils/Digraph.hs | 652 + compiler/utils/Encoding.hs | 387 + compiler/utils/Exception.hs | 81 + compiler/utils/ExtsCompat46.hs | 293 + compiler/utils/FastBool.hs | 70 + compiler/utils/FastFunctions.hs | 46 + compiler/utils/FastMutInt.hs | 63 + compiler/utils/FastString.hs | 640 + compiler/utils/FastTypes.hs | 138 + compiler/utils/Fingerprint.hsc | 71 + compiler/utils/FiniteMap.hs | 29 + compiler/utils/GraphBase.hs | 105 + compiler/utils/GraphColor.hs | 369 + compiler/utils/GraphOps.hs | 665 + compiler/utils/GraphPpr.hs | 168 + compiler/utils/IOEnv.hs | 219 + compiler/utils/ListSetOps.hs | 187 + compiler/utils/Maybes.hs | 124 + compiler/utils/MonadUtils.hs | 173 + compiler/utils/OrdList.hs | 116 + compiler/utils/Outputable.hs | 1029 + compiler/utils/Outputable.hs-boot | 3 + compiler/utils/Pair.hs | 50 + compiler/utils/Panic.hs | 307 + compiler/utils/Platform.hs | 155 + compiler/utils/Pretty.hs | 1024 + compiler/utils/Serialized.hs | 189 + compiler/utils/State.hs | 51 + compiler/utils/Stream.hs | 109 + compiler/utils/StringBuffer.hs | 257 + compiler/utils/UnVarGraph.hs | 136 + compiler/utils/UniqFM.hs | 315 + compiler/utils/UniqSet.hs | 115 + compiler/utils/Util.hs | 1138 + compiler/utils/md5.h | 24 + compiler/vectorise/Vectorise.hs | 356 + compiler/vectorise/Vectorise/Builtins.hs | 35 + compiler/vectorise/Vectorise/Builtins/Base.hs | 217 + .../Vectorise/Builtins/Initialise.hs | 232 + compiler/vectorise/Vectorise/Convert.hs | 103 + compiler/vectorise/Vectorise/Env.hs | 234 + compiler/vectorise/Vectorise/Exp.hs | 1237 + .../Vectorise/Generic/Description.hs | 292 + .../vectorise/Vectorise/Generic/PADict.hs | 125 + .../vectorise/Vectorise/Generic/PAMethods.hs | 584 + compiler/vectorise/Vectorise/Generic/PData.hs | 161 + compiler/vectorise/Vectorise/Monad.hs | 198 + compiler/vectorise/Vectorise/Monad/Base.hs | 246 + compiler/vectorise/Vectorise/Monad/Global.hs | 238 + compiler/vectorise/Vectorise/Monad/InstEnv.hs | 80 + compiler/vectorise/Vectorise/Monad/Local.hs | 104 + compiler/vectorise/Vectorise/Monad/Naming.hs | 123 + compiler/vectorise/Vectorise/Type/Classify.hs | 137 + compiler/vectorise/Vectorise/Type/Env.hs | 452 + .../vectorise/Vectorise/Type/TyConDecl.hs | 194 + compiler/vectorise/Vectorise/Type/Type.hs | 82 + compiler/vectorise/Vectorise/Utils.hs | 165 + compiler/vectorise/Vectorise/Utils/Base.hs | 262 + compiler/vectorise/Vectorise/Utils/Closure.hs | 161 + .../vectorise/Vectorise/Utils/Hoisting.hs | 98 + compiler/vectorise/Vectorise/Utils/PADict.hs | 228 + compiler/vectorise/Vectorise/Utils/Poly.hs | 72 + compiler/vectorise/Vectorise/Var.hs | 103 + compiler/vectorise/Vectorise/Vect.hs | 126 + config.guess | 1420 + config.sub | 1794 + configure | 14339 ++++++ configure.ac | 1162 + distrib/INSTALL | 41 + distrib/Makefile | 73 + distrib/README | 17 + distrib/compare/BuildInfo.hs | 59 + distrib/compare/Change.hs | 43 + distrib/compare/FilenameDescr.hs | 61 + distrib/compare/Makefile | 12 + distrib/compare/Tar.hs | 58 + distrib/compare/Utils.hs | 44 + distrib/compare/compare.hs | 322 + distrib/configure.ac.in | 175 + distrib/cross-port | 77 + distrib/hc-build | 114 + distrib/hsicon.ico | Bin 0 -> 2734 bytes distrib/mkDocs/mkDocs | 47 + distrib/remilestoning.pl | 119 + docs/Makefile | 4 + docs/backpack/.gitignore | 10 + docs/backpack/Makefile | 7 + docs/backpack/arch.png | Bin 0 -> 107562 bytes docs/backpack/backpack-impl.bib | 17 + docs/backpack/backpack-impl.pdf | Bin 0 -> 436890 bytes docs/backpack/backpack-impl.tex | 2492 + docs/backpack/backpack-manual.pdf | Bin 0 -> 199748 bytes docs/backpack/backpack-manual.tex | 648 + docs/backpack/commands-new-new.tex | 891 + docs/backpack/commands-rebindings.tex | 57 + docs/backpack/diagrams.pdf | Bin 0 -> 145951 bytes docs/backpack/diagrams.xoj | Bin 0 -> 118800 bytes docs/backpack/pkgdb.png | Bin 0 -> 61693 bytes docs/coding-style.html | 542 + docs/core-spec/.gitignore | 5 + docs/core-spec/CoreLint.ott | 539 + docs/core-spec/CoreSyn.ott | 406 + docs/core-spec/Makefile | 18 + docs/core-spec/OpSem.ott | 97 + docs/core-spec/README | 83 + docs/core-spec/core-spec.mng | 466 + docs/core-spec/core-spec.pdf | Bin 0 -> 339243 bytes docs/ghci/ghci.tex | 1598 + docs/hep/hep.tex | 1299 + docs/index.html.in | 58 + docs/man/gen_flags.xsl.sh | 290 + docs/man/ghc.mk | 58 + docs/ndp/haskell.sty | 496 + docs/ndp/vect.tex | 363 + docs/rts/closure.ps | 129 + docs/rts/closure.tex | 7 + docs/rts/hugs_ret.pstex | 145 + docs/rts/hugs_ret.pstex_t | 13 + docs/rts/hugs_ret2.pstex | 130 + docs/rts/hugs_ret2.pstex_t | 13 + docs/rts/rts.tex | 4683 ++ docs/stg-spec/fast-curry.rkt | 247 + docs/storage-mgt/Makefile | 42 + docs/storage-mgt/architecture.eepic | 55 + docs/storage-mgt/architecture.fig | 59 + docs/storage-mgt/cacheprof_p.eps | 2083 + docs/storage-mgt/code.sty | 83 + docs/storage-mgt/freelist.eepic | 104 + docs/storage-mgt/freelist.fig | 116 + docs/storage-mgt/gen.eepic | 57 + docs/storage-mgt/gen.fig | 71 + docs/storage-mgt/generation.eepic | 62 + docs/storage-mgt/generation.fig | 65 + docs/storage-mgt/largeobjectpool.eepic | 70 + docs/storage-mgt/largeobjectpool.fig | 82 + docs/storage-mgt/ldv.eepic | 41 + docs/storage-mgt/ldv.fig | 53 + docs/storage-mgt/ldv.tex | 695 + docs/storage-mgt/megablock.eepic | 35 + docs/storage-mgt/megablock.fig | 40 + docs/storage-mgt/nursery.eepic | 89 + docs/storage-mgt/nursery.fig | 107 + docs/storage-mgt/reference.bib | 14 + docs/storage-mgt/rp.tex | 1102 + docs/storage-mgt/sm.tex | 995 + docs/storage-mgt/smallobjectpool.eepic | 65 + docs/storage-mgt/smallobjectpool.fig | 74 + docs/storage-mgt/step.eepic | 121 + docs/storage-mgt/step.fig | 154 + docs/users_guide/7.10.1-notes.xml | 975 + docs/users_guide/7.10.2-notes.xml | 340 + docs/users_guide/7.10.3-notes.xml | 176 + docs/users_guide/Makefile | 3 + docs/users_guide/bugs.xml | 620 + docs/users_guide/codegens.xml | 125 + docs/users_guide/debugging.xml | 777 + docs/users_guide/extending_ghc.xml | 349 + docs/users_guide/ffi-chap.xml | 824 + docs/users_guide/flags.xml | 3363 ++ docs/users_guide/ghc.mk | 37 + docs/users_guide/ghci.xml | 3672 ++ docs/users_guide/glasgow_exts.xml | 12720 +++++ docs/users_guide/gone_wrong.xml | 212 + docs/users_guide/images/Recip.png | Bin 0 -> 72701 bytes docs/users_guide/intro.xml | 319 + docs/users_guide/lang.xml | 15 + docs/users_guide/license.xml | 65 + docs/users_guide/packages.xml | 1907 + docs/users_guide/parallel.xml | 202 + docs/users_guide/phases.xml | 1362 + docs/users_guide/prof_scc.eps | Bin 0 -> 17580 bytes docs/users_guide/profiling.xml | 1786 + docs/users_guide/runghc.xml | 46 + docs/users_guide/runtime_control.xml | 1589 + docs/users_guide/safe_haskell.xml | 793 + docs/users_guide/separate_compilation.xml | 1350 + docs/users_guide/shared_libs.xml | 262 + docs/users_guide/sooner.xml | 544 + docs/users_guide/ug-book.xml.in | 31 + docs/users_guide/ug-ent.xml.in | 32 + docs/users_guide/using.xml | 3446 ++ docs/users_guide/utils.xml | 606 + docs/users_guide/win32-dlls.xml | 574 + driver/Makefile | 15 + driver/gcc/gcc.c | 59 + driver/ghc-usage.txt | 81 + driver/ghc.mk | 22 + driver/ghc/Makefile | 3 + driver/ghc/ghc.c | 14 + driver/ghc/ghc.mk | 24 + driver/ghci-usage.txt | 27 + driver/ghci/Makefile | 15 + driver/ghci/ghc.mk | 67 + driver/ghci/ghci.c | 24 + driver/ghci/ghci.ico | Bin 0 -> 2734 bytes driver/ghci/ghci.rc | 1 + driver/haddock/Makefile | 3 + driver/haddock/ghc.mk | 24 + driver/haddock/haddock.c | 14 + driver/split/Makefile | 15 + driver/split/ghc-split.lprl | 434 + driver/split/ghc.mk | 20 + driver/utils/cwrapper.c | 156 + driver/utils/cwrapper.h | 5 + driver/utils/dynwrapper.c | 197 + driver/utils/getLocation.c | 40 + driver/utils/getLocation.h | 4 + ghc.mk | 1427 + ghc/GhciMonad.hs | 401 + ghc/GhciTags.hs | 206 + ghc/InteractiveUI.hs | 3232 ++ ghc/Main.hs | 896 + ghc/Makefile | 16 + ghc/ghc-bin.cabal.in | 62 + ghc/ghc-cross.wrapper | 1 + ghc/ghc.mk | 189 + ghc/ghc.wrapper | 1 + ghc/hschooks.c | 56 + includes/.dir-locals.el | 13 + includes/Cmm.h | 929 + includes/CodeGen.Platform.hs | 1127 + includes/HsFFI.h | 174 + includes/MachDeps.h | 120 + includes/Makefile | 15 + includes/Rts.h | 349 + includes/RtsAPI.h | 268 + includes/Stg.h | 559 + includes/ghc.mk | 235 + includes/ghcconfig.h | 7 + includes/rts/Adjustor.h | 25 + includes/rts/BlockSignals.h | 37 + includes/rts/Bytecodes.h | 94 + includes/rts/Config.h | 47 + includes/rts/Constants.h | 303 + includes/rts/EventLogFormat.h | 244 + includes/rts/FileLock.h | 22 + includes/rts/Flags.h | 298 + includes/rts/GetTime.h | 19 + includes/rts/Globals.h | 30 + includes/rts/Hooks.h | 26 + includes/rts/Hpc.h | 37 + includes/rts/IOManager.h | 46 + includes/rts/Linker.h | 72 + includes/rts/Main.h | 21 + includes/rts/Messages.h | 106 + includes/rts/OSThreads.h | 250 + includes/rts/Parallel.h | 19 + includes/rts/PrimFloat.h | 20 + includes/rts/Signals.h | 26 + includes/rts/SpinLock.h | 117 + includes/rts/Stable.h | 43 + includes/rts/StaticPtrTable.h | 39 + includes/rts/TTY.h | 20 + includes/rts/Threads.h | 77 + includes/rts/Ticky.h | 35 + includes/rts/Timer.h | 21 + includes/rts/Types.h | 40 + includes/rts/Utils.h | 19 + includes/rts/prof/CCS.h | 254 + includes/rts/prof/LDV.h | 47 + includes/rts/storage/Block.h | 333 + includes/rts/storage/ClosureMacros.h | 570 + includes/rts/storage/ClosureTypes.h | 88 + includes/rts/storage/Closures.h | 429 + includes/rts/storage/FunTypes.h | 57 + includes/rts/storage/GC.h | 284 + includes/rts/storage/InfoTables.h | 417 + includes/rts/storage/MBlock.h | 221 + includes/rts/storage/SMPClosureOps.h | 125 + includes/rts/storage/TSO.h | 273 + includes/shell-tools.c | 139 + includes/stg/DLL.h | 75 + includes/stg/HaskellMachRegs.h | 48 + includes/stg/MachRegs.h | 709 + includes/stg/MiscClosures.h | 500 + includes/stg/Prim.h | 85 + includes/stg/Regs.h | 531 + includes/stg/RtsMachRegs.h | 54 + includes/stg/SMP.h | 465 + includes/stg/Ticky.h | 213 + includes/stg/Types.h | 155 + install-sh | 527 + libffi-tarballs/LICENSE | 21 + libffi-tarballs/README | 4 + libffi-tarballs/libffi-3.1.tar.gz | Bin 0 -> 937214 bytes libffi/Makefile | 15 + libffi/ghc.mk | 139 + libffi/libffi.x86-execstack.patch | 24 + libffi/ln | 3 + libraries/Cabal/.gitignore | 36 + libraries/Cabal/.travis.yml | 71 + libraries/Cabal/Cabal/.gitignore | 2 + libraries/Cabal/Cabal/Cabal.cabal | 328 + .../Cabal/Cabal/Distribution/Compat/Binary.hs | 52 + .../Cabal/Distribution/Compat/Binary/Class.hs | 530 + .../Distribution/Compat/Binary/Generic.hs | 128 + .../Cabal/Distribution/Compat/CopyFile.hs | 109 + .../Cabal/Distribution/Compat/CreatePipe.hs | 62 + .../Cabal/Distribution/Compat/Environment.hs | 24 + .../Cabal/Distribution/Compat/Exception.hs | 17 + .../Cabal/Cabal/Distribution/Compat/ReadP.hs | 398 + .../Cabal/Distribution/Compat/TempFile.hs | 128 + .../Cabal/Cabal/Distribution/Compiler.hs | 204 + libraries/Cabal/Cabal/Distribution/GetOpt.hs | 335 + .../Distribution/InstalledPackageInfo.hs | 391 + libraries/Cabal/Cabal/Distribution/License.hs | 177 + libraries/Cabal/Cabal/Distribution/Make.hs | 184 + .../Cabal/Cabal/Distribution/ModuleName.hs | 110 + libraries/Cabal/Cabal/Distribution/Package.hs | 379 + .../Cabal/Distribution/PackageDescription.hs | 1157 + .../Distribution/PackageDescription/Check.hs | 1590 + .../PackageDescription/Configuration.hs | 609 + .../Distribution/PackageDescription/Parse.hs | 1279 + .../PackageDescription/PrettyPrint.hs | 243 + .../Distribution/PackageDescription/Utils.hs | 23 + .../Cabal/Cabal/Distribution/ParseUtils.hs | 755 + libraries/Cabal/Cabal/Distribution/ReadE.hs | 51 + libraries/Cabal/Cabal/Distribution/Simple.hs | 700 + .../Cabal/Cabal/Distribution/Simple/Bench.hs | 128 + .../Cabal/Cabal/Distribution/Simple/Build.hs | 605 + .../Cabal/Distribution/Simple/Build/Macros.hs | 109 + .../Distribution/Simple/Build/PathsModule.hs | 303 + .../Cabal/Distribution/Simple/BuildPaths.hs | 121 + .../Cabal/Distribution/Simple/BuildTarget.hs | 939 + .../Cabal/Distribution/Simple/CCompiler.hs | 124 + .../Cabal/Distribution/Simple/Command.hs | 600 + .../Cabal/Distribution/Simple/Compiler.hs | 287 + .../Cabal/Distribution/Simple/Configure.hs | 1674 + .../Cabal/Cabal/Distribution/Simple/GHC.hs | 1108 + .../Cabal/Distribution/Simple/GHC/IPI641.hs | 106 + .../Cabal/Distribution/Simple/GHC/IPI642.hs | 141 + .../Cabal/Distribution/Simple/GHC/ImplInfo.hs | 108 + .../Cabal/Distribution/Simple/GHC/Internal.hs | 492 + .../Cabal/Cabal/Distribution/Simple/GHCJS.hs | 904 + .../Cabal/Distribution/Simple/Haddock.hs | 804 + .../Cabal/Distribution/Simple/HaskellSuite.hs | 228 + .../Cabal/Cabal/Distribution/Simple/Hpc.hs | 141 + .../Cabal/Distribution/Simple/Install.hs | 190 + .../Cabal/Distribution/Simple/InstallDirs.hs | 608 + .../Cabal/Cabal/Distribution/Simple/JHC.hs | 196 + .../Cabal/Cabal/Distribution/Simple/LHC.hs | 803 + .../Distribution/Simple/LocalBuildInfo.hs | 504 + .../Cabal/Distribution/Simple/PackageIndex.hs | 695 + .../Cabal/Distribution/Simple/PreProcess.hs | 620 + .../Distribution/Simple/PreProcess/Unlit.hs | 165 + .../Cabal/Distribution/Simple/Program.hs | 222 + .../Cabal/Distribution/Simple/Program/Ar.hs | 169 + .../Distribution/Simple/Program/Builtin.hs | 362 + .../Cabal/Distribution/Simple/Program/Db.hs | 471 + .../Cabal/Distribution/Simple/Program/Find.hs | 126 + .../Cabal/Distribution/Simple/Program/GHC.hs | 562 + .../Distribution/Simple/Program/HcPkg.hs | 396 + .../Cabal/Distribution/Simple/Program/Hpc.hs | 100 + .../Cabal/Distribution/Simple/Program/Ld.hs | 62 + .../Cabal/Distribution/Simple/Program/Run.hs | 257 + .../Distribution/Simple/Program/Script.hs | 110 + .../Distribution/Simple/Program/Strip.hs | 72 + .../Distribution/Simple/Program/Types.hs | 164 + .../Cabal/Distribution/Simple/Register.hs | 464 + .../Cabal/Cabal/Distribution/Simple/Setup.hs | 2224 + .../Cabal/Distribution/Simple/SrcDist.hs | 490 + .../Cabal/Cabal/Distribution/Simple/Test.hs | 136 + .../Cabal/Distribution/Simple/Test/ExeV10.hs | 168 + .../Cabal/Distribution/Simple/Test/LibV09.hs | 258 + .../Cabal/Distribution/Simple/Test/Log.hs | 161 + .../Cabal/Cabal/Distribution/Simple/UHC.hs | 276 + .../Cabal/Distribution/Simple/UserHooks.hs | 211 + .../Cabal/Cabal/Distribution/Simple/Utils.hs | 1370 + libraries/Cabal/Cabal/Distribution/System.hs | 215 + .../Cabal/Cabal/Distribution/TestSuite.hs | 96 + libraries/Cabal/Cabal/Distribution/Text.hs | 68 + .../Cabal/Cabal/Distribution/Utils/NubList.hs | 100 + .../Cabal/Cabal/Distribution/Verbosity.hs | 89 + libraries/Cabal/Cabal/Distribution/Version.hs | 757 + libraries/Cabal/Cabal/GNUmakefile | 4 + libraries/Cabal/Cabal/LICENSE | 34 + .../Cabal/Cabal/Language/Haskell/Extension.hs | 795 + libraries/Cabal/Cabal/Makefile | 129 + libraries/Cabal/Cabal/README.md | 182 + libraries/Cabal/Cabal/Setup.hs | 10 + libraries/Cabal/Cabal/changelog | 467 + libraries/Cabal/Cabal/doc/Cabal.css | 49 + .../Cabal/doc/developing-packages.markdown | 2146 + libraries/Cabal/Cabal/doc/index.markdown | 200 + .../Cabal/doc/installing-packages.markdown | 1067 + libraries/Cabal/Cabal/doc/misc.markdown | 109 + libraries/Cabal/Cabal/ghc.mk | 5 + .../Cabal/misc/gen-extra-source-files.sh | 5 + libraries/Cabal/Cabal/prologue.txt | 7 + libraries/Cabal/Cabal/tests/PackageTests.hs | 172 + .../Cabal/Cabal/tests/PackageTests/.gitignore | 3 + .../PackageTests/BenchmarkExeV10/Check.hs | 16 + .../tests/PackageTests/BenchmarkExeV10/Foo.hs | 4 + .../BenchmarkExeV10/benchmarks/bench-Foo.hs | 8 + .../PackageTests/BenchmarkExeV10/my.cabal | 15 + .../BenchmarkOptions/BenchmarkOptions.cabal | 20 + .../PackageTests/BenchmarkOptions/Check.hs | 26 + .../BenchmarkOptions/test-BenchmarkOptions.hs | 11 + .../PackageTests/BenchmarkStanza/Check.hs | 52 + .../PackageTests/BenchmarkStanza/my.cabal | 19 + .../GlobalBuildDepsNotAdditive1/Check.hs | 22 + .../GlobalBuildDepsNotAdditive1.cabal | 20 + .../GlobalBuildDepsNotAdditive1/MyLibrary.hs | 10 + .../GlobalBuildDepsNotAdditive2/Check.hs | 22 + .../GlobalBuildDepsNotAdditive2.cabal | 20 + .../GlobalBuildDepsNotAdditive2/lemon.hs | 7 + .../BuildDeps/InternalLibrary0/Check.hs | 22 + .../BuildDeps/InternalLibrary0/MyLibrary.hs | 10 + .../BuildDeps/InternalLibrary0/my.cabal | 24 + .../InternalLibrary0/programs/lemon.hs | 6 + .../BuildDeps/InternalLibrary1/Check.hs | 16 + .../BuildDeps/InternalLibrary1/MyLibrary.hs | 10 + .../BuildDeps/InternalLibrary1/my.cabal | 23 + .../InternalLibrary1/programs/lemon.hs | 6 + .../BuildDeps/InternalLibrary2/Check.hs | 32 + .../BuildDeps/InternalLibrary2/MyLibrary.hs | 10 + .../BuildDeps/InternalLibrary2/my.cabal | 23 + .../InternalLibrary2/programs/lemon.hs | 6 + .../InternalLibrary2/to-install/MyLibrary.hs | 10 + .../InternalLibrary2/to-install/my.cabal | 18 + .../BuildDeps/InternalLibrary3/Check.hs | 32 + .../BuildDeps/InternalLibrary3/MyLibrary.hs | 10 + .../BuildDeps/InternalLibrary3/my.cabal | 23 + .../InternalLibrary3/programs/lemon.hs | 6 + .../InternalLibrary3/to-install/MyLibrary.hs | 10 + .../InternalLibrary3/to-install/my.cabal | 18 + .../BuildDeps/InternalLibrary4/Check.hs | 32 + .../BuildDeps/InternalLibrary4/MyLibrary.hs | 10 + .../BuildDeps/InternalLibrary4/my.cabal | 23 + .../InternalLibrary4/programs/lemon.hs | 6 + .../InternalLibrary4/to-install/MyLibrary.hs | 10 + .../InternalLibrary4/to-install/my.cabal | 18 + .../BuildDeps/SameDepsAllRound/Check.hs | 21 + .../BuildDeps/SameDepsAllRound/MyLibrary.hs | 10 + .../SameDepsAllRound/SameDepsAllRound.cabal | 31 + .../BuildDeps/SameDepsAllRound/lemon.hs | 7 + .../BuildDeps/SameDepsAllRound/pineapple.hs | 7 + .../BuildDeps/TargetSpecificDeps1/Check.hs | 29 + .../TargetSpecificDeps1/MyLibrary.hs | 10 + .../BuildDeps/TargetSpecificDeps1/lemon.hs | 7 + .../BuildDeps/TargetSpecificDeps1/my.cabal | 22 + .../BuildDeps/TargetSpecificDeps2/Check.hs | 21 + .../TargetSpecificDeps2/MyLibrary.hs | 10 + .../BuildDeps/TargetSpecificDeps2/lemon.hs | 5 + .../BuildDeps/TargetSpecificDeps2/my.cabal | 24 + .../BuildDeps/TargetSpecificDeps3/Check.hs | 28 + .../TargetSpecificDeps3/MyLibrary.hs | 10 + .../BuildDeps/TargetSpecificDeps3/lemon.hs | 7 + .../BuildDeps/TargetSpecificDeps3/my.cabal | 22 + .../BuildTestSuiteDetailedV09/Check.hs | 18 + .../BuildTestSuiteDetailedV09/Dummy.hs | 6 + .../BuildTestSuiteDetailedV09/my.cabal | 19 + .../Cabal/tests/PackageTests/CMain/Bar.hs | 7 + .../Cabal/tests/PackageTests/CMain/Check.hs | 20 + .../Cabal/tests/PackageTests/CMain/Setup.hs | 3 + .../Cabal/tests/PackageTests/CMain/foo.c | 13 + .../Cabal/tests/PackageTests/CMain/my.cabal | 10 + .../PackageTests/DeterministicAr/Check.hs | 141 + .../tests/PackageTests/DeterministicAr/Lib.hs | 5 + .../PackageTests/DeterministicAr/my.cabal | 17 + .../tests/PackageTests/EmptyLib/Check.hs | 16 + .../PackageTests/EmptyLib/empty/empty.cabal | 6 + .../Cabal/tests/PackageTests/Haddock/CPP.hs | 9 + .../Cabal/tests/PackageTests/Haddock/Check.hs | 42 + .../tests/PackageTests/Haddock/Literate.lhs | 4 + .../Cabal/tests/PackageTests/Haddock/NoCPP.hs | 8 + .../tests/PackageTests/Haddock/Simple.hs | 4 + .../Cabal/tests/PackageTests/Haddock/my.cabal | 16 + .../tests/PackageTests/OrderFlags/Check.hs | 24 + .../tests/PackageTests/OrderFlags/Foo.hs | 8 + .../tests/PackageTests/OrderFlags/my.cabal | 20 + .../Cabal/tests/PackageTests/PackageTester.hs | 308 + .../PathsModule/Executable/Check.hs | 16 + .../PathsModule/Executable/Main.hs | 8 + .../PathsModule/Executable/my.cabal | 16 + .../PackageTests/PathsModule/Library/Check.hs | 16 + .../PackageTests/PathsModule/Library/my.cabal | 15 + .../tests/PackageTests/PreProcess/Check.hs | 16 + .../tests/PackageTests/PreProcess/Foo.hsc | 1 + .../tests/PackageTests/PreProcess/Main.hs | 6 + .../tests/PackageTests/PreProcess/my.cabal | 32 + .../PackageTests/ReexportedModules/Check.hs | 41 + .../ReexportedModules/ReexportedModules.cabal | 11 + .../PackageTests/TemplateHaskell/Check.hs | 41 + .../TemplateHaskell/dynamic/Exe.hs | 6 + .../TemplateHaskell/dynamic/Lib.hs | 6 + .../TemplateHaskell/dynamic/TH.hs | 4 + .../TemplateHaskell/dynamic/my.cabal | 15 + .../TemplateHaskell/profiling/Exe.hs | 6 + .../TemplateHaskell/profiling/Lib.hs | 6 + .../TemplateHaskell/profiling/TH.hs | 4 + .../TemplateHaskell/profiling/my.cabal | 15 + .../TemplateHaskell/vanilla/Exe.hs | 6 + .../TemplateHaskell/vanilla/Lib.hs | 6 + .../TemplateHaskell/vanilla/TH.hs | 4 + .../TemplateHaskell/vanilla/my.cabal | 15 + .../tests/PackageTests/TestOptions/Check.hs | 26 + .../TestOptions/TestOptions.cabal | 20 + .../TestOptions/test-TestOptions.hs | 11 + .../tests/PackageTests/TestStanza/Check.hs | 53 + .../tests/PackageTests/TestStanza/my.cabal | 19 + .../PackageTests/TestSuiteExeV10/Check.hs | 147 + .../tests/PackageTests/TestSuiteExeV10/Foo.hs | 4 + .../PackageTests/TestSuiteExeV10/my.cabal | 15 + .../TestSuiteExeV10/tests/test-Foo.hs | 8 + libraries/Cabal/Cabal/tests/README.md | 34 + libraries/Cabal/Cabal/tests/Setup.hs | 3 + libraries/Cabal/Cabal/tests/UnitTests.hs | 27 + .../Distribution/Compat/CreatePipe.hs | 20 + .../UnitTests/Distribution/Compat/ReadP.hs | 153 + .../UnitTests/Distribution/Utils/NubList.hs | 47 + libraries/Cabal/Cabal/tests/hackage/check.sh | 25 + .../Cabal/Cabal/tests/hackage/download.sh | 19 + libraries/Cabal/Cabal/tests/hackage/unpack.sh | 16 + .../tests/misc/ghc-supported-languages.hs | 97 + libraries/Cabal/HACKING.md | 89 + libraries/Cabal/LICENSE | 33 + libraries/Cabal/README.md | 12 + libraries/Cabal/cabal-install/.ghci | 1 + .../Client/BuildReports/Anonymous.hs | 316 + .../Client/BuildReports/Storage.hs | 152 + .../Distribution/Client/BuildReports/Types.hs | 44 + .../Client/BuildReports/Upload.hs | 80 + .../Distribution/Client/Check.hs | 85 + .../Distribution/Client/Compat/Environment.hs | 87 + .../Client/Compat/ExecutablePath.hs | 183 + .../Distribution/Client/Compat/FilePerms.hs | 36 + .../Distribution/Client/Compat/Process.hs | 48 + .../Distribution/Client/Compat/Semaphore.hs | 104 + .../Distribution/Client/Compat/Time.hs | 142 + .../Distribution/Client/Config.hs | 931 + .../Distribution/Client/Configure.hs | 254 + .../Distribution/Client/Dependency.hs | 687 + .../Distribution/Client/Dependency/Modular.hs | 58 + .../Client/Dependency/Modular/Assignment.hs | 154 + .../Client/Dependency/Modular/Builder.hs | 170 + .../Client/Dependency/Modular/Configured.hs | 10 + .../Modular/ConfiguredConversion.hs | 40 + .../Client/Dependency/Modular/Dependency.hs | 181 + .../Client/Dependency/Modular/Explore.hs | 149 + .../Client/Dependency/Modular/Flag.hs | 70 + .../Client/Dependency/Modular/Index.hs | 33 + .../Dependency/Modular/IndexConversion.hs | 200 + .../Client/Dependency/Modular/Log.hs | 121 + .../Client/Dependency/Modular/Message.hs | 101 + .../Client/Dependency/Modular/PSQ.hs | 94 + .../Client/Dependency/Modular/Package.hs | 111 + .../Client/Dependency/Modular/Preference.hs | 281 + .../Client/Dependency/Modular/Solver.hs | 60 + .../Client/Dependency/Modular/Tree.hs | 121 + .../Client/Dependency/Modular/Validate.hs | 232 + .../Client/Dependency/Modular/Version.hs | 42 + .../Distribution/Client/Dependency/TopDown.hs | 946 + .../Client/Dependency/TopDown/Constraints.hs | 603 + .../Client/Dependency/TopDown/Types.hs | 91 + .../Distribution/Client/Dependency/Types.hs | 258 + .../cabal-install/Distribution/Client/Exec.hs | 122 + .../Distribution/Client/Fetch.hs | 195 + .../Distribution/Client/FetchUtils.hs | 192 + .../Distribution/Client/Freeze.hs | 237 + .../Distribution/Client/GZipUtils.hs | 44 + .../cabal-install/Distribution/Client/Get.hs | 355 + .../Distribution/Client/Haddock.hs | 69 + .../Distribution/Client/HttpUtils.hs | 159 + .../Distribution/Client/IndexUtils.hs | 591 + .../cabal-install/Distribution/Client/Init.hs | 864 + .../Distribution/Client/Init/Heuristics.hs | 386 + .../Distribution/Client/Init/Licenses.hs | 3065 ++ .../Distribution/Client/Init/Types.hs | 170 + .../Distribution/Client/Install.hs | 1565 + .../Distribution/Client/InstallPlan.hs | 627 + .../Distribution/Client/InstallSymlink.hs | 245 + .../Distribution/Client/JobControl.hs | 89 + .../cabal-install/Distribution/Client/List.hs | 589 + .../Distribution/Client/PackageIndex.hs | 490 + .../Distribution/Client/PackageUtils.hs | 34 + .../Distribution/Client/ParseUtils.hs | 62 + .../cabal-install/Distribution/Client/Run.hs | 95 + .../Distribution/Client/Sandbox.hs | 766 + .../Distribution/Client/Sandbox/Index.hs | 242 + .../Client/Sandbox/PackageEnvironment.hs | 573 + .../Distribution/Client/Sandbox/Timestamp.hs | 292 + .../Distribution/Client/Sandbox/Types.hs | 64 + .../Distribution/Client/Setup.hs | 2155 + .../Distribution/Client/SetupWrapper.hs | 579 + .../Distribution/Client/SrcDist.hs | 139 + .../cabal-install/Distribution/Client/Tar.hs | 951 + .../Distribution/Client/Targets.hs | 774 + .../Distribution/Client/Types.hs | 247 + .../Distribution/Client/Update.hs | 55 + .../Distribution/Client/Upload.hs | 173 + .../Distribution/Client/Utils.hs | 237 + .../Distribution/Client/Win32SelfUpgrade.hs | 225 + .../Distribution/Client/World.hs | 172 + libraries/Cabal/cabal-install/LICENSE | 34 + libraries/Cabal/cabal-install/Main.hs | 1119 + libraries/Cabal/cabal-install/README.md | 155 + libraries/Cabal/cabal-install/Setup.hs | 2 + .../Cabal/cabal-install/bash-completion/cabal | 80 + libraries/Cabal/cabal-install/bootstrap.sh | 436 + .../Cabal/cabal-install/cabal-install.cabal | 263 + .../Cabal/cabal-install/cbits/getnumcores.c | 46 + libraries/Cabal/cabal-install/changelog | 196 + .../Cabal/cabal-install/tests/PackageTests.hs | 88 + .../tests/PackageTests/Exec/Check.hs | 146 + .../tests/PackageTests/Exec/Foo.hs | 4 + .../tests/PackageTests/Exec/My.hs | 5 + .../tests/PackageTests/Exec/my.cabal | 14 + .../tests/PackageTests/Exec/subdir/.gitkeep | 0 .../tests/PackageTests/Freeze/Check.hs | 114 + .../tests/PackageTests/Freeze/my.cabal | 21 + .../PackageTests/MultipleSource/Check.hs | 28 + .../PackageTests/MultipleSource/p/LICENSE | 0 .../PackageTests/MultipleSource/p/Setup.hs | 2 + .../PackageTests/MultipleSource/p/p.cabal | 11 + .../PackageTests/MultipleSource/q/LICENSE | 0 .../PackageTests/MultipleSource/q/Setup.hs | 2 + .../PackageTests/MultipleSource/q/q.cabal | 11 + .../tests/PackageTests/PackageTester.hs | 232 + libraries/Cabal/cabal-install/tests/README | 1 + .../Cabal/cabal-install/tests/UnitTests.hs | 24 + .../Client/Dependency/Modular/PSQ.hs | 22 + .../UnitTests/Distribution/Client/Sandbox.hs | 29 + .../UnitTests/Distribution/Client/Targets.hs | 59 + .../Distribution/Client/UserConfig.hs | 104 + .../cabal-install/tests/test-cabal-install | 9 + .../tests/test-cabal-install-user | 8 + libraries/Cabal/ghc-packages | 2 + libraries/Makefile | 16 + libraries/Win32/.gitignore | 7 + libraries/Win32/.hgignore | 8 + libraries/Win32/GNUmakefile | 4 + libraries/Win32/Graphics/Win32.hs | 47 + libraries/Win32/Graphics/Win32/Control.hsc | 348 + libraries/Win32/Graphics/Win32/Dialogue.hsc | 336 + libraries/Win32/Graphics/Win32/GDI.hs | 51 + libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc | 423 + libraries/Win32/Graphics/Win32/GDI/Brush.hsc | 79 + libraries/Win32/Graphics/Win32/GDI/Clip.hsc | 159 + libraries/Win32/Graphics/Win32/GDI/Font.hsc | 209 + .../Win32/Graphics/Win32/GDI/Graphics2D.hs | 228 + libraries/Win32/Graphics/Win32/GDI/HDC.hs | 322 + .../Win32/Graphics/Win32/GDI/Palette.hsc | 52 + libraries/Win32/Graphics/Win32/GDI/Path.hs | 93 + libraries/Win32/Graphics/Win32/GDI/Pen.hsc | 109 + libraries/Win32/Graphics/Win32/GDI/Region.hs | 152 + libraries/Win32/Graphics/Win32/GDI/Types.hsc | 397 + libraries/Win32/Graphics/Win32/Icon.hs | 51 + libraries/Win32/Graphics/Win32/Key.hsc | 126 + libraries/Win32/Graphics/Win32/Menu.hsc | 478 + libraries/Win32/Graphics/Win32/Message.hsc | 180 + libraries/Win32/Graphics/Win32/Misc.hsc | 300 + libraries/Win32/Graphics/Win32/Resource.hsc | 150 + libraries/Win32/Graphics/Win32/Window.hsc | 725 + libraries/Win32/LICENSE | 30 + libraries/Win32/Setup.hs | 6 + libraries/Win32/System/Win32.hs | 55 + libraries/Win32/System/Win32/Console.hsc | 62 + libraries/Win32/System/Win32/DLL.hsc | 88 + libraries/Win32/System/Win32/DebugApi.hsc | 411 + libraries/Win32/System/Win32/File.hsc | 657 + libraries/Win32/System/Win32/FileMapping.hsc | 174 + libraries/Win32/System/Win32/Info.hsc | 396 + libraries/Win32/System/Win32/Mem.hsc | 319 + libraries/Win32/System/Win32/NLS.hsc | 383 + libraries/Win32/System/Win32/Process.hsc | 132 + libraries/Win32/System/Win32/Registry.hsc | 525 + libraries/Win32/System/Win32/Security.hsc | 237 + libraries/Win32/System/Win32/Shell.hsc | 89 + libraries/Win32/System/Win32/SimpleMAPI.hsc | 417 + libraries/Win32/System/Win32/Time.hsc | 311 + libraries/Win32/System/Win32/Types.hs | 328 + libraries/Win32/Win32.cabal | 81 + libraries/Win32/cbits/HsGDI.c | 3 + libraries/Win32/cbits/HsWin32.c | 19 + libraries/Win32/cbits/WndProc.c | 90 + libraries/Win32/cbits/diatemp.c | 224 + libraries/Win32/cbits/dumpBMP.c | 201 + libraries/Win32/cbits/ellipse.c | 51 + libraries/Win32/cbits/errors.c | 33 + libraries/Win32/doc/HSWin32.xml | 190 + libraries/Win32/doc/Makefile | 6 + libraries/Win32/examples/Makefile | 31 + libraries/Win32/examples/hello.lhs | 121 + libraries/Win32/ghc.mk | 5 + libraries/Win32/include/HsGDI.h | 47 + libraries/Win32/include/HsWin32.h | 47 + libraries/Win32/include/Win32Aux.h | 3 + libraries/Win32/include/WndProc.h | 9 + libraries/Win32/include/diatemp.h | 30 + libraries/Win32/include/dumpBMP.h | 6 + libraries/Win32/include/ellipse.h | 8 + libraries/Win32/include/errors.h | 16 + libraries/Win32/include/win32debug.h | 9 + libraries/Win32/include/windows_cconv.h | 13 + libraries/Win32/prologue.txt | 1 + libraries/Win32/tests/Makefile | 7 + libraries/Win32/tests/T4452.hs | 13 + libraries/Win32/tests/all.T | 8 + libraries/Win32/tests/helloworld.hs | 104 + libraries/Win32/tests/lasterror.hs | 19 + libraries/Win32/tests/registry001.hs | 16 + libraries/Win32/tests/registry001.stdout | 1 + libraries/array/.gitignore | 5 + libraries/array/.travis.yml | 35 + libraries/array/Data/Array.hs | 73 + libraries/array/Data/Array/Base.hs | 1604 + libraries/array/Data/Array/IArray.hs | 52 + libraries/array/Data/Array/IO.hs | 103 + libraries/array/Data/Array/IO/Internals.hs | 427 + libraries/array/Data/Array/IO/Safe.hs | 36 + libraries/array/Data/Array/MArray.hs | 53 + libraries/array/Data/Array/MArray/Safe.hs | 56 + libraries/array/Data/Array/ST.hs | 72 + libraries/array/Data/Array/ST/Safe.hs | 34 + libraries/array/Data/Array/Storable.hs | 40 + .../array/Data/Array/Storable/Internals.hs | 85 + libraries/array/Data/Array/Storable/Safe.hs | 45 + libraries/array/Data/Array/Unboxed.hs | 26 + libraries/array/Data/Array/Unsafe.hs | 33 + libraries/array/GNUmakefile | 4 + libraries/array/LICENSE | 83 + libraries/array/README.md | 4 + libraries/array/Setup.hs | 6 + libraries/array/array.cabal | 57 + libraries/array/changelog.md | 31 + libraries/array/ghc.mk | 5 + libraries/array/prologue.txt | 1 + libraries/array/tests/.gitignore | 15 + libraries/array/tests/Makefile | 7 + libraries/array/tests/T2120.hs | 16 + libraries/array/tests/T2120.stdout | 2 + libraries/array/tests/T9220.script | 4 + libraries/array/tests/T9220.stdout | 42 + libraries/array/tests/all.T | 6 + libraries/array/tests/array001.hs | 34 + libraries/array/tests/array001.stdout | 2 + libraries/array/tests/largeArray.hs | 13 + libraries/array/tests/largeArray.stdout | 1 + libraries/base/.authorspellings | 12 + libraries/base/.gitignore | 22 + libraries/base/Control/Applicative.hs | 136 + libraries/base/Control/Arrow.hs | 372 + libraries/base/Control/Category.hs | 64 + libraries/base/Control/Concurrent.hs | 661 + libraries/base/Control/Concurrent/Chan.hs | 162 + libraries/base/Control/Concurrent/MVar.hs | 274 + libraries/base/Control/Concurrent/QSem.hs | 130 + libraries/base/Control/Concurrent/QSemN.hs | 124 + libraries/base/Control/Exception.hs | 391 + libraries/base/Control/Exception/Base.hs | 407 + libraries/base/Control/Monad.hs | 249 + libraries/base/Control/Monad/Fix.hs | 83 + libraries/base/Control/Monad/Instances.hs | 19 + libraries/base/Control/Monad/ST.hs | 35 + libraries/base/Control/Monad/ST/Imp.hs | 38 + libraries/base/Control/Monad/ST/Lazy.hs | 34 + libraries/base/Control/Monad/ST/Lazy/Imp.hs | 151 + libraries/base/Control/Monad/ST/Lazy/Safe.hs | 36 + .../base/Control/Monad/ST/Lazy/Unsafe.hs | 28 + libraries/base/Control/Monad/ST/Safe.hs | 33 + libraries/base/Control/Monad/ST/Strict.hs | 22 + libraries/base/Control/Monad/ST/Unsafe.hs | 29 + libraries/base/Control/Monad/Zip.hs | 55 + libraries/base/Data/Bifunctor.hs | 101 + libraries/base/Data/Bits.hs | 667 + libraries/base/Data/Bool.hs | 61 + libraries/base/Data/Char.hs | 497 + libraries/base/Data/Coerce.hs | 30 + libraries/base/Data/Complex.hs | 188 + libraries/base/Data/Data.hs | 1400 + libraries/base/Data/Dynamic.hs | 145 + libraries/base/Data/Either.hs | 297 + libraries/base/Data/Eq.hs | 22 + libraries/base/Data/Fixed.hs | 209 + libraries/base/Data/Foldable.hs | 477 + libraries/base/Data/Function.hs | 100 + libraries/base/Data/Functor.hs | 143 + libraries/base/Data/Functor/Identity.hs | 104 + libraries/base/Data/IORef.hs | 162 + libraries/base/Data/Int.hs | 55 + libraries/base/Data/Ix.hs | 64 + libraries/base/Data/List.hs | 241 + libraries/base/Data/Maybe.hs | 300 + libraries/base/Data/Monoid.hs | 209 + libraries/base/Data/OldList.hs | 1179 + libraries/base/Data/Ord.hs | 52 + libraries/base/Data/Proxy.hs | 104 + libraries/base/Data/Ratio.hs | 73 + libraries/base/Data/STRef.hs | 54 + libraries/base/Data/STRef/Lazy.hs | 38 + libraries/base/Data/STRef/Strict.hs | 22 + libraries/base/Data/String.hs | 39 + libraries/base/Data/Traversable.hs | 284 + libraries/base/Data/Tuple.hs | 51 + libraries/base/Data/Type/Bool.hs | 55 + libraries/base/Data/Type/Coercion.hs | 101 + libraries/base/Data/Type/Equality.hs | 282 + libraries/base/Data/Typeable.hs | 130 + libraries/base/Data/Typeable/Internal.hs | 350 + libraries/base/Data/Unique.hs | 72 + libraries/base/Data/Version.hs | 131 + libraries/base/Data/Void.hs | 74 + libraries/base/Data/Word.hs | 60 + libraries/base/Debug/Trace.hs | 289 + libraries/base/Foreign.hs | 38 + libraries/base/Foreign/C.hs | 27 + libraries/base/Foreign/C/Error.hs | 575 + libraries/base/Foreign/C/String.hs | 459 + libraries/base/Foreign/C/Types.hs | 259 + libraries/base/Foreign/Concurrent.hs | 51 + libraries/base/Foreign/ForeignPtr.hs | 47 + libraries/base/Foreign/ForeignPtr/Imp.hs | 120 + libraries/base/Foreign/ForeignPtr/Safe.hs | 49 + libraries/base/Foreign/ForeignPtr/Unsafe.hs | 28 + libraries/base/Foreign/Marshal.hs | 34 + libraries/base/Foreign/Marshal/Alloc.hs | 226 + libraries/base/Foreign/Marshal/Array.hs | 281 + libraries/base/Foreign/Marshal/Error.hs | 82 + libraries/base/Foreign/Marshal/Pool.hs | 198 + libraries/base/Foreign/Marshal/Safe.hs | 36 + libraries/base/Foreign/Marshal/Unsafe.hs | 45 + libraries/base/Foreign/Marshal/Utils.hs | 187 + libraries/base/Foreign/Ptr.hs | 100 + libraries/base/Foreign/Safe.hs | 40 + libraries/base/Foreign/StablePtr.hs | 47 + libraries/base/Foreign/Storable.hs | 254 + libraries/base/GHC/Arr.hs | 899 + libraries/base/GHC/Base.hs | 1199 + libraries/base/GHC/Char.hs | 15 + libraries/base/GHC/Conc.hs | 119 + libraries/base/GHC/Conc/IO.hs | 203 + libraries/base/GHC/Conc/Signal.hs | 99 + libraries/base/GHC/Conc/Sync.hs | 897 + libraries/base/GHC/Conc/Windows.hs | 339 + libraries/base/GHC/ConsoleHandler.hs | 162 + libraries/base/GHC/Constants.hs | 10 + libraries/base/GHC/Desugar.hs | 41 + libraries/base/GHC/Enum.hs | 731 + libraries/base/GHC/Environment.hs | 62 + libraries/base/GHC/Err.hs | 47 + libraries/base/GHC/Event.hs | 46 + libraries/base/GHC/Event/Arr.hs | 32 + libraries/base/GHC/Event/Array.hs | 312 + libraries/base/GHC/Event/Clock.hsc | 17 + libraries/base/GHC/Event/Control.hs | 210 + libraries/base/GHC/Event/EPoll.hsc | 239 + libraries/base/GHC/Event/IntTable.hs | 145 + libraries/base/GHC/Event/Internal.hs | 209 + libraries/base/GHC/Event/KQueue.hsc | 294 + libraries/base/GHC/Event/Manager.hs | 515 + libraries/base/GHC/Event/PSQ.hs | 484 + libraries/base/GHC/Event/Poll.hsc | 211 + libraries/base/GHC/Event/Thread.hs | 362 + libraries/base/GHC/Event/TimerManager.hs | 243 + libraries/base/GHC/Event/Unique.hs | 43 + libraries/base/GHC/Exception.hs | 197 + libraries/base/GHC/Exception.hs-boot | 34 + libraries/base/GHC/Exts.hs | 186 + libraries/base/GHC/Fingerprint.hs | 114 + libraries/base/GHC/Fingerprint.hs-boot | 14 + libraries/base/GHC/Fingerprint/Type.hs | 33 + libraries/base/GHC/Float.hs | 1153 + libraries/base/GHC/Float/ConversionUtils.hs | 100 + libraries/base/GHC/Float/RealFracMethods.hs | 342 + libraries/base/GHC/Foreign.hs | 255 + libraries/base/GHC/ForeignPtr.hs | 444 + libraries/base/GHC/GHCi.hs | 50 + libraries/base/GHC/Generics.hs | 819 + libraries/base/GHC/IO.hs | 490 + libraries/base/GHC/IO.hs-boot | 9 + libraries/base/GHC/IO/Buffer.hs | 291 + libraries/base/GHC/IO/BufferedIO.hs | 126 + libraries/base/GHC/IO/Device.hs | 170 + libraries/base/GHC/IO/Encoding.hs | 288 + libraries/base/GHC/IO/Encoding.hs-boot | 10 + libraries/base/GHC/IO/Encoding/CodePage.hs | 184 + .../base/GHC/IO/Encoding/CodePage/API.hs | 428 + .../base/GHC/IO/Encoding/CodePage/Table.hs | 432 + libraries/base/GHC/IO/Encoding/Failure.hs | 202 + libraries/base/GHC/IO/Encoding/Iconv.hs | 201 + libraries/base/GHC/IO/Encoding/Latin1.hs | 230 + libraries/base/GHC/IO/Encoding/Types.hs | 132 + libraries/base/GHC/IO/Encoding/UTF16.hs | 359 + libraries/base/GHC/IO/Encoding/UTF32.hs | 336 + libraries/base/GHC/IO/Encoding/UTF8.hs | 362 + libraries/base/GHC/IO/Exception.hs | 394 + libraries/base/GHC/IO/Exception.hs-boot | 15 + libraries/base/GHC/IO/FD.hs | 677 + libraries/base/GHC/IO/Handle.hs | 743 + libraries/base/GHC/IO/Handle.hs-boot | 10 + libraries/base/GHC/IO/Handle/FD.hs | 291 + libraries/base/GHC/IO/Handle/FD.hs-boot | 10 + libraries/base/GHC/IO/Handle/Internals.hs | 941 + libraries/base/GHC/IO/Handle/Text.hs | 1006 + libraries/base/GHC/IO/Handle/Types.hs | 430 + libraries/base/GHC/IO/IOMode.hs | 30 + libraries/base/GHC/IOArray.hs | 77 + libraries/base/GHC/IORef.hs | 54 + libraries/base/GHC/IP.hs | 17 + libraries/base/GHC/Int.hs | 1021 + libraries/base/GHC/List.hs | 1014 + libraries/base/GHC/MVar.hs | 182 + libraries/base/GHC/Natural.hs | 644 + libraries/base/GHC/Num.hs | 99 + libraries/base/GHC/OldList.hs | 29 + libraries/base/GHC/PArr.hs | 37 + libraries/base/GHC/Pack.hs | 101 + libraries/base/GHC/Profiling.hs | 10 + libraries/base/GHC/Ptr.hs | 174 + libraries/base/GHC/RTS/Flags.hsc | 457 + libraries/base/GHC/Read.hs | 650 + libraries/base/GHC/Real.hs | 664 + libraries/base/GHC/ST.hs | 165 + libraries/base/GHC/STRef.hs | 49 + libraries/base/GHC/Show.hs | 507 + libraries/base/GHC/SrcLoc.hs | 33 + libraries/base/GHC/Stable.hs | 111 + libraries/base/GHC/Stack.hsc | 185 + libraries/base/GHC/StaticPtr.hs | 117 + libraries/base/GHC/Stats.hsc | 154 + libraries/base/GHC/Storable.hs | 158 + libraries/base/GHC/TopHandler.hs | 254 + libraries/base/GHC/TypeLits.hs | 241 + libraries/base/GHC/Unicode.hs | 184 + libraries/base/GHC/Weak.hs | 157 + libraries/base/GHC/Windows.hs | 196 + libraries/base/GHC/Word.hs | 804 + libraries/base/GNUmakefile | 4 + libraries/base/LICENSE | 83 + libraries/base/Numeric.hs | 231 + libraries/base/Numeric/Natural.hs | 24 + libraries/base/Prelude.hs | 172 + libraries/base/Setup.hs | 6 + libraries/base/System/CPUTime.hsc | 161 + libraries/base/System/Console/GetOpt.hs | 407 + libraries/base/System/Environment.hs | 449 + .../System/Environment/ExecutablePath.hsc | 175 + libraries/base/System/Exit.hs | 82 + libraries/base/System/IO.hs | 596 + libraries/base/System/IO/Error.hs | 337 + libraries/base/System/IO/Unsafe.hs | 50 + libraries/base/System/Info.hs | 51 + libraries/base/System/Mem.hs | 35 + libraries/base/System/Mem/StableName.hs | 126 + libraries/base/System/Mem/Weak.hs | 142 + libraries/base/System/Posix/Internals.hs | 565 + libraries/base/System/Posix/Types.hs | 178 + libraries/base/System/Timeout.hs | 122 + .../base/Text/ParserCombinators/ReadP.hs | 510 + .../base/Text/ParserCombinators/ReadPrec.hs | 169 + libraries/base/Text/Printf.hs | 898 + libraries/base/Text/Read.hs | 90 + libraries/base/Text/Read/Lex.hs | 558 + libraries/base/Text/Show.hs | 34 + libraries/base/Text/Show/Functions.hs | 26 + libraries/base/Unsafe/Coerce.hs | 62 + libraries/base/aclocal.m4 | 229 + libraries/base/base.buildinfo.in | 4 + libraries/base/base.cabal | 357 + libraries/base/cbits/DarwinUtils.c | 22 + libraries/base/cbits/PrelIOUtils.c | 45 + libraries/base/cbits/README.Unicode | 8 + libraries/base/cbits/SetEnv.c | 11 + libraries/base/cbits/WCsubst.c | 4748 ++ libraries/base/cbits/Win32Utils.c | 151 + libraries/base/cbits/consUtils.c | 111 + libraries/base/cbits/iconv.c | 25 + libraries/base/cbits/inputReady.c | 172 + libraries/base/cbits/md5.c | 238 + libraries/base/cbits/primFloat.c | 532 + libraries/base/cbits/rts.c | 42 + libraries/base/cbits/sysconf.c | 19 + libraries/base/cbits/ubconfc | 345 + libraries/base/changelog.md | 333 + libraries/base/codepages/MakeTable.hs | 265 + libraries/base/codepages/Makefile | 19 + libraries/base/config.guess | 1420 + libraries/base/config.sub | 1794 + libraries/base/configure | 21877 +++++++++ libraries/base/configure.ac | 213 + libraries/base/ghc.mk | 5 + libraries/base/include/CTypes.h | 54 + libraries/base/include/EventConfig.h.in | 91 + libraries/base/include/HsBase.h | 559 + libraries/base/include/HsBaseConfig.h.in | 624 + libraries/base/include/HsEvent.h | 41 + libraries/base/include/Typeable.h | 31 + libraries/base/include/WCsubst.h | 25 + libraries/base/include/consUtils.h | 13 + libraries/base/include/ieee-flpt.h | 35 + libraries/base/include/md5.h | 24 + libraries/base/install-sh | 527 + libraries/base/prologue.txt | 3 + libraries/base/tests/.gitignore | 275 + libraries/base/tests/CPUTime001.hs | 26 + libraries/base/tests/CPUTime001.stdout | 4 + libraries/base/tests/CatEntail.hs | 27 + libraries/base/tests/CatPairs.hs | 34 + libraries/base/tests/Concurrent/4876.stdout | 1 + libraries/base/tests/Concurrent/Chan001.hs | 109 + .../base/tests/Concurrent/Chan001.stdout | 3 + libraries/base/tests/Concurrent/Chan002.hs | 19 + .../base/tests/Concurrent/Chan002.stdout | 1 + libraries/base/tests/Concurrent/Chan003.hs | 17 + .../base/tests/Concurrent/Chan003.stdout | 1 + libraries/base/tests/Concurrent/MVar001.hs | 148 + .../base/tests/Concurrent/MVar001.stdout | 6 + libraries/base/tests/Concurrent/Makefile | 7 + .../base/tests/Concurrent/ThreadDelay001.hs | 27 + libraries/base/tests/Concurrent/all.T | 9 + libraries/base/tests/IO/IOError001.hs | 9 + libraries/base/tests/IO/IOError001.stdout | 2 + .../base/tests/IO/IOError001.stdout-hugs | 2 + libraries/base/tests/IO/IOError002.hs | 5 + libraries/base/tests/IO/IOError002.stdout | 1 + libraries/base/tests/IO/Makefile | 52 + libraries/base/tests/IO/T2122.hs | 77 + libraries/base/tests/IO/T3307.hs | 52 + libraries/base/tests/IO/T3307.stdout | 12 + libraries/base/tests/IO/T4144.hs | 115 + libraries/base/tests/IO/T4144.stdout | 1 + libraries/base/tests/IO/T4808.hs | 13 + libraries/base/tests/IO/T4808.stderr | 1 + libraries/base/tests/IO/T4808.stdout | 1 + libraries/base/tests/IO/T4855.hs | 3 + libraries/base/tests/IO/T4855.stderr | 1 + libraries/base/tests/IO/T4895.hs | 9 + libraries/base/tests/IO/T4895.stdout | 1 + libraries/base/tests/IO/T7853.hs | 28 + libraries/base/tests/IO/T7853.stdout | 11 + libraries/base/tests/IO/all.T | 166 + libraries/base/tests/IO/concio001.hs | 6 + libraries/base/tests/IO/concio001.stdout | 2 + libraries/base/tests/IO/concio001.thr.stdout | 2 + libraries/base/tests/IO/concio002.hs | 14 + libraries/base/tests/IO/concio002.stdout | 4 + libraries/base/tests/IO/countReaders001.hs | 17 + .../base/tests/IO/countReaders001.stdout | 1 + libraries/base/tests/IO/decodingerror001.hs | 22 + libraries/base/tests/IO/decodingerror001.in1 | 1 + libraries/base/tests/IO/decodingerror001.in2 | 1 + .../base/tests/IO/decodingerror001.stdout | 10 + libraries/base/tests/IO/decodingerror002.hs | 23 + libraries/base/tests/IO/decodingerror002.in | 1 + .../base/tests/IO/decodingerror002.stdout | 4 + .../tests/IO/encoded-data/CP1251-UTF8.txt | 34 + .../base/tests/IO/encoded-data/CP1251.txt | 34 + .../base/tests/IO/encoded-data/CP936-UTF8.txt | 153 + .../base/tests/IO/encoded-data/CP936.txt | 153 + libraries/base/tests/IO/encoding001.hs | 71 + libraries/base/tests/IO/encoding002.hs | 65 + libraries/base/tests/IO/encoding002.stdout | 61 + libraries/base/tests/IO/encoding003.hs | 23 + libraries/base/tests/IO/encoding003.stdout | 1 + libraries/base/tests/IO/encoding004.hs | 107 + libraries/base/tests/IO/encoding004.stdout | 3 + libraries/base/tests/IO/encoding005.hs | 115 + libraries/base/tests/IO/encoding005.stdout | 5 + libraries/base/tests/IO/encodingerror001.hs | 27 + .../base/tests/IO/encodingerror001.stdout | 36 + libraries/base/tests/IO/environment001.hs | 16 + libraries/base/tests/IO/environment001.stdout | 6 + libraries/base/tests/IO/finalization001.hs | 26 + .../base/tests/IO/finalization001.stdout | 200 + libraries/base/tests/IO/hClose001.hs | 8 + libraries/base/tests/IO/hClose001.stdout | 1 + libraries/base/tests/IO/hClose002.hs | 32 + libraries/base/tests/IO/hClose002.stdout | 4 + .../IO/hClose002.stdout-i386-unknown-solaris2 | 4 + .../hClose002.stdout-x86_64-unknown-solaris2 | 4 + libraries/base/tests/IO/hClose003.hs | 42 + libraries/base/tests/IO/hClose003.stdout | 4 + libraries/base/tests/IO/hDuplicateTo001.hs | 25 + .../base/tests/IO/hDuplicateTo001.stderr | 2 + libraries/base/tests/IO/hFileSize001.hs | 8 + libraries/base/tests/IO/hFileSize001.stdout | 1 + libraries/base/tests/IO/hFileSize002.hs | 36 + libraries/base/tests/IO/hFileSize002.stdout | 5 + libraries/base/tests/IO/hFlush001.hs | 32 + libraries/base/tests/IO/hFlush001.stdout | 2 + libraries/base/tests/IO/hGetBuf001.hs | 218 + libraries/base/tests/IO/hGetBuf001.stdout | 117 + libraries/base/tests/IO/hGetBuffering001.hs | 21 + .../base/tests/IO/hGetBuffering001.stdout | 7 + libraries/base/tests/IO/hGetChar001.hs | 18 + libraries/base/tests/IO/hGetChar001.stdin | 2 + libraries/base/tests/IO/hGetChar001.stdout | 1 + libraries/base/tests/IO/hGetLine001.hs | 25 + libraries/base/tests/IO/hGetLine001.stdout | 100 + libraries/base/tests/IO/hGetLine002.hs | 17 + libraries/base/tests/IO/hGetLine002.stdin | 1 + libraries/base/tests/IO/hGetLine002.stdout | 2 + .../base/tests/IO/hGetLine002.stdout-hugs | 2 + libraries/base/tests/IO/hGetLine003.hs | 9 + libraries/base/tests/IO/hGetLine003.stdin | 1 + libraries/base/tests/IO/hGetLine003.stdout | 2 + libraries/base/tests/IO/hGetPosn001.hs | 28 + libraries/base/tests/IO/hGetPosn001.in | 2 + libraries/base/tests/IO/hGetPosn001.stdout | 5 + .../base/tests/IO/hGetPosn001.stdout-hugs | 5 + libraries/base/tests/IO/hIsEOF001.hs | 8 + libraries/base/tests/IO/hIsEOF001.stdout | 2 + libraries/base/tests/IO/hIsEOF002.hs | 48 + libraries/base/tests/IO/hIsEOF002.stdout | 16 + libraries/base/tests/IO/hReady001.hs | 12 + libraries/base/tests/IO/hReady001.stdout | 2 + libraries/base/tests/IO/hReady002.hs | 10 + libraries/base/tests/IO/hReady002.stdout | 1 + libraries/base/tests/IO/hSeek001.hs | 29 + libraries/base/tests/IO/hSeek001.in | 1 + libraries/base/tests/IO/hSeek001.stdout | 7 + libraries/base/tests/IO/hSeek002.hs | 25 + libraries/base/tests/IO/hSeek002.stdout | 5 + libraries/base/tests/IO/hSeek003.hs | 51 + libraries/base/tests/IO/hSeek003.stdout | 24 + libraries/base/tests/IO/hSeek004.hs | 8 + libraries/base/tests/IO/hSeek004.stdout | 1 + libraries/base/tests/IO/hSetBuffering002.hs | 6 + .../base/tests/IO/hSetBuffering002.stdout | 6 + libraries/base/tests/IO/hSetBuffering003.hs | 80 + .../base/tests/IO/hSetBuffering003.stderr | 1 + .../base/tests/IO/hSetBuffering003.stdout | 22 + libraries/base/tests/IO/hSetBuffering004.hs | 10 + .../base/tests/IO/hSetBuffering004.stdout | 2 + libraries/base/tests/IO/hSetEncoding001.hs | 49 + libraries/base/tests/IO/hSetEncoding001.in | Bin 0 -> 2076 bytes .../base/tests/IO/hSetEncoding001.stdout | 90 + libraries/base/tests/IO/hSetEncoding002.hs | 13 + .../base/tests/IO/hSetEncoding002.stdout | 1 + .../base/tests/IO/ioeGetErrorString001.hs | 13 + .../base/tests/IO/ioeGetErrorString001.stdout | 1 + libraries/base/tests/IO/ioeGetFileName001.hs | 12 + .../base/tests/IO/ioeGetFileName001.stdout | 1 + libraries/base/tests/IO/ioeGetHandle001.hs | 13 + .../base/tests/IO/ioeGetHandle001.stdout | 1 + libraries/base/tests/IO/isEOF001.hs | 3 + libraries/base/tests/IO/isEOF001.stdout | 1 + libraries/base/tests/IO/latin1 | 5 + libraries/base/tests/IO/misc001.hs | 24 + libraries/base/tests/IO/misc001.stdout | 0 libraries/base/tests/IO/newline001.hs | 121 + libraries/base/tests/IO/openFile001.hs | 11 + libraries/base/tests/IO/openFile001.stdout | 1 + libraries/base/tests/IO/openFile002.hs | 6 + libraries/base/tests/IO/openFile002.stderr | 1 + .../base/tests/IO/openFile002.stderr-hugs | 1 + libraries/base/tests/IO/openFile003.hs | 17 + libraries/base/tests/IO/openFile003.stdout | 4 + .../base/tests/IO/openFile003.stdout-mingw32 | 4 + .../tests/IO/openFile003.stdout-mips-sgi-irix | 4 + .../IO/openFile003.stdout-sparc-sun-solaris2 | 4 + libraries/base/tests/IO/openFile004.hs | 23 + libraries/base/tests/IO/openFile004.stdout | 1 + libraries/base/tests/IO/openFile005.hs | 45 + libraries/base/tests/IO/openFile005.stdout | 12 + libraries/base/tests/IO/openFile006.hs | 14 + libraries/base/tests/IO/openFile006.stdout | 2 + libraries/base/tests/IO/openFile007.hs | 18 + libraries/base/tests/IO/openFile007.stdout | 2 + libraries/base/tests/IO/openFile008.hs | 22 + libraries/base/tests/IO/openTempFile001.hs | 13 + libraries/base/tests/IO/putStr001.hs | 6 + libraries/base/tests/IO/putStr001.stdout | 1 + libraries/base/tests/IO/readFile001.hs | 26 + libraries/base/tests/IO/readFile001.stdout | 30 + libraries/base/tests/IO/readwrite001.hs | 23 + libraries/base/tests/IO/readwrite001.stdout | 3 + libraries/base/tests/IO/readwrite002.hs | 49 + libraries/base/tests/IO/readwrite002.stdout | 9 + libraries/base/tests/IO/readwrite003.hs | 12 + libraries/base/tests/IO/readwrite003.stdout | 4 + libraries/base/tests/IO/utf8-test | 3 + libraries/base/tests/Makefile | 7 + libraries/base/tests/Memo1.lhs | 141 + libraries/base/tests/Memo2.lhs | 141 + libraries/base/tests/Numeric/Makefile | 7 + libraries/base/tests/Numeric/all.T | 21 + libraries/base/tests/Numeric/num001.hs | 6 + libraries/base/tests/Numeric/num001.stdout | 1 + libraries/base/tests/Numeric/num002.hs | 20 + libraries/base/tests/Numeric/num002.stdout | 6 + .../Numeric/num002.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num002.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num002.stdout-ws-64 | 6 + .../num002.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num003.hs | 20 + libraries/base/tests/Numeric/num003.stdout | 6 + .../Numeric/num003.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num003.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num003.stdout-ws-64 | 6 + .../num003.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num004.hs | 20 + libraries/base/tests/Numeric/num004.stdout | 6 + .../Numeric/num004.stdout-alpha-dec-osf3 | 6 + .../tests/Numeric/num004.stdout-mips-sgi-irix | 6 + .../base/tests/Numeric/num004.stdout-ws-64 | 6 + .../num004.stdout-x86_64-unknown-openbsd | 6 + libraries/base/tests/Numeric/num005.hs | 23 + libraries/base/tests/Numeric/num005.stdout | 55 + .../Numeric/num005.stdout-alpha-dec-osf3 | 55 + .../tests/Numeric/num005.stdout-mips-sgi-irix | 55 + .../base/tests/Numeric/num005.stdout-ws-64 | 55 + .../num005.stdout-x86_64-unknown-openbsd | 55 + libraries/base/tests/Numeric/num006.hs | 28 + libraries/base/tests/Numeric/num006.stdout | 6 + libraries/base/tests/Numeric/num007.hs | 17 + libraries/base/tests/Numeric/num007.stdout | 9 + libraries/base/tests/Numeric/num008.hs | 57 + libraries/base/tests/Numeric/num008.stdout | 148 + libraries/base/tests/Numeric/num009.hs | 37 + libraries/base/tests/Numeric/num009.stdout | 1 + .../num009.stdout-i386-unknown-mingw32 | 16 + libraries/base/tests/Numeric/num010.hs | 29 + libraries/base/tests/Numeric/num010.stdout | 189 + libraries/base/tests/System/Makefile | 7 + libraries/base/tests/System/T5930.hs | 10 + libraries/base/tests/System/T5930.stdout | 2 + libraries/base/tests/System/Timeout001.hs | 10 + libraries/base/tests/System/all.T | 9 + libraries/base/tests/System/exitWith001.hs | 3 + .../base/tests/System/exitWith001.stdout | 0 libraries/base/tests/System/getArgs001.hs | 8 + libraries/base/tests/System/getArgs001.stdout | 1 + libraries/base/tests/System/getEnv001.hs | 15 + libraries/base/tests/System/getEnv001.stdout | 2 + libraries/base/tests/System/system001.hs | 18 + libraries/base/tests/System/system001.stdout | 18 + libraries/base/tests/T10149.hs | 19 + libraries/base/tests/T10149.stdout | 4 + libraries/base/tests/T2528.hs | 27 + libraries/base/tests/T2528.stdout | 4 + libraries/base/tests/T4006.hs | 8 + libraries/base/tests/T4006.stdout | 2 + libraries/base/tests/T5943.hs | 36 + libraries/base/tests/T5943.stdout | 7 + libraries/base/tests/T5962.hs | 8 + libraries/base/tests/T5962.stdout | 1 + libraries/base/tests/T7034.hs | 11 + libraries/base/tests/T7034.stdout | 6 + libraries/base/tests/T7457.hs | 2 + libraries/base/tests/T7457.stdout | 1 + libraries/base/tests/T7653.hs | 7 + libraries/base/tests/T7773.hs | 9 + libraries/base/tests/T7773.stdout | 2 + libraries/base/tests/T7787.hs | 8 + libraries/base/tests/T7787.stdout | 1 + libraries/base/tests/T8089.hs | 32 + libraries/base/tests/T8766.hs | 4 + libraries/base/tests/T8766.stdout | 1 + libraries/base/tests/T9111.hs | 10 + libraries/base/tests/T9395.hs | 2 + libraries/base/tests/T9395.stderr | 2 + libraries/base/tests/T9532.hs | 89 + libraries/base/tests/T9532.stdout | 1 + libraries/base/tests/T9586.hs | 8 + libraries/base/tests/T9681.hs | 3 + libraries/base/tests/T9681.stderr | 5 + libraries/base/tests/T9826.hs | 24 + libraries/base/tests/T9826.stdout | 1 + libraries/base/tests/Text.Printf/Makefile | 7 + libraries/base/tests/Text.Printf/T1548.hs | 11 + libraries/base/tests/Text.Printf/T1548.stdout | 3 + libraries/base/tests/Text.Printf/all.T | 1 + libraries/base/tests/addr001.hs | 10 + libraries/base/tests/addr001.stdout | 2 + .../base/tests/addr001.stdout-alpha-dec-osf3 | 2 + .../base/tests/addr001.stdout-mips-sgi-irix | 2 + libraries/base/tests/addr001.stdout-ws-64 | 2 + .../addr001.stdout-x86_64-unknown-openbsd | 2 + libraries/base/tests/all.T | 183 + libraries/base/tests/assert.hs | 9 + libraries/base/tests/assert.stderr | 2 + libraries/base/tests/char001.hs | 43 + libraries/base/tests/char001.stdout | 18 + libraries/base/tests/char002.hs | 7 + libraries/base/tests/char002.stdout | 4 + libraries/base/tests/cstring001.hs | 18 + libraries/base/tests/data-fixed-show-read.hs | 29 + .../base/tests/data-fixed-show-read.stdout | 20 + libraries/base/tests/dynamic001.hs | 107 + libraries/base/tests/dynamic001.stdout | 42 + libraries/base/tests/dynamic002.hs | 91 + libraries/base/tests/dynamic002.stdout | 64 + libraries/base/tests/dynamic003.hs | 12 + libraries/base/tests/dynamic003.stdout | 1 + libraries/base/tests/dynamic004.hs | 36 + libraries/base/tests/dynamic004.stdout | 1 + libraries/base/tests/dynamic005.hs | 14 + libraries/base/tests/dynamic005.stdout | 1 + libraries/base/tests/echo001.hs | 13 + libraries/base/tests/echo001.stdout | 14 + libraries/base/tests/enum01.hs | 529 + libraries/base/tests/enum01.stdout | 246 + .../base/tests/enum01.stdout-alpha-dec-osf3 | 230 + libraries/base/tests/enum01.stdout-hugs | 246 + libraries/base/tests/enum01.stdout-ws-64 | 246 + libraries/base/tests/enum02.hs | 266 + libraries/base/tests/enum02.stdout | 141 + .../base/tests/enum02.stdout-alpha-dec-osf3 | 141 + libraries/base/tests/enum02.stdout-hugs | 141 + .../base/tests/enum02.stdout-mips-sgi-irix | 141 + libraries/base/tests/enum02.stdout-ws-64 | 141 + .../enum02.stdout-x86_64-unknown-openbsd | 141 + libraries/base/tests/enum03.hs | 269 + libraries/base/tests/enum03.stdout | 142 + .../base/tests/enum03.stdout-alpha-dec-osf3 | 142 + libraries/base/tests/enum03.stdout-hugs | 142 + .../base/tests/enum03.stdout-mips-sgi-irix | 142 + libraries/base/tests/enum03.stdout-ws-64 | 142 + .../enum03.stdout-x86_64-unknown-openbsd | 142 + libraries/base/tests/enum04.hs | 14 + libraries/base/tests/enum04.stdout | 4 + libraries/base/tests/enumDouble.hs | 3 + libraries/base/tests/enumDouble.stdout | 1 + libraries/base/tests/enumRatio.hs | 3 + libraries/base/tests/enumRatio.stdout | 1 + libraries/base/tests/enum_processor.py | 28 + libraries/base/tests/exceptionsrun001.hs | 46 + libraries/base/tests/exceptionsrun001.stdout | 5 + libraries/base/tests/exceptionsrun002.hs | 95 + libraries/base/tests/exceptionsrun002.stdout | 40 + libraries/base/tests/fixed.hs | 19 + libraries/base/tests/fixed.stdout | 72 + libraries/base/tests/foldableArray.hs | 129 + libraries/base/tests/foldableArray.stdout | 13 + libraries/base/tests/genericNegative001.hs | 8 + .../base/tests/genericNegative001.stdout | 3 + libraries/base/tests/hGetBuf002.hs | 22 + libraries/base/tests/hGetBuf002.stdout | 44 + libraries/base/tests/hGetBuf003.hs | 26 + libraries/base/tests/hGetBuf003.stdout | 52 + libraries/base/tests/hPutBuf001.hs | 7 + libraries/base/tests/hPutBuf001.stdout | 1 + libraries/base/tests/hPutBuf002.hs | 9 + libraries/base/tests/hPutBuf002.stdout | 1 + libraries/base/tests/hTell001.hs | 63 + libraries/base/tests/hTell001.stdout | 38 + libraries/base/tests/hTell002.hs | 33 + libraries/base/tests/hTell002.stdout | Bin 0 -> 51 bytes libraries/base/tests/inits.hs | 28 + libraries/base/tests/ioref001.hs | 9 + libraries/base/tests/ioref001.stdout | 1 + libraries/base/tests/isSuffixOf.hs | 10 + libraries/base/tests/isSuffixOf.stdout | 84 + libraries/base/tests/ix001.hs | 4 + libraries/base/tests/ix001.stdout | 1 + libraries/base/tests/length001.hs | 8 + libraries/base/tests/length001.stdout | 2 + libraries/base/tests/lex001.hs | 39 + libraries/base/tests/lex001.stdout | 84 + libraries/base/tests/list001.hs | 152 + libraries/base/tests/list001.stdout | 54 + libraries/base/tests/list001.stdout-ghc | 54 + libraries/base/tests/list002.hs | 6 + libraries/base/tests/list002.stdout | 1 + libraries/base/tests/list003.hs | 7 + libraries/base/tests/list003.stdout | 1 + libraries/base/tests/memo001.hs | 19 + libraries/base/tests/memo001.stdout | 1 + libraries/base/tests/memo002.hs | 30 + libraries/base/tests/memo002.stdout | 44 + libraries/base/tests/packedstring001.hs | 11 + libraries/base/tests/packedstring001.stdout | 1 + libraries/base/tests/performGC001.hs | 5 + libraries/base/tests/performGC001.stdout | 0 libraries/base/tests/qsem001.hs | 87 + libraries/base/tests/qsem001.stdout | 5 + libraries/base/tests/qsemn001.hs | 109 + libraries/base/tests/qsemn001.stdout | 5 + libraries/base/tests/quotOverflow.hs | 33 + libraries/base/tests/quotOverflow.stdout | 45 + libraries/base/tests/rand001.hs | 22 + libraries/base/tests/rand001.stdout | 5 + libraries/base/tests/ratio001.hs | 4 + libraries/base/tests/ratio001.stdout | 1 + libraries/base/tests/ratio001.stdout-ghc | 1 + libraries/base/tests/readDouble001.hs | 11 + libraries/base/tests/readDouble001.stdout | 6 + libraries/base/tests/readFixed001.hs | 13 + libraries/base/tests/readFixed001.stdout | 6 + libraries/base/tests/readFloat.hs | 5 + libraries/base/tests/readFloat.stderr | 1 + libraries/base/tests/readInteger001.hs | 7 + libraries/base/tests/readInteger001.stdout | 2 + libraries/base/tests/readLitChar.hs | 12 + libraries/base/tests/readLitChar.stdout | 4 + libraries/base/tests/reads001.hs | 10 + libraries/base/tests/reads001.stdout | 4 + libraries/base/tests/show001.hs | 24 + libraries/base/tests/show001.stdout | 15 + libraries/base/tests/showDouble.hs | 41 + libraries/base/tests/showDouble.stdout | 22 + libraries/base/tests/stableptr001.hs | 19 + libraries/base/tests/stableptr001.stdout | 1 + libraries/base/tests/stableptr003.hs | 16 + libraries/base/tests/stableptr004.hs | 12 + libraries/base/tests/stableptr004.stdout | 2 + libraries/base/tests/stableptr005.hs | 22 + libraries/base/tests/stableptr005.stdout | 1 + libraries/base/tests/take001.hs | 5 + libraries/base/tests/take001.stdout | 1 + libraries/base/tests/tempfiles.hs | 36 + libraries/base/tests/tempfiles.stdout | 12 + libraries/base/tests/text001.hs | 15 + libraries/base/tests/text001.stdout | 1 + libraries/base/tests/topHandler01.hs | 16 + libraries/base/tests/topHandler01.stdout | 1 + libraries/base/tests/topHandler02.hs | 7 + libraries/base/tests/topHandler03.hs | 8 + libraries/base/tests/trace001.hs | 10 + libraries/base/tests/trace001.stderr | 14 + libraries/base/tests/trace001.stdout | 1 + libraries/base/tests/tup001.hs | 33 + libraries/base/tests/tup001.stdout | 7 + libraries/base/tests/unicode001.hs | 46 + libraries/base/tests/unicode001.stdout | 14 + libraries/base/tests/unicode001.stdout-hugs | 14 + libraries/base/tests/unicode002.hs | 44 + libraries/base/tests/unicode002.stdout | 6555 +++ libraries/base/tests/weak001.hs | 12 + libraries/bin-package-db/GHC/PackageDb.hs | 426 + libraries/bin-package-db/GNUmakefile | 4 + libraries/bin-package-db/LICENSE | 31 + libraries/bin-package-db/bin-package-db.cabal | 44 + libraries/bin-package-db/ghc.mk | 5 + libraries/binary/.gitignore | 17 + libraries/binary/.hgignore | 7 + libraries/binary/.travis.yml | 42 + libraries/binary/GNUmakefile | 4 + libraries/binary/LICENSE | 30 + libraries/binary/README.md | 93 + libraries/binary/Setup.lhs | 3 + libraries/binary/benchmarks/Benchmark.hs | 1464 + libraries/binary/benchmarks/Builder.hs | 199 + libraries/binary/benchmarks/CBenchmark.c | 39 + libraries/binary/benchmarks/CBenchmark.h | 4 + libraries/binary/benchmarks/Get.hs | 319 + libraries/binary/benchmarks/MemBench.hs | 85 + libraries/binary/binary.cabal | 137 + libraries/binary/changelog.md | 97 + libraries/binary/docs/hcar/binary-Lb.tex | 48 + libraries/binary/ghc.mk | 5 + libraries/binary/src/Data/Binary.hs | 248 + libraries/binary/src/Data/Binary/Builder.hs | 57 + .../binary/src/Data/Binary/Builder/Base.hs | 512 + .../src/Data/Binary/Builder/Internal.hs | 28 + libraries/binary/src/Data/Binary/Class.hs | 585 + libraries/binary/src/Data/Binary/Generic.hs | 128 + libraries/binary/src/Data/Binary/Get.hs | 561 + .../binary/src/Data/Binary/Get/Internal.hs | 418 + libraries/binary/src/Data/Binary/Put.hs | 216 + libraries/binary/tests/Action.hs | 405 + libraries/binary/tests/Arbitrary.hs | 55 + libraries/binary/tests/File.hs | 39 + libraries/binary/tests/QC.hs | 514 + libraries/binary/tools/derive/BinaryDerive.hs | 57 + libraries/binary/tools/derive/Example.hs | 72 + libraries/bytestring/.darcs-boring | 5 + libraries/bytestring/.gitignore | 9 + libraries/bytestring/.hgignore | 2 + libraries/bytestring/.travis.yml | 46 + libraries/bytestring/Changelog.md | 18 + libraries/bytestring/Data/ByteString.hs | 1903 + .../bytestring/Data/ByteString/Builder.hs | 453 + .../Data/ByteString/Builder/ASCII.hs | 390 + .../Data/ByteString/Builder/Extra.hs | 212 + .../Data/ByteString/Builder/Internal.hs | 1140 + .../Data/ByteString/Builder/Prim.hs | 741 + .../Data/ByteString/Builder/Prim/ASCII.hs | 291 + .../Data/ByteString/Builder/Prim/Binary.hs | 339 + .../Data/ByteString/Builder/Prim/Internal.hs | 280 + .../Builder/Prim/Internal/Base16.hs | 80 + .../Builder/Prim/Internal/Floating.hs | 59 + .../Builder/Prim/Internal/UncheckedShifts.hs | 114 + libraries/bytestring/Data/ByteString/Char8.hs | 1013 + .../bytestring/Data/ByteString/Internal.hs | 691 + libraries/bytestring/Data/ByteString/Lazy.hs | 1332 + .../Data/ByteString/Lazy/Builder.hs | 11 + .../Data/ByteString/Lazy/Builder/ASCII.hs | 24 + .../Data/ByteString/Lazy/Builder/Extras.hs | 11 + .../bytestring/Data/ByteString/Lazy/Char8.hs | 875 + .../Data/ByteString/Lazy/Internal.hs | 260 + libraries/bytestring/Data/ByteString/Short.hs | 85 + .../Data/ByteString/Short/Internal.hs | 593 + .../bytestring/Data/ByteString/Unsafe.hs | 304 + libraries/bytestring/GNUmakefile | 4 + libraries/bytestring/LICENSE | 30 + libraries/bytestring/README.md | 38 + libraries/bytestring/Setup.hs | 2 + libraries/bytestring/TODO | 71 + libraries/bytestring/bench/BenchAll.hs | 305 + .../bytestring/bench/BoundsCheckFusion.hs | 127 + libraries/bytestring/bench/CSV.hs | 614 + libraries/bytestring/bench/LICENSE | 30 + .../bytestring/bench/bench-bytestring.cabal | 145 + libraries/bytestring/bytestring.cabal | 225 + libraries/bytestring/cbits/fpstring.c | 90 + libraries/bytestring/cbits/itoa.c | 215 + libraries/bytestring/ghc.mk | 5 + libraries/bytestring/include/fpstring.h | 9 + libraries/bytestring/tests/.gitignore | 3 + libraries/bytestring/tests/Bench.hs | 334 + libraries/bytestring/tests/BenchUtils.hs | 145 + libraries/bytestring/tests/Hash.hs | 88 + libraries/bytestring/tests/Makefile | 223 + libraries/bytestring/tests/Properties.hs | 2335 + libraries/bytestring/tests/QuickCheckUtils.hs | 168 + libraries/bytestring/tests/Regressions.hs | 25 + libraries/bytestring/tests/Rules.hs | 39 + libraries/bytestring/tests/TestFramework.hs | 70 + libraries/bytestring/tests/Units.hs | 27 + libraries/bytestring/tests/Usr.Dict.Words | 38617 +++++++++++++++ libraries/bytestring/tests/Words.hs | 70 + .../Data/ByteString/Builder/Prim/TestUtils.hs | 377 + .../Data/ByteString/Builder/Prim/Tests.hs | 168 + .../builder/Data/ByteString/Builder/Tests.hs | 609 + .../bytestring/tests/builder/TestSuite.hs | 22 + .../bytestring/tests/bytestring-tests.cabal | 110 + libraries/bytestring/tests/data | 3925 ++ libraries/bytestring/tests/edit.hs | 11 + libraries/bytestring/tests/groupby.hs | 24 + libraries/bytestring/tests/iavor.hs | 24 + libraries/bytestring/tests/inline.hs | 21 + libraries/bytestring/tests/lazy-hclose.hs | 65 + libraries/bytestring/tests/lazybuild.hs | 24 + libraries/bytestring/tests/lazybuildcons.hs | 24 + libraries/bytestring/tests/lazyio.hs | 9 + libraries/bytestring/tests/lazylines.hs | 9 + libraries/bytestring/tests/lazyread.hs | 17 + .../bytestring/tests/letter_frequency.hs | 20 + libraries/bytestring/tests/linesort.hs | 16 + libraries/bytestring/tests/macros.m4 | 15 + libraries/bytestring/tests/pack.hs | 3 + libraries/bytestring/tests/revcomp.hs | 33 + .../bytestring/tests/spellcheck-input.txt | 38618 ++++++++++++++++ libraries/bytestring/tests/spellcheck.hs | 69 + libraries/bytestring/tests/sum.hs | 30 + libraries/bytestring/tests/test-compare.hs | 72 + libraries/bytestring/tests/unpack.hs | 36 + libraries/bytestring/tests/wc.hs | 14 + libraries/bytestring/tests/zipwith.hs | 7 + libraries/containers/.gitignore | 10 + libraries/containers/.travis.yml | 58 + libraries/containers/Data/Graph.hs | 481 + libraries/containers/Data/IntMap.hs | 102 + libraries/containers/Data/IntMap/Base.hs | 2252 + libraries/containers/Data/IntMap/Lazy.hs | 220 + libraries/containers/Data/IntMap/Strict.hs | 1009 + libraries/containers/Data/IntSet.hs | 153 + libraries/containers/Data/IntSet/Base.hs | 1491 + libraries/containers/Data/Map.hs | 132 + libraries/containers/Data/Map/Base.hs | 2914 ++ libraries/containers/Data/Map/Lazy.hs | 233 + libraries/containers/Data/Map/Strict.hs | 1205 + libraries/containers/Data/Sequence.hs | 2415 + libraries/containers/Data/Set.hs | 154 + libraries/containers/Data/Set/Base.hs | 1598 + libraries/containers/Data/Tree.hs | 195 + libraries/containers/Data/Utils/BitUtil.hs | 69 + libraries/containers/Data/Utils/StrictFold.hs | 19 + libraries/containers/Data/Utils/StrictPair.hs | 16 + libraries/containers/GNUmakefile | 4 + libraries/containers/LICENSE | 31 + libraries/containers/README.md | 12 + libraries/containers/Setup.hs | 6 + libraries/containers/benchmarks/.gitignore | 1 + libraries/containers/benchmarks/IntMap.hs | 97 + libraries/containers/benchmarks/IntSet.hs | 51 + .../containers/benchmarks/LookupGE/IntMap.hs | 51 + .../benchmarks/LookupGE/LookupGE_IntMap.hs | 97 + .../benchmarks/LookupGE/LookupGE_Map.hs | 78 + .../containers/benchmarks/LookupGE/Makefile | 3 + .../containers/benchmarks/LookupGE/Map.hs | 50 + libraries/containers/benchmarks/Makefile | 16 + libraries/containers/benchmarks/Map.hs | 131 + libraries/containers/benchmarks/Sequence.hs | 72 + libraries/containers/benchmarks/Set.hs | 53 + .../benchmarks/SetOperations/Makefile | 3 + .../SetOperations/SetOperations-IntMap.hs | 6 + .../SetOperations/SetOperations-IntSet.hs | 6 + .../SetOperations/SetOperations-Map.hs | 6 + .../SetOperations/SetOperations-Set.hs | 6 + .../benchmarks/SetOperations/SetOperations.hs | 45 + libraries/containers/benchmarks/bench-cmp.pl | 24 + libraries/containers/benchmarks/bench-cmp.sh | 3 + libraries/containers/containers.cabal | 254 + libraries/containers/ghc.mk | 5 + libraries/containers/include/containers.h | 61 + libraries/containers/prologue.txt | 1 + libraries/containers/tests-ghc/Makefile | 7 + libraries/containers/tests-ghc/all.T | 7 + .../containers/tests-ghc/dataintset001.hs | 11 + .../containers/tests-ghc/dataintset001.stdout | 1 + libraries/containers/tests-ghc/datamap001.hs | 14 + .../containers/tests-ghc/datamap001.stdout | 1 + libraries/containers/tests-ghc/datamap002.hs | 11 + .../containers/tests-ghc/datamap002.stdout | 1 + libraries/containers/tests-ghc/sequence001.hs | 9 + .../containers/tests-ghc/sequence001.stdout | 2 + .../containers/tests-ghc/unreliable/README | 2 + .../tests-ghc/unreliable/coerce_tests | 5 + .../tests-ghc/unreliable/mapcoerceintmap.hs | 25 + .../unreliable/mapcoerceintmap.stdout | 3 + .../unreliable/mapcoerceintmapstrict.hs | 25 + .../mapcoerceintmapstrict.hs.stdout | 3 + .../tests-ghc/unreliable/mapcoercemap.hs | 25 + .../tests-ghc/unreliable/mapcoercemap.stdout | 3 + .../tests-ghc/unreliable/mapcoerceseq.hs | 25 + .../tests-ghc/unreliable/mapcoerceseq.stdout | 3 + .../tests-ghc/unreliable/mapcoercesmap.hs | 25 + .../tests-ghc/unreliable/mapcoercesmap.stdout | 3 + libraries/containers/tests/Makefile | 20 + .../containers/tests/deprecated-properties.hs | 102 + .../containers/tests/intmap-properties.hs | 1056 + .../containers/tests/intmap-strictness.hs | 127 + .../containers/tests/intset-properties.hs | 337 + libraries/containers/tests/map-properties.hs | 1203 + libraries/containers/tests/map-strictness.hs | 128 + libraries/containers/tests/seq-properties.hs | 631 + libraries/containers/tests/set-properties.hs | 378 + libraries/deepseq/.gitignore | 4 + libraries/deepseq/.travis.yml | 47 + libraries/deepseq/Control/DeepSeq.hs | 581 + libraries/deepseq/GNUmakefile | 4 + libraries/deepseq/LICENSE | 39 + libraries/deepseq/README.md | 4 + libraries/deepseq/Setup.hs | 6 + libraries/deepseq/changelog.md | 87 + libraries/deepseq/deepseq.cabal | 84 + libraries/deepseq/ghc.mk | 5 + libraries/deepseq/tests/Main.hs | 152 + libraries/defineTOP.mk | 3 + libraries/directory/.gitignore | 13 + libraries/directory/.travis.yml | 53 + libraries/directory/GNUmakefile | 4 + libraries/directory/LICENSE | 63 + libraries/directory/README.md | 23 + libraries/directory/Setup.hs | 6 + libraries/directory/System/Directory.hs | 1285 + libraries/directory/cbits/directory.c | 11 + libraries/directory/changelog.md | 55 + libraries/directory/config.guess | 1420 + libraries/directory/config.sub | 1794 + libraries/directory/configure | 4223 ++ libraries/directory/configure.ac | 16 + libraries/directory/directory.buildinfo | 1 + libraries/directory/directory.cabal | 91 + libraries/directory/ghc.mk | 5 + libraries/directory/include/HsDirectory.h | 70 + .../directory/include/HsDirectoryConfig.h.in | 49 + libraries/directory/install-sh | 527 + libraries/directory/prologue.txt | 1 + libraries/directory/tests/.gitignore | 27 + libraries/directory/tests/Makefile | 7 + libraries/directory/tests/T8482.hs | 16 + libraries/directory/tests/T8482.stdout | 3 + libraries/directory/tests/TestUtils.hs | 86 + libraries/directory/tests/all.T | 32 + .../directory/tests/canonicalizePath001.hs | 8 + .../tests/canonicalizePath001.stdout | 1 + libraries/directory/tests/copyFile001.hs | 26 + libraries/directory/tests/copyFile001.stdout | 5 + .../directory/tests/copyFile001dir/source | 1 + libraries/directory/tests/copyFile002.hs | 31 + libraries/directory/tests/copyFile002.stdout | 5 + .../directory/tests/copyFile002dir/source | 1 + .../directory/tests/createDirectory001.hs | 12 + .../directory/tests/createDirectory001.stdout | 1 + .../tests/createDirectory001.stdout-mingw32 | 1 + .../tests/createDirectoryIfMissing001.hs | 79 + .../tests/createDirectoryIfMissing001.stdout | 8 + ...createDirectoryIfMissing001.stdout-mingw32 | 8 + .../directory/tests/currentDirectory001.hs | 27 + .../tests/currentDirectory001.stdout | 1 + libraries/directory/tests/directory001.hs | 16 + libraries/directory/tests/directory001.stdout | 1 + .../directory/tests/doesDirectoryExist001.hs | 11 + .../tests/doesDirectoryExist001.stdout | 1 + .../directory/tests/getDirContents001.hs | 18 + .../directory/tests/getDirContents001.stdout | 2 + .../directory/tests/getDirContents002.hs | 3 + .../directory/tests/getDirContents002.stderr | 1 + .../tests/getDirContents002.stderr-mingw32 | 1 + .../directory/tests/getHomeDirectory001.hs | 8 + .../directory/tests/getPermissions001.hs | 20 + .../directory/tests/getPermissions001.stdout | 3 + .../getPermissions001.stdout-alpha-dec-osf3 | 3 + ...Permissions001.stdout-i386-unknown-freebsd | 3 + ...Permissions001.stdout-i386-unknown-openbsd | 3 + .../tests/getPermissions001.stdout-mingw | 3 + ...rmissions001.stdout-x86_64-unknown-openbsd | 3 + .../tests/removeDirectoryRecursive001.hs | 93 + .../tests/removeDirectoryRecursive001.stdout | 19 + libraries/directory/tests/renameFile001.hs | 13 + .../directory/tests/renameFile001.stdout | 2 + libraries/directory/tools/dispatch-tests.hs | 63 + libraries/directory/tools/ghc.patch | 62 + libraries/directory/tools/run-tests | 50 + .../directory/tools/update-extra-source-files | 123 + libraries/doc/Makefile | 4 + libraries/doc/lib-hierarchy.html | 286 + libraries/filepath/.ghci | 13 + libraries/filepath/.gitignore | 4 + libraries/filepath/.travis.yml | 10 + libraries/filepath/GNUmakefile | 4 + libraries/filepath/Generate.hs | 107 + libraries/filepath/LICENSE | 30 + libraries/filepath/README.md | 9 + libraries/filepath/Setup.hs | 2 + libraries/filepath/System/FilePath.hs | 29 + .../filepath/System/FilePath/Internal.hs | 965 + libraries/filepath/System/FilePath/Posix.hs | 4 + libraries/filepath/System/FilePath/Windows.hs | 4 + libraries/filepath/changelog.md | 57 + libraries/filepath/filepath.cabal | 65 + libraries/filepath/ghc.mk | 5 + libraries/filepath/prologue.txt | 1 + libraries/filepath/tests/Test.hs | 30 + libraries/filepath/tests/TestGen.hs | 414 + libraries/filepath/tests/TestUtil.hs | 61 + libraries/filepath/travis.hs | 2 + libraries/gen_contents_index | 83 + libraries/ghc-prim/.gitignore | 4 + libraries/ghc-prim/GHC/CString.hs | 122 + libraries/ghc-prim/GHC/Classes.hs | 299 + libraries/ghc-prim/GHC/Debug.hs | 48 + libraries/ghc-prim/GHC/IntWord64.hs | 71 + libraries/ghc-prim/GHC/Magic.hs | 75 + libraries/ghc-prim/GHC/Tuple.hs | 211 + libraries/ghc-prim/GHC/Types.hs | 239 + libraries/ghc-prim/GNUmakefile | 4 + libraries/ghc-prim/LICENSE | 62 + libraries/ghc-prim/Setup.hs | 88 + libraries/ghc-prim/cbits/atomic.c | 320 + libraries/ghc-prim/cbits/bswap.c | 27 + libraries/ghc-prim/cbits/clz.c | 41 + libraries/ghc-prim/cbits/ctz.c | 57 + libraries/ghc-prim/cbits/debug.c | 10 + libraries/ghc-prim/cbits/longlong.c | 89 + libraries/ghc-prim/cbits/popcnt.c | 87 + libraries/ghc-prim/cbits/word2float.c | 15 + libraries/ghc-prim/ghc-prim.cabal | 66 + libraries/ghc-prim/ghc.mk | 5 + libraries/ghc-prim/tests/T6026.hs | 10 + libraries/ghc-prim/tests/T6026.stdout | 1 + libraries/haskeline/.gitignore | 4 + libraries/haskeline/.travis.yml | 39 + libraries/haskeline/Changelog | 167 + libraries/haskeline/GNUmakefile | 4 + libraries/haskeline/LICENSE | 23 + libraries/haskeline/README.md | 26 + libraries/haskeline/Setup.hs | 126 + .../haskeline/System/Console/Haskeline.hs | 320 + .../System/Console/Haskeline/Backend.hs | 55 + .../Console/Haskeline/Backend/DumbTerm.hs | 118 + .../Console/Haskeline/Backend/Posix.hsc | 343 + .../Haskeline/Backend/Posix/Encoder.hs | 211 + .../Console/Haskeline/Backend/Posix/IConv.hsc | 177 + .../Console/Haskeline/Backend/Terminfo.hs | 365 + .../Console/Haskeline/Backend/WCWidth.hs | 50 + .../Console/Haskeline/Backend/Win32.hsc | 546 + .../System/Console/Haskeline/Command.hs | 166 + .../Console/Haskeline/Command/Completion.hs | 163 + .../Console/Haskeline/Command/History.hs | 205 + .../Console/Haskeline/Command/KillRing.hs | 92 + .../System/Console/Haskeline/Command/Undo.hs | 50 + .../System/Console/Haskeline/Completion.hs | 190 + .../System/Console/Haskeline/Directory.hsc | 120 + .../System/Console/Haskeline/Emacs.hs | 102 + .../System/Console/Haskeline/History.hs | 149 + .../haskeline/System/Console/Haskeline/IO.hs | 100 + .../System/Console/Haskeline/InputT.hs | 203 + .../haskeline/System/Console/Haskeline/Key.hs | 125 + .../System/Console/Haskeline/LineState.hs | 415 + .../Console/Haskeline/MonadException.hs | 182 + .../System/Console/Haskeline/Monads.hs | 136 + .../System/Console/Haskeline/Prefs.hs | 138 + .../System/Console/Haskeline/Recover.hs | 22 + .../System/Console/Haskeline/RunCommand.hs | 112 + .../System/Console/Haskeline/Term.hs | 198 + .../haskeline/System/Console/Haskeline/Vi.hs | 447 + libraries/haskeline/cbits/h_iconv.c | 18 + libraries/haskeline/cbits/h_wcwidth.c | 309 + libraries/haskeline/cbits/win_console.c | 13 + libraries/haskeline/examples/Test.hs | 41 + .../examples/export/HaskelineExport.hs | 44 + libraries/haskeline/examples/export/Makefile | 13 + .../haskeline/examples/export/README.txt | 4 + libraries/haskeline/examples/export/main.c | 39 + libraries/haskeline/ghc.mk | 5 + libraries/haskeline/haskeline.cabal | 132 + libraries/haskeline/includes/h_iconv.h | 9 + libraries/haskeline/includes/win_console.h | 9 + libraries/haskeline/tests/Pty.hs | 100 + libraries/haskeline/tests/RunTTY.hs | 136 + libraries/haskeline/tests/Unit.hs | 314 + .../tests/dummy-\316\274\316\261\317\203/bar" | 0 .../\317\202\316\265\317\201\317\204" | 0 libraries/hoopl/.gitignore | 32 + libraries/hoopl/.travis.yml | 40 + libraries/hoopl/GNUmakefile | 4 + libraries/hoopl/HOWTO-BRANCHES | 15 + libraries/hoopl/LICENSE | 33 + libraries/hoopl/PROBLEMS | 68 + libraries/hoopl/README | 28 + libraries/hoopl/Setup.hs | 2 + libraries/hoopl/changelog.md | 289 + libraries/hoopl/ghc.mk | 5 + libraries/hoopl/hoopl.cabal | 70 + libraries/hoopl/hoopl.pdf | Bin 0 -> 279781 bytes libraries/hoopl/paper/.gitignore | 46 + libraries/hoopl/paper/Makefile | 63 + libraries/hoopl/paper/NOTES | 197 + libraries/hoopl/paper/Rew.hs | 46 + libraries/hoopl/paper/TODO | 26 + libraries/hoopl/paper/bbl.dias.mk | 5 + libraries/hoopl/paper/bbl.nr.mk | 6 + libraries/hoopl/paper/bbl.simonpj.mk | 2 + libraries/hoopl/paper/bitly.dias.mk | 3 + libraries/hoopl/paper/bitly.nr.mk | 3 + libraries/hoopl/paper/bitly.simonpj.mk | 3 + libraries/hoopl/paper/code.sty | 94 + libraries/hoopl/paper/defuse | 463 + libraries/hoopl/paper/dfopt.bib | 250 + libraries/hoopl/paper/dfopt.tex | 4043 ++ libraries/hoopl/paper/haskell-reviews.txt | 222 + libraries/hoopl/paper/hsprelude | 60 + libraries/hoopl/paper/icfp2010response.txt | 70 + libraries/hoopl/paper/icfp2010reviews.html | 424 + libraries/hoopl/paper/latex.mk | 18 + libraries/hoopl/paper/mkfile | 82 + libraries/hoopl/paper/notes-relatedwork | 57 + .../paper/old-implementation-sections.tex | 344 + libraries/hoopl/paper/onepage.tex | 610 + libraries/hoopl/paper/proto-response.txt | 87 + libraries/hoopl/paper/refs.txt | 78 + libraries/hoopl/paper/spell.mk | 21 + libraries/hoopl/paper/xsource | 75 + libraries/hoopl/private/authors-response | 56 + libraries/hoopl/private/icfp09.reviews | 186 + libraries/hoopl/private/popl-response.txt | 72 + libraries/hoopl/private/popl10-reviews.txt | 302 + libraries/hoopl/private/popl2010-reviews.txt | 292 + libraries/hoopl/prototypes/.gitignore | 3 + libraries/hoopl/prototypes/Cunning3.hs | 347 + .../hoopl/prototypes/CunningTransfers.hs | 419 + libraries/hoopl/prototypes/Hoopl.hs | 459 + libraries/hoopl/prototypes/Hoopl1.hs | 470 + libraries/hoopl/prototypes/Hoopl4.hs | 528 + libraries/hoopl/prototypes/Hoopl5.hs | 739 + libraries/hoopl/prototypes/Hoopl6.hs | 753 + libraries/hoopl/prototypes/Hoopl7.hs | 692 + libraries/hoopl/prototypes/RG.hs | 21 + libraries/hoopl/prototypes/Zipper.hs | 90 + libraries/hoopl/src/.gitignore | 6 + libraries/hoopl/src/Compiler/Hoopl.hs | 38 + libraries/hoopl/src/Compiler/Hoopl/Block.hs | 421 + .../hoopl/src/Compiler/Hoopl/Checkpoint.hs | 20 + .../hoopl/src/Compiler/Hoopl/Collections.hs | 92 + .../hoopl/src/Compiler/Hoopl/Combinators.hs | 236 + .../hoopl/src/Compiler/Hoopl/Dataflow.hs | 829 + .../hoopl/src/Compiler/Hoopl/DataflowFold.hs | 712 + libraries/hoopl/src/Compiler/Hoopl/Debug.hs | 106 + libraries/hoopl/src/Compiler/Hoopl/Fuel.hs | 130 + libraries/hoopl/src/Compiler/Hoopl/GHC.hs | 27 + libraries/hoopl/src/Compiler/Hoopl/Graph.hs | 424 + libraries/hoopl/src/Compiler/Hoopl/HISTORY | 54 + libraries/hoopl/src/Compiler/Hoopl/Haddock.hs | 12 + .../hoopl/src/Compiler/Hoopl/Internals.hs | 18 + libraries/hoopl/src/Compiler/Hoopl/Label.hs | 111 + libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs | 258 + libraries/hoopl/src/Compiler/Hoopl/NOTES | 64 + .../hoopl/src/Compiler/Hoopl/OldDataflow.hs | 698 + .../hoopl/src/Compiler/Hoopl/Passes/DList.hs | 48 + .../src/Compiler/Hoopl/Passes/Dominator.hs | 133 + .../hoopl/src/Compiler/Hoopl/Passes/Live.hs | 94 + .../hoopl/src/Compiler/Hoopl/Passes/mkfile | 3 + libraries/hoopl/src/Compiler/Hoopl/Pointed.hs | 150 + libraries/hoopl/src/Compiler/Hoopl/Shape.hs | 53 + libraries/hoopl/src/Compiler/Hoopl/Show.hs | 46 + libraries/hoopl/src/Compiler/Hoopl/Stream.hs | 67 + libraries/hoopl/src/Compiler/Hoopl/Unique.hs | 164 + .../hoopl/src/Compiler/Hoopl/Wrappers.hs | 12 + libraries/hoopl/src/Compiler/Hoopl/XUtil.hs | 171 + libraries/hoopl/src/Compiler/Hoopl/mkfile | 3 + libraries/hoopl/src/Compiler/mkfile | 3 + libraries/hoopl/src/LOOPS | 45 + libraries/hoopl/src/mkfile | 55 + libraries/hoopl/src/subdir.mk | 11 + libraries/hoopl/testing/.gitignore | 4 + libraries/hoopl/testing/Ast.hs | 32 + libraries/hoopl/testing/Ast2ir.hs | 83 + libraries/hoopl/testing/ConstProp.hs | 82 + libraries/hoopl/testing/Eval.hs | 175 + libraries/hoopl/testing/EvalMonad.hs | 137 + libraries/hoopl/testing/Expr.hs | 42 + libraries/hoopl/testing/IR.hs | 60 + libraries/hoopl/testing/Live.hs | 50 + libraries/hoopl/testing/Main.hs | 15 + libraries/hoopl/testing/OptSupport.hs | 123 + libraries/hoopl/testing/PP.hs | 8 + libraries/hoopl/testing/Parse.hs | 202 + libraries/hoopl/testing/README | 56 + libraries/hoopl/testing/Simplify.hs | 47 + libraries/hoopl/testing/Test.hs | 94 + libraries/hoopl/testing/constprop-figure | 52 + libraries/hoopl/testing/mkfile | 22 + libraries/hoopl/testing/tests/ExpectedOutput | 211 + libraries/hoopl/testing/tests/if-test | 10 + libraries/hoopl/testing/tests/if-test2 | 21 + libraries/hoopl/testing/tests/if-test3 | 12 + libraries/hoopl/testing/tests/if-test4 | 12 + libraries/hoopl/testing/tests/test1 | 7 + libraries/hoopl/testing/tests/test2 | 14 + libraries/hoopl/testing/tests/test3 | 14 + libraries/hoopl/testing/tests/test4 | 13 + libraries/hoopl/validate | 8 + libraries/hpc/.gitignore | 5 + libraries/hpc/.travis.yml | 23 + libraries/hpc/GNUmakefile | 4 + libraries/hpc/LICENSE | 25 + libraries/hpc/README.md | 5 + libraries/hpc/Setup.hs | 6 + libraries/hpc/Trace/Hpc/Mix.hs | 190 + libraries/hpc/Trace/Hpc/Reflect.hsc | 79 + libraries/hpc/Trace/Hpc/Tix.hs | 63 + libraries/hpc/Trace/Hpc/Util.hs | 114 + libraries/hpc/changelog.md | 17 + libraries/hpc/ghc.mk | 5 + libraries/hpc/hpc.cabal | 43 + libraries/hpc/prologue.txt | 1 + libraries/hpc/tests/.gitignore | 20 + libraries/hpc/tests/Makefile | 40 + libraries/hpc/tests/fork/Makefile | 8 + libraries/hpc/tests/fork/hpc_fork.hs | 10 + libraries/hpc/tests/fork/hpc_fork.stdout | 121 + libraries/hpc/tests/fork/test.T | 9 + libraries/hpc/tests/function/Makefile | 8 + libraries/hpc/tests/function/test.T | 12 + libraries/hpc/tests/function/tough.hs | 47 + libraries/hpc/tests/function/tough.stdout | 164 + libraries/hpc/tests/function2/Makefile | 8 + .../hpc/tests/function2/subdir/tough2.lhs | 49 + libraries/hpc/tests/function2/test.T | 18 + libraries/hpc/tests/function2/tough2.stdout | 166 + libraries/hpc/tests/ghc_ghci/A.hs | 5 + libraries/hpc/tests/ghc_ghci/B.hs | 7 + libraries/hpc/tests/ghc_ghci/Makefile | 13 + .../hpc/tests/ghc_ghci/hpc_ghc_ghci.stdout | 1 + libraries/hpc/tests/ghc_ghci/test.T | 10 + libraries/hpc/tests/hpc.ovr | 13 + libraries/hpc/tests/hpcrun.pl | 44 + libraries/hpc/tests/raytrace/CSG.hs | 16 + libraries/hpc/tests/raytrace/Construct.hs | 265 + libraries/hpc/tests/raytrace/Data.hs | 408 + libraries/hpc/tests/raytrace/Eval.hs | 355 + libraries/hpc/tests/raytrace/Geometry.hs | 313 + libraries/hpc/tests/raytrace/Illumination.hs | 231 + libraries/hpc/tests/raytrace/Intersections.hs | 404 + libraries/hpc/tests/raytrace/Interval.hs | 121 + libraries/hpc/tests/raytrace/Main.hs | 15 + libraries/hpc/tests/raytrace/Makefile | 4 + libraries/hpc/tests/raytrace/Misc.hs | 11 + libraries/hpc/tests/raytrace/Parse.hs | 137 + libraries/hpc/tests/raytrace/Pixmap.hs | 64 + libraries/hpc/tests/raytrace/Primitives.hs | 24 + libraries/hpc/tests/raytrace/RayTrace.hs | 9 + libraries/hpc/tests/raytrace/Surface.hs | 115 + libraries/hpc/tests/raytrace/galois.gml | 147 + libraries/hpc/tests/raytrace/galois.sample | 1 + libraries/hpc/tests/raytrace/test.T | 11 + .../hpc/tests/raytrace/tixs/.hpc/CSG.mix | 1 + .../tests/raytrace/tixs/.hpc/Construct.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Data.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Eval.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Geometry.mix | 1 + .../tests/raytrace/tixs/.hpc/Illumination.mix | 1 + .../raytrace/tixs/.hpc/Intersections.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Interval.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Main.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Misc.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Parse.mix | 1 + .../tests/raytrace/tixs/.hpc/Primitives.mix | 1 + .../hpc/tests/raytrace/tixs/.hpc/Surface.mix | 1 + libraries/hpc/tests/raytrace/tixs/Makefile | 10 + .../raytrace/tixs/hpc_markup_multi_001.stdout | 5 + .../raytrace/tixs/hpc_markup_multi_002.stdout | 16 + .../raytrace/tixs/hpc_markup_multi_003.stdout | 17 + .../tests/raytrace/tixs/hpc_raytrace.stdout | 2955 ++ .../raytrace/tixs/hpc_report_multi_001.stdout | 9 + .../raytrace/tixs/hpc_report_multi_002.stdout | 108 + .../raytrace/tixs/hpc_report_multi_003.stdout | 41 + .../hpc/tests/raytrace/tixs/hpc_sample.tix | 1 + .../raytrace/tixs/hpc_show_multi_001.stdout | 5400 +++ .../raytrace/tixs/hpc_show_multi_002.stdout | 522 + libraries/hpc/tests/raytrace/tixs/test.T | 26 + libraries/hpc/tests/simple/Makefile | 8 + libraries/hpc/tests/simple/hpc001.hs | 1 + libraries/hpc/tests/simple/hpc001.stdout | 112 + libraries/hpc/tests/simple/test.T | 8 + .../hpc/tests/simple/tixs/.hpc.copy/Main.mix | 1 + libraries/hpc/tests/simple/tixs/.hpc/Main.mix | 1 + libraries/hpc/tests/simple/tixs/Makefile | 14 + .../hpc/tests/simple/tixs/hand_overlay.ovr | 6 + libraries/hpc/tests/simple/tixs/hpc001.hs | 1 + .../hpc/tests/simple/tixs/hpc_bad_001.stdout | 1 + .../hpc/tests/simple/tixs/hpc_draft.stdout | 6 + .../tests/simple/tixs/hpc_hand_overlay.stdout | 8 + .../hpc/tests/simple/tixs/hpc_help.stdout | 18 + .../tests/simple/tixs/hpc_help_draft.stdout | 18 + .../tests/simple/tixs/hpc_help_help.stdout | 3 + .../tests/simple/tixs/hpc_help_markup.stdout | 20 + .../tests/simple/tixs/hpc_help_overlay.stdout | 16 + .../tests/simple/tixs/hpc_help_report.stdout | 20 + .../tests/simple/tixs/hpc_help_show.stdout | 18 + .../tests/simple/tixs/hpc_help_version.stdout | 3 + .../tests/simple/tixs/hpc_markup_001.stdout | 21 + .../tests/simple/tixs/hpc_markup_002.stdout | 21 + .../simple/tixs/hpc_markup_error_001.stdout | 21 + .../simple/tixs/hpc_markup_error_002.stdout | 21 + .../hpc/tests/simple/tixs/hpc_overlay.stdout | 8 + .../hpc/tests/simple/tixs/hpc_overlay2.stdout | 8 + .../tests/simple/tixs/hpc_report_001.stdout | 13 + .../tests/simple/tixs/hpc_report_002.stdout | 23 + .../tests/simple/tixs/hpc_report_003.stdout | 9 + .../simple/tixs/hpc_report_error_001.stdout | 21 + .../simple/tixs/hpc_report_error_002.stdout | 21 + .../hpc/tests/simple/tixs/hpc_sample.tix | 1 + .../hpc/tests/simple/tixs/hpc_show.stdout | 5 + .../simple/tixs/hpc_show_error_001.stdout | 19 + .../simple/tixs/hpc_show_error_002.stdout | 19 + .../hpc/tests/simple/tixs/hpc_version.stdout | 1 + .../hpc/tests/simple/tixs/sample_overlay.ovr | 6 + libraries/hpc/tests/simple/tixs/test.T | 73 + libraries/hscolour.css | 5 + libraries/integer-gmp/.gitignore | 16 + libraries/integer-gmp/GHC/Integer.lhs | 66 + .../integer-gmp/GHC/Integer/GMP/Internals.hs | 40 + libraries/integer-gmp/GHC/Integer/GMP/Prim.hs | 372 + .../integer-gmp/GHC/Integer/Logarithms.hs | 43 + .../GHC/Integer/Logarithms/Internals.hs | 260 + libraries/integer-gmp/GHC/Integer/Type.lhs | 1021 + libraries/integer-gmp/GNUmakefile | 4 + libraries/integer-gmp/LICENSE | 62 + libraries/integer-gmp/Setup.hs | 6 + libraries/integer-gmp/aclocal.m4 | 44 + libraries/integer-gmp/cbits/alloc.c | 97 + libraries/integer-gmp/cbits/cbits.c | 14 + libraries/integer-gmp/cbits/float.c | 249 + libraries/integer-gmp/cbits/gmp-wrappers.cmm | 823 + libraries/integer-gmp/cbits/longlong.c | 66 + libraries/integer-gmp/changelog.md | 44 + libraries/integer-gmp/config.guess | 1420 + libraries/integer-gmp/config.sub | 1794 + libraries/integer-gmp/configure | 4985 ++ libraries/integer-gmp/configure.ac | 86 + libraries/integer-gmp/ghc.mk | 5 + libraries/integer-gmp/gmp/config.mk.in | 11 + libraries/integer-gmp/gmp/ghc.mk | 197 + libraries/integer-gmp/gmp/ln | 3 + libraries/integer-gmp/gmp/tarball/README | 8 + .../tarball/gmp-5.0.3-nodoc-patched.tar.bz2 | Bin 0 -> 2176824 bytes .../integer-gmp/gmp/tarball/gmp-5.0.4.patch | 1584 + libraries/integer-gmp/gmp/tarball/patch | 103 + .../integer-gmp/include/HsIntegerGmp.h.in | 6 + libraries/integer-gmp/install-sh | 527 + .../integer-gmp/integer-gmp.buildinfo.in | 5 + libraries/integer-gmp/integer-gmp.cabal | 80 + .../mkGmpDerivedConstants/Makefile | 15 + .../integer-gmp/mkGmpDerivedConstants/ghc.mk | 39 + .../mkGmpDerivedConstants.c | 75 + libraries/integer-gmp2/.gitignore | 14 + libraries/integer-gmp2/GNUmakefile | 4 + libraries/integer-gmp2/LICENSE | 30 + libraries/integer-gmp2/Setup.hs | 6 + libraries/integer-gmp2/aclocal.m4 | 44 + libraries/integer-gmp2/cbits/wrappers.c | 832 + libraries/integer-gmp2/changelog.md | 51 + libraries/integer-gmp2/config.guess | 1420 + libraries/integer-gmp2/config.sub | 1794 + libraries/integer-gmp2/configure | 5221 +++ libraries/integer-gmp2/configure.ac | 116 + libraries/integer-gmp2/ghc.mk | 5 + libraries/integer-gmp2/gmp/config.mk.in | 11 + libraries/integer-gmp2/gmp/ghc-gmp.h | 1 + libraries/integer-gmp2/gmp/ghc.mk | 139 + libraries/integer-gmp2/gmp/gmpsrc.patch | 37 + libraries/integer-gmp2/gmp/ln | 3 + .../integer-gmp2/include/HsIntegerGmp.h.in | 14 + libraries/integer-gmp2/install-sh | 527 + .../integer-gmp2/integer-gmp.buildinfo.in | 5 + libraries/integer-gmp2/integer-gmp.cabal | 66 + libraries/integer-gmp2/src/GHC/Integer.hs | 73 + .../src/GHC/Integer/GMP/Internals.hs | 362 + .../src/GHC/Integer/Logarithms.hs | 73 + .../src/GHC/Integer/Logarithms/Internals.hs | 118 + .../integer-gmp2/src/GHC/Integer/Type.hs | 2002 + libraries/integer-simple/.gitignore | 3 + libraries/integer-simple/GHC/Integer.hs | 43 + .../integer-simple/GHC/Integer/Logarithms.hs | 43 + .../GHC/Integer/Logarithms/Internals.hs | 166 + .../GHC/Integer/Simple/Internals.hs | 23 + libraries/integer-simple/GHC/Integer/Type.hs | 895 + libraries/integer-simple/GNUmakefile | 4 + libraries/integer-simple/LICENSE | 26 + libraries/integer-simple/Setup.hs | 6 + libraries/integer-simple/ghc.mk | 5 + libraries/integer-simple/integer-simple.cabal | 31 + libraries/libraries-footer.txt | 20 + libraries/libraries-header.txt | 1 + libraries/pretty/.gitignore | 6 + libraries/pretty/.travis.yml | 45 + libraries/pretty/CHANGELOG.md | 170 + libraries/pretty/GNUmakefile | 4 + libraries/pretty/LICENSE | 39 + libraries/pretty/README.md | 58 + libraries/pretty/Setup.hs | 7 + libraries/pretty/TODO | 98 + libraries/pretty/ghc.mk | 5 + libraries/pretty/pretty.cabal | 66 + libraries/pretty/src/Text/PrettyPrint.hs | 71 + .../pretty/src/Text/PrettyPrint/HughesPJ.hs | 965 + .../src/Text/PrettyPrint/HughesPJClass.hs | 146 + libraries/pretty/tests/Bench1.hs | 55 + libraries/pretty/tests/BugSep.hs | 36 + libraries/pretty/tests/PrettyTestVersion.hs | 14 + libraries/pretty/tests/Test.hs | 989 + libraries/pretty/tests/TestGenerators.hs | 75 + libraries/pretty/tests/TestStructures.hs | 92 + libraries/pretty/tests/TestUtils.hs | 19 + libraries/pretty/tests/UnitPP1.hs | 76 + libraries/pretty/tests/UnitT3911.hs | 25 + libraries/process/.gitignore | 16 + libraries/process/.travis.yml | 43 + libraries/process/GNUmakefile | 4 + libraries/process/LICENSE | 63 + libraries/process/README.md | 15 + libraries/process/Setup.hs | 6 + libraries/process/System/Cmd.hs | 32 + libraries/process/System/Process.hsc | 959 + libraries/process/System/Process/Internals.hs | 740 + libraries/process/aclocal.m4 | 50 + libraries/process/cbits/runProcess.c | 635 + libraries/process/changelog.md | 52 + libraries/process/configure | 4838 ++ libraries/process/configure.ac | 23 + libraries/process/ghc.mk | 5 + .../process/include/HsProcessConfig.h.in | 91 + libraries/process/include/processFlags.h | 8 + libraries/process/include/runProcess.h | 86 + libraries/process/process.buildinfo | 1 + libraries/process/process.cabal | 78 + libraries/process/prologue.txt | 1 + libraries/process/test/main.hs | 14 + libraries/process/tests/.gitignore | 31 + libraries/process/tests/Makefile | 12 + libraries/process/tests/T1780.hs | 19 + libraries/process/tests/T1780.stdout | 1 + libraries/process/tests/T3231.hs | 22 + libraries/process/tests/T3231.stdout | 1 + libraries/process/tests/T3994.hs | 22 + libraries/process/tests/T3994.stdout | 2 + libraries/process/tests/T4198.hs | 3 + libraries/process/tests/T4198.stdout | 1 + libraries/process/tests/T4198.stdout-mingw32 | 1 + libraries/process/tests/T4889.hs | 10 + libraries/process/tests/T4889.stdout | 2 + libraries/process/tests/T8343.hs | 8 + libraries/process/tests/T8343.stdout | 2 + libraries/process/tests/all.T | 37 + libraries/process/tests/exitminus1.c | 1 + libraries/process/tests/process001.hs | 16 + libraries/process/tests/process002.hs | 15 + libraries/process/tests/process003.hs | 24 + libraries/process/tests/process003.stdout | 4 + libraries/process/tests/process004.hs | 23 + libraries/process/tests/process004.stdout | 2 + .../process/tests/process004.stdout-mingw32 | 2 + libraries/process/tests/process005.hs | 26 + libraries/process/tests/process005.stdin | 3 + libraries/process/tests/process005.stdout | 4 + libraries/process/tests/process006.hs | 15 + libraries/process/tests/process006.stderr | 1 + libraries/process/tests/process006.stdout | 4 + libraries/process/tests/process007.hs | 24 + libraries/process/tests/process007.stdout | 2 + libraries/process/tests/process007_fd.c | 41 + libraries/process/tests/process008.hs | 9 + libraries/process/tests/process008.stdout | 2 + libraries/process/tests/process009.hs | 18 + libraries/process/tests/process009.stdout | 3 + libraries/process/tests/process010.hs | 13 + libraries/process/tests/process010.stdout | 4 + .../process010.stdout-i386-unknown-solaris2 | 4 + .../process/tests/process010.stdout-mingw32 | 4 + libraries/process/tests/process011.hs | 77 + libraries/process/tests/process011.stdout | 12 + libraries/prologue.txt.in | 5 + libraries/template-haskell/.gitignore | 3 + libraries/template-haskell/GNUmakefile | 4 + libraries/template-haskell/LICENSE | 33 + .../template-haskell/Language/Haskell/TH.hs | 150 + .../Language/Haskell/TH/Lib.hs | 705 + .../Language/Haskell/TH/Lib/Map.hs | 108 + .../Language/Haskell/TH/Ppr.hs | 603 + .../Language/Haskell/TH/PprLib.hs | 225 + .../Language/Haskell/TH/Quote.hs | 87 + .../Language/Haskell/TH/Syntax.hs | 1441 + libraries/template-haskell/Setup.hs | 6 + libraries/template-haskell/changelog.md | 22 + libraries/template-haskell/ghc.mk | 5 + libraries/template-haskell/prologue.txt | 1 + .../template-haskell/template-haskell.cabal | 56 + libraries/template-haskell/tests/.gitignore | 16 + libraries/template-haskell/tests/Makefile | 7 + libraries/template-haskell/tests/all.T | 2 + .../template-haskell/tests/dataToExpQUnit.hs | 15 + .../tests/dataToExpQUnit.stderr | 1 + libraries/terminfo/.gitignore | 8 + libraries/terminfo/.travis.yml | 44 + libraries/terminfo/GNUmakefile | 4 + libraries/terminfo/LICENSE | 23 + libraries/terminfo/README.md | 4 + libraries/terminfo/Setup.lhs | 6 + libraries/terminfo/System/Console/Terminfo.hs | 24 + .../terminfo/System/Console/Terminfo/Base.hs | 376 + .../terminfo/System/Console/Terminfo/Color.hs | 124 + .../System/Console/Terminfo/Cursor.hs | 199 + .../terminfo/System/Console/Terminfo/Edit.hs | 28 + .../System/Console/Terminfo/Effects.hs | 160 + .../terminfo/System/Console/Terminfo/Keys.hs | 81 + libraries/terminfo/configure | 4633 ++ libraries/terminfo/configure.ac | 62 + libraries/terminfo/ghc.mk | 5 + libraries/terminfo/terminfo.buildinfo.in | 4 + libraries/terminfo/terminfo.cabal | 41 + libraries/time/.gitignore | 9 + libraries/time/GNUmakefile | 4 + libraries/time/LICENSE | 10 + libraries/time/Makefile | 32 + libraries/time/README | 4 + libraries/time/Setup.hs | 6 + libraries/time/aclocal.m4 | 19 + libraries/time/configure | 4638 ++ libraries/time/configure.ac | 23 + libraries/time/ghc.mk | 5 + libraries/time/lib/Data/Time.hs | 12 + libraries/time/lib/Data/Time/Calendar.hs | 8 + libraries/time/lib/Data/Time/Calendar/Days.hs | 74 + .../time/lib/Data/Time/Calendar/Easter.hs | 36 + .../time/lib/Data/Time/Calendar/Gregorian.hs | 82 + .../time/lib/Data/Time/Calendar/Julian.hs | 73 + .../lib/Data/Time/Calendar/JulianYearDay.hs | 46 + .../time/lib/Data/Time/Calendar/MonthDay.hs | 49 + .../lib/Data/Time/Calendar/OrdinalDate.hs | 127 + .../time/lib/Data/Time/Calendar/Private.hs | 50 + .../time/lib/Data/Time/Calendar/WeekDate.hs | 52 + libraries/time/lib/Data/Time/Clock.hs | 18 + .../time/lib/Data/Time/Clock/CTimeval.hs | 36 + libraries/time/lib/Data/Time/Clock/POSIX.hs | 66 + libraries/time/lib/Data/Time/Clock/Scale.hs | 110 + libraries/time/lib/Data/Time/Clock/TAI.hs | 143 + libraries/time/lib/Data/Time/Clock/UTC.hs | 125 + libraries/time/lib/Data/Time/Clock/UTCDiff.hs | 13 + libraries/time/lib/Data/Time/Format.hs | 246 + libraries/time/lib/Data/Time/Format/Locale.hs | 87 + libraries/time/lib/Data/Time/Format/Parse.hs | 489 + libraries/time/lib/Data/Time/LocalTime.hs | 10 + .../time/lib/Data/Time/LocalTime/LocalTime.hs | 109 + .../time/lib/Data/Time/LocalTime/TimeOfDay.hs | 97 + .../time/lib/Data/Time/LocalTime/TimeZone.hs | 100 + libraries/time/lib/cbits/HsTime.c | 51 + libraries/time/lib/include/HsConfigure.h | 7 + libraries/time/lib/include/HsTime.h | 23 + libraries/time/lib/include/HsTimeConfig.h | 87 + libraries/time/lib/include/HsTimeConfig.h.in | 86 + .../time/test/ShowDefaultTZAbbreviations.hs | 9 + libraries/time/test/Test.hs | 11 + libraries/time/test/Test/AddDays.hs | 41 + libraries/time/test/Test/AddDaysRef.hs | 250 + libraries/time/test/Test/ClipDates.hs | 46 + libraries/time/test/Test/ClipDatesRef.hs | 566 + libraries/time/test/Test/ConvertBack.hs | 40 + libraries/time/test/Test/CurrentTime.hs | 13 + libraries/time/test/Test/LongWeekYears.hs | 20 + libraries/time/test/Test/LongWeekYearsRef.hs | 155 + .../time/test/Test/RealToFracBenchmark.hs | 22 + libraries/time/test/Test/ShowDST.hs | 43 + libraries/time/test/Test/TAI_UTC_DAT.hs | 42 + libraries/time/test/Test/TestCalendars.hs | 30 + libraries/time/test/Test/TestCalendarsRef.hs | 9 + libraries/time/test/Test/TestEaster.hs | 36 + libraries/time/test/Test/TestEasterRef.hs | 62 + libraries/time/test/Test/TestFormat.hs | 185 + libraries/time/test/Test/TestFormatStuff.c | 15 + libraries/time/test/Test/TestFormatStuff.h | 6 + libraries/time/test/Test/TestMonthDay.hs | 22 + libraries/time/test/Test/TestMonthDayRef.hs | 751 + libraries/time/test/Test/TestParseDAT.hs | 53 + libraries/time/test/Test/TestParseDAT_Ref.hs | 95 + libraries/time/test/Test/TestParseTime.hs | 581 + libraries/time/test/Test/TestTime.hs | 106 + libraries/time/test/Test/TestTimeRef.hs | 881 + libraries/time/test/Test/TestTimeZone.hs | 17 + libraries/time/test/Test/TestUtil.hs | 39 + libraries/time/test/Test/Tests.hs | 30 + libraries/time/test/Test/TimeZone.hs | 10 + libraries/time/test/Test/UseCases.lhs | 83 + libraries/time/time.cabal | 149 + .../Control/Applicative/Backwards.hs | 76 + .../transformers/Control/Applicative/Lift.hs | 129 + .../transformers/Control/Monad/IO/Class.hs | 39 + .../transformers/Control/Monad/Signatures.hs | 32 + .../transformers/Control/Monad/Trans/Class.hs | 244 + .../transformers/Control/Monad/Trans/Cont.hs | 191 + .../transformers/Control/Monad/Trans/Error.hs | 298 + .../Control/Monad/Trans/Except.hs | 234 + .../Control/Monad/Trans/Identity.hs | 111 + .../transformers/Control/Monad/Trans/List.hs | 116 + .../transformers/Control/Monad/Trans/Maybe.hs | 161 + .../transformers/Control/Monad/Trans/RWS.hs | 21 + .../Control/Monad/Trans/RWS/Lazy.hs | 319 + .../Control/Monad/Trans/RWS/Strict.hs | 319 + .../Control/Monad/Trans/Reader.hs | 178 + .../transformers/Control/Monad/Trans/State.hs | 29 + .../Control/Monad/Trans/State/Lazy.hs | 364 + .../Control/Monad/Trans/State/Strict.hs | 361 + .../Control/Monad/Trans/Writer.hs | 21 + .../Control/Monad/Trans/Writer/Lazy.hs | 232 + .../Control/Monad/Trans/Writer/Strict.hs | 235 + .../transformers/Data/Functor/Classes.hs | 131 + .../transformers/Data/Functor/Compose.hs | 92 + .../transformers/Data/Functor/Constant.hs | 58 + .../transformers/Data/Functor/Product.hs | 83 + .../transformers/Data/Functor/Reverse.hs | 80 + libraries/transformers/Data/Functor/Sum.hs | 65 + libraries/transformers/GNUmakefile | 4 + libraries/transformers/LICENSE | 31 + libraries/transformers/Setup.hs | 2 + libraries/transformers/changelog | 68 + libraries/transformers/ghc.mk | 5 + .../oldsrc/Data/Functor/Identity.hs | 70 + libraries/transformers/transformers.cabal | 76 + libraries/unix/.gitignore | 19 + libraries/unix/.travis.yml | 40 + libraries/unix/GNUmakefile | 4 + libraries/unix/LICENSE | 31 + libraries/unix/README.md | 15 + libraries/unix/Setup.hs | 6 + libraries/unix/System/Posix.hs | 191 + libraries/unix/System/Posix/ByteString.hs | 70 + .../unix/System/Posix/ByteString/FilePath.hsc | 127 + libraries/unix/System/Posix/Directory.hsc | 159 + .../System/Posix/Directory/ByteString.hsc | 160 + .../unix/System/Posix/Directory/Common.hsc | 88 + libraries/unix/System/Posix/DynamicLinker.hsc | 72 + .../System/Posix/DynamicLinker/ByteString.hsc | 73 + .../System/Posix/DynamicLinker/Common.hsc | 92 + .../System/Posix/DynamicLinker/Module.hsc | 121 + .../Posix/DynamicLinker/Module/ByteString.hsc | 79 + .../unix/System/Posix/DynamicLinker/Prim.hsc | 124 + libraries/unix/System/Posix/Env.hsc | 187 + .../unix/System/Posix/Env/ByteString.hsc | 168 + libraries/unix/System/Posix/Error.hs | 63 + libraries/unix/System/Posix/Fcntl.hsc | 104 + libraries/unix/System/Posix/Files.hsc | 448 + .../unix/System/Posix/Files/ByteString.hsc | 448 + libraries/unix/System/Posix/Files/Common.hsc | 613 + libraries/unix/System/Posix/IO.hsc | 93 + libraries/unix/System/Posix/IO/ByteString.hsc | 93 + libraries/unix/System/Posix/IO/Common.hsc | 425 + libraries/unix/System/Posix/Process.hsc | 131 + .../unix/System/Posix/Process/ByteString.hsc | 142 + .../unix/System/Posix/Process/Common.hsc | 431 + .../unix/System/Posix/Process/Internals.hs | 79 + libraries/unix/System/Posix/Resource.hsc | 159 + libraries/unix/System/Posix/Semaphore.hsc | 131 + libraries/unix/System/Posix/SharedMem.hsc | 91 + libraries/unix/System/Posix/Signals.hsc | 642 + libraries/unix/System/Posix/Signals/Exts.hsc | 49 + libraries/unix/System/Posix/Temp.hsc | 131 + .../unix/System/Posix/Temp/ByteString.hsc | 131 + libraries/unix/System/Posix/Terminal.hsc | 188 + .../unix/System/Posix/Terminal/ByteString.hsc | 196 + .../unix/System/Posix/Terminal/Common.hsc | 695 + libraries/unix/System/Posix/Time.hsc | 41 + libraries/unix/System/Posix/Unistd.hsc | 266 + libraries/unix/System/Posix/User.hsc | 473 + libraries/unix/aclocal.m4 | 49 + libraries/unix/cbits/HsUnix.c | 177 + libraries/unix/cbits/dirUtils.c | 83 + libraries/unix/cbits/execvpe.c | 173 + libraries/unix/cbits/ghcrts.c | 15 + libraries/unix/changelog.md | 90 + libraries/unix/config.guess | 1420 + libraries/unix/config.sub | 1794 + libraries/unix/configure | 6199 +++ libraries/unix/configure.ac | 208 + libraries/unix/ghc.mk | 5 + libraries/unix/include/HsUnix.h | 197 + libraries/unix/include/HsUnixConfig.h.in | 387 + libraries/unix/include/execvpe.h | 29 + libraries/unix/install-sh | 527 + libraries/unix/prologue.txt | 1 + libraries/unix/tests/.gitignore | 42 + libraries/unix/tests/Makefile | 7 + libraries/unix/tests/T1185.hs | 24 + libraries/unix/tests/T1185.stdout | 2 + libraries/unix/tests/T3816.hs | 4 + libraries/unix/tests/T3816.stdout | 2 + libraries/unix/tests/T8108.hs | 8 + libraries/unix/tests/all.T | 75 + libraries/unix/tests/executeFile001.hs | 6 + libraries/unix/tests/executeFile001.stdout | 1 + libraries/unix/tests/fdReadBuf001.hs | 27 + libraries/unix/tests/fileStatus.hs | 109 + libraries/unix/tests/fileStatusByteString.hs | 108 + libraries/unix/tests/fileexist01.hs | 5 + libraries/unix/tests/fileexist01.stdout | 2 + libraries/unix/tests/forkprocess01.hs | 9 + libraries/unix/tests/forkprocess01.stdout | 1 + libraries/unix/tests/getEnvironment01.hs | 8 + libraries/unix/tests/getEnvironment01.stdout | 1 + libraries/unix/tests/getEnvironment02.hs | 8 + libraries/unix/tests/getEnvironment02.stdout | 1 + libraries/unix/tests/getGroupEntryForName.hs | 5 + .../unix/tests/getGroupEntryForName.stderr | 1 + libraries/unix/tests/getUserEntryForName.hs | 5 + .../unix/tests/getUserEntryForName.stderr | 1 + libraries/unix/tests/libposix/Makefile | 7 + libraries/unix/tests/libposix/all.T | 16 + libraries/unix/tests/libposix/posix002.hs | 4 + libraries/unix/tests/libposix/posix002.stdout | 2 + libraries/unix/tests/libposix/posix003.hs | 17 + libraries/unix/tests/libposix/posix003.stdout | 1 + libraries/unix/tests/libposix/posix004.hs | 48 + libraries/unix/tests/libposix/posix004.stdout | 1 + libraries/unix/tests/libposix/posix005.hs | 21 + libraries/unix/tests/libposix/posix005.stdout | 7 + libraries/unix/tests/libposix/posix006.hs | 18 + libraries/unix/tests/libposix/posix006.stdout | 1 + libraries/unix/tests/libposix/posix009.hs | 15 + libraries/unix/tests/libposix/posix009.stdout | 6 + libraries/unix/tests/libposix/posix010.hs | 16 + libraries/unix/tests/libposix/posix010.stdout | 3 + libraries/unix/tests/libposix/posix014.hs | 13 + libraries/unix/tests/libposix/posix014.stdout | 1 + libraries/unix/tests/processGroup001.hs | 7 + libraries/unix/tests/processGroup001.stdout | 1 + libraries/unix/tests/processGroup002.hs | 21 + libraries/unix/tests/processGroup002.stdout | 3 + libraries/unix/tests/queryfdoption01.hs | 11 + libraries/unix/tests/queryfdoption01.stdin | 3 + libraries/unix/tests/queryfdoption01.stdout | 2 + libraries/unix/tests/resourceLimit.hs | 16 + libraries/unix/tests/resourceLimit.stdout | 2 + libraries/unix/tests/signals001.hs | 108 + libraries/unix/tests/signals001.stdout | 4 + .../signals001.stdout-i386-unknown-freebsd | 4 + .../signals001.stdout-i386-unknown-openbsd | 4 + .../signals001.stdout-sparc-unknown-openbsd | 4 + .../signals001.stdout-x86_64-unknown-openbsd | 4 + libraries/unix/tests/signals002.hs | 15 + libraries/unix/tests/signals002.stdout | 2 + libraries/unix/tests/signals004.hs | 26 + libraries/unix/tests/user001.hs | 27 + libraries/unix/tests/user001.stdout | 11 + libraries/unix/unix.buildinfo.in | 3 + libraries/unix/unix.cabal | 133 + libraries/xhtml/.gitignore | 7 + libraries/xhtml/GNUmakefile | 4 + libraries/xhtml/LICENSE | 31 + libraries/xhtml/README | 2 + libraries/xhtml/Setup.hs | 6 + libraries/xhtml/Text/XHtml.hs | 70 + libraries/xhtml/Text/XHtml/BlockTable.hs | 168 + libraries/xhtml/Text/XHtml/Debug.hs | 116 + libraries/xhtml/Text/XHtml/Extras.hs | 133 + libraries/xhtml/Text/XHtml/Frameset.hs | 57 + .../xhtml/Text/XHtml/Frameset/Attributes.hs | 26 + .../xhtml/Text/XHtml/Frameset/Elements.hs | 20 + libraries/xhtml/Text/XHtml/Internals.hs | 360 + libraries/xhtml/Text/XHtml/Strict.hs | 66 + .../xhtml/Text/XHtml/Strict/Attributes.hs | 112 + libraries/xhtml/Text/XHtml/Strict/Elements.hs | 167 + libraries/xhtml/Text/XHtml/Table.hs | 120 + libraries/xhtml/Text/XHtml/Transitional.hs | 63 + .../Text/XHtml/Transitional/Attributes.hs | 123 + .../xhtml/Text/XHtml/Transitional/Elements.hs | 51 + libraries/xhtml/ghc.mk | 5 + libraries/xhtml/xhtml.cabal | 44 + mk/build.mk.sample | 314 + mk/compiler-ghc.mk | 58 + mk/config.h.in | 413 + mk/config.mk.in | 817 + mk/custom-settings.mk | 14 + mk/fptools.css | 41 + mk/get-win32-tarballs.sh | 144 + mk/install.mk.in | 187 + mk/project.mk.in | 165 + mk/sub-makefile.mk | 62 + mk/tree.mk | 72 + mk/validate-settings.mk | 190 + mk/ways.mk | 116 + packages | 70 + rts/.dir-locals.el | 13 + rts/Adjustor.c | 1323 + rts/AdjustorAsm.S | 198 + rts/Apply.cmm | 403 + rts/Apply.h | 26 + rts/Arena.c | 119 + rts/Arena.h | 25 + rts/AutoApply.h | 91 + rts/AwaitEvent.h | 24 + rts/BeginPrivate.h | 10 + rts/Capability.c | 1171 + rts/Capability.h | 428 + rts/CheckUnload.c | 324 + rts/CheckUnload.h | 20 + rts/ClosureFlags.c | 93 + rts/Disassembler.c | 317 + rts/Disassembler.h | 19 + rts/EndPrivate.h | 3 + rts/Exception.cmm | 628 + rts/FileLock.c | 145 + rts/FileLock.h | 15 + rts/GetEnv.h | 23 + rts/GetTime.h | 31 + rts/Globals.c | 142 + rts/Globals.h | 18 + rts/Hash.c | 430 + rts/Hash.h | 61 + rts/HeapStackCheck.cmm | 711 + rts/Hpc.c | 406 + rts/HsFFI.c | 68 + rts/Inlines.c | 9 + rts/Interpreter.c | 1524 + rts/Interpreter.h | 14 + rts/LdvProfile.c | 251 + rts/LdvProfile.h | 41 + rts/Linker.c | 7454 +++ rts/LinkerInternals.h | 156 + rts/Makefile | 17 + rts/Messages.c | 346 + rts/Messages.h | 30 + rts/OldARMAtomic.c | 57 + rts/Papi.c | 396 + rts/Papi.h | 36 + rts/PosixSource.h | 42 + rts/Prelude.h | 148 + rts/PrimOps.cmm | 2426 + rts/Printer.c | 1036 + rts/Printer.h | 41 + rts/ProfHeap.c | 1149 + rts/ProfHeap.h | 21 + rts/Profiling.c | 1147 + rts/Profiling.h | 48 + rts/Proftimer.c | 91 + rts/Proftimer.h | 24 + rts/RaiseAsync.c | 1099 + rts/RaiseAsync.h | 86 + rts/RetainerProfile.c | 2288 + rts/RetainerProfile.h | 53 + rts/RetainerSet.c | 493 + rts/RetainerSet.h | 205 + rts/RtsAPI.c | 622 + rts/RtsDllMain.c | 43 + rts/RtsDllMain.h | 15 + rts/RtsFlags.c | 1880 + rts/RtsFlags.h | 27 + rts/RtsMain.c | 119 + rts/RtsMessages.c | 285 + rts/RtsProbes.d | 109 + rts/RtsSignals.h | 67 + rts/RtsStartup.c | 556 + rts/RtsUtils.c | 331 + rts/RtsUtils.h | 50 + rts/STM.c | 1698 + rts/STM.h | 223 + rts/Schedule.c | 2894 ++ rts/Schedule.h | 260 + rts/Sparks.c | 312 + rts/Sparks.h | 108 + rts/Stable.c | 551 + rts/Stable.h | 54 + rts/StaticPtrTable.c | 104 + rts/StaticPtrTable.h | 19 + rts/Stats.c | 987 + rts/Stats.h | 77 + rts/StgCRun.c | 831 + rts/StgMiscClosures.cmm | 984 + rts/StgPrimFloat.c | 233 + rts/StgPrimFloat.h | 24 + rts/StgRun.h | 18 + rts/StgStartup.cmm | 182 + rts/StgStdThunks.cmm | 286 + rts/Task.c | 518 + rts/Task.h | 342 + rts/ThreadLabels.c | 84 + rts/ThreadLabels.h | 27 + rts/ThreadPaused.c | 384 + rts/ThreadPaused.h | 14 + rts/Threads.c | 864 + rts/Threads.h | 54 + rts/Ticker.h | 23 + rts/Ticky.c | 621 + rts/Ticky.h | 14 + rts/Timer.c | 135 + rts/Timer.h | 15 + rts/Trace.c | 807 + rts/Trace.h | 882 + rts/Updates.cmm | 103 + rts/Updates.h | 93 + rts/WSDeque.c | 295 + rts/WSDeque.h | 126 + rts/Weak.c | 146 + rts/Weak.h | 27 + rts/eventlog/EventLog.c | 1265 + rts/eventlog/EventLog.h | 172 + rts/ghc.mk | 587 + rts/hooks/FlagDefaults.c | 21 + rts/hooks/MallocFail.c | 17 + rts/hooks/OnExit.c | 20 + rts/hooks/OutOfHeap.c | 24 + rts/hooks/StackOverflow.c | 17 + rts/package.conf.in | 173 + rts/posix/Clock.h | 35 + rts/posix/GetEnv.c | 44 + rts/posix/GetTime.c | 249 + rts/posix/Itimer.c | 282 + rts/posix/Itimer.h | 12 + rts/posix/OSMem.c | 320 + rts/posix/OSThreads.c | 360 + rts/posix/Select.c | 454 + rts/posix/Select.h | 17 + rts/posix/Signals.c | 697 + rts/posix/Signals.h | 33 + rts/posix/TTY.c | 67 + rts/posix/TTY.h | 14 + rts/sm/BlockAlloc.c | 896 + rts/sm/BlockAlloc.h | 34 + rts/sm/Compact.c | 1026 + rts/sm/Compact.h | 53 + rts/sm/Evac.c | 1110 + rts/sm/Evac.h | 43 + rts/sm/GC.c | 1750 + rts/sm/GC.h | 66 + rts/sm/GCAux.c | 148 + rts/sm/GCTDecl.h | 146 + rts/sm/GCThread.h | 212 + rts/sm/GCUtils.c | 345 + rts/sm/GCUtils.h | 68 + rts/sm/MBlock.c | 288 + rts/sm/MarkStack.h | 71 + rts/sm/MarkWeak.c | 423 + rts/sm/MarkWeak.h | 30 + rts/sm/OSMem.h | 25 + rts/sm/Sanity.c | 938 + rts/sm/Sanity.h | 46 + rts/sm/Scav.c | 2086 + rts/sm/Scav.h | 32 + rts/sm/Storage.c | 1473 + rts/sm/Storage.h | 165 + rts/sm/Sweep.c | 86 + rts/sm/Sweep.h | 19 + rts/win32/AsyncIO.c | 383 + rts/win32/AsyncIO.h | 27 + rts/win32/AwaitEvent.c | 57 + rts/win32/ConsoleHandler.c | 351 + rts/win32/ConsoleHandler.h | 64 + rts/win32/GetEnv.c | 62 + rts/win32/GetTime.c | 162 + rts/win32/IOManager.c | 608 + rts/win32/IOManager.h | 107 + rts/win32/OSMem.c | 418 + rts/win32/OSThreads.c | 324 + rts/win32/ThrIOManager.c | 159 + rts/win32/Ticker.c | 81 + rts/win32/WorkQueue.c | 225 + rts/win32/WorkQueue.h | 38 + rts/win32/libHSbase.def | 44 + rts/win32/libHSffi.def | 19 + rts/win32/libHSghc-prim.def | 14 + rts/win32/seh_excn.c | 50 + rts/win32/seh_excn.h | 92 + rules/add-dependency.mk | 15 + rules/all-target.mk | 18 + rules/bindist.mk | 32 + rules/build-dependencies.mk | 156 + rules/build-package-data.mk | 137 + rules/build-package-way.mk | 177 + rules/build-package.mk | 164 + rules/build-perl.mk | 83 + rules/build-prog.mk | 323 + rules/c-objs.mk | 17 + rules/c-sources.mk | 17 + rules/c-suffix-rules.mk | 64 + rules/clean-target.mk | 21 + rules/cmm-objs.mk | 16 + rules/cmm-suffix-rules.mk | 52 + rules/cross-compiling.mk | 24 + rules/dependencies.mk | 38 + rules/distdir-opts.mk | 114 + rules/distdir-way-opts.mk | 199 + rules/docbook.mk | 86 + rules/foreachLibrary.mk | 58 + rules/haddock.mk | 81 + rules/hi-rule.mk | 110 + rules/hs-objs.mk | 17 + rules/hs-sources.mk | 58 + rules/hs-suffix-rules-srcdir.mk | 50 + rules/hs-suffix-way-rules-srcdir.mk | 88 + rules/hs-suffix-way-rules.mk | 54 + rules/include-dependencies.mk | 45 + rules/includes-sources.mk | 26 + rules/library-path.mk | 21 + rules/make-command.mk | 21 + rules/manual-package-config.mk | 42 + rules/package-config.mk | 69 + rules/pretty_commands.mk | 13 + rules/prof.mk | 20 + rules/shell-wrapper.mk | 113 + rules/tags-package.mk | 36 + rules/trace.mk | 21 + rules/way-prelims.mk | 36 + settings.in | 33 + utils/checkUniques/Makefile | 16 + utils/checkUniques/checkUniques.hs | 113 + utils/compare_sizes/LICENSE | 31 + utils/compare_sizes/Main.hs | 175 + utils/compare_sizes/compareSizes.cabal | 21 + utils/compare_sizes/ghc.mk | 9 + utils/completion/README | 43 + utils/completion/ghc.bash | 60 + utils/count_lines/count_lines.lprl | 74 + utils/count_lines/ghc.mk | 5 + utils/coverity/model.c | 112 + utils/debugNCG/Diff_Gcc_Nat.hs | 380 + utils/debugNCG/Makefile | 19 + utils/debugNCG/README | 46 + utils/deriveConstants/DeriveConstants.hs | 912 + utils/deriveConstants/Makefile | 15 + utils/deriveConstants/ghc.mk | 19 + .../describe-unexpected.hs | 25 + utils/dll-split/Main.hs | 82 + utils/dll-split/dll-split.cabal | 22 + utils/dll-split/ghc.mk | 18 + utils/fingerprint/fingerprint.py | 255 + utils/genapply/GenApply.hs | 1040 + utils/genapply/Makefile | 15 + utils/genapply/ghc.mk | 27 + utils/genargs/Makefile | 8 + utils/genargs/genargs.pl | 65 + utils/genprimopcode/Lexer.hs | 356 + utils/genprimopcode/Lexer.x.source | 90 + utils/genprimopcode/Main.hs | 953 + utils/genprimopcode/Makefile | 15 + utils/genprimopcode/Parser.hs | 1175 + utils/genprimopcode/Parser.y.source | 203 + utils/genprimopcode/ParserM.hs | 180 + utils/genprimopcode/Syntax.hs | 177 + utils/genprimopcode/ghc.mk | 18 + utils/ghc-cabal/Main.hs | 516 + utils/ghc-cabal/Makefile | 15 + utils/ghc-cabal/cabal_macros_boot.h | 21 + utils/ghc-cabal/ghc-cabal.cabal | 23 + utils/ghc-cabal/ghc.mk | 72 + utils/ghc-pkg/CRT_noglob.c | 4 + utils/ghc-pkg/Main.hs | 2084 + utils/ghc-pkg/Makefile | 15 + utils/ghc-pkg/ghc-pkg.cabal | 34 + utils/ghc-pkg/ghc-pkg.wrapper | 5 + utils/ghc-pkg/ghc.mk | 84 + utils/ghc-pwd/Main.hs | 22 + utils/ghc-pwd/Setup.hs | 2 + utils/ghc-pwd/ghc-pwd.cabal | 19 + utils/ghc-pwd/ghc.mk | 9 + utils/ghctags/Main.hs | 361 + utils/ghctags/README | 13 + utils/ghctags/ghc.mk | 18 + utils/ghctags/ghctags.cabal | 23 + utils/haddock/.arcconfig | 5 + utils/haddock/.arclint | 24 + utils/haddock/.ghci | 1 + utils/haddock/.gitignore | 19 + utils/haddock/.travis.yml | 27 + utils/haddock/CHANGES | 710 + utils/haddock/CONTRIBUTING | 17 + utils/haddock/LICENSE | 23 + utils/haddock/Makefile | 15 + utils/haddock/README.md | 72 + utils/haddock/STYLE | 3 + utils/haddock/Setup.lhs | 3 + utils/haddock/build-windows-dist.sh | 18 + utils/haddock/dist/build/.depend.c_asm | 1 + utils/haddock/dist/build/.depend.haskell | 677 + utils/haddock/dist/build/.depend.haskell.tmp | 629 + utils/haddock/dist/build/.depend.haskell.tmp2 | 629 + .../dist/build/autogen/Paths_haddock.hs | 35 + .../haddock/dist/build/autogen/cabal_macros.h | 165 + utils/haddock/dist/build/tmp/haddock | Bin 0 -> 3562336 bytes utils/haddock/dist/haddock-prologue.txt | 2 + utils/haddock/dist/package-data.mk | 36 + utils/haddock/dist/setup-config | Bin 0 -> 167501 bytes utils/haddock/doc/Makefile | 6 + utils/haddock/doc/README.md | 25 + utils/haddock/doc/aclocal.m4 | 174 + utils/haddock/doc/config.mk.in | 15 + utils/haddock/doc/configure.ac | 12 + utils/haddock/doc/docbook-xml.mk | 130 + utils/haddock/doc/fptools.css | 36 + utils/haddock/doc/ghc.mk | 15 + utils/haddock/doc/haddock.pdf | Bin 0 -> 193208 bytes utils/haddock/doc/haddock.ps | 11535 +++++ utils/haddock/doc/haddock.xml | 2270 + utils/haddock/doc/haddock/ch01s03.html | 6 + utils/haddock/doc/haddock/ch01s04.html | 8 + utils/haddock/doc/haddock/ch03s02.html | 60 + utils/haddock/doc/haddock/ch03s03.html | 50 + utils/haddock/doc/haddock/ch03s04.html | 102 + utils/haddock/doc/haddock/ch03s05.html | 30 + utils/haddock/doc/haddock/ch03s08.html | 313 + utils/haddock/doc/haddock/fptools.css | 41 + utils/haddock/doc/haddock/hyperlinking.html | 48 + utils/haddock/doc/haddock/index.html | 2 + utils/haddock/doc/haddock/introduction.html | 53 + utils/haddock/doc/haddock/invoking.html | 384 + utils/haddock/doc/haddock/ix01.html | 1 + utils/haddock/doc/haddock/license.html | 21 + utils/haddock/doc/haddock/markup.html | 50 + .../doc/haddock/module-attributes.html | 41 + utils/haddock/driver/Main.hs | 29 + utils/haddock/ghc.mk | 71 + utils/haddock/haddock-api/.ghci | 1 + utils/haddock/haddock-api/LICENSE | 23 + utils/haddock/haddock-api/Setup.lhs | 3 + utils/haddock/haddock-api/haddock-api.cabal | 94 + .../html/Classic.theme/haskell_icon.gif | Bin 0 -> 911 bytes .../resources/html/Classic.theme/minus.gif | Bin 0 -> 56 bytes .../resources/html/Classic.theme/plus.gif | Bin 0 -> 59 bytes .../resources/html/Classic.theme/xhaddock.css | 499 + .../html/Ocean.std-theme/hslogo-16.png | Bin 0 -> 1684 bytes .../resources/html/Ocean.std-theme/minus.gif | Bin 0 -> 56 bytes .../resources/html/Ocean.std-theme/ocean.css | 600 + .../resources/html/Ocean.std-theme/plus.gif | Bin 0 -> 59 bytes .../html/Ocean.std-theme/synopsis.png | Bin 0 -> 11327 bytes .../haddock-api/resources/html/frames.html | 30 + .../resources/html/haddock-util.js | 344 + .../haddock-api/resources/latex/haddock.sty | 57 + .../haddock-api/src/Documentation/Haddock.hs | 89 + utils/haddock/haddock-api/src/Haddock.hs | 525 + .../src/Haddock/Backends/HaddockDB.hs | 170 + .../src/Haddock/Backends/Hoogle.hs | 360 + .../haddock-api/src/Haddock/Backends/LaTeX.hs | 1235 + .../haddock-api/src/Haddock/Backends/Xhtml.hs | 686 + .../src/Haddock/Backends/Xhtml/Decl.hs | 919 + .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 250 + .../src/Haddock/Backends/Xhtml/Layout.hs | 257 + .../src/Haddock/Backends/Xhtml/Names.hs | 171 + .../src/Haddock/Backends/Xhtml/Themes.hs | 207 + .../src/Haddock/Backends/Xhtml/Types.hs | 37 + .../src/Haddock/Backends/Xhtml/Utils.hs | 218 + .../haddock-api/src/Haddock/Convert.hs | 412 + utils/haddock/haddock-api/src/Haddock/Doc.hs | 34 + .../haddock-api/src/Haddock/GhcUtils.hs | 268 + .../haddock-api/src/Haddock/Interface.hs | 244 + .../src/Haddock/Interface/AttachInstances.hs | 243 + .../src/Haddock/Interface/Create.hs | 874 + .../src/Haddock/Interface/LexParseRn.hs | 157 + .../Haddock/Interface/ParseModuleHeader.hs | 149 + .../src/Haddock/Interface/Rename.hs | 532 + .../haddock-api/src/Haddock/InterfaceFile.hs | 648 + .../haddock-api/src/Haddock/ModuleTree.hs | 62 + .../haddock-api/src/Haddock/Options.hs | 308 + .../haddock/haddock-api/src/Haddock/Parser.hs | 44 + .../haddock/haddock-api/src/Haddock/Types.hs | 552 + .../haddock/haddock-api/src/Haddock/Utils.hs | 479 + .../haddock-api/src/Haddock/Version.hs | 30 + utils/haddock/haddock-api/src/haddock.sh | 7 + utils/haddock/haddock-library/.ghci | 1 + utils/haddock/haddock-library/LICENSE | 23 + utils/haddock/haddock-library/Setup.hs | 2 + .../haddock-library/haddock-library.cabal | 84 + .../src/Documentation/Haddock/Doc.hs | 89 + .../src/Documentation/Haddock/Parser.hs | 577 + .../src/Documentation/Haddock/Parser/Monad.hs | 149 + .../src/Documentation/Haddock/Parser/Util.hs | 80 + .../src/Documentation/Haddock/Types.hs | 78 + .../src/Documentation/Haddock/Utf8.hs | 74 + .../Documentation/Haddock/Parser/UtilSpec.hs | 23 + .../test/Documentation/Haddock/ParserSpec.hs | 968 + .../test/Documentation/Haddock/Utf8Spec.hs | 14 + utils/haddock/haddock-library/test/Spec.hs | 1 + .../attoparsec-0.12.1.1/Data/Attoparsec.hs | 23 + .../Data/Attoparsec/ByteString.hs | 223 + .../Data/Attoparsec/ByteString/Buffer.hs | 151 + .../Data/Attoparsec/ByteString/Char8.hs | 469 + .../Data/Attoparsec/ByteString/FastSet.hs | 115 + .../Data/Attoparsec/ByteString/Internal.hs | 485 + .../Data/Attoparsec/Combinator.hs | 220 + .../Data/Attoparsec/Internal.hs | 142 + .../Data/Attoparsec/Internal/Fhthagn.hs | 18 + .../Data/Attoparsec/Internal/Types.hs | 230 + .../Data/Attoparsec/Number.hs | 137 + .../vendor/attoparsec-0.12.1.1/LICENSE | 30 + utils/haddock/haddock.cabal | 131 + utils/haddock/haddock.wrapper | 3 + utils/haddock/html-test/README.markdown | 27 + utils/haddock/html-test/accept.lhs | 49 + utils/haddock/html-test/ref/A.html | 179 + utils/haddock/html-test/ref/AdvanceTypes.html | 97 + utils/haddock/html-test/ref/B.html | 171 + utils/haddock/html-test/ref/Bold.html | 99 + utils/haddock/html-test/ref/Bug1.html | 102 + utils/haddock/html-test/ref/Bug195.html | 179 + utils/haddock/html-test/ref/Bug2.html | 65 + utils/haddock/html-test/ref/Bug201.html | 102 + utils/haddock/html-test/ref/Bug253.html | 99 + utils/haddock/html-test/ref/Bug26.html | 177 + utils/haddock/html-test/ref/Bug294.html | 171 + utils/haddock/html-test/ref/Bug298.html | 133 + utils/haddock/html-test/ref/Bug3.html | 82 + utils/haddock/html-test/ref/Bug308.html | 111 + .../html-test/ref/Bug308CrossModule.html | 91 + utils/haddock/html-test/ref/Bug310.html | 89 + utils/haddock/html-test/ref/Bug313.html | 132 + utils/haddock/html-test/ref/Bug335.html | 125 + utils/haddock/html-test/ref/Bug387.html | 111 + utils/haddock/html-test/ref/Bug4.html | 81 + utils/haddock/html-test/ref/Bug6.html | 329 + utils/haddock/html-test/ref/Bug7.html | 172 + utils/haddock/html-test/ref/Bug8.html | 141 + utils/haddock/html-test/ref/Bug85.html | 135 + .../haddock/html-test/ref/BugDeprecated.html | 185 + .../html-test/ref/BugExportHeadings.html | 205 + utils/haddock/html-test/ref/Bugs.html | 81 + .../html-test/ref/CrossPackageDocs.html | 287 + .../html-test/ref/DeprecatedClass.html | 155 + .../haddock/html-test/ref/DeprecatedData.html | 189 + .../html-test/ref/DeprecatedFunction.html | 107 + .../html-test/ref/DeprecatedFunction2.html | 83 + .../html-test/ref/DeprecatedFunction3.html | 83 + .../html-test/ref/DeprecatedModule.html | 81 + .../html-test/ref/DeprecatedModule2.html | 75 + .../html-test/ref/DeprecatedNewtype.html | 155 + .../html-test/ref/DeprecatedReExport.html | 124 + .../html-test/ref/DeprecatedRecord.html | 147 + .../html-test/ref/DeprecatedTypeFamily.html | 105 + .../html-test/ref/DeprecatedTypeSynonym.html | 113 + utils/haddock/html-test/ref/Examples.html | 174 + utils/haddock/html-test/ref/Extensions.html | 89 + utils/haddock/html-test/ref/FunArgs.html | 281 + utils/haddock/html-test/ref/GADTRecords.html | 231 + utils/haddock/html-test/ref/Hash.html | 330 + .../html-test/ref/HiddenInstances.html | 171 + .../html-test/ref/HiddenInstancesB.html | 143 + utils/haddock/html-test/ref/Hyperlinks.html | 87 + .../haddock/html-test/ref/IgnoreExports.html | 99 + .../haddock/html-test/ref/ImplicitParams.html | 111 + utils/haddock/html-test/ref/Minimal.html | 297 + .../html-test/ref/ModuleWithWarning.html | 81 + utils/haddock/html-test/ref/NamedDoc.html | 67 + utils/haddock/html-test/ref/Nesting.html | 345 + utils/haddock/html-test/ref/NoLayout.html | 85 + utils/haddock/html-test/ref/NonGreedy.html | 81 + utils/haddock/html-test/ref/Operators.html | 461 + utils/haddock/html-test/ref/PatternSyns.html | 257 + utils/haddock/html-test/ref/Properties.html | 91 + .../html-test/ref/PruneWithWarning.html | 70 + utils/haddock/html-test/ref/QuasiExpr.html | 225 + utils/haddock/html-test/ref/QuasiQuote.html | 65 + .../ref/SpuriousSuperclassConstraints.html | 125 + utils/haddock/html-test/ref/TH.html | 63 + utils/haddock/html-test/ref/TH2.html | 63 + utils/haddock/html-test/ref/Test.html | 2123 + utils/haddock/html-test/ref/Threaded.html | 94 + utils/haddock/html-test/ref/Ticket112.html | 81 + utils/haddock/html-test/ref/Ticket61.html | 79 + utils/haddock/html-test/ref/Ticket75.html | 115 + .../haddock/html-test/ref/TitledPicture.html | 109 + utils/haddock/html-test/ref/TypeFamilies.html | 1117 + .../haddock/html-test/ref/TypeFamilies2.html | 241 + .../haddock/html-test/ref/TypeOperators.html | 173 + utils/haddock/html-test/ref/Unicode.html | 81 + utils/haddock/html-test/ref/Visible.html | 67 + utils/haddock/html-test/ref/frames.html | 30 + utils/haddock/html-test/ref/haddock-util.js | 344 + utils/haddock/html-test/ref/hslogo-16.png | Bin 0 -> 1684 bytes utils/haddock/html-test/ref/mini_A.html | 59 + .../html-test/ref/mini_AdvanceTypes.html | 33 + utils/haddock/html-test/ref/mini_B.html | 45 + utils/haddock/html-test/ref/mini_Bug1.html | 33 + utils/haddock/html-test/ref/mini_Bug2.html | 31 + utils/haddock/html-test/ref/mini_Bug3.html | 31 + utils/haddock/html-test/ref/mini_Bug4.html | 31 + utils/haddock/html-test/ref/mini_Bug6.html | 65 + utils/haddock/html-test/ref/mini_Bug7.html | 41 + utils/haddock/html-test/ref/mini_Bug8.html | 63 + .../html-test/ref/mini_BugDeprecated.html | 61 + .../html-test/ref/mini_BugExportHeadings.html | 73 + utils/haddock/html-test/ref/mini_Bugs.html | 33 + .../html-test/ref/mini_CrossPackageDocs.html | 45 + .../html-test/ref/mini_DeprecatedClass.html | 41 + .../html-test/ref/mini_DeprecatedData.html | 41 + .../ref/mini_DeprecatedFunction.html | 37 + .../ref/mini_DeprecatedFunction2.html | 31 + .../ref/mini_DeprecatedFunction3.html | 31 + .../html-test/ref/mini_DeprecatedModule.html | 31 + .../html-test/ref/mini_DeprecatedModule2.html | 31 + .../html-test/ref/mini_DeprecatedNewtype.html | 41 + .../ref/mini_DeprecatedReExport.html | 35 + .../html-test/ref/mini_DeprecatedRecord.html | 33 + .../ref/mini_DeprecatedTypeFamily.html | 41 + .../ref/mini_DeprecatedTypeSynonym.html | 41 + .../haddock/html-test/ref/mini_Examples.html | 31 + utils/haddock/html-test/ref/mini_FunArgs.html | 37 + .../html-test/ref/mini_GADTRecords.html | 33 + utils/haddock/html-test/ref/mini_Hash.html | 71 + .../html-test/ref/mini_HiddenInstances.html | 41 + .../html-test/ref/mini_HiddenInstancesB.html | 41 + .../html-test/ref/mini_Hyperlinks.html | 31 + .../html-test/ref/mini_IgnoreExports.html | 37 + .../html-test/ref/mini_ModuleWithWarning.html | 31 + .../haddock/html-test/ref/mini_NamedDoc.html | 25 + .../haddock/html-test/ref/mini_NoLayout.html | 31 + .../haddock/html-test/ref/mini_NonGreedy.html | 31 + .../html-test/ref/mini_Properties.html | 31 + .../html-test/ref/mini_PruneWithWarning.html | 25 + .../haddock/html-test/ref/mini_QuasiExpr.html | 59 + .../html-test/ref/mini_QuasiQuote.html | 31 + .../mini_SpuriousSuperclassConstraints.html | 33 + utils/haddock/html-test/ref/mini_TH.html | 31 + utils/haddock/html-test/ref/mini_TH2.html | 31 + utils/haddock/html-test/ref/mini_Test.html | 257 + .../haddock/html-test/ref/mini_Ticket112.html | 31 + .../html-test/ref/mini_Ticket253_1.html | 31 + .../html-test/ref/mini_Ticket253_2.html | 39 + .../haddock/html-test/ref/mini_Ticket61.html | 33 + .../haddock/html-test/ref/mini_Ticket75.html | 39 + .../html-test/ref/mini_TitledPicture.html | 37 + .../html-test/ref/mini_TypeFamilies.html | 105 + .../html-test/ref/mini_TypeOperators.html | 95 + utils/haddock/html-test/ref/mini_Unicode.html | 31 + utils/haddock/html-test/ref/mini_Visible.html | 31 + utils/haddock/html-test/ref/minus.gif | Bin 0 -> 56 bytes utils/haddock/html-test/ref/ocean.css | 600 + utils/haddock/html-test/ref/plus.gif | Bin 0 -> 59 bytes utils/haddock/html-test/ref/synopsis.png | Bin 0 -> 11327 bytes utils/haddock/html-test/run.lhs | 191 + utils/haddock/html-test/src/A.hs | 17 + utils/haddock/html-test/src/AdvanceTypes.hs | 9 + utils/haddock/html-test/src/B.hs | 8 + utils/haddock/html-test/src/Bold.hs | 9 + utils/haddock/html-test/src/Bug1.hs | 6 + utils/haddock/html-test/src/Bug195.hs | 11 + utils/haddock/html-test/src/Bug2.hs | 4 + utils/haddock/html-test/src/Bug201.hs | 28 + utils/haddock/html-test/src/Bug253.hs | 10 + utils/haddock/html-test/src/Bug26.hs | 29 + utils/haddock/html-test/src/Bug294.hs | 37 + utils/haddock/html-test/src/Bug298.hs | 22 + utils/haddock/html-test/src/Bug3.hs | 6 + utils/haddock/html-test/src/Bug308.hs | 21 + .../html-test/src/Bug308CrossModule.hs | 17 + utils/haddock/html-test/src/Bug310.hs | 4 + utils/haddock/html-test/src/Bug313.hs | 37 + utils/haddock/html-test/src/Bug335.hs | 26 + utils/haddock/html-test/src/Bug387.hs | 12 + utils/haddock/html-test/src/Bug4.hs | 5 + utils/haddock/html-test/src/Bug6.hs | 23 + utils/haddock/html-test/src/Bug7.hs | 13 + utils/haddock/html-test/src/Bug8.hs | 15 + utils/haddock/html-test/src/Bug85.hs | 14 + utils/haddock/html-test/src/BugDeprecated.hs | 26 + .../html-test/src/BugExportHeadings.hs | 29 + utils/haddock/html-test/src/Bugs.hs | 3 + .../html-test/src/CrossPackageDocs.hs_hidden | 4 + .../haddock/html-test/src/DeprecatedClass.hs | 15 + utils/haddock/html-test/src/DeprecatedData.hs | 15 + .../html-test/src/DeprecatedFunction.hs | 10 + .../html-test/src/DeprecatedFunction2.hs | 6 + .../html-test/src/DeprecatedFunction3.hs | 6 + .../haddock/html-test/src/DeprecatedModule.hs | 5 + .../html-test/src/DeprecatedModule2.hs | 4 + .../html-test/src/DeprecatedNewtype.hs | 10 + .../html-test/src/DeprecatedReExport.hs | 16 + .../haddock/html-test/src/DeprecatedRecord.hs | 9 + .../html-test/src/DeprecatedTypeFamily.hs | 9 + .../html-test/src/DeprecatedTypeSynonym.hs | 9 + utils/haddock/html-test/src/Examples.hs | 39 + utils/haddock/html-test/src/Extensions.hs | 7 + utils/haddock/html-test/src/FunArgs.hs | 38 + utils/haddock/html-test/src/GADTRecords.hs | 11 + utils/haddock/html-test/src/Hash.hs | 51 + utils/haddock/html-test/src/Hidden.hs | 6 + .../haddock/html-test/src/HiddenInstances.hs | 35 + .../haddock/html-test/src/HiddenInstancesA.hs | 17 + .../haddock/html-test/src/HiddenInstancesB.hs | 2 + utils/haddock/html-test/src/Hyperlinks.hs | 8 + utils/haddock/html-test/src/IgnoreExports.hs | 10 + utils/haddock/html-test/src/ImplicitParams.hs | 13 + utils/haddock/html-test/src/Minimal.hs | 53 + .../html-test/src/ModuleWithWarning.hs | 5 + utils/haddock/html-test/src/NamedDoc.hs | 4 + utils/haddock/html-test/src/Nesting.hs | 136 + utils/haddock/html-test/src/NoLayout.hs | 12 + utils/haddock/html-test/src/NonGreedy.hs | 5 + utils/haddock/html-test/src/Operators.hs | 64 + utils/haddock/html-test/src/PatternSyns.hs | 22 + utils/haddock/html-test/src/Properties.hs | 9 + .../haddock/html-test/src/PruneWithWarning.hs | 15 + utils/haddock/html-test/src/QuasiExpr.hs | 34 + utils/haddock/html-test/src/QuasiQuote.hs | 9 + .../src/SpuriousSuperclassConstraints.hs | 30 + utils/haddock/html-test/src/TH.hs | 8 + utils/haddock/html-test/src/TH2.hs | 7 + utils/haddock/html-test/src/Test.hs | 423 + utils/haddock/html-test/src/Threaded.hs | 10 + utils/haddock/html-test/src/Threaded_TH.hs | 13 + utils/haddock/html-test/src/Ticket112.hs | 9 + utils/haddock/html-test/src/Ticket61.hs | 3 + .../haddock/html-test/src/Ticket61_Hidden.hs | 7 + utils/haddock/html-test/src/Ticket75.hs | 8 + utils/haddock/html-test/src/TitledPicture.hs | 7 + utils/haddock/html-test/src/TypeFamilies.hs | 92 + utils/haddock/html-test/src/TypeFamilies2.hs | 39 + utils/haddock/html-test/src/TypeOperators.hs | 27 + utils/haddock/html-test/src/Unicode.hs | 6 + utils/haddock/html-test/src/Visible.hs | 3 + utils/haddock/latex-test/accept.lhs | 46 + .../haddock/latex-test/ref/Simple/Simple.tex | 17 + .../haddock/latex-test/ref/Simple/haddock.sty | 57 + utils/haddock/latex-test/ref/Simple/main.tex | 11 + utils/haddock/latex-test/run.lhs | 162 + utils/haddock/latex-test/src/Simple/Simple.hs | 5 + utils/haddock/make-sdist.sh | 36 + utils/hp2ps/AreaBelow.c | 62 + utils/hp2ps/AreaBelow.h | 6 + utils/hp2ps/AuxFile.c | 164 + utils/hp2ps/AuxFile.h | 7 + utils/hp2ps/Axes.c | 241 + utils/hp2ps/Axes.h | 6 + utils/hp2ps/CHANGES | 37 + utils/hp2ps/Curves.c | 158 + utils/hp2ps/Curves.h | 10 + utils/hp2ps/Defines.h | 61 + utils/hp2ps/Deviation.c | 138 + utils/hp2ps/Deviation.h | 7 + utils/hp2ps/Dimensions.c | 205 + utils/hp2ps/Dimensions.h | 22 + utils/hp2ps/Error.c | 59 + utils/hp2ps/Error.h | 8 + utils/hp2ps/HpFile.c | 594 + utils/hp2ps/HpFile.h | 77 + utils/hp2ps/Key.c | 88 + utils/hp2ps/Key.h | 6 + utils/hp2ps/Main.c | 257 + utils/hp2ps/Main.h | 79 + utils/hp2ps/Makefile | 15 + utils/hp2ps/Marks.c | 42 + utils/hp2ps/Marks.h | 6 + utils/hp2ps/PsFile.c | 295 + utils/hp2ps/PsFile.h | 7 + utils/hp2ps/README.GHC | 4 + utils/hp2ps/Reorder.c | 86 + utils/hp2ps/Reorder.h | 8 + utils/hp2ps/Scale.c | 86 + utils/hp2ps/Scale.h | 7 + utils/hp2ps/Shade.c | 124 + utils/hp2ps/Shade.h | 8 + utils/hp2ps/TopTwenty.c | 72 + utils/hp2ps/TopTwenty.h | 6 + utils/hp2ps/TraceElement.c | 96 + utils/hp2ps/TraceElement.h | 6 + utils/hp2ps/Utilities.c | 122 + utils/hp2ps/Utilities.h | 13 + utils/hp2ps/ghc.mk | 26 + utils/hp2ps/hp2ps.1 | 147 + utils/hp2ps/makefile.original | 42 + utils/hpc/HpcCombine.hs | 198 + utils/hpc/HpcDraft.hs | 145 + utils/hpc/HpcFlags.hs | 267 + utils/hpc/HpcLexer.hs | 57 + utils/hpc/HpcMarkup.hs | 500 + utils/hpc/HpcOverlay.hs | 159 + utils/hpc/HpcParser.hs | 722 + utils/hpc/HpcParser.y.source | 122 + utils/hpc/HpcReport.hs | 279 + utils/hpc/HpcShowTix.hs | 64 + utils/hpc/HpcUtils.hs | 35 + utils/hpc/Main.hs | 140 + utils/hpc/Makefile | 15 + utils/hpc/ghc.mk | 21 + utils/hpc/hpc-bin.cabal | 49 + utils/hpc/hpc.wrapper | 2 + utils/hsc2hs/.gitignore | 2 + utils/hsc2hs/C.hs | 208 + utils/hsc2hs/Common.hs | 67 + utils/hsc2hs/CrossCodegen.hs | 598 + utils/hsc2hs/DirectCodegen.hs | 109 + utils/hsc2hs/Flags.hs | 138 + utils/hsc2hs/HSCParser.hs | 320 + utils/hsc2hs/LICENSE | 31 + utils/hsc2hs/Main.hs | 234 + utils/hsc2hs/Makefile | 15 + utils/hsc2hs/Makefile.inc | 7 + utils/hsc2hs/Makefile.nhc98 | 79 + utils/hsc2hs/Setup.hs | 2 + utils/hsc2hs/UtilsCodegen.hs | 86 + utils/hsc2hs/ghc.mk | 54 + utils/hsc2hs/hsc2hs.cabal | 44 + utils/hsc2hs/hsc2hs.wrapper | 21 + utils/hsc2hs/template-hsc.h | 119 + utils/lndir/lndir-Xos.h | 152 + utils/lndir/lndir-Xosdefs.h | 99 + utils/lndir/lndir.c | 485 + utils/mkUserGuidePart/Main.hs | 62 + utils/mkUserGuidePart/Makefile | 15 + utils/mkUserGuidePart/ghc.mk | 18 + utils/mkUserGuidePart/mkUserGuidePart.cabal | 19 + utils/mkdirhier/Makefile | 15 + utils/mkdirhier/ghc.mk | 23 + utils/mkdirhier/mkdirhier.sh | 4 + utils/runghc/Makefile | 15 + utils/runghc/ghc.mk | 43 + utils/runghc/runghc.cabal.in | 29 + utils/runghc/runghc.hs | 180 + utils/runghc/runghc.wrapper | 3 + utils/testremove/checkremove.hs | 150 + utils/testremove/ghc.mk | 9 + utils/testremove/wouldrm.hs | 16 + utils/touchy/Makefile | 37 + utils/touchy/ghc.mk | 18 + utils/touchy/touchy.c | 118 + utils/unlit/Makefile | 15 + utils/unlit/README | 8 + utils/unlit/ghc.mk | 20 + utils/unlit/unlit.c | 399 + utils/vagrant/bootstrap-deb.sh | 3 + utils/vagrant/bootstrap-rhel.sh | 4 + 3671 files changed, 1009879 insertions(+) create mode 100644 ANNOUNCE create mode 100644 GIT_COMMIT_ID create mode 100644 HACKING.md create mode 100644 INSTALL.md create mode 100644 LICENSE create mode 100644 MAKEHELP.md create mode 100644 Makefile create mode 100644 README.md create mode 100644 VERSION create mode 100644 aclocal.m4 create mode 100644 bindisttest/HelloWorld.lhs create mode 100644 bindisttest/Makefile create mode 100644 bindisttest/checkBinaries.sh create mode 100644 bindisttest/expected_output create mode 100644 bindisttest/ghc.mk create mode 100755 boot create mode 100644 compiler/DEPEND-NOTES create mode 100644 compiler/HsVersions.h create mode 100644 compiler/LICENSE create mode 100644 compiler/Makefile create mode 100644 compiler/NOTES create mode 100644 compiler/basicTypes/Avail.hs create mode 100644 compiler/basicTypes/BasicTypes.hs create mode 100644 compiler/basicTypes/ConLike.hs create mode 100644 compiler/basicTypes/DataCon.hs create mode 100644 compiler/basicTypes/DataCon.hs-boot create mode 100644 compiler/basicTypes/Demand.hs create mode 100644 compiler/basicTypes/Id.hs create mode 100644 compiler/basicTypes/IdInfo.hs create mode 100644 compiler/basicTypes/IdInfo.hs-boot create mode 100644 compiler/basicTypes/Lexeme.hs create mode 100644 compiler/basicTypes/Literal.hs create mode 100644 compiler/basicTypes/MkId.hs create mode 100644 compiler/basicTypes/MkId.hs-boot create mode 100644 compiler/basicTypes/Module.hs create mode 100644 compiler/basicTypes/Module.hs-boot create mode 100644 compiler/basicTypes/Name.hs create mode 100644 compiler/basicTypes/Name.hs-boot create mode 100644 compiler/basicTypes/NameEnv.hs create mode 100644 compiler/basicTypes/NameSet.hs create mode 100644 compiler/basicTypes/OccName.hs create mode 100644 compiler/basicTypes/OccName.hs-boot create mode 100644 compiler/basicTypes/PatSyn.hs create mode 100644 compiler/basicTypes/PatSyn.hs-boot create mode 100644 compiler/basicTypes/RdrName.hs create mode 100644 compiler/basicTypes/SrcLoc.hs create mode 100644 compiler/basicTypes/UniqSupply.hs create mode 100644 compiler/basicTypes/Unique.hs create mode 100644 compiler/basicTypes/Var.hs create mode 100644 compiler/basicTypes/VarEnv.hs create mode 100644 compiler/basicTypes/VarSet.hs create mode 100644 compiler/cbits/genSym.c create mode 100644 compiler/cmm/Bitmap.hs create mode 100644 compiler/cmm/BlockId.hs create mode 100644 compiler/cmm/CLabel.hs create mode 100644 compiler/cmm/Cmm.hs create mode 100644 compiler/cmm/CmmBuildInfoTables.hs create mode 100644 compiler/cmm/CmmCallConv.hs create mode 100644 compiler/cmm/CmmCommonBlockElim.hs create mode 100644 compiler/cmm/CmmContFlowOpt.hs create mode 100644 compiler/cmm/CmmExpr.hs create mode 100644 compiler/cmm/CmmInfo.hs create mode 100644 compiler/cmm/CmmLayoutStack.hs create mode 100644 compiler/cmm/CmmLex.hs create mode 100644 compiler/cmm/CmmLex.x.source create mode 100644 compiler/cmm/CmmLint.hs create mode 100644 compiler/cmm/CmmLive.hs create mode 100644 compiler/cmm/CmmMachOp.hs create mode 100644 compiler/cmm/CmmNode.hs create mode 100644 compiler/cmm/CmmOpt.hs create mode 100644 compiler/cmm/CmmParse.hs create mode 100644 compiler/cmm/CmmParse.y.source create mode 100644 compiler/cmm/CmmPipeline.hs create mode 100644 compiler/cmm/CmmProcPoint.hs create mode 100644 compiler/cmm/CmmSink.hs create mode 100644 compiler/cmm/CmmType.hs create mode 100644 compiler/cmm/CmmUtils.hs create mode 100644 compiler/cmm/Debug.hs create mode 100644 compiler/cmm/Hoopl.hs create mode 100644 compiler/cmm/Hoopl/Dataflow.hs create mode 100644 compiler/cmm/MkGraph.hs create mode 100644 compiler/cmm/PprC.hs create mode 100644 compiler/cmm/PprCmm.hs create mode 100644 compiler/cmm/PprCmmDecl.hs create mode 100644 compiler/cmm/PprCmmExpr.hs create mode 100644 compiler/cmm/SMRep.hs create mode 100644 compiler/cmm/cmm-notes create mode 100644 compiler/codeGen/CgUtils.hs create mode 100644 compiler/codeGen/CodeGen/Platform.hs create mode 100644 compiler/codeGen/CodeGen/Platform/ARM.hs create mode 100644 compiler/codeGen/CodeGen/Platform/ARM64.hs create mode 100644 compiler/codeGen/CodeGen/Platform/NoRegs.hs create mode 100644 compiler/codeGen/CodeGen/Platform/PPC.hs create mode 100644 compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs create mode 100644 compiler/codeGen/CodeGen/Platform/SPARC.hs create mode 100644 compiler/codeGen/CodeGen/Platform/X86.hs create mode 100644 compiler/codeGen/CodeGen/Platform/X86_64.hs create mode 100644 compiler/codeGen/StgCmm.hs create mode 100644 compiler/codeGen/StgCmmArgRep.hs create mode 100644 compiler/codeGen/StgCmmBind.hs create mode 100644 compiler/codeGen/StgCmmBind.hs-boot create mode 100644 compiler/codeGen/StgCmmClosure.hs create mode 100644 compiler/codeGen/StgCmmCon.hs create mode 100644 compiler/codeGen/StgCmmEnv.hs create mode 100644 compiler/codeGen/StgCmmExpr.hs create mode 100644 compiler/codeGen/StgCmmExtCode.hs create mode 100644 compiler/codeGen/StgCmmForeign.hs create mode 100644 compiler/codeGen/StgCmmHeap.hs create mode 100644 compiler/codeGen/StgCmmHpc.hs create mode 100644 compiler/codeGen/StgCmmLayout.hs create mode 100644 compiler/codeGen/StgCmmMonad.hs create mode 100644 compiler/codeGen/StgCmmPrim.hs create mode 100644 compiler/codeGen/StgCmmProf.hs create mode 100644 compiler/codeGen/StgCmmTicky.hs create mode 100644 compiler/codeGen/StgCmmUtils.hs create mode 100644 compiler/coreSyn/CoreArity.hs create mode 100644 compiler/coreSyn/CoreFVs.hs create mode 100644 compiler/coreSyn/CoreLint.hs create mode 100644 compiler/coreSyn/CorePrep.hs create mode 100644 compiler/coreSyn/CoreSubst.hs create mode 100644 compiler/coreSyn/CoreSyn.hs create mode 100644 compiler/coreSyn/CoreTidy.hs create mode 100644 compiler/coreSyn/CoreUnfold.hs create mode 100644 compiler/coreSyn/CoreUtils.hs create mode 100644 compiler/coreSyn/MkCore.hs create mode 100644 compiler/coreSyn/PprCore.hs create mode 100644 compiler/coreSyn/TrieMap.hs create mode 100644 compiler/deSugar/Check.hs create mode 100644 compiler/deSugar/Coverage.hs create mode 100644 compiler/deSugar/Desugar.hs create mode 100644 compiler/deSugar/DsArrows.hs create mode 100644 compiler/deSugar/DsBinds.hs create mode 100644 compiler/deSugar/DsCCall.hs create mode 100644 compiler/deSugar/DsExpr.hs create mode 100644 compiler/deSugar/DsExpr.hs-boot create mode 100644 compiler/deSugar/DsForeign.hs create mode 100644 compiler/deSugar/DsGRHSs.hs create mode 100644 compiler/deSugar/DsListComp.hs create mode 100644 compiler/deSugar/DsMeta.hs create mode 100644 compiler/deSugar/DsMonad.hs create mode 100644 compiler/deSugar/DsUtils.hs create mode 100644 compiler/deSugar/Match.hs create mode 100644 compiler/deSugar/Match.hs-boot create mode 100644 compiler/deSugar/MatchCon.hs create mode 100644 compiler/deSugar/MatchLit.hs create mode 100644 compiler/deSugar/StaticPtrTable.hs create mode 100644 compiler/ghc.cabal.in create mode 100644 compiler/ghc.mk create mode 100644 compiler/ghci/ByteCodeAsm.hs create mode 100644 compiler/ghci/ByteCodeGen.hs create mode 100644 compiler/ghci/ByteCodeInstr.hs create mode 100644 compiler/ghci/ByteCodeItbls.hs create mode 100644 compiler/ghci/ByteCodeLink.hs create mode 100644 compiler/ghci/Debugger.hs create mode 100644 compiler/ghci/DebuggerUtils.hs create mode 100644 compiler/ghci/LibFFI.hsc create mode 100644 compiler/ghci/Linker.hs create mode 100644 compiler/ghci/ObjLink.hs create mode 100644 compiler/ghci/RtClosureInspect.hs create mode 100644 compiler/ghci/keepCAFsForGHCi.c create mode 100644 compiler/hsSyn/Convert.hs create mode 100644 compiler/hsSyn/HsBinds.hs create mode 100644 compiler/hsSyn/HsDecls.hs create mode 100644 compiler/hsSyn/HsDoc.hs create mode 100644 compiler/hsSyn/HsExpr.hs create mode 100644 compiler/hsSyn/HsExpr.hs-boot create mode 100644 compiler/hsSyn/HsImpExp.hs create mode 100644 compiler/hsSyn/HsLit.hs create mode 100644 compiler/hsSyn/HsPat.hs create mode 100644 compiler/hsSyn/HsPat.hs-boot create mode 100644 compiler/hsSyn/HsSyn.hs create mode 100644 compiler/hsSyn/HsTypes.hs create mode 100644 compiler/hsSyn/HsUtils.hs create mode 100644 compiler/hsSyn/PlaceHolder.hs create mode 100644 compiler/iface/BinIface.hs create mode 100644 compiler/iface/BuildTyCl.hs create mode 100644 compiler/iface/FlagChecker.hs create mode 100644 compiler/iface/IfaceEnv.hs create mode 100644 compiler/iface/IfaceSyn.hs create mode 100644 compiler/iface/IfaceType.hs create mode 100644 compiler/iface/LoadIface.hs create mode 100644 compiler/iface/MkIface.hs create mode 100644 compiler/iface/TcIface.hs create mode 100644 compiler/iface/TcIface.hs-boot create mode 100644 compiler/llvmGen/Llvm.hs create mode 100644 compiler/llvmGen/Llvm/AbsSyn.hs create mode 100644 compiler/llvmGen/Llvm/MetaData.hs create mode 100644 compiler/llvmGen/Llvm/PpLlvm.hs create mode 100644 compiler/llvmGen/Llvm/Types.hs create mode 100644 compiler/llvmGen/LlvmCodeGen.hs create mode 100644 compiler/llvmGen/LlvmCodeGen/Base.hs create mode 100644 compiler/llvmGen/LlvmCodeGen/CodeGen.hs create mode 100644 compiler/llvmGen/LlvmCodeGen/Data.hs create mode 100644 compiler/llvmGen/LlvmCodeGen/Ppr.hs create mode 100644 compiler/llvmGen/LlvmCodeGen/Regs.hs create mode 100644 compiler/llvmGen/LlvmMangler.hs create mode 100644 compiler/main/Annotations.hs create mode 100644 compiler/main/BreakArray.hs create mode 100644 compiler/main/CmdLineParser.hs create mode 100644 compiler/main/CodeOutput.hs create mode 100644 compiler/main/Constants.hs create mode 100644 compiler/main/DriverMkDepend.hs create mode 100644 compiler/main/DriverPhases.hs create mode 100644 compiler/main/DriverPipeline.hs create mode 100644 compiler/main/DynFlags.hs create mode 100644 compiler/main/DynFlags.hs-boot create mode 100644 compiler/main/DynamicLoading.hs create mode 100644 compiler/main/ErrUtils.hs create mode 100644 compiler/main/ErrUtils.hs-boot create mode 100644 compiler/main/Finder.hs create mode 100644 compiler/main/GHC.hs create mode 100644 compiler/main/GhcMake.hs create mode 100644 compiler/main/GhcMonad.hs create mode 100644 compiler/main/GhcPlugins.hs create mode 100644 compiler/main/HeaderInfo.hs create mode 100644 compiler/main/Hooks.hs create mode 100644 compiler/main/Hooks.hs-boot create mode 100644 compiler/main/HscMain.hs create mode 100644 compiler/main/HscStats.hs create mode 100644 compiler/main/HscTypes.hs create mode 100644 compiler/main/InteractiveEval.hs create mode 100644 compiler/main/InteractiveEvalTypes.hs create mode 100644 compiler/main/PackageConfig.hs create mode 100644 compiler/main/Packages.hs create mode 100644 compiler/main/Packages.hs-boot create mode 100644 compiler/main/PipelineMonad.hs create mode 100644 compiler/main/PlatformConstants.hs create mode 100644 compiler/main/Plugins.hs create mode 100644 compiler/main/PprTyThing.hs create mode 100644 compiler/main/StaticFlags.hs create mode 100644 compiler/main/StaticFlags.hs-boot create mode 100644 compiler/main/SysTools.hs create mode 100644 compiler/main/TidyPgm.hs create mode 100644 compiler/nativeGen/AsmCodeGen.hs create mode 100644 compiler/nativeGen/CPrim.hs create mode 100644 compiler/nativeGen/Dwarf.hs create mode 100644 compiler/nativeGen/Dwarf/Constants.hs create mode 100644 compiler/nativeGen/Dwarf/Types.hs create mode 100644 compiler/nativeGen/Instruction.hs create mode 100644 compiler/nativeGen/NCG.h create mode 100644 compiler/nativeGen/NCGMonad.hs create mode 100644 compiler/nativeGen/NOTES create mode 100644 compiler/nativeGen/PIC.hs create mode 100644 compiler/nativeGen/PPC/CodeGen.hs create mode 100644 compiler/nativeGen/PPC/Cond.hs create mode 100644 compiler/nativeGen/PPC/Instr.hs create mode 100644 compiler/nativeGen/PPC/Ppr.hs create mode 100644 compiler/nativeGen/PPC/RegInfo.hs create mode 100644 compiler/nativeGen/PPC/Regs.hs create mode 100644 compiler/nativeGen/PprBase.hs create mode 100644 compiler/nativeGen/Reg.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/ArchBase.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/ArchX86.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/Coalesce.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/Main.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/Spill.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/SpillClean.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/SpillCost.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/Stats.hs create mode 100644 compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/Base.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/Main.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/StackMap.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/State.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/Stats.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs create mode 100644 compiler/nativeGen/RegAlloc/Liveness.hs create mode 100644 compiler/nativeGen/RegClass.hs create mode 100644 compiler/nativeGen/SPARC/AddrMode.hs create mode 100644 compiler/nativeGen/SPARC/Base.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Amode.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Base.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/CondCode.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Expand.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Gen32.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot create mode 100644 compiler/nativeGen/SPARC/CodeGen/Gen64.hs create mode 100644 compiler/nativeGen/SPARC/CodeGen/Sanity.hs create mode 100644 compiler/nativeGen/SPARC/Cond.hs create mode 100644 compiler/nativeGen/SPARC/Imm.hs create mode 100644 compiler/nativeGen/SPARC/Instr.hs create mode 100644 compiler/nativeGen/SPARC/Ppr.hs create mode 100644 compiler/nativeGen/SPARC/Regs.hs create mode 100644 compiler/nativeGen/SPARC/ShortcutJump.hs create mode 100644 compiler/nativeGen/SPARC/Stack.hs create mode 100644 compiler/nativeGen/Size.hs create mode 100644 compiler/nativeGen/TargetReg.hs create mode 100644 compiler/nativeGen/X86/CodeGen.hs create mode 100644 compiler/nativeGen/X86/Cond.hs create mode 100644 compiler/nativeGen/X86/Instr.hs create mode 100644 compiler/nativeGen/X86/Ppr.hs create mode 100644 compiler/nativeGen/X86/RegInfo.hs create mode 100644 compiler/nativeGen/X86/Regs.hs create mode 100644 compiler/parser/ApiAnnotation.hs create mode 100644 compiler/parser/Ctype.hs create mode 100644 compiler/parser/HaddockUtils.hs create mode 100644 compiler/parser/Lexer.hs create mode 100644 compiler/parser/Lexer.x.source create mode 100644 compiler/parser/Parser.hs create mode 100644 compiler/parser/Parser.y.source create mode 100644 compiler/parser/RdrHsSyn.hs create mode 100644 compiler/parser/cutils.c create mode 100644 compiler/parser/cutils.h create mode 100644 compiler/prelude/ForeignCall.hs create mode 100644 compiler/prelude/PrelInfo.hs create mode 100644 compiler/prelude/PrelNames.hs create mode 100644 compiler/prelude/PrelNames.hs-boot create mode 100644 compiler/prelude/PrelRules.hs create mode 100644 compiler/prelude/PrimOp.hs create mode 100644 compiler/prelude/PrimOp.hs-boot create mode 100644 compiler/prelude/TysPrim.hs create mode 100644 compiler/prelude/TysWiredIn.hs create mode 100644 compiler/prelude/TysWiredIn.hs-boot create mode 100644 compiler/prelude/primops.txt.pp create mode 100644 compiler/profiling/CostCentre.hs create mode 100644 compiler/profiling/NOTES create mode 100644 compiler/profiling/ProfInit.hs create mode 100644 compiler/profiling/SCCfinal.hs create mode 100644 compiler/rename/RnBinds.hs create mode 100644 compiler/rename/RnEnv.hs create mode 100644 compiler/rename/RnExpr.hs create mode 100644 compiler/rename/RnExpr.hs-boot create mode 100644 compiler/rename/RnHsDoc.hs create mode 100644 compiler/rename/RnNames.hs create mode 100644 compiler/rename/RnPat.hs create mode 100644 compiler/rename/RnSource.hs create mode 100644 compiler/rename/RnSplice.hs create mode 100644 compiler/rename/RnSplice.hs-boot create mode 100644 compiler/rename/RnTypes.hs create mode 100644 compiler/rename/rename.tex create mode 100644 compiler/simplCore/CSE.hs create mode 100644 compiler/simplCore/CallArity.hs create mode 100644 compiler/simplCore/CoreMonad.hs create mode 100644 compiler/simplCore/FloatIn.hs create mode 100644 compiler/simplCore/FloatOut.hs create mode 100644 compiler/simplCore/LiberateCase.hs create mode 100644 compiler/simplCore/OccurAnal.hs create mode 100644 compiler/simplCore/SAT.hs create mode 100644 compiler/simplCore/SetLevels.hs create mode 100644 compiler/simplCore/SimplCore.hs create mode 100644 compiler/simplCore/SimplEnv.hs create mode 100644 compiler/simplCore/SimplMonad.hs create mode 100644 compiler/simplCore/SimplUtils.hs create mode 100644 compiler/simplCore/Simplify.hs create mode 100644 compiler/simplCore/simplifier.tib create mode 100644 compiler/simplStg/SimplStg.hs create mode 100644 compiler/simplStg/StgStats.hs create mode 100644 compiler/simplStg/UnariseStg.hs create mode 100644 compiler/specialise/Rules.hs create mode 100644 compiler/specialise/SpecConstr.hs create mode 100644 compiler/specialise/Specialise.hs create mode 100644 compiler/stgSyn/CoreToStg.hs create mode 100644 compiler/stgSyn/StgLint.hs create mode 100644 compiler/stgSyn/StgSyn.hs create mode 100644 compiler/stranal/DmdAnal.hs create mode 100644 compiler/stranal/WorkWrap.hs create mode 100644 compiler/stranal/WwLib.hs create mode 100644 compiler/typecheck/FamInst.hs create mode 100644 compiler/typecheck/Flattening-notes create mode 100644 compiler/typecheck/FunDeps.hs create mode 100644 compiler/typecheck/Inst.hs create mode 100644 compiler/typecheck/TcAnnotations.hs create mode 100644 compiler/typecheck/TcArrows.hs create mode 100644 compiler/typecheck/TcBinds.hs create mode 100644 compiler/typecheck/TcCanonical.hs create mode 100644 compiler/typecheck/TcClassDcl.hs create mode 100644 compiler/typecheck/TcDefaults.hs create mode 100644 compiler/typecheck/TcDeriv.hs create mode 100644 compiler/typecheck/TcEnv.hs create mode 100644 compiler/typecheck/TcEnv.hs-boot create mode 100644 compiler/typecheck/TcErrors.hs create mode 100644 compiler/typecheck/TcEvidence.hs create mode 100644 compiler/typecheck/TcExpr.hs create mode 100644 compiler/typecheck/TcExpr.hs-boot create mode 100644 compiler/typecheck/TcFlatten.hs create mode 100644 compiler/typecheck/TcForeign.hs create mode 100644 compiler/typecheck/TcGenDeriv.hs create mode 100644 compiler/typecheck/TcGenGenerics.hs create mode 100644 compiler/typecheck/TcHsSyn.hs create mode 100644 compiler/typecheck/TcHsType.hs create mode 100644 compiler/typecheck/TcInstDcls.hs create mode 100644 compiler/typecheck/TcInteract.hs create mode 100644 compiler/typecheck/TcMType.hs create mode 100644 compiler/typecheck/TcMatches.hs create mode 100644 compiler/typecheck/TcMatches.hs-boot create mode 100644 compiler/typecheck/TcPat.hs create mode 100644 compiler/typecheck/TcPatSyn.hs create mode 100644 compiler/typecheck/TcPatSyn.hs-boot create mode 100644 compiler/typecheck/TcPluginM.hs create mode 100644 compiler/typecheck/TcRnDriver.hs create mode 100644 compiler/typecheck/TcRnMonad.hs create mode 100644 compiler/typecheck/TcRnTypes.hs create mode 100644 compiler/typecheck/TcRules.hs create mode 100644 compiler/typecheck/TcSMonad.hs create mode 100644 compiler/typecheck/TcSimplify.hs create mode 100644 compiler/typecheck/TcSplice.hs create mode 100644 compiler/typecheck/TcSplice.hs-boot create mode 100644 compiler/typecheck/TcTyClsDecls.hs create mode 100644 compiler/typecheck/TcTyDecls.hs create mode 100644 compiler/typecheck/TcType.hs create mode 100644 compiler/typecheck/TcType.hs-boot create mode 100644 compiler/typecheck/TcTypeNats.hs create mode 100644 compiler/typecheck/TcTypeNats.hs-boot create mode 100644 compiler/typecheck/TcUnify.hs create mode 100644 compiler/typecheck/TcUnify.hs-boot create mode 100644 compiler/typecheck/TcValidity.hs create mode 100644 compiler/types/Class.hs create mode 100644 compiler/types/CoAxiom.hs create mode 100644 compiler/types/Coercion.hs create mode 100644 compiler/types/FamInstEnv.hs create mode 100644 compiler/types/InstEnv.hs create mode 100644 compiler/types/Kind.hs create mode 100644 compiler/types/OptCoercion.hs create mode 100644 compiler/types/TyCon.hs create mode 100644 compiler/types/TyCon.hs-boot create mode 100644 compiler/types/Type.hs create mode 100644 compiler/types/Type.hs-boot create mode 100644 compiler/types/TypeRep.hs create mode 100644 compiler/types/TypeRep.hs-boot create mode 100644 compiler/types/Unify.hs create mode 100644 compiler/utils/Bag.hs create mode 100644 compiler/utils/Binary.hs create mode 100644 compiler/utils/BooleanFormula.hs create mode 100644 compiler/utils/BufWrite.hs create mode 100644 compiler/utils/Digraph.hs create mode 100644 compiler/utils/Encoding.hs create mode 100644 compiler/utils/Exception.hs create mode 100644 compiler/utils/ExtsCompat46.hs create mode 100644 compiler/utils/FastBool.hs create mode 100644 compiler/utils/FastFunctions.hs create mode 100644 compiler/utils/FastMutInt.hs create mode 100644 compiler/utils/FastString.hs create mode 100644 compiler/utils/FastTypes.hs create mode 100644 compiler/utils/Fingerprint.hsc create mode 100644 compiler/utils/FiniteMap.hs create mode 100644 compiler/utils/GraphBase.hs create mode 100644 compiler/utils/GraphColor.hs create mode 100644 compiler/utils/GraphOps.hs create mode 100644 compiler/utils/GraphPpr.hs create mode 100644 compiler/utils/IOEnv.hs create mode 100644 compiler/utils/ListSetOps.hs create mode 100644 compiler/utils/Maybes.hs create mode 100644 compiler/utils/MonadUtils.hs create mode 100644 compiler/utils/OrdList.hs create mode 100644 compiler/utils/Outputable.hs create mode 100644 compiler/utils/Outputable.hs-boot create mode 100644 compiler/utils/Pair.hs create mode 100644 compiler/utils/Panic.hs create mode 100644 compiler/utils/Platform.hs create mode 100644 compiler/utils/Pretty.hs create mode 100644 compiler/utils/Serialized.hs create mode 100644 compiler/utils/State.hs create mode 100644 compiler/utils/Stream.hs create mode 100644 compiler/utils/StringBuffer.hs create mode 100644 compiler/utils/UnVarGraph.hs create mode 100644 compiler/utils/UniqFM.hs create mode 100644 compiler/utils/UniqSet.hs create mode 100644 compiler/utils/Util.hs create mode 100644 compiler/utils/md5.h create mode 100644 compiler/vectorise/Vectorise.hs create mode 100644 compiler/vectorise/Vectorise/Builtins.hs create mode 100644 compiler/vectorise/Vectorise/Builtins/Base.hs create mode 100644 compiler/vectorise/Vectorise/Builtins/Initialise.hs create mode 100644 compiler/vectorise/Vectorise/Convert.hs create mode 100644 compiler/vectorise/Vectorise/Env.hs create mode 100644 compiler/vectorise/Vectorise/Exp.hs create mode 100644 compiler/vectorise/Vectorise/Generic/Description.hs create mode 100644 compiler/vectorise/Vectorise/Generic/PADict.hs create mode 100644 compiler/vectorise/Vectorise/Generic/PAMethods.hs create mode 100644 compiler/vectorise/Vectorise/Generic/PData.hs create mode 100644 compiler/vectorise/Vectorise/Monad.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Base.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Global.hs create mode 100644 compiler/vectorise/Vectorise/Monad/InstEnv.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Local.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Naming.hs create mode 100644 compiler/vectorise/Vectorise/Type/Classify.hs create mode 100644 compiler/vectorise/Vectorise/Type/Env.hs create mode 100644 compiler/vectorise/Vectorise/Type/TyConDecl.hs create mode 100644 compiler/vectorise/Vectorise/Type/Type.hs create mode 100644 compiler/vectorise/Vectorise/Utils.hs create mode 100644 compiler/vectorise/Vectorise/Utils/Base.hs create mode 100644 compiler/vectorise/Vectorise/Utils/Closure.hs create mode 100644 compiler/vectorise/Vectorise/Utils/Hoisting.hs create mode 100644 compiler/vectorise/Vectorise/Utils/PADict.hs create mode 100644 compiler/vectorise/Vectorise/Utils/Poly.hs create mode 100644 compiler/vectorise/Vectorise/Var.hs create mode 100644 compiler/vectorise/Vectorise/Vect.hs create mode 100644 config.guess create mode 100644 config.sub create mode 100755 configure create mode 100644 configure.ac create mode 100644 distrib/INSTALL create mode 100644 distrib/Makefile create mode 100644 distrib/README create mode 100644 distrib/compare/BuildInfo.hs create mode 100644 distrib/compare/Change.hs create mode 100644 distrib/compare/FilenameDescr.hs create mode 100644 distrib/compare/Makefile create mode 100644 distrib/compare/Tar.hs create mode 100644 distrib/compare/Utils.hs create mode 100644 distrib/compare/compare.hs create mode 100644 distrib/configure.ac.in create mode 100644 distrib/cross-port create mode 100644 distrib/hc-build create mode 100644 distrib/hsicon.ico create mode 100755 distrib/mkDocs/mkDocs create mode 100644 distrib/remilestoning.pl create mode 100644 docs/Makefile create mode 100644 docs/backpack/.gitignore create mode 100644 docs/backpack/Makefile create mode 100644 docs/backpack/arch.png create mode 100644 docs/backpack/backpack-impl.bib create mode 100644 docs/backpack/backpack-impl.pdf create mode 100644 docs/backpack/backpack-impl.tex create mode 100644 docs/backpack/backpack-manual.pdf create mode 100644 docs/backpack/backpack-manual.tex create mode 100644 docs/backpack/commands-new-new.tex create mode 100644 docs/backpack/commands-rebindings.tex create mode 100644 docs/backpack/diagrams.pdf create mode 100644 docs/backpack/diagrams.xoj create mode 100644 docs/backpack/pkgdb.png create mode 100644 docs/coding-style.html create mode 100644 docs/core-spec/.gitignore create mode 100644 docs/core-spec/CoreLint.ott create mode 100644 docs/core-spec/CoreSyn.ott create mode 100644 docs/core-spec/Makefile create mode 100644 docs/core-spec/OpSem.ott create mode 100644 docs/core-spec/README create mode 100644 docs/core-spec/core-spec.mng create mode 100644 docs/core-spec/core-spec.pdf create mode 100644 docs/ghci/ghci.tex create mode 100644 docs/hep/hep.tex create mode 100644 docs/index.html.in create mode 100644 docs/man/gen_flags.xsl.sh create mode 100644 docs/man/ghc.mk create mode 100644 docs/ndp/haskell.sty create mode 100644 docs/ndp/vect.tex create mode 100644 docs/rts/closure.ps create mode 100644 docs/rts/closure.tex create mode 100644 docs/rts/hugs_ret.pstex create mode 100644 docs/rts/hugs_ret.pstex_t create mode 100644 docs/rts/hugs_ret2.pstex create mode 100644 docs/rts/hugs_ret2.pstex_t create mode 100644 docs/rts/rts.tex create mode 100644 docs/stg-spec/fast-curry.rkt create mode 100644 docs/storage-mgt/Makefile create mode 100644 docs/storage-mgt/architecture.eepic create mode 100644 docs/storage-mgt/architecture.fig create mode 100644 docs/storage-mgt/cacheprof_p.eps create mode 100644 docs/storage-mgt/code.sty create mode 100644 docs/storage-mgt/freelist.eepic create mode 100644 docs/storage-mgt/freelist.fig create mode 100644 docs/storage-mgt/gen.eepic create mode 100644 docs/storage-mgt/gen.fig create mode 100644 docs/storage-mgt/generation.eepic create mode 100644 docs/storage-mgt/generation.fig create mode 100644 docs/storage-mgt/largeobjectpool.eepic create mode 100644 docs/storage-mgt/largeobjectpool.fig create mode 100644 docs/storage-mgt/ldv.eepic create mode 100644 docs/storage-mgt/ldv.fig create mode 100644 docs/storage-mgt/ldv.tex create mode 100644 docs/storage-mgt/megablock.eepic create mode 100644 docs/storage-mgt/megablock.fig create mode 100644 docs/storage-mgt/nursery.eepic create mode 100644 docs/storage-mgt/nursery.fig create mode 100644 docs/storage-mgt/reference.bib create mode 100644 docs/storage-mgt/rp.tex create mode 100644 docs/storage-mgt/sm.tex create mode 100644 docs/storage-mgt/smallobjectpool.eepic create mode 100644 docs/storage-mgt/smallobjectpool.fig create mode 100644 docs/storage-mgt/step.eepic create mode 100644 docs/storage-mgt/step.fig create mode 100644 docs/users_guide/7.10.1-notes.xml create mode 100644 docs/users_guide/7.10.2-notes.xml create mode 100644 docs/users_guide/7.10.3-notes.xml create mode 100644 docs/users_guide/Makefile create mode 100644 docs/users_guide/bugs.xml create mode 100644 docs/users_guide/codegens.xml create mode 100644 docs/users_guide/debugging.xml create mode 100644 docs/users_guide/extending_ghc.xml create mode 100644 docs/users_guide/ffi-chap.xml create mode 100644 docs/users_guide/flags.xml create mode 100644 docs/users_guide/ghc.mk create mode 100644 docs/users_guide/ghci.xml create mode 100644 docs/users_guide/glasgow_exts.xml create mode 100644 docs/users_guide/gone_wrong.xml create mode 100644 docs/users_guide/images/Recip.png create mode 100644 docs/users_guide/intro.xml create mode 100644 docs/users_guide/lang.xml create mode 100644 docs/users_guide/license.xml create mode 100644 docs/users_guide/packages.xml create mode 100644 docs/users_guide/parallel.xml create mode 100644 docs/users_guide/phases.xml create mode 100644 docs/users_guide/prof_scc.eps create mode 100644 docs/users_guide/profiling.xml create mode 100644 docs/users_guide/runghc.xml create mode 100644 docs/users_guide/runtime_control.xml create mode 100644 docs/users_guide/safe_haskell.xml create mode 100644 docs/users_guide/separate_compilation.xml create mode 100644 docs/users_guide/shared_libs.xml create mode 100644 docs/users_guide/sooner.xml create mode 100644 docs/users_guide/ug-book.xml.in create mode 100644 docs/users_guide/ug-ent.xml.in create mode 100644 docs/users_guide/using.xml create mode 100644 docs/users_guide/utils.xml create mode 100644 docs/users_guide/win32-dlls.xml create mode 100644 driver/Makefile create mode 100644 driver/gcc/gcc.c create mode 100644 driver/ghc-usage.txt create mode 100644 driver/ghc.mk create mode 100644 driver/ghc/Makefile create mode 100644 driver/ghc/ghc.c create mode 100644 driver/ghc/ghc.mk create mode 100644 driver/ghci-usage.txt create mode 100644 driver/ghci/Makefile create mode 100644 driver/ghci/ghc.mk create mode 100644 driver/ghci/ghci.c create mode 100644 driver/ghci/ghci.ico create mode 100644 driver/ghci/ghci.rc create mode 100644 driver/haddock/Makefile create mode 100644 driver/haddock/ghc.mk create mode 100644 driver/haddock/haddock.c create mode 100644 driver/split/Makefile create mode 100644 driver/split/ghc-split.lprl create mode 100644 driver/split/ghc.mk create mode 100644 driver/utils/cwrapper.c create mode 100644 driver/utils/cwrapper.h create mode 100644 driver/utils/dynwrapper.c create mode 100644 driver/utils/getLocation.c create mode 100644 driver/utils/getLocation.h create mode 100644 ghc.mk create mode 100644 ghc/GhciMonad.hs create mode 100644 ghc/GhciTags.hs create mode 100644 ghc/InteractiveUI.hs create mode 100644 ghc/Main.hs create mode 100644 ghc/Makefile create mode 100644 ghc/ghc-bin.cabal.in create mode 100644 ghc/ghc-cross.wrapper create mode 100644 ghc/ghc.mk create mode 100644 ghc/ghc.wrapper create mode 100644 ghc/hschooks.c create mode 100644 includes/.dir-locals.el create mode 100644 includes/Cmm.h create mode 100644 includes/CodeGen.Platform.hs create mode 100644 includes/HsFFI.h create mode 100644 includes/MachDeps.h create mode 100644 includes/Makefile create mode 100644 includes/Rts.h create mode 100644 includes/RtsAPI.h create mode 100644 includes/Stg.h create mode 100644 includes/ghc.mk create mode 100644 includes/ghcconfig.h create mode 100644 includes/rts/Adjustor.h create mode 100644 includes/rts/BlockSignals.h create mode 100644 includes/rts/Bytecodes.h create mode 100644 includes/rts/Config.h create mode 100644 includes/rts/Constants.h create mode 100644 includes/rts/EventLogFormat.h create mode 100644 includes/rts/FileLock.h create mode 100644 includes/rts/Flags.h create mode 100644 includes/rts/GetTime.h create mode 100644 includes/rts/Globals.h create mode 100644 includes/rts/Hooks.h create mode 100644 includes/rts/Hpc.h create mode 100644 includes/rts/IOManager.h create mode 100644 includes/rts/Linker.h create mode 100644 includes/rts/Main.h create mode 100644 includes/rts/Messages.h create mode 100644 includes/rts/OSThreads.h create mode 100644 includes/rts/Parallel.h create mode 100644 includes/rts/PrimFloat.h create mode 100644 includes/rts/Signals.h create mode 100644 includes/rts/SpinLock.h create mode 100644 includes/rts/Stable.h create mode 100644 includes/rts/StaticPtrTable.h create mode 100644 includes/rts/TTY.h create mode 100644 includes/rts/Threads.h create mode 100644 includes/rts/Ticky.h create mode 100644 includes/rts/Timer.h create mode 100644 includes/rts/Types.h create mode 100644 includes/rts/Utils.h create mode 100644 includes/rts/prof/CCS.h create mode 100644 includes/rts/prof/LDV.h create mode 100644 includes/rts/storage/Block.h create mode 100644 includes/rts/storage/ClosureMacros.h create mode 100644 includes/rts/storage/ClosureTypes.h create mode 100644 includes/rts/storage/Closures.h create mode 100644 includes/rts/storage/FunTypes.h create mode 100644 includes/rts/storage/GC.h create mode 100644 includes/rts/storage/InfoTables.h create mode 100644 includes/rts/storage/MBlock.h create mode 100644 includes/rts/storage/SMPClosureOps.h create mode 100644 includes/rts/storage/TSO.h create mode 100644 includes/shell-tools.c create mode 100644 includes/stg/DLL.h create mode 100644 includes/stg/HaskellMachRegs.h create mode 100644 includes/stg/MachRegs.h create mode 100644 includes/stg/MiscClosures.h create mode 100644 includes/stg/Prim.h create mode 100644 includes/stg/Regs.h create mode 100644 includes/stg/RtsMachRegs.h create mode 100644 includes/stg/SMP.h create mode 100644 includes/stg/Ticky.h create mode 100644 includes/stg/Types.h create mode 100755 install-sh create mode 100644 libffi-tarballs/LICENSE create mode 100644 libffi-tarballs/README create mode 100644 libffi-tarballs/libffi-3.1.tar.gz create mode 100644 libffi/Makefile create mode 100644 libffi/ghc.mk create mode 100644 libffi/libffi.x86-execstack.patch create mode 100755 libffi/ln create mode 100644 libraries/Cabal/.gitignore create mode 100644 libraries/Cabal/.travis.yml create mode 100644 libraries/Cabal/Cabal/.gitignore create mode 100644 libraries/Cabal/Cabal/Cabal.cabal create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/Binary.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/Binary/Class.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/Binary/Generic.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/CopyFile.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/CreatePipe.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/Environment.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/Exception.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/ReadP.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compat/TempFile.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Compiler.hs create mode 100644 libraries/Cabal/Cabal/Distribution/GetOpt.hs create mode 100644 libraries/Cabal/Cabal/Distribution/InstalledPackageInfo.hs create mode 100644 libraries/Cabal/Cabal/Distribution/License.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Make.hs create mode 100644 libraries/Cabal/Cabal/Distribution/ModuleName.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Package.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription/Check.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription/Configuration.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription/Parse.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs create mode 100644 libraries/Cabal/Cabal/Distribution/PackageDescription/Utils.hs create mode 100644 libraries/Cabal/Cabal/Distribution/ParseUtils.hs create mode 100644 libraries/Cabal/Cabal/Distribution/ReadE.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Bench.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Build.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Build/Macros.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Build/PathsModule.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/BuildPaths.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/BuildTarget.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/CCompiler.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Command.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Compiler.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Configure.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHC.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHC/IPI641.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHC/IPI642.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHC/Internal.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/GHCJS.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Haddock.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/HaskellSuite.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Hpc.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Install.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/InstallDirs.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/JHC.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/LHC.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/PackageIndex.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/PreProcess.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Ar.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Builtin.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Db.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Find.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/GHC.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/HcPkg.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Hpc.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Ld.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Run.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Script.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Strip.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Program/Types.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Register.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Setup.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/SrcDist.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Test.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Test/LibV09.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Test/Log.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/UHC.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/UserHooks.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Simple/Utils.hs create mode 100644 libraries/Cabal/Cabal/Distribution/System.hs create mode 100644 libraries/Cabal/Cabal/Distribution/TestSuite.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Text.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Utils/NubList.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Verbosity.hs create mode 100644 libraries/Cabal/Cabal/Distribution/Version.hs create mode 100644 libraries/Cabal/Cabal/GNUmakefile create mode 100644 libraries/Cabal/Cabal/LICENSE create mode 100644 libraries/Cabal/Cabal/Language/Haskell/Extension.hs create mode 100644 libraries/Cabal/Cabal/Makefile create mode 100644 libraries/Cabal/Cabal/README.md create mode 100644 libraries/Cabal/Cabal/Setup.hs create mode 100644 libraries/Cabal/Cabal/changelog create mode 100644 libraries/Cabal/Cabal/doc/Cabal.css create mode 100644 libraries/Cabal/Cabal/doc/developing-packages.markdown create mode 100644 libraries/Cabal/Cabal/doc/index.markdown create mode 100644 libraries/Cabal/Cabal/doc/installing-packages.markdown create mode 100644 libraries/Cabal/Cabal/doc/misc.markdown create mode 100644 libraries/Cabal/Cabal/ghc.mk create mode 100755 libraries/Cabal/Cabal/misc/gen-extra-source-files.sh create mode 100644 libraries/Cabal/Cabal/prologue.txt create mode 100644 libraries/Cabal/Cabal/tests/PackageTests.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/.gitignore create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/CMain/Bar.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/CMain/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/CMain/Setup.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/CMain/foo.c create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/CMain/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/DeterministicAr/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/DeterministicAr/Lib.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/DeterministicAr/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/EmptyLib/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/EmptyLib/empty/empty.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/CPP.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/Literate.lhs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/NoCPP.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/Simple.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/Haddock/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/OrderFlags/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/OrderFlags/Foo.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/OrderFlags/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PackageTester.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PathsModule/Executable/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PathsModule/Executable/Main.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PathsModule/Executable/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PathsModule/Library/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PathsModule/Library/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PreProcess/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PreProcess/Foo.hsc create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PreProcess/Main.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/PreProcess/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/ReexportedModules/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/ReexportedModules/ReexportedModules.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/vanilla/TH.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TemplateHaskell/vanilla/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestOptions/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestStanza/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestStanza/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal create mode 100644 libraries/Cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs create mode 100644 libraries/Cabal/Cabal/tests/README.md create mode 100644 libraries/Cabal/Cabal/tests/Setup.hs create mode 100644 libraries/Cabal/Cabal/tests/UnitTests.hs create mode 100644 libraries/Cabal/Cabal/tests/UnitTests/Distribution/Compat/CreatePipe.hs create mode 100644 libraries/Cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs create mode 100644 libraries/Cabal/Cabal/tests/UnitTests/Distribution/Utils/NubList.hs create mode 100644 libraries/Cabal/Cabal/tests/hackage/check.sh create mode 100644 libraries/Cabal/Cabal/tests/hackage/download.sh create mode 100644 libraries/Cabal/Cabal/tests/hackage/unpack.sh create mode 100644 libraries/Cabal/Cabal/tests/misc/ghc-supported-languages.hs create mode 100644 libraries/Cabal/HACKING.md create mode 100644 libraries/Cabal/LICENSE create mode 100644 libraries/Cabal/README.md create mode 100644 libraries/Cabal/cabal-install/.ghci create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/BuildReports/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Check.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/Environment.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/Process.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Compat/Time.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Config.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Configure.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Dependency/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Exec.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Fetch.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/FetchUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Freeze.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/GZipUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Get.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Haddock.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/HttpUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/IndexUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Init.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Init/Heuristics.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Init/Licenses.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Init/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Install.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/InstallPlan.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/InstallSymlink.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/JobControl.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/List.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/PackageIndex.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/PackageUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/ParseUtils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Run.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Sandbox.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Sandbox/Index.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Sandbox/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Setup.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/SetupWrapper.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/SrcDist.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Tar.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Targets.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Types.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Update.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Upload.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Utils.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs create mode 100644 libraries/Cabal/cabal-install/Distribution/Client/World.hs create mode 100644 libraries/Cabal/cabal-install/LICENSE create mode 100644 libraries/Cabal/cabal-install/Main.hs create mode 100644 libraries/Cabal/cabal-install/README.md create mode 100644 libraries/Cabal/cabal-install/Setup.hs create mode 100644 libraries/Cabal/cabal-install/bash-completion/cabal create mode 100755 libraries/Cabal/cabal-install/bootstrap.sh create mode 100644 libraries/Cabal/cabal-install/cabal-install.cabal create mode 100644 libraries/Cabal/cabal-install/cbits/getnumcores.c create mode 100644 libraries/Cabal/cabal-install/changelog create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Exec/Check.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Exec/Foo.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Exec/My.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Exec/my.cabal create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Exec/subdir/.gitkeep create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Freeze/Check.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/Freeze/my.cabal create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/Check.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/p/LICENSE create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/p/Setup.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/p/p.cabal create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/q/LICENSE create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/q/Setup.hs create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/MultipleSource/q/q.cabal create mode 100644 libraries/Cabal/cabal-install/tests/PackageTests/PackageTester.hs create mode 100644 libraries/Cabal/cabal-install/tests/README create mode 100644 libraries/Cabal/cabal-install/tests/UnitTests.hs create mode 100644 libraries/Cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs create mode 100644 libraries/Cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs create mode 100644 libraries/Cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs create mode 100644 libraries/Cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs create mode 100644 libraries/Cabal/cabal-install/tests/test-cabal-install create mode 100644 libraries/Cabal/cabal-install/tests/test-cabal-install-user create mode 100644 libraries/Cabal/ghc-packages create mode 100644 libraries/Makefile create mode 100644 libraries/Win32/.gitignore create mode 100644 libraries/Win32/.hgignore create mode 100644 libraries/Win32/GNUmakefile create mode 100644 libraries/Win32/Graphics/Win32.hs create mode 100644 libraries/Win32/Graphics/Win32/Control.hsc create mode 100644 libraries/Win32/Graphics/Win32/Dialogue.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI.hs create mode 100644 libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Brush.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Clip.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Font.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Graphics2D.hs create mode 100644 libraries/Win32/Graphics/Win32/GDI/HDC.hs create mode 100644 libraries/Win32/Graphics/Win32/GDI/Palette.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Path.hs create mode 100644 libraries/Win32/Graphics/Win32/GDI/Pen.hsc create mode 100644 libraries/Win32/Graphics/Win32/GDI/Region.hs create mode 100644 libraries/Win32/Graphics/Win32/GDI/Types.hsc create mode 100644 libraries/Win32/Graphics/Win32/Icon.hs create mode 100644 libraries/Win32/Graphics/Win32/Key.hsc create mode 100644 libraries/Win32/Graphics/Win32/Menu.hsc create mode 100644 libraries/Win32/Graphics/Win32/Message.hsc create mode 100644 libraries/Win32/Graphics/Win32/Misc.hsc create mode 100644 libraries/Win32/Graphics/Win32/Resource.hsc create mode 100644 libraries/Win32/Graphics/Win32/Window.hsc create mode 100644 libraries/Win32/LICENSE create mode 100644 libraries/Win32/Setup.hs create mode 100644 libraries/Win32/System/Win32.hs create mode 100644 libraries/Win32/System/Win32/Console.hsc create mode 100644 libraries/Win32/System/Win32/DLL.hsc create mode 100644 libraries/Win32/System/Win32/DebugApi.hsc create mode 100644 libraries/Win32/System/Win32/File.hsc create mode 100644 libraries/Win32/System/Win32/FileMapping.hsc create mode 100644 libraries/Win32/System/Win32/Info.hsc create mode 100644 libraries/Win32/System/Win32/Mem.hsc create mode 100644 libraries/Win32/System/Win32/NLS.hsc create mode 100644 libraries/Win32/System/Win32/Process.hsc create mode 100644 libraries/Win32/System/Win32/Registry.hsc create mode 100644 libraries/Win32/System/Win32/Security.hsc create mode 100644 libraries/Win32/System/Win32/Shell.hsc create mode 100644 libraries/Win32/System/Win32/SimpleMAPI.hsc create mode 100644 libraries/Win32/System/Win32/Time.hsc create mode 100755 libraries/Win32/System/Win32/Types.hs create mode 100644 libraries/Win32/Win32.cabal create mode 100644 libraries/Win32/cbits/HsGDI.c create mode 100644 libraries/Win32/cbits/HsWin32.c create mode 100644 libraries/Win32/cbits/WndProc.c create mode 100644 libraries/Win32/cbits/diatemp.c create mode 100644 libraries/Win32/cbits/dumpBMP.c create mode 100644 libraries/Win32/cbits/ellipse.c create mode 100644 libraries/Win32/cbits/errors.c create mode 100644 libraries/Win32/doc/HSWin32.xml create mode 100644 libraries/Win32/doc/Makefile create mode 100644 libraries/Win32/examples/Makefile create mode 100644 libraries/Win32/examples/hello.lhs create mode 100644 libraries/Win32/ghc.mk create mode 100644 libraries/Win32/include/HsGDI.h create mode 100644 libraries/Win32/include/HsWin32.h create mode 100644 libraries/Win32/include/Win32Aux.h create mode 100644 libraries/Win32/include/WndProc.h create mode 100644 libraries/Win32/include/diatemp.h create mode 100644 libraries/Win32/include/dumpBMP.h create mode 100644 libraries/Win32/include/ellipse.h create mode 100644 libraries/Win32/include/errors.h create mode 100644 libraries/Win32/include/win32debug.h create mode 100644 libraries/Win32/include/windows_cconv.h create mode 100644 libraries/Win32/prologue.txt create mode 100644 libraries/Win32/tests/Makefile create mode 100644 libraries/Win32/tests/T4452.hs create mode 100644 libraries/Win32/tests/all.T create mode 100644 libraries/Win32/tests/helloworld.hs create mode 100644 libraries/Win32/tests/lasterror.hs create mode 100644 libraries/Win32/tests/registry001.hs create mode 100644 libraries/Win32/tests/registry001.stdout create mode 100644 libraries/array/.gitignore create mode 100644 libraries/array/.travis.yml create mode 100644 libraries/array/Data/Array.hs create mode 100644 libraries/array/Data/Array/Base.hs create mode 100644 libraries/array/Data/Array/IArray.hs create mode 100644 libraries/array/Data/Array/IO.hs create mode 100644 libraries/array/Data/Array/IO/Internals.hs create mode 100644 libraries/array/Data/Array/IO/Safe.hs create mode 100644 libraries/array/Data/Array/MArray.hs create mode 100644 libraries/array/Data/Array/MArray/Safe.hs create mode 100644 libraries/array/Data/Array/ST.hs create mode 100644 libraries/array/Data/Array/ST/Safe.hs create mode 100644 libraries/array/Data/Array/Storable.hs create mode 100644 libraries/array/Data/Array/Storable/Internals.hs create mode 100644 libraries/array/Data/Array/Storable/Safe.hs create mode 100644 libraries/array/Data/Array/Unboxed.hs create mode 100644 libraries/array/Data/Array/Unsafe.hs create mode 100644 libraries/array/GNUmakefile create mode 100644 libraries/array/LICENSE create mode 100644 libraries/array/README.md create mode 100644 libraries/array/Setup.hs create mode 100644 libraries/array/array.cabal create mode 100644 libraries/array/changelog.md create mode 100644 libraries/array/ghc.mk create mode 100644 libraries/array/prologue.txt create mode 100644 libraries/array/tests/.gitignore create mode 100644 libraries/array/tests/Makefile create mode 100644 libraries/array/tests/T2120.hs create mode 100644 libraries/array/tests/T2120.stdout create mode 100644 libraries/array/tests/T9220.script create mode 100644 libraries/array/tests/T9220.stdout create mode 100644 libraries/array/tests/all.T create mode 100644 libraries/array/tests/array001.hs create mode 100644 libraries/array/tests/array001.stdout create mode 100644 libraries/array/tests/largeArray.hs create mode 100644 libraries/array/tests/largeArray.stdout create mode 100644 libraries/base/.authorspellings create mode 100644 libraries/base/.gitignore create mode 100644 libraries/base/Control/Applicative.hs create mode 100644 libraries/base/Control/Arrow.hs create mode 100644 libraries/base/Control/Category.hs create mode 100644 libraries/base/Control/Concurrent.hs create mode 100644 libraries/base/Control/Concurrent/Chan.hs create mode 100644 libraries/base/Control/Concurrent/MVar.hs create mode 100644 libraries/base/Control/Concurrent/QSem.hs create mode 100644 libraries/base/Control/Concurrent/QSemN.hs create mode 100644 libraries/base/Control/Exception.hs create mode 100644 libraries/base/Control/Exception/Base.hs create mode 100644 libraries/base/Control/Monad.hs create mode 100644 libraries/base/Control/Monad/Fix.hs create mode 100644 libraries/base/Control/Monad/Instances.hs create mode 100644 libraries/base/Control/Monad/ST.hs create mode 100644 libraries/base/Control/Monad/ST/Imp.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Imp.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Safe.hs create mode 100644 libraries/base/Control/Monad/ST/Lazy/Unsafe.hs create mode 100644 libraries/base/Control/Monad/ST/Safe.hs create mode 100644 libraries/base/Control/Monad/ST/Strict.hs create mode 100644 libraries/base/Control/Monad/ST/Unsafe.hs create mode 100644 libraries/base/Control/Monad/Zip.hs create mode 100644 libraries/base/Data/Bifunctor.hs create mode 100644 libraries/base/Data/Bits.hs create mode 100644 libraries/base/Data/Bool.hs create mode 100644 libraries/base/Data/Char.hs create mode 100644 libraries/base/Data/Coerce.hs create mode 100644 libraries/base/Data/Complex.hs create mode 100644 libraries/base/Data/Data.hs create mode 100644 libraries/base/Data/Dynamic.hs create mode 100644 libraries/base/Data/Either.hs create mode 100644 libraries/base/Data/Eq.hs create mode 100644 libraries/base/Data/Fixed.hs create mode 100644 libraries/base/Data/Foldable.hs create mode 100644 libraries/base/Data/Function.hs create mode 100644 libraries/base/Data/Functor.hs create mode 100644 libraries/base/Data/Functor/Identity.hs create mode 100644 libraries/base/Data/IORef.hs create mode 100644 libraries/base/Data/Int.hs create mode 100644 libraries/base/Data/Ix.hs create mode 100644 libraries/base/Data/List.hs create mode 100644 libraries/base/Data/Maybe.hs create mode 100644 libraries/base/Data/Monoid.hs create mode 100644 libraries/base/Data/OldList.hs create mode 100644 libraries/base/Data/Ord.hs create mode 100644 libraries/base/Data/Proxy.hs create mode 100644 libraries/base/Data/Ratio.hs create mode 100644 libraries/base/Data/STRef.hs create mode 100644 libraries/base/Data/STRef/Lazy.hs create mode 100644 libraries/base/Data/STRef/Strict.hs create mode 100644 libraries/base/Data/String.hs create mode 100644 libraries/base/Data/Traversable.hs create mode 100644 libraries/base/Data/Tuple.hs create mode 100644 libraries/base/Data/Type/Bool.hs create mode 100644 libraries/base/Data/Type/Coercion.hs create mode 100644 libraries/base/Data/Type/Equality.hs create mode 100644 libraries/base/Data/Typeable.hs create mode 100644 libraries/base/Data/Typeable/Internal.hs create mode 100644 libraries/base/Data/Unique.hs create mode 100644 libraries/base/Data/Version.hs create mode 100644 libraries/base/Data/Void.hs create mode 100644 libraries/base/Data/Word.hs create mode 100644 libraries/base/Debug/Trace.hs create mode 100644 libraries/base/Foreign.hs create mode 100644 libraries/base/Foreign/C.hs create mode 100644 libraries/base/Foreign/C/Error.hs create mode 100644 libraries/base/Foreign/C/String.hs create mode 100644 libraries/base/Foreign/C/Types.hs create mode 100644 libraries/base/Foreign/Concurrent.hs create mode 100644 libraries/base/Foreign/ForeignPtr.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Imp.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Safe.hs create mode 100644 libraries/base/Foreign/ForeignPtr/Unsafe.hs create mode 100644 libraries/base/Foreign/Marshal.hs create mode 100644 libraries/base/Foreign/Marshal/Alloc.hs create mode 100644 libraries/base/Foreign/Marshal/Array.hs create mode 100644 libraries/base/Foreign/Marshal/Error.hs create mode 100644 libraries/base/Foreign/Marshal/Pool.hs create mode 100644 libraries/base/Foreign/Marshal/Safe.hs create mode 100644 libraries/base/Foreign/Marshal/Unsafe.hs create mode 100644 libraries/base/Foreign/Marshal/Utils.hs create mode 100644 libraries/base/Foreign/Ptr.hs create mode 100644 libraries/base/Foreign/Safe.hs create mode 100644 libraries/base/Foreign/StablePtr.hs create mode 100644 libraries/base/Foreign/Storable.hs create mode 100644 libraries/base/GHC/Arr.hs create mode 100644 libraries/base/GHC/Base.hs create mode 100644 libraries/base/GHC/Char.hs create mode 100644 libraries/base/GHC/Conc.hs create mode 100644 libraries/base/GHC/Conc/IO.hs create mode 100644 libraries/base/GHC/Conc/Signal.hs create mode 100644 libraries/base/GHC/Conc/Sync.hs create mode 100644 libraries/base/GHC/Conc/Windows.hs create mode 100644 libraries/base/GHC/ConsoleHandler.hs create mode 100644 libraries/base/GHC/Constants.hs create mode 100644 libraries/base/GHC/Desugar.hs create mode 100644 libraries/base/GHC/Enum.hs create mode 100644 libraries/base/GHC/Environment.hs create mode 100644 libraries/base/GHC/Err.hs create mode 100644 libraries/base/GHC/Event.hs create mode 100644 libraries/base/GHC/Event/Arr.hs create mode 100644 libraries/base/GHC/Event/Array.hs create mode 100644 libraries/base/GHC/Event/Clock.hsc create mode 100644 libraries/base/GHC/Event/Control.hs create mode 100644 libraries/base/GHC/Event/EPoll.hsc create mode 100644 libraries/base/GHC/Event/IntTable.hs create mode 100644 libraries/base/GHC/Event/Internal.hs create mode 100644 libraries/base/GHC/Event/KQueue.hsc create mode 100644 libraries/base/GHC/Event/Manager.hs create mode 100644 libraries/base/GHC/Event/PSQ.hs create mode 100644 libraries/base/GHC/Event/Poll.hsc create mode 100644 libraries/base/GHC/Event/Thread.hs create mode 100644 libraries/base/GHC/Event/TimerManager.hs create mode 100644 libraries/base/GHC/Event/Unique.hs create mode 100644 libraries/base/GHC/Exception.hs create mode 100644 libraries/base/GHC/Exception.hs-boot create mode 100755 libraries/base/GHC/Exts.hs create mode 100644 libraries/base/GHC/Fingerprint.hs create mode 100644 libraries/base/GHC/Fingerprint.hs-boot create mode 100644 libraries/base/GHC/Fingerprint/Type.hs create mode 100644 libraries/base/GHC/Float.hs create mode 100644 libraries/base/GHC/Float/ConversionUtils.hs create mode 100644 libraries/base/GHC/Float/RealFracMethods.hs create mode 100644 libraries/base/GHC/Foreign.hs create mode 100644 libraries/base/GHC/ForeignPtr.hs create mode 100644 libraries/base/GHC/GHCi.hs create mode 100644 libraries/base/GHC/Generics.hs create mode 100644 libraries/base/GHC/IO.hs create mode 100644 libraries/base/GHC/IO.hs-boot create mode 100644 libraries/base/GHC/IO/Buffer.hs create mode 100644 libraries/base/GHC/IO/BufferedIO.hs create mode 100644 libraries/base/GHC/IO/Device.hs create mode 100644 libraries/base/GHC/IO/Encoding.hs create mode 100644 libraries/base/GHC/IO/Encoding.hs-boot create mode 100644 libraries/base/GHC/IO/Encoding/CodePage.hs create mode 100644 libraries/base/GHC/IO/Encoding/CodePage/API.hs create mode 100644 libraries/base/GHC/IO/Encoding/CodePage/Table.hs create mode 100644 libraries/base/GHC/IO/Encoding/Failure.hs create mode 100644 libraries/base/GHC/IO/Encoding/Iconv.hs create mode 100644 libraries/base/GHC/IO/Encoding/Latin1.hs create mode 100644 libraries/base/GHC/IO/Encoding/Types.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF16.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF32.hs create mode 100644 libraries/base/GHC/IO/Encoding/UTF8.hs create mode 100644 libraries/base/GHC/IO/Exception.hs create mode 100644 libraries/base/GHC/IO/Exception.hs-boot create mode 100644 libraries/base/GHC/IO/FD.hs create mode 100644 libraries/base/GHC/IO/Handle.hs create mode 100644 libraries/base/GHC/IO/Handle.hs-boot create mode 100644 libraries/base/GHC/IO/Handle/FD.hs create mode 100644 libraries/base/GHC/IO/Handle/FD.hs-boot create mode 100644 libraries/base/GHC/IO/Handle/Internals.hs create mode 100644 libraries/base/GHC/IO/Handle/Text.hs create mode 100644 libraries/base/GHC/IO/Handle/Types.hs create mode 100644 libraries/base/GHC/IO/IOMode.hs create mode 100644 libraries/base/GHC/IOArray.hs create mode 100644 libraries/base/GHC/IORef.hs create mode 100644 libraries/base/GHC/IP.hs create mode 100644 libraries/base/GHC/Int.hs create mode 100644 libraries/base/GHC/List.hs create mode 100644 libraries/base/GHC/MVar.hs create mode 100644 libraries/base/GHC/Natural.hs create mode 100644 libraries/base/GHC/Num.hs create mode 100644 libraries/base/GHC/OldList.hs create mode 100644 libraries/base/GHC/PArr.hs create mode 100644 libraries/base/GHC/Pack.hs create mode 100644 libraries/base/GHC/Profiling.hs create mode 100644 libraries/base/GHC/Ptr.hs create mode 100644 libraries/base/GHC/RTS/Flags.hsc create mode 100644 libraries/base/GHC/Read.hs create mode 100644 libraries/base/GHC/Real.hs create mode 100644 libraries/base/GHC/ST.hs create mode 100644 libraries/base/GHC/STRef.hs create mode 100644 libraries/base/GHC/Show.hs create mode 100644 libraries/base/GHC/SrcLoc.hs create mode 100644 libraries/base/GHC/Stable.hs create mode 100644 libraries/base/GHC/Stack.hsc create mode 100644 libraries/base/GHC/StaticPtr.hs create mode 100644 libraries/base/GHC/Stats.hsc create mode 100644 libraries/base/GHC/Storable.hs create mode 100644 libraries/base/GHC/TopHandler.hs create mode 100644 libraries/base/GHC/TypeLits.hs create mode 100644 libraries/base/GHC/Unicode.hs create mode 100644 libraries/base/GHC/Weak.hs create mode 100644 libraries/base/GHC/Windows.hs create mode 100644 libraries/base/GHC/Word.hs create mode 100644 libraries/base/GNUmakefile create mode 100644 libraries/base/LICENSE create mode 100644 libraries/base/Numeric.hs create mode 100644 libraries/base/Numeric/Natural.hs create mode 100644 libraries/base/Prelude.hs create mode 100644 libraries/base/Setup.hs create mode 100644 libraries/base/System/CPUTime.hsc create mode 100644 libraries/base/System/Console/GetOpt.hs create mode 100644 libraries/base/System/Environment.hs create mode 100644 libraries/base/System/Environment/ExecutablePath.hsc create mode 100644 libraries/base/System/Exit.hs create mode 100644 libraries/base/System/IO.hs create mode 100644 libraries/base/System/IO/Error.hs create mode 100644 libraries/base/System/IO/Unsafe.hs create mode 100644 libraries/base/System/Info.hs create mode 100644 libraries/base/System/Mem.hs create mode 100644 libraries/base/System/Mem/StableName.hs create mode 100644 libraries/base/System/Mem/Weak.hs create mode 100644 libraries/base/System/Posix/Internals.hs create mode 100644 libraries/base/System/Posix/Types.hs create mode 100644 libraries/base/System/Timeout.hs create mode 100644 libraries/base/Text/ParserCombinators/ReadP.hs create mode 100644 libraries/base/Text/ParserCombinators/ReadPrec.hs create mode 100644 libraries/base/Text/Printf.hs create mode 100644 libraries/base/Text/Read.hs create mode 100644 libraries/base/Text/Read/Lex.hs create mode 100644 libraries/base/Text/Show.hs create mode 100644 libraries/base/Text/Show/Functions.hs create mode 100644 libraries/base/Unsafe/Coerce.hs create mode 100644 libraries/base/aclocal.m4 create mode 100644 libraries/base/base.buildinfo.in create mode 100644 libraries/base/base.cabal create mode 100644 libraries/base/cbits/DarwinUtils.c create mode 100644 libraries/base/cbits/PrelIOUtils.c create mode 100644 libraries/base/cbits/README.Unicode create mode 100644 libraries/base/cbits/SetEnv.c create mode 100644 libraries/base/cbits/WCsubst.c create mode 100644 libraries/base/cbits/Win32Utils.c create mode 100644 libraries/base/cbits/consUtils.c create mode 100644 libraries/base/cbits/iconv.c create mode 100644 libraries/base/cbits/inputReady.c create mode 100644 libraries/base/cbits/md5.c create mode 100644 libraries/base/cbits/primFloat.c create mode 100644 libraries/base/cbits/rts.c create mode 100644 libraries/base/cbits/sysconf.c create mode 100644 libraries/base/cbits/ubconfc create mode 100644 libraries/base/changelog.md create mode 100644 libraries/base/codepages/MakeTable.hs create mode 100644 libraries/base/codepages/Makefile create mode 100644 libraries/base/config.guess create mode 100644 libraries/base/config.sub create mode 100755 libraries/base/configure create mode 100644 libraries/base/configure.ac create mode 100644 libraries/base/ghc.mk create mode 100644 libraries/base/include/CTypes.h create mode 100644 libraries/base/include/EventConfig.h.in create mode 100644 libraries/base/include/HsBase.h create mode 100644 libraries/base/include/HsBaseConfig.h.in create mode 100644 libraries/base/include/HsEvent.h create mode 100644 libraries/base/include/Typeable.h create mode 100644 libraries/base/include/WCsubst.h create mode 100644 libraries/base/include/consUtils.h create mode 100644 libraries/base/include/ieee-flpt.h create mode 100644 libraries/base/include/md5.h create mode 100644 libraries/base/install-sh create mode 100644 libraries/base/prologue.txt create mode 100644 libraries/base/tests/.gitignore create mode 100644 libraries/base/tests/CPUTime001.hs create mode 100644 libraries/base/tests/CPUTime001.stdout create mode 100644 libraries/base/tests/CatEntail.hs create mode 100644 libraries/base/tests/CatPairs.hs create mode 100644 libraries/base/tests/Concurrent/4876.stdout create mode 100644 libraries/base/tests/Concurrent/Chan001.hs create mode 100644 libraries/base/tests/Concurrent/Chan001.stdout create mode 100644 libraries/base/tests/Concurrent/Chan002.hs create mode 100644 libraries/base/tests/Concurrent/Chan002.stdout create mode 100644 libraries/base/tests/Concurrent/Chan003.hs create mode 100644 libraries/base/tests/Concurrent/Chan003.stdout create mode 100644 libraries/base/tests/Concurrent/MVar001.hs create mode 100644 libraries/base/tests/Concurrent/MVar001.stdout create mode 100644 libraries/base/tests/Concurrent/Makefile create mode 100644 libraries/base/tests/Concurrent/ThreadDelay001.hs create mode 100644 libraries/base/tests/Concurrent/all.T create mode 100644 libraries/base/tests/IO/IOError001.hs create mode 100644 libraries/base/tests/IO/IOError001.stdout create mode 100644 libraries/base/tests/IO/IOError001.stdout-hugs create mode 100644 libraries/base/tests/IO/IOError002.hs create mode 100644 libraries/base/tests/IO/IOError002.stdout create mode 100644 libraries/base/tests/IO/Makefile create mode 100644 libraries/base/tests/IO/T2122.hs create mode 100644 libraries/base/tests/IO/T3307.hs create mode 100644 libraries/base/tests/IO/T3307.stdout create mode 100644 libraries/base/tests/IO/T4144.hs create mode 100644 libraries/base/tests/IO/T4144.stdout create mode 100644 libraries/base/tests/IO/T4808.hs create mode 100644 libraries/base/tests/IO/T4808.stderr create mode 100644 libraries/base/tests/IO/T4808.stdout create mode 100644 libraries/base/tests/IO/T4855.hs create mode 100644 libraries/base/tests/IO/T4855.stderr create mode 100644 libraries/base/tests/IO/T4895.hs create mode 100644 libraries/base/tests/IO/T4895.stdout create mode 100644 libraries/base/tests/IO/T7853.hs create mode 100644 libraries/base/tests/IO/T7853.stdout create mode 100644 libraries/base/tests/IO/all.T create mode 100644 libraries/base/tests/IO/concio001.hs create mode 100644 libraries/base/tests/IO/concio001.stdout create mode 100644 libraries/base/tests/IO/concio001.thr.stdout create mode 100644 libraries/base/tests/IO/concio002.hs create mode 100644 libraries/base/tests/IO/concio002.stdout create mode 100644 libraries/base/tests/IO/countReaders001.hs create mode 100644 libraries/base/tests/IO/countReaders001.stdout create mode 100644 libraries/base/tests/IO/decodingerror001.hs create mode 100644 libraries/base/tests/IO/decodingerror001.in1 create mode 100644 libraries/base/tests/IO/decodingerror001.in2 create mode 100644 libraries/base/tests/IO/decodingerror001.stdout create mode 100644 libraries/base/tests/IO/decodingerror002.hs create mode 100644 libraries/base/tests/IO/decodingerror002.in create mode 100644 libraries/base/tests/IO/decodingerror002.stdout create mode 100644 libraries/base/tests/IO/encoded-data/CP1251-UTF8.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP1251.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP936-UTF8.txt create mode 100644 libraries/base/tests/IO/encoded-data/CP936.txt create mode 100644 libraries/base/tests/IO/encoding001.hs create mode 100644 libraries/base/tests/IO/encoding002.hs create mode 100644 libraries/base/tests/IO/encoding002.stdout create mode 100644 libraries/base/tests/IO/encoding003.hs create mode 100644 libraries/base/tests/IO/encoding003.stdout create mode 100644 libraries/base/tests/IO/encoding004.hs create mode 100644 libraries/base/tests/IO/encoding004.stdout create mode 100644 libraries/base/tests/IO/encoding005.hs create mode 100644 libraries/base/tests/IO/encoding005.stdout create mode 100644 libraries/base/tests/IO/encodingerror001.hs create mode 100644 libraries/base/tests/IO/encodingerror001.stdout create mode 100644 libraries/base/tests/IO/environment001.hs create mode 100644 libraries/base/tests/IO/environment001.stdout create mode 100644 libraries/base/tests/IO/finalization001.hs create mode 100644 libraries/base/tests/IO/finalization001.stdout create mode 100644 libraries/base/tests/IO/hClose001.hs create mode 100644 libraries/base/tests/IO/hClose001.stdout create mode 100644 libraries/base/tests/IO/hClose002.hs create mode 100644 libraries/base/tests/IO/hClose002.stdout create mode 100644 libraries/base/tests/IO/hClose002.stdout-i386-unknown-solaris2 create mode 100644 libraries/base/tests/IO/hClose002.stdout-x86_64-unknown-solaris2 create mode 100644 libraries/base/tests/IO/hClose003.hs create mode 100644 libraries/base/tests/IO/hClose003.stdout create mode 100644 libraries/base/tests/IO/hDuplicateTo001.hs create mode 100644 libraries/base/tests/IO/hDuplicateTo001.stderr create mode 100644 libraries/base/tests/IO/hFileSize001.hs create mode 100644 libraries/base/tests/IO/hFileSize001.stdout create mode 100644 libraries/base/tests/IO/hFileSize002.hs create mode 100644 libraries/base/tests/IO/hFileSize002.stdout create mode 100644 libraries/base/tests/IO/hFlush001.hs create mode 100644 libraries/base/tests/IO/hFlush001.stdout create mode 100644 libraries/base/tests/IO/hGetBuf001.hs create mode 100644 libraries/base/tests/IO/hGetBuf001.stdout create mode 100644 libraries/base/tests/IO/hGetBuffering001.hs create mode 100644 libraries/base/tests/IO/hGetBuffering001.stdout create mode 100644 libraries/base/tests/IO/hGetChar001.hs create mode 100644 libraries/base/tests/IO/hGetChar001.stdin create mode 100644 libraries/base/tests/IO/hGetChar001.stdout create mode 100644 libraries/base/tests/IO/hGetLine001.hs create mode 100644 libraries/base/tests/IO/hGetLine001.stdout create mode 100644 libraries/base/tests/IO/hGetLine002.hs create mode 100644 libraries/base/tests/IO/hGetLine002.stdin create mode 100644 libraries/base/tests/IO/hGetLine002.stdout create mode 100644 libraries/base/tests/IO/hGetLine002.stdout-hugs create mode 100644 libraries/base/tests/IO/hGetLine003.hs create mode 100644 libraries/base/tests/IO/hGetLine003.stdin create mode 100644 libraries/base/tests/IO/hGetLine003.stdout create mode 100644 libraries/base/tests/IO/hGetPosn001.hs create mode 100644 libraries/base/tests/IO/hGetPosn001.in create mode 100644 libraries/base/tests/IO/hGetPosn001.stdout create mode 100644 libraries/base/tests/IO/hGetPosn001.stdout-hugs create mode 100644 libraries/base/tests/IO/hIsEOF001.hs create mode 100644 libraries/base/tests/IO/hIsEOF001.stdout create mode 100644 libraries/base/tests/IO/hIsEOF002.hs create mode 100644 libraries/base/tests/IO/hIsEOF002.stdout create mode 100644 libraries/base/tests/IO/hReady001.hs create mode 100644 libraries/base/tests/IO/hReady001.stdout create mode 100644 libraries/base/tests/IO/hReady002.hs create mode 100644 libraries/base/tests/IO/hReady002.stdout create mode 100644 libraries/base/tests/IO/hSeek001.hs create mode 100644 libraries/base/tests/IO/hSeek001.in create mode 100644 libraries/base/tests/IO/hSeek001.stdout create mode 100644 libraries/base/tests/IO/hSeek002.hs create mode 100644 libraries/base/tests/IO/hSeek002.stdout create mode 100644 libraries/base/tests/IO/hSeek003.hs create mode 100644 libraries/base/tests/IO/hSeek003.stdout create mode 100644 libraries/base/tests/IO/hSeek004.hs create mode 100644 libraries/base/tests/IO/hSeek004.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering002.hs create mode 100644 libraries/base/tests/IO/hSetBuffering002.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering003.hs create mode 100644 libraries/base/tests/IO/hSetBuffering003.stderr create mode 100644 libraries/base/tests/IO/hSetBuffering003.stdout create mode 100644 libraries/base/tests/IO/hSetBuffering004.hs create mode 100644 libraries/base/tests/IO/hSetBuffering004.stdout create mode 100644 libraries/base/tests/IO/hSetEncoding001.hs create mode 100644 libraries/base/tests/IO/hSetEncoding001.in create mode 100644 libraries/base/tests/IO/hSetEncoding001.stdout create mode 100644 libraries/base/tests/IO/hSetEncoding002.hs create mode 100644 libraries/base/tests/IO/hSetEncoding002.stdout create mode 100644 libraries/base/tests/IO/ioeGetErrorString001.hs create mode 100644 libraries/base/tests/IO/ioeGetErrorString001.stdout create mode 100644 libraries/base/tests/IO/ioeGetFileName001.hs create mode 100644 libraries/base/tests/IO/ioeGetFileName001.stdout create mode 100644 libraries/base/tests/IO/ioeGetHandle001.hs create mode 100644 libraries/base/tests/IO/ioeGetHandle001.stdout create mode 100644 libraries/base/tests/IO/isEOF001.hs create mode 100644 libraries/base/tests/IO/isEOF001.stdout create mode 100644 libraries/base/tests/IO/latin1 create mode 100644 libraries/base/tests/IO/misc001.hs create mode 100644 libraries/base/tests/IO/misc001.stdout create mode 100644 libraries/base/tests/IO/newline001.hs create mode 100644 libraries/base/tests/IO/openFile001.hs create mode 100644 libraries/base/tests/IO/openFile001.stdout create mode 100644 libraries/base/tests/IO/openFile002.hs create mode 100644 libraries/base/tests/IO/openFile002.stderr create mode 100644 libraries/base/tests/IO/openFile002.stderr-hugs create mode 100644 libraries/base/tests/IO/openFile003.hs create mode 100644 libraries/base/tests/IO/openFile003.stdout create mode 100644 libraries/base/tests/IO/openFile003.stdout-mingw32 create mode 100644 libraries/base/tests/IO/openFile003.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/IO/openFile003.stdout-sparc-sun-solaris2 create mode 100644 libraries/base/tests/IO/openFile004.hs create mode 100644 libraries/base/tests/IO/openFile004.stdout create mode 100644 libraries/base/tests/IO/openFile005.hs create mode 100644 libraries/base/tests/IO/openFile005.stdout create mode 100644 libraries/base/tests/IO/openFile006.hs create mode 100644 libraries/base/tests/IO/openFile006.stdout create mode 100644 libraries/base/tests/IO/openFile007.hs create mode 100644 libraries/base/tests/IO/openFile007.stdout create mode 100644 libraries/base/tests/IO/openFile008.hs create mode 100644 libraries/base/tests/IO/openTempFile001.hs create mode 100644 libraries/base/tests/IO/putStr001.hs create mode 100644 libraries/base/tests/IO/putStr001.stdout create mode 100644 libraries/base/tests/IO/readFile001.hs create mode 100644 libraries/base/tests/IO/readFile001.stdout create mode 100644 libraries/base/tests/IO/readwrite001.hs create mode 100644 libraries/base/tests/IO/readwrite001.stdout create mode 100644 libraries/base/tests/IO/readwrite002.hs create mode 100644 libraries/base/tests/IO/readwrite002.stdout create mode 100644 libraries/base/tests/IO/readwrite003.hs create mode 100644 libraries/base/tests/IO/readwrite003.stdout create mode 100644 libraries/base/tests/IO/utf8-test create mode 100644 libraries/base/tests/Makefile create mode 100644 libraries/base/tests/Memo1.lhs create mode 100644 libraries/base/tests/Memo2.lhs create mode 100644 libraries/base/tests/Numeric/Makefile create mode 100644 libraries/base/tests/Numeric/all.T create mode 100644 libraries/base/tests/Numeric/num001.hs create mode 100644 libraries/base/tests/Numeric/num001.stdout create mode 100644 libraries/base/tests/Numeric/num002.hs create mode 100644 libraries/base/tests/Numeric/num002.stdout create mode 100644 libraries/base/tests/Numeric/num002.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num002.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num002.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num002.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num003.hs create mode 100644 libraries/base/tests/Numeric/num003.stdout create mode 100644 libraries/base/tests/Numeric/num003.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num003.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num003.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num003.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num004.hs create mode 100644 libraries/base/tests/Numeric/num004.stdout create mode 100644 libraries/base/tests/Numeric/num004.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num004.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num004.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num004.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num005.hs create mode 100644 libraries/base/tests/Numeric/num005.stdout create mode 100644 libraries/base/tests/Numeric/num005.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/Numeric/num005.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/Numeric/num005.stdout-ws-64 create mode 100644 libraries/base/tests/Numeric/num005.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/Numeric/num006.hs create mode 100644 libraries/base/tests/Numeric/num006.stdout create mode 100644 libraries/base/tests/Numeric/num007.hs create mode 100644 libraries/base/tests/Numeric/num007.stdout create mode 100644 libraries/base/tests/Numeric/num008.hs create mode 100644 libraries/base/tests/Numeric/num008.stdout create mode 100644 libraries/base/tests/Numeric/num009.hs create mode 100644 libraries/base/tests/Numeric/num009.stdout create mode 100644 libraries/base/tests/Numeric/num009.stdout-i386-unknown-mingw32 create mode 100644 libraries/base/tests/Numeric/num010.hs create mode 100644 libraries/base/tests/Numeric/num010.stdout create mode 100644 libraries/base/tests/System/Makefile create mode 100644 libraries/base/tests/System/T5930.hs create mode 100644 libraries/base/tests/System/T5930.stdout create mode 100644 libraries/base/tests/System/Timeout001.hs create mode 100644 libraries/base/tests/System/all.T create mode 100644 libraries/base/tests/System/exitWith001.hs create mode 100644 libraries/base/tests/System/exitWith001.stdout create mode 100644 libraries/base/tests/System/getArgs001.hs create mode 100644 libraries/base/tests/System/getArgs001.stdout create mode 100644 libraries/base/tests/System/getEnv001.hs create mode 100644 libraries/base/tests/System/getEnv001.stdout create mode 100644 libraries/base/tests/System/system001.hs create mode 100644 libraries/base/tests/System/system001.stdout create mode 100644 libraries/base/tests/T10149.hs create mode 100644 libraries/base/tests/T10149.stdout create mode 100644 libraries/base/tests/T2528.hs create mode 100644 libraries/base/tests/T2528.stdout create mode 100644 libraries/base/tests/T4006.hs create mode 100644 libraries/base/tests/T4006.stdout create mode 100644 libraries/base/tests/T5943.hs create mode 100644 libraries/base/tests/T5943.stdout create mode 100644 libraries/base/tests/T5962.hs create mode 100644 libraries/base/tests/T5962.stdout create mode 100644 libraries/base/tests/T7034.hs create mode 100644 libraries/base/tests/T7034.stdout create mode 100644 libraries/base/tests/T7457.hs create mode 100644 libraries/base/tests/T7457.stdout create mode 100644 libraries/base/tests/T7653.hs create mode 100644 libraries/base/tests/T7773.hs create mode 100644 libraries/base/tests/T7773.stdout create mode 100644 libraries/base/tests/T7787.hs create mode 100644 libraries/base/tests/T7787.stdout create mode 100644 libraries/base/tests/T8089.hs create mode 100644 libraries/base/tests/T8766.hs create mode 100644 libraries/base/tests/T8766.stdout create mode 100644 libraries/base/tests/T9111.hs create mode 100644 libraries/base/tests/T9395.hs create mode 100644 libraries/base/tests/T9395.stderr create mode 100644 libraries/base/tests/T9532.hs create mode 100644 libraries/base/tests/T9532.stdout create mode 100644 libraries/base/tests/T9586.hs create mode 100644 libraries/base/tests/T9681.hs create mode 100644 libraries/base/tests/T9681.stderr create mode 100644 libraries/base/tests/T9826.hs create mode 100644 libraries/base/tests/T9826.stdout create mode 100644 libraries/base/tests/Text.Printf/Makefile create mode 100644 libraries/base/tests/Text.Printf/T1548.hs create mode 100644 libraries/base/tests/Text.Printf/T1548.stdout create mode 100644 libraries/base/tests/Text.Printf/all.T create mode 100644 libraries/base/tests/addr001.hs create mode 100644 libraries/base/tests/addr001.stdout create mode 100644 libraries/base/tests/addr001.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/addr001.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/addr001.stdout-ws-64 create mode 100644 libraries/base/tests/addr001.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/all.T create mode 100644 libraries/base/tests/assert.hs create mode 100644 libraries/base/tests/assert.stderr create mode 100644 libraries/base/tests/char001.hs create mode 100644 libraries/base/tests/char001.stdout create mode 100644 libraries/base/tests/char002.hs create mode 100644 libraries/base/tests/char002.stdout create mode 100644 libraries/base/tests/cstring001.hs create mode 100644 libraries/base/tests/data-fixed-show-read.hs create mode 100644 libraries/base/tests/data-fixed-show-read.stdout create mode 100644 libraries/base/tests/dynamic001.hs create mode 100644 libraries/base/tests/dynamic001.stdout create mode 100644 libraries/base/tests/dynamic002.hs create mode 100644 libraries/base/tests/dynamic002.stdout create mode 100644 libraries/base/tests/dynamic003.hs create mode 100644 libraries/base/tests/dynamic003.stdout create mode 100644 libraries/base/tests/dynamic004.hs create mode 100644 libraries/base/tests/dynamic004.stdout create mode 100644 libraries/base/tests/dynamic005.hs create mode 100644 libraries/base/tests/dynamic005.stdout create mode 100644 libraries/base/tests/echo001.hs create mode 100644 libraries/base/tests/echo001.stdout create mode 100644 libraries/base/tests/enum01.hs create mode 100644 libraries/base/tests/enum01.stdout create mode 100644 libraries/base/tests/enum01.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum01.stdout-hugs create mode 100644 libraries/base/tests/enum01.stdout-ws-64 create mode 100644 libraries/base/tests/enum02.hs create mode 100644 libraries/base/tests/enum02.stdout create mode 100644 libraries/base/tests/enum02.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum02.stdout-hugs create mode 100644 libraries/base/tests/enum02.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/enum02.stdout-ws-64 create mode 100644 libraries/base/tests/enum02.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/enum03.hs create mode 100644 libraries/base/tests/enum03.stdout create mode 100644 libraries/base/tests/enum03.stdout-alpha-dec-osf3 create mode 100644 libraries/base/tests/enum03.stdout-hugs create mode 100644 libraries/base/tests/enum03.stdout-mips-sgi-irix create mode 100644 libraries/base/tests/enum03.stdout-ws-64 create mode 100644 libraries/base/tests/enum03.stdout-x86_64-unknown-openbsd create mode 100644 libraries/base/tests/enum04.hs create mode 100644 libraries/base/tests/enum04.stdout create mode 100644 libraries/base/tests/enumDouble.hs create mode 100644 libraries/base/tests/enumDouble.stdout create mode 100644 libraries/base/tests/enumRatio.hs create mode 100644 libraries/base/tests/enumRatio.stdout create mode 100755 libraries/base/tests/enum_processor.py create mode 100644 libraries/base/tests/exceptionsrun001.hs create mode 100644 libraries/base/tests/exceptionsrun001.stdout create mode 100644 libraries/base/tests/exceptionsrun002.hs create mode 100644 libraries/base/tests/exceptionsrun002.stdout create mode 100644 libraries/base/tests/fixed.hs create mode 100644 libraries/base/tests/fixed.stdout create mode 100644 libraries/base/tests/foldableArray.hs create mode 100644 libraries/base/tests/foldableArray.stdout create mode 100644 libraries/base/tests/genericNegative001.hs create mode 100644 libraries/base/tests/genericNegative001.stdout create mode 100644 libraries/base/tests/hGetBuf002.hs create mode 100644 libraries/base/tests/hGetBuf002.stdout create mode 100644 libraries/base/tests/hGetBuf003.hs create mode 100644 libraries/base/tests/hGetBuf003.stdout create mode 100644 libraries/base/tests/hPutBuf001.hs create mode 100644 libraries/base/tests/hPutBuf001.stdout create mode 100644 libraries/base/tests/hPutBuf002.hs create mode 100644 libraries/base/tests/hPutBuf002.stdout create mode 100644 libraries/base/tests/hTell001.hs create mode 100644 libraries/base/tests/hTell001.stdout create mode 100644 libraries/base/tests/hTell002.hs create mode 100644 libraries/base/tests/hTell002.stdout create mode 100644 libraries/base/tests/inits.hs create mode 100644 libraries/base/tests/ioref001.hs create mode 100644 libraries/base/tests/ioref001.stdout create mode 100644 libraries/base/tests/isSuffixOf.hs create mode 100644 libraries/base/tests/isSuffixOf.stdout create mode 100644 libraries/base/tests/ix001.hs create mode 100644 libraries/base/tests/ix001.stdout create mode 100644 libraries/base/tests/length001.hs create mode 100644 libraries/base/tests/length001.stdout create mode 100644 libraries/base/tests/lex001.hs create mode 100644 libraries/base/tests/lex001.stdout create mode 100644 libraries/base/tests/list001.hs create mode 100644 libraries/base/tests/list001.stdout create mode 100644 libraries/base/tests/list001.stdout-ghc create mode 100644 libraries/base/tests/list002.hs create mode 100644 libraries/base/tests/list002.stdout create mode 100644 libraries/base/tests/list003.hs create mode 100644 libraries/base/tests/list003.stdout create mode 100644 libraries/base/tests/memo001.hs create mode 100644 libraries/base/tests/memo001.stdout create mode 100644 libraries/base/tests/memo002.hs create mode 100644 libraries/base/tests/memo002.stdout create mode 100644 libraries/base/tests/packedstring001.hs create mode 100644 libraries/base/tests/packedstring001.stdout create mode 100644 libraries/base/tests/performGC001.hs create mode 100644 libraries/base/tests/performGC001.stdout create mode 100644 libraries/base/tests/qsem001.hs create mode 100644 libraries/base/tests/qsem001.stdout create mode 100644 libraries/base/tests/qsemn001.hs create mode 100644 libraries/base/tests/qsemn001.stdout create mode 100644 libraries/base/tests/quotOverflow.hs create mode 100644 libraries/base/tests/quotOverflow.stdout create mode 100644 libraries/base/tests/rand001.hs create mode 100644 libraries/base/tests/rand001.stdout create mode 100644 libraries/base/tests/ratio001.hs create mode 100644 libraries/base/tests/ratio001.stdout create mode 100644 libraries/base/tests/ratio001.stdout-ghc create mode 100644 libraries/base/tests/readDouble001.hs create mode 100644 libraries/base/tests/readDouble001.stdout create mode 100644 libraries/base/tests/readFixed001.hs create mode 100644 libraries/base/tests/readFixed001.stdout create mode 100644 libraries/base/tests/readFloat.hs create mode 100644 libraries/base/tests/readFloat.stderr create mode 100644 libraries/base/tests/readInteger001.hs create mode 100644 libraries/base/tests/readInteger001.stdout create mode 100644 libraries/base/tests/readLitChar.hs create mode 100644 libraries/base/tests/readLitChar.stdout create mode 100644 libraries/base/tests/reads001.hs create mode 100644 libraries/base/tests/reads001.stdout create mode 100644 libraries/base/tests/show001.hs create mode 100644 libraries/base/tests/show001.stdout create mode 100644 libraries/base/tests/showDouble.hs create mode 100644 libraries/base/tests/showDouble.stdout create mode 100644 libraries/base/tests/stableptr001.hs create mode 100644 libraries/base/tests/stableptr001.stdout create mode 100644 libraries/base/tests/stableptr003.hs create mode 100644 libraries/base/tests/stableptr004.hs create mode 100644 libraries/base/tests/stableptr004.stdout create mode 100644 libraries/base/tests/stableptr005.hs create mode 100644 libraries/base/tests/stableptr005.stdout create mode 100644 libraries/base/tests/take001.hs create mode 100644 libraries/base/tests/take001.stdout create mode 100644 libraries/base/tests/tempfiles.hs create mode 100644 libraries/base/tests/tempfiles.stdout create mode 100644 libraries/base/tests/text001.hs create mode 100644 libraries/base/tests/text001.stdout create mode 100644 libraries/base/tests/topHandler01.hs create mode 100644 libraries/base/tests/topHandler01.stdout create mode 100644 libraries/base/tests/topHandler02.hs create mode 100644 libraries/base/tests/topHandler03.hs create mode 100644 libraries/base/tests/trace001.hs create mode 100644 libraries/base/tests/trace001.stderr create mode 100644 libraries/base/tests/trace001.stdout create mode 100644 libraries/base/tests/tup001.hs create mode 100644 libraries/base/tests/tup001.stdout create mode 100644 libraries/base/tests/unicode001.hs create mode 100644 libraries/base/tests/unicode001.stdout create mode 100644 libraries/base/tests/unicode001.stdout-hugs create mode 100644 libraries/base/tests/unicode002.hs create mode 100644 libraries/base/tests/unicode002.stdout create mode 100644 libraries/base/tests/weak001.hs create mode 100644 libraries/bin-package-db/GHC/PackageDb.hs create mode 100644 libraries/bin-package-db/GNUmakefile create mode 100644 libraries/bin-package-db/LICENSE create mode 100644 libraries/bin-package-db/bin-package-db.cabal create mode 100644 libraries/bin-package-db/ghc.mk create mode 100644 libraries/binary/.gitignore create mode 100644 libraries/binary/.hgignore create mode 100644 libraries/binary/.travis.yml create mode 100644 libraries/binary/GNUmakefile create mode 100644 libraries/binary/LICENSE create mode 100644 libraries/binary/README.md create mode 100755 libraries/binary/Setup.lhs create mode 100644 libraries/binary/benchmarks/Benchmark.hs create mode 100644 libraries/binary/benchmarks/Builder.hs create mode 100644 libraries/binary/benchmarks/CBenchmark.c create mode 100644 libraries/binary/benchmarks/CBenchmark.h create mode 100644 libraries/binary/benchmarks/Get.hs create mode 100644 libraries/binary/benchmarks/MemBench.hs create mode 100644 libraries/binary/binary.cabal create mode 100644 libraries/binary/changelog.md create mode 100644 libraries/binary/docs/hcar/binary-Lb.tex create mode 100644 libraries/binary/ghc.mk create mode 100644 libraries/binary/src/Data/Binary.hs create mode 100644 libraries/binary/src/Data/Binary/Builder.hs create mode 100644 libraries/binary/src/Data/Binary/Builder/Base.hs create mode 100644 libraries/binary/src/Data/Binary/Builder/Internal.hs create mode 100644 libraries/binary/src/Data/Binary/Class.hs create mode 100644 libraries/binary/src/Data/Binary/Generic.hs create mode 100644 libraries/binary/src/Data/Binary/Get.hs create mode 100644 libraries/binary/src/Data/Binary/Get/Internal.hs create mode 100644 libraries/binary/src/Data/Binary/Put.hs create mode 100644 libraries/binary/tests/Action.hs create mode 100644 libraries/binary/tests/Arbitrary.hs create mode 100644 libraries/binary/tests/File.hs create mode 100644 libraries/binary/tests/QC.hs create mode 100644 libraries/binary/tools/derive/BinaryDerive.hs create mode 100644 libraries/binary/tools/derive/Example.hs create mode 100644 libraries/bytestring/.darcs-boring create mode 100644 libraries/bytestring/.gitignore create mode 100644 libraries/bytestring/.hgignore create mode 100644 libraries/bytestring/.travis.yml create mode 100644 libraries/bytestring/Changelog.md create mode 100644 libraries/bytestring/Data/ByteString.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/ASCII.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Extra.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Internal.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/ASCII.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/Binary.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/Internal.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/Internal/Base16.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/Internal/Floating.hs create mode 100644 libraries/bytestring/Data/ByteString/Builder/Prim/Internal/UncheckedShifts.hs create mode 100644 libraries/bytestring/Data/ByteString/Char8.hs create mode 100644 libraries/bytestring/Data/ByteString/Internal.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy/Builder.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy/Builder/ASCII.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy/Builder/Extras.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy/Char8.hs create mode 100644 libraries/bytestring/Data/ByteString/Lazy/Internal.hs create mode 100644 libraries/bytestring/Data/ByteString/Short.hs create mode 100644 libraries/bytestring/Data/ByteString/Short/Internal.hs create mode 100644 libraries/bytestring/Data/ByteString/Unsafe.hs create mode 100644 libraries/bytestring/GNUmakefile create mode 100644 libraries/bytestring/LICENSE create mode 100644 libraries/bytestring/README.md create mode 100644 libraries/bytestring/Setup.hs create mode 100644 libraries/bytestring/TODO create mode 100644 libraries/bytestring/bench/BenchAll.hs create mode 100644 libraries/bytestring/bench/BoundsCheckFusion.hs create mode 100644 libraries/bytestring/bench/CSV.hs create mode 100644 libraries/bytestring/bench/LICENSE create mode 100644 libraries/bytestring/bench/bench-bytestring.cabal create mode 100644 libraries/bytestring/bytestring.cabal create mode 100644 libraries/bytestring/cbits/fpstring.c create mode 100644 libraries/bytestring/cbits/itoa.c create mode 100644 libraries/bytestring/ghc.mk create mode 100644 libraries/bytestring/include/fpstring.h create mode 100644 libraries/bytestring/tests/.gitignore create mode 100644 libraries/bytestring/tests/Bench.hs create mode 100644 libraries/bytestring/tests/BenchUtils.hs create mode 100644 libraries/bytestring/tests/Hash.hs create mode 100644 libraries/bytestring/tests/Makefile create mode 100644 libraries/bytestring/tests/Properties.hs create mode 100644 libraries/bytestring/tests/QuickCheckUtils.hs create mode 100644 libraries/bytestring/tests/Regressions.hs create mode 100644 libraries/bytestring/tests/Rules.hs create mode 100644 libraries/bytestring/tests/TestFramework.hs create mode 100644 libraries/bytestring/tests/Units.hs create mode 100644 libraries/bytestring/tests/Usr.Dict.Words create mode 100644 libraries/bytestring/tests/Words.hs create mode 100644 libraries/bytestring/tests/builder/Data/ByteString/Builder/Prim/TestUtils.hs create mode 100644 libraries/bytestring/tests/builder/Data/ByteString/Builder/Prim/Tests.hs create mode 100644 libraries/bytestring/tests/builder/Data/ByteString/Builder/Tests.hs create mode 100644 libraries/bytestring/tests/builder/TestSuite.hs create mode 100644 libraries/bytestring/tests/bytestring-tests.cabal create mode 100644 libraries/bytestring/tests/data create mode 100644 libraries/bytestring/tests/edit.hs create mode 100644 libraries/bytestring/tests/groupby.hs create mode 100644 libraries/bytestring/tests/iavor.hs create mode 100644 libraries/bytestring/tests/inline.hs create mode 100644 libraries/bytestring/tests/lazy-hclose.hs create mode 100644 libraries/bytestring/tests/lazybuild.hs create mode 100644 libraries/bytestring/tests/lazybuildcons.hs create mode 100644 libraries/bytestring/tests/lazyio.hs create mode 100644 libraries/bytestring/tests/lazylines.hs create mode 100644 libraries/bytestring/tests/lazyread.hs create mode 100644 libraries/bytestring/tests/letter_frequency.hs create mode 100644 libraries/bytestring/tests/linesort.hs create mode 100644 libraries/bytestring/tests/macros.m4 create mode 100644 libraries/bytestring/tests/pack.hs create mode 100644 libraries/bytestring/tests/revcomp.hs create mode 100644 libraries/bytestring/tests/spellcheck-input.txt create mode 100644 libraries/bytestring/tests/spellcheck.hs create mode 100644 libraries/bytestring/tests/sum.hs create mode 100644 libraries/bytestring/tests/test-compare.hs create mode 100644 libraries/bytestring/tests/unpack.hs create mode 100644 libraries/bytestring/tests/wc.hs create mode 100644 libraries/bytestring/tests/zipwith.hs create mode 100644 libraries/containers/.gitignore create mode 100644 libraries/containers/.travis.yml create mode 100644 libraries/containers/Data/Graph.hs create mode 100644 libraries/containers/Data/IntMap.hs create mode 100644 libraries/containers/Data/IntMap/Base.hs create mode 100644 libraries/containers/Data/IntMap/Lazy.hs create mode 100644 libraries/containers/Data/IntMap/Strict.hs create mode 100644 libraries/containers/Data/IntSet.hs create mode 100644 libraries/containers/Data/IntSet/Base.hs create mode 100644 libraries/containers/Data/Map.hs create mode 100644 libraries/containers/Data/Map/Base.hs create mode 100644 libraries/containers/Data/Map/Lazy.hs create mode 100644 libraries/containers/Data/Map/Strict.hs create mode 100644 libraries/containers/Data/Sequence.hs create mode 100644 libraries/containers/Data/Set.hs create mode 100644 libraries/containers/Data/Set/Base.hs create mode 100644 libraries/containers/Data/Tree.hs create mode 100644 libraries/containers/Data/Utils/BitUtil.hs create mode 100644 libraries/containers/Data/Utils/StrictFold.hs create mode 100644 libraries/containers/Data/Utils/StrictPair.hs create mode 100644 libraries/containers/GNUmakefile create mode 100644 libraries/containers/LICENSE create mode 100644 libraries/containers/README.md create mode 100644 libraries/containers/Setup.hs create mode 100644 libraries/containers/benchmarks/.gitignore create mode 100644 libraries/containers/benchmarks/IntMap.hs create mode 100644 libraries/containers/benchmarks/IntSet.hs create mode 100644 libraries/containers/benchmarks/LookupGE/IntMap.hs create mode 100644 libraries/containers/benchmarks/LookupGE/LookupGE_IntMap.hs create mode 100644 libraries/containers/benchmarks/LookupGE/LookupGE_Map.hs create mode 100644 libraries/containers/benchmarks/LookupGE/Makefile create mode 100644 libraries/containers/benchmarks/LookupGE/Map.hs create mode 100644 libraries/containers/benchmarks/Makefile create mode 100644 libraries/containers/benchmarks/Map.hs create mode 100644 libraries/containers/benchmarks/Sequence.hs create mode 100644 libraries/containers/benchmarks/Set.hs create mode 100644 libraries/containers/benchmarks/SetOperations/Makefile create mode 100644 libraries/containers/benchmarks/SetOperations/SetOperations-IntMap.hs create mode 100644 libraries/containers/benchmarks/SetOperations/SetOperations-IntSet.hs create mode 100644 libraries/containers/benchmarks/SetOperations/SetOperations-Map.hs create mode 100644 libraries/containers/benchmarks/SetOperations/SetOperations-Set.hs create mode 100644 libraries/containers/benchmarks/SetOperations/SetOperations.hs create mode 100755 libraries/containers/benchmarks/bench-cmp.pl create mode 100755 libraries/containers/benchmarks/bench-cmp.sh create mode 100644 libraries/containers/containers.cabal create mode 100644 libraries/containers/ghc.mk create mode 100644 libraries/containers/include/containers.h create mode 100644 libraries/containers/prologue.txt create mode 100644 libraries/containers/tests-ghc/Makefile create mode 100644 libraries/containers/tests-ghc/all.T create mode 100644 libraries/containers/tests-ghc/dataintset001.hs create mode 100644 libraries/containers/tests-ghc/dataintset001.stdout create mode 100644 libraries/containers/tests-ghc/datamap001.hs create mode 100644 libraries/containers/tests-ghc/datamap001.stdout create mode 100644 libraries/containers/tests-ghc/datamap002.hs create mode 100644 libraries/containers/tests-ghc/datamap002.stdout create mode 100644 libraries/containers/tests-ghc/sequence001.hs create mode 100644 libraries/containers/tests-ghc/sequence001.stdout create mode 100644 libraries/containers/tests-ghc/unreliable/README create mode 100644 libraries/containers/tests-ghc/unreliable/coerce_tests create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceintmap.hs create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceintmap.stdout create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceintmapstrict.hs create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceintmapstrict.hs.stdout create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoercemap.hs create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoercemap.stdout create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceseq.hs create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoerceseq.stdout create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoercesmap.hs create mode 100644 libraries/containers/tests-ghc/unreliable/mapcoercesmap.stdout create mode 100644 libraries/containers/tests/Makefile create mode 100644 libraries/containers/tests/deprecated-properties.hs create mode 100644 libraries/containers/tests/intmap-properties.hs create mode 100644 libraries/containers/tests/intmap-strictness.hs create mode 100644 libraries/containers/tests/intset-properties.hs create mode 100644 libraries/containers/tests/map-properties.hs create mode 100644 libraries/containers/tests/map-strictness.hs create mode 100644 libraries/containers/tests/seq-properties.hs create mode 100644 libraries/containers/tests/set-properties.hs create mode 100644 libraries/deepseq/.gitignore create mode 100644 libraries/deepseq/.travis.yml create mode 100644 libraries/deepseq/Control/DeepSeq.hs create mode 100644 libraries/deepseq/GNUmakefile create mode 100644 libraries/deepseq/LICENSE create mode 100644 libraries/deepseq/README.md create mode 100644 libraries/deepseq/Setup.hs create mode 100644 libraries/deepseq/changelog.md create mode 100644 libraries/deepseq/deepseq.cabal create mode 100644 libraries/deepseq/ghc.mk create mode 100644 libraries/deepseq/tests/Main.hs create mode 100644 libraries/defineTOP.mk create mode 100644 libraries/directory/.gitignore create mode 100644 libraries/directory/.travis.yml create mode 100644 libraries/directory/GNUmakefile create mode 100644 libraries/directory/LICENSE create mode 100644 libraries/directory/README.md create mode 100644 libraries/directory/Setup.hs create mode 100644 libraries/directory/System/Directory.hs create mode 100644 libraries/directory/cbits/directory.c create mode 100644 libraries/directory/changelog.md create mode 100644 libraries/directory/config.guess create mode 100755 libraries/directory/config.sub create mode 100755 libraries/directory/configure create mode 100644 libraries/directory/configure.ac create mode 100644 libraries/directory/directory.buildinfo create mode 100644 libraries/directory/directory.cabal create mode 100644 libraries/directory/ghc.mk create mode 100644 libraries/directory/include/HsDirectory.h create mode 100644 libraries/directory/include/HsDirectoryConfig.h.in create mode 100644 libraries/directory/install-sh create mode 100644 libraries/directory/prologue.txt create mode 100644 libraries/directory/tests/.gitignore create mode 100644 libraries/directory/tests/Makefile create mode 100644 libraries/directory/tests/T8482.hs create mode 100644 libraries/directory/tests/T8482.stdout create mode 100644 libraries/directory/tests/TestUtils.hs create mode 100644 libraries/directory/tests/all.T create mode 100644 libraries/directory/tests/canonicalizePath001.hs create mode 100644 libraries/directory/tests/canonicalizePath001.stdout create mode 100644 libraries/directory/tests/copyFile001.hs create mode 100644 libraries/directory/tests/copyFile001.stdout create mode 100644 libraries/directory/tests/copyFile001dir/source create mode 100644 libraries/directory/tests/copyFile002.hs create mode 100644 libraries/directory/tests/copyFile002.stdout create mode 100644 libraries/directory/tests/copyFile002dir/source create mode 100644 libraries/directory/tests/createDirectory001.hs create mode 100644 libraries/directory/tests/createDirectory001.stdout create mode 100644 libraries/directory/tests/createDirectory001.stdout-mingw32 create mode 100644 libraries/directory/tests/createDirectoryIfMissing001.hs create mode 100644 libraries/directory/tests/createDirectoryIfMissing001.stdout create mode 100644 libraries/directory/tests/createDirectoryIfMissing001.stdout-mingw32 create mode 100644 libraries/directory/tests/currentDirectory001.hs create mode 100644 libraries/directory/tests/currentDirectory001.stdout create mode 100644 libraries/directory/tests/directory001.hs create mode 100644 libraries/directory/tests/directory001.stdout create mode 100644 libraries/directory/tests/doesDirectoryExist001.hs create mode 100644 libraries/directory/tests/doesDirectoryExist001.stdout create mode 100644 libraries/directory/tests/getDirContents001.hs create mode 100644 libraries/directory/tests/getDirContents001.stdout create mode 100644 libraries/directory/tests/getDirContents002.hs create mode 100644 libraries/directory/tests/getDirContents002.stderr create mode 100644 libraries/directory/tests/getDirContents002.stderr-mingw32 create mode 100644 libraries/directory/tests/getHomeDirectory001.hs create mode 100644 libraries/directory/tests/getPermissions001.hs create mode 100644 libraries/directory/tests/getPermissions001.stdout create mode 100644 libraries/directory/tests/getPermissions001.stdout-alpha-dec-osf3 create mode 100644 libraries/directory/tests/getPermissions001.stdout-i386-unknown-freebsd create mode 100644 libraries/directory/tests/getPermissions001.stdout-i386-unknown-openbsd create mode 100644 libraries/directory/tests/getPermissions001.stdout-mingw create mode 100644 libraries/directory/tests/getPermissions001.stdout-x86_64-unknown-openbsd create mode 100644 libraries/directory/tests/removeDirectoryRecursive001.hs create mode 100644 libraries/directory/tests/removeDirectoryRecursive001.stdout create mode 100644 libraries/directory/tests/renameFile001.hs create mode 100644 libraries/directory/tests/renameFile001.stdout create mode 100644 libraries/directory/tools/dispatch-tests.hs create mode 100644 libraries/directory/tools/ghc.patch create mode 100755 libraries/directory/tools/run-tests create mode 100755 libraries/directory/tools/update-extra-source-files create mode 100644 libraries/doc/Makefile create mode 100644 libraries/doc/lib-hierarchy.html create mode 100644 libraries/filepath/.ghci create mode 100644 libraries/filepath/.gitignore create mode 100644 libraries/filepath/.travis.yml create mode 100644 libraries/filepath/GNUmakefile create mode 100755 libraries/filepath/Generate.hs create mode 100644 libraries/filepath/LICENSE create mode 100644 libraries/filepath/README.md create mode 100644 libraries/filepath/Setup.hs create mode 100644 libraries/filepath/System/FilePath.hs create mode 100644 libraries/filepath/System/FilePath/Internal.hs create mode 100644 libraries/filepath/System/FilePath/Posix.hs create mode 100644 libraries/filepath/System/FilePath/Windows.hs create mode 100644 libraries/filepath/changelog.md create mode 100644 libraries/filepath/filepath.cabal create mode 100644 libraries/filepath/ghc.mk create mode 100644 libraries/filepath/prologue.txt create mode 100755 libraries/filepath/tests/Test.hs create mode 100755 libraries/filepath/tests/TestGen.hs create mode 100644 libraries/filepath/tests/TestUtil.hs create mode 100755 libraries/filepath/travis.hs create mode 100644 libraries/gen_contents_index create mode 100644 libraries/ghc-prim/.gitignore create mode 100644 libraries/ghc-prim/GHC/CString.hs create mode 100644 libraries/ghc-prim/GHC/Classes.hs create mode 100644 libraries/ghc-prim/GHC/Debug.hs create mode 100644 libraries/ghc-prim/GHC/IntWord64.hs create mode 100644 libraries/ghc-prim/GHC/Magic.hs create mode 100644 libraries/ghc-prim/GHC/Tuple.hs create mode 100644 libraries/ghc-prim/GHC/Types.hs create mode 100644 libraries/ghc-prim/GNUmakefile create mode 100644 libraries/ghc-prim/LICENSE create mode 100644 libraries/ghc-prim/Setup.hs create mode 100644 libraries/ghc-prim/cbits/atomic.c create mode 100644 libraries/ghc-prim/cbits/bswap.c create mode 100644 libraries/ghc-prim/cbits/clz.c create mode 100644 libraries/ghc-prim/cbits/ctz.c create mode 100644 libraries/ghc-prim/cbits/debug.c create mode 100644 libraries/ghc-prim/cbits/longlong.c create mode 100644 libraries/ghc-prim/cbits/popcnt.c create mode 100644 libraries/ghc-prim/cbits/word2float.c create mode 100644 libraries/ghc-prim/ghc-prim.cabal create mode 100644 libraries/ghc-prim/ghc.mk create mode 100644 libraries/ghc-prim/tests/T6026.hs create mode 100644 libraries/ghc-prim/tests/T6026.stdout create mode 100644 libraries/haskeline/.gitignore create mode 100644 libraries/haskeline/.travis.yml create mode 100644 libraries/haskeline/Changelog create mode 100644 libraries/haskeline/GNUmakefile create mode 100644 libraries/haskeline/LICENSE create mode 100644 libraries/haskeline/README.md create mode 100644 libraries/haskeline/Setup.hs create mode 100644 libraries/haskeline/System/Console/Haskeline.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/DumbTerm.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/Posix/Encoder.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/Posix/IConv.hsc create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/Terminfo.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/WCWidth.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc create mode 100644 libraries/haskeline/System/Console/Haskeline/Command.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Command/Completion.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Command/History.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Command/KillRing.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Command/Undo.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Completion.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Directory.hsc create mode 100644 libraries/haskeline/System/Console/Haskeline/Emacs.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/History.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/IO.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/InputT.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Key.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/LineState.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/MonadException.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Monads.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Prefs.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Recover.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/RunCommand.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Term.hs create mode 100644 libraries/haskeline/System/Console/Haskeline/Vi.hs create mode 100644 libraries/haskeline/cbits/h_iconv.c create mode 100644 libraries/haskeline/cbits/h_wcwidth.c create mode 100644 libraries/haskeline/cbits/win_console.c create mode 100644 libraries/haskeline/examples/Test.hs create mode 100644 libraries/haskeline/examples/export/HaskelineExport.hs create mode 100644 libraries/haskeline/examples/export/Makefile create mode 100644 libraries/haskeline/examples/export/README.txt create mode 100644 libraries/haskeline/examples/export/main.c create mode 100644 libraries/haskeline/ghc.mk create mode 100644 libraries/haskeline/haskeline.cabal create mode 100644 libraries/haskeline/includes/h_iconv.h create mode 100644 libraries/haskeline/includes/win_console.h create mode 100644 libraries/haskeline/tests/Pty.hs create mode 100644 libraries/haskeline/tests/RunTTY.hs create mode 100644 libraries/haskeline/tests/Unit.hs create mode 100644 "libraries/haskeline/tests/dummy-\316\274\316\261\317\203/bar" create mode 100644 "libraries/haskeline/tests/dummy-\316\274\316\261\317\203/\317\202\316\265\317\201\317\204" create mode 100644 libraries/hoopl/.gitignore create mode 100644 libraries/hoopl/.travis.yml create mode 100644 libraries/hoopl/GNUmakefile create mode 100644 libraries/hoopl/HOWTO-BRANCHES create mode 100644 libraries/hoopl/LICENSE create mode 100644 libraries/hoopl/PROBLEMS create mode 100644 libraries/hoopl/README create mode 100644 libraries/hoopl/Setup.hs create mode 100644 libraries/hoopl/changelog.md create mode 100644 libraries/hoopl/ghc.mk create mode 100644 libraries/hoopl/hoopl.cabal create mode 100644 libraries/hoopl/hoopl.pdf create mode 100644 libraries/hoopl/paper/.gitignore create mode 100644 libraries/hoopl/paper/Makefile create mode 100644 libraries/hoopl/paper/NOTES create mode 100644 libraries/hoopl/paper/Rew.hs create mode 100644 libraries/hoopl/paper/TODO create mode 100644 libraries/hoopl/paper/bbl.dias.mk create mode 100644 libraries/hoopl/paper/bbl.nr.mk create mode 100644 libraries/hoopl/paper/bbl.simonpj.mk create mode 100644 libraries/hoopl/paper/bitly.dias.mk create mode 100644 libraries/hoopl/paper/bitly.nr.mk create mode 100644 libraries/hoopl/paper/bitly.simonpj.mk create mode 100644 libraries/hoopl/paper/code.sty create mode 100755 libraries/hoopl/paper/defuse create mode 100644 libraries/hoopl/paper/dfopt.bib create mode 100644 libraries/hoopl/paper/dfopt.tex create mode 100644 libraries/hoopl/paper/haskell-reviews.txt create mode 100644 libraries/hoopl/paper/hsprelude create mode 100644 libraries/hoopl/paper/icfp2010response.txt create mode 100644 libraries/hoopl/paper/icfp2010reviews.html create mode 100644 libraries/hoopl/paper/latex.mk create mode 100644 libraries/hoopl/paper/mkfile create mode 100644 libraries/hoopl/paper/notes-relatedwork create mode 100644 libraries/hoopl/paper/old-implementation-sections.tex create mode 100644 libraries/hoopl/paper/onepage.tex create mode 100644 libraries/hoopl/paper/proto-response.txt create mode 100644 libraries/hoopl/paper/refs.txt create mode 100644 libraries/hoopl/paper/spell.mk create mode 100755 libraries/hoopl/paper/xsource create mode 100644 libraries/hoopl/private/authors-response create mode 100644 libraries/hoopl/private/icfp09.reviews create mode 100644 libraries/hoopl/private/popl-response.txt create mode 100644 libraries/hoopl/private/popl10-reviews.txt create mode 100644 libraries/hoopl/private/popl2010-reviews.txt create mode 100644 libraries/hoopl/prototypes/.gitignore create mode 100644 libraries/hoopl/prototypes/Cunning3.hs create mode 100644 libraries/hoopl/prototypes/CunningTransfers.hs create mode 100644 libraries/hoopl/prototypes/Hoopl.hs create mode 100644 libraries/hoopl/prototypes/Hoopl1.hs create mode 100644 libraries/hoopl/prototypes/Hoopl4.hs create mode 100644 libraries/hoopl/prototypes/Hoopl5.hs create mode 100644 libraries/hoopl/prototypes/Hoopl6.hs create mode 100644 libraries/hoopl/prototypes/Hoopl7.hs create mode 100644 libraries/hoopl/prototypes/RG.hs create mode 100644 libraries/hoopl/prototypes/Zipper.hs create mode 100644 libraries/hoopl/src/.gitignore create mode 100644 libraries/hoopl/src/Compiler/Hoopl.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Block.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Checkpoint.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Collections.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Combinators.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Dataflow.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/DataflowFold.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Debug.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Fuel.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/GHC.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Graph.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/HISTORY create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Haddock.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Internals.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Label.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/NOTES create mode 100644 libraries/hoopl/src/Compiler/Hoopl/OldDataflow.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Passes/DList.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Passes/Live.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Passes/mkfile create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Pointed.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Shape.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Show.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Stream.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Unique.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/Wrappers.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/XUtil.hs create mode 100644 libraries/hoopl/src/Compiler/Hoopl/mkfile create mode 100644 libraries/hoopl/src/Compiler/mkfile create mode 100644 libraries/hoopl/src/LOOPS create mode 100644 libraries/hoopl/src/mkfile create mode 100644 libraries/hoopl/src/subdir.mk create mode 100644 libraries/hoopl/testing/.gitignore create mode 100644 libraries/hoopl/testing/Ast.hs create mode 100644 libraries/hoopl/testing/Ast2ir.hs create mode 100644 libraries/hoopl/testing/ConstProp.hs create mode 100644 libraries/hoopl/testing/Eval.hs create mode 100644 libraries/hoopl/testing/EvalMonad.hs create mode 100644 libraries/hoopl/testing/Expr.hs create mode 100644 libraries/hoopl/testing/IR.hs create mode 100644 libraries/hoopl/testing/Live.hs create mode 100644 libraries/hoopl/testing/Main.hs create mode 100644 libraries/hoopl/testing/OptSupport.hs create mode 100644 libraries/hoopl/testing/PP.hs create mode 100644 libraries/hoopl/testing/Parse.hs create mode 100644 libraries/hoopl/testing/README create mode 100644 libraries/hoopl/testing/Simplify.hs create mode 100644 libraries/hoopl/testing/Test.hs create mode 100644 libraries/hoopl/testing/constprop-figure create mode 100644 libraries/hoopl/testing/mkfile create mode 100644 libraries/hoopl/testing/tests/ExpectedOutput create mode 100644 libraries/hoopl/testing/tests/if-test create mode 100644 libraries/hoopl/testing/tests/if-test2 create mode 100644 libraries/hoopl/testing/tests/if-test3 create mode 100644 libraries/hoopl/testing/tests/if-test4 create mode 100644 libraries/hoopl/testing/tests/test1 create mode 100644 libraries/hoopl/testing/tests/test2 create mode 100644 libraries/hoopl/testing/tests/test3 create mode 100644 libraries/hoopl/testing/tests/test4 create mode 100755 libraries/hoopl/validate create mode 100644 libraries/hpc/.gitignore create mode 100644 libraries/hpc/.travis.yml create mode 100644 libraries/hpc/GNUmakefile create mode 100644 libraries/hpc/LICENSE create mode 100644 libraries/hpc/README.md create mode 100644 libraries/hpc/Setup.hs create mode 100644 libraries/hpc/Trace/Hpc/Mix.hs create mode 100644 libraries/hpc/Trace/Hpc/Reflect.hsc create mode 100644 libraries/hpc/Trace/Hpc/Tix.hs create mode 100644 libraries/hpc/Trace/Hpc/Util.hs create mode 100644 libraries/hpc/changelog.md create mode 100644 libraries/hpc/ghc.mk create mode 100644 libraries/hpc/hpc.cabal create mode 100644 libraries/hpc/prologue.txt create mode 100644 libraries/hpc/tests/.gitignore create mode 100644 libraries/hpc/tests/Makefile create mode 100644 libraries/hpc/tests/fork/Makefile create mode 100644 libraries/hpc/tests/fork/hpc_fork.hs create mode 100644 libraries/hpc/tests/fork/hpc_fork.stdout create mode 100644 libraries/hpc/tests/fork/test.T create mode 100644 libraries/hpc/tests/function/Makefile create mode 100644 libraries/hpc/tests/function/test.T create mode 100644 libraries/hpc/tests/function/tough.hs create mode 100644 libraries/hpc/tests/function/tough.stdout create mode 100644 libraries/hpc/tests/function2/Makefile create mode 100644 libraries/hpc/tests/function2/subdir/tough2.lhs create mode 100644 libraries/hpc/tests/function2/test.T create mode 100644 libraries/hpc/tests/function2/tough2.stdout create mode 100644 libraries/hpc/tests/ghc_ghci/A.hs create mode 100644 libraries/hpc/tests/ghc_ghci/B.hs create mode 100644 libraries/hpc/tests/ghc_ghci/Makefile create mode 100644 libraries/hpc/tests/ghc_ghci/hpc_ghc_ghci.stdout create mode 100644 libraries/hpc/tests/ghc_ghci/test.T create mode 100644 libraries/hpc/tests/hpc.ovr create mode 100644 libraries/hpc/tests/hpcrun.pl create mode 100644 libraries/hpc/tests/raytrace/CSG.hs create mode 100644 libraries/hpc/tests/raytrace/Construct.hs create mode 100644 libraries/hpc/tests/raytrace/Data.hs create mode 100644 libraries/hpc/tests/raytrace/Eval.hs create mode 100644 libraries/hpc/tests/raytrace/Geometry.hs create mode 100644 libraries/hpc/tests/raytrace/Illumination.hs create mode 100644 libraries/hpc/tests/raytrace/Intersections.hs create mode 100644 libraries/hpc/tests/raytrace/Interval.hs create mode 100644 libraries/hpc/tests/raytrace/Main.hs create mode 100644 libraries/hpc/tests/raytrace/Makefile create mode 100644 libraries/hpc/tests/raytrace/Misc.hs create mode 100644 libraries/hpc/tests/raytrace/Parse.hs create mode 100644 libraries/hpc/tests/raytrace/Pixmap.hs create mode 100644 libraries/hpc/tests/raytrace/Primitives.hs create mode 100644 libraries/hpc/tests/raytrace/RayTrace.hs create mode 100644 libraries/hpc/tests/raytrace/Surface.hs create mode 100644 libraries/hpc/tests/raytrace/galois.gml create mode 100644 libraries/hpc/tests/raytrace/galois.sample create mode 100644 libraries/hpc/tests/raytrace/test.T create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/CSG.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Construct.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Data.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Eval.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Geometry.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Illumination.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Intersections.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Interval.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Main.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Misc.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Parse.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Primitives.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/.hpc/Surface.mix create mode 100644 libraries/hpc/tests/raytrace/tixs/Makefile create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_markup_multi_001.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_markup_multi_002.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_markup_multi_003.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_raytrace.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_report_multi_001.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_report_multi_002.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_report_multi_003.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_sample.tix create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_show_multi_001.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/hpc_show_multi_002.stdout create mode 100644 libraries/hpc/tests/raytrace/tixs/test.T create mode 100644 libraries/hpc/tests/simple/Makefile create mode 100644 libraries/hpc/tests/simple/hpc001.hs create mode 100644 libraries/hpc/tests/simple/hpc001.stdout create mode 100644 libraries/hpc/tests/simple/test.T create mode 100644 libraries/hpc/tests/simple/tixs/.hpc.copy/Main.mix create mode 100644 libraries/hpc/tests/simple/tixs/.hpc/Main.mix create mode 100644 libraries/hpc/tests/simple/tixs/Makefile create mode 100644 libraries/hpc/tests/simple/tixs/hand_overlay.ovr create mode 100644 libraries/hpc/tests/simple/tixs/hpc001.hs create mode 100644 libraries/hpc/tests/simple/tixs/hpc_bad_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_draft.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_hand_overlay.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_draft.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_help.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_markup.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_overlay.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_report.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_show.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_help_version.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_markup_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_markup_002.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_markup_error_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_markup_error_002.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_overlay.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_overlay2.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_report_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_report_002.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_report_003.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_report_error_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_report_error_002.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_sample.tix create mode 100644 libraries/hpc/tests/simple/tixs/hpc_show.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_show_error_001.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_show_error_002.stdout create mode 100644 libraries/hpc/tests/simple/tixs/hpc_version.stdout create mode 100644 libraries/hpc/tests/simple/tixs/sample_overlay.ovr create mode 100644 libraries/hpc/tests/simple/tixs/test.T create mode 100644 libraries/hscolour.css create mode 100644 libraries/integer-gmp/.gitignore create mode 100644 libraries/integer-gmp/GHC/Integer.lhs create mode 100644 libraries/integer-gmp/GHC/Integer/GMP/Internals.hs create mode 100644 libraries/integer-gmp/GHC/Integer/GMP/Prim.hs create mode 100644 libraries/integer-gmp/GHC/Integer/Logarithms.hs create mode 100644 libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs create mode 100644 libraries/integer-gmp/GHC/Integer/Type.lhs create mode 100644 libraries/integer-gmp/GNUmakefile create mode 100644 libraries/integer-gmp/LICENSE create mode 100644 libraries/integer-gmp/Setup.hs create mode 100644 libraries/integer-gmp/aclocal.m4 create mode 100644 libraries/integer-gmp/cbits/alloc.c create mode 100644 libraries/integer-gmp/cbits/cbits.c create mode 100644 libraries/integer-gmp/cbits/float.c create mode 100644 libraries/integer-gmp/cbits/gmp-wrappers.cmm create mode 100644 libraries/integer-gmp/cbits/longlong.c create mode 100644 libraries/integer-gmp/changelog.md create mode 100755 libraries/integer-gmp/config.guess create mode 100755 libraries/integer-gmp/config.sub create mode 100755 libraries/integer-gmp/configure create mode 100644 libraries/integer-gmp/configure.ac create mode 100644 libraries/integer-gmp/ghc.mk create mode 100644 libraries/integer-gmp/gmp/config.mk.in create mode 100644 libraries/integer-gmp/gmp/ghc.mk create mode 100755 libraries/integer-gmp/gmp/ln create mode 100644 libraries/integer-gmp/gmp/tarball/README create mode 100644 libraries/integer-gmp/gmp/tarball/gmp-5.0.3-nodoc-patched.tar.bz2 create mode 100644 libraries/integer-gmp/gmp/tarball/gmp-5.0.4.patch create mode 100644 libraries/integer-gmp/gmp/tarball/patch create mode 100644 libraries/integer-gmp/include/HsIntegerGmp.h.in create mode 100755 libraries/integer-gmp/install-sh create mode 100644 libraries/integer-gmp/integer-gmp.buildinfo.in create mode 100644 libraries/integer-gmp/integer-gmp.cabal create mode 100644 libraries/integer-gmp/mkGmpDerivedConstants/Makefile create mode 100644 libraries/integer-gmp/mkGmpDerivedConstants/ghc.mk create mode 100644 libraries/integer-gmp/mkGmpDerivedConstants/mkGmpDerivedConstants.c create mode 100644 libraries/integer-gmp2/.gitignore create mode 100644 libraries/integer-gmp2/GNUmakefile create mode 100644 libraries/integer-gmp2/LICENSE create mode 100644 libraries/integer-gmp2/Setup.hs create mode 100644 libraries/integer-gmp2/aclocal.m4 create mode 100644 libraries/integer-gmp2/cbits/wrappers.c create mode 100644 libraries/integer-gmp2/changelog.md create mode 100755 libraries/integer-gmp2/config.guess create mode 100755 libraries/integer-gmp2/config.sub create mode 100755 libraries/integer-gmp2/configure create mode 100644 libraries/integer-gmp2/configure.ac create mode 100644 libraries/integer-gmp2/ghc.mk create mode 100644 libraries/integer-gmp2/gmp/config.mk.in create mode 100644 libraries/integer-gmp2/gmp/ghc-gmp.h create mode 100644 libraries/integer-gmp2/gmp/ghc.mk create mode 100644 libraries/integer-gmp2/gmp/gmpsrc.patch create mode 100755 libraries/integer-gmp2/gmp/ln create mode 100644 libraries/integer-gmp2/include/HsIntegerGmp.h.in create mode 100755 libraries/integer-gmp2/install-sh create mode 100644 libraries/integer-gmp2/integer-gmp.buildinfo.in create mode 100644 libraries/integer-gmp2/integer-gmp.cabal create mode 100644 libraries/integer-gmp2/src/GHC/Integer.hs create mode 100644 libraries/integer-gmp2/src/GHC/Integer/GMP/Internals.hs create mode 100644 libraries/integer-gmp2/src/GHC/Integer/Logarithms.hs create mode 100644 libraries/integer-gmp2/src/GHC/Integer/Logarithms/Internals.hs create mode 100644 libraries/integer-gmp2/src/GHC/Integer/Type.hs create mode 100644 libraries/integer-simple/.gitignore create mode 100644 libraries/integer-simple/GHC/Integer.hs create mode 100644 libraries/integer-simple/GHC/Integer/Logarithms.hs create mode 100644 libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs create mode 100644 libraries/integer-simple/GHC/Integer/Simple/Internals.hs create mode 100644 libraries/integer-simple/GHC/Integer/Type.hs create mode 100644 libraries/integer-simple/GNUmakefile create mode 100644 libraries/integer-simple/LICENSE create mode 100644 libraries/integer-simple/Setup.hs create mode 100644 libraries/integer-simple/ghc.mk create mode 100644 libraries/integer-simple/integer-simple.cabal create mode 100644 libraries/libraries-footer.txt create mode 100644 libraries/libraries-header.txt create mode 100644 libraries/pretty/.gitignore create mode 100644 libraries/pretty/.travis.yml create mode 100644 libraries/pretty/CHANGELOG.md create mode 100644 libraries/pretty/GNUmakefile create mode 100644 libraries/pretty/LICENSE create mode 100644 libraries/pretty/README.md create mode 100644 libraries/pretty/Setup.hs create mode 100644 libraries/pretty/TODO create mode 100644 libraries/pretty/ghc.mk create mode 100644 libraries/pretty/pretty.cabal create mode 100644 libraries/pretty/src/Text/PrettyPrint.hs create mode 100644 libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs create mode 100644 libraries/pretty/src/Text/PrettyPrint/HughesPJClass.hs create mode 100644 libraries/pretty/tests/Bench1.hs create mode 100644 libraries/pretty/tests/BugSep.hs create mode 100644 libraries/pretty/tests/PrettyTestVersion.hs create mode 100644 libraries/pretty/tests/Test.hs create mode 100644 libraries/pretty/tests/TestGenerators.hs create mode 100644 libraries/pretty/tests/TestStructures.hs create mode 100644 libraries/pretty/tests/TestUtils.hs create mode 100644 libraries/pretty/tests/UnitPP1.hs create mode 100644 libraries/pretty/tests/UnitT3911.hs create mode 100644 libraries/process/.gitignore create mode 100644 libraries/process/.travis.yml create mode 100644 libraries/process/GNUmakefile create mode 100644 libraries/process/LICENSE create mode 100644 libraries/process/README.md create mode 100644 libraries/process/Setup.hs create mode 100644 libraries/process/System/Cmd.hs create mode 100644 libraries/process/System/Process.hsc create mode 100644 libraries/process/System/Process/Internals.hs create mode 100644 libraries/process/aclocal.m4 create mode 100644 libraries/process/cbits/runProcess.c create mode 100644 libraries/process/changelog.md create mode 100755 libraries/process/configure create mode 100644 libraries/process/configure.ac create mode 100644 libraries/process/ghc.mk create mode 100644 libraries/process/include/HsProcessConfig.h.in create mode 100644 libraries/process/include/processFlags.h create mode 100644 libraries/process/include/runProcess.h create mode 100644 libraries/process/process.buildinfo create mode 100644 libraries/process/process.cabal create mode 100644 libraries/process/prologue.txt create mode 100644 libraries/process/test/main.hs create mode 100644 libraries/process/tests/.gitignore create mode 100644 libraries/process/tests/Makefile create mode 100644 libraries/process/tests/T1780.hs create mode 100644 libraries/process/tests/T1780.stdout create mode 100644 libraries/process/tests/T3231.hs create mode 100644 libraries/process/tests/T3231.stdout create mode 100644 libraries/process/tests/T3994.hs create mode 100644 libraries/process/tests/T3994.stdout create mode 100644 libraries/process/tests/T4198.hs create mode 100644 libraries/process/tests/T4198.stdout create mode 100644 libraries/process/tests/T4198.stdout-mingw32 create mode 100644 libraries/process/tests/T4889.hs create mode 100644 libraries/process/tests/T4889.stdout create mode 100644 libraries/process/tests/T8343.hs create mode 100644 libraries/process/tests/T8343.stdout create mode 100644 libraries/process/tests/all.T create mode 100644 libraries/process/tests/exitminus1.c create mode 100644 libraries/process/tests/process001.hs create mode 100644 libraries/process/tests/process002.hs create mode 100644 libraries/process/tests/process003.hs create mode 100644 libraries/process/tests/process003.stdout create mode 100644 libraries/process/tests/process004.hs create mode 100644 libraries/process/tests/process004.stdout create mode 100644 libraries/process/tests/process004.stdout-mingw32 create mode 100644 libraries/process/tests/process005.hs create mode 100644 libraries/process/tests/process005.stdin create mode 100644 libraries/process/tests/process005.stdout create mode 100644 libraries/process/tests/process006.hs create mode 100644 libraries/process/tests/process006.stderr create mode 100644 libraries/process/tests/process006.stdout create mode 100644 libraries/process/tests/process007.hs create mode 100644 libraries/process/tests/process007.stdout create mode 100644 libraries/process/tests/process007_fd.c create mode 100644 libraries/process/tests/process008.hs create mode 100644 libraries/process/tests/process008.stdout create mode 100644 libraries/process/tests/process009.hs create mode 100644 libraries/process/tests/process009.stdout create mode 100644 libraries/process/tests/process010.hs create mode 100644 libraries/process/tests/process010.stdout create mode 100644 libraries/process/tests/process010.stdout-i386-unknown-solaris2 create mode 100644 libraries/process/tests/process010.stdout-mingw32 create mode 100644 libraries/process/tests/process011.hs create mode 100644 libraries/process/tests/process011.stdout create mode 100644 libraries/prologue.txt.in create mode 100644 libraries/template-haskell/.gitignore create mode 100644 libraries/template-haskell/GNUmakefile create mode 100644 libraries/template-haskell/LICENSE create mode 100644 libraries/template-haskell/Language/Haskell/TH.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/Lib.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/Ppr.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/PprLib.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/Quote.hs create mode 100644 libraries/template-haskell/Language/Haskell/TH/Syntax.hs create mode 100644 libraries/template-haskell/Setup.hs create mode 100644 libraries/template-haskell/changelog.md create mode 100644 libraries/template-haskell/ghc.mk create mode 100644 libraries/template-haskell/prologue.txt create mode 100644 libraries/template-haskell/template-haskell.cabal create mode 100644 libraries/template-haskell/tests/.gitignore create mode 100644 libraries/template-haskell/tests/Makefile create mode 100644 libraries/template-haskell/tests/all.T create mode 100644 libraries/template-haskell/tests/dataToExpQUnit.hs create mode 100644 libraries/template-haskell/tests/dataToExpQUnit.stderr create mode 100644 libraries/terminfo/.gitignore create mode 100644 libraries/terminfo/.travis.yml create mode 100644 libraries/terminfo/GNUmakefile create mode 100644 libraries/terminfo/LICENSE create mode 100644 libraries/terminfo/README.md create mode 100644 libraries/terminfo/Setup.lhs create mode 100644 libraries/terminfo/System/Console/Terminfo.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Base.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Color.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Cursor.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Edit.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Effects.hs create mode 100644 libraries/terminfo/System/Console/Terminfo/Keys.hs create mode 100755 libraries/terminfo/configure create mode 100644 libraries/terminfo/configure.ac create mode 100644 libraries/terminfo/ghc.mk create mode 100644 libraries/terminfo/terminfo.buildinfo.in create mode 100644 libraries/terminfo/terminfo.cabal create mode 100644 libraries/time/.gitignore create mode 100644 libraries/time/GNUmakefile create mode 100644 libraries/time/LICENSE create mode 100644 libraries/time/Makefile create mode 100644 libraries/time/README create mode 100644 libraries/time/Setup.hs create mode 100644 libraries/time/aclocal.m4 create mode 100755 libraries/time/configure create mode 100644 libraries/time/configure.ac create mode 100644 libraries/time/ghc.mk create mode 100644 libraries/time/lib/Data/Time.hs create mode 100644 libraries/time/lib/Data/Time/Calendar.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/Days.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/Easter.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/Gregorian.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/Julian.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/JulianYearDay.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/MonthDay.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/OrdinalDate.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/Private.hs create mode 100644 libraries/time/lib/Data/Time/Calendar/WeekDate.hs create mode 100644 libraries/time/lib/Data/Time/Clock.hs create mode 100644 libraries/time/lib/Data/Time/Clock/CTimeval.hs create mode 100644 libraries/time/lib/Data/Time/Clock/POSIX.hs create mode 100644 libraries/time/lib/Data/Time/Clock/Scale.hs create mode 100644 libraries/time/lib/Data/Time/Clock/TAI.hs create mode 100644 libraries/time/lib/Data/Time/Clock/UTC.hs create mode 100644 libraries/time/lib/Data/Time/Clock/UTCDiff.hs create mode 100644 libraries/time/lib/Data/Time/Format.hs create mode 100644 libraries/time/lib/Data/Time/Format/Locale.hs create mode 100644 libraries/time/lib/Data/Time/Format/Parse.hs create mode 100644 libraries/time/lib/Data/Time/LocalTime.hs create mode 100644 libraries/time/lib/Data/Time/LocalTime/LocalTime.hs create mode 100644 libraries/time/lib/Data/Time/LocalTime/TimeOfDay.hs create mode 100644 libraries/time/lib/Data/Time/LocalTime/TimeZone.hs create mode 100644 libraries/time/lib/cbits/HsTime.c create mode 100644 libraries/time/lib/include/HsConfigure.h create mode 100644 libraries/time/lib/include/HsTime.h create mode 100644 libraries/time/lib/include/HsTimeConfig.h create mode 100644 libraries/time/lib/include/HsTimeConfig.h.in create mode 100644 libraries/time/test/ShowDefaultTZAbbreviations.hs create mode 100644 libraries/time/test/Test.hs create mode 100644 libraries/time/test/Test/AddDays.hs create mode 100644 libraries/time/test/Test/AddDaysRef.hs create mode 100644 libraries/time/test/Test/ClipDates.hs create mode 100644 libraries/time/test/Test/ClipDatesRef.hs create mode 100644 libraries/time/test/Test/ConvertBack.hs create mode 100644 libraries/time/test/Test/CurrentTime.hs create mode 100644 libraries/time/test/Test/LongWeekYears.hs create mode 100644 libraries/time/test/Test/LongWeekYearsRef.hs create mode 100644 libraries/time/test/Test/RealToFracBenchmark.hs create mode 100644 libraries/time/test/Test/ShowDST.hs create mode 100644 libraries/time/test/Test/TAI_UTC_DAT.hs create mode 100644 libraries/time/test/Test/TestCalendars.hs create mode 100644 libraries/time/test/Test/TestCalendarsRef.hs create mode 100644 libraries/time/test/Test/TestEaster.hs create mode 100644 libraries/time/test/Test/TestEasterRef.hs create mode 100644 libraries/time/test/Test/TestFormat.hs create mode 100644 libraries/time/test/Test/TestFormatStuff.c create mode 100644 libraries/time/test/Test/TestFormatStuff.h create mode 100644 libraries/time/test/Test/TestMonthDay.hs create mode 100644 libraries/time/test/Test/TestMonthDayRef.hs create mode 100644 libraries/time/test/Test/TestParseDAT.hs create mode 100644 libraries/time/test/Test/TestParseDAT_Ref.hs create mode 100644 libraries/time/test/Test/TestParseTime.hs create mode 100644 libraries/time/test/Test/TestTime.hs create mode 100644 libraries/time/test/Test/TestTimeRef.hs create mode 100644 libraries/time/test/Test/TestTimeZone.hs create mode 100644 libraries/time/test/Test/TestUtil.hs create mode 100644 libraries/time/test/Test/Tests.hs create mode 100644 libraries/time/test/Test/TimeZone.hs create mode 100644 libraries/time/test/Test/UseCases.lhs create mode 100644 libraries/time/time.cabal create mode 100644 libraries/transformers/Control/Applicative/Backwards.hs create mode 100644 libraries/transformers/Control/Applicative/Lift.hs create mode 100644 libraries/transformers/Control/Monad/IO/Class.hs create mode 100644 libraries/transformers/Control/Monad/Signatures.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Class.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Cont.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Error.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Except.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Identity.hs create mode 100644 libraries/transformers/Control/Monad/Trans/List.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Maybe.hs create mode 100644 libraries/transformers/Control/Monad/Trans/RWS.hs create mode 100644 libraries/transformers/Control/Monad/Trans/RWS/Lazy.hs create mode 100644 libraries/transformers/Control/Monad/Trans/RWS/Strict.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Reader.hs create mode 100644 libraries/transformers/Control/Monad/Trans/State.hs create mode 100644 libraries/transformers/Control/Monad/Trans/State/Lazy.hs create mode 100644 libraries/transformers/Control/Monad/Trans/State/Strict.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Writer.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Writer/Lazy.hs create mode 100644 libraries/transformers/Control/Monad/Trans/Writer/Strict.hs create mode 100644 libraries/transformers/Data/Functor/Classes.hs create mode 100644 libraries/transformers/Data/Functor/Compose.hs create mode 100644 libraries/transformers/Data/Functor/Constant.hs create mode 100644 libraries/transformers/Data/Functor/Product.hs create mode 100644 libraries/transformers/Data/Functor/Reverse.hs create mode 100644 libraries/transformers/Data/Functor/Sum.hs create mode 100644 libraries/transformers/GNUmakefile create mode 100644 libraries/transformers/LICENSE create mode 100644 libraries/transformers/Setup.hs create mode 100644 libraries/transformers/changelog create mode 100644 libraries/transformers/ghc.mk create mode 100644 libraries/transformers/oldsrc/Data/Functor/Identity.hs create mode 100644 libraries/transformers/transformers.cabal create mode 100644 libraries/unix/.gitignore create mode 100644 libraries/unix/.travis.yml create mode 100644 libraries/unix/GNUmakefile create mode 100644 libraries/unix/LICENSE create mode 100644 libraries/unix/README.md create mode 100644 libraries/unix/Setup.hs create mode 100644 libraries/unix/System/Posix.hs create mode 100644 libraries/unix/System/Posix/ByteString.hs create mode 100644 libraries/unix/System/Posix/ByteString/FilePath.hsc create mode 100644 libraries/unix/System/Posix/Directory.hsc create mode 100644 libraries/unix/System/Posix/Directory/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Directory/Common.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker/ByteString.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker/Common.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker/Module.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker/Module/ByteString.hsc create mode 100644 libraries/unix/System/Posix/DynamicLinker/Prim.hsc create mode 100644 libraries/unix/System/Posix/Env.hsc create mode 100644 libraries/unix/System/Posix/Env/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Error.hs create mode 100644 libraries/unix/System/Posix/Fcntl.hsc create mode 100644 libraries/unix/System/Posix/Files.hsc create mode 100644 libraries/unix/System/Posix/Files/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Files/Common.hsc create mode 100644 libraries/unix/System/Posix/IO.hsc create mode 100644 libraries/unix/System/Posix/IO/ByteString.hsc create mode 100644 libraries/unix/System/Posix/IO/Common.hsc create mode 100644 libraries/unix/System/Posix/Process.hsc create mode 100644 libraries/unix/System/Posix/Process/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Process/Common.hsc create mode 100644 libraries/unix/System/Posix/Process/Internals.hs create mode 100644 libraries/unix/System/Posix/Resource.hsc create mode 100644 libraries/unix/System/Posix/Semaphore.hsc create mode 100644 libraries/unix/System/Posix/SharedMem.hsc create mode 100644 libraries/unix/System/Posix/Signals.hsc create mode 100644 libraries/unix/System/Posix/Signals/Exts.hsc create mode 100644 libraries/unix/System/Posix/Temp.hsc create mode 100644 libraries/unix/System/Posix/Temp/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Terminal.hsc create mode 100644 libraries/unix/System/Posix/Terminal/ByteString.hsc create mode 100644 libraries/unix/System/Posix/Terminal/Common.hsc create mode 100644 libraries/unix/System/Posix/Time.hsc create mode 100644 libraries/unix/System/Posix/Unistd.hsc create mode 100644 libraries/unix/System/Posix/User.hsc create mode 100644 libraries/unix/aclocal.m4 create mode 100644 libraries/unix/cbits/HsUnix.c create mode 100644 libraries/unix/cbits/dirUtils.c create mode 100644 libraries/unix/cbits/execvpe.c create mode 100644 libraries/unix/cbits/ghcrts.c create mode 100644 libraries/unix/changelog.md create mode 100755 libraries/unix/config.guess create mode 100755 libraries/unix/config.sub create mode 100755 libraries/unix/configure create mode 100644 libraries/unix/configure.ac create mode 100644 libraries/unix/ghc.mk create mode 100644 libraries/unix/include/HsUnix.h create mode 100644 libraries/unix/include/HsUnixConfig.h.in create mode 100644 libraries/unix/include/execvpe.h create mode 100755 libraries/unix/install-sh create mode 100644 libraries/unix/prologue.txt create mode 100644 libraries/unix/tests/.gitignore create mode 100644 libraries/unix/tests/Makefile create mode 100644 libraries/unix/tests/T1185.hs create mode 100644 libraries/unix/tests/T1185.stdout create mode 100644 libraries/unix/tests/T3816.hs create mode 100644 libraries/unix/tests/T3816.stdout create mode 100644 libraries/unix/tests/T8108.hs create mode 100644 libraries/unix/tests/all.T create mode 100644 libraries/unix/tests/executeFile001.hs create mode 100644 libraries/unix/tests/executeFile001.stdout create mode 100644 libraries/unix/tests/fdReadBuf001.hs create mode 100644 libraries/unix/tests/fileStatus.hs create mode 100644 libraries/unix/tests/fileStatusByteString.hs create mode 100644 libraries/unix/tests/fileexist01.hs create mode 100644 libraries/unix/tests/fileexist01.stdout create mode 100644 libraries/unix/tests/forkprocess01.hs create mode 100644 libraries/unix/tests/forkprocess01.stdout create mode 100644 libraries/unix/tests/getEnvironment01.hs create mode 100644 libraries/unix/tests/getEnvironment01.stdout create mode 100644 libraries/unix/tests/getEnvironment02.hs create mode 100644 libraries/unix/tests/getEnvironment02.stdout create mode 100644 libraries/unix/tests/getGroupEntryForName.hs create mode 100644 libraries/unix/tests/getGroupEntryForName.stderr create mode 100644 libraries/unix/tests/getUserEntryForName.hs create mode 100644 libraries/unix/tests/getUserEntryForName.stderr create mode 100644 libraries/unix/tests/libposix/Makefile create mode 100644 libraries/unix/tests/libposix/all.T create mode 100644 libraries/unix/tests/libposix/posix002.hs create mode 100644 libraries/unix/tests/libposix/posix002.stdout create mode 100644 libraries/unix/tests/libposix/posix003.hs create mode 100644 libraries/unix/tests/libposix/posix003.stdout create mode 100644 libraries/unix/tests/libposix/posix004.hs create mode 100644 libraries/unix/tests/libposix/posix004.stdout create mode 100644 libraries/unix/tests/libposix/posix005.hs create mode 100644 libraries/unix/tests/libposix/posix005.stdout create mode 100644 libraries/unix/tests/libposix/posix006.hs create mode 100644 libraries/unix/tests/libposix/posix006.stdout create mode 100644 libraries/unix/tests/libposix/posix009.hs create mode 100644 libraries/unix/tests/libposix/posix009.stdout create mode 100644 libraries/unix/tests/libposix/posix010.hs create mode 100644 libraries/unix/tests/libposix/posix010.stdout create mode 100644 libraries/unix/tests/libposix/posix014.hs create mode 100644 libraries/unix/tests/libposix/posix014.stdout create mode 100644 libraries/unix/tests/processGroup001.hs create mode 100644 libraries/unix/tests/processGroup001.stdout create mode 100644 libraries/unix/tests/processGroup002.hs create mode 100644 libraries/unix/tests/processGroup002.stdout create mode 100644 libraries/unix/tests/queryfdoption01.hs create mode 100644 libraries/unix/tests/queryfdoption01.stdin create mode 100644 libraries/unix/tests/queryfdoption01.stdout create mode 100644 libraries/unix/tests/resourceLimit.hs create mode 100644 libraries/unix/tests/resourceLimit.stdout create mode 100644 libraries/unix/tests/signals001.hs create mode 100644 libraries/unix/tests/signals001.stdout create mode 100644 libraries/unix/tests/signals001.stdout-i386-unknown-freebsd create mode 100644 libraries/unix/tests/signals001.stdout-i386-unknown-openbsd create mode 100644 libraries/unix/tests/signals001.stdout-sparc-unknown-openbsd create mode 100644 libraries/unix/tests/signals001.stdout-x86_64-unknown-openbsd create mode 100644 libraries/unix/tests/signals002.hs create mode 100644 libraries/unix/tests/signals002.stdout create mode 100644 libraries/unix/tests/signals004.hs create mode 100644 libraries/unix/tests/user001.hs create mode 100644 libraries/unix/tests/user001.stdout create mode 100644 libraries/unix/unix.buildinfo.in create mode 100644 libraries/unix/unix.cabal create mode 100644 libraries/xhtml/.gitignore create mode 100644 libraries/xhtml/GNUmakefile create mode 100644 libraries/xhtml/LICENSE create mode 100644 libraries/xhtml/README create mode 100644 libraries/xhtml/Setup.hs create mode 100644 libraries/xhtml/Text/XHtml.hs create mode 100644 libraries/xhtml/Text/XHtml/BlockTable.hs create mode 100644 libraries/xhtml/Text/XHtml/Debug.hs create mode 100644 libraries/xhtml/Text/XHtml/Extras.hs create mode 100644 libraries/xhtml/Text/XHtml/Frameset.hs create mode 100644 libraries/xhtml/Text/XHtml/Frameset/Attributes.hs create mode 100644 libraries/xhtml/Text/XHtml/Frameset/Elements.hs create mode 100644 libraries/xhtml/Text/XHtml/Internals.hs create mode 100644 libraries/xhtml/Text/XHtml/Strict.hs create mode 100644 libraries/xhtml/Text/XHtml/Strict/Attributes.hs create mode 100644 libraries/xhtml/Text/XHtml/Strict/Elements.hs create mode 100644 libraries/xhtml/Text/XHtml/Table.hs create mode 100644 libraries/xhtml/Text/XHtml/Transitional.hs create mode 100644 libraries/xhtml/Text/XHtml/Transitional/Attributes.hs create mode 100644 libraries/xhtml/Text/XHtml/Transitional/Elements.hs create mode 100644 libraries/xhtml/ghc.mk create mode 100644 libraries/xhtml/xhtml.cabal create mode 100644 mk/build.mk.sample create mode 100644 mk/compiler-ghc.mk create mode 100644 mk/config.h.in create mode 100644 mk/config.mk.in create mode 100644 mk/custom-settings.mk create mode 100644 mk/fptools.css create mode 100755 mk/get-win32-tarballs.sh create mode 100644 mk/install.mk.in create mode 100644 mk/project.mk.in create mode 100644 mk/sub-makefile.mk create mode 100644 mk/tree.mk create mode 100644 mk/validate-settings.mk create mode 100644 mk/ways.mk create mode 100644 packages create mode 100644 rts/.dir-locals.el create mode 100644 rts/Adjustor.c create mode 100644 rts/AdjustorAsm.S create mode 100644 rts/Apply.cmm create mode 100644 rts/Apply.h create mode 100644 rts/Arena.c create mode 100644 rts/Arena.h create mode 100644 rts/AutoApply.h create mode 100644 rts/AwaitEvent.h create mode 100644 rts/BeginPrivate.h create mode 100644 rts/Capability.c create mode 100644 rts/Capability.h create mode 100644 rts/CheckUnload.c create mode 100644 rts/CheckUnload.h create mode 100644 rts/ClosureFlags.c create mode 100644 rts/Disassembler.c create mode 100644 rts/Disassembler.h create mode 100644 rts/EndPrivate.h create mode 100644 rts/Exception.cmm create mode 100644 rts/FileLock.c create mode 100644 rts/FileLock.h create mode 100644 rts/GetEnv.h create mode 100644 rts/GetTime.h create mode 100644 rts/Globals.c create mode 100644 rts/Globals.h create mode 100644 rts/Hash.c create mode 100644 rts/Hash.h create mode 100644 rts/HeapStackCheck.cmm create mode 100644 rts/Hpc.c create mode 100644 rts/HsFFI.c create mode 100644 rts/Inlines.c create mode 100644 rts/Interpreter.c create mode 100644 rts/Interpreter.h create mode 100644 rts/LdvProfile.c create mode 100644 rts/LdvProfile.h create mode 100644 rts/Linker.c create mode 100644 rts/LinkerInternals.h create mode 100644 rts/Makefile create mode 100644 rts/Messages.c create mode 100644 rts/Messages.h create mode 100644 rts/OldARMAtomic.c create mode 100644 rts/Papi.c create mode 100644 rts/Papi.h create mode 100644 rts/PosixSource.h create mode 100644 rts/Prelude.h create mode 100644 rts/PrimOps.cmm create mode 100644 rts/Printer.c create mode 100644 rts/Printer.h create mode 100644 rts/ProfHeap.c create mode 100644 rts/ProfHeap.h create mode 100644 rts/Profiling.c create mode 100644 rts/Profiling.h create mode 100644 rts/Proftimer.c create mode 100644 rts/Proftimer.h create mode 100644 rts/RaiseAsync.c create mode 100644 rts/RaiseAsync.h create mode 100644 rts/RetainerProfile.c create mode 100644 rts/RetainerProfile.h create mode 100644 rts/RetainerSet.c create mode 100644 rts/RetainerSet.h create mode 100644 rts/RtsAPI.c create mode 100644 rts/RtsDllMain.c create mode 100644 rts/RtsDllMain.h create mode 100644 rts/RtsFlags.c create mode 100644 rts/RtsFlags.h create mode 100644 rts/RtsMain.c create mode 100644 rts/RtsMessages.c create mode 100644 rts/RtsProbes.d create mode 100644 rts/RtsSignals.h create mode 100644 rts/RtsStartup.c create mode 100644 rts/RtsUtils.c create mode 100644 rts/RtsUtils.h create mode 100644 rts/STM.c create mode 100644 rts/STM.h create mode 100644 rts/Schedule.c create mode 100644 rts/Schedule.h create mode 100644 rts/Sparks.c create mode 100644 rts/Sparks.h create mode 100644 rts/Stable.c create mode 100644 rts/Stable.h create mode 100644 rts/StaticPtrTable.c create mode 100644 rts/StaticPtrTable.h create mode 100644 rts/Stats.c create mode 100644 rts/Stats.h create mode 100644 rts/StgCRun.c create mode 100644 rts/StgMiscClosures.cmm create mode 100644 rts/StgPrimFloat.c create mode 100644 rts/StgPrimFloat.h create mode 100644 rts/StgRun.h create mode 100644 rts/StgStartup.cmm create mode 100644 rts/StgStdThunks.cmm create mode 100644 rts/Task.c create mode 100644 rts/Task.h create mode 100644 rts/ThreadLabels.c create mode 100644 rts/ThreadLabels.h create mode 100644 rts/ThreadPaused.c create mode 100644 rts/ThreadPaused.h create mode 100644 rts/Threads.c create mode 100644 rts/Threads.h create mode 100644 rts/Ticker.h create mode 100644 rts/Ticky.c create mode 100644 rts/Ticky.h create mode 100644 rts/Timer.c create mode 100644 rts/Timer.h create mode 100644 rts/Trace.c create mode 100644 rts/Trace.h create mode 100644 rts/Updates.cmm create mode 100644 rts/Updates.h create mode 100644 rts/WSDeque.c create mode 100644 rts/WSDeque.h create mode 100644 rts/Weak.c create mode 100644 rts/Weak.h create mode 100644 rts/eventlog/EventLog.c create mode 100644 rts/eventlog/EventLog.h create mode 100644 rts/ghc.mk create mode 100644 rts/hooks/FlagDefaults.c create mode 100644 rts/hooks/MallocFail.c create mode 100644 rts/hooks/OnExit.c create mode 100644 rts/hooks/OutOfHeap.c create mode 100644 rts/hooks/StackOverflow.c create mode 100644 rts/package.conf.in create mode 100644 rts/posix/Clock.h create mode 100644 rts/posix/GetEnv.c create mode 100644 rts/posix/GetTime.c create mode 100644 rts/posix/Itimer.c create mode 100644 rts/posix/Itimer.h create mode 100644 rts/posix/OSMem.c create mode 100644 rts/posix/OSThreads.c create mode 100644 rts/posix/Select.c create mode 100644 rts/posix/Select.h create mode 100644 rts/posix/Signals.c create mode 100644 rts/posix/Signals.h create mode 100644 rts/posix/TTY.c create mode 100644 rts/posix/TTY.h create mode 100644 rts/sm/BlockAlloc.c create mode 100644 rts/sm/BlockAlloc.h create mode 100644 rts/sm/Compact.c create mode 100644 rts/sm/Compact.h create mode 100644 rts/sm/Evac.c create mode 100644 rts/sm/Evac.h create mode 100644 rts/sm/GC.c create mode 100644 rts/sm/GC.h create mode 100644 rts/sm/GCAux.c create mode 100644 rts/sm/GCTDecl.h create mode 100644 rts/sm/GCThread.h create mode 100644 rts/sm/GCUtils.c create mode 100644 rts/sm/GCUtils.h create mode 100644 rts/sm/MBlock.c create mode 100644 rts/sm/MarkStack.h create mode 100644 rts/sm/MarkWeak.c create mode 100644 rts/sm/MarkWeak.h create mode 100644 rts/sm/OSMem.h create mode 100644 rts/sm/Sanity.c create mode 100644 rts/sm/Sanity.h create mode 100644 rts/sm/Scav.c create mode 100644 rts/sm/Scav.h create mode 100644 rts/sm/Storage.c create mode 100644 rts/sm/Storage.h create mode 100644 rts/sm/Sweep.c create mode 100644 rts/sm/Sweep.h create mode 100644 rts/win32/AsyncIO.c create mode 100644 rts/win32/AsyncIO.h create mode 100644 rts/win32/AwaitEvent.c create mode 100644 rts/win32/ConsoleHandler.c create mode 100644 rts/win32/ConsoleHandler.h create mode 100644 rts/win32/GetEnv.c create mode 100644 rts/win32/GetTime.c create mode 100644 rts/win32/IOManager.c create mode 100644 rts/win32/IOManager.h create mode 100644 rts/win32/OSMem.c create mode 100644 rts/win32/OSThreads.c create mode 100644 rts/win32/ThrIOManager.c create mode 100644 rts/win32/Ticker.c create mode 100644 rts/win32/WorkQueue.c create mode 100644 rts/win32/WorkQueue.h create mode 100644 rts/win32/libHSbase.def create mode 100644 rts/win32/libHSffi.def create mode 100644 rts/win32/libHSghc-prim.def create mode 100644 rts/win32/seh_excn.c create mode 100644 rts/win32/seh_excn.h create mode 100644 rules/add-dependency.mk create mode 100644 rules/all-target.mk create mode 100644 rules/bindist.mk create mode 100644 rules/build-dependencies.mk create mode 100644 rules/build-package-data.mk create mode 100644 rules/build-package-way.mk create mode 100644 rules/build-package.mk create mode 100644 rules/build-perl.mk create mode 100644 rules/build-prog.mk create mode 100644 rules/c-objs.mk create mode 100644 rules/c-sources.mk create mode 100644 rules/c-suffix-rules.mk create mode 100644 rules/clean-target.mk create mode 100644 rules/cmm-objs.mk create mode 100644 rules/cmm-suffix-rules.mk create mode 100644 rules/cross-compiling.mk create mode 100644 rules/dependencies.mk create mode 100644 rules/distdir-opts.mk create mode 100644 rules/distdir-way-opts.mk create mode 100644 rules/docbook.mk create mode 100644 rules/foreachLibrary.mk create mode 100644 rules/haddock.mk create mode 100644 rules/hi-rule.mk create mode 100644 rules/hs-objs.mk create mode 100644 rules/hs-sources.mk create mode 100644 rules/hs-suffix-rules-srcdir.mk create mode 100644 rules/hs-suffix-way-rules-srcdir.mk create mode 100644 rules/hs-suffix-way-rules.mk create mode 100644 rules/include-dependencies.mk create mode 100644 rules/includes-sources.mk create mode 100644 rules/library-path.mk create mode 100644 rules/make-command.mk create mode 100644 rules/manual-package-config.mk create mode 100644 rules/package-config.mk create mode 100644 rules/pretty_commands.mk create mode 100644 rules/prof.mk create mode 100644 rules/shell-wrapper.mk create mode 100644 rules/tags-package.mk create mode 100644 rules/trace.mk create mode 100644 rules/way-prelims.mk create mode 100644 settings.in create mode 100644 utils/checkUniques/Makefile create mode 100644 utils/checkUniques/checkUniques.hs create mode 100644 utils/compare_sizes/LICENSE create mode 100644 utils/compare_sizes/Main.hs create mode 100644 utils/compare_sizes/compareSizes.cabal create mode 100644 utils/compare_sizes/ghc.mk create mode 100644 utils/completion/README create mode 100755 utils/completion/ghc.bash create mode 100644 utils/count_lines/count_lines.lprl create mode 100644 utils/count_lines/ghc.mk create mode 100644 utils/coverity/model.c create mode 100644 utils/debugNCG/Diff_Gcc_Nat.hs create mode 100644 utils/debugNCG/Makefile create mode 100644 utils/debugNCG/README create mode 100644 utils/deriveConstants/DeriveConstants.hs create mode 100644 utils/deriveConstants/Makefile create mode 100644 utils/deriveConstants/ghc.mk create mode 100644 utils/describe-unexpected/describe-unexpected.hs create mode 100644 utils/dll-split/Main.hs create mode 100644 utils/dll-split/dll-split.cabal create mode 100644 utils/dll-split/ghc.mk create mode 100755 utils/fingerprint/fingerprint.py create mode 100644 utils/genapply/GenApply.hs create mode 100644 utils/genapply/Makefile create mode 100644 utils/genapply/ghc.mk create mode 100644 utils/genargs/Makefile create mode 100644 utils/genargs/genargs.pl create mode 100644 utils/genprimopcode/Lexer.hs create mode 100644 utils/genprimopcode/Lexer.x.source create mode 100644 utils/genprimopcode/Main.hs create mode 100644 utils/genprimopcode/Makefile create mode 100644 utils/genprimopcode/Parser.hs create mode 100644 utils/genprimopcode/Parser.y.source create mode 100644 utils/genprimopcode/ParserM.hs create mode 100644 utils/genprimopcode/Syntax.hs create mode 100644 utils/genprimopcode/ghc.mk create mode 100644 utils/ghc-cabal/Main.hs create mode 100644 utils/ghc-cabal/Makefile create mode 100644 utils/ghc-cabal/cabal_macros_boot.h create mode 100644 utils/ghc-cabal/ghc-cabal.cabal create mode 100644 utils/ghc-cabal/ghc.mk create mode 100644 utils/ghc-pkg/CRT_noglob.c create mode 100644 utils/ghc-pkg/Main.hs create mode 100644 utils/ghc-pkg/Makefile create mode 100644 utils/ghc-pkg/ghc-pkg.cabal create mode 100644 utils/ghc-pkg/ghc-pkg.wrapper create mode 100644 utils/ghc-pkg/ghc.mk create mode 100644 utils/ghc-pwd/Main.hs create mode 100644 utils/ghc-pwd/Setup.hs create mode 100644 utils/ghc-pwd/ghc-pwd.cabal create mode 100644 utils/ghc-pwd/ghc.mk create mode 100644 utils/ghctags/Main.hs create mode 100644 utils/ghctags/README create mode 100644 utils/ghctags/ghc.mk create mode 100644 utils/ghctags/ghctags.cabal create mode 100644 utils/haddock/.arcconfig create mode 100644 utils/haddock/.arclint create mode 100644 utils/haddock/.ghci create mode 100644 utils/haddock/.gitignore create mode 100644 utils/haddock/.travis.yml create mode 100644 utils/haddock/CHANGES create mode 100644 utils/haddock/CONTRIBUTING create mode 100644 utils/haddock/LICENSE create mode 100644 utils/haddock/Makefile create mode 100644 utils/haddock/README.md create mode 100644 utils/haddock/STYLE create mode 100755 utils/haddock/Setup.lhs create mode 100644 utils/haddock/build-windows-dist.sh create mode 100644 utils/haddock/dist/build/.depend.c_asm create mode 100644 utils/haddock/dist/build/.depend.haskell create mode 100644 utils/haddock/dist/build/.depend.haskell.tmp create mode 100644 utils/haddock/dist/build/.depend.haskell.tmp2 create mode 100644 utils/haddock/dist/build/autogen/Paths_haddock.hs create mode 100644 utils/haddock/dist/build/autogen/cabal_macros.h create mode 100755 utils/haddock/dist/build/tmp/haddock create mode 100644 utils/haddock/dist/haddock-prologue.txt create mode 100644 utils/haddock/dist/package-data.mk create mode 100644 utils/haddock/dist/setup-config create mode 100644 utils/haddock/doc/Makefile create mode 100644 utils/haddock/doc/README.md create mode 100644 utils/haddock/doc/aclocal.m4 create mode 100644 utils/haddock/doc/config.mk.in create mode 100644 utils/haddock/doc/configure.ac create mode 100644 utils/haddock/doc/docbook-xml.mk create mode 100644 utils/haddock/doc/fptools.css create mode 100644 utils/haddock/doc/ghc.mk create mode 100644 utils/haddock/doc/haddock.pdf create mode 100644 utils/haddock/doc/haddock.ps create mode 100644 utils/haddock/doc/haddock.xml create mode 100644 utils/haddock/doc/haddock/ch01s03.html create mode 100644 utils/haddock/doc/haddock/ch01s04.html create mode 100644 utils/haddock/doc/haddock/ch03s02.html create mode 100644 utils/haddock/doc/haddock/ch03s03.html create mode 100644 utils/haddock/doc/haddock/ch03s04.html create mode 100644 utils/haddock/doc/haddock/ch03s05.html create mode 100644 utils/haddock/doc/haddock/ch03s08.html create mode 100644 utils/haddock/doc/haddock/fptools.css create mode 100644 utils/haddock/doc/haddock/hyperlinking.html create mode 100644 utils/haddock/doc/haddock/index.html create mode 100644 utils/haddock/doc/haddock/introduction.html create mode 100644 utils/haddock/doc/haddock/invoking.html create mode 100644 utils/haddock/doc/haddock/ix01.html create mode 100644 utils/haddock/doc/haddock/license.html create mode 100644 utils/haddock/doc/haddock/markup.html create mode 100644 utils/haddock/doc/haddock/module-attributes.html create mode 100644 utils/haddock/driver/Main.hs create mode 100644 utils/haddock/ghc.mk create mode 100644 utils/haddock/haddock-api/.ghci create mode 100644 utils/haddock/haddock-api/LICENSE create mode 100755 utils/haddock/haddock-api/Setup.lhs create mode 100644 utils/haddock/haddock-api/haddock-api.cabal create mode 100644 utils/haddock/haddock-api/resources/html/Classic.theme/haskell_icon.gif create mode 100644 utils/haddock/haddock-api/resources/html/Classic.theme/minus.gif create mode 100644 utils/haddock/haddock-api/resources/html/Classic.theme/plus.gif create mode 100644 utils/haddock/haddock-api/resources/html/Classic.theme/xhaddock.css create mode 100644 utils/haddock/haddock-api/resources/html/Ocean.std-theme/hslogo-16.png create mode 100644 utils/haddock/haddock-api/resources/html/Ocean.std-theme/minus.gif create mode 100644 utils/haddock/haddock-api/resources/html/Ocean.std-theme/ocean.css create mode 100644 utils/haddock/haddock-api/resources/html/Ocean.std-theme/plus.gif create mode 100644 utils/haddock/haddock-api/resources/html/Ocean.std-theme/synopsis.png create mode 100644 utils/haddock/haddock-api/resources/html/frames.html create mode 100644 utils/haddock/haddock-api/resources/html/haddock-util.js create mode 100644 utils/haddock/haddock-api/resources/latex/haddock.sty create mode 100644 utils/haddock/haddock-api/src/Documentation/Haddock.hs create mode 100644 utils/haddock/haddock-api/src/Haddock.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/HaddockDB.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Types.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Convert.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Doc.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/GhcUtils.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface/Create.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/ModuleTree.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Options.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Parser.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Types.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Utils.hs create mode 100644 utils/haddock/haddock-api/src/Haddock/Version.hs create mode 100644 utils/haddock/haddock-api/src/haddock.sh create mode 100644 utils/haddock/haddock-library/.ghci create mode 100644 utils/haddock/haddock-library/LICENSE create mode 100644 utils/haddock/haddock-library/Setup.hs create mode 100644 utils/haddock/haddock-library/haddock-library.cabal create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Doc.hs create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Parser/Monad.hs create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Parser/Util.hs create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Types.hs create mode 100644 utils/haddock/haddock-library/src/Documentation/Haddock/Utf8.hs create mode 100644 utils/haddock/haddock-library/test/Documentation/Haddock/Parser/UtilSpec.hs create mode 100644 utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs create mode 100644 utils/haddock/haddock-library/test/Documentation/Haddock/Utf8Spec.hs create mode 100644 utils/haddock/haddock-library/test/Spec.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Buffer.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/FastSet.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Internal.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Combinator.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Fhthagn.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Number.hs create mode 100644 utils/haddock/haddock-library/vendor/attoparsec-0.12.1.1/LICENSE create mode 100644 utils/haddock/haddock.cabal create mode 100644 utils/haddock/haddock.wrapper create mode 100644 utils/haddock/html-test/README.markdown create mode 100755 utils/haddock/html-test/accept.lhs create mode 100644 utils/haddock/html-test/ref/A.html create mode 100644 utils/haddock/html-test/ref/AdvanceTypes.html create mode 100644 utils/haddock/html-test/ref/B.html create mode 100644 utils/haddock/html-test/ref/Bold.html create mode 100644 utils/haddock/html-test/ref/Bug1.html create mode 100644 utils/haddock/html-test/ref/Bug195.html create mode 100644 utils/haddock/html-test/ref/Bug2.html create mode 100644 utils/haddock/html-test/ref/Bug201.html create mode 100644 utils/haddock/html-test/ref/Bug253.html create mode 100644 utils/haddock/html-test/ref/Bug26.html create mode 100644 utils/haddock/html-test/ref/Bug294.html create mode 100644 utils/haddock/html-test/ref/Bug298.html create mode 100644 utils/haddock/html-test/ref/Bug3.html create mode 100644 utils/haddock/html-test/ref/Bug308.html create mode 100644 utils/haddock/html-test/ref/Bug308CrossModule.html create mode 100644 utils/haddock/html-test/ref/Bug310.html create mode 100644 utils/haddock/html-test/ref/Bug313.html create mode 100644 utils/haddock/html-test/ref/Bug335.html create mode 100644 utils/haddock/html-test/ref/Bug387.html create mode 100644 utils/haddock/html-test/ref/Bug4.html create mode 100644 utils/haddock/html-test/ref/Bug6.html create mode 100644 utils/haddock/html-test/ref/Bug7.html create mode 100644 utils/haddock/html-test/ref/Bug8.html create mode 100644 utils/haddock/html-test/ref/Bug85.html create mode 100644 utils/haddock/html-test/ref/BugDeprecated.html create mode 100644 utils/haddock/html-test/ref/BugExportHeadings.html create mode 100644 utils/haddock/html-test/ref/Bugs.html create mode 100644 utils/haddock/html-test/ref/CrossPackageDocs.html create mode 100644 utils/haddock/html-test/ref/DeprecatedClass.html create mode 100644 utils/haddock/html-test/ref/DeprecatedData.html create mode 100644 utils/haddock/html-test/ref/DeprecatedFunction.html create mode 100644 utils/haddock/html-test/ref/DeprecatedFunction2.html create mode 100644 utils/haddock/html-test/ref/DeprecatedFunction3.html create mode 100644 utils/haddock/html-test/ref/DeprecatedModule.html create mode 100644 utils/haddock/html-test/ref/DeprecatedModule2.html create mode 100644 utils/haddock/html-test/ref/DeprecatedNewtype.html create mode 100644 utils/haddock/html-test/ref/DeprecatedReExport.html create mode 100644 utils/haddock/html-test/ref/DeprecatedRecord.html create mode 100644 utils/haddock/html-test/ref/DeprecatedTypeFamily.html create mode 100644 utils/haddock/html-test/ref/DeprecatedTypeSynonym.html create mode 100644 utils/haddock/html-test/ref/Examples.html create mode 100644 utils/haddock/html-test/ref/Extensions.html create mode 100644 utils/haddock/html-test/ref/FunArgs.html create mode 100644 utils/haddock/html-test/ref/GADTRecords.html create mode 100644 utils/haddock/html-test/ref/Hash.html create mode 100644 utils/haddock/html-test/ref/HiddenInstances.html create mode 100644 utils/haddock/html-test/ref/HiddenInstancesB.html create mode 100644 utils/haddock/html-test/ref/Hyperlinks.html create mode 100644 utils/haddock/html-test/ref/IgnoreExports.html create mode 100644 utils/haddock/html-test/ref/ImplicitParams.html create mode 100644 utils/haddock/html-test/ref/Minimal.html create mode 100644 utils/haddock/html-test/ref/ModuleWithWarning.html create mode 100644 utils/haddock/html-test/ref/NamedDoc.html create mode 100644 utils/haddock/html-test/ref/Nesting.html create mode 100644 utils/haddock/html-test/ref/NoLayout.html create mode 100644 utils/haddock/html-test/ref/NonGreedy.html create mode 100644 utils/haddock/html-test/ref/Operators.html create mode 100644 utils/haddock/html-test/ref/PatternSyns.html create mode 100644 utils/haddock/html-test/ref/Properties.html create mode 100644 utils/haddock/html-test/ref/PruneWithWarning.html create mode 100644 utils/haddock/html-test/ref/QuasiExpr.html create mode 100644 utils/haddock/html-test/ref/QuasiQuote.html create mode 100644 utils/haddock/html-test/ref/SpuriousSuperclassConstraints.html create mode 100644 utils/haddock/html-test/ref/TH.html create mode 100644 utils/haddock/html-test/ref/TH2.html create mode 100644 utils/haddock/html-test/ref/Test.html create mode 100644 utils/haddock/html-test/ref/Threaded.html create mode 100644 utils/haddock/html-test/ref/Ticket112.html create mode 100644 utils/haddock/html-test/ref/Ticket61.html create mode 100644 utils/haddock/html-test/ref/Ticket75.html create mode 100644 utils/haddock/html-test/ref/TitledPicture.html create mode 100644 utils/haddock/html-test/ref/TypeFamilies.html create mode 100644 utils/haddock/html-test/ref/TypeFamilies2.html create mode 100644 utils/haddock/html-test/ref/TypeOperators.html create mode 100644 utils/haddock/html-test/ref/Unicode.html create mode 100644 utils/haddock/html-test/ref/Visible.html create mode 100644 utils/haddock/html-test/ref/frames.html create mode 100644 utils/haddock/html-test/ref/haddock-util.js create mode 100644 utils/haddock/html-test/ref/hslogo-16.png create mode 100644 utils/haddock/html-test/ref/mini_A.html create mode 100644 utils/haddock/html-test/ref/mini_AdvanceTypes.html create mode 100644 utils/haddock/html-test/ref/mini_B.html create mode 100644 utils/haddock/html-test/ref/mini_Bug1.html create mode 100644 utils/haddock/html-test/ref/mini_Bug2.html create mode 100644 utils/haddock/html-test/ref/mini_Bug3.html create mode 100644 utils/haddock/html-test/ref/mini_Bug4.html create mode 100644 utils/haddock/html-test/ref/mini_Bug6.html create mode 100644 utils/haddock/html-test/ref/mini_Bug7.html create mode 100644 utils/haddock/html-test/ref/mini_Bug8.html create mode 100644 utils/haddock/html-test/ref/mini_BugDeprecated.html create mode 100644 utils/haddock/html-test/ref/mini_BugExportHeadings.html create mode 100644 utils/haddock/html-test/ref/mini_Bugs.html create mode 100644 utils/haddock/html-test/ref/mini_CrossPackageDocs.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedClass.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedData.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedFunction.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedFunction2.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedFunction3.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedModule.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedModule2.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedNewtype.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedReExport.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedRecord.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedTypeFamily.html create mode 100644 utils/haddock/html-test/ref/mini_DeprecatedTypeSynonym.html create mode 100644 utils/haddock/html-test/ref/mini_Examples.html create mode 100644 utils/haddock/html-test/ref/mini_FunArgs.html create mode 100644 utils/haddock/html-test/ref/mini_GADTRecords.html create mode 100644 utils/haddock/html-test/ref/mini_Hash.html create mode 100644 utils/haddock/html-test/ref/mini_HiddenInstances.html create mode 100644 utils/haddock/html-test/ref/mini_HiddenInstancesB.html create mode 100644 utils/haddock/html-test/ref/mini_Hyperlinks.html create mode 100644 utils/haddock/html-test/ref/mini_IgnoreExports.html create mode 100644 utils/haddock/html-test/ref/mini_ModuleWithWarning.html create mode 100644 utils/haddock/html-test/ref/mini_NamedDoc.html create mode 100644 utils/haddock/html-test/ref/mini_NoLayout.html create mode 100644 utils/haddock/html-test/ref/mini_NonGreedy.html create mode 100644 utils/haddock/html-test/ref/mini_Properties.html create mode 100644 utils/haddock/html-test/ref/mini_PruneWithWarning.html create mode 100644 utils/haddock/html-test/ref/mini_QuasiExpr.html create mode 100644 utils/haddock/html-test/ref/mini_QuasiQuote.html create mode 100644 utils/haddock/html-test/ref/mini_SpuriousSuperclassConstraints.html create mode 100644 utils/haddock/html-test/ref/mini_TH.html create mode 100644 utils/haddock/html-test/ref/mini_TH2.html create mode 100644 utils/haddock/html-test/ref/mini_Test.html create mode 100644 utils/haddock/html-test/ref/mini_Ticket112.html create mode 100644 utils/haddock/html-test/ref/mini_Ticket253_1.html create mode 100644 utils/haddock/html-test/ref/mini_Ticket253_2.html create mode 100644 utils/haddock/html-test/ref/mini_Ticket61.html create mode 100644 utils/haddock/html-test/ref/mini_Ticket75.html create mode 100644 utils/haddock/html-test/ref/mini_TitledPicture.html create mode 100644 utils/haddock/html-test/ref/mini_TypeFamilies.html create mode 100644 utils/haddock/html-test/ref/mini_TypeOperators.html create mode 100644 utils/haddock/html-test/ref/mini_Unicode.html create mode 100644 utils/haddock/html-test/ref/mini_Visible.html create mode 100644 utils/haddock/html-test/ref/minus.gif create mode 100644 utils/haddock/html-test/ref/ocean.css create mode 100644 utils/haddock/html-test/ref/plus.gif create mode 100644 utils/haddock/html-test/ref/synopsis.png create mode 100755 utils/haddock/html-test/run.lhs create mode 100644 utils/haddock/html-test/src/A.hs create mode 100644 utils/haddock/html-test/src/AdvanceTypes.hs create mode 100644 utils/haddock/html-test/src/B.hs create mode 100644 utils/haddock/html-test/src/Bold.hs create mode 100644 utils/haddock/html-test/src/Bug1.hs create mode 100644 utils/haddock/html-test/src/Bug195.hs create mode 100644 utils/haddock/html-test/src/Bug2.hs create mode 100644 utils/haddock/html-test/src/Bug201.hs create mode 100644 utils/haddock/html-test/src/Bug253.hs create mode 100644 utils/haddock/html-test/src/Bug26.hs create mode 100644 utils/haddock/html-test/src/Bug294.hs create mode 100644 utils/haddock/html-test/src/Bug298.hs create mode 100644 utils/haddock/html-test/src/Bug3.hs create mode 100644 utils/haddock/html-test/src/Bug308.hs create mode 100644 utils/haddock/html-test/src/Bug308CrossModule.hs create mode 100644 utils/haddock/html-test/src/Bug310.hs create mode 100644 utils/haddock/html-test/src/Bug313.hs create mode 100644 utils/haddock/html-test/src/Bug335.hs create mode 100644 utils/haddock/html-test/src/Bug387.hs create mode 100644 utils/haddock/html-test/src/Bug4.hs create mode 100644 utils/haddock/html-test/src/Bug6.hs create mode 100644 utils/haddock/html-test/src/Bug7.hs create mode 100644 utils/haddock/html-test/src/Bug8.hs create mode 100644 utils/haddock/html-test/src/Bug85.hs create mode 100644 utils/haddock/html-test/src/BugDeprecated.hs create mode 100644 utils/haddock/html-test/src/BugExportHeadings.hs create mode 100644 utils/haddock/html-test/src/Bugs.hs create mode 100644 utils/haddock/html-test/src/CrossPackageDocs.hs_hidden create mode 100644 utils/haddock/html-test/src/DeprecatedClass.hs create mode 100644 utils/haddock/html-test/src/DeprecatedData.hs create mode 100644 utils/haddock/html-test/src/DeprecatedFunction.hs create mode 100644 utils/haddock/html-test/src/DeprecatedFunction2.hs create mode 100644 utils/haddock/html-test/src/DeprecatedFunction3.hs create mode 100644 utils/haddock/html-test/src/DeprecatedModule.hs create mode 100644 utils/haddock/html-test/src/DeprecatedModule2.hs create mode 100644 utils/haddock/html-test/src/DeprecatedNewtype.hs create mode 100644 utils/haddock/html-test/src/DeprecatedReExport.hs create mode 100644 utils/haddock/html-test/src/DeprecatedRecord.hs create mode 100644 utils/haddock/html-test/src/DeprecatedTypeFamily.hs create mode 100644 utils/haddock/html-test/src/DeprecatedTypeSynonym.hs create mode 100644 utils/haddock/html-test/src/Examples.hs create mode 100644 utils/haddock/html-test/src/Extensions.hs create mode 100644 utils/haddock/html-test/src/FunArgs.hs create mode 100644 utils/haddock/html-test/src/GADTRecords.hs create mode 100644 utils/haddock/html-test/src/Hash.hs create mode 100644 utils/haddock/html-test/src/Hidden.hs create mode 100644 utils/haddock/html-test/src/HiddenInstances.hs create mode 100644 utils/haddock/html-test/src/HiddenInstancesA.hs create mode 100644 utils/haddock/html-test/src/HiddenInstancesB.hs create mode 100644 utils/haddock/html-test/src/Hyperlinks.hs create mode 100644 utils/haddock/html-test/src/IgnoreExports.hs create mode 100644 utils/haddock/html-test/src/ImplicitParams.hs create mode 100644 utils/haddock/html-test/src/Minimal.hs create mode 100644 utils/haddock/html-test/src/ModuleWithWarning.hs create mode 100644 utils/haddock/html-test/src/NamedDoc.hs create mode 100644 utils/haddock/html-test/src/Nesting.hs create mode 100644 utils/haddock/html-test/src/NoLayout.hs create mode 100644 utils/haddock/html-test/src/NonGreedy.hs create mode 100644 utils/haddock/html-test/src/Operators.hs create mode 100644 utils/haddock/html-test/src/PatternSyns.hs create mode 100644 utils/haddock/html-test/src/Properties.hs create mode 100644 utils/haddock/html-test/src/PruneWithWarning.hs create mode 100644 utils/haddock/html-test/src/QuasiExpr.hs create mode 100644 utils/haddock/html-test/src/QuasiQuote.hs create mode 100644 utils/haddock/html-test/src/SpuriousSuperclassConstraints.hs create mode 100644 utils/haddock/html-test/src/TH.hs create mode 100644 utils/haddock/html-test/src/TH2.hs create mode 100644 utils/haddock/html-test/src/Test.hs create mode 100644 utils/haddock/html-test/src/Threaded.hs create mode 100644 utils/haddock/html-test/src/Threaded_TH.hs create mode 100644 utils/haddock/html-test/src/Ticket112.hs create mode 100644 utils/haddock/html-test/src/Ticket61.hs create mode 100644 utils/haddock/html-test/src/Ticket61_Hidden.hs create mode 100644 utils/haddock/html-test/src/Ticket75.hs create mode 100644 utils/haddock/html-test/src/TitledPicture.hs create mode 100644 utils/haddock/html-test/src/TypeFamilies.hs create mode 100644 utils/haddock/html-test/src/TypeFamilies2.hs create mode 100644 utils/haddock/html-test/src/TypeOperators.hs create mode 100644 utils/haddock/html-test/src/Unicode.hs create mode 100644 utils/haddock/html-test/src/Visible.hs create mode 100755 utils/haddock/latex-test/accept.lhs create mode 100644 utils/haddock/latex-test/ref/Simple/Simple.tex create mode 100644 utils/haddock/latex-test/ref/Simple/haddock.sty create mode 100644 utils/haddock/latex-test/ref/Simple/main.tex create mode 100755 utils/haddock/latex-test/run.lhs create mode 100644 utils/haddock/latex-test/src/Simple/Simple.hs create mode 100644 utils/haddock/make-sdist.sh create mode 100644 utils/hp2ps/AreaBelow.c create mode 100644 utils/hp2ps/AreaBelow.h create mode 100644 utils/hp2ps/AuxFile.c create mode 100644 utils/hp2ps/AuxFile.h create mode 100644 utils/hp2ps/Axes.c create mode 100644 utils/hp2ps/Axes.h create mode 100644 utils/hp2ps/CHANGES create mode 100644 utils/hp2ps/Curves.c create mode 100644 utils/hp2ps/Curves.h create mode 100644 utils/hp2ps/Defines.h create mode 100644 utils/hp2ps/Deviation.c create mode 100644 utils/hp2ps/Deviation.h create mode 100644 utils/hp2ps/Dimensions.c create mode 100644 utils/hp2ps/Dimensions.h create mode 100644 utils/hp2ps/Error.c create mode 100644 utils/hp2ps/Error.h create mode 100644 utils/hp2ps/HpFile.c create mode 100644 utils/hp2ps/HpFile.h create mode 100644 utils/hp2ps/Key.c create mode 100644 utils/hp2ps/Key.h create mode 100644 utils/hp2ps/Main.c create mode 100644 utils/hp2ps/Main.h create mode 100644 utils/hp2ps/Makefile create mode 100644 utils/hp2ps/Marks.c create mode 100644 utils/hp2ps/Marks.h create mode 100644 utils/hp2ps/PsFile.c create mode 100644 utils/hp2ps/PsFile.h create mode 100644 utils/hp2ps/README.GHC create mode 100644 utils/hp2ps/Reorder.c create mode 100644 utils/hp2ps/Reorder.h create mode 100644 utils/hp2ps/Scale.c create mode 100644 utils/hp2ps/Scale.h create mode 100644 utils/hp2ps/Shade.c create mode 100644 utils/hp2ps/Shade.h create mode 100644 utils/hp2ps/TopTwenty.c create mode 100644 utils/hp2ps/TopTwenty.h create mode 100644 utils/hp2ps/TraceElement.c create mode 100644 utils/hp2ps/TraceElement.h create mode 100644 utils/hp2ps/Utilities.c create mode 100644 utils/hp2ps/Utilities.h create mode 100644 utils/hp2ps/ghc.mk create mode 100644 utils/hp2ps/hp2ps.1 create mode 100644 utils/hp2ps/makefile.original create mode 100644 utils/hpc/HpcCombine.hs create mode 100644 utils/hpc/HpcDraft.hs create mode 100644 utils/hpc/HpcFlags.hs create mode 100644 utils/hpc/HpcLexer.hs create mode 100644 utils/hpc/HpcMarkup.hs create mode 100644 utils/hpc/HpcOverlay.hs create mode 100644 utils/hpc/HpcParser.hs create mode 100644 utils/hpc/HpcParser.y.source create mode 100644 utils/hpc/HpcReport.hs create mode 100644 utils/hpc/HpcShowTix.hs create mode 100644 utils/hpc/HpcUtils.hs create mode 100644 utils/hpc/Main.hs create mode 100644 utils/hpc/Makefile create mode 100644 utils/hpc/ghc.mk create mode 100644 utils/hpc/hpc-bin.cabal create mode 100644 utils/hpc/hpc.wrapper create mode 100644 utils/hsc2hs/.gitignore create mode 100644 utils/hsc2hs/C.hs create mode 100644 utils/hsc2hs/Common.hs create mode 100644 utils/hsc2hs/CrossCodegen.hs create mode 100644 utils/hsc2hs/DirectCodegen.hs create mode 100644 utils/hsc2hs/Flags.hs create mode 100644 utils/hsc2hs/HSCParser.hs create mode 100644 utils/hsc2hs/LICENSE create mode 100644 utils/hsc2hs/Main.hs create mode 100644 utils/hsc2hs/Makefile create mode 100644 utils/hsc2hs/Makefile.inc create mode 100644 utils/hsc2hs/Makefile.nhc98 create mode 100644 utils/hsc2hs/Setup.hs create mode 100644 utils/hsc2hs/UtilsCodegen.hs create mode 100644 utils/hsc2hs/ghc.mk create mode 100644 utils/hsc2hs/hsc2hs.cabal create mode 100644 utils/hsc2hs/hsc2hs.wrapper create mode 100644 utils/hsc2hs/template-hsc.h create mode 100644 utils/lndir/lndir-Xos.h create mode 100644 utils/lndir/lndir-Xosdefs.h create mode 100644 utils/lndir/lndir.c create mode 100644 utils/mkUserGuidePart/Main.hs create mode 100644 utils/mkUserGuidePart/Makefile create mode 100644 utils/mkUserGuidePart/ghc.mk create mode 100644 utils/mkUserGuidePart/mkUserGuidePart.cabal create mode 100644 utils/mkdirhier/Makefile create mode 100644 utils/mkdirhier/ghc.mk create mode 100644 utils/mkdirhier/mkdirhier.sh create mode 100644 utils/runghc/Makefile create mode 100644 utils/runghc/ghc.mk create mode 100644 utils/runghc/runghc.cabal.in create mode 100644 utils/runghc/runghc.hs create mode 100644 utils/runghc/runghc.wrapper create mode 100644 utils/testremove/checkremove.hs create mode 100644 utils/testremove/ghc.mk create mode 100644 utils/testremove/wouldrm.hs create mode 100644 utils/touchy/Makefile create mode 100644 utils/touchy/ghc.mk create mode 100644 utils/touchy/touchy.c create mode 100644 utils/unlit/Makefile create mode 100644 utils/unlit/README create mode 100644 utils/unlit/ghc.mk create mode 100644 utils/unlit/unlit.c create mode 100755 utils/vagrant/bootstrap-deb.sh create mode 100755 utils/vagrant/bootstrap-rhel.sh diff --git a/ANNOUNCE b/ANNOUNCE new file mode 100644 index 00000000..7812ebad --- /dev/null +++ b/ANNOUNCE @@ -0,0 +1,126 @@ + + ============================================================== + The (Interactive) Glasgow Haskell Compiler -- version 7.10.2 + ============================================================== + +The GHC Team is pleased to announce a new minor release of GHC. This is a +bug-fix release and contains a number of important fixes, + + * Various typechecker issues have been fixed, including some bugs which allowed + the user to write unsafeCoerce + + * DWARF debug information is now more correct and supported on Windows + + * Portability issues resulting in crashes on SPARC, Linux/i386, ARM, AArch64, + and PowerPC have been fixed + + * The event manager's multi-shot event registration functionality now works + correctly + + * A bug where unaccounted for register aliasing could result in incorrect + floating-point results has been fixed + + * An infinite loop during program startup when iconv is unavailable hsa been + fixed + + * The source location of the caller of a function is now available as an implicit + parameter to allow for better error reporting in the future + +A more thorough list of the changes in the release can be found in the release +notes, + + http://haskell.org/ghc/docs/7.10.2/html/users_guide/release-7-10-2.html + + +How to get it +~~~~~~~~~~~~~ + +The easy way is to go to the web page, which should be self-explanatory: + + http://www.haskell.org/ghc/ + +We supply binary builds in the native package format for many +platforms, and the source distribution is available from the same +place. + +Packages will appear as they are built - if the package for your +system isn't available yet, please try again later. + + +Background +~~~~~~~~~~ + +Haskell is a standard lazy functional programming language. + +GHC is a state-of-the-art programming suite for Haskell. Included is +an optimising compiler generating efficient code for a variety of +platforms, together with an interactive system for convenient, quick +development. The distribution includes space and time profiling +facilities, a large collection of libraries, and support for various +language extensions, including concurrency, exceptions, and foreign +language interfaces. GHC is distributed under a BSD-style open source license. + +A wide variety of Haskell related resources (tutorials, libraries, +specifications, documentation, compilers, interpreters, references, +contact information, links to research groups) are available from the +Haskell home page (see below). + + +On-line GHC-related resources +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Relevant URLs on the World-Wide Web: + +GHC home page http://www.haskell.org/ghc/ +GHC developers' home page http://ghc.haskell.org/trac/ghc/ +Haskell home page http://www.haskell.org/ + + +Supported Platforms +~~~~~~~~~~~~~~~~~~~ + +The list of platforms we support, and the people responsible for them, +is here: + + http://ghc.haskell.org/trac/ghc/wiki/Contributors + +Ports to other platforms are possible with varying degrees of +difficulty. The Building Guide describes how to go about porting to a +new platform: + + http://ghc.haskell.org/trac/ghc/wiki/Building + + +Developers +~~~~~~~~~~ + +We welcome new contributors. Instructions on accessing our source +code repository, and getting started with hacking on GHC, are +available from the GHC's developer's site run by Trac: + + http://ghc.haskell.org/trac/ghc/ + + +Mailing lists +~~~~~~~~~~~~~ + +We run mailing lists for GHC users and bug reports; to subscribe, use +the web interfaces at + + http://mail.haskell.org/cgi-bin/mailman/listinfo/glasgow-haskell-users + http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-tickets + +There are several other haskell and ghc-related mailing lists on +www.haskell.org; for the full list, see + + https://mail.haskell.org/cgi-bin/mailman/listinfo + +Some GHC developers hang out on #haskell on IRC, too: + + http://www.haskell.org/haskellwiki/IRC_channel + +Please report bugs using our bug tracking system. Instructions on +reporting bugs can be found here: + + http://www.haskell.org/ghc/reportabug + diff --git a/GIT_COMMIT_ID b/GIT_COMMIT_ID new file mode 100644 index 00000000..2b2cb975 --- /dev/null +++ b/GIT_COMMIT_ID @@ -0,0 +1 @@ +97e7c293abbde5223d2bf0516f8969bdd1a9a7a2 \ No newline at end of file diff --git a/HACKING.md b/HACKING.md new file mode 100644 index 00000000..6ed39eaf --- /dev/null +++ b/HACKING.md @@ -0,0 +1,154 @@ +Contributing to the Glasgow Haskell Compiler +============================================ + +So you've decided to hack on GHC, congratulations! We hope you have a +rewarding experience. This file will point you in the direction of +information to help you get started right away. + +The GHC Developer's Wiki +======================== + +The home for GHC hackers is our Trac instance, located here: + + + +From here, you can file bugs (or look them up,) use the wiki, view the +`git` history, among other things. Of particular note is the building +page, which has the high level overview of the build process and how +to get the source: + + + +Contributing patches to GHC in a hurry +====================================== + +Make sure your system has the necessary tools to compile GHC. You can +find an overview here: + + + +Next, clone the repository and all the associated libraries: + +``` +$ git clone --recursive git://git.haskell.org/ghc.git +``` + +On Windows, you need an extra repository containing some build tools. +These can be downloaded for you by configure. This only needs to be done once by running: + +``` +$ ./configure --enable-tarballs-autodownload +``` + +First copy `mk/build.mk.sample` to `mk/build.mk` and ensure it has +your preferred build settings. (You probably want to at least set +`BuildFlavour` to `quick`): + +``` +$ cp mk/build.mk.sample mk/build.mk +$ ... double-check mk/build.mk ... +``` + +Now build. If you have multiple cores, **you should always use them to +speed up compilation**: + +``` +$ ./boot +$ ./configure +$ make -jN # is the number of cores you have. +``` + +You can use the `./inplace/bin/ghc-stage2` binary to play with the +newly built compiler. + +Now, hack on your copy and rebuild (with `make`) as necessary. + +Then start by making your commits however you want. When you're done, you +can use `git format-patch` to create a series of `.patch` files you +can give to us. In this example, we'll assume I'm on a `bugfix` branch +and want to submit my patches: + +``` +$ git branch +* bugfix + master +$ git format-patch master -o patches +... +$ +``` + +Now create a trac ticket: + + + +And attach the files in your `patches/` directory. Set the status from +*new* to *patch* and we'll review it as soon as we can! + +Useful links: +============= + +An overview of things like using git, the release process, filing bugs +and more can be located here: + + + +You can find our coding conventions for the compiler and RTS here: + + + + +A high level overview of the bug tracker: + + + +If you're going to contribute regularly, **learning how to use the +build system is important** and will save you lots of time. You should +read over this page carefully: + + + +How to communicate with us +========================== + +GHC is a big project, so you'll surely need help. Luckily, we can +provide plenty through a variety of means! + +## IRC + +If you're an IRC user, be sure to drop by the official `#ghc` channel +on [freenode](http://freenode.org). Many (but not all) of the +developers and committers are actively there during a variety of +hours. + +## Mailing lists + +In the event IRC does not work or if you'd like a bigger audience, GHC +has several mailing lists for this purpose. The most important one is +[ghc-devs](http://www.haskell.org/pipermail/ghc-devs/), which is where +the developers actively hang out and discuss incoming changes and +problems. + +There is no strict standard about where you post patches - either in +`ghc-devs` or in the bug tracker. Ideally, please put it in the bug +tracker with test cases or relevant information in a ticket, and set +the ticket status to `patch`. By doing this, we'll see the patch +quickly and be able to review. This will also ensure it doesn't get +lost. But if the change is small and self contained, feel free to +attach it to your email, and send it to `ghc-devs`. + +Furthermore, if you're a developer (or want to become one!) you're +undoubtedly also interested in the other mailing lists: + + * [glasgow-haskell-users](http://www.haskell.org/mailman/listinfo/glasgow-haskell-users) + is where developers/users meet. + * [ghc-tickets](http://www.haskell.org/mailman/listinfo/ghc-tickets) + for email from Trac. + * [ghc-builds](http://www.haskell.org/mailman/listinfo/ghc-builds) + for nightly build emails. + * [ghc-commits](http://www.haskell.org/mailman/listinfo/ghc-commits) + for commit messages when someone pushes to the repository. + +El fin +====== + +Happy Hacking! -- The GHC Team diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 00000000..58930afe --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,45 @@ +Building & Installing +===================== + +For full information on building GHC, see the GHC Building Guide [1]. +Here follows a summary - if you get into trouble, the Building Guide +has all the answers. + +Before building GHC you may need to install some other tools and +libraries. See "Setting up your system for building GHC" [2]. + +NB. in particular you need GHC installed in order to build GHC, +because the compiler is itself written in Haskell. For instructions +on how to port GHC to a new platform, see the Building Guide [1]. + +For building library documentation, you'll need Haddock [3]. To build +the compiler documentation, you need a good DocBook XML toolchain and +dblatex. + +Quick start: the following gives you a default build: + + $ perl boot + $ ./configure + $ make + $ make install + + On Windows, you need an extra repository containing some build tools. + These can be downloaded for you by configure. This only needs to be done once by running: + + $ ./configure --enable-tarballs-autodownload + +The "perl boot" step is only necessary if this is a tree checked out +from git. For source distributions downloaded from GHC's web site, +this step has already been performed. + +These steps give you the default build, which includes everything +optimised and built in various ways (eg. profiling libs are built). +It can take a long time. To customise the build, see the file +`HACKING.md`. + +References +========== + + [1] http://www.haskell.org/ghc/ + [2] http://hackage.haskell.org/trac/ghc/wiki/Building/Preparation + [3] http://www.haskell.org/haddock/ diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..b5059b71 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/MAKEHELP.md b/MAKEHELP.md new file mode 100644 index 00000000..ff0e4340 --- /dev/null +++ b/MAKEHELP.md @@ -0,0 +1,81 @@ +Quick `make` guide for GHC +========================== + +For a "Getting Started" guide, see: + + http://ghc.haskell.org/trac/ghc/wiki/Building/Hacking + +Common commands: + + - `make` + + Builds everything: ghc stages 1 and 2, all libraries and tools. + + - `make -j2` + + Parallel build: runs up to 2 commands at a time. + + - `cd ; make` + + Builds everything in the given directory. + + - cd ; make help + + Shows the targets available in + + - make install + + Installs GHC, libraries and tools under $(prefix) + + - make sdist + - make binary-dist + + Builds a source or binary distribution respectively + + - `make show VALUE=` + + Displays the value of make variable + + - make clean + - make distclean + - make maintainer-clean + + Various levels of cleaning: "clean" restores the tree to the + state after "./configure", "distclean" restores to the state + after "perl boot", and maintainer-clean restores the tree to the + completely clean checked-out state. + +Using `make` in subdirectories +============================== + + - `make` + + Builds everything in this directory (including dependencies elsewhere + in the tree, if necessary) + + - `make fast` + + The same as 'make', but omits some phases and does not + recalculate dependencies. Useful for saving time if you are sure + the rest of the tree is up to date. + + - `make clean` + - `make distclean` + - `make maintainer-clean` + + Clean just this directory + + - `make html` + - `make pdf` + - `make ps` + + Make documentation in this directory (if any) + + - `make show VALUE=var` + + Show the value of $(var) + + - `make ` + + Bring a particular file up to date, e.g. make dist/build/Module.o + The name is relative to the current directory diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..de9bcf32 --- /dev/null +++ b/Makefile @@ -0,0 +1,121 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +ifeq "$(wildcard distrib/)" "" + +# We're in a bindist + +.PHONY: default +default: + @echo 'Run "make install" to install' + @false + +.PHONY: install show +install show: + $(MAKE) -r --no-print-directory -f ghc.mk $@ BINDIST=YES NO_INCLUDE_DEPS=YES + +else + +default : all + @: + +# For help, type 'make help' +.PHONY: help +help: + @cat MAKEHELP.md + +ifneq "$(filter maintainer-clean distclean clean help,$(MAKECMDGOALS))" "" +-include mk/config.mk +else +include mk/config.mk +ifeq "$(ProjectVersion)" "" +$(error Please run ./configure first) +endif +endif + +include mk/custom-settings.mk + +# Verify that stage 0 LLVM backend isn't affected by Bug #9439 if needed +ifeq "$(GHC_LLVM_AFFECTED_BY_9439)" "1" +ifneq "$(findstring -fllvm,$(GhcHcOpts) $(GhcStage1HcOpts))" "" +$(error Stage 0 compiler is affected by Bug #9439. Refusing to bootstrap with -fllvm) +endif +endif + +# No need to update makefiles for these targets: +REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show echo help test fulltest,$(MAKECMDGOALS)) + +# configure touches certain files even if they haven't changed. This +# can mean a lot of unnecessary recompilation after a re-configure, so +# here we cache the old versions of these files so we can restore the +# timestamps. +%.old: % + @set -x && test -f $@ && cmp -s $< $@ || cp -p $< $@ + touch -r $@ $< + + +# NB. not the same as saying '%: ...', which doesn't do the right thing: +# it does nothing if we specify a target that already exists. +.PHONY: $(REALGOALS) +$(REALGOALS) all: mk/config.mk.old mk/project.mk.old compiler/ghc.cabal.old +ifneq "$(OMIT_PHASE_0)" "YES" + @echo "===--- building phase 0" + $(MAKE) -r --no-print-directory -f ghc.mk phase=0 phase_0_builds +endif +ifneq "$(OMIT_PHASE_1)" "YES" + @echo "===--- building phase 1" + $(MAKE) -r --no-print-directory -f ghc.mk phase=1 phase_1_builds +endif + @echo "===--- building final phase" + $(MAKE) -r --no-print-directory -f ghc.mk phase=final $@ + +binary-dist: binary-dist-prep + mv bindistprep/*.tar.$(TAR_COMP_EXT) . + +binary-dist-prep: +ifeq "$(mingw32_TARGET_OS)" "1" + $(MAKE) -r --no-print-directory -f ghc.mk windows-binary-dist-prep +else + rm -f bindist-list + $(MAKE) -r --no-print-directory -f ghc.mk bindist BINDIST=YES + $(MAKE) -r --no-print-directory -f ghc.mk unix-binary-dist-prep +endif + +clean distclean maintainer-clean: + $(MAKE) -r --no-print-directory -f ghc.mk $@ CLEANING=YES + test ! -d testsuite || $(MAKE) -C testsuite $@ + +$(filter clean_%, $(MAKECMDGOALS)) : clean_% : + $(MAKE) -r --no-print-directory -f ghc.mk $@ CLEANING=YES + +bootstrapping-files show echo: + $(MAKE) -r --no-print-directory -f ghc.mk $@ + +ifeq "$(darwin_TARGET_OS)" "1" +framework-pkg: + $(MAKE) -C distrib/MacOS $@ +endif + +# If the user says 'make A B', then we don't want to invoke two +# instances of the rule above in parallel: +.NOTPARALLEL: + +endif + +.PHONY: test +test: + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt fast + +.PHONY: fulltest +fulltest: + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt + diff --git a/README.md b/README.md new file mode 100644 index 00000000..025140c7 --- /dev/null +++ b/README.md @@ -0,0 +1,129 @@ +The Glasgow Haskell Compiler +============================ + +[![Build Status](https://api.travis-ci.org/ghc/ghc.svg?branch=master)](http://travis-ci.org/ghc/ghc) + +This is the source tree for [GHC][1], a compiler and interactive +environment for the Haskell functional programming language. + +For more information, visit [GHC's web site][1]. + +Information for developers of GHC can be found on the [GHC Trac][2]. + + +Getting the Source +================== + +There are two ways to get a source tree: + + 1. *Download source tarballs* + + Download the GHC source distribution: + + ghc--src.tar.bz2 + + which contains GHC itself and the "boot" libraries. + + 2. *Check out the source code from git* + + $ git clone --recursive git://git.haskell.org/ghc.git + + Note: cloning GHC from Github requires a special setup. See [Getting a GHC + repository from Github] [7]. + + **DO NOT submit pull request directly to the github repo.** + *See the GHC team's working conventions re [how to contribute a patch to GHC](http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/FixingBugs "ghc.haskell.org/trac/ghc/wiki/WorkingConventions/FixingBug").* + + +Building & Installing +===================== + +For full information on building GHC, see the [GHC Building Guide] [3]. +Here follows a summary - if you get into trouble, the Building Guide +has all the answers. + +Before building GHC you may need to install some other tools and +libraries. See, [Setting up your system for building GHC] [8]. + +*NB.* In particular, you need [GHC] [1] installed in order to build GHC, +because the compiler is itself written in Haskell. You also need +[Happy] [4], [Alex] [5], and [Cabal] [9]. For instructions on how +to port GHC to a new platform, see the [GHC Building Guide] [3]. + +For building library documentation, you'll need [Haddock] [6]. To build +the compiler documentation, you need a good DocBook XML toolchain and +dblatex. + +**Quick start**: the following gives you a default build: + + $ ./boot + $ ./configure + $ make # can also say 'make -jX' for X number of jobs + $ make install + + On Windows, you need an extra repository containing some build tools. + These can be downloaded for you by configure. This only needs to be done once by running: + + $ ./configure --enable-tarballs-autodownload + +(NB: **Do you have multiple cores? Be sure to tell that to `make`!** This can +save you hours of build time depending on your system configuration, and is +almost always a win regardless of how many cores you have. As a simple rule, +you should have about N+1 jobs, where `N` is the amount of cores you have.) + +The `./boot` step is only necessary if this is a tree checked out +from git. For source distributions downloaded from [GHC's web site] [1], +this step has already been performed. + +These steps give you the default build, which includes everything +optimised and built in various ways (eg. profiling libs are built). +It can take a long time. To customise the build, see the file `HACKING`. + +Filing bugs and feature requests +================================ + +If you've encountered what you believe is a bug in GHC, or you'd like +to propose a feature request, please let us know! Submit a ticket in +our [bug tracker] [10] and we'll be sure to look into it. Remember: +**Filing a bug is the best way to make sure your issue isn't lost over +time**, so please feel free. + +If you're an active user of GHC, you may also be interested in joining +the [glasgow-haskell-users] [11] mailing list, where developers and +GHC users discuss various topics and hang out. + +Hacking & Developing GHC +======================== + +Once you've filed a bug, maybe you'd like to fix it yourself? That +would be great, and we'd surely love your company! If you're looking +to hack on GHC, check out the guidelines in the `HACKING.md` file in +this directory - they'll get you up to speed quickly. + +Contributors & Acknowledgements +=============================== + +GHC in its current form wouldn't exist without the hard work of +[its many contributors] [12]. Over time, it has grown to include the +efforts and research of many institutions, highly talented people, and +groups from around the world. We'd like to thank them all, and invite +you to join! + + [1]: http://www.haskell.org/ghc/ "www.haskell.org/ghc/" + [2]: http://ghc.haskell.org/trac/ghc "ghc.haskell.org/trac/ghc" + [3]: http://ghc.haskell.org/trac/ghc/wiki/Building + "ghc.haskell.org/trac/ghc/wiki/Building" + [4]: http://www.haskell.org/happy/ "www.haskell.org/happy/" + [5]: http://www.haskell.org/alex/ "www.haskell.org/alex/" + [6]: http://www.haskell.org/haddock/ "www.haskell.org/haddock/" + [7]: https://ghc.haskell.org/trac/ghc/wiki/Building/GettingTheSources#GettingaGHCrepositoryfromGitHub + "https://ghc.haskell.org/trac/ghc/wiki/Building/GettingTheSources#GettingaGHCrepositoryfromGitHub" + [8]: http://ghc.haskell.org/trac/ghc/wiki/Building/Preparation + "http://ghc.haskell.org/trac/ghc/wiki/Building/Preparation" + [9]: http://www.haskell.org/cabal/ "http://www.haskell.org/cabal/" + [10]: http://ghc.haskell.org/trac/ghc/ + "http://ghc.haskell.org/trac/ghc/" + [11]: http://www.haskell.org/pipermail/glasgow-haskell-users/ + "http://www.haskell.org/pipermail/glasgow-haskell-users/" + [12]: http://ghc.haskell.org/trac/ghc/wiki/TeamGHC + "http://ghc.haskell.org/trac/ghc/wiki/TeamGHC" diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..0cbdb604 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +7.10.3 diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 index 00000000..874e1907 --- /dev/null +++ b/aclocal.m4 @@ -0,0 +1,2381 @@ +# Extra autoconf macros for the Glasgow fptools +# +# To be a good autoconf citizen, names of local macros have prefixed with FP_ to +# ensure we don't clash with any pre-supplied autoconf ones. + + +AC_DEFUN([GHC_SELECT_FILE_EXTENSIONS], +[ + $2='' + $3='.so' + case $1 in + *-unknown-cygwin32) + AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) + AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) + exit 1 + ;; + *-unknown-mingw32) + windows=YES + $2='.exe' + $3='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + $3='.dylib' + ;; + x86_64-apple-darwin) + $3='.dylib' + ;; + arm-apple-darwin10|i386-apple-darwin11|aarch64-apple-darwin14) + $2='.a' + $3='.dylib' + ;; + esac +]) + +# FPTOOLS_SET_PLATFORM_VARS +# ---------------------------------- +# Set the platform variables +AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], +[ + # If no argument was given for a configuration variable, then discard + # the guessed canonical system and use the configuration of the + # bootstrapping ghc. If an argument was given, map it from gnu format + # to ghc format. + # + # For why we do it this way, see: #3637, #1717, #2951 + # + # In bindists, we haven't called AC_CANONICAL_{BUILD,HOST,TARGET} + # so this justs uses $bootstrap_target. + + if test "$build_alias" = "" + then + if test "$bootstrap_target" != "" + then + build=$bootstrap_target + echo "Build platform inferred as: $build" + else + echo "Can't work out build platform" + exit 1 + fi + + BuildArch=`echo "$build" | sed 's/-.*//'` + BuildVendor=`echo "$build" | sed -e 's/.*-\(.*\)-.*/\1/'` + BuildOS=`echo "$build" | sed 's/.*-//'` + else + GHC_CONVERT_CPU([$build_cpu], [BuildArch]) + GHC_CONVERT_VENDOR([$build_vendor], [BuildVendor]) + GHC_CONVERT_OS([$build_os], [$BuildArch], [BuildOS]) + fi + + if test "$host_alias" = "" + then + if test "$bootstrap_target" != "" + then + host=$bootstrap_target + echo "Host platform inferred as: $host" + else + echo "Can't work out host platform" + exit 1 + fi + + HostArch=`echo "$host" | sed 's/-.*//'` + HostVendor=`echo "$host" | sed -e 's/.*-\(.*\)-.*/\1/'` + HostOS=`echo "$host" | sed 's/.*-//'` + else + GHC_CONVERT_CPU([$host_cpu], [HostArch]) + GHC_CONVERT_VENDOR([$host_vendor], [HostVendor]) + GHC_CONVERT_OS([$host_os], [$HostArch], [HostOS]) + fi + + if test "$target_alias" = "" + then + if test "$host_alias" != "" + then + GHC_CONVERT_CPU([$host_cpu], [TargetArch]) + GHC_CONVERT_VENDOR([$host_vendor], [TargetVendor]) + GHC_CONVERT_OS([$host_os], [$TargetArch],[TargetOS]) + else + if test "$bootstrap_target" != "" + then + target=$bootstrap_target + echo "Target platform inferred as: $target" + else + echo "Can't work out target platform" + exit 1 + fi + + TargetArch=`echo "$target" | sed 's/-.*//'` + TargetVendor=`echo "$target" | sed -e 's/.*-\(.*\)-.*/\1/'` + TargetOS=`echo "$target" | sed 's/.*-//'` + fi + else + GHC_CONVERT_CPU([$target_cpu], [TargetArch]) + GHC_CONVERT_VENDOR([$target_vendor], [TargetVendor]) + GHC_CONVERT_OS([$target_os], [$TargetArch], [TargetOS]) + fi + + GHC_SELECT_FILE_EXTENSIONS([$host], [exeext_host], [soext_host]) + GHC_SELECT_FILE_EXTENSIONS([$target], [exeext_target], [soext_target]) + windows=NO + case $host in + *-unknown-mingw32) + windows=YES + ;; + esac + + BuildPlatform="$BuildArch-$BuildVendor-$BuildOS" + BuildPlatform_CPP=`echo "$BuildPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildArch_CPP=` echo "$BuildArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildVendor_CPP=` echo "$BuildVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildOS_CPP=` echo "$BuildOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + HostPlatform="$HostArch-$HostVendor-$HostOS" + HostPlatform_CPP=`echo "$HostPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostArch_CPP=` echo "$HostArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostVendor_CPP=` echo "$HostVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostOS_CPP=` echo "$HostOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + TargetPlatform="$TargetArch-$TargetVendor-$TargetOS" + TargetPlatform_CPP=`echo "$TargetPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetArch_CPP=` echo "$TargetArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetVendor_CPP=` echo "$TargetVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetOS_CPP=` echo "$TargetOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + echo "GHC build : $BuildPlatform" + echo "GHC host : $HostPlatform" + echo "GHC target : $TargetPlatform" + + AC_SUBST(BuildPlatform) + AC_SUBST(HostPlatform) + AC_SUBST(TargetPlatform) + AC_SUBST(HostPlatform_CPP) + AC_SUBST(BuildPlatform_CPP) + AC_SUBST(TargetPlatform_CPP) + + AC_SUBST(HostArch_CPP) + AC_SUBST(BuildArch_CPP) + AC_SUBST(TargetArch_CPP) + + AC_SUBST(HostOS_CPP) + AC_SUBST(BuildOS_CPP) + AC_SUBST(TargetOS_CPP) + + AC_SUBST(HostVendor_CPP) + AC_SUBST(BuildVendor_CPP) + AC_SUBST(TargetVendor_CPP) + + AC_SUBST(exeext_host) + AC_SUBST(exeext_target) + AC_SUBST(soext_host) + AC_SUBST(soext_target) +]) + + +# FPTOOLS_SET_HASKELL_PLATFORM_VARS +# ---------------------------------- +# Set the Haskell platform variables +AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], +[ + checkArch() { + case [$]1 in + i386) + test -z "[$]2" || eval "[$]2=ArchX86" + ;; + x86_64|amd64) + test -z "[$]2" || eval "[$]2=ArchX86_64" + ;; + powerpc) + test -z "[$]2" || eval "[$]2=ArchPPC" + ;; + powerpc64) + test -z "[$]2" || eval "[$]2=ArchPPC_64" + ;; + sparc) + test -z "[$]2" || eval "[$]2=ArchSPARC" + ;; + arm) + GET_ARM_ISA() + test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT, armABI = \$ARM_ABI}\"" + ;; + aarch64) + test -z "[$]2" || eval "[$]2=ArchARM64" + ;; + alpha) + test -z "[$]2" || eval "[$]2=ArchAlpha" + ;; + mips|mipseb) + test -z "[$]2" || eval "[$]2=ArchMipseb" + ;; + mipsel) + test -z "[$]2" || eval "[$]2=ArchMipsel" + ;; + hppa|hppa1_1|ia64|m68k|powerpc64le|rs6000|s390|s390x|sparc64|vax) + test -z "[$]2" || eval "[$]2=ArchUnknown" + ;; + *) + echo "Unknown arch [$]1" + exit 1 + ;; + esac + } + + checkVendor() { + case [$]1 in + dec|unknown|hp|apple|next|sun|sgi|ibm|montavista|portbld) + ;; + *) + echo "Unknown vendor [$]1" + exit 1 + ;; + esac + } + + checkOS() { + case [$]1 in + linux) + test -z "[$]2" || eval "[$]2=OSLinux" + ;; + ios) + test -z "[$]2" || eval "[$]2=OSiOS" + ;; + darwin) + test -z "[$]2" || eval "[$]2=OSDarwin" + ;; + solaris2) + test -z "[$]2" || eval "[$]2=OSSolaris2" + ;; + mingw32) + test -z "[$]2" || eval "[$]2=OSMinGW32" + ;; + freebsd) + test -z "[$]2" || eval "[$]2=OSFreeBSD" + ;; + dragonfly) + test -z "[$]2" || eval "[$]2=OSDragonFly" + ;; + kfreebsdgnu) + test -z "[$]2" || eval "[$]2=OSKFreeBSD" + ;; + openbsd) + test -z "[$]2" || eval "[$]2=OSOpenBSD" + ;; + netbsd) + test -z "[$]2" || eval "[$]2=OSNetBSD" + ;; + haiku) + test -z "[$]2" || eval "[$]2=OSHaiku" + ;; + osf3) + test -z "[$]2" || eval "[$]2=OSOsf3" + ;; + nto-qnx) + test -z "[$]2" || eval "[$]2=OSQNXNTO" + ;; + dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) + test -z "[$]2" || eval "[$]2=OSUnknown" + ;; + linux-android) + test -z "[$]2" || eval "[$]2=OSAndroid" + ;; + *) + echo "Unknown OS '[$]1'" + exit 1 + ;; + esac + } + + dnl ** check for Apple-style dead-stripping support + dnl (.subsections-via-symbols assembler directive) + + AC_MSG_CHECKING(for .subsections_via_symbols) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [__asm__ (".subsections_via_symbols");])], + [AC_MSG_RESULT(yes) + HaskellHaveSubsectionsViaSymbols=True + AC_DEFINE([HAVE_SUBSECTIONS_VIA_SYMBOLS],[1], + [Define to 1 if Apple-style dead-stripping is supported.]) + ], + [HaskellHaveSubsectionsViaSymbols=False + AC_MSG_RESULT(no)]) + + dnl ** check for .ident assembler directive + + AC_MSG_CHECKING(whether your assembler supports .ident directive) + AC_COMPILE_IFELSE( + [AC_LANG_SOURCE([__asm__ (".ident \"GHC x.y.z\"");])], + [AC_MSG_RESULT(yes) + HaskellHaveIdentDirective=True], + [AC_MSG_RESULT(no) + HaskellHaveIdentDirective=False]) + + dnl *** check for GNU non-executable stack note support (ELF only) + dnl (.section .note.GNU-stack,"",@progbits) + + dnl This test doesn't work with "gcc -g" in gcc 4.4 (GHC trac #3889: + dnl Error: can't resolve `.note.GNU-stack' {.note.GNU-stack section} - `.Ltext0' {.text section} + dnl so we empty CFLAGS while running this test + CFLAGS2="$CFLAGS" + CFLAGS= + AC_MSG_CHECKING(for GNU non-executable stack support) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([__asm__ (".section .note.GNU-stack,\"\",@progbits");], [0])], + [AC_MSG_RESULT(yes) + HaskellHaveGnuNonexecStack=True], + [AC_MSG_RESULT(no) + HaskellHaveGnuNonexecStack=False]) + CFLAGS="$CFLAGS2" + + checkArch "$BuildArch" "HaskellBuildArch" + checkVendor "$BuildVendor" + checkOS "$BuildOS" "" + + checkArch "$HostArch" "HaskellHostArch" + checkVendor "$HostVendor" + checkOS "$HostOS" "" + + checkArch "$TargetArch" "HaskellTargetArch" + checkVendor "$TargetVendor" + checkOS "$TargetOS" "HaskellTargetOs" + + AC_SUBST(HaskellTargetArch) + AC_SUBST(HaskellTargetOs) + AC_SUBST(HaskellHaveSubsectionsViaSymbols) + AC_SUBST(HaskellHaveIdentDirective) + AC_SUBST(HaskellHaveGnuNonexecStack) +]) + + +# GET_ARM_ISA +# ---------------------------------- +# Get info about the ISA on the ARM arch +AC_DEFUN([GET_ARM_ISA], +[ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM( + [], + [#if defined(__ARM_ARCH_2__) || \ + defined(__ARM_ARCH_3__) || \ + defined(__ARM_ARCH_3M__) || \ + defined(__ARM_ARCH_4__) || \ + defined(__ARM_ARCH_4T__) || \ + defined(__ARM_ARCH_5__) || \ + defined(__ARM_ARCH_5T__) || \ + defined(__ARM_ARCH_5E__) || \ + defined(__ARM_ARCH_5TE__) + return 0; + #else + not pre arm v6 + #endif] + )], + [AC_DEFINE(arm_HOST_ARCH_PRE_ARMv6, 1, [ARM pre v6]) + AC_DEFINE(arm_HOST_ARCH_PRE_ARMv7, 1, [ARM pre v7]) + changequote(, )dnl + ARM_ISA=ARMv5 + ARM_ISA_EXT="[]" + changequote([, ])dnl + ], + [ + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM( + [], + [#if defined(__ARM_ARCH_6__) || \ + defined(__ARM_ARCH_6J__) || \ + defined(__ARM_ARCH_6T2__) || \ + defined(__ARM_ARCH_6Z__) || \ + defined(__ARM_ARCH_6ZK__) || \ + defined(__ARM_ARCH_6M__) + return 0; + #else + not pre arm v7 + #endif] + )], + [AC_DEFINE(arm_HOST_ARCH_PRE_ARMv7, 1, [ARM pre v7]) + ARM_ISA=ARMv6 + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM( + [], + [#if defined(__VFP_FP__) + return 0; + #else + no vfp + #endif] + )], + [changequote(, )dnl + ARM_ISA_EXT="[VFPv2]" + changequote([, ])dnl + ], + [changequote(, )dnl + ARM_ISA_EXT="[]" + changequote([, ])dnl + ] + )], + [changequote(, )dnl + ARM_ISA=ARMv7 + ARM_ISA_EXT="[VFPv3,NEON]" + changequote([, ])dnl + ]) + ]) + + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [], + [#if defined(__SOFTFP__) + return 0; + #else + not softfp + #endif] + )], + [changequote(, )dnl + ARM_ABI="SOFT" + changequote([, ])dnl + ], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [], + [#if defined(__ARM_PCS_VFP) + return 0; + #else + no hard float ABI + #endif] + )], + [ARM_ABI="HARD"], + [ARM_ABI="SOFTFP"] + )] + ) +]) + + +# FP_SETTINGS +# ---------------------------------- +# Set the variables used in the settings file +AC_DEFUN([FP_SETTINGS], +[ + if test "$windows" = YES + then + mingw_bin_prefix=mingw/bin/ + SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPFlags="$HaskellCPPArgs" + SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe" + SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe" + SettingsPerlCommand='$topdir/../perl/perl.exe' + SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe" + SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe" + SettingsTouchCommand='$topdir/touchy.exe' + else + SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsHaskellCPPCommand="$HaskellCPPCmd" + SettingsHaskellCPPFlags="$HaskellCPPArgs" + SettingsLdCommand="$LdCmd" + SettingsArCommand="$ArCmd" + SettingsPerlCommand="$PerlCmd" + SettingsDllWrapCommand="/bin/false" + SettingsWindresCommand="/bin/false" + SettingsLibtoolCommand="libtool" + SettingsReadElfCommand="$ReadElfCmd" + SettingsTouchCommand='touch' + fi + if test -z "$LlcCmd" + then + SettingsLlcCommand="llc" + else + SettingsLlcCommand="$LlcCmd" + fi + if test -z "$OptCmd" + then + SettingsOptCommand="opt" + else + SettingsOptCommand="$OptCmd" + fi + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" + SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2" + AC_SUBST(SettingsCCompilerCommand) + AC_SUBST(SettingsHaskellCPPCommand) + AC_SUBST(SettingsHaskellCPPFlags) + AC_SUBST(SettingsCCompilerFlags) + AC_SUBST(SettingsCCompilerLinkFlags) + AC_SUBST(SettingsLdCommand) + AC_SUBST(SettingsLdFlags) + AC_SUBST(SettingsArCommand) + AC_SUBST(SettingsPerlCommand) + AC_SUBST(SettingsDllWrapCommand) + AC_SUBST(SettingsWindresCommand) + AC_SUBST(SettingsLibtoolCommand) + AC_SUBST(SettingsReadElfCommand) + AC_SUBST(SettingsTouchCommand) + AC_SUBST(SettingsLlcCommand) + AC_SUBST(SettingsOptCommand) +]) + + +# FPTOOLS_SET_C_LD_FLAGS +# ---------------------------------- +# Set the C, LD and CPP flags for a given platform +# $1 is the platform +# $2 is the name of the CC flags variable +# $3 is the name of the linker flags variable when linking with gcc +# $4 is the name of the linker flags variable when linking with ld +# $5 is the name of the CPP flags variable +AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], +[ + AC_MSG_CHECKING([Setting up $2, $3, $4 and $5]) + case $$1 in + i386-*) + # Workaround for #7799 + $2="$$2 -U__i686" + ;; + esac + + case $$1 in + i386-unknown-mingw32) + $2="$$2 -march=i686" + ;; + i386-portbld-freebsd*) + $2="$$2 -march=i686" + ;; + i386-apple-darwin) + $2="$$2 -m32" + $3="$$3 -m32" + $4="$$4 -arch i386" + $5="$$5 -m32" + ;; + x86_64-apple-darwin) + $2="$$2 -m64" + $3="$$3 -m64" + $4="$$4 -arch x86_64" + $5="$$5 -m64" + ;; + x86_64-unknown-solaris2) + $2="$$2 -m64" + $3="$$3 -m64" + $4="$$4 -m64" + $5="$$5 -m64" + ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + $2="$$2 -w -mieee -D_REENTRANT" + $3="$$3 -w -mieee -D_REENTRANT" + $5="$$5 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + $2="$$2 -D_HPUX_SOURCE" + $3="$$3 -D_HPUX_SOURCE" + $5="$$5 -D_HPUX_SOURCE" + ;; + arm*linux*) + # On arm/linux and arm/android, tell gcc to generate Arm + # instructions (ie not Thumb) and to link using the gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + $2="$$2 -marm" + $3="$$3 -fuse-ld=gold -Wl,-z,noexecstack" + $4="$$4 -z noexecstack" + ;; + + aarch64*linux*) + # On aarch64/linux and aarch64/android, tell gcc to link using the + # gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + $3="$$3 -fuse-ld=gold -Wl,-z,noexecstack" + $4="$$4 -z noexecstack" + ;; + esac + + # If gcc knows about the stack protector, turn it off. + # Otherwise the stack-smash handler gets triggered. + echo 'int main(void) {return 0;}' > conftest.c + if $CC -c conftest.c -fno-stack-protector > /dev/null 2>&1 + then + $2="$$2 -fno-stack-protector" + fi + + rm -f conftest.c conftest.o + AC_MSG_RESULT([done]) +]) + + +AC_DEFUN([FP_PATH_PROG],[ + AC_PATH_PROG($1,$2,$3,$4,$5,$6) + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${$1}" != "" + then + # Canonicalise to :/path/to/gcc + $1=`cygpath -m "${$1}"` + fi +]) + + +# FP_VISIBILITY_HIDDEN +# ---------------------------------- +# Is the visibility hidden attribute supported? +AC_DEFUN([FP_VISIBILITY_HIDDEN], +[ + AC_MSG_CHECKING([whether __attribute__((visibility("hidden"))) is supported]) + echo '__attribute__((visibility("hidden"))) void foo(void) {}' > conftest.c + if $CC -Wall -Werror -c conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + AC_DEFINE(HAS_VISIBILITY_HIDDEN, 1, [Has visibility hidden]) + else + AC_MSG_RESULT([no]) + fi + rm -f conftest.c conftest.o +]) + + +# FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN +# ---------------------------------- +# Little endian ARM on Linux with some ABIs has big endian word order +# in doubles. Define FLOAT_WORDS_BIGENDIAN if this is the case. +AC_DEFUN([FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN], + [AC_CACHE_CHECK([whether float word order is big endian], [fptools_cv_float_word_order_bigendian], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [#include ], + [#if defined(__FLOAT_WORD_ORDER) && __FLOAT_WORD_ORDER == BIG_ENDIAN + return 0; + #else + not float word order big endian + #endif] + )], + [fptools_cv_float_word_order_bigendian=yes], + [fptools_cv_float_word_order_bigendian=no]) + ]) + case $fptools_cv_float_word_order_bigendian in + yes) + AC_DEFINE([FLOAT_WORDS_BIGENDIAN], 1, + [Define to 1 if your processor stores words of floats with + the most significant byte first]) ;; + esac +]) + + +# FP_ARG_WITH_PATH_GNU_PROG_GENERAL +# -------------------- +# Find the specified command on the path or allow a user to set it manually +# with a --with- option. +# +# This is ignored on the mingw32 platform. +# +# $1 = the variable to set +# $2 = the with option name +# $3 = the command to look for +# $4 = prepend target to program name? if 'no', use the name unchanged +# $5 = optional? if 'no', then raise an error if the command isn't found +# +AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG_GENERAL], +[ +AC_ARG_WITH($2, +[AC_HELP_STRING([--with-$2=ARG], + [Use ARG as the path to $2 [default=autodetect]])], +[ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + $1=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_$2=$withval +], +[ + if test "$HostOS" != "mingw32" + then + if test "$4" = "no" -o "$target_alias" = "" ; then + AC_PATH_PROG([$1], [$3]) + else + AC_PATH_PROG([$1], [$target_alias-$3]) + fi + if test "$5" = "no" -a -z "$$1" + then + AC_MSG_ERROR([cannot find $3 in your PATH]) + fi + fi +] +) +]) # FP_ARG_WITH_PATH_GNU_PROG_GENERAL + + +# FP_ARG_WITH_PATH_GNU_PROG +# -------------------- +# The usual case: prepend the target, and the program is not optional. +AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG], +[FP_ARG_WITH_PATH_GNU_PROG_GENERAL([$1], [$2], [$3], [yes], [no])]) + +# FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL +# -------------------- +# Same as FP_ARG_WITH_PATH_GNU_PROG but no error will be thrown if the command +# isn't found. +AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL], +[FP_ARG_WITH_PATH_GNU_PROG_GENERAL([$1], [$2], [$3], [yes], [yes])]) + +# FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET +# -------------------- +# Same as FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL but don't prepend the target name +# (used for LLVM). +AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET], +[FP_ARG_WITH_PATH_GNU_PROG_GENERAL([$1], [$2], [$3], [no], [yes])]) + + +# FP_PROG_CONTEXT_DIFF +# -------------------- +# Figure out how to do context diffs. Sets the output variable ContextDiffCmd. +# +# Note: NeXTStep thinks diff'ing a file against itself is "trouble". +AC_DEFUN([FP_PROG_CONTEXT_DIFF], +[AC_CACHE_CHECK([for a working context diff], [fp_cv_context_diff], +[echo foo > conftest1 +echo foo > conftest2 +fp_cv_context_diff=no +for fp_var in '-U 1' '-u1' '-C 1' '-c1' +do + if diff $fp_var conftest1 conftest2 > /dev/null 2>&1; then + fp_cv_context_diff="diff $fp_var" + break + fi +done]) +if test x"$fp_cv_context_diff" = xno; then + AC_MSG_ERROR([cannot figure out how to do context diffs]) +fi +AC_SUBST(ContextDiffCmd, [$fp_cv_context_diff]) +])# FP_PROG_CONTEXT_DIFF + + +# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS) +# -------------------------------------------------------- +# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for +# compilation. Execute IF-FAILS when unable to determine the value. Works for +# cross-compilation, too. +# +# Implementation note: We are lazy and use an internal autoconf macro, but it +# is supported in autoconf versions 2.50 up to the actual 2.57, so there is +# little risk. +AC_DEFUN([FP_COMPUTE_INT], +[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl +])# FP_COMPUTE_INT + + +# FP_CHECK_ALIGNMENT(TYPE, [IGNORED], [INCLUDES = DEFAULT-INCLUDES]) +# ------------------------------------------------------------------ +# A variation of AC_CHECK_SIZEOF for computing the alignment restrictions of a +# given type. Defines ALIGNMENT_TYPE. +AC_DEFUN([FP_CHECK_ALIGNMENT], +[AS_LITERAL_IF(m4_translit([[$1]], [*], [p]), [], + [AC_FATAL([$0: requires literal arguments])])[]dnl +AC_CHECK_TYPE([$1], [], [], [$3])[]dnl +m4_pushdef([fp_Cache], [AS_TR_SH([fp_cv_alignment_$1])])[]dnl +AC_CACHE_CHECK([alignment of $1], [fp_Cache], +[if test "$AS_TR_SH([ac_cv_type_$1])" = yes; then + FP_COMPUTE_INT([offsetof(struct { char c; $1 ty; },ty)], + [fp_Cache], + [AC_INCLUDES_DEFAULT([$3])], + [AC_MSG_ERROR([cannot compute alignment ($1) +See `config.log' for more details.], [77])]) +else + fp_Cache=0 +fi])[]dnl +AC_DEFINE_UNQUOTED(AS_TR_CPP(alignment_$1), $fp_Cache, [The alignment of a `$1'.])[]dnl +m4_popdef([fp_Cache])[]dnl +])# FP_CHECK_ALIGNMENT + + +# FP_LEADING_UNDERSCORE +# --------------------- +# Test for determining whether symbol names have a leading underscore. We assume +# that they _haven't_ if anything goes wrong. Sets the output variable +# LeadingUnderscore to YES or NO and defines LEADING_UNDERSCORE correspondingly. +# +# Some nlist implementations seem to try to be compatible by ignoring a leading +# underscore sometimes (eg. FreeBSD). We therefore have to work around this by +# checking for *no* leading underscore first. Sigh. --SDM +# +# Similarly on OpenBSD, but this test doesn't help. -- dons +AC_DEFUN([FP_LEADING_UNDERSCORE], +[AC_CHECK_LIB([elf], [nlist], [LIBS="-lelf $LIBS"]) +AC_CACHE_CHECK([leading underscore in symbol names], [fptools_cv_leading_underscore], [ +# Hack!: nlist() under Digital UNIX insist on there being an _, +# but symbol table listings shows none. What is going on here?!? +# +# Another hack: cygwin doesn't come with nlist.h , so we hardwire +# the underscoredness of that "platform" +case $HostPlatform in +*openbsd*) # x86 openbsd is ELF from 3.4 >, meaning no leading uscore + case $build in + i386-*2\.@<:@0-9@:>@ | i386-*3\.@<:@0-3@:>@ ) fptools_cv_leading_underscore=yes ;; + *) fptools_cv_leading_underscore=no ;; + esac ;; +alpha-dec-osf*) fptools_cv_leading_underscore=no;; +*cygwin32) fptools_cv_leading_underscore=yes;; +i386-unknown-mingw32) fptools_cv_leading_underscore=yes;; +x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;; + + # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries +x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; +*-apple-ios) fptools_cv_leading_underscore=yes;; + +*) AC_RUN_IFELSE([AC_LANG_SOURCE([[#ifdef HAVE_NLIST_H +#include +struct nlist xYzzY1[] = {{"xYzzY1", 0},{0}}; +struct nlist xYzzY2[] = {{"_xYzzY2", 0},{0}}; +#endif + +int main(argc, argv) +int argc; +char **argv; +{ +#ifdef HAVE_NLIST_H + if(nlist(argv[0], xYzzY1) == 0 && xYzzY1[0].n_value != 0) + exit(1); + if(nlist(argv[0], xYzzY2) == 0 && xYzzY2[0].n_value != 0) + exit(0); +#endif + exit(1); +}]])],[fptools_cv_leading_underscore=yes],[fptools_cv_leading_underscore=no],[fptools_cv_leading_underscore=no]) +;; +esac]); +AC_SUBST([LeadingUnderscore], [`echo $fptools_cv_leading_underscore | sed 'y/yesno/YESNO/'`]) +if test x"$fptools_cv_leading_underscore" = xyes; then + AC_DEFINE([LEADING_UNDERSCORE], [1], [Define to 1 if C symbols have a leading underscore added by the compiler.]) +fi])# FP_LEADING_UNDERSCORE + + +# FP_COMPARE_VERSIONS(VERSION1, TEST, VERSION2, [ACTION-IF-TRUE], [ACTION-IF-FALSE]) +# ---------------------------------------------------------------------------------- +# Compare dotted version numbers VERSION1 and VERSION2 lexicographically according +# to TEST (one of -eq, -ne, -lt, -le, -gt, or -ge). +AC_DEFUN([FP_COMPARE_VERSIONS], +[fp_version1=$1; fp_version2=$3 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $[@%:@] = 0 || { fp_num1="[$]1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="[$]*" + + set dummy $fp_version2; shift + fp_num2="" + test $[@%:@] = 0 || { fp_num2="[$]1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="[$]*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +AS_IF([test "$fp_num1" $2 "$fp_num2"], [$4], [$5])[]dnl +])# FP_COMPARE_VERSIONS + + +dnl +dnl Check for Happy and version. If we're building GHC, then we need +dnl at least Happy version 1.19. If there's no installed Happy, we look +dnl for a happy source tree and point the build system at that instead. +dnl +AC_DEFUN([FPTOOLS_HAPPY], +[FP_PATH_PROG(HappyCmd,happy,) + +AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version, +changequote(, )dnl +[if test x"$HappyCmd" != x; then + fptools_cv_happy_version=`"$HappyCmd" -v | + grep 'Happy Version' | sed -e 's/Happy Version \([^ ]*\).*/\1/g'` ; +else + fptools_cv_happy_version=""; +fi; +changequote([, ])dnl +]) +if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs +then + FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.4], + [AC_MSG_ERROR([Happy version 1.19.4 or later is required to compile GHC.])])[] +fi +HappyVersion=$fptools_cv_happy_version; +AC_SUBST(HappyVersion) +]) + +dnl +dnl Check for Alex and version. If we're building GHC, then we need +dnl at least Alex version 2.1.1. +dnl +AC_DEFUN([FPTOOLS_ALEX], +[ +FP_PATH_PROG(AlexCmd,alex,) + +AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, +changequote(, )dnl +[if test x"$AlexCmd" != x; then + fptools_cv_alex_version=`"$AlexCmd" -v | + grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; +else + fptools_cv_alex_version=""; +fi; +changequote([, ])dnl +]) +FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-ge],[3.0], + [Alex3=YES],[Alex3=NO]) +if test ! -f compiler/cmm/CmmLex.hs || test ! -f compiler/parser/Lexer.hs +then + FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[3.1.0], + [AC_MSG_ERROR([Alex version 3.1.0 or later is required to compile GHC.])])[] +fi +AlexVersion=$fptools_cv_alex_version; +AC_SUBST(AlexVersion) +AC_SUBST(Alex3) +]) + + +# FP_PROG_LD_FLAG +# --------------- +# Sets the output variable $2 to $1 if ld supports the $1 flag. +# Otherwise the variable's value is empty. +AC_DEFUN([FP_PROG_LD_FLAG], +[ +AC_CACHE_CHECK([whether ld understands $1], [fp_cv_$2], +[echo 'int foo() { return 0; }' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r $1 -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_$2=$1 +else + fp_cv_$2= +fi +rm -rf conftest*]) +$2=$fp_cv_$2 +])# FP_PROG_LD_FLAG + + +# FP_PROG_LD_BUILD_ID +# ------------ + +# Sets the output variable LdHasBuildId to YES if ld supports +# --build-id, or NO otherwise. +AC_DEFUN([FP_PROG_LD_BUILD_ID], +[ +AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id], +[echo 'int foo() { return 0; }' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi +AC_SUBST([LdHasBuildId]) +])# FP_PROG_LD_BUILD_ID + + +# FP_PROG_LD_IS_GNU +# ----------------- +# Sets the output variable LdIsGNULd to YES or NO, depending on whether it is +# GNU ld or not. +AC_DEFUN([FP_PROG_LD_IS_GNU], +[ +AC_CACHE_CHECK([whether ld is GNU ld], [fp_cv_gnu_ld], +[if ${LdCmd} --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then + fp_cv_gnu_ld=yes +else + fp_cv_gnu_ld=no +fi]) +AC_SUBST([LdIsGNULd], [`echo $fp_cv_gnu_ld | sed 'y/yesno/YESNO/'`]) +])# FP_PROG_LD_IS_GNU + + +# FP_PROG_LD_NO_COMPACT_UNWIND +# ---------------------------- + +# Sets the output variable LdHasNoCompactUnwind to YES if ld supports +# -no_compact_unwind, or NO otherwise. +AC_DEFUN([FP_PROG_LD_NO_COMPACT_UNWIND], +[ +AC_CACHE_CHECK([whether ld understands -no_compact_unwind], [fp_cv_ld_no_compact_unwind], +[echo 'int foo() { return 0; }' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r -no_compact_unwind -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_no_compact_unwind=yes +else + fp_cv_ld_no_compact_unwind=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_no_compact_unwind" = yes; then + LdHasNoCompactUnwind=YES +else + LdHasNoCompactUnwind=NO +fi +AC_SUBST([LdHasNoCompactUnwind]) +])# FP_PROG_LD_NO_COMPACT_UNWIND + + +# FP_PROG_LD_FILELIST +# ------------------- + +# Sets the output variable LdHasFilelist to YES if ld supports +# -filelist, or NO otherwise. +AC_DEFUN([FP_PROG_LD_FILELIST], +[ +AC_CACHE_CHECK([whether ld understands -filelist], [fp_cv_ld_has_filelist], +[ + echo 'int foo() { return 0; }' > conftest1.c + echo 'int bar() { return 0; }' > conftest2.c + ${CC-cc} -c conftest1.c + ${CC-cc} -c conftest2.c + echo conftest1.o > conftest.o-files + echo conftest2.o >> conftest.o-files + if ${LdCmd} -r -filelist conftest.o-files -o conftest.o > /dev/null 2>&1 + then + fp_cv_ld_has_filelist=yes + else + fp_cv_ld_has_filelist=no + fi + rm -rf conftest* +]) +if test "$fp_cv_ld_has_filelist" = yes; then + LdHasFilelist=YES +else + LdHasFilelist=NO +fi +AC_SUBST([LdHasFilelist]) +])# FP_PROG_LD_FILELIST + + +# FP_PROG_AR +# ---------- +# Sets fp_prog_ar to a (non-Cygwin) path to ar. Exits if no ar can be found +AC_DEFUN([FP_PROG_AR], +[FP_PATH_PROG([fp_prog_ar], [ar]) +if test -z "$fp_prog_ar"; then + AC_MSG_ERROR([cannot find ar in your PATH, no idea how to make a library]) +fi +])# FP_PROG_AR + + +# FP_PROG_AR_IS_GNU +# ----------------- +# Sets fp_prog_ar_is_gnu to yes or no, depending on whether it is GNU ar or not. +AC_DEFUN([FP_PROG_AR_IS_GNU], +[AC_REQUIRE([FP_PROG_AR]) +AC_CACHE_CHECK([whether $fp_prog_ar is GNU ar], [fp_cv_prog_ar_is_gnu], +[if "$fp_prog_ar" --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then + fp_cv_prog_ar_is_gnu=yes +else + fp_cv_prog_ar_is_gnu=no +fi]) +fp_prog_ar_is_gnu=$fp_cv_prog_ar_is_gnu +AC_SUBST([ArIsGNUAr], [`echo $fp_prog_ar_is_gnu | tr 'a-z' 'A-Z'`]) +])# FP_PROG_AR_IS_GNU + + +# FP_PROG_AR_SUPPORTS_ATFILE +# ----------------- +# Sets fp_prog_ar_supports_atfile to yes or no, depending on whether +# or not it supports the @file syntax +AC_DEFUN([FP_PROG_AR_SUPPORTS_ATFILE], +[AC_REQUIRE([FP_PROG_AR]) + AC_REQUIRE([FP_PROG_AR_ARGS]) +AC_CACHE_CHECK([whether $fp_prog_ar supports @file], [fp_cv_prog_ar_supports_atfile], +[ +rm -f conftest* +touch conftest.file +echo conftest.file > conftest.atfile +echo conftest.file >> conftest.atfile +"$fp_prog_ar" $fp_prog_ar_args conftest.a @conftest.atfile > /dev/null 2>&1 +fp_prog_ar_supports_atfile_tmp=`"$fp_prog_ar" t conftest.a 2> /dev/null | grep -c conftest.file` +rm -f conftest* +if test "$fp_prog_ar_supports_atfile_tmp" -eq 2 +then + fp_cv_prog_ar_supports_atfile=yes +else + fp_cv_prog_ar_supports_atfile=no +fi]) +fp_prog_ar_supports_atfile=$fp_cv_prog_ar_supports_atfile +AC_SUBST([ArSupportsAtFile], [`echo $fp_prog_ar_supports_atfile | tr 'a-z' 'A-Z'`]) +])# FP_PROG_AR_SUPPORTS_ATFILE + +# FP_PROG_AR_ARGS +# --------------- +# Sets fp_prog_ar_args to the arguments for ar and the output variable ArCmd +# to a non-Cygwin invocation of ar including these arguments. +AC_DEFUN([FP_PROG_AR_ARGS], +[AC_REQUIRE([FP_PROG_AR_IS_GNU]) +AC_CACHE_CHECK([for ar arguments], [fp_cv_prog_ar_args], +[ +# GNU ar needs special treatment: it appears to have problems with +# object files with the same name if you use the 's' modifier, but +# simple 'ar q' works fine, and doesn't need a separate ranlib. +if test $fp_prog_ar_is_gnu = yes; then + fp_cv_prog_ar_args="q" +else + touch conftest.dummy + for fp_var in clqsZ clqs cqs clq cq ; do + rm -f conftest.a + if "$fp_prog_ar" $fp_var conftest.a conftest.dummy > /dev/null 2> /dev/null; then + fp_cv_prog_ar_args=$fp_var + break + fi + done + rm -f conftest* + if test -z "$fp_cv_prog_ar_args"; then + AC_MSG_ERROR([cannot figure out how to use your $fp_prog_ar]) + fi +fi]) +fp_prog_ar_args=$fp_cv_prog_ar_args +AC_SUBST([ArCmd], ["$fp_prog_ar"]) +AC_SUBST([ArArgs], ["$fp_prog_ar_args"]) + +])# FP_PROG_AR_ARGS + + +# FP_PROG_AR_NEEDS_RANLIB +# ----------------------- +# Sets the output variable RANLIB_CMD to "ranlib" if it is needed and +# found, to "true" otherwise. Sets REAL_RANLIB_CMD to the ranlib program, +# even if we don't need ranlib (libffi might still need it). +AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],[ + AC_REQUIRE([FP_PROG_AR_IS_GNU]) + AC_REQUIRE([FP_PROG_AR_ARGS]) + AC_REQUIRE([AC_PROG_CC]) + + AC_PROG_RANLIB + + if test $fp_prog_ar_is_gnu = yes + then + fp_cv_prog_ar_needs_ranlib=no + elif test "$TargetOS_CPP" = "darwin" + then + # It's quite tedious to check for Apple's crazy timestamps in + # .a files, so we hardcode it. + fp_cv_prog_ar_needs_ranlib=yes + else + case $fp_prog_ar_args in + *s*) + fp_cv_prog_ar_needs_ranlib=no;; + *) + fp_cv_prog_ar_needs_ranlib=yes;; + esac + fi + + # workaround for AC_PROG_RANLIB which sets RANLIB to `:' when + # ranlib is missing on the target OS. The problem is that + # ghc-cabal cannot execute `:' which is a shell built-in but can + # execute `true' which is usually simple program supported by the + # OS. + # Fixes #8795 + if test "$RANLIB" = ":" + then + RANLIB="true" + fi + REAL_RANLIB_CMD="$RANLIB" + if test $fp_cv_prog_ar_needs_ranlib = yes + then + RANLIB_CMD="$RANLIB" + else + RANLIB_CMD="true" + fi + AC_SUBST([REAL_RANLIB_CMD]) + AC_SUBST([RANLIB_CMD]) +])# FP_PROG_AR_NEEDS_RANLIB + + +# FP_GCC_VERSION +# ----------- +# Extra testing of the result AC_PROG_CC, testing the gcc version no. Sets the +# output variable GccVersion. +AC_DEFUN([FP_GCC_VERSION], +[AC_REQUIRE([AC_PROG_CC]) +if test -z "$CC" +then + AC_MSG_ERROR([gcc is required]) +fi +GccLT34=NO +GccLT46=NO +AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], +[ + fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], + [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) + # See #2770: gcc 2.95 doesn't work any more, apparently. There probably + # isn't a very good reason for that, but for now just make configure + # fail. + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6], GccLT46=YES) +]) +AC_SUBST([GccVersion], [$fp_cv_gcc_version]) +AC_SUBST(GccLT34) +AC_SUBST(GccLT46) +])# FP_GCC_VERSION + +dnl Check to see if the C compiler is clang or llvm-gcc +dnl +GccIsClang=NO +AC_DEFUN([FP_CC_LLVM_BACKEND], +[AC_REQUIRE([AC_PROG_CC]) +AC_MSG_CHECKING([whether C compiler is clang]) +$CC -x c /dev/null -dM -E > conftest.txt 2>&1 +if grep "__clang__" conftest.txt >/dev/null 2>&1; then + AC_SUBST([CC_CLANG_BACKEND], [1]) + AC_SUBST([CC_LLVM_BACKEND], [1]) + GccIsClang=YES + AC_MSG_RESULT([yes]) +else + AC_MSG_RESULT([no]) + AC_MSG_CHECKING([whether C compiler has an LLVM back end]) + if grep "__llvm__" conftest.txt >/dev/null 2>&1; then + AC_SUBST([CC_CLANG_BACKEND], [0]) + AC_SUBST([CC_LLVM_BACKEND], [1]) + AC_MSG_RESULT([yes]) + else + AC_SUBST([CC_CLANG_BACKEND], [0]) + AC_SUBST([CC_LLVM_BACKEND], [0]) + AC_MSG_RESULT([no]) + fi +fi +AC_SUBST(GccIsClang) + +rm -f conftest.txt +]) + +dnl Small feature test for perl version. Assumes PerlCmd +dnl contains path to perl binary. +dnl +dnl (Perl versions prior to v5.6 does not contain the string "v5"; +dnl instead they display version strings such as "version 5.005".) +dnl +AC_DEFUN([FPTOOLS_CHECK_PERL_VERSION], +[$PerlCmd -v >conftest.out 2>&1 + if grep "v5" conftest.out >/dev/null 2>&1; then + : + else + AC_MSG_ERROR([your version of perl probably won't work, try upgrading it.]) + fi +rm -fr conftest* +]) + + +# FP_CHECK_PROG(VARIABLE, PROG-TO-CHECK-FOR, +# [VALUE-IF-NOT-FOUND], [PATH], [REJECT]) +# ----------------------------------------------------- +# HACK: A small wrapper around AC_CHECK_PROG, setting VARIABLE to the full path +# of PROG-TO-CHECK-FOR when found. +AC_DEFUN([FP_CHECK_PROG], +[AC_CHECK_PROG([$1], [$2], [$as_dir/$ac_word$ac_exec_ext], [$3], [$4], [$5])][]dnl +)# FP_CHECK_PROC + + +# FP_PROG_FIND +# ------------ +# Find a non-WinDoze version of the "find" utility. +AC_DEFUN([FP_PROG_FIND], +[AC_PATH_PROGS([fp_prog_find], [gfind find], find) +echo foo > conftest.txt +$fp_prog_find conftest.txt -print > conftest.out 2>&1 +if grep '^conftest.txt$' conftest.out > /dev/null 2>&1 ; then + # OK, looks like a real "find". + case $HostPlatform in + *mingw32) + if test x${OSTYPE} != xmsys + then + fp_prog_find="`cygpath --mixed ${fp_prog_find}`" + AC_MSG_NOTICE([normalized find command to $fp_prog_find]) + fi ;; + *) ;; + esac + FindCmd="$fp_prog_find" +else + # Found a poor WinDoze version of "find", ignore it. + AC_MSG_WARN([$fp_prog_find looks like a non-*nix find, ignoring it]) + FP_CHECK_PROG([FindCmd], [find], [], [], [$fp_prog_find]) +fi +rm -f conftest.txt conftest.out +AC_SUBST([FindCmd])[]dnl +])# FP_PROG_FIND + + +# FP_PROG_SORT +# ------------ +# Find a Unix-like sort +AC_DEFUN([FP_PROG_SORT], +[AC_PATH_PROG([fp_prog_sort], [sort]) +echo conwip > conftest.txt +$fp_prog_sort -f conftest.txt > conftest.out 2>&1 +if grep 'conwip' conftest.out > /dev/null 2>&1 ; then + # The goods + SortCmd="$fp_prog_sort" +else + # Summink else..pick next one. + AC_MSG_WARN([$fp_prog_sort looks like a non-*nix sort, ignoring it]) + FP_CHECK_PROG([SortCmd], [sort], [], [], [$fp_prog_sort]) +fi +rm -f conftest.txt conftest.out +AC_SUBST([SortCmd])[]dnl +])# FP_PROG_SORT + + +dnl +dnl FPTOOLS_NOCACHE_CHECK prints a message, then sets the +dnl values of the second argument to the result of running +dnl the commands given by the third. It does not cache its +dnl result, so it is suitable for checks which should be +dnl run every time. +dnl +AC_DEFUN([FPTOOLS_NOCACHE_CHECK], +[AC_MSG_CHECKING([$1]) + $3 + AC_MSG_RESULT([$][$2]) +]) + +dnl +dnl FPTOOLS_GHC_VERSION(version) +dnl FPTOOLS_GHC_VERSION(major, minor [, patchlevel]) +dnl FPTOOLS_GHC_VERSION(version, major, minor, patchlevel) +dnl +dnl Test for version of installed ghc. Uses $GHC. +dnl [original version pinched from c2hs] +dnl +AC_DEFUN([FPTOOLS_GHC_VERSION], +[FPTOOLS_NOCACHE_CHECK([version of ghc], [fptools_version_of_ghc], +["${WithGhc-ghc}" --version > conftestghc 2>&1 + cat conftestghc >&AS_MESSAGE_LOG_FD +#Useless Use Of cat award... + fptools_version_of_ghc=`cat conftestghc | sed -n -e 's/, patchlevel *\([[0-9]]\)/.\1/;s/.* version \([[0-9]][[0-9.]]*\).*/\1/p'` + rm -fr conftest* + if test "[$]fptools_version_of_ghc" = "" + then + fptools_version_of_ghc='unknown' + fi +fptools_version_of_ghc[_major]=`echo [$]fptools_version_of_ghc | sed -e 's/^\([[0-9]]\).*/\1/'` +fptools_version_of_ghc[_minor]=`echo [$]fptools_version_of_ghc | sed -e 's/^[[0-9]]\.\([[0-9]]*\).*/\1/'` +fptools_version_of_ghc[_pl]=`echo [$]fptools_version_of_ghc | sed -n -e 's/^[[0-9]]\.[[0-9]]*\.\([[0-9]]*\)/\1/p'` +# +if test "[$]fptools_version_of_ghc[_pl]" = "" +then + fptools_version_of_ghc[_all]="[$]fptools_version_of_ghc[_major].[$]fptools_version_of_ghc[_minor]" + fptools_version_of_ghc[_pl]="0" +else + fptools_version_of_ghc[_all]="[$]fptools_version_of_ghc[_major].[$]fptools_version_of_ghc[_minor].[$]fptools_version_of_ghc[_pl]" +fi +# +ifelse($#, [1], [dnl +[$1]="[$]fptools_version_of_ghc[_all]" +], $#, [2], [dnl +[$1]="[$]fptools_version_of_ghc[_major]" +[$2]="[$]fptools_version_of_ghc[_minor]" +], $#, [3], [dnl +[$1]="[$]fptools_version_of_ghc[_major]" +[$2]="[$]fptools_version_of_ghc[_minor]" +[$3]="[$]fptools_version_of_ghc[_pl]" +], $#, [4], [dnl +[$1]="[$]fptools_version_of_ghc[_all]" +[$2]="[$]fptools_version_of_ghc[_major]" +[$3]="[$]fptools_version_of_ghc[_minor]" +[$4]="[$]fptools_version_of_ghc[_pl]" +]) +]) +])dnl + + +# FP_CHECK_FUNC(FUNCTION, PROLOGUE, BODY, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) +# --------------------------------------------------------------------------------- +# A variant of AC_CHECK_FUNCS, limited to a single FUNCTION, but with the +# additional flexibility of specifying the PROLOGUE and BODY. +AC_DEFUN([FP_CHECK_FUNC], +[AS_VAR_PUSHDEF([fp_func], [fp_cv_func_$1])dnl +AC_CACHE_CHECK([for $1], fp_func, +[AC_LINK_IFELSE([AC_LANG_PROGRAM([$2], [$3])], + [AS_VAR_SET(fp_func, yes)], + [AS_VAR_SET(fp_func, no)])]) +AS_IF([test AS_VAR_GET(fp_func) = yes], + [AC_DEFINE(AS_TR_CPP(HAVE_$1), [1], + [Define to 1 if you have the `]$1[' function.]) $4], + [$5])dnl +AS_VAR_POPDEF([fp_func])dnl +])# FP_CHECK_FUNC + + +# FP_GEN_DOCBOOK_XML +# ------------------ +# Generates a DocBook XML V4.5 document in conftest.xml. +# +# It took a lot of experimentation to find a document that will cause +# xsltproc to fail with an error code when the relevant +# stylesheets/DTDs are not found. I couldn't make xsltproc fail with +# a single-file document, it seems a multi-file document is needed. +# -- SDM 2009-06-03 +# +AC_DEFUN([FP_GEN_DOCBOOK_XML], +[rm -f conftest.xml conftest-book.xml +cat > conftest.xml << EOF + + +]]> + +&conftest-book; + +EOF +cat >conftest-book.xml << EOF + + A DocBook “Test Document” + + A Chapter Title + This is a paragraph, referencing . + + + Another Chapter Title + This is another paragraph, referencing . + +EOF +]) # FP_GEN_DOCBOOK_XML + + +# FP_PROG_DBLATEX +# ---------------- +# Sets the output variable DblatexCmd to the full path of dblatex, +# which we use for building PDF and PS docs. +# DblatexCmd is empty if dblatex could not be found. +AC_DEFUN([FP_PROG_DBLATEX], +[FP_PATH_PROG([DblatexCmd], [dblatex]) +if test -z "$DblatexCmd"; then + AC_MSG_WARN([cannot find dblatex in your PATH, you will not be able to build the PDF and PS documentation]) +fi +])# FP_PROG_DBLATEX + + +# FP_PROG_XSLTPROC +# ---------------- +# Sets the output variable XsltprocCmd to the full path of the XSLT processor +# xsltproc. XsltprocCmd is empty if xsltproc could not be found. +AC_DEFUN([FP_PROG_XSLTPROC], +[FP_PATH_PROG([XsltprocCmd], [xsltproc]) +if test -z "$XsltprocCmd"; then + AC_MSG_WARN([cannot find xsltproc in your PATH, you will not be able to build the HTML documentation]) +fi +])# FP_PROG_XSLTPROC + + +# FP_DOCBOOK_XSL +# ---------------------------- +# Check that we can process a DocBook XML document to HTML using xsltproc. +AC_DEFUN([FP_DOCBOOK_XSL], +[AC_REQUIRE([FP_PROG_XSLTPROC])dnl +if test -n "$XsltprocCmd"; then + AC_CACHE_CHECK([for DocBook XSL stylesheet], fp_cv_dir_docbook_xsl, + [FP_GEN_DOCBOOK_XML + fp_cv_dir_docbook_xsl=no + if $XsltprocCmd --nonet http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl conftest.xml > /dev/null 2>&1; then + fp_cv_dir_docbook_xsl=yes + fi + rm -rf conftest*]) +fi +if test x"$fp_cv_dir_docbook_xsl" = xno; then + AC_MSG_WARN([cannot find DocBook XSL stylesheets, you will not be able to build the documentation]) + HAVE_DOCBOOK_XSL=NO +else + HAVE_DOCBOOK_XSL=YES +fi +AC_SUBST([HAVE_DOCBOOK_XSL]) +])# FP_DOCBOOK_XSL + + +# FP_PROG_XMLLINT +# ---------------- +# Sets the output variable XmllintCmd to the full path of the XSLT processor +# xmllint. XmllintCmd is empty if xmllint could not be found. +AC_DEFUN([FP_PROG_XMLLINT], +[FP_PATH_PROG([XmllintCmd], [xmllint]) +if test -z "$XmllintCmd"; then + AC_MSG_WARN([cannot find xmllint in your PATH, you will not be able to validate your documentation]) +fi +])# FP_PROG_XMLLINT + + +# FP_CHECK_DOCBOOK_DTD +# -------------------- +AC_DEFUN([FP_CHECK_DOCBOOK_DTD], +[AC_REQUIRE([FP_PROG_XMLLINT])dnl +if test -n "$XmllintCmd"; then + AC_MSG_CHECKING([for DocBook DTD]) + FP_GEN_DOCBOOK_XML + if $XmllintCmd --nonet --valid --noout conftest.xml ; then + AC_MSG_RESULT([ok]) + else + AC_MSG_RESULT([failed]) + AC_MSG_WARN([cannot find a DTD for DocBook XML V4.5, you will not be able to validate your documentation]) + AC_MSG_WARN([check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog]) + fi + rm -rf conftest* +fi +])# FP_CHECK_DOCBOOK_DTD + + +# FP_PROG_GHC_PKG +# ---------------- +# Try to find a ghc-pkg matching the ghc mentioned in the environment variable +# WithGhc. Sets the output variable GhcPkgCmd. +AC_DEFUN([FP_PROG_GHC_PKG], +[AC_CACHE_CHECK([for ghc-pkg matching $WithGhc], fp_cv_matching_ghc_pkg, +[ +# If we are told to use ghc-stage2, then we're using an in-tree +# compiler. In this case, we just want ghc-pkg, not ghc-pkg-stage2, +# so we sed off -stage[0-9]$. However, if we are told to use +# ghc-6.12.1 then we want to use ghc-pkg-6.12.1, so we keep any +# other suffix. +fp_ghc_pkg_guess=`echo $WithGhc | sed -e 's/-stage@<:@0-9@:>@$//' -e 's,ghc\(@<:@^/\\@:>@*\)$,ghc-pkg\1,'` +if "$fp_ghc_pkg_guess" list > /dev/null 2>&1; then + fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess +else + AC_MSG_ERROR([Cannot find matching ghc-pkg]) +fi]) +GhcPkgCmd=$fp_cv_matching_ghc_pkg +AC_SUBST([GhcPkgCmd]) +])# FP_PROG_GHC_PKG + + +# FP_GCC_EXTRA_FLAGS +# ------------------ +# Determine which extra flags we need to pass gcc when we invoke it +# to compile .hc code. +# +# -fwrapv is needed for gcc to emit well-behaved code in the presence of +# integer wrap around. (Trac #952) +# +AC_DEFUN([FP_GCC_EXTRA_FLAGS], +[AC_REQUIRE([FP_GCC_VERSION]) +AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts], +[fp_cv_gcc_extra_opts= + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], + [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"], + []) +]) +AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts) +]) + + +# FP_SETUP_PROJECT_VERSION +# --------------------- +AC_DEFUN([FP_SETUP_PROJECT_VERSION], +[ +if test "$RELEASE" = "NO"; then + AC_MSG_CHECKING([for GHC version date]) + if test -f VERSION_DATE; then + PACKAGE_VERSION=${PACKAGE_VERSION}.`cat VERSION_DATE` + AC_MSG_RESULT(given $PACKAGE_VERSION) + elif test -d .git; then + changequote(, )dnl + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` + if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else + changequote([, ])dnl + AC_MSG_ERROR([failed to detect version date: check that git is in your path]) + fi + PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date + AC_MSG_RESULT(inferred $PACKAGE_VERSION) + elif test -f VERSION; then + PACKAGE_VERSION=`cat VERSION` + AC_MSG_RESULT(given $PACKAGE_VERSION) + else + AC_MSG_WARN([cannot determine snapshot version: no .git directory and no VERSION file]) + dnl We'd really rather this case didn't happen, but it might + dnl do (in particular, people using lndir trees may find that + dnl the build system can't find any other date). If it does + dnl happen, then we use the current date. + dnl This way we get some idea about how recent a build is. + dnl It also means that packages built for 2 different builds + dnl will probably use different version numbers, so things are + dnl less likely to go wrong. + PACKAGE_VERSION=${PACKAGE_VERSION}.`date +%Y%m%d` + fi +fi + + AC_MSG_CHECKING([for GHC Git commit id]) + if test -d .git; then + git_commit_id=`git rev-parse HEAD` + if test -n "$git_commit_id" 2>&1 >/dev/null; then true; else + AC_MSG_ERROR([failed to detect revision: check that git is in your path]) + fi + PACKAGE_GIT_COMMIT_ID=$git_commit_id + AC_MSG_RESULT(inferred $PACKAGE_GIT_COMMIT_ID) + elif test -f GIT_COMMIT_ID; then + PACKAGE_GIT_COMMIT_ID=`cat GIT_COMMIT_ID` + AC_MSG_RESULT(given $PACKAGE_GIT_COMMIT_ID) + else + AC_MSG_WARN([cannot determine snapshot revision: no .git directory and no 'GIT_COMMIT_ID' file]) + PACKAGE_GIT_COMMIT_ID="0000000000000000000000000000000000000000" + fi + + +# Some renamings +AC_SUBST([ProjectName], [$PACKAGE_NAME]) +AC_SUBST([ProjectVersion], [$PACKAGE_VERSION]) +AC_SUBST([ProjectGitCommitId], [$PACKAGE_GIT_COMMIT_ID]) + +# Split PACKAGE_VERSION into (possibly empty) parts +VERSION_MAJOR=`echo $PACKAGE_VERSION | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\1'/` +VERSION_TMP=`echo $PACKAGE_VERSION | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\3'/` +VERSION_MINOR=`echo $VERSION_TMP | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\1'/` +ProjectPatchLevel=`echo $VERSION_TMP | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\3'/` + +# Calculate project version as an integer, using 2 digits for minor version +case $VERSION_MINOR in + ?) ProjectVersionInt=${VERSION_MAJOR}0${VERSION_MINOR} ;; + ??) ProjectVersionInt=${VERSION_MAJOR}${VERSION_MINOR} ;; + *) AC_MSG_ERROR([bad minor version in $PACKAGE_VERSION]) ;; +esac +AC_SUBST([ProjectVersionInt]) + +# The project patchlevel is zero unless stated otherwise +test -z "$ProjectPatchLevel" && ProjectPatchLevel=0 + +# Save split version of ProjectPatchLevel +ProjectPatchLevel1=`echo $ProjectPatchLevel | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\1/'` +ProjectPatchLevel2=`echo $ProjectPatchLevel | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\3/'` + +AC_SUBST([ProjectPatchLevel1]) +AC_SUBST([ProjectPatchLevel2]) + +# Remove dots from the patch level; this allows us to have versions like 6.4.1.20050508 +ProjectPatchLevel=`echo $ProjectPatchLevel | sed 's/\.//'` + +AC_SUBST([ProjectPatchLevel]) +])# FP_SETUP_PROJECT_VERSION + + +# Check for a working timer_create(). We need a pretty detailed check +# here, because there exist partially-working implementations of +# timer_create() in certain versions of Linux (see bug #1933). +# +AC_DEFUN([FP_CHECK_TIMER_CREATE],[ +AC_CHECK_FUNC([timer_create],[HAVE_timer_create=yes],[HAVE_timer_create=no]) + +if test "$HAVE_timer_create" = "yes" +then + if test "$cross_compiling" = "yes" + then + # We can't test timer_create when we're cross-compiling, so we + # optimistiaclly assume that it actually works properly. + AC_DEFINE([USE_TIMER_CREATE], 1, [Define to 1 if we can use timer_create(CLOCK_PROCESS_CPUTIME_ID,...)]) + else + AC_CACHE_CHECK([for a working timer_create(CLOCK_REALTIME)], + [fptools_cv_timer_create_works], + [AC_TRY_RUN([ +#include +#ifdef HAVE_STDLIB_H +#include +#endif +#ifdef HAVE_TIME_H +#include +#endif +#ifdef HAVE_SIGNAL_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif + +static volatile int tock = 0; +static void handler(int i) +{ + tock = 1; +} + +static void timeout(int i) +{ + // timer_settime() has been known to hang, so just in case + // we install a 1-second timeout (see #2257) + exit(99); +} + +int main(int argc, char *argv[]) +{ + + struct sigevent ev; + timer_t timer; + struct itimerspec it; + struct sigaction action; + int m,n,count = 0; + + ev.sigev_notify = SIGEV_SIGNAL; + ev.sigev_signo = SIGVTALRM; + + action.sa_handler = handler; + action.sa_flags = 0; + sigemptyset(&action.sa_mask); + if (sigaction(SIGVTALRM, &action, NULL) == -1) { + fprintf(stderr,"SIGVTALRM problem\n"); + exit(3); + } + + action.sa_handler = timeout; + action.sa_flags = 0; + sigemptyset(&action.sa_mask); + if (sigaction(SIGALRM, &action, NULL) == -1) { + fprintf(stderr,"SIGALRM problem\n"); + exit(3); + } + alarm(1); + + if (timer_create(CLOCK_PROCESS_CPUTIME_ID, &ev, &timer) != 0) { + fprintf(stderr,"No CLOCK_PROCESS_CPUTIME_ID timer\n"); + exit(1); + } + + it.it_value.tv_sec = 0; + it.it_value.tv_nsec = 1; + it.it_interval = it.it_value; + if (timer_settime(timer, 0, &it, NULL) != 0) { + fprintf(stderr,"settime problem\n"); + exit(4); + } + + tock = 0; + + for(n = 3; n < 20000; n++){ + for(m = 2; m <= n/2; m++){ + if (!(n%m)) count++; + if (tock) goto out; + } + } +out: + + if (!tock) { + fprintf(stderr,"no CLOCK_PROCESS_CPUTIME_ID signal\n"); + exit(5); + } + + timer_delete(timer); + + if (timer_create(CLOCK_REALTIME, &ev, &timer) != 0) { + fprintf(stderr,"No CLOCK_REALTIME timer\n"); + exit(2); + } + + it.it_value.tv_sec = 0; + it.it_value.tv_nsec = 1000000; + it.it_interval = it.it_value; + if (timer_settime(timer, 0, &it, NULL) != 0) { + fprintf(stderr,"settime problem\n"); + exit(4); + } + + tock = 0; + + usleep(3000); + + if (!tock) { + fprintf(stderr,"no CLOCK_REALTIME signal\n"); + exit(5); + } + + timer_delete(timer); + + exit(0); +} + ], + [fptools_cv_timer_create_works=yes], + [fptools_cv_timer_create_works=no]) + ]) +case $fptools_cv_timer_create_works in + yes) AC_DEFINE([USE_TIMER_CREATE], 1, + [Define to 1 if we can use timer_create(CLOCK_PROCESS_CPUTIME_ID,...)]);; +esac + fi +fi +]) + +# FP_ICONV +# ------------- +AC_DEFUN([FP_ICONV], +[ + dnl-------------------------------------------------------------------- + dnl * Deal with arguments telling us iconv is somewhere odd + dnl-------------------------------------------------------------------- + + dnl Note: ICONV_LIB_DIRS and ICONV_INCLUDE_DIRS are not predefined + dnl to the empty string to allow them to be overridden from the + dnl environment. + + AC_ARG_WITH([iconv-includes], + [AC_HELP_STRING([--with-iconv-includes], + [directory containing iconv.h])], + [ICONV_INCLUDE_DIRS=$withval]) + + AC_ARG_WITH([iconv-libraries], + [AC_HELP_STRING([--with-iconv-libraries], + [directory containing iconv library])], + [ICONV_LIB_DIRS=$withval]) + + AC_SUBST(ICONV_INCLUDE_DIRS) + AC_SUBST(ICONV_LIB_DIRS) +])# FP_ICONV + +# FP_GMP +# ------------- +AC_DEFUN([FP_GMP], +[ + dnl-------------------------------------------------------------------- + dnl * Deal with arguments telling us gmp is somewhere odd + dnl-------------------------------------------------------------------- + + AC_ARG_WITH([gmp-includes], + [AC_HELP_STRING([--with-gmp-includes], + [directory containing gmp.h])], + [GMP_INCLUDE_DIRS=$withval]) + + AC_ARG_WITH([gmp-libraries], + [AC_HELP_STRING([--with-gmp-libraries], + [directory containing gmp library])], + [GMP_LIB_DIRS=$withval]) + + AC_SUBST(GMP_INCLUDE_DIRS) + AC_SUBST(GMP_LIB_DIRS) +])# FP_GMP + +# FP_CURSES +# ------------- +AC_DEFUN([FP_CURSES], +[ + dnl-------------------------------------------------------------------- + dnl * Deal with arguments telling us curses is somewhere odd + dnl-------------------------------------------------------------------- + + AC_ARG_WITH([curses-includes], + [AC_HELP_STRING([--with-curses-includes], + [directory containing curses headers])], + [CURSES_INCLUDE_DIRS=$withval]) + + AC_ARG_WITH([curses-libraries], + [AC_HELP_STRING([--with-curses-libraries], + [directory containing curses libraries])], + [CURSES_LIB_DIRS=$withval]) + + AC_SUBST(CURSES_INCLUDE_DIRS) + AC_SUBST(CURSES_LIB_DIRS) +])# FP_CURSES + +# -------------------------------------------------------------- +# Calculate absolute path to build tree +# -------------------------------------------------------------- + +AC_DEFUN([FP_INTREE_GHC_PWD],[ +AC_MSG_NOTICE(Building in-tree ghc-pwd) + dnl This would be + dnl make -C utils/ghc-pwd clean && make -C utils/ghc-pwd + dnl except we don't want to have to know what make is called. Sigh. + rm -rf utils/ghc-pwd/dist-boot + mkdir utils/ghc-pwd/dist-boot + dnl If special linker flags are needed to build things, then allow + dnl the user to pass them in via LDFLAGS. + changequote(, )dnl + GHC_LDFLAGS=`perl -e 'foreach (@ARGV) { print "-optl$_ " }' -- $LDFLAGS` + changequote([, ])dnl + if ! "$WithGhc" $GHC_LDFLAGS -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd + then + AC_MSG_ERROR([Building ghc-pwd failed]) + fi + + GHC_PWD=utils/ghc-pwd/dist-boot/ghc-pwd +]) + +AC_DEFUN([FP_BINDIST_GHC_PWD],[ + GHC_PWD=utils/ghc-pwd/dist-install/build/tmp/ghc-pwd-bindist +]) + +AC_DEFUN([FP_FIND_ROOT],[ +AC_MSG_CHECKING(for path to top of build tree) + hardtop=`$GHC_PWD` + + dnl Remove common automounter nonsense + hardtop=`echo $hardtop | sed 's|^/tmp_mnt.*\(/local/.*\)$|\1|' | sed 's|^/tmp_mnt/|/|'` + + if ! test -d "$hardtop"; then + AC_MSG_ERROR([cannot determine current directory]) + fi + + dnl We don't support building in directories with spaces. + case "$hardtop" in + *' '*) + AC_MSG_ERROR([ + The build system does not support building in a directory + containing space characters. + Suggestion: move the build tree somewhere else.]) + ;; + esac + + AC_SUBST(hardtop) + + AC_MSG_RESULT($hardtop) +]) + +# GHC_CONVERT_CPU(cpu, target_var) +# -------------------------------- +# converts cpu from gnu to ghc naming, and assigns the result to $target_var +AC_DEFUN([GHC_CONVERT_CPU],[ +case "$1" in + aarch64*) + $2="aarch64" + ;; + alpha*) + $2="alpha" + ;; + arm*) + $2="arm" + ;; + hppa1.1*) + $2="hppa1_1" + ;; + hppa*) + $2="hppa" + ;; + i386|i486|i586|i686) + $2="i386" + ;; + ia64) + $2="ia64" + ;; + m68k*) + $2="m68k" + ;; + mipseb*) + $2="mipseb" + ;; + mipsel*) + $2="mipsel" + ;; + mips*) + $2="mips" + ;; + powerpc64le*) + $2="powerpc64le" + ;; + powerpc64*) + $2="powerpc64" + ;; + powerpc*) + $2="powerpc" + ;; + rs6000) + $2="rs6000" + ;; + s390x*) + $2="s390x" + ;; + s390*) + $2="s390" + ;; + sparc64*) + $2="sparc64" + ;; + sparc*) + $2="sparc" + ;; + vax) + $2="vax" + ;; + x86_64|amd64) + $2="x86_64" + ;; + *) + echo "Unknown CPU $1" + exit 1 + ;; + esac +]) + +# GHC_CONVERT_VENDOR(vendor, target_var) +# -------------------------------- +# converts vendor from gnu to ghc naming, and assigns the result to $target_var +AC_DEFUN([GHC_CONVERT_VENDOR],[ + case "$1" in + pc|gentoo|w64) # like i686-pc-linux-gnu, i686-gentoo-freebsd8, x86_64-w64-mingw32 + $2="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + $2="unknown" + ;; + *) + #pass thru by default + $2="$1" + ;; + esac +]) + +# GHC_CONVERT_OS(os, converted_cpu, target_var) +# -------------------------------- +# converts os from gnu to ghc naming, and assigns the result to $target_var +AC_DEFUN([GHC_CONVERT_OS],[ +case "$1-$2" in + darwin10-arm|darwin11-i386|darwin14-aarch64) + $3="ios" + ;; + *) + case "$1" in + linux-android*) + $3="linux-android" + ;; + linux-*|linux) + $3="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + $3="$1" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + $3="freebsd" + ;; + nto-qnx*) + $3="nto-qnx" + ;; + *) + echo "Unknown OS $1" + exit 1 + ;; + esac + ;; + esac +]) + +# BOOTSTRAPPING_GHC_INFO_FIELD +# -------------------------------- +# Set the variable $1 to the value of the ghc --info field $2. +AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[ +$1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'` +tmp=${$1#\$topdir/} +if test "${$1}" != "$tmp" +then + topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'` + $1="$topdir/$tmp" +fi +AC_SUBST($1) +]) + +# LIBRARY_VERSION(lib, [dir]) +# -------------------------------- +# Gets the version number of a library. +# If $1 is ghc-prim, then we define LIBRARY_ghc_prim_VERSION as 1.2.3 +# $2 points to the directory under libraries/ +AC_DEFUN([LIBRARY_VERSION],[ +dir=m4_default([$2],[$1]) +LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/${dir}/$1.cabal | sed "s/.* //"` +AC_SUBST(LIBRARY_[]translit([$1], [-], [_])[]_VERSION) +]) + +# XCODE_VERSION() +# -------------------------------- +# Gets the version number of XCode, if on a Mac +AC_DEFUN([XCODE_VERSION],[ + if test "$TargetOS_CPP" = "darwin" + then + AC_MSG_CHECKING(XCode version) + XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` + # Old XCode versions don't actually give the XCode version + if test "$XCodeVersion" = "" + then + AC_MSG_RESULT(not found (too old?)) + XCodeVersion1=0 + XCodeVersion2=0 + else + AC_MSG_RESULT($XCodeVersion) + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` + changequote(, )dnl + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` + changequote([, ])dnl + AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1) + AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2) + fi + fi +]) + +# FIND_LLVM_PROG() +# -------------------------------- +# Find where the llvm tools are. We have a special function to handle when they +# are installed with a version suffix (e.g., llc-3.1). +# +# $1 = the variable to set +# $2 = the with option name +# $3 = the command to look for +# $4 = the version of the command to look for +# +AC_DEFUN([FIND_LLVM_PROG],[ + # Test for program with version name. + FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3-$4]) + if test "$$1" = ""; then + # Test for program without version name. + FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3]) + AC_MSG_CHECKING([$$1 is version $4]) + if test `$$1 --version | grep -c "version $4"` -gt 0 ; then + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + $1="" + fi + fi +]) + +# FIND_LD +# Find the version of `ld` to use. This is used in both in the top level +# configure.ac and in distrib/configure.ac.in. +# +# $1 = the variable to set +# +AC_DEFUN([FIND_LD],[ + FP_ARG_WITH_PATH_GNU_PROG([LD], [ld], [ld]) + case $target in + arm*linux* | \ + aarch64*linux* ) + # Arm and Aarch64 requires use of the binutils ld.gold linker. + # This case should catch at least arm-unknown-linux-gnueabihf, + # arm-linux-androideabi, arm64-unknown-linux and + # aarch64-linux-android + FP_ARG_WITH_PATH_GNU_PROG([LD_GOLD], [ld.gold], [ld.gold]) + $1="$LD_GOLD" + ;; + *) + $1="$LD" + ;; + esac +]) + +# FIND_GHC_BOOTSTRAP_PROG() +# -------------------------------- +# Parse the bootstrap GHC's compier settings file for the location of things +# like the `llc` and `opt` commands. +# +# $1 = the variable to set +# $2 = The bootstrap compiler. +# $3 = The string to grep for to find the correct line. +# +AC_DEFUN([FIND_GHC_BOOTSTRAP_PROG],[ + BootstrapTmpCmd=`grep $3 $($2 --print-libdir)/settings 2>/dev/null | sed 's/.*", "//;s/".*//'` + if test -n "$BootstrapTmpCmd" && test `basename $BootstrapTmpCmd` = $BootstrapTmpCmd ; then + AC_PATH_PROG([$1], [$BootstrapTmpCmd], "") + else + $1=$BootstrapTmpCmd + fi +]) + + +# FIND_GCC() +# -------------------------------- +# Finds where gcc is +# +# $1 = the variable to set +# $2 = the with option name +# $3 = the command to look for +AC_DEFUN([FIND_GCC],[ + if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -eq 4 && + test "$XCodeVersion2" -lt 2 + then + # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather + # than the LLVM backend). We prefer the legacy gcc, but in + # Xcode 4.2 'gcc-4.2' was removed. + FP_ARG_WITH_PATH_GNU_PROG([$1], [gcc-4.2], [gcc-4.2]) + elif test "$windows" = YES + then + $1="$CC" + else + FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [$2], [$3]) + # From Xcode 5 on/, OS X command line tools do not include gcc + # anymore. Use clang. + if test -z "$$1" + then + FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [clang], [clang]) + fi + if test -z "$$1" + then + AC_MSG_ERROR([cannot find $3 nor clang in your PATH]) + fi + fi + AC_SUBST($1) +]) + +# FIND_READELF() +# -------------------------------- +# Finds which `readelf` to use. This is used in both in the top level +# `configure.ac` and in `distrib/configure.ac.in` +# +# $1 = the variable to set +# +AC_DEFUN([FIND_READELF],[ + if test "$HostOS" != "mingw32" && + test "$HostOS" != "darwin" ; then + FP_ARG_WITH_PATH_GNU_PROG([READELF], [readelf], [readelf]) + if test -z "$READELF"; then + AC_MSG_ERROR([cannot identify readelf tool]) + fi + $1="$READELF" + fi +]) + +AC_DEFUN([MAYBE_OVERRIDE_STAGE0],[ + if test ! -z "$With_$1" -a "$CrossCompiling" != "YES"; then + AC_MSG_NOTICE([Not cross-compiling, so --with-$1 also sets $2]) + $2=$With_$1 + fi +]) + + +# FP_CPP_CMD_WITH_ARGS() +# ---------------------- +# sets CPP command and its arguments +# +# $1 = the variable to set to CPP command +# $2 = the varibale to set to CPP command arguments + +AC_DEFUN([FP_CPP_CMD_WITH_ARGS],[ +dnl ** what cpp to use? +dnl -------------------------------------------------------------- +AC_ARG_WITH(hs-cpp, +[AC_HELP_STRING([--with-hs-cpp=ARG], + [Use ARG as the path to cpp [default=autodetect]])], +[ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HS_CPP_CMD=$withval + fi +], +[ + + HS_CPP_CMD=$WhatGccIsCalled + + SOLARIS_GCC_CPP_BROKEN=NO + SOLARIS_FOUND_GOOD_CPP=NO + case $host in + i386-*-solaris2) + GCC_MAJOR_MINOR=`$WhatGccIsCalled --version|grep "gcc (GCC)"|cut -d ' ' -f 3-3|cut -d '.' -f 1-2` + if test "$GCC_MAJOR_MINOR" != "3.4"; then + # this is not 3.4.x release so with broken CPP + SOLARIS_GCC_CPP_BROKEN=YES + fi + ;; + esac + + if test "$SOLARIS_GCC_CPP_BROKEN" = "YES"; then + # let's try to find if GNU C 3.4.x is installed + if test -x /usr/sfw/bin/gcc; then + # something executable is in expected path so let's + # see if it's really GNU C + NEW_GCC_MAJOR_MINOR=`/usr/sfw/bin/gcc --version|grep "gcc (GCC)"|cut -d ' ' -f 3-3|cut -d '.' -f 1-2` + if test "$NEW_GCC_MAJOR_MINOR" = "3.4"; then + # this is GNU C 3.4.x which provides non-broken CPP on Solaris + # let's use it as CPP then. + HS_CPP_CMD=/usr/sfw/bin/gcc + SOLARIS_FOUND_GOOD_CPP=YES + fi + fi + if test "$SOLARIS_FOUND_GOOD_CPP" = "NO"; then + AC_MSG_WARN([Your GNU C provides broken CPP and you do not have GNU C 3.4.x installed.]) + AC_MSG_WARN([Please install GNU C 3.4.x to solve this issue. It will be used as CPP only.]) + fi + fi +] +) + + + +dnl ** what cpp flags to use? +dnl ----------------------------------------------------------- +AC_ARG_WITH(hs-cpp-flags, + [AC_HELP_STRING([--with-hs-cpp-flags=ARG], + [Use ARG as the path to hs cpp [default=autodetect]])], + [ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HS_CPP_ARGS=$withval + fi + ], +[ + $HS_CPP_CMD -x c /dev/null -dM -E > conftest.txt 2>&1 + if grep "__clang__" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs " + else + $HS_CPP_CMD -v > conftest.txt 2>&1 + if grep "gcc" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="-E -undef -traditional " + else + $HS_CPP_CMD --version > conftest.txt 2>&1 + if grep "cpphs" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="--cpp -traditional" + else + AC_MSG_WARN([configure can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly]) + HS_CPP_ARGS="" + fi + fi + fi + ] +) + +$1=$HS_CPP_CMD +$2=$HS_CPP_ARGS + +]) + +# FP_BFD_SUPPORT() +# ---------------------- +# whether to use libbfd for debugging RTS +AC_DEFUN([FP_BFD_SUPPORT], [ + AC_ARG_ENABLE(bfd-debug, + [AC_HELP_STRING([--enable-bfd-debug], + [Enable symbol resolution for -debug rts ('+RTS -Di') via binutils' libbfd [default=no]])], + [ + # don't pollute general LIBS environment + save_LIBS="$LIBS" + AC_CHECK_HEADERS([bfd.h]) + dnl ** check whether this machine has BFD and libiberty installed (used for debugging) + dnl the order of these tests matters: bfd needs libiberty + AC_CHECK_LIB(iberty, xmalloc) + dnl 'bfd_init' is a rare non-macro in libbfd + AC_CHECK_LIB(bfd, bfd_init) + + AC_TRY_LINK([#include ], + [ + /* mimic our rts/Printer.c */ + bfd* abfd; + const char * name; + char **matching; + + name = "some.executable"; + bfd_init(); + abfd = bfd_openr(name, "default"); + bfd_check_format_matches (abfd, bfd_object, &matching); + { + long storage_needed; + storage_needed = bfd_get_symtab_upper_bound (abfd); + } + { + asymbol **symbol_table; + long number_of_symbols; + symbol_info info; + + number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table); + bfd_get_symbol_info(abfd,symbol_table[0],&info); + } + ], + [],dnl bfd seems to work + [AC_MSG_ERROR([can't use 'bfd' library])]) + LIBS="$save_LIBS" + ] + ) +]) + +# LocalWords: fi diff --git a/bindisttest/HelloWorld.lhs b/bindisttest/HelloWorld.lhs new file mode 100644 index 00000000..94f7defd --- /dev/null +++ b/bindisttest/HelloWorld.lhs @@ -0,0 +1,8 @@ + +\begin{code} +module Main (main) where + +main :: IO () +main = putStr "Hello world!" +\end{code} + diff --git a/bindisttest/Makefile b/bindisttest/Makefile new file mode 100644 index 00000000..bc805c84 --- /dev/null +++ b/bindisttest/Makefile @@ -0,0 +1,65 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +.PHONY: default_target + +default_target: all + +# Ideally we'd just include something to give us variables +# for paths and arguments to tools etc, and those set in mk/build.mk. +TOP=.. +include $(TOP)/mk/tree.mk +include $(TOP)/mk/config.mk + +ifeq "$(TEST_PREP)" "YES" +BIN_DIST_TEST_TAR_COMP = ../$(BIN_DIST_PREP_TAR_COMP) +else +BIN_DIST_TEST_TAR_COMP = ../$(BIN_DIST_TAR_COMP) +endif + +all: + "$(RM)" $(RM_OPTS_REC) $(BIN_DIST_INST_SUBDIR) + "$(RM)" $(RM_OPTS_REC) a/b/c/* + "$(RM)" $(RM_OPTS) HelloWorld HelloWorld.o HelloWorld.hi output +# We use the a/b/c subdirectory as configure looks for install-sh in +# . .. ../.. and we don't want it to find the build system's install-sh. +# +# NB. tar has funny interpretation of filenames sometimes (thinking +# c:/foo is a remote file), so it's safer to bzip and then pipe into +# tar rather than using tar -xjf: + cd a/b/c/ && $(TAR_COMP_CMD) -cd ../../../$(BIN_DIST_TEST_TAR_COMP) | $(TAR_CMD) -xf - +ifeq "$(Windows)" "YES" + mv a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR) +else + cd a/b/c/$(BIN_DIST_NAME) && ./configure --prefix=$(BIN_DIST_INST_DIR) + cd a/b/c/$(BIN_DIST_NAME) && $(MAKE) install +endif + $(BIN_DIST_INST_DIR)/bin/runghc HelloWorld > output + $(CONTEXT_DIFF) output expected_output + $(BIN_DIST_INST_DIR)/bin/ghc --make HelloWorld + ./HelloWorld > output + $(CONTEXT_DIFF) output expected_output +# Without --no-user-package-db we might pick up random packages from ~/.ghc + $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db + +clean distclean: + "$(RM)" $(RM_OPTS_REC) $(BIN_DIST_INST_SUBDIR) + "$(RM)" $(RM_OPTS_REC) a/b/c/* + "$(RM)" $(RM_OPTS) HelloWorld HelloWorld.o HelloWorld.hi output + +# Ignore a load of other standard targets +install install-docs doc: + @: + +show: + @echo '$(VALUE)="$($(VALUE))"' + diff --git a/bindisttest/checkBinaries.sh b/bindisttest/checkBinaries.sh new file mode 100644 index 00000000..cf8b09bd --- /dev/null +++ b/bindisttest/checkBinaries.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +EXPECTED_VERSION="$1" + +# Our shared libraries are currently executable (is that a bug?), so +# we exclude anything that looks like a shared library +for f in `find bindisttest/a/b/c -type f -perm -u+x ! -name '*.so' ! -name '*.dylib' ! -name '*.dll'` +do + if grep -q '("GHC RTS", "YES")' "$f" + then + # Looks like a GHC executable. Is it for the right version? + THIS_VERSION=`./$f +RTS --info | grep '"GHC version"' | sed -e 's/^ ,("GHC version", "//' -e 's/")$//'` + if [ "$THIS_VERSION" != "$EXPECTED_VERSION" ] + then + echo "Bad GHC version '$THIS_VERSION' for '$f'" >&2 + exit 1 + fi + fi +done diff --git a/bindisttest/expected_output b/bindisttest/expected_output new file mode 100644 index 00000000..6769dd60 --- /dev/null +++ b/bindisttest/expected_output @@ -0,0 +1 @@ +Hello world! \ No newline at end of file diff --git a/bindisttest/ghc.mk b/bindisttest/ghc.mk new file mode 100644 index 00000000..4b211064 --- /dev/null +++ b/bindisttest/ghc.mk @@ -0,0 +1,55 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +ifeq "$(TEST_PREP)" "YES" +BIN_DIST_TEST_TAR_COMP = $(BIN_DIST_PREP_TAR_COMP) +else +BIN_DIST_TEST_TAR_COMP = $(BIN_DIST_TAR_COMP) +endif + +.PHONY: test_bindist +test_bindist: + "$(RM)" $(RM_OPTS_REC) bindisttest/$(BIN_DIST_INST_SUBDIR) + "$(RM)" $(RM_OPTS_REC) bindisttest/a + "$(RM)" $(RM_OPTS) bindisttest/HelloWorld + "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.o + "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.hi + "$(RM)" $(RM_OPTS) bindisttest/output +# We use the a/b/c subdirectory as configure looks for install-sh in +# . .. ../.. and we don't want it to find the build system's install-sh. +# +# NB. tar has funny interpretation of filenames sometimes (thinking +# c:/foo is a remote file), so it's safer to bzip and then pipe into +# tar rather than using tar -xjf: + mkdir bindisttest/a + mkdir bindisttest/a/b + mkdir bindisttest/a/b/c + cd bindisttest/a/b/c/ && $(TAR_COMP_CMD) -cd ../../../../$(BIN_DIST_TEST_TAR_COMP) | $(TAR_CMD) -xf - + $(SHELL) bindisttest/checkBinaries.sh $(ProjectVersion) +ifeq "$(Windows_Host)" "YES" + mv bindisttest/a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR) +else + cd bindisttest/a/b/c/$(BIN_DIST_NAME) && ./configure --prefix=$(TOP)/$(BIN_DIST_INST_DIR) --with-gcc="$(WhatGccIsCalled)" + cd bindisttest/a/b/c/$(BIN_DIST_NAME) && $(MAKE) install +endif +ifeq "$(GhcProfiled)" "NO" + $(BIN_DIST_INST_DIR)/bin/runghc bindisttest/HelloWorld > bindisttest/output + $(CONTEXT_DIFF) bindisttest/output bindisttest/expected_output +endif + $(BIN_DIST_INST_DIR)/bin/ghc --make bindisttest/HelloWorld + bindisttest/HelloWorld > bindisttest/output + $(CONTEXT_DIFF) bindisttest/output bindisttest/expected_output +# Without --no-user-package-db we might pick up random packages from ~/.ghc + $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db + +$(eval $(call clean-target,bindisttest,all,$(BIN_DIST_INST_DIR) $(wildcard bindisttest/a/b/c/*) bindisttest/HelloWorld bindisttest/HelloWorld.o bindisttest/HelloWorld.hi bindisttest/output)) + diff --git a/boot b/boot new file mode 100755 index 00000000..e4a8c7ba --- /dev/null +++ b/boot @@ -0,0 +1,193 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use Cwd; +use File::Path 'rmtree'; +use File::Basename; + +my %required_tag; +my $validate; +my $curdir; + +$required_tag{"-"} = 1; +$validate = 0; + +$curdir = &cwd() + or die "Can't find current directory: $!"; + +while ($#ARGV ne -1) { + my $arg = shift @ARGV; + + if ($arg =~ /^--required-tag=(.*)/) { + $required_tag{$1} = 1; + } + elsif ($arg =~ /^--validate$/) { + $validate = 1; + } + else { + die "Bad arg: $arg"; + } +} + +sub sanity_check_line_endings { + local $/ = undef; + open FILE, "packages" or die "Couldn't open file: $!"; + binmode FILE; + my $string = ; + close FILE; + + if ($string =~ /\r/) { + print STDERR <) { + if (/^#/) { + # Comment; do nothing + } + elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+$/) { + $dir = $1; + $tag = $2; + + # If $tag is not "-" then it is an optional repository, so its + # absence isn't an error. + if (defined($required_tag{$tag})) { + # We would like to just check for a .git directory here, + # but in an lndir tree we avoid making .git directories, + # so it doesn't exist. We therefore require that every repo + # has a LICENSE file instead. + if (! -f "$dir/LICENSE") { + print STDERR "Error: $dir/LICENSE doesn't exist.\n"; + die "Maybe you haven't done 'git submodule update --init'?"; + } + } + } + else { + die "Bad line in packages file: $_"; + } + } + close PACKAGES; +} + +# Create libraries/*/{ghc.mk,GNUmakefile} +sub boot_pkgs { + my @library_dirs = (); + + my $package; + + for $package (glob "libraries/*/") { + $package =~ s/\/$//; + my $pkgs = "$package/ghc-packages"; + if (-f $pkgs) { + open PKGS, "< $pkgs" + or die "Failed to open $pkgs: $!"; + while () { + chomp; + s/\r//g; + if (/.+/) { + push @library_dirs, "$package/$_"; + } + } + } + else { + push @library_dirs, $package; + } + } + + for $package (@library_dirs) { + my $dir = &basename($package); + my @cabals = glob("$package/*.cabal"); + if ($#cabals > 0) { + die "Too many .cabal file in $package\n"; + } + if ($#cabals eq 0) { + my $cabal = $cabals[0]; + my $pkg; + my $top; + if (-f $cabal) { + $pkg = $cabal; + $pkg =~ s#.*/##; + $pkg =~ s/\.cabal$//; + $top = $package; + $top =~ s#[^/]+#..#g; + $dir = $package; + $dir =~ s#^libraries/##g; + + print "Creating $package/ghc.mk\n"; + open GHCMK, "> $package/ghc.mk" + or die "Opening $package/ghc.mk failed: $!"; + print GHCMK "${package}_PACKAGE = ${pkg}\n"; + print GHCMK "${package}_dist-install_GROUP = libraries\n"; + print GHCMK "\$(if \$(filter ${dir},\$(PACKAGES_STAGE0)),\$(eval \$(call build-package,${package},dist-boot,0)))\n"; + print GHCMK "\$(if \$(filter ${dir},\$(PACKAGES_STAGE1)),\$(eval \$(call build-package,${package},dist-install,1)))\n"; + print GHCMK "\$(if \$(filter ${dir},\$(PACKAGES_STAGE2)),\$(eval \$(call build-package,${package},dist-install,2)))\n"; + close GHCMK + or die "Closing $package/ghc.mk failed: $!"; + + print "Creating $package/GNUmakefile\n"; + open GNUMAKEFILE, "> $package/GNUmakefile" + or die "Opening $package/GNUmakefile failed: $!"; + print GNUMAKEFILE "dir = ${package}\n"; + print GNUMAKEFILE "TOP = ${top}\n"; + print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n"; + print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n"; + close GNUMAKEFILE + or die "Closing $package/GNUmakefile failed: $!"; + } + } + } +} + +# autoreconf everything that needs it. +sub autoreconf { + my $dir; + + foreach $dir (".", glob("libraries/*/")) { + if (-f "$dir/configure.ac") { + print "Booting $dir\n"; + chdir $dir or die "can't change to $dir: $!"; + system("autoreconf") == 0 + or die "Running autoreconf failed with exitcode $?"; + chdir $curdir or die "can't change to $curdir: $!"; + } + } +} + +sub checkBuildMk { + if ($validate eq 0 && ! -f "mk/build.mk") { + print < m Bool +-- +-- do { c <- getChar; MASSERT( isUpper c ); ... } +-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } +-- do { str <- getStr; ASSERTM( flagSet str ); .. } +-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } +-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } +#define MASSERT(e) ASSERT(e) return () +#define MASSERT2(e,msg) ASSERT2(e,msg) return () +#define ASSERTM(e) do { bool <- e; MASSERT(bool) } +#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } +#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } + +#endif /* HsVersions.h */ + diff --git a/compiler/LICENSE b/compiler/LICENSE new file mode 100644 index 00000000..b5059b71 --- /dev/null +++ b/compiler/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/compiler/Makefile b/compiler/Makefile new file mode 100644 index 00000000..69144827 --- /dev/null +++ b/compiler/Makefile @@ -0,0 +1,24 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +# If the user says 'make' or 'make stage=2' here, we behave as if they were +# in the ghc directory instead, so that the executable GHC gets built. +.PHONY: default_to_ghc all_ghc +default_to_ghc : all_ghc + +dir = compiler + +include ../mk/compiler-ghc.mk + +all_ghc : + +$(TOPMAKE) all_ghc $(EXTRA_MAKE_OPTS) + diff --git a/compiler/NOTES b/compiler/NOTES new file mode 100644 index 00000000..14a1f80b --- /dev/null +++ b/compiler/NOTES @@ -0,0 +1,16 @@ +Note [Subsections Via Symbols] + +If we are using the .subsections_via_symbols directive +(available on recent versions of Darwin), +we have to make sure that there is some kind of reference +from the entry code to a label on the _top_ of of the info table, +so that the linker will not think it is unreferenced and dead-strip +it. That's why the label is called a DeadStripPreventer (_dsp). + +The LLVM code gen already creates `iTableSuf` symbols, where +the X86 would generate the DeadStripPreventer (_dsp) symbol. +Therefore all that is left for llvm code gen, is to ensure +that all the `iTableSuf` symbols are marked as used. +As of this writing the documentation regarding the +.subsections_via_symbols and -dead_stip can be found at + \ No newline at end of file diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs new file mode 100644 index 00000000..495e96de --- /dev/null +++ b/compiler/basicTypes/Avail.hs @@ -0,0 +1,103 @@ +-- +-- (c) The University of Glasgow +-- + +module Avail ( + Avails, + AvailInfo(..), + availsToNameSet, + availsToNameEnv, + availName, availNames, + stableAvailCmp + ) where + +import Name +import NameEnv +import NameSet + +import Binary +import Outputable +import Util + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are "available", i.e. in scope +data AvailInfo = Avail Name -- ^ An ordinary identifier in scope + | AvailTC Name + [Name] -- ^ A type or class in scope. Parameters: + -- + -- 1) The name of the type or class + -- 2) The available pieces of type or class. + -- + -- The AvailTC Invariant: + -- * If the type or class is itself + -- to be in scope, it must be + -- *first* in this list. Thus, + -- typically: @AvailTC Eq [Eq, ==, \/=]@ + deriving( Eq ) + -- Equality used when deciding if the + -- interface has changed + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'GenAvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _) = n + +-- | All names made available by the availability information +availNames :: AvailInfo -> [Name] +availNames (Avail n) = [n] +availNames (AvailTC _ ns) = ns + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) = ppr n +pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac) = do + putByte bh 1 + put_ bh ab + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + return (AvailTC ab ac) + diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs new file mode 100644 index 00000000..cf1c6d1b --- /dev/null +++ b/compiler/basicTypes/BasicTypes.hs @@ -0,0 +1,1116 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellanous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module BasicTypes( + Version, bumpVersion, initialVersion, + + ConTag, fIRST_TAG, + + Arity, RepArity, + + Alignment, + + FunctionOrData(..), + + WarningTxt(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, + + Boxity(..), isBoxed, + + TupleSort(..), tupleSortBoxity, boxityNormalTupleSort, + tupleParens, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, + strongLoopBreaker, weakLoopBreaker, + + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + InterestingCxt, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, isSwapped, + + CompilerPhase(..), PhaseNum, + Activation(..), isActive, isActiveIn, + isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), isEmptyInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + + SuccessFlag(..), succeeded, failed, successIf, + + FractionalLit(..), negateFractionalLit, integralFractionalLit, + + HValue(..), + + SourceText + ) where + +import FastString +import Outputable +import SrcLoc ( Located,unLoc ) + +import Data.Data hiding (Fixity) +import Data.Function (on) +import GHC.Exts (Any) + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +type Arity = Int + +-- | The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | Type of the tags associated with each constructor possibility +type ConTag = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). + +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a \"one-shot\" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | ProbOneShot -- ^ The lambda is probably applied at most once + -- See Note [Computing one-shot info, and ProbOneShot] in OccurAnl + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot ProbOneShot NoOneShotInfo = NoOneShotInfo +worstOneShot ProbOneShot _ = ProbOneShot +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot ProbOneShot OneShotLam = OneShotLam +bestOneShot ProbOneShot _ = ProbOneShot +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot") +pprOneShotInfo OneShotLam = ptext (sLit "OneShot") + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = ptext (sLit "Is-swapped") + ppr NotSwapped = ptext (sLit "Not-swapped") + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data, Typeable) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +{- +************************************************************************ +* * +\subsection[Version]{Module and identifier version numbers} +* * +************************************************************************ +-} + +type Version = Int + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 + +{- +************************************************************************ +* * + Deprecations +* * +************************************************************************ +-} + +-- reason/explanation from a WARNING or DEPRECATED pragma +-- For SourceText usage, see note [Pragma source text] +data WarningTxt = WarningTxt (Located SourceText) [Located FastString] + | DeprecatedTxt (Located SourceText) [Located FastString] + deriving (Eq, Data, Typeable) + +instance Outputable WarningTxt where + ppr (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws)) + ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . unLoc) ds)) + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + +{- +************************************************************************ +* * +\subsection[Fixity]{Fixity info} +* * +************************************************************************ +-} + +------------------------ +data Fixity = Fixity Int FixityDirection + deriving (Data, Typeable) + +instance Outputable Fixity where + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data, Typeable) + +instance Outputable FixityDirection where + ppr InfixL = ptext (sLit "infixl") + ppr InfixR = ptext (sLit "infixr") + ppr InfixN = ptext (sLit "infix") + +------------------------ +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity 0 InfixR -- Fixity of '->' + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange appication, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = ptext (sLit "") + ppr NotTopLevel = ptext (sLit "") + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data, Typeable ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data, Typeable ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = ptext (sLit "Recursive") + ppr NonRecursive = ptext (sLit "NonRecursive") + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +data Origin = FromSource + | Generated + deriving( Eq, Data, Typeable ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = ptext (sLit "FromSource") + ppr Generated = ptext (sLit "Generated") + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a +-- explanation of the `isSafeOverlap` field. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'ApiAnnotation.AnnClose' @`\#-\}`@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data, Typeable) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in InstEnv + + deriving (Eq, Data, Typeable) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = ptext (sLit "[overlappable]") + ppr (Overlapping _) = ptext (sLit "[overlapping]") + ppr (Overlaps _) = ptext (sLit "[overlap ok]") + ppr (Incoherent _) = ptext (sLit "[incoherent]") + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = ptext $ sLit "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data, Typeable ) + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityNormalTupleSort :: Boxity -> TupleSort +boxityNormalTupleSort Boxed = BoxedTuple +boxityNormalTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples + -- directly, we overload the (,,) syntax +tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in VarEnv, which is pretty near +the base of the module hierarchy. So it seemed simpler to put the +defn of OccInfo here, safely at the bottom +-} + +-- | Identifier occurrence information +data OccInfo + = NoOccInfo -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc + !InsideLam + !OneBranch + !InterestingCxt -- ^ Occurs exactly once, not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker -- Note [LoopBreaker OccInfo] + !RulesOnly + + deriving (Eq) + +type RulesOnly = Bool + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +isNoOcc :: OccInfo -> Bool +isNoOcc NoOccInfo = True +isNoOcc _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +type InterestingCxt = Bool -- True <=> Function: is applied + -- Data value: scrutinised by a case with + -- at least one non-DEFAULT branch + +----------------- +type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. +insideLam, notInsideLam :: InsideLam +insideLam = True +notInsideLam = False + +----------------- +type OneBranch = Bool -- True <=> Occurs in only one case branch + -- so no code-duplication issue to worry about +oneBranch, notOneBranch :: OneBranch +oneBranch = True +notOneBranch = False + +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False +weakLoopBreaker = IAmALoopBreaker True + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker _) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +zapFragileOcc (OneOcc {}) = NoOccInfo +zapFragileOcc occ = occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr NoOccInfo = empty + ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty + ppr IAmDead = ptext (sLit "Dead") + ppr (OneOcc inside_lam one_branch int_cxt) + = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args + where + pp_lam | inside_lam = char 'L' + | otherwise = empty + pp_br | one_branch = empty + | otherwise = char '*' + pp_args | int_cxt = char '!' + | otherwise = empty + +{- +************************************************************************ +* * + Default method specfication +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMeth before begin put in a +Class object. +-} + +data DefMethSpec = NoDM -- No default method + | VanillaDM -- Default method given with polymorphic code + | GenericDM -- Default method given with generic code + deriving Eq + +instance Outputable DefMethSpec where + ppr NoDM = empty + ppr VanillaDM = ptext (sLit "{- Has default method -}") + ppr GenericDM = ptext (sLit "{- Has generic default method -}") + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Outputable SuccessFlag where + ppr Succeeded = ptext (sLit "Succeeded") + ppr Failed = ptext (sLit "Failed") + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20` + HsCharPrim '\x41`# == `A` + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004## == 4## + HsWord64Prim 005## == 5## + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + +type SourceText = String -- Note [Literal source text],[Pragma source text] + + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active +-} + +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = Phase PhaseNum + | InitialPhase -- The first phase -- number = infinity! + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = ptext (sLit "InitialPhase") + +data Activation = NeverActive + | AlwaysActive + | ActiveBefore PhaseNum -- Active only *before* this phase + | ActiveAfter PhaseNum -- Active in this phase and later + deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls + +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the InlineRule, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data, Typeable ) + +data InlineSpec -- What the user's INLINE pragma looked like + = Inline + | Inlinable + | NoInline + | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo, + -- where there isn't any real inline pragma at all + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x + +{- +Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = False + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = True, then the Id should have an InlineRule unfolding. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function coreUtils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in Rules.lhs. +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +isEmptyInlineSpec :: InlineSpec -> Bool +isEmptyInlineSpec EmptyInlineSpec = True +isEmptyInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = EmptyInlineSpec + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = brackets (ptext (sLit "ALWAYS")) + ppr NeverActive = brackets (ptext (sLit "NEVER")) + ppr (ActiveBefore n) = brackets (char '~' <> int n) + ppr (ActiveAfter n) = brackets (int n) + +instance Outputable RuleMatchInfo where + ppr ConLike = ptext (sLit "CONLIKE") + ppr FunLike = ptext (sLit "FUNLIKE") + +instance Outputable InlineSpec where + ppr Inline = ptext (sLit "INLINE") + ppr NoInline = ptext (sLit "NOINLINE") + ppr Inlinable = ptext (sLit "INLINABLE") + ppr EmptyInlineSpec = empty + +instance Outputable InlinePragma where + ppr (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase AlwaysActive = True +isActive InitialPhase (ActiveBefore {}) = True +isActive InitialPhase _ = False +isActive (Phase p) act = isActiveIn p act + +isActiveIn :: PhaseNum -> Activation -> Bool +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter n) = p <= n +isActiveIn p (ActiveBefore n) = p > n + +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False + +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: String -- How the value was written in the source + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Typeable, Show) + -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value } +negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value } + +integralFractionalLit :: Integer -> FractionalLit +integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr = text . fl_text + +newtype HValue = HValue Any diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs new file mode 100644 index 00000000..7b8f70d6 --- /dev/null +++ b/compiler/basicTypes/ConLike.hs @@ -0,0 +1,81 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module ConLike ( + ConLike(..) + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon (DataCon) +import {-# SOURCE #-} PatSyn (PatSyn) +import Outputable +import Unique +import Util +import Name + +import Data.Function (on) +import qualified Data.Data as Data +import qualified Data.Typeable + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + deriving Data.Typeable.Typeable + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Ord ConLike where + (<=) = (<=) `on` getUnique + (<) = (<) `on` getUnique + (>=) = (>=) `on` getUnique + (>) = (>) `on` getUnique + compare = compare `on` getUnique + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs new file mode 100644 index 00000000..b635aaf4 --- /dev/null +++ b/compiler/basicTypes/DataCon.hs @@ -0,0 +1,1158 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module DataCon ( + -- * Main data types + DataCon, DataConRep(..), + HsBang(..), HsSrcBang, HsImplBang, + StrictnessMark(..), + ConTag, + + -- ** Type construction + mkDataCon, fIRST_TAG, + buildAlgTyCon, + + -- ** Type deconstruction + dataConRepType, dataConSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTyCon, + dataConOrigTyCon, dataConUserType, + dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, + dataConEqSpec, eqSpecPreds, dataConTheta, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, + dataConSrcBangs, + dataConSourceArity, dataConRepArity, dataConRepRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, + dataConRepStrictness, dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, + isBanged, isMarkedStrict, eqHsBang, + + -- ** Promotion related functions + promoteKind, promoteDataCon, promoteDataCon_maybe + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} MkId( DataConBoxer ) +import Type +import TypeRep( Type(..) ) -- Used in promoteType +import PrelNames( liftedTypeKindTyConKey ) +import ForeignCall( CType ) +import Coercion +import Kind +import Unify +import TyCon +import Class +import Name +import Var +import Outputable +import Unique +import ListSetOps +import Util +import BasicTypes +import FastString +import Module +import VarEnv + +import qualified Data.Data as Data +import qualified Data.Typeable +import Data.Maybe +import Data.Char +import Data.Word + +{- +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? Two reasons: + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coerion + [a] :: [a]~[a] + +INVARIANT: the dictionary constructor for a class + never has a wrapper. + + +A note about the stupid context +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could evasily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a where + -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) + + -- *** As represented internally + -- data T a where + -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a] + -- dcExTyVars = [x,y] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + --- result type of (rep) data con is exactly (T a b c) + + dcExTyVars :: [TyVar], -- Existentially-quantified type vars + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS + -- FOR THE PARENT TyCon. With GADTs the data con might not even have + -- the same number of type variables. + -- [This is a change (Oct05): previously, vanilla datacons guaranteed to + -- have the same type variables as their parent TyCon, but that seems ugly.] + + -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames + -- Reason: less confusing, and easier to generate IfaceSyn + + dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, + -- _as written by the programmer_ + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsBang], + -- See Note [Bangs on data constructor arguments] + -- For DataCons defined in this module: + -- the [HsSrcBang] as written by the programmer. + -- For DataCons imported from an interface file: + -- the [HsImplBang] determined when compiling the + -- defining module + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached + dcRepArity :: Arity, -- == length dataConRepArgTys + dcSourceArity :: Arity, -- == length dcOrigArgTys + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data con representation] below) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in CoreLint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable + -- See Note [Promoted data constructors] in TyCon + } + deriving Data.Typeable.Typeable + +data DataConRep + = NoDataConRep -- No wrapper + + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys + -- See also Note [Data-con worker strictness] in MkId.lhs + + , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + } +-- Algebraic data types always have a worker, and +-- may or may not have a wrapper, depending on whether +-- the wrapper does anything. +-- +-- Data types have a worker with no unfolding +-- Newtypes just have a worker, which has a compulsory unfolding (just a cast) + +-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + +-- The wrapper (if it exists) takes dcOrigArgTys as its arguments +-- The worker takes dataConRepArgTys as its arguments +-- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + +-- The 'NoDataConRep' case is important +-- Not only is this efficient, +-- but it also ensures that the wrapper is replaced +-- by the worker (because it *is* the worker) +-- even when there are no args. E.g. in +-- f (:) x +-- the (:) *is* the worker. +-- This is really important in rule matching, +-- (We could match on the wrappers, +-- but that makes it less likely that rules will match +-- when we bring bits of unfoldings together.) + +------------------------- +-- HsBang describes the strictness/unpack status of one +-- of the original data constructor arguments (i.e. *not* +-- of the representation data constructor which may have +-- more arguments after the originals have been unpacked) +-- See Note [Bangs on data constructor arguments] +data HsBang + = HsNoBang -- Equivalent to (HsSrcBang Nothing False) + + | HsSrcBang -- What the user wrote in the source code + (Maybe SourceText) -- Note [Pragma source text] in BasicTypes + (Maybe Bool) -- Just True {-# UNPACK #-} + -- Just False {-# NOUNPACK #-} + -- Nothing no pragma + Bool -- True <=> '!' specified + -- (HsSrcBang (Just True) False) makes no sense + -- We emit a warning (in checkValidDataCon) and treat it + -- just like (HsSrcBang Nothing False) + + -- Definite implementation commitments, generated by the compiler + -- after consulting HsSrcBang (if any), flags, etc + | HsUnpack -- Definite commitment: this field is strict and unboxed + (Maybe Coercion) -- co :: arg-ty ~ product-ty + + | HsStrict -- Definite commitment: this field is strict but not unboxed + deriving (Data.Data, Data.Typeable) + +-- Two type-insecure, but useful, synonyms +type HsSrcBang = HsBang -- What the user wrote; hence always HsNoBang or HsSrcBang + +type HsImplBang = HsBang -- A HsBang implementation decision, + -- as determined by the compiler + -- Never HsSrcBang + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsNoBang, HsUserBang + + * HsImplBang: What GHC decided + Constructors: HsNoBang, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang Nothing True + , HsSrcBang (Just True) True + , HsNoBang] + +* However, if T was defined in an imported module, MkT's dcSrcBangs + field gives the [HsImplBang] recording the decisions of the + defining module. The importing module must follow those decisions, + regardless of the flag settings in the importing module. + +* The dcr_bangs field of the dcRep field records the [HsImplBang] + If T was defined in this module, Without -O the dcr_bangs might be + [HsStrict, HsStrict, HsNoBang] + With -O it might be + [HsStrict, HsUnpack, HsNoBang] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack, HsNoBang] + +Note [Data con representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The dcRepType field contains the type of the representation of a contructor +This may differ from the type of the contructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Ord DataCon where + a <= b = getUnique a <= getUnique b + a < b = getUnique a < getUnique b + a >= b = getUnique a >= getUnique b + a > b = getUnique a > getUnique b + compare a b = getUnique a `compare` getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsBang where + ppr HsNoBang = empty + ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!') + ppr (HsUnpack Nothing) = ptext (sLit "Unpk") + ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) + ppr HsStrict = ptext (sLit "SrictNotUnpacked") + +pp_unpk :: Maybe Bool -> SDoc +pp_unpk Nothing = empty +pp_unpk (Just True) = ptext (sLit "{-# UNPACK #-}") +pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}") + +instance Outputable StrictnessMark where + ppr MarkedStrict = ptext (sLit "!") + ppr NotMarkedStrict = empty + + +eqHsBang :: HsBang -> HsBang -> Bool +eqHsBang HsNoBang HsNoBang = True +eqHsBang HsStrict HsStrict = True +eqHsBang (HsSrcBang _ u1 b1) (HsSrcBang _ u2 b2) = u1==u2 && b1==b2 +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsBang -> Bool +isBanged HsNoBang = False +isBanged (HsSrcBang _ _ bang) = bang +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> [HsBang] -- ^ Strictness/unpack annotations, from user; + -- or, for imported DataCons, from the interface file + -> [FieldLabel] -- ^ Field labels for the constructor, if it is a record, + -- otherwise empty + -> [TyVar] -- ^ Universally quantified type variables + -> [TyVar] -- ^ Existentially quantified type variables + -> [(TyVar,Type)] -- ^ GADT equalities + -> ThetaType -- ^ Theta-type occuring before the arguments proper + -> [Type] -- ^ Original argument types + -> Type -- ^ Original result type + -> TyCon -- ^ Representation type constructor + -> ThetaType -- ^ The "stupid theta", context of the data declaration + -- e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix + arg_stricts -- Must match orig_arg_tys 1-1 + fields + univ_tvs ex_tvs + eq_spec theta + orig_arg_tys orig_res_ty rep_tycon + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that asaertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys, + dcPromoted = mb_promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con + rep_arg_tys = dataConRepArgTys con + rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ + mkFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + + mb_promoted -- See Note [Promoted data constructors] in TyCon + | isJust (promotableTyCon_maybe rep_tycon) + -- The TyCon is promotable only if all its datacons + -- are, so the promoteType for prom_kind should succeed + = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles) + | otherwise + = Nothing + prom_kind = promoteType (dataConUserType con) + roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ + map (const Representational) orig_arg_tys + +eqSpecPreds :: [(TyVar,Type)] -> ThetaType +eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] + +{- +Note [Unpack equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a GADT with a contructor C :: (a~[b]) => b -> T a +we definitely want that equality predicate *unboxed* so that it +takes no space at all. This is easily done: just give it +an UNPACK pragma. The rest of the unpack/repack code does the +heavy lifting. This one line makes every GADT take a word less +space for each equality predicate, so it's pretty important! +-} + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars = dcUnivTyVars + +-- | The existentially-quantified type variables of the constructor +dataConExTyVars :: DataCon -> [TyVar] +dataConExTyVars = dcExTyVars + +-- | Both the universal and existentiatial type variables of the constructor +dataConAllTyVars :: DataCon -> [TyVar] +dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration +dataConEqSpec :: DataCon -> [(TyVar,Type)] +dataConEqSpec = dcEqSpec + +-- | The *full* constraints on the constructor type +dataConTheta :: DataCon -> ThetaType +dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds eq_spec ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor +-- and also for a newtype (whose constructor is inlined compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitIds :: DataCon -> [Id] +dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep}) + = case rep of + NoDataConRep -> [work] + DCR { dcr_wrap_id = wrap } -> [wrap,work] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabel -> Type +dataConFieldType con label + = case lookup label (dcFields con `zip` dcOrigArgTys con) of + Just ty -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | The strictness markings written by the porgrammer. +-- The list is in one-to-one correspondence with the arity of the 'DataCon' +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Source-level arity of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + + +-- | The number of fields in the /representation/ of the constructor +-- AFTER taking into account the unpacking of any unboxed tuple fields +dataConRepRepArity :: DataCon -> RepArity +dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc) + +-- | Return whether there are any argument types for this 'DataCon's original source type +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = null (dcOrigArgTys dc) + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) +dataConRepStrictness dc = case dcRep dc of + NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] + DCR { dcr_stricts = strs } -> strs + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc + = case dcRep dc of + NoDataConRep -> replicate (dcSourceArity dc) HsNoBang + DCR { dcr_bangs = bangs } -> bangs + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +-- | The \"signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConAllTyVars', +-- +-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit +-- parameter - whatever) +-- +-- 3) The type arguments to the constructor +-- +-- 4) The /original/ result type of the 'DataCon' +dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) +dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyVars' +-- +-- 3) The result of 'dataConEqSpec' +-- +-- 4) The result of 'dataConDictTheta' +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConUserType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConUserType (MkData { dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs, dcEqSpec = eq_spec, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ + mkFunTys theta $ + mkFunTys arg_tys $ + res_ty + +-- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2( length univ_tvs == length inst_tys + , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2( null ex_tvs && null eq_spec, ppr dc ) + map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in MatchCon, we really do want just the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns the arg types of the worker, including *all* evidence, after any +-- flattening has been done and without substituting for any type variables +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys }) + = case rep of + NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys + DCR { dcr_arg_tys = arg_tys } -> arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> [Word8] +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = bytesFS (packageKeyFS (modulePackageKey mod)) ++ + fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ + fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +-- NB: look at *all* equality constraints, not only those +-- in dataConEqSpec; see Trac #5168 +dataConCannotMatch tys con + | null theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise + = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) + | (ty1, ty2) <- concatMap predEqs theta ] + where + dc_tvs = dataConUnivTyVars con + theta = dataConTheta con + subst = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys ) + zipTopTvSubst dc_tvs tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + TuplePred ts -> concatMap predEqs ts + _ -> [] + +{- +************************************************************************ +* * + Building an algebraic data type +* * +************************************************************************ + +buildAlgTyCon is here because it is called from TysWiredIn, which in turn +depends on DataCon, but not on BuildTyCl. +-} + +buildAlgTyCon :: Name + -> [TyVar] -- ^ Kind variables and type variables + -> [Role] + -> Maybe CType + -> ThetaType -- ^ Stupid theta + -> AlgTyConRhs + -> RecFlag + -> Bool -- ^ True <=> this TyCon is promotable + -> Bool -- ^ True <=> was declared in GADT syntax + -> TyConParent + -> TyCon + +buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs + is_rec is_promotable gadt_syn parent + = tc + where + kind = mkPiKinds ktvs liftedTypeKind + + -- tc and mb_promoted_tc are mutually recursive + tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta + rhs parent is_rec gadt_syn + mb_promoted_tc + + mb_promoted_tc + | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind)) + | otherwise = Nothing + +{- +************************************************************************ +* * + Promoting of data types to the kind level +* * +************************************************************************ + +These two 'promoted..' functions are here because + * They belong together + * 'promoteDataCon' depends on DataCon stuff +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = Just tc }) = tc +promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc) + +promoteDataCon_maybe :: DataCon -> Maybe TyCon +promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc + +{- +Note [Promoting a Type to a Kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppsoe we have a data constructor D + D :: forall (a:*). Maybe a -> T a +We promote this to be a type constructor 'D: + 'D :: forall (k:BOX). 'Maybe k -> 'T k + +The transformation from type to kind is done by promoteType + + * Convert forall (a:*) to forall (k:BOX), and substitute + + * Ensure all foralls are at the top (no higher rank stuff) + + * Ensure that all type constructors mentioned (Maybe and T + in the example) are promotable; that is, they have kind + * -> ... -> * -> * +-} + +-- | Promotes a type to a kind. +-- Assumes the argument satisfies 'isPromotableType' +promoteType :: Type -> Kind +promoteType ty + = mkForAllTys kvs (go rho) + where + (tvs, rho) = splitForAllTys ty + kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] + env = zipVarEnv tvs kvs + + go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc + = mkTyConApp prom_tc (map go tys) + go (FunTy arg res) = mkArrowKind (go arg) (go res) + go (TyVarTy tv) | Just kv <- lookupVarEnv env tv + = TyVarTy kv + go _ = panic "promoteType" -- Argument did not satisfy isPromotableType + +promoteKind :: Kind -> SuperKind +-- Promote the kind of a type constructor +-- from (* -> * -> *) to (BOX -> BOX -> BOX) +promoteKind (TyConApp tc []) + | tc `hasKey` liftedTypeKindTyConKey = superKind +promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res) +promoteKind k = pprPanic "promoteKind" (ppr k) + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its /representation/ arg types + + -- Rejecting existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot new file mode 100644 index 00000000..5370a87d --- /dev/null +++ b/compiler/basicTypes/DataCon.hs-boot @@ -0,0 +1,18 @@ +module DataCon where +import Name( Name, NamedThing ) +import {-# SOURCE #-} TyCon( TyCon ) +import Unique ( Uniquable ) +import Outputable ( Outputable, OutputableBndr ) + +data DataCon +data DataConRep +dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon +isVanillaDataCon :: DataCon -> Bool + +instance Eq DataCon +instance Ord DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs new file mode 100644 index 00000000..747f210d --- /dev/null +++ b/compiler/basicTypes/Demand.hs @@ -0,0 +1,1946 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Demand]{@Demand@: A decoupled implementation of a demand domain} +-} + +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} + +module Demand ( + StrDmd, UseDmd(..), Count(..), + countOnce, countMany, -- cardinality + + Demand, CleanDemand, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + getUsage, toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, + lubDmd, bothDmd, apply1Dmd, apply2Dmd, + isTopDmd, isBotDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, + addCaseBndrDmd, + + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + nopDmdType, botDmdType, mkDmdType, + addDemand, removeDmdTyArgs, + BothDmdArg, mkBothDmdArg, toBothDmdArg, + + DmdEnv, emptyDmdEnv, + peelFV, findIdDemand, + + DmdResult, CPRResult, + isBotRes, isTopRes, + topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes, + appIsBottom, isBottomingSig, pprIfaceStrictSig, + trimCPRInfo, returnsCPR_maybe, + StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, + isNopSig, splitStrictSig, increaseStrictSigArity, + + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, + deferAfterIO, + postProcessUnsat, postProcessDmdTypeM, + + splitProdDmd_maybe, peelCallDmd, mkCallDmd, + dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, + argOneShots, argsOneShots, + trimToType, TypeShape(..), + + isSingleUsed, reuseEnv, + killUsageDemand, killUsageSig, zapUsageDemand, + strictifyDictDmd + + ) where + +#include "HsVersions.h" + +import StaticFlags +import DynFlags +import Outputable +import Var ( Var ) +import VarEnv +import UniqFM +import Util +import BasicTypes +import Binary +import Maybes ( orElse ) + +import Type ( Type, isUnLiftedType ) +import TyCon ( isNewTyCon, isClassTyCon ) +import DataCon ( splitDataProductType_maybe ) +import FastString + +{- +************************************************************************ +* * +\subsection{Strictness domain} +* * +************************************************************************ + + Lazy + | + HeadStr + / \ + SCall SProd + \ / + HyperStr +-} + +-- Vanilla strictness domain +data StrDmd + = HyperStr -- Hyper-strict + -- Bottom of the lattice + -- Note [HyperStr and Use demands] + + | SCall StrDmd -- Call demand + -- Used only for values of function type + + | SProd [MaybeStr] -- Product + -- Used only for values of product type + -- Invariant: not all components are HyperStr (use HyperStr) + -- not all components are Lazy (use HeadStr) + + | HeadStr -- Head-Strict + -- A polymorphic demand: used for values of all types, + -- including a type variable + + deriving ( Eq, Show ) + +data MaybeStr = Lazy -- Lazy + -- Top of the lattice + | Str StrDmd + deriving ( Eq, Show ) + +-- Well-formedness preserving constructors for the Strictness domain +strBot, strTop :: MaybeStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [MaybeStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: MaybeStr -> Bool +isLazy Lazy = True +isLazy (Str _) = False + +isHyperStr :: MaybeStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False + +-- Pretty-printing +instance Outputable StrDmd where + ppr HyperStr = char 'B' + ppr (SCall s) = char 'C' <> parens (ppr s) + ppr HeadStr = char 'S' + ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) + +instance Outputable MaybeStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr +lubMaybeStr Lazy _ = Lazy +lubMaybeStr _ Lazy = Lazy +lubMaybeStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + +lubStr :: StrDmd -> StrDmd -> StrDmd +lubStr HyperStr s = s +lubStr (SCall s1) HyperStr = SCall s1 +lubStr (SCall _) HeadStr = HeadStr +lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr +lubStr (SProd s1) (SProd s2) + | length s1 == length s2 = mkSProd (zipWith lubMaybeStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr +bothMaybeStr Lazy s = s +bothMaybeStr s Lazy = s +bothMaybeStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) + +bothStr :: StrDmd -> StrDmd -> StrDmd +bothStr HyperStr _ = HyperStr +bothStr HeadStr s = s +bothStr (SCall _) HyperStr = HyperStr +bothStr (SCall s1) HeadStr = SCall s1 +bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) +bothStr (SCall _) (SProd _) = HyperStr -- Weird + +bothStr (SProd _) HyperStr = HyperStr +bothStr (SProd s1) HeadStr = SProd s1 +bothStr (SProd s1) (SProd s2) + | length s1 == length s2 = mkSProd (zipWith bothMaybeStr s1 s2) + | otherwise = HyperStr -- Weird +bothStr (SProd _) (SCall _) = HyperStr + +-- utility functions to deal with memory leaks +seqStrDmd :: StrDmd -> () +seqStrDmd (SProd ds) = seqStrDmdList ds +seqStrDmd (SCall s) = s `seq` () +seqStrDmd _ = () + +seqStrDmdList :: [MaybeStr] -> () +seqStrDmdList [] = () +seqStrDmdList (d:ds) = seqMaybeStr d `seq` seqStrDmdList ds + +seqMaybeStr :: MaybeStr -> () +seqMaybeStr Lazy = () +seqMaybeStr (Str s) = seqStrDmd s + +-- Splitting polymorphic demands +splitMaybeStrProdDmd :: Int -> MaybeStr -> Maybe [MaybeStr] +splitMaybeStrProdDmd n Lazy = Just (replicate n Lazy) +splitMaybeStrProdDmd n (Str s) = splitStrProdDmd n s + +splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (Trac #9208) + +{- +************************************************************************ +* * +\subsection{Absence domain} +* * +************************************************************************ + + Used + / \ + UCall UProd + \ / + UHead + | + Abs +-} + +-- Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- Call demand for absence + -- Used only for values of function type + + | UProd [MaybeUsed] -- Product + -- Used only for values of product type + -- See Note [Don't optimise UProd(Used) to Used] + -- [Invariant] Not all components are Abs + -- (in that case, use UHead) + + | UHead -- May be used; but its sub-components are + -- definitely *not* used. Roughly U(AAA) + -- Eg the usage of x in x `seq` e + -- A polymorphic demand: used for values of all types, + -- including a type variable + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + + | Used -- May be used; and its sub-components may be used + -- Top of the lattice + deriving ( Eq, Show ) + +-- Extended usage demand for absence and counting +data MaybeUsed + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count UseDmd -- May be used with some cardinality + deriving ( Eq, Show ) + +-- Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable MaybeUsed where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" + +-- Well-formedness preserving constructors for the Absence domain +countOnce, countMany :: Count +countOnce = One +countMany = Many + +useBot, useTop :: MaybeUsed +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [MaybeUsed] -> UseDmd +mkUProd ux + | all (== Abs) ux = UHead + | otherwise = UProd ux + +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed +lubMaybeUsed Abs x = x +lubMaybeUsed x Abs = x +lubMaybeUsed (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = UProd $ zipWith lubMaybeUsed ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubMaybeUsed` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubMaybeUsed` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed +bothMaybeUsed Abs x = x +bothMaybeUsed x Abs = x +bothMaybeUsed (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = UProd $ zipWith bothMaybeUsed ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothMaybeUsed` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothMaybeUsed` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing + +addCaseBndrDmd :: Demand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd (JD { strd = ms, absd = mu }) alt_dmds + = case mu of + Abs -> alt_dmds + Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) + where + Just ss = splitMaybeStrProdDmd arity ms -- Guaranteed not to be a call + Just us = splitUseProdDmd arity u -- Ditto + where + arity = length alt_dmds + +{- Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to Trac #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis: + f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=] + { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +It's true that ds_dnz is *itself* absent, b ut the use of wild_X7 means +that it is very much alive and demanded. See Trac #10148 for how the +consequences play out. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get , but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; intead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +-} + +-- If a demand is used multiple times (i.e. reused), than any use-once +-- mentioned there, that is not protected by a UCall, can happen many times. +markReusedDmd :: MaybeUsed -> MaybeUsed +markReusedDmd Abs = Abs +markReusedDmd (Use _ a) = Use Many (markReused a) + +markReused :: UseDmd -> UseDmd +markReused (UCall _ u) = UCall Many u -- No need to recurse here +markReused (UProd ux) = UProd (map markReusedDmd ux) +markReused u = u + +isUsedMU :: MaybeUsed -> Bool +-- True <=> markReusedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markReused d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqMaybeUsedList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqMaybeUsedList :: [MaybeUsed] -> () +seqMaybeUsedList [] = () +seqMaybeUsedList (d:ds) = seqMaybeUsed d `seq` seqMaybeUsedList ds + +seqMaybeUsed :: MaybeUsed -> () +seqMaybeUsed (Use c u) = c `seq` seqUseDmd u +seqMaybeUsed _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> Maybe [MaybeUsed] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (Trac #9208) + +{- +************************************************************************ +* * +\subsection{Joint domain for Strictness and Absence} +* * +************************************************************************ +-} + +data JointDmd = JD { strd :: MaybeStr, absd :: MaybeUsed } + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable JointDmd where + ppr (JD {strd = s, absd = a}) = angleBrackets (ppr s <> char ',' <> ppr a) + +-- Well-formedness preserving constructors for the joint domain +mkJointDmd :: MaybeStr -> MaybeUsed -> JointDmd +mkJointDmd s a = JD { strd = s, absd = a } + +mkJointDmds :: [MaybeStr] -> [MaybeUsed] -> [JointDmd] +mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as + +absDmd :: JointDmd +absDmd = mkJointDmd Lazy Abs + +apply1Dmd, apply2Dmd :: Demand +-- C1(U), C1(C1(U)) respectively +apply1Dmd = JD { strd = Lazy, absd = Use Many (UCall One Used) } +apply2Dmd = JD { strd = Lazy, absd = Use Many (UCall One (UCall One Used)) } + +topDmd :: JointDmd +topDmd = mkJointDmd Lazy useTop + +seqDmd :: JointDmd +seqDmd = mkJointDmd (Str HeadStr) (Use One UHead) + +botDmd :: JointDmd +botDmd = mkJointDmd strBot useBot + +lubDmd :: JointDmd -> JointDmd -> JointDmd +lubDmd (JD {strd = s1, absd = a1}) + (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `lubMaybeStr` s2) (a1 `lubMaybeUsed` a2) + +bothDmd :: JointDmd -> JointDmd -> JointDmd +bothDmd (JD {strd = s1, absd = a1}) + (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `bothMaybeStr` s2) (a1 `bothMaybeUsed` a2) + +isTopDmd :: JointDmd -> Bool +isTopDmd (JD {strd = Lazy, absd = Use Many Used}) = True +isTopDmd _ = False + +isBotDmd :: JointDmd -> Bool +isBotDmd (JD {strd = Str HyperStr, absd = Abs}) = True +isBotDmd _ = False + +isAbsDmd :: JointDmd -> Bool +isAbsDmd (JD {absd = Abs}) = True -- The strictness part can be HyperStr +isAbsDmd _ = False -- for a bottom demand + +isSeqDmd :: JointDmd -> Bool +isSeqDmd (JD {strd=Str HeadStr, absd=Use _ UHead}) = True +isSeqDmd _ = False + +-- More utility functions for strictness +seqDemand :: JointDmd -> () +seqDemand (JD {strd = x, absd = y}) = seqMaybeStr x `seq` seqMaybeUsed y `seq` () + +seqDemandList :: [JointDmd] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +isStrictDmd :: Demand -> Bool +-- See Note [Strict demands] +isStrictDmd (JD {absd = Abs}) = False +isStrictDmd (JD {strd = Lazy}) = False +isStrictDmd _ = True + +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {strd = s, absd = a}) = isLazy s && isUsedMU a + +cleanUseDmd_maybe :: JointDmd -> Maybe UseDmd +cleanUseDmd_maybe (JD { absd = Use _ ud }) = Just ud +cleanUseDmd_maybe _ = Nothing + +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = foldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { strd = s, absd = u }) (lazy_fv, sig_fv) + | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) + | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { strd = Lazy, absd = u }) + , addToUFM_Directly sig_fv uniq (JD { strd = s, absd = Abs }) ) + +{- +************************************************************************ +* * +\subsection{Clean demand for Strictness and Usage} +* * +************************************************************************ + +This domain differst from JointDemand in the sence that pure absence +is taken away, i.e., we deal *only* with non-absent demands. + +Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~ +isStrictDmd returns true only of demands that are + both strict + and used +In particular, it is False for , which can and does +arise in, say (Trac #7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In Trac #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [Dealing with call demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Call demands are constructed and deconstructed coherently for +strictness and absence. For instance, the strictness signature for the +following function + +f :: (Int -> (Int, Int)) -> (Int, Bool) +f g = (snd (g 3), True) + +should be: m +-} + +data CleanDemand -- A demand that is at least head-strict + = CD { sd :: StrDmd, ud :: UseDmd } + deriving ( Eq, Show ) + +instance Outputable CleanDemand where + ppr (CD {sd = s, ud = a}) = angleBrackets (ppr s <> comma <> ppr a) + +mkCleanDmd :: StrDmd -> UseDmd -> CleanDemand +mkCleanDmd s a = CD { sd = s, ud = a } + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (CD { sd = s1, ud = a1}) (CD { sd = s2, ud = a2}) + = CD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict (CD { ud = a }) = mkCleanDmd HeadStr a + +oneifyDmd :: JointDmd -> JointDmd +oneifyDmd (JD { strd = s, absd = Use _ a }) = JD { strd = s, absd = Use One a } +oneifyDmd jd = jd + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> JointDmd +mkOnceUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use One a) +mkManyUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use Many a) + +getUsage :: CleanDemand -> UseDmd +getUsage = ud + +evalDmd :: JointDmd +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = mkJointDmd (Str HeadStr) useTop + +mkProdDmd :: [JointDmd] -> CleanDemand +mkProdDmd dx + = mkCleanDmd sp up + where + sp = mkSProd $ map strd dx + up = mkUProd $ map absd dx + +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (CD {sd = d, ud = u}) + = mkCleanDmd (mkSCall d) (mkUCall One u) + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = mkCleanDmd HeadStr Used + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = mkCleanDmd HeadStr (UProd (replicate n useTop)) + +isSingleUsed :: JointDmd -> Bool +isSingleUsed (JD {absd=a}) = is_used_once a + where + is_used_once Abs = True + is_used_once (Use One _) = True + is_used_once _ = False + + +data TypeShape = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +instance Outputable TypeShape where + ppr TsUnk = ptext (sLit "TsUnk") + ppr (TsFun ts) = ptext (sLit "TsFun") <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +trimToType :: JointDmd -> TypeShape -> JointDmd +-- See Note [Trimming a demand to a type] +trimToType (JD ms mu) ts + = JD (go_ms ms ts) (go_mu mu ts) + where + go_ms :: MaybeStr -> TypeShape -> MaybeStr + go_ms Lazy _ = Lazy + go_ms (Str s) ts = Str (go_s s ts) + + go_s :: StrDmd -> TypeShape -> StrDmd + go_s HyperStr _ = HyperStr + go_s (SCall s) (TsFun ts) = SCall (go_s s ts) + go_s (SProd mss) (TsProd tss) + | equalLength mss tss = SProd (zipWith go_ms mss tss) + go_s _ _ = HeadStr + + go_mu :: MaybeUsed -> TypeShape -> MaybeUsed + go_mu Abs _ = Abs + go_mu (Use c u) ts = Use c (go_u u ts) + + go_u :: UseDmd -> TypeShape -> UseDmd + go_u UHead _ = UHead + go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) + go_u (UProd mus) (TsProd tss) + | equalLength mus tss = UProd (zipWith go_mu mus tss) + go_u _ _ = Used + +{- +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, Trac #8569). + +Bottom line: we really don't want to have a binder whose demand is more +deeply-nested than its type. There are various ways to tackle this. +When processing (x |> g1), we could "trim" the incoming demand U(U,U) +to match x's type. But I'm currently doing so just at the moment when +we pin a demand on a binder, in DmdAnal.findBndrDmd. + + +Note [Threshold demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +Threshold usage demand is generated to figure out if +cardinality-instrumented demands of a binding's free variables should +be unleashed. See also [Aggregated demand for cardinality]. + +Note [Replicating polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some demands can be considered as polymorphic. Generally, it is +applicable to such beasts as tops, bottoms as well as Head-Used adn +Head-stricts demands. For instance, + +S ~ S(L, ..., L) + +Also, when top or bottom is occurred as a result demand, it in fact +can be expanded to saturate a callee's arity. +-} + +splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD {strd = s, absd = u}) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +{- +************************************************************************ +* * + Demand results +* * +************************************************************************ + + +DmdResult: Dunno CPRResult + / + Diverges + + +CPRResult: NoCPR + / \ + RetProd RetSum ConTag + + +Product contructors return (Dunno (RetProd rs)) +In a fixpoint iteration, start from Diverges +We have lubs, but not glbs; but that is ok. +-} + +------------------------------------------------------------------------ +-- Constructed Product Result +------------------------------------------------------------------------ + +data Termination r = Diverges -- Definitely diverges + | Dunno r -- Might diverge or converge + deriving( Eq, Show ) + +type DmdResult = Termination CPRResult + +data CPRResult = NoCPR -- Top of the lattice + | RetProd -- Returns a constructor from a product type + | RetSum ConTag -- Returns a constructor from a data type + deriving( Eq, Show ) + +lubCPR :: CPRResult -> CPRResult -> CPRResult +lubCPR (RetSum t1) (RetSum t2) + | t1 == t2 = RetSum t1 +lubCPR RetProd RetProd = RetProd +lubCPR _ _ = NoCPR + +lubDmdResult :: DmdResult -> DmdResult -> DmdResult +lubDmdResult Diverges r = r +lubDmdResult (Dunno c1) Diverges = Dunno c1 +lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +bothDmdResult :: DmdResult -> Termination () -> DmdResult +-- See Note [Asymmetry of 'both' for DmdType and DmdResult] +bothDmdResult _ Diverges = Diverges +bothDmdResult r _ = r +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +instance Outputable DmdResult where + ppr Diverges = char 'b' + ppr (Dunno c) = ppr c + +instance Outputable CPRResult where + ppr NoCPR = empty + ppr (RetSum n) = char 'm' <> int n + ppr RetProd = char 'm' + +seqDmdResult :: DmdResult -> () +seqDmdResult Diverges = () +seqDmdResult (Dunno c) = seqCPRResult c + +seqCPRResult :: CPRResult -> () +seqCPRResult NoCPR = () +seqCPRResult (RetSum n) = n `seq` () +seqCPRResult RetProd = () + + +------------------------------------------------------------------------ +-- Combined demand result -- +------------------------------------------------------------------------ + +-- [cprRes] lets us switch off CPR analysis +-- by making sure that everything uses TopRes +topRes, botRes :: DmdResult +topRes = Dunno NoCPR +botRes = Diverges + +cprSumRes :: ConTag -> DmdResult +cprSumRes tag | opt_CprOff = topRes + | otherwise = Dunno $ RetSum tag + +cprProdRes :: [DmdType] -> DmdResult +cprProdRes _arg_tys + | opt_CprOff = topRes + | otherwise = Dunno $ RetProd + +vanillaCprProdRes :: Arity -> DmdResult +vanillaCprProdRes _arity + | opt_CprOff = topRes + | otherwise = Dunno $ RetProd + +isTopRes :: DmdResult -> Bool +isTopRes (Dunno NoCPR) = True +isTopRes _ = False + +isBotRes :: DmdResult -> Bool +isBotRes Diverges = True +isBotRes _ = False + +trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult +trimCPRInfo trim_all trim_sums res + = trimR res + where + trimR (Dunno c) = Dunno (trimC c) + trimR Diverges = Diverges + + trimC (RetSum n) | trim_all || trim_sums = NoCPR + | otherwise = RetSum n + trimC RetProd | trim_all = NoCPR + | otherwise = RetProd + trimC NoCPR = NoCPR + +returnsCPR_maybe :: DmdResult -> Maybe ConTag +returnsCPR_maybe (Dunno c) = retCPR_maybe c +returnsCPR_maybe Diverges = Nothing + +retCPR_maybe :: CPRResult -> Maybe ConTag +retCPR_maybe (RetSum t) = Just t +retCPR_maybe RetProd = Just fIRST_TAG +retCPR_maybe NoCPR = Nothing + +-- See Notes [Default demand on free variables] +-- and [defaultDmd vs. resTypeArgDmd] +defaultDmd :: Termination r -> JointDmd +defaultDmd Diverges = botDmd +defaultDmd _ = absDmd + +resTypeArgDmd :: DmdResult -> JointDmd +-- TopRes and BotRes are polymorphic, so that +-- BotRes === Bot -> BotRes === ... +-- TopRes === Top -> TopRes === ... +-- This function makes that concrete +-- Also see Note [defaultDmd vs. resTypeArgDmd] +resTypeArgDmd r | isBotRes r = botDmd +resTypeArgDmd _ = topDmd + +{- +Note [defaultDmd and resTypeArgDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These functions are similar: They express the demand on something not +explicitly mentioned in the environment resp. the argument list. Yet they are +different: + * Variables not mentioned in the free variables environment are definitely + unused, so we can use absDmd there. + * Further arguments *can* be used, of course. Hence topDmd is used. + +Note [Worthy functions for Worker-Wrapper split] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For non-bottoming functions a worker-wrapper transformation takes into +account several possibilities to decide if the function is worthy for +splitting: + +1. The result is of product type and the function is strict in some +(or even all) of its arguments. The check that the argument is used is +more of sanity nature, since strictness implies usage. Example: + +f :: (Int, Int) -> Int +f p = (case p of (a,b) -> a) + 1 + +should be splitted to + +f :: (Int, Int) -> Int +f p = case p of (a,b) -> $wf a + +$wf :: Int -> Int +$wf a = a + 1 + +2. Sometimes it also makes sense to perform a WW split if the +strictness analysis cannot say for sure if the function is strict in +components of its argument. Then we reason according to the inferred +usage information: if the function uses its product argument's +components, the WW split can be beneficial. Example: + +g :: Bool -> (Int, Int) -> Int +g c p = case p of (a,b) -> + if c then a else b + +The function g is strict in is argument p and lazy in its +components. However, both components are used in the RHS. The idea is +since some of the components (both in this case) are used in the +right-hand side, the product must presumable be taken apart. + +Therefore, the WW transform splits the function g to + +g :: Bool -> (Int, Int) -> Int +g c p = case p of (a,b) -> $wg c a b + +$wg :: Bool -> Int -> Int -> Int +$wg c a b = if c then a else b + +3. If an argument is absent, it would be silly to pass it to a +function, hence the worker with reduced arity is generated. + + +Note [Worker-wrapper for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to split if the result is bottom. +[Justification: there's no efficiency to be gained.] + +But it's sometimes bad not to make a wrapper. Consider + fw = \x# -> let x = I# x# in case e of + p1 -> error_fn x + p2 -> error_fn x + p3 -> the real stuff +The re-boxing code won't go away unless error_fn gets a wrapper too. +[We don't do reboxing now, but in general it's better to pass an +unboxed thing to f, and have it reboxed in the error cases....] + +However we *don't* want to do this when the argument is not actually +taken apart in the function at all. Otherwise we risk decomposing a +masssive tuple which is barely used. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + +Here, f does not take 'pr' apart, and it's stupid to do so. +Imagine that it had millions of fields. This actually happened +in GHC itself where the tuple was DynFlags + + +************************************************************************ +* * +\subsection{Demand environments and types} +* * +************************************************************************ +-} + +type Demand = JointDmd + +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] + +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + DmdResult -- See [Nature of result demand] + +{- +Note [Nature of result demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A DmdResult contains information about termination (currently distinguishing +definite divergence and no information; it is possible to include definite +convergence here), and CPR information about the result. + +The semantics of this depends on whether we are looking at a DmdType, i.e. the +demand put on by an expression _under a specific incoming demand_ on its +environment, or at a StrictSig describing a demand transformer. + +For a + * DmdType, the termination information is true given the demand it was + generated with, while for + * a StrictSig it is olds after applying enough arguments. + +The CPR information, though, is valid after the number of arguments mentioned +in the type is given. Therefore, when forgetting the demand on arguments, as in +dmdAnalRhs, this needs to be considere (via removeDmdTyArgs). + +Consider + b2 x y = x `seq` y `seq` error (show x) +this has a strictness signature of + b +meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but +for "b2 1 2 `seq` ()" we get definite divergence. + +For comparison, + b1 x = x `seq` error (show x) +has a strictness signature of + b +and "b1 1 `seq` ()" is known to terminate. + +Now consider a function h with signature "", and the expression + e1 = h b1 +now h puts a demand of onto its argument, and the demand transformer +turns it into + b +Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not +diverge, and we do not anything being passed to b. + +Note [Asymmetry of 'both' for DmdType and DmdResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *assymetrical*, because there is only one +result! For example, given (e1 e2), we get a DmdType dt1 for e1, use +its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). +Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `bothType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, but + 4. take CPR info from the first argument. + +3 and 4 are implementd in bothDmdResult. +-} + +-- Equality needed for fixpoints in DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 res1) + (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 + && ds1 == ds2 && res1 == res2 + +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_res + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1 r1) = ensureArgs n d1 + (DmdType fv2 ds2 r2) = ensureArgs n d2 + + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) + lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_res = lubDmdResult r1 r2 + +{- +Note [The need for BothDmdArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the right argument to bothDmdType, as well as the return value of +dmdAnalStar via postProcessDmdTypeM, was a DmdType. But bothDmdType only needs +to know about the free variables and termination information, but nothing about +the demand put on arguments, nor cpr information. So we make that explicit by +only passing the relevant information. +-} + +type BothDmdArg = (DmdEnv, Termination ()) + +mkBothDmdArg :: DmdEnv -> BothDmdArg +mkBothDmdArg env = (env, Dunno ()) + +toBothDmdArg :: DmdType -> BothDmdArg +toBothDmdArg (DmdType fv _ r) = (fv, go r) + where + go (Dunno {}) = Dunno () + go Diverges = Diverges + +bothDmdType :: DmdType -> BothDmdArg -> DmdType +bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'both' for DmdType and DmdResult] + -- 'both' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + = DmdType both_fv ds1 (r1 `bothDmdResult` t2) + where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2) + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [text "DmdType", + hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = ufmToList fv + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +-- nopDmdType is the demand of doing nothing +-- (lazy, absent, no CPR information, no termination information). +-- Note that it is ''not'' the top of the lattice (which would be "may use everything"), +-- so it is (no longer) called topDmd +nopDmdType, botDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topRes +botDmdType = DmdType emptyDmdEnv [] botRes + +cprProdDmdType :: Arity -> DmdType +cprProdDmdType _arity + = DmdType emptyDmdEnv [] (Dunno RetProd) + +isNopDmdType :: DmdType -> Bool +isNopDmdType (DmdType env [] res) + | isTopRes res && isEmptyVarEnv env = True +isNopDmdType _ = False + +mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType +mkDmdType fv ds res = DmdType fv ds res + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds + +-- Remove any demand on arguments. This is used in dmdAnalRhs on the body +removeDmdTyArgs :: DmdType -> DmdType +removeDmdTyArgs = ensureArgs 0 + +-- This makes sure we can use the demand type with n arguments, +-- It extends the argument list with the correct resTypeArgDmd +-- It also adjusts the DmdResult: Divergence survives additional arguments, +-- CPR information does not (and definite converge also would not). +ensureArgs :: Arity -> DmdType -> DmdType +ensureArgs n d | n == depth = d + | otherwise = DmdType fv ds' r' + where depth = dmdTypeDepth d + DmdType fv ds r = d + + ds' = take n (ds ++ repeat (resTypeArgDmd r)) + r' | Diverges <- r = r + | otherwise = topRes + -- See [Nature of result demand] + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqDemandList (varEnvElts env) + + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + +-- When e is evaluated after executing an IO action, and d is e's demand, then +-- what of this demand should we consider, given that the IO action can cleanly +-- exit? +-- * We have to kill all strictness demands (i.e. lub with a lazy demand) +-- * We can keep demand information (i.e. lub with an absent deman) +-- * We have to kill definite divergence +-- * We can keep CPR information. +-- See Note [IO hack in the demand analyser] +deferAfterIO :: DmdType -> DmdType +deferAfterIO d@(DmdType _ _ res) = + case d `lubDmdType` nopDmdType of + DmdType fv ds _ -> DmdType fv ds (defer_res res) + where + defer_res Diverges = topRes + defer_res r = r + +strictenDmd :: JointDmd -> CleanDemand +strictenDmd (JD {strd = s, absd = u}) + = CD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = HeadStr + poke_s (Str s) = s + poke_u Abs = UHead + poke_u (Use _ u) = u + +-- Deferring and peeeling + +type DeferAndUse -- Describes how to degrade a result type + =( Bool -- Lazify (defer) the type + , Count) -- Many => manify the type + +type DeferAndUseM = Maybe DeferAndUse + -- Nothing <=> absent-ify the result type; it will never be used + +toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM) +toCleanDmd (JD { strd = s, absd = u }) expr_ty + = case (s,u) of + (Str s', Use c u') -> -- The normal case + (CD { sd = s', ud = u' }, Just (False, c)) + + (Lazy, Use c u') -> -- See Note [Analyzing with lazy demand and lambdas] + (CD { sd = HeadStr, ud = u' }, Just (True, c)) + + (_, Abs) -- See Note [Analysing with absent demand] + | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One)) + | otherwise -> (CD { sd = HeadStr, ud = Used }, Nothing) + +-- This is used in dmdAnalStar when post-processing +-- a function's argument demand. So we only care about what +-- does to free variables, and whether it terminates. +-- see Note [The need for BothDmdArg] +postProcessDmdTypeM :: DeferAndUseM -> DmdType -> BothDmdArg +postProcessDmdTypeM Nothing _ = (emptyDmdEnv, Dunno ()) + -- Incoming demand was Absent, so just discard all usage information + -- We only processed the thing at all to analyse the body + -- See Note [Always analyse in virgin pass] +postProcessDmdTypeM (Just du) (DmdType fv _ res_ty) + = (postProcessDmdEnv du fv, postProcessDmdResult du res_ty) + +postProcessDmdResult :: DeferAndUse -> DmdResult -> Termination () +postProcessDmdResult (True,_) _ = Dunno () +postProcessDmdResult (False,_) (Dunno {}) = Dunno () +postProcessDmdResult (False,_) Diverges = Diverges + +postProcessDmdEnv :: DeferAndUse -> DmdEnv -> DmdEnv +postProcessDmdEnv (True, Many) env = deferReuseEnv env +postProcessDmdEnv (False, Many) env = reuseEnv env +postProcessDmdEnv (True, One) env = deferEnv env +postProcessDmdEnv (False, One) env = env + + +postProcessUnsat :: DeferAndUse -> DmdType -> DmdType +postProcessUnsat (True, Many) ty = deferReuse ty +postProcessUnsat (False, Many) ty = reuseType ty +postProcessUnsat (True, One) ty = deferType ty +postProcessUnsat (False, One) ty = ty + +deferType, reuseType, deferReuse :: DmdType -> DmdType +deferType (DmdType fv ds _) = DmdType (deferEnv fv) (map deferDmd ds) topRes +reuseType (DmdType fv ds res_ty) = DmdType (reuseEnv fv) (map reuseDmd ds) res_ty +deferReuse (DmdType fv ds _) = DmdType (deferReuseEnv fv) (map deferReuseDmd ds) topRes + +deferEnv, reuseEnv, deferReuseEnv :: DmdEnv -> DmdEnv +deferEnv fv = mapVarEnv deferDmd fv +reuseEnv fv = mapVarEnv reuseDmd fv +deferReuseEnv fv = mapVarEnv deferReuseDmd fv + +deferDmd, reuseDmd, deferReuseDmd :: JointDmd -> JointDmd +deferDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy a +reuseDmd (JD {strd=d, absd=a}) = mkJointDmd d (markReusedDmd a) +deferReuseDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy (markReusedDmd a) + +-- Peels one call level from the demand, and also returns +-- whether it was unsaturated (separately for strictness and usage) +peelCallDmd :: CleanDemand -> (CleanDemand, DeferAndUse) +-- Exploiting the fact that +-- on the strictness side C(B) = B +-- and on the usage side C(U) = U +peelCallDmd (CD {sd = s, ud = u}) + = case (s, u) of + (SCall s', UCall c u') -> (CD { sd = s', ud = u' }, (False, c)) + (SCall s', _) -> (CD { sd = s', ud = Used }, (False, Many)) + (HyperStr, UCall c u') -> (CD { sd = HyperStr, ud = u' }, (False, c)) + (HyperStr, _) -> (CD { sd = HyperStr, ud = Used }, (False, Many)) + (_, UCall c u') -> (CD { sd = HeadStr, ud = u' }, (True, c)) + (_, _) -> (CD { sd = HeadStr, ud = Used }, (True, Many)) + -- The _ cases for usage includes UHead which seems a bit wrong + -- because the body isn't used at all! + -- c.f. the Abs case in toCleanDmd + +-- Peels that multiple nestings of calls clean demand and also returns +-- whether it was unsaturated (separately for strictness and usage +-- see Note [Demands from unsaturated function calls] +peelManyCalls :: Int -> CleanDemand -> DeferAndUse +peelManyCalls n (CD { sd = str, ud = abs }) + = (go_str n str, go_abs n abs) + where + go_str :: Int -> StrDmd -> Bool -- True <=> unsaturated, defer + go_str 0 _ = False + go_str _ HyperStr = False -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) + go_str n (SCall d') = go_str (n-1) d' + go_str _ _ = True + + go_abs :: Int -> UseDmd -> Count -- Many <=> unsaturated, or at least + go_abs 0 _ = One -- one UCall Many in the demand + go_abs n (UCall One d') = go_abs (n-1) d' + go_abs _ _ = Many + +{- +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than . There are a few cases: + * Not enough demand on the strictness side: + - In that case, we need to zap all strictness in the demand on arguments and + free variables. + - Furthermore, we remove CPR information. It could be left, but given the incoming + demand is not enough to evaluate so far we just do not bother. + - And finally termination information: If r says that f diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convegence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Not enough demand from the usage side: The missing usage can be expanded + using UCall Many, therefore this is subsumed by the third case: + * At least one of the uses has a cardinality of Many. + - Even if f puts a One demand on any of its argument or free variables, if + we call f multiple times, we may evaluate this argument or free variable + multiple times. So forget about any occurrence of "One" in the demand. + +In dmdTransformSig, we call peelManyCalls to find out if we are in any of these +cases, and then call postProcessUnsat to reduce the demand appropriately. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables] + dmd = lookupVarEnv fv id `orElse` defaultDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultDmd res + +{- +Note [Default demand on free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the variable is not mentioned in the environment of a demand type, +its demand is taken to be a result demand of the type. + For the stricness component, + if the result demand is a Diverges, then we use HyperStr + else we use Lazy + For the usage component, we use Absent. +So we use either absDmd or botDmd. + +Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just retuned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand . +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand . + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand . The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdTypeM. + +* But in the case of an *unlifted type* we must be extra careful, + because unlifted values are evaluated even if they are not used. + Example (see Trac #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + An alternative would be to replace the 'case y of ...' with (say) 0#, + but I have not tried that. It's not a common situation, but it is + not theoretical: unsafePerformIO's implementation is very very like + 'f' above. + + +************************************************************************ +* * + Demand signatures +* * +************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand +transfomer, namely + + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. +Also see Note [Nature of result demand] for the meaning of a DmdResult in a +strictness signature. + +If an Id is applied to less arguments than its arity, it means that +the demand on the function at a call site is weaker than the vanilla +call demand, used for signature inference. Therefore we place a top +demand on all arguments. Otherwise, the demand is specified by Id's +signature. + +For example, the demand transformer described by the demand signature + StrictSig (DmdType {x -> } m) +says that when the function is applied to two arguments, it +unleashes demand on the free var x, on the first arg, +and on the second, then returning a constructor. + +If this same function is applied to one arg, all we can say is that it +uses x with , and its arg with demand . +-} + +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + +mkStrictSig :: DmdType -> StrictSig +mkStrictSig dmd_ty = StrictSig dmd_ty + +mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig +mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res) + +splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- Add extra arguments to a strictness signature +increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) + = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) + +isNopSig :: StrictSig -> Bool +isNopSig (StrictSig ty) = isNopDmdType ty + +isBottomingSig :: StrictSig -> Bool +isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res + +nopSig, botSig :: StrictSig +nopSig = StrictSig nopDmdType +botSig = StrictSig botDmdType + +cprProdSig :: Arity -> StrictSig +cprProdSig arity = StrictSig (cprProdDmdType arity) + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType +-- (dmdTransformSig fun_sig dmd) considers a call to a function whose +-- signature is fun_sig, with demand dmd. We return the demand +-- that the function places on its context (eg its args) +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd + = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty + -- see Note [Demands from unsaturated function calls] + +dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType +-- Same as dmdTransformSig but for a data constructor (worker), +-- which has a special kind of demand transformer. +-- If the constructor is saturated, we feed the demand on +-- the result into the constructor arguments. +dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) + (CD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res + -- Must remember whether it's a product, hence con_res, not TopRes + + | otherwise -- Not saturated + = nopDmdType + where + go_str 0 dmd = splitStrProdDmd arity dmd + go_str n (SCall s') = go_str (n-1) s' + go_str n HyperStr = go_str (n-1) HyperStr + go_str _ _ = Nothing + + go_abs 0 dmd = splitUseProdDmd arity dmd + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd + | (cd',defer_use) <- peelCallDmd cd + , Just jds <- splitProdDmd_maybe dict_dmd + = postProcessUnsat defer_use $ + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance cd old | isAbsDmd old = old + | otherwise = mkOnceUsedDmd cd -- This is the one! + +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. + +For single-method classes, which are represented by newtypes the signature +of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +That's fine: if we are doing strictness analysis we are also doing inling, +so we'll have inlined 'op' into a cast. So we can bale out in a conservative +way, returning nopDmdType. + +It is (just.. Trac #8329) possible to be running strictness analysis *without* +having inlined class ops from single-method classes. Suppose you are using +ghc --make; and the first module has a local -O0 flag. So you may load a class +without interface pragmas, ie (currently) without an unfolding for the class +ops. Now if a subsequent module in the --make sweep has a local -O flag +you might do strictness analysis, but there is no inlining for the class op. +This is weird, so I'm not worried about whether this optimises brilliantly; but +it should not fall over. +-} + +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info, and ProbOneShot] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + good_one_shot + | unsaturated_call = ProbOneShot + | otherwise = OneShotLam + + go [] = [] + go (arg_d : arg_ds) = argOneShots good_one_shot arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +argOneShots :: OneShotInfo -> JointDmd -> [OneShotInfo] +argOneShots one_shot_info (JD { absd = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = one_shot_info : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] + +{- +Note [Computing one-shot info, and ProbOneShot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. + +But suppose f was not saturated, so the call looks like + f (\pqr. e1) (\xyz. e2) +The in principle this partial application might be shared, and +the (\prq.e1) abstraction might be called more than once. So +we can't mark them OneShot. But instead we return + [[ProbOneShot,NoOneShotInfo,ProbOneShot], [ProbOneShot]] +The occurrence analyser propagates this to the \pqr and \xyz +binders. + +How is it used? Well, it's quite likely that the partial application +of f is not shared, so the float-out pass (in SetLevels.lvlLamBndrs) +does not float MFEs out of a ProbOneShot lambda. That currently is +the only way that ProbOneShot is used. +-} + +-- appIsBottom returns true if an application to n args would diverge +-- See Note [Unsaturated applications] +appIsBottom :: StrictSig -> Int -> Bool +appIsBottom (StrictSig (DmdType _ ds res)) n + | isBotRes res = not $ lengthExceeds ds n +appIsBottom _ _ = False + +{- +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsBottom, which, given a strictness signature and a number +of arguments, says conservatively if the function is going to diverge +or not. + +Zap absence or one-shot information, under control of flags + +Note [Killing usage information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flags -fkill-one-shot and -fkill-absence let you switch off the generation +of absence or one-shot information altogether. This is only used for performance +tests, to see how important they are. +-} + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage (True, True) + +killUsageDemand :: DynFlags -> Demand -> Demand +-- See Note [Killing usage information] +killUsageDemand dflags dmd + | Just kfs <- killFlags dflags = kill_usage kfs dmd + | otherwise = dmd + +killUsageSig :: DynFlags -> StrictSig -> StrictSig +-- See Note [Killing usage information] +killUsageSig dflags sig@(StrictSig (DmdType env ds r)) + | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) + | otherwise = sig + +type KillFlags = (Bool, Bool) + +killFlags :: DynFlags -> Maybe KillFlags +-- See Note [Killing usage information] +killFlags dflags + | not kill_abs && not kill_one_shot = Nothing + | otherwise = Just (kill_abs, kill_one_shot) + where + kill_abs = gopt Opt_KillAbsence dflags + kill_one_shot = gopt Opt_KillOneShot dflags + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u} + +zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed +zap_musg (kill_abs, _) Abs + | kill_abs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u) + +zap_count :: KillFlags -> Count -> Count +zap_count (_, kill_one_shot) c + | kill_one_shot = Many + | otherwise = c + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u + +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case absd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + CD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary + +{- +Note [HyperStr and Use demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The information "HyperStr" needs to be in the strictness signature, and not in +the demand signature, because we still want to know about the demand on things. Consider + + f (x,y) True = error (show x) + f (x,y) False = x+1 + +The signature of f should be m. If we were not +distinguishing the uses on x and y in the True case, we could either not figure +out how deeply we can unpack x, or that we do not have to pass y. + + +************************************************************************ +* * + Serialisation +* * +************************************************************************ +-} + +instance Binary StrDmd where + put_ bh HyperStr = do putByte bh 0 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 + put_ bh s + put_ bh (SProd sx) = do putByte bh 3 + put_ bh sx + get bh = do + h <- getByte bh + case h of + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) + _ -> do sx <- get bh + return (SProd sx) + +instance Binary MaybeStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary MaybeUsed where + put_ bh Abs = do + putByte bh 0 + put_ bh (Use c u) = do + putByte bh 1 + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do + putByte bh 2 + put_ bh c + put_ bh u + put_ bh (UProd ux) = do + putByte bh 3 + put_ bh ux + + get bh = do + h <- getByte bh + case h of + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) + _ -> do ux <- get bh + return (UProd ux) + +instance Binary JointDmd where + put_ bh (JD {strd = x, absd = y}) = do put_ bh x; put_ bh y + get bh = do + x <- get bh + y <- get bh + return $ mkJointDmd x y + +instance Binary StrictSig where + put_ bh (StrictSig aa) = do + put_ bh aa + get bh = do + aa <- get bh + return (StrictSig aa) + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) + = do put_ bh ds + put_ bh dr + get bh + = do ds <- get bh + dr <- get bh + return (DmdType emptyDmdEnv ds dr) + +instance Binary DmdResult where + put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } + put_ bh Diverges = putByte bh 2 + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { c <- get bh; return (Dunno c) } + _ -> return Diverges } + +instance Binary CPRResult where + put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } + put_ bh RetProd = putByte bh 1 + put_ bh NoCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (RetSum n) } + 1 -> return RetProd + _ -> return NoCPR diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs new file mode 100644 index 00000000..780e54d6 --- /dev/null +++ b/compiler/basicTypes/Id.hs @@ -0,0 +1,820 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + +{-# LANGUAGE CPP #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TypeRep.Type' and some additional +-- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that +-- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either +-- be global or local, see "Var#globalvslocal" +-- +-- * 'Var.Var': see "Var#name_types" + +module Id ( + -- * The main types + Var, Id, isId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, + mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, + mkDerivedLocalM, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkWorkerId, mkWiredInIdName, + + -- ** Taking an Id apart + idName, idType, idUnique, idInfo, idDetails, idRepArity, + recordSelectorFieldLabel, + + -- ** Modifying an Id + setIdName, setIdUnique, Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapFragileIdInfo, + zapIdStrictness, + transferPolyIdInfo, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, + isConLikeId, isBottomingId, idIsFrom, + hasNoBinding, + + -- ** Evidence variables + DictId, isDictId, dfunNSilent, isEvVar, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + isOneShotBndr, isOneShotLambda, isProbablyOneShotLambda, + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + isStateHackType, stateHackOneShot, typeOneShot, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, + idOneShotInfo, + idOccInfo, + + -- ** Writing 'IdInfo' fields + setIdUnfoldingLazily, + setIdUnfolding, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + + setIdDemandInfo, + setIdStrictness, + + idDemandInfo, + idStrictness, + + ) where + +#include "HsVersions.h" + +import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) ) + +import IdInfo +import BasicTypes + +-- Imported and re-exported +import Var( Id, DictId, + idInfo, idDetails, globaliseId, varType, + isId, isLocalId, isGlobalId, isExportedId ) +import qualified Var + +import TyCon +import Type +import TysPrim +import DataCon +import Demand +import Name +import Module +import Class +import {-# SOURCE #-} PrimOp (PrimOp) +import ForeignCall +import Maybes +import SrcLoc +import Outputable +import Unique +import UniqSupply +import FastString +import Util +import StaticFlags + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfoldingLazily`, + `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdStrictness` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | ASSERT( isId id ) isLocalId id && isInternalName name + = id + | otherwise + = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info) + -- Try to avoid spack leaks by seq'ing + +modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecesary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo = mkGlobalId VanillaId + + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkLocalId :: Name -> Type -> Id +mkLocalId name ty = mkLocalIdWithInfo name ty + (vanillaIdInfo `setOneShotInfo` typeOneShot ty) + +mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Type -> Id +mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty + +mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) + + +-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty + +mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id +mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc)) + +mkDerivedLocalM :: MonadUnique m => (OccName -> OccName) -> Id -> Type -> m Id +mkDerivedLocalM deriv_name id ty + = getUniqueM >>= (\uniq -> return (mkLocalId (mkDerivedInternalName deriv_name uniq (getName id)) ty)) + +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkSysLocal (fsLit "tpl") (mkBuiltinUnique i) ty + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- +Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIs, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. CoreFVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (Trac #9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in TidyPgm. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise +recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) +recordSelectorFieldLabel id + = case Var.idDetails id of + RecSelId { sel_tycon = tycon } -> (tycon, idName id) + _ -> panic "recordSelectorFieldLabel" + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDFunId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId _ -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +dfunNSilent :: Id -> Int +dfunNSilent id = case Var.idDetails id of + DFunId ns _ -> ns + _ -> pprPanic "dfunSilent: not a dfun:" (ppr id) + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. +-- EXCEPT: unboxed tuples, which definitely have no binding +hasNoBinding id = case Var.idDetails id of + PrimOpId _ -> True -- See Note [Primop wrappers] + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc + _ -> False + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +{- +Note [Primop wrappers] +~~~~~~~~~~~~~~~~~~~~~~ +Currently hasNoBinding claims that PrimOpIds don't have a curried +function definition. But actually they do, in GHC.PrimopWrappers, +which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding +could return 'False' for PrimOpIds. + +But we'd need to add something in CoreToStg to swizzle any unsaturated +applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#. + +Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's +used by GHCi, which does not implement primops direct at all. +-} + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Evidence variables +* * +************************************************************************ +-} + +isEvVar :: Var -> Bool +isEvVar var = isPredTy (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +idRepArity :: Id -> RepArity +idRepArity x = typeRepArity (idArity x) (idType x) + +-- | Returns true if an application to n args would diverge +isBottomingId :: Id -> Bool +isBottomingId id = isBottomingSig (idStrictness id) + +idStrictness :: Id -> StrictSig +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id + +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id + +-- | This predicate says whether the 'Id' has a strict demand placed on it or +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to +-- check separately whether the 'Id' has a so-called \"strict type\" because if +-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict +-- type, we still want @isStrictId id@ to be @True@. +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + (isStrictType (idType id)) || + -- Take the best of both strictnesses - old and new + (isStrictDmd (idDemandInfo id)) + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfoldingLazily :: Id -> Unfolding -> Id +setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfolding) id + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs + +idSpecialisation :: Id -> SpecInfo +idSpecialisation id = specInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptySpecInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> SpecInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Occcurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` NoOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | otherwise = isOneShotLambda var + +-- | Should we apply the state hack to values of this 'Type'? +stateHackOneShot :: OneShotInfo +stateHackOneShot = OneShotLam -- Or maybe ProbOneShot? + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = stateHackOneShot + | otherwise = NoOneShotInfo + +isStateHackType :: Type -> Bool +isStateHackType ty + | opt_NoStateHack + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.lhs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once. +-- You probably want to use 'isOneShotBndr' instead +isOneShotLambda :: Id -> Bool +isOneShotLambda id = case idOneShotInfo id of + OneShotLam -> True + _ -> False + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idOneShotInfo id of + OneShotLam -> True + ProbOneShot -> True + NoOneShotInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | do_upd = setIdOneShotInfo id one_shot + | otherwise = id + where + do_upd = case (idOneShotInfo id, one_shot) of + (NoOneShotInfo, _) -> True + (OneShotLam, _) -> False + (_, NoOneShotInfo) -> False + _ -> True + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +zapIdDemandInfo :: Id -> Id +zapIdDemandInfo = zapInfo zapDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in two places: + FloatOut (long-distance let-floating) + SimplUtils.abstractFloats (short-distance let-floating) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see Trac #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + + old_strictness = strictnessInfo old_info + new_strictness = increaseStrictSigArity arity_increase old_strictness + + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` old_occ_info + `setStrictnessInfo` new_strictness diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs new file mode 100644 index 00000000..4dd03c91 --- /dev/null +++ b/compiler/basicTypes/IdInfo.hs @@ -0,0 +1,519 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +module IdInfo ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + seqIdInfo, megaSeqIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + zapDemandInfo, zapUsageInfo, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + strictnessInfo, setStrictnessInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam, OneBranch, + insideLam, notInsideLam, oneBranch, notOneBranch, + + -- ** The SpecInfo type + SpecInfo(..), + emptySpecInfo, + isEmptySpecInfo, specInfoFreeVars, + specInfoRules, seqSpecInfo, setSpecInfoHead, + specInfo, setSpecInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + ) where + +import CoreSyn + +import Class +import {-# SOURCE #-} PrimOp (PrimOp) +import Name +import VarSet +import BasicTypes +import DataCon +import TyCon +import ForeignCall +import Outputable +import Module +import FastString +import Demand + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setSpecInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setStrictnessInfo`, + `setDemandInfo` + +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: TyCon -- ^ For a data type family, this is the /instance/ 'TyCon' + -- not the family 'TyCon' + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in TcTyClsDecls + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + + | ClassOpId Class -- ^ The 'Id' is a superclass selector or class operation of a class + + | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Int Bool -- ^ A dictionary function. + -- Int = the number of "silent" arguments to the dfun + -- e.g. class D a => C a where ... + -- instance C a => C [a] + -- has is_silent = 1, because the dfun + -- has type dfun :: (D a, C a) => C [a] + -- See Note [Silent superclass arguments] in TcInstDcls + -- + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + +coVarDetails :: IdDetails +coVarDetails = VanillaId + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = ptext (sLit "DataCon") + pp (DataConWrapId _) = ptext (sLit "DataConWrapper") + pp (ClassOpId {}) = ptext (sLit "ClassOp") + pp (PrimOpId _) = ptext (sLit "PrimOp") + pp (FCallId _) = ptext (sLit "ForeignCall") + pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") + pp (DFunId ns nt) = ptext (sLit "DFunId") + <> ppWhen (ns /= 0) (brackets (int ns)) + <> ppWhen nt (ptext (sLit "(nt)")) + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ ptext (sLit "RecSel") + <> ppWhen is_naughty (ptext (sLit "(naughty)")) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- The 'IdInfo' gives information about the value, or definition, of the +-- 'Id'. It does not contain information about the 'Id''s usage, +-- except for 'demandInfo' and 'oneShotInfo'. +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, -- ^ 'Id' arity + specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist + -- See Note [Specialisations and RULES in IdInfo] + unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding + cafInfo :: CafInfo, -- ^ 'Id' CAF info + oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one + inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' + occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program + + strictnessInfo :: StrictSig, -- ^ A strictness signature + + demandInfo :: Demand, -- ^ ID demand information + callArityInfo :: !ArityInfo -- ^ How this is called. + -- n <=> all calls have at least n arguments + } + +-- | Just evaluate the 'IdInfo' to WHNF +seqIdInfo :: IdInfo -> () +seqIdInfo (IdInfo {}) = () + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqSpecInfo (specInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemandInfo (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqStrictnessInfo :: StrictSig -> () +seqStrictnessInfo ty = seqStrictSig ty + +seqDemandInfo :: Demand -> () +seqDemandInfo dmd = seqDemand dmd + +-- Setters + +setSpecInfo :: IdInfo -> SpecInfo -> IdInfo +setSpecInfo info sp = sp `seq` info { specInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid spack leaks by seq'ing + +setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the + = -- unfolding of an imported Id unless necessary + info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.) + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = info { arityInfo = ar } +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = info { callArityInfo = ar } +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = info { cafInfo = caf } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, + specInfo = emptySpecInfo, + unfoldingInfo = noUnfolding, + oneShotInfo = NoOneShotInfo, + inlinePragInfo = defaultInlinePragma, + occInfo = NoOccInfo, + demandInfo = topDmd, + strictnessInfo = nopSig, + callArityInfo = unknownArity + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in MkId. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) +-} + +-- | An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 :: Arity + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [ptext (sLit "Arity"), int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: StrictSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + SpecInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalIdshas an *empty* SpecInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +jsut for convenience really. + +However, LocalIds may have non-empty SpecInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data SpecInfo + = SpecInfo + [CoreRule] + VarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in OccurAnal + +-- | Assume that no specilizations exist: always safe +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet + +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs + +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's +setSpecInfoHead :: Name -> SpecInfo -> SpecInfo +setSpecInfoHead fn (SpecInfo rules fvs) + = SpecInfo (map (setRuleIdName fn) rules) fvs + +seqSpecInfo :: SpecInfo -> () +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). + +-- | Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs") +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ (OneOcc in_lam _ _) = in_lam + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt + _other -> occ + + is_safe_dmd dmd = not (isStrictDmd dmd) + +-- | Remove all demand info on the 'IdInfo' +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info = Just (info {demandInfo = topDmd}) + +-- | Remove usage (but not strictness) info on the 'IdInfo' +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info + = Just (info `setSpecInfo` emptySpecInfo + `setUnfoldingInfo` noUnfolding + `setOccInfo` zapFragileOcc occ) + where + occ = occInfo info + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = ptext (sLit "tick") <+> ppr (mod,n) diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot new file mode 100644 index 00000000..2e986294 --- /dev/null +++ b/compiler/basicTypes/IdInfo.hs-boot @@ -0,0 +1,8 @@ +module IdInfo where +import Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +pprIdDetails :: IdDetails -> SDoc diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs new file mode 100644 index 00000000..a2409614 --- /dev/null +++ b/compiler/basicTypes/Lexeme.hs @@ -0,0 +1,261 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in Lexer.x, but sadly there seems to be way to merge them. + +module Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import FastString +import Util ((<||>)) + +import Data.Char +import qualified Data.Set as Set + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +------------- +startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool +startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors +startsVarId c = c == '_' || case generalCategory c of -- Ordinary Ids + LowercaseLetter -> True + OtherLetter -> True -- See #1103 + _ -> False +startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors + +startsVarSymASCII :: Char -> Bool +startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" + +isVarSymChar :: Char -> Bool +isVarSymChar c = c == ':' || startsVarSym c + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + not (str `Set.member` reservedIds) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 str + where + -- check for tuple name, starting at the beginning + is_tuple_name1 ('(' : rest) = is_tuple_name2 rest + is_tuple_name1 _ = False + + -- check for tuple tail + is_tuple_name2 ")" = True + is_tuple_name2 (',' : rest) = is_tuple_name2 rest + is_tuple_name2 (ws : rest) + | isSpace ws = is_tuple_name2 rest + is_tuple_name2 _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + -- TODO. #10196. Only allow modifier letters in the suffix of an identifier. + = let hashes = dropWhile (okIdChar <||> okIdSuffixChar) str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in Lexer.x +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + OtherLetter -> True + TitlecaseLetter -> True + DecimalNumber -> True + OtherNumber -> True + _ -> c == '\'' || c == '_' + +-- | Is this character acceptable in the suffix of an identifier. +-- See alexGetByte in Lexer.x +okIdSuffixChar :: Char -> Bool +okIdSuffixChar c = case generalCategory c of + ModifierLetter -> True -- See #10196 + _ -> False + +-- | Is this character acceptable in a symbol (after the first char)? +-- See alexGetByte in Lexer.x +okSymChar :: Char -> Bool +okSymChar c + | c `elem` specialSymbols + = False + | c `elem` "_\"'" + = False + | otherwise + = case generalCategory c of + ConnectorPunctuation -> True + DashPunctuation -> True + OtherPunctuation -> True + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + _ -> False + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "foreign", "if", "import", "in" + , "infix", "infixl", "infixr", "instance", "let" + , "module", "newtype", "of", "then", "type", "where" + , "_" ] + +-- | All punctuation that cannot appear in symbols. See $special in Lexer.x. +specialSymbols :: [Char] +specialSymbols = "(),;[]`{}" + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report. +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "@", "~", "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs new file mode 100644 index 00000000..cb0be034 --- /dev/null +++ b/compiler/basicTypes/Literal.hs @@ -0,0 +1,493 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[Literal]{@Literal@: Machine literals (unboxed, of course)} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + + -- ** Creating Literals + , mkMachInt, mkMachWord + , mkMachInt64, mkMachWord64 + , mkMachFloat, mkMachDouble + , mkMachChar, mkMachString + , mkLitInteger + + -- ** Operations on Literals + , literalType + , hashLiteral + , absentLiteralOf + , pprLiteral + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange + , isZeroLit + , litFitsInChar + + -- ** Coercions + , word2IntLit, int2WordLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import TysPrim +import PrelNames +import Type +import TyCon +import Outputable +import FastTypes +import FastString +import BasicTypes +import Binary +import Constants +import DynFlags +import UniqFM +import Util + +import Data.ByteString (ByteString) +import Data.Int +import Data.Ratio +import Data.Word +import Data.Char +import Data.Data ( Data, Typeable ) +import Numeric ( fromRat ) + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.), +-- which is presumed to be surrounded by appropriate constructors +-- (@Int#@, etc.), so that the overall thing makes sense. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('MachLabel') +data Literal + = ------------------ + -- First the primitive guys + MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar' + + | MachStr ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @'\0'@ + -- terminator. Create with 'mkMachString' + + | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt' + | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64' + | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord' + | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64' + + | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat' + | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' + + | MachLabel FastString + (Maybe Int) + FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\@ will + -- be appended to label name when emitting assembly. + + | LitInteger Integer Type -- ^ Integer literals + -- See Note [Integer literals] + deriving (Data, Typeable) + +{- +Note [Integer literals] +~~~~~~~~~~~~~~~~~~~~~~~ +An Integer literal is represented using, well, an Integer, to make it +easier to write RULEs for them. They also contain the Integer type, so +that e.g. literalType can return the right Type for them. + +They only get converted into real Core, + mkInteger [c1, c2, .., cn] +during the CorePrep phase, although TidyPgm looks ahead at what the +core will be, so that it can see whether it involves CAFs. + +When we initally build an Integer literal, notably when +deserialising it from an interface file (see the Binary instance +below), we don't have convenient access to the mkInteger Id. So we +just use an error thunk, and fill in the real Id when we do tcIfaceLit +in TcIface. + + +Binary instance +-} + +instance Binary Literal where + put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa + put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab + put_ bh (MachNullAddr) = do putByte bh 2 + put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad + put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae + put_ bh (MachWord af) = do putByte bh 5; put_ bh af + put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag + put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah + put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai + put_ bh (MachLabel aj mb fod) + = do putByte bh 9 + put_ bh aj + put_ bh mb + put_ bh fod + put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (MachChar aa) + 1 -> do + ab <- get bh + return (MachStr ab) + 2 -> do + return (MachNullAddr) + 3 -> do + ad <- get bh + return (MachInt ad) + 4 -> do + ae <- get bh + return (MachInt64 ae) + 5 -> do + af <- get bh + return (MachWord af) + 6 -> do + ag <- get bh + return (MachWord64 ag) + 7 -> do + ah <- get bh + return (MachFloat ah) + 8 -> do + ai <- get bh + return (MachDouble ai) + 9 -> do + aj <- get bh + mb <- get bh + fod <- get bh + return (MachLabel aj mb fod) + _ -> do + i <- get bh + -- See Note [Integer literals] + return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger") + +instance Outputable Literal where + ppr lit = pprLiteral (\d -> d) lit + +instance Eq Literal where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord Literal where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpLit a b + +{- + Construction + ~~~~~~~~~~~~ +-} + +-- | Creates a 'Literal' of type @Int#@ +mkMachInt :: DynFlags -> Integer -> Literal +mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) + MachInt x + +-- | Creates a 'Literal' of type @Word#@ +mkMachWord :: DynFlags -> Integer -> Literal +mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) + MachWord x + +-- | Creates a 'Literal' of type @Int64#@ +mkMachInt64 :: Integer -> Literal +mkMachInt64 x = MachInt64 x + +-- | Creates a 'Literal' of type @Word64#@ +mkMachWord64 :: Integer -> Literal +mkMachWord64 x = MachWord64 x + +-- | Creates a 'Literal' of type @Float#@ +mkMachFloat :: Rational -> Literal +mkMachFloat = MachFloat + +-- | Creates a 'Literal' of type @Double#@ +mkMachDouble :: Rational -> Literal +mkMachDouble = MachDouble + +-- | Creates a 'Literal' of type @Char#@ +mkMachChar :: Char -> Literal +mkMachChar = MachChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkMachString :: String -> Literal +-- stored UTF-8 encoded +mkMachString s = MachStr (fastStringToByteString $ mkFastString s) + +mkLitInteger :: Integer -> Type -> Literal +mkLitInteger = LitInteger + +inIntRange, inWordRange :: DynFlags -> Integer -> Bool +inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags +inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (MachInt 0) = True +isZeroLit (MachInt64 0) = True +isZeroLit (MachWord 0) = True +isZeroLit (MachWord64 0) = True +isZeroLit (MachFloat 0) = True +isZeroLit (MachDouble 0) = True +isZeroLit _ = False + +{- + Coercions + ~~~~~~~~~ +-} + +narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal +word2IntLit dflags (MachWord w) + | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1) + | otherwise = MachInt w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) + +int2WordLit dflags (MachInt i) + | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD + | otherwise = MachWord i +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) + +narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) +narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l) +narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) +narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l) +narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) +narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l) +narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) +narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l) +narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) +narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l) +narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) +narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l) + +char2IntLit (MachChar c) = MachInt (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) + +float2IntLit (MachFloat f) = MachInt (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (MachInt i) = MachFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) + +double2IntLit (MachDouble f) = MachInt (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (MachInt i) = MachDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) + +float2DoubleLit (MachFloat f) = MachDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (MachDouble d) = MachFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = MachNullAddr + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings +litIsTrivial :: Literal -> Bool +-- c.f. CoreUtils.exprIsTrivial +litIsTrivial (MachStr _) = False +litIsTrivial (LitInteger {}) = False +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +-- Currently we treat it just like 'litIsTrivial' +litIsDupable :: DynFlags -> Literal -> Bool +-- c.f. CoreUtils.exprIsDupable +litIsDupable _ (MachStr _) = False +litIsDupable dflags (LitInteger i _) = inIntRange dflags i +litIsDupable _ _ = True + +litFitsInChar :: Literal -> Bool +litFitsInChar (MachInt i) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitInteger {}) = True +litIsLifted _ = False + +{- + Types + ~~~~~ +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType MachNullAddr = addrPrimTy +literalType (MachChar _) = charPrimTy +literalType (MachStr _) = addrPrimTy +literalType (MachInt _) = intPrimTy +literalType (MachWord _) = wordPrimTy +literalType (MachInt64 _) = int64PrimTy +literalType (MachWord64 _) = word64PrimTy +literalType (MachFloat _) = floatPrimTy +literalType (MachDouble _) = doublePrimTy +literalType (MachLabel _ _ _) = addrPrimTy +literalType (LitInteger _ t) = t + +absentLiteralOf :: TyCon -> Maybe Literal +-- Return a literal of the appropriate primtive +-- TyCon, to use as a placeholder when it doesn't matter +absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) + +absent_lits :: UniqFM Literal +absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) + , (charPrimTyConKey, MachChar 'x') + , (intPrimTyConKey, MachInt 0) + , (int64PrimTyConKey, MachInt64 0) + , (floatPrimTyConKey, MachFloat 0) + , (doublePrimTyConKey, MachDouble 0) + , (wordPrimTyConKey, MachWord 0) + , (word64PrimTyConKey, MachWord64 0) ] + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (MachChar a) (MachChar b) = a `compare` b +cmpLit (MachStr a) (MachStr b) = a `compare` b +cmpLit (MachNullAddr) (MachNullAddr) = EQ +cmpLit (MachInt a) (MachInt b) = a `compare` b +cmpLit (MachWord a) (MachWord b) = a `compare` b +cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b +cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b +cmpLit (MachFloat a) (MachFloat b) = a `compare` b +cmpLit (MachDouble a) (MachDouble b) = a `compare` b +cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b +cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b +cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT + | otherwise = GT + +litTag :: Literal -> FastInt +litTag (MachChar _) = _ILIT(1) +litTag (MachStr _) = _ILIT(2) +litTag (MachNullAddr) = _ILIT(3) +litTag (MachInt _) = _ILIT(4) +litTag (MachWord _) = _ILIT(5) +litTag (MachInt64 _) = _ILIT(6) +litTag (MachWord64 _) = _ILIT(7) +litTag (MachFloat _) = _ILIT(8) +litTag (MachDouble _) = _ILIT(9) +litTag (MachLabel _ _ _) = _ILIT(10) +litTag (LitInteger {}) = _ILIT(11) + +{- + Printing + ~~~~~~~~ +* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") + exceptions: MachFloat gets an initial keyword prefix. +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +-- The function is used on non-atomic literals +-- to wrap parens around literals that occur in +-- a context requiring an atomic thing +pprLiteral _ (MachChar ch) = pprHsChar ch +pprLiteral _ (MachStr s) = pprHsBytes s +pprLiteral _ (MachInt i) = pprIntVal i +pprLiteral _ (MachDouble d) = double (fromRat d) +pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL") +pprLiteral add_par (LitInteger i _) = add_par (ptext (sLit "__integer") <+> integer i) +pprLiteral add_par (MachInt64 i) = add_par (ptext (sLit "__int64") <+> integer i) +pprLiteral add_par (MachWord w) = add_par (ptext (sLit "__word") <+> integer w) +pprLiteral add_par (MachWord64 w) = add_par (ptext (sLit "__word64") <+> integer w) +pprLiteral add_par (MachFloat f) = add_par (ptext (sLit "__float") <+> float (fromRat f)) +pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod) + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) + +pprIntVal :: Integer -> SDoc +-- ^ Print negative integers with parens to be sure it's unambiguous +pprIntVal i | i < 0 = parens (integer i) + | otherwise = integer i + +{- +************************************************************************ +* * +\subsection{Hashing} +* * +************************************************************************ + +Hash values should be zero or a positive integer. No negatives please. +(They mess up the UniqFM for some reason.) +-} + +hashLiteral :: Literal -> Int +hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints +hashLiteral (MachStr s) = hashByteString s +hashLiteral (MachNullAddr) = 0 +hashLiteral (MachInt i) = hashInteger i +hashLiteral (MachInt64 i) = hashInteger i +hashLiteral (MachWord i) = hashInteger i +hashLiteral (MachWord64 i) = hashInteger i +hashLiteral (MachFloat r) = hashRational r +hashLiteral (MachDouble r) = hashRational r +hashLiteral (MachLabel s _ _) = hashFS s +hashLiteral (LitInteger i _) = hashInteger i + +hashRational :: Rational -> Int +hashRational r = hashInteger (numerator r) + +hashInteger :: Integer -> Int +hashInteger i = 1 + abs (fromInteger (i `rem` 10000)) + -- The 1+ is to avoid zero, which is a Bad Number + -- since we use * to combine hash values + +hashFS :: FastString -> Int +hashFS s = iBox (uniqueOfFS s) diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs new file mode 100644 index 00000000..c3a9f9a7 --- /dev/null +++ b/compiler/basicTypes/MkId.hs @@ -0,0 +1,1397 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# LANGUAGE CPP #-} + +module MkId ( + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + + mkPrimOpId, mkFCallId, + + wrapNewTypeBody, unwrapNewTypeBody, + wrapFamInstBody, unwrapFamInstScrut, + wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut, + unwrapTypeUnbranchedFamInstScrut, + + DataConBoxer(..), mkDataConRep, mkDataConWorkId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + unsafeCoerceName, unsafeCoerceId, realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, magicDictId, coerceId, + proxyHashId, + + -- Re-export error Ids + module PrelRules + ) where + +#include "HsVersions.h" + +import Rules +import TysPrim +import TysWiredIn +import PrelRules +import Type +import FamInstEnv +import Coercion +import TcType +import MkCore +import CoreUtils ( exprType, mkCast ) +import CoreUnfold +import Literal +import TyCon +import CoAxiom +import Class +import NameSet +import VarSet +import Name +import PrimOp +import ForeignCall +import DataCon +import Id +import IdInfo +import Demand +import CoreSyn +import Unique +import UniqSupply +import PrelNames +import BasicTypes hiding ( SuccessFlag(..) ) +import Util +import Pair +import DynFlags +import Outputable +import FastString +import ListSetOps + +import Data.Maybe ( maybeToList ) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +There are several reasons why an Id might appear in the wiredInIds: + +(1) The ghcPrimIds are wired in because they can't be defined in + Haskell at all, although the can be defined in Core. They have + compulsory unfoldings, so they are always inlined and they have + no definition site. Their home module is GHC.Prim, so they + also have a description in primops.txt.pp, where they are called + 'pseudoops'. + +(2) The 'error' function, eRROR_ID, is wired in because we don't yet have + a way to express in an interface file that the result type variable + is 'open'; that is can be unified with an unboxed type + + [The interface file format now carry such information, but there's + no way yet of expressing at the definition site for these + error-reporting functions that they have an 'open' + result type. -- sof 1/99] + +(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because + the desugarer generates code that mentiones them directly, and + (b) for the same reason as eRROR_ID + +(4) lazyId is wired in because the wired-in version overrides the + strictness of the version defined in GHC.Base + +In cases (2-4), the function has a definition in a library module, and +can be called; but the wired-in version means that the details are +never read from that module's interface file; instead, the full definition +is right here. +-} + +wiredInIds :: [Id] +wiredInIds + = [lazyId, dollarId, oneShotId] + ++ errorIds -- Defined in MkCore + ++ ghcPrimIds + +-- These Ids are exported from GHC.Prim +ghcPrimIds :: [Id] +ghcPrimIds + = [ -- These can't be defined in Haskell, but they have + -- perfectly reasonable unfoldings in Core + realWorldPrimId, + voidPrimId, + unsafeCoerceId, + nullAddrId, + seqId, + magicDictId, + coerceId, + proxyHashId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +This is unlike ordinary record selectors, which have all the for-alls +at the outside. When dealing with classes it's very convenient to +recover the original type signature from the class op selector. +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) + (getNth arg_tys val_index)) + + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index) + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma + + | otherwise + = base_info `setSpecInfo` mkSpecInfo [rule] + -- Add a magic BuiltinRule, but no unfolding + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls + + n_ty_args = length tyvars + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + + strict_sig = mkClosedStrictSig [arg_dmd] topRes + arg_dmd | new_tycon = evalDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 arg_tys + + rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +dictSelRule val_index n_ty_args _ id_unf _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon + = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info + + where + tycon = dataConTyCon data_con + + ----------- Workers for data types -------------- + alg_wkr_ty = dataConRepType data_con + wkr_arity = dataConRepArity data_con + wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setStrictnessInfo` wkr_sig + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + + wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) + -- Note [Data-con worker strictness] + -- Notice that we do *not* say the worker is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* is strict (and its unfolding has case + -- expresssions that do the evals) but the *worker* itself is not. + -- If we pretend it is strict then when we see + -- case x of y -> $wMkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- $wMkT is strict) and drops the case. No, $wMkT is not strict. + -- + -- When the simplifer sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + ----------- Workers for newtypes -------------- + (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con + res_ty_args = mkTyVarTys nt_tvs + nt_wrap_ty = dataConUserType data_con + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` newtype_unf + id_arg1 = mkTemplateLocal 1 (head nt_arg_tys) + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton nt_arg_tys, ppr data_con ) + -- Note [Newtype datacons] + mkCompulsoryUnfolding $ + mkLams nt_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +dataConCPR :: DataCon -> DmdResult +dataConCPR con + | isDataTyCon tycon -- Real data types only; that is, + -- not unboxed tuples or newtypes + , isVanillaDataCon con -- No existentials + , wkr_arity > 0 + , wkr_arity <= mAX_CPR_SIZE + = if is_prod then vanillaCprProdRes (dataConRepArity con) + else cprSumRes (dataConTag con) + | otherwise + = topRes + where + is_prod = isProductTyCon tycon + tycon = dataConTyCon con + wkr_arity = dataConRepArity con + + mAX_CPR_SIZE :: Arity + mAX_CPR_SIZE = 10 + -- We do not treat very big tuples as CPR-ish: + -- a) for a start we get into trouble because there aren't + -- "enough" unboxed tuple types (a tiresome restriction, + -- but hard to fix), + -- b) more importantly, big unboxed tuples get returned mainly + -- on the stack, and are often then allocated in the heap + -- by the caller. So doing CPR for them may in fact make + -- things worse. + +{- +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep +mkDataConRep dflags fam_envs wrap_name data_con + | not wrapper_reqd + = return NoDataConRep + + | otherwise + = do { wrap_args <- mapM newLocal wrap_arg_tys + ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` wrap_unf + `setStrictnessInfo` wrap_sig + -- We need to get the CAF info right here because TidyPgm + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + + wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) + wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs) + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + -- The Cpr info can be important inside INLINE rhss, where the + -- wrapper constructor isn't inlined. + -- And the argument strictness can be important too; we + -- may not inline a contructor when it is partially applied. + -- For example: + -- data W = C !Int !Int !Int + -- ...(let w = C x in ...(w p q)...)... + -- we want to see that w is strict in its two arguments + + wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs + wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs + wrap_rhs = mkLams wrap_tvs $ + mkLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys + , dcr_stricts = rep_strs + , dcr_bangs = dropList ev_tys wrap_bangs }) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con + res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConUserType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = ev_tys ++ orig_arg_tys + orig_bangs = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con + + wrap_arg_tys = theta ++ orig_arg_tys + wrap_arity = length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + (wrap_bangs, rep_tys_w_strs, wrappers) + = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs) + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker + && (any isBanged orig_bangs -- Some forcing/unboxing + -- (includes eq_spec) + || isFamInstTyCon tycon) -- Cast result + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . snd) eq_spec + -- Dont box the eq_spec coercions since they are + -- marked as HsUnpack by mk_dict_strict_mark + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let ex_vars = takeList ex_tvs src_vars + subst1 = mkTopTvSubst (univ_tvs `zip` ty_args) + subst2 = extendTvSubstList subst1 ex_tvs + (mkTyVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars) + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + +------------------------- +newLocal :: Type -> UniqSM Var +newLocal ty = do { uniq <- getUniqueM + ; return (mkSysLocal (fsLit "dt") uniq ty) } + +------------------------- +dataConArgRep + :: DynFlags + -> FamInstEnvs + -> Type + -> HsSrcBang -- For DataCons defined in this module, this is the + -- bang/unpack annotation that the programmer wrote + -- For DataCons imported from an interface file, this + -- is the HsImplBang implementation decision taken + -- by the compiler in the defining module; just follow + -- it slavishly, so that we make the same decision as + -- in the defining module + -> ( HsImplBang -- Implementation decision about unpack strategy + , [(Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgRep _ _ arg_ty HsNoBang + = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep _ _ arg_ty (HsSrcBang _ _ False) -- No '!' + = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep dflags fam_envs arg_ty + (HsSrcBang _ unpk_prag True) -- {-# UNPACK #-} ! + | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas + -- Don't unpack if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , let mb_co = topNormaliseType_maybe fam_envs arg_ty + -- Unwrap type families and newtypes + arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } + , isUnpackableType fam_envs arg_ty' + , (rep_tys, wrappers) <- dataConArgUnpack arg_ty' + , case unpk_prag of + Nothing -> gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && length rep_tys <= 1) -- See Note [Unpack one-wide fields] + Just unpack_me -> unpack_me + = case mb_co of + Nothing -> (HsUnpack Nothing, rep_tys, wrappers) + Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers) + + | otherwise -- Record the strict-but-no-unpack decision + = strict_but_not_unpacked arg_ty + +dataConArgRep _ _ arg_ty HsStrict + = strict_but_not_unpacked arg_ty + +dataConArgRep _ _ arg_ty (HsUnpack Nothing) + | (rep_tys, wrappers) <- dataConArgUnpack arg_ty + = (HsUnpack Nothing, rep_tys, wrappers) + +dataConArgRep _ _ _ (HsUnpack (Just co)) + | let co_rep_ty = pSnd (coercionKind co) + , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty + = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers) + +strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer)) +strict_but_not_unpacked arg_ty + = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal rep_ty + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCo (tvCvSubst subst) co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +seqUnboxer :: Unboxer +seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)]) + +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- +dataConArgUnpack + :: Type + -> ( [(Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgUnpack arg_ty + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + , Just con <- tyConSingleAlgDataCon_maybe tc + -- NB: check for an *algebraic* data type + -- A recursive newtype might mean that + -- 'arg_ty' is a newtype + , let rep_tys = dataConInstArgTys con tc_args + = ASSERT( isVanillaDataCon con ) + ( rep_tys `zip` dataConRepStrictness con + ,( \ arg_id -> + do { rep_ids <- mapM newLocal rep_tys + ; let unbox_fn body + = Case (Var arg_id) arg_id (exprType body) + [(DataAlt con, rep_ids, body)] + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTys subst tc_args) + `mkVarApps` rep_ids ) } ) ) + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +isUnpackableType :: FamInstEnvs -> Type -> Bool +-- True if we can unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +isUnpackableType fam_envs ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just con <- tyConSingleAlgDataCon_maybe tc + , isVanillaDataCon con + = ok_con_args (unitNameSet (getName tc)) con + | otherwise + = False + where + ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + ok_ty tcs ty + | Just (tc, _) <- splitTyConApp_maybe ty + , let tc_name = getName tc + = not (tc_name `elemNameSet` tcs) + && case tyConSingleAlgDataCon_maybe tc of + Just con | isVanillaDataCon con + -> ok_con_args (tcs `extendNameSet` getName tc) con + _ -> True + | otherwise + = True + + ok_con_args tcs con + = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + + attempt_unpack (HsUnpack {}) = True + attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk + attempt_unpack (HsSrcBang _ Nothing bang) = bang -- Be conservative + attempt_unpack HsStrict = False + attempt_unpack HsNoBang = False + +{- +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Here is a more complicated case: + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int +Each of S and T must decide independendently whether to unpack +and they had better not both say yes. So they must both say no. + +Also behave conservatively when there is no UNPACK pragma + data T = MkS !T Int +with -funbox-strict-fields or -funbox-small-strict-fields +we need to behave as if there was an UNPACK pragma there. + +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + + +Note [Unpack equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a GADT with a contructor C :: (a~[b]) => b -> T a +we definitely want that equality predicate *unboxed* so that it +takes no space at all. This is easily done: just give it +an UNPACK pragma. The rest of the unpack/repack code does the +heavy lifting. This one line makes every GADT take a word less +space for each equality predicate, so it's pretty important! +-} + +mk_pred_strict_mark :: PredType -> HsSrcBang +mk_pred_strict_mark pred + | isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates] + | otherwise = HsNoBang + +{- +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon assoicated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops +-- +-- If the we are dealing with a newtype *instance*, we have a second coercion +-- identifying the family instance with the constructor of the newtype +-- instance. This coercion is applied in any case (ie, composed with the +-- coercion constructor of the newtype or applied by itself). + +wrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + wrapFamInstBody tycon args $ + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a spliting operation (cf, TcPat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args)) + | otherwise + = body + +-- Same as `wrapFamInstBody`, but for type family instances, which are +-- represented by a `CoAxiom`, and not a `TyCon` +wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr +wrapTypeFamInstBody axiom ind args body + = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args)) + +wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr +wrapTypeUnbranchedFamInstBody axiom + = wrapTypeFamInstBody axiom 0 + +unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapFamInstScrut tycon args scrut + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only + | otherwise + = scrut + +unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr +unwrapTypeFamInstScrut axiom ind args scrut + = mkCast scrut (mkAxInstCo Representational axiom ind args) + +unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr +unwrapTypeUnbranchedFamInstScrut axiom + = unwrapTypeFamInstScrut axiom 0 + +{- +************************************************************************ +* * +\subsection{Primitive operations} +* * +************************************************************************ +-} + +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + info = noCafIdInfo + `setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setInlinePragInfo` neverInlinePragma + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf Trac #7287 + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty + = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setStrictnessInfo` strict_sig + + (_, tau) = tcSplitForAllTys ty + (arg_tys, _) = tcSplitFunTys tau + arity = length arg_tys + + strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doen't + -- necessarily force them. See Trac #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see TcInstDcls) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId n_silent is_nt) + dfun_name + dfun_ty + where + is_nt = isNewTyCon (classTyCon clas) + (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type) +mkDictFunTy tvs theta clas tys + = (length silent_theta, dfun_ty) + where + dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys) + silent_theta + | null tvs, null theta + = [] + | otherwise + = filterOut discard $ + substTheta (zipTopTvSubst (classTyVars clas) tys) + (classSCTheta clas) + -- See Note [Silent Superclass Arguments] + discard pred = any (`eqPred` pred) theta + -- See the DFun Superclass Invariant in TcInstDcls + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that +just gets expanded into a type coercion wherever it occurs. Hence we +add it as a built-in Id with an unfolding here. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. +-} + +lazyIdName, unsafeCoerceName, nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + magicDictName, coerceName, proxyName, dollarName, oneShotName :: Name +unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId +dollarName = mkWiredInIdName gHC_BASE (fsLit "$") dollarIdKey dollarId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId + +dollarId :: Id -- Note [dollarId magic] +dollarId = pcMiscPrelId dollarName ty + (noCafIdInfo `setUnfoldingInfo` unf) + where + fun_ty = mkFunTy alphaTy openBetaTy + ty = mkForAllTys [alphaTyVar, openBetaTyVar] $ + mkFunTy fun_ty fun_ty + unf = mkInlineUnfolding (Just 2) rhs + [f,x] = mkTemplateLocals [fun_ty, alphaTy] + rhs = mkLams [alphaTyVar, openBetaTyVar, f, x] $ + App (Var f) (Var x) + +------------------------------------------------ +-- proxy# :: forall a. Proxy# a +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] + where + ty = mkForAllTys [kv, tv] (mkProxyPrimTy k t) + kv = kKiVar + k = mkTyVarTy kv + tv:_ = tyVarList k + t = mkTyVarTy tv + +------------------------------------------------ +-- unsafeCoerce# :: forall a b. a -> b +unsafeCoerceId :: Id +unsafeCoerceId + = pcMiscPrelId unsafeCoerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + + ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] + (mkFunTy openAlphaTy openBetaTy) + [x] = mkTemplateLocals [openAlphaTy] + rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ + Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy) + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason is is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setSpecInfo` mkSpecInfo [seq_cast_rule] + + inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see CoreSubst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + ty = mkForAllTys [alphaTyVar,betaTyVar] + (mkFunTy alphaTy (mkFunTy betaTy betaTy)) + -- NB argBetaTyVar; see Note [seqId magic] + + [x,y] = mkTemplateLocals [alphaTy, betaTy] + rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) + + -- See Note [Built-in RULES for seq] + -- NB: ru_nargs = 3, not 4, to match the code in + -- Simplify.rebuildCase which tries to apply this rule + seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast" + , ru_fn = seqName + , ru_nargs = 3 + , ru_try = match_seq_of_cast } + +match_seq_of_cast :: RuleFun + -- See Note [Built-in RULES for seq] +match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co] + = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, + scrut]) +match_seq_of_cast _ _ _ _ = Nothing + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo + ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) + +oneShotId :: Id -- See Note [The oneShot function] +oneShotId = pcMiscPrelId oneShotName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkForAllTys [alphaTyVar, betaTyVar] (mkFunTy fun_ty fun_ty) + fun_ty = mkFunTy alphaTy betaTy + [body, x] = mkTemplateLocals [fun_ty, alphaTy] + x' = setOneShotLambda x + rhs = mkLams [alphaTyVar, betaTyVar, body, x'] $ Var body `App` Var x + + +-------------------------------------------------------------------------------- +magicDictId :: Id -- See Note [magicDictId magic] +magicDictId = pcMiscPrelId magicDictName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + ty = mkForAllTys [alphaTyVar] alphaTy + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcMiscPrelId coerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + eqRTy = mkTyConApp coercibleTyCon [liftedTypeKind, alphaTy, betaTy] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [liftedTypeKind, alphaTy, betaTy] + ty = mkForAllTys [alphaTyVar, betaTyVar] $ + mkFunTys [eqRTy, alphaTy] betaTy + + [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] + rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ + mkWildCase (Var eqR) eqRTy betaTy $ + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))] + +{- +Note [dollarId magic] +~~~~~~~~~~~~~~~~~~~~~ +The only reason that ($) is wired in is so that its type can be + forall (a:*, b:Open). (a->b) -> a -> b +That is, the return type can be unboxed. E.g. this is OK + foo $ True where foo :: Bool -> Int# +because ($) doesn't inspect or move the result of the call to foo. +See Trac #8739. + +There is a special typing rule for ($) in TcExpr, so the type of ($) +isn't looked at there, BUT Lint subsequently (and rightly) complains +if sees ($) applied to Int# (say), unless we give it a wired-in type +as we do here. + +Note [Unsafe coerce magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a *primitive* + GHC.Prim.unsafeCoerce# +and then in the base library we define the ordinary function + Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b + unsafeCoerce x = unsafeCoerce# x + +Notice that unsafeCoerce has a civilized (albeit still dangerous) +polymorphic type, whose type args have kind *. So you can't use it on +unboxed values (unsafeCoerce 3#). + +In contrast unsafeCoerce# is even more dangerous because you *can* use +it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is + forall (a:OpenKind) (b:OpenKind). a -> b + +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) Its second arg can have an unboxed type + x `seq` (v +# w) + Hence its second type variable has ArgKind + +b) Its fixity is set in LoadIface.ghcPrimIface + +c) It has quite a bit of desugaring magic. + See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3) + +d) There is some special rule handing: Note [User-defined RULES for seq] + +e) See Note [Typing rule for seq] in TcExpr. + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in Simplify.rebuildCase.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (c) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +Note [Built-in RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also have the following built-in rule for seq + + seq (x `cast` co) y = seq x y + +This eliminates unnecessary casts and also allows other seq rules to +match more often. Notably, + + seq (f x `cast` co) y --> seq (f x) y + +and now a user-defined rule for seq (see Note [User-defined RULES for seq]) +may fire. + + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ + lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) + +Used to lazify pseq: pseq a b = a `seq` lazy b + +Also, no strictness: by being a built-in Id, all the info about lazyId comes from here, +not from GHC.Base.hi. This is important, because the strictness +analyser will spot it as strict! + +Also no unfolding in lazyId: it gets "inlined" by a HACK in CorePrep. +It's very important to do this inlining *after* unfoldings are exposed +in the interface file. Otherwise, the unfolding for (say) pseq in the +interface file will not mention 'lazy', so if we inline 'pseq' we'll totally +miss the very thing that 'lazy' was there for in the first place. +See Trac #3259 for a real world example. + +lazyId is defined in GHC.Base, so we don't *have* to inline it. If it +appears un-applied, we'll end up just calling it. + +Note [The oneShot function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +Like most magic functions it has a compulsary unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +It is only effective if this bits survives as long as possible and makes it into +the interface in unfoldings (See Note [Preserve OneShotInfo]). Also see +https://ghc.haskell.org/trac/ghc/wiki/OneShot. + + +Note [magicDictId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The identifier `magicDict` is just a place-holder, which is used to +implement a primitve that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicDict :: forall a. a + +The intention is that the identifier will be used in a very specific way, +to create dictionaries for classes with a single method. Consider a class +like this: + + class C a where + f :: T a + +We are going to use `magicDict`, in conjunction with a built-in Prelude +rule, to cast values of type `T a` into dictionaries for `C a`. To do +this, we define a function like this in the library: + + data WrapC a b = WrapC (C a => Proxy a -> b) + + withT :: (C a => Proxy a -> b) + -> T a -> Proxy a -> b + withT f x y = magicDict (WrapC f) x y + +The purpose of `WrapC` is to avoid having `f` instantiated. +Also, it avoids impredicativity, because `magicDict`'s type +cannot be instantiated with a forall. The field of `WrapC` contains +a `Proxy` parameter which is used to link the type of the constraint, +`C a`, with the type of the `Wrap` value being made. + +Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), +which will replace the RHS of this definition with the appropriate +definition in Core. The rewrite rule works as follows: + +magicDict@t (wrap@a@b f) x y +----> +f (x `cast` co a) y + +The `co` coercion is the newtype-coercion extracted from the type-class. +The type class is obtain by looking at the type of wrap. + + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` stateHackOneShot) + +voidPrimId :: Id -- Global constant :: Void# +voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- Used to replace Coercion terms when we go to STG + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot new file mode 100644 index 00000000..69a694b1 --- /dev/null +++ b/compiler/basicTypes/MkId.hs-boot @@ -0,0 +1,12 @@ +module MkId where +import Name( Name ) +import Var( Id ) +import {-# SOURCE #-} DataCon( DataCon ) +import {-# SOURCE #-} PrimOp( PrimOp ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkPrimOpId :: PrimOp -> Id + +magicDictId :: Id diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs new file mode 100644 index 00000000..85e852fa --- /dev/null +++ b/compiler/basicTypes/Module.hs @@ -0,0 +1,512 @@ +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module Module + ( + -- * The ModuleName type + ModuleName, + pprModuleName, + moduleNameFS, + moduleNameString, + moduleNameSlashes, moduleNameColons, + mkModuleName, + mkModuleNameFS, + stableModuleNameCmp, + + -- * The PackageKey type + PackageKey, + fsToPackageKey, + packageKeyFS, + stringToPackageKey, + packageKeyString, + stablePackageKeyCmp, + + -- * Wired-in PackageKeys + -- $wired_in_packages + primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + dphSeqPackageKey, + dphParPackageKey, + mainPackageKey, + thisGhcPackageKey, + interactivePackageKey, isInteractiveModule, + wiredInPackageKeys, + + -- * The Module type + Module(Module), + modulePackageKey, moduleName, + pprModule, + mkModule, + stableModuleCmp, + HasModule(..), + ContainsModule(..), + + -- * The ModuleLocation type + ModLocation(..), + addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, + + -- * Module mappings + ModuleEnv, + elemModuleEnv, extendModuleEnv, extendModuleEnvList, + extendModuleEnvList_C, plusModuleEnv_C, + delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, + lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, + moduleEnvKeys, moduleEnvElts, moduleEnvToList, + unitModuleEnv, isEmptyModuleEnv, + foldModuleEnv, extendModuleEnvWith, filterModuleEnv, + + -- * ModuleName mappings + ModuleNameEnv, + + -- * Sets of Modules + ModuleSet, + emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet + ) where + +import Config +import Outputable +import Unique +import UniqFM +import FastString +import Binary +import Util +import {-# SOURCE #-} Packages +import GHC.PackageDb (BinaryStringRep(..)) + +import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map +import System.FilePath + +{- +************************************************************************ +* * +\subsection{Module locations} +* * +************************************************************************ +-} + +-- | Where a module lives on the file system: the actual locations +-- of the .hs, .hi and .o files, if we have them +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +{- +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. +-} + +addBootSuffix :: FilePath -> FilePath +-- ^ Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) } + +{- +************************************************************************ +* * +\subsection{The name of a module} +* * +************************************************************************ +-} + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString + deriving Typeable + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + +instance Eq ModuleName where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +-- Warning: gives an ordering relation based on the uniques of the +-- FastStrings which are the (encoded) module names. This is _not_ +-- a lexicographical ordering. +instance Ord ModuleName where + nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 + +instance Outputable ModuleName where + ppr = pprModuleName + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +instance BinaryStringRep ModuleName where + fromStringRep = mkModuleNameFS . mkFastStringByteString + toStringRep = fastStringToByteString . moduleNameFS + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS nm) + else ftext nm + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by underscores. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +{- +************************************************************************ +* * +\subsection{A fully qualified module} +* * +************************************************************************ +-} + +-- | A Module is a pair of a 'PackageKey' and a 'ModuleName'. +data Module = Module { + modulePackageKey :: !PackageKey, -- pkg-1.0 + moduleName :: !ModuleName -- A.B.C + } + deriving (Eq, Ord, Typeable) + +instance Uniquable Module where + getUnique (Module p n) = getUnique (packageKeyFS p `appendFS` moduleNameFS n) + +instance Outputable Module where + ppr = pprModule + +instance Binary Module where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +instance Data Module where + -- don't traverse? + toConstr _ = abstractConstr "Module" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Module" + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) + = (p1 `stablePackageKeyCmp` p2) `thenCmp` + (n1 `stableModuleNameCmp` n2) + +mkModule :: PackageKey -> ModuleName -> Module +mkModule = Module + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = + pprPackagePrefix p mod <> pprModuleName n + +pprPackagePrefix :: PackageKey -> Module -> SDoc +pprPackagePrefix p mod = getPprStyle doc + where + doc sty + | codeStyle sty = + if p == mainPackageKey + then empty -- never qualify the main package in code + else ztext (zEncodeFS (packageKeyFS p)) <> char '_' + | qualModule sty mod = ppr (modulePackageKey mod) <> char ':' + -- the PrintUnqualified tells us which modules have to + -- be qualified with package names + | otherwise = empty + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + +{- +************************************************************************ +* * +\subsection{PackageKey} +* * +************************************************************************ +-} + +-- | A string which uniquely identifies a package. For wired-in packages, +-- it is just the package name, but for user compiled packages, it is a hash. +-- ToDo: when the key is a hash, we can do more clever things than store +-- the hex representation and hash-cons those strings. +newtype PackageKey = PId FastString deriving( Eq, Typeable ) + -- here to avoid module loops with PackageConfig + +instance Uniquable PackageKey where + getUnique pid = getUnique (packageKeyFS pid) + +-- Note: *not* a stable lexicographic ordering, a faster unique-based +-- ordering. +instance Ord PackageKey where + nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 + +instance Data PackageKey where + -- don't traverse? + toConstr _ = abstractConstr "PackageKey" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PackageKey" + +stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering +-- ^ Compares package ids lexically, rather than by their 'Unique's +stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2 + +instance Outputable PackageKey where + ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> + case packageKeyPackageIdString dflags pk of + Nothing -> ftext (packageKeyFS pk) + Just pkg -> text pkg + -- Don't bother qualifying if it's wired in! + <> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys) + then char '@' <> ftext (packageKeyFS pk) + else empty) + +instance Binary PackageKey where + put_ bh pid = put_ bh (packageKeyFS pid) + get bh = do { fs <- get bh; return (fsToPackageKey fs) } + +instance BinaryStringRep PackageKey where + fromStringRep = fsToPackageKey . mkFastStringByteString + toStringRep = fastStringToByteString . packageKeyFS + +fsToPackageKey :: FastString -> PackageKey +fsToPackageKey = PId + +packageKeyFS :: PackageKey -> FastString +packageKeyFS (PId fs) = fs + +stringToPackageKey :: String -> PackageKey +stringToPackageKey = fsToPackageKey . mkFastString + +packageKeyString :: PackageKey -> String +packageKeyString = unpackFS . packageKeyFS + + +-- ----------------------------------------------------------------------------- +-- $wired_in_packages +-- Certain packages are known to the compiler, in that we know about certain +-- entities that reside in these packages, and the compiler needs to +-- declare static Modules and Names that refer to these packages. Hence +-- the wired-in packages can't include version numbers, since we don't want +-- to bake the version numbers of these packages into GHC. +-- +-- So here's the plan. Wired-in packages are still versioned as +-- normal in the packages database, and you can still have multiple +-- versions of them installed. However, for each invocation of GHC, +-- only a single instance of each wired-in package will be recognised +-- (the desired one is selected via @-package@\/@-hide-package@), and GHC +-- will use the unversioned 'PackageKey' below when referring to it, +-- including in .hi files and object file symbols. Unselected +-- versions of wired-in packages will be ignored, as will any other +-- package that depends directly or indirectly on it (much as if you +-- had used @-ignore-package@). + +-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here + +integerPackageKey, primPackageKey, + basePackageKey, rtsPackageKey, + thPackageKey, dphSeqPackageKey, dphParPackageKey, + mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey +primPackageKey = fsToPackageKey (fsLit "ghc-prim") +integerPackageKey = fsToPackageKey (fsLit n) + where + n = case cIntegerLibraryType of + IntegerGMP -> "integer-gmp" + IntegerGMP2 -> "integer-gmp" + IntegerSimple -> "integer-simple" +basePackageKey = fsToPackageKey (fsLit "base") +rtsPackageKey = fsToPackageKey (fsLit "rts") +thPackageKey = fsToPackageKey (fsLit "template-haskell") +dphSeqPackageKey = fsToPackageKey (fsLit "dph-seq") +dphParPackageKey = fsToPackageKey (fsLit "dph-par") +thisGhcPackageKey = fsToPackageKey (fsLit "ghc") +interactivePackageKey = fsToPackageKey (fsLit "interactive") + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainPackageKey = fsToPackageKey (fsLit "main") + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = modulePackageKey mod == interactivePackageKey + +wiredInPackageKeys :: [PackageKey] +wiredInPackageKeys = [ primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + thisGhcPackageKey, + dphSeqPackageKey, + dphParPackageKey ] + +{- +************************************************************************ +* * +\subsection{@ModuleEnv@s} +* * +************************************************************************ +-} + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map Module elt) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member m e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup m e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList xs) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = Map.keys e + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts (ModuleEnv e) = Map.elems e + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = Map.toList e + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton m x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e + +-- | A set of 'Module's +type ModuleSet = Map Module () + +mkModuleSet :: [Module] -> ModuleSet +extendModuleSet :: ModuleSet -> Module -> ModuleSet +emptyModuleSet :: ModuleSet +moduleSetElts :: ModuleSet -> [Module] +elemModuleSet :: Module -> ModuleSet -> Bool + +emptyModuleSet = Map.empty +mkModuleSet ms = Map.fromList [(m,()) | m <- ms ] +extendModuleSet s m = Map.insert m () s +moduleSetElts = Map.keys +elemModuleSet = Map.member + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM elt diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot new file mode 100644 index 00000000..8a73d382 --- /dev/null +++ b/compiler/basicTypes/Module.hs-boot @@ -0,0 +1,8 @@ +module Module where + +data Module +data ModuleName +data PackageKey +moduleName :: Module -> ModuleName +modulePackageKey :: Module -> PackageKey +packageKeyString :: PackageKey -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs new file mode 100644 index 00000000..f2b9ac1e --- /dev/null +++ b/compiler/basicTypes/Name.hs @@ -0,0 +1,615 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They +-- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have +-- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names +-- also contain information about where they originated from, see "Name#name_sorts" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + mkLocalisedOccName, + + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, + isWiredInName, isBuiltInSyntax, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, + + pprInfixName, pprPrefixName, pprModulePrefix, + + -- Re-export the OccName stuff + module OccName + ) where + +import {-# SOURCE #-} TypeRep( TyThing ) +import {-# SOURCE #-} PrelNames( liftedTypeKindTyConKey ) + +import OccName +import Module +import SrcLoc +import Unique +import Util +import Maybes +import Binary +import DynFlags +import FastTypes +import FastString +import Outputable + +import Data.Data + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambigious name for something, containing information about where +-- that thing originated. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: FastInt, -- UNPACK doesn't work, recursive type +--(note later when changing Int# -> FastInt: is that still true about UNPACK?) + n_loc :: !SrcSpan -- Definition site + } + deriving Typeable + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +data NameSort + = External Module + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Notes about the NameSorts: + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in IfaceEnv. + +3. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +4. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = mkUniqueGrimily (iBox (n_uniq name)) +nameOccName name = n_occ name +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GCHi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in HscTypes + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod + | otherwise = True + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = getKeyFastInt uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> String -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +-- |Create a localised variant of a name. +-- +-- If the name is external, encode the original's module name to disambiguate. +-- SPJ says: this looks like a rather odd-looking function; but it seems to +-- be used only during vectorisation, so I'm not going to worry +mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName +mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name) + where + origin + | nameIsLocalOrFrom this_mod name = Nothing + | otherwise = Just (moduleNameColons . moduleName . nameModule $ name) + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) + +stableNameCmp :: Name -> Name -> Ordering +-- Compare lexicographically +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +instance Binary Name where + put_ bh name = + case getUserData bh of + UserData{ ud_put_name = put_name } -> put_name bh name + + get bh = + case getUserData bh of + UserData { ud_get_name = get_name } -> get_name bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + + +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ + where uniq = mkUniqueGrimily (iBox u) + +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debugStyle sty = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ + where + pp_mod = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressModulePrefixes dflags + then empty + else ppr mod <> dot + +pprInternal :: PprStyle -> Unique -> OccName -> SDoc +pprInternal sty uniq occ + | codeStyle sty = pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc +pprSystem sty uniq occ + | codeStyle sty = pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in HscTypes +pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressModulePrefixes dflags + then empty + else + case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (modulePackageKey mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope either + _otherwise -> empty + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressUniques dflags + then empty + else char '_' <> pprUnique uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = ptext (sLit "Defined") <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s -> ptext (sLit "at") <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> ptext (sLit "at") <+> ftext s + | otherwise + -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName + +pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName thing + | name `hasKey` liftedTypeKindTyConKey + = ppr name -- See Note [Special treatment for kind *] + | otherwise + = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing + +{- +Note [Special treatment for kind *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not put parens around the kind '*'. Even though it looks like +an operator, it is really a special case. + +This pprPrefixName stuff is really only used when printing HsSyn, +which has to be polymorphic in the name type, and hence has to go via +the overloaded function pprPrefixOcc. It's easier where we know the +type being pretty printed; eg the pretty-printing code in TypeRep. + +See Trac #7645, which led to this. +-} diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot new file mode 100644 index 00000000..313db26e --- /dev/null +++ b/compiler/basicTypes/Name.hs-boot @@ -0,0 +1,7 @@ +module Name where + +import {-# SOURCE #-} Module + +data Name + +nameModule :: Name -> Module diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs new file mode 100644 index 00000000..9018bc44 --- /dev/null +++ b/compiler/basicTypes/NameEnv.hs @@ -0,0 +1,117 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +{-# LANGUAGE CPP #-} +module NameEnv ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, nameEnvUniqueElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + foldNameEnv, filterNameEnv, anyNameEnv, + plusNameEnv, plusNameEnv_C, alterNameEnv, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + + -- ** Dependency analysis + depAnal + ) where + +#include "HsVersions.h" + +import Digraph +import Name +import Unique +import UniqFM +import Maybes + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +depAnal :: (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Peform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes) + where + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node)) + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +mkNameEnv :: [(Name,a)] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +nameEnvUniqueElts :: NameEnv a -> [(Unique, a)] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool + +nameEnvElts x = eltsUFM x +emptyNameEnv = emptyUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +elemNameEnv x y = elemUFM x y +foldNameEnv a b c = foldUFM a b c +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +nameEnvUniqueElts x = ufmToList x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +anyNameEnv f x = foldUFM ((||) . f) False x +disjointNameEnv x y = isNullUFM (intersectUFM x y) + +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs new file mode 100644 index 00000000..7bca4798 --- /dev/null +++ b/compiler/basicTypes/NameSet.hs @@ -0,0 +1,195 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + +{-# LANGUAGE CPP #-} +module NameSet ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, nameSetElems, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet, + intersectsNameSet, intersectNameSet, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses + ) where + +#include "HsVersions.h" + +import Name +import UniqSet + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +nameSetElems :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +nameSetElems = uniqSetToList +delFromNameSet = delOneFromUniqSet +foldNameSet = foldUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets + +delListFromNameSet set ns = foldl delFromNameSet set ns + +intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = [DefUse] + +emptyDUs :: DefUses +emptyDUs = [] + +usesOnly :: Uses -> DefUses +usesOnly uses = [(Nothing, uses)] + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = (++) + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || any (startsWithUnderscore . nameOccName) (nameSetElems defs) + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs new file mode 100644 index 00000000..a0b57583 --- /dev/null +++ b/compiler/basicTypes/OccName.hs @@ -0,0 +1,893 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module OccName ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + nameSpacesRelated, + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkGenDefMethodOcc, + mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, + mkPDataTyConOcc, mkPDataDataConOcc, + mkPDatasTyConOcc, mkPDatasDataConOcc, + mkPReprTyConOcc, + mkPADFunOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, startsWithUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, pprOccEnv, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, + foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import Util +import Unique +import DynFlags +import UniqFM +import UniqSet +import FastString +import Outputable +import Lexeme +import Binary +import Data.Char +import Data.Data + +{- +************************************************************************ +* * + FastStringEnv +* * +************************************************************************ + +FastStringEnv can't be in FastString because the env depends on UniqFM +-} + +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM +mkFsEnv = listToUFM + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + {-! derive: Binary !-} + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in DataCon.lhs +-- +-- $real_vs_source_data_constructors +-- There are two forms of data constructor: +-- +-- [Source data constructors] The data constructors mentioned in Haskell source code +-- +-- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type +-- +-- For example: +-- +-- > data T = T !(Int, Int) +-- +-- The source datacon has type @(Int, Int) -> T@ +-- The real datacon has type @Int -> Int -> T@ +-- +-- GHC chooses a representation based on the strictness etc. + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = ptext (sLit "data constructor") +pprNameSpace VarName = ptext (sLit "variable") +pprNameSpace TvName = ptext (sLit "type variable") +pprNameSpace TcClsName = ptext (sLit "type constructor or class") + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = ptext (sLit "tv") +pprNameSpaceBrief TcClsName = ptext (sLit "tc") + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- See Note [Demotion] in RnEnv +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + deriving Typeable + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS occ) + else pp_occ <> pp_debug sty + where + pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) + | otherwise = empty + + pp_occ = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressUniques dflags + then text (strip_th_unique (unpackFS occ)) + else ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] + +{- +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in Convert.hs + +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char representing the name space. This in turn makes it +easy to build an OccEnv. +-} + +instance Uniquable OccName where + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs + +newtype OccEnv a = A (UniqFM a) + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt +alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y +alterOccEnv fn (A y) k = A $ alterUFM fn y k + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env + +type OccSet = UniqSet OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +occSetElts :: OccSet -> [OccName] +foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +occSetElts = uniqSetToList +foldOccSet = foldUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +-- | /Value/ 'OccNames's are those that are either in +-- the variable or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName TvName s) = isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unsed +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = case occNameString occ of + ('_' : _) -> True + _other -> False + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for functtoin 'f' + $sf.. Specialised version of f + T:C Tycon for dictionary for class C + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its respresentation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +mk_deriv :: NameSpace + -> String -- Distinguishes one sort of derived name from another + -> String + -> OccName + +mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) + +isDerivedOccName :: OccName -> Bool +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True + ':':c:_ | isAlphaNum c -> True + _other -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGen1R, mkGenRCo, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies as a tycon/datacon +mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con + -- for datacons from classes +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- used in derived instances +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" + +-- Generic derivable classes (old) +mkGenOcc1 = mk_simple_deriv varName "$gfrom" +mkGenOcc2 = mk_simple_deriv varName "$gto" + +-- Generic deriving mechanism (new) +mkGenD = mk_simple_deriv tcName "D1" + +mkGenC :: OccName -> Int -> OccName +mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ) + +mkGenS :: OccName -> Int -> Int -> OccName +mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) + (occNameString occ) + +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" +mkGenRCo = mk_simple_deriv tcName "CoRep_" + +-- data T = MkT ... deriving( Data ) needs definitions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc = mk_simple_deriv varName "$t" +mkDataCOcc = mk_simple_deriv varName "$c" + +-- Vectorisation +mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, + mkPADFunOcc, mkPReprTyConOcc, + mkPDataTyConOcc, mkPDataDataConOcc, + mkPDatasTyConOcc, mkPDatasDataConOcc + :: Maybe String -> OccName -> OccName +mkVectOcc = mk_simple_deriv_with varName "$v" +mkVectTyConOcc = mk_simple_deriv_with tcName "V:" +mkVectDataConOcc = mk_simple_deriv_with dataName "VD:" +mkVectIsoOcc = mk_simple_deriv_with varName "$vi" +mkPADFunOcc = mk_simple_deriv_with varName "$pa" +mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:" +mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:" +mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:" +mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:" +mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:" + +mk_simple_deriv :: NameSpace -> String -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) + +mk_simple_deriv_with :: NameSpace -> String -> Maybe String -> OccName -> OccName +mk_simple_deriv_with sp px Nothing occ = mk_deriv sp px (occNameString occ) +mk_simple_deriv_with sp px (Just with) occ = mk_deriv sp (px ++ with ++ "_") (occNameString occ) + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ) + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName ("$L" ++ show uniq) (occNameString occ) + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str set = + chooseUniqueOcc tcName ('R' : ':' : str) set + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See TcClassDcl.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (Trac #10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a20001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + +-} + +type TidyOccEnv = UniqFM Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + = case lookupUFM env fs of + Nothing -> (addToUFM env fs 1, occ) -- Desired OccName is free + Just {} -> case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case lookupUFM env new_fs of + Just {} -> find (k+1 :: Int) (n+k) + -- By using n+k, the n arguemt to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + Nothing -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base_fs, so that next time we'll start whwere we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + +{- +************************************************************************ +* * + Binary instance + Here rather than BinIface because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot new file mode 100644 index 00000000..c6fa8850 --- /dev/null +++ b/compiler/basicTypes/OccName.hs-boot @@ -0,0 +1,3 @@ +module OccName where + +data OccName diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs new file mode 100644 index 00000000..081968aa --- /dev/null +++ b/compiler/basicTypes/PatSyn.hs @@ -0,0 +1,345 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynIsInfix, + patSynArgs, patSynTyDetails, patSynType, + patSynMatcher, patSynBuilder, + patSynExTyVars, patSynSig, + patSynInstArgTys, patSynInstResTy, + tidyPatSynIds + ) where + +#include "HsVersions.h" + +import Type +import TcType( mkSigmaTy ) +import Name +import Outputable +import Unique +import Util +import BasicTypes +import FastString +import Var +import HsBinds( HsPatSynDetails(..) ) + +import qualified Data.Data as Data +import qualified Data.Typeable +import Data.Function + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | A pattern synonym +-- See Note [Pattern synonym representation] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + + psUnivTyVars :: [TyVar], -- Universially-quantified type variables + psReqTheta :: ThetaType, -- Required dictionaries + psExTyVars :: [TyVar], -- Existentially-quantified type vars + psProvTheta :: ThetaType, -- Provided dictionaries + psOrigResTy :: Type, -- Mentions only psUnivTyVars + + -- See Note [Matchers and builders for pattern synonyms] + psMatcher :: (Id, Bool), + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (r :: ?) univ_tvs. req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (r :: ?) univ_tvs. req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + + psBuilder :: Maybe (Id, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (prov_theta, req_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + } + deriving Data.Typeable.Typeable + +{- +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + provides: (Show (Maybe t), Ord b) + requires: (Eq t, Num t) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psOrigResTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by TcPatSyn.patSynBuilderOcc. + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Ord PatSyn where + (<=) = (<=) `on` getUnique + (<) = (<) `on` getUnique + (>=) = (>=) `on` getUnique + (>) = (>) `on` getUnique + compare = compare `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables + -- and required dicts + -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables + -- and provided dicts + -> [Type] -- ^ Original arguments + -> Type -- ^ Original result type + -> (Id, Bool) -- ^ Name of matcher + -> Maybe (Id, Bool) -- ^ Name of builder + -> PatSyn +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psOrigResTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +patSynType :: PatSyn -> Type +-- The full pattern type, used only in error messages +patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psOrigResTy = orig_res_ty }) + = mkSigmaTy univ_tvs req_theta $ + mkSigmaTy ex_tvs prov_theta $ + mkFunTys orig_args orig_res_ty + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynTyDetails :: PatSyn -> HsPatSynDetails Type +patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys }) + | is_infix, [left,right] <- arg_tys + = InfixPatSyn left right + | otherwise + = PrefixPatSyn arg_tys + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars = psExTyVars + +patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type) +patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psOrigResTy = res_ty }) + = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder = psBuilder + +tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) + = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } + where + tidy_pr (id, dummy) = (tidy_fn id, dummy) + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psOrigResTy = res_ty }) + inst_tys + = ASSERT2( length univ_tvs == length inst_tys + , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith univ_tvs inst_tys res_ty diff --git a/compiler/basicTypes/PatSyn.hs-boot b/compiler/basicTypes/PatSyn.hs-boot new file mode 100644 index 00000000..733c51b3 --- /dev/null +++ b/compiler/basicTypes/PatSyn.hs-boot @@ -0,0 +1,17 @@ +module PatSyn where +import Name( NamedThing ) +import Data.Typeable ( Typeable ) +import Data.Data ( Data ) +import Outputable ( Outputable, OutputableBndr ) +import Unique ( Uniquable ) + +data PatSyn + +instance Eq PatSyn +instance Ord PatSyn +instance NamedThing PatSyn +instance Outputable PatSyn +instance OutputableBndr PatSyn +instance Uniquable PatSyn +instance Typeable PatSyn +instance Data PatSyn diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs new file mode 100644 index 00000000..094347a4 --- /dev/null +++ b/compiler/basicTypes/RdrName.hs @@ -0,0 +1,951 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'OccName.OccName' with an optional module +-- qualifier +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module RdrName ( + -- * The main type + RdrName(..), -- Constructors exported only to BinIface + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes, + transformGREs, findLocalDupsRdrEnv, pickGREs, + + -- * GlobalRdrElts + gresFromAvails, gresFromAvail, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK, + Provenance(..), pprNameProvenance, + Parent(..), + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isExplicitItem + ) where + +#include "HsVersions.h" + +import Module +import Name +import Avail +import NameSet +import Maybes +import SrcLoc +import FastString +import Outputable +import Unique +import Util +import StaticFlags( opt_PprStyle_Debug ) + +import Data.Data + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'ApiAnnotation.AnnBackquote' @'`'@, +-- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh', +-- 'ApiAnnotation.AnnTilde', + +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving (Data, Typeable) + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | isExternalName n + = Orig (nameModule n) occ + | otherwise -- This can happen when quoting and then splicing a fixity + -- declaration for a type + = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n) + where + occ = setOccNameSpace ns (nameOccName n) + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in OccName +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = panic "demoteRdrName" +demoteRdrName (Exact _) = panic "demoteRdrName" + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +-- | This environment is used to store local bindings (@let@, @where@, lambda, @case@). +-- It is keyed by OccName, because we never use it for qualified names +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact Names] in RnEnv +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (ptext (sLit "LocalRdrEnv {")) + 2 (vcat [ ptext (sLit "env =") <+> pprOccEnv ppr_elt env + , ptext (sLit "in_scope =") <+> braces (pprWithCommas ppr (nameSetElems ns)) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv, lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- The Name should be a non-top-level thing +extendLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) name + = WARN( isExternalName name, ppr name ) + LRE { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) names + = WARN( any isExternalName names, ppr names ) + LRE { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env }) (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv _ _ = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) occs + = LRE { lre_env = delListFromOccEnv env occs + , lre_in_scope = ns } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +type GlobalRdrEnv = OccEnv [GlobalRdrElt] +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in RnNames +-- Note [Top-level Names in Template Haskell decl quotes] + +-- | An element of the 'GlobalRdrEnv' +data GlobalRdrElt + = GRE { gre_name :: Name, + gre_par :: Parent, + gre_prov :: Provenance -- ^ Why it's in scope + } + +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. See Note [Parents] +data Parent = NoParent | ParentIs Name + deriving (Eq) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent (ParentIs n) p2 = hasParent n p2 +plusParent p1 (ParentIs n) = hasParent n p1 +plusParent _ _ = NoParent + +hasParent :: Name -> Parent -> Parent +#ifdef DEBUG +hasParent n (ParentIs n') + | n /= n' = pprPanic "hasParent" (ppr n <+> ppr n') -- Parents should agree +#endif +hasParent n _ = ParentIs n + +{- +Note [Parents] +~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and the combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- Provenance (useful for "hiding" imports, or imports with +-- no details). +gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt] +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = [ GRE {gre_name = n, + gre_par = mkParent n avail, + gre_prov = prov_fn n} + | n <- availNames avail ] + where + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _) | n == m = NoParent + | otherwise = ParentIs m + +emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +instance Outputable GlobalRdrElt where + ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ ptext (sLit "GlobalRdrEnv") <+> ppWhen locals_only (ptext (sLit "(locals only)")) + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres = hang (ppr occ + <+> parens (ptext (sLit "unique") <+> ppr (getUnique occ)) + <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (gre_name (head gres)) + +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of + Nothing -> [] + Just gres -> gres + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] +lookupGRE_Name env name + = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), + gre_name gre == name ] + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env + = map (qualifier_maybe . gre_prov) . lookupGRE_Name env + where + qualifier_maybe LocalDef = Nothing + qualifier_maybe (Imported iss) = Just $ map (is_as . is_decl) iss + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_prov = LocalDef}) = True +isLocalGRE _ = False + +unQualOK :: GlobalRdrElt -> Bool +-- ^ Test if an unqualifed version of this thing would be in scope +unQualOK (GRE {gre_prov = LocalDef}) = True +unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK is + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- ^ Take a list of GREs which have the right OccName +-- Pick those GREs that are suitable for this RdrName +-- And for those, keep only only the Provenances that are suitable +-- Only used for Qual and Unqual, not Orig or Exact +-- +-- Consider: +-- +-- @ +-- module A ( f ) where +-- import qualified Foo( f ) +-- import Baz( f ) +-- f = undefined +-- @ +-- +-- Let's suppose that @Foo.f@ and @Baz.f@ are the same entity really. +-- The export of @f@ is ambiguous because it's in scope from the local def +-- and the import. The lookup of @Unqual f@ should return a GRE for +-- the locally-defined @f@, and a GRE for the imported @f@, with a /single/ +-- provenance, namely the one for @Baz(f)@. +pickGREs rdr_name gres + | (_ : _ : _) <- candidates -- This is usually false, so we don't have to + -- even look at internal_candidates + , (gre : _) <- internal_candidates + = [gre] -- For this internal_candidate stuff, + -- see Note [Template Haskell binders in the GlobalRdrEnv] + -- If there are multiple Internal candidates, pick the + -- first one (ie with the (innermost binding) + | otherwise + = ASSERT2( isSrcRdrName rdr_name, ppr rdr_name ) + candidates + where + candidates = mapMaybe pick gres + internal_candidates = filter (isInternalName . gre_name) candidates + + rdr_is_unqual = isUnqual rdr_name + rdr_is_qual = isQual_maybe rdr_name + + pick :: GlobalRdrElt -> Maybe GlobalRdrElt + pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def + | rdr_is_unqual = Just gre + | Just (mod,_) <- rdr_is_qual -- Qualified name + , Just n_mod <- nameModule_maybe n -- Binder is External + , mod == moduleName n_mod = Just gre + | otherwise = Nothing + pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency) + | rdr_is_unqual, + not (is_qual (is_decl is)) = Just gre + | Just (mod,_) <- rdr_is_qual, + mod == is_as (is_decl is) = Just gre + | otherwise = Nothing + pick gre@(GRE {gre_prov = Imported is}) -- Multiple import + | null filtered_is = Nothing + | otherwise = Just (gre {gre_prov = Imported filtered_is}) + where + filtered_is | rdr_is_unqual + = filter (not . is_qual . is_decl) is + | Just (mod,_) <- rdr_is_qual + = filter ((== mod) . is_as . is_decl) is + | otherwise + = [] + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE singleton env + (nameOccName (gre_name gre)) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1, + gre_prov = gre_prov g1 `plusProv` gre_prov g2, + gre_par = gre_par g1 `plusParent` gre_par g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: Bool -> GlobalRdrEnv -> [AvailInfo] -> GlobalRdrEnv +-- Extend with new LocalDef GREs from the AvailInfos. +-- +-- If do_shadowing is True, first remove name clashes between the new +-- AvailInfos and the existing GlobalRdrEnv. +-- This is used by the GHCi top-level +-- +-- E.g. Adding a LocalDef "x" when there is an existing GRE for Q.x +-- should remove any unqualified import of Q.x, +-- leaving only the qualified one +-- +-- However do *not* remove name clashes between the AvailInfos themselves, +-- so that (say) data T = A | A +-- will still give a duplicate-binding error. +-- Same thing if there are multiple AvailInfos (don't remove clashes), +-- though I'm not sure this ever happens with do_shadowing=True + +extendGlobalRdrEnv do_shadowing env avails + = foldl add_avail env1 avails + where + names = concatMap availNames avails + env1 | do_shadowing = foldl shadow_name env names + | otherwise = env + -- By doing the removal first, we ensure that the new AvailInfos + -- don't shadow each other; that would conceal genuine errors + -- E.g. in GHCi data T = A | A + + add_avail env avail = foldl (add_name avail) env (availNames avail) + + add_name avail env name + = extendOccEnv_Acc (:) singleton env occ gre + where + occ = nameOccName name + gre = GRE { gre_name = name + , gre_par = mkParent name avail + , gre_prov = LocalDef } + +shadow_name :: GlobalRdrEnv -> Name -> GlobalRdrEnv +shadow_name env name + = alterOccEnv (fmap alter_fn) env (nameOccName name) + where + alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] + alter_fn gres = mapMaybe (shadow_with name) gres + + shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt + shadow_with new_name old_gre@(GRE { gre_name = old_name, gre_prov = LocalDef }) + = case (nameModule_maybe old_name, nameModule_maybe new_name) of + (Nothing, _) -> Nothing + (Just old_mod, Just new_mod) | new_mod == old_mod -> Nothing + (Just old_mod, _) -> Just (old_gre { gre_prov = Imported [fake_imp_spec] }) + where + fake_imp_spec = ImpSpec id_spec ImpAll -- Urgh! + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod_name + , is_as = old_mod_name + , is_qual = True + , is_dloc = nameSrcSpan old_name } + shadow_with new_name old_gre@(GRE { gre_prov = Imported imp_specs }) + | null imp_specs' = Nothing + | otherwise = Just (old_gre { gre_prov = Imported imp_specs' }) + where + imp_specs' = mapMaybe (shadow_is new_name) imp_specs + + shadow_is :: Name -> ImportSpec -> Maybe ImportSpec + shadow_is new_name is@(ImpSpec { is_decl = id_spec }) + | Just new_mod <- nameModule_maybe new_name + , is_as id_spec == moduleName new_mod + = Nothing -- Shadow both qualified and unqualified + | otherwise -- Shadow unqualified only + = Just (is { is_decl = id_spec { is_qual = True } }) + +{- +Note [Template Haskell binders in the GlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For reasons described in Note [Top-level Names in Template Haskell decl quotes] +in RnNames, a GRE with an Internal gre_name (i.e. one generated by a TH decl +quote) should *shadow* a GRE with an External gre_name. Hence some faffing +around in pickGREs and findLocalDupsRdrEnv +-} + +findLocalDupsRdrEnv :: GlobalRdrEnv -> [Name] -> [[GlobalRdrElt]] +-- ^ For each 'OccName', see if there are multiple local definitions +-- for it; return a list of all such +-- and return a list of the duplicate bindings +findLocalDupsRdrEnv rdr_env occs + = go rdr_env [] occs + where + go _ dups [] = dups + go rdr_env dups (name:names) + = case filter (pick name) gres of + [] -> go rdr_env dups names + [_] -> go rdr_env dups names -- The common case + dup_gres -> go rdr_env' (dup_gres : dups) names + where + occ = nameOccName name + gres = lookupOccEnv rdr_env occ `orElse` [] + rdr_env' = delFromOccEnv rdr_env occ + -- The delFromOccEnv avoids repeating the same + -- complaint twice, when names itself has a duplicate + -- which is a common case + + -- See Note [Template Haskell binders in the GlobalRdrEnv] + pick name (GRE { gre_name = n, gre_prov = LocalDef }) + | isInternalName name = isInternalName n + | otherwise = True + pick _ _ = False + +{- +************************************************************************ +* * + Provenance +* * +************************************************************************ +-} + +-- | The 'Provenance' of something says how it came to be in scope. +-- It's quite elaborate so that we can give accurate unused-name warnings. +data Provenance + = LocalDef -- ^ The thing was defined locally + | Imported + [ImportSpec] -- ^ The thing was imported. + -- + -- INVARIANT: the list of 'ImportSpec' is non-empty + +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Ord ) + +-- | Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe PackageKey here too. + is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: Bool, -- ^ Was this import qualified? + is_dloc :: SrcSpan -- ^ The location of the entire import declaration + } + +-- | Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule is = is_mod (is_decl is) + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +-- Note [Comparing provenance] +-- Comparison of provenance is just used for grouping +-- error messages (in RnEnv.warnUnusedBinds) +instance Eq Provenance where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImpDeclSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImpItemSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord Provenance where + compare LocalDef LocalDef = EQ + compare LocalDef (Imported _) = LT + compare (Imported _ ) LocalDef = GT + compare (Imported is1) (Imported is2) = compare (head is1) + {- See Note [Comparing provenance] -} (head is2) + +instance Ord ImpDeclSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_dloc is1 `compare` is_dloc is2) + +instance Ord ImpItemSpec where + compare is1 is2 = is_iloc is1 `compare` is_iloc is2 + +plusProv :: Provenance -> Provenance -> Provenance +-- Choose LocalDef over Imported +-- There is an obscure bug lurking here; in the presence +-- of recursive modules, something can be imported *and* locally +-- defined, and one might refer to it with a qualified name from +-- the import -- but I'm going to ignore that because it makes +-- the isLocalGRE predicate so much nicer this way +plusProv LocalDef LocalDef = panic "plusProv" +plusProv LocalDef _ = LocalDef +plusProv _ LocalDef = LocalDef +plusProv (Imported is1) (Imported is2) = Imported (is1++is2) + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- ^ Print out the place where the name was imported +pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef}) + = ptext (sLit "defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys}) + = case whys of + (why:_) | opt_PprStyle_Debug -> vcat (map pp_why whys) + | otherwise -> pp_why why + [] -> panic "pprNameProvenance" + where + pp_why why = sep [ppr why, ppr_defn_site why name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (ptext (sLit "and originally defined") <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = ptext (sLit "in") <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = ptext (sLit "imported") <+> qual + <+> ptext (sLit "from") <+> quotes (ppr (importSpecModule imp_spec)) + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = ptext (sLit "qualified") + | otherwise = empty + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s) = ptext (sLit "at") <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs new file mode 100644 index 00000000..362a9259 --- /dev/null +++ b/compiler/basicTypes/SrcLoc.hs @@ -0,0 +1,601 @@ +-- (c) The University of Glasgow, 1992-2006 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + -- Workaround for Trac #5252 crashes the bootstrap compiler without -O + -- When the earliest compiler we want to boostrap with is + -- GHC 7.2, we can make RealSrcLoc properly abstract + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + containsSpan, + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, sortLocated + ) where + +import Util +import Outputable +import FastString + +#if __GLASGOW_HASKELL__ < 709 +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) +#endif +import Data.Bits +import Data.Data +import Data.List +import Data.Ord + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Represents a single point within a file +data RealSrcLoc + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + +data SrcLoc + = RealSrcLoc {-# UNPACK #-}!RealSrcLoc + | UnhelpfulLoc FastString -- Just a general indication + deriving Show + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) + `shiftL` 3) + 1) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +-- SrcLoc is an instance of Ord so that we can sort error messages easily +instance Eq SrcLoc where + loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of + EQ -> True + _other -> False + +instance Eq RealSrcLoc where + loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of + EQ -> True + _other -> False + +instance Ord SrcLoc where + compare = cmpSrcLoc + +instance Ord RealSrcLoc where + compare = cmpRealSrcLoc + +sortLocated :: [Located a] -> [Located a] +sortLocated things = sortBy (comparing getLoc) things + +cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering +cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT +cmpSrcLoc (RealSrcLoc _) (UnhelpfulLoc _) = LT +cmpSrcLoc (RealSrcLoc l1) (RealSrcLoc l2) = (l1 `compare` l2) + +cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering +cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) + = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) + +instance Outputable RealSrcLoc where + ppr (SrcLoc src_path src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A SrcSpan delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} +data RealSrcSpan + = SrcSpanOneLine -- a common case: a single line + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + + | SrcSpanMultiLine + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + + | SrcSpanPoint + { srcSpanFile :: !FastString, + srcSpanLine :: {-# UNPACK #-} !Int, + srcSpanCol :: {-# UNPACK #-} !Int + } + deriving (Eq, Typeable) + +data SrcSpan = + RealSrcSpan !RealSrcSpan + | UnhelpfulSpan !FastString -- Just a general indication + -- also used to indicate an empty span + + deriving (Eq, Ord, Typeable, Show) -- Show is used by Lexer.x, because we + -- derive Show for Token + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, wiredInSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 + | line1 == line2 = if col1 == col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 + | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) + = RealSrcSpan (combineRealSrcSpans span1 span2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = if line_start == line_end + then if col_start == col_end + then SrcSpanPoint file line_start col_start + else SrcSpanOneLine file line_start col_start col_end + else SrcSpanMultiLine file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = srcSpanFile s1 == srcSpanFile s2 + && (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l +srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l + +srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l +srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l + +srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l + +srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + a `compare` b = + (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` + (realSrcSpanEnd a `compare` realSrcSpanEnd b) + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show (SrcSpanOneLine file l sc ec) + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [l,sc,ec]) + show (SrcSpanMultiLine file sl sc el ec) + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + show (SrcSpanPoint file l c) + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int start_col + , ppUnless (end_col - start_col <= 1) (char '-' <> int (end_col - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +pprUserRealSpan show_path (SrcSpanPoint src_path line col) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Typeable, Data) +deriving instance Foldable (GenLocated l) +deriving instance Traversable (GenLocated l) + +type Located e = GenLocated SrcSpan e +type RealLocated e = GenLocated RealSrcSpan e + +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e + +getLoc :: GenLocated l e -> l +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: Eq a => Located a -> Located a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: Ord a => Located a -> Located a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance Functor (GenLocated l) where + fmap f (L l e) = L l (f e) + +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + ifPprDebug (braces (ppr l)) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Alternative strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering +rightmost = flip compare +leftmost_smallest = compare +leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` + (srcSpanEnd b `compare` srcSpanEnd a) + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf src parent + | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False + | otherwise = srcSpanStart parent <= srcSpanStart src && + srcSpanEnd parent >= srcSpanEnd src diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs new file mode 100644 index 00000000..3d0573db --- /dev/null +++ b/compiler/basicTypes/UniqSupply.hs @@ -0,0 +1,200 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE UnboxedTuples #-} + +module UniqSupply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), + + -- ** Operations on the monad + initUs, initUs_, + lazyThenUs, lazyMapUs, + ) where + +import Unique +import FastTypes + +import GHC.IO + +import MonadUtils +import Control.Monad + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +-- | A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply FastInt -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. The character given must +-- be distinct from those of all calls to this function in the compiler +-- for the values generated to be truly unique. + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +mkSplitUniqSupply c + = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of + mask -> let + -- here comes THE MAGIC: + + -- This is one of the most hammered bits in the whole compiler + mk_supply + -- NB: Use unsafeInterleaveIO for thread-safety. + = unsafeInterleaveIO ( + genSym >>= \ u_ -> case iUnbox u_ of { u -> ( + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2) + )}) + in + mk_supply + +foreign import ccall unsafe "genSym" genSym :: IO Int + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n) +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1) + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) } + +instance Monad UniqSM where + return = returnUs + (>>=) = thenUs + (>>) = thenUs_ + +instance Functor UniqSM where + fmap f (USM x) = USM (\us -> case x us of + (# r, us' #) -> (# f r, us' #)) + +instance Applicative UniqSM where + pure = returnUs + (USM f) <*> (USM x) = USM $ \us -> case f us of + (# ff, us' #) -> case x us' of + (# xx, us'' #) -> (# ff xx, us'' #) + (*>) = thenUs_ + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r } + +{-# INLINE thenUs #-} +{-# INLINE lazyThenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} + +-- @thenUs@ is where we split the @UniqSupply@. + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us') + +instance MonadFix UniqSM where + mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #)) + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs (USM expr) cont + = USM (\us -> case (expr us) of + (# result, us' #) -> unUSM (cont result) us') + +lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +lazyThenUs expr cont + = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us') + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ (USM expr) (USM cont) + = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' }) + +returnUs :: a -> UniqSM a +returnUs result = USM (\us -> (# result, us #)) + +getUs :: UniqSM UniqSupply +getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #)) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueUs :: UniqSM Unique +getUniqueUs = USM (\us -> case takeUniqFromSupply us of + (u,us') -> (# u, us' #)) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = USM (\us -> case splitUniqSupply us of + (us1,us2) -> (# uniqsFromSupply us1, us2 #)) + +-- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-} +-- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-} + +lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] +lazyMapUs _ [] = returnUs [] +lazyMapUs f (x:xs) + = f x `lazyThenUs` \ r -> + lazyMapUs f xs `lazyThenUs` \ rs -> + returnUs (r:rs) diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs new file mode 100644 index 00000000..ecff80fe --- /dev/null +++ b/compiler/basicTypes/Unique.hs @@ -0,0 +1,351 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} + +module Unique ( + -- * Main data types + Unique, Uniquable(..), + + -- ** Constructors, desctructors and operations on 'Unique's + hasKey, + + pprUnique, + + mkUniqueGrimily, -- Used in UniqSupply only! + getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! + mkUnique, unpkUnique, -- Used in BinIface only + + incrUnique, -- Used for renumbering + deriveUnique, -- Ditto + newTagUnique, -- Used in CgCase + initTyVarUnique, + + -- ** Making built-in uniques + + -- now all the built-in Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, + mkTupleTyConUnique, mkTupleDataConUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkPArrDataConUnique, + + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, + + mkBuiltinUnique, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH + ) where + +#include "HsVersions.h" + +import BasicTypes +import FastTypes +import FastString +import Outputable +-- import StaticFlags +import Util + +--just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..)) + +import Data.Char ( chr, ord ) + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: +-} + +--why not newtype Int? + +-- | The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +data Unique = MkUnique FastInt + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var +getKeyFastInt :: Unique -> FastInt -- for Var + +incrUnique :: Unique -> Unique +deriveUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily x = MkUnique (iUnbox x) + +{-# INLINE getKey #-} +getKey (MkUnique x) = iBox x +{-# INLINE getKeyFastInt #-} +getKeyFastInt (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i +# _ILIT(1)) + +-- deriveUnique uses an 'X' tag so that it won't clash with +-- any of the uniques produced any other way +deriveUnique (MkUnique i) delta = mkUnique 'X' (iBox i + delta) + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module +mkUnique c i + = MkUnique (tag `bitOrFastInt` bits) + where + !tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) + !bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-} + +unpkUnique (MkUnique u) + = let + -- as long as the Char may have its eighth bit set, we + -- really do need the logical right-shift here! + tag = cBox (fastChr (u `shiftRLFastInt` _ILIT(24))) + i = iBox (u `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-}) + in + (tag, i) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (iBox (uniqueOfFS fs)) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +eqUnique, ltUnique, leUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2 +ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 +leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 + +cmpUnique :: Unique -> Unique -> Ordering +cmpUnique (MkUnique u1) (MkUnique u2) + = if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Ord Unique where + a < b = ltUnique a b + a <= b = leUnique a b + a > b = not (leUnique a b) + a >= b = not (ltUnique a b) + compare a b = cmpUnique a b + +----------------- +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_show tag u (iToBase62 u) + +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u + +pprUnique :: Unique -> SDoc +pprUnique u = text (showUnique u) + +instance Outputable Unique where + ppr = pprUnique + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +-} + +iToBase62 :: Int -> String +iToBase62 n_ + = ASSERT(n_ >= 0) go (iUnbox n_) "" + where + go n cs | n <# _ILIT(62) + = case chooseChar62 n of { c -> c `seq` (c : cs) } + | otherwise + = case (quotRem (iBox n) 62) of { (q_, r_) -> + case iUnbox q_ of { q -> case iUnbox r_ of { r -> + case (chooseChar62 r) of { c -> c `seq` + (go q (c : cs)) }}}} + + chooseChar62 :: FastInt -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 n = C# (indexCharOffAddr# chars62 n) + !chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + +{- +************************************************************************ +* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +* * +************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques derived by deriveUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + n Native codegen + r Hsc name cache + s simplifier +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPreludeTyConUnique :: Int -> Unique +mkTupleTyConUnique :: TupleSort -> Int -> Unique +mkPreludeDataConUnique :: Int -> Unique +mkTupleDataConUnique :: TupleSort -> Int -> Unique +mkPrimOpIdUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique +mkPArrDataConUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUnique '1' i + +mkPreludeClassUnique i = mkUnique '2' i + +-- Prelude type constructors occupy *three* slots. +-- The first is for the tycon itself; the latter two +-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. + +mkPreludeTyConUnique i = mkUnique '3' (3*i) +mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a) +mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a) +mkTupleTyConUnique ConstraintTuple a = mkUnique 'k' (3*a) + +-- Data constructor keys occupy *two* slots. The first is used for the +-- data constructor itself and its wrapper function (the function that +-- evaluates arguments as necessary and calls the worker). The second is +-- used for the worker function (the function that builds the constructor +-- representation). + +mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic +mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a) +mkTupleDataConUnique ConstraintTuple a = mkUnique 'h' (2*a) + +mkPrimOpIdUnique op = mkUnique '9' op +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- No numbers left anymore, so I pick something different for the character tag +mkPArrDataConUnique a = mkUnique ':' (2*a) + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in OccName +mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs)) +mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs)) +mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs)) +mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs)) diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs new file mode 100644 index 00000000..925ffe35 --- /dev/null +++ b/compiler/basicTypes/Var.hs @@ -0,0 +1,440 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'TypeRep.Kind' +-- rather than a 'TypeRep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module Var ( + -- * The main data type and synonyms + Var, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, + TyVar, TypeVar, KindVar, TKVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, + + -- ** Predicates + isId, isTKVar, isTyVar, isTcTyVar, + isLocalVar, isLocalId, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- ** Constructing 'TyVar's + mkTyVar, mkTcTyVar, mkKindVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM + + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TypeRep( Type, Kind, SuperKind ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails ) + +import Name hiding (varName) +import Unique +import Util +import FastTypes +import FastString +import Outputable + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of Id.hs :-( +-} + +type Id = Var -- A term-level identifier + +type TyVar = Var -- Type *or* kind variable (historical) + +type TKVar = Var -- Type *or* kind variable (historical) +type TypeVar = Var -- Definitely a type variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar +type EvVar = EvId -- ...historical name for EvId +type DFunId = Id -- A dictionary function +type DictId = EvId -- A dictionary variable +type IpId = EvId -- A term-level implicit parameter +type EqVar = EvId -- Boxed equality evidence + +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + +{- +Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a *boxed*, term-level evidence variable + (dictionary, implicit parameter, or equality). + +* A CoVar (coercion variable) is an *unboxed* term-level evidence variable + of type (t1 ~# t2). So it's the unboxed version of an EqVar. + +* Only CoVars can occur in Coercions, EqVars appear in TcCoercions. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are use to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and it's use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: FastInt, -- Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: FastInt, + varType :: Kind, + tc_tv_details :: TcTyVarDetails } + + | Id { + varName :: !Name, + realUnique :: FastInt, + varType :: Type, + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + deriving Typeable + +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +After CoreTidy, top-level LocalIds are turned into GlobalIds +-} + +instance Outputable Var where + ppr var = ppr (varName var) <> getPprStyle (ppr_debug var) + +ppr_debug :: Var -> PprStyle -> SDoc +ppr_debug (TyVar {}) sty + | debugStyle sty = brackets (ptext (sLit "tv")) +ppr_debug (TcTyVar {tc_tv_details = d}) sty + | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) +ppr_debug (Id { idScope = s, id_details = d }) sty + | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) +ppr_debug _ _ = empty + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = ptext (sLit "gid") +ppr_id_scope (LocalId Exported) = ptext (sLit "lidx") +ppr_id_scope (LocalId NotExported) = ptext (sLit "lid") + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a ==# realUnique b + +instance Ord Var where + a <= b = realUnique a <=# realUnique b + a < b = realUnique a <# realUnique b + a >= b = realUnique a >=# realUnique b + a > b = realUnique a ># realUnique b + a `compare` b = varUnique a `compare` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (iBox (realUnique var)) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKeyFastInt uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKeyFastInt (getUnique new_name), + varName = new_name } + +setVarType :: Id -> Type -> Id +setVarType id ty = id { varType = ty } + +{- +************************************************************************ +* * +\subsection{Type and kind variables} +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKeyFastInt (nameUnique name) + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = getKeyFastInt (nameUnique name), + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +mkKindVar :: Name -> SuperKind -> KindVar +-- mkKindVar take a SuperKind as argument because we don't have access +-- to superKind here. +mkKindVar name kind = TyVar + { varName = name + , realUnique = getKeyFastInt (nameUnique name) + , varType = kind } + +{- +************************************************************************ +* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because Id.lhs uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name ty GlobalId details info + +mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkLocalVar details name ty info + = mk_id name ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name ty (LocalId Exported) details info + +mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name ty scope details info + = Id { varName = name, + realUnique = getKeyFastInt (nameUnique name), + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +isTyVar :: Var -> Bool +isTyVar = isTKVar -- Historical + +isTKVar :: Var -> Bool -- True of both type and kind variables +isTKVar (TyVar {}) = True +isTKVar (TcTyVar {}) = True +isTKVar _ = False + +isTcTyVar :: Var -> Bool +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs new file mode 100644 index 00000000..1d1c0604 --- /dev/null +++ b/compiler/basicTypes/VarEnv.hs @@ -0,0 +1,450 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module VarEnv ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, + elemVarEnv, varEnvElts, varEnvKeys, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv, + delVarEnvList, delVarEnv, + minusVarEnv, intersectsVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, foldVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv, filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, + + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + delBndrL, delBndrR, delBndrsL, delBndrsR, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv + ) where + +import OccName +import Var +import VarSet +import UniqFM +import Unique +import Util +import Maybes +import Outputable +import FastTypes +import StaticFlags +import FastString + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point +data InScopeSet = InScope (VarEnv Var) FastInt + -- The (VarEnv Var) is just a VarSet. But we write it like + -- this to remind ourselves that you can look up a Var in + -- the InScopeSet. Typically the InScopeSet contains the + -- canonical version of the variable (e.g. with an informative + -- unfolding), so this lookup is useful. + -- + -- INVARIANT: the VarEnv maps (the Unique of) a variable to + -- a variable with the same Uniqua. (This was not + -- the case in the past, when we had a grevious hack + -- mapping var1 to var2. + -- + -- The FastInt is a kind of hash-value used by uniqAway + -- For example, it might be the size of the set + -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway + +instance Outputable InScopeSet where + ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet (_ILIT(1)) + +getInScopeVars :: InScopeSet -> VarEnv Var +getInScopeVars (InScope vs _) = vs + +mkInScopeSet :: VarEnv Var -> InScopeSet +mkInScopeSet in_scope = InScope in_scope (_ILIT(1)) + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1)) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) + (n +# iUnbox (length vs)) + +extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet +extendInScopeSetSet (InScope in_scope n) vs + = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs)) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope _) uniq + = lookupVarEnv_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1 _) (InScope s2 n2) + = InScope (s1 `plusVarEnv` s2) n2 + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses a combination of that and the hash-code +-- found in the in-scope set +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' (InScope set n) var + = try (_ILIT(1)) + where + orig_unique = getUnique var + try k + | debugIsOn && (k ># _ILIT(1000)) + = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + | uniq `elemVarSetByKey` set = try (k +# _ILIT(1)) + | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3)) + = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + setVarUnique var uniq + | otherwise = setVarUnique var uniq + where + uniq = deriveUnique orig_unique (iBox (n *# k)) + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +addRnInScopeSet :: RnEnv2 -> VarEnv Var -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarEnv vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b } + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +{- +************************************************************************ +* * +\subsection{@VarEnv@s} +* * +************************************************************************ +-} + +type VarEnv elt = UniqFM elt +type IdEnv elt = VarEnv elt +type TyVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a +varEnvElts :: VarEnv a -> [a] +varEnvKeys :: VarEnv a -> [Unique] + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +minusVarEnv = minusUFM +intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) +plusVarEnv = plusUFM +lookupVarEnv = lookupUFM +filterVarEnv = filterUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +emptyVarEnv = emptyUFM +varEnvElts = eltsUFM +varEnvKeys = keysUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +foldVarEnv = foldUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly +partitionVarEnv = partitionUFM + +restrictVarEnv env vs = filterVarEnv_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs new file mode 100644 index 00000000..c1341248 --- /dev/null +++ b/compiler/basicTypes/VarSet.hs @@ -0,0 +1,120 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module VarSet ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, extendVarSet_C, + elemVarSet, varSetElems, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, foldVarSet, filterVarSet, fixVarSet, + lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet + ) where + +#include "HsVersions.h" + +import Var ( Var, TyVar, CoVar, Id ) +import Unique +import UniqSet + +{- +************************************************************************ +* * +\subsection{@VarSet@s} +* * +************************************************************************ +-} + +type VarSet = UniqSet Var +type IdSet = UniqSet Id +type TyVarSet = UniqSet TyVar +type CoVarSet = UniqSet CoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function oer the list, and union the results + +varSetElems :: VarSet -> [Var] +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +mapVarSet :: (Var -> Var) -> VarSet -> VarSet +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet +extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +fixVarSet :: (VarSet -> VarSet) -> VarSet -> VarSet +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +varSetElems = uniqSetToList +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +foldVarSet = foldUniqSet +lookupVarSet = lookupUniqSet +mapVarSet = mapUniqSet +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +extendVarSet_C = addOneToUniqSet_C +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +-- Iterate f to a fixpoint +fixVarSet f s | new_s `subVarSet` s = s + | otherwise = fixVarSet f new_s + where + new_s = f s + +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c new file mode 100644 index 00000000..08d403d8 --- /dev/null +++ b/compiler/cbits/genSym.c @@ -0,0 +1,17 @@ + +#include "Rts.h" + +static HsInt GenSymCounter = 0; + +HsInt genSym(void) { +#if defined(THREADED_RTS) + if (n_capabilities == 1) { + return GenSymCounter++; + } else { + return atomic_inc((StgWord *)&GenSymCounter, 1); + } +#else + return GenSymCounter++; +#endif +} + diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs new file mode 100644 index 00000000..e7aa0720 --- /dev/null +++ b/compiler/cmm/Bitmap.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} + +-- +-- (c) The University of Glasgow 2003-2006 +-- + +-- Functions for constructing bitmaps, which are used in various +-- places in generated code (stack frame liveness masks, function +-- argument liveness masks, SRT bitmaps). + +module Bitmap ( + Bitmap, mkBitmap, + intsToBitmap, intsToReverseBitmap, + mAX_SMALL_BITMAP_SIZE, + seqBitmap, + ) where + +#include "HsVersions.h" +#include "../includes/MachDeps.h" + +import SMRep +import DynFlags +import Util + +import Data.Bits + +{-| +A bitmap represented by a sequence of 'StgWord's on the /target/ +architecture. These are used for bitmaps in info tables and other +generated code which need to be emitted as sequences of StgWords. +-} +type Bitmap = [StgWord] + +-- | Make a bitmap from a sequence of bits +mkBitmap :: DynFlags -> [Bool] -> Bitmap +mkBitmap _ [] = [] +mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest + where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff + +chunkToBitmap :: DynFlags -> [Bool] -> StgWord +chunkToBitmap dflags chunk = + foldr (.|.) (toStgWord dflags 0) [ toStgWord dflags 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +-- | Make a bitmap where the slots specified are the /ones/ in the bitmap. +-- eg. @[0,1,3], size 4 ==> 0xb@. +-- +-- The list of @Int@s /must/ be already sorted. +intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap +intsToBitmap dflags size slots{- must be sorted -} + | size <= 0 = [] + | otherwise = + (foldr (.|.) (toStgWord dflags 0) (map (toStgWord dflags 1 `shiftL`) these)) : + intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags) + (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) + where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots + +-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. +-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero, +-- just to make the bitmap easier to read). +-- +-- The list of @Int@s /must/ be already sorted and duplicate-free. +intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap +intsToReverseBitmap dflags size slots{- must be sorted -} + | size <= 0 = [] + | otherwise = + (foldr xor (toStgWord dflags init) (map (toStgWord dflags 1 `shiftL`) these)) : + intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags) + (map (\x -> x - wORD_SIZE_IN_BITS dflags) rest) + where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots + init + | size >= wORD_SIZE_IN_BITS dflags = -1 + | otherwise = (1 `shiftL` size) - 1 + +{- | +Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h. +Some kinds of bitmap pack a size\/bitmap into a single word if +possible, or fall back to an external pointer when the bitmap is too +large. This value represents the largest size of bitmap that can be +packed into a single word. +-} +mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int +mAX_SMALL_BITMAP_SIZE dflags + | wORD_SIZE dflags == 4 = 27 + | otherwise = 58 + +seqBitmap :: Bitmap -> a -> a +seqBitmap = seqList + diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs new file mode 100644 index 00000000..e4cc0bcc --- /dev/null +++ b/compiler/cmm/BlockId.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- BlockId module should probably go away completely, being superseded by Label -} +module BlockId + ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet + , BlockSet, BlockEnv + , IsSet(..), setInsertList, setDeleteList, setUnions + , IsMap(..), mapInsertList, mapDeleteList, mapUnions + , emptyBlockSet, emptyBlockMap + , blockLbl, infoTblLbl, retPtLbl + ) where + +import CLabel +import IdInfo +import Name +import Outputable +import Unique + +import Compiler.Hoopl as Hoopl hiding (Unique) +import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique) + +---------------------------------------------------------------- +--- Block Ids, their environments, and their sets + +{- Note [Unique BlockId] +~~~~~~~~~~~~~~~~~~~~~~~~ +Although a 'BlockId' is a local label, for reasons of implementation, +'BlockId's must be unique within an entire compilation unit. The reason +is that each local label is mapped to an assembly-language label, and in +most assembly languages allow, a label is visible throughout the entire +compilation unit in which it appears. +-} + +type BlockId = Hoopl.Label + +instance Uniquable BlockId where + getUnique label = getUnique (lblToUnique label) + +instance Outputable BlockId where + ppr label = ppr (getUnique label) + +mkBlockId :: Unique -> BlockId +mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique + +retPtLbl :: BlockId -> CLabel +retPtLbl label = mkReturnPtLabel $ getUnique label + +blockLbl :: BlockId -> CLabel +blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs + +infoTblLbl :: BlockId -> CLabel +infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs + +-- Block environments: Id blocks +type BlockEnv a = Hoopl.LabelMap a + +instance Outputable a => Outputable (BlockEnv a) where + ppr = ppr . mapToList + +emptyBlockMap :: BlockEnv a +emptyBlockMap = mapEmpty + +-- Block sets +type BlockSet = Hoopl.LabelSet + +instance Outputable BlockSet where + ppr = ppr . setElems + +emptyBlockSet :: BlockSet +emptyBlockSet = setEmpty diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs new file mode 100644 index 00000000..ebf902f1 --- /dev/null +++ b/compiler/cmm/CLabel.hs @@ -0,0 +1,1209 @@ +----------------------------------------------------------------------------- +-- +-- Object-file symbols (called CLabel for histerical raisins). +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module CLabel ( + CLabel, -- abstract type + ForeignLabelSource(..), + pprDebugCLabel, + + mkClosureLabel, + mkSRTLabel, + mkTopSRTLabel, + mkInfoTableLabel, + mkEntryLabel, + mkSlowEntryLabel, + mkConEntryLabel, + mkStaticConEntryLabel, + mkRednCountsLabel, + mkConInfoTableLabel, + mkStaticInfoTableLabel, + mkLargeSRTLabel, + mkApEntryLabel, + mkApInfoTableLabel, + mkClosureTableLabel, + + mkLocalClosureLabel, + mkLocalInfoTableLabel, + mkLocalEntryLabel, + mkLocalConEntryLabel, + mkLocalStaticConEntryLabel, + mkLocalConInfoTableLabel, + mkLocalStaticInfoTableLabel, + mkLocalClosureTableLabel, + + mkReturnPtLabel, + mkReturnInfoLabel, + mkAltLabel, + mkDefaultLabel, + mkBitmapLabel, + mkStringLitLabel, + + mkAsmTempLabel, + mkAsmTempDerivedLabel, + mkAsmTempEndLabel, + + mkPlainModuleInitLabel, + + mkSplitMarkerLabel, + mkDirty_MUT_VAR_Label, + mkUpdInfoLabel, + mkBHUpdInfoLabel, + mkIndStaticInfoLabel, + mkMainCapabilityLabel, + mkMAP_FROZEN_infoLabel, + mkMAP_FROZEN0_infoLabel, + mkMAP_DIRTY_infoLabel, + mkSMAP_FROZEN_infoLabel, + mkSMAP_FROZEN0_infoLabel, + mkSMAP_DIRTY_infoLabel, + mkEMPTY_MVAR_infoLabel, + mkArrWords_infoLabel, + + mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, + mkCAFBlackHoleEntryLabel, + mkRtsPrimOpLabel, + mkRtsSlowFastTickyCtrLabel, + + mkSelectorInfoLabel, + mkSelectorEntryLabel, + + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkCmmClosureLabel, + + mkRtsApFastLabel, + + mkPrimCallLabel, + + mkForeignLabel, + addLabelSize, + foreignLabelStdcallInfo, + + mkCCLabel, mkCCSLabel, + + DynamicLinkerLabelInfo(..), + mkDynamicLinkerLabel, + dynamicLinkerLabelInfo, + + mkPicBaseLabel, + mkDeadStripPreventer, + + mkHpcTicksLabel, + + hasCAF, + needsCDecl, maybeAsmTemp, externallyVisibleCLabel, + isMathFun, + isCFunctionLabel, isGcPtrLabel, labelDynamic, + + -- * Conversions + toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, toRednCountsLbl, hasHaskellName, + + pprCLabel + ) where + +import IdInfo +import BasicTypes +import Packages +import Module +import Name +import Unique +import PrimOp +import Config +import CostCentre +import Outputable +import FastString +import DynFlags +import Platform +import UniqSet +import PprCore ( {- instances -} ) + +-- ----------------------------------------------------------------------------- +-- The CLabel type + +{- + | CLabel is an abstract type that supports the following operations: + + - Pretty printing + + - In a C file, does it need to be declared before use? (i.e. is it + guaranteed to be already in scope in the places we need to refer to it?) + + - If it needs to be declared, what type (code or data) should it be + declared to have? + + - Is it visible outside this object file or not? + + - Is it "dynamic" (see details below) + + - Eq and Ord, so that we can make sets of CLabels (currently only + used in outputting C as far as I can tell, to avoid generating + more than one declaration for any given label). + + - Converting an info table label into an entry label. +-} + +data CLabel + = -- | A label related to the definition of a particular Id or Con in a .hs file. + IdLabel + Name + CafInfo + IdLabelInfo -- encodes the suffix of the label + + -- | A label from a .cmm file that is not associated with a .hs level Id. + | CmmLabel + PackageKey -- what package the label belongs to. + FastString -- identifier giving the prefix of the label + CmmLabelInfo -- encodes the suffix of the label + + -- | A label with a baked-in \/ algorithmically generated name that definitely + -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so + -- If it doesn't have an algorithmically generated name then use a CmmLabel + -- instead and give it an appropriate PackageKey argument. + | RtsLabel + RtsLabelInfo + + -- | A 'C' (or otherwise foreign) label. + -- + | ForeignLabel + FastString -- name of the imported label. + + (Maybe Int) -- possible '@n' suffix for stdcall functions + -- When generating C, the '@n' suffix is omitted, but when + -- generating assembler we must add it to the label. + + ForeignLabelSource -- what package the foreign label is in. + + FunctionOrData + + -- | A family of labels related to a particular case expression. + | CaseLabel + {-# UNPACK #-} !Unique -- Unique says which case expression + CaseLabelInfo + + | AsmTempLabel + {-# UNPACK #-} !Unique + + | AsmTempDerivedLabel + CLabel + FastString -- suffix + + | StringLitLabel + {-# UNPACK #-} !Unique + + | PlainModuleInitLabel -- without the version & way info + Module + + | CC_Label CostCentre + | CCS_Label CostCentreStack + + + -- | These labels are generated and used inside the NCG only. + -- They are special variants of a label used for dynamic linking + -- see module PositionIndependentCode for details. + | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel + + -- | This label is generated and used inside the NCG only. + -- It is used as a base for PIC calculations on some platforms. + -- It takes the form of a local numeric assembler label '1'; and + -- is pretty-printed as 1b, referring to the previous definition + -- of 1: in the assembler source file. + | PicBaseLabel + + -- | A label before an info table to prevent excessive dead-stripping on darwin + | DeadStripPreventer CLabel + + + -- | Per-module table of tick locations + | HpcTicksLabel Module + + -- | Static reference table + | SRTLabel !Unique + + -- | Label of an StgLargeSRT + | LargeSRTLabel + {-# UNPACK #-} !Unique + + -- | A bitmap (function or case return) + | LargeBitmapLabel + {-# UNPACK #-} !Unique + + deriving (Eq, Ord) + + +-- | Record where a foreign label is stored. +data ForeignLabelSource + + -- | Label is in a named package + = ForeignLabelInPackage PackageKey + + -- | Label is in some external, system package that doesn't also + -- contain compiled Haskell code, and is not associated with any .hi files. + -- We don't have to worry about Haskell code being inlined from + -- external packages. It is safe to treat the RTS package as "external". + | ForeignLabelInExternalPackage + + -- | Label is in the package currenly being compiled. + -- This is only used for creating hacky tmp labels during code generation. + -- Don't use it in any code that might be inlined across a package boundary + -- (ie, core code) else the information will be wrong relative to the + -- destination module. + | ForeignLabelInThisPackage + + deriving (Eq, Ord) + + +-- | For debugging problems with the CLabel representation. +-- We can't make a Show instance for CLabel because lots of its components don't have instances. +-- The regular Outputable instance only shows the label name, and not its other info. +-- +pprDebugCLabel :: CLabel -> SDoc +pprDebugCLabel lbl + = case lbl of + IdLabel{} -> ppr lbl <> (parens $ text "IdLabel") + CmmLabel pkg _name _info + -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) + + RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel") + + ForeignLabel _name mSuffix src funOrData + -> ppr lbl <> (parens $ text "ForeignLabel" + <+> ppr mSuffix + <+> ppr src + <+> ppr funOrData) + + _ -> ppr lbl <> (parens $ text "other CLabel)") + + +data IdLabelInfo + = Closure -- ^ Label for closure + | SRT -- ^ Static reference table (TODO: could be removed + -- with the old code generator, but might be needed + -- when we implement the New SRT Plan) + | InfoTable -- ^ Info tables for closures; always read-only + | Entry -- ^ Entry point + | Slow -- ^ Slow entry point + + | LocalInfoTable -- ^ Like InfoTable but not externally visible + | LocalEntry -- ^ Like Entry but not externally visible + + | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id + + | ConEntry -- ^ Constructor entry point + | ConInfoTable -- ^ Corresponding info table + | StaticConEntry -- ^ Static constructor entry point + | StaticInfoTable -- ^ Corresponding info table + + | ClosureTable -- ^ Table of closures for Enum tycons + + deriving (Eq, Ord) + + +data CaseLabelInfo + = CaseReturnPt + | CaseReturnInfo + | CaseAlt ConTag + | CaseDefault + deriving (Eq, Ord) + + +data RtsLabelInfo + = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks + | RtsSelectorEntry Bool{-updatable-} Int{-offset-} + + | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks + | RtsApEntry Bool{-updatable-} Int{-arity-} + + | RtsPrimOp PrimOp + | RtsApFast FastString -- ^ _fast versions of generic apply + | RtsSlowFastTickyCtr String + + deriving (Eq, Ord) + -- NOTE: Eq on LitString compares the pointer only, so this isn't + -- a real equality. + + +-- | What type of Cmm label we're dealing with. +-- Determines the suffix appended to the name when a CLabel.CmmLabel +-- is pretty printed. +data CmmLabelInfo + = CmmInfo -- ^ misc rts info tabless, suffix _info + | CmmEntry -- ^ misc rts entry points, suffix _entry + | CmmRetInfo -- ^ misc rts ret info tables, suffix _info + | CmmRet -- ^ misc rts return points, suffix _ret + | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure + | CmmCode -- ^ misc rts code + | CmmClosure -- ^ closures eg CHARLIKE_closure + | CmmPrimCall -- ^ a prim call to some hand written Cmm code + deriving (Eq, Ord) + +data DynamicLinkerLabelInfo + = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt + | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo + | GotSymbolPtr -- ELF: foo@got + | GotSymbolOffset -- ELF: foo@gotoff + + deriving (Eq, Ord) + + +-- ----------------------------------------------------------------------------- +-- Constructing CLabels +-- ----------------------------------------------------------------------------- + +-- Constructing IdLabels +-- These are always local: +mkSlowEntryLabel :: Name -> CafInfo -> CLabel +mkSlowEntryLabel name c = IdLabel name c Slow + +mkTopSRTLabel :: Unique -> CLabel +mkTopSRTLabel u = SRTLabel u + +mkSRTLabel :: Name -> CafInfo -> CLabel +mkRednCountsLabel :: Name -> CLabel +mkSRTLabel name c = IdLabel name c SRT +mkRednCountsLabel name = + IdLabel name NoCafRefs RednCounts -- Note [ticky for LNE] + +-- These have local & (possibly) external variants: +mkLocalClosureLabel :: Name -> CafInfo -> CLabel +mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel +mkLocalEntryLabel :: Name -> CafInfo -> CLabel +mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel +mkLocalClosureLabel name c = IdLabel name c Closure +mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable +mkLocalEntryLabel name c = IdLabel name c LocalEntry +mkLocalClosureTableLabel name c = IdLabel name c ClosureTable + +mkClosureLabel :: Name -> CafInfo -> CLabel +mkInfoTableLabel :: Name -> CafInfo -> CLabel +mkEntryLabel :: Name -> CafInfo -> CLabel +mkClosureTableLabel :: Name -> CafInfo -> CLabel +mkLocalConInfoTableLabel :: CafInfo -> Name -> CLabel +mkLocalConEntryLabel :: CafInfo -> Name -> CLabel +mkLocalStaticInfoTableLabel :: CafInfo -> Name -> CLabel +mkLocalStaticConEntryLabel :: CafInfo -> Name -> CLabel +mkConInfoTableLabel :: Name -> CafInfo -> CLabel +mkStaticInfoTableLabel :: Name -> CafInfo -> CLabel +mkClosureLabel name c = IdLabel name c Closure +mkInfoTableLabel name c = IdLabel name c InfoTable +mkEntryLabel name c = IdLabel name c Entry +mkClosureTableLabel name c = IdLabel name c ClosureTable +mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable +mkLocalConEntryLabel c con = IdLabel con c ConEntry +mkLocalStaticInfoTableLabel c con = IdLabel con c StaticInfoTable +mkLocalStaticConEntryLabel c con = IdLabel con c StaticConEntry +mkConInfoTableLabel name c = IdLabel name c ConInfoTable +mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable + +mkConEntryLabel :: Name -> CafInfo -> CLabel +mkStaticConEntryLabel :: Name -> CafInfo -> CLabel +mkConEntryLabel name c = IdLabel name c ConEntry +mkStaticConEntryLabel name c = IdLabel name c StaticConEntry + +-- Constructing Cmm Labels +mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, + mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, + mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel, + mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel, + mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel, + mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel, + mkSMAP_DIRTY_infoLabel :: CLabel +mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction +mkSplitMarkerLabel = CmmLabel rtsPackageKey (fsLit "__stg_split_marker") CmmCode +mkUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_upd_frame") CmmInfo +mkBHUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_bh_upd_frame" ) CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsPackageKey (fsLit "MainCapability") CmmData +mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo +mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_EMPTY_MVAR") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsPackageKey (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmEntry +mkArrWords_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_ARR_WORDS") CmmInfo +mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo +mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo + +----- +mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, + mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel + :: PackageKey -> FastString -> CLabel + +mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo +mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry +mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo +mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet +mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode +mkCmmDataLabel pkg str = CmmLabel pkg str CmmData +mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure + + +-- Constructing RtsLabels +mkRtsPrimOpLabel :: PrimOp -> CLabel +mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) + +mkSelectorInfoLabel :: Bool -> Int -> CLabel +mkSelectorEntryLabel :: Bool -> Int -> CLabel +mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) +mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) + +mkApInfoTableLabel :: Bool -> Int -> CLabel +mkApEntryLabel :: Bool -> Int -> CLabel +mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) +mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) + + +-- A call to some primitive hand written Cmm code +mkPrimCallLabel :: PrimCall -> CLabel +mkPrimCallLabel (PrimCall str pkg) + = CmmLabel pkg str CmmPrimCall + + +-- Constructing ForeignLabels + +-- | Make a foreign label +mkForeignLabel + :: FastString -- name + -> Maybe Int -- size prefix + -> ForeignLabelSource -- what package it's in + -> FunctionOrData + -> CLabel + +mkForeignLabel str mb_sz src fod + = ForeignLabel str mb_sz src fod + + +-- | Update the label size field in a ForeignLabel +addLabelSize :: CLabel -> Int -> CLabel +addLabelSize (ForeignLabel str _ src fod) sz + = ForeignLabel str (Just sz) src fod +addLabelSize label _ + = label + +-- | Get the label size field from a ForeignLabel +foreignLabelStdcallInfo :: CLabel -> Maybe Int +foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info +foreignLabelStdcallInfo _lbl = Nothing + + +-- Constructing Large*Labels +mkLargeSRTLabel :: Unique -> CLabel +mkBitmapLabel :: Unique -> CLabel +mkLargeSRTLabel uniq = LargeSRTLabel uniq +mkBitmapLabel uniq = LargeBitmapLabel uniq + + +-- Constructin CaseLabels +mkReturnPtLabel :: Unique -> CLabel +mkReturnInfoLabel :: Unique -> CLabel +mkAltLabel :: Unique -> ConTag -> CLabel +mkDefaultLabel :: Unique -> CLabel +mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt +mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo +mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) +mkDefaultLabel uniq = CaseLabel uniq CaseDefault + +-- Constructing Cost Center Labels +mkCCLabel :: CostCentre -> CLabel +mkCCSLabel :: CostCentreStack -> CLabel +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs + +mkRtsApFastLabel :: FastString -> CLabel +mkRtsApFastLabel str = RtsLabel (RtsApFast str) + +mkRtsSlowFastTickyCtrLabel :: String -> CLabel +mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) + + +-- Constructing Code Coverage Labels +mkHpcTicksLabel :: Module -> CLabel +mkHpcTicksLabel = HpcTicksLabel + + +-- Constructing labels used for dynamic linking +mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel +mkDynamicLinkerLabel = DynamicLinkerLabel + +dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) +dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) +dynamicLinkerLabelInfo _ = Nothing + +mkPicBaseLabel :: CLabel +mkPicBaseLabel = PicBaseLabel + + +-- Constructing miscellaneous other labels +mkDeadStripPreventer :: CLabel -> CLabel +mkDeadStripPreventer lbl = DeadStripPreventer lbl + +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel + +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) + +mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel +mkAsmTempDerivedLabel = AsmTempDerivedLabel + +mkAsmTempEndLabel :: CLabel -> CLabel +mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") +mkPlainModuleInitLabel :: Module -> CLabel +mkPlainModuleInitLabel mod = PlainModuleInitLabel mod + +-- ----------------------------------------------------------------------------- +-- Convert between different kinds of label + +toClosureLbl :: CLabel -> CLabel +toClosureLbl (IdLabel n c _) = IdLabel n c Closure +toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure +toClosureLbl l = pprPanic "toClosureLbl" (ppr l) + +toSlowEntryLbl :: CLabel -> CLabel +toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow +toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) + +toEntryLbl :: CLabel -> CLabel +toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry +toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +toEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry +toEntryLbl (IdLabel n c _) = IdLabel n c Entry +toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry +toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet +toEntryLbl l = pprPanic "toEntryLbl" (ppr l) + +toInfoLbl :: CLabel -> CLabel +toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable +toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +toInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable +toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable +toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l) + +toRednCountsLbl :: CLabel -> Maybe CLabel +toRednCountsLbl = fmap mkRednCountsLabel . hasHaskellName + +hasHaskellName :: CLabel -> Maybe Name +hasHaskellName (IdLabel n _ _) = Just n +hasHaskellName _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Does a CLabel's referent itself refer to a CAF? +hasCAF :: CLabel -> Bool +hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE] +hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF _ = False + +-- Note [ticky for LNE] +-- ~~~~~~~~~~~~~~~~~~~~~ + +-- Until 14 Feb 2013, every ticky counter was associated with a +-- closure. Thus, ticky labels used IdLabel. It is odd that +-- CmmBuildInfoTables.cafTransfers would consider such a ticky label +-- reason to add the name to the CAFEnv (and thus eventually the SRT), +-- but it was harmless because the ticky was only used if the closure +-- was also. +-- +-- Since we now have ticky counters for LNEs, it is no longer the case +-- that every ticky counter has an actual closure. So I changed the +-- generation of ticky counters' CLabels to not result in their +-- associated id ending up in the SRT. +-- +-- NB IdLabel is still appropriate for ticky ids (as opposed to +-- CmmLabel) because the LNE's counter is still related to an .hs Id, +-- that Id just isn't for a proper closure. + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need declaring before use or not? +-- +-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes + +needsCDecl :: CLabel -> Bool + -- False <=> it's pre-declared; don't bother + -- don't bother declaring Bitmap labels, we always make sure + -- they are defined before use. +needsCDecl (SRTLabel _) = True +needsCDecl (LargeSRTLabel _) = False +needsCDecl (LargeBitmapLabel _) = False +needsCDecl (IdLabel _ _ _) = True +needsCDecl (CaseLabel _ _) = True +needsCDecl (PlainModuleInitLabel _) = True + +needsCDecl (StringLitLabel _) = False +needsCDecl (AsmTempLabel _) = False +needsCDecl (AsmTempDerivedLabel _ _) = False +needsCDecl (RtsLabel _) = False + +needsCDecl (CmmLabel pkgId _ _) + -- Prototypes for labels defined in the runtime system are imported + -- into HC files via includes/Stg.h. + | pkgId == rtsPackageKey = False + + -- For other labels we inline one into the HC file directly. + | otherwise = True + +needsCDecl l@(ForeignLabel{}) = not (isMathFun l) +needsCDecl (CC_Label _) = True +needsCDecl (CCS_Label _) = True +needsCDecl (HpcTicksLabel _) = True +needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" +needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" +needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" + +-- | If a label is a local temporary used for native code generation +-- then return just its unique, otherwise nothing. +maybeAsmTemp :: CLabel -> Maybe Unique +maybeAsmTemp (AsmTempLabel uq) = Just uq +maybeAsmTemp _ = Nothing + + +-- | Check whether a label corresponds to a C function that has +-- a prototype in a system header somehere, or is built-in +-- to the C compiler. For these labels we avoid generating our +-- own C prototypes. +isMathFun :: CLabel -> Bool +isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs +isMathFun _ = False + +math_funs :: UniqSet FastString +math_funs = mkUniqSet [ + -- _ISOC99_SOURCE + (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), + (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), + (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), + (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), + (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), + (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), + (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), + (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), + (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), + (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), + (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), + (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), + (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), + (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), + (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), + (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), + (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), + (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), + (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), + (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), + (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), + (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), + (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), + (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), + (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), + (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), + (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), + (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), + (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), + (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), + (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), + (fsLit "log"), (fsLit "logf"), (fsLit "logl"), + (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), + (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), + (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), + (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), + (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), + (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), + (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), + (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), + (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), + (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), + (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), + (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), + (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), + (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), + (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), + (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), + (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), + (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), + (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), + (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), + (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), + (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), + (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), + (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), + (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), + -- ISO C 99 also defines these function-like macros in math.h: + -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, + -- isgreaterequal, isless, islessequal, islessgreater, isunordered + + -- additional symbols from _BSD_SOURCE + (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), + (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), + (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), + (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), + (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), + (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), + (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), + (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), + (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), + (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), + (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), + (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), + (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), + (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl") + ] + +-- ----------------------------------------------------------------------------- +-- | Is a CLabel visible outside this object file or not? +-- From the point of view of the code generator, a name is +-- externally visible if it has to be declared as exported +-- in the .o file's symbol table; that is, made non-static. +externallyVisibleCLabel :: CLabel -> Bool -- not C "static" +externallyVisibleCLabel (CaseLabel _ _) = False +externallyVisibleCLabel (StringLitLabel _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False +externallyVisibleCLabel (PlainModuleInitLabel _)= True +externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (CmmLabel _ _ _) = True +externallyVisibleCLabel (ForeignLabel{}) = True +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info +externallyVisibleCLabel (CC_Label _) = True +externallyVisibleCLabel (CCS_Label _) = True +externallyVisibleCLabel (DynamicLinkerLabel _ _) = False +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (SRTLabel _) = False +externallyVisibleCLabel (LargeSRTLabel _) = False +externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" +externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" + +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel SRT = False +externallyVisibleIdLabel LocalInfoTable = False +externallyVisibleIdLabel LocalEntry = False +externallyVisibleIdLabel _ = True + +-- ----------------------------------------------------------------------------- +-- Finding the "type" of a CLabel + +-- For generating correct types in label declarations: + +data CLabelType + = CodeLabel -- Address of some executable instructions + | DataLabel -- Address of data, not a GC ptr + | GcPtrLabel -- Address of a (presumably static) GC object + +isCFunctionLabel :: CLabel -> Bool +isCFunctionLabel lbl = case labelType lbl of + CodeLabel -> True + _other -> False + +isGcPtrLabel :: CLabel -> Bool +isGcPtrLabel lbl = case labelType lbl of + GcPtrLabel -> True + _other -> False + + +-- | Work out the general type of data at the address of this label +-- whether it be code, data, or static GC object. +labelType :: CLabel -> CLabelType +labelType (CmmLabel _ _ CmmData) = DataLabel +labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel +labelType (CmmLabel _ _ CmmCode) = CodeLabel +labelType (CmmLabel _ _ CmmInfo) = DataLabel +labelType (CmmLabel _ _ CmmEntry) = CodeLabel +labelType (CmmLabel _ _ CmmPrimCall) = CodeLabel +labelType (CmmLabel _ _ CmmRetInfo) = DataLabel +labelType (CmmLabel _ _ CmmRet) = CodeLabel +labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApFast _)) = CodeLabel +labelType (CaseLabel _ CaseReturnInfo) = DataLabel +labelType (CaseLabel _ _) = CodeLabel +labelType (PlainModuleInitLabel _) = CodeLabel +labelType (SRTLabel _) = DataLabel +labelType (LargeSRTLabel _) = DataLabel +labelType (LargeBitmapLabel _) = DataLabel +labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel +labelType (IdLabel _ _ info) = idInfoLabelType info +labelType _ = DataLabel + +idInfoLabelType :: IdLabelInfo -> CLabelType +idInfoLabelType info = + case info of + InfoTable -> DataLabel + LocalInfoTable -> DataLabel + Closure -> GcPtrLabel + ConInfoTable -> DataLabel + StaticInfoTable -> DataLabel + ClosureTable -> DataLabel + RednCounts -> DataLabel + _ -> CodeLabel + + +-- ----------------------------------------------------------------------------- +-- Does a CLabel need dynamic linkage? + +-- When referring to data in code, we need to know whether +-- that data resides in a DLL or not. [Win32 only.] +-- @labelDynamic@ returns @True@ if the label is located +-- in a DLL, be it a data reference or not. + +labelDynamic :: DynFlags -> PackageKey -> Module -> CLabel -> Bool +labelDynamic dflags this_pkg this_mod lbl = + case lbl of + -- is the RTS in a DLL or not? + RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageKey) + + IdLabel n _ _ -> isDllName dflags this_pkg this_mod n + + -- When compiling in the "dyn" way, each package is to be linked into + -- its own shared library. + CmmLabel pkg _ _ + | os == OSMinGW32 -> + not (gopt Opt_Static dflags) && (this_pkg /= pkg) + | otherwise -> + True + + ForeignLabel _ _ source _ -> + if os == OSMinGW32 + then case source of + -- Foreign label is in some un-named foreign package (or DLL). + ForeignLabelInExternalPackage -> True + + -- Foreign label is linked into the same package as the + -- source file currently being compiled. + ForeignLabelInThisPackage -> False + + -- Foreign label is in some named package. + -- When compiling in the "dyn" way, each package is to be + -- linked into its own DLL. + ForeignLabelInPackage pkgId -> + (not (gopt Opt_Static dflags)) && (this_pkg /= pkgId) + + else -- On Mac OS X and on ELF platforms, false positives are OK, + -- so we claim that all foreign imports come from dynamic + -- libraries + True + + PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m) + + HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_mod /= m + + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. + _ -> False + where os = platformOS (targetPlatform dflags) + +{- +OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the +right places. It is used to detect when the abstractC statement of an +CCodeBlock actually contains the code for a slow entry point. -- HWL + +We need at least @Eq@ for @CLabels@, because we want to avoid +duplicate declarations in generating C (see @labelSeenTE@ in +@PprAbsC@). +-} + +----------------------------------------------------------------------------- +-- Printing out CLabels. + +{- +Convention: + + _ + +where is _ for external names and for +internal names. is one of the following: + + info Info table + srt Static reference table + srtd Static reference table descriptor + entry Entry code (function, closure) + slow Slow entry code (if any) + ret Direct return address + vtbl Vector table + _alt Case alternative (tag n) + dflt Default case alternative + btm Large bitmap vector + closure Static closure + con_entry Dynamic Constructor entry code + con_info Dynamic Constructor info table + static_entry Static Constructor entry code + static_info Static Constructor info table + sel_info Selector info table + sel_entry Selector entry code + cc Cost centre + ccs Cost centre stack + +Many of these distinctions are only for documentation reasons. For +example, _ret is only distinguished from _entry to make it easy to +tell whether a code fragment is a return point or a closure/function +entry. + +Note [Closure and info labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a function 'foo, we have: + foo_info : Points to the info table describing foo's closure + (and entry code for foo with tables next to code) + foo_closure : Static (no-free-var) closure only: + points to the statically-allocated closure + +For a data constructor (such as Just or Nothing), we have: + Just_con_info: Info table for the data constructor itself + the first word of a heap-allocated Just + Just_info: Info table for the *worker function*, an + ordinary Haskell function of arity 1 that + allocates a (Just x) box: + Just = \x -> Just x + Just_closure: The closure for this worker + + Nothing_closure: a statically allocated closure for Nothing + Nothing_static_info: info table for Nothing_closure + +All these must be exported symbol, EXCEPT Just_info. We don't need to +export this because in other modules we either have + * A reference to 'Just'; use Just_closure + * A saturated call 'Just x'; allocate using Just_con_info +Not exporting these Just_info labels reduces the number of symbols +somewhat. +-} + +instance Outputable CLabel where + ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c + +pprCLabel :: Platform -> CLabel -> SDoc + +pprCLabel platform (AsmTempLabel u) + | cGhcWithNativeCodeGen == "YES" + = getPprStyle $ \ sty -> + if asmStyle sty then + ptext (asmTempLabelPrefix platform) <> pprUnique u + else + char '_' <> pprUnique u + +pprCLabel platform (AsmTempDerivedLabel l suf) + | cGhcWithNativeCodeGen == "YES" + = ptext (asmTempLabelPrefix platform) + <> case l of AsmTempLabel u -> pprUnique u + _other -> pprCLabel platform l + <> ftext suf + +pprCLabel platform (DynamicLinkerLabel info lbl) + | cGhcWithNativeCodeGen == "YES" + = pprDynamicLinkerAsmLabel platform info lbl + +pprCLabel _ PicBaseLabel + | cGhcWithNativeCodeGen == "YES" + = ptext (sLit "1b") + +pprCLabel platform (DeadStripPreventer lbl) + | cGhcWithNativeCodeGen == "YES" + = pprCLabel platform lbl <> ptext (sLit "_dsp") + +pprCLabel platform lbl + = getPprStyle $ \ sty -> + if cGhcWithNativeCodeGen == "YES" && asmStyle sty + then maybe_underscore (pprAsmCLbl platform lbl) + else pprCLbl lbl + +maybe_underscore :: SDoc -> SDoc +maybe_underscore doc + | underscorePrefix = pp_cSEP <> doc + | otherwise = doc + +pprAsmCLbl :: Platform -> CLabel -> SDoc +pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) + | platformOS platform == OSMinGW32 + -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. + -- (The C compiler does this itself). + = ftext fs <> char '@' <> int sz +pprAsmCLbl _ lbl + = pprCLbl lbl + +pprCLbl :: CLabel -> SDoc +pprCLbl (StringLitLabel u) + = pprUnique u <> ptext (sLit "_str") + +pprCLbl (CaseLabel u CaseReturnPt) + = hcat [pprUnique u, ptext (sLit "_ret")] +pprCLbl (CaseLabel u CaseReturnInfo) + = hcat [pprUnique u, ptext (sLit "_info")] +pprCLbl (CaseLabel u (CaseAlt tag)) + = hcat [pprUnique u, pp_cSEP, int tag, ptext (sLit "_alt")] +pprCLbl (CaseLabel u CaseDefault) + = hcat [pprUnique u, ptext (sLit "_dflt")] + +pprCLbl (SRTLabel u) + = pprUnique u <> pp_cSEP <> ptext (sLit "srt") + +pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") +pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") +-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') +-- until that gets resolved we'll just force them to start +-- with a letter so the label will be legal assmbly code. + + +pprCLbl (CmmLabel _ str CmmCode) = ftext str +pprCLbl (CmmLabel _ str CmmData) = ftext str +pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str + +pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") + +pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) + = hcat [ptext (sLit "stg_sel_"), text (show offset), + ptext (if upd_reqd + then (sLit "_upd_info") + else (sLit "_noupd_info")) + ] + +pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) + = hcat [ptext (sLit "stg_sel_"), text (show offset), + ptext (if upd_reqd + then (sLit "_upd_entry") + else (sLit "_noupd_entry")) + ] + +pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) + = hcat [ptext (sLit "stg_ap_"), text (show arity), + ptext (if upd_reqd + then (sLit "_upd_info") + else (sLit "_noupd_info")) + ] + +pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) + = hcat [ptext (sLit "stg_ap_"), text (show arity), + ptext (if upd_reqd + then (sLit "_upd_entry") + else (sLit "_noupd_entry")) + ] + +pprCLbl (CmmLabel _ fs CmmInfo) + = ftext fs <> ptext (sLit "_info") + +pprCLbl (CmmLabel _ fs CmmEntry) + = ftext fs <> ptext (sLit "_entry") + +pprCLbl (CmmLabel _ fs CmmRetInfo) + = ftext fs <> ptext (sLit "_info") + +pprCLbl (CmmLabel _ fs CmmRet) + = ftext fs <> ptext (sLit "_ret") + +pprCLbl (CmmLabel _ fs CmmClosure) + = ftext fs <> ptext (sLit "_closure") + +pprCLbl (RtsLabel (RtsPrimOp primop)) + = ptext (sLit "stg_") <> ppr primop + +pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat)) + = ptext (sLit "SLOW_CALL_fast_") <> text pat <> ptext (sLit "_ctr") + +pprCLbl (ForeignLabel str _ _ _) + = ftext str + +pprCLbl (IdLabel name _cafs flavor) = ppr name <> ppIdFlavor flavor + +pprCLbl (CC_Label cc) = ppr cc +pprCLbl (CCS_Label ccs) = ppr ccs + +pprCLbl (PlainModuleInitLabel mod) + = ptext (sLit "__stginit_") <> ppr mod + +pprCLbl (HpcTicksLabel mod) + = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") + +pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel" +pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel" +pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel" +pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel" +pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer" + +ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor x = pp_cSEP <> + (case x of + Closure -> ptext (sLit "closure") + SRT -> ptext (sLit "srt") + InfoTable -> ptext (sLit "info") + LocalInfoTable -> ptext (sLit "info") + Entry -> ptext (sLit "entry") + LocalEntry -> ptext (sLit "entry") + Slow -> ptext (sLit "slow") + RednCounts -> ptext (sLit "ct") + ConEntry -> ptext (sLit "con_entry") + ConInfoTable -> ptext (sLit "con_info") + StaticConEntry -> ptext (sLit "static_entry") + StaticInfoTable -> ptext (sLit "static_info") + ClosureTable -> ptext (sLit "closure_tbl") + ) + + +pp_cSEP :: SDoc +pp_cSEP = char '_' + + +instance Outputable ForeignLabelSource where + ppr fs + = case fs of + ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId + ForeignLabelInThisPackage -> parens $ text "this package" + ForeignLabelInExternalPackage -> parens $ text "external package" + +-- ----------------------------------------------------------------------------- +-- Machine-dependent knowledge about labels. + +underscorePrefix :: Bool -- leading underscore on assembler labels? +underscorePrefix = (cLeadingUnderscore == "YES") + +asmTempLabelPrefix :: Platform -> LitString -- for formatting labels +asmTempLabelPrefix platform = + if platformOS platform == OSDarwin + then sLit "L" + else sLit ".L" + +pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc +pprDynamicLinkerAsmLabel platform dllInfo lbl + = if platformOS platform == OSDarwin + then if platformArch platform == ArchX86_64 + then case dllInfo of + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" + GotSymbolPtr -> ppr lbl <> text "@GOTPCREL" + GotSymbolOffset -> ppr lbl + else case dllInfo of + CodeStub -> char 'L' <> ppr lbl <> text "$stub" + SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr" + _ -> panic "pprDynamicLinkerAsmLabel" + + else if osElfTarget (platformOS platform) + then if platformArch platform == ArchPPC + then case dllInfo of + CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] + ppr lbl <> text "+32768@plt" + SymbolPtr -> text ".LC_" <> ppr lbl + _ -> panic "pprDynamicLinkerAsmLabel" + else if platformArch platform == ArchX86_64 + then case dllInfo of + CodeStub -> ppr lbl <> text "@plt" + GotSymbolPtr -> ppr lbl <> text "@gotpcrel" + GotSymbolOffset -> ppr lbl + SymbolPtr -> text ".LC_" <> ppr lbl + else case dllInfo of + CodeStub -> ppr lbl <> text "@plt" + SymbolPtr -> text ".LC_" <> ppr lbl + GotSymbolPtr -> ppr lbl <> text "@got" + GotSymbolOffset -> ppr lbl <> text "@gotoff" + else if platformOS platform == OSMinGW32 + then case dllInfo of + SymbolPtr -> text "__imp_" <> ppr lbl + _ -> panic "pprDynamicLinkerAsmLabel" + else panic "pprDynamicLinkerAsmLabel" + diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs new file mode 100644 index 00000000..9e9bae93 --- /dev/null +++ b/compiler/cmm/Cmm.hs @@ -0,0 +1,212 @@ +-- Cmm representations using Hoopl's Graph CmmNode e x. +{-# LANGUAGE CPP, GADTs #-} + +module Cmm ( + -- * Cmm top-level datatypes + CmmProgram, CmmGroup, GenCmmGroup, + CmmDecl, GenCmmDecl(..), + CmmGraph, GenCmmGraph(..), + CmmBlock, + RawCmmDecl, RawCmmGroup, + Section(..), CmmStatics(..), CmmStatic(..), + + -- ** Blocks containing lists + GenBasicBlock(..), blockId, + ListGraph(..), pprBBlock, + + -- * Cmm graphs + CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite, + + -- * Info Tables + CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, + ClosureTypeInfo(..), + C_SRT(..), needsSRT, + ProfilingInfo(..), ConstrDescription, + + -- * Statements, expressions and types + module CmmNode, + module CmmExpr, + ) where + +import CLabel +import BlockId +import CmmNode +import SMRep +import CmmExpr +import UniqSupply +import Compiler.Hoopl +import Outputable + +import Data.Word ( Word8 ) + +#include "HsVersions.h" + +----------------------------------------------------------------------------- +-- Cmm, GenCmm +----------------------------------------------------------------------------- + +-- A CmmProgram is a list of CmmGroups +-- A CmmGroup is a list of top-level declarations + +-- When object-splitting is on,each group is compiled into a separate +-- .o file. So typically we put closely related stuff in a CmmGroup. + +type CmmProgram = [CmmGroup] + +type GenCmmGroup d h g = [GenCmmDecl d h g] +type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph + +----------------------------------------------------------------------------- +-- CmmDecl, GenCmmDecl +----------------------------------------------------------------------------- + +-- GenCmmDecl is abstracted over +-- d, the type of static data elements in CmmData +-- h, the static info preceding the code of a CmmProc +-- g, the control-flow graph of a CmmProc +-- +-- We expect there to be two main instances of this type: +-- (a) C--, i.e. populated with various C-- constructs +-- (b) Native code, populated with data/instructions + +-- | A top-level chunk, abstracted over the type of the contents of +-- the basic blocks (Cmm or instructions are the likely instantiations). +data GenCmmDecl d h g + = CmmProc -- A procedure + h -- Extra header such as the info table + CLabel -- Entry label + [GlobalReg] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProcs. + g -- Control-flow graph for the procedure's code + + | CmmData -- Static data + Section + d + +type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph + +type RawCmmDecl + = GenCmmDecl + CmmStatics + (BlockEnv CmmStatics) + CmmGraph + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +type CmmBlock = Block CmmNode C C + +type CmmReplGraph e x = GenCmmReplGraph CmmNode e x +type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x)) +type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f +type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f + +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable + , stack_info :: CmmStackInfo } + +topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing + +data CmmStackInfo + = StackInfo { + arg_space :: ByteOff, + -- number of bytes of arguments on the stack on entry to the + -- the proc. This is filled in by StgCmm.codeGen, and used + -- by the stack allocator later. + updfr_space :: Maybe ByteOff, + -- XXX: this never contains anything useful, but it should. + -- See comment in CmmLayoutStack. + do_layout :: Bool + -- Do automatic stack layout for this proc. This is + -- True for all code generated by the code generator, + -- but is occasionally False for hand-written Cmm where + -- we want to do the stack manipulation manually. + } + +-- | Info table as a haskell data type +data CmmInfoTable + = CmmInfoTable { + cit_lbl :: CLabel, -- Info table label + cit_rep :: SMRep, + cit_prof :: ProfilingInfo, + cit_srt :: C_SRT + } + +data ProfilingInfo + = NoProfilingInfo + | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc + +-- C_SRT is what StgSyn.SRT gets translated to... +-- we add a label for the table, and expect only the 'offset/length' form + +data C_SRT = NoC_SRT + | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + deriving (Eq) + +needsSRT :: C_SRT -> Bool +needsSRT NoC_SRT = False +needsSRT (C_SRT _ _ _) = True + +----------------------------------------------------------------------------- +-- Static Data +----------------------------------------------------------------------------- + +data Section + = Text + | Data + | ReadOnlyData + | RelocatableReadOnlyData + | UninitialisedData + | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned + | OtherSection String + +data CmmStatic + = CmmStaticLit CmmLit + -- a literal value, size given by cmmLitRep of the literal. + | CmmUninitialised Int + -- uninitialised data, N bytes long + | CmmString [Word8] + -- string of 8-bit values only, not zero terminated. + +data CmmStatics + = Statics + CLabel -- Label of statics + [CmmStatic] -- The static data itself + +-- ----------------------------------------------------------------------------- +-- Basic blocks consisting of lists + +-- These are used by the LLVM and NCG backends, when populating Cmm +-- with lists of instructions. + +data GenBasicBlock i = BasicBlock BlockId [i] + +-- | The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId :: GenBasicBlock i -> BlockId +blockId (BasicBlock blk_id _ ) = blk_id + +newtype ListGraph i = ListGraph [GenBasicBlock i] + +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock + +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs new file mode 100644 index 00000000..6521a840 --- /dev/null +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE CPP, GADTs #-} + +-- See Note [Deprecations in Hoopl] in Hoopl module +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +module CmmBuildInfoTables + ( CAFSet, CAFEnv, cafAnal + , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData ) +where + +#include "HsVersions.h" + +import Hoopl +import Digraph +import BlockId +import Bitmap +import CLabel +import PprCmmDecl () +import Cmm +import CmmUtils +import CmmInfo +import Data.List +import DynFlags +import Maybes +import Outputable +import SMRep +import UniqSupply +import Util + +import PprCmm() +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad + +import qualified Prelude as P +import Prelude hiding (succ) + +foldSet :: (a -> b -> b) -> b -> Set a -> b +foldSet = Set.foldr + +----------------------------------------------------------------------- +-- SRTs + +{- EXAMPLE + +f = \x. ... g ... + where + g = \y. ... h ... c1 ... + h = \z. ... c2 ... + +c1 & c2 are CAFs + +g and h are local functions, but they have no static closures. When +we generate code for f, we start with a CmmGroup of four CmmDecls: + + [ f_closure, f_entry, g_entry, h_entry ] + +we process each CmmDecl separately in cpsTop, giving us a list of +CmmDecls. e.g. for f_entry, we might end up with + + [ f_entry, f1_ret, f2_proc ] + +where f1_ret is a return point, and f2_proc is a proc-point. We have +a CAFSet for each of these CmmDecls, let's suppose they are + + [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ] + [ g_entry{h_closure, c1_closure} ] + [ h_entry{c2_closure} ] + +Now, note that we cannot use g_closure and h_closure in an SRT, +because there are no static closures corresponding to these functions. +So we have to flatten out the structure, replacing g_closure and +h_closure with their contents: + + [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ] + [ g_entry{c2_closure, c1_closure} ] + [ h_entry{c2_closure} ] + +This is what flattenCAFSets is doing. + +-} + +----------------------------------------------------------------------- +-- Finding the CAFs used by a procedure + +type CAFSet = Set CLabel +type CAFEnv = BlockEnv CAFSet + +-- First, an analysis to find live CAFs. +cafLattice :: DataflowLattice CAFSet +cafLattice = DataflowLattice "live cafs" Set.empty add + where add _ (OldFact old) (NewFact new) = case old `Set.union` new of + new' -> (changeIf $ Set.size new' > Set.size old, new') + +cafTransfers :: BwdTransfer CmmNode CAFSet +cafTransfers = mkBTransfer3 first middle last + where first _ live = live + middle m live = foldExpDeep addCaf m live + last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live) + addCaf e set = case e of + CmmLit (CmmLabel c) -> add c set + CmmLit (CmmLabelOff c _) -> add c set + CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set + _ -> set + add l s = if hasCAF l then Set.insert (toClosureLbl l) s + else s + +cafAnal :: CmmGraph -> CAFEnv +cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers + +----------------------------------------------------------------------- +-- Building the SRTs + +-- Description of the SRT for a given module. +-- Note that this SRT may grow as we greedily add new CAFs to it. +data TopSRT = TopSRT { lbl :: CLabel + , next_elt :: Int -- the next entry in the table + , rev_elts :: [CLabel] + , elt_map :: Map CLabel Int } + -- map: CLabel -> its last entry in the table +instance Outputable TopSRT where + ppr (TopSRT lbl next elts eltmap) = + text "TopSRT:" <+> ppr lbl + <+> ppr next + <+> ppr elts + <+> ppr eltmap + +emptySRT :: MonadUnique m => m TopSRT +emptySRT = + do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u + return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } + +isEmptySRT :: TopSRT -> Bool +isEmptySRT srt = null (rev_elts srt) + +cafMember :: TopSRT -> CLabel -> Bool +cafMember srt lbl = Map.member lbl (elt_map srt) + +cafOffset :: TopSRT -> CLabel -> Maybe Int +cafOffset srt lbl = Map.lookup lbl (elt_map srt) + +addCAF :: CLabel -> TopSRT -> TopSRT +addCAF caf srt = + srt { next_elt = last + 1 + , rev_elts = caf : rev_elts srt + , elt_map = Map.insert caf last (elt_map srt) } + where last = next_elt srt + +srtToData :: TopSRT -> CmmGroup +srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] + where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) + +-- Once we have found the CAFs, we need to do two things: +-- 1. Build a table of all the CAFs used in the procedure. +-- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint. +-- +-- When building the local view of the SRT, we first make sure that all the CAFs are +-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, +-- we make sure they're all close enough to the bottom of the table that the +-- bitmap will be able to cover all of them. +buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) +buildSRT dflags topSRT cafs = + do let + -- For each label referring to a function f without a static closure, + -- replace it with the CAFs that are reachable from f. + sub_srt topSRT localCafs = + let cafs = Set.elems localCafs + mkSRT topSRT = + do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs + return (topSRT, localSRTs) + in if length cafs > maxBmpSize dflags then + mkSRT (foldl add_if_missing topSRT cafs) + else -- make sure all the cafs are near the bottom of the srt + mkSRT (add_if_too_far topSRT cafs) + add_if_missing srt caf = + if cafMember srt caf then srt else addCAF caf srt + -- If a CAF is more than maxBmpSize entries from the young end of the + -- SRT, then we add it to the SRT again. + -- (Note: Not in the SRT => infinitely far.) + add_if_too_far srt@(TopSRT {elt_map = m}) cafs = + add srt (sortBy farthestFst cafs) + where + farthestFst x y = case (Map.lookup x m, Map.lookup y m) of + (Nothing, Nothing) -> EQ + (Nothing, Just _) -> LT + (Just _, Nothing) -> GT + (Just d, Just d') -> compare d' d + add srt [] = srt + add srt@(TopSRT {next_elt = next}) (caf : rst) = + case cafOffset srt caf of + Just ix -> if next - ix > maxBmpSize dflags then + add (addCAF caf srt) rst + else srt + Nothing -> add (addCAF caf srt) rst + (topSRT, subSRTs) <- sub_srt topSRT cafs + let (sub_tbls, blockSRTs) = subSRTs + return (topSRT, sub_tbls, blockSRTs) + +-- Construct an SRT bitmap. +-- Adapted from simpleStg/SRT.lhs, which expects Id's. +procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] -> + UniqSM (Maybe CmmDecl, C_SRT) +procpointSRT _ _ _ [] = + return (Nothing, NoC_SRT) +procpointSRT dflags top_srt top_table entries = + do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap + return (top, srt) + where + ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries + sorted_ints = sort ints + offset = head sorted_ints + bitmap_entries = map (subtract offset) sorted_ints + len = P.last bitmap_entries + 1 + bitmap = intsToBitmap dflags len bitmap_entries + +maxBmpSize :: DynFlags -> Int +maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2 + +-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. +to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) +to_SRT dflags top_srt off len bmp + | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))] + = do id <- getUniqueM + let srt_desc_lbl = mkLargeSRTLabel id + tbl = CmmData RelocatableReadOnlyData $ + Statics srt_desc_lbl $ map CmmStaticLit + ( cmmLabelOffW dflags top_srt off + : mkWordCLit dflags (fromIntegral len) + : map (mkStgWordCLit dflags) bmp) + return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) + | otherwise + = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) + -- The fromIntegral converts to StgHalfWord + +-- Gather CAF info for a procedure, but only if the procedure +-- doesn't have a static closure. +-- (If it has a static closure, it will already have an SRT to +-- keep its CAFs live.) +-- Any procedure referring to a non-static CAF c must keep live +-- any CAF that is reachable from c. +localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) +localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) +localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) = + case topInfoTable proc of + Just (CmmInfoTable { cit_rep = rep }) + | not (isStaticRep rep) && not (isStackRep rep) + -> (cafs, Just (toClosureLbl top_l)) + _other -> (cafs, Nothing) + where + cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv + +-- Once we have the local CAF sets for some (possibly) mutually +-- recursive functions, we can create an environment mapping +-- each function to its set of CAFs. Note that a CAF may +-- be a reference to a function. If that function f does not have +-- a static closure, then we need to refer specifically +-- to the set of CAFs used by f. Of course, the set of CAFs +-- used by f must be included in the local CAF sets that are input to +-- this function. To minimize lookup time later, we return +-- the environment with every reference to f replaced by its set of CAFs. +-- To do this replacement efficiently, we gather strongly connected +-- components, then we sort the components in topological order. +mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet +mkTopCAFInfo localCAFs = foldl addToTop Map.empty g + where + addToTop env (AcyclicSCC (l, cafset)) = + Map.insert l (flatten env cafset) env + addToTop env (CyclicSCC nodes) = + let (lbls, cafsets) = unzip nodes + cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls + in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls + + g = stronglyConnCompFromEdgedVertices + [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ] + +flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet +flatten env cafset = foldSet (lookup env) Set.empty cafset + where + lookup env caf cafset' = + case Map.lookup caf env of + Just cafs -> foldSet Set.insert cafset' cafs + Nothing -> Set.insert caf cafset' + +bundle :: Map CLabel CAFSet + -> (CAFEnv, CmmDecl) + -> (CAFSet, Maybe CLabel) + -> (BlockEnv CAFSet, CmmDecl) +bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl) + = ( mapMapWithKey get_cafs (info_tbls infos), decl ) + where + entry = g_entry g + + entry_cafs + | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap + | otherwise = flatten flatmap closure_cafs + + get_cafs l _ + | l == entry = entry_cafs + | Just info <- mapLookup l env = flatten flatmap info + | otherwise = Set.empty + -- the label might not be in the env if the code corresponding to + -- this info table was optimised away (perhaps because it was + -- unreachable). In this case it doesn't matter what SRT we + -- infer, since the info table will not appear in the generated + -- code. See #9329. + +bundle _flatmap (_, decl) _ + = ( mapEmpty, decl ) + + +flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)] +flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs + where + zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ] + localCAFs = unzipWith localCAFInfo zipped + flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs + +doSRTs :: DynFlags + -> TopSRT + -> [(CAFEnv, [CmmDecl])] + -> IO (TopSRT, [CmmDecl]) + +doSRTs dflags topSRT tops + = do + let caf_decls = flattenCAFSets tops + us <- mkSplitUniqSupply 'u' + let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls + return (topSRT', reverse gs' {- Note [reverse gs] -}) + where + setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do + (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map + let decl' = updInfoSRTs srt_env decl + return (topSRT, decl': srt_tables ++ rst) + setSRT (topSRT, rst) (_, decl) = + return (topSRT, decl : rst) + +buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet + -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT) +buildSRTs dflags top_srt caf_map + = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map) + where + doOne (top_srt, decls, srt_env) (l, cafs) + = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs + return ( top_srt, maybeToList mb_decl ++ decls + , mapInsert l srt srt_env ) + +{- +- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable +- The one corresponding to g_entry is the closure info table, the + rest are continuations. +- Each one needs an SRT. +- We get the CAFSet for each one from the CAFEnv +- flatten gives us + [(BlockEnv CAFSet, CmmDecl)] +- +-} + + +{- Note [reverse gs] + + It is important to keep the code blocks in the same order, + otherwise binary sizes get slightly bigger. I'm not completely + sure why this is, perhaps the assembler generates bigger jump + instructions for forward refs. --SDM +-} + +updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl +updInfoSRTs srt_env (CmmProc top_info top_l live g) = + CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g + where updInfoTbl l info_tbl + = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } +updInfoSRTs _ t = t diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs new file mode 100644 index 00000000..440ee563 --- /dev/null +++ b/compiler/cmm/CmmCallConv.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} + +module CmmCallConv ( + ParamLocation(..), + assignArgumentsPos, + assignStack, + realArgRegsCover +) where + +#include "HsVersions.h" + +import CmmExpr +import SMRep +import Cmm (Convention(..)) +import PprCmm () + +import DynFlags +import Platform +import Outputable + +-- Calculate the 'GlobalReg' or stack locations for function call +-- parameters as used by the Cmm calling convention. + +data ParamLocation + = RegisterParam GlobalReg + | StackParam ByteOff + +instance Outputable ParamLocation where + ppr (RegisterParam g) = ppr g + ppr (StackParam p) = ppr p + +-- | +-- Given a list of arguments, and a function that tells their types, +-- return a list showing where each argument is passed +-- +assignArgumentsPos :: DynFlags + -> ByteOff -- stack offset to start with + -> Convention + -> (a -> CmmType) -- how to get a type from an arg + -> [a] -- args + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) + +assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) + where + regs = case (reps, conv) of + (_, NativeNodeCall) -> getRegsWithNode dflags + (_, NativeDirectCall) -> getRegsWithoutNode dflags + ([_], NativeReturn) -> allRegs dflags + (_, NativeReturn) -> getRegsWithNode dflags + -- GC calling convention *must* put values in registers + (_, GC) -> allRegs dflags + (_, Slow) -> nodeOnly + -- The calling conventions first assign arguments to registers, + -- then switch to the stack when we first run out of registers + -- (even if there are still available registers for args of a + -- different type). When returning an unboxed tuple, we also + -- separate the stack arguments by pointerhood. + (reg_assts, stk_args) = assign_regs [] reps regs + (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args + assignments = reg_assts ++ stk_assts + + assign_regs assts [] _ = (assts, []) + assign_regs assts (r:rs) regs | isVecType ty = vec + | isFloatType ty = float + | otherwise = int + where vec = case (w, regs) of + (W128, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) + (W256, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) + (W512, (vs, fs, ds, ls, s:ss)) + | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) + _ -> (assts, (r:rs)) + float = case (w, regs) of + (W32, (vs, fs, ds, ls, s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) + (W32, (vs, f:fs, ds, ls, ss)) + | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) + (W64, (vs, fs, ds, ls, s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) + (W64, (vs, fs, d:ds, ls, ss)) + | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + (W80, _) -> panic "F80 unsupported register type" + _ -> (assts, (r:rs)) + int = case (w, regs) of + (W128, _) -> panic "W128 unsupported register type" + (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags) + -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) + (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) + -> k (RegisterParam l, (vs, fs, ds, ls, ss)) + _ -> (assts, (r:rs)) + k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' + ty = arg_ty r + w = typeWidth ty + gcp | isGcPtrType ty = VGcPtr + | otherwise = VNonGcPtr + passFloatInXmm = passFloatArgsInXmm dflags + +passFloatArgsInXmm :: DynFlags -> Bool +passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + _ -> False + +-- On X86_64, we always pass 128-bit-wide vectors in registers. On 32-bit X86 +-- and for all larger vector sizes on X86_64, LLVM's GHC calling convention +-- does not currently pass vectors in registers. The patch to update the GHC +-- calling convention to support passing SIMD vectors in registers is small and +-- well-contained, so it may make it into LLVM 3.4. The hidden +-- -fllvm-pass-vectors-in-regs flag will generate LLVM code that attempts to +-- pass vectors in registers, but it must only be used with a version of LLVM +-- that has an updated GHC calling convention. +passVectorInReg :: Width -> DynFlags -> Bool +passVectorInReg W128 dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + _ -> gopt Opt_LlvmPassVectorsInRegisters dflags +passVectorInReg _ dflags = gopt Opt_LlvmPassVectorsInRegisters dflags + +assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) +assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) + where + assign_stk offset assts [] = (offset, assts) + assign_stk offset assts (r:rs) + = assign_stk off' ((r, StackParam off') : assts) rs + where w = typeWidth (arg_ty r) + size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size + off' = offset + size + word_size = wORD_SIZE dflags + +----------------------------------------------------------------------------- +-- Local information about the registers available + +type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. + , [GlobalReg] -- floats + , [GlobalReg] -- doubles + , [GlobalReg] -- longs (int64 and word64) + , [Int] -- XMM (floats and doubles) + ) + +-- Vanilla registers can contain pointers, Ints, Chars. +-- Floats and doubles have separate register supplies. +-- +-- We take these register supplies from the *real* registers, i.e. those +-- that are guaranteed to map to machine registers. + +getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs +getRegsWithoutNode dflags = + ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags + , realXmmRegNos dflags) + +-- getRegsWithNode uses R1/node even if it isn't a register +getRegsWithNode dflags = + ( if null (realVanillaRegs dflags) + then [VanillaReg 1] + else realVanillaRegs dflags + , realFloatRegs dflags + , realDoubleRegs dflags + , realLongRegs dflags + , realXmmRegNos dflags) + +allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] +allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +allXmmRegs :: DynFlags -> [Int] + +allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) +allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) +allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) +allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) +allXmmRegs dflags = regList (mAX_XMM_REG dflags) + +realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] +realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +realXmmRegNos :: DynFlags -> [Int] + +realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) +realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) +realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) +realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) + +realXmmRegNos dflags + | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags) + | otherwise = [] + +regList :: Int -> [Int] +regList n = [1 .. n] + +allRegs :: DynFlags -> AvailRegs +allRegs dflags = (allVanillaRegs dflags, + allFloatRegs dflags, + allDoubleRegs dflags, + allLongRegs dflags, + allXmmRegs dflags) + +nodeOnly :: AvailRegs +nodeOnly = ([VanillaReg 1], [], [], [], []) + +-- This returns the set of global registers that *cover* the machine registers +-- used for argument passing. On platforms where registers can overlap---right +-- now just x86-64, where Float and Double registers overlap---passing this set +-- of registers is guaranteed to preserve the contents of all live registers. We +-- only use this functionality in hand-written C-- code in the RTS. +realArgRegsCover :: DynFlags -> [GlobalReg] +realArgRegsCover dflags + | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ + realLongRegs dflags ++ + map XmmReg (realXmmRegNos dflags) + | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags ++ + map XmmReg (realXmmRegNos dflags) diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs new file mode 100644 index 00000000..cf057545 --- /dev/null +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE GADTs, BangPatterns #-} +module CmmCommonBlockElim + ( elimCommonBlocks + ) +where + + +import BlockId +import Cmm +import CmmUtils +import CmmContFlowOpt +-- import PprCmm () +import Prelude hiding (iterate, succ, unzip, zip) + +import Hoopl hiding (ChangeFlag) +import Data.Bits +import Data.Maybe (mapMaybe) +import qualified Data.List as List +import Data.Word +import qualified Data.Map as M +import Outputable +import UniqFM +import Unique +import Control.Arrow (first, second) + +-- ----------------------------------------------------------------------------- +-- Eliminate common blocks + +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. + +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. + +-- To avoid comparing every block with every other block repeatedly, we group +-- them by +-- * a hash of the block, ignoring labels (explained below) +-- * the list of outgoing labels +-- The hash is invariant under relabeling, so we only ever compare within +-- the same group of blocks. +-- +-- The list of outgoing labels is updated as we merge blocks (that is why they +-- are not included in the hash, which we want to calculate only once). +-- +-- All in all, two blocks should never be compared if they have different +-- hashes, and at most once otherwise. Previously, we were slower, and people +-- rightfully complained: #10397 + +-- TODO: Use optimization fuel +elimCommonBlocks :: CmmGraph -> CmmGraph +elimCommonBlocks g = replaceLabels env $ copyTicks env g + where + env = iterate mapEmpty blocks_with_key + groups = groupByInt hash_block (postorderDfs g) + blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] + +-- Invariant: The blocks in the list are pairwise distinct +-- (so avoid comparing them again) +type DistinctBlocks = [CmmBlock] +type Key = [Label] +type Subst = BlockEnv BlockId + +-- The outer list groups by hash. We retain this grouping throughout. +iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst +iterate subst blocks + | mapNull new_substs = subst + | otherwise = iterate subst' updated_blocks + where + grouped_blocks :: [[(Key, [DistinctBlocks])]] + grouped_blocks = map groupByLabel blocks + + merged_blocks :: [[(Key, DistinctBlocks)]] + (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks + where + go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db)) + where + (new_subst2, db) = mergeBlockList subst dbs + + subst' = subst `mapUnion` new_substs + updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks + +mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks) +mergeBlocks subst existing new = go new + where + go [] = (mapEmpty, existing) + go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of + -- This block is a duplicate. Drop it, and add it to the substitution + Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs + -- This block is not a duplicate, keep it. + Nothing -> second (b:) $ go bs + +mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks) +mergeBlockList _ [] = pprPanic "mergeBlockList" empty +mergeBlockList subst (b:bs) = go mapEmpty b bs + where + go !new_subst1 b [] = (new_subst1, b) + go !new_subst1 b1 (b2:bs) = go new_subst b bs + where + (new_subst2, b) = mergeBlocks subst b1 b2 + new_subst = new_subst1 `mapUnion` new_subst2 + + +-- ----------------------------------------------------------------------------- +-- Hashing and equality on blocks + +-- Below here is mostly boilerplate: hashing blocks ignoring labels, +-- and comparing blocks modulo a label mapping. + +-- To speed up comparisons, we hash each basic block modulo jump labels. +-- The hashing is a bit arbitrary (the numbers are completely arbitrary), +-- but it should be fast and good enough. + +-- We want to get as many small buckets as possible, as comparing blocks is +-- expensive. So include as much as possible in the hash. Ideally everything +-- that is compared with (==) in eqBlockBodyWith. + +type HashCode = Int + +hash_block :: CmmBlock -> HashCode +hash_block block = + fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) + -- UniqFM doesn't like negative Ints + where hash_fst _ h = h + hash_mid m h = hash_node m + h `shiftL` 1 + hash_lst m h = hash_node m + h `shiftL` 1 + + hash_node :: CmmNode O x -> Word32 + hash_node n | dont_care n = 0 -- don't care + hash_node (CmmUnwind _ e) = hash_e e + hash_node (CmmAssign r e) = hash_reg r + hash_e e + hash_node (CmmStore e e') = hash_e e + hash_e e' + hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as + hash_node (CmmBranch _) = 23 -- NB. ignore the label + hash_node (CmmCondBranch p _ _) = hash_e p + hash_node (CmmCall e _ _ _ _ _) = hash_e e + hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t + hash_node (CmmSwitch e _) = hash_e e + hash_node _ = error "hash_node: unknown Cmm node!" + + hash_reg :: CmmReg -> Word32 + hash_reg (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397 + hash_reg (CmmGlobal _) = 19 + + hash_e :: CmmExpr -> Word32 + hash_e (CmmLit l) = hash_lit l + hash_e (CmmLoad e _) = 67 + hash_e e + hash_e (CmmReg r) = hash_reg r + hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check + hash_e (CmmRegOff r i) = hash_reg r + cvt i + hash_e (CmmStackSlot _ _) = 13 + + hash_lit :: CmmLit -> Word32 + hash_lit (CmmInt i _) = fromInteger i + hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmVec ls) = hash_list hash_lit ls + hash_lit (CmmLabel _) = 119 -- ugh + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i + hash_lit (CmmBlock _) = 191 -- ugh + hash_lit (CmmHighStackMark) = cvt 313 + + hash_tgt (ForeignTarget e _) = hash_e e + hash_tgt (PrimTarget _) = 31 -- lots of these + + hash_list f = foldl (\z x -> f x + z) (0::Word32) + + cvt = fromInteger . toInteger + + hash_unique :: Uniquable a => a -> Word32 + hash_unique = cvt . getKey . getUnique + +-- | Ignore these node types for equality +dont_care :: CmmNode O x -> Bool +dont_care CmmComment {} = True +dont_care CmmTick {} = True +dont_care _other = False + +-- Utilities: equality and substitution on the graph. + +-- Given a map ``subst'' from BlockID -> BlockID, we define equality. +eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool +eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' +lookupBid :: BlockEnv BlockId -> BlockId -> BlockId +lookupBid subst bid = case mapLookup bid subst of + Just bid -> lookupBid subst bid + Nothing -> bid + +-- Middle nodes and expressions can contain BlockIds, in particular in +-- CmmStackSlot and CmmBlock, so we have to use a special equality for +-- these. +-- +eqMiddleWith :: (BlockId -> BlockId -> Bool) + -> CmmNode O O -> CmmNode O O -> Bool +eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) + = r1 == r2 && eqExprWith eqBid e1 e2 +eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2) + = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 +eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) + (CmmUnsafeForeignCall t2 r2 a2) + = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2) +eqMiddleWith _ _ _ = False + +eqExprWith :: (BlockId -> BlockId -> Bool) + -> CmmExpr -> CmmExpr -> Bool +eqExprWith eqBid = eq + where + CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2 + CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2 + CmmReg r1 `eq` CmmReg r2 = r1==r2 + CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 + CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 + _e1 `eq` _e2 = False + + xs `eqs` ys = and (zipWith eq xs ys) + + eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 + eqLit l1 l2 = l1 == l2 + + eqArea Old Old = True + eqArea (Young id1) (Young id2) = eqBid id1 id2 + eqArea _ _ = False + +-- Equality on the body of a block, modulo a function mapping block +-- IDs to block IDs. +eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool +eqBlockBodyWith eqBid block block' + {- + | equal = pprTrace "equal" (vcat [ppr block, ppr block']) True + | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False + -} + = equal + where (_,m,l) = blockSplit block + nodes = filter (not . dont_care) (blockToList m) + (_,m',l') = blockSplit block' + nodes' = filter (not . dont_care) (blockToList m') + + equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') && + eqLastWith eqBid l l' + + +eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool +eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) = + c1 == c2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 +eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) = + e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2 +eqLastWith _ _ _ = False + +eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool +eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es') + +eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool +eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' +eqMaybeWith _ Nothing Nothing = True +eqMaybeWith _ _ _ = False + +-- | Given a block map, ensure that all "target" blocks are covered by +-- the same ticks as the respective "source" blocks. This not only +-- means copying ticks, but also adjusting tick scopes where +-- necessary. +copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph +copyTicks env g + | mapNull env = g + | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap + where -- Reverse block merge map + blockMap = toBlockMap g + revEnv = mapFoldWithKey insertRev M.empty env + insertRev k x = M.insertWith (const (k:)) x [k] + -- Copy ticks and scopes into the given block + copyTo block = case M.lookup (entryLabel block) revEnv of + Nothing -> block + Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls + copy from to = + let ticks = blockTicks from + CmmEntry _ scp0 = firstNode from + (CmmEntry lbl scp1, code) = blockSplitHead to + in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead` + foldr blockCons code (map CmmTick ticks) + +-- Group by [Label] +groupByLabel :: [(Key, a)] -> [(Key, [a])] +groupByLabel = go M.empty + where + go !m [] = M.elems m + go !m ((k,v) : entries) = go (M.alter adjust k' m) entries + where k' = map getUnique k + adjust Nothing = Just (k,[v]) + adjust (Just (_,vs)) = Just (k,v:vs) + + +groupByInt :: (a -> Int) -> [a] -> [[a]] +groupByInt f xs = eltsUFM $ List.foldl' go emptyUFM xs + where go m x = alterUFM (Just . maybe [x] (x:)) m (f x) diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs new file mode 100644 index 00000000..bcb4cf97 --- /dev/null +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +module CmmContFlowOpt + ( cmmCfgOpts + , cmmCfgOptsProc + , removeUnreachableBlocksProc + , replaceLabels + ) +where + +import Hoopl +import BlockId +import Cmm +import CmmUtils +import Maybes +import Panic + +import Control.Monad +import Prelude hiding (succ, unzip, zip) + + +-- Note [What is shortcutting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider this Cmm code: +-- +-- L1: ... +-- goto L2; +-- L2: goto L3; +-- L3: ... +-- +-- Here L2 is an empty block and contains only an unconditional branch +-- to L3. In this situation any block that jumps to L2 can jump +-- directly to L3: +-- +-- L1: ... +-- goto L3; +-- L2: goto L3; +-- L3: ... +-- +-- In this situation we say that we shortcut L2 to L3. One of +-- consequences of shortcutting is that some blocks of code may become +-- unreachable (in the example above this is true for L2). + + +-- Note [Control-flow optimisations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This optimisation does three things: +-- +-- - If a block finishes in an unconditonal branch to another block +-- and that is the only jump to that block we concatenate the +-- destination block at the end of the current one. +-- +-- - If a block finishes in a call whose continuation block is a +-- goto, then we can shortcut the destination, making the +-- continuation block the destination of the goto - but see Note +-- [Shortcut call returns]. +-- +-- - For any block that is not a call we try to shortcut the +-- destination(s). Additionally, if a block ends with a +-- conditional branch we try to invert the condition. +-- +-- Blocks are processed using postorder DFS traversal. A side effect +-- of determining traversal order with a graph search is elimination +-- of any blocks that are unreachable. +-- +-- Transformations are improved by working from the end of the graph +-- towards the beginning, because we may be able to perform many +-- shortcuts in one go. + + +-- Note [Shortcut call returns] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We are going to maintain the "current" graph (BlockEnv CmmBlock) as +-- we go, and also a mapping from BlockId to BlockId, representing +-- continuation labels that we have renamed. This latter mapping is +-- important because we might shortcut a CmmCall continuation. For +-- example: +-- +-- Sp[0] = L +-- call g returns to L +-- L: goto M +-- M: ... +-- +-- So when we shortcut the L block, we need to replace not only +-- the continuation of the call, but also references to L in the +-- code (e.g. the assignment Sp[0] = L): +-- +-- Sp[0] = M +-- call g returns to M +-- M: ... +-- +-- So we keep track of which labels we have renamed and apply the mapping +-- at the end with replaceLabels. + + +-- Note [Shortcut call returns and proc-points] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider this code that you might get from a recursive +-- let-no-escape: +-- +-- goto L1 +-- L1: +-- if (Hp > HpLim) then L2 else L3 +-- L2: +-- call stg_gc_noregs returns to L4 +-- L4: +-- goto L1 +-- L3: +-- ... +-- goto L1 +-- +-- Then the control-flow optimiser shortcuts L4. But that turns L1 +-- into the call-return proc point, and every iteration of the loop +-- has to shuffle variables to and from the stack. So we must *not* +-- shortcut L4. +-- +-- Moreover not shortcutting call returns is probably fine. If L4 can +-- concat with its branch target then it will still do so. And we +-- save some compile time because we don't have to traverse all the +-- code in replaceLabels. +-- +-- However, we probably do want to do this if we are splitting proc +-- points, because L1 will be a proc-point anyway, so merging it with +-- L4 reduces the number of proc points. Unfortunately recursive +-- let-no-escapes won't generate very good code with proc-point +-- splitting on - we should probably compile them to explicitly use +-- the native calling convention instead. + +cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph +cmmCfgOpts split g = fst (blockConcat split g) + +cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' + where (g', env) = blockConcat split g + info' = info{ info_tbls = new_info_tbls } + new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) + + -- If we changed any labels, then we have to update the info tables + -- too, except for the top-level info table because that might be + -- referred to by other procs. + upd_info (k,info) + | Just k' <- mapLookup k env + = (k', if k' == g_entry g' + then info + else info{ cit_lbl = infoTblLbl k' }) + | otherwise + = (k,info) +cmmCfgOptsProc _ top = top + + +blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId) +blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } + = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') + where + -- We might be able to shortcut the entry BlockId itself. + -- Remember to update the shortcut_map, since we also have to + -- update the info_tbls mapping now. + (new_entry, shortcut_map') + | Just entry_blk <- mapLookup entry_id new_blocks + , Just dest <- canShortcut entry_blk + = (dest, mapInsert entry_id dest shortcut_map) + | otherwise + = (entry_id, shortcut_map) + + -- blocks is a list of blocks in DFS postorder, while blockmap is + -- a map of blocks. We process each element from blocks and update + -- blockmap accordingly + blocks = postorderDfs g + blockmap = foldr addBlock emptyBody blocks + + -- Accumulator contains three components: + -- * map of blocks in a graph + -- * map of shortcut labels. See Note [Shortcut call returns] + -- * map containing number of predecessors for each block. We discard + -- it after we process all blocks. + (new_blocks, shortcut_map, _) = + foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks + + -- Map of predecessors for initial graph. We increase number of + -- predecessors for entry block by one to denote that it is + -- target of a jump, even if no block in the current graph jumps + -- to it. + initialBackEdges = incPreds entry_id (predMap blocks) + + maybe_concat :: CmmBlock + -> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int) + -> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int) + maybe_concat block (blocks, shortcut_map, backEdges) + -- If: + -- (1) current block ends with unconditional branch to b' and + -- (2) it has exactly one predecessor (namely, current block) + -- + -- Then: + -- (1) append b' block at the end of current block + -- (2) remove b' from the map of blocks + -- (3) remove information about b' from predecessors map + -- + -- Since we know that the block has only one predecessor we call + -- mapDelete directly instead of calling decPreds. + -- + -- Note that we always maintain an up-to-date list of predecessors, so + -- we can ignore the contents of shortcut_map + | CmmBranch b' <- last + , hasOnePredecessor b' + , Just blk' <- mapLookup b' blocks + = let bid' = entryLabel blk' + in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks + , shortcut_map + , mapDelete b' backEdges ) + + -- If: + -- (1) we are splitting proc points (see Note + -- [Shortcut call returns and proc-points]) and + -- (2) current block is a CmmCall or CmmForeignCall with + -- continuation b' and + -- (3) we can shortcut that continuation to dest + -- Then: + -- (1) we change continuation to point to b' + -- (2) create mapping from b' to dest + -- (3) increase number of predecessors of dest by 1 + -- (4) decrease number of predecessors of b' by 1 + -- + -- Later we will use replaceLabels to substitute all occurrences of b' + -- with dest. + | splitting_procs + , Just b' <- callContinuation_maybe last + , Just blk' <- mapLookup b' blocks + , Just dest <- canShortcut blk' + = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks + , mapInsert b' dest shortcut_map + , decPreds b' $ incPreds dest backEdges ) + + -- If: + -- (1) a block does not end with a call + -- Then: + -- (1) if it ends with a conditional attempt to invert the + -- conditional + -- (2) attempt to shortcut all destination blocks + -- (3) if new successors of a block are different from the old ones + -- update the of predecessors accordingly + -- + -- A special case of this is a situation when a block ends with an + -- unconditional jump to a block that can be shortcut. + | Nothing <- callContinuation_maybe last + = let oldSuccs = successors last + newSuccs = successors swapcond_last + in ( mapInsert bid (blockJoinTail head swapcond_last) blocks + , shortcut_map + , if oldSuccs == newSuccs + then backEdges + else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs ) + + -- Otherwise don't do anything + | otherwise + = ( blocks, shortcut_map, backEdges ) + where + (head, last) = blockSplitTail block + bid = entryLabel block + + -- Changes continuation of a call to a specified label + update_cont dest = + case last of + CmmCall{} -> last { cml_cont = Just dest } + CmmForeignCall{} -> last { succ = dest } + _ -> panic "Can't shortcut continuation." + + -- Attempts to shortcut successors of last node + shortcut_last = mapSuccessors shortcut last + where + shortcut l = + case mapLookup l blocks of + Just b | Just dest <- canShortcut b -> dest + _otherwise -> l + + -- For a conditional, we invert the conditional if that would make it + -- more likely that the branch-not-taken case becomes a fallthrough. + -- This helps the native codegen a little bit, and probably has no + -- effect on LLVM. It's convenient to do it here, where we have the + -- information about predecessors. + swapcond_last + | CmmCondBranch cond t f <- shortcut_last + , numPreds f > 1 + , hasOnePredecessor t + , Just cond' <- maybeInvertCmmExpr cond + = CmmCondBranch cond' f t + + | otherwise + = shortcut_last + + -- Number of predecessors for a block + numPreds bid = mapLookup bid backEdges `orElse` 0 + + hasOnePredecessor b = numPreds b == 1 + +-- Functions for incrementing and decrementing number of predecessors. If +-- decrementing would set the predecessor count to 0, we remove entry from the +-- map. +-- Invariant: if a block has no predecessors it should be dropped from the +-- graph because it is unreachable. maybe_concat is constructed to maintain +-- that invariant, but calling replaceLabels may introduce unreachable blocks. +-- We rely on subsequent passes in the Cmm pipeline to remove unreachable +-- blocks. +incPreds, decPreds :: BlockId -> BlockEnv Int -> BlockEnv Int +incPreds bid edges = mapInsertWith (+) bid 1 edges +decPreds bid edges = case mapLookup bid edges of + Just preds | preds > 1 -> mapInsert bid (preds - 1) edges + Just _ -> mapDelete bid edges + _ -> edges + + +-- Checks if a block consists only of "goto dest". If it does than we return +-- "Just dest" label. See Note [What is shortcutting] +canShortcut :: CmmBlock -> Maybe BlockId +canShortcut block + | (_, middle, CmmBranch dest) <- blockSplit block + , all dont_care $ blockToList middle + = Just dest + | otherwise + = Nothing + where dont_care CmmComment{} = True + dont_care CmmTick{} = True + dont_care _other = False + +-- Concatenates two blocks. First one is assumed to be open on exit, the second +-- is assumed to be closed on entry (i.e. it has a label attached to it, which +-- the splice function removes by calling snd on result of blockSplitHead). +splice :: Block CmmNode C O -> CmmBlock -> CmmBlock +splice head rest = entry `blockJoinHead` code0 `blockAppend` code1 + where (CmmEntry lbl sc0, code0) = blockSplitHead head + (CmmEntry _ sc1, code1) = blockSplitHead rest + entry = CmmEntry lbl (combineTickScopes sc0 sc1) + +-- If node is a call with continuation call return Just label of that +-- continuation. Otherwise return Nothing. +callContinuation_maybe :: CmmNode O C -> Maybe BlockId +callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b +callContinuation_maybe (CmmForeignCall { succ = b }) = Just b +callContinuation_maybe _ = Nothing + + +-- Map over the CmmGraph, replacing each label with its mapping in the +-- supplied BlockEnv. +replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph +replaceLabels env g + | mapNull env = g + | otherwise = replace_eid $ mapGraphNodes1 txnode g + where + replace_eid g = g {g_entry = lookup (g_entry g)} + lookup id = mapLookup id env `orElse` id + + txnode :: CmmNode e x -> CmmNode e x + txnode (CmmBranch bid) = CmmBranch (lookup bid) + txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f) + txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms) + txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r + txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc) + , succ = lookup (succ fc) } + txnode other = mapExpDeep exp other + + exp :: CmmExpr -> CmmExpr + exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) + exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i + exp e = e + +mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C +mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f + +-- Build a map from a block to its set of predecessors. +predMap :: [CmmBlock] -> BlockEnv Int +predMap blocks = foldr add_preds mapEmpty blocks + where + add_preds block env = foldr add env (successors block) + where add lbl env = mapInsertWith (+) lbl 1 env + +-- Removing unreachable blocks +removeUnreachableBlocksProc :: CmmDecl -> CmmDecl +removeUnreachableBlocksProc proc@(CmmProc info lbl live g) + | length used_blocks < mapSize (toBlockMap g) + = CmmProc info' lbl live g' + | otherwise + = proc + where + g' = ofBlockList (g_entry g) used_blocks + info' = info { info_tbls = keep_used (info_tbls info) } + -- Remove any info_tbls for unreachable + + keep_used :: BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable + keep_used bs = mapFoldWithKey keep emptyBlockMap bs + + keep :: Label -> CmmInfoTable -> BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable + keep l i env | l `setMember` used_lbls = mapInsert l i env + | otherwise = env + + used_blocks :: [CmmBlock] + used_blocks = postorderDfs g + + used_lbls :: LabelSet + used_lbls = foldr (setInsert . entryLabel) setEmpty used_blocks diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs new file mode 100644 index 00000000..3d21ebce --- /dev/null +++ b/compiler/cmm/CmmExpr.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module CmmExpr + ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr + , CmmReg(..), cmmRegType + , CmmLit(..), cmmLitType + , LocalReg(..), localRegType + , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg + , VGcPtr(..), vgcFlag -- Temporary! + + , DefinerOfRegs, UserOfRegs + , foldRegsDefd, foldRegsUsed, filterRegsUsed + , foldLocalRegsDefd, foldLocalRegsUsed + + , RegSet, LocalRegSet, GlobalRegSet + , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet + , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet + , regSetToList + + , Area(..) + , module CmmMachOp + , module CmmType + ) +where + +#include "HsVersions.h" + +import CmmType +import CmmMachOp +import BlockId +import CLabel +import DynFlags +import Unique +import Outputable (panic) + +import Data.Set (Set) +import qualified Data.Set as Set + +----------------------------------------------------------------------------- +-- CmmExpr +-- An expression. Expressions have no side effects. +----------------------------------------------------------------------------- + +data CmmExpr + = CmmLit CmmLit -- Literal + | CmmLoad !CmmExpr !CmmType -- Read memory location + | CmmReg !CmmReg -- Contents of register + | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) + | CmmStackSlot Area {-# UNPACK #-} !Int + -- addressing expression of a stack slot + -- See Note [CmmStackSlot aliasing] + | CmmRegOff !CmmReg Int + -- CmmRegOff reg i + -- ** is shorthand only, meaning ** + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) + +instance Eq CmmExpr where -- Equality ignores the types + CmmLit l1 == CmmLit l2 = l1==l2 + CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 + CmmReg r1 == CmmReg r2 = r1==r2 + CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 + CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 + CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 + _e1 == _e2 = False + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalReg + deriving( Eq, Ord ) + +-- | A stack area is either the stack slot where a variable is spilled +-- or the stack space where function arguments and results are passed. +data Area + = Old -- See Note [Old Area] + | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockId] in CmmNode. + deriving (Eq, Ord) + +{- Note [Old Area] +~~~~~~~~~~~~~~~~~~ +There is a single call area 'Old', allocated at the extreme old +end of the stack frame (ie just younger than the return address) +which holds: + * incoming (overflow) parameters, + * outgoing (overflow) parameter to tail calls, + * outgoing (overflow) result values + * the update frame (if any) + +Its size is the max of all these requirements. On entry, the stack +pointer will point to the youngest incoming parameter, which is not +necessarily at the young end of the Old area. + +End of note -} + + +{- Note [CmmStackSlot aliasing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When do two CmmStackSlots alias? + + - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M + - T[old+N] aliases with U[old+M] only if the areas actually overlap + +Or more informally, different Areas may overlap with each other. + +An alternative semantics, that we previously had, was that different +Areas do not overlap. The problem that lead to redefining the +semantics of stack areas is described below. + +e.g. if we had + + x = Sp[old + 8] + y = Sp[old + 16] + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = y + Sp[young(L) + 24] = x + call f() returns to L + +if areas semantically do not overlap, then we might optimise this to + + Sp[young(L) + 8] = L + Sp[young(L) + 16] = Sp[old + 8] + Sp[young(L) + 24] = Sp[old + 16] + call f() returns to L + +and now young(L) cannot be allocated at the same place as old, and we +are doomed to use more stack. + + - old+8 conflicts with young(L)+8 + - old+16 conflicts with young(L)+16 and young(L)+8 + +so young(L)+8 == old+24 and we get + + Sp[-8] = L + Sp[-16] = Sp[8] + Sp[-24] = Sp[0] + Sp -= 24 + call f() returns to L + +However, if areas are defined to be "possibly overlapping" in the +semantics, then we cannot commute any loads/stores of old with +young(L), and we will be able to re-use both old+8 and old+16 for +young(L). + + x = Sp[8] + y = Sp[0] + + Sp[8] = L + Sp[0] = y + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L + +Now, the assignments of y go away, + + x = Sp[8] + Sp[8] = L + Sp[-8] = x + Sp = Sp - 8 + call f() returns to L +-} + +data CmmLit + = CmmInt !Integer Width + -- Interpretation: the 2's complement representation of the value + -- is truncated to the specified size. This is easier than trying + -- to keep the value within range, because we don't know whether + -- it will be used as a signed or unsigned value (the CmmType doesn't + -- distinguish between signed & unsigned). + | CmmFloat Rational Width + | CmmVec [CmmLit] -- Vector literal + | CmmLabel CLabel -- Address of label + | CmmLabelOff CLabel Int -- Address of label + byte offset + + -- Due to limitations in the C backend, the following + -- MUST ONLY be used inside the info table indicated by label2 + -- (label2 must be the info label), and label1 must be an + -- SRT, a slow entrypoint or a large bitmap (see the Mangler) + -- Don't use it at all unless tablesNextToCode. + -- It is also used inside the NCG during when generating + -- position-independent code. + | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset + + | CmmBlock {-# UNPACK #-} !BlockId -- Code label + -- Invariant: must be a continuation BlockId + -- See Note [Continuation BlockId] in CmmNode. + + | CmmHighStackMark -- A late-bound constant that stands for the max + -- #bytes of stack space used during a procedure. + -- During the stack-layout pass, CmmHighStackMark + -- is replaced by a CmmInt for the actual number + -- of bytes used + deriving Eq + +cmmExprType :: DynFlags -> CmmExpr -> CmmType +cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit +cmmExprType _ (CmmLoad _ rep) = rep +cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg +cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) +cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg +cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address +-- Careful though: what is stored at the stack slot may be bigger than +-- an address + +cmmLitType :: DynFlags -> CmmLit -> CmmType +cmmLitType _ (CmmInt _ width) = cmmBits width +cmmLitType _ (CmmFloat _ width) = cmmFloat width +cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []" +cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l + in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls) + then cmmVec (1+length ls) ty + else panic "cmmLitType: CmmVec" +cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags +cmmLitType dflags (CmmBlock _) = bWord dflags +cmmLitType dflags (CmmHighStackMark) = bWord dflags + +cmmLabelType :: DynFlags -> CLabel -> CmmType +cmmLabelType dflags lbl + | isGcPtrLabel lbl = gcWord dflags + | otherwise = bWord dflags + +cmmExprWidth :: DynFlags -> CmmExpr -> Width +cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) + +-------- +--- Negation for conditional branches + +maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr +maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op + return (CmmMachOp op' args) +maybeInvertCmmExpr _ = Nothing + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +cmmRegType :: DynFlags -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +----------------------------------------------------------------------------- +-- Register-use information for expressions and other types +----------------------------------------------------------------------------- + +-- | Sets of registers + +-- These are used for dataflow facts, and a common operation is taking +-- the union of two RegSets and then asking whether the union is the +-- same as one of the inputs. UniqSet isn't good here, because +-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary +-- Sets. + +type RegSet r = Set r +type LocalRegSet = RegSet LocalReg +type GlobalRegSet = RegSet GlobalReg + +emptyRegSet :: Ord r => RegSet r +nullRegSet :: Ord r => RegSet r -> Bool +elemRegSet :: Ord r => r -> RegSet r -> Bool +extendRegSet :: Ord r => RegSet r -> r -> RegSet r +deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r +mkRegSet :: Ord r => [r] -> RegSet r +minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r +sizeRegSet :: Ord r => RegSet r -> Int +regSetToList :: Ord r => RegSet r -> [r] + +emptyRegSet = Set.empty +nullRegSet = Set.null +elemRegSet = Set.member +extendRegSet = flip Set.insert +deleteFromRegSet = flip Set.delete +mkRegSet = Set.fromList +minusRegSet = Set.difference +plusRegSet = Set.union +timesRegSet = Set.intersection +sizeRegSet = Set.size +regSetToList = Set.toList + +class Ord r => UserOfRegs r a where + foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsUsed :: UserOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsUsed = foldRegsUsed + +class Ord r => DefinerOfRegs r a where + foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsDefd :: DefinerOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsDefd = foldRegsDefd + +filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r +filterRegsUsed dflags p e = + foldRegsUsed dflags + (\regs r -> if p r then extendRegSet regs r else regs) + emptyRegSet e + +instance UserOfRegs LocalReg CmmReg where + foldRegsUsed _ f z (CmmLocal reg) = f z reg + foldRegsUsed _ _ z (CmmGlobal _) = z + +instance DefinerOfRegs LocalReg CmmReg where + foldRegsDefd _ f z (CmmLocal reg) = f z reg + foldRegsDefd _ _ z (CmmGlobal _) = z + +instance UserOfRegs GlobalReg CmmReg where + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg + +instance DefinerOfRegs GlobalReg CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal reg) = f z reg + +instance Ord r => UserOfRegs r r where + foldRegsUsed _ f z r = f z r + +instance Ord r => DefinerOfRegs r r where + foldRegsDefd _ f z r = f z r + +instance Ord r => UserOfRegs r (RegSet r) where + foldRegsUsed _ f = Set.fold (flip f) + +instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where + foldRegsUsed dflags f z e = expr z e + where expr z (CmmLit _) = z + expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr + expr z (CmmReg r) = foldRegsUsed dflags f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs + expr z (CmmRegOff r _) = foldRegsUsed dflags f z r + expr z (CmmStackSlot _ _) = z + +instance UserOfRegs r a => UserOfRegs r (Maybe a) where + foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x + foldRegsUsed _ _ z Nothing = z + +instance UserOfRegs r a => UserOfRegs r [a] where + foldRegsUsed _ _ set [] = set + foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs + +instance DefinerOfRegs r a => DefinerOfRegs r [a] where + foldRegsDefd _ _ set [] = set + foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs + +instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where + foldRegsDefd _ _ set Nothing = set + foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- + +data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) + -- TEMPORARY!!! + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +vgcFlag :: CmmType -> VGcPtr +vgcFlag ty | isGcPtrType ty = VGcPtr + | otherwise = VNonGcPtr + +{- +Note [Overlapping global registers] + +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register + | CCCS -- Current cost-centre stack + | CurrentTSO -- pointer to current thread's TSO + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun + + -- Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + -- Base Register for PIC (position-independent code) calculations + -- Only used inside the native code generator. It's exact meaning differs + -- from platform to platform (see module PositionIndependentCode). + | PicBaseReg + + deriving( Show ) + +instance Eq GlobalReg where + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + FloatReg i == FloatReg j = i==j + DoubleReg i == DoubleReg j = i==j + LongReg i == LongReg j = i==j + XmmReg i == XmmReg j = i==j + YmmReg i == YmmReg j = i==j + ZmmReg i == ZmmReg j = i==j + Sp == Sp = True + SpLim == SpLim = True + Hp == Hp = True + HpLim == HpLim = True + CCCS == CCCS = True + CurrentTSO == CurrentTSO = True + CurrentNursery == CurrentNursery = True + HpAlloc == HpAlloc = True + EagerBlackholeInfo == EagerBlackholeInfo = True + GCEnter1 == GCEnter1 = True + GCFun == GCFun = True + BaseReg == BaseReg = True + PicBaseReg == PicBaseReg = True + _r1 == _r2 = False + +instance Ord GlobalReg where + compare (VanillaReg i _) (VanillaReg j _) = compare i j + -- Ignore type when seeking clashes + compare (FloatReg i) (FloatReg j) = compare i j + compare (DoubleReg i) (DoubleReg j) = compare i j + compare (LongReg i) (LongReg j) = compare i j + compare (XmmReg i) (XmmReg j) = compare i j + compare (YmmReg i) (YmmReg j) = compare i j + compare (ZmmReg i) (ZmmReg j) = compare i j + compare Sp Sp = EQ + compare SpLim SpLim = EQ + compare Hp Hp = EQ + compare HpLim HpLim = EQ + compare CCCS CCCS = EQ + compare CurrentTSO CurrentTSO = EQ + compare CurrentNursery CurrentNursery = EQ + compare HpAlloc HpAlloc = EQ + compare EagerBlackholeInfo EagerBlackholeInfo = EQ + compare GCEnter1 GCEnter1 = EQ + compare GCFun GCFun = EQ + compare BaseReg BaseReg = EQ + compare PicBaseReg PicBaseReg = EQ + compare (VanillaReg _ _) _ = LT + compare _ (VanillaReg _ _) = GT + compare (FloatReg _) _ = LT + compare _ (FloatReg _) = GT + compare (DoubleReg _) _ = LT + compare _ (DoubleReg _) = GT + compare (LongReg _) _ = LT + compare _ (LongReg _) = GT + compare (XmmReg _) _ = LT + compare _ (XmmReg _) = GT + compare (YmmReg _) _ = LT + compare _ (YmmReg _) = GT + compare (ZmmReg _) _ = LT + compare _ (ZmmReg _) = GT + compare Sp _ = LT + compare _ Sp = GT + compare SpLim _ = LT + compare _ SpLim = GT + compare Hp _ = LT + compare _ Hp = GT + compare HpLim _ = LT + compare _ HpLim = GT + compare CCCS _ = LT + compare _ CCCS = GT + compare CurrentTSO _ = LT + compare _ CurrentTSO = GT + compare CurrentNursery _ = LT + compare _ CurrentNursery = GT + compare HpAlloc _ = LT + compare _ HpAlloc = GT + compare GCEnter1 _ = LT + compare _ GCEnter1 = GT + compare GCFun _ = LT + compare _ GCFun = GT + compare BaseReg _ = LT + compare _ BaseReg = GT + compare EagerBlackholeInfo _ = LT + compare _ EagerBlackholeInfo = GT + +-- convenient aliases +baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg +baseReg = CmmGlobal BaseReg +spReg = CmmGlobal Sp +hpReg = CmmGlobal Hp +spLimReg = CmmGlobal SpLim +nodeReg = CmmGlobal node + +node :: GlobalReg +node = VanillaReg 1 VGcPtr + +globalRegType :: DynFlags -> GlobalReg -> CmmType +globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags +globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags +globalRegType _ (FloatReg _) = cmmFloat W32 +globalRegType _ (DoubleReg _) = cmmFloat W64 +globalRegType _ (LongReg _) = cmmBits W64 +globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) +globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) +globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) + +globalRegType dflags Hp = gcWord dflags + -- The initialiser for all + -- dynamically allocated closures +globalRegType dflags _ = bWord dflags + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs new file mode 100644 index 00000000..ce8b9f8b --- /dev/null +++ b/compiler/cmm/CmmInfo.hs @@ -0,0 +1,553 @@ +{-# LANGUAGE CPP #-} +module CmmInfo ( + mkEmptyContInfoTable, + cmmToRawCmm, + mkInfoTable, + srtEscape, + + -- info table accessors + closureInfoPtr, + entryCode, + getConstrTag, + cmmGetClosureType, + infoTable, + infoTableConstrTag, + infoTableSrtBitmap, + infoTableClosureType, + infoTablePtrs, + infoTableNonPtrs, + funInfoTable, + funInfoArity, + + -- info table sizes and offsets + stdInfoTableSizeW, + fixedInfoTableSizeW, + profInfoTableSizeW, + maxStdInfoTableSizeW, + maxRetInfoTableSizeW, + stdInfoTableSizeB, + stdSrtBitmapOffset, + stdClosureTypeOffset, + stdPtrsOffset, stdNonPtrsOffset, +) where + +#include "HsVersions.h" + +import Cmm +import CmmUtils +import CLabel +import SMRep +import Bitmap +import Stream (Stream) +import qualified Stream +import Hoopl + +import Maybes +import DynFlags +import Panic +import UniqSupply +import MonadUtils +import Util +import Outputable + +import Data.Bits +import Data.Word + +-- When we split at proc points, we need an empty info table. +mkEmptyContInfoTable :: CLabel -> CmmInfoTable +mkEmptyContInfoTable info_lbl + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = mkStackRep [] + , cit_prof = NoProfilingInfo + , cit_srt = NoC_SRT } + +cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () + -> IO (Stream IO RawCmmGroup ()) +cmmToRawCmm dflags cmms + = do { uniqs <- mkSplitUniqSupply 'i' + ; let do_one uniqs cmm = do + case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of + (b,uniqs') -> return (uniqs',b) + -- NB. strictness fixes a space leak. DO NOT REMOVE. + ; return (Stream.mapAccumL do_one uniqs cmms >> return ()) + } + +-- Make a concrete info table, represented as a list of CmmStatic +-- (it can't be simply a list of Word, because the SRT field is +-- represented by a label+offset expression). +-- +-- With tablesNextToCode, the layout is +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See includes/rts/storage/InfoTables.h +-- +-- For return-points these are as follows +-- +-- Tables next to code: +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- * The SRT slot is only there if there is SRT info to record + +mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) + = return [CmmData sec dat] + +mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) + -- + -- in the non-tables-next-to-code case, procs can have at most a + -- single info table associated with the entry label of the proc. + -- + | not (tablesNextToCode dflags) + = case topInfoTable proc of -- must be at most one + -- no info table + Nothing -> + return [CmmProc mapEmpty entry_lbl live blocks] + + Just info@CmmInfoTable { cit_lbl = info_lbl } -> do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents dflags info Nothing + let + rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits + -- + -- Separately emit info table (with the function entry + -- point as first entry) and the entry code + -- + return (top_decls ++ + [CmmProc mapEmpty entry_lbl live blocks, + mkDataLits Data info_lbl + (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) + + -- + -- With tables-next-to-code, we can have many info tables, + -- associated with some of the BlockIds of the proc. For each info + -- table we need to turn it into CmmStatics, and collect any new + -- CmmDecls that arise from doing so. + -- + | otherwise + = do + (top_declss, raw_infos) <- + unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) + return (concat top_declss ++ + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) + + where + do_one_info (lbl,itbl) = do + (top_decls, (std_info, extra_bits)) <- + mkInfoTableContents dflags itbl Nothing + let + info_lbl = cit_lbl itbl + rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info + rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits + -- + return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ + reverse rel_extra_bits ++ rel_std_info)) + +----------------------------------------------------- +type InfoTableContents = ( [CmmLit] -- The standard part + , [CmmLit] ) -- The "extra bits" +-- These Lits have *not* had mkRelativeTo applied to them + +mkInfoTableContents :: DynFlags + -> CmmInfoTable + -> Maybe Int -- Override default RTS type tag? + -> UniqSM ([RawCmmDecl], -- Auxiliary top decls + InfoTableContents) -- Info tbl + extra bits + +mkInfoTableContents dflags + info@(CmmInfoTable { cit_lbl = info_lbl + , cit_rep = smrep + , cit_prof = prof + , cit_srt = srt }) + mb_rts_tag + | RTSRep rts_tag rep <- smrep + = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) + -- Completely override the rts_tag that mkInfoTableContents would + -- otherwise compute, with the rts_tag stored in the RTSRep + -- (which in turn came from a handwritten .cmm file) + + | StackRep frame <- smrep + = do { (prof_lits, prof_data) <- mkProfLits dflags prof + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt + ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame + ; let + std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit + rts_tag | Just tag <- mb_rts_tag = tag + | null liveness_data = rET_SMALL -- Fits in extra_bits + | otherwise = rET_BIG -- Does not; extra_bits is + -- a label + ; return (prof_data ++ liveness_data, (std_info, srt_label)) } + + | HeapRep _ ptrs nonptrs closure_type <- smrep + = do { let layout = packIntsCLit dflags ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits dflags prof + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt + ; (mb_srt_field, mb_layout, extra_bits, ct_data) + <- mk_pieces closure_type srt_label + ; let std_info = mkStdInfoTable dflags prof_lits + (mb_rts_tag `orElse` rtsClosureType smrep) + (mb_srt_field `orElse` srt_bitmap) + (mb_layout `orElse` layout) + ; return (prof_data ++ ct_data, (std_info, extra_bits)) } + where + mk_pieces :: ClosureTypeInfo -> [CmmLit] + -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this + , Maybe CmmLit -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls + mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor + = do { (descr_lit, decl) <- newStringLit con_descr + ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) + , Nothing, [descr_lit], [decl]) } + + mk_pieces Thunk srt_label + = return (Nothing, Nothing, srt_label, []) + + mk_pieces (ThunkSelector offset) _no_srt + = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) + -- Layout known (one free var); we use the layout field for offset + + mk_pieces (Fun arity (ArgSpec fun_type)) srt_label + = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label + ; return (Nothing, Nothing, extra_bits, []) } + + mk_pieces (Fun arity (ArgGen arg_bits)) srt_label + = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits + ; let fun_type | null liveness_data = aRG_GEN + | otherwise = aRG_GEN_BIG + extra_bits = [ packIntsCLit dflags fun_type arity + , srt_lit, liveness_lit, slow_entry ] + ; return (Nothing, Nothing, extra_bits, liveness_data) } + where + slow_entry = CmmLabel (toSlowEntryLbl info_lbl) + srt_lit = case srt_label of + [] -> mkIntCLit dflags 0 + (lit:_rest) -> ASSERT( null _rest ) lit + + mk_pieces other _ = pprPanic "mk_pieces" (ppr other) + +mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier + +packIntsCLit :: DynFlags -> Int -> Int -> CmmLit +packIntsCLit dflags a b = packHalfWordsCLit dflags + (toStgHalfWord dflags (fromIntegral a)) + (toStgHalfWord dflags (fromIntegral b)) + + +mkSRTLit :: DynFlags + -> C_SRT + -> ([CmmLit], -- srt_label, if any + StgHalfWord) -- srt_bitmap +mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0) +mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) + + +------------------------------------------------------------------------- +-- +-- Lay out the info table and handle relative offsets +-- +------------------------------------------------------------------------- + +-- This function takes +-- * the standard info table portion (StgInfoTable) +-- * the "extra bits" (StgFunInfoExtraRev etc.) +-- * the entry label +-- * the code +-- and lays them out in memory, producing a list of RawCmmDecl + +------------------------------------------------------------------------- +-- +-- Position independent code +-- +------------------------------------------------------------------------- +-- In order to support position independent code, we mustn't put absolute +-- references into read-only space. Info tables in the tablesNextToCode +-- case must be in .text, which is read-only, so we doctor the CmmLits +-- to use relative offsets instead. + +-- Note that this is done even when the -fPIC flag is not specified, +-- as we want to keep binary compatibility between PIC and non-PIC. + +makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit + +makeRelativeRefTo dflags info_lbl (CmmLabel lbl) + | tablesNextToCode dflags + = CmmLabelDiffOff lbl info_lbl 0 +makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off) + | tablesNextToCode dflags + = CmmLabelDiffOff lbl info_lbl off +makeRelativeRefTo _ _ lit = lit + + +------------------------------------------------------------------------- +-- +-- Build a liveness mask for the stack layout +-- +------------------------------------------------------------------------- + +-- There are four kinds of things on the stack: +-- +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) +-- +-- The first two are represented with a 'Just' of a 'LocalReg'. +-- The last two with one or more 'Nothing' constructors. +-- Each 'Nothing' represents one used word. +-- +-- The head of the stack layout is the top of the stack and +-- the least-significant bit. + +mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) + -- ^ Returns: + -- 1. The bitmap (literal value or label) + -- 2. Large bitmap CmmData if needed + +mkLivenessBits dflags liveness + | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word + = do { uniq <- getUniqueM + ; let bitmap_lbl = mkBitmapLabel uniq + ; return (CmmLabel bitmap_lbl, + [mkRODataLits bitmap_lbl lits]) } + + | otherwise -- Fits in one word + = return (mkStgWordCLit dflags bitmap_word, []) + where + n_bits = length liveness + + bitmap :: Bitmap + bitmap = mkBitmap dflags liveness + + small_bitmap = case bitmap of + [] -> toStgWord dflags 0 + [b] -> b + _ -> panic "mkLiveness" + bitmap_word = toStgWord dflags (fromIntegral n_bits) + .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) + + lits = mkWordCLit dflags (fromIntegral n_bits) + : map (mkStgWordCLit dflags) bitmap + -- The first word is the size. The structure must match + -- StgLargeBitmap in includes/rts/storage/InfoTable.h + +------------------------------------------------------------------------- +-- +-- Generating a standard info table +-- +------------------------------------------------------------------------- + +-- The standard bits of an info table. This part of the info table +-- corresponds to the StgInfoTable type defined in +-- includes/rts/storage/InfoTables.h. +-- +-- Its shape varies with ticky/profiling/tables next to code etc +-- so we can't use constant offsets from Constants + +mkStdInfoTable + :: DynFlags + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + -> Int -- Closure RTS tag + -> StgHalfWord -- SRT length + -> CmmLit -- layout field + -> [CmmLit] + +mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit + = -- Parallel revertible-black hole field + prof_info + -- Ticky info (none at present) + -- Debug info (none at present) + ++ [layout_lit, type_lit] + + where + prof_info + | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] + | otherwise = [] + + type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len + +------------------------------------------------------------------------- +-- +-- Making string literals +-- +------------------------------------------------------------------------- + +mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) +mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), []) +mkProfLits _ (ProfilingInfo td cd) + = do { (td_lit, td_decl) <- newStringLit td + ; (cd_lit, cd_decl) <- newStringLit cd + ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } + +newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) +newStringLit bytes + = do { uniq <- getUniqueM + ; return (mkByteStringCLit uniq bytes) } + + +-- Misc utils + +-- | Value of the srt field of an info table when using an StgLargeSRT +srtEscape :: DynFlags -> StgHalfWord +srtEscape dflags = toStgHalfWord dflags (-1) + +------------------------------------------------------------------------- +-- +-- Accessing fields of an info table +-- +------------------------------------------------------------------------- + +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer and returns the info table pointer +closureInfoPtr dflags e = CmmLoad e (bWord dflags) + +entryCode :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info pointer (the first word of a closure) +-- and returns its entry code +entryCode dflags e + | tablesNextToCode dflags = e + | otherwise = CmmLoad e (bWord dflags) + +getConstrTag :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer, and return the *zero-indexed* +-- constructor tag obtained from the info table +-- This lives in the SRT field of the info table +-- (constructors don't need SRTs). +getConstrTag dflags closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] + where + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) + +cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr +-- Takes a closure pointer, and return the closure type +-- obtained from the info table +cmmGetClosureType dflags closure_ptr + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] + where + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) + +infoTable :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info pointer (the first word of a closure) +-- and returns a pointer to the first word of the standard-form +-- info table, excluding the entry-code word (if present) +infoTable dflags info_ptr + | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer + +infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the constr tag +-- field of the info table (same as the srt_bitmap field) +infoTableConstrTag = infoTableSrtBitmap + +infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the srt_bitmap +-- field of the info table +infoTableSrtBitmap dflags info_tbl + = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) + +infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr +-- Takes an info table pointer (from infoTable) and returns the closure type +-- field of the info table. +infoTableClosureType dflags info_tbl + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) + +infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTablePtrs dflags info_tbl + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) + +infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTableNonPtrs dflags info_tbl + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) + +funInfoTable :: DynFlags -> CmmExpr -> CmmExpr +-- Takes the info pointer of a function, +-- and returns a pointer to the first word of the StgFunInfoExtra struct +-- in the info table. +funInfoTable dflags info_ptr + | tablesNextToCode dflags + = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) + | otherwise + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) + -- Past the entry code pointer + +-- Takes the info pointer of a function, returns the function's arity +funInfoArity :: DynFlags -> CmmExpr -> CmmExpr +funInfoArity dflags iptr + = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes)) + where + fun_info = funInfoTable dflags iptr + rep = cmmBits (widthFromBytes rep_bytes) + + (rep_bytes, offset) + | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc + , oFFSET_StgFunInfoExtraRev_arity dflags ) + | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc + , oFFSET_StgFunInfoExtraFwd_arity dflags ) + + pc = sPlatformConstants (settings dflags) + +----------------------------------------------------------------------------- +-- +-- Info table sizes & offsets +-- +----------------------------------------------------------------------------- + +stdInfoTableSizeW :: DynFlags -> WordOff +-- The size of a standard info table varies with profiling/ticky etc, +-- so we can't get it from Constants +-- It must vary in sync with mkStdInfoTable +stdInfoTableSizeW dflags + = fixedInfoTableSizeW + + if gopt Opt_SccProfilingOn dflags + then profInfoTableSizeW + else 0 + +fixedInfoTableSizeW :: WordOff +fixedInfoTableSizeW = 2 -- layout, type + +profInfoTableSizeW :: WordOff +profInfoTableSizeW = 2 + +maxStdInfoTableSizeW :: WordOff +maxStdInfoTableSizeW = + 1 {- entry, when !tablesNextToCode -} + + fixedInfoTableSizeW + + profInfoTableSizeW + +maxRetInfoTableSizeW :: WordOff +maxRetInfoTableSizeW = + maxStdInfoTableSizeW + + 1 {- srt label -} + +stdInfoTableSizeB :: DynFlags -> ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags + +stdSrtBitmapOffset :: DynFlags -> ByteOff +-- Byte offset of the SRT bitmap half-word which is +-- in the *higher-addressed* part of the type_lit +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags + +stdClosureTypeOffset :: DynFlags -> ByteOff +-- Byte offset of the closure type half-word +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags + +stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs new file mode 100644 index 00000000..8439240b --- /dev/null +++ b/compiler/cmm/CmmLayoutStack.hs @@ -0,0 +1,1113 @@ +{-# LANGUAGE CPP, RecordWildCards, GADTs #-} +module CmmLayoutStack ( + cmmLayoutStack, setInfoTableStackMap + ) where + +import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation +import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation + +import BasicTypes +import Cmm +import CmmInfo +import BlockId +import CLabel +import CmmUtils +import MkGraph +import ForeignCall +import CmmLive +import CmmProcPoint +import SMRep +import Hoopl +import UniqSupply +import Maybes +import UniqFM +import Util + +import DynFlags +import FastString +import Outputable +import qualified Data.Set as Set +import Control.Monad.Fix +import Data.Array as Array +import Data.Bits +import Data.List (nub) +import Control.Monad (liftM) + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +#include "HsVersions.h" + +{- Note [Stack Layout] + +The job of this pass is to + + - replace references to abstract stack Areas with fixed offsets from Sp. + + - replace the CmmHighStackMark constant used in the stack check with + the maximum stack usage of the proc. + + - save any variables that are live across a call, and reload them as + necessary. + +Before stack allocation, local variables remain live across native +calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local +variables are clobbered by native calls. + +We want to do stack allocation so that as far as possible + - stack use is minimized, and + - unnecessary stack saves and loads are avoided. + +The algorithm we use is a variant of linear-scan register allocation, +where the stack is our register file. + + - First, we do a liveness analysis, which annotates every block with + the variables live on entry to the block. + + - We traverse blocks in reverse postorder DFS; that is, we visit at + least one predecessor of a block before the block itself. The + stack layout flowing from the predecessor of the block will + determine the stack layout on entry to the block. + + - We maintain a data structure + + Map Label StackMap + + which describes the contents of the stack and the stack pointer on + entry to each block that is a successor of a block that we have + visited. + + - For each block we visit: + + - Look up the StackMap for this block. + + - If this block is a proc point (or a call continuation, if we + aren't splitting proc points), emit instructions to reload all + the live variables from the stack, according to the StackMap. + + - Walk forwards through the instructions: + - At an assignment x = Sp[loc] + - Record the fact that Sp[loc] contains x, so that we won't + need to save x if it ever needs to be spilled. + - At an assignment x = E + - If x was previously on the stack, it isn't any more + - At the last node, if it is a call or a jump to a proc point + - Lay out the stack frame for the call (see setupStackFrame) + - emit instructions to save all the live variables + - Remember the StackMaps for all the successors + - emit an instruction to adjust Sp + - If the last node is a branch, then the current StackMap is the + StackMap for the successors. + + - Manifest Sp: replace references to stack areas in this block + with real Sp offsets. We cannot do this until we have laid out + the stack area for the successors above. + + In this phase we also eliminate redundant stores to the stack; + see elimStackStores. + + - There is one important gotcha: sometimes we'll encounter a control + transfer to a block that we've already processed (a join point), + and in that case we might need to rearrange the stack to match + what the block is expecting. (exactly the same as in linear-scan + register allocation, except here we have the luxury of an infinite + supply of temporary variables). + + - Finally, we update the magic CmmHighStackMark constant with the + stack usage of the function, and eliminate the whole stack check + if there was no stack use. (in fact this is done as part of the + main traversal, by feeding the high-water-mark output back in as + an input. I hate cyclic programming, but it's just too convenient + sometimes.) + +There are plenty of tricky details: update frames, proc points, return +addresses, foreign calls, and some ad-hoc optimisations that are +convenient to do here and effective in common cases. Comments in the +code below explain these. + +-} + + +-- All stack locations are expressed as positive byte offsets from the +-- "base", which is defined to be the address above the return address +-- on the stack on entry to this CmmProc. +-- +-- Lower addresses have higher StackLocs. +-- +type StackLoc = ByteOff + +{- + A StackMap describes the stack at any given point. At a continuation + it has a particular layout, like this: + + | | <- base + |-------------| + | ret0 | <- base + 8 + |-------------| + . upd frame . <- base + sm_ret_off + |-------------| + | | + . vars . + . (live/dead) . + | | <- base + sm_sp - sm_args + |-------------| + | ret1 | + . ret vals . <- base + sm_sp (<--- Sp points here) + |-------------| + +Why do we include the final return address (ret0) in our stack map? I +have absolutely no idea, but it seems to be done that way consistently +in the rest of the code generator, so I played along here. --SDM + +Note that we will be constructing an info table for the continuation +(ret1), which needs to describe the stack down to, but not including, +the update frame (or ret0, if there is no update frame). +-} + +data StackMap = StackMap + { sm_sp :: StackLoc + -- ^ the offset of Sp relative to the base on entry + -- to this block. + , sm_args :: ByteOff + -- ^ the number of bytes of arguments in the area for this block + -- Defn: the offset of young(L) relative to the base is given by + -- (sm_sp - sm_args) of the StackMap for block L. + , sm_ret_off :: ByteOff + -- ^ Number of words of stack that we do not describe with an info + -- table, because it contains an update frame. + , sm_regs :: UniqFM (LocalReg,StackLoc) + -- ^ regs on the stack + } + +instance Outputable StackMap where + ppr StackMap{..} = + text "Sp = " <> int sm_sp $$ + text "sm_args = " <> int sm_args $$ + text "sm_ret_off = " <> int sm_ret_off $$ + text "sm_regs = " <> ppr (eltsUFM sm_regs) + + +cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph + -> UniqSM (CmmGraph, BlockEnv StackMap) +cmmLayoutStack dflags procpoints entry_args + graph0@(CmmGraph { g_entry = entry }) + = do + -- We need liveness info. Dead assignments are removed later + -- by the sinking pass. + let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0) + blocks = postorderDfs graph + + (final_stackmaps, _final_high_sp, new_blocks) <- + mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> + layout dflags procpoints liveness entry entry_args + rec_stackmaps rec_high_sp blocks + + new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks + return (ofBlockList entry new_blocks', final_stackmaps) + + +layout :: DynFlags + -> BlockSet -- proc points + -> BlockEnv CmmLocalLive -- liveness + -> BlockId -- entry + -> ByteOff -- stack args on entry + + -> BlockEnv StackMap -- [final] stack maps + -> ByteOff -- [final] Sp high water mark + + -> [CmmBlock] -- [in] blocks + + -> UniqSM + ( BlockEnv StackMap -- [out] stack maps + , ByteOff -- [out] Sp high water mark + , [CmmBlock] -- [out] new blocks + ) + +layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks + = go blocks init_stackmap entry_args [] + where + (updfr, cont_info) = collectContInfo blocks + + init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args + , sm_args = entry_args + , sm_ret_off = updfr + , sm_regs = emptyUFM + } + + go [] acc_stackmaps acc_hwm acc_blocks + = return (acc_stackmaps, acc_hwm, acc_blocks) + + go (b0 : bs) acc_stackmaps acc_hwm acc_blocks + = do + let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0 + + let stack0@StackMap { sm_sp = sp0 } + = mapFindWithDefault + (pprPanic "no stack map for" (ppr entry_lbl)) + entry_lbl acc_stackmaps + + -- (a) Update the stack map to include the effects of + -- assignments in this block + let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0 + + -- (b) Insert assignments to reload all the live variables if this + -- block is a proc point + let middle1 = if entry_lbl `setMember` procpoints + then foldr blockCons middle0 (insertReloads stack0) + else middle0 + + -- (c) Look at the last node and if we are making a call or + -- jumping to a proc point, we must save the live + -- variables, adjust Sp, and construct the StackMaps for + -- each of the successor blocks. See handleLastNode for + -- details. + (middle2, sp_off, last1, fixup_blocks, out) + <- handleLastNode dflags procpoints liveness cont_info + acc_stackmaps stack1 tscope middle0 last0 + + -- (d) Manifest Sp: run over the nodes in the block and replace + -- CmmStackSlot with CmmLoad from Sp with a concrete offset. + -- + -- our block: + -- middle1 -- the original middle nodes + -- middle2 -- live variable saves from handleLastNode + -- Sp = Sp + sp_off -- Sp adjustment goes here + -- last1 -- the last node + -- + let middle_pre = blockToList $ foldl blockSnoc middle1 middle2 + + final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0 + middle_pre sp_off last1 fixup_blocks + + acc_stackmaps' = mapUnion acc_stackmaps out + + -- If this block jumps to the GC, then we do not take its + -- stack usage into account for the high-water mark. + -- Otherwise, if the only stack usage is in the stack-check + -- failure block itself, we will do a redundant stack + -- check. The stack has a buffer designed to accommodate + -- the largest amount of stack needed for calling the GC. + -- + this_sp_hwm | isGcJump last0 = 0 + | otherwise = sp0 - sp_off + + hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out)) + + go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) + + +-- ----------------------------------------------------------------------------- + +-- Not foolproof, but GCFun is the culprit we most want to catch +isGcJump :: CmmNode O C -> Bool +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) + = l == GCFun || l == GCEnter1 +isGcJump _something_else = False + +-- ----------------------------------------------------------------------------- + +-- This doesn't seem right somehow. We need to find out whether this +-- proc will push some update frame material at some point, so that we +-- can avoid using that area of the stack for spilling. The +-- updfr_space field of the CmmProc *should* tell us, but it doesn't +-- (I think maybe it gets filled in later when we do proc-point +-- splitting). +-- +-- So we'll just take the max of all the cml_ret_offs. This could be +-- unnecessarily pessimistic, but probably not in the code we +-- generate. + +collectContInfo :: [CmmBlock] -> (ByteOff, BlockEnv ByteOff) +collectContInfo blocks + = (maximum ret_offs, mapFromList (catMaybes mb_argss)) + where + (mb_argss, ret_offs) = mapAndUnzip get_cont blocks + + get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff) + get_cont b = + case lastNode b of + CmmCall { cml_cont = Just l, .. } + -> (Just (l, cml_ret_args), cml_ret_off) + CmmForeignCall { .. } + -> (Just (succ, ret_args), ret_off) + _other -> (Nothing, 0) + + +-- ----------------------------------------------------------------------------- +-- Updating the StackMap from middle nodes + +-- Look for loads from stack slots, and update the StackMap. This is +-- purely for optimisation reasons, so that we can avoid saving a +-- variable back to a different stack slot if it is already on the +-- stack. +-- +-- This happens a lot: for example when function arguments are passed +-- on the stack and need to be immediately saved across a call, we +-- want to just leave them where they are on the stack. +-- +procMiddle :: BlockEnv StackMap -> CmmNode e x -> StackMap -> StackMap +procMiddle stackmaps node sm + = case node of + CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _) + -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } + where loc = getStackLoc area off stackmaps + CmmAssign (CmmLocal r) _other + -> sm { sm_regs = delFromUFM (sm_regs sm) r } + _other + -> sm + +getStackLoc :: Area -> ByteOff -> BlockEnv StackMap -> StackLoc +getStackLoc Old n _ = n +getStackLoc (Young l) n stackmaps = + case mapLookup l stackmaps of + Nothing -> pprPanic "getStackLoc" (ppr l) + Just sm -> sm_sp sm - sm_args sm + n + + +-- ----------------------------------------------------------------------------- +-- Handling stack allocation for a last node + +-- We take a single last node and turn it into: +-- +-- C1 (some statements) +-- Sp = Sp + N +-- C2 (some more statements) +-- call f() -- the actual last node +-- +-- plus possibly some more blocks (we may have to add some fixup code +-- between the last node and the continuation). +-- +-- C1: is the code for saving the variables across this last node onto +-- the stack, if the continuation is a call or jumps to a proc point. +-- +-- C2: if the last node is a safe foreign call, we have to inject some +-- extra code that goes *after* the Sp adjustment. + +handleLastNode + :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff + -> BlockEnv StackMap -> StackMap -> CmmTickScope + -> Block CmmNode O O + -> CmmNode O C + -> UniqSM + ( [CmmNode O O] -- nodes to go *before* the Sp adjustment + , ByteOff -- amount to adjust Sp + , CmmNode O C -- new last node + , [CmmBlock] -- new blocks + , BlockEnv StackMap -- stackmaps for the continuations + ) + +handleLastNode dflags procpoints liveness cont_info stackmaps + stack0@StackMap { sm_sp = sp0 } tscp middle last + = case last of + -- At each return / tail call, + -- adjust Sp to point to the last argument pushed, which + -- is cml_args, after popping any other junk from the stack. + CmmCall{ cml_cont = Nothing, .. } -> do + let sp_off = sp0 - cml_args + return ([], sp_off, last, [], mapEmpty) + + -- At each CmmCall with a continuation: + CmmCall{ cml_cont = Just cont_lbl, .. } -> + return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off + + CmmForeignCall{ succ = cont_lbl, .. } -> do + return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off + -- one word of args: the return address + + CmmBranch {} -> handleBranches + CmmCondBranch {} -> handleBranches + CmmSwitch {} -> handleBranches + + where + -- Calls and ForeignCalls are handled the same way: + lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff + -> ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , BlockEnv StackMap + ) + lastCall lbl cml_args cml_ret_args cml_ret_off + = ( assignments + , spOffsetForCall sp0 cont_stack cml_args + , last + , [] -- no new blocks + , mapSingleton lbl cont_stack ) + where + (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off + + + prepareStack lbl cml_ret_args cml_ret_off + | Just cont_stack <- mapLookup lbl stackmaps + -- If we have already seen this continuation before, then + -- we just have to make the stack look the same: + = (fixupStack stack0 cont_stack, cont_stack) + -- Otherwise, we have to allocate the stack frame + | otherwise + = (save_assignments, new_cont_stack) + where + (new_cont_stack, save_assignments) + = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0 + + + -- For other last nodes (branches), if any of the targets is a + -- proc point, we have to set up the stack to match what the proc + -- point is expecting. + -- + handleBranches :: UniqSM ( [CmmNode O O] + , ByteOff + , CmmNode O C + , [CmmBlock] + , BlockEnv StackMap ) + + handleBranches + -- Note [diamond proc point] + | Just l <- futureContinuation middle + , (nub $ filter (`setMember` procpoints) $ successors last) == [l] + = do + let cont_args = mapFindWithDefault 0 l cont_info + (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0) + out = mapFromList [ (l', cont_stack) + | l' <- successors last ] + return ( assigs + , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags) + , last + , [] + , out) + + | otherwise = do + pps <- mapM handleBranch (successors last) + let lbl_map :: LabelMap Label + lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ] + fix_lbl l = mapFindWithDefault l l lbl_map + return ( [] + , 0 + , mapSuccessors fix_lbl last + , concat [ blk | (_,_,_,blk) <- pps ] + , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] ) + + -- For each successor of this block + handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]) + handleBranch l + -- (a) if the successor already has a stackmap, we need to + -- shuffle the current stack to make it look the same. + -- We have to insert a new block to make this happen. + | Just stack2 <- mapLookup l stackmaps + = do + let assigs = fixupStack stack0 stack2 + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (b) if the successor is a proc point, save everything + -- on the stack. + | l `setMember` procpoints + = do + let cont_args = mapFindWithDefault 0 l cont_info + (stack2, assigs) = + setupStackFrame dflags l liveness (sm_ret_off stack0) + cont_args stack0 + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + return (l, tmp_lbl, stack2, block) + + -- (c) otherwise, the current StackMap is the StackMap for + -- the continuation. But we must remember to remove any + -- variables from the StackMap that are *not* live at + -- the destination, because this StackMap might be used + -- by fixupStack if this is a join point. + | otherwise = return (l, l, stack1, []) + where live = mapFindWithDefault (panic "handleBranch") l liveness + stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) } + is_live (r,_) = r `elemRegSet` live + + +makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap + -> CmmTickScope -> [CmmNode O O] + -> UniqSM (Label, [CmmBlock]) +makeFixupBlock dflags sp0 l stack tscope assigs + | null assigs && sp0 == sm_sp stack = return (l, []) + | otherwise = do + tmp_lbl <- liftM mkBlockId $ getUniqueM + let sp_off = sp0 - sm_sp stack + block = blockJoin (CmmEntry tmp_lbl tscope) + (maybeAddSpAdj dflags sp_off (blockFromList assigs)) + (CmmBranch l) + return (tmp_lbl, [block]) + + +-- Sp is currently pointing to current_sp, +-- we want it to point to +-- (sm_sp cont_stack - sm_args cont_stack + args) +-- so the difference is +-- sp0 - (sm_sp cont_stack - sm_args cont_stack + args) +spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff +spOffsetForCall current_sp cont_stack args + = current_sp - (sm_sp cont_stack - sm_args cont_stack + args) + + +-- | create a sequence of assignments to establish the new StackMap, +-- given the old StackMap. +fixupStack :: StackMap -> StackMap -> [CmmNode O O] +fixupStack old_stack new_stack = concatMap move new_locs + where + old_map = sm_regs old_stack + new_locs = stackSlotRegs new_stack + + move (r,n) + | Just (_,m) <- lookupUFM old_map r, n == m = [] + | otherwise = [CmmStore (CmmStackSlot Old n) + (CmmReg (CmmLocal r))] + + + +setupStackFrame + :: DynFlags + -> BlockId -- label of continuation + -> BlockEnv CmmLocalLive -- liveness + -> ByteOff -- updfr + -> ByteOff -- bytes of return values on stack + -> StackMap -- current StackMap + -> (StackMap, [CmmNode O O]) + +setupStackFrame dflags lbl liveness updfr_off ret_args stack0 + = (cont_stack, assignments) + where + -- get the set of LocalRegs live in the continuation + live = mapFindWithDefault Set.empty lbl liveness + + -- the stack from the base to updfr_off is off-limits. + -- our new stack frame contains: + -- * saved live variables + -- * the return address [young(C) + 8] + -- * the args for the call, + -- which are replaced by the return values at the return + -- point. + + -- everything up to updfr_off is off-limits + -- stack1 contains updfr_off, plus everything we need to save + (stack1, assignments) = allocate dflags updfr_off live stack0 + + -- And the Sp at the continuation is: + -- sm_sp stack1 + ret_args + cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args + , sm_args = ret_args + , sm_ret_off = updfr_off + } + + +-- ----------------------------------------------------------------------------- +-- Note [diamond proc point] +-- +-- This special case looks for the pattern we get from a typical +-- tagged case expression: +-- +-- Sp[young(L1)] = L1 +-- if (R1 & 7) != 0 goto L1 else goto L2 +-- L2: +-- call [R1] returns to L1 +-- L1: live: {y} +-- x = R1 +-- +-- If we let the generic case handle this, we get +-- +-- Sp[-16] = L1 +-- if (R1 & 7) != 0 goto L1a else goto L2 +-- L2: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- call [R1] returns to L1 +-- L1a: +-- Sp[-8] = y +-- Sp = Sp - 16 +-- goto L1 +-- L1: +-- x = R1 +-- +-- The code for saving the live vars is duplicated in each branch, and +-- furthermore there is an extra jump in the fast path (assuming L1 is +-- a proc point, which it probably is if there is a heap check). +-- +-- So to fix this we want to set up the stack frame before the +-- conditional jump. How do we know when to do this, and when it is +-- safe? The basic idea is, when we see the assignment +-- +-- Sp[young(L)] = L +-- +-- we know that +-- * we are definitely heading for L +-- * there can be no more reads from another stack area, because young(L) +-- overlaps with it. +-- +-- We don't necessarily know that everything live at L is live now +-- (some might be assigned between here and the jump to L). So we +-- simplify and only do the optimisation when we see +-- +-- (1) a block containing an assignment of a return address L +-- (2) ending in a branch where one (and only) continuation goes to L, +-- and no other continuations go to proc points. +-- +-- then we allocate the stack frame for L at the end of the block, +-- before the branch. +-- +-- We could generalise (2), but that would make it a bit more +-- complicated to handle, and this currently catches the common case. + +futureContinuation :: Block CmmNode O O -> Maybe BlockId +futureContinuation middle = foldBlockNodesB f middle Nothing + where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId + f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _ + = Just l + f _ r = r + +-- ----------------------------------------------------------------------------- +-- Saving live registers + +-- | Given a set of live registers and a StackMap, save all the registers +-- on the stack and return the new StackMap and the assignments to do +-- the saving. +-- +allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap + -> (StackMap, [CmmNode O O]) +allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 + , sm_regs = regs0 } + = + -- we only have to save regs that are not already in a slot + let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) + regs1 = filterUFM (\(r,_) -> elemRegSet r live) regs0 + in + + -- make a map of the stack + let stack = reverse $ Array.elems $ + accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $ + ret_words ++ live_words + where ret_words = + [ (x, Occupied) + | x <- [ 1 .. toWords dflags ret_off] ] + live_words = + [ (toWords dflags x, Occupied) + | (r,off) <- eltsUFM regs1, + let w = localRegBytes dflags r, + x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ] + in + + -- Pass over the stack: find slots to save all the new live variables, + -- choosing the oldest slots first (hence a foldr). + let + save slot ([], stack, n, assigs, regs) -- no more regs to save + = ([], slot:stack, plusW dflags n 1, assigs, regs) + save slot (to_save, stack, n, assigs, regs) + = case slot of + Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs) + Empty + | Just (stack', r, to_save') <- + select_save to_save (slot:stack) + -> let assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + n' = plusW dflags n 1 + in + (to_save', stack', n', assig : assigs, (r,(r,n')):regs) + + | otherwise + -> (to_save, slot:stack, plusW dflags n 1, assigs, regs) + + -- we should do better here: right now we'll fit the smallest first, + -- but it would make more sense to fit the biggest first. + select_save :: [LocalReg] -> [StackSlot] + -> Maybe ([StackSlot], LocalReg, [LocalReg]) + select_save regs stack = go regs [] + where go [] _no_fit = Nothing + go (r:rs) no_fit + | Just rest <- dropEmpty words stack + = Just (replicate words Occupied ++ rest, r, rs++no_fit) + | otherwise + = go rs (r:no_fit) + where words = localRegWords dflags r + + -- fill in empty slots as much as possible + (still_to_save, save_stack, n, save_assigs, save_regs) + = foldr save (to_save, [], 0, [], []) stack + + -- push any remaining live vars on the stack + (push_sp, push_assigs, push_regs) + = foldr push (n, [], []) still_to_save + where + push r (n, assigs, regs) + = (n', assig : assigs, (r,(r,n')) : regs) + where + n' = n + localRegBytes dflags r + assig = CmmStore (CmmStackSlot Old n') + (CmmReg (CmmLocal r)) + + trim_sp + | not (null push_regs) = push_sp + | otherwise + = plusW dflags n (- length (takeWhile isEmpty save_stack)) + + final_regs = regs1 `addListToUFM` push_regs + `addListToUFM` save_regs + + in + -- XXX should be an assert + if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else + + if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else + + ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } + , push_assigs ++ save_assigs ) + + +-- ----------------------------------------------------------------------------- +-- Manifesting Sp + +-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp. The +-- block looks like this: +-- +-- middle_pre -- the middle nodes +-- Sp = Sp + sp_off -- Sp adjustment goes here +-- last -- the last node +-- +-- And we have some extra blocks too (that don't contain Sp adjustments) +-- +-- The adjustment for middle_pre will be different from that for +-- middle_post, because the Sp adjustment intervenes. +-- +manifestSp + :: DynFlags + -> BlockEnv StackMap -- StackMaps for other blocks + -> StackMap -- StackMap for this block + -> ByteOff -- Sp on entry to the block + -> ByteOff -- SpHigh + -> CmmNode C O -- first node + -> [CmmNode O O] -- middle + -> ByteOff -- sp_off + -> CmmNode O C -- last node + -> [CmmBlock] -- new blocks + -> [CmmBlock] -- final blocks with Sp manifest + +manifestSp dflags stackmaps stack0 sp0 sp_high + first middle_pre sp_off last fixup_blocks + = final_block : fixup_blocks' + where + area_off = getAreaOff stackmaps + + adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x + adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off) + adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off) + + -- Add unwind pseudo-instructions to document Sp level for debugging + add_unwind_info block + | gopt Opt_Debug dflags = CmmUnwind Sp sp_unwind : block + | otherwise = block + sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags) + + final_middle = maybeAddSpAdj dflags sp_off $ + blockFromList $ + add_unwind_info $ + map adj_pre_sp $ + elimStackStores stack0 stackmaps area_off $ + middle_pre + + final_last = optStackCheck (adj_post_sp last) + + final_block = blockJoin first final_middle final_last + + fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks + + +getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc) +getAreaOff _ Old = 0 +getAreaOff stackmaps (Young l) = + case mapLookup l stackmaps of + Just sm -> sm_sp sm - sm_args sm + Nothing -> pprPanic "getAreaOff" (ppr l) + + +maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj _ 0 block = block +maybeAddSpAdj dflags sp_off block + = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off) + + +{- +Sp(L) is the Sp offset on entry to block L relative to the base of the +OLD area. + +SpArgs(L) is the size of the young area for L, i.e. the number of +arguments. + + - in block L, each reference to [old + N] turns into + [Sp + Sp(L) - N] + + - in block L, each reference to [young(L') + N] turns into + [Sp + Sp(L) - Sp(L') + SpArgs(L') - N] + + - be careful with the last node of each block: Sp has already been adjusted + to be Sp + Sp(L) - Sp(L') +-} + +areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr + +areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) + = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n) + -- Replace (CmmStackSlot area n) with an offset from Sp + +areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) + = mkIntExpr dflags sp_hwm + -- Replace CmmHighStackMark with the number of bytes of stack used, + -- the sp_hwm. See Note [Stack usage] in StgCmmHeap + +areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) + [CmmMachOp (MO_Sub _) + [ CmmRegOff (CmmGlobal Sp) x_off + , CmmLit (CmmInt y_lit _)], + CmmReg (CmmGlobal SpLim)]) + | fromIntegral x_off >= y_lit + = zeroExpr dflags + -- Replace a stack-overflow test that cannot fail with a no-op + -- See Note [Always false stack check] + +areaToSp _ _ _ _ other = other + +-- Note [Always false stack check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We can optimise stack checks of the form +-- +-- if ((Sp + x) - y < SpLim) then .. else .. +-- +-- where are non-negative integer byte offsets. Since we know that +-- SpLim <= Sp (remember the stack grows downwards), this test must +-- yield False if (x >= y), so we can rewrite the comparison to False. +-- A subsequent sinking pass will later drop the dead code. +-- Optimising this away depends on knowing that SpLim <= Sp, so it is +-- really the job of the stack layout algorithm, hence we do it now. + +optStackCheck :: CmmNode O C -> CmmNode O C +optStackCheck n = -- Note [Always false stack check] + case n of + CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false + other -> other + + +-- ----------------------------------------------------------------------------- + +-- | Eliminate stores of the form +-- +-- Sp[area+n] = r +-- +-- when we know that r is already in the same slot as Sp[area+n]. We +-- could do this in a later optimisation pass, but that would involve +-- a separate analysis and we already have the information to hand +-- here. It helps clean up some extra stack stores in common cases. +-- +-- Note that we may have to modify the StackMap as we walk through the +-- code using procMiddle, since an assignment to a variable in the +-- StackMap will invalidate its mapping there. +-- +elimStackStores :: StackMap + -> BlockEnv StackMap + -> (Area -> ByteOff) + -> [CmmNode O O] + -> [CmmNode O O] +elimStackStores stackmap stackmaps area_off nodes + = go stackmap nodes + where + go _stackmap [] = [] + go stackmap (n:ns) + = case n of + CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) + | Just (_,off) <- lookupUFM (sm_regs stackmap) r + , area_off area + m == off + -> go stackmap ns + _otherwise + -> n : go (procMiddle stackmaps n stackmap) ns + + +-- ----------------------------------------------------------------------------- +-- Update info tables to include stack liveness + + +setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g + where + fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = + info_tbl { cit_rep = StackRep (get_liveness lbl) } + fix_info _ other = other + + get_liveness :: BlockId -> Liveness + get_liveness lbl + = case mapLookup lbl stackmaps of + Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) + Just sm -> stackMapToLiveness dflags sm + +setInfoTableStackMap _ _ d = d + + +stackMapToLiveness :: DynFlags -> StackMap -> Liveness +stackMapToLiveness dflags StackMap{..} = + reverse $ Array.elems $ + accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1, + toWords dflags (sm_sp - sm_args)) live_words + where + live_words = [ (toWords dflags off, False) + | (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ] + + +-- ----------------------------------------------------------------------------- +-- Lowering safe foreign calls + +{- +Note [Lower safe foreign calls] + +We start with + + Sp[young(L1)] = L1 + ,----------------------- + | r1 = foo(x,y,z) returns to L1 + '----------------------- + L1: + R1 = r1 -- copyIn, inserted by mkSafeCall + ... + +the stack layout algorithm will arrange to save and reload everything +live across the call. Our job now is to expand the call so we get + + Sp[young(L1)] = L1 + ,----------------------- + | SAVE_THREAD_STATE() + | token = suspendThread(BaseReg, interruptible) + | r = foo(x,y,z) + | BaseReg = resumeThread(token) + | LOAD_THREAD_STATE() + | R1 = r -- copyOut + | jump Sp[0] + '----------------------- + L1: + r = R1 -- copyIn, inserted by mkSafeCall + ... + +Note the copyOut, which saves the results in the places that L1 is +expecting them (see Note {safe foreign call convention]). Note also +that safe foreign call is replace by an unsafe one in the Cmm graph. +-} + +lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock +lowerSafeForeignCall dflags block + | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block + = do + -- Both 'id' and 'new_base' are KindNonPtr because they're + -- RTS-only objects and are not subject to garbage collection + id <- newTemp (bWord dflags) + new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) + let (caller_save, caller_load) = callerSaveVolatileRegs dflags + load_stack <- newTemp (gcWord dflags) + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + let suspend = saveThreadState dflags tso cn <*> + caller_save <*> + mkMiddle (callSuspendThread dflags id intrbl) + midCall = mkUnsafeCall tgt res args + resume = mkMiddle (callResumeThread new_base id) <*> + -- Assign the result to BaseReg: we + -- might now have a different Capability! + mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> + caller_load <*> + loadThreadState dflags tso load_stack cn bdfree bdstart + + (_, regs, copyout) = + copyOutOflow dflags NativeReturn Jump (Young succ) + (map (CmmReg . CmmLocal) res) + ret_off [] + + -- NB. after resumeThread returns, the top-of-stack probably contains + -- the stack frame for succ, but it might not: if the current thread + -- received an exception during the call, then the stack might be + -- different. Hence we continue by jumping to the top stack frame, + -- not by jumping to succ. + jump = CmmCall { cml_target = entryCode dflags $ + CmmLoad (CmmReg spReg) (bWord dflags) + , cml_cont = Just succ + , cml_args_regs = regs + , cml_args = widthInBytes (wordWidth dflags) + , cml_ret_args = ret_args + , cml_ret_off = ret_off } + + graph' <- lgraphOfAGraph ( suspend <*> + midCall <*> + resume <*> + copyout <*> + mkLast jump, tscp) + + case toBlockList graph' of + [one] -> let (_, middle', last) = blockSplit one + in return (blockJoin entry (middle `blockAppend` middle') last) + _ -> panic "lowerSafeForeignCall0" + + -- Block doesn't end in a safe foreign call: + | otherwise = return block + + +foreignLbl :: FastString -> CmmExpr +foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) + +newTemp :: CmmType -> UniqSM LocalReg +newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) + +callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O +callSuspendThread dflags id intrbl = + CmmUnsafeForeignCall + (ForeignTarget (foreignLbl (fsLit "suspendThread")) + (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn)) + [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] + +callResumeThread :: LocalReg -> LocalReg -> CmmNode O O +callResumeThread new_base id = + CmmUnsafeForeignCall + (ForeignTarget (foreignLbl (fsLit "resumeThread")) + (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn)) + [new_base] [CmmReg (CmmLocal id)] + +-- ----------------------------------------------------------------------------- + +plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff +plusW dflags b w = b + w * wORD_SIZE dflags + +data StackSlot = Occupied | Empty + -- Occupied: a return address or part of an update frame + +instance Outputable StackSlot where + ppr Occupied = ptext (sLit "XXX") + ppr Empty = ptext (sLit "---") + +dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] +dropEmpty 0 ss = Just ss +dropEmpty n (Empty : ss) = dropEmpty (n-1) ss +dropEmpty _ _ = Nothing + +isEmpty :: StackSlot -> Bool +isEmpty Empty = True +isEmpty _ = False + +localRegBytes :: DynFlags -> LocalReg -> ByteOff +localRegBytes dflags r + = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r))) + +localRegWords :: DynFlags -> LocalReg -> WordOff +localRegWords dflags = toWords dflags . localRegBytes dflags + +toWords :: DynFlags -> ByteOff -> WordOff +toWords dflags x = x `quot` wORD_SIZE dflags + + +insertReloads :: StackMap -> [CmmNode O O] +insertReloads stackmap = + [ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot Old sp) + (localRegType r)) + | (r,sp) <- stackSlotRegs stackmap + ] + + +stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] +stackSlotRegs sm = eltsUFM (sm_regs sm) diff --git a/compiler/cmm/CmmLex.hs b/compiler/cmm/CmmLex.hs new file mode 100644 index 00000000..38cdcb6f --- /dev/null +++ b/compiler/cmm/CmmLex.hs @@ -0,0 +1,615 @@ +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 13 "compiler/cmm/CmmLex.x" #-} + +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -Wwarn -w #-} +-- The above -Wwarn supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module CmmLex ( + CmmToken(..), cmmlex, + ) where + +import CmmExpr + +import Lexer +import SrcLoc +import UniqFM +import StringBuffer +import FastString +import Ctype +import Util +--import TRACE + +import Data.Word +import Data.Char + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\xc9\x00\x00\x00\x43\x00\x00\x00\x4d\x00\x00\x00\x9f\xff\xff\xff\xd6\x00\x00\x00\x41\x00\x00\x00\xed\x00\x00\x00\x0f\x01\x00\x00\xa4\xff\xff\xff\x29\x01\x00\x00\xb8\xff\xff\xff\xd8\xff\xff\xff\xdf\xff\xff\xff\xe7\xff\xff\xff\xd9\xff\xff\xff\x41\x01\x00\x00\xdc\xff\xff\xff\xb8\x01\x00\x00\xdb\x01\x00\x00\x48\x00\x00\x00\x4b\x00\x00\x00\xc4\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\xff\xff\x51\x00\x00\x00\x58\x00\x00\x00\xd7\x01\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x65\x00\x00\x00\x5e\x00\x00\x00\xbf\x00\x00\x00\xc2\x00\x00\x00\xd4\x00\x00\x00\x5f\x00\x00\x00\x61\x00\x00\x00\x71\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xa1\x00\x00\x00\xa4\x00\x00\x00\xa8\x00\x00\x00\xad\x00\x00\x00\x13\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\x00\x00\xda\x03\x00\x00\xd9\x04\x00\x00\xd8\x05\x00\x00\xd7\x06\x00\x00\xd7\x07\x00\x00\xaa\x08\x00\x00\x7d\x09\x00\x00\x50\x0a\x00\x00\x23\x0b\x00\x00\xf6\x0b\x00\x00\xc9\x0c\x00\x00\x9c\x0d\x00\x00\x6f\x0e\x00\x00\x37\x0f\x00\x00\x36\x10\x00\x00\x35\x11\x00\x00\x34\x12\x00\x00\x33\x13\x00\x00\x33\x14\x00\x00\x06\x15\x00\x00\xd9\x15\x00\x00\xac\x16\x00\x00\x7f\x17\x00\x00\x52\x18\x00\x00\x25\x19\x00\x00\xf8\x19\x00\x00\xcb\x1a\x00\x00\x9e\x1b\x00\x00\x71\x1c\x00\x00\x44\x1d\x00\x00\x17\x1e\x00\x00\xea\x1e\x00\x00\xbd\x1f\x00\x00\x90\x20\x00\x00\x63\x21\x00\x00\x36\x22\x00\x00\x09\x23\x00\x00\xdc\x23\x00\x00\xaf\x24\x00\x00\x82\x25\x00\x00\x55\x26\x00\x00\x28\x27\x00\x00\xfb\x27\x00\x00\xce\x28\x00\x00\xa1\x29\x00\x00\x74\x2a\x00\x00\x47\x2b\x00\x00\x1a\x2c\x00\x00\xed\x2c\x00\x00\xc0\x2d\x00\x00\x93\x2e\x00\x00\x66\x2f\x00\x00\x39\x30\x00\x00\x35\x03\x00\x00\xb1\x03\x00\x00\x01\x31\x00\x00\x0b\x31\x00\x00\x34\x04\x00\x00\x44\x02\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\x73\x00\xff\xff\x19\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x29\x00\x16\x00\x16\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x2b\x00\x13\x00\x1a\x00\x09\x00\x2c\x00\x2e\x00\xff\xff\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x71\x00\x2c\x00\x74\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x31\x00\x2c\x00\x2f\x00\x2a\x00\x30\x00\xff\xff\x11\x00\x77\x00\x63\x00\x5c\x00\x4d\x00\x0b\x00\x4c\x00\x0d\x00\x6f\x00\x04\x00\x0e\x00\x16\x00\x4e\x00\x16\x00\x16\x00\x16\x00\x4a\x00\xff\xff\x4b\x00\x70\x00\x18\x00\x17\x00\xff\xff\x17\x00\x17\x00\x17\x00\xff\xff\x2c\x00\xff\xff\x2c\x00\x2c\x00\x0c\x00\x2c\x00\xff\xff\x16\x00\x0f\x00\x14\x00\x1a\x00\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x08\x00\x17\x00\x08\x00\xff\xff\x1c\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\xff\xff\x2c\x00\x2d\x00\x2c\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x38\x00\x22\x00\x39\x00\x28\x00\x3a\x00\x26\x00\xff\xff\x1d\x00\x20\x00\xff\xff\x16\x00\x3b\x00\x16\x00\x16\x00\x16\x00\x16\x00\x24\x00\x16\x00\x16\x00\x16\x00\x75\x00\xff\xff\x17\x00\xff\xff\x17\x00\x17\x00\x17\x00\xff\xff\x1f\x00\x35\x00\x37\x00\x00\x00\x16\x00\x16\x00\x36\x00\x34\x00\x33\x00\x00\x00\x16\x00\x00\x00\x00\x00\x1a\x00\x17\x00\x76\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x00\x00\x27\x00\x21\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x00\x00\x00\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x13\x00\x16\x00\x00\x00\x00\x00\x00\x00\x13\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x17\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x13\x00\x00\x00\x00\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x00\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\xff\xff\x10\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\xff\xff\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x73\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x73\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3d\x00\x00\x00\x64\x00\x64\x00\x07\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3e\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3f\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x40\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\xff\xff\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3d\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3e\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x3f\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x40\x00\x00\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\xff\xff\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x73\x00\x73\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x65\x00\x61\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x6d\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x69\x00\x01\x00\x42\x00\x43\x00\x44\x00\x67\x00\x46\x00\x61\x00\x48\x00\x6e\x00\x72\x00\x09\x00\x4c\x00\x0b\x00\x0c\x00\x0d\x00\x50\x00\x0a\x00\x52\x00\x53\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x6c\x00\x60\x00\x0a\x00\x20\x00\x70\x00\x22\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x22\x00\x0a\x00\x2b\x00\x20\x00\x2d\x00\x0a\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0a\x00\x65\x00\x3d\x00\x6c\x00\x3d\x00\x61\x00\x26\x00\x70\x00\x0a\x00\x01\x00\x6d\x00\x0a\x00\x09\x00\x7c\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x72\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\xd7\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x6e\x00\x3c\x00\x3d\x00\xff\xff\xa0\x00\x20\x00\x3d\x00\x3e\x00\x3a\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\xa0\x00\x01\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x69\x00\x67\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\xa0\x00\xff\xff\xff\xff\xff\xff\x27\x00\xa0\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\x00\x00\x78\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x01\x00\xff\xff\x22\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x00\x00\x5c\x00\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x5c\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x64\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\x13\x00\x14\x00\x15\x00\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x25\x00\x25\x00\xff\xff\xff\xff\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,120) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAcc (alex_action_5),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_2) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_2) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_2) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc (alex_action_5)),AlexAccPred (alex_action_2) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc (alex_action_5)),AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAcc (alex_action_5),AlexAccSkip,AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAcc (alex_action_36),AlexAcc (alex_action_36),AlexAcc (alex_action_37)] +{-# LINE 125 "compiler/cmm/CmmLex.x" #-} + +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_align + | CmmT_goto + | CmmT_if + | CmmT_call + | CmmT_jump + | CmmT_foreign + | CmmT_never + | CmmT_prim + | CmmT_reserve + | CmmT_return + | CmmT_returns + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_push + | CmmT_unwind + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_bits128 + | CmmT_bits256 + | CmmT_bits512 + | CmmT_float32 + | CmmT_float64 + | CmmT_gcptr + | CmmT_GlobalReg GlobalReg + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF + deriving (Show) + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do popLexState; lexToken + +special_char :: Action +special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span buf len = return (L span tok) + +global_regN :: (Int -> GlobalReg) -> Action +global_regN con span buf len + = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) + where buf' = stepOn buf + n = parseUnsignedInteger buf' (len-1) 10 octDecDigit + +global_reg :: GlobalReg -> Action +global_reg r span buf len = return (L span (CmmT_GlobalReg r)) + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "align", CmmT_align ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), + ( "reserve", CmmT_reserve ), + ( "return", CmmT_return ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "unwind", CmmT_unwind ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "bits128", CmmT_bits128 ), + ( "bits256", CmmT_bits256 ), + ( "bits512", CmmT_bits512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), +-- New forms + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "b128", CmmT_bits128 ), + ( "b256", CmmT_bits256 ), + ( "b512", CmmT_bits512 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code span buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState + pushLexState code + lexToken + +setFile :: Int -> Action +setFile code span buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState + pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> P a) -> P a +cmmlex cont = do + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) + +lexToken :: P (RealLocated CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 + setLastToken span 0 + return (L span CmmT_EOF) + AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,buf2) len t -> do + setInput inp2 + let span = mkRealSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (RealSrcLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (loc,s) + | atEnd s = Nothing + | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) + where c = currentChar s + b = fromIntegral $ ord $ c + loc' = advanceSrcLoc loc c + s' = stepOn s + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> P () +setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } () + + +line_prag,line_prag1,line_prag2 :: Int +line_prag = 1 +line_prag1 = 2 +line_prag2 = 3 +alex_action_2 = begin line_prag +alex_action_3 = setLine line_prag1 +alex_action_4 = setFile line_prag2 +alex_action_5 = pop +alex_action_7 = special_char +alex_action_8 = kw CmmT_DotDot +alex_action_9 = kw CmmT_DoubleColon +alex_action_10 = kw CmmT_Shr +alex_action_11 = kw CmmT_Shl +alex_action_12 = kw CmmT_Ge +alex_action_13 = kw CmmT_Le +alex_action_14 = kw CmmT_Eq +alex_action_15 = kw CmmT_Ne +alex_action_16 = kw CmmT_BoolAnd +alex_action_17 = kw CmmT_BoolOr +alex_action_18 = global_regN (\n -> VanillaReg n VGcPtr) +alex_action_19 = global_regN (\n -> VanillaReg n VNonGcPtr) +alex_action_20 = global_regN FloatReg +alex_action_21 = global_regN DoubleReg +alex_action_22 = global_regN LongReg +alex_action_23 = global_reg Sp +alex_action_24 = global_reg SpLim +alex_action_25 = global_reg Hp +alex_action_26 = global_reg HpLim +alex_action_27 = global_reg CCCS +alex_action_28 = global_reg CurrentTSO +alex_action_29 = global_reg CurrentNursery +alex_action_30 = global_reg HpAlloc +alex_action_31 = global_reg BaseReg +alex_action_32 = name +alex_action_33 = tok_octal +alex_action_34 = tok_decimal +alex_action_35 = tok_hexadecimal +alex_action_36 = strtoken tok_float +alex_action_37 = strtoken tok_string +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 6 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 21 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif +{-# LINE 51 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetByte input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input'' len, _) -> + + + + AlexSkip input'' len + + (AlexLastAcc k input''' len, _) -> + + + + AlexToken input''' len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) + + check_accs (AlexAccPred a predx rest) + | predx user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + | otherwise + = check_accs rest + + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap f AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap f (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAccNone + | AlexAcc a + | AlexAccSkip + + | AlexAccPred a (AlexAccPred user) (AlexAcc a user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc a user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/compiler/cmm/CmmLex.x.source b/compiler/cmm/CmmLex.x.source new file mode 100644 index 00000000..d5a80674 --- /dev/null +++ b/compiler/cmm/CmmLex.x.source @@ -0,0 +1,363 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2004-2006 +-- +-- Lexer for concrete Cmm. We try to stay close to the C-- spec, but there +-- are a few minor differences: +-- +-- * extra keywords for our macros, and float32/float64 types +-- * global registers (Sp,Hp, etc.) +-- +----------------------------------------------------------------------------- + +{ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -Wwarn -w #-} +-- The above -Wwarn supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module CmmLex ( + CmmToken(..), cmmlex, + ) where + +import CmmExpr + +import Lexer +import SrcLoc +import UniqFM +import StringBuffer +import FastString +import Ctype +import Util +--import TRACE + +import Data.Word +import Data.Char +} + +$whitechar = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space +$white_no_nl = $whitechar # \n + +$ascdigit = 0-9 +$unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. +$digit = [$ascdigit $unidigit] +$octit = 0-7 +$hexit = [$digit A-F a-f] + +$unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. +$asclarge = [A-Z \xc0-\xd6 \xd8-\xde] +$large = [$asclarge $unilarge] + +$unismall = \x04 -- Trick Alex into handling Unicode. See alexGetChar. +$ascsmall = [a-z \xdf-\xf6 \xf8-\xff] +$small = [$ascsmall $unismall \_] + +$namebegin = [$large $small \. \$ \@] +$namechar = [$namebegin $digit] + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+]? @decimal + +@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent + +@escape = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) +@strchar = ($printable # [\"\\]) | @escape + +cmm :- + +$white_no_nl+ ; +^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output + +^\# (line)? { begin line_prag } + +-- single-line line pragmas, of the form +-- # "" \n + $digit+ { setLine line_prag1 } + \" [^\"]* \" { setFile line_prag2 } + .* { pop } + +<0> { + \n ; + + [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } + + ".." { kw CmmT_DotDot } + "::" { kw CmmT_DoubleColon } + ">>" { kw CmmT_Shr } + "<<" { kw CmmT_Shl } + ">=" { kw CmmT_Ge } + "<=" { kw CmmT_Le } + "==" { kw CmmT_Eq } + "!=" { kw CmmT_Ne } + "&&" { kw CmmT_BoolAnd } + "||" { kw CmmT_BoolOr } + + P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } + R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } + F@decimal { global_regN FloatReg } + D@decimal { global_regN DoubleReg } + L@decimal { global_regN LongReg } + Sp { global_reg Sp } + SpLim { global_reg SpLim } + Hp { global_reg Hp } + HpLim { global_reg HpLim } + CCCS { global_reg CCCS } + CurrentTSO { global_reg CurrentTSO } + CurrentNursery { global_reg CurrentNursery } + HpAlloc { global_reg HpAlloc } + BaseReg { global_reg BaseReg } + + $namebegin $namechar* { name } + + 0 @octal { tok_octal } + @decimal { tok_decimal } + 0[xX] @hexadecimal { tok_hexadecimal } + @floating_point { strtoken tok_float } + + \" @strchar* \" { strtoken tok_string } +} + +{ +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_align + | CmmT_goto + | CmmT_if + | CmmT_call + | CmmT_jump + | CmmT_foreign + | CmmT_never + | CmmT_prim + | CmmT_reserve + | CmmT_return + | CmmT_returns + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_push + | CmmT_unwind + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_bits128 + | CmmT_bits256 + | CmmT_bits512 + | CmmT_float32 + | CmmT_float64 + | CmmT_gcptr + | CmmT_GlobalReg GlobalReg + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF + deriving (Show) + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do popLexState; lexToken + +special_char :: Action +special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span buf len = return (L span tok) + +global_regN :: (Int -> GlobalReg) -> Action +global_regN con span buf len + = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) + where buf' = stepOn buf + n = parseUnsignedInteger buf' (len-1) 10 octDecDigit + +global_reg :: GlobalReg -> Action +global_reg r span buf len = return (L span (CmmT_GlobalReg r)) + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "align", CmmT_align ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), + ( "reserve", CmmT_reserve ), + ( "return", CmmT_return ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "unwind", CmmT_unwind ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "bits128", CmmT_bits128 ), + ( "bits256", CmmT_bits256 ), + ( "bits512", CmmT_bits512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), +-- New forms + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "b128", CmmT_bits128 ), + ( "b256", CmmT_bits256 ), + ( "b512", CmmT_bits512 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code span buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState + pushLexState code + lexToken + +setFile :: Int -> Action +setFile code span buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState + pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> P a) -> P a +cmmlex cont = do + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) + +lexToken :: P (RealLocated CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 + setLastToken span 0 + return (L span CmmT_EOF) + AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,buf2) len t -> do + setInput inp2 + let span = mkRealSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (RealSrcLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (loc,s) + | atEnd s = Nothing + | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) + where c = currentChar s + b = fromIntegral $ ord $ c + loc' = advanceSrcLoc loc c + s' = stepOn s + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> P () +setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } () +} diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs new file mode 100644 index 00000000..e5938150 --- /dev/null +++ b/compiler/cmm/CmmLint.hs @@ -0,0 +1,263 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2011 +-- +-- CmmLint: checking the correctness of Cmm statements and expressions +-- +----------------------------------------------------------------------------- +{-# LANGUAGE GADTs, CPP #-} +module CmmLint ( + cmmLint, cmmLintGraph + ) where + +import Hoopl +import Cmm +import CmmUtils +import CmmLive +import PprCmm () +import BlockId +import FastString +import Outputable +import DynFlags + +import Data.Maybe +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +-- Things to check: +-- - invariant on CmmBlock in CmmExpr (see comment there) +-- - check for branches to blocks that don't exist +-- - check types + +-- ----------------------------------------------------------------------------- +-- Exported entry points: + +cmmLint :: (Outputable d, Outputable h) + => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops + +cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc +cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g + +runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint dflags l p = + case unCL (l p) dflags of + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (ppr p)]) + Right _ -> Nothing + +lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl _ g) + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g +lintCmmDecl _ (CmmData {}) + = return () + + +lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () +lintCmmGraph dflags g = + cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) + where + blocks = toBlockList g + labels = setFromList (map entryLabel blocks) + + +lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint () +lintCmmBlock labels block + = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do + let (_, middle, last) = blockSplit block + mapM_ lintCmmMiddle (blockToList middle) + lintCmmLast labels last + +-- ----------------------------------------------------------------------------- +-- lintCmmExpr + +-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking +-- byte/word mismatches. + +lintCmmExpr :: CmmExpr -> CmmLint CmmType +lintCmmExpr (CmmLoad expr rep) = do + _ <- lintCmmExpr expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ + -- cmmCheckWordAddress expr + return rep +lintCmmExpr expr@(CmmMachOp op args) = do + dflags <- getDynFlags + tys <- mapM lintCmmExpr args + if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op + then cmmCheckMachOp op args tys + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) +lintCmmExpr (CmmRegOff reg offset) + = do dflags <- getDynFlags + let rep = typeWidth (cmmRegType dflags reg) + lintCmmExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) +lintCmmExpr expr = + do dflags <- getDynFlags + return (cmmExprType dflags expr) + +-- Check for some common byte/word mismatches (eg. Sp + 1) +cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp op [reg, lit] tys +cmmCheckMachOp op _ tys + = do dflags <- getDynFlags + return (machOpResultType dflags op tys) + +{- +isOffsetOp :: MachOp -> Bool +isOffsetOp (MO_Add _) = True +isOffsetOp (MO_Sub _) = True +isOffsetOp _ = False + +-- This expression should be an address from which a word can be loaded: +-- check for funny-looking sub-word offsets. +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 + = cmmLintDubiousWordOffset e +_cmmCheckWordAddress _ + = return () + +-- No warnings for unaligned arithmetic with the node register, +-- which is used to extract fields from tagged constructor closures. +notNodeReg :: CmmExpr -> Bool +notNodeReg (CmmReg reg) | reg == nodeReg = False +notNodeReg _ = True +-} + +lintCmmMiddle :: CmmNode O O -> CmmLint () +lintCmmMiddle node = case node of + CmmComment _ -> return () + CmmTick _ -> return () + CmmUnwind{} -> return () + + CmmAssign reg expr -> do + dflags <- getDynFlags + erep <- lintCmmExpr expr + let reg_ty = cmmRegType dflags reg + if (erep `cmmEqType_ignoring_ptrhood` reg_ty) + then return () + else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + + CmmStore l r -> do + _ <- lintCmmExpr l + _ <- lintCmmExpr r + return () + + CmmUnsafeForeignCall target _formals actuals -> do + lintTarget target + mapM_ lintCmmExpr actuals + + +lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint () +lintCmmLast labels node = case node of + CmmBranch id -> checkTarget id + + CmmCondBranch e t f -> do + dflags <- getDynFlags + mapM_ checkTarget [t,f] + _ <- lintCmmExpr e + checkCond dflags e + + CmmSwitch e branches -> do + dflags <- getDynFlags + mapM_ checkTarget $ catMaybes branches + erep <- lintCmmExpr e + if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) + then return () + else cmmLintErr (text "switch scrutinee is not a word: " <> + ppr e <> text " :: " <> ppr erep) + + CmmCall { cml_target = target, cml_cont = cont } -> do + _ <- lintCmmExpr target + maybe (return ()) checkTarget cont + + CmmForeignCall tgt _ args succ _ _ _ -> do + lintTarget tgt + mapM_ lintCmmExpr args + checkTarget succ + where + checkTarget id + | setMember id labels = return () + | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) + + +lintTarget :: ForeignTarget -> CmmLint () +lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () +lintTarget (PrimTarget {}) = return () + + +checkCond :: DynFlags -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values +checkCond _ expr + = cmmLintErr (hang (text "expression is not a conditional:") 2 + (ppr expr)) + +-- ----------------------------------------------------------------------------- +-- CmmLint monad + +-- just a basic error monad: + +newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } + +instance Functor CmmLint where + fmap = liftM + +instance Applicative CmmLint where + pure = return + (<*>) = ap + +instance Monad CmmLint where + CmmLint m >>= k = CmmLint $ \dflags -> + case m dflags of + Left e -> Left e + Right a -> unCL (k a) dflags + return a = CmmLint (\_ -> Right a) + +instance HasDynFlags CmmLint where + getDynFlags = CmmLint (\dflags -> Right dflags) + +cmmLintErr :: SDoc -> CmmLint a +cmmLintErr msg = CmmLint (\_ -> Left msg) + +addLintInfo :: SDoc -> CmmLint a -> CmmLint a +addLintInfo info thing = CmmLint $ \dflags -> + case unCL thing dflags of + Left err -> Left (hang info 2 err) + Right a -> Right a + +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep opExpectsRep + = cmmLintErr (text "in MachOp application: " $$ + nest 2 (ppr expr) $$ + (text "op is expecting: " <+> ppr opExpectsRep) $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a +cmmLintAssignErr stmt e_ty r_ty + = cmmLintErr (text "in assignment: " $$ + nest 2 (vcat [ppr stmt, + text "Reg ty:" <+> ppr r_ty, + text "Rhs ty:" <+> ppr e_ty])) + + +{- +cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a +cmmLintDubiousWordOffset expr + = cmmLintErr (text "offset is not a multiple of words: " $$ + nest 2 (ppr expr)) +-} + diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs new file mode 100644 index 00000000..dfacd139 --- /dev/null +++ b/compiler/cmm/CmmLive.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- See Note [Deprecations in Hoopl] in Hoopl module +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +module CmmLive + ( CmmLocalLive + , CmmGlobalLive + , cmmLocalLiveness + , cmmGlobalLiveness + , liveLattice + , noLiveOnEntry, xferLive, gen, kill, gen_kill + ) +where + +import DynFlags +import BlockId +import Cmm +import CmmUtils +import PprCmmExpr () + +import Hoopl +import Maybes +import Outputable + +----------------------------------------------------------------------------- +-- Calculating what variables are live on entry to a basic block +----------------------------------------------------------------------------- + +-- | The variables live on entry to a block +type CmmLive r = RegSet r +type CmmLocalLive = CmmLive LocalReg +type CmmGlobalLive = CmmLive GlobalReg + +-- | The dataflow lattice +liveLattice :: Ord r => DataflowLattice (CmmLive r) +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} +liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add + where add _ (OldFact old) (NewFact new) = + (changeIf $ sizeRegSet join > sizeRegSet old, join) + where !join = plusRegSet old new + + +-- | A mapping from block labels to the variables live on entry +type BlockEntryLiveness r = BlockEnv (CmmLive r) + +----------------------------------------------------------------------------- +-- | Calculated liveness info for a CmmGraph +----------------------------------------------------------------------------- + +cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness dflags graph = + check $ dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) + where entry = g_entry graph + check facts = noLiveOnEntry entry + (expectJust "check" $ mapLookup entry facts) facts + +cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness dflags graph = + dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) + +-- | On entry to the procedure, there had better not be any LocalReg's live-in. +noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a +noLiveOnEntry bid in_fact x = + if nullRegSet in_fact then x + else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) + +-- | The transfer equations use the traditional 'gen' and 'kill' +-- notations, which should be familiar from the Dragon Book. +gen :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE gen #-} +gen dflags a live = foldRegsUsed dflags extendRegSet live a + +kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE kill #-} +kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a + +gen_kill :: (DefinerOfRegs r a, UserOfRegs r a) + => DynFlags -> a -> CmmLive r -> CmmLive r +{-# INLINE gen_kill #-} +gen_kill dflags a = gen dflags a . kill dflags a + +-- | The transfer function +xferLive :: forall r . ( UserOfRegs r (CmmNode O O) + , DefinerOfRegs r (CmmNode O O) + , UserOfRegs r (CmmNode O C) + , DefinerOfRegs r (CmmNode O C)) + => DynFlags -> BwdTransfer CmmNode (CmmLive r) +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-} +xferLive dflags = mkBTransfer3 fst mid lst + where fst _ f = f + mid :: CmmNode O O -> CmmLive r -> CmmLive r + mid n f = gen_kill dflags n f + lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r + lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs new file mode 100644 index 00000000..e9215d50 --- /dev/null +++ b/compiler/cmm/CmmMachOp.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE CPP #-} + +module CmmMachOp + ( MachOp(..) + , pprMachOp, isCommutableMachOp, isAssociativeMachOp + , isComparisonMachOp, maybeIntComparison, machOpResultType + , machOpArgReps, maybeInvertComparison + + -- MachOp builders + , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot + , mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord + , mo_u_32ToWord, mo_s_32ToWord + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + + -- CallishMachOp + , CallishMachOp(..), callishMachOpHints + , pprCallishMachOp + + -- Atomic read-modify-write + , AtomicMachOp(..) + ) +where + +#include "HsVersions.h" + +import CmmType +import Outputable +import DynFlags + +----------------------------------------------------------------------------- +-- MachOp +----------------------------------------------------------------------------- + +{- | +Machine-level primops; ones which we can reasonably delegate to the +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. +-} + +data MachOp + -- Integer operations (insensitive to signed/unsigned) + = MO_Add Width + | MO_Sub Width + | MO_Eq Width + | MO_Ne Width + | MO_Mul Width -- low word of multiply + + -- Signed multiply/divide + | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows + | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) + | MO_S_Rem Width -- signed % (same semantics as IntRemOp) + | MO_S_Neg Width -- unary - + + -- Unsigned multiply/divide + | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows + | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) + | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) + + -- Signed comparisons + | MO_S_Ge Width + | MO_S_Le Width + | MO_S_Gt Width + | MO_S_Lt Width + + -- Unsigned comparisons + | MO_U_Ge Width + | MO_U_Le Width + | MO_U_Gt Width + | MO_U_Lt Width + + -- Floating point arithmetic + | MO_F_Add Width + | MO_F_Sub Width + | MO_F_Neg Width -- unary - + | MO_F_Mul Width + | MO_F_Quot Width + + -- Floating point comparison + | MO_F_Eq Width + | MO_F_Ne Width + | MO_F_Ge Width + | MO_F_Le Width + | MO_F_Gt Width + | MO_F_Lt Width + + -- Bitwise operations. Not all of these may be supported + -- at all sizes, and only integral Widths are valid. + | MO_And Width + | MO_Or Width + | MO_Xor Width + | MO_Not Width + | MO_Shl Width + | MO_U_Shr Width -- unsigned shift right + | MO_S_Shr Width -- signed shift right + + -- Conversions. Some of these will be NOPs. + -- Floating-point conversions use the signed variant. + | MO_SF_Conv Width Width -- Signed int -> Float + | MO_FS_Conv Width Width -- Float -> Signed int + | MO_SS_Conv Width Width -- Signed int -> Signed int + | MO_UU_Conv Width Width -- unsigned int -> unsigned int + | MO_FF_Conv Width Width -- Float -> Float + + -- Vector element insertion and extraction operations + | MO_V_Insert Length Width -- Insert scalar into vector + | MO_V_Extract Length Width -- Extract scalar from vector + + -- Integer vector operations + | MO_V_Add Length Width + | MO_V_Sub Length Width + | MO_V_Mul Length Width + + -- Signed vector multiply/divide + | MO_VS_Quot Length Width + | MO_VS_Rem Length Width + | MO_VS_Neg Length Width + + -- Unsigned vector multiply/divide + | MO_VU_Quot Length Width + | MO_VU_Rem Length Width + + -- Floting point vector element insertion and extraction operations + | MO_VF_Insert Length Width -- Insert scalar into vector + | MO_VF_Extract Length Width -- Extract scalar from vector + + -- Floating point vector operations + | MO_VF_Add Length Width + | MO_VF_Sub Length Width + | MO_VF_Neg Length Width -- unary - + | MO_VF_Mul Length Width + | MO_VF_Quot Length Width + deriving (Eq, Show) + +pprMachOp :: MachOp -> SDoc +pprMachOp mo = text (show mo) + + + +-- ----------------------------------------------------------------------------- +-- Some common MachReps + +-- A 'wordRep' is a machine word on the target architecture +-- Specifically, it is the size of an Int#, Word#, Addr# +-- and the unit of allocation on the stack and the heap +-- Any pointer is also guaranteed to be a wordRep. + +mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + :: DynFlags -> MachOp + +mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_32To8, mo_32To16 + :: MachOp + +mo_wordAdd dflags = MO_Add (wordWidth dflags) +mo_wordSub dflags = MO_Sub (wordWidth dflags) +mo_wordEq dflags = MO_Eq (wordWidth dflags) +mo_wordNe dflags = MO_Ne (wordWidth dflags) +mo_wordMul dflags = MO_Mul (wordWidth dflags) +mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) +mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) +mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) +mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) +mo_wordURem dflags = MO_U_Rem (wordWidth dflags) + +mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) +mo_wordSLe dflags = MO_S_Le (wordWidth dflags) +mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) +mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) + +mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) +mo_wordULe dflags = MO_U_Le (wordWidth dflags) +mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) +mo_wordULt dflags = MO_U_Lt (wordWidth dflags) + +mo_wordAnd dflags = MO_And (wordWidth dflags) +mo_wordOr dflags = MO_Or (wordWidth dflags) +mo_wordXor dflags = MO_Xor (wordWidth dflags) +mo_wordNot dflags = MO_Not (wordWidth dflags) +mo_wordShl dflags = MO_Shl (wordWidth dflags) +mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) +mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) +mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) +mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) +mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) +mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) +mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) + +mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 +mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 +mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 +mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 + + +-- ---------------------------------------------------------------------------- +-- isCommutableMachOp + +{- | +Returns 'True' if the MachOp has commutable arguments. This is used +in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = + case mop of + MO_Add _ -> True + MO_Eq _ -> True + MO_Ne _ -> True + MO_Mul _ -> True + MO_S_MulMayOflo _ -> True + MO_U_MulMayOflo _ -> True + MO_And _ -> True + MO_Or _ -> True + MO_Xor _ -> True + MO_F_Add _ -> True + MO_F_Mul _ -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isAssociativeMachOp + +{- | +Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) +This is used in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isAssociativeMachOp :: MachOp -> Bool +isAssociativeMachOp mop = + case mop of + MO_Add {} -> True -- NB: does not include + MO_Mul {} -> True -- floatint point! + MO_And {} -> True + MO_Or {} -> True + MO_Xor {} -> True + _other -> False + + +-- ---------------------------------------------------------------------------- +-- isComparisonMachOp + +{- | +Returns 'True' if the MachOp is a comparison. + +If in doubt, return False. This generates worse code on the +native routes, but is otherwise harmless. +-} +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = + case mop of + MO_Eq _ -> True + MO_Ne _ -> True + MO_S_Ge _ -> True + MO_S_Le _ -> True + MO_S_Gt _ -> True + MO_S_Lt _ -> True + MO_U_Ge _ -> True + MO_U_Le _ -> True + MO_U_Gt _ -> True + MO_U_Lt _ -> True + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +{- | +Returns @Just w@ if the operation is an integer comparison with width +@w@, or @Nothing@ otherwise. +-} +maybeIntComparison :: MachOp -> Maybe Width +maybeIntComparison mop = + case mop of + MO_Eq w -> Just w + MO_Ne w -> Just w + MO_S_Ge w -> Just w + MO_S_Le w -> Just w + MO_S_Gt w -> Just w + MO_S_Lt w -> Just w + MO_U_Ge w -> Just w + MO_U_Le w -> Just w + MO_U_Gt w -> Just w + MO_U_Lt w -> Just w + _ -> Nothing + +-- ----------------------------------------------------------------------------- +-- Inverting conditions + +-- Sometimes it's useful to be able to invert the sense of a +-- condition. Not all conditional tests are invertible: in +-- particular, floating point conditionals cannot be inverted, because +-- there exist floating-point values which return False for both senses +-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). + +maybeInvertComparison :: MachOp -> Maybe MachOp +maybeInvertComparison op + = case op of -- None of these Just cases include floating point + MO_Eq r -> Just (MO_Ne r) + MO_Ne r -> Just (MO_Eq r) + MO_U_Lt r -> Just (MO_U_Ge r) + MO_U_Gt r -> Just (MO_U_Le r) + MO_U_Le r -> Just (MO_U_Gt r) + MO_U_Ge r -> Just (MO_U_Lt r) + MO_S_Lt r -> Just (MO_S_Ge r) + MO_S_Gt r -> Just (MO_S_Le r) + MO_S_Le r -> Just (MO_S_Gt r) + MO_S_Ge r -> Just (MO_S_Lt r) + _other -> Nothing + +-- ---------------------------------------------------------------------------- +-- machOpResultType + +{- | +Returns the MachRep of the result of a MachOp. +-} +machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType +machOpResultType dflags mop tys = + case mop of + MO_Add {} -> ty1 -- Preserve GC-ptr-hood + MO_Sub {} -> ty1 -- of first arg + MO_Mul r -> cmmBits r + MO_S_MulMayOflo r -> cmmBits r + MO_S_Quot r -> cmmBits r + MO_S_Rem r -> cmmBits r + MO_S_Neg r -> cmmBits r + MO_U_MulMayOflo r -> cmmBits r + MO_U_Quot r -> cmmBits r + MO_U_Rem r -> cmmBits r + + MO_Eq {} -> comparisonResultRep dflags + MO_Ne {} -> comparisonResultRep dflags + MO_S_Ge {} -> comparisonResultRep dflags + MO_S_Le {} -> comparisonResultRep dflags + MO_S_Gt {} -> comparisonResultRep dflags + MO_S_Lt {} -> comparisonResultRep dflags + + MO_U_Ge {} -> comparisonResultRep dflags + MO_U_Le {} -> comparisonResultRep dflags + MO_U_Gt {} -> comparisonResultRep dflags + MO_U_Lt {} -> comparisonResultRep dflags + + MO_F_Add r -> cmmFloat r + MO_F_Sub r -> cmmFloat r + MO_F_Mul r -> cmmFloat r + MO_F_Quot r -> cmmFloat r + MO_F_Neg r -> cmmFloat r + MO_F_Eq {} -> comparisonResultRep dflags + MO_F_Ne {} -> comparisonResultRep dflags + MO_F_Ge {} -> comparisonResultRep dflags + MO_F_Le {} -> comparisonResultRep dflags + MO_F_Gt {} -> comparisonResultRep dflags + MO_F_Lt {} -> comparisonResultRep dflags + + MO_And {} -> ty1 -- Used for pointer masking + MO_Or {} -> ty1 + MO_Xor {} -> ty1 + MO_Not r -> cmmBits r + MO_Shl r -> cmmBits r + MO_U_Shr r -> cmmBits r + MO_S_Shr r -> cmmBits r + + MO_SS_Conv _ to -> cmmBits to + MO_UU_Conv _ to -> cmmBits to + MO_FS_Conv _ to -> cmmBits to + MO_SF_Conv _ to -> cmmFloat to + MO_FF_Conv _ to -> cmmFloat to + + MO_V_Insert l w -> cmmVec l (cmmBits w) + MO_V_Extract _ w -> cmmBits w + + MO_V_Add l w -> cmmVec l (cmmBits w) + MO_V_Sub l w -> cmmVec l (cmmBits w) + MO_V_Mul l w -> cmmVec l (cmmBits w) + + MO_VS_Quot l w -> cmmVec l (cmmBits w) + MO_VS_Rem l w -> cmmVec l (cmmBits w) + MO_VS_Neg l w -> cmmVec l (cmmBits w) + + MO_VU_Quot l w -> cmmVec l (cmmBits w) + MO_VU_Rem l w -> cmmVec l (cmmBits w) + + MO_VF_Insert l w -> cmmVec l (cmmFloat w) + MO_VF_Extract _ w -> cmmFloat w + + MO_VF_Add l w -> cmmVec l (cmmFloat w) + MO_VF_Sub l w -> cmmVec l (cmmFloat w) + MO_VF_Mul l w -> cmmVec l (cmmFloat w) + MO_VF_Quot l w -> cmmVec l (cmmFloat w) + MO_VF_Neg l w -> cmmVec l (cmmFloat w) + where + (ty1:_) = tys + +comparisonResultRep :: DynFlags -> CmmType +comparisonResultRep = bWord -- is it? + + +-- ----------------------------------------------------------------------------- +-- machOpArgReps + +-- | This function is used for debugging only: we can check whether an +-- application of a MachOp is "type-correct" by checking that the MachReps of +-- its arguments are the same as the MachOp expects. This is used when +-- linting a CmmExpr. + +machOpArgReps :: DynFlags -> MachOp -> [Width] +machOpArgReps dflags op = + case op of + MO_Add r -> [r,r] + MO_Sub r -> [r,r] + MO_Eq r -> [r,r] + MO_Ne r -> [r,r] + MO_Mul r -> [r,r] + MO_S_MulMayOflo r -> [r,r] + MO_S_Quot r -> [r,r] + MO_S_Rem r -> [r,r] + MO_S_Neg r -> [r] + MO_U_MulMayOflo r -> [r,r] + MO_U_Quot r -> [r,r] + MO_U_Rem r -> [r,r] + + MO_S_Ge r -> [r,r] + MO_S_Le r -> [r,r] + MO_S_Gt r -> [r,r] + MO_S_Lt r -> [r,r] + + MO_U_Ge r -> [r,r] + MO_U_Le r -> [r,r] + MO_U_Gt r -> [r,r] + MO_U_Lt r -> [r,r] + + MO_F_Add r -> [r,r] + MO_F_Sub r -> [r,r] + MO_F_Mul r -> [r,r] + MO_F_Quot r -> [r,r] + MO_F_Neg r -> [r] + MO_F_Eq r -> [r,r] + MO_F_Ne r -> [r,r] + MO_F_Ge r -> [r,r] + MO_F_Le r -> [r,r] + MO_F_Gt r -> [r,r] + MO_F_Lt r -> [r,r] + + MO_And r -> [r,r] + MO_Or r -> [r,r] + MO_Xor r -> [r,r] + MO_Not r -> [r] + MO_Shl r -> [r, wordWidth dflags] + MO_U_Shr r -> [r, wordWidth dflags] + MO_S_Shr r -> [r, wordWidth dflags] + + MO_SS_Conv from _ -> [from] + MO_UU_Conv from _ -> [from] + MO_SF_Conv from _ -> [from] + MO_FS_Conv from _ -> [from] + MO_FF_Conv from _ -> [from] + + MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags] + MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags] + + MO_V_Add _ r -> [r,r] + MO_V_Sub _ r -> [r,r] + MO_V_Mul _ r -> [r,r] + + MO_VS_Quot _ r -> [r,r] + MO_VS_Rem _ r -> [r,r] + MO_VS_Neg _ r -> [r] + + MO_VU_Quot _ r -> [r,r] + MO_VU_Rem _ r -> [r,r] + + MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags] + MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] + + MO_VF_Add _ r -> [r,r] + MO_VF_Sub _ r -> [r,r] + MO_VF_Mul _ r -> [r,r] + MO_VF_Quot _ r -> [r,r] + MO_VF_Neg _ r -> [r] + +----------------------------------------------------------------------------- +-- CallishMachOp +----------------------------------------------------------------------------- + +-- CallishMachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Log + | MO_F64_Exp + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Log + | MO_F32_Exp + | MO_F32_Sqrt + + | MO_UF_Conv Width + + | MO_S_QuotRem Width + | MO_U_QuotRem Width + | MO_U_QuotRem2 Width + | MO_Add2 Width + | MO_AddIntC Width + | MO_SubIntC Width + | MO_U_Mul2 Width + + | MO_WriteBarrier + | MO_Touch -- Keep variables live (when using interior pointers) + + -- Prefetch + | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not + -- program behavior. + -- the Int can be 0-3. Needs to be known at compile time + -- to interact with code generation correctly. + -- TODO: add support for prefetch WRITES, + -- currently only exposes prefetch reads, which + -- would the majority of use cases in ghc anyways + + + -- Note that these three MachOps all take 1 extra parameter than the + -- standard C lib versions. The extra (last) parameter contains + -- alignment of the pointers. Used for optimisation in backends. + | MO_Memcpy + | MO_Memset + | MO_Memmove + + | MO_PopCnt Width + | MO_Clz Width + | MO_Ctz Width + + | MO_BSwap Width + + -- Atomic read-modify-write. + | MO_AtomicRMW Width AtomicMachOp + | MO_AtomicRead Width + | MO_AtomicWrite Width + | MO_Cmpxchg Width + deriving (Eq, Show) + +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + +callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) +callishMachOpHints op = case op of + MO_Memcpy -> ([], [AddrHint,AddrHint,NoHint,NoHint]) + MO_Memset -> ([], [AddrHint,NoHint,NoHint,NoHint]) + MO_Memmove -> ([], [AddrHint,AddrHint,NoHint,NoHint]) + _ -> ([],[]) + -- empty lists indicate NoHint diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs new file mode 100644 index 00000000..0f26d377 --- /dev/null +++ b/compiler/cmm/CmmNode.hs @@ -0,0 +1,687 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- CmmNode type for representation using Hoopl graphs. + +module CmmNode ( + CmmNode(..), CmmFormal, CmmActual, CmmTickish, + UpdFrameOffset, Convention(..), + ForeignConvention(..), ForeignTarget(..), foreignTargetHints, + CmmReturnInfo(..), + mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, + mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, + + -- * Tick scopes + CmmTickScope(..), isTickSubScope, combineTickScopes, + ) where + +import CodeGen.Platform +import CmmExpr +import DynFlags +import FastString +import ForeignCall +import Outputable +import SMRep +import CoreSyn (Tickish) +import qualified Unique as U + +import Compiler.Hoopl +import Data.Maybe +import Data.List (tails,sort) +import Prelude hiding (succ) + + +------------------------ +-- CmmNode + +#define ULabel {-# UNPACK #-} !Label + +data CmmNode e x where + CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O + + CmmComment :: FastString -> CmmNode O O + + -- Tick annotation, covering Cmm code in our tick scope. We only + -- expect non-code @Tickish@ at this point (e.g. @SourceNote@). + -- See Note [CmmTick scoping details] + CmmTick :: !CmmTickish -> CmmNode O O + + -- Unwind pseudo-instruction, encoding stack unwinding + -- instructions for a debugger. This describes how to reconstruct + -- the "old" value of a register if we want to navigate the stack + -- up one frame. Having unwind information for @Sp@ will allow the + -- debugger to "walk" the stack. + CmmUnwind :: !GlobalReg -> !CmmExpr -> CmmNode O O + + CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O + -- Assign to register + + CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. + + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments + CmmNode O O + -- Semantics: clobbers any GlobalRegs for which callerSaves r == True + -- See Note [Unsafe foreign calls clobber caller-save registers] + -- + -- Invariant: the arguments and the ForeignTarget must not + -- mention any registers for which CodeGen.Platform.callerSaves + -- is True. See Note [Register Parameter Passing]. + + CmmBranch :: ULabel -> CmmNode O C + -- Goto another block in the same procedure + + CmmCondBranch :: { -- conditional branch + cml_pred :: CmmExpr, + cml_true, cml_false :: ULabel + } -> CmmNode O C + + CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch + -- The scrutinee is zero-based; + -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when there's a Nothing + + CmmCall :: { -- A native call or tail call + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! + + cml_cont :: Maybe Label, + -- Label of continuation (Nothing for return or tail call) + -- + -- Note [Continuation BlockId]: these BlockIds are called + -- Continuation BlockIds, and are the only BlockIds that can + -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or + -- (CmmStackSlot (Young b) _). + + cml_args_regs :: [GlobalReg], + -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed + -- to the call. This is essential information for the + -- native code generator's register allocator; without + -- knowing which GlobalRegs are live it has to assume that + -- they are all live. This list should only include + -- GlobalRegs that are mapped to real machine registers on + -- the target platform. + + cml_args :: ByteOff, + -- Byte offset, from the *old* end of the Area associated with + -- the Label (if cml_cont = Nothing, then Old area), of + -- youngest outgoing arg. Set the stack pointer to this before + -- transferring control. + -- (NB: an update frame might also have been stored in the Old + -- area, but it'll be in an older part than the args.) + + cml_ret_args :: ByteOff, + -- For calls *only*, the byte offset for youngest returned value + -- This is really needed at the *return* point rather than here + -- at the call, but in practice it's convenient to record it here. + + cml_ret_off :: ByteOff + -- For calls *only*, the byte offset of the base of the frame that + -- must be described by the info table for the return point. + -- The older words are an update frames, which have their own + -- info-table and layout information + + -- From a liveness point of view, the stack words older than + -- cml_ret_off are treated as live, even if the sequel of + -- the call goes into a loop. + } -> CmmNode O C + + CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] + -- Always the last node of a block + tgt :: ForeignTarget, -- call target and convention + res :: [CmmFormal], -- zero or more results + args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] + succ :: ULabel, -- Label of continuation + ret_args :: ByteOff, -- same as cml_ret_args + ret_off :: ByteOff, -- same as cml_ret_off + intrbl:: Bool -- whether or not the call is interruptible + } -> CmmNode O C + +{- Note [Foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~ +A CmmUnsafeForeignCall is used for *unsafe* foreign calls; +a CmmForeignCall call is used for *safe* foreign calls. + +Unsafe ones are mostly easy: think of them as a "fat machine +instruction". In particular, they do *not* kill all live registers, +just the registers they return to (there was a bit of code in GHC that +conservatively assumed otherwise.) However, see [Register parameter passing]. + +Safe ones are trickier. A safe foreign call + r = f(x) +ultimately expands to + push "return address" -- Never used to return to; + -- just points an info table + save registers into TSO + call suspendThread + r = f(x) -- Make the call + call resumeThread + restore registers + pop "return address" +We cannot "lower" a safe foreign call to this sequence of Cmms, because +after we've saved Sp all the Cmm optimiser's assumptions are broken. + +Note that a safe foreign call needs an info table. + +So Safe Foreign Calls must remain as last nodes until the stack is +made manifest in CmmLayoutStack, where they are lowered into the above +sequence. +-} + +{- Note [Unsafe foreign calls clobber caller-save registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A foreign call is defined to clobber any GlobalRegs that are mapped to +caller-saves machine registers (according to the prevailing C ABI). +StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves. + +This is a design choice that makes it easier to generate code later. +We could instead choose to say that foreign calls do *not* clobber +caller-saves regs, but then we would have to figure out which regs +were live across the call later and insert some saves/restores. + +Furthermore when we generate code we never have any GlobalRegs live +across a call, because they are always copied-in to LocalRegs and +copied-out again before making a call/jump. So all we have to do is +avoid any code motion that would make a caller-saves GlobalReg live +across a foreign call during subsequent optimisations. +-} + +{- Note [Register parameter passing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On certain architectures, some registers are utilized for parameter +passing in the C calling convention. For example, in x86-64 Linux +convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for +argument passing. These are registers R3-R6, which our generated +code may also be using; as a result, it's necessary to save these +values before doing a foreign call. This is done during initial +code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However, +one result of doing this is that the contents of these registers +may mysteriously change if referenced inside the arguments. This +is dangerous, so you'll need to disable inlining much in the same +way is done in cmm/CmmOpt.hs currently. We should fix this! +-} + +--------------------------------------------- +-- Eq instance of CmmNode + +deriving instance Eq (CmmNode e x) + +---------------------------------------------- +-- Hoopl instances of CmmNode + +instance NonLocal CmmNode where + entryLabel (CmmEntry l _) = l + + successors (CmmBranch l) = [l] + successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint + successors (CmmSwitch _ ls) = catMaybes ls + successors (CmmCall {cml_cont=l}) = maybeToList l + successors (CmmForeignCall {succ=l}) = [l] + + +-------------------------------------------------- +-- Various helper types + +type CmmActual = CmmExpr +type CmmFormal = LocalReg + +type UpdFrameOffset = ByteOff + +-- | A convention maps a list of values (function arguments or return +-- values) to registers or stack locations. +data Convention + = NativeDirectCall + -- ^ top-level Haskell functions use @NativeDirectCall@, which + -- maps arguments to registers starting with R2, according to + -- how many registers are available on the platform. This + -- convention ignores R1, because for a top-level function call + -- the function closure is implicit, and doesn't need to be passed. + | NativeNodeCall + -- ^ non-top-level Haskell functions, which pass the address of + -- the function closure in R1 (regardless of whether R1 is a + -- real register or not), and the rest of the arguments in + -- registers or on the stack. + | NativeReturn + -- ^ a native return. The convention for returns depends on + -- how many values are returned: for just one value returned, + -- the appropriate register is used (R1, F1, etc.). regardless + -- of whether it is a real register or not. For multiple + -- values returned, they are mapped to registers or the stack. + | Slow + -- ^ Slow entry points: all args pushed on the stack + | GC + -- ^ Entry to the garbage collector: uses the node reg! + -- (TODO: I don't think we need this --SDM) + deriving( Eq ) + +data ForeignConvention + = ForeignConvention + CCallConv -- Which foreign-call convention + [ForeignHint] -- Extra info about the args + [ForeignHint] -- Extra info about the result + CmmReturnInfo + deriving Eq + +data CmmReturnInfo + = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) + +data ForeignTarget -- The target of a foreign call + = ForeignTarget -- A foreign procedure + CmmExpr -- Its address + ForeignConvention -- Its calling convention + | PrimTarget -- A possibly-side-effecting machine operation + CallishMachOp -- Which one + deriving Eq + +foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) +foreignTargetHints target + = ( res_hints ++ repeat NoHint + , arg_hints ++ repeat NoHint ) + where + (res_hints, arg_hints) = + case target of + PrimTarget op -> callishMachOpHints op + ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) -> + (res_hints, arg_hints) + +-------------------------------------------------- +-- Instances of register and slot users / definers + +instance UserOfRegs LocalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt} -> fold f z tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfRegs LocalReg a => + (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n + +instance UserOfRegs GlobalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n + +instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where + foldRegsUsed _ _ z (PrimTarget _) = z + foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e + +instance DefinerOfRegs LocalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall _ fs _ -> fold f z fs + CmmForeignCall {res=res} -> fold f z res + _ -> z + where fold :: forall a b. + DefinerOfRegs LocalReg a => + (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + +instance DefinerOfRegs GlobalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) + CmmCall {} -> fold f z activeRegs + CmmForeignCall {} -> fold f z activeRegs + -- See Note [Safe foreign calls clobber STG registers] + _ -> z + where fold :: forall a b. + DefinerOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + + platform = targetPlatform dflags + activeRegs = activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform) activeRegs + + foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] + foreignTargetRegs _ = activeCallerSavesRegs + +-- Note [Safe foreign calls clobber STG registers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During stack layout phase every safe foreign call is expanded into a block +-- that contains unsafe foreign call (instead of safe foreign call) and ends +-- with a normal call (See Note [Foreign calls]). This means that we must +-- treat safe foreign call as if it was a normal call (because eventually it +-- will be). This is important if we try to run sinking pass before stack +-- layout phase. Consider this example of what might go wrong (this is cmm +-- code from stablename001 test). Here is code after common block elimination +-- (before stack layout): +-- +-- c1q6: +-- _s1pf::P64 = R1; +-- _c1q8::I64 = performMajorGC; +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- If we run sinking pass now (still before stack layout) we will get this: +-- +-- c1q6: +-- I64[(young + 8)] = c1q9; +-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...) +-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that _s1pf was sunk past a foreign call. When we run stack layout +-- safe call to performMajorGC will be turned into: +-- +-- c1q6: +-- _s1pc::P64 = P64[Sp + 8]; +-- I64[Sp - 8] = c1q9; +-- Sp = Sp - 8; +-- I64[I64[CurrentTSO + 24] + 16] = Sp; +-- P64[CurrentNursery + 8] = Hp + 8; +-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,] +-- result hints: [PtrHint] suspendThread(BaseReg, 0); +-- call "ccall" arg hints: [] result hints: [] performMajorGC(); +-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint] +-- result hints: [PtrHint] resumeThread(_u1qI::I64); +-- BaseReg = _u1qJ::I64; +-- _u1qK::P64 = CurrentTSO; +-- _u1qL::P64 = I64[_u1qK::P64 + 24]; +-- Sp = I64[_u1qL::P64 + 16]; +-- SpLim = _u1qL::P64 + 192; +-- HpAlloc = 0; +-- Hp = I64[CurrentNursery + 8] - 8; +-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1); +-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8; +-- c1q9: +-- I64[(young + 8)] = c1qb; +-- _s1pf::P64 = R1; <------ INCORRECT! +-- R1 = _s1pc::P64; +-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8; +-- +-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that +-- call is clearly incorrect. This is what would happen if we assumed that +-- safe foreign call has the same semantics as unsafe foreign call. To prevent +-- this we need to treat safe foreign call as if was normal call. + +----------------------------------- +-- mapping Expr in CmmNode + +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c +mapForeignTarget _ m@(PrimTarget _) = m + +wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr +-- Take a transformer on expressions and apply it recursively. +-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e +-- then uses f to rewrite the resulting expression +wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) +wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) +wrapRecExp f e = f e + +mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExp _ f@(CmmEntry{}) = f +mapExp _ m@(CmmComment _) = m +mapExp _ m@(CmmTick _) = m +mapExp f (CmmUnwind r e) = CmmUnwind r (f e) +mapExp f (CmmAssign r e) = CmmAssign r (f e) +mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) +mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) +mapExp _ l@(CmmBranch _) = l +mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi +mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl +mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} +mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl + +mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExpDeep f = mapExp $ wrapRecExp f + +------------------------------------------------------------------------ +-- mapping Expr in CmmNode, but not performing allocation if no changes + +mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget +mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e +mapForeignTargetM _ (PrimTarget _) = Nothing + +wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) +-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e +-- then gives f a chance to rewrite the resulting expression +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) +wrapRecExpM f e = f e + +mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpM _ (CmmEntry{}) = Nothing +mapExpM _ (CmmComment _) = Nothing +mapExpM _ (CmmTick _) = Nothing +mapExpM f (CmmUnwind r e) = CmmUnwind r `fmap` f e +mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e +mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] +mapExpM _ (CmmBranch _) = Nothing +mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e +mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e +mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt +mapExpM f (CmmUnsafeForeignCall tgt fs as) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) + Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as +mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as + +-- share as much as possible +mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] +mapListM f xs = let (b, r) = mapListT f xs + in if b then Just r else Nothing + +mapListJ :: (a -> Maybe a) -> [a] -> [a] +mapListJ f xs = snd (mapListT f xs) + +mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) +mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) + where g (_, y, Nothing) (True, ys) = (True, y:ys) + g (_, _, Just y) (True, ys) = (True, y:ys) + g (ys', _, Nothing) (False, _) = (False, ys') + g (_, _, Just y) (False, ys) = (True, y:ys) + +mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpDeepM f = mapExpM $ wrapRecExpM f + +----------------------------------- +-- folding Expr in CmmNode + +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget exp (ForeignTarget e _) z = exp e z +foldExpForeignTarget _ (PrimTarget _) z = z + +-- Take a folder on expressions and apply it recursively. +-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad +-- itself, delegating all the other CmmExpr forms to 'f'. +wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z +wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es +wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) +wrapRecExpf f e z = f e z + +foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExp _ (CmmEntry {}) z = z +foldExp _ (CmmComment {}) z = z +foldExp _ (CmmTick {}) z = z +foldExp f (CmmUnwind _ e) z = f e z +foldExp f (CmmAssign _ e) z = f e z +foldExp f (CmmStore addr e) z = f addr $ f e z +foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as +foldExp _ (CmmBranch _) z = z +foldExp f (CmmCondBranch e _ _) z = f e z +foldExp f (CmmSwitch e _) z = f e z +foldExp f (CmmCall {cml_target=tgt}) z = f tgt z +foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args + +foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExpDeep f = foldExp (wrapRecExpf f) + +-- ----------------------------------------------------------------------------- + +mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C +mapSuccessors f (CmmBranch bid) = CmmBranch (f bid) +mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n) +mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms) +mapSuccessors _ n = n + +-- ----------------------------------------------------------------------------- + +-- | Tickish in Cmm context (annotations only) +type CmmTickish = Tickish () + +-- | Tick scope identifier, allowing us to reason about what +-- annotations in a Cmm block should scope over. We especially take +-- care to allow optimisations to reorganise blocks without losing +-- tick association in the process. +data CmmTickScope + = GlobalScope + -- ^ The global scope is the "root" of the scope graph. Every + -- scope is a sub-scope of the global scope. It doesn't make sense + -- to add ticks to this scope. On the other hand, this means that + -- setting this scope on a block means no ticks apply to it. + + | SubScope U.Unique CmmTickScope + -- ^ Constructs a new sub-scope to an existing scope. This allows + -- us to translate Core-style scoping rules (see @tickishScoped@) + -- into the Cmm world. Suppose the following code: + -- + -- tick<1> case ... of + -- A -> tick<2> ... + -- B -> tick<3> ... + -- + -- We want the top-level tick annotation to apply to blocks + -- generated for the A and B alternatives. We can achieve that by + -- generating tick<1> into a block with scope a, while the code + -- for alternatives A and B gets generated into sub-scopes a/b and + -- a/c respectively. + + | CombinedScope CmmTickScope CmmTickScope + -- ^ A combined scope scopes over everything that the two given + -- scopes cover. It is therefore a sub-scope of either scope. This + -- is required for optimisations. Consider common block elimination: + -- + -- A -> tick<2> case ... of + -- C -> [common] + -- B -> tick<3> case ... of + -- D -> [common] + -- + -- We will generate code for the C and D alternatives, and figure + -- out afterwards that it's actually common code. Scoping rules + -- dictate that the resulting common block needs to be covered by + -- both tick<2> and tick<3>, therefore we need to construct a + -- scope that is a child to *both* scope. Now we can do that - if + -- we assign the scopes a/c and b/d to the common-ed up blocks, + -- the new block could have a combined tick scope a/c+b/d, which + -- both tick<2> and tick<3> apply to. + +-- Note [CmmTick scoping details]: +-- +-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the +-- same block. Note that as a result of this, optimisations making +-- tick scopes more specific can *reduce* the amount of code a tick +-- scopes over. Fixing this would require a separate @CmmTickScope@ +-- field for @CmmTick@. Right now we do not do this simply because I +-- couldn't find an example where it actually mattered -- multiple +-- blocks within the same scope generally jump to each other, which +-- prevents common block elimination from happening in the first +-- place. But this is no strong reason, so if Cmm optimisations become +-- more involved in future this might have to be revisited. + +-- | Output all scope paths. +scopeToPaths :: CmmTickScope -> [[U.Unique]] +scopeToPaths GlobalScope = [[]] +scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s) +scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2 + +-- | Returns the head uniques of the scopes. This is based on the +-- assumption that the @Unique@ of @SubScope@ identifies the +-- underlying super-scope. Used for efficient equality and comparison, +-- see below. +scopeUniques :: CmmTickScope -> [U.Unique] +scopeUniques GlobalScope = [] +scopeUniques (SubScope u _) = [u] +scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 + +-- Equality and order is based on the head uniques defined above. We +-- take care to short-cut the (extremly) common cases. +instance Eq CmmTickScope where + GlobalScope == GlobalScope = True + GlobalScope == _ = False + _ == GlobalScope = False + (SubScope u _) == (SubScope u' _) = u == u' + (SubScope _ _) == _ = False + _ == (SubScope _ _) = False + scope == scope' = sort (scopeUniques scope) == + sort (scopeUniques scope') +instance Ord CmmTickScope where + compare GlobalScope GlobalScope = EQ + compare GlobalScope _ = LT + compare _ GlobalScope = GT + compare (SubScope u _) (SubScope u' _) = compare u u' + compare scope scope' = compare (sort $ scopeUniques scope) + (sort $ scopeUniques scope') + +instance Outputable CmmTickScope where + ppr GlobalScope = text "global" + ppr (SubScope us GlobalScope) + = ppr us + ppr (SubScope us s) = ppr s <> char '/' <> ppr us + ppr combined = parens $ hcat $ punctuate (char '+') $ + map (hcat . punctuate (char '/') . map ppr . reverse) $ + scopeToPaths combined + +-- | Checks whether two tick scopes are sub-scopes of each other. True +-- if the two scopes are equal. +isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool +isTickSubScope = cmp + where cmp _ GlobalScope = True + cmp GlobalScope _ = False + cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s' + cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2' + cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s' + +-- | Combine two tick scopes. The new scope should be sub-scope of +-- both parameters. We simplfy automatically if one tick scope is a +-- sub-scope of the other already. +combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope +combineTickScopes s1 s2 + | s1 `isTickSubScope` s2 = s1 + | s2 `isTickSubScope` s1 = s2 + | otherwise = CombinedScope s1 s2 diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs new file mode 100644 index 00000000..84499b97 --- /dev/null +++ b/compiler/cmm/CmmOpt.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Cmm optimisation +-- +-- (c) The University of Glasgow 2006 +-- +----------------------------------------------------------------------------- + +module CmmOpt ( + constantFoldNode, + constantFoldExpr, + cmmMachOpFold, + cmmMachOpFoldM + ) where + +#include "HsVersions.h" + +import CmmUtils +import Cmm +import DynFlags + +import FastTypes +import Outputable +import Platform + +import Data.Bits +import Data.Maybe + + +constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x +constantFoldNode dflags = mapExp (constantFoldExpr dflags) + +constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr +constantFoldExpr dflags = wrapRecExp f + where f (CmmMachOp op args) = cmmMachOpFold dflags op args + f (CmmRegOff r 0) = CmmReg r + f e = e + +-- ----------------------------------------------------------------------------- +-- MachOp constant folder + +-- Now, try to constant-fold the MachOps. The arguments have already +-- been optimized and folded. + +cmmMachOpFold + :: DynFlags + -> MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments + -> CmmExpr + +cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args) + +-- Returns Nothing if no changes, useful for Hoopl, also reduces +-- allocation! +cmmMachOpFoldM + :: DynFlags + -> MachOp + -> [CmmExpr] + -> Maybe CmmExpr + +cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)] + = Just $ case op of + MO_S_Neg _ -> CmmLit (CmmInt (-x) rep) + MO_Not _ -> CmmLit (CmmInt (complement x) rep) + + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. + MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to) + MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) + MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) + + _ -> panic "cmmMachOpFoldM: unknown unary op" + + +-- Eliminate conversion NOPs +cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x + +-- Eliminate nested conversions where possible +cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]] + | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, + Just (_, rep3,signed2) <- isIntConversion conv_outer + = case () of + -- widen then narrow to the same size is a nop + _ | rep1 < rep2 && rep1 == rep3 -> Just x + -- Widen then narrow to different size: collapse to single conversion + -- but remember to use the signedness from the widening, just in case + -- the final conversion is a widen. + | rep1 < rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] + -- Nested widenings: collapse if the signedness is the same + | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] + -- Nested narrowings: collapse + | rep1 > rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x] + | otherwise -> + Nothing + where + isIntConversion (MO_UU_Conv rep1 rep2) + = Just (rep1,rep2,False) + isIntConversion (MO_SS_Conv rep1 rep2) + = Just (rep1,rep2,True) + isIntConversion _ = Nothing + + intconv True = MO_SS_Conv + intconv False = MO_UU_Conv + +-- ToDo: a narrow of a load can be collapsed into a narrow load, right? +-- but what if the architecture only supports word-sized loads, should +-- we do the transformation anyway? + +cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] + = case mop of + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags)) + MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags)) + + MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags)) + MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags)) + MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags)) + MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags)) + + MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags)) + MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags)) + MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags)) + MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags)) + + MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) + MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) + MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) + MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) + MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) + MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) + MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) + + MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) + MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) + + _ -> Nothing + + where + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + + +-- When possible, shift the constants to the right-hand side, so that we +-- can match for strength reductions. Note that the code generator will +-- also assume that constants have been shifted to the right when +-- possible. + +cmmMachOpFoldM dflags op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = Just (cmmMachOpFold dflags op [y, x]) + +-- Turn (a+b)+c into a+(b+c) where possible. Because literals are +-- moved to the right, it is more likely that we will find +-- opportunities for constant folding when the expression is +-- right-associated. +-- +-- ToDo: this appears to introduce a quadratic behaviour due to the +-- nested cmmMachOpFold. Can we fix this? +-- +-- Why do we check isLit arg1? If arg1 is a lit, it means that arg2 +-- is also a lit (otherwise arg1 would be on the right). If we +-- put arg1 on the left of the rearranged expression, we'll get into a +-- loop: (x1+x2)+x3 => x1+(x2+x3) => (x2+x3)+x1 => x2+(x3+x1) ... +-- +-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the +-- PicBaseReg from the corresponding label (or label difference). +-- +cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3] + | mop2 `associates_with` mop1 + && not (isLit arg1) && not (isPicReg arg1) + = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]]) + where + MO_Add{} `associates_with` MO_Sub{} = True + mop1 `associates_with` mop2 = + mop1 == mop2 && isAssociativeMachOp mop1 + +-- special case: (a - b) + c ==> a + (c - b) +cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] + | not (isLit arg1) && not (isPicReg arg1) + = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]]) + +-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N) +-- +-- this is better because lit+N is a single link-time constant (e.g. a +-- CmmLabelOff), so the right-hand expression needs only one +-- instruction, whereas the left needs two. This happens when pointer +-- tagging gives us label+offset, and PIC turns the label into +-- PicBaseReg + label. +-- +cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit] + , CmmLit (CmmInt n rep) ] + | isPicReg pic + = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] + where off = fromIntegral (narrowS rep n) + +-- Make a RegOff if we can +cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n)) + +-- Fold label(+/-)offset into a CmmLit where possible + +cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) + + +-- Comparison of literal with widened operand: perform the comparison +-- at the smaller width, as long as the literal is within range. + +-- We can't do the reverse trick, when the operand is narrowed: +-- narrowing throws away bits from the operand, there's no way to do +-- the same comparison at the larger size. + +cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] + | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try + platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64], + -- if the operand is widened: + Just (rep, signed, narrow_fn) <- maybe_conversion conv, + -- and this is a comparison operation: + Just narrow_cmp <- maybe_comparison cmp rep signed, + -- and the literal fits in the smaller size: + i == narrow_fn rep i + -- then we can do the comparison at the smaller size + = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)]) + where + maybe_conversion (MO_UU_Conv from to) + | to > from + = Just (from, False, narrowU) + maybe_conversion (MO_SS_Conv from to) + | to > from + = Just (from, True, narrowS) + + -- don't attempt to apply this optimisation when the source + -- is a float; see #1916 + maybe_conversion _ = Nothing + + -- careful (#2080): if the original comparison was signed, but + -- we were doing an unsigned widen, then we must do an + -- unsigned comparison at the smaller size. + maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep) + maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep) + maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep) + maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep) + maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep) + maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep) + maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep) + maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep) + maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep) + maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep) + maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep) + maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep) + maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep) + maybe_comparison _ _ _ = Nothing + +-- We can often do something with constants of 0 and 1 ... + +cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))] + = case mop of + MO_Add _ -> Just x + MO_Sub _ -> Just x + MO_Mul _ -> Just y + MO_And _ -> Just y + MO_Or _ -> Just x + MO_Xor _ -> Just x + MO_Shl _ -> Just x + MO_S_Shr _ -> Just x + MO_U_Shr _ -> Just x + MO_Ne _ | isComparisonExpr x -> Just x + MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt _ | isComparisonExpr x -> Just x + MO_S_Gt _ | isComparisonExpr x -> Just x + MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' + _ -> Nothing + +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))] + = case mop of + MO_Mul _ -> Just x + MO_S_Quot _ -> Just x + MO_U_Quot _ -> Just x + MO_S_Rem _ -> Just $ CmmLit (CmmInt 0 rep) + MO_U_Rem _ -> Just $ CmmLit (CmmInt 0 rep) + MO_Ne _ | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_Eq _ | isComparisonExpr x -> Just x + MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_U_Ge _ | isComparisonExpr x -> Just x + MO_S_Ge _ | isComparisonExpr x -> Just x + _ -> Nothing + +-- Now look for multiplication/division by powers of 2 (integers). + +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))] + = case mop of + MO_Mul rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + MO_U_Quot rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + MO_S_Quot rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x below, hence require + -- it is a reg. FIXME: remove this restriction. + -- shift right is not the same as quot, because it rounds + -- to minus infinity, whereasq quot rounds toward zero. + -- To fix this up, we add one less than the divisor to the + -- dividend if it is a negative number. + -- + -- to avoid a test/jump, we use the following sequence: + -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) + -- x2 = y & (divisor-1) + -- result = (x+x2) >>= log2(divisor) + -- this could be done a bit more simply using conditional moves, + -- but we're processor independent here. + -- + -- we optimise the divide by 2 case slightly, generating + -- x1 = x >> word_size-1 (unsigned) + -- return = (x + x1) >>= log2(divisor) + let + bits = fromIntegral (widthInBits rep) - 1 + shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] + x2 = if p == 1 then x1 else + CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] + x3 = CmmMachOp (MO_Add rep) [x, x2] + in + Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) + _ -> Nothing + +-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x +-- Unfortunately this needs a unique supply because x might not be a +-- register. See #2253 (program 6) for an example. + + +-- Anything else is just too hard. + +cmmMachOpFoldM _ _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- exactLog2 + +-- This algorithm for determining the $\log_2$ of exact powers of 2 comes +-- from GCC. It requires bit manipulation primitives, and we use GHC +-- extensions. Tough. +-- +-- Used to be in MachInstrs --SDM. +-- ToDo: remove use of unboxery --SDM. + +-- Unboxery removed in favor of FastInt; but is the function supposed to fail +-- on inputs >= 2147483648, or was that just an implementation artifact? +-- And is this speed-critical, or can we just use Integer operations +-- (including Data.Bits)? +-- --Isaac Dupree + +exactLog2 :: Integer -> Maybe Integer +exactLog2 x_ + = if (x_ <= 0 || x_ >= 2147483648) then + Nothing + else + case iUnbox (fromInteger x_) of { x -> + if (x `bitAndFastInt` negateFastInt x) /=# x then + Nothing + else + Just (toInteger (iBox (pow2 x))) + } + where + pow2 x | x ==# _ILIT(1) = _ILIT(0) + | otherwise = _ILIT(1) +# pow2 (x `shiftR_FastInt` _ILIT(1)) + +-- ----------------------------------------------------------------------------- +-- Utils + +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False + +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False + +isPicReg :: CmmExpr -> Bool +isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True +isPicReg _ = False diff --git a/compiler/cmm/CmmParse.hs b/compiler/cmm/CmmParse.hs new file mode 100644 index 00000000..030e3043 --- /dev/null +++ b/compiler/cmm/CmmParse.hs @@ -0,0 +1,3198 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module CmmParse ( parseCmmFile ) where + +import StgCmmExtCode +import CmmCallConv +import StgCmmProf +import StgCmmHeap +import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore + , emitAssign, emitOutOfLine, withUpdFrameOff + , getUpdFrameOff ) +import qualified StgCmmMonad as F +import StgCmmUtils +import StgCmmForeign +import StgCmmExpr +import StgCmmClosure +import StgCmmLayout hiding (ArgRep(..)) +import StgCmmTicky +import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) +import CoreSyn ( Tickish(SourceNote) ) + +import CmmOpt +import MkGraph +import Cmm +import CmmUtils +import CmmInfo +import BlockId +import CmmLex +import CLabel +import SMRep +import Lexer + +import CostCentre +import ForeignCall +import Module +import Platform +import Literal +import Unique +import UniqFM +import SrcLoc +import DynFlags +import StaticFlags +import ErrUtils +import StringBuffer +import FastString +import Panic +import Constants +import Outputable +import BasicTypes +import Bag ( emptyBag, unitBag ) +import Var + +import Control.Monad +import Data.Array +import Data.Char ( ord ) +import System.Exit +import Data.Maybe + +#include "HsVersions.h" +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) + +-- parser produced by Happy Version 1.19.4 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (CmmParse CLabel) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ([CmmParse [CmmStatic]]) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (CmmParse [CmmStatic]) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Convention) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Convention) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([(FastString, CLabel)]) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: ((FastString, CLabel)) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> ((FastString, CLabel)) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: ([FastString]) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> ([FastString]) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (CmmReturnInfo) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (CmmReturnInfo) +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> (CmmParse BoolExpr) +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (CmmParse BoolExpr) +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: (Safety) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> (Safety) +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: ([GlobalReg]) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> ([GlobalReg]) +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: ([GlobalReg]) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> ([GlobalReg]) +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: (Maybe (Int,Int)) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> (Maybe (Int,Int)) +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: ([CmmParse ([Int],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> ([CmmParse ([Int],Either BlockId (CmmParse ()))]) +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (CmmParse ([Int],Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> (CmmParse ([Int],Either BlockId (CmmParse ()))) +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> (CmmParse (Either BlockId (CmmParse ()))) +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: ([Int]) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> ([Int]) +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (Maybe (CmmParse ())) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (Maybe (CmmParse ())) +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> (CmmParse ()) +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (CmmType) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (CmmType) +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> ([CmmParse (CmmExpr, ForeignHint)]) +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> ([CmmParse (CmmExpr, ForeignHint)]) +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> (CmmParse (CmmExpr, ForeignHint)) +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> ([CmmParse CmmExpr]) +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> (CmmParse CmmExpr) +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> ([CmmParse (LocalReg, ForeignHint)]) +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> ([CmmParse (LocalReg, ForeignHint)]) +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> (CmmParse (LocalReg, ForeignHint)) +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> (CmmParse LocalReg) +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (CmmParse CmmReg) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> (CmmParse CmmReg) +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> (Maybe [CmmParse LocalReg]) +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> ([CmmParse LocalReg]) +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> ([CmmParse LocalReg]) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> (CmmParse LocalReg) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: (CmmType) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> (CmmType) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: (CmmType) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> (CmmType) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x07\x01\x00\x00\xf9\x03\x07\x01\x00\x00\x00\x00\x04\x04\x00\x00\xfc\x03\x00\x00\x3a\x04\x39\x04\x38\x04\x34\x04\x33\x04\x32\x04\xf7\x03\xf5\x03\xe3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x04\x20\x04\xee\x03\x00\x00\xec\x03\x31\x04\x30\x04\x1b\x04\xe9\x03\xe8\x03\xe7\x03\xe2\x03\xe1\x03\xe0\x03\x15\x04\x00\x04\x00\x00\x00\x00\x86\x01\xde\x03\x00\x00\xf4\x03\xf3\x03\xf2\x03\xf0\x03\xed\x03\xd9\x03\xac\x03\x00\x00\xa9\x03\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x13\x01\xeb\x03\x00\x00\xa5\x03\xa4\x03\xa2\x03\x9b\x03\x98\x03\x91\x03\xc4\x03\x00\x00\xb3\x03\x79\x03\x00\x00\x00\x00\x21\x00\xb9\x03\x21\x00\x21\x00\xd7\xff\xcc\x03\x24\x00\x00\x00\xd1\x03\x6d\x03\x62\x00\x4b\x00\x4b\x00\x4b\x00\xaa\x03\xa3\x03\x9e\x03\x56\x03\x00\x00\x0e\x00\x00\x00\xde\x03\x00\x00\x83\x03\x7a\x03\x09\x00\x77\x03\x6e\x03\x6b\x03\x00\x00\x74\x03\x13\x01\xff\xff\x70\x03\x65\x03\x64\x03\x02\x00\x19\x03\x14\x03\x99\x01\x4a\x03\x00\x00\x4c\x03\x00\x00\x4b\x00\x4b\x00\x01\x03\x4b\x00\x00\x00\x00\x00\x00\x00\x0a\x03\x0a\x03\x00\x00\x00\x00\xfc\x02\xf5\x02\xf0\x02\x00\x00\xde\x03\xe4\x02\x1c\x03\x4b\x00\x00\x00\x00\x00\x4b\x00\x17\x03\x4b\x00\x4b\x00\xe3\x02\x4b\x00\x5d\x02\xc8\x01\x2e\x02\x01\x00\x00\x00\xad\x02\x62\x00\x62\x00\x15\x03\x16\x03\x00\x03\x00\x00\x05\x03\x00\x00\xd8\x02\x4b\x00\x4b\x00\xd0\x02\xfb\x02\x00\x00\x00\x00\x00\x00\xce\x02\xc5\x02\x85\x01\xfc\x01\x00\x00\xff\x02\x19\x01\xfe\x02\x00\x00\x00\x00\x01\x01\xf9\x02\x46\x02\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x21\x00\x62\x00\x62\x00\xb9\x02\x4b\x00\xfd\x02\x06\x00\x4b\x00\xca\x00\x85\x02\xf6\x02\x00\x00\xcf\x02\xad\x01\xee\x02\x4b\x00\xe2\x02\x71\x02\xd7\x02\xdf\x02\xd9\x02\xdc\x02\xdb\x02\xda\x02\x00\x00\xde\x03\x00\x00\x25\x00\xd1\x02\x00\x00\x46\x02\x4b\x00\x8b\x02\x00\x00\xcb\x02\xba\x02\x87\x02\xc0\x02\xc3\x02\xc2\x02\xbb\x02\xb0\x02\x93\x02\xe2\x01\x00\x00\x4b\x00\x00\x00\x56\x02\x68\x02\x67\x02\x00\x00\x66\x02\x00\x00\x00\x00\x9a\x02\xad\x02\xfa\x00\x52\x02\x40\x02\x86\x02\x4b\x00\xfa\x00\x00\x00\x6e\x02\x6f\x02\x00\x00\x6d\x02\x5e\x02\x00\x00\x60\x02\x00\x00\xc1\x00\x47\x02\x5b\x02\x99\x02\x99\x02\x99\x02\x99\x02\xf7\x01\xf7\x01\x99\x02\x99\x02\xea\x03\xf1\x03\x18\x01\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x02\x54\x02\x00\x00\x55\x02\x00\x00\x4a\x02\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x28\x02\x4d\x02\x01\x02\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x3f\x02\x0d\x02\x0c\x02\xf0\x01\x00\x00\x00\x00\x22\x02\x21\x02\x20\x02\x17\x02\x23\x02\x00\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x01\xe3\x01\xd8\x01\xd7\x01\x1d\x02\x07\x02\x00\x00\x11\x02\x13\x02\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x10\x02\x15\x02\x71\x01\xb0\x00\x0a\x02\x00\x00\xe5\x01\xf1\x01\xf8\x01\x4b\x00\xb0\x01\x00\x00\x00\x00\x4b\x00\x21\x00\xd9\x01\xdd\x01\x00\x00\x95\x01\x08\x00\xc9\x01\xbd\x01\xba\x01\xc6\x01\x00\x00\x8a\x01\x89\x01\x7d\x01\x00\x00\x21\x00\x7f\x01\x00\x00\x21\x00\xc2\x01\xbf\x01\xaa\x01\x7e\x01\x00\x00\x00\x00\x00\x00\xaf\x01\x69\x01\x9b\x01\x00\x00\x00\x00\x98\x01\x88\x01\x70\x01\x6a\x01\x5a\x01\x58\x01\x1a\x01\x23\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x01\x45\x01\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\xd4\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x36\x01\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x01\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x2b\x01\xbb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x1c\x01\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x0e\x01\xe6\x00\x00\x00\x00\x00\x14\x01\x00\x00\xfb\x03\x00\x00\x4a\x01\xc3\x03\xc0\x03\xb7\x03\x00\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\xb4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x03\xa8\x03\x00\x00\x9f\x03\x00\x00\x00\x00\x00\x00\xf2\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x0b\x03\x00\x00\x02\x03\x93\x03\x00\x00\xf4\x02\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x01\x46\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x90\x03\x87\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x03\x7b\x03\x78\x03\x6f\x03\x6c\x03\x63\x03\x60\x03\x57\x03\x54\x03\x4b\x03\x48\x03\x3f\x03\x3c\x03\x33\x03\x30\x03\x27\x03\xe3\x00\x07\x00\x05\x00\x00\x00\xeb\x02\x00\x00\xce\x00\xdd\x02\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x03\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x03\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x69\x00\x00\x00\x00\x00\x0f\x03\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x02\x53\x00\x18\x03\x44\x01\x56\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x67\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x02\x0b\x00\x00\x00\x00\x00\xae\x02\xdb\x00\x00\x00\x00\x00\x00\x00\xf8\xff\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x66\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\xff\x65\xff\x64\xff\x63\xff\x62\xff\x61\xff\x60\xff\x5f\xff\x5e\xff\x5d\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\xea\xff\xfd\xff\x00\x00\x6d\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x6a\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\xff\x00\x00\x00\x00\x70\xff\x71\xff\x68\xff\x6b\xff\x6e\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x66\xff\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8f\xff\x8b\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7a\xff\x7b\xff\x8c\xff\x87\xff\x87\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x6d\xff\x00\x00\x00\x00\x00\x00\x69\xff\xd2\xff\x7f\xff\x00\x00\x7f\xff\x00\x00\x00\x00\x7f\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbc\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x77\xff\x74\xff\x00\x00\x72\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x73\xff\x00\x00\x76\xff\x00\x00\xcb\xff\xb8\xff\x00\x00\xbc\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\x00\x00\x00\x00\x00\x00\x7f\xff\x00\x00\x00\x00\x7f\xff\x00\x00\x7d\xff\x00\x00\x7e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\xff\x00\x00\x8e\xff\x91\xff\x00\x00\x92\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\x7f\xff\x86\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xc0\xff\x00\x00\xad\xff\x00\x00\x00\x00\x00\x00\x00\x00\x71\xff\x00\x00\x00\x00\xb4\xff\x00\x00\xb1\xff\xc9\xff\x00\x00\xc4\xff\xb9\xff\xba\xff\x00\x00\x94\xff\x93\xff\x96\xff\x98\xff\x9c\xff\x9d\xff\x95\xff\x97\xff\x99\xff\x9a\xff\x9b\xff\x9e\xff\x9f\xff\xa0\xff\xa1\xff\xa2\xff\xb7\xff\x78\xff\x75\xff\x00\x00\x00\x00\xd1\xff\x00\x00\xbf\xff\x00\x00\x7f\xff\x85\xff\x00\x00\x00\x00\xa4\xff\x00\x00\x00\x00\xb3\xff\xb2\xff\x00\x00\xc1\xff\x7c\xff\xca\xff\x00\x00\xa5\xff\xad\xff\x00\x00\xc2\xff\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x90\xff\x89\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\xff\xac\xff\x00\x00\x00\x00\xaf\xff\xc8\xff\x7f\xff\xb0\xff\xc6\xff\xc3\xff\x00\x00\x00\x00\x00\x00\x81\xff\x00\x00\x84\xff\x83\xff\x00\x00\x00\x00\x00\x00\xb6\xff\x80\xff\xd0\xff\x7f\xff\xe0\xff\x00\x00\x00\x00\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xab\xff\xe0\xff\x00\x00\xa7\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xbe\xff\xb5\xff\x82\xff\xce\xff\x00\x00\x00\x00\x00\x00\xa3\xff\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xaa\xff\xa9\xff\xa6\xff\xc5\xff\xbd\xff\xcf\xff\x00\x00\x00\x00\xe4\xff\xe5\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x02\x00\x04\x00\x05\x00\x03\x00\x22\x00\x07\x00\x30\x00\x06\x00\x32\x00\x0b\x00\x03\x00\x06\x00\x0e\x00\x0f\x00\x01\x00\x1b\x00\x08\x00\x02\x00\x0d\x00\x1c\x00\x07\x00\x12\x00\x07\x00\x13\x00\x14\x00\x13\x00\x14\x00\x29\x00\x2a\x00\x2b\x00\x16\x00\x15\x00\x20\x00\x21\x00\x02\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x07\x00\x05\x00\x47\x00\x48\x00\x27\x00\x2c\x00\x27\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x2c\x00\x1c\x00\x31\x00\x32\x00\x31\x00\x32\x00\x1d\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x29\x00\x49\x00\x46\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x07\x00\x32\x00\x33\x00\x34\x00\x0b\x00\x36\x00\x37\x00\x0e\x00\x0f\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x07\x00\x09\x00\x47\x00\x17\x00\x0b\x00\x04\x00\x05\x00\x0e\x00\x0f\x00\x1f\x00\x20\x00\x1e\x00\x22\x00\x23\x00\x24\x00\x07\x00\x17\x00\x27\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x0e\x00\x19\x00\x1a\x00\x19\x00\x1a\x00\x31\x00\x32\x00\x09\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x31\x00\x32\x00\x06\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x31\x00\x32\x00\x0d\x00\x0e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x07\x00\x0b\x00\x0c\x00\x0a\x00\x07\x00\x0c\x00\x10\x00\x0a\x00\x06\x00\x0c\x00\x20\x00\x21\x00\x0b\x00\x0c\x00\x17\x00\x0b\x00\x0c\x00\x10\x00\x20\x00\x2b\x00\x10\x00\x0d\x00\x0e\x00\x0b\x00\x0c\x00\x27\x00\x0b\x00\x0c\x00\x10\x00\x16\x00\x28\x00\x10\x00\x21\x00\x48\x00\x2c\x00\x31\x00\x32\x00\x02\x00\x03\x00\x31\x00\x32\x00\x28\x00\x31\x00\x32\x00\x28\x00\x2c\x00\x31\x00\x32\x00\x2c\x00\x11\x00\x31\x00\x32\x00\x28\x00\x31\x00\x32\x00\x28\x00\x2c\x00\x46\x00\x47\x00\x2c\x00\x21\x00\x31\x00\x32\x00\x18\x00\x31\x00\x32\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x06\x00\x10\x00\x03\x00\x10\x00\x20\x00\x21\x00\x0f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x0f\x00\x29\x00\x2a\x00\x1a\x00\x1b\x00\x09\x00\x22\x00\x28\x00\x2d\x00\x28\x00\x0f\x00\x2c\x00\x0f\x00\x2c\x00\x36\x00\x08\x00\x31\x00\x32\x00\x31\x00\x32\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x08\x00\x47\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x13\x00\x14\x00\x13\x00\x14\x00\x13\x00\x14\x00\x08\x00\x47\x00\x48\x00\x48\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x27\x00\x49\x00\x27\x00\x16\x00\x27\x00\x16\x00\x27\x00\x08\x00\x02\x00\x04\x00\x31\x00\x32\x00\x31\x00\x32\x00\x31\x00\x32\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x02\x00\x03\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x04\x00\x02\x00\x35\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x31\x00\x03\x00\x02\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x02\x00\x48\x00\x47\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x05\x00\x08\x00\x07\x00\x16\x00\x48\x00\x48\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x49\x00\x16\x00\x03\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x48\x00\x08\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x03\x00\x01\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x01\x00\x48\x00\x48\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x49\x00\x16\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x16\x00\x16\x00\x49\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x38\x00\x06\x00\x39\x00\x46\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x02\x00\x28\x00\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x07\x00\x09\x00\x2e\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x20\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x06\x00\x16\x00\x06\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x02\x00\x49\x00\x38\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x02\x00\x0a\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x49\x00\x49\x00\x49\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x02\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x1f\x00\x20\x00\x48\x00\x16\x00\x06\x00\x47\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x07\x00\x02\x00\x23\x00\x24\x00\x1f\x00\x20\x00\x27\x00\x31\x00\x32\x00\x08\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x18\x00\x31\x00\x32\x00\x08\x00\x25\x00\x26\x00\x27\x00\x31\x00\x32\x00\x16\x00\x16\x00\x16\x00\x1f\x00\x20\x00\x16\x00\x08\x00\x31\x00\x32\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x08\x00\x02\x00\x47\x00\x08\x00\x25\x00\x26\x00\x27\x00\x31\x00\x32\x00\x09\x00\x09\x00\x0e\x00\x1f\x00\x20\x00\x47\x00\x08\x00\x31\x00\x32\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x47\x00\x16\x00\x02\x00\x48\x00\x25\x00\x26\x00\x27\x00\x31\x00\x32\x00\x08\x00\x47\x00\x09\x00\x1f\x00\x20\x00\x19\x00\x08\x00\x31\x00\x32\x00\x25\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x49\x00\x49\x00\x1f\x00\x20\x00\x25\x00\x26\x00\x27\x00\x31\x00\x32\x00\x26\x00\x27\x00\x1f\x00\x20\x00\x49\x00\x1f\x00\x20\x00\x31\x00\x32\x00\x49\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x49\x00\x1f\x00\x20\x00\x47\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x05\x00\x1f\x00\x20\x00\x0a\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x49\x00\x1f\x00\x20\x00\x47\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x05\x00\x1f\x00\x20\x00\x07\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x05\x00\x1f\x00\x20\x00\x04\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x16\x00\x1f\x00\x20\x00\x16\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x16\x00\x1f\x00\x20\x00\x16\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x16\x00\x1f\x00\x20\x00\x46\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x07\x00\x1f\x00\x20\x00\x05\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x07\x00\x1f\x00\x20\x00\x47\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x04\x00\x1f\x00\x20\x00\x47\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x16\x00\x1f\x00\x20\x00\x08\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x09\x00\x1f\x00\x20\x00\x47\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x1f\x00\x20\x00\x49\x00\x1f\x00\x20\x00\x49\x00\x31\x00\x32\x00\x27\x00\x31\x00\x32\x00\x27\x00\x49\x00\x01\x00\x49\x00\x49\x00\x16\x00\x47\x00\x31\x00\x32\x00\x47\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x16\x00\x1a\x00\x1b\x00\x16\x00\x07\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x02\x00\x47\x00\x48\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x29\x00\x2a\x00\x2b\x00\x47\x00\x47\x00\x47\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x47\x00\x47\x00\x47\x00\x16\x00\x02\x00\x47\x00\x03\x00\x47\x00\x16\x00\x02\x00\x34\x00\x07\x00\x07\x00\x07\x00\xff\xff\x48\x00\x47\x00\x07\x00\x07\x00\x07\x00\xff\xff\x47\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x7c\x00\x85\x00\x6f\x00\xcb\x00\x21\x00\x7d\x00\xa9\x00\xef\x00\xaa\x00\x7e\x00\x7a\x01\x0c\x01\x7f\x00\x80\x00\x91\x00\x78\x01\x8b\x00\x58\x01\x0d\x01\x7b\x01\x92\x00\x84\x01\x59\x01\x11\x01\x9b\x00\x12\x01\x9b\x00\x26\x01\xa1\x00\xa2\x00\x8c\x00\x80\x01\xcc\x00\xcd\x00\x58\x00\x9c\x00\x78\x00\x9c\x00\x78\x00\x59\x00\xa7\x00\x22\x00\x23\x00\x79\x00\xce\x00\x79\x00\x70\x00\x71\x00\xbb\x00\xbc\x00\xbd\x00\x7b\x01\x51\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x54\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x11\x00\xf0\x00\x0e\x01\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x79\xff\x7d\x00\x79\xff\x5e\x00\x5f\x00\x7e\x00\x13\x00\x60\x00\x7f\x00\x80\x00\x61\x00\x62\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x63\x00\x64\x00\x9e\x00\x37\x01\x26\x00\x59\x01\x7e\x00\x6e\x00\x6f\x00\x7f\x00\x80\x00\x5f\x01\x78\x00\x5b\x01\x60\x01\x61\x01\x62\x01\x7d\x00\x9f\x00\x79\x00\x8f\x00\x4c\x00\x4d\x00\x09\x00\x7f\x00\x53\x01\x3c\x01\x3b\x01\x3c\x01\x7a\x00\x09\x00\x3e\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xde\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x70\x00\x71\x00\xf2\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xf8\x00\x09\x00\x40\x00\x1f\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x2f\x00\x03\x00\x04\x00\x07\x01\x02\x00\x03\x00\x04\x00\x05\x00\x89\x01\x52\x00\x06\x00\x05\x00\x07\x00\x53\x00\x06\x00\xff\x00\x07\x00\xcc\x00\xcd\x00\x8b\x01\x52\x00\x0a\x01\x7e\x01\x52\x00\x53\x00\x4b\x01\xb1\x00\x53\x00\x1e\x00\x1f\x00\x13\x01\x52\x00\x79\x00\xaa\x00\x52\x00\x53\x00\xcf\x00\x54\x00\x53\x00\xe2\x00\x68\x01\x55\x00\x7a\x00\x09\x00\x50\x00\x51\x00\x56\x00\x09\x00\x54\x00\x08\x00\x09\x00\x54\x00\x55\x00\x08\x00\x09\x00\x55\x00\x2a\x01\x56\x00\x09\x00\x54\x00\x56\x00\x09\x00\x54\x00\x55\x00\x63\x00\x09\x01\x55\x00\xe4\x00\x56\x00\x09\x00\x94\x00\x56\x00\x09\x00\xab\x00\x52\x00\x51\x00\x52\x00\x8d\x00\x53\x00\x41\x00\x53\x00\xcc\x00\xcd\x00\x2c\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x43\x00\x11\x00\x12\x00\xc5\x00\xc6\x00\x4e\x00\x73\x00\x54\x00\x30\x00\x54\x00\x24\x00\x55\x00\x2c\x00\x55\x00\x13\x00\x2d\x00\x56\x00\x09\x00\x56\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x9b\x01\x1e\x00\x74\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xb6\x00\x9b\x00\xb7\x00\xb8\x00\x9a\x00\x9b\x00\x9c\x01\xa5\x00\xa6\x00\x9a\x01\x5d\x01\x78\x00\x9c\x00\x78\x00\xb9\x00\x78\x00\x9c\x00\x78\x00\x79\x00\x99\x01\x79\x00\x90\x01\x79\x00\x91\x01\x79\x00\x92\x01\x69\x01\x93\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x2a\x01\x50\x00\x51\x00\x94\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xec\x00\x95\x01\x96\x01\x97\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x86\x01\x04\x01\x98\x01\x87\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x88\x01\x89\x01\x8d\x01\x8b\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xd1\x00\x75\x01\xd2\x00\x76\x01\x8e\x01\x8f\x01\x77\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x53\x01\x78\x01\x7d\x01\x7e\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x46\x01\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x82\x01\x65\x01\x84\x01\x66\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x29\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x67\x01\x6b\x01\x6d\x01\x6e\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x6a\x01\x6f\x01\x70\x01\x71\x01\x72\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x4d\x01\x73\x01\x4e\x01\x74\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcf\x00\x4f\x01\x50\x01\x51\x01\x53\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x3e\x01\x57\x01\x56\x01\x0e\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xf7\x00\x5b\x01\x5d\x01\x2e\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x2f\x01\x30\x01\x31\x01\x32\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xd3\x00\xcc\x00\x33\x01\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x35\x01\x34\x01\x36\x01\x37\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x8f\x00\x3a\x01\x3b\x01\x3e\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x07\x01\x40\x01\x47\x01\x44\x01\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\x00\x00\x41\x01\x42\x01\x43\x01\x48\x01\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x49\x01\x4a\x01\x4b\x01\xf1\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xd3\x00\x78\x00\xf2\x00\x8f\x00\xf4\x00\xf5\x00\x7f\x01\xd5\x00\x79\x00\x5f\x01\x78\x00\xf8\x00\xff\x00\x82\x01\x62\x01\xd3\x00\x78\x00\x79\x00\x7a\x00\x09\x00\xfd\x00\x6b\x01\xd5\x00\x79\x00\xd3\x00\x78\x00\x05\x01\x7a\x00\x09\x00\x01\x01\x63\x01\xd5\x00\x79\x00\x7a\x00\x09\x00\xfa\x00\xfb\x00\xfc\x00\xd3\x00\x78\x00\xfe\x00\x03\x01\x7a\x00\x09\x00\x44\x01\xd5\x00\x79\x00\xd3\x00\x78\x00\x06\x01\x0f\x01\x11\x01\x25\x01\x09\x01\xd5\x00\x79\x00\x7a\x00\x09\x00\x26\x01\x28\x01\xae\x00\xd3\x00\x78\x00\x2c\x01\xb3\x00\x7a\x00\x09\x00\x0f\x01\xd5\x00\x79\x00\xd3\x00\x78\x00\x2d\x01\xb4\x00\xb6\x00\xaf\x00\xd4\x00\xd5\x00\x79\x00\x7a\x00\x09\x00\xb5\x00\xa5\x00\xda\x00\xd3\x00\x78\x00\xe4\x00\xdd\x00\x7a\x00\x09\x00\xd8\x00\xd5\x00\x79\x00\xd3\x00\x78\x00\xd7\x00\xde\x00\xd3\x00\x78\x00\xda\x00\xd5\x00\x79\x00\x7a\x00\x09\x00\x38\x01\x79\x00\x5e\x01\x78\x00\xe0\x00\xf5\x00\x78\x00\x7a\x00\x09\x00\xe1\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x01\x01\x78\x00\xe2\x00\x14\x01\x78\x00\xe7\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x15\x01\x78\x00\xea\x00\x16\x01\x78\x00\xeb\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x17\x01\x78\x00\xed\x00\x18\x01\x78\x00\xee\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x19\x01\x78\x00\x75\x00\x1a\x01\x78\x00\x76\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x1b\x01\x78\x00\x77\x00\x1c\x01\x78\x00\x87\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x1d\x01\x78\x00\x88\x00\x1e\x01\x78\x00\x89\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x1f\x01\x78\x00\x8a\x00\x20\x01\x78\x00\x8d\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x21\x01\x78\x00\x8f\x00\x22\x01\x78\x00\x93\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x23\x01\x78\x00\x94\x00\xaf\x00\x78\x00\x96\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\xb0\x00\x78\x00\x97\x00\xd7\x00\x78\x00\xa0\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\xdb\x00\x78\x00\xad\x00\xe5\x00\x78\x00\x65\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\xe7\x00\x78\x00\x66\x00\xe8\x00\x78\x00\x67\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x77\x00\x78\x00\xa8\x00\x97\x00\x78\x00\x68\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x98\x00\x78\x00\x69\x00\x99\x00\x78\x00\x6a\x00\x7a\x00\x09\x00\x79\x00\x7a\x00\x09\x00\x79\x00\x6b\x00\x6e\x00\x6c\x00\x6d\x00\x45\x00\x43\x00\x7a\x00\x09\x00\x26\x00\x7a\x00\x09\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x46\x00\xc5\x00\xc6\x00\x47\x00\x32\x00\x48\x00\x49\x00\x4a\x00\xc5\x00\xc6\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x33\x00\xa5\x00\xa6\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa0\x00\xa1\x00\xa2\x00\x34\x00\x35\x00\x36\x00\xa3\x00\x4c\x00\x4d\x00\x09\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3d\x00\x3c\x00\x3e\x00\x3f\x00\x40\x00\x2f\x00\x27\x00\x28\x00\x29\x00\x00\x00\x24\x00\x26\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x26\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 162) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162) + ] + +happy_n_terms = 76 :: Int +happy_n_nonterms = 51 :: Int + +happyReduce_1 = happySpecReduce_0 0# happyReduction_1 +happyReduction_1 = happyIn4 + (return () + ) + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 +happyReduction_6 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> + case happyOut10 happy_x_6 of { happy_var_6 -> + ( withThisPackage $ \pkg -> + do lits <- sequence happy_var_6; + staticClosure pkg happy_var_3 happy_var_5 (map getLit lits))}}} + ) (\r -> happyReturn (happyIn5 r)) + +happyReduce_7 = happyReduce 6# 2# happyReduction_7 +happyReduction_7 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_5 of { happy_var_5 -> + happyIn6 + (do lbl <- happy_var_4; + ss <- sequence happy_var_5; + code (emitDecl (CmmData (section happy_var_2) (Statics lbl $ concat ss))) + ) `HappyStk` happyRest}}} + +happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 +happyReduction_8 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg happy_var_1))} + ) (\r -> happyReturn (happyIn7 r)) + +happyReduce_9 = happySpecReduce_0 4# happyReduction_9 +happyReduction_9 = happyIn8 + ([] + ) + +happyReduce_10 = happySpecReduce_2 4# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_11 = happySpecReduce_3 5# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn9 + (do e <- happy_var_2; + return [CmmStaticLit (getLit e)] + )} + +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1))] + )} + +happyReduce_13 = happyReduce 5# 5# happyReduction_13 +happyReduction_13 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> + happyIn9 + (return [mkString happy_var_4] + ) `HappyStk` happyRest} + +happyReduce_14 = happyReduce 5# 5# happyReduction_14 +happyReduction_14 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (fromIntegral happy_var_3)] + ) `HappyStk` happyRest} + +happyReduce_15 = happyReduce 5# 5# happyReduction_15 +happyReduction_15 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1) * + fromIntegral happy_var_3)] + ) `HappyStk` happyRest}} + +happyReduce_16 = happyReduce 5# 5# happyReduction_16 +happyReduction_16 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn9 + (do { lits <- sequence happy_var_4 + ; dflags <- getDynFlags + ; return $ map CmmStaticLit $ + mkStaticClosure dflags (mkForeignLabel happy_var_3 Nothing ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. + dontCareCCS (map getLit lits) [] [] [] } + ) `HappyStk` happyRest}} + +happyReduce_17 = happySpecReduce_0 6# happyReduction_17 +happyReduction_17 = happyIn10 + ([] + ) + +happyReduce_18 = happySpecReduce_3 6# happyReduction_18 +happyReduction_18 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn10 + (happy_var_2 : happy_var_3 + )}} + +happyReduce_19 = happyReduce 4# 7# happyReduction_19 +happyReduction_19 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_4 of { happy_var_4 -> + happyIn11 + (do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeScoped $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- happy_var_1; + dflags <- getDynFlags; + formals <- sequence (fromMaybe [] happy_var_3); + withName (showSDoc dflags (ppr entry_ret_label)) + happy_var_4; + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust happy_var_3 + code (emitProcWithStackFrame happy_var_2 info + entry_ret_label stk_formals formals agraph + do_layout ) + ) `HappyStk` happyRest}}}} + +happyReduce_20 = happySpecReduce_0 8# happyReduction_20 +happyReduction_20 = happyIn12 + (NativeNodeCall + ) + +happyReduce_21 = happySpecReduce_1 8# happyReduction_21 +happyReduction_21 happy_x_1 + = happyIn12 + (NativeReturn + ) + +happyReduce_22 = happySpecReduce_1 9# happyReduction_22 +happyReduction_22 happy_x_1 + = happyIn13 + (return () + ) + +happyReduce_23 = happySpecReduce_3 9# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn13 + (withSourceNote happy_var_1 happy_var_3 happy_var_2 + )}}} + +happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24 +happyReduction_24 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( withThisPackage $ \pkg -> + do newFunctionName happy_var_1 pkg + return (mkCmmCodeLabel pkg happy_var_1, Nothing, []))} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25 +happyReduction_25 (happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + ( withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags happy_var_11 happy_var_13 + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep dflags False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) Thunk + -- not really Thunk, but that makes the info table + -- we want. + return (mkCmmEntryLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []))}}}}}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_26 = happyMonadReduce 16# 10# happyReduction_26 +happyReduction_26 (happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> + ( withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags happy_var_11 happy_var_13 + ty = Fun 0 (ArgSpec (fromIntegral happy_var_15)) + -- Arity zero, arg_type happy_var_15 + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep dflags False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []))}}}}}}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27 +happyReduction_27 (happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> + ( withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags happy_var_13 happy_var_15 + ty = Constr (fromIntegral happy_var_9) -- Tag + (stringToWord8s happy_var_13) + rep = mkRTSRep (fromIntegral happy_var_11) $ + mkHeapRep dflags False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []))}}}}}}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28 +happyReduction_28 (happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + ( withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags happy_var_9 happy_var_11 + ty = ThunkSelector (fromIntegral happy_var_5) + rep = mkRTSRep (fromIntegral happy_var_7) $ + mkHeapRep dflags False 0 0 ty + return (mkCmmEntryLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []))}}}}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29 +happyReduction_29 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + ( withThisPackage $ \pkg -> + do let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep [] + return (mkCmmRetLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []))}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30 +happyReduction_30 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOut50 happy_x_7 of { happy_var_7 -> + ( withThisPackage $ \pkg -> + do dflags <- getDynFlags + live <- sequence happy_var_7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness dflags (map Just (drop 1 live)) + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap + return (mkCmmRetLabel pkg happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + live))}}} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_31 = happySpecReduce_0 11# happyReduction_31 +happyReduction_31 = happyIn15 + (return () + ) + +happyReduce_32 = happySpecReduce_2 11# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_33 = happySpecReduce_2 11# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_34 = happySpecReduce_3 12# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn16 + (mapM_ (newLocal happy_var_1) happy_var_2 + )}} + +happyReduce_35 = happySpecReduce_3 12# happyReduction_35 +happyReduction_35 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (mapM_ newImport happy_var_2 + )} + +happyReduce_36 = happySpecReduce_3 12# happyReduction_36 +happyReduction_36 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn16 + (return () + ) + +happyReduce_37 = happySpecReduce_1 13# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn17 + ([happy_var_1] + )} + +happyReduce_38 = happySpecReduce_3 13# happyReduction_38 +happyReduction_38 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn17 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_39 = happySpecReduce_1 14# happyReduction_39 +happyReduction_39 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn18 + ((happy_var_1, mkForeignLabel happy_var_1 Nothing ForeignLabelInExternalPackage IsFunction) + )} + +happyReduce_40 = happySpecReduce_2 14# happyReduction_40 +happyReduction_40 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkForeignLabel happy_var_2 Nothing ForeignLabelInExternalPackage IsData) + )} + +happyReduce_41 = happySpecReduce_2 14# happyReduction_41 +happyReduction_41 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkCmmCodeLabel (fsToPackageKey (mkFastString happy_var_1)) happy_var_2) + )}} + +happyReduce_42 = happySpecReduce_1 15# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn19 + ([happy_var_1] + )} + +happyReduce_43 = happySpecReduce_3 15# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn19 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_44 = happySpecReduce_1 16# happyReduction_44 +happyReduction_44 happy_x_1 + = happyIn20 + (return () + ) + +happyReduce_45 = happySpecReduce_2 16# happyReduction_45 +happyReduction_45 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn20 + (do l <- newLabel happy_var_1; emitLabel l + )} + +happyReduce_46 = happyReduce 4# 16# happyReduction_46 +happyReduction_46 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn20 + (do reg <- happy_var_1; e <- happy_var_3; emitAssign reg e + ) `HappyStk` happyRest}} + +happyReduce_47 = happyReduce 7# 16# happyReduction_47 +happyReduction_47 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + case happyOut35 happy_x_6 of { happy_var_6 -> + happyIn20 + (doStore happy_var_1 happy_var_3 happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_48 = happyMonadReduce 10# 16# happyReduction_48 +happyReduction_48 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> + case happyOut21 happy_x_4 of { happy_var_4 -> + case happyOut38 happy_x_6 of { happy_var_6 -> + case happyOut25 happy_x_8 of { happy_var_8 -> + case happyOut22 happy_x_9 of { happy_var_9 -> + ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}} + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_49 = happyMonadReduce 8# 16# happyReduction_49 +happyReduction_49 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> + case happyOut41 happy_x_6 of { happy_var_6 -> + ( primCall happy_var_1 happy_var_4 happy_var_6)}}} + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_50 = happyMonadReduce 5# 16# happyReduction_50 +happyReduction_50 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut41 happy_x_3 of { happy_var_3 -> + ( stmtMacro happy_var_1 happy_var_3)}} + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_51 = happyReduce 7# 16# happyReduction_51 +happyReduction_51 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut28 happy_x_2 of { happy_var_2 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + case happyOut29 happy_x_5 of { happy_var_5 -> + case happyOut33 happy_x_6 of { happy_var_6 -> + happyIn20 + (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 + ) `HappyStk` happyRest}}}} + +happyReduce_52 = happySpecReduce_3 16# happyReduction_52 +happyReduction_52 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn20 + (do l <- lookupLabel happy_var_2; emit (mkBranch l) + )} + +happyReduce_53 = happyReduce 5# 16# happyReduction_53 +happyReduction_53 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut41 happy_x_3 of { happy_var_3 -> + happyIn20 + (doReturn happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_54 = happyReduce 4# 16# happyReduction_54 +happyReduction_54 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut26 happy_x_3 of { happy_var_3 -> + happyIn20 + (doRawJump happy_var_2 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_55 = happyReduce 6# 16# happyReduction_55 +happyReduction_55 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut41 happy_x_4 of { happy_var_4 -> + happyIn20 + (doJumpWithStack happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_56 = happyReduce 9# 16# happyReduction_56 +happyReduction_56 (happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut41 happy_x_4 of { happy_var_4 -> + case happyOut41 happy_x_7 of { happy_var_7 -> + happyIn20 + (doJumpWithStack happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_57 = happyReduce 6# 16# happyReduction_57 +happyReduction_57 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut41 happy_x_4 of { happy_var_4 -> + happyIn20 + (doCall happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_58 = happyReduce 10# 16# happyReduction_58 +happyReduction_58 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut35 happy_x_6 of { happy_var_6 -> + case happyOut41 happy_x_8 of { happy_var_8 -> + happyIn20 + (doCall happy_var_6 happy_var_2 happy_var_8 + ) `HappyStk` happyRest}}} + +happyReduce_59 = happyReduce 4# 16# happyReduction_59 +happyReduction_59 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> + happyIn20 + (do l <- lookupLabel happy_var_4; cmmRawIf happy_var_2 l + ) `HappyStk` happyRest}} + +happyReduce_60 = happyReduce 6# 16# happyReduction_60 +happyReduction_60 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut34 happy_x_6 of { happy_var_6 -> + happyIn20 + (cmmIfThenElse happy_var_2 (withSourceNote happy_var_3 happy_var_5 happy_var_4) happy_var_6 + ) `HappyStk` happyRest}}}}} + +happyReduce_61 = happyReduce 5# 16# happyReduction_61 +happyReduction_61 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut41 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_5 of { happy_var_5 -> + happyIn20 + (pushStackFrame happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_62 = happyReduce 5# 16# happyReduction_62 +happyReduction_62 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + case happyOut13 happy_x_5 of { happy_var_5 -> + happyIn20 + (reserveStackFrame happy_var_2 happy_var_4 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_63 = happyReduce 4# 16# happyReduction_63 +happyReduction_63 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_GlobalReg happy_var_2)) -> + case happyOut35 happy_x_4 of { happy_var_4 -> + happyIn20 + (happy_var_4 >>= code . emitUnwind happy_var_2 + ) `HappyStk` happyRest}} + +happyReduce_64 = happySpecReduce_1 17# happyReduction_64 +happyReduction_64 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn21 + (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 Nothing ForeignLabelInThisPackage IsFunction))) + )} + +happyReduce_65 = happySpecReduce_0 18# happyReduction_65 +happyReduction_65 = happyIn22 + (CmmMayReturn + ) + +happyReduce_66 = happySpecReduce_2 18# happyReduction_66 +happyReduction_66 happy_x_2 + happy_x_1 + = happyIn22 + (CmmNeverReturns + ) + +happyReduce_67 = happySpecReduce_1 19# happyReduction_67 +happyReduction_67 happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + happyIn23 + (happy_var_1 + )} + +happyReduce_68 = happySpecReduce_1 19# happyReduction_68 +happyReduction_68 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn23 + (do e <- happy_var_1; return (BoolTest e) + )} + +happyReduce_69 = happySpecReduce_3 20# happyReduction_69 +happyReduction_69 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn24 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolAnd e1 e2) + )}} + +happyReduce_70 = happySpecReduce_3 20# happyReduction_70 +happyReduction_70 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn24 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolOr e1 e2) + )}} + +happyReduce_71 = happySpecReduce_2 20# happyReduction_71 +happyReduction_71 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn24 + (do e <- happy_var_2; return (BoolNot e) + )} + +happyReduce_72 = happySpecReduce_3 20# happyReduction_72 +happyReduction_72 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn24 + (happy_var_2 + )} + +happyReduce_73 = happySpecReduce_0 21# happyReduction_73 +happyReduction_73 = happyIn25 + (PlayRisky + ) + +happyReduce_74 = happyMonadReduce 1# 21# happyReduction_74 +happyReduction_74 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + ( parseSafety happy_var_1)} + ) (\r -> happyReturn (happyIn25 r)) + +happyReduce_75 = happySpecReduce_2 22# happyReduction_75 +happyReduction_75 happy_x_2 + happy_x_1 + = happyIn26 + ([] + ) + +happyReduce_76 = happyMonadReduce 3# 22# happyReduction_76 +happyReduction_76 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (( do df <- getDynFlags + ; return (realArgRegsCover df)) + ) (\r -> happyReturn (happyIn26 r)) + +happyReduce_77 = happySpecReduce_3 22# happyReduction_77 +happyReduction_77 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_2 of { happy_var_2 -> + happyIn26 + (happy_var_2 + )} + +happyReduce_78 = happySpecReduce_1 23# happyReduction_78 +happyReduction_78 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn27 + ([happy_var_1] + )} + +happyReduce_79 = happySpecReduce_3 23# happyReduction_79 +happyReduction_79 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn27 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_80 = happyReduce 5# 24# happyReduction_80 +happyReduction_80 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> + happyIn28 + (Just (fromIntegral happy_var_2, fromIntegral happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_81 = happySpecReduce_0 24# happyReduction_81 +happyReduction_81 = happyIn28 + (Nothing + ) + +happyReduce_82 = happySpecReduce_0 25# happyReduction_82 +happyReduction_82 = happyIn29 + ([] + ) + +happyReduce_83 = happySpecReduce_2 25# happyReduction_83 +happyReduction_83 happy_x_2 + happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut29 happy_x_2 of { happy_var_2 -> + happyIn29 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_84 = happyReduce 4# 26# happyReduction_84 +happyReduction_84 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut31 happy_x_4 of { happy_var_4 -> + happyIn30 + (do b <- happy_var_4; return (happy_var_2, b) + ) `HappyStk` happyRest}} + +happyReduce_85 = happySpecReduce_3 27# happyReduction_85 +happyReduction_85 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn31 + (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2)) + )}}} + +happyReduce_86 = happySpecReduce_3 27# happyReduction_86 +happyReduction_86 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn31 + (do l <- lookupLabel happy_var_2; return (Left l) + )} + +happyReduce_87 = happySpecReduce_1 28# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + happyIn32 + ([ fromIntegral happy_var_1 ] + )} + +happyReduce_88 = happySpecReduce_3 28# happyReduction_88 +happyReduction_88 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 + (fromIntegral happy_var_1 : happy_var_3 + )}} + +happyReduce_89 = happyReduce 5# 29# happyReduction_89 +happyReduction_89 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + happyIn33 + (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_90 = happySpecReduce_0 29# happyReduction_90 +happyReduction_90 = happyIn33 + (Nothing + ) + +happyReduce_91 = happySpecReduce_0 30# happyReduction_91 +happyReduction_91 = happyIn34 + (return () + ) + +happyReduce_92 = happyReduce 4# 30# happyReduction_92 +happyReduction_92 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn34 + (withSourceNote happy_var_2 happy_var_4 happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_93 = happySpecReduce_3 31# happyReduction_93 +happyReduction_93 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] + )}} + +happyReduce_94 = happySpecReduce_3 31# happyReduction_94 +happyReduction_94 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Mul [happy_var_1,happy_var_3] + )}} + +happyReduce_95 = happySpecReduce_3 31# happyReduction_95 +happyReduction_95 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] + )}} + +happyReduce_96 = happySpecReduce_3 31# happyReduction_96 +happyReduction_96 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Sub [happy_var_1,happy_var_3] + )}} + +happyReduce_97 = happySpecReduce_3 31# happyReduction_97 +happyReduction_97 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Add [happy_var_1,happy_var_3] + )}} + +happyReduce_98 = happySpecReduce_3 31# happyReduction_98 +happyReduction_98 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] + )}} + +happyReduce_99 = happySpecReduce_3 31# happyReduction_99 +happyReduction_99 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Shl [happy_var_1,happy_var_3] + )}} + +happyReduce_100 = happySpecReduce_3 31# happyReduction_100 +happyReduction_100 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_And [happy_var_1,happy_var_3] + )}} + +happyReduce_101 = happySpecReduce_3 31# happyReduction_101 +happyReduction_101 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Xor [happy_var_1,happy_var_3] + )}} + +happyReduce_102 = happySpecReduce_3 31# happyReduction_102 +happyReduction_102 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Or [happy_var_1,happy_var_3] + )}} + +happyReduce_103 = happySpecReduce_3 31# happyReduction_103 +happyReduction_103 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] + )}} + +happyReduce_104 = happySpecReduce_3 31# happyReduction_104 +happyReduction_104 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] + )}} + +happyReduce_105 = happySpecReduce_3 31# happyReduction_105 +happyReduction_105 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Le [happy_var_1,happy_var_3] + )}} + +happyReduce_106 = happySpecReduce_3 31# happyReduction_106 +happyReduction_106 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] + )}} + +happyReduce_107 = happySpecReduce_3 31# happyReduction_107 +happyReduction_107 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Ne [happy_var_1,happy_var_3] + )}} + +happyReduce_108 = happySpecReduce_3 31# happyReduction_108 +happyReduction_108 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + (mkMachOp MO_Eq [happy_var_1,happy_var_3] + )}} + +happyReduce_109 = happySpecReduce_2 31# happyReduction_109 +happyReduction_109 happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn35 + (mkMachOp MO_Not [happy_var_2] + )} + +happyReduce_110 = happySpecReduce_2 31# happyReduction_110 +happyReduction_110 happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn35 + (mkMachOp MO_S_Neg [happy_var_2] + )} + +happyReduce_111 = happyMonadReduce 5# 31# happyReduction_111 +happyReduction_111 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut36 happy_x_5 of { happy_var_5 -> + ( do { mo <- nameToMachOp happy_var_3 ; + return (mkMachOp mo [happy_var_1,happy_var_5]) })}}} + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_112 = happySpecReduce_1 31# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn35 + (happy_var_1 + )} + +happyReduce_113 = happySpecReduce_2 32# happyReduction_113 +happyReduction_113 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn36 + (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_114 = happySpecReduce_2 32# happyReduction_114 +happyReduction_114 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> + case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn36 + (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_115 = happySpecReduce_1 32# happyReduction_115 +happyReduction_115 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + happyIn36 + (do s <- code (newStringCLit happy_var_1); + return (CmmLit s) + )} + +happyReduce_116 = happySpecReduce_1 32# happyReduction_116 +happyReduction_116 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_117 = happyReduce 4# 32# happyReduction_117 +happyReduction_117 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn36 + (do e <- happy_var_3; return (CmmLoad e happy_var_1) + ) `HappyStk` happyRest}} + +happyReduce_118 = happyMonadReduce 5# 32# happyReduction_118 +happyReduction_118 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + case happyOut41 happy_x_4 of { happy_var_4 -> + ( exprOp happy_var_2 happy_var_4)}} + ) (\r -> happyReturn (happyIn36 r)) + +happyReduce_119 = happySpecReduce_3 32# happyReduction_119 +happyReduction_119 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn36 + (happy_var_2 + )} + +happyReduce_120 = happyMonadReduce 0# 33# happyReduction_120 +happyReduction_120 (happyRest) tk + = happyThen (( do dflags <- getDynFlags; return $ bWord dflags) + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_121 = happySpecReduce_2 33# happyReduction_121 +happyReduction_121 happy_x_2 + happy_x_1 + = case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn37 + (happy_var_2 + )} + +happyReduce_122 = happySpecReduce_0 34# happyReduction_122 +happyReduction_122 = happyIn38 + ([] + ) + +happyReduce_123 = happySpecReduce_1 34# happyReduction_123 +happyReduction_123 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn38 + (happy_var_1 + )} + +happyReduce_124 = happySpecReduce_1 35# happyReduction_124 +happyReduction_124 happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn39 + ([happy_var_1] + )} + +happyReduce_125 = happySpecReduce_3 35# happyReduction_125 +happyReduction_125 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut39 happy_x_3 of { happy_var_3 -> + happyIn39 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_126 = happySpecReduce_1 36# happyReduction_126 +happyReduction_126 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn40 + (do e <- happy_var_1; + return (e, inferCmmHint e) + )} + +happyReduce_127 = happyMonadReduce 2# 36# happyReduction_127 +happyReduction_127 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + ( do h <- parseCmmHint happy_var_2; + return $ do + e <- happy_var_1; return (e, h))}} + ) (\r -> happyReturn (happyIn40 r)) + +happyReduce_128 = happySpecReduce_0 37# happyReduction_128 +happyReduction_128 = happyIn41 + ([] + ) + +happyReduce_129 = happySpecReduce_1 37# happyReduction_129 +happyReduction_129 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn41 + (happy_var_1 + )} + +happyReduce_130 = happySpecReduce_1 38# happyReduction_130 +happyReduction_130 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn42 + ([ happy_var_1 ] + )} + +happyReduce_131 = happySpecReduce_3 38# happyReduction_131 +happyReduction_131 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_132 = happySpecReduce_1 39# happyReduction_132 +happyReduction_132 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn43 + (lookupName happy_var_1 + )} + +happyReduce_133 = happySpecReduce_1 39# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn43 + (return (CmmReg (CmmGlobal happy_var_1)) + )} + +happyReduce_134 = happySpecReduce_0 40# happyReduction_134 +happyReduction_134 = happyIn44 + ([] + ) + +happyReduce_135 = happyReduce 4# 40# happyReduction_135 +happyReduction_135 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_2 of { happy_var_2 -> + happyIn44 + (happy_var_2 + ) `HappyStk` happyRest} + +happyReduce_136 = happySpecReduce_1 41# happyReduction_136 +happyReduction_136 happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn45 + ([happy_var_1] + )} + +happyReduce_137 = happySpecReduce_2 41# happyReduction_137 +happyReduction_137 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn45 + ([happy_var_1] + )} + +happyReduce_138 = happySpecReduce_3 41# happyReduction_138 +happyReduction_138 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut45 happy_x_3 of { happy_var_3 -> + happyIn45 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_139 = happySpecReduce_1 42# happyReduction_139 +happyReduction_139 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn46 + (do e <- happy_var_1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) + )} + +happyReduce_140 = happyMonadReduce 2# 42# happyReduction_140 +happyReduction_140 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOut47 happy_x_2 of { happy_var_2 -> + ( do h <- parseCmmHint happy_var_1; + return $ do + e <- happy_var_2; return (e,h))}} + ) (\r -> happyReturn (happyIn46 r)) + +happyReduce_141 = happySpecReduce_1 43# happyReduction_141 +happyReduction_141 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn47 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") + )} + +happyReduce_142 = happySpecReduce_1 44# happyReduction_142 +happyReduction_142 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn48 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") + )} + +happyReduce_143 = happySpecReduce_1 44# happyReduction_143 +happyReduction_143 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn48 + (return (CmmGlobal happy_var_1) + )} + +happyReduce_144 = happySpecReduce_0 45# happyReduction_144 +happyReduction_144 = happyIn49 + (Nothing + ) + +happyReduce_145 = happySpecReduce_3 45# happyReduction_145 +happyReduction_145 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_2 of { happy_var_2 -> + happyIn49 + (Just happy_var_2 + )} + +happyReduce_146 = happySpecReduce_0 46# happyReduction_146 +happyReduction_146 = happyIn50 + ([] + ) + +happyReduce_147 = happySpecReduce_1 46# happyReduction_147 +happyReduction_147 happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn50 + (happy_var_1 + )} + +happyReduce_148 = happySpecReduce_2 47# happyReduction_148 +happyReduction_148 happy_x_2 + happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn51 + ([happy_var_1] + )} + +happyReduce_149 = happySpecReduce_1 47# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn51 + ([happy_var_1] + )} + +happyReduce_150 = happySpecReduce_3 47# happyReduction_150 +happyReduction_150 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_3 of { happy_var_3 -> + happyIn51 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_151 = happySpecReduce_2 48# happyReduction_151 +happyReduction_151 happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn52 + (newLocal happy_var_1 happy_var_2 + )}} + +happyReduce_152 = happySpecReduce_1 49# happyReduction_152 +happyReduction_152 happy_x_1 + = happyIn53 + (b8 + ) + +happyReduce_153 = happySpecReduce_1 49# happyReduction_153 +happyReduction_153 happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn53 + (happy_var_1 + )} + +happyReduce_154 = happySpecReduce_1 50# happyReduction_154 +happyReduction_154 happy_x_1 + = happyIn54 + (b16 + ) + +happyReduce_155 = happySpecReduce_1 50# happyReduction_155 +happyReduction_155 happy_x_1 + = happyIn54 + (b32 + ) + +happyReduce_156 = happySpecReduce_1 50# happyReduction_156 +happyReduction_156 happy_x_1 + = happyIn54 + (b64 + ) + +happyReduce_157 = happySpecReduce_1 50# happyReduction_157 +happyReduction_157 happy_x_1 + = happyIn54 + (b128 + ) + +happyReduce_158 = happySpecReduce_1 50# happyReduction_158 +happyReduction_158 happy_x_1 + = happyIn54 + (b256 + ) + +happyReduce_159 = happySpecReduce_1 50# happyReduction_159 +happyReduction_159 happy_x_1 + = happyIn54 + (b512 + ) + +happyReduce_160 = happySpecReduce_1 50# happyReduction_160 +happyReduction_160 happy_x_1 + = happyIn54 + (f32 + ) + +happyReduce_161 = happySpecReduce_1 50# happyReduction_161 +happyReduction_161 happy_x_1 + = happyIn54 + (f64 + ) + +happyReduce_162 = happyMonadReduce 1# 50# happyReduction_162 +happyReduction_162 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (( do dflags <- getDynFlags; return $ gcWord dflags) + ) (\r -> happyReturn (happyIn54 r)) + +happyNewToken action sts stk + = cmmlex(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ CmmT_EOF -> happyDoAction 75# tk action sts stk; + L _ (CmmT_SpecChar ':') -> cont 1#; + L _ (CmmT_SpecChar ';') -> cont 2#; + L _ (CmmT_SpecChar '{') -> cont 3#; + L _ (CmmT_SpecChar '}') -> cont 4#; + L _ (CmmT_SpecChar '[') -> cont 5#; + L _ (CmmT_SpecChar ']') -> cont 6#; + L _ (CmmT_SpecChar '(') -> cont 7#; + L _ (CmmT_SpecChar ')') -> cont 8#; + L _ (CmmT_SpecChar '=') -> cont 9#; + L _ (CmmT_SpecChar '`') -> cont 10#; + L _ (CmmT_SpecChar '~') -> cont 11#; + L _ (CmmT_SpecChar '/') -> cont 12#; + L _ (CmmT_SpecChar '*') -> cont 13#; + L _ (CmmT_SpecChar '%') -> cont 14#; + L _ (CmmT_SpecChar '-') -> cont 15#; + L _ (CmmT_SpecChar '+') -> cont 16#; + L _ (CmmT_SpecChar '&') -> cont 17#; + L _ (CmmT_SpecChar '^') -> cont 18#; + L _ (CmmT_SpecChar '|') -> cont 19#; + L _ (CmmT_SpecChar '>') -> cont 20#; + L _ (CmmT_SpecChar '<') -> cont 21#; + L _ (CmmT_SpecChar ',') -> cont 22#; + L _ (CmmT_SpecChar '!') -> cont 23#; + L _ (CmmT_DotDot) -> cont 24#; + L _ (CmmT_DoubleColon) -> cont 25#; + L _ (CmmT_Shr) -> cont 26#; + L _ (CmmT_Shl) -> cont 27#; + L _ (CmmT_Ge) -> cont 28#; + L _ (CmmT_Le) -> cont 29#; + L _ (CmmT_Eq) -> cont 30#; + L _ (CmmT_Ne) -> cont 31#; + L _ (CmmT_BoolAnd) -> cont 32#; + L _ (CmmT_BoolOr) -> cont 33#; + L _ (CmmT_CLOSURE) -> cont 34#; + L _ (CmmT_INFO_TABLE) -> cont 35#; + L _ (CmmT_INFO_TABLE_RET) -> cont 36#; + L _ (CmmT_INFO_TABLE_FUN) -> cont 37#; + L _ (CmmT_INFO_TABLE_CONSTR) -> cont 38#; + L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 39#; + L _ (CmmT_else) -> cont 40#; + L _ (CmmT_export) -> cont 41#; + L _ (CmmT_section) -> cont 42#; + L _ (CmmT_align) -> cont 43#; + L _ (CmmT_goto) -> cont 44#; + L _ (CmmT_if) -> cont 45#; + L _ (CmmT_call) -> cont 46#; + L _ (CmmT_jump) -> cont 47#; + L _ (CmmT_foreign) -> cont 48#; + L _ (CmmT_never) -> cont 49#; + L _ (CmmT_prim) -> cont 50#; + L _ (CmmT_reserve) -> cont 51#; + L _ (CmmT_return) -> cont 52#; + L _ (CmmT_returns) -> cont 53#; + L _ (CmmT_import) -> cont 54#; + L _ (CmmT_switch) -> cont 55#; + L _ (CmmT_case) -> cont 56#; + L _ (CmmT_default) -> cont 57#; + L _ (CmmT_push) -> cont 58#; + L _ (CmmT_unwind) -> cont 59#; + L _ (CmmT_bits8) -> cont 60#; + L _ (CmmT_bits16) -> cont 61#; + L _ (CmmT_bits32) -> cont 62#; + L _ (CmmT_bits64) -> cont 63#; + L _ (CmmT_bits128) -> cont 64#; + L _ (CmmT_bits256) -> cont 65#; + L _ (CmmT_bits512) -> cont 66#; + L _ (CmmT_float32) -> cont 67#; + L _ (CmmT_float64) -> cont 68#; + L _ (CmmT_gcptr) -> cont 69#; + L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 70#; + L _ (CmmT_Name happy_dollar_dollar) -> cont 71#; + L _ (CmmT_String happy_dollar_dollar) -> cont 72#; + L _ (CmmT_Int happy_dollar_dollar) -> cont 73#; + L _ (CmmT_Float happy_dollar_dollar) -> cont 74#; + _ -> happyError' tk + }) + +happyError_ 75# tk = happyError' tk +happyError_ _ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (Located CmmToken) -> P a +happyError' tk = (\token -> happyError) tk + +cmmParse = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDoSeq + + +section :: String -> Section +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "relrodata" = RelocatableReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +mkString :: String -> CmmStatic +mkString s = CmmString (map (fromIntegral.ord) s) + +-- | +-- Given an info table, decide what the entry convention for the proc +-- is. That is, for an INFO_TABLE_RET we want the return convention, +-- otherwise it is a NativeNodeCall. +-- +infoConv :: Maybe CmmInfoTable -> Convention +infoConv Nothing = NativeNodeCall +infoConv (Just info) + | isStackRep (cit_rep info) = NativeReturn + | otherwise = NativeNodeCall + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr +mkMachOp fn args = do + dflags <- getDynFlags + arg_exprs <- sequence args + return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> P (Width -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just m -> return m + +exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr) +exprOp name args_code = do + dflags <- getDynFlags + case lookupUFM (exprMacros dflags) name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) +exprMacros dflags = listToUFM [ + ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), + ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) + ] + +-- we understand a subset of C-- primitives: +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Conv W8 ), + ( "f2i16", flip MO_FS_Conv W16 ), + ( "f2i32", flip MO_FS_Conv W32 ), + ( "f2i64", flip MO_FS_Conv W64 ), + ( "i2f32", flip MO_SF_Conv W32 ), + ( "i2f64", flip MO_SF_Conv W64 ) + ] + +callishMachOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "write_barrier", MO_WriteBarrier ), + ( "memcpy", MO_Memcpy ), + ( "memset", MO_Memset ), + ( "memmove", MO_Memmove ), + + ("prefetch0",MO_Prefetch_Data 0), + ("prefetch1",MO_Prefetch_Data 1), + ("prefetch2",MO_Prefetch_Data 2), + ("prefetch3",MO_Prefetch_Data 3) + + -- ToDo: the rest, maybe + -- edit: which rest? + -- also: how do we tell CMM Lint how to type check callish macops? + ] + +parseSafety :: String -> P Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible +parseSafety str = fail ("unrecognised safety: " ++ str) + +parseCmmHint :: String -> P ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = fail ("unrecognised hint: " ++ str) + +-- labels are always pointers, so we might as well infer the hint +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) = AddrHint +inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint +inferCmmHint _ = NoHint + +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg CCCS = True +isPtrGlobalReg CurrentTSO = True +isPtrGlobalReg CurrentNursery = True +isPtrGlobalReg (VanillaReg _ VGcPtr) = True +isPtrGlobalReg _ = False + +happyError :: P a +happyError = srcParseFail + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ()) +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> fail ("unknown macro: " ++ unpackFS fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) +stmtMacros = listToUFM [ + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), + + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) + ] + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + dflags <- getDynFlags + emitUpdateFrame dflags sp mkUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + dflags <- getDynFlags + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body + +reserveStackFrame + :: CmmParse CmmExpr + -> CmmParse CmmReg + -> CmmParse () + -> CmmParse () +reserveStackFrame psize preg body = do + dflags <- getDynFlags + old_updfr_off <- getUpdFrameOff + reg <- preg + esize <- psize + let size = case constantFoldExpr dflags esize of + CmmLit (CmmInt n _) -> n + _other -> pprPanic "CmmParse: not a compile-time integer: " + (ppr esize) + let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size + emitAssign reg (CmmStackSlot Old frame) + withUpdFrameOff frame body + +profilingInfo dflags desc_str ty_str + = if not (gopt Opt_SccProfilingOn dflags) + then NoProfilingInfo + else ProfilingInfo (stringToWord8s desc_str) + (stringToWord8s ty_str) + +staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure pkg cl_label info payload + = do dflags <- getDynFlags + let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + +foreignCall + :: String + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety + -> CmmReturnInfo + -> P (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of + "C" -> return CCallConv + "stdcall" -> return StdCallConv + _ -> fail ("unknown calling convention: " ++ conv_string) + return $ do + dflags <- getDynFlags + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + let + expr' = adjCallTarget dflags conv expr args + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr' fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + dflags <- getDynFlags + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple dflags exprs updfr_off) + +mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple dflags actuals updfr_off = + mkReturn dflags e actuals updfr_off + where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) + (gcWord dflags)) + +doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () +doRawJump expr_code vols = do + dflags <- getDynFlags + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump dflags expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + dflags <- getDynFlags + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + dflags <- getDynFlags + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] + -> CmmExpr +-- On Windows, we have to add the '@N' suffix to the label when making +-- a call with the stdcall calling convention. +adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args + | platformOS (targetPlatform dflags) == OSMinGW32 + = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) + where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) + -- c.f. CgForeignCall.emitForeignCall +adjCallTarget _ _ expr _ + = expr + +primCall + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> P (CmmParse ()) +primCall results_code name args_code + = case lookupUFM callishMachOps name of + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just p -> return $ do + results <- sequence results_code + args <- sequence args_code + code (emitPrimCall (map fst results) p args) + +doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () +doStore rep addr_code val_code + = do dflags <- getDynFlags + addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let val_width = typeWidth (cmmExprType dflags val) + rep_width = typeWidth rep + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val + emitStore addr coerce_val + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +cmmIfThenElse cond then_part else_part = do + then_id <- newBlockId + join_id <- newBlockId + c <- cond + emitCond c then_id + else_part + emit (mkBranch join_id) + emitLabel then_id + then_part + -- fall through to join + emitLabel join_id + +cmmRawIf cond then_id = do + c <- cond + emitCond c then_id + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id = do + else_id <- newBlockId + emit (mkCbranch e then_id else_id) + emitLabel else_id +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id +emitCond (BoolNot e) then_id = do + else_id <- newBlockId + emitCond e else_id + emit (mkBranch then_id) + emitLabel else_id +emitCond (e1 `BoolOr` e2) then_id = do + emitCond e1 then_id + emitCond e2 then_id +emitCond (e1 `BoolAnd` e2) then_id = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId + emitCond e1 and_id + emit (mkBranch else_id) + emitLabel and_id + emitCond e2 then_id + emitLabel else_id + +-- ----------------------------------------------------------------------------- +-- Source code notes + +-- | Generate a source note spanning from "a" to "b" (inclusive), then +-- proceed with parsing. This allows debugging tools to reason about +-- locations in Cmm code. +withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c +withSourceNote a b parse = do + name <- getName + case combineSrcSpans (getLoc a) (getLoc b) of + RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse + _other -> parse + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + + -- Construct the table + let + all_entries = concat table_entries + ixs = map fst all_entries + (min,max) + | Just (l,u) <- mb_range = (l,u) + | otherwise = (minimum ixs, maximum ixs) + + entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max) + all_entries) + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit (mkSwitch expr entries) + where + emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + (_,ag) <- getCodeScoped p + l <- newBlockId + emitOutOfLine l ag + return l + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: DynFlags -> Env +initEnv dflags = listToUFM [ + ( fsLit "SIZEOF_StgHeader", + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )), + ( fsLit "SIZEOF_StgInfoTable", + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) + ] + +parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) +parseCmmFile dflags filename = do + showPass dflags "ParseCmm" + buf <- hGetStringBuffer filename + let + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (mkPState dflags buf init_loc) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + case unP cmmParse init_state of + PFailed span err -> do + let msg = mkPlainErrMsg dflags span err + return ((emptyBag, unitBag msg), Nothing) + POk pst code -> do + st <- initC + let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () + (cmm,_) = runC dflags no_module st fcode + let ms = getMessages pst + if (errorsFound dflags ms) + then return (ms, Nothing) + else do + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + return (ms, Just cmm) + where + no_module = panic "parseCmmFile: no module" +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 8 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif +{-# LINE 46 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 67 "templates/GenericTemplate.hs" #-} + +{-# LINE 77 "templates/GenericTemplate.hs" #-} + +{-# LINE 86 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/compiler/cmm/CmmParse.y.source b/compiler/cmm/CmmParse.y.source new file mode 100644 index 00000000..fd9489bd --- /dev/null +++ b/compiler/cmm/CmmParse.y.source @@ -0,0 +1,1389 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2004-2012 +-- +-- Parser for concrete Cmm. +-- +----------------------------------------------------------------------------- + +{- ----------------------------------------------------------------------------- +Note [Syntax of .cmm files] + +NOTE: You are very much on your own in .cmm. There is very little +error checking at all: + + * Type errors are detected by the (optional) -dcmm-lint pass, if you + don't turn this on then a type error will likely result in a panic + from the native code generator. + + * Passing the wrong number of arguments or arguments of the wrong + type is not detected. + +There are two ways to write .cmm code: + + (1) High-level Cmm code delegates the stack handling to GHC, and + never explicitly mentions Sp or registers. + + (2) Low-level Cmm manages the stack itself, and must know about + calling conventions. + +Whether you want high-level or low-level Cmm is indicated by the +presence of an argument list on a procedure. For example: + +foo ( gcptr a, bits32 b ) +{ + // this is high-level cmm code + + if (b > 0) { + // we can make tail calls passing arguments: + jump stg_ap_0_fast(a); + } + + push (stg_upd_frame_info, a) { + // stack frames can be explicitly pushed + + (x,y) = call wibble(a,b,3,4); + // calls pass arguments and return results using the native + // Haskell calling convention. The code generator will automatically + // construct a stack frame and an info table for the continuation. + + return (x,y); + // we can return multiple values from the current proc + } +} + +bar +{ + // this is low-level cmm code, indicated by the fact that we did not + // put an argument list on bar. + + x = R1; // the calling convention is explicit: better be careful + // that this works on all platforms! + + jump %ENTRY_CODE(Sp(0)) +} + +Here is a list of rules for high-level and low-level code. If you +break the rules, you get a panic (for using a high-level construct in +a low-level proc), or wrong code (when using low-level code in a +high-level proc). This stuff isn't checked! (TODO!) + +High-level only: + + - tail-calls with arguments, e.g. + jump stg_fun (arg1, arg2); + + - function calls: + (ret1,ret2) = call stg_fun (arg1, arg2); + + This makes a call with the NativeNodeCall convention, and the + values are returned to the following code using the NativeReturn + convention. + + - returning: + return (ret1, ret2) + + These use the NativeReturn convention to return zero or more + results to the caller. + + - pushing stack frames: + push (info_ptr, field1, ..., fieldN) { ... statements ... } + + - reserving temporary stack space: + + reserve N = x { ... } + + this reserves an area of size N (words) on the top of the stack, + and binds its address to x (a local register). Typically this is + used for allocating temporary storage for passing to foreign + functions. + + Note that if you make any native calls or invoke the GC in the + scope of the reserve block, you are responsible for ensuring that + the stack you reserved is laid out correctly with an info table. + +Low-level only: + + - References to Sp, R1-R8, F1-F4 etc. + + NB. foreign calls may clobber the argument registers R1-R8, F1-F4 + etc., so ensure they are saved into variables around foreign + calls. + + - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp + directly. + +Both high-level and low-level code can use a raw tail-call: + + jump stg_fun [R1,R2] + +NB. you *must* specify the list of GlobalRegs that are passed via a +jump, otherwise the register allocator will assume that all the +GlobalRegs are dead at the jump. + + +Calling Conventions +------------------- + +High-level procedures use the NativeNode calling convention, or the +NativeReturn convention if the 'return' keyword is used (see Stack +Frames below). + +Low-level procedures implement their own calling convention, so it can +be anything at all. + +If a low-level procedure implements the NativeNode calling convention, +then it can be called by high-level code using an ordinary function +call. In general this is hard to arrange because the calling +convention depends on the number of physical registers available for +parameter passing, but there are two cases where the calling +convention is platform-independent: + + - Zero arguments. + + - One argument of pointer or non-pointer word type; this is always + passed in R1 according to the NativeNode convention. + + - Returning a single value; these conventions are fixed and platform + independent. + + +Stack Frames +------------ + +A stack frame is written like this: + +INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN ) + return ( arg1, ..., argM ) +{ + ... code ... +} + +where field1 ... fieldN are the fields of the stack frame (with types) +arg1...argN are the values returned to the stack frame (with types). +The return values are assumed to be passed according to the +NativeReturn convention. + +On entry to the code, the stack frame looks like: + + |----------| + | fieldN | + | ... | + | field1 | + |----------| + | info_ptr | + |----------| + | argN | + | ... | <- Sp + +and some of the args may be in registers. + +We prepend the code by a copyIn of the args, and assign all the stack +frame fields to their formals. The initial "arg offset" for stack +layout purposes consists of the whole stack frame plus any args that +might be on the stack. + +A tail-call may pass a stack frame to the callee using the following +syntax: + +jump f (info_ptr, field1,..,fieldN) (arg1,..,argN) + +where info_ptr and field1..fieldN describe the stack frame, and +arg1..argN are the arguments passed to f using the NativeNodeCall +convention. + +----------------------------------------------------------------------------- -} + +{ +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module CmmParse ( parseCmmFile ) where + +import StgCmmExtCode +import CmmCallConv +import StgCmmProf +import StgCmmHeap +import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore + , emitAssign, emitOutOfLine, withUpdFrameOff + , getUpdFrameOff ) +import qualified StgCmmMonad as F +import StgCmmUtils +import StgCmmForeign +import StgCmmExpr +import StgCmmClosure +import StgCmmLayout hiding (ArgRep(..)) +import StgCmmTicky +import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) +import CoreSyn ( Tickish(SourceNote) ) + +import CmmOpt +import MkGraph +import Cmm +import CmmUtils +import CmmInfo +import BlockId +import CmmLex +import CLabel +import SMRep +import Lexer + +import CostCentre +import ForeignCall +import Module +import Platform +import Literal +import Unique +import UniqFM +import SrcLoc +import DynFlags +import StaticFlags +import ErrUtils +import StringBuffer +import FastString +import Panic +import Constants +import Outputable +import BasicTypes +import Bag ( emptyBag, unitBag ) +import Var + +import Control.Monad +import Data.Array +import Data.Char ( ord ) +import System.Exit +import Data.Maybe + +#include "HsVersions.h" +} + +%expect 0 + +%token + ':' { L _ (CmmT_SpecChar ':') } + ';' { L _ (CmmT_SpecChar ';') } + '{' { L _ (CmmT_SpecChar '{') } + '}' { L _ (CmmT_SpecChar '}') } + '[' { L _ (CmmT_SpecChar '[') } + ']' { L _ (CmmT_SpecChar ']') } + '(' { L _ (CmmT_SpecChar '(') } + ')' { L _ (CmmT_SpecChar ')') } + '=' { L _ (CmmT_SpecChar '=') } + '`' { L _ (CmmT_SpecChar '`') } + '~' { L _ (CmmT_SpecChar '~') } + '/' { L _ (CmmT_SpecChar '/') } + '*' { L _ (CmmT_SpecChar '*') } + '%' { L _ (CmmT_SpecChar '%') } + '-' { L _ (CmmT_SpecChar '-') } + '+' { L _ (CmmT_SpecChar '+') } + '&' { L _ (CmmT_SpecChar '&') } + '^' { L _ (CmmT_SpecChar '^') } + '|' { L _ (CmmT_SpecChar '|') } + '>' { L _ (CmmT_SpecChar '>') } + '<' { L _ (CmmT_SpecChar '<') } + ',' { L _ (CmmT_SpecChar ',') } + '!' { L _ (CmmT_SpecChar '!') } + + '..' { L _ (CmmT_DotDot) } + '::' { L _ (CmmT_DoubleColon) } + '>>' { L _ (CmmT_Shr) } + '<<' { L _ (CmmT_Shl) } + '>=' { L _ (CmmT_Ge) } + '<=' { L _ (CmmT_Le) } + '==' { L _ (CmmT_Eq) } + '!=' { L _ (CmmT_Ne) } + '&&' { L _ (CmmT_BoolAnd) } + '||' { L _ (CmmT_BoolOr) } + + 'CLOSURE' { L _ (CmmT_CLOSURE) } + 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } + 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } + 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } + 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } + 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } + 'else' { L _ (CmmT_else) } + 'export' { L _ (CmmT_export) } + 'section' { L _ (CmmT_section) } + 'align' { L _ (CmmT_align) } + 'goto' { L _ (CmmT_goto) } + 'if' { L _ (CmmT_if) } + 'call' { L _ (CmmT_call) } + 'jump' { L _ (CmmT_jump) } + 'foreign' { L _ (CmmT_foreign) } + 'never' { L _ (CmmT_never) } + 'prim' { L _ (CmmT_prim) } + 'reserve' { L _ (CmmT_reserve) } + 'return' { L _ (CmmT_return) } + 'returns' { L _ (CmmT_returns) } + 'import' { L _ (CmmT_import) } + 'switch' { L _ (CmmT_switch) } + 'case' { L _ (CmmT_case) } + 'default' { L _ (CmmT_default) } + 'push' { L _ (CmmT_push) } + 'unwind' { L _ (CmmT_unwind) } + 'bits8' { L _ (CmmT_bits8) } + 'bits16' { L _ (CmmT_bits16) } + 'bits32' { L _ (CmmT_bits32) } + 'bits64' { L _ (CmmT_bits64) } + 'bits128' { L _ (CmmT_bits128) } + 'bits256' { L _ (CmmT_bits256) } + 'bits512' { L _ (CmmT_bits512) } + 'float32' { L _ (CmmT_float32) } + 'float64' { L _ (CmmT_float64) } + 'gcptr' { L _ (CmmT_gcptr) } + + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } + +%monad { P } { >>= } { return } +%lexer { cmmlex } { L _ CmmT_EOF } +%name cmmParse cmm +%tokentype { Located CmmToken } + +-- C-- operator precedences, taken from the C-- spec +%right '||' -- non-std extension, called %disjoin in C-- +%right '&&' -- non-std extension, called %conjoin in C-- +%right '!' +%nonassoc '>=' '>' '<=' '<' '!=' '==' +%left '|' +%left '^' +%left '&' +%left '>>' '<<' +%left '-' '+' +%left '/' '*' '%' +%right '~' + +%% + +cmm :: { CmmParse () } + : {- empty -} { return () } + | cmmtop cmm { do $1; $2 } + +cmmtop :: { CmmParse () } + : cmmproc { $1 } + | cmmdata { $1 } + | decl { $1 } + | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' + {% withThisPackage $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $3 $5 (map getLit lits) } + +-- The only static closures in the RTS are dummy closures like +-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need +-- to provide the full generality of static closures here. +-- In particular: +-- * CCS can always be CCS_DONT_CARE +-- * closure is always extern +-- * payload is always empty +-- * we can derive closure and info table labels from a single NAME + +cmmdata :: { CmmParse () } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) } + +data_label :: { CmmParse CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } + +statics :: { [CmmParse [CmmStatic]] } + : {- empty -} { [] } + | static statics { $1 : $2 } + +-- Strings aren't used much in the RTS HC code, so it doesn't seem +-- worth allowing inline strings. C-- doesn't allow them anyway. +static :: { CmmParse [CmmStatic] } + : type expr ';' { do e <- $2; + return [CmmStaticLit (getLit e)] } + | type ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1))] } + | 'bits8' '[' ']' STRING ';' { return [mkString $4] } + | 'bits8' '[' INT ']' ';' { return [CmmUninitialised + (fromIntegral $3)] } + | typenot8 '[' INT ']' ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1) * + fromIntegral $3)] } + | 'CLOSURE' '(' NAME lits ')' + { do { lits <- sequence $4 + ; dflags <- getDynFlags + ; return $ map CmmStaticLit $ + mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. + dontCareCCS (map getLit lits) [] [] [] } } + -- arrays of closures required for the CHARLIKE & INTLIKE arrays + +lits :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | ',' expr lits { $2 : $3 } + +cmmproc :: { CmmParse () } + : info maybe_conv maybe_formals maybe_body + { do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeScoped $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- $1; + dflags <- getDynFlags; + formals <- sequence (fromMaybe [] $3); + withName (showSDoc dflags (ppr entry_ret_label)) + $4; + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust $3 + code (emitProcWithStackFrame $2 info + entry_ret_label stk_formals formals agraph + do_layout ) } + +maybe_conv :: { Convention } + : {- empty -} { NativeNodeCall } + | 'return' { NativeReturn } + +maybe_body :: { CmmParse () } + : ';' { return () } + | '{' body '}' { withSourceNote $1 $3 $2 } + +info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } + : NAME + {% withThisPackage $ \pkg -> + do newFunctionName $1 pkg + return (mkCmmCodeLabel pkg $1, Nothing, []) } + + + | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, closure type, description, type + {% withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 + rep = mkRTSRep (fromIntegral $9) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) Thunk + -- not really Thunk, but that makes the info table + -- we want. + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + -- ptrs, nptrs, closure type, description, type, fun type + {% withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $11 $13 + ty = Fun 0 (ArgSpec (fromIntegral $15)) + -- Arity zero, arg_type $15 + rep = mkRTSRep (fromIntegral $9) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + -- we leave most of the fields zero here. This is only used + -- to generate the BCO info table in the RTS at the moment. + + | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, tag, closure type, description, type + {% withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $13 $15 + ty = Constr (fromIntegral $9) -- Tag + (stringToWord8s $13) + rep = mkRTSRep (fromIntegral $11) $ + mkHeapRep dflags False (fromIntegral $5) + (fromIntegral $7) ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + -- If profiling is on, this string gets duplicated, + -- but that's the way the old code did it we can fix it some other time. + + | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + -- selector, closure type, description, type + {% withThisPackage $ \pkg -> + do dflags <- getDynFlags + let prof = profilingInfo dflags $9 $11 + ty = ThunkSelector (fromIntegral $5) + rep = mkRTSRep (fromIntegral $7) $ + mkHeapRep dflags False 0 0 ty + return (mkCmmEntryLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ')' + -- closure type (no live regs) + {% withThisPackage $ \pkg -> + do let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] + return (mkCmmRetLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' + -- closure type, live regs + {% withThisPackage $ \pkg -> + do dflags <- getDynFlags + live <- sequence $7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness dflags (map Just (drop 1 live)) + rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap + return (mkCmmRetLabel pkg $3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + live) } + +body :: { CmmParse () } + : {- empty -} { return () } + | decl body { do $1; $2 } + | stmt body { do $1; $2 } + +decl :: { CmmParse () } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' importNames ';' { mapM_ newImport $2 } + | 'export' names ';' { return () } -- ignore exports + + +-- an imported function name, with optional packageId +importNames + :: { [(FastString, CLabel)] } + : importName { [$1] } + | importName ',' importNames { $1 : $3 } + +importName + :: { (FastString, CLabel) } + + -- A label imported without an explicit packageId. + -- These are taken to come frome some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- as previous 'NAME', but 'IsData' + | 'CLOSURE' NAME + { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) } + + -- A label imported with an explicit packageId. + | STRING NAME + { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) } + + +names :: { [FastString] } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } + +stmt :: { CmmParse () } + : ';' { return () } + + | NAME ':' + { do l <- newLabel $1; emitLabel l } + + + + | lreg '=' expr ';' + { do reg <- $1; e <- $3; emitAssign reg e } + | type '[' expr ']' '=' expr ';' + { doStore $1 $3 $6 } + + -- Gah! We really want to say "foreign_results" but that causes + -- a shift/reduce conflict with assignment. We either + -- we expand out the no-result and single result cases or + -- we tweak the syntax to avoid the conflict. The later + -- option is taken here because the other way would require + -- multiple levels of expanding and get unwieldy. + | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $8 $9 } + | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' + {% primCall $1 $4 $6 } + -- stmt-level macros, stealing syntax from ordinary C-- function calls. + -- Perhaps we ought to use the %%-form? + | NAME '(' exprs0 ')' ';' + {% stmtMacro $1 $3 } + | 'switch' maybe_range expr '{' arms default '}' + { do as <- sequence $5; doSwitch $2 $3 as $6 } + | 'goto' NAME ';' + { do l <- lookupLabel $2; emit (mkBranch l) } + | 'return' '(' exprs0 ')' ';' + { doReturn $3 } + | 'jump' expr vols ';' + { doRawJump $2 $3 } + | 'jump' expr '(' exprs0 ')' ';' + { doJumpWithStack $2 [] $4 } + | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';' + { doJumpWithStack $2 $4 $7 } + | 'call' expr '(' exprs0 ')' ';' + { doCall $2 [] $4 } + | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' + { doCall $6 $2 $8 } + | 'if' bool_expr 'goto' NAME + { do l <- lookupLabel $4; cmmRawIf $2 l } + | 'if' bool_expr '{' body '}' else + { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 } + | 'push' '(' exprs0 ')' maybe_body + { pushStackFrame $3 $5 } + | 'reserve' expr '=' lreg maybe_body + { reserveStackFrame $2 $4 $5 } + | 'unwind' GLOBALREG '=' expr + { $4 >>= code . emitUnwind $2 } + +foreignLabel :: { CmmParse CmmExpr } + : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) } + +opt_never_returns :: { CmmReturnInfo } + : { CmmMayReturn } + | 'never' 'returns' { CmmNeverReturns } + +bool_expr :: { CmmParse BoolExpr } + : bool_op { $1 } + | expr { do e <- $1; return (BoolTest e) } + +bool_op :: { CmmParse BoolExpr } + : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolAnd e1 e2) } + | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolOr e1 e2) } + | '!' bool_expr { do e <- $2; return (BoolNot e) } + | '(' bool_op ')' { $2 } + +safety :: { Safety } + : {- empty -} { PlayRisky } + | STRING {% parseSafety $1 } + +vols :: { [GlobalReg] } + : '[' ']' { [] } + | '[' '*' ']' {% do df <- getDynFlags + ; return (realArgRegsCover df) } + -- All of them. See comment attached + -- to realArgRegsCover + | '[' globals ']' { $2 } + +globals :: { [GlobalReg] } + : GLOBALREG { [$1] } + | GLOBALREG ',' globals { $1 : $3 } + +maybe_range :: { Maybe (Int,Int) } + : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } + | {- empty -} { Nothing } + +arms :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] } + : {- empty -} { [] } + | arm arms { $1 : $2 } + +arm :: { CmmParse ([Int],Either BlockId (CmmParse ())) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } + +arm_body :: { CmmParse (Either BlockId (CmmParse ())) } + : '{' body '}' { return (Right (withSourceNote $1 $3 $2)) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } + +ints :: { [Int] } + : INT { [ fromIntegral $1 ] } + | INT ',' ints { fromIntegral $1 : $3 } + +default :: { Maybe (CmmParse ()) } + : 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) } + -- taking a few liberties with the C-- syntax here; C-- doesn't have + -- 'default' branches + | {- empty -} { Nothing } + +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. +else :: { CmmParse () } + : {- empty -} { return () } + | 'else' '{' body '}' { withSourceNote $2 $4 $3 } + +-- we have to write this out longhand so that Happy's precedence rules +-- can kick in. +expr :: { CmmParse CmmExpr } + : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } + | expr '*' expr { mkMachOp MO_Mul [$1,$3] } + | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } + | expr '-' expr { mkMachOp MO_Sub [$1,$3] } + | expr '+' expr { mkMachOp MO_Add [$1,$3] } + | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } + | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } + | expr '&' expr { mkMachOp MO_And [$1,$3] } + | expr '^' expr { mkMachOp MO_Xor [$1,$3] } + | expr '|' expr { mkMachOp MO_Or [$1,$3] } + | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } + | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } + | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } + | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } + | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } + | expr '==' expr { mkMachOp MO_Eq [$1,$3] } + | '~' expr { mkMachOp MO_Not [$2] } + | '-' expr { mkMachOp MO_S_Neg [$2] } + | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; + return (mkMachOp mo [$1,$5]) } } + | expr0 { $1 } + +expr0 :: { CmmParse CmmExpr } + : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } + | STRING { do s <- code (newStringCLit $1); + return (CmmLit s) } + | reg { $1 } + | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } + | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } + | '(' expr ')' { $2 } + + +-- leaving out the type of a literal gives you the native word size in C-- +maybe_ty :: { CmmType } + : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } + | '::' type { $2 } + +cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] } + : {- empty -} { [] } + | cmm_hint_exprs { $1 } + +cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } + +cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) } + : expr { do e <- $1; + return (e, inferCmmHint e) } + | expr STRING {% do h <- parseCmmHint $2; + return $ do + e <- $1; return (e, h) } + +exprs0 :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | exprs { $1 } + +exprs :: { [CmmParse CmmExpr] } + : expr { [ $1 ] } + | expr ',' exprs { $1 : $3 } + +reg :: { CmmParse CmmExpr } + : NAME { lookupName $1 } + | GLOBALREG { return (CmmReg (CmmGlobal $1)) } + +foreign_results :: { [CmmParse (LocalReg, ForeignHint)] } + : {- empty -} { [] } + | '(' foreign_formals ')' '=' { $2 } + +foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] } + : foreign_formal { [$1] } + | foreign_formal ',' { [$1] } + | foreign_formal ',' foreign_formals { $1 : $3 } + +foreign_formal :: { CmmParse (LocalReg, ForeignHint) } + : local_lreg { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) } + | STRING local_lreg {% do h <- parseCmmHint $1; + return $ do + e <- $2; return (e,h) } + +local_lreg :: { CmmParse LocalReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } + +lreg :: { CmmParse CmmReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } + | GLOBALREG { return (CmmGlobal $1) } + +maybe_formals :: { Maybe [CmmParse LocalReg] } + : {- empty -} { Nothing } + | '(' formals0 ')' { Just $2 } + +formals0 :: { [CmmParse LocalReg] } + : {- empty -} { [] } + | formals { $1 } + +formals :: { [CmmParse LocalReg] } + : formal ',' { [$1] } + | formal { [$1] } + | formal ',' formals { $1 : $3 } + +formal :: { CmmParse LocalReg } + : type NAME { newLocal $1 $2 } + +type :: { CmmType } + : 'bits8' { b8 } + | typenot8 { $1 } + +typenot8 :: { CmmType } + : 'bits16' { b16 } + | 'bits32' { b32 } + | 'bits64' { b64 } + | 'bits128' { b128 } + | 'bits256' { b256 } + | 'bits512' { b512 } + | 'float32' { f32 } + | 'float64' { f64 } + | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } + +{ +section :: String -> Section +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "relrodata" = RelocatableReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +mkString :: String -> CmmStatic +mkString s = CmmString (map (fromIntegral.ord) s) + +-- | +-- Given an info table, decide what the entry convention for the proc +-- is. That is, for an INFO_TABLE_RET we want the return convention, +-- otherwise it is a NativeNodeCall. +-- +infoConv :: Maybe CmmInfoTable -> Convention +infoConv Nothing = NativeNodeCall +infoConv (Just info) + | isStackRep (cit_rep info) = NativeReturn + | otherwise = NativeNodeCall + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr +mkMachOp fn args = do + dflags <- getDynFlags + arg_exprs <- sequence args + return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> P (Width -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just m -> return m + +exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr) +exprOp name args_code = do + dflags <- getDynFlags + case lookupUFM (exprMacros dflags) name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) +exprMacros dflags = listToUFM [ + ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), + ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) + ] + +-- we understand a subset of C-- primitives: +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Conv W8 ), + ( "f2i16", flip MO_FS_Conv W16 ), + ( "f2i32", flip MO_FS_Conv W32 ), + ( "f2i64", flip MO_FS_Conv W64 ), + ( "i2f32", flip MO_SF_Conv W32 ), + ( "i2f64", flip MO_SF_Conv W64 ) + ] + +callishMachOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "write_barrier", MO_WriteBarrier ), + ( "memcpy", MO_Memcpy ), + ( "memset", MO_Memset ), + ( "memmove", MO_Memmove ), + + ("prefetch0",MO_Prefetch_Data 0), + ("prefetch1",MO_Prefetch_Data 1), + ("prefetch2",MO_Prefetch_Data 2), + ("prefetch3",MO_Prefetch_Data 3) + + -- ToDo: the rest, maybe + -- edit: which rest? + -- also: how do we tell CMM Lint how to type check callish macops? + ] + +parseSafety :: String -> P Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible +parseSafety str = fail ("unrecognised safety: " ++ str) + +parseCmmHint :: String -> P ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = fail ("unrecognised hint: " ++ str) + +-- labels are always pointers, so we might as well infer the hint +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) = AddrHint +inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint +inferCmmHint _ = NoHint + +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg CCCS = True +isPtrGlobalReg CurrentTSO = True +isPtrGlobalReg CurrentNursery = True +isPtrGlobalReg (VanillaReg _ VGcPtr) = True +isPtrGlobalReg _ = False + +happyError :: P a +happyError = srcParseFail + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ()) +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> fail ("unknown macro: " ++ unpackFS fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) +stmtMacros = listToUFM [ + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), + + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) + ] + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + dflags <- getDynFlags + emitUpdateFrame dflags sp mkUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + dflags <- getDynFlags + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body + +reserveStackFrame + :: CmmParse CmmExpr + -> CmmParse CmmReg + -> CmmParse () + -> CmmParse () +reserveStackFrame psize preg body = do + dflags <- getDynFlags + old_updfr_off <- getUpdFrameOff + reg <- preg + esize <- psize + let size = case constantFoldExpr dflags esize of + CmmLit (CmmInt n _) -> n + _other -> pprPanic "CmmParse: not a compile-time integer: " + (ppr esize) + let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size + emitAssign reg (CmmStackSlot Old frame) + withUpdFrameOff frame body + +profilingInfo dflags desc_str ty_str + = if not (gopt Opt_SccProfilingOn dflags) + then NoProfilingInfo + else ProfilingInfo (stringToWord8s desc_str) + (stringToWord8s ty_str) + +staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure pkg cl_label info payload + = do dflags <- getDynFlags + let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + +foreignCall + :: String + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety + -> CmmReturnInfo + -> P (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of + "C" -> return CCallConv + "stdcall" -> return StdCallConv + _ -> fail ("unknown calling convention: " ++ conv_string) + return $ do + dflags <- getDynFlags + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + let + expr' = adjCallTarget dflags conv expr args + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr' fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + dflags <- getDynFlags + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple dflags exprs updfr_off) + +mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple dflags actuals updfr_off = + mkReturn dflags e actuals updfr_off + where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off) + (gcWord dflags)) + +doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () +doRawJump expr_code vols = do + dflags <- getDynFlags + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump dflags expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + dflags <- getDynFlags + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + dflags <- getDynFlags + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] + -> CmmExpr +-- On Windows, we have to add the '@N' suffix to the label when making +-- a call with the stdcall calling convention. +adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args + | platformOS (targetPlatform dflags) == OSMinGW32 + = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) + where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) + -- c.f. CgForeignCall.emitForeignCall +adjCallTarget _ _ expr _ + = expr + +primCall + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> P (CmmParse ()) +primCall results_code name args_code + = case lookupUFM callishMachOps name of + Nothing -> fail ("unknown primitive " ++ unpackFS name) + Just p -> return $ do + results <- sequence results_code + args <- sequence args_code + code (emitPrimCall (map fst results) p args) + +doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () +doStore rep addr_code val_code + = do dflags <- getDynFlags + addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let val_width = typeWidth (cmmExprType dflags val) + rep_width = typeWidth rep + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val + emitStore addr coerce_val + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +cmmIfThenElse cond then_part else_part = do + then_id <- newBlockId + join_id <- newBlockId + c <- cond + emitCond c then_id + else_part + emit (mkBranch join_id) + emitLabel then_id + then_part + -- fall through to join + emitLabel join_id + +cmmRawIf cond then_id = do + c <- cond + emitCond c then_id + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id = do + else_id <- newBlockId + emit (mkCbranch e then_id else_id) + emitLabel else_id +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id +emitCond (BoolNot e) then_id = do + else_id <- newBlockId + emitCond e else_id + emit (mkBranch then_id) + emitLabel else_id +emitCond (e1 `BoolOr` e2) then_id = do + emitCond e1 then_id + emitCond e2 then_id +emitCond (e1 `BoolAnd` e2) then_id = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId + emitCond e1 and_id + emit (mkBranch else_id) + emitLabel and_id + emitCond e2 then_id + emitLabel else_id + +-- ----------------------------------------------------------------------------- +-- Source code notes + +-- | Generate a source note spanning from "a" to "b" (inclusive), then +-- proceed with parsing. This allows debugging tools to reason about +-- locations in Cmm code. +withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c +withSourceNote a b parse = do + name <- getName + case combineSrcSpans (getLoc a) (getLoc b) of + RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse + _other -> parse + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + + -- Construct the table + let + all_entries = concat table_entries + ixs = map fst all_entries + (min,max) + | Just (l,u) <- mb_range = (l,u) + | otherwise = (minimum ixs, maximum ixs) + + entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max) + all_entries) + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit (mkSwitch expr entries) + where + emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + (_,ag) <- getCodeScoped p + l <- newBlockId + emitOutOfLine l ag + return l + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: DynFlags -> Env +initEnv dflags = listToUFM [ + ( fsLit "SIZEOF_StgHeader", + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )), + ( fsLit "SIZEOF_StgInfoTable", + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) + ] + +parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) +parseCmmFile dflags filename = do + showPass dflags "ParseCmm" + buf <- hGetStringBuffer filename + let + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (mkPState dflags buf init_loc) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + case unP cmmParse init_state of + PFailed span err -> do + let msg = mkPlainErrMsg dflags span err + return ((emptyBag, unitBag msg), Nothing) + POk pst code -> do + st <- initC + let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return () + (cmm,_) = runC dflags no_module st fcode + let ms = getMessages pst + if (errorsFound dflags ms) + then return (ms, Nothing) + else do + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + return (ms, Just cmm) + where + no_module = panic "parseCmmFile: no module" +} diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs new file mode 100644 index 00000000..af4f62a4 --- /dev/null +++ b/compiler/cmm/CmmPipeline.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE BangPatterns #-} + +module CmmPipeline ( + -- | Converts C-- with an implicit stack and native C-- calls into + -- optimized, CPS converted and native-call-less C--. The latter + -- C-- can be used to generate assembly. + cmmPipeline +) where + +import Cmm +import CmmLint +import CmmBuildInfoTables +import CmmCommonBlockElim +import CmmProcPoint +import CmmContFlowOpt +import CmmLayoutStack +import CmmSink +import Hoopl + +import UniqSupply +import DynFlags +import ErrUtils +import HscTypes +import Control.Monad +import Outputable +import Platform + +----------------------------------------------------------------------------- +-- | Top level driver for C-- pipeline +----------------------------------------------------------------------------- + +cmmPipeline :: HscEnv -- Compilation env including + -- dynamic flags: -dcmm-lint -ddump-cps-cmm + -> TopSRT -- SRT table and accumulating list of compiled procs + -> CmmGroup -- Input C-- with Procedures + -> IO (TopSRT, CmmGroup) -- Output CPS transformed C-- + +cmmPipeline hsc_env topSRT prog = + do let dflags = hsc_dflags hsc_env + + tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog + + (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops + dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms + + return (topSRT, cmms) + + +cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) +cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) +cpsTop hsc_env proc = + do + ----------- Control-flow optimisations ---------------------------------- + + -- The first round of control-flow optimisation speeds up the + -- later passes by removing lots of empty blocks, so we do it + -- even when optimisation isn't turned on. + -- + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} + return $ cmmCfgOptsProc splitting_proc_points proc + dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + let !TopInfo {stack_info=StackInfo { arg_space = entry_off + , do_layout = do_layout }} = h + + ----------- Eliminate common blocks ------------------------------------- + g <- {-# SCC "elimCommonBlocks" #-} + condPass Opt_CmmElimCommonBlocks elimCommonBlocks g + Opt_D_dump_cmm_cbe "Post common block elimination" + + -- Any work storing block Labels must be performed _after_ + -- elimCommonBlocks + + ----------- Proc points ------------------------------------------------- + let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + proc_points <- + if splitting_proc_points + then do + pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ + minimalProcPointSet (targetPlatform dflags) call_pps g + dumpIfSet_dyn dflags Opt_D_dump_cmm "Proc points" + (ppr l $$ ppr pp $$ ppr g) + return pp + else + return call_pps + + ----------- Layout the stack and manifest Sp ---------------------------- + (g, stackmaps) <- + {-# SCC "layoutStack" #-} + if do_layout + then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + else return (g, mapEmpty) + dump Opt_D_dump_cmm_sp "Layout Stack" g + + ----------- Sink and inline assignments -------------------------------- + g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] + condPass Opt_CmmSink (cmmSink dflags) g + Opt_D_dump_cmm_sink "Sink assignments" + + ------------- CAF analysis ---------------------------------------------- + let cafEnv = {-# SCC "cafAnal" #-} cafAnal g + dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv) + + g <- if splitting_proc_points + then do + ------------- Split into separate procedures ----------------------- + pp_map <- {-# SCC "procPointAnalysis" #-} runUniqSM $ + procPointAnalysis proc_points g + dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map + g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ + splitAtProcPoints dflags l call_pps proc_points pp_map + (CmmProc h l v g) + dumps Opt_D_dump_cmm_split "Post splitting" g + return g + else do + -- attach info tables to return points + return $ [attachContInfoTables call_pps (CmmProc h l v g)] + + ------------- Populate info tables with stack info ----------------- + g <- {-# SCC "setInfoTableStackMap" #-} + return $ map (setInfoTableStackMap dflags stackmaps) g + dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g + + ----------- Control-flow optimisations ----------------------------- + g <- {-# SCC "cmmCfgOpts(2)" #-} + return $ if optLevel dflags >= 1 + then map (cmmCfgOptsProc splitting_proc_points) g + else g + g <- return (map removeUnreachableBlocksProc g) + -- See Note [unreachable blocks] + dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g + + return (cafEnv, g) + + where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + dump = dumpGraph dflags + + dumps flag name + = mapM_ (dumpWith dflags flag name) + + condPass flag pass g dumpflag dumpname = + if gopt flag dflags + then do + g <- return $ pass g + dump dumpflag dumpname g + return g + else return g + + + -- we don't need to split proc points for the NCG, unless + -- tablesNextToCode is off. The latter is because we have no + -- label to put on info tables for basic blocks that are not + -- the entry point. + splitting_proc_points = hscTarget dflags /= HscAsm + || not (tablesNextToCode dflags) + || -- Note [inconsistent-pic-reg] + usingInconsistentPicReg + usingInconsistentPicReg + = case (platformArch platform, platformOS platform, gopt Opt_PIC dflags) + of (ArchX86, OSDarwin, pic) -> pic + (ArchPPC, OSDarwin, pic) -> pic + _ -> False + +-- Note [Sinking after stack layout] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In the past we considered running sinking pass also before stack +-- layout, but after making some measurements we realized that: +-- +-- a) running sinking only before stack layout produces slower +-- code than running sinking only before stack layout +-- +-- b) running sinking both before and after stack layout produces +-- code that has the same performance as when running sinking +-- only after stack layout. +-- +-- In other words sinking before stack layout doesn't buy as anything. +-- +-- An interesting question is "why is it better to run sinking after +-- stack layout"? It seems that the major reason are stores and loads +-- generated by stack layout. Consider this code before stack layout: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[(young + 8)] = c1D; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Stack layout pass will save all local variables live across a call +-- (_c1C, _c1B and _c1A in this example) on the stack just before +-- making a call and reload them from the stack after returning from a +-- call: +-- +-- c1E: +-- _c1C::P64 = R3; +-- _c1B::P64 = R2; +-- _c1A::P64 = R1; +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = _c1A::P64; +-- P64[Sp - 16] = _c1B::P64; +-- P64[Sp - 8] = _c1C::P64; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- _c1A::P64 = P64[Sp + 8]; +-- _c1B::P64 = P64[Sp + 16]; +-- _c1C::P64 = P64[Sp + 24]; +-- R3 = _c1C::P64; +-- R2 = _c1B::P64; +-- R1 = _c1A::P64; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- If we don't run sinking pass after stack layout we are basically +-- left with such code. However, running sinking on this code can lead +-- to significant improvements: +-- +-- c1E: +-- I64[Sp - 32] = c1D; +-- P64[Sp - 24] = R1; +-- P64[Sp - 16] = R2; +-- P64[Sp - 8] = R3; +-- Sp = Sp - 32; +-- call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8; +-- c1D: +-- R3 = P64[Sp + 24]; +-- R2 = P64[Sp + 16]; +-- R1 = P64[Sp + 8]; +-- Sp = Sp + 32; +-- call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8; +-- +-- Now we only have 9 assignments instead of 15. +-- +-- There is one case when running sinking before stack layout could +-- be beneficial. Consider this: +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...x...y... +-- +-- Since both x and y are live across a call to f, they will be stored +-- on the stack during stack layout and restored after the call: +-- +-- L1: +-- x = y +-- P64[Sp - 24] = L2 +-- P64[Sp - 16] = x +-- P64[Sp - 8] = y +-- Sp = Sp - 24 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 16] +-- x = P64[Sp + 8] +-- Sp = Sp + 24 +-- ...x...y... +-- +-- However, if we run sinking before stack layout we would propagate x +-- to its usage place (both x and y must be local register for this to +-- be possible - global registers cannot be floated past a call): +-- +-- L1: +-- x = y +-- call f() returns L2 +-- L2: ...y...y... +-- +-- Thus making x dead at the call to f(). If we ran stack layout now +-- we would generate less stores and loads: +-- +-- L1: +-- x = y +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = y +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- y = P64[Sp + 8] +-- Sp = Sp + 16 +-- ...y...y... +-- +-- But since we don't see any benefits from running sinking befroe stack +-- layout, this situation probably doesn't arise too often in practice. +-- + +{- Note [inconsistent-pic-reg] + +On x86/Darwin, PIC is implemented by inserting a sequence like + + call 1f + 1: popl %reg + +at the proc entry point, and then referring to labels as offsets from +%reg. If we don't split proc points, then we could have many entry +points in a proc that would need this sequence, and each entry point +would then get a different value for %reg. If there are any join +points, then at the join point we don't have a consistent value for +%reg, so we don't know how to refer to labels. + +Hence, on x86/Darwin, we have to split proc points, and then each proc +point will get its own PIC initialisation sequence. + +The situation is the same for ppc/Darwin. We use essentially the same +sequence to load the program counter onto reg: + + bcl 20,31,1f + 1: mflr reg + +This isn't an issue on x86/ELF, where the sequence is + + call 1f + 1: popl %reg + addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg + +so %reg always has a consistent value: the address of +_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. + +-} + +{- Note [unreachable blocks] + +The control-flow optimiser sometimes leaves unreachable blocks behind +containing junk code. These aren't necessarily a problem, but +removing them is good because it might save time in the native code +generator later. + +-} + +runUniqSM :: UniqSM a -> IO a +runUniqSM m = do + us <- mkSplitUniqSupply 'u' + return (initUs_ us m) + + +dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph dflags flag name g = do + when (gopt Opt_DoCmmLinting dflags) $ do_lint g + dumpWith dflags flag name g + where + do_lint g = case cmmLintGraph dflags g of + Just err -> do { fatalErrorMsg dflags err + ; ghcExit dflags 1 + } + Nothing -> return () + +dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO () +dumpWith dflags flag txt g = do + -- ToDo: No easy way of say "dump all the cmm, *and* split + -- them into files." Also, -ddump-cmm doesn't play nicely + -- with -ddump-to-file, since the headers get omitted. + dumpIfSet_dyn dflags flag txt (ppr g) + when (not (dopt flag dflags)) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g) diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs new file mode 100644 index 00000000..2add4741 --- /dev/null +++ b/compiler/cmm/CmmProcPoint.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE GADTs, DisambiguateRecordFields #-} + +module CmmProcPoint + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , splitAtProcPoints, procPointAnalysis + , attachContInfoTables + ) +where + +import Prelude hiding (last, unzip, succ, zip) + +import DynFlags +import BlockId +import CLabel +import Cmm +import PprCmm () +import CmmUtils +import CmmInfo +import CmmLive (cmmGlobalLiveness) +import Data.List (sortBy) +import Maybes +import Control.Monad +import Outputable +import Platform +import UniqSupply + +import Hoopl + +-- Compute a minimal set of proc points for a control-flow graph. + +-- Determine a protocol for each proc point (which live variables will +-- be passed as arguments and which will be on the stack). + +{- +A proc point is a basic block that, after CPS transformation, will +start a new function. The entry block of the original function is a +proc point, as is the continuation of each function call. +A third kind of proc point arises if we want to avoid copying code. +Suppose we have code like the following: + + f() { + if (...) { ..1..; call foo(); ..2..} + else { ..3..; call bar(); ..4..} + x = y + z; + return x; + } + +The statement 'x = y + z' can be reached from two different proc +points: the continuations of foo() and bar(). We would prefer not to +put a copy in each continuation; instead we would like 'x = y + z' to +be the start of a new procedure to which the continuations can jump: + + f_cps () { + if (...) { ..1..; push k_foo; jump foo_cps(); } + else { ..3..; push k_bar; jump bar_cps(); } + } + k_foo() { ..2..; jump k_join(y, z); } + k_bar() { ..4..; jump k_join(y, z); } + k_join(y, z) { x = y + z; return x; } + +You might think then that a criterion to make a node a proc point is +that it is directly reached by two distinct proc points. (Note +[Direct reachability].) But this criterion is a bit too simple; for +example, 'return x' is also reached by two proc points, yet there is +no point in pulling it out of k_join. A good criterion would be to +say that a node should be made a proc point if it is reached by a set +of proc points that is different than its immediate dominator. NR +believes this criterion can be shown to produce a minimum set of proc +points, and given a dominator tree, the proc points can be chosen in +time linear in the number of blocks. Lacking a dominator analysis, +however, we turn instead to an iterative solution, starting with no +proc points and adding them according to these rules: + + 1. The entry block is a proc point. + 2. The continuation of a call is a proc point. + 3. A node is a proc point if it is directly reached by more proc + points than one of its predecessors. + +Because we don't understand the problem very well, we apply rule 3 at +most once per iteration, then recompute the reachability information. +(See Note [No simple dataflow].) The choice of the new proc point is +arbitrary, and I don't know if the choice affects the final solution, +so I don't know if the number of proc points chosen is the +minimum---but the set will be minimal. + + + +Note [Proc-point analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given a specified set of proc-points (a set of block-ids), "proc-point +analysis" figures out, for every block, which proc-point it belongs to. +All the blocks belonging to proc-point P will constitute a single +top-level C procedure. + +A non-proc-point block B "belongs to" a proc-point P iff B is +reachable from P without going through another proc-point. + +Invariant: a block B should belong to at most one proc-point; if it +belongs to two, that's a bug. + +Note [Non-existing proc-points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +On some architectures it might happen that the list of proc-points +computed before stack layout pass will be invalidated by the stack +layout. This will happen if stack layout removes from the graph +blocks that were determined to be proc-points. Later on in the pipeline +we use list of proc-points to perform [Proc-point analysis], but +if a proc-point does not exist anymore then we will get compiler panic. +See #8205. +-} + +type ProcPointSet = BlockSet + +data Status + = ReachedBy ProcPointSet -- set of proc points that directly reach the block + | ProcPoint -- this block is itself a proc point + +instance Outputable Status where + ppr (ReachedBy ps) + | setNull ps = text "" + | otherwise = text "reached by" <+> + (hsep $ punctuate comma $ map ppr $ setElems ps) + ppr ProcPoint = text "" + +-------------------------------------------------- +-- Proc point analysis + +procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status) +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from +-- See Note [Proc-point analysis] +procPointAnalysis procPoints g@(CmmGraph {g_graph = graph}) = + -- pprTrace "procPointAnalysis" (ppr procPoints) $ + dataflowAnalFwdBlocks g initProcPoints $ analFwd lattice forward + where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints, + id `setMember` labelsInGraph ] + -- See Note [Non-existing proc-points] + labelsInGraph = labelsDefined graph +-- transfer equations + +forward :: FwdTransfer CmmNode Status +forward = mkFTransfer3 first middle last + where + first :: CmmNode C O -> Status -> Status + first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id + first _ x = x + + middle _ x = x + + last :: CmmNode O C -> Status -> FactBase Status + last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l) + +lattice :: DataflowLattice Status +lattice = DataflowLattice "direct proc-point reachability" unreached add_to + where unreached = ReachedBy setEmpty + add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint) + add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) + -- because of previous case + add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) + | setSize union > setSize p = (SomeChange, ReachedBy union) + | otherwise = (NoChange, ReachedBy p) + where + union = setUnion p' p + +---------------------------------------------------------------------- + +-- It is worth distinguishing two sets of proc points: those that are +-- induced by calls in the original graph and those that are +-- introduced because they're reachable from multiple proc points. +-- +-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +callProcPoints :: CmmGraph -> ProcPointSet +callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g + where add :: CmmBlock -> BlockSet -> BlockSet + add b set = case lastNode b of + CmmCall {cml_cont = Just k} -> setInsert k set + CmmForeignCall {succ=k} -> setInsert k set + _ -> set + +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph + -> UniqSM ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure out the minimal set of necessary proc-points +minimalProcPointSet platform callProcPoints g + = extendPPSet platform g (postorderDfs g) callProcPoints + +extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet +extendPPSet platform g blocks procPoints = + do env <- procPointAnalysis procPoints g + -- pprTrace "extensPPSet" (ppr env) $ return () + let add block pps = let id = entryLabel block + in case mapLookup id env of + Just ProcPoint -> setInsert id pps + _ -> pps + procPoints' = foldGraphBlocks add setEmpty g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b = + let nreached id = case mapLookup id env `orElse` + pprPanic "no ppt" (ppr id <+> ppr b) of + ProcPoint -> 1 + ReachedBy ps -> setSize ps + block_procpoints = nreached (entryLabel b) + -- | Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (setMember succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ successors b +{- + case newPoints of + [] -> return procPoints' + pps -> extendPPSet g blocks + (foldl extendBlockSet procPoints' pps) +-} + case newPoint of + Just id -> + if setMember id procPoints' + then panic "added old proc pt" + else extendPPSet platform g blocks (setInsert id procPoints') + Nothing -> return procPoints' + + +-- At this point, we have found a set of procpoints, each of which should be +-- the entry point of a procedure. +-- Now, we create the procedure for each proc point, +-- which requires that we: +-- 1. build a map from proc points to the blocks reachable from the proc point +-- 2. turn each branch to a proc point into a jump +-- 3. turn calls and returns into jumps +-- 4. build info tables for the procedures -- and update the info table for +-- the SRTs in the entry procedure as well. +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY +splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> + CmmDecl -> UniqSM [CmmDecl] +splitAtProcPoints dflags entry_label callPPs procPoints procMap + (CmmProc (TopInfo {info_tbls = info_tbls}) + top_l _ g@(CmmGraph {g_entry=entry})) = + do -- Build a map from procpoints to the blocks they reach + let addBlock b graphEnv = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> graphEnv + where bid = entryLabel b + add graphEnv procId bid b = mapInsert procId graph' graphEnv + where graph = mapLookup procId graphEnv `orElse` mapEmpty + graph' = mapInsert bid b graph + + let liveness = cmmGlobalLiveness dflags g + let ppLiveness pp = filter isArgReg $ + regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g + + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if + -- the proc point is a callPP) + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = mapInsert pp lbls map + where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls)) + | otherwise = (block_lbl, guard (setMember pp callPPs) >> + Just (toInfoLbl block_lbl)) + where block_lbl = blockLbl pp + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl add_label mapEmpty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block (env, bs) (pp, l) = + do bid <- liftM mkBlockId getUniqueM + let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 + return (mapInsert pp bid env, b : bs) + + add_jumps newGraphEnv (ppId, blockEnv) = + do let needed_jumps = -- find which procpoints we currently branch to + mapFold add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) + _ -> rst + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + jump_label (Just info_lbl) _ + | tablesNextToCode dflags = info_lbl + | otherwise = toEntryLbl info_lbl + jump_label Nothing block_lbl = block_lbl + + add_if_pp id rst = case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst + Nothing -> rst + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ mapLookup ppId blockEnv + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + let g' = ofBlockMap ppId blockEnv''' + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + + graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv + + let to_proc (bid, g) + | bid == entry + = CmmProc (TopInfo {info_tbls = info_tbls, + stack_info = stack_info}) + top_l live g' + | otherwise + = case expectJust "pp label" $ mapLookup bid procLabels of + (lbl, Just info_lbl) + -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) + , stack_info=stack_info}) + lbl live g' + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) + lbl live g' + where + g' = replacePPIds g + live = ppLiveness (g_entry g') + stack_info = StackInfo { arg_space = 0 + , updfr_space = Nothing + , do_layout = True } + -- cannot use panic, this is printed by -ddump-cmm + + -- References to procpoint IDs can now be replaced with the + -- infotable's label + replacePPIds g = {-# SCC "replacePPIds" #-} + mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case mapLookup bid procLabels of + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e + repl e = e + + -- The C back end expects to see return continuations before the + -- call sites. Here, we sort them in reverse order -- it gets + -- reversed later. + let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g) + add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) + sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ mapLookup bid block_order) + (expectJust "block_order" $ mapLookup bid' block_order) + procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs +splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] + +-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a +-- recursive lookup, see comment below. +replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph +replaceBranches env cmmg + = {-# SCC "replaceBranches" #-} + ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg + where + f block = replaceLastNode block $ last (lastNode block) + + last :: CmmNode O C -> CmmNode O C + last (CmmBranch id) = CmmBranch (lookup id) + last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi) + last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl) + last l@(CmmCall {}) = l { cml_cont = Nothing } + -- NB. remove the continuation of a CmmCall, since this + -- label will now be in a different CmmProc. Not only + -- is this tidier, it stops CmmLint from complaining. + last l@(CmmForeignCall {}) = l + lookup id = fmap lookup (mapLookup id env) `orElse` id + -- XXX: this is a recursive lookup, it follows chains + -- until the lookup returns Nothing, at which point we + -- return the last BlockId + +-- -------------------------------------------------------------- +-- Not splitting proc points: add info tables for continuations + +attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g + where + info_tbls' = mapUnion (info_tbls top_info) $ + mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) + | l <- setElems call_proc_points + , l /= g_entry g ] +attachContInfoTables _ other_decl + = other_decl + +---------------------------------------------------------------- + +{- +Note [Direct reachability] + +Block B is directly reachable from proc point P iff control can flow +from P to B without passing through an intervening proc point. +-} + +---------------------------------------------------------------- + +{- +Note [No simple dataflow] + +Sadly, it seems impossible to compute the proc points using a single +dataflow pass. One might attempt to use this simple lattice: + + data Location = Unknown + | InProc BlockId -- node is in procedure headed by the named proc point + | ProcPoint -- node is itself a proc point + +At a join, a node in two different blocks becomes a proc point. +The difficulty is that the change of information during iterative +computation may promote a node prematurely. Here's a program that +illustrates the difficulty: + + f () { + entry: + .... + L1: + if (...) { ... } + else { ... } + + L2: if (...) { g(); goto L1; } + return x + y; + } + +The only proc-point needed (besides the entry) is L1. But in an +iterative analysis, consider what happens to L2. On the first pass +through, it rises from Unknown to 'InProc entry', but when L1 is +promoted to a proc point (because it's the successor of g()), L1's +successors will be promoted to 'InProc L1'. The problem hits when the +new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. +The join operation makes it a proc point when in fact it needn't be, +because its immediate dominator L1 is already a proc point and there +are no other proc points that directly reach L2. +-} + + + +{- Note [Separate Adams optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It may be worthwhile to attempt the Adams optimization by rewriting +the graph before the assignment of proc-point protocols. Here are a +couple of rules: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: // no CopyIn node here L: CopyIn c ress; + + +And when c == c' and ress == ress', this also: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: CopyIn c' ress' L: CopyIn c' ress' ; + +In both cases the goal is to eliminate k. +-} diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs new file mode 100644 index 00000000..7279013e --- /dev/null +++ b/compiler/cmm/CmmSink.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE GADTs #-} +module CmmSink ( + cmmSink + ) where + +import Cmm +import CmmOpt +import BlockId +import CmmLive +import CmmUtils +import Hoopl +import CodeGen.Platform +import Platform (isARM, platformArch) + +import DynFlags +import UniqFM +import PprCmm () + +import Data.List (partition) +import qualified Data.Set as Set +import Data.Maybe + +-- ----------------------------------------------------------------------------- +-- Sinking and inlining + +-- This is an optimisation pass that +-- (a) moves assignments closer to their uses, to reduce register pressure +-- (b) pushes assignments into a single branch of a conditional if possible +-- (c) inlines assignments to registers that are mentioned only once +-- (d) discards dead assignments +-- +-- This tightens up lots of register-heavy code. It is particularly +-- helpful in the Cmm generated by the Stg->Cmm code generator, in +-- which every function starts with a copyIn sequence like: +-- +-- x1 = R1 +-- x2 = Sp[8] +-- x3 = Sp[16] +-- if (Sp - 32 < SpLim) then L1 else L2 +-- +-- we really want to push the x1..x3 assignments into the L2 branch. +-- +-- Algorithm: +-- +-- * Start by doing liveness analysis. +-- +-- * Keep a list of assignments A; earlier ones may refer to later ones. +-- Currently we only sink assignments to local registers, because we don't +-- have liveness information about global registers. +-- +-- * Walk forwards through the graph, look at each node N: +-- +-- * If it is a dead assignment, i.e. assignment to a register that is +-- not used after N, discard it. +-- +-- * Try to inline based on current list of assignments +-- * If any assignments in A (1) occur only once in N, and (2) are +-- not live after N, inline the assignment and remove it +-- from A. +-- +-- * If an assignment in A is cheap (RHS is local register), then +-- inline the assignment and keep it in A in case it is used afterwards. +-- +-- * Otherwise don't inline. +-- +-- * If N is assignment to a local register pick up the assignment +-- and add it to A. +-- +-- * If N is not an assignment to a local register: +-- * remove any assignments from A that conflict with N, and +-- place them before N in the current block. We call this +-- "dropping" the assignments. +-- +-- * An assignment conflicts with N if it: +-- - assigns to a register mentioned in N +-- - mentions a register assigned by N +-- - reads from memory written by N +-- * do this recursively, dropping dependent assignments +-- +-- * At an exit node: +-- * drop any assignments that are live on more than one successor +-- and are not trivial +-- * if any successor has more than one predecessor (a join-point), +-- drop everything live in that successor. Since we only propagate +-- assignments that are not dead at the successor, we will therefore +-- eliminate all assignments dead at this point. Thus analysis of a +-- join-point will always begin with an empty list of assignments. +-- +-- +-- As a result of above algorithm, sinking deletes some dead assignments +-- (transitively, even). This isn't as good as removeDeadAssignments, +-- but it's much cheaper. + +-- ----------------------------------------------------------------------------- +-- things that we aren't optimising very well yet. +-- +-- ----------- +-- (1) From GHC's FastString.hashStr: +-- +-- s2ay: +-- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; +-- c2gn: +-- R1 = _s2au::I64; +-- call (I64[Sp])(R1) args: 8, res: 0, upd: 8; +-- c2gp: +-- _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128, +-- 4091); +-- _s2an::I64 = _s2an::I64 + 1; +-- _s2au::I64 = _s2cO::I64; +-- goto s2ay; +-- +-- a nice loop, but we didn't eliminate the silly assignment at the end. +-- See Note [dependent assignments], which would probably fix this. +-- This is #8336 on Trac. +-- +-- ----------- +-- (2) From stg_atomically_frame in PrimOps.cmm +-- +-- We have a diamond control flow: +-- +-- x = ... +-- | +-- / \ +-- A B +-- \ / +-- | +-- use of x +-- +-- Now x won't be sunk down to its use, because we won't push it into +-- both branches of the conditional. We certainly do have to check +-- that we can sink it past all the code in both A and B, but having +-- discovered that, we could sink it to its use. +-- + +-- ----------------------------------------------------------------------------- + +type Assignment = (LocalReg, CmmExpr, AbsMem) + -- Assignment caches AbsMem, an abstraction of the memory read by + -- the RHS of the assignment. + +type Assignments = [Assignment] + -- A sequence of assignements; kept in *reverse* order + -- So the list [ x=e1, y=e2 ] means the sequence of assignments + -- y = e2 + -- x = e1 + +cmmSink :: DynFlags -> CmmGraph -> CmmGraph +cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks + where + liveness = cmmLocalLiveness dflags graph + getLive l = mapFindWithDefault Set.empty l liveness + + blocks = postorderDfs graph + + join_pts = findJoinPoints blocks + + sink :: BlockEnv Assignments -> [CmmBlock] -> [CmmBlock] + sink _ [] = [] + sink sunk (b:bs) = + -- pprTrace "sink" (ppr lbl) $ + blockJoin first final_middle final_last : sink sunk' bs + where + lbl = entryLabel b + (first, middle, last) = blockSplit b + + succs = successors last + + -- Annotate the middle nodes with the registers live *after* + -- the node. This will help us decide whether we can inline + -- an assignment in the current node or not. + live = Set.unions (map getLive succs) + live_middle = gen_kill dflags last live + ann_middles = annotate dflags live_middle (blockToList middle) + + -- Now sink and inline in this block + (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) + fold_last = constantFoldNode dflags last + (final_last, assigs') = tryToInline dflags live fold_last assigs + + -- We cannot sink into join points (successors with more than + -- one predecessor), so identify the join points and the set + -- of registers live in them. + (joins, nonjoins) = partition (`mapMember` join_pts) succs + live_in_joins = Set.unions (map getLive joins) + + -- We do not want to sink an assignment into multiple branches, + -- so identify the set of registers live in multiple successors. + -- This is made more complicated because when we sink an assignment + -- into one branch, this might change the set of registers that are + -- now live in multiple branches. + init_live_sets = map getLive nonjoins + live_in_multi live_sets r = + case filter (Set.member r) live_sets of + (_one:_two:_) -> True + _ -> False + + -- Now, drop any assignments that we will not sink any further. + (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs' + + drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') + where + should_drop = conflicts dflags a final_last + || not (isTrivial dflags rhs) && live_in_multi live_sets r + || r `Set.member` live_in_joins + + live_sets' | should_drop = live_sets + | otherwise = map upd live_sets + + upd set | r `Set.member` set = set `Set.union` live_rhs + | otherwise = set + + live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs + + final_middle = foldl blockSnoc middle' dropped_last + + sunk' = mapUnion sunk $ + mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') + | l <- succs ] + +{- TODO: enable this later, when we have some good tests in place to + measure the effect and tune it. + +-- small: an expression we don't mind duplicating +isSmall :: CmmExpr -> Bool +isSmall (CmmReg (CmmLocal _)) = True -- +isSmall (CmmLit _) = True +isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y +isSmall (CmmRegOff (CmmLocal _) _) = True +isSmall _ = False +-} + +-- +-- We allow duplication of trivial expressions: registers (both local and +-- global) and literals. +-- +isTrivial :: DynFlags -> CmmExpr -> Bool +isTrivial _ (CmmReg (CmmLocal _)) = True +isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] + if isARM (platformArch (targetPlatform dflags)) + then True -- CodeGen.Platform.ARM does not have globalRegMaybe + else isJust (globalRegMaybe (targetPlatform dflags) r) + -- GlobalRegs that are loads from BaseReg are not trivial +isTrivial _ (CmmLit _) = True +isTrivial _ _ = False + +-- +-- annotate each node with the set of registers live *after* the node +-- +annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] +annotate dflags live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) + +-- +-- Find the blocks that have multiple successors (join points) +-- +findJoinPoints :: [CmmBlock] -> BlockEnv Int +findJoinPoints blocks = mapFilter (>1) succ_counts + where + all_succs = concatMap successors blocks + + succ_counts :: BlockEnv Int + succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs + +-- +-- filter the list of assignments to remove any assignments that +-- are not live in a continuation. +-- +filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments +filterAssignments dflags live assigs = reverse (go assigs []) + where go [] kept = kept + go (a@(r,_,_):as) kept | needed = go as (a:kept) + | otherwise = go as kept + where + needed = r `Set.member` live + || any (conflicts dflags a) (map toNode kept) + -- Note that we must keep assignments that are + -- referred to by other assignments we have + -- already kept. + +-- ----------------------------------------------------------------------------- +-- Walk through the nodes of a block, sinking and inlining assignments +-- as we go. +-- +-- On input we pass in a: +-- * list of nodes in the block +-- * a list of assignments that appeared *before* this block and +-- that are being sunk. +-- +-- On output we get: +-- * a new block +-- * a list of assignments that will be placed *after* that block. +-- + +walk :: DynFlags + -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with + -- the set of registers live *after* + -- this node. + + -> Assignments -- The current list of + -- assignments we are sinking. + -- Earlier assignments may refer + -- to later ones. + + -> ( Block CmmNode O O -- The new block + , Assignments -- Assignments to sink further + ) + +walk dflags nodes assigs = go nodes emptyBlock assigs + where + go [] block as = (block, as) + go ((live,node):ns) block as + | shouldDiscard node live = go ns block as + -- discard dead assignment + | Just a <- shouldSink dflags node2 = go ns block (a : as1) + | otherwise = go ns block' as' + where + node1 = constantFoldNode dflags node + + (node2, as1) = tryToInline dflags live node1 as + + (dropped, as') = dropAssignmentsSimple dflags + (\a -> conflicts dflags a node2) as1 + + block' = foldl blockSnoc block dropped `blockSnoc` node2 + + +-- +-- Heuristic to decide whether to pick up and sink an assignment +-- Currently we pick up all assignments to local registers. It might +-- be profitable to sink assignments to global regs too, but the +-- liveness analysis doesn't track those (yet) so we can't. +-- +shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment +shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e) + where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e +shouldSink _ _other = Nothing + +-- +-- discard dead assignments. This doesn't do as good a job as +-- removeDeadAsssignments, because it would need multiple passes +-- to get all the dead code, but it catches the common case of +-- superfluous reloads from the stack that the stack allocator +-- leaves behind. +-- +-- Also we catch "r = r" here. You might think it would fall +-- out of inlining, but the inliner will see that r is live +-- after the instruction and choose not to inline r in the rhs. +-- +shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool +shouldDiscard node live + = case node of + CmmAssign r (CmmReg r') | r == r' -> True + CmmAssign (CmmLocal r) _ -> not (r `Set.member` live) + _otherwise -> False + + +toNode :: Assignment -> CmmNode O O +toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs + +dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) () + +dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments + -> ([CmmNode O O], Assignments) +dropAssignments dflags should_drop state assigs + = (dropped, reverse kept) + where + (dropped,kept) = go state assigs [] [] + + go _ [] dropped kept = (dropped, kept) + go state (assig : rest) dropped kept + | conflict = go state' rest (toNode assig : dropped) kept + | otherwise = go state' rest dropped (assig:kept) + where + (dropit, state') = should_drop assig state + conflict = dropit || any (conflicts dflags assig) dropped + + +-- ----------------------------------------------------------------------------- +-- Try to inline assignments into a node. + +tryToInline + :: DynFlags + -> LocalRegSet -- set of registers live after this + -- node. We cannot inline anything + -- that is live after the node, unless + -- it is small enough to duplicate. + -> CmmNode O x -- The node to inline into + -> Assignments -- Assignments to inline + -> ( + CmmNode O x -- New node + , Assignments -- Remaining assignments + ) + +tryToInline dflags live node assigs = go usages node [] assigs + where + usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used + usages = foldLocalRegsUsed dflags addUsage emptyUFM node + + go _usages node _skipped [] = (node, []) + + go usages node skipped (a@(l,rhs,_) : rest) + | cannot_inline = dont_inline + | occurs_none = discard -- Note [discard during inlining] + | occurs_once = inline_and_discard + | isTrivial dflags rhs = inline_and_keep + | otherwise = dont_inline + where + inline_and_discard = go usages' inl_node skipped rest + where usages' = foldLocalRegsUsed dflags addUsage usages rhs + + discard = go usages node skipped rest + + dont_inline = keep node -- don't inline the assignment, keep it + inline_and_keep = keep inl_node -- inline the assignment, keep it + + keep node' = (final_node, a : rest') + where (final_node, rest') = go usages' node' (l:skipped) rest + usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) + usages rhs + -- we must not inline anything that is mentioned in the RHS + -- of a binding that we have already skipped, so we set the + -- usages of the regs on the RHS to 2. + + cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] + || l `elem` skipped + || not (okToInline dflags rhs node) + + l_usages = lookupUFM usages l + l_live = l `elemRegSet` live + + occurs_once = not l_live && l_usages == Just 1 + occurs_none = not l_live && l_usages == Nothing + + inl_node = mapExpDeep inline node + -- mapExpDeep is where the inlining actually takes place! + where inline (CmmReg (CmmLocal l')) | l == l' = rhs + inline (CmmRegOff (CmmLocal l') off) | l == l' + = cmmOffset dflags rhs off + -- re-constant fold after inlining + inline (CmmMachOp op args) = cmmMachOpFold dflags op args + inline other = other + +-- Note [dependent assignments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If our assignment list looks like +-- +-- [ y = e, x = ... y ... ] +-- +-- We cannot inline x. Remember this list is really in reverse order, +-- so it means x = ... y ...; y = e +-- +-- Hence if we inline x, the outer assignment to y will capture the +-- reference in x's right hand side. +-- +-- In this case we should rename the y in x's right-hand side, +-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ] +-- Now we can go ahead and inline x. +-- +-- For now we do nothing, because this would require putting +-- everything inside UniqSM. +-- +-- One more variant of this (#7366): +-- +-- [ y = e, y = z ] +-- +-- If we don't want to inline y = e, because y is used many times, we +-- might still be tempted to inline y = z (because we always inline +-- trivial rhs's). But of course we can't, because y is equal to e, +-- not z. + +-- Note [discard during inlining] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Opportunities to discard assignments sometimes appear after we've +-- done some inlining. Here's an example: +-- +-- x = R1; +-- y = P64[x + 7]; +-- z = P64[x + 15]; +-- /* z is dead */ +-- R1 = y & (-8); +-- +-- The x assignment is trivial, so we inline it in the RHS of y, and +-- keep both x and y. z gets dropped because it is dead, then we +-- inline y, and we have a dead assignment to x. If we don't notice +-- that x is dead in tryToInline, we end up retaining it. + +addUsage :: UniqFM Int -> LocalReg -> UniqFM Int +addUsage m r = addToUFM_C (+) m r 1 + +regsUsedIn :: [LocalReg] -> CmmExpr -> Bool +regsUsedIn [] _ = False +regsUsedIn ls e = wrapRecExpf f e False + where f (CmmReg (CmmLocal l)) _ | l `elem` ls = True + f (CmmRegOff (CmmLocal l) _) _ | l `elem` ls = True + f _ z = z + +-- we don't inline into CmmUnsafeForeignCall if the expression refers +-- to global registers. This is a HACK to avoid global registers +-- clashing with C argument-passing registers, really the back-end +-- ought to be able to handle it properly, but currently neither PprC +-- nor the NCG can do it. See Note [Register parameter passing] +-- See also StgCmmForeign:load_args_into_temps. +okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +okToInline dflags expr node@(CmmUnsafeForeignCall{}) = + not (globalRegistersConflict dflags expr node) +okToInline _ _ _ = True + +-- ----------------------------------------------------------------------------- + +-- | @conflicts (r,e) node@ is @False@ if and only if the assignment +-- @r = e@ can be safely commuted past statement @node@. +conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool +conflicts dflags (r, rhs, addr) node + + -- (1) node defines registers used by rhs of assignment. This catches + -- assignments and all three kinds of calls. See Note [Sinking and calls] + | globalRegistersConflict dflags rhs node = True + | localRegistersConflict dflags rhs node = True + + -- (2) node uses register defined by assignment + | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True + + -- (3) a store to an address conflicts with a read of the same memory + | CmmStore addr' e <- node + , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True + + -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively + | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + + -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] + | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True + + -- (6) native calls clobber any memory + | CmmCall{} <- node, memConflicts addr AnyMem = True + + -- (7) otherwise, no conflict + | otherwise = False + +-- Returns True if node defines any global registers that are used in the +-- Cmm expression +globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +globalRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr) + False node + +-- Returns True if node defines any local registers that are used in the +-- Cmm expression +localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool +localRegistersConflict dflags expr node = + foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr) + False node + +-- Note [Sinking and calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall) +-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after +-- stack layout (see Note [Sinking after stack layout]) which leads to two +-- invariants related to calls: +-- +-- a) during stack layout phase all safe foreign calls are turned into +-- unsafe foreign calls (see Note [Lower safe foreign calls]). This +-- means that we will never encounter CmmForeignCall node when running +-- sinking after stack layout +-- +-- b) stack layout saves all variables live across a call on the stack +-- just before making a call (remember we are not sinking assignments to +-- stack): +-- +-- L1: +-- x = R1 +-- P64[Sp - 16] = L2 +-- P64[Sp - 8] = x +-- Sp = Sp - 16 +-- call f() returns L2 +-- L2: +-- +-- We will attempt to sink { x = R1 } but we will detect conflict with +-- { P64[Sp - 8] = x } and hence we will drop { x = R1 } without even +-- checking whether it conflicts with { call f() }. In this way we will +-- never need to check any assignment conflicts with CmmCall. Remember +-- that we still need to check for potential memory conflicts. +-- +-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes +-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]). +-- This assumption holds only when we do sinking after stack layout. If we run +-- it before stack layout we need to check for possible conflicts with all three +-- kinds of calls. Our `conflicts` function does that by using a generic +-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and +-- UserOfRegs typeclasses. +-- + +-- An abstraction of memory read or written. +data AbsMem + = NoMem -- no memory accessed + | AnyMem -- arbitrary memory + | HeapMem -- definitely heap memory + | StackMem -- definitely stack memory + | SpMem -- [Sp+n] + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +-- Having SpMem is important because it lets us float loads from Sp +-- past stores to Sp as long as they don't overlap, and this helps to +-- unravel some long sequences of +-- x1 = [Sp + 8] +-- x2 = [Sp + 16] +-- ... +-- [Sp + 8] = xi +-- [Sp + 16] = xj +-- +-- Note that SpMem is invalidated if Sp is changed, but the definition +-- of 'conflicts' above handles that. + +-- ToDo: this won't currently fix the following commonly occurring code: +-- x1 = [R1 + 8] +-- x2 = [R1 + 16] +-- .. +-- [Hp - 8] = x1 +-- [Hp - 16] = x2 +-- .. + +-- because [R1 + 8] and [Hp - 8] are both HeapMem. We know that +-- assignments to [Hp + n] do not conflict with any other heap memory, +-- but this is tricky to nail down. What if we had +-- +-- x = Hp + n +-- [x] = ... +-- +-- the store to [x] should be "new heap", not "old heap". +-- Furthermore, you could imagine that if we started inlining +-- functions in Cmm then there might well be reads of heap memory +-- that was written in the same basic block. To take advantage of +-- non-aliasing of heap memory we will have to be more clever. + +-- Note [Foreign calls clobber heap] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- It is tempting to say that foreign calls clobber only +-- non-heap/stack memory, but unfortunately we break this invariant in +-- the RTS. For example, in stg_catch_retry_frame we call +-- stmCommitNestedTransaction() which modifies the contents of the +-- TRec it is passed (this actually caused incorrect code to be +-- generated). +-- +-- Since the invariant is true for the majority of foreign calls, +-- perhaps we ought to have a special annotation for calls that can +-- modify heap/stack memory. For now we just use the conservative +-- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. + + +bothMems :: AbsMem -> AbsMem -> AbsMem +bothMems NoMem x = x +bothMems x NoMem = x +bothMems HeapMem HeapMem = HeapMem +bothMems StackMem StackMem = StackMem +bothMems (SpMem o1 w1) (SpMem o2 w2) + | o1 == o2 = SpMem o1 (max w1 w2) + | otherwise = StackMem +bothMems SpMem{} StackMem = StackMem +bothMems StackMem SpMem{} = StackMem +bothMems _ _ = AnyMem + +memConflicts :: AbsMem -> AbsMem -> Bool +memConflicts NoMem _ = False +memConflicts _ NoMem = False +memConflicts HeapMem StackMem = False +memConflicts StackMem HeapMem = False +memConflicts SpMem{} HeapMem = False +memConflicts HeapMem SpMem{} = False +memConflicts (SpMem o1 w1) (SpMem o2 w2) + | o1 < o2 = o1 + w1 > o2 + | otherwise = o2 + w2 > o1 +memConflicts _ _ = True + +exprMem :: DynFlags -> CmmExpr -> AbsMem +exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr) +exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es) +exprMem _ _ = NoMem + +loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem +loadAddr dflags e w = + case e of + CmmReg r -> regAddr dflags r 0 w + CmmRegOff r i -> regAddr dflags r i w + _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem + | otherwise -> AnyMem + +regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem +regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) +regAddr _ (CmmGlobal Hp) _ _ = HeapMem +regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps +regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ _ = AnyMem + +{- +Note [Inline GlobalRegs?] + +Should we freely inline GlobalRegs? + +Actually it doesn't make a huge amount of difference either way, so we +*do* currently treat GlobalRegs as "trivial" and inline them +everywhere, but for what it's worth, here is what I discovered when I +(SimonM) looked into this: + +Common sense says we should not inline GlobalRegs, because when we +have + + x = R1 + +the register allocator will coalesce this assignment, generating no +code, and simply record the fact that x is bound to $rbx (or +whatever). Furthermore, if we were to sink this assignment, then the +range of code over which R1 is live increases, and the range of code +over which x is live decreases. All things being equal, it is better +for x to be live than R1, because R1 is a fixed register whereas x can +live in any register. So we should neither sink nor inline 'x = R1'. + +However, not inlining GlobalRegs can have surprising +consequences. e.g. (cgrun020) + + c3EN: + _s3DB::P64 = R1; + _c3ES::P64 = _s3DB::P64 & 7; + if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV; + c3EU: + _s3DD::P64 = P64[_s3DB::P64 + 6]; + _s3DE::P64 = P64[_s3DB::P64 + 14]; + I64[Sp - 8] = c3F0; + R1 = _s3DE::P64; + P64[Sp] = _s3DD::P64; + +inlining the GlobalReg gives: + + c3EN: + if (R1 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + _s3DD::P64 = P64[R1 + 6]; + R1 = P64[R1 + 14]; + P64[Sp] = _s3DD::P64; + +but if we don't inline the GlobalReg, instead we get: + + _s3DB::P64 = R1; + if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV; + c3EU: + I64[Sp - 8] = c3F0; + R1 = P64[_s3DB::P64 + 14]; + P64[Sp] = P64[_s3DB::P64 + 6]; + +This looks better - we managed to inline _s3DD - but in fact it +generates an extra reg-reg move: + +.Lc3EU: + movq $c3F0_info,-8(%rbp) + movq %rbx,%rax + movq 14(%rbx),%rbx + movq 6(%rax),%rax + movq %rax,(%rbp) + +because _s3DB is now live across the R1 assignment, we lost the +benefit of coalescing. + +Who is at fault here? Perhaps if we knew that _s3DB was an alias for +R1, then we would not sink a reference to _s3DB past the R1 +assignment. Or perhaps we *should* do that - we might gain by sinking +it, despite losing the coalescing opportunity. + +Sometimes not inlining global registers wins by virtue of the rule +about not inlining into arguments of a foreign call, e.g. (T7163) this +is what happens when we inlined F1: + + _s3L2::F32 = F1; + _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32); + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(_c3O3::F32); + +but if we don't inline F1: + + (_s3L7::F32) = call "ccall" arg hints: [] result hints: [] rintFloat(%MO_F_Mul_W32(_s3L2::F32, + 10.0 :: W32)); +-} diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs new file mode 100644 index 00000000..f852d54b --- /dev/null +++ b/compiler/cmm/CmmType.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE CPP #-} + +module CmmType + ( CmmType -- Abstract + , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord + , cInt, cLong + , cmmBits, cmmFloat + , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32 + + , Width(..) + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , halfWordMask + , narrowU, narrowS + , rEP_CostCentreStack_mem_alloc + , rEP_CostCentreStack_scc_count + , rEP_StgEntCounter_allocs + , rEP_StgEntCounter_allocd + + , ForeignHint(..) + + , Length + , vec, vec2, vec4, vec8, vec16 + , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 + , cmmVec + , vecLength, vecElemType + , isVecType + ) +where + +#include "HsVersions.h" + +import DynFlags +import FastString +import Outputable + +import Data.Word +import Data.Int + +----------------------------------------------------------------------------- +-- CmmType +----------------------------------------------------------------------------- + + -- NOTE: CmmType is an abstract type, not exported from this + -- module so you can easily change its representation + -- + -- However Width is exported in a concrete way, + -- and is used extensively in pattern-matching + +data CmmType -- The important one! + = CmmType CmmCat Width + +data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + | VecCat Length CmmCat -- Vector + deriving( Eq ) + -- See Note [Signed vs unsigned] at the end + +instance Outputable CmmType where + ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) + +instance Outputable CmmCat where + ppr FloatCat = ptext $ sLit("F") + ppr GcPtrCat = ptext $ sLit("P") + ppr BitsCat = ptext $ sLit("I") + ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" + +-- Why is CmmType stratified? For native code generation, +-- most of the time you just want to know what sort of register +-- to put the thing in, and for this you need to know how +-- many bits thing has and whether it goes in a floating-point +-- register. By contrast, the distinction between GcPtr and +-- GcNonPtr is of interest to only a few parts of the code generator. + +-------- Equality on CmmType -------------- +-- CmmType is *not* an instance of Eq; sometimes we care about the +-- Gc/NonGc distinction, and sometimes we don't +-- So we use an explicit function to force you to think about it +cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality +cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 + +cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool + -- This equality is temporary; used in CmmLint + -- but the RTS files are not yet well-typed wrt pointers +cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1==w2 + where + weak_eq :: CmmCat -> CmmCat -> Bool + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 + && cat1 `weak_eq` cat2 + (VecCat {}) `weak_eq` _other = False + _other `weak_eq` (VecCat {}) = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr + +--- Simple operations on CmmType ----- +typeWidth :: CmmType -> Width +typeWidth (CmmType _ w) = w + +cmmBits, cmmFloat :: Width -> CmmType +cmmBits = CmmType BitsCat +cmmFloat = CmmType FloatCat + +-------- Common CmmTypes ------------ +-- Floats and words of specific widths +b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType +b8 = cmmBits W8 +b16 = cmmBits W16 +b32 = cmmBits W32 +b64 = cmmBits W64 +b128 = cmmBits W128 +b256 = cmmBits W256 +b512 = cmmBits W512 +f32 = cmmFloat W32 +f64 = cmmFloat W64 + +-- CmmTypes of native word widths +bWord :: DynFlags -> CmmType +bWord dflags = cmmBits (wordWidth dflags) + +bHalfWord :: DynFlags -> CmmType +bHalfWord dflags = cmmBits (halfWordWidth dflags) + +gcWord :: DynFlags -> CmmType +gcWord dflags = CmmType GcPtrCat (wordWidth dflags) + +cInt, cLong :: DynFlags -> CmmType +cInt dflags = cmmBits (cIntWidth dflags) +cLong dflags = cmmBits (cLongWidth dflags) + + +------------ Predicates ---------------- +isFloatType, isGcPtrType :: CmmType -> Bool +isFloatType (CmmType FloatCat _) = True +isFloatType _other = False + +isGcPtrType (CmmType GcPtrCat _) = True +isGcPtrType _other = False + +isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool +-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) +-- isFloat32 and 64 are obvious + +isWord64 (CmmType BitsCat W64) = True +isWord64 (CmmType GcPtrCat W64) = True +isWord64 _other = False + +isWord32 (CmmType BitsCat W32) = True +isWord32 (CmmType GcPtrCat W32) = True +isWord32 _other = False + +isFloat32 (CmmType FloatCat W32) = True +isFloat32 _other = False + +isFloat64 (CmmType FloatCat W64) = True +isFloat64 _other = False + +----------------------------------------------------------------------------- +-- Width +----------------------------------------------------------------------------- + +data Width = W8 | W16 | W32 | W64 + | W80 -- Extended double-precision float, + -- used in x86 native codegen only. + -- (we use Ord, so it'd better be in this order) + | W128 + | W256 + | W512 + deriving (Eq, Ord, Show) + +instance Outputable Width where + ppr rep = ptext (mrStr rep) + +mrStr :: Width -> LitString +mrStr W8 = sLit("W8") +mrStr W16 = sLit("W16") +mrStr W32 = sLit("W32") +mrStr W64 = sLit("W64") +mrStr W128 = sLit("W128") +mrStr W256 = sLit("W256") +mrStr W512 = sLit("W512") +mrStr W80 = sLit("W80") + + +-------- Common Widths ------------ +wordWidth :: DynFlags -> Width +wordWidth dflags + | wORD_SIZE dflags == 4 = W32 + | wORD_SIZE dflags == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordWidth :: DynFlags -> Width +halfWordWidth dflags + | wORD_SIZE dflags == 4 = W16 + | wORD_SIZE dflags == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +halfWordMask :: DynFlags -> Integer +halfWordMask dflags + | wORD_SIZE dflags == 4 = 0xFFFF + | wORD_SIZE dflags == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" + +-- cIntRep is the Width for a C-language 'int' +cIntWidth, cLongWidth :: DynFlags -> Width +cIntWidth dflags = case cINT_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) +cLongWidth dflags = case cLONG_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cLONG_SIZE: " ++ show s) + +widthInBits :: Width -> Int +widthInBits W8 = 8 +widthInBits W16 = 16 +widthInBits W32 = 32 +widthInBits W64 = 64 +widthInBits W128 = 128 +widthInBits W256 = 256 +widthInBits W512 = 512 +widthInBits W80 = 80 + +widthInBytes :: Width -> Int +widthInBytes W8 = 1 +widthInBytes W16 = 2 +widthInBytes W32 = 4 +widthInBytes W64 = 8 +widthInBytes W128 = 16 +widthInBytes W256 = 32 +widthInBytes W512 = 64 +widthInBytes W80 = 10 + +widthFromBytes :: Int -> Width +widthFromBytes 1 = W8 +widthFromBytes 2 = W16 +widthFromBytes 4 = W32 +widthFromBytes 8 = W64 +widthFromBytes 16 = W128 +widthFromBytes 32 = W256 +widthFromBytes 64 = W512 +widthFromBytes 10 = W80 +widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) + +-- log_2 of the width in bytes, useful for generating shifts. +widthInLog :: Width -> Int +widthInLog W8 = 0 +widthInLog W16 = 1 +widthInLog W32 = 2 +widthInLog W64 = 3 +widthInLog W128 = 4 +widthInLog W256 = 5 +widthInLog W512 = 6 +widthInLog W80 = panic "widthInLog: F80" + +-- widening / narrowing + +narrowU :: Width -> Integer -> Integer +narrowU W8 x = fromIntegral (fromIntegral x :: Word8) +narrowU W16 x = fromIntegral (fromIntegral x :: Word16) +narrowU W32 x = fromIntegral (fromIntegral x :: Word32) +narrowU W64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +narrowS :: Width -> Integer -> Integer +narrowS W8 x = fromIntegral (fromIntegral x :: Int8) +narrowS W16 x = fromIntegral (fromIntegral x :: Int16) +narrowS W32 x = fromIntegral (fromIntegral x :: Int32) +narrowS W64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +----------------------------------------------------------------------------- +-- SIMD +----------------------------------------------------------------------------- + +type Length = Int + +vec :: Length -> CmmType -> CmmType +vec l (CmmType cat w) = CmmType (VecCat l cat) vecw + where + vecw :: Width + vecw = widthFromBytes (l*widthInBytes w) + +vec2, vec4, vec8, vec16 :: CmmType -> CmmType +vec2 = vec 2 +vec4 = vec 4 +vec8 = vec 8 +vec16 = vec 16 + +vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType +vec2f64 = vec 2 f64 +vec2b64 = vec 2 b64 +vec4f32 = vec 4 f32 +vec4b32 = vec 4 b32 +vec8b16 = vec 8 b16 +vec16b8 = vec 16 b8 + +cmmVec :: Int -> CmmType -> CmmType +cmmVec n (CmmType cat w) = + CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) + +vecLength :: CmmType -> Length +vecLength (CmmType (VecCat l _) _) = l +vecLength _ = panic "vecLength: not a vector" + +vecElemType :: CmmType -> CmmType +vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw + where + scalw :: Width + scalw = widthFromBytes (widthInBytes w `div` l) +vecElemType _ = panic "vecElemType: not a vector" + +isVecType :: CmmType -> Bool +isVecType (CmmType (VecCat {}) _) = True +isVecType _ = False + +------------------------------------------------------------------------- +-- Hints + +-- Hints are extra type information we attach to the arguments and +-- results of a foreign call, where more type information is sometimes +-- needed by the ABI to make the correct kind of call. + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +------------------------------------------------------------------------- + +-- These don't really belong here, but I don't know where is best to +-- put them. + +rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType +rEP_CostCentreStack_mem_alloc dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_CostCentreStack_scc_count :: DynFlags -> CmmType +rEP_CostCentreStack_scc_count dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_StgEntCounter_allocs :: DynFlags -> CmmType +rEP_StgEntCounter_allocs dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_StgEntCounter_allocd :: DynFlags -> CmmType +rEP_StgEntCounter_allocd dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) + where pc = sPlatformConstants (settings dflags) + +------------------------------------------------------------------------- +{- Note [Signed vs unsigned] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Should a CmmType include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the CmmType, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from CmmType, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to CmmType: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the CmmType for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different CmmType in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represented by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs new file mode 100644 index 00000000..8e7a2dc4 --- /dev/null +++ b/compiler/cmm/CmmUtils.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE CPP, GADTs, RankNTypes #-} + +----------------------------------------------------------------------------- +-- +-- Cmm utilities. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module CmmUtils( + -- CmmType + primRepCmmType, primRepForeignHint, + typeCmmType, typeForeignHint, + + -- CmmLit + zeroCLit, mkIntCLit, + mkWordCLit, packHalfWordsCLit, + mkByteStringCLit, + mkDataLits, mkRODataLits, + mkStgWordCLit, + + -- CmmExpr + mkIntExpr, zeroExpr, + mkLblExpr, + cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, + cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, + cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, + cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, + cmmNegate, + cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord, + cmmToWord, + + isTrivialCmmExpr, hasNoGlobalRegs, + + -- Statics + blankWord, + + -- Tagging + cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, + cmmConstrTag1, + + -- Overlap and usage + regsOverlap, regUsedIn, + + -- Liveness and bitmaps + mkLiveness, + + -- * Operations that probably don't belong here + modifyGraph, + + ofBlockMap, toBlockMap, insertBlock, + ofBlockList, toBlockList, bodyToBlockList, + toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, + foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, + + analFwd, analBwd, analRewFwd, analRewBwd, + dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd, + dataflowAnalFwdBlocks, + + -- * Ticks + blockTicks + ) where + +#include "HsVersions.h" + +import TyCon ( PrimRep(..), PrimElemRep(..) ) +import Type ( UnaryType, typePrimRep ) + +import SMRep +import Cmm +import BlockId +import CLabel +import Outputable +import Unique +import UniqSupply +import DynFlags +import Util +import CodeGen.Platform + +import Data.Word +import Data.Maybe +import Data.Bits +import Hoopl + +--------------------------------------------------- +-- +-- CmmTypes +-- +--------------------------------------------------- + +primRepCmmType :: DynFlags -> PrimRep -> CmmType +primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" +primRepCmmType dflags PtrRep = gcWord dflags +primRepCmmType dflags IntRep = bWord dflags +primRepCmmType dflags WordRep = bWord dflags +primRepCmmType _ Int64Rep = b64 +primRepCmmType _ Word64Rep = b64 +primRepCmmType dflags AddrRep = bWord dflags +primRepCmmType _ FloatRep = f32 +primRepCmmType _ DoubleRep = f64 +primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep) + +primElemRepCmmType :: PrimElemRep -> CmmType +primElemRepCmmType Int8ElemRep = b8 +primElemRepCmmType Int16ElemRep = b16 +primElemRepCmmType Int32ElemRep = b32 +primElemRepCmmType Int64ElemRep = b64 +primElemRepCmmType Word8ElemRep = b8 +primElemRepCmmType Word16ElemRep = b16 +primElemRepCmmType Word32ElemRep = b32 +primElemRepCmmType Word64ElemRep = b64 +primElemRepCmmType FloatElemRep = f32 +primElemRepCmmType DoubleElemRep = f64 + +typeCmmType :: DynFlags -> UnaryType -> CmmType +typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty) + +primRepForeignHint :: PrimRep -> ForeignHint +primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" +primRepForeignHint PtrRep = AddrHint +primRepForeignHint IntRep = SignedHint +primRepForeignHint WordRep = NoHint +primRepForeignHint Int64Rep = SignedHint +primRepForeignHint Word64Rep = NoHint +primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg +primRepForeignHint FloatRep = NoHint +primRepForeignHint DoubleRep = NoHint +primRepForeignHint (VecRep {}) = NoHint + +typeForeignHint :: UnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRep + +--------------------------------------------------- +-- +-- CmmLit +-- +--------------------------------------------------- + +-- XXX: should really be Integer, since Int doesn't necessarily cover +-- the full range of target Ints. +mkIntCLit :: DynFlags -> Int -> CmmLit +mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) + +mkIntExpr :: DynFlags -> Int -> CmmExpr +mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i + +zeroCLit :: DynFlags -> CmmLit +zeroCLit dflags = CmmInt 0 (wordWidth dflags) + +zeroExpr :: DynFlags -> CmmExpr +zeroExpr dflags = CmmLit (zeroCLit dflags) + +mkWordCLit :: DynFlags -> Integer -> CmmLit +mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) + +mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) +-- We have to make a top-level decl for the string, +-- and return a literal pointing to it +mkByteStringCLit uniq bytes + = (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes]) + where + lbl = mkStringLitLabel uniq +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a data-segment data block +mkDataLits section lbl lits + = CmmData section (Statics lbl $ map CmmStaticLit lits) + +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a read-only data block +mkRODataLits lbl lits + = mkDataLits section lbl lits + where + section | any needsRelocation lits = RelocatableReadOnlyData + | otherwise = ReadOnlyData + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + +mkStgWordCLit :: DynFlags -> StgWord -> CmmLit +mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) + +packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit +-- Make a single word literal in which the lower_half_word is +-- at the lower address, and the upper_half_word is at the +-- higher address +-- ToDo: consider using half-word lits instead +-- but be careful: that's vulnerable when reversed +packHalfWordsCLit dflags lower_half_word upper_half_word + = if wORDS_BIGENDIAN dflags + then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u) + else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags)) + where l = fromStgHalfWord lower_half_word + u = fromStgHalfWord upper_half_word + +--------------------------------------------------- +-- +-- CmmExpr +-- +--------------------------------------------------- + +mkLblExpr :: CLabel -> CmmExpr +mkLblExpr lbl = CmmLit (CmmLabel lbl) + +cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +-- assumes base and offset have the same CmmType +cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) +cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] + +-- NB. Do *not* inspect the value of the offset in these smart constructors!!! +-- because the offset is sometimes involved in a loop in the code generator +-- (we don't know the real Hp offset until we've generated code for the entire +-- basic block, for example). So we cannot eliminate zero offsets at this +-- stage; they're eliminated later instead (either during printing or +-- a later optimisation step on Cmm). +-- +cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr +cmmOffset _ e 0 = e +cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off +cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) +cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) +cmmOffset _ (CmmStackSlot area off) byte_off + = CmmStackSlot area (off - byte_off) + -- note stack area offsets increase towards lower addresses +cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 + = CmmMachOp (MO_Add rep) + [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] +cmmOffset dflags expr byte_off + = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] + where + width = cmmExprWidth dflags expr + +-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. +cmmRegOff :: CmmReg -> Int -> CmmExpr +cmmRegOff reg 0 = CmmReg reg +cmmRegOff reg byte_off = CmmRegOff reg byte_off + +cmmOffsetLit :: CmmLit -> Int -> CmmLit +cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off +cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) +cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off + = CmmLabelDiffOff l1 l2 (m+byte_off) +cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep +cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) + +cmmLabelOff :: CLabel -> Int -> CmmLit +-- Smart constructor for CmmLabelOff +cmmLabelOff lbl 0 = CmmLabel lbl +cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off + +-- | Useful for creating an index into an array, with a staticaly known offset. +-- The type is the element type; used for making the multiplier +cmmIndex :: DynFlags + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> Int -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) + +-- | Useful for creating an index into an array, with an unknown offset. +cmmIndexExpr :: DynFlags + -> Width -- Width w + -> CmmExpr -- Address of vector of items of width w + -> CmmExpr -- Which element of the vector (0 based) + -> CmmExpr -- Address of i'th element +cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) +cmmIndexExpr dflags width base idx = + cmmOffsetExpr dflags base byte_off + where + idx_w = cmmExprWidth dflags idx + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] + +cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty + +-- The "B" variants take byte offsets +cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr +cmmRegOffB = cmmRegOff + +cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB = cmmOffset + +cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB = cmmOffsetExpr + +cmmLabelOffB :: CLabel -> ByteOff -> CmmLit +cmmLabelOffB = cmmLabelOff + +cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit +cmmOffsetLitB = cmmOffsetLit + +----------------------- +-- The "W" variants take word offsets + +cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +-- The second arg is a *word* offset; need to change it to bytes +cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) +cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off + +cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr +cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n) + +cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr +cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off) + +cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit +cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off) + +cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit +cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off) + +cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr +cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty + +----------------------- +cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord + :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] +cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] +cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] +cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] +cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] +cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] +cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] +--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2] +cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] +cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] +cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] +cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] +cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] + +cmmNegate :: DynFlags -> CmmExpr -> CmmExpr +cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) +cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] + +blankWord :: DynFlags -> CmmStatic +blankWord dflags = CmmUninitialised (wORD_SIZE dflags) + +cmmToWord :: DynFlags -> CmmExpr -> CmmExpr +cmmToWord dflags e + | w == word = e + | otherwise = CmmMachOp (MO_UU_Conv w word) [e] + where + w = cmmExprWidth dflags e + word = wordWidth dflags + +--------------------------------------------------- +-- +-- CmmExpr predicates +-- +--------------------------------------------------- + +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" + +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False + +--------------------------------------------------- +-- +-- Tagging +-- +--------------------------------------------------- + +-- Tag bits mask +--cmmTagBits = CmmLit (mkIntCLit tAG_BITS) +cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr +cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) +cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) + +-- Used to untag a possibly tagged pointer +-- A static label need not be untagged +cmmUntag :: DynFlags -> CmmExpr -> CmmExpr +cmmUntag _ e@(CmmLit (CmmLabel _)) = e +-- Default case +cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) + +-- Test if a closure pointer is untagged +cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr +cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) + +cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr +-- Get constructor tag, but one based. +cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) + + +----------------------------------------------------------------------------- +-- Overlap and usage + +-- | Returns True if the two STG registers overlap on the specified +-- platform, in the sense that writing to one will clobber the +-- other. This includes the case that the two registers are the same +-- STG register. See Note [Overlapping global registers] for details. +regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool +regsOverlap dflags (CmmGlobal g) (CmmGlobal g') + | Just real <- globalRegMaybe (targetPlatform dflags) g, + Just real' <- globalRegMaybe (targetPlatform dflags) g', + real == real' + = True +regsOverlap _ reg reg' = reg == reg' + +-- | Returns True if the STG register is used by the expression, in +-- the sense that a store to the register might affect the value of +-- the expression. +-- +-- We must check for overlapping registers and not just equal +-- registers here, otherwise CmmSink may incorrectly reorder +-- assignments that conflict due to overlap. See Trac #10521 and Note +-- [Overlapping global registers]. +regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool +regUsedIn dflags = regUsedIn_ where + _ `regUsedIn_` CmmLit _ = False + reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e + reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg' + reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg' + reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es + _ `regUsedIn_` CmmStackSlot _ _ = False + +-------------------------------------------- +-- +-- mkLiveness +-- +--------------------------------------------- + +mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness +mkLiveness _ [] = [] +mkLiveness dflags (reg:regs) + = take sizeW bits ++ mkLiveness dflags regs + where + sizeW = case reg of + Nothing -> 1 + Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1) + `quot` wORD_SIZE dflags + -- number of words, rounded up + bits = repeat $ is_non_ptr reg -- True <=> Non Ptr + + is_non_ptr Nothing = True + is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg) + + +-- ============================================== - +-- ============================================== - +-- ============================================== - + +--------------------------------------------------- +-- +-- Manipulating CmmGraphs +-- +--------------------------------------------------- + +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + +toBlockMap :: CmmGraph -> BlockEnv CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph +ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} + +insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock +insertBlock block map = + ASSERT(isNothing $ mapLookup id map) + mapInsert id block map + where id = entryLabel block + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + +-- | like 'toBlockList', but the entry block always comes first +toBlockListEntryFirst :: CmmGraph -> [CmmBlock] +toBlockListEntryFirst g + | mapNull m = [] + | otherwise = entry_block : others + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + others = filter ((/= entry_id) . entryLabel) (mapElems m) + +-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks +-- so that the false case of a conditional jumps to the next block in the output +-- list of blocks. This matches the way OldCmm blocks were output since in +-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches +-- have both true and false successors. Block ordering can make a big difference +-- in performance in the LLVM backend. Note that we rely crucially on the order +-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode +-- defind in cmm/CmmNode.hs. -GBM +toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] +toBlockListEntryFirstFalseFallthrough g + | mapNull m = [] + | otherwise = dfs setEmpty [entry_block] + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + + dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] + dfs _ [] = [] + dfs visited (block:bs) + | id `setMember` visited = dfs visited bs + | otherwise = block : dfs (setInsert id visited) bs' + where id = entryLabel block + bs' = foldr add_id bs (successors block) + add_id id bs = case mapLookup id m of + Just b -> b : bs + Nothing -> bs + +ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph +ofBlockList entry blocks = CmmGraph { g_entry = entry + , g_graph = GMany NothingO body NothingO } + where body = foldr addBlock emptyBody blocks + +bodyToBlockList :: Body CmmNode -> [CmmBlock] +bodyToBlockList body = mapElems body + +mapGraphNodes :: ( CmmNode C O -> CmmNode C O + , CmmNode O O -> CmmNode O O + , CmmNode O C -> CmmNode O C) + -> CmmGraph -> CmmGraph +mapGraphNodes funs@(mf,_,_) g = + ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ + mapMap (mapBlock3' funs) $ toBlockMap g + +mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph +mapGraphNodes1 f = modifyGraph (mapGraph f) + + +foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a +foldGraphBlocks k z g = mapFold k z $ toBlockMap g + +postorderDfs :: CmmGraph -> [CmmBlock] +postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g) + +------------------------------------------------- +-- Running dataflow analysis and/or rewrites + +-- Constructing forward and backward analysis-only pass +analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f +analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f + +analFwd lat xfer = analRewFwd lat xfer noFwdRewrite +analBwd lat xfer = analRewBwd lat xfer noBwdRewrite + +-- Constructing forward and backward analysis + rewrite pass +analRewFwd :: DataflowLattice f -> FwdTransfer n f + -> FwdRewrite UniqSM n f + -> FwdPass UniqSM n f + +analRewBwd :: DataflowLattice f + -> BwdTransfer n f + -> BwdRewrite UniqSM n f + -> BwdPass UniqSM n f + +analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew} +analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew} + +-- Running forward and backward dataflow analysis + optional rewrite +dataflowPassFwd :: NonLocal n => + GenCmmGraph n -> [(BlockId, f)] + -> FwdPass UniqSM n f + -> UniqSM (GenCmmGraph n, BlockEnv f) +dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do + (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) + return (CmmGraph {g_entry=entry, g_graph=graph}, facts) + +dataflowAnalFwd :: NonLocal n => + GenCmmGraph n -> [(BlockId, f)] + -> FwdPass UniqSM n f + -> BlockEnv f +dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = + analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) + +dataflowAnalFwdBlocks :: NonLocal n => + GenCmmGraph n -> [(BlockId, f)] + -> FwdPass UniqSM n f + -> UniqSM (BlockEnv f) +dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do +-- (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) +-- return facts + return (analyzeFwdBlocks fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)) + +dataflowAnalBwd :: NonLocal n => + GenCmmGraph n -> [(BlockId, f)] + -> BwdPass UniqSM n f + -> BlockEnv f +dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = + analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) + +dataflowPassBwd :: NonLocal n => + GenCmmGraph n -> [(BlockId, f)] + -> BwdPass UniqSM n f + -> UniqSM (GenCmmGraph n, BlockEnv f) +dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do + (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) + return (CmmGraph {g_entry=entry, g_graph=graph}, facts) + +------------------------------------------------- +-- Tick utilities + +-- | Extract all tick annotations from the given block +blockTicks :: Block CmmNode C C -> [CmmTickish] +blockTicks b = reverse $ foldBlockNodesF goStmt b [] + where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] + goStmt (CmmTick t) ts = t:ts + goStmt _other ts = ts diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs new file mode 100644 index 00000000..069f5cc2 --- /dev/null +++ b/compiler/cmm/Debug.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE GADTs, CPP #-} + +----------------------------------------------------------------------------- +-- +-- Debugging data +-- +-- Association of debug data on the Cmm level, with methods to encode it in +-- event log format for later inclusion in profiling event logs. +-- +----------------------------------------------------------------------------- + +module Debug ( + + DebugBlock(..), dblIsEntry, + UnwindTable, UnwindExpr(..), + cmmDebugGen, + cmmDebugLabels, + cmmDebugLink, + debugToMap + + ) where + +import BlockId ( blockLbl ) +import CLabel +import Cmm +import CmmUtils +import CoreSyn +import FastString ( nilFS, mkFastString ) +import Module +import Outputable +import PprCore () +import PprCmmExpr ( pprExpr ) +import SrcLoc +import Util + +import Compiler.Hoopl + +import Data.Maybe +import Data.List ( minimumBy, nubBy ) +import Data.Ord ( comparing ) +import qualified Data.Map as Map + +-- | Debug information about a block of code. Ticks scope over nested +-- blocks. +data DebugBlock = + DebugBlock + { dblProcedure :: !Label -- ^ Entry label of containing proc + , dblLabel :: !Label -- ^ Hoopl label + , dblCLabel :: !CLabel -- ^ Output label + , dblHasInfoTbl :: !Bool -- ^ Has an info table? + , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block + , dblSourceTick + :: !(Maybe CmmTickish) -- ^ Best source tick covering block + , dblPosition :: !(Maybe Int) -- ^ Output position relative to + -- other blocks. @Nothing@ means + -- the block was optimized out + , dblUnwind :: !UnwindTable -- ^ Unwind information + , dblBlocks :: ![DebugBlock] -- ^ Nested blocks + } + +-- | Is this the entry block? +dblIsEntry :: DebugBlock -> Bool +dblIsEntry blk = dblProcedure blk == dblLabel blk + +instance Outputable DebugBlock where + ppr blk = (if dblProcedure blk == dblLabel blk + then text "proc " + else if dblHasInfoTbl blk + then text "pp-blk " + else text "blk ") <> + ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+> + (maybe empty ppr (dblSourceTick blk)) <+> + (maybe (text "removed") ((text "pos " <>) . ppr) + (dblPosition blk)) <+> + pprUwMap (dblUnwind blk) $$ + (if null (dblBlocks blk) then empty else ppr (dblBlocks blk)) + where pprUw (g, expr) = ppr g <> char '=' <> ppr expr + pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList + +-- | Intermediate data structure holding debug-relevant context information +-- about a block. +type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable) + +-- | Extract debug data from a group of procedures. We will prefer +-- source notes that come from the given module (presumably the module +-- that we are currently compiling). +cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock] +cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes + where + blockCtxs :: Map.Map CmmTickScope [BlockContext] + blockCtxs = blockContexts decls + + -- Analyse tick scope structure: Each one is either a top-level + -- tick scope, or the child of another. + (topScopes, childScopes) + = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs + findP tsc GlobalScope = Left tsc -- top scope + findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc) + | otherwise = findP tsc scp' + where -- Note that we only following the left parent of + -- combined scopes. This loses us ticks, which we will + -- recover by copying ticks below. + scp' | SubScope _ scp' <- scp = scp' + | CombinedScope scp' _ <- scp = scp' + | otherwise = panic "findP impossible" + + scopeMap = foldr (uncurry insertMulti) Map.empty childScopes + + -- This allows us to recover ticks that we lost by flattening + -- the graph. Basically, if the parent is A but the child is + -- CBA, we know that there is no BA, because it would have taken + -- priority - but there might be a B scope, with ticks that + -- would not be associated with our child anymore. Note however + -- that there might be other childs (DB), which we have to + -- filter out. + -- + -- We expect this to be called rarely, which is why we are not + -- trying too hard to be efficient here. In many cases we won't + -- have to construct blockCtxsU in the first place. + ticksToCopy :: CmmTickScope -> [CmmTickish] + ticksToCopy (CombinedScope scp s) = go s + where go s | scp `isTickSubScope` s = [] -- done + | SubScope _ s' <- s = ticks ++ go s' + | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 + | otherwise = panic "ticksToCopy impossible" + where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs + ticksToCopy _ = [] + bCtxsTicks = concatMap (blockTicks . fstOf3) + + -- Finding the "best" source tick is somewhat arbitrary -- we + -- select the first source span, while preferring source ticks + -- from the same source file. Furthermore, dumps take priority + -- (if we generated one, we probably want debug information to + -- refer to it). + bestSrcTick = minimumBy (comparing rangeRating) + rangeRating (SourceNote span _) + | srcSpanFile span == thisFile = 1 + | otherwise = 2 :: Int + rangeRating note = pprPanic "rangeRating" (ppr note) + thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + + -- Returns block tree for this scope as well as all nested + -- scopes. Note that if there are multiple blocks in the (exact) + -- same scope we elect one as the "branch" node and add the rest + -- as children. + blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock + blocksForScope cstick scope = mkBlock True (head bctxs) + where bctxs = fromJust $ Map.lookup scope blockCtxs + nested = fromMaybe [] $ Map.lookup scope scopeMap + childs = map (mkBlock False) (tail bctxs) ++ + map (blocksForScope stick) nested + mkBlock top (block, prc, unwind) + = DebugBlock { dblProcedure = g_entry graph + , dblLabel = label + , dblCLabel = case info of + Just (Statics infoLbl _) -> infoLbl + Nothing + | g_entry graph == label -> entryLbl + | otherwise -> blockLbl label + , dblHasInfoTbl = isJust info + , dblTicks = ticks + , dblPosition = Nothing -- see cmmDebugLink + , dblUnwind = unwind + , dblSourceTick = stick + , dblBlocks = blocks + } + where (CmmProc infos entryLbl _ graph) = prc + label = entryLabel block + info = mapLookup label infos + blocks | top = seqList childs childs + | otherwise = [] + + -- A source tick scopes over all nested blocks. However + -- their source ticks might take priority. + isSourceTick SourceNote {} = True + isSourceTick _ = False + -- Collect ticks from all blocks inside the tick scope. + -- We attempt to filter out duplicates while we're at it. + ticks = nubBy (flip tickishContains) $ + bCtxsTicks bctxs ++ ticksToCopy scope + stick = case filter isSourceTick ticks of + [] -> cstick + sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick) + +-- | Build a map of blocks sorted by their tick scopes +-- +-- This involves a pre-order traversal, as we want blocks in rough +-- control flow order (so ticks have a chance to be sorted in the +-- right order). We also use this opportunity to have blocks inherit +-- unwind information from their predecessor blocks where it is +-- lacking. +blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext] +blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls + where walkProc CmmData{} m = m + walkProc prc@(CmmProc _ _ _ graph) m + | mapNull blocks = m + | otherwise = snd $ walkBlock prc entry Map.empty (emptyLbls, m) + where blocks = toBlockMap graph + entry = [mapFind (g_entry graph) blocks] + emptyLbls = setEmpty :: LabelSet + walkBlock _ [] _ c = c + walkBlock prc (block:blocks) unwind (visited, m) + | lbl `setMember` visited + = walkBlock prc blocks unwind (visited, m) + | otherwise + = walkBlock prc blocks unwind $ + walkBlock prc succs unwind' + (lbl `setInsert` visited, + insertMulti scope (block, prc, unwind') m) + where CmmEntry lbl scope = firstNode block + unwind' = extractUnwind block `Map.union` unwind + (CmmProc _ _ _ graph) = prc + succs = map (flip mapFind (toBlockMap graph)) + (successors (lastNode block)) + mapFind = mapFindWithDefault (error "contextTree: block not found!") + +insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] +insertMulti k v = Map.insertWith (const (v:)) k [v] + +cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] +cmmDebugLabels isMeta nats = seqList lbls lbls + where -- Find order in which procedures will be generated by the + -- back-end (that actually matters for DWARF generation). + -- + -- Note that we might encounter blocks that are missing or only + -- consist of meta instructions -- we will declare them missing, + -- which will skip debug data generation without messing up the + -- block hierarchy. + lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats + getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs + getBlocks _other = [] + allMeta (BasicBlock _ instrs) = all isMeta instrs + +-- | Sets position fields in the debug block tree according to native +-- generated code. +cmmDebugLink :: [Label] -> [DebugBlock] -> [DebugBlock] +cmmDebugLink labels blocks = map link blocks + where blockPos :: LabelMap Int + blockPos = mapFromList $ flip zip [0..] labels + link block = block { dblPosition = mapLookup (dblLabel block) blockPos + , dblBlocks = map link (dblBlocks block) + } + +-- | Converts debug blocks into a label map for easier lookups +debugToMap :: [DebugBlock] -> LabelMap DebugBlock +debugToMap = mapUnions . map go + where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b) + +-- | Maps registers to expressions that yield their "old" values +-- further up the stack. Most interesting for the stack pointer Sp, +-- but might be useful to document saved registers, too. +type UnwindTable = Map.Map GlobalReg UnwindExpr + +-- | Expressions, used for unwind information +data UnwindExpr = UwConst Int -- ^ literal value + | UwReg GlobalReg Int -- ^ register plus offset + | UwDeref UnwindExpr -- ^ pointer dereferencing + | UwPlus UnwindExpr UnwindExpr + | UwMinus UnwindExpr UnwindExpr + | UwTimes UnwindExpr UnwindExpr + deriving (Eq) + +instance Outputable UnwindExpr where + pprPrec _ (UwConst i) = ppr i + pprPrec _ (UwReg g 0) = ppr g + pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x)) + pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e + pprPrec p (UwPlus e0 e1) | p <= 0 + = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1 + pprPrec p (UwMinus e0 e1) | p <= 0 + = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1 + pprPrec p (UwTimes e0 e1) | p <= 1 + = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1 + pprPrec _ other = parens (pprPrec 0 other) + +extractUnwind :: CmmBlock -> UnwindTable +extractUnwind b = go $ blockToList mid + where (_, mid, _) = blockSplit b + go :: [CmmNode O O] -> UnwindTable + go [] = Map.empty + go (x : xs) = case x of + CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs + CmmTick {} -> go xs + _other -> Map.empty + -- TODO: Unwind statements after actual instructions + +-- | Conversion of Cmm expressions to unwind expressions. We check for +-- unsupported operator usages and simplify the expression as far as +-- possible. +toUnwindExpr :: CmmExpr -> UnwindExpr +toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) +toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i +toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0 +toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e) +toUnwindExpr e@(CmmMachOp op [e1, e2]) = + case (op, toUnwindExpr e1, toUnwindExpr e2) of + (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) + (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y) + (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y) + (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y) + (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y) + (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y) + (MO_Add{}, u1, u2 ) -> UwPlus u1 u2 + (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 + (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 + _otherwise -> pprPanic "Unsupported operator in unwind expression!" + (pprExpr e) +toUnwindExpr e + = pprPanic "Unsupported unwind expression!" (ppr e) diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs new file mode 100644 index 00000000..4b371728 --- /dev/null +++ b/compiler/cmm/Hoopl.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +module Hoopl ( + module Compiler.Hoopl, + module Hoopl.Dataflow, + deepFwdRw, deepFwdRw3, + deepBwdRw, deepBwdRw3, + thenFwdRw + ) where + +import Compiler.Hoopl hiding + ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph + Unique, + FwdTransfer(..), FwdRewrite(..), FwdPass(..), + BwdTransfer(..), BwdRewrite(..), BwdPass(..), + noFwdRewrite, noBwdRewrite, + analyzeAndRewriteFwd, analyzeAndRewriteBwd, + mkFactBase, Fact, + mkBRewrite, mkBRewrite3, mkBTransfer, mkBTransfer3, + mkFRewrite, mkFRewrite3, mkFTransfer, mkFTransfer3, + deepFwdRw, deepFwdRw3, thenFwdRw, iterFwdRw, + deepBwdRw, deepBwdRw3, thenBwdRw, iterBwdRw + ) + +import Hoopl.Dataflow +import Control.Monad +import UniqSupply + +deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O))) + -> (n O O -> f -> UniqSM (Maybe (Graph n O O))) + -> (n O C -> f -> UniqSM (Maybe (Graph n O C))) + -> (FwdRewrite UniqSM n f) +deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f +deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l +deepFwdRw f = deepFwdRw3 f f f + +-- N.B. rw3, rw3', and rw3a are triples of functions. +-- But rw and rw' are single functions. +thenFwdRw :: forall n f. + FwdRewrite UniqSM n f + -> FwdRewrite UniqSM n f + -> FwdRewrite UniqSM n f +thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' + where + thenrw :: forall e x t t1. + (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))) + -> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))) + -> t + -> t1 + -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)) + thenrw rw rw' n f = rw n f >>= fwdRes + where fwdRes Nothing = rw' n f + fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr + +iterFwdRw :: forall n f. + FwdRewrite UniqSM n f + -> FwdRewrite UniqSM n f +iterFwdRw rw3 = wrapFR iter rw3 + where iter :: forall a e x t. + (t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))) + -> t + -> a + -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)) + iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n + +-- | Function inspired by 'rew' in the paper +_frewrite_cps :: ((Graph n e x, FwdRewrite UniqSM n f) -> UniqSM a) + -> UniqSM a + -> (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))) + -> n e x + -> f + -> UniqSM a +_frewrite_cps j n rw node f = + do mg <- rw node f + case mg of Nothing -> n + Just gr -> j gr + + + +-- | Function inspired by 'add' in the paper +fadd_rw :: FwdRewrite UniqSM n f + -> (Graph n e x, FwdRewrite UniqSM n f) + -> (Graph n e x, FwdRewrite UniqSM n f) +fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2) + + + +deepBwdRw3 :: + (n C O -> f -> UniqSM (Maybe (Graph n C O))) + -> (n O O -> f -> UniqSM (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C))) + -> (BwdRewrite UniqSM n f) +deepBwdRw :: (forall e x . n e x -> Fact x f -> UniqSM (Maybe (Graph n e x))) + -> BwdRewrite UniqSM n f +deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l +deepBwdRw f = deepBwdRw3 f f f + + +thenBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f +thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2 + where f :: forall t t1 t2 e x. + t + -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))) + -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))) + -> t1 + -> t2 + -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)) + f _ rw1 rw2' n f = do + res1 <- rw1 n f + case res1 of + Nothing -> rw2' n f + Just gr -> return $ Just $ badd_rw rw2 gr + +iterBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f +iterBwdRw rw = wrapBR f rw + where f :: forall t e x t1 t2. + t + -> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))) + -> t1 + -> t2 + -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)) + f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f) + +-- | Function inspired by 'add' in the paper +badd_rw :: BwdRewrite UniqSM n f + -> (Graph n e x, BwdRewrite UniqSM n f) + -> (Graph n e x, BwdRewrite UniqSM n f) +badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) + +-- Note [Deprecations in Hoopl] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- CmmLive and CmmBuildInfoTables modules enable -fno-warn-warnings-deprecations +-- flag because they import deprecated functions from Hoopl. I spent some time +-- trying to figure out what is going on, so here's a brief explanation. The +-- culprit is the joinOutFacts function, which should be replaced with +-- joinFacts. The difference between them is that the latter one needs extra +-- Label parameter. Labels identify blocks and are used in the fact base to +-- assign facts to a block (in case you're wondering, Label is an Int wrapped in +-- a newtype). Lattice join function is also required to accept a Label but the +-- only reason why it is so are the debugging purposes: see joinInFacts function +-- which is a no-op and is run only because join function might produce +-- debugging output. Now, going back to the Cmm modules. The "problem" with the +-- deprecated joinOutFacts function is that it passes wrong label when calling +-- lattice join function: instead of label of a block for which we are joining +-- facts it uses labels of successors of that block. So the joinFacts function +-- expects to be given a label of a block for which we are joining facts. I +-- don't see an obvious way of recovering that Label at the call sites of +-- joinOutFacts (if that was easily done then joinFacts function could do it +-- internally without requiring label as a parameter). A cheap way of +-- eliminating these warnings would be to create a bogus Label, since none of +-- our join functions is actually using the Label parameter. But that doesn't +-- feel right. I think the real solution here is to fix Hoopl API, which is +-- already broken in several ways. See Hoopl/Cleanup page on the wiki for more +-- notes on improving Hoopl. diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs new file mode 100644 index 00000000..4fbf42e6 --- /dev/null +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -0,0 +1,887 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fprof-auto-top #-} + +-- +-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, +-- and Norman Ramsey +-- +-- Modifications copyright (c) The University of Glasgow 2012 +-- +-- This module is a specialised and optimised version of +-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is +-- specialised to the UniqSM monad. +-- + +module Hoopl.Dataflow + ( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase + , ChangeFlag(..) + , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3 + -- * Respecting Fuel + + -- $fuel + , FwdRewrite, mkFRewrite, mkFRewrite3, getFRewrite3, noFwdRewrite + , wrapFR, wrapFR2 + , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3 + , wrapBR, wrapBR2 + , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite + , analyzeAndRewriteFwd, analyzeAndRewriteBwd + , analyzeFwd, analyzeFwdBlocks, analyzeBwd + ) +where + +import UniqSupply + +import Data.Maybe +import Data.Array + +import Compiler.Hoopl hiding + ( mkBRewrite3, mkFRewrite3, noFwdRewrite, noBwdRewrite + , analyzeAndRewriteBwd, analyzeAndRewriteFwd + ) +import Compiler.Hoopl.Internals + ( wrapFR, wrapFR2 + , wrapBR, wrapBR2 + , splice + ) + + +-- ----------------------------------------------------------------------------- + +noRewrite :: a -> b -> UniqSM (Maybe c) +noRewrite _ _ = return Nothing + +noFwdRewrite :: FwdRewrite UniqSM n f +noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite) + +-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply. +-- The result returned by 'mkFRewrite3' respects fuel. +mkFRewrite3 :: forall n f. + (n C O -> f -> UniqSM (Maybe (Graph n C O))) + -> (n O O -> f -> UniqSM (Maybe (Graph n O O))) + -> (n O C -> f -> UniqSM (Maybe (Graph n O C))) + -> FwdRewrite UniqSM n f +mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> UniqSM (Maybe a)) + -> t -> t1 -> UniqSM (Maybe (a, FwdRewrite UniqSM n f)) + {-# INLINE lift #-} + lift rw node fact = do + a <- rw node fact + case a of + Nothing -> return Nothing + Just a -> return (Just (a,noFwdRewrite)) + +noBwdRewrite :: BwdRewrite UniqSM n f +noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite) + +mkBRewrite3 :: forall n f. + (n C O -> f -> UniqSM (Maybe (Graph n C O))) + -> (n O O -> f -> UniqSM (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C))) + -> BwdRewrite UniqSM n f +mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> UniqSM (Maybe a)) + -> t -> t1 -> UniqSM (Maybe (a, BwdRewrite UniqSM n f)) + {-# INLINE lift #-} + lift rw node fact = do + a <- rw node fact + case a of + Nothing -> return Nothing + Just a -> return (Just (a,noBwdRewrite)) + +----------------------------------------------------------------------------- +-- Analyze and rewrite forward: the interface +----------------------------------------------------------------------------- + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeAndRewriteFwd + :: forall n f e x . NonLocal n => + FwdPass UniqSM n f + -> MaybeC e [Label] + -> Graph n e x -> Fact e f + -> UniqSM (Graph n e x, FactBase f, MaybeO x f) +analyzeAndRewriteFwd pass entries g f = + do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedExitFact g' fout) + +distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f +distinguishedExitFact g f = maybe g + where maybe :: Graph n e x -> MaybeO x f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany _ _ x) = case x of NothingO -> NothingO + JustO _ -> JustO f + +---------------------------------------------------------------- +-- Forward Implementation +---------------------------------------------------------------- + +type Entries e = MaybeC e [Label] + +arfGraph :: forall n f e x . NonLocal n => + FwdPass UniqSM n f -> + Entries e -> Graph n e x -> Fact e f -> UniqSM (DG f n e x, Fact x f) +arfGraph pass@FwdPass { fp_lattice = lattice, + fp_transfer = transfer, + fp_rewrite = rewrite } entries g in_fact = graph g in_fact + where + {- nested type synonyms would be so lovely here + type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f) + type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) + -} + graph :: Graph n e x -> Fact e f -> UniqSM (DG f n e x, Fact x f) + block :: forall e x . + Block n e x -> f -> UniqSM (DG f n e x, Fact x f) + + body :: [Label] -> LabelMap (Block n C C) + -> Fact C f -> UniqSM (DG f n C C, Fact C f) + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' + + cat :: forall e a x f1 f2 f3. + (f1 -> UniqSM (DG f n e a, f2)) + -> (f2 -> UniqSM (DG f n a x, f3)) + -> (f1 -> UniqSM (DG f n e x, f3)) + + graph GNil f = return (dgnil, f) + graph (GUnit blk) f = block blk f + graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> UniqSM (DG f n e C, Fact C f) + exit :: MaybeO x (Block n C O) -> Fact C f -> UniqSM (DG f n C x, Fact x f) + exit (JustO blk) f = arfx block blk f + exit NothingO f = return (dgnilC, f) + ebcat entry bdy f = c entries entry f + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact e f -> UniqSM (DG f n e C, Fact C f) + c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f + c (JustC entries) NothingO f = body entries bdy f + c _ _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks + block BNil f = return (dgnil, f) + block (BlockCO n b) f = (node n `cat` block b) f + block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f + block (BlockOC b n) f = (block b `cat` node n) f + + block (BMiddle n) f = node n f + block (BCat b1 b2) f = (block b1 `cat` block b2) f + block (BSnoc h n) f = (block h `cat` node n) f + block (BCons n t) f = (node n `cat` block t) f + + {-# INLINE node #-} + node :: forall e x . (ShapeLifter e x) + => n e x -> f -> UniqSM (DG f n e x, Fact x f) + node n f + = do { grw <- frewrite rewrite n f + ; case grw of + Nothing -> return ( singletonDG f n + , ftransfer transfer n f ) + Just (g, rw) -> + let pass' = pass { fp_rewrite = rw } + f' = fwdEntryFact n f + in arfGraph pass' (fwdEntryLabel n) g f' } + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} + cat ft1 ft2 f = do { (g1,f1) <- ft1 f + ; (g2,f2) <- ft2 f1 + ; let !g = g1 `dgSplice` g2 + ; return (g, f2) } + + arfx :: forall x . + (Block n C x -> f -> UniqSM (DG f n C x, Fact x f)) + -> (Block n C x -> Fact C f -> UniqSM (DG f n C x, Fact x f)) + arfx arf thing fb = + arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb + -- joinInFacts adds debugging information + + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' + body entries blockmap init_fbase + = fixpoint Fwd lattice do_block entries blockmap init_fbase + where + lattice = fp_lattice pass + do_block :: forall x . Block n C x -> FactBase f + -> UniqSM (DG f n C x, Fact x f) + do_block b fb = block b entryFact + where entryFact = getFact lattice (entryLabel b) fb + + +-- Join all the incoming facts with bottom. +-- We know the results _shouldn't change_, but the transfer +-- functions might, for example, generate some debugging traces. +joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f +joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb = + mkFactBase lattice $ map botJoin $ mapToList fb + where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f)) + +forwardBlockList :: (NonLocal n) + => [Label] -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for forward analysis, +-- along with the list of Labels it may depend on for facts. +forwardBlockList entries blks = postorder_dfs_from blks entries + +---------------------------------------------------------------- +-- Forward Analysis only +---------------------------------------------------------------- + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeFwd + :: forall n f e . NonLocal n => + FwdPass UniqSM n f + -> MaybeC e [Label] + -> Graph n e C -> Fact e f + -> FactBase f +analyzeFwd FwdPass { fp_lattice = lattice, + fp_transfer = FwdTransfer3 (ftr, mtr, ltr) } + entries g in_fact = graph g in_fact + where + graph :: Graph n e C -> Fact e f -> FactBase f + graph (GMany entry blockmap NothingO) + = case (entries, entry) of + (NothingC, JustO entry) -> block entry `cat` body (successors entry) + (JustC entries, NothingO) -> body entries + _ -> error "bogus GADT pattern match failure" + where + body :: [Label] -> Fact C f -> Fact C f + body entries f + = fixpointAnal Fwd lattice do_block entries blockmap f + where + do_block :: forall x . Block n C x -> FactBase f -> Fact x f + do_block b fb = block b entryFact + where entryFact = getFact lattice (entryLabel b) fb + + -- NB. eta-expand block, GHC can't do this by itself. See #5809. + block :: forall e x . Block n e x -> f -> Fact x f + block BNil f = f + block (BlockCO n b) f = (ftr n `cat` block b) f + block (BlockCC l b n) f = (ftr l `cat` (block b `cat` ltr n)) f + block (BlockOC b n) f = (block b `cat` ltr n) f + + block (BMiddle n) f = mtr n f + block (BCat b1 b2) f = (block b1 `cat` block b2) f + block (BSnoc h n) f = (block h `cat` mtr n) f + block (BCons n t) f = (mtr n `cat` block t) f + + {-# INLINE cat #-} + cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3) + cat ft1 ft2 = \f -> ft2 $! ft1 f + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeFwdBlocks + :: forall n f e . NonLocal n => + FwdPass UniqSM n f + -> MaybeC e [Label] + -> Graph n e C -> Fact e f + -> FactBase f +analyzeFwdBlocks FwdPass { fp_lattice = lattice, + fp_transfer = FwdTransfer3 (ftr, _, ltr) } + entries g in_fact = graph g in_fact + where + graph :: Graph n e C -> Fact e f -> FactBase f + graph (GMany entry blockmap NothingO) + = case (entries, entry) of + (NothingC, JustO entry) -> block entry `cat` body (successors entry) + (JustC entries, NothingO) -> body entries + _ -> error "bogus GADT pattern match failure" + where + body :: [Label] -> Fact C f -> Fact C f + body entries f + = fixpointAnal Fwd lattice do_block entries blockmap f + where + do_block :: forall x . Block n C x -> FactBase f -> Fact x f + do_block b fb = block b entryFact + where entryFact = getFact lattice (entryLabel b) fb + + -- NB. eta-expand block, GHC can't do this by itself. See #5809. + block :: forall e x . Block n e x -> f -> Fact x f + block BNil f = f + block (BlockCO n _) f = ftr n f + block (BlockCC l _ n) f = (ftr l `cat` ltr n) f + block (BlockOC _ n) f = ltr n f + block _ _ = error "analyzeFwdBlocks" + + {-# INLINE cat #-} + cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3) + cat ft1 ft2 = \f -> ft2 $! ft1 f + +---------------------------------------------------------------- +-- Backward Analysis only +---------------------------------------------------------------- + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeBwd + :: forall n f e . NonLocal n => + BwdPass UniqSM n f + -> MaybeC e [Label] + -> Graph n e C -> Fact C f + -> FactBase f +analyzeBwd BwdPass { bp_lattice = lattice, + bp_transfer = BwdTransfer3 (ftr, mtr, ltr) } + entries g in_fact = graph g in_fact + where + graph :: Graph n e C -> Fact C f -> FactBase f + graph (GMany entry blockmap NothingO) + = case (entries, entry) of + (NothingC, JustO entry) -> body (successors entry) + (JustC entries, NothingO) -> body entries + _ -> error "bogus GADT pattern match failure" + where + body :: [Label] -> Fact C f -> Fact C f + body entries f + = fixpointAnal Bwd lattice do_block entries blockmap f + where + do_block :: forall x . Block n C x -> Fact x f -> FactBase f + do_block b fb = mapSingleton (entryLabel b) (block b fb) + + -- NB. eta-expand block, GHC can't do this by itself. See #5809. + block :: forall e x . Block n e x -> Fact x f -> f + block BNil f = f + block (BlockCO n b) f = (ftr n `cat` block b) f + block (BlockCC l b n) f = ((ftr l `cat` block b) `cat` ltr n) f + block (BlockOC b n) f = (block b `cat` ltr n) f + + block (BMiddle n) f = mtr n f + block (BCat b1 b2) f = (block b1 `cat` block b2) f + block (BSnoc h n) f = (block h `cat` mtr n) f + block (BCons n t) f = (mtr n `cat` block t) f + + {-# INLINE cat #-} + cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3) + cat ft1 ft2 = \f -> ft1 $! ft2 f + +----------------------------------------------------------------------------- +-- Backward analysis and rewriting: the interface +----------------------------------------------------------------------------- + + +-- | if the graph being analyzed is open at the exit, I don't +-- quite understand the implications of possible other exits +analyzeAndRewriteBwd + :: NonLocal n + => BwdPass UniqSM n f + -> MaybeC e [Label] -> Graph n e x -> Fact x f + -> UniqSM (Graph n e x, FactBase f, MaybeO e f) +analyzeAndRewriteBwd pass entries g f = + do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedEntryFact g' fout) + +distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f +distinguishedEntryFact g f = maybe g + where maybe :: Graph n e x -> MaybeO e f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany e _ _) = case e of NothingO -> NothingO + JustO _ -> JustO f + + +----------------------------------------------------------------------------- +-- Backward implementation +----------------------------------------------------------------------------- + +arbGraph :: forall n f e x . + NonLocal n => + BwdPass UniqSM n f -> + Entries e -> Graph n e x -> Fact x f -> UniqSM (DG f n e x, Fact e f) +arbGraph pass@BwdPass { bp_lattice = lattice, + bp_transfer = transfer, + bp_rewrite = rewrite } entries g in_fact = graph g in_fact + where + {- nested type synonyms would be so lovely here + type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f) + type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f) + -} + graph :: Graph n e x -> Fact x f -> UniqSM (DG f n e x, Fact e f) + block :: forall e x . Block n e x -> Fact x f -> UniqSM (DG f n e x, f) + body :: [Label] -> Body n -> Fact C f -> UniqSM (DG f n C C, Fact C f) + node :: forall e x . (ShapeLifter e x) + => n e x -> Fact x f -> UniqSM (DG f n e x, f) + cat :: forall e a x info info' info''. + (info' -> UniqSM (DG f n e a, info'')) + -> (info -> UniqSM (DG f n a x, info')) + -> (info -> UniqSM (DG f n e x, info'')) + + graph GNil f = return (dgnil, f) + graph (GUnit blk) f = block blk f + graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> UniqSM (DG f n e C, Fact e f) + exit :: MaybeO x (Block n C O) -> Fact x f -> UniqSM (DG f n C x, Fact C f) + exit (JustO blk) f = arbx block blk f + exit NothingO f = return (dgnilC, f) + ebcat entry bdy f = c entries entry f + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact C f -> UniqSM (DG f n e C, Fact e f) + c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f + c (JustC entries) NothingO f = body entries bdy f + c _ _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks + block BNil f = return (dgnil, f) + block (BlockCO n b) f = (node n `cat` block b) f + block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f + block (BlockOC b n) f = (block b `cat` node n) f + + block (BMiddle n) f = node n f + block (BCat b1 b2) f = (block b1 `cat` block b2) f + block (BSnoc h n) f = (block h `cat` node n) f + block (BCons n t) f = (node n `cat` block t) f + + {-# INLINE node #-} + node n f + = do { bwdres <- brewrite rewrite n f + ; case bwdres of + Nothing -> return (singletonDG entry_f n, entry_f) + where entry_f = btransfer transfer n f + Just (g, rw) -> + do { let pass' = pass { bp_rewrite = rw } + ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f + ; return (g, bwdEntryFact lattice n f)} } + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} + cat ft1 ft2 f = do { (g2,f2) <- ft2 f + ; (g1,f1) <- ft1 f2 + ; let !g = g1 `dgSplice` g2 + ; return (g, f1) } + + arbx :: forall x . + (Block n C x -> Fact x f -> UniqSM (DG f n C x, f)) + -> (Block n C x -> Fact x f -> UniqSM (DG f n C x, Fact C f)) + + arbx arb thing f = do { (rg, f) <- arb thing f + ; let fb = joinInFacts (bp_lattice pass) $ + mapSingleton (entryLabel thing) f + ; return (rg, fb) } + -- joinInFacts adds debugging information + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' + body entries blockmap init_fbase + = fixpoint Bwd (bp_lattice pass) do_block entries blockmap init_fbase + where + do_block :: forall x. Block n C x -> Fact x f -> UniqSM (DG f n C x, LabelMap f) + do_block b f = do (g, f) <- block b f + return (g, mapSingleton (entryLabel b) f) + + +{- + +The forward and backward cases are not dual. In the forward case, the +entry points are known, and one simply traverses the body blocks from +those points. In the backward case, something is known about the exit +points, but this information is essentially useless, because we don't +actually have a dual graph (that is, one with edges reversed) to +compute with. (Even if we did have a dual graph, it would not avail +us---a backward analysis must include reachable blocks that don't +reach the exit, as in a procedure that loops forever and has side +effects.) + +-} + +----------------------------------------------------------------------------- +-- fixpoint +----------------------------------------------------------------------------- + +data Direction = Fwd | Bwd + +-- | fixpointing for analysis-only +-- +fixpointAnal :: forall n f. NonLocal n + => Direction + -> DataflowLattice f + -> (Block n C C -> Fact C f -> Fact C f) + -> [Label] + -> LabelMap (Block n C C) + -> Fact C f -> FactBase f + +fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join } + do_block entries blockmap init_fbase + = loop start init_fbase + where + blocks = sortBlocks direction entries blockmap + n = length blocks + block_arr = {-# SCC "block_arr" #-} listArray (0,n-1) blocks + start = {-# SCC "start" #-} [0..n-1] + dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks + + loop + :: IntHeap -- blocks still to analyse + -> FactBase f -- current factbase (increases monotonically) + -> FactBase f + + loop [] fbase = fbase + loop (ix:todo) fbase = + let + blk = block_arr ! ix + + out_facts = {-# SCC "do_block" #-} do_block blk fbase + + !(todo', fbase') = {-# SCC "mapFoldWithKey" #-} + mapFoldWithKey (updateFact join dep_blocks) + (todo,fbase) out_facts + in + -- trace ("analysing: " ++ show (entryLabel blk)) $ + -- trace ("fbase': " ++ show (mapKeys fbase')) $ return () + -- trace ("changed: " ++ show changed) $ return () + -- trace ("to analyse: " ++ show to_analyse) $ return () + + loop todo' fbase' + + +-- | fixpointing for combined analysis/rewriting +-- +fixpoint :: forall n f. NonLocal n + => Direction + -> DataflowLattice f + -> (Block n C C -> Fact C f -> UniqSM (DG f n C C, Fact C f)) + -> [Label] + -> LabelMap (Block n C C) + -> (Fact C f -> UniqSM (DG f n C C, Fact C f)) + +fixpoint direction DataflowLattice{ fact_bot = _, fact_join = join } + do_block entries blockmap init_fbase + = do + -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return() + (fbase, newblocks) <- loop start init_fbase mapEmpty + -- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return() + return (GMany NothingO newblocks NothingO, + mapDeleteList (mapKeys blockmap) fbase) + -- The successors of the Graph are the the Labels + -- for which we have facts and which are *not* in + -- the blocks of the graph + where + blocks = sortBlocks direction entries blockmap + n = length blocks + block_arr = {-# SCC "block_arr" #-} listArray (0,n-1) blocks + start = {-# SCC "start" #-} [0..n-1] + dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks + + loop + :: IntHeap + -> FactBase f -- current factbase (increases monotonically) + -> LabelMap (DBlock f n C C) -- transformed graph + -> UniqSM (FactBase f, LabelMap (DBlock f n C C)) + + loop [] fbase newblocks = return (fbase, newblocks) + loop (ix:todo) fbase !newblocks = do + let blk = block_arr ! ix + + -- trace ("analysing: " ++ show (entryLabel blk)) $ return () + (rg, out_facts) <- do_block blk fbase + let !(todo', fbase') = + mapFoldWithKey (updateFact join dep_blocks) + (todo,fbase) out_facts + + -- trace ("fbase': " ++ show (mapKeys fbase')) $ return () + -- trace ("changed: " ++ show changed) $ return () + -- trace ("to analyse: " ++ show to_analyse) $ return () + + let newblocks' = case rg of + GMany _ blks _ -> mapUnion blks newblocks + + loop todo' fbase' newblocks' + + +{- Note [TxFactBase invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TxFactBase is used only during a fixpoint iteration (or "sweep"), +and accumulates facts (and the transformed code) during the fixpoint +iteration. + +* tfb_fbase increases monotonically, across all sweeps + +* At the beginning of each sweep + tfb_cha = NoChange + tfb_lbls = {} + +* During each sweep we process each block in turn. Processing a block + is done thus: + 1. Read from tfb_fbase the facts for its entry label (forward) + or successors labels (backward) + 2. Transform those facts into new facts for its successors (forward) + or entry label (backward) + 3. Augment tfb_fbase with that info + We call the labels read in step (1) the "in-labels" of the sweep + +* The field tfb_lbls is the set of in-labels of all blocks that have + been processed so far this sweep, including the block that is + currently being processed. tfb_lbls is initialised to {}. It is a + subset of the Labels of the *original* (not transformed) blocks. + +* The tfb_cha field is set to SomeChange iff we decide we need to + perform another iteration of the fixpoint loop. It is initialsed to NoChange. + + Specifically, we set tfb_cha to SomeChange in step (3) iff + (a) The fact in tfb_fbase for a block L changes + (b) L is in tfb_lbls + Reason: until a label enters the in-labels its accumuated fact in tfb_fbase + has not been read, hence cannot affect the outcome + +Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* ixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + + +----------------------------------------------------------------------------- +-- Pieces that are shared by fixpoint and fixpoint_anal +----------------------------------------------------------------------------- + +-- | Sort the blocks into the right order for analysis. +sortBlocks :: NonLocal n => Direction -> [Label] -> LabelMap (Block n C C) + -> [Block n C C] +sortBlocks direction entries blockmap + = case direction of Fwd -> fwd + Bwd -> reverse fwd + where fwd = forwardBlockList entries blockmap + +-- | construct a mapping from L -> block indices. If the fact for L +-- changes, re-analyse the given blocks. +mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int] +mkDepBlocks Fwd blocks = go blocks 0 mapEmpty + where go [] !_ m = m + go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m +mkDepBlocks Bwd blocks = go blocks 0 mapEmpty + where go [] !_ m = m + go (b:bs) !n m = go bs (n+1) $! go' (successors b) m + where go' [] m = m + go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m) + + +-- | After some new facts have been generated by analysing a block, we +-- fold this function over them to generate (a) a list of block +-- indices to (re-)analyse, and (b) the new FactBase. +-- +updateFact :: JoinFun f -> LabelMap [Int] + -> Label -> f -- out fact + -> (IntHeap, FactBase f) + -> (IntHeap, FactBase f) + +updateFact fact_join dep_blocks lbl new_fact (todo, fbase) + = case lookupFact lbl fbase of + Nothing -> let !z = mapInsert lbl new_fact fbase in (changed, z) + -- Note [no old fact] + Just old_fact -> + case fact_join lbl (OldFact old_fact) (NewFact new_fact) of + (NoChange, _) -> (todo, fbase) + (_, f) -> let !z = mapInsert lbl f fbase in (changed, z) + where + changed = foldr insertIntHeap todo $ + mapFindWithDefault [] lbl dep_blocks + +{- +Note [no old fact] + +We know that the new_fact is >= _|_, so we don't need to join. However, +if the new fact is also _|_, and we have already analysed its block, +we don't need to record a change. So there's a tradeoff here. It turns +out that always recording a change is faster. +-} + +----------------------------------------------------------------------------- +-- DG: an internal data type for 'decorated graphs' +-- TOTALLY internal to Hoopl; each block is decorated with a fact +----------------------------------------------------------------------------- + +type DG f = Graph' (DBlock f) +data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact + +instance NonLocal n => NonLocal (DBlock f n) where + entryLabel (DBlock _ b) = entryLabel b + successors (DBlock _ b) = successors b + +--- constructors + +dgnil :: DG f n O O +dgnilC :: DG f n C C +dgSplice :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x + +---- observers + +normalizeGraph :: forall n f e x . + NonLocal n => DG f n e x + -> (Graph n e x, FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +normalizeGraph g = (mapGraphBlocks dropFact g, facts g) + where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3 + dropFact (DBlock _ b) = b + facts :: DG f n e x -> FactBase f + facts GNil = noFacts + facts (GUnit _) = noFacts + facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit + exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f + exitFacts NothingO = noFacts + exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f + bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f + bodyFacts body = mapFoldWithKey f noFacts body + where f :: forall t a x. (NonLocal t) => Label -> DBlock a t C x -> LabelMap a -> LabelMap a + f lbl (DBlock f _) fb = mapInsert lbl f fb + +--- implementation of the constructors (boring) + +dgnil = GNil +dgnilC = GMany NothingO emptyBody NothingO + +dgSplice = splice fzCat + where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x + fzCat (DBlock f b1) (DBlock _ b2) = DBlock f $! b1 `blockAppend` b2 + -- NB. strictness, this function is hammered. + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Lifting based on shape: +-- - from nodes to blocks +-- - from facts to fact-like things +-- Lowering back: +-- - from fact-like things to facts +-- Note that the latter two functions depend only on the entry shape. +class ShapeLifter e x where + singletonDG :: f -> n e x -> DG f n e x + fwdEntryFact :: NonLocal n => n e x -> f -> Fact e f + fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label] + ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f + frewrite :: FwdRewrite m n f -> n e x + -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)) +-- @ end node.tex + bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f + btransfer :: BwdTransfer n f -> n e x -> Fact x f -> f + brewrite :: BwdRewrite m n f -> n e x + -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f)) + +instance ShapeLifter C O where + singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil)) + fwdEntryFact n f = mapSingleton (entryLabel n) f + bwdEntryFact lat n fb = getFact lat (entryLabel n) fb + ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f + btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f + frewrite (FwdRewrite3 (fr, _, _)) n f = fr n f + brewrite (BwdRewrite3 (br, _, _)) n f = br n f + fwdEntryLabel n = JustC [entryLabel n] + +instance ShapeLifter O O where + singletonDG f = gUnitOO . DBlock f . BMiddle + fwdEntryFact _ f = f + bwdEntryFact _ _ f = f + ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f + btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f + frewrite (FwdRewrite3 (_, fr, _)) n f = fr n f + brewrite (BwdRewrite3 (_, br, _)) n f = br n f + fwdEntryLabel _ = NothingC + +instance ShapeLifter O C where + singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n)) + fwdEntryFact _ f = f + bwdEntryFact _ _ f = f + ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f + btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f + frewrite (FwdRewrite3 (_, _, fr)) n f = fr n f + brewrite (BwdRewrite3 (_, _, br)) n f = br n f + fwdEntryLabel _ = NothingC + +{- +class ShapeLifter e x where + singletonDG :: f -> n e x -> DG f n e x + +instance ShapeLifter C O where + singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil)) + +instance ShapeLifter O O where + singletonDG f = gUnitOO . DBlock f . BMiddle + +instance ShapeLifter O C where + singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n)) +-} + +-- Fact lookup: the fact `orelse` bottom +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact l fb of Just f -> f + Nothing -> fact_bot lat + + + +{- Note [Respects fuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} +-- $fuel +-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if +-- any function contained within the value satisfies the following properties: +-- +-- * When fuel is exhausted, it always returns 'Nothing'. +-- +-- * When it returns @Just g rw@, it consumes /exactly/ one unit +-- of fuel, and new rewrite 'rw' also respects fuel. +-- +-- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', +-- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply, +-- the results respect fuel. +-- +-- It is an /unchecked/ run-time error for the argument passed to 'wrapFR', +-- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel. + +-- ----------------------------------------------------------------------------- +-- a Heap of Int + +-- We should really use a proper Heap here, but my attempts to make +-- one have not succeeded in beating the simple ordered list. Another +-- alternative is IntSet (using deleteFindMin), but that was also +-- slower than the ordered list in my experiments --SDM 25/1/2012 + +type IntHeap = [Int] -- ordered + +insertIntHeap :: Int -> [Int] -> [Int] +insertIntHeap x [] = [x] +insertIntHeap x (y:ys) + | x < y = x : y : ys + | x == y = x : ys + | otherwise = y : insertIntHeap x ys diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs new file mode 100644 index 00000000..064577cd --- /dev/null +++ b/compiler/cmm/MkGraph.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BangPatterns, CPP, GADTs #-} + +module MkGraph + ( CmmAGraph, CmmAGraphScoped, CgStmt(..) + , (<*>), catAGraphs + , mkLabel, mkMiddle, mkLast, outOfLine + , lgraphOfAGraph, labelAGraph + + , stackStubExpr + , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo + , mkJumpReturnsTo + , mkJump, mkJumpExtra + , mkRawJump + , mkCbranch, mkSwitch + , mkReturn, mkComment, mkCallEntry, mkBranch + , copyInOflow, copyOutOflow + , noExtraStack + , toCall, Transfer(..) + ) +where + +import BlockId +import Cmm +import CmmCallConv + +import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) +import DynFlags +import FastString +import ForeignCall +import SMRep (ByteOff) +import UniqSupply +import OrdList + +import Control.Monad +import Data.List +import Data.Maybe +import Prelude (($),Int,Eq(..)) -- avoid importing (<*>) + +#include "HsVersions.h" + + +----------------------------------------------------------------------------- +-- Building Graphs + + +-- | CmmAGraph is a chunk of code consisting of: +-- +-- * ordinary statements (assignments, stores etc.) +-- * jumps +-- * labels +-- * out-of-line labelled blocks +-- +-- The semantics is that control falls through labels and out-of-line +-- blocks. Everything after a jump up to the next label is by +-- definition unreachable code, and will be discarded. +-- +-- Two CmmAGraphs can be stuck together with <*>, with the meaning that +-- control flows from the first to the second. +-- +-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) +-- by providing a label for the entry point and a tick scope; see +-- 'labelAGraph'. +type CmmAGraph = OrdList CgStmt +-- | Unlabeled graph with tick scope +type CmmAGraphScoped = (CmmAGraph, CmmTickScope) + +data CgStmt + = CgLabel BlockId CmmTickScope + | CgStmt (CmmNode O O) + | CgLast (CmmNode O C) + | CgFork BlockId CmmAGraph CmmTickScope + +flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph +flattenCmmAGraph id (stmts_t, tscope) = + CmmGraph { g_entry = id, + g_graph = GMany NothingO body NothingO } + where + body = foldr addBlock emptyBody $ flatten id stmts_t tscope [] + + -- + -- flatten: given an entry label and a CmmAGraph, make a list of blocks. + -- + -- NB. avoid the quadratic-append trap by passing in the tail of the + -- list. This is important for Very Long Functions (e.g. in T783). + -- + flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C] + -> [Block CmmNode C C] + flatten id g tscope blocks + = flatten1 (fromOL g) block' blocks + where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock + -- + -- flatten0: we are outside a block at this point: any code before + -- the first label is unreachable, so just drop it. + -- + flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] + flatten0 [] blocks = blocks + + flatten0 (CgLabel id tscope : stmts) blocks + = flatten1 stmts block blocks + where !block = blockJoinHead (CmmEntry id tscope) emptyBlock + + flatten0 (CgFork fork_id stmts_t tscope : rest) blocks + = flatten fork_id stmts_t tscope $ flatten0 rest blocks + + flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks + flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks + + -- + -- flatten1: we have a partial block, collect statements until the + -- next last node to make a block, then call flatten0 to get the rest + -- of the blocks + -- + flatten1 :: [CgStmt] -> Block CmmNode C O + -> [Block CmmNode C C] -> [Block CmmNode C C] + + -- The current block falls through to the end of a function or fork: + -- this code should not be reachable, but it may be referenced by + -- other code that is not reachable. We'll remove it later with + -- dead-code analysis, but for now we have to keep the graph + -- well-formed, so we terminate the block with a branch to the + -- beginning of the current block. + flatten1 [] block blocks + = blockJoinTail block (CmmBranch (entryLabel block)) : blocks + + flatten1 (CgLast stmt : stmts) block blocks + = block' : flatten0 stmts blocks + where !block' = blockJoinTail block stmt + + flatten1 (CgStmt stmt : stmts) block blocks + = flatten1 stmts block' blocks + where !block' = blockSnoc block stmt + + flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks + = flatten fork_id stmts_t tscope $ flatten1 rest block blocks + + -- a label here means that we should start a new block, and the + -- current block should fall through to the new block. + flatten1 (CgLabel id tscp : stmts) block blocks + = blockJoinTail block (CmmBranch id) : + flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks + + + +---------- AGraph manipulation + +(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph +(<*>) = appOL + +catAGraphs :: [CmmAGraph] -> CmmAGraph +catAGraphs = concatOL + +-- | created a sequence "goto id; id:" as an AGraph +mkLabel :: BlockId -> CmmTickScope -> CmmAGraph +mkLabel bid scp = unitOL (CgLabel bid scp) + +-- | creates an open AGraph from a given node +mkMiddle :: CmmNode O O -> CmmAGraph +mkMiddle middle = unitOL (CgStmt middle) + +-- | created a closed AGraph from a given node +mkLast :: CmmNode O C -> CmmAGraph +mkLast last = unitOL (CgLast last) + +-- | A labelled code block; should end in a last node +outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph +outOfLine l (c,s) = unitOL (CgFork l c s) + +-- | allocate a fresh label for the entry point +lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph +lgraphOfAGraph g = do + u <- getUniqueM + return (labelAGraph (mkBlockId u) g) + +-- | use the given BlockId as the label of the entry point +labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph +labelAGraph lbl ag = flattenCmmAGraph lbl ag + +---------- No-ops +mkNop :: CmmAGraph +mkNop = nilOL + +mkComment :: FastString -> CmmAGraph +#ifdef DEBUG +-- SDM: generating all those comments takes time, this saved about 4% for me +mkComment fs = mkMiddle $ CmmComment fs +#else +mkComment _ = nilOL +#endif + +---------- Assignment and store +mkAssign :: CmmReg -> CmmExpr -> CmmAGraph +mkAssign l (CmmReg r) | l == r = mkNop +mkAssign l r = mkMiddle $ CmmAssign l r + +mkStore :: CmmExpr -> CmmExpr -> CmmAGraph +mkStore l r = mkMiddle $ CmmStore l r + +---------- Control transfer +mkJump :: DynFlags -> Convention -> CmmExpr + -> [CmmActual] + -> UpdFrameOffset + -> CmmAGraph +mkJump dflags conv e actuals updfr_off = + lastWithArgs dflags Jump Old conv actuals updfr_off $ + toCall e Nothing updfr_off 0 + +-- | A jump where the caller says what the live GlobalRegs are. Used +-- for low-level hand-written Cmm. +mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] + -> CmmAGraph +mkRawJump dflags e updfr_off vols = + lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ + \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols + + +mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual] + -> UpdFrameOffset -> [CmmActual] + -> CmmAGraph +mkJumpExtra dflags conv e actuals updfr_off extra_stack = + lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ + toCall e Nothing updfr_off 0 + +mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph +mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot) + +mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph +mkSwitch e tbl = mkLast $ CmmSwitch e tbl + +mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset + -> CmmAGraph +mkReturn dflags e actuals updfr_off = + lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ + toCall e Nothing updfr_off 0 + +mkBranch :: BlockId -> CmmAGraph +mkBranch bid = mkLast (CmmBranch bid) + +mkFinalCall :: DynFlags + -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset + -> CmmAGraph +mkFinalCall dflags f _ actuals updfr_off = + lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ + toCall f Nothing updfr_off 0 + +mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> [CmmActual] + -> CmmAGraph +mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do + lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals + updfr_off extra_stack $ + toCall f (Just ret_lbl) updfr_off ret_off + +-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be +-- already on the stack). +mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual] + -> BlockId + -> ByteOff + -> UpdFrameOffset + -> CmmAGraph +mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do + lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $ + toCall f (Just ret_lbl) updfr_off ret_off + +mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph +mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as + + +-------------------------------------------------------------------------- + + + + +-- Why are we inserting extra blocks that simply branch to the successors? +-- Because in addition to the branch instruction, @mkBranch@ will insert +-- a necessary adjustment to the stack pointer. + + +-- For debugging purposes, we can stub out dead stack slots: +stackStubExpr :: Width -> CmmExpr +stackStubExpr w = CmmLit (CmmInt 0 w) + +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass the +-- variables in their spill slots. Therefore, for copying arguments +-- and results, we provide different functions to pass the arguments +-- in an overflow area and to pass them in spill slots. +copyInOflow :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (Int, [GlobalReg], CmmAGraph) + +copyInOflow dflags conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk + +-- Return the number of bytes used for copying arguments, as well as the +-- instructions to copy the arguments. +copyIn :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (ByteOff, [GlobalReg], [CmmNode O O]) +copyIn dflags conv area formals extra_stk + = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) + where + ci (reg, RegisterParam r) = + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + ci (reg, StackParam off) = + CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) + where ty = localRegType reg + + init_offset = widthInBytes (wordWidth dflags) -- infotable + + (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk + + (stk_size, args) = assignArgumentsPos dflags stk_off conv + localRegType formals + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: + +data Transfer = Call | JumpRet | Jump | Ret deriving Eq + +copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual] + -> UpdFrameOffset + -> [CmmActual] -- extra stack args + -> (Int, [GlobalReg], CmmAGraph) + +-- Generate code to move the actual parameters into the locations +-- required by the calling convention. This includes a store for the +-- return address. +-- +-- The argument layout function ignores the pointer to the info table, +-- so we slot that in here. When copying-out to a young area, we set +-- the info table for return and adjust the offsets of the other +-- parameters. If this is a call instruction, we adjust the offsets +-- of the other parameters. +copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff + = (stk_size, regs, graph) + where + (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) + + co (v, RegisterParam r) (rs, ms) + = (r:rs, mkAssign (CmmGlobal r) v <*> ms) + co (v, StackParam off) (rs, ms) + = (rs, mkStore (CmmStackSlot area off) v <*> ms) + + (setRA, init_offset) = + case area of + Young id -> -- Generate a store instruction for + -- the return address if making a call + case transfer of + Call -> + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes (wordWidth dflags)) + JumpRet -> + ([], + widthInBytes (wordWidth dflags)) + _other -> + ([], 0) + Old -> ([], updfr_off) + + (extra_stack_off, stack_params) = + assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff + + args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it + (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv + (cmmExprType dflags) actuals + + + +mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] + -> (Int, [GlobalReg], CmmAGraph) +mkCallEntry dflags conv formals extra_stk + = copyInOflow dflags conv Old formals extra_stk + +lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual] + -> UpdFrameOffset + -> (ByteOff -> [GlobalReg] -> CmmAGraph) + -> CmmAGraph +lastWithArgs dflags transfer area conv actuals updfr_off last = + lastWithArgsAndExtraStack dflags transfer area conv actuals + updfr_off noExtraStack last + +lastWithArgsAndExtraStack :: DynFlags + -> Transfer -> Area -> Convention -> [CmmActual] + -> UpdFrameOffset -> [CmmActual] + -> (ByteOff -> [GlobalReg] -> CmmAGraph) + -> CmmAGraph +lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off + extra_stack last = + copies <*> last outArgs regs + where + (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals + updfr_off extra_stack + + +noExtraStack :: [CmmActual] +noExtraStack = [] + +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff + -> ByteOff -> [GlobalReg] + -> CmmAGraph +toCall e cont updfr_off res_space arg_space regs = + mkLast $ CmmCall e cont regs arg_space res_space updfr_off diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs new file mode 100644 index 00000000..3c4c3795 --- /dev/null +++ b/compiler/cmm/PprC.hs @@ -0,0 +1,1271 @@ +{-# LANGUAGE CPP, GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as C, suitable for feeding gcc +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- Print Cmm as real C, for -fvia-C +-- +-- See wiki:Commentary/Compiler/Backends/PprC +-- +-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" +-- relative to the old AbstractC, and many oddities/decorations have +-- disappeared from the data type. +-- +-- This code generator is only supported in unregisterised mode. +-- +----------------------------------------------------------------------------- + +module PprC ( + writeCs, + pprStringInCStyle + ) where + +#include "HsVersions.h" + +-- Cmm stuff +import BlockId +import CLabel +import ForeignCall +import Cmm hiding (pprBBlock) +import PprCmm () +import Hoopl +import CmmUtils + +-- Utils +import CPrim +import DynFlags +import FastString +import Outputable +import Platform +import UniqSet +import Unique +import Util + +-- The rest +import Control.Monad.ST +import Data.Bits +import Data.Char +import Data.List +import Data.Map (Map) +import Data.Word +import System.IO +import qualified Data.Map as Map +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST + +-- -------------------------------------------------------------------------- +-- Top level + +pprCs :: DynFlags -> [RawCmmGroup] -> SDoc +pprCs dflags cmms + = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) + where + split_marker + | gopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER") + | otherwise = empty + +writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO () +writeCs dflags handle cmms + = printForC dflags handle (pprCs dflags cmms) + +-- -------------------------------------------------------------------------- +-- Now do some real work +-- +-- for fun, we could call cmmToCmm over the tops... +-- + +pprC :: RawCmmGroup -> SDoc +pprC tops = vcat $ intersperse blankLine $ map pprTop tops + +-- +-- top level procs +-- +pprTop :: RawCmmDecl -> SDoc +pprTop (CmmProc infos clbl _ graph) = + + (case mapLookup (g_entry graph) infos of + Nothing -> empty + Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ + pprWordArray info_clbl info_dat) $$ + (vcat [ + blankLine, + extern_decls, + (if (externallyVisibleCLabel clbl) + then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, + nest 8 temp_decls, + vcat (map pprBBlock blocks), + rbrace ] + ) + where + blocks = toBlockListEntryFirst graph + (temp_decls, extern_decls) = pprTempAndExternDecls blocks + + +-- Chunks of static data. + +-- We only handle (a) arrays of word-sized things and (b) strings. + +pprTop (CmmData _section (Statics lbl [CmmString str])) = + hcat [ + pprLocalness lbl, ptext (sLit "char "), ppr lbl, + ptext (sLit "[] = "), pprStringInCStyle str, semi + ] + +pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = + hcat [ + pprLocalness lbl, ptext (sLit "char "), ppr lbl, + brackets (int size), semi + ] + +pprTop (CmmData _section (Statics lbl lits)) = + pprDataExterns lits $$ + pprWordArray lbl lits + +-- -------------------------------------------------------------------------- +-- BasicBlocks are self-contained entities: they always end in a jump. +-- +-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn +-- as many jumps as possible into fall throughs. +-- + +pprBBlock :: CmmBlock -> SDoc +pprBBlock block = + nest 4 (pprBlockId (entryLabel block) <> colon) $$ + nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) + where + (_, nodes, last) = blockSplit block + +-- -------------------------------------------------------------------------- +-- Info tables. Just arrays of words. +-- See codeGen/ClosureInfo, and nativeGen/PprMach + +pprWordArray :: CLabel -> [CmmStatic] -> SDoc +pprWordArray lbl ds + = sdocWithDynFlags $ \dflags -> + hcat [ pprLocalness lbl, ptext (sLit "StgWord") + , space, ppr lbl, ptext (sLit "[] = {") ] + $$ nest 8 (commafy (pprStatics dflags ds)) + $$ ptext (sLit "};") + +-- +-- has to be static, if it isn't globally visible +-- +pprLocalness :: CLabel -> SDoc +pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") + | otherwise = empty + +-- -------------------------------------------------------------------------- +-- Statements. +-- + +pprStmt :: CmmNode e x -> SDoc + +pprStmt stmt = + sdocWithDynFlags $ \dflags -> + case stmt of + CmmEntry{} -> empty + CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + -- XXX if the string contains "*/", we need to fix it + -- XXX we probably want to emit these comments when + -- some debugging option is on. They can get quite + -- large. + + CmmTick _ -> empty + + CmmAssign dest src -> pprAssign dflags dest src + + CmmStore dest src + | typeWidth rep == W64 && wordWidth dflags /= W64 + -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL") + else ptext (sLit ("ASSIGN_Word64"))) <> + parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + + | otherwise + -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] + where + rep = cmmExprType dflags src + + CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> + fnCall + where + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + ForeignConvention cconv _ _ ret = conv + + cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) + + -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes + fnCall = + case fn of + CmmLit (CmmLabel lbl) + | StdCallConv <- cconv -> + pprCall (ppr lbl) cconv hresults hargs + -- stdcall functions must be declared with + -- a function type, otherwise the C compiler + -- doesn't add the @n suffix to the label. We + -- can't add the @n suffix ourselves, because + -- it isn't valid C. + | CmmNeverReturns <- ret -> + pprCall cast_fn cconv hresults hargs <> semi + | not (isMathFun lbl) -> + pprForeignCall (ppr lbl) cconv hresults hargs + _ -> + pprCall cast_fn cconv hresults hargs <> semi + -- for a dynamic call, no declaration is necessary. + + CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty + CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty + + CmmUnsafeForeignCall target@(PrimTarget op) results args -> + fn_call + where + cconv = CCallConv + fn = pprCallishMachOp_for_C op + + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + fn_call + -- The mem primops carry an extra alignment arg, must drop it. + -- We could maybe emit an alignment directive using this info. + -- We also need to cast mem primops to prevent conflicts with GCC + -- builtins (see bug #5967). + | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove] + = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$ + pprForeignCall fn cconv hresults (init hargs) + | otherwise + = pprCall fn cconv hresults hargs + + CmmBranch ident -> pprBranch ident + CmmCondBranch expr yes no -> pprCondBranch expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi + CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> + pprSwitch dflags arg ids + + _other -> pprPanic "PprC.pprStmt" (ppr stmt) + +type Hinted a = (a, ForeignHint) + +pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] + -> SDoc +pprForeignCall fn cconv results args = fn_call + where + fn_call = braces ( + pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall (text "ghcFunPtr") cconv results args <> semi + ) + cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) + +pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCFunType ppr_fn cconv ress args + = sdocWithDynFlags $ \dflags -> + let res_type [] = ptext (sLit "void") + res_type [(one, hint)] = machRepHintCType (localRegType one) hint + res_type _ = panic "pprCFunType: only void or 1 return value supported" + + arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint + in res_type ress <+> + parens (ccallConvAttribute cconv <> ppr_fn) <> + parens (commafy (map arg_type args)) + +-- --------------------------------------------------------------------- +-- unconditional branches +pprBranch :: BlockId -> SDoc +pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi + + +-- --------------------------------------------------------------------- +-- conditional branches to local labels +pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch expr yes no + = hsep [ ptext (sLit "if") , parens(pprExpr expr) , + ptext (sLit "goto"), pprBlockId yes <> semi, + ptext (sLit "else goto"), pprBlockId no <> semi ] + +-- --------------------------------------------------------------------- +-- a local table branch +-- +-- we find the fall-through cases +-- +-- N.B. we remove Nothing's from the list of branches, as they are +-- 'undefined'. However, they may be defined one day, so we better +-- document this behaviour. +-- +pprSwitch :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc +pprSwitch dflags e maybe_ids + = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ] + pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ] + in + (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace) + 4 (vcat ( map caseify pairs2 ))) + $$ rbrace + + where + sndEq (_,x) (_,y) = x == y + + -- fall through case + caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix + where + do_fallthrough ix = + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , + ptext (sLit "/* fall through */") ] + + final_branch ix = + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , + ptext (sLit "goto") , (pprBlockId ident) <> semi ] + + caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!" + +-- --------------------------------------------------------------------- +-- Expressions. +-- + +-- C Types: the invariant is that the C expression generated by +-- +-- pprExpr e +-- +-- has a type in C which is also given by +-- +-- machRepCType (cmmExprType e) +-- +-- (similar invariants apply to the rest of the pretty printer). + +pprExpr :: CmmExpr -> SDoc +pprExpr e = case e of + CmmLit lit -> pprLit lit + + + CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty + CmmReg reg -> pprCastReg reg + CmmRegOff reg 0 -> pprCastReg reg + + CmmRegOff reg i + | i < 0 && negate_ok -> pprRegOff (char '-') (-i) + | otherwise -> pprRegOff (char '+') i + where + pprRegOff op i' = pprCastReg reg <> op <> int i' + negate_ok = negate (fromIntegral i :: Integer) < + fromIntegral (maxBound::Int) + -- overflow is undefined; see #7620 + + CmmMachOp mop args -> pprMachOpApp mop args + + CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + + +pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +pprLoad dflags e ty + | width == W64, wordWidth dflags /= W64 + = (if isFloatType ty then ptext (sLit "PK_DBL") + else ptext (sLit "PK_Word64")) + <> parens (mkP_ <> pprExpr1 e) + + | otherwise + = case e of + CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) + -> char '*' <> pprAsPtrReg r + + CmmRegOff r off | isPtrReg r && width == wordWidth dflags + , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty) + -- ToDo: check that the offset is a word multiple? + -- (For tagging to work, I had to avoid unaligned loads. --ARY) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) + + _other -> cLoad e ty + where + width = typeWidth ty + +pprExpr1 :: CmmExpr -> SDoc +pprExpr1 (CmmLit lit) = pprLit1 lit +pprExpr1 e@(CmmReg _reg) = pprExpr e +pprExpr1 other = parens (pprExpr other) + +-- -------------------------------------------------------------------------- +-- MachOp applications + +pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc + +pprMachOpApp op args + | isMulMayOfloOp op + = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args)) + where isMulMayOfloOp (MO_U_MulMayOflo _) = True + isMulMayOfloOp (MO_S_MulMayOflo _) = True + isMulMayOfloOp _ = False + +pprMachOpApp mop args + | Just ty <- machOpNeedsCast mop + = ty <> parens (pprMachOpApp' mop args) + | otherwise + = pprMachOpApp' mop args + +-- Comparisons in C have type 'int', but we want type W_ (this is what +-- resultRepOfMachOp says). The other C operations inherit their type +-- from their operands, so no casting is required. +machOpNeedsCast :: MachOp -> Maybe SDoc +machOpNeedsCast mop + | isComparisonMachOp mop = Just mkW_ + | otherwise = Nothing + +pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' mop args + = case args of + -- dyadic + [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y + + -- unary + [x] -> pprMachOp_for_C mop <> parens (pprArg x) + + _ -> panic "PprC.pprMachOp : machop with wrong number of args" + + where + -- Cast needed for signed integer ops + pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e + | needsFCasts mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e + | otherwise = pprExpr1 e + needsFCasts (MO_F_Eq _) = False + needsFCasts (MO_F_Ne _) = False + needsFCasts (MO_F_Neg _) = True + needsFCasts (MO_F_Quot _) = True + needsFCasts mop = floatComparison mop + +-- -------------------------------------------------------------------------- +-- Literals + +pprLit :: CmmLit -> SDoc +pprLit lit = case lit of + CmmInt i rep -> pprHexVal i rep + + CmmFloat f w -> parens (machRep_F_CType w) <> str + where d = fromRational f :: Double + str | isInfinite d && d < 0 = ptext (sLit "-INFINITY") + | isInfinite d = ptext (sLit "INFINITY") + | isNaN d = ptext (sLit "NAN") + | otherwise = text (show d) + -- these constants come from + -- see #1861 + + CmmVec {} -> panic "PprC printing vector literal" + + CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) + CmmHighStackMark -> panic "PprC printing high stack mark" + CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl + CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i + CmmLabelDiffOff clbl1 _ i + -- WARNING: + -- * the lit must occur in the info table clbl2 + -- * clbl1 must be an SRT, a slow entry point or a large bitmap + -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i + + where + pprCLabelAddr lbl = char '&' <> ppr lbl + +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) +pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit) +pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit) +pprLit1 other = pprLit other + +-- --------------------------------------------------------------------------- +-- Static data + +pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] +pprStatics _ [] = [] +pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) + -- floats are padded to a word, see #1852 + | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' + | wORD_SIZE dflags == 4 + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest + | otherwise + = pprPanic "pprStatics: float" (vcat (map ppr' rest)) + where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> + ppr (cmmLitType dflags l) + ppr' _other = ptext (sLit "bad static!") +pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) + = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest +pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) + | wordWidth dflags == W32 + = if wORDS_BIGENDIAN dflags + then pprStatics dflags (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) + else pprStatics dflags (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) + where r = i .&. 0xffffffff + q = i `shiftR` 32 +pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) + | w /= wordWidth dflags + = panic "pprStatics: cannot emit a non-word-sized static literal" +pprStatics dflags (CmmStaticLit lit : rest) + = pprLit1 lit : pprStatics dflags rest +pprStatics _ (other : _) + = pprPanic "pprWord" (pprStatic other) + +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + + CmmStaticLit lit -> nest 4 (pprLit lit) + CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) + + -- these should be inlined, like the old .hc + CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s')) + + +-- --------------------------------------------------------------------------- +-- Block Ids + +pprBlockId :: BlockId -> SDoc +pprBlockId b = char '_' <> ppr (getUnique b) + +-- -------------------------------------------------------------------------- +-- Print a MachOp in a way suitable for emitting via C. +-- + +pprMachOp_for_C :: MachOp -> SDoc + +pprMachOp_for_C mop = case mop of + + -- Integer operations + MO_Add _ -> char '+' + MO_Sub _ -> char '-' + MO_Eq _ -> ptext (sLit "==") + MO_Ne _ -> ptext (sLit "!=") + MO_Mul _ -> char '*' + + MO_S_Quot _ -> char '/' + MO_S_Rem _ -> char '%' + MO_S_Neg _ -> char '-' + + MO_U_Quot _ -> char '/' + MO_U_Rem _ -> char '%' + + -- & Floating-point operations + MO_F_Add _ -> char '+' + MO_F_Sub _ -> char '-' + MO_F_Neg _ -> char '-' + MO_F_Mul _ -> char '*' + MO_F_Quot _ -> char '/' + + -- Signed comparisons + MO_S_Ge _ -> ptext (sLit ">=") + MO_S_Le _ -> ptext (sLit "<=") + MO_S_Gt _ -> char '>' + MO_S_Lt _ -> char '<' + + -- & Unsigned comparisons + MO_U_Ge _ -> ptext (sLit ">=") + MO_U_Le _ -> ptext (sLit "<=") + MO_U_Gt _ -> char '>' + MO_U_Lt _ -> char '<' + + -- & Floating-point comparisons + MO_F_Eq _ -> ptext (sLit "==") + MO_F_Ne _ -> ptext (sLit "!=") + MO_F_Ge _ -> ptext (sLit ">=") + MO_F_Le _ -> ptext (sLit "<=") + MO_F_Gt _ -> char '>' + MO_F_Lt _ -> char '<' + + -- Bitwise operations. Not all of these may be supported at all + -- sizes, and only integral MachReps are valid. + MO_And _ -> char '&' + MO_Or _ -> char '|' + MO_Xor _ -> char '^' + MO_Not _ -> char '~' + MO_Shl _ -> ptext (sLit "<<") + MO_U_Shr _ -> ptext (sLit ">>") -- unsigned shift right + MO_S_Shr _ -> ptext (sLit ">>") -- signed shift right + +-- Conversions. Some of these will be NOPs, but never those that convert +-- between ints and floats. +-- Floating-point conversions use the signed variant. +-- We won't know to generate (void*) casts here, but maybe from +-- context elsewhere + +-- noop casts + MO_UU_Conv from to | from == to -> empty + MO_UU_Conv _from to -> parens (machRep_U_CType to) + + MO_SS_Conv from to | from == to -> empty + MO_SS_Conv _from to -> parens (machRep_S_CType to) + + MO_FF_Conv from to | from == to -> empty + MO_FF_Conv _from to -> parens (machRep_F_CType to) + + MO_SF_Conv _from to -> parens (machRep_F_CType to) + MO_FS_Conv _from to -> parens (machRep_S_CType to) + + MO_S_MulMayOflo _ -> pprTrace "offending mop:" + (ptext $ sLit "MO_S_MulMayOflo") + (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" + ++ " should have been handled earlier!") + MO_U_MulMayOflo _ -> pprTrace "offending mop:" + (ptext $ sLit "MO_U_MulMayOflo") + (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" + ++ " should have been handled earlier!") + + MO_V_Insert {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_V_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" + ++ " should have been handled earlier!") + MO_V_Extract {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_V_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" + ++ " should have been handled earlier!") + + MO_V_Add {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_V_Add") + (panic $ "PprC.pprMachOp_for_C: MO_V_Add" + ++ " should have been handled earlier!") + MO_V_Sub {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_V_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" + ++ " should have been handled earlier!") + MO_V_Mul {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_V_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" + ++ " should have been handled earlier!") + + MO_VS_Quot {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VS_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" + ++ " should have been handled earlier!") + MO_VS_Rem {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VS_Rem") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem" + ++ " should have been handled earlier!") + MO_VS_Neg {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VS_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" + ++ " should have been handled earlier!") + + MO_VU_Quot {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VU_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" + ++ " should have been handled earlier!") + MO_VU_Rem {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VU_Rem") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" + ++ " should have been handled earlier!") + + MO_VF_Insert {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Insert") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" + ++ " should have been handled earlier!") + MO_VF_Extract {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Extract") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" + ++ " should have been handled earlier!") + + MO_VF_Add {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Add") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" + ++ " should have been handled earlier!") + MO_VF_Sub {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Sub") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" + ++ " should have been handled earlier!") + MO_VF_Neg {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Neg") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" + ++ " should have been handled earlier!") + MO_VF_Mul {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Mul") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" + ++ " should have been handled earlier!") + MO_VF_Quot {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VF_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" + ++ " should have been handled earlier!") + +signedOp :: MachOp -> Bool -- Argument type(s) are signed ints +signedOp (MO_S_Quot _) = True +signedOp (MO_S_Rem _) = True +signedOp (MO_S_Neg _) = True +signedOp (MO_S_Ge _) = True +signedOp (MO_S_Le _) = True +signedOp (MO_S_Gt _) = True +signedOp (MO_S_Lt _) = True +signedOp (MO_S_Shr _) = True +signedOp (MO_SS_Conv _ _) = True +signedOp (MO_SF_Conv _ _) = True +signedOp _ = False + +floatComparison :: MachOp -> Bool -- comparison between float args +floatComparison (MO_F_Eq _) = True +floatComparison (MO_F_Ne _) = True +floatComparison (MO_F_Ge _) = True +floatComparison (MO_F_Le _) = True +floatComparison (MO_F_Gt _) = True +floatComparison (MO_F_Lt _) = True +floatComparison _ = False + +-- --------------------------------------------------------------------- +-- tend to be implemented by foreign calls + +pprCallishMachOp_for_C :: CallishMachOp -> SDoc + +pprCallishMachOp_for_C mop + = case mop of + MO_F64_Pwr -> ptext (sLit "pow") + MO_F64_Sin -> ptext (sLit "sin") + MO_F64_Cos -> ptext (sLit "cos") + MO_F64_Tan -> ptext (sLit "tan") + MO_F64_Sinh -> ptext (sLit "sinh") + MO_F64_Cosh -> ptext (sLit "cosh") + MO_F64_Tanh -> ptext (sLit "tanh") + MO_F64_Asin -> ptext (sLit "asin") + MO_F64_Acos -> ptext (sLit "acos") + MO_F64_Atan -> ptext (sLit "atan") + MO_F64_Log -> ptext (sLit "log") + MO_F64_Exp -> ptext (sLit "exp") + MO_F64_Sqrt -> ptext (sLit "sqrt") + MO_F32_Pwr -> ptext (sLit "powf") + MO_F32_Sin -> ptext (sLit "sinf") + MO_F32_Cos -> ptext (sLit "cosf") + MO_F32_Tan -> ptext (sLit "tanf") + MO_F32_Sinh -> ptext (sLit "sinhf") + MO_F32_Cosh -> ptext (sLit "coshf") + MO_F32_Tanh -> ptext (sLit "tanhf") + MO_F32_Asin -> ptext (sLit "asinf") + MO_F32_Acos -> ptext (sLit "acosf") + MO_F32_Atan -> ptext (sLit "atanf") + MO_F32_Log -> ptext (sLit "logf") + MO_F32_Exp -> ptext (sLit "expf") + MO_F32_Sqrt -> ptext (sLit "sqrtf") + MO_WriteBarrier -> ptext (sLit "write_barrier") + MO_Memcpy -> ptext (sLit "memcpy") + MO_Memset -> ptext (sLit "memset") + MO_Memmove -> ptext (sLit "memmove") + (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) + (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_Clz w) -> ptext (sLit $ clzLabel w) + (MO_Ctz w) -> ptext (sLit $ ctzLabel w) + (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) + (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) + (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) + (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) + (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _ ) -> unsupported + --- we could support prefetch via "__builtin_prefetch" + --- Not adding it for now + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") + +-- --------------------------------------------------------------------- +-- Useful #defines +-- + +mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc + +mkJMP_ i = ptext (sLit "JMP_") <> parens i +mkFN_ i = ptext (sLit "FN_") <> parens i -- externally visible function +mkIF_ i = ptext (sLit "IF_") <> parens i -- locally visible + +-- from includes/Stg.h +-- +mkC_,mkW_,mkP_ :: SDoc + +mkC_ = ptext (sLit "(C_)") -- StgChar +mkW_ = ptext (sLit "(W_)") -- StgWord +mkP_ = ptext (sLit "(P_)") -- StgWord* + +-- --------------------------------------------------------------------- +-- +-- Assignments +-- +-- Generating assignments is what we're all about, here +-- +pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc + +-- dest is a reg, rhs is a reg +pprAssign _ r1 (CmmReg r2) + | isPtrReg r1 && isPtrReg r2 + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] + +-- dest is a reg, rhs is a CmmRegOff +pprAssign dflags r1 (CmmRegOff r2 off) + | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) + = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] + where + off1 = off `shiftR` wordShift dflags + + (op,off') | off >= 0 = (char '+', off1) + | otherwise = (char '-', -off1) + +-- dest is a reg, rhs is anything. +-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting +-- the lvalue elicits a warning from new GCC versions (3.4+). +pprAssign _ r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) + | otherwise = mkAssign (pprExpr r2) + where mkAssign x = if r1 == CmmGlobal BaseReg + then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi + else pprReg r1 <> ptext (sLit " = ") <> x <> semi + +-- --------------------------------------------------------------------- +-- Registers + +pprCastReg :: CmmReg -> SDoc +pprCastReg reg + | isStrangeTypeReg reg = mkW_ <> pprReg reg + | otherwise = pprReg reg + +-- True if (pprReg reg) will give an expression with type StgPtr. We +-- need to take care with pointer arithmetic on registers with type +-- StgPtr. +isFixedPtrReg :: CmmReg -> Bool +isFixedPtrReg (CmmLocal _) = False +isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r + +-- True if (pprAsPtrReg reg) will give an expression with type StgPtr +-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. +-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; +-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. +isPtrReg :: CmmReg -> Bool +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg + +-- True if this global reg has type StgPtr +isFixedPtrGlobalReg :: GlobalReg -> Bool +isFixedPtrGlobalReg Sp = True +isFixedPtrGlobalReg Hp = True +isFixedPtrGlobalReg HpLim = True +isFixedPtrGlobalReg SpLim = True +isFixedPtrGlobalReg _ = False + +-- True if in C this register doesn't have the type given by +-- (machRepCType (cmmRegType reg)), so it has to be cast. +isStrangeTypeReg :: CmmReg -> Bool +isStrangeTypeReg (CmmLocal _) = False +isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g + +isStrangeTypeGlobal :: GlobalReg -> Bool +isStrangeTypeGlobal CCCS = True +isStrangeTypeGlobal CurrentTSO = True +isStrangeTypeGlobal CurrentNursery = True +isStrangeTypeGlobal BaseReg = True +isStrangeTypeGlobal r = isFixedPtrGlobalReg r + +strangeRegType :: CmmReg -> Maybe SDoc +strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *")) +strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *")) +strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *")) +strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *")) +strangeRegType _ = Nothing + +-- pprReg just prints the register name. +-- +pprReg :: CmmReg -> SDoc +pprReg r = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +pprAsPtrReg :: CmmReg -> SDoc +pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) + = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p") +pprAsPtrReg other_reg = pprReg other_reg + +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr = case gr of + VanillaReg n _ -> char 'R' <> int n <> ptext (sLit ".w") + -- pprGlobalReg prints a VanillaReg as a .w regardless + -- Example: R1.w = R1.w & (-0x8UL); + -- JMP_(*R1.p); + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> ptext (sLit "Sp") + SpLim -> ptext (sLit "SpLim") + Hp -> ptext (sLit "Hp") + HpLim -> ptext (sLit "HpLim") + CCCS -> ptext (sLit "CCCS") + CurrentTSO -> ptext (sLit "CurrentTSO") + CurrentNursery -> ptext (sLit "CurrentNursery") + HpAlloc -> ptext (sLit "HpAlloc") + BaseReg -> ptext (sLit "BaseReg") + EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") + GCEnter1 -> ptext (sLit "stg_gc_enter_1") + GCFun -> ptext (sLit "stg_gc_fun") + other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other + +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq + +-- ----------------------------------------------------------------------------- +-- Foreign Calls + +pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCall ppr_fn cconv results args + | not (is_cishCC cconv) + = panic $ "pprCall: unknown calling convention" + + | otherwise + = + ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi + where + ppr_assign [] rhs = rhs + ppr_assign [(one,hint)] rhs + = pprLocalReg one <> ptext (sLit " = ") + <> pprUnHint hint (localRegType one) <> rhs + ppr_assign _other _rhs = panic "pprCall: multiple results" + + pprArg (expr, AddrHint) + = cCast (ptext (sLit "void *")) expr + -- see comment by machRepHintCType below + pprArg (expr, SignedHint) + = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr + pprArg (expr, _other) + = pprExpr expr + + pprUnHint AddrHint rep = parens (machRepCType rep) + pprUnHint SignedHint rep = parens (machRepCType rep) + pprUnHint _ _ = empty + +-- Currently we only have these two calling conventions, but this might +-- change in the future... +is_cishCC :: CCallConv -> Bool +is_cishCC CCallConv = True +is_cishCC CApiConv = True +is_cishCC StdCallConv = True +is_cishCC PrimCallConv = False +is_cishCC JavaScriptCallConv = False + +-- --------------------------------------------------------------------- +-- Find and print local and external declarations for a list of +-- Cmm statements. +-- +pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls stmts + = (vcat (map pprTempDecl (uniqSetToList temps)), + vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) + where (temps, lbls) = runTE (mapM_ te_BB stmts) + +pprDataExterns :: [CmmStatic] -> SDoc +pprDataExterns statics + = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)) + where (_, lbls) = runTE (mapM_ te_Static statics) + +pprTempDecl :: LocalReg -> SDoc +pprTempDecl l@(LocalReg _ rep) + = hcat [ machRepCType rep, space, pprLocalReg l, semi ] + +pprExternDecl :: Bool -> CLabel -> SDoc +pprExternDecl _in_srt lbl + -- do not print anything for "known external" things + | not (needsCDecl lbl) = empty + | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz + | otherwise = + hcat [ visibility, label_type lbl, + lparen, ppr lbl, text ");" ] + where + label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_") + | otherwise = ptext (sLit "I_") + + visibility + | externallyVisibleCLabel lbl = char 'E' + | otherwise = char 'I' + + -- If the label we want to refer to is a stdcall function (on Windows) then + -- we must generate an appropriate prototype for it, so that the C compiler will + -- add the @n suffix to the label (#2276) + stdcall_decl sz = sdocWithDynFlags $ \dflags -> + ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl + <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) + <> semi + +type TEState = (UniqSet LocalReg, Map CLabel ()) +newtype TE a = TE { unTE :: TEState -> (a, TEState) } + +instance Functor TE where + fmap = liftM + +instance Applicative TE where + pure = return + (<*>) = ap + +instance Monad TE where + TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' + return a = TE $ \s -> (a, s) + +te_lbl :: CLabel -> TE () +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) + +te_temp :: LocalReg -> TE () +te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) + +runTE :: TE () -> TEState +runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) + +te_Static :: CmmStatic -> TE () +te_Static (CmmStaticLit lit) = te_Lit lit +te_Static _ = return () + +te_BB :: CmmBlock -> TE () +te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last + where (_, mid, last) = blockSplit block + +te_Lit :: CmmLit -> TE () +te_Lit (CmmLabel l) = te_lbl l +te_Lit (CmmLabelOff l _) = te_lbl l +te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 +te_Lit _ = return () + +te_Stmt :: CmmNode e x -> TE () +te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e +te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r +te_Stmt (CmmUnsafeForeignCall target rs es) + = do te_Target target + mapM_ te_temp rs + mapM_ te_Expr es +te_Stmt (CmmCondBranch e _ _) = te_Expr e +te_Stmt (CmmSwitch e _) = te_Expr e +te_Stmt (CmmCall { cml_target = e }) = te_Expr e +te_Stmt _ = return () + +te_Target :: ForeignTarget -> TE () +te_Target (ForeignTarget e _) = te_Expr e +te_Target (PrimTarget{}) = return () + +te_Expr :: CmmExpr -> TE () +te_Expr (CmmLit lit) = te_Lit lit +te_Expr (CmmLoad e _) = te_Expr e +te_Expr (CmmReg r) = te_Reg r +te_Expr (CmmMachOp _ es) = mapM_ te_Expr es +te_Expr (CmmRegOff r _) = te_Reg r +te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" + +te_Reg :: CmmReg -> TE () +te_Reg (CmmLocal l) = te_temp l +te_Reg _ = return () + + +-- --------------------------------------------------------------------- +-- C types for MachReps + +cCast :: SDoc -> CmmExpr -> SDoc +cCast ty expr = parens ty <> pprExpr1 expr + +cLoad :: CmmExpr -> CmmType -> SDoc +cLoad expr rep + = sdocWithPlatform $ \platform -> + if bewareLoadStoreAlignment (platformArch platform) + then let decl = machRepCType rep <+> ptext (sLit "x") <> semi + struct = ptext (sLit "struct") <+> braces (decl) + packed_attr = ptext (sLit "__attribute__((packed))") + cast = parens (struct <+> packed_attr <> char '*') + in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x") + else char '*' <> parens (cCast (machRepPtrCType rep) expr) + where -- On these platforms, unaligned loads are known to cause problems + bewareLoadStoreAlignment ArchAlpha = True + bewareLoadStoreAlignment ArchMipseb = True + bewareLoadStoreAlignment ArchMipsel = True + bewareLoadStoreAlignment (ArchARM {}) = True + bewareLoadStoreAlignment ArchARM64 = True + -- Pessimistically assume that they will also cause problems + -- on unknown arches + bewareLoadStoreAlignment ArchUnknown = True + bewareLoadStoreAlignment _ = False + +isCmmWordType :: DynFlags -> CmmType -> Bool +-- True of GcPtrReg/NonGcReg of native word size +isCmmWordType dflags ty = not (isFloatType ty) + && typeWidth ty == wordWidth dflags + +-- This is for finding the types of foreign call arguments. For a pointer +-- argument, we always cast the argument to (void *), to avoid warnings from +-- the C compiler. +machRepHintCType :: CmmType -> ForeignHint -> SDoc +machRepHintCType _ AddrHint = ptext (sLit "void *") +machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) +machRepHintCType rep _other = machRepCType rep + +machRepPtrCType :: CmmType -> SDoc +machRepPtrCType r + = sdocWithDynFlags $ \dflags -> + if isCmmWordType dflags r then ptext (sLit "P_") + else machRepCType r <> char '*' + +machRepCType :: CmmType -> SDoc +machRepCType ty | isFloatType ty = machRep_F_CType w + | otherwise = machRep_U_CType w + where + w = typeWidth ty + +machRep_F_CType :: Width -> SDoc +machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct? +machRep_F_CType W64 = ptext (sLit "StgDouble") +machRep_F_CType _ = panic "machRep_F_CType" + +machRep_U_CType :: Width -> SDoc +machRep_U_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "W_") + W8 -> ptext (sLit "StgWord8") + W16 -> ptext (sLit "StgWord16") + W32 -> ptext (sLit "StgWord32") + W64 -> ptext (sLit "StgWord64") + _ -> panic "machRep_U_CType" + +machRep_S_CType :: Width -> SDoc +machRep_S_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "I_") + W8 -> ptext (sLit "StgInt8") + W16 -> ptext (sLit "StgInt16") + W32 -> ptext (sLit "StgInt32") + W64 -> ptext (sLit "StgInt64") + _ -> panic "machRep_S_CType" + + +-- --------------------------------------------------------------------- +-- print strings as valid C strings + +pprStringInCStyle :: [Word8] -> SDoc +pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) + +-- --------------------------------------------------------------------------- +-- Initialising static objects with floating-point numbers. We can't +-- just emit the floating point number, because C will cast it to an int +-- by rounding it. We want the actual bit-representation of the float. + +-- This is a hack to turn the floating point numbers into ints that we +-- can safely initialise to static locations. + +big_doubles :: DynFlags -> Bool +big_doubles dflags + | widthInBytes W64 == 2 * wORD_SIZE dflags = True + | widthInBytes W64 == wORD_SIZE dflags = False + | otherwise = panic "big_doubles" + +castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) +castFloatToIntArray = U.castSTUArray + +castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) +castDoubleToIntArray = U.castSTUArray + +-- floats are always 1 word +floatToWord :: DynFlags -> Rational -> CmmLit +floatToWord dflags r + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 (fromRational r) + arr' <- castFloatToIntArray arr + i <- readArray arr' 0 + return (CmmInt (toInteger i) (wordWidth dflags)) + ) + +doubleToWords :: DynFlags -> Rational -> [CmmLit] +doubleToWords dflags r + | big_doubles dflags -- doubles are 2 words + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i1 <- readArray arr' 0 + i2 <- readArray arr' 1 + return [ CmmInt (toInteger i1) (wordWidth dflags) + , CmmInt (toInteger i2) (wordWidth dflags) + ] + ) + | otherwise -- doubles are 1 word + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i <- readArray arr' 0 + return [ CmmInt (toInteger i) (wordWidth dflags) ] + ) + +-- --------------------------------------------------------------------------- +-- Utils + +wordShift :: DynFlags -> Int +wordShift dflags = widthInLog (wordWidth dflags) + +commafy :: [SDoc] -> SDoc +commafy xs = hsep $ punctuate comma xs + +-- Print in C hex format: 0x13fa +pprHexVal :: Integer -> Width -> SDoc +pprHexVal w rep + | w < 0 = parens (char '-' <> + ptext (sLit "0x") <> intToDoc (-w) <> repsuffix rep) + | otherwise = ptext (sLit "0x") <> intToDoc w <> repsuffix rep + where + -- type suffix for literals: + -- Integer literals are unsigned in Cmm/C. We explicitly cast to + -- signed values for doing signed operations, but at all other + -- times values are unsigned. This also helps eliminate occasional + -- warnings about integer overflow from gcc. + + repsuffix W64 = sdocWithDynFlags $ \dflags -> + if cINT_SIZE dflags == 8 then char 'U' + else if cLONG_SIZE dflags == 8 then ptext (sLit "UL") + else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL") + else panic "pprHexVal: Can't find a 64-bit type" + repsuffix _ = char 'U' + + intToDoc :: Integer -> SDoc + intToDoc i = case truncInt i of + 0 -> char '0' + v -> go v + + -- We need to truncate value as Cmm backend does not drop + -- redundant bits to ease handling of negative values. + -- Thus the following Cmm code on 64-bit arch, like amd64: + -- CInt v; + -- v = {something}; + -- if (v == %lobits32(-1)) { ... + -- leads to the following C code: + -- StgWord64 v = (StgWord32)({something}); + -- if (v == 0xFFFFffffFFFFffffU) { ... + -- Such code is incorrect as it promotes both operands to StgWord64 + -- and the whole condition is always false. + truncInt :: Integer -> Integer + truncInt i = + case rep of + W8 -> i `rem` (2^(8 :: Int)) + W16 -> i `rem` (2^(16 :: Int)) + W32 -> i `rem` (2^(32 :: Int)) + W64 -> i `rem` (2^(64 :: Int)) + _ -> panic ("pprHexVal/truncInt: C backend can't encode " + ++ show rep ++ " literals") + + go 0 = empty + go w' = go q <> dig + where + (q,r) = w' `quotRem` 16 + dig | r < 10 = char (chr (fromInteger r + ord '0')) + | otherwise = char (chr (fromInteger r - 10 + ord 'a')) diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs new file mode 100644 index 00000000..9d9f3081 --- /dev/null +++ b/compiler/cmm/PprCmm.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +---------------------------------------------------------------------------- +-- +-- Pretty-printing of Cmm as (a superset of) C-- +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +-- +-- This is where we walk over CmmNode emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs + +module PprCmm + ( module PprCmmDecl + , module PprCmmExpr + ) +where + +import BlockId () +import CLabel +import Cmm +import CmmUtils +import DynFlags +import FastString +import Outputable +import PprCmmDecl +import PprCmmExpr +import Util +import PprCore () + +import BasicTypes +import Compiler.Hoopl +import Data.List +import Prelude hiding (succ) + +------------------------------------------------- +-- Outputable instances + +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +instance Outputable CmmTopInfo where + ppr = pprTopInfo + + +instance Outputable (CmmNode e x) where + ppr = pprNode + +instance Outputable Convention where + ppr = pprConvention + +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +instance Outputable ForeignTarget where + ppr = pprForeignTarget + +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +instance Outputable (Block CmmNode C C) where + ppr = pprBlock +instance Outputable (Block CmmNode C O) where + ppr = pprBlock +instance Outputable (Block CmmNode O C) where + ppr = pprBlock +instance Outputable (Block CmmNode O O) where + ppr = pprBlock + +instance Outputable (Graph CmmNode e x) where + ppr = pprGraph + +instance Outputable CmmGraph where + ppr = pprCmmGraph + +---------------------------------------------------------- +-- Outputting types Cmm contains + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = + ptext (sLit "arg_space: ") <> ppr arg_space <+> + ptext (sLit "updfr_space: ") <> ppr updfr_space + +pprTopInfo :: CmmTopInfo -> SDoc +pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, + ptext (sLit "stack_info: ") <> ppr stack_info] + +---------------------------------------------------------- +-- Outputting blocks and graphs + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock block + = foldBlockNodesB3 ( ($$) . ppr + , ($$) . (nest 4) . ppr + , ($$) . (nest 4) . ppr + ) + block + empty + +pprGraph :: Graph CmmNode e x -> SDoc +pprGraph GNil = empty +pprGraph (GUnit block) = ppr block +pprGraph (GMany entry body exit) + = text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: Outputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = ppr block + +pprCmmGraph :: CmmGraph -> SDoc +pprCmmGraph g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map ppr blocks) + $$ text "}" + where blocks = postorderDfs g + -- postorderDfs has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +--------------------------------------------- +-- Outputting CmmNode and types which it contains + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = ptext (sLit "never returns") + +pprForeignTarget :: ForeignTarget -> SDoc +pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = ppr t + ppr_target fn' = parens (ppr fn') + +pprForeignTarget (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = ppr + (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) + +pprNode :: CmmNode e x -> SDoc +pprNode node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = sdocWithDynFlags $ \dflags -> case node of + -- label: + CmmEntry id tscope -> ppr id <> colon <+> + (sdocWithDynFlags $ \dflags -> + ppWhen (gopt Opt_PprShowTicks dflags) (text "//" <+> ppr tscope)) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> if gopt Opt_PprShowTicks dflags + then ptext (sLit "//tick") <+> ppr t + else empty + + -- unwind reg = expr; + CmmUnwind r e -> ptext (sLit "unwind ") <> ppr r <+> char '=' <+> ppr e + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + where + rep = sdocWithDynFlags $ \dflags -> + ppr ( cmmExprType dflags expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + ptext $ sLit "call", + ppr target <> parens (commafy $ map ppr args) <> semi] + + -- goto label; + CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f -> + hsep [ ptext (sLit "if") + , parens(ppr expr) + , ptext (sLit "goto") + , ppr t <> semi + , ptext (sLit "else goto") + , ppr f <> semi + ] + + CmmSwitch expr maybe_ids -> + hang (hcat [ ptext (sLit "switch [0 .. ") + , int (length maybe_ids - 1) + , ptext (sLit "] ") + , if isTrivialCmmExpr expr + then ppr expr + else parens (ppr expr) + , ptext (sLit " {") + ]) + 4 (vcat ( map caseify pairs )) $$ rbrace + where pairs = groupBy snds (zip [0 .. ] maybe_ids ) + snds a b = (snd a) == (snd b) + caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ") + <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */") + caseify as = let (is,ids) = unzip as + in hsep [ ptext (sLit "case") + , hcat (punctuate comma (map int is)) + , ptext (sLit ": goto") + , ppr (head [ id | Just id <- ids]) <> semi ] + + CmmCall tgt k regs out res updfr_off -> + hcat [ ptext (sLit "call"), space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + ptext (sLit "args: ") <> ppr out <> comma <+> + ptext (sLit "res: ") <> ppr res <> comma <+> + ptext (sLit "upd: ") <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = ppr f + pprFun f = parens (ppr f) + + returns + | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ + [ ptext (sLit "foreign call"), space + , ppr t, ptext (sLit "(...)"), space + , ptext (sLit "returns to") <+> ppr s + <+> ptext (sLit "args:") <+> parens (ppr as) + <+> ptext (sLit "ress:") <+> parens (ppr rs) + , ptext (sLit "ret_args:") <+> ppr a + , ptext (sLit "ret_off:") <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs new file mode 100644 index 00000000..87cda6a9 --- /dev/null +++ b/compiler/cmm/PprCmmDecl.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} + +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PprCmmDecl + ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic + ) +where + +import PprCmmExpr +import Cmm + +import DynFlags +import Outputable +import FastString + +import Data.List +import System.IO + +-- Temp Jan08 +import SMRep +#include "../includes/rts/storage/FunTypes.h" + + +pprCmms :: (Outputable info, Outputable g) + => [GenCmmGroup CmmStatics info g] -> SDoc +pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) + where + separator = space $$ ptext (sLit "-------------------") $$ space + +writeCmms :: (Outputable info, Outputable g) + => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () +writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) + +----------------------------------------------------------------------------- + +instance (Outputable d, Outputable info, Outputable i) + => Outputable (GenCmmDecl d info i) where + ppr t = pprTop t + +instance Outputable CmmStatics where + ppr = pprStatics + +instance Outputable CmmStatic where + ppr = pprStatic + +instance Outputable CmmInfoTable where + ppr = pprInfoTable + + +----------------------------------------------------------------------------- + +pprCmmGroup :: (Outputable d, Outputable info, Outputable g) + => GenCmmGroup d info g -> SDoc +pprCmmGroup tops + = vcat $ intersperse blankLine $ map pprTop tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- +pprTop :: (Outputable d, Outputable info, Outputable i) + => GenCmmDecl d info i -> SDoc + +pprTop (CmmProc info lbl live graph) + + = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live + , nest 8 $ lbrace <+> ppr info $$ rbrace + , nest 4 $ ppr graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- +pprTop (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Info tables. + +pprInfoTable :: CmmInfoTable -> SDoc +pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = _srt }) + = vcat [ ptext (sLit "label:") <+> ppr lbl + , ptext (sLit "rep:") <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct + , ptext (sLit "desc: ") <> pprWord8String cd ] ] + +instance Outputable C_SRT where + ppr NoC_SRT = ptext (sLit "_no_srt_") + ppr (C_SRT label off bitmap) + = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap) + +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) + +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Section -> SDoc +pprSection s = case s of + Text -> section <+> doubleQuotes (text "text") + Data -> section <+> doubleQuotes (text "data") + ReadOnlyData -> section <+> doubleQuotes (text "readonly") + ReadOnlyData16 -> section <+> doubleQuotes (text "readonly16") + RelocatableReadOnlyData + -> section <+> doubleQuotes (text "relreadonly") + UninitialisedData -> section <+> doubleQuotes (text "uninitialised") + OtherSection s' -> section <+> doubleQuotes (text s') + where + section = ptext (sLit "section") diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs new file mode 100644 index 00000000..0bb79ac1 --- /dev/null +++ b/compiler/cmm/PprCmmExpr.hs @@ -0,0 +1,278 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PprCmmExpr + ( pprExpr, pprLit + ) +where + +import CmmExpr + +import Outputable +import FastString + +import Data.Maybe +import Numeric ( fromRat ) + +----------------------------------------------------------------------------- + +instance Outputable CmmExpr where + ppr e = pprExpr e + +instance Outputable CmmReg where + ppr e = pprReg e + +instance Outputable CmmLit where + ppr l = pprLit l + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +instance Outputable Area where + ppr e = pprArea e + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +-- -------------------------------------------------------------------------- +-- Expressions +-- + +pprExpr :: CmmExpr -> SDoc +pprExpr e + = sdocWithDynFlags $ \dflags -> + case e of + CmmRegOff reg i -> + pprExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType dflags reg) + CmmLit lit -> pprLit lit + _other -> pprExpr1 e + +-- Here's the precedence table from CmmParse.y: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc +pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op + = pprExpr7 x <+> doc <+> pprExpr7 y +pprExpr1 e = pprExpr7 e + +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + +infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) +infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) +infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) +infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>")) +infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">=")) +infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<=")) +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op + = pprExpr7 x <+> doc <+> pprExpr8 y +pprExpr7 e = pprExpr8 e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op + = pprExpr8 x <+> doc <+> pprExpr9 y +pprExpr8 e = pprExpr9 e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: CmmExpr -> SDoc +pprExpr9 e = + case e of + CmmLit lit -> pprLit1 lit + CmmLoad expr rep -> ppr rep <> brackets (ppr expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp mop args + +genMachOp :: MachOp -> [CmmExpr] -> SDoc +genMachOp mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y + + -- unary + [x] -> doc <> pprExpr9 x + + _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map pprExpr args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) + + | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Literals. +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- +pprLit :: CmmLit -> SDoc +pprLit lit = sdocWithDynFlags $ \dflags -> + case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth dflags) $ + space <> dcolon <+> ppr rep ] + + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>' + CmmLabel clbl -> ppr clbl + CmmLabelOff clbl i -> ppr clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-' + <> ppr clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" + +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) +pprLit1 lit = pprLit lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +-- -------------------------------------------------------------------------- +-- Registers, whether local (temps) or global +-- +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + = char '_' <> ppr uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +-- Stack areas +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + +-- needs to be kept in syn with CmmExpr.hs.GlobalReg +-- +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr + = case gr of + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> ptext (sLit "XMM") <> int n + YmmReg n -> ptext (sLit "YMM") <> int n + ZmmReg n -> ptext (sLit "ZMM") <> int n + Sp -> ptext (sLit "Sp") + SpLim -> ptext (sLit "SpLim") + Hp -> ptext (sLit "Hp") + HpLim -> ptext (sLit "HpLim") + CCCS -> ptext (sLit "CCCS") + CurrentTSO -> ptext (sLit "CurrentTSO") + CurrentNursery -> ptext (sLit "CurrentNursery") + HpAlloc -> ptext (sLit "HpAlloc") + EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") + GCEnter1 -> ptext (sLit "stg_gc_enter_1") + GCFun -> ptext (sLit "stg_gc_fun") + BaseReg -> ptext (sLit "BaseReg") + PicBaseReg -> ptext (sLit "PicBaseReg") + +----------------------------------------------------------------------------- + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs new file mode 100644 index 00000000..ca272fc9 --- /dev/null +++ b/compiler/cmm/SMRep.hs @@ -0,0 +1,546 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- Storage manager representation of closures + +{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} + +module SMRep ( + -- * Words and bytes + WordOff, ByteOff, + wordsToBytes, bytesToWordsRoundUp, + roundUpToWords, + + StgWord, fromStgWord, toStgWord, + StgHalfWord, fromStgHalfWord, toStgHalfWord, + hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS, + + -- * Closure repesentation + SMRep(..), -- CmmInfo sees the rep; no one else does + IsStatic, + ClosureTypeInfo(..), ArgDescr(..), Liveness, + ConstrDescription, + + -- ** Construction + mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, + smallArrPtrsRep, arrWordsRep, + + -- ** Predicates + isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, + isStackRep, + + -- ** Size-related things + heapClosureSizeW, + fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, + arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, + smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, + fixedHdrSize, + + -- ** RTS closure types + rtsClosureType, rET_SMALL, rET_BIG, + aRG_GEN, aRG_GEN_BIG, + + -- ** Arrays + card, cardRoundUp, cardTableSizeB, cardTableSizeW, + + -- * Operations over [Word8] strings that don't belong here + pprWord8String, stringToWord8s + ) where + +#include "../HsVersions.h" +#include "../includes/MachDeps.h" + +import DynFlags +import Outputable +import Platform +import FastString + +import Data.Char( ord ) +import Data.Word +import Data.Bits + +{- +************************************************************************ +* * + Words and bytes +* * +************************************************************************ +-} + +-- | Word offset, or word count +type WordOff = Int + +-- | Byte offset, or byte count +type ByteOff = Int + +-- | Round up the given byte count to the next byte count that's a +-- multiple of the machine's word size. +roundUpToWords :: DynFlags -> ByteOff -> ByteOff +roundUpToWords dflags n = + (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1)) + +-- | Convert the given number of words to a number of bytes. +-- +-- This function morally has type @WordOff -> ByteOff@, but uses @Num +-- a@ to allow for overloading. +wordsToBytes :: Num a => DynFlags -> a -> a +wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n +{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} + +-- | First round the given byte count up to a multiple of the +-- machine's word size and then convert the result to words. +bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff +bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size + where word_size = wORD_SIZE dflags +-- StgWord is a type representing an StgWord on the target platform. +-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform +newtype StgWord = StgWord Word64 + deriving (Eq, Bits) + +fromStgWord :: StgWord -> Integer +fromStgWord (StgWord i) = toInteger i + +toStgWord :: DynFlags -> Integer -> StgWord +toStgWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgWord (-1) + -- do the right thing + 4 -> StgWord (fromIntegral (fromInteger i :: Word32)) + 8 -> StgWord (fromInteger i :: Word64) + w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w) + +instance Outputable StgWord where + ppr (StgWord i) = integer (toInteger i) + +-- + +-- A Word32 is large enough to hold half a Word for either a 32bit or +-- 64bit platform +newtype StgHalfWord = StgHalfWord Word32 + deriving Eq + +fromStgHalfWord :: StgHalfWord -> Integer +fromStgHalfWord (StgHalfWord w) = toInteger w + +toStgHalfWord :: DynFlags -> Integer -> StgHalfWord +toStgHalfWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgHalfWord (-1) + -- do the right thing + 4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) + 8 -> StgHalfWord (fromInteger i :: Word32) + w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w) + +instance Outputable StgHalfWord where + ppr (StgHalfWord w) = integer (toInteger w) + +hALF_WORD_SIZE :: DynFlags -> ByteOff +hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1 +hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int +hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2 + +{- +************************************************************************ +* * +\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} +* * +************************************************************************ +-} + +-- | A description of the layout of a closure. Corresponds directly +-- to the closure types in includes/rts/storage/ClosureTypes.h. +data SMRep + = HeapRep -- GC routines consult sizes in info tbl + IsStatic + !WordOff -- # ptr words + !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) + ClosureTypeInfo -- type-specific info + + | ArrayPtrsRep + !WordOff -- # ptr words + !WordOff -- # card table words + + | SmallArrayPtrsRep + !WordOff -- # ptr words + + | ArrayWordsRep + !WordOff -- # bytes expressed in words, rounded up + + | StackRep -- Stack frame (RET_SMALL or RET_BIG) + Liveness + + | RTSRep -- The RTS needs to declare info tables with specific + Int -- type tags, so this form lets us override the default + SMRep -- tag for an SMRep. + +-- | True <=> This is a static closure. Affects how we garbage-collect it. +-- Static closure have an extra static link field at the end. +type IsStatic = Bool + +-- From an SMRep you can get to the closure type defined in +-- includes/rts/storage/ClosureTypes.h. Described by the function +-- rtsClosureType below. + +data ClosureTypeInfo + = Constr ConstrTag ConstrDescription + | Fun FunArity ArgDescr + | Thunk + | ThunkSelector SelectorOffset + | BlackHole + | IndStatic + +type ConstrTag = Int +type ConstrDescription = [Word8] -- result of dataConIdentity +type FunArity = Int +type SelectorOffset = Int + +------------------------- +-- We represent liveness bitmaps as a Bitmap (whose internal +-- representation really is a bitmap). These are pinned onto case return +-- vectors to indicate the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single +-- word (StgWord) are stored as a single word, while larger bitmaps are +-- stored as a pointer to an array of words. + +type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead + -- False <=> ptr + +------------------------- +-- An ArgDescr describes the argument pattern of a function + +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... + + | ArgGen -- General case + Liveness -- Details about the arguments + + +----------------------------------------------------------------------------- +-- Construction + +mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo + -> SMRep +mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info + = HeapRep is_static + ptr_wds + (nonptr_wds + slop_wds) + cl_type_info + where + slop_wds + | is_static = 0 + | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) + + hdr_size = closureTypeHdrSize dflags cl_type_info + payload_size = ptr_wds + nonptr_wds + +mkRTSRep :: Int -> SMRep -> SMRep +mkRTSRep = RTSRep + +mkStackRep :: [Bool] -> SMRep +mkStackRep liveness = StackRep liveness + +blackHoleRep :: SMRep +blackHoleRep = HeapRep False 0 0 BlackHole + +indStaticRep :: SMRep +indStaticRep = HeapRep True 1 0 IndStatic + +arrPtrsRep :: DynFlags -> WordOff -> SMRep +arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) + +smallArrPtrsRep :: WordOff -> SMRep +smallArrPtrsRep elems = SmallArrayPtrsRep elems + +arrWordsRep :: DynFlags -> ByteOff -> SMRep +arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) + +----------------------------------------------------------------------------- +-- Predicates + +isStaticRep :: SMRep -> IsStatic +isStaticRep (HeapRep is_static _ _ _) = is_static +isStaticRep (RTSRep _ rep) = isStaticRep rep +isStaticRep _ = False + +isStackRep :: SMRep -> Bool +isStackRep StackRep{} = True +isStackRep (RTSRep _ rep) = isStackRep rep +isStackRep _ = False + +isConRep :: SMRep -> Bool +isConRep (HeapRep _ _ _ Constr{}) = True +isConRep _ = False + +isThunkRep :: SMRep -> Bool +isThunkRep (HeapRep _ _ _ Thunk{}) = True +isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True +isThunkRep (HeapRep _ _ _ BlackHole{}) = True +isThunkRep (HeapRep _ _ _ IndStatic{}) = True +isThunkRep _ = False + +isFunRep :: SMRep -> Bool +isFunRep (HeapRep _ _ _ Fun{}) = True +isFunRep _ = False + +isStaticNoCafCon :: SMRep -> Bool +-- This should line up exactly with CONSTR_NOCAF_STATIC above +-- See Note [Static NoCaf constructors] +isStaticNoCafCon (HeapRep True 0 _ Constr{}) = True +isStaticNoCafCon _ = False + + +----------------------------------------------------------------------------- +-- Size-related things + +fixedHdrSize :: DynFlags -> ByteOff +fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) + +-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) +fixedHdrSizeW :: DynFlags -> WordOff +fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags + +-- | Size of the profiling part of a closure header +-- (StgProfHeader in includes/rts/storage/Closures.h) +profHdrSize :: DynFlags -> WordOff +profHdrSize dflags + | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags + | otherwise = 0 + +-- | The garbage collector requires that every closure is at least as +-- big as this. +minClosureSize :: DynFlags -> WordOff +minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags + +arrWordsHdrSize :: DynFlags -> ByteOff +arrWordsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgArrWords_NoHdr dflags + +arrWordsHdrSizeW :: DynFlags -> WordOff +arrWordsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgArrWords_NoHdr dflags `quot` wORD_SIZE dflags) + +arrPtrsHdrSize :: DynFlags -> ByteOff +arrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags + +arrPtrsHdrSizeW :: DynFlags -> WordOff +arrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + +smallArrPtrsHdrSize :: DynFlags -> ByteOff +smallArrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags + +smallArrPtrsHdrSizeW :: DynFlags -> WordOff +smallArrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + +-- Thunks have an extra header word on SMP, so the update doesn't +-- splat the payload. +thunkHdrSize :: DynFlags -> WordOff +thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags + +hdrSize :: DynFlags -> SMRep -> ByteOff +hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) + +hdrSizeW :: DynFlags -> SMRep -> WordOff +hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty +hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags +hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags +hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags +hdrSizeW _ _ = panic "SMRep.hdrSizeW" + +nonHdrSize :: DynFlags -> SMRep -> ByteOff +nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) + +nonHdrSizeW :: SMRep -> WordOff +nonHdrSizeW (HeapRep _ p np _) = p + np +nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct +nonHdrSizeW (SmallArrayPtrsRep elems) = elems +nonHdrSizeW (ArrayWordsRep words) = words +nonHdrSizeW (StackRep bs) = length bs +nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep + +-- | The total size of the closure, in words. +heapClosureSizeW :: DynFlags -> SMRep -> WordOff +heapClosureSizeW dflags (HeapRep _ p np ty) + = closureTypeHdrSize dflags ty + p + np +heapClosureSizeW dflags (ArrayPtrsRep elems ct) + = arrPtrsHdrSizeW dflags + elems + ct +heapClosureSizeW dflags (SmallArrayPtrsRep elems) + = smallArrPtrsHdrSizeW dflags + elems +heapClosureSizeW dflags (ArrayWordsRep words) + = arrWordsHdrSizeW dflags + words +heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" + +closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff +closureTypeHdrSize dflags ty = case ty of + Thunk{} -> thunkHdrSize dflags + ThunkSelector{} -> thunkHdrSize dflags + BlackHole{} -> thunkHdrSize dflags + IndStatic{} -> thunkHdrSize dflags + _ -> fixedHdrSizeW dflags + -- All thunks use thunkHdrSize, even if they are non-updatable. + -- this is because we don't have separate closure types for + -- updatable vs. non-updatable thunks, so the GC can't tell the + -- difference. If we ever have significant numbers of non- + -- updatable thunks, it might be worth fixing this. + +-- --------------------------------------------------------------------------- +-- Arrays + +-- | The byte offset into the card table of the card for a given element +card :: DynFlags -> Int -> Int +card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags + +-- | Convert a number of elements to a number of cards, rounding up +cardRoundUp :: DynFlags -> Int -> Int +cardRoundUp dflags i = + card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) + +-- | The size of a card table, in bytes +cardTableSizeB :: DynFlags -> Int -> ByteOff +cardTableSizeB dflags elems = cardRoundUp dflags elems + +-- | The size of a card table, in words +cardTableSizeW :: DynFlags -> Int -> WordOff +cardTableSizeW dflags elems = + bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) + +----------------------------------------------------------------------------- +-- deriving the RTS closure type from an SMRep + +#include "../includes/rts/storage/ClosureTypes.h" +#include "../includes/rts/storage/FunTypes.h" +-- Defines CONSTR, CONSTR_1_0 etc + +-- | Derives the RTS closure type from an 'SMRep' +rtsClosureType :: SMRep -> Int +rtsClosureType rep + = case rep of + RTSRep ty _ -> ty + + HeapRep False 1 0 Constr{} -> CONSTR_1_0 + HeapRep False 0 1 Constr{} -> CONSTR_0_1 + HeapRep False 2 0 Constr{} -> CONSTR_2_0 + HeapRep False 1 1 Constr{} -> CONSTR_1_1 + HeapRep False 0 2 Constr{} -> CONSTR_0_2 + HeapRep False _ _ Constr{} -> CONSTR + + HeapRep False 1 0 Fun{} -> FUN_1_0 + HeapRep False 0 1 Fun{} -> FUN_0_1 + HeapRep False 2 0 Fun{} -> FUN_2_0 + HeapRep False 1 1 Fun{} -> FUN_1_1 + HeapRep False 0 2 Fun{} -> FUN_0_2 + HeapRep False _ _ Fun{} -> FUN + + HeapRep False 1 0 Thunk{} -> THUNK_1_0 + HeapRep False 0 1 Thunk{} -> THUNK_0_1 + HeapRep False 2 0 Thunk{} -> THUNK_2_0 + HeapRep False 1 1 Thunk{} -> THUNK_1_1 + HeapRep False 0 2 Thunk{} -> THUNK_0_2 + HeapRep False _ _ Thunk{} -> THUNK + + HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR + + -- Approximation: we use the CONSTR_NOCAF_STATIC type for static + -- constructors -- that have no pointer words only. + HeapRep True 0 _ Constr{} -> CONSTR_NOCAF_STATIC -- See isStaticNoCafCon below + HeapRep True _ _ Constr{} -> CONSTR_STATIC + HeapRep True _ _ Fun{} -> FUN_STATIC + HeapRep True _ _ Thunk{} -> THUNK_STATIC + + HeapRep False _ _ BlackHole{} -> BLACKHOLE + + HeapRep False _ _ IndStatic{} -> IND_STATIC + + _ -> panic "rtsClosureType" + +-- We export these ones +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int +rET_SMALL = RET_SMALL +rET_BIG = RET_BIG +aRG_GEN = ARG_GEN +aRG_GEN_BIG = ARG_GEN_BIG + +{- +Note [Static NoCaf constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we know that a top-level binding 'x' is not Caffy (ie no CAFs are +reachable from 'x'), then a statically allocated constructor (Just x) +is also not Caffy, and the garbage collector need not follow its +argument fields. Exploiting this would require two static info tables +for Just, for the two cases where the argument was Caffy or non-Caffy. + +Currently we don't do this; instead we treat nullary constructors +as non-Caffy, and the others as potentially Caffy. + + +************************************************************************ +* * + Pretty printing of SMRep and friends +* * +************************************************************************ +-} + +instance Outputable ClosureTypeInfo where + ppr = pprTypeInfo + +instance Outputable SMRep where + ppr (HeapRep static ps nps tyinfo) + = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) + where + header = ptext (sLit "HeapRep") + <+> if static then ptext (sLit "static") else empty + <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps + pp_n :: String -> Int -> SDoc + pp_n _ 0 = empty + pp_n s n = int n <+> text s + + ppr (ArrayPtrsRep size _) = ptext (sLit "ArrayPtrsRep") <+> ppr size + + ppr (SmallArrayPtrsRep size) = ptext (sLit "SmallArrayPtrsRep") <+> ppr size + + ppr (ArrayWordsRep words) = ptext (sLit "ArrayWordsRep") <+> ppr words + + ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs + + ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep + +instance Outputable ArgDescr where + ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> ppr n + ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls + +pprTypeInfo :: ClosureTypeInfo -> SDoc +pprTypeInfo (Constr tag descr) + = ptext (sLit "Con") <+> + braces (sep [ ptext (sLit "tag:") <+> ppr tag + , ptext (sLit "descr:") <> text (show descr) ]) + +pprTypeInfo (Fun arity args) + = ptext (sLit "Fun") <+> + braces (sep [ ptext (sLit "arity:") <+> ppr arity + , ptext (sLit ("fun_type:")) <+> ppr args ]) + +pprTypeInfo (ThunkSelector offset) + = ptext (sLit "ThunkSel") <+> ppr offset + +pprTypeInfo Thunk = ptext (sLit "Thunk") +pprTypeInfo BlackHole = ptext (sLit "BlackHole") +pprTypeInfo IndStatic = ptext (sLit "IndStatic") + +-- XXX Does not belong here!! +stringToWord8s :: String -> [Word8] +stringToWord8s s = map (fromIntegral . ord) s + +pprWord8String :: [Word8] -> SDoc +-- Debug printing. Not very clever right now. +pprWord8String ws = text (show ws) diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes new file mode 100644 index 00000000..99b2599a --- /dev/null +++ b/compiler/cmm/cmm-notes @@ -0,0 +1,285 @@ +More notes (Aug 11) +~~~~~~~~~~~~~~~~~~ +* CmmInfo.cmmToRawCmm expands info tables to their representations + (needed for .cmm files as well as the code generators) + +* Why is FCode a lazy monad? That makes it inefficient. + We want laziness to get code out one procedure at a time, + but not at the instruction level. + +Things we did + * Remove CmmCvt.graphToZgraph (Conversion from old to new Cmm reps) + * Remove HscMain.optionallyConvertAndOrCPS (converted old Cmm to + new, ran pipeline, and converted back) + * Remove CmmDecl. Put its types in Cmm. Import Cmm into OldCmm + so it can get those types. + + +More notes (June 11) +~~~~~~~~~~~~~~~~~~~~ + +* In CmmContFlowOpts.branchChainElim, can a single block be the + successor of two calls? + +* Check in ClosureInfo: + -- NB: Results here should line up with the results of SMRep.rtsClosureType + +More notes (May 11) +~~~~~~~~~~~~~~~~~~~ +In CmmNode, consider spliting CmmCall into two: call and jump + +Notes on new codegen (Aug 10) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Things to do: + - Proc points pass all arguments on the stack, adding more code and + slowing down things a lot. We either need to fix this or even better + would be to get rid of proc points. + + - Sort out Label, LabelMap, LabelSet versus BlockId, BlockEnv, BlockSet + dichotomy. Mostly this means global replace, but we also need to make + Label an instance of Outputable (probably in the Outputable module). + + EZY: We should use Label, since that's the terminology Hoopl uses. + + - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline + EZY (2011-04-16): The mini-inliner has been generalized and ported, + but the constant folding and other optimizations need to still be + ported. + + - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches); + we ultimately want to share this with the Cmm branch eliminator. + + - At the moment, references to global registers like Hp are "lowered" + late (in CgUtils.fixStgRegisters). We should do this early, in the + new native codegen, much in the way that we lower calling conventions. + Might need to be a bit sophisticated about aliasing. + + - Move to new Cmm rep: + * Make native CG consume New Cmm; + * Convert Old Cmm->New Cmm to keep old path alive + * Produce New Cmm when reading in .cmm files + + - Top-level SRT threading is a bit ugly + + - See "CAFs" below; we want to totally refactor the way SRTs are calculated + + - Garbage-collect http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/CPS + moving good stuff into + http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/NewCodeGenPipeline + + - Currently AsmCodeGen top level calls AsmCodeGen.cmmToCmm, which is a small + C-- optimiser. It has quite a lot of boilerplate folding code in AsmCodeGen + (cmmBlockConFold, cmmStmtConFold, cmmExprConFold), before calling out to + CmmOpt. ToDo: see what optimisations are being done; and do them before + AsmCodeGen. + + - If we stick CAF and stack liveness info on a LastCall node (not LastRet/Jump) + then all CAF and stack liveness stuff be completed before we split + into separate C procedures. + + Short term: + compute and attach liveness into LastCall + right at end, split, cvt to old rep + [must split before cvt, because old rep is not expressive enough] + + Longer term: + when old rep disappears, + move the whole splitting game into the C back end *only* + (guided by the procpoint set) + +---------------------------------------------------- + Modules in codeGen/ +---------------------------------------------------- + + +------- Shared --------- +Bitmap.hs +SMRep.lhs + +CmmParse.y +CgExtCode.hs used in CmmParse.y + +------- New codegen --------- + +StgCmm.hs +StgCmmBind.hs +StgCmmClosure.hs (corresponds to old ClosureInfo) +StgCmmCon.hs +StgCmmEnv.hs +StgCmmExpr.hs +StgCmmForeign.hs +StgCmmGran.hs +StgCmmHeap.hs +StgCmmHpc.hs +StgCmmLayout.hs +StgCmmMonad.hs +StgCmmPrim.hs +StgCmmProf.hs +StgCmmTicky.hs +StgCmmUtils.hs + +------- Old codegen (moribund) --------- +CodeGen.lhs +CgBindery.lhs +CgCallConv.hs +CgCase.lhs +CgClosure.lhs +CgCon.lhs +CgExpr.lhs +CgLetNoEscape.lhs +CgForeignCall.hs +CgHeapery.lhs +CgHpc.hs +CgInfoTbls.hs +CgMonad.lhs +CgParallel.hs +CgPrimOp.hs +CgProf.hs +CgStackery.lhs +CgTailCall.lhs +CgTicky.hs +CgUtils.hs +ClosureInfo.lhs + +---------------------------------------------------- + Modules in cmm/ +---------------------------------------------------- + +-------- Moribund stuff ------------ +OldCmm.hs Definition of flowgraph of old representation + Imports some data types from (new) Cmm +OldCmmUtil.hs Utilites that operates mostly on on CmmStmt +OldPprCmm.hs Pretty print for CmmStmt, GenBasicBlock and ListGraph +CmmOpt.hs Hopefully-redundant optimiser + +-------- Stuff to keep ------------ +CmmPipeline.hs Driver for new pipeline + +CmmLive.hs Liveness analysis, dead code elim +CmmProcPoint.hs Identifying and splitting out proc-points + +CmmSpillReload.hs Save and restore across calls + +CmmCommonBlockElim.hs Common block elim +CmmContFlowOpt.hs Other optimisations (branch-chain, merging) + +CmmBuildInfoTables.hs New info-table +CmmStackLayout.hs and stack layout +CmmCallConv.hs +CmmInfo.hs Defn of InfoTables, and conversion to exact byte layout + +---------- Cmm data types -------------- +Cmm.hs Cmm instantiations of dataflow graph framework + CmmExpr.hs Type of Cmm expression + CmmType.hs Type of Cmm types and their widths + CmmMachOp.hs MachOp type and accompanying utilities + +PprCmm.hs Pretty printer for Cmm + PprCmmExpr.hs Pretty printer for CmmExpr + +MkGraph.hs Interface for building Cmm for codeGen/Stg*.hs modules + +CmmUtils.hs +CmmLint.hs + +PprC.hs Pretty print Cmm in C syntax + +CLabel.hs CLabel +BlockId.hs BlockId, BlockEnv, BlockSet + + +---------------------------------------------------- + Proc-points +---------------------------------------------------- + +Consider this program, which has a diamond control flow, +with a call on one branch + fn(p,x) { + h() + if b then { ... f(x) ...; q=5; goto J } + else { ...; q=7; goto J } + J: ..p...q... + } +then the join point J is a "proc-point". So, is 'p' passed to J +as a parameter? Or, if 'p' was saved on the stack anyway, perhaps +to keep it alive across the call to h(), maybe 'p' gets communicated +to J that way. This is an awkward choice. (We think that we currently +never pass variables to join points via arguments.) + +Furthermore, there is *no way* to pass q to J in a register (other +than a parameter register). + +What we want is to do register allocation across the whole caboodle. +Then we could drop all the code that deals with the above awkward +decisions about spilling variables across proc-points. + +Note that J doesn't need an info table. + +What we really want is for each LastCall (not LastJump/Ret) +to have an info table. Note that ProcPoints that are not successors +of calls don't need an info table. + +Figuring out proc-points +~~~~~~~~~~~~~~~~~~~~~~~~ +Proc-points are identified by +CmmProcPoint.minimalProcPointSet/extendPPSet Although there isn't +that much code, JD thinks that it could be done much more nicely using +a dominator analysis, using the Dataflow Engine. + +---------------------------------------------------- + CAFs +---------------------------------------------------- + +* The code for a procedure f may refer to either the *closure* + or the *entry point* of another top-level procedure g. + If f is live, then so is g. f's SRT must include g's closure. + +* The CLabel for the entry-point/closure reveals whether g is + a CAF (or refers to CAFs). See the IdLabel constructor of CLabel. + +* The CAF-ness of the original top-level defininions is figured out + (by TidyPgm) before we generate C--. This CafInfo is only set for + top-level Ids; nested bindings stay with MayHaveCafRefs. + +* Currently an SRT contains (only) pointers to (top-level) closures. + +* Consider this Core code + f = \x -> let g = \y -> ...x...y...h1... + in ...h2...g... + and suppose that h1, h2 have IdInfo of MayHaveCafRefs. + Therefore, so will f, But g will not (since it's nested). + + This generates C-- roughly like this: + f_closure: .word f_entry + f_entry() [info-tbl-for-f] { ...jump g_entry...jump h2... } + g_entry() [info-tbl-for-g] { ...jump h1... } + + Note that there is no top-level closure for g (only an info table). + This fact (whether or not there is a top-level closure) is recorded + in the InfoTable attached to the CmmProc for f, g + INVARIANT: + Any out-of-Group references to an IdLabel goes to + a Proc whose InfoTable says "I have a top-level closure". + Equivalently: + A CmmProc whose InfoTable says "I do not have a top-level + closure" is referred to only from its own Group. + +* So: info-tbl-for-f must have an SRT that keeps h1,h2 alive + info-tbl-for-g must have an SRT that keeps h1 (only) alive + + But if we just look for the free CAF refs, we get: + f h2 (only) + g h1 + + So we need to do a transitive closure thing to flesh out + f's keep-alive refs to include h1. + +* The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a + CmmInfoTable attached to each CmmProc. CmmPipeline.toTops actually does + the attaching, right at the end of the pipeline. The C_SRT part + gives offsets within a single, shared table of closure pointers. + +* DECIDED: we can generate SRTs based on the final Cmm program + without knowledge of how it is generated. + diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs new file mode 100644 index 00000000..51b8ed9e --- /dev/null +++ b/compiler/codeGen/CgUtils.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE CPP, GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Code generator utilities; mostly monadic +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module CgUtils ( fixStgRegisters ) where + +#include "HsVersions.h" + +import CodeGen.Platform +import Cmm +import Hoopl +import CmmUtils +import CLabel +import DynFlags +import Outputable + +-- ----------------------------------------------------------------------------- +-- Information about global registers + +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags +baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags +baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags +baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags +baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags +baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags +baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags +baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags +baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags +baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags +baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags +baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags +baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags +baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags +baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags +baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags +baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags +baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags +baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags +baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags +baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags +baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags +baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags +baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags +baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags +baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags +baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") +baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags +baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags +baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags +baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags +baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags +baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags +baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") +baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags +baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags +baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags +baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags +baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags +baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags +baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg" + + +-- ----------------------------------------------------------------------------- +-- +-- STG/Cmm GlobalReg +-- +-- ----------------------------------------------------------------------------- + +-- | We map STG registers onto appropriate CmmExprs. Either they map +-- to real machine registers or stored as offsets from BaseReg. Given +-- a GlobalReg, get_GlobalReg_addr always produces the +-- register table address for it. +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) + +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _ offset = + if haveRegBase (targetPlatform dflags) + then CmmRegOff (CmmGlobal BaseReg) offset + else regTableOffset dflags offset + +-- | Fixup global registers so that they assign to locations within the +-- RegTable if they aren't pinned for the current target. +fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl +fixStgRegisters _ top@(CmmData _ _) = top + +fixStgRegisters dflags (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph + in CmmProc info lbl live graph' + +fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block + +fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x +fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt + where + platform = targetPlatform dflags + + fixAssign stmt = + case stmt of + CmmAssign (CmmGlobal reg) src -> + let baseAddr = get_GlobalReg_addr dflags reg + in case reg `elem` activeStgRegs (targetPlatform dflags) of + True -> CmmAssign (CmmGlobal reg) src + False -> CmmStore baseAddr src + other_stmt -> other_stmt + + fixExpr expr = case expr of + CmmReg (CmmGlobal reg) -> + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this + -- arch are left unchanged. For the rest, BaseReg is taken + -- to mean the address of the reg table in MainCapability, + -- and for all others we generate an indirection to its + -- location in the register table. + case reg `elem` activeStgRegs platform of + True -> expr + False -> + let baseAddr = get_GlobalReg_addr dflags reg + in case reg of + BaseReg -> baseAddr + _other -> CmmLoad baseAddr (globalRegType dflags reg) + + CmmRegOff (CmmGlobal reg) offset -> + -- RegOf leaves are just a shorthand form. If the reg maps + -- to a real reg, we keep the shorthand, otherwise, we just + -- expand it and defer to the above code. + case reg `elem` activeStgRegs platform of + True -> expr + False -> CmmMachOp (MO_Add (wordWidth dflags)) [ + fixExpr (CmmReg (CmmGlobal reg)), + CmmLit (CmmInt (fromIntegral offset) + (wordWidth dflags))] + + other_expr -> other_expr + diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs new file mode 100644 index 00000000..e44eed67 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform.hs @@ -0,0 +1,117 @@ + +module CodeGen.Platform + (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) + where + +import CmmExpr +import FastBool +import Platform +import Reg + +import qualified CodeGen.Platform.ARM as ARM +import qualified CodeGen.Platform.ARM64 as ARM64 +import qualified CodeGen.Platform.PPC as PPC +import qualified CodeGen.Platform.PPC_Darwin as PPC_Darwin +import qualified CodeGen.Platform.SPARC as SPARC +import qualified CodeGen.Platform.X86 as X86 +import qualified CodeGen.Platform.X86_64 as X86_64 +import qualified CodeGen.Platform.NoRegs as NoRegs + +-- | Returns 'True' if this global register is stored in a caller-saves +-- machine register. + +callerSaves :: Platform -> GlobalReg -> Bool +callerSaves platform + | platformUnregisterised platform = NoRegs.callerSaves + | otherwise + = case platformArch platform of + ArchX86 -> X86.callerSaves + ArchX86_64 -> X86_64.callerSaves + ArchSPARC -> SPARC.callerSaves + ArchARM {} -> ARM.callerSaves + ArchARM64 -> ARM64.callerSaves + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.callerSaves + _ -> PPC.callerSaves + + | otherwise -> NoRegs.callerSaves + +-- | Here is where the STG register map is defined for each target arch. +-- The order matters (for the llvm backend anyway)! We must make sure to +-- maintain the order here with the order used in the LLVM calling conventions. +-- Note that also, this isn't all registers, just the ones that are currently +-- possbily mapped to real registers. +activeStgRegs :: Platform -> [GlobalReg] +activeStgRegs platform + | platformUnregisterised platform = NoRegs.activeStgRegs + | otherwise + = case platformArch platform of + ArchX86 -> X86.activeStgRegs + ArchX86_64 -> X86_64.activeStgRegs + ArchSPARC -> SPARC.activeStgRegs + ArchARM {} -> ARM.activeStgRegs + ArchARM64 -> ARM64.activeStgRegs + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.activeStgRegs + _ -> PPC.activeStgRegs + + | otherwise -> NoRegs.activeStgRegs + +haveRegBase :: Platform -> Bool +haveRegBase platform + | platformUnregisterised platform = NoRegs.haveRegBase + | otherwise + = case platformArch platform of + ArchX86 -> X86.haveRegBase + ArchX86_64 -> X86_64.haveRegBase + ArchSPARC -> SPARC.haveRegBase + ArchARM {} -> ARM.haveRegBase + ArchARM64 -> ARM64.haveRegBase + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.haveRegBase + _ -> PPC.haveRegBase + + | otherwise -> NoRegs.haveRegBase + +globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg +globalRegMaybe platform + | platformUnregisterised platform = NoRegs.globalRegMaybe + | otherwise + = case platformArch platform of + ArchX86 -> X86.globalRegMaybe + ArchX86_64 -> X86_64.globalRegMaybe + ArchSPARC -> SPARC.globalRegMaybe + ArchARM {} -> ARM.globalRegMaybe + ArchARM64 -> ARM64.globalRegMaybe + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.globalRegMaybe + _ -> PPC.globalRegMaybe + + | otherwise -> NoRegs.globalRegMaybe + +freeReg :: Platform -> RegNo -> FastBool +freeReg platform + | platformUnregisterised platform = NoRegs.freeReg + | otherwise + = case platformArch platform of + ArchX86 -> X86.freeReg + ArchX86_64 -> X86_64.freeReg + ArchSPARC -> SPARC.freeReg + ArchARM {} -> ARM.freeReg + ArchARM64 -> ARM64.freeReg + arch + | arch `elem` [ArchPPC, ArchPPC_64] -> + case platformOS platform of + OSDarwin -> PPC_Darwin.freeReg + _ -> PPC.freeReg + + | otherwise -> NoRegs.freeReg + diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs new file mode 100644 index 00000000..5d114849 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/ARM.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.ARM where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_arm 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/ARM64.hs b/compiler/codeGen/CodeGen/Platform/ARM64.hs new file mode 100644 index 00000000..c3ebeda6 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/ARM64.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.ARM64 where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_aarch64 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs new file mode 100644 index 00000000..0c85ffbd --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.NoRegs where + +#define MACHREGS_NO_REGS 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs new file mode 100644 index 00000000..76a2b020 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/PPC.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.PPC where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_powerpc 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs new file mode 100644 index 00000000..a98e558c --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.PPC_Darwin where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_powerpc 1 +#define MACHREGS_darwin 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs new file mode 100644 index 00000000..991f515e --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.SPARC where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_sparc 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs new file mode 100644 index 00000000..e74807ff --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/X86.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.X86 where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_i386 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs new file mode 100644 index 00000000..102132d6 --- /dev/null +++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module CodeGen.Platform.X86_64 where + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_x86_64 1 +#include "../../../../includes/CodeGen.Platform.hs" + diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs new file mode 100644 index 00000000..efc89fe0 --- /dev/null +++ b/compiler/codeGen/StgCmm.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmm ( codeGen ) where + +#define FAST_STRING_NOT_NEEDED +#include "HsVersions.h" + +import StgCmmProf (initCostCentres, ldvEnter) +import StgCmmMonad +import StgCmmEnv +import StgCmmBind +import StgCmmCon +import StgCmmLayout +import StgCmmUtils +import StgCmmClosure +import StgCmmHpc +import StgCmmTicky + +import Cmm +import CLabel + +import StgSyn +import DynFlags + +import HscTypes +import CostCentre +import Id +import IdInfo +import Type +import DataCon +import Name +import TyCon +import Module +import Outputable +import Stream +import BasicTypes + +import OrdList +import MkGraph + +import Data.IORef +import Control.Monad (when,void) +import Util + +codeGen :: DynFlags + -> Module + -> [TyCon] + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> [StgBinding] -- Bindings to convert + -> HpcInfo + -> Stream IO CmmGroup () -- Output as a stream, so codegen can + -- be interleaved with output + +codeGen dflags this_mod data_tycons + cost_centre_info stg_binds hpc_info + = do { -- cg: run the code generator, and yield the resulting CmmGroup + -- Using an IORef to store the state is a bit crude, but otherwise + -- we would need to add a state monad layer. + ; cgref <- liftIO $ newIORef =<< initC + ; let cg :: FCode () -> Stream IO CmmGroup () + cg fcode = do + cmm <- liftIO $ do + st <- readIORef cgref + let (a,st') = runC dflags this_mod st (getCmm fcode) + + -- NB. stub-out cgs_tops and cgs_stmts. This fixes + -- a big space leak. DO NOT REMOVE! + writeIORef cgref $! st'{ cgs_tops = nilOL, + cgs_stmts = mkNop } + return a + yield cmm + + -- Note [codegen-split-init] the cmm_init block must come + -- FIRST. This is because when -split-objs is on we need to + -- combine this block with its initialisation routines; see + -- Note [pipeline-split-init]. + ; cg (mkModuleInit cost_centre_info this_mod hpc_info) + + ; mapM_ (cg . cgTopBinding dflags) stg_binds + + -- Put datatype_stuff after code_stuff, because the + -- datatype closure table (for enumeration types) to + -- (say) PrelBase_True_closure, which is defined in + -- code_stuff + ; let do_tycon tycon = do + -- Generate a table of static closures for an + -- enumeration type Note that the closure pointers are + -- tagged. + when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) + mapM_ (cg . cgDataCon) (tyConDataCons tycon) + + ; mapM_ do_tycon data_tycons + } + +--------------------------------------------------------------- +-- Top-level bindings +--------------------------------------------------------------- + +{- 'cgTopBinding' is only used for top-level bindings, since they need +to be allocated statically (not in the heap) and need to be labelled. +No unboxed bindings can happen at top level. + +In the code below, the static bindings are accumulated in the +@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. +This is so that we can write the top level processing in a compositional +style, with the increasing static environment being plumbed as a state +variable. -} + +cgTopBinding :: DynFlags -> StgBinding -> FCode () +cgTopBinding dflags (StgNonRec id rhs) + = do { id' <- maybeExternaliseId dflags id + ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs + ; fcode + ; addBindC info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences + } + +cgTopBinding dflags (StgRec pairs) + = do { let (bndrs, rhss) = unzip pairs + ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs + ; let pairs' = zip bndrs' rhss + r = unzipWith (cgTopRhs dflags Recursive) pairs' + (infos, fcodes) = unzip r + ; addBindsC infos + ; sequence_ fcodes + } + + +cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) + -- The Id is passed along for setting up a binding... + -- It's already been externalised if necessary + +cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) + = cgTopRhsCon dflags bndr con args + +cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) + = ASSERT(null fvs) -- There should be no free variables + cgTopRhsClosure dflags rec bndr cc bi upd_flag args body + + +--------------------------------------------------------------- +-- Module initialisation code +--------------------------------------------------------------- + +{- The module initialisation code looks like this, roughly: + + FN(__stginit_Foo) { + JMP_(__stginit_Foo_1_p) + } + + FN(__stginit_Foo_1_p) { + ... + } + + We have one version of the init code with a module version and the + 'way' attached to it. The version number helps to catch cases + where modules are not compiled in dependency order before being + linked: if a module has been compiled since any modules which depend on + it, then the latter modules will refer to a different version in their + init blocks and a link error will ensue. + + The 'way' suffix helps to catch cases where modules compiled in different + ways are linked together (eg. profiled and non-profiled). + + We provide a plain, unadorned, version of the module init code + which just jumps to the version with the label and way attached. The + reason for this is that when using foreign exports, the caller of + startupHaskell() must supply the name of the init function for the "top" + module in the program, and we don't want to require that this name + has the version and way info appended to it. + +We initialise the module tree by keeping a work-stack, + * pointed to by Sp + * that grows downward + * Sp points to the last occupied slot +-} + +mkModuleInit + :: CollectedCCs -- cost centre info + -> Module + -> HpcInfo + -> FCode () + +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) [])) + } + + +--------------------------------------------------------------- +-- Generating static stuff for algebraic data types +--------------------------------------------------------------- + + +cgEnumerationTyCon :: TyCon -> FCode () +cgEnumerationTyCon tycon + = do dflags <- getDynFlags + emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) + (tagForCon dflags con) + | con <- tyConDataCons tycon] + + +cgDataCon :: DataCon -> FCode () +-- Generate the entry code, info tables, and (for niladic constructor) +-- the static closure, for a constructor. +cgDataCon data_con + = do { dflags <- getDynFlags + ; let + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + arg_things) = mkVirtConstrOffsets dflags arg_reps + + nonptr_wds = tot_wds - ptr_wds + + sta_info_tbl = mkDataConInfoTable dflags data_con True ptr_wds nonptr_wds + dyn_info_tbl = mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds + + emit_info info_tbl ticky_code + = emitClosureAndInfoTable info_tbl NativeDirectCall [] + $ mk_code ticky_code + + mk_code ticky_code + = -- NB: the closure pointer is assumed *untagged* on + -- entry to a constructor. If the pointer is tagged, + -- then we should not be entering it. This assumption + -- is used in ldvEnter and when tagging the pointer to + -- return it. + -- NB 2: We don't set CC when entering data (WDP 94/06) + do { _ <- ticky_code + ; ldvEnter (CmmReg nodeReg) + ; tickyReturnOldCon (length arg_things) + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) + (tagForCon dflags data_con)] + } + -- The case continuation code expects a tagged pointer + + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] + + -- Dynamic closure code for non-nullary constructors only + ; when (not (isNullaryRepDataCon data_con)) + (emit_info dyn_info_tbl tickyEnterDynCon) + + -- Dynamic-Closure first, to reduce forward references + ; emit_info sta_info_tbl tickyEnterStaticCon } + + +--------------------------------------------------------------- +-- Stuff to support splitting +--------------------------------------------------------------- + +maybeExternaliseId :: DynFlags -> Id -> FCode Id +maybeExternaliseId dflags id + | gopt Opt_SplitObjs dflags, -- See Note [Externalise when splitting] + -- in StgCmmMonad + isInternalName name = do { mod <- getModuleName + ; returnFC (setIdName id (externalise mod)) } + | otherwise = returnFC id + where + externalise mod = mkExternalName uniq mod new_occ loc + name = idName id + uniq = nameUnique name + new_occ = mkLocalOcc uniq (nameOccName name) + loc = nameSrcSpan name + -- We want to conjure up a name that can't clash with any + -- existing name. So we generate + -- Mod_$L243foo + -- where 243 is the unique. diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs new file mode 100644 index 00000000..9821b0a2 --- /dev/null +++ b/compiler/codeGen/StgCmmArgRep.hs @@ -0,0 +1,151 @@ +----------------------------------------------------------------------------- +-- +-- Argument representations used in StgCmmLayout. +-- +-- (c) The University of Glasgow 2013 +-- +----------------------------------------------------------------------------- + +module StgCmmArgRep ( + ArgRep(..), toArgRep, argRepSizeW, + + argRepString, isNonV, idArgRep, + + slowCallPattern, + + ) where + +import StgCmmClosure ( idPrimRep ) + +import SMRep ( WordOff ) +import Id ( Id ) +import TyCon ( PrimRep(..), primElemRepSizeB ) +import BasicTypes ( RepArity ) +import Constants ( wORD64_SIZE ) +import DynFlags + +import Outputable +import FastString + +-- I extricated this code as this new module in order to avoid a +-- cyclic dependency between StgCmmLayout and StgCmmTicky. +-- +-- NSF 18 Feb 2013 + +------------------------------------------------------------------------- +-- Classifying arguments: ArgRep +------------------------------------------------------------------------- + +-- ArgRep is re-exported by StgCmmLayout, but only for use in the +-- byte-code generator which also needs to know about the +-- classification of arguments. + +data ArgRep = P -- GC Ptr + | N -- Word-sized non-ptr + | L -- 64-bit non-ptr (long) + | V -- Void + | F -- Float + | D -- Double + | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc. + | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc. + | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc. +instance Outputable ArgRep where ppr = text . argRepString + +argRepString :: ArgRep -> String +argRepString P = "P" +argRepString N = "N" +argRepString L = "L" +argRepString V = "V" +argRepString F = "F" +argRepString D = "D" +argRepString V16 = "V16" +argRepString V32 = "V32" +argRepString V64 = "V64" + +toArgRep :: PrimRep -> ArgRep +toArgRep VoidRep = V +toArgRep PtrRep = P +toArgRep IntRep = N +toArgRep WordRep = N +toArgRep AddrRep = N +toArgRep Int64Rep = L +toArgRep Word64Rep = L +toArgRep FloatRep = F +toArgRep DoubleRep = D +toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of + 16 -> V16 + 32 -> V32 + 64 -> V64 + _ -> error "toArgRep: bad vector primrep" + +isNonV :: ArgRep -> Bool +isNonV V = False +isNonV _ = True + +argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words +argRepSizeW _ N = 1 +argRepSizeW _ P = 1 +argRepSizeW _ F = 1 +argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags +argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +argRepSizeW _ V = 0 +argRepSizeW dflags V16 = 16 `quot` wORD_SIZE dflags +argRepSizeW dflags V32 = 32 `quot` wORD_SIZE dflags +argRepSizeW dflags V64 = 64 `quot` wORD_SIZE dflags + +idArgRep :: Id -> ArgRep +idArgRep = toArgRep . idPrimRep + +-- This list of argument patterns should be kept in sync with at least +-- the following: +-- +-- * StgCmmLayout.stdPattern maybe to some degree? +-- +-- * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast) +-- declarations in includes/stg/MiscClosures.h +-- +-- * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h, +-- +-- * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h, +-- +-- * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c, +-- +-- * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and +-- SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c +-- +-- There may be more places that I haven't found; I merely igrep'd for +-- pppppp and excluded things that seemed ghci-specific. +-- +-- Also, it seems at the moment that ticky counters with void +-- arguments will never be bumped, but I'm still declaring those +-- counters, defensively. +-- +-- NSF 6 Mar 2013 + +slowCallPattern :: [ArgRep] -> (FastString, RepArity) +-- Returns the generic apply function and arity +-- +-- The first batch of cases match (some) specialised entries +-- The last group deals exhaustively with the cases for the first argument +-- (and the zero-argument case) +-- +-- In 99% of cases this function will match *all* the arguments in one batch + +slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) +slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) +slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4) +slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4) +slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3) +slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3) +slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2) +slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2) +slowCallPattern (P: _) = (fsLit "stg_ap_p", 1) +slowCallPattern (V: _) = (fsLit "stg_ap_v", 1) +slowCallPattern (N: _) = (fsLit "stg_ap_n", 1) +slowCallPattern (F: _) = (fsLit "stg_ap_f", 1) +slowCallPattern (D: _) = (fsLit "stg_ap_d", 1) +slowCallPattern (L: _) = (fsLit "stg_ap_l", 1) +slowCallPattern (V16: _) = (fsLit "stg_ap_v16", 1) +slowCallPattern (V32: _) = (fsLit "stg_ap_v32", 1) +slowCallPattern (V64: _) = (fsLit "stg_ap_v64", 1) +slowCallPattern [] = (fsLit "stg_ap_0", 0) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs new file mode 100644 index 00000000..da87f965 --- /dev/null +++ b/compiler/codeGen/StgCmmBind.hs @@ -0,0 +1,751 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: bindings +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmBind ( + cgTopRhsClosure, + cgBind, + emitBlackHoleCode, + pushUpdateFrame, emitUpdateFrame + ) where + +#include "HsVersions.h" + +import StgCmmExpr +import StgCmmMonad +import StgCmmEnv +import StgCmmCon +import StgCmmHeap +import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk, + initUpdFrameProf) +import StgCmmTicky +import StgCmmLayout +import StgCmmUtils +import StgCmmClosure +import StgCmmForeign (emitPrimCall) + +import MkGraph +import CoreSyn ( AltCon(..), tickishIsCode ) +import SMRep +import Cmm +import CmmInfo +import CmmUtils +import CLabel +import StgSyn +import CostCentre +import Id +import IdInfo +import Name +import Module +import ListSetOps +import Util +import BasicTypes +import Outputable +import FastString +import DynFlags + +import Control.Monad + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +------------------------------------------------------------------------ +-- Top-level bindings +------------------------------------------------------------------------ + +-- For closures bound at top level, allocate in static space. +-- They should have no free variables. + +cgTopRhsClosure :: DynFlags + -> RecFlag -- member of a recursive group? + -> Id + -> CostCentreStack -- Optional cost centre annotation + -> StgBinderInfo + -> UpdateFlag + -> [Id] -- Args + -> StgExpr + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure dflags rec id ccs _ upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + in (cg_id_info, gen_code dflags lf_info closure_label) + where + -- special case for a indirection (f = g). We create an IND_STATIC + -- closure pointing directly to the indirectee. This is exactly + -- what the CAF will eventually evaluate to anyway, we're just + -- shortcutting the whole process, and generating a lot less code + -- (#7308) + -- + -- Note: we omit the optimisation when this binding is part of a + -- recursive group, because the optimisation would inhibit the black + -- hole detection from working in that case. Test + -- concurrent/should_run/4030 fails, for instance. + -- + gen_code dflags _ closure_label + | StgApp f [] <- body, null args, isNonRec rec + = do + cg_info <- getCgIdInfo f + let closure_rep = mkStaticClosureFields dflags + indStaticInfoTable ccs MayHaveCafRefs + [unLit (idInfoToAmode cg_info)] + emitDataLits closure_label closure_rep + return () + + gen_code dflags lf_info closure_label + = do { -- LAY OUT THE OBJECT + let name = idName id + ; mod_name <- getModuleName + ; let descr = closureDescription dflags mod_name name + closure_info = mkClosureInfo dflags True id lf_info 0 0 descr + + caffy = idCafInfo id + info_tbl = mkCmmInfo closure_info -- XXX short-cut + closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] + + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) + ; emitDataLits closure_label closure_rep + ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] + (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) + (addIdReps []) + -- Don't drop the non-void args until the closure info has been made + ; forkClosureBody (closureCodeBody True id closure_info ccs + (nonVoidIds args) (length args) body fv_details) + + ; return () } + + unLit (CmmLit l) = l + unLit _ = panic "unLit" + +------------------------------------------------------------------------ +-- Non-top-level bindings +------------------------------------------------------------------------ + +cgBind :: StgBinding -> FCode () +cgBind (StgNonRec name rhs) + = do { (info, fcode) <- cgRhs name rhs + ; addBindC info + ; init <- fcode + ; emit init } + -- init cannot be used in body, so slightly better to sink it eagerly + +cgBind (StgRec pairs) + = do { r <- sequence $ unzipWith cgRhs pairs + ; let (id_infos, fcodes) = unzip r + ; addBindsC id_infos + ; (inits, body) <- getCodeR $ sequence fcodes + ; emit (catAGraphs inits <*> body) } + +{- Note [cgBind rec] + + Recursive let-bindings are tricky. + Consider the following pseudocode: + + let x = \_ -> ... y ... + y = \_ -> ... z ... + z = \_ -> ... x ... + in ... + + For each binding, we need to allocate a closure, and each closure must + capture the address of the other closures. + We want to generate the following C-- code: + // Initialization Code + x = hp - 24; // heap address of x's closure + y = hp - 40; // heap address of x's closure + z = hp - 64; // heap address of x's closure + // allocate and initialize x + m[hp-8] = ... + m[hp-16] = y // the closure for x captures y + m[hp-24] = x_info; + // allocate and initialize y + m[hp-32] = z; // the closure for y captures z + m[hp-40] = y_info; + // allocate and initialize z + ... + + For each closure, we must generate not only the code to allocate and + initialize the closure itself, but also some initialization Code that + sets a variable holding the closure pointer. + + We could generate a pair of the (init code, body code), but since + the bindings are recursive we also have to initialise the + environment with the CgIdInfo for all the bindings before compiling + anything. So we do this in 3 stages: + + 1. collect all the CgIdInfos and initialise the environment + 2. compile each binding into (init, body) code + 3. emit all the inits, and then all the bodies + + We'd rather not have separate functions to do steps 1 and 2 for + each binding, since in pratice they share a lot of code. So we + have just one function, cgRhs, that returns a pair of the CgIdInfo + for step 1, and a monadic computation to generate the code in step + 2. + + The alternative to separating things in this way is to use a + fixpoint. That's what we used to do, but it introduces a + maintenance nightmare because there is a subtle dependency on not + being too strict everywhere. Doing things this way means that the + FCode monad can be strict, for example. + -} + +cgRhs :: Id + -> StgRhs + -> FCode ( + CgIdInfo -- The info for this binding + , FCode CmmAGraph -- A computation which will generate the + -- code for the binding, and return an + -- assignent of the form "x = Hp - n" + -- (see above) + ) + +cgRhs id (StgRhsCon cc con args) + = withNewTickyCounterThunk False (idName id) $ -- False for "not static" + buildDynCon id True cc con args + +{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} +cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) + = do dflags <- getDynFlags + mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body + +------------------------------------------------------------------------ +-- Non-constructor right hand sides +------------------------------------------------------------------------ + +mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo + -> [NonVoid Id] -- Free vars + -> UpdateFlag + -> [Id] -- Args + -> StgExpr + -> FCode (CgIdInfo, FCode CmmAGraph) + +{- mkRhsClosure looks for two special forms of the right-hand side: + a) selector thunks + b) AP thunks + +If neither happens, it just calls mkClosureLFInfo. You might think +that mkClosureLFInfo should do all this, but it seems wrong for the +latter to look at the structure of an expression + +Note [Selectors] +~~~~~~~~~~~~~~~~ +We look at the body of the closure to see if it's a selector---turgid, +but nothing deep. We are looking for a closure of {\em exactly} the +form: + +... = [the_fv] \ u [] -> + case the_fv of + con a_1 ... a_n -> a_i + +Note [Ap thunks] +~~~~~~~~~~~~~~~~ +A more generic AP thunk of the form + + x = [ x_1...x_n ] \.. [] -> x_1 ... x_n + +A set of these is compiled statically into the RTS, so we just use +those. We could extend the idea to thunks where some of the x_i are +global ids (and hence not free variables), but this would entail +generating a larger thunk. It might be an option for non-optimising +compilation, though. + +We only generate an Ap thunk if all the free variables are pointers, +for semi-obvious reasons. + +-} + +---------- Note [Selectors] ------------------ +mkRhsClosure dflags bndr _cc _bi + [NonVoid the_fv] -- Just one free var + upd_flag -- Updatable thunk + [] -- A thunk + expr + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee [{-no args-}]) + _ _ _ _ -- ignore uniq, etc. + (AlgAlt _) + [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr + , StgApp selectee [{-no args-}] <- strip sel_expr + , the_fv == scrutinee -- Scrutinee is the only free variable + + , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params) + -- Just want the layout + , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) + + , let offset_into_int = bytesToWordsRoundUp dflags the_offset + - fixedHdrSizeW dflags + , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough + = -- NOT TRUE: ASSERT(is_single_constructor) + -- The simplifier may have statically determined that the single alternative + -- is the only possible case and eliminated the others, even if there are + -- other constructors in the datatype. It's still ok to make a selector + -- thunk in this case, because we *know* which constructor the scrutinee + -- will evaluate to. + -- + -- srt is discarded; it must be empty + let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) + in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] + +---------- Note [Ap thunks] ------------------ +mkRhsClosure dflags bndr _cc _bi + fvs + upd_flag + [] -- No args; a thunk + (StgApp fun_id args) + + | args `lengthIs` (arity-1) + && all (isGcPtrRep . idPrimRep . unsafe_stripNV) fvs + && isUpdatable upd_flag + && arity <= mAX_SPEC_AP_SIZE dflags + && not (gopt Opt_SccProfilingOn dflags) + -- not when profiling: we don't want to + -- lose information about this particular + -- thunk (e.g. its type) (#949) + + -- Ha! an Ap thunk + = cgRhsStdThunk bndr lf_info payload + + where + lf_info = mkApLFInfo bndr upd_flag arity + -- the payload has to be in the correct order, hence we can't + -- just use the fvs. + payload = StgVarArg fun_id : args + arity = length fvs + +---------- Default case ------------------ +mkRhsClosure dflags bndr cc _ fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args + ; (id_info, reg) <- rhsIdInfo bndr lf_info + ; return (id_info, gen_code lf_info reg) } + where + gen_code lf_info reg + = do { -- LAY OUT THE OBJECT + -- If the binder is itself a free variable, then don't store + -- it in the closure. Instead, just bind it to Node on entry. + -- NB we can be sure that Node will point to it, because we + -- haven't told mkClosureLFInfo about this; so if the binder + -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* + -- stored in the closure itself, so it will make sure that + -- Node points to it... + ; let + is_elem = isIn "cgRhsClosure" + bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] + | otherwise = fvs + + + -- MAKE CLOSURE INFO FOR THIS CLOSURE + ; mod_name <- getModuleName + ; dflags <- getDynFlags + ; let name = idName bndr + descr = closureDescription dflags mod_name name + fv_details :: [(NonVoid Id, ByteOff)] + (tot_wds, ptr_wds, fv_details) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) + (addIdReps (map unsafe_stripNV reduced_fvs)) + closure_info = mkClosureInfo dflags False -- Not static + bndr lf_info tot_wds ptr_wds + descr + + -- BUILD ITS INFO TABLE AND CODE + ; forkClosureBody $ + -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere + -- (b) ignore Sequel from context; use empty Sequel + -- And compile the body + closureCodeBody False bndr closure_info cc (nonVoidIds args) + (length args) body fv_details + + -- BUILD THE OBJECT +-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body + ; let use_cc = curCCS; blame_cc = curCCS + ; emit (mkComment $ mkFastString "calling allocDynClosure") + ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) + ; let info_tbl = mkCmmInfo closure_info + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc + (map toVarArg fv_details) + + -- RETURN + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + +------------------------- +cgRhsStdThunk + :: Id + -> LambdaFormInfo + -> [StgArg] -- payload + -> FCode (CgIdInfo, FCode CmmAGraph) + +cgRhsStdThunk bndr lf_info payload + = do { (id_info, reg) <- rhsIdInfo bndr lf_info + ; return (id_info, gen_code reg) + } + where + gen_code reg -- AHA! A STANDARD-FORM THUNK + = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static" + do + { -- LAY OUT THE OBJECT + mod_name <- getModuleName + ; dflags <- getDynFlags + ; let (tot_wds, ptr_wds, payload_w_offsets) + = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) + + descr = closureDescription dflags mod_name (idName bndr) + closure_info = mkClosureInfo dflags False -- Not static + bndr lf_info tot_wds ptr_wds + descr + +-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body + ; let use_cc = curCCS; blame_cc = curCCS + + ; tickyEnterStdThunk closure_info + + -- BUILD THE OBJECT + ; let info_tbl = mkCmmInfo closure_info + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info + use_cc blame_cc payload_w_offsets + + -- RETURN + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + + +mkClosureLFInfo :: DynFlags + -> Id -- The binder + -> TopLevelFlag -- True of top level + -> [NonVoid Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> LambdaFormInfo +mkClosureLFInfo dflags bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag + | otherwise = + mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) + + +------------------------------------------------------------------------ +-- The code for closures +------------------------------------------------------------------------ + +closureCodeBody :: Bool -- whether this is a top-level binding + -> Id -- the closure's name + -> ClosureInfo -- Lots of information about this closure + -> CostCentreStack -- Optional cost centre attached to closure + -> [NonVoid Id] -- incoming args to the closure + -> Int -- arity, including void args + -> StgExpr + -> [(NonVoid Id, ByteOff)] -- the closure's free vars + -> FCode () + +{- There are two main cases for the code for closures. + +* If there are *no arguments*, then the closure is a thunk, and not in + normal form. So it should set up an update frame (if it is + shared). NB: Thunks cannot have a primitive type! + +* If there is *at least one* argument, then this closure is in + normal form, so there is no need to set up an update frame. + + The Macros for GrAnSim are produced at the beginning of the + argSatisfactionCheck (by calling fetchAndReschedule). + There info if Node points to closure is available. -- HWL -} + +closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details + | arity == 0 -- No args i.e. thunk + = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $ + emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ + \(_, node, _) -> thunkCode cl_info fv_details cc node arity body + where + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info + +closureCodeBody top_lvl bndr cl_info cc args arity body fv_details + = -- Note: args may be [], if all args are Void + withNewTickyCounterFun (closureName cl_info) args $ do { + + ; let + lf_info = closureLFInfo cl_info + info_tbl = mkCmmInfo cl_info + + -- Emit the main entry code + ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ + \(_offset, node, arg_regs) -> do + -- Emit slow-entry code (for entering a closure through a PAP) + { mkSlowEntryCode bndr cl_info arg_regs + ; dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags lf_info + node' = if node_points then Just node else Nothing + ; loop_header_id <- newLabelC + -- Extend reader monad with information that + -- self-recursive tail calls can be optimized into local + -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr. + ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do + { + -- Main payload + ; entryHeapCheck cl_info node' arity arg_regs $ do + { -- emit LDV code when profiling + when node_points (ldvEnterClosure cl_info (CmmLocal node)) + -- ticky after heap check to avoid double counting + ; tickyEnterFun cl_info + ; enterCostCentreFun cc + (CmmMachOp (mo_wordSub dflags) + [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] + , mkIntExpr dflags (funTag dflags cl_info) ]) + ; fv_bindings <- mapM bind_fv fv_details + -- Load free vars out of closure *after* + -- heap check, to reduce live vars over check + ; when node_points $ load_fvs node lf_info fv_bindings + ; void $ cgExpr body + }}} + + } + +-- Note [NodeReg clobbered with loopification] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon +-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1 +-- may get clobbered inside the body of a closure, and since a self-recursive +-- tail call does not restore R1, a subsequent call to enterFunCCS received a +-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to +-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores +-- the original value of R1. This way R1 may get modified but loopification will +-- not care. + +-- A function closure pointer may be tagged, so we +-- must take it into account when accessing the free variables. +bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff) +bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } + +load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () +load_fvs node lf_info = mapM_ (\ (reg, off) -> + do dflags <- getDynFlags + let tag = lfDynTag dflags lf_info + emit $ mkTaggedObjectLoad dflags reg node off tag) + +----------------------------------------- +-- The "slow entry" code for a function. This entry point takes its +-- arguments on the stack. It loads the arguments into registers +-- according to the calling convention, and jumps to the function's +-- normal entry point. The function's closure is assumed to be in +-- R1/node. +-- +-- The slow entry point is used for unknown calls: eg. stg_PAP_entry + +mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () +-- If this function doesn't have a specialised ArgDescr, we need +-- to generate the function's arg bitmap and slow-entry code. +-- Here, we emit the slow-entry code. +mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' + | Just (_, ArgGen _) <- closureFunInfo cl_info + = do dflags <- getDynFlags + let node = idToReg dflags (NonVoid bndr) + slow_lbl = closureSlowEntryLabel cl_info + fast_lbl = closureLocalEntryLabel dflags cl_info + -- mkDirectJump does not clobber `Node' containing function closure + jump = mkJump dflags NativeNodeCall + (mkLblExpr fast_lbl) + (map (CmmReg . CmmLocal) (node : arg_regs)) + (initUpdFrameOff dflags) + tscope <- getTickScope + emitProcWithConvention Slow Nothing slow_lbl + (node : arg_regs) (jump, tscope) + | otherwise = return () + +----------------------------------------- +thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack + -> LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details _cc node arity body + = do { dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) + node' = if node_points then Just node else Nothing + ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling + + -- Heap overflow check + ; entryHeapCheck cl_info node' arity [] $ do + { -- Overwrite with black hole if necessary + -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info + ; when (blackHoleOnEntry cl_info && node_points) + (blackHoleIt node) + + -- Push update frame + ; setupUpdate cl_info node $ + -- We only enter cc after setting up update so + -- that cc of enclosing scope will be recorded + -- in update frame CAF/DICT functions will be + -- subsumed by this enclosing cc + do { tickyEnterThunk cl_info + ; enterCostCentreThunk (CmmReg nodeReg) + ; let lf_info = closureLFInfo cl_info + ; fv_bindings <- mapM bind_fv fv_details + ; load_fvs node lf_info fv_bindings + ; void $ cgExpr body }}} + + +------------------------------------------------------------------------ +-- Update and black-hole wrappers +------------------------------------------------------------------------ + +blackHoleIt :: LocalReg -> FCode () +-- Only called for closures with no args +-- Node points to the closure +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) + +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do + dflags <- getDynFlags + + -- Eager blackholing is normally disabled, but can be turned on with + -- -feager-blackholing. When it is on, we replace the info pointer + -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. + + -- If we wanted to do eager blackholing with slop filling, we'd need + -- to do it at the *end* of a basic block, otherwise we overwrite + -- the free variables in the thunk that we still need. We have a + -- patch for this from Andy Cheadle, but not incorporated yet. --SDM + -- [6/2004] + -- + -- Previously, eager blackholing was enabled when ticky-ticky was + -- on. But it didn't work, and it wasn't strictly necessary to bring + -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is + -- unconditionally disabled. -- krc 1/2007 + + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, + -- because emitBlackHoleCode is called from CmmParse. + + let eager_blackholing = not (gopt Opt_SccProfilingOn dflags) + && gopt Opt_EagerBlackHoling dflags + -- Profiling needs slop filling (to support LDV + -- profiling), so currently eager blackholing doesn't + -- work with profiling. + + when eager_blackholing $ do + emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) + (CmmReg (CmmGlobal CurrentTSO)) + emitPrimCall [] MO_WriteBarrier [] + emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) + +setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () + -- Nota Bene: this function does not change Node (even if it's a CAF), + -- so that the cost centre in the original closure can still be + -- extracted by a subsequent enterCostCentre +setupUpdate closure_info node body + | not (lfUpdatable (closureLFInfo closure_info)) + = body + + | not (isStaticClosure closure_info) + = if not (closureUpdReqd closure_info) + then do tickyUpdateFrameOmitted; body + else do + tickyPushUpdateFrame + dflags <- getDynFlags + let + bh = blackHoleOnEntry closure_info && + not (gopt Opt_SccProfilingOn dflags) && + gopt Opt_EagerBlackHoling dflags + + lbl | bh = mkBHUpdInfoLabel + | otherwise = mkUpdInfoLabel + + pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + + | otherwise -- A static closure + = do { tickyUpdateBhCaf closure_info + + ; if closureUpdReqd closure_info + then do -- Blackhole the (updatable) CAF: + { upd_closure <- link_caf node True + ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + else do {tickyUpdateFrameOmitted; body} + } + +----------------------------------------------------------------------------- +-- Setting up update frames + +-- Push the update frame on the stack in the Entry area, +-- leaving room for the return address that is already +-- at the old end of the area. +-- +pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode () +pushUpdateFrame lbl updatee body + = do + updfr <- getUpdFrameOff + dflags <- getDynFlags + let + hdr = fixedHdrSize dflags + frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags + -- + emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee + withUpdFrameOff frame body + +emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () +emitUpdateFrame dflags frame lbl updatee = do + let + hdr = fixedHdrSize dflags + off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags + -- + emitStore frame (mkLblExpr lbl) + emitStore (cmmOffset dflags frame off_updatee) updatee + initUpdFrameProf frame + +----------------------------------------------------------------------------- +-- Entering a CAF +-- +-- See Note [CAF management] in rts/sm/Storage.c + +link_caf :: LocalReg -- pointer to the closure + -> Bool -- True <=> updatable, False <=> single-entry + -> FCode CmmExpr -- Returns amode for closure to be updated +-- This function returns the address of the black hole, so it can be +-- updated with the new value when available. +link_caf node _is_upd = do + { dflags <- getDynFlags + -- Call the RTS function newCAF, returning the newly-allocated + -- blackhole indirection closure + ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing + ForeignLabelInExternalPackage IsFunction + ; bh <- newTemp (bWord dflags) + ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl + [ (CmmReg (CmmGlobal BaseReg), AddrHint), + (CmmReg (CmmLocal node), AddrHint) ] + False + + -- see Note [atomic CAF entry] in rts/sm/Storage.c + ; updfr <- getUpdFrameOff + ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) + ; emit =<< mkCmmIfThen + (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags)) + -- re-enter the CAF + (mkJump dflags NativeNodeCall target [] updfr) + + ; return (CmmReg (CmmLocal bh)) } + +------------------------------------------------------------------------ +-- Profiling +------------------------------------------------------------------------ + +-- For "global" data constructors the description is simply occurrence +-- name of the data constructor itself. Otherwise it is determined by +-- @closureDescription@ from the let binding information. + +closureDescription :: DynFlags + -> Module -- Module + -> Name -- Id of closure binding + -> String + -- Not called for StgRhsCon which have global info tables built in + -- CgConTbls.lhs with a description generated from the data constructor +closureDescription dflags mod_name name + = showSDocDump dflags (char '<' <> + (if isExternalName name + then ppr name -- ppr will include the module name prefix + else pprModule mod_name <> char '.' <> ppr name) <> + char '>') + -- showSDocDump, because we want to see the unique on the Name. diff --git a/compiler/codeGen/StgCmmBind.hs-boot b/compiler/codeGen/StgCmmBind.hs-boot new file mode 100644 index 00000000..5840e990 --- /dev/null +++ b/compiler/codeGen/StgCmmBind.hs-boot @@ -0,0 +1,6 @@ +module StgCmmBind where + +import StgCmmMonad( FCode ) +import StgSyn( StgBinding ) + +cgBind :: StgBinding -> FCode () diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs new file mode 100644 index 00000000..f8741b7f --- /dev/null +++ b/compiler/codeGen/StgCmmClosure.hs @@ -0,0 +1,1036 @@ +{-# LANGUAGE CPP, RecordWildCards #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: +-- +-- The types LambdaFormInfo +-- ClosureInfo +-- +-- Nothing monadic in here! +-- +----------------------------------------------------------------------------- + +module StgCmmClosure ( + DynTag, tagForCon, isSmallFamily, + ConTagZ, dataConTagZ, + + idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + argPrimRep, + + -- * LambdaFormInfo + LambdaFormInfo, -- Abstract + StandardFormInfo, -- ...ditto... + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + lfDynTag, + maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, + + -- * Used by other modules + CgLoc(..), SelfLoopInfo, CallMethod(..), + nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod, + + -- * ClosureInfo + ClosureInfo, + mkClosureInfo, + mkCmmInfo, + + -- ** Inspection + closureLFInfo, closureName, + + -- ** Labels + -- These just need the info table label + closureInfoLabel, staticClosureLabel, + closureSlowEntryLabel, closureLocalEntryLabel, + + -- ** Predicates + -- These are really just functions on LambdaFormInfo + closureUpdReqd, closureSingleEntry, + closureReEntrant, closureFunInfo, + isToplevClosure, + + blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep + isStaticClosure, -- Needs SMPre + + -- * InfoTables + mkDataConInfoTable, + cafBlackHoleInfoTable, + indStaticInfoTable, + staticClosureNeedsLink, + ) where + +#include "../includes/MachDeps.h" + +#define FAST_STRING_NOT_NEEDED +#include "HsVersions.h" + +import StgSyn +import SMRep +import Cmm +import PprCmmExpr() + +import BlockId +import CLabel +import Id +import IdInfo +import DataCon +import FastString +import Name +import Type +import TypeRep +import TcType +import TyCon +import BasicTypes +import Outputable +import DynFlags +import Util + +----------------------------------------------------------------------------- +-- Data types and synonyms +----------------------------------------------------------------------------- + +-- These data types are mostly used by other modules, especially StgCmmMonad, +-- but we define them here because some functions in this module need to +-- have access to them as well + +data CgLoc + = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning + -- Hp, so that it remains valid across calls + + | LneLoc BlockId [LocalReg] -- A join point + -- A join point (= let-no-escape) should only + -- be tail-called, and in a saturated way. + -- To tail-call it, assign to these locals, + -- and branch to the block id + +instance Outputable CgLoc where + ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e + ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs + +type SelfLoopInfo = (Id, BlockId, [LocalReg]) + +-- used by ticky profiling +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun (LFReEntrant _ _ _ _) = True +isKnownFun LFLetNoEscape = True +isKnownFun _ = False + + +----------------------------------------------------------------------------- +-- Representations +----------------------------------------------------------------------------- + +-- Why are these here? + +idPrimRep :: Id -> PrimRep +idPrimRep id = typePrimRep (idType id) + -- NB: typePrimRep fails on unboxed tuples, + -- but by StgCmm no Ids have unboxed tuple type + +addIdReps :: [Id] -> [(PrimRep, Id)] +addIdReps ids = [(idPrimRep id, id) | id <- ids] + +addArgReps :: [StgArg] -> [(PrimRep, StgArg)] +addArgReps args = [(argPrimRep arg, arg) | arg <- args] + +argPrimRep :: StgArg -> PrimRep +argPrimRep arg = typePrimRep (stgArgType arg) + + +----------------------------------------------------------------------------- +-- LambdaFormInfo +----------------------------------------------------------------------------- + +-- Information about an identifier, from the code generator's point of +-- view. Every identifier is bound to a LambdaFormInfo in the +-- environment, which gives the code generator enough info to be able to +-- tail call or return that identifier. + +data LambdaFormInfo + = LFReEntrant -- Reentrant closure (a function) + TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated constructor application + DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnLifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + + +------------------------- +-- StandardFormInfo tells whether this thunk has one of +-- a small number of standard forms + +data StandardFormInfo + = NonStandardThunk + -- The usual case: not of the standard forms + + | SelectorThunk + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + RepArity -- Arity, n + + +------------------------------------------------------ +-- Building LambdaFormInfo +------------------------------------------------------ + +mkLFArgument :: Id -> LambdaFormInfo +mkLFArgument id + | isUnLiftedType ty = LFUnLifted + | might_be_a_function ty = LFUnknown True + | otherwise = LFUnknown False + where + ty = idType id + +------------- +mkLFLetNoEscape :: LambdaFormInfo +mkLFLetNoEscape = LFLetNoEscape + +------------- +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo + +mkLFReEntrant top fvs args arg_descr + = LFReEntrant top (length args) (null fvs) arg_descr + +------------- +mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo +mkLFThunk thunk_ty top fvs upd_flag + = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) + +-------------- +might_be_a_function :: Type -> Bool +-- Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as poss +might_be_a_function ty + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True + +------------- +mkConLFInfo :: DataCon -> LambdaFormInfo +mkConLFInfo con = LFCon con + +------------- +mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo +mkSelectorLFInfo id offset updatable + = LFThunk NotTopLevel False updatable (SelectorThunk offset) + (might_be_a_function (idType id)) + +------------- +mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo +mkApLFInfo id upd_flag arity + = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) + (might_be_a_function (idType id)) + +------------- +mkLFImported :: Id -> LambdaFormInfo +mkLFImported id + | Just con <- isDataConWorkId_maybe id + , isNullaryRepDataCon con + = LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor + + | arity > 0 + = LFReEntrant TopLevel arity True (panic "arg_descr") + + | otherwise + = mkLFArgument id -- Not sure of exact arity + where + arity = idRepArity id + +----------------------------------------------------- +-- Dynamic pointer tagging +----------------------------------------------------- + +type ConTagZ = Int -- A *zero-indexed* contructor tag + +type DynTag = Int -- The tag on a *pointer* + -- (from the dynamic-tagging paper) + +-- Note [Data constructor dynamic tags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The family size of a data type (the number of constructors +-- or the arity of a function) can be either: +-- * small, if the family size < 2**tag_bits +-- * big, otherwise. +-- +-- Small families can have the constructor tag in the tag bits. +-- Big families only use the tag value 1 to represent evaluatedness. +-- We don't have very many tag bits: for example, we have 2 bits on +-- x86-32 and 3 bits on x86-64. + +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags + +-- We keep the *zero-indexed* tag in the srt_len field of the info +-- table of a data constructor. +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +tagForCon :: DynFlags -> DataCon -> DynTag +tagForCon dflags con + | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 + where + con_tag = dataConTagZ con + fam_size = tyConFamilySize (dataConTyCon con) + +tagForArity :: DynFlags -> RepArity -> DynTag +tagForArity dflags arity + | isSmallFamily dflags arity = arity + | otherwise = 0 + +lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag +-- Return the tag in the low order bits of a variable bound +-- to this LambdaForm +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 + + +----------------------------------------------------------------------------- +-- Observing LambdaFormInfo +----------------------------------------------------------------------------- + +------------- +maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon +maybeIsLFCon (LFCon con) = Just con +maybeIsLFCon _ = Nothing + +------------ +isLFThunk :: LambdaFormInfo -> Bool +isLFThunk (LFThunk {}) = True +isLFThunk _ = False + +isLFReEntrant :: LambdaFormInfo -> Bool +isLFReEntrant (LFReEntrant {}) = True +isLFReEntrant _ = False + +----------------------------------------------------------------------------- +-- Choosing SM reps +----------------------------------------------------------------------------- + +lfClosureType :: LambdaFormInfo -> ClosureTypeInfo +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" + +thunkClosureType :: StandardFormInfo -> ClosureTypeInfo +thunkClosureType (SelectorThunk off) = ThunkSelector off +thunkClosureType _ = Thunk + +-- We *do* get non-updatable top-level thunks sometimes. eg. f = g +-- gets compiled to a jump to g (if g has non-zero arity), instead of +-- messing around with update frames and PAPs. We set the closure type +-- to FUN_STATIC in this case. + +----------------------------------------------------------------------------- +-- nodeMustPointToIt +----------------------------------------------------------------------------- + +nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool +-- If nodeMustPointToIt is true, then the entry convention for +-- this closure has R1 (the "Node" register) pointing to the +-- closure itself --- the "self" argument + +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) + = not no_fvs -- Certainly if it has fvs we need to point to it + || isNotTopLevel top -- See Note [GC recovery] + -- For lex_profiling we also access the cost centre for a + -- non-inherited (i.e. non-top-level) function. + -- The isNotTopLevel test above ensures this is ok. + +nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) + = not no_fvs -- Self parameter + || isNotTopLevel top -- Note [GC recovery] + || updatable -- Need to push update frame + || gopt Opt_SccProfilingOn dflags + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) ToDo: do we need this even for + -- top-level thunks? If not, + -- isNotTopLevel subsumes this + +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk + = True + +nodeMustPointToIt _ (LFCon _) = True + + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. + +nodeMustPointToIt _ (LFUnknown _) = True +nodeMustPointToIt _ LFUnLifted = False +nodeMustPointToIt _ LFLetNoEscape = False + +{- Note [GC recovery] +~~~~~~~~~~~~~~~~~~~~~ +If we a have a local let-binding (function or thunk) + let f = in ... +AND allocates, then the heap-overflow check needs to know how +to re-start the evaluation. It uses the "self" pointer to do this. +So even if there are no free variables in , we still make +nodeMustPointToIt be True for non-top-level bindings. + +Why do any such bindings exist? After all, let-floating should have +floated them out. Well, a clever optimiser might leave one there to +avoid a space leak, deliberately recomputing a thunk. Also (and this +really does happen occasionally) let-floating may make a function f smaller +so it can be inlined, so now (f True) may generate a local no-fv closure. +This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind +in TcGenDeriv.) -} + +----------------------------------------------------------------------------- +-- getCallMethod +----------------------------------------------------------------------------- + +{- The entry conventions depend on the type of closure being entered, +whether or not it has free variables, and whether we're running +sequentially or in parallel. + +Closure Node Argument Enter +Characteristics Par Req'd Passing Via +--------------------------------------------------------------------------- +Unknown & no & yes & stack & node +Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) +0 arg, no fvs \r,\s & no & no & n/a & direct entry +0 arg, no fvs \u & no & yes & n/a & node +0 arg, fvs \r,\s,selector & no & yes & n/a & node +0 arg, fvs \r,\s & no & yes & n/a & direct entry +0 arg, fvs \u & no & yes & n/a & node +Unknown & yes & yes & stack & node +Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & yes & yes & registers & node +0 arg, fvs \r,\s,selector & yes & yes & n/a & node +0 arg, no fvs \r,\s & yes & no & n/a & direct entry +0 arg, no fvs \u & yes & yes & n/a & node +0 arg, fvs \r,\s & yes & yes & n/a & node +0 arg, fvs \u & yes & yes & n/a & node + +When black-holing, single-entry closures could also be entered via node +(rather than directly) to catch double-entry. -} + +data CallMethod + = EnterIt -- No args, not a function + + | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop + + | ReturnIt -- It's a value (function, unboxed value, + -- or constructor), so just return it. + + | SlowCall -- Unknown fun, or known fun with + -- too few args. + + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + RepArity -- Its arity + +getCallMethod :: DynFlags + -> Name -- Function being applied + -> Id -- Function Id used to chech if it can refer to + -- CAF's and whether the function is tail-calling + -- itself + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -> CgLoc -- Passed in from cgIdApp so that we can + -- handle let-no-escape bindings and self-recursive + -- tail calls using the same data constructor, + -- JumpToIt. This saves us one case branch in + -- cgIdApp + -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? + -> CallMethod + +getCallMethod dflags _ id _ n_args _cg_loc (Just (self_loop_id, block_id, args)) + | gopt Opt_Loopification dflags, id == self_loop_id, n_args == length args + -- If these patterns match then we know that: + -- * loopification optimisation is turned on + -- * function is performing a self-recursive call in a tail position + -- * number of parameters of the function matches functions arity. + -- See Note [Self-recursive tail calls] in StgCmmExpr for more details + = JumpToIt block_id args + +getCallMethod dflags _name _ lf_info _n_args _cg_loc _self_loop_info + | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags + = -- If we're parallel, then we must always enter via node. + -- The reason is that the closure may have been + -- fetched since we allocated it. + EnterIt + +getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _cg_loc + _self_loop_info + | n_args == 0 = ASSERT( arity /= 0 ) + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args + | otherwise = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity + +getCallMethod _ _name _ LFUnLifted n_args _cg_loc _self_loop_info + = ASSERT( n_args == 0 ) ReturnIt + +getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info + = ASSERT( n_args == 0 ) ReturnIt + +getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) + n_args _cg_loc _self_loop_info + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] + + -- Since is_fun is False, we are *definitely* looking at a data value + | updatable || gopt Opt_Ticky dflags -- to catch double entry + {- OLD: || opt_SMP + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} + = EnterIt + + -- even a non-updatable selector thunk can be updated by the garbage + -- collector, so we must enter it. (#8817) + | SelectorThunk{} <- std_form_info + = EnterIt + + -- We used to have ASSERT( n_args == 0 ), but actually it is + -- possible for the optimiser to generate + -- let bot :: Int = error Int "urk" + -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 + -- This happens as a result of the case-of-error transformation + -- So the right thing to do is just to enter the thing + + | otherwise -- Jump direct to code for single-entry thunks + = ASSERT( n_args == 0 ) + DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info + updatable) 0 + +getCallMethod _ _name _ (LFUnknown True) _n_arg _cg_locs _self_loop_info + = SlowCall -- might be a function + +getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info + = ASSERT2( n_args == 0, ppr name <+> ppr n_args ) + EnterIt -- Not a function + +getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) + _self_loop_info + = JumpToIt blk_id lne_regs + +getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" + +----------------------------------------------------------------------------- +-- staticClosureRequired +----------------------------------------------------------------------------- + +{- staticClosureRequired is never called (hence commented out) + + SimonMar writes (Sept 07) It's an optimisation we used to apply at + one time, I believe, but it got lost probably in the rewrite of + the RTS/code generator. I left that code there to remind me to + look into whether it was worth doing sometime + +{- Avoiding generating entries and info tables + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, for every function we generate all of the following, +just in case. But they aren't always all needed, as noted below: + +[NB1: all of this applies only to *functions*. Thunks always +have closure, info table, and entry code.] + +[NB2: All are needed if the function is *exported*, just to play safe.] + +* Fast-entry code ALWAYS NEEDED + +* Slow-entry code + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) we're in the parallel world and the function has free vars + [Reason: in parallel world, we always enter functions + with free vars via the closure.] + +* The function closure + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie not top level) + + Why case (a) here? Because if the arg-satis check fails, + UpdatePAP stuffs a pointer to the function closure in the PAP. + [Could be changed; UpdatePAP could stuff in a code ptr instead, + but doesn't seem worth it.] + + [NB: these conditions imply that we might need the closure + without the slow-entry code. Here's how. + + f x y = let g w = ...x..y..w... + in + ...(g t)... + + Here we need a closure for g which contains x and y, + but since the calls are all saturated we just jump to the + fast entry point for g, with R1 pointing to the closure for g.] + + +* Standard info table + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie not top level) + + NB. In the sequential world, (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + [NB In the parallel world (c) is needed regardless because + we enter functions with free vars via the closure.] + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. +-} + +staticClosureRequired + :: Name + -> StgBinderInfo + -> LambdaFormInfo + -> Bool +staticClosureRequired binder bndr_info + (LFReEntrant top_level _ _ _) -- It's a function + = ASSERT( isTopLevel top_level ) + -- Assumption: it's a top-level, no-free-var binding + not (satCallsOnly bndr_info) + +staticClosureRequired binder other_binder_info other_lf_info = True +-} + +----------------------------------------------------------------------------- +-- Data types for closure information +----------------------------------------------------------------------------- + + +{- ClosureInfo: information about a binding + + We make a ClosureInfo for each let binding (both top level and not), + but not bindings for data constructors: for those we build a CmmInfoTable + directly (see mkDataConInfoTable). + + To a first approximation: + ClosureInfo = (LambdaFormInfo, CmmInfoTable) + + A ClosureInfo has enough information + a) to construct the info table itself, and build other things + related to the binding (e.g. slow entry points for a function) + b) to allocate a closure containing that info pointer (i.e. + it knows the info table label) +-} + +data ClosureInfo + = ClosureInfo { + closureName :: !Name, -- The thing bound to this closure + -- we don't really need this field: it's only used in generating + -- code for ticky and profiling, and we could pass the information + -- around separately, but it doesn't do much harm to keep it here. + + closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon + -- this tells us about what the closure contains: it's right-hand-side. + + -- the rest is just an unpacked CmmInfoTable. + closureInfoLabel :: !CLabel, + closureSMRep :: !SMRep, -- representation used by storage mgr + closureProf :: !ProfilingInfo + } + +-- | Convert from 'ClosureInfo' to 'CmmInfoTable'. +mkCmmInfo :: ClosureInfo -> CmmInfoTable +mkCmmInfo ClosureInfo {..} + = CmmInfoTable { cit_lbl = closureInfoLabel + , cit_rep = closureSMRep + , cit_prof = closureProf + , cit_srt = NoC_SRT } + +-------------------------------------- +-- Building ClosureInfos +-------------------------------------- + +mkClosureInfo :: DynFlags + -> Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words + -> String -- String descriptor + -> ClosureInfo +mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr + = ClosureInfo { closureName = name + , closureLFInfo = lf_info + , closureInfoLabel = info_lbl -- These three fields are + , closureSMRep = sm_rep -- (almost) an info table + , closureProf = prof } -- (we don't have an SRT yet) + where + name = idName id + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) + prof = mkProfilingInfo dflags id val_descr + nonptr_wds = tot_wds - ptr_wds + + info_lbl = mkClosureInfoTableLabel id lf_info + +-------------------------------------- +-- Other functions over ClosureInfo +-------------------------------------- + +-- Eager blackholing is normally disabled, but can be turned on with +-- -feager-blackholing. When it is on, we replace the info pointer of +-- the thunk with stg_EAGER_BLACKHOLE_info on entry. + +-- If we wanted to do eager blackholing with slop filling, +-- we'd need to do it at the *end* of a basic block, otherwise +-- we overwrite the free variables in the thunk that we still +-- need. We have a patch for this from Andy Cheadle, but not +-- incorporated yet. --SDM [6/2004] +-- +-- +-- Previously, eager blackholing was enabled when ticky-ticky +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- is unconditionally disabled. -- krc 1/2007 +-- +-- +-- Static closures are never themselves black-holed. +-- +-- We also never black-hole non-updatable thunks. +-- See Note [Black-holing non-updatable thunks] + +blackHoleOnEntry :: ClosureInfo -> Bool +blackHoleOnEntry cl_info + | isStaticRep (closureSMRep cl_info) + = False -- Never black-hole a static closure + + | otherwise + = case closureLFInfo cl_info of + LFReEntrant _ _ _ _ -> False + LFLetNoEscape -> False + LFThunk _ _no_fvs updatable _ _ -> updatable + _other -> panic "blackHoleOnEntry" -- Should never happen + +{- +Note [Black-holing non-updatable thunks] +========================================= + +We cannot black-hole non-updatable thunks otherwise we run into issues like +Trac #10414. A single-entry (non-updatable) thunk can actually be entered more +than once in a parallel program, if work is duplicated by two threads both +entering the same updatable thunk before the other has blackholed it. So, we +must not eagerly blackhole non-updatable thunks, or the second thread to enter +one will become blocked indefinitely. (They are not blackholed by lazy +blackholing either, since they have no associated update frame.) + +For instance, let's consider the following value (in pseudo-Core, example due to +Reid Barton), + + x = \u [] concat [[1], []] + +with the following definitions, + + concat x = case x of + [] -> [] + (:) x xs -> (++) x (concat xs) + + (++) xs ys = case xs of + [] -> ys + (:) x rest -> (:) x ((++) rest ys) + +Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to +denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@ +to WHNF and calls @(++)@ the heap will contain the following thunks, + + x = 1 : y + y = \u [] (++) [] z + z = \s [] concat [] + +Now that the stage is set, consider the follow evaluations by two racing threads +A and B, + + 1. Both threads enter @y@ before either is able to replace it with an + indirection + + 2. Thread A does the case analysis in @(++)@ and consequently enters @z@, + replacing it with a black-hole + + 3. At some later point thread B does the same case analysis and also attempts + to enter @z@. However, it finds that it has been replaced with a black-hole + so it blocks. + + 4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@ + accordingly. It does *not* update @z@, however, as it is single-entry. This + leaves Thread B blocked forever on a black-hole which will never be + updated. + +To avoid this sort of condition we never black-hole non-updatable thunks. +-} + +isStaticClosure :: ClosureInfo -> Bool +isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) + +closureUpdReqd :: ClosureInfo -> Bool +closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info + +lfUpdatable :: LambdaFormInfo -> Bool +lfUpdatable (LFThunk _ _ upd _ _) = upd +lfUpdatable _ = False + +closureSingleEntry :: ClosureInfo -> Bool +closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd +closureSingleEntry _ = False + +closureReEntrant :: ClosureInfo -> Bool +closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True +closureReEntrant _ = False + +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) +closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info + +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) +lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing + +funTag :: DynFlags -> ClosureInfo -> DynTag +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag dflags lf_info + +isToplevClosure :: ClosureInfo -> Bool +isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) + = case lf_info of + LFReEntrant TopLevel _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + _other -> False + +-------------------------------------- +-- Label generation +-------------------------------------- + +staticClosureLabel :: ClosureInfo -> CLabel +staticClosureLabel = toClosureLbl . closureInfoLabel + +closureSlowEntryLabel :: ClosureInfo -> CLabel +closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel + +closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel +closureLocalEntryLabel dflags + | tablesNextToCode dflags = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel + +mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel id lf_info + = case lf_info of + LFThunk _ _ upd_flag (SelectorThunk offset) _ + -> mkSelectorInfoLabel upd_flag offset + + LFThunk _ _ upd_flag (ApThunk arity) _ + -> mkApInfoTableLabel upd_flag arity + + LFThunk{} -> std_mk_lbl name cafs + LFReEntrant{} -> std_mk_lbl name cafs + _other -> panic "closureInfoTableLabel" + + where + name = idName id + + std_mk_lbl | is_local = mkLocalInfoTableLabel + | otherwise = mkInfoTableLabel + + cafs = idCafInfo id + is_local = isDataConWorkId id + -- Make the _info pointer for the implicit datacon worker + -- binding local. The reason we can do this is that importing + -- code always either uses the _closure or _con_info. By the + -- invariants in CorePrep anything else gets eta expanded. + + +thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +-- thunkEntryLabel is a local help function, not exported. It's used from +-- getCallMethod. +thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag + = enterApLabel dflags upd_flag arity +thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag + = enterSelectorLabel dflags upd_flag offset +thunkEntryLabel dflags thunk_id c _ _ + = enterIdLabel dflags thunk_id c + +enterApLabel :: DynFlags -> Bool -> Arity -> CLabel +enterApLabel dflags is_updatable arity + | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity + | otherwise = mkApEntryLabel is_updatable arity + +enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel +enterSelectorLabel dflags upd_flag offset + | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset + | otherwise = mkSelectorEntryLabel upd_flag offset + +enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel +enterIdLabel dflags id c + | tablesNextToCode dflags = mkInfoTableLabel id c + | otherwise = mkEntryLabel id c + + +-------------------------------------- +-- Profiling +-------------------------------------- + +-- Profiling requires two pieces of information to be determined for +-- each closure's info table --- description and type. + +-- The description is stored directly in the @CClosureInfoTable@ when the +-- info table is built. + +-- The type is determined from the type information stored with the @Id@ +-- in the closure info using @closureTypeDescr@. + +mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo +mkProfilingInfo dflags id val_descr + | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 + where + ty_descr_w8 = stringToWord8s (getTyDescription (idType id)) + val_descr_w8 = stringToWord8s val_descr + +getTyDescription :: Type -> String +getTyDescription ty + = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> + case tau_ty of + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon + ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n + } + where + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n + +-------------------------------------- +-- CmmInfoTable-related things +-------------------------------------- + +mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds + = CmmInfoTable { cit_lbl = info_lbl + , cit_rep = sm_rep + , cit_prof = prof + , cit_srt = NoC_SRT } + where + name = dataConName data_con + + info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs + | otherwise = mkConInfoTableLabel name NoCafRefs + + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type + + cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) + + prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr val_descr + + ty_descr = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con + val_descr = stringToWord8s $ occNameString $ getOccName data_con + +-- We need a black-hole closure info to pass to @allocDynClosure@ when we +-- want to allocate the black hole on entry to a CAF. + +cafBlackHoleInfoTable :: CmmInfoTable +cafBlackHoleInfoTable + = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel + , cit_rep = blackHoleRep + , cit_prof = NoProfilingInfo + , cit_srt = NoC_SRT } + +indStaticInfoTable :: CmmInfoTable +indStaticInfoTable + = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel + , cit_rep = indStaticRep + , cit_prof = NoProfilingInfo + , cit_srt = NoC_SRT } + +staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool +-- A static closure needs a link field to aid the GC when traversing +-- the static closure graph. But it only needs such a field if either +-- a) it has an SRT +-- b) it's a constructor with one or more pointer fields +-- In case (b), the constructor's fields themselves play the role +-- of the SRT. +-- +-- At this point, the cit_srt field has not been calculated (that +-- happens right at the end of the Cmm pipeline), but we do have the +-- VarSet of CAFs that CoreToStg attached, and if that is empty there +-- will definitely not be an SRT. +-- +staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep } + | isConRep smrep = not (isStaticNoCafCon smrep) + | otherwise = has_srt -- needsSRT (cit_srt info_tbl) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs new file mode 100644 index 00000000..edd06484 --- /dev/null +++ b/compiler/codeGen/StgCmmCon.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C--: code generation for constructors +-- +-- This module provides the support code for StgCmm to deal with with +-- constructors on the RHSs of let(rec)s. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmCon ( + cgTopRhsCon, buildDynCon, bindConArgs + ) where + +#include "HsVersions.h" + +import StgSyn +import CoreSyn ( AltCon(..) ) + +import StgCmmMonad +import StgCmmEnv +import StgCmmHeap +import StgCmmLayout +import StgCmmUtils +import StgCmmClosure +import StgCmmProf ( curCCS ) + +import CmmExpr +import CLabel +import MkGraph +import SMRep +import CostCentre +import Module +import DataCon +import DynFlags +import FastString +import Id +import Literal +import PrelInfo +import Outputable +import Platform +import Util + +import Control.Monad +import Data.Char + + + +--------------------------------------------------------------- +-- Top-level constructors +--------------------------------------------------------------- + +cgTopRhsCon :: DynFlags + -> Id -- Name of thing bound to this RHS + -> DataCon -- Id + -> [StgArg] -- Args + -> (CgIdInfo, FCode ()) +cgTopRhsCon dflags id con args = + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + in (id_info, gen_code) + where + name = idName id + caffy = idCafInfo id -- any stgArgHasCafRefs args + closure_label = mkClosureLabel name caffy + + gen_code = + do { this_mod <- getModuleName + ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ + -- Windows DLLs have a problem with static cross-DLL refs. + ASSERT( not (isDllConApp dflags this_mod con args) ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () + + -- LAY IT OUT + ; let + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) + + nonptr_wds = tot_wds - ptr_wds + + -- we're not really going to emit an info table, so having + -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields + -- needs to poke around inside it. + info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds + + get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg + ; return lit } + + ; payload <- mapM get_lit nv_args_w_offsets + -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs + -- NB2: all the amodes should be Lits! + + ; let closure_rep = mkStaticClosureFields + dflags + info_tbl + dontCareCCS -- Because it's static data + caffy -- Has CAF refs + payload + + -- BUILD THE OBJECT + ; emitDataLits closure_label closure_rep + + ; return () } + + +--------------------------------------------------------------- +-- Lay out and allocate non-top-level constructors +--------------------------------------------------------------- + +buildDynCon :: Id -- Name of the thing to which this constr will + -- be bound + -> Bool -- is it genuinely bound to that name, or just for profiling? + -> CostCentreStack -- Where to grab cost centre from; + -- current CCS if currentOrSubsumedCCS + -> DataCon -- The data constructor + -> [StgArg] -- Its args + -> FCode (CgIdInfo, FCode CmmAGraph) + -- Return details about how to find it and initialization code +buildDynCon binder actually_bound cc con args + = do dflags <- getDynFlags + buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args + + +buildDynCon' :: DynFlags + -> Platform + -> Id -> Bool + -> CostCentreStack + -> DataCon + -> [StgArg] + -> FCode (CgIdInfo, FCode CmmAGraph) + +{- We used to pass a boolean indicating whether all the +args were of size zero, so we could use a static +constructor; but I concluded that it just isn't worth it. +Now I/O uses unboxed tuples there just aren't any constructors +with all size-zero args. + +The reason for having a separate argument, rather than looking at +the addr modes of the args is that we may be in a "knot", and +premature looking at the args will cause the compiler to black-hole! +-} + + +-------- buildDynCon': Nullary constructors -------------- +-- First we deal with the case of zero-arity constructors. They +-- will probably be unfolded, so we don't expect to see this case much, +-- if at all, but it does no harm, and sets the scene for characters. +-- +-- In the case of zero-arity constructors, or, more accurately, those +-- which have exclusively size-zero (VoidRep) args, we generate no code +-- at all. + +buildDynCon' dflags _ binder _ _cc con [] + = return (litIdInfo dflags binder (mkConLFInfo con) + (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), + return mkNop) + +-------- buildDynCon': Charlike and Intlike constructors ----------- +{- The following three paragraphs about @Char@-like and @Int@-like +closures are obsolete, but I don't understand the details well enough +to properly word them, sorry. I've changed the treatment of @Char@s to +be analogous to @Int@s: only a subset is preallocated, because @Char@ +has now 31 bits. Only literals are handled here. -- Qrczak + +Now for @Char@-like closures. We generate an assignment of the +address of the closure to a temporary. It would be possible simply to +generate no code, and record the addressing mode in the environment, +but we'd have to be careful if the argument wasn't a constant --- so +for simplicity we just always asssign to a temporary. + +Last special case: @Int@-like closures. We only special-case the +situation in which the argument is a literal in the range +@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can +work with any old argument, but for @Int@-like ones the argument has +to be a literal. Reason: @Char@ like closures have an argument type +which is guaranteed in range. + +Because of this, we use can safely return an addressing mode. + +We don't support this optimisation when compiling into Windows DLLs yet +because they don't support cross package data references well. +-} + +buildDynCon' dflags platform binder _ _cc con [arg] + | maybeIntLikeCon con + , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) + , StgLitArg (MachInt val) <- arg + , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! + , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_INTLIKE") + val_int = fromIntegral val :: Int + offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) + -- INTLIKE closures consist of a header and one word payload + intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW + ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode + , return mkNop) } + +buildDynCon' dflags platform binder _ _cc con [arg] + | maybeCharLikeCon con + , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) + , StgLitArg (MachChar val) <- arg + , let val_int = ord val :: Int + , val_int <= mAX_CHARLIKE dflags + , val_int >= mIN_CHARLIKE dflags + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_CHARLIKE") + offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) + -- CHARLIKE closures consist of a header and one word payload + charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW + ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode + , return mkNop) } + +-------- buildDynCon': the general case ----------- +buildDynCon' dflags _ binder actually_bound ccs con args + = do { (id_info, reg) <- rhsIdInfo binder lf_info + ; return (id_info, gen_code reg) + } + where + lf_info = mkConLFInfo con + + gen_code reg + = do { let (tot_wds, ptr_wds, args_w_offsets) + = mkVirtConstrOffsets dflags (addArgReps args) + -- No void args in args_w_offsets + nonptr_wds = tot_wds - ptr_wds + info_tbl = mkDataConInfoTable dflags con False + ptr_wds nonptr_wds + ; let ticky_name | actually_bound = Just binder + | otherwise = Nothing + + ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info + use_cc blame_cc args_w_offsets + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + where + use_cc -- cost-centre to stick in the object + | isCurrentCCS ccs = curCCS + | otherwise = panic "buildDynCon: non-current CCS not implemented" + + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + + +--------------------------------------------------------------- +-- Binding constructor arguments +--------------------------------------------------------------- + +bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg] +-- bindConArgs is called from cgAlt of a case +-- (bindConArgs con args) augments the environment with bindings for the +-- binders args, assuming that we have just returned from a 'case' which +-- found a con +bindConArgs (DataAlt con) base args + = ASSERT(not (isUnboxedTupleCon con)) + do dflags <- getDynFlags + let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) + tag = tagForCon dflags con + + -- The binding below forces the masking out of the tag bits + -- when accessing the constructor field. + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg + bind_arg (arg, offset) + = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag + bindArgToReg arg + mapM bind_arg args_w_offsets + +bindConArgs _other_con _base args + = ASSERT( null args ) return [] + diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs new file mode 100644 index 00000000..4127b674 --- /dev/null +++ b/compiler/codeGen/StgCmmEnv.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: the binding environment +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +module StgCmmEnv ( + CgIdInfo, + + litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, + idInfoToAmode, + + NonVoid(..), unsafe_stripNV, nonVoidIds, + + addBindC, addBindsC, + + bindArgsToRegs, bindToReg, rebindToReg, + bindArgToReg, idToReg, + getArgAmode, getNonVoidArgAmodes, + getCgIdInfo, + maybeLetNoEscape, + ) where + +#include "HsVersions.h" + +import TyCon +import StgCmmMonad +import StgCmmUtils +import StgCmmClosure + +import CLabel + +import DynFlags +import MkGraph +import BlockId +import CmmExpr +import CmmUtils +import FastString +import Id +import VarEnv +import Control.Monad +import Name +import StgSyn +import Outputable + +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) + +-- Use with care; if used inappropriately, it could break invariants. +unsafe_stripNV :: NonVoid a -> a +unsafe_stripNV (NonVoid a) = a + +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] + +------------------------------------- +-- Manipulating CgIdInfo +------------------------------------- + +mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo id lf expr + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc expr } + +litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo dflags id lf lit + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) } + where + tag = lfDynTag dflags lf + +lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo dflags id regs + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) } + where + lf = mkLFLetNoEscape + blk_id = mkBlockId (idUnique id) + + +rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) +rhsIdInfo id lf_info + = do dflags <- getDynFlags + reg <- newTemp (gcWord dflags) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) + +mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit dflags reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) + +idInfoToAmode :: CgIdInfo -> CmmExpr +-- Returns a CmmExpr for the *tagged* pointer +idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e +idInfoToAmode cg_info + = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc + +addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr +-- A tag adds a byte offset to the pointer +addDynTag dflags expr tag = cmmOffsetB dflags expr tag + +maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) +maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) +maybeLetNoEscape _other = Nothing + + + +--------------------------------------------------------- +-- The binding environment +-- +-- There are three basic routines, for adding (addBindC), +-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. +--------------------------------------------------------- + +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do + binds <- getBinds + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind + +addBindsC :: [CgIdInfo] -> FCode () +addBindsC new_bindings = do + binds <- getBinds + let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info) + binds + new_bindings + setBinds new_binds + +getCgIdInfo :: Id -> FCode CgIdInfo +getCgIdInfo id + = do { dflags <- getDynFlags + ; local_binds <- getBinds -- Try local bindings first + ; case lookupVarEnv local_binds id of { + Just info -> return info ; + Nothing -> do { + + -- Should be imported; make up a CgIdInfo for it + let name = idName id + ; if isExternalName name then + let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) + in return (litIdInfo dflags id (mkLFImported id) ext_lbl) + else + cgLookupPanic id -- Bug + }}} + +cgLookupPanic :: Id -> FCode a +cgLookupPanic id + = do local_binds <- getBinds + pprPanic "StgCmmEnv: variable not found" + (vcat [ppr id, + ptext (sLit "local binds for:"), + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] + ]) + + +-------------------- +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = + do { info <- getCgIdInfo var; return (idInfoToAmode info) } +getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit + +getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] +-- NB: Filters out void args, +-- so the result list may be shorter than the argument list +getNonVoidArgAmodes [] = return [] +getNonVoidArgAmodes (arg:args) + | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args + | otherwise = do { amode <- getArgAmode (NonVoid arg) + ; amodes <- getNonVoidArgAmodes args + ; return ( amode : amodes ) } + +------------------------------------------------------------------------ +-- Interface functions for binding and re-binding names +------------------------------------------------------------------------ + +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg +-- Bind an Id to a fresh LocalReg +bindToReg nvid@(NonVoid id) lf_info + = do dflags <- getDynFlags + let reg = idToReg dflags nvid + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + return reg + +rebindToReg :: NonVoid Id -> FCode LocalReg +-- Like bindToReg, but the Id is already in scope, so +-- get its LF info from the envt +rebindToReg nvid@(NonVoid id) + = do { info <- getCgIdInfo id + ; bindToReg nvid (cg_lf info) } + +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) + +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] +bindArgsToRegs args = mapM bindArgToReg args + +idToReg :: DynFlags -> NonVoid Id -> LocalReg +-- Make a register from an Id, typically a function argument, +-- free variable, or case binder +-- +-- We re-use the Unique from the Id to make it easier to see what is going on +-- +-- By now the Ids should be uniquely named; else one would worry +-- about accidental collision +idToReg dflags (NonVoid id) + = LocalReg (idUnique id) + (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) + _ -> primRepCmmType dflags (idPrimRep id)) + + diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs new file mode 100644 index 00000000..57ac6261 --- /dev/null +++ b/compiler/codeGen/StgCmmExpr.hs @@ -0,0 +1,902 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: expressions +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmExpr ( cgExpr ) where + +#define FAST_STRING_NOT_NEEDED +#include "HsVersions.h" + +import {-# SOURCE #-} StgCmmBind ( cgBind ) + +import StgCmmMonad +import StgCmmHeap +import StgCmmEnv +import StgCmmCon +import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC) +import StgCmmLayout +import StgCmmPrim +import StgCmmHpc +import StgCmmTicky +import StgCmmUtils +import StgCmmClosure + +import StgSyn + +import MkGraph +import BlockId +import Cmm +import CmmInfo +import CoreSyn +import DataCon +import ForeignCall +import Id +import PrimOp +import TyCon +import Type +import CostCentre ( CostCentreStack, currentCCS ) +import Maybes +import Util +import FastString +import Outputable + +import Control.Monad (when,void) +import Control.Arrow (first) + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +------------------------------------------------------------------------ +-- cgExpr: the main function +------------------------------------------------------------------------ + +cgExpr :: StgExpr -> FCode ReturnKind + +cgExpr (StgApp fun args) = cgIdApp fun args + +{- seq# a s ==> a -} +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = + cgIdApp a [] + +cgExpr (StgOpApp op args ty) = cgOpApp op args ty +cgExpr (StgConApp con args) = cgConApp con args +cgExpr (StgTick t e) = cgTick t >> cgExpr e +cgExpr (StgLit lit) = do cmm_lit <- cgLit lit + emitReturn [CmmLit cmm_lit] + +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } +cgExpr (StgLetNoEscape _ _ binds expr) = + do { u <- newUnique + ; let join_id = mkBlockId u + ; cgLneBinds join_id binds + ; r <- cgExpr expr + ; emitLabel join_id + ; return r } + +cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) = + cgCase expr bndr alt_type alts + +cgExpr (StgLam {}) = panic "cgExpr: StgLam" + +------------------------------------------------------------------------ +-- Let no escape +------------------------------------------------------------------------ + +{- Generating code for a let-no-escape binding, aka join point is very +very similar to what we do for a case expression. The duality is +between + let-no-escape x = b + in e +and + case e of ... -> b + +That is, the RHS of 'x' (ie 'b') will execute *later*, just like +the alternative of the case; it needs to be compiled in an environment +in which all volatile bindings are forgotten, and the free vars are +bound only to stable things like stack locations.. The 'e' part will +execute *next*, just like the scrutinee of a case. -} + +------------------------- +cgLneBinds :: BlockId -> StgBinding -> FCode () +cgLneBinds join_id (StgNonRec bndr rhs) + = do { local_cc <- saveCurrentCostCentre + -- See Note [Saving the current cost centre] + ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs + ; fcode + ; addBindC info } + +cgLneBinds join_id (StgRec pairs) + = do { local_cc <- saveCurrentCostCentre + ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs + ; let (infos, fcodes) = unzip r + ; addBindsC infos + ; sequence_ fcodes + } + +------------------------- +cgLetNoEscapeRhs + :: BlockId -- join point for successor of let-no-escape + -> Maybe LocalReg -- Saved cost centre + -> Id + -> StgRhs + -> FCode (CgIdInfo, FCode ()) + +cgLetNoEscapeRhs join_id local_cc bndr rhs = + do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs + ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info + ; let code = do { (_, body) <- getCodeScoped rhs_code + ; emitOutOfLine bid (first (<*> mkBranch join_id) body) } + ; return (info, code) + } + +cgLetNoEscapeRhsBody + :: Maybe LocalReg -- Saved cost centre + -> Id + -> StgRhs + -> FCode (CgIdInfo, FCode ()) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) + = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) + = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) + -- For a constructor RHS we want to generate a single chunk of + -- code which can be jumped to from many places, which will + -- return the constructor. It's easy; just behave as if it + -- was an StgRhsClosure with a ConApp inside! + +------------------------- +cgLetNoEscapeClosure + :: Id -- binder + -> Maybe LocalReg -- Slot for saved current cost centre + -> CostCentreStack -- XXX: *** NOT USED *** why not? + -> [NonVoid Id] -- Args (as in \ args -> body) + -> StgExpr -- Body (as in above) + -> FCode (CgIdInfo, FCode ()) + +cgLetNoEscapeClosure bndr cc_slot _unused_cc args body + = do dflags <- getDynFlags + return ( lneIdInfo dflags bndr args + , code ) + where + code = forkLneBody $ do { + ; withNewTickyCounterLNE (idName bndr) args $ do + ; restoreCurrentCostCentre cc_slot + ; arg_regs <- bindArgsToRegs args + ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } + + +------------------------------------------------------------------------ +-- Case expressions +------------------------------------------------------------------------ + +{- Note [Compiling case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is quite interesting to decide whether to put a heap-check at the +start of each alternative. Of course we certainly have to do so if +the case forces an evaluation, or if there is a primitive op which can +trigger GC. + +A more interesting situation is this (a Plan-B situation) + + !P!; + ...P... + case x# of + 0# -> !Q!; ...Q... + default -> !R!; ...R... + +where !x! indicates a possible heap-check point. The heap checks +in the alternatives *can* be omitted, in which case the topmost +heapcheck will take their worst case into account. + +In favour of omitting !Q!, !R!: + + - *May* save a heap overflow test, + if ...P... allocates anything. + + - We can use relative addressing from a single Hp to + get at all the closures so allocated. + + - No need to save volatile vars etc across heap checks + in !Q!, !R! + +Against omitting !Q!, !R! + + - May put a heap-check into the inner loop. Suppose + the main loop is P -> R -> P -> R... + Q is the loop exit, and only it does allocation. + This only hurts us if P does no allocation. If P allocates, + then there is a heap check in the inner loop anyway. + + - May do more allocation than reqd. This sometimes bites us + badly. For example, nfib (ha!) allocates about 30\% more space if the + worst-casing is done, because many many calls to nfib are leaf calls + which don't need to allocate anything. + + We can un-allocate, but that costs an instruction + +Neither problem hurts us if there is only one alternative. + +Suppose the inner loop is P->R->P->R etc. Then here is +how many heap checks we get in the *inner loop* under various +conditions + + Alooc Heap check in branches (!Q!, !R!)? + P Q R yes no (absorb to !P!) +-------------------------------------- + n n n 0 0 + n y n 0 1 + n . y 1 1 + y . y 2 1 + y . n 1 1 + +Best choices: absorb heap checks from Q and R into !P! iff + a) P itself does some allocation +or + b) P does allocation, or there is exactly one alternative + +We adopt (b) because that is more likely to put the heap check at the +entry to a function, when not many things are live. After a bunch of +single-branch cases, we may have lots of things live + +Hence: two basic plans for + + case e of r { alts } + +------ Plan A: the general case --------- + + ...save current cost centre... + + ...code for e, + with sequel (SetLocals r) + + ...restore current cost centre... + ...code for alts... + ...alts do their own heap checks + +------ Plan B: special case when --------- + (i) e does not allocate or call GC + (ii) either upstream code performs allocation + or there is just one alternative + + Then heap allocation in the (single) case branch + is absorbed by the upstream check. + Very common example: primops on unboxed values + + ...code for e, + with sequel (SetLocals r)... + + ...code for alts... + ...no heap check... +-} + + + +------------------------------------- +data GcPlan + = GcInAlts -- Put a GC check at the start the case alternatives, + [LocalReg] -- which binds these registers + | NoGcInAlts -- The scrutinee is a primitive value, or a call to a + -- primitive op which does no GC. Absorb the allocation + -- of the case alternative(s) into the upstream check + +------------------------------------- +cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ReturnKind + +cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts + | isEnumerationTyCon tycon -- Note [case on bool] + = do { tag_expr <- do_enum_primop op args + + -- If the binder is not dead, convert the tag to a constructor + -- and assign it. + ; when (not (isDeadBinder bndr)) $ do + { dflags <- getDynFlags + ; tmp_reg <- bindArgToReg (NonVoid bndr) + ; emitAssign (CmmLocal tmp_reg) + (tagToClosure dflags tycon tag_expr) } + + ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly) + (NonVoid bndr) alts + ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1) + ; return AssignedDirectly + } + where + do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr + do_enum_primop TagToEnumOp [arg] -- No code! + = getArgAmode (NonVoid arg) + do_enum_primop primop args + = do dflags <- getDynFlags + tmp <- newTemp (bWord dflags) + cgPrimOp [tmp] primop args + return (CmmReg (CmmLocal tmp)) + +{- +Note [case on bool] +~~~~~~~~~~~~~~~~~~~ +This special case handles code like + + case a <# b of + True -> + False -> + +--> case tagToEnum# (a <$# b) of + True -> .. ; False -> ... + +--> case (a <$# b) of r -> + case tagToEnum# r of + True -> .. ; False -> ... + +If we let the ordinary case code handle it, we'll get something like + + tmp1 = a < b + tmp2 = Bool_closure_tbl[tmp1] + if (tmp2 & 7 != 0) then ... // normal tagged case + +but this junk won't optimise away. What we really want is just an +inline comparison: + + if (a < b) then ... + +So we add a special case to generate + + tmp1 = a < b + if (tmp1 == 0) then ... + +and later optimisations will further improve this. + +Now that #6135 has been resolved it should be possible to remove that +special case. The idea behind this special case and pre-6135 implementation +of Bool-returning primops was that tagToEnum# was added implicitly in the +codegen and then optimized away. Now the call to tagToEnum# is explicit +in the source code, which allows to optimize it away at the earlier stages +of compilation (i.e. at the Core level). + +Note [Scrutinising VoidRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this STG code: + f = \[s : State# RealWorld] -> + case s of _ -> blah +This is very odd. Why are we scrutinising a state token? But it +can arise with bizarre NOINLINE pragmas (Trac #9964) + crash :: IO () + crash = IO (\s -> let {-# NOINLINE s' #-} + s' = s + in (# s', () #)) + +Now the trouble is that 's' has VoidRep, and we do not bind void +arguments in the environment; they don't live anywhere. See the +calls to nonVoidIds in various places. So we must not look up +'s' in the environment. Instead, just evaluate the RHS! Simple. + +Note [Dodgy unsafeCoerce 1] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case (x :: MutVar# Int) |> co of (y :: HValue) + DEFAULT -> ... +We want to gnerate an assignment + y := x +We want to allow this assignment to be generated in the case when the +types are compatible, because this allows some slightly-dodgy but +occasionally-useful casts to be used, such as in RtClosureInspect +where we cast an HValue to a MutVar# so we can print out the contents +of the MutVar#. If instead we generate code that enters the HValue, +then we'll get a runtime panic, because the HValue really is a +MutVar#. The types are compatible though, so we can just generate an +assignment. + +Note [Dodgy unsafeCoerce 2] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [ticket #3132]: we might be looking at a case of a lifted Id that +was cast to an unlifted type. The Id will always be bottom, but we +don't want the code generator to fall over here. If we just emit an +assignment here, the assignment will be type-incorrect Cmm. Hence, we +emit the usual enter/return code, (and because bottom must be +untagged, it will be entered and the program will crash). The Sequel +is a type-correct assignment, albeit bogus. The (dead) continuation +loops; it would be better to invoke some kind of panic function here. +-} + +cgCase (StgApp v []) _ (PrimAlt _) alts + | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + , [(DEFAULT, _, _, rhs)] <- alts + = cgExpr rhs + +cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts + | isUnLiftedType (idType v) -- Note [Dodgy unsafeCoerce 1] + || reps_compatible + = -- assignment suffices for unlifted types + do { dflags <- getDynFlags + ; when (not reps_compatible) $ + panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + ; v_info <- getCgIdInfo v + ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) + ; _ <- bindArgsToRegs [NonVoid bndr] + ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } + where + reps_compatible = idPrimRep v == idPrimRep bndr + +cgCase scrut@(StgApp v []) _ (PrimAlt _) _ + = -- See Note [Dodgy unsafeCoerce 2] + do { dflags <- getDynFlags + ; mb_cc <- maybeSaveCostCentre True + ; _ <- withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc + ; emitComment $ mkFastString "should be unreachable code" + ; l <- newLabelC + ; emitLabel l + ; emit (mkBranch l) + ; return AssignedDirectly + } + +{- Note [Handle seq#] +~~~~~~~~~~~~~~~~~~~~~ +case seq# a s of v + (# s', a' #) -> e + +==> + +case a of v + (# s', a' #) -> e + +(taking advantage of the fact that the return convention for (# State#, a #) +is the same as the return convention for just 'a') +-} + +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts + = -- Note [Handle seq#] + -- Use the same return convention as vanilla 'a'. + cgCase (StgApp a []) bndr alt_type alts + +cgCase scrut bndr alt_type alts + = -- the general case + do { dflags <- getDynFlags + ; up_hp_usg <- getVirtHp -- Upstream heap usage + ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts + alt_regs = map (idToReg dflags) ret_bndrs + ; simple_scrut <- isSimpleScrut scrut alt_type + ; let do_gc | not simple_scrut = True + | isSingleton alts = False + | up_hp_usg > 0 = False + | otherwise = True + -- cf Note [Compiling case expressions] + gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts + + ; mb_cc <- maybeSaveCostCentre simple_scrut + + ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} + ; ret_kind <- withSequel sequel (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc + ; _ <- bindArgsToRegs ret_bndrs + ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts + } + + +{- +Note [scrut sequel] + +The job of the scrutinee is to assign its value(s) to alt_regs. +Additionally, if we plan to do a heap-check in the alternatives (see +Note [Compiling case expressions]), then we *must* retreat Hp to +recover any unused heap before passing control to the sequel. If we +don't do this, then any unused heap will become slop because the heap +check will reset the heap usage. Slop in the heap breaks LDV profiling +(+RTS -hb) which needs to do a linear sweep through the nursery. + + +Note [Inlining out-of-line primops and heap checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If shouldInlinePrimOp returns True when called from StgCmmExpr for the +purpose of heap check placement, we *must* inline the primop later in +StgCmmPrim. If we don't things will go wrong. +-} + +----------------- +maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) +maybeSaveCostCentre simple_scrut + | simple_scrut = return Nothing + | otherwise = saveCurrentCostCentre + + +----------------- +isSimpleScrut :: StgExpr -> AltType -> FCode Bool +-- Simple scrutinee, does not block or allocate; hence safe to amalgamate +-- heap usage from alternatives into the stuff before the case +-- NB: if you get this wrong, and claim that the expression doesn't allocate +-- when it does, you'll deeply mess up allocation +isSimpleScrut (StgOpApp op args _) _ = isSimpleOp op args +isSimpleScrut (StgLit _) _ = return True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... } +isSimpleScrut _ _ = return False + +isSimpleOp :: StgOp -> [StgArg] -> FCode Bool +-- True iff the op cannot block or allocate +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) +isSimpleOp (StgPrimOp op) stg_args = do + arg_exprs <- getNonVoidArgAmodes stg_args + dflags <- getDynFlags + -- See Note [Inlining out-of-line primops and heap checks] + return $! isJust $ shouldInlinePrimOp dflags op arg_exprs +isSimpleOp (StgPrimCallOp _) _ = return False + +----------------- +chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] +-- These are the binders of a case that are assigned +-- by the evaluation of the scrutinee +-- Only non-void ones come back +chooseReturnBndrs bndr (PrimAlt _) _alts + = nonVoidIds [bndr] + +chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)] + = nonVoidIds ids -- 'bndr' is not assigned! + +chooseReturnBndrs bndr (AlgAlt _) _alts + = nonVoidIds [bndr] -- Only 'bndr' is assigned + +chooseReturnBndrs bndr PolyAlt _alts + = nonVoidIds [bndr] -- Only 'bndr' is assigned + +chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" + -- UbxTupALt has only one alternative + +------------------------------------- +cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [StgAlt] + -> FCode ReturnKind +-- At this point the result of the case are in the binders +cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)] + = maybeAltHeapCheck gc_plan (cgExpr rhs) + +cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)] + = maybeAltHeapCheck gc_plan (cgExpr rhs) + -- Here bndrs are *already* in scope, so don't rebind them + +cgAlts gc_plan bndr (PrimAlt _) alts + = do { dflags <- getDynFlags + + ; tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let bndr_reg = CmmLocal (idToReg dflags bndr) + (DEFAULT,deflt) = head tagged_cmms + -- PrimAlts always have a DEFAULT case + -- and it always comes first + + tagged_cmms' = [(lit,code) + | (LitAlt lit, code) <- tagged_cmms] + ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt + ; return AssignedDirectly } + +cgAlts gc_plan bndr (AlgAlt tycon) alts + = do { dflags <- getDynFlags + + ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts + + ; let fam_sz = tyConFamilySize tycon + bndr_reg = CmmLocal (idToReg dflags bndr) + + -- Is the constructor tag in the node reg? + ; if isSmallFamily dflags fam_sz + then do + let -- Yes, bndr_reg has constr. tag in ls bits + tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) + branches' = [(tag+1,branch) | (tag,branch) <- branches] + emitSwitch tag_expr branches' mb_deflt 1 fam_sz + return AssignedDirectly + + else -- No, get tag from info table + do dflags <- getDynFlags + let -- Note that ptr _always_ has tag 1 + -- when the family size is big enough + untagged_ptr = cmmRegOffB bndr_reg (-1) + tag_expr = getConstrTag dflags (untagged_ptr) + emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) + return AssignedDirectly } + +cgAlts _ _ _ _ = panic "cgAlts" + -- UbxTupAlt and PolyAlt have only one alternative + + +-- Note [alg-alt heap check] +-- +-- In an algebraic case with more than one alternative, we will have +-- code like +-- +-- L0: +-- x = R1 +-- goto L1 +-- L1: +-- if (x & 7 >= 2) then goto L2 else goto L3 +-- L2: +-- Hp = Hp + 16 +-- if (Hp > HpLim) then goto L4 +-- ... +-- L4: +-- call gc() returns to L5 +-- L5: +-- x = R1 +-- goto L1 + +------------------- +cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] + -> FCode ( Maybe CmmAGraphScoped + , [(ConTagZ, CmmAGraphScoped)] ) +cgAlgAltRhss gc_plan bndr alts + = do { tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let { mb_deflt = case tagged_cmms of + ((DEFAULT,rhs) : _) -> Just rhs + _other -> Nothing + -- DEFAULT is always first, if present + + ; branches = [ (dataConTagZ con, cmm) + | (DataAlt con, cmm) <- tagged_cmms ] + } + + ; return (mb_deflt, branches) + } + + +------------------- +cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] + -> FCode [(AltCon, CmmAGraphScoped)] +cgAltRhss gc_plan bndr alts = do + dflags <- getDynFlags + let + base_reg = idToReg dflags bndr + cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped) + cg_alt (con, bndrs, _uses, rhs) + = getCodeScoped $ + maybeAltHeapCheck gc_plan $ + do { _ <- bindConArgs con base_reg bndrs + ; _ <- cgExpr rhs + ; return con } + forkAlts (map cg_alt alts) + +maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a +maybeAltHeapCheck (NoGcInAlts,_) code = code +maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code = + altHeapCheck regs code +maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code = + altHeapCheckReturnsTo regs lret off code + +----------------------------------------------------------------------------- +-- Tail calls +----------------------------------------------------------------------------- + +cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind +cgConApp con stg_args + | isUnboxedTupleCon con -- Unboxed tuple: assign and return + = do { arg_exprs <- getNonVoidArgAmodes stg_args + ; tickyUnboxedTupleReturn (length arg_exprs) + ; emitReturn arg_exprs } + + | otherwise -- Boxed constructors; allocate and return + = ASSERT2( stg_args `lengthIs` dataConRepRepArity con, ppr con <+> ppr stg_args ) + do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False + currentCCS con stg_args + -- The first "con" says that the name bound to this + -- closure is is "con", which is a bit of a fudge, but + -- it only affects profiling (hence the False) + + ; emit =<< fcode_init + ; emitReturn [idInfoToAmode idinfo] } + +cgIdApp :: Id -> [StgArg] -> FCode ReturnKind +cgIdApp fun_id [] | isVoidTy (idType fun_id) = emitReturn [] +cgIdApp fun_id args = do + dflags <- getDynFlags + fun_info <- getCgIdInfo fun_id + self_loop_info <- getSelfLoop + let cg_fun_id = cg_id fun_info + -- NB: use (cg_id fun_info) instead of fun_id, because + -- the former may be externalised for -split-objs. + -- See Note [Externalise when splitting] in StgCmmMonad + + fun_arg = StgVarArg cg_fun_id + fun_name = idName cg_fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + node_points dflags = nodeMustPointToIt dflags lf_info + case (getCallMethod dflags fun_name cg_fun_id lf_info (length args) (cg_loc fun_info) self_loop_info) of + + -- A value in WHNF, so we can just return it. + ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? + + EnterIt -> ASSERT( null args ) -- Discarding arguments + emitEnter fun + + SlowCall -> do -- A slow function call via the RTS apply routines + { tickySlowCall lf_info args + ; emitComment $ mkFastString "slowCall" + ; slowCall fun args } + + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity -> do + { tickyDirectCall arity args + ; if node_points dflags + then directCall NativeNodeCall lbl arity (fun_arg:args) + else directCall NativeDirectCall lbl arity args } + + -- Let-no-escape call or self-recursive tail-call + JumpToIt blk_id lne_regs -> do + { adjustHpBackwards -- always do this before a tail-call + ; cmm_args <- getNonVoidArgAmodes args + ; emitMultiAssign lne_regs cmm_args + ; emit (mkBranch blk_id) + ; return AssignedDirectly } + +-- Note [Self-recursive tail calls] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Self-recursive tail calls can be optimized into a local jump in the same +-- way as let-no-escape bindings (see Note [What is a non-escaping let] in +-- stgSyn/CoreToStg.lhs). Consider this: +-- +-- foo.info: +-- a = R1 // calling convention +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: R1 = x +-- R2 = y +-- call foo(R1,R2) +-- +-- Instead of putting x and y into registers (or other locations required by the +-- calling convention) and performing a call we can put them into local +-- variables a and b and perform jump to L1: +-- +-- foo.info: +-- a = R1 +-- b = R2 +-- goto L1 +-- L1: ... +-- ... +-- ... +-- L2: a = x +-- b = y +-- goto L1 +-- +-- This can be done only when function is calling itself in a tail position +-- and only if the call passes number of parameters equal to function's arity. +-- Note that this cannot be performed if a function calls itself with a +-- continuation. +-- +-- This in fact implements optimization known as "loopification". It was +-- described in "Low-level code optimizations in the Glasgow Haskell Compiler" +-- by Krzysztof Woś, though we use different approach. Krzysztof performed his +-- optimization at the Cmm level, whereas we perform ours during code generation +-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is +-- generated in the first place. +-- +-- Implementation is spread across a couple of places in the code: +-- +-- * FCode monad stores additional information in its reader environment +-- (cgd_self_loop field). This information tells us which function can +-- tail call itself in an optimized way (it is the function currently +-- being compiled), what is the label of a loop header (L1 in example above) +-- and information about local registers in which we should arguments +-- before making a call (this would be a and b in example above). +-- +-- * Whenever we are compiling a function, we set that information to reflect +-- the fact that function currently being compiled can be jumped to, instead +-- of called. This is done in closureCodyBody in StgCmmBind. +-- +-- * We also have to emit a label to which we will be jumping. We make sure +-- that the label is placed after a stack check but before the heap +-- check. The reason is that making a recursive tail-call does not increase +-- the stack so we only need to check once. But it may grow the heap, so we +-- have to repeat the heap check in every self-call. This is done in +-- do_checks in StgCmmHeap. +-- +-- * When we begin compilation of another closure we remove the additional +-- information from the environment. This is done by forkClosureBody +-- in StgCmmMonad. Other functions that duplicate the environment - +-- forkLneBody, forkAlts, codeOnly - duplicate that information. In other +-- words, we only need to clean the environment of the self-loop information +-- when compiling right hand side of a closure (binding). +-- +-- * When compiling a call (cgIdApp) we use getCallMethod to decide what kind +-- of call will be generated. getCallMethod decides to generate a self +-- recursive tail call when (a) environment stores information about +-- possible self tail-call; (b) that tail call is to a function currently +-- being compiled; (c) number of passed arguments is equal to function's +-- arity. (d) loopification is turned on via -floopification command-line +-- option. +-- +-- * Command line option to turn loopification on and off is implemented in +-- DynFlags. +-- + + +emitEnter :: CmmExpr -> FCode ReturnKind +emitEnter fun = do + { dflags <- getDynFlags + ; adjustHpBackwards + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; case sequel of + -- For a return, we have the option of generating a tag-test or + -- not. If the value is tagged, we can return directly, which + -- is quicker than entering the value. This is a code + -- size/speed trade-off: when optimising for speed rather than + -- size we could generate the tag test. + -- + -- Right now, we do what the old codegen did, and omit the tag + -- test, just generating an enter. + Return _ -> do + { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg + ; emit $ mkJump dflags NativeNodeCall entry + [cmmUntag dflags fun] updfr_off + ; return AssignedDirectly + } + + -- The result will be scrutinised in the sequel. This is where + -- we generate a tag-test to avoid entering the closure if + -- possible. + -- + -- The generated code will be something like this: + -- + -- R1 = fun -- copyout + -- if (fun & 7 != 0) goto Lcall else goto Lret + -- Lcall: + -- call [fun] returns to Lret + -- Lret: + -- fun' = R1 -- copyin + -- ... + -- + -- Note in particular that the label Lret is used as a + -- destination by both the tag-test and the call. This is + -- becase Lret will necessarily be a proc-point, and we want to + -- ensure that we generate only one proc-point for this + -- sequence. + -- + -- Furthermore, we tell the caller that we generated a native + -- return continuation by returning (ReturnedTo Lret off), so + -- that the continuation can be reused by the heap-check failure + -- code in the enclosing case expression. + -- + AssignTo res_regs _ -> do + { lret <- newLabelC + ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; lcall <- newLabelC + ; updfr_off <- getUpdFrameOff + ; let area = Young lret + ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area + [fun] updfr_off [] + -- refer to fun via nodeReg after the copyout, to avoid having + -- both live simultaneously; this sometimes enables fun to be + -- inlined in the RHS of the R1 assignment. + ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) + the_call = toCall entry (Just lret) updfr_off off outArgs regs + ; tscope <- getTickScope + ; emit $ + copyout <*> + mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*> + outOfLine lcall (the_call,tscope) <*> + mkLabel lret tscope <*> + copyin + ; return (ReturnedTo lret off) + } + } + +------------------------------------------------------------------------ +-- Ticks +------------------------------------------------------------------------ + +-- | Generate Cmm code for a tick. Depending on the type of Tickish, +-- this will either generate actual Cmm instrumentation code, or +-- simply pass on the annotation as a @CmmTickish@. +cgTick :: Tickish Id -> FCode () +cgTick tick + = do { dflags <- getDynFlags + ; case tick of + ProfNote cc t p -> emitSetCCC cc t p + HpcTick m n -> emit (mkTickBox dflags m n) + SourceNote s n -> emitTick $ SourceNote s n + _other -> return () -- ignore + } diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs new file mode 100644 index 00000000..03f6a47d --- /dev/null +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP #-} + +-- | Our extended FCode monad. + +-- We add a mapping from names to CmmExpr, to support local variable names in +-- the concrete C-- code. The unique supply of the underlying FCode monad +-- is used to grab a new unique for each local variable. + +-- In C--, a local variable can be declared anywhere within a proc, +-- and it scopes from the beginning of the proc to the end. Hence, we have +-- to collect declarations as we parse the proc, and feed the environment +-- back in circularly (to avoid a two-pass algorithm). + +module StgCmmExtCode ( + CmmParse, unEC, + Named(..), Env, + + loopDecls, + getEnv, + + withName, + getName, + + newLocal, + newLabel, + newBlockId, + newFunctionName, + newImport, + lookupLabel, + lookupName, + + code, + emit, emitLabel, emitAssign, emitStore, + getCode, getCodeR, getCodeScoped, + emitOutOfLine, + withUpdFrameOff, getUpdFrameOff +) + +where + +import qualified StgCmmMonad as F +import StgCmmMonad (FCode, newUnique) + +import Cmm +import CLabel +import MkGraph + +-- import BasicTypes +import BlockId +import DynFlags +import FastString +import Module +import UniqFM +import Unique + +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +-- | The environment contains variable definitions or blockids. +data Named + = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + + | FunN PackageKey -- ^ A function name from this package + | LabelN BlockId -- ^ A blockid of some code or data. + +-- | An environment of named things. +type Env = UniqFM Named + +-- | Local declarations that are in scope during code generation. +type Decls = [(FastString,Named)] + +-- | Does a computation in the FCode monad, with a current environment +-- and a list of local declarations. Returns the resulting list of declarations. +newtype CmmParse a + = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } + +type ExtCode = CmmParse () + +returnExtFC :: a -> CmmParse a +returnExtFC a = EC $ \_ _ s -> return (s, a) + +thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b +thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' + +instance Functor CmmParse where + fmap = liftM + +instance Applicative CmmParse where + pure = return + (<*>) = ap + +instance Monad CmmParse where + (>>=) = thenExtFC + return = returnExtFC + +instance HasDynFlags CmmParse where + getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags + return (d, dflags)) + + +-- | Takes the variable decarations and imports from the monad +-- and makes an environment, which is looped back into the computation. +-- In this way, we can have embedded declarations that scope over the whole +-- procedure, and imports that scope over the entire module. +-- Discards the local declaration contained within decl' +-- +loopDecls :: CmmParse a -> CmmParse a +loopDecls (EC fcode) = + EC $ \c e globalDecls -> do + (_, a) <- F.fixC $ \ ~(decls, _) -> + fcode c (addListToUFM e decls) globalDecls + return (globalDecls, a) + + +-- | Get the current environment from the monad. +getEnv :: CmmParse Env +getEnv = EC $ \_ e s -> return (s, e) + +-- | Get the current context name from the monad +getName :: CmmParse String +getName = EC $ \c _ s -> return (s, c) + +-- | Set context name for a sub-parse +withName :: String -> CmmParse a -> CmmParse a +withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s + +addDecl :: FastString -> Named -> ExtCode +addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ()) + + +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. +addVarDecl :: FastString -> CmmExpr -> ExtCode +addVarDecl var expr = addDecl var (VarN expr) + +-- | Add a new label to the list of local declarations. +addLabel :: FastString -> BlockId -> ExtCode +addLabel name block_id = addDecl name (LabelN block_id) + + +-- | Create a fresh local variable of a given type. +newLocal + :: CmmType -- ^ data type + -> FastString -- ^ name of variable + -> CmmParse LocalReg -- ^ register holding the value + +newLocal ty name = do + u <- code newUnique + let reg = LocalReg u ty + addVarDecl name (CmmReg (CmmLocal reg)) + return reg + + +-- | Allocate a fresh label. +newLabel :: FastString -> CmmParse BlockId +newLabel name = do + u <- code newUnique + addLabel name (mkBlockId u) + return (mkBlockId u) + +newBlockId :: CmmParse BlockId +newBlockId = code F.newLabelC + +-- | Add add a local function to the environment. +newFunctionName + :: FastString -- ^ name of the function + -> PackageKey -- ^ package of the current module + -> ExtCode + +newFunctionName name pkg = addDecl name (FunN pkg) + + +-- | Add an imported foreign label to the list of local declarations. +-- If this is done at the start of the module the declaration will scope +-- over the whole module. +newImport + :: (FastString, CLabel) + -> CmmParse () + +newImport (name, cmmLabel) + = addVarDecl name (CmmLit (CmmLabel cmmLabel)) + + +-- | Lookup the BlockId bound to the label with this name. +-- If one hasn't been bound yet, create a fresh one based on the +-- Unique of the name. +lookupLabel :: FastString -> CmmParse BlockId +lookupLabel name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (LabelN l) -> l + _other -> mkBlockId (newTagUnique (getUnique name) 'L') + + +-- | Lookup the location of a named variable. +-- Unknown names are treated as if they had been 'import'ed from the runtime system. +-- This saves us a lot of bother in the RTS sources, at the expense of +-- deferring some errors to link time. +lookupName :: FastString -> CmmParse CmmExpr +lookupName name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (VarN e) -> e + Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name)) + + +-- | Lift an FCode computation into the CmmParse monad +code :: FCode a -> CmmParse a +code fc = EC $ \_ _ s -> do + r <- fc + return (s, r) + +emit :: CmmAGraph -> CmmParse () +emit = code . F.emit + +emitLabel :: BlockId -> CmmParse () +emitLabel = code . F.emitLabel + +emitAssign :: CmmReg -> CmmExpr -> CmmParse () +emitAssign l r = code (F.emitAssign l r) + +emitStore :: CmmExpr -> CmmExpr -> CmmParse () +emitStore l r = code (F.emitStore l r) + +getCode :: CmmParse a -> CmmParse CmmAGraph +getCode (EC ec) = EC $ \c e s -> do + ((s',_), gr) <- F.getCodeR (ec c e s) + return (s', gr) + +getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph) +getCodeR (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeR (ec c e s) + return (s', (r,gr)) + +getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped) +getCodeScoped (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeScoped (ec c e s) + return (s', (r,gr)) + +emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse () +emitOutOfLine l g = code (F.emitOutOfLine l g) + +withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () +withUpdFrameOff size inner + = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s + +getUpdFrameOff :: CmmParse UpdFrameOffset +getUpdFrameOff = code $ F.getUpdFrameOff diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs new file mode 100644 index 00000000..c38519ed --- /dev/null +++ b/compiler/codeGen/StgCmmForeign.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Code generation for foreign calls. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmForeign ( + cgForeignCall, + emitPrimCall, emitCCall, + emitForeignCall, -- For CmmParse + emitSaveThreadState, + saveThreadState, + emitLoadThreadState, + loadThreadState, + emitOpenNursery, + emitCloseNursery, + ) where + +#include "HsVersions.h" + +import StgSyn +import StgCmmProf (storeCurCCS, ccsType, curCCS) +import StgCmmEnv +import StgCmmMonad +import StgCmmUtils +import StgCmmClosure +import StgCmmLayout + +import Cmm +import CmmUtils +import MkGraph +import Type +import TysPrim +import CLabel +import SMRep +import ForeignCall +import DynFlags +import Maybes +import Outputable +import BasicTypes + +import Control.Monad + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding( succ, (<*>) ) +#else +import Prelude hiding( succ ) +#endif + +----------------------------------------------------------------------------- +-- Code generation for Foreign Calls +----------------------------------------------------------------------------- + +-- | emit code for a foreign call, and return the results to the sequel. +-- +cgForeignCall :: ForeignCall -- the op + -> [StgArg] -- x,y arguments + -> Type -- result type + -> FCode ReturnKind + +cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty + = do { dflags <- getDynFlags + ; let -- in the stdcall calling convention, the symbol needs @size appended + -- to it, where size is the total number of bytes of arguments. We + -- attach this info to the CLabel here, and the CLabel pretty printer + -- will generate the suffix when the label is printed. + call_size args + | StdCallConv <- cconv = Just (sum (map arg_size args)) + | otherwise = Nothing + + -- ToDo: this might not be correct for 64-bit API + arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) + (wORD_SIZE dflags) + ; cmm_args <- getFCallArgs stg_args + ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty + ; let ((call_args, arg_hints), cmm_target) + = case target of + StaticTarget _ _ False -> + panic "cgForeignCall: unexpected FFI value import" + StaticTarget lbl mPkgId True + -> let labelSource + = case mPkgId of + Nothing -> ForeignLabelInThisPackage + Just pkgId -> ForeignLabelInPackage pkgId + size = call_size cmm_args + in ( unzip cmm_args + , CmmLit (CmmLabel + (mkForeignLabel lbl size labelSource IsFunction))) + + DynamicTarget -> case cmm_args of + (fn,_):rest -> (unzip rest, fn) + [] -> panic "cgForeignCall []" + fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn + call_target = ForeignTarget cmm_target fc + + -- we want to emit code for the call, and then emitReturn. + -- However, if the sequel is AssignTo, we shortcut a little + -- and generate a foreign call that assigns the results + -- directly. Otherwise we end up generating a bunch of + -- useless "r = r" assignments, which are not merely annoying: + -- they prevent the common block elimination from working correctly + -- in the case of a safe foreign call. + -- See Note [safe foreign call convention] + -- + ; sequel <- getSequel + ; case sequel of + AssignTo assign_to_these _ -> + emitForeignCall safety assign_to_these call_target call_args + + _something_else -> + do { _ <- emitForeignCall safety res_regs call_target call_args + ; emitReturn (map (CmmReg . CmmLocal) res_regs) + } + } + +{- Note [safe foreign call convention] + +The simple thing to do for a safe foreign call would be the same as an +unsafe one: just + + emitForeignCall ... + emitReturn ... + +but consider what happens in this case + + case foo x y z of + (# s, r #) -> ... + +The sequel is AssignTo [r]. The call to newUnboxedTupleRegs picks [r] +as the result reg, and we generate + + r = foo(x,y,z) returns to L1 -- emitForeignCall + L1: + r = r -- emitReturn + goto L2 +L2: + ... + +Now L1 is a proc point (by definition, it is the continuation of the +safe foreign call). If L2 does a heap check, then L2 will also be a +proc point. + +Furthermore, the stack layout algorithm has to arrange to save r +somewhere between the call and the jump to L1, which is annoying: we +would have to treat r differently from the other live variables, which +have to be saved *before* the call. + +So we adopt a special convention for safe foreign calls: the results +are copied out according to the NativeReturn convention by the call, +and the continuation of the call should copyIn the results. (The +copyOut code is actually inserted when the safe foreign call is +lowered later). The result regs attached to the safe foreign call are +only used temporarily to hold the results before they are copied out. + +We will now generate this: + + r = foo(x,y,z) returns to L1 + L1: + r = R1 -- copyIn, inserted by mkSafeCall + goto L2 + L2: + ... r ... + +And when the safe foreign call is lowered later (see Note [lower safe +foreign calls]) we get this: + + suspendThread() + r = foo(x,y,z) + resumeThread() + R1 = r -- copyOut, inserted by lowerSafeForeignCall + jump L1 + L1: + r = R1 -- copyIn, inserted by mkSafeCall + goto L2 + L2: + ... r ... + +Now consider what happens if L2 does a heap check: the Adams +optimisation kicks in and commons up L1 with the heap-check +continuation, resulting in just one proc point instead of two. Yay! +-} + + +emitCCall :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall hinted_results fn hinted_args + = void $ emitForeignCall PlayRisky results target args + where + (args, arg_hints) = unzip hinted_args + (results, result_hints) = unzip hinted_results + target = ForeignTarget fn fc + fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn + + +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () +emitPrimCall res op args + = void $ emitForeignCall PlayRisky res (PrimTarget op) args + +-- alternative entry point, used by CmmParse +emitForeignCall + :: Safety + -> [CmmFormal] -- where to put the results + -> ForeignTarget -- the op + -> [CmmActual] -- arguments + -> FCode ReturnKind +emitForeignCall safety results target args + | not (playSafe safety) = do + dflags <- getDynFlags + let (caller_save, caller_load) = callerSaveVolatileRegs dflags + emit caller_save + target' <- load_target_into_temp target + args' <- mapM maybe_assign_temp args + emit $ mkUnsafeCall target' results args' + emit caller_load + return AssignedDirectly + + | otherwise = do + dflags <- getDynFlags + updfr_off <- getUpdFrameOff + target' <- load_target_into_temp target + args' <- mapM maybe_assign_temp args + k <- newLabelC + let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + -- see Note [safe foreign call convention] + tscope <- getTickScope + emit $ + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) + (CmmLit (CmmBlock k)) + <*> mkLast (CmmForeignCall { tgt = target' + , res = results + , args = args' + , succ = k + , ret_args = off + , ret_off = updfr_off + , intrbl = playInterruptible safety }) + <*> mkLabel k tscope + <*> copyout + ) + return (ReturnedTo k off) + +load_target_into_temp :: ForeignTarget -> FCode ForeignTarget +load_target_into_temp (ForeignTarget expr conv) = do + tmp <- maybe_assign_temp expr + return (ForeignTarget tmp conv) +load_target_into_temp other_target@(PrimTarget _) = + return other_target + +-- What we want to do here is create a new temporary for the foreign +-- call argument if it is not safe to use the expression directly, +-- because the expression mentions caller-saves GlobalRegs (see +-- Note [Register Parameter Passing]). +-- +-- However, we can't pattern-match on the expression here, because +-- this is used in a loop by CmmParse, and testing the expression +-- results in a black hole. So we always create a temporary, and rely +-- on CmmSink to clean it up later. (Yuck, ToDo). The generated code +-- ends up being the same, at least for the RTS .cmm code. +-- +maybe_assign_temp :: CmmExpr -> FCode CmmExpr +maybe_assign_temp e = do + dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) + emitAssign (CmmLocal reg) e + return (CmmReg (CmmLocal reg)) + +-- ----------------------------------------------------------------------------- +-- Save/restore the thread state in the TSO + +-- This stuff can't be done in suspendThread/resumeThread, because it +-- refers to global registers which aren't available in the C world. + +emitSaveThreadState :: FCode () +emitSaveThreadState = do + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ saveThreadState dflags tso cn + + +-- saveThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +saveThreadState dflags tso cn = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- tso->stackobj->sp = Sp; + mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp, + closeNursery dflags tso cn, + -- and save the current cost centre stack in the TSO when profiling: + if gopt Opt_SccProfilingOn dflags then + mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS + else mkNop + ] + +emitCloseNursery :: FCode () +emitCloseNursery = do + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + closeNursery dflags tso cn + +{- +Closing the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNuresry; + + // Update the allocation limit for the current thread. We don't + // check to see whether it has overflowed at this point, that check is + // made when we run out of space in the current heap block (stg_gc_noregs) + // and in the scheduler when context switching (schedulePostRunThread). + tso->alloc_limit -= Hp + WDS(1) - cn->start; + + // Set cn->free to the next unoccupied word in the block + cn->free = Hp + WDS(1); +-} + +closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +closeNursery df tso cn = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + in + catAGraphs [ + mkAssign cnreg stgCurrentNursery, + + -- CurrentNursery->free = Hp+1; + mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1), + + let alloc = + CmmMachOp (mo_wordSub df) + [ cmmOffsetW df stgHp 1 + , CmmLoad (nursery_bdescr_start df cnreg) (bWord df) + ] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Sub W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + ] + +emitLoadThreadState :: FCode () +emitLoadThreadState = do + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + stack <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ loadThreadState dflags tso stack cn bdfree bdstart + +-- loadThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +loadThreadState :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +loadThreadState dflags tso stack cn bdfree bdstart = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), + -- Sp = stack->sp; + mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), + -- HpAlloc = 0; + -- HpAlloc is assumed to be set to non-zero only by a failed + -- a heap check, see HeapStackCheck.cmm:GC_GENERIC + mkAssign hpAlloc (zeroExpr dflags), + openNursery dflags tso cn bdfree bdstart, + -- and load the current cost centre stack from the TSO when profiling: + if gopt Opt_SccProfilingOn dflags + then storeCurCCS + (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) + (tso_CCCS dflags)) (ccsType dflags)) + else mkNop + ] + + +emitOpenNursery :: FCode () +emitOpenNursery = do + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + openNursery dflags tso cn bdfree bdstart + +{- +Opening the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNursery; + bdfree = CurrentNuresry->free; + bdstart = CurrentNuresry->start; + + // We *add* the currently occupied portion of the nursery block to + // the allocation limit, because we will subtract it again in + // closeNursery. + tso->alloc_limit += bdfree - bdstart; + + // Set Hp to the last occupied word of the heap block. Why not the + // next unocupied word? Doing it this way means that we get to use + // an offset of zero more often, which might lead to slightly smaller + // code on some architectures. + Hp = bdfree - WDS(1); + + // Set HpLim to the end of the current nursery block (note that this block + // might be a block group, consisting of several adjacent blocks. + HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; +-} + +openNursery :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +openNursery df tso cn bdfree bdstart = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + bdfreereg = CmmLocal bdfree + bdstartreg = CmmLocal bdstart + in + -- These assignments are carefully ordered to reduce register + -- pressure and generate not completely awful code on x86. To see + -- what code we generate, look at the assembly for + -- stg_returnToStackTop in rts/StgStartup.cmm. + catAGraphs [ + mkAssign cnreg stgCurrentNursery, + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)), + + -- Hp = CurrentNursery->free - 1; + mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)), + + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)), + + -- HpLim = CurrentNursery->start + + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; + mkAssign hpLim + (cmmOffsetExpr df + (CmmReg bdstartreg) + (cmmOffset df + (CmmMachOp (mo_wordMul df) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth df)) + [CmmLoad (nursery_bdescr_blocks df cnreg) b32], + mkIntExpr df (bLOCK_SIZE df) + ]) + (-1) + ) + ), + + -- alloc = bd->free - bd->start + let alloc = + CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Add W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + + ] + +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks + :: DynFlags -> CmmReg -> CmmExpr +nursery_bdescr_free dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags) + +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff +tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) +tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) +stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) +stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) + + +closureField :: DynFlags -> ByteOff -> ByteOff +closureField dflags off = off + fixedHdrSize dflags + +stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr +stgSp = CmmReg sp +stgHp = CmmReg hp +stgCurrentTSO = CmmReg currentTSO +stgCurrentNursery = CmmReg currentNursery + +sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg +sp = CmmGlobal Sp +spLim = CmmGlobal SpLim +hp = CmmGlobal Hp +hpLim = CmmGlobal HpLim +currentTSO = CmmGlobal CurrentTSO +currentNursery = CmmGlobal CurrentNursery +hpAlloc = CmmGlobal HpAlloc + +-- ----------------------------------------------------------------------------- +-- For certain types passed to foreign calls, we adjust the actual +-- value passed to the call. For ByteArray#/Array# we pass the +-- address of the actual array, not the address of the heap object. + +getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] +-- (a) Drop void args +-- (b) Add foreign-call shim code +-- It's (b) that makes this differ from getNonVoidArgAmodes + +getFCallArgs args + = do { mb_cmms <- mapM get args + ; return (catMaybes mb_cmms) } + where + get arg | isVoidRep arg_rep + = return Nothing + | otherwise + = do { cmm <- getArgAmode (NonVoid arg) + ; dflags <- getDynFlags + ; return (Just (add_shim dflags arg_ty cmm, hint)) } + where + arg_ty = stgArgType arg + arg_rep = typePrimRep arg_ty + hint = typeForeignHint arg_ty + +add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr +add_shim dflags arg_ty expr + | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon + = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) + + | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon + = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags) + + | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon + = cmmOffsetB dflags expr (arrWordsHdrSize dflags) + + | otherwise = expr + where + UnaryRep rep_ty = repType arg_ty + tycon = tyConAppTyCon rep_ty + -- should be a tycon app, since this is a foreign call diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs new file mode 100644 index 00000000..0e9eb6d6 --- /dev/null +++ b/compiler/codeGen/StgCmmHeap.hs @@ -0,0 +1,688 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C--: heap management functions +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmHeap ( + getVirtHp, setVirtHp, setRealHp, + getHpRelOffset, + + entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo, + heapStackCheckGen, + entryHeapCheck', + + mkStaticClosureFields, mkStaticClosure, + + allocDynClosure, allocDynClosureCmm, allocHeapClosure, + emitSetDynHdr + ) where + +#include "HsVersions.h" + +import StgSyn +import CLabel +import StgCmmLayout +import StgCmmUtils +import StgCmmMonad +import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr) +import StgCmmTicky +import StgCmmClosure +import StgCmmEnv + +import MkGraph + +import Hoopl +import SMRep +import Cmm +import CmmUtils +import CostCentre +import IdInfo( CafInfo(..), mayHaveCafRefs ) +import Id ( Id ) +import Module +import DynFlags +import FastString( mkFastString, fsLit ) + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +import Control.Monad (when) +import Data.Maybe (isJust) + +----------------------------------------------------------- +-- Initialise dynamic heap objects +----------------------------------------------------------- + +allocDynClosure + :: Maybe Id + -> CmmInfoTable + -> LambdaFormInfo + -> CmmExpr -- Cost Centre to stick in the object + -> CmmExpr -- Cost Centre to blame for this alloc + -- (usually the same; sometimes "OVERHEAD") + + -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object + -- ie Info ptr has offset zero. + -- No void args in here + -> FCode CmmExpr -- returns Hp+n + +allocDynClosureCmm + :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr + -> [(CmmExpr, ByteOff)] + -> FCode CmmExpr -- returns Hp+n + +-- allocDynClosure allocates the thing in the heap, +-- and modifies the virtual Hp to account for this. +-- The second return value is the graph that sets the value of the +-- returned LocalReg, which should point to the closure after executing +-- the graph. + +-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is +-- only valid until Hp is changed. The caller should assign the +-- result to a LocalReg if it is required to remain live. +-- +-- The reason we don't assign it to a LocalReg here is that the caller +-- is often about to call regIdInfo, which immediately assigns the +-- result of allocDynClosure to a new temp in order to add the tag. +-- So by not generating a LocalReg here we avoid a common source of +-- new temporaries and save some compile time. This can be quite +-- significant - see test T4801. + + +allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do + let (args, offsets) = unzip args_w_offsets + cmm_args <- mapM getArgAmode args -- No void args + allocDynClosureCmm mb_id info_tbl lf_info + use_cc _blame_cc (zip cmm_args offsets) + + +allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do + -- SAY WHAT WE ARE ABOUT TO DO + let rep = cit_rep info_tbl + tickyDynAlloc mb_id rep lf_info + let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl)) + allocHeapClosure rep info_ptr use_cc amodes_w_offsets + + +-- | Low-level heap object allocation. +allocHeapClosure + :: SMRep -- ^ representation of the object + -> CmmExpr -- ^ info pointer + -> CmmExpr -- ^ cost centre + -> [(CmmExpr,ByteOff)] -- ^ payload + -> FCode CmmExpr -- ^ returns the address of the object +allocHeapClosure rep info_ptr use_cc payload = do + profDynAlloc rep use_cc + + virt_hp <- getVirtHp + + -- Find the offset of the info-ptr word + let info_offset = virt_hp + 1 + -- info_offset is the VirtualHpOffset of the first + -- word of the new object + -- Remember, virtHp points to last allocated word, + -- ie 1 *before* the info-ptr word of new object. + + base <- getHpRelOffset info_offset + emitComment $ mkFastString "allocHeapClosure" + emitSetDynHdr base info_ptr use_cc + + -- Fill in the fields + hpStore base payload + + -- Bump the virtual heap pointer + dflags <- getDynFlags + setVirtHp (virt_hp + heapClosureSizeW dflags rep) + + return base + + +emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitSetDynHdr base info_ptr ccs + = do dflags <- getDynFlags + hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..]) + where + header :: DynFlags -> [CmmExpr] + header dflags = [info_ptr] ++ dynProfHdr dflags ccs + -- ToDof: Parallel stuff + -- No ticky header + +-- Store the item (expr,off) in base[off] +hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () +hpStore base vals = do + dflags <- getDynFlags + sequence_ $ + [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ] + +----------------------------------------------------------- +-- Layout of static closures +----------------------------------------------------------- + +-- Make a static closure, adding on any extra padding needed for CAFs, +-- and adding a static link field if necessary. + +mkStaticClosureFields + :: DynFlags + -> CmmInfoTable + -> CostCentreStack + -> CafInfo + -> [CmmLit] -- Payload + -> [CmmLit] -- The full closure +mkStaticClosureFields dflags info_tbl ccs caf_refs payload + = mkStaticClosure dflags info_lbl ccs payload padding + static_link_field saved_info_field + where + info_lbl = cit_lbl info_tbl + + -- CAFs must have consistent layout, regardless of whether they + -- are actually updatable or not. The layout of a CAF is: + -- + -- 3 saved_info + -- 2 static_link + -- 1 indirectee + -- 0 info ptr + -- + -- the static_link and saved_info fields must always be in the + -- same place. So we use isThunkRep rather than closureUpdReqd + -- here: + + is_caf = isThunkRep (cit_rep info_tbl) + + padding + | is_caf && null payload = [mkIntCLit dflags 0] + | otherwise = [] + + static_link_field + | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl + = [static_link_value] + | otherwise + = [] + + saved_info_field + | is_caf = [mkIntCLit dflags 0] + | otherwise = [] + + -- For a static constructor which has NoCafRefs, we set the + -- static link field to a non-zero value so the garbage + -- collector will ignore it. + static_link_value + | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 -- No CAF refs + + +mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] + -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] +mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field + = [CmmLabel info_lbl] + ++ staticProfHdr dflags ccs + ++ concatMap (padLitToWord dflags) payload + ++ padding + ++ static_link_field + ++ saved_info_field + +-- JD: Simon had ellided this padding, but without it the C back end asserts +-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) + pad_length = wORD_SIZE dflags - widthInBytes width :: Int + + padding n | n <= 0 = [] + | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) + | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) + | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) + | otherwise = CmmInt 0 W64 : padding (n-8) + +----------------------------------------------------------- +-- Heap overflow checking +----------------------------------------------------------- + +{- Note [Heap checks] + ~~~~~~~~~~~~~~~~~~ +Heap checks come in various forms. We provide the following entry +points to the runtime system, all of which use the native C-- entry +convention. + + * gc() performs garbage collection and returns + nothing to its caller + + * A series of canned entry points like + r = gc_1p( r ) + where r is a pointer. This performs gc, and + then returns its argument r to its caller. + + * A series of canned entry points like + gcfun_2p( f, x, y ) + where f is a function closure of arity 2 + This performs garbage collection, keeping alive the + three argument ptrs, and then tail-calls f(x,y) + +These are used in the following circumstances + +* entryHeapCheck: Function entry + (a) With a canned GC entry sequence + f( f_clo, x:ptr, y:ptr ) { + Hp = Hp+8 + if Hp > HpLim goto L + ... + L: HpAlloc = 8 + jump gcfun_2p( f_clo, x, y ) } + Note the tail call to the garbage collector; + it should do no register shuffling + + (b) No canned sequence + f( f_clo, x:ptr, y:ptr, ...etc... ) { + T: Hp = Hp+8 + if Hp > HpLim goto L + ... + L: HpAlloc = 8 + call gc() -- Needs an info table + goto T } + +* altHeapCheck: Immediately following an eval + Started as + case f x y of r { (p,q) -> rhs } + (a) With a canned sequence for the results of f + (which is the very common case since + all boxed cases return just one pointer + ... + r = f( x, y ) + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... + + L: r = gc_1p( r ) + goto K } + + Here, the info table needed by the call + to gc_1p should be the *same* as the + one for the call to f; the C-- optimiser + spots this sharing opportunity) + + (b) No canned sequence for results of f + Note second info table + ... + (r1,r2,r3) = call f( x, y ) + K: + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... + + L: call gc() -- Extra info table here + goto K + +* generalHeapCheck: Anywhere else + e.g. entry to thunk + case branch *not* following eval, + or let-no-escape + Exactly the same as the previous case: + + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ... + + L: call gc() + goto K +-} + +-------------------------------------------------------------- +-- A heap/stack check at a function or thunk entry point. + +entryHeapCheck :: ClosureInfo + -> Maybe LocalReg -- Function (closure environment) + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () + +entryHeapCheck cl_info nodeSet arity args code + = entryHeapCheck' is_fastf node arity args code + where + node = case nodeSet of + Just r -> CmmReg (CmmLocal r) + Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info) + + is_fastf = case closureFunInfo cl_info of + Just (_, ArgGen _) -> False + _otherwise -> True + +-- | lower-level version for CmmParse +entryHeapCheck' :: Bool -- is a known function pattern + -> CmmExpr -- expression for the closure pointer + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () +entryHeapCheck' is_fastf node arity args code + = do dflags <- getDynFlags + let is_thunk = arity == 0 + + args' = map (CmmReg . CmmLocal) args + stg_gc_fun = CmmReg (CmmGlobal GCFun) + stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) + + {- Thunks: jump stg_gc_enter_1 + + Function (fast): call (NativeNode) stg_gc_fun(fun, args) + + Function (slow): call (slow) stg_gc_fun(fun, args) + -} + gc_call upd + | is_thunk + = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd + + | is_fastf + = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd + + | otherwise + = mkJump dflags Slow stg_gc_fun (node : args') upd + + updfr_sz <- getUpdFrameOff + + loop_id <- newLabelC + emitLabel loop_id + heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code + +-- ------------------------------------------------------------ +-- A heap/stack check in a case alternative + + +-- If there are multiple alts and we need to GC, but don't have a +-- continuation already (the scrut was simple), then we should +-- pre-generate the continuation. (if there are multiple alts it is +-- always a canned GC point). + +-- altHeapCheck: +-- If we have a return continuation, +-- then if it is a canned GC pattern, +-- then we do mkJumpReturnsTo +-- else we do a normal call to stg_gc_noregs +-- else if it is a canned GC pattern, +-- then generate the continuation and do mkCallReturnsTo +-- else we do a normal call to stg_gc_noregs + +altHeapCheck :: [LocalReg] -> FCode a -> FCode a +altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code + +altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a +altOrNoEscapeHeapCheck checkYield regs code = do + dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of + Nothing -> genericGC checkYield code + Just gc -> do + lret <- newLabelC + let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + lcont <- newLabelC + tscope <- getTickScope + emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) + emitLabel lcont + cannedGCReturnsTo checkYield False gc regs lret off code + +altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a +altHeapCheckReturnsTo regs lret off code + = do dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of + Nothing -> genericGC False code + Just gc -> cannedGCReturnsTo False True gc regs lret off code + +-- noEscapeHeapCheck is implemented identically to altHeapCheck (which +-- is more efficient), but cannot be optimized away in the non-allocating +-- case because it may occur in a loop +noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a +noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code + +cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff + -> FCode a + -> FCode a +cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code + = do dflags <- getDynFlags + updfr_sz <- getUpdFrameOff + heapCheck False checkYield (gc_call dflags gc updfr_sz) code + where + reg_exprs = map (CmmReg . CmmLocal) regs + -- Note [stg_gc arguments] + + -- NB. we use the NativeReturn convention for passing arguments + -- to the canned heap-check routines, because we are in a case + -- alternative and hence the [LocalReg] was passed to us in the + -- NativeReturn convention. + gc_call dflags label sp + | cont_on_stack + = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp + | otherwise + = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp [] + +genericGC :: Bool -> FCode a -> FCode a +genericGC checkYield code + = do updfr_sz <- getUpdFrameOff + lretry <- newLabelC + emitLabel lretry + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] + heapCheck False checkYield (call <*> mkBranch lretry) code + +cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint dflags regs + = case map localRegType regs of + [] -> Just (mkGcLabel "stg_gc_noregs") + [ty] + | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") + | isFloatType ty -> case width of + W32 -> Just (mkGcLabel "stg_gc_f1") + W64 -> Just (mkGcLabel "stg_gc_d1") + _ -> Nothing + + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing + where + width = typeWidth ty + [ty1,ty2] + | isGcPtrType ty1 + && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") + [ty1,ty2,ty3] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") + [ty1,ty2,ty3,ty4] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 + && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") + _otherwise -> Nothing + +-- Note [stg_gc arguments] +-- It might seem that we could avoid passing the arguments to the +-- stg_gc function, because they are already in the right registers. +-- While this is usually the case, it isn't always. Sometimes the +-- code generator has cleverly avoided the eval in a case, e.g. in +-- ffi/should_run/4221.hs we found +-- +-- case a_r1mb of z +-- FunPtr x y -> ... +-- +-- where a_r1mb is bound a top-level constructor, and is known to be +-- evaluated. The codegen just assigns x, y and z, and continues; +-- R1 is never assigned. +-- +-- So we'll have to rely on optimisations to eliminatethese +-- assignments where possible. + + +-- | The generic GC procedure; no params, no results +generic_gc :: CmmExpr +generic_gc = mkGcLabel "stg_gc_noregs" + +-- | Create a CLabel for calling a garbage collector entry point +mkGcLabel :: String -> CmmExpr +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit s))) + +------------------------------- +heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a +heapCheck checkStack checkYield do_gc code + = getHeapUsage $ \ hpHw -> + -- Emit heap checks, but be sure to do it lazily so + -- that the conditionals on hpHw don't cause a black hole + do { dflags <- getDynFlags + ; let mb_alloc_bytes + | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags))) + | otherwise = Nothing + stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) + | otherwise = Nothing + ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc + ; tickyAllocHeap True hpHw + ; setRealHp hpHw + ; code } + +heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode () +heapStackCheckGen stk_hwm mb_bytes + = do updfr_sz <- getUpdFrameOff + lretry <- newLabelC + emitLabel lretry + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] + do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry) + +-- Note [Single stack check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When compiling a function we can determine how much stack space it +-- will use. We therefore need to perform only a single stack check at +-- the beginning of a function to see if we have enough stack space. +-- +-- The check boils down to comparing Sp-N with SpLim, where N is the +-- amount of stack space needed (see Note [Stack usage] below). *BUT* +-- at this stage of the pipeline we are not supposed to refer to Sp +-- itself, because the stack is not yet manifest, so we don't quite +-- know where Sp pointing. + +-- So instead of referring directly to Sp - as we used to do in the +-- past - the code generator uses (old + 0) in the stack check. That +-- is the address of the first word of the old area, so if we add N +-- we'll get the address of highest used word. +-- +-- This makes the check robust. For example, while we need to perform +-- only one stack check for each function, we could in theory place +-- more stack checks later in the function. They would be redundant, +-- but not incorrect (in a sense that they should not change program +-- behaviour). We need to make sure however that a stack check +-- inserted after incrementing the stack pointer checks for a +-- respectively smaller stack space. This would not be the case if the +-- code generator produced direct references to Sp. By referencing +-- (old + 0) we make sure that we always check for a correct amount of +-- stack: when converting (old + 0) to Sp the stack layout phase takes +-- into account changes already made to stack pointer. The idea for +-- this change came from observations made while debugging #8275. + +-- Note [Stack usage] +-- ~~~~~~~~~~~~~~~~~~ +-- At the moment we convert from STG to Cmm we don't know N, the +-- number of bytes of stack that the function will use, so we use a +-- special late-bound CmmLit, namely +-- CmmHighStackMark +-- to stand for the number of bytes needed. When the stack is made +-- manifest, the number of bytes needed is calculated, and used to +-- replace occurrences of CmmHighStackMark +-- +-- The (Maybe CmmExpr) passed to do_checks is usually +-- Just (CmmLit CmmHighStackMark) +-- but can also (in certain hand-written RTS functions) +-- Just (CmmLit 8) or some other fixed valuet +-- If it is Nothing, we don't generate a stack check at all. + +do_checks :: Maybe CmmExpr -- Should we check the stack? + -- See Note [Stack usage] + -> Bool -- Should we check for preemption? + -> Maybe CmmExpr -- Heap headroom (bytes) + -> CmmAGraph -- What to do on failure + -> FCode () +do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do + dflags <- getDynFlags + gc_id <- newLabelC + + let + Just alloc_lit = mb_alloc_lit + + bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit + + -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) + -- At the beginning of a function old + 0 = Sp + -- See Note [Single stack check] + sp_oflo sp_hwm = + CmmMachOp (mo_wordULt dflags) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) + [CmmStackSlot Old 0, sp_hwm], + CmmReg spLimReg] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit + + case mb_stk_hwm of + Nothing -> return () + Just stk_hwm -> tickyStackCheck >> (emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id) + + -- Emit new label that might potentially be a header + -- of a self-recursive tail call. + -- See Note [Self-recursive loop header]. + self_loop_info <- getSelfLoop + case self_loop_info of + Just (_, loop_header_id, _) + | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id + _otherwise -> return () + + if (isJust mb_alloc_lit) + then do + tickyHeapCheck + emitAssign hpReg bump_hp + emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + else do + when (checkYield && not (gopt Opt_OmitYields dflags)) $ do + -- Yielding if HpLim == 0 + let yielding = CmmMachOp (mo_wordEq dflags) + [CmmReg (CmmGlobal HpLim), + CmmLit (zeroCLit dflags)] + emit =<< mkCmmIfGoto yielding gc_id + + tscope <- getTickScope + emitOutOfLine gc_id + (do_gc, tscope) -- this is expected to jump back somewhere + + -- Test for stack pointer exhaustion, then + -- bump heap pointer, and test for heap exhaustion + -- Note that we don't move the heap pointer unless the + -- stack check succeeds. Otherwise we might end up + -- with slop at the end of the current block, which can + -- confuse the LDV profiler. + +-- Note [Self-recursive loop header] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Self-recursive loop header is required by loopification optimization (See +-- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if: +-- +-- 1. There is information about self-loop in the FCode environment. We don't +-- check the binder (first component of the self_loop_info) because we are +-- certain that if the self-loop info is present then we are compiling the +-- binder body. Reason: the only possible way to get here with the +-- self_loop_info present is from closureCodeBody. +-- +-- 2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible +-- to preempt the heap check (see #367 for motivation behind this check). It +-- is True for heap checks placed at the entry to a function and +-- let-no-escape heap checks but false for other heap checks (eg. in case +-- alternatives or created from hand-written high-level Cmm). The second +-- check (isJust mb_stk_hwm) is true for heap checks at the entry to a +-- function and some heap checks created in hand-written Cmm. Otherwise it +-- is Nothing. In other words the only situation when both conditions are +-- true is when compiling stack and heap checks at the entry to a +-- function. This is the only situation when we want to emit a self-loop +-- label. diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs new file mode 100644 index 00000000..c8e65ad1 --- /dev/null +++ b/compiler/codeGen/StgCmmHpc.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- +-- Code generation for coverage +-- +-- (c) Galois Connections, Inc. 2006 +-- +----------------------------------------------------------------------------- + +module StgCmmHpc ( initHpc, mkTickBox ) where + +import StgCmmMonad + +import MkGraph +import CmmExpr +import CLabel +import Module +import CmmUtils +import StgCmmUtils +import HscTypes +import DynFlags + +import Control.Monad + +mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph +mkTickBox dflags mod n + = mkStore tick_box (CmmMachOp (MO_Add W64) + [ CmmLoad tick_box b64 + , CmmLit (CmmInt 1 W64) + ]) + where + tick_box = cmmIndex dflags W64 + (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) + n + +initHpc :: Module -> HpcInfo -> FCode () +-- Emit top-level tables for HPC and return code to initialise +initHpc _ (NoHpcInfo {}) + = return () +initHpc this_mod (HpcInfo tickCount _hashNo) + = do dflags <- getDynFlags + when (gopt Opt_Hpc dflags) $ + do emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0 :: Int ..] + ] + diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs new file mode 100644 index 00000000..c3d8873c --- /dev/null +++ b/compiler/codeGen/StgCmmLayout.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Building info tables. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmLayout ( + mkArgDescr, + emitCall, emitReturn, adjustHpBackwards, + + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, + + slowCall, directCall, + + mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, + + ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep + ) where + + +#include "HsVersions.h" + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +import StgCmmClosure +import StgCmmEnv +import StgCmmArgRep -- notably: ( slowCallPattern ) +import StgCmmTicky +import StgCmmMonad +import StgCmmUtils +import StgCmmProf (curCCS) + +import MkGraph +import SMRep +import Cmm +import CmmUtils +import CmmInfo +import CLabel +import StgSyn +import Id +import TyCon ( PrimRep(..) ) +import BasicTypes ( RepArity ) +import DynFlags +import Module + +import Util +import Data.List +import Outputable +import FastString +import Control.Monad + +------------------------------------------------------------------------ +-- Call and return sequences +------------------------------------------------------------------------ + +-- | Return multiple values to the sequel +-- +-- If the sequel is @Return@ +-- +-- > return (x,y) +-- +-- If the sequel is @AssignTo [p,q]@ +-- +-- > p=x; q=y; +-- +emitReturn :: [CmmExpr] -> FCode ReturnKind +emitReturn results + = do { dflags <- getDynFlags + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; case sequel of + Return _ -> + do { adjustHpBackwards + ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) + ; emit (mkReturn dflags (entryCode dflags e) results updfr_off) + } + AssignTo regs adjust -> + do { when adjust adjustHpBackwards + ; emitMultiAssign regs results } + ; return AssignedDirectly + } + + +-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@, +-- using the call/return convention @conv@, passing @args@, and +-- returning the results to the current sequel. +-- +emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind +emitCall convs fun args + = emitCallWithExtraStack convs fun args noExtraStack + + +-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the +-- entry-code of @fun@, using the call/return convention @conv@, +-- passing @args@, pushing some extra stack frames described by +-- @stack@, and returning the results to the current sequel. +-- +emitCallWithExtraStack + :: (Convention, Convention) -> CmmExpr -> [CmmExpr] + -> [CmmExpr] -> FCode ReturnKind +emitCallWithExtraStack (callConv, retConv) fun args extra_stack + = do { dflags <- getDynFlags + ; adjustHpBackwards + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; case sequel of + Return _ -> do + emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack + return AssignedDirectly + AssignTo res_regs _ -> do + k <- newLabelC + let area = Young k + (off, _, copyin) = copyInOflow dflags retConv area res_regs [] + copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off + extra_stack + tscope <- getTickScope + emit (copyout <*> mkLabel k tscope <*> copyin) + return (ReturnedTo k off) + } + + +adjustHpBackwards :: FCode () +-- This function adjusts the heap pointer just before a tail call or +-- return. At a call or return, the virtual heap pointer may be less +-- than the real Hp, because the latter was advanced to deal with +-- the worst-case branch of the code, and we may be in a better-case +-- branch. In that case, move the real Hp *back* and retract some +-- ticky allocation count. +-- +-- It *does not* deal with high-water-mark adjustment. That's done by +-- functions which allocate heap. +adjustHpBackwards + = do { hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + adjust_words = vHp -rHp + ; new_hp <- getHpRelOffset vHp + + ; emit (if adjust_words == 0 + then mkNop + else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + + ; tickyAllocHeap False adjust_words -- ...ditto + + ; setRealHp vHp + } + + +------------------------------------------------------------------------- +-- Making calls: directCall and slowCall +------------------------------------------------------------------------- + +-- General plan is: +-- - we'll make *one* fast call, either to the function itself +-- (directCall) or to stg_ap__fast (slowCall) +-- Any left-over arguments will be pushed on the stack, +-- +-- e.g. Sp[old+8] = arg1 +-- Sp[old+16] = arg2 +-- Sp[old+32] = stg_ap_pp_info +-- R2 = arg3 +-- R3 = arg4 +-- call f() return to Nothing updfr_off: 32 + + +directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind +-- (directCall f n args) +-- calls f(arg1, ..., argn), and applies the result to the remaining args +-- The function f has arity n, and there are guaranteed at least n args +-- Both arity and args include void args +directCall conv lbl arity stg_args + = do { argreps <- getArgRepsAmodes stg_args + ; direct_call "directCall" conv lbl arity argreps } + + +slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind +-- (slowCall fun args) applies fun to args, returning the results to Sequel +slowCall fun stg_args + = do dflags <- getDynFlags + argsreps <- getArgRepsAmodes stg_args + let (rts_fun, arity) = slowCallPattern (map fst argsreps) + + (r, slow_code) <- getCodeR $ do + r <- direct_call "slow_call" NativeNodeCall + (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) + emitComment $ mkFastString ("slow_call for " ++ + showSDoc dflags (ppr fun) ++ + " with pat " ++ unpackFS rts_fun) + return r + + -- Note [avoid intermediate PAPs] + let n_args = length stg_args + if n_args > arity && optLevel dflags >= 2 + then do + funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun + fun_iptr <- (CmmReg . CmmLocal) `fmap` + assignTemp (closureInfoPtr dflags (cmmUntag dflags funv)) + + -- ToDo: we could do slightly better here by reusing the + -- continuation from the slow call, which we have in r. + -- Also we'd like to push the continuation on the stack + -- before the branch, so that we only get one copy of the + -- code that saves all the live variables across the + -- call, but that might need some improvements to the + -- special case in the stack layout code to handle this + -- (see Note [diamond proc point]). + + fast_code <- getCode $ + emitCall (NativeNodeCall, NativeReturn) + (entryCode dflags fun_iptr) + (nonVArgs ((P,Just funv):argsreps)) + + slow_lbl <- newLabelC + fast_lbl <- newLabelC + is_tagged_lbl <- newLabelC + end_lbl <- newLabelC + + let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr) + (mkIntExpr dflags n_args) + + tscope <- getTickScope + emit (mkCbranch (cmmIsTagged dflags funv) is_tagged_lbl slow_lbl + <*> mkLabel is_tagged_lbl tscope + <*> mkCbranch correct_arity fast_lbl slow_lbl + <*> mkLabel fast_lbl tscope + <*> fast_code + <*> mkBranch end_lbl + <*> mkLabel slow_lbl tscope + <*> slow_code + <*> mkLabel end_lbl tscope) + return r + + else do + emit slow_code + return r + + +-- Note [avoid intermediate PAPs] +-- +-- A slow call which needs multiple generic apply patterns will be +-- almost guaranteed to create one or more intermediate PAPs when +-- applied to a function that takes the correct number of arguments. +-- We try to avoid this situation by generating code to test whether +-- we are calling a function with the correct number of arguments +-- first, i.e.: +-- +-- if (TAG(f) != 0} { // f is not a thunk +-- if (f->info.arity == n) { +-- ... make a fast call to f ... +-- } +-- } +-- ... otherwise make the slow call ... +-- +-- We *only* do this when the call requires multiple generic apply +-- functions, which requires pushing extra stack frames and probably +-- results in intermediate PAPs. (I say probably, because it might be +-- that we're over-applying a function, but that seems even less +-- likely). +-- +-- This very rarely applies, but if it does happen in an inner loop it +-- can have a severe impact on performance (#6084). + + +-------------- +direct_call :: String + -> Convention -- e.g. NativeNodeCall or NativeDirectCall + -> CLabel -> RepArity + -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind +direct_call caller call_conv lbl arity args + | debugIsOn && real_arity > length args -- Too few args + = do -- Caller should ensure that there enough args! + pprPanic "direct_call" $ + text caller <+> ppr arity <+> + ppr lbl <+> ppr (length args) <+> + ppr (map snd args) <+> ppr (map fst args) + + | null rest_args -- Precisely the right number of arguments + = emitCall (call_conv, NativeReturn) target (nonVArgs args) + + | otherwise -- Note [over-saturated calls] + = do dflags <- getDynFlags + emitCallWithExtraStack (call_conv, NativeReturn) + target + (nonVArgs fast_args) + (nonVArgs (stack_args dflags)) + where + target = CmmLit (CmmLabel lbl) + (fast_args, rest_args) = splitAt real_arity args + stack_args dflags = slowArgs dflags rest_args + real_arity = case call_conv of + NativeNodeCall -> arity+1 + _ -> arity + + +-- When constructing calls, it is easier to keep the ArgReps and the +-- CmmExprs zipped together. However, a void argument has no +-- representation, so we need to use Maybe CmmExpr (the alternative of +-- using zeroCLit or even undefined would work, but would be ugly). +-- +getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)] +getArgRepsAmodes = mapM getArgRepAmode + where getArgRepAmode arg + | V <- rep = return (V, Nothing) + | otherwise = do expr <- getArgAmode (NonVoid arg) + return (rep, Just expr) + where rep = toArgRep (argPrimRep arg) + +nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] +nonVArgs [] = [] +nonVArgs ((_,Nothing) : args) = nonVArgs args +nonVArgs ((_,Just arg) : args) = arg : nonVArgs args + +{- +Note [over-saturated calls] + +The natural thing to do for an over-saturated call would be to call +the function with the correct number of arguments, and then apply the +remaining arguments to the value returned, e.g. + + f a b c d (where f has arity 2) + --> + r = call f(a,b) + call r(c,d) + +but this entails + - saving c and d on the stack + - making a continuation info table + - at the continuation, loading c and d off the stack into regs + - finally, call r + +Note that since there are a fixed number of different r's +(e.g. stg_ap_pp_fast), we can also pre-compile continuations +that correspond to each of them, rather than generating a fresh +one for each over-saturated call. + +Not only does this generate much less code, it is faster too. We will +generate something like: + +Sp[old+16] = c +Sp[old+24] = d +Sp[old+32] = stg_ap_pp_info +call f(a,b) -- usual calling convention + +For the purposes of the CmmCall node, we count this extra stack as +just more arguments that we are passing on the stack (cml_args). +-} + +-- | 'slowArgs' takes a list of function arguments and prepares them for +-- pushing on the stack for "extra" arguments to a function which requires +-- fewer arguments than we currently have. +slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] +slowArgs _ [] = [] +slowArgs dflags args -- careful: reps contains voids (V), but args does not + | gopt Opt_SccProfilingOn dflags + = save_cccs ++ this_pat ++ slowArgs dflags rest_args + | otherwise = this_pat ++ slowArgs dflags rest_args + where + (arg_pat, n) = slowCallPattern (map fst args) + (call_args, rest_args) = splitAt n args + + stg_ap_pat = mkCmmRetInfoLabel rtsPackageKey arg_pat + this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args + save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] + save_cccs_lbl = mkCmmRetInfoLabel rtsPackageKey (fsLit "stg_restore_cccs") + +------------------------------------------------------------------------- +---- Laying out objects on the heap and stack +------------------------------------------------------------------------- + +-- The heap always grows upwards, so hpRel is easy to compute +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset +hpRel hp off = off - hp + +getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr +-- See Note [Virtual and real heap pointers] in StgCmmMonad +getHpRelOffset virtual_offset + = do dflags <- getDynFlags + hp_usg <- getHpUsage + return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) + +mkVirtHeapOffsets + :: DynFlags + -> Bool -- True <=> is a thunk + -> [(PrimRep,a)] -- Things to make offsets for + -> (WordOff, -- _Total_ number of words allocated + WordOff, -- Number of words allocated for *pointers* + [(NonVoid a, ByteOff)]) + +-- Things with their offsets from start of object in order of +-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER +-- First in list gets lowest offset, which is initial offset + 1. +-- +-- Void arguments are removed, so output list may be shorter than +-- input list +-- +-- mkVirtHeapOffsets always returns boxed things with smaller offsets +-- than the unboxed things + +mkVirtHeapOffsets dflags is_thunk things + = ( bytesToWordsRoundUp dflags tot_bytes + , bytesToWordsRoundUp dflags bytes_of_ptrs + , ptrs_w_offsets ++ non_ptrs_w_offsets + ) + where + hdr_words | is_thunk = thunkHdrSize dflags + | otherwise = fixedHdrSizeW dflags + hdr_bytes = wordsToBytes dflags hdr_words + + non_void_things = filterOut (isVoidRep . fst) things + (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things + + (bytes_of_ptrs, ptrs_w_offsets) = + mapAccumL computeOffset 0 ptrs + (tot_bytes, non_ptrs_w_offsets) = + mapAccumL computeOffset bytes_of_ptrs non_ptrs + + computeOffset bytes_so_far (rep, thing) + = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)), + (NonVoid thing, hdr_bytes + bytes_so_far)) + +-- | Just like mkVirtHeapOffsets, but for constructors +mkVirtConstrOffsets + :: DynFlags -> [(PrimRep,a)] + -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) +mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False + + +------------------------------------------------------------------------- +-- +-- Making argument descriptors +-- +-- An argument descriptor describes the layout of args on the stack, +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails +-- +-- Void arguments aren't important, therefore (contrast constructSlowCall) +-- +------------------------------------------------------------------------- + +-- bring in ARG_P, ARG_N, etc. +#include "../includes/rts/storage/FunTypes.h" + +mkArgDescr :: DynFlags -> [Id] -> ArgDescr +mkArgDescr dflags args + = let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) + -- Getting rid of voids eases matching of standard patterns + in case stdPattern arg_reps of + Just spec_id -> ArgSpec spec_id + Nothing -> ArgGen arg_bits + +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (P : args) = False : argBits dflags args +argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) + ++ argBits dflags args + +---------------------- +stdPattern :: [ArgRep] -> Maybe Int +stdPattern reps + = case reps of + [] -> Just ARG_NONE -- just void args, probably + [N] -> Just ARG_N + [P] -> Just ARG_P + [F] -> Just ARG_F + [D] -> Just ARG_D + [L] -> Just ARG_L + [V16] -> Just ARG_V16 + [V32] -> Just ARG_V32 + [V64] -> Just ARG_V64 + + [N,N] -> Just ARG_NN + [N,P] -> Just ARG_NP + [P,N] -> Just ARG_PN + [P,P] -> Just ARG_PP + + [N,N,N] -> Just ARG_NNN + [N,N,P] -> Just ARG_NNP + [N,P,N] -> Just ARG_NPN + [N,P,P] -> Just ARG_NPP + [P,N,N] -> Just ARG_PNN + [P,N,P] -> Just ARG_PNP + [P,P,N] -> Just ARG_PPN + [P,P,P] -> Just ARG_PPP + + [P,P,P,P] -> Just ARG_PPPP + [P,P,P,P,P] -> Just ARG_PPPPP + [P,P,P,P,P,P] -> Just ARG_PPPPPP + + _ -> Nothing + +------------------------------------------------------------------------- +-- +-- Generating the info table and code for a closure +-- +------------------------------------------------------------------------- + +-- Here we make an info table of type 'CmmInfo'. The concrete +-- representation as a list of 'CmmAddr' is handled later +-- in the pipeline by 'cmmToRawCmm'. +-- When loading the free variables, a function closure pointer may be tagged, +-- so we must take it into account. + +emitClosureProcAndInfoTable :: Bool -- top-level? + -> Id -- name of the closure + -> LambdaFormInfo + -> CmmInfoTable + -> [NonVoid Id] -- incoming arguments + -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body + -> FCode () +emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body + = do { dflags <- getDynFlags + -- Bind the binder itself, but only if it's not a top-level + -- binding. We need non-top let-bindings to refer to the + -- top-level binding, which this binding would incorrectly shadow. + ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr) + else bindToReg (NonVoid bndr) lf_info + ; let node_points = nodeMustPointToIt dflags lf_info + ; arg_regs <- bindArgsToRegs args + ; let args' = if node_points then (node : arg_regs) else arg_regs + conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall + else NativeDirectCall + (offset, _, _) = mkCallEntry dflags conv args' [] + ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) + } + +-- Data constructors need closures, but not with all the argument handling +-- needed for functions. The shared part goes here. +emitClosureAndInfoTable :: + CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable info_tbl conv args body + = do { (_, blks) <- getCodeScoped body + ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) + ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks + } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs new file mode 100644 index 00000000..f7a13f9c --- /dev/null +++ b/compiler/codeGen/StgCmmMonad.hs @@ -0,0 +1,876 @@ +{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- +-- Monad for Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmMonad ( + FCode, -- type + + initC, runC, thenC, thenFC, listCs, + returnFC, fixC, + newUnique, newUniqSupply, + + newLabelC, emitLabel, + + emit, emitDecl, emitProc, + emitProcWithConvention, emitProcWithStackFrame, + emitOutOfLine, emitAssign, emitStore, emitComment, + emitTick, emitUnwind, + + getCmm, aGraphToGraph, + getCodeR, getCode, getCodeScoped, getHeapUsage, + + mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, + mkCall, mkCmmCall, + + forkClosureBody, forkLneBody, forkAlts, codeOnly, + + ConTagZ, + + Sequel(..), ReturnKind(..), + withSequel, getSequel, + + setTickyCtrLabel, getTickyCtrLabel, + tickScope, getTickScope, + + withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + + HeapUsage(..), VirtualHpOffset, initHpUsage, + getHpUsage, setHpUsage, heapHWM, + setVirtHp, getVirtHp, setRealHp, + + getModuleName, + + -- ideally we wouldn't export these, but some other modules access internal state + getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage, + + -- more localised access to monad state + CgIdInfo(..), + getBinds, setBinds, + + -- out of general friendliness, we also export ... + CgInfoDownwards(..), CgState(..) -- non-abstract + ) where + +#include "HsVersions.h" + +import Cmm +import StgCmmClosure +import DynFlags +import Hoopl +import Maybes +import MkGraph +import BlockId +import CLabel +import SMRep +import Module +import Id +import VarEnv +import OrdList +import Unique +import UniqSupply +import FastString +import Outputable + +import qualified Control.Applicative as A +import Control.Monad +import Data.List +import Prelude hiding( sequence, succ ) + +infixr 9 `thenC` -- Right-associative! +infixr 9 `thenFC` + + +-------------------------------------------------------- +-- The FCode monad and its types +-- +-- FCode is the monad plumbed through the Stg->Cmm code generator, and +-- the Cmm parser. It contains the following things: +-- +-- - A writer monad, collecting: +-- - code for the current function, in the form of a CmmAGraph. +-- The function "emit" appends more code to this. +-- - the top-level CmmDecls accumulated so far +-- +-- - A state monad with: +-- - the local bindings in scope +-- - the current heap usage +-- - a UniqSupply +-- +-- - A reader monad, for CgInfoDownwards, containing +-- - DynFlags, +-- - the current Module +-- - the update-frame offset +-- - the ticky counter label +-- - the Sequel (the continuation to return to) +-- - the self-recursive tail call information + +-------------------------------------------------------- + +newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #)) + +instance Functor FCode where + fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #) + +instance A.Applicative FCode where + pure = return + (<*>) = ap + +instance Monad FCode where + (>>=) = thenFC + return = returnFC + +{-# INLINE thenC #-} +{-# INLINE thenFC #-} +{-# INLINE returnFC #-} + +initC :: IO CgState +initC = do { uniqs <- mkSplitUniqSupply 'c' + ; return (initCgState uniqs) } + +runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) +runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st + +returnFC :: a -> FCode a +returnFC val = FCode (\_info_down state -> (# val, state #)) + +thenC :: FCode () -> FCode a -> FCode a +thenC (FCode m) (FCode k) = + FCode $ \info_down state -> case m info_down state of + (# _,new_state #) -> k info_down new_state + +listCs :: [FCode ()] -> FCode () +listCs [] = return () +listCs (fc:fcs) = do + fc + listCs fcs + +thenFC :: FCode a -> (a -> FCode c) -> FCode c +thenFC (FCode m) k = FCode $ + \info_down state -> + case m info_down state of + (# m_result, new_state #) -> + case k m_result of + FCode kcode -> kcode info_down new_state + +fixC :: (a -> FCode a) -> FCode a +fixC fcode = FCode ( + \info_down state -> + let + (v,s) = doFCode (fcode v) info_down state + in + (# v, s #) + ) + +-------------------------------------------------------- +-- The code generator environment +-------------------------------------------------------- + +-- This monadery has some information that it only passes +-- *downwards*, as well as some ``state'' which is modified +-- as we go along. + +data CgInfoDownwards -- information only passed *downwards* by the monad + = MkCgInfoDown { + cgd_dflags :: DynFlags, + cgd_mod :: Module, -- Module being compiled + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_ticky :: CLabel, -- Current destination for ticky counts + cgd_sequel :: Sequel, -- What to do at end of basic block + cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled + -- as local jumps? See Note + -- [Self-recursive tail calls] in + -- StgCmmExpr + cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks + } + +type CgBindings = IdEnv CgIdInfo + +data CgIdInfo + = CgIdInfo + { cg_id :: Id -- Id that this is the info for + -- Can differ from the Id at occurrence sites by + -- virtue of being externalised, for splittable C + -- See Note [Externalise when splitting] + , cg_lf :: LambdaFormInfo + , cg_loc :: CgLoc -- CmmExpr for the *tagged* value + } + +-- Note [Externalise when splitting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we're splitting the object with -fsplit-objs, we need to +-- externalise *all* the top-level names, and then make sure we only +-- use the externalised one in any C label we use which refers to this +-- name. + +instance Outputable CgIdInfo where + ppr (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> ptext (sLit "-->") <+> ppr loc + +-- Sequel tells what to do with the result of this expression +data Sequel + = Return Bool -- Return result(s) to continuation found on the stack. + -- True <=> the continuation is update code (???) + + | AssignTo + [LocalReg] -- Put result(s) in these regs and fall through + -- NB: no void arguments here + -- + Bool -- Should we adjust the heap pointer back to + -- recover space that's unused on this path? + -- We need to do this only if the expression + -- may allocate (e.g. it's a foreign call or + -- allocating primOp) + +-- See Note [sharing continuations] below +data ReturnKind + = AssignedDirectly + | ReturnedTo BlockId ByteOff + +-- Note [sharing continuations] +-- +-- ReturnKind says how the expression being compiled returned its +-- results: either by assigning directly to the registers specified +-- by the Sequel, or by returning to a continuation that does the +-- assignments. The point of this is we might be able to re-use the +-- continuation in a subsequent heap-check. Consider: +-- +-- case f x of z +-- True -> +-- False -> +-- +-- Naively we would generate +-- +-- R2 = x -- argument to f +-- Sp[young(L1)] = L1 +-- call f returns to L1 +-- L1: +-- z = R1 +-- if (z & 1) then Ltrue else Lfalse +-- Ltrue: +-- Hp = Hp + 24 +-- if (Hp > HpLim) then L4 else L7 +-- L4: +-- HpAlloc = 24 +-- goto L5 +-- L5: +-- R1 = z +-- Sp[young(L6)] = L6 +-- call stg_gc_unpt_r1 returns to L6 +-- L6: +-- z = R1 +-- goto L1 +-- L7: +-- +-- Lfalse: +-- +-- +-- We want the gc call in L4 to return to L1, and discard L6. Note +-- that not only can we share L1 and L6, but the assignment of the +-- return address in L4 is unnecessary because the return address for +-- L1 is already on the stack. We used to catch the sharing of L1 and +-- L6 in the common-block-eliminator, but not the unnecessary return +-- address assignment. +-- +-- Since this case is so common I decided to make it more explicit and +-- robust by programming the sharing directly, rather than relying on +-- the common-block elimiantor to catch it. This makes +-- common-block-elimianteion an optional optimisation, and furthermore +-- generates less code in the first place that we have to subsequently +-- clean up. +-- +-- There are some rarer cases of common blocks that we don't catch +-- this way, but that's ok. Common-block-elimination is still available +-- to catch them when optimisation is enabled. Some examples are: +-- +-- - when both the True and False branches do a heap check, we +-- can share the heap-check failure code L4a and maybe L4 +-- +-- - in a case-of-case, there might be multiple continuations that +-- we can common up. +-- +-- It is always safe to use AssignedDirectly. Expressions that jump +-- to the continuation from multiple places (e.g. case expressions) +-- fall back to AssignedDirectly. +-- + + +initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards +initCgInfoDown dflags mod + = MkCgInfoDown { cgd_dflags = dflags + , cgd_mod = mod + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_ticky = mkTopTickyCtrLabel + , cgd_sequel = initSequel + , cgd_self_loop = Nothing + , cgd_tick_scope= GlobalScope } + +initSequel :: Sequel +initSequel = Return False + +initUpdFrameOff :: DynFlags -> UpdFrameOffset +initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA + + +-------------------------------------------------------- +-- The code generator state +-------------------------------------------------------- + +data CgState + = MkCgState { + cgs_stmts :: CmmAGraph, -- Current procedure + + cgs_tops :: OrdList CmmDecl, + -- Other procedures and data blocks in this compilation unit + -- Both are ordered only so that we can + -- reduce forward references, when it's easy to do so + + cgs_binds :: CgBindings, + + cgs_hp_usg :: HeapUsage, + + cgs_uniqs :: UniqSupply } + +data HeapUsage -- See Note [Virtual and real heap pointers] + = HeapUsage { + virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word + -- Incremented whenever we allocate + realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr + -- Used in instruction addressing modes + } + +type VirtualHpOffset = WordOff + + +{- Note [Virtual and real heap pointers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The code generator can allocate one or more objects contiguously, performing +one heap check to cover allocation of all the objects at once. Let's call +this little chunk of heap space an "allocation chunk". The code generator +will emit code to + * Perform a heap-exhaustion check + * Move the heap pointer to the end of the allocation chunk + * Allocate multiple objects within the chunk + +The code generator uses VirtualHpOffsets to address words within a +single allocation chunk; these start at one and increase positively. +The first word of the chunk has VirtualHpOffset=1, the second has +VirtualHpOffset=2, and so on. + + * The field realHp tracks (the VirtualHpOffset) where the real Hp + register is pointing. Typically it'll be pointing to the end of the + allocation chunk. + + * The field virtHp gives the VirtualHpOffset of the highest-allocated + word so far. It starts at zero (meaning no word has been allocated), + and increases whenever an object is allocated. + +The difference between realHp and virtHp gives the offset from the +real Hp register of a particular word in the allocation chunk. This +is what getHpRelOffset does. Since the returned offset is relative +to the real Hp register, it is valid only until you change the real +Hp register. (Changing virtHp doesn't matter.) +-} + + +initCgState :: UniqSupply -> CgState +initCgState uniqs + = MkCgState { cgs_stmts = mkNop + , cgs_tops = nilOL + , cgs_binds = emptyVarEnv + , cgs_hp_usg = initHpUsage + , cgs_uniqs = uniqs } + +stateIncUsage :: CgState -> CgState -> CgState +-- stateIncUsage@ e1 e2 incorporates in e1 +-- the heap high water mark found in e2. +stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) + = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } + `addCodeBlocksFrom` s2 + +addCodeBlocksFrom :: CgState -> CgState -> CgState +-- Add code blocks from the latter to the former +-- (The cgs_stmts will often be empty, but not always; see codeOnly) +s1 `addCodeBlocksFrom` s2 + = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2, + cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } + + +-- The heap high water mark is the larger of virtHp and hwHp. The latter is +-- only records the high water marks of forked-off branches, so to find the +-- heap high water mark you have to take the max of virtHp and hwHp. Remember, +-- virtHp never retreats! +-- +-- Note Jan 04: ok, so why do we only look at the virtual Hp?? + +heapHWM :: HeapUsage -> VirtualHpOffset +heapHWM = virtHp + +initHpUsage :: HeapUsage +initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } + +maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage +hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } + +-------------------------------------------------------- +-- Operators for getting and setting the state and "info_down". +-------------------------------------------------------- + +getState :: FCode CgState +getState = FCode $ \_info_down state -> (# state, state #) + +setState :: CgState -> FCode () +setState state = FCode $ \_info_down _ -> (# (), state #) + +getHpUsage :: FCode HeapUsage +getHpUsage = do + state <- getState + return $ cgs_hp_usg state + +setHpUsage :: HeapUsage -> FCode () +setHpUsage new_hp_usg = do + state <- getState + setState $ state {cgs_hp_usg = new_hp_usg} + +setVirtHp :: VirtualHpOffset -> FCode () +setVirtHp new_virtHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {virtHp = new_virtHp}) } + +getVirtHp :: FCode VirtualHpOffset +getVirtHp + = do { hp_usage <- getHpUsage + ; return (virtHp hp_usage) } + +setRealHp :: VirtualHpOffset -> FCode () +setRealHp new_realHp + = do { hp_usage <- getHpUsage + ; setHpUsage (hp_usage {realHp = new_realHp}) } + +getBinds :: FCode CgBindings +getBinds = do + state <- getState + return $ cgs_binds state + +setBinds :: CgBindings -> FCode () +setBinds new_binds = do + state <- getState + setState $ state {cgs_binds = new_binds} + +withState :: FCode a -> CgState -> FCode (a,CgState) +withState (FCode fcode) newstate = FCode $ \info_down state -> + case fcode info_down newstate of + (# retval, state2 #) -> (# (retval,state2), state #) + +newUniqSupply :: FCode UniqSupply +newUniqSupply = do + state <- getState + let (us1, us2) = splitUniqSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us1 } + return us2 + +newUnique :: FCode Unique +newUnique = do + state <- getState + let (u,us') = takeUniqFromSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us' } + return u + +------------------ +getInfoDown :: FCode CgInfoDownwards +getInfoDown = FCode $ \info_down state -> (# info_down,state #) + +getSelfLoop :: FCode (Maybe SelfLoopInfo) +getSelfLoop = do + info_down <- getInfoDown + return $ cgd_self_loop info_down + +withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a +withSelfLoop self_loop code = do + info_down <- getInfoDown + withInfoDown code (info_down {cgd_self_loop = Just self_loop}) + +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown + +getThisPackage :: FCode PackageKey +getThisPackage = liftM thisPackage getDynFlags + +withInfoDown :: FCode a -> CgInfoDownwards -> FCode a +withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state + +doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) +doFCode (FCode fcode) info_down state = + case fcode info_down state of + (# a, s #) -> ( a, s ) + +-- ---------------------------------------------------------------------------- +-- Get the current module name + +getModuleName :: FCode Module +getModuleName = do { info <- getInfoDown; return (cgd_mod info) } + +-- ---------------------------------------------------------------------------- +-- Get/set the end-of-block info + +withSequel :: Sequel -> FCode a -> FCode a +withSequel sequel code + = do { info <- getInfoDown + ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) } + +getSequel :: FCode Sequel +getSequel = do { info <- getInfoDown + ; return (cgd_sequel info) } + +-- ---------------------------------------------------------------------------- +-- Get/set the size of the update frame + +-- We keep track of the size of the update frame so that we +-- can set the stack pointer to the proper address on return +-- (or tail call) from the closure. +-- There should be at most one update frame for each closure. +-- Note: I'm including the size of the original return address +-- in the size of the update frame -- hence the default case on `get'. + +withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a +withUpdFrameOff size code + = do { info <- getInfoDown + ; withInfoDown code (info {cgd_updfr_off = size }) } + +getUpdFrameOff :: FCode UpdFrameOffset +getUpdFrameOff + = do { info <- getInfoDown + ; return $ cgd_updfr_off info } + +-- ---------------------------------------------------------------------------- +-- Get/set the current ticky counter label + +getTickyCtrLabel :: FCode CLabel +getTickyCtrLabel = do + info <- getInfoDown + return (cgd_ticky info) + +setTickyCtrLabel :: CLabel -> FCode a -> FCode a +setTickyCtrLabel ticky code = do + info <- getInfoDown + withInfoDown code (info {cgd_ticky = ticky}) + +-- ---------------------------------------------------------------------------- +-- Manage tick scopes + +-- | The current tick scope. We will assign this to generated blocks. +getTickScope :: FCode CmmTickScope +getTickScope = do + info <- getInfoDown + return (cgd_tick_scope info) + +-- | Places blocks generated by the given code into a fresh +-- (sub-)scope. This will make sure that Cmm annotations in our scope +-- will apply to the Cmm blocks generated therein - but not the other +-- way around. +tickScope :: FCode a -> FCode a +tickScope code = do + info <- getInfoDown + if not (gopt Opt_Debug (cgd_dflags info)) then code else do + u <- newUnique + let scope' = SubScope u (cgd_tick_scope info) + withInfoDown code info{ cgd_tick_scope = scope' } + + +-------------------------------------------------------- +-- Forking +-------------------------------------------------------- + +forkClosureBody :: FCode () -> FCode () +-- forkClosureBody compiles body_code in environment where: +-- - sequel, update stack frame and self loop info are +-- set to fresh values +-- - state is set to a fresh value, except for local bindings +-- that are passed in unchanged. It's up to the enclosed code to +-- re-bind the free variables to a field of the closure. + +forkClosureBody body_code + = do { dflags <- getDynFlags + ; info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_self_loop = Nothing } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + ((),fork_state_out) = doFCode body_code body_info_down fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out } + +forkLneBody :: FCode a -> FCode a +-- 'forkLneBody' takes a body of let-no-escape binding and compiles +-- it in the *current* environment, returning the graph thus constructed. +-- +-- The current environment is passed on completely unchanged to +-- the successor. In particular, any heap usage from the enclosed +-- code is discarded; it should deal with its own heap consumption. +forkLneBody body_code + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out + ; return result } + +codeOnly :: FCode () -> FCode () +-- Emit any code from the inner thing into the outer thing +-- Do not affect anything else in the outer state +-- Used in almost-circular code to prevent false loop dependencies +codeOnly body_code + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } + ((), fork_state_out) = doFCode body_code info_down fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out } + +forkAlts :: [FCode a] -> FCode [a] +-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and +-- an fcode for the default case 'd', and compiles each in the current +-- environment. The current environment is passed on unmodified, except +-- that the virtual Hp is moved on to the worst virtual Hp for the branches + +forkAlts branch_fcodes + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let compile us branch + = (us2, doFCode branch info_down branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state + , cgs_hp_usg = cgs_hp_usg state } + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + ; setState $ foldl stateIncUsage state branch_out_states + -- NB foldl. state is the *left* argument to stateIncUsage + ; return branch_results } + +-- collect the code emitted by an FCode computation +getCodeR :: FCode a -> FCode (a, CmmAGraph) +getCodeR fcode + = do { state1 <- getState + ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, cgs_stmts state2) } + +getCode :: FCode a -> FCode CmmAGraph +getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } + +-- | Generate code into a fresh tick (sub-)scope and gather generated code +getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped) +getCodeScoped fcode + = do { state1 <- getState + ; ((a, tscope), state2) <- + tickScope $ + flip withState state1 { cgs_stmts = mkNop } $ + do { a <- fcode + ; scp <- getTickScope + ; return (a, scp) } + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, (cgs_stmts state2, tscope)) } + + +-- 'getHeapUsage' applies a function to the amount of heap that it uses. +-- It initialises the heap usage to zeros, and passes on an unchanged +-- heap usage. +-- +-- It is usually a prelude to performing a GC check, so everything must +-- be in a tidy and consistent state. +-- +-- Note the slightly subtle fixed point behaviour needed here + +getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a +getHeapUsage fcode + = do { info_down <- getInfoDown + ; state <- getState + ; let fstate_in = state { cgs_hp_usg = initHpUsage } + (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in + hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! + + ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } + ; return r } + +-- ---------------------------------------------------------------------------- +-- Combinators for emitting code + +emitCgStmt :: CgStmt -> FCode () +emitCgStmt stmt + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } + } + +emitLabel :: BlockId -> FCode () +emitLabel id = do tscope <- getTickScope + emitCgStmt (CgLabel id tscope) + +emitComment :: FastString -> FCode () +#if 0 /* def DEBUG */ +emitComment s = emitCgStmt (CgStmt (CmmComment s)) +#else +emitComment _ = return () +#endif + +emitTick :: CmmTickish -> FCode () +emitTick = emitCgStmt . CgStmt . CmmTick + +emitUnwind :: GlobalReg -> CmmExpr -> FCode () +emitUnwind g e = do + dflags <- getDynFlags + when (gopt Opt_Debug dflags) $ + emitCgStmt $ CgStmt $ CmmUnwind g e + +emitAssign :: CmmReg -> CmmExpr -> FCode () +emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) + +emitStore :: CmmExpr -> CmmExpr -> FCode () +emitStore l r = emitCgStmt (CgStmt (CmmStore l r)) + + +newLabelC :: FCode BlockId +newLabelC = do { u <- newUnique + ; return $ mkBlockId u } + +emit :: CmmAGraph -> FCode () +emit ag + = do { state <- getState + ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } } + +emitDecl :: CmmDecl -> FCode () +emitDecl decl + = do { state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } + +emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode () +emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope) + +emitProcWithStackFrame + :: Convention -- entry convention + -> Maybe CmmInfoTable -- info table? + -> CLabel -- label for the proc + -> [CmmFormal] -- stack frame + -> [CmmFormal] -- arguments + -> CmmAGraphScoped -- code + -> Bool -- do stack layout? + -> FCode () + +emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False + = do { dflags <- getDynFlags + ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False + } +emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True + -- do layout + = do { dflags <- getDynFlags + ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + graph' = entry MkGraph.<*> graph + ; emitProc_ mb_info lbl live (graph', tscope) offset True + } +emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" + +emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel + -> [CmmFormal] + -> CmmAGraphScoped + -> FCode () +emitProcWithConvention conv mb_info lbl args blocks + = emitProcWithStackFrame conv mb_info lbl [] args blocks True + +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped + -> Int -> FCode () +emitProc mb_info lbl live blocks offset + = emitProc_ mb_info lbl live blocks offset True + +emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped + -> Int -> Bool -> FCode () +emitProc_ mb_info lbl live blocks offset do_layout + = do { dflags <- getDynFlags + ; l <- newLabelC + ; let + blks = labelAGraph l blocks + + infos | Just info <- mb_info = mapSingleton (g_entry blks) info + | otherwise = mapEmpty + + sinfo = StackInfo { arg_space = offset + , updfr_space = Just (initUpdFrameOff dflags) + , do_layout = do_layout } + + tinfo = TopInfo { info_tbls = infos + , stack_info=sinfo} + + proc_block = CmmProc tinfo lbl live blks + + ; state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } + +getCmm :: FCode () -> FCode CmmGroup +-- Get all the CmmTops (there should be no stmts) +-- Return a single Cmm which may be split from other Cmms by +-- object splitting (at a later stage) +getCmm code + = do { state1 <- getState + ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) + ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; return (fromOL (cgs_tops state2)) } + + +mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph +mkCmmIfThenElse e tbranch fbranch = do + tscp <- getTickScope + endif <- newLabelC + tid <- newLabelC + fid <- newLabelC + return $ catAGraphs [ mkCbranch e tid fid + , mkLabel tid tscp, tbranch, mkBranch endif + , mkLabel fid tscp, fbranch, mkLabel endif tscp ] + +mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph +mkCmmIfGoto e tid = do + endif <- newLabelC + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif, mkLabel endif tscp ] + +mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph +mkCmmIfThen e tbranch = do + endif <- newLabelC + tid <- newLabelC + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif + , mkLabel tid tscp, tbranch, mkLabel endif tscp ] + + +mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] + -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph +mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do + dflags <- getDynFlags + k <- newLabelC + tscp <- getTickScope + let area = Young k + (off, _, copyin) = copyInOflow dflags retConv area results [] + copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack + return $ catAGraphs [copyout, mkLabel k tscp, copyin] + +mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset + -> FCode CmmAGraph +mkCmmCall f results actuals updfr_off + = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off [] + + +-- ---------------------------------------------------------------------------- +-- turn CmmAGraph into CmmGraph, for making a new proc. + +aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph +aGraphToGraph stmts + = do { l <- newLabelC + ; return (labelAGraph l stmts) } diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs new file mode 100644 index 00000000..55b42646 --- /dev/null +++ b/compiler/codeGen/StgCmmPrim.hs @@ -0,0 +1,2157 @@ +{-# LANGUAGE CPP #-} + +---------------------------------------------------------------------------- +-- +-- Stg to C--: primitive operations +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmPrim ( + cgOpApp, + cgPrimOp, -- internal(ish), used by cgCase to get code for a + -- comparison without also turning it into a Bool. + shouldInlinePrimOp + ) where + +#include "HsVersions.h" + +import StgCmmLayout +import StgCmmForeign +import StgCmmEnv +import StgCmmMonad +import StgCmmUtils +import StgCmmTicky +import StgCmmHeap +import StgCmmProf ( costCentreFrom, curCCS ) + +import DynFlags +import Platform +import BasicTypes +import MkGraph +import StgSyn +import Cmm +import CmmInfo +import Type ( Type, tyConAppTyCon ) +import TyCon +import CLabel +import CmmUtils +import PrimOp +import SMRep +import FastString +import Outputable +import Util + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + +import Data.Bits ((.&.), bit) +import Control.Monad (liftM, when) + +------------------------------------------------------------------------ +-- Primitive operations and foreign calls +------------------------------------------------------------------------ + +{- Note [Foreign call results] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A foreign call always returns an unboxed tuple of results, one +of which is the state token. This seems to happen even for pure +calls. + +Even if we returned a single result for pure calls, it'd still be +right to wrap it in a singleton unboxed tuple, because the result +might be a Haskell closure pointer, we don't want to evaluate it. -} + +---------------------------------- +cgOpApp :: StgOp -- The op + -> [StgArg] -- Arguments + -> Type -- Result type (always an unboxed tuple) + -> FCode ReturnKind + +-- Foreign calls +cgOpApp (StgFCallOp fcall _) stg_args res_ty + = cgForeignCall fcall stg_args res_ty + -- Note [Foreign call results] + +-- tagToEnum# is special: we need to pull the constructor +-- out of the table, and perform an appropriate return. + +cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty + = ASSERT(isEnumerationTyCon tycon) + do { dflags <- getDynFlags + ; args' <- getNonVoidArgAmodes [arg] + ; let amode = case args' of [amode] -> amode + _ -> panic "TagToEnumOp had void arg" + ; emitReturn [tagToClosure dflags tycon amode] } + where + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + tycon = tyConAppTyCon res_ty + +cgOpApp (StgPrimOp primop) args res_ty = do + dflags <- getDynFlags + cmm_args <- getNonVoidArgAmodes args + case shouldInlinePrimOp dflags primop cmm_args of + Nothing -> do -- out-of-line + let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + emitCall (NativeNodeCall, NativeReturn) fun cmm_args + + Just f -- inline + | ReturnsPrim VoidRep <- result_info + -> do f [] + emitReturn [] + + | ReturnsPrim rep <- result_info + -> do dflags <- getDynFlags + res <- newTemp (primRepCmmType dflags rep) + f [res] + emitReturn [CmmReg (CmmLocal res)] + + | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon + -> do (regs, _hints) <- newUnboxedTupleRegs res_ty + f regs + emitReturn (map (CmmReg . CmmLocal) regs) + + | otherwise -> panic "cgPrimop" + where + result_info = getPrimOpResultInfo primop + +cgOpApp (StgPrimCallOp primcall) args _res_ty + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) + ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } + +-- | Interpret the argument as an unsigned value, assuming the value +-- is given in two-complement form in the given width. +-- +-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615. +-- +-- This function is used to work around the fact that many array +-- primops take Int# arguments, but we interpret them as unsigned +-- quantities in the code gen. This means that we have to be careful +-- every time we work on e.g. a CmmInt literal that corresponds to the +-- array size, as it might contain a negative Integer value if the +-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int# +-- literal. +asUnsigned :: Width -> Integer -> Integer +asUnsigned w n = n .&. (bit (widthInBits w) - 1) + +-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use +-- ByteOff (or some other fixed width signed type) to represent +-- array sizes or indices. This means that these will overflow for +-- large enough sizes. + +-- | Decide whether an out-of-line primop should be replaced by an +-- inline implementation. This might happen e.g. if there's enough +-- static information, such as statically know arguments, to emit a +-- more efficient implementation inline. +-- +-- Returns 'Nothing' if this primop should use its out-of-line +-- implementation (defined elsewhere) and 'Just' together with a code +-- generating function that takes the output regs as arguments +-- otherwise. +shouldInlinePrimOp :: DynFlags + -> PrimOp -- ^ The primop + -> [CmmExpr] -- ^ The primop arguments + -> Maybe ([LocalReg] -> FCode ()) + +shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))] + | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> doNewByteArrayOp res (fromInteger n) + +shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> + doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel + [ (mkIntExpr dflags (fromInteger n), + fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) + , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), + fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) + ] + (fromInteger n) init + +shouldInlinePrimOp _ CopyArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp _ CopyMutableArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp _ CopyArrayArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp _ CopyMutableArrayArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> + doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel + [ (mkIntExpr dflags (fromInteger n), + fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + ] + (fromInteger n) init + +shouldInlinePrimOp _ CopySmallArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp _ CopySmallMutableArrayOp + [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] = + Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n) + +shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))] + | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) = + Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) + +shouldInlinePrimOp dflags primop args + | primOpOutOfLine primop = Nothing + | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args + +-- TODO: Several primops, such as 'copyArray#', only have an inline +-- implementation (below) but could possibly have both an inline +-- implementation and an out-of-line implementation, just like +-- 'newArray#'. This would lower the amount of code generated, +-- hopefully without a performance impact (needs to be measured). + +--------------------------------------------------- +cgPrimOp :: [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [StgArg] -- arguments + -> FCode () + +cgPrimOp results op args + = do dflags <- getDynFlags + arg_exprs <- getNonVoidArgAmodes args + emitPrimOp dflags results op arg_exprs + + +------------------------------------------------------------------------ +-- Emitting code for a primop +------------------------------------------------------------------------ + +emitPrimOp :: DynFlags + -> [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [CmmExpr] -- arguments + -> FCode () + +-- First we handle various awkward cases specially. The remaining +-- easy cases are then handled by translateOp, defined below. + +emitPrimOp _ [res] ParOp [arg] + = + -- for now, just implement this in a C function + -- later, we might want to inline it. + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] + +emitPrimOp dflags [res] SparkOp [arg] + = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + tmp2 <- newTemp (bWord dflags) + emitCCall + [(tmp2,NoHint)] + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) + +emitPrimOp dflags [res] GetCCSOfOp [arg] + = emitAssign (CmmLocal res) val + where + val + | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) + +emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] + = emitAssign (CmmLocal res) curCCS + +emitPrimOp dflags [res] ReadMutVarOp [mutv] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags)) + +emitPrimOp dflags [] WriteMutVarOp [mutv,var] + = do emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var + emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = ((StgArrWords *)(a))->bytes +emitPrimOp dflags [res] SizeofByteArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = ((StgArrWords *)(a))->bytes +emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] + = emitPrimOp dflags [res] SizeofByteArrayOp [arg] + + +-- #define touchzh(o) /* nothing */ +emitPrimOp _ res@[] TouchOp args@[_arg] + = do emitPrimCall res MO_Touch args + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) +emitPrimOp dflags [res] ByteArrayContents_Char [arg] + = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)) + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) +emitPrimOp dflags [res] StableNameToIntOp [arg] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags)) + +-- #define eqStableNamezh(r,sn1,sn2) \ +-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) +emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ + cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags) + ]) + + +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) + +-- #define addrToHValuezh(r,a) r=(P_)a +emitPrimOp _ [res] AddrToAnyOp [arg] + = emitAssign (CmmLocal res) arg + +-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +-- Note: argument may be tagged! +emitPrimOp dflags [res] DataToTagOp [arg] + = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)) + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) +-- { +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); +-- r = a; +-- } +emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] + = emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)), + mkAssign (CmmLocal res) arg ] +emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] + = emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)), + mkAssign (CmmLocal res) arg ] +emitPrimOp _ [res] UnsafeFreezeSmallArrayOp [arg] + = emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN0_infoLabel)), + mkAssign (CmmLocal res) arg ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] + = emitAssign (CmmLocal res) arg + +-- Reading/writing pointer arrays + +emitPrimOp _ [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp _ [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp _ [res] ReadSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix +emitPrimOp _ [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix +emitPrimOp _ [] WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v + +-- Getting the size of pointer arrays + +emitPrimOp dflags [res] SizeofArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg + (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags)) + (bWord dflags)) +emitPrimOp dflags [res] SizeofMutableArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] + +emitPrimOp dflags [res] SizeofSmallArrayOp [arg] = + emit $ mkAssign (CmmLocal res) + (cmmLoadIndexW dflags arg + (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) + (bWord dflags)) +emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] = + emitPrimOp dflags [res] SizeofSmallArrayOp [arg] + +-- IndexXXXoffAddr + +emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + +emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args + +-- IndexXXXArray + +emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args + +-- ReadXXXArray, identical to IndexXXXArray. + +emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args + +-- WriteXXXoffAddr + +emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing f32 res args +emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing f64 res args +emitPrimOp dflags res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing b64 res args +emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing b64 res args + +-- WriteXXXArray + +emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing f32 res args +emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing f64 res args +emitPrimOp dflags res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing b64 res args +emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing b64 res args + +-- Copying and setting byte arrays +emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyByteArrayOp src src_off dst dst_off n +emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableByteArrayOp src src_off dst dst_off n +emitPrimOp _ [] CopyByteArrayToAddrOp [src,src_off,dst,n] = + doCopyByteArrayToAddrOp src src_off dst n +emitPrimOp _ [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] = + doCopyMutableByteArrayToAddrOp src src_off dst n +emitPrimOp _ [] CopyAddrToByteArrayOp [src,dst,dst_off,n] = + doCopyAddrToByteArrayOp src dst dst_off n +emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = + doSetByteArrayOp ba off len c + +emitPrimOp _ [res] BSwap16Op [w] = emitBSwapCall res w W16 +emitPrimOp _ [res] BSwap32Op [w] = emitBSwapCall res w W32 +emitPrimOp _ [res] BSwap64Op [w] = emitBSwapCall res w W64 +emitPrimOp dflags [res] BSwapOp [w] = emitBSwapCall res w (wordWidth dflags) + +-- Population count +emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8 +emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16 +emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32 +emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 +emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags) + +-- count leading zeros +emitPrimOp _ [res] Clz8Op [w] = emitClzCall res w W8 +emitPrimOp _ [res] Clz16Op [w] = emitClzCall res w W16 +emitPrimOp _ [res] Clz32Op [w] = emitClzCall res w W32 +emitPrimOp _ [res] Clz64Op [w] = emitClzCall res w W64 +emitPrimOp dflags [res] ClzOp [w] = emitClzCall res w (wordWidth dflags) + +-- count trailing zeros +emitPrimOp _ [res] Ctz8Op [w] = emitCtzCall res w W8 +emitPrimOp _ [res] Ctz16Op [w] = emitCtzCall res w W16 +emitPrimOp _ [res] Ctz32Op [w] = emitCtzCall res w W32 +emitPrimOp _ [res] Ctz64Op [w] = emitCtzCall res w W64 +emitPrimOp dflags [res] CtzOp [w] = emitCtzCall res w (wordWidth dflags) + +-- Unsigned int to floating point conversions +emitPrimOp _ [res] Word2FloatOp [w] = emitPrimCall [res] + (MO_UF_Conv W32) [w] +emitPrimOp _ [res] Word2DoubleOp [w] = emitPrimCall [res] + (MO_UF_Conv W64) [w] + +-- SIMD primops +emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do + checkVecCompatibility dflags vcat n w + doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res + where + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags [res] (VecPackOp vcat n w) es = do + checkVecCompatibility dflags vcat n w + when (length es /= n) $ + panic "emitPrimOp: VecPackOp has wrong number of arguments" + doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res + where + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do + checkVecCompatibility dflags vcat n w + when (length res /= n) $ + panic "emitPrimOp: VecUnpackOp has wrong number of results" + doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do + checkVecCompatibility dflags vcat n w + doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doWriteByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doWriteOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOpAs Nothing vecty ty res args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexByteArrayOpAs Nothing vecty ty res args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doWriteByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOpAs Nothing vecty ty res args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doIndexOffAddrOpAs Nothing vecty ty res args + where + vecty :: CmmType + vecty = vecVmmType vcat n w + + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do + checkVecCompatibility dflags vcat n w + doWriteOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecCmmCat vcat w + +-- Prefetch +emitPrimOp _ [] PrefetchByteArrayOp3 args = doPrefetchByteArrayOp 3 args +emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3 args +emitPrimOp _ [] PrefetchAddrOp3 args = doPrefetchAddrOp 3 args +emitPrimOp _ [] PrefetchValueOp3 args = doPrefetchValueOp 3 args + +emitPrimOp _ [] PrefetchByteArrayOp2 args = doPrefetchByteArrayOp 2 args +emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2 args +emitPrimOp _ [] PrefetchAddrOp2 args = doPrefetchAddrOp 2 args +emitPrimOp _ [] PrefetchValueOp2 args = doPrefetchValueOp 2 args + +emitPrimOp _ [] PrefetchByteArrayOp1 args = doPrefetchByteArrayOp 1 args +emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1 args +emitPrimOp _ [] PrefetchAddrOp1 args = doPrefetchAddrOp 1 args +emitPrimOp _ [] PrefetchValueOp1 args = doPrefetchValueOp 1 args + +emitPrimOp _ [] PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 args +emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0 args +emitPrimOp _ [] PrefetchAddrOp0 args = doPrefetchAddrOp 0 args +emitPrimOp _ [] PrefetchValueOp0 args = doPrefetchValueOp 0 args + +-- Atomic read-modify-write +emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Add mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Sub mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_And mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Nand mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Or mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Xor mba ix (bWord dflags) n +emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = + doAtomicReadByteArray res mba ix (bWord dflags) +emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = + doAtomicWriteByteArray mba ix (bWord dflags) val +emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = + doCasByteArray res mba ix (bWord dflags) old new + +-- The rest just translate straightforwardly +emitPrimOp dflags [res] op [arg] + | nopOp op + = emitAssign (CmmLocal res) arg + + | Just (mop,rep) <- narrowOp op + = emitAssign (CmmLocal res) $ + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] + +emitPrimOp dflags r@[res] op args + | Just prim <- callishOp op + = do emitPrimCall r prim args + + | Just mop <- translateOp dflags op + = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in + emit stmt + +emitPrimOp dflags results op args + = case callishPrimOpSupported dflags op of + Left op -> emit $ mkUnsafeCall (PrimTarget op) results args + Right gen -> gen results args + +type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () + +callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp +callishPrimOpSupported dflags op + = case op of + IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericIntQuotRemOp dflags) + + WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRemOp dflags) + + WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRem2Op dflags) + + WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) + | otherwise -> Right genericWordAdd2Op + + IntAddCOp | ncg && x86ish -> Left (MO_AddIntC (wordWidth dflags)) + | otherwise -> Right genericIntAddCOp + + IntSubCOp | ncg && x86ish -> Left (MO_SubIntC (wordWidth dflags)) + | otherwise -> Right genericIntSubCOp + + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) + | otherwise -> Right genericWordMul2Op + + _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op) + where + ncg = case hscTarget dflags of + HscAsm -> True + _ -> False + + x86ish = case platformArch (targetPlatform dflags) of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + +genericIntQuotRemOp :: DynFlags -> GenericOp +genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" + +genericWordQuotRemOp :: DynFlags -> GenericOp +genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" + +genericWordQuotRem2Op :: DynFlags -> GenericOp +genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] + = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + where ty = cmmExprType dflags arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + zero = lit 0 + one = lit 1 + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) + + f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph + f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> + mkAssign (CmmLocal res_r) high) + f i acc high low = + do roverflowedBit <- newTemp ty + rhigh' <- newTemp ty + rhigh'' <- newTemp ty + rlow' <- newTemp ty + risge <- newTemp ty + racc' <- newTemp ty + let high' = CmmReg (CmmLocal rhigh') + isge = CmmReg (CmmLocal risge) + overflowedBit = CmmReg (CmmLocal roverflowedBit) + let this = catAGraphs + [mkAssign (CmmLocal roverflowedBit) + (shr high negone), + mkAssign (CmmLocal rhigh') + (or (shl high one) (shr low negone)), + mkAssign (CmmLocal rlow') + (shl low one), + mkAssign (CmmLocal risge) + (or (overflowedBit `ne` zero) + (high' `ge` arg_y)), + mkAssign (CmmLocal rhigh'') + (high' `minus` (arg_y `times` isge)), + mkAssign (CmmLocal racc') + (or (shl acc one) isge)] + rest <- f (i - 1) (CmmReg (CmmLocal racc')) + (CmmReg (CmmLocal rhigh'')) + (CmmReg (CmmLocal rlow')) + return (this <*> rest) +genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" + +genericWordAdd2Op :: GenericOp +genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] + = do dflags <- getDynFlags + r1 <- newTemp (cmmExprType dflags arg_x) + r2 <- newTemp (cmmExprType dflags arg_x) + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + emit $ catAGraphs + [mkAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + mkAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + mkAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] +genericWordAdd2Op _ _ = panic "genericWordAdd2Op" + +genericIntAddCOp :: GenericOp +genericIntAddCOp [res_r, res_c] [aa, bb] +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntAddCOp _ _ = panic "genericIntAddCOp" + +genericIntSubCOp :: GenericOp +genericIntSubCOp [res_r, res_c] [aa, bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = do dflags <- getDynFlags + emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] + ], + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) + ] + ] +genericIntSubCOp _ _ = panic "genericIntSubCOp" + +genericWordMul2Op :: GenericOp +genericWordMul2Op [res_h, res_l] [arg_x, arg_y] + = do dflags <- getDynFlags + let t = cmmExprType dflags arg_x + xlyl <- liftM CmmLocal $ newTemp t + xlyh <- liftM CmmLocal $ newTemp t + xhyl <- liftM CmmLocal $ newTemp t + r <- liftM CmmLocal $ newTemp t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + emit $ catAGraphs + [mkAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + mkAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + mkAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + mkAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + mkAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] +genericWordMul2Op _ _ = panic "genericWordMul2Op" + +-- These PrimOps are NOPs in Cmm + +nopOp :: PrimOp -> Bool +nopOp Int2WordOp = True +nopOp Word2IntOp = True +nopOp Int2AddrOp = True +nopOp Addr2IntOp = True +nopOp ChrOp = True -- Int# and Char# are rep'd the same +nopOp OrdOp = True +nopOp _ = False + +-- These PrimOps turn into double casts + +narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width) +narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8) +narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16) +narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) +narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) +narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) +narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) +narrowOp _ = Nothing + +-- Native word signless ops + +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) + +-- Native word signed ops + +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) + + +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) + +translateOp dflags AndIOp = Just (mo_wordAnd dflags) +translateOp dflags OrIOp = Just (mo_wordOr dflags) +translateOp dflags XorIOp = Just (mo_wordXor dflags) +translateOp dflags NotIOp = Just (mo_wordNot dflags) +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) + +-- Native word unsigned ops + +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) + +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) + +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) + +-- Char# ops + +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) + +-- Double ops + +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) + +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) + +-- Float ops + +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) + +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) + +-- Vector ops + +translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add n w) +translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub n w) +translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul n w) +translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w) +translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg n w) + +translateOp _ (VecAddOp IntVec n w) = Just (MO_V_Add n w) +translateOp _ (VecSubOp IntVec n w) = Just (MO_V_Sub n w) +translateOp _ (VecMulOp IntVec n w) = Just (MO_V_Mul n w) +translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w) +translateOp _ (VecRemOp IntVec n w) = Just (MO_VS_Rem n w) +translateOp _ (VecNegOp IntVec n w) = Just (MO_VS_Neg n w) + +translateOp _ (VecAddOp WordVec n w) = Just (MO_V_Add n w) +translateOp _ (VecSubOp WordVec n w) = Just (MO_V_Sub n w) +translateOp _ (VecMulOp WordVec n w) = Just (MO_V_Mul n w) +translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w) +translateOp _ (VecRemOp WordVec n w) = Just (MO_VU_Rem n w) + +-- Conversions + +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) + +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) + +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) + +-- Word comparisons masquerading as more exotic things. + +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) + +translateOp _ _ = Nothing + +-- These primops are implemented by CallishMachOps, because they sometimes +-- turn into foreign calls depending on the backend. + +callishOp :: PrimOp -> Maybe CallishMachOp +callishOp DoublePowerOp = Just MO_F64_Pwr +callishOp DoubleSinOp = Just MO_F64_Sin +callishOp DoubleCosOp = Just MO_F64_Cos +callishOp DoubleTanOp = Just MO_F64_Tan +callishOp DoubleSinhOp = Just MO_F64_Sinh +callishOp DoubleCoshOp = Just MO_F64_Cosh +callishOp DoubleTanhOp = Just MO_F64_Tanh +callishOp DoubleAsinOp = Just MO_F64_Asin +callishOp DoubleAcosOp = Just MO_F64_Acos +callishOp DoubleAtanOp = Just MO_F64_Atan +callishOp DoubleLogOp = Just MO_F64_Log +callishOp DoubleExpOp = Just MO_F64_Exp +callishOp DoubleSqrtOp = Just MO_F64_Sqrt + +callishOp FloatPowerOp = Just MO_F32_Pwr +callishOp FloatSinOp = Just MO_F32_Sin +callishOp FloatCosOp = Just MO_F32_Cos +callishOp FloatTanOp = Just MO_F32_Tan +callishOp FloatSinhOp = Just MO_F32_Sinh +callishOp FloatCoshOp = Just MO_F32_Cosh +callishOp FloatTanhOp = Just MO_F32_Tanh +callishOp FloatAsinOp = Just MO_F32_Asin +callishOp FloatAcosOp = Just MO_F32_Acos +callishOp FloatAtanOp = Just MO_F32_Atan +callishOp FloatLogOp = Just MO_F32_Log +callishOp FloatExpOp = Just MO_F32_Exp +callishOp FloatSqrtOp = Just MO_F32_Sqrt + +callishOp _ = Nothing + +------------------------------------------------------------------------------ +-- Helpers for translating various minor variants of array indexing. + +doIndexOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx +doIndexOffAddrOp _ _ _ _ + = panic "StgCmmPrim: doIndexOffAddrOp" + +doIndexOffAddrOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx +doIndexOffAddrOpAs _ _ _ _ _ + = panic "StgCmmPrim: doIndexOffAddrOpAs" + +doIndexByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx +doIndexByteArrayOp _ _ _ _ + = panic "StgCmmPrim: doIndexByteArrayOp" + +doIndexByteArrayOpAs :: Maybe MachOp + -> CmmType + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] + = do dflags <- getDynFlags + mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx +doIndexByteArrayOpAs _ _ _ _ _ + = panic "StgCmmPrim: doIndexByteArrayOpAs" + +doReadPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadPtrArrayOp res addr idx + = do dflags <- getDynFlags + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx + +doWriteOffAddrOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val] + = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val +doWriteOffAddrOp _ _ _ _ + = panic "StgCmmPrim: doWriteOffAddrOp" + +doWriteByteArrayOp :: Maybe MachOp + -> CmmType + -> [LocalReg] + -> [CmmExpr] + -> FCode () +doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] + = do dflags <- getDynFlags + mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val +doWriteByteArrayOp _ _ _ _ + = panic "StgCmmPrim: doWriteByteArrayOp" + +doWritePtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWritePtrArrayOp addr idx val + = do dflags <- getDynFlags + let ty = cmmExprType dflags val + mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + emit $ mkStore ( + cmmOffsetExpr dflags + (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) + (loadArrPtrsSize dflags addr)) + (CmmMachOp (mo_wordUShr dflags) [idx, + mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) + ) (CmmLit (CmmInt 1 W8)) + +loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) + where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags + +mkBasicIndexedRead :: ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional result cast + -> CmmType -- Type of element we are accessing + -> LocalReg -- Destination + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> FCode () +mkBasicIndexedRead off Nothing ty res base idx_ty idx + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx) +mkBasicIndexedRead off (Just cast) ty res base idx_ty idx + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr dflags off ty base idx_ty idx]) + +mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional value cast + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr -- Value to write + -> FCode () +mkBasicIndexedWrite off Nothing base idx_ty idx val + = do dflags <- getDynFlags + emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val +mkBasicIndexedWrite off (Just cast) base idx_ty idx val + = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) + +-- ---------------------------------------------------------------------------- +-- Misc utils + +cmmIndexOffExpr :: DynFlags + -> ByteOff -- Initial offset in bytes + -> Width -- Width of element by which we are indexing + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> CmmExpr +cmmIndexOffExpr dflags off width base idx + = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx + +cmmLoadIndexOffExpr :: DynFlags + -> ByteOff -- Initial offset in bytes + -> CmmType -- Type of element we are accessing + -> CmmExpr -- Base address + -> CmmType -- Type of element by which we are indexing + -> CmmExpr -- Index + -> CmmExpr +cmmLoadIndexOffExpr dflags off ty base idx_ty idx + = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty + +setInfo :: CmmExpr -> CmmExpr -> CmmAGraph +setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr + +------------------------------------------------------------------------------ +-- Helpers for translating vector primops. + +vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType +vecVmmType pocat n w = vec n (vecCmmCat pocat w) + +vecCmmCat :: PrimOpVecCat -> Width -> CmmType +vecCmmCat IntVec = cmmBits +vecCmmCat WordVec = cmmBits +vecCmmCat FloatVec = cmmFloat + +vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemInjectCast _ FloatVec _ = Nothing +vecElemInjectCast dflags IntVec W8 = Just (mo_WordTo8 dflags) +vecElemInjectCast dflags IntVec W16 = Just (mo_WordTo16 dflags) +vecElemInjectCast dflags IntVec W32 = Just (mo_WordTo32 dflags) +vecElemInjectCast _ IntVec W64 = Nothing +vecElemInjectCast dflags WordVec W8 = Just (mo_WordTo8 dflags) +vecElemInjectCast dflags WordVec W16 = Just (mo_WordTo16 dflags) +vecElemInjectCast dflags WordVec W32 = Just (mo_WordTo32 dflags) +vecElemInjectCast _ WordVec W64 = Nothing +vecElemInjectCast _ _ _ = Nothing + +vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemProjectCast _ FloatVec _ = Nothing +vecElemProjectCast dflags IntVec W8 = Just (mo_s_8ToWord dflags) +vecElemProjectCast dflags IntVec W16 = Just (mo_s_16ToWord dflags) +vecElemProjectCast dflags IntVec W32 = Just (mo_s_32ToWord dflags) +vecElemProjectCast _ IntVec W64 = Nothing +vecElemProjectCast dflags WordVec W8 = Just (mo_u_8ToWord dflags) +vecElemProjectCast dflags WordVec W16 = Just (mo_u_16ToWord dflags) +vecElemProjectCast dflags WordVec W32 = Just (mo_u_32ToWord dflags) +vecElemProjectCast _ WordVec W64 = Nothing +vecElemProjectCast _ _ _ = Nothing + +-- Check to make sure that we can generate code for the specified vector type +-- given the current set of dynamic flags. +checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () +checkVecCompatibility dflags vcat l w = do + when (hscTarget dflags /= HscLlvm) $ do + sorry $ unlines ["SIMD vector instructions require the LLVM back-end." + ,"Please use -fllvm."] + check vecWidth vcat l w + where + check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () + check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = + sorry $ "128-bit wide single-precision floating point " ++ + "SIMD vector instructions require at least -msse." + check W128 _ _ _ | not (isSse2Enabled dflags) = + sorry $ "128-bit wide integer and double precision " ++ + "SIMD vector instructions require at least -msse2." + check W256 FloatVec _ _ | not (isAvxEnabled dflags) = + sorry $ "256-bit wide floating point " ++ + "SIMD vector instructions require at least -mavx." + check W256 _ _ _ | not (isAvx2Enabled dflags) = + sorry $ "256-bit wide integer " ++ + "SIMD vector instructions require at least -mavx2." + check W512 _ _ _ | not (isAvx512fEnabled dflags) = + sorry $ "512-bit wide " ++ + "SIMD vector instructions require -mavx512f." + check _ _ _ _ = return () + + vecWidth = typeWidth (vecVmmType vcat l w) + +------------------------------------------------------------------------------ +-- Helpers for translating vector packing and unpacking. + +doVecPackOp :: Maybe MachOp -- Cast from element to vector component + -> CmmType -- Type of vector + -> CmmExpr -- Initial vector + -> [CmmExpr] -- Elements + -> CmmFormal -- Destination for result + -> FCode () +doVecPackOp maybe_pre_write_cast ty z es res = do + dst <- newTemp ty + emitAssign (CmmLocal dst) z + vecPack dst es 0 + where + vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode () + vecPack src [] _ = + emitAssign (CmmLocal res) (CmmReg (CmmLocal src)) + + vecPack src (e : es) i = do + dst <- newTemp ty + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) + [CmmReg (CmmLocal src), cast e, iLit]) + vecPack dst es (i + 1) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + cast :: CmmExpr -> CmmExpr + cast val = case maybe_pre_write_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecUnpackOp :: Maybe MachOp -- Cast from vector component to element result + -> CmmType -- Type of vector + -> CmmExpr -- Vector + -> [CmmFormal] -- Element results + -> FCode () +doVecUnpackOp maybe_post_read_cast ty e res = + vecUnpack res 0 + where + vecUnpack :: [CmmFormal] -> Int -> FCode () + vecUnpack [] _ = + return () + + vecUnpack (r : rs) i = do + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid) + [e, iLit])) + else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid) + [e, iLit])) + vecUnpack rs (i + 1) + where + -- vector indices are always 32-bits + iLit = CmmLit (CmmInt (toInteger i) W32) + + cast :: CmmExpr -> CmmExpr + cast val = case maybe_post_read_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +doVecInsertOp :: Maybe MachOp -- Cast from element to vector component + -> CmmType -- Vector type + -> CmmExpr -- Source vector + -> CmmExpr -- Element + -> CmmExpr -- Index at which to insert element + -> CmmFormal -- Destination for result + -> FCode () +doVecInsertOp maybe_pre_write_cast ty src e idx res = do + dflags <- getDynFlags + -- vector indices are always 32-bits + let idx' :: CmmExpr + idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx] + if isFloatType (vecElemType ty) + then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx']) + else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx']) + where + cast :: CmmExpr -> CmmExpr + cast val = case maybe_pre_write_cast of + Nothing -> val + Just cast -> CmmMachOp cast [val] + + len :: Length + len = vecLength ty + + wid :: Width + wid = typeWidth (vecElemType ty) + +------------------------------------------------------------------------------ +-- Helpers for translating prefetching. + + +-- | Translate byte array prefetch operations into proper primcalls. +doPrefetchByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchByteArrayOp locality [addr,idx] + = do dflags <- getDynFlags + mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx +doPrefetchByteArrayOp _ _ + = panic "StgCmmPrim: doPrefetchByteArrayOp" + +-- | Translate mutable byte array prefetch operations into proper primcalls. +doPrefetchMutableByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchMutableByteArrayOp locality [addr,idx] + = do dflags <- getDynFlags + mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx +doPrefetchMutableByteArrayOp _ _ + = panic "StgCmmPrim: doPrefetchByteArrayOp" + +-- | Translate address prefetch operations into proper primcalls. +doPrefetchAddrOp ::Int + -> [CmmExpr] + -> FCode () +doPrefetchAddrOp locality [addr,idx] + = mkBasicPrefetch locality 0 addr idx +doPrefetchAddrOp _ _ + = panic "StgCmmPrim: doPrefetchAddrOp" + +-- | Translate value prefetch operations into proper primcalls. +doPrefetchValueOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchValueOp locality [addr] + = do dflags <- getDynFlags + mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth dflags))) +doPrefetchValueOp _ _ + = panic "StgCmmPrim: doPrefetchValueOp" + +-- | helper to generate prefetch primcalls +mkBasicPrefetch :: Int -- Locality level 0-3 + -> ByteOff -- Initial offset in bytes + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> FCode () +mkBasicPrefetch locality off base idx + = do dflags <- getDynFlags + emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx] + return () + +-- ---------------------------------------------------------------------------- +-- Allocating byte arrays + +-- | Takes a register to return the newly allocated array in and the +-- size of the new array in bytes. Allocates a new +-- 'MutableByteArray#'. +doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () +doNewByteArrayOp res_r n = do + dflags <- getDynFlags + + let info_ptr = mkLblExpr mkArrWords_infoLabel + rep = arrWordsRep dflags n + + tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags)) + (mkIntExpr dflags (nonHdrSize dflags rep)) + (zeroExpr dflags) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr curCCS + [ (mkIntExpr dflags n, + hdr_size + oFFSET_StgArrWords_bytes dflags) + ] + + emit $ mkAssign (CmmLocal res_r) base + +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + dflags <- getDynFlags + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) + ] + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + dflags <- getDynFlags + dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off + copy src dst dst_p src_p n + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyByteArrayToAddrOp src src_off dst_p bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + dflags <- getDynFlags + src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) + +-- | Takes a source 'MutableByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp + +-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into +-- the destination array, and the number of bytes to copy. Copies the given +-- number of bytes from the source memory region to the destination array. +doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToByteArrayOp src_p dst dst_off bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + dflags <- getDynFlags + dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) + + +-- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c + = do dflags <- getDynFlags + p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (mkIntExpr dflags 1) + +-- ---------------------------------------------------------------------------- +-- Allocating arrays + +-- | Allocate a new array. +doNewArrayOp :: CmmFormal -- ^ return register + -> SMRep -- ^ representation of the array + -> CLabel -- ^ info pointer + -> [(CmmExpr, ByteOff)] -- ^ header payload + -> WordOff -- ^ array size + -> CmmExpr -- ^ initial element + -> FCode () +doNewArrayOp res_r rep info payload n init = do + dflags <- getDynFlags + + let info_ptr = mkLblExpr info + + tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep)) + (mkIntExpr dflags (nonHdrSize dflags rep)) + (zeroExpr dflags) + + base <- allocHeapClosure rep info_ptr curCCS payload + + arr <- CmmLocal `fmap` newTemp (bWord dflags) + emit $ mkAssign arr base + + -- Initialise all elements of the the array + p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep) + for <- newLabelC + emitLabel for + let loopBody = + [ mkStore (CmmReg (CmmLocal p)) init + , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1) + , mkBranch for ] + emit =<< mkCmmIfThen + (cmmULtWord dflags (CmmReg (CmmLocal p)) + (cmmOffsetW dflags (CmmReg arr) + (hdrSizeW dflags rep + n))) + (catAGraphs loopBody) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + dflags <- getDynFlags + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)), + getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)) + ] + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopyArray copy src0 src_off dst0 dst_off0 n = do + dflags <- getDynFlags + when (n /= 0) $ do + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB dflags dst + (arrPtrsHdrSize dflags) + dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW dflags + (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off + let bytes = wordsToBytes dflags n + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p + (loadArrPtrsSize dflags dst) + + emitSetCards dst_off dst_cards_p n + +doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallArrayOp = emitCopySmallArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)) + + +doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallMutableArrayOp = emitCopySmallArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + dflags <- getDynFlags + [moveCall, cpyCall] <- forkAlts + [ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)) + , getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes) + (mkIntExpr dflags (wORD_SIZE dflags)) + ] + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall + +emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopySmallArray copy src0 src_off dst0 dst_off n = do + dflags <- getDynFlags + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + + dst_p <- assignTempE $ cmmOffsetExprW dflags + (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExprW dflags + (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off + let bytes = wordsToBytes dflags n + + copy src dst dst_p src_p bytes + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneArray info_p res_r src src_off n = do + dflags <- getDynFlags + + let info_ptr = mkLblExpr info_p + rep = arrPtrsRep dflags n + + tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) + (mkIntExpr dflags (nonHdrSize dflags rep)) + (zeroExpr dflags) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr curCCS + [ (mkIntExpr dflags n, + hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) + , (mkIntExpr dflags (nonHdrSizeW rep), + hdr_size + oFFSET_StgMutArrPtrs_size dflags) + ] + + arr <- CmmLocal `fmap` newTemp (bWord dflags) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) + (arrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW dflags src + (cmmAddWord dflags + (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) + (mkIntExpr dflags (wORD_SIZE dflags)) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneSmallArray info_p res_r src src_off n = do + dflags <- getDynFlags + + let info_ptr = mkLblExpr info_p + rep = smallArrPtrsRep n + + tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags)) + (mkIntExpr dflags (nonHdrSize dflags rep)) + (zeroExpr dflags) + + let hdr_size = fixedHdrSize dflags + + base <- allocHeapClosure rep info_ptr curCCS + [ (mkIntExpr dflags n, + hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + ] + + arr <- CmmLocal `fmap` newTemp (bWord dflags) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr) + (smallArrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW dflags src + (cmmAddWord dflags + (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n)) + (mkIntExpr dflags (wORD_SIZE dflags)) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes and offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). The number of elements may not be zero. +-- Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () +emitSetCards dst_start dst_cards_start n = do + dflags <- getDynFlags + start_card <- assignTempE $ cardCmm dflags dst_start + let end_card = cardCmm dflags + (cmmSubWord dflags + (cmmAddWord dflags dst_start (mkIntExpr dflags n)) + (mkIntExpr dflags 1)) + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (mkIntExpr dflags 1) + (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1)) + (mkIntExpr dflags 1) -- no alignment (1 byte) + +-- Convert an element index to a card index +cardCmm :: DynFlags -> CmmExpr -> CmmExpr +cardCmm dflags i = + cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)) + +------------------------------------------------------------------------------ +-- SmallArray PrimOp implementations + +doReadSmallPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadSmallPtrArrayOp res addr idx = do + dflags <- getDynFlags + mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr + (gcWord dflags) idx + +doWriteSmallPtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWriteSmallPtrArrayOp addr idx val = do + dflags <- getDynFlags + let ty = cmmExprType dflags val + mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + +------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ +-- Helpers for emitting function calls + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemcpyCall dst src n align = do + emitPrimCall + [ {-no results-} ] + MO_Memcpy + [ dst, src, n, align ] + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemmoveCall dst src n align = do + emitPrimCall + [ {- no results -} ] + MO_Memmove + [ dst, src, n, align ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemsetCall dst c n align = do + emitPrimCall + [ {- no results -} ] + MO_Memset + [ dst, c, n, align ] + +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = do + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + +emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitPopCntCall res x width = do + emitPrimCall + [ res ] + (MO_PopCnt width) + [ x ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = do + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = do + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs new file mode 100644 index 00000000..7249477c --- /dev/null +++ b/compiler/codeGen/StgCmmProf.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Code generation for profiling +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmProf ( + initCostCentres, ccType, ccsType, + mkCCostCentre, mkCCostCentreStack, + + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + enterCostCentreThunk, enterCostCentreFun, + costCentreFrom, + curCCS, storeCurCCS, + emitSetCCC, + + saveCurrentCostCentre, restoreCurrentCostCentre, + + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate + ) where + +#include "HsVersions.h" + +import StgCmmClosure +import StgCmmUtils +import StgCmmMonad +import SMRep + +import MkGraph +import Cmm +import CmmUtils +import CLabel + +import qualified Module +import CostCentre +import DynFlags +import FastString +import Module +import Outputable + +import Control.Monad +import Data.Char (ord) + +----------------------------------------------------------------------------- +-- +-- Cost-centre-stack Profiling +-- +----------------------------------------------------------------------------- + +-- Expression representing the current cost centre stack +ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack +ccsType = bWord + +ccType :: DynFlags -> CmmType -- Type of a cost centre +ccType = bWord + +curCCS :: CmmExpr +curCCS = CmmReg (CmmGlobal CCCS) + +storeCurCCS :: CmmExpr -> CmmAGraph +storeCurCCS e = mkAssign (CmmGlobal CCCS) e + +mkCCostCentre :: CostCentre -> CmmLit +mkCCostCentre cc = CmmLabel (mkCCLabel cc) + +mkCCostCentreStack :: CostCentreStack -> CmmLit +mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) + +costCentreFrom :: DynFlags + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure +costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) + +-- | The profiling header words in a static closure +staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] +staticProfHdr dflags ccs + = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] + +-- | Profiling header words in a dynamic closure +dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] + +-- | Initialise the profiling field of an update frame +initUpdFrameProf :: CmmExpr -> FCode () +initUpdFrameProf frame + = ifProfiling $ -- frame->header.prof.ccs = CCCS + do dflags <- getDynFlags + emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + -- is unnecessary because it is not used anyhow. + +--------------------------------------------------------------------------- +-- Saving and restoring the current cost centre +--------------------------------------------------------------------------- + +{- Note [Saving the current cost centre] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current cost centre is like a global register. Like other +global registers, it's a caller-saves one. But consider + case (f x) of (p,q) -> rhs +Since 'f' may set the cost centre, we must restore it +before resuming rhs. So we want code like this: + local_cc = CCC -- save + r = f( x ) + CCC = local_cc -- restore +That is, we explicitly "save" the current cost centre in +a LocalReg, local_cc; and restore it after the call. The +C-- infrastructure will arrange to save local_cc across the +call. + +The same goes for join points; + let j x = join-stuff + in blah-blah +We want this kind of code: + local_cc = CCC -- save + blah-blah + J: + CCC = local_cc -- restore +-} + +saveCurrentCostCentre :: FCode (Maybe LocalReg) + -- Returns Nothing if profiling is off +saveCurrentCostCentre + = do dflags <- getDynFlags + if not (gopt Opt_SccProfilingOn dflags) + then return Nothing + else do local_cc <- newTemp (ccType dflags) + emitAssign (CmmLocal local_cc) curCCS + return (Just local_cc) + +restoreCurrentCostCentre :: Maybe LocalReg -> FCode () +restoreCurrentCostCentre Nothing + = return () +restoreCurrentCostCentre (Just local_cc) + = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) + + +------------------------------------------------------------------------------- +-- Recording allocation in a cost centre +------------------------------------------------------------------------------- + +-- | Record the allocation of a closure. The CmmExpr is the cost +-- centre stack to which to attribute the allocation. +profDynAlloc :: SMRep -> CmmExpr -> FCode () +profDynAlloc rep ccs + = ifProfiling $ + do dflags <- getDynFlags + profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs + +-- | Record the allocation of a closure (size is given by a CmmExpr) +-- The size must be in words, because the allocation counter in a CCS counts +-- in words. +profAlloc :: CmmExpr -> CmmExpr -> FCode () +profAlloc words ccs + = ifProfiling $ + do dflags <- getDynFlags + let alloc_rep = rEP_CostCentreStack_mem_alloc dflags + emit (addToMemE alloc_rep + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. + +-- ----------------------------------------------------------------------- +-- Setting the current cost centre on entry to a closure + +enterCostCentreThunk :: CmmExpr -> FCode () +enterCostCentreThunk closure = + ifProfiling $ do + dflags <- getDynFlags + emit $ storeCurCCS (costCentreFrom dflags closure) + +enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () +enterCostCentreFun ccs closure = + ifProfiling $ do + if isCurrentCCS ccs + then do dflags <- getDynFlags + emitRtsCall rtsPackageKey (fsLit "enterFunCCS") + [(CmmReg (CmmGlobal BaseReg), AddrHint), + (costCentreFrom dflags closure, AddrHint)] False + else return () -- top-level function, nothing to do + +ifProfiling :: FCode () -> FCode () +ifProfiling code + = do dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then code + else return () + +ifProfilingL :: DynFlags -> [a] -> [a] +ifProfilingL dflags xs + | gopt Opt_SccProfilingOn dflags = xs + | otherwise = [] + + +--------------------------------------------------------------- +-- Initialising Cost Centres & CCSs +--------------------------------------------------------------- + +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations +initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) + = do dflags <- getDynFlags + when (gopt Opt_SccProfilingOn dflags) $ + do mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + + +emitCostCentreDecl :: CostCentre -> FCode () +emitCostCentreDecl cc = do + { dflags <- getDynFlags + ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags + -- NB. bytesFS: we want the UTF-8 bytes here (#5559) + ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) + ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS + $ Module.moduleName + $ cc_mod cc) + ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ + showPpr dflags (costCentreSrcSpan cc) + -- XXX going via FastString to get UTF-8 encoding is silly + ; let + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, + loc, -- char *srcloc, + zero64, -- StgWord64 mem_alloc + zero dflags, -- StgWord time_ticks + is_caf, -- StgInt is_caf + zero dflags -- struct _CostCentre *link + ] + ; emitDataLits (mkCCLabel cc) lits + } + +emitCostCentreStackDecl :: CostCentreStack -> FCode () +emitCostCentreStackDecl ccs + = case maybeSingletonCCS ccs of + Just cc -> + do dflags <- getDynFlags + let mk_lits cc = zero dflags : + mkCCostCentre cc : + replicate (sizeof_ccs_words dflags - 2) (zero dflags) + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 +zero64 :: CmmLit +zero64 = CmmInt 0 W64 + +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags + -- round up to the next word. + | ms == 0 = ws + | otherwise = ws + 1 + where + (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags + +-- --------------------------------------------------------------------------- +-- Set the current cost centre stack + +emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () +emitSetCCC cc tick push + = do dflags <- getDynFlags + if not (gopt Opt_SccProfilingOn dflags) + then return () + else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW + pushCostCentre tmp curCCS cc + when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) + +pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () +pushCostCentre result ccs cc + = emitRtsCallWithResult result AddrHint + rtsPackageKey + (fsLit "pushCostCentre") [(ccs,AddrHint), + (CmmLit (mkCCostCentre cc), AddrHint)] + False + +bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph +bumpSccCount dflags ccs + = addToMem (rEP_CostCentreStack_scc_count dflags) + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + +----------------------------------------------------------------------------- +-- +-- Lag/drag/void stuff +-- +----------------------------------------------------------------------------- + +-- +-- Initial value for the LDV field in a static closure +-- +staticLdvInit :: DynFlags -> CmmLit +staticLdvInit = zeroCLit + +-- +-- Initial value of the LDV field in a dynamic closure +-- +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], + CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) + ] + +-- +-- Initialise the LDV word of a new closure +-- +ldvRecordCreate :: CmmExpr -> FCode () +ldvRecordCreate closure = do dflags <- getDynFlags + emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) + +-- +-- Called when a closure is entered, marks the closure as having been "used". +-- The closure is not an 'inherently used' one. +-- The closure is not IND or IND_OLDGEN because neither is considered for LDV +-- profiling. +-- +ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () +ldvEnterClosure closure_info node_reg = do + dflags <- getDynFlags + let tag = funTag dflags closure_info + -- don't forget to substract node's tag + ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag)) + +ldvEnter :: CmmExpr -> FCode () +-- Argument is a closure pointer +ldvEnter cl_ptr = do + dflags <- getDynFlags + let -- don't forget to substract node's tag + ldv_wd = ldvWord dflags cl_ptr + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) + ifProfiling $ + -- if (era > 0) { + -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | + -- era | LDV_STATE_USE } + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + (mkStore ldv_wd new_ldv_wd) + mkNop + +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "era"))) + (cInt dflags)] + +ldvWord :: DynFlags -> CmmExpr -> CmmExpr +-- Takes the address of a closure, and returns +-- the address of the LDV word in the closure +ldvWord dflags closure_ptr + = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs new file mode 100644 index 00000000..3652a799 --- /dev/null +++ b/compiler/codeGen/StgCmmTicky.hs @@ -0,0 +1,659 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +----------------------------------------------------------------------------- +-- +-- Code generation for ticky-ticky profiling +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +{- OVERVIEW: ticky ticky profiling + +Please see +http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also +edit it and the rest of this comment to keep them up-to-date if you +change ticky-ticky. Thanks! + + *** All allocation ticky numbers are in bytes. *** + +Some of the relevant source files: + + ***not necessarily an exhaustive list*** + + * some codeGen/ modules import this one + + * this module imports cmm/CLabel.hs to manage labels + + * cmm/CmmParse.y expands some macros using generators defined in + this module + + * includes/stg/Ticky.h declares all of the global counters + + * includes/rts/Ticky.h declares the C data type for an + STG-declaration's counters + + * some macros defined in includes/Cmm.h (and used within the RTS's + CMM code) update the global ticky counters + + * at the end of execution rts/Ticky.c generates the final report + +RTS -r -RTS + +The rts/Ticky.c function that generates the report includes an +STG-declaration's ticky counters if + + * that declaration was entered, or + + * it was allocated (if -ticky-allocd) + +On either of those events, the counter is "registered" by adding it to +a linked list; cf the CMM generated by registerTickyCtr. + +Ticky-ticky profiling has evolved over many years. Many of the +counters from its most sophisticated days are no longer +active/accurate. As the RTS has changed, sometimes the ticky code for +relevant counters was not accordingly updated. Unfortunately, neither +were the comments. + +As of March 2013, there still exist deprecated code and comments in +the code generator as well as the RTS because: + + * I don't know what is out-of-date versus merely commented out for + momentary convenience, and + + * someone else might know how to repair it! + +-} + +module StgCmmTicky ( + withNewTickyCounterFun, + withNewTickyCounterLNE, + withNewTickyCounterThunk, + withNewTickyCounterStdThunk, + + tickyDynAlloc, + tickyAllocHeap, + + tickyAllocPrim, + tickyAllocThunk, + tickyAllocPAP, + tickyHeapCheck, + tickyStackCheck, + + tickyUnknownCall, tickyDirectCall, + + tickyPushUpdateFrame, + tickyUpdateFrameOmitted, + + tickyEnterDynCon, + tickyEnterStaticCon, + tickyEnterViaNode, + + tickyEnterFun, + tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value + -- thunks only + tickyEnterLNE, + + tickyUpdateBhCaf, + tickyBlackHole, + tickyUnboxedTupleReturn, tickyVectoredReturn, + tickyReturnOldCon, tickyReturnNewCon, + + tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, + tickySlowCall, tickySlowCallPat, + ) where + +#include "HsVersions.h" + +import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString ) +import StgCmmEnv ( NonVoid, unsafe_stripNV ) +import StgCmmClosure +import StgCmmUtils +import StgCmmMonad + +import StgSyn +import CmmExpr +import MkGraph +import CmmUtils +import CLabel +import SMRep + +import Module +import Name +import Id +import BasicTypes +import FastString +import Outputable + +import DynFlags + +-- Turgid imports for showTypeCategory +import PrelNames +import TcType +import Type +import TyCon + +import Data.Maybe +import qualified Data.Char +import Control.Monad ( unless, when ) + +----------------------------------------------------------------------------- +-- +-- Ticky-ticky profiling +-- +----------------------------------------------------------------------------- + +data TickyClosureType = TickyFun | TickyThunk | TickyLNE + +withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterFun = withNewTickyCounter TickyFun + +withNewTickyCounterLNE nm args code = do + b <- tickyLNEIsOn + if not b then code else withNewTickyCounter TickyLNE nm args code + +withNewTickyCounterThunk,withNewTickyCounterStdThunk :: + Bool -> Name -> FCode a -> FCode a +withNewTickyCounterThunk isStatic name code = do + b <- tickyDynThunkIsOn + if isStatic || not b -- ignore static thunks + then code + else withNewTickyCounter TickyThunk name [] code + +withNewTickyCounterStdThunk = withNewTickyCounterThunk + +-- args does not include the void arguments +withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounter cloType name args m = do + lbl <- emitTickyCounter cloType name args + setTickyCtrLabel lbl m + +emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel +emitTickyCounter cloType name args + = let ctr_lbl = mkRednCountsLabel name in + (>> return ctr_lbl) $ + ifTicky $ do + { dflags <- getDynFlags + ; parent <- getTickyCtrLabel + ; mod_name <- getModuleName + + -- When printing the name of a thing in a ticky file, we + -- want to give the module name even for *local* things. We + -- print just "x (M)" rather that "M.x" to distinguish them + -- from the global kind. + ; let ppr_for_ticky_name :: SDoc + ppr_for_ticky_name = + let n = ppr name + p = case hasHaskellName parent of + -- NB the default "top" ticky ctr does not + -- have a Haskell name + Just pname -> text "in" <+> ppr (nameUnique pname) + _ -> empty + in (<+> p) $ if isInternalName name + then let s = n <+> (parens (ppr mod_name)) + in case cloType of + TickyFun -> s + TickyThunk -> s <+> parens (text "thk") + TickyLNE -> s <+> parens (text "LNE") + else case cloType of + TickyFun -> n + TickyThunk -> n <+> parens (text "thk") + TickyLNE -> panic "emitTickyCounter: how is this an external LNE?" + + ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name + ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args + ; emitDataLits ctr_lbl + -- Must match layout of includes/rts/Ticky.h's StgEntCounter + -- + -- krc: note that all the fields are I32 now; some were I16 + -- before, but the code generator wasn't handling that + -- properly and it led to chaos, panic and disorder. + [ mkIntCLit dflags 0, -- registered? + mkIntCLit dflags (length args), -- Arity + mkIntCLit dflags 0, -- Heap allocated for this thing + fun_descr_lit, + arg_descr_lit, + zeroCLit dflags, -- Entries into this thing + zeroCLit dflags, -- Heap allocated by this thing + zeroCLit dflags -- Link to next StgEntCounter + ] + } + +-- ----------------------------------------------------------------------------- +-- Ticky stack frames + +tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode () +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") + +-- ----------------------------------------------------------------------------- +-- Ticky entries + +-- NB the name-specific entries are only available for names that have +-- dedicated Cmm code. As far as I know, this just rules out +-- constructor thunks. For them, there is no CMM code block to put the +-- bump of name-specific ticky counter into. On the other hand, we can +-- still track allocation their allocation. + +tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") +tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") +tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") + +tickyEnterThunk :: ClosureInfo -> FCode () +tickyEnterThunk cl_info + = ifTicky $ do + { bumpTickyCounter ctr + ; unless static $ do + ticky_ctr_lbl <- getTickyCtrLabel + registerTickyCtrAtEntryDyn ticky_ctr_lbl + bumpTickyEntryCount ticky_ctr_lbl } + where + updatable = closureSingleEntry cl_info + static = isStaticClosure cl_info + + ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" + else fsLit "ENT_STATIC_THK_MANY_ctr" + | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" + else fsLit "ENT_DYN_THK_MANY_ctr" + +tickyEnterStdThunk :: ClosureInfo -> FCode () +tickyEnterStdThunk = tickyEnterThunk + +tickyBlackHole :: Bool{-updatable-} -> FCode () +tickyBlackHole updatable + = ifTicky (bumpTickyCounter ctr) + where + ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") + +tickyUpdateBhCaf :: ClosureInfo -> FCode () +tickyUpdateBhCaf cl_info + = ifTicky (bumpTickyCounter ctr) + where + ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr") + +tickyEnterFun :: ClosureInfo -> FCode () +tickyEnterFun cl_info = ifTicky $ do + ctr_lbl <- getTickyCtrLabel + + if isStaticClosure cl_info + then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr") + registerTickyCtr ctr_lbl + else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr") + registerTickyCtrAtEntryDyn ctr_lbl + + bumpTickyEntryCount ctr_lbl + +tickyEnterLNE :: FCode () +tickyEnterLNE = ifTicky $ do + bumpTickyCounter (fsLit "ENT_LNE_ctr") + ifTickyLNE $ do + ctr_lbl <- getTickyCtrLabel + registerTickyCtr ctr_lbl + bumpTickyEntryCount ctr_lbl + +-- needn't register a counter upon entry if +-- +-- 1) it's for a dynamic closure, and +-- +-- 2) -ticky-allocd is on +-- +-- since the counter was registered already upon being alloc'd +registerTickyCtrAtEntryDyn :: CLabel -> FCode () +registerTickyCtrAtEntryDyn ctr_lbl = do + already_registered <- tickyAllocdIsOn + when (not already_registered) $ registerTickyCtr ctr_lbl + +registerTickyCtr :: CLabel -> FCode () +-- Register a ticky counter +-- if ( ! f_ct.registeredp ) { +-- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ +-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ +-- f_ct.registeredp = 1 } +registerTickyCtr ctr_lbl = do + dflags <- getDynFlags + let + -- krc: code generator doesn't handle Not, so we test for Eq 0 instead + test = CmmMachOp (MO_Eq (wordWidth dflags)) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), + zeroExpr dflags] + register_stmts + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , mkStore (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) + (mkIntExpr dflags 1) ] + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "ticky_entry_ctrs")) + emit =<< mkCmmIfThen test (catAGraphs register_stmts) + +tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () +tickyReturnOldCon arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } +tickyReturnNewCon arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } + +tickyUnboxedTupleReturn :: RepArity -> FCode () +tickyUnboxedTupleReturn arity + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } + +tickyVectoredReturn :: Int -> FCode () +tickyVectoredReturn family_size + = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") + ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } + +-- ----------------------------------------------------------------------------- +-- Ticky calls + +-- Ticks at a *call site*: +tickyDirectCall :: RepArity -> [StgArg] -> FCode () +tickyDirectCall arity args + | arity == length args = tickyKnownCallExact + | otherwise = do tickyKnownCallExtraArgs + tickySlowCallPat (map argPrimRep (drop arity args)) + +tickyKnownCallTooFewArgs :: FCode () +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") + +tickyKnownCallExact :: FCode () +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") + +tickyKnownCallExtraArgs :: FCode () +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") + +tickyUnknownCall :: FCode () +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") + +-- Tick for the call pattern at slow call site (i.e. in addition to +-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) +tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode () +tickySlowCall _ [] = return () +tickySlowCall lf_info args = do + -- see Note [Ticky for slow calls] + if isKnownFun lf_info + then tickyKnownCallTooFewArgs + else tickyUnknownCall + tickySlowCallPat (map argPrimRep args) + +tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat args = ifTicky $ + let argReps = map toArgRep args + (_, n_matched) = slowCallPattern argReps + in if n_matched > 0 && n_matched == length args + then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps + else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr" + +{- + +Note [Ticky for slow calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Terminology is unfortunately a bit mixed up for these calls. codeGen +uses "slow call" to refer to unknown calls and under-saturated known +calls. + +Nowadays, though (ie as of the eval/apply paper), the significantly +slower calls are actually just a subset of these: the ones with no +built-in argument pattern (cf StgCmmArgRep.slowCallPattern) + +So for ticky profiling, we split slow calls into +"SLOW_CALL_fast__ctr" (those matching a built-in pattern) and +VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very +bad for both space and time). + +-} + +-- ----------------------------------------------------------------------------- +-- Ticky allocation + +tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () +-- Called when doing a dynamic heap allocation; the LambdaFormInfo +-- used to distinguish between closure types +-- +-- TODO what else to count while we're here? +tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> + let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep + + countGlobal tot ctr = do + bumpTickyCounterBy tot bytes + bumpTickyCounter ctr + countSpecific = ifTickyAllocd $ case mb_id of + Nothing -> return () + Just id -> do + let ctr_lbl = mkRednCountsLabel (idName id) + registerTickyCtr ctr_lbl + bumpTickyAllocd ctr_lbl bytes + + -- TODO are we still tracking "good stuff" (_gds) versus + -- administrative (_adm) versus slop (_slp)? I'm going with all _gds + -- for now, since I don't currently know neither if we do nor how to + -- distinguish. NSF Mar 2013 + + in case () of + _ | isConRep rep -> + ifTickyDynThunk countSpecific >> + countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") + | isThunkRep rep -> + ifTickyDynThunk countSpecific >> + if lfUpdatable lf + then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") + else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") + | isFunRep rep -> + countSpecific >> + countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") + | otherwise -> panic "How is this heap object not a con, thunk, or fun?" + + + +tickyAllocHeap :: + Bool -> -- is this a genuine allocation? As opposed to + -- StgCmmLayout.adjustHpBackwards + VirtualHpOffset -> FCode () +-- Called when doing a heap check [TICK_ALLOC_HEAP] +-- Must be lazy in the amount of allocation! +tickyAllocHeap genuine hp + = ifTicky $ + do { dflags <- getDynFlags + ; ticky_ctr <- getTickyCtrLabel + ; emit $ catAGraphs $ + -- only test hp from within the emit so that the monadic + -- computation itself is not strict in hp (cf knot in + -- StgCmmMonad.getHeapUsage) + if hp == 0 then [] + else let !bytes = wORD_SIZE dflags * hp in [ + -- Bump the allocation total in the closure's StgEntCounter + addToMem (rEP_StgEntCounter_allocs dflags) + (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) + bytes, + -- Bump the global allocation total ALLOC_HEAP_tot + addToMemLbl (cLong dflags) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_tot")) + bytes, + -- Bump the global allocation counter ALLOC_HEAP_ctr + if not genuine then mkNop + else addToMemLbl (cLong dflags) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_ctr")) + 1 + ]} + + +-------------------------------------------------------------------------------- +-- these three are only called from CmmParse.y (ie ultimately from the RTS) + +-- the units are bytes + +tickyAllocPrim :: CmmExpr -- ^ size of the full header, in bytes + -> CmmExpr -- ^ size of the payload, in bytes + -> CmmExpr -> FCode () +tickyAllocPrim _hdr _goods _slop = ifTicky $ do + bumpTickyCounter (fsLit "ALLOC_PRIM_ctr") + bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr + bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop + +tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode () +tickyAllocThunk _goods _slop = ifTicky $ do + -- TODO is it ever called with a Single-Entry thunk? + bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr") + bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop + +tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode () +tickyAllocPAP _goods _slop = ifTicky $ do + bumpTickyCounter (fsLit "ALLOC_PAP_ctr") + bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods + bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop + +tickyHeapCheck :: FCode () +tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr") + +tickyStackCheck :: FCode () +tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr") + +-- ----------------------------------------------------------------------------- +-- Ticky utils + +ifTicky :: FCode () -> FCode () +ifTicky code = + getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code + +tickyAllocdIsOn :: FCode Bool +tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags + +tickyLNEIsOn :: FCode Bool +tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags + +tickyDynThunkIsOn :: FCode Bool +tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags + +ifTickyAllocd :: FCode () -> FCode () +ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code + +ifTickyLNE :: FCode () -> FCode () +ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code + +ifTickyDynThunk :: FCode () -> FCode () +ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code + +bumpTickyCounter :: FastString -> FCode () +bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageKey lbl) + +bumpTickyCounterBy :: FastString -> Int -> FCode () +bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageKey lbl) + +bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () +bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageKey lbl) + +bumpTickyEntryCount :: CLabel -> FCode () +bumpTickyEntryCount lbl = do + dflags <- getDynFlags + bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags)) + +bumpTickyAllocd :: CLabel -> Int -> FCode () +bumpTickyAllocd lbl bytes = do + dflags <- getDynFlags + bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes + +bumpTickyLbl :: CLabel -> FCode () +bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 + +bumpTickyLblBy :: CLabel -> Int -> FCode () +bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) + +bumpTickyLblByE :: CLabel -> CmmExpr -> FCode () +bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0) + +bumpTickyLit :: CmmLit -> FCode () +bumpTickyLit lhs = bumpTickyLitBy lhs 1 + +bumpTickyLitBy :: CmmLit -> Int -> FCode () +bumpTickyLitBy lhs n = do + dflags <- getDynFlags + emit (addToMem (bWord dflags) (CmmLit lhs) n) + +bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () +bumpTickyLitByE lhs e = do + dflags <- getDynFlags + emit (addToMemE (bWord dflags) (CmmLit lhs) e) + +bumpHistogram :: FastString -> Int -> FCode () +bumpHistogram _lbl _n +-- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) + = return () -- TEMP SPJ Apr 07 + -- six years passed - still temp? JS Aug 2013 + +{- +bumpHistogramE :: LitString -> CmmExpr -> FCode () +bumpHistogramE lbl n + = do t <- newTemp cLong + emitAssign (CmmLocal t) n + emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) + (mkAssign (CmmLocal t) eight)) + emit (addToMem cLong + (cmmIndexExpr cLongWidth + (CmmLit (CmmLabel (mkRtsDataLabel lbl))) + (CmmReg (CmmLocal t))) + 1) + where + eight = CmmLit (CmmInt 8 cLongWidth) +-} + +------------------------------------------------------------------ +-- Showing the "type category" for ticky-ticky profiling + +showTypeCategory :: Type -> Char + {- + + dictionary + + > function + + {C,I,F,D,W} char, int, float, double, word + {c,i,f,d,w} unboxed ditto + + T tuple + + P other primitive type + p unboxed ditto + + L list + E enumeration type + S other single-constructor type + M other multi-constructor data-con type + + . other type + + - reserved for others to mark as "uninteresting" + + Accurate as of Mar 2013, but I eliminated the Array category instead + of updating it, for simplicity. It's in P/p, I think --NSF + + -} +showTypeCategory ty + | isDictTy ty = '+' + | otherwise = case tcSplitTyConApp_maybe ty of + Nothing -> '.' + Just (tycon, _) -> + (if isUnLiftedTyCon tycon then Data.Char.toLower else \x -> x) $ + let anyOf us = getUnique tycon `elem` us in + case () of + _ | anyOf [funTyConKey] -> '>' + | anyOf [charPrimTyConKey, charTyConKey] -> 'C' + | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D' + | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F' + | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey, + intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey + ] -> 'I' + | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey, + word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey + ] -> 'W' + | anyOf [listTyConKey] -> 'L' + | isTupleTyCon tycon -> 'T' + | isPrimTyCon tycon -> 'P' + | isEnumerationTyCon tycon -> 'E' + | isJust (tyConSingleDataCon_maybe tycon) -> 'S' + | otherwise -> 'M' -- oh, well... diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs new file mode 100644 index 00000000..8d8c8a03 --- /dev/null +++ b/compiler/codeGen/StgCmmUtils.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Code generator utilities; mostly monadic +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmUtils ( + cgLit, mkSimpleLit, + emitDataLits, mkDataLits, + emitRODataLits, mkRODataLits, + emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, + assignTemp, newTemp, + + newUnboxedTupleRegs, + + emitMultiAssign, emitCmmLitSwitch, emitSwitch, + + tagToClosure, mkTaggedObjectLoad, + + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, + + cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, + cmmOffsetExprW, cmmOffsetExprB, + cmmRegOffW, cmmRegOffB, + cmmLabelOffW, cmmLabelOffB, + cmmOffsetW, cmmOffsetB, + cmmOffsetLitW, cmmOffsetLitB, + cmmLoadIndexW, + cmmConstrTag1, + + cmmUntag, cmmIsTagged, + + addToMem, addToMemE, addToMemLblE, addToMemLbl, + mkWordCLit, + newStringCLit, newByteStringCLit, + blankWord + ) where + +#include "HsVersions.h" + +import StgCmmMonad +import StgCmmClosure +import Cmm +import BlockId +import MkGraph +import CodeGen.Platform +import CLabel +import CmmUtils + +import ForeignCall +import IdInfo +import Type +import TyCon +import SMRep +import Module +import Literal +import Digraph +import ListSetOps +import Util +import Unique +import DynFlags +import FastString +import Outputable + +import qualified Data.ByteString as BS +import Data.Char +import Data.List +import Data.Ord +import Data.Word +import Data.Maybe + + +------------------------------------------------------------------------- +-- +-- Literals +-- +------------------------------------------------------------------------- + +cgLit :: Literal -> FCode CmmLit +cgLit (MachStr s) = newByteStringCLit (BS.unpack s) + -- not unpackFS; we want the UTF-8 byte stream. +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) + +mkLtOp :: DynFlags -> Literal -> MachOp +-- On signed literals we must do a signed comparison +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) + -- ToDo: seems terribly indirect! + +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage +mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) + +-------------------------------------------------------------------------- +-- +-- Incrementing a memory location +-- +-------------------------------------------------------------------------- + +addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph +addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n + +addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph +addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) + +addToMem :: CmmType -- rep of the counter + -> CmmExpr -- Address + -> Int -- What to add (a word) + -> CmmAGraph +addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) + +addToMemE :: CmmType -- rep of the counter + -> CmmExpr -- Address + -> CmmExpr -- What to add (a word-typed expression) + -> CmmAGraph +addToMemE rep ptr n + = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n]) + + +------------------------------------------------------------------------- +-- +-- Loading a field from an object, +-- where the object pointer is itself tagged +-- +------------------------------------------------------------------------- + +mkTaggedObjectLoad + :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph +-- (loadTaggedObjectField reg base off tag) generates assignment +-- reg = bitsK[ base + off - tag ] +-- where K is fixed by 'reg' +mkTaggedObjectLoad dflags reg base offset tag + = mkAssign (CmmLocal reg) + (CmmLoad (cmmOffsetB dflags + (CmmReg (CmmLocal base)) + (offset - tag)) + (localRegType reg)) + +------------------------------------------------------------------------- +-- +-- Converting a closure tag to a closure for enumeration types +-- (this is the implementation of tagToEnum#). +-- +------------------------------------------------------------------------- + +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag + = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags) + where closure_tbl = CmmLit (CmmLabel lbl) + lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs + +------------------------------------------------------------------------- +-- +-- Conditionals and rts calls +-- +------------------------------------------------------------------------- + +emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe + +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString + -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe + +-- Make a call to an RTS C procedure +emitRtsCallGen + :: [(LocalReg,ForeignHint)] + -> CLabel + -> [(CmmExpr,ForeignHint)] + -> Bool -- True <=> CmmSafe call + -> FCode () +emitRtsCallGen res lbl args safe + = do { dflags <- getDynFlags + ; updfr_off <- getUpdFrameOff + ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags + ; emit caller_save + ; call updfr_off + ; emit caller_load } + where + call updfr_off = + if safe then + emit =<< mkCmmCall fun_expr res' args' updfr_off + else do + let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn + emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' + (args', arg_hints) = unzip args + (res', res_hints) = unzip res + fun_expr = mkLblExpr lbl + + +----------------------------------------------------------------------------- +-- +-- Caller-Save Registers +-- +----------------------------------------------------------------------------- + +-- Here we generate the sequence of saves/restores required around a +-- foreign call instruction. + +-- TODO: reconcile with includes/Regs.h +-- * Regs.h claims that BaseReg should be saved last and loaded first +-- * This might not have been tickled before since BaseReg is callee save +-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim +-- +-- This code isn't actually used right now, because callerSaves +-- only ever returns true in the current universe for registers NOT in +-- system_regs (just do a grep for CALLER_SAVES in +-- includes/stg/MachRegs.h). It's all one giant no-op, and for +-- good reason: having to save system registers on every foreign call +-- would be very expensive, so we avoid assigning them to those +-- registers when we add support for an architecture. +-- +-- Note that the old code generator actually does more work here: it +-- also saves other global registers. We can't (nor want) to do that +-- here, as we don't have liveness information. And really, we +-- shouldn't be doing the workaround at this point in the pipeline, see +-- Note [Register parameter passing] and the ToDo on CmmCall in +-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across +-- unsafe foreign calls in rewriteAssignments, but this is strictly +-- temporary. +callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) +callerSaveVolatileRegs dflags = (caller_save, caller_load) + where + platform = targetPlatform dflags + + caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save) + caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save) + + system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery + {- ,SparkHd,SparkTl,SparkBase,SparkLim -} + , BaseReg ] + + regs_to_save = filter (callerSaves platform) system_regs + + callerSaveGlobalReg reg + = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) + + callerRestoreGlobalReg reg + = mkAssign (CmmGlobal reg) + (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) + +-- ----------------------------------------------------------------------------- +-- Global registers + +-- We map STG registers onto appropriate CmmExprs. Either they map +-- to real machine registers or stored as offsets from BaseReg. Given +-- a GlobalReg, get_GlobalReg_addr always produces the +-- register table address for it. +-- (See also get_GlobalReg_reg_or_addr in MachRegs) + +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) + +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _rep offset = + if haveRegBase (targetPlatform dflags) + then CmmRegOff (CmmGlobal BaseReg) offset + else regTableOffset dflags offset + + +-- ----------------------------------------------------------------------------- +-- Information about global registers + +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg) + +------------------------------------------------------------------------- +-- +-- Strings generate a top-level data block +-- +------------------------------------------------------------------------- + +emitDataLits :: CLabel -> [CmmLit] -> FCode () +-- Emit a data-segment data block +emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits) + +emitRODataLits :: CLabel -> [CmmLit] -> FCode () +-- Emit a read-only data block +emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) + +newStringCLit :: String -> FCode CmmLit +-- Make a global definition for the string, +-- and return its label +newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str) + +newByteStringCLit :: [Word8] -> FCode CmmLit +newByteStringCLit bytes + = do { uniq <- newUnique + ; let (lit, decl) = mkByteStringCLit uniq bytes + ; emitDecl decl + ; return lit } + +------------------------------------------------------------------------- +-- +-- Assigning expressions to temporaries +-- +------------------------------------------------------------------------- + +assignTemp :: CmmExpr -> FCode LocalReg +-- Make sure the argument is in a local register. +-- We don't bother being particularly aggressive with avoiding +-- unnecessary local registers, since we can rely on a later +-- optimization pass to inline as necessary (and skipping out +-- on things like global registers can be a little dangerous +-- due to them being trashed on foreign calls--though it means +-- the optimization pass doesn't have to do as much work) +assignTemp (CmmReg (CmmLocal reg)) = return reg +assignTemp e = do { dflags <- getDynFlags + ; uniq <- newUnique + ; let reg = LocalReg uniq (cmmExprType dflags e) + ; emitAssign (CmmLocal reg) e + ; return reg } + +newTemp :: CmmType -> FCode LocalReg +newTemp rep = do { uniq <- newUnique + ; return (LocalReg uniq rep) } + +newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) +-- Choose suitable local regs to use for the components +-- of an unboxed tuple that we are about to return to +-- the Sequel. If the Sequel is a join point, using the +-- regs it wants will save later assignments. +newUnboxedTupleRegs res_ty + = ASSERT( isUnboxedTupleType res_ty ) + do { dflags <- getDynFlags + ; sequel <- getSequel + ; regs <- choose_regs dflags sequel + ; ASSERT( regs `equalLength` reps ) + return (regs, map primRepForeignHint reps) } + where + UbxTupleRep ty_args = repType res_ty + reps = [ rep + | ty <- ty_args + , let rep = typePrimRep ty + , not (isVoidRep rep) ] + choose_regs _ (AssignTo regs _) = return regs + choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps + + + +------------------------------------------------------------------------- +-- emitMultiAssign +------------------------------------------------------------------------- + +emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode () +-- Emit code to perform the assignments in the +-- input simultaneously, using temporary variables when necessary. + +type Key = Int +type Vrtx = (Key, Stmt) -- Give each vertex a unique number, + -- for fast comparison +type Stmt = (LocalReg, CmmExpr) -- r := e + +-- We use the strongly-connected component algorithm, in which +-- * the vertices are the statements +-- * an edge goes from s1 to s2 iff +-- s1 assigns to something s2 uses +-- that is, if s1 should *follow* s2 in the final order + +emitMultiAssign [] [] = return () +emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs +emitMultiAssign regs rhss = do + dflags <- getDynFlags + ASSERT( equalLength regs rhss ) + unscramble dflags ([1..] `zip` (regs `zip` rhss)) + +unscramble :: DynFlags -> [Vrtx] -> FCode () +unscramble dflags vertices = mapM_ do_component components + where + edges :: [ (Vrtx, Key, [Key]) ] + edges = [ (vertex, key1, edges_from stmt1) + | vertex@(key1, stmt1) <- vertices ] + + edges_from :: Stmt -> [Key] + edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, + stmt1 `mustFollow` stmt2 ] + + components :: [SCC Vrtx] + components = stronglyConnCompFromEdgedVertices edges + + -- do_components deal with one strongly-connected component + -- Not cyclic, or singleton? Just do it + do_component :: SCC Vrtx -> FCode () + do_component (AcyclicSCC (_,stmt)) = mk_graph stmt + do_component (CyclicSCC []) = panic "do_component" + do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt + + -- Cyclic? Then go via temporaries. Pick one to + -- break the loop and try again with the rest. + do_component (CyclicSCC ((_,first_stmt) : rest)) = do + dflags <- getDynFlags + u <- newUnique + let (to_tmp, from_tmp) = split dflags u first_stmt + mk_graph to_tmp + unscramble dflags rest + mk_graph from_tmp + + split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) + split dflags uniq (reg, rhs) + = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) + where + rep = cmmExprType dflags rhs + tmp = LocalReg uniq rep + + mk_graph :: Stmt -> FCode () + mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs + + mustFollow :: Stmt -> Stmt -> Bool + (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs + +------------------------------------------------------------------------- +-- mkSwitch +------------------------------------------------------------------------- + + +emitSwitch :: CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches + -> Maybe CmmAGraphScoped -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; + -- behaviour outside this range is + -- undefined + -> FCode () +emitSwitch tag_expr branches mb_deflt lo_tag hi_tag + = do { dflags <- getDynFlags + ; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag } + where + via_C dflags | HscC <- hscTarget dflags = True + | otherwise = False + + +mkCmmSwitch :: Bool -- True <=> never generate a + -- conditional tree + -> CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches + -> Maybe CmmAGraphScoped -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; + -- behaviour outside this range is + -- undefined + -> FCode () + +-- First, two rather common cases in which there is no work to do +mkCmmSwitch _ _ [] (Just code) _ _ = emit (fst code) +mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit (fst code) + +-- Right, off we go +mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do + join_lbl <- newLabelC + mb_deflt_lbl <- label_default join_lbl mb_deflt + branches_lbls <- label_branches join_lbl branches + tag_expr' <- assignTemp' tag_expr + + emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls) + mb_deflt_lbl lo_tag hi_tag via_C + + -- Sort the branches before calling mk_switch + + emitLabel join_lbl + +mk_switch :: CmmExpr -> [(ConTagZ, BlockId)] + -> Maybe BlockId + -> ConTagZ -> ConTagZ -> Bool + -> FCode CmmAGraph + +-- SINGLETON TAG RANGE: no case analysis to do +mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C + | lo_tag == hi_tag + = ASSERT( tag == lo_tag ) + return (mkBranch lbl) + +-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do +mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ + = return (mkBranch lbl) + -- The simplifier might have eliminated a case + -- so we may have e.g. case xs of + -- [] -> e + -- In that situation we can be sure the (:) case + -- can't happen, so no need to test + +-- SINGLETON BRANCH: one equality check to do +mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ + = do dflags <- getDynFlags + let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag) + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default + return (mkCbranch cond deflt lbl) + +-- ToDo: we might want to check for the two branch case, where one of +-- the branches is the tag 0, because comparing '== 0' is likely to be +-- more efficient than other kinds of comparison. + +-- DENSE TAG RANGE: use a switch statment. +-- +-- We also use a switch uncoditionally when compiling via C, because +-- this will get emitted as a C switch statement and the C compiler +-- should do a good job of optimising it. Also, older GCC versions +-- (2.95 in particular) have problems compiling the complicated +-- if-trees generated by this code, so compiling to a switch every +-- time works around that problem. +-- +mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C + | use_switch -- Use a switch + = do let + find_branch :: ConTagZ -> Maybe BlockId + find_branch i = case (assocMaybe branches i) of + Just lbl -> Just lbl + Nothing -> mb_deflt + + -- NB. we have eliminated impossible branches at + -- either end of the range (see below), so the first + -- tag of a real branch is real_lo_tag (not lo_tag). + arms :: [Maybe BlockId] + arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] + dflags <- getDynFlags + return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms) + + -- if we can knock off a bunch of default cases with one if, then do so + | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt + lowest_branch hi_tag via_C + mkCmmIfThenElse + (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch)) + (mkBranch deflt) + stmts + + | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt + lo_tag highest_branch via_C + mkCmmIfThenElse + (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch)) + (mkBranch deflt) + stmts + + | otherwise -- Use an if-tree + = do dflags <- getDynFlags + lo_stmts <- mk_switch tag_expr lo_branches mb_deflt + lo_tag (mid_tag-1) via_C + hi_stmts <- mk_switch tag_expr hi_branches mb_deflt + mid_tag hi_tag via_C + mkCmmIfThenElse + (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag)) + hi_stmts + lo_stmts + -- we test (e >= mid_tag) rather than (e < mid_tag), because + -- the former works better when e is a comparison, and there + -- are two tags 0 & 1 (mid_tag == 1). In this case, the code + -- generator can reduce the condition to e itself without + -- having to reverse the sense of the comparison: comparisons + -- can't always be easily reversed (eg. floating + -- pt. comparisons). + where + use_switch = {- pprTrace "mk_switch" ( + ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> + text "branches:" <+> ppr (map fst branches) <+> + text "n_branches:" <+> int n_branches <+> + text "lo_tag:" <+> int lo_tag <+> + text "hi_tag:" <+> int hi_tag <+> + text "real_lo_tag:" <+> int real_lo_tag <+> + text "real_hi_tag:" <+> int real_hi_tag) $ -} + ASSERT( n_branches > 1 && n_tags > 1 ) + n_tags > 2 && (via_C || (dense && big_enough)) + -- up to 4 branches we use a decision tree, otherwise + -- a switch (== jump table in the NCG). This seems to be + -- optimal, and corresponds with what gcc does. + big_enough = n_branches > 4 + dense = n_branches > (n_tags `div` 2) + n_branches = length branches + + -- ignore default slots at each end of the range if there's + -- no default branch defined. + lowest_branch = fst (head branches) + highest_branch = fst (last branches) + + real_lo_tag + | isNothing mb_deflt = lowest_branch + | otherwise = lo_tag + + real_hi_tag + | isNothing mb_deflt = highest_branch + | otherwise = hi_tag + + n_tags = real_hi_tag - real_lo_tag + 1 + + -- INVARIANT: Provided hi_tag > lo_tag (which is true) + -- lo_tag <= mid_tag < hi_tag + -- lo_branches have tags < mid_tag + -- hi_branches have tags >= mid_tag + + (mid_tag,_) = branches !! (n_branches `div` 2) + -- 2 branches => n_branches `div` 2 = 1 + -- => branches !! 1 give the *second* tag + -- There are always at least 2 branches here + + (lo_branches, hi_branches) = span is_lo branches + is_lo (t,_) = t < mid_tag + +-------------- +emitCmmLitSwitch :: CmmExpr -- Tag to switch on + -> [(Literal, CmmAGraphScoped)] -- Tagged branches + -> CmmAGraphScoped -- Default branch (always) + -> FCode () -- Emit the code +-- Used for general literals, whose size might not be a word, +-- where there is always a default case, and where we don't know +-- the range of values for certain. For simplicity we always generate a tree. +-- +-- ToDo: for integers we could do better here, perhaps by generalising +-- mk_switch and using that. --SDM 15/09/2004 +emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt +emitCmmLitSwitch scrut branches deflt = do + scrut' <- assignTemp' scrut + join_lbl <- newLabelC + deflt_lbl <- label_code join_lbl deflt + branches_lbls <- label_branches join_lbl branches + emit =<< mk_lit_switch scrut' deflt_lbl + (sortBy (comparing fst) branches_lbls) + emitLabel join_lbl + +mk_lit_switch :: CmmExpr -> BlockId + -> [(Literal,BlockId)] + -> FCode CmmAGraph +mk_lit_switch scrut deflt [(lit,blk)] + = do + dflags <- getDynFlags + let + cmm_lit = mkSimpleLit dflags lit + cmm_ty = cmmLitType dflags cmm_lit + rep = typeWidth cmm_ty + ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep + return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) + +mk_lit_switch scrut deflt_blk_id branches + = do dflags <- getDynFlags + lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches + hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches + mkCmmIfThenElse (cond dflags) lo_blk hi_blk + where + n_branches = length branches + (mid_lit,_) = branches !! (n_branches `div` 2) + -- See notes above re mid_tag + + (lo_branches, hi_branches) = span is_lo branches + is_lo (t,_) = t < mid_lit + + cond dflags = CmmMachOp (mkLtOp dflags mid_lit) + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] + + +-------------- +label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId) +label_default _ Nothing + = return Nothing +label_default join_lbl (Just code) + = do lbl <- label_code join_lbl code + return (Just lbl) + +-------------- +label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)] +label_branches _join_lbl [] + = return [] +label_branches join_lbl ((tag,code):branches) + = do lbl <- label_code join_lbl code + branches' <- label_branches join_lbl branches + return ((tag,lbl):branches') + +-------------- +label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId +-- label_code J code +-- generates +-- [L: code; goto J] +-- and returns L +label_code join_lbl (code,tsc) = do + lbl <- newLabelC + emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc) + return lbl + +-------------- +assignTemp' :: CmmExpr -> FCode CmmExpr +assignTemp' e + | isTrivialCmmExpr e = return e + | otherwise = do + dflags <- getDynFlags + lreg <- newTemp (cmmExprType dflags e) + let reg = CmmLocal lreg + emitAssign reg e + return (CmmReg reg) diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs new file mode 100644 index 00000000..07ef3980 --- /dev/null +++ b/compiler/coreSyn/CoreArity.hs @@ -0,0 +1,1028 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} + +-- | Arity and eta expansion +module CoreArity ( + manifestArity, exprArity, typeArity, exprBotStrictness_maybe, + exprEtaExpandArity, findRhsArity, CheapFun, etaExpand + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import CoreSubst +import Demand +import Var +import VarEnv +import Id +import Type +import TyCon ( initRecTc, checkRecTc ) +import Coercion +import BasicTypes +import Unique +import DynFlags ( DynFlags, GeneralFlag(..), gopt ) +import Outputable +import FastString +import Pair +import Util ( debugIsOn ) + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, fast, version of 'exprEtaExpandArity' +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) + -- Note [exprArity invariant] + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + + trim_arity :: Arity -> Type -> Arity + trim_arity arity ty = arity `min` length (typeArity ty) + +--------------- +typeArity :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [exprArity invariant] +typeArity ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] + -- in TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case getBotArity (arityType env e) of + Nothing -> Nothing + Just ar -> Just (ar, sig ar) + where + env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } + sig ar = mkClosedStrictSig (replicate ar topDmd) botRes + -- For this purpose we can be very simple + +{- +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariant: + + (1) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + So the case analysis in etaExpand and in typeArity must match + + (2) exprArity e <= typeArity (exprType e) + + (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n + + That is, if exprArity says "the arity is n" then etaExpand really + can get "n" manifest lambdas to the top. + +Why is this important? Because + - In TidyPgm we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in TidyPgm, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in Trac #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- + + +Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divegent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Big Deal with computing arities is expressions like + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +Trac #5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it is + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected bahaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in Trac #5557 + + (2) Do NOT move a lambda outside a case if all the branches of + the case are known to return bottom. + case x of { (a,b) -> \y -> error "urk" } + This case is less important, but the idea is that if the fn is + going to diverge eventually anyway then getting the best arity + isn't an issue, so we might as well play safe + + (3) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see Trac #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +4. Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decopose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (Trac #2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottomming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in Trac #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If at = ABot n, then (f x1..xn) definitely diverges. Partial + applications to fewer than n args may *or may not* diverge. + + We allow ourselves to eta-expand bottoming functions, even + if doing so may lose some `seq` sharing, + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + * If at = ATop as, and n=length as, + then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, + assuming the calls of f respect the one-shot-ness of of + its definition. + + NB 'f' is an arbitary expression, eg (f = g e1 e2). This 'f' + can have ArityType as ATop, with length as > 0, only if e1 e2 are + themselves. + + * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] + The one-shot-ness means we can, in effect, push that + 'let' inside the \st. + + +Suppose f = \xy. x+y +Then f :: AT [False,False] ATop + f v :: AT [False] ATop + f :: AT [] ATop + +-------------------- Main arity code ---------------------------- +-} + +-- See Note [ArityType] +data ArityType = ATop [OneShotInfo] | ABot Arity + -- There is always an explicit lambda + -- to justify the [OneShot], or the Arity + +vanillaArityType :: ArityType +vanillaArityType = ATop [] -- Totally uninformative + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +exprEtaExpandArity dflags e + = case (arityType env e) of + ATop oss -> length oss + ABot n -> n + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + +getBotArity :: ArityType -> Maybe Arity +-- Arity of a divergent function +getBotArity (ABot n) = Just n +getBotArity _ = Nothing + +mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun +mk_cheap_fn dflags cheap_app + | not (gopt Opt_DictsCheap dflags) + = \e _ -> exprIsCheap' cheap_app e + | otherwise + = \e mb_ty -> exprIsCheap' cheap_app e + || case mb_ty of + Nothing -> False + Just ty -> isDictLikeTy ty + + +---------------------- +findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +findRhsArity dflags bndr rhs old_arity + = go (rhsEtaExpandArity dflags init_cheap_app rhs) + -- We always call exprEtaExpandArity once, but usually + -- that produces a result equal to old_arity, and then + -- we stop right away (since arities should not decrease) + -- Result: the common case is that there is just one iteration + where + init_cheap_app :: CheapAppFun + init_cheap_app fn n_val_args + | fn == bndr = True -- On the first pass, this binder gets infinite arity + | otherwise = isCheapApp fn n_val_args + + go :: Arity -> Arity + go cur_arity + | cur_arity <= old_arity = cur_arity + | new_arity == cur_arity = cur_arity + | otherwise = ASSERT( new_arity < cur_arity ) +#ifdef DEBUG + pprTrace "Exciting arity" + (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity + , ppr rhs]) +#endif + go new_arity + where + new_arity = rhsEtaExpandArity dflags cheap_app rhs + + cheap_app :: CheapAppFun + cheap_app fn n_val_args + | fn == bndr = n_val_args < cur_arity + | otherwise = isCheapApp fn n_val_args + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +rhsEtaExpandArity dflags cheap_app e + = case (arityType env e) of + ATop (os:oss) + | isOneShotInfo os || has_lam e -> 1 + length oss + -- Don't expand PAPs/thunks + -- Note [Eta expanding thunks] + | otherwise -> 0 + ATop [] -> 0 + ABot n -> n + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + + has_lam (Tick _ e) = has_lam e + has_lam (Lam b e) = isId b || has_lam e + has_lam _ = False + +{- +Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in Trac #4138. + +The analysis is easy to achieve because exprEtaExpandArity takes an +argument + type CheapFun = CoreExpr -> Maybe Type -> Bool +used to decide if an expression is cheap enough to push inside a +lambda. And exprIsCheap' in turn takes an argument + type CheapAppFun = Id -> Int -> Bool +which tells when an application is cheap. This makes it easy to +write the analysis loop. + +The analysis is cheap-and-cheerful because it doesn't deal with +mutual recursion. But the self-recursive case is the important one. + + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. + +See Note [Dictionary-like types] in TcType.lhs for why we use +isDictLikeTy here rather than isDictTy + +Note [Eta expanding thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand + * Trivial RHSs x = y + * PAPs x = map g + * Thunks f = case y of p -> \x -> blah + +When we see + f = case y of p -> \x -> blah +should we eta-expand it? Well, if 'x' is a one-shot state token +then 'yes' because 'f' will only be applied once. But otherwise +we (conservatively) say no. My main reason is to avoid expanding +PAPSs + f = g d ==> f = \x. g d x +because that might in turn make g inline (if it has an inline pragma), +which we might not want. After all, INLINE pragmas say "inline only +when saturated" so we don't want to be too gung-ho about saturating! +-} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (ATop as) = ATop (idOneShotInfo id : as) +arityLam _ (ABot n) = ABot (n+1) + +floatIn :: Bool -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +floatIn _ (ABot n) = ABot n +floatIn True (ATop as) = ATop as +floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) + -- If E is not cheap, keep arity only for one-shots + +arityApp :: ArityType -> Bool -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (ABot 0) _ = ABot 0 +arityApp (ABot n) _ = ABot (n-1) +arityApp (ATop []) _ = ATop [] +arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) + +andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' +andArityType (ABot n1) (ABot n2) + = ABot (n1 `min` n2) +andArityType (ATop as) (ABot _) = ATop as +andArityType (ABot _) (ATop bs) = ATop bs +andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) + where -- See Note [Combining case branches] + combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs + combine [] bs = takeWhile isOneShotInfo bs + combine as [] = takeWhile isOneShotInfo as + +{- +Note [Combining case branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x +We *really* want to eta-expand go and go2. +When combining the barnches of the case we have + ATop [] `andAT` ATop [OneShotLam] +and we want to get ATop [OneShotLam]. But if the inner +lambda wasn't one-shot we don't want to do this. +(We need a proper arity analysis to justify that.) + +So we combine the best of the two branches, on the (slightly dodgy) +basis that if we know one branch is one-shot, then they all must be. +-} + +--------------------------- +type CheapFun = CoreExpr -> Maybe Type -> Bool + -- How to decide if an expression is cheap + -- If the Maybe is Just, the type is the type + -- of the expression; Nothing means "don't know" + +data ArityEnv + = AE { ae_cheap_fn :: CheapFun + , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms + } + +arityType :: ArityEnv -> CoreExpr -> ArityType + +arityType env (Cast e co) + = case arityType env e of + ATop os -> ATop (take co_arity os) + ABot n -> ABot (n `min` co_arity) + where + co_arity = length (typeArity (pSnd (coercionKind co))) + -- See Note [exprArity invariant] (2); must be true of + -- arityType too, since that is how we compute the arity + -- of variables, and they in turn affect result of exprArity + -- Trac #5441 is a nice demo + -- However, do make sure that ATop -> ATop and ABot -> ABot! + -- Casts don't affect that part. Getting this wrong provoked #5475 + +arityType _ (Var v) + | strict_sig <- idStrictness v + , not $ isNopSig strict_sig + , (ds, res) <- splitStrictSig strict_sig + , let arity = length ds + = if isBotRes res then ABot arity + else ATop (take arity one_shots) + | otherwise + = ATop (take (idArity v) one_shots) + where + one_shots :: [OneShotInfo] -- One-shot-ness derived from the type + one_shots = typeArity (idType v) + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env e) + | otherwise = arityType env e + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' + -- +arityType env (Case scrut _ _ alts) + | exprIsBottom scrut || null alts + = ABot 0 -- Do not eta expand + -- See Note [Dealing with bottom (1)] + | otherwise + = case alts_type of + ABot n | n>0 -> ATop [] -- Don't eta expand + | otherwise -> ABot 0 -- if RHS is bottomming + -- See Note [Dealing with bottom (2)] + + ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] + , ae_cheap_fn env scrut Nothing -> ATop as + | exprOkForSpeculation scrut -> ATop as + | otherwise -> ATop (takeWhile isOneShotInfo as) + where + alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] + +arityType env (Let b e) + = floatIn (cheap_bind b) (arityType env e) + where + cheap_bind (NonRec b e) = is_cheap (b,e) + cheap_bind (Rec prs) = all is_cheap prs + is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = vanillaArityType + +{- +************************************************************************ +* * + The main eta-expander +* * +************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alernative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +-} + +-- | @etaExpand n us e ty@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n us e ty +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' +etaExpand :: Arity -- ^ Result should have this number of value args + -> CoreExpr -- ^ Expression to expand + -> CoreExpr +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) +-- +-- It deals with coerces too, though they are now rare +-- so perhaps the extra code isn't worth it + +etaExpand n orig_expr + = go n orig_expr + where + -- Strip off existing lambdas and casts + -- Note [Eta expansion and SCCs] + go 0 expr = expr + go n (Lam v body) | isTyVar v = Lam v (go n body) + | otherwise = Lam v (go (n-1) body) + go n (Cast expr co) = Cast (go n expr) co + go n expr + = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ + retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) + where + in_scope = mkInScopeSet (exprFreeVars expr) + (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) + subst' = mkEmptySubst in_scope' + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = foldl App expr'' args + retick expr = foldr mkTick expr ticks + + -- Wrapper Unwrapper +-------------- +data EtaInfo = EtaVar Var -- /\a. [], [] a + -- \x. [], [] x + | EtaCo Coercion -- [] |> co, [] |> (sym co) + +instance Outputable EtaInfo where + ppr (EtaVar v) = ptext (sLit "EtaVar") <+> ppr v + ppr (EtaCo co) = ptext (sLit "EtaCo") <+> ppr co + +pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] +pushCoercion co1 (EtaCo co2 : eis) + | isReflCo co = eis + | otherwise = EtaCo co : eis + where + co = co1 `mkTransCo` co2 + +pushCoercion co eis = EtaCo co : eis + +-------------- +etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr +etaInfoAbs [] expr = expr +etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) + +-------------- +etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr +-- (etaInfoApp s e eis) returns something equivalent to +-- ((substExpr s e) `appliedto` eis) + +etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) + = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis + +etaInfoApp subst (Cast e co1) eis + = etaInfoApp subst e (pushCoercion co' eis) + where + co' = CoreSubst.substCo subst co1 + +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts' + where + (subst1, b1) = substBndr subst b + alts' = map subst_alt alts + subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) + where + (subst2,bs') = substBndrs subst1 bs + + mk_alts_ty ty [] = ty + mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis + mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis + +etaInfoApp subst (Let b e) eis + = Let b' (etaInfoApp subst' e eis) + where + (subst', b') = subst_bind subst b + +etaInfoApp subst (Tick t e) eis + = Tick (substTickish subst t) (etaInfoApp subst e eis) + +etaInfoApp subst e eis + = go (subst_expr subst e) eis + where + go e [] = e + go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis + go e (EtaCo co : eis) = go (Cast e co) eis + +-------------- +mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type + -> (InScopeSet, [EtaInfo]) + -- EtaInfo contains fresh variables, + -- not free in the incoming CoreExpr + -- Outgoing InScopeSet includes the EtaInfo vars + -- and the original free vars + +mkEtaWW orig_n orig_expr in_scope orig_ty + = go orig_n empty_subst orig_ty [] + where + empty_subst = TvSubst in_scope emptyTvSubstEnv + + go n subst ty eis -- See Note [exprArity invariant] + | n == 0 + = (getTvInScope subst, reverse eis) + + | Just (tv,ty') <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substTyVarBndr subst tv + -- Avoid free vars of the original expression + = go n subst' ty' (EtaVar tv' : eis) + + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', eta_id') = freshEtaId n subst arg_ty + -- Avoid free vars of the original expression + = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + + | Just (co, ty') <- topNormaliseNewType_maybe ty + = -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + go n subst ty' (EtaCo co : eis) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function. + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) + (getTvInScope subst, reverse eis) + -- This *can* legitmately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + + +-------------- +-- Avoiding unnecessary substitution; use short-cutting versions + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr = substExprSC (text "CoreArity:substExpr") + +subst_bind :: Subst -> CoreBind -> (Subst, CoreBind) +subst_bind = substBindSC + + +-------------- +freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + ty' = Type.substTy subst ty + eta_id' = uniqAway (getTvInScope subst) $ + mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' + subst' = extendTvInScope subst eta_id' diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs new file mode 100644 index 00000000..cce313df --- /dev/null +++ b/compiler/coreSyn/CoreFVs.hs @@ -0,0 +1,533 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Taken quite directly from the Peyton Jones/Lester paper. +-} + +{-# LANGUAGE CPP #-} + +-- | A module concerned with finding the free variables of an expression. +module CoreFVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids + exprsFreeVars, -- [CoreExpr] -> VarSet + bindFreeVars, -- CoreBind -> VarSet + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + + -- * Free variables of Rules, Vars and Ids + varTypeTyVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idRuleVars, idRuleRhsVars, stableUnfoldingVars, + ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, + ruleLhsOrphNames, ruleLhsFreeIds, + vectsFreeVars, + + -- * Core syntax tree annotation with free variables + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet + ) where + +#include "HsVersions.h" + +import CoreSyn +import Id +import IdInfo +import NameSet +import UniqFM +import Name +import VarSet +import Var +import TcType +import Coercion +import Maybes( orElse ) +import Util +import BasicTypes( Activation ) +import Outputable + +{- +************************************************************************ +* * +\section{Finding the free variables of an expression} +* * +************************************************************************ + +This function simply finds the free variables of an expression. +So far as type variables are concerned, it only finds tyvars that are + + * free in type arguments, + * free in the type of a binder, + +but not those that are free in the type of variable occurrence. +-} + +-- | Find all locally-defined free Ids or type variables in an expression +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = exprSomeFreeVars isLocalVar + +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + +-- | Find all locally-defined free Ids or type variables in several expressions +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = mapUnionVarSet exprFreeVars + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet +bindFreeVars (Rec prs) = addBndrs (map fst prs) + (foldr (union . rhs_fvs) noVars prs) + isLocalVar emptyVarSet + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand) + +-- | Predicate on possible free variables: returns @True@ iff the variable is interesting +type InterestingVarFun = Var -> Bool + +type FV = InterestingVarFun + -> VarSet -- Locally bound + -> VarSet -- Free vars + -- Return the vars that are both (a) interesting + -- and (b) not locally bound + -- See function keep_it + +keep_it :: InterestingVarFun -> VarSet -> Var -> Bool +keep_it fv_cand in_scope var + | var `elemVarSet` in_scope = False + | fv_cand var = True + | otherwise = False + +union :: FV -> FV -> FV +union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope + +noVars :: FV +noVars _ _ = emptyVarSet + +-- Comment about obselete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- is a little weird. The reason is that the former is more efficient, +-- but the latter is more fine grained, and a makes a difference when +-- a variable mentions itself one of its own rule RHSs" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + +oneVar :: Id -> FV +oneVar var fv_cand in_scope + = ASSERT( isId var ) + if keep_it fv_cand in_scope var + then unitVarSet var + else emptyVarSet + +someVars :: VarSet -> FV +someVars vars fv_cand in_scope + = filterVarSet (keep_it fv_cand in_scope) vars + +addBndr :: CoreBndr -> FV -> FV +addBndr bndr fv fv_cand in_scope + = someVars (varTypeTyVars bndr) fv_cand in_scope + -- Include type varibles in the binder's type + -- (not just Ids; coercion variables too!) + `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr) + +addBndrs :: [CoreBndr] -> FV -> FV +addBndrs bndrs fv = foldr addBndr fv bndrs + +expr_fvs :: CoreExpr -> FV + +expr_fvs (Type ty) = someVars (tyVarsOfType ty) +expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) +expr_fvs (Var var) = oneVar var +expr_fvs (Lit _) = noVars +expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr +expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg +expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) +expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) + +expr_fvs (Case scrut bndr ty alts) + = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr + (foldr (union . alt_fvs) noVars alts) + where + alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + +expr_fvs (Let (NonRec bndr rhs) body) + = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body) + +expr_fvs (Let (Rec pairs) body) + = addBndrs (map fst pairs) + (foldr (union . rhs_fvs) (expr_fvs body) pairs) + +--------- +rhs_fvs :: (Id,CoreExpr) -> FV +rhs_fvs (bndr, rhs) = expr_fvs rhs `union` + someVars (bndrRuleAndUnfoldingVars bndr) + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs :: [CoreExpr] -> FV +exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs + +tickish_fvs :: Tickish Id -> FV +tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids) +tickish_fvs _ = noVars + +{- +************************************************************************ +* * +\section{Free names} +* * +************************************************************************ +-} + +-- | ruleLhsOrphNames is used when deciding whether +-- a rule is an orphan. In particular, suppose that T is defined in this +-- module; we want to avoid declaring that a rule like: +-- +-- > fromIntegral T = fromIntegral_T +-- +-- is an orphan. Of course it isn't, and declaring it an orphan would +-- make the whole module an orphan module, which is bad. +ruleLhsOrphNames :: CoreRule -> NameSet +ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args }) + = extendNameSet (exprsOrphNames tpl_args) fn + -- No need to delete bndrs, because + -- exprsOrphNames finds only External names + +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +exprOrphNames :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +exprOrphNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e co) = go e `unionNameSet` orphNamesOfCo co + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (_,_,r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +-- | Those variables free in the right hand side of a rule +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + -- See Note [Rule free var hack] + +-- | Those variables free in the both the left right hand sides of a rule +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars (BuiltinRule {}) = noFVs +ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) + = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet + -- See Note [Rule free var hack] + +idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet +-- Just the variables free on the *rhs* of a rule +idRuleRhsVars is_active id + = mapUnionVarSet get_fvs (idCoreRules id) + where + get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs + , ru_rhs = rhs, ru_act = act }) + | is_active act + -- See Note [Finding rule RHS free vars] in OccAnal.lhs + = delFromUFM fvs fn -- Note [Rule free var hack] + where + fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + get_fvs _ = noFVs + +-- | Those variables free in the right hand side of several rules +rulesFreeVars :: [CoreRule] -> VarSet +rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules + +ruleLhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +ruleLhsFreeIds (BuiltinRule {}) = noFVs +ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet + +{- +Note [Rule free var hack] (Not a hack any more) +~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. +-} + +-- |Free variables of a vectorisation declaration +vectsFreeVars :: [CoreVect] -> VarSet +vectsFreeVars = mapUnionVarSet vectFreeVars + where + vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (NoVect _) = noFVs + vectFreeVars (VectType _ _ _) = noFVs + vectFreeVars (VectClass _) = noFVs + vectFreeVars (VectInst _) = noFVs + -- this function is only concerned with values, not types + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars +type CoreBindWithFVs = AnnBind Id VarSet +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars +type CoreExprWithFVs = AnnExpr Id VarSet + +freeVarsOf :: CoreExprWithFVs -> IdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (free_vars, _) = free_vars + +noFVs :: VarSet +noFVs = emptyVarSet + +aFreeVar :: Var -> VarSet +aFreeVar = unitVarSet + +unionFVs :: VarSet -> VarSet -> VarSet +unionFVs = unionVarSet + +delBindersFV :: [Var] -> VarSet -> VarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> VarSet -> VarSet +-- This way round, so we can do it multiple times using foldr + +-- (b `delBinderFV` s) removes the binder b from the free variable set s, +-- but *adds* to s +-- +-- the free variables of b's type +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.lhs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b + -- Include coercion variables too! + +varTypeTyVars :: Var -> TyVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyVars var = tyVarsOfType (varType var) + +idFreeVars :: Id -> VarSet +-- Type variables, rule variables, and inline variables +idFreeVars id = ASSERT( isId id) + varTypeTyVars id `unionVarSet` + idRuleAndUnfoldingVars id + +bndrRuleAndUnfoldingVars ::Var -> VarSet +-- A 'let' can bind a type variable, and idRuleVars assumes +-- it's seeing an Id. This function tests first. +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet + | otherwise = idRuleAndUnfoldingVars v + +idRuleAndUnfoldingVars :: Id -> VarSet +idRuleAndUnfoldingVars id = ASSERT( isId id) + idRuleVars id `unionVarSet` + idUnfoldingVars id + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (exprFreeVars rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node +freeVars (Var v) + = (fvs, AnnVar v) + where + -- ToDo: insert motivating example for why we *need* + -- to include the idSpecVars in the FV list. + -- Actually [June 98] I don't think it's necessary + -- fvs = fvs_v `unionVarSet` idSpecVars v + + fvs | isLocalVar v = aFreeVar v + | otherwise = noFVs + +freeVars (Lit lit) = (noFVs, AnnLit lit) +freeVars (Lam b body) + = (b `delBinderFV` freeVarsOf body', AnnLam b body') + where + body' = freeVars body + +freeVars (App fun arg) + = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2) + where + fun2 = freeVars fun + arg2 = freeVars arg + +freeVars (Case scrut bndr ty alts) + = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, + AnnCase scrut2 bndr ty alts2) + where + scrut2 = freeVars scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = foldr unionFVs noFVs alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = freeVars rhs + +freeVars (Let (NonRec binder rhs) body) + = (freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` bndrRuleAndUnfoldingVars binder, + -- Remember any rules; cf rhs_fvs above + AnnLet (AnnNonRec binder rhs2) body2) + where + rhs2 = freeVars rhs + body2 = freeVars body + body_fvs = binder `delBinderFV` freeVarsOf body2 + +freeVars (Let (Rec binds) body) + = (delBindersFV binders all_fvs, + AnnLet (AnnRec (binders `zip` rhss2)) body2) + where + (binders, rhss) = unzip binds + + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + + body2 = freeVars body + body_fvs = freeVarsOf body2 + +freeVars (Cast expr co) + = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) + where + expr2 = freeVars expr + cfvs = tyCoVarsOfCo co + +freeVars (Tick tickish expr) + = (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2) + where + expr2 = freeVars expr + tickishFVs (Breakpoint _ ids) = mkVarSet ids + tickishFVs _ = emptyVarSet + +freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs new file mode 100644 index 00000000..adac6b8a --- /dev/null +++ b/compiler/coreSyn/CoreLint.hs @@ -0,0 +1,1802 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fprof-auto #-} + +module CoreLint ( + lintCoreBindings, lintUnfolding, + lintPassResult, lintInteractiveExpr, lintExpr, + lintAnnots, + + -- ** Debug output + CoreLint.showPass, showPassIO, endPass, endPassIO, + dumpPassResult, + CoreLint.dumpIfSet, + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import CoreMonad +import Bag +import Literal +import DataCon +import TysWiredIn +import TysPrim +import TcType ( isFloatingTy ) +import Var +import VarEnv +import VarSet +import Name +import Id +import PprCore +import ErrUtils +import Coercion +import SrcLoc +import Kind +import Type +import TypeRep +import TyCon +import CoAxiom +import BasicTypes +import ErrUtils as Err +import StaticFlags +import ListSetOps +import PrelNames +import Outputable +import FastString +import Util +import InstEnv ( instanceDFunId ) +import OptCoercion ( checkAxInstCo ) +import UniqSupply + +import HscTypes +import DynFlags +import Control.Monad +import MonadUtils +import Data.Maybe +import Pair + +{- +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document ghc.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Outstanding issues: + + -- Things are *not* OK if: + -- + -- * Unsaturated type app before specialisation has been done; + -- + -- * Oversaturated type app after specialisation (eta reduction + -- may well be happening...); + + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Int in +That is, use a type let. See Note [Type let] in CoreSyn. + +However, when linting we need to remember that a=Int, else we might +reject a correct program. So we carry a type substitution (in this example +[a -> Int]) and apply this substitution before comparing types. The functin + lintInTy :: Type -> LintM Type +returns a substituted type; that's the only reason it returns anything. + +When we encounter a binder (like x::a) we must apply the substitution +to the type of the binding variable. lintBinders does this. + +For Ids, the type-substituted Id is added to the in_scope set (which +itself is part of the TvSubst we are carrying down), and when we +find an occurrence of an Id, we fetch it from the in-scope set. + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a conveneint place. place for them. They print out +stuff before and after core passes, and do Core Lint when necessary. +-} + +showPass :: CoreToDo -> CoreM () +showPass pass = do { dflags <- getDynFlags + ; liftIO $ showPassIO dflags pass } + +showPassIO :: DynFlags -> CoreToDo -> IO () +showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass) + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; print_unqual <- getPrintUnqualified + ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } + +endPassIO :: HscEnv -> PrintUnqualified + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +-- Used by the IO-is CorePrep too +endPassIO hsc_env print_unqual pass binds rules + = do { dumpPassResult dflags print_unqual mb_flag + (ppr pass) (pprPassDetails pass) binds rules + ; lintPassResult hsc_env pass binds } + where + dflags = hsc_dflags hsc_env + mb_flag = case coreDumpFlag pass of + Just flag | dopt flag dflags -> Just flag + | dopt Opt_D_verbose_core2core dflags -> Just flag + _ -> Nothing + +dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dflags dump_me pass extra_info doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc + +dumpPassResult :: DynFlags + -> PrintUnqualified + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult dflags unqual mb_flag hdr extra_info binds rules + | Just flag <- mb_flag + = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc + + | otherwise + = Err.debugTraceMsg dflags 2 size_doc + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + + where + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , pprCoreBindings binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , ptext (sLit "------ Local rules for imported ids --------") + , pprRules rules ] + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () +lintPassResult hsc_env pass binds + | not (gopt Opt_DoCoreLinting dflags) + = return () + | otherwise + = do { let (warns, errs) = lintCoreBindings pass (interactiveInScope hsc_env) binds + ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults dflags pass warns errs binds } + where + dflags = hsc_dflags hsc_env + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not opt_NoDebugOutput + , showLintWarnings pass + = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns) + + | otherwise = return () + where + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> pass + <+> ptext (sLit "***") + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings _ = True + +lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr (interactiveInScope hsc_env) expr + = do { display_lint_err err + ; Err.ghcExit dflags 1 } + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + + display_lint_err err + = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (vcat [ lint_banner "errors" (text what) + , err + , ptext (sLit "*** Offending Program ***") + , pprCoreExpr expr + , ptext (sLit "*** End of Offense ***") ]) + ; Err.ghcExit dflags 1 } + +interactiveInScope :: HscEnv -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See Trac #8215 for an example +interactiveInScope hsc_env + = varSetElems tyvars ++ ids + where + -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr + ictxt = hsc_IC hsc_env + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) + ids = typeEnvIds te + tyvars = mapUnionVarSet (tyVarsOfType . idType) ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) + +lintCoreBindings :: CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings pass local_in_scope binds + = initL flags $ + addLoc TopLevelBindings $ + addInScopeVars local_in_scope $ + addInScopeVars binders $ + -- Put all the top-level binders in scope at the start + -- This is because transformation rules can bring something + -- into use 'unexpectedly' + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; mapM lint_bind binds } + where + flags = LF { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs } + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + binders = bindersOfBinds binds + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT + + -- If you edit this function, you may need to update the GHC formalism + -- See Note [GHC Formalism] + lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs + lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +We use this to check all unfoldings that come in from interfaces +(it is very painful to catch errors otherwise): +-} + +lintUnfolding :: SrcLoc + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintUnfolding locn vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL defaultLintFlags linter + linter = addLoc (ImportedUnfolding locn) $ + addInScopeVars vars $ + lintCoreExpr expr + +lintExpr :: [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL defaultLintFlags linter + linter = addLoc TopLevelBindings $ + addInScopeVars vars $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) + = addLoc (RhsOf binder) $ + -- Check the rhs + do { ty <- lintCoreExpr rhs + ; lintBinder binder -- Check match to RHS type + ; binder_ty <- applySubstTy binder_ty + ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) + + -- Check the let/app invariant + -- See Note [CoreSyn let/app invariant] in CoreSyn + ; checkL (not (isUnLiftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs)) + (mkRhsPrimMsg binder rhs) + + -- Check that if the binder is top-level or recursive, it's not demanded + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) + (mkStrictMsg binder) + + -- Check that if the binder is local, it is not marked as exported + ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) + (mkNonTopExportedMsg binder) + + -- Check that if the binder is local, it does not have an external name + ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) + (mkNonTopExternalNameMsg binder) + + -- Check whether binder's specialisations contain any out-of-scope variables + ; mapM_ (checkBndrIdInScope binder) bndr_vars + + ; flags <- getLintFlags + ; when (lf_check_inline_loop_breakers flags + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- Check whether arity and demand type are consistent (only if demand analysis + -- already happened) + -- + -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] + -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. + -- ; let dmdTy = idStrictness binder + -- ; checkL (case dmdTy of + -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) + -- (mkArityMsg binder) + + ; lintIdUnfolding binder binder_ty (idUnfolding binder) } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + where + binder_ty = idType binder + bndr_vars = varSetElems (idFreeVars binder) + + -- If you edit this function, you may need to update the GHC formalism + -- See Note [GHC Formalism] + lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) + | otherwise = return () + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src + = do { ty <- lintCoreExpr rhs + ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } +lintIdUnfolding _ _ _ + = return () -- We could check more + +{- +Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +--type InKind = Kind -- Substitution not yet applied +type InType = Type +type InCoercion = Coercion +type InVar = Var +type InTyVar = TyVar + +type OutKind = Kind -- Substitution has been applied to this, + -- but has not been linted yet +type LintedKind = Kind -- Substitution applied, and type is linted + +type OutType = Type -- Substitution has been applied to this, + -- but has not been linted yet + +type LintedType = Type -- Substitution applied, and type is linted + +type OutCoercion = Coercion +type OutVar = Var +type OutTyVar = TyVar + +lintCoreExpr :: CoreExpr -> LintM OutType +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreExpr (Var var) + = do { checkL (not (var == oneTupleDataConId)) + (ptext (sLit "Illegal one-tuple")) + + ; checkL (isId var && not (isCoVar var)) + (ptext (sLit "Non term variable") <+> ppr var) + + ; checkDeadIdOcc var + ; var' <- lookupIdInScope var + ; return (idType var') } + +lintCoreExpr (Lit lit) + = return (literalType lit) + +lintCoreExpr (Cast expr co) + = do { expr_ty <- lintCoreExpr expr + ; co' <- applySubstCo co + ; (_, from_ty, to_ty, r) <- lintCoercion co' + ; checkRole co' Representational r + ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr (Tick (Breakpoint _ ids) expr) + = do forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + lintCoreExpr expr + +lintCoreExpr (Tick _other_tickish expr) + = lintCoreExpr expr + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- applySubstTy ty + ; lintTyBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ checkTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendSubstL tv' ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) + ; addLoc (BodyOfLetRec [bndr]) + (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr (Let (Rec pairs) body) + = lintAndScopeIds bndrs $ \_ -> + do { checkL (null dups) (dupVars dups) + ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs + ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } + where + bndrs = map fst pairs + (_, dups) = removeDups compare bndrs + +lintCoreExpr e@(App _ _) + = do { fun_ty <- lintCoreExpr fun + ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } + where + (fun, args) = collectArgs e + +lintCoreExpr (Lam var expr) + = addLoc (LambdaBodyOf var) $ + lintBinder var $ \ var' -> + do { body_ty <- lintCoreExpr expr + ; if isId var' then + return (mkFunTy (idType var') body_ty) + else + return (mkForAllTy var' body_ty) + } + -- The applySubstTy is needed to apply the subst to var + +lintCoreExpr e@(Case scrut var alt_ty alts) = + -- Check the scrutinee + do { scrut_ty <- lintCoreExpr scrut + ; alt_ty <- lintInTy alt_ty + ; var_ty <- lintInTy (idType var) + + -- See Note [Rules for floating-point comparisons] in PrelRules + ; let isLitPat (LitAlt _, _ , _) = True + isLitPat _ = False + ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) + (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ + "expression with literal pattern in case " ++ + "analysis (see Trac #9238).") + $$ text "scrut" <+> ppr scrut) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn && + isAlgTyCon tycon && + not (isFamilyTyCon tycon || isAbstractTyCon tycon) && + null (tyConDataCons tycon) -> + pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate + + ; subst <- getTvSubst + ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + + ; lintAndScopeId var $ \_ -> + do { -- Check the alternatives + mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts + ; return alt_ty } } + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = pprPanic "lintCoreExpr" (ppr ty) + +lintCoreExpr (Coercion co) + = do { (_kind, ty1, ty2, role) <- lintInCo co + ; return (mkCoercionType role ty1 ty2) } + +{- +Note [Kind instantiation in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following coercion axiom: + ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa + +Consider the following instantiation: + ax_co <* -> *> + +We need to split the co_ax_tvs into kind and type variables in order +to find out the coercion kind instantiations. Those can only be Refl +since we don't have kind coercions. This is just a way to represent +kind instantiation. + +We use the number of kind variables to know how to split the coercions +instantiations between kind coercions and type coercions. We lint the +kind coercions and produce the following substitution which is to be +applied in the type variables: + k_ag ~~> * -> * + +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and worth looking at +in the linter (cf Trac #10180). We check two things: + +* exprIsHNF is false: certainly, it would be terribly wrong if the + scrutinee was already in head normal form. + +* exprIsBottom is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +In principle, the first check is redundant: exprIsBottom == True will +always imply exprIsHNF == False. But the first check is reliable: If +exprIsHNF == True, then there definitely is a problem (exprIsHNF errs +on the right side). If the second check triggers then it may be the +case that the compiler got smarter elsewhere, and the empty case is +correct, but that exprIsBottom is unable to see it. In particular, the +empty-type check in exprIsBottom is an approximation. Therefore, this +check is not fully reliable, and we keep both around. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + +lintCoreArg :: OutType -> CoreArg -> LintM OutType +lintCoreArg fun_ty (Type arg_ty) + = do { arg_ty' <- applySubstTy arg_ty + ; lintTyApp fun_ty arg_ty' } + +lintCoreArg fun_ty arg + = do { arg_ty <- lintCoreExpr arg + ; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) + ; lintValApp arg fun_ty arg_ty } + +----------------- +lintAltBinders :: OutType -- Scrutinee type + -> OutType -- Constructor type + -> [OutVar] -- Binders + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders scrut_ty con_ty [] + = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) +lintAltBinders scrut_ty con_ty (bndr:bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + | otherwise + = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + +----------------- +lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp fun_ty arg_ty + | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty + , isTyVar tyvar + = do { checkTyKind tyvar arg_ty + ; return (substTyWith [tyvar] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- +lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType +lintValApp arg fun_ty arg_ty + | Just (arg,res) <- splitFunTy_maybe fun_ty + = do { checkTys arg arg_ty err1 + ; return res } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +checkTyKind :: OutTyVar -> OutType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +checkTyKind tyvar arg_ty + | isSuperKind tyvar_kind -- kind forall + = lintKind arg_ty + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. + | otherwise -- type forall + = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `isSubKind` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } + where + tyvar_kind = tyVarKind tyvar + +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifer correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (DEFAULT, _, _) = False + non_deflt _ = True + + is_infinite_ty = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +checkAltExpr :: CoreExpr -> OutType -> LintM () +checkAltExpr expr ann_ty + = do { actual_ty <- lintCoreExpr expr + ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + +lintCoreAlt :: OutType -- Type of scrutinee + -> OutType -- Type of the alternative + -> CoreAlt + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = + do { checkL (null args) (mkDefaultArgsMsg args) + ; checkAltExpr rhs alt_ty } + +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { checkL (null args) (mkDefaultArgsMsg args) + ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; checkAltExpr rhs alt_ty } + where + lit_ty = literalType lit + +lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) + | isNewTyCon (dataConTyCon con) + = addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + -- We've already check + checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys + + -- And now bring the new binders into scope + ; lintBinders args $ \ args' -> do + { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') + ; checkAltExpr rhs alt_ty } } + + | otherwise -- Scrut-ty is wrong shape + = addErrL (mkBadAltMsg scrut_ty alt) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders [] linterF = linterF [] +lintBinders (var:vars) linterF = lintBinder var $ \var' -> + lintBinders vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: Var -> (Var -> LintM a) -> LintM a +lintBinder var linterF + | isId var = lintIdBndr var linterF + | otherwise = lintTyBndr var linterF + +lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyBndr tv thing_inside + = do { subst <- getTvSubst + ; let (subst', tv') = Type.substTyVarBndr subst tv + ; lintTyBndrKind tv' + ; updateTvSubst subst' (thing_inside tv') } + +lintIdBndr :: Id -> (Id -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules + +lintIdBndr id linterF + = do { lintAndScopeId id $ \id' -> linterF id' } + +lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a +lintAndScopeIds ids linterF + = go ids + where + go [] = linterF [] + go (id:ids) = lintAndScopeId id $ \id -> + lintAndScopeIds ids $ \ids -> + linterF (id:ids) + +lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a +lintAndScopeId id linterF + = do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (ptext (sLit "Non-local Id binder") <+> ppr id) + -- See Note [Checking for global Ids] + ; ty <- lintInTy (idType id) + ; let id' = setIdType id ty + ; addInScopeVar id' $ (linterF id') } + +{- +************************************************************************ +* * + Types and kinds +* * +************************************************************************ + +We have a single linter for types and kinds. That is convenient +because sometimes it's not clear whether the thing we are looking +at is a type or a kind. +-} + +lintInTy :: InType -> LintM LintedType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintInTy ty + = addLoc (InType ty) $ + do { ty' <- applySubstTy ty + ; _k <- lintType ty' + ; return ty' } + +------------------- +lintTyBndrKind :: OutTyVar -> LintM () +-- Handles both type and kind foralls. +lintTyBndrKind tv = lintKind (tyVarKind tv) + +------------------- +lintType :: OutType -> LintM LintedKind +-- The returned Kind has itself been linted + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + = do { checkTyCoVarInScope tv + ; return (tyVarKind tv) } + -- We checked its kind when we added it to the envt + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lint_ty_app ty k1 [(t2,k2)] } + +lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } + +lintType ty@(TyConApp tc tys) + | Just ty' <- coreView ty + = lintType ty' -- Expand type synonyms, so that we do not bogusly complain + -- about un-saturated type synonyms + + | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + -- See Note [The kind invariant] in TypeRep + -- Also type synonyms and type families + , length tys < tyConArity tc + = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty)) + + | otherwise + = do { ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +lintKind :: OutKind -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintKind k = do { sk <- lintType k + ; unless (isSuperKind sk) + (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) + 2 (ptext (sLit "has kind:") <+> ppr sk))) } + +lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 + -- or lintarrow "coercion `blah'" k1 k2 + | isSuperKind k1 + = return superKind + | otherwise + = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) + ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) + ; return liftedTypeKind } + where + msg ar k + = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) + 2 (ptext (sLit "in") <+> what) + , what <+> ptext (sLit "kind:") <+> ppr k ] + +lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_ty_app ty k tys + = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_co_app ty k tys + = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n +lintTyLit (StrTyLit _) = return () + +lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind +-- (lint_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind +-- Takes care of linting the OutTypes + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lint_app doc kfn kas + = foldlM go_app kfn kas + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] + + go_app kfn ka + | Just kfn' <- coreView kfn + = go_app kfn' ka + + go_app (FunTy kfa kfb) (_,ka) + = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) + ; return kfb } + + go_app (ForAllTy kv kfn) (ta,ka) + = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) + ; return (substKiWith [kv] [ta] kfn) } + + go_app _ _ = failWithL fail_msg + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role) +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; lintCoercion co' } + +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role) +-- Check the kind of a coercion term, returning the kind +-- Post-condition: the returned OutTypes are lint-free +-- and have the same kind as each other + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoercion (Refl r ty) + = do { k <- lintType ty + ; return (k, ty, ty, r) } + +lintCoercion co@(TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [co1,co2] <- cos + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 + ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 + ; checkRole co1 r r1 + ; checkRole co2 r r2 + ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } + + | Just {} <- synTyConDefn_maybe tc + = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) + + | otherwise + = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos + ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) + ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs + ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) } + +lintCoercion co@(AppCo co1 co2) + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 + ; rk <- lint_co_app co k1 [(s2,k2)] + ; if r1 == Phantom + then checkL (r2 == Phantom || r2 == Nominal) + (ptext (sLit "Second argument in AppCo cannot be R:") $$ + ppr co) + else checkRole co Nominal r2 + ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) } + +lintCoercion (ForAllCo tv co) + = do { lintTyBndrKind tv + ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co) + ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) } + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv) + 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) + | otherwise + = do { checkTyCoVarInScope cv + ; cv' <- lookupIdInScope cv + ; let (s,t) = coVarKind cv' + k = typeKind s + r = coVarRole cv' + ; when (isSuperKind k) $ + do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality")) + 2 (ppr cv)) + ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) + 2 (ppr cv)) } + ; return (k, s, t, r) } + +lintCoercion (UnivCo _prov r ty1 ty2) + = do { k1 <- lintType ty1 + ; _k2 <- lintType ty2 +-- ; unless (k1 `eqKind` k2) $ +-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) +-- 2 (ppr co)) + ; return (k1, ty1, ty2, r) } + +lintCoercion (SymCo co) + = do { (k, ty1, ty2, r) <- lintCoercion co + ; return (k, ty2, ty1, r) } + +lintCoercion co@(TransCo co1 co2) + = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1 + ; (_, ty2a, ty2b, r2) <- lintCoercion co2 + ; checkL (ty1b `eqType` ty2a) + (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) + 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) + ; checkRole co r1 r2 + ; return (k1, ty1a, ty2b, r1) } + +lintCoercion the_co@(NthCo n co) + = do { (_,s,t,r) <- lintCoercion co + ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , isDistinctTyCon tc_s || r /= Representational + -- see Note [NthCo and newtypes] in Coercion + , tys_s `equalLength` tys_t + , n < length tys_s + -> return (ks, ts, tt, tr) + where + ts = getNth tys_s n + tt = getNth tys_t n + tr = nthRole r tc_s n + ks = typeKind ts + + _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion the_co@(LRCo lr co) + = do { (_,s,t,r) <- lintCoercion co + ; checkRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just s_pr, Just t_pr) + -> return (k, s_pick, t_pick, Nominal) + where + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + k = typeKind s_pick + + _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg_ty) + = do { (k,s,t,r) <- lintCoercion co + ; arg_kind <- lintType arg_ty + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + (Just (tv1,ty1), Just (tv2,ty2)) + | arg_kind `isSubKind` tyVarKind tv1 + -> return (k, substTyWith [tv1] [arg_ty] ty1, + substTyWith [tv2] [arg_ty] ty2, r) + | otherwise + -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) + _ -> failWithL (ptext (sLit "Bad argument of inst")) } + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con)) + (bad_ax (ptext (sLit "index out of range"))) + -- See Note [Kind instantiation in coercions] + ; let CoAxBranch { cab_tvs = ktvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomNthBranch con ind + ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) + ; in_scope <- getInScope + ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv + ; (subst_l, subst_r) <- foldlM check_ki + (empty_subst, empty_subst) + (zip3 ktvs roles cos) + ; let lhs' = Type.substTys subst_l lhs + rhs' = Type.substTy subst_r rhs + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) + Nothing -> return () + ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } + where + bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, co) + = do { (k, t1, t2, r) <- lintCoercion co + ; checkRole co role r + ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) + -- Using subst_l is ok, because subst_l and subst_r + -- must agree on kind equalities + ; unless (k `isSubKind` ktv_kind) + (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) + ; return (Type.extendTvSubst subst_l ktv t1, + Type.extendTvSubst subst_r ktv t2) } + +lintCoercion co@(SubCo co') + = do { (k,s,t,r) <- lintCoercion co' + ; checkRole co Nominal r + ; return (k,s,t,Representational) } + + +lintCoercion this@(AxiomRuleCo co ts cs) + = do _ks <- mapM lintType ts + eqs <- mapM lintCoercion cs + + let tyNum = length ts + + case compare (coaxrTypeArity co) tyNum of + EQ -> return () + LT -> err "Too many type arguments" + [ txt "expected" <+> int (coaxrTypeArity co) + , txt "provided" <+> int tyNum ] + GT -> err "Not enough type arguments" + [ txt "expected" <+> int (coaxrTypeArity co) + , txt "provided" <+> int tyNum ] + checkRoles 0 (coaxrAsmpRoles co) eqs + + case coaxrProves co ts [ Pair l r | (_,l,r,_) <- eqs ] of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just (Pair l r) -> + do kL <- lintType l + kR <- lintType r + unless (eqKind kL kR) + $ err "Kind error in CoAxiomRule" + [ppr kL <+> txt "/=" <+> ppr kR] + return (kL, l, r, coaxrRole co) + where + txt = ptext . sLit + err m xs = failWithL $ + hang (txt m) 2 $ vcat (txt "Rule:" <+> ppr (coaxrName co) : xs) + + checkRoles n (e : es) ((_,_,_,r) : rs) + | e == r = checkRoles (n+1) es rs + | otherwise = err "Argument roles mismatch" + [ txt "In argument:" <+> int (n+1) + , txt "Expected:" <+> ppr e + , txt "Found:" <+> ppr r ] + checkRoles _ [] [] = return () + checkRoles n [] rs = err "Too many coercion arguments" + [ txt "Expected:" <+> int n + , txt "Provided:" <+> int (n + length rs) ] + + checkRoles n es [] = err "Not enough coercion arguments" + [ txt "Expected:" <+> int (n + length es) + , txt "Provided:" <+> int n ] + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + , le_subst :: TvSubst -- Current type substitution; we also use this + } -- to keep track of all the variables in scope, + -- both Ids and TyVars + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + } + +defaultLintFlags :: LintFlags +defaultLintFlags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True } + +newtype LintM a = + LintM { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Error and warning messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and Trac #9857. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. +-} + +instance Functor LintM where + fmap = liftM + +instance Applicative LintM where + pure = return + (<*>) = ap + +instance Monad LintM where + return x = LintM (\ _ errs -> (Just x, errs)) + fail err = failWithL (text err) + m >>= k = LintM (\ env errs -> + let (res, errs') = unLintM m env errs in + case res of + Just r -> unLintM (k r) env errs' + Nothing -> (Nothing, errs')) + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf Id -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + +initL :: LintFlags -> LintM a -> WarnsAndErrs -- Errors and warnings +initL flags m + = case unLintM m env (emptyBag, emptyBag) of + (_, errs) -> errs + where + env = LE { le_flags = flags, le_subst = emptyTvSubst, le_loc = [] } + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +failWithL :: MsgDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + (Nothing, (warns, addMsg env errs msg)) + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + (Just (), (warns, addMsg env errs msg)) + +addWarnL :: MsgDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + (Just (), (addMsg env warns msg, errs)) + +addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg env msgs msg + = ASSERT( notNull locs ) + msgs `snocBag` mk_msg msg + where + locs = le_loc env + (loc, cxt1) = dumpLoc (head locs) + cxts = [snd (dumpLoc loc) | loc <- locs] + context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ + ptext (sLit "Substitution:") <+> ppr (le_subst env) + | otherwise = cxt1 + + mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeVars :: [Var] -> LintM a -> LintM a +addInScopeVars vars m + = LintM $ \ env errs -> + unLintM m (env { le_subst = extendTvInScopeList (le_subst env) vars }) + errs + +addInScopeVar :: Var -> LintM a -> LintM a +addInScopeVar var m + = LintM $ \ env errs -> + unLintM m (env { le_subst = extendTvInScope (le_subst env) var }) errs + +extendSubstL :: TyVar -> Type -> LintM a -> LintM a +extendSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +updateTvSubst :: TvSubst -> LintM a -> LintM a +updateTvSubst subst' m + = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs + +getTvSubst :: LintM TvSubst +getTvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> (Just (getTvInScope (le_subst env)), errs)) + +applySubstTy :: InType -> LintM OutType +applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } + +applySubstCo :: InCoercion -> LintM OutCoercion +applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } + +lookupIdInScope :: Id -> LintM Id +lookupIdInScope id + | not (mustHaveLocalBinding id) + = return id -- An imported Id + | otherwise + = do { subst <- getTvSubst + ; case lookupInScope (getTvInScope subst) id of + Just v -> return v + Nothing -> do { addErrL out_of_scope + ; return id } } + where + out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") + + +oneTupleDataConId :: Id -- Should not happen +oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) + +checkBndrIdInScope :: Var -> Var -> LintM () +checkBndrIdInScope binder id + = checkInScope msg id + where + msg = ptext (sLit "is out of scope inside info for") <+> + ppr binder + +checkTyCoVarInScope :: Var -> LintM () +checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v + +checkInScope :: SDoc -> Var -> LintM () +checkInScope loc_msg var = + do { subst <- getTvSubst + ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) + (hsep [pprBndr LetBind var, loc_msg]) } + +checkTys :: OutType -> OutType -> MsgDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have alrady had the substitution applied +checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg + +checkRole :: Coercion + -> Role -- expected + -> Role -- actual + -> LintM () +checkRole co r1 r2 + = checkL (r1 == r2) + (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> + ptext (sLit "got") <+> ppr r2 $$ + ptext (sLit "in") <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) + +dumpLoc (BodyOfLetRec bs@(_:_)) + = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs)) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (con, args, _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (con, args, _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (ImportedUnfolding locn) + = (locn, brackets (ptext (sLit "in an imported unfolding"))) +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ppr ty1, ppr ty2, ppr e]) + +mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc +mkScrutMsg var var_ty scrut_ty subst + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty, + hsep [ptext (sLit "Current TV subst"), ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg fun_ty arg_ty arg + = vcat [ptext (sLit "Argument value doesn't match argument type:"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [ptext (sLit "Non-function type in function position"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr bndr rhs + = vcat [ptext (sLit "Bad `let' binding:"), + hang (ptext (sLit "Variable:")) + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (ptext (sLit "Rhs:")) + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (ptext (sLit "Exp type:")) + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty + = vcat + [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon, + ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], + hsep [ptext (sLit "Rhs type:"), ppr ty]] + +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) + 2 (ppr e) + +mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc +mkRhsPrimMsg binder _rhs + = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), + ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] + ] + +mkStrictMsg :: Id -> MsgDoc +mkStrictMsg binder + = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), + ppr binder], + hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] + ] + +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] + +mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg tyvar arg_ty + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +{- Not needed now +mkArityMsg :: Id -> MsgDoc +mkArityMsg binder + = vcat [hsep [ptext (sLit "Demand type has"), + ppr (dmdTypeDepth dmd_ty), + ptext (sLit "arguments, rhs has"), + ppr (idArity binder), + ptext (sLit "arguments,"), + ppr binder], + hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] + + ] + where (StrictSig dmd_ty) = idStrictness binder +-} +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr co from_ty expr_ty + = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), + ptext (sLit "From-type:") <+> ppr from_ty, + ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, + ptext (sLit "Actual enclosed expr:") <+> ppr expr, + ptext (sLit "Coercion used in cast:") <+> ppr co + ] + +dupVars :: [[Var]] -> MsgDoc +dupVars vars + = hang (ptext (sLit "Duplicate variables brought into scope")) + 2 (ppr vars) + +dupExtVars :: [[Name]] -> MsgDoc +dupExtVars vars + = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) + 2 (ppr vars) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = do + -- Run the pass as we normally would + dflags <- getDynFlags + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass dflags "Annotation linting - first run" + nguts <- pass guts + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + when (gopt Opt_DoAnnotationLinting dflags) $ do + liftIO $ Err.showPass dflags "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass dflags "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ CoreMonad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs + ] + -- Return actual new guts + return nguts + +-- | Run the given pass without annotations. This means that we both +-- remove the @Opt_Debug@ flag from the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + dflags <- getDynFlags + let removeFlag env = env{hsc_dflags = gopt_unset dflags Opt_Debug} + withoutFlag corem = + liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> + getUniqueSupplyM <*> getModule <*> + getPrintUnqualified <*> pure corem + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of @Opt_Debug@? + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied + fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs new file mode 100644 index 00000000..924dfb48 --- /dev/null +++ b/compiler/coreSyn/CorePrep.hs @@ -0,0 +1,1293 @@ +{- +(c) The University of Glasgow, 1994-2006 + + +Core pass to saturate constructors and PrimOps +-} + +{-# LANGUAGE BangPatterns, CPP #-} + +module CorePrep ( + corePrepPgm, corePrepExpr, cvtLitInteger, + lookupMkIntegerName, lookupIntegerSDataConName + ) where + +#include "HsVersions.h" + +import OccurAnal + +import HscTypes +import PrelNames +import CoreUtils +import CoreArity +import CoreFVs +import CoreMonad ( CoreToDo(..) ) +import CoreLint ( endPassIO ) +import CoreSyn +import CoreSubst +import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here +import Type +import Literal +import Coercion +import TcEnv +import TcRnMonad +import TyCon +import Demand +import Var +import VarSet +import VarEnv +import Id +import IdInfo +import TysWiredIn +import DataCon +import PrimOp +import BasicTypes +import Module +import UniqSupply +import Maybes +import OrdList +import ErrUtils +import DynFlags +import Util +import Pair +import Outputable +import Platform +import FastString +import Config +import Name ( NamedThing(..), nameSrcSpan ) +import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) +import Data.Bits +import Data.List ( mapAccumL ) +import Control.Monad + +{- +-- --------------------------------------------------------------------------- +-- Overview +-- --------------------------------------------------------------------------- + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form; that is, function arguments + are always variables. + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that *value* lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + Type lambdas are ok, however, because the code gen discards them. + +5. [Not any more; nuked Jun 2002] Do the seq/par munging. + +6. Clone all local Ids. + This means that all such Ids are unique, rather than the + weaker guarantee of no clashes which the simplifier provides. + And that is what the code generator needs. + + We don't clone TyVars or CoVars. The code gen doesn't need that, + and doing so would be tiresome because then we'd need + to substitute in types and coercions. + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +8. Inject bindings for the "implicit" Ids: + * Constructor wrappers + * Constructor workers + We want curried definitions for all of these in case they + aren't inlined by some caller. + +9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs + +10. Convert (LitInteger i t) into the core representation + for the Integer i. Normally this uses mkInteger, but if + we are using the integer-gmp implementation then there is a + special case where we use the S# constructor for Integers that + are in the range of Int. + +11. Uphold tick consistency while doing this: We move ticks out of + (non-type) applications where we can, and make sure that we + annotate according to scoping rules when floating. + +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + + +Invariants +~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: + + Trivial expressions + triv ::= lit | var + | triv ty | /\a. triv + | truv co | /\c. triv | triv |> co + + Applications + app ::= lit | var | app triv | app ty | app co | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co + + Right hand sides (only place where value lambdas can occur) + rhs ::= /\a.rhs | \x.rhs | body + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. +-} + +type CpeTriv = CoreExpr -- Non-terminal 'triv' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' + +{- +************************************************************************ +* * + Top level stuff +* * +************************************************************************ +-} + +corePrepPgm :: HscEnv -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram +corePrepPgm hsc_env mod_loc binds data_tycons = do + let dflags = hsc_dflags hsc_env + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env + + let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + + binds_out = initUs_ us $ do + floats1 <- corePrepTopBinds initialCorePrepEnv binds + floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds + return (deFloatTop (floats1 `appendFloats` floats2)) + + endPassIO hsc_env alwaysQualify CorePrep binds_out [] + return binds_out + +corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr dflags hsc_env expr = do + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) + return new_expr + +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind + binds' <- go env' binds + return (bind' `appendFloats` binds') + +mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] +-- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in TidyPgm +mkDataConWorkers dflags mod_loc data_tycons + = [ NonRec id (tick_it (getName data_con) (Var id)) + -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con + ] + where + -- If we want to generate debug info, we put a source note on the + -- worker. This is useful, especially for heap profiling. + tick_it name + | not (gopt Opt_Debug dflags) = id + | RealSrcSpan span <- nameSrcSpan name = tick span + | Just file <- ml_hs_file mod_loc = tick (span1 file) + | otherwise = tick (span1 "???") + where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name)) + span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + +{- +Note [Floating out of top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: we do need to float out of top-level bindings +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [CafInfo and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What happens when we try to float bindings to the top level? At this +point all the CafInfo is supposed to be correct, and we must make certain +that is true of the new top-level bindings. There are two cases +to consider + +a) The top-level binding is marked asCafRefs. In that case we are + basically fine. The floated bindings had better all be lazy lets, + so they can float to top level, but they'll all have HasCafRefs + (the default) which is safe. + +b) The top-level binding is marked NoCafRefs. This really happens + Example. CoreTidy produces + $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... + Now CorePrep has to eta-expand to + $fApplicativeSTM = let sat = \xy. retry x y + in D:Alternative sat ...blah... + So what we *want* is + sat [NoCafRefs] = \xy. retry x y + $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... + + So, gruesomely, we must set the NoCafRefs flag on the sat bindings, + *and* substutite the modified 'sat' into the old RHS. + + It should be the case that 'sat' is itself [NoCafRefs] (a value, no + cafs) else the original top-level binding would not itself have been + marked [NoCafRefs]. The DEBUG check in CoreToStg for + consistentCafInfo will find this. + +This is all very gruesome and horrible. It would be better to figure +out CafInfo later, after CorePrep. We'll do that in due course. +Meanwhile this horrible hack works. + + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. + + +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this (see Trac #4962): + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they +are only kept alive by the occurrence analyser because they are +referred to by the rules of g, which is being kept alive by the fact +that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g +will ever fire, and it really seems like a shame to produce an output +program that goes to the trouble of allocating a closure for the +unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + + * In deFloatTop, run a simple dead code analyser on each top-level + RHS to drop the dead local bindings. For that call to OccAnal, we + disable the binder swap, else the occurrence analyser sometimes + introduces new let bindings for cased binders, which lead to the bug + in #5433. + +The reason we don't just OccAnal the whole output of CorePrep is that +the tidier ensures that all top-level binders are GlobalIds, so they +don't show up in the free variables any longer. So if you run the +occurrence analyser on the output of CoreTidy (or later) you e.g. turn +this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + +************************************************************************ +* * + The main code +* * +************************************************************************ +-} + +cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, Floats) +cpeBind top_lvl env (NonRec bndr rhs) + = do { (_, bndr1) <- cpCloneBndr env bndr + ; let dmd = idDemandInfo bndr + is_unlifted = isUnLiftedType (idType bndr) + ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive + dmd + is_unlifted + env bndr1 rhs + ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 + + -- We want bndr'' in the envt, because it records + -- the evaluated-ness of the binder + ; return (extendCorePrepEnv env bndr bndr2, + addFloat floats new_float) } + +cpeBind top_lvl env (Rec pairs) + = do { let (bndrs,rhss) = unzip pairs + ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss + + ; let (floats_s, bndrs2, rhss2) = unzip3 stuff + all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) + (concatFloats floats_s) + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + unitFloat (FloatLet (Rec all_pairs))) } + where + -- Flatten all the floats, and the currrent + -- group into a single giant Rec + add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 + add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + add_float b _ = pprPanic "cpeBind" (ppr b) + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool + -> CorePrepEnv -> Id -> CoreExpr + -> UniqSM (Floats, Id, CpeRhs) +-- Used for all bindings +cpePair top_lvl is_rec dmd is_unlifted env bndr rhs + = do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs3) + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat topDmd False v rhs2 + ; return ( addFloat floats2 float + , cpeEtaExpand arity (Var v)) }) + + -- Wrap floating ticks + ; let (floats4, rhs4) = wrapTicks floats3 rhs3 + + -- Record if the binder is evaluated + -- and otherwise trim off the unfolding altogether + -- It's not used by the code generator; getting rid of it reduces + -- heap usage and, since we may be changing uniques, we'd have + -- to substitute to keep it right + ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr `setIdUnfolding` noUnfolding + + ; return (floats4, bndr', rhs4) } + where + is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted + + platform = targetPlatform (cpe_dynFlags env) + + arity = idArity bndr -- We must match this arity + + --------------------- + float_from_rhs floats rhs + | isEmptyFloats floats = return (emptyFloats, rhs) + | isTopLevel top_lvl = float_top floats rhs + | otherwise = float_nested floats rhs + + --------------------- + float_nested floats rhs + | wantFloatNested is_rec is_strict_or_unlifted floats rhs + = return (floats, rhs) + | otherwise = dont_float floats rhs + + --------------------- + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] + | mayHaveCafRefs (idCafInfo bndr) + , allLazyTop floats + = return (floats, rhs) + + -- So the top-level binding is marked NoCafRefs + | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs + = return (floats', rhs') + + | otherwise + = dont_float floats rhs + + --------------------- + dont_float floats rhs + -- Non-empty floats, but do not want to float from rhs + -- So wrap the rhs in the floats + -- But: rhs1 might have lambdas, and we can't + -- put them inside a wrapBinds + = do { body <- rhsToBodyNF rhs + ; return (emptyFloats, wrapBinds floats body) } + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} + +-- --------------------------------------------------------------------------- +-- CpeRhs: produces a result satisfying CpeRhs +-- --------------------------------------------------------------------------- + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE env (Lit (LitInteger i _)) + = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) + (cpe_integerSDataCon env) i) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr + +cpeRhsE env (Var f `App` _ `App` arg) + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId + +cpeRhsE env expr@(App {}) = cpeApp env expr + +cpeRhsE env (Let bind expr) + = do { (env', new_binds) <- cpeBind NotTopLevel env bind + ; (floats, body) <- cpeRhsE env' expr + ; return (new_binds `appendFloats` floats, body) } + +cpeRhsE env (Tick tickish expr) + | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope + = do { (floats, body) <- cpeRhsE env expr + -- See [Floating Ticks in CorePrep] + ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } + | otherwise + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, mkTick tickish' body) } + where + tickish' | Breakpoint n fvs <- tickish + = Breakpoint n (map (lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' co) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cpCloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +cpeRhsE env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBody env scrut + ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + ; (env', bndr2) <- cpCloneBndr env bndr1 + ; alts' <- mapM (sat_alt env') alts + ; return (floats, Case scrut' bndr2 ty alts') } + where + sat_alt env (con, bs, rhs) + = do { (env2, bs') <- cpCloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (con, bs', rhs') } + +cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr +-- Here we convert a literal Integer to the low-level +-- represenation. Exactly how we do this depends on the +-- library that implements Integer. If it's GMP we +-- use the S# data constructor for small literals. +-- See Note [Integer literals] in Literal +cvtLitInteger dflags _ (Just sdatacon) i + | inIntRange dflags i -- Special case for small integers + = mkConApp sdatacon [Lit (mkMachInt dflags i)] + +cvtLitInteger dflags mk_integer _ i + = mkApps (Var mk_integer) [isNonNegative, ints] + where isNonNegative = if i < 0 then mkConApp falseDataCon [] + else mkConApp trueDataCon [] + ints = mkListExpr intTy (f (abs i)) + f 0 = [] + f x = let low = x .&. mask + high = x `shiftR` bits + in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high + bits = 31 + mask = 2 ^ bits - 1 + +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- + +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } + +-------- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody rhs + ; return (floats1 `appendFloats` floats2, body) } + +-------- +rhsToBodyNF :: CpeRhs -> UniqSM CpeBody +rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs + ; return (wrapBinds floats body) } + +-------- +rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding + +rhsToBody (Tick t expr) + | tickishScoped t == NoScope -- only float out of non-scoped annotations + = do { (floats, expr') <- rhsToBody expr + ; return (floats, mkTick t expr') } + +rhsToBody (Cast e co) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, e') <- rhsToBody e + ; return (floats, Cast e' co) } + +rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { fn <- newVar (exprType expr) + ; let rhs = cpeEtaExpand (exprArity expr) expr + float = FloatLet (NonRec fn rhs) + ; return (unitFloat float, Var fn) } + where + (bndrs,body) = collectBinders expr + +rhsToBody expr = return (emptyFloats, expr) + + + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- May return a CpeRhs because of saturating primops +cpeApp env expr + = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 + ; MASSERT(null ss) -- make sure we used all the strictness info + + -- Now deal with the function + ; case head of + Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth + ; return (floats, sat_app) } + _other -> return (floats, app) } + + where + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + + collect_args + :: CoreExpr + -> Int -- Current app depth + -> UniqSM (CpeApp, -- The rebuilt expression + (CoreExpr,Int), -- The head of the application, + -- and no. of args it was applied to + Type, -- Type of the whole expr + Floats, -- Any floats we pulled out + [Demand]) -- Remaining argument demands + + collect_args (App fun arg@(Type arg_ty)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + + collect_args (App fun arg@(Coercion arg_co)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } + + collect_args (App fun arg) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) + ; let + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (topDmd, []) + (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ + splitFunTy_maybe fun_ty + + ; (fs, arg') <- cpeArg env ss1 arg arg_ty + ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } + + collect_args (Var v) depth + = do { v1 <- fiddleCCall v + ; let v2 = lookupCorePrepEnv env v1 + ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } + where + stricts = case idStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + collect_args (Cast fun co) depth + = do { let Pair _ty1 ty2 = coercionKind co + ; (fun', hd, _, floats, ss) <- collect_args fun depth + ; return (Cast fun' co, hd, ty2, floats, ss) } + + collect_args (Tick tickish fun) depth + | tickishPlace tickish == PlaceNonLam + && tickish `tickishScopesLike` SoftScope + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + -- See [Floating Ticks in CorePrep] + ; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) } + + -- N-variable fun, better let-bind it + collect_args fun depth + = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty + -- The evalDmd says that it's sure to be evaluated, + -- so we'll end up case-binding it + ; return (fun', (fun', depth), ty, fun_floats, []) } + where + ty = exprType fun + +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> Demand + -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) +cpeArg env dmd arg arg_ty + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else do { body1 <- rhsToBodyNF arg1 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument + then return (floats2, arg2) + else do + { v <- newVar arg_ty + ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + arg_float = mkFloat dmd is_unlifted v arg3 + ; return (addFloat floats2 arg_float, varToCoreExpr v) } } + where + is_unlifted = isUnLiftedType arg_ty + is_strict = isStrictDmd dmd + want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) + +{- +Note [Floating unlifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider C (let v* = expensive in v) + +where the "*" indicates "will be demanded". Usually v will have been +inlined by now, but let's suppose it hasn't (see Trac #2756). Then we +do *not* want to get + + let v* = expensive in C v + +because that has different strictness. Hence the use of 'allLazy'. +(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) + + +------------------------------------------------------------------------------ +-- Building the saturated syntax +-- --------------------------------------------------------------------------- + +maybeSaturate deals with saturating primops and constructors +The type is the type of the entire application +-} + +maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs +maybeSaturate fn expr n_args + | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg + -- A gruesome special case + = saturateDataToTag sat_expr + + | hasNoBinding fn -- There's no binding + = return sat_expr + + | otherwise + = return expr + where + fn_arity = idArity fn + excess_arity = fn_arity - n_args + sat_expr = cpeEtaExpand excess_arity expr + +------------- +saturateDataToTag :: CpeApp -> UniqSM CpeApp +-- See Note [dataToTag magic] +saturateDataToTag sat_expr + = do { let (eta_bndrs, eta_body) = collectBinders sat_expr + ; eta_body' <- eval_data2tag_arg eta_body + ; return (mkLams eta_bndrs eta_body') } + where + eval_data2tag_arg :: CpeApp -> UniqSM CpeBody + eval_data2tag_arg app@(fun `App` arg) + | exprIsHNF arg -- Includes nullary constructors + = return app -- The arg is evaluated + | otherwise -- Arg not evaluated, so evaluate it + = do { arg_id <- newVar (exprType arg) + ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding + ; return (Case arg arg_id1 (exprType app) + [(DEFAULT, [], fun `App` Var arg_id1)]) } + + eval_data2tag_arg (Tick t app) -- Scc notes can appear + = do { app' <- eval_data2tag_arg app + ; return (Tick t app') } + + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) + +{- +Note [dataToTag magic] +~~~~~~~~~~~~~~~~~~~~~~ +Horrid: we must ensure that the arg of data2TagOp is evaluated + (data2tag x) --> (case x of y -> data2tag y) +(yuk yuk) take into account the lambdas we've now introduced + +How might it not be evaluated? Well, we might have floated it out +of the scope of a `seq`, or dropped the `seq` altogether. + + +************************************************************************ +* * + Simple CoreSyn operations +* * +************************************************************************ +-} + +cpe_ExprIsTrivial :: CoreExpr -> Bool +-- Version that doesn't consider an scc annotation to be trivial. +cpe_ExprIsTrivial (Var _) = True +cpe_ExprIsTrivial (Type _) = True +cpe_ExprIsTrivial (Coercion _) = True +cpe_ExprIsTrivial (Lit _) = True +cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body +cpe_ExprIsTrivial _ = False + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little words for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead CoreArity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y +-} + +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Why try eta reduction? Hasn't the simplifier already done eta? +But the simplifier only eta reduces if that leaves something +trivial (like f, or f Int). But for deLam it would be enough to +get to a partial application: + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } +-} + +tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReducePrep bndrs expr@(App _ _) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes + = Just remaining_expr + where + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + ok bndr (Var arg) = bndr == arg + ok _ _ = False + + -- We can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) = not (hasNoBinding f) + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise + +tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) + | not (any (`elemVarSet` fvs) bndrs) + = case tryEtaReducePrep bndrs body of + Just e -> Just (Let bind e) + Nothing -> Nothing + where + fvs = exprFreeVars r + +tryEtaReducePrep bndrs (Tick tickish e) + = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e + +tryEtaReducePrep _ _ = Nothing + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ + +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets so that we can see the one-shot thunks. +-} + +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + Id CpeBody + Bool -- The bool indicates "ok-for-speculation" + + -- | See Note [Floating Ticks in CorePrep] + | FloatTick (Tickish Id) + +data Floats = Floats OkToSpec (OrdList FloatingBind) + +instance Outputable FloatingBind where + ppr (FloatLet b) = ppr b + ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r + ppr (FloatTick t) = ppr t + +instance Outputable Floats where + ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+> + braces (vcat (map ppr (fromOL fs))) + +instance Outputable OkToSpec where + ppr OkToSpec = ptext (sLit "OkToSpec") + ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") + ppr NotOkToSpec = ptext (sLit "NotOkToSpec") + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + +mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind +mkFloat dmd is_unlifted bndr rhs + | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + -- See Note [Pin demand info on floats] + where + is_hnf = exprIsHNF rhs + is_strict = isStrictDmd dmd + use_case = is_unlifted || is_strict && not is_hnf + -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL + +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs + +wrapBinds :: Floats -> CpeBody -> CpeBody +wrapBinds (Floats _ binds) body + = foldrOL mk_bind body binds + where + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body + mk_bind (FloatTick tickish) body = mkTick tickish body + +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet _) = OkToSpec + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + check FloatTick{} = OkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> OrdList FloatingBind +concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL + +combine :: OkToSpec -> OkToSpec -> OkToSpec +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = occurAnalyseRHSs b : bs + get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) + occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] + +--------------------------------------------------------------------------- + +canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) + -- Note [CafInfo and floating] +canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs + | OkToSpec <- ok_to_spec -- Worth trying + , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) + = Just (Floats OkToSpec fs', subst_expr subst rhs) + | otherwise + = Nothing + where + subst_expr = substExpr (text "CorePrep") + + go :: (Subst, OrdList FloatingBind) -> [FloatingBind] + -> Maybe (Subst, OrdList FloatingBind) + + go (subst, fbs_out) [] = Just (subst, fbs_out) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + | rhs_ok r + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (subst', b') = set_nocaf_bndr subst b + new_fb = FloatLet (NonRec b' (subst_expr subst r)) + + go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) + | all rhs_ok rs + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (bs,rs) = unzip prs + (subst', bs') = mapAccumL set_nocaf_bndr subst bs + rs' = map (subst_expr subst') rs + new_fb = FloatLet (Rec (bs' `zip` rs')) + + go (subst, fbs_out) (ft@FloatTick{} : fbs_in) + = go (subst, fbs_out `snocOL` ft) fbs_in + + go _ _ = Nothing -- Encountered a caffy binding + + ------------ + set_nocaf_bndr subst bndr + = (extendIdSubst subst bndr (Var bndr'), bndr') + where + bndr' = bndr `setIdCafInfo` NoCafRefs + + ------------ + rhs_ok :: CoreExpr -> Bool + -- We can only float to top level from a NoCaf thing if + -- the new binding is static. However it can't mention + -- any non-static things or it would *already* be Caffy + rhs_ok = rhsIsStatic platform (\_ -> False) + (\i -> pprPanic "rhsIsStatic" (integer i)) + -- Integer literals should not show up + +wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool +wantFloatNested is_rec strict_or_unlifted floats rhs + = isEmptyFloats floats + || strict_or_unlifted + || (allLazyNested is_rec floats && exprIsHNF rhs) + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early + +allLazyTop :: Floats -> Bool +allLazyTop (Floats OkToSpec _) = True +allLazyTop _ = False + +allLazyNested :: RecFlag -> Floats -> Bool +allLazyNested _ (Floats OkToSpec _) = True +allLazyNested _ (Floats NotOkToSpec _) = False +allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec + +{- +************************************************************************ +* * + Cloning +* * +************************************************************************ +-} + +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +data CorePrepEnv = CPE { + cpe_dynFlags :: DynFlags, + cpe_env :: (IdEnv Id), -- Clone local Ids + cpe_mkIntegerId :: Id, + cpe_integerSDataCon :: Maybe DataCon + } + +lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id +lookupMkIntegerName dflags hsc_env + = guardIntegerUse dflags $ liftM tyThingId $ + initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + +lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) +lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of + IntegerGMP -> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) + IntegerGMP2-> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) + IntegerSimple -> return Nothing + +-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' +guardIntegerUse :: DynFlags -> IO a -> IO a +guardIntegerUse dflags act + | thisPackage dflags == primPackageKey + = return $ panic "Can't use Integer in ghc-prim" + | thisPackage dflags == integerPackageKey + = return $ panic "Can't use Integer in integer-*" + | otherwise = act + +mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv dflags hsc_env + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env + integerSDataCon <- lookupIntegerSDataConName dflags hsc_env + return $ CPE { + cpe_dynFlags = dflags, + cpe_env = emptyVarEnv, + cpe_mkIntegerId = mkIntegerId, + cpe_integerSDataCon = integerSDataCon + } + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv cpe id id' + = cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' } + +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList cpe prs + = cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs } + +lookupCorePrepEnv :: CorePrepEnv -> Id -> Id +lookupCorePrepEnv cpe id + = case lookupVarEnv (cpe_env cpe) id of + Nothing -> id + Just id' -> id' + +getMkIntegerId :: CorePrepEnv -> Id +getMkIntegerId = cpe_mkIntegerId + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs + +cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) +cpCloneBndr env bndr + | isLocalId bndr, not (isCoVar bndr) + = do bndr' <- setVarUnique bndr <$> getUniqueM + + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings + -- so that we can drop more stuff as dead code. + -- See also Note [Dead code in CorePrep] + let bndr'' = bndr' `setIdUnfolding` noUnfolding + `setIdSpecialisation` emptySpecInfo + return (extendCorePrepEnv env bndr bndr'', bndr'') + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + -- And we don't clone tyvars, or coercion variables + = return (env, bndr) + + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: Type -> UniqSM Id +newVar ty + = seqType ty `seq` do + uniq <- getUniqueM + return (mkSysLocal (fsLit "sat") uniq ty) + + +------------------------------------------------------------------------------ +-- Floating ticks +-- --------------------------------------------------------------------------- +-- +-- Note [Floating Ticks in CorePrep] +-- +-- It might seem counter-intuitive to float ticks by default, given +-- that we don't actually want to move them if we can help it. On the +-- other hand, nothing gets very far in CorePrep anyway, and we want +-- to preserve the order of let bindings and tick annotations in +-- relation to each other. For example, if we just wrapped let floats +-- when they pass through ticks, we might end up performing the +-- following transformation: +-- +-- src<...> let foo = bar in baz +-- ==> let foo = src<...> bar in src<...> baz +-- +-- Because the let-binding would float through the tick, and then +-- immediately materialize, achieving nothing but decreasing tick +-- accuracy. The only special case is the following scenario: +-- +-- let foo = src<...> (let a = b in bar) in baz +-- ==> let foo = src<...> bar; a = src<...> b in baz +-- +-- Here we would not want the source tick to end up covering "baz" and +-- therefore refrain from pushing ticks outside. Instead, we copy them +-- into the floating binds (here "a") in cpePair. Note that where "b" +-- or "bar" are (value) lambdas we have to push the annotations +-- further inside in order to uphold our rules. +-- +-- All of this is implemented below in @wrapTicks@. + +-- | Like wrapFloats, but only wraps tick floats +wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) +wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr') + where (floats1, expr') = foldrOL go (nilOL, expr) floats0 + go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam) + (mapOL (wrap t) fs, mkTick t e) + go other (fs, e) = (other `consOL` fs, e) + wrap t (FloatLet bind) = FloatLet (wrapBind t bind) + wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok + wrap _ other = pprPanic "wrapTicks: unexpected float!" + (ppr other) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs new file mode 100644 index 00000000..fa83f41a --- /dev/null +++ b/compiler/coreSyn/CoreSubst.hs @@ -0,0 +1,1527 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} +module CoreSubst ( + -- * Main data types + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, + + -- ** Substituting into expressions and related types + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substUnfolding, substUnfoldingSC, + lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, + substTickish, substVarSet, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkGblSubst, mkOpenSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, + extendCvSubst, extendCvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + isInScope, setInScope, + delBndr, delBndrs, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import Literal ( Literal(MachStr) ) +import qualified Data.ByteString as BS +import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) + +import qualified Type +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) + +import TyCon ( tyConArity ) +import DataCon +import PrelNames ( eqBoxDataConKey, coercibleDataConKey, unpackCStringIdKey + , unpackCStringUtf8IdKey ) +import OptCoercion ( optCoercion ) +import PprCore ( pprCoreBindings, pprRules ) +import Module ( Module ) +import VarSet +import VarEnv +import Id +import Name ( Name ) +import Var +import IdInfo +import Unique +import UniqSupply +import Maybes +import ErrUtils +import DynFlags +import BasicTypes ( isAlwaysActive ) +import Util +import Pair +import Outputable +import PprCore () -- Instances +import FastString + +import Data.List + +import TysWiredIn + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +-- | A substitution environment, containing both 'Id' and 'TyVar' substitutions. +-- +-- Some invariants apply to how you use the substitution: +-- +-- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/ +-- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the +-- substitution range that might possibly clash with locally-bound variables in the thing being substituted in. +-- +-- 2. #apply_once# You may apply the substitution only /once/ +-- +-- There are various ways of setting up the in-scope set such that the first of these invariants hold: +-- +-- * Arrange that the in-scope set really is all the things in scope +-- +-- * Arrange that it's the free vars of the range of the substitution +-- +-- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution for Ids + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See #in_scope_invariant# + -- This is what lets us deal with name capture properly + -- It's a hard invariant to check... + -- + -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with + -- Types.TvSubstEnv + -- + -- INVARIANT 3: See Note [Extending the Subst] + +{- +Note [Extending the Subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a core Subst, which binds Ids as well, we make a different choice for Ids +than we do for TyVars. + +For TyVars, see Note [Extending the TvSubst] with Type.TvSubstEnv + +For Ids, we have a different invariant + The IdSubstEnv is extended *only* when the Unique on an Id changes + Otherwise, we just extend the InScopeSet + +In consequence: + +* If the TvSubstEnv and IdSubstEnv are both empty, substExpr would be a + no-op, so substExprSC ("short cut") does nothing. + + However, substExpr still goes ahead and substitutes. Reason: we may + want to replace existing Ids with new ones from the in-scope set, to + avoid space leaks. + +* In substIdBndr, we extend the IdSubstEnv only when the unique changes + +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + +* In lookupIdSubst, we *must* look up the Id in the in-scope set, because + it may contain non-trivial changes. Example: + (/\a. \x:a. ...x...) Int + We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change + so we only extend the in-scope set. Then we must look up in the in-scope + set when we find the occurrence of x. + +* The requirement to look up the Id in the in-scope set means that we + must NOT take no-op short cut when the IdSubst is empty. + We must still look up every Id in the in-scope set. + +* (However, we don't need to do so for expressions found in the IdSubst + itself, whose range is assumed to be correct wrt the in-scope set.) + +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? + +* For Ids, we change the IdInfo all the time (e.g. deleting the + unfolding), and adding it back later, so using the TyVar convention + would entail extending the substitution almost all the time + +* The simplifier wants to look up in the in-scope set anyway, in case it + can see a better unfolding from an enclosing case expression + +* For TyVars, only coercion variables can possibly change, and they are + easy to spot + +Note [IdSubstEnv] +~~~~~~~~~~~~~~~~~ +An IdSubstEnv has a "local environment" of type (IdEnv CoreExpr); +this is extended when we meet a binder, in the usual way. But it also +has a "global environment" of type GblIdSubst. This global envt is +never modified during substitution. Rather: + + * The GblIdSubst is used when initialising the substitution via + mkGblSubst, to give an "ambient substitution" for the enclosing + context. + + * On lookup, we look first in the local envt and then in the global envt + (see lookupIdSubst) + + * The GblIdSubst is just a function; but since we need to delete things + from the substitution when passing a binder, we have to record a set + of Ids gis_del that must *not* be looked up in the gbl envt. + +All this is needed to support SimplEnv.substExpr, which starts off +with a SimplIdSubst, which provides the ambient subsitution. +-} + +-- | An environment for substituting for 'Id's +-- See Note [IdSubstEnv] +data IdSubstEnv = ISE { ise_env :: !(IdEnv CoreExpr) + , ise_gbl :: !GblIdSubst } + +data GblIdSubst = NoGIS + | GIS { gis_env :: !(InScopeSet -> Id -> Maybe CoreExpr) + , gis_del :: !IdSet } -- Deletions from gis_env + +instance Outputable IdSubstEnv where + ppr (ISE { ise_env = lcl, ise_gbl = gbl }) + = ppr gbl $$ ppr lcl + +instance Outputable GblIdSubst where + ppr NoGIS = empty + ppr (GIS { gis_del = dels }) = ptext (sLit "GIS") <+> ppr dels + +lookupGIS :: GblIdSubst -> InScopeSet -> Id -> Maybe CoreExpr +lookupGIS NoGIS _ _ = Nothing +lookupGIS (GIS { gis_env = gbl_fn, gis_del = dels }) in_scope v + | v `elemVarSet` dels = Nothing + | otherwise = gbl_fn in_scope v + +isEmptyIdSubst :: IdSubstEnv -> Bool +isEmptyIdSubst (ISE { ise_env = lcl, ise_gbl = NoGIS }) = isEmptyVarEnv lcl +isEmptyIdSubst _ = False + +emptyIdSubst :: IdSubstEnv +emptyIdSubst = ISE { ise_env = emptyVarEnv, ise_gbl = NoGIS } + +extendIdSubstEnv :: IdSubstEnv -> Id -> CoreExpr -> IdSubstEnv +extendIdSubstEnv ise v e = ise { ise_env = extendVarEnv (ise_env ise) v e } + +extendIdSubstEnvList :: IdSubstEnv -> [(Id,CoreExpr)] -> IdSubstEnv +extendIdSubstEnvList ise prs = ise { ise_env = extendVarEnvList (ise_env ise) prs } + +delIdSubst :: IdSubstEnv -> Id -> IdSubstEnv +delIdSubst (ISE { ise_env = lcl, ise_gbl = gbl }) v + = ISE { ise_env = delVarEnv lcl v, ise_gbl = delGIS gbl v } + +delIdSubstList :: IdSubstEnv -> [Id] -> IdSubstEnv +delIdSubstList (ISE { ise_env = lcl, ise_gbl = gbl }) vs + = ISE { ise_env = delVarEnvList lcl vs, ise_gbl = delGISList gbl vs } + +delGIS :: GblIdSubst -> Id -> GblIdSubst +delGIS NoGIS _ = NoGIS +delGIS (GIS { gis_env = gbl, gis_del = dels }) v + = GIS { gis_env = gbl, gis_del = if isJust (gbl emptyInScopeSet v) + then extendVarSet dels v + else dels } + +delGISList :: GblIdSubst -> [Id] -> GblIdSubst +delGISList NoGIS _ = NoGIS +delGISList (GIS { gis_env = gbl, gis_del = dels }) vs + = GIS { gis_env = gbl, gis_del = extendVarSetList dels del_vs } + where + del_vs = [ v | v <- vs, isJust (gbl emptyInScopeSet v)] + +---------------------------- +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyIdSubst id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyIdSubst emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyIdSubst emptyVarEnv emptyVarEnv + +mkGblSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv + -> (InScopeSet -> Id -> Maybe CoreExpr) + -> Subst +mkGblSubst in_scope tvs cvs lookup_id + = Subst in_scope id_subst tvs cvs + where + id_subst = ISE { ise_env = emptyVarEnv + , ise_gbl = GIS { gis_env = lookup_id, gis_del = emptyVarSet } } + +-- | Find the in-scope set: see "CoreSubst#in_scope_invariant" +substInScope :: Subst -> InScopeSet +substInScope (Subst in_scope _ _ _) = in_scope + +-- | Remove all substitutions for 'Id's and 'Var's that might have been built up +-- while preserving the in-scope set +zapSubstEnv :: Subst -> Subst +zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyIdSubst emptyVarEnv emptyVarEnv + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendIdSubst :: Subst -> Id -> CoreExpr -> Subst +-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set +extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendIdSubstEnv ids v r) tvs cvs + +-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendIdSubstEnvList ids prs) tvs cvs + +-- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the +-- 'Subst': see also 'extendCvSubst' +extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst +extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'. +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. +extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst +extendSubstList subst [] = subst +extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs + +-- | Find the substitution for an 'Id' in the 'Subst' +lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr +lookupIdSubst doc (Subst in_scope (ISE { ise_env = lcl, ise_gbl = gbl }) _ _) v + | not (isLocalId v) = Var v + | Just e <- lookupVarEnv lcl v = e + | Just e <- lookupGIS gbl in_scope v = e + | Just v' <- lookupInScope in_scope v = Var v' + -- Vital! See Note [Extending the Subst] + | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v + $$ ppr in_scope) + Var v + +-- | Find the substitution for a 'TyVar' in the 'Subst' +lookupTvSubst :: Subst -> TyVar -> Type +lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + +-- | Find the coercion substitution for a 'CoVar' in the 'Subst' +lookupCvSubst :: Subst -> CoVar -> Coercion +lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v + +delBndr :: Subst -> Var -> Subst +-- Doesn't work for gbl_ids +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delIdSubst ids v) tvs cvs + +delBndrs :: Subst -> [Var] -> Subst +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delIdSubstList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easiest thing is just delete all from all! + +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs + = Subst in_scope + (ISE { ise_env = mkVarEnv [(id,e) | (id, e) <- pairs, isId id], ise_gbl = NoGIS}) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) + +------------------------------ +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope + +-- | Add the 'Var' to the in-scope set, but do not remove +-- any existing substitutions for it +addInScopeSet :: Subst -> VarSet -> Subst +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs + +-- | Add the 'Var' to the in-scope set: as a side effect, +-- and remove any existing substitutions for it +extendInScope :: Subst -> Var -> Subst +extendInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delIdSubst` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendInScopeList :: Subst -> [Var] -> Subst +extendInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delIdSubstList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) + +-- | Optimized version of 'extendInScopeList' that can be used if you are certain +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delIdSubstList` vs) tvs cvs + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = ptext (sLit " braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) + $$ ptext (sLit " IdSubst =") <+> ppr ids + $$ ptext (sLit " TvSubst =") <+> ppr tvs + $$ ptext (sLit " CvSubst =") <+> ppr cvs + <> char '>' + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only +-- apply the substitution /once/: see "CoreSubst#apply_once" +-- +-- Do *not* attempt to short-cut in the case of an empty substitution! +-- See Note [Extending the Subst] +substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExprSC _doc subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ + subst_expr subst orig_expr + +substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExpr _doc subst orig_expr = subst_expr subst orig_expr + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr subst expr + = go expr + where + go (Var v) = lookupIdSubst (text "subst_expr") subst v + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (subst_expr subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (subst_expr subst' body) + where + (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + +-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' +-- that should be used by subsequent substitutions. +substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) + +substBindSC subst bind -- Short-cut if the substitution is empty + | not (isEmptySubst subst) + = substBind subst bind + | otherwise + = case bind of + NonRec bndr rhs -> (subst', NonRec bndr' rhs) + where + (subst', bndr') = substBndr subst bndr + Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' | isEmptySubst subst' = rhss + | otherwise = map (subst_expr subst') rhss + +substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (subst_expr subst') rhss + +-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply +-- by running over the bindings with an empty substitution, because substitution +-- returns a result that has no-shadowing guaranteed. +-- +-- (Actually, within a single /type/ there might still be shadowing, because +-- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here +deShadowBinds :: CoreProgram -> CoreProgram +deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) + +{- +************************************************************************ +* * + Substituting binders +* * +************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. +-} + +-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning +-- the result and an updated 'Subst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr + +-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right +substBndrs :: Subst -> [Var] -> (Subst, [Var]) +substBndrs subst bndrs = mapAccumL substBndr subst bndrs + +-- | Substitute in a mutually recursive group of 'Id's +substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs + +substIdBndr :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> Subst -> Id -- ^ Substitution and Id to transform + -> (Subst, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped + +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id + = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 | no_type_change = id1 + | otherwise = setIdType id1 (substTy subst old_ty) + + old_ty = idType old_id + no_type_change = isEmptyVarEnv tvs || + isEmptyVarSet (Type.tyVarsOfType old_ty) + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delIdSubst env old_id + | otherwise = extendIdSubstEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + +{- +Now a variant that unconditionally allocates a new unique. +It also unconditionally zaps the OccInfo. +-} + +-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for +-- each variable in its output. It substitutes the IdInfo though. +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final +-- substitution from left to right +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) + +cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) +cloneBndr subst uniq v + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids + = (subst', ids') + where + (subst', ids') = mapAccumL (clone_id subst') subst + (ids `zip` uniqsFromSupply us) + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitution and Id to transform + -> (Subst, Id) -- Transformed pair + +clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + where + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendIdSubstEnv idvs old_id (Var new_id), cvs) + +{- +************************************************************************ +* * + Types and Coercions +* * +************************************************************************ + +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TvSubst. +-} + +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv + = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + +substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') + +-- | See 'Type.substTy' +substTy :: Subst -> Type -> Type +substTy subst ty = Type.substTy (getTvSubst subst) ty + +getTvSubst :: Subst -> TvSubst +getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv + +getCvSubst :: Subst -> CvSubst +getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getCvSubst subst) co + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id + | otherwise = setIdType id (substTy subst old_ty) + -- The tyVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +------------------ +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo +substIdInfo subst new_id info + | nothing_to_do = Nothing + | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = specInfo info + old_unf = unfoldingInfo info + nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf + + +------------------ +-- | Substitutes for the 'Id's within an unfolding +substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely + +substUnfoldingSC subst unf -- Short-cut version + | isEmptySubst subst = unf + | otherwise = substUnfolding subst unf + +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } + where + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr (text "subst-unf:dfun") subst') args + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep a stable one! + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } + where + new_tmpl = substExpr (text "subst-unf") subst tmpl + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) + +------------------ +-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' +substSpec :: Subst -> Id -> SpecInfo -> SpecInfo +substSpec subst new_id (SpecInfo rules rhs_fvs) + = seqSpecInfo new_spec `seq` new_spec + where + subst_ru_fn = const (idName new_id) + new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) + (substVarSet subst rhs_fvs) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst not_needed) rules + where + not_needed name = pprPanic "substRulesForImportedIds" (ppr name) + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr doc subst') args + , ru_rhs = substExpr (text "foo") subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + where + doc = ptext (sLit "subst-rule") <+> ppr fn_name + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substVects :: Subst -> [CoreVect] -> [CoreVect] +substVects subst = map (substVect subst) + +------------------ +substVect :: Subst -> CoreVect -> CoreVect +substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) +substVect _subst vd@(NoVect _) = vd +substVect _subst vd@(VectType _ _ _) = vd +substVect _subst vd@(VectClass _) = vd +substVect _subst vd@(VectInst _) = vd + +------------------ +substVarSet :: Subst -> VarSet -> VarSet +substVarSet subst fvs + = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs + where + subst_fv subst fv + | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv) + | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) + +------------------ +substTickish :: Subst -> Tickish Id -> Tickish Id +substTickish subst (Breakpoint n ids) = Breakpoint n (map do_one ids) + where do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst +substTickish _subst other = other + +{- Note [Substitute lazily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions that substitute over IdInfo must be pretty lazy, becuause +they are knot-tied by substRecBndrs. + +One case in point was Trac #10627 in which a rule for a function 'f' +referred to 'f' (at a differnet type) on the RHS. But instead of just +substituting in the rhs of the rule, we were calling simpleOptExpr, which +looked at the idInfo for 'f'; result <>. + +In any case we don't need to optimise the RHS of rules, or unfoldings, +because the simplifier will do that. + + +Note [substTickish] +~~~~~~~~~~~~~~~~~~~~~~ +A Breakpoint contains a list of Ids. What happens if we ever want to +substitute an expression for one of these Ids? + +First, we ensure that we only ever substitute trivial expressions for +these Ids, by marking them as NoOccInfo in the occurrence analyser. +Then, when substituting for the Id, we unwrap any type applications +and abstractions to get back to an Id, with getIdFromTrivialExpr. + +Second, we have to ensure that we never try to substitute a literal +for an Id in a breakpoint. We ensure this by never storing an Id with +an unlifted type in a Breakpoint - see Coverage.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get sustituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurrence +analyser, so it's possible that the worker is not even in scope any more. + +In all all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. + + +************************************************************************ +* * + The Very Simple Optimiser +* * +************************************************************************ + +Note [Optimise coercion boxes agressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The simple expression optimiser needs to deal with Eq# boxes as follows: + 1. If the result of optimising the RHS of a non-recursive binding is an + Eq# box, that box is substituted rather than turned into a let, just as + if it were trivial. + let eqv = Eq# co in e ==> e[Eq# co/eqv] + + 2. If the result of optimising a case scrutinee is a Eq# box and the case + deconstructs it in a trivial way, we evaluate the case then and there. + case Eq# co of Eq# cov -> e ==> e[co/cov] + +We do this for two reasons: + + 1. Bindings/case scrutinisation of this form is often created by the + evidence-binding mechanism and we need them to be inlined to be able + desugar RULE LHSes that involve equalities (see e.g. T2291) + + 2. The test T4356 fails Lint because it creates a coercion between types + of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this + inlining agressively we can collapse away the intermediate coercion between + these two types and hence pass Lint again. (This is a sort of a hack.) + +In fact, our implementation uses slightly liberalised versions of the second rule +rule so that the optimisations are a bit more generally applicable. Precisely: + 2a. We reduce any situation where we can spot a case-of-known-constructor + +As a result, the only time we should get residual coercion boxes in the code is +when the type checker generates something like: + + \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...) + +However, the case of lambda-bound equality evidence is fairly rare, so these two +rules should suffice for solving the rule LHS problem for now. + +Annoyingly, we cannot use this modified rule 1a instead of 1: + + 1a. If we come across a let-bound constructor application with trivial arguments, + add an appropriate unfolding to the let binder. We spot constructor applications + by using exprIsConApp_maybe, so this would actually let rule 2a reduce more. + +The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a +we wouldn't simplify this expression at all: + + let eqv = Eq# co + in foo eqv (bar eqv) + +The rule LHS desugarer can't deal with Let at all, so we need to push that box into +the use sites. +-} + +simpleOptExpr :: CoreExpr -> CoreExpr +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Optimise coercion boxes agressively]. +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprWith :: Subst -> InExpr -> OutExpr +simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) + +---------------------- +simpleOptPgm :: DynFlags -> Module + -> CoreProgram -> [CoreRule] -> [CoreVect] + -> IO (CoreProgram, [CoreRule], [CoreVect]) +simpleOptPgm dflags this_mod binds rules vects + = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings occ_anald_binds $$ pprRules rules ); + + ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } + where + occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} + rules vects emptyVarEnv binds + (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds + + do_one (subst, binds') bind + = case simple_opt_bind subst bind of + (subst', Nothing) -> (subst', binds') + (subst', Just bind') -> (subst', bind':binds') + +---------------------- +type InVar = Var +type OutVar = Var +type InId = Id +type OutId = Id +type InExpr = CoreExpr +type OutExpr = CoreExpr + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +simple_opt_expr :: Subst -> InExpr -> OutExpr +simple_opt_expr subst expr + = go expr + where + in_scope_env = (substInScope subst, simpleUnfoldingFun) + + go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v + go (App e1 e2) = simple_app subst e1 [go e2] + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) + go (Lit lit) = Lit lit + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' + where + co' = optCoercion (getCvSubst subst) co + + go (Let bind body) = case simple_opt_bind subst bind of + (subst', Nothing) -> simple_opt_expr subst' body + (subst', Just bind) -> Let bind (simple_opt_expr subst' body) + + go lam@(Lam {}) = go_lam [] subst lam + go (Case e b ty as) + -- See Note [Optimise coercion boxes agressively] + | isDeadBinder b + , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs + where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst + (zipEqual "simpleOptExpr" bs es) + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt subst') as) + where + e' = go e + (subst', b') = subst_opt_bndr subst b + + ---------------------- + go_alt subst (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr subst' rhs) + where + (subst', bndrs') = subst_opt_bndrs subst bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam bs' subst (Lam b e) + = go_lam (b':bs') subst' e + where + (subst', b') = subst_opt_bndr subst b + go_lam bs' subst e + | Just etad_e <- tryEtaReduce bs e' = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr subst e + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr +simple_app subst (App e1 e2) as + = simple_app subst e1 (simple_opt_expr subst e2 : as) +simple_app subst (Lam b e) (a:as) + = case maybe_substitute subst b a of + Just ext_subst -> simple_app ext_subst e as + Nothing -> Let (NonRec b2 a) (simple_app subst' e as) + where + (subst', b') = subst_opt_bndr subst b + b2 = add_info subst' b b' +simple_app subst (Var v) as + | isCompulsoryUnfolding (idUnfolding v) + , isAlwaysActive (idInlineActivation v) + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app subst (unfoldingTemplate (idUnfolding v)) as +simple_app subst (Tick t e) as + -- Okay to do "(Tick t e) x ==> Tick t (e x)"? + | t `tickishScopesLike` SoftScope + = mkTick t $ simple_app subst e as +simple_app subst e as + = foldl App (simple_opt_expr subst e) as + +---------------------- +simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) +simple_opt_bind s b -- Can add trace stuff here + = simple_opt_bind' s b + +simple_opt_bind' subst (Rec prs) + = (subst'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + (subst', bndrs') = subst_opt_bndrs subst (map fst prs) + (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') + do_pr (subst, prs) ((b,r), b') + = case maybe_substitute subst b r2 of + Just subst' -> (subst', prs) + Nothing -> (subst, (b2,r2):prs) + where + b2 = add_info subst b b' + r2 = simple_opt_expr subst r + +simple_opt_bind' subst (NonRec b r) + = simple_opt_out_bind subst (b, simple_opt_expr subst r) + +---------------------- +simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind) +simple_opt_out_bind subst (b, r') + | Just ext_subst <- maybe_substitute subst b r' + = (ext_subst, Nothing) + | otherwise + = (subst', Just (NonRec b2 r')) + where + (subst', b') = subst_opt_bndr subst b + b2 = add_info subst' b b' + +---------------------- +maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst + -- (maybe_substitute subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +maybe_substitute subst b r + | Type ty <- r -- let a::* = TYPE ty in + = ASSERT( isTyVar b ) + Just (extendTvSubst subst b ty) + + | Coercion co <- r + = ASSERT( isCoVar b ) + Just (extendCvSubst subst b co) + + | isId b -- let x = e in + , not (isCoVar b) -- See Note [Do not inline CoVars unconditionally] + -- in SimplUtils + , safe_to_inline (idOccInfo b) + , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] + , not (isStableUnfolding (idUnfolding b)) + , not (isExportedId b) + , not (isUnLiftedType (idType b)) || exprOkForSpeculation r + = Just (extendIdSubst subst b r) + + | otherwise + = Nothing + where + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline IAmDead = True + safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial + safe_to_inline NoOccInfo = trivial + + trivial | exprIsTrivial r = True + | (Var fun, args) <- collectArgs r + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` eqBoxDataConKey || dc `hasKey` coercibleDataConKey + , all exprIsTrivial args = True -- See Note [Optimise coercion boxes agressively] + | otherwise = False + +---------------------- +subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) +subst_opt_bndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = subst_opt_id_bndr subst bndr + +subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; +-- it gets added back later by add_info +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id + = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) + where + id1 = uniqAway in_scope old_id + id2 = setIdType id1 (substTy subst (idType old_id)) + new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + new_in_scope = in_scope `extendInScopeSet` new_id + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst | new_id /= old_id + = extendIdSubstEnv id_subst old_id (Var new_id) + | otherwise + = delIdSubst id_subst old_id + +---------------------- +subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar]) +subst_opt_bndrs subst bndrs + = mapAccumL subst_opt_bndr subst bndrs + +---------------------- +add_info :: Subst -> InVar -> OutVar -> OutVar +add_info subst old_bndr new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = maybeModifyIdInfo mb_new_info new_bndr + where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) + +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in Desugar. + +However, we don't want to inline 'seq', which happens to also have a +compulsory unfolding, so we only do this unfolding only for things +that are always-active. See Note [User-defined RULES for seq] in MkId. + + +************************************************************************ +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains a ByteString, so +we must parse it back into a FastString to split off the first character. +That way we can treat unpackCString# and unpackCStringUtf8# in the same way. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is +-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, +-- where t1..tk are the *universally-qantified* type args of 'dc' +exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) + where + go :: Either InScopeSet Subst + -> CoreExpr -> ConCont + -> Maybe (DataCon, [Type], [CoreExpr]) + go subst (Tick t expr) cont + | not (tickishIsCode t) = go subst expr cont + go subst (Cast expr co1) (CC [] co2) + = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2)) + go subst (App fun arg) (CC args co) + = go subst fun (CC (subst_arg subst arg : args) co) + go subst (Lam var body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst var arg) body (CC args co) + go (Right sub) (Var v) cont + = go (Left (substInScope sub)) + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = dealWithCoercion co con args + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args) + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + = go (Left in_scope') rhs cont + + | (fun `hasKey` unpackCStringIdKey) + || (fun `hasKey` unpackCStringUtf8IdKey) + , [Lit (MachStr str)] <- args + = dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ = Nothing + + ---------------------------- + -- Operations on the (Either InScopeSet CoreSubst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = CoreSubst.substCo s co + + subst_arg (Left {}) e = e + subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> Coercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral _ str co + | BS.null str + = dealWithCoercion co nilDataCon [Type charTy] + +dealWithStringLiteral fun str co + = let strFS = mkFastStringByteString str + + char = mkConApp charDataCon [mkCharLit (headFS strFS)] + charTail = fastStringToByteString (tailFS strFS) + + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (MachStr charTail)) + + in dealWithCoercion co consDataCon [Type charTy, char, rest] + +dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] + -> Maybe (DataCon, [Type], [CoreExpr]) +dealWithCoercion co dc dc_args + | isReflCo co + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, stripTypeArgs univ_ty_args, rest_args) + + | Pair _from_ty to_ty <- coercionKind co + , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + = -- Here we do the KPush reduction rule as described in the FC paper + -- The transformation applies iff we have + -- (C e1 ... en) `cast` co + -- where co :: (T t1 .. tn) ~ to_ty + -- The left-hand one must be a T, because exprIsConApp returned True + -- but the right-hand one might not be. (Though it usually will.) + let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + theta_subst = liftCoSubstWith Representational + (dc_univ_tyvars ++ dc_ex_tyvars) + -- existentials are at role N + (gammas ++ map (mkReflCo Nominal) + (stripTypeArgs ex_args)) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty) + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ] + in + ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) + , dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) + + | otherwise + = Nothing + +stripTypeArgs :: [CoreExpr] -> [Type] +stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) + [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! + +{- +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (inclding +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(_, id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v | Just rhs <- expandUnfolding_maybe (id_unf v) + -> exprIsLiteral_maybe env rhs + _ -> Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[Tickish Id]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe (in_scope_set, id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > length (filter isValArg as) + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) +pushCoercionIntoLambda in_scope x e co + -- This implements the Push rule from the paper on coercions + -- Compare with simplCast in Simplify + | ASSERT(not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just (_s1,_s2) <- splitFunTy_maybe s1s2 + , Just (t1,_t2) <- splitFunTy_maybe t1t2 + = let [co1, co2] = decomposeCo 2 co + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') co1) + in Just (x', subst_expr subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs new file mode 100644 index 00000000..ca0fdd1f --- /dev/null +++ b/compiler/coreSyn/CoreSyn.hs @@ -0,0 +1,1718 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} + +-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module CoreSyn ( + -- * Main data types + Expr(..), Alt, Bind(..), AltCon(..), Arg, + Tickish(..), TickishScoping(..), TickishPlacement(..), + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + + -- ** 'Expr' construction + mkLets, mkLams, + mkApps, mkTyApps, mkCoApps, mkVarApps, + + mkIntLit, mkIntLitInt, + mkWordLit, mkWordLitWord, + mkWord64LitWord64, mkInt64LitInt64, + mkCharLit, mkStringLit, + mkFloatLit, mkFloatLitFloat, + mkDoubleLit, mkDoubleLitDouble, + + mkConApp, mkConApp2, mkTyBind, mkCoBind, + varToCoreExpr, varsToCoreExprs, + + isId, cmpAltCon, cmpAlt, ltAlt, + + -- ** Simple 'Expr' access functions and predicates + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, collectArgsTicks, flattenBinds, + + isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + + tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, + tickishCanSplit, mkNoCount, mkNoScope, + tickishIsCode, tickishPlace, + tickishContains, + + -- * Unfolding data types + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + unfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, hasStableCoreUnfolding_maybe, + isClosedUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + + -- * Strictness + seqExpr, seqExprs, seqUnfolding, + + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + + -- ** Operations on annotated expressions + collectAnnArgs, collectAnnArgsTicks, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, + + -- * Core rule data types + CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, + + -- ** Operations on 'CoreRule's + seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, + isBuiltinRule, isLocalRule, isAutoRule, + + -- * Core vectorisation declarations data type + CoreVect(..) + ) where + +#include "HsVersions.h" + +import CostCentre +import VarEnv( InScopeSet ) +import Var +import Type +import Coercion +import Name +import Literal +import DataCon +import Module +import TyCon +import BasicTypes +import DynFlags +import FastString +import Outputable +import Util +import SrcLoc ( RealSrcSpan, containsSpan ) + +import Data.Data hiding (TyCon) +import Data.Int +import Data.Word + +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` +-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) + +{- +************************************************************************ +* * +\subsection{The main data types} +* * +************************************************************************ + +These data types are the heart of the compiler +-} + +-- | This is the data type that represents GHCs core intermediate language. Currently +-- GHC uses System FC for this purpose, +-- which is closely related to the simpler and better known System F . +-- +-- We get from Haskell source to this Core language in a number of stages: +-- +-- 1. The source code is parsed into an abstract syntax tree, which is represented +-- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' +-- +-- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' +-- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. +-- For example, this program: +-- +-- @ +-- f x = let f x = x + 1 +-- in f (x - 2) +-- @ +-- +-- Would be renamed by having 'Unique's attached so it looked something like this: +-- +-- @ +-- f_1 x_2 = let f_3 x_4 = x_4 + 1 +-- in f_3 (x_2 - 2) +-- @ +-- But see Note [Shadowing] below. +-- +-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating +-- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. +-- +-- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into +-- this 'Expr' type, which has far fewer constructors and hence is easier to perform +-- optimization, analysis and code generation on. +-- +-- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- +-- See "CoreSyn#let_app_invariant" for another invariant +-- +-- * Lambda abstraction +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- #top_level_invariant# +-- #letrec_invariant# +-- +-- The right hand sides of all top-level and recursive @let@s +-- /must/ be of lifted type (see "Type#type_classification" for +-- the meaning of /lifted/ vs. /unlifted/). +-- +-- See Note [CoreSyn let/app invariant] +-- +-- #type_let# +-- We allow a /non-recursive/ let to bind a type variable, thus: +-- +-- > Let (NonRec tv (Type ty)) body +-- +-- This can be very convenient for postponing type substitutions until +-- the next run of the simplifier. +-- +-- At the moment, the rest of the compiler only deals with type-let +-- in a Let expression, rather than at top level. We may want to revist +-- this choice. +-- +-- * Case split. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- #case_invariants# +-- This is one of the more complicated elements of the Core language, +-- and comes with a number of restrictions: +-- +-- 1. The list of alternatives may be empty; +-- See Note [Empty case alternatives] +-- +-- 2. The 'DEFAULT' case alternative must be first in the list, +-- if it occurs at all. +-- +-- 3. The remaining cases are in order of increasing +-- tag (for 'DataAlts') or +-- lit (for 'LitAlts'). +-- This makes finding the relevant constructor easy, +-- and makes comparison easier too. +-- +-- 4. The list of alternatives must be exhaustive. An /exhaustive/ case +-- does not necessarily mention all constructors: +-- +-- @ +-- data Foo = Red | Green | Blue +-- ... case x of +-- Red -> True +-- other -> f (case x of +-- Green -> ... +-- Blue -> ... ) ... +-- @ +-- +-- The inner case does not need a @Red@ alternative, because @x@ +-- can't be @Red@ at that program point. +-- +-- 5. Floating-point values must not be scrutinised against literals. +-- See Trac #9238 and Note [Rules for floating-point comparisons] +-- in PrelRules for rationale. +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Notes. These allow general information to be added to expressions +-- in the syntax tree +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Expr b + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] -- See #case_invariant# + | Cast (Expr b) Coercion + | Tick (Tickish Id) (Expr b) + | Type Type + | Coercion Coercion + deriving (Data, Typeable) + +-- | Type synonym for expressions that occur in function argument positions. +-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not +type Arg b = Expr b + +-- | A case split alternative. Consists of the constructor leading to the alternative, +-- the variables bound from the constructor, and the expression to be executed given that binding. +-- The default alternative is @(DEFAULT, [], rhs)@ + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +type Alt b = (AltCon, [b], Expr b) + +-- | A case alternative constructor (i.e. pattern match) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data AltCon + = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. + -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + + | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ + -- Invariant: always an *unlifted* literal + -- See Note [Literal alternatives] + + | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ + deriving (Eq, Ord, Data, Typeable) + +-- | Binding, used for top level bindings in a module and local bindings in a @let@. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + deriving (Data, Typeable) + +{- +Note [Shadowing] +~~~~~~~~~~~~~~~~ +While various passes attempt to rename on-the-fly in a manner that +avoids "shadowing" (thereby simplifying downstream optimizations), +neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +In particular, scrutinee variables `x` in expressions of the form +`Case e x t` are often renamed to variables with a prefix +"wild_". These "wild" variables may appear in the body of the +case-expression, and further, may be shadowed within the body. + +So the Unique in an Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +Note [Literal alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal alternatives (LitAlt lit) are always for *un-lifted* literals. +We have one literal, a literal Integer, that is lifted, and we don't +allow in a LitAlt, because LitAlt cases don't do any evaluation. Also +(see Trac #5603) if you say + case 3 of + S# x -> ... + J# _ _ -> ... +(where S#, J# are the constructors for Integer) we don't want the +simplifier calling findAlt with argument (LitAlt 3). No no. Integer +literals are an opaque encoding of an algebraic data type, not of +an unlifted literal, like all the others. + +Also, we do not permit case analysis with literal patterns on floating-point +types. See Trac #9238 and Note [Rules for floating-point comparisons] in +PrelRules for the rationale for this restriction. + +-------------------------- CoreSyn INVARIANTS --------------------------- + +Note [CoreSyn top-level invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #toplevel_invariant# + +Note [CoreSyn letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #letrec_invariant# + +Note [CoreSyn let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let/app invariant + the right hand side of of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'CoreUtils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp + +Note [CoreSyn case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #case_invariants# + +Note [CoreSyn let goal] +~~~~~~~~~~~~~~~~~~~~~~~ +* The simplifier tries to ensure that if the RHS of a let is a constructor + application, its arguments are trivial, so that the constructor can be + inlined vigorously. + +Note [Type let] +~~~~~~~~~~~~~~~ +See #type_let# + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. A case expression +can have empty alternatives if (and only if) the scrutinee is bound to raise +an exception or diverge. So: + Case (error Int "Hello") b Bool [] +is fine, and has type Bool. This is one reason we need a type on +the case expression: if the alternatives are empty we can't get the type +from the alternatives! I'll write this + case (error Int "Hello") of Bool {} +with the return type just before the alternatives. + +Here's another example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} +Since T has no data constructors, the case alternatives are of course +empty. However note that 'x' is not bound to a visibly-bottom value; +it's the *type* that tells us it's going to diverge. Its a bit of a +degnerate situation but we do NOT want to replace + case x of Bool {} --> error Bool "Inaccessible case" +because x might raise an exception, and *that*'s what we want to see! +(Trac #6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just a case, so we are back to square 1. Or I suppose +we could say + x |> UnsafeCoerce T Bool +but that loses all trace of the fact that this originated with an empty +set of alternatives. + +We can use the empty-alternative construct to coerce error values from +one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + +Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } +and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + +This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), +if for no other reason that we don't need to instantiate the (~) at an +unboxed type. + + +************************************************************************ +* * + Ticks +* * +************************************************************************ +-} + +-- | Allows attaching extra information to points in expressions + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Tickish id = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. + ProfNote { + profNoteCC :: CostCentre, -- ^ the cost centre + profNoteCount :: !Bool, -- ^ bump the entry count? + profNoteScope :: !Bool -- ^ scopes over the enclosed expression + -- (i.e. not just a tick) + } + + -- | A "tick" used by HPC to track the execution of each + -- subexpression in the original source code. + | HpcTick { + tickModule :: Module, + tickId :: !Int + } + + -- | A breakpoint for the GHCi debugger. This behaves like an HPC + -- tick, but has a list of free variables which will be available + -- for inspection in GHCi when the program stops at the breakpoint. + -- + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint + { breakpointId :: !Int + , breakpointFVs :: [id] -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in HscTypes.ModBreaks. + -- + -- Careful about substitution! See + -- Note [substTickish] in CoreSubst. + } + + -- | A source note. + -- + -- Source notes are pure annotations: Their presence should neither + -- influence compilation nor execution. The semantics are given by + -- causality: The presence of a source note means that a local + -- change in the referenced source code span will possibly provoke + -- the generated code to change. On the flip-side, the functionality + -- of annotated code *must* be invariant against changes to all + -- source code *except* the spans referenced in the source notes + -- (see "Causality of optimized Haskell" paper for details). + -- + -- Therefore extending the scope of any given source note is always + -- valid. Note that it is still undesirable though, as this reduces + -- their usefulness for debugging and profiling. Therefore we will + -- generally try only to make use of this property where it is + -- neccessary to enable optimizations. + | SourceNote + { sourceSpan :: RealSrcSpan -- ^ Source covered + , sourceName :: String -- ^ Name for source location + -- (uses same names as CCs) + } + + deriving (Eq, Ord, Data, Typeable) + +-- | A "counting tick" (where tickishCounts is True) is one that +-- counts evaluations in some way. We cannot discard a counting tick, +-- and the compiler should preserve the number of counting ticks as +-- far as possible. +-- +-- However, we still allow the simplifier to increase or decrease +-- sharing, so in practice the actual number of ticks may vary, except +-- that we never change the value from zero to non-zero or vice versa. +tickishCounts :: Tickish id -> Bool +tickishCounts n@ProfNote{} = profNoteCount n +tickishCounts HpcTick{} = True +tickishCounts Breakpoint{} = True +tickishCounts _ = False + + +-- | Specifies the scoping behaviour of ticks. This governs the +-- behaviour of ticks that care about the covered code and the cost +-- associated with it. Important for ticks relating to profiling. +data TickishScoping = + -- | No scoping: The tick does not care about what code it + -- covers. Transformations can freely move code inside as well as + -- outside without any additional annotation obligations + NoScope + + -- | Soft scoping: We want all code that is covered to stay + -- covered. Note that this scope type does not forbid + -- transformations from happening, as as long as all results of + -- the transformations are still covered by this tick or a copy of + -- it. For example + -- + -- let x = tick<...> (let y = foo in bar) in baz + -- ===> + -- let x = tick<...> bar; y = tick<...> foo in baz + -- + -- Is a valid transformation as far as "bar" and "foo" is + -- concerned, because both still are scoped over by the tick. + -- + -- Note though that one might object to the "let" not being + -- covered by the tick any more. However, we are generally lax + -- with this - constant costs don't matter too much, and given + -- that the "let" was effectively merged we can view it as having + -- lost its identity anyway. + -- + -- Also note that this scoping behaviour allows floating a tick + -- "upwards" in pretty much any situation. For example: + -- + -- case foo of x -> tick<...> bar + -- ==> + -- tick<...> case foo of x -> bar + -- + -- While this is always leagl, we want to make a best effort to + -- only make us of this where it exposes transformation + -- opportunities. + | SoftScope + + -- | Cost centre scoping: We don't want any costs to move to other + -- cost-centre stacks. This means we not only want no code or cost + -- to get moved out of their cost centres, but we also object to + -- code getting associated with new cost-centre ticks - or + -- changing the order in which they get applied. + -- + -- A rule of thumb is that we don't want any code to gain new + -- annotations. However, there are notable exceptions, for + -- example: + -- + -- let f = \y -> foo in tick<...> ... (f x) ... + -- ==> + -- tick<...> ... foo[x/y] ... + -- + -- In-lining lambdas like this is always legal, because inlining a + -- function does not change the cost-centre stack when the + -- function is called. + | CostCentreScope + + deriving (Eq) + +-- | Returns the intended scoping rule for a Tickish +tickishScoped :: Tickish id -> TickishScoping +tickishScoped n@ProfNote{} + | profNoteScope n = CostCentreScope + | otherwise = NoScope +tickishScoped HpcTick{} = NoScope +tickishScoped Breakpoint{} = CostCentreScope + -- Breakpoints are scoped: eventually we're going to do call + -- stacks, but also this helps prevent the simplifier from moving + -- breakpoints around and changing their result type (see #1531). +tickishScoped SourceNote{} = SoftScope + +-- | Returns whether the tick scoping rule is at least as permissive +-- as the given scoping rule. +tickishScopesLike :: Tickish id -> TickishScoping -> Bool +tickishScopesLike t scope = tickishScoped t `like` scope + where NoScope `like` _ = True + _ `like` NoScope = False + SoftScope `like` _ = True + _ `like` SoftScope = False + CostCentreScope `like` _ = True + +-- | Returns @True@ for ticks that can be floated upwards easily even +-- where it might change execution counts, such as: +-- +-- Just (tick<...> foo) +-- ==> +-- tick<...> (Just foo) +-- +-- This is a combination of @tickishSoftScope@ and +-- @tickishCounts@. Note that in principle splittable ticks can become +-- floatable using @mkNoTick@ -- even though there's currently no +-- tickish for which that is the case. +tickishFloatable :: Tickish id -> Bool +tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) + +-- | Returns @True@ for a tick that is both counting /and/ scoping and +-- can be split into its (tick, scope) parts using 'mkNoScope' and +-- 'mkNoTick' respectively. +tickishCanSplit :: Tickish id -> Bool +tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} + = True +tickishCanSplit _ = False + +mkNoCount :: Tickish id -> Tickish id +mkNoCount n | not (tickishCounts n) = n + | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" +mkNoCount n@ProfNote{} = n {profNoteCount = False} +mkNoCount _ = panic "mkNoCount: Undefined split!" + +mkNoScope :: Tickish id -> Tickish id +mkNoScope n | tickishScoped n == NoScope = n + | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" +mkNoScope n@ProfNote{} = n {profNoteScope = False} +mkNoScope _ = panic "mkNoScope: Undefined split!" + +-- | Return @True@ if this source annotation compiles to some backend +-- code. Without this flag, the tickish is seen as a simple annotation +-- that does not have any associated evaluation code. +-- +-- What this means that we are allowed to disregard the tick if doing +-- so means that we can skip generating any code in the first place. A +-- typical example is top-level bindings: +-- +-- foo = tick<...> \y -> ... +-- ==> +-- foo = \y -> tick<...> ... +-- +-- Here there is just no operational difference between the first and +-- the second version. Therefore code generation should simply +-- translate the code as if it found the latter. +tickishIsCode :: Tickish id -> Bool +tickishIsCode SourceNote{} = False +tickishIsCode _tickish = True -- all the rest for now + + +-- | Governs the kind of expression that the tick gets placed on when +-- annotating for example using @mkTick@. If we find that we want to +-- put a tickish on an expression ruled out here, we try to float it +-- inwards until we find a suitable expression. +data TickishPlacement = + + -- | Place ticks exactly on run-time expressions. We can still + -- move the tick through pure compile-time constructs such as + -- other ticks, casts or type lambdas. This is the most + -- restrictive placement rule for ticks, as all tickishs have in + -- common that they want to track runtime processes. The only + -- legal placement rule for counting ticks. + PlaceRuntime + + -- | As @PlaceRuntime@, but we float the tick through all + -- lambdas. This makes sense where there is little difference + -- between annotating the lambda and annotating the lambda's code. + | PlaceNonLam + + -- | In addition to floating through lambdas, cost-centre style + -- tickishs can also be moved from constructors, non-function + -- variables and literals. For example: + -- + -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... + -- + -- Neither the constructor application, the variable or the + -- literal are likely to have any cost worth mentioning. And even + -- if y names a thunk, the call would not care about the + -- evaluation context. Therefore removing all annotations in the + -- above example is safe. + | PlaceCostCentre + + deriving (Eq) + +-- | Placement behaviour we want for the ticks +tickishPlace :: Tickish id -> TickishPlacement +tickishPlace n@ProfNote{} + | profNoteCount n = PlaceRuntime + | otherwise = PlaceCostCentre +tickishPlace HpcTick{} = PlaceRuntime +tickishPlace Breakpoint{} = PlaceRuntime +tickishPlace SourceNote{} = PlaceNonLam + +-- | Returns whether one tick "contains" the other one, therefore +-- making the second tick redundant. +tickishContains :: Eq b => Tickish b -> Tickish b -> Bool +tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) + = n1 == n2 && containsSpan sp1 sp2 +tickishContains t1 t2 + = t1 == t2 + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ + +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. +-} + +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- @False@ <=> generated at the users behest + -- Main effect: reporting of orphan-hood + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor) + + -- NB: ru_local is *not* used to decide orphan-hood + -- c.g. MkIface.coreRuleToIfaceRule + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in rule matching] in Rules.lhs + +type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local + +-- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } + +{- +************************************************************************ +* * +\subsection{Vectorisation declarations} +* * +************************************************************************ + +Representation of desugared vectorisation declarations that are fed to the vectoriser (via +'ModGuts'). +-} + +data CoreVect = Vect Id CoreExpr + | NoVect Id + | VectType Bool TyCon (Maybe TyCon) + | VectClass TyCon -- class tycon + | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now + +{- +************************************************************************ +* * + Unfoldings +* * +************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "CoreUnfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +------------------------------------------------ +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + + InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- + -- See Note [InlineRules] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see MkId.lhs, calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + deriving (Eq) + +{- +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_work_free = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () + +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource InlineRhs = False + +-- | Retrieves the template of an unfolding: panics if none is known +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate = uf_tmpl + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in Rules.lhs +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing + +hasStableCoreUnfolding_maybe :: Unfolding -> Maybe Bool +-- Just True <=> has stable inlining, very keen to inline (eg. INLINE pragma) +-- Just False <=> has stable inlining, open to inlining it (eg. INLINEABLE pragma) +-- Nothing <=> not stable, or cannot inline it anyway +hasStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isStableSource src + = case guide of + UnfWhen {} -> Just True + UnfIfGoodArgs {} -> Just False + UnfNever -> Nothing +hasStableCoreUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +isClosedUnfolding :: Unfolding -> Bool -- No free variables +isClosedUnfolding (CoreUnfolding {}) = False +isClosedUnfolding (DFunUnfolding {}) = False +isClosedUnfolding _ = True + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding _ = True + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +{- +Note [InlineRules] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. + +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in CoreUnfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurrence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simpifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + + +************************************************************************ +* * + AltCon +* * +************************************************************************ +-} + +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = ptext (sLit "__DEFAULT") + +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering +cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 + +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- ^ Compares 'AltCon's within a single list of alternatives +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT _ = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> + ppr con1 <+> ppr con2 ) + LT + +{- +************************************************************************ +* * +\subsection{Useful synonyms} +* * +************************************************************************ + +Note [CoreProgram] +~~~~~~~~~~~~~~~~~~ +The top level bindings of a program, a CoreProgram, are represented as +a list of CoreBind + + * Later bindings in the list can refer to earlier ones, but not vice + versa. So this is OK + NonRec { x = 4 } + Rec { p = ...q...x... + ; q = ...p...x } + Rec { f = ...p..x..f.. } + NonRec { g = ..f..q...x.. } + But it would NOT be ok for 'f' to refer to 'g'. + + * The occurrence analyser does strongly-connected component analysis + on each Rec binding, and splits it into a sequence of smaller + bindings where possible. So the program typically starts life as a + single giant Rec, which is then dependency-analysed into smaller + chunks. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +type CoreProgram = [CoreBind] -- See Note [CoreProgram] + +-- | The common case for the type of binders and variables when +-- we are manipulating the Core language within GHC +type CoreBndr = Var +-- | Expressions where binders are 'CoreBndr's +type CoreExpr = Expr CoreBndr +-- | Argument expressions where binders are 'CoreBndr's +type CoreArg = Arg CoreBndr +-- | Binding groups where binders are 'CoreBndr's +type CoreBind = Bind CoreBndr +-- | Case alternatives where binders are 'CoreBndr's +type CoreAlt = Alt CoreBndr + +{- +************************************************************************ +* * +\subsection{Tagging} +* * +************************************************************************ +-} + +-- | Binders are /tagged/ with a t +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" + +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + +deTagExpr :: TaggedExpr t -> CoreExpr +deTagExpr (Var v) = Var v +deTagExpr (Lit l) = Lit l +deTagExpr (Type ty) = Type ty +deTagExpr (Coercion co) = Coercion co +deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) +deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) +deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) +deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) +deTagExpr (Tick t e) = Tick t (deTagExpr e) +deTagExpr (Cast e co) = Cast (deTagExpr e) co + +deTagBind :: TaggedBind t -> CoreBind +deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) +deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] + +deTagAlt :: TaggedAlt t -> CoreAlt +deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) + +{- +************************************************************************ +* * +\subsection{Core-constructing functions with checking} +* * +************************************************************************ +-} + +-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to +-- use 'MkCore.mkCoreApps' if possible +mkApps :: Expr b -> [Arg b] -> Expr b +-- | Apply a list of type argument expressions to a function expression in a nested fashion +mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b +-- | Apply a list of type or value variables to a function expression in a nested fashion +mkVarApps :: Expr b -> [Var] -> Expr b +-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to +-- use 'MkCore.mkCoreConApps' if possible +mkConApp :: DataCon -> [Arg b] -> Expr b + +mkApps f args = foldl App f args +mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args +mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b +mkConApp2 con tys arg_ids = Var (dataConWorkId con) + `mkApps` map Type tys + `mkApps` map varToCoreExpr arg_ids + + +-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLit :: DynFlags -> Integer -> Expr b +-- | Create a machine integer literal expression of type @Int#@ from an @Int@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLitInt :: DynFlags -> Int -> Expr b + +mkIntLit dflags n = Lit (mkMachInt dflags n) +mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) + +-- | Create a machine word literal expression of type @Word#@ from an @Integer@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLit :: DynFlags -> Integer -> Expr b +-- | Create a machine word literal expression of type @Word#@ from a @Word@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLitWord :: DynFlags -> Word -> Expr b + +mkWordLit dflags w = Lit (mkMachWord dflags w) +mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) + +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) + +-- | Create a machine character literal expression of type @Char#@. +-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' +mkCharLit :: Char -> Expr b +-- | Create a machine string literal expression of type @Addr#@. +-- If you want an expression of type @String@ use 'MkCore.mkStringExpr' +mkStringLit :: String -> Expr b + +mkCharLit c = Lit (mkMachChar c) +mkStringLit s = Lit (mkMachString s) + +-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLit :: Rational -> Expr b +-- | Create a machine single precision literal expression of type @Float#@ from a @Float@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLitFloat :: Float -> Expr b + +mkFloatLit f = Lit (mkMachFloat f) +mkFloatLitFloat f = Lit (mkMachFloat (toRational f)) + +-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLit :: Rational -> Expr b +-- | Create a machine double precision literal expression of type @Double#@ from a @Double@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLitDouble :: Double -> Expr b + +mkDoubleLit d = Lit (mkMachDouble d) +mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) + +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant +mkLets :: [Bind b] -> Expr b -> Expr b +-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to +-- use 'MkCore.mkCoreLams' if possible +mkLams :: [b] -> Expr b -> Expr b + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr Let body binds + + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + +-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v + +varsToCoreExprs :: [CoreBndr] -> [Expr b] +varsToCoreExprs vs = map varToCoreExpr vs + +{- +************************************************************************ +* * +\subsection{Simple access functions} +* * +************************************************************************ +-} + +-- | Extract every variable by this group +bindersOf :: Bind b -> [b] +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +-- | 'bindersOf' applied to a list of binding groups +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] + +-- | Collapse all the bindings in the supplied groups into a single +-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group +flattenBinds :: [Bind b] -> [(b, Expr b)] +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] + +-- | We often want to strip off leading lambdas before getting down to +-- business. This function is your friend. +collectBinders :: Expr b -> ([b], Expr b) +-- | Collect as many type bindings as possible from the front of a nested lambda +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +-- | Collect as many value bindings as possible from the front of a nested lambda +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +-- | Collect type binders from the front of the lambda first, +-- then follow up by collecting as many value bindings as possible +-- from the resulting stripped expression +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) + +-- | Takes a nested application expression and returns the the function +-- being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go e as = (e, as) + +-- | Like @collectArgs@, but also collects looks through floatable +-- ticks if it means that we can find more arguments. +collectArgsTicks :: (Tickish Id -> Bool) -> Expr b + -> (Expr b, [Arg b], [Tickish Id]) +collectArgsTicks skipTick expr + = go expr [] [] + where + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts + | skipTick t = go e as (t:ts) + go e as ts = (e, as, reverse ts) + + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ + +At one time we optionally carried type arguments through to runtime. +@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, +i.e. if type applications are actual lambdas because types are kept around +at runtime. Similarly isRuntimeArg. +-} + +-- | Will this variable exist at runtime? +isRuntimeVar :: Var -> Bool +isRuntimeVar = isId + +-- | Will this argument expression exist at runtime? +isRuntimeArg :: CoreExpr -> Bool +isRuntimeArg = isValArg + +-- | Returns @True@ for value arguments, false for type args +-- NB: coercions are value arguments (zero width, to be sure, +-- like State#, but still value args). +isValArg :: Expr b -> Bool +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. +isTypeArg :: Expr b -> Bool +isTypeArg (Type {}) = True +isTypeArg _ = False + +-- | The number of binders that bind values rather than types +valBndrCount :: [CoreBndr] -> Int +valBndrCount = count isId + +-- | The number of argument expressions that are values rather than types at their top level +valArgCount :: [Arg b] -> Int +valArgCount = count isValArg + +{- +************************************************************************ +* * +\subsection{Seq stuff} +* * +************************************************************************ +-} + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: Tickish Id -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b = b `seq` () + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +{- +************************************************************************ +* * +\subsection{Annotated core} +* * +************************************************************************ +-} + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick (Tickish Id) (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) +collectAnnArgsTicks tickishOk expr + = go expr [] [] + where + go (_, AnnApp f a) as ts = go f (a:as) ts + go (_, AnnTick t e) as ts | tickishOk t + = go e as (t:ts) + go e as ts = (e, as, reverse ts) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) + where + deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) + deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs new file mode 100644 index 00000000..7f09c68c --- /dev/null +++ b/compiler/coreSyn/CoreTidy.hs @@ -0,0 +1,272 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in TidyPgm. +-} + +{-# LANGUAGE CPP #-} +module CoreTidy ( + tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreArity +import Id +import IdInfo +import Type( tidyType, tidyTyVarBndr ) +import Coercion( tidyCo ) +import Var +import VarEnv +import UniqFM +import Name hiding (tidyNameOcc) +import SrcLoc +import Maybes +import Data.List + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (env', bndrs') = mapAccumL (tidyLetBndr env') env prs + in + map (tidyExpr env') (map snd prs) =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt b env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: CoreBndr -> TidyEnv -> CoreAlt -> CoreAlt +tidyAlt _case_bndr env (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM var_env n of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyVar var = tidyTyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf | isEvaldUnfolding old_unf = evaldUnfolding + | otherwise = noUnfolding + -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> (Id, CoreExpr) -> (TidyEnv, Var) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- + -- Similarly arity info for eta expansion in CorePrep + -- + -- Set inline-prag info so that we preseve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` exprArity rhs + `setStrictnessInfo` strictnessInfo old_info + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = noUnfolding + old_unf = unfoldingInfo old_info + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + unf_from_rhs + | isStableSource src + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + | otherwise + = unf_from_rhs +tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs new file mode 100644 index 00000000..2e21ba9e --- /dev/null +++ b/compiler/coreSyn/CoreUnfold.hs @@ -0,0 +1,1369 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Core-syntax unfoldings + +Unfoldings (which can travel across module boundaries) are in Core +syntax (namely @CoreExpr@s). + +The type @Unfolding@ sits ``above'' simply-Core-expressions +unfoldings, capturing ``higher-level'' things we know about a binding, +usually things that the simplifier found out (e.g., ``it's a +literal''). In the corner of a @CoreUnfolding@ unfolding, you will +find, unsurprisingly, a Core expression. +-} + +{-# LANGUAGE CPP #-} + +module CoreUnfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + noUnfolding, mkImplicitUnfolding, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, + specUnfolding, + + ArgSummary(..), + + couldBeSmallEnoughToInline, inlineBoringOk, + certainlyWillInline, smallEnoughToInline, + + callSiteInline, CallCtxt(..), + + -- Reexport from CoreSubst (it only live there so it can be used + -- by the Very Simple Optimiser) + exprIsConApp_maybe, exprIsLiteral_maybe + ) where + +#include "HsVersions.h" + +import DynFlags +import CoreSyn +import PprCore () -- Instances +import OccurAnal ( occurAnalyseExpr ) +import CoreSubst hiding( substTy ) +import CoreArity ( manifestArity, exprBotStrictness_maybe ) +import CoreUtils +import Id +import DataCon +import Literal +import PrimOp +import IdInfo +import BasicTypes ( Arity ) +import Type +import PrelNames +import TysPrim ( realWorldStatePrimTy ) +import Bag +import Util +import FastTypes +import FastString +import Outputable +import ForeignCall + +import qualified Data.ByteString as BS +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Making unfoldings} +* * +************************************************************************ +-} + +mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding +mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -} + +mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding +-- For implicit Ids, do a tiny bit of optimising first +mkImplicitUnfolding dflags expr + = mkTopUnfolding dflags False (simpleOptExpr expr) + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr ops } + -- See Note [Occurrrence analysis of unfoldings] + +mkWwInlineRule :: CoreExpr -> Arity -> Unfolding +mkWwInlineRule expr arity + = mkCoreUnfolding InlineStable True + (simpleOptExpr expr) + (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtNotOk }) + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr expr) + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) + +mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding +-- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap +mkWorkerUnfolding dflags work_fn + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl }) + | isStableSource src + = mkCoreUnfolding src top_lvl new_tmpl guidance + where + new_tmpl = simpleOptExpr (work_fn tmpl) + guidance = calcUnfoldingGuidance dflags new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding +mkInlineUnfolding mb_arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr expr + guide = case mb_arity of + Nothing -> UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + Just arity -> UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable True is_bot expr' + where + expr' = simpleOptExpr expr + is_bot = isJust (exprBotStrictness_maybe expr') + +specUnfolding :: DynFlags -> Subst -> [Var] -> [CoreExpr] -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +specUnfolding _ subst new_bndrs spec_args + df@(DFunUnfolding { df_bndrs = bndrs, df_con = con , df_args = args }) + = ASSERT2( length bndrs >= length spec_args, ppr df $$ ppr spec_args $$ ppr new_bndrs ) + mkDFunUnfolding (new_bndrs ++ extra_bndrs) con + (map (substExpr spec_doc subst2) args) + where + subst1 = extendSubstList subst (bndrs `zip` spec_args) + (subst2, extra_bndrs) = substBndrs subst1 (dropList spec_args bndrs) + +specUnfolding _dflags subst new_bndrs spec_args + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl + , uf_guidance = old_guidance }) + | isStableSource src -- See Note [Specialising unfoldings] + , UnfWhen { ug_arity = old_arity + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } <- old_guidance + = let guidance = UnfWhen { ug_arity = old_arity - count isValArg spec_args + + count isId new_bndrs + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } + new_tmpl = simpleOptExpr $ mkLams new_bndrs $ + mkApps (substExpr spec_doc subst tmpl) spec_args + -- The beta-redexes created here will be simplified + -- away by simplOptExpr in mkUnfolding + + in mkCoreUnfolding src top_lvl new_tmpl guidance + +specUnfolding _ _ _ _ _ = noUnfolding + +spec_doc :: SDoc +spec_doc = ptext (sLit "specUnfolding") + +{- +Note [Specialising unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise a function for some given type-class arguments, we use +specUnfolding to specialise its unfolding. Some important points: + +* If the original function has a DFunUnfolding, the specialised one + must do so too! Otherwise we lose the magic rules that make it + interact with ClassOps + +* There is a bit of hack for INLINABLE functions: + f :: Ord a => .... + f = + {- INLINEABLE f #-} + Now if we specialise f, should the specialised version still have + an INLINEABLE pragma? If it does, we'll capture a specialised copy + of as its unfolding, and that probaby won't inline. But + if we don't, the specialised version of might be small + enough to inline at a call site. This happens with Control.Monad.liftM3, + and can cause a lot more allocation as a result (nofib n-body shows this). + + Moreover, keeping the INLINEABLE thing isn't much help, because + the specialised function (probaby) isn't overloaded any more. + + Conclusion: drop the INLINEALE pragma. In practice what this means is: + if a stable unfolding has UnfoldingGuidance of UnfWhen, + we keep it (so the specialised thing too will always inline) + if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs + (which arises from INLINEABLE), we discard it +-} + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence analysis of unfoldings] + uf_src = src, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -> Bool -> CoreExpr + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding dflags src top_lvl is_bottoming expr + | top_lvl && is_bottoming + , not (exprIsTrivial expr) + = NoUnfolding -- See Note [Do not inline top-level bottoming functions] + | otherwise + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence analysis of unfoldings] + uf_src = src, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_work_free = exprIsWorkFree expr, + uf_guidance = guidance } + where + guidance = calcUnfoldingGuidance dflags expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +{- +Note [Occurrence analysis of unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do occurrence-analysis of unfoldings once and for all, when the +unfolding is built, rather than each time we inline them. + +But given this decision it's vital that we do +*always* do it. Consider this unfolding + \x -> letrec { f = ...g...; g* = f } in body +where g* is (for some strange reason) the loop breaker. If we don't +occ-anal it when reading it in, we won't mark g as a loop breaker, and +we may inline g entirely in body, dropping its binding, and leaving +the occurrence in f out of scope. This happened in Trac #8892, where +the unfolding in question was a DFun unfolding. + +But more generally, the simplifier is designed on the +basis that it is looking at occurrence-analysed expressions, so better +ensure that they acutally are. + +Note [Calculate unfolding guidance on the non-occ-anal'd expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we give the non-occur-analysed expression to +calcUnfoldingGuidance. In some ways it'd be better to occur-analyse +first; for example, sometimes during simplification, there's a large +let-bound thing which has been substituted, and so is now dead; so +'expr' contains two copies of the thing while the occurrence-analysed +expression doesn't. + +Nevertheless, we *don't* and *must not* occ-analyse before computing +the size because + +a) The size computation bales out after a while, whereas occurrence + analysis does not. + +b) Residency increases sharply if you occ-anal first. I'm not + 100% sure why, but it's a large effect. Compiling Cabal went + from residency of 534M to over 800M with this one change. + +This can occasionally mean that the guidance is very pessimistic; +it gets fixed up next round. And it should be rare, because large +let-bound things that are dead are usually caught by preInlineUnconditionally + + +************************************************************************ +* * +\subsection{The UnfoldingGuidance type} +* * +************************************************************************ +-} + +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + +calcUnfoldingGuidance + :: DynFlags + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance dflags (Tick t expr) + | not (tickishIsCode t) -- non-code ticks don't matter for unfolding + = calcUnfoldingGuidance dflags expr +calcUnfoldingGuidance dflags expr + = case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline expr n_val_bndrs (iBox size) + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = iBox size + , ug_res = iBox scrut_discount } + + where + (bndrs, body) = collectBinders expr + bOMB_OUT_SIZE = ufCreationThreshold dflags + -- Bomb out if size gets bigger than this + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + mk_discount :: Bag (Id,Int) -> Id -> Int + mk_discount cbs bndr = foldlBag combine 0 cbs + where + combine acc (bndr', disc) + | bndr == bndr' = acc `plus_disc` disc + | otherwise = acc + + plus_disc :: Int -> Int -> Int + plus_disc | isFunTy (idType bndr) = max + | otherwise = (+) + -- See Note [Function and non-function discounts] + +{- +Note [Computing the size of an expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of sizeExpr is obvious enough: count nodes. But getting the +heuristics right has taken a long time. Here's the basic strategy: + + * Variables, literals: 0 + (Exception for string literals, see litSize.) + + * Function applications (f e1 .. en): 1 + #value args + + * Constructor applications: 1, regardless of #args + + * Let(rec): 1 + size of components + + * Note, cast: 0 + +Examples + + Size Term + -------------- + 0 42# + 0 x + 0 True + 2 f x + 1 Just x + 4 f (g x) + +Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's +a function call to account for. Notice also that constructor applications +are very cheap, because exposing them to a caller is so valuable. + +[25/5/11] All sizes are now multiplied by 10, except for primops +(which have sizes like 1 or 4. This makes primops look fantastically +cheap, and seems to be almost unversally beneficial. Done partly as a +result of #4978. + +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it into +even the most boring context. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + +(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that + (f x) --> (g 3) -- YES, unconditionally + (f x) --> x : [] -- YES, *even though* there are two + -- arguments to the cons + x --> g 3 -- NO + x --> Just v -- NO + + It's very important not to unconditionally replace a variable by + a non-atomic term. + +(2) We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +(3) However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. (This check is + made in the UnfWhen case of callSiteInline.) Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + +(4) We must be much more cautious about arity-zero things. Consider + let x = y +# z in ... + In *size* terms primops look very small, because the generate a + single instruction, but we do not want to unconditionally replace + every occurrence of x with (y +# z). So we only do the + unconditional-inline thing for *trivial* expressions. + + NB: you might think that PostInlineUnconditionally would do this + but it doesn't fire for top-level things; see SimplUtils + Note [Top level and postInlineUnconditionally] +-} + +uncondInline :: CoreExpr -> Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [INLINE for small functions] +uncondInline rhs arity size + | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) + | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) + +sizeExpr :: DynFlags + -> FastInt -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> CoreExpr + -> ExprSize + +-- Note [Computing the size of an expression] + +sizeExpr dflags bOMB_OUT_SIZE top_args expr + = size_up expr + where + size_up (Cast e _) = size_up e + size_up (Tick _ e) = size_up e + size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero + size_up (Lit lit) = sizeN (litSize lit) + size_up (Var f) | isRealWorldId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 + + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + + size_up (Lam b e) + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) + | otherwise = size_up e + + size_up (Let (NonRec binder rhs) body) + = size_up rhs `addSizeNSD` + size_up body `addSizeN` + (if isUnLiftedType (idType binder) then 0 else 10) + -- For the allocation + -- If the binder has an unlifted type there is no allocation + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up . snd) + (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation + pairs + + size_up (Case (Var v) _ _ alts) + | v `elem` top_args -- We are scrutinising an argument variable + = alts_size (foldr addAltSize sizeZero alt_sizes) + (foldr maxSize sizeZero alt_sizes) + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + where + alt_sizes = map size_up_alt alts + + -- alts_size tries to compute a good discount for + -- the case when we are scrutinising an argument variable + alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives + (SizeIs max _ _) -- Size of biggest alternative + = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut + -- If the variable is known, we produce a discount that + -- will take us back to 'max', the size of the largest alternative + -- The 1+ is a little discount for reduced allocation in the caller + -- + -- Notice though, that we return tot_disc, the total discount from + -- all branches. I think that's right. + + alts_size tot_size _ = tot_size + + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "not (lengthExceeds alts 1)" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = isUnLiftedType (idType v) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False + + ------------ + -- size_up_app is used when there's ONE OR MORE value args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app (Tick _ expr) args voids = size_up_app expr args voids + size_up_app other args voids = size_up other `addSizeN` (length args - voids) + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (10 * (1 + length val_args)) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize dflags top_args val_args + _ -> funSize dflags top_args fun (length val_args) voids + + ------------ + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 + -- Don't charge for args, so that wrappers look cheap + -- (See comments about wrappers with Case) + -- + -- IMPORATANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errrnoToIOError + + ------------ + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d + + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) + (xs `unionBags` ys) + (d1 +# d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) + (xs `unionBags` ys) + d2 -- Ignore d1 + + isRealWorldId id = idType id `eqType` realWorldStatePrimTy + + -- an expression of type State# RealWorld must be a variable + isRealWorldExpr (Var id) = isRealWorldId id + isRealWorldExpr (Tick _ e) = isRealWorldExpr e + isRealWorldExpr _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by CoreUnfold.sizeExpr +litSize (LitInteger {}) = 100 -- Note [Size of literal integers] +litSize (MachStr str) = 10 + 10 * ((BS.length str + 3) `div` 4) + -- If size could be 0 then @f "x"@ might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 0 -- Must match size of nullary constructors + -- Key point: if x |-> 4, then x must inline unconditionally + -- (eg via case binding) + +classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ _ [] + = sizeZero +classOpSize dflags top_args (arg1 : other_args) + = SizeIs (iUnbox size) arg_discount (_ILIT(0)) + where + size = 20 + (10 * length other_args) + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, ufDictDiscount dflags) + _other -> emptyBag + +funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize +-- Size for functions that are not constructors or primops +-- Note [Function applications] +funSize dflags top_args fun n_val_args voids + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize + | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount) + where + some_val_args = n_val_args > 0 + + size | some_val_args = 10 * (1 + n_val_args - voids) + | otherwise = 0 + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + + -- DISCOUNTS + -- See Note [Function and non-function discounts] + arg_discount | some_val_args && fun `elem` top_args + = unitBag (fun, ufFunAppDiscount dflags) + | otherwise = emptyBag + -- If the function is an argument and is applied + -- to some values, give it an arg-discount + + res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags + | otherwise = 0 + -- If the function is partially applied, show a result discount + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) + +{- +Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. But to give a bit +of extra incentive we give a discount of 10*(1 + n_val_args). + +Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), +and said it was an "unambiguous win", but its terribly dangerous +because a fuction with many many case branches, each finishing with +a constructor, can have an arbitrarily large discount. This led to +terrible code bloat: see Trac #6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +Note [Function and non-function discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with Trac #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +Trac #6048 is about. + +On the other hand, for data-valued arguments, if there are lots of +case expressions in the body, each one will get smaller if we apply +the function to a constructor application, so we *want* a big discount +if the argument is scrutinised by many case expressions. + +Conclusion: + - For functions, take the max of the discounts + - For data values, take the sum of the discounts + + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (S# n). We just use an aribitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = S# 5 +There's no point in doing so -- any optimisations will see the S# +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. +-} + +primOpSize :: PrimOp -> Int -> ExprSize +primOpSize op n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op + + +buildSize :: ExprSize +buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) + -- We really want to inline applications of build + -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) + -- Indeed, we should add a result_discount becuause build is + -- very like a constructor. We don't bother to check that the + -- build is saturated (it usually is). The "-2" discounts for the \c n, + -- The "4" is rather arbitrary. + +augmentSize :: ExprSize +augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) + -- Ditto (augment t (\cn -> e) ys) should cost only the cost of + -- e plus ys. The -2 accounts for the \cn + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (iUnbox (ufFunAppDiscount dflags)) +lamScrutDiscount _ TooBig = TooBig + +{- +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in main/DynFlags, +all of form ufXxxx. They are: + +ufCreationThreshold + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +ufUseThreshold + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +ufKeenessFactor + Factor by which the discounts are multiplied before + subtracting from size + +ufDictDiscount + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +ufFunAppDiscount + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +ufDearOp + The size of a foreign call or not-dupable PrimOp + + +Note [Function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a function application (f a b) + + - If 'f' is an argument to the function being analysed, + and there's at least one value arg, record a FunAppDiscount for f + + - If the application if a PAP (arity > 2 in this example) + record a *result* discount (because inlining + with "extra" args in the call may mean that we now + get a saturated application) + +Code for manipulating sizes +-} + +data ExprSize = TooBig + | SizeIs FastInt -- Size found + !(Bag (Id,Int)) -- Arguments cased herein, and discount for each such + FastInt -- Size to subtract if result is scrutinised + -- by a case expression + +instance Outputable ExprSize where + ppr TooBig = ptext (sLit "TooBig") + ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox c)) + +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize +mkSizeIs max n xs d | (n -# d) ># max = TooBig + | otherwise = SizeIs n xs d + +maxSize :: ExprSize -> ExprSize -> ExprSize +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 + | otherwise = s2 + +sizeZero :: ExprSize +sizeN :: Int -> ExprSize + +sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) +sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline dflags threshold rhs + = case sizeExpr dflags (iUnbox threshold) [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: DynFlags -> Unfolding -> Bool +smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) + = size <= ufUseThreshold dflags +smallEnoughToInline _ _ + = False + +---------------- +certainlyWillInline :: DynFlags -> Unfolding -> Maybe Unfolding +-- Sees if the unfolding is pretty certain to inline +-- If so, return a *stable* unfolding for it, that will always inline +certainlyWillInline dflags unf@(CoreUnfolding { uf_guidance = guidance, uf_tmpl = expr }) + = case guidance of + UnfNever -> Nothing + UnfWhen {} -> Just (unf { uf_src = InlineStable }) + + -- The UnfIfGoodArgs case seems important. If we w/w small functions + -- binary sizes go up by 10%! (This is with SplitObjs.) I'm not totally + -- sure whyy. + UnfIfGoodArgs { ug_size = size, ug_args = args } + | not (null args) -- See Note [certainlyWillInline: be careful of thunks] + , let arity = length args + , size - (10 * (arity + 1)) <= ufUseThreshold dflags + -> Just (unf { uf_src = InlineStable + , uf_guidance = UnfWhen { ug_arity = arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk expr } }) + -- Note the "unsaturatedOk". A function like f = \ab. a + -- will certainly inline, even if partially applied (f e), so we'd + -- better make sure that the transformed inlining has the same property + + _ -> Nothing + +certainlyWillInline _ unf@(DFunUnfolding {}) + = Just unf + +certainlyWillInline _ _ + = Nothing + +{- +Note [certainlyWillInline: be careful of thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't claim that thunks will certainly inline, because that risks work +duplication. Even if the work duplication is not great (eg is_cheap +holds), it can make a big difference in an inner loop In Trac #5623 we +found that the WorkWrap phase thought that + y = case x of F# v -> F# (v +# v) +was certainlyWillInline, so the addition got duplicated. + + +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: DynFlags + -> Id -- The Id + -> Bool -- True <=> unfolding is active + -> Bool -- True if there are are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +instance Outputable ArgSummary where + ppr TrivArg = ptext (sLit "TrivArg") + ppr NonTrivArg = ptext (sLit "NonTrivArg") + ppr ValueArg = ptext (sLit "ValueArg") + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True + +data CallCtxt + = BoringCtxt + | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a fuction with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = ptext (sLit "CaseCtxt") + ppr ValAppCtxt = ptext (sLit "ValAppCtxt") + ppr BoringCtxt = ptext (sLit "BoringCtxt") + ppr RhsCtxt = ptext (sLit "RhsCtxt") + ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt") + ppr RuleArgCtxt = ptext (sLit "RuleArgCtxt") + +callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top + , uf_is_work_free = is_wf + , uf_guidance = guidance, uf_expandable = is_exp } + | active_unfolding -> tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template is_top + is_wf is_exp guidance + | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +traceInline :: DynFlags -> String -> SDoc -> a -> a +traceInline dflags str doc result + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + = pprTrace str doc result + | otherwise + = result + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template is_top + is_wf is_exp guidance + = case guidance of + UnfNever -> traceInline dflags str (ptext (sLit "UnfNever")) Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit) + -- See Note [INLINE for small functions (3)] + -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline dflags str (mk_doc some_benefit empty False) Nothing + where + some_benefit = calc_some_benefit uf_arity + enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | is_wf && some_benefit && small_enough + -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template) + | otherwise + -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing + where + some_benefit = calc_some_benefit (length arg_discounts) + extra_doc = text "discounted size =" <+> int discounted_size + discounted_size = size - discount + small_enough = discounted_size <= ufUseThreshold dflags + discount = computeDiscount dflags arg_discounts + res_discount arg_infos cont_info + + where + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , text "is exp:" <+> ppr is_exp + , text "is work-free:" <+> ppr is_wf + , text "guidance" <+> ppr guidance + , extra_doc + , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] + + str = "Considering inlining: " ++ showSDocDump dflags (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + calc_some_benefit :: Arity -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + DiscArgCtxt -> uf_arity > 0 -- + RhsCtxt -> uf_arity > 0 -- + _ -> not is_top && uf_arity > 0 -- Note [Nested functions] + -- Note [Inlining in ArgCtxt] + +{- +Note [Unfold into lazy contexts], Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the call is the argument of a function with a RULE, or the RHS of a let, +we are a little bit keener to inline. For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. +So we treat the RHS of a let as not-totally-boring. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) programmer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +If a function has a nested defn we also record some-benefit, on the +grounds that we are often able to eliminate the binding, and hence the +allocation, for the function altogether; this is good for join points. +But this only makes sense for *functions*; inlining a constructor +doesn't help allocation unless the result is scrutinised. UNLESS the +constructor occurs just once, albeit possibly in multiple case +branches. Then inlining it doesn't increase allocation, but it does +increase the chance that the constructor won't be allocated at all in +the branches that don't use it. + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~ which appears below +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory varaints, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. is is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. If the thing is bound to a value. + +However, watch out: + + * Consider this: + foo = _inline_ (\n. [n]) + bar = _inline_ (foo 20) + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_wf" in the + InlineRule branch. + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutines a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. +-} + +computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount dflags arg_discounts res_discount arg_infos cont_info + -- We multiple the raw discounts (args_discount and result_discount) + -- ty opt_UnfoldingKeenessFactor because the former have to do with + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- by inlining. + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + round (ufKeenessFactor dflags * + fromIntegral (total_arg_discount + res_discount')) + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to aovid inlining large functions that return + -- constructors into contexts that are simply "interesting" + diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs new file mode 100644 index 00000000..57e0e692 --- /dev/null +++ b/compiler/coreSyn/CoreUtils.hs @@ -0,0 +1,2099 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} + +-- | Commonly useful utilites for manipulating the Core language +module CoreUtils ( + -- * Constructing expressions + mkCast, + mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, + mkAltExpr, + + -- * Taking expressions apart + findDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, filterAlts, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, + exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, + exprIsBig, exprIsConLike, + rhsIsStatic, isCheapApp, isExpandableApp, + + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, + + -- * Equality + cheapEqExpr, cheapEqExpr', eqExpr, + diffExpr, diffBinds, + + -- * Eta reduction + tryEtaReduce, + + -- * Manipulating data constructors and types + applyTypeToArgs, applyTypeToArg, + dataConRepInstPat, dataConRepFSInstPat, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT + ) where + +#include "HsVersions.h" + +import CoreSyn +import PprCore +import CoreFVs( exprFreeVars ) +import Var +import SrcLoc +import VarEnv +import VarSet +import Name +import Literal +import DataCon +import PrimOp +import Id +import IdInfo +import Type +import Coercion +import TyCon +import Unique +import Outputable +import TysPrim +import DynFlags +import FastString +import Maybes +import Platform +import Util +import Pair +import Data.Function ( on ) +import Data.List +import Data.Ord ( comparing ) +import OrdList + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'CoreSyn.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWith [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType (_,bs,rhs) + | any bad_binder bs = expandTypeSynonyms ty + | otherwise = ty -- Note [Existential variables and silly type synonyms] + where + ty = exprType rhs + free_tvs = tyVarsOfType ty + bad_binder b = isTyVar b && b `elemVarSet` free_tvs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desuguarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (Trac #8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See Trac #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. +-} + +applyTypeToArg :: Type -> CoreExpr -> Type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression +applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty +applyTypeToArg fun_ty _ = funResultTy fun_ty + +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. +-- The first argument is just for debugging, and gives some context +applyTypeToArgs e op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ _ = pprPanic "applyTypeToArgs" panic_msg + + -- go_ty_args: accumulate type arguments so we can instantiate all at once + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys args + = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args + + panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg + panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e + , ptext (sLit "Type:") <+> ppr op_ty + , ptext (sLit "Args:") <+> ppr args ] + +{- +************************************************************************ +* * +\subsection{Attaching notes} +* * +************************************************************************ +-} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: CoreExpr -> Coercion -> CoreExpr +mkCast e co | ASSERT2( coercionRole co == Representational + , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) ) + isReflCo co = e + +mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind co)) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + = Coercion (mkCoCast e_co co) + +mkCast (Cast expr co2) co + = WARN(let { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + not (from_ty `eqType` to_ty2), + vcat ([ ptext (sLit "expr:") <+> ppr expr + , ptext (sLit "co2:") <+> ppr co2 + , ptext (sLit "co:") <+> ppr co ]) ) + mkCast expr (mkTransCo co2 co) + +mkCast (Tick t expr) co + = Tick t (mkCast expr co) + +mkCast expr co + = let Pair from_ty _to_ty = coercionKind co in +-- if to_ty `eqType` from_ty +-- then expr +-- else + WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co)) + (Cast expr co) + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: Tickish Id -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the + -- non-counting part having laxer placement properties. + canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + + mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) + -> CoreExpr -- ^ current expression + -> CoreExpr + mkTick' top rest expr = case expr of + + -- Cost centre ticks should never be reordered relative to each + -- other. Therefore we can stop whenever two collide. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expresion +stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (c,bs,e) = (c,bs, go e) + +stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (_, _, e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'MkCore.mkCoreLet' +bindNonRec bndr rhs body + | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + | otherwise = Let (NonRec bndr rhs) body + +-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression +-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" +needsCaseBinding :: Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + +mkAltExpr :: AltCon -- ^ Case alternative constructor + -> [CoreBndr] -- ^ Things bound by the pattern match + -> [Type] -- ^ The type arguments to the case alternative + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +{- +************************************************************************ +* * +\subsection{Taking expressions apart} +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +isDefaultAlt :: (AltCon, a, b) -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt _ = False + + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) + -- A "Nothing" result *is* legitmiate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +--------------------------------- +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] +-- ^ Merge alternatives preserving order; alternatives in +-- the first argument shadow ones in the second +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match agains the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon + -> Type -- ^ Type of scrutinee (used to prune possibilities) + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], Bool, [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) + -- 3. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- and with the DEFAULT expanded to a DataAlt if there is exactly + -- remaining constructor that can match + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts us ty imposs_cons alts + | Just (tycon, inst_tys) <- splitTyConApp_maybe ty + = filter_alts tycon inst_tys + | otherwise + = (imposs_cons, False, alts) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + + filter_alts tycon inst_tys + = (imposs_deflt_cons, refined_deflt, merged_alts) + where + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_deflt_cons = nub (imposs_cons ++ alt_cons) + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') + -- We need the mergeAlts in case the new default_alt + -- has turned into a constructor alternative. + -- The merge keeps the inner DEFAULT at the front, if there is one + -- and interleaves the alternatives in the right order + + (refined_deflt, maybe_deflt') = case maybe_deflt of + Nothing -> (False, Nothing) + Just deflt_rhs + | isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type + impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con + -> case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, Nothing) + -- It matches exactly one constructor, so fill it in: + [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) + where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + + | debugIsOn, isAlgTyCon tycon + , null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + -> pprTrace "prepareDefault" (ppr tycon) + (False, Just (DEFAULT, [], deflt_rhs)) + + | otherwise -> (False, Just (DEFAULT, [], deflt_rhs)) + + impossible_alt :: [Type] -> (AltCon, a, b) -> Bool + impossible_alt _ (con, _, _) | con `elem` imposs_cons = True + impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +{- +Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf Trac #3118.) Then the full-lazines pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in Simplify.rebuildCase. + + +************************************************************************ +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variable are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ + +Ticks are only trivial if they are pure annotations. If we treat +"tick x" as trivial, it will be inlined inside lambdas and the +entry count will be skewed, for example. Furthermore "scc x" will +turn into just "x" in mkTick. +-} + +exprIsTrivial :: CoreExpr -> Bool +exprIsTrivial (Var _) = True -- See Note [Variables are trivial] +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e + -- See Note [Tick trivial] +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial _ = False + +{- +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial. +-} + +getIdFromTrivialExpr :: CoreExpr -> Id +getIdFromTrivialExpr e = go e + where go (Var v) = v + go (App f t) | not (isRuntimeArg t) = go f + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (Lam b e) | not (isRuntimeVar b) = go e + go e = pprPanic "getIdFromTrivialExpr" (ppr e) + +{- +exprIsBottom is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. See +also CoreArity.exprBotStrictness_maybe, but that's a bit more +expensive. +-} + +exprIsBottom :: CoreExpr -> Bool +exprIsBottom e + = go 0 e + where + go n (Var v) = isBottomingId v && n >= idArity v + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go _ _ = False + +{- +************************************************************************ +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: DynFlags -> CoreExpr -> Bool +exprIsDupable dflags e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable dflags lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed Trac #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (Trac #5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) +-} + +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = go 0 e + where -- n is the number of value arguments + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) + [ go n rhs | (_,_,rhs) <- alts ] + -- See Note [Case expressions are work-free] + go _ (Let {}) = False + go n (Var v) = isCheapApp v n + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = exprIsWorkFree e && go (n+1) f + | otherwise = go n f + +{- +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + + +Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +[Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap.] + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. +-} + +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheap' isCheapApp + +exprIsExpandable :: CoreExpr -> Bool +exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes + +exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Coercion _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e + +exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && + and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] + -- Experimentally, treat (case x of ...) as cheap + -- (and case __coerce x etc.) + -- This improves arities of overloaded functions where + -- there is only dictionary selection (no construction) involved + +exprIsCheap' good_app (Tick t e) + | tickishCounts t = False + | otherwise = exprIsCheap' good_app e + -- never duplicate counting ticks. If we get this wrong, then + -- HPC's entry counts will be off (check test in + -- libraries/hpc/tests/raytrace) + +exprIsCheap' good_app (Let (NonRec _ b) e) + = exprIsCheap' good_app b && exprIsCheap' good_app e +exprIsCheap' good_app (Let (Rec prs) e) + = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e + +exprIsCheap' good_app other_expr -- Applications and variables + = go other_expr [] + where + -- Accumulate value arguments, then decide + go (Cast e _) val_args = go e val_args + go (App f a) val_args | isRuntimeArg a = go f (a:val_args) + | otherwise = go f val_args + + go (Var _) [] = True + -- Just a type application of a variable + -- (f t1 t2 t3) counts as WHNF + -- This case is probably handeld by the good_app case + -- below, which should have a case for n=0, but putting + -- it here too is belt and braces; and it's such a common + -- case that checking for null directly seems like a + -- good plan + + go (Var f) args + | good_app f (length args) + = go_pap args + + | otherwise + = case idDetails f of + RecSelId {} -> go_sel args + ClassOpId {} -> go_sel args + PrimOpId op -> go_primop op args + _ | isBottomingId f -> True + | otherwise -> False + -- Application of a function which + -- always gives bottom; we treat this as cheap + -- because it certainly doesn't need to be shared! + + go (Tick t e) args + | not (tickishCounts t) -- don't duplicate counting ticks, see above + = go e args + + go _ _ = False + + -------------- + go_pap args = all (exprIsCheap' good_app) args + -- Used to be "all exprIsTrivial args" due to concerns about + -- duplicating nested constructor applications, but see #4978. + -- The principle here is that + -- let x = a +# b in c *# x + -- should behave equivalently to + -- c *# (a +# b) + -- Since lets with cheap RHSs are accepted, + -- so should paps with cheap arguments + + -------------- + go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + + -------------- + go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection + go_sel _ = False -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection. + -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but + -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +------------------------------------- +type CheapAppFun = Id -> Int -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- Mainly true of partial applications, data constructors, + -- and of course true if the number of args is zero + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + = isDataConWorkId fn + || n_val_args == 0 + || n_val_args < idArity fn + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + = isConLikeId fn + || n_val_args < idArity fn + || go n_val_args (idType fn) + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + -- This incidentally picks up the (n_val_args = 0) case + go 0 _ = True + go n_val_args ty + | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty + | Just (arg, ty) <- splitFunTy_maybe ty + , isPredTy arg = go (n_val_args-1) ty + | otherwise = False + +{- +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + +************************************************************************ +* * + exprOkForSpeculation +* * +************************************************************************ +-} + +----------------------------- +-- | 'exprOkForSpeculation' returns True of an expression that is: +-- +-- * Safe to evaluate even if normal order eval might not +-- evaluate the expression at all, or +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- It is usually called on arguments of unlifted type, but not always +-- In particular, Simplify.rebuildCase calls it on lifted types +-- when a 'case' is a plain 'seq'. See the example in +-- Note [exprOkForSpeculation: case expressions] below +-- +-- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) +-- +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in PrimOp +-- and Note [Implementation: how can_fail/has_side_effects affect transformations] +-- +-- As an example of the considerations in this test, consider: +-- +-- > let x = case y# +# 1# of { r# -> I# r# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- We can only do this if the @y + 1@ is ok for speculation: it has no +-- side effects, and can't diverge or raise an exception. +exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects + -- Polymorphic in binder type + -- There is one call at a non-Id binder type, in SetLevels + +expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok primop_ok e + +expr_ok primop_ok (Case e _ _ alts) + = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts -- Note [Exhaustive alts] + +expr_ok primop_ok other_expr + = case collectArgs other_expr of + (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr + -> app_ok primop_ok f args + _ -> False + +----------------------------- +app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool +app_ok primop_ok fun args + = case idDetails fun of + DFunId _ new_type -> not new_type + -- DFuns terminate, unless the dict is implemented + -- with a newtype in which case they may not + + DataConWorkId {} -> True + -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op + | isDivOp op -- Special case for dividing operations that fail + , [arg1, Lit lit] <- args -- only if the divisor is zero + -> not (isZeroLit lit) && expr_ok primop_ok arg1 + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner looop + + | DataToTagOp <- op -- See Note [dataToTag speculation] + -> True + + | otherwise + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy + + _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF + || idArity fun > n_val_args -- Partial apps + || (n_val_args == 0 && + isEvaldUnfolding (idUnfolding fun)) -- Let-bound values + where + n_val_args = valArgCount args + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definiely exhaustive +-- False <=> they may or may not be +altsAreExhaustive [] + = False -- Should not happen +altsAreExhaustive ((con1,_,_) : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | True of dyadic operators that can fail only if the second arg is zero! +isDivOp :: PrimOp -> Bool +-- This function probably belongs in PrimOp, or even in +-- an automagically generated file.. but it's such a +-- special case I thought I'd leave it here for now. +isDivOp IntQuotOp = True +isDivOp IntRemOp = True +isDivOp WordQuotOp = True +isDivOp WordRemOp = True +isDivOp FloatDivOp = True +isDivOp DoubleDivOp = True +isDivOp _ = False + +{- +Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's always sound for exprOkForSpeculation to return False, and we +don't want it to take too long, so it bales out on complicated-looking +terms. Notably lets, which can be stacked very deeply; and in any +case the argument of exprOkForSpeculation is usually in a strict context, +so any lets will have been floated away. + +However, we keep going on case-expressions. An example like this one +showed up in DPH code (Trac #3717): + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +If exprOkForSpeculation doesn't look through case expressions, you get this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 + } + +The inner case is redundant, and should be nuked. + +Note [Exhaustive alts] +~~~~~~~~~~~~~~~~~~~~~~ +We might have something like + case x of { + A -> ... + _ -> ...(case x of { B -> ...; C -> ... })... +Here, the inner case is fine, because the A alternative +can't happen, but it's not ok to float the inner case outside +the outer one (even if we know x is evaluated outside), because +then it would be non-exhaustive. See Trac #5453. + +Similarly, this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... +But we don't want to speculate the v binding. + +One could try to be clever, but the easy fix is simpy to regard +a non-exhaustive case as *not* okForSpeculation. + + +Note [dataToTag speculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this OK? + f x = let v::Int# = dataToTag# x + in ... +We say "yes", even though 'x' may not be evaluated. Reasons + + * dataToTag#'s strictness means that its argument often will be + evaluated, but FloatOut makes that temporarily untrue + case x of y -> let v = dataToTag# y in ... + --> + case x of y -> let v = dataToTag# x in ... + Note that we look at 'x' instead of 'y' (this is to improve + floating in FloatOut). So Lint complains. + + Moreover, it really *might* improve floating to let the + v-binding float out + + * CorePrep makes sure dataToTag#'s argument is evaluated, just + before code gen. Until then, it's not guaranteed + + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to change: +-- +-- > case x of _ -> e +-- +-- into: +-- +-- > e +-- +-- and to decide whether it's safe to discard a 'seq'. +-- +-- So, it does /not/ treat variables as evaluated, unless they say they are. +-- However, it /does/ treat partial applications and constructor applications +-- as values, even if their arguments are non-trivial, provided the argument +-- type is lifted. For example, both of these are values: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't +-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of +-- unboxed type must be ok-for-speculation (or trivial). +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf = is_hnf_like + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = is_con v -- Catches nullary constructors, + -- so that [] and () are values, for example + || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + is_hnf_like (Lit _) = True + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- See Note [exprIsHNF Tick] + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e (Coercion _)) = is_hnf_like e + is_hnf_like (App e a) = app_is_value e [a] + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- There is at least one value argument + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var fun) args + = idArity fun > valArgCount args -- Under-applied function + || is_con fun -- or constructor-like + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as = app_is_value f (a:as) + app_is_value _ _ = False + +{- +Note [exprIsHNF Tick] + +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +regarded as HNF if the expression they surround is HNF, because the +tick is there to tell us that the expression was evaluated, so we +don't want to discard a seq on it. +-} + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a triple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipOpenTvSubst univ_tvs inst_tys + + -- Make existential type variables, applyingn and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) + , new_tv) + where + new_tv = mkTyVar new_name kind + new_name = mkSysTvName uniq fs + kind = Type.substTy subst (tyVarKind tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs ty str + = mkLocalIdWithInfo name (Type.substTy full_subst ty) info + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding + | otherwise = vanillaIdInfo + -- See Note [Mark evaluated arguments] + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +-- +-- See also 'exprIsBig' +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool +cheapEqExpr' ignoreTick = go_s + where go_s = go `on` stripTicksTopE ignoreTick + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 + + go (App f1 a1) (App f2 a2) + = f1 `go_s` f2 && a1 `go_s` a2 + + go (Cast e1 t1) (Cast e2 t2) + = e1 `go_s` e2 && t1 `coreEqCoercion` t2 + + go (Tick t1 e1) (Tick t2 e2) + = t1 == t2 && e1 `go_s` e2 + + go _ _ = False + {-# INLINE go #-} +{-# INLINE cheapEqExpr' #-} + +exprIsBig :: Expr b -> Bool +-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' +exprIsBig (Lit _) = False +exprIsBig (Var _) = False +exprIsBig (Type _) = False +exprIsBig (Coercion _) = False +exprIsBig (Lam _ e) = exprIsBig e +exprIsBig (App f a) = exprIsBig f || exprIsBig a +exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! +exprIsBig (Tick _ e) = exprIsBig e +exprIsBig _ = True + +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = go (mkRnEnv2 in_scope) e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = length ps1 == length ps2 + && all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + +eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids +eqTickish _ l r = l == r + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | coreEqCoercion2 env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | coreEqCoercion2 env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isBottomingId absent && isBottomingId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (c1, bs1, e1) (c2, bs2, e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then specuatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go fuel env binds1 binds2 + -- No binds left to compare? Bail out early. + | null binds1 || null binds2 + = (warn env binds1 binds2, env) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst (head binds1) + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && length bs1 == length bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) + (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) + | v1 == v2 && cl1 == cl2 + && wf1 == wf2 && x1 == x2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + +{- +************************************************************************ +* * +\subsection{The size of an expression} +* * +************************************************************************ +-} + +data CoreStats = CS { cs_tm :: Int -- Terms + , cs_ty :: Int -- Types + , cs_co :: Int } -- Coercions + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) + = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, + ptext (sLit "types:") <+> intWithCommas i2 <> comma, + ptext (sLit "coercions:") <+> intWithCommas i3]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldr (plusCS . f) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS bindStats + +bindStats :: CoreBind -> CoreStats +bindStats (NonRec v r) = bindingStats v r +bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs + +bindingStats :: Var -> CoreExpr -> CoreStats +bindingStats v r = bndrStats v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b t as) = seqType t `seq` exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote cc _ _) = cc `seq` 1 +tickSize _ = 1 -- the rest are strict + +bndrSize :: Var -> Int +bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try for eta reduction here, but *only* if we get all the way to an +trivial expression. We don't want to remove extra lambdas unless we +are going to avoid allocating this thing altogether. + +There are some particularly delicate points here: + +* We want to eta-reduce if doing so leaves a trivial expression, + *including* a cast. For example + \x. f |> co --> f |> co + (provided co doesn't mention x) + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it + *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands + the definition again, so that it does not termninate after all. + Result: seg-fault because the boolean case actually gets a function value. + See Trac #1947. + + So it's important to do the right thing. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in SimplEnv) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity; and for primops we + must, since they have no unfolding. + +* Regardless of whether 'f' is a value, we always want to + reduce (/\a -> f a) to f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc isDictId + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +It's true that we could also hope to eta reduce these: + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) +But the simplifier pushes those casts outwards, so we don't +need to address that here. +-} + +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body (mkReflCo Representational (exprType body)) + where + incoming_arity = count isId bndrs + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + go [] fun co + | ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , not (any (`elemVarSet` used_vars) bndrs) + = Just (mkCast fun co) -- Check for any of the binders free in the result + -- including the accumulated coercion + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + ok_fun_id fun = fun_arity fun >= incoming_arity + + --------------- + fun_arity fun -- See Note [Arity care] + | isLocalId fun + , isStrongLoopBreaker (idOccInfo fun) = 0 + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction of an eval'd function] + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [Tickish Var]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkForAllCo tv co, []) + ok_arg bndr (Var v) co + | bndr == v = let reflCo = mkReflCo Representational (idType bndr) + in Just (mkFunCo Representational reflCo co, []) + ok_arg bndr (Cast e co_arg) co + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , bndr == v + = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co + = Just (co', t:ticks) + + ok_arg _ _ _ = Nothing + +{- +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell is is not true that f = \x. f x +because f might be bottom, and 'seq' can distinguish them. + +But it *is* true that f = f `seq` \x. f x +and we'd like to simplify the latter to the former. This amounts +to the rule that + * when there is just *one* value argument, + * f is not bottom +we can eta-reduce \x. f x ===> f + +This turned up in Trac #7542. + + +************************************************************************ +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +-- | This function is called only on *top-level* right-hand sides. +-- Returns @True@ if the RHS can be allocated statically in the output, +-- with no thunks involved at all. +rhsIsStatic :: Platform + -> (Name -> Bool) -- Which names are dynamic + -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting) + -- C.f. Note [Disgusting computation of CafRefs] + -- in TidyPgm + -> CoreExpr -> Bool +-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or +-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an +-- update flag on it and (iii) in DsExpr to decide how to expand +-- list literals +-- +-- The basic idea is that rhsIsStatic returns True only if the RHS is +-- (a) a value lambda +-- (b) a saturated constructor application with static args +-- +-- BUT watch out for +-- (i) Any cross-DLL references kill static-ness completely +-- because they must be 'executed' not statically allocated +-- ("DLL" here really only refers to Windows DLLs, on other platforms, +-- this is not necessary) +-- +-- (ii) We treat partial applications as redexes, because in fact we +-- make a thunk for them that runs and builds a PAP +-- at run-time. The only appliations that are treated as +-- static are *saturated* applications of constructors. + +-- We used to try to be clever with nested structures like this: +-- ys = (:) w ((:) w []) +-- on the grounds that CorePrep will flatten ANF-ise it later. +-- But supporting this special case made the function much more +-- complicated, because the special case only applies if there are no +-- enclosing type lambdas: +-- ys = /\ a -> Foo (Baz ([] a)) +-- Here the nested (Baz []) won't float out to top level in CorePrep. +-- +-- But in fact, even without -O, nested structures at top level are +-- flattened by the simplifier, so we don't need to be super-clever here. +-- +-- Examples +-- +-- f = \x::Int. x+7 TRUE +-- p = (True,False) TRUE +-- +-- d = (fst p, False) FALSE because there's a redex inside +-- (this particular one doesn't happen but...) +-- +-- h = D# (1.0## /## 2.0##) FALSE (redex again) +-- n = /\a. Nil a TRUE +-- +-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) +-- +-- +-- This is a bit like CoreUtils.exprIsHNF, with the following differences: +-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) +-- +-- b) (C x xs), where C is a contructor is updatable if the application is +-- dynamic +-- +-- c) don't look through unfolding of f in (f x). + +rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs + where + is_static :: Bool -- True <=> in a constructor argument; must be atomic + -> CoreExpr -> Bool + + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Tick n e) = not (tickishIsCode n) + && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i) + is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit _) = True + -- A MachLabel (foreign import "&foo") in an argument + -- prevents a constructor application from being static. The + -- reason is that it might give rise to unresolvable symbols + -- in the object file: under Linux, references to "weak" + -- symbols from the data segment give rise to "unresolvable + -- relocation" errors at link time This might be due to a bug + -- in the linker, but we'll work around it here anyway. + -- SDM 24/2/2004 + + is_static in_arg other_expr = go other_expr 0 + where + go (Var f) n_val_args + | (platformOS platform /= OSMinGW32) || + not (is_dynamic_name (idName f)) + = saturated_data_con f n_val_args + || (in_arg && n_val_args == 0) + -- A naked un-applied variable is *not* deemed a static RHS + -- E.g. f = g + -- Reason: better to update so that the indirection gets shorted + -- out, and the true value will be seen + -- NB: if you change this, you'll break the invariant that THUNK_STATICs + -- are always updatable. If you do so, make sure that non-updatable + -- ones have enough space for their static link field! + + go (App f a) n_val_args + | isTypeArg a = go f n_val_args + | not in_arg && is_static True a = go f (n_val_args + 1) + -- The (not in_arg) checks that we aren't in a constructor argument; + -- if we are, we don't allow (value) applications of any sort + -- + -- NB. In case you wonder, args are sometimes not atomic. eg. + -- x = D# (1.0## /## 2.0##) + -- can't float because /## can fail. + + go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args + go (Cast e _) n_val_args = go e n_val_args + go _ _ = False + + saturated_data_con f n_val_args + = case isDataConWorkId_maybe f of + Just dc -> n_val_args == dataConRepArity dc + Nothing -> False diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs new file mode 100644 index 00000000..6905641f --- /dev/null +++ b/compiler/coreSyn/MkCore.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE CPP #-} + +-- | Handy functions for creating much Core syntax +module MkCore ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkWordExpr, mkWordExprWord, + mkIntExpr, mkIntExprInt, + mkIntegerExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, + + -- * Floats + FloatBind(..), wrapFloat, + + -- * Constructing equality evidence boxes + mkEqBox, + + -- * Constructing general big tuples + -- $big_tuples + mkChunkified, + + -- * Constructing small tuples + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, + + -- * Constructing big tuples + mkBigCoreVarTup, mkBigCoreVarTupTy, + mkBigCoreTup, mkBigCoreTupTy, + + -- * Deconstructing small tuples + mkSmallTupleSelector, mkSmallTupleCase, + + -- * Deconstructing big tuples + mkTupleSelector, mkTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, errorIds, + rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + uNDEFINED_ID, undefinedName + ) where + +#include "HsVersions.h" + +import Id +import Var ( EvVar, setTyVarUnique ) + +import CoreSyn +import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) +import Literal +import HscTypes + +import TysWiredIn +import PrelNames + +import TcType ( mkSigmaTy ) +import Type +import Coercion +import TysPrim +import DataCon ( DataCon, dataConWorkId ) +import IdInfo ( vanillaIdInfo, setStrictnessInfo, + setArityInfo ) +import Demand +import Name hiding ( varName ) +import Outputable +import FastString +import UniqSupply +import BasicTypes +import Util +import Pair +import Constants +import DynFlags + +import Data.Char ( ord ) +import Data.List +import Data.Ord +#if __GLASGOW_HASKELL__ < 709 +import Data.Word ( Word ) +#endif + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic CoreSyn construction} +* * +************************************************************************ +-} + +sortQuantVars :: [Var] -> [Var] +-- Sort the variables (KindVars, TypeVars, and Ids) +-- into order: Kind, then Type, then Id +sortQuantVars = sortBy (comparing withCategory) + where + withCategory v = (category v, v) + category :: Var -> Int + category v + | isKindVar v = 1 + | isTyVar v = 2 + | otherwise = 3 + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "CoreSyn#let_app_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] + | needsCaseBinding (idType bndr) rhs + = Case rhs bndr (exprType body) [(DEFAULT,[],body)] +mkCoreLet bind body + = Let bind body + +-- | Bind a list of binding groups over an expression. The leftmost binding +-- group becomes the outermost group in the resulting expression +mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets binds body = foldr mkCoreLet body binds + +-- | Construct an expression which represents the application of one expression +-- to the other +mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreApp fun (Type ty) = App fun (Type ty) +mkCoreApp fun (Coercion co) = App fun (Coercion co) +mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) + mk_val_app fun arg arg_ty res_ty + where + fun_ty = exprType fun + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | Construct an expression which represents the application of a number of +-- expressions to another. The leftmost expression in the list is applied first +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- Slightly more efficient version of (foldl mkCoreApp) +mkCoreApps orig_fun orig_args + = go orig_fun (exprType orig_fun) orig_args + where + go fun _ [] = fun + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args + go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun + $$ ppr orig_args ) + go (mk_val_app fun arg arg_ty res_ty) res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | Construct an expression which represents the application of a number of +-- expressions to that of a data constructor expression. The leftmost expression +-- in the list is applied first +mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args + +mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +-- Build an application (e1 e2), +-- or a strict binding (case e2 of x -> e1 x) +-- using the latter when necessary to respect the let/app invariant +-- See Note [CoreSyn let/app invariant] +mk_val_app fun arg arg_ty res_ty + | not (needsCaseBinding arg_ty arg) + = App fun arg -- The vastly common case + + | otherwise + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + where + arg_id = mkWildValBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mk_val_app returns an expression that does not have + -- have a free wild-id. So the only thing that can go wrong + -- is if you take apart this case expression, and pass a + -- fragmet of it as the fun part of a 'mk_val_app'. + +----------- +mkWildEvBinder :: PredType -> EvVar +mkWildEvBinder pred = mkWildValBinder pred + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +-- See Note [WildCard binders] in SimplEnv +mkWildValBinder :: Type -> Id +mkWildValBinder ty = mkLocalId wildCardName ty + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildValBinder scrut_ty) res_ty alts + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard boolTy (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in CoreSyn +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + where + e_ty = exprType e + +{- +The functions from this point don't really do anything cleverer than +their counterparts in CoreSyn, but they are here for consistency +-} + +-- | Create a lambda where the given expression has a number of variables +-- bound over it. The leftmost binder is that bound by the outermost +-- lambda in the result +mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr +mkCoreLams = mkLams + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt dflags i = mkConApp intDataCon [mkIntLitInt dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +mkWordExpr :: DynFlags -> Integer -> CoreExpr +mkWordExpr dflags w = mkConApp wordDataCon [mkWordLit dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Word@ +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkConApp wordDataCon [mkWordLitWord dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ +mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer +mkIntegerExpr i = do t <- lookupTyCon integerTyConName + return (Lit (mkLitInteger i (mkTyConTy t))) + +-- | Create a 'CoreExpr' which will evaluate to the given @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkConApp floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkConApp doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkConApp charDataCon [mkCharLit c] + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String +-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ +mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String + +mkStringExpr str = mkStringExprFS (mkFastString str) + +mkStringExprFS str + | nullFS str + = return (mkNilExpr charTy) + + | all safeChar chars + = do unpack_id <- lookupId unpackCStringName + return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + + | otherwise + = do unpack_id <- lookupId unpackCStringUtf8Name + return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + +-- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b) +mkEqBox :: Coercion -> CoreExpr +mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) + Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co + where (Pair ty1 ty2, role) = coercionKindRole co + k = typeKind ty1 + datacon = case role of + Nominal -> eqBoxDataCon + Representational -> coercibleDataCon + Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" + (ppr co) + +{- +************************************************************************ +* * +\subsection{Tuple constructors} +* * +************************************************************************ +-} + +-- $big_tuples +-- #big_tuples# +-- +-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but +-- we might concievably want to build such a massive tuple as part of the +-- output of a desugaring stage (notably that for list comprehensions). +-- +-- We call tuples above this size \"big tuples\", and emulate them by +-- creating and pattern matching on >nested< tuples that are expressible +-- by GHC. +-- +-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) +-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any +-- construction to be big. +-- +-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' +-- and 'mkTupleCase' functions to do all your work with tuples you should be +-- fine, and not have to worry about the arity limitation at all. + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + +{- +Creating tuples and their types for Core expressions + +@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. + +* If it has only one element, it is the identity function. + +* If there are more elements than a big tuple can have, it nests + the tuples. +-} + +-- | Build a small tuple holding the specified variables +mkCoreVarTup :: [Id] -> CoreExpr +mkCoreVarTup ids = mkCoreTup (map Var ids) + +-- | Bulid the type of a small tuple that holds the specified variables +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [] = Var unitDataConId +mkCoreTup [c] = c +mkCoreTup cs = mkConApp (tupleCon BoxedTuple (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a big tuple holding the specified variables +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +-- | Build the type of a big tuple that holds the specified variables +mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build a big tuple holding the specified expressions +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup = mkChunkified mkCoreTup + +-- | Build the type of a big tuple that holds the specified type of thing +mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating cases] in SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] + +{- +************************************************************************ +* * +\subsection{Tuple destructors} +* * +************************************************************************ +-} + +-- | Builds a selector which scrutises the given +-- expression and extracts the one name from the list given. +-- If you want the no-shadowing rule to apply, the caller +-- is responsible for making sure that none of these names +-- are in scope. +-- +-- If there is just one 'Id' in the tuple, then the selector is +-- just the identity. +-- +-- If necessary, we pattern match on a \"big\" tuple. +mkTupleSelector :: [Id] -- ^ The 'Id's to pattern match the tuple against + -> Id -- ^ The 'Id' to select + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ^ Selector expression + +-- mkTupleSelector [a,b,c,d] b v e +-- = case e of v { +-- (p,q) -> case p of p { +-- (a,b) -> b }} +-- We use 'tpl' vars for the p,q, since shadowing does not matter. +-- +-- In fact, it's more convenient to generate it innermost first, getting +-- +-- case (case e of v +-- (p,q) -> p) of p +-- (a,b) -> b +mkTupleSelector vars the_var scrut_var scrut + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + the_var `elem` gp ] + +-- | Like 'mkTupleSelector' but for tuples that are guaranteed +-- never to be \"big\". +-- +-- > mkSmallTupleSelector [x] x v e = [| e |] +-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] +mkSmallTupleSelector :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee + -> CoreExpr +mkSmallTupleSelector [var] should_be_the_same_var _ scrut + = ASSERT(var == should_be_the_same_var) + scrut +mkSmallTupleSelector vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var (idType the_var) + [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] + +-- | A generalization of 'mkTupleSelector', allowing the body +-- of the case to be an arbitrary expression. +-- +-- To avoid shadowing, we use uniques to invent new variables. +-- +-- If necessary we pattern match on a \"big\" tuple. +mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables + -> [Id] -- ^ The tuple identifiers to pattern match on + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr +-- ToDo: eliminate cases where none of the variables are needed. +-- +-- mkTupleCase uniqs [a,b,c,d] body v e +-- = case e of v { (p,q) -> +-- case p of p { (a,b) -> +-- case q of q { (c,d) -> +-- body }}} +mkTupleCase uniqs vars body scrut_var scrut + = mk_tuple_case uniqs (chunkify vars) body + where + -- This is the case where don't need any nesting + mk_tuple_case _ [vars] body + = mkSmallTupleCase vars body scrut_var scrut + + -- This is the case where we must make nest tuples at least once + mk_tuple_case us vars_s body + = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s + in mk_tuple_case us' (chunkify vars') body' + + one_tuple_case chunk_vars (us, vs, body) + = let (uniq, us') = takeUniqFromSupply us + scrut_var = mkSysLocal (fsLit "ds") uniq + (mkBoxedTupleTy (map idType chunk_vars)) + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + in (us', scrut_var:vs, body') + +-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed +-- not to need nesting. +mkSmallTupleCase + :: [Id] -- ^ The tuple args + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut +-- One branch no refinement? + = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)] + +{- +************************************************************************ +* * +\subsection{Common list manipulation expressions} +* * +************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. +-} + +-- | Makes a list @[]@ for lists of the specified type +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = mkConApp nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] + +-- | Make a list containing the given expressions, where the list has the given type +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +-- | Make a fully applied 'foldr' expression +mkFoldrExpr :: MonadThings m + => Type -- ^ Element type of the list + -> Type -- ^ Fold result type + -> CoreExpr -- ^ "Cons" function expression for the fold + -> CoreExpr -- ^ "Nil" expression for the fold + -> CoreExpr -- ^ List expression being folded acress + -> m CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- lookupId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +-- | Make a 'build' expression applied to a locally-bound worker function +mkBuildExpr :: (MonadThings m, MonadUnique m) + => Type -- ^ Type of list elements to be built + -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's + -- of the binders for the build worker function, returns + -- the body of that worker + -> m CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + [n_tyvar] <- newTyVars [alphaTyVar] + let n_ty = mkTyVarTy n_tyvar + c_ty = mkFunTys [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- lookupId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + where + newTyVars tyvar_tmpls = do + uniqs <- getUniquesM + return (zipWith setTyVarUnique tyvar_tmpls uniqs) + +{- +************************************************************************ +* * + Error expressions +* * +************************************************************************ +-} + +mkRuntimeErrorApp + :: Id -- Should be of type (forall a. Addr# -> a) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [Type res_ty, err_string] + where + err_string = Lit (mkMachString err_msg) + +mkImpossibleExpr :: Type -> CoreExpr +mkImpossibleExpr res_ty + = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" + +{- +************************************************************************ +* * + Error Ids +* * +************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. +-} + +errorIds :: [Id] +errorIds + = [ eRROR_ID, -- This one isn't used anywhere else in the compiler + -- But we still need it in wiredInIds so that when GHC + -- compiles a program that mentions 'error' we don't + -- import its type from the interface file; we just get + -- the Id defined here. Which has an 'open-tyvar' type. + + uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it + -- an 'open-tyvar' type. + + rUNTIME_ERROR_ID, + iRREFUT_PAT_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, + aBSENT_ERROR_ID ] + +recSelErrorName, runtimeErrorName, absentErrorName :: Name +irrefutPatErrorName, recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID + +noMethodBindingErrorName = err_nm "noMethodBindingError" + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID + +err_nm :: String -> Unique -> Id -> Name +err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id + +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +aBSENT_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName + +mkRuntimeErrorId :: Name -> Id +mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy + +runtimeErrorTy :: Type +-- The runtime error Ids take a UTF8-encoded string as argument +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) + +errorName :: Name +errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID + +eRROR_ID :: Id +eRROR_ID = pc_bottoming_Id1 errorName errorTy + +errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) + +undefinedName :: Name +undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID + +uNDEFINED_ID :: Id +uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy + +undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] +undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy + +{- +Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (a::OpenKind). String -> a + undefined :: forall (a::OpenKind). a +Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that +"error" can be instantiated at + * unboxed as well as boxed types + * polymorphic types +This is OK because it never returns, so the return type is irrelevant. +See Note [OpenTypeKind accepts foralls] in TcUnify. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ +-} + +pc_bottoming_Id1 :: Name -> Type -> Id +-- Function of arity 1, which diverges after being given one argument +pc_bottoming_Id1 name ty + = mkVanillaGlobalWithInfo name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `setArityInfo` 1 + -- Make arity and strictness agree + + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + + strict_sig = mkClosedStrictSig [evalDmd] botRes + -- These "bottom" out, no matter what their arguments + +pc_bottoming_Id0 :: Name -> Type -> Id +-- Same but arity zero +pc_bottoming_Id0 name ty + = mkVanillaGlobalWithInfo name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + strict_sig = mkClosedStrictSig [] botRes diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs new file mode 100644 index 00000000..59c52145 --- /dev/null +++ b/compiler/coreSyn/PprCore.hs @@ -0,0 +1,533 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PprCore ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprRules + ) where + +import CoreSyn +import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) +import Var +import Id +import IdInfo +import Demand +import DataCon +import TyCon +import Type +import Coercion +import DynFlags +import BasicTypes +import Util +import Outputable +import FastString +import SrcLoc ( pprUserRealSpan ) + +{- +************************************************************************ +* * +\subsection{Public interfaces for Core printing (excluding instances)} +* * +************************************************************************ + +@pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} + +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc + +pprCoreBindings = pprTopBinds +pprCoreBinding = pprTopBind + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc +pprTopBinds binds = vcat (map pprTopBind binds) + +pprTopBind :: OutputableBndr a => Bind a -> SDoc +pprTopBind (NonRec binder expr) + = ppr_binding (binder,expr) $$ blankLine + +pprTopBind (Rec []) + = ptext (sLit "Rec { }") +pprTopBind (Rec (b:bs)) + = vcat [ptext (sLit "Rec {"), + ppr_binding b, + vcat [blankLine $$ ppr_binding b | b <- bs], + ptext (sLit "end Rec }"), + blankLine] + +ppr_bind :: OutputableBndr b => Bind b -> SDoc + +ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) +ppr_bind (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding bind <> semi + +ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc +ppr_binding (val_bdr, expr) + = pprBndr LetBind val_bdr $$ + hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +ppr_expr _ (Var name) = ppr name +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) +ppr_expr add_par (Lit lit) = pprLiteral add_par lit + +ppr_expr add_par (Cast expr co) + = add_par $ + sep [pprParendExpr expr, + ptext (sLit "`cast`") <+> pprCo co] + where + pprCo co = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressCoercions dflags + then ptext (sLit "...") + else parens $ + sep [ppr co, dcolon <+> ppr (coercionType co)] + + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(App {}) + = case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) + in + case fun of + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated && isTupleTyCon tc + -> tupleParens (tupleTyConSort tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> add_par (hang (ppr f) 2 pp_args) + + _ -> add_par (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprCaseAsLet dflags + then add_par $ -- See Note [Print case as let] + sep [ sep [ ptext (sLit "let! {") + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") <+> ppr_expr id expr + <+> ptext (sLit "} in") ] + , pprCoreExpr rhs + ] + else add_par $ + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, + ifPprDebug (braces (ppr ty)), + sep [ptext (sLit "of") <+> ppr_bndr var, + char '{' <+> ppr_case_pat con args <+> arrow] + ], + pprCoreExpr rhs, + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + +ppr_expr add_par (Case expr var ty alts) + = add_par $ + sep [sep [ptext (sLit "case") + <+> pprCoreExpr expr + <+> ifPprDebug (braces (ppr ty)), + ptext (sLit "of") <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + ptext (sLit "} in"), + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (ptext (sLit "let {")) + 2 (hsep [ppr_binding (val_bdr,rhs), + ptext (sLit "} in")]) + $$ + pprCoreExpr expr) +-} + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), + pprCoreExpr expr] + where + keyword = case bind of + Rec _ -> (sLit "letrec {") + NonRec _ _ -> (sLit "let {") + +ppr_expr add_par (Tick tickish expr) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprShowTicks dflags + then add_par (sep [ppr tickish, pprCoreExpr expr]) + else ppr_expr add_par expr + +pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) + +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args + | isTupleTyCon tc + = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args))) + where + ppr_bndr = pprBndr CaseBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CaseBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressTypeApplications dflags + then empty + else ptext (sLit "@") <+> pprParendType ty +pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co +pprArg expr = pprParendExpr expr + +{- +Note [Print case as let] +~~~~~~~~~~~~~~~~~~~~~~~~ +Single-branch case expressions are very common: + case x of y { I# x' -> + case p of q { I# p' -> ... } } +These are, in effect, just strict let's, with pattern matching. +With -dppr-case-as-let we print them as such: + let! { I# x' ~ y <- x } in + let! { I# p' ~ q <- p } in ... + + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. +-} + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + +pprCoreBinder :: BindingSite -> Var -> SDoc +pprCoreBinder LetBind binder + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder bind_site bndr + = getPprStyle $ \ sty -> + pprTypedLamBinder bind_site (debugStyle sty) bndr + +pprUntypedBinder :: Var -> SDoc +pprUntypedBinder binder + | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | otherwise = pprIdBndr binder + +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc +-- For lambda and case binders, show the unfolding info (usually none) +pprTypedLamBinder bind_site debug_on var + = sdocWithDynFlags $ \dflags -> + case () of + _ + | not debug_on -- Even dead binders can be one-shot + , isDeadBinder var -> char '_' <+> ppWhen (isId var) + (pprIdBndrInfo (idInfo var)) + + | not debug_on -- No parens, no kind info + , CaseBind <- bind_site -> pprUntypedBinder var + + | suppress_sigs dflags -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + suppress_sigs = gopt Opt_SuppressTypeSignatures + + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocWithDynFlags $ \dflags -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = ptext (sLit "@") <+> pprTvBndr tyvar + +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr :: Id -> SDoc +pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) + +pprIdBndrInfo :: IdInfo -> SDoc +pprIdBndrInfo info + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressIdInfo dflags + then empty + else megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes + where + prag_info = inlinePragInfo info + occ_info = occInfo info + dmd_info = demandInfo info + lbv_info = oneShotInfo info + + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOcc occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info) + ] + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressIdInfo dflags + then empty + else + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, ptext (sLit "Arity=") <> int arity) + , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity) + , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) + , (True, ptext (sLit "Str=") <> pprStrictness str_info) + , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) + , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr + where + pp_scope | isGlobalId id = ptext (sLit "GblId") + | isExportedId id = ptext (sLit "LclIdX") + | otherwise = ptext (sLit "LclId") + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = specInfoRules (specInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] + +{- +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- +-} + +instance Outputable UnfoldingGuidance where + ppr UnfNever = ptext (sLit "NEVER") + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = ptext (sLit "ALWAYS_IF") <> + parens (ptext (sLit "arity=") <> int arity <> comma <> + ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <> + ptext (sLit "boring_ok=") <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ ptext (sLit "IF_ARGS"), + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = ptext (sLit "Compulsory") + ppr InlineStable = ptext (sLit "InlineStable") + ppr InlineRhs = ptext (sLit "") + +instance Outputable Unfolding where + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_work_free=wf + , uf_expandable=exp, uf_guidance=g }) + = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ ptext (sLit "Src=") <> ppr src + , ptext (sLit "TopLvl=") <> ppr top + , ptext (sLit "Value=") <> ppr hnf + , ptext (sLit "ConLike=") <> ppr conlike + , ptext (sLit "WorkFree=") <> ppr wf + , ptext (sLit "Expandable=") <> ppr exp + , ptext (sLit "Guidance=") <> ppr g ] + pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +{- +----------------------------------------------------- +-- Rules +----------------------------------------------------- +-} + +instance Outputable CoreRule where + ppr = pprRule + +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) + +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) + +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [ptext (sLit "forall") <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable id => Outputable (Tickish id) where + ppr (HpcTick modl ix) = + hcat [ptext (sLit "hpc<"), + ppr modl, comma, + ppr ix, + ptext (sLit ">")] + ppr (Breakpoint ix vars) = + hcat [ptext (sLit "break<"), + ppr ix, + ptext (sLit ">"), + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] + (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] + _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] + ppr (SourceNote span _) = + hcat [ ptext (sLit "src<"), pprUserRealSpan True span, char '>'] + +{- +----------------------------------------------------- +-- Vectorisation declarations +----------------------------------------------------- +-} + +instance Outputable CoreVect where + ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') + 4 (pprCoreExpr e) + ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var + ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var + ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var + ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+> + ppr tc + ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> + char '=' <+> ppr tc + ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc + ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/TrieMap.hs new file mode 100644 index 00000000..efae2865 --- /dev/null +++ b/compiler/coreSyn/TrieMap.hs @@ -0,0 +1,839 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE RankNTypes, TypeFamilies #-} +module TrieMap( + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + CoercionMap, + MaybeMap, + ListMap, + TrieMap(..), insertTM, deleteTM, + lookupTypeMapTyCon + ) where + +import CoreSyn +import Coercion +import Literal +import Name +import Type +import TypeRep +import TyCon(TyCon) +import Var +import UniqFM +import Unique( Unique ) +import FastString(FastString) +import CoAxiom(CoAxiomRule(coaxrName)) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import VarEnv +import NameEnv +import Outputable +import Control.Monad( (>=>) ) + +{- +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: * + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + mapTM :: (a->b) -> m a -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.fold k z m + mapTM f m = IntMap.map f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.fold k z m + mapTM f m = Map.map f m + +instance TrieMap UniqFM where + type Key UniqFM = Unique + emptyTM = emptyUFM + lookupTM k m = lookupUFM m k + alterTM k f m = alterUFM f m k + foldTM k m z = foldUFM k z m + mapTM f m = mapUFM f m + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + mapTM = mapMb + +mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b +mapMb f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } + +lkMaybe :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +-------------------- +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + mapTM = mapList + +mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b +mapList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +{- +************************************************************************ +* * + Basic maps +* * +************************************************************************ +-} + +lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a +lkNamed n env = lookupNameEnv env (getName n) + +xtNamed :: NamedThing n => n -> XT a -> NameEnv a -> NameEnv a +xtNamed tc f m = alterNameEnv f m (getName tc) + +------------------------ +type LiteralMap a = Map.Map Literal a + +emptyLiteralMap :: LiteralMap a +emptyLiteralMap = emptyTM + +lkLit :: Literal -> LiteralMap a -> Maybe a +lkLit = lookupTM + +xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a +xtLit = alterTM + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ + +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMap (TypeMap a) + rather than + cm_lam :: TypeMap (CoreMap a) + + * We don't need to look at the type of some binders, notalby + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (Trac #6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecesary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in CoreSyn. +-} + +data CoreMap a + = EmptyCM + | CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMap a + , cm_type :: TypeMap a + , cm_cast :: CoreMap (CoercionMap a) + , cm_tick :: CoreMap (TickishMap a) + , cm_app :: CoreMap (CoreMap a) + , cm_lam :: CoreMap (TypeMap a) -- Note [Binders] + , cm_letn :: CoreMap (CoreMap (BndrMap a)) + , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) + , cm_case :: CoreMap (ListMap AltMap a) + , cm_ecase :: CoreMap (TypeMap a) -- Note [Empty case alternatives] + } + + +wrapEmptyCM :: CoreMap a +wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_ecase = emptyTM, cm_tick = emptyTM } + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = EmptyCM + lookupTM = lkE emptyCME + alterTM = xtE emptyCME + foldTM = fdE + mapTM = mapE + +-------------------------- +mapE :: (a->b) -> CoreMap a -> CoreMap b +mapE _ EmptyCM = EmptyCM +mapE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit + , cm_co = mapTM f cco, cm_type = mapTM f ctype + , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp + , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn + , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase + , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lkE emptyCME e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = xtE emptyCME e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = fdE k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = EmptyCM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldCoreMap (:) [] m) + +------------------------- +fdE :: (a -> b -> b) -> CoreMap a -> b -> b +fdE _ EmptyCM = \z -> z +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_tick m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) + +lkE :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a +-- lkE: lookup in trie for expressions +lkE env expr cm + | EmptyCM <- cm = Nothing + | otherwise = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lkLit l + go (Type t) = cm_type >.> lkT env t + go (Coercion c) = cm_co >.> lkC env c + go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c + go (Tick tickish e) = cm_tick >.> lkE env e >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 + go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkE env r + >=> lkE (extendCME env b) e >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkE env1) rhss >=> lkE env1 e + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkE env e >=> lkT env ty + | otherwise = cm_case >.> lkE env e + >=> lkList (lkA (extendCME env b)) as + +xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a +xtE env e f EmptyCM = xtE env e f wrapEmptyCM +xtE env (Var v) f m = m { cm_var = cm_var m |> xtVar env v f } +xtE env (Type t) f m = m { cm_type = cm_type m |> xtT env t f } +xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } +xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } +xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> + xtC env c f } +xtE env (Tick t e) f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f } +xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } +xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e + |>> xtBndr env v f } +xtE env (Let (NonRec b r) e) f m = m { cm_letn = cm_letn m + |> xtE (extendCME env b) e + |>> xtE env r |>> xtBndr env b f } +xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtE env1) rhss + |>> xtE env1 e + |>> xtList (xtBndr env1) bndrs f } +xtE env (Case e b ty as) f m + | null as = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f } + | otherwise = m { cm_case = cm_case m |> xtE env e + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +type TickishMap a = Map.Map (Tickish Id) a +lkTickish :: Tickish Id -> TickishMap a -> Maybe a +lkTickish = lookupTM + +xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a +xtTickish = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMap a + , am_data :: NameEnv (CoreMap a) + , am_lit :: LiteralMap (CoreMap a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyNameEnv + , am_lit = emptyLiteralMap } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + mapTM = mapA + +mapA :: (a->b) -> AltMap a -> AltMap b +mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapTM f adeflt + , am_data = mapNameEnv (mapTM f) adata + , am_lit = mapTM (mapTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkE env rhs +lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkE env rhs +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkNamed dc >=> lkE (extendCMEs env bs) rhs + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (DEFAULT, _, rhs) f m = m { am_deflt = am_deflt m |> xtE env rhs f } +xtA env (LitAlt l, _, rhs) f m = m { am_lit = am_lit m |> xtLit l |>> xtE env rhs f } +xtA env (DataAlt d, bs, rhs) f m = m { am_data = am_data m |> xtNamed d + |>> xtE (extendCMEs env bs) rhs f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +data CoercionMap a + = EmptyKM + | KM { km_refl :: RoleMap (TypeMap a) + , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a)) + , km_app :: CoercionMap (CoercionMap a) + , km_forall :: CoercionMap (TypeMap a) + , km_var :: VarMap a + , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a)) + , km_univ :: RoleMap (TypeMap (TypeMap a)) + , km_sym :: CoercionMap a + , km_trans :: CoercionMap (CoercionMap a) + , km_nth :: IntMap.IntMap (CoercionMap a) + , km_left :: CoercionMap a + , km_right :: CoercionMap a + , km_inst :: CoercionMap (TypeMap a) + , km_sub :: CoercionMap a + , km_axiom_rule :: Map.Map FastString + (ListMap TypeMap (ListMap CoercionMap a)) + } + +wrapEmptyKM :: CoercionMap a +wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM + , km_app = emptyTM, km_forall = emptyTM + , km_var = emptyTM, km_axiom = emptyNameEnv + , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM + , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM + , km_inst = emptyTM, km_sub = emptyTM + , km_axiom_rule = emptyTM } + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = EmptyKM + lookupTM = lkC emptyCME + alterTM = xtC emptyCME + foldTM = fdC + mapTM = mapC + +mapC :: (a->b) -> CoercionMap a -> CoercionMap b +mapC _ EmptyKM = EmptyKM +mapC f (KM { km_refl = krefl, km_tc_app = ktc + , km_app = kapp, km_forall = kforall + , km_var = kvar, km_axiom = kax + , km_univ = kuniv , km_sym = ksym, km_trans = ktrans + , km_nth = knth, km_left = kml, km_right = kmr + , km_inst = kinst, km_sub = ksub + , km_axiom_rule = kaxr }) + = KM { km_refl = mapTM (mapTM f) krefl + , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc + , km_app = mapTM (mapTM f) kapp + , km_forall = mapTM (mapTM f) kforall + , km_var = mapTM f kvar + , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax + , km_univ = mapTM (mapTM (mapTM f)) kuniv + , km_sym = mapTM f ksym + , km_trans = mapTM (mapTM f) ktrans + , km_nth = IntMap.map (mapTM f) knth + , km_left = mapTM f kml + , km_right = mapTM f kmr + , km_inst = mapTM (mapTM f) kinst + , km_sub = mapTM f ksub + , km_axiom_rule = mapTM (mapTM (mapTM f)) kaxr + } + +lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a +lkC env co m + | EmptyKM <- m = Nothing + | otherwise = go co m + where + go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty + go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs + go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs + go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2 + go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2 + + -- the provenance is not used in the map + go (UnivCo _ r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2 + go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t + go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v + go (CoVarCo v) = km_var >.> lkVar env v + go (SymCo c) = km_sym >.> lkC env c + go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c + go (LRCo CLeft c) = km_left >.> lkC env c + go (LRCo CRight c) = km_right >.> lkC env c + go (SubCo c) = km_sub >.> lkC env c + go (AxiomRuleCo co ts cs) = km_axiom_rule >.> + lookupTM (coaxrName co) >=> + lkList (lkT env) ts >=> + lkList (lkC env) cs + + +xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a +xtC env co f EmptyKM = xtC env co f wrapEmptyKM +xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f } +xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f } +xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f } +xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f } +xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f } +-- the provenance is not used in the map +xtC env (UnivCo _ r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f } +xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } +xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c + |>> xtBndr env v f } +xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } +xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } +xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } +xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } +xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f } +xtC env (AxiomRuleCo co ts cs) f m = m { km_axiom_rule = km_axiom_rule m + |> alterTM (coaxrName co) + |>> xtList (xtT env) ts + |>> xtList (xtC env) cs f} + +fdC :: (a -> b -> b) -> CoercionMap a -> b -> b +fdC _ EmptyKM = \z -> z +fdC k m = foldTM (foldTM k) (km_refl m) + . foldTM (foldTM (foldTM k)) (km_tc_app m) + . foldTM (foldTM k) (km_app m) + . foldTM (foldTM k) (km_forall m) + . foldTM k (km_var m) + . foldTM (foldTM (foldTM k)) (km_axiom m) + . foldTM (foldTM (foldTM k)) (km_univ m) + . foldTM k (km_sym m) + . foldTM (foldTM k) (km_trans m) + . foldTM (foldTM k) (km_nth m) + . foldTM k (km_left m) + . foldTM k (km_right m) + . foldTM (foldTM k) (km_inst m) + . foldTM k (km_sub m) + . foldTM (foldTM (foldTM k)) (km_axiom_rule m) + +newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } + +instance TrieMap RoleMap where + type Key RoleMap = Role + emptyTM = RM emptyTM + lookupTM = lkR + alterTM = xtR + foldTM = fdR + mapTM = mapR + +lkR :: Role -> RoleMap a -> Maybe a +lkR Nominal = lookupTM 1 . unRM +lkR Representational = lookupTM 2 . unRM +lkR Phantom = lookupTM 3 . unRM + +xtR :: Role -> XT a -> RoleMap a -> RoleMap a +xtR Nominal f = RM . alterTM 1 f . unRM +xtR Representational f = RM . alterTM 2 f . unRM +xtR Phantom f = RM . alterTM 3 f . unRM + +fdR :: (a -> b -> b) -> RoleMap a -> b -> b +fdR f (RM m) = foldTM f m + +mapR :: (a -> b) -> RoleMap a -> RoleMap b +mapR f = RM . mapTM f . unRM + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +data TypeMap a + = EmptyTM + | TM { tm_var :: VarMap a + , tm_app :: TypeMap (TypeMap a) + , tm_fun :: TypeMap (TypeMap a) + , tm_tc_app :: NameEnv (ListMap TypeMap a) + , tm_forall :: TypeMap (BndrMap a) + , tm_tylit :: TyLitMap a + } + + +instance Outputable a => Outputable (TypeMap a) where + ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = fdT k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = EmptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lkT emptyCME t cm + +-- Returns the type map entries that have keys starting with the given tycon. +-- This only considers saturated applications (i.e. TyConApp ones). +lookupTypeMapTyCon :: TypeMap a -> TyCon -> [a] +lookupTypeMapTyCon EmptyTM _ = [] +lookupTypeMapTyCon TM { tm_tc_app = cs } tc = + case lookupUFM cs tc of + Nothing -> [] + Just xs -> foldTM (:) xs [] + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = xtT emptyCME t (\_ -> Just v) m + +wrapEmptyTypeMap :: TypeMap a +wrapEmptyTypeMap = TM { tm_var = emptyTM + , tm_app = EmptyTM + , tm_fun = EmptyTM + , tm_tc_app = emptyNameEnv + , tm_forall = EmptyTM + , tm_tylit = emptyTyLitMap } + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = EmptyTM + lookupTM = lkT emptyCME + alterTM = xtT emptyCME + foldTM = fdT + mapTM = mapT + +mapT :: (a->b) -> TypeMap a -> TypeMap b +mapT _ EmptyTM = EmptyTM +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_fun = tfun + , tm_tc_app = ttcapp, tm_forall = tforall, tm_tylit = tlit }) + = TM { tm_var = mapTM f tvar + , tm_app = mapTM (mapTM f) tapp + , tm_fun = mapTM (mapTM f) tfun + , tm_tc_app = mapNameEnv (mapTM f) ttcapp + , tm_forall = mapTM (mapTM f) tforall + , tm_tylit = mapTM f tlit } + +----------------- +lkT :: CmEnv -> Type -> TypeMap a -> Maybe a +lkT env ty m + | EmptyTM <- m = Nothing + | otherwise = go ty m + where + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 + go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 + go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv + + +----------------- +xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a +xtT env ty f m + | EmptyTM <- m = xtT env ty f wrapEmptyTypeMap + | Just ty' <- coreView ty = xtT env ty' f m + +xtT env (TyVarTy v) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT env (AppTy t1 t2) f m = m { tm_app = tm_app m |> xtT env t1 |>> xtT env t2 f } +xtT env (FunTy t1 t2) f m = m { tm_fun = tm_fun m |> xtT env t1 |>> xtT env t2 f } +xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME env tv) ty + |>> xtBndr env tv f } +xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc + |>> xtList (xtT env) tys f } +xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } + +fdT :: (a -> b -> b) -> TypeMap a -> b -> b +fdT _ EmptyTM = \z -> z +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM (foldTM k) (tm_fun m) + . foldTM (foldTM k) (tm_tc_app m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + + + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +instance TrieMap TyLitMap where + type Key TyLitMap = TyLit + emptyTM = emptyTyLitMap + lookupTM = lkTyLit + alterTM = xtTyLit + foldTM = foldTyLit + mapTM = mapTyLit + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b +mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) + = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.fold l) (tlm_string m) + . flip (Map.fold l) (tlm_number m) + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +--------- Variable binders ------------- + +-- | A 'BndrMap' is a 'TypeMap' which allows us to distinguish between +-- binding forms whose binders have different types. For example, +-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should +-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: +-- we can disambiguate this by matching on the type (or kind, if this +-- a binder in a type) of the binder. +type BndrMap = TypeMap + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v m = lkT env (varType v) m + +xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v f = xtT env (varType v) f + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: VarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + mapTM = mapVar + +mapVar :: (a->b) -> VarMap a -> VarMap b +mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapTM f bv, vm_fvar = mapVarEnv f fv } + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> xtInt bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkFreeVar :: Var -> VarEnv a -> Maybe a +lkFreeVar var env = lookupVarEnv env var + +xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a +xtFreeVar v f m = alterVarEnv f m v diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs new file mode 100644 index 00000000..3d53e698 --- /dev/null +++ b/compiler/deSugar/Check.hs @@ -0,0 +1,773 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +Author: Juan J. Quintela +-} + +{-# LANGUAGE CPP #-} + +module Check ( check , ExhaustivePat ) where + +#include "HsVersions.h" + +import HsSyn +import TcHsSyn +import DsUtils +import MatchLit +import Id +import ConLike +import DataCon +import PatSyn +import Name +import TysWiredIn +import PrelNames +import TyCon +import SrcLoc +import UniqSet +import Util +import BasicTypes +import Outputable +import FastString + +{- +This module performs checks about if one list of equations are: +\begin{itemize} +\item Overlapped +\item Non exhaustive +\end{itemize} +To discover that we go through the list of equations in a tree-like fashion. + +If you like theory, a similar algorithm is described in: +\begin{quotation} + {\em Two Techniques for Compiling Lazy Pattern Matching}, + Luc Maranguet, + INRIA Rocquencourt (RR-2385, 1994) +\end{quotation} +The algorithm is based on the first technique, but there are some differences: +\begin{itemize} +\item We don't generate code +\item We have constructors and literals (not only literals as in the + article) +\item We don't use directions, we must select the columns from + left-to-right +\end{itemize} +(By the way the second technique is really similar to the one used in + @Match.lhs@ to generate code) + +This function takes the equations of a pattern and returns: +\begin{itemize} +\item The patterns that are not recognized +\item The equations that are not overlapped +\end{itemize} +It simplify the patterns and then call @check'@ (the same semantics), and it +needs to reconstruct the patterns again .... + +The problem appear with things like: +\begin{verbatim} + f [x,y] = .... + f (x:xs) = ..... +\end{verbatim} +We want to put the two patterns with the same syntax, (prefix form) and +then all the constructors are equal: +\begin{verbatim} + f (: x (: y [])) = .... + f (: x xs) = ..... +\end{verbatim} +(more about that in @tidy_eqns@) + +We would prefer to have a @WarningPat@ of type @String@, but Strings and the +Pretty Printer are not friends. + +We use @InPat@ in @WarningPat@ instead of @OutPat@ +because we need to print the +warning messages in the same way they are introduced, i.e. if the user +wrote: +\begin{verbatim} + f [x,y] = .. +\end{verbatim} +He don't want a warning message written: +\begin{verbatim} + f (: x (: y [])) ........ +\end{verbatim} +Then we need to use InPats. +\begin{quotation} + Juan Quintela 5 JUL 1998\\ + User-friendliness and compiler writers are no friends. +\end{quotation} +-} + +type WarningPat = InPat Name +type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) +type EqnNo = Int +type EqnSet = UniqSet EqnNo + + +check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) + -- Second result is the shadowed equations + -- if there are view patterns, just give up - don't know what the function is +check qs = (untidy_warns, shadowed_eqns) + where + tidy_qs = map tidy_eqn qs + (warns, used_nos) = check' ([1..] `zip` tidy_qs) + untidy_warns = map untidy_exhaustive warns + shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], + not (i `elementOfUniqSet` used_nos)] + +untidy_exhaustive :: ExhaustivePat -> ExhaustivePat +untidy_exhaustive ([pat], messages) = + ([untidy_no_pars pat], map untidy_message messages) +untidy_exhaustive (pats, messages) = + (map untidy_pars pats, map untidy_message messages) + +untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) +untidy_message (string, lits) = (string, map untidy_lit lits) + +-- The function @untidy@ does the reverse work of the @tidy_pat@ function. + +type NeedPars = Bool + +untidy_no_pars :: WarningPat -> WarningPat +untidy_no_pars p = untidy False p + +untidy_pars :: WarningPat -> WarningPat +untidy_pars p = untidy True p + +untidy :: NeedPars -> WarningPat -> WarningPat +untidy b (L loc p) = L loc (untidy' b p) + where + untidy' _ p@(WildPat _) = p + untidy' _ p@(VarPat _) = p + untidy' _ (LitPat lit) = LitPat (untidy_lit lit) + untidy' _ p@(ConPatIn _ (PrefixCon [])) = p + untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) + untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing + untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys + untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" + untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" + untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" + untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" + untidy' _ (AsPat {}) = panic "Check.untidy: AsPat" + untidy' _ (ParPat {}) = panic "Check.untidy: ParPat" + untidy' _ (BangPat {}) = panic "Check.untidy: BangPat" + untidy' _ (ConPatOut {}) = panic "Check.untidy: ConPatOut" + untidy' _ (ViewPat {}) = panic "Check.untidy: ViewPat" + untidy' _ (SplicePat {}) = panic "Check.untidy: SplicePat" + untidy' _ (QuasiQuotePat {}) = panic "Check.untidy: QuasiQuotePat" + untidy' _ (NPat {}) = panic "Check.untidy: NPat" + untidy' _ (NPlusKPat {}) = panic "Check.untidy: NPlusKPat" + untidy' _ (SigPatOut {}) = panic "Check.untidy: SigPatOut" + untidy' _ (CoPat {}) = panic "Check.untidy: CoPat" + +untidy_con :: HsConPatDetails Name -> HsConPatDetails Name +untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) +untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) +untidy_con (RecCon (HsRecFields flds dd)) + = RecCon (HsRecFields [ L l (fld { hsRecFieldArg + = untidy_pars (hsRecFieldArg fld) }) + | L l fld <- flds ] dd) + +pars :: NeedPars -> WarningPat -> Pat Name +pars True p = ParPat p +pars _ p = unLoc p + +untidy_lit :: HsLit -> HsLit +untidy_lit (HsCharPrim src c) = HsChar src c +untidy_lit lit = lit + +{- +This equation is the same that check, the only difference is that the +boring work is done, that work needs to be done only once, this is +the reason top have two functions, check is the external interface, +@check'@ is called recursively. + +There are several cases: + +\begin{itemize} +\item There are no equations: Everything is OK. +\item There are only one equation, that can fail, and all the patterns are + variables. Then that equation is used and the same equation is + non-exhaustive. +\item All the patterns are variables, and the match can fail, there are + more equations then the results is the result of the rest of equations + and this equation is used also. + +\item The general case, if all the patterns are variables (here the match + can't fail) then the result is that this equation is used and this + equation doesn't generate non-exhaustive cases. + +\item In the general case, there can exist literals ,constructors or only + vars in the first column, we actuate in consequence. + +\end{itemize} +-} + +check' :: [(EqnNo, EquationInfo)] + -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all + EqnSet) -- Eqns that are used (others are overlapped) + +check' [] = ([],emptyUniqSet) + -- Was ([([],[])], emptyUniqSet) + -- But that (a) seems weird, and (b) triggered Trac #7669 + -- So now I'm just doing the simple obvious thing + +check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) + | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False } + = ([], unitUniqSet n) -- One eqn, which can't fail + + | first_eqn_all_vars && null rs -- One eqn, but it can fail + = ([(takeList ps (repeat nlWildPatName),[])], unitUniqSet n) + + | first_eqn_all_vars -- Several eqns, first can fail + = (pats, addOneToUniqSet indexs n) + where + first_eqn_all_vars = all_vars ps + (pats,indexs) = check' rs + +check' qs + | some_literals = split_by_literals qs + | some_constructors = split_by_constructor qs + | only_vars = first_column_only_vars qs + | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) + -- Shouldn't happen + where + -- Note: RecPats will have been simplified to ConPats + -- at this stage. + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs + some_constructors = any is_con first_pats + some_literals = any is_lit first_pats + only_vars = all is_var first_pats + +{- +Here begins the code to deal with literals, we need to split the matrix +in different matrix beginning by each literal and a last matrix with the +rest of values. +-} + +split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +split_by_literals qs = process_literals used_lits qs + where + used_lits = get_used_lits qs + +{- +@process_explicit_literals@ is a function that process each literal that appears +in the column of the matrix. +-} + +process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) + where + pats_indexs = map (\x -> construct_literal_matrix x qs) lits + (pats,indexs) = unzip pats_indexs + +{- +@process_literals@ calls @process_explicit_literals@ to deal with the literals +that appears in the matrix and deal also with the rest of the cases. It +must be one Variable to be complete. +-} + +process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +process_literals used_lits qs + | null default_eqns = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs) + | otherwise = (pats_default,indexs_default) + where + (pats,indexs) = process_explicit_literals used_lits qs + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + [remove_var q | q <- qs, is_var (firstPatN q)] + (pats',indexs') = check' default_eqns + pats_default = [(nlWildPatName:ps,constraints) | + (ps,constraints) <- (pats')] ++ pats + indexs_default = unionUniqSets indexs' indexs + +{- +Here we have selected the literal and we will select all the equations that +begins for that literal and create a new matrix. +-} + +construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +construct_literal_matrix lit qs = + (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) + where + (pats,indexs) = (check' (remove_first_column_lit lit qs)) + new_lit = nlLitPat lit + +remove_first_column_lit :: HsLit + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] +remove_first_column_lit lit qs + = ASSERT2( okGroup qs, pprGroup qs ) + [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)] + where + shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps } + shift_pat _ = panic "Check.shift_var: no patterns" + +{- +This function splits the equations @qs@ in groups that deal with the +same constructor. +-} + +split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +split_by_constructor qs + | null used_cons = ([], mkUniqSet $ map fst qs) + | notNull unused_cons = need_default_case used_cons unused_cons qs + | otherwise = no_need_default_case used_cons qs + where + used_cons = get_used_cons qs + unused_cons = get_unused_cons used_cons + +{- +The first column of the patterns matrix only have vars, then there is +nothing to do. +-} + +first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +first_column_only_vars qs + = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs) + where + (pats, indexs) = check' (map remove_var qs) + +{- +This equation takes a matrix of patterns and split the equations by +constructor, using all the constructors that appears in the first column +of the pattern matching. + +We can need a default clause or not ...., it depends if we used all the +constructors or not explicitly. The reasoning is similar to @process_literals@, +the difference is that here the default case is not always needed. +-} + +no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) + where + pats_indexs = map (\x -> construct_matrix x qs) cons + (pats,indexs) = unzip pats_indexs + +need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +need_default_case used_cons unused_cons qs + | null default_eqns = (pats_default_no_eqns,indexs) + | otherwise = (pats_default,indexs_default) + where + (pats,indexs) = no_need_default_case used_cons qs + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + [remove_var q | q <- qs, is_var (firstPatN q)] + (pats',indexs') = check' default_eqns + pats_default = [(make_whole_con c:ps,constraints) | + c <- unused_cons, (ps,constraints) <- pats'] ++ pats + new_wilds = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs) + pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats + indexs_default = unionUniqSets indexs' indexs + +construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +construct_matrix con qs = + (map (make_con con) pats,indexs) + where + (pats,indexs) = (check' (remove_first_column con qs)) + +{- +Here remove first column is more difficult that with literals due to the fact +that constructors can have arguments. + +For instance, the matrix +\begin{verbatim} + (: x xs) y + z y +\end{verbatim} +is transformed in: +\begin{verbatim} + x xs y + _ _ y +\end{verbatim} +-} + +remove_first_column :: Pat Id -- Constructor + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] +remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs + = ASSERT2( okGroup qs, pprGroup qs ) + [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)] + where + new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats] + shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps}) + = eqn { eqn_pats = map unLoc ps' ++ ps } + shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps }) + = eqn { eqn_pats = new_wilds ++ ps } + shift_var _ = panic "Check.Shift_var:No done" +remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut" + +make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat +make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) + = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName) + ,[(new_var,used_lits)]) + where + new_var = hash_x + +hash_x :: Name +hash_x = mkInternalName unboundKey {- doesn't matter much -} + (mkVarOccFS (fsLit "#x")) + noSrcSpan + +make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] +make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) + = takeList (tail pats) (repeat nlWildPatName) + +compare_cons :: Pat Id -> Pat Id -> Bool +compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 }) + = case (con1, con2) of + (RealDataCon id1, RealDataCon id2) -> id1 == id2 + _ -> False +compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon" + +remove_dups :: [Pat Id] -> [Pat Id] +remove_dups [] = [] +remove_dups (x:xs) | any (\y -> compare_cons x y) xs = remove_dups xs + | otherwise = x : remove_dups xs + +get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id] +get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, + isConPatOut pat] + +isConPatOut :: Pat Id -> Bool +isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True +isConPatOut _ = False + +remove_dups' :: [HsLit] -> [HsLit] +remove_dups' [] = [] +remove_dups' (x:xs) | x `elem` xs = remove_dups' xs + | otherwise = x : remove_dups' xs + + +get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit] +get_used_lits qs = remove_dups' all_literals + where + all_literals = get_used_lits' qs + +get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit] +get_used_lits' [] = [] +get_used_lits' (q:qs) + | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs + | otherwise = get_used_lits qs + +get_lit :: Pat id -> Maybe HsLit +-- Get a representative HsLit to stand for the OverLit +-- It doesn't matter which one, because they will only be compared +-- with other HsLits gotten in the same way +get_lit (LitPat lit) = Just lit +get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i})) mb _) + = Just (HsIntPrim src (mb_neg negate mb i)) +get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _) + = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) +get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s })) _ _) + = Just (HsStringPrim src (fastStringToByteString s)) +get_lit _ = Nothing + +mb_neg :: (a -> a) -> Maybe b -> a -> a +mb_neg _ Nothing v = v +mb_neg negate (Just _) v = negate v + +get_unused_cons :: [Pat Id] -> [DataCon] +get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons + where + used_set :: UniqSet DataCon + used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons] + (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons + ty_con = dataConTyCon con1 + unused_cons = filterOut is_used (tyConDataCons ty_con) + is_used con = con `elementOfUniqSet` used_set + || dataConCannotMatch inst_tys con + +all_vars :: [Pat Id] -> Bool +all_vars [] = True +all_vars (WildPat _:ps) = all_vars ps +all_vars _ = False + +remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo) +remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps }) +remove_var _ = panic "Check.remove_var: equation does not begin with a variable" + +----------------------- +eqnPats :: (EqnNo, EquationInfo) -> [Pat Id] +eqnPats (_, eqn) = eqn_pats eqn + +okGroup :: [(EqnNo, EquationInfo)] -> Bool +-- True if all equations have at least one pattern, and +-- all have the same number of patterns +okGroup [] = True +okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] + where + n_pats = length (eqnPats e) + +-- Half-baked print +pprGroup :: [(EqnNo, EquationInfo)] -> SDoc +pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc +pprGroup es = vcat (map pprEqnInfo es) +pprEqnInfo e = ppr (eqnPats e) + + +firstPatN :: (EqnNo, EquationInfo) -> Pat Id +firstPatN (_, eqn) = firstPat eqn + +is_con :: Pat Id -> Bool +is_con (ConPatOut {}) = True +is_con _ = False + +is_lit :: Pat Id -> Bool +is_lit (LitPat _) = True +is_lit (NPat _ _ _) = True +is_lit _ = False + +is_var :: Pat Id -> Bool +is_var (WildPat _) = True +is_var _ = False + +is_var_con :: ConLike -> Pat Id -> Bool +is_var_con _ (WildPat _) = True +is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con +is_var_con _ _ = False + +is_var_lit :: HsLit -> Pat Id -> Bool +is_var_lit _ (WildPat _) = True +is_var_lit lit pat + | Just lit' <- get_lit pat = lit == lit' + | otherwise = False + +{- +The difference beteewn @make_con@ and @make_whole_con@ is that +@make_wole_con@ creates a new constructor with all their arguments, and +@make_con@ takes a list of argumntes, creates the contructor getting their +arguments from the list. See where \fbox{\ ???\ } are used for details. + +We need to reconstruct the patterns (make the constructors infix and +similar) at the same time that we create the constructors. + +You can tell tuple constructors using +\begin{verbatim} + Id.isTupleDataCon +\end{verbatim} +You can see if one constructor is infix with this clearer code :-)))))))))) +\begin{verbatim} + Lex.isLexConSym (Name.occNameString (Name.getOccName con)) +\end{verbatim} + + Rather clumsy but it works. (Simon Peyton Jones) + + +We don't mind the @nilDataCon@ because it doesn't change the way to +print the message, we are searching only for things like: @[1,2,3]@, +not @x:xs@ .... + +In @reconstruct_pat@ we want to ``undo'' the work +that we have done in @tidy_pat@. +In particular: +\begin{tabular}{lll} + @((,) x y)@ & returns to be & @(x, y)@ +\\ @((:) x xs)@ & returns to be & @(x:xs)@ +\\ @(x:(...:[])@ & returns to be & @[x,...]@ +\end{tabular} + +The difficult case is the third one becouse we need to follow all the +contructors until the @[]@ to know that we need to use the second case, +not the second. \fbox{\ ???\ } +-} + +isInfixCon :: DataCon -> Bool +isInfixCon con = isDataSymOcc (getOccName con) + +is_nil :: Pat Name -> Bool +is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon +is_nil _ = False + +is_list :: Pat Name -> Bool +is_list (ListPat _ _ Nothing) = True +is_list _ = False + +return_list :: DataCon -> Pat Name -> Bool +return_list id q = id == consDataCon && (is_nil q || is_list q) + +make_list :: LPat Name -> Pat Name -> Pat Name +make_list p q | is_nil q = ListPat [p] placeHolderType Nothing +make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing +make_list _ _ = panic "Check.make_list: Invalid argument" + +make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat +make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints) + | return_list id q = (noLoc (make_list lp q) : ps, constraints) + | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) + where q = unLoc lq + +make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats}) + (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) []) + : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) + : rest_pats, constraints) + | otherwise = (nlConPatName name pats_con + : rest_pats, constraints) + where + name = getName id + (pats_con, rest_pats) = splitAtList pats ps + tc = dataConTyCon id + +make_con _ _ = panic "Check.make_con: Not ConPatOut" + +-- reconstruct parallel array pattern +-- +-- * don't check for the type only; we need to make sure that we are really +-- dealing with one of the fake constructors and not with the real +-- representation + +make_whole_con :: DataCon -> WarningPat +make_whole_con con | isInfixCon con = nlInfixConPat name + nlWildPatName nlWildPatName + | otherwise = nlConPatName name pats + where + name = getName con + pats = [nlWildPatName | _ <- dataConOrigArgTys con] + +{- +------------------------------------------------------------------------ + Tidying equations +------------------------------------------------------------------------ + +tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@; +that is, it removes syntactic sugar, reducing the number of cases that +must be handled by the main checking algorithm. One difference is +that here we can do *all* the tidying at once (recursively), rather +than doing it incrementally. +-} + +tidy_eqn :: EquationInfo -> EquationInfo +tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn), + eqn_rhs = tidy_rhs (eqn_rhs eqn) } + where + -- Horrible hack. The tidy_pat stuff converts "might-fail" patterns to + -- WildPats which of course loses the info that they can fail to match. + -- So we stick in a CanFail as if it were a guard. + tidy_rhs (MatchResult can_fail body) + | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body + | otherwise = MatchResult can_fail body + +-------------- +might_fail_pat :: Pat Id -> Bool +-- Returns True of patterns that might fail (i.e. fall through) in a way +-- that is not covered by the checking algorithm. Specifically: +-- NPlusKPat +-- ViewPat (if refutable) +-- ConPatOut of a PatSynCon + +-- First the two special cases +might_fail_pat (NPlusKPat {}) = True +might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) + +-- Now the recursive stuff +might_fail_pat (ParPat p) = might_fail_lpat p +might_fail_pat (AsPat _ p) = might_fail_lpat p +might_fail_pat (SigPatOut p _ ) = might_fail_lpat p +might_fail_pat (ListPat ps _ Nothing) = any might_fail_lpat ps +might_fail_pat (ListPat _ _ (Just _)) = True +might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps +might_fail_pat (PArrPat ps _) = any might_fail_lpat ps +might_fail_pat (BangPat p) = might_fail_lpat p +might_fail_pat (ConPatOut { pat_con = con, pat_args = ps }) + = case unLoc con of + RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps) + PatSynCon _psyn -> True + +-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm +might_fail_pat (LazyPat _) = False -- Always succeeds +might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat + +-------------- +might_fail_lpat :: LPat Id -> Bool +might_fail_lpat (L _ p) = might_fail_pat p + +-------------- +tidy_lpat :: LPat Id -> LPat Id +tidy_lpat p = fmap tidy_pat p + +-------------- +tidy_pat :: Pat Id -> Pat Id +tidy_pat pat@(WildPat _) = pat +tidy_pat (VarPat id) = WildPat (idType id) +tidy_pat (ParPat p) = tidy_pat (unLoc p) +tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking + -- purposes, a ~pat is like a wildcard +tidy_pat (BangPat p) = tidy_pat (unLoc p) +tidy_pat (AsPat _ p) = tidy_pat (unLoc p) +tidy_pat (SigPatOut p _) = tidy_pat (unLoc p) +tidy_pat (CoPat _ pat _) = tidy_pat pat + +-- These two are might_fail patterns, so we map them to +-- WildPats. The might_fail_pat stuff arranges that the +-- guard says "this equation might fall through". +tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) +tidy_pat (ViewPat _ _ ty) = WildPat ty +tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty +tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys }) + = WildPat (patSynInstResTy syn tys) + +tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps }) + = pat { pat_args = tidy_con con ps } + +tidy_pat (ListPat ps ty Nothing) + = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty]) + (mkNilPat ty) + (map tidy_lpat ps) + +-- introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +-- +tidy_pat (PArrPat ps ty) + = unLoc $ mkPrefixConPat (parrFakeCon (length ps)) + (map tidy_lpat ps) + [ty] + +tidy_pat (TuplePat ps boxity tys) + = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) + (map tidy_lpat ps) tys + where + arity = length ps + +tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq +tidy_pat (LitPat lit) = tidy_lit_pat lit + +tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn" +tidy_pat (SplicePat {}) = panic "Check.tidy_pat: SplicePat" +tidy_pat (QuasiQuotePat {}) = panic "Check.tidy_pat: QuasiQuotePat" +tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn" + +tidy_lit_pat :: HsLit -> Pat Id +-- Unpack string patterns fully, so we can see when they +-- overlap with each other, or even explicit lists of Chars. +tidy_lit_pat lit + | HsString src s <- lit + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon + [mkCharLitPat src c, pat] [charTy]) + (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s) + | otherwise + = tidyLitPat lit + +----------------- +tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id +tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps) +tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2] +tidy_con con (RecCon (HsRecFields fs _)) + | null fs = PrefixCon (replicate arity nlWildPatId) + -- Special case for null patterns; maybe not a record at all + | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats) + where + arity = case con of + RealDataCon dcon -> dataConSourceArity dcon + PatSynCon psyn -> patSynArity psyn + + -- pad out all the missing fields with WildPats. + field_pats = case con of + RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc) + PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" + all_pats = foldr (\(L _ (HsRecField id p _)) acc + -> insertNm (getName (unLoc id)) p acc) + field_pats fs + + insertNm nm p [] = [(nm,p)] + insertNm nm p (x@(n,_):xs) + | nm == n = (nm,p):xs + | otherwise = x : insertNm nm p xs diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs new file mode 100644 index 00000000..b44e9d8f --- /dev/null +++ b/compiler/deSugar/Coverage.hs @@ -0,0 +1,1274 @@ +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +{-# LANGUAGE NondecreasingIndentation #-} + +module Coverage (addTicksToBinds, hpcInitCode) where + +import Type +import HsSyn +import Module +import Outputable +import DynFlags +import Control.Monad +import SrcLoc +import ErrUtils +import NameSet hiding (FreeVars) +import Name +import Bag +import CostCentre +import CoreSyn +import Id +import VarSet +import Data.List +import FastString +import HscTypes +import TyCon +import UniqSupply +import BasicTypes +import MonadUtils +import Maybes +import CLabel +import Util + +import Data.Array +import Data.Time +import System.Directory + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import BreakArray +import Data.Map (Map) +import qualified Data.Map as Map + +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} + +addTicksToBinds + :: DynFlags + -> Module + -> ModLocation -- ... off the current module + -> NameSet -- Exported Ids. When we call addTicksToBinds, + -- isExportedId doesn't work yet (the desugarer + -- hasn't set it), so we have to work from this set. + -> [TyCon] -- Type constructor in this module + -> LHsBinds Id + -> IO (LHsBinds Id, HpcInfo, ModBreaks) + +addTicksToBinds dflags mod mod_loc exports tyCons binds + | let passes = coveragePasses dflags, not (null passes), + Just orig_file <- ml_hs_file mod_loc = do + + if "boot" `isSuffixOf` orig_file + then return (binds, emptyHpcInfo False, emptyModBreaks) + else do + + us <- mkSplitUniqSupply 'C' -- for cost centres + let orig_file2 = guessSourceFile binds orig_file + + tickPass tickish (binds,st) = + let env = TTE + { fileName = mkFastString orig_file2 + , declPath = [] + , tte_dflags = dflags + , exports = exports + , inlines = emptyVarSet + , inScope = emptyVarSet + , blackList = Map.fromList + [ (getSrcSpan (tyConName tyCon),()) + | tyCon <- tyCons ] + , density = mkDensity tickish dflags + , this_mod = mod + , tickishType = tickish + } + (binds',_,st') = unTM (addTickLHsBinds binds) env st + in (binds', st') + + initState = TT { tickBoxCount = 0 + , mixEntries = [] + , breakCount = 0 + , breaks = [] + , uniqSupply = us + } + + (binds1,st) = foldr tickPass (binds, initState) passes + + let tickCount = tickBoxCount st + hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st) + orig_file2 + modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st) + + when (dopt Opt_D_dump_ticked dflags) $ + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (pprLHsBinds binds1) + + return (binds1, HpcInfo tickCount hashNo, modBreaks) + + | otherwise = return (binds, emptyHpcInfo False, emptyModBreaks) + +guessSourceFile :: LHsBinds Id -> FilePath -> FilePath +guessSourceFile binds orig_file = + -- Try look for a file generated from a .hsc file to a + -- .hs file, by peeking ahead. + let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> + srcSpanFileName_maybe pos : rest) [] binds + in + case top_pos of + (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name + -> unpackFS file_name + _ -> orig_file + + +mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks dflags count entries = do + breakArray <- newBreakArray dflags $ length entries + let + locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] + varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] + declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] + modBreaks = emptyModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + } + -- + return modBreaks + + +writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int +writeMixEntries dflags mod count entries filename + | not (gopt Opt_Hpc dflags) = return 0 + | otherwise = do + let + hpc_dir = hpcDir dflags + mod_name = moduleNameString (moduleName mod) + + hpc_mod_dir + | modulePackageKey mod == mainPackageKey = hpc_dir + | otherwise = hpc_dir ++ "/" ++ packageKeyString (modulePackageKey mod) + + tabStop = 8 -- counts as a normal char in GHC's location ranges. + + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationUTCTime filename + let entries' = [ (hpcPos, box) + | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] + when (length entries' /= count) $ do + panic "the number of .mix entries are inconsistent" + let hashNo = mixHash filename modTime tabStop entries' + mixCreate hpc_mod_dir mod_name + $ Mix filename modTime (toHash hashNo) tabStop entries' + return hashNo + + +-- ----------------------------------------------------------------------------- +-- TickDensity: where to insert ticks + +data TickDensity + = TickForCoverage -- for Hpc + | TickForBreakPoints -- for GHCi + | TickAllFunctions -- for -prof-auto-all + | TickTopFunctions -- for -prof-auto-top + | TickExportedFunctions -- for -prof-auto-exported + | TickCallSites -- for stack tracing + deriving Eq + +mkDensity :: TickishType -> DynFlags -> TickDensity +mkDensity tickish dflags = case tickish of + HpcTicks -> TickForCoverage + SourceNotes -> TickForCoverage + Breakpoints -> TickForBreakPoints + ProfNotes -> + case profAuto dflags of + ProfAutoAll -> TickAllFunctions + ProfAutoTop -> TickTopFunctions + ProfAutoExports -> TickExportedFunctions + ProfAutoCalls -> TickCallSites + _other -> panic "mkDensity" + +-- | Decide whether to add a tick to a binding or not. +shouldTickBind :: TickDensity + -> Bool -- top level? + -> Bool -- exported? + -> Bool -- simple pat bind? + -> Bool -- INLINE pragma? + -> Bool + +shouldTickBind density top_lev exported simple_pat inline + = case density of + TickForBreakPoints -> not simple_pat + -- we never add breakpoints to simple pattern bindings + -- (there's always a tick on the rhs anyway). + TickAllFunctions -> not inline + TickTopFunctions -> top_lev && not inline + TickExportedFunctions -> exported && not inline + TickForCoverage -> True + TickCallSites -> False + +shouldTickPatBind :: TickDensity -> Bool -> Bool +shouldTickPatBind density top_lev + = case density of + TickForBreakPoints -> False + TickAllFunctions -> True + TickTopFunctions -> top_lev + TickExportedFunctions -> False + TickForCoverage -> False + TickCallSites -> False + +-- ----------------------------------------------------------------------------- +-- Adding ticks to bindings + +addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) +addTickLHsBinds = mapBagM addTickLHsBind + +addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, + abs_exports = abs_exports })) = do + withEnv add_exports $ do + withEnv add_inlines $ do + binds' <- addTickLHsBinds binds + return $ L pos $ bind { abs_binds = binds' } + where + -- in AbsBinds, the Id on each binding is not the actual top-level + -- Id that we are defining, they are related by the abs_exports + -- field of AbsBinds. So if we're doing TickExportedFunctions we need + -- to add the local Ids to the set of exported Names so that we know to + -- tick the right bindings. + add_exports env = + env{ exports = exports env `extendNameSetList` + [ idName mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , idName pid `elemNameSet` (exports env) ] } + + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isAnyInlinePragma (idInlinePragma pid) ] } + + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do + let name = getOccString id + decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + let inline = isAnyInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + tickish <- tickishType `liftM` getEnv + if inline && tickish == ProfNotes then return (L pos funBind) else do + + (fvs, mg@(MG { mg_alts = matches' })) <- + getFreeVars $ + addPathEntry name $ + addTickMatchGroup False (fun_matches funBind) + + blackListed <- isBlackListed pos + exported_names <- liftM exports getEnv + + -- We don't want to generate code for blacklisted positions + -- We don't want redundant ticks on simple pattern bindings + -- We don't want to tick non-exported bindings in TickExportedFunctions + let simple = isSimplePatBind funBind + toplev = null decl_path + exported = idName id `elemNameSet` exported_names + + tick <- if not blackListed && + shouldTickBind density toplev exported simple inline + then + bindTick density name pos fvs + else + return Nothing + + let mbCons = maybe Prelude.id (:) + return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' } + , fun_tick = tick `mbCons` fun_tick funBind } + + where + -- a binding is a simple pattern binding if it is a funbind with zero patterns + isSimplePatBind :: HsBind a -> Bool + isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 + +-- TODO: Revisit this +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do + let name = "(...)" + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs + let pat' = pat { pat_rhs = rhs'} + + -- Should create ticks here? + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + if not (shouldTickPatBind density top_lev) then return (L pos pat') else do + + -- Allocate the ticks + rhs_tick <- bindTick density name pos fvs + let patvars = map getOccString (collectPatBinders lhs) + patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars + + -- Add to pattern + let mbCons = maybe id (:) + rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') + patvar_tickss = zipWith mbCons patvar_ticks + (snd (pat_ticks pat') ++ repeat []) + return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind + + +bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) +bindTick density name pos fvs = do + decl_path <- getPathEntry + let + toplev = null decl_path + count_entries = toplev || density == TickAllFunctions + top_only = density /= TickAllFunctions + box_label = if toplev then TopLevelBox [name] + else LocalBox (decl_path ++ [name]) + -- + allocATickBox box_label count_entries top_only pos fvs + + +-- Note [inline sccs] +-- +-- It should be reasonable to add ticks to INLINE functions; however +-- currently this tickles a bug later on because the SCCfinal pass +-- does not look inside unfoldings to find CostCentres. It would be +-- difficult to fix that, because SCCfinal currently works on STG and +-- not Core (and since it also generates CostCentres for CAFs, +-- changing this would be difficult too). +-- +-- Another reason not to add ticks to INLINE functions is that this +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. + +-- ----------------------------------------------------------------------------- +-- Decorate an LHsExpr with ticks + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExpr e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprRHS e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. +addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +-- general heuristic: expressions which do not denote values are good break points +isGoodBreakExpr :: HsExpr Id -> Bool +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr (NegApp {}) = True +isGoodBreakExpr (HsIf {}) = True +isGoodBreakExpr (HsMultiIf {}) = True +isGoodBreakExpr (HsCase {}) = True +isGoodBreakExpr (RecordCon {}) = True +isGoodBreakExpr (RecordUpd {}) = True +isGoodBreakExpr (ArithSeq {}) = True +isGoodBreakExpr (PArrSeq {}) = True +isGoodBreakExpr _other = False + +isCallSite :: HsExpr Id -> Bool +isCallSite HsApp{} = True +isCallSite OpApp{} = True +isCallSite _ = False + +addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprOptAlt oneOfMany (L pos e0) + = ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addBinTickLHsExpr boxLabel (L pos e0) + = ifDensity TickForCoverage + (allocBinTickBox boxLabel pos $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + + +-- ----------------------------------------------------------------------------- +-- Decoarate an HsExpr with ticks + +addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) +addTickHsExpr e@(HsVar id) = do freeVar id; return e +addTickHsExpr e@(HsIPVar _) = return e +addTickHsExpr e@(HsOverLit _) = return e +addTickHsExpr e@(HsLit _) = return e +addTickHsExpr (HsLam matchgroup) = + liftM HsLam (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase ty mgs) = + liftM (HsLamCase ty) (addTickMatchGroup True mgs) +addTickHsExpr (HsApp e1 e2) = + liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) +addTickHsExpr (OpApp e1 e2 fix e3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (return fix) + (addTickLHsExpr e3) +addTickHsExpr (NegApp e neg) = + liftM2 NegApp + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) +addTickHsExpr (HsPar e) = + liftM HsPar (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL e1 e2) = + liftM2 SectionL + (addTickLHsExpr e1) + (addTickLHsExprNever e2) +addTickHsExpr (SectionR e1 e2) = + liftM2 SectionR + (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple es boxity) = + liftM2 ExplicitTuple + (mapM addTickTupArg es) + (return boxity) +addTickHsExpr (HsCase e mgs) = + liftM2 HsCase + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. + (addTickMatchGroup False mgs) +addTickHsExpr (HsIf cnd e1 e2 e3) = + liftM3 (HsIf cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of [_] -> False; _ -> True + ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts + ; return $ HsMultiIf ty alts' } +addTickHsExpr (HsLet binds e) = + bindLocals (collectLocalBinders binds) $ + liftM2 HsLet + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsExprLetBody e) +addTickHsExpr (HsDo cxt stmts srcloc) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo cxt stmts' srcloc) } + where + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing +addTickHsExpr (ExplicitList ty wit es) = + liftM3 ExplicitList + (return ty) + (addTickWit wit) + (mapM (addTickLHsExpr) es) + where addTickWit Nothing = return Nothing + addTickWit (Just fln) = do fln' <- addTickHsExpr fln + return (Just fln') +addTickHsExpr (ExplicitPArr ty es) = + liftM2 ExplicitPArr + (return ty) + (mapM (addTickLHsExpr) es) + +addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e + +addTickHsExpr (RecordCon id ty rec_binds) = + liftM3 RecordCon + (return id) + (return ty) + (addTickHsRecordBinds rec_binds) +addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) = + liftM5 RecordUpd + (addTickLHsExpr e) + (addTickHsRecordBinds rec_binds) + (return cons) (return tys1) (return tys2) + +addTickHsExpr (ExprWithTySigOut e ty) = + liftM2 ExprWithTySigOut + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq + (return ty) + (addTickWit wit) + (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickHsExpr fl + return (Just fl') + +-- We might encounter existing ticks (multiple Coverage passes) +addTickHsExpr (HsTick t e) = + liftM (HsTick t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick t0 t1 e) = + liftM (HsBinTick t0 t1) (addTickLHsExprNever e) + +addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do + e2 <- allocTickBox (ExpBox False) False False pos $ + addTickHsExpr e0 + return $ unLoc e2 +addTickHsExpr (PArrSeq ty arith_seq) = + liftM2 PArrSeq + (return ty) + (addTickArithSeqInfo arith_seq) +addTickHsExpr (HsSCC src nm e) = + liftM3 HsSCC + (return src) + (return nm) + (addTickLHsExpr e) +addTickHsExpr (HsCoreAnn src nm e) = + liftM3 HsCoreAnn + (return src) + (return nm) + (addTickLHsExpr e) +addTickHsExpr e@(HsBracket {}) = return e +addTickHsExpr e@(HsTcBracketOut {}) = return e +addTickHsExpr e@(HsRnBracketOut {}) = return e +addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr (HsProc pat cmdtop) = + liftM2 HsProc + (addTickLPat pat) + (liftL (addTickHsCmdTop) cmdtop) +addTickHsExpr (HsWrap w e) = + liftM2 HsWrap + (return w) + (addTickHsExpr e) -- explicitly no tick on inside + +addTickHsExpr e@(HsType _) = return e +addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" + +-- Others dhould never happen in expression content. +addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) + +addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) +addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) + +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) +addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do + let isOneOfMany = matchesOneOfMany matches + matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches + return $ mg { mg_alts = matches' } + +addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) +addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs + return $ Match mf pats opSig gRHSs' + +addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) +addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded + return $ GRHSs guarded' local_binds' + where + binders = collectLocalBinders local_binds + +addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id)) +addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do + (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts + (addTickGRHSBody isOneOfMany isLambda expr) + return $ GRHS stmts' expr' + +addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id) +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr + TickAllFunctions | isLambda -> + addPathEntry "\\" $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ + addTickHsExpr e0 + _otherwise -> + addTickLHsExprRHS expr + +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id] +addTickLStmts isGuard stmts = do + (stmts, _) <- addTickLStmts' isGuard stmts (return ()) + return stmts + +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a + -> TM ([ExprLStmt Id], a) +addTickLStmts' isGuard lstmts res + = bindLocals (collectLStmtsBinders lstmts) $ + do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } + +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id)) +addTickStmt _isGuard (LastStmt e ret) = do + liftM2 LastStmt + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickStmt _isGuard (BindStmt pat e bind fail) = do + liftM4 BindStmt + (addTickLPat pat) + (addTickLHsExprRHS e) + (addTickSyntaxExpr hpcSrcSpan bind) + (addTickSyntaxExpr hpcSrcSpan fail) +addTickStmt isGuard (BodyStmt e bind' guard' ty) = do + liftM4 BodyStmt + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') + (return ty) +addTickStmt _isGuard (LetStmt binds) = do + liftM LetStmt + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do + liftM3 ParStmt + (mapM (addTickStmtAndBinders isGuard) pairs) + (addTickSyntaxExpr hpcSrcSpan mzipExpr) + (addTickSyntaxExpr hpcSrcSpan bindExpr) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } + +addTickStmt isGuard stmt@(RecStmt {}) + = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) +addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprRHS e + +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id + -> TM (ParStmtBlock Id Id) +addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = + liftM3 ParStmtBlock + (addTickLStmts isGuard stmts) + (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) +addTickHsLocalBinds (HsValBinds binds) = + liftM HsValBinds + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds binds) = + liftM HsIPBinds + (addTickHsIPBinds binds) +addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds + +addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b) +addTickHsValBinds (ValBindsOut binds sigs) = + liftM2 ValBindsOut + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) +addTickHsValBinds _ = panic "addTickHsValBinds" + +addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) +addTickHsIPBinds (IPBinds ipbinds dictbinds) = + liftM2 IPBinds + (mapM (liftL (addTickIPBind)) ipbinds) + (return dictbinds) + +addTickIPBind :: IPBind Id -> TM (IPBind Id) +addTickIPBind (IPBind nm e) = + liftM2 IPBind + (return nm) + (addTickLHsExpr e) + +-- There is no location here, so we might need to use a context location?? +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) +addTickSyntaxExpr pos x = do + L _ x' <- addTickLHsExpr (L pos x) + return $ x' +-- we do not walk into patterns. +addTickLPat :: LPat Id -> TM (LPat Id) +addTickLPat pat = return pat + +addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id) +addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = + liftM4 HsCmdTop + (addTickLHsCmd cmd) + (return tys) + (return ty) + (return syntaxtable) + +addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) +addTickLHsCmd (L pos c0) = do + c1 <- addTickHsCmd c0 + return $ L pos c1 + +addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) +addTickHsCmd (HsCmdLam matchgroup) = + liftM HsCmdLam (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp c e) = + liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) +{- +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) +-} +addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) +addTickHsCmd (HsCmdCase e mgs) = + liftM2 HsCmdCase + (addTickLHsExpr e) + (addTickCmdMatchGroup mgs) +addTickHsCmd (HsCmdIf cnd e1 c2 c3) = + liftM3 (HsCmdIf cnd) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsCmd c2) + (addTickLHsCmd c3) +addTickHsCmd (HsCmdLet binds c) = + bindLocals (collectLocalBinders binds) $ + liftM2 HsCmdLet + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsCmd c) +addTickHsCmd (HsCmdDo stmts srcloc) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsCmdDo stmts' srcloc) } + +addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = + liftM5 HsCmdArrApp + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return arr_ty) + (return lr) +addTickHsCmd (HsCmdArrForm e fix cmdtop) = + liftM3 HsCmdArrForm + (addTickLHsExpr e) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + +addTickHsCmd (HsCmdCast co cmd) + = liftM2 HsCmdCast (return co) (addTickHsCmd cmd) + +-- Others should never happen in a command context. +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) + +addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) +addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do + matches' <- mapM (liftL addTickCmdMatch) matches + return $ mg { mg_alts = matches' } + +addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) +addTickCmdMatch (Match mf pats opSig gRHSs) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ Match mf pats opSig gRHSs' + +addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) +addTickCmdGRHSs (GRHSs guarded local_binds) = do + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (liftL addTickCmdGRHS) guarded + return $ GRHSs guarded' local_binds' + where + binders = collectLocalBinders local_binds + +addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id)) +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS stmts' expr' } + +addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)] +addTickLCmdStmts stmts = do + (stmts, _) <- addTickLCmdStmts' stmts (return ()) + return stmts + +addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a) +addTickLCmdStmts' lstmts res + = bindLocals binders $ do + lstmts' <- mapM (liftL addTickCmdStmt) lstmts + a <- res + return (lstmts', a) + where + binders = collectLStmtsBinders lstmts + +addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) +addTickCmdStmt (BindStmt pat c bind fail) = do + liftM4 BindStmt + (addTickLPat pat) + (addTickLHsCmd c) + (return bind) + (return fail) +addTickCmdStmt (LastStmt c ret) = do + liftM2 LastStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (BodyStmt c bind' guard' ty) = do + liftM4 BodyStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') + (return ty) +addTickCmdStmt (LetStmt binds) = do + liftM LetStmt + (addTickHsLocalBinds binds) +addTickCmdStmt stmt@(RecStmt {}) + = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +-- Others should never happen in a command context. +addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) + +addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM process fields + ; return (HsRecFields fields' dd) } + where + process (L l (HsRecField ids expr doc)) + = do { expr' <- addTickLHsExpr expr + ; return (L l (HsRecField ids expr' doc)) } + +addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) +addTickArithSeqInfo (From e1) = + liftM From + (addTickLHsExpr e1) +addTickArithSeqInfo (FromThen e1 e2) = + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromTo e1 e2) = + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromThenTo e1 e2 e3) = + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) + +liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a) +liftL f (L loc a) = do + a' <- f a + return $ L loc a' + +data TickTransState = TT { tickBoxCount:: Int + , mixEntries :: [MixEntry_] + , breakCount :: Int + , breaks :: [MixEntry_] + , uniqSupply :: UniqSupply + } + +data TickTransEnv = TTE { fileName :: FastString + , density :: TickDensity + , tte_dflags :: DynFlags + , exports :: NameSet + , inlines :: VarSet + , declPath :: [String] + , inScope :: VarSet + , blackList :: Map SrcSpan () + , this_mod :: Module + , tickishType :: TickishType + } + +-- deriving Show + +data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes + deriving (Eq) + +coveragePasses :: DynFlags -> [TickishType] +coveragePasses dflags = + ifa (hscTarget dflags == HscInterpreted) Breakpoints $ + ifa (gopt Opt_Hpc dflags) HpcTicks $ + ifa (gopt Opt_SccProfilingOn dflags && + profAuto dflags /= NoProfAuto) ProfNotes $ + ifa (gopt Opt_Debug dflags) SourceNotes [] + where ifa f x xs | f = x:xs + | otherwise = xs + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + +type FreeVars = OccEnv Id +noFVs :: FreeVars +noFVs = emptyOccEnv + +-- Note [freevars] +-- For breakpoints we want to collect the free variables of an +-- expression for pinning on the HsTick. We don't want to collect +-- *all* free variables though: in particular there's no point pinning +-- on free variables that are will otherwise be in scope at the GHCi +-- prompt, which means all top-level bindings. Unfortunately detecting +-- top-level bindings isn't easy (collectHsBindsBinders on the top-level +-- bindings doesn't do it), so we keep track of a set of "in-scope" +-- variables in addition to the free variables, and the former is used +-- to filter additions to the latter. This gives us complete control +-- over what free variables we track. + +data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + -- a combination of a state monad (TickTransState) and a writer + -- monad (FreeVars). + +instance Functor TM where + fmap = liftM + +instance Applicative TM where + pure = return + (<*>) = ap + +instance Monad TM where + return a = TM $ \ _env st -> (a,noFVs,st) + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> + case unTM (k r1) env st1 of + (r2,fv2,st2) -> + (r2, fv1 `plusOccEnv` fv2, st2) + +instance HasDynFlags TM where + getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) + +instance MonadUnique TM where + getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st) + getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st) + in (u, noFVs, st { uniqSupply = us' }) + +getState :: TM TickTransState +getState = TM $ \ _ st -> (st, noFVs, st) + +setState :: (TickTransState -> TickTransState) -> TM () +setState f = TM $ \ _ st -> ((), noFVs, f st) + +getEnv :: TM TickTransEnv +getEnv = TM $ \ env st -> (env, noFVs, st) + +withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of + (a, fvs, st') -> (a, fvs, st') + +getDensity :: TM TickDensity +getDensity = TM $ \env st -> (density env, noFVs, st) + +ifDensity :: TickDensity -> TM a -> TM a -> TM a +ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el + +getFreeVars :: TM a -> TM (FreeVars, a) +getFreeVars (TM m) + = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') + +freeVar :: Id -> TM () +freeVar id = TM $ \ env st -> + if id `elemVarSet` inScope env + then ((), unitOccEnv (nameOccName (idName id)) id, st) + else ((), noFVs, st) + +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) + +getPathEntry :: TM [String] +getPathEntry = declPath `liftM` getEnv + +getFileName :: TM FastString +getFileName = fileName `liftM` getEnv + +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do + file_name <- getFileName + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code + +bindLocals :: [Id] -> TM a -> TM a +bindLocals new_ids (TM m) + = TM $ \ env st -> + case m env{ inScope = inScope env `extendVarSetList` new_ids } st of + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') + where occs = [ nameOccName (idName id) | id <- new_ids ] + +isBlackListed :: SrcSpan -> TM Bool +isBlackListed pos = TM $ \ env st -> + case Map.lookup pos (blackList env) of + Nothing -> (False,noFVs,st) + Just () -> (True,noFVs,st) + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id) + -> TM (LHsExpr Id) +allocTickBox boxLabel countEntries topOnly pos m = + ifGoodTickSrcSpan pos (do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (L pos (HsTick tickish (L pos e))) + ) (do + e <- m + return (L pos e) + ) + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars + -> TM (Maybe (Tickish Id)) +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let + mydecl_path = case boxLabel of + TopLevelBox x -> x + LocalBox xs -> xs + _ -> panic "allocATickBox" + tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path + return (Just tickish) + ) (return Nothing) + + +mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] + -> TM (Tickish Id) +mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs + -- unlifted types cause two problems here: + -- * we can't bind them at the GHCi prompt + -- (bindLocalsAtBreakpoint already fliters them out), + -- * the simplifier might try to substitute a literal for + -- the Id, and we can't handle that. + + me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) + + cc_name | topOnly = head decl_path + | otherwise = concat (intersperse "." decl_path) + + dflags <- getDynFlags + env <- getEnv + case tickishType env of + HpcTicks -> do + c <- liftM tickBoxCount getState + setState $ \st -> st { tickBoxCount = c + 1 + , mixEntries = me : mixEntries st } + return $ HpcTick (this_mod env) c + + ProfNotes -> do + ccUnique <- getUniqueM + let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique + count = countEntries && gopt Opt_ProfCountEntries dflags + return $ ProfNote cc count True{-scopes-} + + Breakpoints -> do + c <- liftM breakCount getState + setState $ \st -> st { breakCount = c + 1 + , breaks = me:breaks st } + return $ Breakpoint c ids + + SourceNotes | RealSrcSpan pos' <- pos -> + return $ SourceNote pos' cc_name + + _otherwise -> panic "mkTickish: bad source span!" + + +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id) + -> TM (LHsExpr Id) +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L pos) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id + -> TM (LHsExpr Id) +mkBinTickBoxHpc boxLabel pos e = + TM $ \ env st -> + let meT = (pos,declPath env, [],boxLabel True) + meF = (pos,declPath env, [],boxLabel False) + meE = (pos,declPath env, [],ExpBox False) + c = tickBoxCount st + mes = mixEntries st + in + ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , noFVs + , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} + ) + +mkHpcPos :: SrcSpan -> HpcPos +mkHpcPos pos@(RealSrcSpan s) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" + +hpcSrcSpan :: SrcSpan +hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") + +matchesOneOfMany :: [LMatch Id body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss + +type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) + +-- For the hash value, we hash everything: the file name, +-- the timestamp of the original source file, the tab stop, +-- and the mix entries. We cheat, and hash the show'd string. +-- This hash only has to be hashed at Mix creation time, +-- and is for sanity checking only. + +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int +mixHash file tm tabstop entries = fromIntegral $ hashString + (show $ Mix file tm 0 tabstop entries) + +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} +-} + +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = Outputable.empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + ptext (sLit "extern StgWord64 ") <> tickboxes <> + ptext (sLit "[]") <> semi, + ptext (sLit "hs_hpc_module") <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = ppr (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ + bytesFS (moduleNameFS (Module.moduleName this_mod))) + package_name = hcat (map (text.charToC) $ + bytesFS (packageKeyFS (modulePackageKey this_mod))) + full_name_str + | modulePackageKey this_mod == mainPackageKey + = module_name + | otherwise + = package_name <> char '/' <> module_name diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs new file mode 100644 index 00000000..e4181b9b --- /dev/null +++ b/compiler/deSugar/Desugar.hs @@ -0,0 +1,486 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The Desugarer: turning HsSyn into Core. +-} + +{-# LANGUAGE CPP #-} + +module Desugar ( deSugar, deSugarExpr ) where + +import DynFlags +import HscTypes +import HsSyn +import TcRnTypes +import TcRnMonad ( finalSafeMode ) +import MkIface +import Id +import Name +import Type +import FamInstEnv +import Coercion +import InstEnv +import Class +import Avail +import CoreSyn +import CoreSubst +import PprCore +import DsMonad +import DsExpr +import DsBinds +import DsForeign +import Module +import NameSet +import NameEnv +import Rules +import TysPrim (eqReprPrimTyCon) +import TysWiredIn (coercibleTyCon ) +import BasicTypes ( Activation(.. ) ) +import CoreMonad ( CoreToDo(..) ) +import CoreLint ( endPassIO ) +import MkCore +import FastString +import ErrUtils +import Outputable +import SrcLoc +import Coverage +import Util +import MonadUtils +import OrdList +import StaticPtrTable +import Data.List +import Data.IORef +import Control.Monad( when ) + +{- +************************************************************************ +* * +* The main function: deSugar +* * +************************************************************************ +-} + +-- | Main entry point to the desugarer. +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + mod_loc + tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_keep = keep_var, + tcg_th_splice_used = tc_splice_used, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_inst_env = inst_env, + tcg_fam_inst_env = fam_inst_env, + tcg_warns = warns, + tcg_anns = anns, + tcg_binds = binds, + tcg_imp_specs = imp_specs, + tcg_dependent_files = dependent_files, + tcg_ev_binds = ev_binds, + tcg_fords = fords, + tcg_rules = rules, + tcg_vects = vects, + tcg_patsyns = patsyns, + tcg_tcs = tcs, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info}) + + = do { let dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + ; showPass dflags "Desugar" + + -- Desugar the program + ; let export_set = availsToNameSet exports + target = hscTarget dflags + hpcInfo = emptyHpcInfo other_hpc_info + + ; (binds_cvr, ds_hpc_info, modBreaks) + <- if not (isHsBootOrSig hsc_src) + then addTicksToBinds dflags mod mod_loc export_set + (typeEnvTyCons type_env) binds + else return (binds, hpcInfo, emptyModBreaks) + + ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $ + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds binds_cvr + ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; ds_vects <- mapM dsVect vects + ; stBinds <- dsGetStaticBindsVar >>= + liftIO . readIORef + ; let hpc_init + | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info + | otherwise = empty + -- Stub to insert the static entries of the + -- module into the static pointer table + spt_init = sptInitCode mod stBinds + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + `appOL` toOL (map snd stBinds) + , spec_rules ++ ds_rules, ds_vects + , ds_fords `appendStubC` hpc_init + `appendStubC` spt_init) } + + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do + + do { -- Add export flags to bindings + keep_alive <- readIORef keep_var + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules + final_prs = addExportFlagsAndRules target export_set keep_alive + rules_for_locals (fromOL all_prs) + + final_pgm = combineEvBinds ds_ev_binds final_prs + -- Notice that we put the whole lot in a big Rec, even the foreign binds + -- When compiling PrelFloat, which defines data Float = F# Float# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! + +#ifdef DEBUG + -- Debug only as pre-simple-optimisation program may be really big + ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps +#endif + ; (ds_binds, ds_rules_for_imps, ds_vects) + <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 + -- The simpleOptPgm gets rid of type + -- bindings plus any stupid dead code + + ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps + + ; let used_names = mkUsedNames tcg_env + ; deps <- mkDependencies tcg_env + + ; used_th <- readIORef tc_splice_used + ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env + + ; let mod_guts = ModGuts { + mg_module = mod, + mg_boot = hsc_src == HsBootFile, + mg_exports = exports, + mg_deps = deps, + mg_used_names = used_names, + mg_used_th = used_th, + mg_dir_imps = imp_mods imports, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_anns = anns, + mg_tcs = tcs, + mg_insts = insts, + mg_fam_insts = fam_insts, + mg_inst_env = inst_env, + mg_fam_inst_env = fam_inst_env, + mg_patsyns = patsyns, + mg_rules = ds_rules_for_imps, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_hpc_info = ds_hpc_info, + mg_modBreaks = modBreaks, + mg_vect_decls = ds_vects, + mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, + mg_trust_pkg = imp_trust_own_pkg imports, + mg_dependent_files = dep_files + } + ; return (msgs, Just mod_guts) + }}} + +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } + +combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] +-- Top-level bindings can include coercion bindings, but not via superclasses +-- See Note [Top-level evidence] +combineEvBinds [] val_prs + = [Rec val_prs] +combineEvBinds (NonRec b r : bs) val_prs + | isId b = combineEvBinds bs ((b,r):val_prs) + | otherwise = NonRec b r : combineEvBinds bs val_prs +combineEvBinds (Rec prs : bs) val_prs + = combineEvBinds bs (prs ++ val_prs) + +{- +Note [Top-level evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level evidence bindings may be mutually recursive with the top-level value +bindings, so we must put those in a Rec. But we can't put them *all* in a Rec +because the occurrence analyser doesn't teke account of type/coercion variables +when computing dependencies. + +So we pull out the type/coercion variables (which are in dependency order), +and Rec the rest. +-} + +deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) + +deSugarExpr hsc_env tc_expr + = do { let dflags = hsc_dflags hsc_env + icntxt = hsc_IC hsc_env + rdr_env = ic_rn_gbl_env icntxt + type_env = mkTypeEnvWithImplicits (ic_tythings icntxt) + fam_insts = snd (ic_instances icntxt) + fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts + -- This stuff is a half baked version of TcRnDriver.setInteractiveContext + + ; showPass dflags "Desugar" + + -- Do desugaring + ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env + type_env fam_inst_env $ + dsLExpr tc_expr + + ; case mb_core_expr of + Nothing -> return () + Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) + + ; return (msgs, mb_core_expr) } + +{- +************************************************************************ +* * +* Add rules and export flags to binders +* * +************************************************************************ +-} + +addExportFlagsAndRules + :: HscTarget -> NameSet -> NameSet -> [CoreRule] + -> [(Id, t)] -> [(Id, t)] +addExportFlagsAndRules target exports keep_alive rules prs + = mapFst add_one prs + where + add_one bndr = add_rules name (add_export name bndr) + where + name = idName bndr + + ---------- Rules -------- + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + add_rules name bndr + | Just rules <- lookupNameEnv rule_base name + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + rule_base = extendRuleBaseList emptyRuleBase rules + + ---------- Export flag -------- + -- See Note [Adding export flags] + add_export name bndr + | dont_discard name = setIdExported bndr + | otherwise = bndr + + dont_discard :: Name -> Bool + dont_discard name = is_exported name + || name `elemNameSet` keep_alive + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. + is_exported :: Name -> Bool + is_exported | targetRetainsAllBindings target = isExternalName + | otherwise = (`elemNameSet` exports) + +{- +Note [Adding export flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Set the no-discard flag if either + a) the Id is exported + b) it's mentioned in the RHS of an orphan rule + c) it's in the keep-alive set + +It means that the binding won't be discarded EVEN if the binding +ends up being trivial (v = w) -- the simplifier would usually just +substitute w for v throughout, but we don't apply the substitution to +the rules (maybe we should?), so this substitution would make the rule +bogus. + +You might wonder why exported Ids aren't already marked as such; +it's just because the type checker is rather busy already and +I didn't want to pass in yet another mapping. + +Note [Attach rules to local ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Find the rules for locally-defined Ids; then we can attach them +to the binders in the top-level bindings + +Reason + - It makes the rules easier to look up + - It means that transformation rules and specialisations for + locally defined Ids are handled uniformly + - It keeps alive things that are referred to only from a rule + (the occurrence analyser knows about rules attached to Ids) + - It makes sure that, when we apply a rule, the free vars + of the RHS are more likely to be in scope + - The imported rules are carried in the in-scope set + which is extended on each iteration by the new wave of + local binders; any rules which aren't on the binding will + thereby get dropped + + +************************************************************************ +* * +* Desugaring transformation rules +* * +************************************************************************ +-} + +dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) +dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) + = putSrcSpanDs loc $ + do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] + + ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] + + ; rhs' <- dsLExpr rhs + ; dflags <- getDynFlags + + ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs' + + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + ; case decomposeRuleLhs bndrs'' lhs'' of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do + + { let is_local = isLocalId fn_id + -- NB: isLocalId is False of implicit Ids. This is good because + -- we don't want to attach rules to the bindings of implicit Ids, + -- because they don't show up in the bindings until just before code gen + fn_name = idName fn_id + final_rhs = simpleOptExpr rhs'' -- De-crap it + rule = mkRule False {- Not auto -} is_local + (unLoc name) act fn_name final_bndrs args + final_rhs + + inline_shadows_rule -- Function can be inlined before rule fires + | wopt Opt_WarnInlineRuleShadowing dflags + , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id) + -- If imported with no unfolding, no worries + = case (idInlineActivation fn_id, act) of + (NeverActive, _) -> False + (AlwaysActive, _) -> True + (ActiveBefore {}, _) -> True + (ActiveAfter {}, NeverActive) -> True + (ActiveAfter n, ActiveAfter r) -> r < n -- Rule active strictly first + (ActiveAfter {}, AlwaysActive) -> False + (ActiveAfter {}, ActiveBefore {}) -> False + | otherwise = False + + ; when inline_shadows_rule $ + warnDs (vcat [ hang (ptext (sLit "Rule") + <+> doubleQuotes (ftext $ unLoc name) + <+> ptext (sLit "may never fire")) + 2 (ptext (sLit "because") <+> quotes (ppr fn_id) + <+> ptext (sLit "might inline first")) + , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on") + <+> quotes (ppr fn_id) ]) + + ; return (Just rule) + } } } + +-- See Note [Desugaring coerce as cast] +unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) +unfold_coerce bndrs lhs rhs = do + (bndrs', wrap) <- go bndrs + return (bndrs', wrap lhs, wrap rhs) + where + go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) + go [] = return ([], id) + go (v:vs) + | Just (tc, args) <- splitTyConApp_maybe (idType v) + , tc == coercibleTyCon = do + let ty' = mkTyConApp eqReprPrimTyCon args + v' <- mkDerivedLocalM mkRepEqOcc v ty' + + (bndrs, wrap) <- go vs + return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap) + | otherwise = do + (bndrs,wrap) <- go vs + return (v:bndrs, wrap) + +{- +Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See DsExpr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too. + + + +Nor do we want to warn of conversion identities on the LHS; +the rule is precisly to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + + +Note [Desugaring coerce as cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want the user to express a rule saying roughly “mapping a coercion over a +list can be replaced by a coercion”. But the cast operator of Core (▷) cannot +be written in Haskell. So we use `coerce` for that (#2110). The user writes + map coerce = coerce +as a RULE, and this optimizes any kind of mapped' casts aways, including `map +MkNewtype`. + +For that we replace any forall'ed `c :: Coercible a b` value in a RULE by +corresponding `co :: a ~#R b` and wrap the LHS and the RHS in +`let c = MkCoercible co in ...`. This is later simplified to the desired form +by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). + +************************************************************************ +* * +* Desugaring vectorisation declarations +* * +************************************************************************ +-} + +dsVect :: LVectDecl Id -> DsM CoreVect +dsVect (L loc (HsVect _ (L _ v) rhs)) + = putSrcSpanDs loc $ + do { rhs' <- dsLExpr rhs + ; return $ Vect v rhs' + } +dsVect (L _loc (HsNoVect _ (L _ v))) + = return $ NoVect v +dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) + = return $ VectType isScalar tycon' rhs_tycon + where + tycon' | Just ty <- coreView $ mkTyConTy tycon + , (tycon', []) <- splitTyConApp ty = tycon' + | otherwise = tycon +dsVect vd@(L _ (HsVectTypeIn _ _ _ _)) + = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) +dsVect (L _loc (HsVectClassOut cls)) + = return $ VectClass (classTyCon cls) +dsVect vc@(L _ (HsVectClassIn _ _)) + = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) +dsVect (L _loc (HsVectInstOut inst)) + = return $ VectInst (instanceDFunId inst) +dsVect vi@(L _ (HsVectInstIn _)) + = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs new file mode 100644 index 00000000..73fc039e --- /dev/null +++ b/compiler/deSugar/DsArrows.hs @@ -0,0 +1,1178 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring arrow commands +-} + +{-# LANGUAGE CPP #-} + +module DsArrows ( dsProcExpr ) where + +#include "HsVersions.h" + +import Match +import DsUtils +import DsMonad + +import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) +import TcHsSyn + +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types (newtypes etc), and sometimes not +-- So WATCH OUT; check each use of split*Ty functions. +-- Sigh. This is a pain. + +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) + +import TcType +import TcEvidence +import CoreSyn +import CoreFVs +import CoreUtils +import MkCore +import DsBinds (dsHsWrapper) + +import Name +import Var +import Id +import DataCon +import TysWiredIn +import BasicTypes +import PrelNames +import Outputable +import Bag +import VarSet +import SrcLoc +import ListSetOps( assocDefault ) +import FastString +import Data.List + +data DsCmdEnv = DsCmdEnv { + arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr + } + +mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in HsExpr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + ; return (meth_binds, DsCmdEnv { + arr_id = Var (find_meth prs arrAName), + compose_id = Var (find_meth prs composeAName), + first_id = Var (find_meth prs firstAName), + app_id = Var (find_meth prs appAName), + choice_id = Var (find_meth prs choiceAName), + loop_id = Var (find_meth prs loopAName) + }) } + where + mk_bind (std_name, expr) + = do { rhs <- dsExpr expr + ; id <- newSysLocalDs (exprType rhs) + ; return (NonRec id rhs, (std_name, id)) } + + find_meth prs std_name + = assocDefault (mk_panic std_name) prs std_name + mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name) + +-- arr :: forall b c. (b -> c) -> a b c +do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr +do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f] + +-- (>>>) :: forall b c d. a b c -> a c d -> a b d +do_compose :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_compose ids b_ty c_ty d_ty f g + = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g] + +-- first :: forall b c d. a b c -> a (b,d) (c,d) +do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_first ids b_ty c_ty d_ty f + = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f] + +-- app :: forall b c. a (a b c, b) c +do_app :: DsCmdEnv -> Type -> Type -> CoreExpr +do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty] + +-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d +-- note the swapping of d and c +do_choice :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_choice ids b_ty c_ty d_ty f g + = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g] + +-- loop :: forall b d c. a (b,d) (c,d) -> a b c +-- note the swapping of d and c +do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr +do_loop ids b_ty c_ty d_ty f + = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f] + +-- premap :: forall b c d. (b -> c) -> a c d -> a b d +-- premap f g = arr f >>> g +do_premap :: DsCmdEnv -> Type -> Type -> Type -> + CoreExpr -> CoreExpr -> CoreExpr +do_premap ids b_ty c_ty d_ty f g + = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g + +mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr +mkFailExpr ctxt ty + = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a +mkFstExpr :: Type -> Type -> DsM CoreExpr +mkFstExpr a_ty b_ty = do + a_var <- newSysLocalDs a_ty + b_var <- newSysLocalDs b_ty + pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var a_var))) + +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b +mkSndExpr :: Type -> Type -> DsM CoreExpr +mkSndExpr a_ty b_ty = do + a_var <- newSysLocalDs a_ty + b_var <- newSysLocalDs b_ty + pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var b_var))) + +{- +Build case analysis of a tuple. This cannot be done in the DsM monad, +because the list of variables is typically not yet defined. +-} + +-- coreCaseTuple [u1..] v [x1..xn] body +-- = case v of v { (x1, .., xn) -> body } +-- But the matching may be nested if the tuple is very big + +coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr +coreCaseTuple uniqs scrut_var vars body + = mkTupleCase uniqs vars body scrut_var (Var scrut_var) + +coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr +coreCasePair scrut_var var1 var2 body + = Case (Var scrut_var) scrut_var (exprType body) + [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)] + +mkCorePairTy :: Type -> Type -> Type +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] + +mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr +mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] + +{- +The input is divided into a local environment, which is a flat tuple +(unless it's too big), and a stack, which is a right-nested pair. +In general, the input has the form + + ((x1,...,xn), (s1,...(sk,())...)) + +where xi are the environment values, and si the ones on the stack, +with s1 being the "top", the first one to be matched with a lambda. +-} + +envStackType :: [Id] -> Type -> Type +envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty + +-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) +splitTypeAt :: Int -> Type -> ([Type], Type) +splitTypeAt n ty + | n == 0 = ([], ty) + | otherwise = case tcTyConAppArgs ty of + [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) + _ -> pprPanic "splitTypeAt" (ppr ty) + +---------------------------------------------- +-- buildEnvStack +-- +-- ((x1,...,xn),stk) + +buildEnvStack :: [Id] -> Id -> CoreExpr +buildEnvStack env_ids stack_id + = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) + +---------------------------------------------- +-- matchEnvStack +-- +-- \ ((x1,...,xn),stk) -> body +-- => +-- \ pair -> +-- case pair of (tup,stk) -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnvStack :: [Id] -- x1..xn + -> Id -- stk + -> CoreExpr -- e + -> DsM CoreExpr +matchEnvStack env_ids stack_id body = do + uniqs <- newUniqueSupply + tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + let match_env = coreCaseTuple uniqs tup_var env_ids body + pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) + return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) + +---------------------------------------------- +-- matchEnv +-- +-- \ (x1,...,xn) -> body +-- => +-- \ tup -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnv :: [Id] -- x1..xn + -> CoreExpr -- e + -> DsM CoreExpr +matchEnv env_ids body = do + uniqs <- newUniqueSupply + tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + +---------------------------------------------- +-- matchVarStack +-- +-- case (x1, ...(xn, s)...) -> e +-- => +-- case z0 of (x1,z1) -> +-- case zn-1 of (xn,s) -> +-- e +matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) +matchVarStack [] stack_id body = return (stack_id, body) +matchVarStack (param_id:param_ids) stack_id body = do + (tail_id, tail_code) <- matchVarStack param_ids stack_id body + pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) + return (pair_id, coreCasePair pair_id param_id tail_id tail_code) + +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] + +-- Translation of arrow abstraction + +-- D; xs |-a c : () --> t' ---> c' +-- -------------------------- +-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' +-- +-- where (xs) is the tuple of variables bound by p + +dsProcExpr + :: LPat Id + -> LHsCmdTop Id + -> DsM CoreExpr +dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + let locals = mkVarSet (collectPatBinders pat) + (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd + let env_ty = mkBigCoreVarTupTy env_ids + let env_stk_ty = mkCorePairTy env_ty unitTy + let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr + fail_expr <- mkFailExpr ProcExpr env_stk_ty + var <- selectSimpleMatchVarL pat + match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr + let pat_ty = hsLPatType pat + proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty + (Lam var match_code) + core_cmd + return (mkLets meth_binds proc_code) + +{- +Translation of a command judgement of the form + + D; xs |-a c : stk --> t + +to an expression e such that + + D |- e :: a (xs, stk) t +-} + +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] + -> DsM (CoreExpr, IdSet) +dsLCmd ids local_vars stk_ty res_ty cmd env_ids + = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids + +dsCmd :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> HsCmd Id -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + IdSet) -- subset of local vars that occur free + +-- D |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ----------------------------- +-- D; xs |-a fun -< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> arg) fun + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs stack_ty + core_make_arg <- matchEnvStack env_ids stack_id core_arg + return (do_premap ids + (envStackType env_ids stack_ty) + arg_ty + res_ty + core_make_arg + core_arrow, + exprFreeIds core_arg `intersectVarSet` local_vars) + +-- D, xs |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ------------------------------ +-- D; xs |-a fun -<< arg : stk --> t2 +-- +-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app + +dsCmd ids local_vars stack_ty res_ty + (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) + env_ids = do + let + (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty + (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty + + core_arrow <- dsLExpr arrow + core_arg <- dsLExpr arg + stack_id <- newSysLocalDs stack_ty + core_make_pair <- matchEnvStack env_ids stack_id + (mkCorePairExpr core_arrow core_arg) + + return (do_premap ids + (envStackType env_ids stack_ty) + (mkCorePairTy arrow_ty arg_ty) + res_ty + core_make_pair + (do_app ids arg_ty res_ty), + (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg) + `intersectVarSet` local_vars) + +-- D; ys |-a cmd : (t,stk) --> t' +-- D, xs |- exp :: t +-- ------------------------ +-- D; xs |-a cmd exp : stk --> t' +-- +-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd + +dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do + core_arg <- dsLExpr arg + let + arg_ty = exprType core_arg + stack_ty' = mkCorePairTy arg_ty stack_ty + (core_cmd, free_vars, env_ids') + <- dsfixCmd ids local_vars stack_ty' res_ty cmd + stack_id <- newSysLocalDs stack_ty + arg_id <- newSysLocalDs arg_ty + -- push the argument expression onto the stack + let + stack' = mkCorePairExpr (Var arg_id) (Var stack_id) + core_body = bindNonRec arg_id core_arg + (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') + + -- match the environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_body + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty') + res_ty + core_map + core_cmd, + free_vars `unionVarSet` + (exprFreeIds core_arg `intersectVarSet` local_vars)) + +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' +-- +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _ + (GRHSs [L _ (GRHS [] body)] _ ))] })) + env_ids = do + let + pat_vars = mkVarSet (collectPatsBinders pats) + local_vars' = pat_vars `unionVarSet` local_vars + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- mapM newSysLocalDs pat_tys + stack_id' <- newSysLocalDs stack_ty' + + -- the expression is built from the inside out, so the actions + -- are presented in reverse order + + let + -- build a new environment, plus what's left of the stack + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' + + fail_expr <- mkFailExpr LambdaExpr in_ty' + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code + -- match the old environment and stack against the input + select_code <- matchEnvStack env_ids stack_id param_code + return (do_premap ids in_ty in_ty' res_ty select_code core_body, + free_vars `minusVarSet` pat_vars) + +dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids + = dsLCmd ids local_vars stack_ty res_ty cmd env_ids + +-- D, xs |- e :: Bool +-- D; xs1 |-a c1 : stk --> t +-- D; xs2 |-a c2 : stk --> t +-- ---------------------------------------- +-- D; xs |-a if e then c1 else c2 : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> +-- if e then Left ((xs1),stk) else Right ((xs2),stk)) +-- (c1 ||| c2) + +dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) + env_ids = do + core_cond <- dsLExpr cond + (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + stack_id <- newSysLocalDs stack_ty + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e] + + in_ty = envStackType env_ids stack_ty + then_ty = envStackType then_ids stack_ty + else_ty = envStackType else_ids stack_ty + sum_ty = mkTyConApp either_con [then_ty, else_ty] + fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars + + core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) + + core_if <- case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; matchEnvStack env_ids stack_id $ + mkCoreApps core_fun [core_cond, core_left, core_right] } + Nothing -> matchEnvStack env_ids stack_id $ + mkIfThenElse core_cond core_left core_right + + return (do_premap ids in_ty sum_ty res_ty + core_if + (do_choice ids then_ty else_ty res_ty core_then core_else), + fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else) + +{- +Case commands are treated in much the same way as if commands +(see above) except that there are more alternatives. For example + + case e of { p1 -> c1; p2 -> c2; p3 -> c3 } + +is translated to + + premap (\ ((xs)*ts) -> case e of + p1 -> (Left (Left (xs1)*ts)) + p2 -> Left ((Right (xs2)*ts)) + p3 -> Right ((xs3)*ts)) + ((c1 ||| c2) ||| c3) + +The idea is to extract the commands from the case, build a balanced tree +of choices, and replace the commands with expressions that build tagged +tuples, obtaining a case expression that can be desugared normally. +To build all this, we use triples describing segments of the list of +case bodies, containing the following fields: + * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put + into the case replacing the commands + * a sum type that is the common type of these expressions, and also the + input type of the arrow + * a CoreExpr for an arrow built by combining the translated command + bodies with |||. +-} + +dsCmd ids local_vars stack_ty res_ty + (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin })) + env_ids = do + stack_id <- newSysLocalDs stack_ty + + -- Extract and desugar the leaf commands in the case, building tuple + -- expressions that will (after tagging) replace these leaves + + let + leaves = concatMap leavesMatch matches + make_branch (leaf, bound_vars) = do + (core_leaf, _fvs, leaf_ids) <- + dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf + return ([mkHsEnvStackExpr leaf_ids stack_id], + envStackType leaf_ids stack_ty, + core_leaf) + + branches <- mapM make_branch leaves + either_con <- dsLookupTyCon eitherTyConName + left_con <- dsLookupDataCon leftDataConName + right_con <- dsLookupDataCon rightDataConName + let + left_id = HsVar (dataConWrapId left_con) + right_id = HsVar (dataConWrapId right_con) + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e + + -- Prefix each tuple with a distinct series of Left's and Right's, + -- in a balanced way, keeping track of the types. + + merge_branches (builds1, in_ty1, core_exp1) + (builds2, in_ty2, core_exp2) + = (map (left_expr in_ty1 in_ty2) builds1 ++ + map (right_expr in_ty1 in_ty2) builds2, + mkTyConApp either_con [in_ty1, in_ty2], + do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2) + (leaves', sum_ty, core_choices) = foldb merge_branches branches + + -- Replace the commands in the case with these tagged tuples, + -- yielding a HsExpr Id we can feed to dsExpr. + + (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches + in_ty = envStackType env_ids stack_ty + + core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys + , mg_res_ty = sum_ty, mg_origin = origin })) + -- Note that we replace the HsCase result type by sum_ty, + -- which is the type of matches' + + core_matches <- matchEnvStack env_ids stack_id core_body + return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, + exprFreeIds core_body `intersectVarSet` local_vars) + +-- D; ys |-a cmd : stk --> t +-- ---------------------------------- +-- D; xs |-a let binds in cmd : stk --> t +-- +-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do + let + defined_vars = mkVarSet (collectLocalBinders binds) + local_vars' = defined_vars `unionVarSet` local_vars + + (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body + stack_id <- newSysLocalDs stack_ty + -- build a new environment, plus the stack, using the let bindings + core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id) + -- match the old environment and stack against the input + core_map <- matchEnvStack env_ids stack_id core_binds + return (do_premap ids + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty) + res_ty + core_map + core_body, + exprFreeIds core_binds `intersectVarSet` local_vars) + +-- D; xs |-a ss : t +-- ---------------------------------- +-- D; xs |-a do { ss } : () --> t +-- +-- ---> premap (\ (env,stk) -> env) c + +dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do + (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids + let env_ty = mkBigCoreVarTupTy env_ids + core_fst <- mkFstExpr env_ty stack_ty + return (do_premap ids + (mkCorePairTy env_ty stack_ty) + env_ty + res_ty + core_fst + core_stmts, + env_ids') + +-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t +-- D; xs |-a ci :: stki --> ti +-- ----------------------------------- +-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn + +dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do + let env_ty = mkBigCoreVarTupTy env_ids + core_op <- dsLExpr op + (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args + return (mkApps (App core_op (Type env_ty)) core_args, + unionVarSets fv_sets) + +dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do + (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids + wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd + return (wrapped_cmd, env_ids') + +dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) + +-- D; ys |-a c : stk --> t (ys <= xs) +-- --------------------- +-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c + +dsTrimCmdArg + :: IdSet -- set of local vars available to this command + -> [Id] -- list of vars in the input to this command + -> LHsCmdTop Id -- command argument to desugar + -> DsM (CoreExpr, -- desugared expression + IdSet) -- subset of local vars that occur free +dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do + (meth_binds, meth_ids) <- mkCmdEnv ids + (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + stack_id <- newSysLocalDs stack_ty + trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) + let + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty + arg_code = if env_ids' == env_ids then core_cmd else + do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd + return (mkLets meth_binds arg_code, free_vars) + +-- Given D; xs |-a c : stk --> t, builds c with xs fed back. +-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) + +dsfixCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this command + -> Type -- type of the stack (right-nested tuple) + -> Type -- return type of the command + -> LHsCmd Id -- command to desugar + -> DsM (CoreExpr, -- desugared expression + IdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back +dsfixCmd ids local_vars stk_ty cmd_ty cmd + = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, IdSet)) + -> DsM (CoreExpr, -- desugared expression + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids + return (core_cmd, free_vars, varSetElems free_vars)) + +{- +Translation of command judgements of the form + + D |-a do { ss } : t +-} + +dsCmdDo :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [CmdLStmt Id] -- statements to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + IdSet) -- subset of local vars that occur free + +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" + +-- D; xs |-a c : () --> t +-- -------------------------- +-- D; xs |-a do { c } : t +-- +-- ---> premap (\ (xs) -> ((xs), ())) c + +dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do + (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids + let env_ty = mkBigCoreVarTupTy env_ids + env_var <- newSysLocalDs env_ty + let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) + return (do_premap ids + env_ty + (mkCorePairTy env_ty unitTy) + res_ty + core_map + core_body, + env_ids') + +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do + let + bound_vars = mkVarSet (collectLStmtBinders stmt) + local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + res_ty + core_stmt + core_stmts, + fv_stmt) + +{- +A statement maps one local environment to another, and is represented +as an arrow from one tuple type to another. A statement sequence is +translated to a composition of such arrows. +-} + +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] + -> DsM (CoreExpr, IdSet) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids + +dsCmdStmt + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> CmdStmt Id -- statement to desugar + -> [Id] -- list of vars in the input to this statement + -- This is typically fed back, + -- so don't pull on it too early + -> DsM (CoreExpr, -- desugared expression + IdSet) -- subset of local vars that occur free + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' +-- ------------------------------ +-- D; xs |-a do { c; ss } : t' +-- +-- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) +-- (first c >>> arr snd) >>> ss + +dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup out_ids)) + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + out_ty = mkBigCoreVarTupTy out_ids + before_c_ty = mkCorePairTy in_ty1 out_ty + after_c_ty = mkCorePairTy c_ty out_ty + snd_fn <- mkSndExpr c_ty out_ty + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 c_ty out_ty core_cmd) $ + do_arr ids after_c_ty out_ty snd_fn, + extendVarSetList fv_cmd out_ids) + +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) +-- ----------------------------------- +-- D; xs |-a do { p <- c; ss } : t' +-- +-- ---> premap (\ (xs) -> (((xs1),()),(xs2))) +-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss +-- +-- It would be simpler and more consistent to do this using second, +-- but that's likely to be defined in terms of first. + +dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd + let + pat_ty = hsLPatType pat + pat_vars = mkVarSet (collectPatBinders pat) + env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars) + env_ty2 = mkBigCoreVarTupTy env_ids2 + + -- multiplexing function + -- \ (xs) -> (((xs1),()),(xs2)) + + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup env_ids2)) + + -- projection function + -- \ (p, (xs2)) -> (zs) + + env_id <- newSysLocalDs env_ty2 + uniqs <- newUniqueSupply + let + after_c_ty = mkCorePairTy pat_ty env_ty2 + out_ty = mkBigCoreVarTupTy out_ids + body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + + fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty + pat_id <- selectSimpleMatchVarL pat + match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr + pair_id <- newSysLocalDs after_c_ty + let + proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) + + -- put it all together + let + in_ty = mkBigCoreVarTupTy env_ids + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy + in_ty2 = mkBigCoreVarTupTy env_ids2 + before_c_ty = mkCorePairTy in_ty1 in_ty2 + return (do_premap ids in_ty before_c_ty out_ty core_mux $ + do_compose ids before_c_ty after_c_ty out_ty + (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ + do_arr ids after_c_ty out_ty proj_expr, + fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars)) + +-- D; xs' |-a do { ss } : t +-- -------------------------------------- +-- D; xs |-a do { let binds; ss } : t +-- +-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss + +dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do + -- build a new environment using the let bindings + core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) + -- match the old environment against the input + core_map <- matchEnv env_ids core_binds + return (do_arr ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy out_ids) + core_map, + exprFreeIds core_binds `intersectVarSet` local_vars) + +-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... +-- D; xs' |-a do { ss' } : t +-- ------------------------------------ +-- D; xs |-a do { rec ss; ss' } : t +-- +-- xs1 = xs' /\ defs(ss) +-- xs2 = xs' - defs(ss) +-- ys1 = ys - defs(ss) +-- ys2 = ys /\ defs(ss) +-- +-- ---> arr (\(xs) -> ((ys1),(xs2))) >>> +-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> +-- arr (\((xs1),(xs2)) -> (xs')) >>> ss' + +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) + env_ids = do + let + env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids + env2_ids = varSetElems env2_id_set + env2_ty = mkBigCoreVarTupTy env2_ids + + -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) + + uniqs <- newUniqueSupply + env2_id <- newSysLocalDs env2_ty + let + later_ty = mkBigCoreVarTupTy later_ids + post_pair_ty = mkCorePairTy later_ty env2_ty + post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + + post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body + + --- loop (...) + + (core_loop, env1_id_set, env1_ids) + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets + + -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) + + let + env1_ty = mkBigCoreVarTupTy env1_ids + pre_pair_ty = mkCorePairTy env1_ty env2_ty + pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) + (mkBigCoreVarTup env2_ids) + + pre_loop_fn <- matchEnv env_ids pre_loop_body + + -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn + + let + env_ty = mkBigCoreVarTupTy env_ids + out_ty = mkBigCoreVarTupTy out_ids + core_body = do_premap ids env_ty pre_pair_ty out_ty + pre_loop_fn + (do_compose ids pre_pair_ty post_pair_ty out_ty + (do_first ids env1_ty later_ty env2_ty + core_loop) + (do_arr ids post_pair_ty out_ty + post_loop_fn)) + + return (core_body, env1_id_set `unionVarSet` env2_id_set) + +dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) + +-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) +-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [CmdLStmt Id] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr Id] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr Id] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do + let + later_id_set = mkVarSet later_ids + rec_id_set = mkVarSet rec_ids + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars + + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) + + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets + let + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets))) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets + later_ty = mkBigCoreVarTupTy later_ids + + rec_tuple = mkBigCoreTup core_rec_rets + rec_ty = mkBigCoreVarTupTy rec_ids + + out_pair = mkCorePairExpr later_tuple rec_tuple + out_pair_ty = mkCorePairTy later_ty rec_ty + + mk_pair_fn <- matchEnv out_ids out_pair + + -- ss + + (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts + + -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) + + rec_id <- newSysLocalDs rec_ty + let + env1_id_set = fv_stmts `minusVarSet` rec_id_set + env1_ids = varSetElems env1_id_set + env1_ty = mkBigCoreVarTupTy env1_ids + in_pair_ty = mkCorePairTy env1_ty rec_ty + core_body = mkBigCoreTup (map selectVar env_ids) + where + selectVar v + | v `elemVarSet` rec_id_set + = mkTupleSelector rec_ids v rec_id (Var rec_id) + | otherwise = Var v + + squash_pair_fn <- matchEnvStack env1_ids rec_id core_body + + -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) + + let + env_ty = mkBigCoreVarTupTy env_ids + core_loop = do_loop ids env1_ty later_ty rec_ty + (do_premap ids in_pair_ty env_ty out_pair_ty + squash_pair_fn + (do_compose ids env_ty out_ty out_pair_ty + core_stmts + (do_arr ids out_ty out_pair_ty mk_pair_fn))) + + return (core_loop, env1_id_set, env1_ids) + +{- +A sequence of statements (as in a rec) is desugared to an arrow between +two environments (no stack) +-} + +dsfixCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt Id] -- statements to desugar + -> DsM (CoreExpr, -- desugared expression + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsfixCmdStmts ids local_vars out_ids stmts + = trimInput (dsCmdStmts ids local_vars out_ids stmts) + +dsCmdStmts + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [Id] -- output vars of these statements + -> [CmdLStmt Id] -- statements to desugar + -> [Id] -- list of vars in the input to these statements + -> DsM (CoreExpr, -- desugared expression + IdSet) -- subset of local vars that occur free + +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids + +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do + let + bound_vars = mkVarSet (collectLStmtBinders stmt) + local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids + return (do_compose ids + (mkBigCoreVarTupTy env_ids) + (mkBigCoreVarTupTy env_ids') + (mkBigCoreVarTupTy out_ids) + core_stmt + core_stmts, + fv_stmt) + +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" + +-- Match a list of expressions against a list of patterns, left-to-right. + +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContext Name -- Match kind + -> [LPat Id] -- Patterns they should match + -> CoreExpr -- Return this if they all match + -> CoreExpr -- Return this if they don't + -> DsM CoreExpr +matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr +matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do + match_code <- matchSimplys exps ctxt pats result_expr fail_expr + matchSimply exp ctxt pat match_code fail_expr +matchSimplys _ _ _ _ _ = panic "matchSimplys" + +-- List of leaf expressions, with set of variables bound in each + +leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] +leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds))) + = let + defined_vars = mkVarSet (collectPatsBinders pats) + `unionVarSet` + mkVarSet (collectLocalBinders binds) + in + [(body, + mkVarSet (collectLStmtsBinders stmts) + `unionVarSet` defined_vars) + | L _ (GRHS stmts body) <- grhss] + +-- Replace the leaf commands in a match + +replaceLeavesMatch + :: Type -- new result type + -> [Located (body' Id)] -- replacement leaf expressions of that type + -> LMatch Id (Located (body Id)) -- the matches of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LMatch Id (Located (body' Id))) -- updated match +replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds))) + = let + (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss + in + (leaves', L loc (Match mf pat mt (GRHSs grhss' binds))) + +replaceLeavesGRHS + :: [Located (body' Id)] -- replacement leaf expressions of that type + -> LGRHS Id (Located (body Id)) -- rhss of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LGRHS Id (Located (body' Id))) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) + = (leaves, L loc (GRHS stmts leaf)) +replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" + +-- Balanced fold of a non-empty list. + +foldb :: (a -> a -> a) -> [a] -> a +foldb _ [] = error "foldb of empty list" +foldb _ [x] = x +foldb f xs = foldb f (fold_pairs xs) + where + fold_pairs [] = [] + fold_pairs [x] = [x] + fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs + +{- +Note [Dictionary binders in ConPatOut] See also same Note in HsUtils +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following functions to collect value variables from patterns are +copied from HsUtils, with one change: we also collect the dictionary +bindings (pat_binds) from ConPatOut. We need them for cases like + +h :: Arrow a => Int -> a (Int,Int) Int +h x = proc (y,z) -> case compare x y of + GT -> returnA -< z+x + +The type checker turns the case into + + case compare x y of + GT { p77 = plusInt } -> returnA -< p77 z x + +Here p77 is a local binding for the (+) operation. + +See comments in HsUtils for why the other version does not include +these bindings. +-} + +collectPatBinders :: LPat Id -> [Id] +collectPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat Id] -> [Id] +collectPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl :: LPat Id -> [Id] -> [Id] +-- See Note [Dictionary binders in ConPatOut] +collectl (L _ pat) bndrs + = go pat + where + go (VarPat var) = var : bndrs + go (WildPat _) = bndrs + go (LazyPat pat) = collectl pat bndrs + go (BangPat pat) = collectl pat bndrs + go (AsPat (L _ a) pat) = a : collectl pat bndrs + go (ParPat pat) = collectl pat bndrs + + go (ListPat pats _ _) = foldr collectl bndrs pats + go (PArrPat pats _) = foldr collectl bndrs pats + go (TuplePat pats _ _) = foldr collectl bndrs pats + + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps, pat_binds=ds}) = + collectEvBinders ds + ++ foldr collectl bndrs (hsConPatArgs ps) + go (LitPat _) = bndrs + go (NPat _ _ _) = bndrs + go (NPlusKPat (L _ n) _ _ _) = n : bndrs + + go (SigPatIn pat _) = collectl pat bndrs + go (SigPatOut pat _) = collectl pat bndrs + go (CoPat _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ pat _) = collectl pat bndrs + go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) + go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) + +collectEvBinders :: TcEvBinds -> [Id] +collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs +collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" + +add_ev_bndr :: EvBind -> [Id] -> [Id] +add_ev_bndr (EvBind b _) bs | isId b = b:bs + | otherwise = bs + -- A worry: what about coercion variable binders?? + +collectLStmtsBinders :: [LStmt Id body] -> [Id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders :: LStmt Id body -> [Id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt Id body -> [Id] +collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt binds) = collectLocalBinders binds +collectStmtBinders (BodyStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders + $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs new file mode 100644 index 00000000..d65cc42c --- /dev/null +++ b/compiler/deSugar/DsBinds.hs @@ -0,0 +1,1200 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching bindings (HsBinds and MonoBinds) + +Handles @HsBinds@; those at the top level require different handling, +in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at +lower levels it is preserved with @let@/@letrec@s). +-} + +{-# LANGUAGE CPP #-} + +module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, + dsHsWrapper, dsTcEvBinds, dsEvBinds + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr( dsLExpr ) +import {-# SOURCE #-} Match( matchWrapper ) + +import DsMonad +import DsGRHSs +import DsUtils + +import HsSyn -- lots of things +import CoreSyn -- lots of things +import Literal ( Literal(MachStr) ) +import CoreSubst +import OccurAnal ( occurAnalyseExpr ) +import MkCore +import CoreUtils +import CoreArity ( etaExpand ) +import CoreUnfold +import CoreFVs +import UniqSupply +import Digraph +import PrelNames +import TysPrim ( mkProxyPrimTy ) +import TyCon ( isTupleTyCon, tyConDataCons_maybe + , tyConName, isPromotedTyCon, isPromotedDataCon, tyConKind ) +import TcEvidence +import TcType +import Type +import Kind (returnsConstraintKind) +import Coercion hiding (substCo) +import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy + , mkBoxedTupleTy, stringTy ) +import Id +import MkId(proxyHashId) +import Class +import DataCon ( dataConTyCon, dataConWorkId ) +import Name +import IdInfo ( IdDetails(..) ) +import Var +import VarSet +import Rules +import VarEnv +import Outputable +import Module +import SrcLoc +import Maybes +import OrdList +import Bag +import BasicTypes hiding ( TopLevel ) +import DynFlags +import FastString +import ErrUtils( MsgDoc ) +import ListSetOps( getNth ) +import Util +import Control.Monad( when ) +import MonadUtils +import Control.Monad(liftM) +import Fingerprint(Fingerprint(..), fingerprintString) + +{- +************************************************************************ +* * +\subsection[dsMonoBinds]{Desugaring a @MonoBinds@} +* * +************************************************************************ +-} + +dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds = ds_lhs_binds binds + +dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] +dsLHsBinds binds = do { binds' <- ds_lhs_binds binds + ; return (fromOL binds') } + +------------------------ +ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) + +ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds + ; return (foldBag appOL id nilOL ds_bs) } + +dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr)) +dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind + +dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) + +dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) + = do { dflags <- getDynFlags + ; core_expr <- dsLExpr expr + + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr + | otherwise = var + + ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) } + +dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches + , fun_co_fn = co_fn, fun_tick = tick + , fun_infix = inf }) + = do { dflags <- getDynFlags + ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches + ; let body' = mkOptTickBox tick body + ; rhs <- dsHsWrapper co_fn (mkLams args body') + ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} + return (unitOL (makeCorePair dflags fun False 0 rhs)) } + +dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty + , pat_ticks = (rhs_tick, var_ticks) }) + = do { body_expr <- dsGuarded grhss ty + ; let body' = mkOptTickBox rhs_tick body_expr + ; sel_binds <- mkSelectorBinds var_ticks pat body' + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter + ; return (toOL sel_binds) } + + -- A common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings, and recursive bindings + -- that have been chopped up with type signatures +dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = [export] + , abs_ev_binds = ev_binds, abs_binds = binds }) + | ABE { abe_wrap = wrap, abe_poly = global + , abe_mono = local, abe_prags = prags } <- export + = do { dflags <- getDynFlags + ; bind_prs <- ds_lhs_binds binds + ; let core_bind = Rec (fromOL bind_prs) + ; ds_binds <- dsTcEvBinds ev_binds + ; rhs <- dsHsWrapper wrap $ -- Usually the identity + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_binds $ + Let core_bind $ + Var local + + ; (spec_binds, rules) <- dsSpecs rhs prags + + ; let global' = addIdSpecialisations global rules + main_bind = makeCorePair dflags global' (isDefaultMethod prags) + (dictArity dicts) rhs + + ; return (main_bind `consOL` spec_binds) } + +dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports, abs_ev_binds = ev_binds + , abs_binds = binds }) + -- See Note [Desugaring AbsBinds] + = do { dflags <- getDynFlags + ; bind_prs <- ds_lhs_binds binds + ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- fromOL bind_prs ] + -- Monomorphic recursion possible, hence Rec + + locals = map abe_mono exports + tup_expr = mkBigCoreVarTup locals + tup_ty = exprType tup_expr + ; ds_binds <- dsTcEvBinds ev_binds + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_binds $ + Let core_bind $ + tup_expr + + ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) + + ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + = do { tup_id <- newSysLocalDs tup_ty + ; rhs <- dsHsWrapper wrap $ + mkLams tyvars $ mkLams dicts $ + mkTupleSelector locals local tup_id $ + mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. + ; return ((global', rhs) `consOL` spec_binds) } + + ; export_binds_s <- mapM mk_bind exports + + ; return ((poly_tup_id, poly_tup_rhs) `consOL` + concatOL export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id + +dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind" + +------------------------ +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) + + | DFunId _ is_newtype <- idDetails gbl_id + = (mk_dfun_w_stuff is_newtype, rhs) + + | otherwise + = case inlinePragmaSpec inline_prag of + EmptyInlineSpec -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair + + where + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding dflags rhs + inline_pair + | Just arity <- inlinePragmaSat inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + arity + -- NB: The arity in the InlineRule takes account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs) + + -- See Note [ClassOp/DFun selection] in TcInstDcls + -- See Note [Single-method classes] in TcInstDcls + mk_dfun_w_stuff is_newtype + | is_newtype + = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs + `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args + `setInlinePragma` dfunInlinePragma + (dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs) + (dfun_con, dfun_args) = collectArgs dfun_body + dfun_constr | Var id <- dfun_con + , DataConWorkId con <- idDetails id + = con + | otherwise = pprPanic "makeCorePair: dfun" (ppr rhs) + + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +{- +[Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + +Note [Rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Common special case: no type or dictionary abstraction +This is a bit less trivial than you might suppose +The naive way woudl be to desguar to something like + f_lcl = ...f_lcl... -- The "binds" from AbsBinds + M.f = f_lcl -- Generated from "exports" +But we don't want that, because if M.f isn't exported, +it'll be inlined unconditionally at every call site (its rhs is +trivial). That would be ok unless it has RULES, which would +thereby be completely lost. Bad, bad, bad. + +Instead we want to generate + M.f = ...f_lcl... + f_lcl = M.f +Now all is cool. The RULES are attached to M.f (by SimplCore), +and f_lcl is rapidly inlined away. + +This does not happen in the same way to polymorphic binds, +because they desugar to + M.f = /\a. let f_lcl = ...f_lcl... in f_lcl +Although I'm a bit worried about whether full laziness might +float the f_lcl binding out and then inline M.f at its call site + +Note [Specialising in no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even if there are no tyvars or dicts, we may have specialisation pragmas. +Class methods can generate + AbsBinds [] [] [( ... spec-prag] + { AbsBinds [tvs] [dicts] ...blah } +So the overloading is in the nested AbsBinds. A good example is in GHC.Float: + + class (Real a, Fractional a) => RealFrac a where + round :: (Integral b) => a -> b + + instance RealFrac Float where + {-# SPECIALIZE round :: Float -> Int #-} + +The top-level AbsBinds for $cround has no tyvars or dicts (because the +instance does not). But the method is locally overloaded! + +Note [Abstracting over tyvars only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When abstracting over type variable only (not dictionaries), we don't really need to +built a tuple and select from it, as we do in the general case. Instead we can take + + AbsBinds [a,b] [ ([a,b], fg, fl, _), + ([b], gg, gl, _) ] + { fl = e1 + gl = e2 + h = e3 } + +and desugar it to + + fg = /\ab. let B in e1 + gg = /\b. let a = () in let B in S(e2) + h = /\ab. let B in e3 + +where B is the *non-recursive* binding + fl = fg a b + gl = gg b + h = h a b -- See (b); note shadowing! + +Notice (a) g has a different number of type variables to f, so we must + use the mkArbitraryType thing to fill in the gaps. + We use a type-let to do that. + + (b) The local variable h isn't in the exports, and rather than + clone a fresh copy we simply replace h by (h a b), where + the two h's have different types! Shadowing happens here, + which looks confusing but works fine. + + (c) The result is *still* quadratic-sized if there are a lot of + small bindings. So if there are more than some small + number (10), we filter the binding set B by the free + variables of the particular RHS. Tiresome. + +Why got to this trouble? It's a common case, and it removes the +quadratic-sized tuple desugaring. Less clutter, hopefully faster +compilation, especially in a case where there are a *lot* of +bindings. + + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we pre-emptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + +Note [Implementing SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + f = + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + +Note that wrap_fn can transform *any* function with the right type prefix + forall ab. (Eq a, Ix b) => XXX +regardless of XXX. It's sort of polymorphic in XXX. This is +useful: we use the same wrapper to transform each of the class ops, as +well as the dict. + +From these we generate: + + Rule: forall p, q, (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $dfIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec, has a *copy* of 'binds', so that it + can fully specialise it. +-} + +------------------------ +dsSpecs :: CoreExpr -- Its rhs + -> TcSpecPrags + -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Implementing SPECIALISE pragmas] +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding + -- Nothing => RULE is for an imported Id + -- rhs is in the Id's unfolding + -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + | isJust (isClassOpId_maybe poly_id) + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") + <+> quotes (ppr poly_id)) + ; return Nothing } -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + + | no_act_spec && isNeverActive rule_act + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:") + <+> quotes (ppr poly_id)) + ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + -- See Note [Activation pragmas for SPECIALISE] + + | otherwise + = putSrcSpanDs loc $ + do { uniq <- newUnique + ; let poly_name = idName poly_id + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) + ; (bndrs, ds_lhs) <- liftM collectBinders + (dsHsWrapper spec_co (Var poly_id)) + ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) + ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id + -- , ptext (sLit "spec_co:") <+> ppr spec_co + -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $ + case decomposeRuleLhs bndrs ds_lhs of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (rule_bndrs, _fn, args) -> do + + { dflags <- getDynFlags + ; let fn_unf = realIdUnfolding poly_id + unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet + in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args) + spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf + spec_id = mkLocalId spec_name spec_ty + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + rule = mkRule False {- Not auto -} is_local_id + (mkFastString ("SPEC " ++ showPpr dflags poly_name)) + rule_act poly_name + rule_bndrs args + (mkVarApps (Var spec_id) bndrs) + + ; spec_rhs <- dsHsWrapper spec_co poly_rhs + + ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) + (warnDs (specOnInline poly_name)) + + ; return (Just (unitOL (spec_id, spec_rhs), rule)) + -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because + -- makeCorePair overwrites the unfolding, which we have + -- just created using specUnfolding + } } } + where + is_local_id = isJust mb_poly_rhs + poly_rhs | Just rhs <- mb_poly_rhs + = rhs -- Local Id; this is its rhs + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- The type checker has checked that it *has* an unfolding + + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + + +specOnInline :: Name -> MsgDoc +specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") + <+> quotes (ppr f) + +{- +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overriden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see Trac #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + +************************************************************************ +* * +\subsection{Adding inline pragmas} +* * +************************************************************************ +-} + +decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) +-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, +-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs +-- may add some extra dictionary binders (see Note [Free dictionaries]) +-- +-- Returns Nothing if the LHS isn't of the expected shape +-- Note [Decomposing the left-hand side of a RULE] +decomposeRuleLhs orig_bndrs orig_lhs + | not (null unbound) -- Check for things unbound on LHS + -- See Note [Unused spec binders] + = Left (vcat (map dead_msg unbound)) + + | Just (fn_id, args) <- decompose fun2 args2 + , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args + = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs + -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs + -- , ptext (sLit "lhs1:") <+> ppr lhs1 + -- , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs + -- , ptext (sLit "fn_id:") <+> ppr fn_id + -- , ptext (sLit "args:") <+> ppr args]) $ + Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args) + + | otherwise + = Left bad_shape_msg + where + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + + lhs_fvs = exprFreeVars lhs2 + unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs + + orig_bndr_set = mkVarSet orig_bndrs + + -- Add extra dict binders: Note [Free dictionaries] + mk_extra_dict_bndrs fn_id args + = [ mkLocalId (localiseName (idName d)) (idType d) + | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs)) + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, Trac #10251) + , isDictId d ] + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose _ _ = Nothing + + bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) + 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 + , text "Orig lhs:" <+> ppr orig_lhs]) + dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr + , ptext (sLit "is not bound in RULE lhs")]) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "optimised lhs:" <+> ppr lhs2 ]) + pp_bndr bndr + | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) + | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred) + | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) + + drop_dicts :: CoreExpr -> CoreExpr + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets e + | Let (NonRec d r) body <- e + , isDictId d + , (bs, body') <- split_lets body + = ((d,r):bs, body') + | otherwise + = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d + +{- +Note [Decomposing the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several things going on here. +* drop_dicts: see Note [Drop dictionary bindings on rule LHS] +* simpleOptExpr: see Note [Simplify rule LHS] +* extra_dict_bndrs: see Note [Free dictionaries] + +Note [Drop dictionary bindings on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +drop_dicts drops dictionary bindings on the LHS where possible. + E.g. let d:Eq [Int] = $fEqList $fEqInt in f d + --> f d + Reasoning here is that there is only one d:Eq [Int], and so we can + quantify over it. That makes 'd' free in the LHS, but that is later + picked up by extra_dict_bndrs (Note [Dead spec binders]). + + NB 1: We can only drop the binding if the RHS doesn't bind + one of the orig_bndrs, which we assume occur on RHS. + Example + f :: (Eq a) => b -> a -> a + {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} + Here we want to end up with + RULE forall d:Eq a. f ($dfEqList d) = f_spec d + Of course, the ($dfEqlist d) in the pattern makes it less likely + to match, but ther is no other way to get d:Eq a + + NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all + the evidence bindings to be wrapped around the outside of the + LHS. (After simplOptExpr they'll usually have been inlined.) + dsHsWrapper does dependency analysis, so that civilised ones + will be simple NonRec bindings. We don't handle recursive + dictionaries! + + NB3: In the common case of a non-overloaded, but perhaps-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (Trac #8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadBstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + + Trac #8848 is a good example of where there are some intersting + dictionary bindings to discard. + +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + +Note [Simplify rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~ +simplOptExpr occurrence-analyses and simplifies the LHS: + + (a) Inline any remaining dictionary bindings (which hopefully + occur just once) + + (b) Substitute trivial lets so that they don't get in the way + Note that we substitute the function too; we might + have this as a LHS: let f71 = M.f Int in f71 + + (c) Do eta reduction. To see why, consider the fold/build rule, + which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... + This doesn't match unless you do eta reduction on the build argument. + Similarly for a LHS like + augment g (build h) + we do not want to get + augment (\a. g a) (build h) + otherwise we don't match when given an argument like + augment (\a. h a a) (build h) + +Note [Matching seqId] +~~~~~~~~~~~~~~~~~~~ +The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack +and this code turns it back into an application of seq! +See Note [Rules for seq] in MkId for the details. + +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + ... SPECIALISE f :: Eq a => a -> a ... +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, because it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, because +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [Free dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + ... SPECIALISE f :: Int -> Int ... + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have an InlineRule or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + + +************************************************************************ +* * + Desugaring evidence +* * +************************************************************************ + +-} + +dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr +dsHsWrapper WpHole e = return e +dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) +dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds + return (mkCoreLets bs e) +dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e + ; dsHsWrapper c1 e1 } +dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1 + ; e1 <- dsHsWrapper c1 (Var x) + ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1) + ; return (Lam x e2) } +dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational) + dsTcCoercion co (mkCast e) +dsHsWrapper (WpEvLam ev) e = return $ Lam ev e +dsHsWrapper (WpTyLam tv) e = return $ Lam tv e +dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm) + +-------------------------------------- +dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds (EvBinds bs) = dsEvBinds bs + +dsEvBinds :: Bag EvBind -> DsM [CoreBind] +dsEvBinds bs = mapM ds_scc (sccEvBinds bs) + where + ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r) + ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs) + + ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r) + +sccEvBinds :: Bag EvBind -> [SCC EvBind] +sccEvBinds bs = stronglyConnCompFromEdgedVertices edges + where + edges :: [(EvBind, EvVar, [EvVar])] + edges = foldrBag ((:) . mk_node) [] bs + + mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) + mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term)) + + +--------------------------------------- +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvId v) = return (Var v) + +dsEvTerm (EvCast tm co) + = do { tm' <- dsEvTerm tm + ; dsTcCoercion co $ mkCast tm' } + -- 'v' is always a lifted evidence variable so it is + -- unnecessary to call varToCoreExpr v here. + +dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms + ; return (Var df `mkTyApps` tys `mkApps` tms') } + +dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] +dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox + +dsEvTerm (EvTupleSel tm n) + = do { tup <- dsEvTerm tm + ; let scrut_ty = exprType tup + (tc, tys) = splitTyConApp scrut_ty + Just [dc] = tyConDataCons_maybe tc + xs = mkTemplateLocals tys + the_x = getNth xs n + ; ASSERT( isTupleTyCon tc ) + return $ + Case tup (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } + +dsEvTerm (EvTupleMk tms) + = do { tms' <- mapM dsEvTerm tms + ; let tys = map exprType tms' + ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' } + where + dc = tupleCon ConstraintTuple (length tms) + +dsEvTerm (EvSuperClass d n) + = do { d' <- dsEvTerm d + ; let (cls, tys) = getClassPredTys (exprType d') + sc_sel_id = classSCSelId cls n -- Zero-indexed + ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } + where + +dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where + errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr (fastStringToByteString msg)) + +dsEvTerm (EvLit l) = + case l of + EvNum n -> mkIntegerExpr n + EvStr s -> mkStringExprFS s + +dsEvTerm (EvTypeable ev) = dsEvTypeable ev + +dsEvTerm (EvCallStack cs) = dsEvCallStack cs + +dsEvTypeable :: EvTypeable -> DsM CoreExpr +dsEvTypeable ev = + do tyCl <- dsLookupTyCon typeableClassName + typeRepTc <- dsLookupTyCon typeRepTyConName + let tyRepType = mkTyConApp typeRepTc [] + + (ty, rep) <- + case ev of + + EvTypeableTyCon tc ks -> + do ctr <- dsLookupGlobalId mkPolyTyConAppName + mkTyCon <- dsLookupGlobalId mkTyConName + dflags <- getDynFlags + let mkRep cRep kReps tReps = + mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps + , mkListExpr tyRepType tReps ] + + let kindRep k = + case splitTyConApp_maybe k of + Nothing -> panic "dsEvTypeable: not a kind constructor" + Just (kc,ks) -> + do kcRep <- tyConRep dflags mkTyCon kc + reps <- mapM kindRep ks + return (mkRep kcRep [] reps) + + tcRep <- tyConRep dflags mkTyCon tc + + kReps <- mapM kindRep ks + + return ( mkTyConApp tc ks + , mkRep tcRep kReps [] + ) + + EvTypeableTyApp t1 t2 -> + do e1 <- getRep tyCl t1 + e2 <- getRep tyCl t2 + ctr <- dsLookupGlobalId mkAppTyName + + return ( mkAppTy (snd t1) (snd t2) + , mkApps (Var ctr) [ e1, e2 ] + ) + + EvTypeableTyLit ty -> + do str <- case (isNumLitTy ty, isStrLitTy ty) of + (Just n, _) -> return (show n) + (_, Just n) -> return (show n) + _ -> panic "dsEvTypeable: malformed TyLit evidence" + ctr <- dsLookupGlobalId typeLitTypeRepName + tag <- mkStringExpr str + return (ty, mkApps (Var ctr) [ tag ]) + + -- TyRep -> Typeable t + -- see also: Note [Memoising typeOf] + repName <- newSysLocalDs tyRepType + let proxyT = mkProxyPrimTy (typeKind ty) ty + method = bindNonRec repName rep + $ mkLams [mkWildValBinder proxyT] (Var repName) + + -- package up the method as `Typeable` dictionary + return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty + + where + -- co: method -> Typeable k t + getTypeableCo tc t = + case instNewTyCon_maybe tc [typeKind t, t] of + Just (_,co) -> co + _ -> panic "Class `Typeable` is not a `newtype`." + + -- Typeable t -> TyRep + getRep tc (ev,t) = + do typeableExpr <- dsEvTerm ev + let co = getTypeableCo tc t + method = mkCast typeableExpr co + proxy = mkTyApps (Var proxyHashId) [typeKind t, t] + return (mkApps method [proxy]) + + -- This part could be cached + tyConRep dflags mkTyCon tc = + do pkgStr <- mkStringExprFS pkg_fs + modStr <- mkStringExprFS modl_fs + nameStr <- mkStringExprFS name_fs + return (mkApps (Var mkTyCon) [ int64 high, int64 low + , pkgStr, modStr, nameStr + ]) + where + tycon_name = tyConName tc + modl = nameModule tycon_name + pkg = modulePackageKey modl + + modl_fs = moduleNameFS (moduleName modl) + pkg_fs = packageKeyFS pkg + name_fs = occNameFS (nameOccName tycon_name) + hash_name_fs + | isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs + | isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs + | isTupleTyCon tc && + returnsConstraintKind (tyConKind tc) + = appendFS (mkFastString "$p") name_fs + | otherwise = name_fs + + hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs] + Fingerprint high low = fingerprintString hashThis + + int64 + | wORD_SIZE dflags == 4 = mkWord64LitWord64 + | otherwise = mkWordLit dflags . fromIntegral + + + +{- Note [Memoising typeOf] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #3245, #9203 + +IMPORTANT: we don't want to recalculate the TypeRep once per call with +the proxy argument. This is what went wrong in #3245 and #9203. So we +help GHC by manually keeping the 'rep' *outside* the lambda. +-} + +dsEvCallStack :: EvCallStack -> DsM CoreExpr +-- See Note [Overview of implicit CallStacks] in TcEvidence.hs +dsEvCallStack cs = do + df <- getDynFlags + m <- getModule + srcLocDataCon <- dsLookupDataCon srcLocDataConName + let srcLocTyCon = dataConTyCon srcLocDataCon + let srcLocTy = mkTyConTy srcLocTyCon + let mkSrcLoc l = + liftM (mkCoreConApps srcLocDataCon) + (sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey m) + , mkStringExprFS (moduleNameFS $ moduleName m) + , mkStringExprFS (srcSpanFile l) + , return $ mkIntExprInt df (srcSpanStartLine l) + , return $ mkIntExprInt df (srcSpanStartCol l) + , return $ mkIntExprInt df (srcSpanEndLine l) + , return $ mkIntExprInt df (srcSpanEndCol l) + ]) + + let callSiteTy = mkBoxedTupleTy [stringTy, srcLocTy] + + matchId <- newSysLocalDs $ mkListTy callSiteTy + + callStackDataCon <- dsLookupDataCon callStackDataConName + let callStackTyCon = dataConTyCon callStackDataCon + let callStackTy = mkTyConTy callStackTyCon + let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy] + let pushCS name loc rest = + mkWildCase rest callStackTy callStackTy + [( DataAlt callStackDataCon + , [matchId] + , mkCoreConApps callStackDataCon + [mkConsExpr callSiteTy + (mkCoreTup [name, loc]) + (Var matchId)] + )] + let mkPush name loc tm = do + nameExpr <- mkStringExprFS name + locExpr <- mkSrcLoc loc + case tm of + EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS) + _ -> do tmExpr <- dsEvTerm tm + -- at this point tmExpr :: IP sym CallStack + -- but we need the actual CallStack to pass to pushCS, + -- so we use unwrapIP to strip the dictionary wrapper + -- See Note [Overview of implicit CallStacks] + let ip_co = unwrapIP (exprType tmExpr) + return (pushCS nameExpr locExpr (mkCast tmExpr ip_co)) + case cs of + EvCsTop name loc tm -> mkPush name loc tm + EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm + EvCsEmpty -> panic "Cannot have an empty CallStack" + +--------------------------------------- +dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr +-- This is the crucial function that moves +-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion +-- e.g. dsTcCoercion (trans g1 g2) k +-- = case g1 of EqBox g1# -> +-- case g2 of EqBox g2# -> +-- k (trans g1# g2#) +-- thing_inside will get a coercion at the role requested +dsTcCoercion co thing_inside + = do { us <- newUniqueSupply + ; let eqvs_covs :: [(EqVar,CoVar)] + eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) + (uniqsFromSupply us) + + subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] + result_expr = thing_inside (ds_tc_coercion subst co) + result_ty = exprType result_expr + + ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } + where + mk_co_var :: Id -> Unique -> (Id, Id) + mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc) + where + eq_nm = idName eqv + occ = nameOccName eq_nm + loc = nameSrcSpan eq_nm + ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2 + (ty1, ty2) = getEqPredTys (evVarPred eqv) + + wrap_in_case result_ty (eqv, cov) body + = case getEqPredRole (evVarPred eqv) of + Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] + Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)] + Phantom -> panic "wrap_in_case/phantom" + +ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion +-- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b) +-- the result is of type (a ~# b) (reps. a ~# b) +-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on) +-- No need for InScope set etc because the +ds_tc_coercion subst tc_co + = go tc_co + where + go (TcRefl r ty) = Refl r (Coercion.substTy subst ty) + go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos) + go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2) + go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co) + where + (subst', tv') = Coercion.substTyVarBndr subst tv + go (TcAxiomInstCo ax ind cos) + = AxiomInstCo ax ind (map go cos) + go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2 + go (TcSymCo co) = mkSymCo (go co) + go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) + go (TcNthCo n co) = mkNthCo n (go co) + go (TcLRCo lr co) = mkLRCo lr (go co) + go (TcSubCo co) = mkSubCo (go co) + go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co + go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) + go (TcCoVarCo v) = ds_ev_id subst v + go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs) + go (TcCoercion co) = co + + ds_co_binds :: TcEvBinds -> CvSubst + ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs) + ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb) + + ds_scc :: CvSubst -> SCC EvBind -> CvSubst + ds_scc subst (AcyclicSCC (EvBind v ev_term)) + = extendCvSubstAndInScope subst v (ds_co_term subst ev_term) + ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co) + + ds_co_term :: CvSubst -> EvTerm -> Coercion + ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co + ds_co_term subst (EvId v) = ds_ev_id subst v + ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co) + ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co) + + ds_ev_id :: CvSubst -> EqVar -> Coercion + ds_ev_id subst v + | Just co <- Coercion.lookupCoVar subst v = co + | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co) + +{- +Note [Simple coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +We have a special case for coercions that are simple variables. +Suppose cv :: a ~ b is in scope +Lacking the special case, if we see + f a b cv +we'd desguar to + f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#) +which is a bit stupid. The special case does the obvious thing. + +This turns out to be important when desugaring the LHS of a RULE +(see Trac #7837). Suppose we have + normalise :: (a ~ Scalar a) => a -> a + normalise_Double :: Double -> Double + {-# RULES "normalise" normalise = normalise_Double #-} + +Then the RULE we want looks like + forall a, (cv:a~Scalar a). + normalise a cv = normalise_Double +But without the special case we generate the redundant box/unbox, +which simpleOpt (currently) doesn't remove. So the rule never matches. + +Maybe simpleOpt should be smarter. But it seems like a good plan +to simply never generate the redundant box/unbox in the first place. +-} diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs new file mode 100644 index 00000000..5c5fde0b --- /dev/null +++ b/compiler/deSugar/DsCCall.hs @@ -0,0 +1,382 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Desugaring foreign calls +-} + +{-# LANGUAGE CPP #-} +module DsCCall + ( dsCCall + , mkFCall + , unboxArg + , boxResult + , resultWrapper + ) where + +#include "HsVersions.h" + + +import CoreSyn + +import DsMonad + +import CoreUtils +import MkCore +import Var +import MkId +import ForeignCall +import DataCon + +import TcType +import Type +import Coercion +import PrimOp +import TysPrim +import TyCon +import TysWiredIn +import BasicTypes +import Literal +import PrelNames +import VarSet +import DynFlags +import Outputable +import Util + +import Data.Maybe + +{- +Desugaring of @ccall@s consists of adding some state manipulation, +unboxing any boxed primitive arguments and boxing the result if +desired. + +The state stuff just consists of adding in +@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. + +The unboxing is straightforward, as all information needed to unbox is +available from the type. For each boxed-primitive argument, we +transform: +\begin{verbatim} + _ccall_ foo [ r, t1, ... tm ] e1 ... em + | + | + V + case e1 of { T1# x1# -> + ... + case em of { Tm# xm# -> xm# + ccall# foo [ r, t1#, ... tm# ] x1# ... xm# + } ... } +\end{verbatim} + +The reboxing of a @_ccall_@ result is a bit tricker: the types don't +contain information about the state-pairing functions so we have to +keep a list of \tr{(type, s-p-function)} pairs. We transform as +follows: +\begin{verbatim} + ccall# foo [ r, t1#, ... tm# ] e1# ... em# + | + | + V + \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of + (StateAnd# result# state#) -> (R# result#, realWorld#) +\end{verbatim} +-} + +dsCCall :: CLabelString -- C routine to invoke + -> [CoreExpr] -- Arguments (desugared) + -> Safety -- Safety of the call + -> Type -- Type of the result: IO t + -> DsM CoreExpr -- Result, of type ??? + +dsCCall lbl args may_gc result_ty + = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args + (ccall_result_ty, res_wrapper) <- boxResult result_ty + uniq <- newUnique + dflags <- getDynFlags + let + target = StaticTarget lbl Nothing True + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty + return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + +mkFCall :: DynFlags -> Unique -> ForeignCall + -> [CoreExpr] -- Args + -> Type -- Result type + -> CoreExpr +-- Construct the ccall. The only tricky bit is that the ccall Id should have +-- no free vars, so if any of the arg tys do we must give it a polymorphic type. +-- [I forget *why* it should have no free vars!] +-- For example: +-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char] +-- +-- Here we build a ccall thus +-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) +-- a b s x c +mkFCall dflags uniq the_fcall val_args res_ty + = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + where + arg_tys = map exprType val_args + body_ty = (mkFunTys arg_tys res_ty) + tyvars = varSetElems (tyVarsOfType body_ty) + ty = mkForAllTys tyvars body_ty + the_fcall_id = mkFCallId dflags uniq the_fcall ty + +unboxArg :: CoreExpr -- The supplied argument + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +-- Example: if the arg is e::Int, unboxArg will return +-- (x#::Int#, \W. case x of I# x# -> W) +-- where W is a CoreExpr that probably mentions x# + +unboxArg arg + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxArg (mkCast arg co) + + -- Booleans + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = do dflags <- getDynFlags + prim_arg <- newSysLocalDs intPrimTy + return (Var prim_arg, + \ body -> Case (mkWildCase arg arg_ty intPrimTy + [(DataAlt falseDataCon,[],mkIntLit dflags 0), + (DataAlt trueDataCon, [],mkIntLit dflags 1)]) + -- In increasing tag order! + prim_arg + (exprType body) + [(DEFAULT,[],body)]) + + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty) + -- Typechecker ensures this + do case_bndr <- newSysLocalDs arg_ty + prim_arg <- newSysLocalDs data_con_arg_ty1 + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3 && + isJust maybe_arg3_tycon && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 + Just arg3_tycon = maybe_arg3_tycon + +boxResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) + +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for an side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; let extra_result_tys + = case res of + (Just ty,_) + | isUnboxedTupleType ty + -> let Just ls = tyConAppArgs_maybe ty in tail ls + _ -> [] + + return_result state anss + = mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys)) + (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) + ++ (state : anss)) + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } + +boxResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- resultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) + where + return_result _ [ans] = ans + return_result _ _ = panic "return_result: expected single result" + + +mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, (AltCon, [Id], Expr Var)) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + [wrap_result (panic "boxResult")] + + ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] + the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) + + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + -- The ccall returns a non-() value + | isUnboxedTupleType prim_res_ty= do + let + Just ls = tyConAppArgs_maybe prim_res_ty + arity = 1 + length ls + args_ids@(result_id:as) <- mapM newSysLocalDs ls + state_id <- newSysLocalDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id) : map Var as) + ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity) + (realWorldStatePrimTy : ls) + the_alt = ( DataAlt (tupleCon UnboxedTuple arity) + , (state_id : args_ids) + , the_rhs + ) + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalDs prim_res_ty + state_id <- newSysLocalDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + [wrap_result (Var result_id)] + ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] + the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) + return (ccall_res_ty, the_alt) + + +resultWrapper :: Type + -> DsM (Maybe Type, -- Type of the expected result, if any + CoreExpr -> CoreExpr) -- Wrapper for the result +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +resultWrapper result_ty + -- Base case 1: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey + = do + dflags <- getDynFlags + return + (Just intPrimTy, \e -> mkWildCase e intPrimTy + boolTy + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)]) + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do (maybe_ty, wrapper) <- resultWrapper rep_ty + return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co)) + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTy_maybe result_ty + = do (maybe_ty, wrapper) <- resultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty, + dataConSourceArity data_con == 1 + = do dflags <- getDynFlags + let + (unwrapped_res_ty : _) = data_con_arg_tys + narrow_wrapper = maybeNarrow dflags tycon + (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)])) + + | otherwise + = pprPanic "resultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- When the result of a foreign call is smaller than the word size, we +-- need to sign- or zero-extend the result up to the word size. The C +-- standard appears to say that this is the responsibility of the +-- caller, not the callee. + +maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow dflags tycon + | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e + | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e + | tycon `hasKey` int32TyConKey + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + + | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e + | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e + | tycon `hasKey` word32TyConKey + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + | otherwise = id diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs new file mode 100644 index 00000000..0cd609e8 --- /dev/null +++ b/compiler/deSugar/DsExpr.hs @@ -0,0 +1,979 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring exporessions. +-} + +{-# LANGUAGE CPP #-} + +module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where + +#include "HsVersions.h" + +import Match +import MatchLit +import DsBinds +import DsGRHSs +import DsListComp +import DsUtils +import DsArrows +import DsMonad +import Name +import NameEnv +import FamInstEnv( topNormaliseType ) + +#ifdef GHCI + -- Template Haskell stuff iff bootstrapped +import DsMeta +#endif + +import HsSyn + +import Platform +-- NB: The desugarer, which straddles the source and Core worlds, sometimes +-- needs to see source types +import TcType +import Coercion ( Role(..) ) +import TcEvidence +import TcRnMonad +import Type +import CoreSyn +import CoreUtils +import CoreFVs +import MkCore + +import DynFlags +import CostCentre +import Id +import Module +import VarSet +import VarEnv +import ConLike +import DataCon +import TysWiredIn +import PrelNames +import BasicTypes +import Maybes +import SrcLoc +import Util +import Bag +import Outputable +import FastString + +import IdInfo +import Data.IORef ( atomicModifyIORef, modifyIORef ) + +import Control.Monad +import GHC.Fingerprint + +{- +************************************************************************ +* * + dsLocalBinds, dsValBinds +* * +************************************************************************ +-} + +dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds EmptyLocalBinds body = return body +dsLocalBinds (HsValBinds binds) body = dsValBinds binds body +dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body + +------------------------- +dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr +dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds +dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn" + +------------------------- +dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr +dsIPBinds (IPBinds ip_binds ev_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body + -- The dict bindings may not be in + -- dependency order; hence Rec + ; foldrM ds_ip_bind inner ip_binds } + where + ds_ip_bind (L _ (IPBind ~(Right n) e)) body + = do e' <- dsLExpr e + return (Let (NonRec n e') body) + +------------------------- +ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr +-- Special case for bindings which bind unlifted variables +-- We need to do a case right away, rather than building +-- a tuple and doing selections. +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind (NonRecursive, hsbinds) body + | [L loc bind] <- bagToList hsbinds, + -- Non-recursive, non-overloaded bindings only come in ones + -- ToDo: in some bizarre case it's conceivable that there + -- could be dict binds in the 'binds'. (See the notes + -- below. Then pattern-match would fail. Urk.) + strictMatchOnly bind + = putSrcSpanDs loc (dsStrictBind bind body) + +-- Ordinary case for bindings; none should be unlifted +ds_val_bind (_is_rec, binds) body + = do { prs <- dsLHsBinds binds + ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds ) + case prs of + [] -> return body + _ -> return (Let (Rec prs) body) } + -- Use a Rec regardless of is_rec. + -- Why? Because it allows the binds to be all + -- mixed up, which is what happens in one rare case + -- Namely, for an AbsBind with no tyvars and no dicts, + -- but which does have dictionary bindings. + -- See notes with TcSimplify.inferLoop [NO TYVARS] + -- It turned out that wrapping a Rec here was the easiest solution + -- + -- NB The previous case dealt with unlifted bindings, so we + -- only have to deal with lifted ones now; so Rec is ok + +------------------ +dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr +dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds }) body + = do { let body1 = foldr bind_export body exports + bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b + ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body) + body1 lbinds + ; ds_binds <- dsTcEvBinds ev_binds + ; return (mkCoreLets ds_binds body2) } + +dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn + , fun_tick = tick, fun_infix = inf }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches + ; MASSERT( null args ) -- Functions aren't lifted + ; MASSERT( isIdHsWrapper co_fn ) + ; let rhs' = mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs <- dsGuarded grhss ty + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar upat + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (bindNonRec var rhs result) } + +dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +---------------------- +strictMatchOnly :: HsBind Id -> Bool +strictMatchOnly (AbsBinds { abs_binds = lbinds }) + = anyBag (strictMatchOnly . unLoc) lbinds +strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty }) + = isUnLiftedType rhs_ty + || isStrictLPat lpat + || any (isUnLiftedType . idType) (collectPatBinders lpat) +strictMatchOnly (FunBind { fun_id = L _ id }) + = isUnLiftedType (idType id) +strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact + +{- +************************************************************************ +* * +\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} +* * +************************************************************************ +-} + +dsLExpr :: LHsExpr Id -> DsM CoreExpr + +dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e + +dsExpr :: HsExpr Id -> DsM CoreExpr +dsExpr (HsPar e) = dsLExpr e +dsExpr (ExprWithTySigOut e _) = dsLExpr e +dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] +dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" +dsExpr (HsLit lit) = dsLit lit +dsExpr (HsOverLit lit) = dsOverLit lit + +dsExpr (HsWrap co_fn e) + = do { e' <- dsExpr e + ; wrapped_e <- dsHsWrapper co_fn e' + ; dflags <- getDynFlags + ; warnAboutIdentities dflags e' (exprType wrapped_e) + ; return wrapped_e } + +dsExpr (NegApp expr neg_expr) + = App <$> dsExpr neg_expr <*> dsLExpr expr + +dsExpr (HsLam a_Match) + = uncurry mkLams <$> matchWrapper LambdaExpr a_Match + +dsExpr (HsLamCase arg matches) + = do { arg_var <- newSysLocalDs arg + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches + ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } + +dsExpr (HsApp fun arg) + = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + +dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" + +{- +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + +Operator sections. At first it looks as if we can convert +\begin{verbatim} + (expr op) +\end{verbatim} +to +\begin{verbatim} + \x -> op expr x +\end{verbatim} + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider +\begin{verbatim} + map (expr op) xs +\end{verbatim} +for example. So we convert instead to +\begin{verbatim} + let y = expr in \x -> op y x +\end{verbatim} +If \tr{expr} is actually just a variable, say, then the simplifier +will sort it out. +-} + +dsExpr (OpApp e1 op _ e2) + = -- for the type of y, we need the type of op's 2nd argument + mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2] + +dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) + = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr + +-- dsLExpr (SectionR op expr) -- \ x -> op x expr +dsExpr (SectionR op expr) = do + core_op <- dsLExpr op + -- for the type of x, we need the type of op's 2nd argument + let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + -- See comment with SectionL + y_core <- dsLExpr expr + x_id <- newSysLocalDs x_ty + y_id <- newSysLocalDs y_ty + return (bindNonRec y_id y_core $ + Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) + +dsExpr (ExplicitTuple tup_args boxity) + = do { let go (lam_vars, args) (L _ (Missing ty)) + -- For every missing expression, we need + -- another lambda in the desugaring. + = do { lam_var <- newSysLocalDs ty + ; return (lam_var : lam_vars, Var lam_var : args) } + go (lam_vars, args) (L _ (Present expr)) + -- Expressions that are present don't generate + -- lambdas, just arguments. + = do { core_expr <- dsLExpr expr + ; return (lam_vars, core_expr : args) } + + ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) + -- The reverse is because foldM goes left-to-right + + ; return $ mkCoreLams lam_vars $ + mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) + (map (Type . exprType) args ++ args) } + +dsExpr (HsSCC _ cc expr@(L loc _)) = do + dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + uniq <- newUnique + Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) + <$> dsLExpr expr + else dsLExpr expr + +dsExpr (HsCoreAnn _ _ expr) + = dsLExpr expr + +dsExpr (HsCase discrim matches) + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches + ; return (bindNonRec discrim_var core_discrim matching_code) } + +-- Pepe: The binds are in scope in the body but NOT in the binding group +-- This is to avoid silliness in breakpoints +dsExpr (HsLet binds body) = do + body' <- dsLExpr body + dsLocalBinds binds body' + +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts + +dsExpr (HsIf mb_fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; return (mkCoreApps core_fun [pred,b1,b2]) } + Nothing -> return $ mkIfThenElse pred b1 b2 } + +dsExpr (HsMultiIf res_ty alts) + | null alts + = mkErrorExpr + + | otherwise + = do { match_result <- liftM (foldr1 combineMatchResults) + (mapM (dsGRHS IfAlt res_ty) alts) + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (ptext (sLit "multi-way if")) + +{- +\noindent +\underline{\bf Various data construction things} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +dsExpr (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs + +-- We desugar [:x1, ..., xn:] as +-- singletonP x1 +:+ ... +:+ singletonP xn +-- +dsExpr (ExplicitPArr ty []) = do + emptyP <- dsDPHBuiltin emptyPVar + return (Var emptyP `App` Type ty) +dsExpr (ExplicitPArr ty xs) = do + singletonP <- dsDPHBuiltin singletonPVar + appP <- dsDPHBuiltin appPVar + xs' <- mapM dsLExpr xs + return . foldr1 (binary appP) $ map (unary singletonP) xs' + where + unary fn x = mkApps (Var fn) [Type ty, x] + binary fn x y = mkApps (Var fn) [Type ty, x, y] + +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { + ; fl' <- dsExpr fl + ; newArithSeq <- dsArithSeq expr seq + ; return (App fl' newArithSeq)} + +dsExpr (PArrSeq expr (FromTo from to)) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] + +dsExpr (PArrSeq expr (FromThenTo from thn to)) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] + +dsExpr (PArrSeq _ _) + = panic "DsExpr.dsExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer and typechecker + -- shouldn't have let it through + +{- +\noindent +\underline{\bf Static Pointers} + ~~~~~~~~~~~~~~~ +\begin{verbatim} + g = ... static f ... +==> + sptEntry:N = StaticPtr + (fingerprintString "pkgKey:module.sptEntry:N") + (StaticPtrInfo "current pkg key" "current module" "sptEntry:0") + f + g = ... sptEntry:N +\end{verbatim} +-} + +dsExpr (HsStatic expr@(L loc _)) = do + expr_ds <- dsLExpr expr + let ty = exprType expr_ds + n' <- mkSptEntryName loc + static_binds_var <- dsGetStaticBindsVar + + staticPtrTyCon <- dsLookupTyCon staticPtrTyConName + staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName + staticPtrDataCon <- dsLookupDataCon staticPtrDataConName + fingerprintDataCon <- dsLookupDataCon fingerprintDataConName + + dflags <- getDynFlags + let (line, col) = case loc of + RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r + ) + _ -> (0, 0) + srcLoc = mkCoreConApps (tupleCon BoxedTuple 2) + [ Type intTy , Type intTy + , mkIntExprInt dflags line, mkIntExprInt dflags col + ] + info <- mkConApp staticPtrInfoDataCon <$> + (++[srcLoc]) <$> + mapM mkStringExprFS + [ packageKeyFS $ modulePackageKey $ nameModule n' + , moduleNameFS $ moduleName $ nameModule n' + , occNameFS $ nameOccName n' + ] + let tvars = varSetElems $ tyVarsOfType ty + speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] + speId = mkExportedLocalId VanillaId n' speTy + fp@(Fingerprint w0 w1) = fingerprintName $ idName speId + fp_core = mkConApp fingerprintDataCon + [ mkWord64LitWordRep dflags w0 + , mkWord64LitWordRep dflags w1 + ] + sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds] + liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :) + putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars) + + where + + -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep dflags + | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64 + | otherwise = mkWordLit dflags . toInteger + + fingerprintName :: Name -> Fingerprint + fingerprintName n = fingerprintString $ unpackFS $ concatFS + [ packageKeyFS $ modulePackageKey $ nameModule n + , fsLit ":" + , moduleNameFS (moduleName $ nameModule n) + , fsLit "." + , occNameFS $ occName n + ] + +{- +\noindent +\underline{\bf Record construction and update} + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) +\begin{verbatim} + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.lhs/230/op1") + e + (recConErr t1 "M.lhs/230/op3") +\end{verbatim} +@recConErr@ then converts its arugment string into a proper message +before printing it as +\begin{verbatim} + M.lhs, line 230: missing field op1 was evaluated +\end{verbatim} + +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. +-} + +dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do + con_expr' <- dsExpr con_expr + let + (arg_tys, _) = tcSplitFunTys (exprType con_expr') + -- A newtype in the corner should be opaque; + -- hence TcType.tcSplitFunTys + + mk_arg (arg_ty, lbl) -- Selector id has the field label as its name + = case findField (rec_flds rbinds) lbl of + (rhs:rhss) -> ASSERT( null rhss ) + dsLExpr rhs + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl) + unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty + + labels = dataConFieldLabels (idDataCon data_con_id) + -- The data_con_id is guaranteed to be the wrapper id of the constructor + + con_args <- if null labels + then mapM unlabelled_bottom arg_tys + else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) + + return (mkCoreApps con_expr' con_args) + +{- +Record update is a little harder. Suppose we have the decl: +\begin{verbatim} + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op2 :: Int} + | T3 +\end{verbatim} +Then we translate as follows: +\begin{verbatim} + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.lhs/230" +\end{verbatim} +It's important that we use the constructor Ids for @T1@, @T2@ etc on the +RHSs, and do not generate a Core constructor application directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + T1 { f1 :: a } :: T a Int + +Then the wrapper function for T1 has type + $WT1 :: a -> T a Int +But if x::T a b, then + x { f1 = v } :: T a b (not T a Int!) +So we need to cast (T a Int) to (T a b). Sigh. +-} + +dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) + cons_to_upd in_inst_tys out_inst_tys) + | null fields + = dsLExpr record_expr + | otherwise + = ASSERT2( notNull cons_to_upd, ppr expr ) + + do { record_expr' <- dsLExpr record_expr + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] + + -- It's important to generate the match with matchWrapper, + -- and the right hand sides with applications of the wrapper Id + -- so that everything works when we are doing fancy unboxing on the + -- constructor aguments. + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty] + , mg_res_ty = out_ty, mg_origin = FromSource }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a lcoal binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf Trac #2735 + ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + tycon = dataConTyCon (head cons_to_upd) + in_ty = mkTyConApp tycon in_inst_tys + out_ty = mkFamilyTyConApp tycon out_inst_tys + + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + theta, arg_tys, _) = dataConFullSig con + subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) + ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) + ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + (dataConFieldLabels con) arg_ids + mk_val_arg field_name pat_arg_id + = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) + inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) + -- Reconstruct with the WrapId so that unpacking happens + wrap = mkWpEvVarApps theta_vars <.> + mkWpTyApps (mkTyVarTys ex_tvs) <.> + mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys + , not (tv `elemVarEnv` wrap_subst) ] + rhs = foldl (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrap_co = mkTcTyConAppCo Nominal tycon + [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkTcReflCo Nominal ty + wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) + | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] + + pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con) + , pat_tvs = ex_tvs + , pat_dicts = eqs_vars ++ theta_vars + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_arg_tys = in_inst_tys + , pat_wrap = idHsWrapper } + ; let wrapped_rhs | null eq_spec = rhs + | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs + ; return (mkSimpleMatch [pat] wrapped_rhs) } + +-- Here is where we desugar the Template Haskell brackets and escapes + +-- Template Haskell stuff + +dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" +#ifdef GHCI +dsExpr (HsTcBracketOut x ps) = dsBracket x ps +#else +dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut" +#endif +dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) + +-- Arrow notation extension +dsExpr (HsProc pat cmd) = dsProcExpr pat cmd + +-- Hpc Support + +dsExpr (HsTick tickish e) = do + e' <- dsLExpr e + return (Tick tickish e') + +-- There is a problem here. The then and else branches +-- have no free variables, so they are open to lifting. +-- We need someway of stopping this. +-- This will make no difference to binary coverage +-- (did you go here: YES or NO), but will effect accurate +-- tick counting. + +dsExpr (HsBinTick ixT ixF e) = do + e2 <- dsLExpr e + do { ASSERT(exprType e2 `eqType` boolTy) + mkBinaryTickBox ixT ixF e2 + } + +dsExpr (HsTickPragma _ _ expr) = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsTickPragma" + else dsLExpr expr + +-- HsSyn constructs that just shouldn't be here: +dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" +dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" +dsExpr (HsQuasiQuoteE {}) = panic "dsExpr:HsQuasiQuoteE" +dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp" +dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm" +dsExpr (EWildPat {}) = panic "dsExpr:EWildPat" +dsExpr (EAsPat {}) = panic "dsExpr:EAsPat" +dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" +dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" +dsExpr (HsType {}) = panic "dsExpr:HsType" +dsExpr (HsDo {}) = panic "dsExpr:HsDo" + + + +findField :: [LHsRecField Id arg] -> Name -> [arg] +findField rbinds lbl + = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds + , lbl == idName (unLoc id) ] + +{- +%-------------------------------------------------------------------- + +Note [Desugaring explicit lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Explicit lists are desugared in a cleverer way to prevent some +fruitless allocations. Essentially, whenever we see a list literal +[x_1, ..., x_n] we: + +1. Find the tail of the list that can be allocated statically (say + [x_k, ..., x_n]) by later stages and ensure we desugar that + normally: this makes sure that we don't cause a code size increase + by having the cons in that expression fused (see later) and hence + being unable to statically allocate any more + +2. For the prefix of the list which cannot be allocated statically, + say [x_1, ..., x_(k-1)], we turn it into an expression involving + build so that if we find any foldrs over it it will fuse away + entirely! + + So in this example we will desugar to: + build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n] + + If fusion fails to occur then build will get inlined and (since we + defined a RULE for foldr (:) []) we will get back exactly the + normal desugaring for an explicit list. + +This optimisation can be worth a lot: up to 25% of the total +allocation in some nofib programs. Specifically + + Program Size Allocs Runtime CompTime + rewrite +0.0% -26.3% 0.02 -1.8% + ansi -0.3% -13.8% 0.00 +0.0% + lift +0.0% -8.7% 0.00 -2.3% + +Of course, if rules aren't turned on then there is pretty much no +point doing this fancy stuff, and it may even be harmful. + +=======> Note by SLPJ Dec 08. + +I'm unconvinced that we should *ever* generate a build for an explicit +list. See the comments in GHC.Base about the foldr/cons rule, which +points out that (foldr k z [a,b,c]) may generate *much* less code than +(a `k` b `k` c `k` z). + +Furthermore generating builds messes up the LHS of RULES. +Example: the foldr/single rule in GHC.Base + foldr k z [x] = ... +We do not want to generate a build invocation on the LHS of this RULE! + +We fix this by disabling rules in rule LHSs, and testing that +flag here; see Note [Desugaring RULE left hand sides] in Desugar + +To test this I've added a (static) flag -fsimple-list-literals, which +makes all list literals be generated via the simple route. +-} + +dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] + -> DsM CoreExpr +-- See Note [Desugaring explicit lists] +dsExplicitList elt_ty Nothing xs + = do { dflags <- getDynFlags + ; xs' <- mapM dsLExpr xs + ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' + ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals + || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in Desugar + || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)! + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) } + where + is_static :: CoreExpr -> Bool + is_static e = all is_static_var (varSetElems (exprFreeVars e)) + + is_static_var :: Var -> Bool + is_static_var v + | isId v = isExternalName (idName v) -- Top-level things are given external names + | otherwise = False -- Type variables + + mkSplitExplicitList prefix suffix (c, _) (n, n_ty) + = do { let suffix' = mkListExpr elt_ty suffix + ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' + ; return (foldr (App . App (Var c)) folded_suffix prefix) } + +dsExplicitList elt_ty (Just fln) xs + = do { fln' <- dsExpr fln + ; list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) } + +spanTail :: (a -> Bool) -> [a] -> ([a], [a]) +spanTail f xs = (reverse rejected, reverse satisfying) + where (satisfying, rejected) = span f $ reverse xs + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExpr from +dsArithSeq expr (FromTo from to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from Nothing to + expr' <- dsExpr expr + from' <- dsLExpr from + to' <- dsLExpr to + return $ mkApps expr' [from', to'] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from (Just thn) to + expr' <- dsExpr expr + from' <- dsLExpr from + thn' <- dsLExpr thn + to' <- dsLExpr to + return $ mkApps expr' [from', thn', to'] + +{- +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in DsListComp). Basically does the translation given in the +Haskell 98 report: +-} + +dsDo :: [ExprLStmt Id] -> DsM CoreExpr +dsDo stmts + = goL stmts + where + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (BodyStmt rhs then_expr _ _) stmts + = do { rhs2 <- dsLExpr rhs + ; warnDiscardedDoBindings rhs (exprType rhs2) + ; then_expr2 <- dsExpr then_expr + ; rest <- goL stmts + ; return (mkApps then_expr2 [rhs2, rest]) } + + go _ (LetStmt binds) stmts + = do { rest <- goL stmts + ; dsLocalBinds binds rest } + + go _ (BindStmt pat rhs bind_op fail_op) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op' [rhs', Lam var match_code]) } + + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } + where + new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats) + mfix_app bind_op + noSyntaxExpr -- Tuple cannot fail + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case + rec_tup_pats = map nlVarPat tup_ids + later_pats = rec_tup_pats + rets = map noLoc rec_rets + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body] + , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_origin = Generated }) + mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly + + go _ (ParStmt {}) _ = panic "dsDo ParStmt" + go _ (TransStmt {}) _ = panic "dsDo TransStmt" + +handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr + -- In a do expression, pattern-match failure just calls + -- the monadic 'fail' rather than throwing an exception +handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") + +mk_fail_msg :: DynFlags -> Located e -> String +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ + showPpr dflags (getLoc pat) + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { warn_unused <- woptM Opt_WarnUnusedDoBind + ; warn_wrong <- woptM Opt_WarnWrongDoBind + ; when (warn_unused || warn_wrong) $ + do { fam_inst_envs <- dsGetFamInstEnvs + ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty + + -- Warn about discarding non-() things in 'monadic' binding + ; if warn_unused && not (isUnitTy norm_elt_ty) + then warnDs (badMonadBind rhs elt_ty + (ptext (sLit "-fno-warn-unused-do-bind"))) + else + + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + when warn_wrong $ + do { case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> warnDs (badMonadBind rhs elt_ty + (ptext (sLit "-fno-warn-wrong-do-bind"))) + _ -> return () } } } + + | otherwise -- RHS does have type of form (m ty), which is weird + = return () -- but at lesat this warning is irrelevant + +badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc +badMonadBind rhs elt_ty flag_doc + = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type")) + 2 (quotes (ppr elt_ty)) + , hang (ptext (sLit "Suppress this warning by saying")) + 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) + , ptext (sLit "or by using the flag") <+> flag_doc ] + +{- +************************************************************************ +* * +\subsection{Static pointers} +* * +************************************************************************ +-} + +-- | Creates an name for an entry in the Static Pointer Table. +-- +-- The name has the form @sptEntry:@ where @@ is generated from a +-- per-module counter. +-- +mkSptEntryName :: SrcSpan -> DsM Name +mkSptEntryName loc = do + uniq <- newUnique + mod <- getModule + occ <- mkWrapperName "sptEntry" + return $ mkExternalName uniq mod occ loc + where + mkWrapperName what + = do dflags <- getDynFlags + thisMod <- getModule + let -- Note [Generating fresh names for ccall wrapper] + -- in compiler/typecheck/TcEnv.hs + wrapperRef = nextWrapperNum dflags + wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + in (extendModuleEnv mod_env thisMod (num+1), num) + return $ mkVarOcc $ what ++ ":" ++ show wrapperNum diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot new file mode 100644 index 00000000..129185d2 --- /dev/null +++ b/compiler/deSugar/DsExpr.hs-boot @@ -0,0 +1,9 @@ +module DsExpr where +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) +import Var ( Id ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) + +dsExpr :: HsExpr Id -> DsM CoreExpr +dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs new file mode 100644 index 00000000..715e1ce0 --- /dev/null +++ b/compiler/deSugar/DsForeign.hs @@ -0,0 +1,812 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +Desugaring foreign declarations (see also DsCCall). +-} + +{-# LANGUAGE CPP #-} + +module DsForeign ( dsForeigns + , dsForeigns' + , dsFImport, dsCImport, dsFCall, dsPrimCall + , dsFExport, dsFExportDynamic, mkFExportCBits + , toCType + , foreignExportInitialiser + ) where + +#include "HsVersions.h" +import TcRnMonad -- temp + +import TypeRep + +import CoreSyn + +import DsCCall +import DsMonad + +import HsSyn +import DataCon +import CoreUnfold +import Id +import Literal +import Module +import Name +import Type +import TyCon +import Coercion +import TcEnv +import TcType + +import CmmExpr +import CmmUtils +import HscTypes +import ForeignCall +import TysWiredIn +import TysPrim +import PrelNames +import BasicTypes +import SrcLoc +import Outputable +import FastString +import DynFlags +import Platform +import Config +import OrdList +import Pair +import Util +import Hooks + +import Data.Maybe +import Data.List + +{- +Desugaring of @foreign@ declarations is naturally split up into +parts, an @import@ and an @export@ part. A @foreign import@ +declaration +\begin{verbatim} + foreign import cc nm f :: prim_args -> IO prim_res +\end{verbatim} +is the same as +\begin{verbatim} + f :: prim_args -> IO prim_res + f a1 ... an = _ccall_ nm cc a1 ... an +\end{verbatim} +so we reuse the desugaring code in @DsCCall@ to deal with these. +-} + +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + +dsForeigns :: [LForeignDecl Id] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) + +dsForeigns' :: [LForeignDecl Id] + -> DsM (ForeignStubs, OrdList Binding) +dsForeigns' [] + = return (NoStubs, nilOL) +dsForeigns' fos = do + fives <- mapM do_ldecl fos + let + (hs, cs, idss, bindss) = unzip4 fives + fe_ids = concat idss + fe_init_code = map foreignExportInitialiser fe_ids + -- + return (ForeignStubs + (vcat hs) + (vcat cs $$ vcat fe_init_code), + foldr (appOL . toOL) nilOL bindss) + where + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + + do_decl (ForeignImport id _ co spec) = do + traceIf (text "fi start" <+> ppr id) + (bs, h, c) <- dsFImport (unLoc id) co spec + traceIf (text "fi end" <+> ppr id) + return (h, c, [], bs) + + do_decl (ForeignExport (L _ id) _ co + (CExport (L _ (CExportStatic ext_nm cconv)) _)) = do + (h, c, _, _) <- dsFExport id co ext_nm cconv False + return (h, c, [id], []) + +{- +************************************************************************ +* * +\subsection{Foreign import} +* * +************************************************************************ + +Desugaring foreign imports is just the matter of creating a binding +that on its RHS unboxes its arguments, performs the external call +(using the @CCallOp@ primop), before boxing the result up and returning it. + +However, we create a worker/wrapper pair, thus: + + foreign import f :: Int -> IO Int +==> + f x = IO ( \s -> case x of { I# x# -> + case fw s x# of { (# s1, y# #) -> + (# s1, I# y# #)}}) + + fw s x# = ccall f s x# + +The strictness/CPR analyser won't do this automatically because it doesn't look +inside returned tuples; but inlining this wrapper is a Really Good Idea +because it exposes the boxing to the call site. +-} + +dsFImport :: Id + -> Coercion + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc) +dsFImport id co (CImport cconv safety mHeader spec _) = do + (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader + return (ids, h, c) + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], SDoc, SDoc) +dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags + let ty = pFst $ coercionKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (resTy, foRhs) <- resultWrapper ty + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let + rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info dflags cconv ty + in + return ([(id, rhs')], empty, empty) + +dsCImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsCImport id co CWrapper cconv _ _ + = dsFExportDynamic id co cconv + +-- For stdcall labels, if the type was a FunPtr or newtype thereof, +-- then we need to calculate the size of the arguments in order to add +-- the @n suffix to the label. +fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info dflags StdCallConv ty + | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, + tyConUnique tc == funPtrTyConKey + = let + (_tvs,sans_foralls) = tcSplitForAllTys arg_ty + (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) +fun_type_arg_stdcall_info _ _other_conv _ + = Nothing + +{- +************************************************************************ +* * +\subsection{Foreign calls} +* * +************************************************************************ +-} + +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsFCall fn_id co fcall mDeclHeader = do + let + ty = pFst $ coercionKind co + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + -- Must use tcSplit* functions because we want to + -- see that (IO t) in the corner + + args <- newSysLocalsDs arg_tys + (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + dflags <- getDynFlags + (fcall', cDoc) <- + case fcall of + CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) -> + do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety) + c = includes + $$ fun_proto <+> braces (cRet <> semi) + includes = vcat [ text "#include <" <> ftext h <> text ">" + | Header h <- nub headers ] + fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + cRet + | isVoidRes = cCall + | otherwise = text "return" <+> cCall + cCall = if isFun + then ppr cName <> parens argVals + else if null arg_tys + then ppr cName + else panic "dsFCall: Unexpected arguments to FFI value import" + raw_res_ty = case tcSplitIOType_maybe io_res_ty of + Just (_ioTyCon, res_ty) -> res_ty + Nothing -> io_res_ty + isVoidRes = raw_res_ty `eqType` unitTy + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty + pprCconv = ccallConvAttribute CApiConv + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType t ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' + argVals = hsep $ punctuate comma + [ char 'a' <> int n + | (_, n) <- zip arg_tys [1..] ] + return (fcall', c) + _ -> + return (fcall, empty) + let + -- Build the worker + worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) + +{- +************************************************************************ +* * +\subsection{Primitive calls} +* * +************************************************************************ + +This is for `@foreign import prim@' declarations. + +Currently, at the core level we pretend that these primitive calls are +foreign calls. It may make more sense in future to have them as a distinct +kind of Id, or perhaps to bundle them with PrimOps since semantically and +for calling convention they are really prim ops. +-} + +dsPrimCall :: Id -> Coercion -> ForeignCall + -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) +dsPrimCall fn_id co fcall = do + let + ty = pFst $ coercionKind co + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + -- Must use tcSplit* functions because we want to + -- see that (IO t) in the corner + + args <- newSysLocalsDs arg_tys + + ccall_uniq <- newUnique + dflags <- getDynFlags + let + call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + rhs' = Cast rhs co + return ([(fn_id, rhs')], empty, empty) + +{- +************************************************************************ +* * +\subsection{Foreign export} +* * +************************************************************************ + +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands + into.) + +For each `@foreign export foo@' in a module M we generate: +\begin{itemize} +\item a C function `@foo@', which calls +\item a Haskell stub `@M.\$ffoo@', which calls +\end{itemize} +the user-written Haskell function `@M.foo@'. +-} + +dsFExport :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( SDoc -- contents of Module_stub.h + , SDoc -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , Int -- size of args to stub function + ) + +dsFExport fn_id co ext_name cconv isDyn = do + let + ty = pSnd $ coercionKind co + (_tvs,sans_foralls) = tcSplitForAllTys ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + + dflags <- getDynFlags + return $ + mkFExportCBits dflags ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv + +{- +@foreign import "wrapper"@ (previously "foreign export dynamic") lets +you dress up Haskell IO actions of some fixed type behind an +externally callable interface (i.e., as a C function pointer). Useful +for callbacks and stuff. + +\begin{verbatim} +type Fun = Bool -> Int -> IO Int +foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) + +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? + +f :: Fun -> IO (FunPtr Fun) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) + +foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) + +-- and the helper in C: (approximately; see `mkFExportCBits` below) + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + Capability *cap; + cap = rts_lock(); + rts_evalIO(&cap, + rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); + rts_unlock(cap); +} +\end{verbatim} +-} + +dsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], SDoc, SDoc) +dsFExportDynamic id co0 cconv = do + fe_id <- newSysLocalDs ty + mod <- getModule + dflags <- getDynFlags + let + -- hack: need to get at the name of the C stub we're about to generate. + -- TODO: There's no real need to go via String with + -- (mkFastString . zString). In fact, is there a reason to convert + -- to FastString at all now, rather than sticking with FastZString? + fe_nm = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id) + + cback <- newSysLocalDs arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkFunTy stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalDs stable_ptr_ty + (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) + , Var stbl_value + , Lit (MachLabel fe_nm mb_sz_args IsFunction) + , Lit (mkMachString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + + where + ty = pFst (coercionKind co0) + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty + -- Must have an IO type; hence Just + +toCName :: DynFlags -> Id -> String +toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) + +{- +* + +\subsection{Generating @foreign export@ stubs} + +* + +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. +-} + +mkFExportCBits :: DynFlags + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (SDoc, + SDoc, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = (header_bits, c_bits, type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + ) + where + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType dflags (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n stg_ty + | libffi = char '*' <> parens (stg_ty <> char '*') <> + ptext (sLit "args") <> brackets (int (n-1)) + | otherwise = text ('a':show n) + + -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled + libffi = cLibFFI && isNothing maybe_target + + type_string + -- libffi needs to know the result type too: + | libffi = primTyDescChar dflags res_hty : arg_type_string + | otherwise = arg_type_string + + arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] + -- just the real args + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeCmmType dflags (mkStablePtrPrimTy alphaTy)) + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- when the return type is integral and word-sized or smaller, it + -- must be assigned as type ffi_arg (#3516). To see what type + -- libffi is expecting here, take a look in its own testsuite, e.g. + -- libffi/testsuite/libffi.call/cls_align_ulonglong.c + ffi_cResType + | is_ffi_arg_type = text "ffi_arg" + | otherwise = cResType + where + res_ty_key = getUnique (getName (typeTyCon res_hty)) + is_ffi_arg_type = res_ty_key `notElem` + [floatTyConKey, doubleTyConKey, + int64TyConKey, word64TyConKey] + + -- Now we can cook up the prototype for the exported function. + pprCconv = ccallConvAttribute cc + + header_bits = ptext (sLit "extern") <+> fun_proto <> semi + + fun_args + | null aug_arg_info = text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info + + fun_proto + | libffi + = ptext (sLit "void") <+> ftext c_nm <> + parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")) + | otherwise + = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_evalIO + expr_to_run + = foldl appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- finally, the whole darn thing + c_bits = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , ptext (sLit "Capability *cap;") + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , ptext (sLit "rts_evalIO") <> parens ( + char '&' <> cap <> + ptext (sLit "rts_apply") <> parens ( + cap <> + text "(HaskellObj)" + <> ptext (if is_IO_res_ty + then (sLit "runIO_closure") + else (sLit "runNonIO_closure")) + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , ptext (sLit "rts_unlock(cap);") + , ppUnless res_hty_is_unit $ + if libffi + then char '*' <> parens (ffi_cResType <> char '*') <> + ptext (sLit "resp = cret;") + else ptext (sLit "return cret;") + , rbrace + ] + + +foreignExportInitialiser :: Id -> SDoc +foreignExportInitialiser hs_fn = + -- Initialise foreign exports by registering a stable pointer from an + -- __attribute__((constructor)) function. + -- The alternative is to do this from stginit functions generated in + -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact + -- on binary sizes and link times because the static linker will think that + -- all modules that are imported directly or indirectly are actually used by + -- the program. + -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) + vcat + [ text "static void stginit_export_" <> ppr hs_fn + <> text "() __attribute__((constructor));" + , text "static void stginit_export_" <> ppr hs_fn <> text "()" + , braces (text "foreignExportStablePtr" + <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") + <> semi) + ] + + +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | TyConApp tycon _ <- t + , Just (CType _ mHeader cType) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, ptext (sLit "void")) + | otherwise + = pprPanic "toCType" (ppr t) + +typeTyCon :: Type -> TyCon +typeTyCon ty + | UnaryRep rep_ty <- repType ty + , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + = tc + | otherwise + = pprPanic "DsForeign.typeTyCon" (ppr ty) + +insertRetAddr :: DynFlags -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr dflags CCallConv args + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg dflags : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg dflags : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg dflags : args + where platform = targetPlatform dflags +insertRetAddr _ _ args = args + +ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, + typeCmmType dflags addrPrimTy) + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). +getPrimTyOf :: Type -> UnaryType +getPrimTyOf ty + | isBoolTy rep_ty = intPrimTy + -- Except for Bool, the types we are interested in have a single constructor + -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). + | otherwise = + case splitDataProductType_maybe rep_ty of + Just (_, _, data_con, [prim_ty]) -> + ASSERT(dataConSourceArity data_con == 1) + ASSERT2(isUnLiftedType prim_ty, ppr prim_ty) + prim_ty + _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) + where + UnaryRep rep_ty = repType ty + +-- represent a primitive type as a Char, for building a string that +-- described the foreign function type. The types are size-dependent, +-- e.g. 'W' is a signed 32-bit integer. +primTyDescChar :: DynFlags -> Type -> Char +primTyDescChar dflags ty + | ty `eqType` unitTy = 'v' + | otherwise + = case typePrimRep (getPrimTyOf ty) of + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> 'L' + Word64Rep -> 'l' + AddrRep -> 'p' + FloatRep -> 'f' + DoubleRep -> 'd' + _ -> pprPanic "primTyDescChar" (ppr ty) + where + (signed_word, unsigned_word) + | wORD_SIZE dflags == 4 = ('W','w') + | wORD_SIZE dflags == 8 = ('L','l') + | otherwise = panic "primTyDescChar" diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs new file mode 100644 index 00000000..1346f8af --- /dev/null +++ b/compiler/deSugar/DsGRHSs.hs @@ -0,0 +1,159 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Matching guarded right-hand-sides (GRHSs) +-} + +{-# LANGUAGE CPP #-} + +module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} Match ( matchSinglePat ) + +import HsSyn +import MkCore +import CoreSyn +import Var +import Type + +import DsMonad +import DsUtils +import TysWiredIn +import PrelNames +import Module +import Name +import Util +import SrcLoc +import Outputable + +{- +@dsGuarded@ is used for both @case@ expressions and pattern bindings. +It desugars: +\begin{verbatim} + | g1 -> e1 + ... + | gn -> en + where binds +\end{verbatim} +producing an expression with a runtime error in the corner if +necessary. The type argument gives the type of the @ei@. +-} + +dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr + +dsGuarded grhss rhs_ty = do + match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty + error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty + extractMatchResult match_result error_expr + +-- In contrast, @dsGRHSs@ produces a @MatchResult@. + +dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from + -> GRHSs Id (LHsExpr Id) -- Guarded RHSs + -> Type -- Type of RHS + -> DsM MatchResult +dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty + = ASSERT( notNull grhss ) + do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss + ; let match_result1 = foldr1 combineMatchResults match_results + match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 + -- NB: nested dsLet inside matchResult + ; return match_result2 } + +dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult +dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) + = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty + +{- +************************************************************************ +* * +* matchGuard : make a MatchResult from a guarded RHS * +* * +************************************************************************ +-} + +matchGuards :: [GuardStmt Id] -- Guard + -> HsStmtContext Name -- Context + -> LHsExpr Id -- RHS + -> Type -- Type of RHS of guard + -> DsM MatchResult + +-- See comments with HsExpr.Stmt re what a BodyStmt means +-- Here we must be in a guard context (not do-expression, nor list-comp) + +matchGuards [] _ rhs _ + = do { core_rhs <- dsLExpr rhs + ; return (cantFailMatchResult core_rhs) } + + -- BodyStmts must be guards + -- Turn an "otherwise" guard is a no-op. This ensures that + -- you don't get a "non-exhaustive eqns" message when the guards + -- finish in "otherwise". + -- NB: The success of this clause depends on the typechecker not + -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors + -- If it does, you'll get bogus overlap warnings +matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty + | Just addTicks <- isTrueLHsExpr e = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs addTicks match_result) +matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + pred_expr <- dsLExpr expr + return (mkGuardedMatchResult pred_expr match_result) + +matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + return (adjustMatchResultDs (dsLocalBinds binds) match_result) + -- NB the dsLet occurs inside the match_result + -- Reason: dsLet takes the body expression as its argument + -- so we can't desugar the bindings without the + -- body expression in hand + +matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty + core_rhs <- dsLExpr bind_rhs + matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result + +matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt" +matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt" +matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" +matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" + +isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) + +-- Returns Just {..} if we're sure that the expression is True +-- I.e. * 'True' datacon +-- * 'otherwise' Id +-- * Trivial wappings of these +-- The arguments to Just are any HsTicks that we have found, +-- because we still want to tick then, even it they are aways evaluted. +isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return + -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsTick tickish e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> ticks x >>= return . (Tick tickish)) + -- This encodes that the result is constant True for Hpc tick purposes; + -- which is specifically what isTrueLHsExpr is trying to find out. +isTrueLHsExpr (L _ (HsBinTick ixT _ e)) + | Just ticks <- isTrueLHsExpr e + = Just (\x -> do e <- ticks x + this_mod <- getModule + return (Tick (HpcTick this_mod ixT) e)) + +isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing + +{- +Should {\em fail} if @e@ returns @D@ +\begin{verbatim} +f x | p <- e', let C y# = e, f y# = r1 + | otherwise = r2 +\end{verbatim} +-} diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs new file mode 100644 index 00000000..79d6f476 --- /dev/null +++ b/compiler/deSugar/DsListComp.hs @@ -0,0 +1,871 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Desugaring list comprehensions, monad comprehensions and array comprehensions +-} + +{-# LANGUAGE CPP, NamedFieldPuns #-} + +module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) + +import HsSyn +import TcHsSyn +import CoreSyn +import MkCore + +import DsMonad -- the monadery used in the desugarer +import DsUtils + +import DynFlags +import CoreUtils +import Id +import Type +import TysWiredIn +import Match +import PrelNames +import SrcLoc +import Outputable +import FastString +import TcType +import ListSetOps( getNth ) +import Util + +{- +List comprehensions may be desugared in one of two ways: ``ordinary'' +(as you would expect if you read SLPJ's book) and ``with foldr/build +turned on'' (if you read Gill {\em et al.}'s paper on the subject). + +There will be at least one ``qualifier'' in the input. +-} + +dsListComp :: [ExprLStmt Id] + -> Type -- Type of entire list + -> DsM CoreExpr +dsListComp lquals res_ty = do + dflags <- getDynFlags + let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) + + if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags + -- Either rules are switched off, or we are ignoring what there are; + -- Either way foldr/build won't happen, so use the more efficient + -- Wadler-style desugaring + || isParallelComp quals + -- Foldr-style desugaring can't handle parallel list comprehensions + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) + -- Foldr/build should be enabled, so desugar + -- into foldrs and builds + + where + -- We must test for ParStmt anywhere, not just at the head, because an extension + -- to list comprehensions would be to add brackets to specify the associativity + -- of qualifier lists. This is really easy to do by adding extra ParStmts into the + -- mix of possibly a single element in length, so we do this to leave the possibility open + isParallelComp = any isParallelStmt + + isParallelStmt (ParStmt {}) = True + isParallelStmt _ = False + + +-- This function lets you desugar a inner list comprehension and a list of the binders +-- of that comprehension that we need in the outer comprehension into such an expression +-- and the type of the elements that it outputs (tuples of binders) +dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) +dsInnerListComp (ParStmtBlock stmts bndrs _) + = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) + (mkListTy bndrs_tuple_type) + ; return (expr, bndrs_tuple_type) } + where + bndrs_tuple_type = mkBigCoreVarTupTy bndrs + +-- This function factors out commonality between the desugaring strategies for GroupStmt. +-- Given such a statement it gives you back an expression representing how to compute the transformed +-- list and the tuple that you need to bind from that list in order to proceed with your desugaring +dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + usingExpr' <- dsLExpr using + usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } + + -- Create an unzip function for the appropriate arity and element types and find "map" + unzip_stuff <- mkUnzipBind form from_bndrs_tys + map_id <- dsLookupGlobalId mapName + + -- Generate the expressions to build the grouped list + let -- First we apply the grouping function to the inner list + inner_list_expr = mkApps usingExpr' usingArgs + -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists + -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and + -- the "b" to be a tuple of "to" lists! + -- Then finally we bind the unzip function around that expression + bound_unzipped_inner_list_expr + = case unzip_stuff of + Nothing -> inner_list_expr + Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn + , inner_list_expr] + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTup to_bndrs + return (bound_unzipped_inner_list_expr, pat) + +dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" + +{- +************************************************************************ +* * +\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} +* * +************************************************************************ + +Just as in Phil's chapter~7 in SLPJ, using the rules for +optimally-compiled list comprehensions. This is what Kevin followed +as well, and I quite happily do the same. The TQ translation scheme +transforms a list of qualifiers (either boolean expressions or +generators) into a single expression which implements the list +comprehension. Because we are generating 2nd-order polymorphic +lambda-calculus, calls to NIL and CONS must be applied to a type +argument, as well as their usual value arguments. +\begin{verbatim} +TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> + +(Rule C) +TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> + +(Rule B) +TQ << [ e | b , qs ] ++ L >> = + if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> + +(Rule A') +TQ << [ e | p <- L1, qs ] ++ L2 >> = + letrec + h = \ u1 -> + case u1 of + [] -> TE << L2 >> + (u2 : u3) -> + (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) + [] (h u3) + in + h ( TE << L1 >> ) + +"h", "u1", "u2", and "u3" are new variables. +\end{verbatim} + +@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ +is the TE translation scheme. Note that we carry around the @L@ list +already desugared. @dsListComp@ does the top TE rule mentioned above. + +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((x1, .., xn), (y1, ..., ym)) <- + zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13] + [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]] +where (x1, .., xn) are the variables bound in p1, v1, p2 + (y1, .., ym) are the variables bound in q1, v2, q2 + +In the translation below, the ParStmt branch translates each parallel branch +into a sub-comprehension, and desugars each independently. The resulting lists +are fed to a zip function, we create a binding for all the variables bound in all +the comprehensions, and then we hand things off the the desugarer for bindings. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. +-} + +deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr + +deListComp [] _ = panic "deListComp" + +deListComp (LastStmt body _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } + + -- Non-last: must be a guard +deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above + core_guard <- dsLExpr guard + core_rest <- deListComp quals list + return (mkIfThenElse core_guard core_rest list) + +-- [e | let B, qs] = let B in [e | qs] +deListComp (LetStmt binds : quals) list = do + core_rest <- deListComp quals list + dsLocalBinds binds core_rest + +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list + +deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above + core_list1 <- dsLExpr list1 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list } + where + bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTup pats + pats = map mkBigLHsVarPatTup bndrs_s + +deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" + +deBindComp :: OutPat Id + -> CoreExpr + -> [ExprStmt Id] + -> CoreExpr + -> DsM (Expr Id) +deBindComp pat core_list1 quals core_list2 = do + let + u3_ty@u1_ty = exprType core_list1 -- two names, same thing + + -- u1_ty is a [alpha] type, and u2_ty = alpha + u2_ty = hsLPatType pat + + res_ty = exprType core_list2 + h_ty = u1_ty `mkFunTy` res_ty + + [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] + + -- the "fail" value ... + let + core_fail = App (Var h) (Var u3) + letrec_body = App (Var h) core_list1 + + rest_expr <- deListComp quals core_fail + core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail + + let + rhs = Lam u1 $ + Case (Var u1) u1 res_ty + [(DataAlt nilDataCon, [], core_list2), + (DataAlt consDataCon, [u2, u3], core_match)] + -- Increasing order of tag + + return (Let (Rec [(h, rhs)]) letrec_body) + +{- +************************************************************************ +* * +\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} +* * +************************************************************************ + +@dfListComp@ are the rules used with foldr/build turned on: + +\begin{verbatim} +TE[ e | ] c n = c e n +TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n +TE[ e | p <- l , q ] c n = let + f = \ x b -> case x of + p -> TE[ e | q ] c b + _ -> b + in + foldr f n l +\end{verbatim} +-} + +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt Id] -- the rest of the qual's + -> DsM CoreExpr + +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt body _ : quals) + = ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } + + -- Non-last: must be a guard +dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do + core_guard <- dsLExpr guard + core_rest <- dfListComp c_id n_id quals + return (mkIfThenElse core_guard core_rest (Var n_id)) + +dfListComp c_id n_id (LetStmt binds : quals) = do + -- new in 1.3, local bindings + core_rest <- dfListComp c_id n_id quals + dsLocalBinds binds core_rest + +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt + -- Anyway, we bind the newly grouped list via the generic binding function + dfBindComp c_id n_id (pat, inner_list_expr) quals + +dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do + -- evaluate the two lists + core_list1 <- dsLExpr list1 + + -- Do the rest of the work in the generic binding builder + dfBindComp c_id n_id (pat, core_list1) quals + +dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" +dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" + +dfBindComp :: Id -> Id -- 'c' and 'n' + -> (LPat Id, CoreExpr) + -> [ExprStmt Id] -- the rest of the qual's + -> DsM CoreExpr +dfBindComp c_id n_id (pat, core_list1) quals = do + -- find the required type + let x_ty = hsLPatType pat + b_ty = idType n_id + + -- create some new local id's + [b, x] <- newSysLocalsDs [b_ty, x_ty] + + -- build rest of the comprehesion + core_rest <- dfListComp c_id b quals + + -- build the pattern match + core_expr <- matchSimply (Var x) (StmtCtxt ListComp) + pat core_rest (Var b) + + -- now build the outermost foldr, and return + mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 + +{- +************************************************************************ +* * +\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} +* * +************************************************************************ +-} + +mkZipBind :: [Type] -> DsM (Id, CoreExpr) +-- mkZipBind [t1, t2] +-- = (zip, \as1:[t1] as2:[t2] +-- -> case as1 of +-- [] -> [] +-- (a1:as'1) -> case as2 of +-- [] -> [] +-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] + +mkZipBind elt_tys = do + ass <- mapM newSysLocalDs elt_list_tys + as' <- mapM newSysLocalDs elt_tys + as's <- mapM newSysLocalDs elt_list_tys + + zip_fn <- newSysLocalDs zip_fn_ty + + let inner_rhs = mkConsExpr elt_tuple_ty + (mkBigCoreVarTup as') + (mkVarApps (Var zip_fn) as's) + zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) + + return (zip_fn, mkLams ass zip_body) + where + elt_list_tys = map mkListTy elt_tys + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + + zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty + + mk_case (as, a', as') rest + = Case (Var as) as elt_tuple_list_ty + [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty), + (DataAlt consDataCon, [a', as'], rest)] + -- Increasing order of tag + + +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) +-- mkUnzipBind [t1, t2] +-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) +-- -> case ax of +-- (x1, x2) -> case axs of +-- (xs1, xs2) -> (x1 : xs1, x2 : xs2)) +-- ([], []) +-- ys) +-- +-- We use foldr here in all cases, even if rules are turned off, because we may as well! +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalDs elt_tuple_ty + ; axs <- newSysLocalDs elt_list_tuple_ty + ; ys <- newSysLocalDs elt_tuple_list_ty + ; xs <- mapM newSysLocalDs elt_tys + ; xss <- mapM newSysLocalDs elt_list_tys + + ; unzip_fn <- newSysLocalDs unzip_fn_ty + + ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) + folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } + where + elt_tuple_ty = mkBigCoreTupTy elt_tys + elt_tuple_list_ty = mkListTy elt_tuple_ty + elt_list_tys = map mkListTy elt_tys + elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys + + unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty + + mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail + +{- +************************************************************************ +* * +\subsection[DsPArrComp]{Desugaring of array comprehensions} +* * +************************************************************************ +-} + +-- entry point for desugaring a parallel array comprehension +-- +-- [:e | qss:] = <<[:e | qss:]>> () [:():] +-- +dsPArrComp :: [ExprStmt Id] + -> DsM CoreExpr + +-- Special case for parallel comprehension +dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals + +-- Special case for simple generators: +-- +-- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e +-- +-- if matching again p cannot fail, or else +-- +-- <<[:e' | p <- e, qs:]>> = +-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) +-- +dsPArrComp (BindStmt p e _ _ : qs) = do + filterP <- dsDPHBuiltin filterPVar + ce <- dsLExpr e + let ety'ce = parrElemType ce + false = Var falseDataConId + true = Var trueDataConId + v <- newSysLocalDs ety'ce + pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false + let gen | isIrrefutableHsPat p = ce + | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] + dePArrComp qs p gen + +dsPArrComp qs = do -- no ParStmt in `qs' + sglP <- dsDPHBuiltin singletonPVar + let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] + dePArrComp qs (noLoc $ WildPat unitTy) unitArray + + + +-- the work horse +-- +dePArrComp :: [ExprStmt Id] + -> LPat Id -- the current generator pattern + -> CoreExpr -- the current generator expression + -> DsM CoreExpr + +dePArrComp [] _ _ = panic "dePArrComp" + +-- +-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea +-- +dePArrComp (LastStmt e' _ : quals) pa cea + = ASSERT( null quals ) + do { mapP <- dsDPHBuiltin mapPVar + ; let ty = parrElemType cea + ; (clam, ty'e') <- deLambda ty pa e' + ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] } +-- +-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) +-- +dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do + filterP <- dsDPHBuiltin filterPVar + let ty = parrElemType cea + (clam,_) <- deLambda ty pa b + dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) + +-- +-- <<[:e' | p <- e, qs:]>> pa ea = +-- let ef = \pa -> e +-- in +-- <<[:e' | qs:]>> (pa, p) (crossMap ea ef) +-- +-- if matching again p cannot fail, or else +-- +-- <<[:e' | p <- e, qs:]>> pa ea = +-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e +-- in +-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) +-- +dePArrComp (BindStmt p e _ _ : qs) pa cea = do + filterP <- dsDPHBuiltin filterPVar + crossMapP <- dsDPHBuiltin crossMapPVar + ce <- dsLExpr e + let ety'cea = parrElemType cea + ety'ce = parrElemType ce + false = Var falseDataConId + true = Var trueDataConId + v <- newSysLocalDs ety'ce + pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false + let cef | isIrrefutableHsPat p = ce + | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] + (clam, _) <- mkLambda ety'cea pa cef + let ety'cef = ety'ce -- filter doesn't change the element type + pa' = mkLHsPatTup [pa, p] + + dePArrComp qs pa' (mkApps (Var crossMapP) + [Type ety'cea, Type ety'cef, cea, clam]) +-- +-- <<[:e' | let ds, qs:]>> pa ea = +-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) +-- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) +-- where +-- {x_1, ..., x_n} = DV (ds) -- Defined Variables +-- +dePArrComp (LetStmt ds : qs) pa cea = do + mapP <- dsDPHBuiltin mapPVar + let xs = collectLocalBinders ds + ty'cea = parrElemType cea + v <- newSysLocalDs ty'cea + clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) + let'v <- newSysLocalDs (exprType clet) + let projBody = mkCoreLet (NonRec let'v clet) $ + mkCoreTup [Var v, Var let'v] + errTy = exprType projBody + errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!") + cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg + ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr + let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] + proj = mkLams [v] ccase + dePArrComp qs pa' (mkApps (Var mapP) + [Type ty'cea, Type errTy, proj, cea]) +-- +-- The parser guarantees that parallel comprehensions can only appear as +-- singleton qualifier lists, which we already special case in the caller. +-- So, encountering one here is a bug. +-- +dePArrComp (ParStmt {} : _) _ _ = + panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt" +dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" +dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" + +-- <<[:e' | qs | qss:]>> pa ea = +-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) +-- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) +-- where +-- {x_1, ..., x_n} = DV (qs) +-- +dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr +dePArrParComp qss quals = do + (pQss, ceQss) <- deParStmt qss + dePArrComp quals pQss ceQss + where + deParStmt [] = + -- empty parallel statement lists have no source representation + panic "DsListComp.dePArrComp: Empty parallel list comprehension" + deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement + let res_expr = mkLHsVarTuple xs + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) + parStmts qss (mkLHsVarPatTup xs) cqs + --- + parStmts [] pa cea = return (pa, cea) + parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) + zipP <- dsDPHBuiltin zipPVar + let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] + ty'cea = parrElemType cea + res_expr = mkLHsVarTuple xs + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) + let ty'cqs = parrElemType cqs + cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] + parStmts qss pa' cea' + +-- generate Core corresponding to `\p -> e' +-- +deLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> LHsExpr Id -- body + -> DsM (CoreExpr, Type) +deLambda ty p e = + mkLambda ty p =<< dsLExpr e + +-- generate Core for a lambda pattern match, where the body is already in Core +-- +mkLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> CoreExpr -- desugared body + -> DsM (CoreExpr, Type) +mkLambda ty p ce = do + v <- newSysLocalDs ty + let errMsg = ptext (sLit "DsListComp.deLambda: internal error!") + ce'ty = exprType ce + cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg + res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr + return (mkLams [v] res, ce'ty) + +-- obtain the element type of the parallel array produced by the given Core +-- expression +-- +parrElemType :: CoreExpr -> Type +parrElemType e = + case splitTyConApp_maybe (exprType e) of + Just (tycon, [ty]) | tycon == parrTyCon -> ty + _ -> panic + "DsListComp.parrElemType: not a parallel array type" + +-- Translation for monad comprehensions + +-- Entry point for monad comprehension desugaring +dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr + +dsMcStmt (LastStmt body ret_op) stmts + = ASSERT( null stmts ) + do { body' <- dsLExpr body + ; ret_op' <- dsExpr ret_op + ; return (App ret_op' body') } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' bind_op fail_op stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts + = do { exp' <- dsLExpr exp + ; guard_exp' <- dsExpr guard_exp + ; then_exp' <- dsExpr then_exp + ; rest <- dsMcStmts stmts + ; return $ mkApps then_exp' [ mkApps guard_exp' [exp'] + , rest ] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + from_bndr_tys = map idType from_bndrs -- Types ty + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; bind_op' <- dsExpr bind_op + ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 + n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c) + tup_n_ty = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var <- newSysLocalDs n_tup_ty + ; tup_n_var <- newSysLocalDs tup_n_ty + ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs + body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr + + ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let -- The pattern variables + pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks] + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } + where + ds_inner (ParStmtBlock stmts bndrs return_op) + = do { exp <- dsInnerMonadComp stmts bndrs return_op + ; return (exp, mkBigCoreVarTupTy bndrs) } + +dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { us <- newUniqueSupply + ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat Id + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr Id + -> SyntaxExpr Id + -> [ExprLStmt Id] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op stmts + = do { body <- dsMcStmts stmts + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op' [rhs', Lam var match_code]) } + + where + -- In a monad comprehension expression, pattern-match failure just calls + -- the monadic `fail` rather than throwing an exception + handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; dflags <- getDynFlags + ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") + + mk_fail_msg :: DynFlags -> Located e -> String + mk_fail_msg dflags pat + = "Pattern match failure in monad comprehension at " ++ + showPpr dflags (getLoc pat) + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [ExprLStmt Id] + -> [Id] -- Return a tuple of these variables + -> HsExpr Id -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)]) + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> SyntaxExpr TcId -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- mapM newSysLocalDs elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (getNth elt_tys i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs new file mode 100644 index 00000000..6eeba5eb --- /dev/null +++ b/compiler/deSugar/DsMeta.hs @@ -0,0 +1,2919 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- The purpose of this module is to transform an HsExpr into a CoreExpr which +-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the +-- input HsExpr. We do this in the DsM monad, which supplies access to +-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +-- +-- It also defines a bunch of knownKeyNames, in the same way as is done +-- in prelude/PrelNames. It's much more convenient to do it here, because +-- otherwise we have to recompile PrelNames whenever we add a Name, which is +-- a Royal Pain (triggers other recompilation). +----------------------------------------------------------------------------- + +module DsMeta( dsBracket, + templateHaskellNames, qTyConName, nameTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, + decQTyConName, decsQTyConName, typeQTyConName, + decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, + quoteExpName, quotePatName, quoteDecName, quoteTypeName, + tExpTyConName, tExpDataConName, unTypeName, unTypeQName, + unsafeTExpCoerceName + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsExpr ) + +import MatchLit +import DsMonad + +import qualified Language.Haskell.TH as TH + +import HsSyn +import Class +import PrelNames +-- To avoid clashes with DsMeta.varName we must make a local alias for +-- OccName.varName we do this by removing varName from the import of +-- OccName above, making a qualified instance of OccName and using +-- OccNameAlias.varName where varName ws previously used in this file. +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName ) + +import Module +import Id +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) +import NameEnv +import TcType +import TyCon +import TysWiredIn +import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) +import CoreSyn +import MkCore +import CoreUtils +import SrcLoc +import Unique +import BasicTypes +import Outputable +import Bag +import DynFlags +import FastString +import ForeignCall +import Util +import MonadUtils + +import Data.Maybe +import Control.Monad +import Data.List + +----------------------------------------------------------------------------- +dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr +-- Returns a CoreExpr of type TH.ExpQ +-- The quoted thing is parameterised over Name, even though it has +-- been type checked. We don't want all those type decorations! + +dsBracket brack splices + = dsExtendMetaEnv new_bit (do_brack brack) + where + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendSplice n e <- splices] + + do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } + +{- -------------- Examples -------------------- + + [| \x -> x |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (var x1) + + + [| \x -> $(f [| x |]) |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (f (var x1)) +-} + + +------------------------------------------------------- +-- Declarations +------------------------------------------------------- + +repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapGenSyms ss pat' } + +repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) +repTopDs group@(HsGroup { hs_valds = valds + , hs_splcds = splcds + , hs_tyclds = tyclds + , hs_instds = instds + , hs_derivds = derivds + , hs_fixds = fixds + , hs_defds = defds + , hs_fords = fords + , hs_warnds = warnds + , hs_annds = annds + , hs_ruleds = ruleds + , hs_vects = vects + , hs_docs = docs }) + = do { let { tv_bndrs = hsSigTvBinders valds + ; bndrs = tv_bndrs ++ hsGroupBinders group } ; + ss <- mkGenSyms bndrs ; + + -- Bind all the names mainly to avoid repeated use of explicit strings. + -- Thus we get + -- do { t :: String <- genSym "T" ; + -- return (Data t [] ...more t's... } + -- The other important reason is that the output must mention + -- only "T", not "Foo:T" where Foo is the current module + + decls <- addBinds ss ( + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repFixD fixds + ; _ <- mapM no_default_decl defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) + warnds) + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) + ruleds) + ; _ <- mapM no_vect vects + ; _ <- mapM no_doc docs + + -- more needed + ; return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ role_ds + ++ (concat fix_ds) + ++ inst_ds ++ rule_ds ++ for_ds + ++ ann_ds ++ deriv_ds) }) ; + + decl_ty <- lookupType decQTyConName ; + let { core_list = coreList' decl_ty decls } ; + + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceQ dec_ty core_list ; + + wrapGenSyms ss q_decs + } + where + no_splice (L loc _) + = notHandledL loc "Splices within declaration brackets" empty + no_default_decl (L loc decl) + = notHandledL loc "Default declarations" (ppr decl) + no_warn (L loc (Warning thing _)) + = notHandledL loc "WARNING and DEPRECATION pragmas" $ + text "Pragma for declaration of" <+> ppr thing + no_vect (L loc decl) + = notHandledL loc "Vectorisation pragmas" (ppr decl) + no_doc (L loc _) + = notHandledL loc "Haddock documentation" empty + +hsSigTvBinders :: HsValBinds Name -> [Name] +-- See Note [Scoped type variables in bindings] +hsSigTvBinders binds + = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs + , tv <- hsQTvBndrs qtvs] + where + sigs = case binds of + ValBindsIn _ sigs -> sigs + ValBindsOut _ sigs -> sigs + + +{- Notes + +Note [Scoped type variables in bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a + f x = x::a +Here the 'forall a' brings 'a' into scope over the binding group. +To achieve this we + + a) Gensym a binding for 'a' at the same time as we do one for 'f' + collecting the relevant binders with hsSigTvBinders + + b) When processing the 'forall', don't gensym + +The relevant places are signposted with references to this Note + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we desugar [d| data T = MkT |] +we want to get + Data "T" [] [Con "MkT" []] [] +and *not* + Data "Foo:T" [] [Con "Foo:MkT" []] [] +That is, the new data decl should fit into whatever new module it is +asked to fit in. We do *not* clone, though; no need for this: + Data "T79" .... + +But if we see this: + data T = MkT + foo = reifyDecl T + +then we must desugar to + foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] + +So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. +And we use lookupOcc, rather than lookupBinder +in repTyClD and repC. + +-} + +-- represent associated family instances +-- +repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) + +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) + +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repSynDecl tc1 bndrs rhs + ; return (Just (loc, dec)) } + +repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; tc_tvs <- mk_extra_tvs tc tvs defn + ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> + repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn + ; return (Just (loc, dec)) } + +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats, tcdATDefs = [] })) + = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; sigs1 <- rep_sigs sigs + ; binds1 <- rep_binds meth_binds + ; fds1 <- repLFunDeps fds + ; ats1 <- repFamilyDecls ats + ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) + ; repClass cxt1 cls1 bndrs fds1 decls1 + } + ; return $ Just (loc, dec) + } + +-- Un-handled cases +repTyClD (L loc d) = putSrcSpanDs loc $ + do { warnDs (hang ds_msg 4 (ppr d)) + ; return Nothing } + +------------------------- +repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRoleD (L loc (RoleAnnotDecl tycon roles)) + = do { tycon1 <- lookupLOcc tycon + ; roles1 <- mapM repRole roles + ; roles2 <- coreList roleTyConName roles1 + ; dec <- repRoleAnnotD tycon1 roles2 + ; return (loc, dec) } + +------------------------- +repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> [Name] -> HsDataDefn Name + -> DsM (Core TH.DecQ) +repDataDefn tc bndrs opt_tys tv_names + (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt + , dd_cons = cons, dd_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case new_or_data of + NewType -> do { con1 <- repC tv_names (head cons) + ; case con1 of + [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1 + _cs -> failWithDs (ptext + (sLit "Multiple constructors for newtype:") + <+> pprQuotedList + (con_names $ unLoc $ head cons)) + } + DataType -> do { consL <- concatMapM (repC tv_names) cons + ; cons1 <- coreList conQTyConName consL + ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } } + +repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] + -> LHsType Name + -> DsM (Core TH.DecQ) +repSynDecl tc bndrs ty + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs ty1 } + +repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repFamilyDecl (L loc (FamilyDecl { fdInfo = info, + fdLName = tc, + fdTyVars = tvs, + fdKindSig = opt_kind })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + case (opt_kind, info) of + (Nothing, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; repClosedFamilyNoKind tc1 bndrs eqns2 } + (Just ki, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; ki1 <- repLKind ki + ; repClosedFamilyKind tc1 bndrs ki1 eqns2 } + (Nothing, _) -> + do { info' <- repFamilyInfo info + ; repFamilyNoKind info' tc1 bndrs } + (Just ki, _) -> + do { info' <- repFamilyInfo info + ; ki1 <- repLKind ki + ; repFamilyKind info' tc1 bndrs ki1 } + ; return (loc, dec) + } + +repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] +repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) + +------------------------- +mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name + -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) +-- If there is a kind signature it must be of form +-- k1 -> .. -> kn -> * +-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] +mk_extra_tvs tc tvs defn + | HsDataDefn { dd_kindSig = Just hs_kind } <- defn + = do { extra_tvs <- go hs_kind + ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) } + | otherwise + = return tvs + where + go :: LHsKind Name -> DsM [LHsTyVarBndr Name] + go (L loc (HsFunTy kind rest)) + = do { uniq <- newUnique + ; let { occ = mkTyVarOccFS (fsLit "t") + ; nm = mkInternalName uniq occ loc + ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) } + ; hs_tvs <- go rest + ; return (hs_tv : hs_tvs) } + + go (L _ (HsTyVar n)) + | n == liftedTypeKindTyConName + = return [] + + go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc) + +------------------------- +-- represent fundeps +-- +repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep]) +repLFunDeps fds = repList funDepTyConName repLFunDep fds + +repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep) +repLFunDep (L _ (xs, ys)) + = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs + ys' <- repList nameTyConName (lookupBinder . unLoc) ys + repFunDep xs' ys' + +-- represent family declaration flavours +-- +repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour) +repFamilyInfo OpenTypeFamily = rep2 typeFamName [] +repFamilyInfo DataFamily = rep2 dataFamName [] +repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo" + +-- Represent instance declarations +-- +repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) + = do { dec <- repTyFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) + = do { dec <- repDataFamInstD fi_decl + ; return (loc, dec) } +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) + = do { dec <- repClsInstD cls_decl + ; return (loc, dec) } + +repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) +repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds + , cid_sigs = prags, cid_tyfam_insts = ats + , cid_datafam_insts = adts }) + = addTyVarBinds tvs $ \_ -> + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't + -- appear in the resulting data structure + -- + -- But we do NOT bring the binders of 'binds' into scope + -- because they are properly regarded as occurrences + -- For example, the method names should be bound to + -- the selector Ids, not to fresh names (Trac #5410) + -- + do { cxt1 <- repContext cxt + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tys <- repLTys tys + ; inst_ty1 <- repTapps cls_tcon cls_tys + ; binds1 <- rep_binds binds + ; prags1 <- rep_sigs prags + ; ats1 <- mapM (repTyFamInstD . unLoc) ats + ; adts1 <- mapM (repDataFamInstD . unLoc) adts + ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) + ; repInst cxt1 inst_ty1 decls } + where + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + +repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) + = do { dec <- addTyVarBinds tvs $ \_ -> + do { cxt' <- repContext cxt + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tys <- repLTys tys + ; inst_ty <- repTapps cls_tcon cls_tys + ; repDeriv cxt' inst_ty } + ; return (loc, dec) } + where + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + +repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) +repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) + = do { let tc_name = tyFamInstDeclLName decl + ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; eqn1 <- repTyFamEqn eqn + ; repTySynInst tc eqn1 } + +repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) +repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys + , hswb_kvs = kv_names + , hswb_tvs = tv_names } + , tfe_rhs = rhs })) + = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names + , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk + ; addTyClTyVarBinds hs_tvs $ \ _ -> + do { tys1 <- repLTys tys + ; tys2 <- coreList typeQTyConName tys1 + ; rhs1 <- repLTy rhs + ; repTySynEqn tys2 rhs1 } } + +repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) +repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name + , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names } + , dfid_defn = defn }) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let loc = getLoc tc_name + hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk + ; addTyClTyVarBinds hs_tvs $ \ bndrs -> + do { tys1 <- repList typeQTyConName repLTy tys + ; repDataDefn tc bndrs (Just tys1) tv_names defn } } + +repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) +repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) + = do MkC name' <- lookupLOcc name + MkC typ' <- repLTy typ + MkC cc' <- repCCallConv cc + MkC s' <- repSafety s + cis' <- conv_cimportspec cis + MkC str <- coreStringLit (static ++ chStr ++ cis') + dec <- rep2 forImpDName [cc', s', str, name', typ'] + return (loc, dec) + where + conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) + conv_cimportspec (CFunction DynamicTarget) = return "dynamic" + conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet" + conv_cimportspec CWrapper = return "wrapper" + -- these calling conventions do not support headers and the static keyword + raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv + static = case cis of + CFunction (StaticTarget _ _ _) | not raw_cconv -> "static " + _ -> "" + chStr = case mch of + Just (Header h) | not raw_cconv -> unpackFS h ++ " " + _ -> "" +repForD decl = notHandled "Foreign declaration" (ppr decl) + +repCCallConv :: CCallConv -> DsM (Core TH.Callconv) +repCCallConv CCallConv = rep2 cCallName [] +repCCallConv StdCallConv = rep2 stdCallName [] +repCCallConv CApiConv = rep2 cApiCallName [] +repCCallConv PrimCallConv = rep2 primCallName [] +repCCallConv JavaScriptCallConv = rep2 javaScriptCallName [] + +repSafety :: Safety -> DsM (Core TH.Safety) +repSafety PlayRisky = rep2 unsafeName [] +repSafety PlayInterruptible = rep2 interruptibleName [] +repSafety PlaySafe = rep2 safeName [] + +repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] +repFixD (L loc (FixitySig names (Fixity prec dir))) + = do { MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; let do_one name + = do { MkC name' <- lookupLOcc name + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc,dec) } + ; mapM do_one names } + +repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) + = do { let bndr_names = concatMap ruleBndrNames bndrs + ; ss <- mkGenSyms bndr_names + ; rule1 <- addBinds ss $ + do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs + ; n' <- coreStringLit $ unpackFS $ unLoc n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' bndrs' lhs' rhs' act' } + ; rule2 <- wrapGenSyms ss rule1 + ; return (loc, rule2) } + +ruleBndrNames :: LRuleBndr Name -> [Name] +ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))) + = unLoc n : kvs ++ tvs + +repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr (L _ (RuleBndr n)) + = do { MkC n' <- lookupLBinder n + ; rep2 ruleVarName [n'] } +repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty }))) + = do { MkC n' <- lookupLBinder n + ; MkC ty' <- repLTy ty + ; rep2 typedRuleVarName [n', ty'] } + +repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) + = do { target <- repAnnProv ann_prov + ; exp' <- repE exp + ; dec <- repPragAnn target exp' + ; return (loc, dec) } + +repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) +repAnnProv (ValueAnnProvenance (L _ n)) + = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level + ; rep2 valueAnnotationName [ n' ] } +repAnnProv (TypeAnnProvenance (L _ n)) + = do { MkC n' <- globalVar n + ; rep2 typeAnnotationName [ n' ] } +repAnnProv ModuleAnnProvenance + = rep2 moduleAnnotationName [] + +ds_msg :: SDoc +ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") + +------------------------------------------------------- +-- Constructors +------------------------------------------------------- + +repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ] +repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) + | null (hsQTvBndrs con_tvs) + = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences] + ; mapM (\c -> repConstr c details) con1 } + +repC tvs (L _ (ConDecl { con_names = cons + , con_qvars = con_tvs, con_cxt = L _ ctxt + , con_details = details + , con_res = res_ty })) + = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty + ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) + , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } + + ; binds <- mapM dupBinder con_tv_subst + ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs + do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + ; c' <- mapM (\c -> repConstr c details) cons1 + ; ctxt' <- repContext (eq_ctxt ++ ctxt) + ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) } + ; return [b] + } + +in_subst :: [(Name,Name)] -> Name -> Bool +in_subst [] _ = False +in_subst ((n',_):ns) n = n==n' || in_subst ns n + +mkGadtCtxt :: [Name] -- Tyvars of the data type + -> ResType (LHsType Name) + -> DsM (HsContext Name, [(Name,Name)]) +-- Given a data type in GADT syntax, figure out the equality +-- context, so that we can represent it with an explicit +-- equality context, because that is the only way to express +-- the GADT in TH syntax +-- +-- Example: +-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e +-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e) +-- returns +-- (b~[e], c~e), [d->a] +-- +-- This function is fiddly, but not really hard +mkGadtCtxt _ ResTyH98 + = return ([], []) +mkGadtCtxt data_tvs (ResTyGADT _ res_ty) + | Just (_, tys) <- hsTyGetAppHead_maybe res_ty + , data_tvs `equalLength` tys + = return (go [] [] (data_tvs `zip` tys)) + + | otherwise + = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) + where + go cxt subst [] = (cxt, subst) + go cxt subst ((data_tv, ty) : rest) + | Just con_tv <- is_hs_tyvar ty + , isTyVarName con_tv + , not (in_subst subst con_tv) + = go cxt ((con_tv, data_tv) : subst) rest + | otherwise + = go (eq_pred : cxt) subst rest + where + loc = getLoc ty + eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty) + + is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons + is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty + is_hs_tyvar _ = Nothing + + +repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) +repBangTy ty= do + MkC s <- rep2 str [] + MkC t <- repLTy ty' + rep2 strictTypeName [s, t] + where + (str, ty') = case ty of + L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName, ty) + L _ (HsBangTy (HsSrcBang _ _ True) ty) -> (isStrictName, ty) + _ -> (notStrictName, ty) + +------------------------------------------------------- +-- Deriving clause +------------------------------------------------------- + +repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name]) +repDerivs Nothing = coreList nameTyConName [] +repDerivs (Just (L _ ctxt)) + = repList nameTyConName rep_deriv ctxt + where + rep_deriv :: LHsType Name -> DsM (Core TH.Name) + -- Deriving clauses must have the simple H98 form + rep_deriv ty + | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty) + = lookupOcc cls + | otherwise + = notHandled "Non-H98 deriving clause" (ppr ty) + + +------------------------------------------------------- +-- Signatures in a class decl, or a group of bindings +------------------------------------------------------- + +rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] +rep_sigs sigs = do locs_cores <- rep_sigs' sigs + return $ de_loc $ sort_by_loc locs_cores + +rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] + -- We silently ignore ones we don't recognise +rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; + return (concat sigs1) } + +rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms +rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty +rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms +rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level +rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc +rep_sig (L loc (SpecSig nm tys ispec)) + = concatMapM (\t -> rep_specialise nm t ispec loc) tys +rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc +rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty + +rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) +rep_ty_sig mk_sig loc (L _ ty) nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty ty + ; sig <- repProto mk_sig nm1 ty1 + ; return (loc, sig) } + where + -- We must special-case the top-level explicit for-all of a TypeSig + -- See Note [Scoped type variables in bindings] + rep_ty (HsForAllTy Explicit _ tvs ctxt ty) + = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs) + ; ctxt1 <- repLContext ctxt + ; ty1 <- repLTy ty + ; repTForall bndrs1 ctxt1 ty1 } + + rep_ty ty = repTy ty + +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; inline <- repInline $ inl_inline ispec + ; rm <- repRuleMatch $ inl_rule ispec + ; phases <- repPhases $ inl_act ispec + ; pragma <- repPragInl nm1 inline rm phases + ; return [(loc, pragma)] + } + +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialise nm ty ispec loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; phases <- repPhases $ inl_act ispec + ; let inline = inl_inline ispec + ; pragma <- if isEmptyInlineSpec inline + then -- SPECIALISE + repPragSpec nm1 ty1 phases + else -- SPECIALISE INLINE + do { inline1 <- repInline inline + ; repPragSpecInl nm1 ty1 inline1 phases } + ; return [(loc, pragma)] + } + +rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialiseInst ty loc + = do { ty1 <- repLTy ty + ; pragma <- repPragSpecInst ty1 + ; return [(loc, pragma)] } + +repInline :: InlineSpec -> DsM (Core TH.Inline) +repInline NoInline = dataCon noInlineDataConName +repInline Inline = dataCon inlineDataConName +repInline Inlinable = dataCon inlinableDataConName +repInline spec = notHandled "repInline" (ppr spec) + +repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch) +repRuleMatch ConLike = dataCon conLikeDataConName +repRuleMatch FunLike = dataCon funLikeDataConName + +repPhases :: Activation -> DsM (Core TH.Phases) +repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i + ; dataCon' beforePhaseDataConName [arg] } +repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i + ; dataCon' fromPhaseDataConName [arg] } +repPhases _ = dataCon allPhasesDataConName + +------------------------------------------------------- +-- Types +------------------------------------------------------- + +addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) +-- gensym a list of type variables and enter them into the meta environment; +-- the computations passed as the second argument is executed in that extended +-- meta environment and gets the *new* names on Core-level as an argument + +addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m + = do { fresh_kv_names <- mkGenSyms kvs + ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs) + ; let fresh_names = fresh_kv_names ++ fresh_tv_names + ; term <- addBinds fresh_names $ + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names) + ; m kbs } + ; wrapGenSyms fresh_names term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) + +addTyClTyVarBinds :: LHsTyVarBndrs Name + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) + -> DsM (Core (TH.Q a)) + +-- Used for data/newtype declarations, and family instances, +-- so that the nested type variables work right +-- instance C (T a) where +-- type W (T a) = blah +-- The 'a' in the type instance is the one bound by the instance decl +addTyClTyVarBinds tvs m + = do { let tv_names = hsLKiTyVarNames tvs + ; env <- dsGetMetaEnv + ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) + -- Make fresh names for the ones that are not already in scope + -- This makes things work for family declarations + + ; term <- addBinds freshNames $ + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs) + ; m kbs } + + ; wrapGenSyms freshNames term } + where + mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv v } + +-- Produce kinded binder constructors from the Haskell tyvar binders +-- +repTyVarBndrWithKind :: LHsTyVarBndr Name + -> Core TH.Name -> DsM (Core TH.TyVarBndr) +repTyVarBndrWithKind (L _ (UserTyVar _)) nm + = repPlainTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm + = repLKind ki >>= repKindedTV nm + +-- represent a type context +-- +repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext (L _ ctxt) = repContext ctxt + +repContext :: HsContext Name -> DsM (Core TH.CxtQ) +repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt + repCtxt preds + +-- yield the representation of a list of types +-- +repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys tys = mapM repLTy tys + +-- represent a type +-- +repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy (L _ ty) = repTy ty + +repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy (HsForAllTy _ _ tvs ctxt ty) = + addTyVarBinds tvs $ \bndrs -> do + ctxt1 <- repLContext ctxt + ty1 <- repLTy ty + repTForall bndrs ctxt1 ty1 + +repTy (HsTyVar n) + | isTvOcc occ = do tv1 <- lookupOcc n + repTvar tv1 + | isDataOcc occ = do tc1 <- lookupOcc n + repPromotedTyCon tc1 + | otherwise = do tc1 <- lookupOcc n + repNamedTyCon tc1 + where + occ = nameOccName n + +repTy (HsAppTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsFunTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) + repTapp tcon t1 +repTy (HsTupleTy HsUnboxedTuple tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t +repTy (HsEqTy t1 t2) = do + t1' <- repLTy t1 + t2' <- repLTy t2 + eq <- repTequality + repTapps eq [t1', t2'] +repTy (HsKindSig t k) = do + t1 <- repLTy t + k1 <- repLKind k + repTSig t1 k1 +repTy (HsSpliceTy splice _) = repSplice splice +repTy (HsExplicitListTy _ tys) = do + tys1 <- repLTys tys + repTPromotedList tys1 +repTy (HsExplicitTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repPromotedTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsTyLit lit) = do + lit' <- repTyLit lit + repTLit lit' + +repTy ty = notHandled "Exotic form of type" (ppr ty) + +repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) +repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i + rep2 numTyLitName [iExpr] +repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s + ; rep2 strTyLitName [s'] + } + +-- represent a kind +-- +repLKind :: LHsKind Name -> DsM (Core TH.Kind) +repLKind ki + = do { let (kis, ki') = splitHsFunType ki + ; kis_rep <- mapM repLKind kis + ; ki'_rep <- repNonArrowLKind ki' + ; kcon <- repKArrow + ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2 + ; foldrM f ki'_rep kis_rep + } + +repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) +repNonArrowLKind (L _ ki) = repNonArrowKind ki + +repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) +repNonArrowKind (HsTyVar name) + | name == liftedTypeKindTyConName = repKStar + | name == constraintKindTyConName = repKConstraint + | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar + | otherwise = lookupOcc name >>= repKCon +repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f + ; a' <- repLKind a + ; repKApp f' a' + } +repNonArrowKind (HsListTy k) = do { k' <- repLKind k + ; kcon <- repKList + ; repKApp kcon k' + } +repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks + ; kcon <- repKTuple (length ks) + ; repKApps kcon ks' + } +repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) + +repRole :: Located (Maybe Role) -> DsM (Core TH.Role) +repRole (L _ (Just Nominal)) = rep2 nominalRName [] +repRole (L _ (Just Representational)) = rep2 representationalRName [] +repRole (L _ (Just Phantom)) = rep2 phantomRName [] +repRole (L _ Nothing) = rep2 inferRName [] + +----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +repSplice :: HsSplice Name -> DsM (Core a) +-- See Note [How brackets and nested splices are handled] in TcSplice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsSplice n _) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (DsSplice e) -> do { e' <- dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- +-- Expressions +----------------------------------------------------------------------------- + +repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs es = repList expQTyConName repLE es + +-- FIXME: some of these panics should be converted into proper error messages +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage +repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) +repLE (L loc e) = putSrcSpanDs loc (repE e) + +repE :: HsExpr Name -> DsM (Core TH.ExpQ) +repE (HsVar x) = + do { mb_val <- dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- globalVar x + ; repVarOrCon x str } + Just (DsBound y) -> repVarOrCon x (coreVar y) + Just (DsSplice e) -> do { e' <- dsExpr e + ; return (MkC e') } } +repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) + + -- Remember, we're desugaring renamer output here, so + -- HsOverlit can definitely occur +repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit l) = do { a <- repLiteral l; repLit a } +repE (HsLam (MG { mg_alts = [m] })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = ms })) + = do { ms' <- mapM repMatchTup ms + ; core_ms <- coreList matchQTyConName ms' + ; repLamCase core_ms } +repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} + +repE (OpApp e1 op _ e2) = + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; + repInfixApp arg1 the_op arg2 } +repE (NegApp x _) = do + a <- repLE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a +repE (HsPar x) = repLE x +repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase e (MG { mg_alts = ms })) + = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; core_ms2 <- coreList matchQTyConName ms2 + ; repCaseE arg core_ms2 } +repE (HsIf _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c +repE (HsMultiIf _ alts) + = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList alts') + ; wrapGenSyms (concat binds) expr' } +repE (HsLet bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } + +-- FIXME: I haven't got the types here right yet +repE e@(HsDo ctxt sts _) + | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } + = do { (ss,zs) <- repLSts sts; + e' <- repDoE (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | ListComp <- ctxt + = do { (ss,zs) <- repLSts sts; + e' <- repComp (nonEmptyCoreList zs); + wrapGenSyms ss e' } + + | otherwise + = notHandled "mdo, monad comprehension and [: :]" (ppr e) + +repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } +repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) +repE e@(ExplicitTuple es boxed) + | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) + | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] + ; repUnboxedTup xs } + +repE (RecordCon c _ flds) + = do { x <- lookupLOcc c; + fs <- repFields flds; + repRecCon x fs } +repE (RecordUpd e flds _ _ _) + = do { x <- repLE e; + fs <- repFields flds; + repRecUpd x fs } + +repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } +repE (ArithSeq _ _ aseq) = + case aseq of + From e -> do { ds1 <- repLE e; repFrom ds1 } + FromThen e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromThen ds1 ds2 + FromTo e1 e2 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromTo ds1 ds2 + FromThenTo e1 e2 e3 -> do + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 + repFromThenTo ds1 ds2 ds3 + +repE (HsSpliceE _ splice) = repSplice splice +repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC +repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) +repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) +repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) +repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) +repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e) +repE e = notHandled "Expression form" (ppr e) + +----------------------------------------------------------------------------- +-- Building representations of auxillary structures like Match, Clause, Stmt, + +repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) +repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) = + do { ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + ; gs <- repGuards guards + ; match <- repMatch p1 gs ds + ; wrapGenSyms (ss1++ss2) match }}} +repMatchTup _ = panic "repMatchTup: case alt with more than one arg" + +repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) +repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) = + do { ss1 <- mkGenSyms (collectPatsBinders ps) + ; addBinds ss1 $ do { + ps1 <- repLPs ps + ; (ss2,ds) <- repBinds wheres + ; addBinds ss2 $ do { + gs <- repGuards guards + ; clause <- repClause ps1 gs ds + ; wrapGenSyms (ss1++ss2) clause }}} + +repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) +repGuards [L _ (GRHS [] e)] + = do {a <- repLE e; repNormal a } +repGuards other + = do { zs <- mapM repLGRHS other + ; let (xs, ys) = unzip zs + ; gd <- repGuarded (nonEmptyCoreList ys) + ; wrapGenSyms (concat xs) gd } + +repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) + = do { guarded <- repLNormalGE e1 e2 + ; return ([], guarded) } +repLGRHS (L _ (GRHS ss rhs)) + = do { (gs, ss') <- repLSts ss + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' + ; return (gs, guarded) } + +repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = repList fieldExpQTyConName rep_fld flds + where + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } + + +----------------------------------------------------------------------------- +-- Representing Stmt's is tricky, especially if bound variables +-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- First gensym new names for every variable in any of the patterns. +-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) +-- if variables didn't shaddow, the static gensym wouldn't be necessary +-- and we could reuse the original names (x and x). +-- +-- do { x'1 <- gensym "x" +-- ; x'2 <- gensym "x" +-- ; doE [ BindSt (pvar x'1) [| f 1 |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] +-- ] +-- } + +-- The strategy is to translate a whole list of do-bindings by building a +-- bigger environment, and a bigger set of meta bindings +-- (like: x'1 <- gensym "x" ) and then combining these with the translations +-- of the expressions within the Do + +----------------------------------------------------------------------------- +-- The helper function repSts computes the translation of each sub expression +-- and a bunch of prefix bindings denoting the dynamic renaming. + +repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts stmts = repSts (map unLoc stmts) + +repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts (BindStmt p e _ _ : ss) = + do { e2 <- repLE e + ; ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repLP p; + ; (ss2,zs) <- repSts ss + ; z <- repBindSt p1 e2 + ; return (ss1++ss2, z : zs) }} +repSts (LetStmt bs : ss) = + do { (ss1,ds) <- repBinds bs + ; z <- repLetSt ds + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (BodyStmt e _ _ _ : ss) = + do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; (ss2,zs) <- repSts ss + ; return (ss2, z : zs) } +repSts (ParStmt stmt_blocks _ _ : ss) = + do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 + ss1 = concat ss_s + ; z <- repParSt stmt_blocks2 + ; (ss2, zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } + where + rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) + rep_stmt_block (ParStmtBlock stmts _ _) = + do { (ss1, zs) <- repSts (map unLoc stmts) + ; zs1 <- coreList stmtQTyConName zs + ; return (ss1, zs1) } +repSts [LastStmt e _] + = do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; return ([], [z]) } +repSts [] = return ([],[]) +repSts other = notHandled "Exotic statement" (ppr other) + + +----------------------------------------------------------- +-- Bindings +----------------------------------------------------------- + +repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds EmptyLocalBinds + = do { core_list <- coreList decQTyConName [] + ; return ([], core_list) } + +repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) + +repBinds (HsValBinds decs) + = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } + -- No need to worrry about detailed scopes within + -- the binding group, because we are talking Names + -- here, so we can safely treat it as a mutually + -- recursive group + -- For hsSigTvBinders see Note [Scoped type variables in bindings] + ; ss <- mkGenSyms bndrs + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc prs)) + ; return (ss, core_list) } + +rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +-- Assumes: all the binders of the binding are alrady in the meta-env +rep_val_binds (ValBindsOut binds sigs) + = do { core1 <- rep_binds' (unionManyBags (map snd binds)) + ; core2 <- rep_sigs' sigs + ; return (core1 ++ core2) } +rep_val_binds (ValBindsIn _ _) + = panic "rep_val_binds: ValBindsIn" + +rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] +rep_binds binds = do { binds_w_locs <- rep_binds' binds + ; return (de_loc (sort_by_loc binds_w_locs)) } + +rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' = mapM rep_bind . bagToList + +rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) +-- Assumes: all the binders of the binding are alrady in the meta-env + +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- with an empty list of patterns +rep_bind (L loc (FunBind + { fun_id = fn, + fun_matches = MG { mg_alts = [L _ (Match _ [] _ + (GRHSs guards wheres))] } })) + = do { (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupLBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } + +rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } })) + = do { ms1 <- mapM repClauseTup ms + ; fn' <- lookupLBinder fn + ; ans <- repFun fn' (nonEmptyCoreList ms1) + ; return (loc, ans) } + +rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) + = do { patcore <- repLP pat + ; (ss,wherecore) <- repBinds wheres + ; guardcore <- addBinds ss (repGuards guards) + ; ans <- repVal patcore guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } + +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) + = do { v' <- lookupBinder v + ; e2 <- repLE e + ; x <- repNormal e2 + ; patcore <- repPvar v' + ; empty_decls <- coreList decQTyConName [] + ; ans <- repVal patcore x empty_decls + ; return (srcLocSpan (getSrcLoc v), ans) } + +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec) +----------------------------------------------------------------------------- +-- Since everything in a Bind is mutually recursive we need rename all +-- all the variables simultaneously. For example: +-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to +-- do { f'1 <- gensym "f" +-- ; g'2 <- gensym "g" +-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, +-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} +-- ]} +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as +-- MonoBinds, but which has slots for the representations + + +----------------------------------------------------------------------------- +-- GHC allows a more general form of lambda abstraction than specified +-- by Haskell 98. In particular it allows guarded lambda's like : +-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in +-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like +-- (\ p1 .. pn -> exp) by causing an error. + +repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) +repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) + = do { let bndrs = collectPatsBinders ps ; + ; ss <- mkGenSyms bndrs + ; lam <- addBinds ss ( + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + ; wrapGenSyms ss lam } + +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) + + +----------------------------------------------------------------------------- +-- Patterns +-- repP deals with patterns. It assumes that we have already +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound +-- variable should already appear in the environment. + +-- Process a list of patterns +repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) +repLPs ps = repList patQTyConName repLP ps + +repLP :: LPat Name -> DsM (Core TH.PatQ) +repLP (L _ p) = repP p + +repP :: Pat Name -> DsM (Core TH.PatQ) +repP (WildPat _) = repPwild +repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p} +repP (TuplePat ps boxed _) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } +repP (ConPatIn dc details) + = do { con_str <- lookupLOcc dc + ; case details of + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec) + ; repPrec con_str fps } + InfixCon p1 p2 -> do { p1' <- repLP p1; + p2' <- repLP p2; + repPinfix p1' con_str p2' } + } + where + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } + +repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) + -- The problem is to do with scoped type variables. + -- To implement them, we have to implement the scoping rules + -- here in DsMeta, and I don't want to do that today! + -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } + -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) + -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + +repP (SplicePat splice) = repSplice splice + +repP other = notHandled "Exotic pattern" (ppr other) + +---------------------------------------------------------- +-- Declaration ordering helpers + +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] +sort_by_loc xs = sortBy comp xs + where comp x y = compare (fst x) (fst y) + +de_loc :: [(a, b)] -> [b] +de_loc = map snd + +---------------------------------------------------------- +-- The meta-environment + +-- A name/identifier association for fresh names of locally bound entities +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... + +-- Generate a fresh name for a locally bound entity + +mkGenSyms :: [Name] -> DsM [GenSymBind] +-- We can use the existing name. For example: +-- [| \x_77 -> x_77 + x_77 |] +-- desugars to +-- do { x_77 <- genSym "x"; .... } +-- We use the same x_77 in the desugared program, but with the type Bndr +-- instead of Int +-- +-- We do make it an Internal name, though (hence localiseName) +-- +-- Nevertheless, it's monadic because we have to generate nameTy +mkGenSyms ns = do { var_ty <- lookupType nameTyConName + ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } + + +addBinds :: [GenSymBind] -> DsM a -> DsM a +-- Add a list of fresh names for locally bound entities to the +-- meta environment (which is part of the state carried around +-- by the desugarer monad) +addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m + +dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal) +dupBinder (new, old) + = do { mb_val <- dsLookupMetaEnv old + ; case mb_val of + Just val -> return (new, val) + Nothing -> pprPanic "dupBinder" (ppr old) } + +-- Look up a locally bound name +-- +lookupLBinder :: Located Name -> DsM (Core TH.Name) +lookupLBinder (L _ n) = lookupBinder n + +lookupBinder :: Name -> DsM (Core TH.Name) +lookupBinder = lookupOcc + -- Binders are brought into scope before the pattern or what-not is + -- desugared. Moreover, in instance declaration the binder of a method + -- will be the selector Id and hence a global; so we need the + -- globalVar case of lookupOcc + +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- +lookupLOcc :: Located Name -> DsM (Core TH.Name) +-- Lookup an occurrence; it can't be a splice. +-- Use the in-scope bindings if they exist +lookupLOcc (L _ n) = lookupOcc n + +lookupOcc :: Name -> DsM (Core TH.Name) +lookupOcc n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Nothing -> globalVar n + Just (DsBound x) -> return (coreVar x) + Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) + } + +globalVar :: Name -> DsM (Core TH.Name) +-- Not bound by the meta-env +-- Could be top-level; or could be local +-- f x = $(g [| x |]) +-- Here the x will be local +globalVar name + | isExternalName name + = do { MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg + ; MkC occ <- occNameLit name + ; rep2 mk_varg [pkg,mod,occ] } + | otherwise + = do { MkC occ <- occNameLit name + ; MkC uni <- coreIntLit (getKey (getUnique name)) + ; rep2 mkNameLName [occ,uni] } + where + mod = ASSERT( isExternalName name) nameModule name + name_mod = moduleNameString (moduleName mod) + name_pkg = packageKeyString (modulePackageKey mod) + name_occ = nameOccName name + mk_varg | OccName.isDataOcc name_occ = mkNameG_dName + | OccName.isVarOcc name_occ = mkNameG_vName + | OccName.isTcOcc name_occ = mkNameG_tcName + | otherwise = pprPanic "DsMeta.globalVar" (ppr name) + +lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) + -> DsM Type -- The type +lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; + return (mkTyConApp tc []) } + +wrapGenSyms :: [GenSymBind] + -> Core (TH.Q a) -> DsM (Core (TH.Q a)) +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) + +wrapGenSyms binds body@(MkC b) + = do { var_ty <- lookupType nameTyConName + ; go var_ty binds } + where + [elt_ty] = tcTyConAppArgs (exprType b) + -- b :: Q a, so we can get the type 'a' by looking at the + -- argument type. NB: this relies on Q being a data/newtype, + -- not a type synonym + + go _ [] = return body + go var_ty ((name,id) : binds) + = do { MkC body' <- go var_ty binds + ; lit_str <- occNameLit name + ; gensym_app <- repGensym lit_str + ; repBindQ var_ty elt_ty + gensym_app (MkC (Lam id body')) } + +occNameLit :: Name -> DsM (Core String) +occNameLit n = coreStringLit (occNameString (nameOccName n)) + + +-- %********************************************************************* +-- %* * +-- Constructing code +-- %* * +-- %********************************************************************* + +----------------------------------------------------------------------------- +-- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- we invent a new datatype which uses phantom types. + +newtype Core a = MkC CoreExpr +unC :: Core a -> CoreExpr +unC (MkC x) = x + +rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) +rep2 n xs = do { id <- dsLookupGlobalId n + ; return (MkC (foldl App (Var id) xs)) } + +dataCon' :: Name -> [CoreExpr] -> DsM (Core a) +dataCon' n args = do { id <- dsLookupDataCon n + ; return $ MkC $ mkCoreConApps id args } + +dataCon :: Name -> DsM (Core a) +dataCon n = dataCon' n [] + +-- Then we make "repConstructors" which use the phantom types for each of the +-- smart constructors of the Meta.Meta datatypes. + + +-- %********************************************************************* +-- %* * +-- The 'smart constructors' +-- %* * +-- %********************************************************************* + +--------------- Patterns ----------------- +repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) +repPlit (MkC l) = rep2 litPName [l] + +repPvar :: Core TH.Name -> DsM (Core TH.PatQ) +repPvar (MkC s) = rep2 varPName [s] + +repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPtup (MkC ps) = rep2 tupPName [ps] + +repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + +repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] + +repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ) +repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] + +repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] + +repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) +repPtilde (MkC p) = rep2 tildePName [p] + +repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) +repPbang (MkC p) = rep2 bangPName [p] + +repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] + +repPwild :: DsM (Core TH.PatQ) +repPwild = rep2 wildPName [] + +repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPlist (MkC ps) = rep2 listPName [ps] + +repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + +--------------- Expressions ----------------- +repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) +repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str + | otherwise = repVar str + +repVar :: Core TH.Name -> DsM (Core TH.ExpQ) +repVar (MkC s) = rep2 varEName [s] + +repCon :: Core TH.Name -> DsM (Core TH.ExpQ) +repCon (MkC s) = rep2 conEName [s] + +repLit :: Core TH.Lit -> DsM (Core TH.ExpQ) +repLit (MkC c) = rep2 litEName [c] + +repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repApp (MkC x) (MkC y) = rep2 appEName [x,y] + +repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] + +repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) +repLamCase (MkC ms) = rep2 lamCaseEName [ms] + +repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repTup (MkC es) = rep2 tupEName [es] + +repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + +repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] + +repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) +repMultiIf (MkC alts) = rep2 multiIfEName [alts] + +repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] + +repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ) +repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] + +repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) +repDoE (MkC ss) = rep2 doEName [ss] + +repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) +repComp (MkC ss) = rep2 compEName [ss] + +repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repListExp (MkC es) = rep2 listEName [es] + +repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) +repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] + +repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ) +repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] + +repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] + +repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp)) +repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] + +repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] + +repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] + +repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] + +------------ Right hand sides (guarded expressions) ---- +repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) +repGuarded (MkC pairs) = rep2 guardedBName [pairs] + +repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) +repNormal (MkC e) = rep2 normalBName [e] + +------------ Guards ---- +repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repLNormalGE g e = do g' <- repLE g + e' <- repLE e + repNormalGE g' e' + +repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] + +repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] + +------------- Stmts ------------------- +repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) +repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] + +repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ) +repLetSt (MkC ds) = rep2 letSName [ds] + +repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ) +repNoBindSt (MkC e) = rep2 noBindSName [e] + +repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) +repParSt (MkC sss) = rep2 parSName [sss] + +-------------- Range (Arithmetic sequences) ----------- +repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) +repFrom (MkC x) = rep2 fromEName [x] + +repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] + +repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] + +repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] + +------------ Match and Clause Tuples ----------- +repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) +repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] + +repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) +repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] + +-------------- Dec ----------------------------- +repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] + +repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) +repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] + +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) +repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, cons, derivs] +repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) + = rep2 dataInstDName [cxt, nm, tys, cons, derivs] + +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) +repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, con, derivs] +repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) + = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] + +repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] + -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repTySyn (MkC nm) (MkC tvs) (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] + +repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) +repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] + +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Core [TH.FunDep] -> Core [TH.DecQ] + -> DsM (Core TH.DecQ) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) + = rep2 classDName [cxt, cls, tvs, fds, ds] + +repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty] + +repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch + -> Core TH.Phases -> DsM (Core TH.DecQ) +repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) + = rep2 pragInlDName [nm, inline, rm, phases] + +repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases + -> DsM (Core TH.DecQ) +repPragSpec (MkC nm) (MkC ty) (MkC phases) + = rep2 pragSpecDName [nm, ty, phases] + +repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline + -> Core TH.Phases -> DsM (Core TH.DecQ) +repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) + = rep2 pragSpecInlDName [nm, ty, inline, phases] + +repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ) +repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] + +repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ + -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ) +repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases) + = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases] + +repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) +repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] + +repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> DsM (Core TH.DecQ) +repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs) + = rep2 familyNoKindDName [flav, nm, tvs] + +repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> DsM (Core TH.DecQ) +repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) + = rep2 familyKindDName [flav, nm, tvs, ki] + +repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) +repTySynInst (MkC nm) (MkC eqn) + = rep2 tySynInstDName [nm, eqn] + +repClosedFamilyNoKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns) + = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns] + +repClosedFamilyKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns) + = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns] + +repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) +repTySynEqn (MkC lhs) (MkC rhs) + = rep2 tySynEqnName [lhs, rhs] + +repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ) +repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] + +repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) +repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] + +repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] + +repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) +repCtxt (MkC tys) = rep2 cxtName [tys] + +repConstr :: Core TH.Name -> HsConDeclDetails Name + -> DsM (Core TH.ConQ) +repConstr con (PrefixCon ps) + = do arg_tys <- repList strictTypeQTyConName repBangTy ps + rep2 normalCName [unC con, unC arg_tys] + +repConstr con (RecCon (L _ ips)) + = do { args <- concatMapM rep_ip ips + ; arg_vtys <- coreList varStrictTypeQTyConName args + ; rep2 recCName [unC con, unC arg_vtys] } + where + rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) + rep_one_ip t n = do { MkC v <- lookupLOcc n + ; MkC ty <- repBangTy t + ; rep2 varStrictTypeName [v,ty] } + +repConstr con (InfixCon st1 st2) + = do arg1 <- repBangTy st1 + arg2 <- repBangTy st2 + rep2 infixCName [unC arg1, unC con, unC arg2] + +------------ Types ------------------- + +repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ + -> DsM (Core TH.TypeQ) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) + = rep2 forallTName [tvars, ctxt, ty] + +repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) +repTvar (MkC s) = rep2 varTName [s] + +repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] + +repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) +repTapps f [] = return f +repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } + +repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + +repTequality :: DsM (Core TH.TypeQ) +repTequality = rep2 equalityTName [] + +repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ) +repTPromotedList [] = repPromotedNilTyCon +repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon + ; f <- repTapp tcon t + ; t' <- repTPromotedList ts + ; repTapp f t' + } + +repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) +repTLit (MkC lit) = rep2 litTName [lit] + +--------- Type constructors -------------- + +repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) +repNamedTyCon (MkC s) = rep2 conTName [s] + +repTupleTyCon :: Int -> DsM (Core TH.TypeQ) +-- Note: not Core Int; it's easier to be direct here +repTupleTyCon i = do dflags <- getDynFlags + rep2 tupleTName [mkIntExprInt dflags i] + +repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = do dflags <- getDynFlags + rep2 unboxedTupleTName [mkIntExprInt dflags i] + +repArrowTyCon :: DsM (Core TH.TypeQ) +repArrowTyCon = rep2 arrowTName [] + +repListTyCon :: DsM (Core TH.TypeQ) +repListTyCon = rep2 listTName [] + +repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) +repPromotedTyCon (MkC s) = rep2 promotedTName [s] + +repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) +repPromotedTupleTyCon i = do dflags <- getDynFlags + rep2 promotedTupleTName [mkIntExprInt dflags i] + +repPromotedNilTyCon :: DsM (Core TH.TypeQ) +repPromotedNilTyCon = rep2 promotedNilTName [] + +repPromotedConsTyCon :: DsM (Core TH.TypeQ) +repPromotedConsTyCon = rep2 promotedConsTName [] + +------------ Kinds ------------------- + +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV (MkC nm) = rep2 plainTVName [nm] + +repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] + +repKVar :: Core TH.Name -> DsM (Core TH.Kind) +repKVar (MkC s) = rep2 varKName [s] + +repKCon :: Core TH.Name -> DsM (Core TH.Kind) +repKCon (MkC s) = rep2 conKName [s] + +repKTuple :: Int -> DsM (Core TH.Kind) +repKTuple i = do dflags <- getDynFlags + rep2 tupleKName [mkIntExprInt dflags i] + +repKArrow :: DsM (Core TH.Kind) +repKArrow = rep2 arrowKName [] + +repKList :: DsM (Core TH.Kind) +repKList = rep2 listKName [] + +repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) +repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2] + +repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind) +repKApps f [] = return f +repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks } + +repKStar :: DsM (Core TH.Kind) +repKStar = rep2 starKName [] + +repKConstraint :: DsM (Core TH.Kind) +repKConstraint = rep2 constraintKName [] + +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit -> DsM (Core TH.Lit) +repLiteral lit + = do lit' <- case lit of + HsIntPrim _ i -> mk_integer i + HsWordPrim _ w -> mk_integer w + HsInt _ i -> mk_integer i + HsFloatPrim r -> mk_rational r + HsDoublePrim r -> mk_rational r + _ -> return lit + lit_expr <- dsLit lit' + case mb_lit_name of + Just lit_name -> rep2 lit_name [lit_expr] + Nothing -> notHandled "Exotic literal" (ppr lit) + where + mb_lit_name = case lit of + HsInteger _ _ _ -> Just integerLName + HsInt _ _ -> Just integerLName + HsIntPrim _ _ -> Just intPrimLName + HsWordPrim _ _ -> Just wordPrimLName + HsFloatPrim _ -> Just floatPrimLName + HsDoublePrim _ -> Just doublePrimLName + HsChar _ _ -> Just charLName + HsString _ _ -> Just stringLName + HsRat _ _ -> Just rationalLName + _ -> Nothing + +mk_integer :: Integer -> DsM HsLit +mk_integer i = do integer_ty <- lookupType integerTyConName + return $ HsInteger "" i integer_ty +mk_rational :: FractionalLit -> DsM HsLit +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty +mk_string :: FastString -> DsM HsLit +mk_string s = return $ HsString "" s + +repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) +repOverloadedLiteral (OverLit { ol_val = val}) + = do { lit <- mk_lit val; repLiteral lit } + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used + +mk_lit :: OverLitVal -> DsM HsLit +mk_lit (HsIntegral _ i) = mk_integer i +mk_lit (HsFractional f) = mk_rational f +mk_lit (HsIsString _ s) = mk_string s + +--------------- Miscellaneous ------------------- + +repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) +repGensym (MkC lit_str) = rep2 newNameName [lit_str] + +repBindQ :: Type -> Type -- a and b + -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) +repBindQ ty_a ty_b (MkC x) (MkC y) + = rep2 bindQName [Type ty_a, Type ty_b, x, y] + +repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) +repSequenceQ ty_a (MkC list) + = rep2 sequenceQName [Type ty_a, list] + +------------ Lists and Tuples ------------------- +-- turn a list of patterns into a single pattern matching a list + +repList :: Name -> (a -> DsM (Core b)) + -> [a] -> DsM (Core [b]) +repList tc_name f args + = do { args1 <- mapM f args + ; coreList tc_name args1 } + +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> DsM (Core [a]) +coreList tc_name es + = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } + +coreList' :: Type -- The element type + -> [Core a] -> Core [a] +coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) + +nonEmptyCoreList :: [Core a] -> Core [a] + -- The list must be non-empty so we can get the element type + -- Otherwise use coreList +nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) + +coreStringLit :: String -> DsM (Core String) +coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } + +------------ Literals & Variables ------------------- + +coreIntLit :: Int -> DsM (Core Int) +coreIntLit i = do dflags <- getDynFlags + return (MkC (mkIntExprInt dflags i)) + +coreVar :: Id -> Core TH.Name -- The Id has type Name +coreVar id = MkC (Var id) + +----------------- Failure ----------------------- +notHandledL :: SrcSpan -> String -> SDoc -> DsM a +notHandledL loc what doc + | isGoodSrcSpan loc + = putSrcSpanDs loc $ notHandled what doc + | otherwise + = notHandled what doc + +notHandled :: String -> SDoc -> DsM a +notHandled what doc = failWithDs msg + where + msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) + 2 doc + + +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to knownKeyNames + +templateHaskellNames :: [Name] +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of DsMeta + +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + liftStringName, + unTypeName, + unTypeQName, + unsafeTExpCoerceName, + + -- Lit + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, + -- Pat + litPName, varPName, tupPName, unboxedTupPName, + conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, + tupEName, unboxedTupEName, + condEName, multiIfEName, letEName, caseEName, doEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragRuleDName, pragAnnDName, defaultSigDName, + familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, + tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, + roleAnnotDName, + -- Cxt + cxtName, + -- Strict + isStrictName, notStrictName, unpackedName, + -- Con + normalCName, recCName, infixCName, forallCName, + -- StrictType + strictTypeName, + -- VarStrictType + varStrictTypeName, + -- Type + forallTName, varTName, conTName, appTName, equalityTName, + tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + -- TyLit + numTyLitName, strTyLitName, + -- TyVarBndr + plainTVName, kindedTVName, + -- Role + nominalRName, representationalRName, phantomRName, inferRName, + -- Kind + varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName, + -- Callconv + cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, + -- Safety + unsafeName, + safeName, + interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, + -- RuleMatch + conLikeDataConName, funLikeDataConName, + -- Phases + allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, + -- TExp + tExpDataConName, + -- RuleBndr + ruleVarName, typedRuleVarName, + -- FunDep + funDepName, + -- FamFlavour + typeFamName, dataFamName, + -- TySynEqn + tySynEqnName, + -- AnnTarget + valueAnnotationName, typeAnnotationName, moduleAnnotationName, + + -- And the tycons + qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, + clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, + stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, + patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, + roleTyConName, tExpTyConName, + + -- Quasiquoting + quoteDecName, quoteTypeName, quoteExpName, quotePatName] + +thSyn, thLib, qqLib :: Module +thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") +qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") + +mkTHModule :: FastString -> Module +mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) + +libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name +libFun = mk_known_key_name OccName.varName thLib +libTc = mk_known_key_name OccName.tcName thLib +thFun = mk_known_key_name OccName.varName thSyn +thTc = mk_known_key_name OccName.tcName thSyn +thCon = mk_known_key_name OccName.dataName thSyn +qqFun = mk_known_key_name OccName.varName qqLib + +-------------------- TH.Syntax ----------------------- +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, + predTyConName, tExpTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +tExpTyConName = thTc (fsLit "TExp") tExpTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameLName, liftStringName, unTypeName, unTypeQName, + unsafeTExpCoerceName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey +newNameName = thFun (fsLit "newName") newNameIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey +mkNameName = thFun (fsLit "mkName") mkNameIdKey +mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey +mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey +mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey +unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey +unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey + + +-------------------- TH.Lib ----------------------- +-- data Lit = ... +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey +doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey +rationalLName = libFun (fsLit "rationalL") rationalLIdKey + +-- data Pat = ... +litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name +litPName = libFun (fsLit "litP") litPIdKey +varPName = libFun (fsLit "varP") varPIdKey +tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey +conPName = libFun (fsLit "conP") conPIdKey +infixPName = libFun (fsLit "infixP") infixPIdKey +tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey +asPName = libFun (fsLit "asP") asPIdKey +wildPName = libFun (fsLit "wildP") wildPIdKey +recPName = libFun (fsLit "recP") recPIdKey +listPName = libFun (fsLit "listP") listPIdKey +sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey + +-- type FieldPat = ... +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey + +-- data Match = ... +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey + +-- data Clause = ... +clauseName :: Name +clauseName = libFun (fsLit "clause") clauseIdKey + +-- data Exp = ... +varEName, conEName, litEName, appEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, + unboxedTupEName, condEName, multiIfEName, letEName, caseEName, + doEName, compEName, staticEName :: Name +varEName = libFun (fsLit "varE") varEIdKey +conEName = libFun (fsLit "conE") conEIdKey +litEName = libFun (fsLit "litE") litEIdKey +appEName = libFun (fsLit "appE") appEIdKey +infixEName = libFun (fsLit "infixE") infixEIdKey +infixAppName = libFun (fsLit "infixApp") infixAppIdKey +sectionLName = libFun (fsLit "sectionL") sectionLIdKey +sectionRName = libFun (fsLit "sectionR") sectionRIdKey +lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey +tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey +condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey +letEName = libFun (fsLit "letE") letEIdKey +caseEName = libFun (fsLit "caseE") caseEIdKey +doEName = libFun (fsLit "doE") doEIdKey +compEName = libFun (fsLit "compE") compEIdKey +-- ArithSeq skips a level +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +fromEName = libFun (fsLit "fromE") fromEIdKey +fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey +fromToEName = libFun (fsLit "fromToE") fromToEIdKey +fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName, sigEName, recConEName, recUpdEName :: Name +listEName = libFun (fsLit "listE") listEIdKey +sigEName = libFun (fsLit "sigE") sigEIdKey +recConEName = libFun (fsLit "recConE") recConEIdKey +recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey + +-- type FieldExp = ... +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey + +-- data Guard = ... +normalGEName, patGEName :: Name +normalGEName = libFun (fsLit "normalGE") normalGEIdKey +patGEName = libFun (fsLit "patGE") patGEIdKey + +-- data Stmt = ... +bindSName, letSName, noBindSName, parSName :: Name +bindSName = libFun (fsLit "bindS") bindSIdKey +letSName = libFun (fsLit "letS") letSIdKey +noBindSName = libFun (fsLit "noBindS") noBindSIdKey +parSName = libFun (fsLit "parS") parSIdKey + +-- data Dec = ... +funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, + instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, + pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, + familyNoKindDName, standaloneDerivDName, defaultSigDName, + familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, + closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceDName = libFun (fsLit "instanceD") instanceDIdKey +standaloneDerivDName + = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey +familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +closedTypeFamilyKindDName + = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey +closedTypeFamilyNoKindDName + = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey + +-- type Ctxt = ... +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data Strict = ... +isStrictName, notStrictName, unpackedName :: Name +isStrictName = libFun (fsLit "isStrict") isStrictKey +notStrictName = libFun (fsLit "notStrict") notStrictKey +unpackedName = libFun (fsLit "unpacked") unpackedKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName :: Name +normalCName = libFun (fsLit "normalC") normalCIdKey +recCName = libFun (fsLit "recC") recCIdKey +infixCName = libFun (fsLit "infixC") infixCIdKey +forallCName = libFun (fsLit "forallC") forallCIdKey + +-- type StrictType = ... +strictTypeName :: Name +strictTypeName = libFun (fsLit "strictType") strictTKey + +-- type VarStrictType = ... +varStrictTypeName :: Name +varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey + +-- data Type = ... +forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, + listTName, appTName, sigTName, equalityTName, litTName, + promotedTName, promotedTupleTName, + promotedNilTName, promotedConsTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +equalityTName = libFun (fsLit "equalityT") equalityTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +-- data Role = ... +nominalRName, representationalRName, phantomRName, inferRName :: Name +nominalRName = libFun (fsLit "nominalR") nominalRIdKey +representationalRName = libFun (fsLit "representationalR") representationalRIdKey +phantomRName = libFun (fsLit "phantomR") phantomRIdKey +inferRName = libFun (fsLit "inferR") inferRIdKey + +-- data Kind = ... +varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName :: Name +varKName = libFun (fsLit "varK") varKIdKey +conKName = libFun (fsLit "conK") conKIdKey +tupleKName = libFun (fsLit "tupleK") tupleKIdKey +arrowKName = libFun (fsLit "arrowK") arrowKIdKey +listKName = libFun (fsLit "listK") listKIdKey +appKName = libFun (fsLit "appK") appKIdKey +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey + +-- data Callconv = ... +cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey +cApiCallName = libFun (fsLit "cApi") cApiCallIdKey +primCallName = libFun (fsLit "prim") primCallIdKey +javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey + +-- data Safety = ... +unsafeName, safeName, interruptibleName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey + +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + +-- newtype TExp a = ... +tExpDataConName :: Name +tExpDataConName = thCon (fsLit "TExp") tExpDataConKey + +-- data RuleBndr = ... +ruleVarName, typedRuleVarName :: Name +ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey +typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey + +-- data FunDep = ... +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data FamFlavour = ... +typeFamName, dataFamName :: Name +typeFamName = libFun (fsLit "typeFam") typeFamIdKey +dataFamName = libFun (fsLit "dataFam") dataFamIdKey + +-- data TySynEqn = ... +tySynEqnName :: Name +tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey + +-- data AnnTarget = ... +valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name +valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey +typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey +moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey + +matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, + decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, + patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, + ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name +matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey +clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey +expQTyConName = libTc (fsLit "ExpQ") expQTyConKey +stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey +decQTyConName = libTc (fsLit "DecQ") decQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +conQTyConName = libTc (fsLit "ConQ") conQTyConKey +strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey +varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey +typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey +fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey +patQTyConName = libTc (fsLit "PatQ") patQTyConKey +fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey +predQTyConName = libTc (fsLit "PredQ") predQTyConKey +ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey +tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey +roleTyConName = libTc (fsLit "Role") roleTyConKey + +-- quasiquoting +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey + +-- TyConUniques available: 200-299 +-- Check in PrelNames if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, + stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, + decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, + predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, + roleTyConKey, tExpTyConKey :: Unique +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +decQTyConKey = mkPreludeTyConUnique 205 +patTyConKey = mkPreludeTyConUnique 206 +matchQTyConKey = mkPreludeTyConUnique 207 +clauseQTyConKey = mkPreludeTyConUnique 208 +stmtQTyConKey = mkPreludeTyConUnique 209 +conQTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +varStrictTypeQTyConKey = mkPreludeTyConUnique 214 +strictTypeQTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +fieldPatQTyConKey = mkPreludeTyConUnique 220 +fieldExpQTyConKey = mkPreludeTyConUnique 221 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 +ruleBndrQTyConKey = mkPreludeTyConUnique 227 +tySynEqnQTyConKey = mkPreludeTyConUnique 228 +roleTyConKey = mkPreludeTyConUnique 229 +tExpTyConKey = mkPreludeTyConUnique 230 + +-- IdUniques available: 200-499 +-- If you want to change this, make sure you check in PrelNames + +returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +liftIdKey = mkPreludeMiscIdUnique 203 +newNameIdKey = mkPreludeMiscIdUnique 204 +mkNameIdKey = mkPreludeMiscIdUnique 205 +mkNameG_vIdKey = mkPreludeMiscIdUnique 206 +mkNameG_dIdKey = mkPreludeMiscIdUnique 207 +mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 +mkNameLIdKey = mkPreludeMiscIdUnique 209 +unTypeIdKey = mkPreludeMiscIdUnique 210 +unTypeQIdKey = mkPreludeMiscIdUnique 211 +unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212 + + +-- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 228 + +-- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +conPIdKey = mkPreludeMiscIdUnique 244 +infixPIdKey = mkPreludeMiscIdUnique 245 +tildePIdKey = mkPreludeMiscIdUnique 246 +bangPIdKey = mkPreludeMiscIdUnique 247 +asPIdKey = mkPreludeMiscIdUnique 248 +wildPIdKey = mkPreludeMiscIdUnique 249 +recPIdKey = mkPreludeMiscIdUnique 250 +listPIdKey = mkPreludeMiscIdUnique 251 +sigPIdKey = mkPreludeMiscIdUnique 252 +viewPIdKey = mkPreludeMiscIdUnique 253 + +-- type FieldPat = ... +fieldPatIdKey :: Unique +fieldPatIdKey = mkPreludeMiscIdUnique 260 + +-- data Match = ... +matchIdKey :: Unique +matchIdKey = mkPreludeMiscIdUnique 261 + +-- data Clause = ... +clauseIdKey :: Unique +clauseIdKey = mkPreludeMiscIdUnique 262 + + +-- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, + unboxedTupEIdKey, condEIdKey, multiIfEIdKey, + letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +infixEIdKey = mkPreludeMiscIdUnique 274 +infixAppIdKey = mkPreludeMiscIdUnique 275 +sectionLIdKey = mkPreludeMiscIdUnique 276 +sectionRIdKey = mkPreludeMiscIdUnique 277 +lamEIdKey = mkPreludeMiscIdUnique 278 +lamCaseEIdKey = mkPreludeMiscIdUnique 279 +tupEIdKey = mkPreludeMiscIdUnique 280 +unboxedTupEIdKey = mkPreludeMiscIdUnique 281 +condEIdKey = mkPreludeMiscIdUnique 282 +multiIfEIdKey = mkPreludeMiscIdUnique 283 +letEIdKey = mkPreludeMiscIdUnique 284 +caseEIdKey = mkPreludeMiscIdUnique 285 +doEIdKey = mkPreludeMiscIdUnique 286 +compEIdKey = mkPreludeMiscIdUnique 287 +fromEIdKey = mkPreludeMiscIdUnique 288 +fromThenEIdKey = mkPreludeMiscIdUnique 289 +fromToEIdKey = mkPreludeMiscIdUnique 290 +fromThenToEIdKey = mkPreludeMiscIdUnique 291 +listEIdKey = mkPreludeMiscIdUnique 292 +sigEIdKey = mkPreludeMiscIdUnique 293 +recConEIdKey = mkPreludeMiscIdUnique 294 +recUpdEIdKey = mkPreludeMiscIdUnique 295 +staticEIdKey = mkPreludeMiscIdUnique 296 + +-- type FieldExp = ... +fieldExpIdKey :: Unique +fieldExpIdKey = mkPreludeMiscIdUnique 310 + +-- data Body = ... +guardedBIdKey, normalBIdKey :: Unique +guardedBIdKey = mkPreludeMiscIdUnique 311 +normalBIdKey = mkPreludeMiscIdUnique 312 + +-- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique +normalGEIdKey = mkPreludeMiscIdUnique 313 +patGEIdKey = mkPreludeMiscIdUnique 314 + +-- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique +bindSIdKey = mkPreludeMiscIdUnique 320 +letSIdKey = mkPreludeMiscIdUnique 321 +noBindSIdKey = mkPreludeMiscIdUnique 322 +parSIdKey = mkPreludeMiscIdUnique 323 + +-- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, + classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, + pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, + pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, + closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 342 +pragRuleDIdKey = mkPreludeMiscIdUnique 343 +pragAnnDIdKey = mkPreludeMiscIdUnique 344 +familyNoKindDIdKey = mkPreludeMiscIdUnique 345 +familyKindDIdKey = mkPreludeMiscIdUnique 346 +dataInstDIdKey = mkPreludeMiscIdUnique 347 +newtypeInstDIdKey = mkPreludeMiscIdUnique 348 +tySynInstDIdKey = mkPreludeMiscIdUnique 349 +closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 350 +closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 351 +infixLDIdKey = mkPreludeMiscIdUnique 352 +infixRDIdKey = mkPreludeMiscIdUnique 353 +infixNDIdKey = mkPreludeMiscIdUnique 354 +roleAnnotDIdKey = mkPreludeMiscIdUnique 355 +standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 +defaultSigDIdKey = mkPreludeMiscIdUnique 357 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 360 + +-- data Strict = ... +isStrictKey, notStrictKey, unpackedKey :: Unique +isStrictKey = mkPreludeMiscIdUnique 363 +notStrictKey = mkPreludeMiscIdUnique 364 +unpackedKey = mkPreludeMiscIdUnique 365 + +-- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique +normalCIdKey = mkPreludeMiscIdUnique 370 +recCIdKey = mkPreludeMiscIdUnique 371 +infixCIdKey = mkPreludeMiscIdUnique 372 +forallCIdKey = mkPreludeMiscIdUnique 373 + +-- type StrictType = ... +strictTKey :: Unique +strictTKey = mkPreludeMiscIdUnique 374 + +-- type VarStrictType = ... +varStrictTKey :: Unique +varStrictTKey = mkPreludeMiscIdUnique 375 + +-- data Type = ... +forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, + listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, + promotedTIdKey, promotedTupleTIdKey, + promotedNilTIdKey, promotedConsTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 380 +varTIdKey = mkPreludeMiscIdUnique 381 +conTIdKey = mkPreludeMiscIdUnique 382 +tupleTIdKey = mkPreludeMiscIdUnique 383 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 +arrowTIdKey = mkPreludeMiscIdUnique 385 +listTIdKey = mkPreludeMiscIdUnique 386 +appTIdKey = mkPreludeMiscIdUnique 387 +sigTIdKey = mkPreludeMiscIdUnique 388 +equalityTIdKey = mkPreludeMiscIdUnique 389 +litTIdKey = mkPreludeMiscIdUnique 390 +promotedTIdKey = mkPreludeMiscIdUnique 391 +promotedTupleTIdKey = mkPreludeMiscIdUnique 392 +promotedNilTIdKey = mkPreludeMiscIdUnique 393 +promotedConsTIdKey = mkPreludeMiscIdUnique 394 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 395 +strTyLitIdKey = mkPreludeMiscIdUnique 396 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 397 +kindedTVIdKey = mkPreludeMiscIdUnique 398 + +-- data Role = ... +nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique +nominalRIdKey = mkPreludeMiscIdUnique 400 +representationalRIdKey = mkPreludeMiscIdUnique 401 +phantomRIdKey = mkPreludeMiscIdUnique 402 +inferRIdKey = mkPreludeMiscIdUnique 403 + +-- data Kind = ... +varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, + starKIdKey, constraintKIdKey :: Unique +varKIdKey = mkPreludeMiscIdUnique 404 +conKIdKey = mkPreludeMiscIdUnique 405 +tupleKIdKey = mkPreludeMiscIdUnique 406 +arrowKIdKey = mkPreludeMiscIdUnique 407 +listKIdKey = mkPreludeMiscIdUnique 408 +appKIdKey = mkPreludeMiscIdUnique 409 +starKIdKey = mkPreludeMiscIdUnique 410 +constraintKIdKey = mkPreludeMiscIdUnique 411 + +-- data Callconv = ... +cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, + javaScriptCallIdKey :: Unique +cCallIdKey = mkPreludeMiscIdUnique 420 +stdCallIdKey = mkPreludeMiscIdUnique 421 +cApiCallIdKey = mkPreludeMiscIdUnique 422 +primCallIdKey = mkPreludeMiscIdUnique 423 +javaScriptCallIdKey = mkPreludeMiscIdUnique 424 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 430 +safeIdKey = mkPreludeMiscIdUnique 431 +interruptibleIdKey = mkPreludeMiscIdUnique 432 + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 40 +inlineDataConKey = mkPreludeDataConUnique 41 +inlinableDataConKey = mkPreludeDataConUnique 42 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 43 +funLikeDataConKey = mkPreludeDataConUnique 44 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 45 +fromPhaseDataConKey = mkPreludeDataConUnique 46 +beforePhaseDataConKey = mkPreludeDataConUnique 47 + +-- newtype TExp a = ... +tExpDataConKey :: Unique +tExpDataConKey = mkPreludeDataConUnique 48 + +-- data FunDep = ... +funDepIdKey :: Unique +funDepIdKey = mkPreludeMiscIdUnique 440 + +-- data FamFlavour = ... +typeFamIdKey, dataFamIdKey :: Unique +typeFamIdKey = mkPreludeMiscIdUnique 450 +dataFamIdKey = mkPreludeMiscIdUnique 451 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 460 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 470 +quotePatKey = mkPreludeMiscIdUnique 471 +quoteDecKey = mkPreludeMiscIdUnique 472 +quoteTypeKey = mkPreludeMiscIdUnique 473 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 480 +typedRuleVarIdKey = mkPreludeMiscIdUnique 481 + +-- data AnnTarget = ... +valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique +valueAnnotationIdKey = mkPreludeMiscIdUnique 490 +typeAnnotationIdKey = mkPreludeMiscIdUnique 491 +moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs new file mode 100644 index 00000000..f01a9d81 --- /dev/null +++ b/compiler/deSugar/DsMonad.hs @@ -0,0 +1,455 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@DsMonad@: monadery used in desugaring +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan + +module DsMonad ( + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, fixDs, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, + Applicative(..),(<$>), + + newLocalName, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + newFailLocalDs, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, + mkPrintUnqualifiedDs, + newUnique, + UniqSupply, newUniqueSupply, + getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar, + dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, + + PArrBuiltin(..), + dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, + dsInitPArrBuiltin, + + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, + + -- Warnings + DsWarning, warnDs, failWithDs, discardWarningsDs, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, + CanItFail(..), orFail + ) where + +import TcRnMonad +import FamInstEnv +import CoreSyn +import HsSyn +import TcIface +import LoadIface +import Finder +import PrelNames +import RdrName +import HscTypes +import Bag +import DataCon +import TyCon +import Id +import Module +import Outputable +import SrcLoc +import Type +import UniqSupply +import Name +import NameEnv +import DynFlags +import ErrUtils +import FastString +import Maybes +import GHC.Fingerprint + +import Data.IORef +import Control.Monad + +{- +************************************************************************ +* * + Data types for the desugarer +* * +************************************************************************ +-} + +data DsMatchContext + = DsMatchContext (HsMatchContext Name) SrcSpan + deriving () + +data EquationInfo + = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn + eqn_rhs :: MatchResult } -- What to do after match + +instance Outputable EquationInfo where + ppr (EqnInfo pats _) = ppr pats + +type DsWrapper = CoreExpr -> CoreExpr +idDsWrapper :: DsWrapper +idDsWrapper e = e + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not bound by wrap + + +-- A MatchResult is an expression with a hole in it +data MatchResult + = MatchResult + CanItFail -- Tells whether the failure expression is used + (CoreExpr -> DsM CoreExpr) + -- Takes a expression to plug in at the + -- failure point(s). The expression should + -- be duplicatable! + +data CanItFail = CanFail | CantFail + +orFail :: CanItFail -> CanItFail -> CanItFail +orFail CantFail CantFail = CantFail +orFail _ _ = CanFail + +{- +************************************************************************ +* * + Monad functions +* * +************************************************************************ +-} + +-- Compatibility functions +fixDs :: (a -> DsM a) -> DsM a +fixDs = fixM + +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the print_unqual stuff later on to turn it + -- into a Doc. + +initDs :: HscEnv + -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> DsM a + -> IO (Messages, Maybe a) +-- Print errors and warnings, if any arise + +initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside + = do { msg_var <- newIORef (emptyBag, emptyBag) + ; static_binds_var <- newIORef [] + ; let dflags = hsc_dflags hsc_env + (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env + fam_inst_env msg_var + static_binds_var + + ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ + loadDAP $ + initDPHBuiltins $ + tryM thing_inside -- Catch exceptions (= errors during desugaring) + + -- Display any errors and warnings + -- Note: if -Werror is used, we don't signal an error here. + ; msgs <- readIORef msg_var + + ; let final_res | errorsFound dflags msgs = Nothing + | otherwise = case either_res of + Right res -> Just res + Left exn -> pprPanic "initDs" (text (show exn)) + -- The (Left exn) case happens when the thing_inside throws + -- a UserError exception. Then it should have put an error + -- message in msg_var, so we just discard the exception + + ; return (msgs, final_res) + } + where + -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of + -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). + -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. + loadDAP thing_inside + = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr + ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr + ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside + } + where + loadOneModule :: ModuleName -- the module to load + -> DsM Bool -- under which condition + -> MsgDoc -- error message if module not found + -> DsM GlobalRdrEnv -- empty if condition 'False' + loadOneModule modname check err + = do { doLoad <- check + ; if not doLoad + then return emptyGlobalRdrEnv + else do { + ; result <- liftIO $ findImportedModule hsc_env modname Nothing + ; case result of + Found _ mod -> loadModule err mod + _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err + } } + + paErr = ptext (sLit "To use ParallelArrays,") <+> specBackend $$ hint1 $$ hint2 + veErr = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2 + specBackend = ptext (sLit "you must specify a DPH backend package") + hint1 = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'") + hint2 = ptext (sLit "You may need to install them with 'cabal install dph-examples'") + + initDPHBuiltins thing_inside + = do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those + ; doInitBuiltins <- checkLoadDAP + ; if doInitBuiltins + then dsInitPArrBuiltin thing_inside + else thing_inside + } + + checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays + ; return $ paEnabled && + mod /= gHC_PARR' && + moduleName mod /= dATA_ARRAY_PARALLEL_NAME + } + -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a + -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top + -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries + +initDsTc :: DsM a -> TcM a +initDsTc thing_inside + = do { this_mod <- getModule + ; tcg_env <- getGblEnv + ; msg_var <- getErrsVar + ; dflags <- getDynFlags + ; static_binds_var <- liftIO $ newIORef [] + ; let type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env + fam_inst_env = tcg_fam_inst_env tcg_env + ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env + msg_var static_binds_var + ; setEnvs ds_envs thing_inside + } + +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var + = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } + if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod) + gbl_env = DsGblEnv { ds_mod = mod + , ds_fam_inst_env = fam_inst_env + , ds_if_env = (if_genv, if_lenv) + , ds_unqual = mkPrintUnqualified dflags rdr_env + , ds_msgs = msg_var + , ds_dph_env = emptyGlobalRdrEnv + , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" + , ds_static_binds = static_binds_var + } + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = noSrcSpan + } + in (gbl_env, lcl_env) + +-- Attempt to load the given module and return its exported entities if successful. +-- +loadModule :: SDoc -> Module -> DsM GlobalRdrEnv +loadModule doc mod + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) $ do + { iface <- loadInterface doc mod ImportBySystem + ; case iface of + Failed err -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc) + Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface + } } + where + prov = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }] + imp_spec = ImpDeclSpec { is_mod = name, is_qual = True, + is_dloc = wiredInSrcSpan, is_as = name } + name = moduleName mod + +{- +************************************************************************ +* * + Operations in the monad +* * +************************************************************************ + +And all this mysterious stuff is so we can occasionally reach out and +grab one or more names. @newLocalDs@ isn't exported---exported +functions are defined with it. The difference in name-strings makes +it easier to read debugging output. +-} + +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Id -> Type -> DsM Id +newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local + = do { uniq <- newUnique + ; return (setIdUnique old_local uniq) } + +newPredVarDs :: PredType -> DsM Var +newPredVarDs pred + = newSysLocalDs pred + +newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDs = mkSysLocalM (fsLit "ds") +newFailLocalDs = mkSysLocalM (fsLit "fail") + +newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDs tys = mapM newSysLocalDs tys + +{- +We can also reach out and either set/grab location information from +the @SrcSpan@ being carried around. +-} + +getGhcModeDs :: DsM GhcMode +getGhcModeDs = getDynFlags >>= return . ghcMode + +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv; return (dsl_loc env) } + +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {dsl_loc = new_loc}) thing_inside +warnDs :: SDoc -> DsM () +warnDs warn = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; dflags <- getDynFlags + ; let msg = mkErrMsg dflags loc (ds_unqual env) err + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) + ; failM } + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv + +instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where + lookupThing = dsLookupGlobal + +dsLookupGlobal :: Name -> DsM TyThing +-- Very like TcEnv.tcLookupGlobal +dsLookupGlobal name + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } + +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name + = tyThingId <$> dsLookupGlobal name + +-- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the +-- global desugerar environment. +-- +dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a +dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name + = tyThingTyCon <$> dsLookupGlobal name + +dsLookupDataCon :: Name -> DsM DataCon +dsLookupDataCon name + = tyThingDataCon <$> dsLookupGlobal name + +-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'. +-- Panic if there isn't one, or if it is defined multiple times. +dsLookupDPHRdrEnv :: OccName -> DsM Name +dsLookupDPHRdrEnv occ + = liftM (fromMaybe (pprPanic nameNotFound (ppr occ))) + $ dsLookupDPHRdrEnv_maybe occ + where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':" + +-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim', +-- returning `Nothing` if it's not defined. Panic if it's defined multiple times. +dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name) +dsLookupDPHRdrEnv_maybe occ + = do { env <- ds_dph_env <$> getGblEnv + ; let gres = lookupGlobalRdrEnv env occ + ; case gres of + [] -> return $ Nothing + [gre] -> return $ Just $ gre_name gre + _ -> pprPanic multipleNames (ppr occ) + } + where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':" + + +-- Populate 'ds_parr_bi' from 'ds_dph_env'. +-- +dsInitPArrBuiltin :: DsM a -> DsM a +dsInitPArrBuiltin thing_inside + = do { lengthPVar <- externalVar (fsLit "lengthP") + ; replicatePVar <- externalVar (fsLit "replicateP") + ; singletonPVar <- externalVar (fsLit "singletonP") + ; mapPVar <- externalVar (fsLit "mapP") + ; filterPVar <- externalVar (fsLit "filterP") + ; zipPVar <- externalVar (fsLit "zipP") + ; crossMapPVar <- externalVar (fsLit "crossMapP") + ; indexPVar <- externalVar (fsLit "!:") + ; emptyPVar <- externalVar (fsLit "emptyP") + ; appPVar <- externalVar (fsLit "+:+") + -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP") + -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP") + ; enumFromToPVar <- return arithErr + ; enumFromThenToPVar <- return arithErr + + ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin + { lengthPVar = lengthPVar + , replicatePVar = replicatePVar + , singletonPVar = singletonPVar + , mapPVar = mapPVar + , filterPVar = filterPVar + , zipPVar = zipPVar + , crossMapPVar = crossMapPVar + , indexPVar = indexPVar + , emptyPVar = emptyPVar + , appPVar = appPVar + , enumFromToPVar = enumFromToPVar + , enumFromThenToPVar = enumFromThenToPVar + } }) + thing_inside + } + where + externalVar :: FastString -> DsM Var + externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId + + arithErr = panic "Arithmetic sequences have to wait until we support type classes" + +dsGetFamInstEnvs :: DsM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +dsGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, ds_fam_inst_env env) } + +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } + +dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) } + +dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside + +-- | Gets a reference to the SPT entries created so far. +dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))]) +dsGetStaticBindsVar = fmap ds_static_binds getGblEnv + +discardWarningsDs :: DsM a -> DsM a +-- Ignore warnings inside the thing inside; +-- used to ignore inaccessable cases etc. inside generated code +discardWarningsDs thing_inside + = do { env <- getGblEnv + ; old_msgs <- readTcRef (ds_msgs env) + + ; result <- thing_inside + + -- Revert messages to old_msgs + ; writeTcRef (ds_msgs env) old_msgs + + ; return result } diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs new file mode 100644 index 00000000..f94b831a --- /dev/null +++ b/compiler/deSugar/DsUtils.hs @@ -0,0 +1,825 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utilities for desugaring + +This module exports some utility functions of no great interest. +-} + +{-# LANGUAGE CPP #-} + +-- | Utility functions for constructing Core syntax, principally for desugaring +module DsUtils ( + EquationInfo(..), + firstPat, shiftEqns, + + MatchResult(..), CanItFail(..), CaseAlt(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResult, adjustMatchResultDs, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, + matchCanFail, mkEvalMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, + wrapBind, wrapBinds, + + mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, + + seqVar, + + -- LHs tuples + mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, + mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, + + mkSelectorBinds, + + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkOptTickBox, mkBinaryTickBox + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( matchSimply ) + +import HsSyn +import TcHsSyn +import TcType( tcSplitTyConApp ) +import CoreSyn +import DsMonad +import {-# SOURCE #-} DsExpr ( dsLExpr ) + +import CoreUtils +import MkCore +import MkId +import Id +import Literal +import TyCon +import ConLike +import DataCon +import PatSyn +import Type +import TysPrim +import TysWiredIn +import BasicTypes +import UniqSet +import UniqSupply +import Module +import PrelNames +import Outputable +import SrcLoc +import Util +import DynFlags +import FastString + +import TcEvidence + +import Control.Monad ( zipWithM ) + +{- +************************************************************************ +* * +\subsection{ Selecting match variables} +* * +************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. +-} + +selectSimpleMatchVarL :: LPat Id -> DsM Id +selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- +-- OLD, but interesting note: +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! +-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat + +selectMatchVars :: [Pat Id] -> DsM [Id] +selectMatchVars ps = mapM selectMatchVar ps + +selectMatchVar :: Pat Id -> DsM Id +selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders] +selectMatchVar (AsPat var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) + -- OK, better make up one... + +{- +Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + + +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. +-} + +firstPat :: EquationInfo -> Pat Id +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) + +shiftEqns :: [EquationInfo] -> [EquationInfo] +-- Drop the first pattern in each equation +shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] + +-- Functions on MatchResults + +matchCanFail :: MatchResult -> Bool +matchCanFail (MatchResult CanFail _) = True +matchCanFail (MatchResult CantFail _) = False + +alwaysFailMatchResult :: MatchResult +alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail) + +cantFailMatchResult :: CoreExpr -> MatchResult +cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr) + +extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr +extractMatchResult (MatchResult CantFail match_fn) _ + = match_fn (error "It can't fail!") + +extractMatchResult (MatchResult CanFail match_fn) fail_expr = do + (fail_bind, if_it_fails) <- mkFailurePair fail_expr + body <- match_fn if_it_fails + return (mkCoreLet fail_bind body) + + +combineMatchResults :: MatchResult -> MatchResult -> MatchResult +combineMatchResults (MatchResult CanFail body_fn1) + (MatchResult can_it_fail2 body_fn2) + = MatchResult can_it_fail2 body_fn + where + body_fn fail = do body2 <- body_fn2 fail + (fail_bind, duplicatable_expr) <- mkFailurePair body2 + body1 <- body_fn1 duplicatable_expr + return (Let fail_bind body1) + +combineMatchResults match_result1@(MatchResult CantFail _) _ + = match_result1 + +adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult +adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail) + +adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult +adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) + = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail) + +wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr +wrapBinds [] e = e +wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) + +wrapBind :: Var -> Var -> CoreExpr -> CoreExpr +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body + +seqVar :: Var -> CoreExpr -> CoreExpr +seqVar var body = Case (Var var) var (exprType body) + [(DEFAULT, [], body)] + +mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult +mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) + +-- (mkViewMatchResult var' viewExpr var mr) makes the expression +-- let var' = viewExpr var in mr +mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr var = + adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var)))) + +mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult +mkEvalMatchResult var ty + = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) + +mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult +mkGuardedMatchResult pred_expr (MatchResult _ body_fn) + = MatchResult CanFail (\fail -> do body <- body_fn fail + return (mkIfThenElse pred_expr body fail)) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult)] -- Alternatives + -> MatchResult -- Literals are all unlifted +mkCoPrimCaseMatchResult var ty match_alts + = MatchResult CanFail mk_case + where + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) + + sorted_alts = sortWith fst match_alts -- Right order for a Case + mk_alt fail (lit, MatchResult _ body_fn) + = ASSERT( not (litIsLifted lit) ) + do body <- body_fn fail + return (LitAlt lit, [], body) + +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [CoreBndr], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult } + +mkCoAlgCaseMatchResult + :: DynFlags + -> Id -- Scrutinee + -> Type -- Type of exp + -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult +mkCoAlgCaseMatchResult dflags var ty match_alts + | isNewtype -- Newtype case; use a let + = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) + mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 + + | isPArrFakeAlts match_alts + = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) + | otherwise + = mkDataConCase var ty match_alts + where + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + + -- [Interesting: because of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] + + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } + = ASSERT( notNull match_alts ) head match_alts + -- Stuff for newtype + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 + var_ty = idType var + (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) + + --- Stuff for parallel arrays + -- + -- Concerning `isPArrFakeAlts': + -- + -- * it is *not* sufficient to just check the type of the type + -- constructor, as we have to be careful not to confuse the real + -- representation of parallel arrays with the fake constructors; + -- moreover, a list of alternatives must not mix fake and real + -- constructors (this is checked earlier on) + -- + -- FIXME: We actually go through the whole list and make sure that + -- either all or none of the constructors are fake parallel + -- array constructors. This is to spot equations that mix fake + -- constructors with the real representation defined in + -- `PrelPArr'. It would be nicer to spot this situation + -- earlier and raise a proper error message, but it can really + -- only happen in `PrelPArr' anyway. + -- + + isPArrFakeAlts :: [CaseAlt DataCon] -> Bool + isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) + isPArrFakeAlts (alt:alts) = + case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of + (True , True ) -> True + (False, False) -> False + _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" + isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult +mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt + +sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] +sort_alts = sortWith (dataConTag . alt_pat) + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty] + let MatchResult _ mkCont = match_result + cont <- mkCoreLams bndrs <$> mkCont fail + return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + (matcher, needs_void_lam) = patSynMatcher psyn + + -- See Note [Matchers and builders for pattern synonyms] in PatSyns + -- on these extra Void# arguments + ensure_unstrict cont | needs_void_lam = Lam voidArgId cont + | otherwise = cont + +mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult +mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" +mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + match_results = map alt_result alts + + sorted_alts :: [CaseAlt DataCon] + sorted_alts = sort_alts alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: CoreExpr -> DsM CoreExpr + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) + + mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt + mk_alt fail MkCaseAlt{ alt_pat = con, + alt_bndrs = args, + alt_result = MatchResult _ body_fn } + = do { body <- body_fn fail + ; case dataConBoxer con of { + Nothing -> return (DataAlt con, args, body) ; + Just (DCB boxer) -> + do { us <- newUniqueSupply + ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) + ; return (DataAlt con, rep_ids, mkLets binds body) } } } + + mk_default :: CoreExpr -> [CoreAlt] + mk_default fail | exhaustive_case = [] + | otherwise = [(DEFAULT, [], fail)] + + fail_flag :: CanItFail + fail_flag | exhaustive_case + = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] + | otherwise + = CanFail + + mentioned_constructors = mkUniqSet $ map alt_pat alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +--- Stuff for parallel arrays +-- +-- * the following is to desugar cases over fake constructors for +-- parallel arrays, which are introduced by `tidy1' in the `PArrPat' +-- case +-- +mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr +mkPArrCase dflags var ty sorted_alts fail = do + lengthP <- dsDPHBuiltin lengthPVar + alt <- unboxAlt + return (mkWildCase (len lengthP) intTy ty [alt]) + where + elemTy = case splitTyConApp (idType var) of + (_, [elemTy]) -> elemTy + _ -> panic panicMsg + panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" + len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] + -- + unboxAlt = do + l <- newSysLocalDs intPrimTy + indexP <- dsDPHBuiltin indexPVar + alts <- mapM (mkAlt indexP) sorted_alts + return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) + where + dft = (DEFAULT, [], fail) + + -- + -- each alternative matches one array length (corresponding to one + -- fake array constructor), so the match is on a literal; each + -- alternative's body is extended by a local binding for each + -- constructor argument, which are bound to array elements starting + -- with the first + -- + mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do + body <- bodyFun fail + return (LitAlt lit, [], mkCoreLets binds body) + where + lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) + binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] + -- + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] + +{- +************************************************************************ +* * +\subsection{Desugarer's versions of some Core functions} +* * +************************************************************************ +-} + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> SDoc -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg = do + src_loc <- getSrcSpanDs + dflags <- getDynFlags + let + full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg]) + core_msg = Lit (mkMachString full_msg) + -- mkMachString returns a result of type String# + return (mkApps (Var err_id) [Type ty, core_msg]) + +{- +'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. + +Note [Desugaring seq (1)] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~~~~~ + f x y = x `seq` (y `seq` (# x,y #)) + +The [CoreSyn let/app invariant] means that, other things being equal, because +the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + +But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + +Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + +Note [Desugaring seq (2)] cf Trac #2273 +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... +Here the seq is designed to plug the space leak of retaining (snd x) +for too long. + +If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + +But since chp is cheap, and the case is an alluring contet, we'll +inline chp into the case scrutinee. Now there is only one use of chp, +so we'll inline a second copy. Alas, we've now ruined the purpose of +the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + +We can try to avoid doing this by ensuring that the binder-swap in the +case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } +But this is fragile. The real culprit is the source program. Perhaps we +should have said explicitly + let !chp2 = chp in ...chp2... + +But that's painful. So the code here does a little hack to make seq +more robust: a saturated application of 'seq' is turned *directly* into +the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + +So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } +And now all is well. + +The reason it's a hack is because if you define mySeq=seq, the hack +won't work on mySeq. + +Note [Desugaring seq (3)] cf Trac #2409 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The isLocalId ensures that we don't turn + True `seq` e +into + case True of True { ... } +which stupidly tries to bind the datacon 'True'. +-} + +mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 + | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] + = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] + _ -> mkWildValBinder ty1 + +mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore + +mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs fun args = foldl mkCoreAppDs fun args + +{- +************************************************************************ +* * +\subsection[mkSelectorBind]{Make a selector bind} +* * +************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: +\begin{verbatim} + b = case v of pat' -> b' +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +Note [mkSelectorBinds] +~~~~~~~~~~~~~~~~~~~~~~ +Given p = e, where p binds x,y +we are going to make EITHER + +EITHER (A) v = e (where v is fresh) + x = case v of p -> x + y = case v of p -> y + +OR (B) t = case e of p -> (x,y) + x = case t of (x,_) -> x + y = case t of (_,y) -> y + +We do (A) when + * Matching the pattern is cheap so we don't mind + doing it twice. + * Or if the pattern binds only one variable (so we'll only + match once) + * AND the pattern can't fail (else we tiresomely get two inexhaustive + pattern warning messages) + +Otherwise we do (B). Really (A) is just an optimisation for very common +cases like + Just x = e + (p,q) = e +-} + +mkSelectorBinds :: [[Tickish Id]] -- ticks to add, possibly + -> LPat Id -- The pattern + -> CoreExpr -- Expression to which the pattern is bound + -> DsM [(Id,CoreExpr)] + +mkSelectorBinds ticks (L _ (VarPat v)) val_expr + = return [(v, case ticks of + [t] -> mkOptTickBox t val_expr + _ -> val_expr)] + +mkSelectorBinds ticks pat val_expr + | null binders + = return [] + + | isSingleton binders || is_simple_lpat pat + -- See Note [mkSelectorBinds] + = do { val_var <- newSysLocalDs (hsLPatType pat) + -- Make up 'v' in Note [mkSelectorBinds] + -- NB: give it the type of *pattern* p, not the type of the *rhs* e. + -- This does not matter after desugaring, but there's a subtle + -- issue with implicit parameters. Consider + -- (x,y) = ?i + -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque + -- to the desugarer. (Why opaque? Because newtypes have to be. Why + -- does it get that type? So that when we abstract over it we get the + -- right top-level type (?i::Int) => ...) + -- + -- So to get the type of 'v', use the pattern not the rhs. Often more + -- efficient too. + + -- For the error message we make one error-app, to avoid duplication. + -- But we need it at different types, so we make it polymorphic: + -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah" + ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat) + ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy) + ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders + ; return ( (val_var, val_expr) : + (err_var, Lam alphaTyVar err_app) : + binds ) } + + | otherwise + = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat) + ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr + ; tuple_var <- newSysLocalDs tuple_ty + ; let mk_tup_bind tick binder + = (binder, mkOptTickBox tick $ + mkTupleSelector local_binders binder + tuple_var (Var tuple_var)) + ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) } + where + binders = collectPatBinders pat + ticks' = ticks ++ repeat [] + + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTup binders + tuple_ty = exprType local_tuple + + mk_bind scrut_var err_var tick bndr_var = do + -- (mk_bind sv err_var) generates + -- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv } + -- Remember, pat binds bv + rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat + (Var bndr_var) error_expr + return (bndr_var, mkOptTickBox tick rhs_expr) + where + error_expr = Var err_var `App` Type (idType bndr_var) + + is_simple_lpat p = is_simple_pat (unLoc p) + + is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps + is_simple_pat pat@(ConPatOut{}) = case unLoc (pat_con pat) of + RealDataCon con -> isProductTyCon (dataConTyCon con) + && all is_triv_lpat (hsConPatArgs (pat_args pat)) + PatSynCon _ -> False + is_simple_pat (VarPat _) = True + is_simple_pat (ParPat p) = is_simple_lpat p + is_simple_pat _ = False + + is_triv_lpat p = is_triv_pat (unLoc p) + + is_triv_pat (VarPat _) = True + is_triv_pat (WildPat _) = True + is_triv_pat (ParPat p) = is_triv_lpat p + is_triv_pat _ = False + +{- +Creating big tuples and their types for full Haskell expressions. +They work over *Ids*, and create tuples replete with their types, +which is whey they are not in HsUtils. +-} + +mkLHsPatTup :: [LPat Id] -> LPat Id +mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = L (getLoc (head lpats)) $ + mkVanillaTuplePat lpats Boxed + +mkLHsVarPatTup :: [Id] -> LPat Id +mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) + +mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id +-- A vanilla tuple pattern simply gets its type from its sub-patterns +mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTup :: [Id] -> LHsExpr Id +mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) + +mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id +mkBigLHsTup = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTup :: [Id] -> LPat Id +mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) + +mkBigLHsPatTup :: [LPat Id] -> LPat Id +mkBigLHsPatTup = mkChunkified mkLHsPatTup + +{- +************************************************************************ +* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +* * +************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of @fail.33@, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of @fail.33@ is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: Void -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 void + p3 -> fail.33 void + p4 -> ... +\end{verbatim} + +Now @fail.33@ is a function, so it can be let-bound. +-} + +mkFailurePair :: CoreExpr -- Result type of the whole case expression + -> DsM (CoreBind, -- Binds the newly-created fail variable + -- to \ _ -> expression + CoreExpr) -- Fail variable applied to realWorld# +-- See Note [Failure thunks and CPR] +mkFailurePair expr + = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty) + ; fail_fun_arg <- newSysLocalDs voidPrimTy + ; let real_arg = setOneShotLambda fail_fun_arg + ; return (NonRec fail_fun_var (Lam real_arg expr), + App (Var fail_fun_var) (Var voidPrimId)) } + where + ty = exprType expr + +{- +Note [Failure thunks and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we make a failure point we ensure that it +does not look like a thunk. Example: + + let fail = \rw -> error "urk" + in case x of + [] -> fail realWorld# + (y:ys) -> case ys of + [] -> fail realWorld# + (z:zs) -> (y,z) + +Reason: we know that a failure point is always a "join point" and is +entered at most once. Adding a dummy 'realWorld' token argument makes +it clear that sharing is not an issue. And that in turn makes it more +CPR-friendly. This matters a lot: if you don't get it right, you lose +the tail call property. For example, see Trac #3403. +-} + +mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr +mkOptTickBox = flip (foldr Tick) + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + uq <- newUnique + this_mod <- getModule + let bndr1 = mkSysLocal (fsLit "t1") uq boolTy + let + falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) + trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) + -- + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs new file mode 100644 index 00000000..c8e30f18 --- /dev/null +++ b/compiler/deSugar/Match.hs @@ -0,0 +1,1091 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @match@ function +-} + +{-# LANGUAGE CPP #-} + +module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where + +#include "HsVersions.h" + +import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) + +import DynFlags +import HsSyn +import TcHsSyn +import TcEvidence +import TcRnMonad +import Check +import CoreSyn +import Literal +import CoreUtils +import MkCore +import DsMonad +import DsBinds +import DsGRHSs +import DsUtils +import Id +import ConLike +import DataCon +import PatSyn +import MatchCon +import MatchLit +import Type +import TyCon( isNewTyCon ) +import TysWiredIn +import ListSetOps +import SrcLoc +import Maybes +import Util +import Name +import Outputable +import BasicTypes ( boxityNormalTupleSort, isGenerated ) +import FastString + +import Control.Monad( when ) +import qualified Data.Map as Map + +{- +This function is a wrapper of @match@, it must be called from all the parts where +it was called match, but only substitutes the first call, .... +if the associated flags are declared, warnings will be issued. +It can not be called matchWrapper because this name already exists :-( + +JJCQ 30-Nov-1997 +-} + +matchCheck :: DsMatchContext + -> [Id] -- Vars rep'ing the exprs we're matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! + +matchCheck ctx vars ty qs + = do { dflags <- getDynFlags + ; matchCheck_really dflags ctx vars ty qs } + +matchCheck_really :: DynFlags + -> DsMatchContext + -> [Id] + -> Type + -> [EquationInfo] + -> DsM MatchResult +matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs + = do { when shadow (dsShadowWarn ctx eqns_shadow) + ; when incomplete (dsIncompleteWarn ctx pats) + ; match vars ty qs } + where + (pats, eqns_shadow) = check qs + incomplete = incomplete_flag hs_ctx && notNull pats + shadow = wopt Opt_WarnOverlappingPatterns dflags + && notNull eqns_shadow + + incomplete_flag :: HsMatchContext id -> Bool + incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag IfAlt = False + + incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags + + incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags + + incomplete_flag ThPatSplice = False + incomplete_flag PatSyn = False + incomplete_flag ThPatQuote = False + incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns + -- in list comprehensions, pattern guards + -- etc. They are often *supposed* to be + -- incomplete + +{- +This variable shows the maximum number of lines of output generated for warnings. +It will limit the number of patterns/equations displayed to@ maximum_output@. + +(ToDo: add command-line option?) +-} + +maximum_output :: Int +maximum_output = 4 + +-- The next two functions create the warning message. + +dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () +dsShadowWarn ctx@(DsMatchContext kind loc) qs + = putSrcSpanDs loc (warnDs warn) + where + warn | qs `lengthExceeds` maximum_output + = pp_context ctx (ptext (sLit "are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext (sLit "...")) + | otherwise + = pp_context ctx (ptext (sLit "are overlapped")) + (\ f -> vcat $ map (ppr_eqn f kind) qs) + + +dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats + = putSrcSpanDs loc (warnDs warn) + where + warn = pp_context ctx (ptext (sLit "are non-exhaustive")) + (\_ -> hang (ptext (sLit "Patterns not matched:")) + 4 ((vcat $ map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ dots)) + + dots | pats `lengthExceeds` maximum_output = ptext (sLit "...") + | otherwise = empty + +pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc +pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun + = vcat [ptext (sLit "Pattern match(es)") <+> msg, + sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] + where + (ppr_match, pref) + = case kind of + FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) + +ppr_pats :: Outputable a => [a] -> SDoc +ppr_pats pats = sep (map ppr pats) + +ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc +ppr_shadow_pats kind pats + = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")] + +ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc +ppr_incomplete_pats _ (pats,[]) = ppr_pats pats +ppr_incomplete_pats _ (pats,constraints) = + sep [ppr_pats pats, ptext (sLit "with"), + sep (map ppr_constraint constraints)] + +ppr_constraint :: (Name,[HsLit]) -> SDoc +ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats] + +ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc +ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) + +{- +************************************************************************ +* * + The main matching function +* * +************************************************************************ + +The function @match@ is basically the same as in the Wadler chapter, +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let +in +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a type synonym, @EquationInfo@, defined in module @DsUtils@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @Var@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@Var "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\begin{itemize} +\item +Remove the `as' patterns from column~1. +\item +Make all constructor patterns in column~1 into @ConPats@, notably +@ListPats@ and @TuplePats@. +\item +Handle any irrefutable (or ``twiddle'') @LazyPats@. +\end{itemize} +\item +Now {\em unmix} the equations into {\em blocks} [w\/ local function +@unmix_eqns@], in which the equations in a block all have variable +patterns in column~1, or they all have constructor patterns in ... +(see ``the mixture rule'' in SLPJ). +\item +Call @matchEqnBlock@ on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern, usually ending up +in a recursive call to @match@. +\end{enumerate} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ +(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and +(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column of patterns either all +constructors, or all variables (or similar beasts), etc. + +@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the +Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ +corresponds roughly to @matchVarCon@. +-} + +match :: [Id] -- Variables rep\'ing the exprs we\'re matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! + +match [] ty eqns + = ASSERT2( not (null eqns), ppr ty ) + return (foldr1 combineMatchResults match_results) + where + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] + +match vars@(v:_) ty eqns -- Eqns *can* be empty + = do { dflags <- getDynFlags + -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + + -- Group the equations and match each group in turn + ; let grouped = groupEquations dflags tidy_eqns + + -- print the view patterns that are commoned up to help debug + ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- match_groups grouped + ; return (adjustMatchResult (foldr (.) id aux_binds) $ + foldr1 combineMatchResults match_results) } + where + dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] + dropGroup = map snd + + match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult] + -- Result list of [MatchResult] is always non-empty + match_groups [] = matchEmpty v ty + match_groups gs = mapM match_group gs + + match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult + match_group [] = panic "match_group" + match_group eqns@((group,_) : _) + = case group of + PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns]) + PgSyn _ -> matchPatSyn vars ty (dropGroup eqns) + PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns]) + PgAny -> matchVariables vars ty (dropGroup eqns) + PgN _ -> matchNPats vars ty (dropGroup eqns) + PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo _ -> matchCoercion vars ty (dropGroup eqns) + PgView _ _ -> matchView vars ty (dropGroup eqns) + PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded literals + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = warnDs (vcat l) + in + maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) + (filter (not . null) gs)) + +matchEmpty :: Id -> Type -> DsM [MatchResult] +-- See Note [Empty case expressions] +matchEmpty var res_ty + = return [MatchResult CanFail mk_seq] + where + mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty + [(DEFAULT, [], fail)] + +matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns) +matchVariables [] _ _ = panic "matchVariables" + +matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchBangs (var:vars) ty eqns + = do { match_result <- match (var:vars) ty $ + map (decomposeFirstPat getBangPat) eqns + ; return (mkEvalMatchResult var ty match_result) } +matchBangs [] _ _ = panic "matchBangs" + +matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the coercion to the match variable and then match that +matchCoercion (var:vars) ty (eqns@(eqn1:_)) + = do { let CoPat co pat _ = firstPat eqn1 + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getCoPat) eqns + ; rhs' <- dsHsWrapper co (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } +matchCoercion _ _ _ = panic "matchCoercion" + +matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the view function to the match variable and then match that +matchView (var:vars) ty (eqns@(eqn1:_)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + -- do the rest of the compilation + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getViewPat) eqns + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' viewExpr' var match_result) } +matchView _ _ _ = panic "matchView" + +matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) +-- Since overloaded list patterns are treated as view patterns, +-- the code is roughly the same as for matchView + = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern + ; e' <- dsExpr e + ; return (mkViewMatchResult var' e' var match_result) } +matchOverloadedList _ _ _ = panic "matchOverloadedList" + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo +decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} +decomposeFirstPat _ _ = panic "decomposeFirstPat" + +getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id +getCoPat (CoPat _ pat _) = pat +getCoPat _ = panic "getCoPat" +getBangPat (BangPat pat ) = unLoc pat +getBangPat _ = panic "getBangPat" +getViewPat (ViewPat _ pat _) = unLoc pat +getViewPat _ = panic "getViewPat" +getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat _ = panic "getOLPat" + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list of EquationInfo can be empty, arising from + case x of {} or \case {} +In that situation we desugar to + case x of { _ -> error "pattern match failure" } +The *desugarer* isn't certain whether there really should be no +alternatives, so it adds a default case, as it always does. A later +pass may remove it if it's inaccessible. (See also Note [Empty case +alternatives] in CoreSyn.) + +We do *not* desugar simply to + error "empty case" +or some such, because 'x' might be bound to (error "hello"), in which +case we want to see that "hello" exception, not (error "empty case"). +See also Note [Case elimination: lifted case] in Simplify. + + +************************************************************************ +* * + Tidying patterns +* * +************************************************************************ + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. This means: +\begin{itemize} +\item +Replace variable patterns @x@ (@x /= v@) with the pattern @_@, +together with the binding @x = v@. +\item +Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. +\item +Removing lazy (irrefutable) patterns (you don't want to know...). +\item +Converting explicit tuple-, list-, and parallel-array-pats into ordinary +@ConPats@. +\item +Convert the literal pat "" to []. +\end{itemize} + +The result of this tidying is that the column of patterns will include +{\em only}: +\begin{description} +\item[@WildPats@:] +The @VarPat@ information isn't needed any more after this. + +\item[@ConPats@:] +@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. + +\item[@LitPats@ and @NPats@:] +@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, +Float, Double, at least) are converted to unboxed form; e.g., +\tr{(NPat (HsInt i) _ _)} is converted to: +\begin{verbatim} +(ConPat I# _ _ [LitPat (HsIntPrim i)]) +\end{verbatim} +\end{description} +-} + +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- WildPat + -- ConPat + -- NPat + -- LitPat + -- NPlusKPat + -- but no other + +tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) + = panic "tidyEqnInfo" + +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) + = do { (wrap, pat') <- tidy1 v pat + ; return (wrap, eqn { eqn_pats = do pat' : pats }) } + +tidy1 :: Id -- The Id being scrutinised + -> Pat Id -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat Id) -- Equivalent pattern + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) yielding one of: +-- WildPat +-- ConPatOut +-- LitPat +-- NPat +-- NPlusKPat + +tidy1 v (ParPat pat) = tidy1 v (unLoc pat) +tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v (VarPat var) + = return (wrapBind var v, WildPat (idType var)) + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v (AsPat (L _ var) pat) + = do { (wrap, pat') <- tidy1 v (unLoc pat) + ; return (wrapBind var v . wrap, pat') } + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr +-} + +tidy1 v (LazyPat pat) + = do { sel_prs <- mkSelectorBinds [] pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } + +tidy1 _ (ListPat pats ty Nothing) + = return (idDsWrapper, unLoc list_ConPat) + where + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) + pats + +-- Introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +tidy1 _ (PArrPat pats ty) + = return (idDsWrapper, unLoc parrConPat) + where + arity = length pats + parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] + +tidy1 _ (TuplePat pats boxity tys) + = return (idDsWrapper, unLoc tuple_ConPat) + where + arity = length pats + tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys + +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 _ (LitPat lit) + = return (idDsWrapper, tidyLitPat lit) + +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 _ (NPat (L _ lit) mb_neg eq) + = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) + +-- Everything else goes through unchanged... + +tidy1 _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) + +-------------------- +tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) + +-- Discard par/sig under a bang +tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p + +-- Push the bang-pattern inwards, in the hope that +-- it may disappear next time +tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) +tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) + +-- Discard bang around strict pattern +tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p +tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p +tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p +tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p + +-- Data/newtype constructors +tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args }) + | isNewTyCon (dataConTyCon dc) -- Newtypes: push bang inwards (Trac #9844) + = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args }) + | otherwise -- Data types: discard the bang + = tidy1 v p + +------------------- +-- Default case, leave the bang there: +-- VarPat, +-- LazyPat, +-- WildPat, +-- ViewPat, +-- pattern synonyms (ConPatOut with PatSynCon) +-- NPat, +-- NPlusKPat +-- +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (Trac #8952) +-- +-- NB: SigPatIn, ConPatIn should not happen + +tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) + +------------------- +push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id +-- See Note [Bang patterns and newtypes] +-- We are transforming !(N p) into (N !p) +push_bang_into_newtype_arg l (PrefixCon (arg:args)) + = ASSERT( null args) + PrefixCon [L l (BangPat arg)] +push_bang_into_newtype_arg l (RecCon rf) + | HsRecFields { rec_flds = L lf fld : flds } <- rf + , HsRecField { hsRecFieldArg = arg } <- fld + = ASSERT( null flds) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) +push_bang_into_newtype_arg _ cd + = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) + +{- +Note [Bang patterns and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the pattern !(Just pat) we can discard the bang, because +the pattern is strict anyway. But for !(N pat), where + newtype NT = N Int +we definitely can't discard the bang. Trac #9844. + +So what we do is to push the bang inwards, in the hope that it will +get discarded there. So we transform + !(N pat) into (N !pat) + + +\noindent +{\bf Previous @matchTwiddled@ stuff:} + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +************************************************************************ +* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +* * +************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +************************************************************************ +* * +* matchWrapper: a convenient way to call @match@ * +* * +************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typchecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @CoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} +-} + +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id (LHsExpr Id) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results + +{- + There is one small problem with the Lambda Patterns, when somebody + writes something similar to: +\begin{verbatim} + (\ (x:xs) -> ...) +\end{verbatim} + he/she don't want a warning about incomplete patterns, that is done with + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @DsExpr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than +one pattern, and match simply only accepts one pattern. + +JJQC 30-Nov-1997 +-} + +matchWrapper ctxt (MG { mg_alts = matches + , mg_arg_tys = arg_tys + , mg_res_ty = rhs_ty + , mg_origin = origin }) + = do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- case matches of + [] -> mapM newSysLocalDs arg_tys + (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) + ; result_expr <- handleWarnings $ + matchEquations ctxt new_vars eqns_info rhs_ty + ; return (new_vars, result_expr) } + where + mk_eqn_info (L _ (Match _ pats _ grhss)) + = do { let upats = map unLoc pats + ; match_result <- dsGRHSs ctxt upats grhss rhs_ty + ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + + handleWarnings = if isGenerated origin + then discardWarningsDs + else id + + +matchEquations :: HsMatchContext Name + -> [Id] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_doc = matchContextErrString ctxt + + ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc + ; extractMatchResult match_result fail_expr } + +{- +************************************************************************ +* * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} +* * +************************************************************************ + +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. +-} + +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext Name -- Match kind + -> LPat Id -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't + -> DsM CoreExpr +-- Do not warn about incomplete patterns; see matchSinglePat comments +matchSimply scrut hs_ctx pat result_expr fail_expr = do + let + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result + extractMatchResult match_result' fail_expr + +matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id + -> Type -> MatchResult -> DsM MatchResult +-- Do not warn about incomplete patterns +-- Used for things like [ e | pat <- stuff ], where +-- incomplete patterns are just fine +matchSinglePat (Var var) ctx (L _ pat) ty match_result + = do { locn <- getSrcSpanDs + ; matchCheck (DsMatchContext ctx locn) + [var] ty + [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] } + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL pat + ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result + ; return (adjustMatchResult (bindNonRec var scrut) match_result') } + +{- +************************************************************************ +* * + Pattern classification +* * +************************************************************************ +-} + +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgSyn PatSyn + | PgLit Literal -- Literal patterns + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + | PgView (LHsExpr Id) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) + | PgOverloadedList + +groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty +-- The ordering of equations is unchanged +groupEquations dflags eqns + = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] + where + same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool + (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + +subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +subGroup group + = map reverse $ Map.elems $ foldl accumulate Map.empty group + where + accumulate pg_map (pg, eqn) + = case Map.lookup pg pg_map of + Just eqns -> Map.insert pg (eqn:eqns) pg_map + Nothing -> Map.insert pg [eqn] pg_map + + -- pg_map :: Map a [EquationInfo] + -- Equations seen so far in reverse order of appearance + +{- +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! +-} + +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgSyn p1) (PgSyn p2) = p1==p2 +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 + -- CoPats are in the same goup only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same group iff the expressions + -- are "equal"---conservatively, we use syntactic equality +sameGroup _ _ = False + +-- An approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- This function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- Currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool +viewLExprEq (e1,_) (e2,_) = lexp e1 e2 + where + lexp :: LHsExpr Id -> LHsExpr Id -> Bool + lexp e e' = exp (unLoc e) (unLoc e') + + --------- + exp :: HsExpr Id -> HsExpr Id -> Bool + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar (L _ e)) e' = exp e e' + exp e (HsPar (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' + exp (HsVar i) (HsVar i') = i == i' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLit l) (HsOverLit l') = + -- Overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + eqType (overLitType l) (overLitType l') && l == l' + exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' + exp (SectionL e1 e2) (SectionL e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR e1 e2) (SectionR e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + eq_list tup_arg es1 es2 + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + + -- Enhancement: could implement equality for more expressions + -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions + exp _ _ = False + + --------- + tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg _ _ = False + + --------- + wrap :: HsWrapper -> HsWrapper -> Bool + -- Conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- Coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' + wrap (WpCast co) (WpCast co') = co `eq_co` co' + wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 + wrap (WpTyApp t) (WpTyApp t') = eqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + --------- + ev_term :: EvTerm -> EvTerm -> Bool + ev_term (EvId a) (EvId b) = a==b + ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b + ev_term _ _ = False + + --------- + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys + + --------- + eq_co :: TcCoercion -> TcCoercion -> Bool + -- Just some simple cases (should the r1 == r2 rather be an ASSERT?) + eq_co (TcRefl r1 t1) (TcRefl r2 t2) = r1 == r2 && eqType t1 t2 + eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2 + eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2 + eq_co (TcTyConAppCo r1 tc1 cos1) (TcTyConAppCo r2 tc2 cos2) = r1 == r2 && tc1==tc2 && eq_list eq_co cos1 cos2 + eq_co _ _ = False + +patGroup :: DynFlags -> Pat Id -> PatGroup +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (ConPatOut { pat_con = con }) = case unLoc con of + RealDataCon dcon -> PgCon dcon + PatSynCon psyn -> PgSyn psyn +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (NPat (L _ olit) mb_neg _) + = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList +patGroup _ pat = pprPanic "patGroup" (ppr pat) + +{- +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. +-} diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot new file mode 100644 index 00000000..826f635e --- /dev/null +++ b/compiler/deSugar/Match.hs-boot @@ -0,0 +1,33 @@ +module Match where +import Var ( Id ) +import TcType ( Type ) +import DsMonad ( DsM, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import Name ( Name ) + +match :: [Id] + -> Type + -> [EquationInfo] + -> DsM MatchResult + +matchWrapper + :: HsMatchContext Name + -> MatchGroup Id (LHsExpr Id) + -> DsM ([Id], CoreExpr) + +matchSimply + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr + +matchSinglePat + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> Type + -> MatchResult + -> DsM MatchResult diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs new file mode 100644 index 00000000..b42522c3 --- /dev/null +++ b/compiler/deSugar/MatchCon.hs @@ -0,0 +1,290 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching constructors +-} + +{-# LANGUAGE CPP #-} + +module MatchCon ( matchConFamily, matchPatSyn ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( match ) + +import HsSyn +import DsBinds +import ConLike +import DataCon +import PatSyn +import TcType +import DsMonad +import DsUtils +import MkCore ( mkCoreLets ) +import Util +import ListSetOps ( runs ) +import Id +import NameEnv +import SrcLoc +import DynFlags +import Outputable +import Control.Monad(liftM) + +{- +We are confronted with the first column of patterns in a set of +equations, all beginning with constructors from one ``family'' (e.g., +@[]@ and @:@ make up the @List@ ``family''). We want to generate the +alternatives for a @Case@ expression. There are several choices: +\begin{enumerate} +\item +Generate an alternative for every constructor in the family, whether +they are used in this set of equations or not; this is what the Wadler +chapter does. +\begin{description} +\item[Advantages:] +(a)~Simple. (b)~It may also be that large sparsely-used constructor +families are mainly handled by the code for literals. +\item[Disadvantages:] +(a)~Not practical for large sparsely-used constructor families, e.g., +the ASCII character set. (b)~Have to look up a list of what +constructors make up the whole family. +\end{description} + +\item +Generate an alternative for each constructor used, then add a default +alternative in case some constructors in the family weren't used. +\begin{description} +\item[Advantages:] +(a)~Alternatives aren't generated for unused constructors. (b)~The +STG is quite happy with defaults. (c)~No lookup in an environment needed. +\item[Disadvantages:] +(a)~A spurious default alternative may be generated. +\end{description} + +\item +``Do it right:'' generate an alternative for each constructor used, +and add a default alternative if all constructors in the family +weren't used. +\begin{description} +\item[Advantages:] +(a)~You will get cases with only one alternative (and no default), +which should be amenable to optimisation. Tuples are a common example. +\item[Disadvantages:] +(b)~Have to look up constructor families in TDE (as above). +\end{description} +\end{enumerate} + +We are implementing the ``do-it-right'' option for now. The arguments +to @matchConFamily@ are the same as to @match@; the extra @Int@ +returned is the number of constructors in the family. + +The function @matchConFamily@ is concerned with this +have-we-used-all-the-constructors? question; the local function +@match_cons_used@ does all the real work. +-} + +matchConFamily :: [Id] + -> Type + -> [[EquationInfo]] + -> DsM MatchResult +-- Each group of eqns is for a single constructor +matchConFamily (var:vars) ty groups + = do dflags <- getDynFlags + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + return (mkCoAlgCaseMatchResult dflags var ty alts) + where + toRealAlt alt = case alt_pat alt of + RealDataCon dcon -> alt{ alt_pat = dcon } + _ -> panic "matchConFamily: not RealDataCon" +matchConFamily [] _ _ = panic "matchConFamily []" + +matchPatSyn :: [Id] + -> Type + -> [EquationInfo] + -> DsM MatchResult +matchPatSyn (var:vars) ty eqns + = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns + return (mkCoSynCaseMatchResult var ty alt) + where + toSynAlt alt = case alt_pat alt of + PatSynCon psyn -> alt{ alt_pat = psyn } + _ -> panic "matchPatSyn: not PatSynCon" +matchPatSyn _ _ _ = panic "matchPatSyn []" + +type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) + +matchOneConLike :: [Id] + -> Type + -> [EquationInfo] + -> DsM (CaseAlt ConLike) +matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor + = do { arg_vars <- selectConMatchVars val_arg_tys args1 + -- Use the first equation as a source of + -- suggestions for the new variables + + -- Divide into sub-groups; see Note [Record patterns] + ; let groups :: [[(ConArgPats, EquationInfo)]] + groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn) + | eqn <- eqn1:eqns ] + + ; match_results <- mapM (match_group arg_vars) groups + + ; return $ MkCaseAlt{ alt_pat = con1, + alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, + alt_wrapper = wrapper1, + alt_result = foldr1 combineMatchResults match_results } } + where + ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1, + pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } + = firstPat eqn1 + fields1 = case con1 of + RealDataCon dcon1 -> dataConFieldLabels dcon1 + PatSynCon{} -> [] + + val_arg_tys = case con1 of + RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys + PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys + inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want + + ex_tvs = case con1 of + RealDataCon dcon1 -> dataConExTyVars dcon1 + PatSynCon psyn1 -> patSynExTyVars psyn1 + + match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult + -- All members of the group have compatible ConArgPats + match_group arg_vars arg_eqn_prs + = ASSERT( notNull arg_eqn_prs ) + do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + ; match_result <- match (group_arg_vars ++ vars) ty eqns' + ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } + + shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, + pat_binds = bind, pat_args = args + } : pats })) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } + ) + shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + + -- Choose the right arg_vars in the right order for this group + -- Note [Record patterns] + select_arg_vars arg_vars ((arg_pats, _) : _) + | RecCon flds <- arg_pats + , let rpats = rec_flds flds + , not (null rpats) -- Treated specially; cf conArgPats + = ASSERT2( length fields1 == length arg_vars, + ppr con1 $$ ppr fields1 $$ ppr arg_vars ) + map lookup_fld rpats + | otherwise + = arg_vars + where + fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env + (idName (unLoc (hsRecFieldId rpat))) + select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" +matchOneConLike _ _ [] = panic "matchOneCon []" + +----------------- +compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool +-- Two constructors have compatible argument patterns if the number +-- and order of sub-matches is the same in both cases +compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2 +compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1) +compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2) +compatible_pats _ _ = True -- Prefix or infix con + +same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool +same_fields flds1 flds2 + = all2 (\(L _ f1) (L _ f2) + -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) + (rec_flds flds1) (rec_flds flds2) + + +----------------- +selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] +selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys +selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) +selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] + +conArgPats :: [Type] -- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway + -> ConArgPats + -> [Pat Id] +conArgPats _arg_tys (PrefixCon ps) = map unLoc ps +conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] +conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) + | null rpats = map WildPat arg_tys + -- Important special case for C {}, which can be used for a + -- datacon that isn't declared to have fields at all + | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats + +{- +Note [Record patterns] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = T { x,y,z :: Bool } + + f (T { y=True, x=False }) = ... + +We must match the patterns IN THE ORDER GIVEN, thus for the first +one we match y=True before x=False. See Trac #246; or imagine +matching against (T { y=False, x=undefined }): should fail without +touching the undefined. + +Now consider: + + f (T { y=True, x=False }) = ... + f (T { x=True, y= False}) = ... + +In the first we must test y first; in the second we must test x +first. So we must divide even the equations for a single constructor +T into sub-goups, based on whether they match the same field in the +same order. That's what the (runs compatible_pats) grouping. + +All non-record patterns are "compatible" in this sense, because the +positional patterns (T a b) and (a `T` b) all match the arguments +in order. Also T {} is special because it's equivalent to (T _ _). +Hence the (null rpats) checks here and there. + + +Note [Existentials in shift_con_pat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. Ord a => T a (a->Int) + + f (T x f) True = ...expr1... + f (T y g) False = ...expr2.. + +When we put in the tyvars etc we get + + f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... + f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... + +After desugaring etc we'll get a single case: + + f = \t::T b::Bool -> + case t of + T a (d::Ord a) (x::a) (f::a->Int)) -> + case b of + True -> ...expr1... + False -> ...expr2... + +*** We have to substitute [a/b, d/e] in expr2! ** +Hence + False -> ....((/\b\(e:Ord b).expr2) a d).... + +Originally I tried to use + (\b -> let e = d in expr2) a +to do this substitution. While this is "correct" in a way, it fails +Lint, because e::Ord b but d::Ord a. +-} diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs new file mode 100644 index 00000000..6e8dfc1d --- /dev/null +++ b/compiler/deSugar/MatchLit.hs @@ -0,0 +1,464 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching literal patterns +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , warnAboutIdentities, warnAboutEmptyEnumerations + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( match ) +import {-# SOURCE #-} DsExpr ( dsExpr ) + +import DsMonad +import DsUtils + +import HsSyn + +import Id +import CoreSyn +import MkCore +import TyCon +import DataCon +import TcHsSyn ( shortCutLit ) +import TcType +import Name +import Type +import PrelNames +import TysWiredIn +import Literal +import SrcLoc +import Data.Ratio +import Outputable +import BasicTypes +import DynFlags +import Util +import FastString +import Control.Monad + +import Data.Int +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable (traverse) +#endif +import Data.Word + +{- +************************************************************************ +* * + Desugaring literals + [used to be in DsExpr, but DsMeta needs it, + and it's nice to avoid a loop] +* * +************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. +-} + +dsLit :: HsLit -> DsM CoreExpr +dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) +dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) +dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) +dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) +dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i)) +dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w)) +dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) + +dsLit (HsChar _ c) = return (mkCharExpr c) +dsLit (HsString _ str) = mkStringExprFS str +dsLit (HsInteger _ i _) = mkIntegerExpr i +dsLit (HsInt _ i) = do dflags <- getDynFlags + return (mkIntExpr dflags i) + +dsLit (HsRat r ty) = do + num <- mkIntegerExpr (numerator (fl_value r)) + denom <- mkIntegerExpr (denominator (fl_value r)) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + where + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) + x -> pprPanic "dsLit" (ppr x) + +dsOverLit :: HsOverLit Id -> DsM CoreExpr +dsOverLit lit = do { dflags <- getDynFlags + ; warnAboutOverflowedLiterals dflags lit + ; dsOverLit' dflags lit } + +dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr +-- Post-typechecker, the SyntaxExpr field of an OverLit contains +-- (an expression for) the literal value itself +dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = witness, ol_type = ty }) + | not rebindable + , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] + | otherwise = dsExpr witness + +{- +Note [Literal short cut] +~~~~~~~~~~~~~~~~~~~~~~~~ +The type checker tries to do this short-cutting as early as possible, but +because of unification etc, more information is available to the desugarer. +And where it's possible to generate the correct literal right away, it's +much better to do so. + + +************************************************************************ +* * + Warnings about overflowed literals +* * +************************************************************************ + +Warn about functions like toInteger, fromIntegral, that convert +between one type and another when the to- and from- types are the +same. Then it's probably (albeit not definitely) the identity +-} + +warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () +warnAboutIdentities dflags (Var conv_fn) type_of_conv + | wopt Opt_WarnIdentities dflags + , idName conv_fn `elem` conversionNames + , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , arg_ty `eqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ ptext (sLit "can probably be omitted") + , parens (ptext (sLit "Use -fno-warn-identities to suppress this message")) + ]) +warnAboutIdentities _ _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- because they are generated by literals + +warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () +warnAboutOverflowedLiterals dflags lit + | wopt Opt_WarnOverflowedLiterals dflags + , Just (i, tc) <- getIntegralLit lit + = if tc == intTyConName then check i tc (undefined :: Int) + else if tc == int8TyConName then check i tc (undefined :: Int8) + else if tc == int16TyConName then check i tc (undefined :: Int16) + else if tc == int32TyConName then check i tc (undefined :: Int32) + else if tc == int64TyConName then check i tc (undefined :: Int64) + else if tc == wordTyConName then check i tc (undefined :: Word) + else if tc == word8TyConName then check i tc (undefined :: Word8) + else if tc == word16TyConName then check i tc (undefined :: Word16) + else if tc == word32TyConName then check i tc (undefined :: Word32) + else if tc == word64TyConName then check i tc (undefined :: Word64) + else return () + + | otherwise = return () + where + check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM () + check i tc _proxy + = when (i < minB || i > maxB) $ do + warnDs (vcat [ ptext (sLit "Literal") <+> integer i + <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range") + <+> integer minB <> ptext (sLit "..") <> integer maxB + , sug ]) + where + minB = toInteger (minBound :: a) + maxB = toInteger (maxBound :: a) + sug | minB == -i -- Note [Suggest NegativeLiterals] + , i > 0 + , not (xopt Opt_NegativeLiterals dflags) + = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals") + | otherwise = Outputable.empty + +{- +Note [Suggest NegativeLiterals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write + x :: Int8 + x = -128 +it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. +We get an erroneous suggestion for + x = 128 +but perhaps that does not matter too much. +-} + +warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () +-- Warns about [2,3 .. 1] which returns the empty list +-- Only works for integral types, not floating point +warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr + | wopt Opt_WarnEmptyEnumerations dflags + , Just (from,tc) <- getLHsIntegralLit fromExpr + , Just mThn <- traverse getLHsIntegralLit mThnExpr + , Just (to,_) <- getLHsIntegralLit toExpr + , let check :: forall a. (Enum a, Num a) => a -> DsM () + check _proxy + = when (null enumeration) $ + warnDs (ptext (sLit "Enumeration is empty")) + where + enumeration :: [a] + enumeration = case mThn of + Nothing -> [fromInteger from .. fromInteger to] + Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] + + = if tc == intTyConName then check (undefined :: Int) + else if tc == int8TyConName then check (undefined :: Int8) + else if tc == int16TyConName then check (undefined :: Int16) + else if tc == int32TyConName then check (undefined :: Int32) + else if tc == int64TyConName then check (undefined :: Int64) + else if tc == wordTyConName then check (undefined :: Word) + else if tc == word8TyConName then check (undefined :: Word8) + else if tc == word16TyConName then check (undefined :: Word16) + else if tc == word32TyConName then check (undefined :: Word32) + else if tc == word64TyConName then check (undefined :: Word64) + else return () + + | otherwise = return () + +getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) +-- See if the expression is an Integral literal +-- Remember to look through automatically-added tick-boxes! (Trac #8384) +getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit +getLHsIntegralLit _ = Nothing + +getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) +getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty }) + | Just tc <- tyConAppTyCon_maybe ty + = Just (i, tyConName tc) +getIntegralLit _ = Nothing + +{- +************************************************************************ +* * + Tidying lit pats +* * +************************************************************************ +-} + +tidyLitPat :: HsLit -> Pat Id +-- Result has only the following HsLits: +-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim, HsString +-- * HsInteger, HsRat, HsInt can't show up in LitPats +-- * We get rid of HsChar right here +tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) +tidyLitPat (HsString src s) + | lengthFS s <= 1 -- Short string literals only + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon + [mkCharLitPat src c, pat] [charTy]) + (mkNilPat charTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! +tidyLitPat lit = LitPat lit + +---------------- +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Pat Id +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for weird cases like Trac #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we hvae 'instance IsString Int' + -- + + | isIntTy ty, Just int_lit <- mb_int_lit + = mk_con_pat intDataCon (HsIntPrim "" int_lit) + | isWordTy ty, Just int_lit <- mb_int_lit + = mk_con_pat wordDataCon (HsWordPrim "" int_lit) + | isStringTy ty, Just str_lit <- mb_str_lit + = tidy_lit_pat (HsString "" str_lit) + -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 + -- If we do convert to the constructor form, we'll generate a case + -- expression on a Float# or Double# and that's not allowed in Core; see + -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules + where + mk_con_pat :: DataCon -> HsLit -> Pat Id + mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) + + mb_int_lit :: Maybe Integer + mb_int_lit = case (mb_neg, val) of + (Nothing, HsIntegral _ i) -> Just i + (Just _, HsIntegral _ i) -> Just (-i) + _ -> Nothing + + mb_str_lit :: Maybe FastString + mb_str_lit = case (mb_neg, val) of + (Nothing, HsIsString _ s) -> Just s + _ -> Nothing + +tidyNPat _ over_lit mb_neg eq + = NPat (noLoc over_lit) mb_neg eq + +{- +************************************************************************ +* * + Pattern matching on LitPat +* * +************************************************************************ +-} + +matchLiterals :: [Id] + -> Type -- Type of the whole case expression + -> [[EquationInfo]] -- All PgLits + -> DsM MatchResult + +matchLiterals (var:vars) ty sub_groups + = ASSERT( notNull sub_groups && all notNull sub_groups ) + do { -- Deal with each group + ; alts <- mapM match_group sub_groups + + -- Combine results. For everything except String + -- we can use a case expression; for String we need + -- a chain of if-then-else + ; if isStringTy (idType var) then + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts + ; return (foldr1 combineMatchResults mrs) } + else + return (mkCoPrimCaseMatchResult var ty alts) + } + where + match_group :: [EquationInfo] -> DsM (Literal, MatchResult) + match_group eqns + = do dflags <- getDynFlags + let LitPat hs_lit = firstPat (head eqns) + match_result <- match vars ty (shiftEqns eqns) + return (hsLitKey dflags hs_lit, match_result) + + wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult + -- Equality check for string literals + wrap_str_guard eq_str (MachStr s, mr) + = do { -- We now have to convert back to FastString. Perhaps there + -- should be separate MachBytes and MachStr constructors? + let s' = mkFastStringByteString s + ; lit <- mkStringExprFS s' + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } + wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) + +matchLiterals [] _ _ = panic "matchLiterals []" + +--------------------------- +hsLitKey :: DynFlags -> HsLit -> Literal +-- Get a Core literal to use (only) a grouping key +-- Hence its type doesn't need to match the type of the original literal +-- (and doesn't for strings) +-- It only works for primitive types and strings; +-- others have been removed by tidy +hsLitKey dflags (HsIntPrim _ i) = mkMachInt dflags i +hsLitKey dflags (HsWordPrim _ w) = mkMachWord dflags w +hsLitKey _ (HsInt64Prim _ i) = mkMachInt64 i +hsLitKey _ (HsWord64Prim _ w) = mkMachWord64 w +hsLitKey _ (HsCharPrim _ c) = MachChar c +hsLitKey _ (HsStringPrim _ s) = MachStr s +hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d) +hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) + +--------------------------- +hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal +-- Ditto for HsOverLit; the boolean indicates to negate +hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg + +--------------------------- +litValKey :: OverLitVal -> Bool -> Literal +litValKey (HsIntegral _ i) False = MachInt i +litValKey (HsIntegral _ i) True = MachInt (-i) +litValKey (HsFractional r) False = MachFloat (fl_value r) +litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) +litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr + (fastStringToByteString s) + +{- +************************************************************************ +* * + Pattern matching on NPat +* * +************************************************************************ +-} + +matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal + = do { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of + Nothing -> return lit_expr + Just neg -> do { neg_expr <- dsExpr neg + ; return (App neg_expr lit_expr) } + ; eq_expr <- dsExpr eq_chk + ; let pred_expr = mkApps eq_expr [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } +matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) + +{- +************************************************************************ +* * + Pattern matching on n+k patterns +* * +************************************************************************ + +For an n+k pattern, we use the various magic expressions we've been given. +We generate: +\begin{verbatim} + if ge var lit then + let n = sub var lit + in + else + +\end{verbatim} +-} + +matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- All NPlusKPats, for the *same* literal k +matchNPlusKPats (var:vars) ty (eqn1:eqns) + = do { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1 + ; ge_expr <- dsExpr ge + ; minus_expr <- dsExpr minus + ; lit_expr <- dsOverLit lit + ; let pred_expr = mkApps ge_expr [Var var, lit_expr] + minusk_expr = mkApps minus_expr [Var var, lit_expr] + (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) + ; match_result <- match vars ty eqns' + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + adjustMatchResult (foldr1 (.) wraps) $ + match_result) } + where + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats }) + = (wrapBind n n1, eqn { eqn_pats = pats }) + -- The wrapBind is a no-op for the first equation + shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) + +matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) diff --git a/compiler/deSugar/StaticPtrTable.hs b/compiler/deSugar/StaticPtrTable.hs new file mode 100644 index 00000000..d1e8e051 --- /dev/null +++ b/compiler/deSugar/StaticPtrTable.hs @@ -0,0 +1,97 @@ +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_sptEntryZC0_closure; +-- > hs_spt_insert(k0, &Main_sptEntryZC0_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_sptEntryZC1_closure; +-- > hs_spt_insert(k1, &Main_sptEntryZC1_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- +module StaticPtrTable (sptInitCode) where + +import CoreSyn +import Module +import Outputable +import Id +import CLabel +import GHC.Fingerprint + + +-- | @sptInitCode module statics@ is a C stub to insert the static entries +-- @statics@ of @module@ into the static pointer table. +-- +-- Each entry contains the fingerprint used to locate the entry and the +-- top-level binding for the entry. +-- +sptInitCode :: Module -> [(Fingerprint, (Id,CoreExpr))] -> SDoc +sptInitCode _ [] = Outputable.empty +sptInitCode this_mod entries = vcat + [ text "static void hs_spt_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, (fp, (n, _))) <- zip [0..] entries + ] + , text "static void hs_spt_fini_" <> ppr this_mod + <> text "(void) __attribute__((destructor));" + , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (fp, _)) <- zip [0..] entries + ] + ] + + where + + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in new file mode 100644 index 00000000..684ee6bf --- /dev/null +++ b/compiler/ghc.cabal.in @@ -0,0 +1,579 @@ +-- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by +-- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. + +Name: ghc +Version: @ProjectVersion@ +License: BSD3 +License-File: ../LICENSE +Author: The GHC Team +Maintainer: glasgow-haskell-users@haskell.org +Homepage: http://www.haskell.org/ghc/ +Synopsis: The GHC API +Description: + GHC's functionality can be useful for more things than just + compiling Haskell programs. Important use cases are programs + that analyse (and perhaps transform) Haskell code. Others + include loading Haskell code dynamically in a GHCi-like manner. + For this reason, a lot of GHC's functionality is made available + through this package. +Category: Development +Build-Type: Simple +Cabal-Version: >=1.10 + +Flag ghci + Description: Build GHCi support. + Default: False + Manual: True + +Flag stage1 + Description: Is this stage 1? + Default: False + Manual: True + +Flag stage2 + Description: Is this stage 2? + Default: False + Manual: True + +Flag stage3 + Description: Is this stage 3? + Default: False + Manual: True + +Library + Default-Language: Haskell2010 + Exposed: False + + Build-Depends: base >= 4 && < 5, + directory >= 1 && < 1.3, + process >= 1 && < 1.3, + bytestring >= 0.9 && < 0.11, + time < 1.6, + containers >= 0.5 && < 0.6, + array >= 0.1 && < 0.6, + filepath >= 1 && < 1.5, + hpc, + transformers, + bin-package-db, + hoopl + + if os(windows) + Build-Depends: Win32 + else + Build-Depends: unix + + GHC-Options: -Wall -fno-warn-name-shadowing + + if flag(ghci) + Build-Depends: template-haskell + CPP-Options: -DGHCI + Include-Dirs: ../rts/dist/build @FFIIncludeDir@ + + Other-Extensions: + BangPatterns + CPP + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + DisambiguateRecordFields + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NondecreasingIndentation + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TupleSections + TypeFamilies + TypeSynonymInstances + UnboxedTuples + UndecidableInstances + + Include-Dirs: . parser utils + + if impl( ghc >= 7.9 ) + -- We need to set the package key to ghc (without a version number) + -- as it's magic. But we can't set it for old versions of GHC (e.g. + -- when bootstrapping) because those versions of GHC don't understand + -- that GHC is wired-in. + GHC-Options: -this-package-key ghc + + if flag(stage1) + Include-Dirs: stage1 + else + if flag(stage2) + Include-Dirs: stage2 + else + if flag(stage3) + Include-Dirs: stage2 + + Install-Includes: HsVersions.h, ghc_boot_platform.h + + c-sources: + parser/cutils.c + ghci/keepCAFsForGHCi.c + cbits/genSym.c + + hs-source-dirs: + basicTypes + cmm + codeGen + coreSyn + deSugar + ghci + hsSyn + iface + llvmGen + main + nativeGen + parser + prelude + profiling + rename + simplCore + simplStg + specialise + stgSyn + stranal + typecheck + types + utils + vectorise + + Exposed-Modules: + Avail + BasicTypes + ConLike + DataCon + PatSyn + Demand + Debug + Exception + GhcMonad + Hooks + Id + IdInfo + Lexeme + Literal + Llvm + Llvm.AbsSyn + Llvm.MetaData + Llvm.PpLlvm + Llvm.Types + LlvmCodeGen + LlvmCodeGen.Base + LlvmCodeGen.CodeGen + LlvmCodeGen.Data + LlvmCodeGen.Ppr + LlvmCodeGen.Regs + LlvmMangler + MkId + Module + Name + NameEnv + NameSet + OccName + RdrName + SrcLoc + UniqSupply + Unique + Var + VarEnv + VarSet + UnVarGraph + BlockId + CLabel + Cmm + CmmBuildInfoTables + CmmPipeline + CmmCallConv + CmmCommonBlockElim + CmmContFlowOpt + CmmExpr + CmmInfo + CmmLex + CmmLint + CmmLive + CmmMachOp + CmmNode + CmmOpt + CmmParse + CmmProcPoint + CmmSink + CmmType + CmmUtils + CmmLayoutStack + MkGraph + PprBase + PprC + PprCmm + PprCmmDecl + PprCmmExpr + Bitmap + CodeGen.Platform + CodeGen.Platform.ARM + CodeGen.Platform.ARM64 + CodeGen.Platform.NoRegs + CodeGen.Platform.PPC + CodeGen.Platform.PPC_Darwin + CodeGen.Platform.SPARC + CodeGen.Platform.X86 + CodeGen.Platform.X86_64 + CgUtils + StgCmm + StgCmmBind + StgCmmClosure + StgCmmCon + StgCmmEnv + StgCmmExpr + StgCmmForeign + StgCmmHeap + StgCmmHpc + StgCmmArgRep + StgCmmLayout + StgCmmMonad + StgCmmPrim + StgCmmProf + StgCmmTicky + StgCmmUtils + StgCmmExtCode + SMRep + CoreArity + CoreFVs + CoreLint + CorePrep + CoreSubst + CoreSyn + TrieMap + CoreTidy + CoreUnfold + CoreUtils + MkCore + PprCore + Check + Coverage + Desugar + DsArrows + DsBinds + DsCCall + DsExpr + DsForeign + DsGRHSs + DsListComp + DsMonad + DsUtils + Match + MatchCon + MatchLit + HsBinds + HsDecls + HsDoc + HsExpr + HsImpExp + HsLit + PlaceHolder + HsPat + HsSyn + HsTypes + HsUtils + BinIface + BuildTyCl + IfaceEnv + IfaceSyn + IfaceType + LoadIface + MkIface + TcIface + FlagChecker + Annotations + BreakArray + CmdLineParser + CodeOutput + Config + Constants + DriverMkDepend + DriverPhases + PipelineMonad + DriverPipeline + DynFlags + ErrUtils + Finder + GHC + GhcMake + GhcPlugins + DynamicLoading + HeaderInfo + HscMain + HscStats + HscTypes + InteractiveEval + InteractiveEvalTypes + PackageConfig + Packages + PlatformConstants + Plugins + TcPluginM + PprTyThing + StaticFlags + StaticPtrTable + SysTools + TidyPgm + Ctype + HaddockUtils + Lexer + OptCoercion + Parser + RdrHsSyn + ApiAnnotation + ForeignCall + PrelInfo + PrelNames + PrelRules + PrimOp + TysPrim + TysWiredIn + CostCentre + ProfInit + SCCfinal + RnBinds + RnEnv + RnExpr + RnHsDoc + RnNames + RnPat + RnSource + RnSplice + RnTypes + CoreMonad + CSE + FloatIn + FloatOut + LiberateCase + OccurAnal + SAT + SetLevels + SimplCore + SimplEnv + SimplMonad + SimplUtils + Simplify + SimplStg + StgStats + UnariseStg + Rules + SpecConstr + Specialise + CoreToStg + StgLint + StgSyn + CallArity + DmdAnal + WorkWrap + WwLib + FamInst + Inst + TcAnnotations + TcArrows + TcBinds + TcClassDcl + TcDefaults + TcDeriv + TcEnv + TcExpr + TcForeign + TcGenDeriv + TcGenGenerics + TcHsSyn + TcHsType + TcInstDcls + TcMType + TcValidity + TcMatches + TcPat + TcPatSyn + TcRnDriver + TcRnMonad + TcRnTypes + TcRules + TcSimplify + TcErrors + TcTyClsDecls + TcTyDecls + TcType + TcEvidence + TcUnify + TcInteract + TcCanonical + TcFlatten + TcSMonad + TcTypeNats + TcSplice + Class + Coercion + FamInstEnv + FunDeps + InstEnv + TyCon + CoAxiom + Kind + Type + TypeRep + Unify + Bag + Binary + BooleanFormula + BufWrite + Digraph + Encoding + FastBool + FastFunctions + FastMutInt + FastString + FastTypes + Fingerprint + FiniteMap + GraphBase + GraphColor + GraphOps + GraphPpr + IOEnv + ListSetOps + Maybes + MonadUtils + OrdList + Outputable + Pair + Panic + Pretty + Serialized + State + Stream + StringBuffer + UniqFM + UniqSet + Util + ExtsCompat46 +-- ^^^ a temporary module necessary to bootstrap with GHC <= 7.6 + Vectorise.Builtins.Base + Vectorise.Builtins.Initialise + Vectorise.Builtins + Vectorise.Monad.Base + Vectorise.Monad.Naming + Vectorise.Monad.Local + Vectorise.Monad.Global + Vectorise.Monad.InstEnv + Vectorise.Monad + Vectorise.Utils.Base + Vectorise.Utils.Closure + Vectorise.Utils.Hoisting + Vectorise.Utils.PADict + Vectorise.Utils.Poly + Vectorise.Utils + Vectorise.Generic.Description + Vectorise.Generic.PAMethods + Vectorise.Generic.PADict + Vectorise.Generic.PData + Vectorise.Type.Env + Vectorise.Type.Type + Vectorise.Type.TyConDecl + Vectorise.Type.Classify + Vectorise.Convert + Vectorise.Vect + Vectorise.Var + Vectorise.Env + Vectorise.Exp + Vectorise + Hoopl.Dataflow + Hoopl +-- CgInfoTbls used in ghci/DebuggerUtils +-- CgHeapery mkVirtHeapOffsets used in ghci + + Exposed-Modules: + AsmCodeGen + TargetReg + NCGMonad + Instruction + Size + Reg + RegClass + PIC + Platform + CPrim + X86.Regs + X86.RegInfo + X86.Instr + X86.Cond + X86.Ppr + X86.CodeGen + PPC.Regs + PPC.RegInfo + PPC.Instr + PPC.Cond + PPC.Ppr + PPC.CodeGen + SPARC.Base + SPARC.Regs + SPARC.Imm + SPARC.AddrMode + SPARC.Cond + SPARC.Instr + SPARC.Stack + SPARC.ShortcutJump + SPARC.Ppr + SPARC.CodeGen + SPARC.CodeGen.Amode + SPARC.CodeGen.Base + SPARC.CodeGen.CondCode + SPARC.CodeGen.Gen32 + SPARC.CodeGen.Gen64 + SPARC.CodeGen.Sanity + SPARC.CodeGen.Expand + RegAlloc.Liveness + RegAlloc.Graph.Main + RegAlloc.Graph.Stats + RegAlloc.Graph.ArchBase + RegAlloc.Graph.ArchX86 + RegAlloc.Graph.Coalesce + RegAlloc.Graph.Spill + RegAlloc.Graph.SpillClean + RegAlloc.Graph.SpillCost + RegAlloc.Graph.TrivColorable + RegAlloc.Linear.Main + RegAlloc.Linear.JoinToTargets + RegAlloc.Linear.State + RegAlloc.Linear.Stats + RegAlloc.Linear.FreeRegs + RegAlloc.Linear.StackMap + RegAlloc.Linear.Base + RegAlloc.Linear.X86.FreeRegs + RegAlloc.Linear.X86_64.FreeRegs + RegAlloc.Linear.PPC.FreeRegs + RegAlloc.Linear.SPARC.FreeRegs + Dwarf + Dwarf.Types + Dwarf.Constants + + if flag(ghci) + Exposed-Modules: + DsMeta + Convert + ByteCodeAsm + ByteCodeGen + ByteCodeInstr + ByteCodeItbls + ByteCodeLink + Debugger + LibFFI + Linker + ObjLink + RtClosureInspect + DebuggerUtils diff --git a/compiler/ghc.mk b/compiler/ghc.mk new file mode 100644 index 00000000..7bb72c2f --- /dev/null +++ b/compiler/ghc.mk @@ -0,0 +1,746 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009-2012 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# Create compiler configuration +# +# The 'echo' commands simply spit the values of various make variables +# into Config.hs, whence they can be compiled and used by GHC itself + +# This is just to avoid generating a warning when generating deps +# involving RtsFlags.h +compiler_stage1_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES +compiler_stage2_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES +compiler_stage3_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES + +compiler_stage1_C_FILES_NODEPS = compiler/parser/cutils.c + +# This package doesn't pass the Cabal checks because include-dirs +# points outside the source directory. This isn't a real problem, so +# we just skip the check. +compiler_NO_CHECK = YES + +ifneq "$(BINDIST)" "YES" +compiler/stage1/package-data.mk : compiler/stage1/build/Config.hs +compiler/stage2/package-data.mk : compiler/stage2/build/Config.hs +compiler/stage3/package-data.mk : compiler/stage3/build/Config.hs + +compiler/stage1/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage2/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage3/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) +compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) +compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) +compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) +compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) +compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) +endif + +compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. + $(call removeFiles,$@) + @echo 'Creating $@ ... ' + @echo '{-# LANGUAGE CPP #-}' >> $@ + @echo 'module Config where' >> $@ + @echo >> $@ + @echo '#include "ghc_boot_platform.h"' >> $@ + @echo >> $@ + @echo 'data IntegerLibrary = IntegerGMP' >> $@ + @echo ' | IntegerGMP2' >> $@ + @echo ' | IntegerSimple' >> $@ + @echo ' deriving Eq' >> $@ + @echo >> $@ + @echo 'cBuildPlatformString :: String' >> $@ + @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ + @echo 'cHostPlatformString :: String' >> $@ + @echo 'cHostPlatformString = HostPlatform_NAME' >> $@ + @echo 'cTargetPlatformString :: String' >> $@ + @echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@ + @echo >> $@ + @echo 'cProjectName :: String' >> $@ + @echo 'cProjectName = "$(ProjectName)"' >> $@ + @echo 'cProjectGitCommitId :: String' >> $@ + @echo 'cProjectGitCommitId = "$(ProjectGitCommitId)"' >> $@ + @echo 'cProjectVersion :: String' >> $@ + @echo 'cProjectVersion = "$(ProjectVersion)"' >> $@ + @echo 'cProjectVersionInt :: String' >> $@ + @echo 'cProjectVersionInt = "$(ProjectVersionInt)"' >> $@ + @echo 'cProjectPatchLevel :: String' >> $@ + @echo 'cProjectPatchLevel = "$(ProjectPatchLevel)"' >> $@ + @echo 'cProjectPatchLevel1 :: String' >> $@ + @echo 'cProjectPatchLevel1 = "$(ProjectPatchLevel1)"' >> $@ + @echo 'cProjectPatchLevel2 :: String' >> $@ + @echo 'cProjectPatchLevel2 = "$(ProjectPatchLevel2)"' >> $@ + @echo 'cBooterVersion :: String' >> $@ + @echo 'cBooterVersion = "$(GhcVersion)"' >> $@ + @echo 'cStage :: String' >> $@ + @echo 'cStage = show (STAGE :: Int)' >> $@ + @echo 'cIntegerLibrary :: String' >> $@ + @echo 'cIntegerLibrary = "$(INTEGER_LIBRARY)"' >> $@ + @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ +ifeq "$(INTEGER_LIBRARY)" "integer-gmp" + @echo 'cIntegerLibraryType = IntegerGMP' >> $@ +else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" + @echo 'cIntegerLibraryType = IntegerGMP2' >> $@ +else ifeq "$(INTEGER_LIBRARY)" "integer-simple" + @echo 'cIntegerLibraryType = IntegerSimple' >> $@ +else ifneq "$(CLEANING)" "YES" +$(error Unknown integer library) +endif + @echo 'cSupportsSplitObjs :: String' >> $@ + @echo 'cSupportsSplitObjs = "$(SupportsSplitObjs)"' >> $@ + @echo 'cGhcWithInterpreter :: String' >> $@ + @echo 'cGhcWithInterpreter = "$(GhcWithInterpreter)"' >> $@ + @echo 'cGhcWithNativeCodeGen :: String' >> $@ + @echo 'cGhcWithNativeCodeGen = "$(GhcWithNativeCodeGen)"' >> $@ + @echo 'cGhcWithSMP :: String' >> $@ + @echo 'cGhcWithSMP = "$(GhcWithSMP)"' >> $@ + @echo 'cGhcRTSWays :: String' >> $@ + @echo 'cGhcRTSWays = "$(GhcRTSWays)"' >> $@ + @echo 'cGhcEnableTablesNextToCode :: String' >> $@ + @echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@ + @echo 'cLeadingUnderscore :: String' >> $@ + @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ + @echo 'cGHC_UNLIT_PGM :: String' >> $@ + @echo 'cGHC_UNLIT_PGM = "$(utils/unlit_dist_PROG)"' >> $@ + @echo 'cGHC_SPLIT_PGM :: String' >> $@ + @echo 'cGHC_SPLIT_PGM = "$(driver/split_dist_PROG)"' >> $@ + @echo 'cLibFFI :: Bool' >> $@ +ifeq "$(UseLibFFIForAdjustors)" "YES" + @echo 'cLibFFI = True' >> $@ +else + @echo 'cLibFFI = False' >> $@ +endif +# Note that GhcThreaded just reflects the Makefile variable setting. +# In particular, the stage1 compiler is never actually compiled with +# -threaded, but it will nevertheless have cGhcThreaded = True. +# The "+RTS --info" output will show what RTS GHC is really using. + @echo 'cGhcThreaded :: Bool' >> $@ +ifeq "$(GhcThreaded)" "YES" + @echo 'cGhcThreaded = True' >> $@ +else + @echo 'cGhcThreaded = False' >> $@ +endif + @echo 'cGhcDebugged :: Bool' >> $@ +ifeq "$(GhcDebugged)" "YES" + @echo 'cGhcDebugged = True' >> $@ +else + @echo 'cGhcDebugged = False' >> $@ +endif + @echo done. + +# ----------------------------------------------------------------------------- +# Create platform includes + +# Here we generate a little header file containing CPP symbols that GHC +# uses to determine which platform it is building on/for. The platforms +# can differ between stage1 and stage2 if we're cross-compiling, so we +# need one of these header files per stage. + +PLATFORM_H = ghc_boot_platform.h + +compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. + $(call removeFiles,$@) + @echo "Creating $@..." + @echo "#ifndef __PLATFORM_H__" >> $@ + @echo "#define __PLATFORM_H__" >> $@ + @echo >> $@ + @echo "#define BuildPlatform_NAME \"$(BUILDPLATFORM)\"" >> $@ + @echo "#define HostPlatform_NAME \"$(HOSTPLATFORM)\"" >> $@ + @echo "#define TargetPlatform_NAME \"$(TARGETPLATFORM)\"" >> $@ + @echo >> $@ + @echo "#define $(BuildPlatform_CPP)_BUILD 1" >> $@ + @echo "#define $(HostPlatform_CPP)_HOST 1" >> $@ + @echo "#define $(TargetPlatform_CPP)_TARGET 1" >> $@ + @echo >> $@ + @echo "#define $(BuildArch_CPP)_BUILD_ARCH 1" >> $@ + @echo "#define $(HostArch_CPP)_HOST_ARCH 1" >> $@ + @echo "#define $(TargetArch_CPP)_TARGET_ARCH 1" >> $@ + @echo "#define BUILD_ARCH \"$(BuildArch_CPP)\"" >> $@ + @echo "#define HOST_ARCH \"$(HostArch_CPP)\"" >> $@ + @echo "#define TARGET_ARCH \"$(TargetArch_CPP)\"" >> $@ + @echo >> $@ + @echo "#define $(BuildOS_CPP)_BUILD_OS 1" >> $@ + @echo "#define $(HostOS_CPP)_HOST_OS 1" >> $@ + @echo "#define $(TargetOS_CPP)_TARGET_OS 1" >> $@ + @echo "#define BUILD_OS \"$(BuildOS_CPP)\"" >> $@ + @echo "#define HOST_OS \"$(HostOS_CPP)\"" >> $@ + @echo "#define TARGET_OS \"$(TargetOS_CPP)\"" >> $@ +ifeq "$(TargetOS_CPP)" "irix" + @echo "#ifndef $(IRIX_MAJOR)_TARGET_OS" >> $@ + @echo "#define $(IRIX_MAJOR)_TARGET_OS 1" >> $@ + @echo "#endif" >> $@ +endif + @echo >> $@ + @echo "#define $(BuildVendor_CPP)_BUILD_VENDOR 1" >> $@ + @echo "#define $(HostVendor_CPP)_HOST_VENDOR 1" >> $@ + @echo "#define $(TargetVendor_CPP)_TARGET_VENDOR 1" >> $@ + @echo "#define BUILD_VENDOR \"$(BuildVendor_CPP)\"" >> $@ + @echo "#define HOST_VENDOR \"$(HostVendor_CPP)\"" >> $@ + @echo "#define TARGET_VENDOR \"$(TargetVendor_CPP)\"" >> $@ + @echo >> $@ + @echo "#endif /* __PLATFORM_H__ */" >> $@ + @echo "Done." + +# For stage2 and above, the BUILD platform is the HOST of stage1, and +# the HOST platform is the TARGET of stage1. The TARGET remains the same +# (stage1 is the cross-compiler, not stage2). +compiler/stage2/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. + $(call removeFiles,$@) + @echo "Creating $@..." + @echo "#ifndef __PLATFORM_H__" >> $@ + @echo "#define __PLATFORM_H__" >> $@ + @echo >> $@ + @echo "#define BuildPlatform_NAME \"$(HOSTPLATFORM)\"" >> $@ + @echo "#define HostPlatform_NAME \"$(TARGETPLATFORM)\"" >> $@ + @echo "#define TargetPlatform_NAME \"$(TARGETPLATFORM)\"" >> $@ + @echo >> $@ + @echo "#define $(HostPlatform_CPP)_BUILD 1" >> $@ + @echo "#define $(TargetPlatform_CPP)_HOST 1" >> $@ + @echo "#define $(TargetPlatform_CPP)_TARGET 1" >> $@ + @echo >> $@ + @echo "#define $(HostArch_CPP)_BUILD_ARCH 1" >> $@ + @echo "#define $(TargetArch_CPP)_HOST_ARCH 1" >> $@ + @echo "#define $(TargetArch_CPP)_TARGET_ARCH 1" >> $@ + @echo "#define BUILD_ARCH \"$(HostArch_CPP)\"" >> $@ + @echo "#define HOST_ARCH \"$(TargetArch_CPP)\"" >> $@ + @echo "#define TARGET_ARCH \"$(TargetArch_CPP)\"" >> $@ + @echo >> $@ + @echo "#define $(HostOS_CPP)_BUILD_OS 1" >> $@ + @echo "#define $(TargetOS_CPP)_HOST_OS 1" >> $@ + @echo "#define $(TargetOS_CPP)_TARGET_OS 1" >> $@ + @echo "#define BUILD_OS \"$(HostOS_CPP)\"" >> $@ + @echo "#define HOST_OS \"$(TargetOS_CPP)\"" >> $@ + @echo "#define TARGET_OS \"$(TargetOS_CPP)\"" >> $@ +ifeq "$(TargetOS_CPP)" "irix" + @echo "#ifndef $(IRIX_MAJOR)_TARGET_OS" >> $@ + @echo "#define $(IRIX_MAJOR)_TARGET_OS 1" >> $@ + @echo "#endif" >> $@ +endif + @echo >> $@ + @echo "#define $(HostVendor_CPP)_BUILD_VENDOR 1" >> $@ + @echo "#define $(TargetVendor_CPP)_HOST_VENDOR 1" >> $@ + @echo "#define $(TargetVendor_CPP)_TARGET_VENDOR 1" >> $@ + @echo "#define BUILD_VENDOR \"$(HostVendor_CPP)\"" >> $@ + @echo "#define HOST_VENDOR \"$(TargetVendor_CPP)\"" >> $@ + @echo "#define TARGET_VENDOR \"$(TargetVendor_CPP)\"" >> $@ + @echo >> $@ + @echo "#endif /* __PLATFORM_H__ */" >> $@ + @echo "Done." + +compiler/stage3/$(PLATFORM_H) : compiler/stage2/$(PLATFORM_H) + "$(CP)" $< $@ + +# ---------------------------------------------------------------------------- +# Generate supporting stuff for prelude/PrimOp.lhs +# from prelude/primops.txt + +PRIMOP_BITS_NAMES = primop-data-decl.hs-incl \ + primop-tag.hs-incl \ + primop-list.hs-incl \ + primop-has-side-effects.hs-incl \ + primop-out-of-line.hs-incl \ + primop-commutable.hs-incl \ + primop-code-size.hs-incl \ + primop-can-fail.hs-incl \ + primop-strictness.hs-incl \ + primop-fixity.hs-incl \ + primop-primop-info.hs-incl \ + primop-vector-uniques.hs-incl \ + primop-vector-tys.hs-incl \ + primop-vector-tys-exports.hs-incl \ + primop-vector-tycons.hs-incl + +PRIMOP_BITS_STAGE1 = $(addprefix compiler/stage1/build/,$(PRIMOP_BITS_NAMES)) +PRIMOP_BITS_STAGE2 = $(addprefix compiler/stage2/build/,$(PRIMOP_BITS_NAMES)) +PRIMOP_BITS_STAGE3 = $(addprefix compiler/stage3/build/,$(PRIMOP_BITS_NAMES)) + +compiler_CPP_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) +compiler_CPP_OPTS += ${GhcCppOpts} + +define preprocessCompilerFiles +# $0 = stage +compiler/stage$1/build/primops.txt: compiler/prelude/primops.txt.pp compiler/stage$1/$$(PLATFORM_H) + $$(CPP) $$(RAWCPP_FLAGS) -P $$(compiler_CPP_OPTS) -Icompiler/stage$1 -x c $$< | grep -v '^#pragma GCC' > $$@ + +compiler/stage$1/build/primop-data-decl.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --data-decl < $$< > $$@ +compiler/stage$1/build/primop-tag.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-tag < $$< > $$@ +compiler/stage$1/build/primop-list.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-list < $$< > $$@ +compiler/stage$1/build/primop-has-side-effects.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --has-side-effects < $$< > $$@ +compiler/stage$1/build/primop-out-of-line.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --out-of-line < $$< > $$@ +compiler/stage$1/build/primop-commutable.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --commutable < $$< > $$@ +compiler/stage$1/build/primop-code-size.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --code-size < $$< > $$@ +compiler/stage$1/build/primop-can-fail.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --can-fail < $$< > $$@ +compiler/stage$1/build/primop-strictness.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --strictness < $$< > $$@ +compiler/stage$1/build/primop-fixity.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --fixity < $$< > $$@ +compiler/stage$1/build/primop-primop-info.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-primop-info < $$< > $$@ +compiler/stage$1/build/primop-vector-uniques.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-uniques < $$< > $$@ +compiler/stage$1/build/primop-vector-tys.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tys < $$< > $$@ +compiler/stage$1/build/primop-vector-tys-exports.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tys-exports < $$< > $$@ +compiler/stage$1/build/primop-vector-tycons.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tycons < $$< > $$@ + +# Usages aren't used any more; but the generator +# can still generate them if we want them back +compiler/stage$1/build/primop-usage.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --usage < $$< > $$@ + +endef + +$(eval $(call preprocessCompilerFiles,1)) +$(eval $(call preprocessCompilerFiles,2)) +$(eval $(call preprocessCompilerFiles,3)) + +# ----------------------------------------------------------------------------- +# Configuration + +compiler_stage1_CONFIGURE_OPTS += --flags=stage1 +compiler_stage2_CONFIGURE_OPTS += --flags=stage2 +compiler_stage3_CONFIGURE_OPTS += --flags=stage3 + +ifeq "$(GhcThreaded)" "YES" +# We pass THREADED_RTS to the stage2 C files so that cbits/genSym.c will bring +# the threaded version of atomic_inc() into scope. +compiler_stage2_CONFIGURE_OPTS += --ghc-option=-optc-DTHREADED_RTS +endif + +ifeq "$(GhcWithNativeCodeGen)" "YES" +compiler_stage1_CONFIGURE_OPTS += --flags=ncg +compiler_stage2_CONFIGURE_OPTS += --flags=ncg +endif + +ifeq "$(GhcWithInterpreter)" "YES" +compiler_stage2_CONFIGURE_OPTS += --flags=ghci + +ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO" +# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style +# or not? +# XXX This should logically be a CPP option, but there doesn't seem to +# be a flag for that +compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE +endif + +# Should the debugger commands be enabled? +ifeq "$(GhciWithDebugger)" "YES" +compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DDEBUGGER +endif + +endif + +ifeq "$(TargetOS_CPP)" "openbsd" +compiler_CONFIGURE_OPTS += --ld-options=-E +endif + +ifeq "$(GhcUnregisterised)" "NO" +else +compiler_CONFIGURE_OPTS += --ghc-option=-DNO_REGS +endif + +ifneq "$(GhcWithSMP)" "YES" +compiler_CONFIGURE_OPTS += --ghc-option=-DNOSMP +compiler_CONFIGURE_OPTS += --ghc-option=-optc-DNOSMP +endif + +# Careful optimisation of the parser: we don't want to throw everything +# at it, because that takes too long and doesn't buy much, but we do want +# to inline certain key external functions, so we instruct GHC not to +# throw away inlinings as it would normally do in -O0 mode. +compiler/stage1/build/Parser_HC_OPTS += -O0 -fno-ignore-interface-pragmas +# If we're bootstrapping the compiler during stage2, or we're being +# built by a GHC whose version is > 7.8, we need -fcmm-sink to be +# passed to the compiler. This is required on x86 to avoid the +# register allocator running out of stack slots when compiling this +# module with -fPIC -dynamic. +# See #8182 for all the details +ifeq "$(CMM_SINK_BOOTSTRAP_IS_NEEDED)" "YES" +compiler/stage1/build/Parser_HC_OPTS += -fcmm-sink +endif +# We also pass -fcmm-sink to every stage != 1 +compiler/stage2/build/Parser_HC_OPTS += -O0 -fno-ignore-interface-pragmas -fcmm-sink +compiler/stage3/build/Parser_HC_OPTS += -O0 -fno-ignore-interface-pragmas -fcmm-sink + + +ifeq "$(GhcProfiled)" "YES" +# If we're profiling GHC then we want SCCs. However, adding -auto-all +# everywhere tends to give a hard-to-read profile, and adds lots of +# overhead. A better approach is to proceed top-down; identify the +# parts of the compiler of interest, and then add further cost centres +# as necessary. Turn on -auto-all for individual modules like this: + +# compiler/main/DriverPipeline_HC_OPTS += -auto-all +compiler/main/GhcMake_HC_OPTS += -auto-all +compiler/main/GHC_HC_OPTS += -auto-all + +# or alternatively add {-# OPTIONS_GHC -auto-all #-} to the top of +# modules you're interested in. + +# We seem to still build the vanilla libraries even if we say +# --disable-library-vanilla, but installation then fails, as Cabal +# doesn't copy the vanilla .hi files, but ghc-pkg complains about +# their absence when we register the package. So for now, we just +# leave the vanilla libraries enabled. +# compiler_stage2_CONFIGURE_OPTS += --disable-library-vanilla +compiler_stage2_CONFIGURE_OPTS += --ghc-pkg-option=--force +endif + +compiler_stage3_CONFIGURE_OPTS := $(compiler_stage2_CONFIGURE_OPTS) + +compiler_stage1_CONFIGURE_OPTS += --ghc-option=-DSTAGE=1 +compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DSTAGE=2 +compiler_stage3_CONFIGURE_OPTS += --ghc-option=-DSTAGE=3 +compiler_stage2_HADDOCK_OPTS += --optghc=-DSTAGE=2 + +compiler/stage1/package-data.mk : compiler/ghc.mk +compiler/stage2/package-data.mk : compiler/ghc.mk +compiler/stage3/package-data.mk : compiler/ghc.mk + +# ----------------------------------------------------------------------------- +# And build the package + +compiler_PACKAGE = ghc + +# Note [fiddle-stage1-version] +# The version of the GHC package changes every day, since the +# patchlevel is the current date. We don't want to force +# recompilation of the entire compiler when this happens, so for stage +# 1 we omit the patchlevel from the version number. For stage 2 we +# have to include the patchlevel since this is the package we install, +# however. +# +# Note: we also have to tweak the version number of the package itself +# when it gets registered; see Note [munge-stage1-package-config] +# below. +# The ProjectPatchLevel > 20000000 iff it's a date. If it's e.g. 6.12.1 +# then we don't want to remove it +ifneq "$(CLEANING)" "YES" +ifeq "$(shell [ $(ProjectPatchLevel) -gt 20000000 ] && echo YES)" "YES" +compiler_stage1_VERSION_MUNGED = YES +endif +endif + +ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) +define compiler_PACKAGE_MAGIC +compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) +compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY)) +compiler_stage1_LIB_NAME = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_LIB_NAME)) +endef + +# NB: the PACKAGE_KEY munging has no effect for new-style package keys +# (which indeed, have nothing version like in them, but are important for +# old-style package keys which do.) The subst operation is idempotent, so +# as long as we do it at least once we should be good. + +# Don't register the non-munged package +compiler_stage1_REGISTER_PACKAGE = NO + +endif + +# Don't do splitting for the GHC package, it takes too long and +# there's not much benefit. +compiler_stage1_SplitObjs = NO +compiler_stage2_SplitObjs = NO +compiler_stage3_SplitObjs = NO + +# There are too many symbols in the ghc package for a Windows DLL. +# We therefore need to split some of the modules off into a separate +# DLL. This clump are the modules reachable from DynFlags: +compiler_stage2_dll0_START_MODULE = DynFlags +compiler_stage2_dll0_MODULES = \ + Annotations \ + ApiAnnotation \ + Avail \ + Bag \ + BasicTypes \ + Binary \ + BooleanFormula \ + BreakArray \ + BufWrite \ + Class \ + CmdLineParser \ + CmmType \ + CoAxiom \ + ConLike \ + Coercion \ + Config \ + Constants \ + CoreArity \ + CoreFVs \ + CoreSubst \ + CoreSyn \ + CoreTidy \ + CoreUnfold \ + CoreUtils \ + CostCentre \ + Ctype \ + DataCon \ + Demand \ + Digraph \ + DriverPhases \ + DynFlags \ + Encoding \ + ErrUtils \ + Exception \ + ExtsCompat46 \ + FamInstEnv \ + FastFunctions \ + FastMutInt \ + FastString \ + FastTypes \ + Fingerprint \ + FiniteMap \ + ForeignCall \ + Hooks \ + HsBinds \ + HsDecls \ + HsDoc \ + HsExpr \ + HsImpExp \ + HsLit \ + PlaceHolder \ + HsPat \ + HsSyn \ + HsTypes \ + HsUtils \ + HscTypes \ + IOEnv \ + Id \ + IdInfo \ + IfaceSyn \ + IfaceType \ + InstEnv \ + Kind \ + Lexeme \ + Lexer \ + ListSetOps \ + Literal \ + Maybes \ + MkCore \ + MkId \ + Module \ + MonadUtils \ + Name \ + NameEnv \ + NameSet \ + OccName \ + OccurAnal \ + OptCoercion \ + OrdList \ + Outputable \ + PackageConfig \ + Packages \ + Pair \ + Panic \ + PatSyn \ + PipelineMonad \ + Platform \ + PlatformConstants \ + PprCore \ + PrelNames \ + PrelRules \ + Pretty \ + PrimOp \ + RdrName \ + Rules \ + Serialized \ + SrcLoc \ + StaticFlags \ + StringBuffer \ + TcEvidence \ + TcRnTypes \ + TcType \ + TrieMap \ + TyCon \ + Type \ + TypeRep \ + TysPrim \ + TysWiredIn \ + Unify \ + UniqFM \ + UniqSet \ + UniqSupply \ + Unique \ + Util \ + Var \ + VarEnv \ + VarSet + +ifeq "$(GhcWithInterpreter)" "YES" +# These files are reacheable from DynFlags +# only by GHCi-enabled code (see #9552) +compiler_stage2_dll0_MODULES += \ + Bitmap \ + BlockId \ + ByteCodeAsm \ + ByteCodeInstr \ + ByteCodeItbls \ + CLabel \ + Cmm \ + CmmCallConv \ + CmmExpr \ + CmmInfo \ + CmmMachOp \ + CmmNode \ + CmmUtils \ + CodeGen.Platform \ + CodeGen.Platform.ARM \ + CodeGen.Platform.ARM64 \ + CodeGen.Platform.NoRegs \ + CodeGen.Platform.PPC \ + CodeGen.Platform.PPC_Darwin \ + CodeGen.Platform.SPARC \ + CodeGen.Platform.X86 \ + CodeGen.Platform.X86_64 \ + FastBool \ + Hoopl \ + Hoopl.Dataflow \ + InteractiveEvalTypes \ + MkGraph \ + PprCmm \ + PprCmmDecl \ + PprCmmExpr \ + Reg \ + RegClass \ + SMRep \ + StgCmmArgRep \ + StgCmmClosure \ + StgCmmEnv \ + StgCmmLayout \ + StgCmmMonad \ + StgCmmProf \ + StgCmmTicky \ + StgCmmUtils \ + StgSyn \ + Stream +endif + +compiler_stage2_dll0_HS_OBJS = \ + $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES))) + +# if stage is set to something other than "1" or "", disable stage 1 +ifneq "$(filter-out 1,$(stage))" "" +compiler_stage1_NOT_NEEDED = YES +endif +# if stage is set to something other than "2" or "", disable stage 2 +ifneq "$(filter-out 2,$(stage))" "" +compiler_stage2_NOT_NEEDED = YES +endif +# stage 3 has to be requested explicitly with stage=3 +ifneq "$(stage)" "3" +compiler_stage3_NOT_NEEDED = YES +endif +$(eval $(call build-package,compiler,stage1,0)) +$(eval $(call build-package,compiler,stage2,1)) +$(eval $(call build-package,compiler,stage3,2)) + +# We only want to turn keepCAFs on if we will be loading dynamic +# Haskell libraries with GHCi. We therefore filter the object file +# out for non-dynamic ways. +define keepCAFsForGHCiDynOnly +# $1 = stage +# $2 = way +ifeq "$$(findstring dyn, $1)" "" +compiler_stage$1_$2_C_OBJS := $$(filter-out %/keepCAFsForGHCi.o,$$(compiler_stage$1_$2_C_OBJS)) +endif +endef +$(foreach w,$(compiler_stage1_WAYS),$(eval $(call keepCAFsForGHCiDynOnly,1,$w))) +$(foreach w,$(compiler_stage2_WAYS),$(eval $(call keepCAFsForGHCiDynOnly,2,$w))) +$(foreach w,$(compiler_stage3_WAYS),$(eval $(call keepCAFsForGHCiDynOnly,3,$w))) + +# after build-package, because that adds --enable-library-for-ghci +# to compiler_stage*_CONFIGURE_OPTS: +# We don't build the GHCi library for the ghc package. We can load it +# the .a file instead, and as object splitting isn't on for the ghc +# package this isn't much slower.However, not building the package saves +# a significant chunk of disk space. +compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci +compiler_stage2_CONFIGURE_OPTS += --disable-library-for-ghci +compiler_stage3_CONFIGURE_OPTS += --disable-library-for-ghci + +# after build-package, because that sets compiler_stage1_HC_OPTS: +compiler_stage1_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts) +compiler_stage2_HC_OPTS += $(GhcHcOpts) $(GhcStage2HcOpts) +compiler_stage3_HC_OPTS += $(GhcHcOpts) $(GhcStage3HcOpts) + +ifneq "$(BINDIST)" "YES" + +compiler_stage2_TAGS_HC_OPTS = -package ghc +$(eval $(call tags-package,compiler,stage2)) + +$(compiler_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H) +$(compiler_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H) +$(compiler_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H) + +COMPILER_INCLUDES_DEPS += $(includes_H_CONFIG) +COMPILER_INCLUDES_DEPS += $(includes_H_PLATFORM) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_TYPE) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_WRAPPERS) +COMPILER_INCLUDES_DEPS += $(includes_GHCCONSTANTS_HASKELL_EXPORTS) +COMPILER_INCLUDES_DEPS += $(includes_DERIVEDCONSTANTS) + +$(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE1) +$(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE2) +$(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE3) + +$(foreach way,$(compiler_stage1_WAYS),\ + compiler/stage1/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE1) +$(foreach way,$(compiler_stage2_WAYS),\ + compiler/stage2/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE2) +$(foreach way,$(compiler_stage3_WAYS),\ + compiler/stage3/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE3) + + +# GHC itself doesn't know about the above dependencies, so we have to +# switch off the recompilation checker for that module: +compiler/prelude/PrimOp_HC_OPTS += -fforce-recomp + +ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" +compiler/utils/Util_HC_OPTS += -DDYNAMIC_GHC_PROGRAMS +endif + +# LibFFI.hs #includes ffi.h +ifneq "$(UseSystemLibFFI)" "YES" +compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) +endif + +# Note [munge-stage1-package-config] +# Strip the date/patchlevel from the version of stage1. See Note +# [fiddle-stage1-version] above. +ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +compiler/stage1/inplace-pkg-config-munged: compiler/stage1/inplace-pkg-config + sed -e 's/^\(version: .*\)\.$(ProjectPatchLevel)$$/\1/' \ + -e 's/^\(id: .*\)\.$(ProjectPatchLevel)$$/\1/' \ + -e 's/^\(hs-libraries: HSghc-.*\)\.$(ProjectPatchLevel)$$/\1/' \ + < $< > $@ + "$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@ + +# We need to make sure the munged config is in the database before we +# try to configure ghc-bin +ghc/stage1/package-data.mk : compiler/stage1/inplace-pkg-config-munged +endif + +endif + diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs new file mode 100644 index 00000000..efcca14f --- /dev/null +++ b/compiler/ghci/ByteCodeAsm.hs @@ -0,0 +1,555 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | ByteCodeLink: Bytecode assembler and linker +module ByteCodeAsm ( + assembleBCOs, assembleBCO, + + CompiledByteCode(..), + UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH + ) where + +#include "HsVersions.h" + +import ByteCodeInstr +import ByteCodeItbls + +import Name +import NameSet +import Literal +import TyCon +import PrimOp +import FastString +import StgCmmLayout ( ArgRep(..) ) +import SMRep +import DynFlags +import Outputable +import Platform +import Util + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif +import Control.Monad +import Control.Monad.ST ( runST ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict + +import Data.Array.MArray + +import qualified Data.Array.Unboxed as Array +import Data.Array.Base ( UArray(..) ) + +import Data.Array.Unsafe( castSTUArray ) + +import Foreign +import Data.Char ( ord ) +import Data.List +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map + +import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld ) + +-- ----------------------------------------------------------------------------- +-- Unlinked BCOs + +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +data CompiledByteCode + = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings + ItblEnv -- A mapping from DataCons to their itbls + +instance Outputable CompiledByteCode where + ppr (ByteCode bcos _) = ppr bcos + + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: Name, + unlinkedBCOArity :: Int, + unlinkedBCOInstrs :: ByteArray#, -- insns + unlinkedBCOBitmap :: ByteArray#, -- bitmap + unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs + } + +data BCOPtr + = BCOPtrName Name + | BCOPtrPrimOp PrimOp + | BCOPtrBCO UnlinkedBCO + | BCOPtrBreakInfo BreakInfo + | BCOPtrArray (MutableByteArray# RealWorld) + +data BCONPtr + = BCONPtrWord Word + | BCONPtrLbl FastString + | BCONPtrItbl Name + +-- | Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcoFreeNames :: UnlinkedBCO -> NameSet +bcoFreeNames bco + = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco] + where + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + = unionNameSets ( + mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] : + mkNameSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] + ) + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeSS lits), text "lits", + ppr (sizeSS ptrs), text "ptrs" ] + +-- ----------------------------------------------------------------------------- +-- The bytecode assembler + +-- The object format for bytecodes is: 16 bits for the opcode, and 16 +-- for each field -- so the code can be considered a sequence of +-- 16-bit ints. Each field denotes either a stack offset or number of +-- items on the stack (eg SLIDE), and index into the pointer table (eg +-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a +-- bytecode address in this BCO. + +-- Top level assembler fn. +assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs dflags proto_bcos tycons + = do itblenv <- mkITbls dflags tycons + bcos <- mapM (assembleBCO dflags) proto_bcos + return (ByteCode bcos itblenv) + +assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do + -- pass 1: collect up the offsets of the local labels. + let asm = mapM_ (assembleI dflags) instrs + + initial_offset = 0 + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm + ((n_insns, lbl_map), long_jumps) + | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True) + | otherwise = ((n_insns0, lbl_map0), False) + + env :: Word16 -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (Map.lookup lbl lbl_map) + + -- pass 2: run assembler and generate instructions, literals and pointers + let initial_state = (emptySS, emptySS, emptySS) + (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm + + -- precomputed size should be equal to final size + ASSERT(n_insns == sizeSS final_insns) return () + + let asm_insns = ssElts final_insns + barr a = case a of UArray _lo _hi _n b -> b + + insns_arr = Array.listArray (0, n_insns - 1) asm_insns + !insns_barr = barr insns_arr + + bitmap_arr = mkBitmapArray bsize bitmap + !bitmap_barr = barr bitmap_arr + + ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + +mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word +-- Here the return type must be an array of Words, not StgWords, +-- because the underlying ByteArray# will end up as a component +-- of a BCO object. +mkBitmapArray bsize bitmap + = Array.listArray (0, length bitmap) $ + fromIntegral bsize : map (fromInteger . fromStgWord) bitmap + +-- instrs nonptrs ptrs +type AsmState = (SizedSeq Word16, + SizedSeq BCONPtr, + SizedSeq BCOPtr) + +data SizedSeq a = SizedSeq !Word [a] +emptySS :: SizedSeq a +emptySS = SizedSeq 0 [] + +addToSS :: SizedSeq a -> a -> SizedSeq a +addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) + +addListToSS :: SizedSeq a -> [a] -> SizedSeq a +addListToSS (SizedSeq n r_xs) xs + = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs) + +ssElts :: SizedSeq a -> [a] +ssElts (SizedSeq _ r_xs) = reverse r_xs + +sizeSS :: SizedSeq a -> Word +sizeSS (SizedSeq n _) = n + +data Operand + = Op Word + | SmallOp Word16 + | LabelOp Word16 +-- (unused) | LargeOp Word + +data Assembler a + = AllocPtr (IO BCOPtr) (Word -> Assembler a) + | AllocLit [BCONPtr] (Word -> Assembler a) + | AllocLabel Word16 (Assembler a) + | Emit Word16 [Operand] (Assembler a) + | NullAsm a + +instance Functor Assembler where + fmap = liftM + +instance Applicative Assembler where + pure = return + (<*>) = ap + +instance Monad Assembler where + return = NullAsm + NullAsm x >>= f = f x + AllocPtr p k >>= f = AllocPtr p (k >=> f) + AllocLit l k >>= f = AllocLit l (k >=> f) + AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) + Emit w ops k >>= f = Emit w ops (k >>= f) + +ioptr :: IO BCOPtr -> Assembler Word +ioptr p = AllocPtr p return + +ptr :: BCOPtr -> Assembler Word +ptr = ioptr . return + +lit :: [BCONPtr] -> Assembler Word +lit l = AllocLit l return + +label :: Word16 -> Assembler () +label w = AllocLabel w (return ()) + +emit :: Word16 -> [Operand] -> Assembler () +emit w ops = Emit w ops (return ()) + +type LabelEnv = Word16 -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + SmallOp _ -> False + Op w -> isLarge w + LabelOp _ -> long_jumps +-- LargeOp _ -> True + +runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a +runAsm dflags long_jumps e = go + where + go (NullAsm x) = return x + go (AllocPtr p_io k) = do + p <- lift p_io + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_p1 = addToSS st_p0 p + in (sizeSS st_p0, (st_i0,st_l0,st_p1)) + go $ k w + go (AllocLit lits k) = do + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_l1 = addListToSS st_l0 lits + in (sizeSS st_l0, (st_i0,st_l1,st_p0)) + go $ k w + go (AllocLabel _ k) = go k + go (Emit w ops k) = do + let largeOps = any (largeOp long_jumps) ops + opcode + | largeOps = largeArgInstr w + | otherwise = w + words = concatMap expand ops + expand (SmallOp w) = [w] + expand (LabelOp w) = expand (Op (e w)) + expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] +-- expand (LargeOp w) = largeArg dflags w + state $ \(st_i0,st_l0,st_p0) -> + let st_i1 = addListToSS st_i0 (opcode : words) + in ((), (st_i1,st_l0,st_p0)) + go k + +type LabelEnvMap = Map Word16 Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) +inspectAsm dflags long_jumps initial_offset + = go (InspectState initial_offset 0 0 Map.empty) + where + go s (NullAsm _) = (instrCount s, lblEnv s) + go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) + where n = ptrCount s + go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) + where n = litCount s + go s (AllocLabel lbl k) = go s' k + where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } + go s (Emit _ ops k) = go s' k + where + s' = s { instrCount = instrCount s + size } + size = sum (map count ops) + 1 + largeOps = any (largeOp long_jumps) ops + count (SmallOp _) = 1 + count (LabelOp _) = count (Op 0) + count (Op _) = if largeOps then largeArg16s dflags else 1 +-- count (LargeOp _) = largeArg16s dflags + +-- Bring in all the bci_ bytecode constants. +#include "rts/Bytecodes.h" + +largeArgInstr :: Word16 -> Word16 +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +largeArg :: DynFlags -> Word -> [Word16] +largeArg dflags w + | wORD_SIZE_IN_BITS dflags == 64 + = [fromIntegral (w `shiftR` 48), + fromIntegral (w `shiftR` 32), + fromIntegral (w `shiftR` 16), + fromIntegral w] + | wORD_SIZE_IN_BITS dflags == 32 + = [fromIntegral (w `shiftR` 16), + fromIntegral w] + | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" + +largeArg16s :: DynFlags -> Word +largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4 + | otherwise = 2 + +assembleI :: DynFlags + -> BCInstr + -> Assembler () +assembleI dflags i = case i of + STKCHECK n -> emit bci_STKCHECK [Op n] + PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] + PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] + PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_G [Op p] + PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_ALTS [Op p] + PUSH_ALTS_UNLIFTED proto pk + -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit (push_alts pk) [Op p] + PUSH_UBX (Left lit) nws -> do np <- literal lit + emit bci_PUSH_UBX [Op np, SmallOp nws] + PUSH_UBX (Right aa) nws -> do np <- addr aa + emit bci_PUSH_UBX [Op np, SmallOp nws] + + PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] + ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] + ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] + ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] + MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] + MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] + UNPACK n -> emit bci_UNPACK [SmallOp n] + PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] + emit bci_PACK [Op itbl_no, SmallOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit bci_CASEFAIL [] + SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] + JMP l -> emit bci_JMP [LabelOp l] + ENTER -> emit bci_ENTER [] + RETURN -> emit bci_RETURN [] + RETURN_UBX rep -> emit (return_ubx rep) [] + CCALL off m_addr i -> do np <- addr m_addr + emit bci_CCALL [SmallOp off, Op np, SmallOp i] + BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array) + p2 <- ptr (BCOPtrBreakInfo info) + emit bci_BRK_FUN [Op p1, SmallOp index, Op p2] + + where + literal (MachLabel fs (Just sz) _) + | platformOS (targetPlatform dflags) == OSMinGW32 + = litlabel (appendFS fs (mkFastString ('@':show sz))) + -- On Windows, stdcall labels have a suffix indicating the no. of + -- arg words, e.g. foo@8. testcase: ffi012(ghci) + literal (MachLabel fs _ _) = litlabel fs + literal (MachWord w) = int (fromIntegral w) + literal (MachInt j) = int (fromIntegral j) + literal MachNullAddr = int 0 + literal (MachFloat r) = float (fromRational r) + literal (MachDouble r) = double (fromRational r) + literal (MachChar c) = int (ord c) + literal (MachInt64 ii) = int64 (fromIntegral ii) + literal (MachWord64 ii) = int64 (fromIntegral ii) + literal other = pprPanic "ByteCodeAsm.literal" (ppr other) + + litlabel fs = lit [BCONPtrLbl fs] + addr = words . mkLitPtr + float = words . mkLitF + double = words . mkLitD dflags + int = words . mkLitI + int64 = words . mkLitI64 dflags + words ws = lit (map BCONPtrWord ws) + word w = words [w] + +isLarge :: Word -> Bool +isLarge n = n > 65535 + +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D +push_alts V16 = error "push_alts: vector" +push_alts V32 = error "push_alts: vector" +push_alts V64 = error "push_alts: vector" + +return_ubx :: ArgRep -> Word16 +return_ubx V = bci_RETURN_V +return_ubx P = bci_RETURN_P +return_ubx N = bci_RETURN_N +return_ubx L = bci_RETURN_L +return_ubx F = bci_RETURN_F +return_ubx D = bci_RETURN_D +return_ubx V16 = error "return_ubx: vector" +return_ubx V32 = error "return_ubx: vector" +return_ubx V64 = error "return_ubx: vector" + +-- Make lists of host-sized words for literals, so that when the +-- words are placed in memory at increasing addresses, the +-- bit pattern is correct for the host's word size and endianness. +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: DynFlags -> Double -> [Word] +mkLitPtr :: Ptr () -> [Word] +mkLitI64 :: DynFlags -> Int64 -> [Word] + +mkLitF f + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 f + f_arr <- castSTUArray arr + w0 <- readArray f_arr 0 + return [w0 :: Word] + ) + +mkLitD dflags d + | wORD_SIZE dflags == 4 + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word, w1] + ) + | wORD_SIZE dflags == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + | otherwise + = panic "mkLitD: Bad wORD_SIZE" + +mkLitI64 dflags ii + | wORD_SIZE dflags == 4 + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] + ) + | wORD_SIZE dflags == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + | otherwise + = panic "mkLitI64: Bad wORD_SIZE" + +mkLitI i + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 i + i_arr <- castSTUArray arr + w0 <- readArray i_arr 0 + return [w0 :: Word] + ) + +mkLitPtr a + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 a + a_arr <- castSTUArray arr + w0 <- readArray a_arr 0 + return [w0 :: Word] + ) + +iNTERP_STACK_CHECK_THRESH :: Int +iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs new file mode 100644 index 00000000..de5b84e4 --- /dev/null +++ b/compiler/ghci/ByteCodeGen.hs @@ -0,0 +1,1688 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | ByteCodeGen: Generate bytecode from Core +module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where + +#include "HsVersions.h" + +import ByteCodeInstr +import ByteCodeItbls +import ByteCodeAsm +import ByteCodeLink +import LibFFI + +import DynFlags +import Outputable +import Platform +import Name +import MkId +import Id +import ForeignCall +import HscTypes +import CoreUtils +import CoreSyn +import PprCore +import Literal +import PrimOp +import CoreFVs +import Type +import DataCon +import TyCon +import Util +import VarSet +import TysPrim +import ErrUtils +import Unique +import FastString +import Panic +import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW ) +import SMRep +import Bitmap +import OrdList + +import Data.List +import Foreign +import Foreign.C + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif +import Control.Monad +import Data.Char + +import UniqSupply +import BreakArray +import Data.Maybe +import Module + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map +import Data.Ord + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module + +byteCodeGen :: DynFlags + -> Module + -> CoreProgram + -> [TyCon] + -> ModBreaks + -> IO CompiledByteCode +byteCodeGen dflags this_mod binds tycs modBreaks + = do showPass dflags "ByteCodeGen" + + let flatBinds = [ (bndr, freeVars rhs) + | (bndr, rhs) <- flattenBinds binds] + + us <- mkSplitUniqSupply 'y' + (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos) + <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds) + + when (notNull mallocd) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) + + assembleBCOs dflags proto_bcos tycs + +-- ----------------------------------------------------------------------------- +-- Generating byte code for an expression + +-- Returns: (the root BCO for this expression, +-- a list of auxilary BCOs resulting from compiling closures) +coreExprToBCOs :: DynFlags + -> Module + -> CoreExpr + -> IO UnlinkedBCO +coreExprToBCOs dflags this_mod expr + = do showPass dflags "ByteCodeGen" + + -- create a totally bogus name for the top-level BCO; this + -- should be harmless, since it's never used for anything + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") + invented_id = Id.mkLocalId invented_name (panic "invented_id's type") + + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco) + <- runBc dflags us this_mod emptyModBreaks $ + schemeTopBind (invented_id, freeVars expr) + + when (notNull mallocd) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) + + assembleBCO dflags proto_bco + + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr + +type Sequel = Word -- back off to this depth before ENTER + +-- Maps Ids to the offset from the stack _base_ so we don't have +-- to mess with it after each push/pop. +type BCEnv = Map Id Word -- To find vars on the stack + +{- +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) + $$ text "end-env" + where + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var) + cmp_snd x y = compare (snd x) (snd y) +-} + +-- Create a BCO and do a spot of peephole optimisation on the insns +-- at the same time. +mkProtoBCO + :: DynFlags + -> name + -> BCInstrList + -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet) + -> Int + -> Word16 + -> [StgWord] + -> Bool -- True <=> is a return point, rather than a function + -> [BcPtr] + -> ProtoBCO name +mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOPtrs = mallocd_blocks + } + where + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit one in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : peep_d + | otherwise + = peep_d -- the supposedly common case + + -- We assume that this sum doesn't wrap + stack_usage = sum (map bciStackUse peep_d) + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) + = PUSH_LLL off1 (off2-1) (off3-2) : peep rest + peep (PUSH_L off1 : PUSH_L off2 : rest) + = PUSH_LL off1 (off2-1) : peep rest + peep (i:rest) + = i : peep rest + peep [] + = [] + +argBits :: DynFlags -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits dflags (rep : args) + | isFollowableArg rep = False : argBits dflags args + | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding + +schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) + + +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do + dflags <- getDynFlags + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. + -- ioToBc (putStrLn $ "top level BCO") + emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (id, rhs) + + +-- ----------------------------------------------------------------------------- +-- schemeR + +-- Compile code for a right-hand side, to give a BCO that, +-- when executed with the free variables and arguments on top of the stack, +-- will return with a pointer to the result on top of the stack, after +-- removing the free variables and arguments. +-- +-- Park the resulting BCO in the monad. Also requires the +-- variable to which this value was bound, so as to give the +-- resulting BCO a name. + +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Id, AnnExpr Id VarSet) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined + | otherwise +-} + = schemeR_wrk fvs nm rhs (collect rhs) + +collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) +collect (_, e) = go [] e + where + go xs e | Just e' <- bcView e = go xs e' + go xs (AnnLam x (_,e)) + | UbxTupleRep _ <- repType (idType x) + = unboxedTupleException + | otherwise + = go (x:xs) e + go xs not_lambda = (reverse xs, not_lambda) + +schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) +schemeR_wrk fvs nm original_body (args, body) + = do + dflags <- getDynFlags + let + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first + + szsw_args = map (fromIntegral . idSizeW dflags) all_args + szw_args = sum szsw_args + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) + + -- make the arg bitmap + bits = argBits dflags (reverse (map bcIdArgRep all_args)) + bitmap_size = genericLength bits + bitmap = mkBitmap dflags bits + body_code <- schemeER_wrk szw_args p_init body + + emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) + +-- introduce break instructions for ticked expressions +schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeER_wrk d p rhs + | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs + = do code <- schemeE (fromIntegral d) 0 p newRhs + arr <- getBreakArray + this_mod <- getCurrentModule + let idOffSets = getVarOffSets d p fvs + let breakInfo = BreakInfo + { breakInfo_module = this_mod + , breakInfo_number = tick_no + , breakInfo_vars = idOffSets + , breakInfo_resty = exprType (deAnnotate' newRhs) + } + let breakInstr = case arr of + BA arr# -> + BRK_FUN arr# (fromIntegral tick_no) breakInfo + return $ breakInstr `consOL` code + | otherwise = schemeE (fromIntegral d) 0 p rhs + +getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)] +getVarOffSets d p = catMaybes . map (getOffSet d p) + +getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16) +getOffSet d env id + = case lookupBCEnv_maybe id env of + Nothing -> Nothing + Just offset -> Just (id, trunc16 $ d - offset) + +trunc16 :: Word -> Word16 +trunc16 w + | w > fromIntegral (maxBound :: Word16) + = panic "stack depth overflow" + | otherwise + = fromIntegral w + +fvsToEnv :: BCEnv -> VarSet -> [Id] +-- Takes the free variables of a right-hand side, and +-- delivers an ordered list of the local variables that will +-- be captured in the thunk for the RHS +-- The BCEnv argument tells which variables are in the local +-- environment: these are the ones that should be captured +-- +-- The code that constructs the thunk, and the code that executes +-- it, have to agree about this layout +fvsToEnv p fvs = [v | v <- varSetElems fvs, + isId v, -- Could be a type variable + v `Map.member` p] + +-- ----------------------------------------------------------------------------- +-- schemeE + +returnUnboxedAtom :: Word -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> ArgRep + -> BcM BCInstrList +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnboxedAtom d s p e e_rep + = do (push, szw) <- pushAtom d p e + return (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX e_rep) -- go + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList + +schemeE d s p e + | Just e' <- bcView e + = schemeE d s p e' + +-- Delegate tail-calls to schemeT. +schemeE d s p e@(AnnApp _ _) = schemeT d s p e + +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V + +schemeE d s p e@(AnnVar v) + | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) + | otherwise = schemeT d s p e + +schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) + | (AnnVar v, args_r_to_l) <- splitApp rhs, + Just data_con <- isDataConWorkId_maybe v, + dataConRepArity data_con == length args_r_to_l + = do -- Special case for a non-recursive let whose RHS is a + -- saturatred constructor application. + -- Just allocate the constructor and carry on + alloc_code <- mkConAppCode d s p data_con args_r_to_l + body_code <- schemeE (d+1) s (Map.insert x d p) body + return (alloc_code `appOL` body_code) + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (AnnLet binds (_,body)) = do + dflags <- getDynFlags + let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) + AnnRec xs_n_rhss -> unzip xs_n_rhss + n_binds = genericLength xs + + fvss = map (fvsToEnv p' . fst) rhss + + -- Sizes of free vars + sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (genericLength . fst . collect) rhss + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1. d' and p' reflect the stack + -- after the closures have been allocated in the heap (but not + -- filled in), and pointers to them parked on the stack. + p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p + d' = d + fromIntegral n_binds + zipE = zipEqual "schemeE" + + -- ToDo: don't build thunks for things with no free variables + build_thunk _ [] size bco off arity + = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do + (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) + more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity + return (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD sz + | otherwise = ALLOC_AP sz + mkAlloc sz arity = ALLOC_PAP arity sz + + is_tick = case binds of + AnnNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x rhs size arity off = do + bco <- schemeR fvs (x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +-- introduce a let binding for a ticked case expression. This rule +-- *should* only fire when the expression was not already let-bound +-- (the code gen for let bindings should take care of that). Todo: we +-- call exprFreeVars on a deAnnotated expression, this may not be the +-- best way to calculate the free vars but it seemed like the least +-- intrusive thing to do +schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) + = if isUnLiftedType ty + then do + -- If the result type is unlifted, then we must generate + -- let f = \s . tick e + -- in f realWorld# + -- When we stop at the breakpoint, _result will have an unlifted + -- type and hence won't be bound in the environment, but the + -- breakpoint will otherwise work fine. + id <- newId (mkFunTy realWorldStatePrimTy ty) + st <- newId realWorldStatePrimTy + let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp))) + (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) + (emptyVarSet, AnnVar realWorldPrimId))) + schemeE d s p letExp + else do + id <- newId ty + -- Todo: is emptyVarSet correct on the next line? + let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id) + schemeE d s p letExp + where exp' = deAnnotate' exp + fvs = exprFreeVars exp' + ty = exprType exp' + +-- ignore other kinds of tick +schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs + +schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut + -- no alts: scrut is guaranteed to diverge + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc + , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2) + -- Convert + -- case .... of x { (# V'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. + , Just res <- case () of + _ | VoidRep <- typePrimRep rep_ty1 + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | VoidRep <- typePrimRep rep_ty2 + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | otherwise + -> Nothing + = res + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1) + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + = --trace "automagic mashing of case alts (# a #)" $ + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + +schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)]) + | Just (tc, tys) <- splitTyConApp_maybe (idType bndr) + , isUnboxedTupleTyCon tc + , Just res <- case tys of + [ty] | UnaryRep _ <- repType ty + , let bind = bndr `setIdType` ty + -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1 + , UnaryRep rep_ty2 <- repType ty2 + -> case () of + _ | VoidRep <- typePrimRep rep_ty1 + , let bind2 = bndr `setIdType` ty2 + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | VoidRep <- typePrimRep rep_ty2 + , let bind1 = bndr `setIdType` ty1 + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + | otherwise + -> Nothing + _ -> Nothing + = res + +schemeE d s p (AnnCase scrut bndr _ alts) + = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} + +schemeE _ _ _ expr + = pprPanic "ByteCodeGen.schemeE: unhandled case" + (pprCoreExpr (deAnnotate' expr)) + +{- + Ticked Expressions + ------------------ + + The idea is that the "breakpoint E" is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression E. + +-} + +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "GHC.Prim.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. The fn denotes a ccall. Defer to generateCCall. +-- +-- 2. (Another nasty hack). Spot (# a::V, b #) and treat +-- it simply as b -- since the representations are identical +-- (the V takes up zero stack space). Also, spot +-- (# b #) and treat it as b. +-- +-- 3. Application of a constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 4. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: Word -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> AnnExpr' Id VarSet + -> BcM BCInstrList + +schemeT d s p app + +-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False +-- = panic "schemeT ?!?!" + +-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False +-- = error "?!?!" + + -- Case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = generateCCall d s p ccall_spec fn args_r_to_l + + -- Case 2: Constructor application + | Just con <- maybe_saturated_dcon, + isUnboxedTupleCon con + = case args_r_to_l of + [arg1,arg2] | isVAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> unboxedTupleException + + -- Case 3: Ordinary data constructor + | Just con <- maybe_saturated_dcon + = do alloc_con <- mkConAppCode d s p con args_r_to_l + return (alloc_con `appOL` + mkSLIDE 1 (d - s) `snocOL` + ENTER) + + -- Case 4: Tail call of function + | otherwise + = doTailCall d s p fn args_r_to_l + + where + -- Extract the args (R->L) and fn + -- The function will necessarily be a variable, + -- because we are compiling a tail call + (AnnVar fn, args_r_to_l) = splitApp app + + -- Only consider this to be a constructor application iff it is + -- saturated. Otherwise, we'll call the constructor wrapper. + n_args = length args_r_to_l + maybe_saturated_dcon + = case isDataConWorkId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing + +-- ----------------------------------------------------------------------------- +-- Generate code to build a constructor application, +-- leaving it on top of the stack + +mkConAppCode :: Word -> Sequel -> BCEnv + -> DataCon -- The data constructor + -> [AnnExpr' Id VarSet] -- Args, in *reverse* order + -> BcM BCInstrList + +mkConAppCode _ _ _ con [] -- Nullary constructor + = ASSERT( isNullaryRepDataCon con ) + return (unitOL (PUSH_G (getName (dataConWorkId con)))) + -- Instead of doing a PACK, which would allocate a fresh + -- copy of this constructor, use the single shared version. + +mkConAppCode orig_d _ p con args_r_to_l + = ASSERT( dataConRepArity con == length args_r_to_l ) + do_pushery orig_d (non_ptr_args ++ ptr_args) + where + -- The args are already in reverse order, which is the way PACK + -- expects them to be. We must push the non-ptrs after the ptrs. + (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l + + do_pushery d (arg:args) + = do (push, arg_words) <- pushAtom d p arg + more_push_code <- do_pushery (d + fromIntegral arg_words) args + return (push `appOL` more_push_code) + do_pushery d [] + = return (unitOL (PACK con n_arg_words)) + where + n_arg_words = trunc16 $ d - orig_d + + +-- ----------------------------------------------------------------------------- +-- Returning an unboxed tuple with one non-void component (the only +-- case we can handle). +-- +-- Remember, we don't want to *evaluate* the component that is being +-- returned, even if it is a pointed type. We always just return. + +unboxedTupleReturn + :: Word -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> BcM BCInstrList +unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: Word -> Sequel -> BCEnv + -> Id -> [AnnExpr' Id VarSet] + -> BcM BCInstrList +doTailCall init_d s p fn args + = do_pushes init_d args (map atomRep args) + where + do_pushes d [] reps = do + ASSERT( null reps ) return () + (push_fn, sz) <- pushAtom d p (AnnVar fn) + ASSERT( sz == 1 ) return () + return (push_fn `appOL` ( + mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL` + unitOL ENTER)) + do_pushes d args reps = do + let (push_apply, n, rest_of_reps) = findPushSeq reps + (these_args, rest_of_args) = splitAt n args + (next_d, push_code) <- push_seq d these_args + instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + return (push_code `appOL` (push_apply `consOL` instrs)) + + push_seq d [] = return (d, nilOL) + push_seq d (arg:args) = do + (push_code, sz) <- pushAtom d p arg + (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args + return (final_d, push_code `appOL` more_push_code) + +-- v. similar to CgStackery.findMatch, ToDo: merge +findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (P: P: P: P: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (P: P: P: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (P: P: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (P: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (V: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (N: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (F: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (D: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (L: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq _ + = panic "ByteCodeGen.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +doCase :: Word -> Sequel -> BCEnv + -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] + -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) bndr alts is_unboxed_tuple + | UbxTupleRep _ <- repType (idType bndr) + = unboxedTupleException + | otherwise + = do + dflags <- getDynFlags + let + -- Top of stack is the return itbl, as usual. + -- underneath it is the pointer to the alt_code BCO. + -- When an alt is entered, it assumes the returned value is + -- on top of the itbl. + ret_frame_sizeW :: Word + ret_frame_sizeW = 2 + + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_sizeW :: Word + unlifted_itbl_sizeW | isAlgCase = 0 + | otherwise = 1 + + -- depth of stack after the return value has been pushed + d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr) + + -- depth of stack after the extra info table for an unboxed return + -- has been pushed, if any. This is the stack depth at the + -- continuation. + d_alts = d_bndr + unlifted_itbl_sizeW + + -- Env in which to compile the alts, not including + -- any vars bound by the alts themselves + d_bndr' = fromIntegral d_bndr - 1 + p_alts0 = Map.insert bndr d_bndr' p + p_alts = case is_unboxed_tuple of + Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0 + Nothing -> p_alts0 + + bndr_ty = idType bndr + isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple + + -- given an alt, return a discr and code for it. + codeAlt (DEFAULT, _, (_,rhs)) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) + + codeAlt alt@(_, bndrs, (_,rhs)) + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs + return (my_discr alt, rhs_code) + | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs + = unboxedTupleException + -- algebraic alt with some binders + | otherwise = + let + (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs + ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs + nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs + bind_sizes = ptr_sizes ++ nptrs_sizes + size = sum ptr_sizes + sum nptrs_sizes + -- the UNPACK instruction unpacks in reverse order... + p' = Map.insertList + (zip (reverse (ptrs ++ nptrs)) + (mkStackOffsets d_alts (reverse bind_sizes))) + p_alts + in do + MASSERT(isAlgCase) + rhs_code <- schemeE (d_alts + size) s p' rhs + return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code) + where + real_bndrs = filterOut isTyVar bndrs + + my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} + my_discr (DataAlt dc, _, _) + | isUnboxedTupleCon dc + = unboxedTupleException + | otherwise + = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) + my_discr (LitAlt l, _, _) + = case l of MachInt i -> DiscrI (fromInteger i) + MachWord w -> DiscrW (fromInteger w) + MachFloat r -> DiscrF (fromRational r) + MachDouble r -> DiscrD (fromRational r) + MachChar i -> DiscrI (ord i) + _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) + + maybe_ncons + | not isAlgCase = Nothing + | otherwise + = case [dc | (DataAlt dc, _, _) <- alts] of + [] -> Nothing + (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) + + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + bitmap_size = trunc16 $ d-s + bitmap_size' :: Int + bitmap_size' = fromIntegral bitmap_size + bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} + (sort (filter (< bitmap_size') rel_slots)) + where + binds = Map.toList p + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + rel_slots = nub $ map fromIntegral $ concat (map spread binds) + spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = trunc16 $ d - fromIntegral offset - 1 + + alt_stuff <- mapM codeAlt alts + alt_final <- mkMultiBranch maybe_ncons alt_stuff + + let + alt_bco_name = getName bndr + alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) + 0{-no arity-} bitmap_size bitmap True{-is alts-} +-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ +-- "\n bitmap = " ++ show bitmap) $ do + scrut_code <- schemeE (d + ret_frame_sizeW) + (d + ret_frame_sizeW) + p scrut + alt_bco' <- emitBc alt_bco + let push_alts + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) + return (push_alts `consOL` scrut_code) + + +-- ----------------------------------------------------------------------------- +-- Deal with a CCall. + +-- Taggedly push the args onto the stack R->L, +-- deferencing ForeignObj#s and adjusting addrs to point to +-- payloads in Ptr/Byte arrays. Then, generate the marshalling +-- (machine) code for the ccall, and create bytecodes to call that and +-- then return in the right way. + +generateCCall :: Word -> Sequel -- stack and sequel depths + -> BCEnv + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr' Id VarSet] -- args (atoms) + -> BcM BCInstrList + +generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + = do + dflags <- getDynFlags + + let + -- useful constants + addr_sizeW :: Word16 + addr_sizeW = fromIntegral (argRepSizeW dflags N) + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- ArgRep of what was actually pushed. + + pargs _ [] = return [] + pargs d (a:az) + = let UnaryRep arg_ty = repType (exprType (deAnnotate' a)) + + in case tyConAppTyCon_maybe arg_ty of + -- Don't push the FO; instead push the Addr# it + -- contains. + Just t + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + -> do rest <- pargs (d + fromIntegral addr_sizeW) az + code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon + -> do rest <- pargs (d + fromIntegral addr_sizeW) az + code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + -> do rest <- pargs (d + fromIntegral addr_sizeW) az + code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + -- Default case: push taggedly, but otherwise intact. + _ + -> do (code_a, sz_a) <- pushAtom d p a + rest <- pargs (d + fromIntegral sz_a) az + return ((code_a, atomPrimRep a) : rest) + + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet + -> BcM BCInstrList + parg_ArrayishRep hdrSize d p a + = do (push_fo, _) <- pushAtom d p a + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + return (push_fo `snocOL` SWIZZLE 0 hdrSize) + + code_n_reps <- pargs d0 args_r_to_l + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l)) + + push_args = concatOL pushs_arg + d_after_args = d0 + a_reps_sizeW + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + = panic "ByteCodeGen.generateCCall: missing or invalid World token?" + | otherwise + = reverse (tail a_reps_pushed_r_to_l) + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + (returns_void, r_rep) + = case maybe_getCCallReturnRep (idType fn) of + Nothing -> (True, VoidRep) + Just rr -> (False, rr) + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshall code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshall_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + get_target_info = do + case target of + DynamicTarget + -> return (False, panic "ByteCodeGen.generateCCall(dyn)") + + StaticTarget _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget target _ True + -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) + return (True, res) + where + stdcall_adj_target + | OSMinGW32 <- platformOS (targetPlatform dflags) + , StdCallConv <- cconv + = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in + mkFastString (unpackFS target ++ '@':show size) + | otherwise + = target + + (is_static, static_target_addr) <- get_target_info + let + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW + then panic "ByteCodeGen.generateCCall: dyn with no args" + else tail a_reps_pushed_RAW + + -- push the Addr# + (push_Addr, d_after_Addr) + | is_static + = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW], + d_after_args + fromIntegral addr_sizeW) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a V (tag). + r_sizeW = fromIntegral (primRepSizeW dflags r_rep) + d_after_r = d_after_Addr + fromIntegral r_sizeW + r_lit = mkDummyLiteral r_rep + push_r = (if returns_void + then nilOL + else unitOL (PUSH_UBX (Left r_lit) r_sizeW)) + + -- generate the marshalling code we're going to call + + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = trunc16 $ d_after_r - s + + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep + let addr_of_marshaller = castPtrToFunPtr token + + recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) + let + -- do the call + do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller) + (fromIntegral (fromEnum (playInterruptible safety)))) + -- slide and return + wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s) + `snocOL` RETURN_UBX (toArgRep r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ + return ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral pr + = case pr of + IntRep -> MachInt 0 + WordRep -> MachWord 0 + AddrRep -> MachNullAddr + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + Int64Rep -> MachInt64 0 + Word64Rep -> MachWord64 0 + _ -> panic "mkDummyLiteral" + + +-- Convert (eg) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +-- +-- to Just IntRep +-- and check that an unboxed pair is returned wherein the first arg is V'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) +-- +-- to Nothing + +maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep fn_ty + = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + maybe_r_rep_to_go + = if isSingleton r_reps then Nothing else Just (r_reps !! 1) + r_reps = case repType r_ty of + UbxTupleRep reps -> map typePrimRep reps + UnaryRep _ -> blargh + ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) + || r_reps == [VoidRep] ) + && case maybe_r_rep_to_go of + Nothing -> True + Just r_rep -> r_rep /= PtrRep + -- if it was, it would be impossible + -- to create a valid return value + -- placeholder on the stack + + blargh :: a -- Used at more than one type + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + in + --trace (showSDoc (ppr (a_reps, r_reps))) $ + if ok then maybe_r_rep_to_go else blargh + +maybe_is_tagToEnum_call :: AnnExpr' Id VarSet -> Maybe (AnnExpr' Id VarSet, [Name]) +-- Detect and extract relevant info for the tagToEnum kludge. +maybe_is_tagToEnum_call app + | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app + , Just TagToEnumOp <- isPrimOpId_maybe v + = Just (snd arg, extract_constr_Names t) + | otherwise + = Nothing + where + extract_constr_Names ty + | UnaryRep rep_ty <- repType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty, + isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.lhs for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) + +{- ----------------------------------------------------------------------------- +Note [Implementing tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(implement_tagToId arg names) compiles code which takes an argument +'arg', (call it i), and enters the i'th closure in the supplied list +as a consequence. The [Name] is a list of the constructors of this +(enumeration) type. + +The code we generate is this: + push arg + push bogus-word + + TESTEQ_I 0 L1 + PUSH_G + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G + JMP L_Exit + + L_fail: CASEFAIL + + L_exit: SLIDE 1 n + ENTER + +The 'bogus-word' push is because TESTEQ_I expects the top of the stack +to have an info-table, and the next word to have the value to be +tested. This is very weird, but it's the way it is right now. See +Interpreter.c. We don't acutally need an info-table here; we just +need to have the argument to be one-from-top on the stack, hence pushing +a 1-word null. See Trac #8383. +-} + + +implement_tagToId :: Word -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> [Name] -> BcM BCInstrList +-- See Note [Implementing tagToEnum#] +implement_tagToId d s p arg names + = ASSERT( notNull names ) + do (push_arg, arg_words) <- pushAtom d p arg + labels <- getLabelsBc (genericLength names) + label_fail <- getLabelBc + label_exit <- getLabelBc + let infos = zip4 labels (tail labels ++ [label_fail]) + [0 ..] names + steps = map (mkStep label_exit) infos + + return (push_arg + `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1) + -- Push bogus word (see Note [Implementing tagToEnum#]) + `appOL` concatOL steps + `appOL` toOL [ LABEL label_fail, CASEFAIL, + LABEL label_exit ] + `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1) + -- "+1" to account for bogus word + -- (see Note [Implementing tagToEnum#]) + `appOL` unitOL ENTER) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, + JMP l_exit] + + +-- ----------------------------------------------------------------------------- +-- pushAtom + +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +-- +-- The env p must map each variable to the highest- numbered stack +-- slot for it. For example, if the stack has depth 4 and we +-- tagged-ly push (v :: Int#) on it, the value will be in stack[4], +-- the tag in stack[5], the stack will have depth 6, and p must map v +-- to 5 and not to 4. Stack locations are numbered from zero, so a +-- depth 6 stack has valid words 0 .. 5. + +pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16) + +pushAtom d p e + | Just e' <- bcView e + = pushAtom d p e' + +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable V + +pushAtom d p (AnnVar v) + | UnaryRep rep_ty <- repType (idType v) + , V <- typeArgRep rep_ty + = return (nilOL, 0) + + | isFCallId v + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) + + | Just primop <- isPrimOpId_maybe v + = return (unitOL (PUSH_PRIMOP primop), 1) + + | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + l = trunc16 $ d - d_v + fromIntegral sz - 2 + return (toOL (genericReplicate sz (PUSH_L l)), sz) + -- d - d_v the number of words between the TOS + -- and the 1st slot of the object + -- + -- d - d_v - 1 the offset from the TOS of the 1st slot + -- + -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot + -- of the object. + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. + + | otherwise -- v must be a global variable + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + MASSERT(sz == 1) + return (unitOL (PUSH_G (getName v)), sz) + + +pushAtom _ _ (AnnLit lit) = do + dflags <- getDynFlags + let code rep + = let size_host_words = fromIntegral (argRepSizeW dflags rep) + in return (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) + + case lit of + MachLabel _ _ _ -> code N + MachWord _ -> code N + MachInt _ -> code N + MachWord64 _ -> code L + MachInt64 _ -> code L + MachFloat _ -> code F + MachDouble _ -> code D + MachChar _ -> code N + MachNullAddr -> code N + MachStr s -> pushStr s + -- No LitInteger's should be left by the time this is called. + -- CorePrep should have converted them all to a real core + -- representation. + LitInteger {} -> panic "pushAtom: LitInteger" + where + pushStr s + = let getMallocvilleAddr + = + -- we could grab the Ptr from the ForeignPtr, + -- but then we have no way to control its lifetime. + -- In reality it'll probably stay alive long enoungh + -- by virtue of the global FastString table, but + -- to be on the safe side we copy the string into + -- a malloc'd area of memory. + do let n = BS.length s + ptr <- ioToBc (mallocBytes (n+1)) + recordMallocBc ptr + ioToBc ( + BS.unsafeUseAsCString s $ \p -> do + memcpy ptr p (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + return ptr + ) + in do + addr <- getMallocvilleAddr + -- Get the addr on the stack, untaggedly + return (unitOL (PUSH_UBX (Right addr) 1), 1) + +pushAtom _ _ expr + = pprPanic "ByteCodeGen.pushAtom" + (pprCoreExpr (deAnnotate (undefined, expr))) + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr b -> CSize -> IO () + + +-- ----------------------------------------------------------------------------- +-- Given a bunch of alts code and their discrs, do the donkey work +-- of making a multiway branch using a switch tree. +-- What a load of hassle! + +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] + -> BcM BCInstrList +mkMultiBranch maybe_ncons raw_ways = do + lbl_default <- getLabelBc + + let + mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList + mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) + -- shouldn't happen? + + mkTree [val] range_lo range_hi + | range_lo == range_hi + = return (snd val) + | null defaults -- Note [CASEFAIL] + = do lbl <- getLabelBc + return (testEQ (fst val) lbl + `consOL` (snd val + `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) + | otherwise + = return (testEQ (fst val) lbl_default `consOL` snd val) + + -- Note [CASEFAIL] It may be that this case has no default + -- branch, but the alternatives are not exhaustive - this + -- happens for GADT cases for example, where the types + -- prove that certain branches are impossible. We could + -- just assume that the other cases won't occur, but if + -- this assumption was wrong (because of a bug in GHC) + -- then the result would be a segfault. So instead we + -- emit an explicit test and a CASEFAIL instruction that + -- causes the interpreter to barf() if it is ever + -- executed. + + mkTree vals range_lo range_hi + = let n = length vals `div` 2 + vals_lo = take n vals + vals_hi = drop n vals + v_mid = fst (head vals_hi) + in do + label_geq <- getLabelBc + code_lo <- mkTree vals_lo range_lo (dec v_mid) + code_hi <- mkTree vals_hi v_mid range_hi + return (testLT v_mid label_geq + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default + = case defaults of + [] -> nilOL + [(_, def)] -> LABEL lbl_default `consOL` def + _ -> panic "mkMultiBranch/the_default" + instrs <- mkTree notd_ways init_lo init_hi + return (instrs `appOL` the_default) + where + (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways + notd_ways = sortBy (comparing fst) not_defaults + + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + + -- None of these will be needed if there are no non-default alts + (init_lo, init_hi) + | null notd_ways + = panic "mkMultiBranch: awesome foursome" + | otherwise + = case fst (head notd_ways) of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" + + (algMinBound, algMaxBound) + = case maybe_ncons of + -- XXX What happens when n == 0? + Just n -> (0, fromIntegral n - 1) + Nothing -> (minBound, maxBound) + + isNoDiscr NoDiscr = True + isNoDiscr _ = False + + dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-1) + dec (DiscrP i) = DiscrP (i-1) + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve + + -- same snotty comment applies to the following + minF, maxF :: Float + minD, maxD :: Double + minF = -1.0e37 + maxF = 1.0e37 + minD = -1.0e308 + maxD = 1.0e308 + + +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrW Word + | DiscrF Float + | DiscrD Double + | DiscrP Word16 + | NoDiscr + deriving (Eq, Ord) + +instance Outputable Discr where + ppr (DiscrI i) = int i + ppr (DiscrW w) = text (show w) + ppr (DiscrF f) = text (show f) + ppr (DiscrD d) = text (show d) + ppr (DiscrP i) = ppr i + ppr NoDiscr = text "DEF" + + +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word +lookupBCEnv_maybe = Map.lookup + +idSizeW :: DynFlags -> Id -> Int +idSizeW dflags = argRepSizeW dflags . bcIdArgRep + +bcIdArgRep :: Id -> ArgRep +bcIdArgRep = toArgRep . bcIdPrimRep + +bcIdPrimRep :: Id -> PrimRep +bcIdPrimRep = typePrimRep . bcIdUnaryType + +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +isVoidArg :: ArgRep -> Bool +isVoidArg V = True +isVoidArg _ = False + +bcIdUnaryType :: Id -> UnaryType +bcIdUnaryType x = case repType (idType x) of + UnaryRep rep_ty -> rep_ty + UbxTupleRep [rep_ty] -> rep_ty + UbxTupleRep [rep_ty1, rep_ty2] + | VoidRep <- typePrimRep rep_ty1 -> rep_ty2 + | VoidRep <- typePrimRep rep_ty2 -> rep_ty1 + _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x)) + +-- See bug #1257 +unboxedTupleException :: a +unboxedTupleException + = throwGhcException + (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples.\n"++ + " Possibly due to foreign import/export decls in source.\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + + +mkSLIDE :: Word16 -> Word -> OrdList BCInstr +mkSLIDE n d + -- if the amount to slide doesn't fit in a word, + -- generate multiple slide instructions + | d > fromIntegral limit + = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit) + | d == 0 + = nilOL + | otherwise + = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d) + where + limit :: Word16 + limit = maxBound + +splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) + -- The arguments are returned in *right-to-left* order +splitApp e | Just e' <- bcView e = splitApp e' +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) + + +bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) +-- The "bytecode view" of a term discards +-- a) type abstractions +-- b) type applications +-- c) casts +-- d) ticks (but not breakpoints) +-- Type lambdas *can* occur in random expressions, +-- whereas value lambdas cannot; that is why they are nuked here +bcView (AnnCast (_,e) _) = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView (AnnTick Breakpoint{} _) = Nothing +bcView (AnnTick _other_tick (_,e)) = Just e +bcView _ = Nothing + +isVAtom :: AnnExpr' Var ann -> Bool +isVAtom e | Just e' <- bcView e = isVAtom e' +isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) +isVAtom (AnnCoercion {}) = True +isVAtom _ = False + +atomPrimRep :: AnnExpr' Id ann -> PrimRep +atomPrimRep e | Just e' <- bcView e = atomPrimRep e' +atomPrimRep (AnnVar v) = bcIdPrimRep v +atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnCoercion {}) = VoidRep +atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) + +atomRep :: AnnExpr' Id ann -> ArgRep +atomRep e = toArgRep (atomPrimRep e) + +isPtrAtom :: AnnExpr' Id ann -> Bool +isPtrAtom e = isFollowableArg (atomRep e) + +-- Let szsw be the sizes in words of some items pushed onto the stack, +-- which has initial depth d'. Return the values which the stack environment +-- should map these items to. +mkStackOffsets :: Word -> [Word] -> [Word] +mkStackOffsets original_depth szsw + = map (subtract 1) (tail (scanl (+) original_depth szsw)) + +typeArgRep :: Type -> ArgRep +typeArgRep = toArgRep . typePrimRep + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad + +type BcPtr = Either ItblPtr (Ptr ()) + +data BcM_State + = BcM_State + { bcm_dflags :: DynFlags + , uniqSupply :: UniqSupply -- for generating fresh variable names + , thisModule :: Module -- current module (for breakpoints) + , nextlabel :: Word16 -- for generating local labels + , malloced :: [BcPtr] -- thunks malloced for current BCO + -- Should be free()d when it is GCd + , breakArray :: BreakArray -- array of breakpoint flags + } + +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) + +ioToBc :: IO a -> BcM a +ioToBc io = BcM $ \st -> do + x <- io + return (st, x) + +runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r + -> IO (BcM_State, r) +runBc dflags us this_mod modBreaks (BcM m) + = m (BcM_State dflags us this_mod 0 [] breakArray) + where + breakArray = modBreaks_flags modBreaks + +thenBc :: BcM a -> (a -> BcM b) -> BcM b +thenBc (BcM expr) cont = BcM $ \st0 -> do + (st1, q) <- expr st0 + let BcM k = cont q + (st2, r) <- k st1 + return (st2, r) + +thenBc_ :: BcM a -> BcM b -> BcM b +thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do + (st1, _) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) + +returnBc :: a -> BcM a +returnBc result = BcM $ \st -> (return (st, result)) + +instance Functor BcM where + fmap = liftM + +instance Applicative BcM where + pure = return + (<*>) = ap + +instance Monad BcM where + (>>=) = thenBc + (>>) = thenBc_ + return = returnBc + +instance HasDynFlags BcM where + getDynFlags = BcM $ \st -> return (st, bcm_dflags st) + +emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) + +recordMallocBc :: Ptr a -> BcM () +recordMallocBc a + = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ()) + +recordItblMallocBc :: ItblPtr -> BcM () +recordItblMallocBc a + = BcM $ \st -> return (st{malloced = Left a : malloced st}, ()) + +getLabelBc :: BcM Word16 +getLabelBc + = BcM $ \st -> do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (st{nextlabel = nl + 1}, nl) + +getLabelsBc :: Word16 -> BcM [Word16] +getLabelsBc n + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + +getBreakArray :: BcM BreakArray +getBreakArray = BcM $ \st -> return (st, breakArray st) + +newUnique :: BcM Unique +newUnique = BcM $ + \st -> case takeUniqFromSupply (uniqSupply st) of + (uniq, us) -> let newState = st { uniqSupply = us } + in return (newState, uniq) + +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \st -> return (st, thisModule st) + +newId :: Type -> BcM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal tickFS uniq ty + +tickFS :: FastString +tickFS = fsLit "ticked" diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs new file mode 100644 index 00000000..fee15bbf --- /dev/null +++ b/compiler/ghci/ByteCodeInstr.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | ByteCodeInstrs: Bytecode instruction definitions +module ByteCodeInstr ( + BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) + ) where + +#include "HsVersions.h" +#include "../includes/MachDeps.h" + +import ByteCodeItbls ( ItblPtr ) + +import StgCmmLayout ( ArgRep(..) ) +import PprCore +import Type +import Outputable +import FastString +import Name +import Id +import CoreSyn +import Literal +import DataCon +import VarSet +import PrimOp +import SMRep + +import Module (Module) +import GHC.Exts +import Data.Word + +-- ---------------------------------------------------------------------------- +-- Bytecode instructions + +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from + protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), + -- malloc'd pointers + protoBCOPtrs :: [Either ItblPtr (Ptr ())] + } + +type LocalLabel = Word16 + +data BCInstr + -- Messing with the stack + = STKCHECK Word + + -- Push locals (existing bits of the stack) + | PUSH_L !Word16{-offset-} + | PUSH_LL !Word16 !Word16{-2 offsets-} + | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} + + -- Push a ptr (these all map to PUSH_G really) + | PUSH_G Name + | PUSH_PRIMOP PrimOp + | PUSH_BCO (ProtoBCO Name) + + -- Push an alt continuation + | PUSH_ALTS (ProtoBCO Name) + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep + + -- Pushing literals + | PUSH_UBX (Either Literal (Ptr ())) Word16 + -- push this int/float/double/addr, on the stack. Word16 + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to assemble BCOs. + + -- various kinds of application + | PUSH_APPLY_N + | PUSH_APPLY_V + | PUSH_APPLY_F + | PUSH_APPLY_D + | PUSH_APPLY_L + | PUSH_APPLY_P + | PUSH_APPLY_PP + | PUSH_APPLY_PPP + | PUSH_APPLY_PPPP + | PUSH_APPLY_PPPPP + | PUSH_APPLY_PPPPPP + + | SLIDE Word16{-this many-} Word16{-down by this much-} + + -- To do with the heap + | ALLOC_AP !Word16 -- make an AP with this many payload words + | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words + | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} + | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} + | UNPACK !Word16 -- unpack N words from t.o.s Constr + | PACK DataCon !Word16 + -- after assembly, the DataCon is an index into the + -- itbl array + -- For doing case trees + | LABEL LocalLabel + | TESTLT_I Int LocalLabel + | TESTEQ_I Int LocalLabel + | TESTLT_W Word LocalLabel + | TESTEQ_W Word LocalLabel + | TESTLT_F Float LocalLabel + | TESTEQ_F Float LocalLabel + | TESTLT_D Double LocalLabel + | TESTEQ_D Double LocalLabel + + -- The Word16 value is a constructor number and therefore + -- stored in the insn stream rather than as an offset into + -- the literal pool. + | TESTLT_P Word16 LocalLabel + | TESTEQ_P Word16 LocalLabel + + | CASEFAIL + | JMP LocalLabel + + -- For doing calls to C (via glue code generated by libffi) + | CCALL Word16 -- stack frame size + (Ptr ()) -- addr of the glue code + Word16 -- whether or not the call is interruptible + -- (XXX: inefficient, but I don't know + -- what the alignment constraints are.) + + -- For doing magic ByteArray passing to foreign calls + | SWIZZLE Word16 -- to the ptr N words down the stack, + Word16 -- add M (interpreted as a signed 16-bit entity) + + -- To Infinity And Beyond + | ENTER + | RETURN -- return a lifted value + | RETURN_UBX ArgRep -- return an unlifted value, here's its rep + + -- Breakpoints + | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo + +data BreakInfo + = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: {-# UNPACK #-} !Int + , breakInfo_vars :: [(Id,Word16)] + , breakInfo_resty :: Type + } + +instance Outputable BreakInfo where + ppr info = text "BreakInfo" <+> + parens (ppr (breakInfo_module info) <+> + ppr (breakInfo_number info) <+> + ppr (breakInfo_vars info) <+> + ppr (breakInfo_resty info)) + +-- ----------------------------------------------------------------------------- +-- Printing bytecode instructions + +instance Outputable a => Outputable (ProtoBCO a) where + ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show malloced) <> colon) + $$ nest 3 (case origin of + Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) + (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' + Right rhs -> pprCoreExprShort (deAnnotate rhs)) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) + $$ nest 3 (vcat (map ppr instrs)) + +-- Print enough of the Core expression to enable the reader to find +-- the expression in the -ddump-prep output. That is, we need to +-- include at least a binder. + +pprCoreExprShort :: CoreExpr -> SDoc +pprCoreExprShort expr@(Lam _ _) + = let + (bndrs, _) = collectBinders expr + in + char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> ptext (sLit "...") + +pprCoreExprShort (Case _expr var _ty _alts) + = ptext (sLit "case of") <+> ppr var + +pprCoreExprShort (Let (NonRec x _) _) = ptext (sLit "let") <+> ppr x <+> ptext (sLit ("= ... in ...")) +pprCoreExprShort (Let (Rec bs) _) = ptext (sLit "let {") <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) + +pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e +pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> ptext (sLit "`cast` T") + +pprCoreExprShort e = pprCoreExpr e + +pprCoreAltShort :: CoreAlt -> SDoc +pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> ptext (sLit "->") <+> pprCoreExprShort expr + +instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> ppr n + ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset + ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 + ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." + <> ppr op + ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) + ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) + ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) + + ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit + ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa) + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + + ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d + ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz + ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz + ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (UNPACK sz) = text "UNPACK " <+> ppr sz + ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz + ppr (LABEL lab) = text "__" <> ppr lab <> colon + ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab + ppr CASEFAIL = text "CASEFAIL" + ppr (JMP lab) = text "JMP" <+> ppr lab + ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off + <+> text "marshall code at" + <+> text (show marshall_addr) + <+> (if int == 1 + then text "(interruptible)" + else empty) + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff + <+> text "by" <+> ppr n + ppr ENTER = text "ENTER" + ppr RETURN = text "RETURN" + ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "" <+> ppr index <+> ppr info + +-- ----------------------------------------------------------------------------- +-- The stack use, in words, of each bytecode insn. These _must_ be +-- correct, or overestimates of reality, to be safe. + +-- NOTE: we aggregate the stack use from case alternatives too, so that +-- we can do a single stack check at the beginning of a function only. + +-- This could all be made more accurate by keeping track of a proper +-- stack high water mark, but it doesn't seem worth the hassle. + +protoBCOStackUse :: ProtoBCO a -> Word +protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) + +bciStackUse :: BCInstr -> Word +bciStackUse STKCHECK{} = 0 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_LLL{} = 3 +bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_PRIMOP{} = 1 +bciStackUse PUSH_BCO{} = 1 +bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco +bciStackUse (PUSH_UBX _ nw) = fromIntegral nw +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse ALLOC_AP{} = 1 +bciStackUse ALLOC_AP_NOUPD{} = 1 +bciStackUse ALLOC_PAP{} = 1 +bciStackUse (UNPACK sz) = fromIntegral sz +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UBX{} = 1 +bciStackUse CCALL{} = 0 +bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 + +-- These insns actually reduce stack use, but we need the high-tide level, +-- so can't use this info. Not that it matters much. +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs new file mode 100644 index 00000000..fee50ee5 --- /dev/null +++ b/compiler/ghci/ByteCodeItbls.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes +module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl + , StgInfoTable(..) + ) where + +#include "HsVersions.h" + +import DynFlags +import Panic +import Platform +import Name ( Name, getName ) +import NameEnv +import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import Type ( flattenRepType, repType, typePrimRep ) +import StgCmmLayout ( mkVirtHeapOffsets ) +import Util + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict +import Data.Maybe +import Foreign +import Foreign.C + +import GHC.Exts ( Int(I#), addr2Int# ) +import GHC.Ptr ( FunPtr(..) ) + +{- + Manufacturing of info tables for DataCons +-} + +newtype ItblPtr = ItblPtr (Ptr ()) deriving Show + +itblCode :: DynFlags -> ItblPtr -> Ptr () +itblCode dflags (ItblPtr ptr) + | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags + | otherwise = castPtr ptr + +-- XXX bogus +conInfoTableSizeB :: DynFlags -> Int +conInfoTableSizeB dflags = 3 * wORD_SIZE dflags + +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv +mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] + + +-- Make info tables for the data decls in this module +mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv +mkITbls _ [] = return emptyNameEnv +mkITbls dflags (tc:tcs) = do itbls <- mkITbl dflags tc + itbls2 <- mkITbls dflags tcs + return (itbls `plusNameEnv` itbls2) + +mkITbl :: DynFlags -> TyCon -> IO ItblEnv +mkITbl dflags tc + | not (isDataTyCon tc) + = return emptyNameEnv + | dcs `lengthIs` n -- paranoia; this is an assertion. + = make_constr_itbls dflags dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + +mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!" + +#include "../includes/rts/storage/ClosureTypes.h" +cONSTR :: Int -- Defined in ClosureTypes.h +cONSTR = CONSTR + +-- Assumes constructors are numbered from zero, not one +make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv +make_constr_itbls dflags cons + = do is <- mapM mk_dirret_itbl (zip cons [0..]) + return (mkItblEnv is) + where + mk_dirret_itbl (dcon, conNo) + = mk_itbl dcon conNo stg_interp_constr_entry + + mk_itbl :: DataCon -> Int -> EntryFunPtr -> IO (Name,ItblPtr) + mk_itbl dcon conNo entry_addr = do + let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args + + ptrs' = ptr_wds + nptrs' = tot_wds - ptr_wds + nptrs_really + | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' + | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' + code' = mkJumpToAddr dflags entry_addr + itbl = StgInfoTable { + entry = if ghciTablesNextToCode + then Nothing + else Just entry_addr, + ptrs = fromIntegral ptrs', + nptrs = fromIntegral nptrs_really, + tipe = fromIntegral cONSTR, + srtlen = fromIntegral conNo, + code = if ghciTablesNextToCode + then Just code' + else Nothing + } + + -- Make a piece of code to jump to "entry_label". + -- This is the only arch-dependent bit. + addrCon <- newExecConItbl dflags itbl (dataConIdentity dcon) + --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) + --putStrLn ("# ptrs of itbl is " ++ show ptrs) + --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) + return (getName dcon, ItblPtr (castFunPtrToPtr addrCon)) + + +-- Make code which causes a jump to the given address. This is the +-- only arch-dependent bit of the itbl story. + +-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc. +#include "nativeGen/NCG.h" + +type ItblCodes = Either [Word8] [Word32] + +funPtrToInt :: FunPtr a -> Int +funPtrToInt (FunPtr a#) = I# (addr2Int# a#) + +mkJumpToAddr :: DynFlags -> EntryFunPtr -> ItblCodes +mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of + ArchSPARC -> + -- After some consideration, we'll try this, where + -- 0x55555555 stands in for the address to jump to. + -- According to includes/rts/MachRegs.h, %g3 is very + -- likely indeed to be baggable. + -- + -- 0000 07155555 sethi %hi(0x55555555), %g3 + -- 0004 8610E155 or %g3, %lo(0x55555555), %g3 + -- 0008 81C0C000 jmp %g3 + -- 000c 01000000 nop + + let w32 = fromIntegral (funPtrToInt a) + + hi22, lo10 :: Word32 -> Word32 + lo10 x = x .&. 0x3FF + hi22 x = (x `shiftR` 10) .&. 0x3FFFF + + in Right [ 0x07000000 .|. (hi22 w32), + 0x8610E000 .|. (lo10 w32), + 0x81C0C000, + 0x01000000 ] + + ArchPPC -> + -- We'll use r12, for no particular reason. + -- 0xDEADBEEF stands for the address: + -- 3D80DEAD lis r12,0xDEAD + -- 618CBEEF ori r12,r12,0xBEEF + -- 7D8903A6 mtctr r12 + -- 4E800420 bctr + + let w32 = fromIntegral (funPtrToInt a) + hi16 x = (x `shiftR` 16) .&. 0xFFFF + lo16 x = x .&. 0xFFFF + in Right [ 0x3D800000 .|. hi16 w32, + 0x618C0000 .|. lo16 w32, + 0x7D8903A6, 0x4E800420 ] + + ArchX86 -> + -- Let the address to jump to be 0xWWXXYYZZ. + -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax + -- which is + -- B8 ZZ YY XX WW FF E0 + + let w32 = fromIntegral (funPtrToInt a) :: Word32 + insnBytes :: [Word8] + insnBytes + = [0xB8, byte0 w32, byte1 w32, + byte2 w32, byte3 w32, + 0xFF, 0xE0] + in + Left insnBytes + + ArchX86_64 -> + -- Generates: + -- jmpq *.L1(%rip) + -- .align 8 + -- .L1: + -- .quad + -- + -- which looks like: + -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 + -- with addr at 10. + -- + -- We need a full 64-bit pointer (we can't assume the info table is + -- allocated in low memory). Assuming the info pointer is aligned to + -- an 8-byte boundary, the addr will also be aligned. + + let w64 = fromIntegral (funPtrToInt a) :: Word64 + insnBytes :: [Word8] + insnBytes + = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, + byte0 w64, byte1 w64, byte2 w64, byte3 w64, + byte4 w64, byte5 w64, byte6 w64, byte7 w64] + in + Left insnBytes + + ArchAlpha -> + let w64 = fromIntegral (funPtrToInt a) :: Word64 + in Right [ 0xc3800000 -- br at, .+4 + , 0xa79c000c -- ldq at, 12(at) + , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well + , 0x47ff041f -- nop + , fromIntegral (w64 .&. 0x0000FFFF) + , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] + + ArchARM { } -> + -- Generates Arm sequence, + -- ldr r1, [pc, #0] + -- bx r1 + -- + -- which looks like: + -- 00000000 <.addr-0x8>: + -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr> + -- 4: 11ff2fe1 bx r1 + let w32 = fromIntegral (funPtrToInt a) :: Word32 + in Left [ 0x00, 0x10, 0x9f, 0xe5 + , 0x11, 0xff, 0x2f, 0xe1 + , byte0 w32, byte1 w32, byte2 w32, byte3 w32] + + arch -> + panic ("mkJumpToAddr not defined for " ++ show arch) + +byte0, byte1, byte2, byte3 :: (Integral w, Bits w) => w -> Word8 +byte0 w = fromIntegral w +byte1 w = fromIntegral (w `shiftR` 8) +byte2 w = fromIntegral (w `shiftR` 16) +byte3 w = fromIntegral (w `shiftR` 24) +byte4, byte5, byte6, byte7 :: (Integral w, Bits w) => w -> Word8 +byte4 w = fromIntegral (w `shiftR` 32) +byte5 w = fromIntegral (w `shiftR` 40) +byte6 w = fromIntegral (w `shiftR` 48) +byte7 w = fromIntegral (w `shiftR` 56) + +-- entry point for direct returns for created constr itbls +foreign import ccall "&stg_interp_constr_entry" + stg_interp_constr_entry :: EntryFunPtr + + + + +-- Ultra-minimalist version specially for constructors +#if SIZEOF_VOID_P == 8 +type HalfWord = Word32 +#else +type HalfWord = Word16 +#endif + +data StgConInfoTable = StgConInfoTable { + conDesc :: Ptr Word8, + infoTable :: StgInfoTable +} + +sizeOfConItbl :: DynFlags -> StgConInfoTable -> Int +sizeOfConItbl dflags conInfoTable + = sum [ fieldSz conDesc conInfoTable + , sizeOfItbl dflags (infoTable conInfoTable) ] + +pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable + -> StgConInfoTable + -> IO () +pokeConItbl dflags wr_ptr ex_ptr itbl + = flip evalStateT (castPtr wr_ptr) $ do + when ghciTablesNextToCode $ do + let con_desc = conDesc itbl `minusPtr` + (ex_ptr `plusPtr` conInfoTableSizeB dflags) + store (fromIntegral con_desc :: Word32) + when (wORD_SIZE dflags == 8) $ + store (fromIntegral con_desc :: Word32) + store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl) + unless ghciTablesNextToCode $ store (conDesc itbl) + +type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) + +data StgInfoTable = StgInfoTable { + entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: HalfWord, + srtlen :: HalfWord, + code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode + } + +sizeOfItbl :: DynFlags -> StgInfoTable -> Int +sizeOfItbl dflags itbl + = sum + [ + if ghciTablesNextToCode then 0 else fieldSz (fromJust . entry) itbl, + fieldSz ptrs itbl, + fieldSz nptrs itbl, + fieldSz tipe itbl, + fieldSz srtlen itbl, + if ghciTablesNextToCode then case mkJumpToAddr dflags undefined of + Left xs -> sizeOf (head xs) * length xs + Right xs -> sizeOf (head xs) * length xs + else 0 + ] + +pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO () +pokeItbl _ a0 itbl + = flip evalStateT (castPtr a0) + $ do + case entry itbl of + Nothing -> return () + Just e -> store e + store (ptrs itbl) + store (nptrs itbl) + store (tipe itbl) + store (srtlen itbl) + case code itbl of + Nothing -> return () + Just (Left xs) -> mapM_ store xs + Just (Right xs) -> mapM_ store xs + +peekItbl :: DynFlags -> Ptr StgInfoTable -> IO StgInfoTable +peekItbl dflags a0 + = flip evalStateT (castPtr a0) + $ do + entry' <- if ghciTablesNextToCode + then return Nothing + else liftM Just load + ptrs' <- load + nptrs' <- load + tipe' <- load + srtlen' <- load + code' <- if ghciTablesNextToCode + then liftM Just $ case mkJumpToAddr dflags undefined of + Left xs -> + liftM Left $ sequence (replicate (length xs) load) + Right xs -> + liftM Right $ sequence (replicate (length xs) load) + else return Nothing + return + StgInfoTable { + entry = entry', + ptrs = ptrs', + nptrs = nptrs', + tipe = tipe', + srtlen = srtlen' + ,code = code' + } + +fieldSz :: Storable b => (a -> b) -> a -> Int +fieldSz sel x = sizeOf (sel x) + +type PtrIO = StateT (Ptr Word8) IO + +advance :: Storable a => PtrIO (Ptr a) +advance = advance' sizeOf + +advance' :: (a -> Int) -> PtrIO (Ptr a) +advance' fSizeOf = state adv + where adv addr = case castPtr addr of + addrCast -> + (addrCast, + addr `plusPtr` sizeOfPointee fSizeOf addrCast) + +sizeOfPointee :: (a -> Int) -> Ptr a -> Int +sizeOfPointee fSizeOf addr = fSizeOf (typeHack addr) + where typeHack = undefined :: Ptr a -> a + +store :: Storable a => a -> PtrIO () +store = store' sizeOf poke + +store' :: (a -> Int) -> (Ptr a -> a -> IO ()) -> a -> PtrIO () +store' fSizeOf fPoke x = do addr <- advance' fSizeOf + lift (fPoke addr x) + +load :: Storable a => PtrIO a +load = do addr <- advance + lift (peek addr) + +newExecConItbl :: DynFlags -> StgInfoTable -> [Word8] -> IO (FunPtr ()) +newExecConItbl dflags obj con_desc + = alloca $ \pcode -> do + let lcon_desc = length con_desc + 1{- null terminator -} + dummy_cinfo = StgConInfoTable { conDesc = nullPtr, infoTable = obj } + sz = fromIntegral (sizeOfConItbl dflags dummy_cinfo) + -- Note: we need to allocate the conDesc string next to the info + -- table, because on a 64-bit platform we reference this string + -- with a 32-bit offset relative to the info table, so if we + -- allocated the string separately it might be out of range. + wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode + ex_ptr <- peek pcode + let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz + , infoTable = obj } + pokeConItbl dflags wr_ptr ex_ptr cinfo + pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc + _flushExec sz ex_ptr -- Cache flush (if needed) + return (castPtrToFunPtr ex_ptr) + +foreign import ccall unsafe "allocateExec" + _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) + +foreign import ccall unsafe "flushExec" + _flushExec :: CUInt -> Ptr a -> IO () diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs new file mode 100644 index 00000000..5090f990 --- /dev/null +++ b/compiler/ghci/ByteCodeLink.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | ByteCodeLink: Bytecode assembler and linker +module ByteCodeLink ( + ClosureEnv, emptyClosureEnv, extendClosureEnv, + linkBCO, lookupStaticPtr, lookupName + ,lookupIE + ) where + +#include "HsVersions.h" + +import ByteCodeItbls +import ByteCodeAsm +import ObjLink + +import DynFlags +import BasicTypes +import Name +import NameEnv +import PrimOp +import Module +import FastString +import Panic +import Outputable +import Util + +-- Standard libraries + +import Data.Array.Base + +import Control.Monad +import Control.Monad.ST ( stToIO ) + +import GHC.Arr ( Array(..), STArray(..) ) +import GHC.IO ( IO(..) ) +import GHC.Exts +import GHC.Ptr ( castPtr ) + +{- + Linking interpretables into something we can run +-} + +type ClosureEnv = NameEnv (Name, HValue) + +emptyClosureEnv :: ClosureEnv +emptyClosureEnv = emptyNameEnv + +extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv +extendClosureEnv cl_env pairs + = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] + +{- + Linking interpretables into something we can run +-} + +{- +data BCO# = BCO# ByteArray# -- instrs :: Array Word16# + ByteArray# -- literals :: Array Word32# + PtrArray# -- ptrs :: Array HValue + ByteArray# -- itbls :: Array Addr# +-} + +linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue +linkBCO dflags ie ce ul_bco + = do BCO bco# <- linkBCO' dflags ie ce ul_bco + -- SDM: Why do we need mkApUpd0 here? I *think* it's because + -- otherwise top-level interpreted CAFs don't get updated + -- after evaluation. A top-level BCO will evaluate itself and + -- return its value when entered, but it won't update itself. + -- Wrapping the BCO in an AP_UPD thunk will take care of the + -- update for us. + -- + -- Update: the above is true, but now we also have extra invariants: + -- (a) An AP thunk *must* point directly to a BCO + -- (b) A zero-arity BCO *must* be wrapped in an AP thunk + -- (c) An AP is always fully saturated, so we *can't* wrap + -- non-zero arity BCOs in an AP thunk. + -- + if (unlinkedBCOArity ul_bco > 0) + then return (HValue (unsafeCoerce# bco#)) + else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) } + + +linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO +linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) + -- Raises an IO exception on failure + = do let literals = ssElts literalsSS + ptrs = ssElts ptrsSS + + linked_literals <- mapM (lookupLiteral dflags ie) literals + + let n_literals = sizeSS literalsSS + n_ptrs = sizeSS ptrsSS + + ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs + + let + !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr + + litRange + | n_literals > 0 = (0, fromIntegral n_literals - 1) + | otherwise = (1, 0) + literals_arr :: UArray Word Word + literals_arr = listArray litRange linked_literals + !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr + + !(I# arity#) = arity + + newBCO insns_barr literals_barr ptrs_parr arity# bitmap + + +-- we recursively link any sub-BCOs while making the ptrs array +mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) +mkPtrsArray dflags ie ce n_ptrs ptrs = do + let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) + marr <- newArray_ ptrRange + let + fill (BCOPtrName n) i = do + ptr <- lookupName ce n + unsafeWrite marr i ptr + fill (BCOPtrPrimOp op) i = do + ptr <- lookupPrimOp op + unsafeWrite marr i ptr + fill (BCOPtrBCO ul_bco) i = do + BCO bco# <- linkBCO' dflags ie ce ul_bco + writeArrayBCO marr i bco# + fill (BCOPtrBreakInfo brkInfo) i = + unsafeWrite marr i (HValue (unsafeCoerce# brkInfo)) + fill (BCOPtrArray brkArray) i = + unsafeWrite marr i (HValue (unsafeCoerce# brkArray)) + zipWithM_ fill ptrs [0..] + unsafeFreeze marr + +newtype IOArray i e = IOArray (STArray RealWorld i e) + +instance MArray IOArray e IO where + getBounds (IOArray marr) = stToIO $ getBounds marr + getNumElements (IOArray marr) = stToIO $ getNumElements marr + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOArray marr) + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOArray marr) + unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i) + unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e) + +-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#. +writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO () +writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# -> + case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> + (# s#, () #) } + +{- +writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO () +writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# -> + case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> + (# s#, () #) } +-} + +data BCO = BCO BCO# + +newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO +newBCO instrs lits ptrs arity bitmap + = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of + (# s1, bco #) -> (# s1, BCO bco #) + + +lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm + return (W# (int2Word# (addr2Int# a#))) + +lookupStaticPtr :: FastString -> IO (Ptr ()) +lookupStaticPtr addr_of_label_string + = do let label_to_find = unpackFS addr_of_label_string + m <- lookupSymbol label_to_find + case m of + Just ptr -> return ptr + Nothing -> linkFail "ByteCodeLink: can't find label" + label_to_find + +lookupPrimOp :: PrimOp -> IO HValue +lookupPrimOp primop + = do let sym_to_find = primopToCLabel primop "closure" + m <- lookupSymbol sym_to_find + case m of + Just (Ptr addr) -> case addrToAny# addr of + (# a #) -> return (HValue a) + Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find + +lookupName :: ClosureEnv -> Name -> IO HValue +lookupName ce nm + = case lookupNameEnv ce nm of + Just (_,aa) -> return aa + Nothing + -> ASSERT2(isExternalName nm, ppr nm) + do let sym_to_find = nameToCLabel nm "closure" + m <- lookupSymbol sym_to_find + case m of + Just (Ptr addr) -> case addrToAny# addr of + (# a #) -> return (HValue a) + Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find + +lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a) +lookupIE dflags ie con_nm + = case lookupNameEnv ie con_nm of + Just (_, a) -> return (castPtr (itblCode dflags a)) + Nothing + -> do -- try looking up in the object files. + let sym_to_find1 = nameToCLabel con_nm "con_info" + m <- lookupSymbol sym_to_find1 + case m of + Just addr -> return addr + Nothing + -> do -- perhaps a nullary constructor? + let sym_to_find2 = nameToCLabel con_nm "static_info" + n <- lookupSymbol sym_to_find2 + case n of + Just addr -> return addr + Nothing -> linkFail "ByteCodeLink.lookupIE" + (sym_to_find1 ++ " or " ++ sym_to_find2) + +linkFail :: String -> String -> IO a +linkFail who what + = throwGhcExceptionIO (ProgramError $ + unlines [ "",who + , "During interactive linking, GHCi couldn't find the following symbol:" + , ' ' : ' ' : what + , "This may be due to you not asking GHCi to load extra object files," + , "archives or DLLs needed by your current session. Restart GHCi, specifying" + , "the missing library using the -L/path/to/object/dir and -lmissinglibname" + , "flags, or simply by naming the relevant files on the GHCi command line." + , "Alternatively, this link failure might indicate a bug in GHCi." + , "If you suspect the latter, please send a bug report to:" + , " glasgow-haskell-bugs@haskell.org" + ]) + + +nameToCLabel :: Name -> String -> String +nameToCLabel n suffix = label where + encodeZ = zString . zEncodeFS + (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n + packagePart = encodeZ (packageKeyFS pkgKey) + modulePart = encodeZ (moduleNameFS modName) + occPart = encodeZ (occNameFS (nameOccName n)) + + label = concat + [ if pkgKey == mainPackageKey then "" else packagePart ++ "_" + , modulePart + , '_':occPart + , '_':suffix + ] + + +primopToCLabel :: PrimOp -> String -> String +primopToCLabel primop suffix = concat + [ "ghczmprim_GHCziPrimopWrappers_" + , zString (zEncodeFS (occNameFS (primOpOcc primop))) + , '_':suffix + ] + diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs new file mode 100644 index 00000000..e5d021d3 --- /dev/null +++ b/compiler/ghci/Debugger.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- GHCi Interactive debugging commands +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +-- ToDo: lots of violation of layering here. This module should +-- decide whether it is above the GHC API (import GHC and nothing +-- else) or below it. +-- +----------------------------------------------------------------------------- + +module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where + +import Linker +import RtClosureInspect + +import GhcMonad +import HscTypes +import Id +import Name +import Var hiding ( varName ) +import VarSet +import UniqSupply +import Type +import Kind +import GHC +import Outputable +import PprTyThing +import ErrUtils +import MonadUtils +import DynFlags +import Exception + +import Control.Monad +import Data.List +import Data.Maybe +import Data.IORef + +import GHC.Exts + +------------------------------------- +-- | The :print & friends commands +------------------------------------- +pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () +pprintClosureCommand bindThings force str = do + tythings <- (catMaybes . concat) `liftM` + mapM (\w -> GHC.parseName w >>= + mapM GHC.lookupName) + (words str) + let ids = [id | AnId id <- tythings] + + -- Obtain the terms and the recovered type information + (subst, terms) <- mapAccumLM go emptyTvSubst ids + + -- Apply the substitutions obtained after recovering the types + modifySession $ \hsc_env -> + hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} + + -- Finally, print the Terms + unqual <- GHC.getPrintUnqual + docterms <- mapM showTerm terms + dflags <- getDynFlags + liftIO $ (printOutputForUser dflags unqual . vcat) + (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) + ids + docterms) + where + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance + go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term) + go subst id = do + let id' = id `setIdType` substTy subst (idType id) + term_ <- GHC.obtainTermFromId maxBound force id' + term <- tidyTermTyVars term_ + term' <- if bindThings && + False == isUnliftedTypeKind (termType term) + then bindSuspensions term + else return term + -- Before leaving, we compare the type obtained to see if it's more specific + -- Then, we extract a substitution, + -- mapping the old tyvars to the reconstructed types. + let reconstructed_type = termType term + hsc_env <- getSession + case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of + Nothing -> return (subst, term') + Just subst' -> do { traceOptIf Opt_D_dump_rtti + (fsep $ [text "RTTI Improvement for", ppr id, + text "is the substitution:" , ppr subst']) + ; return (subst `unionTvSubst` subst', term')} + + tidyTermTyVars :: GhcMonad m => Term -> m Term + tidyTermTyVars t = + withSession $ \hsc_env -> do + let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyVars t + tvs = env_tvs `minusVarSet` my_tvs + tyvarOccName = nameOccName . tyVarName + tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs)) + , env_tvs `intersectVarSet` my_tvs) + return$ mapTermType (snd . tidyOpenType tidyEnv) t + +-- | Give names, and bind in the interactive environment, to all the suspensions +-- included (inductively) in a term +bindSuspensions :: GhcMonad m => Term -> m Term +bindSuspensions t = do + hsc_env <- getSession + inScope <- GHC.getBindings + let ictxt = hsc_IC hsc_env + prefix = "_t" + alreadyUsedNames = map (occNameString . nameOccName . getName) inScope + availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames + availNames_var <- liftIO $ newIORef availNames + (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t + let (names, tys, hvals) = unzip3 stuff + let ids = [ mkVanillaGlobal name ty + | (name,ty) <- zip names tys] + new_ic = extendInteractiveContextWithIds ictxt ids + liftIO $ extendLinkEnv (zip names hvals) + modifySession $ \_ -> hsc_env {hsc_IC = new_ic } + return t' + where + +-- Processing suspensions. Give names and recopilate info + nameSuspensionsAndGetInfos :: IORef [String] -> + TermFold (IO (Term, [(Name,Type,HValue)])) + nameSuspensionsAndGetInfos freeNames = TermFold + { + fSuspension = doSuspension freeNames + , fTerm = \ty dc v tt -> do + tt' <- sequence tt + let (terms,names) = unzip tt' + return (Term ty dc v terms, concat names) + , fPrim = \ty n ->return (Prim ty n,[]) + , fNewtypeWrap = + \ty dc t -> do + (term, names) <- t + return (NewtypeWrap ty dc term, names) + , fRefWrap = \ty t -> do + (term, names) <- t + return (RefWrap ty term, names) + } + doSuspension freeNames ct ty hval _name = do + name <- atomicModifyIORef freeNames (\x->(tail x, head x)) + n <- newGrimName name + return (Suspension ct ty hval (Just n), [(n,ty,hval)]) + + +-- A custom Term printer to enable the use of Show instances +showTerm :: GhcMonad m => Term -> m SDoc +showTerm term = do + dflags <- GHC.getSessionDynFlags + if gopt Opt_PrintEvldWithShow dflags + then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term + else cPprTerm cPprTermBase term + where + cPprShowable prec t@Term{ty=ty, val=val} = + if not (isFullyEvaluatedTerm t) + then return Nothing + else do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + do + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + -- XXX: this tries to disable logging of errors + -- does this still do what it is intended to do + -- with the changed error handling and logging? + let noop_log _ _ _ _ _ = return () + expr = "show " ++ showPpr dflags bname + _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} + txt_ <- withExtendedLinkEnv [(bname, val)] + (GHC.compileExpr expr) + let myprec = 10 -- application precedence. TODO Infix constructors + let txt = unsafeCoerce# txt_ :: [a] + if not (null txt) then + return $ Just $ cparen (prec >= myprec && needsParens txt) + (text txt) + else return Nothing + `gfinally` do + setSession hsc_env + GHC.setSessionDynFlags dflags + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = + cPprShowable prec t{ty=new_ty} + cPprShowable _ _ = return Nothing + + needsParens ('"':_) = False -- some simple heuristics to see whether parens + -- are redundant in an arbitrary Show output + needsParens ('(':_) = False + needsParens txt = ' ' `elem` txt + + + bindToFreshName hsc_env ty userName = do + name <- newGrimName userName + let id = mkVanillaGlobal name ty + new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] + return (hsc_env {hsc_IC = new_ic }, name) + +-- Create new uniques and give them sequentially numbered names +newGrimName :: MonadIO m => String -> m Name +newGrimName userName = do + us <- liftIO $ mkSplitUniqSupply 'b' + let unique = uniqFromSupply us + occname = mkOccName varName userName + name = mkInternalName unique occname noSrcSpan + return name + +pprTypeAndContents :: GhcMonad m => Id -> m SDoc +pprTypeAndContents id = do + dflags <- GHC.getSessionDynFlags + let pcontents = gopt Opt_PrintBindContents dflags + pprdId = (PprTyThing.pprTyThing . AnId) id + if pcontents + then do + let depthBound = 100 + -- If the value is an exception, make sure we catch it and + -- show the exception, rather than propagating the exception out. + e_term <- gtry $ GHC.obtainTermFromId depthBound False id + docs_term <- case e_term of + Right term -> showTerm term + Left exn -> return (text "*** Exception:" <+> + text (show (exn :: SomeException))) + return $ pprdId <+> equals <+> docs_term + else return pprdId + +-------------------------------------------------------------- +-- Utils + +traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m () +traceOptIf flag doc = do + dflags <- GHC.getSessionDynFlags + when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs new file mode 100644 index 00000000..cafc3759 --- /dev/null +++ b/compiler/ghci/DebuggerUtils.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE CPP #-} + +module DebuggerUtils ( + dataConInfoPtrToName, + ) where + +import CmmInfo ( stdInfoTableSizeB ) +import ByteCodeItbls +import DynFlags +import FastString +import TcRnTypes +import TcRnMonad +import IfaceEnv +import Module +import OccName +import Name +import Outputable +import Platform +import Util + +import Data.Char +import Foreign +import Data.List + +#include "HsVersions.h" + +-- | Given a data constructor in the heap, find its Name. +-- The info tables for data constructors have a field which records +-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded +-- string). The format is: +-- +-- > Package:Module.Name +-- +-- We use this string to lookup the interpreter's internal representation of the name +-- using the lookupOrig. +-- +dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) +dataConInfoPtrToName x = do + dflags <- getDynFlags + theString <- liftIO $ do + let ptr = castPtr x :: Ptr StgInfoTable + conDescAddress <- getConDescAddress dflags ptr + peekArray0 0 conDescAddress + let (pkg, mod, occ) = parse theString + pkgFS = mkFastStringByteList pkg + modFS = mkFastStringByteList mod + occFS = mkFastStringByteList occ + occName = mkOccNameFS OccName.dataName occFS + modName = mkModule (fsToPackageKey pkgFS) (mkModuleNameFS modFS) + return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) + `recoverM` (Right `fmap` lookupOrig modName occName) + + where + + {- To find the string in the constructor's info table we need to consider + the layout of info tables relative to the entry code for a closure. + + An info table can be next to the entry code for the closure, or it can + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. + + The diagrams below show where the string is to be found relative to + the normal info table of the closure. + + 1) Code next to table: + + -------------- + | | <- pointer to the start of the string + -------------- + | | <- the (start of the) info table structure + | | + | | + -------------- + | entry code | + | .... | + + In this case the pointer to the start of the string can be found in + the memory location _one word before_ the first entry in the normal info + table. + + 2) Code NOT next to table: + + -------------- + info table structure -> | *------------------> -------------- + | | | entry code | + | | | .... | + -------------- + ptr to start of str -> | | + -------------- + + In this case the pointer to the start of the string can be found + in the memory location: info_table_ptr + info_table_size + -} + + getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) + getConDescAddress dflags ptr + | ghciTablesNextToCode = do + let ptr' = ptr `plusPtr` (- wORD_SIZE dflags) + -- offsetToString is really an StgWord, but we have to jump + -- through some hoops due to the way that our StgWord Haskell + -- type is the same on 32 and 64bit platforms + offsetToString <- case platformWordSize (targetPlatform dflags) of + 4 -> do w <- peek ptr' + return (fromIntegral (w :: Word32)) + 8 -> do w <- peek ptr' + return (fromIntegral (w :: Word32)) + w -> panic ("getConDescAddress: Unknown platformWordSize: " ++ show w) + return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString + | otherwise = + peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) + -- parsing names is a little bit fiddly because we have a string in the form: + -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). + -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. + -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas + -- this is not the conventional way of writing Haskell names. We stick with + -- convention, even though it makes the parsing code more troublesome. + -- Warning: this code assumes that the string is well formed. + parse :: [Word8] -> ([Word8], [Word8], [Word8]) + parse input + = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) + where + dot = fromIntegral (ord '.') + (pkg, rest1) = break (== fromIntegral (ord ':')) input + (mod, occ) + = (concat $ intersperse [dot] $ reverse modWords, occWord) + where + (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1)) + parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) + -- We only look for dots if str could start with a module name, + -- i.e. if it starts with an upper case character. + -- Otherwise we might think that "X.:->" is the module name in + -- "X.:->.+", whereas actually "X" is the module name and + -- ":->.+" is a constructor name. + parseModOcc acc str@(c : _) + | isUpper $ chr $ fromIntegral c + = case break (== dot) str of + (top, []) -> (acc, top) + (top, _ : bot) -> parseModOcc (top : acc) bot + parseModOcc acc str = (acc, str) diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc new file mode 100644 index 00000000..d3759f3c --- /dev/null +++ b/compiler/ghci/LibFFI.hsc @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- +-- libffi bindings +-- +-- (c) The University of Glasgow 2008 +-- +----------------------------------------------------------------------------- + +#include + +module LibFFI ( + ForeignCallToken, + prepForeignCall + ) where + +import TyCon +import ForeignCall +import Panic +import DynFlags + +import Control.Monad +import Foreign +import Foreign.C + +---------------------------------------------------------------------------- + +type ForeignCallToken = C_ffi_cif + +prepForeignCall + :: DynFlags + -> CCallConv + -> [PrimRep] -- arg types + -> PrimRep -- result type + -> IO (Ptr ForeignCallToken) -- token for making calls + -- (must be freed by caller) +prepForeignCall dflags cconv arg_types result_type + = do + let n_args = length arg_types + arg_arr <- mallocArray n_args + let init_arg ty n = pokeElemOff arg_arr n (primRepToFFIType dflags ty) + zipWithM_ init_arg arg_types [0..] + cif <- mallocBytes (#const sizeof(ffi_cif)) + let abi = convToABI cconv + let res_ty = primRepToFFIType dflags result_type + r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr + if (r /= fFI_OK) + then throwGhcExceptionIO (InstallationError + ("prepForeignCallFailed: " ++ show r)) + else return cif + +convToABI :: CCallConv -> C_ffi_abi +convToABI CCallConv = fFI_DEFAULT_ABI +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) +convToABI StdCallConv = fFI_STDCALL +#endif +-- unknown conventions are mapped to the default, (#3336) +convToABI _ = fFI_DEFAULT_ABI + +-- c.f. DsForeign.primTyDescChar +primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type +primRepToFFIType dflags r + = case r of + VoidRep -> ffi_type_void + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> ffi_type_sint64 + Word64Rep -> ffi_type_uint64 + AddrRep -> ffi_type_pointer + FloatRep -> ffi_type_float + DoubleRep -> ffi_type_double + _ -> panic "primRepToFFIType" + where + (signed_word, unsigned_word) + | wORD_SIZE dflags == 4 = (ffi_type_sint32, ffi_type_uint32) + | wORD_SIZE dflags == 8 = (ffi_type_sint64, ffi_type_uint64) + | otherwise = panic "primTyDescChar" + + +data C_ffi_type +data C_ffi_cif + +type C_ffi_status = (#type ffi_status) +type C_ffi_abi = (#type ffi_abi) + +foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type +foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type +foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type + +fFI_OK :: C_ffi_status +fFI_OK = (#const FFI_OK) +--fFI_BAD_ABI :: C_ffi_status +--fFI_BAD_ABI = (#const FFI_BAD_ABI) +--fFI_BAD_TYPEDEF :: C_ffi_status +--fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF) + +fFI_DEFAULT_ABI :: C_ffi_abi +fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) +fFI_STDCALL :: C_ffi_abi +fFI_STDCALL = (#const FFI_STDCALL) +#endif + +-- ffi_status ffi_prep_cif(ffi_cif *cif, +-- ffi_abi abi, +-- unsigned int nargs, +-- ffi_type *rtype, +-- ffi_type **atypes); + +foreign import ccall "ffi_prep_cif" + ffi_prep_cif :: Ptr C_ffi_cif -- cif + -> C_ffi_abi -- abi + -> CUInt -- nargs + -> Ptr C_ffi_type -- result type + -> Ptr (Ptr C_ffi_type) -- arg types + -> IO C_ffi_status + +-- Currently unused: + +-- void ffi_call(ffi_cif *cif, +-- void (*fn)(), +-- void *rvalue, +-- void **avalue); + +-- foreign import ccall "ffi_call" +-- ffi_call :: Ptr C_ffi_cif -- cif +-- -> FunPtr (IO ()) -- function to call +-- -> Ptr () -- put result here +-- -> Ptr (Ptr ()) -- arg values +-- -> IO () diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs new file mode 100644 index 00000000..4b33f4c2 --- /dev/null +++ b/compiler/ghci/Linker.hs @@ -0,0 +1,1323 @@ +{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fno-cse #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +-- | The dynamic linker for GHCi. +-- +-- This module deals with the top-level issues of dynamic linking, +-- calling the object-code linker and the byte-code linker where +-- necessary. +module Linker ( getHValue, showLinkerState, + linkExpr, linkDecls, unload, withExtendedLinkEnv, + extendLinkEnv, deleteFromLinkEnv, + extendLoadedPkgs, + linkPackages,initDynLinker,linkModule, + linkCmdLineLibs, + + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals + ) where + +#include "HsVersions.h" + +import LoadIface +import ObjLink +import ByteCodeLink +import ByteCodeItbls +import ByteCodeAsm +import TcRnMonad +import Packages +import DriverPhases +import Finder +import HscTypes +import Name +import NameEnv +import NameSet +import UniqFM +import Module +import ListSetOps +import DynFlags +import BasicTypes +import Outputable +import Panic +import Util +import ErrUtils +import SrcLoc +import qualified Maybes +import UniqSet +import FastString +import Platform +import SysTools + +-- Standard libraries +import Control.Monad + +import Data.IORef +import Data.List +import Control.Concurrent.MVar + +import System.FilePath +import System.IO +import System.Directory hiding (findFile) + +import Exception + + +{- ********************************************************************** + + The Linker's state + + ********************************************************************* -} + +{- +The persistent linker state *must* match the actual state of the +C dynamic linker at all times, so we keep it in a private global variable. + +The global IORef used for PersistentLinkerState actually contains another MVar. +The reason for this is that we want to allow another loaded copy of the GHC +library to side-effect the PLS and for those changes to be reflected here. + +The PersistentLinkerState maps Names to actual closures (for +interpreted code only), for use during linking. +-} + +GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) +GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised + +modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f + +modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f + +data PersistentLinkerState + = PersistentLinkerState { + + -- Current global mapping from Names to their true values + closure_env :: ClosureEnv, + + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. + itbl_env :: !ItblEnv, + + -- The currently loaded interpreted modules (home package) + bcos_loaded :: ![Linkable], + + -- And the currently-loaded compiled modules (home package) + objs_loaded :: ![Linkable], + + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: ![PackageKey], + + -- we need to remember the name of previous temporary DLL/.so + -- libraries so we can link them (see #10322) + temp_sos :: ![(FilePath, String)] } + + +emptyPLS :: DynFlags -> PersistentLinkerState +emptyPLS _ = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [], + temp_sos = [] } + + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs = [rtsPackageKey] + + +extendLoadedPkgs :: [PackageKey] -> IO () +extendLoadedPkgs pkgs = + modifyPLS_ $ \s -> + return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } + +extendLinkEnv :: [(Name,HValue)] -> IO () +-- Automatically discards shadowed bindings +extendLinkEnv new_bindings = + modifyPLS_ $ \pls -> + let new_closure_env = extendClosureEnv (closure_env pls) new_bindings + in return pls{ closure_env = new_closure_env } + +deleteFromLinkEnv :: [Name] -> IO () +deleteFromLinkEnv to_remove = + modifyPLS_ $ \pls -> + let new_closure_env = delListFromNameEnv (closure_env pls) to_remove + in return pls{ closure_env = new_closure_env } + +-- | Get the 'HValue' associated with the given name. +-- +-- May cause loading the module that contains the name. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. +getHValue :: HscEnv -> Name -> IO HValue +getHValue hsc_env name = do + initDynLinker (hsc_dflags hsc_env) + pls <- modifyPLS $ \pls -> do + if (isExternalName name) then do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] + if (failed ok) then throwGhcExceptionIO (ProgramError "") + else return (pls', pls') + else + return (pls, pls) + lookupName (closure_env pls) name + +linkDependencies :: HscEnv -> PersistentLinkerState + -> SrcSpan -> [Module] + -> IO (PersistentLinkerState, SuccessFlag) +linkDependencies hsc_env pls span needed_mods = do +-- initDynLinker (hsc_dflags hsc_env) + let hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay dflags span + + -- Find what packages and linkables are required + (lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf span needed_mods + + -- Link the packages and modules required + pls1 <- linkPackages' dflags pkgs pls + linkModules dflags pls1 lnks + + +-- | Temporarily extend the linker state. + +withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) => + [(Name,HValue)] -> m a -> m a +withExtendedLinkEnv new_env action + = gbracket (liftIO $ extendLinkEnv new_env) + (\_ -> reset_old_env) + (\_ -> action) + where + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = liftIO $ do + modifyPLS_ $ \pls -> + let cur = closure_env pls + new = delListFromNameEnv cur (map fst new_env) + in return pls{ closure_env = new } + +-- filterNameMap removes from the environment all entries except +-- those for a given set of modules; +-- Note that this removes all *local* (i.e. non-isExternal) names too +-- (these are the temporary bindings from the command line). +-- Used to filter both the ClosureEnv and ItblEnv + +filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) +filterNameMap mods env + = filterNameEnv keep_elt env + where + keep_elt (n,_) = isExternalName n + && (nameModule n `elem` mods) + + +-- | Display the persistent linker state. +showLinkerState :: DynFlags -> IO () +showLinkerState dflags + = do pls <- readIORef v_PersistentLinkerState >>= readMVar + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (vcat [text "----- Linker state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) + + +{- ********************************************************************** + + Initialisation + + ********************************************************************* -} + +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- c) Loading any packages specified on the command line, now held in the +-- @-l@ options in @v_Opt_l@, +-- +-- d) Loading any @.o\/.dll@ files specified on the command line, now held +-- in @ldInputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: This function is idempotent; if called more than once, it does +-- nothing. This is useful in Template Haskell, where we call it before +-- trying to link. +-- +initDynLinker :: DynFlags -> IO () +initDynLinker dflags = + modifyPLS_ $ \pls0 -> do + done <- readIORef v_InitLinkerDone + if done then return pls0 + else do writeIORef v_InitLinkerDone True + reallyInitDynLinker dflags + +reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState +reallyInitDynLinker dflags = + do { -- Initialise the linker state + let pls0 = emptyPLS dflags + + -- (a) initialise the C dynamic linker + ; initObjLinker + + -- (b) Load packages from the command-line (Note [preload packages]) + ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 + + -- steps (c), (d) and (e) + ; linkCmdLineLibs' dflags pls + } + +linkCmdLineLibs :: DynFlags -> IO () +linkCmdLineLibs dflags = do + initDynLinker dflags + modifyPLS_ $ \pls -> do + linkCmdLineLibs' dflags pls + +linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState +linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths}) pls = + do { -- (c) Link libraries from the command-line + ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls + + -- (d) Link .o files from the command-line + ; classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + ; let platform = targetPlatform dflags + ; let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] + ++ libspecs + ++ map Framework frameworks + ; if null cmdline_lib_specs then return pls + else do + + { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls + cmdline_lib_specs + ; maybePutStr dflags "final link ... " + ; ok <- resolveObjs + + ; if succeeded ok then maybePutStrLn dflags "done" + else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") + + ; return pls1 + }} + + +{- Note [preload packages] + +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... + + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput dflags f + | isObjectFilename platform f = return (Just (Object f)) + | isDynLibFilename platform f = return (Just (DLLPath f)) + | otherwise = do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing + where platform = targetPlatform dflags + +preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState + -> LibrarySpec -> IO (PersistentLinkerState) +preloadLib dflags lib_paths framework_paths pls lib_spec + = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Object static_ish + -> do (b, pls1) <- preload_static lib_paths static_ish + maybePutStrLn dflags (if b then "done" + else "not found") + return pls1 + + Archive static_ish + -> do b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" + else "not found") + return pls + + DLL dll_unadorned + -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned) + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Just mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so" + case err2 of + Nothing -> maybePutStrLn dflags "done" + Just _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path + -> do maybe_errstr <- loadDLL dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else panic "preloadLib Framework" + + where + platform = targetPlatform dflags + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr dflags "failed.\n" + throwGhcExceptionIO $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + (concat (intersperse "\n" (map (" "++) paths))))) + + -- Not interested in the paths in the static case. + preload_static _paths name + = do b <- doesFileExist name + if not b then return (False, pls) + else if dynamicGhc + then do pls1 <- dynLoadObjs dflags pls [name] + return (True, pls1) + else do loadObj name + return (True, pls) + + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else do if dynamicGhc + then panic "Loading archives not supported" + else loadArchive name + return True + + +{- ********************************************************************** + + Link a byte-code expression + + ********************************************************************* -} + +-- | Link a single expression, /including/ first linking packages and +-- modules that this expression depends on. +-- +-- Raises an IO exception ('ProgramError') if it can't find a compiled +-- version of the dependents to link. +-- +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue +linkExpr hsc_env span root_ul_bco + = do { + -- Initialise the linker (if it's not been done already) + let dflags = hsc_dflags hsc_env + ; initDynLinker dflags + + -- Take lock for the actual work. + ; modifyPLS $ \pls0 -> do { + + -- Link the packages and modules required + ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + ; if failed ok then + throwGhcExceptionIO (ProgramError "") + else do { + + -- Link the expression itself + let ie = itbl_env pls + ce = closure_env pls + + -- Link the necessary packages and linkables + ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco] + ; return (pls, root_hval) + }}} + where + free_names = nameSetElems (bcoFreeNames root_ul_bco) + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + +dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) + + +checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay dflags srcspan = + if interpWays == haskellWays + then return Nothing + -- see #3604: object files compiled for way "dyn" need to link to the + -- dynamic packages, so we can't load them into a statically-linked GHCi. + -- we have to treat "dyn" in the same way as "prof". + -- + -- In the future when GHCi is dynamically linked we should be able to relax + -- this, but they we may have to make it possible to load either ordinary + -- .o files or -dynamic .o files into GHCi (currently that's not possible + -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn + -- whereas we have __stginit_base_Prelude_. + else if objectSuf dflags == normalObjectSuffix && not (null haskellWays) + then failNonStd dflags srcspan + else return $ Just $ if dynamicGhc + then "dyn_o" + else "o" + where haskellWays = filter (not . wayRTSOnly) (ways dflags) + +normalObjectSuffix :: String +normalObjectSuffix = phaseInputExt StopLn + +failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +failNonStd dflags srcspan = dieWith dflags srcspan $ + ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ + ptext (sLit "You need to build the program twice: once the") <+> ghciWay <+> ptext (sLit "way, and then") $$ + ptext (sLit "in the desired way using -osuf to set the object file suffix.") + where ghciWay = if dynamicGhc + then ptext (sLit "dynamic") + else ptext (sLit "normal") + +getLinkDeps :: HscEnv -> HomePackageTable + -> PersistentLinkerState + -> Maybe FilePath -- replace object suffices? + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [PackageKey]) -- ... then link these first +-- Fails with an IO exception if it can't find enough files + +getLinkDeps hsc_env hpt pls replace_osuf span mods +-- Find all the packages and linkables that a set of modules depends on + = do { + -- 1. Find the dependent home-pkg-modules/packages from each iface + -- (omitting modules from the interactive package, which is already linked) + ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) + emptyUniqSet emptyUniqSet; + + ; let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + + linked_mods = map (moduleName.linkableModule) + (objs_loaded pls ++ bcos_loaded pls) } + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable + ; let { osuf = objectSuf dflags } + ; lnks_needed <- mapM (get_linkable osuf) mods_needed + + ; return (lnks_needed, pkgs_needed) } + where + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqSet ModuleName -- accum. module dependencies + -> UniqSet PackageKey -- accum. package dependencies + -> IO ([ModuleName], [PackageKey]) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- initIfaceCheck hsc_env $ + loadInterface msg mod (ImportByUser False) + iface <- case mb_iface of + Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface) $ link_boot_mod_error mod + + let + pkg = modulePackageKey mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) + where is_boot (m,True) = Left m + is_boot (m,False) = Right m + + boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps + acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps + -- + if pkg /= this_pkg + then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) + else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + + + link_boot_mod_error mod = + throwGhcExceptionIO (ProgramError (showSDoc dflags ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith dflags span $ + ptext (sLit "cannot find object file for module ") <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = ptext (sLit "while linking an interpreted expression") + + -- This one is a build-system bug + + get_linkable osuf mod_name -- A home-package module + | Just mod_info <- lookupUFM hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name + where + found loc mod = do { + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} + + adjust_linkable lnk + | Just new_osuf <- replace_osuf = do + new_uls <- mapM (adjust_ul new_osuf) + (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul new_osuf (DotO file) = do + MASSERT(osuf `isSuffixOf` file) + let file_base = dropTail (length osuf + 1) file + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith dflags span $ + ptext (sLit "cannot find normal object file ") + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) + adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) + adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) + adjust_ul _ l@(BCOs {}) = return l + + +{- ********************************************************************** + + Loading a Decls statement + + ********************************************************************* -} + +linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue] +linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do + -- Initialise the linker (if it's not been done already) + let dflags = hsc_dflags hsc_env + initDynLinker dflags + + -- Take lock for the actual work. + modifyPLS $ \pls0 -> do + + -- Link the packages and modules required + (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + if failed ok + then throwGhcExceptionIO (ProgramError "") + else do + + -- Link the expression itself + let ie = plusNameEnv (itbl_env pls) itblEnv + ce = closure_env pls + + -- Link the necessary packages and linkables + (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs + let pls2 = pls { closure_env = final_gce, + itbl_env = ie } + return (pls2, ()) --hvals) + where + free_names = concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + + +{- ********************************************************************** + + Loading a single module + + ********************************************************************* -} + +linkModule :: HscEnv -> Module -> IO () +linkModule hsc_env mod = do + initDynLinker (hsc_dflags hsc_env) + modifyPLS_ $ \pls -> do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] + if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") + else return pls' + +{- ********************************************************************** + + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules + + ********************************************************************* -} + +linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +linkModules dflags pls linkables + = mask_ $ do -- don't want to be interrupted by ^C in here + + let (objs, bcos) = partition isObjectLinkable + (concatMap partitionLinkable linkables) + + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- dynLinkObjs dflags pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs dflags pls1 bcos + return (pls2, Succeeded) + + +-- HACK to support f-x-dynamic in the interpreter; no other purpose +partitionLinkable :: Linkable -> [Linkable] +partitionLinkable li + = let li_uls = linkableUnlinked li + li_uls_obj = filter isObject li_uls + li_uls_bco = filter isInterpretable li_uls + in + case (li_uls_obj, li_uls_bco) of + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [li] + +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable +findModuleLinkable_maybe lis mod + = case [LM time nm us | LM time nm us <- lis, nm == mod] of + [] -> Nothing + [li] -> Just li + _ -> pprPanic "findModuleLinkable" (ppr mod) + +linkableInSet :: Linkable -> [Linkable] -> Bool +linkableInSet l objs_loaded = + case findModuleLinkable_maybe objs_loaded (linkableModule l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m + + +{- ********************************************************************** + + The object-code linker + + ********************************************************************* -} + +dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +dynLinkObjs dflags pls objs = do + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + wanted_objs = map nameOfObject unlinkeds + + if dynamicGhc + then do pls2 <- dynLoadObjs dflags pls1 wanted_objs + return (pls2, Succeeded) + else do mapM_ loadObj wanted_objs + + -- Link them all together + ok <- resolveObjs + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + return (pls1, Succeeded) + else do + pls2 <- unload_wkr dflags [] pls1 + return (pls2, Failed) + + +dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath] + -> IO PersistentLinkerState +dynLoadObjs _ pls [] = return pls +dynLoadObjs dflags pls objs = do + let platform = targetPlatform dflags + (soFile, libPath , libName) <- newTempLibName dflags (soExt platform) + let -- When running TH for a non-dynamic way, we still need to make + -- -l flags to link against the dynamic libraries, so we turn + -- Opt_Static off + dflags1 = gopt_unset dflags Opt_Static + dflags2 = dflags1 { + -- We don't want the original ldInputs in + -- (they're already linked in), but we do want + -- to link against previous dynLoadObjs + -- libraries if there were any, so that the linker + -- can resolve dependencies when it loads this + -- library. + ldInputs = + concatMap + (\(lp, l) -> + [ Option ("-L" ++ lp) + , Option ("-Wl,-rpath") + , Option ("-Wl," ++ lp) + , Option ("-l" ++ l) + ]) + (temp_sos pls), + -- Even if we're e.g. profiling, we still want + -- the vanilla dynamic libraries, so we set the + -- ways / build tag to be just WayDyn. + ways = [WayDyn], + buildTag = mkBuildTag [WayDyn], + outputFile = Just soFile + } + -- link all "loaded packages" so symbols in those can be resolved + -- Note: We are loading packages with local scope, so to see the + -- symbols in this link we must link all loaded packages again. + linkDynLib dflags2 objs (pkgs_loaded pls) + consIORef (filesToNotIntermediateClean dflags) soFile + m <- loadDLL soFile + case m of + Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls } + Just err -> panic ("Loading temp shared object failed: " ++ err) + +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) +rmDupLinkables already ls + = go already [] ls + where + go already extras [] = (already, extras) + go already extras (l:ls) + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls + +{- ********************************************************************** + + The byte-code linker + + ********************************************************************* -} + + +dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO PersistentLinkerState +dynLinkBCOs dflags pls bcos = do + + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] + ies = [ie | ByteCode _ ie <- cbcs] + gce = closure_env pls + final_ie = foldr plusNameEnv (itbl_env pls) ies + + (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos + -- XXX What happens to these linked_bcos? + + let pls2 = pls1 { closure_env = final_gce, + itbl_env = final_ie } + + return pls2 + +-- Link a bunch of BCOs and return them + updated closure env. +linkSomeBCOs :: DynFlags + -> Bool -- False <=> add _all_ BCOs to returned closure env + -- True <=> add only toplevel BCOs to closure env + -> ItblEnv + -> ClosureEnv + -> [UnlinkedBCO] + -> IO (ClosureEnv, [HValue]) + -- The returned HValues are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + +linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos + = do let nms = map unlinkedBCOName ul_bcos + hvals <- fixIO + ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) + in mapM (linkBCO dflags ie ce_out) ul_bcos ) + let ce_all_additions = zip nms hvals + ce_top_additions = filter (isExternalName.fst) ce_all_additions + ce_additions = if toplevs_only then ce_top_additions + else ce_all_additions + ce_out = -- make sure we're not inserting duplicate names into the + -- closure environment, which leads to trouble. + ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + extendClosureEnv ce_in ce_additions + return (ce_out, hvals) + + +{- ********************************************************************** + + Unload some object modules + + ********************************************************************* -} + +-- --------------------------------------------------------------------------- +-- | Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers \"stable\", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one -- the user may have +-- recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. +-- +unload :: DynFlags + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () +unload dflags linkables + = mask_ $ do -- mask, so we're safe from Ctrl-C in here + + -- Initialise the linker (if it's not been done already) + initDynLinker dflags + + new_pls + <- modifyPLS $ \pls -> do + pls1 <- unload_wkr dflags linkables pls + return (pls1, pls1) + + debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) + debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + return () + +unload_wkr :: DynFlags + -> [Linkable] -- stable linkables + -> PersistentLinkerState + -> IO PersistentLinkerState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the PLS get and put) + +unload_wkr _ linkables pls + = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables + + objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) + bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) + + let bcos_retained = map linkableModule bcos_loaded' + itbl_env' = filterNameMap bcos_retained (itbl_env pls) + closure_env' = filterNameMap bcos_retained (closure_env pls) + new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = bcos_loaded', + objs_loaded = objs_loaded' } + + return new_pls + where + maybeUnload :: [Linkable] -> Linkable -> IO Bool + maybeUnload keep_linkables lnk + | linkableInSet lnk keep_linkables = return True + -- We don't do any cleanup when linking objects with the dynamic linker. + -- Doing so introduces extra complexity for not much benefit. + | dynamicGhc = return False + | otherwise + = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + return False + +{- ********************************************************************** + + Loading packages + + ********************************************************************* -} + +data LibrarySpec + = Object FilePath -- Full path name of a .o file, including trailing .o + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | Archive FilePath -- Full path name of a .a file, including trailing .a + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On WinDoze "burble" denotes "burble.DLL" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently + + | DLLPath FilePath -- Absolute or relative pathname to a dynamic library + -- (ends with .dll or .so). + + | Framework String -- Only used for darwin, but does no harm + +-- If this package is already part of the GHCi binary, we'll already +-- have the right DLLs for this package loaded, so don't try to +-- load them again. +-- +-- But on Win32 we must load them 'again'; doing so is a harmless no-op +-- as far as the loader is concerned, but it does initialise the list +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library +-- just to get the DLL handle into the list. +partOfGHCi :: [PackageName] +partOfGHCi + | isWindowsHost || isDarwinHost = [] + | otherwise = map (PackageName . mkFastString) + ["base", "template-haskell", "editline"] + +showLS :: LibrarySpec -> String +showLS (Object nm) = "(static) " ++ nm +showLS (Archive nm) = "(static archive) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm +showLS (Framework nm) = "(framework) " ++ nm + +-- | Link exactly the specified packages, and their dependents (unless of +-- course they are already linked). The dependents are linked +-- automatically, and it doesn't matter what order you specify the input +-- packages. +-- +linkPackages :: DynFlags -> [PackageKey] -> IO () +-- NOTE: in fact, since each module tracks all the packages it depends on, +-- we don't really need to use the package-config dependencies. +-- +-- However we do need the package-config stuff (to find aux libs etc), +-- and following them lets us load libraries in the right order, which +-- perhaps makes the error message a bit more localised if we get a link +-- failure. So the dependency walking code is still here. + +linkPackages dflags new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + initDynLinker dflags + modifyPLS_ $ \pls -> do + linkPackages' dflags new_pkgs pls + +linkPackages' :: DynFlags -> [PackageKey] -> PersistentLinkerState + -> IO PersistentLinkerState +linkPackages' dflags new_pks pls = do + pkgs' <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' } + where + link :: [PackageKey] -> [PackageKey] -> IO [PackageKey] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + link_one pkgs new_pkg + | new_pkg `elem` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupPackage dflags new_pkg + = do { -- Link dependents first + pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid + | ipid <- depends pkg_cfg ] + -- Now link the package itself + ; linkPackage dflags pkg_cfg + ; return (new_pkg : pkgs') } + + | otherwise + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageKeyString new_pkg)) + + +linkPackage :: DynFlags -> PackageConfig -> IO () +linkPackage dflags pkg + = do + let platform = targetPlatform dflags + dirs = Packages.libraryDirs pkg + + let hs_libs = Packages.hsLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- compiler/ghci/Linker.lhs + rts/Linker.c link the + -- interpreted references to FFI to the compiled FFI. + -- We therefore filter it out so that we don't get + -- duplicate symbol errors. + hs_libs' = filter ("HSffi" /=) hs_libs + + -- Because of slight differences between the GHC dynamic linker and + -- the native system linker some packages have to link with a + -- different list of libraries when using GHCi. Examples include: libs + -- that are actually gnu ld scripts, and the possability that the .a + -- libs do not exactly match the .so/.dll equivalents. So if the + -- package file provides an "extra-ghci-libraries" field then we use + -- that instead of the "extra-libraries" field. + extra_libs = + (if null (Packages.extraGHCiLibraries pkg) + then Packages.extraLibraries pkg + else Packages.extraGHCiLibraries pkg) + ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] + + hs_classifieds <- mapM (locateLib dflags True dirs) hs_libs' + extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs + let classifieds = hs_classifieds ++ extra_classifieds + + -- Complication: all the .so's must be loaded before any of the .o's. + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] + + maybePutStr dflags + ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") + + -- See comments with partOfGHCi + when (packageName pkg `notElem` partOfGHCi) $ do + loadFrameworks platform pkg + mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls) + + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ loadObj objs + mapM_ loadArchive archs + + maybePutStr dflags "linking ... " + ok <- resolveObjs + if succeeded ok + then maybePutStrLn dflags "done." + else let errmsg = "unable to load package `" + ++ sourcePackageIdString pkg ++ "'" + in throwGhcExceptionIO (InstallationError errmsg) + +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +-- +load_dyn :: FilePath -> IO () +load_dyn dll = do r <- loadDLL dll + case r of + Nothing -> return () + Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")" )) + +loadFrameworks :: Platform -> PackageConfig -> IO () +loadFrameworks platform pkg + = if platformUsesFrameworks platform + then mapM_ load frameworks + else return () + where + fw_dirs = Packages.frameworkDirs pkg + frameworks = Packages.frameworks pkg + + load fw = do r <- loadFramework fw_dirs fw + case r of + Nothing -> return () + Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" )) + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume that addDLL in the RTS can find it, +-- which generally means that it should be a dynamic library in the +-- standard system search path. + +locateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec +locateLib dflags is_hs dirs lib + | not is_hs + -- For non-Haskell libraries (e.g. gmp, iconv): + -- first look in library-dirs for a dynamic library (libfoo.so) + -- then look in library-dirs for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path + -- for a dynamic library (#5289) + -- otherwise, assume loadDLL can find it + -- + = findDll `orElse` findArchive `orElse` tryGcc `orElse` tryGccPrefixed `orElse` assumeDll + + | not dynamicGhc + -- When the GHC package was not compiled as dynamic library + -- (=DYNAMIC not set), we search for .o libraries or, if they + -- don't exist, .a libraries. + = findObject `orElse` findArchive `orElse` assumeDll + + | otherwise + -- When the GHC package was compiled as dynamic library (=DYNAMIC set), + -- we search for .so libraries first. + = findHSDll `orElse` findDynObject `orElse` assumeDll + where + mk_obj_path dir = dir (lib <.> "o") + mk_dyn_obj_path dir = dir (lib <.> "dyn_o") + mk_arch_path dir = dir ("lib" ++ lib <.> "a") + + hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags + mk_hs_dyn_lib_path dir = dir mkHsSOName platform hs_dyn_lib_name + + so_name = mkSOName platform lib + lib_so_name = "lib" ++ so_name + mk_dyn_lib_path dir = case (arch, os) of + (ArchX86_64, OSSolaris2) -> dir ("64/" ++ so_name) + _ -> dir so_name + + findObject = liftM (fmap Object) $ findFile mk_obj_path dirs + findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs + findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs + findHSDll = liftM (fmap DLLPath) $ findFile mk_hs_dyn_lib_path dirs + findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs + tryGcc = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs + tryGccPrefixed = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs + + assumeDll = return (DLL lib) + infixr `orElse` + f `orElse` g = do m <- f + case m of + Just x -> return x + Nothing -> g + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + +searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc dflags so dirs = do + -- GCC does not seem to extend the library search path (using -L) when using + -- --print-file-name. So instead pass it a new base location. + str <- askCc dflags (map (FileOption "-B") dirs + ++ [Option "--print-file-name", Option so]) + let file = case lines str of + [] -> "" + l:_ -> l + if (file == so) + then return Nothing + else return (Just file) + +-- ---------------------------------------------------------------------------- +-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + +-- Darwin / MacOS X only: load a framework +-- a framework is a dynamic library packaged inside a directory of the same +-- name. They are searched for in different paths than normal libraries. +loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) +loadFramework extraPaths rootname + = do { either_dir <- tryIO getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir ++ "/Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; mb_fwk <- findFile mk_fwk ps + ; case mb_fwk of + Just fwk_path -> loadDLL fwk_path + Nothing -> return (Just "not found") } + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up + where + mk_fwk dir = dir (rootname ++ ".framework/" ++ rootname) + -- sorry for the hardcoded paths, I hope they won't change anytime soon: + defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] + +{- ********************************************************************** + + Helper functions + + ********************************************************************* -} + +findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path + -> [FilePath] -- Directories to look in + -> IO (Maybe FilePath) -- The first file path to match +findFile _ [] = return Nothing +findFile mk_file_path (dir : dirs) + = do let file_path = mk_file_path dir + b <- doesFileExist file_path + if b then return (Just file_path) + else findFile mk_file_path dirs + +maybePutStr :: DynFlags -> String -> IO () +maybePutStr dflags s + = when (verbosity dflags > 1) $ + do let act = log_action dflags + act dflags SevInteractive noSrcSpan defaultUserStyle (text s) + +maybePutStrLn :: DynFlags -> String -> IO () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") + +{- ********************************************************************** + + Tunneling global variables into new instance of GHC library + + ********************************************************************* -} + +saveLinkerGlobals :: IO (MVar PersistentLinkerState, Bool) +saveLinkerGlobals = liftM2 (,) (readIORef v_PersistentLinkerState) (readIORef v_InitLinkerDone) + +restoreLinkerGlobals :: (MVar PersistentLinkerState, Bool) -> IO () +restoreLinkerGlobals (pls, ild) = do + writeIORef v_PersistentLinkerState pls + writeIORef v_InitLinkerDone ild diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs new file mode 100644 index 00000000..c9cf78cc --- /dev/null +++ b/compiler/ghci/ObjLink.hs @@ -0,0 +1,118 @@ +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- --------------------------------------------------------------------------- +-- The dynamic linker for object code (.o .so .dll files) +-- --------------------------------------------------------------------------- + +-- | Primarily, this module consists of an interface to the C-land +-- dynamic linker. +module ObjLink ( + initObjLinker, -- :: IO () + loadDLL, -- :: String -> IO (Maybe String) + loadArchive, -- :: String -> IO () + loadObj, -- :: String -> IO () + unloadObj, -- :: String -> IO () + insertSymbol, -- :: String -> String -> Ptr a -> IO () + lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) + resolveObjs -- :: IO SuccessFlag + ) where + +import Panic +import BasicTypes ( SuccessFlag, successIf ) +import Config ( cLeadingUnderscore ) +import Util + +import Control.Monad ( when ) +import Foreign.C +import Foreign ( nullPtr ) +import GHC.Exts ( Ptr(..) ) +import System.Posix.Internals ( CFilePath, withFilePath ) +import System.FilePath ( dropExtension ) + + +-- --------------------------------------------------------------------------- +-- RTS Linker Interface +-- --------------------------------------------------------------------------- + +insertSymbol :: String -> String -> Ptr a -> IO () +insertSymbol obj_name key symbol + = let str = prefixUnderscore key + in withFilePath obj_name $ \c_obj_name -> + withCAString str $ \c_str -> + c_insertSymbol c_obj_name c_str symbol + +lookupSymbol :: String -> IO (Maybe (Ptr a)) +lookupSymbol str_in = do + let str = prefixUnderscore str_in + withCAString str $ \c_str -> do + addr <- c_lookupSymbol c_str + if addr == nullPtr + then return Nothing + else return (Just addr) + +prefixUnderscore :: String -> String +prefixUnderscore + | cLeadingUnderscore == "YES" = ('_':) + | otherwise = id + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +loadDLL :: String -> IO (Maybe String) +-- Nothing => success +-- Just err_msg => failure +loadDLL str0 = do + let + -- On Windows, addDLL takes a filename without an extension, because + -- it tries adding both .dll and .drv. To keep things uniform in the + -- layers above, loadDLL always takes a filename with an extension, and + -- we drop it here on Windows only. + str | isWindowsHost = dropExtension str0 + | otherwise = str0 + -- + maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll + if maybe_errmsg == nullPtr + then return Nothing + else do str <- peekCString maybe_errmsg + return (Just str) + +loadArchive :: String -> IO () +loadArchive str = do + withFilePath str $ \c_str -> do + r <- c_loadArchive c_str + when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) + +loadObj :: String -> IO () +loadObj str = do + withFilePath str $ \c_str -> do + r <- c_loadObj c_str + when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) + +unloadObj :: String -> IO () +unloadObj str = + withFilePath str $ \c_str -> do + r <- c_unloadObj c_str + when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) + +resolveObjs :: IO SuccessFlag +resolveObjs = do + r <- c_resolveObjs + return (successIf (r /= 0)) + +-- --------------------------------------------------------------------------- +-- Foreign declarations to RTS entry points which does the real work; +-- --------------------------------------------------------------------------- + +foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString +foreign import ccall unsafe "initLinker" initObjLinker :: IO () +foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () +foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) +foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int +foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int +foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int +foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs new file mode 100644 index 00000000..56efbb8f --- /dev/null +++ b/compiler/ghci/RtClosureInspect.hs @@ -0,0 +1,1287 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- +-- GHC Interactive support for inspecting arbitrary closures at runtime +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- +module RtClosureInspect( + cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term + cvReconstructType, + improveRTTIType, + + Term(..), + isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap, + isFullyEvaluated, isFullyEvaluatedTerm, + termType, mapTermType, termTyVars, + foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold, + pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter, + +-- unsafeDeepSeq, + + Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection + ) where + +#include "HsVersions.h" + +import DebuggerUtils +import ByteCodeItbls ( StgInfoTable, peekItbl ) +import qualified ByteCodeItbls as BCI( StgInfoTable(..) ) +import BasicTypes ( HValue ) +import HscTypes + +import DataCon +import Type +import qualified Unify as U +import Var +import TcRnMonad +import TcType +import TcMType +import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv ) +import TcUnify +import TcEnv + +import TyCon +import Name +import VarEnv +import Util +import VarSet +import BasicTypes ( TupleSort(UnboxedTuple) ) +import TysPrim +import PrelNames +import TysWiredIn +import DynFlags +import Outputable as Ppr +import GHC.Arr ( Array(..) ) +import GHC.Exts +import GHC.IO ( IO(..) ) + +import StaticFlags( opt_PprStyle_Debug ) +import Control.Monad +import Data.Maybe +import Data.Array.Base +import Data.Ix +import Data.List +import qualified Data.Sequence as Seq +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid (mappend) +#endif +import Data.Sequence (viewl, ViewL(..)) +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif +import System.IO.Unsafe + +--------------------------------------------- +-- * A representation of semi evaluated Terms +--------------------------------------------- + +data Term = Term { ty :: RttiType + , dc :: Either String DataCon + -- Carries a text representation if the datacon is + -- not exported by the .hi file, which is the case + -- for private constructors in -O0 compiled libraries + , val :: HValue + , subTerms :: [Term] } + + | Prim { ty :: RttiType + , value :: [Word] } + + | Suspension { ctype :: ClosureType + , ty :: RttiType + , val :: HValue + , bound_to :: Maybe Name -- Useful for printing + } + | NewtypeWrap{ -- At runtime there are no newtypes, and hence no + -- newtype constructors. A NewtypeWrap is just a + -- made-up tag saying "heads up, there used to be + -- a newtype constructor here". + ty :: RttiType + , dc :: Either String DataCon + , wrapped_term :: Term } + | RefWrap { -- The contents of a reference + ty :: RttiType + , wrapped_term :: Term } + +isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool +isTerm Term{} = True +isTerm _ = False +isSuspension Suspension{} = True +isSuspension _ = False +isPrim Prim{} = True +isPrim _ = False +isNewtypeWrap NewtypeWrap{} = True +isNewtypeWrap _ = False + +isFun Suspension{ctype=Fun} = True +isFun _ = False + +isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty +isFunLike _ = False + +termType :: Term -> RttiType +termType t = ty t + +isFullyEvaluatedTerm :: Term -> Bool +isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt +isFullyEvaluatedTerm Prim {} = True +isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm _ = False + +instance Outputable (Term) where + ppr t | Just doc <- cPprTerm cPprTermBase t = doc + | otherwise = panic "Outputable Term instance" + +------------------------------------------------------------------------- +-- Runtime Closure Datatype and functions for retrieving closure related stuff +------------------------------------------------------------------------- +data ClosureType = Constr + | Fun + | Thunk Int + | ThunkSelector + | Blackhole + | AP + | PAP + | Indirection Int + | MutVar Int + | MVar Int + | Other Int + deriving (Show, Eq) + +data Closure = Closure { tipe :: ClosureType + , infoPtr :: Ptr () + , infoTable :: StgInfoTable + , ptrs :: Array Int HValue + , nonPtrs :: [Word] + } + +instance Outputable ClosureType where + ppr = text . show + +#include "../includes/rts/storage/ClosureTypes.h" + +aP_CODE, pAP_CODE :: Int +aP_CODE = AP +pAP_CODE = PAP +#undef AP +#undef PAP + +getClosureData :: DynFlags -> a -> IO Closure +getClosureData dflags a = + case unpackClosure# a of + (# iptr, ptrs, nptrs #) -> do + let iptr' + | ghciTablesNextToCode = + Ptr iptr + | otherwise = + -- the info pointer we get back from unpackClosure# + -- is to the beginning of the standard info table, + -- but the Storable instance for info tables takes + -- into account the extra entry pointer when + -- !ghciTablesNextToCode, so we must adjust here: + Ptr iptr `plusPtr` negate (wORD_SIZE dflags) + itbl <- peekItbl dflags iptr' + let tipe = readCType (BCI.tipe itbl) + elems = fromIntegral (BCI.ptrs itbl) + ptrsList = Array 0 (elems - 1) elems ptrs + nptrs_data = [W# (indexWordArray# nptrs i) + | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ] + ASSERT(elems >= 0) return () + ptrsList `seq` + return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) + +readCType :: Integral a => a -> ClosureType +readCType i + | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr + | i >= FUN && i <= FUN_STATIC = Fun + | i >= THUNK && i < THUNK_SELECTOR = Thunk i' + | i == THUNK_SELECTOR = ThunkSelector + | i == BLACKHOLE = Blackhole + | i >= IND && i <= IND_STATIC = Indirection i' + | i' == aP_CODE = AP + | i == AP_STACK = AP + | i' == pAP_CODE = PAP + | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i' + | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' + | otherwise = Other i' + where i' = fromIntegral i + +isConstr, isIndirection, isThunk :: ClosureType -> Bool +isConstr Constr = True +isConstr _ = False + +isIndirection (Indirection _) = True +isIndirection _ = False + +isThunk (Thunk _) = True +isThunk ThunkSelector = True +isThunk AP = True +isThunk _ = False + +isFullyEvaluated :: DynFlags -> a -> IO Bool +isFullyEvaluated dflags a = do + closure <- getClosureData dflags a + case tipe closure of + Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) + return$ and are_subs_evaluated + _ -> return False + where amapM f = sequence . amap' f + +-- TODO: Fix it. Probably the otherwise case is failing, trace/debug it +{- +unsafeDeepSeq :: a -> b -> b +unsafeDeepSeq = unsafeDeepSeq1 2 + where unsafeDeepSeq1 0 a b = seq a $! b + unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks + | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b + -- | unsafePerformIO (isFullyEvaluated a) = b + | otherwise = case unsafePerformIO (getClosureData a) of + closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure) + where tipe = unsafePerformIO (getClosureType a) +-} + +----------------------------------- +-- * Traversals for Terms +----------------------------------- +type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b + +data TermFold a = TermFold { fTerm :: TermProcessor a a + , fPrim :: RttiType -> [Word] -> a + , fSuspension :: ClosureType -> RttiType -> HValue + -> Maybe Name -> a + , fNewtypeWrap :: RttiType -> Either String DataCon + -> a -> a + , fRefWrap :: RttiType -> a -> a + } + + +data TermFoldM m a = + TermFoldM {fTermM :: TermProcessor a (m a) + , fPrimM :: RttiType -> [Word] -> m a + , fSuspensionM :: ClosureType -> RttiType -> HValue + -> Maybe Name -> m a + , fNewtypeWrapM :: RttiType -> Either String DataCon + -> a -> m a + , fRefWrapM :: RttiType -> a -> m a + } + +foldTerm :: TermFold a -> Term -> a +foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) +foldTerm tf (Prim ty v ) = fPrim tf ty v +foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b +foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) +foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) + + +foldTermM :: Monad m => TermFoldM m a -> Term -> m a +foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v +foldTermM tf (Prim ty v ) = fPrimM tf ty v +foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b +foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc +foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty + +idTermFold :: TermFold Term +idTermFold = TermFold { + fTerm = Term, + fPrim = Prim, + fSuspension = Suspension, + fNewtypeWrap = NewtypeWrap, + fRefWrap = RefWrap + } + +mapTermType :: (RttiType -> Type) -> Term -> Term +mapTermType f = foldTerm idTermFold { + fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, + fSuspension = \ct ty hval n -> + Suspension ct (f ty) hval n, + fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, + fRefWrap = \ty t -> RefWrap (f ty) t} + +mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term +mapTermTypeM f = foldTermM TermFoldM { + fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, + fPrimM = (return.) . Prim, + fSuspensionM = \ct ty hval n -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n, + fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, + fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} + +termTyVars :: Term -> TyVarSet +termTyVars = foldTerm TermFold { + fTerm = \ty _ _ tt -> + tyVarsOfType ty `plusVarEnv` concatVarEnv tt, + fSuspension = \_ ty _ _ -> tyVarsOfType ty, + fPrim = \ _ _ -> emptyVarEnv, + fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t, + fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t} + where concatVarEnv = foldr plusVarEnv emptyVarEnv + +---------------------------------- +-- Pretty printing of terms +---------------------------------- + +type Precedence = Int +type TermPrinter = Precedence -> Term -> SDoc +type TermPrinterM m = Precedence -> Term -> m SDoc + +app_prec,cons_prec, max_prec ::Int +max_prec = 10 +app_prec = max_prec +cons_prec = 5 -- TODO Extract this info from GHC itself + +pprTerm :: TermPrinter -> TermPrinter +pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc +pprTerm _ _ _ = panic "pprTerm" + +pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m +pprTermM y p t = pprDeeper `liftM` ppr_termM y p t + +ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do + tt_docs <- mapM (y app_prec) tt + return $ cparen (not (null tt) && p >= app_prec) + (text dc_tag <+> pprDeeperList fsep tt_docs) + +ppr_termM y p Term{dc=Right dc, subTerms=tt} +{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) +-} -- TODO Printing infix constructors properly + | null sub_terms_to_show + = return (ppr dc) + | otherwise + = do { tt_docs <- mapM (y app_prec) sub_terms_to_show + ; return $ cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } + where + sub_terms_to_show -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + | opt_PprStyle_Debug = tt + | otherwise = dropList (dataConTheta dc) tt + +ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t +ppr_termM y p RefWrap{wrapped_term=t} = do + contents <- y app_prec t + return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) + -- The constructor name is wired in here ^^^ for the sake of simplicity. + -- I don't think mutvars are going to change in a near future. + -- In any case this is solely a presentation matter: MutVar# is + -- a datatype with no constructors, implemented by the RTS + -- (hence there is no way to obtain a datacon and print it). +ppr_termM _ _ t = ppr_termM1 t + + +ppr_termM1 :: Monad m => Term -> m SDoc +ppr_termM1 Prim{value=words, ty=ty} = + return $ repPrim (tyConAppTyCon ty) words +ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = + return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) +ppr_termM1 Suspension{ty=ty, bound_to=Just n} +-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("") + | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty +ppr_termM1 Term{} = panic "ppr_termM1 - Term" +ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" +ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" + +pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} + | Just (tc,_) <- tcSplitTyConApp_maybe ty + , ASSERT(isNewTyCon tc) True + , Just new_dc <- tyConSingleDataCon_maybe tc = do + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) +pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" + +------------------------------------------------------- +-- Custom Term Pretty Printers +------------------------------------------------------- + +-- We can want to customize the representation of a +-- term depending on its type. +-- However, note that custom printers have to work with +-- type representations, instead of directly with types. +-- We cannot use type classes here, unless we employ some +-- typerep trickery (e.g. Weirich's RepLib tricks), +-- which I didn't. Therefore, this code replicates a lot +-- of what type classes provide for free. + +type CustomTermPrinter m = TermPrinterM m + -> [Precedence -> Term -> (m (Maybe SDoc))] + +-- | Takes a list of custom printers with a explicit recursion knot and a term, +-- and returns the output of the first successful printer, or the default printer +cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc +cPprTerm printers_ = go 0 where + printers = printers_ go + go prec t = do + let default_ = Just `liftM` pprTermM go prec t + mb_customDocs = [pp prec t | pp <- printers] ++ [default_] + Just doc <- firstJustM mb_customDocs + return$ cparen (prec>app_prec+1) doc + + firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) + firstJustM [] = return Nothing + +-- Default set of custom printers. Note that the recursion knot is explicit +cPprTermBase :: forall m. Monad m => CustomTermPrinter m +cPprTermBase y = + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + . mapM (y (-1)) + . subTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) + ppr_list + , ifTerm (isTyCon intTyCon . ty) ppr_int + , ifTerm (isTyCon charTyCon . ty) ppr_char + , ifTerm (isTyCon floatTyCon . ty) ppr_float + , ifTerm (isTyCon doubleTyCon . ty) ppr_double + , ifTerm (isIntegerTy . ty) ppr_integer + ] + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f prec t@Term{} + | pred t = Just `liftM` f prec t + ifTerm _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + isIntegerTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (tyConName tc == integerTyConName) + + ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer + :: Precedence -> Term -> m SDoc + ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) + ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') + ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v))) + ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v))) + ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v))) + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h : getListTerms t + isConsLast = not(termType(last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + + print_elems <- mapM (y cons_prec) elems + if is_string + then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" + + +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where + rep x + | t == charPrimTyCon = text $ show (build x :: Char) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = text "" + | t == stableNamePrimTyCon = text "" + | t == statePrimTyCon = text "" + | t == proxyPrimTyCon = text "" + | t == realWorldTyCon = text "" + | t == threadIdPrimTyCon = text "" + | t == weakPrimTyCon = text "" + | t == arrayPrimTyCon = text "" + | t == smallArrayPrimTyCon = text "" + | t == byteArrayPrimTyCon = text "" + | t == mutableArrayPrimTyCon = text "" + | t == smallMutableArrayPrimTyCon = text "" + | t == mutableByteArrayPrimTyCon = text "" + | t == mutVarPrimTyCon = text "" + | t == mVarPrimTyCon = text "" + | t == tVarPrimTyCon = text "" + | otherwise = char '<' <> ppr t <> char '>' + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. + +----------------------------------- +-- Type Reconstruction +----------------------------------- +{- +Type Reconstruction is type inference done on heap closures. +The algorithm walks the heap generating a set of equations, which +are solved with syntactic unification. +A type reconstruction equation looks like: + + = + +The full equation set is generated by traversing all the subterms, starting +from a given term. + +The only difficult part is that newtypes are only found in the lhs of equations. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. + +The function congruenceNewtypes takes a shot at (b) +-} + + +-- A (non-mutable) tau type containing +-- existentially quantified tyvars. +-- (since GHC type language currently does not support +-- existentials, we leave these variables unquantified) +type RttiType = Type + +-- An incomplete type as stored in GHCi: +-- no polymorphism: no quantifiers & all tyvars are skolem. +type GhciType = Type + + +-- The Type Reconstruction monad +-------------------------------- +type TR a = TcM a + +runTR :: HscEnv -> TR a -> IO a +runTR hsc_env thing = do + mb_val <- runTR_maybe hsc_env thing + case mb_val of + Nothing -> error "unable to :print the term" + Just x -> return x + +runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) +runTR_maybe hsc_env thing_inside + = do { (_errs, res) <- initTcInteractive hsc_env thing_inside + ; return res } + +-- | Term Reconstruction trace +traceTR :: SDoc -> TR () +traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti + + +-- Semantically different to recoverM in TcRnMonad +-- recoverM retains the errors in the first action, +-- whereas recoverTc here does not +recoverTR :: TR a -> TR a -> TR a +recoverTR recover thing = do + (_,mb_res) <- tryTcErrs thing + case mb_res of + Nothing -> recover + Just res -> return res + +trIO :: IO a -> TR a +trIO = liftTcM . liftIO + +liftTcM :: TcM a -> TR a +liftTcM = id + +newVar :: Kind -> TR TcType +newVar = liftTcM . newFlexiTyVarTy + +instTyVars :: [TyVar] -> TR (TvSubst, [TcTyVar]) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars = liftTcM . tcInstTyVars + +type RttiInstantiation = [(TcTyVar, TyVar)] + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their + -- debugger-world RuntimeUnk counterparts. + -- If the TcTyVar has not been refined by the runtime type + -- elaboration, then we want to turn it back into the + -- original RuntimeUnk + +-- | Returns the instantiated type scheme ty', and the +-- mapping from new (instantiated) -to- old (skolem) type variables +instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) +instScheme (tvs, ty) + = liftTcM $ do { (subst, tvs') <- tcInstTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; return (substTy subst ty, rtti_inst) } + +applyRevSubst :: RttiInstantiation -> TR () +-- Apply the *reverse* substitution in-place to any un-filled-in +-- meta tyvars. This recovers the original debugger-world variable +-- unless it has been refined by new information from the heap +applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) + where + do_pair (tc_tv, rtti_tv) + = do { tc_ty <- zonkTcTyVar tc_tv + ; case tcGetTyVar_maybe tc_ty of + Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) + _ -> return () } + +-- Adds a constraint of the form t1 == t2 +-- t1 is expected to come from walking the heap +-- t2 is expected to come from a datacon signature +-- Before unification, congruenceNewtypes needs to +-- do its magic. +addConstraint :: TcType -> TcType -> TR () +addConstraint actual expected = do + traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) + recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, + text "with", ppr expected]) $ + do { (ty1, ty2) <- congruenceNewtypes actual expected + ; _ <- captureConstraints $ unifyType ty1 ty2 + ; return () } + -- TOMDO: what about the coercion? + -- we should consider family instances + + +-- Type & Term reconstruction +------------------------------ +cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term +cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do + -- we quantify existential tyvars as universal, + -- as this is needed to be able to manipulate + -- them properly + let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty + sigma_old_ty = mkForAllTys old_tvs old_tau + traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) + term <- + if null old_tvs + then do + term <- go max_depth sigma_old_ty sigma_old_ty hval + term' <- zonkTerm term + return $ fixFunDictionaries $ expandNewtypes term' + else do + (old_ty', rev_subst) <- instScheme quant_old_ty + my_ty <- newVar openTypeKind + when (check1 quant_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + term <- go max_depth my_ty sigma_old_ty hval + new_ty <- zonkTcType (termType term) + if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty + then do + traceTR (text "check2 passed") + addConstraint new_ty old_ty' + applyRevSubst rev_subst + zterm' <- zonkTerm term + return ((fixFunDictionaries . expandNewtypes) zterm') + else do + traceTR (text "check2 failed" <+> parens + (ppr term <+> text "::" <+> ppr new_ty)) + -- we have unsound types. Replace constructor types in + -- subterms with tyvars + zterm' <- mapTermTypeM + (\ty -> case tcSplitTyConApp_maybe ty of + Just (tc, _:_) | tc /= funTyCon + -> newVar openTypeKind + _ -> return ty) + term + zonkTerm zterm' + traceTR (text "Term reconstruction completed." $$ + text "Term obtained: " <> ppr term $$ + text "Type obtained: " <> ppr (termType term)) + return term + where + dflags = hsc_dflags hsc_env + + go :: Int -> Type -> Type -> HValue -> TcM Term + -- I believe that my_ty should not have any enclosing + -- foralls, nor any free RuntimeUnk skolems; + -- that is partly what the quantifyType stuff achieved + -- + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + + go max_depth _ _ _ | seq max_depth False = undefined + go 0 my_ty _old_ty a = do + traceTR (text "Gave up reconstructing a term after" <> + int max_depth <> text " steps") + clos <- trIO $ getClosureData dflags a + return (Suspension (tipe clos) my_ty a Nothing) + go max_depth my_ty old_ty a = do + let monomorphic = not(isTyVarTy my_ty) + -- This ^^^ is a convention. The ancestor tests for + -- monomorphism and passes a type instead of a tv + clos <- trIO $ getClosureData dflags a + case tipe clos of +-- Thunks we may want to force + t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> + seq a (go (pred max_depth) my_ty old_ty a) +-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we +-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up +-- showing '_' which is what we want. + Blackhole -> do traceTR (text "Following a BLACKHOLE") + appArr (go max_depth my_ty old_ty) (ptrs clos) 0 +-- We always follow indirections + Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) ) + go max_depth my_ty old_ty $! (ptrs clos ! 0) +-- We also follow references + MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + -> do + -- Deal with the MutVar# primitive + -- It does not have a constructor at all, + -- so we simulate the following one + -- MutVar# :: contents_ty -> MutVar# s contents_ty + traceTR (text "Following a MutVar") + contents_tv <- newVar liftedTypeKind + contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w + ASSERT(isUnliftedTypeKind $ typeKind my_ty) return () + (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy + contents_ty (mkTyConApp tycon [world,contents_ty]) + addConstraint (mkFunTy contents_tv my_ty) mutvar_ty + x <- go (pred max_depth) contents_tv contents_ty contents + return (RefWrap my_ty x) + + -- The interesting case + Constr -> do + traceTR (text "entering a constructor " <> + if monomorphic + then parens (text "already monomorphic: " <> ppr my_ty) + else Ppr.empty) + Right dcname <- dataConInfoPtrToName (infoPtr clos) + (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) + case mb_dc of + Nothing -> do -- This can happen for private constructors compiled -O0 + -- where the .hi descriptor does not export them + -- In such case, we return a best approximation: + -- ignore the unpointed args, and recover the pointeds + -- This preserves laziness, and should be safe. + traceTR (text "Not constructor" <+> ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname + vars <- replicateM (length$ elems$ ptrs clos) + (newVar liftedTypeKind) + subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i + | (i, tv) <- zip [0..] vars] + return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) + Just dc -> do + traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) + subTtypes <- getDataConArgTys dc my_ty + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes + return (Term my_ty (Right dc) a subTerms) + +-- The otherwise case: can be a Thunk,AP,PAP,etc. + tipe_clos -> + return (Suspension tipe_clos my_ty a Nothing) + + -- insert NewtypeWraps around newtypes + expandNewtypes = foldTerm idTermFold { fTerm = worker } where + worker ty dc hval tt + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , isNewTyCon tc + , wrapped_type <- newTyConInstRhs tc args + , Just dc' <- tyConSingleDataCon_maybe tc + , t' <- worker wrapped_type dc hval tt + = NewtypeWrap ty (Right dc') t' + | otherwise = Term ty dc hval tt + + + -- Avoid returning types where predicates have been expanded to dictionaries. + fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where + worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n + | otherwise = Suspension ct ty hval n + +extractSubTerms :: (Type -> HValue -> TcM Term) + -> Closure -> [Type] -> TcM [Term] +extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) + where + go ptr_i ws [] = return (ptr_i, ws, []) + go ptr_i ws (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case repType ty of + UnaryRep rep_ty -> do + (ptr_i, ws, term0) <- go_rep ptr_i ws ty (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, term0 : terms1) + UbxTupleRep rep_tys -> do + (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys + (ptr_i, ws, terms1) <- go ptr_i ws tys + return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i ws [] = return (ptr_i, ws, []) + go_unary_types ptr_i ws (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, ws, term0) <- go_rep ptr_i ws tv (typePrimRep rep_ty) + (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys + return (ptr_i, ws, term0 : terms1) + + go_rep ptr_i ws ty rep = case rep of + PtrRep -> do + t <- appArr (recurse ty) (ptrs clos) ptr_i + return (ptr_i + 1, ws, t) + _ -> do + dflags <- getDynFlags + let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws + return (ptr_i, ws1, Prim ty ws0) + + unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + + +-- Fast, breadth-first Type reconstruction +------------------------------------------ +cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type) +cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do + traceTR (text "RTTI started with initial type " <> ppr old_ty) + let sigma_old_ty@(old_tvs, _) = quantifyType old_ty + new_ty <- + if null old_tvs + then return old_ty + else do + (old_ty', rev_subst) <- instScheme sigma_old_ty + my_ty <- newVar openTypeKind + when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + search (isMonomorphic `fmap` zonkTcType my_ty) + (\(ty,a) -> go ty a) + (Seq.singleton (my_ty, hval)) + max_depth + new_ty <- zonkTcType my_ty + if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty + then do + traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) + addConstraint my_ty old_ty' + applyRevSubst rev_subst + zonkRttiType new_ty + else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> + return old_ty + traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) + return new_ty + where + dflags = hsc_dflags hsc_env + +-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () + search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> + int max_depth <> text " steps") + search stop expand l d = + case viewl l of + EmptyL -> return () + x :< xx -> unlessM stop $ do + new <- expand x + search stop expand (xx `mappend` Seq.fromList new) $! (pred d) + + -- returns unification tasks,since we are going to want a breadth-first search + go :: Type -> HValue -> TR [(Type, HValue)] + go my_ty a = do + traceTR (text "go" <+> ppr my_ty) + clos <- trIO $ getClosureData dflags a + case tipe clos of + Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO + Indirection _ -> go my_ty $! (ptrs clos ! 0) + MutVar _ -> do + contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w + tv' <- newVar liftedTypeKind + world <- newVar liftedTypeKind + addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) + return [(tv', contents)] + Constr -> do + Right dcname <- dataConInfoPtrToName (infoPtr clos) + traceTR (text "Constr1" <+> ppr dcname) + (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) + case mb_dc of + Nothing-> do + -- TODO: Check this case + forM [0..length (elems $ ptrs clos)] $ \i -> do + tv <- newVar liftedTypeKind + return$ appArr (\e->(tv,e)) (ptrs clos) i + + Just dc -> do + arg_tys <- getDataConArgTys dc my_ty + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ [ appArr (\e-> (ty,e)) (ptrs clos) i + | (i,ty) <- itys] + _ -> return [] + +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case repType ty of + UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + UbxTupleRep rep_tys -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) rep_tys + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras) + + +-- Compute the difference between a base type and the type found by RTTI +-- improveType +-- The types can contain skolem type variables, which need to be treated as normal vars. +-- In particular, we want them to unify with things. +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst +improveRTTIType _ base_ty new_ty = U.tcUnifyTy base_ty new_ty + +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +-- +-- I believe that con_app_ty should not have any enclosing foralls +getDataConArgTys dc con_app_ty + = do { let UnaryRep rep_con_app_ty = repType con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) + ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) + ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) + -- See Note [Constructor arg types] + ; let con_arg_tys = substTys subst (dataConRepArgTys dc) + ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) + ; return con_arg_tys } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyVars dc + +{- Note [Constructor arg types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a GADT (cf Trac #7386) + data family D a b + data instance D [a] a where + MkT :: a -> D [a] (Maybe a) + ... + +In getDataConArgTys +* con_app_ty is the known type (from outside) of the constructor application, + say D [Int] Int + +* The data constructor MkT has a (representation) dataConTyCon = DList, + say where + data DList a where + MkT :: a -> DList a (Maybe a) + ... + +So the dataConTyCon of the data constructor, DList, differs from +the "outside" type, D. So we can't straightforwardly decompose the +"outside" type, and we end up in the "_" branch of the case. + +Then we match the dataConOrigResTy of the data constructor against the +outside type, hoping to get a substitution that tells how to instantiate +the *representation* type constructor. This looks a bit delicate to +me, but it seems to work. +-} + +-- Soundness checks +-------------------- +{- +This is not formalized anywhere, so hold to your seats! +RTTI in the presence of newtypes can be a tricky and unsound business. + +Example: +~~~~~~~~~ +Suppose we are doing RTTI for a partially evaluated +closure t, the real type of which is t :: MkT Int, for + + newtype MkT a = MkT [Maybe a] + +The table below shows the results of RTTI and the improvement +calculated for different combinations of evaluatedness and :type t. +Regard the two first columns as input and the next two as output. + + # | t | :type t | rtti(t) | improv. | result + ------------------------------------------------------------ + 1 | _ | t b | a | none | OK + 2 | _ | MkT b | a | none | OK + 3 | _ | t Int | a | none | OK + + If t is not evaluated at *all*, we are safe. + + 4 | (_ : _) | t b | [a] | t = [] | UNSOUND + 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) + 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND + + If a is a minimal whnf, we run into trouble. Note that + row 5 above does newtype enrichment on the ty_rtty parameter. + + 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND + | | | b = Maybe a| + + 8 | (Just _:_)| MkT b | MkT a | none | OK + 9 | (Just _:_)| t Int | FAIL | none | OK + + And if t is any more evaluated than whnf, we are still in trouble. + Because constraints are solved in top-down order, when we reach the + Maybe subterm what we got is already unsound. This explains why the + row 9 fails to complete. + + 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK + 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK + + We can undo the failure in row 9 by leaving out the constraint + coming from the type signature of t (i.e., the 2nd column). + Note that this type information is still used + to calculate the improvement. But we fail + when trying to calculate the improvement, as there is no unifier for + t Int = [Maybe a] or t Int = [Maybe Int]. + + + Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] + + # | t | :type t | rtti(t) | improvement | result + --------------------------------------------------------------------- + 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | + | | | | b = Maybe a | + +The checks: +~~~~~~~~~~~ +Consider a function obtainType that takes a value and a type and produces +the Term representation and a substitution (the improvement). +Assume an auxiliar rtti' function which does the actual job if recovering +the type, but which may produce a false type. + +In pseudocode: + + rtti' :: a -> IO Type -- Does not use the static type information + + obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) + obtainType v old_ty = do + rtti_ty <- rtti' v + if monomorphic rtti_ty || (check rtti_ty old_ty) + then ... + else return Nothing + where check rtti_ty old_ty = check1 rtti_ty && + check2 rtti_ty old_ty + + check1 :: Type -> Bool + check2 :: Type -> Type -> Bool + +Now, if rtti' returns a monomorphic type, we are safe. +If that is not the case, then we consider two conditions. + + +1. To prevent the class of unsoundness displayed by + rows 4 and 7 in the example: no higher kind tyvars + accepted. + + check1 (t a) = NO + check1 (t Int) = NO + check1 ([] a) = YES + +2. To prevent the class of unsoundness shown by row 6, + the rtti type should be structurally more + defined than the old type we are comparing it to. + check2 :: NewType -> OldType -> Bool + check2 a _ = True + check2 [a] a = True + check2 [a] (t Int) = False + check2 [a] (t a) = False -- By check1 we never reach this equation + check2 [Int] a = True + check2 [Int] (t Int) = True + check2 [Maybe a] (t Int) = False + check2 [Maybe Int] (t Int) = True + check2 (Maybe [a]) (m [Int]) = False + check2 (Maybe [Int]) (m [Int]) = True + +-} + +check1 :: QuantifiedType -> Bool +check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) + where + isHigherKind = not . null . fst . splitKindFunTys + +check2 :: QuantifiedType -> QuantifiedType -> Bool +check2 (_, rtti_ty) (_, old_ty) + | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty + = case () of + _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty + -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) + _ | Just _ <- splitAppTy_maybe old_ty + -> isMonomorphicOnNonPhantomArgs rtti_ty + _ -> True + | otherwise = True + +-- Dealing with newtypes +-------------------------- +{- + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present + in runtime, but sometimes there is evidence available. + Evidence can come from DataCon signatures or + from compile-time type inference. + What we are doing here is an approximation + of unification modulo a set of equations derived + from newtype definitions. These equations should be the + same as the equality coercions generated for newtypes + in System Fc. The idea is to perform a sort of rewriting, + taking those equations as rules, before launching unification. + + The caller must ensure the following. + The 1st type (lhs) comes from the heap structure of ptrs,nptrs. + The 2nd type (rhs) comes from a DataCon type signature. + Rewriting (i.e. adding/removing a newtype wrapper) can happen + in both types, but in the rhs it is restricted to the result type. + + Note that it is very tricky to make this 'rewriting' + work with the unification implemented by TcM, where + substitutions are operationally inlined. The order in which + constraints are unified is vital as we cannot modify + anything that has been touched by a previous unification step. +Therefore, congruenceNewtypes is sound only if the types +recovered by the RTTI mechanism are unified Top-Down. +-} +congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) +congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') + where + go l r + -- TyVar lhs inductive case + | Just tv <- getTyVar_maybe l + , isTcTyVar tv + , isMetaTyVar tv + = recoverTR (return r) $ do + Indirect ty_v <- readMetaTyVar tv + traceTR $ fsep [text "(congruence) Following indirect tyvar:", + ppr tv, equals, ppr ty_v] + go ty_v r +-- FunTy inductive case + | Just (l1,l2) <- splitFunTy_maybe l + , Just (r1,r2) <- splitFunTy_maybe r + = do r2' <- go l2 r2 + r1' <- go l1 r1 + return (mkFunTy r1' r2') +-- TyconApp Inductive case; this is the interesting bit. + | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r + = upgrade tycon_l r + + | otherwise = return r + + where upgrade :: TyCon -> Type -> TR Type + upgrade new_tycon ty + | not (isNewTyCon new_tycon) = do + traceTR (text "(Upgrade) Not matching newtype evidence: " <> + ppr new_tycon <> text " for " <> ppr ty) + return ty + | otherwise = do + traceTR (text "(Upgrade) upgraded " <> ppr ty <> + text " in presence of newtype evidence " <> ppr new_tycon) + (_, vars) <- instTyVars (tyConTyVars new_tycon) + let ty' = mkTyConApp new_tycon (mkTyVarTys vars) + UnaryRep rep_ty = repType ty' + _ <- liftTcM (unifyType ty rep_ty) + -- assumes that reptype doesn't ^^^^ touch tyconApp args + return ty' + + +zonkTerm :: Term -> TcM Term +zonkTerm = foldTermM (TermFoldM + { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> + return (Term ty' dc v tt) + , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b) + , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> + return$ NewtypeWrap ty' dc t + , fRefWrapM = \ty t -> return RefWrap `ap` + zonkRttiType ty `ap` return t + , fPrimM = (return.) . Prim }) + +zonkRttiType :: TcType -> TcM Type +-- Zonk the type, replacing any unbound Meta tyvars +-- by skolems, safely out of Meta-tyvar-land +zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) + where + zonk_unbound_meta tv + = ASSERT( isTcTyVar tv ) + do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad + ; return (mkTyVarTy tv') } + +-------------------------------------------------------------------------------- +-- Restore Class predicates out of a representation type +dictsView :: Type -> Type +dictsView ty = ty + + +-- Use only for RTTI types +isMonomorphic :: RttiType -> Bool +isMonomorphic ty = noExistentials && noUniversals + where (tvs, _, ty') = tcSplitSigmaTy ty + noExistentials = isEmptyVarSet (tyVarsOfType ty') + noUniversals = null tvs + +-- Use only for RTTI types +isMonomorphicOnNonPhantomArgs :: RttiType -> Bool +isMonomorphicOnNonPhantomArgs ty + | UnaryRep rep_ty <- repType ty + , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty + , phantom_vars <- tyConPhantomTyVars tc + , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args + , tyv `notElem` phantom_vars] + = all isMonomorphicOnNonPhantomArgs concrete_args + | Just (ty1, ty2) <- splitFunTy_maybe ty + = all isMonomorphicOnNonPhantomArgs [ty1,ty2] + | otherwise = isMonomorphic ty + +tyConPhantomTyVars :: TyCon -> [TyVar] +tyConPhantomTyVars tc + | isAlgTyCon tc + , Just dcs <- tyConDataCons_maybe tc + , dc_vars <- concatMap dataConUnivTyVars dcs + = tyConTyVars tc \\ dc_vars +tyConPhantomTyVars _ = [] + +type QuantifiedType = ([TyVar], Type) + -- Make the free type variables explicit + -- The returned Type should have no top-level foralls (I believe) + +quantifyType :: Type -> QuantifiedType +-- Generalize the type: find all free and forall'd tyvars +-- and return them, together with the type inside, which +-- should not be a forall type. +-- +-- Thus (quantifyType (forall a. a->[b])) +-- returns ([a,b], a -> [b]) + +quantifyType ty = (varSetElems (tyVarsOfType rho), rho) + where + (_tvs, rho) = tcSplitForAllTys ty + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = condM >>= \c -> unless c acc + + +-- Strict application of f at index i +appArr :: Ix i => (e -> a) -> Array i e -> Int -> a +appArr f a@(Array _ _ _ ptrs#) i@(I# i#) + = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) + case indexArray# ptrs# i# of + (# e #) -> f e + +amap' :: (t -> b) -> Array Int t -> [b] +amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] + where g (I# i#) = case indexArray# arr# i# of + (# e #) -> f e diff --git a/compiler/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c new file mode 100644 index 00000000..23482335 --- /dev/null +++ b/compiler/ghci/keepCAFsForGHCi.c @@ -0,0 +1,15 @@ +#include "Rts.h" + +// This file is only included in the dynamic library. +// It contains an __attribute__((constructor)) function (run prior to main()) +// which sets the keepCAFs flag in the RTS, before any Haskell code is run. +// This is required so that GHCi can use dynamic libraries instead of HSxyz.o +// files. + +static void keepCAFsForGHCi(void) __attribute__((constructor)); + +static void keepCAFsForGHCi(void) +{ + keepCAFs = 1; +} + diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs new file mode 100644 index 00000000..8ffda3a9 --- /dev/null +++ b/compiler/hsSyn/Convert.hs @@ -0,0 +1,1295 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +This module converts Template Haskell syntax into HsSyn +-} + +{-# LANGUAGE CPP #-} + +module Convert( convertToHsExpr, convertToPat, convertToHsDecls, + convertToHsType, + thRdrNameGuesses ) where + +import HsSyn as Hs +import HsTypes ( mkHsForAllTy ) +import qualified Class +import RdrName +import qualified Name +import Module +import RdrHsSyn +import qualified OccName +import OccName +import SrcLoc +import Type +import qualified Coercion ( Role(..) ) +import TysWiredIn +import TysPrim (eqPrimTyCon) +import BasicTypes as Hs +import ForeignCall +import Unique +import ErrUtils +import Bag +import Lexeme +import Util +import FastString +import Outputable + +import qualified Data.ByteString as BS +import Control.Monad( unless, liftM, ap ) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +import Data.Char ( chr ) +import Data.Word ( Word8 ) +import Data.Maybe( catMaybes ) +import Language.Haskell.TH as TH hiding (sigP) +import Language.Haskell.TH.Syntax as TH + +------------------------------------------------------------------- +-- The external interface + +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] +convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) + where + cvt_dec d = wrapMsg "declaration" d (cvtDec d) + +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) +convertToHsExpr loc e + = initCvt loc $ wrapMsg "expression" e $ cvtl e + +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) +convertToPat loc p + = initCvt loc $ wrapMsg "pattern" p $ cvtPat p + +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) +convertToHsType loc t + = initCvt loc $ wrapMsg "type" t $ cvtType t + +------------------------------------------------------------------- +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } + -- Push down the source location; + -- Can fail, with a single error message + +-- NB: If the conversion succeeds with (Right x), there should +-- be no exception values hiding in x +-- Reason: so a (head []) in TH code doesn't subsequently +-- make GHC crash when it tries to walk the generated tree + +-- Use the loc everywhere, for lack of anything better +-- In particular, we want it on binding locations, so that variables bound in +-- the spliced-in declarations get a location that at least relates to the splice point + +instance Functor CvtM where + fmap = liftM + +instance Applicative CvtM where + pure = return + (<*>) = ap + +instance Monad CvtM where + return x = CvtM $ \loc -> Right (loc,x) + (CvtM m) >>= k = CvtM $ \loc -> case m loc of + Left err -> Left err + Right (loc',v) -> unCvtM (k v) loc' + +initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a +initCvt loc (CvtM m) = fmap snd (m loc) + +force :: a -> CvtM () +force a = a `seq` return () + +failWith :: MsgDoc -> CvtM a +failWith m = CvtM (\_ -> Left m) + +getL :: CvtM SrcSpan +getL = CvtM (\loc -> Right (loc,loc)) + +setL :: SrcSpan -> CvtM () +setL loc = CvtM (\_ -> Right (loc, ())) + +returnL :: a -> CvtM (Located a) +returnL x = CvtM (\loc -> Right (loc, L loc x)) + +returnJustL :: a -> CvtM (Maybe (Located a)) +returnJustL = fmap Just . returnL + +wrapParL :: (Located a -> a) -> a -> CvtM a +wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x))) + +wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b +-- E.g wrapMsg "declaration" dec thing +wrapMsg what item (CvtM m) + = CvtM (\loc -> case m loc of + Left err -> Left (err $$ getPprStyle msg) + Right v -> Right v) + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon) + 2 (if debugStyle sty + then text (show item) + else text (pprint item)) + +wrapL :: CvtM a -> CvtM (Located a) +wrapL (CvtM m) = CvtM (\loc -> case m loc of + Left err -> Left err + Right (loc',v) -> Right (loc',L loc v)) + +------------------------------------------------------------------- +cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName] +cvtDecs = fmap catMaybes . mapM cvtDec + +cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) +cvtDec (TH.ValD pat body ds) + | TH.VarP s <- pat + = do { s' <- vNameL s + ; cl' <- cvtClause (Clause [] body ds) + ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } + + | otherwise + = do { pat' <- cvtPat pat + ; body' <- cvtGuard body + ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds + ; returnJustL $ Hs.ValD $ + PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds' + , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames + , pat_ticks = ([],[]) } } + +cvtDec (TH.FunD nm cls) + | null cls + = failWith (ptext (sLit "Function binding for") + <+> quotes (text (TH.pprint nm)) + <+> ptext (sLit "has no equations")) + | otherwise + = do { nm' <- vNameL nm + ; cls' <- mapM cvtClause cls + ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } + +cvtDec (TH.SigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) } + +cvtDec (TH.InfixD fx nm) + -- fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameL nm + ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } + +cvtDec (PragmaD prag) + = cvtPragmaD prag + +cvtDec (TySynD tc tvs rhs) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; rhs' <- cvtType rhs + ; returnJustL $ TyClD $ + SynDecl { tcdLName = tc' + , tcdTyVars = tvs', tcdFVs = placeHolderNames + , tcdRhs = rhs' } } + +cvtDec (DataD ctxt tc tvs constrs derivs) + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; cons' <- mapM cvtConstr constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = Nothing + , dd_cons = cons', dd_derivs = derivs' } + ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdDataDefn = defn + , tcdFVs = placeHolderNames }) } + +cvtDec (NewtypeD ctxt tc tvs constr derivs) + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; con' <- cvtConstr constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = Nothing + , dd_cons = [con'] + , dd_derivs = derivs' } + ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdDataDefn = defn + , tcdFVs = placeHolderNames }) } + +cvtDec (ClassD ctxt cl tvs fds decs) + = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs + ; fds' <- mapM cvt_fundep fds + ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs + ; unless (null adts') + (failWith $ (ptext (sLit "Default data instance declarations are not allowed:")) + $$ (Outputable.ppr adts')) + ; at_defs <- mapM cvt_at_def ats' + ; returnJustL $ TyClD $ + ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] + , tcdFVs = placeHolderNames } + -- no docs in TH ^^ + } + where + cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) + -- Very similar to what happens in RdrHsSyn.mkClassDecl + cvt_at_def decl = case RdrHsSyn.mkATDefault decl of + Right def -> return def + Left (_, msg) -> failWith msg + +cvtDec (InstanceD ctxt ty decs) + = do { let doc = ptext (sLit "an instance declaration") + ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs + ; unless (null fams') (failWith (mkBadDecMsg doc fams')) + ; ctxt' <- cvtContext ctxt + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty' + ; returnJustL $ InstD $ ClsInstD $ + ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing } + +cvtDec (ForeignD ford) + = do { ford' <- cvtForD ford + ; returnJustL $ ForD ford' } + +cvtDec (FamilyD flav tc tvs kind) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; kind' <- cvtMaybeKind kind + ; returnJustL $ TyClD $ FamDecl $ + FamilyDecl (cvtFamFlavour flav) tc' tvs' kind' } + where + cvtFamFlavour TypeFam = OpenTypeFamily + cvtFamFlavour DataFam = DataFamily + +cvtDec (DataInstD ctxt tc tys constrs derivs) + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys + ; cons' <- mapM cvtConstr constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = Nothing + , dd_cons = cons', dd_derivs = derivs' } + + ; returnJustL $ InstD $ DataFamInstD + { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' + , dfid_defn = defn + , dfid_fvs = placeHolderNames } }} + +cvtDec (NewtypeInstD ctxt tc tys constr derivs) + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys + ; con' <- cvtConstr constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = Nothing + , dd_cons = [con'], dd_derivs = derivs' } + ; returnJustL $ InstD $ DataFamInstD + { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' + , dfid_defn = defn + , dfid_fvs = placeHolderNames } }} + +cvtDec (TySynInstD tc eqn) + = do { tc' <- tconNameL tc + ; eqn' <- cvtTySynEqn tc' eqn + ; returnJustL $ InstD $ TyFamInstD + { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' + , tfid_fvs = placeHolderNames } } } + +cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns) + | not $ null eqns + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars + ; mkind' <- cvtMaybeKind mkind + ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; returnJustL $ TyClD $ FamDecl $ + FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind' } + | otherwise + = failWith (ptext (sLit "Illegal empty closed type family")) + +cvtDec (TH.RoleAnnotD tc roles) + = do { tc' <- tconNameL tc + ; let roles' = map (noLoc . cvtRole) roles + ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + +cvtDec (TH.StandaloneDerivD cxt ty) + = do { cxt' <- cvtContext cxt + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty' + ; returnJustL $ DerivD $ + DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } } + +cvtDec (TH.DefaultSigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' } +---------------- +cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) +cvtTySynEqn tc (TySynEqn lhs rhs) + = do { lhs' <- mapM cvtType lhs + ; rhs' <- cvtType rhs + ; returnL $ TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs lhs' + , tfe_rhs = rhs' } } + +---------------- +cvt_ci_decs :: MsgDoc -> [TH.Dec] + -> CvtM (LHsBinds RdrName, + [LSig RdrName], + [LFamilyDecl RdrName], + [LTyFamInstDecl RdrName], + [LDataFamInstDecl RdrName]) +-- Convert the declarations inside a class or instance decl +-- ie signatures, bindings, and associated types +cvt_ci_decs doc decs + = do { decs' <- cvtDecs decs + ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' + ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' + ; let (sigs', prob_binds') = partitionWith is_sig no_ats' + ; let (binds', prob_fams') = partitionWith is_bind prob_binds' + ; let (fams', bads) = partitionWith is_fam_decl prob_fams' + ; unless (null bads) (failWith (mkBadDecMsg doc bads)) + --We use FromSource as the origin of the bind + -- because the TH declaration is user-written + ; return (listToBag binds', sigs', fams', ats', adts') } + +---------------- +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] + -> CvtM ( LHsContext RdrName + , Located RdrName + , LHsTyVarBndrs RdrName) +cvt_tycl_hdr cxt tc tvs + = do { cxt' <- cvtContext cxt + ; tc' <- tconNameL tc + ; tvs' <- cvtTvs tvs + ; return (cxt', tc', tvs') + } + +cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] + -> CvtM ( LHsContext RdrName + , Located RdrName + , HsWithBndrs RdrName [LHsType RdrName]) +cvt_tyinst_hdr cxt tc tys + = do { cxt' <- cvtContext cxt + ; tc' <- tconNameL tc + ; tys' <- mapM cvtType tys + ; return (cxt', tc', mkHsWithBndrs tys') } + +------------------------------------------------------------------- +-- Partitioning declarations +------------------------------------------------------------------- + +is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName) +is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d) +is_fam_decl decl = Right decl + +is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName) +is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d) +is_tyfam_inst decl = Right decl + +is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName) +is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d) +is_datafam_inst decl = Right decl + +is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) +is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) +is_sig decl = Right decl + +is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) +is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) +is_bind decl = Right decl + +mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc +mkBadDecMsg doc bads + = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon + , nest 2 (vcat (map Outputable.ppr bads)) ] + +--------------------------------------------------- +-- Data types +-- Can't handle GADTs yet +--------------------------------------------------- + +cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) + +cvtConstr (NormalC c strtys) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; tys' <- mapM cvt_arg strtys + ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') } + +cvtConstr (RecC c varstrtys) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; args' <- mapM cvt_id_arg varstrtys + ; returnL $ mkSimpleConDecl c' noExistentials cxt' + (RecCon (noLoc args')) } + +cvtConstr (InfixC st1 c st2) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; st1' <- cvt_arg st1 + ; st2' <- cvt_arg st2 + ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') } + +cvtConstr (ForallC tvs ctxt con) + = do { tvs' <- cvtTvs tvs + ; L loc ctxt' <- cvtContext ctxt + ; L _ con' <- cvtConstr con + ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) + , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } + +cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) +cvt_arg (NotStrict, ty) = cvtType ty +cvt_arg (IsStrict, ty) + = do { ty' <- cvtType ty + ; returnL $ HsBangTy (HsSrcBang Nothing Nothing True) ty' } +cvt_arg (Unpacked, ty) + = do { ty' <- cvtType ty + ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' } + +cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName) +cvt_id_arg (i, str, ty) + = do { i' <- vNameL i + ; ty' <- cvt_arg (str,ty) + ; return $ noLoc (ConDeclField { cd_fld_names = [i'] + , cd_fld_type = ty' + , cd_fld_doc = Nothing}) } + +cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName])) +cvtDerivs [] = return Nothing +cvtDerivs cs = do { cs' <- mapM cvt_one cs + ; return (Just (noLoc cs')) } + where + cvt_one c = do { c' <- tconName c + ; returnL $ HsTyVar c' } + +cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs + ; ys' <- mapM tName ys + ; returnL (map noLoc xs', map noLoc ys') } + +noExistentials :: [LHsTyVarBndr RdrName] +noExistentials = [] + +------------------------------------------ +-- Foreign declarations +------------------------------------------ + +cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) +cvtForD (ImportF callconv safety from nm ty) + | callconv == TH.Prim || callconv == TH.JavaScript + = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing + (CFunction (StaticTarget (mkFastString from) Nothing True)) + (noLoc from)) + | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') + (mkFastString (TH.nameBase nm)) + from (noLoc from) + = mk_imp impspec + | otherwise + = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent") + where + mk_imp impspec + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) + } + safety' = case safety of + Unsafe -> PlayRisky + Safe -> PlaySafe + Interruptible -> PlayInterruptible + +cvtForD (ExportF callconv as nm ty) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let e = CExport (noLoc (CExportStatic (mkFastString as) + (cvt_conv callconv))) + (noLoc as) + ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } + +cvt_conv :: TH.Callconv -> CCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv +cvt_conv TH.CApi = CApiConv +cvt_conv TH.Prim = PrimCallConv +cvt_conv TH.JavaScript = JavaScriptCallConv + +------------------------------------------ +-- Pragmas +------------------------------------------ + +cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) +cvtPragmaD (InlineP nm inline rm phases) + = do { nm' <- vNameL nm + ; let dflt = dfltActivation inline + ; let ip = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = cvtInline inline + , inl_rule = cvtRuleMatch rm + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + ; returnJustL $ Hs.SigD $ InlineSig nm' ip } + +cvtPragmaD (SpecialiseP nm ty inline phases) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let (inline', dflt) = case inline of + Just inline1 -> (cvtInline inline1, dfltActivation inline1) + Nothing -> (EmptyInlineSpec, AlwaysActive) + ; let ip = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = inline' + , inl_rule = Hs.FunLike + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip } + +cvtPragmaD (SpecialiseInstP ty) + = do { ty' <- cvtType ty + ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' } + +cvtPragmaD (RuleP nm bndrs lhs rhs phases) + = do { let nm' = mkFastString nm + ; let act = cvtPhases phases AlwaysActive + ; bndrs' <- mapM cvtRuleBndr bndrs + ; lhs' <- cvtl lhs + ; rhs' <- cvtl rhs + ; returnJustL $ Hs.RuleD + $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs' + lhs' placeHolderNames + rhs' placeHolderNames] + } + +cvtPragmaD (AnnP target exp) + = do { exp' <- cvtl exp + ; target' <- case target of + ModuleAnnotation -> return ModuleAnnProvenance + TypeAnnotation n -> do + n' <- tconName n + return (TypeAnnProvenance (noLoc n')) + ValueAnnotation n -> do + n' <- vcName n + return (ValueAnnProvenance (noLoc n')) + ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp' + } + +cvtPragmaD (LineP line file) + = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) + ; return Nothing + } + +dfltActivation :: TH.Inline -> Activation +dfltActivation TH.NoInline = NeverActive +dfltActivation _ = AlwaysActive + +cvtInline :: TH.Inline -> Hs.InlineSpec +cvtInline TH.NoInline = Hs.NoInline +cvtInline TH.Inline = Hs.Inline +cvtInline TH.Inlinable = Hs.Inlinable + +cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo +cvtRuleMatch TH.ConLike = Hs.ConLike +cvtRuleMatch TH.FunLike = Hs.FunLike + +cvtPhases :: TH.Phases -> Activation -> Activation +cvtPhases AllPhases dflt = dflt +cvtPhases (FromPhase i) _ = ActiveAfter i +cvtPhases (BeforePhase i) _ = ActiveBefore i + +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) +cvtRuleBndr (RuleVar n) + = do { n' <- vNameL n + ; return $ noLoc $ Hs.RuleBndr n' } +cvtRuleBndr (TypedRuleVar n ty) + = do { n' <- vNameL n + ; ty' <- cvtType ty + ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' } + +--------------------------------------------------- +-- Declarations +--------------------------------------------------- + +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs doc ds + | null ds + = return EmptyLocalBinds + | otherwise + = do { ds' <- cvtDecs ds + ; let (binds, prob_sigs) = partitionWith is_bind ds' + ; let (sigs, bads) = partitionWith is_sig prob_sigs + ; unless (null bads) (failWith (mkBadDecMsg doc bads)) + ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } + +cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) +cvtClause (Clause ps body wheres) + = do { ps' <- cvtPats ps + ; g' <- cvtGuard body + ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres + ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') } + + +------------------------------------------------------------------- +-- Expressions +------------------------------------------------------------------- + +cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) +cvtl e = wrapL (cvt e) + where + cvt (VarE s) = do { s' <- vName s; return $ HsVar s' } + cvt (ConE s) = do { s' <- cName s; return $ HsVar s' } + cvt (LitE l) + | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } + | otherwise = do { l' <- cvtLit l; return $ HsLit l' } + + cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } + cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e + ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) } + cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms + ; return $ HsLamCase placeHolderType + (mkMatchGroup FromSource ms') + } + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } + -- Note [Dropping constructors] + -- Singleton tuples treated like nothing (just parens) + cvt (TupE es) = do { es' <- mapM cvtl es + ; return $ ExplicitTuple (map (noLoc . Present) es') + Boxed } + cvt (UnboxedTupE es) = do { es' <- mapM cvtl es + ; return $ ExplicitTuple + (map (noLoc . Present) es') Unboxed } + cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; + ; return $ HsIf (Just noSyntaxExpr) x' y' z' } + cvt (MultiIfE alts) + | null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives")) + | otherwise = do { alts' <- mapM cvtpair alts + ; return $ HsMultiIf placeHolderType alts' } + cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds + ; e' <- cvtl e; return $ HsLet ds' e' } + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms + ; return $ HsCase e' (mkMatchGroup FromSource ms') } + cvt (DoE ss) = cvtHsDo DoExpr ss + cvt (CompE ss) = cvtHsDo ListComp ss + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } + cvt (ListE xs) + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } + -- Note [Converting strings] + | otherwise = do { xs' <- mapM cvtl xs + ; return $ ExplicitList placeHolderType Nothing xs' + } + + -- Infix expressions + cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y + ; wrapParL HsPar $ + OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } + -- Parenthesise both arguments and result, + -- to ensure this operator application does + -- does not get re-associated + -- See Note [Operator association] + cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y + ; wrapParL HsPar $ SectionR s' y' } + -- See Note [Sections in HsSyn] in HsExpr + cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s + ; wrapParL HsPar $ SectionL x' s' } + + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } + -- Can I indicate this is an infix thing? + -- Note [Dropping constructors] + + cvt (UInfixE x s y) = do { x' <- cvtl x + ; let x'' = case x' of + L _ (OpApp {}) -> x' + _ -> mkLHsPar x' + ; cvtOpApp x'' s y } -- Note [Converting UInfix] + + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } + cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t + ; return $ ExprWithTySig e' t' PlaceHolder } + cvt (RecConE c flds) = do { c' <- cNameL c + ; flds' <- mapM cvtFld flds + ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)} + cvt (RecUpdE e flds) = do { e' <- cvtl e + ; flds' <- mapM cvtFld flds + ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } + cvt (StaticE e) = fmap HsStatic $ cvtl e + +{- Note [Dropping constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we drop constructors from the input (for instance, when we encounter @TupE [e]@) +we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ +could meet @UInfix@ constructors containing the @TupE [e]@. For example: + + UInfixE x * (TupE [UInfixE y + z]) + +If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet +and the above expression would be reassociated to + + OpApp (OpApp x * y) + z + +which we don't want. +-} + +cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName)) +cvtFld (v,e) + = do { v' <- vNameL v; e' <- cvtl e + ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e' + , hsRecPun = False}) } + +cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) +cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } +cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } +cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } +cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } + +{- Note [Operator assocation] +We must be quite careful about adding parens: + * Infix (UInfix ...) op arg Needs parens round the first arg + * Infix (Infix ...) op arg Needs parens round the first arg + * UInfix (UInfix ...) op arg No parens for first arg + * UInfix (Infix ...) op arg Needs parens round first arg + + +Note [Converting UInfix] +~~~~~~~~~~~~~~~~~~~~~~~~ +When converting @UInfixE@ and @UInfixP@ values, we want to readjust +the trees to reflect the fixities of the underlying operators: + + UInfixE x * (UInfixE y + z) ---> (x * y) + z + +This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in +RnTypes), which expects that the input will be completely left-biased. +So we left-bias the trees of @UInfixP@ and @UInfixE@ that we come across. + +Sample input: + + UInfixE + (UInfixE x op1 y) + op2 + (UInfixE z op3 w) + +Sample output: + + OpApp + (OpApp + (OpApp x op1 y) + op2 + z) + op3 + w + +The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this +left-biasing. +-} + +{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix expressions will be left-biased, provided @x@ is. + +We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis +is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that +this holds for both branches (of @cvtOpApp@), provided we assume it holds for +the recursive calls to @cvtOpApp@. + +When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased +since we have already run @cvtl@ on it. +-} +cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) +cvtOpApp x op1 (UInfixE y op2 z) + = do { l <- wrapL $ cvtOpApp x op1 y + ; cvtOpApp l op2 z } +cvtOpApp x op y + = do { op' <- cvtl op + ; y' <- cvtl y + ; return (OpApp x op' undefined y') } + +------------------------------------- +-- Do notation and statements +------------------------------------- + +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) +cvtHsDo do_or_lc stmts + | null stmts = failWith (ptext (sLit "Empty stmt list in do-block")) + | otherwise + = do { stmts' <- cvtStmts stmts + ; let Just (stmts'', last') = snocView stmts' + + ; last'' <- case last' of + L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType } + where + bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon + , nest 2 $ Outputable.ppr stmt + , ptext (sLit "(It should be an expression.)") ] + +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] +cvtStmts = mapM cvtStmt + +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } +cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds + ; returnL $ LetStmt ds' } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr } + where + cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } + +cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) +cvtMatch (TH.Match p body decs) + = do { p' <- cvtPat p + ; g' <- cvtGuard body + ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs + ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') } + +cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] +cvtGuard (GuardedB pairs) = mapM cvtpair pairs +cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } + +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName)) +cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs + ; g' <- returnL $ mkBodyStmt ge' + ; returnL $ GRHS [g'] rhs' } +cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs + ; returnL $ GRHS gs' rhs' } + +cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) +cvtOverLit (IntegerL i) + = do { force i; return $ mkHsIntegral (show i) i placeHolderType} +cvtOverLit (RationalL r) + = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} +cvtOverLit (StringL s) + = do { let { s' = mkFastString s } + ; force s' + ; return $ mkHsIsString s s' placeHolderType + } +cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" +-- An Integer is like an (overloaded) '3' in a Haskell source program +-- Similarly 3.5 for fractionals + +{- Note [Converting strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to +a string literal for "xy". Of course, we might hope to get +(LitE (StringL "xy")), but not always, and allCharLs fails quickly +if it isn't a literal string +-} + +allCharLs :: [TH.Exp] -> Maybe String +-- Note [Converting strings] +-- NB: only fire up this setup for a non-empty list, else +-- there's a danger of returning "" for [] :: [Int]! +allCharLs xs + = case xs of + LitE (CharL c) : ys -> go [c] ys + _ -> Nothing + where + go cs [] = Just (reverse cs) + go cs (LitE (CharL c) : ys) = go (c:cs) ys + go _ _ = Nothing + +cvtLit :: Lit -> CvtM HsLit +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w } +cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } +cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } +cvtLit (CharL c) = do { force c; return $ HsChar (show c) c } +cvtLit (StringL s) = do { let { s' = mkFastString s } + ; force s' + ; return $ HsString s s' } +cvtLit (StringPrimL s) = do { let { s' = BS.pack s } + ; force s' + ; return $ HsStringPrim (w8ToString s) s' } +cvtLit _ = panic "Convert.cvtLit: Unexpected literal" + -- cvtLit should not be called on IntegerL, RationalL + -- That precondition is established right here in + -- Convert.lhs, hence panic + +w8ToString :: [Word8] -> String +w8ToString ws = map (\w -> chr (fromIntegral w)) ws + +cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] +cvtPats pats = mapM cvtPat pats + +cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName) +cvtPat pat = wrapL (cvtp pat) + +cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) +cvtp (TH.LitP l) + | overloadedLit l = do { l' <- cvtOverLit l + ; return (mkNPat (noLoc l') Nothing) } + -- Not right for negative patterns; + -- need to think about that! + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } +cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } +cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps + ; return $ ConPatIn s' (PrefixCon ps') } +cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; wrapParL ParPat $ + ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } + -- See Note [Operator association] +cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] +cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp TH.WildP = return $ WildPat placeHolderType +cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs + ; return $ ConPatIn c' + $ Hs.RecCon (HsRecFields fs' Nothing) } +cvtp (ListP ps) = do { ps' <- cvtPats ps + ; return $ ListPat ps' placeHolderType Nothing } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; return $ SigPatIn p' (mkHsWithBndrs t') } +cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p + ; return $ ViewPat e' p' placeHolderType } + +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) +cvtPatFld (s,p) + = do { s' <- vNameL s; p' <- cvtPat p + ; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p' + , hsRecPun = False}) } + +{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix patterns will be left-biased, provided @x@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) +cvtOpAppP x op1 (UInfixP y op2 z) + = do { l <- wrapL $ cvtOpAppP x op1 y + ; cvtOpAppP l op2 z } +cvtOpAppP x op y + = do { op' <- cNameL op + ; y' <- cvtPat y + ; return (ConPatIn op' (InfixCon x y')) } + +----------------------------------------------------------- +-- Types and type variables + +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName) +cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } + +cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) +cvt_tv (TH.PlainTV nm) + = do { nm' <- tName nm + ; returnL $ UserTyVar nm' } +cvt_tv (TH.KindedTV nm ki) + = do { nm' <- tName nm + ; ki' <- cvtKind ki + ; returnL $ KindedTyVar (noLoc nm') ki' } + +cvtRole :: TH.Role -> Maybe Coercion.Role +cvtRole TH.NominalR = Just Coercion.Nominal +cvtRole TH.RepresentationalR = Just Coercion.Representational +cvtRole TH.PhantomR = Just Coercion.Phantom +cvtRole TH.InferR = Nothing + +cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) +cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } + +cvtPred :: TH.Pred -> CvtM (LHsType RdrName) +cvtPred = cvtType + +cvtType :: TH.Type -> CvtM (LHsType RdrName) +cvtType = cvtTypeKind "type" + +cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName) +cvtTypeKind ty_str ty + = do { (head_ty, tys') <- split_ty_app ty + ; case head_ty of + TupleT n + | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy HsBoxedOrConstraintTuple tys') + | n == 1 + -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) + | otherwise + -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys' + UnboxedTupleT n + | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy HsUnboxedTuple tys') + | otherwise + -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys' + ArrowT + | [x',y'] <- tys' -> returnL (HsFunTy x' y') + | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' + ListT + | [x'] <- tys' -> returnL (HsListTy x') + | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys' + VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' } + ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' } + + ForallT tvs cxt ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; cxt' <- cvtContext cxt + ; ty' <- cvtType ty + ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' + } + + SigT ty ki + -> do { ty' <- cvtType ty + ; ki' <- cvtKind ki + ; mk_apps (HsKindSig ty' ki') tys' + } + + LitT lit + -> returnL (HsTyLit (cvtTyLit lit)) + + PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' } + -- Promoted data constructor; hence cName + + PromotedTupleT n + | n == 1 + -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) + | m == n -- Saturated + -> do { let kis = replicate m placeHolderKind + ; returnL (HsExplicitTupleTy kis tys') + } + where + m = length tys' + + PromotedNilT + -> returnL (HsExplicitListTy placeHolderKind []) + + PromotedConsT -- See Note [Representing concrete syntax in types] + -- in Language.Haskell.TH.Syntax + | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys' + -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2)) + | otherwise + -> mk_apps (HsTyVar (getRdrName consDataCon)) tys' + + StarT + -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon)) + + ConstraintT + -> returnL (HsTyVar (getRdrName constraintKindTyCon)) + + EqualityT + | [x',y'] <- tys' -> returnL (HsEqTy x' y') + | otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys' + + _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) + } + +mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) +mk_apps head_ty [] = returnL head_ty +mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty + ; mk_apps (HsAppTy head_ty' ty) tys } + +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) +split_ty_app ty = go ty [] + where + go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } + go f as = return (f,as) + +cvtTyLit :: TH.TyLit -> HsTyLit +cvtTyLit (NumTyLit i) = HsNumTy (show i) i +cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s) + +cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) +cvtKind = cvtTypeKind "kind" + +cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) +cvtMaybeKind Nothing = return Nothing +cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki + ; return (Just ki') } + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN + +----------------------------------------------------------- + + +----------------------------------------------------------- +-- some useful things + +overloadedLit :: Lit -> Bool +-- True for literals that Haskell treats as overloaded +overloadedLit (IntegerL _) = True +overloadedLit (RationalL _) = True +overloadedLit _ = False + +cvtFractionalLit :: Rational -> FractionalLit +cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } + +-------------------------------------------------------------------- +-- Turning Name back into RdrName +-------------------------------------------------------------------- + +-- variable names +vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName + +-- Variable names +vNameL n = wrapL (vName n) +vName n = cvtName OccName.varName n + +-- Constructor function names; this is Haskell source, hence srcDataName +cNameL n = wrapL (cName n) +cName n = cvtName OccName.dataName n + +-- Variable *or* constructor names; check by looking at the first char +vcNameL n = wrapL (vcName n) +vcName n = if isVarName n then vName n else cName n + +-- Type variable names +tName n = cvtName OccName.tvName n + +-- Type Constructor names +tconNameL n = wrapL (tconName n) +tconName n = cvtName OccName.tcClsName n + +cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName +cvtName ctxt_ns (TH.Name occ flavour) + | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) + | otherwise + = do { loc <- getL + ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour + ; force rdr_name + ; return rdr_name } + where + occ_str = TH.occString occ + +okOcc :: OccName.NameSpace -> String -> Bool +okOcc ns str + | OccName.isVarNameSpace ns = okVarOcc str + | OccName.isDataConNameSpace ns = okConOcc str + | otherwise = okTcOcc str + +-- Determine the name space of a name in a type +-- +isVarName :: TH.Name -> Bool +isVarName (TH.Name occ _) + = case TH.occString occ of + "" -> False + (c:_) -> startsVarId c || startsVarSym c + +badOcc :: OccName.NameSpace -> String -> SDoc +badOcc ctxt_ns occ + = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns + <+> ptext (sLit "name:") <+> quotes (text occ) + +thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName +-- This turns a TH Name into a RdrName; used for both binders and occurrences +-- See Note [Binders in Template Haskell] +-- The passed-in name space tells what the context is expecting; +-- use it unless the TH name knows what name-space it comes +-- from, in which case use the latter +-- +-- We pass in a SrcSpan (gotten from the monad) because this function +-- is used for *binders* and if we make an Exact Name we want it +-- to have a binding site inside it. (cf Trac #5434) +-- +-- ToDo: we may generate silly RdrNames, by passing a name space +-- that doesn't match the string, like VarName ":+", +-- which will give confusing error messages later +-- +-- The strict applications ensure that any buried exceptions get forced +thRdrName loc ctxt_ns th_occ th_name + = case th_name of + TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod + TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc) + TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name + | otherwise -> mkRdrUnqual $! occ + -- We check for built-in syntax here, because the TH + -- user might have written a (NameS "(,,)"), for example + where + occ :: OccName.OccName + occ = mk_occ ctxt_ns th_occ + +thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) + +thRdrNameGuesses :: TH.Name -> [RdrName] +thRdrNameGuesses (TH.Name occ flavour) + -- This special case for NameG ensures that we don't generate duplicates in the output list + | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] + | otherwise = [ thRdrName noSrcSpan gns occ_str flavour + | gns <- guessed_nss] + where + -- guessed_ns are the name spaces guessed from looking at the TH name + guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] + | otherwise = [OccName.varName, OccName.tvName] + occ_str = TH.occString occ + +-- The packing and unpacking is rather turgid :-( +mk_occ :: OccName.NameSpace -> String -> OccName.OccName +mk_occ ns occ = OccName.mkOccName ns occ + +mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName + +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.PkgName -> PackageKey +mk_pkg pkg = stringToPackageKey (TH.pkgString pkg) + +mk_uniq :: Int -> Unique +mk_uniq u = mkUniqueGrimily u + +{- +Note [Binders in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this TH term construction: + do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name + ; x2 <- TH.newName "x" -- Builds a NameU + ; x3 <- TH.newName "x" + + ; let x = mkName "x" -- mkName :: String -> TH.Name + -- Builds a NameS + + ; return (LamE (..pattern [x1,x2]..) $ + LamE (VarPat x3) $ + ..tuple (x1,x2,x3,x)) } + +It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) + +a) We don't want to complain about "x" being bound twice in + the pattern [x1,x2] +b) We don't want x3 to shadow the x1,x2 +c) We *do* want 'x' (dynamically bound with mkName) to bind + to the innermost binding of "x", namely x3. +d) When pretty printing, we want to print a unique with x1,x2 + etc, else they'll all print as "x" which isn't very helpful + +When we convert all this to HsSyn, the TH.Names are converted with +thRdrName. To achieve (b) we want the binders to be Exact RdrNames. +Achieving (a) is a bit awkward, because + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. + See Note [Collect binders only after renaming] in HsUtils + + - But to achieve (a) we must distinguish between the Exact + RdrNames arising from TH and the Unqual RdrNames that would + come from a user writing \[x,x] -> blah + +So in Convert.thRdrName we translate + TH Name RdrName + -------------------------------------------------------- + NameU (arising from newName) --> Exact (Name{ System }) + NameS (arising from mkName) --> Unqual + +Notice that the NameUs generate *System* Names. Then, when +figuring out shadowing and duplicates, we can filter out +System Names. + +This use of System Names fits with other uses of System Names, eg for +temporary variables "a". Since there are lots of things called "a" we +usually want to print the name with the unique, and that is indeed +the way System Names are printed. + +There's a small complication of course; see Note [Looking up Exact +RdrNames] in RnEnv. +-} diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs new file mode 100644 index 00000000..eaf64949 --- /dev/null +++ b/compiler/hsSyn/HsBinds.hs @@ -0,0 +1,929 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module HsBinds where + +import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, + MatchGroup, pprFunBind, + GRHSs, pprPatBind ) +import {-# SOURCE #-} HsPat ( LPat ) + +import PlaceHolder ( PostTc,PostRn,DataId ) +import HsTypes +import PprCore () +import CoreSyn +import TcEvidence +import Type +import Name +import NameSet +import BasicTypes +import Outputable +import SrcLoc +import Var +import Bag +import FastString +import BooleanFormula (BooleanFormula) + +import Data.Data hiding ( Fixity ) +import Data.List +import Data.Ord +import Data.Foldable ( Foldable(..) ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( Traversable(..) ) +import Data.Monoid ( mappend ) +import Control.Applicative hiding (empty) +#endif + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the the right-hand sides have not. +-- the ...LR datatypes are parametrized by two id types, +-- one for the left and one for the right. +-- Other than during renaming, these will be the same. + +type HsLocalBinds id = HsLocalBindsLR id id + +-- | Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR + = HsValBinds (HsValBindsLR idL idR) + -- There should be no pattern synonyms in the HsValBindsLR + -- These are *local* (not top level) bindings + -- The parser accepts them, however, leaving the the + -- renamer to report them + + | HsIPBinds (HsIPBinds idR) + + | EmptyLocalBinds + deriving (Typeable) + +deriving instance (DataId idL, DataId idR) + => Data (HsLocalBindsLR idL idR) + +type HsValBinds id = HsValBindsLR id id + +-- | Value bindings (not implicit parameters) +-- Used for both top level and nested bindings +-- May contain pattern synonym bindings +data HsValBindsLR idL idR + = -- | Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBindsIn + (LHsBindsLR idL idR) [LSig idR] + + -- | After renaming RHS; idR can be Name or Id + -- Dependency analysed, + -- later bindings in the list may depend on earlier + -- ones. + | ValBindsOut + [(RecFlag, LHsBinds idL)] + [LSig Name] + deriving (Typeable) + +deriving instance (DataId idL, DataId idR) + => Data (HsValBindsLR idL idR) + +type LHsBind id = LHsBindLR id id +type LHsBinds id = LHsBindsLR id id +type HsBind id = HsBindLR id id + +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) +type LHsBindLR idL idR = Located (HsBindLR idL idR) + +data HsBindLR idL idR + = -- | FunBind is used for both functions @f x = e@ + -- and variables @f = \x -> e@ + -- + -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. + -- + -- Reason 2: Instance decls can only have FunBinds, which is convenient. + -- If you change this, you'll need to change e.g. rnMethodBinds + -- + -- But note that the form @f :: a->a = ...@ + -- parses as a pattern binding, just like + -- @(f :: a -> a) = ... @ + -- + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches + -- + -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + FunBind { + + fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr + + fun_infix :: Bool, -- ^ True => infix declaration + + fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + + fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of + -- the Id. Example: + -- + -- @ + -- f :: Int -> forall a. a -> a + -- f x y = y + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. + + bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + + + fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any + } + + -- | The pattern is never a simple variable; + -- That case is done by FunBind + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatBind { + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR (LHsExpr idR), + pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs + bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars] + pat_ticks :: ([Tickish Id], [[Tickish Id]]) + -- ^ Ticks to put on the rhs, if any, and ticks to put on + -- the bound variables. + } + + -- | Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_id :: idL, + var_rhs :: LHsExpr idR, -- ^ Located only for consistency + var_inline :: Bool -- ^ True <=> inline this binding regardless + -- (used for implication constraints only) + } + + | AbsBinds { -- Binds abstraction; TRANSLATION + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport idL], + + abs_ev_binds :: TcEvBinds, -- ^ Evidence bindings + abs_binds :: LHsBinds idL -- ^ Typechecked user bindings + } + + | PatSynBind (PatSynBind idL idR) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', + -- 'ApiAnnotation.AnnWhere' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + deriving (Typeable) +deriving instance (DataId idL, DataId idR) + => Data (HsBindLR idL idR) + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +data ABExport id + = ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id + , abe_mono :: id + , abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } deriving (Data, Typeable) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' +-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, +-- 'ApiAnnotation.AnnClose' @'}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data PatSynBind idL idR + = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] + psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } deriving (Typeable) +deriving instance (DataId idL, DataId idR ) + => Data (PatSynBind idL idR) + +{- +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to record +*typechecked* and *generalised* bindings. Consider a module M, with this +top-level binding + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses +being *monomorphic*. So after typechecking *and* desugaring we will get something +like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before desugaring? +That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: a -> a}] + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + * abs_tvs says what type variables are abstracted over the binding group, + just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' from the + monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive functions without type +signatures, we get one AbsBinds with the monomorphic versions of the +bindings in abs_binds, and one element of abe_exports for each +variable bound in the mutually recursive group. This is true even for +pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + +Note [AbsBinds wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (f,g) = (\x.x, \y.y) +This ultimately desugars to something like this: + tup :: forall a b. (a->a, b->b) + tup = /\a b. (\x:a.x, \y:b.y) + f :: forall a. a -> a + f = /\a. case tup a Any of + (fm::a->a,gm:Any->Any) -> fm + ...similarly for g... + +The abe_wrap field deals with impedence-matching between + (/\a b. case tup a b of { (f,g) -> f }) +and the thing we really want, which may have fewer type +variables. The action happens in TcBinds.mkExport. + +Note [Bind free vars] +~~~~~~~~~~~~~~~~~~~~~ +The bind_fvs field of FunBind and PatBind records the free variables +of the definition. It is used for two purposes + +a) Dependency analysis prior to type checking + (see TcBinds.tc_group) + +b) Deciding whether we can do generalisation of the binding + (see TcBinds.decideGeneralisationPlan) + +Specifically, + + * bind_fvs includes all free vars that are defined in this module + (including top-level things and lexically scoped type variables) + + * bind_fvs excludes imported vars; this is just to keep the set smaller + + * Before renaming, and after typechecking, the field is unused; + it's just an error thunk +-} + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where + ppr (HsValBinds bs) = ppr bs + ppr (HsIPBinds bs) = ppr bs + ppr EmptyLocalBinds = empty + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where + ppr (ValBindsIn binds sigs) + = pprDeclList (pprLHsBindsForUser binds sigs) + + ppr (ValBindsOut sccs sigs) + = getPprStyle $ \ sty -> + if debugStyle sty then -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + else + pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = ptext (sLit "rec") + pp_rec NonRecursive = ptext (sLit "nonrec") + +pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = pprDeclList (map ppr (bagToList binds)) + +pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) + => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs + = map snd (sort_by_loc decls) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(loc, ppr sig) | L loc sig <- sigs] ++ + [(loc, ppr bind) | L loc bind <- bagToList binds] + + sort_by_loc decls = sortBy (comparing fst) decls + +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + +------------ +emptyLocalBinds :: HsLocalBindsLR a b +emptyLocalBinds = EmptyLocalBinds + +isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds +isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds +isEmptyLocalBinds EmptyLocalBinds = True + +isEmptyValBinds :: HsValBindsLR a b -> Bool +isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b +emptyValBindsIn = ValBindsIn emptyBag [] +emptyValBindsOut = ValBindsOut [] [] + +emptyLHsBinds :: LHsBindsLR idL idR +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a +plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) + = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) + = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds _ _ + = panic "HsBinds.plusHsValBinds" + +getTypeSigNames :: HsValBinds a -> NameSet +-- Get the names that have a user type sig +getTypeSigNames (ValBindsOut _ sigs) + = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names] +getTypeSigNames _ + = panic "HsBinds.getTypeSigNames" + +{- +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds tvs + [d1,d2] + [(tvs1, f1p, f1m), + (tvs2, f2p, f2m)] + BIND +means + + f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND + in fm + + gp = ...same again, with gm instead of fm + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) +-} + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] +ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, + fun_co_fn = wrap, + fun_matches = matches, + fun_tick = ticks }) + = pprTicks empty (if null ticks then empty + else text "-- ticks = " <> ppr ticks) + $$ ifPprDebug (pprBndr LetBind (unLoc fun)) + $$ pprFunBind (unLoc fun) inf matches + $$ ifPprDebug (ppr wrap) +ppr_monobind (PatSynBind psb) = ppr psb +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars) + <+> brackets (interpp'SP dictvars)) + 2 $ braces $ vcat + [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports))) + , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , ptext (sLit "Binds:") <+> pprLHsBinds val_binds + , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ] + +instance (OutputableBndr id) => Outputable (ABExport id) where + ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) + = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl + , nest 2 (pprTcSpecPrags prags) + , nest 2 (ppr wrap)] + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = ptext (sLit "pattern") <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + (is_infix, ppr_details) = case details of + InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2]) + PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs)) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (ptext (sLit "<-")) + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind psyn is_infix mg) + +pprTicks :: SDoc -> SDoc -> SDoc +-- Print stuff about ticks only when -dppr-debug is on, to avoid +-- them appearing in error messages (from the desugarer); see Trac # 3263 +-- Also print ticks in dumpStyle, so that -ddump-hpc actually does +-- something useful. +pprTicks pp_no_debug pp_when_debug + = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty + then pp_when_debug + else pp_no_debug) + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +data HsIPBinds id + = IPBinds + [LIPBind id] + TcEvBinds -- Only in typechecker output; binds + -- uses of the implicit parameters + deriving (Typeable) +deriving instance (DataId id) => Data (HsIPBinds id) + +isEmptyIPBinds :: HsIPBinds id -> Bool +isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds + +type LIPBind id = Located (IPBind id) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Implicit parameter bindings. +-- +-- These bindings start off as (Left "x") in the parser and stay +-- that way until after type-checking when they are replaced with +-- (Right d), where "d" is the name of the dictionary holding the +-- evidence for the implicit parameter. +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + +-- For details on above see note [Api annotations] in ApiAnnotation +data IPBind id + = IPBind (Either (Located HsIPName) id) (LHsExpr id) + deriving (Typeable) +deriving instance (DataId name) => Data (IPBind name) + +instance (OutputableBndr id) => Outputable (HsIPBinds id) where + ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) + $$ ifPprDebug (ppr ds) + +instance (OutputableBndr id) => Outputable (IPBind id) where + ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case lr of + Left (L _ ip) -> pprBndr LetBind ip + Right id -> pprBndr LetBind id + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. +-} + +type LSig name = Located (Sig name) + +-- | Signatures and pragmas +data Sig name + = -- | An ordinary type signature + -- + -- > f :: Num a => a -> a + -- + -- After renaming, this list of Names contains the named and unnamed + -- wildcards brought into scope by this signature. For a signature + -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@ + -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@ + -- are then both replaced with fresh meta vars in the type. Their names + -- are stored in the type signature that brought them into scope, in + -- this third field to be more specific. + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + TypeSig [Located name] (LHsType name) (PostRn name [Name]) + + -- | A pattern synonym type signature + -- + -- > pattern Single :: () => (Show a) => a -> [a] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatSynSig (Located name) + (HsExplicitFlag, LHsTyVarBndrs name) + (LHsContext name) -- Provided context + (LHsContext name) -- Required context + (LHsType name) + + -- | A type signature for a default method inside a class + -- + -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | GenericSig [Located name] (LHsType name) + + -- | A type signature in generated code, notably the code + -- generated for record selectors. We simply record + -- the desired Id itself, replete with its name, type + -- and IdDetails. Otherwise it's just like a type + -- signature: there should be an accompanying binding + | IdSig Id + + -- | An ordinary fixity declaration + -- + -- > infixl 8 *** + -- + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', + -- 'ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + | FixSig (FixitySig name) + + -- | An inline pragma + -- + -- > {#- INLINE f #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | InlineSig (Located name) -- Function name + InlinePragma -- Never defaultInlinePragma + + -- | A specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecSig (Located name) -- Specialise a function or datatype ... + [LHsType name] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecInstSig SourceText (LHsType name) + -- Note [Pragma source text] in BasicTypes + + -- | A minimal complete definition pragma + -- + -- > {-# MINIMAL a | (b, c | (d | e)) #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | MinimalSig SourceText (BooleanFormula (Located name)) + -- Note [Pragma source text] in BasicTypes + + deriving (Typeable) +deriving instance (DataId name) => Data (Sig name) + + +type LFixitySig name = Located (FixitySig name) +data FixitySig name = FixitySig [Located name] Fixity + deriving (Data, Typeable) + +-- | TsSpecPrags conveys pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + deriving (Data, Typeable) + +type LTcSpecPrag = Located TcSpecPrag + +data TcSpecPrag + = SpecPrag + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, an wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function + deriving (Data, Typeable) + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + + +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig {})) = True +isFixityLSig _ = False + +isVanillaLSig :: LSig name -> Bool -- User type signatures +-- A badly-named function, but it's part of the GHCi (used +-- by Haddock) so I don't want to change it gratuitously. +isVanillaLSig (L _(TypeSig {})) = True +isVanillaLSig _ = False + +isTypeLSig :: LSig name -> Bool -- Type signatures +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False + +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig {})) = True +isSpecLSig _ = False + +isSpecInstLSig :: LSig name -> Bool +isSpecInstLSig (L _ (SpecInstSig {})) = True +isSpecInstLSig _ = False + +isPragLSig :: LSig name -> Bool +-- Identifies pragmas +isPragLSig (L _ (SpecSig {})) = True +isPragLSig (L _ (InlineSig {})) = True +isPragLSig _ = False + +isInlineLSig :: LSig name -> Bool +-- Identifies inline pragmas +isInlineLSig (L _ (InlineSig {})) = True +isInlineLSig _ = False + +isMinimalLSig :: LSig name -> Bool +isMinimalLSig (L _ (MinimalSig {})) = True +isMinimalLSig _ = False + +hsSigDoc :: Sig name -> SDoc +hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature") +hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") +hsSigDoc (IdSig {}) = ptext (sLit "id signature") +hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") +hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma") +hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma") +hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration") +hsSigDoc (MinimalSig {}) = ptext (sLit "MINIMAL pragma") + +{- +Check if signatures overlap; this is used when checking for duplicate +signatures. Since some of the signatures contain a list of names, testing for +equality is not enough -- we have to check if they overlap. +-} + +instance (OutputableBndr name) => Outputable (Sig name) where + ppr sig = ppr_sig sig + +ppr_sig :: OutputableBndr name => Sig name -> SDoc +ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (SpecSig var ty inl) + = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) +ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) +ppr_sig (SpecInstSig _ ty) + = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) +ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) +ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty) + = pprPatSynSig (unLoc name) False -- TODO: is_bindir + (pprHsForAll flag qtvs (noLoc [])) + (pprHsContextMaybe prov) (pprHsContextMaybe req) + (ppr ty) + +pprPatSynSig :: (OutputableBndr name) + => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc +pprPatSynSig ident _is_bidir tvs prov req ty + = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+> + tvs <+> context <+> ty + where + context = case (prov, req) of + (Nothing, Nothing) -> empty + (Nothing, Just req) -> parens empty <+> darrow <+> req <+> darrow + (Just prov, Nothing) -> prov <+> darrow + (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow + +instance OutputableBndr name => Outputable (FixitySig name) where + ppr (FixitySig names fixity) = sep [ppr fixity, pprops] + where + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") + +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) + +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = ppr inl + +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = ptext (sLit "") +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "")) inl + +pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc +pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf) + +{- +************************************************************************ +* * +\subsection[PatSynBind]{A pattern synonym definition} +* * +************************************************************************ +-} + +data HsPatSynDetails a + = InfixPatSyn a a + | PrefixPatSyn [a] + deriving (Data, Typeable) + +instance Functor HsPatSynDetails where + fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right) + fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args) + +instance Foldable HsPatSynDetails where + foldMap f (InfixPatSyn left right) = f left `mappend` f right + foldMap f (PrefixPatSyn args) = foldMap f args + + foldl1 f (InfixPatSyn left right) = left `f` right + foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args + + foldr1 f (InfixPatSyn left right) = left `f` right + foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args + +-- TODO: After a few more versions, we should probably use these. +#if __GLASGOW_HASKELL__ >= 709 + length (InfixPatSyn _ _) = 2 + length (PrefixPatSyn args) = Data.List.length args + + null (InfixPatSyn _ _) = False + null (PrefixPatSyn args) = Data.List.null args + + toList (InfixPatSyn left right) = [left, right] + toList (PrefixPatSyn args) = args +#endif + +instance Traversable HsPatSynDetails where + traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right + traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args + +data HsPatSynDir id + = Unidirectional + | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) + deriving (Typeable) +deriving instance (DataId id) => Data (HsPatSynDir id) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs new file mode 100644 index 00000000..4840768f --- /dev/null +++ b/compiler/hsSyn/HsDecls.hs @@ -0,0 +1,1754 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Abstract syntax of global declarations. +-- +-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, +-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +module HsDecls ( + -- * Toplevel declarations + HsDecl(..), LHsDecl, HsDataDefn(..), + -- ** Class or type declarations + TyClDecl(..), LTyClDecl, + TyClGroup(..), tyClGroupConcat, mkTyClGroup, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, + tyFamInstDeclName, tyFamInstDeclLName, + countTyClDecls, pprTyClDeclFlavour, + tyClDeclLName, tyClDeclTyVars, + hsDeclHasCusk, famDeclHasCusk, + FamilyDecl(..), LFamilyDecl, + + -- ** Instance declarations + InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), + TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, + DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, + TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, + HsTyPats, + LClsInstDecl, ClsInstDecl(..), + + -- ** Standalone deriving declarations + DerivDecl(..), LDerivDecl, + -- ** @RULE@ declarations + LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, + collectRuleBndrSigTys, + flattenRuleDecls, + -- ** @VECTORISE@ declarations + VectDecl(..), LVectDecl, + lvectDeclName, lvectInstDecl, + -- ** @default@ declarations + DefaultDecl(..), LDefaultDecl, + -- ** Template haskell declaration splice + SpliceExplicitFlag(..), + SpliceDecl(..), LSpliceDecl, + -- ** Foreign function interface declarations + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + noForeignImportCoercionYet, noForeignExportCoercionYet, + CImportSpec(..), + -- ** Data-constructor declarations + ConDecl(..), LConDecl, ResType(..), + HsConDeclDetails, hsConDeclArgTys, + -- ** Document comments + DocDecl(..), LDocDecl, docDeclDoc, + -- ** Deprecations + WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, + -- ** Role annotations + RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, + + -- * Grouping + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups + + ) where + +-- friends: +import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprUntypedSplice ) + -- Because Expr imports Decls via HsBracket + +import HsBinds +import HsPat +import HsTypes +import HsDoc +import TyCon +import Name +import BasicTypes +import Coercion +import ForeignCall +import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId ) +import NameSet + +-- others: +import InstEnv +import Class +import Outputable +import Util +import SrcLoc +import FastString + +import Bag +import Data.Data hiding (TyCon,Fixity) +#if __GLASGOW_HASKELL__ < 709 +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) +#endif +import Data.Maybe + +{- +************************************************************************ +* * +\subsection[HsDecl]{Declarations} +* * +************************************************************************ +-} + +type LHsDecl id = Located (HsDecl id) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | A Haskell Declaration +data HsDecl id + = TyClD (TyClDecl id) -- ^ A type or class declaration. + | InstD (InstDecl id) -- ^ An instance declaration. + | DerivD (DerivDecl id) + | ValD (HsBind id) + | SigD (Sig id) + | DefD (DefaultDecl id) + | ForD (ForeignDecl id) + | WarningD (WarnDecls id) + | AnnD (AnnDecl id) + | RuleD (RuleDecls id) + | VectD (VectDecl id) + | SpliceD (SpliceDecl id) + | DocD (DocDecl) + | QuasiQuoteD (HsQuasiQuote id) + | RoleAnnotD (RoleAnnotDecl id) + deriving (Typeable) +deriving instance (DataId id) => Data (HsDecl id) + + +-- NB: all top-level fixity decls are contained EITHER +-- EITHER SigDs +-- OR in the ClassDecls in TyClDs +-- +-- The former covers +-- a) data constructors +-- b) class methods (but they can be also done in the +-- signatures of class decls) +-- c) imported functions (that have an IfacSig) +-- d) top level decls +-- +-- The latter is for class methods only + +-- | A 'HsDecl' is categorised into a 'HsGroup' before being +-- fed to the renamer. +data HsGroup id + = HsGroup { + hs_valds :: HsValBinds id, + hs_splcds :: [LSpliceDecl id], + + hs_tyclds :: [TyClGroup id], + -- A list of mutually-recursive groups + -- No family-instances here; they are in hs_instds + -- Parser generates a singleton list; + -- renamer does dependency analysis + + hs_instds :: [LInstDecl id], + -- Both class and family instance declarations in here + + hs_derivds :: [LDerivDecl id], + + hs_fixds :: [LFixitySig id], + -- Snaffled out of both top-level fixity signatures, + -- and those in class declarations + + hs_defds :: [LDefaultDecl id], + hs_fords :: [LForeignDecl id], + hs_warnds :: [LWarnDecls id], + hs_annds :: [LAnnDecl id], + hs_ruleds :: [LRuleDecls id], + hs_vects :: [LVectDecl id], + + hs_docs :: [LDocDecl] + } deriving (Typeable) +deriving instance (DataId id) => Data (HsGroup id) + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], + hs_derivds = [], + hs_fixds = [], hs_defds = [], hs_annds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], + hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_splcds = [], + hs_docs = [] } + +appendGroups :: HsGroup a -> HsGroup a -> HsGroup a +appendGroups + HsGroup { + hs_valds = val_groups1, + hs_splcds = spliceds1, + hs_tyclds = tyclds1, + hs_instds = instds1, + hs_derivds = derivds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_vects = vects1, + hs_docs = docs1 } + HsGroup { + hs_valds = val_groups2, + hs_splcds = spliceds2, + hs_tyclds = tyclds2, + hs_instds = instds2, + hs_derivds = derivds2, + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_vects = vects2, + hs_docs = docs2 } + = + HsGroup { + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_splcds = spliceds1 ++ spliceds2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_instds = instds1 ++ instds2, + hs_derivds = derivds1 ++ derivds2, + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_vects = vects1 ++ vects2, + hs_docs = docs1 ++ docs2 } + +instance OutputableBndr name => Outputable (HsDecl name) where + ppr (TyClD dcl) = ppr dcl + ppr (ValD binds) = ppr binds + ppr (DefD def) = ppr def + ppr (InstD inst) = ppr inst + ppr (DerivD deriv) = ppr deriv + ppr (ForD fd) = ppr fd + ppr (SigD sd) = ppr sd + ppr (RuleD rd) = ppr rd + ppr (VectD vect) = ppr vect + ppr (WarningD wd) = ppr wd + ppr (AnnD ad) = ppr ad + ppr (SpliceD dd) = ppr dd + ppr (DocD doc) = ppr doc + ppr (QuasiQuoteD qq) = ppr qq + ppr (RoleAnnotD ra) = ppr ra + +instance OutputableBndr name => Outputable (HsGroup name) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = deprec_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls }) + = vcat_mb empty + [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds ann_decls, + ppr_ds rule_decls, + ppr_ds vect_decls, + if isEmptyValBinds val_decls + then Nothing + else Just (ppr val_decls), + ppr_ds (tyClGroupConcat tycl_decls), + ppr_ds inst_decls, + ppr_ds deriv_decls, + ppr_ds foreign_decls] + where + ppr_ds :: Outputable a => [a] -> Maybe SDoc + ppr_ds [] = Nothing + ppr_ds ds = Just (vcat (map ppr ds)) + + vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc + -- Concatenate vertically with white-space between non-blanks + vcat_mb _ [] = empty + vcat_mb gap (Nothing : ds) = vcat_mb gap ds + vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + +data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) + ImplicitSplice -- <=> f x y, i.e. a naked top level expression + deriving (Data, Typeable) + +type LSpliceDecl name = Located (SpliceDecl name) +data SpliceDecl id + = SpliceDecl -- Top level splice + (Located (HsSplice id)) + SpliceExplicitFlag + deriving (Typeable) +deriving instance (DataId id) => Data (SpliceDecl id) + +instance OutputableBndr name => Outputable (SpliceDecl name) where + ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e + +{- +************************************************************************ +* * +\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration} +* * +************************************************************************ + + -------------------------------- + THE NAMING STORY + -------------------------------- + +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! + +"Implicit" (or "system") binders +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Each data type decl defines + a worker name for each constructor + to-T and from-T convertors + Each class decl defines + a tycon for the class + a data constructor for that tycon + the worker for that constructor + a selector for each superclass + +All have occurrence names that are derived uniquely from their parent +declaration. + +None of these get separate definitions in an interface file; they are +fully defined by the data or class decl. But they may *occur* in +interface files, of course. Any such occurrence must haul in the +relevant type or class decl. + +Plan of attack: + - Ensure they "point to" the parent data/class decl + when loading that decl from an interface file + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (RnEnv.lookupSysName), + to ensure correct module and provenance is set + +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in OccName.mkWorkerOcc, etc.) + +Default methods +~~~~~~~~~~~~~~~ + - Occurrence name is derived uniquely from the method name + E.g. $dmmax + + - If there is a default method name at all, it's recorded in + the ClassOpSig (in HsBinds), in the DefMeth field. + (DefMeth is defined in Class.lhs) + +Source-code class decls and interface-code class decls are treated subtly +differently, which has given me a great deal of confusion over the years. +Here's the deal. (We distinguish the two cases because source-code decls +have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. + +In *source-code* class declarations: + + - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName + This is done by RdrHsSyn.mkClassOpSigDM + + - The renamer renames it to a Name + + - During typechecking, we generate a binding for each $dm for + which there's a programmer-supplied default method: + class Foo a where + op1 :: + op2 :: + op1 = ... + We generate a binding for $dmop1 but not for $dmop2. + The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1. + The Name for $dmop2 is simply discarded. + +In *interface-file* class declarations: + - When parsing, we see if there's an explicit programmer-supplied default method + because there's an '=' sign to indicate it: + class Foo a where + op1 = :: -- NB the '=' + op2 :: + We use this info to generate a DefMeth with a suitable RdrName for op1, + and a NoDefMeth for op2 + - The interface file has a separate definition for $dmop1, with unfolding etc. + - The renamer renames it to a Name. + - The renamer treats $dmop1 as a free variable of the declaration, so that + the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) + This doesn't happen for source code class decls, because they *bind* the default method. + +Dictionary functions +~~~~~~~~~~~~~~~~~~~~ +Each instance declaration gives rise to one dictionary function binding. + +The type checker makes up new source-code instance declarations +(e.g. from 'deriving' or generic default methods --- see +TcInstDcls.tcInstDecls1). So we can't generate the names for +dictionary functions in advance (we don't know how many we need). + +On the other hand for interface-file instance declarations, the decl +specifies the name of the dictionary function, and it has a binding elsewhere +in the interface file: + instance {Eq Int} = dEqInt + dEqInt :: {Eq Int} + +So again we treat source code and interface file code slightly differently. + +Source code: + - Source code instance decls have a Nothing in the (Maybe name) field + (see data InstDecl below) + + - The typechecker makes up a Local name for the dict fun for any source-code + instance decl, whether it comes from a source-code instance decl, or whether + the instance decl is derived from some other construct (e.g. 'deriving'). + + - The occurrence name it chooses is derived from the instance decl (just for + documentation really) --- e.g. dNumInt. Two dict funs may share a common + occurrence name, but will have different uniques. E.g. + instance Foo [Int] where ... + instance Foo [Bool] where ... + These might both be dFooList + + - The CoreTidy phase externalises the name, and ensures the occurrence name is + unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. + + - We can take this relaxed approach (changing the occurrence name later) + because dict fun Ids are not captured in a TyCon or Class (unlike default + methods, say). Instead, they are kept separately in the InstEnv. This + makes it easy to adjust them after compiling a module. (Once we've finished + compiling that module, they don't change any more.) + + +Interface file code: + - The instance decl gives the dict fun name, so the InstDecl has a (Just name) + in the (Maybe name) field. + + - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we + suck in the dfun binding +-} + +type LTyClDecl name = Located (TyClDecl name) + +-- | A type or class declaration. +data TyClDecl name + = -- | @type/data family T :: *->*@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + FamDecl { tcdFam :: FamilyDecl name } + + | -- | @type@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnEqual', + + -- For details on above see note [Api annotations] in ApiAnnotation + SynDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type + -- these include outer binders + , tcdRhs :: LHsType name -- ^ RHS of type declaration + , tcdFVs :: PostRn name NameSet } + + | -- | @data@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnNewType', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere', + + -- For details on above see note [Api annotations] in ApiAnnotation + DataDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an assoicated type + -- these include outer binders + -- Eg class T a where + -- type F a :: * + -- type F a = a -> a + -- Here the type decl for 'f' includes 'a' + -- in its tcdTyVars + , tcdDataDefn :: HsDataDefn name + , tcdFVs :: PostRn name NameSet } + + | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... + tcdLName :: Located name, -- ^ Name of the class + tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables + tcdFDs :: [Located (FunDep (Located name))], + -- ^ Functional deps + tcdSigs :: [LSig name], -- ^ Methods' signatures + tcdMeths :: LHsBinds name, -- ^ Default methods + tcdATs :: [LFamilyDecl name], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults + tcdDocs :: [LDocDecl], -- ^ Haddock docs + tcdFVs :: PostRn name NameSet + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnComma' + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + + deriving (Typeable) +deriving instance (DataId id) => Data (TyClDecl id) + + -- This is used in TcTyClsDecls to represent + -- strongly connected components of decls + -- No familiy instances in here + -- The role annotations must be grouped with their decls for the + -- type-checker to infer roles correctly +data TyClGroup name + = TyClGroup { group_tyclds :: [LTyClDecl name] + , group_roles :: [LRoleAnnotDecl name] } + deriving (Typeable) +deriving instance (DataId id) => Data (TyClGroup id) + +tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name] +tyClGroupConcat = concatMap group_tyclds + +mkTyClGroup :: [LTyClDecl name] -> TyClGroup name +mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] } + +type LFamilyDecl name = Located (FamilyDecl name) +data FamilyDecl name = FamilyDecl + { fdInfo :: FamilyInfo name -- type or data, closed or open + , fdLName :: Located name -- type constructor + , fdTyVars :: LHsTyVarBndrs name -- type variables + , fdKindSig :: Maybe (LHsKind name) } -- result kind + deriving( Typeable ) +deriving instance (DataId id) => Data (FamilyDecl id) + +data FamilyInfo name + = DataFamily + | OpenTypeFamily + -- this list might be empty, if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily [LTyFamInstEqn name] + deriving( Typeable ) +deriving instance (DataId name) => Data (FamilyInfo name) + +{- +------------------------------ +Simple classifiers +-} + +-- | @True@ <=> argument is a @data@\/@newtype@ +-- declaration. +isDataDecl :: TyClDecl name -> Bool +isDataDecl (DataDecl {}) = True +isDataDecl _other = False + +-- | type or type instance declaration +isSynDecl :: TyClDecl name -> Bool +isSynDecl (SynDecl {}) = True +isSynDecl _other = False + +-- | type class +isClassDecl :: TyClDecl name -> Bool +isClassDecl (ClassDecl {}) = True +isClassDecl _ = False + +-- | type/data family declaration +isFamilyDecl :: TyClDecl name -> Bool +isFamilyDecl (FamDecl {}) = True +isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl name -> Bool +isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of + OpenTypeFamily -> True + ClosedTypeFamily {} -> True + _ -> False +isTypeFamilyDecl _ = False + +-- | open type family info +isOpenTypeFamilyInfo :: FamilyInfo name -> Bool +isOpenTypeFamilyInfo OpenTypeFamily = True +isOpenTypeFamilyInfo _ = False + +-- | closed type family info +isClosedTypeFamilyInfo :: FamilyInfo name -> Bool +isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True +isClosedTypeFamilyInfo _ = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl name -> Bool +isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl _other = False + +-- Dealing with names + +tyFamInstDeclName :: OutputableBndr name + => TyFamInstDecl name -> name +tyFamInstDeclName = unLoc . tyFamInstDeclLName + +tyFamInstDeclLName :: OutputableBndr name + => TyFamInstDecl name -> Located name +tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = + (L _ (TyFamEqn { tfe_tycon = ln })) }) + = ln + +tyClDeclLName :: TyClDecl name -> Located name +tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln +tyClDeclLName decl = tcdLName decl + +tcdName :: TyClDecl name -> name +tcdName = unLoc . tyClDeclLName + +tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name +tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs +tyClDeclTyVars d = tcdTyVars d + +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True + isNewTy _ = False + +-- | Does this declaration have a complete, user-supplied kind signature? +-- See Note [Complete user-supplied kind signatures] +hsDeclHasCusk :: TyClDecl name -> Bool +hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl +hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + = hsTvbAllKinded tyvars && rhs_annotated rhs + where + rhs_annotated (L _ ty) = case ty of + HsParTy lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False +hsDeclHasCusk (DataDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars + +-- | Does this family declaration have a complete, user-supplied kind signature? +famDeclHasCusk :: FamilyDecl name -> Bool +famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _ + , fdTyVars = tyvars + , fdKindSig = m_sig }) + = hsTvbAllKinded tyvars && isJust m_sig +famDeclHasCusk _ = True -- all open families have CUSKs! + +{- +Note [Complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy +and #9200 for lots of discussion of how we got here. + +A declaration has a CUSK if we can know its complete kind without doing any inference, +at all. Here are the rules: + + - A class or datatype is said to have a CUSK if and only if all of its type +variables are annotated. Its result kind is, by construction, Constraint or * +respectively. + + - A type synonym has a CUSK if and only if all of its type variables and its +RHS are annotated with kinds. + + - A closed type family is said to have a CUSK if and only if all of its type +variables and its return type are annotated. + + - An open type family always has a CUSK -- unannotated type variables (and return type) default to *. +-} + +instance OutputableBndr name + => Outputable (TyClDecl name) where + + ppr (FamDecl { tcdFam = decl }) = ppr decl + ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) + = hang (ptext (sLit "type") <+> + pp_vanilla_decl_head ltycon tyvars [] <+> equals) + 4 (ppr rhs) + + ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn }) + = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn + + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs}) + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> ptext (sLit "where") + , nest 2 $ pprDeclList (map ppr ats ++ + map ppr_fam_deflt_eqn at_defs ++ + pprLHsBindsForUser methods sigs) ] + where + top_matter = ptext (sLit "class") + <+> pp_vanilla_decl_head lclas tyvars (unLoc context) + <+> pprFundeps (map unLoc fds) + +instance OutputableBndr name => Outputable (TyClGroup name) where + ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles }) + = ppr tyclds $$ + ppr roles + +instance (OutputableBndr name) => Outputable (FamilyDecl name) where + ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, + fdTyVars = tyvars, fdKindSig = mb_kind}) + = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where + , nest 2 $ pp_eqns ] + where + pp_kind = case mb_kind of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + (pp_where, pp_eqns) = case info of + ClosedTypeFamily eqns -> ( ptext (sLit "where") + , if null eqns + then ptext (sLit "..") + else vcat $ map ppr_fam_inst_eqn eqns ) + _ -> (empty, empty) + +pprFlavour :: FamilyInfo name -> SDoc +pprFlavour DataFamily = ptext (sLit "data family") +pprFlavour OpenTypeFamily = ptext (sLit "type family") +pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family") + +instance Outputable (FamilyInfo name) where + ppr = pprFlavour + +pp_vanilla_decl_head :: OutputableBndr name + => Located name + -> LHsTyVarBndrs name + -> HsContext name + -> SDoc +pp_vanilla_decl_head thing tyvars context + = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] + +pp_fam_inst_lhs :: OutputableBndr name + => Located name + -> HsTyPats name + -> HsContext name + -> SDoc +pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns + = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) typats)] + +pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd + +{- +************************************************************************ +* * +\subsection[ConDecl]{A data-constructor declaration} +* * +************************************************************************ +-} + +data HsDataDefn name -- The payload of a data type defn + -- Used *both* for vanilla data declarations, + -- *and* for data family instances + = -- | Declares a data type or newtype, giving its constructors + -- @ + -- data/newtype T a = + -- data/newtype instance T [a] = + -- @ + HsDataDefn { dd_ND :: NewOrData, + dd_ctxt :: LHsContext name, -- ^ Context + dd_cType :: Maybe (Located CType), + dd_kindSig:: Maybe (LHsKind name), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, + -- or @data instance@ decl, with explicit kind sig + -- + -- Always @Nothing@ for H98-syntax decls + + dd_cons :: [LConDecl name], + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ResTyH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ResTyGADT'. + + dd_derivs :: Maybe (Located [LHsType name]) + -- ^ Derivings; @Nothing@ => not specified, + -- @Just []@ => derive exactly what is asked + -- + -- These "types" must be of form + -- @ + -- forall ab. C ty1 ty2 + -- @ + -- Typically the foralls and ty args are empty, but they + -- are non-empty for the newtype-deriving case + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + deriving( Typeable ) +deriving instance (DataId id) => Data (HsDataDefn id) + +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving( Eq, Data, Typeable ) -- Needed because Demand derives Eq + +type LConDecl name = Located (ConDecl name) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when + -- in a GADT constructor list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | +-- +-- @ +-- data T b = forall a. Eq a => MkT a b +-- MkT :: forall b a. Eq a => MkT a b +-- +-- data T b where +-- MkT1 :: Int -> T Int +-- +-- data T = Int `MkT` Int +-- | MkT2 +-- +-- data T a where +-- Int `MkT` Int :: T Int +-- @ +-- +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', +-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' + +-- For details on above see note [Api annotations] in ApiAnnotation +data ConDecl name + = ConDecl + { con_names :: [Located name] + -- ^ Constructor names. This is used for the DataCon itself, and for + -- the user-callable wrapper Id. + -- It is a list to deal with GADT constructors of the form + -- T1, T2, T3 :: + , con_explicit :: HsExplicitFlag + -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') + + , con_qvars :: LHsTyVarBndrs name + -- ^ Type variables. Depending on 'con_res' this describes the + -- following entities + -- + -- - ResTyH98: the constructor's *existential* type variables + -- - ResTyGADT: *all* the constructor's quantified type variables + -- + -- If con_explicit is Implicit, then con_qvars is irrelevant + -- until after renaming. + + , con_cxt :: LHsContext name + -- ^ The context. This /does not/ include the \"stupid theta\" which + -- lives only in the 'TyData' decl. + + , con_details :: HsConDeclDetails name + -- ^ The main payload + + , con_res :: ResType (LHsType name) + -- ^ Result type of the constructor + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + + , con_old_rec :: Bool + -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for + -- GADT-style record decl C { blah } :: T a b + -- Remove this when we no longer parse this stuff, and hence do not + -- need to report decprecated use + } deriving (Typeable) +deriving instance (DataId name) => Data (ConDecl name) + +type HsConDeclDetails name + = HsConDetails (LBangType name) (Located [LConDeclField name]) + +hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] +hsConDeclArgTys (PrefixCon tys) = tys +hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] +hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) + +data ResType ty + = ResTyH98 -- Constructor was declared using Haskell 98 syntax + | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax, + -- and here is its result type, and the SrcSpan + -- of the original sigtype, for API Annotations + deriving (Data, Typeable) + +instance Outputable ty => Outputable (ResType ty) where + -- Debugging only + ppr ResTyH98 = ptext (sLit "ResTyH98") + ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty + +pp_data_defn :: OutputableBndr name + => (HsContext name -> SDoc) -- Printing the header + -> HsDataDefn name + -> SDoc +pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) + | null condecls + = ppr new_or_data <+> pp_hdr context <+> pp_sig + + | otherwise + = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) + 2 (pp_condecls condecls $$ pp_derivings) + where + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_derivings = case derivings of + Nothing -> empty + Just (L _ ds) -> hsep [ptext (sLit "deriving"), + parens (interpp'SP ds)] + +instance OutputableBndr name => Outputable (HsDataDefn name) where + ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d + +instance Outputable NewOrData where + ppr NewType = ptext (sLit "newtype") + ppr DataType = ptext (sLit "data") + +pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc +pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax + = hang (ptext (sLit "where")) 2 (vcat (map ppr cs)) +pp_condecls cs -- In H98 syntax + = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) + +instance (OutputableBndr name) => Outputable (ConDecl name) where + ppr = pprConDecl + +pprConDecl :: OutputableBndr name => ConDecl name -> SDoc +pprConDecl (ConDecl { con_names = [L _ con] -- NB: non-GADT means 1 con + , con_explicit = expl, con_qvars = tvs + , con_cxt = cxt, con_details = details + , con_res = ResTyH98, con_doc = doc }) + = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] + where + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con + : map (pprParendHsType . unLoc) tys) + ppr_details (RecCon fields) = pprPrefixOcc con + <+> pprConDeclFields (unLoc fields) + +pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs + , con_cxt = cxt, con_details = PrefixCon arg_tys + , con_res = ResTyGADT _ res_ty }) + = ppr_con_names cons <+> dcolon <+> + sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] + where + mk_fun_ty a b = noLoc (HsFunTy a b) + +pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs + , con_cxt = cxt, con_details = RecCon fields + , con_res = ResTyGADT _ res_ty }) + = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt, + pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] + +pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) + = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] }) + -- In GADT syntax we don't allow infix constructors + -- so if we ever trip over one (albeit I can't see how that + -- can happen) print it like a prefix one + +-- this fallthrough would happen with a non-GADT-syntax ConDecl with more +-- than one constructor, which should indeed be impossible +pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons) + +ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc +ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) + +{- +************************************************************************ +* * + Instance declarations +* * +************************************************************************ + +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type TyFamEqn represents one equation of a type family instance. +It is parameterised over its tfe_pats field: + + * An ordinary type family instance declaration looks like this in source Haskell + type instance T [a] Int = a -> a + (or something similar for a closed family) + It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. + + * On the other hand, the *default instance* of an associated type looksl like + this in source Haskell + class C a where + type T a b + type T a b = a -> b -- The default instance + It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field. +-} + +----------------- Type synonym family instances ------------- +type LTyFamInstEqn name = Located (TyFamInstEqn name) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- when in a list + +-- For details on above see note [Api annotations] in ApiAnnotation + +type LTyFamDefltEqn name = Located (TyFamDefltEqn name) + +type HsTyPats name = HsWithBndrs name [LHsType name] + -- ^ Type patterns (with kind and type bndrs) + -- See Note [Family instance declaration binders] + +type TyFamInstEqn name = TyFamEqn name (HsTyPats name) +type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) + -- See Note [Type family instance declarations in HsSyn] + +-- | One equation in a type family instance declaration +-- See Note [Type family instance declarations in HsSyn] +data TyFamEqn name pats + = TyFamEqn + { tfe_tycon :: Located name + , tfe_pats :: pats + , tfe_rhs :: LHsType name } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving( Typeable ) +deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats) + +type LTyFamInstDecl name = Located (TyFamInstDecl name) +data TyFamInstDecl name + = TyFamInstDecl + { tfid_eqn :: LTyFamInstEqn name + , tfid_fvs :: PostRn name NameSet } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnInstance', + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving( Typeable ) +deriving instance (DataId name) => Data (TyFamInstDecl name) + +----------------- Data family instances ------------- + +type LDataFamInstDecl name = Located (DataFamInstDecl name) +data DataFamInstDecl name + = DataFamInstDecl + { dfid_tycon :: Located name + , dfid_pats :: HsTyPats name -- LHS + , dfid_defn :: HsDataDefn name -- RHS + , dfid_fvs :: PostRn name NameSet } -- Free vars for + -- dependency analysis + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving( Typeable ) +deriving instance (DataId name) => Data (DataFamInstDecl name) + + +----------------- Class instances ------------- + +type LClsInstDecl name = Located (ClsInstDecl name) +data ClsInstDecl name + = ClsInstDecl + { cid_poly_ty :: LHsType name -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds name -- Class methods + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances + , cid_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId id) => Data (ClsInstDecl id) + + +----------------- Instances of all kinds ------------- + +type LInstDecl name = Located (InstDecl name) +data InstDecl name -- Both class and family instances + = ClsInstD + { cid_inst :: ClsInstDecl name } + | DataFamInstD -- data family instance + { dfid_inst :: DataFamInstDecl name } + | TyFamInstD -- type family instance + { tfid_inst :: TyFamInstDecl name } + deriving (Typeable) +deriving instance (DataId id) => Data (InstDecl id) + +{- +Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A {Ty|Data}FamInstDecl is a data/type family instance declaration +the pats field is LHS patterns, and the tvs of the HsBSig +tvs are fv(pat_tys), *including* ones that are already in scope + + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The tcdTyVars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type patter in the 'instance' decl and + in the associated 'type' decl +-} + +instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where + ppr = pprTyFamInstDecl TopLevel + +pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) + = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn + +ppr_instance_keyword :: TopLevelFlag -> SDoc +ppr_instance_keyword TopLevel = ptext (sLit "instance") +ppr_instance_keyword NotTopLevel = empty + +ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = pats + , tfe_rhs = rhs })) + = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs + +ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tvs + , tfe_rhs = rhs })) + = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs + +instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where + ppr = pprDataFamInstDecl TopLevel + +pprDataFamInstDecl :: OutputableBndr name => TopLevelFlag -> DataFamInstDecl name -> SDoc +pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon + , dfid_pats = pats + , dfid_defn = defn }) + = pp_data_defn pp_hdr defn + where + pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pp_fam_inst_lhs tycon pats ctxt + +pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc +pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) + = ppr nd + +instance (OutputableBndr name) => Outputable (ClsInstDecl name) where + ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> ptext (sLit "where") + , nest 2 $ pprDeclList $ + map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ + map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ + pprLHsBindsForUser binds sigs ] + where + top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + +ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just (L _ (NoOverlap _)) -> ptext (sLit "{-# NO_OVERLAP #-}") + Just (L _ (Overlappable _)) -> ptext (sLit "{-# OVERLAPPABLE #-}") + Just (L _ (Overlapping _)) -> ptext (sLit "{-# OVERLAPPING #-}") + Just (L _ (Overlaps _)) -> ptext (sLit "{-# OVERLAPS #-}") + Just (L _ (Incoherent _)) -> ptext (sLit "{-# INCOHERENT #-}") + + + + +instance (OutputableBndr name) => Outputable (InstDecl name) where + ppr (ClsInstD { cid_inst = decl }) = ppr decl + ppr (TyFamInstD { tfid_inst = decl }) = ppr decl + ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + +-- Extract the declarations of associated data types from an instance + +instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name] +instDeclDataFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) + = map unLoc fam_insts + do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] + do_one (L _ (TyFamInstD {})) = [] + +{- +************************************************************************ +* * +\subsection[DerivDecl]{A stand-alone instance deriving declaration} +* * +************************************************************************ +-} + +type LDerivDecl name = Located (DerivDecl name) + +data DerivDecl name = DerivDecl + { deriv_type :: LHsType name + , deriv_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnInstance' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + deriving (Typeable) +deriving instance (DataId name) => Data (DerivDecl name) + +instance (OutputableBndr name) => Outputable (DerivDecl name) where + ppr (DerivDecl ty o) + = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty] + +{- +************************************************************************ +* * +\subsection[DefaultDecl]{A @default@ declaration} +* * +************************************************************************ + +There can only be one default declaration per module, but it is hard +for the parser to check that; we pass them all through in the abstract +syntax, and that restriction must be checked in the front end. +-} + +type LDefaultDecl name = Located (DefaultDecl name) + +data DefaultDecl name + = DefaultDecl [LHsType name] + -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (DefaultDecl name) + +instance (OutputableBndr name) + => Outputable (DefaultDecl name) where + + ppr (DefaultDecl tys) + = ptext (sLit "default") <+> parens (interpp'SP tys) + +{- +************************************************************************ +* * +\subsection{Foreign function interface declaration} +* * +************************************************************************ +-} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used +-- +type LForeignDecl name = Located (ForeignDecl name) + +data ForeignDecl name + = ForeignImport (Located name) -- defines this name + (LHsType name) -- sig_ty + (PostTc name Coercion) -- rep_ty ~ sig_ty + ForeignImport + | ForeignExport (Located name) -- uses this name + (LHsType name) -- sig_ty + (PostTc name Coercion) -- sig_ty ~ rep_ty + ForeignExport + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', + -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (ForeignDecl name) +{- + In both ForeignImport and ForeignExport: + sig_ty is the type given in the Haskell code + rep_ty is the representation for this type, i.e. with newtypes + coerced away and type functions evaluated. + Thus if the declaration is valid, then rep_ty will only use types + such as Int and IO that we know how to make foreign calls with. +-} + +noForeignImportCoercionYet :: PlaceHolder +noForeignImportCoercionYet = PlaceHolder + +noForeignExportCoercionYet :: PlaceHolder +noForeignExportCoercionYet = PlaceHolder + +-- Specification Of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (Located CCallConv) -- ccall or stdcall + (Located Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + (Located SourceText) -- original source text for + -- the C entity + deriving (Data, Typeable) + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) + deriving (Data, Typeable) + +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport = CExport (Located CExportSpec) -- contains the calling + -- convention + (Located SourceText) -- original source text for + -- the C entity + deriving (Data, Typeable) + +-- pretty printing of foreign declarations +-- + +instance OutputableBndr name => Outputable (ForeignDecl name) where + ppr (ForeignImport n ty _ fimport) = + hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport n ty _ fexport) = + hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n) + 2 (dcolon <+> ppr ty) + +instance Outputable ForeignImport where + ppr (CImport cconv safety mHeader spec _) = + ppr cconv <+> ppr safety <+> + char '"' <> pprCEntity spec <> char '"' + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header header) -> ftext header + + pprCEntity (CLabel lbl) = + ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget lbl _ isFun)) = + ptext (sLit "static") + <+> pp_hdr + <+> (if isFun then empty else ptext (sLit "value")) + <+> ppr lbl + pprCEntity (CFunction (DynamicTarget)) = + ptext (sLit "dynamic") + pprCEntity (CWrapper) = ptext (sLit "wrapper") + +instance Outputable ForeignExport where + ppr (CExport (L _ (CExportStatic lbl cconv)) _) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ +-} + +type LRuleDecls name = Located (RuleDecls name) + + -- Note [Pragma source text] in BasicTypes +data RuleDecls name = HsRules { rds_src :: SourceText + , rds_rules :: [LRuleDecl name] } + deriving (Typeable) +deriving instance (DataId name) => Data (RuleDecls name) + +type LRuleDecl name = Located (RuleDecl name) + +data RuleDecl name + = HsRule -- Source rule + (Located RuleName) -- Rule name + Activation + [LRuleBndr name] -- Forall'd vars; after typechecking this + -- includes tyvars + (Located (HsExpr name)) -- LHS + (PostRn name NameSet) -- Free-vars from the LHS + (Located (HsExpr name)) -- RHS + (PostRn name NameSet) -- Free-vars from the RHS + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', + -- 'ApiAnnotation.AnnEqual', + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (RuleDecl name) + +flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name] +flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls + +type LRuleBndr name = Located (RuleBndr name) +data RuleBndr name + = RuleBndr (Located name) + | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name)) + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (RuleBndr name) + +collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] + +instance OutputableBndr name => Outputable (RuleDecls name) where + ppr (HsRules _ rules) = ppr rules + +instance OutputableBndr name => Outputable (RuleDecl name) where + ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) + = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name) + <+> ppr act, + nest 4 (pp_forall <+> pprExpr (unLoc lhs)), + nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] + where + pp_forall | null ns = empty + | otherwise = forAllLit <+> fsep (map ppr ns) <> dot + +instance OutputableBndr name => Outputable (RuleBndr name) where + ppr (RuleBndr name) = ppr name + ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty + +{- +************************************************************************ +* * +\subsection{Vectorisation declarations} +* * +************************************************************************ + +A vectorisation pragma, one of + + {-# VECTORISE f = closure1 g (scalar_map g) #-} + {-# VECTORISE SCALAR f #-} + {-# NOVECTORISE f #-} + + {-# VECTORISE type T = ty #-} + {-# VECTORISE SCALAR type T #-} +-} + +type LVectDecl name = Located (VectDecl name) + +data VectDecl name + = HsVect + SourceText -- Note [Pragma source text] in BasicTypes + (Located name) + (LHsExpr name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsNoVect + SourceText -- Note [Pragma source text] in BasicTypes + (Located name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsVectTypeIn -- pre type-checking + SourceText -- Note [Pragma source text] in BasicTypes + Bool -- 'TRUE' => SCALAR declaration + (Located name) + (Maybe (Located name)) -- 'Nothing' => no right-hand side + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnEqual' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsVectTypeOut -- post type-checking + Bool -- 'TRUE' => SCALAR declaration + TyCon + (Maybe TyCon) -- 'Nothing' => no right-hand side + | HsVectClassIn -- pre type-checking + SourceText -- Note [Pragma source text] in BasicTypes + (Located name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsVectClassOut -- post type-checking + Class + | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now + (LHsType name) + | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now + ClsInst + deriving (Typeable) +deriving instance (DataId name) => Data (VectDecl name) + +lvectDeclName :: NamedThing name => LVectDecl name -> Name +lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon +lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectClassOut cls)) = getName cls +lvectDeclName (L _ (HsVectInstIn _)) + = panic "HsDecls.lvectDeclName: HsVectInstIn" +lvectDeclName (L _ (HsVectInstOut _)) + = panic "HsDecls.lvectDeclName: HsVectInstOut" + +lvectInstDecl :: LVectDecl name -> Bool +lvectInstDecl (L _ (HsVectInstIn _)) = True +lvectInstDecl (L _ (HsVectInstOut _)) = True +lvectInstDecl _ = False + +instance OutputableBndr name => Outputable (VectDecl name) where + ppr (HsVect _ v rhs) + = sep [text "{-# VECTORISE" <+> ppr v, + nest 4 $ + pprExpr (unLoc rhs) <+> text "#-}" ] + ppr (HsNoVect _ v) + = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] + ppr (HsVectTypeIn _ False t Nothing) + = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] + ppr (HsVectTypeIn _ False t (Just t')) + = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] + ppr (HsVectTypeIn _ True t Nothing) + = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] + ppr (HsVectTypeIn _ True t (Just t')) + = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] + ppr (HsVectTypeOut False t Nothing) + = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] + ppr (HsVectTypeOut False t (Just t')) + = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] + ppr (HsVectTypeOut True t Nothing) + = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] + ppr (HsVectTypeOut True t (Just t')) + = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] + ppr (HsVectClassIn _ c) + = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] + ppr (HsVectClassOut c) + = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] + ppr (HsVectInstIn ty) + = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ] + ppr (HsVectInstOut i) + = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ] + +{- +************************************************************************ +* * +\subsection[DocDecl]{Document comments} +* * +************************************************************************ +-} + +type LDocDecl = Located (DocDecl) + +data DocDecl + = DocCommentNext HsDocString + | DocCommentPrev HsDocString + | DocCommentNamed String HsDocString + | DocGroup Int HsDocString + deriving (Data, Typeable) + +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable DocDecl where + ppr _ = text "" + +docDeclDoc :: DocDecl -> HsDocString +docDeclDoc (DocCommentNext d) = d +docDeclDoc (DocCommentPrev d) = d +docDeclDoc (DocCommentNamed _ d) = d +docDeclDoc (DocGroup _ d) = d + +{- +************************************************************************ +* * +\subsection[DeprecDecl]{Deprecations} +* * +************************************************************************ + +We use exported entities for things to deprecate. +-} + + +type LWarnDecls name = Located (WarnDecls name) + + -- Note [Pragma source text] in BasicTypes +data WarnDecls name = Warnings { wd_src :: SourceText + , wd_warnings :: [LWarnDecl name] + } + deriving (Data, Typeable) + + +type LWarnDecl name = Located (WarnDecl name) + +data WarnDecl name = Warning [Located name] WarningTxt + deriving (Data, Typeable) + +instance OutputableBndr name => Outputable (WarnDecls name) where + ppr (Warnings _ decls) = ppr decls + +instance OutputableBndr name => Outputable (WarnDecl name) where + ppr (Warning thing txt) + = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] + +{- +************************************************************************ +* * +\subsection[AnnDecl]{Annotations} +* * +************************************************************************ +-} + +type LAnnDecl name = Located (AnnDecl name) + +data AnnDecl name = HsAnnotation + SourceText -- Note [Pragma source text] in BasicTypes + (AnnProvenance name) (Located (HsExpr name)) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnType' + -- 'ApiAnnotation.AnnModule' + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (AnnDecl name) + +instance (OutputableBndr name) => Outputable (AnnDecl name) where + ppr (HsAnnotation _ provenance expr) + = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + +data AnnProvenance name = ValueAnnProvenance (Located name) + | TypeAnnProvenance (Located name) + | ModuleAnnProvenance + deriving (Data, Typeable, Functor) +deriving instance Foldable AnnProvenance +deriving instance Traversable AnnProvenance + +annProvenanceName_maybe :: AnnProvenance name -> Maybe name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing + +pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc +pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") +pprAnnProvenance (ValueAnnProvenance (L _ name)) + = ptext (sLit "ANN") <+> ppr name +pprAnnProvenance (TypeAnnProvenance (L _ name)) + = ptext (sLit "ANN type") <+> ppr name + +{- +************************************************************************ +* * +\subsection[RoleAnnot]{Role annotations} +* * +************************************************************************ +-} + +type LRoleAnnotDecl name = Located (RoleAnnotDecl name) + +-- See #8185 for more info about why role annotations are +-- top-level declarations +data RoleAnnotDecl name + = RoleAnnotDecl (Located name) -- type constructor + [Located (Maybe Role)] -- optional annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnRole' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Data, Typeable) + +instance OutputableBndr name => Outputable (RoleAnnotDecl name) where + ppr (RoleAnnotDecl ltycon roles) + = ptext (sLit "type role") <+> ppr ltycon <+> + hsep (map (pp_role . unLoc) roles) + where + pp_role Nothing = underscore + pp_role (Just r) = ppr r + +roleAnnotDeclName :: RoleAnnotDecl name -> name +roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs new file mode 100644 index 00000000..72bf0e56 --- /dev/null +++ b/compiler/hsSyn/HsDoc.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module HsDoc ( + HsDocString(..), + LHsDocString, + ppr_mbDoc + ) where + +#include "HsVersions.h" + +import Outputable +import SrcLoc +import FastString + +import Data.Data + +newtype HsDocString = HsDocString FastString + deriving (Eq, Show, Data, Typeable) + +type LHsDocString = Located HsDocString + +instance Outputable HsDocString where + ppr (HsDocString fs) = ftext fs + +ppr_mbDoc :: Maybe LHsDocString -> SDoc +ppr_mbDoc (Just doc) = ppr doc +ppr_mbDoc Nothing = empty + diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs new file mode 100644 index 00000000..7a66a50d --- /dev/null +++ b/compiler/hsSyn/HsExpr.hs @@ -0,0 +1,1951 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} + +-- | Abstract Haskell syntax for expressions. +module HsExpr where + +#include "HsVersions.h" + +-- friends: +import HsDecls +import HsPat +import HsLit +import PlaceHolder ( PostTc,PostRn,DataId ) +import HsTypes +import HsBinds + +-- others: +import TcEvidence +import CoreSyn +import Var +import RdrName +import Name +import BasicTypes +import DataCon +import SrcLoc +import Util +import StaticFlags( opt_PprStyle_Debug ) +import Outputable +import FastString +import Type + +-- libraries: +import Data.Data hiding (Fixity) + +{- +************************************************************************ +* * +\subsection{Expressions proper} +* * +************************************************************************ +-} + +-- * Expressions proper + +type LHsExpr id = Located (HsExpr id) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +------------------------- +-- | PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr Id +-- | We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +noPostTcExpr :: PostTcExpr +noPostTcExpr = HsLit (HsString "" (fsLit "noPostTcExpr")) + +noPostTcTable :: PostTcTable +noPostTcTable = [] + +------------------------- +-- | SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, +-- by the renamer. It's used for rebindable syntax. +-- +-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for +-- @(>>=)@, and then instantiated by the type checker with its type args +-- etc + +type SyntaxExpr id = HsExpr id + +noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, + -- (if the syntax slot makes no sense) +noSyntaxExpr = HsLit (HsString "" (fsLit "noSyntaxExpr")) + + +type CmdSyntaxTable id = [(Name, SyntaxExpr id)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxtable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious RnExpr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +-- | A Haskell expression. +data HsExpr id + = HsVar id -- ^ Variable + | HsIPVar HsIPName -- ^ Implicit parameter + | HsOverLit (HsOverLit id) -- ^ Overloaded literals + + | HsLit HsLit -- ^ Simple (non-overloaded) literals + + | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application + + -- | Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + + | OpApp (LHsExpr id) -- left operand + (LHsExpr id) -- operator + (PostRn id Fixity) -- Renamer adds fixity; bottom until then + (LHsExpr id) -- right operand + + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' + + -- For details on above see note [Api annotations] in ApiAnnotation + | NegApp (LHsExpr id) + (SyntaxExpr id) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsPar (LHsExpr id) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + + | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] + (LHsExpr id) -- operator + | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn] + (LHsExpr id) -- operand + + -- | Used for explicit tuples and sections thereof + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitTuple + [LHsTupArg id] + Boxity + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCase (LHsExpr id) + (MatchGroup id (LHsExpr id)) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsIf (Maybe (SyntaxExpr id)) -- cond function + -- Nothing => use the built-in 'if' + -- See Note [Rebindable if] + (LHsExpr id) -- predicate + (LHsExpr id) -- then part + (LHsExpr id) -- else part + + -- | Multi-way if + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)] + + -- | let(rec) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsLet (HsLocalBinds id) + (LHsExpr id) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + [ExprLStmt id] -- "do":one or more stmts + (PostTc id Type) -- Type of the whole expression + + -- | Syntactic list: [a,b,c,...] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitList + (PostTc id Type) -- Gives type of components of list + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness + [LHsExpr id] + + -- | Syntactic parallel array: [:e1, ..., en:] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnVbar' + -- 'ApiAnnotation.AnnClose' @':]'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitPArr + (PostTc id Type) -- type of elements of the parallel array + [LHsExpr id] + + -- | Record construction + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordCon (Located id) -- The constructor. After type checking + -- it's the dataConWrapId of the constructor + PostTcExpr -- Data con Id applied to type args + (HsRecordBinds id) + + -- | Record update + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordUpd (LHsExpr id) + (HsRecordBinds id) +-- (HsMatchGroup Id) -- Filled in by the type checker to be +-- -- a match that does the job + [DataCon] -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + [PostTc id Type] -- Argument types of *input* record type + [PostTc id Type] -- and *output* record type + -- For a type family, the arg types are of the *instance* tycon, + -- not the family tycon + + -- | Expression with an explicit type signature. @e :: type@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExprWithTySig + (LHsExpr id) + (LHsType id) + (PostRn id [Name]) -- After renaming, the list of Names + -- contains the named and unnamed + -- wildcards brought in scope by the + -- signature + + | ExprWithTySigOut -- TRANSLATION + (LHsExpr id) + (LHsType Name) -- Retain the signature for + -- round-tripping purposes + + -- | Arithmetic sequence + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ArithSeq + PostTcExpr + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness + (ArithSeqInfo id) + + -- | Arithmetic sequence for parallel array + -- + -- > [:e1..e2:] or [:e1, e2..e3:] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' @':]'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | PArrSeq + PostTcExpr + (ArithSeqInfo id) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, + -- 'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSCC SourceText -- Note [Pragma source text] in BasicTypes + FastString -- "set cost centre" SCC pragma + (LHsExpr id) -- expr whose cost is to be measured + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, + -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes + FastString -- hdaume: core annotation + (LHsExpr id) + + ----------------------------------------------------------- + -- MetaHaskell Extensions + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsBracket (HsBracket id) + + -- See Note [Pending Splices] + | HsRnBracketOut + (HsBracket Name) -- Output of the renamer is the *original* renamed + -- expression, plus + [PendingRnSplice] -- _renamed_ splices to be type checked + + | HsTcBracketOut + (HsBracket Name) -- Output of the type checker is the *original* + -- renamed expression, plus + [PendingTcSplice] -- _typechecked_ splices to be + -- pasted back in by the desugarer + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSpliceE Bool -- True <=> typed splice + (HsSplice id) -- False <=> untyped + + | HsQuasiQuoteE (HsQuasiQuote id) + -- See Note [Quasi-quote overview] in TcSplice + + ----------------------------------------------------------- + -- Arrow notation extension + + -- | @proc@ notation for Arrows + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsProc (LPat id) -- arrow abstraction, proc + (LHsCmdTop id) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- static pointers extension + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsStatic (LHsExpr id) + + --------------------------------------- + -- The following are commands, not expressions proper + -- They are only used in the parsing stage and are removed + -- immediately in parser.RdrHsSyn.checkCommand + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', + -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', + -- 'ApiAnnotation.AnnRarrowtail' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + (PostTc id Type) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@, + -- 'ApiAnnotation.AnnClose' @'|)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + (Tickish id) + (LHsExpr id) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr id) -- sub-expression + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnMinus', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsTickPragma -- A pragma introduced tick + SourceText -- Note [Pragma source text] in BasicTypes + (FastString,(Int,Int),(Int,Int)) -- external span for this tick + (LHsExpr id) + + --------------------------------------- + -- These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing. + + | EWildPat -- wildcard + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + + -- For details on above see note [Api annotations] in ApiAnnotation + | EAsPat (Located id) -- as pattern + (LHsExpr id) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | EViewPat (LHsExpr id) -- view pattern + (LHsExpr id) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ELazyPat (LHsExpr id) -- ~ pattern + + | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y + + --------------------------------------- + -- Finally, HsWrap appears only in typechecker output + + | HsWrap HsWrapper -- TRANSLATION + (HsExpr id) + | HsUnboundVar RdrName + deriving (Typeable) +deriving instance (DataId id) => Data (HsExpr id) + +-- | HsTupArg is used for tuple sections +-- (,a,) is represented by ExplicitTuple [Missing ty1, Present a, Missing ty3] +-- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y)) +type LHsTupArg id = Located (HsTupArg id) +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation +data HsTupArg id + = Present (LHsExpr id) -- ^ The argument + | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type + deriving (Typeable) +deriving instance (DataId id) => Data (HsTupArg id) + +tupArgPresent :: LHsTupArg id -> Bool +tupArgPresent (L _ (Present {})) = True +tupArgPresent (L _ (Missing {})) = False + +{- +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * Generally HsPar is optional; the pretty printer adds parens where + necessary. Eg (HsApp f (HsApp g x)) is fine, and prints 'f (g x)' + + * HsPars are pretty printed as '( .. )' regardless of whether + or not they are strictly necssary + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use Nothing to mean "use the old built-in typing rule". +-} + +instance OutputableBndr id => Outputable (HsExpr id) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: OutputableBndr id => HsExpr id -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar _) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp _ _) = True +isQuietHsExpr (OpApp _ _ _ _) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndr idL, OutputableBndr idR) + => HsLocalBindsLR idL idR -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc +ppr_expr (HsVar v) = pprPrefixOcc v +ppr_expr (HsIPVar v) = ppr v +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsOverLit lit) = ppr lit +ppr_expr (HsPar e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn _ s e) + = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] + +ppr_expr (HsApp e1 e2) + = let (fun, args) = collect_args e1 [e2] in + hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args)) + where + collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_expr (OpApp e1 op _ e2) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly v + = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]] + +ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e + +ppr_expr (SectionL expr op) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprDebugParendExpr expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, ptext (sLit "x_ )")]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + +ppr_expr (SectionR op expr) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprDebugParendExpr expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) + 4 (pp_expr <> rparen) + pp_infixly v = sep [pprInfixOcc v, pp_expr] + +ppr_expr (ExplicitTuple exprs boxity) + = tupleParens (boxityNormalTupleSort boxity) + (fcat (ppr_tup_args $ map unLoc exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc [] = empty + +--avoid using PatternSignatures for stage1 code portability +ppr_expr (HsLam matches) + = pprMatches (LambdaExpr :: HsMatchContext id) matches + +ppr_expr (HsLamCase _ matches) + = sep [ sep [ptext (sLit "\\case {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + +ppr_expr (HsCase expr matches) + = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + +ppr_expr (HsIf _ e1 e2 e3) + = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")], + nest 4 (ppr e2), + ptext (sLit "else"), + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = sep $ ptext (sLit "if") : map ppr_alt alts + where ppr_alt (L _ (GRHS guards expr)) = + sep [ char '|' <+> interpp'SP guards + , ptext (sLit "->") <+> pprDeeper (ppr expr) ] + +-- special case: let ... in let ... +ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) + = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lexpr expr] + +ppr_expr (HsLet binds expr) + = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), + hang (ptext (sLit "in")) 2 (ppr expr)] + +ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (ExplicitPArr _ exprs) + = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon con_id _ rbinds) + = hang (ppr con_id) 2 (ppr rbinds) + +ppr_expr (RecordUpd aexp rbinds _ _ _) + = hang (pprParendExpr aexp) 2 (ppr rbinds) + +ppr_expr (ExprWithTySig expr sig _) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) +ppr_expr (ExprWithTySigOut expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) + +ppr_expr EWildPat = char '_' +ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e +ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e + +ppr_expr (HsSCC _ lbl expr) + = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), + pprParendExpr expr ] + +ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn +ppr_expr (HsType id) = ppr id + +ppr_expr (HsSpliceE t s) = pprSplice t s +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsRnBracketOut e []) = ppr e +ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps +ppr_expr (HsTcBracketOut e []) = ppr e +ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps +ppr_expr (HsQuasiQuoteE qq) = ppr qq + +ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) + = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd] + +ppr_expr (HsStatic e) + = hsep [ptext (sLit "static"), pprParendExpr e] + +ppr_expr (HsTick tickish exp) + = pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp +ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) + = pprTicks (ppr exp) $ + hcat [ptext (sLit "bintick<"), + ppr tickIdTrue, + ptext (sLit ","), + ppr tickIdFalse, + ptext (sLit ">("), + ppr exp,ptext (sLit ")")] +ppr_expr (HsTickPragma _ externalSrcLoc exp) + = pprTicks (ppr exp) $ + hcat [ptext (sLit "tickpragma<"), + ppr externalSrcLoc, + ptext (sLit ">("), + ppr exp, + ptext (sLit ")")] + +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] +ppr_expr (HsArrForm op _ args) + = hang (ptext (sLit "(|") <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) +ppr_expr (HsUnboundVar nm) + = ppr nm + +{- +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the oprerator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. +-} + +pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprDebugParendExpr expr + = getPprStyle (\sty -> + if debugStyle sty then pprParendExpr expr + else pprLExpr expr) + +pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprParendExpr expr + | hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr) + | otherwise = pprLExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +hsExprNeedsParens :: HsExpr id -> Bool +-- True of expressions for which '(e)' and 'e' +-- mean the same thing +hsExprNeedsParens (ArithSeq {}) = False +hsExprNeedsParens (PArrSeq {}) = False +hsExprNeedsParens (HsLit {}) = False +hsExprNeedsParens (HsOverLit {}) = False +hsExprNeedsParens (HsVar {}) = False +hsExprNeedsParens (HsUnboundVar {}) = False +hsExprNeedsParens (HsIPVar {}) = False +hsExprNeedsParens (ExplicitTuple {}) = False +hsExprNeedsParens (ExplicitList {}) = False +hsExprNeedsParens (ExplicitPArr {}) = False +hsExprNeedsParens (HsPar {}) = False +hsExprNeedsParens (HsBracket {}) = False +hsExprNeedsParens (HsRnBracketOut {}) = False +hsExprNeedsParens (HsTcBracketOut {}) = False +hsExprNeedsParens (HsDo sc _ _) + | isListCompExpr sc = False +hsExprNeedsParens _ = True + + +isAtomicHsExpr :: HsExpr id -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsUnboundVar {}) = True +isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr _ = False + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ + +We re-use HsExpr to represent these. +-} + +type LHsCmd id = Located (HsCmd id) + +data HsCmd id + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', + -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', + -- 'ApiAnnotation.AnnRarrowtail' + + -- For details on above see note [Api annotations] in ApiAnnotation + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + (PostTc id Type) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@, + -- 'ApiAnnotation.AnnClose' @'|)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (LHsCmd id) + (LHsExpr id) + + | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdPar (LHsCmd id) -- parenthesised command + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdCase (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdLet (HsLocalBinds id) -- let(rec) + (LHsCmd id) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdDo [CmdLStmt id] + (PostTc id Type) -- Type of the whole expression + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr + (HsCmd id) -- If cmd :: arg1 --> res + -- co :: arg1 ~ arg2 + -- Then (HsCmdCast co cmd) :: arg2 --> res + deriving (Typeable) +deriving instance (DataId id) => Data (HsCmd id) + +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving (Data, Typeable) + + +{- | Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. +-} + +type LHsCmdTop id = Located (HsCmdTop id) + +data HsCmdTop id + = HsCmdTop (LHsCmd id) + (PostTc id Type) -- Nested tuple of inputs on the command's stack + (PostTc id Type) -- return type of the command + (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] + deriving (Typeable) +deriving instance (DataId id) => Data (HsCmdTop id) + +instance OutputableBndr id => Outputable (HsCmd id) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: OutputableBndr id => HsCmd id -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar _) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp _ _) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: OutputableBndr id => LHsCmd id -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> SDoc +ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map pprParendExpr args)) + where + collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +--avoid using PatternSignatures for stage1 code portability +ppr_cmd (HsCmdLam matches) + = pprMatches (LambdaExpr :: HsMatchContext id) matches + +ppr_cmd (HsCmdCase expr matches) + = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + +ppr_cmd (HsCmdIf _ e ct ce) + = sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + ptext (sLit "else"), + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _))) + = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet binds cmd) + = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), + hang (ptext (sLit "in")) 2 (ppr cmd)] + +ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts +ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd + , ptext (sLit "|>") <+> ppr co ] + +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] +ppr_cmd (HsCmdArrForm op _ args) + = hang (ptext (sLit "(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) + = ppr_lcmd cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lcmd cmd) + +instance OutputableBndr id => Outputable (HsCmdTop id) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{Record binds} +* * +************************************************************************ +-} + +type HsRecordBinds id = HsRecFields id (LHsExpr id) + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. +-} + +data MatchGroup id body + = MG { mg_alts :: [LMatch id body] -- The alternatives + , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn + , mg_res_ty :: PostTc id Type -- Type of the result, tr + , mg_origin :: Origin } + -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + deriving (Typeable) +deriving instance (Data body,DataId id) => Data (MatchGroup id body) + +type LMatch id body = Located (Match id body) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation +data Match id body + = Match { + m_fun_id_infix :: (Maybe (Located id,Bool)), + -- fun_id and fun_infix for functions with multiple equations + -- only present for a RdrName. See note [fun_id in Match] + m_pats :: [LPat id], -- The patterns + m_type :: (Maybe (LHsType id)), + -- A type signature for the result of the match + -- Nothing after typechecking + m_grhss :: (GRHSs id body) + } deriving (Typeable) +deriving instance (Data body,DataId id) => Data (Match id body) + +{- +Note [fun_id in Match] +~~~~~~~~~~~~~~~~~~~~~~ + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via API +Annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual API Annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + +-} + +isEmptyMatchGroup :: MatchGroup id body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null ms + +matchGroupArity :: MatchGroup id body -> Arity +-- Precondition: MatchGroup is non-empty +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity (MG { mg_alts = alts }) + | (alt1:_) <- alts = length (hsLMatchPats alt1) + | otherwise = panic "matchGroupArity" + +hsLMatchPats :: LMatch id body -> [LPat id] +hsLMatchPats (L _ (Match _ pats _ _)) = pats + +-- | GRHSs are used both for pattern bindings and for Matches +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', +-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' + +-- For details on above see note [Api annotations] in ApiAnnotation +data GRHSs id body + = GRHSs { + grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs + grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause + } deriving (Typeable) +deriving instance (Data body,DataId id) => Data (GRHSs id body) + +type LGRHS id body = Located (GRHS id body) + +-- | Guarded Right Hand Side. +data GRHS id body = GRHS [GuardLStmt id] -- Guards + body -- Right hand side + deriving (Typeable) +deriving instance (Data body,DataId id) => Data (GRHS id body) + +-- We know the list must have at least one @Match@ in it. + +pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> MatchGroup idR body -> SDoc +pprMatches ctxt (MG { mg_alts = matches }) + = vcat (map (pprMatch ctxt) (map unLoc matches)) + -- Don't print the type; it's only a place-holder before typechecking + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc +pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc +pprPatBind pat (grhss) + = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] + +pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc +pprMatch ctxt (Match _ pats maybe_ty grhss) + = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) + , nest 2 ppr_maybe_ty + , nest 2 (pprGRHSs ctxt grhss) ] + where + (herald, other_pats) + = case ctxt of + FunRhs fun is_infix + | not is_infix -> (pprPrefixOcc fun, pats) + -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + + | null pats2 -> (pp_infix, []) + -- x &&& y = e + + | otherwise -> (parens pp_infix, pats2) + -- (x &&& y) z = e + where + pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2 + + LambdaExpr -> (char '\\', pats) + + _ -> ASSERT( null pats1 ) + (ppr pat1, []) -- No parens around the single pat + + (pat1:pats1) = pats + (pat2:pats2) = pats1 + ppr_maybe_ty = case maybe_ty of + Just ty -> dcolon <+> ppr ty + Nothing -> empty + + +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHSs idR body -> SDoc +pprGRHSs ctxt (GRHSs grhss binds) + = vcat (map (pprGRHS ctxt . unLoc) grhss) + $$ ppUnless (isEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) + +pprGRHS :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHS idR body -> SDoc +pprGRHS ctxt (GRHS [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS guards body) + = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt body] + +pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +type LStmt id body = Located (StmtLR id id body) +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +type Stmt id body = StmtLR id id body + +type CmdLStmt id = LStmt id (LHsCmd id) +type CmdStmt id = Stmt id (LHsCmd id) +type ExprLStmt id = LStmt id (LHsExpr id) +type ExprStmt id = Stmt id (LHsExpr id) + +type GuardLStmt id = LStmt id (LHsExpr id) +type GuardStmt id = Stmt id (LHsExpr id) +type GhciLStmt id = LStmt id (LHsExpr id) +type GhciStmt id = Stmt id (LHsExpr id) + +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. +-- | API Annotations when in qualifier lists or guards +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', +-- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', +-- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' + +-- For details on above see note [Api annotations] in ApiAnnotation +data StmtLR idL idR body -- body should always be (LHs**** idR) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, + -- and (after the renamer) DoExpr, MDoExpr + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + body + (SyntaxExpr idR) -- The return operator, used only for MonadComp + -- For ListComp, PArrComp, we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't appply a 'return' at all + -- See Note [Monad Comprehensions] + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | BindStmt (LPat idL) + body + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] + (SyntaxExpr idR) -- The fail operator + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + + | BodyStmt body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + (PostTc idR Type) -- Element type of the RHS (used for arrows) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, + + -- For details on above see note [Api annotations] in ApiAnnotation + | LetStmt (HsLocalBindsLR idL idR) + + -- ParStmts only occur in a list/monad comprehension + | ParStmt [ParStmtBlock idL idR] + (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_form :: TransForm, + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] + + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + } -- See Note [Monad Comprehensions] + + -- Recursive statement (see Note [How RecStmt works] below) + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecStmt + { recS_stmts :: [LStmtLR idL idR body] + + -- The next two fields are only valid after renaming + , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. + -- An Id can be in both groups + -- Both sets of Ids are (now) treated monomorphically + -- See Note [How RecStmt works] for why they are separate + + -- Rebindable syntax + , recS_bind_fn :: SyntaxExpr idR -- The bind function + , recS_ret_fn :: SyntaxExpr idR -- The return function + , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + + -- These fields are only valid after typechecking + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: PostTc idR Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + deriving (Typeable) +deriving instance (Data body, DataId idL, DataId idR) + => Data (StmtLR idL idR body) + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupForm -- then group using f or then group by e using f (depending on trS_by) + deriving (Data, Typeable) + +data ParStmtBlock idL idR + = ParStmtBlock + [ExprLStmt idL] + [idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + deriving( Typeable ) +deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) + +{- +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see Trac #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a TransStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + bound by the stmts to the left of the 'group' + and used either in the 'by' clause, + or in the stmts following the 'group' + Each item is a pair of identical variables. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [BodyStmt] +~~~~~~~~~~~~~~~ +BodyStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. + +Note [How RecStmt works] +~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids + +Note [Typing a RecStmt] +~~~~~~~~~~~~~~~~~~~~~~~ +A (RecStmt stmts) types as if you had written + + (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> + do { stmts + ; return (v1,..vn, r1, ..., rm) }) + +where v1..vn are the later_ids + r1..rm are the rec_ids + +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +BodyStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Parallel statements require the 'Control.Monad.Zip.mzip' function: + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. +-} + +instance (OutputableBndr idL, OutputableBndr idR) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock stmts _ _) = interpp'SP stmts + +instance (OutputableBndr idL, OutputableBndr idR, Outputable body) + => Outputable (StmtLR idL idR body) where + ppr stmt = pprStmt stmt + +pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => (StmtLR idL idR body) -> SDoc +pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr +pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] +pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] +pprStmt (BodyStmt expr _ _ _) = ppr expr +pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = ptext (sLit "rec") <+> + vcat [ ppr_do_stmts segment + , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids + , ptext (sLit "later_ids=") <> ppr later_ids])] + +pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc +pprTransformStmt bndrs using by + = sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = ptext (sLit "by") <+> ppr e + +pprDo :: (OutputableBndr id, Outputable body) + => HsStmtContext any -> [LStmt id body] -> SDoc +pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo PArrComp stmts = paBrackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => [LStmtLR idL idR body] -> SDoc +-- Print a bunch of do stmts, with explicit braces and semicolons, +-- so that we are not vulnerable to layout bugs +ppr_do_stmts stmts + = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) + <+> rbrace + +pprComp :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | not (null quals) + , L _ (LastStmt body _) <- last quals + = hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals)) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +data HsSplice id + = HsSplice -- $z or $(f 4) + id -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + deriving (Typeable ) + +-- See Note [Pending Splices] +data PendingSplice id + = PendSplice Name (LHsExpr id) + deriving( Typeable ) + -- It'd be convenient to re-use HsSplice, but the splice-name + -- really is a Name, never an Id. Using (PostRn id Name) is + -- nearly OK, but annoyingly we can't pretty-print it. + +data PendingRnSplice + = PendingRnExpSplice (PendingSplice Name) + | PendingRnPatSplice (PendingSplice Name) + | PendingRnTypeSplice (PendingSplice Name) + | PendingRnDeclSplice (PendingSplice Name) + | PendingRnCrossStageSplice Name + deriving (Data, Typeable) + +type PendingTcSplice = PendingSplice Id + +deriving instance (DataId id) => Data (HsSplice id) +deriving instance (DataId id) => Data (PendingSplice id) + +{- +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~ +When we rename an untyped bracket, we name and lift out all the nested +splices, so that when the typechecker hits the bracket, it can +typecheck those nested splices without having to walk over the untyped +bracket code. So for example + [| f $(g x) |] +looks like + + HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) + +which the renamer rewrites to + + HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) + [PendingRnExpSplice (HsSplice sn (g x))] + +* The 'sn' is the Name of the splice point. + +* The PendingRnExpSplice gives the splice that splice-point name maps to; + and the typechecker can now conveniently find these sub-expressions + +* The other copy of the splice, in the second argument of HsSpliceE + in the renamed first arg of HsRnBracketOut + is used only for pretty printing + +There are four varieties of pending splices generated by the renamer: + + * Pending expression splices (PendingRnExpSplice), e.g., + + [|$(f x) + 2|] + + * Pending pattern splices (PendingRnPatSplice), e.g., + + [|\ $(f x) -> x|] + + * Pending type splices (PendingRnTypeSplice), e.g., + + [|f :: $(g x)|] + + * Pending cross-stage splices (PendingRnCrossStageSplice), e.g., + + \x -> [| x |] + +There is a fifth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. +-} + +instance OutputableBndr id => Outputable (HsSplice id) where + ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e) + +instance OutputableBndr id => Outputable (PendingSplice id) where + ppr (PendSplice n e) = angleBrackets (ppr n <> comma <+> ppr e) + +pprUntypedSplice :: OutputableBndr id => HsSplice id -> SDoc +pprUntypedSplice = pprSplice False + +pprTypedSplice :: OutputableBndr id => HsSplice id -> SDoc +pprTypedSplice = pprSplice True + +pprSplice :: OutputableBndr id => Bool -> HsSplice id -> SDoc +pprSplice is_typed (HsSplice n e) + = (if is_typed then ptext (sLit "$$") else char '$') + <> ifPprDebug (brackets (ppr n)) <> eDoc + where + -- We use pprLExpr to match pprParendExpr: + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + pp_as_was = pprLExpr e + eDoc = case unLoc e of + HsPar _ -> pp_as_was + HsVar _ -> pp_as_was + _ -> parens pp_as_was + +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] + | DecBrL [LHsDecl id] -- [d| decls |]; result of parser + | DecBrG (HsGroup id) -- [d| decls |]; result of renamer + | TypBr (LHsType id) -- [t| type |] + | VarBr Bool id -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (LHsExpr id) -- [|| expr ||] + deriving (Typeable) +deriving instance (DataId id) => Data (HsBracket id) + +isTypedBracket :: HsBracket id -> Bool +isTypedBracket (TExpBr {}) = True +isTypedBracket _ = False + +instance OutputableBndr id => Outputable (HsBracket id) where + ppr = pprHsBracket + + +pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr True n) = char '\'' <> ppr n +pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n +pprHsBracket (TExpBr e) = thTyBrackets (ppr e) + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> + pp_body <+> ptext (sLit "|]") + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") + +instance Outputable PendingRnSplice where + ppr (PendingRnExpSplice s) = ppr s + ppr (PendingRnPatSplice s) = ppr s + ppr (PendingRnTypeSplice s) = ppr s + ppr (PendingRnDeclSplice s) = ppr s + ppr (PendingRnCrossStageSplice name) = ppr name + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) + deriving (Typeable) +deriving instance (DataId id) => Data (ArithSeqInfo id) + +instance OutputableBndr id => Outputable (ArithSeqInfo id) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = ptext (sLit " .. ") + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +data HsMatchContext id -- Context of a Match + = FunRhs id Bool -- Function binding for f; True <=> written infix + | LambdaExpr -- Patterns of a lambda + | CaseAlt -- Patterns and guards on a case alternative + | IfAlt -- Guards of a multi-way if alternative + | ProcExpr -- Patterns of a proc + | PatBindRhs -- A pattern binding eg [y] <- e = e + + | RecUpd -- Record update [used only in DsExpr to + -- tell matchWrapper what sort of + -- runtime error message to generate] + + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + + | ThPatSplice -- A Template Haskell pattern splice + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- A pattern synonym declaration + deriving (Data, Typeable) + +data HsStmtContext id + = ListComp + | MonadComp + | PArrComp -- Parallel array comprehension + + | DoExpr -- do { ... } + | MDoExpr -- mdo { ... } ie recursive do-expression + | ArrowExpr -- do-notation in an arrow-command context + + | GhciStmtCtxt -- A command-line Stmt in GHCi pat <- rhs + | PatGuard (HsMatchContext id) -- Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + deriving (Data, Typeable) + +isListCompExpr :: HsStmtContext id -> Bool +-- Uses syntax [ e | quals ] +isListCompExpr ListComp = True +isListCompExpr PArrComp = True +isListCompExpr MonadComp = True +isListCompExpr (ParStmtCtxt c) = isListCompExpr c +isListCompExpr (TransStmtCtxt c) = isListCompExpr c +isListCompExpr _ = False + +isMonadCompExpr :: HsStmtContext id -> Bool +isMonadCompExpr MonadComp = True +isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr _ = False + +matchSeparator :: HsMatchContext id -> SDoc +matchSeparator (FunRhs {}) = ptext (sLit "=") +matchSeparator CaseAlt = ptext (sLit "->") +matchSeparator IfAlt = ptext (sLit "->") +matchSeparator LambdaExpr = ptext (sLit "->") +matchSeparator ProcExpr = ptext (sLit "->") +matchSeparator PatBindRhs = ptext (sLit "=") +matchSeparator (StmtCtxt _) = ptext (sLit "<-") +matchSeparator RecUpd = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: Outputable id => HsMatchContext id -> SDoc +pprMatchContext ctxt + | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt + | otherwise = ptext (sLit "a") <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an ProcExpr = True + want_an _ = False + +pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for") + <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") +pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative") +pprMatchContextNoun RecUpd = ptext (sLit "record-update construct") +pprMatchContextNoun ThPatSplice = ptext (sLit "Template Haskell pattern splice") +pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation") +pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding") +pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction") +pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") +pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") + $$ pprStmtContext ctxt +pprMatchContextNoun PatSyn = ptext (sLit "pattern synonym declaration") + +----------------- +pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = ptext (sLit "an") + pp_a = ptext (sLit "a") + article = case ctxt of + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmtCtxt = ptext (sLit "interactive GHCi command") +pprStmtContext DoExpr = ptext (sLit "'do' block") +pprStmtContext MDoExpr = ptext (sLit "'mdo' block") +pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") +pprStmtContext ListComp = ptext (sLit "list comprehension") +pprStmtContext MonadComp = ptext (sLit "monad comprehension") +pprStmtContext PArrComp = ptext (sLit "array comprehension") +pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) + | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c +pprStmtContext (TransStmtCtxt c) + | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable id => HsMatchContext id -> SDoc +matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun +matchContextErrString CaseAlt = ptext (sLit "case") +matchContextErrString IfAlt = ptext (sLit "multi-way if") +matchContextErrString PatBindRhs = ptext (sLit "pattern binding") +matchContextErrString RecUpd = ptext (sLit "record update") +matchContextErrString LambdaExpr = ptext (sLit "lambda") +matchContextErrString ProcExpr = ptext (sLit "proc") +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt GhciStmtCtxt) = ptext (sLit "interactive GHCi command") +matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") +matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") +matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") +matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") + +pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc +pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) + 4 (pprMatch ctxt match) + +pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsStmtContext idL -> StmtLR idL idR body -> SDoc +pprStmtInCtxt ctxt (LastStmt e _) + | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (ptext (sLit "In the expression:")) 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot new file mode 100644 index 00000000..51cbd295 --- /dev/null +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ > 706 +{-# LANGUAGE RoleAnnotations #-} +#endif + +module HsExpr where + +import SrcLoc ( Located ) +import Outputable ( SDoc, OutputableBndr, Outputable ) +import {-# SOURCE #-} HsPat ( LPat ) +import PlaceHolder ( DataId ) +import Data.Data hiding ( Fixity ) + +#if __GLASGOW_HASKELL__ > 706 +type role HsExpr nominal +type role HsCmd nominal +type role MatchGroup nominal representational +type role GRHSs nominal representational +type role HsSplice nominal +#endif +data HsExpr (i :: *) +data HsCmd (i :: *) +data HsSplice (i :: *) +data MatchGroup (a :: *) (body :: *) +data GRHSs (a :: *) (body :: *) + +#if __GLASGOW_HASKELL__ > 706 +instance Typeable HsSplice +instance Typeable HsExpr +instance Typeable MatchGroup +instance Typeable GRHSs +#else +instance Typeable1 HsSplice +instance Typeable1 HsExpr +instance Typeable1 HsCmd +instance Typeable2 MatchGroup +instance Typeable2 GRHSs +#endif + +instance (DataId id) => Data (HsSplice id) +instance (DataId id) => Data (HsExpr id) +instance (DataId id) => Data (HsCmd id) +instance (Data body,DataId id) => Data (MatchGroup id body) +instance (Data body,DataId id) => Data (GRHSs id body) + +instance OutputableBndr id => Outputable (HsExpr id) +instance OutputableBndr id => Outputable (HsCmd id) + +type LHsExpr a = Located (HsExpr a) +type SyntaxExpr a = HsExpr a + +pprLExpr :: (OutputableBndr i) => + LHsExpr i -> SDoc + +pprExpr :: (OutputableBndr i) => + HsExpr i -> SDoc + +pprUntypedSplice :: (OutputableBndr i) => + HsSplice i -> SDoc + +pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc + +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs new file mode 100644 index 00000000..42b374ab --- /dev/null +++ b/compiler/hsSyn/HsImpExp.hs @@ -0,0 +1,209 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +HsImpExp: Abstract syntax: imports, exports, interfaces +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module HsImpExp where + +import Module ( ModuleName ) +import HsDoc ( HsDocString ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) +import BasicTypes ( SourceText ) + +import Outputable +import FastString +import SrcLoc + +import Data.Data + +{- +************************************************************************ +* * +\subsection{Import and export declaration lists} +* * +************************************************************************ + +One per \tr{import} declaration in a module. +-} + +type LImportDecl name = Located (ImportDecl name) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | A single Haskell @import@ declaration. +data ImportDecl name + = ImportDecl { + ideclSourceSrc :: Maybe SourceText, + -- Note [Pragma source text] in BasicTypes + ideclName :: Located ModuleName, -- ^ Module name. + ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. + ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: Bool, -- ^ True => qualified + ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) + ideclAs :: Maybe ModuleName, -- ^ as Module + ideclHiding :: Maybe (Bool, Located [LIE name]) + -- ^ (True => hiding, names) + } + -- ^ + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnImport' + -- + -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource + -- + -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', + -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', + -- 'ApiAnnotation.AnnVal' + -- + -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' attached + -- to location in ideclHiding + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Data, Typeable) + +simpleImportDecl :: ModuleName -> ImportDecl name +simpleImportDecl mn = ImportDecl { + ideclSourceSrc = Nothing, + ideclName = noLoc mn, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, + ideclImplicit = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing + } + +instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where + ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg + , ideclSource = from, ideclSafe = safe + , ideclQualified = qual, ideclImplicit = implicit + , ideclAs = as, ideclHiding = spec }) + = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_implicit implicit, pp_safe safe, + pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) + 4 (pp_spec spec) + where + pp_implicit False = empty + pp_implicit True = ptext (sLit ("(implicit)")) + + pp_pkg Nothing = empty + pp_pkg (Just p) = doubleQuotes (ftext p) + + pp_qual False = empty + pp_qual True = ptext (sLit "qualified") + + pp_safe False = empty + pp_safe True = ptext (sLit "safe") + + pp_as Nothing = empty + pp_as (Just a) = ptext (sLit "as") <+> ppr a + + ppr_imp True = ptext (sLit "{-# SOURCE #-}") + ppr_imp False = empty + + pp_spec Nothing = empty + pp_spec (Just (False, (L _ ies))) = ppr_ies ies + pp_spec (Just (True, (L _ ies))) = ptext (sLit "hiding") <+> ppr_ies ies + + ppr_ies [] = ptext (sLit "()") + ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' + +{- +************************************************************************ +* * +\subsection{Imported and exported entities} +* * +************************************************************************ +-} + +type LIE name = Located (IE name) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Imported or exported entity. +data IE name + = IEVar (Located name) + -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEThingAbs (Located name) -- ^ Class/Type (can't tell) + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEThingAll (Located name) -- ^ Class/Type plus all methods/constructors + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | IEThingWith (Located name) [Located name] + -- ^ Class/Type plus some methods/constructors + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEModuleContents (Located ModuleName) -- ^ (Export Only) + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEGroup Int HsDocString -- ^ Doc section heading + | IEDoc HsDocString -- ^ Some documentation + | IEDocNamed String -- ^ Reference to named doc + deriving (Eq, Data, Typeable) + +ieName :: IE name -> name +ieName (IEVar (L _ n)) = n +ieName (IEThingAbs (L _ n)) = n +ieName (IEThingWith (L _ n) _) = n +ieName (IEThingAll (L _ n)) = n +ieName _ = panic "ieName failed pattern match!" + +ieNames :: IE a -> [a] +ieNames (IEVar (L _ n) ) = [n] +ieNames (IEThingAbs (L _ n) ) = [n] +ieNames (IEThingAll (L _ n) ) = [n] +ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns +ieNames (IEModuleContents _ ) = [] +ieNames (IEGroup _ _ ) = [] +ieNames (IEDoc _ ) = [] +ieNames (IEDocNamed _ ) = [] + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type") + | otherwise = empty + +instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where + ppr (IEVar var) = pprPrefixOcc (unLoc var) + ppr (IEThingAbs thing) = pprImpExp (unLoc thing) + ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"] + ppr (IEThingWith thing withs) + = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma + (map pprImpExp $ map unLoc withs))) + ppr (IEModuleContents mod') + = ptext (sLit "module") <+> ppr mod' + ppr (IEGroup n _) = text ("") + ppr (IEDoc doc) = ppr doc + ppr (IEDocNamed string) = text ("") diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs new file mode 100644 index 00000000..2a910ad8 --- /dev/null +++ b/compiler/hsSyn/HsLit.hs @@ -0,0 +1,177 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsLit]{Abstract syntax: source-language literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} + +module HsLit where + +#include "HsVersions.h" + +import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) +import BasicTypes ( FractionalLit(..),SourceText ) +import Type ( Type ) +import Outputable +import FastString +import PlaceHolder ( PostTc,PostRn,DataId ) + +import Data.ByteString (ByteString) +import Data.Data hiding ( Fixity ) + +{- +************************************************************************ +* * +\subsection[HsLit]{Literals} +* * +************************************************************************ +-} + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +data HsLit + = HsChar SourceText Char -- Character + | HsCharPrim SourceText Char -- Unboxed character + | HsString SourceText FastString -- String + | HsStringPrim SourceText ByteString -- Packed bytes + | HsInt SourceText Integer -- Genuinely an Int; arises from + -- TcGenDeriv, and from TRANSLATION + | HsIntPrim SourceText Integer -- literal Int# + | HsWordPrim SourceText Integer -- literal Word# + | HsInt64Prim SourceText Integer -- literal Int64# + | HsWord64Prim SourceText Integer -- literal Word64# + | HsInteger SourceText Integer Type -- Genuinely an integer; arises only + -- from TRANSLATION (overloaded + -- literals are done with HsOverLit) + | HsRat FractionalLit Type -- Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) + | HsFloatPrim FractionalLit -- Unboxed Float + | HsDoublePrim FractionalLit -- Unboxed Double + deriving (Data, Typeable) + +instance Eq HsLit where + (HsChar _ x1) == (HsChar _ x2) = x1==x2 + (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 + (HsString _ x1) == (HsString _ x2) = x1==x2 + (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 + (HsInt _ x1) == (HsInt _ x2) = x1==x2 + (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 + (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 + (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 + (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 + (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 + (HsRat x1 _) == (HsRat x2 _) = x1==x2 + (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 + (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 + _ == _ = False + +data HsOverLit id -- An overloaded literal + = OverLit { + ol_val :: OverLitVal, + ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable] + ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] + ol_type :: PostTc id Type } + deriving (Typeable) +deriving instance (DataId id) => Data (HsOverLit id) + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +data OverLitVal + = HsIntegral !SourceText !Integer -- Integer-looking literals; + | HsFractional !FractionalLit -- Frac-looking literals + | HsIsString !SourceText !FastString -- String-looking literals + deriving (Data, Typeable) + +overLitType :: HsOverLit a -> PostTc a Type +overLitType = ol_type + +{- +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one + +Note [Overloaded literal witnesses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Before* type checking, the SyntaxExpr in an HsOverLit is the +name of the coercion function, 'fromInteger' or 'fromRational'. +*After* type checking, it is a witness for the literal, such as + (fromInteger 3) or lit_78 +This witness should replace the literal. + +This dual role is unusual, because we're replacing 'fromInteger' with +a call to fromInteger. Reason: it allows commoning up of the fromInteger +calls, which wouldn't be possible if the desguarar made the application. + +The PostTcType in each branch records the type the overload literal is +found to have. +-} + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) +instance Eq (HsOverLit id) where + (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 + +instance Eq OverLitVal where + (HsIntegral _ i1) == (HsIntegral _ i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 + _ == _ = False + +instance Ord (HsOverLit id) where + compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 + +instance Ord OverLitVal where + compare (HsIntegral _ i1) (HsIntegral _ i2) = i1 `compare` i2 + compare (HsIntegral _ _) (HsFractional _) = LT + compare (HsIntegral _ _) (HsIsString _ _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional _) (HsIntegral _ _) = GT + compare (HsFractional _) (HsIsString _ _) = LT + compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 + compare (HsIsString _ _) (HsIntegral _ _) = GT + compare (HsIsString _ _) (HsFractional _) = GT + +instance Outputable HsLit where + -- Use "show" because it puts in appropriate escapes + ppr (HsChar _ c) = pprHsChar c + ppr (HsCharPrim _ c) = pprHsChar c <> char '#' + ppr (HsString _ s) = pprHsString s + ppr (HsStringPrim _ s) = pprHsBytes s <> char '#' + ppr (HsInt _ i) = integer i + ppr (HsInteger _ i _) = integer i + ppr (HsRat f _) = ppr f + ppr (HsFloatPrim f) = ppr f <> char '#' + ppr (HsDoublePrim d) = ppr d <> text "##" + ppr (HsIntPrim _ i) = integer i <> char '#' + ppr (HsWordPrim _ w) = integer w <> text "##" + ppr (HsInt64Prim _ i) = integer i <> text "L#" + ppr (HsWord64Prim _ w) = integer w <> text "L##" + +-- in debug mode, print the expression that it's resolved to, too +instance OutputableBndr id => Outputable (HsOverLit id) where + ppr (OverLit {ol_val=val, ol_witness=witness}) + = ppr val <+> (ifPprDebug (parens (pprExpr witness))) + +instance Outputable OverLitVal where + ppr (HsIntegral _ i) = integer i + ppr (HsFractional f) = ppr f + ppr (HsIsString _ s) = pprHsString s diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs new file mode 100644 index 00000000..1d8da13b --- /dev/null +++ b/compiler/hsSyn/HsPat.hs @@ -0,0 +1,522 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PatSyntax]{Abstract Haskell syntax---patterns} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} + +module HsPat ( + Pat(..), InPat, OutPat, LPat, + + HsConDetails(..), + HsConPatDetails, hsConPatArgs, + HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields, + + mkPrefixConPat, mkCharLitPat, mkNilPat, + + isStrictHsBind, looksLazyPatBind, + isStrictLPat, hsPatNeedsParens, + isIrrefutableHsPat, + + pprParendLPat, pprConArgs + ) where + +import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice) + +-- friends: +import HsBinds +import HsLit +import PlaceHolder ( PostTc,DataId ) +import HsTypes +import TcEvidence +import BasicTypes +-- others: +import PprCore ( {- instance OutputableBndr TyVar -} ) +import TysWiredIn +import Var +import ConLike +import DataCon +import TyCon +import Outputable +import Type +import SrcLoc +import FastString +-- libraries: +import Data.Data hiding (TyCon,Fixity) +import Data.Maybe + +type InPat id = LPat id -- No 'Out' constructors +type OutPat id = LPat id -- No 'In' constructors + +type LPat id = Located (Pat id) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + +-- For details on above see note [Api annotations] in ApiAnnotation +data Pat id + = ------------ Simple patterns --------------- + WildPat (PostTc id Type) -- Wild card + -- The sole reason for a type on a WildPat is to + -- support hsPatType :: Pat Id -> Type + + | VarPat id -- Variable + | LazyPat (LPat id) -- Lazy pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | AsPat (Located id) (LPat id) -- As pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | ParPat (LPat id) -- Parenthesised pattern + -- See Note [Parens in HsSyn] in HsExpr + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | BangPat (LPat id) -- Bang pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + + -- For details on above see note [Api annotations] in ApiAnnotation + + ------------ Lists, tuples, arrays --------------- + | ListPat [LPat id] -- Syntactic list + (PostTc id Type) -- The type of the elements + (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TuplePat [LPat id] -- Tuple sub-patterns + Boxity -- UnitPat is TuplePat [] + [PostTc id Type] -- [] before typechecker, filled in afterwards + -- with the types of the tuple components + -- You might think that the PostTc id Type was redundant, because we can + -- get the pattern type by getting the types of the sub-patterns. + -- But it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar + -- (June 14: I'm not sure this comment is right; the sub-patterns + -- will be wrapped in CoPats, no?) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, + -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | PArrPat [LPat id] -- Syntactic parallel array + (PostTc id Type) -- The type of the elements + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnClose' @':]'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + ------------ Constructor patterns --------------- + | ConPatIn (Located id) + (HsConPatDetails id) + + | ConPatOut { + pat_con :: Located ConLike, + pat_arg_tys :: [Type], -- The univeral arg types, 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con pat_arg_tys) to get + -- the type of the pattern + + pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only) + pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* + -- One reason for putting coercion variable here, I think, + -- is to ensure their kinds are zonked + pat_binds :: TcEvBinds, -- Bindings involving those dictionaries + pat_args :: HsConPatDetails id, + pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + } + + ------------ View patterns --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ViewPat (LHsExpr id) + (LPat id) + (PostTc id Type) -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. + + ------------ Pattern splices --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | SplicePat (HsSplice id) + + ------------ Quasiquoted patterns --------------- + -- See Note [Quasi-quote overview] in TcSplice + | QuasiQuotePat (HsQuasiQuote id) + + ------------ Literal and n+k patterns --------------- + | LitPat HsLit -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. + + | NPat -- Used for all overloaded literals, + -- including overloaded strings with -XOverloadedStrings + (Located (HsOverLit id)) -- ALWAYS positive + (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative + -- patterns, Nothing otherwise + (SyntaxExpr id) -- Equality checker, of type t->t->Bool + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | NPlusKPat (Located id) -- n+k pattern + (Located (HsOverLit id)) -- It'll always be an HsIntegral + (SyntaxExpr id) -- (>=) function, of type t->t->Bool + (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) + + ------------ Pattern type signatures --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SigPatIn (LPat id) -- Pattern with a type signature + (HsWithBndrs id (LHsType id)) -- Signature can bind both + -- kind and type vars + + | SigPatOut (LPat id) -- Pattern with a type signature + Type + + ------------ Pattern coercions (translation only) --------------- + | CoPat HsWrapper -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + (Pat id) -- Why not LPat? Ans: existing locn will do + Type -- Type of whole pattern, t1 + -- During desugaring a (CoPat co pat) turns into a cast with 'co' on + -- the scrutinee, followed by a match on 'pat' + deriving (Typeable) +deriving instance (DataId id) => Data (Pat id) + +-- HsConDetails is use for patterns/expressions *and* for data type declarations + +data HsConDetails arg rec + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + deriving (Data, Typeable) + +type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) + +hsConPatArgs :: HsConPatDetails id -> [LPat id] +hsConPatArgs (PrefixCon ps) = ps +hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) +hsConPatArgs (InfixCon p1 p2) = [p1,p2] + +{- +However HsRecFields is used only for patterns and expressions +(not data type declarations) +-} + +data HsRecFields id arg -- A bunch of record fields + -- { x = 3, y = True } + -- Used for both expressions and patterns + = HsRecFields { rec_flds :: [LHsRecField id arg], + rec_dotdot :: Maybe Int } -- Note [DotDot fields] + deriving (Data, Typeable) + +-- Note [DotDot fields] +-- ~~~~~~~~~~~~~~~~~~~~ +-- The rec_dotdot field means this: +-- Nothing => the normal case +-- Just n => the group uses ".." notation, +-- +-- In the latter case: +-- +-- *before* renamer: rec_flds are exactly the n user-written fields +-- +-- *after* renamer: rec_flds includes *all* fields, with +-- the first 'n' being the user-written ones +-- and the remainder being 'filled in' implicitly + +type LHsRecField id arg = Located (HsRecField id arg) +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', + +-- For details on above see note [Api annotations] in ApiAnnotation +data HsRecField id arg = HsRecField { + hsRecFieldId :: Located id, + hsRecFieldArg :: arg, -- Filled in by renamer + hsRecPun :: Bool -- Note [Punning] + } deriving (Data, Typeable) + +-- Note [Punning] +-- ~~~~~~~~~~~~~~ +-- If you write T { x, y = v+1 }, the HsRecFields will be +-- HsRecField x x True ... +-- HsRecField y (v+1) False ... +-- That is, for "punned" field x is expanded (in the renamer) +-- to x=x; but with a punning flag so we can detect it later +-- (e.g. when pretty printing) +-- +-- If the original field was qualified, we un-qualify it, thus +-- T { A.x } means T { A.x = x } + +hsRecFields :: HsRecFields id arg -> [id] +hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds) + +{- +************************************************************************ +* * +* Printing patterns +* * +************************************************************************ +-} + +instance (OutputableBndr name) => Outputable (Pat name) where + ppr = pprPat + +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var -- Print with type info if -dppr-debug is on + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + else + pprPrefixOcc var + +pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc +pprParendLPat (L _ p) = pprParendPat p + +pprParendPat :: (OutputableBndr name) => Pat name -> SDoc +pprParendPat p | hsPatNeedsParens p = parens (pprPat p) + | otherwise = pprPat p + +pprPat :: (OutputableBndr name) => Pat name -> SDoc +pprPat (VarPat var) = pprPatBndr var +pprPat (WildPat _) = char '_' +pprPat (LazyPat pat) = char '~' <> pprParendLPat pat +pprPat (BangPat pat) = char '!' <> pprParendLPat pat +pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] +pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat pat) = parens (ppr pat) +pprPat (ListPat pats _ _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) + +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details +pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, + pat_binds = binds, pat_args = details }) + = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a + if debugStyle sty then -- typechecked Pat in an error message, + -- and we want to make sure it prints nicely + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds]) + <+> pprConArgs details + else pprUserCon (unLoc con) details + +pprPat (LitPat s) = ppr s +pprPat (NPat l Nothing _) = ppr l +pprPat (NPat l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (SplicePat splice) = pprUntypedSplice splice +pprPat (QuasiQuotePat qq) = ppr qq +pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty + +pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 +pprUserCon c details = pprPrefixOcc c <+> pprConArgs details + +pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc +pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) +pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] +pprConArgs (RecCon rpats) = ppr rpats + +instance (OutputableBndr id, Outputable arg) + => Outputable (HsRecFields id arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds)) + +instance (OutputableBndr id, Outputable arg) + => Outputable (HsRecField id arg) where + ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, + hsRecPun = pun }) + = ppr f <+> (ppUnless pun $ equals <+> ppr arg) + +{- +************************************************************************ +* * +* Building patterns +* * +************************************************************************ +-} + +mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats tys + = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [], + pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, + pat_arg_tys = tys, pat_wrap = idHsWrapper } + +mkNilPat :: Type -> OutPat id +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] + +mkCharLitPat :: String -> Char -> OutPat id +mkCharLitPat src c = mkPrefixConPat charDataCon + [noLoc $ LitPat (HsCharPrim src c)] [] + +{- +************************************************************************ +* * +* Predicates for checking things about pattern-lists in EquationInfo * +* * +************************************************************************ + +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal patterns:] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. +-} + +isStrictLPat :: LPat id -> Bool +isStrictLPat (L _ (ParPat p)) = isStrictLPat p +isStrictLPat (L _ (BangPat {})) = True +isStrictLPat (L _ (TuplePat _ Unboxed _)) = True +isStrictLPat _ = False + +isStrictHsBind :: HsBind id -> Bool +-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly +-- Defined in this module because HsPat is above HsBinds in the import graph +isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p +isStrictHsBind _ = False + +looksLazyPatBind :: HsBind id -> Bool +-- Returns True of anything *except* +-- a StrictHsBind (as above) or +-- a VarPat +-- In particular, returns True of a pattern binding with a compound pattern, like (I# x) +looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p +looksLazyPatBind _ = False + +looksLazyLPat :: LPat id -> Bool +looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p +looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p +looksLazyLPat (L _ (BangPat {})) = False +looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False +looksLazyLPat (L _ (VarPat {})) = False +looksLazyLPat (L _ (WildPat {})) = False +looksLazyLPat _ = True + +isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool +-- (isIrrefutableHsPat p) is true if matching against p cannot fail, +-- in the sense of falling through to the next pattern. +-- (NB: this is not quite the same as the (silly) defn +-- in 3.17.2 of the Haskell 98 report.) +-- +-- isIrrefutableHsPat returns False if it's in doubt; specifically +-- on a ConPatIn it doesn't know the size of the constructor family +-- But if it returns True, the pattern is definitely irrefutable +isIrrefutableHsPat pat + = go pat + where + go (L _ pat) = go1 pat + + go1 (WildPat {}) = True + go1 (VarPat {}) = True + go1 (LazyPat {}) = True + go1 (BangPat pat) = go pat + go1 (CoPat _ pat _) = go1 pat + go1 (ParPat pat) = go pat + go1 (AsPat _ pat) = go pat + go1 (ViewPat _ pat _) = go pat + go1 (SigPatIn pat _) = go pat + go1 (SigPatOut pat _) = go pat + go1 (TuplePat pats _ _) = all go pats + go1 (ListPat {}) = False + go1 (PArrPat {}) = False -- ? + + go1 (ConPatIn {}) = False -- Conservative + go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details }) + = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) + -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because + -- the latter is false of existentials. See Trac #4439 + && all go (hsConPatArgs details) + go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) }) + = False -- Conservative + + go1 (LitPat {}) = False + go1 (NPat {}) = False + go1 (NPlusKPat {}) = False + + -- Both should be gotten rid of by renamer before + -- isIrrefutablePat is called + go1 (SplicePat {}) = urk pat + go1 (QuasiQuotePat {}) = urk pat + + urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) + +hsPatNeedsParens :: Pat a -> Bool +hsPatNeedsParens (NPlusKPat {}) = True +hsPatNeedsParens (SplicePat {}) = False +hsPatNeedsParens (QuasiQuotePat {}) = True +hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds +hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) +hsPatNeedsParens (SigPatIn {}) = True +hsPatNeedsParens (SigPatOut {}) = True +hsPatNeedsParens (ViewPat {}) = True +hsPatNeedsParens (CoPat {}) = True +hsPatNeedsParens (WildPat {}) = False +hsPatNeedsParens (VarPat {}) = False +hsPatNeedsParens (LazyPat {}) = False +hsPatNeedsParens (BangPat {}) = False +hsPatNeedsParens (ParPat {}) = False +hsPatNeedsParens (AsPat {}) = False +hsPatNeedsParens (TuplePat {}) = False +hsPatNeedsParens (ListPat {}) = False +hsPatNeedsParens (PArrPat {}) = False +hsPatNeedsParens (LitPat {}) = False +hsPatNeedsParens (NPat {}) = False + +conPatNeedsParens :: HsConDetails a b -> Bool +conPatNeedsParens (PrefixCon args) = not (null args) +conPatNeedsParens (InfixCon {}) = True +conPatNeedsParens (RecCon {}) = True diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot new file mode 100644 index 00000000..114425b5 --- /dev/null +++ b/compiler/hsSyn/HsPat.hs-boot @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ > 706 +{-# LANGUAGE RoleAnnotations #-} +#endif + +module HsPat where +import SrcLoc( Located ) + +import Data.Data hiding (Fixity) +import Outputable +import PlaceHolder ( DataId ) + +#if __GLASGOW_HASKELL__ > 706 +type role Pat nominal +#endif +data Pat (i :: *) +type LPat i = Located (Pat i) + +#if __GLASGOW_HASKELL__ > 706 +instance Typeable Pat +#else +instance Typeable1 Pat +#endif + +instance (DataId id) => Data (Pat id) +instance (OutputableBndr name) => Outputable (Pat name) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs new file mode 100644 index 00000000..d084dc2f --- /dev/null +++ b/compiler/hsSyn/HsSyn.hs @@ -0,0 +1,145 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} + +module HsSyn ( + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + module HsUtils, + module HsDoc, + module PlaceHolder, + Fixity, + + HsModule(..) +) where + +-- friends: +import HsDecls +import HsBinds +import HsExpr +import HsImpExp +import HsLit +import PlaceHolder +import HsPat +import HsTypes hiding ( mkHsForAllTy ) +import BasicTypes ( Fixity, WarningTxt ) +import HsUtils +import HsDoc + +-- others: +import OccName ( HasOccName ) +import Outputable +import SrcLoc +import Module ( ModuleName ) +import FastString + +-- libraries: +import Data.Data hiding ( Fixity ) + +-- | All we actually declare here is the top-level structure for a module. +data HsModule name + = HsModule { + hsmodName :: Maybe (Located ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (Located [LIE name]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @Just []@: export /nothing/ + -- + -- - @Just [...]@: as you would expect... + -- + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodImports :: [LImportDecl name], + -- ^ We snaffle interesting stuff out of the imported interfaces early + -- on, adding that info to TyDecls/etc; so this list is often empty, + -- downstream. + hsmodDecls :: [LHsDecl name], + -- ^ Type, class, value, and interface signature decls + hsmodDeprecMessage :: Maybe (Located WarningTxt), + -- ^ reason\/explanation for warning/deprecation of this module + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + -- + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodHaddockModHeader :: Maybe LHsDocString + -- ^ Haddock module info and description, unparsed + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' + -- + -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnClose' for explicit braces and semi around + -- hsmodImports,hsmodDecls if this style is used. + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (HsModule name) + +instance (OutputableBndr name, HasOccName name) + => Outputable (HsModule name) where + + ppr (HsModule Nothing _ imports decls _ mbDoc) + = pp_mb mbDoc $$ pp_nonnull imports + $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec mbDoc) + = vcat [ + pp_mb mbDoc, + case exports of + Nothing -> pp_header (ptext (sLit "where")) + Just es -> vcat [ + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), + nest 4 (ptext (sLit ") where")) + ], + pp_nonnull imports, + pp_nonnull decls + ] + where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = ptext (sLit "module") <+> ppr name + +pp_mb :: Outputable t => Maybe t -> SDoc +pp_mb (Just x) = ppr x +pp_mb Nothing = empty + +pp_nonnull :: Outputable t => [t] -> SDoc +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs new file mode 100644 index 00000000..cdb5efe5 --- /dev/null +++ b/compiler/hsSyn/HsTypes.hs @@ -0,0 +1,964 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +HsTypes: Abstract syntax: user-defined types +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} + +module HsTypes ( + HsType(..), LHsType, HsKind, LHsKind, + HsTyOp,LHsTyOp, + HsTyVarBndr(..), LHsTyVarBndr, + LHsTyVarBndrs(..), + HsWithBndrs(..), + HsTupleSort(..), HsExplicitFlag(..), + HsContext, LHsContext, + HsQuasiQuote(..), + HsTyWrapper(..), + HsTyLit(..), + HsIPName(..), hsIPNameFS, + + LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang, + getBangType, getBangStrictness, + + ConDeclField(..), LConDeclField, pprConDeclFields, + + mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, + mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, + mkHsForAllTy, + flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy, + flattenHsForAllTyKeepAnns, + hsExplicitTvs, + hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitLHsInstDeclTy_maybe, + splitHsClassTy_maybe, splitLHsClassTy_maybe, + splitHsFunType, + splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, + isWildcardTy, isNamedWildcardTy, + + -- Printing + pprParendHsType, pprHsForAll, pprHsForAllExtra, + pprHsContext, pprHsContextNoArrow, pprHsContextMaybe + ) where + +import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) + +import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) + +import Name( Name ) +import RdrName( RdrName ) +import DataCon( HsBang(..), HsSrcBang, HsImplBang ) +import TysPrim( funTyConName ) +import Type +import HsDoc +import BasicTypes +import SrcLoc +import StaticFlags +import Outputable +import FastString +import Lexer ( AddAnn, mkParensApiAnn ) +import Maybes( isJust ) + +import Data.Data hiding ( Fixity ) +import Data.Maybe ( fromMaybe ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid hiding ((<>)) +#endif + +{- +************************************************************************ +* * + Quasi quotes; used in types and elsewhere +* * +************************************************************************ +-} + +data HsQuasiQuote id = HsQuasiQuote + id -- The quasi-quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string + deriving (Data, Typeable) + +instance OutputableBndr id => Outputable (HsQuasiQuote id) where + ppr = ppr_qq + +ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc +ppr_qq (HsQuasiQuote quoter _ quote) = + char '[' <> ppr quoter <> ptext (sLit "|") <> + ppr quote <> ptext (sLit "|]") + +{- +************************************************************************ +* * +\subsection{Bang annotations} +* * +************************************************************************ +-} + +type LBangType name = Located (BangType name) +type BangType name = HsType name -- Bangs are in the HsType data type + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ ty)) = ty +getBangType ty = ty + +getBangStrictness :: LHsType a -> HsSrcBang +getBangStrictness (L _ (HsBangTy s _)) = s +getBangStrictness _ = HsNoBang + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ + +This is the syntax for types as seen in type signatures. + +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decoarated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in RnTypes +-} + +type LHsContext name = Located (HsContext name) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type HsContext name = [LHsType name] + +type LHsType name = Located (HsType name) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation +type HsKind name = HsType name +type LHsKind name = Located (HsKind name) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type LHsTyVarBndr name = Located (HsTyVarBndr name) + +data LHsTyVarBndrs name + = HsQTvs { hsq_kvs :: [Name] -- Kind variables + , hsq_tvs :: [LHsTyVarBndr name] -- Type variables + -- See Note [HsForAllTy tyvar binders] + } + deriving( Typeable ) +deriving instance (DataId name) => Data (LHsTyVarBndrs name) + +mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName +-- Just at RdrName because in the Name variant we should know just +-- what the kind-variable binders are; and we don't +-- We put an empty list (rather than a panic) for the kind vars so +-- that the pretty printer works ok on them. +mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } + +emptyHsQTvs :: LHsTyVarBndrs name -- Use only when you know there are no kind binders +emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } + +hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] +hsQTvBndrs = hsq_tvs + +instance Monoid (LHsTyVarBndrs name) where + mempty = emptyHsQTvs + mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2) + = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) + +------------------------------------------------ +-- HsWithBndrs +-- Used to quantify the binders of a type in cases +-- when a HsForAll isn't appropriate: +-- * Patterns in a type/data family instance (HsTyPats) +-- * Type of a rule binder (RuleBndr) +-- * Pattern type signatures (SigPatIn) +-- In the last of these, wildcards can happen, so we must accommodate them + +data HsWithBndrs name thing + = HsWB { hswb_cts :: thing -- Main payload (type or list of types) + , hswb_kvs :: PostRn name [Name] -- Kind vars + , hswb_tvs :: PostRn name [Name] -- Type vars + , hswb_wcs :: PostRn name [Name] -- Wildcards + } + deriving (Typeable) +deriving instance (Data name, Data thing, Data (PostRn name [Name])) + => Data (HsWithBndrs name thing) + +mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing +mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder + , hswb_tvs = PlaceHolder + , hswb_wcs = PlaceHolder } + + +-- | These names are used early on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString-- ?x + deriving( Eq, Data, Typeable ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +data HsTyVarBndr name + = UserTyVar -- no explicit kinding + name + + | KindedTyVar + (Located name) + (LHsKind name) -- The user-supplied kind signature + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (HsTyVarBndr name) + +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr name -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True + +-- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? +hsTvbAllKinded :: LHsTyVarBndrs name -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs + +data HsType name + = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + (Maybe SrcSpan) -- Indicates whether extra constraints may be inferred. + -- When Nothing, no, otherwise the location of the extra- + -- constraints wildcard is stored. For instance, for the + -- signature (Eq a, _) => a -> a -> Bool, this field would + -- be something like (Just 1:8), with 1:8 being line 1, + -- column 8. + (LHsTyVarBndrs name) + (LHsContext name) + (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTyVar name -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsAppTy (LHsType name) + (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsFunTy (LHsType name) -- function type + (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsListTy (LHsType name) -- Element type + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, + -- 'ApiAnnotation.AnnClose' @':]'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTupleTy HsTupleSort + [LHsType name] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, + -- 'ApiAnnotation.AnnClose' @')' or '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsIParamTy HsIPName -- (?x :: ty) + (LHsType name) -- Implicit parameters as they occur in contexts + -- ^ + -- > (?x :: ty) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsEqTy (LHsType name) -- ty1 ~ ty2 + (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule + -- ^ + -- > ty1 ~ ty2 + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsKindSig (LHsType name) -- (ty :: kind) + (LHsKind name) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsQuasiQuoteTy (HsQuasiQuote name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsSpliceTy (HsSplice name) + (PostTc name Kind) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsDocTy (LHsType name) LHsDocString -- A documented type + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, + -- 'ApiAnnotation.AnnClose' @'#-}'@ + -- 'ApiAnnotation.AnnBang' @\'!\'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsRecTy [LConDeclField name] -- Only in data type declarations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitListTy -- A promoted explicit list + (PostTc name Kind) -- See Note [Promoted lists and tuples] + [LHsType name] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitTupleTy -- A promoted explicit tuple + [PostTc name Kind] -- See Note [Promoted lists and tuples] + [LHsType name] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTyLit HsTyLit -- A promoted numeric literal. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsWildcardTy -- A type wildcard + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsNamedWildcardTy name -- A named wildcard + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (HsType name) + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +data HsTyLit + = HsNumTy SourceText Integer + | HsStrTy SourceText FastString + deriving (Data, Typeable) + +data HsTyWrapper + = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn + deriving (Data, Typeable) + +type LHsTyOp name = HsTyOp (Located name) +type HsTyOp name = (HsTyWrapper, name) + +mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name +mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 + +{- +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the variables the user wrote + +After renaming + * Implicit => the *type* variables free in the type + Explicit => the variables the user wrote (renamed) + +Qualified currently behaves exactly as Implicit, +but it is deprecated to use it for implicit quantification. +In this case, GHC 7.10 gives a warning; see +Note [Context quantification] and Trac #4426. +In GHC 7.12, Qualified will no longer bind variables +and this will become an error. + +The kind variables bound in the hsq_kvs field come both + a) from the kind signatures on the kind vars (eg k1) + b) from the scope of the forall (eg k2) +Example: f :: forall (a::k1) b. T a (b::k2) + + +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + +Note [Distinguishing tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Apart from promotion, tuples can have one of three different kinds: + + x :: (Int, Bool) -- Regular boxed tuples + f :: Int# -> (# Int#, Int# #) -- Unboxed tuples + g :: (Eq a, Ord a) => a -- Constraint tuples + +For convenience, internally we use a single constructor for all of these, +namely HsTupleTy, but keep track of the tuple kind (in the first argument to +HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, +because of the #. However, with -XConstraintKinds we can only distinguish +between constraint and boxed tuples during type checking, in general. Hence the +four constructors of HsTupleSort: + + HsUnboxedTuple -> Produced by the parser + HsBoxedTuple -> Certainly a boxed tuple + HsConstraintTuple -> Certainly a constraint tuple + HsBoxedOrConstraintTuple -> Could be a boxed or a constraint + tuple. Produced by the parser only, + disappears after type checking +-} + +data HsTupleSort = HsUnboxedTuple + | HsBoxedTuple + | HsConstraintTuple + | HsBoxedOrConstraintTuple + deriving (Data, Typeable) + +data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable) + +type LConDeclField name = Located (ConDeclField name) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_names :: [Located name], + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving (Typeable) +deriving instance (DataId name) => Data (ConDeclField name) + +----------------------- +-- A valid type must have a for-all at the top of the type, or of the fn arg +-- types + +mkImplicitHsForAllTy :: LHsType RdrName -> HsType RdrName +mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName +mkQualifiedHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName + +-- | mkImplicitHsForAllTy is called when we encounter +-- f :: type +-- Wrap around a HsForallTy if one is not there already. +mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty)) + = HsForAllTy exp' extra tvs cxt ty + where + exp' = case exp of + Qualified -> Implicit + -- Qualified is used only for a nested forall, + -- this is now top level + _ -> exp +mkImplicitHsForAllTy ty = mkHsForAllTy Implicit [] (noLoc []) ty + +mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty +mkQualifiedHsForAllTy ctxt ty = mkHsForAllTy Qualified [] ctxt ty + +-- |Smart constructor for HsForAllTy, which populates the extra-constraints +-- field if a wildcard is present in the context. +mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName +mkHsForAllTy exp tvs (L l []) ty + = HsForAllTy exp Nothing (mkHsQTvs tvs) (L l []) ty +mkHsForAllTy exp tvs ctxt ty + = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt ty + where -- Separate the extra-constraints wildcard when present + (cleanCtxt, extra) + | (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l) + | otherwise = (ctxt, Nothing) + ignoreParens (L _ (HsParTy ty)) = ty + ignoreParens ty = ty + + +-- |When a sigtype is parsed, the type found is wrapped in an Implicit +-- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a +-- forall at the outer level. For Api Annotations this nested structure is +-- important to ensure that all `forall` and `.` locations are retained. From +-- the renamer onwards this structure is flattened, to ease the renaming and +-- type checking process. +flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name +flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty) + +flattenTopLevelHsForAllTy :: HsType name -> HsType name +flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty) + = snd $ mk_forall_ty [] l exp extra tvs ty +flattenTopLevelHsForAllTy ty = ty + +flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name) +flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty) + = mk_forall_ty [] l exp extra tvs ty +flattenHsForAllTyKeepAnns ty = ([],ty) + +-- mk_forall_ty makes a pure for-all type (no context) +mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan + -> LHsTyVarBndrs name + -> LHsType name -> ([AddAnn],HsType name) +mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) + = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra) + (tvs1 `mappend` qtvs2) ctxt ty) + where + -- Bias the merging of extra's to the top level, so that a single + -- wildcard context will prevail + mergeExtra (Just s) _ = Just s + mergeExtra _ e = e +mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty)) + = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty +mk_forall_ty ann l exp extra tvs ty + = (ann,HsForAllTy exp extra tvs (L l []) ty) + -- Even if tvs is empty, we still make a HsForAll! + -- In the Implicit case, this signals the place to do implicit quantification + -- In the Explicit case, it prevents implicit quantification + -- (see the sigtype production in Parser.y) + -- so that (forall. ty) isn't implicitly quantified + +plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag +Qualified `plus` Qualified = Qualified +Explicit `plus` _ = Explicit +_ `plus` Explicit = Explicit +_ `plus` _ = Implicit + +--------------------- +hsExplicitTvs :: LHsType Name -> [Name] +-- The explicitly-given forall'd type variables of a HsType +hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs +hsExplicitTvs _ = [] + +--------------------- +hsTyVarName :: HsTyVarBndr name -> name +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar (L _ n) _) = n + +hsLTyVarName :: LHsTyVarBndr name -> name +hsLTyVarName = hsTyVarName . unLoc + +hsLTyVarNames :: LHsTyVarBndrs name -> [name] +-- Type variables only +hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) + +hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name] +-- Kind and type variables +hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) + = kvs ++ map hsLTyVarName tvs + +hsLTyVarLocName :: LHsTyVarBndr name -> Located name +hsLTyVarLocName = fmap hsTyVarName + +hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) + +--------------------- +isWildcardTy :: HsType a -> Bool +isWildcardTy HsWildcardTy = True +isWildcardTy _ = False + +isNamedWildcardTy :: HsType a -> Bool +isNamedWildcardTy (HsNamedWildcardTy _) = True +isNamedWildcardTy _ = False + +splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) +splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) +splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as +splitHsAppTys f as = (f,as) + +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n]) +hsTyGetAppHead_maybe = go [] + where + go tys (L _ (HsTyVar n)) = Just (n, tys) + go tys (L _ (HsAppTy l r)) = go (r : tys) l + go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys) + go tys (L _ (HsParTy t)) = go tys t + go tys (L _ (HsKindSig t _)) = go tys t + go _ _ = Nothing + +mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n +mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) +mkHsAppTys fun_ty (arg_ty:arg_tys) + = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys + where + mk_app fun arg = HsAppTy (noLoc fun) arg + -- Add noLocs for inner nodes of the application; + -- they are never used + +splitLHsInstDeclTy_maybe + :: LHsType name + -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name]) + -- Split up an instance decl type, returning the pieces +splitLHsInstDeclTy_maybe inst_ty = do + let (tvs, cxt, ty) = splitLHsForAllTy inst_ty + (cls, tys) <- splitLHsClassTy_maybe ty + return (tvs, cxt, cls, tys) + +splitLHsForAllTy + :: LHsType name + -> (LHsTyVarBndrs name, HsContext name, LHsType name) +splitLHsForAllTy poly_ty + = case unLoc poly_ty of + HsParTy ty -> splitLHsForAllTy ty + HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty) + _ -> (emptyHsQTvs, [], poly_ty) + -- The type vars should have been computed by now, even if they were implicit + +splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) +splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty) + +splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +--- Watch out.. in ...deriving( Show )... we use this on +--- the list of partially applied predicates in the deriving, +--- so there can be zero args. + +-- In TcDeriv we also use this to figure out what data type is being +-- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). +splitLHsClassTy_maybe ty + = checkl ty [] + where + checkl (L l ty) args = case ty of + HsTyVar t -> Just (L l t, args) + HsAppTy l r -> checkl l (r:args) + HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args) + HsParTy t -> checkl t args + HsKindSig ty _ -> checkl ty args + _ -> Nothing + +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- Also deals with (->) t1 t2; that is why it only works on LHsType Name +-- (see Trac #9096) +splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name) +splitHsFunType (L _ (HsParTy ty)) + = splitHsFunType ty + +splitHsFunType (L _ (HsFunTy x y)) + | (args, res) <- splitHsFunType y + = (x:args, res) + +splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) + = go t1 [t2] + where -- Look for (->) t1 t2, possibly with parenthesisation + go (L _ (HsTyVar fn)) tys | fn == funTyConName + , [t1,t2] <- tys + , (args, res) <- splitHsFunType t2 + = (t1:args, res) + go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match + +splitHsFunType other = ([], other) + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance (OutputableBndr name) => Outputable (HsType name) where + ppr ty = pprHsType ty + +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where + ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) + = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ] + +instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where + ppr (UserTyVar n) = ppr n + ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] + +instance (Outputable thing) => Outputable (HsWithBndrs name thing) where + ppr (HsWB { hswb_cts = ty }) = ppr ty + +pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc +pprHsForAll exp = pprHsForAllExtra exp Nothing + +-- | Version of 'pprHsForAll' that can also print an extra-constraints +-- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This +-- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' +-- containing the location of the extra-constraints wildcard. A special +-- function for this is needed, as the extra-constraints wildcard is removed +-- from the actual context and type, and stored in a separate field, thus just +-- printing the type will not print the extra-constraints wildcard. +pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc +pprHsForAllExtra exp extra qtvs cxt + | show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt) + | otherwise = pprHsContextExtra show_extra (unLoc cxt) + where + show_extra = isJust extra + show_forall = opt_PprStyle_Debug + || (not (null (hsQTvBndrs qtvs)) && is_explicit) + is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False} + forall_part = forAllLit <+> ppr qtvs <> dot + +pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe + +pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe + +pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc +pprHsContextMaybe [] = Nothing +pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred +pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) + +-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ +pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc +pprHsContextExtra False = pprHsContext +pprHsContextExtra True + = \ctxt -> case ctxt of + [] -> char '_' <+> darrow + _ -> parens (sep (punctuate comma ctxt')) <+> darrow + where ctxt' = map ppr ctxt ++ [char '_'] + +pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc +pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, + cd_fld_doc = doc })) + = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_names [n] = ppr n + ppr_names ns = sep (punctuate comma (map ppr ns)) + +{- +Note [Printing KindedTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Trac #3830 reminded me that we should really only print the kind +signature on a KindedTyVar if the kind signature was put there by the +programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, +rather than converting to KindedTyVars as before. + +(As it happens, the message in #3830 comes out a different way now, +and the problem doesn't show up; but having the flag on a KindedTyVar +seems like the Right Thing anyway.) +-} + +-- Printing works more-or-less as for Types + +pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc + +pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty) +pprParendHsType ty = ppr_mono_ty TyConPrec ty + +-- Before printing a type +-- (a) Remove outermost HsParTy parens +-- (b) Drop top-level for-all type variables in user style +-- since they are implicit in Haskell +prepare :: PprStyle -> HsType name -> HsType name +prepare sty (HsParTy ty) = prepare sty (unLoc ty) +prepare _ ty = ty + +ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + +ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc +ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty) + = maybeParen ctxt_prec FunPrec $ + sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty] + +ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty +ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq +ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds +ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name +ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + _ -> BoxedTuple +ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind) +ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty) +ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) +ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) +ppr_mono_ty _ (HsSpliceTy s _) = pprUntypedSplice s +ppr_mono_ty _ (HsCoreTy ty) = ppr ty +ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) +ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) +ppr_mono_ty _ (HsTyLit t) = ppr_tylit t +ppr_mono_ty _ HsWildcardTy = char '_' +ppr_mono_ty _ (HsNamedWildcardTy name) = ppr name + +ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) + = ppr_mono_ty ctxt_prec ty +-- We are not printing kind applications. If we wanted to do so, we should do +-- something like this: +{- + = go ctxt_prec kis ty + where + go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty + go ctxt_prec (ki:kis) ty + = maybeParen ctxt_prec TyConPrec $ + hsep [ go FunPrec kis ty + , ptext (sLit "@") <> pprParendKind ki ] +-} + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) + = maybeParen ctxt_prec TyOpPrec $ + ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) + = maybeParen ctxt_prec TyConPrec $ + hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2) + = maybeParen ctxt_prec TyOpPrec $ + sep [ ppr_mono_lty TyOpPrec ty1 + , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ] + -- Don't print the wrapper (= kind applications) + -- c.f. HsWrapTy + +ppr_mono_ty _ (HsParTy ty) + = parens (ppr_mono_lty TopPrec ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +ppr_mono_ty ctxt_prec (HsDocTy ty doc) + = maybeParen ctxt_prec TyOpPrec $ + ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc) + -- we pretty print Haddock comments on types as if they were + -- postfix operators + +-------------------------- +ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc +ppr_fun_ty ctxt_prec ty1 ty2 + = let p1 = ppr_mono_lty FunPrec ty1 + p2 = ppr_mono_lty TopPrec ty2 + in + maybeParen ctxt_prec FunPrec $ + sep [p1, ptext (sLit "->") <+> p2] + +-------------------------- +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy _ i) = integer i +ppr_tylit (HsStrTy _ s) = text (show s) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs new file mode 100644 index 00000000..ad438e5c --- /dev/null +++ b/compiler/hsSyn/HsUtils.hs @@ -0,0 +1,936 @@ +{- +(c) The University of Glasgow, 1992-2006 + + +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the instantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + RdrName parser/RdrHsSyn + Name rename/RnHsSyn + Id typecheck/TcHsSyn +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +module HsUtils( + -- Terms + mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, + mkLHsPar, mkHsCmdCast, + + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, + nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + toHsType, toHsKind, + + -- Bindings + mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind, + + -- Literals + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, + + -- Patterns + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, + nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, + nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, + + -- Types + mkHsAppTy, userHsTyVarBndrs, + nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + + -- Stmts + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, + emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, + + -- Template Haskell + mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice, + mkHsQuasiQuote, unqualQuasiQuote, + + -- Flags + noRebindableInfo, + + -- Collecting binders + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsIdBinders, + collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectStmtsBinders, + collectLStmtBinders, collectStmtBinders, + + hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders, + hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ) where + +#include "HsVersions.h" + +import HsDecls +import HsBinds +import HsExpr +import HsPat +import HsTypes +import HsLit +import PlaceHolder + +import TcEvidence +import RdrName +import Var +import TypeRep +import TcType +import Kind +import DataCon +import Name +import NameSet +import BasicTypes +import SrcLoc +import FastString +import Util +import Bag +import Outputable + +import Data.Either +import Data.Function +import Data.List + +{- +************************************************************************ +* * + Some useful helpers for constructing syntax +* * +************************************************************************ + +These functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the nl* functions below which +just attach noSrcSpan to everything. +-} + +mkHsPar :: LHsExpr id -> LHsExpr id +mkHsPar e = L (getLoc e) (HsPar e) + +mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) +mkSimpleMatch pats rhs + = L loc $ + Match Nothing pats Nothing (unguardedGRHSs rhs) + where + loc = case pats of + [] -> getLoc rhs + (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) + +unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) +unguardedGRHSs rhs@(L loc _) = GRHSs (unguardedRHS loc rhs) emptyLocalBinds + +unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))] +unguardedRHS loc rhs = [L loc (GRHS [] rhs)] + +mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))] + -> MatchGroup RdrName (Located (body RdrName)) +mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [] + , mg_res_ty = placeHolderType + , mg_origin = origin } + +mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))] + -> MatchGroup Name (Located (body Name)) +mkMatchGroupName origin matches = MG { mg_alts = matches, mg_arg_tys = [] + , mg_res_ty = placeHolderType + , mg_origin = origin } + +mkHsAppTy :: LHsType name -> LHsType name -> LHsType name +mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) + +mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) + +mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) + where + matches = mkMatchGroup Generated [mkSimpleMatch pats body] + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpLams dicts) expr + +mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id +-- Used for constructing dictionary terms etc, so no locations +mkHsConApp data_con tys args + = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args + where + mk_app f a = noLoc (HsApp f (noLoc a)) + +mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) +-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking +mkSimpleHsAlt pat expr + = mkSimpleMatch [pat] expr + +nlHsTyApp :: name -> [Type] -> LHsExpr name +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) + +nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs + +--------- Adding parens --------- +mkLHsPar :: LHsExpr name -> LHsExpr name +-- Wrap in parens if hsExprNeedsParens says it needs them +-- So 'f x' becomes '(f x)', but '3' stays as '3' +mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) + | otherwise = le + +mkParPat :: LPat name -> LPat name +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) + | otherwise = lp + + +------------------------------- +-- These are the bits of syntax that contain rebindable names +-- See RnEnv.lookupSyntaxName + +mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName +mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName +mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName +mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName +mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName + -> HsExpr RdrName + +mkNPat :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id +mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id + +mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBodyStmt :: Located (bodyR RdrName) + -> StmtLR idL RdrName (Located (bodyR RdrName)) +mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) + +emptyRecStmt :: StmtLR idL RdrName bodyR +emptyRecStmtName :: StmtLR Name Name bodyR +emptyRecStmtId :: StmtLR Id Id bodyR +mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR + + +mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noSyntaxExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr +mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr + +noRebindableInfo :: PlaceHolder +noRebindableInfo = PlaceHolder -- Just another placeholder; + +mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = L (getLoc expr) $ mkLastStmt expr + +mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id +mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b + +mkNPat lit neg = NPat lit neg noSyntaxExpr +mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr + +mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) + +emptyTransStmt :: StmtLR idL idR (LHsExpr idR) +emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } + +mkLastStmt body = LastStmt body noSyntaxExpr +mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr + + +emptyRecStmt' :: forall idL idR body. + PostTc idR Type -> StmtLR idL idR body +emptyRecStmt' tyVal = + RecStmt + { recS_stmts = [], recS_later_ids = [] + , recS_rec_ids = [] + , recS_ret_fn = noSyntaxExpr + , recS_mfix_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] + , recS_rec_rets = [], recS_ret_ty = tyVal } + +emptyRecStmt = emptyRecStmt' placeHolderType +emptyRecStmtName = emptyRecStmt' placeHolderType +emptyRecStmtId = emptyRecStmt' placeHolderTypeTc +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } + +------------------------------- +--- A useful function for building @OpApps@. The operator is always a +-- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 + +mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName +mkHsSplice e = HsSplice unqualSplice e + +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) + +mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceE e = HsSpliceE False (mkHsSplice e) + +mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceTE e = HsSpliceE True (mkHsSplice e) + +mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName +mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind + +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName +mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit +mkHsString s = HsString s (mkFastString s) + +------------- +userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +-- Caller sets location +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] + +{- +************************************************************************ +* * + Constructing syntax with no location info +* * +************************************************************************ +-} + +nlHsVar :: id -> LHsExpr id +nlHsVar n = noLoc (HsVar n) + +nlHsLit :: HsLit -> LHsExpr id +nlHsLit n = noLoc (HsLit n) + +nlVarPat :: id -> LPat id +nlVarPat n = noLoc (VarPat n) + +nlLitPat :: HsLit -> LPat id +nlLitPat l = noLoc (LitPat l) + +nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsApp f x = noLoc (HsApp f x) + +nlHsIntLit :: Integer -> LHsExpr id +nlHsIntLit n = noLoc (HsLit (HsInt (show n) n)) + +nlHsApps :: id -> [LHsExpr id] -> LHsExpr id +nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs + +nlHsVarApps :: id -> [id] -> LHsExpr id +nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs)) + where + mk f a = HsApp (noLoc f) (noLoc a) + +nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName +nlConVarPat con vars = nlConPat con (map nlVarPat vars) + +nlInfixConPat :: id -> LPat id -> LPat id -> LPat id +nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) + +nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName +nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) + +nlConPatName :: Name -> [LPat Name] -> LPat Name +nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) + +nlNullaryConPat :: id -> LPat id +nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) + +nlWildConPat :: DataCon -> LPat RdrName +nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) + (PrefixCon (nOfThem (dataConSourceArity con) + nlWildPat))) + +nlWildPat :: LPat RdrName +nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking + +nlWildPatName :: LPat Name +nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking + +nlWildPatId :: LPat Id +nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking + +nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)] + -> LHsExpr RdrName +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) + +nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id +nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) + +nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName +nlHsPar :: LHsExpr id -> LHsExpr id +nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)] + -> LHsExpr RdrName +nlList :: [LHsExpr RdrName] -> LHsExpr RdrName + +nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar e) +nlHsIf cond true false = noLoc (mkHsIf cond true false) +nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) + +nlHsAppTy :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name + +nlHsAppTy f t = noLoc (HsAppTy f t) +nlHsTyVar x = noLoc (HsTyVar x) +nlHsFunTy a b = noLoc (HsFunTy a b) + +nlHsTyConApp :: name -> [LHsType name] -> LHsType name +nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys + +{- +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. +-} + +mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] = e +mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed + +mkLHsVarTuple :: [a] -> LHsExpr a +mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) + +nlTuplePat :: [LPat id] -> Boxity -> LPat id +nlTuplePat pats box = noLoc (TuplePat pats box []) + +missingTupArg :: HsTupArg RdrName +missingTupArg = Missing placeHolderType + +{- +************************************************************************ +* * + Converting a Type to an HsType RdrName +* * +************************************************************************ + +This is needed to implement GeneralizedNewtypeDeriving. +-} + +toHsType :: Type -> LHsType RdrName +toHsType ty + | [] <- tvs_only + , [] <- theta + = to_hs_type tau + | otherwise + = noLoc $ + mkExplicitHsForAllTy (map mk_hs_tvb tvs_only) + (noLoc $ map toHsType theta) + (to_hs_type tau) + + where + (tvs, theta, tau) = tcSplitSigmaTy ty + tvs_only = filter isTypeVar tvs + + to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv) + to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2) + to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args') + where + args' = filterOut isKind args + -- Source-language types have _implicit_ kind arguments, + -- so we must remove them here (Trac #8563) + to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) ) + nlHsFunTy (toHsType arg) (toHsType res) + to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t) + to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) + to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) + + mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) + (toHsKind (tyVarKind tv)) + +toHsKind :: Kind -> LHsKind RdrName +toHsKind = toHsType + +--------- HsWrappers: type args, dict args, casts --------- +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) + +mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap co_fn e | isIdHsWrapper co_fn = e + | otherwise = HsWrap co_fn e + +mkHsWrapCo :: TcCoercion -- A Nominal coercion a ~N b + -> HsExpr id -> HsExpr id +mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e + +mkHsWrapCoR :: TcCoercion -- A Representational coercion a ~R b + -> HsExpr id -> HsExpr id +mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e + +mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) + +mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id +mkHsCmdCast co cmd | isTcReflCo co = cmd + | otherwise = HsCmdCast co cmd + +coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion +coToHsWrapper co | isTcReflCo co = idHsWrapper + | otherwise = mkWpCast (mkTcSubCo co) + +coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion +coToHsWrapperR co | isTcReflCo co = idHsWrapper + | otherwise = mkWpCast co + +mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id +mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p + | otherwise = CoPat co_fn p ty + +-- input coercion is Nominal +mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo co pat ty | isTcReflCo co = pat + | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty + +mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr + +{- +l +************************************************************************ +* * + Bindings; with a location at the top +* * +************************************************************************ +-} + +mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] + -> HsBind RdrName +-- Not infix, with place holders for coercion and free vars +mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False + , fun_matches = mkMatchGroup Generated ms + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNames + , fun_tick = [] } + +mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] + -> HsBind Name +-- In Name-land, with empty bind_fvs +mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False + , fun_matches = mkMatchGroupName origin ms + , fun_co_fn = idHsWrapper + , bind_fvs = emptyNameSet -- NB: closed + -- binding + , fun_tick = [] } + +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_id = var, var_rhs = rhs, var_inline = False } + +mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) + -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName +mkPatSynBind name details lpat dir = PatSynBind psb + where + psb = PSB{ psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir + , psb_fvs = placeHolderNames } + +------------ +mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] + -> LHsExpr RdrName -> LHsBind RdrName +mk_easy_FunBind loc fun pats expr + = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] + +------------ +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) +mkMatch pats expr binds + = noLoc (Match Nothing (map paren pats) Nothing + (GRHSs (unguardedRHS noSrcSpan expr) binds)) + where + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) + | otherwise = lp + +{- +************************************************************************ +* * + Collecting binders +* * +************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +Note [Collect binders only after renaming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions should only be used on HsSyn *after* the renamer, +to return a [Name] or [Id]. Before renaming the record punning +and wild-card mechanism makes it hard to know what is bound. +So these functions should not be applied to (HsSyn RdrName) +-} + +----------------- Bindings -------------------------- +collectLocalBinders :: HsLocalBindsLR idL idR -> [idL] +collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds + -- No pattern synonyms here +collectLocalBinders (HsIPBinds _) = [] +collectLocalBinders EmptyLocalBinds = [] + +collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL] +-- Collect Id binders only, or Ids + pattern synonmys, respectively +collectHsIdBinders = collect_hs_val_binders True +collectHsValBinders = collect_hs_val_binders False + +collectHsBindBinders :: HsBindLR idL idR -> [idL] +-- Collect both Ids and pattern-synonym binders +collectHsBindBinders b = collect_bind False b [] + +collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] +collectHsBindsBinders binds = collect_binds False binds [] + +collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] +-- Same as collectHsBindsBinders, but works over a list of bindings +collectHsBindListBinders = foldr (collect_bind False . unLoc) [] + +collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL] +collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds + +collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id] +collect_out_binds ps = foldr (collect_binds ps . snd) [] + +collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL] +-- Collect Ids, or Ids + patter synonyms, depending on boolean flag +collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds + +collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL] +collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc +collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc +collect_bind _ (VarBind { var_id = f }) acc = f : acc +collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc + -- I don't think we want the binders from the abe_binds + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn +collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc = + if omitPatSyn then acc else ps : acc + +collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] +-- Used exclusively for the bindings of an instance decl which are all FunBinds +collectMethodBinders binds = foldrBag (get . unLoc) [] binds + where + get (FunBind { fun_id = f }) fs = f : fs + get _ fs = fs + -- Someone else complains about non-FunBinds + +----------------- Statements -------------------------- +collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectStmtsBinders :: [StmtLR idL idR body] -> [idL] +collectStmtsBinders = concatMap collectStmtBinders + +collectLStmtBinders :: LStmtLR idL idR body -> [idL] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: StmtLR idL idR body -> [idL] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt binds) = collectLocalBinders binds +collectStmtBinders (BodyStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders + $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss + + +----------------- Patterns -------------------------- +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = collect_lpat pat [] + +collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders pats = foldr collect_lpat [] pats + +------------- +collect_lpat :: LPat name -> [name] -> [name] +collect_lpat (L _ pat) bndrs + = go pat + where + go (VarPat var) = var : bndrs + go (WildPat _) = bndrs + go (LazyPat pat) = collect_lpat pat bndrs + go (BangPat pat) = collect_lpat pat bndrs + go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (ViewPat _ pat _) = collect_lpat pat bndrs + go (ParPat pat) = collect_lpat pat bndrs + + go (ListPat pats _ _) = foldr collect_lpat bndrs pats + go (PArrPat pats _) = foldr collect_lpat bndrs pats + go (TuplePat pats _ _) = foldr collect_lpat bndrs pats + + go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) + -- See Note [Dictionary binders in ConPatOut] + go (LitPat _) = bndrs + go (NPat _ _ _) = bndrs + go (NPlusKPat (L _ n) _ _ _) = n : bndrs + + go (SigPatIn pat _) = collect_lpat pat bndrs + go (SigPatOut pat _) = collect_lpat pat bndrs + go (SplicePat _) = bndrs + go (QuasiQuotePat _) = bndrs + go (CoPat _ pat _) = go pat + +{- +Note [Dictionary binders in ConPatOut] See also same Note in DsArrows +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* gather (a) dictionary and (b) dictionary bindings as binders +of a ConPatOut pattern. For most calls it doesn't matter, because +it's pre-typechecker and there are no ConPatOuts. But it does matter +more in the desugarer; for example, DsUtils.mkSelectorBinds uses +collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., +we want to generate bindings for x,y but not for dictionaries bound by +C. (The type checker ensures they would not be used.) + +Desugaring of arrow case expressions needs these bindings (see DsArrows +and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its +own pat-binder-collector: + +Here's the problem. Consider + +data T a where + C :: Num a => a -> Int -> T a + +f ~(C (n+1) m) = (n,m) + +Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), +and *also* uses that dictionary to match the (n+1) pattern. Yet, the +variables bound by the lazy pattern are n,m, *not* the dictionary d. +So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. +-} + +hsGroupBinders :: HsGroup Name -> [Name] +hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, + hs_instds = inst_decls, hs_fords = foreign_decls }) + = collectHsValBinders val_decls + ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls + +hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name] + -> [LForeignDecl Name] -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors +hsTyClForeignBinders tycl_decls inst_decls foreign_decls + = map unLoc $ + hsForeignDeclsBinders foreign_decls ++ + concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++ + concatMap hsLInstDeclBinders inst_decls + +------------------- +hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] +-- ^ Returns all the /binding/ names of the decl. +-- The first one is guaranteed to be the name of the decl. For record fields +-- mentioned in multiple constructors, the SrcLoc will be from the first +-- occurrence. We use the equality to filter out duplicate field names. +-- +-- Each returned (Located name) has a SrcSpan for the /whole/ declaration. +-- See Note [SrcSpan for binders] + +hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) + = [L loc name] +hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = [L loc name] +hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name + , tcdSigs = sigs, tcdATs = ats })) + = L loc cls_name : + [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ] +hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) + = L loc name : hsDataDefnBinders defn + +------------------- +hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] +-- See Note [SrcSpan for binders] +hsForeignDeclsBinders foreign_decls + = [ L decl_loc n + | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls] + +------------------- +hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL] +-- Collect pattern-synonym binders only, not Ids +-- See Note [SrcSpan for binders] +hsPatSynBinders binds = foldrBag addPatSynBndr [] binds + +addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL] +-- See Note [SrcSpan for binders] +addPatSynBndr bind pss + | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind + = L bind_loc n : pss + | otherwise + = pss + +------------------- +hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name] +hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) + = concatMap (hsDataFamInstBinders . unLoc) dfis +hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) + = hsDataFamInstBinders fi +hsLInstDeclBinders (L _ (TyFamInstD {})) = [] + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name] +hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) + = hsDataDefnBinders defn + -- There can't be repeated symbols because only data instances have binders + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name] +hsDataDefnBinders (HsDataDefn { dd_cons = cons }) + = hsConDeclsBinders cons + -- See Note [Binders in family instances] + +------------------- +hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name] + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons = go id cons + where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name] + go _ [] = [] + go remSeen (r:rs) = + -- don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + case r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + L loc (ConDecl { con_names = names, con_details = RecCon flds }) -> + (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs + where r' = remSeen (concatMap (cd_fld_names . unLoc) + (unLoc flds)) + remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] + L loc (ConDecl { con_names = names }) -> + (map (L loc . unLoc) names) ++ go remSeen rs + +{- + +Note [SrcSpan for binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extracting the (Located RdrNme) for a binder, at least for the +main name (the TyCon of a type declaration etc), we want to give it +the @SrcSpan@ of the whole /declaration/, not just the name itself +(which is how it appears in the syntax tree). This SrcSpan (for the +entire declaration) is used as the SrcSpan for the Name that is +finally produced, and hence for error messages. (See Trac #8607.) + +Note [Binders in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type or data family instance declaration, the type +constructor is an *occurrence* not a binding site + type instance T Int = Int -> Int -- No binders + data instance S Bool = S1 | S2 -- Binders are S1,S2 + + +************************************************************************ +* * + Collecting binders the user did not write +* * +************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) +-} + +lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (BodyStmt {}) = emptyNameSet + hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + +hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) + = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds +hsValBindsImplicits (ValBindsIn binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet +lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet + where + lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + lhs_bind _ = emptyNameSet + +lPatImplicits :: LPat Name -> NameSet +lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _ _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg + (unLoc fld) + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs new file mode 100644 index 00000000..246abc02 --- /dev/null +++ b/compiler/hsSyn/PlaceHolder.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module PlaceHolder where + +import Type ( Type ) +import Outputable +import Name +import NameSet +import RdrName +import Var +import Coercion + +import Data.Data hiding ( Fixity ) +import BasicTypes (Fixity) + + +{- +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ +-} + +-- | used as place holder in PostTc and PostRn values +data PlaceHolder = PlaceHolder + deriving (Data,Typeable) + +-- | Types that are not defined until after type checking +type family PostTc it ty :: * -- Note [Pass sensitive types] +type instance PostTc Id ty = ty +type instance PostTc Name ty = PlaceHolder +type instance PostTc RdrName ty = PlaceHolder + +-- | Types that are not defined until after renaming +type family PostRn id ty :: * -- Note [Pass sensitive types] +type instance PostRn Id ty = ty +type instance PostRn Name ty = ty +type instance PostRn RdrName ty = PlaceHolder + +placeHolderKind :: PlaceHolder +placeHolderKind = PlaceHolder + +placeHolderFixity :: PlaceHolder +placeHolderFixity = PlaceHolder + +placeHolderType :: PlaceHolder +placeHolderType = PlaceHolder + +placeHolderTypeTc :: Type +placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType" + +placeHolderNames :: PlaceHolder +placeHolderNames = PlaceHolder + +placeHolderNamesTc :: NameSet +placeHolderNamesTc = emptyNameSet + +{- + +Note [Pass sensitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the same AST types are re-used through parsing,renaming and type +checking there are naturally some places in the AST that do not have +any meaningful value prior to the pass they are assigned a value. + +Historically these have been filled in with place holder values of the form + + panic "error message" + +This has meant the AST is difficult to traverse using standed generic +programming techniques. The problem is addressed by introducing +pass-specific data types, implemented as a pair of open type families, +one for PostTc and one for PostRn. These are then explicitly populated +with a PlaceHolder value when they do not yet have meaning. + +Since the required bootstrap compiler at this stage does not have +closed type families, an open type family had to be used, which +unfortunately forces the requirement for UndecidableInstances. + +In terms of actual usage, we have the following + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + +TcId and Var are synonyms for Id +-} + +type DataId id = + ( Data id + , Data (PostRn id NameSet) + , Data (PostRn id Fixity) + , Data (PostRn id Bool) + , Data (PostRn id [Name]) + + , Data (PostTc id Type) + , Data (PostTc id Coercion) + ) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs new file mode 100644 index 00000000..4ec9ec7c --- /dev/null +++ b/compiler/iface/BinIface.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE CPP #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +{-# OPTIONS_GHC -O #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | Binary interface file support. +module BinIface ( + writeBinIface, + readBinIface, + getSymtabName, + getDictFastString, + CheckHiWay(..), + TraceBinIFaceReading(..) + ) where + +#include "HsVersions.h" + +import TcRnMonad +import TyCon +import ConLike +import DataCon (dataConName, dataConWorkId, dataConTyCon) +import PrelInfo (wiredInThings, basicKnownKeyNames) +import Id (idName, isDataConWorkId_maybe) +import TysWiredIn +import IfaceEnv +import HscTypes +import BasicTypes +import Module +import Name +import DynFlags +import UniqFM +import UniqSupply +import Panic +import Binary +import SrcLoc +import ErrUtils +import FastMutInt +import Unique +import Outputable +import Platform +import FastString +import Constants +import Util + +import Data.Bits +import Data.Char +import Data.List +import Data.Word +import Data.Array +import Data.IORef +import Control.Monad + + +-- --------------------------------------------------------------------------- +-- Reading and writing binary interface files +-- + +data CheckHiWay = CheckHiWay | IgnoreHiWay + deriving Eq + +data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading + deriving Eq + +-- | Read an interface file +readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath + -> TcRnIf a b ModIface +readBinIface checkHiWay traceBinIFaceReading hi_path = do + ncu <- mkNameCacheUpdater + dflags <- getDynFlags + liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu + +readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath + -> NameCacheUpdater + -> IO ModIface +readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do + let printer :: SDoc -> IO () + printer = case traceBinIFaceReading of + TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd + QuietBinIFaceReading -> \_ -> return () + wantedGot :: Outputable a => String -> a -> a -> IO () + wantedGot what wanted got = + printer (text what <> text ": " <> + vcat [text "Wanted " <> ppr wanted <> text ",", + text "got " <> ppr got]) + + errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () + errorOnMismatch what wanted got = + -- This will be caught by readIface which will emit an error + -- msg containing the iface module name. + when (wanted /= got) $ throwGhcExceptionIO $ ProgramError + (what ++ " (wanted " ++ show wanted + ++ ", got " ++ show got ++ ")") + bh <- Binary.readBinMem hi_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + wantedGot "Magic" (binaryInterfaceMagic dflags) magic + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + (binaryInterfaceMagic dflags) magic + + -- Note [dummy iface field] + -- read a dummy 32/64 bit value. This field used to hold the + -- dictionary pointer in old interface file formats, but now + -- the dictionary pointer is after the version (where it + -- should be). Also, the serialisation of value of type "Bin + -- a" used to depend on the word size of the machine, now they + -- are always 32 bits. + if wORD_SIZE dflags == 4 + then do _ <- Binary.get bh :: IO Word32; return () + else do _ <- Binary.get bh :: IO Word64; return () + + -- Check the interface file version and ways. + check_ver <- get bh + let our_ver = show hiVersion + wantedGot "Version" our_ver check_ver + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_way <- get bh + let way_descr = getWayDescr dflags + wantedGot "Way" way_descr check_way + when (checkHiWay == CheckHiWay) $ + errorOnMismatch "mismatched interface file ways" way_descr check_way + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p -- Back to where we were before + + -- Initialise the user-data field of bh + bh <- do + bh <- return $ setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab_p <- Binary.get bh -- Get the symtab ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh symtab_p + symtab <- getSymbolTable bh ncu + seekBin bh data_p -- Back to where we were before + + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) + (getDictFastString dict) + + -- Read the interface file + get bh + +-- | Write an interface file +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + put_ bh (binaryInterfaceMagic dflags) + + -- dummy 32/64-bit field before the version/way for + -- compatibility with older interface file formats. + -- See Note [dummy iface field] above. + if wORD_SIZE dflags == 4 + then Binary.put_ bh (0 :: Word32) + else Binary.put_ bh (0 :: Word64) + + -- The version and way descriptor go next + put_ bh (show hiVersion) + let way_descr = getWayDescr dflags + put_ bh way_descr + + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + -- Placeholder for ptr to dictionary + put_ bh dict_p_p + + -- Remember where the symbol table pointer will go + symtab_p_p <- tellBin bh + put_ bh symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = BinSymbolTable { + bin_symtab_next = symtab_next, + bin_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = BinDictionary { + bin_dict_next = dict_next_ref, + bin_dict_map = dict_map_ref } + + -- Put the main thing, + bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) + (putFastString bin_dict) + put_ bh mod_iface + + -- Write the symtab pointer at the fornt of the file + symtab_p <- tellBin bh -- This is where the symtab will start + putAt bh symtab_p_p symtab_p -- Fill in the placeholder + seekBin bh symtab_p -- Seek back to the end of the file + + -- Write the symbol table itself + symtab_next <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh symtab_next symtab_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next + <+> text "Names") + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + + -- Write the dictionary pointer at the fornt of the file + dict_p <- tellBin bh -- This is where the dictionary will start + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") + + -- And send the result to the file + writeBinMem bh hi_path + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +binaryInterfaceMagic :: DynFlags -> Word32 +binaryInterfaceMagic dflags + | target32Bit (targetPlatform dflags) = 0x1face + | otherwise = 0x1face64 + + +-- ----------------------------------------------------------------------------- +-- The symbol table +-- + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (eltsUFM symtab)) + mapM_ (\n -> serialiseName bh n symtab) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + updateNameCache ncu $ \namecache -> + let arr = listArray (0,sz-1) names + (namecache', names) = + mapAccumR (fromOnDiskName arr) namecache od_names + in (namecache', arr) + +type OnDiskName = (PackageKey, ModuleName, OccName) + +fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name) +fromOnDiskName _ nc (pid, mod_name, occ) = + let mod = mkModule pid mod_name + cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name _ = do + let mod = ASSERT2( isExternalName name, ppr name ) nameModule name + put_ bh (modulePackageKey mod, moduleName mod, nameOccName name) + + +-- Note [Symbol table representation of names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- An occurrence of a name in an interface file is serialized as a single 32-bit word. +-- The format of this word is: +-- 00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +-- A normal name. x is an index into the symbol table +-- 01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy +-- A known-key name. x is the Unique's Char, y is the int part +-- 10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz +-- A tuple name: +-- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint) +-- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker) +-- z is the arity +-- 11xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +-- An implicit parameter TyCon name. x is an index into the FastString *dictionary* +-- +-- Note that we have to have special representation for tuples and IP TyCons because they +-- form an "infinite" family and hence are not recorded explicitly in wiredInTyThings or +-- basicKnownKeyNames. + +knownKeyNamesMap :: UniqFM Name +knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames] + where + knownKeyNames :: [Name] + knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames + + +-- See Note [Symbol table representation of names] +putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName _dict BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } bh name + | name `elemUFM` knownKeyNamesMap + , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- ASSERT(u < 2^(22 :: Int)) + put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32)) + | otherwise + = case wiredInNameTyThing_maybe name of + Just (ATyCon tc) + | isTupleTyCon tc -> putTupleName_ bh tc 0 + Just (AConLike (RealDataCon dc)) + | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1 + Just (AnId x) + | Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2 + _ -> do + symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + -- MASSERT(off < 2^(30 :: Int)) + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + +putTupleName_ :: BinHandle -> TyCon -> Word32 -> IO () +putTupleName_ bh tc thing_tag + = -- ASSERT(arity < 2^(30 :: Int)) + put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity) + where + arity = fromIntegral (tupleTyConArity tc) + sort_tag = case tupleTyConSort tc of + BoxedTuple -> 0 + UnboxedTuple -> 1 + ConstraintTuple -> 2 + +-- See Note [Symbol table representation of names] +getSymtabName :: NameCacheUpdater + -> Dictionary -> SymbolTable + -> BinHandle -> IO Name +getSymtabName _ncu _dict symtab bh = do + i <- get bh + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral (i ::  Word32) + 0x40000000 -> return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i) + Just n -> n + where tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + 0x80000000 -> return $! case thing_tag of + 0 -> tyConName (tupleTyCon sort arity) + 1 -> dataConName dc + 2 -> idName (dataConWorkId dc) + _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) + where + dc = tupleCon sort arity + sort = case (i .&. 0x30000000) `shiftR` 28 of + 0 -> BoxedTuple + 1 -> UnboxedTuple + 2 -> ConstraintTuple + _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) + thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26 + arity = fromIntegral (i .&. 0x03FFFFFF) + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + -- indexed by Name + } + +putFastString :: BinDictionary -> BinHandle -> FastString -> IO () +putFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: BinDictionary -> FastString -> IO Word32 +allocateFastString BinDictionary { bin_dict_next = j_r, + bin_dict_map = out_r} f = do + out <- readIORef out_r + let uniq = getUnique f + case lookupUFM out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out uniq (j, f) + return (fromIntegral j :: Word32) + +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +data BinDictionary = BinDictionary { + bin_dict_next :: !FastMutInt, -- The next index to use + bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + -- indexed by FastString + } + +getWayDescr :: DynFlags -> String +getWayDescr dflags + | platformUnregisterised (targetPlatform dflags) = 'u':tag + | otherwise = tag + where tag = buildTag dflags + -- if this is an unregisterised build, make sure our interfaces + -- can't be used by a registerised build. diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs new file mode 100644 index 00000000..33be51ff --- /dev/null +++ b/compiler/iface/BuildTyCl.hs @@ -0,0 +1,333 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module BuildTyCl ( + buildSynonymTyCon, + buildFamilyTyCon, + buildAlgTyCon, + buildDataCon, + buildPatSyn, + TcMethInfo, buildClass, + distinctAbstractTyConRhs, totallyAbstractTyConRhs, + mkNewTyConRhs, mkDataTyConRhs, + newImplicitBinder + ) where + +#include "HsVersions.h" + +import IfaceEnv +import FamInstEnv( FamInstEnvs ) +import DataCon +import PatSyn +import Var +import VarSet +import BasicTypes +import Name +import MkId +import Class +import TyCon +import Type +import Id +import Coercion +import TcType + +import DynFlags +import TcRnMonad +import UniqSupply +import Util +import Outputable + +------------------------------------------------------ +buildSynonymTyCon :: Name -> [TyVar] -> [Role] + -> Type + -> Kind -- ^ Kind of the RHS + -> TcRnIf m n TyCon +buildSynonymTyCon tc_name tvs roles rhs rhs_kind + = return (mkSynonymTyCon tc_name kind tvs roles rhs) + where kind = mkPiKinds tvs rhs_kind + + +buildFamilyTyCon :: Name -> [TyVar] + -> FamTyConFlav + -> Kind -- ^ Kind of the RHS + -> TyConParent + -> TcRnIf m n TyCon +buildFamilyTyCon tc_name tvs rhs rhs_kind parent + = return (mkFamilyTyCon tc_name kind tvs rhs parent) + where kind = mkPiKinds tvs rhs_kind + + +------------------------------------------------------ +distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs +distinctAbstractTyConRhs = AbstractTyCon True +totallyAbstractTyConRhs = AbstractTyCon False + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon { + data_cons = cons, + is_enum = not (null cons) && all is_enum_con cons + -- See Note [Enumeration types] in TyCon + } + where + is_enum_con con + | (_tvs, theta, arg_tys, _res) <- dataConSig con + = null theta && null arg_tys + + +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- ^ Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = co_tycon } ) } + -- Coreview looks through newtypes with a Nothing + -- for nt_co, or uses explicit coercions otherwise + where + tvs = tyConTyVars tycon + roles = tyConRoles tycon + inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs) + rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty + -- Instantiate the data con with the + -- type variables from the tycon + -- NB: a newtype DataCon has a type that must look like + -- forall tvs. -> T tvs + -- Note that we *can't* use dataConInstOrigArgTys here because + -- the newtype arising from class Foo a => Bar a where {} + -- has a single argument (Foo a) that is a *type class*, so + -- dataConInstOrigArgTys returns []. + + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty + + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) + + +------------------------------------------------------ +buildDataCon :: FamInstEnvs + -> Name -> Bool + -> [HsBang] + -> [Name] -- Field labels + -> [TyVar] -> [TyVar] -- Univ and ext + -> [(TyVar,Type)] -- Equality spec + -> ThetaType -- Does not include the "stupid theta" + -- or the GADT equalities + -> [Type] -> Type -- Argument and result types + -> TyCon -- Rep tycon + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls + univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon + = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc + ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space + + ; us <- newUniqueSupply + ; dflags <- getDynFlags + ; let + stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + data_con = mkDataCon src_name declared_infix + arg_stricts field_lbls + univ_tvs ex_tvs eq_spec ctxt + arg_tys res_ty rep_tycon + stupid_ctxt dc_wrk dc_rep + dc_wrk = mkDataConWorkId work_name data_con + dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con) + + ; return data_con } + + +-- The stupid context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta tycon arg_tys univ_tvs + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta + where + tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ + tyVarsOfType pred `intersectVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool + -> (Id,Bool) -> Maybe (Id, Bool) + -> ([TyVar], ThetaType) -- ^ Univ and req + -> ([TyVar], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> PatSyn +buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty + = ASSERT((and [ univ_tvs == univ_tvs' + , ex_tvs == ex_tvs' + , pat_ty `eqType` pat_ty' + , prov_theta `eqTypes` prov_theta' + , req_theta `eqTypes` req_theta' + , arg_tys `eqTypes` arg_tys' + ])) + mkPatSyn src_name declared_infix + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty + matcher builder + where + ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id + ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma + (arg_tys', _) = tcSplitFunTys cont_tau + +-- ------------------------------------------------------ + +type TcMethInfo = (Name, DefMethSpec, Type) + -- A temporary intermediate, to communicate between + -- tcClassSigs and buildClass. + +buildClass :: Name -> [TyVar] -> [Role] -> ThetaType + -> [FunDep TyVar] -- Functional dependencies + -> [ClassATItem] -- Associated types + -> [TcMethInfo] -- Method info + -> ClassMinimalDef -- Minimal complete definition + -> RecFlag -- Info for type constructor + -> TcRnIf m n Class + +buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc + -- The class name is the 'parent' for this datacon, not its tycon, + -- because one should import the class to get the binding for + -- the datacon + + + ; op_items <- mapM (mk_op_item rec_clas) sig_stuff + -- Build the selector id and default method id + + -- Make selectors for the superclasses + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) + [1..length sc_theta] + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas + | sc_name <- sc_sel_names] + -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; let use_newtype = isSingleton arg_tys + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) that value is of lifted type (which they always are, because + -- we box equality superclasses) + -- See note [Class newtypes and equality predicates] + + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of + -- class C a => D a + -- we don't get a newtype with no arguments! + args = sc_sel_names ++ op_names + op_tys = [ty | (_,_,ty) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + arg_tys = sc_theta ++ op_tys + rec_tycon = classTyCon rec_clas + + ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + datacon_name + False -- Not declared infix + (map (const HsNoBang) args) + [{- No fields -}] + tvs [{- no existentials -}] + [{- No GADT equalities -}] + [{- No theta -}] + arg_tys + (mkTyConApp rec_tycon (mkTyVarTys tvs)) + rec_tycon + + ; rhs <- if use_newtype + then mkNewTyConRhs tycon_name rec_tycon dict_con + else return (mkDataTyConRhs [dict_con]) + + ; let { clas_kind = mkPiKinds tvs constraintKind + + ; tycon = mkClassTyCon tycon_name clas_kind tvs roles + rhs rec_clas tc_isrec + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite + -- type] + + ; result = mkClass tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + } + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + where + mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem + mk_op_item rec_clas (op_name, dm_spec, _) + = do { dm_info <- case dm_spec of + NoDM -> return NoDefMeth + GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc + ; return (GenDefMeth dm_name) } + VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc + ; return (DefMeth dm_name) } + ; return (mkDictSelId op_name rec_clas, dm_info) } + +{- +Note [Class newtypes and equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class (a ~ F b) => C a b where + op :: a -> b + +We cannot represent this by a newtype, even though it's not +existential, because there are two value fields (the equality +predicate and op. See Trac #2238 + +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. +-} diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs new file mode 100644 index 00000000..ca8cf28a --- /dev/null +++ b/compiler/iface/FlagChecker.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | This module manages storing the various GHC option flags in a modules +-- interface file as part of the recompilation checking infrastructure. +module FlagChecker ( + fingerprintDynFlags + ) where + +import Binary +import BinIface () +import DynFlags +import HscTypes +import Module +import Name +import Fingerprint +-- import Outputable + +import qualified Data.IntSet as IntSet +import System.FilePath (normalise) + +-- | Produce a fingerprint of a @DynFlags@ value. We only base +-- the finger print on important fields in @DynFlags@ so that +-- the recompilation checker can use this fingerprint. +fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ()) + -> IO Fingerprint + +fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = + let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing + -- see #5878 + -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) + safeHs = setSafeMode safeHaskell + -- oflags = sort $ filter filterOFlags $ flags dflags + + -- *all* the extension flags and the language + lang = (fmap fromEnum language, + IntSet.toList $ extensionFlags) + + -- -I, -D and -U flags affect CPP + cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags) + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + + -- Note [path flags and recompilation] + paths = [ hcSuf ] + + -- -fprof-auto etc. + prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 + + in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $ + computeFingerprint nameio (mainis, safeHs, lang, cpp, paths, prof) + + +{- Note [path flags and recompilation] + +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs new file mode 100644 index 00000000..efd4956b --- /dev/null +++ b/compiler/iface/IfaceEnv.hs @@ -0,0 +1,315 @@ +-- (c) The University of Glasgow 2002-2006 + +{-# LANGUAGE CPP, RankNTypes #-} + +module IfaceEnv ( + newGlobalBinder, newImplicitBinder, + lookupIfaceTop, + lookupOrig, lookupOrigNameCache, extendNameCache, + newIfaceName, newIfaceNames, + extendIfaceIdEnv, extendIfaceTyVarEnv, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar, + + ifaceExportNames, + + -- Name-cache stuff + allocateGlobalBinder, initNameCache, updNameCache, + getNameCache, mkNameCacheUpdater, NameCacheUpdater(..) + ) where + +#include "HsVersions.h" + +import TcRnMonad +import TysWiredIn +import HscTypes +import Type +import Var +import Name +import Avail +import Module +import UniqFM +import FastString +import UniqSupply +import SrcLoc +import Util + +import Outputable +import Exception ( evaluate ) + +import Data.IORef ( atomicModifyIORef, readIORef ) + +{- +********************************************************* +* * + Allocating new Names in the Name Cache +* * +********************************************************* + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invovcation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. +-} + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name +-- Used for source code and interface files, to make the +-- Name for a thing, given its Module and OccName +-- See Note [The Name Cache] +-- +-- The cache may already already have a binding for this thing, +-- because we may have seen an occurrence before, but now is the +-- moment when we know its Module and SrcLoc in their full glory + +newGlobalBinder mod occ loc + = do mod `seq` occ `seq` return () -- See notes with lookupOrig +-- traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) + updNameCache $ \name_cache -> + allocateGlobalBinder name_cache mod occ loc + +allocateGlobalBinder + :: NameCache + -> Module -> OccName -> SrcSpan + -> (NameCache, Name) +-- See Note [The Name Cache] +allocateGlobalBinder name_supply mod occ loc + = case lookupOrigNameCache (nsNames name_supply) mod occ of + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. + -- + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name + -> (name_supply, name) + | otherwise + -> (new_name_supply, name') + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ loc + -- name' is like name, but with the right SrcSpan + new_cache = extendNameCache (nsNames name_supply) mod occ name' + new_name_supply = name_supply {nsNames = new_cache} + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + _ -> (new_name_supply, name) + where + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) + name = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in BuildTyCl to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache +newImplicitBinder base_name mk_sys_occ + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + loc = nameSrcSpan base_name + +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] +ifaceExportNames exports = return exports + +lookupOrig :: Module -> OccName -> TcRnIf a b Name +lookupOrig mod occ + = do { -- First ensure that mod and occ are evaluated + -- If not, chaos can ensue: + -- we read the name-cache + -- then pull on mod (say) + -- which does some stuff that modifies the name cache + -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) + mod `seq` occ `seq` return () +-- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + + ; updNameCache $ \name_cache -> + case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> (name_cache, name); + Nothing -> + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) + }}} + +{- +************************************************************************ +* * + Name cache access +* * +************************************************************************ + +See Note [The Name Cache] above. + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that usin isBuiltInOcc_maybe in lookupOrigNameCache is +unnecessary because tuple TyCon/DataCons are parsed as Exact RdrNames +and *don't* appear as original names in interface files (because +serialization gives them special treatment), so we will never look +them up in the original name cache. + +However, there are two reasons why we might look up an Orig RdrName: + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (DsMeta.globalVar), and parses a NameG into an Orig RdrName + (Convert.thRdrName). So, eg $(do { reify '(,); ... }) will + go this route (Trac #8954). +-} + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +getNameCache :: TcRnIf a b NameCache +getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; + readMutVar nc_var } + +updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c +updNameCache upd_fn = do + HscEnv { hsc_NC = nc_var } <- getTopEnv + atomicUpdMutVar' nc_var upd_fn + +-- | A function that atomically updates the name cache given a modifier +-- function. The second result of the modifier function will be the result +-- of the IO action. +newtype NameCacheUpdater = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } + +-- | Return a function to atomically update the name cache. +mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater +mkNameCacheUpdater = do + nc_var <- hsc_NC `fmap` getTopEnv + let update_nc f = do r <- atomicModifyIORef nc_var f + _ <- evaluate =<< readIORef nc_var + return r + return (NCU update_nc) + +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names + +{- +************************************************************************ +* * + Type variables and local Ids +* * +************************************************************************ +-} + +tcIfaceLclId :: FastString -> IfL Id +tcIfaceLclId occ + = do { lcl <- getLclEnv + ; case (lookupUFM (if_id_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) + } + +extendIfaceIdEnv :: [Id] -> IfL a -> IfL a +extendIfaceIdEnv ids thing_inside + = do { env <- getLclEnv + ; let { id_env' = addListToUFM (if_id_env env) pairs + ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + + +tcIfaceTyVar :: FastString -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; case (lookupUFM (if_tv_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) + } + +lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar) +lookupIfaceTyVar occ + = do { lcl <- getLclEnv + ; return (lookupUFM (if_tv_env lcl) occ) } + +extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a +extendIfaceTyVarEnv tyvars thing_inside + = do { env <- getLclEnv + ; let { tv_env' = addListToUFM (if_tv_env env) pairs + ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } + ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } + +{- +************************************************************************ +* * + Getting from RdrNames to Names +* * +************************************************************************ +-} + +lookupIfaceTop :: OccName -> IfL Name +-- Look up a top-level name from the current Iface module +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } + +newIfaceName :: OccName -> IfL Name +newIfaceName occ + = do { uniq <- newUnique + ; return $! mkInternalName uniq occ noSrcSpan } + +newIfaceNames :: [OccName] -> IfL [Name] +newIfaceNames occs + = do { uniqs <- newUniqueSupply + ; return [ mkInternalName uniq occ noSrcSpan + | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs new file mode 100644 index 00000000..cc40eb2e --- /dev/null +++ b/compiler/iface/IfaceSyn.hs @@ -0,0 +1,1858 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP #-} + +module IfaceSyn ( + module IfaceType, + + IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, + IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceBang(..), IfaceAxBranch(..), + IfaceTyConParent(..), + + -- Misc + ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, + + -- Free Names + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + + -- Pretty printing + pprIfaceExpr, + pprIfaceDecl, + ShowSub(..), ShowHowMuch(..) + ) where + +#include "HsVersions.h" + +import IfaceType +import PprCore() -- Printing DFunArgs +import Demand +import Class +import NameSet +import CoAxiom ( BranchIndex, Role ) +import Name +import CostCentre +import Literal +import ForeignCall +import Annotations( AnnPayload, AnnTarget ) +import BasicTypes +import Outputable +import FastString +import Module +import SrcLoc +import Fingerprint +import Binary +import BooleanFormula ( BooleanFormula ) +import HsBinds +import TyCon (Role (..)) +import StaticFlags (opt_PprStyle_Debug) +import Util( filterOut ) +import InstEnv + +import Control.Monad +import System.IO.Unsafe +import Data.Maybe (isJust) + +infixl 3 &&& + +{- +************************************************************************ +* * + Declarations +* * +************************************************************************ +-} + +type IfaceTopBndr = OccName + -- It's convenient to have an OccName in the IfaceSyn, altough in each + -- case the namespace is implied by the context. However, having an + -- OccNames makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + +data IfaceDecl + = IfaceId { ifName :: IfaceTopBndr, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI + ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data/data family info + ifRec :: RecFlag, -- Recursive or not? + ifPromotable :: Bool, -- Promotable to kind level? + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance + } + + | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of + -- the tycon) + ifSynRhs :: IfaceType } + + | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFamKind :: IfaceKind, -- Kind of the *rhs* (not of + -- the tycon) + ifFamFlav :: IfaceFamTyConFlav } + + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: IfaceTopBndr, -- Name of the class TyCon + ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName, -- Minimal complete definition + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? + } + + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name + ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom + ifAxBranches :: [IfaceAxBranch] -- Branches + } + + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym + ifPatIsInfix :: Bool, + ifPatMatcher :: (IfExtName, Bool), + ifPatBuilder :: Maybe (IfExtName, Bool), + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl + ifPatUnivTvs :: [IfaceTvBndr], + ifPatExTvs :: [IfaceTvBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceType], + ifPatTy :: IfaceType } + + +data IfaceTyConParent + = IfNoParent + | IfDataInstance IfExtName + IfaceTyCon + IfaceTcArgs + +data IfaceFamTyConFlav + = IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + [IfaceAxBranch] -- for pretty printing purposes only + | IfaceAbstractClosedSynFamilyTyCon + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only + +data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method + +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + + +-- This is just like CoAxBranch +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbLHS :: IfaceTcArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in CoAxiom + +data IfaceConDecls + = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon + | IfDataFamTyCon -- Data family + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls + +data IfaceConDecl + = IfCon { + ifConOcc :: IfaceTopBndr, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + ifConEqSpec :: IfaceEqSpec, -- Equality constraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels) + ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + +type IfaceEqSpec = [(IfLclName,IfaceType)] + +data IfaceBang -- This corresponds to an HsImplBang; that is, the final + -- implementation decision about the data constructor arg + = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion + +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +-- The ifFamInstTys field of IfaceFamInst contains a list of the rough +-- match types +data IfaceFamInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: AnnPayload + } + +type IfaceAnnTarget = AnnTarget OccName + +-- Here's a tricky case: +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * When we read in old A.hi we read in its IdInfo (as a thunk) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) +-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] + | HsNoCafRefs + +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +data IfaceUnfolding + = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + -- Possibly could eliminate the Bool here, the information + -- is also in the InlinePragma. + + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + + | IfInlineRule Arity -- INLINE pragmas + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + + +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId IfaceTyCon Bool + | IfDFunId Int -- Number of silent args + +{- +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] + + +************************************************************************ +* * + Functions over declarations +* * +************************************************************************ +-} + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls (IfAbstractTyCon {}) = [] +visibleIfConDecls IfDataFamTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in HscTypes + +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] + +-- Newtype +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ })}) + = -- implicit newtype coercion + (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit + -- data constructor and worker (newtypes don't have a wrapper) + [con_occ, mkDataConWorkerOcc con_occ] + + +ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ, + ifCons = IfDataTyCon cons }) + = -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper + concatMap dc_occs cons + where + dc_occs con_decl + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! + +ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, + ifSigs = sigs, ifATs = ats }) + = -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [ifName at | IfaceAT at _ <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [op | IfaceClassOp op _ _ <- sigs] + where + n_ctxt = length sc_ctxt + n_sigs = length sigs + co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + +ifaceDeclImplicitBndrs _ = [] + +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (ifName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = + unsafeDupablePerformIO + . computeFingerprint (panic "ifaceDeclFingerprints") + +{- +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceLamBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan String -- from SourceNote + -- no breakpoints: we never export these into interface files + +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefault + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal + +data IfaceBinding + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfaceSyn an IfaceCase does not record the types of the alternatives, +unlike CorSyn Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. + +In general we retain all info that is left by CoreTidy.tidyLetBndr, since +that is what is seen by importing module with --make + + +************************************************************************ +* * + Printing IfaceDecl +* * +************************************************************************ +-} + +pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = hang (pprUserIfaceForAll tvs) + 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 2 maybe_incomps + where + pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) + maybe_incomps = ppUnless (null incomps) $ parens $ + ptext (sLit "incompatible indices:") <+> ppr incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance HasOccName IfaceClassOp where + occName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceConDecl where + occName = ifConOcc + +instance HasOccName IfaceDecl where + occName = ifName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showAll + +data ShowSub + = ShowSub + { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl + -- See Note [Printing IfaceDecl binders] + , ss_how_much :: ShowHowMuch } + +data ShowHowMuch + = ShowHeader -- Header information only, not rhs + | ShowSome [OccName] -- [] <=> Print all sub-components + -- (n:ns) <=> print sub-component 'n' with ShowSub=ns + -- elide other sub-components to "..." + -- May 14: the list is max 1 element long at the moment + | ShowIface -- Everything including GHC-internal information (used in --show-iface) + +showAll :: ShowSub +showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = Outputable.empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = Outputable.empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True + +{- +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. +-} + +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in PprTyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifTyVars = tc_tyvars, + ifRoles = roles, ifCons = condecls, + ifParent = parent, ifRec = isrec, + ifGadtSyntax = gadt, + ifPromotable = is_prom }) + + | gadt_style = vcat [ pp_roles + , pp_nd <+> pp_lhs <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + + gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where") + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars + _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = Outputable.empty + | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) + tc_tyvars roles + -- Don't display roles for data family instances (yet) + -- See discussion on Trac #8672. + + add_bars [] = Outputable.empty + add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc + | otherwise = Nothing + + mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) + | otherwise + = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) + where + gadt_subst = mkFsEnv eq_spec + done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) + con_univ_tvs = filterOut done_univ_tv tc_tyvars + + ppr_tc_app gadt_subst dflags + = pprPrefixIfDeclBndr ss tycon + <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) + | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ] + + pp_nd = case condecls of + IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) + IfDataFamTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + + pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] + + pp_prom | is_prom = ptext (sLit "Promotable") + | otherwise = Outputable.empty + + +pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec + , ifCtxt = context, ifName = clas + , ifTyVars = tyvars, ifRoles = roles + , ifFDs = fds }) + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles + , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars + <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + pprec = ppShowIface ss (pprRec isrec) + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + +pprIfaceDecl ss (IfaceSynonym { ifName = tc + , ifTyVars = tv + , ifSynRhs = mono_ty }) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals) + 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + +pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars + , ifFamFlav = rhs, ifFamKind = kind }) + = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon) + 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) + , ppShowRhs ss (nest 2 (pp_branches rhs)) ] + where + pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) + pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) + pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where") + pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) + pp_rhs _ = panic "pprIfaceDecl syn" + + pp_branches (IfaceClosedSynFamilyTyCon ax brs) + = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) + $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) + pp_branches _ = Outputable.empty + +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder, + ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = arg_tys, + ifPatTy = pat_ty} ) + = pprPatSynSig name is_bidirectional + (pprUserIfaceForAll tvs) + (pprIfaceContextMaybe prov_ctxt) + (pprIfaceContextMaybe req_ctxt) + (pprIfaceType ty) + where + is_bidirectional = isJust builder + tvs = univ_tvs ++ ex_tvs + ty = foldr IfaceFunTy pat_ty arg_tys + +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon) + 2 (pprIfaceSigmaType ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) + 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + + +pprCType :: Maybe CType -> SDoc +pprCType Nothing = Outputable.empty +pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType + +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc +pprRoles suppress_if tyCon tyvars roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceKinds dflags tyvars roles + in ppUnless (all suppress_if roles || null froles) $ + ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) + +pprRec :: RecFlag -> SDoc +pprRec NonRecursive = Outputable.empty +pprRec Recursive = ptext (sLit "RecFlag: Recursive") + +pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = pprInfixVar (isSymOcc occ) (ppr_bndr occ) +pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = parenSymOcc occ (ppr_bndr occ) + +instance Outputable IfaceClassOp where + ppr = pprIfaceClassOp showAll + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty) + where opHdr = pprPrefixIfDeclBndr ss n + <+> ppShowIface ss (ppr dm) <+> dcolon + +instance Outputable IfaceAT where + ppr = pprIfaceAT showAll + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> Outputable.empty + Just rhs -> nest 2 $ + ptext (sLit "Default:") <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = Outputable.empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = sdocWithDynFlags $ \dflags -> + let ftys = stripKindArgs dflags tys + in pprIfaceTypeApp tc ftys + +pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context ss tc_occ tv_bndrs + = sdocWithDynFlags $ \ dflags -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr ss tc_occ + <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ] + +isVanillaIfaceConDecl :: IfaceConDecl -> Bool +isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs + , ifConEqSpec = eq_spec + , ifConCtxt = ctxt }) + = (null ex_tvs) && (null eq_spec) && (null ctxt) + +pprIfaceConDecl :: ShowSub -> Bool + -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc)) + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style mk_user_con_res_ty + (IfCon { ifConOcc = name, ifConInfix = is_infix, + ifConExTvs = ex_tvs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = stricts, ifConFields = labels }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty + | otherwise = ppr_fields tys_w_strs + where + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + pp_prefix_con = pprPrefixIfDeclBndr ss name + + (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec + ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" + + ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}") + ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <> + pprParendIfaceCoercion co + + pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty + pprBangTy (bang, ty) = ppr_bang bang <> ppr ty + + maybe_show_label (lbl,bty) + | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) + | otherwise = Nothing + + ppr_fields [ty1, ty2] + | is_infix && null labels + = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2] + ppr_fields fields + | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields) + | otherwise = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $ + map maybe_show_label (zip labels fields)) + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + = sep [hsep [doubleQuotes (ftext name), ppr act, + ptext (sLit "forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + ptext (sLit "=") <+> ppr rhs]) + ] + +instance Outputable IfaceClsInst where + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext (sLit "instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr dfun_id) + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax}) + = hang (ptext (sLit "family instance") <+> + ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) + 2 (equals <+> ppr tycon_ax) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc + +{- +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. + +----------------------------- Printing IfaceExpr ------------------------------------ +-} + +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) + +pprIfaceExpr add_par i@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut + , ptext (sLit "ret_ty") <+> pprParendIfaceType ty + , ptext (sLit "of {}") ]) + +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext (sLit "case") + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext (sLit "case") + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr _ (IfaceCast expr co) + = sep [pprParendIfaceExpr expr, + nest 2 (ptext (sLit "`cast`")), + pprParendIfaceCoercion co] + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [ptext (sLit "let {"), + nest 2 (ppr_bind (b, rhs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [ptext (sLit "letrec {"), + nest 2 (sep (map ppr_bind pairs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceTick tickish e) + = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) + +ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc +ppr_bind (IfLetBndr b ty info, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceTickish :: IfaceTickish -> SDoc +pprIfaceTickish (IfaceHpcTick m ix) + = braces (text "tick" <+> ppr m <+> ppr ix) +pprIfaceTickish (IfaceSCC cc tick scope) + = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) +pprIfaceTickish (IfaceSource src _names) + = braces (pprUserRealSpan True src) + +------------------ +pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) + +------------------ +instance Outputable IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + +------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = Outputable.empty + ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc + <+> if b + then ptext (sLit "") + else Outputable.empty + ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) + +instance Outputable IfaceIdInfo where + ppr NoInfo = Outputable.empty + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is + <+> ptext (sLit "-}") + +instance Outputable IfaceInfoItem where + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") + <> ppWhen lb (ptext (sLit "(loop-breaker)")) + <> colon <+> ppr unf + ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag + ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity + ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str + ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s + then ptext (sLit "") + else Outputable.empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) + +{- +************************************************************************ +* * + Finding the Names in IfaceSyn +* * +************************************************************************ + +This is used for dependency analysis in MkIface, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +-} + +freeNamesIfDecl :: IfaceDecl -> NameSet +freeNamesIfDecl (IfaceId _s t d i) = + freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d +freeNamesIfDecl d@IfaceData{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfaceTyConParent (ifParent d) &&& + freeNamesIfContext (ifCtxt d) &&& + freeNamesIfConDecls (ifCons d) +freeNamesIfDecl d@IfaceSynonym{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfType (ifSynRhs d) &&& + freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we + -- return names in the kind signature +freeNamesIfDecl d@IfaceFamily{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfFamFlav (ifFamFlav d) &&& + freeNamesIfKind (ifFamKind d) -- IA0_NOTE: because of promotion, we + -- return names in the kind signature +freeNamesIfDecl d@IfaceClass{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfContext (ifCtxt d) &&& + fnList freeNamesIfAT (ifATs d) &&& + fnList freeNamesIfClsSig (ifSigs d) +freeNamesIfDecl d@IfaceAxiom{} = + freeNamesIfTc (ifTyCon d) &&& + fnList freeNamesIfAxBranch (ifAxBranches d) +freeNamesIfDecl d@IfacePatSyn{} = + unitNameSet (fst (ifPatMatcher d)) &&& + maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&& + freeNamesIfTvBndrs (ifPatUnivTvs d) &&& + freeNamesIfTvBndrs (ifPatExTvs d) &&& + freeNamesIfContext (ifPatProvCtxt d) &&& + freeNamesIfContext (ifPatReqCtxt d) &&& + fnList freeNamesIfType (ifPatArgs d) &&& + freeNamesIfType (ifPatTy d) + +freeNamesIfAxBranch :: IfaceAxBranch -> NameSet +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) = + freeNamesIfTvBndrs tyvars &&& + freeNamesIfTcArgs lhs &&& + freeNamesIfType rhs + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc +freeNamesIfIdDetails _ = emptyNameSet + +-- All other changes are handled via the version info on the tycon +freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon ax br) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfType + +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl mb_def) + = freeNamesIfDecl decl &&& + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl c + = freeNamesIfTvBndrs (ifConExTvs c) &&& + freeNamesIfContext (ifConCtxt c) &&& + fnList freeNamesIfType (ifConArgTys c) &&& + fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints + +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + +freeNamesIfTcArgs :: IfaceTcArgs -> NameSet +freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts +freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks +freeNamesIfTcArgs ITC_Nil = emptyNameSet + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceTyConApp tc ts) = + freeNamesIfTc tc &&& freeNamesIfTcArgs ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet +freeNamesIfType (IfaceForAllTy tv t) = + freeNamesIfTvBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t +freeNamesIfCoercion (IfaceFunCo _ c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo tv co) + = freeNamesIfTvBndr tv &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceCoVarCo _) + = emptyNameSet +freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) + = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2) + = freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceNthCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co ty) + = freeNamesIfCoercion co &&& freeNamesIfType ty +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceAxiomRuleCo _ax tys cos) + -- the axiom is just a string, so we don't count it as a name. + = fnList freeNamesIfType tys &&& + fnList freeNamesIfCoercion cos + +freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet +freeNamesIfTvBndrs = fnList freeNamesIfTvBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfLetBndr :: IfaceLetBndr -> NameSet +-- Remember IfaceLetBndr is used only for *nested* bindings +-- The IdInfo can contain an unfolding (in the case of +-- local INLINE pragmas), so look there too +freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr = freeNamesIfTvBndr + +freeNamesIfIdInfo :: IfaceIdInfo -> NameSet +freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i + +freeNamesItem :: IfaceInfoItem -> NameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co +freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as +freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body +freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co +freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts + where + fn_alt (_con,_bs,r) = freeNamesIfExpr r + + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body + +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs + +freeNamesIfExpr _ = emptyNameSet + +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) +-- ToDo: shouldn't we include IfaceIntTc & co.? + +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName + +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys + +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSet + +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f + +{- +Note [Tracking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case expression + case e of { C a -> ...; ... } +You might think that we don't need to include the datacon C +in the free names, because its type will probably show up in +the free names of 'e'. But in rare circumstances this may +not happen. Here's the one that bit me: + + module DynFlags where + import {-# SOURCE #-} Packages( PackageState ) + data DynFlags = DF ... PackageState ... + + module Packages where + import DynFlags + data PackageState = PS ... + lookupModule (df :: DynFlags) + = case df of + DF ...p... -> case p of + PS ... -> ... + +Now, lookupModule depends on DynFlags, but the transitive dependency +on the *locally-defined* type PackageState is not visible. We need +to take account of the use of the data constructor PS in the pattern match. + + +************************************************************************ +* * + Binary instances +* * +************************************************************************ +-} + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + put_ bh (occNameFS name) + put_ bh ty + put_ bh details + put_ bh idinfo + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 2 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte bh 3 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceFamily a1 a2 a3 a4) = do + putByte bh 4 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 5 + put_ bh a1 + put_ bh (occNameFS a2) + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 6 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 7 + put_ bh (occNameFS name) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkVarOccFS name + return (IfaceId occ ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + 3 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceSynonym occ a2 a3 a4 a5) + 4 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceFamily occ a2 a3 a4) + 5 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + occ <- return $! mkClsOccFS a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) + 6 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceAxiom occ a2 a3 a4) + 7 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkDataOccFS a1 + return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +instance Binary IfaceFamTyConFlav where + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax + >> put_ bh br + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceOpenSynFamilyTyCon + 1 -> do { ax <- get bh + ; br <- get bh + ; return (IfaceClosedSynFamilyTyCon ax br) } + _ -> return IfaceAbstractClosedSynFamilyTyCon } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n def ty) = do + put_ bh (occNameFS n) + put_ bh def + put_ bh ty + get bh = do + n <- get bh + def <- get bh + ty <- get bh + occ <- return $! mkVarOccFS n + return (IfaceClassOp occ def ty) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5) + +instance Binary IfaceConDecls where + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + put_ bh IfDataFamTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> liftM IfAbstractTyCon $ get bh + 1 -> return IfDataFamTyCon + 2 -> liftM IfDataTyCon $ get bh + _ -> liftM IfNewTyCon $ get bh + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> do { n <- get bh; return (IfDFunId n) } + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + _ -> return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam (ae, os) af) = do + putByte bh 4 + put_ bh ae + put_ bh os + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + os <- get bh + af <- get bh + return (IfaceLam (ae, os) af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + put_ bh (IfaceSource src name) = do + putByte bh 2 + put_ bh (srcSpanFile src) + put_ bh (srcSpanStartLine src) + put_ bh (srcSpanStartCol src) + put_ bh (srcSpanEndLine src) + put_ bh (srcSpanEndCol src) + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + 2 -> do file <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + let start = mkRealSrcLoc file sl sc + end = mkRealSrcLoc file el ec + name <- get bh + return (IfaceSource (mkRealSrcSpan start end) name) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs new file mode 100644 index 00000000..b20e6749 --- /dev/null +++ b/compiler/iface/IfaceType.hs @@ -0,0 +1,973 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + +{-# LANGUAGE CPP #-} +module IfaceType ( + IfExtName, IfLclName, + + IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), + IfaceTyLit(..), IfaceTcArgs(..), + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, + + -- Conversion from Type -> IfaceType + toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, + toIfaceContext, toIfaceBndr, toIfaceIdBndr, + toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, + toIfaceTcArgs, + + -- Conversion from IfaceTcArgs -> IfaceType + tcArgsIfaceTypes, + + -- Conversion from Coercion -> IfaceCoercion + toIfaceCoercion, + + -- Printing + pprIfaceType, pprParendIfaceType, + pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs, + pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, + pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + + suppressIfaceKinds, + stripIfaceKindVars, + stripKindArgs, + substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst + ) where + +#include "HsVersions.h" + +import Coercion +import DataCon ( dataConTyCon ) +import TcType +import DynFlags +import TypeRep +import Unique( hasKey ) +import Util ( filterOut, lengthIs, zipWithEqual ) +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import Id +import Var +-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) +import TysWiredIn +import TysPrim +import PrelNames( funTyConKey, ipClassName ) +import Name +import BasicTypes +import Binary +import Outputable +import FastString +import UniqSet +import Data.Maybe( fromMaybe ) + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +type IfLclName = FastString -- A local name in iface syntax + +type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn + -- (However Internal or System Names never should) + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr + | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + +type IfaceIdBndr = (IfLclName, IfaceType) +type IfaceTvBndr = (IfLclName, IfaceKind) + + +data IfaceOneShot -- see Note [Preserve OneShotInfo] + = IfaceNoOneShot + | IfaceOneShot + +type IfaceLamBndr + = (IfaceBndr, IfaceOneShot) + +------------------------------- +type IfaceKind = IfaceType + +data IfaceType -- A kind of universal type, used for types and kinds + = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceAppTy IfaceType IfaceType + | IfaceFunTy IfaceType IfaceType + | IfaceDFunTy IfaceType IfaceType + | IfaceForAllTy IfaceTvBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceLitTy IfaceTyLit + +type IfacePredType = IfaceType +type IfaceContext = [IfacePredType] + +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString + +-- See Note [Suppressing kinds] +-- We use a new list type (rather than [(IfaceType,Bool)], because +-- it'll be more compact and faster to parse in interface +-- files. Rather than two bytes and two decisions (nil/cons, and +-- type/kind) there'll just be one. +data IfaceTcArgs + = ITC_Nil + | ITC_Type IfaceType IfaceTcArgs + | ITC_Kind IfaceKind IfaceTcArgs + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon + = IfaceTc { ifaceTyConName :: IfExtName } + | IfacePromotedDataCon { ifaceTyConName :: IfExtName } + | IfacePromotedTyCon { ifaceTyConName :: IfExtName } + +data IfaceCoercion + = IfaceReflCo Role IfaceType + | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceTvBndr IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceUnivCo FastString Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceType + | IfaceSubCo IfaceCoercion + | IfaceAxiomRuleCo IfLclName [IfaceType] [IfaceCoercion] + +{- +************************************************************************ +* * + Functions over IFaceTypes +* * +************************************************************************ +-} + +splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType) +-- Mainly for printing purposes +splitIfaceSigmaTy ty + = (tvs, theta, tau) + where + (tvs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy tv ty) + = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceDFunTy ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho tau = ([], tau) + +suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a] +suppressIfaceKinds dflags tys xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) a@(_:xs) + | isIfaceKindVar k = suppress ks xs + | otherwise = a + +stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr] +stripIfaceKindVars dflags tyvars + | gopt Opt_PrintExplicitKinds dflags = tyvars + | otherwise = filterOut isIfaceKindVar tyvars + +isIfaceKindVar :: IfaceTvBndr -> Bool +isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName +isIfaceKindVar _ = False + +ifTyVarsOfType :: IfaceType -> UniqSet IfLclName +ifTyVarsOfType ty + = case ty of + IfaceTyVar v -> unitUniqSet v + IfaceAppTy fun arg + -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg + IfaceFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceDFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceForAllTy (var,t) ty + -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` + ifTyVarsOfType t + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet + +ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName +ifTyVarsOfArgs args = argv emptyUniqSet args + where + argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts + argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks + argv vs ITC_Nil = vs + +{- +Substitutions on IfaceType. This is only used during pretty-printing to construct +the result type of a GADT, and does not deal with binders (eg IfaceForAll), so +it doesn't need fancy capture stuff. +-} + +type IfaceTySubst = FastStringEnv IfaceType + +mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst +mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +substIfaceType env ty + = go ty + where + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2) + go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2) + go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + +substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs +substIfaceTcArgs env args + = go args + where + go ITC_Nil = ITC_Nil + go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys) + go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv + +{- +************************************************************************ +* * + Functions over IFaceTcArgs +* * +************************************************************************ +-} + +stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs +stripKindArgs dflags tys + | gopt Opt_PrintExplicitKinds dflags = tys + | otherwise = suppressKinds tys + where + suppressKinds c + = case c of + ITC_Kind _ ts -> suppressKinds ts + _ -> c + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +-- See Note [Suppressing kinds] +toIfaceTcArgs tc ty_args + = go (tyConKind tc) ty_args + where + go _ [] = ITC_Nil + go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts) + go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts) + go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) + ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded + +tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] +tcArgsIfaceTypes ITC_Nil = [] +tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts +tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts + +{- +Note [Suppressing kinds] +~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceTcArgs to specify which of the arguments to a type +constructor instantiate a for-all, and which are regular kind args. +This in turn used to control kind-suppression when printing types, +under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds. +For example, given + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted +we want + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + + +************************************************************************ +* * + Functions over IFaceTyCon +* * +************************************************************************ +-} + +--isPromotedIfaceTyCon :: IfaceTyCon -> Bool +--isPromotedIfaceTyCon (IfacePromotedTyCon _) = True +--isPromotedIfaceTyCon _ = False + +{- +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc +pprIfaceInfixApp pp p pp_tc ty1 ty2 + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] + +pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc +pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] + +pprIfaceTvBndr :: IfaceTvBndr -> SDoc +pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil) + | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv +pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind) + +pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc +pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceOneShot where + put_ bh IfaceNoOneShot = do + putByte bh 0 + put_ bh IfaceOneShot = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return IfaceNoOneShot + _ -> do return IfaceOneShot + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceType where + ppr ty = pprIfaceType ty + +pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc +pprIfaceType = ppr_ty TopPrec +pprParendIfaceType = ppr_ty TyConPrec + +ppr_ty :: TyPrec -> IfaceType -> SDoc +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys) +ppr_ty _ (IfaceLitTy n) = ppr_tylit n + -- Function types +ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec FunPrec $ + sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)] + where + ppr_fun_tail (IfaceFunTy ty1 ty2) + = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2 + ppr_fun_tail other_ty + = [arrow <+> pprIfaceType other_ty] + +ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) + = maybeParen ctxt_prec TyConPrec $ + ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2 + +ppr_ty ctxt_prec ty + = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty) + +instance Outputable IfaceTcArgs where + ppr tca = pprIfaceTcArgs tca + +pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc +pprIfaceTcArgs = ppr_tc_args TopPrec +pprParendIfaceTcArgs = ppr_tc_args TyConPrec + +ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc +ppr_tc_args ctx_prec args + = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts + in case args of + ITC_Nil -> empty + ITC_Type t ts -> pprTys t ts + ITC_Kind t ts -> pprTys t ts + +------------------- +ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc +ppr_iface_sigma_type show_foralls_unconditionally ty + = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau) + where + (tvs, theta, tau) = splitIfaceSigmaTy ty + +pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc + +ppr_iface_forall_part :: Outputable a + => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc +ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc + = sep [ if show_foralls_unconditionally + then pprIfaceForAll tvs + else pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +pprIfaceForAll :: [IfaceTvBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + +pprIfaceSigmaType :: IfaceType -> SDoc +pprIfaceSigmaType ty = ppr_iface_sigma_type False ty + +pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocWithDynFlags $ \dflags -> + ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ + pprIfaceForAll tvs + where + tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t)) +------------------- + +-- See equivalent function in TypeRep.lhs +pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_ty TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1) + 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tcname == consDataConName + , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tcname == nilDataConName + = ([], Nothing) + where tcname = ifaceTyConName tc + gather ty = ([], Just ty) + +pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) + +pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc +pprTyTcApp ctxt_prec tc tys dflags + | ifaceTyConName tc == ipClassName + , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys + = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty + + | ifaceTyConName tc == consDataConName + , not (gopt Opt_PrintExplicitKinds dflags) + , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys + = pprIfaceTyList ctxt_prec ty1 ty2 + + | otherwise + = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds + where + tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys + +pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys + +ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + where + n = ifaceTyConName tc + +ppr_iface_tc_app pp ctxt_prec tc tys + | Just (tup_sort, tup_args) <- is_tuple + = pprPromotionQuote tc <> + tupleParens tup_sort (sep (punctuate comma (map (pp TopPrec) tup_args))) + + | not (isSymOcc (nameOccName tc_name)) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) + + | [ty1,ty2] <- tys -- Infix, two arguments; + -- we know nothing of precedence though + = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 + + | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName + = ppr tc -- Do not wrap *, # in parens + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys) + where + tc_name = ifaceTyConName tc + + is_tuple = case wiredInNameTyThing_maybe tc_name of + Just (ATyCon tc) + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + -> Just (sort, tys) + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , isTupleTyCon dc_tc + , let arity = tyConArity dc_tc + ty_args = drop arity tys + , ty_args `lengthIs` arity + -> Just (tupleTyConSort tc, ty_args) + + _ -> Nothing + + +ppr_tylit :: IfaceTyLit -> SDoc +ppr_tylit (IfaceNumTyLit n) = integer n +ppr_tylit (IfaceStrTyLit n) = text (show n) + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co TopPrec +pprParendIfaceCoercion = ppr_co TyConPrec + +ppr_co :: TyPrec -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceFunCo r co1 co2) + = maybeParen ctxt_prec FunPrec $ + sep (ppr_co FunPrec co1 : ppr_fun_tail co2) + where + ppr_fun_tail (IfaceFunCo r co1 co2) + = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2 + ppr_fun_tail other_co + = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec TyConPrec $ + ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo _ _) + = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co]) + where + (tvs, inner_co) = split_co co + ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + + split_co (IfaceForAllCo tv co') + = let (tvs, co'') = split_co co' in (tv:tvs,co'') + split_co co' = ([], co') + +ppr_co _ (IfaceCoVarCo covar) = ppr covar + +ppr_co ctxt_prec (IfaceUnivCo s r ty1 ty2) + = maybeParen ctxt_prec TyConPrec $ + ptext (sLit "UnivCo") <+> ftext s <+> ppr r <+> + pprParendIfaceType ty1 <+> pprParendIfaceType ty2 + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec TyConPrec $ + ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty + +ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos) + = maybeParen ctxt_prec TyConPrec + (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))]) + +ppr_co ctxt_prec co + = ppr_special_co ctxt_prec doc cos + where (doc, cos) = case co of + { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos) + ; IfaceSymCo co -> (ptext (sLit "Sym"), [co]) + ; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2]) + ; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d, + [co]) + ; IfaceLRCo lr co -> (ppr lr, [co]) + ; IfaceSubCo co -> (ptext (sLit "Sub"), [co]) + ; _ -> panic "pprIfaceCo" } + +ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec TyConPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------- +instance Outputable IfaceTyCon where + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote (IfacePromotedDataCon _ ) = char '\'' +pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty + +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh tc = + case tc of + IfaceTc n -> putByte bh 0 >> put_ bh n + IfacePromotedDataCon n -> putByte bh 1 >> put_ bh n + IfacePromotedTyCon n -> putByte bh 2 >> put_ bh n + + get bh = + do tc <- getByte bh + case tc of + 0 -> get bh >>= return . IfaceTc + 1 -> get bh >>= return . IfacePromotedDataCon + 2 -> get bh >>= return . IfacePromotedTyCon + _ -> panic ("get IfaceTyCon " ++ show tc) + +instance Outputable IfaceTyLit where + ppr = ppr_tylit + +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceTcArgs where + put_ bh tk = + case tk of + ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts + ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts + ITC_Nil -> putByte bh 2 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + ts <- get bh + return $! ITC_Type t ts + 1 -> do + t <- get bh + ts <- get bh + return $! ITC_Kind t ts + 2 -> return ITC_Nil + _ -> panic ("get IfaceTcArgs " ++ show c) + +------------------- +pprIfaceContextArr :: Outputable a => [a] -> SDoc +-- Prints "(C a, D b) =>", including the arrow +pprIfaceContextArr = maybe empty (<+> darrow) . pprIfaceContextMaybe + +pprIfaceContext :: Outputable a => [a] -> SDoc +pprIfaceContext = fromMaybe (parens empty) . pprIfaceContextMaybe + +pprIfaceContextMaybe :: Outputable a => [a] -> Maybe SDoc +pprIfaceContextMaybe [] = Nothing +pprIfaceContextMaybe [pred] = Just $ ppr pred -- No parens +pprIfaceContextMaybe preds = Just $ parens (fsep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy ag ah) = do + putByte bh 3 + put_ bh ag + put_ bh ah + put_ bh (IfaceDFunTy ag ah) = do + putByte bh 4 + put_ bh ag + put_ bh ah + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + + put_ bh (IfaceLitTy n) + = do { putByte bh 30; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do ag <- get bh + ah <- get bh + return (IfaceFunTy ag ah) + 4 -> do ag <- get bh + ah <- get bh + return (IfaceDFunTy ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + 30 -> do n <- get bh + return (IfaceLitTy n) + + _ -> panic ("get IfaceType " ++ show h) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (IfaceFunCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 3 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceCoVarCo a) = do + putByte bh 6 + put_ bh a + put_ bh (IfaceAxiomInstCo a b c) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceUnivCo a b c d) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfaceSymCo a) = do + putByte bh 9 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 10 + put_ bh a + put_ bh b + put_ bh (IfaceNthCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceSubCo a) = do + putByte bh 14 + put_ bh a + put_ bh (IfaceAxiomRuleCo a b c) = do + putByte bh 15 + put_ bh a + put_ bh b + put_ bh c + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + b <- get bh + return $ IfaceReflCo a b + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a b c + 3 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 4 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 5 -> do a <- get bh + b <- get bh + return $ IfaceForAllCo a b + 6 -> do a <- get bh + return $ IfaceCoVarCo a + 7 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomInstCo a b c + 8 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return $ IfaceUnivCo a b c d + 9 -> do a <- get bh + return $ IfaceSymCo a + 10-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 11-> do a <- get bh + b <- get bh + return $ IfaceNthCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 14-> do a <- get bh + return $ IfaceSubCo a + 15-> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomRuleCo a b c + _ -> panic ("get IfaceCoercion " ++ show tag) + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +---------------- +toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType) +toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar)) +toIfaceIdBndr :: Id -> (IfLclName, IfaceType) +toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) +toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)] +toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +-- Synonyms are retained in the interface type +toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) +toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (FunTy t1 t2) + | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) + | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) +toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) + +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + | isPromotedDataCon tc = IfacePromotedDataCon tc_name + | isPromotedTyCon tc = IfacePromotedTyCon tc_name + | otherwise = IfaceTc tc_name + where tc_name = tyConName tc + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name = IfaceTc + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + +---------------- +toIfaceTypes :: [Type] -> [IfaceType] +toIfaceTypes ts = map toIfaceType ts + +---------------- +toIfaceContext :: ThetaType -> IfaceContext +toIfaceContext = toIfaceTypes + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty) +toIfaceCoercion (TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res) + | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) + (map toIfaceCoercion cos) +toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v) + (toIfaceCoercion co) +toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) +toIfaceCoercion (AxiomInstCo con ind cos) + = IfaceAxiomInstCo (coAxiomName con) ind + (map toIfaceCoercion cos) +toIfaceCoercion (UnivCo s r ty1 ty2)= IfaceUnivCo s r (toIfaceType ty1) + (toIfaceType ty2) +toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co) +toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co) +toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co) +toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co) + (toIfaceType ty) +toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co) + +toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo + (coaxrName co) + (map toIfaceType ts) + (map toIfaceCoercion cs) diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs new file mode 100644 index 00000000..04953d93 --- /dev/null +++ b/compiler/iface/LoadIface.hs @@ -0,0 +1,1093 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Loading interface files +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module LoadIface ( + -- Importing one thing + tcLookupImported_maybe, importDecl, + checkWiredInTyCon, ifCheckWiredInThing, + + -- RnM/TcM functions + loadModuleInterface, loadModuleInterfaces, + loadSrcInterface, loadSrcInterface_maybe, + loadInterfaceForName, loadInterfaceForModule, + + -- IfM functions + loadInterface, loadWiredInHomeIface, + loadSysInterface, loadUserInterface, loadPluginInterface, + findAndReadIface, readIface, -- Used when reading the module's old interface + loadDecls, -- Should move to TcIface and be renamed + initExternalPackageState, + + ifaceStats, pprModIface, showIface + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, + tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations ) + +import DynFlags +import IfaceSyn +import IfaceEnv +import HscTypes + +import BasicTypes hiding (SuccessFlag(..)) +import TcRnMonad + +import Constants +import PrelNames +import PrelInfo +import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) +import MkId ( seqId ) +import Rules +import TyCon +import Annotations +import InstEnv +import FamInstEnv +import Name +import NameEnv +import Avail +import Module +import Maybes +import ErrUtils +import Finder +import UniqFM +import SrcLoc +import Outputable +import BinIface +import Panic +import Util +import FastString +import Fingerprint +import Hooks + +import Control.Monad +import Data.IORef +import System.FilePath + +{- +************************************************************************ +* * +* tcImportDecl is the key function for "faulting in" * +* imported things +* * +************************************************************************ + +The main idea is this. We are chugging along type-checking source code, and +find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find +it in the EPS type envt. So it + 1 loads GHC.Base.hi + 2 gets the decl for GHC.Base.map + 3 typechecks it via tcIfaceDecl + 4 and adds it to the type env in the EPS + +Note that DURING STEP 4, we may find that map's type mentions a type +constructor that also + +Notice that for imported things we read the current version from the EPS +mutable variable. This is important in situations like + ...$(e1)...$(e2)... +where the code that e1 expands to might import some defns that +also turn out to be needed by the code that e2 expands to. +-} + +tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +tcLookupImported_maybe name + = do { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> tcImportDecl_maybe name } + +tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Entry point for *source-code* uses of importDecl +tcImportDecl_maybe name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceTcRn (importDecl name) + +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) +-- Get the TyThing for this Name from an interface file +-- It's not a wired-in thing -- the caller caught that +importDecl name + = ASSERT( not (isWiredInName name) ) + do { traceIf nd_doc + + -- Load the interface, which should populate the PTE + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded _ -> do + + -- Now look it up again; this time we should find it + { eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return (Succeeded thing) + Nothing -> return (Failed not_found_msg) + }}} + where + nd_doc = ptext (sLit "Need decl for") <+> ppr name + not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+> + pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) + 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"), + ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")]) + + +{- +************************************************************************ +* * + Checks for wired-in things +* * +************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOrphanModules) + +* If the instance decl is not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what LoadIface.loadWiredInHomeInterface does. It's called + from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) +-} + +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in TcUnify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.lhs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False + + +{- +************************************************************************ +* * + loadSrcInterface, loadOrphanModules, loadInterfaceForName + + These three are called from TcM-land +* * +************************************************************************ +-} + +-- Note [Un-ambiguous multiple interfaces] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When a user writes an import statement, this usually causes a *single* +-- interface file to be loaded. However, the game is different when +-- signatures are being imported. Suppose in packages p and q we have +-- signatures: +-- +-- module A where +-- foo :: Int +-- +-- module A where +-- bar :: Int +-- +-- If both packages are exposed and I am importing A, I should see a +-- "unified" signature: +-- +-- module A where +-- foo :: Int +-- bar :: Int +-- +-- The way we achieve this is having the module lookup for A load and return +-- multiple interface files, which we will then process as if there were +-- "multiple" imports: +-- +-- import "p" A +-- import "q" A +-- +-- Doing so does not cause any ambiguity, because any overlapping identifiers +-- are guaranteed to have the same name if the backing implementations of the +-- two signatures are the same (a condition which is checked by 'Packages'.) + + +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +-- See Note [Un-ambiguous multiple interfaces] for why the return type +-- is @[ModIface]@ +loadSrcInterface :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM [ModIface] + +loadSrcInterface doc mod want_boot maybe_pkg + = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg + ; case res of + Failed err -> failWithTc err + Succeeded ifaces -> return ifaces } + +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. See also +-- Note [Un-ambiguous multiple interfaces] +loadSrcInterface_maybe :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM (MaybeErr MsgDoc [ModIface]) + +loadSrcInterface_maybe doc mod want_boot maybe_pkg + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + = do { hsc_env <- getTopEnv + -- ToDo: findImportedModule should return a list of interfaces + ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg + ; case res of + Found _ mod -> fmap (fmap (:[])) + . initIfaceTcRn + $ loadInterface doc mod (ImportByUser want_boot) + err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) } + +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). +loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) + +-- | Load interfaces for a collection of modules. +loadModuleInterfaces :: SDoc -> [Module] -> TcM () +loadModuleInterfaces doc mods + | null mods = return () + | otherwise = initIfaceTcRn (mapM_ load mods) + where + load mod = loadSysInterface (doc <+> parens (ppr mod)) mod + +-- | Loads the interface for a given Name. +-- Should only be called for an imported name; +-- otherwise loadSysInterface may not find the interface +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name + = do { when debugIsOn $ -- Check pre-condition + do { this_mod <- getModule + ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } + ; ASSERT2( isExternalName name, ppr name ) + initIfaceTcRn $ loadSysInterface doc (nameModule name) } + +-- | Loads the interface for a given Module. +loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule doc m + = do + -- Should not be called with this module + when debugIsOn $ do + this_mod <- getModule + MASSERT2( this_mod /= m, ppr m <+> parens doc ) + initIfaceTcRn $ loadSysInterface doc m + +{- +********************************************************* +* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +* * +********************************************************* +-} + +-- | An 'IfM' function to load the home interface for a wired-in thing, +-- so that we're sure that we see its instance declarations and rules +-- See Note [Loading instances for wired-in things] in TcIface +loadWiredInHomeIface :: Name -> IfM lcl () +loadWiredInHomeIface name + = ASSERT( isWiredInName name ) + do _ <- loadSysInterface doc (nameModule name); return () + where + doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name + +------------------ +-- | Loads a system interface and throws an exception if it fails +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +------------------ +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name + = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface doc mod_name + = loadInterfaceWithException doc mod_name ImportByPlugin + +------------------ +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = do { mb_iface <- loadInterface doc mod_name where_from + ; dflags <- getDynFlags + ; case mb_iface of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Succeeded iface -> return iface } + +------------------ +loadInterface :: SDoc -> Module -> WhereFrom + -> IfM lcl (MaybeErr MsgDoc ModIface) + +-- loadInterface looks in both the HPT and PIT for the required interface +-- If not found, it loads it, and puts it in the PIT (always). + +-- If it can't find a suitable interface file, we +-- a) modify the PackageIfaceTable to have an empty entry +-- (to avoid repeated complaints) +-- b) return (Left message) +-- +-- It's not necessarily an error for there not to be an interface +-- file -- perhaps the module has changed, and that interface +-- is no longer used + +loadInterface doc_str mod from + = do { -- Read the state + (eps,hpt) <- getEpsAndHpt + + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) + + -- Check whether we have the interface already + ; dflags <- getDynFlags + ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { + Just iface + -> return (Succeeded iface) ; -- Already loaded + -- The (src_imp == mi_boot iface) test checks that the already-loaded + -- interface isn't a boot iface. This can conceivably happen, + -- if an earlier import had a before we got to real imports. I think. + _ -> do { + + -- READ THE MODULE IN + ; read_result <- case (wantHiBootFile dflags eps mod from) of + Failed err -> return (Failed err) + Succeeded hi_boot_file -> findAndReadIface doc_str mod hi_boot_file + ; case read_result of { + Failed err -> do + { let fake_iface = emptyModIface mod + + ; updateEps_ $ \eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } + -- Not found, so add an empty iface to + -- the EPS map so that we don't look again + + ; return (Failed err) } ; + + -- Found and parsed! + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, file_path) -> + + let + loc_doc = text file_path + in + initIfaceLcl mod loc_doc $ do + + -- Load the new ModIface into the External Package State + -- Even home-package interfaces loaded by loadInterface + -- (which only happens in OneShot mode; in Batch/Interactive + -- mode, home-package modules are loaded one by one into the HPT) + -- are put in the EPS. + -- + -- The main thing is to add the ModIface to the PIT, but + -- we also take the + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo + -- out of the ModIface and put them into the big EPS pools + + -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined + --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). + -- If we do loadExport first the wrong info gets into the cache (unless we + -- explicitly tag each export which seems a bit of a bore) + + ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) + ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface) + + ; let { final_iface = iface { + mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_fam_insts = panic "No mi_fam_insts in PIT", + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" + } + } + + ; updateEps_ $ \ eps -> + if elemModuleEnv mod (eps_PIT eps) then eps else + case from of -- See Note [Care with plugin imports] + ImportByPlugin -> eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls} + _ -> eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) + new_eps_rules, + eps_inst_env = extendInstEnvList (eps_inst_env eps) + new_eps_insts, + eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) + new_eps_fam_insts, + eps_vect_info = plusVectInfo (eps_vect_info eps) + new_eps_vect_info, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, + eps_stats = addEpsInStats (eps_stats eps) + (length new_eps_decls) + (length new_eps_insts) + (length new_eps_rules) } + + ; return (Succeeded final_iface) + }}}} + +wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom + -> MaybeErr MsgDoc IsBootInterface +-- Figure out whether we want Foo.hi or Foo.hi-boot +wantHiBootFile dflags eps mod from + = case from of + ImportByUser usr_boot + | usr_boot && not this_package + -> Failed (badSourceImport mod) + | otherwise -> Succeeded usr_boot + + ImportByPlugin + -> Succeeded False + + ImportBySystem + | not this_package -- If the module to be imported is not from this package + -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! + + | otherwise + -> case lookupUFM (eps_is_boot eps) (moduleName mod) of + Just (_, is_boot) -> Succeeded is_boot + Nothing -> Succeeded False + -- The boot-ness of the requested interface, + -- based on the dependencies in directly-imported modules + where + this_package = thisPackage dflags == modulePackageKey mod + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package")) + 2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package") + <+> quotes (ppr (modulePackageKey mod))) + +{- +Note [Care with plugin imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When dynamically loading a plugin (via loadPluginInterface) we +populate the same External Package State (EPS), even though plugin +modules are to link with the compiler itself, and not with the +compiled program. That's fine: mostly the EPS is just a cache for +the interace files on disk. + +But it's NOT ok for the RULES or instance environment. We do not want +to fire a RULE from the plugin on the code we are compiling, otherwise +the code we are compiling will have a reference to a RHS of the rule +that exists only in the compiler! This actually happened to Daniel, +via a RULE arising from a specialisation of (^) in the plugin. + +Solution: when loading plugins, do not extend the rule and instance +environments. We are only interested in the type environment, so that +we can check that the plugin exports a function with the type that the +compiler expects. +-} + +----------------------------------------------------- +-- Loading type/class/value decls +-- We pass the full Module name here, replete with +-- its package info, so that we can build a Name for +-- each binder with the right package info in it +-- All subsequent lookups, including crucially lookups during typechecking +-- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implicit things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). +----------------------------------------------------- + +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things + +loadDecls :: Bool + -> [(Fingerprint, IfaceDecl)] + -> IfL [(Name,TyThing)] +loadDecls ignore_prags ver_decls + = do { mod <- getIfModule + ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls + ; return (concat thingss) + } + +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> Module + -> (Fingerprint, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks +loadDecl ignore_prags mod (_version, decl) + = do { -- Populate the name cache with final versions of all + -- the names associated with the decl + main_name <- lookupOrig mod (ifName decl) + + -- Typecheck the thing, lazily + -- NB. Firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. + + ; thing <- forkM doc $ do { bumpDeclStats main_name + ; tcIfaceDecl ignore_prags decl } + + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ , ] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> , "x" -> , ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implicit_names to the associated + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implicitTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> , 'x' -> , ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implicitTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of on the way to + -- extracting 's OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- All a bit too finely-balanced for my liking. + + -- This mini-env and lookup function mediates between the + --'Name's n and the map from 'OccName's to the implicit TyThings + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] + lookup n = case lookupOccEnv mini_env (getOccName n) of + Just thing -> thing + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) + + ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) + +-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) + ; return $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implicitTyThings are bijective + [(n, lookup n) | n <- implicit_names] + } + where + doc = ptext (sLit "Declaration for") <+> ppr (ifName decl) + +bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used +bumpDeclStats name + = do { traceIf (text "Loading decl for" <+> ppr name) + ; updateEps_ (\eps -> let stats = eps_stats eps + in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) + } + +{- +********************************************************* +* * +\subsection{Reading an interface file} +* * +********************************************************* + +Note [Home module load error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the sought-for interface is in the current package (as determined +by -package-name flag) then it jolly well should already be in the HPT +because we process home-package modules in dependency order. (Except +in one-shot mode; see notes with hsc_HPT decl in HscTypes). + +It is possible (though hard) to get this error through user behaviour. + * Suppose package P (modules P1, P2) depends on package Q (modules Q1, + Q2, with Q2 importing Q1) + * We compile both packages. + * Now we edit package Q so that it somehow depends on P + * Now recompile Q with --make (without recompiling P). + * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 + is a home-package module which is not yet in the HPT! Disaster. + +This actually happened with P=base, Q=ghc-prim, via the AMP warnings. +See Trac #8320. +-} + +findAndReadIface :: SDoc -> Module + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed + + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface + +findAndReadIface doc_str mod hi_boot_file + = do traceIf (sep [hsep [ptext (sLit "Reading"), + if hi_boot_file + then ptext (sLit "[boot]") + else Outputable.empty, + ptext (sLit "interface for"), + ppr mod <> semi], + nest 4 (ptext (sLit "reason:") <+> doc_str)]) + + -- Check for GHC.Prim, and return its static interface + if mod == gHC_PRIM + then do + iface <- getHooked ghcPrimIfaceHook ghcPrimIface + return (Succeeded (iface, + "")) + else do + dflags <- getDynFlags + -- Look for the file + hsc_env <- getTopEnv + mb_found <- liftIO (findExactModule hsc_env mod) + case mb_found of + Found loc mod -> do + + -- Found file, so read it + let file_path = addBootSuffix_maybe hi_boot_file + (ml_hi_file loc) + + -- See Note [Home module load error] + if thisPackage dflags == modulePackageKey mod && + not (isOneShot (ghcMode dflags)) + then return (Failed (homeModError mod loc)) + else do r <- read_file file_path + checkBuildDynamicToo r + return r + err -> do + traceIf (ptext (sLit "...not found")) + dflags <- getDynFlags + return (Failed (cannotFindInterface dflags + (moduleName mod) err)) + where read_file file_path = do + traceIf (ptext (sLit "readIFace") <+> text file_path) + read_result <- readIface mod file_path + case read_result of + Failed err -> return (Failed (badIfaceFile file_path err)) + Succeeded iface + | mi_module iface /= mod -> + return (Failed (wrongIfaceModErr iface mod file_path)) + | otherwise -> + return (Succeeded (iface, file_path)) + -- Don't forget to fill in the package name... + checkBuildDynamicToo (Succeeded (iface, filePath)) = do + dflags <- getDynFlags + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + let ref = canGenerateDynamicToo dflags + dynFilePath = addBootSuffix_maybe hi_boot_file + $ replaceExtension filePath (dynHiSuf dflags) + r <- read_file dynFilePath + case r of + Succeeded (dynIface, _) + | mi_mod_hash iface == mi_mod_hash dynIface -> + return () + | otherwise -> + do traceIf (text "Dynamic hash doesn't match") + liftIO $ writeIORef ref False + Failed err -> + do traceIf (text "Failed to load dynamic interface file:" $$ err) + liftIO $ writeIORef ref False + checkBuildDynamicToo _ = return () + +-- @readIface@ tries just the one file. + +readIface :: Module -> FilePath + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed + +readIface wanted_mod file_path + = do { res <- tryMostM $ + readBinIface CheckHiWay QuietBinIFaceReading file_path + ; case res of + Right iface + | wanted_mod == actual_mod -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + } + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +initExternalPackageState :: ExternalPackageState +initExternalPackageState + = EPS { + eps_is_boot = emptyUFM, + eps_PIT = emptyPackageIfaceTable, + eps_PTE = emptyTypeEnv, + eps_inst_env = emptyInstEnv, + eps_fam_inst_env = emptyFamInstEnv, + eps_rule_base = mkRuleBase builtinRules, + -- Initialise the EPS rule pool with the built-in rules + eps_mod_fam_inst_env + = emptyModuleEnv, + eps_vect_info = noVectInfo, + eps_ann_env = emptyAnnEnv, + eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 + , n_insts_in = 0, n_insts_out = 0 + , n_rules_in = length builtinRules, n_rules_out = 0 } + } + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +ghcPrimIface :: ModIface +ghcPrimIface + = (emptyModIface gHC_PRIM) { + mi_exports = ghcPrimExports, + mi_decls = [], + mi_fixities = fixities, + mi_fix_fn = mkIfaceFixCache fixities + } + where + fixities = (getOccName seqId, Fixity 0 InfixR) -- seq is infixr 0 + : mapMaybe mkFixity allThePrimOps + mkFixity op = (,) (primOpOcc op) <$> primOpFixity op + +{- +********************************************************* +* * +\subsection{Statistics} +* * +********************************************************* +-} + +ifaceStats :: ExternalPackageState -> SDoc +ifaceStats eps + = hcat [text "Renamer stats: ", msg] + where + stats = eps_stats eps + msg = vcat + [int (n_ifaces_in stats) <+> text "interfaces read", + hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", + int (n_decls_in stats), text "read"], + hsep [ int (n_insts_out stats), text "instance decls imported, out of", + int (n_insts_in stats), text "read"], + hsep [ int (n_rules_out stats), text "rule decls imported, out of", + int (n_rules_in stats), text "read"] + ] + +{- +************************************************************************ +* * + Printing interfaces +* * +************************************************************************ +-} + +-- | Read binary interface, and print it out +showIface :: HscEnv -> FilePath -> IO () +showIface hsc_env filename = do + -- skip the hi way check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + iface <- initTcRnIf 's' hsc_env () () $ + readBinIface IgnoreHiWay TraceBinIFaceReading filename + let dflags = hsc_dflags hsc_env + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface) + +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface + = vcat [ ptext (sLit "interface") + <+> ppr (mi_module iface) <+> pp_boot + <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else Outputable.empty) + <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else Outputable.empty) + <+> (if mi_hpc iface then ptext (sLit "[hpc]") else Outputable.empty) + <+> integer hiVersion + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) + , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) + , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) + , nest 2 (ptext (sLit "where")) + , ptext (sLit "exports:") + , nest 2 (vcat (map pprExport (mi_exports iface))) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , vcat (map pprIfaceAnnotation (mi_anns iface)) + , pprFixities (mi_fixities iface) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_fam_insts iface)) + , vcat (map ppr (mi_rules iface)) + , pprVectInfo (mi_vect_info iface) + , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) + ] + where + pp_boot | mi_boot iface = ptext (sLit "[boot]") + | otherwise = Outputable.empty + +{- +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C +-} + +pprExport :: IfaceExport -> SDoc +pprExport (Avail n) = ppr n +pprExport (AvailTC _ []) = Outputable.empty +pprExport (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + where + pp_export [] = Outputable.empty + pp_export names = braces (hsep (map ppr names)) + +pprUsage :: Usage -> SDoc +pprUsage usage@UsagePackageModule{} + = pprUsageImport usage usg_mod +pprUsage usage@UsageHomeModule{} + = pprUsageImport usage usg_mod_name $$ + nest 2 ( + maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ + vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] + ) +pprUsage usage@UsageFile{} + = hsep [ptext (sLit "addDependentFile"), + doubleQuotes (text (usg_file_path usage))] + +pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc +pprUsageImport usage usg_mod' + = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage), + ppr (usg_mod_hash usage)] + where + safe | usg_safe usage = ptext $ sLit "safe" + | otherwise = ptext $ sLit " -/ " + +pprDeps :: Dependencies -> SDoc +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) + = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods), + ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs), + ptext (sLit "orphans:") <+> fsep (map ppr orphs), + ptext (sLit "family instance modules:") <+> fsep (map ppr finsts) + ] + where + ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_pkg (pkg,trust_req) = ppr pkg <> + (if trust_req then text "*" else Outputable.empty) + ppr_boot True = text "[boot]" + ppr_boot False = Outputable.empty + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = Outputable.empty +pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprVectInfo :: IfaceVectInfo -> SDoc +pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoParallelVars = parallelVars + , ifaceVectInfoParallelTyCons = parallelTyCons + }) = + vcat + [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars) + , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons) + , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse) + , ptext (sLit "parallel variables:") <+> hsep (map ppr parallelVars) + , ptext (sLit "parallel tycons:") <+> hsep (map ppr parallelTyCons) + ] + +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust + +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg + +instance Outputable Warnings where + ppr = pprWarns + +pprWarns :: Warnings -> SDoc +pprWarns NoWarnings = Outputable.empty +pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt +pprWarns (WarnSome prs) = ptext (sLit "Warnings") + <+> vcat (map pprWarning prs) + where pprWarning (name, txt) = ppr name <+> ppr txt + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized + +{- +********************************************************* +* * +\subsection{Errors} +* * +********************************************************* +-} + +badIfaceFile :: String -> SDoc -> SDoc +badIfaceFile file err + = vcat [ptext (sLit "Bad interface file:") <+> text file, + nest 4 err] + +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn requested_mod read_mod = + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ + -- we want the Modules below to be qualified with package names, + -- so reset the PrintUnqualified setting. + hsep [ ptext (sLit "Something is amiss; requested module ") + , ppr requested_mod + , ptext (sLit "differs from name found in the interface file") + , ppr read_mod + ] + +wrongIfaceModErr :: ModIface -> Module -> String -> SDoc +wrongIfaceModErr iface mod_name file_path + = sep [ptext (sLit "Interface file") <+> iface_file, + ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma, + ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name), + sep [ptext (sLit "Probable cause: the source code which generated"), + nest 2 iface_file, + ptext (sLit "has an incompatible module name") + ] + ] + where iface_file = doubleQuotes (text file_path) + +homeModError :: Module -> ModLocation -> SDoc +-- See Note [Home module load error] +homeModError mod location + = ptext (sLit "attempting to use module ") <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> Outputable.empty) + <+> ptext (sLit "which is not loaded") diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs new file mode 100644 index 00000000..94ce378d --- /dev/null +++ b/compiler/iface/MkIface.hs @@ -0,0 +1,2033 @@ +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP, NondecreasingIndentation #-} + +-- | Module for constructing @ModIface@ values (interface files), +-- writing them to disk and comparing two versions to see if +-- recompilation is required. +module MkIface ( + mkUsedNames, + mkDependencies, + mkIface, -- Build a ModIface from a ModGuts, + -- including computing version information + + mkIfaceTc, + + writeIfaceFile, -- Write the interface file + + checkOldIface, -- See if recompilation is required, by + -- comparing version information + RecompileRequired(..), recompileRequired, + + tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) where + +{- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- + +A complete description of how recompilation checking works can be +found in the wiki commentary: + + http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance + +Please read the above page for a top-down description of how this all +works. Notes below cover specific issues related to the implementation. + +Basic idea: + + * In the mi_usages information in an interface, we record the + fingerprint of each free variable of the module + + * In mkIface, we compute the fingerprint of each exported thing A.f. + For each external thing that A.f refers to, we include the fingerprint + of the external reference when computing the fingerprint of A.f. So + if anything that A.f depends on changes, then A.f's fingerprint will + change. + Also record any dependent files added with + * addDependentFile + * #include + * -optP-include + + * In checkOldIface we compare the mi_usages for the module with + the actual fingerprint for all each thing recorded in mi_usages +-} + +#include "HsVersions.h" + +import IfaceSyn +import LoadIface +import FlagChecker + +import Id +import IdInfo +import Demand +import Coercion( tidyCo ) +import Annotations +import CoreSyn +import CoreFVs +import Class +import Kind +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import Type +import TcType +import TysPrim ( alphaTyVars ) +import InstEnv +import FamInstEnv +import TcRnMonad +import HsSyn +import HscTypes +import Finder +import DynFlags +import VarEnv +import VarSet +import Var +import Name +import Avail +import RdrName +import NameEnv +import NameSet +import Module +import BinIface +import ErrUtils +import Digraph +import SrcLoc +import Outputable +import BasicTypes hiding ( SuccessFlag(..) ) +import UniqFM +import Unique +import Util hiding ( eqListBy ) +import FastString +import Maybes +import ListSetOps +import Binary +import Fingerprint +import Bag +import Exception + +import Control.Monad +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord +import Data.IORef +import System.Directory +import System.FilePath + +{- +************************************************************************ +* * +\subsection{Completing an interface} +* * +************************************************************************ +-} + +mkIface :: HscEnv + -> Maybe Fingerprint -- The old fingerprint, if we have it + -> ModDetails -- The trimmed, tidied interface + -> ModGuts -- Usages, deprecations, etc + -> IO (Messages, + Maybe (ModIface, -- The new one + Bool)) -- True <=> there was an old Iface, and the + -- new one is identical, so no need + -- to write it + +mkIface hsc_env maybe_old_fingerprint mod_details + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_safe_haskell = safe_mode, + mg_trust_pkg = self_trust, + mg_dependent_files = dependent_files + } + = mkIface_ hsc_env maybe_old_fingerprint + this_mod is_boot used_names used_th deps rdr_env fix_env + warns hpc_info dir_imp_mods self_trust dependent_files + safe_mode mod_details + +-- | make an interface from the results of typechecking only. Useful +-- for non-optimising compilation, or where we aren't generating any +-- object code at all ('HscNothing'). +mkIfaceTc :: HscEnv + -> Maybe Fingerprint -- The old fingerprint, if we have it + -> SafeHaskellMode -- The safe haskell mode + -> ModDetails -- gotten from mkBootModDetails, probably + -> TcGblEnv -- Usages, deprecations, etc + -> IO (Messages, Maybe (ModIface, Bool)) +mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_warns = warns, + tcg_hpc = other_hpc_info, + tcg_th_splice_used = tc_splice_used, + tcg_dependent_files = dependent_files + } + = do + let used_names = mkUsedNames tc_result + deps <- mkDependencies tc_result + let hpc_info = emptyHpcInfo other_hpc_info + used_th <- readIORef tc_splice_used + dep_files <- (readIORef dependent_files) + mkIface_ hsc_env maybe_old_fingerprint + this_mod (hsc_src == HsBootFile) used_names + used_th deps rdr_env + fix_env warns hpc_info (imp_mods imports) + (imp_trust_own_pkg imports) dep_files safe_mode mod_details + + +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus + +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. +mkDependencies :: TcGblEnv -> IO Dependencies +mkDependencies + TcGblEnv{ tcg_mod = mod, + tcg_imports = imports, + tcg_th_used = th_var + } + = do + -- Template Haskell used? + th_used <- readIORef th_var + let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + pkgs | th_used = insertList thPackageKey (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + sorted_pkgs = sortBy stablePackageKeyCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, + dep_pkgs = dep_pkgs', + dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + +mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface + -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv + -> NameEnv FixItem -> Warnings -> HpcInfo + -> ImportedMods -> Bool + -> [FilePath] + -> SafeHaskellMode + -> ModDetails + -> IO (Messages, Maybe (ModIface, Bool)) +mkIface_ hsc_env maybe_old_fingerprint + this_mod is_boot used_names used_th deps rdr_env fix_env src_warns + hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode + ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_anns = anns, + md_vect_info = vect_info, + md_types = type_env, + md_exports = exports } +-- NB: notice that mkIface does not look at the bindings +-- only at the TypeEnv. The previous Tidy phase has +-- put exactly the info into the TypeEnv that we want +-- to expose in the interface + + = do + usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files + + let entities = typeEnvElts type_env + decls = [ tyThingToIfaceDecl entity + | entity <- entities, + let name = getName entity, + not (isImplicitTyThing entity), + -- No implicit Ids and class tycons in the interface file + not (isWiredInName name), + -- Nor wired-in things; the compiler knows about them anyhow + nameIsLocalOrFrom this_mod name ] + -- Sigh: see Note [Root-main Id] in TcRnDriver + + fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] + warns = src_warns + iface_rules = map (coreRuleToIfaceRule this_mod) rules + iface_insts = map instanceToIfaceInst insts + iface_fam_insts = map famInstToIfaceFamInst fam_insts + iface_vect_info = flattenVectInfo vect_info + trust_info = setSafeMode safe_mode + annotations = map mkIfaceAnnotation anns + sig_of = getSigOf dflags (moduleName this_mod) + + intermediate_iface = ModIface { + mi_module = this_mod, + mi_sig_of = sig_of, + mi_boot = is_boot, + mi_deps = deps, + mi_usages = usages, + mi_exports = mkIfaceExports exports, + + -- Sort these lexicographically, so that + -- the result is stable across compilations + mi_insts = sortBy cmp_inst iface_insts, + mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, + mi_rules = sortBy cmp_rule iface_rules, + + mi_vect_info = iface_vect_info, + + mi_fixities = fixities, + mi_warns = warns, + mi_anns = annotations, + mi_globals = maybeGlobalRdrEnv rdr_env, + + -- Left out deliberately: filled in by addFingerprints + mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_exp_hash = fingerprint0, + mi_used_th = used_th, + mi_orphan_hash = fingerprint0, + mi_orphan = False, -- Always set by addFingerprints, but + -- it's a strict field, so we can't omit it. + mi_finsts = False, -- Ditto + mi_decls = deliberatelyOmitted "decls", + mi_hash_fn = deliberatelyOmitted "hash_fn", + mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, + + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities } + + (new_iface, no_change_at_all) + <- {-# SCC "versioninfo" #-} + addFingerprints hsc_env maybe_old_fingerprint + intermediate_iface decls + + -- Warn about orphans + -- See Note [Orphans and auto-generated rules] + let warn_orphs = wopt Opt_WarnOrphans dflags + warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags + orph_warnings --- Laziness means no work done unless -fwarn-orphans + | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns + | otherwise = emptyBag + errs_and_warns = (orph_warnings, emptyBag) + unqual = mkPrintUnqualified dflags rdr_env + inst_warns = listToBag [ instOrphWarn dflags unqual d + | (d,i) <- insts `zip` iface_insts + , isOrphan (ifInstOrph i) ] + rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r + | r <- iface_rules + , isOrphan (ifRuleOrph r) + , if ifRuleAuto r then warn_auto_orphs + else warn_orphs ] + + if errorsFound dflags errs_and_warns + then return ( errs_and_warns, Nothing ) + else do + -- Debug printing + dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" + (pprModIface new_iface) + + -- bug #1617: on reload we weren't updating the PrintUnqualified + -- correctly. This stems from the fact that the interface had + -- not changed, so addFingerprints returns the old ModIface + -- with the old GlobalRdrEnv (mi_globals). + let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env } + + return (errs_and_warns, Just (final_iface, no_change_at_all)) + where + cmp_rule = comparing ifRuleName + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + cmp_inst = comparing (nameOccName . ifDFun) + cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) + + dflags = hsc_dflags hsc_env + + -- We only fill in mi_globals if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_globals field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv rdr_env + | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env + | otherwise = Nothing + + deliberatelyOmitted :: String -> a + deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + + ifFamInstTcName = ifFamInstFam + + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + , vectInfoParallelVars = vParallelVars + , vectInfoParallelTyCons = vParallelTyCons + }) = + IfaceVectInfo + { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar] + , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v] + , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v] + , ifaceVectInfoParallelVars = [Var.varName v | v <- varSetElems vParallelVars] + , ifaceVectInfoParallelTyCons = nameSetElems vParallelTyCons + } + +----------------------------- +writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO () +writeIfaceFile dflags hi_file_path new_iface + = do createDirectoryIfMissing True (takeDirectory hi_file_path) + writeBinIface dflags hi_file_path new_iface + + +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names + +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. + +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> Fingerprint) +mkHashFun hsc_env eps + = \name -> + let + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + occ = nameOccName name + iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` + pprPanic "lookupVers2" (ppr mod <+> ppr occ) + in + snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + where + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +addFingerprints + :: HscEnv + -> Maybe Fingerprint -- the old fingerprint, if any + -> ModIface -- The new interface (lacking decls) + -> [IfaceDecl] -- The new decls + -> IO (ModIface, -- Updated interface + Bool) -- True <=> no changes at all; + -- no need to write Iface + +addFingerprints hsc_env mb_old_fingerprint iface0 new_decls + = do + eps <- hscEPS hsc_env + let + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts + non_orph_fis decl + + edges :: [(IfaceDeclABI, Unique, [Unique])] + edges = [ (abi, getUnique (ifName decl), out) + | decl <- new_decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n + localOccs = map (getUnique . getParent . getOccName) + . filter ((== this_mod) . name_module) + . nameSetElems + where getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldr extend emptyOccEnv new_decls + where extend d env = + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] + where n = ifName d + + -- strongly-connected groups of declarations, in dependency order + groups = stronglyConnCompFromEdgedVertices edges + + global_hash_fn = mkHashFun hsc_env eps + + -- how to output Names when generating the data to fingerprint. + -- Here we want to output the fingerprint for each top-level + -- Name, whether it comes from the current module or another + -- module. In this way, the fingerprint for a declaration will + -- change if the fingerprint for anything it refers to (transitively) + -- changes. + mk_put_name :: (OccEnv (OccName,Fingerprint)) + -> BinHandle -> Name -> IO () + mk_put_name local_env bh name + | isWiredInName name = putNameLiterally bh name + -- wired-in names don't have fingerprints + | otherwise + = ASSERT2( isExternalName name, ppr name ) + let hash | nameModule name /= this_mod = global_hash_fn name + | otherwise = snd (lookupOccEnv local_env (getOccName name) + `orElse` pprPanic "urk! lookup local fingerprint" + (ppr name)) -- (undefined,fingerprint0)) + -- This panic indicates that we got the dependency + -- analysis wrong, because we needed a fingerprint for + -- an entity that wasn't in the environment. To debug + -- it, turn the panic into a trace, uncomment the + -- pprTraces below, run the compile again, and inspect + -- the output and the generated .hi file with + -- --show-iface. + in put_ bh hash + + -- take a strongly-connected group of declarations and compute + -- its fingerprint. + + fingerprint_group :: (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + -> SCC IfaceDeclABI + -> IO (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + + fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) + = do let hash_fn = mk_put_name local_env + decl = abiDecl abi + -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + hash <- computeFingerprint hash_fn abi + env' <- extend_hash_env local_env (hash,decl) + return (env', (hash,decl) : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) + = do let decls = map abiDecl abis + local_env1 <- foldM extend_hash_env local_env + (zip (repeat fingerprint0) decls) + let hash_fn = mk_put_name local_env1 + -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do + let stable_abis = sortBy cmp_abiNames abis + -- put the cycle in a canonical order + hash <- computeFingerprint hash_fn stable_abis + let pairs = zip (repeat hash) decls + local_env2 <- foldM extend_hash_env local_env pairs + return (local_env2, pairs ++ decls_w_hashes) + + -- we have fingerprinted the whole declaration, but we now need + -- to assign fingerprints to all the OccNames that it binds, to + -- use when referencing those OccNames in later declarations. + -- + extend_hash_env :: OccEnv (OccName,Fingerprint) + -> (Fingerprint,IfaceDecl) + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 (hash,d) = do + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) + + -- + (local_env, decls_w_hashes) <- + foldM fingerprint_group (emptyOccEnv, []) groups + + -- when calculating fingerprints, we always need to use canonical + -- ordering for lists of things. In particular, the mi_deps has various + -- lists of modules and suchlike, so put these all in canonical order: + let sorted_deps = sortDependencies (mi_deps iface0) + + -- the export hash of a module depends on the orphan hashes of the + -- orphan modules below us in the dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. We only care about orphan modules in the current + -- package, because changes to orphans outside this package will be + -- tracked by the usage on the ABI hash of package modules that we import. + let orph_mods = filter ((== this_pkg) . modulePackageKey) + $ dep_orphs sorted_deps + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods + + orphan_hash <- computeFingerprint (mk_put_name local_env) + (map ifDFun orph_insts, orph_rules, orph_fis) + + -- the export list hash doesn't depend on the fingerprints of + -- the Names it mentions, only the Names themselves, hence putNameLiterally. + export_hash <- computeFingerprint putNameLiterally + (mi_exports iface0, + orphan_hash, + dep_orphan_hashes, + dep_pkgs (mi_deps iface0), + -- dep_pkgs: see "Package Version Changes" on + -- wiki/Commentary/Compiler/RecompilationAvoidance + mi_trust iface0) + -- Make sure change of Safe Haskell mode causes recomp. + + -- put the declarations in a canonical order, sorted by OccName + let sorted_decls = Map.elems $ Map.fromList $ + [(ifName d, e) | e@(_, d) <- decls_w_hashes] + + -- the flag hash depends on: + -- - (some of) dflags + -- it returns two hashes, one that shouldn't change + -- the abi hash and one that should + flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally + + -- the ABI hash depends on: + -- - decls + -- - export list + -- - orphans + -- - deprecations + -- - vect info + -- - flag abi hash + mod_hash <- computeFingerprint putNameLiterally + (map fst sorted_decls, + export_hash, -- includes orphan_hash + mi_warns iface0, + mi_vect_info iface0) + + -- The interface hash depends on: + -- - the ABI hash, plus + -- - the module level annotations, + -- - usages + -- - deps (home and external packages, dependent files) + -- - hpc + iface_hash <- computeFingerprint putNameLiterally + (mod_hash, + ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache + mi_usages iface0, + sorted_deps, + mi_hpc iface0) + + let + no_change_at_all = Just iface_hash == mb_old_fingerprint + + final_iface = iface0 { + mi_mod_hash = mod_hash, + mi_iface_hash = iface_hash, + mi_exp_hash = export_hash, + mi_orphan_hash = orphan_hash, + mi_flag_hash = flag_hash, + mi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis + && isNoIfaceVectInfo (mi_vect_info iface0)), + mi_finsts = not . null $ mi_fam_insts iface0, + mi_decls = sorted_decls, + mi_hash_fn = lookupOccEnv local_env } + -- + return (final_iface, no_change_at_all) + + where + this_mod = mi_module iface0 + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) + fix_fn = mi_fix_fn iface0 + ann_fn = mkIfaceAnnCache (mi_anns iface0) + +getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] +getOrphanHashes hsc_env mods = do + eps <- hscEPS hsc_env + let + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + dflags = hsc_dflags hsc_env + get_orph_hash mod = + case lookupIfaceByModule dflags hpt pit mod of + Nothing -> pprPanic "moduleOrphanHash" (ppr mod) + Just iface -> mi_orphan_hash iface + -- + return (map get_orph_hash mods) + + +sortDependencies :: Dependencies -> Dependencies +sortDependencies d + = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), + dep_pkgs = sortBy (stablePackageKeyCmp `on` fst) (dep_pkgs d), + dep_orphs = sortBy stableModuleCmp (dep_orphs d), + dep_finsts = sortBy stableModuleCmp (dep_finsts d) } + +-- | Creates cached lookup for the 'mi_anns' field of ModIface +-- Hackily, we use "module" as the OccName for any module-level annotations +mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] +mkIfaceAnnCache anns + = \n -> lookupOccEnv env n `orElse` [] + where + pair (IfaceAnnotation target value) = + (case target of + NamedTarget occn -> occn + ModuleTarget _ -> mkVarOcc "module" + , [value]) + -- flipping (++), so the first argument is always short + env = mkOccEnv_C (flip (++)) (map pair anns) + +{- +Note [Orphans and auto-generated rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise an INLINEABLE function, or when we have +-fspecialise-aggressively, we auto-generate RULES that are orphans. +We don't want to warn about these, at least not by default, or we'd +generate a lot of warnings. Hence -fwarn-auto-orphans. + +Indeed, we don't even treat the module as an oprhan module if it has +auto-generated *rule* orphans. Orphan modules are read every time we +compile, so they are pretty obtrusive and slow down every compilation, +even non-optimised ones. (Reason: for type class instances it's a +type correctness issue.) But specialisation rules are strictly for +*optimisation* only so it's fine not to read the interface. + +What this means is that a SPEC rules from auto-specialisation in +module M will be used in other modules only if M.hi has been read for +some other reason, which is actually pretty likely. + + +************************************************************************ +* * + The ABI of an IfaceDecl +* * +************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as an unfolding in the interface. + + (c) the fixity of the identifier + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. +-} + +type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) + +data IfaceDeclExtras + = IfaceIdExtras IfaceIdExtras + + | IfaceDataExtras + Fixity -- Fixity of the tycon itself + [IfaceInstABI] -- Local class and family instances of this tycon + -- See Note [Orphans] in InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations + + | IfaceClassExtras + Fixity -- Fixity of the class itself + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each class method: fixity, RULES and annotations + + | IfaceSynonymExtras Fixity [AnnPayload] + + | IfaceFamilyExtras Fixity [IfaceInstABI] [AnnPayload] + + | IfaceOtherDeclExtras + +data IfaceIdExtras + = IdExtras + Fixity -- Fixity of the Id + [IfaceRule] -- Rules for the Id + [AnnPayload] -- Annotations for the Id + +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + +abiDecl :: IfaceDeclABI -> IfaceDecl +abiDecl (_, decl, _) = decl + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` + ifName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras id_extras) + = freeNamesIdExtras id_extras +freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceClassExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceSynonymExtras _ _) + = emptyNameSet +freeNamesDeclExtras (IfaceFamilyExtras _ insts _) + = mkNameSet insts +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesIdExtras :: IfaceIdExtras -> NameSet +freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) + +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = Outputable.empty + ppr (IfaceIdExtras extras) = ppr_id_extras extras + ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] + ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] + ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = ptext (sLit "") + +ppr_id_extras_s :: [IfaceIdExtras] -> SDoc +ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) + +ppr_id_extras :: IfaceIdExtras -> SDoc +ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) + +-- This instance is used only to compute fingerprints +instance Binary IfaceDeclExtras where + get _bh = panic "no get for IfaceDeclExtras" + put_ bh (IfaceIdExtras extras) = do + putByte bh 1; put_ bh extras + put_ bh (IfaceDataExtras fix insts anns cons) = do + putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons + put_ bh (IfaceClassExtras fix insts anns methods) = do + putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods + put_ bh (IfaceSynonymExtras fix anns) = do + putByte bh 4; put_ bh fix; put_ bh anns + put_ bh (IfaceFamilyExtras fix finsts anns) = do + putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns + put_ bh IfaceOtherDeclExtras = putByte bh 6 + +instance Binary IfaceIdExtras where + get _bh = panic "no get for IfaceIdExtras" + put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } + +declExtras :: (OccName -> Fixity) + -> (OccName -> [AnnPayload]) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn ann_fn rule_env inst_env fi_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (id_extras n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) + (ann_fn n) + (map (id_extras . ifConOcc) (visibleIfConDecls cons)) + IfaceClass{ifSigs=sigs, ifATs=ats} -> + IfaceClassExtras (fix_fn n) + (map ifDFun $ (concatMap at_extras ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (Trac #5147) + (ann_fn n) + [id_extras op | IfaceClassOp op _ _ <- sigs] + IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) + (ann_fn n) + IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (ann_fn n) + _other -> IfaceOtherDeclExtras + where + n = ifName decl + id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl) + + +lookupOccEnvL :: OccEnv [v] -> OccName -> [v] +lookupOccEnvL env k = lookupOccEnv env k `orElse` [] + +-- used when we want to fingerprint a structure without depending on the +-- fingerprints of external Names that it refers to. +putNameLiterally :: BinHandle -> Name -> IO () +putNameLiterally bh name = ASSERT( isExternalName name ) + do + put_ bh $! nameModule name + put_ bh $! nameOccName name + +{- +-- for testing: use the md5sum command to generate fingerprints and +-- compare the results against our built-in version. + fp' <- oldMD5 dflags bh + if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') + else return fp + +oldMD5 dflags bh = do + tmp <- newTempName dflags "bin" + writeBinMem bh tmp + tmp2 <- newTempName dflags "md5" + let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 + r <- system cmd + case r of + ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) + ExitSuccess -> do + hash_str <- readFile tmp2 + return $! readHexFingerprint hash_str +-} + +instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg +instOrphWarn dflags unqual inst + = mkWarnMsg dflags (getSrcSpan inst) unqual $ + hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) + $$ text "To avoid this" + $$ nest 4 (vcat possibilities) + where + possibilities = + text "move the instance declaration to the module of the class or of the type, or" : + text "wrap the type with a newtype and declare the instance on the new type." : + [] + +ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg +ruleOrphWarn dflags unqual mod rule + = mkWarnMsg dflags silly_loc unqual $ + ptext (sLit "Orphan rule:") <+> ppr rule + where + silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1) + -- We don't have a decent SrcSpan for a Rule, not even the CoreRule + -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to + +---------------------- +-- mkOrphMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkOrphMap get_key decls + = foldl go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | NotOrphan occ <- get_key d + = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) + | otherwise = (non_orphs, d:orphs) + +{- +************************************************************************ +* * + Keeping track of what we've slurped, and fingerprints +* * +************************************************************************ +-} + +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files + = do + eps <- hscEPS hsc_env + hashes <- mapM getFileHash dependent_files + let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod + dir_imp_mods used_names + let usages = mod_usages ++ [ UsageFile { usg_file_path = f + , usg_file_hash = hash } + | (f, hash) <- zip dependent_files hashes ] + usages `seqList` return usages + -- seq the list of Usages returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + +mk_mod_usage_info :: PackageIfaceTable + -> HscEnv + -> Module + -> ImportedMods + -> NameSet + -> [Usage] +mk_mod_usage_info pit hsc_env this_mod direct_imports used_names + = mapMaybe mkUsage usage_mods + where + hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + used_mods = moduleEnvKeys ent_map + dir_imp_mods = moduleEnvKeys direct_imports + all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is imported, to avoid interface-file + -- wobblage. + + -- ent_map groups together all the things imported and used + -- from a particular module + ent_map :: ModuleEnv [OccName] + ent_map = foldNameSet add_mv emptyModuleEnv used_names + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map + -- See Note [Internal used_names] + + Just mod -> -- This lambda function is really just a + -- specialised (++); originally came about to + -- avoid quadratic behaviour (trac #2680) + extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ] + where occ = nameOccName name + + -- We want to create a Usage for a home module if + -- a) we used something from it; has something in used_names + -- b) we imported it, even if we used nothing from it + -- (need to recompile if its export list changes: export_fprint) + mkUsage :: Module -> Maybe Usage + mkUsage mod + | isNothing maybe_iface -- We can't depend on it if we didn't + -- load its interface. + || mod == this_mod -- We don't care about usages of + -- things in *this* module + = Nothing + + | modulePackageKey mod /= this_pkg + = Just UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } + -- for package modules, we record the module hash only + + | (null used_occs + && isNothing export_hash + && not is_direct_import + && not finsts_mod) + = Nothing -- Record no usage info + -- for directly-imported modules, we always want to record a usage + -- on the orphan hash. This is what triggers a recompilation if + -- an orphan is added or removed somewhere below us in the future. + + | otherwise + = Just UsageHomeModule { + usg_mod_name = moduleName mod, + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } + where + maybe_iface = lookupIfaceByModule dflags hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. + + Just iface = maybe_iface + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + export_hash | depend_on_exports = Just (mi_exp_hash iface) + | otherwise = Nothing + + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + Just ((_,_,_,safe):_xs) -> (True, safe) + Just _ -> pprPanic "mkUsage: empty direct import" Outputable.empty + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' + -- is used in the source code. We require them to be safe in Safe Haskell + + used_occs = lookupModuleEnv ent_map mod `orElse` [] + + -- Making a Map here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use Map rather than OccEnv: Map works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) + = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = payload + } + +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical +mkIfaceExports exports + = sortBy stableAvailCmp (map sort_subs exports) + where + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | n==m = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) + -- Maintain the AvailTC Invariant + +{- +Note [Orignal module] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +In the result of MkIfaceExports, the names are grouped by defining module, +so we may need to split up a single Avail into multiple ones. + +Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the used_names are External Names, but we can have Internal +Names too: see Note [Binders in Template Haskell] in Convert, and +Trac #5362 for an example. Such Names are always + - Such Names are always for locally-defined things, for which we + don't gather usage info, so we can just ignore them in ent_map + - They are always System Names, hence the assert, just as a double check. + + +************************************************************************ +* * + Load the old interface file for this module (unless + we have it already), and check whether it is up to date +* * +************************************************************************ +-} + +data RecompileRequired + = UpToDate + -- ^ everything is up to date, recompilation is not required + | MustCompile + -- ^ The .hs file has been touched, or the .o/.hi file does not exist + | RecompBecause String + -- ^ The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + deriving Eq + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + + + +-- | Top level function to check if the version of an old interface file +-- is equivalent to the current source file the user asked us to compile. +-- If the same, we can avoid recompilation. We return a tuple where the +-- first element is a bool saying if we should recompile the object file +-- and the second is maybe the interface file, where Nothng means to +-- rebuild the interface file not use the exisitng one. +checkOldIface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (RecompileRequired, Maybe ModIface) + +checkOldIface hsc_env mod_summary source_modified maybe_iface + = do let dflags = hsc_dflags hsc_env + showPass dflags $ + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) + initIfaceCheck hsc_env $ + check_old_iface hsc_env mod_summary source_modified maybe_iface + +check_old_iface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> IfG (RecompileRequired, Maybe ModIface) + +check_old_iface hsc_env mod_summary src_modified maybe_iface + = let dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> loadIface + + loadIface = do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path + case read_result of + Failed err -> do + traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + src_changed + | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True + | SourceModified <- src_modified = True + | otherwise = False + in do + when src_changed $ + traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off") + + case src_changed of + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + True | not (isObjectTarget $ hscTarget dflags) -> + return (MustCompile, maybe_iface) + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + True -> do + maybe_iface' <- getIface + return (MustCompile, maybe_iface') + + False -> do + maybe_iface' <- getIface + case maybe_iface' of + -- We can't retrieve the iface + Nothing -> return (MustCompile, Nothing) + + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + Just iface -> checkVersions hsc_env mod_summary iface + +-- | Check if a module is still the same 'version'. +-- +-- This function is called in the recompilation checker after we have +-- determined that the module M being checked hasn't had any changes +-- to its source file since we last compiled M. So at this point in general +-- two things may have changed that mean we should recompile M: +-- * The interface export by a dependency of M has changed. +-- * The compiler flags specified this time for M have changed +-- in a manner that is significant for recompilaiton. +-- We return not just if we should recompile the object file but also +-- if we should rebuild the interface file. +checkVersions :: HscEnv + -> ModSummary + -> ModIface -- Old interface + -> IfG (RecompileRequired, Maybe ModIface) +checkVersions hsc_env mod_summary iface + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + ; recomp <- checkFlagHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface)) + /= mi_sig_of iface + then return (RecompBecause "sig-of changed", Nothing) else do { + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recompileRequired recomp then return (recomp, Just iface) else do { + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}}} + where + this_pkg = thisPackage (hsc_dflags hsc_env) + -- This is a bit of a hack really + mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) + mod_deps = mkModDeps (dep_mods (mi_deps iface)) + +-- | Check the flags haven't changed +checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkFlagHash hsc_env iface = do + let old_hash = mi_flag_hash iface + new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + (mi_module iface) + putNameLiterally + case old_hash == new_hash of + True -> up_to_date (ptext $ sLit "Module flags unchanged") + False -> out_of_date_hash "flags changed" + (ptext $ sLit " Module flags have changed") + old_hash new_hash + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- Returns True if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + where + prev_dep_mods = dep_mods (mi_deps iface) + prev_dep_pkgs = dep_pkgs (mi_deps iface) + + this_pkg = thisPackage (hsc_dflags hsc_env) + + dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do + find_res <- liftIO $ findImportedModule hsc_env mod pkg + let reason = moduleNameString mod ++ " changed" + case find_res of + Found _ mod + | pkg == this_pkg + -> if moduleName mod `notElem` map fst prev_dep_mods + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + | otherwise + -> if pkg `notElem` (map fst prev_dep_pkgs) + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " is from package " <> quotes (ppr pkg) <> + text ", which is not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + where pkg = modulePackageKey mod + _otherwise -> return (RecompBecause reason) + +needInterface :: Module -> (ModIface -> IfG RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do -- Load the imported interface if possible + let doc_str = sep [ptext (sLit "need version info for"), ppr mod] + traceHiDiffs (text "Checking usages for module" <+> ppr mod) + + mb_iface <- loadInterface doc_str mod ImportBySystem + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of + Failed _ -> do + traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"), + ppr mod]) + return MustCompile + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> continue iface + + +-- | Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. +checkModUsage :: PackageKey -> Usage -> IfG RecompileRequired +checkModUsage _this_pkg UsagePackageModule{ + usg_mod = mod, + usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) + -- We only track the ABI hash of package modules, rather than + -- individual entity usages, so if the ABI hash changes we must + -- recompile. This is safe but may entail more recompilation when + -- a dependent package has changed. + +checkModUsage this_pkg UsageHomeModule{ + usg_mod_name = mod_name, + usg_mod_hash = old_mod_hash, + usg_exports = maybe_old_export_hash, + usg_entities = old_decl_hash } + = do + let mod = mkModule this_pkg mod_name + needInterface mod $ \iface -> do + + let + new_mod_hash = mi_mod_hash iface + new_decl_hash = mi_hash_fn iface + new_export_hash = mi_exp_hash iface + + reason = moduleNameString mod_name ++ " changed" + + -- CHECK MODULE + recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) + then return UpToDate + else do + + -- CHECK EXPORT LIST + checkMaybeHash reason maybe_old_export_hash new_export_hash + (ptext (sLit " Export list changed")) $ do + + -- CHECK ITEMS ONE BY ONE + recompile <- checkList [ checkEntityUsage reason new_decl_hash u + | u <- old_decl_hash] + if recompileRequired recompile + then return recompile -- This one failed, so just bail out now + else up_to_date (ptext (sLit " Great! The bits I use are up to date")) + + +checkModUsage _this_pkg UsageFile{ usg_file_path = file, + usg_file_hash = old_hash } = + liftIO $ + handleIO handle $ do + new_hash <- getFileHash file + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + recomp = RecompBecause (file ++ " changed") + handle = +#ifdef DEBUG + \e -> pprTrace "UsageFile" (text (show e)) $ return recomp +#else + \_ -> return recomp -- if we can't find the file, just recompile, don't fail +#endif + +------------------------ +checkModuleFingerprint :: String -> Fingerprint -> Fingerprint + -> IfG RecompileRequired +checkModuleFingerprint reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date (ptext (sLit "Module fingerprint unchanged")) + + | otherwise + = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed")) + old_mod_hash new_mod_hash + +------------------------ +checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc + -> IfG RecompileRequired -> IfG RecompileRequired +checkMaybeHash reason maybe_old_hash new_hash doc continue + | Just hash <- maybe_old_hash, hash /= new_hash + = out_of_date_hash reason doc hash new_hash + | otherwise + = continue + +------------------------ +checkEntityUsage :: String + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName, Fingerprint) + -> IfG RecompileRequired +checkEntityUsage reason new_hash (name,old_hash) + = case new_hash name of + + Nothing -> -- We used it before, but it ain't there now + out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name]) + + Just (_, new_hash) -- It's there, but is it up to date? + | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + return UpToDate + | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name) + old_hash new_hash + +up_to_date :: SDoc -> IfG RecompileRequired +up_to_date msg = traceHiDiffs msg >> return UpToDate + +out_of_date :: String -> SDoc -> IfG RecompileRequired +out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) + +out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired +out_of_date_hash reason msg old_hash new_hash + = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) + +---------------------- +checkList :: [IfG RecompileRequired] -> IfG RecompileRequired +-- This helper is used in two places +checkList [] = return UpToDate +checkList (check:checks) = do recompile <- check + if recompileRequired recompile + then return recompile + else checkList checks + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: TyThing -> IfaceDecl +tyThingToIfaceDecl (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only + PatSynCon ps -> patSynToIfaceDecl ps + +-------------------------- +idToIfaceDecl :: Id -> IfaceDecl +-- The Id is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- We can't tidy it here, locally, because it may have +-- free variables in its type or IdInfo +idToIfaceDecl id + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = toIfaceIdInfo (idInfo id) } + +-------------------------- +dataConToIfaceDecl :: DataCon -> IfaceDecl +dataConToIfaceDecl dataCon + = IfaceId { ifName = getOccName dataCon, + ifType = toIfaceType (dataConUserType dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = NoInfo } + +-------------------------- +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getOccName . getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivTvs = toIfaceTvBndrs univ_tvs' + , ifPatExTvs = toIfaceTvBndrs ex_tvs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + } + where + (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps + (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs + (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs + to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + +-------------------------- +coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl +-- We *do* tidy Axioms, because they are not (and cannot +-- conveniently be) built in tidy form +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) + = IfaceAxiom { ifName = name + , ifTyCon = toIfaceTyCon tycon + , ifRole = role + , ifAxBranches = brListMap (coAxBranchToIfaceBranch tycon + (brListMap coAxBranchLHS branches)) + branches } + where + name = getOccName ax + +-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches +-- to incompatible indices +-- See Note [Storing compatibility] in CoAxiom +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s + branch@(CoAxBranch { cab_incomps = incomps }) + = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust "iface_incomps" + . (flip findIndex lhs_s + . eqTypes) + . coAxBranchLHS) incomps + +-- use this one for standalone branches without incompatibles +coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs + , cab_roles = roles, cab_rhs = rhs }) + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs + , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs + , ifaxbRoles = roles + , ifaxbRHS = tidyToIfaceType env1 rhs + , ifaxbIncomps = [] } + where + (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs + -- Don't re-bind in-scope tyvars + -- See Note [CoAxBranch type variables] in CoAxiom + +----------------- +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) +-- We *do* tidy TyCons, because they are not (and cannot +-- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars +tyConToIfaceDecl env tycon + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl env clas + + | Just syn_rhs <- synTyConRhs_maybe tycon + = ( tc_env1 + , IfaceSynonym { ifName = getOccName tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifSynRhs = if_syn_type syn_rhs, + ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) + }) + + | Just fam_flav <- famTyConFlav_maybe tycon + = ( tc_env1 + , IfaceFamily { ifName = getOccName tycon, + ifTyVars = if_tc_tyvars, + ifFamFlav = to_if_fam_flav fam_flav, + ifFamKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) + }) + + | isAlgTyCon tycon + = ( tc_env1 + , IfaceData { ifName = getOccName tycon, + ifCType = tyConCType tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifPromotable = isJust (promotableTyCon_maybe tycon), + ifParent = parent }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- For pretty printing purposes only. + = ( env + , IfaceData { ifName = getOccName tycon, + ifCType = Nothing, + ifTyVars = funAndPrimTyVars, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifRec = boolToRecFlag False, + ifGadtSyntax = False, + ifPromotable = False, + ifParent = IfNoParent }) + where + (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) + if_tc_tyvars = toIfaceTvBndrs tc_tyvars + if_syn_type ty = tidyToIfaceType tc_env1 ty + + funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr + where defs = fromBranchList $ coAxiomBranches ax + ibr = map (coAxBranchToIfaceBranch' tycon) defs + axn = coAxiomName ax + to_if_fam_flav AbstractClosedSynFamilyTyCon + = IfaceAbstractClosedSynFamilyTyCon + + to_if_fam_flav (BuiltInSynFamTyCon {}) + = IfaceBuiltInSynFamTyCon + + + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon + ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct + -- The last case happens when a TyCon has been trimmed during tidying + -- Furthermore, tyThingToIfaceDecl is also used + -- in TcRnDriver for GHCi, when browsing a module, in which case the + -- AbstractTyCon case is perfectly sensible. + + ifaceConDecl data_con + = IfCon { ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), + ifConExTvs = toIfaceTvBndrs ex_tvs', + ifConEqSpec = map to_eq_spec eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, + ifConFields = map getOccName + (dataConFieldLabels data_con), + ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) } + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con + + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- we know that the type variables will line up + -- The latter (b) is important because we pretty-print type construtors + -- by converting to IfaceSyn and pretty-printing that + con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs + to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsNoBang = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ HsStrict = IfStrict +toIfaceBang _ (HsSrcBang {}) = panic "toIfaceBang" + +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) +classToIfaceDecl env clas + = ( env1 + , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, + ifName = getOccName (classTyCon clas), + ifTyVars = toIfaceTvBndrs clas_tyvars', + ifRoles = tyConRoles (classTyCon clas), + ifFDs = map toIfaceFD clas_fds, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = fmap getFS (classMinimalDef clas), + ifRec = boolToRecFlag (isRecursiveTyCon tycon) }) + where + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars + + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc + + toIfaceClassOp (sel_id, def_meth) + = ASSERT(sel_tyvars == clas_tyvars) + IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) + (tidyToIfaceType env1 op_ty) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toDmSpec NoDefMeth = NoDM + toDmSpec (GenDefMeth _) = GenericDM + toDmSpec (DefMeth _) = VanillaDM + + toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1, + map (getFS . tidyTyVar env1) tvs2) + +-------------------------- +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs + +tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- If the type variable "binder" is in scope, don't re-bind it +-- In a class decl, for example, the ATD binders mention +-- (amd must mention) the class tyvars +tidyTyClTyVarBndr env@(_, subst) tv + | Just tv' <- lookupVarEnv subst tv = (env, tv') + | otherwise = tidyTyVarBndr env tv + +tidyTyVar :: TidyEnv -> TyVar -> TyVar +tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv + -- TcType.tidyTyVarOcc messes around with FlatSkols + +getFS :: NamedThing a => a -> FastString +getFS x = occNameFS (getOccName x) + +-------------------------- +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag + , is_cls_nm = cls_name, is_cls = cls + , is_tcs = mb_tcs + , is_orphan = orph }) + = ASSERT( cls_name == className cls ) + IfaceClsInst { ifDFun = dfun_name, + ifOFlag = oflag, + ifInstCls = cls_name, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + dfun_name = idName dfun_id + + +-------------------------- +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_axiom = axiom, + fi_fam = fam, + fi_tcs = roughs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough roughs + , ifFamInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + fam_decl = tyConName $ coAxiomTyCon axiom + mod = ASSERT( isExternalName (coAxiomName axiom) ) + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) + + orph | is_local fam_decl + = NotOrphan (nameOccName fam_decl) + + | not (isEmptyNameSet lhs_names) + = NotOrphan (nameOccName (head (nameSetElems lhs_names))) + + + | otherwise + = IsOrphan + +-------------------------- +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn + +-------------------------- +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId ns _) = IfDFunId ns +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + inline_hsinfo, unfold_hsinfo] of + [] -> NoInfo + infos -> HasInfo infos + -- NB: strictness and arity must appear in the list before unfolding + -- See TcIface.tcUnfolding + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + sig_info = strictnessInfo id_info + strict_hsinfo | not (isNopSig sig_info) = Just (HsStrictness sig_info) + | otherwise = Nothing + + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineStable + -> case guidance of + UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_rhs + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + if_rhs = toIfaceExpr rhs + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ _ + = Nothing + +-------------------------- +coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule +coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule fn + +coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_auto = auto }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) + do_arg arg = toIfaceExpr arg + + -- Compute orphanhood. See Note [Orphans] in InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = nameSetElems (ruleLhsOrphNames rule) + + orph = case filter (nameIsLocalOrFrom mod) lhs_names of + (n : _) -> NotOrphan (nameOccName n) + [] -> IsOrphan + +bogusIfaceRule :: Name -> IfaceRule +bogusIfaceRule id_name + = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, + ifRuleAuto = True } + +--------------------- +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) + | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) + | otherwise = toIfaceExpr e + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) +toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) +toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) +toIfaceTickish (Breakpoint {}) = Nothing + -- Ignore breakpoints, since they are relevant only to GHCi, and + -- should not be serialised (Trac #8333) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +--------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | isTupleTyCon tc && saturated + -> IfaceTuple (tupleTyConSort tc) tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getFS name) + where name = idName v diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs new file mode 100644 index 00000000..fb9ad086 --- /dev/null +++ b/compiler/iface/TcIface.hs @@ -0,0 +1,1381 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Type checking of type signatures in interface files +-} + +{-# LANGUAGE CPP #-} + +module TcIface ( + tcLookupImported_maybe, + importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceVectInfo, tcIfaceAnnotations, + tcIfaceExpr, -- Desired by HERMIT (Trac #7683) + tcIfaceGlobal + ) where + +#include "HsVersions.h" + +import TcTypeNats(typeNatCoAxiomRules) +import IfaceSyn +import LoadIface +import IfaceEnv +import BuildTyCl +import TcRnMonad +import TcType +import Type +import Coercion hiding (substTy) +import TypeRep +import HscTypes +import Annotations +import InstEnv +import FamInstEnv +import CoreSyn +import CoreUtils +import CoreUnfold +import CoreLint +import MkCore +import Id +import MkId +import IdInfo +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PrelNames +import TysWiredIn +import TysPrim ( superKindTyConName ) +import BasicTypes ( strongLoopBreaker ) +import Literal +import qualified Var +import VarEnv +import VarSet +import Name +import NameEnv +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand +import Module +import UniqFM +import UniqSupply +import Outputable +import Maybes +import SrcLoc +import DynFlags +import Util +import FastString + +import Control.Monad +import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( traverse ) +#endif + +{- +This module takes + + IfaceDecl -> TyThing + IfaceType -> Type + etc + +An IfaceDecl is populated with RdrNames, and these are not renamed to +Names before typechecking, because there should be no scope errors etc. + + -- For (b) consider: f = \$(...h....) + -- where h is imported, and calls f via an hi-boot file. + -- This is bad! But it is not seen as a staging error, because h + -- is indeed imported. We don't want the type-checker to black-hole + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + + +************************************************************************ +* * + Type-checking a complete interface +* * +************************************************************************ + +Suppose we discover we don't need to recompile. Then we must type +check the old interface file. This is a bit different to the +incremental type checking we do as we suck in interface files. Instead +we do things similarly as when we are typechecking source decls: we +bring into scope the type envt for the interface all at once, using a +knot. Remember, the decls aren't necessarily in dependency order -- +and even if they were, the type decls might be mutually recursive. +-} + +typecheckIface :: ModIface -- Get the decls from here + -> TcRnIf gbl lcl ModDetails +typecheckIface iface + = initIfaceTc iface $ \ tc_env_var -> do + -- The tc_env_var is freshly allocated, private to + -- type-checking this particular interface + { -- Get the right set of decls and rules. If we are compiling without -O + -- we discard pragmas before typechecking, so that we don't "see" + -- information that we shouldn't. From a versioning point of view + -- It's not actually *wrong* to do so, but in fact GHCi is unable + -- to handle unboxed tuples, so it must not see unfoldings. + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module work out right. In the If monad there is + -- no global envt for the current interface; instead, the knot is tied + -- through the if_rec_types field of IfGblEnv + ; names_w_things <- loadDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things + ; writeMutVar tc_env_var type_env + + -- Now do those rules, instances and annotations + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) + + -- Vectorisation information + ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface) + + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) + + -- Finished + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + text "Type envt:" <+> ppr type_env]) + ; return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_vect_info = vect_info + , md_exports = exports + } + } + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ +-} + +tcHiBootIface :: HscSource -> Module -> TcRn ModDetails +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the ModDetails, empty if no hi-boot iface +tcHiBootIface hsc_src mod + | HsBootFile <- hsc_src -- Already compiling a hs-boot file + = return emptyModDetails + | otherwise + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + ; mode <- getGhcMode + ; if not (isOneShot mode) + -- In --make and interactive mode, if this module has an hs-boot file + -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check wheher the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- And that's fine, because if M's ModInfo is in the HPT, then + -- it's been compiled once, and we don't need to check the boot iface + then do { hpt <- getHpt + ; case lookupUFM hpt (moduleName mod) of + Just info | mi_boot (hm_iface info) + -> return (hm_details info) + _ -> return emptyModDetails } + else do + + -- OK, so we're in one-shot mode. + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { read_result <- findAndReadIface + need mod + True -- Hi-boot file + + ; case read_result of { + Succeeded (iface, _path) -> typecheckIface iface ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + Nothing -> return emptyModDetails -- The typical case + + Just (_, False) -> failWithTc moduleLoop + -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + + Just (_mod, True) -> failWithTc (elaborate err) + -- The hi-boot file has mysteriously disappeared. + }}}} + where + need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod + <+> ptext (sLit "to compare against the Real Thing") + + moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) + <+> ptext (sLit "depends on itself") + + elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> + quotes (ppr mod) <> colon) 4 err + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +When typechecking a data type decl, we *lazily* (via forkM) typecheck +the constructor argument types. This is in the hope that we may never +poke on those argument types, and hence may never need to load the +interface files for types mentioned in the arg types. + +E.g. + data Foo.S = MkS Baz.T +Mabye we can get away without even loading the interface for Baz! + +This is not just a performance thing. Suppose we have + data Foo.S = MkS Baz.T + data Baz.T = MkT Foo.S +(in different interface files, of course). +Now, first we load and typecheck Foo.S, and add it to the type envt. +If we do explore MkS's argument, we'll load and typecheck Baz.T. +If we explore MkT's argument we'll find Foo.S already in the envt. + +If we typechecked constructor args eagerly, when loading Foo.S we'd try to +typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... +which isn't done yet. + +All very cunning. However, there is a rather subtle gotcha which bit +me when developing this stuff. When we typecheck the decl for S, we +extend the type envt with S, MkS, and all its implicit Ids. Suppose +(a bug, but it happened) that the list of implicit Ids depended in +turn on the constructor arg types. Then the following sequence of +events takes place: + * we build a thunk for the constructor arg tys + * we build a thunk for the extended type environment (depends on ) + * we write the extended type envt into the global EPS mutvar + +Now we look something up in the type envt + * that pulls on + * which reads the global type envt out of the global EPS mutvar + * but that depends in turn on + +It's subtle, because, it'd work fine if we typechecked the constructor args +eagerly -- they don't need the extended type envt. They just get the extended +type envt by accident, because they look at it later. + +What this means is that the implicitTyThings MUST NOT DEPEND on any of +the forkM stuff. +-} + +tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tcIfaceDecl = tc_iface_decl NoParentTyCon + +tc_iface_decl :: TyConParent -- For nested declarations + -> Bool -- True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) + = do { name <- lookupIfaceTop occ_name + ; ty <- tcIfaceType iface_type + ; details <- tcIdDetails ty details + ; info <- tcIdInfo ignore_prags name ty info + ; return (AnId (mkGlobalId details name ty info)) } + +tc_iface_decl parent _ (IfaceData {ifName = occ_name, + ifCType = cType, + ifTyVars = tv_bndrs, + ifRoles = roles, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifRec = is_rec, ifPromotable = is_prom, + ifParent = mb_parent }) + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; tycon <- fixM $ \ tycon -> do + { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent mb_parent + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta + cons is_rec is_prom gadt_syn parent') } + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) } + where + tc_parent :: IfaceTyConParent -> IfL TyConParent + tc_parent IfNoParent = return parent + tc_parent (IfDataInstance ax_name _ arg_tys) + = ASSERT( isNoParent parent ) + do { ax <- tcIfaceCoAxiom ax_name + ; let fam_tc = coAxiomTyCon ax + ax_unbr = toUnbranchedAxiom ax + ; lhs_tys <- tcIfaceTcArgs arg_tys + ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) } + +tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, + ifRoles = roles, + ifSynRhs = rhs_ty, + ifSynKind = kind }) + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tcIfaceType rhs_ty + ; tycon <- buildSynonymTyCon tc_name tyvars roles rhs rhs_kind + ; return (ATyCon tycon) } + where + mk_doc n = ptext (sLit "Type synonym") <+> ppr n + +tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, + ifFamFlav = fam_flav, + ifFamKind = kind }) + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tc_fam_flav fam_flav + ; tycon <- buildFamilyTyCon tc_name tyvars rhs rhs_kind parent + ; return (ATyCon tycon) } + where + mk_doc n = ptext (sLit "Type synonym") <+> ppr n + tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon + tc_fam_flav (IfaceClosedSynFamilyTyCon ax_name _) + = do { ax <- tcIfaceCoAxiom ax_name + ; return (ClosedSynFamilyTyCon ax) } + tc_fam_flav IfaceAbstractClosedSynFamilyTyCon + = return AbstractClosedSynFamilyTyCon + tc_fam_flav IfaceBuiltInSynFamTyCon + = pprPanic "tc_iface_decl" + (text "IfaceBuiltInSynFamTyCon in interface file") + +tc_iface_decl _parent ignore_prags + (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, + ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, + ifATs = rdr_ats, ifSigs = rdr_sigs, + ifMinDef = mindef_occ, ifRec = tc_isrec }) +-- ToDo: in hs-boot files we should really treat abstract classes specially, +-- as we do abstract tycons + = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop tc_occ + ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) + ; ctxt <- mapM tc_sc rdr_ctxt + ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) + ; sigs <- mapM tc_sig rdr_sigs + ; fds <- mapM tc_fd rdr_fds + ; traceIf (text "tc-iface-class3" <+> ppr tc_occ) + ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ + ; cls <- fixM $ \ cls -> do + { ats <- mapM (tc_at cls) rdr_ats + ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) + ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec } + ; return (ATyCon (classTyCon cls)) } + where + tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) + -- The *length* of the superclasses is used by buildClass, and hence must + -- not be inside the thunk. But the *content* maybe recursive and hence + -- must be lazy (via forkM). Example: + -- class C (T a) => D a where + -- data T a + -- Here the associated type T is knot-tied with the class, and + -- so we must not pull on T too eagerly. See Trac #5970 + + tc_sig (IfaceClassOp occ dm rdr_ty) + = do { op_name <- lookupIfaceTop occ + ; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty) + -- Must be done lazily for just the same reason as the + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessary to do so + ; return (op_name, dm, op_ty) } + + tc_at cls (IfaceAT tc_decl if_def) + = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just (tc_def, noSrcSpan)) } + -- Must be done lazily in case the RHS of the defaults mention + -- the type constructor being defined here + -- e.g. type AT a; type AT b = AT [b] Trac #8002 + return (ATI tc mb_def) + + mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred + mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc + mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] + + tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 + ; return (tvs1', tvs2') } + +tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc + , ifAxBranches = branches, ifRole = role }) + = do { tc_name <- lookupIfaceTop ax_occ + ; tc_tycon <- tcIfaceTyCon tc + ; tc_branches <- tc_ax_branches branches + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_tc = tc_tycon + , co_ax_role = role + , co_ax_branches = toBranchList tc_branches + , co_ax_implicit = False } + ; return (ACoAxiom axiom) } + +tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name + , ifPatMatcher = if_matcher + , ifPatBuilder = if_builder + , ifPatIsInfix = is_infix + , ifPatUnivTvs = univ_tvs + , ifPatExTvs = ex_tvs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty }) + = do { name <- lookupIfaceTop occ_name + ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) + ; matcher <- tc_pr if_matcher + ; builder <- fmapMaybeM tc_pr if_builder + ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do + { bindIfaceTyVars ex_tvs $ \ex_tvs -> do + { patsyn <- forkM (mk_doc name) $ + do { prov_theta <- tcIfaceCtxt prov_ctxt + ; req_theta <- tcIfaceCtxt req_ctxt + ; pat_ty <- tcIfaceType pat_ty + ; arg_tys <- mapM tcIfaceType args + ; return $ buildPatSyn name is_infix matcher builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty } + ; return $ AConLike . PatSynCon $ patsyn }}} + where + mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n + tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) + tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) + ; return (id, b) } + +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches + +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches + (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs + , ifaxbRoles = roles, ifaxbIncomps = incomps }) + = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do + -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom + { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds] + ; tc_rhs <- tcIfaceType rhs + ; let br = CoAxBranch { cab_loc = noSrcSpan + , cab_tvs = tvs + , cab_lhs = tc_lhs + , cab_roles = roles + , cab_rhs = tc_rhs + , cab_incomps = map (prev_branches !!) incomps } + ; return (prev_branches ++ [br]) } + +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons + = case if_cons of + IfAbstractTyCon dis -> return (AbstractTyCon dis) + IfDataFamTyCon -> return DataFamilyTyCon + IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; mkNewTyConRhs tycon_name tycon data_con } + where + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConExTvs = ex_tvs, + ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = field_lbls, + ifConStricts = if_stricts}) + = -- Universally-quantified tyvars are shared with + -- parent TyCon, and are alrady in scope + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) + ; name <- lookupIfaceTop occ + + -- Read the context and argument types, but lazily for two reasons + -- (a) to avoid looking tugging on a recursive use of + -- the type itself, which is knot-tied + -- (b) to avoid faulting in the component types unless + -- they are really needed + ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $ + do { eq_spec <- tcIfaceEqSpec spec + ; theta <- tcIfaceCtxt ctxt + ; arg_tys <- mapM tcIfaceType args + ; stricts <- mapM tc_strict if_stricts + -- The IfBang field can mention + -- the type itself; hence inside forkM + ; return (eq_spec, theta, arg_tys, stricts) } + ; lbl_names <- mapM lookupIfaceTop field_lbls + + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyVars (mkTopTvSubst eq_spec) tc_tyvars) + + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name)) + name is_infix + stricts -- Pass the HsImplBangs (i.e. final decisions + -- to buildDataCon; it'll use these to guide + -- the construction of a worker + lbl_names + tc_tyvars ex_tyvars + eq_spec theta + arg_tys orig_res_ty tycon + ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name) + ; return con } + mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name + + tc_strict :: IfaceBang -> IfL HsImplBang + tc_strict IfNoBang = return HsNoBang + tc_strict IfStrict = return HsStrict + tc_strict IfUnpack = return (HsUnpack Nothing) + tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co + ; return (HsUnpack (Just co)) } + +tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)] +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + ; ty <- tcIfaceType if_ty + ; return (tv,ty) } + +{- +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (Trac #2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. + +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun oflag orph) } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) + = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name + -- will panic if branched, but that's OK + ; let axiom'' = toUnbranchedAxiom axiom' + mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom'') } + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ + +We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars +are in the type environment. However, remember that typechecking a Rule may +(as a side effect) augment the type envt, and so we may need to iterate the process. +-} + +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + +tcIfaceRule :: IfaceRule -> IfL CoreRule +tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto }) + = do { ~(bndrs', args', rhs') <- + -- Typecheck the payload lazily, in the hope it'll never be looked at + forkM (ptext (sLit "Rule") <+> ftext name) $ + bindIfaceBndrs bndrs $ \ bndrs' -> + do { args' <- mapM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; return (bndrs', args', rhs') } + ; let mb_tcs = map ifTopFreeName args + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = occurAnalyseExpr rhs', + ru_rough = mb_tcs, + ru_auto = auto, + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set + where + -- This function *must* mirror exactly what Rules.topFreeName does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- type syononyms at the top of a type arg. Since + -- we can't tell at this point, we are careful not + -- to write them out in coreRuleToIfaceRule + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceApp f _) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName _ = Nothing + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + +{- +************************************************************************ +* * + Vectorisation information +* * +************************************************************************ +-} + +-- We need access to the type environment as we need to look up information about type constructors +-- (i.e., their data constructors and whether they are class type constructors). If a vectorised +-- type constructor or class is defined in the same module as where it is vectorised, we cannot +-- look that information up from the type constructor that we obtained via a 'forkM'ed +-- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again +-- and again and again... +-- +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceVectInfo mod typeEnv (IfaceVectInfo + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoParallelVars = parallelVars + , ifaceVectInfoParallelTyCons = parallelTyCons + }) + = do { let parallelTyConsSet = mkNameSet parallelTyCons + ; vVars <- mapM vectVarMapping vars + ; let varsSet = mkVarSet (map fst vVars) + ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons + ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse + ; vParallelVars <- mapM vectVar parallelVars + ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2) + ; return $ VectInfo + { vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoParallelVars = mkVarSet vParallelVars + , vectInfoParallelTyCons = parallelTyConsSet + } + } + where + vectVarMapping name + = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name) + ; var <- forkM (ptext (sLit "vect var") <+> ppr name) $ + tcIfaceExtId name + ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+> + ppr mod <> ptext (sLit "; nameModule =") <+> + ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $ + tcIfaceExtId vName + ; return (var, (var, vVar)) + } + -- where + -- lookupLocalOrExternalId name + -- = do { let mb_id = lookupTypeEnv typeEnv name + -- ; case mb_id of + -- -- id is local + -- Just (AnId id) -> return id + -- -- name is not an Id => internal inconsistency + -- Just _ -> notAnIdErr + -- -- Id is external + -- Nothing -> tcIfaceExtId name + -- } + -- + -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name) + + vectVar name + = forkM (ptext (sLit "vect scalar var") <+> ppr name) $ + tcIfaceExtId name + + vectTyConVectMapping vars name + = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name) + ; vectTyConMapping vars name vName + } + + vectTyConReuseMapping vars name + = vectTyConMapping vars name name + + vectTyConMapping vars name vName + = do { tycon <- lookupLocalOrExternalTyCon name + ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ + lookupLocalOrExternalTyCon vName + + -- Map the data constructors of the original type constructor to those of the + -- vectorised type constructor /unless/ the type constructor was vectorised + -- abstractly; if it was vectorised abstractly, the workers of its data constructors + -- do not appear in the set of vectorised variables. + -- + -- NB: This is lazy! We don't pull at the type constructors before we actually use + -- the data constructor mapping. + ; let isAbstract | isClassTyCon tycon = False + | datacon:_ <- tyConDataCons tycon + = not $ dataConWrapId datacon `elemVarSet` vars + | otherwise = True + vDataCons | isAbstract = [] + | otherwise = [ (dataConName datacon, (datacon, vDatacon)) + | (datacon, vDatacon) <- zip (tyConDataCons tycon) + (tyConDataCons vTycon) + ] + + -- Map the (implicit) superclass and methods selectors as they don't occur in + -- the var map. + vScSels | Just cls <- tyConClass_maybe tycon + , Just vCls <- tyConClass_maybe vTycon + = [ (sel, (sel, vSel)) + | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls) + ] + | otherwise + = [] + + ; return ( (name, (tycon, vTycon)) -- (T, T_v) + , vDataCons -- list of (Ci, Ci_v) + , vScSels -- list of (seli, seli_v) + ) + } + where + -- we need a fully defined version of the type constructor to be able to extract + -- its data constructors etc. + lookupLocalOrExternalTyCon name + = do { let mb_tycon = lookupTypeEnv typeEnv name + ; case mb_tycon of + -- tycon is local + Just (ATyCon tycon) -> return tycon + -- name is not a tycon => internal inconsistency + Just _ -> notATyConErr + -- tycon is external + Nothing -> tcIfaceTyCon (IfaceTc name) + } + + notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +tcIfaceType :: IfaceType -> IfL Type +tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } +tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } +tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } +tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 +tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 +tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc + ; tks' <- tcIfaceTcArgs tks + ; return (mkTyConApp tc' tks') } +tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } + +tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type +tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } + +tcIfaceKind :: IfaceKind -> IfL Type +tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } +tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l) +tcIfaceKind k = tcIfaceType k + +tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type +tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } + +tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] +tcIfaceTcArgs args + = case args of + ITC_Type t ts -> + do { t' <- tcIfaceType t + ; ts' <- tcIfaceTcArgs ts + ; return (t':ts') } + ITC_Kind k ks -> + do { k' <- tcIfaceKind k + ; ks' <- tcIfaceTcArgs ks + ; return (k':ks') } + ITC_Nil -> return [] +----------------------------------------- +tcIfaceCtxt :: IfaceContext -> IfL ThetaType +tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +tcIfaceCo :: IfaceCoercion -> IfL Coercion +tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t +tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2 +tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc + <*> mapM tcIfaceCo cs +tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1 + <*> tcIfaceCo c2 +tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo c +tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n +tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n + <*> pure i + <*> mapM tcIfaceCo cs +tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1 + <*> tcIfaceType t2 +tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c +tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1 + <*> tcIfaceCo c2 +tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1 + <*> tcIfaceType t2 +tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c +tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c +tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c +tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo + <$> tcIfaceCoAxiomRule ax + <*> mapM tcIfaceType tys + <*> mapM tcIfaceCo cos + +tcIfaceCoVar :: FastString -> IfL CoVar +tcIfaceCoVar = tcIfaceLclId + +tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule +tcIfaceCoAxiomRule n = + case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) + +{- +************************************************************************ +* * + Core +* * +************************************************************************ +-} + +tcIfaceExpr :: IfaceExpr -> IfL CoreExpr +tcIfaceExpr (IfaceType ty) + = Type <$> tcIfaceType ty + +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + +tcIfaceExpr (IfaceLcl name) + = Var <$> tcIfaceLclId name + +tcIfaceExpr (IfaceExt gbl) + = Var <$> tcIfaceExtId gbl + +tcIfaceExpr (IfaceLit lit) + = do lit' <- tcIfaceLit lit + return (Lit lit') + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + dflags <- getDynFlags + return (Var (mkFCallId dflags u cc ty')) + +tcIfaceExpr (IfaceTuple boxity args) = do + args' <- mapM tcIfaceExpr args + -- Put the missing type arguments back in + let con_args = map (Type . exprType) args' ++ args' + return (mkApps (Var con_id) con_args) + where + arity = length args + con_id = dataConWorkId (tupleCon boxity arity) + + +tcIfaceExpr (IfaceLam (bndr, os) body) + = bindIfaceBndr bndr $ \bndr' -> + Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body + where + tcIfaceOneShot IfaceOneShot b = setOneShotLambda b + tcIfaceOneShot _ b = b + +tcIfaceExpr (IfaceApp fun arg) + = tcIfaceApps fun arg + +tcIfaceExpr (IfaceECase scrut ty) + = do { scrut' <- tcIfaceExpr scrut + ; ty' <- tcIfaceType ty + ; return (castBottomExpr scrut' ty') } + +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) + let + scrut_ty = exprType scrut' + case_bndr' = mkLocalId case_bndr_name scrut_ty + tc_app = splitTyConApp scrut_ty + -- NB: Won't always succeed (polymorphic case) + -- but won't be demanded in those cases + -- NB: not tcSplitTyConApp; we are looking at Core here + -- look through non-rec newtypes to find the tycon that + -- corresponds to the datacon in this case alternative + + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' tc_app) alts + return (Case scrut' case_bndr' (coreAltsType alts') alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + name ty' info + ; let id = mkLocalIdWithInfo name ty' id_info + ; rhs' <- tcIfaceExpr rhs + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = do { ids <- mapM tc_rec_bndr (map fst pairs) + ; extendIfaceIdEnv ids $ do + { pairs' <- zipWithM tc_pair pairs ids + ; body' <- tcIfaceExpr body + ; return (Let (Rec pairs') body') } } + where + tc_rec_bndr (IfLetBndr fs ty _) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; return (mkLocalId name ty') } + tc_pair (IfLetBndr _ _ info, rhs) id + = do { rhs' <- tcIfaceExpr rhs + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + (idName id) (idType id) info + ; return (setIdInfo id id_info, rhs') } + +tcIfaceExpr (IfaceTick tickish expr) = do + expr' <- tcIfaceExpr expr + -- If debug flag is not set: Ignore source notes + dbgFlag <- fmap (gopt Opt_Debug) getDynFlags + case tickish of + IfaceSource{} | not dbgFlag + -> return expr' + _otherwise -> do + tickish' <- tcIfaceTickish tickish + return (Tick tickish' expr') + +------------------------- +tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr +-- See Note [Checking IfaceTypes vs IfaceKinds] +tcIfaceApps fun arg + = go_down fun [arg] + where + go_down (IfaceApp fun arg) args = go_down fun (arg:args) + go_down fun args = do { fun' <- tcIfaceExpr fun + ; go_up fun' (exprType fun') args } + + go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr + go_up fun _ [] = return fun + go_up fun fun_ty (IfaceType t : args) + | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty + = do { t' <- if isKindVar tv + then tcIfaceKind t + else tcIfaceType t + ; let fun_ty' = substTyWith [tv] [t'] body_ty + ; go_up (App fun (Type t')) fun_ty' args } + go_up fun fun_ty (arg : args) + | Just (_, fun_ty') <- splitFunTy_maybe fun_ty + = do { arg' <- tcIfaceExpr arg + ; go_up (App fun arg') fun_ty' args } + go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args) + +------------------------- +tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) +tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) +tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) +tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) + +------------------------- +tcIfaceLit :: Literal -> IfL Literal +-- Integer literals deserialise to (LitInteger i ) +-- so tcIfaceLit just fills in the type. +-- See Note [Integer literals] in Literal +tcIfaceLit (LitInteger i _) + = do t <- tcIfaceTyCon (IfaceTc integerTyConName) + return (mkLitInteger i (mkTyConTy t)) +tcIfaceLit lit = return lit + +------------------------- +tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) + -> (IfaceConAlt, [FastString], IfaceExpr) + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceAlt _ _ (IfaceDefault, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (DEFAULT, [], rhs') + +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) do + lit' <- tcIfaceLit lit + rhs' <- tcIfaceExpr rhs + return (LitAlt lit', [], rhs') + +-- A case alternative is made quite a bit more complicated +-- by the fact that we omit type annotations because we can +-- work them out. True enough, but its not that easy! +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) + = do { con <- tcIfaceDataCon data_occ + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) + ; tcIfaceDataAlt con inst_tys arg_strs rhs } + +tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceDataAlt con inst_tys arg_strs rhs + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs con inst_tys + + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + +{- +************************************************************************ +* * + IdInfo +* * +************************************************************************ +-} + +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty (IfDFunId ns) + = return (DFunId ns (isNewTyCon (classTyCon cls))) + where + (_, _, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) + = do { tc' <- tcIfaceTyCon tc + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + +tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags name ty info + | ignore_prags = return vanillaIdInfo + | otherwise = case info of + NoInfo -> return vanillaIdInfo + HasInfo info -> foldlM tcPrag init_info info + where + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + init_info = vanillaIdInfo + + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) + + -- The next two are lazy, so they don't transitively suck stuff in + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding name ty info if_unf + ; let info1 | lb = info `setOccInfo` strongLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfoLazily` unf) } + +tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding name _ info (IfCoreUnfold stable if_expr) + = do { dflags <- getDynFlags + ; mb_expr <- tcPragExpr name if_expr + ; let unf_src | stable = InlineStable + | otherwise = InlineRhs + ; return $ case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkUnfolding dflags unf_src + True {- Top level -} + (isBottomingSig strict_sig) + expr + } + where + -- Strictness should occur before unfolding! + strict_sig = strictnessInfo info +tcUnfolding name _ _ (IfCompulsory if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding InlineStable True expr guidance )} + where + guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + +tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops) + = bindIfaceBndrs bs $ \ bs' -> + do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + (_, _, cls, _) = tcSplitDFunTy dfun_ty + +{- +For unfoldings we try to do the job lazily, so that we never type check +an unfolding that isn't going to be looked at. +-} + +tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr) +tcPragExpr name expr + = forkM_maybe doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + whenGOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope + case lintUnfolding noSrcLoc in_scope core_expr' of + Nothing -> return () + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ ptext (sLit "In interface for") <+> ppr mod + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr core_expr' + , ptext (sLit "Iface expr =") <+> ppr expr ]) } + return core_expr' + where + doc = text "Unfolding of" <+> ppr name + + get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting + get_in_scope + = do { (gbl_env, lcl_env) <- getEnvs + ; rec_ids <- case if_rec_types gbl_env of + Nothing -> return [] + Just (_, get_env) -> do + { type_env <- setLclEnv () get_env + ; return (typeEnvIds type_env) } + ; return (varEnvElts (if_tv_env lcl_env) ++ + varEnvElts (if_id_env lcl_env) ++ + rec_ids) } + +{- +************************************************************************ +* * + Getting from Names to TyThings +* * +************************************************************************ +-} + +tcIfaceGlobal :: Name -> IfL TyThing +tcIfaceGlobal name + | Just thing <- wiredInNameTyThing_maybe name + -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double + = do { ifCheckWiredInThing thing; return thing } + | otherwise + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] + Just (mod, get_type_env) + | nameIsLocalOrFrom mod name + -> do -- It's defined in the module being compiled + { type_env <- setLclEnv () get_type_env -- yuk + ; case lookupNameEnv type_env name of + Just thing -> return thing + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + (ppr name $$ ppr type_env) } + + ; _ -> do + + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { + Just thing -> return thing ; + Nothing -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}}}} + +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used in two situations: +-- +-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T +-- Then we look up M.T in M's type environment, which is splatted into if_rec_types +-- after we've built M's type envt. +-- +-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi +-- is up to date. So we call typecheckIface on M.hi. This splats M.T into +-- if_rec_types so that the (lazily typechecked) decls see all the other decls +-- +-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT +-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its +-- emasculated form (e.g. lacking data constructors). + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon itc + = do { + ; thing <- tcIfaceGlobal (ifaceTyConName itc) + ; case itc of + IfaceTc _ -> return $ tyThingTyCon thing + IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing + IfacePromotedTyCon name -> + let ktycon tc + | isSuperKind (tyConKind tc) = return tc + | Just prom_tc <- promotableTyCon_maybe tc = return prom_tc + | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) + in ktycon (tyThingTyCon thing) + } + +tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) +tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name + ; return (tyThingCoAxiom thing) } + +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of + AConLike (RealDataCon dc) -> return dc + _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } + +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ +-} + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; let id = mkLocalId name ty' + ; extendIfaceIdEnv [id] (thing_inside id) } +bindIfaceBndr (IfaceTvBndr bndr) thing_inside + = bindIfaceTyVar bndr thing_inside + +bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a +bindIfaceBndrs [] thing_inside = thing_inside [] +bindIfaceBndrs (b:bs) thing_inside + = bindIfaceBndr b $ \ b' -> + bindIfaceBndrs bs $ \ bs' -> + thing_inside (b':bs') + +----------------------- +bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar (occ,kind) thing_inside + = do { name <- newIfaceName (mkTyVarOccFS occ) + ; tyvar <- mk_iface_tyvar name kind + ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } + +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars bndrs thing_inside + = do { names <- newIfaceNames (map mkTyVarOccFS occs) + ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds + (kis_name, tys_name) = splitAt (length kis_kind) names + -- We need to bring the kind variables in scope since type + -- variables may mention them. + ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind + ; extendIfaceTyVarEnv kvs $ do + { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind + ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } } + where + (occs,kinds) = unzip bndrs + +isSuperIfaceKind :: IfaceKind -> Bool +isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName +isSuperIfaceKind _ = False + +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceKind ifKind + ; return (Var.mkTyVar name kind) } + +bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyVars_AT [] thing_inside + = thing_inside [] +bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside + = do { mb_tv <- lookupIfaceTyVar tv_occ + ; let bind_b :: (TyVar -> IfL a) -> IfL a + bind_b = case mb_tv of + Just b' -> \k -> k b' + Nothing -> bindIfaceTyVar b + ; bind_b $ \b' -> + bindIfaceTyVars_AT bs $ \bs' -> + thing_inside (b':bs') } diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot new file mode 100644 index 00000000..619e3efd --- /dev/null +++ b/compiler/iface/TcIface.hs-boot @@ -0,0 +1,18 @@ +module TcIface where + +import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) +import TypeRep ( TyThing ) +import TcRnTypes ( IfL ) +import InstEnv ( ClsInst ) +import FamInstEnv ( FamInst ) +import CoreSyn ( CoreRule ) +import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) +import Module ( Module ) +import Annotations ( Annotation ) + +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs new file mode 100644 index 00000000..85095997 --- /dev/null +++ b/compiler/llvmGen/Llvm.hs @@ -0,0 +1,61 @@ +-- ---------------------------------------------------------------------------- +-- | This module supplies bindings to generate Llvm IR from Haskell +-- (). +-- +-- Note: this module is developed in a demand driven way. It is no complete +-- LLVM binding library in Haskell, but enough to generate code for GHC. +-- +-- This code is derived from code taken from the Essential Haskell Compiler +-- (EHC) project (). +-- + +module Llvm ( + + -- * Modules, Functions and Blocks + LlvmModule(..), + + LlvmFunction(..), LlvmFunctionDecl(..), + LlvmFunctions, LlvmFunctionDecls, + LlvmStatement(..), LlvmExpression(..), + LlvmBlocks, LlvmBlock(..), LlvmBlockId, + LlvmParamAttr(..), LlvmParameter, + + -- * Fence synchronization + LlvmSyncOrdering(..), + + -- * Call Handling + LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), + LlvmLinkageType(..), LlvmFuncAttr(..), + + -- * Operations and Comparisons + LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), + + -- * Variables and Type System + LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), + LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, + LMConst(..), + + -- ** Some basic types + i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + + -- ** Metadata types + MetaExpr(..), MetaAnnot(..), MetaDecl(..), + + -- ** Operations on the type system. + isGlobal, getLitType, getVarType, + getLink, getStatType, pVarLift, pVarLower, + pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, + + -- * Pretty Printing + ppLit, ppName, ppPlainName, + ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, + ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + + ) where + +import Llvm.AbsSyn +import Llvm.MetaData +import Llvm.PpLlvm +import Llvm.Types + diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs new file mode 100644 index 00000000..24d0856e --- /dev/null +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -0,0 +1,301 @@ +-------------------------------------------------------------------------------- +-- | The LLVM abstract syntax. +-- + +module Llvm.AbsSyn where + +import Llvm.MetaData +import Llvm.Types + +import Unique + +-- | Block labels +type LlvmBlockId = Unique + +-- | A block of LLVM code. +data LlvmBlock = LlvmBlock { + -- | The code label for this block + blockLabel :: LlvmBlockId, + + -- | A list of LlvmStatement's representing the code for this block. + -- This list must end with a control flow statement. + blockStmts :: [LlvmStatement] + } + +type LlvmBlocks = [LlvmBlock] + +-- | An LLVM Module. This is a top level container in LLVM. +data LlvmModule = LlvmModule { + -- | Comments to include at the start of the module. + modComments :: [LMString], + + -- | LLVM Alias type definitions. + modAliases :: [LlvmAlias], + + -- | LLVM meta data. + modMeta :: [MetaDecl], + + -- | Global variables to include in the module. + modGlobals :: [LMGlobal], + + -- | LLVM Functions used in this module but defined in other modules. + modFwdDecls :: LlvmFunctionDecls, + + -- | LLVM Functions defined in this module. + modFuncs :: LlvmFunctions + } + +-- | An LLVM Function +data LlvmFunction = LlvmFunction { + -- | The signature of this declared function. + funcDecl :: LlvmFunctionDecl, + + -- | The functions arguments + funcArgs :: [LMString], + + -- | The function attributes. + funcAttrs :: [LlvmFuncAttr], + + -- | The section to put the function into, + funcSect :: LMSection, + + -- | The body of the functions. + funcBody :: LlvmBlocks + } + +type LlvmFunctions = [LlvmFunction] + +type SingleThreaded = Bool + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) + +-- | Llvm Statements +data LlvmStatement + {- | + Assign an expression to an variable: + * dest: Variable to assign to + * source: Source expression + -} + = Assignment LlvmVar LlvmExpression + + {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | + Always branch to the target label + -} + | Branch LlvmVar + + {- | + Branch to label targetTrue if cond is true otherwise to label targetFalse + * cond: condition that will be tested, must be of type i1 + * targetTrue: label to branch to if cond is true + * targetFalse: label to branch to if cond is false + -} + | BranchIf LlvmVar LlvmVar LlvmVar + + {- | + Comment + Plain comment. + -} + | Comment [LMString] + + {- | + Set a label on this position. + * name: Identifier of this label, unique for this module + -} + | MkLabel LlvmBlockId + + {- | + Store variable value in pointer ptr. If value is of type t then ptr must + be of type t*. + * value: Variable/Constant to store. + * ptr: Location to store the value in + -} + | Store LlvmVar LlvmVar + + {- | + Mutliway branch + * scrutinee: Variable or constant which must be of integer type that is + determines which arm is chosen. + * def: The default label if there is no match in target. + * target: A list of (value,label) where the value is an integer + constant and label the corresponding label to jump to if the + scrutinee matches the value. + -} + | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] + + {- | + Return a result. + * result: The variable or constant to return + -} + | Return (Maybe LlvmVar) + + {- | + An instruction for the optimizer that the code following is not reachable + -} + | Unreachable + + {- | + Raise an expression to a statement (if don't want result or want to use + Llvm unnamed values. + -} + | Expr LlvmExpression + + {- | + A nop LLVM statement. Useful as its often more efficient to use this + then to wrap LLvmStatement in a Just or []. + -} + | Nop + + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaAnnot] LlvmStatement + + deriving (Eq) + + +-- | Llvm Expressions +data LlvmExpression + {- | + Allocate amount * sizeof(tp) bytes on the stack + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + = Alloca LlvmType Int + + {- | + Perform the machine operator op on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | LlvmOp LlvmMachOp LlvmVar LlvmVar + + {- | + Perform a compare operation on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | Compare LlvmCmpOp LlvmVar LlvmVar + + {- | + Extract a scalar element from a vector + * val: The vector + * idx: The index of the scalar within the vector + -} + | Extract LlvmVar LlvmVar + + {- | + Insert a scalar element into a vector + * val: The source vector + * elt: The scalar to insert + * index: The index at which to insert the scalar + -} + | Insert LlvmVar LlvmVar LlvmVar + + {- | + Allocate amount * sizeof(tp) bytes on the heap + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + | Malloc LlvmType Int + + {- | + Load the value at location ptr + -} + | Load LlvmVar + + {- | + Atomic load of the value at location ptr + -} + | ALoad LlvmSyncOrdering SingleThreaded LlvmVar + + {- | + Navigate in an structure, selecting elements + * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) + * ptr: Location of the structure + * indexes: A list of indexes to select the correct value. + -} + | GetElemPtr Bool LlvmVar [LlvmVar] + + {- | + Cast the variable from to the to type. This is an abstraction of three + cast operators in Llvm, inttoptr, prttoint and bitcast. + * cast: Cast type + * from: Variable to cast + * to: type to cast to + -} + | Cast LlvmCastOp LlvmVar LlvmType + + {- | + Call a function. The result is the value of the expression. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Concrete arguments for the parameters + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] + + {- | + Call a function as above but potentially taking metadata as arguments. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Arguments that may include metadata. + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] + + {- | + Merge variables from different basic blocks which are predecessors of this + basic block in a new variable of type tp. + * tp: type of the merged variable, must match the types of the + predecessor variables. + * precessors: A list of variables and the basic block that they originate + from. + -} + | Phi LlvmType [(LlvmVar,LlvmVar)] + + {- | + Inline assembly expression. Syntax is very similar to the style used by GCC. + * assembly: Actual inline assembly code. + * constraints: Operand constraints. + * return ty: Return type of function. + * vars: Any variables involved in the assembly code. + * sideeffect: Does the expression have side effects not visible from the + constraints list. + * alignstack: Should the stack be conservatively aligned before this + expression is executed. + -} + | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + + {- | + A LLVM expression with metadata attached to it. + -} + | MExpr [MetaAnnot] LlvmExpression + + deriving (Eq) + diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs new file mode 100644 index 00000000..36efcd71 --- /dev/null +++ b/compiler/llvmGen/Llvm/MetaData.hs @@ -0,0 +1,83 @@ +module Llvm.MetaData where + +import Llvm.Types +import Outputable + +-- The LLVM Metadata System. +-- +-- The LLVM metadata feature is poorly documented but roughly follows the +-- following design: +-- * Metadata can be constructed in a few different ways (See below). +-- * After which it can either be attached to LLVM statements to pass along +-- extra information to the optimizer and code generator OR specificially named +-- metadata has an affect on the whole module (i.e., linking behaviour). +-- +-- +-- # Constructing metadata +-- Metadata comes largely in three forms: +-- +-- * Metadata expressions -- these are the raw metadata values that encode +-- information. They consist of metadata strings, metadata nodes, regular +-- LLVM values (both literals and references to global variables) and +-- metadata expressions (i.e., recursive data type). Some examples: +-- !{ metadata !"hello", metadata !0, i32 0 } +-- !{ metadata !1, metadata !{ i32 0 } } +-- +-- * Metadata nodes -- global metadata variables that attach a metadata +-- expression to a number. For example: +-- !0 = metadata !{ [] !} +-- +-- * Named metadata -- global metadata variables that attach a metadata nodes +-- to a name. Used ONLY to communicated module level information to LLVM +-- through a meaningful name. For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- +-- +-- # Using Metadata +-- Using metadata depends on the form it is in: +-- +-- * Attach to instructions -- metadata can be attached to LLVM instructions +-- using a specific reference as follows: +-- %l = load i32* @glob, !nontemporal !10 +-- %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } } +-- Only metadata nodes or expressions can be attached, named metadata cannot. +-- Refer to LLVM documentation for which instructions take metadata and its +-- meaning. +-- +-- * As arguments -- llvm functions can take metadata as arguments, for +-- example: +-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) +-- As with instructions, only metadata nodes or expressions can be attached. +-- +-- * As a named metadata -- Here the metadata is simply declared in global +-- scope using a specific name to communicate module level information to LLVM. +-- For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- + +-- | LLVM metadata expressions +data MetaExpr = MetaStr LMString + | MetaNode Int + | MetaVar LlvmVar + | MetaStruct [MetaExpr] + deriving (Eq) + +instance Outputable MetaExpr where + ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"' + ppr (MetaNode n ) = text "metadata !" <> int n + ppr (MetaVar v ) = ppr v + ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}' + +-- | Associates some metadata with a specific label for attaching to an +-- instruction. +data MetaAnnot = MetaAnnot LMString MetaExpr + deriving (Eq) + +-- | Metadata declarations. Metadata can only be declared in global scope. +data MetaDecl + -- | Named metadata. Only used for communicating module information to + -- LLVM. ('!name = !{ [!] }' form). + = MetaNamed LMString [Int] + -- | Metadata node declaration. + -- ('!0 = metadata !{ }' form). + | MetaUnamed Int MetaExpr diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs new file mode 100644 index 00000000..73077257 --- /dev/null +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | Pretty print LLVM IR Code. +-- + +module Llvm.PpLlvm ( + + -- * Top level LLVM objects. + ppLlvmModule, + ppLlvmComments, + ppLlvmComment, + ppLlvmGlobals, + ppLlvmGlobal, + ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, + ppLlvmFunctionDecls, + ppLlvmFunctionDecl, + ppLlvmFunctions, + ppLlvmFunction, + + ) where + +#include "HsVersions.h" + +import Llvm.AbsSyn +import Llvm.MetaData +import Llvm.Types + +import Data.List ( intersperse ) +import Outputable +import Unique +import FastString ( sLit ) + +-------------------------------------------------------------------------------- +-- * Top Level Print functions +-------------------------------------------------------------------------------- + +-- | Print out a whole LLVM module. +ppLlvmModule :: LlvmModule -> SDoc +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $+$ newLine + $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine + $+$ ppLlvmGlobals globals $+$ newLine + $+$ ppLlvmFunctionDecls decls $+$ newLine + $+$ ppLlvmFunctions funcs + +-- | Print out a multi-line comment, can be inside a function or on its own +ppLlvmComments :: [LMString] -> SDoc +ppLlvmComments comments = vcat $ map ppLlvmComment comments + +-- | Print out a comment, can be inside a function or on its own +ppLlvmComment :: LMString -> SDoc +ppLlvmComment com = semi <+> ftext com + + +-- | Print out a list of global mutable variable definitions +ppLlvmGlobals :: [LMGlobal] -> SDoc +ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls + +-- | Print out a global mutable variable definition +ppLlvmGlobal :: LMGlobal -> SDoc +ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = + let sect = case x of + Just x' -> text ", section" <+> doubleQuotes (ftext x') + Nothing -> empty + + align = case a of + Just a' -> text ", align" <+> int a' + Nothing -> empty + + rhs = case dat of + Just stat -> ppr stat + Nothing -> ppr (pLower $ getVarType var) + + -- Position of linkage is different for aliases. + const_link = case c of + Global -> ppr link <+> text "global" + Constant -> ppr link <+> text "constant" + Alias -> text "alias" <+> ppr link + + in ppAssignment var $ const_link <+> rhs <> sect <> align + $+$ newLine + +ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags -> + error $ "Non Global var ppr as global! " + ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val) + + +-- | Print out a list of LLVM type aliases. +ppLlvmAliases :: [LlvmAlias] -> SDoc +ppLlvmAliases tys = vcat $ map ppLlvmAlias tys + +-- | Print out an LLVM type alias. +ppLlvmAlias :: LlvmAlias -> SDoc +ppLlvmAlias (name, ty) + = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [MetaDecl] -> SDoc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: MetaDecl -> SDoc +ppLlvmMeta (MetaUnamed n m) + = exclamation <> int n <> text " = " <> ppLlvmMetaExpr m + +ppLlvmMeta (MetaNamed n m) + = exclamation <> ftext n <> text " = !" <> braces nodes + where + nodes = hcat $ intersperse comma $ map pprNode m + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaExpr :: MetaExpr -> SDoc +ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n +ppLlvmMetaExpr (MetaVar v ) = ppr v +ppLlvmMetaExpr (MetaStruct es) = + text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}' + + +-- | Print out a list of function definitions. +ppLlvmFunctions :: LlvmFunctions -> SDoc +ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs + +-- | Print out a function definition. +ppLlvmFunction :: LlvmFunction -> SDoc +ppLlvmFunction (LlvmFunction dec args attrs sec body) = + let attrDoc = ppSpaceJoin attrs + secDoc = case sec of + Just s' -> text "section" <+> (doubleQuotes $ ftext s') + Nothing -> empty + in text "define" <+> ppLlvmFunctionHeader dec args + <+> attrDoc <+> secDoc + $+$ lbrace + $+$ ppLlvmBlocks body + $+$ rbrace + $+$ newLine + $+$ newLine + +-- | Print out a function defenition header. +ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc +ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args + = let varg' = case varg of + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + align = case a of + Just a' -> text " align " <> ppr a' + Nothing -> empty + args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' + <> ftext n) + (zip p args) + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> + (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align + +-- | Print out a list of function declaration. +ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc +ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs + +-- | Print out a function declaration. +-- Declarations define the function type but don't define the actual body of +-- the function. +ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + align = case a of + Just a' -> text " align" <+> ppr a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> ppr t <+> ppSpaceJoin a) p + in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> + ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine + + +-- | Print out a list of LLVM blocks. +ppLlvmBlocks :: LlvmBlocks -> SDoc +ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks + +-- | Print out an LLVM block. +-- It must be part of a function definition. +ppLlvmBlock :: LlvmBlock -> SDoc +ppLlvmBlock (LlvmBlock blockId stmts) = + let isLabel (MkLabel _) = True + isLabel _ = False + (block, rest) = break isLabel stmts + ppRest = case rest of + MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs) + _ -> empty + in ppLlvmBlockLabel blockId + $+$ (vcat $ map ppLlvmStatement block) + $+$ newLine + $+$ ppRest + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> SDoc +ppLlvmBlockLabel id = pprUnique id <> colon + + +-- | Print out an LLVM statement. +ppLlvmStatement :: LlvmStatement -> SDoc +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Fence st ord -> ind $ ppFence st ord + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments + MkLabel label -> ppLlvmBlockLabel label + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" + Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s + + +-- | Print out an LLVM expression. +ppLlvmExpression :: LlvmExpression -> SDoc +ppLlvmExpression expr + = case expr of + Alloca tp amount -> ppAlloca tp amount + LlvmOp op left right -> ppMachOp op left right + Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs + CallM tp fp args attrs -> ppCall tp fp args attrs + Cast op from to -> ppCast op from to + Compare op left right -> ppCmpOp op left right + Extract vec idx -> ppExtract vec idx + Insert vec elt idx -> ppInsert vec elt idx + GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes + Load ptr -> ppLoad ptr + ALoad ord st ptr -> ppALoad ord st ptr + Malloc tp amount -> ppMalloc tp amount + Phi tp precessors -> ppPhi tp precessors + Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MExpr meta expr -> ppMetaExpr meta expr + + +-------------------------------------------------------------------------------- +-- * Individual print functions +-------------------------------------------------------------------------------- + +-- | Should always be a function pointer. So a global var of function type +-- (since globals are always pointers) or a local var of pointer function type. +ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc +ppCall ct fptr args attrs = case fptr of + -- + -- if local var function pointer, unwrap + LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d + + -- should be function type otherwise + LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d + + -- not pointer or function, so error + _other -> error $ "ppCall called with non LMFunction type!\nMust be " + ++ " called with either global var of function type or " + ++ "local var of pointer function type." + + where + ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = + let tc = if ct == TailCall then text "tail " else empty + ppValues = ppCommaJoin args + ppArgTy = (ppCommaJoin $ map fst params) <> + (case argTy of + VarArgs -> text ", ..." + FixedArgs -> empty) + fnty = space <> lparen <> ppArgTy <> rparen <> char '*' + attrDoc = ppSpaceJoin attrs + in tc <> text "call" <+> ppr cc <+> ppr ret + <> fnty <+> ppName fptr <> lparen <+> ppValues + <+> rparen <+> attrDoc + + +ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc +ppMachOp op left right = + (ppr op) <+> (ppr (getVarType left)) <+> ppName left + <> comma <+> ppName right + + +ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc +ppCmpOp op left right = + let cmpOp + | isInt (getVarType left) && isInt (getVarType right) = text "icmp" + | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = text "icmp" -- Just continue as its much easier to debug + {- + | otherwise = error ("can't compare different types, left = " + ++ (show $ getVarType left) ++ ", right = " + ++ (show $ getVarType right)) + -} + in cmpOp <+> ppr op <+> ppr (getVarType left) + <+> ppName left <> comma <+> ppName right + + +ppAssignment :: LlvmVar -> SDoc -> SDoc +ppAssignment var expr = ppName var <+> equals <+> expr + +ppFence :: Bool -> LlvmSyncOrdering -> SDoc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord + +ppSyncOrdering :: LlvmSyncOrdering -> SDoc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" + +-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but +-- we have no way of guaranteeing that this is true with GHC (we would need to +-- modify the layout of the stack and closures, change the storage manager, +-- etc.). So, we blindly tell LLVM that *any* vector store or load could be +-- unaligned. In the future we may be able to guarantee that certain vector +-- access patterns are aligned, in which case we will need a more granular way +-- of specifying alignment. + +ppLoad :: LlvmVar -> SDoc +ppLoad var = text "load" <+> ppr var <> align + where + align | isVector . pLower . getVarType $ var = text ", align 1" + | otherwise = empty + +ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad ord st var = sdocWithDynFlags $ \dflags -> + let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8 + align = text ", align" <+> ppr alignment + sThreaded | st = text " singlethread" + | otherwise = empty + in text "load atomic" <+> ppr var <> sThreaded <+> ppSyncOrdering ord <> align + +ppStore :: LlvmVar -> LlvmVar -> SDoc +ppStore val dst + | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <> + comma <+> text "align 1" + | otherwise = text "store" <+> ppr val <> comma <+> ppr dst + where + isVecPtrVar :: LlvmVar -> Bool + isVecPtrVar = isVector . pLower . getVarType + + +ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc +ppCast op from to + = ppr op + <+> ppr (getVarType from) <+> ppName from + <+> text "to" + <+> ppr to + + +ppMalloc :: LlvmType -> Int -> SDoc +ppMalloc tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "malloc" <+> ppr tp <> comma <+> ppr amount' + + +ppAlloca :: LlvmType -> Int -> SDoc +ppAlloca tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in text "alloca" <+> ppr tp <> comma <+> ppr amount' + + +ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc +ppGetElementPtr inb ptr idx = + let indexes = comma <+> ppCommaJoin idx + inbound = if inb then text "inbounds" else empty + in text "getelementptr" <+> inbound <+> ppr ptr <> indexes + + +ppReturn :: Maybe LlvmVar -> SDoc +ppReturn (Just var) = text "ret" <+> ppr var +ppReturn Nothing = text "ret" <+> ppr LMVoid + + +ppBranch :: LlvmVar -> SDoc +ppBranch var = text "br" <+> ppr var + + +ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppBranchIf cond trueT falseT + = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT + + +ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc +ppPhi tp preds = + let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label + in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) + + +ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc +ppSwitch scrut dflt targets = + let ppTarget (val, lab) = ppr val <> comma <+> ppr lab + ppTargets xs = brackets $ vcat (map ppTarget xs) + in text "switch" <+> ppr scrut <> comma <+> ppr dflt + <+> ppTargets targets + + +ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc +ppAsm asm constraints rty vars sideeffect alignstack = + let asm' = doubleQuotes $ ftext asm + cons = doubleQuotes $ ftext constraints + rty' = ppr rty + vars' = lparen <+> ppCommaJoin vars <+> rparen + side = if sideeffect then text "sideeffect" else empty + align = if alignstack then text "alignstack" else empty + in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma + <+> cons <> vars' + +ppExtract :: LlvmVar -> LlvmVar -> SDoc +ppExtract vec idx = + text "extractelement" + <+> ppr (getVarType vec) <+> ppName vec <> comma + <+> ppr idx + +ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppInsert vec elt idx = + text "insertelement" + <+> ppr (getVarType vec) <+> ppName vec <> comma + <+> ppr (getVarType elt) <+> ppName elt <> comma + <+> ppr idx + + +ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta + +ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta + +ppMetaAnnots :: [MetaAnnot] -> SDoc +ppMetaAnnots meta = hcat $ map ppMeta meta + where + ppMeta (MetaAnnot name e) + = comma <+> exclamation <> ftext name <+> + case e of + MetaNode n -> exclamation <> int n + MetaStruct ms -> exclamation <> braces (ppCommaJoin ms) + other -> exclamation <> braces (ppr other) -- possible? + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +-- | Blank line. +newLine :: SDoc +newLine = empty + +-- | Exclamation point. +exclamation :: SDoc +exclamation = char '!' diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs new file mode 100644 index 00000000..a9d81a18 --- /dev/null +++ b/compiler/llvmGen/Llvm/Types.hs @@ -0,0 +1,839 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + +-------------------------------------------------------------------------------- +-- | The LLVM Type System. +-- + +module Llvm.Types where + +#include "HsVersions.h" + +import Data.Char +import Data.Int +import Numeric + +import DynFlags +import FastString +import Outputable +import Unique + +-- from NCG +import PprBase + +import GHC.Float + +-- ----------------------------------------------------------------------------- +-- * LLVM Basic Types and Variables +-- + +-- | A global mutable variable. Maybe defined or external +data LMGlobal = LMGlobal { + getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' + getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' + } + +-- | A String in LLVM +type LMString = FastString + +-- | A type alias +type LlvmAlias = (LMString, LlvmType) + +-- | Llvm Types +data LlvmType + = LMInt Int -- ^ An integer with a given width in bits. + | LMFloat -- ^ 32 bit floating point + | LMDouble -- ^ 64 bit floating point + | LMFloat80 -- ^ 80 bit (x86 only) floating point + | LMFloat128 -- ^ 128 bit floating point + | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' + | LMArray Int LlvmType -- ^ An array of 'LlvmType' + | LMVector Int LlvmType -- ^ A vector of 'LlvmType' + | LMLabel -- ^ A 'LlvmVar' can represent a label (address) + | LMVoid -- ^ Void type + | LMStruct [LlvmType] -- ^ Structure type + | LMAlias LlvmAlias -- ^ A type alias + | LMMetadata -- ^ LLVM Metadata + + -- | Function type, used to create pointers to functions + | LMFunction LlvmFunctionDecl + deriving (Eq) + +instance Outputable LlvmType where + ppr (LMInt size ) = char 'i' <> ppr size + ppr (LMFloat ) = text "float" + ppr (LMDouble ) = text "double" + ppr (LMFloat80 ) = text "x86_fp80" + ppr (LMFloat128 ) = text "fp128" + ppr (LMPointer x ) = ppr x <> char '*' + ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' + ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' + ppr (LMLabel ) = text "label" + ppr (LMVoid ) = text "void" + ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>" + ppr (LMMetadata ) = text "metadata" + + ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) + = ppr r <+> lparen <> ppParams varg p <> rparen + + ppr (LMAlias (s,_)) = char '%' <> ftext s + +ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc +ppParams varg p + = let varg' = case varg of + VarArgs | null args -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + -- by default we don't print param attributes + args = map fst p + in ppCommaJoin args <> ptext varg' + +-- | An LLVM section definition. If Nothing then let LLVM decide the section +type LMSection = Maybe LMString +type LMAlign = Maybe Int + +data LMConst = Global -- ^ Mutable global variable + | Constant -- ^ Constant global variable + | Alias -- ^ Alias of another variable + deriving (Eq) + +-- | LLVM Variables +data LlvmVar + -- | Variables with a global scope. + = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst + -- | Variables local to a function or parameters. + | LMLocalVar Unique LlvmType + -- | Named local variables. Sometimes we need to be able to explicitly name + -- variables (e.g for function arguments). + | LMNLocalVar LMString LlvmType + -- | A constant variable + | LMLitVar LlvmLit + deriving (Eq) + +instance Outputable LlvmVar where + ppr (LMLitVar x) = ppr x + ppr (x ) = ppr (getVarType x) <+> ppName x + + +-- | Llvm Literal Data. +-- +-- These can be used inline in expressions. +data LlvmLit + -- | Refers to an integer constant (i64 42). + = LMIntLit Integer LlvmType + -- | Floating point literal + | LMFloatLit Double LlvmType + -- | Literal NULL, only applicable to pointer types + | LMNullLit LlvmType + -- | Vector literal + | LMVectorLit [LlvmLit] + -- | Undefined value, random bit pattern. Useful for optimisations. + | LMUndefLit LlvmType + deriving (Eq) + +instance Outputable LlvmLit where + ppr l@(LMVectorLit {}) = ppLit l + ppr l = ppr (getLitType l) <+> ppLit l + + +-- | Llvm Static Data. +-- +-- These represent the possible global level variables and constants. +data LlvmStatic + = LMComment LMString -- ^ A comment in a static section + | LMStaticLit LlvmLit -- ^ A static variant of a literal value + | LMUninitType LlvmType -- ^ For uninitialised data + | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' + | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array + | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type + | LMStaticPointer LlvmVar -- ^ A pointer to other data + + -- static expressions, could split out but leave + -- for moment for ease of use. Not many of them. + + | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion + | LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion + | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation + | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation + +instance Outputable LlvmStatic where + ppr (LMComment s) = text "; " <> ftext s + ppr (LMStaticLit l ) = ppr l + ppr (LMUninitType t) = ppr t <> text " undef" + ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\"" + ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']' + ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>" + ppr (LMStaticPointer v) = ppr v + ppr (LMBitc v t) + = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')' + ppr (LMPtoI v t) + = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')' + + ppr (LMAdd s1 s2) + = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd" + ppr (LMSub s1 s2) + = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub" + +pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc +pprStaticArith s1 s2 int_op float_op op_name = + let ty1 = getStatType s1 + op = if isFloat ty1 then float_op else int_op + in if ty1 == getStatType s2 + then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen + else sdocWithDynFlags $ \dflags -> + error $ op_name ++ " with different types! s1: " + ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2) + +-- ----------------------------------------------------------------------------- +-- ** Operations on LLVM Basic Types and Variables +-- + +-- | Return the variable name or value of the 'LlvmVar' +-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). +ppName :: LlvmVar -> SDoc +ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v +ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v +ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v +ppName v@(LMLitVar {}) = ppPlainName v + +-- | Return the variable name or value of the 'LlvmVar' +-- in a plain textual representation (e.g. @x@, @y@ or @42@). +ppPlainName :: LlvmVar -> SDoc +ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x +ppPlainName (LMLocalVar x LMLabel ) = text (show x) +ppPlainName (LMLocalVar x _ ) = text ('l' : show x) +ppPlainName (LMNLocalVar x _ ) = ftext x +ppPlainName (LMLitVar x ) = ppLit x + +-- | Print a literal value. No type. +ppLit :: LlvmLit -> SDoc +ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32) +ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64) +ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int) +ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r +ppLit (LMFloatLit r LMDouble) = ppDouble r +ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags -> + error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f)) +ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>' +ppLit (LMNullLit _ ) = text "null" +ppLit (LMUndefLit _ ) = text "undef" + +-- | Return the 'LlvmType' of the 'LlvmVar' +getVarType :: LlvmVar -> LlvmType +getVarType (LMGlobalVar _ y _ _ _ _) = y +getVarType (LMLocalVar _ y ) = y +getVarType (LMNLocalVar _ y ) = y +getVarType (LMLitVar l ) = getLitType l + +-- | Return the 'LlvmType' of a 'LlvmLit' +getLitType :: LlvmLit -> LlvmType +getLitType (LMIntLit _ t) = t +getLitType (LMFloatLit _ t) = t +getLitType (LMVectorLit []) = panic "getLitType" +getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) +getLitType (LMNullLit t) = t +getLitType (LMUndefLit t) = t + +-- | Return the 'LlvmType' of the 'LlvmStatic' +getStatType :: LlvmStatic -> LlvmType +getStatType (LMStaticLit l ) = getLitType l +getStatType (LMUninitType t) = t +getStatType (LMStaticStr _ t) = t +getStatType (LMStaticArray _ t) = t +getStatType (LMStaticStruc _ t) = t +getStatType (LMStaticPointer v) = getVarType v +getStatType (LMBitc _ t) = t +getStatType (LMPtoI _ t) = t +getStatType (LMAdd t _) = getStatType t +getStatType (LMSub t _) = getStatType t +getStatType (LMComment _) = error "Can't call getStatType on LMComment!" + +-- | Return the 'LlvmLinkageType' for a 'LlvmVar' +getLink :: LlvmVar -> LlvmLinkageType +getLink (LMGlobalVar _ _ l _ _ _) = l +getLink _ = Internal + +-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' +-- cannot be lifted. +pLift :: LlvmType -> LlvmType +pLift LMLabel = error "Labels are unliftable" +pLift LMVoid = error "Voids are unliftable" +pLift LMMetadata = error "Metadatas are unliftable" +pLift x = LMPointer x + +-- | Lower a variable of 'LMPointer' type. +pVarLift :: LlvmVar -> LlvmVar +pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c +pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) +pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) +pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" + +-- | Remove the pointer indirection of the supplied type. Only 'LMPointer' +-- constructors can be lowered. +pLower :: LlvmType -> LlvmType +pLower (LMPointer x) = x +pLower x = pprPanic "llvmGen(pLower)" + $ ppr x <+> text " is a unlowerable type, need a pointer" + +-- | Lower a variable of 'LMPointer' type. +pVarLower :: LlvmVar -> LlvmVar +pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c +pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) +pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) +pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" + +-- | Test if the given 'LlvmType' is an integer +isInt :: LlvmType -> Bool +isInt (LMInt _) = True +isInt _ = False + +-- | Test if the given 'LlvmType' is a floating point type +isFloat :: LlvmType -> Bool +isFloat LMFloat = True +isFloat LMDouble = True +isFloat LMFloat80 = True +isFloat LMFloat128 = True +isFloat _ = False + +-- | Test if the given 'LlvmType' is an 'LMPointer' construct +isPointer :: LlvmType -> Bool +isPointer (LMPointer _) = True +isPointer _ = False + +-- | Test if the given 'LlvmType' is an 'LMVector' construct +isVector :: LlvmType -> Bool +isVector (LMVector {}) = True +isVector _ = False + +-- | Test if a 'LlvmVar' is global. +isGlobal :: LlvmVar -> Bool +isGlobal (LMGlobalVar _ _ _ _ _ _) = True +isGlobal _ = False + +-- | Width in bits of an 'LlvmType', returns 0 if not applicable +llvmWidthInBits :: DynFlags -> LlvmType -> Int +llvmWidthInBits _ (LMInt n) = n +llvmWidthInBits _ (LMFloat) = 32 +llvmWidthInBits _ (LMDouble) = 64 +llvmWidthInBits _ (LMFloat80) = 80 +llvmWidthInBits _ (LMFloat128) = 128 +-- Could return either a pointer width here or the width of what +-- it points to. We will go with the former for now. +-- PMW: At least judging by the way LLVM outputs constants, pointers +-- should use the former, but arrays the latter. +llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t +llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty +llvmWidthInBits _ LMLabel = 0 +llvmWidthInBits _ LMVoid = 0 +llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys +llvmWidthInBits _ (LMFunction _) = 0 +llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t +llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!" + + +-- ----------------------------------------------------------------------------- +-- ** Shortcut for Common Types +-- + +i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType +i128 = LMInt 128 +i64 = LMInt 64 +i32 = LMInt 32 +i16 = LMInt 16 +i8 = LMInt 8 +i1 = LMInt 1 +i8Ptr = pLift i8 + +-- | The target architectures word size +llvmWord, llvmWordPtr :: DynFlags -> LlvmType +llvmWord dflags = LMInt (wORD_SIZE dflags * 8) +llvmWordPtr dflags = pLift (llvmWord dflags) + +-- ----------------------------------------------------------------------------- +-- * LLVM Function Types +-- + +-- | An LLVM Function +data LlvmFunctionDecl = LlvmFunctionDecl { + -- | Unique identifier of the function + decName :: LMString, + -- | LinkageType of the function + funcLinkage :: LlvmLinkageType, + -- | The calling convention of the function + funcCc :: LlvmCallConvention, + -- | Type of the returned value + decReturnType :: LlvmType, + -- | Indicates if this function uses varargs + decVarargs :: LlvmParameterListType, + -- | Parameter types and attributes + decParams :: [LlvmParameter], + -- | Function align value, must be power of 2 + funcAlign :: LMAlign + } + deriving (Eq) + +instance Outputable LlvmFunctionDecl where + ppr (LlvmFunctionDecl n l c r varg p a) + = let align = case a of + Just a' -> text " align " <> ppr a' + Nothing -> empty + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> + lparen <> ppParams varg p <> rparen <> align + +type LlvmFunctionDecls = [LlvmFunctionDecl] + +type LlvmParameter = (LlvmType, [LlvmParamAttr]) + +-- | LLVM Parameter Attributes. +-- +-- Parameter attributes are used to communicate additional information about +-- the result or parameters of a function +data LlvmParamAttr + -- | This indicates to the code generator that the parameter or return value + -- should be zero-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + = ZeroExt + -- | This indicates to the code generator that the parameter or return value + -- should be sign-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + | SignExt + -- | This indicates that this parameter or return value should be treated in + -- a special target-dependent fashion during while emitting code for a + -- function call or return (usually, by putting it in a register as opposed + -- to memory). + | InReg + -- | This indicates that the pointer parameter should really be passed by + -- value to the function. + | ByVal + -- | This indicates that the pointer parameter specifies the address of a + -- structure that is the return value of the function in the source program. + | SRet + -- | This indicates that the pointer does not alias any global or any other + -- parameter. + | NoAlias + -- | This indicates that the callee does not make any copies of the pointer + -- that outlive the callee itself + | NoCapture + -- | This indicates that the pointer parameter can be excised using the + -- trampoline intrinsics. + | Nest + deriving (Eq) + +instance Outputable LlvmParamAttr where + ppr ZeroExt = text "zeroext" + ppr SignExt = text "signext" + ppr InReg = text "inreg" + ppr ByVal = text "byval" + ppr SRet = text "sret" + ppr NoAlias = text "noalias" + ppr NoCapture = text "nocapture" + ppr Nest = text "nest" + +-- | Llvm Function Attributes. +-- +-- Function attributes are set to communicate additional information about a +-- function. Function attributes are considered to be part of the function, +-- not of the function type, so functions with different parameter attributes +-- can have the same function type. Functions can have multiple attributes. +-- +-- Descriptions taken from +data LlvmFuncAttr + -- | This attribute indicates that the inliner should attempt to inline this + -- function into callers whenever possible, ignoring any active inlining + -- size threshold for this caller. + = AlwaysInline + -- | This attribute indicates that the source code contained a hint that + -- inlining this function is desirable (such as the \"inline\" keyword in + -- C/C++). It is just a hint; it imposes no requirements on the inliner. + | InlineHint + -- | This attribute indicates that the inliner should never inline this + -- function in any situation. This attribute may not be used together + -- with the alwaysinline attribute. + | NoInline + -- | This attribute suggests that optimization passes and code generator + -- passes make choices that keep the code size of this function low, and + -- otherwise do optimizations specifically to reduce code size. + | OptSize + -- | This function attribute indicates that the function never returns + -- normally. This produces undefined behavior at runtime if the function + -- ever does dynamically return. + | NoReturn + -- | This function attribute indicates that the function never returns with + -- an unwind or exceptional control flow. If the function does unwind, its + -- runtime behavior is undefined. + | NoUnwind + -- | This attribute indicates that the function computes its result (or + -- decides to unwind an exception) based strictly on its arguments, without + -- dereferencing any pointer arguments or otherwise accessing any mutable + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It does not write through any pointer arguments (including byval + -- arguments) and never changes any state visible to callers. This means + -- that it cannot unwind exceptions by calling the C++ exception throwing + -- methods, but could use the unwind instruction. + | ReadNone + -- | This attribute indicates that the function does not write through any + -- pointer arguments (including byval arguments) or otherwise modify any + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It may dereference pointer arguments and read state that may be set in + -- the caller. A readonly function always returns the same value (or unwinds + -- an exception identically) when called with the same set of arguments and + -- global state. It cannot unwind an exception by calling the C++ exception + -- throwing methods, but may use the unwind instruction. + | ReadOnly + -- | This attribute indicates that the function should emit a stack smashing + -- protector. It is in the form of a \"canary\"—a random value placed on the + -- stack before the local variables that's checked upon return from the + -- function to see if it has been overwritten. A heuristic is used to + -- determine if a function needs stack protectors or not. + -- + -- If a function that has an ssp attribute is inlined into a function that + -- doesn't have an ssp attribute, then the resulting function will have an + -- ssp attribute. + | Ssp + -- | This attribute indicates that the function should always emit a stack + -- smashing protector. This overrides the ssp function attribute. + -- + -- If a function that has an sspreq attribute is inlined into a function + -- that doesn't have an sspreq attribute or which has an ssp attribute, + -- then the resulting function will have an sspreq attribute. + | SspReq + -- | This attribute indicates that the code generator should not use a red + -- zone, even if the target-specific ABI normally permits it. + | NoRedZone + -- | This attributes disables implicit floating point instructions. + | NoImplicitFloat + -- | This attribute disables prologue / epilogue emission for the function. + -- This can have very system-specific consequences. + | Naked + deriving (Eq) + +instance Outputable LlvmFuncAttr where + ppr AlwaysInline = text "alwaysinline" + ppr InlineHint = text "inlinehint" + ppr NoInline = text "noinline" + ppr OptSize = text "optsize" + ppr NoReturn = text "noreturn" + ppr NoUnwind = text "nounwind" + ppr ReadNone = text "readnon" + ppr ReadOnly = text "readonly" + ppr Ssp = text "ssp" + ppr SspReq = text "ssqreq" + ppr NoRedZone = text "noredzone" + ppr NoImplicitFloat = text "noimplicitfloat" + ppr Naked = text "naked" + + +-- | Different types to call a function. +data LlvmCallType + -- | Normal call, allocate a new stack frame. + = StdCall + -- | Tail call, perform the call in the current stack frame. + | TailCall + deriving (Eq,Show) + +-- | Different calling conventions a function can use. +data LlvmCallConvention + -- | The C calling convention. + -- This calling convention (the default if no other calling convention is + -- specified) matches the target C calling conventions. This calling + -- convention supports varargs function calls and tolerates some mismatch in + -- the declared prototype and implemented declaration of the function (as + -- does normal C). + = CC_Ccc + -- | This calling convention attempts to make calls as fast as possible + -- (e.g. by passing things in registers). This calling convention allows + -- the target to use whatever tricks it wants to produce fast code for the + -- target, without having to conform to an externally specified ABI + -- (Application Binary Interface). Implementations of this convention should + -- allow arbitrary tail call optimization to be supported. This calling + -- convention does not support varargs and requires the prototype of al + -- callees to exactly match the prototype of the function definition. + | CC_Fastcc + -- | This calling convention attempts to make code in the caller as efficient + -- as possible under the assumption that the call is not commonly executed. + -- As such, these calls often preserve all registers so that the call does + -- not break any live ranges in the caller side. This calling convention + -- does not support varargs and requires the prototype of all callees to + -- exactly match the prototype of the function definition. + | CC_Coldcc + -- | Any calling convention may be specified by number, allowing + -- target-specific calling conventions to be used. Target specific calling + -- conventions start at 64. + | CC_Ncc Int + -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it + -- rather than just using CC_Ncc. + | CC_X86_Stdcc + deriving (Eq) + +instance Outputable LlvmCallConvention where + ppr CC_Ccc = text "ccc" + ppr CC_Fastcc = text "fastcc" + ppr CC_Coldcc = text "coldcc" + ppr (CC_Ncc i) = text "cc " <> ppr i + ppr CC_X86_Stdcc = text "x86_stdcallcc" + + +-- | Functions can have a fixed amount of parameters, or a variable amount. +data LlvmParameterListType + -- Fixed amount of arguments. + = FixedArgs + -- Variable amount of arguments. + | VarArgs + deriving (Eq,Show) + + +-- | Linkage type of a symbol. +-- +-- The description of the constructors is copied from the Llvm Assembly Language +-- Reference Manual , because +-- they correspond to the Llvm linkage types. +data LlvmLinkageType + -- | Global values with internal linkage are only directly accessible by + -- objects in the current module. In particular, linking code into a module + -- with an internal global value may cause the internal to be renamed as + -- necessary to avoid collisions. Because the symbol is internal to the + -- module, all references can be updated. This corresponds to the notion + -- of the @static@ keyword in C. + = Internal + -- | Globals with @linkonce@ linkage are merged with other globals of the + -- same name when linkage occurs. This is typically used to implement + -- inline functions, templates, or other code which must be generated + -- in each translation unit that uses it. Unreferenced linkonce globals are + -- allowed to be discarded. + | LinkOnce + -- | @weak@ linkage is exactly the same as linkonce linkage, except that + -- unreferenced weak globals may not be discarded. This is used for globals + -- that may be emitted in multiple translation units, but that are not + -- guaranteed to be emitted into every translation unit that uses them. One + -- example of this are common globals in C, such as @int X;@ at global + -- scope. + | Weak + -- | @appending@ linkage may only be applied to global variables of pointer + -- to array type. When two global variables with appending linkage are + -- linked together, the two global arrays are appended together. This is + -- the Llvm, typesafe, equivalent of having the system linker append + -- together @sections@ with identical names when .o files are linked. + | Appending + -- | The semantics of this linkage follow the ELF model: the symbol is weak + -- until linked, if not linked, the symbol becomes null instead of being an + -- undefined reference. + | ExternWeak + -- | The symbol participates in linkage and can be used to resolve external + -- symbol references. + | ExternallyVisible + -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM + -- assembly. + | External + -- | Symbol is private to the module and should not appear in the symbol table + | Private + deriving (Eq) + +instance Outputable LlvmLinkageType where + ppr Internal = text "internal" + ppr LinkOnce = text "linkonce" + ppr Weak = text "weak" + ppr Appending = text "appending" + ppr ExternWeak = text "extern_weak" + -- ExternallyVisible does not have a textual representation, it is + -- the linkage type a function resolves to if no other is specified + -- in Llvm. + ppr ExternallyVisible = empty + ppr External = text "external" + ppr Private = text "private" + +-- ----------------------------------------------------------------------------- +-- * LLVM Operations +-- + +-- | Llvm binary operators machine operations. +data LlvmMachOp + = LM_MO_Add -- ^ add two integer, floating point or vector values. + | LM_MO_Sub -- ^ subtract two ... + | LM_MO_Mul -- ^ multiply .. + | LM_MO_UDiv -- ^ unsigned integer or vector division. + | LM_MO_SDiv -- ^ signed integer .. + | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) + | LM_MO_SRem -- ^ signed ... + + | LM_MO_FAdd -- ^ add two floating point or vector values. + | LM_MO_FSub -- ^ subtract two ... + | LM_MO_FMul -- ^ multiply ... + | LM_MO_FDiv -- ^ divide ... + | LM_MO_FRem -- ^ remainder ... + + -- | Left shift + | LM_MO_Shl + -- | Logical shift right + -- Shift right, filling with zero + | LM_MO_LShr + -- | Arithmetic shift right + -- The most significant bits of the result will be equal to the sign bit of + -- the left operand. + | LM_MO_AShr + + | LM_MO_And -- ^ AND bitwise logical operation. + | LM_MO_Or -- ^ OR bitwise logical operation. + | LM_MO_Xor -- ^ XOR bitwise logical operation. + deriving (Eq) + +instance Outputable LlvmMachOp where + ppr LM_MO_Add = text "add" + ppr LM_MO_Sub = text "sub" + ppr LM_MO_Mul = text "mul" + ppr LM_MO_UDiv = text "udiv" + ppr LM_MO_SDiv = text "sdiv" + ppr LM_MO_URem = text "urem" + ppr LM_MO_SRem = text "srem" + ppr LM_MO_FAdd = text "fadd" + ppr LM_MO_FSub = text "fsub" + ppr LM_MO_FMul = text "fmul" + ppr LM_MO_FDiv = text "fdiv" + ppr LM_MO_FRem = text "frem" + ppr LM_MO_Shl = text "shl" + ppr LM_MO_LShr = text "lshr" + ppr LM_MO_AShr = text "ashr" + ppr LM_MO_And = text "and" + ppr LM_MO_Or = text "or" + ppr LM_MO_Xor = text "xor" + + +-- | Llvm compare operations. +data LlvmCmpOp + = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) + | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) + | LM_CMP_Ugt -- ^ Unsigned greater than + | LM_CMP_Uge -- ^ Unsigned greater than or equal + | LM_CMP_Ult -- ^ Unsigned less than + | LM_CMP_Ule -- ^ Unsigned less than or equal + | LM_CMP_Sgt -- ^ Signed greater than + | LM_CMP_Sge -- ^ Signed greater than or equal + | LM_CMP_Slt -- ^ Signed less than + | LM_CMP_Sle -- ^ Signed less than or equal + + -- Float comparisons. GHC uses a mix of ordered and unordered float + -- comparisons. + | LM_CMP_Feq -- ^ Float equal + | LM_CMP_Fne -- ^ Float not equal + | LM_CMP_Fgt -- ^ Float greater than + | LM_CMP_Fge -- ^ Float greater than or equal + | LM_CMP_Flt -- ^ Float less than + | LM_CMP_Fle -- ^ Float less than or equal + deriving (Eq) + +instance Outputable LlvmCmpOp where + ppr LM_CMP_Eq = text "eq" + ppr LM_CMP_Ne = text "ne" + ppr LM_CMP_Ugt = text "ugt" + ppr LM_CMP_Uge = text "uge" + ppr LM_CMP_Ult = text "ult" + ppr LM_CMP_Ule = text "ule" + ppr LM_CMP_Sgt = text "sgt" + ppr LM_CMP_Sge = text "sge" + ppr LM_CMP_Slt = text "slt" + ppr LM_CMP_Sle = text "sle" + ppr LM_CMP_Feq = text "oeq" + ppr LM_CMP_Fne = text "une" + ppr LM_CMP_Fgt = text "ogt" + ppr LM_CMP_Fge = text "oge" + ppr LM_CMP_Flt = text "olt" + ppr LM_CMP_Fle = text "ole" + + +-- | Llvm cast operations. +data LlvmCastOp + = LM_Trunc -- ^ Integer truncate + | LM_Zext -- ^ Integer extend (zero fill) + | LM_Sext -- ^ Integer extend (sign fill) + | LM_Fptrunc -- ^ Float truncate + | LM_Fpext -- ^ Float extend + | LM_Fptoui -- ^ Float to unsigned Integer + | LM_Fptosi -- ^ Float to signed Integer + | LM_Uitofp -- ^ Unsigned Integer to Float + | LM_Sitofp -- ^ Signed Int to Float + | LM_Ptrtoint -- ^ Pointer to Integer + | LM_Inttoptr -- ^ Integer to Pointer + | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed + deriving (Eq) + +instance Outputable LlvmCastOp where + ppr LM_Trunc = text "trunc" + ppr LM_Zext = text "zext" + ppr LM_Sext = text "sext" + ppr LM_Fptrunc = text "fptrunc" + ppr LM_Fpext = text "fpext" + ppr LM_Fptoui = text "fptoui" + ppr LM_Fptosi = text "fptosi" + ppr LM_Uitofp = text "uitofp" + ppr LM_Sitofp = text "sitofp" + ppr LM_Ptrtoint = text "ptrtoint" + ppr LM_Inttoptr = text "inttoptr" + ppr LM_Bitcast = text "bitcast" + + +-- ----------------------------------------------------------------------------- +-- * Floating point conversion +-- + +-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In +-- Llvm float literals can be printed in a big-endian hexadecimal format, +-- regardless of underlying architecture. +-- +-- See Note [LLVM Float Types]. +ppDouble :: Double -> SDoc +ppDouble d + = let bs = doubleToBytes d + hex d' = case showHex d' "" of + [] -> error "dToStr: too few hex digits for float" + [x] -> ['0',x] + [x,y] -> [x,y] + _ -> error "dToStr: too many hex digits for float" + + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str + +-- Note [LLVM Float Types] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- We use 'ppDouble' for both printing Float and Double floating point types. This is +-- as LLVM expects all floating point constants (single & double) to be in IEEE +-- 754 Double precision format. However, for single precision numbers (Float) +-- they should be *representable* in IEEE 754 Single precision format. So the +-- easiest way to do this is to narrow and widen again. +-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC +-- doesn't optimize that away. + +-- Note [narrowFp & widenFp] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NOTE: we use float2Double & co directly as GHC likes to optimize away +-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600). +-- 'realToFrac' has inconsistent behaviour with optimisation as well that can +-- also cause issues, these methods don't. + +narrowFp :: Double -> Float +{-# NOINLINE narrowFp #-} +narrowFp = double2Float + +widenFp :: Float -> Double +{-# NOINLINE widenFp #-} +widenFp = float2Double + +ppFloat :: Float -> SDoc +ppFloat = ppDouble . widenFp + +-- | Reverse or leave byte data alone to fix endianness on this target. +fixEndian :: [a] -> [a] +#ifdef WORDS_BIGENDIAN +fixEndian = id +#else +fixEndian = reverse +#endif + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +ppCommaJoin :: (Outputable a) => [a] -> SDoc +ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) + +ppSpaceJoin :: (Outputable a) => [a] -> SDoc +ppSpaceJoin strs = hsep (map ppr strs) diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs new file mode 100644 index 00000000..6120a72d --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + +-- ----------------------------------------------------------------------------- +-- | This is the top-level module in the LLVM code generator. +-- +module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base +import LlvmCodeGen.CodeGen +import LlvmCodeGen.Data +import LlvmCodeGen.Ppr +import LlvmCodeGen.Regs +import LlvmMangler + +import CgUtils ( fixStgRegisters ) +import Cmm +import Hoopl +import PprCmm + +import BufWrite +import DynFlags +import ErrUtils +import FastString +import Outputable +import UniqSupply +import SysTools ( figureLlvmVersion ) +import qualified Stream + +import Control.Monad ( when ) +import Data.IORef ( writeIORef ) +import Data.Maybe ( fromMaybe, catMaybes ) +import System.IO + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM Code generator +-- +llvmCodeGen :: DynFlags -> Handle -> UniqSupply + -> Stream.Stream IO RawCmmGroup () + -> IO () +llvmCodeGen dflags h us cmm_stream + = do bufh <- newBufHandle h + + -- Pass header + showPass dflags "LLVM CodeGen" + + -- get llvm version, cache for later use + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + writeIORef (llvmVersion dflags) ver + + -- warn if unsupported + debugTraceMsg dflags 2 + (text "Using LLVM version:" <+> text (show ver)) + let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + when (ver < minSupportLlvmVersion && doWarn) $ + errorMsg dflags (text "You are using an old version of LLVM that" + <> text " isn't supported anymore!" + $+$ text "We will try though...") + when (ver > maxSupportLlvmVersion && doWarn) $ + putMsg dflags (text "You are using a new version of LLVM that" + <> text " hasn't been tested yet!" + $+$ text "We will try though...") + + -- run code generation + runLlvm dflags ver bufh us $ + llvmCodeGen' (liftStream cmm_stream) + + bFlush bufh + +llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM () +llvmCodeGen' cmm_stream + = do -- Preamble + renderLlvm pprLlvmHeader + ghcInternalFunctions + cmmMetaLlvmPrelude + + -- Procedures + let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream + _ <- Stream.collect llvmStream + + -- Declare aliases for forward references + renderLlvm . pprLlvmData =<< generateExternDecls + + -- Postamble + cmmUsedLlvmGens + +llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () +llvmGroupLlvmGens cmm = do + + -- Insert functions into map, collect data + let split (CmmData s d' ) = return $ Just (s, d') + split (CmmProc h l live g) = do + -- Set function type + let l' = case mapLookup (g_entry g) h of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy live + return Nothing + cdata <- fmap catMaybes $ mapM split cmm + + {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens cdata + {-# SCC "llvm_procs_gen" #-} + mapM_ cmmLlvmGen cmm + +-- ----------------------------------------------------------------------------- +-- | Do LLVM code generation on all these Cmms data sections. +-- +cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () + +cmmDataLlvmGens statics + = do lmdatas <- mapM genLlvmData statics + + let (gss, tss) = unzip lmdatas + + let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) + = funInsert l ty + regGlobal _ = return () + mapM_ regGlobal (concat gss) + gss' <- mapM aliasify $ concat gss + + renderLlvm $ pprLlvmData (concat gss', concat tss) + +-- | Complete LLVM code generation phase for a single top-level chunk of Cmm. +cmmLlvmGen ::RawCmmDecl -> LlvmM () +cmmLlvmGen cmm@CmmProc{} = do + + -- rewrite assignments to global regs + dflags <- getDynFlag id + let fixed_cmm = {-# SCC "llvm_fix_regs" #-} + fixStgRegisters dflags cmm + + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) + + -- generate llvm code from cmm + llvmBC <- withClearVars $ genLlvmProc fixed_cmm + + -- allocate IDs for info table and code, so the mangler can later + -- make sure they end up next to each other. + itableSection <- freshSectionId + _codeSection <- freshSectionId + + -- pretty print + (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC + + -- Output, note down used variables + renderLlvm (vcat docs) + mapM_ markUsedVar $ concat ivars + +cmmLlvmGen _ = return () + +-- ----------------------------------------------------------------------------- +-- | Generate meta data nodes +-- + +cmmMetaLlvmPrelude :: LlvmM () +cmmMetaLlvmPrelude = do + metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + -- Generate / lookup meta data IDs + tbaaId <- getMetaUniqueId + setUniqMeta uniq tbaaId + parentId <- maybe (return Nothing) getUniqMeta parent + -- Build definition + return $ MetaUnamed tbaaId $ MetaStruct + [ MetaStr name + , case parentId of + Just p -> MetaNode p + Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr + ] + renderLlvm $ ppLlvmMetas metas + +-- ----------------------------------------------------------------------------- +-- | Marks variables as used where necessary +-- + +cmmUsedLlvmGens :: LlvmM () +cmmUsedLlvmGens = do + + -- LLVM would discard variables that are internal and not obviously + -- used if we didn't provide these hints. This will generate a + -- definition of the form + -- + -- @llvm.used = appending global [42 x i8*] [i8* bitcast to i8*, ...] + -- + -- Which is the LLVM way of protecting them against getting removed. + ivars <- getUsedVars + let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars) i8Ptr) + usedArray = LMStaticArray (map cast ivars) ty + sectName = Just $ fsLit "llvm.metadata" + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsed = LMGlobal lmUsedVar (Just usedArray) + if null ivars + then return () + else renderLlvm $ pprLlvmData ([lmUsed], []) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs new file mode 100644 index 00000000..83b06a9a --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- | Base LLVM Code Generation module +-- +-- Contains functions useful through out the code generator. +-- + +module LlvmCodeGen.Base ( + + LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, + LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + + LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, + maxSupportLlvmVersion, + + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, + dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars, + ghcInternalFunctions, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + freshSectionId, + + cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, + llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, + llvmPtrBits, mkLlvmFunc, tysToParams, + + strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + getGlobalPtr, generateExternDecls, + + aliasify, + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Regs + +import CLabel +import CodeGen.Platform ( activeStgRegs ) +import DynFlags +import FastString +import Cmm +import qualified Outputable as Outp +import qualified Pretty as Prt +import Platform +import UniqFM +import Unique +import BufWrite ( BufHandle ) +import UniqSet +import UniqSupply +import ErrUtils +import qualified Stream + +import Control.Monad (ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +-- ---------------------------------------------------------------------------- +-- * Some Data Types +-- + +type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) +type LlvmBasicBlock = GenBasicBlock LlvmStatement + +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] + +-- | Unresolved code. +-- Of the form: (data label, data type, unresolved data) +type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) + +-- | Top level LLVM Data (globals and type aliases) +type LlvmData = ([LMGlobal], [LlvmType]) + +-- | An unresolved Label. +-- +-- Labels are unresolved when we haven't yet determined if they are defined in +-- the module we are currently compiling, or an external one. +type UnresLabel = CmmLit +type UnresStatic = Either UnresLabel LlvmStatic + +-- ---------------------------------------------------------------------------- +-- * Type translations +-- + +-- | Translate a basic CmmType to an LlvmType. +cmmToLlvmType :: CmmType -> LlvmType +cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) + | isFloatType ty = widthToLlvmFloat $ typeWidth ty + | otherwise = widthToLlvmInt $ typeWidth ty + +-- | Translate a Cmm Float Width to a LlvmType. +widthToLlvmFloat :: Width -> LlvmType +widthToLlvmFloat W32 = LMFloat +widthToLlvmFloat W64 = LMDouble +widthToLlvmFloat W80 = LMFloat80 +widthToLlvmFloat W128 = LMFloat128 +widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w + +-- | Translate a Cmm Bit Width to a LlvmType. +widthToLlvmInt :: Width -> LlvmType +widthToLlvmInt w = LMInt $ widthInBits w + +-- | GHC Call Convention for LLVM +llvmGhcCC :: DynFlags -> LlvmCallConvention +llvmGhcCC dflags + | platformUnregisterised (targetPlatform dflags) = CC_Ccc + | otherwise = CC_Ncc 10 + +-- | Llvm Function type for Cmm function +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible + +-- | Llvm Function signature +llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + dflags <- getDynFlags + return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs dflags live)) + (llvmFunAlign dflags) + +-- | Create a Haskell function in LLVM. +mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks + -> LlvmM LlvmFunction +mkLlvmFunc live lbl link sec blks + = do funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live) + return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks + +-- | Alignment to use for functions +llvmFunAlign :: DynFlags -> LMAlign +llvmFunAlign dflags = Just (wORD_SIZE dflags) + +-- | Alignment to use for into tables +llvmInfAlign :: DynFlags -> LMAlign +llvmInfAlign dflags = Just (wORD_SIZE dflags) + +-- | A Function's arguments +llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] +llvmFunArgs dflags live = + map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) + where platform = targetPlatform dflags + isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live + isPassed r = not (isSSE r) || isLive r + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE (YmmReg _) = True + isSSE (ZmmReg _) = True + isSSE _ = False + +-- | Llvm standard fun attributes +llvmStdFunAttrs :: [LlvmFuncAttr] +llvmStdFunAttrs = [NoUnwind] + +-- | Convert a list of types to a list of function parameters +-- (each with no parameter attributes) +tysToParams :: [LlvmType] -> [LlvmParameter] +tysToParams = map (\ty -> (ty, [])) + +-- | Pointer width +llvmPtrBits :: DynFlags -> Int +llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags + +-- ---------------------------------------------------------------------------- +-- * Llvm Version +-- + +-- | LLVM Version Number +type LlvmVersion = Int + +-- | The LLVM Version we assume if we don't know +defaultLlvmVersion :: LlvmVersion +defaultLlvmVersion = 30 + +minSupportLlvmVersion :: LlvmVersion +minSupportLlvmVersion = 28 + +maxSupportLlvmVersion :: LlvmVersion +maxSupportLlvmVersion = 35 + +-- ---------------------------------------------------------------------------- +-- * Environment Handling +-- + +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envDynFlags :: DynFlags -- ^ Dynamic flags + , envOutput :: BufHandle -- ^ Output buffer + , envUniq :: UniqSupply -- ^ Supply of unique values + , envNextSection :: Int -- ^ Supply of fresh section IDs + , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + } + +type LlvmEnvMap = UniqFM LlvmType + +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } + +instance Functor LlvmM where + fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env + return (f x, env') + +instance Applicative LlvmM where + pure = return + (<*>) = ap + +instance Monad LlvmM where + return x = LlvmM $ \env -> return (x, env) + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' + +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () +runLlvm dflags ver out us m = do + _ <- runLlvmM m env + return () + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envDynFlags = dflags + , envOutput = out + , envUniq = us + , envFreshMeta = 0 + , envUniqMeta = emptyUFM + , envNextSection = 1 + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Lift a stream into the LlvmM monad +liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x +liftStream s = Stream.Stream $ do + r <- liftIO $ Stream.runStream s + case r of + Left b -> return (Left b) + Right (a, r2) -> return (Right (a, liftStream r2)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM s . envVarMap) +funLookup s = getEnv (flip lookupUFM s . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalReg -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM Bool +checkStackReg r = getEnv ((elem r) . envStackRegs) + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM Int +getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1}) + +-- | Get the LLVM version we are generating code for +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion + +-- | Get the platform we are generating code for +getDynFlag :: (DynFlags -> a) -> LlvmM a +getDynFlag f = getEnv (f . envDynFlags) + +-- | Get the platform we are generating code for +getLlvmPlatform :: LlvmM Platform +getLlvmPlatform = getDynFlag targetPlatform + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr doc = do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags flag hdr doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = do + + -- Write to output + dflags <- getDynFlags + out <- getEnv envOutput + let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc + liftIO $ Prt.bufLeftRender out doc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc + return () + +-- | Run a @UniqSM@ action with our unique supply +runUs :: UniqSM a -> LlvmM a +runUs m = LlvmM $ \env -> do + let (x, us') = initUs (envUniq env) m + return (x, env { envUniq = us' }) + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> Int -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe Int) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- | Returns a fresh section ID +freshSectionId :: LlvmM Int +freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1}) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- + +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes trac #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + dflags <- getDynFlags + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n `appendFS` fsLit "$def" + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm $ ppLlvmFunctionDecl decl + funInsert n' (LMFunction decl) + +-- ---------------------------------------------------------------------------- +-- * Label handling +-- + +-- | Pretty print a 'CLabel'. +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) + return (fsLit str) + +strDisplayName_llvm :: CLabel -> LlvmM LMString +strDisplayName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit (dropInfoSuffix str)) + +dropInfoSuffix :: String -> String +dropInfoSuffix = go + where go "_info" = [] + go "_static_info" = [] + go "_con_info" = [] + go (x:xs) = x:go xs + go [] = [] + +strProcedureName_llvm :: CLabel -> LlvmM LMString +strProcedureName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle Outp.neverQualify depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar llvmLbl i8 Alias + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) +generateExternDecls = do + delayed <- fmap uniqSetToList $ getEnv envAliases + defss <- flip mapM delayed $ \lbl -> do + m_ty <- funLookup lbl + case m_ty of + -- If we have a definition we've already emitted the proper aliases + -- when the symbol itself was emitted by @aliasify@ + Just _ -> return [] + + -- If we don't have a definition this is an external symbol and we + -- need to emit a declaration + Nothing -> + let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global + in return [LMGlobal var Nothing] + + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- | Here we take a global variable definition, rename it with a +-- @$def@ suffix, and generate the appropriate alias. +aliasify :: LMGlobal -> LlvmM [LMGlobal] +aliasify (LMGlobal var val) = do + let i8Ptr = LMPointer (LMInt 8) + LMGlobalVar lbl ty link sect align const = var + + defLbl = lbl `appendFS` fsLit "$def" + defVar = LMGlobalVar defLbl ty Internal sect align const + + defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const + aliasVar = LMGlobalVar lbl (LMPointer i8Ptr) link Nothing Nothing Alias + aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr + + -- we need to mark the $def symbols as used so LLVM doesn't forget which + -- section they need to go in. This will vanish once we switch away from + -- mangling sections for TNTC. + markUsedVar defVar + + return [ LMGlobal defVar val + , LMGlobal aliasVar (Just aliasVal) + ] + +-- Note [Llvm Forward References] +-- +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. +-- +-- In particular when we encounter a reference to a symbol in a chunk of +-- C-- there are three possible scenarios, +-- +-- 1. We have already seen a definition for the referenced symbol. This +-- means we already know its type. +-- +-- 2. We have not yet seen a definition but we will find one later in this +-- compilation unit. Since we want to be a good consumer of the +-- C-- streamed to us from upstream, we don't know the type of the +-- symbol at the time when we must emit the reference. +-- +-- 3. We have not yet seen a definition nor will we find one in this +-- compilation unit. In this case the reference refers to an +-- external symbol for which we do not know the type. +-- +-- Let's consider case (2) for a moment: say we see a reference to +-- the symbol @fooBar@ for which we have not seen a definition. As we +-- do not know the symbol's type, we assume it is of type @i8*@ and emit +-- the appropriate casts in @getSymbolPtr@. Later on, when we +-- encounter the definition of @fooBar@ we emit it but with a modified +-- name, @fooBar$def@ (which we'll call the definition symbol), to +-- since we have already had to assume that the symbol @fooBar@ +-- is of type @i8*@. We then emit @fooBar@ itself as an alias +-- of @fooBar$def@ with appropriate casts. This all happens in +-- @aliasify@. +-- +-- Case (3) is quite similar to (2): References are emitted assuming +-- the referenced symbol is of type @i8*@. When we arrive at the end of +-- the compilation unit and realize that the symbol is external, we emit +-- an LLVM @external global@ declaration for the symbol @fooBar@ +-- (handled in @generateExternDecls@). This takes advantage of the +-- fact that the aliases produced by @aliasify@ for exported symbols +-- have external linkage and can therefore be used as normal symbols. +-- +-- Historical note: As of release 3.5 LLVM does not allow aliases to +-- refer to declarations. This the reason why aliases are produced at the +-- point of definition instead of the point of usage, as was previously +-- done. See #9142 for details. +-- +-- Finally, case (1) is trival. As we already have a definition for +-- and therefore know the type of the referenced symbol, we can do +-- away with casting the alias to the desired type in @getSymbolPtr@ +-- and instead just emit a reference to the definition symbol directly. +-- This is the @Just@ case in @getSymbolPtr@. + +-- ---------------------------------------------------------------------------- +-- * Misc +-- + +-- | Error function +panic :: String -> a +panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs new file mode 100644 index 00000000..c7be2c31 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -0,0 +1,1693 @@ +{-# LANGUAGE CPP, GADTs #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmProc to LLVM code. +-- +module LlvmCodeGen.CodeGen ( genLlvmProc ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base +import LlvmCodeGen.Regs + +import BlockId +import CodeGen.Platform ( activeStgRegs, callerSaves ) +import CLabel +import Cmm +import CPrim +import PprCmm +import CmmUtils +import Hoopl + +import DynFlags +import FastString +import ForeignCall +import Outputable hiding ( panic, pprPanic ) +import qualified Outputable +import Platform +import OrdList +import UniqSupply +import Unique + +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) + +type Atomic = Bool +type LlvmStatements = OrdList LlvmStatement + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM proc Code generator +-- +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do + let blocks = toBlockListEntryFirstFalseFallthrough graph + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks + let info = mapLookup (g_entry graph) infos + proc = CmmProc info lbl live (ListGraph lmblocks) + return (proc:lmdata) + +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" + +-- ----------------------------------------------------------------------------- +-- * Block code generation +-- + +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is exepected to be the entry +-- point and will get the prologue. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live (entryBlock:cmmBlocks) + = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) + + -- Generate code + (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks + + -- Compose + let entryBlock = BasicBlock bid (fromOL prologue ++ entry) + return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) + + +-- | Generate code for one block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block + = do let (_, nodes, tail) = blockSplit block + id = entryLabel block + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (BasicBlock id instrs, top' ++ top) + +-- ----------------------------------------------------------------------------- +-- * CmmNode code generation +-- + +-- A statement conversion return data. +-- * LlvmStatements: The compiled LLVM statements. +-- * LlvmCmmDecl: Any global data needed. +type StmtData = (LlvmStatements, [LlvmCmmDecl]) + + +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) + + +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of + + CmmComment _ -> return (nilOL, []) -- nuke comments + CmmTick _ -> return (nilOL, []) + CmmUnwind {} -> return (nilOL, []) + + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src + + CmmBranch id -> genBranch id + CmmCondBranch arg true false + -> genCondBranch arg true false + CmmSwitch arg ids -> genSwitch arg ids + + -- Foreign Call + CmmUnsafeForeignCall target res args + -> genCall target res args + + -- Tail call + CmmCall { cml_target = arg, + cml_args_regs = live } -> genJump arg live + + _ -> panic "Llvm.CodeGen.stmtToInstrs" + +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + return [CmmData Data [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + +-- | Memory barrier instruction for LLVM >= 3.0 +barrier :: LlvmM StmtData +barrier = do + let s = Fence False SyncSeqCst + return (unitOL s, []) + +-- | Memory barrier instruction for LLVM < 3.0 +oldBarrier :: LlvmM StmtData +oldBarrier = do + + (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1] + + let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] + let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs + + return (unitOL s1, tops) + + where + lmTrue :: LlvmVar + lmTrue = mkIntLit i1 (-1) + +-- | Foreign Calls +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData + +-- Write barrier needs to be handled specially as it is implemented as an LLVM +-- intrinsic function. +genCall (PrimTarget MO_WriteBarrier) _ _ = do + platform <- getLlvmPlatform + ver <- getLlvmVer + case () of + _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] + -> return (nilOL, []) + | ver > 29 -> barrier + | otherwise -> oldBarrier + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do + dstV <- getCmmReg (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst + width = widthToLlvmFloat w + castV <- mkLocalVar ty + (ve, stmts, top) <- exprToVar e + let stmt3 = Assignment castV $ Cast LM_Uitofp ve width + stmt4 = Store castV dstV + return (stmts `snocOL` stmt3 `snocOL` stmt4, top) + +genCall (PrimTarget (MO_UF_Conv _)) [_] args = + panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ + "Can only handle 1, given" ++ show (length args) ++ "." + +-- Handle prefetching data +genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args + | 0 <= localityInt && localityInt <= 3 = do + ver <- getLlvmVer + let argTy | ver <= 29 = [i8Ptr, i32, i32] + | otherwise = [i8Ptr, i32, i32, i32] + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints' = zip args arg_hints + (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + trash <- getTrashStmts + let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 localityInt] + | otherwise = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] + call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] + stmts = stmts1 `appOL` stmts2 `appOL` stmts3 + `appOL` trash `snocOL` call + return (stmts, top1 ++ top2) + | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) + +-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg +-- and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Clz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Ctz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args + +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do + dstV <- getCmmReg (CmmLocal dst) + (v1, stmts, top) <- genLoad True addr (localRegType dst) + let stmt1 = Store v1 dstV + return (stmts `snocOL` stmt1, top) + +-- TODO: implement these properly rather than calling to RTS functions. +-- genCall t@(PrimTarget (MO_AtomicWrite width)) [] [addr, val] = undefined +-- genCall t@(PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = undefined +-- genCall t@(PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = undefined + +-- Handle memcpy function specifically since llvm's intrinsic version takes +-- some extra parameters. +genCall t@(PrimTarget op) [] args' + | op == MO_Memcpy || + op == MO_Memset || + op == MO_Memmove = do + ver <- getLlvmVer + dflags <- getDynFlags + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) + | ver >= 28 = ([i1], [mkIntLit i1 0]) + | otherwise = ([], []) + argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + stmts4 <- getTrashStmts + let arguments = argVars' ++ (alignVal:isVolVal) + call = Expr $ Call StdCall fptr arguments [] + stmts = stmts1 `appOL` stmts2 `appOL` stmts3 + `appOL` stmts4 `snocOL` call + return (stmts, top1 ++ top2) + where + splitAlignVal xs = (init xs, extractLit $ last xs) + + -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other + -- than a direct constant (i.e. 'i32 8') as the alignment argument for the + -- memcpy & co llvm intrinsic functions. So we handle this directly now. + extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i + extractLit _other = trace ("WARNING: Non constant alignment value given" ++ + " for memcpy! Please report to GHC developers") + mkIntLit i32 0 + +-- Handle all other foreign calls and prim ops. +genCall target res args = do + + dflags <- getDynFlags + + -- parameter types + let arg_type (_, AddrHint) = i8Ptr + -- cast pointers to i8*. Llvm equivalent of void* + arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr + + -- ret type + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg + ret_type t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + + -- extract Cmm call convention, and translate to LLVM call convention + platform <- getLlvmPlatform + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> case platformArch platform of + ArchX86 -> CC_X86_Stdcc + ArchX86_64 -> CC_X86_Stdcc + _ -> CC_Ccc + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" + JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv" + + PrimTarget _ -> CC_Ccc + + {- + CC_Ccc of the possibilities here are a worry with the use of a custom + calling convention for passing STG args. In practice the more + dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. + + The native code generator only handles StdCall and CCallConv. + -} + + -- call attributes + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False + + -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints + let ccTy = StdCall -- tail calls should be done through CmmJump + let retTy = ret_type ress_hints + let argTy = tysToParams $ map arg_type args_hints + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy (llvmFunAlign dflags) + + + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy target + + let retStmt | ccTy == TailCall = unitOL $ Return Nothing + | never_returns = unitOL $ Unreachable + | otherwise = nilOL + + stmts3 <- getTrashStmts + let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 + + -- make the actual call + case retTy of + LMVoid -> do + let s1 = Expr $ Call ccTy fptr argVars fnAttrs + let allStmts = stmts `snocOL` s1 `appOL` retStmt + return (allStmts, top1 ++ top2) + + _ -> do + (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs + -- get the return register + let ret_reg [reg] = reg + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." + let creg = ret_reg res + vreg <- getCmmReg (CmmLocal creg) + let allStmts = stmts `snocOL` s1 + if retTy == pLower (getVarType vreg) + then do + let s2 = Store v1 vreg + return (allStmts `snocOL` s2 `appOL` retStmt, + top1 ++ top2) + else do + let ty = pLower $ getVarType vreg + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + + (v2, s2) <- doExpr ty $ Cast op v1 ty + let s3 = Store v2 vreg + return (allStmts `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2) + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + ([retV'], stmts5) <- castVars [(retV,dstTy)] + let s2 = Store retV' dstV + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") + +-- | Create a function pointer from a target. +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) + + ForeignTarget expr _ -> do + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags + let fty = funTy $ fsLit "dynamic" + cast = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genCall: Expr is of bad type for function" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (v2, stmts `snocOL` s1, top) + + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty + +-- | Conversion of call arguments. +arg_vars :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) + +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags + let op = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + a -> panic $ "genCall: Can't cast llvmType to i8*! (" + ++ showSDoc dflags (ppr a) ++ ")" + + (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + tops ++ top') + +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') + + +-- | Cast a collection of LLVM variables to specific types. +castVars :: [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars + let (vars', stmts) = unzip done + return (vars', toOL stmts) + +-- | Cast an LLVM variable to a specific type, panicing if it can't be done. +castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t + = return (v, Nop) + + | otherwise + = do dflags <- getDynFlags + let op = case (getVarType v, t) of + (LMInt n, LMInt m) + -> if n < m then LM_Sext else LM_Trunc + (vt, _) | isFloat vt && isFloat t + -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t + then LM_Fpext else LM_Fptrunc + (vt, _) | isInt vt && isFloat t -> LM_Sitofp + (vt, _) | isFloat vt && isInt t -> LM_Fptosi + (vt, _) | isInt vt && isPointer t -> LM_Inttoptr + (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint + (vt, _) | isPointer vt && isPointer t -> LM_Bitcast + (vt, _) | isVector vt && isVector t -> LM_Bitcast + + (vt, _) -> panic $ "castVars: Can't cast this type (" + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t + + +-- | Decide what C function to use to implement a CallishMachOp +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + ver <- getLlvmVer + dflags <- getDynFlags + let intrinTy1 = (if ver >= 28 + then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = (if ver >= 28 + then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" + MO_F32_Pwr -> fsLit "llvm.pow.f32" + + MO_F32_Sin -> fsLit "llvm.sin.f32" + MO_F32_Cos -> fsLit "llvm.cos.f32" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" + MO_F64_Pwr -> fsLit "llvm.pow.f64" + + MO_F64_Sin -> fsLit "llvm.sin.f64" + MO_F64_Cos -> fsLit "llvm.cos.f64" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1 + MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 + MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 + + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + + (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + MO_UF_Conv _ -> unsupported + + MO_AtomicRead _ -> unsupported + + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + +-- | Tail function calls +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData + +-- Call to known function +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live + let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs + let s2 = Return Nothing + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + + +-- Call to unknown function / address +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags + + let cast = case getVarType vf of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genJump: Expr is of bad type for function call! (" + ++ showSDoc dflags (ppr ty) ++ ")" + + (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) + (stgRegs, stgStmts) <- funEpilogue live + let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs + let s3 = Return Nothing + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + top) + + +-- | CmmAssign operation +-- +-- We use stack allocated variables for CmmReg. The optimiser will replace +-- these with registers when possible. +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 + + let ty = (pLower . getVarType) vreg + dflags <- getDynFlags + case ty of + -- Some registers are pointer types, so need to cast value to pointer + LMPointer _ | getVarType vval == llvmWord dflags -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = Store v vreg + return (stmts `snocOL` s1 `snocOL` s2, top2) + + LMVector _ _ -> do + (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty + let s2 = Store v vreg + return (stmts `snocOL` s1 `snocOL` s2, top2) + + _ -> do + let s1 = Store vval vreg + return (stmts `snocOL` s1, top2) + + +-- | CmmStore operation +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val + +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val + +genStore addr@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (fromInteger n) val + +genStore addr@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (negate $ fromInteger n) val + +-- generic case +genStore addr val + = do other <- getTBAAMeta otherN + genStore_slow addr val other + +-- | CmmStore operation +-- This is a special case for storing to a global register pointer +-- offset such as I32[Sp+8]. +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (vval, stmts, top) <- exprToVar val + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case pLower grt == getVarType vval of + -- were fine + True -> do + let s3 = MetaStmt meta $ Store vval ptr + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3, top) + + -- cast to pointer type needed + False -> do + let ty = (pLift . getVarType) vval + (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty + let s4 = MetaStmt meta $ Store vval ptr' + return (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3 `snocOL` s4, top) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genStore_slow addr val meta + + +-- | CmmStore operation +-- Generic case. Uses casts and pointer arithmetic if needed. +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val + + let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags + case getVarType vaddr of + -- sometimes we need to cast an int to a pointer before storing + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do + (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty + let s2 = MetaStmt meta $ Store v vaddr + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + LMPointer _ -> do + let s1 = MetaStmt meta $ Store vval vaddr + return (stmts `snocOL` s1, top1 ++ top2) + + i@(LMInt _) | i == llvmWord dflags -> do + let vty = pLift $ getVarType vval + (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty + let s2 = MetaStmt meta $ Store vval vptr + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + other -> + pprPanic "genStore: ptr not right type!" + (PprCmm.pprExpr addr <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ + ", Var: " ++ showSDoc dflags (ppr vaddr))) + + +-- | Unconditional branch +genBranch :: BlockId -> LlvmM StmtData +genBranch id = + let label = blockIdToLlvm id + in return (unitOL $ Branch label, []) + + +-- | Conditional branch +genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData +genCondBranch cond idT idF = do + let labelT = blockIdToLlvm idT + let labelF = blockIdToLlvm idF + -- See Note [Literals and branch conditions]. + (vc, stmts, top) <- exprToVarOpt i1Option cond + if getVarType vc == i1 + then do + let s1 = BranchIf vc labelT labelF + return (stmts `snocOL` s1, top) + else do + dflags <- getDynFlags + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" + +{- Note [Literals and branch conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is important that whenever we generate branch conditions for +literals like '1', they are properly narrowed to an LLVM expression of +type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert +a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt +must be certain to return a properly narrowed type. genLit is +responsible for this, in the case of literal integers. + +Often, we won't see direct statements like: + + if(1) { + ... + } else { + ... + } + +at this point in the pipeline, because the Glorious Code Generator +will do trivial branch elimination in the sinking pass (among others,) +which will eliminate the expression entirely. + +However, it's certainly possible and reasonable for this to occur in +hand-written C-- code. Consider something like: + + #ifndef SOME_CONDITIONAL + #define CHECK_THING(x) 1 + #else + #define CHECK_THING(x) some_operation((x)) + #endif + + f() { + + if (CHECK_THING(xyz)) { + ... + } else { + ... + } + + } + +In such an instance, CHECK_THING might result in an *expression* in +one case, and a *literal* in the other, depending on what in +particular was #define'd. So we must be sure to properly narrow the +literal in this case to i1 as it won't be eliminated beforehand. + +For a real example of this, see ./rts/StgStdThunks.cmm + +-} + + + +-- | Switch branch +-- +-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'. +-- However, they may be defined one day, so we better document this behaviour. +genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData +genSwitch cond maybe_ids = do + (vc, stmts, top) <- exprToVar cond + let ty = getVarType vc + + let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] + let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs + -- out of range is undefined, so let's just branch to first label + let (_, defLbl) = head labels + + let s1 = Switch vc defLbl labels + return $ (stmts `snocOL` s1, top) + + +-- ----------------------------------------------------------------------------- +-- * CmmExpr code generation +-- + +-- | An expression conversion return data: +-- * LlvmVar: The var holding the result of the expression +-- * LlvmStatements: Any statements needed to evaluate the expression +-- * LlvmCmmDecl: Any global data needed for this expression +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) + +-- | Values which can be passed to 'exprToVar' to configure its +-- behaviour in certain circumstances. +-- +-- Currently just used for determining if a comparison should return +-- a boolean (i1) or a word. See Note [Literals and branch conditions]. +newtype EOption = EOption { i1Expected :: Bool } +-- XXX: EOption is an ugly and inefficient solution to this problem. + +-- | i1 type expected (condition scrutinee). +i1Option :: EOption +i1Option = EOption True + +-- | Word type expected (usual). +wordOption :: EOption +wordOption = EOption False + +-- | Convert a CmmExpr to a list of LlvmStatements with the result of the +-- expression being stored in the returned LlvmVar. +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption + +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of + + CmmLit lit + -> genLit opt lit + + CmmLoad e' ty + -> genLoad False e' ty + + -- Cmmreg in expression is the value, so must load. If you want actual + -- reg pointer, call getCmmReg directly. + CmmReg r -> do + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of + True -> do + -- Cmm wants the value, so pointer types must be cast to ints + dflags <- getDynFlags + (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) + return (v2, s1 `snocOL` s2, []) + + False -> return (v1, s1, []) + + CmmMachOp op exprs + -> genMachOp opt op exprs + + CmmRegOff r i + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) + + CmmStackSlot _ _ + -> panic "exprToVar: CmmStackSlot not supported!" + + +-- | Handle CmmMachOp expressions +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Unary Machop +genMachOp _ op [x] = case op of + + MO_Not w -> + let all1 = mkIntLit (widthToLlvmInt w) (-1) + in negate (widthToLlvmInt w) all1 LM_MO_Xor + + MO_S_Neg w -> + let all0 = mkIntLit (widthToLlvmInt w) 0 + in negate (widthToLlvmInt w) all0 LM_MO_Sub + + MO_F_Neg w -> + let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) + in negate (widthToLlvmFloat w) all0 LM_MO_FSub + + MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp + MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi + + MO_SS_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext + + MO_UU_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_FF_Conv from to + -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext + + MO_VS_Neg len w -> + let ty = widthToLlvmInt w + vecty = LMVector len ty + all0 = LMIntLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_Sub + + MO_VF_Neg len w -> + let ty = widthToLlvmFloat w + vecty = LMVector len ty + all0 = LMFloatLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_FSub + + -- Handle unsupported cases explicitly so we get a warning + -- of missing case when new MachOps added + MO_Add _ -> panicOp + MO_Mul _ -> panicOp + MO_Sub _ -> panicOp + MO_S_MulMayOflo _ -> panicOp + MO_S_Quot _ -> panicOp + MO_S_Rem _ -> panicOp + MO_U_MulMayOflo _ -> panicOp + MO_U_Quot _ -> panicOp + MO_U_Rem _ -> panicOp + + MO_Eq _ -> panicOp + MO_Ne _ -> panicOp + MO_S_Ge _ -> panicOp + MO_S_Gt _ -> panicOp + MO_S_Le _ -> panicOp + MO_S_Lt _ -> panicOp + MO_U_Ge _ -> panicOp + MO_U_Gt _ -> panicOp + MO_U_Le _ -> panicOp + MO_U_Lt _ -> panicOp + + MO_F_Add _ -> panicOp + MO_F_Sub _ -> panicOp + MO_F_Mul _ -> panicOp + MO_F_Quot _ -> panicOp + MO_F_Eq _ -> panicOp + MO_F_Ne _ -> panicOp + MO_F_Ge _ -> panicOp + MO_F_Gt _ -> panicOp + MO_F_Le _ -> panicOp + MO_F_Lt _ -> panicOp + + MO_And _ -> panicOp + MO_Or _ -> panicOp + MO_Xor _ -> panicOp + MO_Shl _ -> panicOp + MO_U_Shr _ -> panicOp + MO_S_Shr _ -> panicOp + + MO_V_Insert _ _ -> panicOp + MO_V_Extract _ _ -> panicOp + + MO_V_Add _ _ -> panicOp + MO_V_Sub _ _ -> panicOp + MO_V_Mul _ _ -> panicOp + + MO_VS_Quot _ _ -> panicOp + MO_VS_Rem _ _ -> panicOp + + MO_VU_Quot _ _ -> panicOp + MO_VU_Rem _ _ -> panicOp + + MO_VF_Insert _ _ -> panicOp + MO_VF_Extract _ _ -> panicOp + + MO_VF_Add _ _ -> panicOp + MO_VF_Sub _ _ -> panicOp + MO_VF_Mul _ _ -> panicOp + MO_VF_Quot _ _ -> panicOp + + where + negate ty v2 negOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx + return (v1, stmts `snocOL` s1, top) + + negateVec ty v2 negOp = do + (vx, stmts1, top) <- exprToVar x + ([vx'], stmts2) <- castVars [(vx, ty)] + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + + fiConv ty convOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ Cast convOp vx ty + return (v1, stmts `snocOL` s1, top) + + sameConv from ty reduce expand = do + x'@(vx, stmts, top) <- exprToVar x + let sameConv' op = do + (v1, s1) <- doExpr ty $ Cast op vx ty + return (v1, stmts `snocOL` s1, top) + dflags <- getDynFlags + let toWidth = llvmWidthInBits dflags ty + -- LLVM doesn't like trying to convert to same width, so + -- need to check for that as we do get Cmm code doing it. + case widthInBits from of + w | w < toWidth -> sameConv' expand + w | w > toWidth -> sameConv' reduce + _w -> return x' + + panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" + ++ "with one argument! (" ++ show op ++ ")" + +-- Handle GlobalRegs pointers +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e + +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e + +-- Generic case +genMachOp opt op e = genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This is a specialised method that handles Global register manipulations like +-- 'Sp - 16', using the getelementptr instruction. +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + dflags <- getDynFlags + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) + return (var, s1 `snocOL` s2 `snocOL` s3, []) + + False -> genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This handles all the cases not handle by the specialised genMachOp_fast. +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Element extraction +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) + where + ty = widthToLlvmInt w + +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) + where + ty = widthToLlvmFloat w + +-- Element insertion +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, + top1 ++ top2 ++ top3) + where + ty = LMVector l (widthToLlvmInt w) + +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, + top1 ++ top2 ++ top3) + where + ty = LMVector l (widthToLlvmFloat w) + +-- Binary MachOp +genMachOp_slow opt op [x, y] = case op of + + MO_Eq _ -> genBinComp opt LM_CMP_Eq + MO_Ne _ -> genBinComp opt LM_CMP_Ne + + MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt + MO_S_Ge _ -> genBinComp opt LM_CMP_Sge + MO_S_Lt _ -> genBinComp opt LM_CMP_Slt + MO_S_Le _ -> genBinComp opt LM_CMP_Sle + + MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt + MO_U_Ge _ -> genBinComp opt LM_CMP_Uge + MO_U_Lt _ -> genBinComp opt LM_CMP_Ult + MO_U_Le _ -> genBinComp opt LM_CMP_Ule + + MO_Add _ -> genBinMach LM_MO_Add + MO_Sub _ -> genBinMach LM_MO_Sub + MO_Mul _ -> genBinMach LM_MO_Mul + + MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" + + MO_S_MulMayOflo w -> isSMulOK w x y + + MO_S_Quot _ -> genBinMach LM_MO_SDiv + MO_S_Rem _ -> genBinMach LM_MO_SRem + + MO_U_Quot _ -> genBinMach LM_MO_UDiv + MO_U_Rem _ -> genBinMach LM_MO_URem + + MO_F_Eq _ -> genBinComp opt LM_CMP_Feq + MO_F_Ne _ -> genBinComp opt LM_CMP_Fne + MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt + MO_F_Ge _ -> genBinComp opt LM_CMP_Fge + MO_F_Lt _ -> genBinComp opt LM_CMP_Flt + MO_F_Le _ -> genBinComp opt LM_CMP_Fle + + MO_F_Add _ -> genBinMach LM_MO_FAdd + MO_F_Sub _ -> genBinMach LM_MO_FSub + MO_F_Mul _ -> genBinMach LM_MO_FMul + MO_F_Quot _ -> genBinMach LM_MO_FDiv + + MO_And _ -> genBinMach LM_MO_And + MO_Or _ -> genBinMach LM_MO_Or + MO_Xor _ -> genBinMach LM_MO_Xor + MO_Shl _ -> genBinMach LM_MO_Shl + MO_U_Shr _ -> genBinMach LM_MO_LShr + MO_S_Shr _ -> genBinMach LM_MO_AShr + + MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add + MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub + MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul + + MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv + MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem + + MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv + MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem + + MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd + MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub + MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul + MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv + + MO_Not _ -> panicOp + MO_S_Neg _ -> panicOp + MO_F_Neg _ -> panicOp + + MO_SF_Conv _ _ -> panicOp + MO_FS_Conv _ _ -> panicOp + MO_SS_Conv _ _ -> panicOp + MO_UU_Conv _ _ -> panicOp + MO_FF_Conv _ _ -> panicOp + + MO_V_Insert {} -> panicOp + MO_V_Extract {} -> panicOp + + MO_VS_Neg {} -> panicOp + + MO_VF_Insert {} -> panicOp + MO_VF_Extract {} -> panicOp + + MO_VF_Neg {} -> panicOp + + where + binLlvmOp ty binOp = do + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + if getVarType vx == getVarType vy + then do + (v1, s1) <- doExpr (ty vx) $ binOp vx vy + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, + top1 ++ top2) + + else do + -- Error. Continue anyway so we can debug the generated ll file. + dflags <- getDynFlags + let style = mkCodeStyle CStyle + toString doc = renderWithStyle dflags doc style + cmmToStr = (lines . toString . PprCmm.pprExpr) + let dx = Comment $ map fsLit $ cmmToStr x + let dy = Comment $ map fsLit $ cmmToStr y + (v1, s1) <- doExpr (ty vx) $ binOp vx vy + let allStmts = stmts1 `appOL` stmts2 `snocOL` dx + `snocOL` dy `snocOL` s1 + return (v1, allStmts, top1 ++ top2) + + binCastLlvmOp ty binOp = do + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)] + (v1, s1) <- doExpr ty $ binOp vx' vy' + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, + top1 ++ top2) + + -- | Need to use EOption here as Cmm expects word size results from + -- comparisons while LLVM return i1. Need to extend to llvmWord type + -- if expected. See Note [Literals and branch conditions]. + genBinComp opt cmp = do + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags + if getVarType v1 == i1 + then case i1Expected opt of + True -> return ed + False -> do + let w_ = llvmWord dflags + (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ + return (v2, stmts `snocOL` s1, top) + else + panic $ "genBinComp: Compare returned type other then i1! " + ++ (showSDoc dflags $ ppr $ getVarType v1) + + genBinMach op = binLlvmOp getVarType (LlvmOp op) + + genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) + + -- | Detect if overflow will occur in signed multiply of the two + -- CmmExpr's. This is the LLVM assembly equivalent of the NCG + -- implementation. Its much longer due to type information/safety. + -- This should actually compile to only about 3 asm instructions. + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData + isSMulOK _ x y = do + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + + dflags <- getDynFlags + let word = getVarType vx + let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) + let shift = llvmWidthInBits dflags word + let shift1 = toIWord dflags (shift - 1) + let shift2 = toIWord dflags shift + + if isInt word + then do + (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2 + (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2 + (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1 + (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word + (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1 + (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2 + (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word + (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 + let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 + `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 + return (dst, stmts1 `appOL` stmts2 `appOL` stmts, + top1 ++ top2) + + else + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" + + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" + ++ "with two arguments! (" ++ show op ++ ")" + +-- More then two expression, invalid! +genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" + + +-- | Handle CmmLoad expression. +genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData + +-- First we try to detect a few common cases and produce better code for +-- these then the default case. We are mostly trying to detect Cmm code +-- like I32[Sp + n] and use 'getelementptr' operations instead of the +-- generic case that uses casts and pointer arithmetic +genLoad atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty + +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty + +genLoad atomic e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (fromInteger n) ty + +genLoad atomic e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty + +-- generic case +genLoad atomic e ty + = do other <- getTBAAMeta otherN + genLoad_slow atomic e ty other + +-- | Handle CmmLoad expression. +-- This is a special case for loading from a global register pointer +-- offset such as I32[Sp+8]. +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic e r n ty = do + dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of + True -> do + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + -- We might need a different pointer type, so check + case grt == ty' of + -- were fine + True -> do + (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, + []) + + -- cast to pointer type needed + False -> do + let pty = pLift ty' + (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') + return (var, s1 `snocOL` s2 `snocOL` s3 + `snocOL` s4, []) + + -- If its a bit type then we use the slow method since + -- we can't avoid casting anyway. + False -> genLoad_slow atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = do + (iptr, stmts, tops) <- exprToVar e + dflags <- getDynFlags + case getVarType iptr of + LMPointer _ -> do + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MExpr meta $ loadInstr iptr) + return (dvar, stmts `snocOL` load, tops) + + i@(LMInt _) | i == llvmWord dflags -> do + let pty = LMPointer $ cmmToLlvmType ty + (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MExpr meta $ loadInstr ptr) + return (dvar, stmts `snocOL` cast `snocOL` load, tops) + + other -> do dflags <- getDynFlags + pprPanic "exprToVar: CmmLoad expression is not right type!" + (PprCmm.pprExpr e <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ + ", Var: " ++ showSDoc dflags (ppr iptr))) + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + if onStack + then return (lmGlobalRegVar dflags g) + else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + dflags <- getDynFlags + if onStack then loadFromStack else do + let r = lmGlobalRegArg dflags g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack +allocReg :: CmmReg -> (LlvmVar, LlvmStatements) +allocReg (CmmLocal (LocalReg un ty)) + = let ty' = cmmToLlvmType ty + var = LMLocalVar un (LMPointer ty') + alc = Alloca ty' 1 + in (var, unitOL $ Assignment var alc) + +allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" + ++ " have been handled elsewhere!" + + +-- | Generate code for a literal +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) + -- See Note [Literals and branch conditions]. + = let width | i1Expected opt = i1 + | otherwise = LMInt (widthInBits w) + -- comm = Comment [ fsLit $ "EOption: " ++ show opt + -- , fsLit $ "Width : " ++ show w + -- , fsLit $ "Width' : " ++ show (widthInBits w) + -- ] + in return (mkIntLit width i, nilOL, []) + +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), + nilOL, []) + +genLit opt (CmmVec ls) + = do llvmLits <- mapM toLlvmLit ls + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + (llvmLitVar, _, _) <- genLit opt lit + case llvmLitVar of + LMLitVar llvmLit -> return llvmLit + _ -> panic "genLit" + +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let lmty = cmmToLlvmType $ cmmLitType dflags cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + dflags <- getDynFlags + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) + let voff = toIWord dflags off + (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff + return (v1, stmts `snocOL` s1, stat) + +genLit opt (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) + let voff = toIWord dflags off + let ty1 = getVarType vl1 + let ty2 = getVarType vl2 + if (isInt ty1) && (isInt ty2) + && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) + + then do + (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 + (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff + return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + stat1 ++ stat2) + + else + panic "genLit: CmmLabelDiffOff encountered with different label ty!" + +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) + +genLit _ CmmHighStackMark + = panic "genStaticLit - CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allcoated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + trash <- getTrashRegs + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + -- Calls will trash all registers. Unfortunately, this needs them to + -- be stack-allocated in the first place. + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + dflags <- getDynFlags + stmtss <- flip mapM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar dflags r + arg = lmGlobalRegArg dflags r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss, []) + +-- | Function epilogue. Load STG variables to use as argument for call. +-- STG Liveness optimisation done here. +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + + -- Have information and liveness optimisation is enabled? + let liveRegs = alwaysLive ++ live + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE (YmmReg _) = True + isSSE (ZmmReg _) = True + isSSE _ = False + + -- Set to value or "undef" depending on whether the register is + -- actually live + dflags <- getDynFlags + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + platform <- getDynFlag targetPlatform + loads <- flip mapM (activeStgRegs platform) $ \r -> case () of + _ | r `elem` liveRegs -> loadExpr r + | not (isSSE r) -> loadUndef r + | otherwise -> return (Nothing, nilOL) + + let (vars, stmts) = unzip loads + return (catMaybes vars, concatOL stmts) + + +-- | A series of statements to trash all the STG registers. +-- +-- In LLVM we pass the STG registers around everywhere in function calls. +-- So this means LLVM considers them live across the entire function, when +-- in reality they usually aren't. For Caller save registers across C calls +-- the saving and restoring of them is done by the Cmm code generator, +-- using Cmm local vars. So to stop LLVM saving them as well (and saving +-- all of them since it thinks they're always live, we trash them just +-- before the call by assigning the 'undef' value to them. The ones we +-- need are restored from the Cmm local var and the ones we don't need +-- are fine to be trashed. +getTrashStmts :: LlvmM LlvmStatements +getTrashStmts = do + regs <- getTrashRegs + stmts <- flip mapM regs $ \ r -> do + reg <- getCmmReg (CmmGlobal r) + let ty = (pLower . getVarType) reg + return $ Store (LMLitVar $ LMUndefLit ty) reg + return $ toOL stmts + +getTrashRegs :: LlvmM [GlobalReg] +getTrashRegs = do plat <- getLlvmPlatform + return $ filter (callerSaves plat) (activeStgRegs plat) + +-- | Get a function pointer to the CLabel specified. +-- +-- This is for Haskell functions, function type is assumed, so doesn't work +-- with foreign functions. +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) + +-- | Create a new local var +mkLocalVar :: LlvmType -> LlvmM LlvmVar +mkLocalVar ty = do + un <- runUs getUniqueM + return $ LMLocalVar un ty + + +-- | Execute an expression, assigning result to a var +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) +doExpr ty expr = do + v <- mkLocalVar ty + return (v, Assignment v expr) + + +-- | Expand CmmRegOff +expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr +expandCmmReg dflags (reg, off) + = let width = typeWidth (cmmRegType dflags reg) + voff = CmmLit $ CmmInt (fromIntegral off) width + in CmmMachOp (MO_Add width) [CmmReg reg, voff] + + +-- | Convert a block id into a appropriate Llvm label +blockIdToLlvm :: BlockId -> LlvmVar +blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel + +-- | Create Llvm int Literal +mkIntLit :: Integral a => LlvmType -> a -> LlvmVar +mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty + +-- | Convert int type to a LLvmVar of word or i32 size +toI32 :: Integral a => a -> LlvmVar +toI32 = mkIntLit i32 + +toIWord :: Integral a => DynFlags -> a -> LlvmVar +toIWord dflags = mkIntLit (llvmWord dflags) + + +-- | Error functions +panic :: String -> a +panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s + +pprPanic :: String -> SDoc -> a +pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs new file mode 100644 index 00000000..90ce4436 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmData to LLVM code. +-- + +module LlvmCodeGen.Data ( + genLlvmData + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base + +import BlockId +import CLabel +import Cmm + +import FastString +import qualified Outputable + +-- ---------------------------------------------------------------------------- +-- * Constants +-- + +-- | The string appended to a variable name to create its structure type alias +structStr :: LMString +structStr = fsLit "_struct" + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData +genLlvmData (sec, Statics lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + let types = map getStatType static + + strucTy = LMStruct types + tyAlias = LMAlias ((label `appendFS` structStr), strucTy) + + struct = Just $ LMStaticStruc static tyAlias + link = if (externallyVisibleCLabel lbl) + then ExternallyVisible else Internal + const = if isSecConstant sec then Constant else Global + varDef = LMGlobalVar label tyAlias link Nothing Nothing const + globDef = LMGlobal varDef struct + + return ([globDef], [tyAlias]) + +-- | Should a data in this section be considered constant +isSecConstant :: Section -> Bool +isSecConstant Text = True +isSecConstant ReadOnlyData = True +isSecConstant RelocatableReadOnlyData = True +isSecConstant ReadOnlyData16 = True +isSecConstant Data = False +isSecConstant UninitialisedData = False +isSecConstant (OtherSection _) = False + + +-- ---------------------------------------------------------------------------- +-- * Generate static data +-- + +-- | Handle static data +genData :: CmmStatic -> LlvmM LlvmStatic + +genData (CmmString str) = do + let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str + ve = v ++ [LMStaticLit $ LMIntLit 0 i8] + return $ LMStaticArray ve (LMArray (length ve) i8) + +genData (CmmUninitialised bytes) + = return $ LMUninitType (LMArray bytes i8) + +genData (CmmStaticLit lit) + = genStaticLit lit + +-- | Generate Llvm code for a static literal. +-- +-- Will either generate the code or leave it unresolved if it is a 'CLabel' +-- which isn't yet known. +genStaticLit :: CmmLit -> LlvmM LlvmStatic +genStaticLit (CmmInt i w) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + +genStaticLit (CmmFloat r w) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + +genStaticLit (CmmVec ls) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" + +-- Leave unresolved, will fix later +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType dflags cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + dflags <- getDynFlags + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var = LMSub var1 var2 + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset + +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b + +genStaticLit (CmmHighStackMark) + = panic "genStaticLit: CmmHighStackMark unsupported!" + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Error Function +panic :: String -> a +panic s = Outputable.panic $ "LlvmCodeGen.Data." ++ s diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs new file mode 100644 index 00000000..97e43936 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- | Pretty print helpers for the LLVM Code generator. +-- +module LlvmCodeGen.Ppr ( + pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection, iTableSuf + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base +import LlvmCodeGen.Data + +import CLabel +import Cmm +import Platform + +import FastString +import Outputable +import Unique + + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Header code for LLVM modules +pprLlvmHeader :: SDoc +pprLlvmHeader = moduleLayout + + +-- | LLVM module layout description for the host target +moduleLayout :: SDoc +moduleLayout = sdocWithPlatform $ \platform -> + case platform of + Platform { platformArch = ArchX86, platformOS = OSDarwin } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\"" + $+$ text "target triple = \"i386-apple-darwin9.8\"" + Platform { platformArch = ArchX86, platformOS = OSMinGW32 } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" + $+$ text "target triple = \"i686-pc-win32\"" + Platform { platformArch = ArchX86, platformOS = OSLinux } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\"" + $+$ text "target triple = \"i386-pc-linux-gnu\"" + Platform { platformArch = ArchX86_64, platformOS = OSDarwin } -> + text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" + $+$ text "target triple = \"x86_64-apple-darwin10.0.0\"" + Platform { platformArch = ArchX86_64, platformOS = OSLinux } -> + text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\"" + $+$ text "target triple = \"x86_64-linux-gnu\"" + Platform { platformArch = ArchARM {}, platformOS = OSLinux } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\"" + Platform { platformArch = ArchARM {}, platformOS = OSAndroid } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-unknown-linux-androideabi\"" + Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\"" + Platform { platformArch = ArchARM {}, platformOS = OSiOS } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-apple-darwin10\"" + Platform { platformArch = ArchX86, platformOS = OSiOS } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\"" + $+$ text "target triple = \"i386-apple-darwin11\"" + Platform { platformArch = ArchARM64, platformOS = OSiOS } -> + text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-n32:64-S128\"" + $+$ text "target triple = \"arm64-apple-ios7.0.0\"" + Platform { platformArch = ArchARM64, platformOS = OSLinux } -> + text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\"" + $+$ text "target triple = \"aarch64-unknown-linux-gnu\"" + _ -> + if platformIsCrossCompiling platform + then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info." + else empty + -- If you see the above panic, GHC is missing the required target datalayout + -- and triple information. You can obtain this info by compiling a simple + -- 'hello world' C program with the clang C compiler eg: + -- clang hello.c -emit-llvm -o hello.ll + -- and the first two lines of hello.ll should provide the 'target datalayout' + -- and 'target triple' lines required. + + +-- | Pretty print LLVM data code +pprLlvmData :: LlvmData -> SDoc +pprLlvmData (globals, types) = + let ppLlvmTys (LMAlias a) = ppLlvmAlias a + ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f + ppLlvmTys _other = empty + + types' = vcat $ map ppLlvmTys types + globals' = ppLlvmGlobals globals + in types' $+$ globals' + + +-- | Pretty print LLVM code +pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl _ (CmmData _ lmdata) + = return (vcat $ map pprLlvmData lmdata, []) + +pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do (idoc, ivar) <- case mb_info of + Nothing -> return (empty, []) + Just (Statics info_lbl dat) + -> pprInfoTable count info_lbl (Statics entry_lbl dat) + + let sec = mkLayoutSection (count + 1) + (lbl',sec') = case mb_info of + Nothing -> (entry_lbl, Nothing) + Just (Statics info_lbl _) -> (info_lbl, sec) + link = if externallyVisibleCLabel lbl' + then ExternallyVisible + else Internal + lmblocks = map (\(BasicBlock id stmts) -> + LlvmBlock (getUnique id) stmts) blks + + fun <- mkLlvmFunc live lbl' link sec' lmblocks + let name = decName $ funcDecl fun + defName = name `appendFS` fsLit "$def" + funcDecl' = (funcDecl fun) { decName = defName } + fun' = fun { funcDecl = funcDecl' } + funTy = LMFunction funcDecl' + funVar = LMGlobalVar name + (LMPointer funTy) + link + Nothing + Nothing + Alias + defVar = LMGlobalVar defName + (LMPointer funTy) + (funcLinkage funcDecl') + (funcSect fun) + (funcAlign funcDecl') + Alias + alias = LMGlobal funVar + (Just $ LMBitc (LMStaticPointer defVar) + (LMPointer $ LMInt 8)) + + return (ppLlvmGlobal alias $+$ idoc $+$ ppLlvmFunction fun', ivar) + + +-- | Pretty print CmmStatic +pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar]) +pprInfoTable count info_lbl stat + = do (ldata, ltypes) <- genLlvmData (Text, stat) + + dflags <- getDynFlags + platform <- getLlvmPlatform + let setSection :: LMGlobal -> LlvmM (LMGlobal, [LlvmVar]) + setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do + lbl <- strCLabel_llvm info_lbl + let sec = mkLayoutSection count + ilabel = lbl `appendFS` fsLit iTableSuf + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c + -- See Note [Subsections Via Symbols] + v = if (platformHasSubsectionsViaSymbols platform + && l == ExternallyVisible) + || l == Internal + then [gv] + else [] + funInsert ilabel ty + return (LMGlobal gv d, v) + setSection v = return (v,[]) + + (ldata', llvmUsed) <- unzip `fmap` mapM setSection ldata + ldata'' <- mapM aliasify ldata' + let modUsedLabel (LMGlobalVar name ty link sect align const) = + LMGlobalVar (name `appendFS` fsLit "$def") ty link sect align const + modUsedLabel v = v + llvmUsed' = map modUsedLabel $ concat llvmUsed + return (pprLlvmData (concat ldata'', ltypes), llvmUsed') + + +-- | We generate labels for info tables by converting them to the same label +-- as for the entry code but adding this string as a suffix. +iTableSuf :: String +iTableSuf = "_itable" + + +-- | Create a specially crafted section declaration that encodes the order this +-- section should be in the final object code. +-- +-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses +-- this section declaration to do its processing. +mkLayoutSection :: Int -> LMSection +mkLayoutSection n + = Just (fsLit $ infoSection ++ show n) + + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. +infoSection :: String +infoSection = "X98A__STRIP,__me" diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs new file mode 100644 index 00000000..00486590 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | Deal with Cmm registers +-- + +module LlvmCodeGen.Regs ( + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA + ) where + +#include "HsVersions.h" + +import Llvm + +import CmmExpr +import DynFlags +import FastString +import Outputable ( panic ) +import Unique + +-- | Get the LlvmVar function variable storing the real register +lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" + +-- | Get the LlvmVar function argument storing the real register +lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" + +{- Need to make sure the names here can't conflict with the unique generated + names. Uniques generated names containing only base62 chars. So using say + the '_' char guarantees this. +-} +lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar +lmGlobalReg dflags suf reg + = case reg of + BaseReg -> ptrGlobal $ "Base" ++ suf + Sp -> ptrGlobal $ "Sp" ++ suf + Hp -> ptrGlobal $ "Hp" ++ suf + VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf + VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf + VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf + VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf + VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf + VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf + SpLim -> wordGlobal $ "SpLim" ++ suf + FloatReg 1 -> floatGlobal $"F1" ++ suf + FloatReg 2 -> floatGlobal $"F2" ++ suf + FloatReg 3 -> floatGlobal $"F3" ++ suf + FloatReg 4 -> floatGlobal $"F4" ++ suf + FloatReg 5 -> floatGlobal $"F5" ++ suf + FloatReg 6 -> floatGlobal $"F6" ++ suf + DoubleReg 1 -> doubleGlobal $ "D1" ++ suf + DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf + XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf + XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf + XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf + XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf + XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf + XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf + YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf + YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf + YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf + YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf + YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf + YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf + ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf + ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf + ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf + ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf + ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf + ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf + _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) + ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg + where + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) + floatGlobal name = LMNLocalVar (fsLit name) LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) LMDouble + xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32)) + ymmGlobal name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32)) + zmmGlobal name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32)) + +-- | A list of STG Registers that should always be considered alive +alwaysLive :: [GlobalReg] +alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] + +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] +stgTBAA + = [ (topN, fsLit "top", Nothing) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) + -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. + -- OR I think the big thing is Sp is never aliased, so might want + -- to change the hieracy to have Sp on its own branch that is never + -- aliased (e.g never use top as a TBAA node). + , (otherN, fsLit "other", Just topN) + ] + +-- | Id values +topN, stackN, heapN, rxN, baseN, otherN :: Unique +topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") +stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") +heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") +rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") +baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") +otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN") + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs new file mode 100644 index 00000000..8652a890 --- /dev/null +++ b/compiler/llvmGen/LlvmMangler.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP #-} + +-- ----------------------------------------------------------------------------- +-- | GHC LLVM Mangler +-- +-- This script processes the assembly produced by LLVM, rearranging the code +-- so that an info table appears before its corresponding function. +-- + +module LlvmMangler ( llvmFixupAsm ) where + +import DynFlags ( DynFlags ) +import ErrUtils ( showPass ) +import LlvmCodeGen.Ppr ( infoSection ) + +import Control.Exception +import Control.Monad ( when ) +import qualified Data.ByteString.Char8 as B +import Data.Char +import System.IO + +import Data.List ( sortBy ) +import Data.Function ( on ) + +#if x86_64_TARGET_ARCH +#define REWRITE_AVX +#endif + +-- Magic Strings +secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString +secStmt = B.pack "\t.section\t" +infoSec = B.pack infoSection +newLine = B.pack "\n" +textStmt = B.pack "\t.text" +dataStmt = B.pack "\t.data" +syntaxUnified = B.pack "\t.syntax unified" + +infoLen :: Int +infoLen = B.length infoSec + +-- Search Predicates +isType :: B.ByteString -> Bool +isType = B.isPrefixOf (B.pack "\t.type") + +-- section of a file in the form of (header line, contents) +type Section = (B.ByteString, B.ByteString) + +-- | Read in assembly file and process +llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () +llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do + showPass dflags "LLVM Mangler" + r <- openBinaryFile f1 ReadMode + w <- openBinaryFile f2 WriteMode + ss <- readSections r w + hClose r + let fixed = (map rewriteAVX . fixTables) ss + mapM_ (writeSection w) fixed + hClose w + return () + +-- | This rewrites @.type@ annotations of function symbols to @%object@. +-- This is done as the linker can relocate @%functions@ through the +-- Procedure Linking Table (PLT). This is bad since we expect that the +-- info table will appear directly before the symbol's location. In the +-- case that the PLT is used, this will be not an info table but instead +-- some random PLT garbage. +rewriteSymType :: B.ByteString -> B.ByteString +rewriteSymType s = + B.unlines $ map (rewrite '@' . rewrite '%') $ B.lines s + where + rewrite :: Char -> B.ByteString -> B.ByteString + rewrite prefix x + | isType x = replace funcType objType x + | otherwise = x + where + funcType = prefix `B.cons` B.pack "function" + objType = prefix `B.cons` B.pack "object" + +-- | Splits the file contents into its sections +readSections :: Handle -> Handle -> IO [Section] +readSections r w = go B.empty [] [] + where + go hdr ss ls = do + e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString) + + -- Note that ".type" directives at the end of a section refer to + -- the first directive of the *next* section, therefore we take + -- it over to that section. + let (tys, ls') = span isType ls + cts = rewriteSymType $ B.intercalate newLine $ reverse ls' + + -- Decide whether to directly output the section or append it + -- to the list for resorting. + let finishSection + | infoSec `B.isInfixOf` hdr = + cts `seq` return $ (hdr, cts):ss + | otherwise = + writeSection w (hdr, cts) >> return ss + + case e_l of + Right l | l == syntaxUnified + -> finishSection >>= \ss' -> writeSection w (l, B.empty) + >> go B.empty ss' tys + | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt] + -> finishSection >>= \ss' -> go l ss' tys + | otherwise + -> go hdr ss (l:ls) + Left _ -> finishSection >>= \ss' -> return (reverse ss') + +-- | Writes sections back +writeSection :: Handle -> Section -> IO () +writeSection w (hdr, cts) = do + when (not $ B.null hdr) $ + B.hPutStrLn w hdr + B.hPutStrLn w cts + +#if REWRITE_AVX +rewriteAVX :: Section -> Section +rewriteAVX = rewriteVmovaps . rewriteVmovdqa + +rewriteVmovdqa :: Section -> Section +rewriteVmovdqa = rewriteInstructions vmovdqa vmovdqu + where + vmovdqa, vmovdqu :: B.ByteString + vmovdqa = B.pack "vmovdqa" + vmovdqu = B.pack "vmovdqu" + +rewriteVmovap :: Section -> Section +rewriteVmovap = rewriteInstructions vmovap vmovup + where + vmovap, vmovup :: B.ByteString + vmovap = B.pack "vmovap" + vmovup = B.pack "vmovup" + +rewriteInstructions :: B.ByteString -> B.ByteString -> Section -> Section +rewriteInstructions matchBS replaceBS (hdr, cts) = + (hdr, replace matchBS replaceBS cts) +#else /* !REWRITE_AVX */ +rewriteAVX :: Section -> Section +rewriteAVX = id +#endif /* !REWRITE_SSE */ + +replace :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +replace matchBS replaceBS = loop + where + loop :: B.ByteString -> B.ByteString + loop cts = + case B.breakSubstring matchBS cts of + (hd,tl) | B.null tl -> hd + | otherwise -> hd `B.append` replaceBS `B.append` + loop (B.drop (B.length matchBS) tl) + +-- | Reorder and convert sections so info tables end up next to the +-- code. Also does stack fixups. +fixTables :: [Section] -> [Section] +fixTables ss = map strip sorted + where + -- Resort sections: We only assign a non-zero number to all + -- sections having the "STRIP ME" marker. As sortBy is stable, + -- this will cause all these sections to be appended to the end of + -- the file in the order given by the indexes. + extractIx hdr + | B.null a = 0 + | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a) + where (_,a) = B.breakSubstring infoSec hdr + + indexed = zip (map (extractIx . fst) ss) ss + + sorted = map snd $ sortBy (compare `on` fst) indexed + + -- Turn all the "STRIP ME" sections into normal text sections, as + -- they are in the right place now. + strip (hdr, cts) + | infoSec `B.isInfixOf` hdr = (textStmt, cts) + | otherwise = (hdr, cts) + +-- | Read an int or error +readInt :: B.ByteString -> Int +readInt str | B.all isDigit str = (read . B.unpack) str + | otherwise = error $ "LLvmMangler Cannot read " ++ show str + ++ " as it's not an Int" diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs new file mode 100644 index 00000000..82c5d202 --- /dev/null +++ b/compiler/main/Annotations.hs @@ -0,0 +1,124 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +module Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + deserializeAnns + ) where + +import Binary +import Module ( Module ) +import Name +import Outputable +import Serialized +import UniqFM +import Unique + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'HsDecls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Functor AnnTarget where + fmap f (NamedTarget nm) = NamedTarget (f nm) + fmap _ (ModuleTarget mod) = ModuleTarget mod + +-- | Get the 'name' of an annotation target if it exists. +getAnnTargetName_maybe :: AnnTarget name -> Maybe name +getAnnTargetName_maybe (NamedTarget nm) = Just nm +getAnnTargetName_maybe _ = Nothing + +instance Uniquable name => Uniquable (AnnTarget name) where + getUnique (NamedTarget nm) = getUnique nm + getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 + -- deriveUnique prevents OccName uniques clashing with NamedTarget + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +-- Can't use a type synonym or we hit bug #2412 due to source import +newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyUFM + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList (MkAnnEnv env) anns + = MkAnnEnv $ addListToUFM_C (++) env $ + map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize (MkAnnEnv ann_env) + = (mapMaybe (fromSerialized deserialize)) + . (lookupWithDefaultUFM ann_env []) + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] +deserializeAnns deserialize (MkAnnEnv ann_env) + = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env + diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs new file mode 100644 index 00000000..6455912b --- /dev/null +++ b/compiler/main/BreakArray.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +------------------------------------------------------------------------------- +-- +-- | Break Arrays in the IO monad +-- +-- Entries in the array are Word sized Conceptually, a zero-indexed IOArray of +-- Bools, initially False. They're represented as Words with 0==False, 1==True. +-- They're used to determine whether GHCI breakpoints are on or off. +-- +-- (c) The University of Glasgow 2007 +-- +------------------------------------------------------------------------------- + +module BreakArray + ( + BreakArray +#ifdef GHCI + (BA) -- constructor is exported only for ByteCodeGen +#endif + , newBreakArray +#ifdef GHCI + , getBreak + , setBreakOn + , setBreakOff + , showBreakArray +#endif + ) where + +import DynFlags + +#ifdef GHCI +import Control.Monad + +import ExtsCompat46 +import GHC.IO ( IO(..) ) + +data BreakArray = BA (MutableByteArray# RealWorld) + +breakOff, breakOn :: Word +breakOn = 1 +breakOff = 0 + +showBreakArray :: DynFlags -> BreakArray -> IO () +showBreakArray dflags array = do + forM_ [0 .. (size dflags array - 1)] $ \i -> do + val <- readBreakArray array i + putStr $ ' ' : show val + putStr "\n" + +setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOn dflags array index + | safeIndex dflags array index = do + writeBreakArray array index breakOn + return True + | otherwise = return False + +setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOff dflags array index + | safeIndex dflags array index = do + writeBreakArray array index breakOff + return True + | otherwise = return False + +getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word) +getBreak dflags array index + | safeIndex dflags array index = do + val <- readBreakArray array index + return $ Just val + | otherwise = return Nothing + +safeIndex :: DynFlags -> BreakArray -> Int -> Bool +safeIndex dflags array index = index < size dflags array && index >= 0 + +size :: DynFlags -> BreakArray -> Int +size dflags (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE dflags + +allocBA :: Int -> IO BreakArray +allocBA (I# sz) = IO $ \s1 -> + case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } + +-- create a new break array and initialise elements to zero +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray dflags entries@(I# sz) = do + BA array <- allocBA (entries * wORD_SIZE dflags) + case breakOff of + W# off -> do -- Todo: there must be a better way to write zero as a Word! + let loop n | n ==# sz = return () + | otherwise = do + writeBA# array n off + loop (n +# 1#) + loop 0# + return $ BA array + +writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO () +writeBA# array i word = IO $ \s -> + case writeWordArray# array i word s of { s -> (# s, () #) } + +writeBreakArray :: BreakArray -> Int -> Word -> IO () +writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word + +readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word +readBA# array i = IO $ \s -> + case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) } + +readBreakArray :: BreakArray -> Int -> IO Word +readBreakArray (BA array) (I# i) = readBA# array i + +#else /* !GHCI */ + +-- stub implementation to make main/, etc., code happier. +-- IOArray and IOUArray are increasingly non-portable, +-- still don't have quite the same interface, and (for GHCI) +-- presumably have a different representation. +data BreakArray = Unspecified + +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray _ _ = return Unspecified + +#endif /* GHCI */ + diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs new file mode 100644 index 00000000..d4c3ed78 --- /dev/null +++ b/compiler/main/CmdLineParser.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by both StaticFlags and +-- DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module CmdLineParser + ( + processArgs, OptKind(..), GhcFlagMode(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + errorsToGhcException, + + EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate + ) where + +#include "HsVersions.h" + +import Util +import Outputable +import Panic +import Bag +import SrcLoc + +import Data.Function +import Data.List + +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn + | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn + | PrefixPred (String -> Bool) (String -> EwM m ()) + | AnySuffixPred (String -> Bool) (String -> EwM m ()) + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +type Err = Located String +type Warn = Located String +type Errs = Bag Err +type Warns = Bag Warn + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + return v = EwM (\_ e w -> return (e, w, v)) + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag + +setArg :: Monad m => Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ())) + +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addWarn (arg ++ " is deprecated: " ++ s) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + + +-------------------------------------------------------- +-- A state monad for use in the command-line parser +-------------------------------------------------------- + +-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + +instance Functor (CmdLineP s) where + fmap = liftM + +instance Applicative (CmdLineP s) where + pure = return + (<*>) = ap + +instance Monad (CmdLineP s) where + m >>= k = CmdLineP $ \s -> + let (a, s') = runCmdLine m s + in runCmdLine (k a) s' + + return a = CmdLineP $ \s -> (a, s) + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState :: s -> CmdLineP s () +putCmdLineState s = CmdLineP $ \_ -> ((),s) + + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( [Located String], -- spare args + [Located String], -- errors + [Located String] ) -- warnings +processArgs spec args = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, bagToList warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See Trac #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> unknownFlagErr dash_arg + + PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> unknownFlagErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + AnySuffixPred _ f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) rest _ = notNull rest +arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True +arg_ok (AnySuffixPred p _) _ arg = p arg + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + + +-- See Note [Handling errors when parsing flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing commandline flags] + +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs new file mode 100644 index 00000000..f55a15a8 --- /dev/null +++ b/compiler/main/CodeOutput.hs @@ -0,0 +1,253 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section{Code output phase} +-} + +{-# LANGUAGE CPP #-} + +module CodeOutput( codeOutput, outputForeignStubs ) where + +#include "HsVersions.h" + +import AsmCodeGen ( nativeCodeGen ) +import LlvmCodeGen ( llvmCodeGen ) + +import UniqSupply ( mkSplitUniqSupply ) + +import Finder ( mkStubPaths ) +import PprC ( writeCs ) +import CmmLint ( cmmLint ) +import Packages +import Cmm ( RawCmmGroup ) +import HscTypes +import DynFlags +import Config +import SysTools +import Stream (Stream) +import qualified Stream + +import ErrUtils +import Outputable +import Module +import SrcLoc + +import Control.Exception +import System.Directory +import System.FilePath +import System.IO + +{- +************************************************************************ +* * +\subsection{Steering} +* * +************************************************************************ +-} + +codeOutput :: DynFlags + -> Module + -> FilePath + -> ModLocation + -> ForeignStubs + -> [PackageKey] + -> Stream IO RawCmmGroup () -- Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) + +codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream + = + do { + -- Lint each CmmGroup as it goes past + ; let linted_cmm_stream = + if gopt Opt_DoCmmLinting dflags + then Stream.mapM do_lint cmm_stream + else cmm_stream + + do_lint cmm = do + { showPass dflags "CmmLint" + ; case cmmLint dflags cmm of + Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err + ; ghcExit dflags 1 + } + Nothing -> return () + ; return cmm + } + + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; case hscTarget dflags of { + HscAsm -> outputAsm dflags this_mod location filenm + linted_cmm_stream; + HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; + HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; + HscInterpreted -> panic "codeOutput: HscInterpreted"; + HscNothing -> panic "codeOutput: HscNothing" + } + ; return (filenm, stubs_exist) + } + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action + +{- +************************************************************************ +* * +\subsection{C} +* * +************************************************************************ +-} + +outputC :: DynFlags + -> FilePath + -> Stream IO RawCmmGroup () + -> [PackageKey] + -> IO () + +outputC dflags filenm cmm_stream packages + = do + -- ToDo: make the C backend consume the C-- incrementally, by + -- pushing the cmm_stream inside (c.f. nativeCodeGen) + rawcmms <- Stream.collect cmm_stream + + -- figure out which header files to #include in the generated .hc file: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + let rts = getPackageDetails dflags rtsPackageKey + + let cc_injects = unlines (map mk_include (includes rts)) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + + let pkg_names = map packageKeyString packages + + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects + writeCs dflags h rawcmms + +{- +************************************************************************ +* * +\subsection{Assembler} +* * +************************************************************************ +-} + +outputAsm :: DynFlags -> Module -> ModLocation -> FilePath + -> Stream IO RawCmmGroup () + -> IO () +outputAsm dflags this_mod location filenm cmm_stream + | cGhcWithNativeCodeGen == "YES" + = do ncg_uniqs <- mkSplitUniqSupply 'n' + + debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + + _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + return () + + | otherwise + = panic "This compiler was built without a native code generator" + +{- +************************************************************************ +* * +\subsection{LLVM} +* * +************************************************************************ +-} + +outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () +outputLlvm dflags filenm cmm_stream + = do ncg_uniqs <- mkSplitUniqSupply 'n' + + {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f ncg_uniqs cmm_stream + +{- +************************************************************************ +* * +\subsection{Foreign import/export} +* * +************************************************************************ +-} + +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs dflags mod location stubs + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> + return (False, Nothing) + + ForeignStubs h_code c_code -> do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc dflags stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc dflags stub_h_output_d + + createDirectoryIfMissing True (takeDirectory stub_h) + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export header file" stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = getPackageDetails dflags rtsPackageKey in + concatMap mk_include (includes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" + + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes | cLibFFI = "#include \"ffi.h\"\n" + | otherwise = "" + + stub_h_file_exists + <- outputForeignStubs_help stub_h stub_h_output_w + ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export stubs" stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include \"Rts.h\"\n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" + + +-- Don't use doOutput for dumping the f. export stubs +-- since it is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False +outputForeignStubs_help fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs new file mode 100644 index 00000000..0054888d --- /dev/null +++ b/compiler/main/Constants.hs @@ -0,0 +1,32 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Constants]{Info about this compilation} +-} + +module Constants (module Constants) where + +import Config + +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +-- All pretty arbitrary: + +mAX_TUPLE_SIZE :: Int +mAX_TUPLE_SIZE = 62 -- Should really match the number + -- of decls in Data.Tuple + +mAX_CONTEXT_REDUCTION_DEPTH :: Int +mAX_CONTEXT_REDUCTION_DEPTH = 100 + -- Trac #5395 reports at least one library that needs depth 37 here + +mAX_TYPE_FUNCTION_REDUCTION_DEPTH :: Int +mAX_TYPE_FUNCTION_REDUCTION_DEPTH = 200 + -- Needs to be much higher than mAX_CONTEXT_REDUCTION_DEPTH; see Trac #5395 + +wORD64_SIZE :: Int +wORD64_SIZE = 8 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs new file mode 100644 index 00000000..03545d48 --- /dev/null +++ b/compiler/main/DriverMkDepend.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DriverMkDepend ( + doMkDependHS + ) where + +#include "HsVersions.h" + +import qualified GHC +import GhcMonad +import HsSyn ( ImportDecl(..) ) +import DynFlags +import Util +import HscTypes +import SysTools ( newTempName ) +import qualified SysTools +import Module +import Digraph ( SCC(..) ) +import Finder +import Outputable +import Panic +import SrcLoc +import Data.List +import FastString + +import Exception +import ErrUtils + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error ( isEOFError ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags = dflags0 { + ways = [], + buildTag = mkBuildTag [], + hiSuf = "hi", + objectSuf = "o" + } + _ <- GHC.setSessionDynFlags dflags + + when (null (depSuffixes dflags)) $ liftIO $ + throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") + + files <- liftIO $ beginMkDependHS dflags + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -} + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False mod_summaries Nothing + + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + + -- Prcess them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + root <- liftIO getCurrentDirectory + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles dflags mod_summaries + + -- Tidy up + liftIO $ endMkDependHS dflags files + + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: DynFlags -> IO MkDepFiles +beginMkDependHS dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName dflags "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> [ModuleName] + -> FilePath + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps dflags _ _ _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) + +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp loc is_boot pkg_qual imp_mod + = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency root hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency root hdl obj_files src_file + + -- Emit a dependency for each import + + ; let do_imps is_boot idecls = sequence_ + [ do_imp loc is_boot (ideclPkgQual i) mod + | L loc i <- idecls, + let mod = unLoc (ideclName i), + mod `notElem` excl_mods ] + + ; do_imps True (ms_srcimps node) + ; do_imps False (ms_imps node) + } + + +findDependency :: HscEnv + -> SrcSpan + -> Maybe FastString -- package qualifier, if any + -> ModuleName -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file file +findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps + = do { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findImportedModule hsc_env imp pkg + ; case r of + Found loc _ + -- Home package: just depend on the .hi or hi-boot file + | isJust (ml_hs_file loc) || include_pkg_deps + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail + } + +----------------------------- +writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency root hdl targets dep + = do let -- We need to avoid making deps on + -- c:/foo/... + -- on cygwin as make gets confused by the : + -- Making relative deps avoids some instances of this. + dep' = makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . normalise + output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' + hPutStrLn hdl output + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + -- Note that that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we know where to + -- split it +insertSuffixes file_name extras + = [ basename <.> (extra ++ suffix) | extra <- extras ] + where + (basename, suffix) = case splitExtension file_name of + -- Drop the "." from the extension + (b, s) -> (b, drop 1 s) + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: DynFlags -> MkDepFiles -> IO () + +endMkDependHS dflags + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the original makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) + + -- Copy the new makefile in place + SysTools.copy dflags "Installing new makefile" tmp_file makefile + + +----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: DynFlags -> [ModSummary] -> IO () +dumpModCycles dflags mod_summaries + | not (dopt Opt_D_dump_mod_cycles dflags) + = return () + + | null cycles + = putMsg dflags (ptext (sLit "No module cycles")) + + | otherwise + = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles) + where + + cycles :: [[ModSummary]] + cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ] + + pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------")) + $$ pprCycle c $$ blankLine + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModSummary] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_mods :: [ModuleName] -- The modules in this cycle + cycle_mods = map (moduleName . ms_mod) summaries + + pp_group (AcyclicSCC ms) = pp_ms ms + pp_group (CyclicSCC mss) + = ASSERT( not (null boot_only) ) + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imoprts, and we've + -- already checked for that in processModDeps + pp_ms loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partition is_boot_only mss + is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms))) + in_group (L _ m) = m `elem` group_mods + group_mods = map (moduleName . ms_mod) mss + + loop_breaker = head boot_only + all_others = tail boot_only ++ others + groups = GHC.topSortModuleGraph True all_others Nothing + + pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) + <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$ + pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary))) + where + mod_str = moduleNameString (moduleName (ms_mod summary)) + + pp_imps :: SDoc -> [Located ModuleName] -> SDoc + pp_imps _ [] = empty + pp_imps what lms + = case [m | L _ m <- lms, m `elem` cycle_mods] of + [] -> empty + ms -> what <+> ptext (sLit "imports") <+> + pprWithCommas ppr ms + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + +depStartMarker, depEndMarker :: String +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs new file mode 100644 index 00000000..2433f6d6 --- /dev/null +++ b/compiler/main/DriverPhases.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module DriverPhases ( + HscSource(..), isHsBootOrSig, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, + phaseInputExt, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isSourceSuffix, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DynFlags +import Outputable +import Platform +import System.FilePath + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out +-} + +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + +data HscSource + = HsSrcFile | HsBootFile | HsigFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccpp + | Cc + | Cobjc + | Cobjcpp + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | Splitter -- Assembly file splitter (part of '-split-objs') + | SplitAs -- Assembler for split assembly files (part of '-split-objs') + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Ccpp Ccpp = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase Cobjcpp Cobjcpp = True +eqPhase HCc HCc = True +eqPhase Splitter Splitter = True +eqPhase SplitAs SplitAs = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True +eqPhase StopLn StopLn = True +eqPhase _ _ = False + +-- Partial ordering on phases: we want to know which phases will occur before +-- which others. This is used for sanity checking, to ensure that the +-- pipeline will stop at some point (see DriverPipeline.runPipeline). +happensBefore :: DynFlags -> Phase -> Phase -> Bool +happensBefore dflags p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase dflags x + +nextPhase :: DynFlags -> Phase -> Phase +nextPhase dflags p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + Splitter -> SplitAs + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + SplitAs -> MergeStub + As _ -> MergeStub + Ccpp -> As False + Cc -> As False + Cobjc -> As False + Cobjcpp -> As False + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> As False + MergeStub -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised (targetPlatform dflags) + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccpp +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcpp +startPhase "mm" = Cobjcpp +startPhase "cc" = Ccpp +startPhase "cxx" = Ccpp +startPhase "split_s" = Splitter +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccpp = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcpp = "mm" +phaseInputExt Cc = "c" +phaseInputExt Splitter = "split_s" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt SplitAs = "split_s" +phaseInputExt CmmCpp = "cmm" +phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, + haskellish_user_src_suffixes, haskellish_sig_suffixes + :: [String] +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isHaskellSigSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) + diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs new file mode 100644 index 00000000..ff71cb4d --- /dev/null +++ b/compiler/main/DriverPipeline.hs @@ -0,0 +1,2317 @@ +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DriverPipeline ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + linkBinary, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + link, + + -- Exports for hooks to override runPhase and link + PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), + phaseOutputFilename, getPipeState, getPipeEnv, + hscPostBackendPhase, getLocation, setModLocation, setDynFlags, + runPhase, exeFileName, + mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, + maybeCreateManifest, runPhase_MoveBinary, + linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode + ) where + +#include "HsVersions.h" + +import PipelineMonad +import Packages +import HeaderInfo +import DriverPhases +import SysTools +import HscMain +import Finder +import HscTypes hiding ( Hsc ) +import Outputable +import Module +import UniqFM ( eltsUFM ) +import ErrUtils +import DynFlags +import Config +import Panic +import Util +import StringBuffer ( hGetStringBuffer ) +import BasicTypes ( SuccessFlag(..) ) +import Maybes ( expectJust ) +import SrcLoc +import FastString +import LlvmCodeGen ( llvmFixupAsm ) +import MonadUtils +import Platform +import TcRnTypes +import Hooks + +import Exception +import Data.IORef ( readIORef ) +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import Data.List ( isSuffixOf ) +import Data.Maybe +import System.Environment +import Data.Char + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> (FilePath, Maybe Phase) -- ^ filename and starting phase + -> IO (DynFlags, FilePath) +preprocess hsc_env (filename, mb_phase) = + ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) + runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' Nothing (Just batchMsg) + +compileOne' :: Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' m_tc_result mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable + source_modified0 + = do + let dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + src_flavour = ms_hsc_src summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary + mod_graph = hsc_mod_graph hsc_env0 + needsTH = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph + needsQQ = any (xopt Opt_QuasiQuotes . ms_hspp_opts) mod_graph + needsLinker = needsTH || needsQQ + isDynWay = any (== WayDyn) (ways dflags0) + isProfWay = any (== WayProf) (ways dflags0) + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. + let dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay + then gopt_set dflags0 Opt_BuildDynamicToo + else dflags0 + + debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + + let basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import path. + -- This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + let current_dir = takeDirectory basename + old_paths = includePaths dflags1 + dflags = dflags1 { includePaths = current_dir : old_paths } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- Figure out what lang we're generating + let hsc_lang = hscTarget dflags + -- ... and what the next phase should be + let next_phase = hscPostBackendPhase dflags src_flavour hsc_lang + -- ... and what file to generate the output into + output_fn <- getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + + -- -fforce-recomp should also work with --make + let force_recomp = gopt Opt_ForceRecomp dflags + source_modified + | force_recomp = SourceModified + | otherwise = source_modified0 + object_filename = ml_obj_file location + + let always_do_basic_recompilation_check = case hsc_lang of + HscInterpreted -> True + _ -> False + + e <- genericHscCompileGetFrontendResult + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + case e of + Left iface -> + do details <- genModDetails hsc_env iface + MASSERT(isJust maybe_old_linkable) + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = maybe_old_linkable }) + + Right (tc_result, mb_old_hash) -> + -- run the compiler + case hsc_lang of + HscInterpreted -> + case ms_hsc_src summary of + t | isHsBootOrSig t -> + do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = maybe_old_linkable }) + _ -> do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash + (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc modBreaks] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let linkable = LM unlinked_time this_mod + (hs_unlinked ++ stub_o) + + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Just linkable }) + HscNothing -> + do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + when (gopt Opt_WriteInterface dflags) $ + hscWriteIface dflags iface changed summary + let linkable = if isHsBootOrSig src_flavour + then maybe_old_linkable + else Just (LM (ms_hs_date summary) this_mod []) + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = linkable }) + + _ -> + case ms_hsc_src summary of + HsBootFile -> + do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed summary + touchObjectFile dflags object_filename + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = maybe_old_linkable }) + + HsigFile -> + do (iface, changed, details) <- + hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed summary + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + let mod_name = ms_mod_name summary + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name HscUpdateSig)) + (Just basename) + Persistent + (Just location) + Nothing + + -- Same as Hs + o_time <- getModificationUTCTime object_filename + let linkable = + LM o_time this_mod [DotO object_filename] + + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Just linkable }) + + HsSrcFile -> + do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash + hscWriteIface dflags iface changed summary + + -- We're in --make mode: finish the compilation pipeline. + let mod_name = ms_mod_name summary + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) + (Just basename) + Persistent + (Just location) + Nothing + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let linkable = LM o_time this_mod [DotO object_filename] + + return (HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Just linkable }) + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support) + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing + + return stub_o + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> IO () +compileEmptyStub dflags hsc_env basename location = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures + empty_stub <- newTempName dflags "c" + writeFile empty_stub "" + _ <- runPipeline StopLn hsc_env + (empty_stub, Nothing) + (Just basename) + Persistent + (Just location) + Nothing + return () + +-- --------------------------------------------------------------------------- +-- Link + +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink dflags + = lookupHook linkHook l dflags ghcLink dflags + where + l LinkInMemory _ _ _ + = if cGhcWithInterpreter == "YES" + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory + + l NoLink _ _ _ + = return Succeeded + + l LinkBinary dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkDynLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +link' dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> platformBinariesAreStaticLibs (targetPlatform dflags) + + home_mod_infos = eltsUFM hpt + + -- the packages we depend on + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName staticLink dflags + + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps + + if not (gopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) + return Succeeded + else do + + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLibCheck + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let exe_file = exeFileName staticLink dflags + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> do + -- first check object files and extra_ld_inputs + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs + let (errs,extra_times) = splitEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkg_hslibs = [ (libraryDirs c, lib) + | Just c <- map (lookupPackage dflags) pkg_deps, + lib <- packageHsLibs dflags c ] + + pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (tryIO . getModificationUTCTime) + (catMaybes pkg_libfiles) + let (lib_errs,lib_times) = splitEithers e_lib_times + if not (null lib_errs) || any (t <) lib_times + then return True + else checkLinkInfo dflags pkg_deps exe_file + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file + debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info) + return (Just link_info /= m_exe_link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) +findHSLib dflags dirs lib = do + let batch_lib_file = if gopt Opt_Static dflags + then "lib" ++ lib <.> "a" + else mkSOName (targetPlatform dflags) lib + found <- filterM doesFileExist (map ( batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + doLink (hsc_dflags hsc_env) stop_phase o_files + +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + split = gopt Opt_SplitObjs dflags + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + -- If we are dong -fno-code, then act as if the output is + -- 'Temporary'. This stops GHC trying to copy files to their + -- final location. + | HscNothing <- hscTarget dflags = Temporary + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + stop_phase' = case stop_phase of + As _ | split -> SplitAs + _ -> stop_phase + + ( _, out_file) <- runPipeline stop_phase' hsc_env + (src, fmap RealPhase mb_phase) Nothing output + Nothing{-no ModLocation-} Nothing + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLibCheck dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other + + +-- --------------------------------------------------------------------------- + +-- | Run a compilation pipeline, consisting of multiple phases. +-- +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. +-- +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- OPTIONS_GHC pragmas), and the changes affect later phases in the +-- pipeline. +runPipeline + :: Phase -- ^ When to stop + -> HscEnv -- ^ Compilation environment + -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) + -> Maybe FilePath -- ^ original basename (if different from ^^^) + -> PipelineOutput -- ^ Output filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o + + = do let + dflags0 = hsc_dflags hsc_env0 + + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + (input_basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + basename | Just b <- mb_basename = b + | otherwise = input_basename + + -- If we were given a -x flag, then use that phase to start from + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase + + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False + + isHaskellishFile = isHaskell start_phase + + env = PipeEnv{ pe_isHaskellishFile = isHaskellishFile, + stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + -- + -- There is a partial ordering on phases, where A < B iff A occurs + -- before B in a normal compilation pipeline. + + let happensBefore' = happensBefore dflags + case start_phase of + RealPhase start_phase' -> + when (not (start_phase' `happensBefore'` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () + + debugTraceMsg dflags 4 (text "Running the pipeline") + r <- runPipeline' start_phase hsc_env env input_fn + maybe_loc maybe_stub_o + + -- If we are compiling a Haskell module, and doing + -- -dynamic-too, but couldn't do the -dynamic-too fast + -- path, then rerun the pipeline for the dyn way + let dflags = extractDynFlags hsc_env + -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) + when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do + when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do + debugTraceMsg dflags 4 + (text "Running the pipeline again for -dynamic-too") + let dflags' = dynamicTooMkDynamicDynFlags dflags + hsc_env' <- newHscEnv dflags' + _ <- runPipeline' start_phase hsc_env' env input_fn + maybe_loc maybe_stub_o + return () + return r + +runPipeline' + :: PhasePlus -- ^ When to start + -> HscEnv -- ^ Compilation environment + -> PipeEnv + -> FilePath -- ^ Input filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) +runPipeline' start_phase hsc_env env input_fn + maybe_loc maybe_stub_o + = do + -- Execute the pipeline... + let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + evalP (pipeLoop start_phase input_fn) env state + +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath) +pipeLoop phase input_fn = do + env <- getPipeEnv + dflags <- getDynFlags + let happensBefore' = happensBefore dflags + stopPhase = stop_phase env + case phase of + RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done + -> -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + case output_spec env of + Temporary -> + return (dflags, input_fn) + output -> + do pst <- getPipeState + final_fn <- liftIO $ getOutputFilename + stopPhase output (src_basename env) + dflags stopPhase (maybe_loc pst) + when (final_fn /= input_fn) $ do + let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") + line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") + liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + return (dflags, final_fn) + + + | not (realPhase `happensBefore'` stopPhase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + -> panic ("pipeLoop: at phase " ++ show realPhase ++ + " but I wanted to stop at phase " ++ show stopPhase) + + _ + -> do liftIO $ debugTraceMsg dflags 4 + (ptext (sLit "Running phase") <+> ppr phase) + (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + r <- pipeLoop next_phase output_fn + case phase of + HscOut {} -> + whenGeneratingDynamicToo dflags $ do + setDynFlags $ dynamicTooMkDynamicDynFlags dflags + -- TODO shouldn't ignore result: + _ <- pipeLoop phase input_fn + return () + _ -> + return () + return r + +runHookedPhase :: PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath) +runHookedPhase pp input dflags = + lookupHook runPhaseHook runPhase dflags pp input dflags + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + liftIO $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc + +getOutputFilename + :: Phase -> PipelineOutput -> String + -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename stop_phase output basename dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile <- output = case outputFile dflags of + Just f -> return f + Nothing -> + panic "SpecificFile: No filename" + | keep_this_output = persistent_fn + | otherwise = newTempName dflags suffix + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = gopt Opt_KeepHcFiles dflags + keep_s = gopt Opt_KeepSFiles dflags + keep_bc = gopt Opt_KeepLlvmFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = d persistent + | otherwise = persistent + +-- ----------------------------------------------------------------------------- +-- | Each phase in the pipeline returns the next phase to execute, and the +-- name of the file in which the output was placed. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the LLVM route to using the native code generator. +-- +runPhase :: PhasePlus -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (PhasePlus, -- next phase to run + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (RealPhase (Unlit sf)) input_fn dflags + = do + output_fn <- phaseOutputFilename (Cpp sf) + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + SysTools.Option "-h" + , SysTools.Option $ escape $ normalise input_fn + , SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + + liftIO $ SysTools.runUnlit dflags flags + + return (RealPhase (Cpp sf), output_fn) + where + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- Coverage.addTicksToBinds where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.lhs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (RealPhase (Cpp sf)) input_fn dflags0 + = do + src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + + if not (xopt Opt_Cpp dflags1) then do + -- we have to be careful to emit warnings only once. + unless (gopt Opt_Pp dflags1) $ + liftIO $ handleFlagWarnings dflags1 warns + + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (HsPp sf), input_fn) + else do + output_fn <- phaseOutputFilename (HsPp sf) + liftIO $ doCpp dflags1 True{-raw-} + input_fn output_fn + -- re-read the pragmas now that we've preprocessed the file + -- See #2464,#3457 + src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + (dflags2, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + liftIO $ checkProcessArgsResult dflags2 unhandled_flags + unless (gopt Opt_Pp dflags2) $ + liftIO $ handleFlagWarnings dflags2 warns + -- the HsPp pass below will emit warnings + + setDynFlags dflags2 + + return (RealPhase (HsPp sf), output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (RealPhase (HsPp sf)) input_fn dflags + = do + if not (gopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (Hsc sf), input_fn) + else do + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + liftIO $ SysTools.runPp dflags + ( [ SysTools.Option orig_fn + , SysTools.Option input_fn + , SysTools.FileOption "" output_fn + ] + ) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ handleFlagWarnings dflags1 warns + + return (RealPhase (Hsc sf), output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 + = do -- normal Hsc mode, not mkdependHS + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the include path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = takeDirectory basename + paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : paths } + + setDynFlags dflags + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do + do + buf <- hGetStringBuffer input_fn + (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) + return (Just buf, mod_name, imps, src_imps) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- getLocation src_flavour mod_name + + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + dest_file | writeInterfaceOnlyMode dflags + = hi_file + | otherwise + = o_file + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) + + source_unchanged <- liftIO $ + if not (isStopLn stop) + -- SourceModified unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return SourceModified + -- Otherwise look at file modification dates + else do dest_file_exists <- doesFileExist dest_file + if not dest_file_exists + then return SourceModified -- Need to recompile + else do t2 <- getModificationUTCTime dest_file + if t2 > src_timestamp + then return SourceUnmodified + else return SourceModified + + PipeState{hsc_env=hsc_env'} <- getPipeState + + -- Tell the finder cache about this module + mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_iface_date = Nothing, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + -- run the compiler! + result <- liftIO $ hscCompileOneShot hsc_env' + mod_summary source_unchanged + + return (HscOut src_flavour mod_name result, + panic "HscOut doesn't have an input filename") + +runPhase (HscOut src_flavour mod_name result) _ dflags = do + location <- getLocation src_flavour mod_name + setModLocation location + + let o_file = ml_obj_file location -- The real object file + hsc_lang = hscTarget dflags + next_phase = hscPostBackendPhase dflags src_flavour hsc_lang + + case result of + HscNotGeneratingCode -> + return (RealPhase next_phase, + panic "No output filename from Hsc when no-code") + HscUpToDate -> + do liftIO $ touchObjectFile dflags o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't get Nothing) + -- but we touch it anyway, to keep 'make' happy (we think). + return (RealPhase StopLn, o_file) + HscUpdateBoot -> + do -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + liftIO $ touchObjectFile dflags o_file + return (RealPhase next_phase, o_file) + HscUpdateSig -> + do -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + PipeState{hsc_env=hsc_env'} <- getPipeState + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + liftIO $ compileEmptyStub dflags hsc_env' basename location + return (RealPhase next_phase, o_file) + HscRecomp cgguts mod_summary + -> do output_fn <- phaseOutputFilename next_phase + + PipeState{hsc_env=hsc_env'} <- getPipeState + + (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn + case mStub of + Nothing -> return () + Just stub_c -> + do stub_o <- liftIO $ compileStub hsc_env' stub_c + setStubO stub_o + + return (RealPhase next_phase, outputFilename) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase (RealPhase CmmCpp) input_fn dflags + = do + output_fn <- phaseOutputFilename Cmm + liftIO $ doCpp dflags False{-not raw-} + input_fn output_fn + return (RealPhase Cmm, output_fn) + +runPhase (RealPhase Cmm) input_fn dflags + = do + let hsc_lang = hscTarget dflags + + let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang + + output_fn <- phaseOutputFilename next_phase + + PipeState{hsc_env} <- getPipeState + + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +-- we don't support preprocessing .c files (with -E) now. Doing so introduces +-- way too many hacks, and I can't say I've ever used it anyway. + +runPhase (RealPhase cc_phase) input_fn dflags + | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp] + = do + let platform = targetPlatform dflags + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs + let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + pkg_extra_cc_opts <- liftIO $ + if cc_phase `eqPhase` HCc + then return [] + else getPackageExtraCcOpts dflags pkgs + + framework_paths <- + if platformUsesFrameworks platform + then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs + let cmdlineFrameworkPaths = frameworkPaths dflags + return $ map ("-F"++) + (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + else return [] + + let split_objs = gopt Opt_SplitObjs dflags + split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] + | otherwise = [ ] + + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + -- Decide next phase + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- liftIO $ getGhcVersionPathName dflags + + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" + | cc_phase `eqPhase` Cobjcpp = "objective-c++" + | otherwise = "c" + liftIO $ SysTools.runCc dflags ( + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + [ SysTools.Option "-x", SysTools.Option gcc_lang_opt + , SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + pic_c_flags + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if platformOS platform == OSMinGW32 && + thisPackage dflags == basePackageKey + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. See #2872, commit + -- 5bd3072ac30216a505151601884ac88bf404c9f2 + ++ (if platformArch platform == ArchSPARC + then ["-mcpu=v9"] + else []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccpp && cc_phase /= Cobjcpp) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ [ "-S" ] + ++ cc_opt + ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt + , "-include", ghcVersionH + ] + ++ framework_paths + ++ split_opt + ++ include_paths + ++ pkg_extra_cc_opts + )) + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- Splitting phase + +runPhase (RealPhase Splitter) input_fn dflags + = do -- tmp_pfx is the prefix used for the split .s files + + split_s_prefix <- liftIO $ SysTools.newTempName dflags "split" + let n_files_fn = split_s_prefix + + liftIO $ SysTools.runSplit dflags + [ SysTools.FileOption "" input_fn + , SysTools.FileOption "" split_s_prefix + , SysTools.FileOption "" n_files_fn + ] + + -- Save the number of split files for future references + s <- liftIO $ readFile n_files_fn + let n_files = read s :: Int + dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + + setDynFlags dflags' + + -- Remember to delete all these files + liftIO $ addFilesToClean dflags' + [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] + + return (RealPhase SplitAs, + "**splitter**") -- we don't use the filename in SplitAs + +----------------------------------------------------------------------------- +-- As, SpitAs phase : Assembler + +-- This is for calling the assembler on a regular assembly file (not split). +runPhase (RealPhase (As with_cpp)) input_fn dflags + = do + -- LLVM from version 3.0 onwards doesn't support the OS X system + -- assembler, so we use clang as the assembler instead. (#5636) + let whichAsProg | hscTarget dflags == HscLlvm && + platformOS (targetPlatform dflags) == OSDarwin + = do + -- be careful what options we call clang with + -- see #5903 and #7617 for bugs caused by this. + llvmVer <- liftIO $ figureLlvmVersion dflags + return $ case llvmVer of + Just n | n >= 30 -> SysTools.runClang + _ -> SysTools.runAs + + | otherwise = return SysTools.runAs + + as_prog <- whichAsProg + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase + + -- we create directories for the object file, because it + -- might be a hierarchical module. + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + + ccInfo <- liftIO $ getCompilerInfo dflags + let runAssembler inputFilename outputFilename + = liftIO $ as_prog dflags + ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] + + -- See Note [-fPIC for assembler] + ++ map SysTools.Option pic_c_flags + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [SysTools.Option "-Qunused-arguments"] + else []) + ++ [ SysTools.Option "-x" + , if with_cpp + then SysTools.Option "assembler-with-cpp" + else SysTools.Option "assembler" + , SysTools.Option "-c" + , SysTools.FileOption "" inputFilename + , SysTools.Option "-o" + , SysTools.FileOption "" outputFilename + ]) + + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + runAssembler input_fn output_fn + return (RealPhase next_phase, output_fn) + + +-- This is for calling the assembler on a split assembly file (so a collection +-- of assembly files) +runPhase (RealPhase SplitAs) _input_fn dflags + = do + -- we'll handle the stub_o file in this phase, so don't MergeStub, + -- just jump straight to StopLn afterwards. + let next_phase = StopLn + output_fn <- phaseOutputFilename next_phase + + let base_o = dropExtension output_fn + osuf = objectSuf dflags + split_odir = base_o ++ "_" ++ osuf ++ "_split" + + let pic_c_flags = picCCOpts dflags + + -- this also creates the hierarchy + liftIO $ createDirectoryIfMissing True split_odir + + -- remove M_split/ *.o, because we're going to archive M_split/ *.o + -- later and we don't want to pick up any old objects. + fs <- liftIO $ getDirectoryContents split_odir + liftIO $ mapM_ removeFile $ + map (split_odir ) $ filter (osuf `isSuffixOf`) fs + + let (split_s_prefix, n) = case splitInfo dflags of + Nothing -> panic "No split info" + Just x -> x + + let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" + + split_obj :: Int -> FilePath + split_obj n = split_odir + takeFileName base_o ++ "__" ++ show n <.> osuf + + let assemble_file n + = SysTools.runAs dflags ( + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) ++ + + -- See Note [-fPIC for assembler] + map SysTools.Option pic_c_flags ++ + + [ SysTools.Option "-c" + , SysTools.Option "-o" + , SysTools.FileOption "" (split_obj n) + , SysTools.FileOption "" (split_s n) + ]) + + liftIO $ mapM_ assemble_file [1..n] + + -- Note [pipeline-split-init] + -- If we have a stub file, it may contain constructor + -- functions for initialisation of this module. We can't + -- simply leave the stub as a separate object file, because it + -- will never be linked in: nothing refers to it. We need to + -- ensure that if we ever refer to the data in this module + -- that needs initialisation, then we also pull in the + -- initialisation routine. + -- + -- To that end, we make a DANGEROUS ASSUMPTION here: the data + -- that needs to be initialised is all in the FIRST split + -- object. See Note [codegen-split-init]. + + PipeState{maybe_stub_o} <- getPipeState + case maybe_stub_o of + Nothing -> return () + Just stub_o -> liftIO $ do + tmp_split_1 <- newTempName dflags osuf + let split_1 = split_obj 1 + copyFile split_1 tmp_split_1 + removeFile split_1 + joinObjectFiles dflags [tmp_split_1, stub_o] split_1 + + -- join them into a single .o file + liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- LlvmOpt phase + +runPhase (RealPhase LlvmOpt) input_fn dflags + = do + ver <- liftIO $ readIORef (llvmVersion dflags) + + let opt_lvl = max 0 (min 2 $ optLevel dflags) + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map SysTools.Option $ words (llvmOpts ver !! opt_lvl) + else [] + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" + + + output_fn <- phaseOutputFilename LlvmLlc + + liftIO $ SysTools.runLlvmOpt dflags + ([ SysTools.FileOption "" input_fn, + SysTools.Option "-o", + SysTools.FileOption "" output_fn] + ++ optFlag + ++ [SysTools.Option tbaa]) + + return (RealPhase LlvmLlc, output_fn) + where + -- we always (unless -optlo specified) run Opt since we rely on it to + -- fix up some pretty big deficiencies in the code we generate + llvmOpts ver = [ "-mem2reg -globalopt" + , if ver >= 34 then "-O1 -globalopt" else "-O1" + -- LLVM 3.4 -O1 doesn't eliminate aliases reliably (bug #8855) + , "-O2" + ] + +----------------------------------------------------------------------------- +-- LlvmLlc phase + +runPhase (RealPhase LlvmLlc) input_fn dflags + = do + ver <- liftIO $ readIORef (llvmVersion dflags) + + let opt_lvl = max 0 (min 2 $ optLevel dflags) + -- iOS requires external references to be loaded indirectly from the + -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 + rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic" + | gopt Opt_PIC dflags = "pic" + | not (gopt Opt_Static dflags) = "dynamic-no-pic" + | otherwise = "static" + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" + + -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + let next_phase = case gopt Opt_NoLlvmMangler dflags of + False -> LlvmMangle + True | gopt Opt_SplitObjs dflags -> Splitter + True -> As False + + output_fn <- phaseOutputFilename next_phase + + -- AVX can cause LLVM 3.2 to generate a C-like frame pointer + -- prelude, see #9391 + when (ver == 32 && isAvxEnabled dflags) $ liftIO $ errorMsg dflags $ text + "Note: LLVM 3.2 has known problems with AVX instructions (see trac #9391)" + + liftIO $ SysTools.runLlvmLlc dflags + ([ SysTools.Option (llvmOpts !! opt_lvl), + SysTools.Option $ "-relocation-model=" ++ rmodel, + SysTools.FileOption "" input_fn, + SysTools.Option "-o", SysTools.FileOption "" output_fn] + ++ [SysTools.Option tbaa] + ++ map SysTools.Option fpOpts + ++ map SysTools.Option abiOpts + ++ map SysTools.Option sseOpts + ++ map SysTools.Option (avxOpts ver) + ++ map SysTools.Option avx512Opts + ++ map SysTools.Option stackAlignOpts) + + return (RealPhase next_phase, output_fn) + where + -- Bug in LLVM at O3 on OSX. + llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin + then ["-O1", "-O2", "-O2"] + else ["-O1", "-O2", "-O3"] + -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers + -- while compiling GHC source code. It's probably due to fact that it + -- does not enable VFP by default. Let's do this manually here + fpOpts = case platformArch (targetPlatform dflags) of + ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) + then ["-mattr=+v7,+vfp3"] + else if (elem VFPv3D16 ext) + then ["-mattr=+v7,+vfp3,+d16"] + else [] + ArchARM ARMv6 ext _ -> if (elem VFPv2 ext) + then ["-mattr=+v6,+vfp2"] + else ["-mattr=+v6"] + _ -> [] + -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still + -- compiles into soft-float ABI. We need to explicitly set abi + -- to hard + abiOpts = case platformArch (targetPlatform dflags) of + ArchARM _ _ HARD -> ["-float-abi=hard"] + ArchARM _ _ _ -> [] + _ -> [] + + sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"] + | isSse2Enabled dflags = ["-mattr=+sse2"] + | isSseEnabled dflags = ["-mattr=+sse"] + | otherwise = [] + + avxOpts ver | isAvx512fEnabled dflags = ["-mattr=+avx512f"] + | isAvx2Enabled dflags = ["-mattr=+avx2"] + | isAvxEnabled dflags = ["-mattr=+avx"] + | ver == 32 = ["-mattr=-avx"] -- see #9391 + | otherwise = [] + + avx512Opts = + [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++ + [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] ++ + [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ] + + stackAlignOpts = + case platformArch (targetPlatform dflags) of + ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"] + _ -> [] + +----------------------------------------------------------------------------- +-- LlvmMangle phase + +runPhase (RealPhase LlvmMangle) input_fn dflags + = do + let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False + output_fn <- phaseOutputFilename next_phase + liftIO $ llvmFixupAsm dflags input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase (RealPhase MergeStub) input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (RealPhase StopLn, output_fn) + +-- warning suppression +runPhase (RealPhase other) _input_fn _dflags = + panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + +getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation +getLocation src_flavour mod_name = do + dflags <- getDynFlags + + PipeEnv{ src_basename=basename, + src_suffix=suff } <- getPipeEnv + + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames, and this is as good a way + -- as any to generate them, and better than most. (e.g. takes + -- into account the -osuf flags) + location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + + return location4 + +----------------------------------------------------------------------------- +-- MoveBinary sort-of-phase +-- After having produced a binary, move it somewhere else and generate a +-- wrapper script calling the binary. Currently, we need this only in +-- a parallel way (i.e. in GUM), because PVM expects the binary in a +-- central directory. +-- This is called from linkBinary below, after linking. I haven't made it +-- a separate phase to minimise interfering with other modules, and +-- we don't need the generality of a phase (MoveBinary is always +-- done after linking and makes only sense in a parallel setup) -- HWL + +runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool +runPhase_MoveBinary dflags input_fn + | WayPar `elem` ways dflags && not (gopt Opt_Static dflags) = + panic ("Don't know how to combine PVM wrapper and dynamic wrapper") + | WayPar `elem` ways dflags = do + let sysMan = pgm_sysman dflags + pvm_root <- getEnv "PVM_ROOT" + pvm_arch <- getEnv "PVM_ARCH" + let + pvm_executable_base = "=" ++ input_fn + pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base + -- nuke old binary; maybe use configur'ed names for cp and rm? + _ <- tryIO (removeFile pvm_executable) + -- move the newly created binary into PVM land + copy dflags "copying PVM executable" input_fn pvm_executable + -- generate a wrapper script for running a parallel prg under PVM + writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan) + return True + | otherwise = return True + +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags extn + oFile <- newTempName dflags "o" + writeFile cFile xs + let rtsDetails = getPackageDetails dflags rtsPackageKey + pic_c_flags = picCCOpts dflags + SysTools.runCc dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ map (FileOption "-I") (includeDirs rtsDetails) + ++ map Option pic_c_flags) + return oFile + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + mkExtraObj dflags "c" (showSDoc dflags main) + + where + main + | gopt Opt_NoHsMain dflags = Outputable.empty + | otherwise = vcat [ + text "#include \"Rts.h\"", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> ptext (sLit " __conf.rts_opts= ") <> + text (show opts) <> semi, + text " __conf.rts_hs_main = rtsTrue;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + link_opts info = hcat [ + text "\t.section ", text ghcLinkInfoSectionName, + text ",\"\",", + text elfSectionNote, + text "\n", + + text "\t.ascii \"", info', text "\"\n", + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- compiler/nativeGen/AsmCodeGen.lhs for another instance + -- where we need to do this. + (if platformHasGnuNonexecStack (targetPlatform dflags) + then text ".section .note.GNU-stack,\"\",@progbits\n" + else Outputable.empty) + + ] + where + info' = text $ escape info + + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + + elfSectionNote :: String + elfSectionNote = case platformArch (targetPlatform dflags) of + ArchARM _ _ _ -> "%note" + _ -> "@note" + +-- The "link info" is a string representing the parameters of the +-- link. We save this information in the binary, and the next time we +-- link, if nothing else has changed, we use the link info stored in +-- the existing binary to decide whether to re-link or not. +getLinkInfo :: DynFlags -> [PackageKey] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages + pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) + then getPackageFrameworks dflags dep_packages + else return [] + let extra_ld_inputs = ldInputs dflags + let + link_info = (package_link_opts, + pkg_frameworks, + rtsOpts dflags, + rtsOptsEnabled dflags, + gopt Opt_NoHsMain dflags, + map showOpt extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) + +-- generates a Perl skript starting a parallel prg under PVM +mk_pvm_wrapper_script :: String -> String -> String -> String +mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ + [ + "eval 'exec perl -S $0 ${1+\"$@\"}'", + " if $running_under_some_shell;", + "# =!=!=!=!=!=!=!=!=!=!=!", + "# This script is automatically generated: DO NOT EDIT!!!", + "# Generated by Glasgow Haskell Compiler", + "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!", + "#", + "$pvm_executable = '" ++ pvm_executable ++ "';", + "$pvm_executable_base = '" ++ pvm_executable_base ++ "';", + "$SysMan = '" ++ sysMan ++ "';", + "", + {- ToDo: add the magical shortcuts again iff we actually use them -- HWL + "# first, some magical shortcuts to run "commands" on the binary", + "# (which is hidden)", + "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {", + " local($cmd) = $1;", + " system("$cmd $pvm_executable");", + " exit(0); # all done", + "}", -} + "", + "# Now, run the real binary; process the args first", + "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base, + "$debug = '';", + "$nprocessors = 0; # the default: as many PEs as machines in PVM config", + "@nonPVM_args = ();", + "$in_RTS_args = 0;", + "", + "args: while ($a = shift(@ARGV)) {", + " if ( $a eq '+RTS' ) {", + " $in_RTS_args = 1;", + " } elsif ( $a eq '-RTS' ) {", + " $in_RTS_args = 0;", + " }", + " if ( $a eq '-d' && $in_RTS_args ) {", + " $debug = '-';", + " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } else {", + " push(@nonPVM_args, $a);", + " }", + "}", + "", + "local($return_val) = 0;", + "# Start the parallel execution by calling SysMan", + "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");", + "$return_val = $?;", + "# ToDo: fix race condition moving files and flushing them!!", + "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";", + "exit($return_val);" + ] + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [PackageKey] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToPackageKey (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO () +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO () +linkBinary' staticLink dflags o_files dep_packages = do + let platform = targetPlatform dflags + mySettings = settings dflags + verbFlags = getVerbFlags dflags + output_fn = exeFileName staticLink dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d output_fn) + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + not (gopt Opt_Static dflags) + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "$ORIGIN" + (l `makeRelativeTo` full_output_fn) + else l + rpath = if gopt Opt_RPath dflags + then ["-Wl,-rpath", "-Wl," ++ libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Wl,-rpath-link", "-Wl," ++ l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + not (gopt Opt_Static dflags) && + gopt Opt_RPath dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "@loader_path" + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Wl,-rpath", "-Wl," ++ libpath] + | otherwise = ["-L" ++ l] + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages + + pkg_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else other_flags ++ package_hs_libs ++ extra_libs -- -Wl,-u, contained in other_flags + -- needs to be put before -l, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages + let framework_opts = getFrameworkOpts dflags platform + + -- probably _stub.o files + let extra_ld_inputs = ldInputs dflags + + -- Here are some libs that need to be linked at the *end* of + -- the command line, because they contain symbols that are referred to + -- by the RTS. We can't therefore use the ordinary way opts for these. + let + debug_opts | WayDebug `elem` ways dflags = [ +#if defined(HAVE_LIBBFD) + "-lbfd", "-liberty" +#endif + ] + | otherwise = [] + + let thread_opts + | WayThreaded `elem` ways dflags = + let os = platformOS (targetPlatform dflags) + in if os == OSOsf3 then ["-lpthread", "-lexc"] + else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD, + OSNetBSD, OSHaiku, OSQNXNTO, OSiOS, OSDarwin] + then [] + else ["-lpthread"] + | otherwise = [] + + rc_objs <- maybeCreateManifest dflags output_fn + + let link = if staticLink + then SysTools.runLibtool + else SysTools.runLink + link dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + [] + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if sLdSupportsCompactUnwind mySettings && + not staticLink && + (platformOS platform == OSDarwin || platformOS platform == OSiOS) && + case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchARM {} -> True + ArchARM64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- '-no_pie' + -- iOS uses 'dynamic-no-pic', so we must pass this to ld to suppress a warning; see #7722 + ++ (if platformOS platform == OSiOS && + not staticLink + then ["-Wl,-no_pie"] + else []) + + -- '-Wl,-read_only_relocs,suppress' + -- ld gives loads of warnings like: + -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure + -- when linking any program. We're not sure + -- whether this is something we ought to fix, but + -- for now this flags silences them. + ++ (if platformOS platform == OSDarwin && + platformArch platform == ArchX86 && + not staticLink + then ["-Wl,-read_only_relocs,suppress"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj:noteLinkObjs + ++ pkg_link_opts + ++ pkg_framework_opts + ++ debug_opts + ++ thread_opts + )) + + -- parallel only: move binary to another dir -- HWL + success <- runPhase_MoveBinary dflags output_fn + unless success $ + throwGhcExceptionIO (InstallationError ("cannot move binary")) + + +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags + | Just s <- outputFile dflags = + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s "exe" + _ -> if staticLink + then s "a" + else s + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else if staticLink + then "liba.a" + else "a.out" + where s ext | null (takeExtension s) = s <.> ext + | otherwise = s + +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + gopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "\n"++ + " \n"++ + " \n\n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + "\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (gopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] + + +linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () +linkDynLibCheck dflags o_files dep_packages + = do + when (haveRtsOptsFlags dflags) $ do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + linkDynLib dflags o_files dep_packages + +linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () +linkStaticLibCheck dflags o_files dep_packages + = do + when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ + throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS") + linkBinary' True dflags o_files dep_packages + +-- ----------------------------------------------------------------------------- +-- Running CPP + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) + + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS=1", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1", + "-D" ++ TARGET_OS ++ "_HOST_OS=1", + "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__=1" | isSseEnabled dflags ] ++ + [ "-D__SSE2__=1" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__=1" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__=1" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__=1" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__=1" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__=1" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__=1" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__=1" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + +#ifdef GHCI + let th_defs = [ "-D__GLASGOW_HASKELL_TH__=YES" ] +#else + let th_defs = [ "-D__GLASGOW_HASKELL_TH__=NO" ] +#endif + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = + [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt + , "-include", ghcVersionH + ] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case llvmVer of + Just n -> [ "-D__GLASGOW_HASKELL_LLVM__="++show n ] + _ -> [] + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let mySettings = settings dflags + ldIsGnuLd = sLdIsGnuLd mySettings + osInfo = platformOS (targetPlatform dflags) + ld_r args cc = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-Wl,-r" + ] + ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] + then [] + else [SysTools.Option "-nodefaultlibs"]) + ++ (if osInfo == OSFreeBSD + then [SysTools.Option "-L/usr/lib"] + else []) + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + && ldIsGnuLd + then [SysTools.Option "-Wl,-no-relax"] + else []) + ++ map SysTools.Option ld_build_id + ++ [ SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ args) + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"] + | otherwise = [] + + ccInfo <- getCompilerInfo dflags + if ldIsGnuLd + then do + script <- newTempName dflags "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (cwd ) o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [SysTools.FileOption "" script] ccInfo + else if sLdSupportsFilelist mySettings + then do + filelist <- newTempName dflags "filelist" + writeFile filelist $ unlines o_files + ld_r [SysTools.Option "-Wl,-filelist", + SysTools.FileOption "-Wl," filelist] ccInfo + else do + ld_r (map (SysTools.FileOption "") o_files) ccInfo + +-- ----------------------------------------------------------------------------- +-- Misc. + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + HscNothing == hscTarget dflags + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase +hscPostBackendPhase _ HsBootFile _ = StopLn +hscPostBackendPhase _ HsigFile _ = StopLn +hscPostBackendPhase dflags _ hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm | gopt Opt_SplitObjs dflags -> Splitter + | otherwise -> As False + HscLlvm -> LlvmOpt + HscNothing -> StopLn + HscInterpreted -> StopLn + +touchObjectFile :: DynFlags -> FilePath -> IO () +touchObjectFile dflags path = do + createDirectoryIfMissing True $ takeDirectory path + SysTools.touch dflags "Touching object file" path + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + dirs <- getPackageIncludePath dflags [rtsPackageKey] + + found <- filterM doesFileExist (map ( "ghcversion.h") dirs) + case found of + [] -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing")) + (x:_) -> return x + +-- Note [-fPIC for assembler] +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs new file mode 100644 index 00000000..42ac14ee --- /dev/null +++ b/compiler/main/DynFlags.hs @@ -0,0 +1,4308 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +module DynFlags ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), + ExtensionFlag(..), + Language(..), + PlatformConstants(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), + ProfAuto(..), + glasgowExtsFlags, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, + wopt, wopt_set, wopt_unset, + xopt, xopt_set, xopt_unset, + lang_set, + useUnicodeSyntax, + whenGeneratingDynamicToo, ifGeneratingDynamicToo, + whenCannotGenerateDynamicToo, + dynamicTooMkDynamicDynFlags, + DynFlags(..), + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + PkgConfRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fWarningFlags, fLangFlags, xFlags, + dynFlagDependencies, + tablesNextToCode, mkTablesNextToCode, + SigOf(..), getSigOf, + makeDynFlagsConsistent, + + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, + wayGeneralFlags, wayUnsetGeneralFlags, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** System tool settings and locations + Settings(..), + targetPlatform, programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + versionedAppDir, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_libtool, pgm_readelf, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + + -- ** Manipulating DynFlags + defaultDynFlags, -- Settings -> DynFlags + defaultWays, + interpWays, + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultLogAction, + defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, + defaultFlushOut, + defaultFlushErr, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setPackageKey, + interpretPackageEnv, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags + allFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- * Configuration of the stg-to-stg passes + StgToDo(..), + getStgToDo, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + +#ifdef GHCI + rtsIsProfiled, +#endif + dynamicGhc, + +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, + tAG_MASK, + mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, + + unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSseEnabled, + isSse2Enabled, + isSse4_2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + + -- * Linker/compiler information + LinkerInfo(..), + CompilerInfo(..), + ) where + +#include "HsVersions.h" + +import Platform +import PlatformConstants +import Module +import PackageConfig +import {-# SOURCE #-} Hooks +import {-# SOURCE #-} PrelNames ( mAIN ) +import {-# SOURCE #-} Packages (PackageState) +import DriverPhases ( Phase(..), phaseInputExt ) +import Config +import CmdLineParser +import Constants +import Panic +import Util +import Maybes +import MonadUtils +import qualified Pretty +import SrcLoc +import FastString +import Outputable +#ifdef GHCI +import Foreign.C ( CInt(..) ) +import System.IO.Unsafe ( unsafeDupablePerformIO ) +#endif +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Exception (throwIO) + +import Data.Bits +import Data.Char +import Data.Int +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import System.FilePath +import System.Directory +import System.Environment (getEnv) +import System.IO +import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import GHC.Foreign (withCString, peekCString) + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Usually at least two sections need to be +-- updated: +-- +-- * Flag Reference section in docs/users-guide/flags.xml lists all available +-- flags together with a short description +-- +-- * Flag description in docs/users_guide/using.xml provides a detailed +-- explanation of flags' usage. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_raw + -- All of the cmm subflags (there are a lot!) Automatically + -- enabled if you run -ddump-cmm + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_rn + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg + | Opt_D_dump_call_arity + | Opt_D_dump_stranal + | Opt_D_dump_strsigs + | Opt_D_dump_tc + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_vect + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + + deriving (Eq, Show, Enum) + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + + | Opt_WarnIsError -- -Werror; makes warnings fatal + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + + -- optimisation opts + | Opt_CallArity + | Opt_Strictness + | Opt_LateDmdAnal + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_Vectorise + | Opt_VectorisationAvoidance + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) + | Opt_LlvmPassVectorsInRegisters -- Pass SIMD vectors in registers (requires a patched LLVM) (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmElimCommonBlocks + | Opt_OmitYields + | Opt_SimpleListLiterals + | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitObjs + | Opt_StgStats + | Opt_HideAllPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_Hpc_No_Auto + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_EmitExternalCore + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_Parallel + | Opt_GranMacros + | Opt_PIC + | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_Static + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_PprCaseAsLet + | Opt_PprShowTicks + + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + + -- debugging flags + | Opt_Debug + + deriving (Eq, Show, Enum) + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnContextQuantification + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnAMP + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnPointlessPragmas + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSigs + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + deriving (Eq, Show, Enum) + +data Language = Haskell98 | Haskell2010 + deriving Enum + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None + | Sf_Unsafe + | Sf_Trustworthy + | Sf_Safe + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + +instance Outputable SafeHaskellMode where + ppr = text . show + +data ExtensionFlag +-- See Note [Updating flag description in the User's Guide] + = Opt_Cpp + | Opt_OverlappingInstances + | Opt_UndecidableInstances + | Opt_IncoherentInstances + | Opt_MonomorphismRestriction + | Opt_MonoPatBinds + | Opt_MonoLocalBinds + | Opt_RelaxedPolyRec -- Deprecated + | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting + | Opt_ForeignFunctionInterface + | Opt_UnliftedFFITypes + | Opt_InterruptibleFFI + | Opt_CApiFFI + | Opt_GHCForeignImportPrim + | Opt_JavaScriptFFI + | Opt_ParallelArrays -- Syntactic support for parallel arrays + | Opt_Arrows -- Arrow-notation syntax + | Opt_TemplateHaskell + | Opt_QuasiQuotes + | Opt_ImplicitParams + | Opt_ImplicitPrelude + | Opt_ScopedTypeVariables + | Opt_AllowAmbiguousTypes + | Opt_UnboxedTuples + | Opt_BangPatterns + | Opt_TypeFamilies + | Opt_OverloadedStrings + | Opt_OverloadedLists + | Opt_NumDecimals + | Opt_DisambiguateRecordFields + | Opt_RecordWildCards + | Opt_RecordPuns + | Opt_ViewPatterns + | Opt_GADTs + | Opt_GADTSyntax + | Opt_NPlusKPatterns + | Opt_DoAndIfThenElse + | Opt_RebindableSyntax + | Opt_ConstraintKinds + | Opt_PolyKinds -- Kind polymorphism + | Opt_DataKinds -- Datatype promotion + | Opt_InstanceSigs + + | Opt_StandaloneDeriving + | Opt_DeriveDataTypeable + | Opt_AutoDeriveTypeable -- Automatic derivation of Typeable + | Opt_DeriveFunctor + | Opt_DeriveTraversable + | Opt_DeriveFoldable + | Opt_DeriveGeneric -- Allow deriving Generic/1 + | Opt_DefaultSignatures -- Allow extra signatures for defmeths + | Opt_DeriveAnyClass -- Allow deriving any class + + | Opt_TypeSynonymInstances + | Opt_FlexibleContexts + | Opt_FlexibleInstances + | Opt_ConstrainedClassMethods + | Opt_MultiParamTypeClasses + | Opt_NullaryTypeClasses + | Opt_FunctionalDependencies + | Opt_UnicodeSyntax + | Opt_ExistentialQuantification + | Opt_MagicHash + | Opt_EmptyDataDecls + | Opt_KindSignatures + | Opt_RoleAnnotations + | Opt_ParallelListComp + | Opt_TransformListComp + | Opt_MonadComprehensions + | Opt_GeneralizedNewtypeDeriving + | Opt_RecursiveDo + | Opt_PostfixOperators + | Opt_TupleSections + | Opt_PatternGuards + | Opt_LiberalTypeSynonyms + | Opt_RankNTypes + | Opt_ImpredicativeTypes + | Opt_TypeOperators + | Opt_ExplicitNamespaces + | Opt_PackageImports + | Opt_ExplicitForAll + | Opt_AlternativeLayoutRule + | Opt_AlternativeLayoutRuleTransitional + | Opt_DatatypeContexts + | Opt_NondecreasingIndentation + | Opt_RelaxedLayout + | Opt_TraditionalRecordSyntax + | Opt_LambdaCase + | Opt_MultiWayIf + | Opt_BinaryLiterals + | Opt_NegativeLiterals + | Opt_EmptyCase + | Opt_PatternSynonyms + | Opt_PartialTypeSignatures + | Opt_NamedWildCards + | Opt_StaticPointers + deriving (Eq, Enum, Show) + +data SigOf = NotSigOf + | SigOf Module + | SigOfMap (Map ModuleName Module) + +getSigOf :: DynFlags -> ModuleName -> Maybe Module +getSigOf dflags n = + case sigOf dflags of + NotSigOf -> Nothing + SigOf m -> Just m + SigOfMap m -> Map.lookup n m + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + hscTarget :: HscTarget, + settings :: Settings, + -- See Note [Signature parameters in TcGblEnv and DynFlags] + sigOf :: SigOf, -- ^ Compiling an hs-boot against impl. + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + optLevel :: Int, -- ^ Optimisation level + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + ruleCheck :: Maybe String, + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel + -- in --make mode, where Nothing ==> compile as + -- many in parallel as there are CPUs. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See CoreMonad.FloatOutSwitches + + historySize :: Int, + + cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + ctxtStkDepth :: Int, -- ^ Typechecker context stack depth + tyFunStkDepth :: Int, -- ^ Typechecker type function stack depth + + thisPackage :: PackageKey, -- ^ name of package currently being compiled + + -- ways + ways :: [Way], -- ^ Way flags from the command line + buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) + rtsBuildTag :: String, -- ^ The RTS \"way\" + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + + canGenerateDynamicToo :: IORef Bool, + dynObjectSuf :: String, + dynHiSuf :: String, + + -- Packages.isDllName needs to know whether a call is within a + -- single DLL or not. Normally it does this by seeing if the call + -- is to the same package, but for the ghc package, we split the + -- package between 2 DLLs. The dllSplit tells us which sets of + -- modules are in which package. + dllSplitFile :: Maybe FilePath, + dllSplit :: Maybe [Set String], + + outputFile :: Maybe String, + dynOutputFile :: Maybe String, + outputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + -- | This is set by 'DriverPipeline.runPipeline' based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: [String], + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + + -- GHC API hooks + hooks :: Hooks, + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + extraPkgConfs :: [PkgConfRef] -> [PkgConfRef], + -- ^ The @-package-db@ flags given on the command line, in the order + -- they appeared. + + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + -- Package state + -- NB. do not modify this field, it is calculated by + -- Packages.initPackages and Packages.updatePackages. + pkgDatabase :: Maybe [PackageConfig], + pkgState :: PackageState, + + -- Temporary files + -- These have to be IORefs, because the defaultCleanupHandler needs to + -- know what to clean when an exception happens + filesToClean :: IORef [FilePath], + dirsToClean :: IORef (Map FilePath FilePath), + filesToNotIntermediateClean :: IORef [FilePath], + -- The next available suffix to uniquely name a temp file, updated atomically + nextTempSuffix :: IORef Int, + + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + + -- hsc dynamic flags + dumpFlags :: IntSet, + generalFlags :: IntSet, + warningFlags :: IntSet, + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + extensions :: [OnOff ExtensionFlag], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + extensionFlags :: IntSet, + + -- Unfolding control + -- See Note [Discounts and thresholds] in CoreUnfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufKeenessFactor :: Float, + ufDearOp :: Int, + + maxWorkerArgs :: Int, + + ghciHistSize :: Int, + + -- | MsgDoc output action: use "ErrUtils" instead of this if you can + log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, + + haddockOptions :: Maybe String, + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + traceLevel :: Int, -- Standard level is 1. Less verbose is 0. + + useUnicode :: Bool, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + + interactivePrint :: Maybe String, + + llvmVersion :: IORef Int, + + nextWrapperNum :: IORef (ModuleEnv Int), + + -- | Machine dependant flags (-m stuff) + sseVersion :: Maybe SseVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + + -- | Run-time linker information (what options we need, etc.) + rtldInfo :: IORef (Maybe LinkerInfo), + + -- | Run-time compiler information + rtccInfo :: IORef (Maybe CompilerInfo), + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int +} + +class HasDynFlags m where + getDynFlags :: m DynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + replaceDynFlags :: t -> DynFlags -> t + +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) + +data Settings = Settings { + sTargetPlatform :: Platform, -- Filled in by SysTools + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + sProgramName :: String, + sProjectVersion :: String, + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + sLdSupportsCompactUnwind :: Bool, + sLdSupportsBuildId :: Bool, + sLdSupportsFilelist :: Bool, + sLdIsGnuLd :: Bool, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_libtool :: String, + sPgm_readelf :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String], -- LLVM: llc static compiler + + sPlatformConstants :: PlatformConstants + } + +targetPlatform :: DynFlags -> Platform +targetPlatform dflags = sTargetPlatform (settings dflags) +programName :: DynFlags -> String +programName dflags = sProgramName (settings dflags) +projectVersion :: DynFlags -> String +projectVersion dflags = sProjectVersion (settings dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = sPgm_libtool (settings dflags) +pgm_readelf :: DynFlags -> String +pgm_readelf dflags = sPgm_readelf (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ sOpt_P (settings dflags) +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ sOpt_c (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) + +-- | The directory for this version of ghc in the user's app directory +-- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- +versionedAppDir :: DynFlags -> IO FilePath +versionedAppDir dflags = do + appdir <- getAppUserDataDirectory (programName dflags) + return $ appdir (TARGET_ARCH ++ '-':TARGET_OS ++ '-':projectVersion dflags) + +-- | The target code type of the compilation (if any). +-- +-- Whenever you change the target, also make sure to set 'ghcLink' to +-- something sensible. +-- +-- 'HscNothing' can be used to avoid generating any output, however, note +-- that: +-- +-- * If a program uses Template Haskell the typechecker may try to run code +-- from an imported module. This will fail if no code has been generated +-- for this module. You can use 'GHC.needsTemplateHaskell' to detect +-- whether this might be the case and choose to either switch to a +-- different target or avoid typechecking such modules. (The latter may be +-- preferable for security reasons.) +-- +data HscTarget + = HscC -- ^ Generate C code. + | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. + | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') + | HscNothing -- ^ Don't generate any code. See notes above. + deriving (Eq, Show) + +-- | Will this target result in an object file on the disk? +isObjectTarget :: HscTarget -> Bool +isObjectTarget HscC = True +isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True +isObjectTarget _ = False + +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = ptext (sLit "CompManager") + ppr OneShot = ptext (sLit "OneShot") + ppr MkDepend = ptext (sLit "MkDepend") + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +data PackageArg = PackageArg String + | PackageIdArg String + | PackageKeyArg String + deriving (Eq, Show) + +data ModRenaming = ModRenaming Bool [(String, String)] + deriving (Eq, Show) + +data PackageFlag + = ExposePackage PackageArg ModRenaming + | HidePackage String + | IgnorePackage String + | TrustPackage String + | DistrustPackage String + deriving (Eq, Show) + +defaultHscTarget :: Platform -> HscTarget +defaultHscTarget = defaultObjectTarget + +-- | The 'HscTarget' value corresponding to the default way to create +-- object files on the current platform. +defaultObjectTarget :: Platform -> HscTarget +defaultObjectTarget platform + | platformUnregisterised platform = HscC + | cGhcWithNativeCodeGen == "YES" = HscAsm + | otherwise = HscLlvm + +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode dflags + = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags)) + +-- Determines whether we will be compiling +-- info tables that reside just before the entry code, or with an +-- indirection to the entry code. See TABLES_NEXT_TO_CODE in +-- includes/rts/storage/InfoTables.h. +mkTablesNextToCode :: Bool -> Bool +mkTablesNextToCode unregisterised + = not unregisterised && cGhcEnableTablesNextToCode == "YES" + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayCustom String -- for GHC API clients building custom variants + | WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayPar + | WayGran + | WayNDP + | WayDyn + deriving (Eq, Ord, Show) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + (WayCustom {}) `allowedWith` _ = True + WayProf `allowedWith` WayNDP = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" +wayTag WayPar = "mp" +wayTag WayGran = "mg" +wayTag WayNDP = "ndp" + +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True +wayRTSOnly WayPar = False +wayRTSOnly WayGran = False +wayRTSOnly WayNDP = False + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" +wayDesc WayPar = "Parallel" +wayDesc WayGran = "GranSim" +wayDesc WayNDP = "Nested data parallelism" + +-- Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayEventLog = [] +wayGeneralFlags _ WayPar = [Opt_Parallel] +wayGeneralFlags _ WayGran = [Opt_GranMacros] +wayGeneralFlags _ WayNDP = [] + +-- Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting objects + -- when we're going to be dynamically + -- linking. Plus it breaks compilation + -- on OSX x86. + Opt_SplitObjs] +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] +wayUnsetGeneralFlags _ WayPar = [] +wayUnsetGeneralFlags _ WayGran = [] +wayUnsetGeneralFlags _ WayNDP = [] + +wayExtras :: Platform -> Way -> DynFlags -> DynFlags +wayExtras _ (WayCustom {}) dflags = dflags +wayExtras _ WayThreaded dflags = dflags +wayExtras _ WayDebug dflags = dflags +wayExtras _ WayDyn dflags = dflags +wayExtras _ WayProf dflags = dflags +wayExtras _ WayEventLog dflags = dflags +wayExtras _ WayPar dflags = exposePackage' "concurrent" dflags +wayExtras _ WayGran dflags = exposePackage' "concurrent" dflags +wayExtras _ WayNDP dflags = setExtensionFlag' Opt_ParallelArrays + $ setGeneralFlag' Opt_Vectorise dflags + +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] +wayOptc _ WayPar = ["-DPAR", "-w"] +wayOptc _ WayGran = ["-DGRAN"] +wayOptc _ WayNDP = [] + +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- FreeBSD's default threading library is the KSE-based M:N libpthread, + -- which GHC has some problems with. It's currently not clear whether + -- the problems are our fault or theirs, but it seems that using the + -- alternative 1:1 threading library libthr works around it: + OSFreeBSD -> ["-lthr"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] +wayOptl _ WayPar = ["-L${PVM_ROOT}/lib/${PVM_ARCH}", + "-lpvm3", + "-lgpvm3"] +wayOptl _ WayGran = [] +wayOptl _ WayNDP = [] + +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] +wayOptP _ WayPar = ["-D__PARALLEL_HASKELL__"] +wayOptP _ WayGran = ["-D__GRANSIM__"] +wayOptP _ WayNDP = [] + +whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) + +ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g + +whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenCannotGenerateDynamicToo dflags f + = ifCannotGenerateDynamicToo dflags f (return ()) + +ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifCannotGenerateDynamicToo dflags f g + = generateDynamicTooConditional dflags g f g + +generateDynamicTooConditional :: MonadIO m + => DynFlags -> m a -> m a -> m a -> m a +generateDynamicTooConditional dflags canGen cannotGen notTryingToGen + = if gopt Opt_BuildDynamicToo dflags + then do let ref = canGenerateDynamicToo dflags + b <- liftIO $ readIORef ref + if b then canGen else cannotGen + else notTryingToGen + +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef [] + refDirsToClean <- newIORef Map.empty + refFilesToNotIntermediateClean <- newIORef [] + refGeneratedDumps <- newIORef Set.empty + refLlvmVersion <- newIORef 28 + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + return dflags{ + canGenerateDynamicToo = refCanGenerateDynamicToo, + nextTempSuffix = refNextTempSuffix, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + filesToNotIntermediateClean = refFilesToNotIntermediateClean, + generatedDumps = refGeneratedDumps, + llvmVersion = refLlvmVersion, + nextWrapperNum = wrapperNum, + useUnicode = canUseUnicode, + rtldInfo = refRtldInfo, + rtccInfo = refRtccInfo + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + hscTarget = defaultHscTarget (sTargetPlatform mySettings), + sigOf = NotSigOf, + verbosity = 0, + optLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + maxRelevantBinds = Just 6, + simplTickFactor = 100, + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Just 1, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + cmdlineHcIncludes = [], + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, + tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH, + + thisPackage = mainPackageKey, + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + + canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", + dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf = "dyn_hi", + + dllSplitFile = Nothing, + dllSplit = Nothing, + + pluginModNames = [], + pluginModNameOpts = [], + hooks = emptyHooks, + + outputFile = Nothing, + dynOutputFile = Nothing, + outputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + + hpcDir = ".hpc", + + extraPkgConfs = id, + packageFlags = [], + packageEnv = Nothing, + pkgDatabase = Nothing, + pkgState = panic "no package state yet: call GHC.setSessionDynFlags", + ways = defaultWays mySettings, + buildTag = mkBuildTag (defaultWays mySettings), + rtsBuildTag = mkBuildTag (defaultWays mySettings), + splitInfo = Nothing, + settings = mySettings, + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", + filesToClean = panic "defaultDynFlags: No filesToClean", + dirsToClean = panic "defaultDynFlags: No dirsToClean", + filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", + haddockOptions = Nothing, + dumpFlags = IntSet.empty, + generalFlags = IntSet.fromList (map fromEnum (defaultFlags mySettings)), + warningFlags = IntSet.fromList (map fromEnum standardWarnings), + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + -- The ufCreationThreshold threshold must be reasonably high to + -- take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline + -- into Csg.calc (The unfolding for sqr never makes it into the + -- interface file.) + ufCreationThreshold = 750, + ufUseThreshold = 60, + ufFunAppDiscount = 60, + -- Be fairly keen to inline a fuction if that means + -- we'll be able to pick the right method from a dictionary + ufDictDiscount = 30, + ufKeenessFactor = 1.5, + ufDearOp = 40, + + maxWorkerArgs = 10, + + ghciHistSize = 50, -- keep a log of length 50 by default + + log_action = defaultLogAction, + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + traceLevel = 1, + profAuto = NoProfAuto, + llvmVersion = panic "defaultDynFlags: No llvmVersion", + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", + sseVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + rtldInfo = panic "defaultDynFlags: no rtldInfo", + rtccInfo = panic "defaultDynFlags: no rtccInfo", + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32 + } + +defaultWays :: Settings -> [Way] +defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then [WayDyn] + else [] + +interpWays :: [Way] +interpWays = if dynamicGhc + then [WayDyn] + else [] + +-------------------------------------------------------------------------- + +type FatalMessager = String -> IO () +type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + +defaultLogAction :: LogAction +defaultLogAction dflags severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevDump -> printSDoc (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage severity srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + where printSDoc = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty + -- Adds a newline + +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + = Pretty.printDoc_ Pretty.PageMode (pprCols dflags) h doc + where -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + doc = runSDoc d (initSDocContext dflags sty) + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +data OnOff a = On a + | Off a + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] -> IntSet +flattenExtensionFlags ml = foldr f defaultExtensionFlags + where f (On f) flags = IntSet.insert (fromEnum f) flags + f (Off f) flags = IntSet.delete (fromEnum f) flags + defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml)) + +languageExtensions :: Maybe Language -> [ExtensionFlag] + +languageExtensions Nothing + -- Nothing => the default case + = Opt_NondecreasingIndentation -- This has been on by default for some time + : delete Opt_DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + + -- NB: MonoPatBinds is no longer the default + +languageExtensions (Just Haskell98) + = [Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_NPlusKPatterns, + Opt_DatatypeContexts, + Opt_TraditionalRecordSyntax, + Opt_NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + +languageExtensions (Just Haskell2010) + = [Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_DatatypeContexts, + Opt_TraditionalRecordSyntax, + Opt_EmptyDataDecls, + Opt_ForeignFunctionInterface, + Opt_PatternGuards, + Opt_DoAndIfThenElse, + Opt_RelaxedPolyRec] + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) + || (verbosity dflags >= 4 && enableIfVerbose f) + where enableIfVerbose Opt_D_dump_tc_trace = False + enableIfVerbose Opt_D_dump_rn_trace = False + enableIfVerbose Opt_D_dump_cs_trace = False + enableIfVerbose Opt_D_dump_if_trace = False + enableIfVerbose Opt_D_dump_vt_trace = False + enableIfVerbose Opt_D_dump_tc = False + enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_rn_stats = False + enableIfVerbose Opt_D_dump_hi_diffs = False + enableIfVerbose Opt_D_verbose_core2core = False + enableIfVerbose Opt_D_verbose_stg2stg = False + enableIfVerbose Opt_D_dump_splices = False + enableIfVerbose Opt_D_th_dec_file = False + enableIfVerbose Opt_D_dump_rule_firings = False + enableIfVerbose Opt_D_dump_rule_rewrites = False + enableIfVerbose Opt_D_dump_simpl_trace = False + enableIfVerbose Opt_D_dump_rtti = False + enableIfVerbose Opt_D_dump_inlinings = False + enableIfVerbose Opt_D_dump_core_stats = False + enableIfVerbose Opt_D_dump_asm_stats = False + enableIfVerbose Opt_D_dump_types = False + enableIfVerbose Opt_D_dump_simpl_iterations = False + enableIfVerbose Opt_D_dump_ticked = False + enableIfVerbose Opt_D_dump_view_pattern_commoning = False + enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose _ = True + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = IntSet.insert (fromEnum f) (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = IntSet.delete (fromEnum f) (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +gopt :: GeneralFlag -> DynFlags -> Bool +gopt f dflags = fromEnum f `IntSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = fromEnum f `IntSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = IntSet.insert (fromEnum f) (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = IntSet.delete (fromEnum f) (warningFlags dfs) } + +-- | Test whether a 'ExtensionFlag' is set +xopt :: ExtensionFlag -> DynFlags -> Bool +xopt f dflags = fromEnum f `IntSet.member` extensionFlags dflags + +-- | Set a 'ExtensionFlag' +xopt_set :: DynFlags -> ExtensionFlag -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'ExtensionFlag' +xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +useUnicodeSyntax :: DynFlags -> Bool +useUnicodeSyntax = xopt Opt_UnicodeSyntax + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == b = return a + | otherwise = addErr errm >> return (panic errm) + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt Opt_GeneralizedNewtypeDeriving, + flip xopt_unset Opt_GeneralizedNewtypeDeriving) + , ("-XTemplateHaskell", thOnLoc, + xopt Opt_TemplateHaskell, + flip xopt_unset Opt_TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags ++ + -- TODO: Can we do better than this for inference? + [ ("-XOverlappingInstances", overlapInstLoc, + xopt Opt_OverlappingInstances, + flip xopt_unset Opt_OverlappingInstances) + , ("-XIncoherentInstances", incoherentOnLoc, + xopt Opt_IncoherentInstances, + flip xopt_unset Opt_IncoherentInstances) + ] + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, addOptl, addOptc, addOptP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d{ objectDir = Just f} +setHiDir f d = d{ hiDir = Just f} +setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d{ dumpDir = Just f} +setOutputDir f = setObjectDir f . setHiDir f . setStubDir f . setDumpDir f +setDylibInstallName f d = d{ dylibInstallName = Just f} + +setObjectSuf f d = d{ objectSuf = f} +setDynObjectSuf f d = d{ dynObjectSuf = f} +setHiSuf f d = d{ hiSuf = f} +setDynHiSuf f d = d{ dynHiSuf = f} +setHcSuf f d = d{ hcSuf = f} + +setOutputFile f d = d{ outputFile = f} +setDynOutputFile f d = d{ dynOutputFile = f} +setOutputHi f d = d{ outputHi = f} + +parseSigOf :: String -> SigOf +parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str) + where parse = parseOne +++ parseMany + parseOne = SigOf `fmap` parseModule + parseMany = SigOfMap . Map.fromList <$> sepBy parseEntry (R.char ',') + parseEntry = do + n <- tok $ parseModuleName + -- ToDo: deprecate this 'is' syntax? + tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ())) + m <- tok $ parseModule + return (mkModuleName n, m) + parseModule = do + pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_") + _ <- R.char ':' + m <- parseModuleName + return (mkModule (stringToPackageKey pk) (mkModuleName m)) + tok m = skipSpaces >> m + +setSigOf :: String -> DynFlags -> DynFlags +setSigOf s d = d { sigOf = parseSigOf s } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d{ dynLibLoader = Deployable } + ("sysdep", "") -> d{ dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) + + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} + +addHaddockOpts f d = d{ haddockOptions = Just f} + +addGhciScript f d = d{ ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d{ interactivePrint = Just f} + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- | When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. The reason for this is that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform. +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + deriving ( Eq ) + +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n dfs + = dfs2{ optLevel = final_n } + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + dfs1 = foldr (flip gopt_unset) dfs remove_gopts + dfs2 = foldr (flip gopt_set) dfs1 extra_gopts + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + +-- ----------------------------------------------------------------------------- +-- StgToDo: abstraction of stg-to-stg passes to run. + +data StgToDo + = StgDoMassageForProfiling -- should be (next to) last + -- There's also setStgVarInfo, but its absolute "lastness" + -- is so critical that it is hardwired in (no flag). + | D_stg_stats + +getStgToDo :: DynFlags -> [StgToDo] +getStgToDo dflags + = todo2 + where + stg_stats = gopt Opt_StgStats dflags + + todo1 = if stg_stats then [D_stg_stats] else [] + + todo2 | WayProf `elem` ways dflags + = StgDoMassageForProfiling : todo1 + | otherwise + = todo1 + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns the +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs activeFlags args) dflags0 + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ liftIO $ throwGhcExceptionIO $ + errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + dflags3 = updateWays dflags2 + theWays = ways dflags3 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + let chooseOutput + | isJust (outputFile dflags3) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags3)) -- but not -dyno + = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) } + | otherwise + = return dflags3 + where + dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension + dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) + + let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 + + dflags6 <- case dllSplitFile dflags5 of + Nothing -> return (dflags5 { dllSplit = Nothing }) + Just f -> + case dllSplit dflags5 of + Just _ -> + -- If dllSplit is out of date then it would have + -- been set to Nothing. As it's a Just, it must be + -- up-to-date. + return dflags5 + Nothing -> + do xs <- liftIO $ readFile f + let ss = map (Set.fromList . words) (lines xs) + return $ dflags5 { dllSplit = Just ss } + + -- Set timer stats & heap size + when (enableTimeStats dflags6) $ liftIO enableTimingStats + case (ghcHeapSize dflags6) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags6 + + return (dflags6, leftover, consistency_warnings ++ sh_warns ++ warns) + +updateWays :: DynFlags -> DynFlags +updateWays dflags + = let theWays = sort $ nub $ ways dflags + f = if WayDyn `elem` theWays then unSetGeneralFlag' + else setGeneralFlag' + in f Opt_Static + $ dflags { + ways = theWays, + buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays), + rtsBuildTag = mkBuildTag theWays + } + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags + + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) + + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] + +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) + + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + -- Have we inferred Unsafe? + -- See Note [HscMain . Safe Haskell Inference] + + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings. These are the user facing strings for +-- enabling and disabling options. +allFlags :: [String] +allFlags = [ '-':flagName flag + | flag <- flagsAll + , ok (flagOptKind flag) ] + where ok (PrefixPred _ _) = False + ok _ = True + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = package_flags ++ dynamic_flags + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = dynamic_flags + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = package_flags + +--------------- The main flags themselves ------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags :: [Flag (CmdLineP DynFlags)] +dynamic_flags = [ + defFlag "n" + (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) + , defFlag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) + , defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , defFlag "#include" + (HasArg (\s -> do + addCmdlineHCInclude s + addWarn ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect"))) + , defFlag "v" (OptIntSuffix setVerbosity) + + , defGhcFlag "j" (OptIntSuffix (\n -> upd (\d -> d {parMakeCount = n}))) + , defFlag "sig-of" (sepArg setSigOf) + + -- RTS options ------------------------------------------------------------- + , defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , defFlag "Rghc-timing" (NoArg (upd (\d -> d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , defGhcFlag "prof" (NoArg (addWay WayProf)) + , defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) + , defGhcFlag "parallel" (NoArg (addWay WayPar)) + , defGhcFlag "gransim" (NoArg (addWay WayGran)) + , defGhcFlag "smp" + (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , defGhcFlag "debug" (NoArg (addWay WayDebug)) + , defGhcFlag "ndp" (NoArg (addWay WayNDP)) + , defGhcFlag "threaded" (NoArg (addWay WayThreaded)) + + , defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , defGhcFlag "static" (NoArg removeWayDyn) + , defGhcFlag "dynamic" (NoArg (addWay WayDyn)) + , defGhcFlag "rdynamic" $ noArg $ +#ifdef linux_HOST_OS + addOptl "-rdynamic" +#elif defined (mingw32_HOST_OS) + addOptl "-export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , defFlag "pgmlo" + (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , defFlag "pgmlc" + (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , defFlag "pgmL" + (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , defFlag "pgmP" + (hasArg setPgmP) + , defFlag "pgmF" + (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , defFlag "pgmc" + (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , defFlag "pgms" + (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , defFlag "pgma" + (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , defFlag "pgml" + (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , defFlag "pgmdll" + (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , defFlag "pgmwindres" + (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , defFlag "pgmlibtool" + (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) + , defFlag "pgmreadelf" + (hasArg (\f -> alterSettings (\s -> s { sPgm_readelf = f}))) + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , defFlag "optlo" + (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , defFlag "optlc" + (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , defFlag "optL" + (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , defFlag "optP" + (hasArg addOptP) + , defFlag "optF" + (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , defFlag "optc" + (hasArg addOptc) + , defFlag "opta" + (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , defFlag "optl" + (hasArg addOptl) + , defFlag "optwindres" + (hasArg (\f -> + alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) + + , defGhcFlag "split-objs" + (NoArg (if can_split + then setGeneralFlag Opt_SplitObjs + else addWarn "ignoring -fsplit-objs")) + + -------- ghc -M ----------------------------------------------------- + , defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , defGhcFlag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) + , defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , defGhcFlag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) + , defGhcFlag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , defGhcFlag "staticlib" (noArg (\d -> d{ ghcLink=LinkStaticLib })) + , defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + -- -dll-split is an internal flag, used only during the GHC build + , defHiddenFlag "dll-split" + (hasArg (\f d -> d{ dllSplitFile = Just f, dllSplit = Nothing })) + + ------- Libraries --------------------------------------------------- + , defFlag "L" (Prefix addLibraryPath) + , defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , defFlag "framework-path" (HasArg addFrameworkPath) + , defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , defGhcFlag "odir" (hasArg setObjectDir) + , defGhcFlag "o" (sepArg (setOutputFile . Just)) + , defGhcFlag "dyno" (sepArg (setDynOutputFile . Just)) + , defGhcFlag "ohi" (hasArg (setOutputHi . Just )) + , defGhcFlag "osuf" (hasArg setObjectSuf) + , defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , defGhcFlag "hcsuf" (hasArg setHcSuf) + , defGhcFlag "hisuf" (hasArg setHiSuf) + , defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , defGhcFlag "hidir" (hasArg setHiDir) + , defGhcFlag "tmpdir" (hasArg setTmpDir) + , defGhcFlag "stubdir" (hasArg setStubDir) + , defGhcFlag "dumpdir" (hasArg setDumpDir) + , defGhcFlag "outputdir" (hasArg setOutputDir) + , defGhcFlag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) + + , defGhcFlag "dynamic-too" (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , defGhcFlag "keep-hc-file" (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , defGhcFlag "keep-hc-files" (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , defGhcFlag "keep-s-file" (NoArg (setGeneralFlag Opt_KeepSFiles)) + , defGhcFlag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) + , defGhcFlag "keep-llvm-file" (NoArg (do setObjTarget HscLlvm + setGeneralFlag Opt_KeepLlvmFiles)) + , defGhcFlag "keep-llvm-files" (NoArg (do setObjTarget HscLlvm + setGeneralFlag Opt_KeepLlvmFiles)) + -- This only makes sense as plural + , defGhcFlag "keep-tmp-files" (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + + ------- Miscellaneous ---------------------------------------------- + , defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , defGhcFlag "no-hs-main" (NoArg (setGeneralFlag Opt_NoHsMain)) + , defGhcFlag "with-rtsopts" (HasArg setRtsOpts) + , defGhcFlag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , defGhcFlag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , defGhcFlag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , defGhcFlag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , defGhcFlag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , defGhcFlag "main-is" (SepArg setMainIs) + , defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , defGhciFlag "ghci-script" (hasArg addGhciScript) + , defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , defGhcFlag "ticky-allocd" (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , defGhcFlag "ticky-LNE" (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , defGhcFlag "ticky-dyn-thunk" (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + ------- recompilation checker -------------------------------------- + , defGhcFlag "recomp" (NoArg (do unSetGeneralFlag Opt_ForceRecomp + deprecate "Use -fno-force-recomp instead")) + , defGhcFlag "no-recomp" (NoArg (do setGeneralFlag Opt_ForceRecomp + deprecate "Use -fforce-recomp instead")) + + ------ HsCpp opts --------------------------------------------------- + , defFlag "D" (AnySuffix (upd . addOptP)) + , defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , defFlag "I" (Prefix addIncludePath) + , defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , defFlag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n })) + , defFlag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n })) + , defGhcFlag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n })) + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new varibles that + -- have otherwise identical names. + , defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTypeSignatures) + + ------ Debugging ---------------------------------------------------- + , defGhcFlag "dstg-stats" (NoArg (setGeneralFlag Opt_StgStats)) + + , defGhcFlag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , defGhcFlag "ddump-cmm-raw" (setDumpFlag Opt_D_dump_cmm_raw) + , defGhcFlag "ddump-cmm-cfg" (setDumpFlag Opt_D_dump_cmm_cfg) + , defGhcFlag "ddump-cmm-cbe" (setDumpFlag Opt_D_dump_cmm_cbe) + , defGhcFlag "ddump-cmm-proc" (setDumpFlag Opt_D_dump_cmm_proc) + , defGhcFlag "ddump-cmm-sink" (setDumpFlag Opt_D_dump_cmm_sink) + , defGhcFlag "ddump-cmm-sp" (setDumpFlag Opt_D_dump_cmm_sp) + , defGhcFlag "ddump-cmm-procmap" (setDumpFlag Opt_D_dump_cmm_procmap) + , defGhcFlag "ddump-cmm-split" (setDumpFlag Opt_D_dump_cmm_split) + , defGhcFlag "ddump-cmm-info" (setDumpFlag Opt_D_dump_cmm_info) + , defGhcFlag "ddump-cmm-cps" (setDumpFlag Opt_D_dump_cmm_cps) + , defGhcFlag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) + , defGhcFlag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , defGhcFlag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , defGhcFlag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , defGhcFlag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , defGhcFlag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , defGhcFlag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , defGhcFlag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + , defGhcFlag "ddump-llvm" (NoArg (do setObjTarget HscLlvm + setDumpFlag' Opt_D_dump_llvm)) + , defGhcFlag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , defGhcFlag "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , defGhcFlag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + , defGhcFlag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + , defGhcFlag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , defGhcFlag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) + , defGhcFlag "ddump-simpl-trace" (setDumpFlag Opt_D_dump_simpl_trace) + , defGhcFlag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , defGhcFlag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , defGhcFlag "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , defGhcFlag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , defGhcFlag "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , defGhcFlag "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , defGhcFlag "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , defGhcFlag "ddump-call-arity" (setDumpFlag Opt_D_dump_call_arity) + , defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , defGhcFlag "ddump-strsigs" (setDumpFlag Opt_D_dump_strsigs) + , defGhcFlag "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , defGhcFlag "ddump-types" (setDumpFlag Opt_D_dump_types) + , defGhcFlag "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , defGhcFlag "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , defGhcFlag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , defGhcFlag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , defGhcFlag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , defGhcFlag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) + , defGhcFlag "ddump-tc-trace" (NoArg (do + setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , defGhcFlag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) + , defGhcFlag "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , defGhcFlag "dth-dec-file" (setDumpFlag Opt_D_th_dec_file) + + , defGhcFlag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , defGhcFlag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , defGhcFlag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , defGhcFlag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , defGhcFlag "dsource-stats" (setDumpFlag Opt_D_source_stats) + , defGhcFlag "dverbose-core2core" (NoArg (do setVerbosity (Just 2) + setVerboseCore2Core)) + , defGhcFlag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , defGhcFlag "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , defGhcFlag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , defGhcFlag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) + , defGhcFlag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , defGhcFlag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) + , defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , defGhcFlag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) + , defGhcFlag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + , defGhcFlag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) + , defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , defGhcFlag "dshow-passes" (NoArg (do forceRecompile + setVerbosity $ Just 2)) + , defGhcFlag "dfaststring-stats" + (NoArg (setGeneralFlag Opt_D_faststring_stats)) + , defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) + + ------ Machine dependant (-m) stuff --------------------------- + + , defGhcFlag "msse" (noArg (\d -> d{ sseVersion = Just SSE1 })) + , defGhcFlag "msse2" (noArg (\d -> d{ sseVersion = Just SSE2 })) + , defGhcFlag "msse3" (noArg (\d -> d{ sseVersion = Just SSE3 })) + , defGhcFlag "msse4" (noArg (\d -> d{ sseVersion = Just SSE4 })) + , defGhcFlag "msse4.2" (noArg (\d -> d{ sseVersion = Just SSE42 })) + , defGhcFlag "mavx" (noArg (\d -> d{ avx = True })) + , defGhcFlag "mavx2" (noArg (\d -> d{ avx2 = True })) + , defGhcFlag "mavx512cd" (noArg (\d -> d{ avx512cd = True })) + , defGhcFlag "mavx512er" (noArg (\d -> d{ avx512er = True })) + , defGhcFlag "mavx512f" (noArg (\d -> d{ avx512f = True })) + , defGhcFlag "mavx512pf" (noArg (\d -> d{ avx512pf = True })) + + ------ Warning opts ------------------------------------------------- + , defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , defFlag "Werror" (NoArg (setGeneralFlag Opt_WarnIsError)) + , defFlag "Wwarn" (NoArg (unSetGeneralFlag Opt_WarnIsError)) + , defFlag "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , defFlag "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = IntSet.empty}) + deprecate "Use -w instead")) + , defFlag "w" (NoArg (upd (\dfs -> dfs {warningFlags = IntSet.empty}))) + + ------ Plugin flags ------------------------------------------------ + , defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , defGhcFlag "fplugin" (hasArg addPluginModuleName) + + ------ Optimisation flags ------------------------------------------ + , defGhcFlag "O" (noArgM (setOptLevel 1)) + , defGhcFlag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , defGhcFlag "Odph" (noArgM setDPHOpt) + , defGhcFlag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + + , defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d{ maxRelevantBinds = Just n })) + , defFlag "fno-max-relevant-binds" + (noArg (\d -> d{ maxRelevantBinds = Nothing })) + , defFlag "fsimplifier-phases" + (intSuffix (\n d -> d{ simplPhases = n })) + , defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d{ maxSimplIterations = n })) + , defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d{ simplTickFactor = n })) + , defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d{ specConstrThreshold = Just n })) + , defFlag "fno-spec-constr-threshold" + (noArg (\d -> d{ specConstrThreshold = Nothing })) + , defFlag "fspec-constr-count" + (intSuffix (\n d -> d{ specConstrCount = Just n })) + , defFlag "fno-spec-constr-count" + (noArg (\d -> d{ specConstrCount = Nothing })) + , defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d{ specConstrRecursive = n })) + , defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) + , defFlag "fno-liberate-case-threshold" + (noArg (\d -> d{ liberateCaseThreshold = Nothing })) + , defFlag "frule-check" + (sepArg (\s d -> d{ ruleCheck = Just s })) + , defFlag "fcontext-stack" + (intSuffix (\n d -> d{ ctxtStkDepth = n })) + , defFlag "ftype-function-depth" + (intSuffix (\n d -> d{ tyFunStkDepth = n })) + , defFlag "fstrictness-before" + (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , defFlag "ffloat-lam-args" + (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , defFlag "ffloat-all-lams" + (noArg (\d -> d{ floatLamArgs = Nothing })) + + , defFlag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) + + , defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d {ufCreationThreshold = n})) + , defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d {ufUseThreshold = n})) + , defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d {ufDictDiscount = n})) + , defFlag "funfolding-keeness-factor" + (floatSuffix (\n d -> d {ufKeenessFactor = n})) + + , defFlag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n})) + + , defGhciFlag "fghci-hist-size" (intSuffix (\n d -> d {ghciHistSize = n})) + , defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d{ maxInlineAllocSize = n })) + , defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d{ maxInlineMemcpyInsns = n })) + , defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d{ maxInlineMemsetInsns = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , defGhcFlag "auto-all" (noArg (\d -> d { profAuto = ProfAutoAll } )) + , defGhcFlag "no-auto-all" (noArg (\d -> d { profAuto = NoProfAuto } )) + , defGhcFlag "auto" (noArg (\d -> d { profAuto = ProfAutoExports } )) + , defGhcFlag "no-auto" (noArg (\d -> d { profAuto = NoProfAuto } )) + , defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + , defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + + -- NEW profiling flags + , defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + ------ Compiler flags ----------------------------------------------- + + , defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) + , defGhcFlag "fvia-c" (NoArg + (addWarn $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , defGhcFlag "fvia-C" (NoArg + (addWarn $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , defFlag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } + setTarget HscNothing)) + , defFlag "fbyte-code" (NoArg (setTarget HscInterpreted)) + , defFlag "fobject-code" (NoArg (setTargetWithPlatform defaultHscTarget)) + , defFlag "fglasgow-exts" + (NoArg (do enableGlasgowExts + deprecate "Use individual extensions instead")) + , defFlag "fno-glasgow-exts" + (NoArg (do disableGlasgowExts + deprecate "Use individual extensions instead")) + + ------ Safe Haskell flags ------------------------------------------- + , defFlag "fpackage-trust" (NoArg setPackageTrust) + , defFlag "fno-safe-infer" (noArg (\d -> d { safeInfer = False } )) + , defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + + ------ Debugging flags ---------------------------------------------- + , defGhcFlag "g" (NoArg (setGeneralFlag Opt_Debug)) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlags + ++ map (mkFlag turnOff "no-" unSetGeneralFlag) negatableFlags + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlags + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag) dFlags + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlags + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag) fFlags + ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags + ++ map (mkFlag turnOff "fno-" unSetWarningFlag) fWarningFlags + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags + ++ map (mkFlag turnOn "X" setLanguage) languageFlags + ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags + ++ [ defFlag "XGenerics" + (NoArg (deprecate $ + "it does nothing; look into -XDefaultSignatures " ++ + "and -XDeriveGeneric for generic programming support.")) + , defFlag "XNoGenerics" + (NoArg (deprecate $ + "it does nothing; look into -XDefaultSignatures and " ++ + "-XDeriveGeneric for generic programming support.")) ] + +-- See Note [Supporting CLI completion] +package_flags :: [Flag (CmdLineP DynFlags)] +package_flags = [ + ------- Packages ---------------------------------------------------- + defFlag "package-db" (HasArg (addPkgConfRef . PkgConfFile)) + , defFlag "clear-package-db" (NoArg clearPkgConf) + , defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) + , defFlag "no-user-package-db" (NoArg removeUserPkgConf) + , defFlag "global-package-db" (NoArg (addPkgConfRef GlobalPkgConf)) + , defFlag "user-package-db" (NoArg (addPkgConfRef UserPkgConf)) + + -- backwards compat with GHC<=7.4 : + , defFlag "package-conf" (HasArg $ \path -> do + addPkgConfRef (PkgConfFile path) + deprecate "Use -package-db instead") + , defFlag "no-user-package-conf" + (NoArg $ do removeUserPkgConf + deprecate "Use -no-user-package-db instead") + + , defGhcFlag "package-name" (hasArg setPackageKey) + , defGhcFlag "this-package-key" (hasArg setPackageKey) + , defFlag "package-id" (HasArg exposePackageId) + , defFlag "package" (HasArg exposePackage) + , defFlag "package-key" (HasArg exposePackageKey) + , defFlag "hide-package" (HasArg hidePackage) + , defFlag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) + , defFlag "package-env" (HasArg setPackageEnv) + , defFlag "ignore-package" (HasArg ignorePackage) + , defFlag "syslib" + (HasArg (\s -> do exposePackage s + deprecate "Use -package instead")) + , defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , defFlag "trust" (HasArg trustPackage) + , defFlag "distrust" (HasArg distrustPackage) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> FlagSpec flag +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> FlagSpec flag +flagSpec' name flag act = FlagSpec name flag act AllModes + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> FlagSpec flag +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> FlagSpec flag +flagGhciSpec' name flag act = FlagSpec name flag act OnlyGhci + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> FlagSpec flag +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> FlagSpec flag +flagHiddenSpec' name flag act = FlagSpec name flag act HiddenFlag + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> FlagSpec flag -- ^ Specification of this particular flag + -> Flag (CmdLineP DynFlags) +mkFlag turn_on flagPrefix f (FlagSpec name flag extra_action mode) + = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode + +deprecatedForExtension :: String -> TurnOnFlag -> DynP () +deprecatedForExtension lang turn_on + = deprecate ("use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead") + where + flag | turn_on = lang + | otherwise = "No"++lang + +useInstead :: String -> TurnOnFlag -> DynP () +useInstead flag turn_on + = deprecate ("Use -f" ++ no ++ flag ++ " instead") + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fWarningFlags :: [FlagSpec WarningFlag] +fWarningFlags = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "warn-alternative-layout-rule-transitional" + Opt_WarnAlternativeLayoutRuleTransitional, + flagSpec' "warn-amp" Opt_WarnAMP + (\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"), + flagSpec "warn-auto-orphans" Opt_WarnAutoOrphans, + flagSpec "warn-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "warn-deprecated-flags" Opt_WarnDeprecatedFlags, + flagSpec "warn-deriving-typeable" Opt_WarnDerivingTypeable, + flagSpec "warn-dodgy-exports" Opt_WarnDodgyExports, + flagSpec "warn-dodgy-foreign-imports" Opt_WarnDodgyForeignImports, + flagSpec "warn-dodgy-imports" Opt_WarnDodgyImports, + flagSpec "warn-empty-enumerations" Opt_WarnEmptyEnumerations, + flagSpec "warn-context-quantification" Opt_WarnContextQuantification, + flagSpec "warn-duplicate-constraints" Opt_WarnDuplicateConstraints, + flagSpec "warn-duplicate-exports" Opt_WarnDuplicateExports, + flagSpec "warn-hi-shadowing" Opt_WarnHiShadows, + flagSpec "warn-implicit-prelude" Opt_WarnImplicitPrelude, + flagSpec "warn-incomplete-patterns" Opt_WarnIncompletePatterns, + flagSpec "warn-incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, + flagSpec "warn-incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, + flagSpec "warn-inline-rule-shadowing" Opt_WarnInlineRuleShadowing, + flagSpec "warn-identities" Opt_WarnIdentities, + flagSpec "warn-missing-fields" Opt_WarnMissingFields, + flagSpec "warn-missing-import-lists" Opt_WarnMissingImportList, + flagSpec "warn-missing-local-sigs" Opt_WarnMissingLocalSigs, + flagSpec "warn-missing-methods" Opt_WarnMissingMethods, + flagSpec "warn-missing-signatures" Opt_WarnMissingSigs, + flagSpec "warn-missing-exported-sigs" Opt_WarnMissingExportedSigs, + flagSpec "warn-monomorphism-restriction" Opt_WarnMonomorphism, + flagSpec "warn-name-shadowing" Opt_WarnNameShadowing, + flagSpec "warn-orphans" Opt_WarnOrphans, + flagSpec "warn-overflowed-literals" Opt_WarnOverflowedLiterals, + flagSpec "warn-overlapping-patterns" Opt_WarnOverlappingPatterns, + flagSpec "warn-pointless-pragmas" Opt_WarnPointlessPragmas, + flagSpec' "warn-safe" Opt_WarnSafe setWarnSafe, + flagSpec "warn-trustworthy-safe" Opt_WarnTrustworthySafe, + flagSpec "warn-tabs" Opt_WarnTabs, + flagSpec "warn-type-defaults" Opt_WarnTypeDefaults, + flagSpec "warn-typed-holes" Opt_WarnTypedHoles, + flagSpec "warn-partial-type-signatures" Opt_WarnPartialTypeSignatures, + flagSpec "warn-unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, + flagSpec' "warn-unsafe" Opt_WarnUnsafe setWarnUnsafe, + flagSpec "warn-unsupported-calling-conventions" + Opt_WarnUnsupportedCallingConventions, + flagSpec "warn-unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, + flagSpec "warn-unticked-promoted-constructors" + Opt_WarnUntickedPromotedConstructors, + flagSpec "warn-unused-binds" Opt_WarnUnusedBinds, + flagSpec "warn-unused-do-bind" Opt_WarnUnusedDoBind, + flagSpec "warn-unused-imports" Opt_WarnUnusedImports, + flagSpec "warn-unused-matches" Opt_WarnUnusedMatches, + flagSpec "warn-warnings-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "warn-wrong-do-bind" Opt_WarnWrongDoBind] + +-- | These @-\@ flags can all be reversed with @-no-\@ +negatableFlags :: [FlagSpec GeneralFlag] +negatableFlags = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\@ flags can all be reversed with @-dno-\@ +dFlags :: [FlagSpec GeneralFlag] +dFlags = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + flagSpec "ppr-ticks" Opt_PprShowTicks, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cse" Opt_CSE, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "error-spans" Opt_ErrorSpans, + flagSpec "excess-precision" Opt_ExcessPrecision, + flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec' "ext-core" Opt_EmitExternalCore + (\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"), + flagSpec "flat-cache" Opt_FlatCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "full-laziness" Opt_FullLaziness, + flagSpec "fun-to-thunk" Opt_FunToThunk, + flagSpec "gen-manifest" Opt_GenManifest, + flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-sandbox" Opt_GhciSandbox, + flagSpec "helpful-errors" Opt_HelpfulErrors, + flagSpec "hpc" Opt_Hpc, + flagSpec "hpc-no-auto" Opt_Hpc_No_Auto, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "kill-absence" Opt_KillAbsence, + flagSpec "kill-one-shot" Opt_KillOneShot, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-pass-vectors-in-regs" Opt_LlvmPassVectorsInRegisters, + flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, + flagSpec "loopification" Opt_Loopification, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + flagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "simple-list-literals" Opt_SimpleListLiterals, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance, + flagSpec "vectorise" Opt_Vectorise + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [FlagSpec ExtensionFlag] +fLangFlags = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + flagSpec' "th" Opt_TemplateHaskell + (\on -> deprecatedForExtension "TemplateHaskell" on + >> checkTemplateHaskellOk on), + flagSpec' "fi" Opt_ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + flagSpec' "ffi" Opt_ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + flagSpec' "arrows" Opt_Arrows + (deprecatedForExtension "Arrows"), + flagSpec' "implicit-prelude" Opt_ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + flagSpec' "bang-patterns" Opt_BangPatterns + (deprecatedForExtension "BangPatterns"), + flagSpec' "monomorphism-restriction" Opt_MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + flagSpec' "mono-pat-binds" Opt_MonoPatBinds + (deprecatedForExtension "MonoPatBinds"), + flagSpec' "extended-default-rules" Opt_ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + flagSpec' "implicit-params" Opt_ImplicitParams + (deprecatedForExtension "ImplicitParams"), + flagSpec' "scoped-type-variables" Opt_ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + flagSpec' "parr" Opt_ParallelArrays + (deprecatedForExtension "ParallelArrays"), + flagSpec' "PArr" Opt_ParallelArrays + (deprecatedForExtension "ParallelArrays"), + flagSpec' "allow-overlapping-instances" Opt_OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + flagSpec' "allow-undecidable-instances" Opt_UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + flagSpec' "allow-incoherent-instances" Opt_IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map flagSpecName languageFlags + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map flagSpecName safeHaskellFlags + +supportedExtensions :: [String] +supportedExtensions + = concatMap (\name -> [name, "No" ++ name]) (map flagSpecName xFlags) + +supportedLanguagesAndExtensions :: [String] +supportedLanguagesAndExtensions = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions + +-- | These -X flags cannot be reversed with -XNo +languageFlags :: [FlagSpec Language] +languageFlags = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010 + ] + +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlags :: [FlagSpec SafeHaskellMode] +safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X flags can all be reversed with -XNo +xFlags :: [FlagSpec ExtensionFlag] +xFlags = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "AllowAmbiguousTypes" Opt_AllowAmbiguousTypes, + flagSpec "AlternativeLayoutRule" Opt_AlternativeLayoutRule, + flagSpec "AlternativeLayoutRuleTransitional" + Opt_AlternativeLayoutRuleTransitional, + flagSpec "Arrows" Opt_Arrows, + flagSpec "AutoDeriveTypeable" Opt_AutoDeriveTypeable, + flagSpec "BangPatterns" Opt_BangPatterns, + flagSpec "BinaryLiterals" Opt_BinaryLiterals, + flagSpec "CApiFFI" Opt_CApiFFI, + flagSpec "CPP" Opt_Cpp, + flagSpec "ConstrainedClassMethods" Opt_ConstrainedClassMethods, + flagSpec "ConstraintKinds" Opt_ConstraintKinds, + flagSpec "DataKinds" Opt_DataKinds, + flagSpec' "DatatypeContexts" Opt_DatatypeContexts + (\ turn_on -> when turn_on $ + deprecate $ "It was widely considered a misfeature, " ++ + "and has been removed from the Haskell language."), + flagSpec "DefaultSignatures" Opt_DefaultSignatures, + flagSpec "DeriveAnyClass" Opt_DeriveAnyClass, + flagSpec "DeriveDataTypeable" Opt_DeriveDataTypeable, + flagSpec "DeriveFoldable" Opt_DeriveFoldable, + flagSpec "DeriveFunctor" Opt_DeriveFunctor, + flagSpec "DeriveGeneric" Opt_DeriveGeneric, + flagSpec "DeriveTraversable" Opt_DeriveTraversable, + flagSpec "DisambiguateRecordFields" Opt_DisambiguateRecordFields, + flagSpec "DoAndIfThenElse" Opt_DoAndIfThenElse, + flagSpec' "DoRec" Opt_RecursiveDo + (deprecatedForExtension "RecursiveDo"), + flagSpec "EmptyCase" Opt_EmptyCase, + flagSpec "EmptyDataDecls" Opt_EmptyDataDecls, + flagSpec "ExistentialQuantification" Opt_ExistentialQuantification, + flagSpec "ExplicitForAll" Opt_ExplicitForAll, + flagSpec "ExplicitNamespaces" Opt_ExplicitNamespaces, + flagSpec "ExtendedDefaultRules" Opt_ExtendedDefaultRules, + flagSpec "FlexibleContexts" Opt_FlexibleContexts, + flagSpec "FlexibleInstances" Opt_FlexibleInstances, + flagSpec "ForeignFunctionInterface" Opt_ForeignFunctionInterface, + flagSpec "FunctionalDependencies" Opt_FunctionalDependencies, + flagSpec "GADTSyntax" Opt_GADTSyntax, + flagSpec "GADTs" Opt_GADTs, + flagSpec "GHCForeignImportPrim" Opt_GHCForeignImportPrim, + flagSpec' "GeneralizedNewtypeDeriving" Opt_GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec "ImplicitParams" Opt_ImplicitParams, + flagSpec "ImplicitPrelude" Opt_ImplicitPrelude, + flagSpec "ImpredicativeTypes" Opt_ImpredicativeTypes, + flagSpec' "IncoherentInstances" Opt_IncoherentInstances + setIncoherentInsts, + flagSpec "InstanceSigs" Opt_InstanceSigs, + flagSpec "InterruptibleFFI" Opt_InterruptibleFFI, + flagSpec "JavaScriptFFI" Opt_JavaScriptFFI, + flagSpec "KindSignatures" Opt_KindSignatures, + flagSpec "LambdaCase" Opt_LambdaCase, + flagSpec "LiberalTypeSynonyms" Opt_LiberalTypeSynonyms, + flagSpec "MagicHash" Opt_MagicHash, + flagSpec "MonadComprehensions" Opt_MonadComprehensions, + flagSpec "MonoLocalBinds" Opt_MonoLocalBinds, + flagSpec' "MonoPatBinds" Opt_MonoPatBinds + (\ turn_on -> when turn_on $ + deprecate "Experimental feature now removed; has no effect"), + flagSpec "MonomorphismRestriction" Opt_MonomorphismRestriction, + flagSpec "MultiParamTypeClasses" Opt_MultiParamTypeClasses, + flagSpec "MultiWayIf" Opt_MultiWayIf, + flagSpec "NPlusKPatterns" Opt_NPlusKPatterns, + flagSpec "NamedFieldPuns" Opt_RecordPuns, + flagSpec "NamedWildCards" Opt_NamedWildCards, + flagSpec "NegativeLiterals" Opt_NegativeLiterals, + flagSpec "NondecreasingIndentation" Opt_NondecreasingIndentation, + flagSpec' "NullaryTypeClasses" Opt_NullaryTypeClasses + (deprecatedForExtension "MultiParamTypeClasses"), + flagSpec "NumDecimals" Opt_NumDecimals, + flagSpec' "OverlappingInstances" Opt_OverlappingInstances + setOverlappingInsts, + flagSpec "OverloadedLists" Opt_OverloadedLists, + flagSpec "OverloadedStrings" Opt_OverloadedStrings, + flagSpec "PackageImports" Opt_PackageImports, + flagSpec "ParallelArrays" Opt_ParallelArrays, + flagSpec "ParallelListComp" Opt_ParallelListComp, + flagSpec "PartialTypeSignatures" Opt_PartialTypeSignatures, + flagSpec "PatternGuards" Opt_PatternGuards, + flagSpec' "PatternSignatures" Opt_ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + flagSpec "PatternSynonyms" Opt_PatternSynonyms, + flagSpec "PolyKinds" Opt_PolyKinds, + flagSpec "PolymorphicComponents" Opt_RankNTypes, + flagSpec "PostfixOperators" Opt_PostfixOperators, + flagSpec "QuasiQuotes" Opt_QuasiQuotes, + flagSpec "Rank2Types" Opt_RankNTypes, + flagSpec "RankNTypes" Opt_RankNTypes, + flagSpec "RebindableSyntax" Opt_RebindableSyntax, + flagSpec' "RecordPuns" Opt_RecordPuns + (deprecatedForExtension "NamedFieldPuns"), + flagSpec "RecordWildCards" Opt_RecordWildCards, + flagSpec "RecursiveDo" Opt_RecursiveDo, + flagSpec "RelaxedLayout" Opt_RelaxedLayout, + flagSpec' "RelaxedPolyRec" Opt_RelaxedPolyRec + (\ turn_on -> unless turn_on $ + deprecate "You can't turn off RelaxedPolyRec any more"), + flagSpec "RoleAnnotations" Opt_RoleAnnotations, + flagSpec "ScopedTypeVariables" Opt_ScopedTypeVariables, + flagSpec "StandaloneDeriving" Opt_StandaloneDeriving, + flagSpec "StaticPointers" Opt_StaticPointers, + flagSpec' "TemplateHaskell" Opt_TemplateHaskell + checkTemplateHaskellOk, + flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, + flagSpec "TransformListComp" Opt_TransformListComp, + flagSpec "TupleSections" Opt_TupleSections, + flagSpec "TypeFamilies" Opt_TypeFamilies, + flagSpec "TypeOperators" Opt_TypeOperators, + flagSpec "TypeSynonymInstances" Opt_TypeSynonymInstances, + flagSpec "UnboxedTuples" Opt_UnboxedTuples, + flagSpec "UndecidableInstances" Opt_UndecidableInstances, + flagSpec "UnicodeSyntax" Opt_UnicodeSyntax, + flagSpec "UnliftedFFITypes" Opt_UnliftedFFITypes, + flagSpec "ViewPatterns" Opt_ViewPatterns + ] + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_EmbedManifest, + Opt_FlatCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_HelpfulErrors, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_RPath, + Opt_SharedImplib, + Opt_SimplPreInlining + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + ++ default_PIC platform + + ++ (if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then wayGeneralFlags platform WayDyn + else []) + + where platform = sTargetPlatform settings + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + (OSDarwin, ArchX86_64) -> [Opt_PIC] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + _ -> [] + +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)] + +impliedXFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) + , (Opt_ScopedTypeVariables, turnOn, Opt_ExplicitForAll) + , (Opt_LiberalTypeSynonyms, turnOn, Opt_ExplicitForAll) + , (Opt_ExistentialQuantification, turnOn, Opt_ExplicitForAll) + , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) + , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) + + , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! + + , (Opt_GADTs, turnOn, Opt_GADTSyntax) + , (Opt_GADTs, turnOn, Opt_MonoLocalBinds) + , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) + + , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures + , (Opt_PolyKinds, turnOn, Opt_KindSignatures) -- Ditto polymorphic kinds + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (Opt_AutoDeriveTypeable, turnOn, Opt_DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (Opt_TypeFamilies, turnOn, Opt_ExplicitNamespaces) + , (Opt_TypeOperators, turnOn, Opt_ExplicitNamespaces) + + , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) + + , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) + + -- An implicit parameter constraint, `?x::Int`, is desugared into + -- `IP "x" Int`, which requires a flexible context/instance. + , (Opt_ImplicitParams, turnOn, Opt_FlexibleContexts) + , (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances) + + , (Opt_JavaScriptFFI, turnOn, Opt_InterruptibleFFI) + + , (Opt_DeriveTraversable, turnOn, Opt_DeriveFunctor) + , (Opt_DeriveTraversable, turnOn, Opt_DeriveFoldable) + ] + +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant files are: +-- +-- * docs/users_guide/flags.xml +-- * docs/users_guide/using.xml +-- +-- The first contains the Flag Refrence section, which breifly lists all +-- available flags. The second contains a detailed description of the +-- flags. Both places should contain information whether a flag is implied by +-- -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([0,1,2], Opt_DmdTxDictSel) + , ([0,1,2], Opt_LlvmTBAA) + , ([0,1,2], Opt_VectorisationAvoidance) + -- This one is important for a tiresome reason: + -- we want to make sure that the bindings for data + -- constructors are eta-expanded. This is probably + -- a good thing anyway, but it seems fragile. + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CSE) + , ([1,2], Opt_DoEtaReduction) + , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] + -- in PrelRules + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_Specialise) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + ] + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warning enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- * docs/users_guide/using.xml + +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, + Opt_WarnDeprecatedFlags, + Opt_WarnTypedHoles, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnPointlessPragmas, + Opt_WarnDuplicateConstraints, + Opt_WarnDuplicateExports, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnContextQuantification, + Opt_WarnTabs + ] + +minusWOpts :: [WarningFlag] +-- Things you get with -W +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports + ] + +minusWallOpts :: [WarningFlag] +-- Things you get with -Wall +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSigs, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnUntickedPromotedConstructors + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + +glasgowExtsFlags :: [ExtensionFlag] +glasgowExtsFlags = [ + Opt_ConstrainedClassMethods + , Opt_DeriveDataTypeable + , Opt_DeriveFoldable + , Opt_DeriveFunctor + , Opt_DeriveGeneric + , Opt_DeriveTraversable + , Opt_EmptyDataDecls + , Opt_ExistentialQuantification + , Opt_ExplicitNamespaces + , Opt_FlexibleContexts + , Opt_FlexibleInstances + , Opt_ForeignFunctionInterface + , Opt_FunctionalDependencies + , Opt_GeneralizedNewtypeDeriving + , Opt_ImplicitParams + , Opt_KindSignatures + , Opt_LiberalTypeSynonyms + , Opt_MagicHash + , Opt_MultiParamTypeClasses + , Opt_ParallelListComp + , Opt_PatternGuards + , Opt_PostfixOperators + , Opt_RankNTypes + , Opt_RecursiveDo + , Opt_ScopedTypeVariables + , Opt_StandaloneDeriving + , Opt_TypeOperators + , Opt_TypeSynonymInstances + , Opt_UnboxedTuples + , Opt_UnicodeSyntax + , Opt_UnliftedFFITypes ] + +#ifdef GHCI +-- Consult the RTS to find whether GHC itself has been built profiled +-- If so, you can't use Template Haskell +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt + +rtsIsProfiled :: Bool +rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 +#endif + +#ifdef GHCI +-- Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt + +dynamicGhc :: Bool +dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 +#else +dynamicGhc :: Bool +dynamicGhc = False +#endif + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +#ifdef GHCI +checkTemplateHaskellOk turn_on + | turn_on && rtsIsProfiled + = addErr "You can't use Template Haskell with a profiled compiler" + | otherwise + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) +#else +-- In stage 1, Template Haskell is simply illegal, except with -M +-- We don't bleat with -M because there's no problem with TH there, +-- and in fact GHC's build system does ghc -M of the DPH libraries +-- with a stage1 compiler +checkTemplateHaskellOk turn_on + | turn_on = do dfs <- liftEwM getCmdLineState + case ghcMode dfs of + MkDepend -> return () + _ -> addErr msg + | otherwise = return () + where + msg = "Template Haskell requires GHC with interpreter support\n " ++ + "Perhaps you are using a stage-1 compiler?" +#endif + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWay :: Way -> DynP () +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = w : ways dflags0 } + dflags2 = wayExtras platform w dflags1 + dflags3 = foldr setGeneralFlag' dflags2 + (wayGeneralFlags platform w) + dflags4 = foldr unSetGeneralFlag' dflags3 + (wayUnsetGeneralFlags platform w) + in dflags4 + +removeWayDyn :: DynP () +removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = gopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + +-------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: ExtensionFlag -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs] + +forceRecompile :: DynP () +-- Whenver we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +addCmdlineHCInclude :: String -> DynP () +addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) + +data PkgConfRef + = GlobalPkgConf + | UserPkgConf + | PkgConfFile FilePath + +addPkgConfRef :: PkgConfRef -> DynP () +addPkgConfRef p = upd $ \s -> s { extraPkgConfs = (p:) . extraPkgConfs s } + +removeUserPkgConf :: DynP () +removeUserPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotUser . extraPkgConfs s } + where + isNotUser UserPkgConf = False + isNotUser _ = True + +removeGlobalPkgConf :: DynP () +removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extraPkgConfs s } + where + isNotGlobal GlobalPkgConf = False + isNotGlobal _ = True + +clearPkgConf :: DynP () +clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } + +parseModuleName :: ReadP String +parseModuleName = munch1 (\c -> isAlphaNum c || c `elem` ".") + +parsePackageFlag :: (String -> PackageArg) -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where parse = do + pkg <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.") + ( do _ <- tok $ string "with" + fmap (ExposePackage (constr pkg) . ModRenaming True) parseRns + <++ fmap (ExposePackage (constr pkg) . ModRenaming False) parseRns + <++ return (ExposePackage (constr pkg) (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag PackageIdArg p : packageFlags s }) +exposePackageKey p = + upd (\s -> s{ packageFlags = + parsePackageFlag PackageKeyArg p : packageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag PackageArg p : packageFlags dflags } + +setPackageKey :: String -> DynFlags -> DynFlags +setPackageKey p s = s{ thisPackage = stringToPackageKey p } + +-- ----------------------------------------------------------------------------- +-- | Find the package environment (if one exists) +-- +-- We interpret the package environment as a set of package flags; to be +-- specific, if we find a package environment +-- +-- > id1 +-- > id2 +-- > .. +-- > idn +-- +-- we interpret this as +-- +-- > [ -hide-all-packages +-- > , -package-id id1 +-- > , -package-id id2 +-- > , .. +-- > , -package-id idn +-- > ] +interpretPackageEnv :: DynFlags -> IO DynFlags +interpretPackageEnv dflags = do + mPkgEnv <- runMaybeT $ msum $ [ + getCmdLineArg >>= \env -> msum [ + loadEnvFile env + , loadEnvName env + , cmdLineError env + ] + , getEnvVar >>= \env -> msum [ + loadEnvFile env + , loadEnvName env + , envError env + ] + , loadEnvFile localEnvFile + , loadEnvName defaultEnvName + ] + case mPkgEnv of + Nothing -> + -- No environment found. Leave DynFlags unchanged. + return dflags + Just ids -> do + let setFlags :: DynP () + setFlags = do + setGeneralFlag Opt_HideAllPackages + mapM_ exposePackageId (lines ids) + + (_, dflags') = runCmdLine (runEwM setFlags) dflags + + return dflags' + where + -- Loading environments (by name or by location) + + namedEnvPath :: String -> MaybeT IO FilePath + namedEnvPath name = do + appdir <- liftMaybeT $ versionedAppDir dflags + return $ appdir "environments" name + + loadEnvName :: String -> MaybeT IO String + loadEnvName name = loadEnvFile =<< namedEnvPath name + + loadEnvFile :: String -> MaybeT IO String + loadEnvFile path = do + guard =<< liftMaybeT (doesFileExist path) + liftMaybeT $ readFile path + + -- Various ways to define which environment to use + + getCmdLineArg :: MaybeT IO String + getCmdLineArg = MaybeT $ return $ packageEnv dflags + + getEnvVar :: MaybeT IO String + getEnvVar = do + mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" + case mvar of + Right var -> return var + Left err -> if isDoesNotExistError err then mzero + else liftMaybeT $ throwIO err + + defaultEnvName :: String + defaultEnvName = "default" + + localEnvFile :: FilePath + localEnvFile = "./.ghc.environment" + + -- Error reporting + + cmdLineError :: String -> MaybeT IO a + cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " ++ show env ++ " not found" + + envError :: String -> MaybeT IO a + envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " + ++ show env + ++ " (specified in GHC_ENVIRIONMENT) not found" + + +-- If we're linking a binary, then only targets that produce object +-- code are allowed (requests for other target types are ignored). +setTarget :: HscTarget -> DynP () +setTarget l = setTargetWithPlatform (const l) + +setTargetWithPlatform :: (Platform -> HscTarget) -> DynP () +setTargetWithPlatform f = upd set + where + set dfs = let l = f (targetPlatform dfs) + in if ghcLink dfs /= LinkBinary || isObjectTarget l + then dfs{ hscTarget = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjTarget :: HscTarget -> DynP () +setObjTarget l = updM set + where + set dflags + | isObjectTarget (hscTarget dflags) + = return $ dflags { hscTarget = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +checkOptLevel :: Int -> DynFlags -> Either String DynFlags +checkOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = Left "-O conflicts with --interactive; -O ignored." + | otherwise + = Right dflags + +-- -Odph is equivalent to +-- +-- -O2 optimise as much as possible +-- -fmax-simplifier-iterations20 this is necessary sometimes +-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion +-- +setDPHOpt :: DynFlags -> DynP DynFlags +setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 + , simplPhases = 3 + }) + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = upd $ \d -> d{ mainFunIs = Just main_fn, + mainModIs = mkModule mainPackageKey (mkModuleName main_mod) } + + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d{ mainFunIs = Just arg } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = includePaths s ++ splitPathList p}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#ifndef mingw32_TARGET_OS +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#ifndef mingw32_TARGET_OS + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags + = case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode + | gopt Opt_PIC dflags || not (gopt Opt_Static dflags) -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] + | otherwise -> [] + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Splitting + +can_split :: Bool +can_split = cSupportsSplitObjs == "YES" + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Support dynamic-too", if isWindows then "NO" else "YES"), + ("Support parallel --make", "YES"), + ("Support reexported-modules", "YES"), + ("Support thinning and renaming package flags", "YES"), + ("Uses package keys", "YES"), + ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags + then "YES" else "NO"), + ("GHC Dynamic", if dynamicGhc + then "YES" else "NO"), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags) + ] + where + isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (minBound :: Int32) + 8 -> toInteger (minBound :: Int64) + w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Int32) + 8 -> toInteger (maxBound :: Int64) + w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Word32) + 8 -> toInteger (maxBound :: Word64) + w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user. +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + | hscTarget dflags == HscC && + not (platformUnregisterised (targetPlatform dflags)) + = if cGhcWithNativeCodeGen == "YES" + then let dflags' = dflags { hscTarget = HscAsm } + warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" + in loop dflags' warn + else let dflags' = dflags { hscTarget = HscLlvm } + warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" + in loop dflags' warn + | hscTarget dflags == HscAsm && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { hscTarget = HscC }) + "Compiler unregisterised, so compiling via C" + | hscTarget dflags == HscAsm && + cGhcWithNativeCodeGen /= "YES" + = let dflags' = dflags { hscTarget = HscLlvm } + warn = "No native code generator, so using LLVM" + in loop dflags' warn + | hscTarget dflags == HscLlvm && + not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin || os == OSFreeBSD)) && + not ((isARM arch) && (os == OSLinux)) && + (not (gopt Opt_Static dflags) || gopt Opt_PIC dflags) + = if cGhcWithNativeCodeGen == "YES" + then let dflags' = dflags { hscTarget = HscAsm } + warn = "Using native code generator rather than LLVM, as LLVM is incompatible with -fPIC and -dynamic on this platform" + in loop dflags' warn + else throwGhcException $ CmdLineError "Can't use -fPIC or -dynamic on this platform" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + | Left err <- checkOptLevel (optLevel dflags) dflags + = loop (updOptLevel 0 dflags) err + | otherwise = (dflags, []) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws) -> (dflags', L loc warning : ws) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + +{- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). + +-} + +-------------------------------------------------------------------------- +-- Do not use unsafeGlobalDynFlags! +-- +-- unsafeGlobalDynFlags is a hack, necessary because we need to be able +-- to show SDocs when tracing, but we don't always have DynFlags +-- available. +-- +-- Do not use it if you can help it. You may get the wrong value, or this +-- panic! + +GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags) + +unsafeGlobalDynFlags :: DynFlags +unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +data SseVersion = SSE1 + | SSE2 + | SSE3 + | SSE4 + | SSE42 + deriving (Eq, Ord) + +isSseEnabled :: DynFlags -> Bool +isSseEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + ArchX86 -> sseVersion dflags >= Just SSE1 + _ -> False + +isSse2Enabled :: DynFlags -> Bool +isSse2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be + -- possible to make it optional, but we'd need to + -- fix at least the foreign call code where the + -- calling convention specifies the use of xmm regs, + -- and possibly other places. + True + ArchX86 -> sseVersion dflags >= Just SSE2 + _ -> False + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +-- ----------------------------------------------------------------------------- +-- Linker/compiler information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | DarwinLD [Option] + | SolarisLD [Option] + | UnknownLD + deriving Eq + +-- CompilerInfo tells us which C compiler we're using +data CompilerInfo + = GCC + | Clang + | AppleClang + | AppleClang51 + | UnknownCC + deriving Eq + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot new file mode 100644 index 00000000..5cf21669 --- /dev/null +++ b/compiler/main/DynFlags.hs-boot @@ -0,0 +1,13 @@ + +module DynFlags where + +import Platform + +data DynFlags + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +useUnicode :: DynFlags -> Bool +useUnicodeSyntax :: DynFlags -> Bool diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs new file mode 100644 index 00000000..82081bf1 --- /dev/null +++ b/compiler/main/DynamicLoading.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE CPP, MagicHash #-} + +-- | Dynamically lookup up values from modules and loading them. +module DynamicLoading ( +#ifdef GHCI + -- * Loading plugins + loadPlugins, + + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModuleForPlugins, + + -- * Loading values + getValueSafely, + getHValueSafely, + lessUnsafeCoerce +#endif + ) where + +#ifdef GHCI +import Linker ( linkModule, getHValue ) +import SrcLoc ( noSrcSpan ) +import Finder ( findImportedModule, cannotFindModule ) +import TcRnMonad ( initTcInteractive, initIfaceTcRn ) +import LoadIface ( loadPluginInterface ) +import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName + , gre_name, mkRdrQual ) +import OccName ( mkVarOcc ) +import RnNames ( gresFromAvails ) +import DynFlags +import Plugins ( Plugin, CommandLineOption ) +import PrelNames ( pluginTyConName ) + +import HscTypes +import BasicTypes ( HValue ) +import TypeRep ( mkTyConTy, pprTyThingCategory ) +import Type ( Type, eqType ) +import TyCon ( TyCon ) +import Name ( Name, nameModule_maybe ) +import Id ( idType ) +import Module ( Module, ModuleName ) +import Panic +import FastString +import ErrUtils +import Outputable +import Exception +import Hooks + +import Data.Maybe ( mapMaybe ) +import GHC.Exts ( unsafeCoerce# ) + + +loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])] +loadPlugins hsc_env + = do { plugins <- mapM (loadPlugin hsc_env) to_load + ; return $ map attachOptions $ to_load `zip` plugins } + where + dflags = hsc_dflags hsc_env + to_load = pluginModNames dflags + + attachOptions (mod_nm, plug) = (mod_nm, plug, options) + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + +loadPlugin :: HscEnv -> ModuleName -> IO Plugin +loadPlugin hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + dflags = hsc_dflags hsc_env + ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name + plugin_rdr_name + ; case mb_name of { + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ ptext (sLit "The module"), ppr mod_name + , ptext (sLit "did not export the plugin name") + , ppr plugin_rdr_name ]) ; + Just name -> + + do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ ptext (sLit "The value"), ppr name + , ptext (sLit "did not have the type") + , ppr pluginTyConName, ptext (sLit "as required")]) + Just plugin -> return plugin } } } + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTcInteractive hsc_env $ + initIfaceTcRn $ + mapM_ (loadPluginInterface doc) modules) + >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name + + mb_con_thing <- lookupTypeHscEnv hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env val_name expected_type = do + mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type + case mb_hval of + Nothing -> return Nothing + Just hval -> do + value <- lessUnsafeCoerce dflags "getValueSafely" hval + return (Just value) + where + dflags = hsc_dflags hsc_env + +getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) +getHValueSafely hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupTypeHscEnv hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do linkModule hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- getHValue hsc_env val_name + return (Just hval) + else return Nothing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: DynFlags -> String -> a -> IO b +lessUnsafeCoerce dflags context what = do + debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...") + output <- evaluate (unsafeCoerce# what) + debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion" + return output + + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the +-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' +-- could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +-- +-- Can only be used for looking up names while loading plugins (and is +-- *not* suitable for use within plugins). The interface file is +-- loaded very partially: just enough that it can be used, without its +-- rules and instances affecting (and being linked from!) the module +-- being compiled. This was introduced by 57d6798. +-- +-- See Note [Care with plugin imports] in LoadIface. +lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) +lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do + -- First find the package the module resides in by searching exposed packages and home modules + found_module <- findImportedModule hsc_env mod_name Nothing + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_iface) <- initTcInteractive hsc_env $ + initIfaceTcRn $ + loadPluginInterface doc mod + case mb_iface of + Just iface -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + , is_qual = False, is_dloc = noSrcSpan } + provenance = Imported [ImpSpec decl_spec ImpAll] + env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface)) + case lookupGRE_RdrName rdr_name env of + [gre] -> return (Just (gre_name gre)) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + + Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule") + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] + +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcExceptionIO . CmdLineError +#endif diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs new file mode 100644 index 00000000..2a3b4c78 --- /dev/null +++ b/compiler/main/ErrUtils.hs @@ -0,0 +1,431 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[ErrsUtils]{Utilities for error reporting} +-} + +{-# LANGUAGE CPP #-} + +module ErrUtils ( + MsgDoc, + Validity(..), andValid, allValid, isValid, getInvalids, + + ErrMsg, WarnMsg, Severity(..), + Messages, ErrorMessages, WarningMessages, + errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, + pprLocErrMsg, makeIntoWarning, isWarning, + + errorsFound, emptyMessages, isEmptyMessages, + mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, + printBagOfErrors, + warnIsErrorMsg, mkLongWarnMsg, + + ghcExit, + doIfSet, doIfSet_dyn, + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, + mkDumpDoc, dumpSDoc, + + -- * Messages during compilation + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, + errorMsg, warningMsg, + fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', + compilationProgressMsg, + showPass, + debugTraceMsg, + + prettyPrintGhcErrors, + ) where + +#include "HsVersions.h" + +import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) +import Exception +import Outputable +import Panic +import FastString +import SrcLoc +import DynFlags + +import System.Directory +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( takeDirectory, () ) +import Data.List +import qualified Data.Set as Set +import Data.IORef +import Data.Ord +import Data.Time +import Control.Monad +import Control.Monad.IO.Class +import System.IO + +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- Everything is fine + | NotValid MsgDoc -- A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +allValid :: [Validity] -> Validity -- If they aren't all valid, return the first +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + +data ErrMsg = ErrMsg { + errMsgSpan :: SrcSpan, + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: MsgDoc, -- errMsgShort* should always + errMsgShortString :: String, -- contain the same text + errMsgExtraInfo :: MsgDoc, + errMsgSeverity :: Severity + } + -- The SrcSpan is used for sorting errors into line-number order + +type WarnMsg = ErrMsg + +data Severity + = SevOutput + | SevDump + | SevInteractive + | SevInfo + | SevWarning + | SevError + | SevFatal + +instance Show ErrMsg where + show em = errMsgShortString em + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "". +mkLocMessage severity locn msg + = sdocWithDynFlags $ \dflags -> + let locn' = if gopt Opt_ErrorSpans dflags + then ppr locn + else ppr (srcSpanStart locn) + in hang (locn' <> colon <+> sev_info) 4 msg + where + sev_info = case severity of + SevWarning -> ptext (sLit "Warning:") + _other -> empty + -- For warnings, print Foo.hs:34: Warning: + -- + +makeIntoWarning :: ErrMsg -> ErrMsg +makeIntoWarning err = err { errMsgSeverity = SevWarning } + +isWarning :: ErrMsg -> Bool +isWarning err + | SevWarning <- errMsgSeverity err = True + | otherwise = False +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual msg extra + = ErrMsg { errMsgSpan = locn, errMsgContext = print_unqual + , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg + , errMsgExtraInfo = extra + , errMsgSeverity = sev } + +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- A long (multi-line) error message +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg +-- Variant that doesn't care about qualified/unqualified names + +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty + +---------------- +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +isEmptyMessages :: Messages -> Bool +isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs + +warnIsErrorMsg :: DynFlags -> ErrMsg +warnIsErrorMsg dflags + = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") + +errorsFound :: DynFlags -> Messages -> Bool +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = printMsgBag dflags bag_of_errors + +pprErrMsgBag :: Bag ErrMsg -> [SDoc] +pprErrMsgBag bag + = [ sdocWithDynFlags $ \dflags -> + let style = mkErrStyle dflags unqual + in withPprStyle style (d $$ e) + | ErrMsg { errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sortMsgBag bag ] + +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ] + +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpan = s + , errMsgShortDoc = d + , errMsgExtraInfo = e + , errMsgSeverity = sev + , errMsgContext = unqual }) + = sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e)) + +printMsgBag :: DynFlags -> Bag ErrMsg -> IO () +printMsgBag dflags bag + = sequence_ [ let style = mkErrStyle dflags unqual + in log_action dflags dflags sev s style (d $$ e) + | ErrMsg { errMsgSpan = s, + errMsgShortDoc = d, + errMsgSeverity = sev, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sortMsgBag bag ] + +sortMsgBag :: Bag ErrMsg -> [ErrMsg] +sortMsgBag bag = sortBy (comparing errMsgSpan) $ bagToList bag + +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) + +doIfSet :: Bool -> IO () -> IO () +doIfSet flag action | flag = action + | otherwise = return () + +doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() +doIfSet_dyn dflags flag action | gopt flag dflags = action + | otherwise = return () + +-- ----------------------------------------------------------------------------- +-- Dumping + +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc + | not flag = return () + | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) + +-- | a wrapper around 'dumpSDoc'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpIfSet_dyn dflags flag hdr doc + = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc + +-- | a wrapper around 'dumpSDoc'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', +-- has a printer argument but no header argument +dumpIfSet_dyn_printer :: PrintUnqualified + -> DynFlags -> DumpFlag -> SDoc -> IO () +dumpIfSet_dyn_printer printer dflags flag doc + = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text (replicate 20 '=') + + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout. +-- +-- When hdr is empty, we print in a more compact format (no separators and +-- blank lines) +-- +-- The DumpFlag is used only to choose the filename to use if --dump-to-file is +-- used; it is not used to decide whether to dump the output +dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () +dumpSDoc dflags print_unqual flag hdr doc + = do let mFile = chooseDumpFile dflags flag + dump_style = mkDumpStyle print_unqual + case mFile of + Just fileName + -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + when (not append) $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + handle <- openFile fileName mode + + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://ghc.haskell.org/trac/ghc/ticket/10762 + hSetEncoding handle utf8 + + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let d = text (show t) + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle doc' dump_style + hClose handle + + -- write the dump to stdout + Nothing -> do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + log_action dflags dflags severity noSrcSpan dump_style doc' + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String +chooseDumpFile dflags flag + + | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ (beautifyDumpName flag)) + + | otherwise + = Nothing + + where getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by DriverPipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d f + Nothing -> f + +-- | Build a nice file name from name of a GeneralFlag constructor +beautifyDumpName :: DumpFlag -> String +beautifyDumpName Opt_D_th_dec_file = "th.hs" +beautifyDumpName flag + = let str = show flag + suff = case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("Bad flag name: " ++ str) + dash = map (\c -> if c == '_' then '-' else c) suff + in dash + + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +errorMsg :: DynFlags -> MsgDoc -> IO () +errorMsg dflags msg + = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg + +warningMsg :: DynFlags -> MsgDoc -> IO () +warningMsg dflags msg + = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg + +fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO () +fatalErrorMsg' la dflags msg = + la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 $ + logOutput dflags defaultUserStyle (text msg) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 $ + logInfo dflags defaultUserStyle (text "***" <+> text what <> colon) + +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () +debugTraceMsg dflags val msg = ifVerbose dflags val $ + logInfo dflags defaultDumpStyle msg + +putMsg :: DynFlags -> MsgDoc -> IO () +putMsg dflags msg = logInfo dflags defaultUserStyle msg + +printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser dflags print_unqual msg + = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg + +printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser dflags print_unqual msg + = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg + +logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () +logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg + +logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () +-- Like logInfo but with SevOutput rather then SevInfo +logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic (text str) doc + PprSorry str doc -> + pprDebugAndThen dflags sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError (text str) doc + _ -> + liftIO $ throwIO e diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot new file mode 100644 index 00000000..ac1673b3 --- /dev/null +++ b/compiler/main/ErrUtils.hs-boot @@ -0,0 +1,17 @@ +module ErrUtils where + +import Outputable (SDoc) +import SrcLoc (SrcSpan) + +data Severity + = SevOutput + | SevDump + | SevInteractive + | SevInfo + | SevWarning + | SevError + | SevFatal + +type MsgDoc = SDoc + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs new file mode 100644 index 00000000..09bf830f --- /dev/null +++ b/compiler/main/Finder.hs @@ -0,0 +1,705 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section[Finder]{Module Finder} +-} + +{-# LANGUAGE CPP #-} + +module Finder ( + flushFinderCaches, + FindResult(..), + findImportedModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + addHomeModuleToFinder, + uncacheModule, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cannotFindModule, + cannotFindInterface, + + ) where + +#include "HsVersions.h" + +import Module +import HscTypes +import Packages +import FastString +import Util +import PrelNames ( gHC_PRIM ) +import DynFlags +import Outputable +import UniqFM +import Maybes ( expectJust ) +import Exception ( evaluate ) + +import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) +import System.Directory +import System.FilePath +import Control.Monad +import Data.Time +import Data.List ( foldl' ) + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllPackages for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session. +flushFinderCaches :: HscEnv -> IO () +flushFinderCaches hsc_env = do + -- Ideally the update to both caches be a single atomic operation. + writeIORef fc_ref emptyUFM + flushModLocationCache this_pkg mlc_ref + where + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + mlc_ref = hsc_MLC hsc_env + +flushModLocationCache :: PackageKey -> IORef ModLocationCache -> IO () +flushModLocationCache this_pkg ref = do + atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ()) + _ <- evaluate =<< readIORef ref + return () + where is_ext mod _ | modulePackageKey mod /= this_pkg = True + | otherwise = False + +addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () +addToFinderCache ref key val = + atomicModifyIORef ref $ \c -> (addToUFM c key val, ()) + +addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO () +addToModLocationCache ref key val = + atomicModifyIORef ref $ \c -> (extendModuleEnv c key val, ()) + +removeFromFinderCache :: IORef FinderCache -> ModuleName -> IO () +removeFromFinderCache ref key = + atomicModifyIORef ref $ \c -> (delFromUFM c key, ()) + +removeFromModLocationCache :: IORef ModLocationCache -> Module -> IO () +removeFromModLocationCache ref key = + atomicModifyIORef ref $ \c -> (delModuleEnv c key, ()) + +lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) +lookupFinderCache ref key = do + c <- readIORef ref + return $! lookupUFM c key + +lookupModLocationCache :: IORef ModLocationCache -> Module + -> IO (Maybe ModLocation) +lookupModLocationCache ref key = do + c <- readIORef ref + return $! lookupModuleEnv c key + +-- ----------------------------------------------------------------------------- +-- The two external entry points + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult +findImportedModule hsc_env mod_name mb_pkg = + case mb_pkg of + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import + where + home_import = findHomeModule hsc_env mod_name + + pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg + + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule hsc_env mod = + let dflags = hsc_dflags hsc_env + in if modulePackageKey mod == thisPackage dflags + then findHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod + +-- ----------------------------------------------------------------------------- +-- Helpers + +orIfNotFound :: IO FindResult -> IO FindResult -> IO FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + _other -> return res + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult +homeSearchCache hsc_env mod_name do_this = do + m <- lookupFinderCache (hsc_FC hsc_env) mod_name + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod_name result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result + +findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString + -> IO FindResult +findExposedPackageModule hsc_env mod_name mb_pkg + = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of + LookupFound m pkg_conf -> + findPackageModule_ hsc_env m pkg_conf + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens + , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens + , fr_suggestions = [] }) + LookupNotFound suggest -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = suggest }) + +modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache hsc_env mod do_this = do + mb_loc <- lookupModLocationCache mlc mod + case mb_loc of + Just loc -> return (Found loc mod) + Nothing -> do + result <- do_this + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result + where + mlc = hsc_MLC hsc_env + +addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder hsc_env mod_name loc = do + let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name + addToFinderCache (hsc_FC hsc_env) mod_name (Found loc mod) + addToModLocationCache (hsc_MLC hsc_env) mod loc + return mod + +uncacheModule :: HscEnv -> ModuleName -> IO () +uncacheModule hsc_env mod = do + let this_pkg = thisPackage (hsc_dflags hsc_env) + removeFromFinderCache (hsc_FC hsc_env) mod + removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod) + +-- ----------------------------------------------------------------------------- +-- The internal workers + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the package key associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = + homeSearchCache hsc_env mod_name $ + let + dflags = hsc_dflags hsc_env + home_path = importPaths dflags + hisuf = hiSuf dflags + mod = mkModule (thisPackage dflags) mod_name + + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") + , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") + , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") + ] + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + in + + -- special case for GHC.Prim; we won't find it in the filesystem. + -- This is important only when compiling the base package (where GHC.Prim + -- is a home module). + if mod == gHC_PRIM + then return (Found (error "GHC.Prim ModLocation") mod) + else searchPathExts home_path mod exts + + +-- | Search for a module in external packages only. +findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule hsc_env mod = do + let + dflags = hsc_dflags hsc_env + pkg_id = modulePackageKey mod + -- + case lookupPackage dflags pkg_id of + Nothing -> return (NoPackage pkg_id) + Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.lhs@) and (2) +-- the 'PackageConfig' must be consistent with the package key in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult +findPackageModule_ hsc_env mod pkg_conf = + ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) + modLocationCache hsc_env mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod == gHC_PRIM + then return (Found (error "GHC.Prim ModLocation") mod) + else + + let + dflags = hsc_dflags hsc_env + tag = buildTag dflags + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf + + import_dirs = importDirs pkg_conf + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + in + case import_dirs of + [one] | MkDepend <- ghcMode dflags -> do + -- there's only one place that this .hi file can be, so + -- don't bother looking for it. + let basename = moduleNameSlashes (moduleName mod) + loc <- mk_hi_loc one basename + return (Found loc mod) + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> Module -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action + ) + ] + -> IO FindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result + + where + basename = moduleNameSlashes (moduleName mod) + + to_search :: [(FilePath, IO ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] + + search [] = return (NotFound { fr_paths = map fst to_search + , fr_pkg = Just (modulePackageKey mod) + , fr_mods_hidden = [], fr_pkgs_hidden = [] + , fr_suggestions = [] }) + + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + then do { loc <- mk_result; return (Found loc mod) } + else search rest + +mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt + -> FilePath -> BaseName -> IO ModLocation +mkHomeModLocationSearched dflags mod suff path basename = do + mkHomeModLocation2 dflags mod (path basename) suff + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitExtension src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 dflags mod src_basename ext = do + let mod_basename = moduleNameSlashes mod + + obj_fn = mkObjPath dflags src_basename mod_basename + hi_fn = mkHiPath dflags src_basename mod_basename + + return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) + +mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String + -> IO ModLocation +mkHiOnlyModLocation dflags hisuf path basename + = do let full_basename = path basename + obj_fn = mkObjPath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkObjPath dflags basename mod_basename = obj_basename <.> osuf + where + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiPath dflags basename mod_basename = hi_basename <.> hisuf + where + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> ModuleName + -> ModLocation + -> FilePath + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = moduleNameSlashes mod + src_basename = dropExtension $ expectJust "mkStubPaths" + (ml_hs_file location) + + stub_basename0 + | Just dir <- stubdir = dir mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + stub_basename <.> "h" + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc +cannotFindModule = cantFindErr (sLit "Could not find module") + (sLit "Ambiguous module name") + +cannotFindInterface :: DynFlags -> ModuleName -> FindResult -> SDoc +cannotFindInterface = cantFindErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") + +cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult + -> SDoc +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + sep [ptext (sLit "it was found in multiple packages:"), + hsep (map ppr pkgs) ] + ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (modulePackageKey m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> + ptext (sLit "by") <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [ptext (sLit "package") <+> ppr (modulePackageKey m)] + else [] ++ + map ((ptext (sLit "a reexport in package") <+>) + .ppr.packageConfigId) res ++ + if f then [ptext (sLit "a package flag")] else [] + ) + +cantFindErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + NoPackage pkg + -> ptext (sLit "no package key matching") <+> quotes (ppr pkg) <+> + ptext (sLit "was found") $$ looks_like_srcpkgid pkg + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , fr_suggestions = suggest } + | Just pkg <- mb_pkg, pkg /= thisPackage dflags + -> not_found_in_package pkg files + + | not (null suggest) + -> pp_suggestions suggest $$ tried_these files + + | null files && null mod_hiddens && null pkg_hiddens + -> ptext (sLit "It is not a module in the current program, or in any known package.") + + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + tried_these files + + _ -> panic "cantFindErr" + + build_tag = buildTag dflags + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + ptext (sLit "Perhaps you haven't installed the ") <> text build <> + ptext (sLit " libraries for package ") <> quotes (ppr pkg) <> char '?' $$ + tried_these files + + | otherwise + = ptext (sLit "There are files missing in the ") <> quotes (ppr pkg) <> + ptext (sLit " package,") $$ + ptext (sLit "try running 'ghc-pkg check'.") $$ + tried_these files + + tried_these files + | null files = Outputable.empty + | verbosity dflags < 3 = + ptext (sLit "Use -v to see a list of the files searched for.") + | otherwise = + hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) + + pkg_hidden :: PackageKey -> SDoc + pkg_hidden pkgid = + ptext (sLit "It is a member of the hidden package") + <+> quotes (ppr pkgid) + --FIXME: we don't really want to show the package key here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ cabal_pkg_hidden_hint pkgid + cabal_pkg_hidden_hint pkgid + | gopt Opt_BuildingCabalPackage dflags + = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) + in ptext (sLit "Perhaps you need to add") <+> + quotes (ppr (packageName pkg)) <+> + ptext (sLit "to the build-depends in your .cabal file.") + | otherwise = Outputable.empty + + looks_like_srcpkgid :: PackageKey -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a package key FastString into a source package ID + -- FastString and see if it means anything. + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (packageKeyFS pk)) + = parens (text "This package key looks like the source package ID;" $$ + text "the real package key is" <+> quotes (ftext (packageKeyFS (packageKey pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + mod_hidden pkg = + ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) + + pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = Outputable.empty + | otherwise = hang (ptext (sLit "Perhaps you meant")) + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModOrigin{ fromOrigPackage = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | f && moduleName mod == m + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | (pkg:_) <- res + = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) + <> comma <+> ptext (sLit "reexporting") <+> ppr mod) + | f + = parens (ptext (sLit "defined via package flags to be") + <+> ppr mod) + | otherwise = Outputable.empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModOrigin{ fromOrigPackage = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (modulePackageKey mod)) + | (pkg:_) <- rhs + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (packageConfigId pkg)) + | otherwise = Outputable.empty diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs new file mode 100644 index 00000000..b39c0022 --- /dev/null +++ b/compiler/main/GHC.hs @@ -0,0 +1,1463 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2012 +-- +-- The GHC API +-- +-- ----------------------------------------------------------------------------- + +module GHC ( + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, + prettyPrintGhcErrors, + + -- * GHC Monad + Ghc, GhcT, GhcMonad(..), HscEnv, + runGhc, runGhcT, initGhcMonad, + gcatch, gbracket, gfinally, + printException, + handleSourceError, + needsTemplateHaskell, + + -- * Flags and settings + DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt, + GhcMode(..), GhcLink(..), defaultObjectTarget, + parseDynamicFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, + getInteractiveDynFlags, setInteractiveDynFlags, + parseStaticFlags, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Loading\/compiling the program + depanal, + load, LoadHowMuch(..), InteractiveImport(..), + SuccessFlag(..), succeeded, failed, + defaultWarnErrLogger, WarnErrLogger, + workingDirectoryChanged, + parseModule, typecheckModule, desugarModule, loadModule, + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), + TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, + moduleInfo, renamedSource, typecheckedSource, + parsedSource, coreModule, + + -- ** Compiling to Core + CoreModule(..), + compileToCoreModule, compileToCoreSimplified, + + -- * Inspecting the module structure of the program + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), + getModSummary, + getModuleGraph, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoExports, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, + modInfoIface, + modInfoSafe, + lookupGlobalName, + findGlobalAnns, + mkPrintUnqualifiedForModule, + ModIface(..), + SafeHaskellMode(..), + + -- * Querying the environment + -- packageDbModules, + + -- * Printing + PrintUnqualified, alwaysQualify, + + -- * Interactive evaluation + getBindings, getInsts, getPrintUnqual, + findModule, lookupModule, +#ifdef GHCI + isModuleTrusted, + moduleTrustReqs, + setContext, getContext, + getNamesInScope, + getRdrNamesInScope, + getGRE, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + RunResult(..), + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + runTcInteractive, -- Desired by some clients (Trac #8878) + parseImportDecl, SingleStep(..), + resume, + Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, + resumeHistory, resumeHistoryIx), + History(historyBreakInfo, historyEnclosingDecls), + GHC.getHistorySpan, getHistoryModule, + getResumeContext, + abandon, abandonAll, + InteractiveEval.back, + InteractiveEval.forward, + showModule, + isModuleInterpreted, + InteractiveEval.compileExpr, HValue, dynCompileExpr, + GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, + modInfoModBreaks, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, +#endif + lookupName, + +#ifdef GHCI + -- ** EXPERIMENTAL + setGHCiMonad, +#endif + + -- * Abstract syntax elements + + -- ** Packages + PackageKey, + + -- ** Modules + Module, mkModule, pprModule, moduleName, modulePackageKey, + ModuleName, mkModuleName, moduleNameString, + + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + recordSelectorFieldLabel, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, + isPrimTyCon, isFunTyCon, + isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, + tyConClass_maybe, + synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, dataConUserType, + dataConSrcBangs, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, classATs, + pprFundeps, + + -- ** Instances + ClsInst, + instanceDFunId, + pprInstance, pprInstanceHdr, + pprFamInst, + + FamInst, + + -- ** Types and Kinds + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprForAll, pprThetaArrowTy, + + -- ** Entities + TyThing(..), + + -- ** Syntax + module HsSyn, -- ToDo: remove extraneous bits + + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + + -- ** Source locations + SrcLoc(..), RealSrcLoc, + mkSrcLoc, noSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan(..), RealSrcSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Located + GenLocated(..), Located, + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, + + -- * Exceptions + GhcException(..), showGhcException, + + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + + -- * Pure interface to the parser + parser, + + -- * API Annotations + ApiAnns,AnnKeywordId(..),AnnotationComment(..), + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments, getAndRemoveAnnotationComments, + + -- * Miscellaneous + --sessionHscEnv, + cyclicModuleErr, + ) where + +{- + ToDo: + + * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. + * what StaticFlags should we expose, if any? +-} + +#include "HsVersions.h" + +#ifdef GHCI +import ByteCodeInstr +import BreakArray +import InteractiveEval +import TcRnDriver ( runTcInteractive ) +#endif + +import PprTyThing ( pprFamInst ) +import HscMain +import GhcMake +import DriverPipeline ( compileOne' ) +import GhcMonad +import TcRnMonad ( finalSafeMode ) +import TcRnTypes +import Packages +import NameSet +import RdrName +import qualified HsSyn -- hack as we want to reexport the whole module +import HsSyn +import Type hiding( typeKind ) +import Kind ( synTyConResKind ) +import TcType hiding( typeKind ) +import Id +import TysPrim ( alphaTyVars ) +import TyCon +import Class +import DataCon +import Name hiding ( varName ) +import Avail +import InstEnv +import FamInstEnv ( FamInst ) +import SrcLoc +import CoreSyn +import TidyPgm +import DriverPhases ( Phase(..), isHaskellSrcFilename ) +import Finder +import HscTypes +import DynFlags +import StaticFlags +import SysTools +import Annotations +import Module +import UniqFM +import Panic +import Platform +import Bag ( unitBag ) +import ErrUtils +import MonadUtils +import Util +import StringBuffer +import Outputable +import BasicTypes +import Maybes ( expectJust ) +import FastString +import qualified Parser +import Lexer +import ApiAnnotation + +import System.Directory ( doesFileExist ) +import Data.Maybe +import Data.List ( find ) +import Data.Time +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) +import Control.Monad +import System.Exit ( exitWith, ExitCode(..) ) +import Exception +import Data.IORef +import System.FilePath +import System.IO +import Prelude hiding (init) + + +-- %************************************************************************ +-- %* * +-- Initialisation: exception handlers +-- %* * +-- %************************************************************************ + + +-- | Install some default exception handlers and run the inner computation. +-- Unless you want to handle exceptions yourself, you should wrap this around +-- the top level of your program. The default handlers output the error +-- message(s) to stderr and exit cleanly. +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) + => FatalMessager -> FlushOut -> m a -> m a +defaultErrorHandler fm (FlushOut flushOut) inner = + -- top-level exception handler: any unrecognised exception is a compiler bug. + ghandle (\exception -> liftIO $ do + flushOut + case fromException exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg'' fm (show ioe) + _ -> case fromException exception of + Just UserInterrupt -> + -- Important to let this one propagate out so our + -- calling process knows we were interrupted by ^C + liftIO $ throwIO UserInterrupt + Just StackOverflow -> + fatalErrorMsg'' fm "stack overflow: use +RTS -K to increase it" + _ -> case fromException exception of + Just (ex :: ExitCode) -> liftIO $ throwIO ex + _ -> + fatalErrorMsg'' fm + (show (Panic (show exception))) + exitWith (ExitFailure 1) + ) $ + + -- error messages propagated as exceptions + handleGhcException + (\ge -> liftIO $ do + flushOut + case ge of + PhaseFailed _ code -> exitWith code + Signal _ -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg'' fm (show ge) + exitWith (ExitFailure 1) + ) $ + inner + +-- | Install a default cleanup handler to remove temporary files deposited by +-- a GHC run. This is separate from 'defaultErrorHandler', because you might +-- want to override the error handling, but still get the ordinary cleanup +-- behaviour. +defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => + DynFlags -> m a -> m a +defaultCleanupHandler dflags inner = + -- make sure we clean up after ourselves + inner `gfinally` + (liftIO $ do + cleanTempFiles dflags + cleanTempDirs dflags + ) + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. + + +-- %************************************************************************ +-- %* * +-- The Ghc Monad +-- %* * +-- %************************************************************************ + +-- | Run function for the 'Ghc' monad. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. +-- +-- Any errors not handled inside the 'Ghc' action are propagated as IO +-- exceptions. + +runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a +runGhc mb_top_dir ghc = do + ref <- newIORef (panic "empty session") + let session = Session ref + flip unGhc session $ do + initGhcMonad mb_top_dir + ghc + -- XXX: unregister interrupt handlers here? + +-- | Run function for 'GhcT' monad transformer. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. + +runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => + Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> GhcT m a -- ^ The action to perform. + -> m a +runGhcT mb_top_dir ghct = do + ref <- liftIO $ newIORef (panic "empty session") + let session = Session ref + flip unGhcT session $ do + initGhcMonad mb_top_dir + ghct + +-- | Initialise a GHC session. +-- +-- If you implement a custom 'GhcMonad' you must call this function in the +-- monad run function. It will initialise the session variable and clear all +-- warnings. +-- +-- The first argument should point to the directory where GHC's library files +-- reside. More precisely, this should be the output of @ghc --print-libdir@ +-- of the version of GHC the module using this API is compiled with. For +-- portability, you should use the @ghc-paths@ package, available at +-- . + +initGhcMonad :: GhcMonad m => Maybe FilePath -> m () +initGhcMonad mb_top_dir + = do { env <- liftIO $ + do { installSignalHandlers -- catch ^C + ; initStaticOpts + ; mySettings <- initSysTools mb_top_dir + ; dflags <- initDynFlags (defaultDynFlags mySettings) + ; checkBrokenTablesNextToCode dflags + ; setUnsafeGlobalDynFlags dflags + -- c.f. DynFlags.parseDynamicFlagsFull, which + -- creates DynFlags and sets the UnsafeGlobalDynFlags + ; newHscEnv dflags } + ; setSession env } + +-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which +-- breaks tables-next-to-code in dynamically linked modules. This +-- check should be more selective but there is currently no released +-- version where this bug is fixed. +-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and +-- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29 +checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () +checkBrokenTablesNextToCode dflags + = do { broken <- checkBrokenTablesNextToCode' dflags + ; when broken + $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr + ; fail "unsupported linker" + } + } + where + invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> + text "when using binutils ld (please see:" <+> + text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" + +checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool +checkBrokenTablesNextToCode' dflags + | not (isARM arch) = return False + | WayDyn `notElem` ways dflags = return False + | not (tablesNextToCode dflags) = return False + | otherwise = do + linkerInfo <- liftIO $ getLinkerInfo dflags + case linkerInfo of + GnuLD _ -> return True + _ -> return False + where platform = targetPlatform dflags + arch = platformArch platform + + +-- %************************************************************************ +-- %* * +-- Flags & settings +-- %* * +-- %************************************************************************ + +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] +setSessionDynFlags dflags = do + dflags' <- checkNewDynFlags dflags + (dflags'', preload) <- liftIO $ initPackages dflags' + modifySession $ \h -> h{ hsc_dflags = dflags'' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } } + invalidateModSummaryCache + return preload + +-- | Sets the program 'DynFlags'. +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] +setProgramDynFlags dflags = do + dflags' <- checkNewDynFlags dflags + (dflags'', preload) <- liftIO $ initPackages dflags' + modifySession $ \h -> h{ hsc_dflags = dflags'' } + invalidateModSummaryCache + return preload + +-- When changing the DynFlags, we want the changes to apply to future +-- loads, but without completely discarding the program. But the +-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so +-- after a change to DynFlags, the changes would apply to new modules +-- but not existing modules; this seems undesirable. +-- +-- Furthermore, the GHC API client might expect that changing +-- log_action would affect future compilation messages, but for those +-- modules we have cached ModSummaries for, we'll continue to use the +-- old log_action. This is definitely wrong (#7478). +-- +-- Hence, we invalidate the ModSummary cache after changing the +-- DynFlags. We do this by tweaking the date on each ModSummary, so +-- that the next downsweep will think that all the files have changed +-- and preprocess them again. This won't necessarily cause everything +-- to be recompiled, because by the time we check whether we need to +-- recopmile a module, we'll have re-summarised the module and have a +-- correct ModSummary. +-- +invalidateModSummaryCache :: GhcMonad m => m () +invalidateModSummaryCache = + modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) } + where + inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) } + +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'pkgState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + dflags' <- checkNewDynFlags dflags + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags' }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + + +parseDynamicFlags :: MonadIO m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlags = parseDynamicFlagsCmdLine + +-- | Checks the set of new DynFlags for possibly erroneous option +-- combinations when invoking 'setSessionDynFlags' and friends, and if +-- found, returns a fixed copy (if possible). +checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags +checkNewDynFlags dflags = do + -- See Note [DynFlags consistency] + let (dflags', warnings) = makeDynFlagsConsistent dflags + liftIO $ handleFlagWarnings dflags warnings + return dflags' + +-- %************************************************************************ +-- %* * +-- Setting, getting, and modifying the targets +-- %* * +-- %************************************************************************ + +-- ToDo: think about relative vs. absolute file paths. And what +-- happens when the current directory changes. + +-- | Sets the targets for this session. Each target may be a module name +-- or a filename. The targets correspond to the set of root modules for +-- the program\/library. Unloading the current program is achieved by +-- setting the current set of targets to be empty, followed by 'load'. +setTargets :: GhcMonad m => [Target] -> m () +setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) + +-- | Returns the current set of targets +getTargets :: GhcMonad m => m [Target] +getTargets = withSession (return . hsc_targets) + +-- | Add another target. +addTarget :: GhcMonad m => Target -> m () +addTarget target + = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) + +-- | Remove a target +removeTarget :: GhcMonad m => TargetId -> m () +removeTarget target_id + = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] + +-- | Attempts to guess what Target a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - otherwise interpret the string as a module name +-- +guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target +guessTarget str (Just phase) + = return (Target (TargetFile str (Just phase)) True Nothing) +guessTarget str Nothing + | isHaskellSrcFilename file + = return (target (TargetFile file Nothing)) + | otherwise + = do exists <- liftIO $ doesFileExist hs_file + if exists + then return (target (TargetFile hs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then return (target (TargetFile lhs_file Nothing)) + else do + if looksLikeModuleName file + then return (target (TargetModule (mkModuleName file))) + else do + dflags <- getDynFlags + liftIO $ throwGhcExceptionIO + (ProgramError (showSDoc dflags $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) + where + (file,obj_allowed) + | '*':rest <- str = (rest, False) + | otherwise = (str, True) + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + + target tid = Target tid obj_allowed Nothing + + +-- | Inform GHC that the working directory has changed. GHC will flush +-- its cache of module locations, since it may no longer be valid. +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). +workingDirectoryChanged :: GhcMonad m => m () +workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) + + +-- %************************************************************************ +-- %* * +-- Running phases one at a time +-- %* * +-- %************************************************************************ + +class ParsedMod m where + modSummary :: m -> ModSummary + parsedSource :: m -> ParsedSource + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. + +class TypecheckedMod m => DesugaredMod m where + coreModule :: m -> ModGuts + +-- | The result of successful parsing. +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource + , pm_extra_src_files :: [FilePath] + , pm_annotations :: ApiAnns } + -- See Note [Api annotations] in ApiAnnotation.hs + +instance ParsedMod ParsedModule where + modSummary m = pm_mod_summary m + parsedSource m = pm_parsed_source m + +-- | The result of successful typechecking. It also contains the parser +-- result. +data TypecheckedModule = + TypecheckedModule { tm_parsed_module :: ParsedModule + , tm_renamed_source :: Maybe RenamedSource + , tm_typechecked_source :: TypecheckedSource + , tm_checked_module_info :: ModuleInfo + , tm_internals_ :: (TcGblEnv, ModDetails) + } + +instance ParsedMod TypecheckedModule where + modSummary m = modSummary (tm_parsed_module m) + parsedSource m = parsedSource (tm_parsed_module m) + +instance TypecheckedMod TypecheckedModule where + renamedSource m = tm_renamed_source m + typecheckedSource m = tm_typechecked_source m + moduleInfo m = tm_checked_module_info m + tm_internals m = tm_internals_ m + +-- | The result of successful desugaring (i.e., translation to core). Also +-- contains all the information of a typechecked module. +data DesugaredModule = + DesugaredModule { dm_typechecked_module :: TypecheckedModule + , dm_core_module :: ModGuts + } + +instance ParsedMod DesugaredModule where + modSummary m = modSummary (dm_typechecked_module m) + parsedSource m = parsedSource (dm_typechecked_module m) + +instance TypecheckedMod DesugaredModule where + renamedSource m = renamedSource (dm_typechecked_module m) + typecheckedSource m = typecheckedSource (dm_typechecked_module m) + moduleInfo m = moduleInfo (dm_typechecked_module m) + tm_internals m = tm_internals_ (dm_typechecked_module m) + +instance DesugaredMod DesugaredModule where + coreModule m = dm_core_module m + +type ParsedSource = Located (HsModule RdrName) +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe LHsDocString) +type TypecheckedSource = LHsBinds Id + +-- NOTE: +-- - things that aren't in the output of the typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. +getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary mod = do + mg <- liftM hsc_mod_graph getSession + case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of + [] -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph") + [ms] -> return ms + multiple -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) + +-- | Parse a module. +-- +-- Throws a 'SourceError' on parse error. +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + hpm <- liftIO $ hscParse hsc_env_tmp ms + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) + (hpm_annotations hpm)) + -- See Note [Api annotations] in ApiAnnotation.hs + +-- | Typecheck and rename a parsed module. +-- +-- Throws a 'SourceError' if either fails. +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule +typecheckModule pmod = do + let ms = modSummary pmod + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } + details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env + return $ + TypecheckedModule { + tm_internals_ = (tc_gbl_env, details), + tm_parsed_module = pmod, + tm_renamed_source = rn_info, + tm_typechecked_source = tcg_binds tc_gbl_env, + tm_checked_module_info = + ModuleInfo { + minf_type_env = md_types details, + minf_exports = availsToNameSet $ md_exports details, + minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_instances = md_insts details, + minf_iface = Nothing, + minf_safe = safe +#ifdef GHCI + ,minf_modBreaks = emptyModBreaks +#endif + }} + +-- | Desugar a typechecked module. +desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule +desugarModule tcm = do + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg + return $ + DesugaredModule { + dm_typechecked_module = tcm, + dm_core_module = guts + } + +-- | Load a module. Input doesn't need to be desugared. +-- +-- A module must be loaded before dependent modules can be typechecked. This +-- always includes generating a 'ModIface' and, depending on the +-- 'DynFlags.hscTarget', may also include code generation. +-- +-- This function will always cause recompilation and will always overwrite +-- previous compilation results (potentially files on disk). +-- +loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod +loadModule tcm = do + let ms = modSummary tcm + let mod = ms_mod_name ms + let loc = ms_location ms + let (tcg, _details) = tm_internals tcm + + mb_linkable <- case ms_obj_date ms of + Just t | t > ms_hs_date ms -> do + l <- liftIO $ findObjectLinkable (ms_mod ms) + (ml_obj_file loc) t + return (Just l) + _otherwise -> return Nothing + + let source_modified | isNothing mb_linkable = SourceModified + | otherwise = SourceUnmodified + -- we can't determine stability here + + -- compile doesn't change the session + hsc_env <- getSession + mod_info <- liftIO $ compileOne' (Just tcg) Nothing + hsc_env ms 1 1 Nothing mb_linkable + source_modified + + modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } + return tcm + + +-- %************************************************************************ +-- %* * +-- Dealing with Core +-- %* * +-- %************************************************************************ + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' parses, typechecks, and +-- desugars the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule +compileToCoreSimplified = compileCore True + +compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule +compileCore simplify fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget target + _ <- load LoadAllTargets + -- Then find dependencies + modGraph <- depanal [] True + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + mod_guts <- coreModule `fmap` + -- TODO: space leaky: call hsc* directly? + (desugarModule =<< typecheckModule =<< parseModule modSummary) + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ + if simplify + then do + -- If simplify is true: simplify (hscSimplify), then tidy + -- (tidyProgram). + hsc_env <- getSession + simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts + tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts + return $ Left tidy_guts + else + return $ Right mod_guts + + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode + } + gutsToCoreModule safe_mode (Right mg) = CoreModule { + cm_module = mg_module mg, + cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) + (mg_tcs mg) + (mg_fam_insts mg), + cm_binds = mg_binds mg, + cm_safe = safe_mode + } + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +-- | Determines whether a set of modules requires Template Haskell. +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskell :: ModuleGraph -> Bool +needsTemplateHaskell ms = + any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms + +-- | Return @True@ <==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> + return $! isJust (lookupUFM (hsc_HPT hsc_env) m) + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + return $ ic_instances (hsc_IC hsc_env) + +getPrintUnqual :: GhcMonad m => m PrintUnqualified +getPrintUnqual = withSession $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode +#ifdef GHCI + ,minf_modBreaks :: ModBreaks +#endif + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + let mg = hsc_mod_graph hsc_env + if mdl `elem` map ms_mod mg + then liftIO $ getHomeModuleInfo hsc_env mdl + else do + {- if isHomeModule (hsc_dflags hsc_env) mdl + then return Nothing + else -} liftIO $ getPackageModuleInfo hsc_env mdl + -- ToDo: we don't understand what the following comment means. + -- (SDM, 19/7/2011) + -- getPackageModuleInfo will attempt to find the interface, so + -- we don't want to call it for a home module, just in case there + -- was a problem loading the module and the interface doesn't + -- exist... hence the isHomeModule test here. (ToDo: reinstate) + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +#ifdef GHCI +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + names = availsToNameSet avails + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = emptyModBreaks + })) +#else +-- bogusly different for non-GHCI (ToDo) +getPackageModuleInfo _hsc_env _mdl = do + return Nothing +#endif + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = availsToNameSet (md_exports details), + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface +#ifdef GHCI + ,minf_modBreaks = getModBreaks hmi +#endif + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetElems $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) + +mkPrintUnqualifiedForModule :: GhcMonad m => + ModuleInfo + -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X +mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> do + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +#ifdef GHCI +modInfoModBreaks :: ModuleInfo -> ModBreaks +modInfoModBreaks = minf_modBreaks +#endif + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } + +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupGlobalName name = withSession $ \hsc_env -> do + liftIO $ lookupTypeHscEnv hsc_env name + +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) + +#ifdef GHCI +-- | get the GlobalRdrEnv for a session +getGRE :: GhcMonad m => m GlobalRdrEnv +getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +#endif + +-- ----------------------------------------------------------------------------- + +{- ToDo: Move the primary logic here to compiler/main/Packages.lhs +-- | Return all /external/ modules available in the package database. +-- Modules from the current session (i.e., from the 'HomePackageTable') are +-- not included. This includes module names which are reexported by packages. +packageDbModules :: GhcMonad m => + Bool -- ^ Only consider exposed packages. + -> m [Module] +packageDbModules only_exposed = do + dflags <- getSessionDynFlags + let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) + return $ + [ mkModule pid modname + | p <- pkgs + , not only_exposed || exposed p + , let pid = packageConfigId p + , modname <- exposedModules p + ++ map exportName (reexportedModules p) ] + -} + +-- ----------------------------------------------------------------------------- +-- Misc exported utils + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) + +-- ---------------------------------------------------------------------------- + +#if 0 + +-- ToDo: +-- - Data and Typeable instances for HsSyn. + +-- ToDo: check for small transformations that happen to the syntax in +-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) + +-- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way +-- to get from TyCons, Ids etc. to TH syntax (reify). + +-- :browse will use either lm_toplev or inspect lm_interface, depending +-- on whether the module is interpreted or not. + +#endif + +-- Extract the filename, stringbuffer content and dynflags associed to a module +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) +getModuleSourceAndFlags mod = do + m <- getModSummary (moduleName mod) + case ml_hs_file $ ms_location m of + Nothing -> do dflags <- getDynFlags + liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod) + Just sourceFile -> do + source <- liftIO $ hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- The module must be in the module graph and its source must be available. +-- Throws a 'HscTypes.SourceError' on parse error. +getTokenStream :: GhcMonad m => Module -> m [Located Token] +getTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream source startLoc flags of + POk _ ts -> return ts + PFailed span err -> + do dflags <- getDynFlags + liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + case lexTokenStream source startLoc flags of + POk _ ts -> return $ addSourceToTokens startLoc source ts + PFailed span err -> + do dflags <- getDynFlags + liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + = case span of + UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = realSrcSpanStart s + end = realSrcSpanEnd s + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = getFile $ map (getLoc . fst) ts + getFile [] = panic "showRichTokenStream: No source file found" + getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (RealSrcSpan s : _) = srcSpanFile s + startLoc = mkRealSrcLoc sourceFile 1 1 + go _ [] = id + go loc ((L span _, str):ts) + = case span of + UnhelpfulSpan _ -> go loc ts + RealSrcSpan s + | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise -> ((replicate (tokLine - locLine) '\n') ++) + . ((replicate (tokCol - 1) ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) + tokEnd = realSrcSpanEnd s + +-- ----------------------------------------------------------------------------- +-- Interactive evaluation + +-- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the +-- filesystem and package database to find the corresponding 'Module', +-- using the algorithm that is used for an @import@ declaration. +findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +findModule mod_name maybe_pkg = withSession $ \hsc_env -> do + let + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + -- + case maybe_pkg of + Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m -> return m + err -> throwOneError $ noModError dflags noSrcSpan mod_name err + _otherwise -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found loc m | modulePackageKey m /= this_pkg -> return m + | otherwise -> modNotLoadedError dflags m loc + err -> throwOneError $ noModError dflags noSrcSpan mod_name err + +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) +lookupModule mod_name Nothing = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findExposedPackageModule hsc_env mod_name Nothing + case res of + Found _ m -> return m + err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing + +#ifdef GHCI +-- | Check that a module is safe to import (according to Safe Haskell). +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an error may be thrown first. +isModuleTrusted :: GhcMonad m => Module -> m Bool +isModuleTrusted m = withSession $ \hsc_env -> + liftIO $ hscCheckSafe hsc_env m noSrcSpan + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey]) +moduleTrustReqs m = withSession $ \hsc_env -> + liftIO $ hscGetSafe hsc_env m noSrcSpan + +-- | EXPERIMENTAL: DO NOT USE. +-- +-- Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +{-# WARNING setGHCiMonad "This is experimental! Don't use." #-} +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + +getHistorySpan :: GhcMonad m => History -> m SrcSpan +getHistorySpan h = withSession $ \hsc_env -> + return $ InteractiveEval.getHistorySpan hsc_env h + +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a + +obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId bound force id = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id + +#endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupName name = + withSession $ \hsc_env -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) + +parser str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (mkPState dflags buf loc) of + + PFailed span err -> + Left (unitBag (mkPlainErrMsg dflags span err)) + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) + diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs new file mode 100644 index 00000000..5f3e3154 --- /dev/null +++ b/compiler/main/GhcMake.hs @@ -0,0 +1,2039 @@ +{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +-- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as +-- deprecated, although it became un-deprecated later. As a result, using 7.6 +-- as your bootstrap compiler throws annoying warnings. + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GhcMake( + depanal, + load, LoadHowMuch(..), + + topSortModuleGraph, + + noModError, cyclicModuleErr + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker ( unload ) +#endif + +import DriverPhases +import DriverPipeline +import DynFlags +import ErrUtils +import Finder +import GhcMonad +import HeaderInfo +import HsSyn +import HscTypes +import Module +import RdrName ( RdrName ) +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) + +import Bag ( listToBag ) +import BasicTypes +import Digraph +import Exception ( tryIO, gbracket, gfinally ) +import FastString +import Maybes ( expectJust ) +import MonadUtils ( allM, MonadIO ) +import Outputable +import Panic +import SrcLoc +import StringBuffer +import SysTools +import UniqFM +import Util + +import Data.Either ( rights, partitionEithers ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified FiniteMap as Map ( insertListWith ) + +import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Data.IORef +import Data.List +import qualified Data.List as List +import Data.Maybe +import Data.Ord ( comparing ) +import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graphE <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots + mod_graph <- reportImportErrors mod_graphE + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + mod_graph <- depanal [] False + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco ] + + -- the modules from partial_mg that are not also stable + -- NB. also keep cycles, we need to emit an error message later + unstable_mg = filter not_stable partial_mg + where not_stable (CyclicSCC _) = True + not_stable (AcyclicSCC ms) + = ms_mod_name ms `notElem` stable_obj++stable_bco + + -- Load all the stable modules first, before attempting to load + -- an unstable module (#7231). + mg = stable_mg ++ unstable_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env) + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + n_jobs <- case parMakeCount dflags of + Nothing -> liftIO getNumProcessors + Just n -> return n + let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs + | otherwise = upsweep + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep_fn pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = gopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag + +-- If the link failed, unload everything and return. +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession discardIC + return all_ok + + +-- | Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } + +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags) + cleanTempFilesExcept dflags (notIntermediate ++ except) + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + + name_exe = do +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name' <- fmap (<.> "exe") name +#else + name' <- name +#endif + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapUFM prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] +findPartiallyCompletedCycles modsDone theGraph + = chew theGraph + where + chew [] = [] + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. + chew ((CyclicSCC vs):rest) + = let names_in_this_cycle = nub (map ms_mod vs) + mods_in_this_cycle + = nub ([done | done <- modsDone, + done `elem` names_in_this_cycle]) + chewed_rest = chew rest + in + if notNull mods_in_this_cycle + && length mods_in_this_cycle < length names_in_this_cycle + then mods_in_this_cycle ++ chewed_rest + else chewed_rest + + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + -- + -- But see #5527, where someone ran into this and it caused + -- a problem. + + bco_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +{- Parallel Upsweep + - + - The parallel upsweep attempts to concurrently compile the modules in the + - compilation graph using multiple Haskell threads. + - + - The Algorithm + - + - A Haskell thread is spawned for each module in the module graph, waiting for + - its direct dependencies to finish building before it itself begins to build. + - + - Each module is associated with an initially empty MVar that stores the + - result of that particular module's compile. If the compile succeeded, then + - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that + - module, and the module's HMI is deleted from the old HPT (synchronized by an + - IORef) to save space. + - + - Instead of immediately outputting messages to the standard handles, all + - compilation output is deferred to a per-module TQueue. A QSem is used to + - limit the number of workers that are compiling simultaneously. + - + - Meanwhile, the main thread sequentially loops over all the modules in the + - module graph, outputting the messages stored in each module's TQueue. +-} + +-- | Each module is given a unique 'LogQueue' to redirect compilation messages +-- to. A 'Nothing' value contains the result of compilation, and denotes the +-- end of the message queue. +data LogQueue = LogQueue !(IORef [Maybe (Severity, SrcSpan, PprStyle, MsgDoc)]) + !(MVar ()) + +-- | The graph of modules to compile and their corresponding result 'MVar' and +-- 'LogQueue'. +type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] + +-- | Build a 'CompilationGraph' out of a list of strongly-connected modules, +-- also returning the first, if any, encountered module cycle. +buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) +buildCompGraph [] = return ([], Nothing) +buildCompGraph (scc:sccs) = case scc of + AcyclicSCC ms -> do + mvar <- newEmptyMVar + log_queue <- do + ref <- newIORef [] + sem <- newEmptyMVar + return (LogQueue ref sem) + (rest,cycle) <- buildCompGraph sccs + return ((ms,mvar,log_queue):rest, cycle) + CyclicSCC mss -> return ([], Just mss) + +-- A Module and whether it is a boot module. +type BuildModule = (Module, IsBoot) + +-- | 'Bool' indicating if a module is a boot module or not. We need to treat +-- boot modules specially when building compilation graphs, since they break +-- cycles. Regular source files and signature files are treated equivalently. +data IsBoot = IsBoot | NotBoot + deriving (Ord, Eq, Show, Read) + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing +-- elements of 'BuildModule'. +hscSourceToIsBoot :: HscSource -> IsBoot +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + +mkBuildModule :: ModSummary -> BuildModule +mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) + +-- | The entry point to the parallel upsweep. +-- +-- See also the simpler, sequential 'upsweep'. +parUpsweep + :: GhcMonad m + => Int + -- ^ The number of workers we wish to run in parallel + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> (HscEnv -> IO ()) + -> [SCC ModSummary] + -> m (SuccessFlag, + [ModSummary]) +parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + -- The bits of shared state we'll be using: + + -- The global HscEnv is updated with the module's HMI when a module + -- successfully compiles. + hsc_env_var <- liftIO $ newMVar hsc_env + + -- The old HPT is used for recompilation checking in upsweep_mod. When a + -- module sucessfully gets compiled, its HMI is pruned from the old HPT. + old_hpt_var <- liftIO $ newIORef old_hpt + + -- What we use to limit parallelism with. + par_sem <- liftIO $ newQSem n_jobs + + + let updNumCapabilities = liftIO $ do + n_capabilities <- getNumCapabilities + unless (n_capabilities /= 1) $ setNumCapabilities n_jobs + return n_capabilities + -- Reset the number of capabilities once the upsweep ends. + let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n + + gbracket updNumCapabilities resetNumCapabilities $ \_ -> do + + -- Sync the global session with the latest HscEnv once the upsweep ends. + let finallySyncSession io = io `gfinally` do + hsc_env <- liftIO $ readMVar hsc_env_var + setSession hsc_env + + finallySyncSession $ do + + -- Build the compilation graph out of the list of SCCs. Module cycles are + -- handled at the very end, after some useful work gets done. Note that + -- this list is topologically sorted (by virtue of 'sccs' being sorted so). + (comp_graph,cycle) <- liftIO $ buildCompGraph sccs + let comp_graph_w_idx = zip comp_graph [1..] + + -- The list of all loops in the compilation graph. + -- NB: For convenience, the last module of each loop (aka the module that + -- finishes the loop) is prepended to the beginning of the loop. + let comp_graph_loops = go (map fstOf3 (reverse comp_graph)) + where + go [] = [] + go (ms:mss) | Just loop <- getModLoop ms (ms:mss) + = map mkBuildModule (ms:loop) : go mss + | otherwise + = go mss + + -- Build a Map out of the compilation graph with which we can efficiently + -- look up the result MVar associated with a particular home module. + let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) + home_mod_map = + Map.fromList [ (mkBuildModule ms, (mvar, idx)) + | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + + + liftIO $ label_self "main --make thread" + -- For each module in the module graph, spawn a worker thread that will + -- compile this module. + let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> + forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] + -- Replace the default log_action with one that writes each + -- message to the module's log_queue. The main thread will + -- deal with synchronously printing these messages. + -- + -- Use a local filesToClean var so that we can clean up + -- intermediate files in a timely fashion (as soon as + -- compilation for that module is finished) without having to + -- worry about accidentally deleting a simultaneous compile's + -- important files. + lcl_files_to_clean <- newIORef [] + let lcl_dflags = dflags { log_action = parLogAction log_queue + , filesToClean = lcl_files_to_clean } + + -- Unmask asynchronous exceptions and perform the thread-local + -- work to compile the module (see parUpsweep_one). + m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + parUpsweep_one mod home_mod_map comp_graph_loops + lcl_dflags cleanup + par_sem hsc_env_var old_hpt_var + stable_mods mod_idx (length sccs) + + res <- case m_res of + Right flag -> return flag + Left exc -> do + -- Don't print ThreadKilled exceptions: they are used + -- to kill the worker thread in the event of a user + -- interrupt, and the user doesn't have to be informed + -- about that. + when (fromException exc /= Just ThreadKilled) + (errorMsg lcl_dflags (text (show exc))) + return Failed + + -- Populate the result MVar. + putMVar mvar res + + -- Write the end marker to the message queue, telling the main + -- thread that it can stop waiting for messages from this + -- particular compile. + writeLogQueue log_queue Nothing + + -- Add the remaining files that weren't cleaned up to the + -- global filesToClean ref, for cleanup later. + files_kept <- readIORef (filesToClean lcl_dflags) + addFilesToClean dflags files_kept + + + -- Kill all the workers, masking interrupts (since killThread is + -- interruptible). XXX: This is not ideal. + ; killWorkers = uninterruptibleMask_ . mapM_ killThread } + + + -- Spawn the workers, making sure to kill them later. Collect the results + -- of each compile. + results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> + -- Loop over each module in the compilation graph in order, printing + -- each message from its log_queue. + forM comp_graph $ \(mod,mvar,log_queue) -> do + printLogs dflags log_queue + result <- readMVar mvar + if succeeded result then return (Just mod) else return Nothing + + + -- Collect and return the ModSummaries of all the successful compiles. + -- NB: Reverse this list to maintain output parity with the sequential upsweep. + let ok_results = reverse (catMaybes results) + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + return (Failed,ok_results) + Nothing -> do + let success_flag = successIf (all isJust results) + return (success_flag,ok_results) + + where + writeLogQueue :: LogQueue -> Maybe (Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue (LogQueue ref sem) msg = do + atomicModifyIORef ref $ \msgs -> (msg:msgs,()) + _ <- tryPutMVar sem () + return () + + -- The log_action callback that is used to synchronize messages from a + -- worker thread. + parLogAction :: LogQueue -> LogAction + parLogAction log_queue _dflags !severity !srcSpan !style !msg = do + writeLogQueue log_queue (Just (severity,srcSpan,style,msg)) + + -- Print each message from the log_queue using the log_action from the + -- session's DynFlags. + printLogs :: DynFlags -> LogQueue -> IO () + printLogs !dflags (LogQueue ref sem) = read_msgs + where read_msgs = do + takeMVar sem + msgs <- atomicModifyIORef ref $ \xs -> ([], reverse xs) + print_loop msgs + + print_loop [] = read_msgs + print_loop (x:xs) = case x of + Just (severity,srcSpan,style,msg) -> do + log_action dflags dflags severity srcSpan style msg + print_loop xs + -- Exit the loop once we encounter the end marker. + Nothing -> return () + +-- The interruptible subset of the worker threads' work. +parUpsweep_one + :: ModSummary + -- ^ The module we wish to compile + -> Map BuildModule (MVar SuccessFlag, Int) + -- ^ The map of home modules and their result MVar + -> [[BuildModule]] + -- ^ The list of all module loops within the compilation graph. + -> DynFlags + -- ^ The thread-local DynFlags + -> (HscEnv -> IO ()) + -- ^ The callback for cleaning up intermediate files + -> QSem + -- ^ The semaphore for limiting the number of simultaneous compiles + -> MVar HscEnv + -- ^ The MVar that synchronizes updates to the global HscEnv + -> IORef HomePackageTable + -- ^ The old HPT + -> ([ModuleName],[ModuleName]) + -- ^ Lists of stable objects and BCOs + -> Int + -- ^ The index of this module + -> Int + -- ^ The total number of modules + -> IO SuccessFlag + -- ^ The result of this compile +parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem + hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + + let this_build_mod = mkBuildModule mod + + let home_imps = map unLoc $ ms_home_imps mod + let home_src_imps = map unLoc $ ms_home_srcimps mod + + -- All the textual imports of this module. + let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ + zip home_imps (repeat NotBoot) ++ + zip home_src_imps (repeat IsBoot) + + -- Dealing with module loops + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Not only do we have to deal with explicit textual dependencies, we also + -- have to deal with implicit dependencies introduced by import cycles that + -- are broken by an hs-boot file. We have to ensure that: + -- + -- 1. A module that breaks a loop must depend on all the modules in the + -- loop (transitively or otherwise). This is normally always fulfilled + -- by the module's textual dependencies except in degenerate loops, + -- e.g.: + -- + -- A.hs imports B.hs-boot + -- B.hs doesn't import A.hs + -- C.hs imports A.hs, B.hs + -- + -- In this scenario, getModLoop will detect the module loop [A,B] but + -- the loop finisher B doesn't depend on A. So we have to explicitly add + -- A in as a dependency of B when we are compiling B. + -- + -- 2. A module that depends on a module in an external loop can't proceed + -- until the entire loop is re-typechecked. + -- + -- These two invariants have to be maintained to correctly build a + -- compilation graph with one or more loops. + + + -- The loop that this module will finish. After this module successfully + -- compiles, this loop is going to get re-typechecked. + let finish_loop = listToMaybe + [ tail loop | loop <- comp_graph_loops + , head loop == this_build_mod ] + + -- If this module finishes a loop then it must depend on all the other + -- modules in that loop because the entire module loop is going to be + -- re-typechecked once this module gets compiled. These extra dependencies + -- are this module's "internal" loop dependencies, because this module is + -- inside the loop in question. + let int_loop_deps = Set.fromList $ + case finish_loop of + Nothing -> [] + Just loop -> filter (/= this_build_mod) loop + + -- If this module depends on a module within a loop then it must wait for + -- that loop to get re-typechecked, i.e. it must wait on the module that + -- finishes that loop. These extra dependencies are this module's + -- "external" loop dependencies, because this module is outside of the + -- loop(s) in question. + let ext_loop_deps = Set.fromList + [ head loop | loop <- comp_graph_loops + , any (`Set.member` textual_deps) loop + , this_build_mod `notElem` loop ] + + + let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] + + -- All of the module's home-module dependencies. + let home_deps_with_idx = + [ home_dep | dep <- Set.toList all_deps + , Just home_dep <- [Map.lookup dep home_mod_map] ] + + -- Sort the list of dependencies in reverse-topological order. This way, by + -- the time we get woken up by the result of an earlier dependency, + -- subsequent dependencies are more likely to have finished. This step + -- effectively reduces the number of MVars that each thread blocks on. + let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx + + -- Wait for the all the module's dependencies to finish building. + deps_ok <- allM (fmap succeeded . readMVar) home_deps + + -- We can't build this module if any of its dependencies failed to build. + if not deps_ok + then return Failed + else do + -- Any hsc_env at this point is OK to use since we only really require + -- that the HPT contains the HMIs of our dependencies. + hsc_env <- readMVar hsc_env_var + old_hpt <- readIORef old_hpt_var + + let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + + -- Limit the number of parallel compiles. + let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) + mb_mod_info <- withSem par_sem $ + handleSourceError (\err -> do logger err; return Nothing) $ do + -- Have the ModSummary and HscEnv point to our local log_action + -- and filesToClean var. + let lcl_mod = localize_mod mod + let lcl_hsc_env = localize_hsc_env hsc_env + + -- Compile the module. + mod_info <- upsweep_mod lcl_hsc_env old_hpt stable_mods lcl_mod + mod_index num_mods + return (Just mod_info) + + case mb_mod_info of + Nothing -> return Failed + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Prune the old HPT unless this is an hs-boot module. + unless (isBootSummary mod) $ + atomicModifyIORef old_hpt_var $ \old_hpt -> + (delFromUFM old_hpt this_mod, ()) + + -- Update and fetch the global HscEnv. + lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do + let hsc_env' = hsc_env { hsc_HPT = addToUFM (hsc_HPT hsc_env) + this_mod mod_info } + -- If this module is a loop finisher, now is the time to + -- re-typecheck the loop. + hsc_env'' <- case finish_loop of + Nothing -> return hsc_env' + Just loop -> typecheckLoop lcl_dflags hsc_env' $ + map (moduleName . fst) loop + return (hsc_env'', localize_hsc_env hsc_env'') + + -- Clean up any intermediate files. + cleanup lcl_hsc_env' + return Succeeded + + where + localize_mod mod + = mod { ms_hspp_opts = (ms_hspp_opts mod) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + + localize_hsc_env hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + +-- ----------------------------------------------------------------------------- +-- +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. +upsweep + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) + -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) + where + + upsweep' _old_hpt done + [] _ _ + = return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:_) _ _ + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 + + upsweep' old_hpt1 done' mods (mod_index+1) nmods + +maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) +maybeGetIfaceDate dflags location + | writeInterfaceOnlyMode dflags + -- Minor optimization: it should be harmless to check the hi file location + -- always, but it's better to avoid hitting the filesystem if possible. + = modificationTimeIfExists (ml_hi_file location) + | otherwise + = return Nothing + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fllvm to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = + compileOne hsc_env summary' mod_index nmods + mb_old_iface mb_linkable src_modified + + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = + compileOne hsc_env summary' mod_index nmods + Nothing mb_linkable src_modified + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) SourceUnmodifiedAndStable + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) SourceUnmodified + + -- See Note [Recompilation checking when typechecking only] + | writeInterfaceOnlyMode dflags, + Just if_date <- mb_if_date, + if_date >= hs_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping tc'd mod:" <+> ppr this_mod_name) + compile_it Nothing SourceUnmodified + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing SourceModified + +-- Note [Recompilation checking when typechecking only] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we are compiling with -fno-code -fwrite-interface, there won't +-- be any object code that we can compare against, nor should there +-- be: we're *just* generating interface files. In this case, we +-- want to check if the interface file is new, in lieu of the object +-- file. See also Trac #9243. + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | Just loop <- getModLoop ms graph + , let non_boot = filter (not.isBootSummary) loop + = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + +getModLoop :: ModSummary -> ModuleGraph -> Maybe [ModSummary] +getModLoop ms graph + | not (isBootSummary ms) + , any (\m -> ms_mod m == this_mod && isBootSummary m) graph + , let mss = reachableBackwards (ms_mod_name ms) graph + = Just mss + | otherwise + = Nothing + where + this_mod = ms_mod ms + +typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop dflags hsc_env mods = do + debugTraceMsg dflags 2 $ + text "Re-typechecking loop: " <> ppr mods + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = throwGhcException (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +type SummaryNode = (ModSummary, Int, [Int]) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), + hscSourceToIsBoot (ms_hsc_src s)), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else NotBoot + +-- The nodes of the graph are keyed by (mod, is boot?) pairs +-- NB: hsig files show up as *normal* nodes (not boot!), since they don't +-- participate in cycles (for now) +type NodeKey = (ModuleName, IsBoot) +type NodeMap a = Map.Map NodeKey a + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) + = (moduleName mod, hscSourceToIsBoot boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + dflags <- getDynFlags + logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + + +reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b] +reportImportErrors xs | null errs = return oks + | otherwise = throwManyErrors errs + where (errs, oks) = partitionEithers xs + +throwManyErrors :: MonadIO m => [ErrMsg] -> m ab +throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs + + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [Either ErrMsg ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + rootSummariesOk <- reportImportErrors rootSummaries + let root_map = mkRootMap rootSummariesOk + checkDuplicates root_map + summs <- loop (concatMap calcDeps rootSummariesOk) root_map + return summs + where + -- When we're compiling a signature file, we have an implicit + -- dependency on what-ever the signature's implementation is. + -- (But not when we're type checking!) + calcDeps summ + | HsigFile <- ms_hsc_src summ + , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ)) + , modulePackageKey m == thisPackage (hsc_dflags hsc_env) + = (noLoc (moduleName m), NotBoot) : msDeps summ + | otherwise = msDeps summ + + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO (Either ErrMsg ModSummary) + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then Right `fmap` summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else return $ Left $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> return $ Left $ packageModErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map + + loop :: [(Located ModuleName,IsBoot)] + -- Work list: process these modules + -> NodeMap [Either ErrMsg ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [Either ErrMsg ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags (rights summs); return [] } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just (Left e) -> loop ss (Map.insert key [Left e] done) + Just (Right s)-> loop (calcDeps s ++ ss) + (Map.insert key [Right s] done) + where + key = (unLoc wanted_mod, is_boot) + +mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [Right s]) | s <- summaries ] + Map.empty + +-- | Returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] +msDeps s = + concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] + ++ [ (m,NotBoot) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,UTCTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + dflags = hsc_dflags hsc_env + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + if ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) + then do -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location NotBoot + else return Nothing + hi_timestamp <- maybeGetIfaceDate dflags location + return old_summary{ ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp } + else + new_summary src_timestamp + + | otherwise + = do src_timestamp <- get_src_timestamp + new_summary src_timestamp + where + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime file + -- getMofificationUTCTime may fail + + new_summary src_timestamp = do + let dflags = hsc_dflags hsc_env + + let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile + + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags location + + return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_iface_date = hi_timestamp, + ms_obj_date = obj_timestamp }) + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp dflags) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + hi_timestamp <- maybeGetIfaceDate dflags location + return (Just (Right old_summary{ ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp})) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageKey mod /= thisPackage dflags) + return Nothing + + err -> return $ Just $ Left $ noModError dflags loc wanted_mod err + -- Not found + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | IsBoot <- is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t + + + new_summary location mod src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src = case is_boot of + IsBoot -> HsBootFile + _ | isHaskellSigFilename src_fn -> HsigFile + | otherwise -> HsSrcFile + + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg dflags' mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + -- Find the object timestamp, and return the summary + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags location + + return (Just (Right (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_iface_date = hi_timestamp, + ms_obj_date = obj_timestamp }))) + + +getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) +getObjTimestamp location is_boot + = if is_boot == IsBoot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,UTCTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) + = do + let dflags = hsc_dflags hsc_env + let local_opts = getOptions dflags buf src_fn + + (dflags', leftovers, warns) + <- parseDynamicFilePragma dflags local_opts + checkProcessArgsResult dflags leftovers + handleFlagWarnings dflags' warns + + let needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | xopt Opt_Cpp dflags' = True + | gopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg +noHsFileErr dflags loc path + = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + +packageModErr :: DynFlags -> ModuleName -> ErrMsg +packageModErr dflags mod + = mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss + Just path -> vcat [ ptext (sLit "Module imports form a cycle:") + , nest 2 (show_path path) ] + where + graph :: [Node NodeKey ModSummary] + graph = [(ms, msKey ms, get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) + + show_path [] = panic "show_path" + show_path [m] = ptext (sLit "module") <+> ppr_ms m + <+> ptext (sLit "imports itself") + show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1) + : nest 6 (ptext (sLit "imports") <+> ppr_ms m2) + : go ms ) + where + go [] = [ptext (sLit "which imports") <+> ppr_ms m1] + go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms + + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs new file mode 100644 index 00000000..ebcaf368 --- /dev/null +++ b/compiler/main/GhcMonad.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GhcMonad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import MonadUtils +import HscTypes +import DynFlags +import Exception +import ErrUtils + +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Functor Ghc where + fmap f m = Ghc $ \s -> f `fmap` unGhc m s + +instance Applicative Ghc where + pure = return + g <*> m = do f <- g; a <- m; return (f a) + +instance Monad Ghc where + return a = Ghc $ \_ -> return a + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance MonadFix Ghc where + mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } +liftGhcT :: Monad m => m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Functor m => Functor (GhcT m) where + fmap f m = GhcT $ \s -> f `fmap` unGhcT m s + +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + +instance Monad m => Monad (GhcT m) where + return x = GhcT $ \_ -> return x + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance (Functor m, ExceptionMonad m, MonadIO m) => HasDynFlags (GhcT m) where + getDynFlags = getSessionDynFlags + +instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs new file mode 100644 index 00000000..2b7746c6 --- /dev/null +++ b/compiler/main/GhcPlugins.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | This module is not used by GHC itself. Rather, it exports all of +-- the functions and types you are likely to need when writing a +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GhcPlugins". +-- +-- Particularly interesting modules for plugin writers include +-- "CoreSyn" and "CoreMonad". +module GhcPlugins( + module Plugins, + module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, + module CoreMonad, module CoreSyn, module Literal, module DataCon, + module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, + module Rules, module Annotations, + module DynFlags, module Packages, + module Module, module Type, module TyCon, module Coercion, + module TysWiredIn, module HscTypes, module BasicTypes, + module VarSet, module VarEnv, module NameSet, module NameEnv, + module UniqSet, module UniqFM, module FiniteMap, + module Util, module Serialized, module SrcLoc, module Outputable, + module UniqSupply, module Unique, module FastString, module FastTypes + ) where + +-- Plugin stuff itself +import Plugins + +-- Variable naming +import RdrName +import OccName hiding ( varName {- conflicts with Var.varName -} ) +import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import Var +import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import IdInfo + +-- Core +import CoreMonad +import CoreSyn +import Literal +import DataCon +import CoreUtils +import MkCore +import CoreFVs +import CoreSubst + +-- Core "extras" +import Rules +import Annotations + +-- Pipeline-related stuff +import DynFlags +import Packages + +-- Important GHC types +import Module +import Type hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import Coercion hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar ) +import TyCon +import TysWiredIn +import HscTypes +import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) + +-- Collections and maps +import VarSet +import VarEnv +import NameSet +import NameEnv +import UniqSet +import UniqFM +-- Conflicts with UniqFM: +--import LazyUniqFM +import FiniteMap + +-- Common utilities +import Util +import Serialized +import SrcLoc +import Outputable +import UniqSupply +import Unique ( Unique, Uniquable(..) ) +import FastString +import FastTypes diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs new file mode 100644 index 00000000..3473a4ab --- /dev/null +++ b/compiler/main/HeaderInfo.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- | Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module HeaderInfo ( getImports + , mkPrelImports -- used by the renamer too + , getOptionsFromFile, getOptions + , optionsErrorMsgs, + checkProcessArgsResult ) where + +#include "HsVersions.h" + +import RdrName +import HscTypes +import Parser ( parseHeader ) +import Lexer +import FastString +import HsSyn +import Module +import PrelNames +import StringBuffer +import SrcLoc +import DynFlags +import ErrUtils +import Util +import Outputable +import Pretty () +import Maybes +import Bag ( emptyBag, listToBag, unitBag ) +import MonadUtils +import Exception + +import Control.Monad +import System.IO +import System.IO.Unsafe +import Data.List + +------------------------------------------------------------------------------ + +-- | Parse the imports of a source file. +-- +-- Throws a 'SourceError' if parsing fails. +getImports :: DynFlags + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) + -- ^ The source imports, normal imports, and the module name. +getImports dflags buf filename source_filename = do + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP parseHeader (mkPState dflags buf loc) of + PFailed span err -> parseError dflags span err + POk pst rdr_module -> do + let _ms@(_warns, errs) = getMessages pst + -- don't log warnings: they'll be reported when we parse the file + -- for real. See #2500. + ms = (emptyBag, errs) + -- logWarnings warns + if errorsFound dflags ms + then throwIO $ mkSrcErr errs + else + case rdr_module of + L _ (HsModule mb_mod _ imps _ _ _) -> + let + main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) + mod = mb_mod `orElse` L main_loc mAIN_NAME + (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt Opt_ImplicitPrelude dflags + implicit_imports = mkPrelImports (unLoc mod) main_loc + implicit_prelude imps + in + return (src_idecls, implicit_imports ++ ordinary_imps, mod) + +mkPrelImports :: ModuleName + -> SrcSpan -- Attribute the "import Prelude" to this location + -> Bool -> [LImportDecl RdrName] + -> [LImportDecl RdrName] +-- Consruct the implicit declaration "import Prelude" (or not) +-- +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. +mkPrelImports this_mod loc implicit_prelude import_decls + | this_mod == pRELUDE_NAME + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + where + explicit_prelude_import + = notNull [ () | L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing }) + <- import_decls + , unLoc mod == pRELUDE_NAME ] + + preludeImportDecl :: LImportDecl RdrName + preludeImportDecl + = L loc $ ImportDecl { ideclSourceSrc = Nothing, + ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = False, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } + +parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a +parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptionsFromFile :: DynFlags + -> FilePath -- ^ Input file + -> IO [Located String] -- ^ Parsed options, if any. +getOptionsFromFile dflags filename + = Exception.bracket + (openBinaryFile filename ReadMode) + (hClose) + (\handle -> do + opts <- fmap (getOptions' dflags) + (lazyGetToks dflags' filename handle) + seqList opts $ return opts) + where -- We don't need to get haddock doc tokens when we're just + -- getting the options from pragmas, and lazily lexing them + -- correctly is a little tricky: If there is "\n" or "\n-" + -- left at the end of a buffer then the haddock doc may + -- continue past the end of the buffer, despite the fact that + -- we already have an apparently-complete token. + -- We therefore just turn Opt_Haddock off when doing the lazy + -- lex. + dflags' = gopt_unset dflags Opt_Haddock + +blockSize :: Int +-- blockSize = 17 -- for testing :-) +blockSize = 1024 + +lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] +lazyGetToks dflags filename handle = do + buf <- hGetStringBufferBlock handle blockSize + unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize + where + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = do + case unP (lexer False return) state of + POk state' t -> do + -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) + if atEnd (buffer state') && not eof + -- if this token reached the end of the buffer, and we haven't + -- necessarily read up to the end of the file, then the token might + -- be truncated, so read some more of the file and lex it again. + then getMore handle state size + else case t of + L _ ITeof -> return [t] + _other -> do rest <- lazyLexBuf handle state' eof size + return (t : rest) + _ | not eof -> getMore handle state size + | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] + -- parser assumes an ITeof sentinel at the end + + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do + -- pprTrace "getMore" (text (show (buffer state))) (return ()) + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do + newbuf <- appendStringBuffers (buffer state) nextbuf + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size + + +getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] +getToks dflags filename buf = lexAll (pragState dflags buf loc) + where + loc = mkRealSrcLoc (mkFastString filename) 1 1 + + lexAll state = case unP (lexer False return) state of + POk _ t@(L _ ITeof) -> [t] + POk state' t -> t : lexAll state' + _ -> [L (RealSrcSpan (last_loc state)) ITeof] + + +-- | Parse OPTIONS and LANGUAGE pragmas of the source file. +-- +-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) +getOptions :: DynFlags + -> StringBuffer -- ^ Input Buffer + -> FilePath -- ^ Source filename. Used for location info. + -> [Located String] -- ^ Parsed options. +getOptions dflags buf filename + = getOptions' dflags (getToks dflags filename buf) + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: DynFlags + -> [Located Token] -- Input buffer + -> [Located String] -- Options. +getOptions' dflags toks + = parseToks toks + where + getToken (L _loc tok) = tok + getLoc (L loc _tok) = loc + + parseToks (open:close:xs) + | IToptions_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) (words str) ++ + parseToks xs + parseToks (open:close:xs) + | ITinclude_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) ["-#include",removeSpaces str] ++ + parseToks xs + parseToks (open:close:xs) + | ITdocOptions str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] + ++ parseToks xs + parseToks (open:xs) + | ITdocOptionsOld str <- getToken open + = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] + ++ parseToks xs + parseToks (open:xs) + | ITlanguage_prag <- getToken open + = parseLanguage xs + parseToks _ = [] + parseLanguage (L loc (ITconid fs):rest) + = checkExtension dflags (L loc fs) : + case rest of + (L _loc ITcomma):more -> parseLanguage more + (L _loc ITclose_prag):more -> parseToks more + (L loc _):_ -> languagePragParseError dflags loc + [] -> panic "getOptions'.parseLanguage(1) went past eof token" + parseLanguage (tok:_) + = languagePragParseError dflags (getLoc tok) + parseLanguage [] + = panic "getOptions'.parseLanguage(2) went past eof token" + +----------------------------------------------------------------------------- + +-- | Complain about non-dynamic flags in OPTIONS pragmas. +-- +-- Throws a 'SourceError' if the input list is non-empty claiming that the +-- input flags are unknown. +checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () +checkProcessArgsResult dflags flags + = when (notNull flags) $ + liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags + where mkMsg (L loc flag) + = mkPlainErrMsg dflags loc $ + (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> + text flag) + +----------------------------------------------------------------------------- + +checkExtension :: DynFlags -> Located FastString -> Located String +checkExtension dflags (L l ext) +-- Checks if a given extension is valid, and if so returns +-- its corresponding flag. Otherwise it throws an exception. + = let ext' = unpackFS ext in + if ext' `elem` supportedLanguagesAndExtensions + then L l ("-X"++ext') + else unsupportedExtnError dflags l ext' + +languagePragParseError :: DynFlags -> SrcSpan -> a +languagePragParseError dflags loc = + throw $ mkSrcErr $ unitBag $ + (mkPlainErrMsg dflags loc $ + vcat [ text "Cannot parse LANGUAGE pragma" + , text "Expecting comma-separated list of language options," + , text "each starting with a capital letter" + , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]) + +unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a +unsupportedExtnError dflags loc unsup = + throw $ mkSrcErr $ unitBag $ + mkPlainErrMsg dflags loc $ + text "Unsupported extension: " <> text unsup $$ + if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) + where + suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions + + +optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs dflags unhandled_flags flags_lines _filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = + ErrUtils.mkPlainErrMsg dflags flagSpan $ + text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag + diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs new file mode 100644 index 00000000..fd25e330 --- /dev/null +++ b/compiler/main/Hooks.hs @@ -0,0 +1,85 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* +-- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES +-- stuff in compiler/ghc.mk makes DynFlags link to too much stuff + +module Hooks ( Hooks + , emptyHooks + , lookupHook + , getHooked + -- the hooks: + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileOneShotHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runQuasiQuoteHook + , runRnSpliceHook + , getValueSafelyHook + ) where + +import DynFlags +import HsTypes +import Name +import PipelineMonad +import HscTypes +import HsDecls +import HsBinds +import HsExpr +import OrdList +import Id +import TcRnTypes +import Bag +import RdrName +import CoreSyn +import BasicTypes +import Type +import SrcLoc + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing + Nothing + +data Hooks = Hooks + { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) + , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv) + , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus) + , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue) + , ghcPrimIfaceHook :: Maybe ModIface + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) + , runMetaHook :: Maybe (MetaHook TcM) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) + , runQuasiQuoteHook :: Maybe (HsQuasiQuote Name -> RnM (HsQuasiQuote Name)) + , runRnSpliceHook :: Maybe (LHsExpr Name -> RnM (LHsExpr Name)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) + } + +getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a +getHooked hook def = fmap (lookupHook hook def) getDynFlags + +lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a +lookupHook hook def = fromMaybe def . hook . hooks diff --git a/compiler/main/Hooks.hs-boot b/compiler/main/Hooks.hs-boot new file mode 100644 index 00000000..280de320 --- /dev/null +++ b/compiler/main/Hooks.hs-boot @@ -0,0 +1,5 @@ +module Hooks where + +data Hooks + +emptyHooks :: Hooks diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs new file mode 100644 index 00000000..ecc4a299 --- /dev/null +++ b/compiler/main/HscMain.hs @@ -0,0 +1,1727 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "DriverPipeline". +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- Warning messages are dealt with consistently throughout this API: +-- during compilation warnings are collected, and before any function +-- in @HscMain@ returns, the warnings are either printed, or turned +-- into a real compialtion error if the @-Werror@ flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module HscMain + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Messager, batchMsg + , HscStatus (..) + , hscCompileOneShot + , hscCompileCmmFile + , hscCompileCore + + , genericHscCompileGetFrontendResult + + , genModDetails + , hscSimpleIface + , hscWriteIface + , hscNormalIface + , hscGenHardCode + , hscInteractive + + -- * Running passes separately + , hscParse + , hscTypecheckRename + , hscDesugar + , makeSimpleIface + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscCheckSafe + , hscGetSafe +#ifdef GHCI + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscStmtWithLocation + , hscDecls, hscDeclsWithLocation + , hscTcExpr, hscImport, hscKcType + , hscCompileCoreExpr + -- * Low-level exports for hooks + , hscCompileCoreExpr' +#endif + -- We want to make sure that we export enough to be able to redefine + -- hscFileFrontEnd in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule' + , getHscEnv + , hscSimpleIface', hscNormalIface' + , oneShotMsg + , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats + ) where + +#ifdef GHCI +import Id +import BasicTypes ( HValue ) +import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import Linker +import CoreTidy ( tidyExpr ) +import Type ( Type ) +import PrelNames +import {- Kind parts of -} Type ( Kind ) +import CoreLint ( lintInteractiveExpr ) +import DsMeta ( templateHaskellNames ) +import VarEnv ( emptyTidyEnv ) +import Panic +import ConLike + +import GHC.Exts +#endif + +import Module +import Packages +import RdrName +import HsSyn +import CoreSyn +import StringBuffer +import Parser +import Lexer +import SrcLoc +import TcRnDriver +import TcIface ( typecheckIface ) +import TcRnMonad +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo +import MkIface +import Desugar +import SimplCore +import TidyPgm +import CorePrep +import CoreToStg ( coreToStg ) +import qualified StgCmm ( codeGen ) +import StgSyn +import CostCentre +import ProfInit +import TyCon +import Name +import SimplStg ( stg2stg ) +import Cmm +import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables +import CmmPipeline +import CmmInfo +import CodeOutput +import NameEnv ( emptyNameEnv ) +import NameSet ( emptyNameSet ) +import InstEnv +import FamInstEnv +import Fingerprint ( Fingerprint ) +import Hooks + +import DynFlags +import ErrUtils + +import Outputable +import HscStats ( ppSourceStats ) +import HscTypes +import FastString +import UniqFM ( emptyUFM ) +import UniqSupply +import Bag +import Exception +import qualified Stream +import Stream (Stream) + +import Util + +import Data.List +import Control.Monad +import Data.Maybe +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import qualified Data.Map as Map + +#include "HsVersions.h" + + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do + eps_var <- newIORef initExternalPackageState + us <- mkSplitUniqSupply 'r' + nc_var <- newIORef (initNameCache us knownKeyNames) + fc_var <- newIORef emptyUFM + mlc_var <- newIORef emptyModuleEnv + return HscEnv { hsc_dflags = dflags, + hsc_targets = [], + hsc_mod_graph = [], + hsc_IC = emptyInteractiveContext dflags, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_type_env_var = Nothing } + + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, +knownKeyNames = -- where templateHaskellNames are defined + map getName wiredInThings + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif + +-- ----------------------------------------------------------------------------- + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + +-- | Throw some errors. +throwErrors :: ErrorMessages -> Hsc a +throwErrors = liftIO . throwIO . mkSrcErr + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO ioA + logWarnings warns + case mb_r of + Nothing -> throwErrors errs + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +#ifdef GHCI +hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } +#endif + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } + +#ifdef GHCI +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +#endif + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary = do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + liftIO $ showPass dflags "Parser" + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + + case unP parseModule (mkPState dflags buf loc) of + PFailed span err -> + liftIO $ throwOneError (mkPlainErrMsg dflags span err) + + POk pst rdr_module -> do + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ + ppr rdr_module + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ + ppSourceStats False rdr_module + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (elimiante differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . (isPrefixOf "<")) + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + return HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2, + hpm_annotations + = (Map.fromListWith (++) $ annotations pst, + Map.fromList $ ((noSrcSpan,comment_q pst) + :(annotations_comments pst))) + } + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe LHsDocString)) + +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do + tc_result <- tcRnModule' hsc_env mod_summary True rdr_module + + -- This 'do' is in the Maybe monad! + let rn_info = do decl <- tcg_rn_decls tc_result + let imports = tcg_rn_imports tc_result + exports = tcg_rn_exports tc_result + doc_hdr = tcg_doc_hdr tc_result + return (decl,imports,exports,doc_hdr) + + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' hsc_env sum save_rn_syntax mod = do + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + + tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) + dflags <- getDynFlags + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res emptyBag + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (warnSafeOnLoc dflags) $ errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') + False -> return () + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + + -- always check -Werror after desugaring, this is the last opportunity for + -- warnings to arise before the backend. + handleWarnings + return r + +-- | Make a 'ModIface' from the results of typechecking. Used when +-- not optimising, and the interface doesn't need to contain any +-- unfoldings or other cross-module optimisation info. +-- ToDo: the old interface is only needed to get the version numbers, +-- we should use fingerprint versions instead. +makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails + -> IO (ModIface,Bool) +makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do + safe_mode <- hscGetSafeMode tc_result + ioMsgMaybe $ do + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode + details tc_result + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +It's the task of the compilation proper to compile Haskell, hs-boot and core +files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all +(the module is still parsed and type-checked. This feature is mostly used by +IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', +'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () + +genericHscCompileGetFrontendResult :: + Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint)) + +genericHscCompileGetFrontendResult + always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index + = do + + let msg what = case mHscMessage of + Just hscMessage -> hscMessage hsc_env mod_index what mod_summary + Nothing -> return () + + skip iface = do + msg UpToDate + return $ Left iface + + compile mb_old_hash reason = do + msg reason + tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary + return $ Right (tc_result, mb_old_hash) + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + case m_tc_result of + Just tc_result + | not always_do_basic_recompilation_check -> + return $ Right (tc_result, Nothing) + _ -> do + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + checkOldIface hsc_env mod_summary + source_modified mb_old_iface + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap mi_iface_hash mb_checked_iface + + case mb_checked_iface of + Just iface | not (recompileRequired recomp_reqd) -> + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (#481) and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + case m_tc_result of + Nothing + | mi_used_th iface && not stable -> + compile mb_old_hash (RecompBecause "TH") + _ -> + skip iface + _ -> + case m_tc_result of + Nothing -> compile mb_old_hash recomp_reqd + Just tc_result -> + return $ Right (tc_result, mb_old_hash) + +genericHscFrontend :: ModSummary -> Hsc TcGblEnv +genericHscFrontend mod_summary = + getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) + +genericHscFrontend' :: ModSummary -> Hsc TcGblEnv +genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +hscCompileOneShot :: HscEnv + -> ModSummary + -> SourceModified + -> IO HscStatus +hscCompileOneShot env = + lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env + +-- Compile Haskell/boot in OneShot mode. +hscCompileOneShot' :: HscEnv + -> ModSummary + -> SourceModified + -> IO HscStatus +hscCompileOneShot' hsc_env mod_summary src_changed + = do + -- One-shot mode needs a knot-tying mutable variable for interface + -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. + type_env_var <- newIORef emptyNameEnv + let mod = ms_mod mod_summary + hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + + msg what = oneShotMsg hsc_env' what + + skip = do msg UpToDate + dumpIfaceStats hsc_env' + return HscUpToDate + + compile mb_old_hash reason = runHsc hsc_env' $ do + liftIO $ msg reason + tc_result <- genericHscFrontend mod_summary + guts0 <- hscDesugar' (ms_location mod_summary) tc_result + dflags <- getDynFlags + case hscTarget dflags of + HscNothing -> do + when (gopt Opt_WriteInterface dflags) $ liftIO $ do + (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed mod_summary + return HscNotGeneratingCode + _ -> + case ms_hsc_src mod_summary of + t | isHsBootOrSig t -> + do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash + liftIO $ hscWriteIface dflags iface changed mod_summary + return (case t of + HsBootFile -> HscUpdateBoot + HsigFile -> HscUpdateSig + HsSrcFile -> panic "hscCompileOneShot Src") + _ -> + do guts <- hscSimplify' guts0 + (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash + liftIO $ hscWriteIface dflags iface changed mod_summary + return $ HscRecomp cgguts mod_summary + + -- XXX This is always False, because in one-shot mode the + -- concept of stability does not exist. The driver never + -- passes SourceUnmodifiedAndStable in here. + stable = case src_changed of + SourceUnmodifiedAndStable -> True + _ -> False + + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + checkOldIface hsc_env' mod_summary src_changed Nothing + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap mi_iface_hash mb_checked_iface + + case mb_checked_iface of + Just iface | not (recompileRequired recomp_reqd) -> + -- If the module used TH splices when it was last compiled, + -- then the recompilation check is not accurate enough (#481) + -- and we must ignore it. However, if the module is stable + -- (none of the modules it depends on, directly or indirectly, + -- changed), then we *can* skip recompilation. This is why + -- the SourceModified type contains SourceUnmodifiedAndStable, + -- and it's pretty important: otherwise ghc --make would + -- always recompile TH modules, even if nothing at all has + -- changed. Stability is just the same check that make is + -- doing for us in one-shot mode. + if mi_used_th iface && not stable + then compile mb_old_hash (RecompBecause "TH") + else skip + _ -> + compile mb_old_hash recomp_reqd + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceCheck hsc_env (typecheckIface old_iface) + dumpIfaceStats hsc_env + return new_details + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: HscEnv -> RecompileRequired -> IO () +oneShotMsg hsc_env recomp = + case recomp of + UpToDate -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _ -> + return () + +batchMsg :: Messager +batchMsg hsc_env mod_index recomp mod_summary = + case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + where + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ + (showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason + +-------------------------------------------------------------- +-- FrontEnds +-------------------------------------------------------------- + +hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv +hscFileFrontEnd mod_summary = do + hpm <- hscParse' mod_summary + hsc_env <- getHscEnv + tcg_env <- tcRnModule' hsc_env mod_summary False hpm + return tcg_env + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic aproach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and +-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports dflags tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns dflags rules = listToBag $ map (warnRules dflags) rules + warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = + mkPlainWarnMsg dflags loc $ + text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ + text "User defined rules are disabled under Safe Haskell" + +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external pacakge +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- RnNames.rnImportDecl for where package trust dependencies for a module are +-- collected and unioned. Specifically see the Note [RnNames . Tracking Trust +-- Transitively] and the Note [RnNames . Trust Own Package]. +checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv +checkSafeImports dflags tcg_env + = do + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getWarnings + clearWarnings + + -- Check safe imports are correct + safePkgs <- mapM checkSafe safeImps + safeErrs <- getWarnings + clearWarnings + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, []) + True -> do infPkgs <- mapM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs + let newTrust = pkgTrustReqs safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [PackageKey] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "HscMain.condense: Pattern match failure!" + condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs + return (m, l, s) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1@(m1,_,l1,s1) (_,_,_,s2) + | s1 /= s2 + = throwErrors $ unitBag $ mkPlainErrMsg dflags l1 + (text "Module" <+> ppr m1 <+> + (text $ "is imported both as a safe and unsafe import!")) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs req inf infPassed | safeInferOn dflags + && safeHaskell dflags == Sf_None && infPassed + = emptyImportAvails { + imp_trust_pkgs = catMaybes req ++ catMaybes inf + } + pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' dflags m l + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs + errs <- getWarnings + return $ isEmptyBag errs + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey]) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + (self, pkgs) <- hscCheckSafe' dflags m l + good <- isEmptyBag `fmap` getWarnings + clearWarnings -- don't want them printed... + let pkgs' | Just p <- self = p:pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey]) +hscCheckSafe' dflags m l = do + (tw, pkgs) <- isModSafe m l + case tw of + False -> return (Nothing, pkgs) + True | isHomePkg m -> return (Nothing, pkgs) + | otherwise -> return (Just $ modulePackageKey m, pkgs) + where + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey]) + isModSafe m l = do + iface <- lookup' m + case iface of + -- can't load iface to check trust! + Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted trust trust_own_pkg m + -- pkg trust reqs + pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface' + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyBag + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logWarnings errs + return (trust == Sf_Trustworthy, pkgRs) + + where + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (modulePackageKey m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] + + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness. + packageTrusted _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True + packageTrusted _ _ m + | isHomePkg m = True + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m +#ifdef GHCI + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' +#else + return iface +#endif + + + isHomePkg :: Module -> Bool + isHomePkg m + | thisPackage dflags == modulePackageKey m = True + | otherwise = False + +-- | Check the list of packages are trusted. +checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc () +checkPkgTrust dflags pkgs = + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + where + errors = catMaybes $ map go pkgs + go pkg + | trusted $ getPackageDetails dflags pkg + = Nothing + | otherwise + = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags) + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" + +-- | Set module to unsafe and (potentially) wipe trust information. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + when (wopt Opt_WarnUnsafe dflags) + (logWarnings $ unitBag $ + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + + liftIO $ writeIORef (tcg_safeInfer tcg_env) False + -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case safeHaskell dflags == Sf_None of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concat $ map badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't allowed in Safe Haskell"] + | otherwise = [] + + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +hscSimplify :: HscEnv -> ModGuts -> IO ModGuts +hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts + +hscSimplify' :: ModGuts -> Hsc ModGuts +hscSimplify' ds_result = do + hsc_env <- getHscEnv + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +hscSimpleIface :: HscEnv + -> TcGblEnv + -> Maybe Fingerprint + -> IO (ModIface, Bool, ModDetails) +hscSimpleIface hsc_env tc_result mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface + +hscSimpleIface' :: TcGblEnv + -> Maybe Fingerprint + -> Hsc (ModIface, Bool, ModDetails) +hscSimpleIface' tc_result mb_old_iface = do + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result + (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + ioMsgMaybe $ + mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, no_change, details) + +hscNormalIface :: HscEnv + -> ModGuts + -> Maybe Fingerprint + -> IO (ModIface, Bool, ModDetails, CgGuts) +hscNormalIface hsc_env simpl_result mb_old_iface = + runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface + +hscNormalIface' :: ModGuts + -> Maybe Fingerprint + -> Hsc (ModIface, Bool, ModDetails, CgGuts) +hscNormalIface' simpl_result mb_old_iface = do + hsc_env <- getHscEnv + (cg_guts, details) <- {-# SCC "CoreTidy" #-} + liftIO $ tidyProgram hsc_env simpl_result + + -- BUILD THE NEW ModIface and ModDetails + -- and emit external core if necessary + -- This has to happen *after* code gen so that the back-end + -- info has been set. Not yet clear if it matters waiting + -- until after code output + (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + ioMsgMaybe $ + mkIface hsc_env mb_old_iface details simpl_result + + liftIO $ dumpIfaceStats hsc_env + + -- Return the prepared code. + return (new_iface, no_change, details, cg_guts) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- + +hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO () +hscWriteIface dflags iface no_change mod_summary = do + let ifaceFile = ml_hi_file (ms_location mod_summary) + unless no_change $ + {-# SCC "writeIface" #-} + writeIfaceFile dflags ifaceFile iface + whenGeneratingDynamicToo dflags $ do + -- TODO: We should do a no_change check for the dynamic + -- interface file too + -- TODO: Should handle the dynamic hi filename properly + let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags) + dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile + dynDflags = dynamicTooMkDynamicDynFlags dflags + writeIfaceFile dynDflags dynIfaceFile' iface + +-- | Compile to hard-code. +hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath + -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f +hscGenHardCode hsc_env cgguts mod_summary output_filename = do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts + dflags = hsc_dflags hsc_env + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env location core_binds data_tycons ; + ----------------- Convert to STG ------------------ + (stg_binds, cost_centre_info) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags this_mod prepd_binds + + let prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + + ------------------ Code generation ------------------ + + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so showPass isn't very useful here. + -- Hence we have one showPass for the whole backend, the + -- next showPass after this will be "Assembler". + showPass dflags "CodeGen" + + cmms <- {-# SCC "StgCmm" #-} + doCodeGen hsc_env this_mod data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + cmmToRawCmm dflags cmms + + let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" + (ppr a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + (output_filename, (_stub_h_exists, stub_c_exists)) + <- {-# SCC "codeOutput" #-} + codeOutput dflags this_mod output_filename location + foreign_stubs dependencies rawcmms1 + return (output_filename, stub_c_exists) + + +hscInteractive :: HscEnv + -> CgGuts + -> ModSummary + -> IO (Maybe FilePath, CompiledByteCode, ModBreaks) +#ifdef GHCI +hscInteractive hsc_env cgguts mod_summary = do + let dflags = hsc_dflags hsc_env + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks } = cgguts + + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env location core_binds data_tycons + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks + ------------------ Create f-x-dynamic C-side stuff --- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (istub_c_exists, comp_bc, mod_breaks) +#else +hscInteractive _ _ = panic "GHC not compiled with interpreter" +#endif + +------------------------------ + +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + us <- mkSplitUniqSupply 'S' + let initTopSRT = initUs_ us emptySRT + dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm) + (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm + rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) + _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms + return () + where + no_mod = panic "hscCmmFile: no_mod" + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCmmFile: no hi file", + ml_obj_file = panic "hscCmmFile: no obj file" } + +-------------------- Stuff for new code gen --------------------- + +doCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [StgBinding] + -> HpcInfo + -> IO (Stream IO CmmGroup ()) + -- Note we produce a 'Stream' of CmmGroups, so that the + -- backend can be run incrementally. Otherwise it generates all + -- the C-- up front, which has a significant space cost. +doCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = do + let dflags = hsc_dflags hsc_env + + let cmm_stream :: Stream IO CmmGroup () + cmm_stream = {-# SCC "StgCmm" #-} + StgCmm.codeGen dflags this_mod data_tycons + cost_centre_info stg_binds hpc_info + + -- codegen consumes a stream of CmmGroup, and produces a new + -- stream of CmmGroup (not necessarily synchronised: one + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm + "Cmm produced by new codegen" (ppr a) + return a + + ppr_stream1 = Stream.mapM dump1 cmm_stream + + -- We are building a single SRT for the entire module, so + -- we must thread it through all the procedures as we cps-convert them. + us <- mkSplitUniqSupply 'S' + + -- When splitting, we generate one SRT per split chunk, otherwise + -- we generate one SRT for the whole module. + let + pipeline_stream + | gopt Opt_SplitObjs dflags + = {-# SCC "cmmPipeline" #-} + let run_pipeline us cmmgroup = do + let (topSRT', us') = initUs us emptySRT + (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup + let srt | isEmptySRT topSRT = [] + | otherwise = srtToData topSRT + return (us', srt ++ cmmgroup) + + in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 + return () + + | otherwise + = {-# SCC "cmmPipeline" #-} + let initTopSRT = initUs_ us emptySRT + run_pipeline = cmmPipeline hsc_env + in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 + Stream.yield (srtToData topSRT) + + let + dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a + return a + + ppr_stream2 = Stream.mapM dump2 pipeline_stream + + return ppr_stream2 + + + +myCoreToStg :: DynFlags -> Module -> CoreProgram + -> IO ( [StgBinding] -- output program + , CollectedCCs) -- cost centre info (declared and used) +myCoreToStg dflags this_mod prepd_binds = do + stg_binds + <- {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod prepd_binds + + (stg_binds2, cost_centre_info) + <- {-# SCC "Stg2Stg" #-} + stg2stg dflags this_mod stg_binds + + return (stg_binds2, cost_centre_info) + + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes +-} + +#ifdef GHCI +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO (Maybe ([Id], IO [HValue], FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + -- Rename and typecheck it + hsc_env <- getHscEnv + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisPackageKey + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + let hval_io = unsafeCoerce# hval :: IO [HValue] + + return $ Just (ids, hval_io, fix_env) + +-- | Compile a decls +hscDecls :: HscEnv + -> String -- ^ The statement + -> IO ([TyThing], InteractiveContext) +hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 + +-- | Compile a decls +hscDeclsWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ([TyThing], InteractiveContext) +hscDeclsWithLocation hsc_env0 str source linenumber = + runInteractiveHsc hsc_env0 $ do + L _ (HsModule{ hsmodDecls = decls }) <- + hscParseThingWithLocation source linenumber parseModule str + + {- Rename and typecheck it -} + hsc_env <- getHscEnv + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"} + ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv + + {- Simplify -} + simpl_mg <- liftIO $ hscSimplify hsc_env ds_result + + {- Tidy -} + (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + + let dflags = hsc_dflags hsc_env + !CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_modBreaks = mod_breaks } = tidy_cg + + !ModDetails { md_insts = cls_insts + , md_fam_insts = fam_insts } = mod_details + -- Get the *tidied* cls_insts and fam_insts + + data_tycons = filter isDataTyCon tycons + + {- Prepare For Code Generation -} + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons + + {- Generate byte code -} + cbc <- liftIO $ byteCodeGen dflags this_mod + prepd_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + liftIO $ linkDecls hsc_env src_span cbc + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by TidyPgm), since those are the only ones + -- that might be referenced elsewhere. + -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes + -- Implicit Ids are implicit in tcs + + tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + + let icontext = hsc_IC hsc_env + ictxt = extendInteractiveContext icontext ext_ids tcs + cls_insts fam_insts defaults patsyns + return (tythings, ictxt) + +hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + ptext (sLit "parse error in import declaration") + +-- | Typecheck an expression (but don't run it) +-- Returns its most general type +hscTcExpr :: HscEnv + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt expr _ _ _)) -> + ioMsgMaybe $ tcRnExpr hsc_env expr + _ -> + throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +-- | Find the kind of a type +-- Currently this does *not* generalise the kinds of the type +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env normalise ty + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt RdrName)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType RdrName) +hscParseType = hscParseThing parseType +#endif + +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 + +hscParseThingWithLocation :: (Outputable thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str + = {-# SCC "Parser" #-} do + dflags <- getDynFlags + liftIO $ showPass dflags "Parser" + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (mkPState dflags buf loc) of + PFailed span err -> do + let msg = mkPlainErrMsg dflags span err + throwErrors $ unitBag msg + + POk pst thing -> do + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) + return thing + +hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary + -> CoreProgram -> FilePath -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename + = runHsc hsc_env $ do + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) + (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing + liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary + _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename + return () + + where + maybe_simplify mod_guts | simplify = hscSimplify' mod_guts + | otherwise = return mod_guts + +-- Makes a "vanilla" ModGuts. +mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts +mkModGuts mod safe binds = + ModGuts { + mg_module = mod, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_used_th = False, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_tcs = [], + mg_insts = [], + mg_fam_insts = [], + mg_patsyns = [], + mg_rules = [], + mg_vect_decls = [], + mg_binds = binds, + mg_foreign = NoStubs, + mg_warns = NoWarnings, + mg_anns = [], + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv, + mg_safe_haskell = safe, + mg_trust_pkg = False, + mg_dependent_files = [] + } + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +#ifdef GHCI +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr hsc_env = + lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr' hsc_env srcspan ds_expr + | rtsIsProfiled + = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler") + -- Otherwise you get a seg-fault when you run it + + | otherwise + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr dflags ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos + + ; return hval } +#endif + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- readIORef (hsc_EPS hsc_env) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags + + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> String +showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs new file mode 100644 index 00000000..d32f6196 --- /dev/null +++ b/compiler/main/HscStats.hs @@ -0,0 +1,175 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- +module HscStats ( ppSourceStats ) where + +import Bag +import HsSyn +import Outputable +import RdrName +import SrcLoc +import Util + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = sum7 (map import_info imports) + (data_constrs, data_derivs) + = sum2 (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = sum2 (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = sum5 (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = sum5 (map sig_info sigs) + + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info + qual_info False = 0 + qual_info True = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs + , dd_derivs = derivs}}) + = (length cs, case derivs of Nothing -> 0 + Just (L _ ds) -> length ds) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map unLoc $ bagToList (tcdMeths decl) + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) + class_info _ = (0,0) + + inst_info (TyFamInstD {}) = (0,0,0,1,0) + inst_info (DataFamInstD {}) = (0,0,0,0,1) + inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths + , cid_sigs = inst_sigs + , cid_tyfam_insts = ats + , cid_datafam_insts = adts } }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + (addpr (sum3 (map count_bind methods)), + ss, is, length ats, length adts) + where + methods = map unLoc $ bagToList inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) + + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) + diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs new file mode 100644 index 00000000..f3769a9c --- /dev/null +++ b/compiler/main/HscTypes.hs @@ -0,0 +1,2825 @@ +{- +(c) The University of Glasgow, 2006 + +\section[HscTypes]{Types for the per-module compiler} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} + +-- | Types for the per-module compiler +module HscTypes ( + -- * compilation state + HscEnv(..), hscEPS, + FinderCache, FindResult(..), ModLocationCache, + Target(..), TargetId(..), pprTarget, pprTargetId, + ModuleGraph, emptyMG, + HscStatus(..), + + -- * Hsc monad + Hsc(..), runHsc, runInteractiveHsc, + + -- * Information about modules + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedModsVal, + + ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), + + -- * Information about the module being compiled + -- (re-exported from DriverPhases) + HscSource(..), isHsBootOrSig, hscSourceString, + + + -- * State relating to modules in this package + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + hptInstances, hptRules, hptVectInfo, pprHPT, + hptObjs, + + -- * State relating to known packages + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIfaceByModule, emptyModIface, lookupHptByModule, + + PackageInstEnv, PackageFamInstEnv, PackageRuleBase, + + mkSOName, mkHsSOName, soExt, + + -- * Metaprogramming + MetaRequest(..), + MetaResult, -- data constructors not exported to ensure correct response type + metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, + MetaHook, + + -- * Annotations + prepareAnnotations, + + -- * Interactive context + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, + extendInteractiveContext, extendInteractiveContextWithIds, + substInteractiveContext, + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, + mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, + + -- * Interfaces + ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, + + -- * Fixity + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + -- * TyThings and type environments + TyThing(..), tyThingAvailInfo, + tyThingTyCon, tyThingDataCon, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, + + TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, + + -- * MonadThings + MonadThings(..), + + -- * Information on imports and exports + WhetherHasOrphans, IsBootInterface, Usage(..), + Dependencies(..), noDependencies, + NameCache(..), OrigNameCache, + IfaceExport, + + -- * Warnings + Warnings(..), WarningTxt(..), plusWarns, + + -- * Linker stuff + Linkable(..), isObjectLinkable, linkableObjs, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + + -- * Program coverage + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- * Breakpoints + ModBreaks (..), BreakIndex, emptyModBreaks, + + -- * Vectorisation information + VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, + noIfaceVectInfo, isNoIfaceVectInfo, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * result of the parser + HsParsedModule(..), + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import ByteCodeAsm ( CompiledByteCode ) +import InteractiveEvalTypes ( Resume ) +#endif + +import HsSyn +import RdrName +import Avail +import Module +import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import FamInstEnv +import Rules ( RuleBase ) +import CoreSyn ( CoreProgram ) +import Name +import NameEnv +import NameSet +import VarEnv +import VarSet +import Var +import Id +import IdInfo ( IdDetails(..) ) +import Type + +import ApiAnnotation ( ApiAnns ) +import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) +import Packages hiding ( Version(..) ) +import DynFlags +import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString ) +import BasicTypes +import IfaceSyn +import CoreSyn ( CoreRule, CoreVect ) +import Maybes +import Outputable +import BreakArray +import SrcLoc +-- import Unique +import UniqFM +import UniqSupply +import FastString +import StringBuffer ( StringBuffer ) +import Fingerprint +import MonadUtils +import Bag +import Binary +import ErrUtils +import Platform +import Util +import Serialized ( Serialized ) + +import Control.Monad ( guard, liftM, when, ap ) +import Data.Array ( Array, array ) +import Data.IORef +import Data.Time +import Data.Word +import Data.Typeable ( Typeable ) +import Exception +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Compilation state +-- ----------------------------------------------------------------------------- + +-- | Status of a compilation to hard-code +data HscStatus + = HscNotGeneratingCode + | HscUpToDate + | HscUpdateBoot + | HscUpdateSig + | HscRecomp CgGuts ModSummary + +-- ----------------------------------------------------------------------------- +-- The Hsc monad: Passing an environment and warning state + +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + +instance Functor Hsc where + fmap = liftM + +instance Applicative Hsc where + pure = return + (<*>) = ap + +instance Monad Hsc where + return a = Hsc $ \_ w -> return (a, w) + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc hsc_env + = runHsc (hsc_env { hsc_dflags = interactive_dflags }) + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) + +-- ----------------------------------------------------------------------------- +-- Source Errors + +-- When the compiler (HscMain) discovers errors, it throws an +-- exception in the IO monad. + +mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages (SourceError msgs) = msgs + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +throwOneError :: MonadIO m => ErrMsg -> m ab +throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError ErrorMessages + deriving Typeable + +instance Show SourceError where + show (SourceError msgs) = unlines . map show . bagToList $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (ExceptionMonad m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + gcatch act (\(e :: SourceError) -> handler e) + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + deriving Typeable + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns + | gopt Opt_WarnIsError dflags + = when (not (isEmptyBag warns)) $ do + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags + | otherwise + = printBagOfErrors dflags warns + +handleFlagWarnings :: DynFlags -> [Located String] -> IO () +handleFlagWarnings dflags warns + = when (wopt Opt_WarnDeprecatedFlags dflags) $ do + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) + | L loc warn <- warns ] + + printOrThrowWarnings dflags bag + +{- +************************************************************************ +* * +\subsection{HscEnv} +* * +************************************************************************ +-} + +-- | Hscenv is like 'Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. Things like +-- the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- ^ The module graph of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- ^ As with 'hsc_EPS', this is side-effected by compiling to + -- reflect sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + -- ^ The cached result of performing finding in the file system + hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache), + -- ^ This caches the location of modules, so we don't have to + -- search the filesystem multiple times. See also 'hsc_FC'. + + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) + -- ^ Used for one-shot compilation only, to initialise + -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for + -- 'TcRunTypes.TcGblEnv' + } + +instance ContainsDynFlags HscEnv where + extractDynFlags env = hsc_dflags env + replaceDynFlags env dflags = env {hsc_dflags = dflags} + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target + = Target { + targetId :: TargetId, -- ^ module or filename + targetAllowObjCode :: Bool, -- ^ object code allowed? + targetContents :: Maybe (StringBuffer,UTCTime) + -- ^ in-memory text buffer? + } + +data TargetId + = TargetModule ModuleName + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +pprTarget :: Target -> SDoc +pprTarget (Target id obj _) = + (if obj then char '*' else empty) <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + +{- +************************************************************************ +* * +\subsection{Package and Module Tables} +* * +************************************************************************ +-} + +-- | Helps us find information about modules in the home package +type HomePackageTable = ModuleNameEnv HomeModInfo + -- Domain = modules in the home package that have been fully compiled + -- "home" package key cached here for convenience + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty HomePackageTable +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUFM + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +pprHPT :: HomePackageTable -> SDoc +-- A bit aribitrary for now +pprHPT hpt + = vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- eltsUFM hpt ] + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupUFM hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-- | Information about modules in the package being compiled +data HomeModInfo + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: DynFlags + -> HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule _dflags hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package +-- of its own, but it doesn't seem worth the bother. + + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances hsc_env want_this_module + = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do + guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + in (concat insts, concat famInsts) + +-- | Get the combined VectInfo of all modules in the home package table. In +-- contrast to instances and rules, we don't care whether the modules are +-- "below" us in the dependency sense. The VectInfo of those modules not "below" +-- us does not affect the compilation of the current module. +hptVectInfo :: HscEnv -> VectInfo +hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details) + +-- | Get rules from modules "below" this one (in the dependency sense) +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] +hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + + +-- | Get annotations from modules "below" this one (in the dependency sense) +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + +hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] +hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env)) + +-- | Get things from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + + | otherwise + = let hpt = hsc_HPT hsc_env + in + [ thing + | -- Find each non-hi-boot module below me + (mod, is_boot_mod) <- deps + , include_hi_boot || not is_boot_mod + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + + -- Look it up in the HPT + , let things = case lookupUFM hpt mod of + Just info -> extract info + Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] + msg = vcat [ptext (sLit "missing module") <+> ppr mod, + ptext (sLit "Probable cause: out-of-date interface files")] + -- This really shouldn't happen, but see Trac #962 + + -- And get its dfuns + , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) + +{- +************************************************************************ +* * +\subsection{Metaprogramming} +* * +************************************************************************ +-} + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr RdrName -> MetaResult) + | MetaP (LPat RdrName -> MetaResult) + | MetaT (LHsType RdrName -> MetaResult) + | MetaD ([LHsDecl RdrName] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE { unMetaResE :: LHsExpr RdrName } + | MetaResP { unMetaResP :: LPat RdrName } + | MetaResT { unMetaResT :: LHsType RdrName } + | MetaResD { unMetaResD :: [LHsDecl RdrName] } + | MetaResAW { unMetaResAW :: Serialized } + +type MetaHook f = MetaRequest -> LHsExpr Id -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsExpr RdrName) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr Id -> f (LPat RdrName) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsType RdrName) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr Id -> f [LHsDecl RdrName] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr Id -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + +{- +************************************************************************ +* * +\subsection{Dealing with Annotations} +* * +************************************************************************ +-} + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + return ann_env + +{- +************************************************************************ +* * +\subsection{The Finder cache} +* * +************************************************************************ +-} + +-- | The 'FinderCache' maps home module names to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +-- Although the @FinderCache@ range is 'FindResult' for convenience, +-- in fact it will only ever contain 'Found' or 'NotFound' entries. +-- +type FinderCache = ModuleNameEnv FindResult + +-- | The result of searching for an imported module. +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage PackageKey + -- ^ The requested package was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [PackageKey] -- Module is in these packages, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages, + -- but the *package* is hidden + + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules + } + +-- | Cache that remembers where we found a particular module. Contains both +-- home modules and package modules. On @:load@, only home modules are +-- purged from this cache. +type ModLocationCache = ModuleEnv ModLocation + +{- +************************************************************************ +* * +\subsection{Symbol tables and Module details} +* * +************************************************************************ +-} + +-- | A 'ModIface' plus a 'ModDetails' summarises everything we know +-- about a compiled module. The 'ModIface' is the stuff *before* linking, +-- and can be written out to an interface file. The 'ModDetails is after +-- linking and can be completely recovered from just the 'ModIface'. +-- +-- When we read an interface file, we also construct a 'ModIface' from it, +-- except that we explicitly make the 'mi_decls' and a few other fields empty; +-- as when reading we consolidate the declarations etc. into a number of indexed +-- maps and environments in the 'ExternalPackageState'. +data ModIface + = ModIface { + mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? + mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface + mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only + mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags + -- used when compiling this module + + mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans + mi_finsts :: !WhetherHasFamInst, -- ^ Whether this module has family instances + mi_boot :: !IsBootInterface, -- ^ Read from an hi-boot file? + + mi_deps :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + + mi_usages :: [Usage], + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + mi_exports :: ![IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + mi_exp_hash :: !Fingerprint, + -- ^ Hash of export list + + mi_used_th :: !Bool, + -- ^ Module required TH splices when it was compiled. + -- This disables recompilation avoidance (see #481). + + mi_fixities :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns :: Warnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls :: [(Fingerprint,IfaceDecl)], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + mi_globals :: !(Maybe GlobalRdrEnv), + -- ^ Binds all the things defined at the top level in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains @Nothing@). + -- + -- Strictly speaking this field should live in the + -- 'HomeModInfo', but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules :: [IfaceRule], -- ^ Sorted rules + mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family + -- instances, and vectorise pragmas combined + + mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_warn_fn :: Name -> Maybe WarningTxt, -- ^ Cached lookup for 'mi_warns' + mi_fix_fn :: OccName -> Fixity, -- ^ Cached lookup for 'mi_fixities' + mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), + -- ^ Cached lookup for 'mi_decls'. + -- The @Nothing@ in 'mi_hash_fn' means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt. the old interface. + -- The 'OccName' is the parent of the name, if it has one. + + mi_hpc :: !AnyHpcUsage, + -- ^ True if this program uses Hpc at any point in the program. + + mi_trust :: !IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg :: !Bool + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [RnNames . Trust Own Package] + } + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_boot = is_boot, + mi_iface_hash= iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do + put_ bh mod + put_ bh is_boot + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh vect_info + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + put_ bh sig_of + + get bh = do + mod_name <- get bh + is_boot <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + vect_info <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + sig_of <- get bh + return (ModIface { + mi_module = mod_name, + mi_sig_of = sig_of, + mi_boot = is_boot, + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls }) + +-- | The original names declared of a certain module that are exported +type IfaceExport = AvailInfo + +-- | Constructs an empty ModIface +emptyModIface :: Module -> ModIface +emptyModIface mod + = ModIface { mi_module = mod, + mi_sig_of = Nothing, + mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_orphan = False, + mi_finsts = False, + mi_boot = False, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_exp_hash = fingerprint0, + mi_used_th = False, + mi_fixities = [], + mi_warns = NoWarnings, + mi_anns = [], + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_orphan_hash = fingerprint0, + mi_vect_info = noIfaceVectInfo, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache, + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False } + + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldr add_decl emptyOccEnv pairs + add_decl (v,d) env0 = foldr add env0 (ifaceDeclFingerprints v d) + where + add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails + = ModDetails { + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module + md_vect_info :: !VectInfo -- ^ Module vectorisation information + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails + = ModDetails { md_types = emptyTypeEnv, + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + md_anns = [], + md_vect_info = noVectInfo } + +-- | Records the modules directly imported by a module for extracting e.g. usage information +type ImportedMods = ModuleEnv [ImportedModsVal] +type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_boot :: IsBootInterface, -- ^ Whether it's an hs-boot module + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_dir_imps :: !ImportedMods, -- ^ Directly-imported modules; used to + -- generate initialisation code + mg_used_names:: !NameSet, -- ^ What the module needed (used in 'MkIface.mkIface') + + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- See Note [Overall plumbing for rules] in Rules.lhs + mg_binds :: !CoreProgram, -- ^ Bindings for this module + mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module + mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module + -- (produced by desugarer & consumed by vectoriser) + mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, + -- ^ Class instance environment from /home-package/ modules (including + -- this one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, + -- ^ Type-family instance environment for /home-package/ modules + -- (including this one); c.f. 'tcg_fam_inst_env' + mg_safe_haskell :: SafeHaskellMode, + -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, + -- ^ Do we need to trust our own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] + mg_dependent_files :: [FilePath] -- ^ dependencies from addDependentFile + } + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we we regard them + -- as part of the code-gen of tycons + + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !ModBreaks -- ^ Module breakpoints + } + +----------------------------------- +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs SDoc SDoc + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) + +{- +************************************************************************ +* * +\subsection{The interactive context} +* * +************************************************************************ + +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactivePackageKey, and +PrelNames.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at :2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-package-key says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'thisPackage' field stays as 'main' (or whatever -this-package-key says. + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds + b) with an Internal Name (not External) + c) and a tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) They start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. It would be possible subsequently to give + them an External Name (in a GhciN module) but then we'd have + to substitute it out. So for now they stay Internal. + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +However note that TyCons, Classes, and even Ids bound by other top-level +declarations in GHCi (eg foreign import, record selectors) currently get +External Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See Trac #7102 +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHC session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' and updated regularly + -- It contains everything in scope at the command line, + -- including everything in ic_tythings + + ic_instances :: ([ClsInst], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: Maybe [Type], + -- ^ The current default types, set by a 'default' declaration + +#ifdef GHCI + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts +#endif + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath + -- virtual CWD of the program + } + +data InteractiveImport + = IIDecl (ImportDecl RdrName) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, +#ifdef GHCI + ic_resume = [], +#endif + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings + +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. +extendInteractiveContext :: InteractiveContext + -> [Id] -> [TyCon] + -> [ClsInst] -> [FamInst] + -> Maybe [Type] + -> [PatSyn] + -> InteractiveContext +extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_patsyns + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (Trac #9426) + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings + , ic_instances = (new_cls_insts ++ old_cls_insts, new_fam_insts ++ old_fam_insts) + , ic_default = defaults } + where + new_tythings = map AnId ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) new_patsyns + old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt) + + -- Discard old instances that have been fully overrridden + -- See Note [Override identical instances in GHCi] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + old_fam_insts = filterOut (\i -> any (identicalFamInstHead i) new_fam_insts) fam_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +extendInteractiveContextWithIds ictxt ids + | null ids = ictxt + | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } + where + new_tythings = map AnId ids + old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt) + +shadowed_by :: [Id] -> TyThing -> Bool +shadowed_by ids = shadowed + where + shadowed id = getOccName id `elemOccSet` new_occs + new_occs = mkOccSet (map getOccName ids) + +setInteractivePackage :: HscEnv -> HscEnv +-- Set the 'thisPackage' DynFlag to 'interactive' +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } } + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + + -- ToDo: should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the GlobalRdrEnv. +icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + add thing env = extendGlobalRdrEnv True {- Shadowing please -} env + [tyThingAvailInfo thing] + -- One at a time, to ensure each shadows the previous ones + +substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + | isEmptyTvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } + where + subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id) + subst_ty tt = tt + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d + +{- +************************************************************************ +* * + Building a PrintUnqualified +* * +************************************************************************ + +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of PrintUnqualified, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing package keys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +PackageKey, the situation is different. First, the key is not a human readable +at all, so we need to consult the package database to find the appropriate +PackageId to display. Second, there may be multiple copies of a library visible +with the same PackageId, in which case we need to disambiguate. For now, +we just emit the actual package key (which the user can go look up); however, +another scheme is to (recursively) say which dependencies are different. + +NB: When we extend package keys to also have holes, we will have to disambiguate +those as well. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) + where + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual + -- If there's a unique entity that's in scope unqualified with 'occ' + -- AND that entity is the right one, then we can use the unqualified name + + | [gre] <- qual_gres + = NameQual (get_qual_mod (gre_prov gre)) + + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + right_name gre = nameModule_maybe (gre_name gre) == Just mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + get_qual_mod LocalDef = moduleName mod + get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is)) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | modulePackageKey mod == thisPackage dflags = False + + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == modulePackageKey mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a package key if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags pkg_key + | pkg_key == mainPackageKey || pkg_key == interactivePackageKey + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + +{- +************************************************************************ +* * + Implicit TyThings +* * +************************************************************************ + +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = map AnId (dataConImplicitIds dc) + -- For data cons add the worker and (possibly) wrapper + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + -- associated types + -- No extras_plus (recursive call) for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype coercion + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper + concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc) + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + +-- add a thing and recursive call +extras_plus :: TyThing -> [TyThing] +extras_plus thing = thing : implicitTyThings thing + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyCon_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext sould print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of + Just cls -> Just (ATyCon (classTyCon cls)) + Nothing -> Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = tc } -> Just (ATyCon tc) + ClassOpId cls -> Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyVars :: [TyThing] -> TyVarSet +tyThingsTyVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyVarsOfType $ tyConKind tc + ttToVarSet _ = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> AvailInfo +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + where n = getName c + Nothing -> AvailTC n (n : map getName dcs ++ + concatMap dataConFieldLabels dcs) + where n = getName t + dcs = tyConDataCons t +tyThingAvailInfo t + = Avail (getName t) + +{- +************************************************************************ +* * + TypeEnv +* * +************************************************************************ +-} + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT + = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name + where + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + +-- | As 'lookupType', but with a marginally easier-to-use interface +-- if you have a 'HscEnv' +lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) +lookupTypeHscEnv hsc_env name = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType dflags hpt (eps_PTE eps) name + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (pprTyThing other) + +{- +************************************************************************ +* * +\subsection{MonadThings and friends} +* * +************************************************************************ +-} + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +{- +************************************************************************ +* * +\subsection{Auxiliary types} +* * +************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere +-} + +------------------ Warnings ------------------------- +-- | Warning information for a module +data Warnings + = NoWarnings -- ^ Nothing deprecated + | WarnAll WarningTxt -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + deriving( Eq ) + +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + +-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' +mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName + +emptyIfaceWarnCache :: Name -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n `orElse` defaultFixity + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Fixity +emptyIfaceFixCache _ = defaultFixity + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +{- +************************************************************************ +* * +\subsection{WhatsImported} +* * +************************************************************************ +-} + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A transformation rule in a module other than the one defining +-- the function in the head of the rule +-- +-- * A vectorisation pragma +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- | Did this module originate from a *-boot file? +type IsBootInterface = Bool + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +data Dependencies + = Deps { dep_mods :: [(ModuleName, IsBootInterface)] + -- ^ All home-package modules transitively below this one + -- I.e. modules that this one imports, or that are in the + -- dep_mods of those directly-imported modules + + , dep_pkgs :: [(PackageKey, Bool)] + -- ^ All packages transitively below this module + -- I.e. packages to which this module's direct imports belong, + -- or that are in the dep_pkgs of those modules + -- The bool indicates if the package is required to be + -- trusted when the module is imported as a safe import + -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] + + , dep_orphs :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + + , dep_finsts :: [Module] + -- ^ Modules that contain family instances (whether the + -- instances are from the home or an external package) + } + deriving( Eq ) + -- Equality used only for old/new comparison in MkIface.addFingerprints + -- See 'TcRnTypes.ImportAvails' for details on dependencies. + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] [] + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe Fingerprint, + -- ^ Fingerprint for the export list of this module, + -- if we directly imported it (and hence we depend on its export list) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FilePath, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +{- +************************************************************************ +* * + The External Package State +* * +************************************************************************ +-} + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageVectInfo = VectInfo +type PackageAnnEnv = AnnEnv + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'TcRnTypes.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated + -- from all the external-package modules + eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated + -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + +{- +Names in a NameCache are always stored as a Global, and have the SrcLoc +of their binding locations. + +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. +-} + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +mkSOName :: Platform -> FilePath -> FilePath +mkSOName platform root + = case platformOS platform of + OSDarwin -> ("lib" ++ root) <.> "dylib" + OSMinGW32 -> root <.> "dll" + _ -> ("lib" ++ root) <.> "so" + +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + +soExt :: Platform -> FilePath +soExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +{- +************************************************************************ +* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +* * +************************************************************************ +-} + +-- | A ModuleGraph contains all the nodes from the home package (only). +-- There will be a node for each source module, plus a node for each hi-boot +-- module. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. +type ModuleGraph = [ModSummary] + +emptyMG :: ModuleGraph +emptyMG = [] + +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- * An external-core source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell, hs-boot or external core + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we *only* are typechecking (it is + -- 'Nothing' otherwise. + -- See Note [Recompilation checking when typechecking only] and #9243 + ms_srcimps :: [Located (ImportDecl RdrName)], + -- ^ Source imports of the module + ms_textual_imps :: [Located (ImportDecl RdrName)], + -- ^ Non-source imports of the module from the module *text* + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + -- This is a not-entirely-satisfactory means of creating an import + -- that corresponds to an import that did not occur in the program + -- text, such as those induced by the use of plugins (the -plgFoo + -- flag) + mk_additional_import mod_nm = noLoc $ ImportDecl { + ideclSourceSrc = Nothing, + ideclName = noLoc mod_nm, + ideclPkgQual = Nothing, + ideclSource = False, + ideclImplicit = True, -- Maybe implicit because not "in the program text" + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing, + ideclSafe = False + } + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> Bool +isBootSummary ms = ms_hsc_src ms == HsBootFile + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary + = showSDoc dflags $ + hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), + char '(', text (normalise $ msHsFilePath mod_summary) <> comma, + case target of + HscInterpreted | recomp + -> text "interpreted" + HscNothing -> text "nothing" + _ | HsigFile == ms_hsc_src mod_summary -> text "nothing" + | otherwise -> text (normalise $ msObjFilePath mod_summary), + char ')'] + where + mod = moduleName (ms_mod mod_summary) + mod_str = showPpr dflags mod + ++ hscSourceString' dflags mod (ms_hsc_src mod_summary) + +-- | Variant of hscSourceString which prints more information for signatures. +-- This can't live in DriverPhases because this would cause a module loop. +hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String +hscSourceString' _ _ HsSrcFile = "" +hscSourceString' _ _ HsBootFile = "[boot]" +hscSourceString' dflags mod HsigFile = + "[" ++ (maybe "abstract sig" + (("sig of "++).showPpr dflags) + (getSigOf dflags mod)) ++ "]" + -- NB: -sig-of could be missing if we're just typechecking + +{- +************************************************************************ +* * +\subsection{Recmpilation} +* * +************************************************************************ +-} + +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. + +{- +************************************************************************ +* * +\subsection{Hpc Support} +* * +************************************************************************ +-} + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? + } + +-- | This is used to signal if one of my imports used HPC instrumentation +-- even if there is no module-local HPC usage +type AnyHpcUsage = Bool + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +-- | Find out if HPC is used by this module or any of the modules +-- it depends upon +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used + +{- +************************************************************************ +* * +\subsection{Vectorisation Support} +* * +************************************************************************ + +The following information is generated and consumed by the vectorisation +subsystem. It communicates the vectorisation status of declarations from one +module to another. + +Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo +below? We need to know `f' when converting to IfaceVectInfo. However, during +vectorisation, we need to know `f_v', whose `Var' we cannot lookup based +on just the OccName easily in a Core pass. +-} + +-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also +-- documentation at 'Vectorise.Env.GlobalEnv'. +-- +-- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules, +-- which have been subsequently vectorised in the current module. +-- +data VectInfo + = VectInfo + { vectInfoVar :: VarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@ + , vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@ + , vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@ + , vectInfoParallelVars :: VarSet -- ^ set of parallel variables + , vectInfoParallelTyCons :: NameSet -- ^ set of parallel type constructors + } + +-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated +-- across module boundaries. +-- +-- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as +-- class selectors — i.e., their mappings are /not/ implicitly generated from the data types. +-- Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines +-- whether that data constructor was vectorised (or is part of an abstractly vectorised type +-- constructor). +-- +data IfaceVectInfo + = IfaceVectInfo + { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant + , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by + -- 'OccName.mkVectTyConOcc' and + -- 'OccName.mkVectDataConOcc'; the names of the + -- isomorphisms are determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here + -- coincides with the unconverted form; the name of the + -- isomorphisms is determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoParallelVars :: [Name] -- iface version of 'vectInfoParallelVar' + , ifaceVectInfoParallelTyCons :: [Name] -- iface version of 'vectInfoParallelTyCon' + } + +noVectInfo :: VectInfo +noVectInfo + = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyVarSet emptyNameSet + +plusVectInfo :: VectInfo -> VectInfo -> VectInfo +plusVectInfo vi1 vi2 = + VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) + (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) + (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) + (vectInfoParallelVars vi1 `unionVarSet` vectInfoParallelVars vi2) + (vectInfoParallelTyCons vi1 `unionNameSet` vectInfoParallelTyCons vi2) + +concatVectInfo :: [VectInfo] -> VectInfo +concatVectInfo = foldr plusVectInfo noVectInfo + +noIfaceVectInfo :: IfaceVectInfo +noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] + +isNoIfaceVectInfo :: IfaceVectInfo -> Bool +isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) + = null l1 && null l2 && null l3 && null l4 && null l5 + +instance Outputable VectInfo where + ppr info = vcat + [ ptext (sLit "variables :") <+> ppr (vectInfoVar info) + , ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info) + , ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info) + , ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info) + , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info) + ] + +instance Outputable IfaceVectInfo where + ppr info = vcat + [ ptext (sLit "variables :") <+> ppr (ifaceVectInfoVar info) + , ptext (sLit "tycons :") <+> ppr (ifaceVectInfoTyCon info) + , ptext (sLit "tycons reuse :") <+> ppr (ifaceVectInfoTyConReuse info) + , ptext (sLit "parallel vars :") <+> ppr (ifaceVectInfoParallelVars info) + , ptext (sLit "parallel tycons :") <+> ppr (ifaceVectInfoParallelTyCons info) + ] + + +instance Binary IfaceVectInfo where + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) + +{- +************************************************************************ +* * +\subsection{Safe Haskell Support} +* * +************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. +-} + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used + -- to be Sf_SafeInfered but we no longer + -- differentiate. +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) + +{- +************************************************************************ +* * +\subsection{Parser result} +* * +************************************************************************ +-} + +data HsParsedModule = HsParsedModule { + hpm_module :: Located (HsModule RdrName), + hpm_src_files :: [FilePath], + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# ' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + hpm_annotations :: ApiAnns + -- See note [Api annotations] in ApiAnnotation.hs + } + +{- +************************************************************************ +* * +\subsection{Linkable stuff} +* * +************************************************************************ + +This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = LM { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +------------------------------------------- + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode ModBreaks -- ^ A byte-code object, lives only in memory + +#ifndef GHCI +data CompiledByteCode = CompiledByteCodeUndefined +_unused :: CompiledByteCode +_unused = CompiledByteCodeUndefined +#endif + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path +#ifdef GHCI + ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos +#else + ppr (BCOs _ _) = text "No byte code" +#endif + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + +{- +************************************************************************ +* * +\subsection{Breakpoint Support} +* * +************************************************************************ +-} + +-- | Breakpoint index +type BreakIndex = Int + +-- | All the information about the breakpoints for a given module +data ModBreaks + = ModBreaks + { modBreaks_flags :: BreakArray + -- ^ The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + } + +-- | Construct an empty ModBreaks +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- ToDo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] + } diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs new file mode 100644 index 00000000..a3603057 --- /dev/null +++ b/compiler/main/InteractiveEval.hs @@ -0,0 +1,1055 @@ +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module InteractiveEval ( +#ifdef GHCI + RunResult(..), Status(..), Resume(..), History(..), + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + parseImportDecl, SingleStep(..), + resume, + abandon, abandonAll, + getResumeContext, + getHistorySpan, + getModBreaks, + getHistoryModule, + back, forward, + setContext, getContext, + availsToGlobalRdrEnv, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + showModule, + isModuleInterpreted, + compileExpr, dynCompileExpr, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType +#endif + ) where + +#ifdef GHCI + +#include "HsVersions.h" + +import InteractiveEvalTypes + +import GhcMonad +import HscMain +import HsSyn +import HscTypes +import BasicTypes ( HValue ) +import InstEnv +import FamInstEnv ( FamInst, orphNamesOfFamInst ) +import TyCon +import Type hiding( typeKind ) +import TcType hiding( typeKind ) +import Var +import Id +import Name hiding ( varName ) +import NameSet +import Avail +import RdrName +import VarSet +import VarEnv +import ByteCodeInstr +import Linker +import DynFlags +import Unique +import UniqSupply +import Module +import Panic +import UniqFM +import Maybes +import ErrUtils +import SrcLoc +import BreakArray +import RtClosureInspect +import Outputable +import FastString +import MonadUtils + +import System.Mem.Weak +import System.Directory +import Data.Dynamic +import Data.Either +import Data.List (find) +import Control.Monad +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif +import Foreign.C +import GHC.Exts +import Data.Array +import Exception +import Control.Concurrent +import System.IO.Unsafe + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) + +data SingleStep + = RunToCompletion + | SingleStep + | RunAndLogSteps + +isStep :: SingleStep -> Bool +isStep RunToCompletion = False +isStep _ = True + +mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory hsc_env hval bi = let + decls = findEnclosingDecls hsc_env bi + in History hval bi decls + + +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo + +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env hist = + let inf = historyBreakInfo hist + num = breakInfo_number inf + in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> modBreaks_locs (getModBreaks hmi) ! num + _ -> panic "getHistorySpan" + +getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks hmi + | Just linkable <- hm_linkable hmi, + [BCOs _ modBreaks] <- linkableUnlinked linkable + = modBreaks + | otherwise + = emptyModBreaks -- probably object code + +{- | Finds the enclosing top level function name -} +-- ToDo: a better way to do this would be to keep hold of the decl_path computed +-- by the coverage pass, which gives the list of lexically-enclosing bindings +-- for each tick. +findEnclosingDecls :: HscEnv -> BreakInfo -> [String] +findEnclosingDecls hsc_env inf = + let hmi = expectJust "findEnclosingDecls" $ + lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf) + mb = getModBreaks hmi + in modBreaks_decls mb ! breakInfo_number inf + +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } + +-- | Run a statement in the current interactive context. Statement +-- may bind multple values. +runStmt :: GhcMonad m => String -> SingleStep -> m RunResult +runStmt = runStmtWithLocation "" 1 + +-- | Run a statement in the current interactive context. Passing debug information +-- Statement may bind multple values. +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult +runStmtWithLocation source linenumber expr step = + do + hsc_env <- getSession + + breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } + + -- compile to value (IO [HValue]), don't run + r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber + + case r of + -- empty statement / comment + Nothing -> return (RunOk []) + + Just (tyThings, hval, fix_env) -> do + updateFixityEnv fix_env + + status <- + withVirtualCWD $ + withBreakAction (isStep step) idflags' breakMVar statusMVar $ do + liftIO $ sandboxIO idflags' statusMVar hval + + let ic = hsc_IC hsc_env + bindings = (ic_tythings ic, ic_rn_gbl_env ic) + + size = ghciHistSize idflags' + + handleRunStatus step expr bindings tyThings + breakMVar statusMVar status (emptyHistory size) + +runDecls :: GhcMonad m => String -> m [Name] +runDecls = runDeclsWithLocation "" 1 + +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation source linenumber expr = + do + hsc_env <- getSession + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber + + setSession $ hsc_env { hsc_IC = ic } + hsc_env <- getSession + hsc_env' <- liftIO $ rttiEnvironment hsc_env + modifySession (\_ -> hsc_env') + return (map getName tyThings) + + +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m + +parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr + +emptyHistory :: Int -> BoundedList History +emptyHistory size = nilBL size + +handleRunStatus :: GhcMonad m + => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] + -> MVar () -> MVar Status -> Status -> BoundedList History + -> m RunResult + +handleRunStatus step expr bindings final_ids + breakMVar statusMVar status history + | RunAndLogSteps <- step = tracing + | otherwise = not_tracing + where + tracing + | Break is_exception apStack info tid <- status + , not is_exception + = do + hsc_env <- getSession + b <- liftIO $ isBreakEnabled hsc_env info + if b + then not_tracing + -- This breakpoint is explicitly enabled; we want to stop + -- instead of just logging it. + else do + let history' = mkHistory hsc_env apStack info `consBL` history + -- probably better make history strict here, otherwise + -- our BoundedList will be pointless. + _ <- liftIO $ evaluate history' + status <- withBreakAction True (hsc_dflags hsc_env) + breakMVar statusMVar $ do + liftIO $ mask_ $ do + putMVar breakMVar () -- awaken the stopped thread + redirectInterrupts tid $ + takeMVar statusMVar -- and wait for the result + handleRunStatus RunAndLogSteps expr bindings final_ids + breakMVar statusMVar status history' + | otherwise + = not_tracing + + not_tracing + -- Hit a breakpoint + | Break is_exception apStack info tid <- status + = do + hsc_env <- getSession + let mb_info | is_exception = Nothing + | otherwise = Just info + (hsc_env1, names, span) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack mb_info + let + resume = Resume + { resumeStmt = expr, resumeThreadId = tid + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeSpan = span, resumeHistory = toListBL history + , resumeHistoryIx = 0 } + hsc_env2 = pushResume hsc_env1 resume + + modifySession (\_ -> hsc_env2) + return (RunBreak tid names mb_info) + + -- Completed with an exception + | Complete (Left e) <- status + = return (RunException e) + + -- Completed successfully + | Complete (Right hvals) <- status + = do hsc_env <- getSession + let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids + final_names = map getName final_ids + liftIO $ Linker.extendLinkEnv (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + modifySession (\_ -> hsc_env') + return (RunOk final_names) + + | otherwise + = panic "handleRunStatus" -- The above cases are in fact exhaustive + +isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool +isBreakEnabled hsc_env inf = + case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> do + w <- getBreak (hsc_dflags hsc_env) + (modBreaks_flags (getModBreaks hmi)) + (breakInfo_number inf) + case w of Just n -> return (n /= 0); _other -> return False + _ -> + return False + + +foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt +foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt + +setStepFlag :: IO () +setStepFlag = poke stepFlag 1 +resetStepFlag :: IO () +resetStepFlag = poke stepFlag 0 + +-- this points to the IO action that is executed when a breakpoint is hit +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) + +-- When running a computation, we redirect ^C exceptions to the running +-- thread. ToDo: we might want a way to continue even if the target +-- thread doesn't die when it receives the exception... "this thread +-- is not responding". +-- +-- Careful here: there may be ^C exceptions flying around, so we start the new +-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock +-- only while we execute the user's code. We can't afford to lose the final +-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) +sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status +sandboxIO dflags statusMVar thing = + mask $ \restore -> -- fork starts blocked + let runIt = liftM Complete $ try (restore $ rethrow dflags thing) + in if gopt Opt_GhciSandbox dflags + then do tid <- forkIO $ do res <- runIt + putMVar statusMVar res -- empty: can't block + redirectInterrupts tid $ + takeMVar statusMVar + + else -- GLUT on OS X needs to run on the main thread. If you + -- try to use it from another thread then you just get a + -- white rectangle rendered. For this, or anything else + -- with such restrictions, you can turn the GHCi sandbox off + -- and things will be run in the main thread. + -- + -- BUT, note that the debugging features (breakpoints, + -- tracing, etc.) need the expression to be running in a + -- separate thread, so debugging is only enabled when + -- using the sandbox. + runIt + +-- +-- While we're waiting for the sandbox thread to return a result, if +-- the current thread receives an asynchronous exception we re-throw +-- it at the sandbox thread and continue to wait. +-- +-- This is for two reasons: +-- +-- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the +-- computation to run its exception handlers before returning the +-- exception result to the caller of runStmt. +-- +-- * clients of the GHC API can terminate a runStmt in progress +-- without knowing the ThreadId of the sandbox thread (#1381) +-- +-- NB. use a weak pointer to the thread, so that the thread can still +-- be considered deadlocked by the RTS and sent a BlockedIndefinitely +-- exception. A symptom of getting this wrong is that conc033(ghci) +-- will hang. +-- +redirectInterrupts :: ThreadId -> IO a -> IO a +redirectInterrupts target wait + = do wtid <- mkWeakThreadId target + wait `catch` \e -> do + m <- deRefWeak wtid + case m of + Nothing -> wait + Just target -> do throwTo target (e :: SomeException); wait + +-- We want to turn ^C into a break when -fbreak-on-exception is on, +-- but it's an async exception and we only break for sync exceptions. +-- Idea: if we catch and re-throw it, then the re-throw will trigger +-- a break. Great - but we don't want to re-throw all exceptions, because +-- then we'll get a double break for ordinary sync exceptions (you'd have +-- to :continue twice, which looks strange). So if the exception is +-- not "Interrupted", we unset the exception flag before throwing. +-- +rethrow :: DynFlags -> IO a -> IO a +rethrow dflags io = Exception.catch io $ \se -> do + -- If -fbreak-on-error, we break unconditionally, + -- but with care of not breaking twice + if gopt Opt_BreakOnError dflags && + not (gopt Opt_BreakOnException dflags) + then poke exceptionFlag 1 + else case fromException se of + -- If it is a "UserInterrupt" exception, we allow + -- a possible break by way of -fbreak-on-exception + Just UserInterrupt -> return () + -- In any other case, we don't want to break + _ -> poke exceptionFlag 0 + + Exception.throwIO se + +-- This function sets up the interpreter for catching breakpoints, and +-- resets everything when the computation has stopped running. This +-- is a not-very-good way to ensure that only the interactive +-- evaluation should generate breakpoints. +withBreakAction :: (ExceptionMonad m, MonadIO m) => + Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a +withBreakAction step dflags breakMVar statusMVar act + = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act) + where + setBreakAction = do + stablePtr <- newStablePtr onBreak + poke breakPointIOAction stablePtr + when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1 + when step $ setStepFlag + return stablePtr + -- Breaking on exceptions is not enabled by default, since it + -- might be a bit surprising. The exception flag is turned off + -- as soon as it is hit, or in resetBreakAction below. + + onBreak is_exception info apStack = do + tid <- myThreadId + putMVar statusMVar (Break is_exception apStack info tid) + takeMVar breakMVar + + resetBreakAction stablePtr = do + poke breakPointIOAction noBreakStablePtr + poke exceptionFlag 0 + resetStepFlag + freeStablePtr stablePtr + +noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ()) +noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction + +noBreakAction :: Bool -> BreakInfo -> HValue -> IO () +noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" +noBreakAction True _ _ = return () -- exception: just continue + +resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult +resume canLogSpan step + = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + + case resume of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + -- unbind the temporary locals by restoring the TypeEnv from + -- before the breakpoint, and drop this Resume from the + -- InteractiveContext. + let (resume_tmp_te,resume_rdr_env) = resumeBindings r + ic' = ic { ic_tythings = resume_tmp_te, + ic_rn_gbl_env = resume_rdr_env, + ic_resume = rs } + modifySession (\_ -> hsc_env{ hsc_IC = ic' }) + + -- remove any bindings created since the breakpoint from the + -- linker's environment + let new_names = map getName (filter (`notElem` resume_tmp_te) + (ic_tythings ic)) + liftIO $ Linker.deleteFromLinkEnv new_names + + when (isStep step) $ liftIO setStepFlag + case r of + Resume { resumeStmt = expr, resumeThreadId = tid + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span + , resumeHistory = hist } -> do + withVirtualCWD $ do + withBreakAction (isStep step) (hsc_dflags hsc_env) + breakMVar statusMVar $ do + status <- liftIO $ mask_ $ do + putMVar breakMVar () + -- this awakens the stopped thread... + redirectInterrupts tid $ + takeMVar statusMVar + -- and wait for the result + let prevHistoryLst = fromListBL 50 hist + hist' = case info of + Nothing -> prevHistoryLst + Just i + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack i `consBL` + fromListBL 50 hist + handleRunStatus step expr bindings final_ids + breakMVar statusMVar status hist' + +back :: GhcMonad m => m ([Name], Int, SrcSpan) +back = moveHist (+1) + +forward :: GhcMonad m => m ([Name], Int, SrcSpan) +forward = moveHist (subtract 1) + +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist fn = do + hsc_env <- getSession + case ic_resume (hsc_IC hsc_env) of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (new_ix > length history) $ liftIO $ + throwGhcExceptionIO (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ liftIO $ + throwGhcExceptionIO (ProgramError "already at the beginning of the history") + + let + update_ic apStack mb_info = do + (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env + apStack mb_info + let ic = hsc_IC hsc_env1 + r' = r { resumeHistoryIx = new_ix } + ic' = ic { ic_resume = r':rs } + + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) + + return (names, new_ix, span) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakInfo = mb_info } -> + update_ic apStack mb_info + else case history !! (new_ix - 1) of + History apStack info _ -> + update_ic apStack (Just info) + +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment +result_fs :: FastString +result_fs = fsLit "_result" + +bindLocalsAtBreakpoint + :: HscEnv + -> HValue + -> Maybe BreakInfo + -> IO (HscEnv, [Name], SrcSpan) + +-- Nothing case: we stopped when an exception was raised, not at a +-- breakpoint. We have no location information or local variables to +-- bind, all we can do is bind a local variable to the exception +-- value. +bindLocalsAtBreakpoint hsc_env apStack Nothing = do + let exn_fs = fsLit "_exception" + exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span + e_fs = fsLit "e" + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span + e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) + + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] + + span = mkGeneralSrcSpan (fsLit "") + -- + Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) + +-- Just case: we stopped at a breakpoint, we have information about the location +-- of the breakpoint and the free variables of the expression. +bindLocalsAtBreakpoint hsc_env apStack (Just info) = do + + let + mod_name = moduleName (breakInfo_module info) + hmi = expectJust "bindLocalsAtBreakpoint" $ + lookupUFM (hsc_HPT hsc_env) mod_name + breaks = getModBreaks hmi + index = breakInfo_number info + vars = breakInfo_vars info + result_ty = breakInfo_resty info + occs = modBreaks_vars breaks ! index + span = modBreaks_locs breaks ! index + + -- Filter out any unboxed ids; + -- we can't bind these at the prompt + pointers = filter (\(id,_) -> isPointer id) vars + isPointer id | UnaryRep ty <- repType (idType id) + , PtrRep <- typePrimRep ty = True + | otherwise = False + + (ids, offsets) = unzip pointers + + free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids + `unionVarSet` tyVarsOfType result_ty + + -- It might be that getIdValFromApStack fails, because the AP_STACK + -- has been accidentally evaluated, or something else has gone wrong. + -- So that we don't fall over in a heap when this happens, just don't + -- bind any free variables instead, and we emit a warning. + mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) + let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] + when (any isNothing mb_hValues) $ + debugTraceMsg (hsc_dflags hsc_env) 1 $ + text "Warning: _result has been evaluated, some bindings have been lost" + + us <- mkSplitUniqSupply 'I' + let (us1, us2) = splitUniqSupply us + tv_subst = newTyVars us1 free_tvs + new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2) + names = map idName new_ids + + -- make an Id for _result. We use the Unique of the FastString "_result"; + -- we don't care about uniqueness here, because there will only be one + -- _result in scope at any time. + let result_name = mkInternalName (getUnique result_fs) + (mkVarOccFS result_fs) span + result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty) + + -- for each Id we're about to bind in the local envt: + -- - tidy the type variables + -- - globalise the Id (Ids are supposed to be Global, apparently). + -- + let result_ok = isPointer result_id + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids + id_tys = map idType all_ids + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys + final_ids = zipWith setIdType all_ids tidy_tys + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids + + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + return (hsc_env1, if result_ok then result_name:names else names, span) + where + -- We need a fresh Unique for each Id we bind, because the linker + -- state is single-threaded and otherwise we'd spam old bindings + -- whenever we stop at a breakpoint. The InteractveContext is properly + -- saved/restored, but not the linker state. See #1743, test break026. + mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id + mkNewId tv_subst occ id uniq + = Id.mkVanillaGlobalWithInfo name ty (idInfo id) + where + loc = nameSrcSpan (idName id) + name = mkInternalName uniq occ loc + ty = substTy tv_subst (idType id) + + newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst + -- Similarly, clone the type variables mentioned in the types + -- we have here, *and* make them all RuntimeUnk tyars + newTyVars us tvs + = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) + | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us + , let name = setNameUnique (tyVarName tv) uniq ] + +rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + incompletelyTypedIds = + [id | id <- tmp_ids + , not $ noSkolems id + , (occNameFS.nameOccName.idName) id /= result_fs] + hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) + return hsc_env' + where + noSkolems = isEmptyVarSet . tyVarsOfType . idType + improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + Just id = find (\i -> idName i == name) tmp_ids + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + case mb_new_ty of + Nothing -> return hsc_env + Just new_ty -> do + case improveRTTIType hsc_env old_ty new_ty of + Nothing -> return $ + WARN(True, text (":print failed to calculate the " + ++ "improvement for a type")) hsc_env + Just subst -> do + let dflags = hsc_dflags hsc_env + when (dopt Opt_D_dump_rtti dflags) $ + printInfoForUser dflags alwaysQualify $ + fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] + + let ic' = substInteractiveContext ic subst + return hsc_env{hsc_IC=ic'} + +getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) +getIdValFromApStack apStack (I# stackDepth) = do + case getApStackVal# apStack (stackDepth +# 1#) of + -- The +1 is magic! I don't know where it comes + -- from, but this makes things line up. --SDM + (# ok, result #) -> + case ok of + 0# -> return Nothing -- AP_STACK not found + _ -> return (Just (unsafeCoerce# result)) + +pushResume :: HscEnv -> Resume -> HscEnv +pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } + where + ictxt0 = hsc_IC hsc_env + ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } + +-- ----------------------------------------------------------------------------- +-- Abandoning a resume context + +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + r:rs -> do + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandon_ r + return True + +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + rs -> do + modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ abandon_ rs + return True + +-- when abandoning a computation we have to +-- (a) kill the thread with an async exception, so that the +-- computation itself is stopped, and +-- (b) fill in the MVar. This step is necessary because any +-- thunks that were under evaluation will now be updated +-- with the partial computation, which still ends in takeMVar, +-- so any attempt to evaluate one of these thunks will block +-- unless we fill in the MVar. +-- (c) wait for the thread to terminate by taking its status MVar. This +-- step is necessary to prevent race conditions with +-- -fbreak-on-exception (see #5975). +-- See test break010. +abandon_ :: Resume -> IO () +abandon_ r = do + killThread (resumeThreadId r) + putMVar (resumeBreakMVar r) () + _ <- takeMVar (resumeStatMVar r) + return () + +-- ----------------------------------------------------------------------------- +-- Bounded list, optimised for repeated cons + +data BoundedList a = BL + {-# UNPACK #-} !Int -- length + {-# UNPACK #-} !Int -- bound + [a] -- left + [a] -- right, list is (left ++ reverse right) + +nilBL :: Int -> BoundedList a +nilBL bound = BL 0 bound [] [] + +consBL :: a -> BoundedList a -> BoundedList a +consBL a (BL len bound left right) + | len < bound = BL (len+1) bound (a:left) right + | null right = BL len bound [a] $! tail (reverse left) + | otherwise = BL len bound (a:left) $! tail right + +toListBL :: BoundedList a -> [a] +toListBL (BL _ _ left right) = left ++ reverse right + +fromListBL :: Int -> [a] -> BoundedList a +fromListBL bound l = BL (length l) bound l [] + +-- lenBL (BL len _ _ _) = len + +-- ----------------------------------------------------------------------------- +-- | Set the interactive evaluation context. +-- +-- (setContext imports) sets the ic_imports field (which in turn +-- determines what is in scope at the prompt) to 'imports', and +-- constructs the ic_rn_glb_env environment to reflect it. +-- +-- We retain in scope all the things defined at the prompt, and kept +-- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) + +setContext :: GhcMonad m => [InteractiveImport] -> m () +setContext imports + = do { hsc_env <- getSession + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> + liftIO $ throwGhcExceptionIO (formatError dflags mod err) + Right all_env -> do { + ; let old_ic = hsc_IC hsc_env + final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic + ; modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_rn_gbl_env = final_rdr_env }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err + +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (ModuleName, String) GlobalRdrEnv) +-- Compute the GlobalRdrEnv for the interactive context +findGlobalRdrEnv hsc_env imports + = do { idecls_env <- hscRnImportDecls hsc_env idecls + -- This call also loads any orphan modules + ; return $ case partitionEithers (map mkEnv imods) of + ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) + (err : _, _) -> Left err } + where + idecls :: [LImportDecl RdrName] + idecls = [noLoc d | IIDecl d <- imports] + + imods :: [ModuleName] + imods = [m | IIModule m <- imports] + + mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of + Left err -> Left (mod, err) + Right env -> Right env + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) + where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } + +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv +mkTopLevEnv hpt modl + = case lookupUFM hpt modl of + Nothing -> Left "not a home module" + Just details -> + case mi_globals (hm_iface details) of + Nothing -> Left "not interpreted" + Just env -> Right env + +-- | Get the interactive evaluation context, consisting of a pair of the +-- set of modules from which we take the full top-level scope, and the set +-- of modules from which we take just the exports respectively. +getContext :: GhcMonad m => m [InteractiveImport] +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_imports ic) + +-- | Returns @True@ if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> + if modulePackageKey modl /= thisPackage (hsc_dflags h) + then return False + else case lookupUFM (hsc_HPT h) (moduleName modl) of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False + +-- | Looks up an identifier in the current interactive context (for :info) +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! +-- The exact choice of which ones to show, and which to hide, is a judgement call. +-- (see Trac #1581) +getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) +getInfo allInfo name + = withSession $ \hsc_env -> + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, cls_insts, fam_insts) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + + -- Filter the instances based on whether the constituent names of their + -- instance heads are all in scope. + let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts + fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts + return (Just (thing, fixity, cls_insts', fam_insts')) + where + plausible rdr_env names + -- Dfun involving only names that are in ic_rn_glb_env + = allInfo + || all ok (nameSetElems names) + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True -- The one we looked for in the first place! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv + return gbl_names + + +-- ToDo: move to RdrName +greToRdrNames :: GlobalRdrElt -> [RdrName] +greToRdrNames GRE{ gre_name = name, gre_prov = prov } + = case prov of + LocalDef -> [unqual] + Imported specs -> concat (map do_spec (map is_decl specs)) + where + occ = nameOccName name + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: GhcMonad m => String -> m [Name] +parseName str = withSession $ \hsc_env -> liftIO $ + do { lrdr_name <- hscParseIdentifier hsc_env str + ; hscTcRnLookupRdrName hsc_env lrdr_name } + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +-- Returns its most general type +exprType :: GhcMonad m => String -> m Type +exprType expr = withSession $ \hsc_env -> do + ty <- liftIO $ hscTcExpr hsc_env expr + return $ tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) +typeKind normalise str = withSession $ \hsc_env -> do + liftIO $ hscKcType hsc_env normalise str + +----------------------------------------------------------------------------- +-- Compile an expression, run it and deliver the resulting HValue + +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = withSession $ \hsc_env -> do + Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + updateFixityEnv fix_env + hvals <- liftIO hval + case (ids,hvals) of + ([_],[hv]) -> return hv + _ -> panic "compileExpr" + +-- ----------------------------------------------------------------------------- +-- Compile an expression, run it and return the result as a dynamic + +dynCompileExpr :: GhcMonad m => String -> m Dynamic +dynCompileExpr expr = do + iis <- getContext + let importDecl = ImportDecl { + ideclSourceSrc = Nothing, + ideclName = noLoc (mkModuleName "Data.Dynamic"), + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, + ideclQualified = True, + ideclImplicit = False, + ideclAs = Nothing, + ideclHiding = Nothing + } + setContext (IIDecl importDecl : iis) + let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" + Just (ids, hvals, fix_env) <- withSession $ \hsc_env -> + liftIO $ hscStmt hsc_env stmt + setContext iis + updateFixityEnv fix_env + + vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) + case (ids,vals) of + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" + +----------------------------------------------------------------------------- +-- show a module and it's source/object filenames + +showModule :: GhcMonad m => ModSummary -> m String +showModule mod_summary = + withSession $ \hsc_env -> do + interpreted <- isModuleInterpreted mod_summary + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) + +isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool +isModuleInterpreted mod_summary = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> return (not obj_linkable) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + +---------------------------------------------------------------------------- +-- RTTI primitives + +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +obtainTermFromVal hsc_env bound force ty x = + cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) + +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm hsc_env bound force (idType id) hv + +-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic +reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do + hv <- Linker.getHValue hsc_env (varName id) + cvReconstructType hsc_env bound (idType id) hv + +mkRuntimeUnkTyVar :: Name -> Kind -> TyVar +mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk +#endif /* GHCI */ + diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs new file mode 100644 index 00000000..6ea1a256 --- /dev/null +++ b/compiler/main/InteractiveEvalTypes.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module InteractiveEvalTypes ( +#ifdef GHCI + RunResult(..), Status(..), Resume(..), History(..), +#endif + ) where + +#ifdef GHCI + +import Id +import BasicTypes +import Name +import RdrName +import TypeRep +import ByteCodeInstr +import SrcLoc +import Exception +import Control.Concurrent + +data RunResult + = RunOk [Name] -- ^ names bound by this evaluation + | RunException SomeException -- ^ statement raised an exception + | RunBreak ThreadId [Name] (Maybe BreakInfo) + +data Status + = Break Bool HValue BreakInfo ThreadId + -- ^ the computation hit a breakpoint (Bool <=> was an exception) + | Complete (Either SomeException [HValue]) + -- ^ the computation completed with either an exception or a value + +data Resume + = Resume { + resumeStmt :: String, -- the original statement + resumeThreadId :: ThreadId, -- thread running the computation + resumeBreakMVar :: MVar (), + resumeStatMVar :: MVar Status, + resumeBindings :: ([TyThing], GlobalRdrEnv), + resumeFinalIds :: [Id], -- [Id] to bind on completion + resumeApStack :: HValue, -- The object from which we can get + -- value of the free variables. + resumeBreakInfo :: Maybe BreakInfo, + -- the breakpoint we stopped at + -- (Nothing <=> exception) + resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain + -- to fetch the ModDetails & ModBreaks + -- to get this. + resumeHistory :: [History], + resumeHistoryIx :: Int -- 0 <==> at the top of the history + } + +data History + = History { + historyApStack :: HValue, + historyBreakInfo :: BreakInfo, + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint + } +#endif + diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs new file mode 100644 index 00000000..b94ea65a --- /dev/null +++ b/compiler/main/PackageConfig.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP, RecordWildCards #-} + +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities +-- +-- (c) The University of Glasgow, 2004 +-- +module PackageConfig ( + -- $package_naming + + -- * PackageKey + packageConfigId, + + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo(..), + InstalledPackageId(..), + SourcePackageId(..), + PackageName(..), + Version(..), + defaultPackageConfig, + installedPackageIdString, + sourcePackageIdString, + packageNameString, + pprPackageConfig, + ) where + +#include "HsVersions.h" + +import GHC.PackageDb +import Data.Version + +import FastString +import Outputable +import Module + +-- ----------------------------------------------------------------------------- +-- Our PackageConfig type is the InstalledPackageInfo from bin-package-db, +-- which is similar to a subset of the InstalledPackageInfo type from Cabal. + +type PackageConfig = InstalledPackageInfo + InstalledPackageId + SourcePackageId + PackageName + Module.PackageKey + Module.ModuleName + +-- TODO: there's no need for these to be FastString, as we don't need the uniq +-- feature, but ghc doesn't currently have convenient support for any +-- other compact string types, e.g. plain ByteString or Text. + +newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord) +newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) +newtype PackageName = PackageName FastString deriving (Eq, Ord) + +instance BinaryStringRep InstalledPackageId where + fromStringRep = InstalledPackageId . mkFastStringByteString + toStringRep (InstalledPackageId s) = fastStringToByteString s + +instance BinaryStringRep SourcePackageId where + fromStringRep = SourcePackageId . mkFastStringByteString + toStringRep (SourcePackageId s) = fastStringToByteString s + +instance BinaryStringRep PackageName where + fromStringRep = PackageName . mkFastStringByteString + toStringRep (PackageName s) = fastStringToByteString s + +instance Outputable InstalledPackageId where + ppr (InstalledPackageId str) = ftext str + +instance Outputable SourcePackageId where + ppr (SourcePackageId str) = ftext str + +instance Outputable PackageName where + ppr (PackageName str) = ftext str + +-- | Pretty-print an 'ExposedModule' in the same format used by the textual +-- installed package database. +pprExposedModule :: (Outputable a, Outputable b) => ExposedModule a b -> SDoc +pprExposedModule (ExposedModule exposedName exposedReexport exposedSignature) = + sep [ ppr exposedName + , case exposedReexport of + Just m -> sep [text "from", pprOriginalModule m] + Nothing -> empty + , case exposedSignature of + Just m -> sep [text "is", pprOriginalModule m] + Nothing -> empty + ] + +-- | Pretty-print an 'OriginalModule' in the same format used by the textual +-- installed package database. +pprOriginalModule :: (Outputable a, Outputable b) => OriginalModule a b -> SDoc +pprOriginalModule (OriginalModule originalPackageId originalModuleName) = + ppr originalPackageId <> char ':' <> ppr originalModuleName + +defaultPackageConfig :: PackageConfig +defaultPackageConfig = emptyInstalledPackageInfo + +installedPackageIdString :: PackageConfig -> String +installedPackageIdString pkg = unpackFS str + where + InstalledPackageId str = installedPackageId pkg + +sourcePackageIdString :: PackageConfig -> String +sourcePackageIdString pkg = unpackFS str + where + SourcePackageId str = sourcePackageId pkg + +packageNameString :: PackageConfig -> String +packageNameString pkg = unpackFS str + where + PackageName str = packageName pkg + +pprPackageConfig :: PackageConfig -> SDoc +pprPackageConfig InstalledPackageInfo {..} = + vcat [ + field "name" (ppr packageName), + field "version" (text (showVersion packageVersion)), + field "id" (ppr installedPackageId), + field "key" (ppr packageKey), + field "exposed" (ppr exposed), + field "exposed-modules" + (if all isExposedModule exposedModules + then fsep (map pprExposedModule exposedModules) + else pprWithCommas pprExposedModule exposedModules), + field "hidden-modules" (fsep (map ppr hiddenModules)), + field "trusted" (ppr trusted), + field "import-dirs" (fsep (map text importDirs)), + field "library-dirs" (fsep (map text libraryDirs)), + field "hs-libraries" (fsep (map text hsLibraries)), + field "extra-libraries" (fsep (map text extraLibraries)), + field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), + field "include-dirs" (fsep (map text includeDirs)), + field "includes" (fsep (map text includes)), + field "depends" (fsep (map ppr depends)), + field "cc-options" (fsep (map text ccOptions)), + field "ld-options" (fsep (map text ldOptions)), + field "framework-dirs" (fsep (map text frameworkDirs)), + field "frameworks" (fsep (map text frameworks)), + field "haddock-interfaces" (fsep (map text haddockInterfaces)), + field "haddock-html" (fsep (map text haddockHTMLs)) + ] + where + field name body = text name <> colon <+> nest 4 body + isExposedModule (ExposedModule _ Nothing Nothing) = True + isExposedModule _ = False + + +-- ----------------------------------------------------------------------------- +-- PackageKey (package names, versions and dep hash) + +-- $package_naming +-- #package_naming# +-- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes +-- of a package ID, keys of its dependencies, and Cabal flags. You're expected +-- to pass in the package key in the @-this-package-key@ flag. However, for +-- wired-in packages like @base@ & @rts@, we don't necessarily know what the +-- version is, so these are handled specially; see #wired_in_packages#. + +-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig' +packageConfigId :: PackageConfig -> PackageKey +packageConfigId = packageKey + diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs new file mode 100644 index 00000000..aa97280a --- /dev/null +++ b/compiler/main/Packages.hs @@ -0,0 +1,1399 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +-- | Package manipulation +module Packages ( + module PackageConfig, + + -- * Reading the package config, and processing cmdline args + PackageState(preloadPackages), + initPackages, + readPackageConfigs, + getPackageConfRefs, + resolvePackageConfig, + readPackageConfig, + + -- * Querying the package config + lookupPackage, + resolveInstalledPackageId, + searchPackageId, + getPackageDetails, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPreloadPackagesAnd, + + collectIncludeDirs, collectLibraryPaths, collectLinkOpts, + packageHsLibs, + + -- * Utils + packageKeyPackageIdString, + pprFlag, + pprPackages, + pprPackagesSimple, + pprModuleMap, + isDllName + ) +where + +#include "HsVersions.h" + +import GHC.PackageDb +import PackageConfig +import DynFlags +import Name ( Name, nameModule_maybe ) +import UniqFM +import Module +import Util +import Panic +import Outputable +import Maybes + +import System.Environment ( getEnv ) +import FastString +import ErrUtils ( debugTraceMsg, MsgDoc ) +import Exception +import Unique + +import System.Directory +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import Control.Monad +import Data.Char ( toUpper ) +import Data.List as List +import Data.Map (Map) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid hiding ((<>)) +#endif +import qualified Data.Map as Map +import qualified FiniteMap as Map +import qualified Data.Set as Set + +-- --------------------------------------------------------------------------- +-- The Package state + +-- | Package state is all stored in 'DynFlags', including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. +-- +-- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: +-- +-- * @-package @ and @-package-id @ cause @@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package @ causes @@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. +-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of +-- their dependencies. +-- +-- * When searching for a module from an preload import declaration, +-- only the exposed modules in @exposedPackages@ are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from @depExposedPackages@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [PackageConfig] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [PackageConfig] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is expsed, and +-- also its 'PackageConfig'. +fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + mappend _ _ = panic "ModOrigin: hidden module redefined" + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | 'UniqFM' map from 'PackageKey' +type PackageKeyMap = UniqFM + +-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig' +type PackageConfigMap = PackageKeyMap PackageConfig + +-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which +-- are exposed should be dumped into scope, (2) any custom renamings that +-- should also be apply, and (3) what package name is associated with the +-- key, if it might be hidden +type VisibilityMap = + PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) + +-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings +-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons +-- (since this is the slow path, we'll just look it up again). +type ModuleToPkgConfAll = + Map ModuleName (Map Module ModuleOrigin) + +data PackageState = PackageState { + -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted + -- so that only valid packages are here. Currently, we also flip the + -- exposed/trusted bits based on package flags; however, the hope is to + -- stop doing that. + pkgIdMap :: PackageConfigMap, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PackageKey], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleToPkgConfAll :: ModuleToPkgConfAll, + + -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC + -- internally deals in package keys but the database may refer to installed + -- package IDs. + installedPackageIdMap :: InstalledPackageIdMap + } + +type InstalledPackageIdMap = Map InstalledPackageId PackageKey +type InstalledPackageIndex = Map InstalledPackageId PackageConfig + +-- | Empty package configuration map +emptyPackageConfigMap :: PackageConfigMap +emptyPackageConfigMap = emptyUFM + +-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig +lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) + +lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig +lookupPackage' = lookupUFM + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listPackageConfigMap dflags) + +-- | Extends the package configuration map with a list of package configs. +extendPackageConfigMap + :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap +extendPackageConfigMap pkg_map new_pkgs + = foldl add pkg_map new_pkgs + where add pkg_map p = addToUFM pkg_map (packageConfigId p) p + +-- | Looks up the package with the given id in the package state, panicing if it is +-- not found +getPackageDetails :: DynFlags -> PackageKey -> PackageConfig +getPackageDetails dflags pid = + expectJust "getPackageDetails" (lookupPackage dflags pid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, it may not do what you expect it to. +listPackageConfigMap :: DynFlags -> [PackageConfig] +listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) + +-- | Looks up a 'PackageKey' given an 'InstalledPackageId' +resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey +resolveInstalledPackageId dflags ipid = + expectJust "resolveInstalledPackageId" + (Map.lookup ipid (installedPackageIdMap (pkgState dflags))) + +-- ---------------------------------------------------------------------------- +-- Loading the package db files and building up the package state + +-- | Call this after 'DynFlags.parseDynFlags'. It reads the package +-- database files, and sets up various internal tables of package +-- information, according to the package-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- Returns a list of packages to link in if we're doing dynamic linking. +-- This list contains the packages that the user explicitly mentioned with +-- @-package@ flags. +-- +-- 'initPackages' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'pkgState' in 'DynFlags' and return a list of packages to +-- link in. +initPackages :: DynFlags -> IO (DynFlags, [PackageKey]) +initPackages dflags = do + pkg_db <- case pkgDatabase dflags of + Nothing -> readPackageConfigs dflags + Just db -> return $ setBatchPackageFlags dflags db + (pkg_state, preload, this_pkg) + <- mkPackageState dflags pkg_db [] (thisPackage dflags) + return (dflags{ pkgDatabase = Just pkg_db, + pkgState = pkg_state, + thisPackage = this_pkg }, + preload) + +-- ----------------------------------------------------------------------------- +-- Reading the package database(s) + +readPackageConfigs :: DynFlags -> IO [PackageConfig] +readPackageConfigs dflags = do + conf_refs <- getPackageConfRefs dflags + confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs + liftM concat $ mapM (readPackageConfig dflags) confs + +getPackageConfRefs :: DynFlags -> IO [PkgConfRef] +getPackageConfRefs dflags = do + let system_conf_refs = [UserPkgConf, GlobalPkgConf] + + e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | not (null path) && isSearchPathSeparator (last path) + -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs + | otherwise + -> map PkgConfFile (splitSearchPath path) + + return $ reverse (extraPkgConfs dflags base_conf_refs) + -- later packages shadow earlier ones. extraPkgConfs + -- is in the opposite order to the flags on the + -- command line. + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do + dir <- versionedAppDir dflags + let pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing +resolvePackageConfig _ (PkgConfFile name) = return $ Just name + +readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] +readPackageConfig dflags conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then do let filename = conf_file "package.cache" + debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) + readPackageDbForGhc filename + else do + isfile <- doesFileExist conf_file + if isfile + then throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + top_dir = topDir dflags + pkgroot = takeDirectory conf_file + pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs + pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 + -- + return pkg_configs2 + +setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] +setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs + where + maybeDistrustAll pkgs' + | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' + | otherwise = pkgs' + + distrust pkg = pkg{ trusted = False } + +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the package database based on a package flag +-- (-package, -hide-package, -ignore-package). + +applyPackageFlag + :: DynFlags + -> UnusablePackages + -> ([PackageConfig], VisibilityMap) -- Initial database + -> PackageFlag -- flag to apply + -> IO ([PackageConfig], VisibilityMap) -- new database + +-- ToDo: Unfortunately, we still have to plumb the package config through, +-- because Safe Haskell trust is still implemented by modifying the database. +-- Eventually, track that separately and then axe @[PackageConfig]@ from +-- this fold entirely + +applyPackageFlag dflags unusable (pkgs, vm) flag = + case flag of + ExposePackage arg (ModRenaming b rns) -> + case selectPackages (matching arg) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (p:_,_) -> return (pkgs, vm') + where + n = fsPackageName p + vm' = addToUFM_C edit vm_cleared (packageConfigId p) + (b, map convRn rns, n) + edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + convRn (a,b) = (mkModuleName a, mkModuleName b) + -- ToDo: ATM, -hide-all-packages implicitly triggers change in + -- behavior, maybe eventually make it toggleable with a separate + -- flag + vm_cleared | gopt Opt_HideAllPackages dflags = vm + | otherwise = filterUFM_Directly + (\k (_,_,n') -> k == getUnique (packageConfigId p) + || n /= n') vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (ps,_) -> return (pkgs, vm') + where vm' = delListFromUFM vm (map packageConfigId ps) + + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (ps,qs) -> return (map trust ps ++ qs, vm) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (ps,qs) -> return (map distrust ps ++ qs, vm) + where distrust p = p {trusted=False} + + IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage" + +selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] + -> UnusablePackages + -> Either [(PackageConfig, UnusablePackageReason)] + ([PackageConfig], [PackageConfig]) +selectPackages matches pkgs unusable + = let (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByVersion ps, rest) + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> PackageConfig -> Bool +matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + +matchingId :: String -> PackageConfig -> Bool +matchingId str p = str == installedPackageIdString p + +matchingKey :: String -> PackageConfig -> Bool +matchingKey str p = str == packageKeyString (packageConfigId p) + +matching :: PackageArg -> PackageConfig -> Bool +matching (PackageArg str) = matchingStr str +matching (PackageIdArg str) = matchingId str +matching (PackageKeyArg str) = matchingKey str + +sortByVersion :: [PackageConfig] -> [PackageConfig] +sortByVersion = sortBy (flip (comparing packageVersion)) + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +packageFlagErr :: DynFlags + -> PackageFlag + -> [(PackageConfig, UnusablePackageReason)] + -> IO a + +-- for missing DPH package we emit a more helpful error message, because +-- this may be the result of using -fdph-par or -fdph-seq. +packageFlagErr dflags (ExposePackage (PackageArg pkg) _) [] + | is_dph_package pkg + = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err)) + where dph_err = text "the " <> text pkg <> text " package is not installed." + $$ text "To install it: \"cabal install dph\"." + is_dph_package pkg = "dph" `isPrefixOf` pkg + +packageFlagErr dflags flag reasons + = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> pprFlag flag <> + (if null reasons then Outputable.empty else text ": ") $$ + nest 4 (ppr_reasons $$ + -- ToDo: this admonition seems a bit dodgy + text "(use -v for more information)") + ppr_reasons = vcat (map ppr_reason reasons) + ppr_reason (p, reason) = + pprReason (ppr (installedPackageId p) <+> text "is") reason + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + IgnorePackage p -> text "-ignore-package " <> text p + HidePackage p -> text "-hide-package " <> text p + ExposePackage a rns -> ppr_arg a <> ppr_rns rns + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + where ppr_arg arg = case arg of + PackageArg p -> text "-package " <> text p + PackageIdArg p -> text "-package-id " <> text p + PackageKeyArg p -> text "-package-key " <> text p + ppr_rns (ModRenaming True []) = Outputable.empty + ppr_rns (ModRenaming b rns) = + if b then text "with" else Outputable.empty <+> + char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')' + ppr_rn (orig, new) | orig == new = text orig + | otherwise = text orig <+> text "as" <+> text new + +-- ----------------------------------------------------------------------------- +-- Wired-in packages + +wired_in_pkgids :: [String] +wired_in_pkgids = map packageKeyString wiredInPackageKeys + +findWiredInPackages + :: DynFlags + -> [PackageConfig] -- database + -> VisibilityMap -- info on what packages are visible + -> IO ([PackageConfig], VisibilityMap) + +findWiredInPackages dflags pkgs vis_map = do + -- + -- Now we must find our wired-in packages, and rename them to + -- their canonical names (eg. base-1.0 ==> base). + -- + let + matches :: PackageConfig -> String -> Bool + pc `matches` pid = packageNameString pc == pid + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe PackageConfig) + findWiredInPackage pkgs wired_pkg = + let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = + [ p | p <- all_ps + , elemUFM (packageConfigId p) vis_map ] in + case all_exposed_ps of + [] -> case all_ps of + [] -> notfound + many -> pick (head (sortByVersion many)) + many -> pick (head (sortByVersion many)) + where + notfound = do + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " not found.") + return Nothing + pick :: PackageConfig + -> IO (Maybe PackageConfig) + pick pkg = do + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " mapped to ") + <> ppr (installedPackageId pkg) + return (Just pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + wired_in_ids = map installedPackageId wired_in_pkgs + + -- this is old: we used to assume that if there were + -- multiple versions of wired-in packages installed that + -- they were mutually exclusive. Now we're assuming that + -- you have one "main" version of each wired-in package + -- (the latest version), and the others are backward-compat + -- wrappers that depend on this one. e.g. base-4.0 is the + -- latest, base-3.0 is a compat wrapper depending on base-4.0. + {- + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids + && package p `notElem` map fst wired_in_ids + -} + + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg pkg + | installedPackageId pkg `elem` wired_in_ids + = pkg { + packageKey = stringToPackageKey (packageNameString pkg) + } + | otherwise + = pkg + + updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs + where f vm p = case lookupUFM vis_map (packageConfigId p) of + Nothing -> vm + Just r -> addToUFM vm (stringToPackageKey + (packageNameString p)) r + + + return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map) + +-- ---------------------------------------------------------------------------- + +data UnusablePackageReason + = IgnoredWithFlag + | MissingDependencies [InstalledPackageId] + | ShadowedBy InstalledPackageId + +type UnusablePackages = Map InstalledPackageId + (PackageConfig, UnusablePackageReason) + +pprReason :: SDoc -> UnusablePackageReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> ptext (sLit "ignored due to an -ignore-package flag") + MissingDependencies deps -> + pref <+> + ptext (sLit "unusable due to missing or recursive dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedBy ipid -> + pref <+> ptext (sLit "shadowed by package ") <> ppr ipid + +reportUnusable :: DynFlags -> UnusablePackages -> IO () +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg dflags 2 $ + pprReason + (ptext (sLit "package") <+> + ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Detect any packages that have missing dependencies, and also any +-- mutually-recursive groups of packages (loops in the package graph +-- are not allowed). We do this by taking the least fixpoint of the +-- dependency graph, repeatedly adding packages whose dependencies are +-- satisfied until no more can be added. +-- +findBroken :: [PackageConfig] -> UnusablePackages +findBroken pkgs = go [] Map.empty pkgs + where + go avail ipids not_avail = + case partitionWith (depsAvailable ipids) not_avail of + ([], not_avail) -> + Map.fromList [ (installedPackageId p, (p, MissingDependencies deps)) + | (p,deps) <- not_avail ] + (new_avail, not_avail) -> + go (new_avail ++ avail) new_ipids (map fst not_avail) + where new_ipids = Map.insertList + [ (installedPackageId p, p) | p <- new_avail ] + ipids + + depsAvailable :: InstalledPackageIndex + -> PackageConfig + -> Either PackageConfig (PackageConfig, [InstalledPackageId]) + depsAvailable ipids pkg + | null dangling = Left pkg + | otherwise = Right (pkg, dangling) + where dangling = filter (not . (`Map.member` ipids)) (depends pkg) + +-- ----------------------------------------------------------------------------- +-- Eliminate shadowed packages, giving the user some feedback + +-- later packages in the list should shadow earlier ones with the same +-- package name/version. Additionally, a package may be preferred if +-- it is in the transitive closure of packages selected using -package-id +-- flags. +type UnusablePackage = (PackageConfig, UnusablePackageReason) +shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages +shadowPackages pkgs preferred + = let (shadowed,_) = foldl check ([],emptyUFM) pkgs + in Map.fromList shadowed + where + check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig) + -> PackageConfig + -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig) + check (shadowed,pkgmap) pkg + | Just oldpkg <- lookupUFM pkgmap pkgid + , let + ipid_new = installedPackageId pkg + ipid_old = installedPackageId oldpkg + -- + , ipid_old /= ipid_new + = if ipid_old `elem` preferred + then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) + else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap') + | otherwise + = (shadowed, pkgmap') + where + pkgid = packageKeyFS (packageKey pkg) + pkgmap' = addToUFM pkgmap pkgid pkg + +-- ----------------------------------------------------------------------------- + +ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + doit _ = panic "ignorePackages" + +-- ----------------------------------------------------------------------------- + +depClosure :: InstalledPackageIndex + -> [InstalledPackageId] + -> [InstalledPackageId] +depClosure index ipids = closure Map.empty ipids + where + closure set [] = Map.keys set + closure set (ipid : ipids) + | ipid `Map.member` set = closure set ipids + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + (depends p ++ ipids) + | otherwise = closure set ipids + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our package +-- settings and populate the package state. + +mkPackageState + :: DynFlags + -> [PackageConfig] -- initial database + -> [PackageKey] -- preloaded packages + -> PackageKey -- this package + -> IO (PackageState, + [PackageKey], -- new packages to preload + PackageKey) -- this package, might be modified if the current + -- package is a wired-in package. + +mkPackageState dflags0 pkgs0 preload0 this_package = do + dflags <- interpretPackageEnv dflags0 + +{- + Plan. + + 1. P = transitive closure of packages selected by -package-id + + 2. Apply shadowing. When there are multiple packages with the same + packageKey, + * if one is in P, use that one + * otherwise, use the one highest in the package stack + [ + rationale: we cannot use two packages with the same packageKey + in the same program, because packageKey is the symbol prefix. + Hence we must select a consistent set of packages to use. We have + a default algorithm for doing this: packages higher in the stack + shadow those lower down. This default algorithm can be overriden + by giving explicit -package-id flags; then we have to take these + preferences into account when selecting which other packages are + made available. + + Our simple algorithm throws away some solutions: there may be other + consistent sets that would satisfy the -package flags, but it's + not GHC's job to be doing constraint solving. + ] + + 3. remove packages selected by -ignore-package + + 4. remove any packages with missing dependencies, or mutually recursive + dependencies. + + 5. report (with -v) any packages that were removed by steps 2-4 + + 6. apply flags to set exposed/hidden on the resulting packages + - if any flag refers to a package which was removed by 2-4, then + we can give an error message explaining why + + 7. hide any packages which are superseded by later exposed packages +-} + + let + flags = reverse (packageFlags dflags) + + -- pkgs0 with duplicate packages filtered out. This is + -- important: it is possible for a package in the global package + -- DB to have the same IPID as a package in the user DB, and + -- we want the latter to take precedence. This is not the same + -- as shadowing (below), since in this case the two packages + -- have the same ABI and are interchangeable. + -- + -- #4072: note that we must retain the ordering of the list here + -- so that shadowing behaves as expected when we apply it later. + pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0 + where del p (s,ps) + | pid `Set.member` s = (s,ps) + | otherwise = (Set.insert pid s, p:ps) + where pid = installedPackageId p + -- XXX this is just a variant of nub + + ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] + + ipid_selected = depClosure ipid_map + [ InstalledPackageId (mkFastString i) + | ExposePackage (PackageIdArg i) _ <- flags ] + + (ignore_flags, other_flags) = partition is_ignore flags + is_ignore IgnorePackage{} = True + is_ignore _ = False + + shadowed = shadowPackages pkgs0_unique ipid_selected + ignored = ignorePackages ignore_flags pkgs0_unique + + isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId + pkgs0' = filter (not . isBroken) pkgs0_unique + + broken = findBroken pkgs0' + + unusable = shadowed `Map.union` ignored `Map.union` broken + pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0' + + reportUnusable dflags unusable + + -- + -- Calculate the initial set of packages, prior to any package flags. + -- This set contains the latest version of all valid (not unusable) packages, + -- or is empty if we have -hide-all-packages + -- + let preferLater pkg pkg' = + case comparing packageVersion pkg pkg' of + GT -> pkg + _ -> pkg' + calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg + initial = if gopt Opt_HideAllPackages dflags + then emptyUFM + else foldl' calcInitial emptyUFM pkgs1 + vis_map1 = foldUFM (\p vm -> + if exposed p + then addToUFM vm (packageConfigId p) + (True, [], fsPackageName p) + else vm) + emptyUFM initial + + -- + -- Modify the package database according to the command-line flags + -- (-package, -hide-package, -ignore-package, -hide-all-packages). + -- This needs to know about the unusable packages, since if a user tries + -- to enable an unusable package, we should let them know. + -- + (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable) + (pkgs1, vis_map1) other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the package keys of wired in packages, but when we process + -- package arguments we need to key against the old versions. We also + -- have to update the visibility map in the process. + -- + (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2 + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] + + get_exposed (ExposePackage a _) = take 1 . sortByVersion + . filter (matching a) + $ pkgs2 + get_exposed _ = [] + + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3 + + ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) + | p <- pkgs3 ] + + lookupIPID ipid + | Just pid <- Map.lookup ipid ipid_map = return pid + | otherwise = missingPackageErr dflags ipid + + preload2 <- mapM lookupIPID preload1 + + let + -- add base & rts to the preload packages + basicLinkedPackages + | gopt Opt_AutoLinkPackages dflags + = filter (flip elemUFM pkg_db) + [basePackageKey, rtsPackageKey] + | otherwise = [] + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + preload3 = nub $ filter (/= this_package) + $ (basicLinkedPackages ++ preload2) + + -- Close the preload packages with their dependencies + dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) + let new_dep_preload = filter (`notElem` preload0) dep_preload + + let pstate = PackageState{ + preloadPackages = dep_preload, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, + installedPackageIdMap = ipid_map + } + return (pstate, new_dep_preload, this_package) + + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from module to package info + +mkModuleToPkgConfAll + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = + foldl' extend_modmap emptyMap (eltsUFM pkg_db) + where + emptyMap = Map.empty + sing pk m _ = Map.singleton (mkModule pk m) + addListTo = foldl' merge + merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m + setOrigins m os = fmap (const os) m + extend_modmap modmap pkg = addListTo modmap theBindings + where + theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) + = newBindings b rns + | otherwise = newBindings False [] + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, Map Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, Map Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es e = do + -- TODO: signature support + ExposedModule m exposedReexport _exposedSignature <- exposed_mods + let (pk', m', pkg', origin') = + case exposedReexport of + Nothing -> (pk, m, pkg, fromExposedModules e) + Just (OriginalModule ipid' m') -> + let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' + in (pk', m', pkg', fromReexportedModules e pkg') + return (m, sing pk' m' pkg' origin') + + esmap :: UniqFM (Map Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Find all the include directories in these and the preload packages +getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String] +getPackageIncludePath dflags pkgs = + collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs + +collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) + +-- | Find all the library paths in these and the preload packages +getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String] +getPackageLibraryPath dflags pkgs = + collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs + +collectLibraryPaths :: [PackageConfig] -> [FilePath] +collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String]) +getPackageLinkOpts dflags pkgs = + collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) + +packageHsLibs :: DynFlags -> PackageConfig -> [String] +packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) + where + ways0 = ways dflags + + ways1 = filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc.so + -- we leave out the _dyn, because it is superfluous + + -- debug RTS includes support for -eventlog + ways2 | WayDebug `elem` ways1 + = filter (/= WayEventLog) ways1 + | otherwise + = ways1 + + tag = mkBuildTag (filter (not . wayRTSOnly) ways2) + rts_tag = mkBuildTag ways2 + + mkDynName x + | gopt Opt_Static dflags = x + | "HS" `isPrefixOf` x = + x ++ '-':programName dflags ++ projectVersion dflags + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + +-- | Find all the C-compiler options in these and the preload packages +getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap ccOptions ps) + +-- | Find all the package framework paths in these and the preload packages +getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap frameworkDirs ps))) + +-- | Find all the package frameworks in these and the preload packages +getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap frameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, PackageConfig)] +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags + (modulePackageKey m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module PackageConfig + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags m mb_pn + = case Map.lookup m (moduleToPkgConfAll pkg_state) of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[]) (Map.toList xs) of + ([], [], []) -> LookupNotFound suggestions + (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, exposed@(_:_)) -> LookupMultiple exposed + (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_pkg m) origin0 + x = (m, origin) + in case origin of + ModHidden -> (hidden_pkg, x:hidden_mod, exposed) + _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) + | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) + | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + + pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags + pkg_state = pkgState dflags + mod_pkg = pkg_lookup . modulePackageKey + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> PackageConfig + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + + suggestions + | gopt Opt_HelpfulErrors dflags = + fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where visible (_, ms) = any originVisible (Map.elems ms) + +-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of +-- 'PackageConfig's +getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig] +getPreloadPackagesAnd dflags pkgids = + let + state = pkgState dflags + pkg_map = pkgIdMap state + ipid_map = installedPackageIdMap state + preload = preloadPackages state + pairs = zip pkgids (repeat Nothing) + in do + all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) + return (map (getPackageDetails dflags) all_pkgs) + +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: DynFlags + -> PackageConfigMap + -> Map InstalledPackageId PackageKey + -> [(PackageKey, Maybe PackageKey)] + -> IO [PackageKey] +closeDeps dflags pkg_map ipid_map ps + = throwErr dflags (closeDepsErr pkg_map ipid_map ps) + +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r + +closeDepsErr :: PackageConfigMap + -> Map InstalledPackageId PackageKey + -> [(PackageKey,Maybe PackageKey)] + -> MaybeErr MsgDoc [PackageKey] +closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps + +-- internal helper +add_package :: PackageConfigMap + -> Map InstalledPackageId PackageKey + -> [PackageKey] + -> (PackageKey,Maybe PackageKey) + -> MaybeErr MsgDoc [PackageKey] +add_package pkg_db ipid_map ps (p, mb_parent) + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg p <> + missingDependencyMsg mb_parent) + Just pkg -> do + -- Add the package's dependents also + ps' <- foldM add_package_ipid ps (depends pkg) + return (p : ps') + where + add_package_ipid ps ipid + | Just pid <- Map.lookup ipid ipid_map + = add_package pkg_db ipid_map ps (pid, Just p) + | otherwise + = Failed (missingPackageMsg ipid + <> missingDependencyMsg mb_parent) + +missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a +missingPackageErr dflags p + = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p))) + +missingPackageMsg :: Outputable pkgid => pkgid -> SDoc +missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p + +missingDependencyMsg :: Maybe PackageKey -> SDoc +missingDependencyMsg Nothing = Outputable.empty +missingDependencyMsg (Just parent) + = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent)) + +-- ----------------------------------------------------------------------------- + +packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String +packageKeyPackageIdString dflags pkg_key + | pkg_key == mainPackageKey = Just "main" + | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key) + +-- | Will the 'Name' come from a dynamically linked library? +isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the synbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows +isDllName dflags _this_pkg this_mod name + | gopt Opt_Static dflags = False + | Just mod <- nameModule_maybe name + -- Issue #8696 - when GHC is dynamically linked, it will attempt + -- to load the dynamic dependencies of object files at compile + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. This is the cause of # + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = if mod /= this_mod + then True + else case dllSplit dflags of + Nothing -> False + Just ss -> + let findMod m = let modStr = moduleNameString (moduleName m) + in case find (modStr `Set.member`) ss of + Just i -> i + Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split") + in findMod mod /= findMod this_mod + + | otherwise = False -- no, it is not even an external name + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprPackages :: DynFlags -> SDoc +pprPackages = pprPackagesWith pprPackageConfig + +pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc +pprPackagesWith pprIPI dflags = + vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) + +-- | Show simplified package info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprPackagesSimple :: DynFlags -> SDoc +pprPackagesSimple = pprPackagesWith pprIPI + where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi + e = if exposed ipi then text "E" else text " " + t = if trusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: DynFlags -> SDoc +pprModuleMap dflags = + vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry m (m',o) + | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: PackageConfig -> FastString +fsPackageName = mkFastString . packageNameString diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot new file mode 100644 index 00000000..f2343b66 --- /dev/null +++ b/compiler/main/Packages.hs-boot @@ -0,0 +1,6 @@ +module Packages where +-- Well, this is kind of stupid... +import {-# SOURCE #-} Module (PackageKey) +import {-# SOURCE #-} DynFlags (DynFlags) +data PackageState +packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs new file mode 100644 index 00000000..c81f1f20 --- /dev/null +++ b/compiler/main/PipelineMonad.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module PipelineMonad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO + ) where + +import MonadUtils +import Outputable +import DynFlags +import DriverPhases +import HscTypes +import Module + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a +evalP f env st = liftM snd $ unP f env st + +instance Functor CompPipeline where + fmap = liftM + +instance Applicative CompPipeline where + pure = return + (<*>) = ap + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + pe_isHaskellishFile :: Bool, + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +data PipelineOutput + = Temporary + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) diff --git a/compiler/main/PlatformConstants.hs b/compiler/main/PlatformConstants.hs new file mode 100644 index 00000000..b2ca32be --- /dev/null +++ b/compiler/main/PlatformConstants.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- +-- | Platform constants +-- +-- (c) The University of Glasgow 2013 +-- +------------------------------------------------------------------------------- + +module PlatformConstants (PlatformConstants(..)) where + +#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellType.hs" + diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs new file mode 100644 index 00000000..d936e288 --- /dev/null +++ b/compiler/main/Plugins.hs @@ -0,0 +1,38 @@ +module Plugins ( + Plugin(..), CommandLineOption, + defaultPlugin + ) where + +import CoreMonad ( CoreToDo, CoreM ) +import TcRnTypes ( TcPlugin ) + + +-- | Command line options gathered from the -PModule.Name:stuff syntax +-- are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the core compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatability when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify the + -- pipeline in a nondeterministic order. + , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + } + +-- | Default plugin: does nothing at all! For compatability reasons +-- you should base all your plugin definitions on this default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + } diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs new file mode 100644 index 00000000..3e48ec3a --- /dev/null +++ b/compiler/main/PprTyThing.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing TyThings +-- +-- (c) The GHC Team 2005 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +module PprTyThing ( + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + pprTypeForUser, + pprFamInst + ) where + +#include "HsVersions.h" + +import TypeRep ( TyThing(..) ) +import CoAxiom ( coAxiomTyCon ) +import HscTypes( tyThingParent_maybe ) +import MkIface ( tyThingToIfaceDecl ) +import Type ( tidyOpenType ) +import IfaceSyn ( pprIfaceDecl, ShowSub(..), ShowHowMuch(..) ) +import FamInstEnv( FamInst( .. ), FamFlavor(..) ) +import TcType +import Name +import VarEnv( emptyTidyEnv ) +import Outputable +import FastString + +-- ----------------------------------------------------------------------------- +-- Pretty-printing entities that we get from the GHC API + +{- Note [Pretty-printing TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pretty-print a TyThing by converting it to an IfaceDecl, +and pretty-printing that (see ppr_ty_thing below). +Here is why: + +* When pretty-printing (a type, say), the idiomatic solution is not to + "rename type variables on the fly", but rather to "tidy" the type + (which gives each variable a distinct print-name), and then + pretty-print it (without renaming). Separate the two + concerns. Functions like tidyType do this. + +* Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* One alternative would be to ensure that TyCons get type variables + with distinct print-names. That's ok for type variables but less + easy for kind variables. Processing data type declarations is + already so complicated that I don't think it's sensible to add the + extra requirement that it generates only "pretty" types and kinds. + +* One place the non-pretty names can show up is in GHCi. But another + is in interface files. Look at MkIface.tyThingToIfaceDecl which + converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it + already does tidying as part of that conversion! Why? Because + interface files contains fast-strings, not uniques, so the names + must at least be distinct. + +So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can +print that. Of course, that means that pretty-printing IfaceDecls +must be careful to display nice user-friendly results, but that's ok. + +See #7730, #8776 for details -} + +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the representational TyCon, +-- because there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes + +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) + +---------------------------- +-- | Pretty-prints a 'TyThing' with its defining location. +pprTyThingLoc :: TyThing -> SDoc +pprTyThingLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) (pprTyThing tyThing) + +-- | Pretty-prints a 'TyThing'. +pprTyThing :: TyThing -> SDoc +pprTyThing = ppr_ty_thing False [] + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = ppr_ty_thing True [] + +-- | Pretty-prints a 'TyThing' in context: that is, if the entity +-- is a data constructor, record selector, or class method, then +-- the entity's parent declaration is pretty-printed with irrelevant +-- parts omitted. +pprTyThingInContext :: TyThing -> SDoc +pprTyThingInContext thing + = go [] thing + where + go ss thing = case tyThingParent_maybe thing of + Just parent -> go (getOccName thing : ss) parent + Nothing -> ppr_ty_thing False ss thing + +-- | Like 'pprTyThingInContext', but adds the defining location. +pprTyThingInContextLoc :: TyThing -> SDoc +pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext tyThing) + +------------------------ +ppr_ty_thing :: Bool -> [OccName] -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty-printing TyThings] +ppr_ty_thing hdr_only path ty_thing + = pprIfaceDecl ss (tyThingToIfaceDecl ty_thing) + where + ss = ShowSub { ss_how_much = how_much, ss_ppr_bndr = ppr_bndr } + how_much | hdr_only = ShowHeader + | otherwise = ShowSome path + name = getName ty_thing + ppr_bndr :: OccName -> SDoc + ppr_bndr | isBuiltInSyntax name + = ppr + | otherwise + = case nameModule_maybe name of + Just mod -> \ occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) ppr + -- Nothing is unexpected here; TyThings have External names + +pprTypeForUser :: Type -> SDoc +-- We do two things here. +-- a) We tidy the type, regardless +-- b) Swizzle the foralls to the top, so that without +-- -fprint-explicit-foralls we'll suppress all the foralls +-- Prime example: a class op might have type +-- forall a. C a => forall b. Ord b => stuff +-- Then we want to display +-- (C a, Ord b) => stuff +pprTypeForUser ty + = pprSigmaType (mkSigmaTy tvs ctxt tau) + where + (tvs, ctxt, tau) = tcSplitSigmaTy tidy_ty + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + -- Often the types/kinds we print in ghci are fully generalised + -- and have no free variables, but it turns out that we sometimes + -- print un-generalised kinds (eg when doing :k T), so it's + -- better to use tidyOpenType here + +showWithLoc :: SDoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = ptext (sLit "--") diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs new file mode 100644 index 00000000..914a1459 --- /dev/null +++ b/compiler/main/StaticFlags.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP, TupleSections #-} +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- Static flags +-- +-- Static flags can only be set once, on the command-line. Inside GHC, +-- each static flag corresponds to a top-level value, usually of type Bool. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module StaticFlags ( + -- entry point + parseStaticFlags, + + staticFlags, + initStaticOpts, + discardStaticFlags, + + -- Output style options + opt_PprStyle_Debug, + opt_NoDebugOutput, + + -- optimisation opts + opt_NoStateHack, + opt_CprOff, + opt_NoOptCoercion, + + -- For the parser + addOpt, removeOpt, v_opt_C_ready, + + -- For options autocompletion + flagsStatic, flagsStaticNames + ) where + +#include "HsVersions.h" + +import CmdLineParser +import FastString +import SrcLoc +import Util +-- import Maybes ( firstJusts ) +import Panic + +import Control.Monad +import Data.IORef +import System.IO.Unsafe ( unsafePerformIO ) + + +----------------------------------------------------------------------------- +-- Static flags + +-- | Parses GHC's static flags from a list of command line arguments. +-- +-- These flags are static in the sense that they can be set only once and they +-- are global, meaning that they affect every instance of GHC running; +-- multiple GHC threads will use the same flags. +-- +-- This function must be called before any session is started, i.e., before +-- the first call to 'GHC.withGhc'. +-- +-- Static flags are more of a hack and are static for more or less historical +-- reasons. In the long run, most static flags should eventually become +-- dynamic flags. +-- +-- XXX: can we add an auto-generated list of static flags here? +-- +parseStaticFlags :: [Located String] -> IO ([Located String], [Located String]) +parseStaticFlags = parseStaticFlagsFull flagsStatic + +-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also +-- takes a list of available static flags, such that certain flags can be +-- enabled or disabled through this argument. +parseStaticFlagsFull :: [Flag IO] -> [Located String] + -> IO ([Located String], [Located String]) +parseStaticFlagsFull flagsAvailable args = do + ready <- readIORef v_opt_C_ready + when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT") + + (leftover, errs, warns) <- processArgs flagsAvailable args + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ throwGhcExceptionIO $ + errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs + + -- see sanity code in staticOpts + writeIORef v_opt_C_ready True + return (leftover, warns) + +-- holds the static opts while they're being collected, before +-- being unsafely read by unpacked_static_opts below. +GLOBAL_VAR(v_opt_C, [], [String]) +GLOBAL_VAR(v_opt_C_ready, False, Bool) + + +staticFlags :: [String] +staticFlags = unsafePerformIO $ do + ready <- readIORef v_opt_C_ready + if (not ready) + then panic "Static flags have not been initialised!\n Please call GHC.parseStaticFlags early enough." + else readIORef v_opt_C + +-- All the static flags should appear in this list. It describes how each +-- static flag should be processed. Two main purposes: +-- (a) if a command-line flag doesn't appear in the list, GHC can complain +-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" +-- things +-- +-- The common (PassFlag addOpt) action puts the static flag into the bunch of +-- things that are searched up by the top-level definitions like +-- opt_foo = lookUp (fsLit "-dfoo") + +-- Note that ordering is important in the following list: any flag which +-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override +-- flags further down the list with the same prefix. + +-- see Note [Updating flag description in the User's Guide] in DynFlags +flagsStatic :: [Flag IO] +flagsStatic = [ + ------ Debugging ---------------------------------------------------- + defFlag "dppr-debug" (PassFlag addOptEwM) + , defFlag "dno-debug-output" (PassFlag addOptEwM) + -- rest of the debugging flags are dynamic + + ------ Compiler flags ----------------------------------------------- + -- All other "-fno-" options cancel out "-f" on the hsc cmdline + , defFlag "fno-" + (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s))) + + -- Pass all remaining "-f" options to hsc + , defFlag "f" (AnySuffixPred isStaticFlag addOptEwM) + ] + + + +isStaticFlag :: String -> Bool +isStaticFlag f = f `elem` flagsStaticNames + + +-- see Note [Updating flag description in the User's Guide] in DynFlags +flagsStaticNames :: [String] +flagsStaticNames = [ + "fno-state-hack", + "fno-opt-coercion", + "fcpr-off" + ] + +-- We specifically need to discard static flags for clients of the +-- GHC API, since they can't be safely reparsed or reinitialized. In general, +-- the existing flags do nothing other than control debugging and some low-level +-- optimizer phases, so for the most part this is OK. +-- +-- See GHC issue #8276: http://ghc.haskell.org/trac/ghc/ticket/8276#comment:37 +discardStaticFlags :: [String] -> [String] +discardStaticFlags = filter (\x -> x `notElem` flags) + where flags = [ "-fno-state-hack" + , "-fno-opt-coercion" + , "-fcpr-off" + , "-dppr-debug" + , "-dno-debug-output" + ] + + +initStaticOpts :: IO () +initStaticOpts = writeIORef v_opt_C_ready True + +addOpt :: String -> IO () +addOpt = consIORef v_opt_C + +removeOpt :: String -> IO () +removeOpt f = do + fs <- readIORef v_opt_C + writeIORef v_opt_C $! filter (/= f) fs + +type StaticP = EwM IO + +addOptEwM :: String -> StaticP () +addOptEwM = liftEwM . addOpt + +removeOptEwM :: String -> StaticP () +removeOptEwM = liftEwM . removeOpt + +packed_static_opts :: [FastString] +packed_static_opts = map mkFastString staticFlags + +lookUp :: FastString -> Bool +lookUp sw = sw `elem` packed_static_opts + +-- debugging options + +-- see Note [Updating flag description in the User's Guide] in DynFlags + +opt_PprStyle_Debug :: Bool +opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") + +opt_NoDebugOutput :: Bool +opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") + +opt_NoStateHack :: Bool +opt_NoStateHack = lookUp (fsLit "-fno-state-hack") + +-- Switch off CPR analysis in the new demand analyser +opt_CprOff :: Bool +opt_CprOff = lookUp (fsLit "-fcpr-off") + +opt_NoOptCoercion :: Bool +opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") + +{- +-- (lookup_str "foo") looks for the flag -foo=X or -fooX, +-- and returns the string X +lookup_str :: String -> Maybe String +lookup_str sw + = case firstJusts (map (stripPrefix sw) staticFlags) of + Just ('=' : str) -> Just str + Just str -> Just str + Nothing -> Nothing + +lookup_def_int :: String -> Int -> Int +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + +lookup_def_float :: String -> Float -> Float +lookup_def_float sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + +try_read :: Read a => String -> String -> a +-- (try_read sw str) tries to read s; if it fails, it +-- bleats about flag sw +try_read sw str + = case reads str of + ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses + [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) + -- ToDo: hack alert. We should really parse the arguments + -- and announce errors in a more civilised way. +-} + diff --git a/compiler/main/StaticFlags.hs-boot b/compiler/main/StaticFlags.hs-boot new file mode 100644 index 00000000..53ee13bf --- /dev/null +++ b/compiler/main/StaticFlags.hs-boot @@ -0,0 +1,4 @@ +module StaticFlags where + +opt_PprStyle_Debug :: Bool +opt_NoDebugOutput :: Bool diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs new file mode 100644 index 00000000..8c3ab1a8 --- /dev/null +++ b/compiler/main/SysTools.hs @@ -0,0 +1,1760 @@ +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2003 +-- +-- Access to system tools: gcc, cp, rm etc +-- +----------------------------------------------------------------------------- +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module SysTools ( + -- Initialisation + initSysTools, + + -- Interface to system tools + runUnlit, runCpp, runCc, -- [Option] -> IO () + runPp, -- [Option] -> IO () + runSplit, -- [Option] -> IO () + runAs, runLink, runLibtool, -- [Option] -> IO () + runMkDLL, + runWindres, + runLlvmOpt, + runLlvmLlc, + runClang, + figureLlvmVersion, + readElfSection, + + getLinkerInfo, + getCompilerInfo, + + linkDynLib, + + askCc, + + touch, -- String -> String -> IO () + copy, + copyWithHeader, + + -- Temporary-file management + setTmpDir, + newTempName, newTempLibName, + cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, + addFilesToClean, + + Option(..), + + -- frameworks + getPkgFrameworkOpts, + getFrameworkOpts + + + ) where + +#include "HsVersions.h" + +import DriverPhases +import Module +import Packages +import Config +import Outputable +import ErrUtils +import Panic +import Platform +import Util +import DynFlags +import Exception + +import Data.IORef +import Control.Monad +import System.Exit +import System.Environment +import System.FilePath +import System.IO +import System.IO.Error as IO +import System.Directory +import Data.Char +import Data.List +import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R + +#ifndef mingw32_HOST_OS +import qualified System.Posix.Internals +#else /* Must be Win32 */ +import Foreign +import Foreign.C.String +#endif + +import System.Process +import Control.Concurrent +import FastString +import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +{- +How GHC finds its files +~~~~~~~~~~~~~~~~~~~~~~~ + +[Note topdir] + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/bin/.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "bin/.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + + +SysTools.initSysProgs figures out exactly where all the auxiliary programs +are, and initialises mutable variables to make it easy to call them. +To to this, it makes use of definitions in Config.hs, which is a Haskell +file containing variables whose value is figured out by the build system. + +Config.hs contains two sorts of things + + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + + + cUNLIT_DIR The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) + + + +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + +************************************************************************ +* * +\subsection{Initialisation} +* * +************************************************************************ +-} + +initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) + -> IO Settings -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message +initSysTools mbMinusB + = do top_dir <- findTopDir mbMinusB + -- see [Note topdir] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + + let settingsFile = top_dir "settings" + platformConstantsFile = top_dir "platformConstants" + installed :: FilePath -> FilePath + installed file = top_dir file + + settingsStr <- readFile settingsFile + platformConstantsStr <- readFile platformConstantsFile + mySettings <- case maybeReadFuzzy settingsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ show settingsFile) + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ + show platformConstantsFile) + let getSetting key = case lookup key mySettings of + Just xs -> + return $ case stripPrefix "$topdir" xs of + Just [] -> + top_dir + Just xs'@(c:_) + | isPathSeparator c -> + top_dir ++ xs' + _ -> + xs + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + getBooleanSetting key = case lookup key mySettings of + Just "YES" -> return True + Just "NO" -> return False + Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs) + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + readSetting key = case lookup key mySettings of + Just xs -> + case maybeRead xs of + Just v -> return v + Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs) + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + crossCompiling <- getBooleanSetting "cross compiling" + targetArch <- readSetting "target arch" + targetOS <- readSetting "target os" + targetWordSize <- readSetting "target word size" + targetUnregisterised <- getBooleanSetting "Unregisterised" + targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack" + targetHasIdentDirective <- readSetting "target has .ident directive" + targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" + myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + gcc_prog <- getSetting "C compiler command" + gcc_args_str <- getSetting "C compiler flags" + cpp_prog <- getSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" + let unreg_gcc_args = if targetUnregisterised + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + -- TABLES_NEXT_TO_CODE affects the info table layout. + tntc_gcc_args + | mkTablesNextToCode targetUnregisterised + = ["-DTABLES_NEXT_TO_CODE"] + | otherwise = [] + cpp_args= map Option (words cpp_args_str) + gcc_args = map Option (words gcc_args_str + ++ unreg_gcc_args + ++ tntc_gcc_args) + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsBuildId <- getBooleanSetting "ld supports build-id" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + perl_path <- getSetting "perl command" + + let pkgconfig_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path = installed cGHC_UNLIT_PGM + + -- split is a Perl script + split_script = installed cGHC_SPLIT_PGM + + windres_path <- getSetting "windres command" + libtool_path <- getSetting "libtool command" + readelf_path <- getSetting "readelf command" + + tmpdir <- getTemporaryDirectory + + touch_path <- getSetting "touch command" + + let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend + -- a call to Perl to get the invocation of split. + -- On Unix, scripts are invoked using the '#!' method. Binary + -- installations of GHC on Unix place the correct line on the + -- front of the script at installation time, so we don't want + -- to wire-in our knowledge of $(PERL) on the host system here. + (split_prog, split_args) + | isWindowsHost = (perl_path, [Option split_script]) + | otherwise = (split_script, []) + mkdll_prog <- getSetting "dllwrap command" + let mkdll_args = [] + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, as and ld are simply gcc + gcc_link_args_str <- getSetting "C compiler link flags" + let as_prog = gcc_prog + as_args = gcc_args + ld_prog = gcc_prog + ld_args = gcc_args ++ map Option (words gcc_link_args_str) + + -- We just assume on command line + lc_prog <- getSetting "LLVM llc command" + lo_prog <- getSetting "LLVM opt command" + + let platform = Platform { + platformArch = targetArch, + platformOS = targetOS, + platformWordSize = targetWordSize, + platformUnregisterised = targetUnregisterised, + platformHasGnuNonexecStack = targetHasGnuNonexecStack, + platformHasIdentDirective = targetHasIdentDirective, + platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols, + platformIsCrossCompiling = crossCompiling + } + + return $ Settings { + sTargetPlatform = platform, + sTmpDir = normalise tmpdir, + sGhcUsagePath = ghc_usage_msg_path, + sGhciUsagePath = ghci_usage_msg_path, + sTopDir = top_dir, + sRawSettings = mySettings, + sExtraGccViaCFlags = words myExtraGccViaCFlags, + sSystemPackageConfig = pkgconfig_path, + sLdSupportsCompactUnwind = ldSupportsCompactUnwind, + sLdSupportsBuildId = ldSupportsBuildId, + sLdSupportsFilelist = ldSupportsFilelist, + sLdIsGnuLd = ldIsGnuLd, + sProgramName = "ghc", + sProjectVersion = cProjectVersion, + sPgm_L = unlit_path, + sPgm_P = (cpp_prog, cpp_args), + sPgm_F = "", + sPgm_c = (gcc_prog, gcc_args), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog, as_args), + sPgm_l = (ld_prog, ld_args), + sPgm_dll = (mkdll_prog,mkdll_args), + sPgm_T = touch_path, + sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + sPgm_windres = windres_path, + sPgm_libtool = libtool_path, + sPgm_readelf = readelf_path, + sPgm_lo = (lo_prog,[]), + sPgm_lc = (lc_prog,[]), + -- Hans: this isn't right in general, but you can + -- elaborate it in the same way as the others + sOpt_L = [], + sOpt_P = [], + sOpt_F = [], + sOpt_c = [], + sOpt_a = [], + sOpt_l = [], + sOpt_windres = [], + sOpt_lo = [], + sOpt_lc = [], + sPlatformConstants = platformConstants + } + +-- returns a Unix-format path (relying on getBaseDir to do so too) +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir (Just minusb) = return (normalise minusb) +findTopDir Nothing + = do -- Get directory of executable + maybe_exec_dir <- getBaseDir + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO (InstallationError "missing -B option") + Just dir -> return dir + +{- +************************************************************************ +* * +\subsection{Running an external program} +* * +************************************************************************ +-} + +runUnlit :: DynFlags -> [Option] -> IO () +runUnlit dflags args = do + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = do + let (p,args0) = pgm_P dflags + args1 = map Option (getOpts dflags opt_P) + args2 = if gopt Opt_WarnIsError dflags + then [Option "-Werror"] + else [] + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) mb_env + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (args ++ opts) + +runCc :: DynFlags -> [Option] -> IO () +runCc dflags args = do + let (p,args0) = pgm_c dflags + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter = unlines . doFilter . lines + + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +askCc :: DynFlags -> [Option] -> IO String +askCc dflags args = do + let (p,args0) = pgm_c dflags + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } + +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' + :: CreateProcess + -> IO (ExitCode, String) -- ^ stdout +readCreateProcessWithExitCode' proc = do + (_, Just outh, _, pid) <- + createProcess proc{ std_out = CreatePipe } + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length output) >> putMVar outMVar () + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + return (ex, output) + +readProcessEnvWithExitCode + :: String -- ^ program path + -> [String] -- ^ program args + -> [(String, String)] -- ^ environment to override + -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) +readProcessEnvWithExitCode prog args env_update = do + current_env <- getEnvironment + let new_env = env_update ++ [ (k, v) + | let overriden_keys = map fst env_update + , (k, v) <- current_env + , k `notElem` overriden_keys + ] + p = proc prog args + + (_stdin, Just stdoh, Just stdeh, pid) <- + createProcess p{ std_out = CreatePipe + , std_err = CreatePipe + , env = Just new_env + } + + outMVar <- newEmptyMVar + errMVar <- newEmptyMVar + + _ <- forkIO $ do + stdo <- hGetContents stdoh + _ <- evaluate (length stdo) + putMVar outMVar stdo + + _ <- forkIO $ do + stde <- hGetContents stdeh + _ <- evaluate (length stde) + putMVar errMVar stde + + out <- takeMVar outMVar + hClose stdoh + err <- takeMVar errMVar + hClose stdeh + + ex <- waitForProcess pid + + return (ex, out, err) + +-- Don't let gcc localize version info string, #8825 +en_locale_env :: [(String, String)] +en_locale_env = [("LANGUAGE", "en")] + +-- If the -B option is set, add to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (map mangle_path env)) + where + (b_dirs, _) = partitionWith get_b_opt opts + + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other + + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other + +runSplit :: DynFlags -> [Option] -> IO () +runSplit dflags args = do + let (p,args0) = pgm_s dflags + runSomething dflags "Splitter" p (args0++args) + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = do + let (p,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 mb_env + +-- | Run the LLVM Optimiser +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = do + let (p,args0) = pgm_lo dflags + args1 = map Option (getOpts dflags opt_lo) + runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args) + +-- | Run the LLVM Compiler +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = do + let (p,args0) = pgm_lc dflags + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + +-- | Run the clang compiler (used as an assembler for the LLVM +-- backend on OS X as LLVM doesn't support the OS X system +-- assembler) +runClang :: DynFlags -> [Option] -> IO () +runClang dflags args = do + -- we simply assume its available on the PATH + let clang = "clang" + -- be careful what options we call clang with + -- see #5903 and #7617 for bugs caused by this. + (_,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + Exception.catch (do + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env + ) + (\(err :: SomeException) -> do + errorMsg dflags $ + text ("Error running clang! you need clang installed to use the" ++ + "LLVM backend") $+$ + text "(or GHC tried to execute clang incorrectly)" + throwIO err + ) + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe Int) +figureLlvmVersion dflags = do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + ver <- catchIO (do + (pin, pout, perr, _) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + Low Level Virtual Machine (http://llvm.org/): + llvm version 2.8 (Ubuntu 2.8-0Ubuntu1) + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- hGetLine pout + v <- case filter isDigit vline of + [] -> fail "no digits!" + [x] -> fail $ "only 1 digit! (" ++ show x ++ ")" + (x:y:_) -> return ((read [x,y]) :: Int) + hClose pin + hClose pout + hClose perr + return $ Just v + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out LLVM version):" <+> + text (show err)) + errorMsg dflags $ vcat + [ text "Warning:", nest 9 $ + text "Couldn't figure out LLVM version!" $$ + text "Make sure you have installed LLVM"] + return Nothing) + return ver + +{- Note [Windows stack usage] + +See: Trac #8870 (and #8834 for related info) + +On Windows, occasionally we need to grow the stack. In order to do +this, we would normally just bump the stack pointer - but there's a +catch on Windows. + +If the stack pointer is bumped by more than a single page, then the +pages between the initial pointer and the resulting location must be +properly committed by the Windows virtual memory subsystem. This is +only needed in the event we bump by more than one page (i.e 4097 bytes +or more). + +Windows compilers solve this by emitting a call to a special function +called _chkstk, which does this committing of the pages for you. + +The reason this was causing a segfault was because due to the fact the +new code generator tends to generate larger functions, we needed more +stack space in GHC itself. In the x86 codegen, we needed approximately +~12kb of stack space in one go, which caused the process to segfault, +as the intervening pages were not committed. + +In the future, we should do the same thing, to make the problem +completely go away. In the mean time, we're using a workaround: we +instruct the linker to specify the generated PE as having an initial +reserved stack size of 8mb, as well as a initial *committed* stack +size of 8mb. The default committed size was previously only 4k. + +Theoretically it's possible to still hit this problem if you request a +stack bump of more than 8mb in one go. But the amount of code +necessary is quite large, and 8mb "should be more than enough for +anyone" right now (he said, before millions of lines of code cried out +in terror). + +-} + +{- Note [Run-time linker info] + +See also: Trac #5240, Trac #6063, Trac #10110 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + +{- Note [ELF needed shared libs] + +Some distributions change the link editor's default handling of +ELF DT_NEEDED tags to include only those shared objects that are +needed to resolve undefined symbols. For Template Haskell we need +the last temporary shared library also if it is not needed for the +currently linked temporary shared library. We specify --no-as-needed +to override the default. This flag exists in GNU ld and GNU gold. + +The flag is only needed on ELF systems. On Windows (PE) and Mac OS X +(Mach-O) the flag is not needed. + +-} + +{- Note [Windows static libGCC] + +The GCC versions being upgraded to in #10726 are configured with +dynamic linking of libgcc supported. This results in libgcc being +linked dynamically when a shared library is created. + +This introduces thus an extra dependency on GCC dll that was not +needed before by shared libraries created with GHC. This is a particular +issue on Windows because you get a non-obvious error due to this missing +dependency. This dependent dll is also not commonly on your path. + +For this reason using the static libgcc is preferred as it preserves +the same behaviour that existed before. There are however some very good +reasons to have the shared version as well as described on page 181 of +https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : + +"There are several situations in which an application should use the + shared ‘libgcc’ instead of the static version. The most common of these + is when the application wishes to throw and catch exceptions across different + shared libraries. In that case, each of the libraries as well as the application + itself should use the shared ‘libgcc’. " + +-} + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs (SolarisLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 + args3 = filter notNull (map showOpt args2) + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. Trac #5240. + -- Set DT_NEEDED for all shared libraries. Trac #10110. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads", + -- ELF specific flag + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold only needs --no-as-needed. Trac #10110. + -- ELF specific flag, see Note [ELF needed shared libs] + return (GnuGold [Option "-Wl,--no-as-needed"]) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSSolaris2 -> + -- Solaris uses its own Solaris linker. Even all + -- GNU C are recommended to configure with Solaris + -- linker instead of using GNU binutils linker. Also + -- all GCC distributed with Solaris follows this rule + -- precisely so we assume here, the Solaris linker is + -- used. + return $ SolarisLD [] + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSiOS -> + -- Ditto for iOS + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Increase default stack, see + -- Note [Windows stack usage] + -- Force static linking of libGCC + -- Note [Windows static libGCC] + , "-Xlinker", "--stack=0x800000,0x800000", "-static-libgcc" ] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm + (["-Wl,--version"] ++ args3) + en_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info + +-- Grab compiler info and cache it in DynFlags. +getCompilerInfo :: DynFlags -> IO CompilerInfo +getCompilerInfo dflags = do + info <- readIORef (rtccInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getCompilerInfo' dflags + writeIORef (rtccInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getCompilerInfo' :: DynFlags -> IO CompilerInfo +getCompilerInfo' dflags = do + let (pgm,_) = pgm_c dflags + -- Try to grab the info from the process output. + parseCompilerInfo _stdo stde _exitc + -- Regular GCC + | any ("gcc version" `isPrefixOf`) stde = + return GCC + -- Regular clang + | any ("clang version" `isPrefixOf`) stde = + return Clang + -- XCode 5.1 clang + | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = + return AppleClang51 + -- XCode 5 clang + | any ("Apple LLVM version" `isPrefixOf`) stde = + return AppleClang + -- XCode 4.1 clang + | any ("Apple clang version" `isPrefixOf`) stde = + return AppleClang + -- Unknown linker. + | otherwise = fail "invalid -v output, or compiler is unsupported" + + -- Process the executable call + info <- catchIO (do + (exitc, stdo, stde) <- + readProcessEnvWithExitCode pgm ["-v"] en_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. + parseCompilerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out C compiler information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out C compiler information!" $$ + text "Make sure you're using GNU gcc, or clang" + return UnknownCC) + return info + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = do + -- See Note [Run-time linker info] + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ linkargs ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + + +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" libtool args2 mb_env + +runMkDLL :: DynFlags -> [Option] -> IO () +runMkDLL dflags args = do + let (p,args0) = pgm_dll dflags + args1 = args0 ++ args + mb_env <- getGccEnv (args0++args) + runSomethingFiltered dflags id "Make DLL" p args1 mb_env + +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = do + let (gcc, gcc_args) = pgm_c dflags + windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (gcc : + map showOpt gcc_args ++ + map showOpt opts ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args + mb_env <- getGccEnv gcc_args + runSomethingFiltered dflags id "Windres" windres args' mb_env + +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = + runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] + +copy :: DynFlags -> String -> FilePath -> FilePath -> IO () +copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to + +copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath + -> IO () +copyWithHeader dflags purpose maybe_header from to = do + showPass dflags purpose + + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (header hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin + where + -- write the header string in UTF-8. The header is something like + -- {-# LINE "foo.hs" #-} + -- and we want to make sure a Unicode filename isn't mangled. + header h str = do + hSetEncoding h utf8 + hPutStr h str + hSetBinaryMode h True + +-- | read the contents of the named section in an ELF object as a +-- String. +readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) +readElfSection dflags section exe = do + let + prog = pgm_readelf dflags + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args)) + en_locale_env + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces + _ <- R.char '[' + skipSpaces + _ <- string "0]" + skipSpaces + munch (const True) + +{- +************************************************************************ +* * +\subsection{Managing temporary files +* * +************************************************************************ +-} + +cleanTempDirs :: DynFlags -> IO () +cleanTempDirs dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = dirsToClean dflags + ds <- atomicModifyIORef ref $ \ds -> (Map.empty, ds) + removeTmpDirs dflags (Map.elems ds) + +cleanTempFiles :: DynFlags -> IO () +cleanTempFiles dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + fs <- atomicModifyIORef ref $ \fs -> ([],fs) + removeTmpFiles dflags fs + +cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () +cleanTempFilesExcept dflags dont_delete + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + to_delete <- atomicModifyIORef ref $ \files -> + let (to_keep,to_delete) = partition (`elem` dont_delete) files + in (to_keep,to_delete) + removeTmpFiles dflags to_delete + + +-- Return a unique numeric temp file suffix +newTempSuffix :: DynFlags -> IO Int +newTempSuffix dflags = atomicModifyIORef (nextTempSuffix dflags) $ \n -> (n+1,n) + +-- Find a temporary name that doesn't already exist. +newTempName :: DynFlags -> Suffix -> IO FilePath +newTempName dflags extn + = do d <- getTempDir dflags + findTempName (d "ghc_") -- See Note [Deterministic base name] + where + findTempName :: FilePath -> IO FilePath + findTempName prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n <.> extn + b <- doesFileExist filename + if b then findTempName prefix + else do -- clean it up later + consIORef (filesToClean dflags) filename + return filename + +newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String) +newTempLibName dflags extn + = do d <- getTempDir dflags + findTempName d ("ghc_") + where + findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) + findTempName dir prefix + = do n <- newTempSuffix dflags -- See Note [Deterministic base name] + let libname = prefix ++ show n + filename = dir "lib" ++ libname <.> extn + b <- doesFileExist filename + if b then findTempName dir prefix + else do -- clean it up later + consIORef (filesToClean dflags) filename + return (filename, dir, libname) + + +-- Return our temporary directory within tmp_dir, creating one if we +-- don't have one yet. +getTempDir :: DynFlags -> IO FilePath +getTempDir dflags = do + mapping <- readIORef dir_ref + case Map.lookup tmp_dir mapping of + Nothing -> do + pid <- getProcessID + let prefix = tmp_dir "ghc" ++ show pid ++ "_" + mask_ $ mkTempDir prefix + Just dir -> return dir + where + tmp_dir = tmpDir dflags + dir_ref = dirsToClean dflags + + mkTempDir :: FilePath -> IO FilePath + mkTempDir prefix = do + n <- newTempSuffix dflags + let our_dir = prefix ++ show n + + -- 1. Speculatively create our new directory. + createDirectory our_dir + + -- 2. Update the dirsToClean mapping unless an entry already exists + -- (i.e. unless another thread beat us to it). + their_dir <- atomicModifyIORef dir_ref $ \mapping -> + case Map.lookup tmp_dir mapping of + Just dir -> (mapping, Just dir) + Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) + + -- 3. If there was an existing entry, return it and delete the + -- directory we created. Otherwise return the directory we created. + case their_dir of + Nothing -> do + debugTraceMsg dflags 2 $ + text "Created temporary directory:" <+> text our_dir + return our_dir + Just dir -> do + removeDirectory our_dir + return dir + `catchIO` \e -> if isAlreadyExistsError e + then mkTempDir prefix else ioError e + +-- Note [Deterministic base name] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The filename of temporary files, especially the basename of C files, can end +-- up in the output in some form, e.g. as part of linker debug information. In the +-- interest of bit-wise exactly reproducible compilation (#4012), the basename of +-- the temporary file no longer contains random information (it used to contain +-- the process id). +-- +-- This is ok, as the temporary directory used contains the pid (see getTempDir). + +addFilesToClean :: DynFlags -> [FilePath] -> IO () +-- May include wildcards [used by DriverPipeline.run_phase SplitMangle] +addFilesToClean dflags new_files + = atomicModifyIORef (filesToClean dflags) $ \files -> (new_files++files, ()) + +removeTmpDirs :: DynFlags -> [FilePath] -> IO () +removeTmpDirs dflags ds + = traceCmd dflags "Deleting temp dirs" + ("Deleting: " ++ unwords ds) + (mapM_ (removeWith dflags removeDirectory) ds) + +removeTmpFiles :: DynFlags -> [FilePath] -> IO () +removeTmpFiles dflags fs + = warnNon $ + traceCmd dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ (removeWith dflags removeFile) deletees) + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith dflags remover f = remover f `catchIO` + (\e -> + let msg = if isDoesNotExistError e + then ptext (sLit "Warning: deleting non-existent") <+> text f + else ptext (sLit "Warning: exception raised when deleting") + <+> text f <> colon + $$ text (show e) + in debugTraceMsg dflags 2 msg + ) + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: DynFlags + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args Nothing + +-- | Run a command, placing the arguments in an external response file. +-- +-- This command is used in order to avoid overlong command line arguments on +-- Windows. The command line arguments are first written to an external, +-- temporary response file, and then passed to the linker via @filepath. +-- response files for passing them in. See: +-- +-- https://gcc.gnu.org/wiki/Response_Files +-- https://ghc.haskell.org/trac/ghc/ticket/10777 +runSomethingResponseFile + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () + +runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = + runSomethingWith dflags phase_name pgm args $ \real_args -> do + fp <- getResponseFile real_args + let args = ['@':fp] + r <- builderMainLoop dflags filter_fn pgm args mb_env + return (r,()) + where + getResponseFile args = do + fp <- newTempName dflags "rsp" + withFile fp WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h $ unlines $ map escape args + return fp + + -- Note: Response files have backslash-escaping, double quoting, and are + -- whitespace separated (some implementations use newline, others any + -- whitespace character). Therefore, escape any backslashes, newlines, and + -- double quotes in the argument, and surround the content with double + -- quotes. + -- + -- Another possibility that could be considered would be to convert + -- backslashes in the argument to forward slashes. This would generally do + -- the right thing, since backslashes in general only appear in arguments + -- as part of file paths on Windows, and the forward slash is accepted for + -- those. However, escaping is more reliable, in case somehow a backslash + -- appears in a non-file. + escape x = concat + [ "\"" + , concatMap + (\c -> + case c of + '\\' -> "\\\\" + '\n' -> "\\n" + '\"' -> "\\\"" + _ -> [c]) + x + , "\"" + ] + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do + runSomethingWith dflags phase_name pgm args $ \real_args -> do + r <- builderMainLoop dflags filter_fn pgm real_args mb_env + return (r,()) + +runSomethingWith + :: DynFlags -> String -> String -> [Option] + -> ([String] -> IO (ExitCode, a)) + -> IO a + +runSomethingWith dflags phase_name pgm args io = do + let real_args = filter notNull (map showOpt args) + cmdLine = showCommandForUser pgm real_args + traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + +handleProc :: String -> String -> IO (ExitCode, r) -> IO r +handleProc pgm phase_name proc = do + (rc, r) <- proc `catchIO` handler + case rc of + ExitSuccess{} -> return r + ExitFailure n + -- rawSystem returns (ExitFailure 127) if the exec failed for any + -- reason (eg. the program doesn't exist). This is the only clue + -- we have, but we need to report something to the user because in + -- the case of a missing program there will otherwise be no output + -- at all. + | n == 127 -> does_not_exist + | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc) + where + handler err = + if IO.isDoesNotExistError err + then does_not_exist + else IO.ioError err + + does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) + + +builderMainLoop :: DynFlags -> (String -> String) -> FilePath + -> [String] -> Maybe [(String, String)] + -> IO ExitCode +builderMainLoop dflags filter_fn pgm real_args mb_env = do + chan <- newChan + (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env + + -- and run a loop piping the output from the compiler to the log_action in DynFlags + hSetBuffering hStdOut LineBuffering + hSetBuffering hStdErr LineBuffering + _ <- forkIO (readerProc chan hStdOut filter_fn) + _ <- forkIO (readerProc chan hStdErr filter_fn) + -- we don't want to finish until 2 streams have been completed + -- (stdout and stderr) + -- nor until 1 exit code has been retrieved. + rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess + -- after that, we're done here. + hClose hStdIn + hClose hStdOut + hClose hStdErr + return rc + where + -- status starts at zero, and increments each time either + -- a reader process gets EOF, or the build proc exits. We wait + -- for all of these to happen (status==3). + -- ToDo: we should really have a contingency plan in case any of + -- the threads dies, such as a timeout. + loop _ _ 0 0 exitcode = return exitcode + loop chan hProcess t p exitcode = do + mb_code <- if p > 0 + then getProcessExitCode hProcess + else return Nothing + case mb_code of + Just code -> loop chan hProcess t (p-1) code + Nothing + | t > 0 -> do + msg <- readChan chan + case msg of + BuildMsg msg -> do + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg + loop chan hProcess t p exitcode + BuildError loc msg -> do + log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + loop chan hProcess t p exitcode + EOF -> + loop chan hProcess (t-1) p exitcode + | otherwise -> loop chan hProcess t p exitcode + +readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (linesPlatform (filter_fn str)) Nothing) + `finally` + writeChan chan EOF + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. + where + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + _ -> panic "readerProc/loop" + + checkError l ls + = case parseError l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +parseError :: String -> Maybe (String, Int, Int, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (filename, lineNum, columnNum, s3) + Nothing -> + Just (filename, lineNum, 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +breakColon :: String -> Maybe (String, String) +breakColon xs = case break (':' ==) xs of + (ys, _:zs) -> Just (ys, zs) + _ -> Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc + | EOF + +traceCmd :: DynFlags -> String -> String -> IO a -> IO a +-- trace the command (at two levels of verbosity) +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; case flushErr dflags of + FlushErr io -> io + + -- And run it! + ; action `catchIO` handle_exn verb + } + where + handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) + ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) } + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ +-} + +----------------------------------------------------------------------------- +-- Define getBaseDir :: IO (Maybe String) + +getBaseDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe, +-- return the path $(stuff)/lib. +getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf + | otherwise -> try_size (size * 2) + + rootDir s = case splitFileName $ normalise s of + (d, ghc_exe) + | lower ghc_exe `elem` ["ghc.exe", + "ghc-stage1.exe", + "ghc-stage2.exe", + "ghc-stage3.exe"] -> + case splitFileName $ takeDirectory d of + -- ghc is in $topdir/bin/ghc.exe + (d', bin) | lower bin == "bin" -> takeDirectory d' "lib" + _ -> fail + _ -> fail + where fail = panic ("can't decompose ghc.exe path: " ++ show s) + lower = map toLower + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 +#else +getBaseDir = return Nothing +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif + +-- Divvy up text stream into lines, taking platform dependent +-- line termination into account. +linesPlatform :: String -> [String] +#if !defined(mingw32_HOST_OS) +linesPlatform ls = lines ls +#else +linesPlatform "" = [] +linesPlatform xs = + case lineBreak xs of + (as,xs1) -> as : linesPlatform xs1 + where + lineBreak "" = ("","") + lineBreak ('\r':'\n':xs) = ([],xs) + lineBreak ('\n':xs) = ([],xs) + lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) + +#endif + +linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO () +linkDynLib dflags0 o_files dep_packages + = do + let -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 + else dflags1 + dflags = updateWays dflags2 + + verbFlags = getVerbFlags dflags + o_file = outputFile dflags + + pkgs <- getPreloadPackagesAnd dflags dep_packages + + let pkg_lib_paths = collectLibraryPaths pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | ( osElfTarget (platformOS (targetPlatform dflags)) || + osMachOTarget (platformOS (targetPlatform dflags)) ) && + dynLibLoader dflags == SystemDependent && + not (gopt Opt_Static dflags) + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + -- We don't want to link our dynamic libs against the RTS package, + -- because the RTS lib comes in several flavours and we want to be + -- able to pick the flavour when a binary is linked. + -- On Windows we need to link the RTS import lib as Windows does + -- not allow undefined symbols. + -- The RTS library path is still added to the library search path + -- above in case the RTS is being explicitly linked in (see #3807). + let platform = targetPlatform dflags + os = platformOS platform + pkgs_no_rts = case os of + OSMinGW32 -> + pkgs + _ -> + filter ((/= rtsPackageKey) . packageConfigId) pkgs + let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts + in package_hs_libs ++ extra_libs ++ other_flags + + -- probably _stub.o files + -- and last temporary shared object file + let extra_ld_inputs = ldInputs dflags + + -- frameworks + pkg_framework_opts <- getPkgFrameworkOpts dflags platform + (map packageKey pkgs) + let framework_opts = getFrameworkOpts dflags platform + + case os of + OSMinGW32 -> do + ------------------------------------------------------------- + -- Making a DLL + ------------------------------------------------------------- + let output_fn = case o_file of + Just s -> s + Nothing -> "HSdll.dll" + + runLink dflags ( + map Option verbFlags + ++ [ Option "-o" + , FileOption "" output_fn + , Option "-shared" + ] ++ + [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | gopt Opt_SharedImplib dflags + ] + ++ map (FileOption "") o_files + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ [Option "-Wl,--enable-auto-import"] + + ++ extra_ld_inputs + ++ map Option ( + lib_path_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + )) + OSDarwin -> do + ------------------------------------------------------------------- + -- Making a darwin dylib + ------------------------------------------------------------------- + -- About the options used for Darwin: + -- -dynamiclib + -- Apple's way of saying -shared + -- -undefined dynamic_lookup: + -- Without these options, we'd have to specify the correct + -- dependencies for each of the dylibs. Note that we could + -- (and should) do without this for all libraries except + -- the RTS; all we need to do is to pass the correct + -- HSfoo_dyn.dylib files to the link command. + -- This feature requires Mac OS X 10.3 or later; there is + -- a similar feature, -flat_namespace -undefined suppress, + -- which works on earlier versions, but it has other + -- disadvantages. + -- -single_module + -- Build the dynamic library as a single "module", i.e. no + -- dynamic binding nonsense when referring to symbols from + -- within the library. The NCG assumes that this option is + -- specified (on i386, at least). + -- -install_name + -- Mac OS/X stores the path where a dynamic library is (to + -- be) installed in the library itself. It's called the + -- "install name" of the library. Then any library or + -- executable that links against it before it's installed + -- will search for it in its ultimate install location. + -- By default we set the install name to the absolute path + -- at build time, but it can be overridden by the + -- -dylib-install-name option passed to ghc. Cabal does + -- this. + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) + runLink dflags ( + map Option verbFlags + ++ [ Option "-dynamiclib" + , Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup", + Option "-single_module" ] + ++ (if platformArch platform == ArchX86_64 + then [ ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts + ++ extra_ld_inputs + ++ map Option framework_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ++ map Option pkg_framework_opts + ) + OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target") + _ -> do + ------------------------------------------------------------------- + -- Making a DSO + ------------------------------------------------------------------- + + let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + let buildingRts = thisPackage dflags == rtsPackageKey + let bsymbolicFlag = if buildingRts + then -- -Bsymbolic breaks the way we implement + -- hooks in the RTS + [] + else -- we need symbolic linking to resolve + -- non-PIC intra-package-relocations + ["-Wl,-Bsymbolic"] + + runLink dflags ( + map Option verbFlags + ++ [ Option "-o" + , FileOption "" output_fn + ] + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag + -- Set the library soname. We use -h rather than -soname as + -- Solaris 10 doesn't support the latter: + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] + ++ extra_ld_inputs + ++ map Option lib_path_opts + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) + +getPkgFrameworkOpts :: DynFlags -> Platform -> [PackageKey] -> IO [String] +getPkgFrameworkOpts dflags platform dep_packages + | platformUsesFrameworks platform = do + pkg_framework_path_opts <- do + pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages + return $ map ("-F" ++) pkg_framework_paths + + pkg_framework_opts <- do + pkg_frameworks <- getPackageFrameworks dflags dep_packages + return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] + + return (pkg_framework_path_opts ++ pkg_framework_opts) + + | otherwise = return [] + +getFrameworkOpts :: DynFlags -> Platform -> [String] +getFrameworkOpts dflags platform + | platformUsesFrameworks platform = framework_path_opts ++ framework_opts + | otherwise = [] + where + framework_paths = frameworkPaths dflags + framework_path_opts = map ("-F" ++) framework_paths + + frameworks = cmdlineFrameworks dflags + -- reverse because they're added in reverse order from the cmd line: + framework_opts = concat [ ["-framework", fw] + | fw <- reverse frameworks ] diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs new file mode 100644 index 00000000..a616dde3 --- /dev/null +++ b/compiler/main/TidyPgm.hs @@ -0,0 +1,1463 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Tidying up Core} +-} + +{-# LANGUAGE CPP #-} + +module TidyPgm ( + mkBootModDetailsTc, tidyProgram, globaliseAndTidyId + ) where + +#include "HsVersions.h" + +import TcRnTypes +import DynFlags +import CoreSyn +import CoreUnfold +import CoreFVs +import CoreTidy +import CoreMonad +import CorePrep +import CoreUtils +import CoreLint +import Literal +import Rules +import PatSyn +import ConLike +import CoreArity ( exprArity, exprBotStrictness_maybe ) +import VarEnv +import VarSet +import Var +import Id +import MkId ( mkDictSelRhs ) +import IdInfo +import InstEnv +import FamInstEnv +import Type ( tidyTopType ) +import Demand ( appIsBottom, isNopSig, isBottomingSig ) +import BasicTypes +import Name hiding (varName) +import NameSet +import NameEnv +import Avail +import IfaceEnv +import TcEnv +import TcRnMonad +import DataCon +import TyCon +import Class +import Module +import Packages( isDllName ) +import HscTypes +import Maybes +import UniqSupply +import ErrUtils (Severity(..)) +import Outputable +import FastBool hiding ( fastOr ) +import SrcLoc +import FastString +import qualified ErrUtils as Err + +import Control.Monad +import Data.Function +import Data.List ( sortBy ) +import Data.IORef ( atomicModifyIORef ) + +{- +Constructing the TypeEnv, Instances, Rules, VectInfo from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +************************************************************************ +* * + Plan A: simpleTidyPgm +* * +************************************************************************ + + +Plan A: mkBootModDetails: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Caf and Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +* If this an hsig file, drop the instances altogether too (they'll + get pulled in by the implicit module import. +-} + +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc hsc_env + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts + } + = do { let dflags = hsc_dflags hsc_env + ; showPassIO dflags CoreTidy + + ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts + ; type_env1 = mkBootTypeEnv (availsToNameSet exports) + (typeEnvIds type_env) tcs fam_insts + ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns + ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 + ; dfun_ids = map instanceDFunId insts' + ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids + } + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_vect_info = noVectInfo + }) + } + where + +mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv +mkBootTypeEnv exports ids tcs fam_insts + = tidyTypeEnv True $ + typeEnvFromEntities final_ids tcs fam_insts + where + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ if isLocalId id then globaliseAndTidyId id + else id + | id <- ids + , keep_it id ] + + -- default methods have their export flag set, but everything + -- else doesn't (yet), because this is pre-desugaring, so we + -- must test both. + keep_it id = isExportedId id || idName id `elemNameSet` exports + + + +globaliseAndTidyId :: Id -> Id +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood) +globaliseAndTidyId id + = Id.setIdType (globaliseId id) tidy_type + where + tidy_type = tidyTopType (idType id) + +{- +************************************************************************ +* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +* * +************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Figure out which Ids are externally visible + +* Tidy the bindings, externalising appropriate Ids + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Step 1: Figure out external Ids +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [choosing external names] + +See also the section "Interface stability" in the +RecompilationAvoidance commentary: + http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance + +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) ones mentioned in the unfoldings, workers, + rules of externally-visible ones , + or vectorised versions of externally-visible ones + +While figuring out which Ids are external, we pick a "tidy" OccName +for each one. That is, we make its OccName distinct from the other +external OccNames in this module, so that in interface files and +object code we can refer to it unambiguously by its OccName. The +OccName for each binder is prefixed by the name of the exported Id +that references it; e.g. if "f" references "x" in its unfolding, then +"x" is renamed to "f_x". This helps distinguish the different "x"s +from each other, and means that if "f" is later removed, things that +depend on the other "x"s will not need to be recompiled. Of course, +if there are multiple "f_x"s, then we have to disambiguate somehow; we +use "f_x0", "f_x1" etc. + +As far as possible we should assign names in a deterministic fashion. +Each time this module is compiled with the same options, we should end +up with the same set of external names with the same types. That is, +the ABI hash in the interface should not change. This turns out to be +quite tricky, since the order of the bindings going into the tidy +phase is already non-deterministic, as it is based on the ordering of +Uniques, which are assigned unpredictably. + +To name things in a stable way, we do a depth-first-search of the +bindings, starting from the exports sorted by name. This way, as long +as the bindings themselves are deterministic (they sometimes aren't!), +the order in which they are presented to the tidying phase does not +affect the names we assign. + +Step 2: Tidy the program +~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the NameCache kept in the HscEnv as the + source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. Rename top-level Ids according to the names we chose in step 1. + If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator + to decide whether to make the label externally visible + + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS + + +Finally, substitute these new top-level binders consistently +throughout, including in unfoldings. We also tidy binders in +RHSs, so that they print nicely in interfaces. +-} + +tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram hsc_env (ModGuts { mg_module = mod + , mg_exports = exports + , mg_rdr_env = rdr_env + , mg_tcs = tcs + , mg_insts = cls_insts + , mg_fam_insts = fam_insts + , mg_binds = binds + , mg_patsyns = patsyns + , mg_rules = imp_rules + , mg_vect_info = vect_info + , mg_anns = anns + , mg_deps = deps + , mg_foreign = foreign_stubs + , mg_hpc_info = hpc_info + , mg_modBreaks = modBreaks + }) + + = do { let { dflags = hsc_dflags hsc_env + ; omit_prags = gopt Opt_OmitInterfacePragmas dflags + ; expose_all = gopt Opt_ExposeAllUnfoldings dflags + ; print_unqual = mkPrintUnqualified dflags rdr_env + } + ; showPassIO dflags CoreTidy + + ; let { type_env = typeEnvFromEntities [] tcs fam_insts + + ; implicit_binds + = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ + concatMap getTyConImplicitBinds (typeEnvTyCons type_env) + } + + ; (unfold_env, tidy_occ_env) + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules (vectInfoVar vect_info) + ; let { (trimmed_binds, trimmed_rules) + = findExternalRules omit_prags binds imp_rules unfold_env } + + ; (tidy_env, tidy_binds) + <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + + ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] + ; type_env1 = extendTypeEnvWithIds type_env final_ids + + ; tidy_cls_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) cls_insts + -- A DFunId will have a binding in tidy_binds, and so will now be in + -- tidy_type_env, replete with IdInfo. Its name will be unchanged since + -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_cls_insts. Similarly the Ids inside a PatSyn. + + ; tidy_rules = tidyRules tidy_env trimmed_rules + -- You might worry that the tidy_env contains IdInfo-rich stuff + -- and indeed it does, but if omit_prags is on, ext_rules is + -- empty + + ; tidy_vect_info = tidyVectInfo tidy_env vect_info + + -- Tidy the Ids inside each PatSyn, very similarly to DFunIds + -- and then override the PatSyns in the type_env with the new tidy ones + -- This is really the only reason we keep mg_patsyns at all; otherwise + -- they could just stay in type_env + ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns + ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 + + ; tidy_type_env = tidyTypeEnv omit_prags type_env2 + + -- See Note [Injecting implicit bindings] + ; all_tidy_binds = implicit_binds ++ tidy_binds + + -- get the TyCons to generate code for. Careful! We must use + -- the untidied TypeEnv here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + } + + ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + ; unless (dopt Opt_D_dump_simpl dflags) $ + Err.dumpIfSet_dyn dflags Opt_D_dump_rules + (showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules"))) + (pprRulesForUser tidy_rules) + + -- Print one-line size info + ; let cs = coreBindsStats tidy_binds + ; when (dopt Opt_D_dump_core_stats dflags) + (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (ptext (sLit "Tidy size (terms,types,coercions)") + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs) )) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = foreign_stubs, + cg_dep_pkgs = map fst $ dep_pkgs deps, + cg_hpc_info = hpc_info, + cg_modBreaks = modBreaks }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_cls_insts, + md_vect_info = tidy_vect_info, + md_fam_insts = fam_insts, + md_exports = exports, + md_anns = anns -- are already tidy + }) + } + +lookup_aux_id :: TypeEnv -> Var -> Id +lookup_aux_id type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _other -> pprPanic "lookup_aux_id" (ppr id) + +tidyTypeEnv :: Bool -- Compiling without -O, so omit prags + -> TypeEnv -> TypeEnv + +-- The competed type environment is gotten from +-- a) the types and classes defined here (plus implicit things) +-- b) adding Ids with correct IdInfo, including unfoldings, +-- gotten from the bindings +-- From (b) we keep only those Ids with External names; +-- the CoreTidy pass makes sure these are all and only +-- the externally-accessible ones +-- This truncates the type environment to include only the +-- exported Ids and things needed from them, which saves space +-- +-- See Note [Don't attempt to trim data types] + +tidyTypeEnv omit_prags type_env + = let + type_env1 = filterNameEnv (not . isWiredInName . getName) type_env + -- (1) remove wired-in things + type_env2 | omit_prags = mapNameEnv trimThing type_env1 + | otherwise = type_env1 + -- (2) trimmed if necessary + in + type_env2 + +-------------------------- +trimThing :: TyThing -> TyThing +-- Trim off inessentials, for boot files and no -O +trimThing (AnId id) + | not (isImplicitId id) + = AnId (id `setIdInfo` vanillaIdInfo) + +trimThing other_thing + = other_thing + +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + +tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo +tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars + , vectInfoParallelVars = parallelVars + }) + = info { vectInfoVar = tidy_vars + , vectInfoParallelVars = tidy_parallelVars + } + where + -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is + -- inconsistent) + tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v)) + | (var, var_v) <- varEnvElts vars + , let tidy_var = lookup_var var + tidy_var_v = lookup_var var_v + , isExternalId tidy_var && isExportedId tidy_var + , isExternalId tidy_var_v && isExportedId tidy_var_v + , isDataConWorkId var || not (isImplicitId var) + ] + + tidy_parallelVars = mkVarSet [ tidy_var + | var <- varSetElems parallelVars + , let tidy_var = lookup_var var + , isExternalId tidy_var && isExportedId tidy_var + ] + + lookup_var var = lookupWithDefaultVarEnv var_env var var + + -- We need to make sure that all names getting into the iface version of 'VectInfo' are + -- external; otherwise, 'MkIface' will bomb out. + isExternalId = isExternalName . idName + +{- +Note [Don't attempt to trim data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some time GHC tried to avoid exporting the data constructors +of a data type if it wasn't strictly necessary to do so; see Trac #835. +But "strictly necessary" accumulated a longer and longer list +of exceptions, and finally I gave up the battle: + + commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 + Author: Simon Peyton Jones + Date: Thu Dec 6 16:03:16 2012 +0000 + + Stop attempting to "trim" data types in interface files + + Without -O, we previously tried to make interface files smaller + by not including the data constructors of data types. But + there are a lot of exceptions, notably when Template Haskell is + involved or, more recently, DataKinds. + + However Trac #7445 shows that even without TemplateHaskell, using + the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ + is enough to require us to expose the data constructors. + + So I've given up on this "optimisation" -- it's probably not + important anyway. Now I'm simply not attempting to trim off + the data constructors. The gain in simplicity is worth the + modest cost in interface file growth, which is limited to the + bits reqd to describe those data constructors. + +************************************************************************ +* * + Implicit bindings +* * +************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inject the implicit bindings right at the end, in CoreTidy. +Some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. That is +why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of +optimisation first. (Only matters when the selector is used curried; +eg map x ys.) See Trac #2070. + +[Oct 09: in fact, record selectors are no longer implicit Ids at all, +because we really do want to optimise them properly. They are treated +much like any other Id. But doing "light" optimisation on an implicit +Id still makes sense.] + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +because GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (Trac #2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + + - If implicit Ids are already in the bindings when we start TidyPgm, + we'd have to be careful not to treat them as external Ids (in + the sense of chooseExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing refererring to a18 (because the implicit Id is the + one that does, and implicit Ids don't appear in interface files). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +There is one sort of implicit binding that is injected still later, +namely those for data constructor workers. Reason (I think): it's +really just a code generation trick.... binding itself makes no sense. +See Note [Data constructor workers] in CorePrep. +-} + +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) + +{- +************************************************************************ +* * +\subsection{Step 1: finding externals} +* * +************************************************************************ + +See Note [Choosing external names]. +-} + +type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be + -- visible in the interface file. + -- + -- Bool => expose unfolding or not. + +chooseExternalIds :: HscEnv + -> Module + -> Bool -> Bool + -> [CoreBind] + -> [CoreBind] + -> [CoreRule] + -> VarEnv (Var, Var) + -> IO (UnfoldEnv, TidyOccEnv) + -- Step 1 from the notes above + +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } + where + nc_var = hsc_NC hsc_env + + -- init_ext_ids is the intial list of Ids that should be + -- externalised. It serves as the starting point for finding a + -- deterministic, tidy, renaming for all external Ids in this + -- module. + -- + -- It is sorted, so that it has adeterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ + filter is_external binders + + -- An Id should be external if either (a) it is exported, + -- (b) it appears in the RHS of a local rule for an imported Id, or + -- (c) it is the vectorised version of an imported Id + -- See Note [Which rules to expose] + is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules + vect_var_vs = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var] + + binders = bindersOfBinds binds + implicit_binders = bindersOfBinds implicit_binds + binder_set = mkVarSet binders + + avoids = [getOccName name | bndr <- binders ++ implicit_binders, + let name = idName bndr, + isExternalName name ] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + -- In particular, the set of binders doesn't include + -- implicit Ids at this stage. + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_occ_env = initTidyOccEnv avoids + + + search :: [(Id,Id)] -- The work-list: (external id, referrring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id + -> UnfoldEnv -- id -> (new Name, show_unfold) + -> TidyOccEnv -- occ env for choosing new Names + -> IO (UnfoldEnv, TidyOccEnv) + + search [] unfold_env occ_env = return (unfold_env, occ_env) + + search ((idocc,referrer) : rest) unfold_env occ_env + | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env + | otherwise = do + (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc + let + (new_ids, show_unfold) + | omit_prags = ([], False) + | otherwise = addExternal expose_all refined_id + + -- add vectorised version if any exists + new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc) + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> WARN( True, ppr idocc ) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer + -- + search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env' + + tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv + -> IO (UnfoldEnv, TidyOccEnv) + tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) + tidy_internal (id:ids) unfold_env occ_env = do + (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id + let unfold_env' = extendVarEnv unfold_env id (name',False) + tidy_internal ids unfold_env' occ_env' + +addExternal :: Bool -> Id -> ([Id], Bool) +addExternal expose_all id = (new_needed_ids, show_unfold) + where + new_needed_ids = bndrFvsInOrder show_unfold id + idinfo = idInfo id + show_unfold = show_unfolding (unfoldingInfo idinfo) + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) + bottoming_fn = isBottomingSig (strictnessInfo idinfo) + + -- Stuff to do with the Id's unfolding + -- We leave the unfolding there even if there is a worker + -- In GHCi the unfolding is used by importers + + show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly + + || isStableSource src -- Always expose things whose + -- source is an inline rule + + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guidance) + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False + +{- +************************************************************************ +* * + Deterministic free variables +* * +************************************************************************ + +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. + +See Note [Choosing external names] +-} + +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) + +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state + +instance Functor DFFV where + fmap = liftM + +instance Applicative DFFV where + pure = return + (<*>) = ap + +instance Monad DFFV where + return a = DFFV $ \_ st -> (st, a) + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) + +insert :: Var -> DFFV () +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + + +dffvExpr :: CoreExpr -> DFFV () +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick _other e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: (t, [Var], CoreExpr) -> DFFV () +dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) + | not (isId x) = dffvExpr r + | otherwise = dffvLetBndr False x >> dffvExpr r + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! + +dffvLetBndr :: Bool -> Id -> DFFV () +-- Gather the free vars of the RULES and unfolding of a binder +-- We always get the free vars of a *stable* unfolding, but +-- for a *vanilla* one (InlineRhs), the flag controls what happens: +-- True <=> get fvs of even a *vanilla* unfolding +-- False <=> ignore an InlineRhs +-- For nested bindings (call from dffvBind) we always say "False" because +-- we are taking the fvs of the RHS anyway +-- For top-level bindings (call from addExternal, via bndrFvsInOrder) +-- we say "True" if we are exposing that unfolding +dffvLetBndr vanilla_unfold id + = do { go_unf (unfoldingInfo idinfo) + ; mapM_ go_rule (specInfoRules (specInfo idinfo)) } + where + idinfo = idInfo id + + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + = case src of + InlineRhs | vanilla_unfold -> dffvExpr rhs + | otherwise -> return () + _ -> dffvExpr rhs + + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) + +{- +************************************************************************ +* * + findExternalRules +* * +************************************************************************ + +Note [Finding external rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The complete rules are gotten by combining + a) local rules for imported Ids + b) rules embedded in the top-level Ids + +There are two complications: + * Note [Which rules to expose] + * Note [Trimming auto-rules] + +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function 'expose_rule' filters out rules that mention, on the LHS, +Ids that aren't externally visible; these rules can't fire in a client +module. + +The externally-visible binders are computed (by chooseExternalIds) +assuming that all orphan rules are externalised (see init_ext_ids in +function 'search'). So in fact it's a bit conservative and we may +export more than we need. (It's a sort of mutual recursion.) + +Note [Trimming auto-rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Second, with auto-specialisation we may specialise local or imported +dfuns or INLINE functions, and then later inline them. That may leave +behind something like + RULE "foo" forall d. f @ Int d = f_spec +where f is either local or imported, and there is no remaining +reference to f_spec except from the RULE. + +Now that RULE *might* be useful to an importing module, but that is +purely speculative, and meanwhile the code is taking up space and +codegen time. So is seeems better to drop the binding for f_spec if +the auto-generated rule is the *only* reason that it is being kept +alive. + +(The RULE still might have been useful in the past; that is, it was +the right thing to have generated it in the first place. See Note +[Inline specialisations] in Specialise. But now it has served its +purpose, and can be discarded.) + +So findExternalRules does this: + * Remove all bindings that are kept alive *only* by isAutoRule rules + (this is done in trim_binds) + * Remove all auto rules that mention bindings that have been removed + (this is done by filtering by keep_rule) + +So if a binding is kept alive for some *other* reason (e.g. f_spec is +called in the final code), we keep the rule too. + +I found that binary sizes jumped by 6-10% when I started to specialise +INLINE functions (again, Note [Inline specialisations] in Specialise). +Adding trimAutoRules removed all this bloat. +-} + +findExternalRules :: Bool -- Omit pragmas + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> ([CoreBind], [CoreRule]) +-- See Note [Finding external rules] +findExternalRules omit_prags binds imp_id_rules unfold_env + = (trimmed_binds, filter keep_rule all_rules) + where + imp_rules = filter expose_rule imp_id_rules + imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules + + user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet + | otherwise = ruleRhsFreeVars rule + + (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds + + keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs + -- Remove rules that make no sense, because they mention a + -- local binder (on LHS or RHS) that we have now discarded. + -- (NB: ruleFreeVars only includes LocalIds) + -- + -- LHS: we have alrady filtered out rules that mention internal Ids + -- on LHS but that isn't enough because we might have by now + -- discarded a binding with an external Id. (How? + -- chooseExternalIds is a bit conservative.) + -- + -- RHS: the auto rules that might mention a binder that has + -- been discarded; see Note [Trimming auto-rules] + + expose_rule rule + | omit_prags = False + | otherwise = all is_external_id (varSetElems (ruleLhsFreeIds rule)) + -- Don't expose a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module). NB: ruleLhsFreeIds only returns LocalIds. + -- See Note [Which rules to expose] + + is_external_id id = case lookupVarEnv unfold_env id of + Just (name, _) -> isExternalName name + Nothing -> False + + trim_binds :: [CoreBind] + -> ( [CoreBind] -- Trimmed bindings + , VarSet -- Binders of those bindings + , VarSet -- Free vars of those bindings + rhs of user rules + -- (we don't bother to delete the binders) + , [CoreRule]) -- All rules, imported + from the bindings + -- This function removes unnecessary bindings, and gathers up rules from + -- the bindings we keep. See Note [Trimming auto-rules] + trim_binds [] -- Base case, start with imp_user_rule_fvs + = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) + + trim_binds (bind:binds) + | any needed bndrs -- Keep binding + = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) + | otherwise -- Discard binding altogether + = stuff + where + stuff@(binds', bndr_set, needed_fvs, rules) + = trim_binds binds + needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs + + bndrs = bindersOf bind + rhss = rhssOfBind bind + bndr_set' = bndr_set `extendVarSetList` bndrs + + needed_fvs' = needed_fvs `unionVarSet` + mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` + -- Ignore type variables in the type of bndrs + mapUnionVarSet exprFreeVars rhss `unionVarSet` + mapUnionVarSet user_rule_rhs_fvs local_rules + -- In needed_fvs', we don't bother to delete binders from the fv set + + local_rules = [ rule + | id <- bndrs + , is_external_id id -- Only collect rules for external Ids + , rule <- idCoreRules id + , expose_rule rule ] -- and ones that can fire in a client + +{- +************************************************************************ +* * + tidyTopName +* * +************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. +-} + +tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var maybe_ref occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { new_local_name <- atomicModifyIORef nc_var mk_new_local + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { new_external_name <- atomicModifyIORef nc_var mk_new_external + ; return (occ_env', new_external_name) } + + | otherwise = panic "tidyTopName" + where + name = idName id + external = isJust maybe_ref + global = isExternalName name + local = not global + internal = not external + loc = nameSrcSpan name + + old_occ = nameOccName name + new_occ + | Just ref <- maybe_ref, ref /= id = + mkOccName (occNameSpace old_occ) $ + let + ref_str = occNameString (getOccName ref) + occ_str = occNameString old_occ + in + case occ_str of + '$':'w':_ -> occ_str + -- workers: the worker for a function already + -- includes the occname for its parent, so there's + -- no need to prepend the referrer. + _other | isSystemName name -> ref_str + | otherwise -> ref_str ++ '_' : occ_str + -- If this name was system-generated, then don't bother + -- to retain its OccName, just use the referrer. These + -- system-generated names will become "f1", "f2", etc. for + -- a referrer "f". + | otherwise = old_occ + + (occ_env', occ') = tidyOccName occ_env new_occ + + mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) + where + (uniq, us) = takeUniqFromSupply (nsUniqs nc) + + mk_new_external nc = allocateGlobalBinder nc mod occ' loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + +{- +************************************************************************ +* * +\subsection{Step 2: top-level tidying} +* * +************************************************************************ +-} + +-- TopTidyEnv: when tidying we need to know +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: HscEnv + -> Module + -> UnfoldEnv + -> TidyOccEnv + -> CoreProgram + -> IO (TidyEnv, CoreProgram) + +tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env + integerSDataCon <- lookupIntegerSDataConName dflags hsc_env + let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon + return $ tidy cvt_integer init_env binds + where + dflags = hsc_dflags hsc_env + + init_env = (init_occ_env, emptyVarEnv) + + this_pkg = thisPackage dflags + + tidy _ env [] = (env, []) + tidy cvt_integer env (b:bs) + = let (env1, b') = tidyTopBind dflags this_pkg this_mod + cvt_integer unfold_env env b + (env2, bs') = tidy cvt_integer env1 bs + in (env2, b':bs') + +------------------------ +tidyTopBind :: DynFlags + -> PackageKey + -> Module + -> (Integer -> CoreExpr) + -> UnfoldEnv + -> TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env + (occ_env,subst1) (NonRec bndr rhs) + = (tidy_env2, NonRec bndr' rhs') + where + Just (name',show_unfold) = lookupVarEnv unfold_env bndr + caf_info = hasCafRefs dflags this_pkg this_mod (subst1, cvt_integer) (idArity bndr) rhs + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) + subst2 = extendVarEnv subst1 bndr bndr' + tidy_env2 = (occ_env, subst2) + +tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env + (occ_env, subst1) (Rec prs) + = (tidy_env2, Rec prs') + where + prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) + | (id,rhs) <- prs, + let (name',show_unfold) = + expectJust "tidyTopBind" $ lookupVarEnv unfold_env id + ] + + subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + tidy_env2 = (occ_env, subst2) + + bndrs = map fst prs + + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod + (subst1, cvt_integer) + (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs + +----------------------------------------------------------- +tidyTopPair :: DynFlags + -> Bool -- show unfolding + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) + = (bndr1, rhs1) + where + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) + show_unfold caf_info + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info. This must also remain valid through to code generation. +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. +tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr + -> IdInfo -> Bool -> CafInfo -> IdInfo +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + `setOccInfo` robust_occ_info + `setInlinePragInfo` (inlinePragInfo idinfo) + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where + is_external = isExternalName name + + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + mb_bot_str = exprBotStrictness_maybe orig_rhs + + sig = strictnessInfo idinfo + final_sig | not $ isNopSig sig + = WARN( _bottom_hidden sig , ppr name ) sig + -- try a cheap-and-cheerful bottom analyser + | Just (_, nsig) <- mb_bot_str = nsig + | otherwise = sig + + _bottom_hidden id_sig = case mb_bot_str of + Nothing -> False + Just (arity, _) -> not (appIsBottom id_sig arity) + + --------- Unfolding ------------ + unf_info = unfoldingInfo idinfo + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs + | otherwise = noUnfolding + unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs + is_bot = isBottomingSig final_sig + -- NB: do *not* expose the worker if show_unfold is off, + -- because that means this thing is a loop breaker or + -- marked NOINLINE or something like that + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See Trac #1709 + -- + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs + +{- +************************************************************************ +* * +\subsection{Figuring out CafInfo for an expression} +* * +************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +Note [Disgusting computation of CafRefs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute hasCafRefs here, because IdInfo is supposed to be finalised +after TidyPgm. But CorePrep does some transformations that affect CAF-hood. +So we have to *predict* the result here, which is revolting. + +In particular CorePrep expands Integer literals. So in the prediction code +here we resort to applying the same expansion (cvt_integer). Ugh! +-} + +type CafRefEnv = (VarEnv Id, Integer -> CoreExpr) + -- The env finds the Caf-ness of the Id + -- The Integer -> CoreExpr is the desugaring function for Integer literals + -- See Note [Disgusting computation of CafRefs] + +hasCafRefs :: DynFlags -> PackageKey -> Module + -> CafRefEnv -> Arity -> CoreExpr + -> CafInfo +hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr + | is_caf || mentions_cafs = MayHaveCafRefs + | otherwise = NoCafRefs + where + mentions_cafs = isFastTrue (cafRefsE p expr) + is_dynamic_name = isDllName dflags this_pkg this_mod + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr) + + -- NB. we pass in the arity of the expression, which is expected + -- to be calculated by exprArity. This is because exprArity + -- knows how much eta expansion is going to be done by + -- CorePrep later on, and we don't want to duplicate that + -- knowledge in rhsIsStatic below. + +cafRefsE :: CafRefEnv -> Expr a -> FastBool +cafRefsE p (Var id) = cafRefsV p id +cafRefsE p (Lit lit) = cafRefsL p lit +cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a +cafRefsE p (Lam _ e) = cafRefsE p e +cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e +cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) +cafRefsE p (Tick _n e) = cafRefsE p e +cafRefsE p (Cast e _co) = cafRefsE p e +cafRefsE _ (Type _) = fastBool False +cafRefsE _ (Coercion _) = fastBool False + +cafRefsEs :: CafRefEnv -> [Expr a] -> FastBool +cafRefsEs _ [] = fastBool False +cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es + +cafRefsL :: CafRefEnv -> Literal -> FastBool +-- Don't forget that mk_integer id might have Caf refs! +-- We first need to convert the Integer into its final form, to +-- see whether mkInteger is used. +cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i) +cafRefsL _ _ = fastBool False + +cafRefsV :: CafRefEnv -> Id -> FastBool +cafRefsV (subst, _) id + | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) + | Just id' <- lookupVarEnv subst id = fastBool (mayHaveCafRefs (idCafInfo id')) + | otherwise = fastBool False + +fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) + +{- +------------------------------------------------------------------------------ +-- Old, dead, type-trimming code +------------------------------------------------------------------------------- + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (Trac #7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (Trac #2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declartion of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (Trac #5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +-} diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs new file mode 100644 index 00000000..ac657dd5 --- /dev/null +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -0,0 +1,1136 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- This is the top-level module in the native code generator. +-- +-- ----------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-} + +module AsmCodeGen ( nativeCodeGen ) where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" + + +import qualified X86.CodeGen +import qualified X86.Regs +import qualified X86.Instr +import qualified X86.Ppr + +import qualified SPARC.CodeGen +import qualified SPARC.Regs +import qualified SPARC.Instr +import qualified SPARC.Ppr +import qualified SPARC.ShortcutJump +import qualified SPARC.CodeGen.Expand + +import qualified PPC.CodeGen +import qualified PPC.Regs +import qualified PPC.RegInfo +import qualified PPC.Instr +import qualified PPC.Ppr + +import RegAlloc.Liveness +import qualified RegAlloc.Linear.Main as Linear + +import qualified GraphColor as Color +import qualified RegAlloc.Graph.Main as Color +import qualified RegAlloc.Graph.Stats as Color +import qualified RegAlloc.Graph.TrivColorable as Color + +import TargetReg +import Platform +import Config +import Instruction +import PIC +import Reg +import NCGMonad +import Dwarf +import Debug + +import BlockId +import CgUtils ( fixStgRegisters ) +import Cmm +import CmmUtils +import Hoopl +import CmmOpt ( cmmMachOpFold ) +import PprCmm +import CLabel + +import UniqFM +import UniqSupply +import DynFlags +import Util +import Unique + +import BasicTypes ( Alignment ) +import Digraph +import qualified Pretty +import BufWrite +import Outputable +import FastString +import UniqSet +import ErrUtils +import Module +import Stream (Stream) +import qualified Stream + +-- DEBUGGING ONLY +--import OrdList + +import Data.List +import Data.Maybe +import Data.Ord ( comparing ) +import Control.Exception +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif +import Control.Monad +import System.IO + +{- +The native-code generator has machine-independent and +machine-dependent modules. + +This module ("AsmCodeGen") is the top-level machine-independent +module. Before entering machine-dependent land, we do some +machine-independent optimisations (defined below) on the +'CmmStmts's. + +We convert to the machine-specific 'Instr' datatype with +'cmmCodeGen', assuming an infinite supply of registers. We then use +a machine-independent register allocator ('regAlloc') to rejoin +reality. Obviously, 'regAlloc' has machine-specific helper +functions (see about "RegAllocInfo" below). + +Finally, we order the basic blocks of the function so as to minimise +the number of jumps between blocks, by utilising fallthrough wherever +possible. + +The machine-dependent bits break down as follows: + + * ["MachRegs"] Everything about the target platform's machine + registers (and immediate operands, and addresses, which tend to + intermingle/interact with registers). + + * ["MachInstrs"] Includes the 'Instr' datatype (possibly should + have a module of its own), plus a miscellany of other things + (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) + + * ["MachCodeGen"] is where 'Cmm' stuff turns into + machine instructions. + + * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really + a 'SDoc'). + + * ["RegAllocInfo"] In the register allocator, we manipulate + 'MRegsState's, which are 'BitSet's, one bit per machine register. + When we want to say something about a specific machine register + (e.g., ``it gets clobbered by this instruction''), we set/unset + its bit. Obviously, we do this 'BitSet' thing for efficiency + reasons. + + The 'RegAllocInfo' module collects together the machine-specific + info needed to do register allocation. + + * ["RegisterAlloc"] The (machine-independent) register allocator. +-} + +-- ----------------------------------------------------------------------------- +-- Top-level of the native codegen + +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), + getJumpDestBlockId :: jumpDest -> Maybe BlockId, + canShortcut :: instr -> Maybe jumpDest, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, + pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, + maxSpillSlots :: Int, + allocatableRegs :: [RealReg], + ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], + ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], + ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr), + ncgMakeFarBranches :: BlockEnv CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr] + } + +-------------------- +nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply + -> Stream IO RawCmmGroup () + -> IO UniqSupply +nativeCodeGen dflags this_mod modLoc h us cmms + = let platform = targetPlatform dflags + nCG' :: (Outputable statics, Outputable instr, Instruction instr) + => NcgImpl statics instr jumpDest -> IO UniqSupply + nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms + in case platformArch platform of + ArchX86 -> nCG' (x86NcgImpl dflags) + ArchX86_64 -> nCG' (x86_64NcgImpl dflags) + ArchPPC -> nCG' (ppcNcgImpl dflags) + ArchSPARC -> nCG' (sparcNcgImpl dflags) + ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" + ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" + ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" + ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" + ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" + ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" + ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" + ArchJavaScript -> panic "nativeCodeGen: No NCG for JavaScript" + +x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest +x86NcgImpl dflags + = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge } + +x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest +x86_64NcgImpl dflags + = NcgImpl { + cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags + ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId + ,canShortcut = X86.Instr.canShortcut + ,shortcutStatics = X86.Instr.shortcutStatics + ,shortcutJump = X86.Instr.shortcutJump + ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl + ,maxSpillSlots = X86.Instr.maxSpillSlots dflags + ,allocatableRegs = X86.Regs.allocatableRegs platform + ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform + ,ncgExpandTop = id + ,ncgMakeFarBranches = const id + } + where platform = targetPlatform dflags + +ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest +ppcNcgImpl dflags + = NcgImpl { + cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags + ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId + ,canShortcut = PPC.RegInfo.canShortcut + ,shortcutStatics = PPC.RegInfo.shortcutStatics + ,shortcutJump = PPC.RegInfo.shortcutJump + ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl + ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags + ,allocatableRegs = PPC.Regs.allocatableRegs platform + ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform + ,ncgExpandTop = id + ,ncgMakeFarBranches = PPC.Instr.makeFarBranches + } + where platform = targetPlatform dflags + +sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest +sparcNcgImpl dflags + = NcgImpl { + cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags + ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId + ,canShortcut = SPARC.ShortcutJump.canShortcut + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics + ,shortcutJump = SPARC.ShortcutJump.shortcutJump + ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl + ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags + ,allocatableRegs = SPARC.Regs.allocatableRegs + ,ncg_x86fp_kludge = id + ,ncgAllocMoreStack = noAllocMoreStack + ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop + ,ncgMakeFarBranches = const id + } + +-- +-- Allocating more stack space for spilling is currently only +-- supported for the linear register allocator on x86/x86_64, the rest +-- default to the panic below. To support allocating extra stack on +-- more platforms provide a definition of ncgAllocMoreStack. +-- +noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr) +noAllocMoreStack amount _ + = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" + ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" + ++ " is a known limitation in the linear allocator.\n" + ++ "\n" + ++ " Try enabling the graph colouring allocator with -fregs-graph instead." + ++ " You can still file a bug report if you like.\n" + + +-- | Data accumulated during code generation. Mostly about statistics, +-- but also collects debug data for DWARF generation. +data NativeGenAcc statics instr + = NGS { ngs_imports :: ![[CLabel]] + , ngs_natives :: ![[NatCmmDecl statics instr]] + -- ^ Native code generated, for statistics. This might + -- hold a lot of data, so it is important to clear this + -- field as early as possible if it isn't actually + -- required. + , ngs_colorStats :: ![[Color.RegAllocStats statics instr]] + , ngs_linearStats :: ![[Linear.RegAllocStats]] + , ngs_labels :: ![Label] + , ngs_debug :: ![DebugBlock] + , ngs_dwarfFiles :: !DwarfFiles + } + +nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> Handle + -> UniqSupply + -> Stream IO RawCmmGroup () + -> IO UniqSupply +nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms + = do + -- BufHandle is a performance hack. We could hide it inside + -- Pretty if it weren't for the fact that we do lots of little + -- printDocs here (in order to do codegen in constant space). + bufh <- newBufHandle h + let ngs0 = NGS [] [] [] [] [] [] emptyUFM + (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us + cmms ngs0 + finishNativeGen dflags modLoc bufh us' ngs + +finishNativeGen :: Instruction instr + => DynFlags + -> ModLocation + -> BufHandle + -> UniqSupply + -> NativeGenAcc statics instr + -> IO UniqSupply +finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs + = do + -- Write debug data and finish + let emitDw = gopt Opt_Debug dflags && not (gopt Opt_SplitObjs dflags) + us' <- if not emitDw then return us else do + (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) + emitNativeCode dflags bufh dwarf + return us' + bFlush bufh + + -- dump global NCG stats for graph coloring allocator + let stats = concat (ngs_colorStats ngs) + when (not (null stats)) $ do + + -- build the global register conflict graph + let graphGlobal + = foldl Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] + + dump_stats (Color.pprStats stats graphGlobal) + + let platform = targetPlatform dflags + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal + + + -- dump global NCG stats for linear allocator + let linearStats = concat (ngs_linearStats ngs) + when (not (null linearStats)) $ + dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) + + -- write out the imports + Pretty.printDoc Pretty.LeftMode (pprCols dflags) h + $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) + $ makeImportsDoc dflags (concat (ngs_imports ngs)) + return us' + where + dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" + +cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> BufHandle + -> UniqSupply + -> Stream IO RawCmmGroup () + -> NativeGenAcc statics instr + -> IO (NativeGenAcc statics instr, UniqSupply) + +cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs + = do r <- Stream.runStream cmm_stream + case r of + Left () -> + return (ngs { ngs_imports = reverse $ ngs_imports ngs + , ngs_natives = reverse $ ngs_natives ngs + , ngs_colorStats = reverse $ ngs_colorStats ngs + , ngs_linearStats = reverse $ ngs_linearStats ngs + }, + us) + Right (cmms, cmm_stream') -> do + + -- Generate debug information + let debugFlag = gopt Opt_Debug dflags + !ndbgs | debugFlag = cmmDebugGen modLoc cmms + | otherwise = [] + dbgMap = debugToMap ndbgs + + -- Insert split marker, generate native code + let splitFlag = gopt Opt_SplitObjs dflags + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $ + ofBlockList (panic "split_marker_entry") [] + cmms' | splitFlag = split_marker : cmms + | otherwise = cmms + (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us + cmms' ngs 0 + + -- Link native code information into debug blocks + let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs + dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" + (vcat $ map ppr ldbgs) + + -- Emit & clear DWARF information when generating split + -- object files, as we need it to land in the same object file + (ngs'', us'') <- + if debugFlag && splitFlag + then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs + emitNativeCode dflags h dwarf + return (ngs' { ngs_debug = [] + , ngs_dwarfFiles = emptyUFM + , ngs_labels = [] }, + us'') + else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs + , ngs_labels = [] }, + us') + + cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'' + cmm_stream' ngs'' + +-- | Do native code generation on all these cmms. +-- +cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> BufHandle + -> LabelMap DebugBlock + -> UniqSupply + -> [RawCmmDecl] + -> NativeGenAcc statics instr + -> Int + -> IO (NativeGenAcc statics instr, UniqSupply) + +cmmNativeGens _ _ _ _ _ _ us [] ngs !_ + = return (ngs, us) + +cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us + (cmm : cmms) ngs count + = do + let fileIds = ngs_dwarfFiles ngs + (us', fileIds', native, imports, colorStats, linearStats) + <- {-# SCC "cmmNativeGen" #-} + cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap + cmm count + + -- Generate .file directives for every new file that has been + -- used. Note that it is important that we generate these in + -- ascending order, as Clang's 3.6 assembler complains. + let newFileIds = sortBy (comparing snd) $ eltsUFM $ fileIds' `minusUFM` fileIds + pprDecl (f,n) = ptext (sLit "\t.file ") <> ppr n <+> + doubleQuotes (ftext f) + + emitNativeCode dflags h $ vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDecl ncgImpl) native + + -- force evaluation all this stuff to avoid space leaks + {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) + + let !labels' = if gopt Opt_Debug dflags + then cmmDebugLabels isMetaInstr native else [] + !natives' = if dopt Opt_D_dump_asm_stats dflags + then native : ngs_natives ngs else [] + mCon = maybe id (:) + ngs' = ngs{ ngs_imports = imports : ngs_imports ngs + , ngs_natives = natives' + , ngs_colorStats = colorStats `mCon` ngs_colorStats ngs + , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs + , ngs_labels = ngs_labels ngs ++ labels' + , ngs_dwarfFiles = fileIds' + } + cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us' + cmms ngs' (count + 1) + + where seqString [] = () + seqString (x:xs) = x `seq` seqString xs + + +emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () +emitNativeCode dflags h sdoc = do + + {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h + $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) sdoc + + -- dump native code + dumpIfSet_dyn dflags + Opt_D_dump_asm "Asm code" + sdoc + +-- | Complete native code generation phase for a single top-level chunk of Cmm. +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats +cmmNativeGen + :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> Module -> ModLocation + -> NcgImpl statics instr jumpDest + -> UniqSupply + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , DwarfFiles + , [NatCmmDecl statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + +cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count + = do + let platform = targetPlatform dflags + + -- rewrite assignments to global regs + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters dflags cmm + + -- cmm to cmm optimisations + let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} + cmmToCmm dflags this_mod fixed_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" + (pprCmmGroup [opt_cmm]) + + -- generate native code from cmm + let ((native, lastMinuteImports, fileIds'), usGen) = + {-# SCC "genMachCode" #-} + initUs us $ genMachCode dflags this_mod modLoc + (cmmTopCodeGen ncgImpl) + fileIds dbgMap opt_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_asm_native "Native code" + (vcat $ map (pprNatCmmDecl ncgImpl) native) + + -- tag instructions with register liveness information + let (withLiveness, usLive) = + {-# SCC "regLiveness" #-} + initUs usGen + $ mapM (regLiveness platform) + $ map natCmmTopToLive native + + dumpIfSet_dyn dflags + Opt_D_dump_asm_liveness "Liveness annotations added" + (vcat $ map ppr withLiveness) + + -- allocate registers + (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- + if False + -- Disabled, see #7679, #8657 + -- ( gopt Opt_RegsGraph dflags + -- || gopt Opt_RegsIterative dflags) + then do + -- the regs usable for allocation + let (alloc_regs :: UniqFM (UniqSet RealReg)) + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) + emptyUFM + $ allocatableRegs ncgImpl + + -- do the graph coloring register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ Color.regAlloc + dflags + alloc_regs + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + withLiveness + + -- dump out what happened during register allocation + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc_stages "Build/spill stages" + (vcat $ map (\(stage, stats) + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage + $$ ppr stats) + $ zip [0..] regAllocStats) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just regAllocStats else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , mPprStats + , Nothing) + + else do + -- do linear register allocation + let reg_alloc proc = do + (alloced, maybe_more_stack, ra_stats) <- + Linear.regAlloc dflags proc + case maybe_more_stack of + Nothing -> return ( alloced, ra_stats ) + Just amount -> do + alloced' <- ncgAllocMoreStack ncgImpl amount alloced + return (alloced', ra_stats ) + + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ liftM unzip + $ mapM reg_alloc withLiveness + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , Nothing + , mPprStats) + + ---- x86fp_kludge. This pass inserts ffree instructions to clear + ---- the FPU stack on x86. The x86 ABI requires that the FPU stack + ---- is clear, and library functions can return odd results if it + ---- isn't. + ---- + ---- NB. must happen before shortcutBranches, because that + ---- generates JXX_GBLs which we can't fix up in x86fp_kludge. + let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables ncgImpl kludged + + ---- shortcut branches + let shorted = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags ncgImpl tabled + + ---- sequence blocks + let sequenced = + {-# SCC "sequenceBlocks" #-} + map (sequenceTop ncgImpl) shorted + + ---- expansion of SPARC synthetic instrs + let expanded = + {-# SCC "sparc_expand" #-} + ncgExpandTop ncgImpl sequenced + + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + (vcat $ map (pprNatCmmDecl ncgImpl) expanded) + + return ( usAlloc + , fileIds' + , expanded + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) + + +x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr +x86fp_kludge top@(CmmData _ _) = top +x86fp_kludge (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code) + + +-- | Build a doc for all the imports. +-- +makeImportsDoc :: DynFlags -> [CLabel] -> SDoc +makeImportsDoc dflags imports + = dyld_stubs imports + $$ + -- On recent versions of Darwin, the linker supports + -- dead-stripping of code and data on a per-symbol basis. + -- There's a hack to make this work in PprMach.pprNatCmmDecl. + (if platformHasSubsectionsViaSymbols platform + then text ".subsections_via_symbols" + else Outputable.empty) + $$ + -- On recent GNU ELF systems one can mark an object file + -- as not requiring an executable stack. If all objects + -- linked into a program have this note then the program + -- will not use an executable stack, which is good for + -- security. GHC generated code does not need an executable + -- stack so add the note in: + (if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\",@progbits" + else Outputable.empty) + $$ + -- And just because every other compiler does, let's stick in + -- an identifier directive: .ident "GHC x.y.z" + (if platformHasIdentDirective platform + then let compilerIdent = text "GHC" <+> text cProjectVersion + in text ".ident" <+> doubleQuotes compilerIdent + else Outputable.empty) + + where + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> SDoc +{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ + map head $ group $ sort imps-} + -- (Hack) sometimes two Labels pretty-print the same, but have + -- different uniques; so we compare their text versions... + dyld_stubs imps + | needImportedSymbols dflags arch os + = vcat $ + (pprGotDeclaration dflags arch os :) $ + map ( pprImportedSymbol dflags platform . fst . head) $ + groupBy (\(_,a) (_,b) -> a == b) $ + sortBy (\(_,a) (_,b) -> compare a b) $ + map doPpr $ + imps + | otherwise + = Outputable.empty + + doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) + astyle = mkCodeStyle AsmStyle + + +-- ----------------------------------------------------------------------------- +-- Sequencing the basic blocks + +-- Cmm BasicBlocks are self-contained entities: they always end in a +-- jump, either non-local or to another basic block in the same proc. +-- In this phase, we attempt to place the basic blocks in a sequence +-- such that as many of the local jumps as possible turn into +-- fallthroughs. + +sequenceTop + :: Instruction instr + => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr + +sequenceTop _ top@(CmmData _ _) = top +sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks) + +-- The algorithm is very simple (and stupid): we make a graph out of +-- the blocks where there is an edge from one block to another iff the +-- first block ends by jumping to the second. Then we topologically +-- sort this graph. Then traverse the list: for each block, we first +-- output the block, then if it has an out edge, we move the +-- destination of the out edge to the front of the list, and continue. + +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in Hoopl. + +sequenceBlocks + :: Instruction instr + => BlockEnv i + -> [NatBasicBlock instr] + -> [NatBasicBlock instr] + +sequenceBlocks _ [] = [] +sequenceBlocks infos (entry:blocks) = + seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) + -- the first block is the entry point ==> it must remain at the start. + + +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC ( NatBasicBlock instr + , BlockId + , [BlockId])] + +sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) + +-- we're only interested in the last instruction of +-- the block, and only if it has a single destination. +getOutEdges + :: Instruction instr + => [instr] -> [BlockId] + +getOutEdges instrs + = case jumpDestsOfInstr (last instrs) of + [one] -> [one] + _many -> [] + +mkNode :: (Instruction t) + => GenBasicBlock t + -> (GenBasicBlock t, BlockId, [BlockId]) +mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs) + +seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])] + -> [GenBasicBlock t1] +seqBlocks infos blocks = placeNext pullable0 todo0 + where + -- pullable: Blocks that are not yet placed + -- todo: Original order of blocks, to be followed if we have no good + -- reason not to; + -- may include blocks that have already been placed, but then + -- these are not in pullable + pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ] + todo0 = [i | (_,i,_) <- blocks ] + + placeNext _ [] = [] + placeNext pullable (i:rest) + | Just (block, pullable') <- lookupDeleteUFM pullable i + = place pullable' rest block + | otherwise + -- We already placed this block, so ignore + = placeNext pullable rest + + place pullable todo (block,[]) + = block : placeNext pullable todo + place pullable todo (block@(BasicBlock id instrs),[next]) + | mapMember next infos + = block : placeNext pullable todo + | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next + = BasicBlock id (init instrs) : place pullable' todo nextBlock + | otherwise + = block : placeNext pullable todo + place _ _ (_,tooManyNextNodes) + = pprPanic "seqBlocks" (ppr tooManyNextNodes) + + +lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt) +lookupDeleteUFM m k = do -- Maybe monad + v <- lookupUFM m k + return (v, delFromUFM m k) + +-- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] +generateJumpTables ncgImpl xs = concatMap f xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) + +-- ----------------------------------------------------------------------------- +-- Shortcut branches + +shortcutBranches + :: DynFlags + -> NcgImpl statics instr jumpDest + -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] + +shortcutBranches dflags ncgImpl tops + | optLevel dflags < 1 = tops -- only with -O or higher + | otherwise = map (apply_mapping ncgImpl mapping) tops' + where + (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops + mapping = foldr plusUFM emptyUFM mappings + +build_mapping :: NcgImpl statics instr jumpDest + -> GenCmmDecl d (BlockEnv t) (ListGraph instr) + -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest) +build_mapping _ top@(CmmData _ _) = (top, emptyUFM) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), emptyUFM) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) + -- drop the shorted blocks, but don't ever drop the first one, + -- because it is pointed to by a global label. + where + -- find all the blocks that just consist of a jump that can be + -- shorted. + -- Don't completely eliminate loops here -- that can leave a dangling jump! + (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks + split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) + | Just jd <- canShortcut ncgImpl insn, + Just dest <- getJumpDestBlockId ncgImpl jd, + not (has_info id), + (setMember dest s) || dest == id -- loop checks + = (s, shortcut_blocks, b : others) + split (s, shortcut_blocks, others) (BasicBlock id [insn]) + | Just dest <- canShortcut ncgImpl insn, + not (has_info id) + = (setInsert id s, (id,dest) : shortcut_blocks, others) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + + -- do not eliminate blocks that have an info table + has_info l = mapMember l info + + -- build a mapping from BlockId to JumpDest for shorting branches + mapping = foldl add emptyUFM shortcut_blocks + add ufm (id,dest) = addToUFM ufm id dest + +apply_mapping :: NcgImpl statics instr jumpDest + -> UniqFM jumpDest + -> GenCmmDecl statics h (ListGraph instr) + -> GenCmmDecl statics h (ListGraph instr) +apply_mapping ncgImpl ufm (CmmData sec statics) + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) + where + short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns + short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i + -- shortcutJump should apply the mapping repeatedly, + -- just in case we can short multiple branches. + +-- ----------------------------------------------------------------------------- +-- Instruction selection + +-- Native code instruction selection for a chunk of stix code. For +-- this part of the computation, we switch from the UniqSM monad to +-- the NatM monad. The latter carries not only a Unique, but also an +-- Int denoting the current C stack pointer offset in the generated +-- code; this is needed for creating correct spill offsets on +-- architectures which don't offer, or for which it would be +-- prohibitively expensive to employ, a frame pointer register. Viz, +-- x86. + +-- The offset is measured in bytes, and indicates the difference +-- between the current (simulated) C stack-ptr and the value it was at +-- the beginning of the block. For stacks which grow down, this value +-- should be either zero or negative. + +-- Switching between the two monads whilst carrying along the same +-- Unique supply breaks abstraction. Is that bad? + +genMachCode + :: DynFlags + -> Module -> ModLocation + -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) + -> DwarfFiles + -> LabelMap DebugBlock + -> RawCmmDecl + -> UniqSM + ( [NatCmmDecl statics instr] + , [CLabel] + , DwarfFiles) + +genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top + = do { initial_us <- getUniqueSupplyM + ; let initial_st = mkNatM_State initial_us 0 dflags this_mod + modLoc fileIds dbgMap + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_delta = natm_delta final_st + final_imports = natm_imports final_st + ; if final_delta == 0 + then return (new_tops, final_imports, natm_fileid final_st) + else pprPanic "genMachCode: nonzero final delta" (int final_delta) + } + +-- ----------------------------------------------------------------------------- +-- Generic Cmm optimiser + +{- +Here we do: + + (a) Constant folding + (c) Position independent code and dynamic linking + (i) introduce the appropriate indirections + and position independent refs + (ii) compile a list of imported symbols + (d) Some arch-specific optimizations + +(a) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): + + - shortcut jumps-to-jumps + - simple CSE: if an expr is assigned to a temp, then replace later occs of + that expr with the temp, until the expr is no longer valid (can push through + temp assignments, and certain assigns to mem...) +-} + +cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags this_mod (CmmProc info lbl live graph) + = runCmmOpt dflags this_mod $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') + +newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #)) + +instance Functor CmmOptM where + fmap = liftM + +instance Applicative CmmOptM where + pure = return + (<*>) = ap + +instance Monad CmmOptM where + return x = CmmOptM $ \_ _ imports -> (# x, imports #) + (CmmOptM f) >>= g = + CmmOptM $ \dflags this_mod imports -> + case f dflags this_mod imports of + (# x, imports' #) -> + case g x of + CmmOptM g' -> g' dflags this_mod imports' + +instance CmmMakeDynamicReferenceM CmmOptM where + addImport = addImportCmmOpt + getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #) + +addImportCmmOpt :: CLabel -> CmmOptM () +addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #) + +instance HasDynFlags CmmOptM where + getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #) + +runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) +runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of + (# result, imports #) -> (result, imports) + +cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock +cmmBlockConFold block = do + let (entry, middle, last) = blockSplit block + stmts = blockToList middle + stmts' <- mapM cmmStmtConFold stmts + last' <- cmmStmtConFold last + return $ blockJoin entry (blockFromList stmts') last' + +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not Opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. +cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) +cmmStmtConFold stmt + = case stmt of + CmmAssign reg src + -> do src' <- cmmExprConFold DataReference src + return $ case src' of + CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") + new_src -> CmmAssign reg new_src + + CmmStore addr src + -> do addr' <- cmmExprConFold DataReference addr + src' <- cmmExprConFold DataReference src + return $ CmmStore addr' src' + + CmmCall { cml_target = addr } + -> do addr' <- cmmExprConFold JumpReference addr + return $ stmt { cml_target = addr' } + + CmmUnsafeForeignCall target regs args + -> do target' <- case target of + ForeignTarget e conv -> do + e' <- cmmExprConFold CallReference e + return $ ForeignTarget e' conv + PrimTarget _ -> + return target + args' <- mapM (cmmExprConFold DataReference) args + return $ CmmUnsafeForeignCall target' regs args' + + CmmCondBranch test true false + -> do test' <- cmmExprConFold DataReference test + return $ case test' of + CmmLit (CmmInt 0 _) -> CmmBranch false + CmmLit (CmmInt _ _) -> CmmBranch true + _other -> CmmCondBranch test' true false + + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids + + other + -> return other + +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprConFold referenceKind expr = do + dflags <- getDynFlags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again here. + let expr' = if optLevel dflags >= 1 + then expr + else cmmExprCon dflags expr + + cmmExprNative referenceKind expr' + +cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr +cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep +cmmExprCon dflags (CmmMachOp mop args) + = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args) +cmmExprCon _ other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do + dflags <- getDynFlags + let platform = targetPlatform dflags + arch = platformArch platform + case expr of + CmmLoad addr rep + -> do addr' <- cmmExprNative DataReference addr + return $ CmmLoad addr' rep + + CmmMachOp mop args + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' + + CmmLit (CmmBlock id) + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. + + CmmLit (CmmLabel lbl) + -> do + cmmMakeDynamicReference dflags referenceKind lbl + CmmLit (CmmLabelOff lbl off) + -> do + dynRef <- cmmMakeDynamicReference dflags referenceKind lbl + -- need to optimize here, since it's late + return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ + dynRef, + (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags)) + ] + + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal EagerBlackholeInfo) + | arch == ArchPPC && not (gopt Opt_PIC dflags) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmReg (CmmGlobal GCEnter1) + | arch == ArchPPC && not (gopt Opt_PIC dflags) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_enter_1"))) + CmmReg (CmmGlobal GCFun) + | arch == ArchPPC && not (gopt Opt_PIC dflags) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_fun"))) + + other + -> return other diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs new file mode 100644 index 00000000..c52fe10b --- /dev/null +++ b/compiler/nativeGen/CPrim.hs @@ -0,0 +1,101 @@ +-- | Generating C symbol names emitted by the compiler. +module CPrim + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel + , bSwapLabel + , clzLabel + , ctzLabel + , word2FloatLabel + ) where + +import CmmType +import CmmMachOp +import Outputable + +popCntLabel :: Width -> String +popCntLabel w = "hs_popcnt" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) + +bSwapLabel :: Width -> String +bSwapLabel w = "hs_bswap" ++ pprWidth w + where + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) + +clzLabel :: Width -> String +clzLabel w = "hs_clz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w) + +ctzLabel :: Width -> String +ctzLabel w = "hs_ctz" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w) + +word2FloatLabel :: Width -> String +word2FloatLabel w = "hs_word2float" ++ pprWidth w + where + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs new file mode 100644 index 00000000..34f1ed69 --- /dev/null +++ b/compiler/nativeGen/Dwarf.hs @@ -0,0 +1,166 @@ +module Dwarf ( + dwarfGen + ) where + +import CLabel +import CmmExpr ( GlobalReg(..) ) +import Config ( cProjectName, cProjectVersion ) +import CoreSyn ( Tickish(..) ) +import Debug +import DynFlags +import FastString +import Module +import Outputable +import Platform +import Unique +import UniqSupply + +import Dwarf.Constants +import Dwarf.Types + +import Data.Maybe +import Data.List ( sortBy ) +import Data.Ord ( comparing ) +import qualified Data.Map as Map +import System.FilePath +import System.Directory ( getCurrentDirectory ) + +import qualified Compiler.Hoopl as H + +-- | Generate DWARF/debug information +dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] + -> IO (SDoc, UniqSupply) +dwarfGen df modLoc us blocks = do + + -- Convert debug data structures to DWARF info records + -- We strip out block information, as it is not currently useful for + -- anything. In future we might want to only do this for -g1. + let procs = debugSplitProcs blocks + stripBlocks dbg = dbg { dblBlocks = [] } + compPath <- getCurrentDirectory + let dwarfUnit = DwarfCompileUnit + { dwChildren = map (procToDwarf df) (map stripBlocks procs) + , dwName = fromMaybe "" (ml_hs_file modLoc) + , dwCompDir = addTrailingPathSeparator compPath + , dwProducer = cProjectName ++ " " ++ cProjectVersion + , dwLineLabel = dwarfLineLabel + } + + -- Check whether we have any source code information, so we do not + -- end up writing a pointer to an empty .debug_line section + -- (dsymutil on Mac Os gets confused by this). + let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) + || any haveSrcIn (dblBlocks blk) + haveSrc = any haveSrcIn procs + + -- .debug_abbrev section: Declare the format we're using + let abbrevSct = pprAbbrevDecls haveSrc + + -- .debug_info section: Information records on procedures and blocks + let (unitU, us') = takeUniqFromSupply us + infoSct = vcat [ dwarfInfoSection + , compileUnitHeader unitU + , pprDwarfInfo haveSrc dwarfUnit + , compileUnitFooter unitU + ] + + -- .debug_line section: Generated mainly by the assembler, but we + -- need to label it + let lineSct = dwarfLineSection $$ + ptext dwarfLineLabel <> colon + + -- .debug_frame section: Information about the layout of the GHC stack + let (framesU, us'') = takeUniqFromSupply us' + frameSct = dwarfFrameSection $$ + ptext dwarfFrameLabel <> colon $$ + pprDwarfFrame (debugFrame framesU procs) + + return (infoSct $$ abbrevSct $$ lineSct $$ frameSct, us'') + +-- | Header for a compilation unit, establishing global format +-- parameters +compileUnitHeader :: Unique -> SDoc +compileUnitHeader unitU = sdocWithPlatform $ \plat -> + let cuLabel = mkAsmTempLabel unitU + length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel + in vcat [ ptext (sLit "\t.long ") <> length -- compilation unit size + , ppr cuLabel <> colon + , ptext (sLit "\t.word 3") -- DWARF version + , sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel + -- abbrevs offset + , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size + ] + +-- | Compilation unit footer, mainly establishing size of debug sections +compileUnitFooter :: Unique -> SDoc +compileUnitFooter unitU = + let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU + in ppr cuEndLabel <> colon + +-- | Splits the blocks by procedures. In the result all nested blocks +-- will come from the same procedure as the top-level block. +debugSplitProcs :: [DebugBlock] -> [DebugBlock] +debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map split b + where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty + split :: DebugBlock -> H.LabelMap [DebugBlock] + split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested + where prc = dblProcedure blk + own_blks = fromMaybe [] $ H.mapLookup prc nested + nested = mergeMaps $ map split $ dblBlocks blk + -- Note that we are rebuilding the tree here, so tick scopes + -- might change. We could fix that - but we actually only care + -- about dblSourceTick in the result, so this is okay. + +-- | Generate DWARF info for a procedure debug block +procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo +procToDwarf df prc + = DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc + , dwName = case dblSourceTick prc of + Just s@SourceNote{} -> sourceName s + _otherwise -> showSDocDump df $ ppr $ dblLabel prc + , dwLabel = dblCLabel prc + } + +-- | Generate DWARF info for a block +blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo] +blockToDwarf blk dws + | isJust (dblPosition blk) = dw : dws + | otherwise = nested ++ dws -- block was optimized out, flatten + where nested = foldr blockToDwarf [] $ dblBlocks blk + dw = DwarfBlock { dwChildren = nested + , dwLabel = dblCLabel blk + , dwMarker = mkAsmTempLabel (dblLabel blk) + } + +-- | Generates the data for the debug frame section, which encodes the +-- desired stack unwind behaviour for the debugger +debugFrame :: Unique -> [DebugBlock] -> DwarfFrame +debugFrame u procs + = DwarfFrame { dwCieLabel = mkAsmTempLabel u + , dwCieInit = initUws + , dwCieProcs = map (procToFrame initUws) procs + } + where initUws = Map.fromList [(Sp, UwReg Sp 0)] + +-- | Generates unwind information for a procedure debug block +procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc +procToFrame initUws blk + = DwarfFrameProc { dwFdeProc = dblCLabel blk + , dwFdeHasInfo = dblHasInfoTbl blk + , dwFdeBlocks = map (uncurry blockToFrame) blockUws + } + where blockUws :: [(DebugBlock, UnwindTable)] + blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk + flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws, + dblBlocks=blocks } + | Just p <- pos = (p, (b, uws')):nested + | otherwise = nested -- block was optimized out + where uws' = uws `Map.union` uws0 + nested = concatMap (flatten uws') blocks + +blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock +blockToFrame blk uws + = DwarfFrameBlock { dwFdeBlock = mkAsmTempLabel $ dblLabel blk + , dwFdeBlkHasInfo = dblHasInfoTbl blk + , dwFdeUnwind = uws + } diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs new file mode 100644 index 00000000..4b334fca --- /dev/null +++ b/compiler/nativeGen/Dwarf/Constants.hs @@ -0,0 +1,197 @@ +-- | Constants describing the DWARF format. Most of this simply +-- mirrors /usr/include/dwarf.h. + +module Dwarf.Constants where + +import FastString +import Platform +import Outputable + +import Reg +import X86.Regs + +import Data.Word + +-- | Language ID used for Haskell. +dW_LANG_Haskell :: Word +dW_LANG_Haskell = 0x18 + -- Thanks to Nathan Howell for getting us our very own language ID! + +-- | Dwarf tags +dW_TAG_compile_unit, dW_TAG_subroutine_type, + dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, + dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, + dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, + dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable :: Word +dW_TAG_array_type = 1 +dW_TAG_lexical_block = 11 +dW_TAG_pointer_type = 15 +dW_TAG_compile_unit = 17 +dW_TAG_structure_type = 19 +dW_TAG_typedef = 22 +dW_TAG_subroutine_type = 32 +dW_TAG_subrange_type = 33 +dW_TAG_base_type = 36 +dW_TAG_file_type = 41 +dW_TAG_subprogram = 46 +dW_TAG_variable = 52 +dW_TAG_auto_variable = 256 +dW_TAG_arg_variable = 257 + +-- | Dwarf attributes +dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, + dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, + dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word +dW_AT_name = 0x03 +dW_AT_stmt_list = 0x10 +dW_AT_low_pc = 0x11 +dW_AT_high_pc = 0x12 +dW_AT_language = 0x13 +dW_AT_comp_dir = 0x1b +dW_AT_producer = 0x25 +dW_AT_external = 0x3f +dW_AT_frame_base = 0x40 +dW_AT_use_UTF8 = 0x53 +dW_AT_MIPS_linkage_name = 0x2007 + +-- | Abbrev declaration +dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 +dW_CHILDREN_no = 0 +dW_CHILDREN_yes = 1 + +dW_FORM_addr, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, + dW_FORM_block1, dW_FORM_ref4 :: Word +dW_FORM_addr = 0x01 +dW_FORM_data4 = 0x06 +dW_FORM_string = 0x08 +dW_FORM_flag = 0x0c +dW_FORM_block1 = 0x0a +dW_FORM_ref4 = 0x13 + +-- | Dwarf native types +dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, + dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word +dW_ATE_address = 1 +dW_ATE_boolean = 2 +dW_ATE_float = 4 +dW_ATE_signed = 5 +dW_ATE_signed_char = 6 +dW_ATE_unsigned = 7 +dW_ATE_unsigned_char = 8 + +-- | Call frame information +dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, + dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, + dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, + dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, + dW_CFA_offset :: Word8 +dW_CFA_set_loc = 0x01 +dW_CFA_undefined = 0x07 +dW_CFA_same_value = 0x08 +dW_CFA_def_cfa = 0x0c +dW_CFA_def_cfa_offset = 0x0e +dW_CFA_def_cfa_expression = 0x0f +dW_CFA_expression = 0x10 +dW_CFA_offset_extended_sf = 0x11 +dW_CFA_def_cfa_sf = 0x12 +dW_CFA_def_cfa_offset_sf = 0x13 +dW_CFA_val_offset = 0x14 +dW_CFA_val_expression = 0x16 +dW_CFA_offset = 0x80 + +-- | Operations +dW_OP_deref, dW_OP_consts, + dW_OP_minus, dW_OP_mul, dW_OP_plus, + dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 +dW_OP_deref = 0x06 +dW_OP_consts = 0x11 +dW_OP_minus = 0x1c +dW_OP_mul = 0x1e +dW_OP_plus = 0x22 +dW_OP_lit0 = 0x30 +dW_OP_breg0 = 0x70 +dW_OP_call_frame_cfa = 0x9c + +-- | Dwarf section declarations +dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, + dwarfFrameSection, dwarfGhcSection :: SDoc +dwarfInfoSection = dwarfSection "info" +dwarfAbbrevSection = dwarfSection "abbrev" +dwarfLineSection = dwarfSection "line" +dwarfFrameSection = dwarfSection "frame" +dwarfGhcSection = dwarfSection "ghc" + +dwarfSection :: String -> SDoc +dwarfSection name = sdocWithPlatform $ \plat -> ftext $ mkFastString $ + case platformOS plat of + os | osElfTarget os + -> "\t.section .debug_" ++ name ++ ",\"\",@progbits" + | osMachOTarget os + -> "\t.section __DWARF,__debug_" ++ name ++ ",regular,debug" + | otherwise + -> "\t.section .debug_" ++ name ++ ",\"dr\"" + +-- | Dwarf section labels +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: LitString +dwarfInfoLabel = sLit ".Lsection_info" +dwarfAbbrevLabel = sLit ".Lsection_abbrev" +dwarfLineLabel = sLit ".Lsection_line" +dwarfFrameLabel = sLit ".Lsection_frame" + +-- | Mapping of registers to DWARF register numbers +dwarfRegNo :: Platform -> Reg -> Word8 +dwarfRegNo p r = case platformArch p of + ArchX86 + | r == eax -> 0 + | r == ecx -> 1 -- yes, no typo + | r == edx -> 2 + | r == ebx -> 3 + | r == esp -> 4 + | r == ebp -> 5 + | r == esi -> 6 + | r == edi -> 7 + ArchX86_64 + | r == rax -> 0 + | r == rdx -> 1 -- this neither. The order GCC allocates registers in? + | r == rcx -> 2 + | r == rbx -> 3 + | r == rsi -> 4 + | r == rdi -> 5 + | r == rbp -> 6 + | r == rsp -> 7 + | r == r8 -> 8 + | r == r9 -> 9 + | r == r10 -> 10 + | r == r11 -> 11 + | r == r12 -> 12 + | r == r13 -> 13 + | r == r14 -> 14 + | r == r15 -> 15 + | r == xmm0 -> 17 + | r == xmm1 -> 18 + | r == xmm2 -> 19 + | r == xmm3 -> 20 + | r == xmm4 -> 21 + | r == xmm5 -> 22 + | r == xmm6 -> 23 + | r == xmm7 -> 24 + | r == xmm8 -> 25 + | r == xmm9 -> 26 + | r == xmm10 -> 27 + | r == xmm11 -> 28 + | r == xmm12 -> 29 + | r == xmm13 -> 30 + | r == xmm14 -> 31 + | r == xmm15 -> 32 + _other -> error "dwarfRegNo: Unsupported platform or unknown register!" + +-- | Virtual register number to use for return address. +dwarfReturnRegNo :: Platform -> Word8 +dwarfReturnRegNo p + -- We "overwrite" IP with our pseudo register - that makes sense, as + -- when using this mechanism gdb already knows the IP anyway. Clang + -- does this too, so it must be safe. + = case platformArch p of + ArchX86 -> 8 -- eip + ArchX86_64 -> 16 -- rip + _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs new file mode 100644 index 00000000..00d0535a --- /dev/null +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -0,0 +1,443 @@ +module Dwarf.Types + ( -- * Dwarf information + DwarfInfo(..) + , pprDwarfInfo + , pprAbbrevDecls + -- * Dwarf frame + , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..) + , pprDwarfFrame + -- * Utilities + , pprByte + , pprData4' + , pprDwWord + , pprWord + , pprLEBWord + , pprLEBInt + , wordAlign + , sectionOffset + ) + where + +import Debug +import CLabel +import CmmExpr ( GlobalReg(..) ) +import Encoding +import FastString +import Outputable +import Platform +import Reg + +import Dwarf.Constants + +import Data.Bits +import Data.List ( mapAccumL ) +import qualified Data.Map as Map +import Data.Word +import Data.Char + +import CodeGen.Platform + +-- | Individual dwarf records. Each one will be encoded as an entry in +-- the .debug_info section. +data DwarfInfo + = DwarfCompileUnit { dwChildren :: [DwarfInfo] + , dwName :: String + , dwProducer :: String + , dwCompDir :: String + , dwLineLabel :: LitString } + | DwarfSubprogram { dwChildren :: [DwarfInfo] + , dwName :: String + , dwLabel :: CLabel } + | DwarfBlock { dwChildren :: [DwarfInfo] + , dwLabel :: CLabel + , dwMarker :: CLabel } + +-- | Abbreviation codes used for encoding above records in the +-- .debug_info section. +data DwarfAbbrev + = DwAbbrNull -- ^ Pseudo, used for marking the end of lists + | DwAbbrCompileUnit + | DwAbbrSubprogram + | DwAbbrBlock + deriving (Eq, Enum) + +-- | Generate assembly for the given abbreviation code +pprAbbrev :: DwarfAbbrev -> SDoc +pprAbbrev = pprLEBWord . fromIntegral . fromEnum + +-- | Abbreviation declaration. This explains the binary encoding we +-- use for representing @DwarfInfo@. +pprAbbrevDecls :: Bool -> SDoc +pprAbbrevDecls haveDebugLine = + let mkAbbrev abbr tag chld flds = + let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form + in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ + vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 + in dwarfAbbrevSection $$ + ptext dwarfAbbrevLabel <> colon $$ + mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes + ([ (dW_AT_name, dW_FORM_string) + , (dW_AT_producer, dW_FORM_string) + , (dW_AT_language, dW_FORM_data4) + , (dW_AT_comp_dir, dW_FORM_string) + , (dW_AT_use_UTF8, dW_FORM_flag) + ] ++ + (if haveDebugLine + then [ (dW_AT_stmt_list, dW_FORM_data4) ] + else [])) $$ + mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_MIPS_linkage_name, dW_FORM_string) + , (dW_AT_external, dW_FORM_flag) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + , (dW_AT_frame_base, dW_FORM_block1) + ] $$ + mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] $$ + pprByte 0 + +-- | Generate assembly for DWARF data +pprDwarfInfo :: Bool -> DwarfInfo -> SDoc +pprDwarfInfo haveSrc d + = pprDwarfInfoOpen haveSrc d $$ + vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$ + pprDwarfInfoClose + +-- | Prints assembler data corresponding to DWARF info records. Note +-- that the binary format of this is paramterized in @abbrevDecls@ and +-- has to be kept in synch. +pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) = + pprAbbrev DwAbbrCompileUnit + $$ pprString name + $$ pprString producer + $$ pprData4 dW_LANG_Haskell + $$ pprString compDir + $$ pprFlag True -- use UTF8 + $$ if haveSrc + then sectionOffset lineLbl dwarfLineLabel + else empty +pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df -> + pprAbbrev DwAbbrSubprogram + $$ pprString name + $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) + $$ pprFlag (externallyVisibleCLabel label) + $$ pprWord (ppr label) + $$ pprWord (ppr $ mkAsmTempEndLabel label) + $$ pprByte 1 + $$ pprByte dW_OP_call_frame_cfa +pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df -> + pprAbbrev DwAbbrBlock + $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) + $$ pprWord (ppr marker) + $$ pprWord (ppr $ mkAsmTempEndLabel marker) + +-- | Close a DWARF info record with children +pprDwarfInfoClose :: SDoc +pprDwarfInfoClose = pprAbbrev DwAbbrNull + +-- | Information about unwind instructions for a procedure. This +-- corresponds to a "Common Information Entry" (CIE) in DWARF. +data DwarfFrame + = DwarfFrame + { dwCieLabel :: CLabel + , dwCieInit :: UnwindTable + , dwCieProcs :: [DwarfFrameProc] + } + +-- | Unwind instructions for an individual procedure. Corresponds to a +-- "Frame Description Entry" (FDE) in DWARF. +data DwarfFrameProc + = DwarfFrameProc + { dwFdeProc :: CLabel + , dwFdeHasInfo :: Bool + , dwFdeBlocks :: [DwarfFrameBlock] + -- ^ List of blocks. Order must match asm! + } + +-- | Unwind instructions for a block. Will become part of the +-- containing FDE. +data DwarfFrameBlock + = DwarfFrameBlock + { dwFdeBlock :: CLabel + , dwFdeBlkHasInfo :: Bool + , dwFdeUnwind :: UnwindTable + } + +-- | Header for the .debug_frame section. Here we emit the "Common +-- Information Entry" record that etablishes general call frame +-- parameters and the default stack layout. +pprDwarfFrame :: DwarfFrame -> SDoc +pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} + = sdocWithPlatform $ \plat -> + let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") + cieEndLabel = mkAsmTempEndLabel cieLabel + length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel + spReg = dwarfGlobalRegNo plat Sp + retReg = dwarfReturnRegNo plat + wordSize = platformWordSize plat + pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) + in vcat [ ppr cieLabel <> colon + , pprData4' length -- Length of CIE + , ppr cieStartLabel <> colon + , pprData4' (ptext (sLit "-1")) + -- Common Information Entry marker (-1 = 0xf..f) + , pprByte 3 -- CIE version (we require DWARF 3) + , pprByte 0 -- Augmentation (none) + , pprByte 1 -- Code offset multiplicator + , pprByte (128-fromIntegral wordSize) + -- Data offset multiplicator + -- (stacks grow down => "-w" in signed LEB128) + , pprByte retReg -- virtual register holding return address + ] $$ + -- Initial unwind table + vcat (map pprInit $ Map.toList cieInit) $$ + vcat [ -- RET = *CFA + pprByte (dW_CFA_offset+retReg) + , pprByte 0 + + -- Sp' = CFA + -- (we need to set this manually as our Sp register is + -- often not the architecture's default stack register) + , pprByte dW_CFA_val_offset + , pprLEBWord (fromIntegral spReg) + , pprLEBWord 0 + ] $$ + wordAlign $$ + ppr cieEndLabel <> colon $$ + -- Procedure unwind tables + vcat (map (pprFrameProc cieLabel cieInit) procs) + +-- | Writes a "Frame Description Entry" for a procedure. This consists +-- mainly of referencing the CIE and writing state machine +-- instructions to describe how the frame base (CFA) changes. +pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc +pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) + = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") + fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") + procEnd = mkAsmTempEndLabel procLbl + ifInfo str = if hasInfo then text str else empty + -- see [Note: Info Offset] + in vcat [ pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) + , ppr fdeLabel <> colon + , pprData4' (ppr frameLbl <> char '-' <> + ptext dwarfFrameLabel) -- Reference to CIE + , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer + , pprWord (ppr procEnd <> char '-' <> + ppr procLbl <> ifInfo "+1") -- Block byte length + ] $$ + vcat (snd $ mapAccumL pprFrameBlock initUw blocks) $$ + wordAlign $$ + ppr fdeEndLabel <> colon + +-- | Generates unwind information for a block. We only generate +-- instructions where unwind information actually changes. This small +-- optimisations saves a lot of space, as subsequent blocks often have +-- the same unwind information. +pprFrameBlock :: UnwindTable -> DwarfFrameBlock -> (UnwindTable, SDoc) +pprFrameBlock oldUws (DwarfFrameBlock blockLbl hasInfo uws) + | uws == oldUws + = (oldUws, empty) + | otherwise + = (,) uws $ sdocWithPlatform $ \plat -> + let lbl = ppr blockLbl <> if hasInfo then text "-1" else empty + -- see [Note: Info Offset] + isChanged g v | old == Just v = Nothing + | otherwise = Just (old, v) + where old = Map.lookup g oldUws + changed = Map.toList $ Map.mapMaybeWithKey isChanged uws + died = Map.toList $ Map.difference oldUws uws + in pprByte dW_CFA_set_loc $$ pprWord lbl $$ + vcat (map (uncurry $ pprSetUnwind plat) changed) $$ + vcat (map (pprUndefUnwind plat . fst) died) + +-- [Note: Info Offset] +-- +-- GDB was pretty much written with C-like programs in mind, and as a +-- result they assume that once you have a return address, it is a +-- good idea to look at (PC-1) to unwind further - as that's where the +-- "call" instruction is supposed to be. +-- +-- Now on one hand, code generated by GHC looks nothing like what GDB +-- expects, and in fact going up from a return pointer is guaranteed +-- to land us inside an info table! On the other hand, that actually +-- gives us some wiggle room, as we expect IP to never *actually* end +-- up inside the info table, so we can "cheat" by putting whatever GDB +-- expects to see there. This is probably pretty safe, as GDB cannot +-- assume (PC-1) to be a valid code pointer in the first place - and I +-- have seen no code trying to correct this. +-- +-- Note that this will not prevent GDB from failing to look-up the +-- correct function name for the frame, as that uses the symbol table, +-- which we can not manipulate as easily. + +-- | Get DWARF register ID for a given GlobalReg +dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8 +dwarfGlobalRegNo p = maybe 0 (dwarfRegNo p . RegReal) . globalRegMaybe p + +-- | Generate code for setting the unwind information for a register, +-- optimized using its known old value in the table. Note that "Sp" is +-- special: We see it as synonym for the CFA. +pprSetUnwind :: Platform -> GlobalReg -> (Maybe UnwindExpr, UnwindExpr) -> SDoc +pprSetUnwind _ Sp (Just (UwReg s _), UwReg s' o') | s == s' + = if o' >= 0 + then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' +pprSetUnwind plat Sp (_, UwReg s' o') + = if o' >= 0 + then pprByte dW_CFA_def_cfa $$ + pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$ + pprLEBWord (fromIntegral o') + else pprByte dW_CFA_def_cfa_sf $$ + pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$ + pprLEBInt o' +pprSetUnwind _ Sp (_, uw) + = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw +pprSetUnwind plat g (_, UwDeref (UwReg Sp o)) + | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case + = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ + pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat)) + | otherwise + = pprByte dW_CFA_offset_extended_sf $$ + pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$ + pprLEBInt o +pprSetUnwind plat g (_, UwDeref uw) + = pprByte dW_CFA_expression $$ + pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$ + pprUnwindExpr True uw +pprSetUnwind plat g (_, uw) + = pprByte dW_CFA_val_expression $$ + pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$ + pprUnwindExpr True uw + +-- | Generates a DWARF expression for the given unwind expression. If +-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets +-- mentioned. +pprUnwindExpr :: Bool -> UnwindExpr -> SDoc +pprUnwindExpr spIsCFA expr + = sdocWithPlatform $ \plat -> + let ppr (UwConst i) + | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) + | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... + ppr (UwReg Sp i) | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else ppr (UwPlus (UwReg Sp 0) (UwConst i)) + ppr (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$ + pprLEBInt i + ppr (UwDeref u) = ppr u $$ pprByte dW_OP_deref + ppr (UwPlus u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_plus + ppr (UwMinus u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_minus + ppr (UwTimes u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_mul + in ptext (sLit "\t.byte 1f-.-1") $$ + ppr expr $$ + ptext (sLit "1:") + +-- | Generate code for re-setting the unwind information for a +-- register to "undefined" +pprUndefUnwind :: Platform -> GlobalReg -> SDoc +pprUndefUnwind _ Sp = panic "pprUndefUnwind Sp" -- should never happen +pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ + pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat g) + + +-- | Align assembly at (machine) word boundary +wordAlign :: SDoc +wordAlign = sdocWithPlatform $ \plat -> + ptext (sLit "\t.align ") <> case platformOS plat of + OSDarwin -> case platformWordSize plat of + 8 -> text "3" + 4 -> text "2" + _other -> error "wordAlign: Unsupported word size!" + _other -> ppr (platformWordSize plat) + +-- | Assembly for a single byte of constant DWARF data +pprByte :: Word8 -> SDoc +pprByte x = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word) + +-- | Assembly for a constant DWARF flag +pprFlag :: Bool -> SDoc +pprFlag f = pprByte (if f then 0xff else 0x00) + +-- | Assembly for 4 bytes of dynamic DWARF data +pprData4' :: SDoc -> SDoc +pprData4' x = ptext (sLit "\t.long ") <> x + +-- | Assembly for 4 bytes of constant DWARF data +pprData4 :: Word -> SDoc +pprData4 = pprData4' . ppr + +-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as +-- we are generating 32 bit DWARF. +pprDwWord :: SDoc -> SDoc +pprDwWord = pprData4' + +-- | Assembly for a machine word of dynamic data. Depends on the +-- architecture we are currently generating code for. +pprWord :: SDoc -> SDoc +pprWord s = (<> s) . sdocWithPlatform $ \plat -> + case platformWordSize plat of + 4 -> ptext (sLit "\t.long ") + 8 -> ptext (sLit "\t.quad ") + n -> panic $ "pprWord: Unsupported target platform word length " ++ + show n ++ "!" + +-- | Prints a number in "little endian base 128" format. The idea is +-- to optimize for small numbers by stopping once all further bytes +-- would be 0. The highest bit in every byte signals whether there +-- are further bytes to read. +pprLEBWord :: Word -> SDoc +pprLEBWord x | x < 128 = pprByte (fromIntegral x) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBWord (x `shiftR` 7) + +-- | Same as @pprLEBWord@, but for a signed number +pprLEBInt :: Int -> SDoc +pprLEBInt x | x >= -64 && x < 64 + = pprByte (fromIntegral (x .&. 127)) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBInt (x `shiftR` 7) + +-- | Generates a dynamic null-terminated string. If required the +-- caller needs to make sure that the string is escaped properly. +pprString' :: SDoc -> SDoc +pprString' str = ptext (sLit "\t.asciz \"") <> str <> char '"' + +-- | Generate a string constant. We take care to escape the string. +pprString :: String -> SDoc +pprString str + = pprString' $ hcat $ map escapeChar $ + if utf8EncodedLength str == length str + then str + else map (chr . fromIntegral) $ bytesFS $ mkFastString str + +-- | Escape a single non-unicode character +escapeChar :: Char -> SDoc +escapeChar '\\' = ptext (sLit "\\\\") +escapeChar '\"' = ptext (sLit "\\\"") +escapeChar '\n' = ptext (sLit "\\n") +escapeChar c + | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings + = char c + | otherwise + = char '\\' <> char (intToDigit (ch `div` 64)) <> + char (intToDigit ((ch `div` 8) `mod` 8)) <> + char (intToDigit (ch `mod` 8)) + where ch = ord c + +-- | Generate an offset into another section. This is tricky because +-- this is handled differently depending on platform: Mac Os expects +-- us to calculate the offset using assembler arithmetic. Linux expects +-- us to just reference the target directly, and will figure out on +-- their own that we actually need an offset. Finally, Windows has +-- a special directive to refer to relative offsets. Fun. +sectionOffset :: LitString -> LitString -> SDoc +sectionOffset target section = sdocWithPlatform $ \plat -> + case platformOS plat of + OSDarwin -> pprDwWord (ptext target <> char '-' <> ptext section) + OSMinGW32 -> text "\t.secrel32 " <> ptext target + _other -> pprDwWord (ptext target) diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs new file mode 100644 index 00000000..8ecd2eb3 --- /dev/null +++ b/compiler/nativeGen/Instruction.hs @@ -0,0 +1,200 @@ + +module Instruction ( + RegUsage(..), + noUsage, + GenBasicBlock(..), blockId, + ListGraph(..), + NatCmm, + NatCmmDecl, + NatBasicBlock, + topInfoTable, + entryBlocks, + Instruction(..) +) + +where + +import Reg + +import BlockId +import DynFlags +import Cmm hiding (topInfoTable) +import Platform + +-- | Holds a list of source and destination registers used by a +-- particular instruction. +-- +-- Machine registers that are pre-allocated to stgRegs are filtered +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) +-- +-- As far as we are concerned, the fixed registers simply don't exist +-- (for allocation purposes, anyway). +-- +data RegUsage + = RU [Reg] [Reg] + +-- | No regs read or written to. +noUsage :: RegUsage +noUsage = RU [] [] + +-- Our flavours of the Cmm types +-- Type synonyms for Cmm populated with native code +type NatCmm instr + = GenCmmGroup + CmmStatics + (BlockEnv CmmStatics) + (ListGraph instr) + +type NatCmmDecl statics instr + = GenCmmDecl + statics + (BlockEnv CmmStatics) + (ListGraph instr) + + +type NatBasicBlock instr + = GenBasicBlock instr + + +-- | Returns the info table associated with the CmmDecl's entry point, +-- if any. +topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) + = mapLookup (blockId b) infos +topInfoTable _ + = Nothing + +-- | Return the list of BlockIds in a CmmDecl that are entry points +-- for this proc (i.e. they may be jumped to from outside this proc). +entryBlocks :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> [BlockId] +entryBlocks (CmmProc info _ _ (ListGraph code)) = entries + where + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos +entryBlocks _ = [] + +-- | Common things that we can do with instructions, on all architectures. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. +-- +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: Platform + -> instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: DynFlags + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: DynFlags + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + + -- Subtract an amount from the C stack pointer + mkStackAllocInstr + :: Platform -- TODO: remove (needed by x86/x86_64 + -- because they share an Instr type) + -> Int + -> instr + + -- Add an amount to the C stack pointer + mkStackDeallocInstr + :: Platform -- TODO: remove (needed by x86/x86_64 + -- because they share an Instr type) + -> Int + -> instr diff --git a/compiler/nativeGen/NCG.h b/compiler/nativeGen/NCG.h new file mode 100644 index 00000000..bca1de41 --- /dev/null +++ b/compiler/nativeGen/NCG.h @@ -0,0 +1,14 @@ +/* ----------------------------------------------------------------------------- + + (c) The University of Glasgow, 1994-2004 + + Native-code generator header file - just useful macros for now. + + -------------------------------------------------------------------------- */ + +#ifndef NCG_H +#define NCG_H + +#include "ghc_boot_platform.h" + +#endif diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs new file mode 100644 index 00000000..e312d274 --- /dev/null +++ b/compiler/nativeGen/NCGMonad.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- The native code generator's monad. +-- +-- ----------------------------------------------------------------------------- + +module NCGMonad ( + NatM_State(..), mkNatM_State, + + NatM, -- instance Monad + initNat, + addImportNat, + getUniqueNat, + mapAccumLNat, + setDeltaNat, + getDeltaNat, + getThisModuleNat, + getBlockIdNat, + getNewLabelNat, + getNewRegNat, + getNewRegPairNat, + getPicBaseMaybeNat, + getPicBaseNat, + getDynFlags, + getModLoc, + getFileId, + getDebugBlock, + + DwarfFiles +) + +where + +#include "HsVersions.h" + +import Reg +import Size +import TargetReg + +import BlockId +import CLabel ( CLabel, mkAsmTempLabel ) +import Debug +import FastString ( FastString ) +import UniqFM +import UniqSupply +import Unique ( Unique ) +import DynFlags +import Module + +import Control.Monad ( liftM, ap ) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ( Applicative(..) ) +#endif + +import Compiler.Hoopl ( LabelMap, Label ) + +data NatM_State + = NatM_State { + natm_us :: UniqSupply, + natm_delta :: Int, + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags, + natm_this_module :: Module, + natm_modloc :: ModLocation, + natm_fileid :: DwarfFiles, + natm_debug_map :: LabelMap DebugBlock + } + +type DwarfFiles = UniqFM (FastString, Int) + +newtype NatM result = NatM (NatM_State -> (result, NatM_State)) + +unNat :: NatM a -> NatM_State -> (a, NatM_State) +unNat (NatM a) = a + +mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation -> + DwarfFiles -> LabelMap DebugBlock -> NatM_State +mkNatM_State us delta dflags this_mod + = NatM_State us delta [] Nothing dflags this_mod + +initNat :: NatM_State -> NatM a -> (a, NatM_State) +initNat init_st m + = case unNat m init_st of { (r,st) -> (r,st) } + + +instance Functor NatM where + fmap = liftM + +instance Applicative NatM where + pure = return + (<*>) = ap + +instance Monad NatM where + (>>=) = thenNat + return = returnNat + + +thenNat :: NatM a -> (a -> NatM b) -> NatM b +thenNat expr cont + = NatM $ \st -> case unNat expr st of + (result, st') -> unNat (cont result) st' + +returnNat :: a -> NatM a +returnNat result + = NatM $ \st -> (result, st) + +mapAccumLNat :: (acc -> x -> NatM (acc, y)) + -> acc + -> [x] + -> NatM (acc, [y]) + +mapAccumLNat _ b [] + = return (b, []) +mapAccumLNat f b (x:xs) + = do (b__2, x__2) <- f b x + (b__3, xs__2) <- mapAccumLNat f b__2 xs + return (b__3, x__2:xs__2) + +getUniqueNat :: NatM Unique +getUniqueNat = NatM $ \ st -> + case takeUniqFromSupply $ natm_us st of + (uniq, us') -> (uniq, st {natm_us = us'}) + +instance HasDynFlags NatM where + getDynFlags = NatM $ \ st -> (natm_dflags st, st) + + +getDeltaNat :: NatM Int +getDeltaNat = NatM $ \ st -> (natm_delta st, st) + + +setDeltaNat :: Int -> NatM () +setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) + + +getThisModuleNat :: NatM Module +getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) + + +addImportNat :: CLabel -> NatM () +addImportNat imp + = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) + + +getBlockIdNat :: NatM BlockId +getBlockIdNat + = do u <- getUniqueNat + return (mkBlockId u) + + +getNewLabelNat :: NatM CLabel +getNewLabelNat + = do u <- getUniqueNat + return (mkAsmTempLabel u) + + +getNewRegNat :: Size -> NatM Reg +getNewRegNat rep + = do u <- getUniqueNat + dflags <- getDynFlags + return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) + + +getNewRegPairNat :: Size -> NatM (Reg,Reg) +getNewRegPairNat rep + = do u <- getUniqueNat + dflags <- getDynFlags + let vLo = targetMkVirtualReg (targetPlatform dflags) u rep + let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) + + +getPicBaseMaybeNat :: NatM (Maybe Reg) +getPicBaseMaybeNat + = NatM (\state -> (natm_pic state, state)) + + +getPicBaseNat :: Size -> NatM Reg +getPicBaseNat rep + = do mbPicBase <- getPicBaseMaybeNat + case mbPicBase of + Just picBase -> return picBase + Nothing + -> do + reg <- getNewRegNat rep + NatM (\state -> (reg, state { natm_pic = Just reg })) + +getModLoc :: NatM ModLocation +getModLoc + = NatM $ \ st -> (natm_modloc st, st) + +getFileId :: FastString -> NatM Int +getFileId f = NatM $ \st -> + case lookupUFM (natm_fileid st) f of + Just (_,n) -> (n, st) + Nothing -> let n = 1 + sizeUFM (natm_fileid st) + fids = addToUFM (natm_fileid st) f (f,n) + in n `seq` fids `seq` (n, st { natm_fileid = fids }) + +getDebugBlock :: Label -> NatM (Maybe DebugBlock) +getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st) diff --git a/compiler/nativeGen/NOTES b/compiler/nativeGen/NOTES new file mode 100644 index 00000000..9068a7fc --- /dev/null +++ b/compiler/nativeGen/NOTES @@ -0,0 +1,41 @@ +TODO in new NCG +~~~~~~~~~~~~~~~ + +- Are we being careful enough about narrowing those out-of-range CmmInts? + +- Register allocator: + - fixup code + - keep track of free stack slots + + Optimisations: + + - picking the assignment on entry to a block: better to defer this + until we know all the assignments. In a loop, we should pick + the assignment from the looping jump (fixpointing?), so that any + fixup code ends up *outside* the loop. Otherwise, we should + pick the assignment that results in the least fixup code. + +- splitting? + +-- ----------------------------------------------------------------------------- +-- x86 ToDos + +- x86 genCCall needs to tack on the @size for stdcalls (might not be in the + foreignlabel). + +- x86: should really clean up that IMUL64 stuff, and tell the code gen about + Intel imul instructions. + +- x86: we're not careful enough about making sure that we only use + byte-addressable registers in byte instructions. Should we do it this + way, or stick to using 32-bit registers everywhere? + +- Use SSE for floating point, optionally. + +------------------------------------------------------------------------------ +-- Further optimisations: + +- We might be able to extend the scope of the inlining phase so it can + skip over more statements that don't affect the value of the inlined + expr. + diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs new file mode 100644 index 00000000..6326a8bd --- /dev/null +++ b/compiler/nativeGen/PIC.hs @@ -0,0 +1,782 @@ +{- + This module handles generation of position independent code and + dynamic-linking related issues for the native code generator. + + This depends both the architecture and OS, so we define it here + instead of in one of the architecture specific modules. + + Things outside this module which are related to this: + + + module CLabel + - PIC base label (pretty printed as local label 1) + - DynamicLinkerLabels - several kinds: + CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset + - labelDynamic predicate + + module Cmm + - The GlobalReg datatype has a PicBaseReg constructor + - The CmmLit datatype has a CmmLabelDiffOff constructor + + codeGen & RTS + - When tablesNextToCode, no absolute addresses are stored in info tables + any more. Instead, offsets from the info label are used. + - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers + because Win32 doesn't support external references in data sections. + TODO: make sure this still works, it might be bitrotted + + NCG + - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all + labels. + - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output + all the necessary stuff for imported symbols. + - The NCG monad keeps track of a list of imported symbols. + - MachCodeGen invokes initializePicBase to generate code to initialize + the PIC base register when needed. + - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel + that wasn't in the original Cmm code (e.g. floating point literals). +-} + +module PIC ( + cmmMakeDynamicReference, + CmmMakeDynamicReferenceM(..), + ReferenceKind(..), + needImportedSymbols, + pprImportedSymbol, + pprGotDeclaration, + + initializePicBase_ppc, + initializePicBase_x86 +) + +where + +import qualified PPC.Instr as PPC +import qualified PPC.Regs as PPC + +import qualified X86.Instr as X86 + +import Platform +import Instruction +import Reg +import NCGMonad + + +import Hoopl +import Cmm +import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, + mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), + dynamicLinkerLabelInfo, mkPicBaseLabel, + labelDynamic, externallyVisibleCLabel ) + +import CLabel ( mkForeignLabel ) + + +import BasicTypes +import Module + +import Outputable + +import DynFlags +import FastString + + + +-------------------------------------------------------------------------------- +-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm +-- code. It does The Right Thing(tm) to convert the CmmLabel into a +-- position-independent, dynamic-linking-aware reference to the thing +-- in question. +-- Note that this also has to be called from MachCodeGen in order to +-- access static data like floating point literals (labels that were +-- created after the cmmToCmm pass). +-- The function must run in a monad that can keep track of imported symbols +-- A function for recording an imported symbol must be passed in: +-- - addImportCmmOpt for the CmmOptM monad +-- - addImportNat for the NatM monad. + +data ReferenceKind + = DataReference + | CallReference + | JumpReference + deriving(Eq) + +class Monad m => CmmMakeDynamicReferenceM m where + addImport :: CLabel -> m () + getThisModule :: m Module + +instance CmmMakeDynamicReferenceM NatM where + addImport = addImportNat + getThisModule = getThisModuleNat + +cmmMakeDynamicReference + :: CmmMakeDynamicReferenceM m + => DynFlags + -> ReferenceKind -- whether this is the target of a jump + -> CLabel -- the label + -> m CmmExpr + +cmmMakeDynamicReference dflags referenceKind lbl + | Just _ <- dynamicLinkerLabelInfo lbl + = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through + + | otherwise + = do this_mod <- getThisModule + case howToAccessLabel + dflags + (platformArch $ targetPlatform dflags) + (platformOS $ targetPlatform dflags) + this_mod + referenceKind lbl of + + AccessViaStub -> do + let stub = mkDynamicLinkerLabel CodeStub lbl + addImport stub + return $ CmmLit $ CmmLabel stub + + AccessViaSymbolPtr -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags) + + AccessDirectly -> case referenceKind of + -- for data, we might have to make some calculations: + DataReference -> return $ cmmMakePicReference dflags lbl + -- all currently supported processors support + -- PC-relative branch and call instructions, + -- so just jump there if it's a call or a jump + _ -> return $ CmmLit $ CmmLabel lbl + + +-- ----------------------------------------------------------------------------- +-- Create a position independent reference to a label. +-- (but do not bother with dynamic linking). +-- We calculate the label's address by adding some (platform-dependent) +-- offset to our base register; this offset is calculated by +-- the function picRelative in the platform-dependent part below. + +cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr +cmmMakePicReference dflags lbl + + -- Windows doesn't need PIC, + -- everything gets relocated at runtime + | OSMinGW32 <- platformOS $ targetPlatform dflags + = CmmLit $ CmmLabel lbl + + + | (gopt Opt_PIC dflags || not (gopt Opt_Static dflags)) && absoluteLabel lbl + = CmmMachOp (MO_Add (wordWidth dflags)) + [ CmmReg (CmmGlobal PicBaseReg) + , CmmLit $ picRelative + (platformArch $ targetPlatform dflags) + (platformOS $ targetPlatform dflags) + lbl ] + + | otherwise + = CmmLit $ CmmLabel lbl + + +absoluteLabel :: CLabel -> Bool +absoluteLabel lbl + = case dynamicLinkerLabelInfo lbl of + Just (GotSymbolPtr, _) -> False + Just (GotSymbolOffset, _) -> False + _ -> True + + +-------------------------------------------------------------------------------- +-- Knowledge about how special dynamic linker labels like symbol +-- pointers, code stubs and GOT offsets look like is located in the +-- module CLabel. + +-- We have to decide which labels need to be accessed +-- indirectly or via a piece of stub code. +data LabelAccessStyle + = AccessViaStub + | AccessViaSymbolPtr + | AccessDirectly + +howToAccessLabel + :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle + + +-- Windows +-- In Windows speak, a "module" is a set of objects linked into the +-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs). +-- +-- If we're compiling a multi-module program then symbols from other modules +-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the +-- following. +-- +-- (in the local module) +-- __imp_SYMBOL: addr of SYMBOL +-- +-- (in the other module) +-- SYMBOL: the real function / data. +-- +-- To access the function at SYMBOL from our local module, we just need to +-- dereference the local __imp_SYMBOL. +-- +-- If Opt_Static is set then we assume that all our code will be linked +-- into the same .exe file. In this case we always access symbols directly, +-- and never use __imp_SYMBOL. +-- +howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl + + -- Assume all symbols will be in the same PE, so just access them directly. + | gopt Opt_Static dflags + = AccessDirectly + + -- If the target symbol is in another PE we need to access it via the + -- appropriate __imp_SYMBOL pointer. + | labelDynamic dflags (thisPackage dflags) this_mod lbl + = AccessViaSymbolPtr + + -- Target symbol is in the same PE as the caller, so just access it directly. + | otherwise + = AccessDirectly + + +-- Mach-O (Darwin, Mac OS X) +-- +-- Indirect access is required in the following cases: +-- * things imported from a dynamic library +-- * (not on x86_64) data from a different module, if we're generating PIC code +-- It is always possible to access something indirectly, +-- even when it's not necessary. +-- +howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl + -- data access to a dynamic library goes via a symbol pointer + | labelDynamic dflags (thisPackage dflags) this_mod lbl + = AccessViaSymbolPtr + + -- when generating PIC code, all cross-module data references must + -- must go via a symbol pointer, too, because the assembler + -- cannot generate code for a label difference where one + -- label is undefined. Doesn't apply t x86_64. + -- Unfortunately, we don't know whether it's cross-module, + -- so we do it for all externally visible labels. + -- This is a slight waste of time and space, but otherwise + -- we'd need to pass the current Module all the way in to + -- this function. + | arch /= ArchX86_64 + , gopt Opt_PIC dflags && externallyVisibleCLabel lbl + = AccessViaSymbolPtr + + | otherwise + = AccessDirectly + +howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl + -- dyld code stubs don't work for tailcalls because the + -- stack alignment is only right for regular calls. + -- Therefore, we have to go via a symbol pointer: + | arch == ArchX86 || arch == ArchX86_64 + , labelDynamic dflags (thisPackage dflags) this_mod lbl + = AccessViaSymbolPtr + + +howToAccessLabel dflags arch OSDarwin this_mod _ lbl + -- Code stubs are the usual method of choice for imported code; + -- not needed on x86_64 because Apple's new linker, ld64, generates + -- them automatically. + | arch /= ArchX86_64 + , labelDynamic dflags (thisPackage dflags) this_mod lbl + = AccessViaStub + + | otherwise + = AccessDirectly + +-- ELF (Linux) +-- +-- ELF tries to pretend to the main application code that dynamic linking does +-- not exist. While this may sound convenient, it tends to mess things up in +-- very bad ways, so we have to be careful when we generate code for the main +-- program (-dynamic but no -fPIC). +-- +-- Indirect access is required for references to imported symbols +-- from position independent code. It is also required from the main program +-- when dynamic libraries containing Haskell code are used. + +howToAccessLabel _ ArchPPC_64 os _ kind _ + | osElfTarget os + = if kind == DataReference + -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC + then AccessViaSymbolPtr + -- actually, .label instead of label + else AccessDirectly + +howToAccessLabel dflags _ os _ _ _ + -- no PIC -> the dynamic linker does everything for us; + -- if we don't dynamically link to Haskell code, + -- it actually manages to do so without messing things up. + | osElfTarget os + , not (gopt Opt_PIC dflags) && gopt Opt_Static dflags + = AccessDirectly + +howToAccessLabel dflags arch os this_mod DataReference lbl + | osElfTarget os + = case () of + -- A dynamic label needs to be accessed via a symbol pointer. + _ | labelDynamic dflags (thisPackage dflags) this_mod lbl + -> AccessViaSymbolPtr + + -- For PowerPC32 -fPIC, we have to access even static data + -- via a symbol pointer (see below for an explanation why + -- PowerPC32 Linux is especially broken). + | arch == ArchPPC + , gopt Opt_PIC dflags + -> AccessViaSymbolPtr + + | otherwise + -> AccessDirectly + + + -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons: + -- on i386, the position-independent symbol stubs in the Procedure Linkage Table + -- require the address of the GOT to be loaded into register %ebx on entry. + -- The linker will take any reference to the symbol stub as a hint that + -- the label in question is a code label. When linking executables, this + -- will cause the linker to replace even data references to the label with + -- references to the symbol stub. + + -- This leaves calling a (foreign) function from non-PIC code + -- (AccessDirectly, because we get an implicit symbol stub) + -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) + +howToAccessLabel dflags arch os this_mod CallReference lbl + | osElfTarget os + , labelDynamic dflags (thisPackage dflags) this_mod lbl && not (gopt Opt_PIC dflags) + = AccessDirectly + + | osElfTarget os + , arch /= ArchX86 + , labelDynamic dflags (thisPackage dflags) this_mod lbl && gopt Opt_PIC dflags + = AccessViaStub + +howToAccessLabel dflags _ os this_mod _ lbl + | osElfTarget os + = if labelDynamic dflags (thisPackage dflags) this_mod lbl + then AccessViaSymbolPtr + else AccessDirectly + +-- all other platforms +howToAccessLabel dflags _ _ _ _ _ + | not (gopt Opt_PIC dflags) + = AccessDirectly + + | otherwise + = panic "howToAccessLabel: PIC not defined for this platform" + + + +-- ------------------------------------------------------------------- +-- | Says what we we have to add to our 'PIC base register' in order to +-- get the address of a label. + +picRelative :: Arch -> OS -> CLabel -> CmmLit + +-- Darwin, but not x86_64: +-- The PIC base register points to the PIC base label at the beginning +-- of the current CmmDecl. We just have to use a label difference to +-- get the offset. +-- We have already made sure that all labels that are not from the current +-- module are accessed indirectly ('as' can't calculate differences between +-- undefined labels). +picRelative arch OSDarwin lbl + | arch /= ArchX86_64 + = CmmLabelDiffOff lbl mkPicBaseLabel 0 + + +-- PowerPC Linux: +-- The PIC base register points to our fake GOT. Use a label difference +-- to get the offset. +-- We have made sure that *everything* is accessed indirectly, so this +-- is only used for offsets from the GOT to symbol pointers inside the +-- GOT. +picRelative ArchPPC os lbl + | osElfTarget os + = CmmLabelDiffOff lbl gotLabel 0 + + +-- Most Linux versions: +-- The PIC base register points to the GOT. Use foo@got for symbol +-- pointers, and foo@gotoff for everything else. +-- Linux and Darwin on x86_64: +-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers, +-- and a GotSymbolOffset label for other things. +-- For reasons of tradition, the symbol offset label is written as a plain label. +picRelative arch os lbl + | osElfTarget os || (os == OSDarwin && arch == ArchX86_64) + = let result + | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl + = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl' + + | otherwise + = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl + + in result + +picRelative _ _ _ + = panic "PositionIndependentCode.picRelative undefined for this platform" + + + +-------------------------------------------------------------------------------- + +needImportedSymbols :: DynFlags -> Arch -> OS -> Bool +needImportedSymbols dflags arch os + | os == OSDarwin + , arch /= ArchX86_64 + = True + + -- PowerPC Linux: -fPIC or -dynamic + | osElfTarget os + , arch == ArchPPC + = gopt Opt_PIC dflags || not (gopt Opt_Static dflags) + + -- i386 (and others?): -dynamic but not -fPIC + | osElfTarget os + , arch /= ArchPPC_64 + = not (gopt Opt_Static dflags) && not (gopt Opt_PIC dflags) + + | otherwise + = False + +-- gotLabel +-- The label used to refer to our "fake GOT" from +-- position-independent code. +gotLabel :: CLabel +gotLabel + -- HACK: this label isn't really foreign + = mkForeignLabel + (fsLit ".LCTOC1") + Nothing ForeignLabelInThisPackage IsData + + + +-------------------------------------------------------------------------------- +-- We don't need to declare any offset tables. +-- However, for PIC on x86, we need a small helper function. +pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc +pprGotDeclaration dflags ArchX86 OSDarwin + | gopt Opt_PIC dflags + = vcat [ + ptext (sLit ".section __TEXT,__textcoal_nt,coalesced,no_toc"), + ptext (sLit ".weak_definition ___i686.get_pc_thunk.ax"), + ptext (sLit ".private_extern ___i686.get_pc_thunk.ax"), + ptext (sLit "___i686.get_pc_thunk.ax:"), + ptext (sLit "\tmovl (%esp), %eax"), + ptext (sLit "\tret") ] + +pprGotDeclaration _ _ OSDarwin + = empty + +-- Emit GOT declaration +-- Output whatever needs to be output once per .s file. +pprGotDeclaration dflags arch os + | osElfTarget os + , arch /= ArchPPC_64 + , not (gopt Opt_PIC dflags) + = empty + + | osElfTarget os + , arch /= ArchPPC_64 + = vcat [ + -- See Note [.LCTOC1 in PPC PIC code] + ptext (sLit ".section \".got2\",\"aw\""), + ptext (sLit ".LCTOC1 = .+32768") ] + +pprGotDeclaration _ _ _ + = panic "pprGotDeclaration: no match" + + +-------------------------------------------------------------------------------- +-- On Darwin, we have to generate our own stub code for lazy binding.. +-- For each processor architecture, there are two versions, one for PIC +-- and one for non-PIC. +-- +-- Whenever you change something in this assembler output, make sure +-- the splitter in driver/split/ghc-split.lprl recognizes the new output + +pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc +pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS = OSDarwin }) importedLbl + | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl + = case gopt Opt_PIC dflags of + False -> + vcat [ + ptext (sLit ".symbol_stub"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tlis r11,ha16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr)"), + ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr)(r11)"), + ptext (sLit "\tmtctr r12"), + ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr)"), + ptext (sLit "\tbctr") + ] + True -> + vcat [ + ptext (sLit ".section __TEXT,__picsymbolstub1,") + <> ptext (sLit "symbol_stubs,pure_instructions,32"), + ptext (sLit "\t.align 2"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tmflr r0"), + ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel platform lbl, + ptext (sLit "L0$") <> pprCLabel platform lbl <> char ':', + ptext (sLit "\tmflr r11"), + ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl <> char ')', + ptext (sLit "\tmtlr r0"), + ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl + <> ptext (sLit ")(r11)"), + ptext (sLit "\tmtctr r12"), + ptext (sLit "\tbctr") + ] + $+$ vcat [ + ptext (sLit ".lazy_symbol_pointer"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\t.long dyld_stub_binding_helper")] + + | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl + = vcat [ + ptext (sLit ".non_lazy_symbol_pointer"), + char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\t.long\t0")] + + | otherwise + = empty + + +pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl + | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl + = case gopt Opt_PIC dflags of + False -> + vcat [ + ptext (sLit ".symbol_stub"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tjmp *L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr"), + ptext (sLit "L") <> pprCLabel platform lbl + <> ptext (sLit "$stub_binder:"), + ptext (sLit "\tpushl $L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr"), + ptext (sLit "\tjmp dyld_stub_binding_helper") + ] + True -> + vcat [ + ptext (sLit ".section __TEXT,__picsymbolstub2,") + <> ptext (sLit "symbol_stubs,pure_instructions,25"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\tcall ___i686.get_pc_thunk.ax"), + ptext (sLit "1:"), + ptext (sLit "\tmovl L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-1b(%eax),%edx"), + ptext (sLit "\tjmp *%edx"), + ptext (sLit "L") <> pprCLabel platform lbl + <> ptext (sLit "$stub_binder:"), + ptext (sLit "\tlea L") <> pprCLabel platform lbl + <> ptext (sLit "$lazy_ptr-1b(%eax),%eax"), + ptext (sLit "\tpushl %eax"), + ptext (sLit "\tjmp dyld_stub_binding_helper") + ] + $+$ vcat [ ptext (sLit ".section __DATA, __la_sym_ptr") + <> (if gopt Opt_PIC dflags then int 2 else int 3) + <> ptext (sLit ",lazy_symbol_pointers"), + ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\t.long L") <> pprCLabel platform lbl + <> ptext (sLit "$stub_binder")] + + | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl + = vcat [ + ptext (sLit ".non_lazy_symbol_pointer"), + char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), + ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, + ptext (sLit "\t.long\t0")] + + | otherwise + = empty + + +pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ + = empty + + +-- ELF / Linux +-- +-- In theory, we don't need to generate any stubs or symbol pointers +-- by hand for Linux. +-- +-- Reality differs from this in two areas. +-- +-- 1) If we just use a dynamically imported symbol directly in a read-only +-- section of the main executable (as GCC does), ld generates R_*_COPY +-- relocations, which are fundamentally incompatible with reversed info +-- tables. Therefore, we need a table of imported addresses in a writable +-- section. +-- The "official" GOT mechanism (label@got) isn't intended to be used +-- in position dependent code, so we have to create our own "fake GOT" +-- when not Opt_PIC && not (gopt Opt_Static dflags). +-- +-- 2) PowerPC Linux is just plain broken. +-- While it's theoretically possible to use GOT offsets larger +-- than 16 bit, the standard crt*.o files don't, which leads to +-- linker errors as soon as the GOT size exceeds 16 bit. +-- Also, the assembler doesn't support @gotoff labels. +-- In order to be able to use a larger GOT, we have to circumvent the +-- entire GOT mechanism and do it ourselves (this is also what GCC does). + + +-- When needImportedSymbols is defined, +-- the NCG will keep track of all DynamicLinkerLabels it uses +-- and output each of them using pprImportedSymbol. + +pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 }) _ + | osElfTarget (platformOS platform) + = empty + +pprImportedSymbol dflags platform importedLbl + | osElfTarget (platformOS platform) + = case dynamicLinkerLabelInfo importedLbl of + Just (SymbolPtr, lbl) + -> let symbolSize = case wordWidth dflags of + W32 -> sLit "\t.long" + W64 -> sLit "\t.quad" + _ -> panic "Unknown wordRep in pprImportedSymbol" + + in vcat [ + ptext (sLit ".section \".got2\", \"aw\""), + ptext (sLit ".LC_") <> pprCLabel platform lbl <> char ':', + ptext symbolSize <+> pprCLabel platform lbl ] + + -- PLT code stubs are generated automatically by the dynamic linker. + _ -> empty + +pprImportedSymbol _ _ _ + = panic "PIC.pprImportedSymbol: no match" + +-------------------------------------------------------------------------------- +-- Generate code to calculate the address that should be put in the +-- PIC base register. +-- This is called by MachCodeGen for every CmmProc that accessed the +-- PIC base register. It adds the appropriate instructions to the +-- top of the CmmProc. + +-- It is assumed that the first NatCmmDecl in the input list is a Proc +-- and the rest are CmmDatas. + +-- Darwin is simple: just fetch the address of a local label. +-- The FETCHPC pseudo-instruction is expanded to multiple instructions +-- during pretty-printing so that we don't have to deal with the +-- local label: + +-- PowerPC version: +-- bcl 20,31,1f. +-- 1: mflr picReg + +-- i386 version: +-- call 1f +-- 1: popl %picReg + + + +-- Get a pointer to our own fake GOT, which is defined on a per-module basis. +-- This is exactly how GCC does it in linux. + +initializePicBase_ppc + :: Arch -> OS -> Reg + -> [NatCmmDecl CmmStatics PPC.Instr] + -> NatM [NatCmmDecl CmmStatics PPC.Instr] + +initializePicBase_ppc ArchPPC os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = do + let + gotOffset = PPC.ImmConstantDiff + (PPC.ImmCLbl gotLabel) + (PPC.ImmCLbl mkPicBaseLabel) + + blocks' = case blocks of + [] -> [] + (b:bs) -> fetchPC b : map maybeFetchPC bs + + maybeFetchPC b@(BasicBlock bID _) + | bID `mapMember` info = fetchPC b + | otherwise = b + + -- GCC does PIC prologs thusly: + -- bcl 20,31,.L1 + -- .L1: + -- mflr 30 + -- addis 30,30,.LCTOC1-.L1@ha + -- addi 30,30,.LCTOC1-.L1@l + -- TODO: below we use it over temporary register, + -- it can and should be optimised by picking + -- correct PIC reg. + fetchPC (BasicBlock bID insns) = + BasicBlock bID (PPC.FETCHPC picReg + : PPC.ADDIS picReg picReg (PPC.HA gotOffset) + : PPC.ADDI picReg picReg (PPC.LO gotOffset) + : PPC.MR PPC.r30 picReg + : insns) + + return (CmmProc info lab live (ListGraph blocks') : statics) + + +initializePicBase_ppc ArchPPC OSDarwin picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) -- just one entry because of splitting + = return (CmmProc info lab live (ListGraph (b':blocks)) : statics) + + where BasicBlock bID insns = entry + b' = BasicBlock bID (PPC.FETCHPC picReg : insns) + + +initializePicBase_ppc _ _ _ _ + = panic "initializePicBase_ppc: not needed" + + +-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT +-- which pretty-prints as: +-- call 1f +-- 1: popl %picReg +-- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg +-- (See PprMach.lhs) + +initializePicBase_x86 + :: Arch -> OS -> Reg + -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] + +initializePicBase_x86 ArchX86 os picReg + (CmmProc info lab live (ListGraph blocks) : statics) + | osElfTarget os + = return (CmmProc info lab live (ListGraph blocks') : statics) + where blocks' = case blocks of + [] -> [] + (b:bs) -> fetchGOT b : map maybeFetchGOT bs + + -- we want to add a FETCHGOT instruction to the beginning of + -- every block that is an entry point, which corresponds to + -- the blocks that have entries in the info-table mapping. + maybeFetchGOT b@(BasicBlock bID _) + | bID `mapMember` info = fetchGOT b + | otherwise = b + + fetchGOT (BasicBlock bID insns) = + BasicBlock bID (X86.FETCHGOT picReg : insns) + +initializePicBase_x86 ArchX86 OSDarwin picReg + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) + + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) + +initializePicBase_x86 _ _ _ _ + = panic "initializePicBase_x86: not needed" + diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs new file mode 100644 index 00000000..63a7c18c --- /dev/null +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -0,0 +1,1478 @@ +{-# LANGUAGE CPP, GADTs #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, (b) the type signatures, and +-- (c) the #if blah_TARGET_ARCH} things, the +-- structure should not be too overwhelming. + +module PPC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" +#include "../includes/MachDeps.h" + +-- NCG stuff: +import CodeGen.Platform +import PPC.Instr +import PPC.Cond +import PPC.Regs +import CPrim +import NCGMonad +import Instruction +import PIC +import Size +import RegClass +import Reg +import TargetReg +import Platform + +-- Our intermediate code: +import BlockId +import PprCmm ( pprExpr ) +import Cmm +import CmmUtils +import CLabel +import Hoopl + +-- The rest: +import OrdList +import Outputable +import Unique +import DynFlags + +import Control.Monad ( mapAndUnzipM, when ) +import Data.Bits +import Data.Word + +import BasicTypes +import FastString +import Util + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal (pre-order?) yields the insns in the correct +-- order. + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl CmmStatics Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + dflags <- getDynFlags + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS $ targetPlatform dflags + case picBaseMb of + Just picBase -> initializePicBase_ppc ArchPPC os picBase tops + Nothing -> return tops + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen + :: Block CmmNode C C + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl CmmStatics Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + dflags <- getDynFlags + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode size reg src + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType dflags reg + size = cmmTypeSize ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode size addr src + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType dflags src + size = cmmTypeSize ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> do dflags <- getDynFlags + genSwitch dflags arg ids + CmmCall { cml_target = arg } -> genJump arg + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Size -> Register +swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code +swizzleRegisterRep (Any _ codefn) size = Any size codefn + + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + + +{- +Now, given a tree (the argument to an CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) + + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr +mangleIndexTree dflags (CmmRegOff reg off) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) + +mangleIndexTree _ _ + = panic "PPC.CodeGen.mangleIndexTree: no match" + +-- ----------------------------------------------------------------------------- +-- Code gen for 64-bit arithmetic on 32-bit platforms + +{- +Simple support for generating 64-bit code (ie, 64 bit values and 64 +bit assignments) on 32-bit platforms. Unlike the main code generator +we merely shoot for generating working code as simply as possible, and +pay little attention to code quality. Specifically, there is no +attempt to deal cleverly with the fixed-vs-floating register +distinction; all values are generated into (pairs of) floating +registers, even if this would mean some redundant reg-reg moves as a +result. Only one of the VRegUniques is returned, since it will be +of the VRegUniqueLo form, and the upper-half VReg can be determined +by applying getHiVRegFromLo to it. +-} + +data ChildCode64 -- a.k.a "Register64" + = ChildCode64 + InstrBlock -- code + Reg -- the lower 32-bit temporary which contains the + -- result; use getHiVRegFromLo to find the other + -- VRegUnique. Rules of this simplified insn + -- selection game are therefore that the returned + -- Reg may be modified + + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + +getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) +getI64Amodes addrTree = do + Amode hi_addr addr_code <- getAmode addrTree + case addrOffset hi_addr 4 of + Just lo_addr -> return (hi_addr, lo_addr, addr_code) + Nothing -> do (hi_ptr, code) <- getSomeReg addrTree + return (AddrRegImm hi_ptr (ImmInt 0), + AddrRegImm hi_ptr (ImmInt 4), + code) + + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + ChildCode64 vcode rlo <- iselExpr64 valueTree + let + rhi = getHiVRegFromLo rlo + + -- Big-endian store + mov_hi = ST II32 rhi hi_addr + mov_lo = ST II32 rlo lo_addr + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MR r_dst_lo r_src_lo + mov_hi = MR r_dst_hi r_src_hi + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(powerpc): invalid lvalue" + + +iselExpr64 :: CmmExpr -> NatM ChildCode64 +iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do + (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = LD II32 rhi hi_addr + mov_lo = LD II32 rlo lo_addr + return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo + +iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty + = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) + +iselExpr64 (CmmLit (CmmInt i _)) = do + (rlo,rhi) <- getNewRegPairNat II32 + let + half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + + code = toOL [ + LIS rlo (ImmInt half1), + OR rlo rlo (RIImm $ ImmInt half0), + LIS rhi (ImmInt half3), + OR rhi rhi (RIImm $ ImmInt half2) + ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ ADDC rlo r1lo r2lo, + ADDE rhi r1hi r2hi ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ SUBFC rlo r2lo r1lo, + SUBFE rhi r2hi r1hi ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = LI rhi (ImmInt 0) + mov_lo = MR rlo expr_reg + return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo +iselExpr64 expr + = pprPanic "iselExpr64(powerpc)" (pprExpr expr) + + + +getRegister :: CmmExpr -> NatM Register +getRegister e = do dflags <- getDynFlags + getRegister' dflags e + +getRegister' :: DynFlags -> CmmExpr -> NatM Register + +getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) + = do + reg <- getPicBaseNat archWordSize + return (Fixed archWordSize reg nilOL) + +getRegister' dflags (CmmReg reg) + = return (Fixed (cmmTypeSize (cmmRegType dflags reg)) + (getRegisterReg (targetPlatform dflags) reg) nilOL) + +getRegister' dflags tree@(CmmRegOff _ _) + = getRegister' dflags (mangleIndexTree dflags tree) + + -- for 32-bit architectuers, support some 64 -> 32 bit conversions: + -- TO_W_(x), TO_W_(x >> 32) + +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' dflags (CmmLoad mem pk) + | not (isWord64 pk) + = do + let platform = targetPlatform dflags + Amode addr addr_code <- getAmode mem + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) + addr_code `snocOL` LD size dst addr + return (Any size code) + where size = cmmTypeSize pk + +-- catch simple cases of zero- or sign-extended load +getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode mem + return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) + +-- Note: there is no Load Byte Arithmetic instruction, so no signed case here + +getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode mem + return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) + +getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do + Amode addr addr_code <- getAmode mem + return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) + +getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps + = case mop of + MO_Not rep -> triv_ucode_int rep NOT + + MO_F_Neg w -> triv_ucode_float w FNEG + MO_S_Neg w -> triv_ucode_int w NEG + + MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x + MO_FF_Conv W32 W64 -> conversionNop FF64 x + + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + MO_SS_Conv from to + | from == to -> conversionNop (intSize to) x + + -- narrowing is a nop: we treat the high bits as undefined + MO_SS_Conv W32 to -> conversionNop (intSize to) x + MO_SS_Conv W16 W8 -> conversionNop II8 x + MO_SS_Conv W8 to -> triv_ucode_int to (EXTS II8) + MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16) + + MO_UU_Conv from to + | from == to -> conversionNop (intSize to) x + -- narrowing is a nop: we treat the high bits as undefined + MO_UU_Conv W32 to -> conversionNop (intSize to) x + MO_UU_Conv W16 W8 -> conversionNop II8 x + MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32)) + MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + triv_ucode_int width instr = trivialUCode (intSize width) instr x + triv_ucode_float width instr = trivialUCode (floatSize width) instr x + + conversionNop new_size expr + = do e_code <- getRegister' dflags expr + return (swizzleRegisterRep e_code new_size) + +getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps + = case mop of + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y) + MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y) + + MO_S_Gt rep -> condIntReg GTT (extendSExpr rep x) (extendSExpr rep y) + MO_S_Ge rep -> condIntReg GE (extendSExpr rep x) (extendSExpr rep y) + MO_S_Lt rep -> condIntReg LTT (extendSExpr rep x) (extendSExpr rep y) + MO_S_Le rep -> condIntReg LE (extendSExpr rep x) (extendSExpr rep y) + + MO_U_Gt rep -> condIntReg GU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Ge rep -> condIntReg GEU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Lt rep -> condIntReg LU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Le rep -> condIntReg LEU (extendUExpr rep x) (extendUExpr rep y) + + MO_F_Add w -> triv_float w FADD + MO_F_Sub w -> triv_float w FSUB + MO_F_Mul w -> triv_float w FMUL + MO_F_Quot w -> triv_float w FDIV + + -- optimize addition with 32-bit immediate + -- (needed for PIC) + MO_Add W32 -> + case y of + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True (-imm) + -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep) + CmmLit lit + -> do + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + code dst = srcCode `appOL` toOL [ + ADDIS dst src (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + return (Any II32 code) + _ -> trivialCode W32 True ADD x y + + MO_Add rep -> trivialCode rep True ADD x y + MO_Sub rep -> + case y of -- subfi ('substract from' with immediate) doesn't exist + CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm) + -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) + _ -> trivialCodeNoImm' (intSize rep) SUBF y x + + MO_Mul rep -> trivialCode rep True MULLW x y + + MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y + + MO_S_MulMayOflo _ -> panic "S_MulMayOflo (rep /= II32): not implemented" + MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented" + + MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y) + MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y) + + MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y) + MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y) + + MO_And rep -> trivialCode rep False AND x y + MO_Or rep -> trivialCode rep False OR x y + MO_Xor rep -> trivialCode rep False XOR x y + + MO_Shl rep -> trivialCode rep False SLW x y + MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y + MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y + _ -> panic "PPC.CodeGen.getRegister: no match" + + where + triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register + triv_float width instr = trivialCodeNoImm (floatSize width) instr x y + +getRegister' _ (CmmLit (CmmInt i rep)) + | Just imm <- makeImmediate rep True i + = let + code dst = unitOL (LI dst imm) + in + return (Any (intSize rep) code) + +getRegister' _ (CmmLit (CmmFloat f frep)) = do + lbl <- getNewLabelNat + dflags <- getDynFlags + dynRef <- cmmMakeDynamicReference dflags DataReference lbl + Amode addr addr_code <- getAmode dynRef + let size = floatSize frep + code dst = + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) + `consOL` (addr_code `snocOL` LD size dst addr) + return (Any size code) + +getRegister' dflags (CmmLit lit) + = let rep = cmmLitType dflags lit + imm = litToImm lit + code dst = toOL [ + LIS dst (HA imm), + ADD dst dst (RIImm (LO imm)) + ] + in return (Any (cmmTypeSize rep) code) + +getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) + + -- extend?Rep: wrap integer expression of type rep + -- in a conversion to II32 +extendSExpr :: Width -> CmmExpr -> CmmExpr +extendSExpr W32 x = x +extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x] + +extendUExpr :: Width -> CmmExpr -> CmmExpr +extendUExpr W32 x = x +extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x] + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. + +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to an CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + +getAmode :: CmmExpr -> NatM Amode +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) + +getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True (-i) + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + +getAmode (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) + | Just off <- makeImmediate W32 True i + = do + (reg, code) <- getSomeReg x + return (Amode (AddrRegImm reg off) code) + + -- optimize addition with 32-bit immediate + -- (needed for PIC) +getAmode (CmmMachOp (MO_Add W32) [x, CmmLit lit]) + = do + tmp <- getNewRegNat II32 + (src, srcCode) <- getSomeReg x + let imm = litToImm lit + code = srcCode `snocOL` ADDIS tmp src (HA imm) + return (Amode (AddrRegImm tmp (LO imm)) code) + +getAmode (CmmLit lit) + = do + tmp <- getNewRegNat II32 + let imm = litToImm lit + code = unitOL (LIS tmp (HA imm)) + return (Amode (AddrRegImm tmp (LO imm)) code) + +getAmode (CmmMachOp (MO_Add W32) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) + +getAmode other + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) + + + +-- The 'CondCode' type: Condition codes passed up the tree. +data CondCode + = CondCode Bool Cond InstrBlock + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- almost the same as everywhere else - but we need to +-- extend small integers to 32 bit first + +getCondCode (CmmMachOp mop [x, y]) + = case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + MO_Eq rep -> condIntCode EQQ (extendUExpr rep x) (extendUExpr rep y) + MO_Ne rep -> condIntCode NE (extendUExpr rep x) (extendUExpr rep y) + + MO_S_Gt rep -> condIntCode GTT (extendSExpr rep x) (extendSExpr rep y) + MO_S_Ge rep -> condIntCode GE (extendSExpr rep x) (extendSExpr rep y) + MO_S_Lt rep -> condIntCode LTT (extendSExpr rep x) (extendSExpr rep y) + MO_S_Le rep -> condIntCode LE (extendSExpr rep x) (extendSExpr rep y) + + MO_U_Gt rep -> condIntCode GU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Ge rep -> condIntCode GEU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y) + MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y) + + _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) + +getCondCode _ = panic "getCondCode(2)(powerpc)" + + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +-- ###FIXME: I16 and I8! +condIntCode cond x (CmmLit (CmmInt y rep)) + | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y + = do + (src1, code) <- getSomeReg x + let + code' = code `snocOL` + (if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2) + return (CondCode False cond code') + +condIntCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code' = code1 `appOL` code2 `snocOL` + (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2) + return (CondCode False cond code') + +condFltCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 + code'' = case cond of -- twiddle CR to handle unordered case + GE -> code' `snocOL` CRNOR ltbit eqbit gtbit + LE -> code' `snocOL` CRNOR gtbit eqbit ltbit + _ -> code' + where + ltbit = 0 ; eqbit = 2 ; gtbit = 1 + return (CondCode True cond code'') + + + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- getAmode addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + +-- dst is a reg, but src could be anything +assignReg_IntCode _ reg src + = do + dflags <- getDynFlags + let dst = getRegisterReg (targetPlatform dflags) reg + r <- getRegister src + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` MR dst freg + + + +-- Easy, isn't it? +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + + + +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock + +genJump (CmmLit (CmmLabel lbl)) + = return (unitOL $ JMP lbl) + +genJump tree + = do + (target,code) <- getSomeReg tree + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) + + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. +-} + + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock + +genCondJump id bool = do + CondCode _ cond code <- getCondCode bool + return (code `snocOL` BCC cond id) + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +genCCall :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall target dest_regs argsAndHints + = do dflags <- getDynFlags + let platform = targetPlatform dflags + case platformOS platform of + OSLinux -> genCCall' dflags GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints + _ -> panic "PPC.CodeGen.genCCall: not defined for this os" + +data GenCCallPlatform = GCPLinux | GCPDarwin + +genCCall' + :: DynFlags + -> GenCCallPlatform + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +{- + The PowerPC calling convention for Darwin/Mac OS X + is described in Apple's document + "Inside Mac OS X - Mach-O Runtime Architecture". + + PowerPC Linux uses the System V Release 4 Calling Convention + for PowerPC. It is described in the + "System V Application Binary Interface PowerPC Processor Supplement". + + Both conventions are similar: + Parameters may be passed in general-purpose registers starting at r3, in + floating point registers starting at f1, or on the stack. + + But there are substantial differences: + * The number of registers used for parameter passing and the exact set of + nonvolatile registers differs (see MachRegs.lhs). + * On Darwin, stack space is always reserved for parameters, even if they are + passed in registers. The called routine may choose to save parameters from + registers to the corresponding space on the stack. + * On Darwin, a corresponding amount of GPRs is skipped when a floating point + parameter is passed in an FPR. + * SysV insists on either passing I64 arguments on the stack, or in two GPRs, + starting with an odd-numbered GPR. It may skip a GPR to achieve this. + Darwin just treats an I64 like two separate II32s (high word first). + * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only + 4-byte aligned like everything else on Darwin. + * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on + PowerPC Linux does not agree, so neither do we. + + According to both conventions, The parameter area should be part of the + caller's stack frame, allocated in the caller's prologue code (large enough + to hold the parameter lists for all called routines). The NCG already + uses the stack for register spilling, leaving 64 bytes free at the top. + If we need a larger parameter area than that, we just allocate a new stack + frame just before ccalling. +-} + + +genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ + = return $ unitOL LWSYNC + +genCCall' _ _ (PrimTarget MO_Touch) _ _ + = return $ nilOL + +genCCall' _ _ (PrimTarget (MO_Prefetch_Data _)) _ _ + = return $ nilOL + +genCCall' dflags gcp target dest_regs args0 + = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeSize argReps) + -- we rely on argument promotion in the codeGen + do + (finalStack,passArgumentsCode,usedRegs) <- passArguments + (zip args argReps) + allArgRegs + (allFPArgRegs platform) + initialStackOffset + (toOL []) [] + + (labelOrExpr, reduceToFF32) <- case target of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + uses_pic_base_implicitly + return (Left lbl, False) + ForeignTarget expr _ -> do + uses_pic_base_implicitly + return (Right expr, False) + PrimTarget mop -> outOfLineMachOp mop + + let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode + codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 + + case labelOrExpr of + Left lbl -> do + return ( codeBefore + `snocOL` BL lbl usedRegs + `appOL` codeAfter) + Right dyn -> do + (dynReg, dynCode) <- getSomeReg dyn + return ( dynCode + `snocOL` MTCTR dynReg + `appOL` codeBefore + `snocOL` BCTRL usedRegs + `appOL` codeAfter) + where + platform = targetPlatform dflags + + uses_pic_base_implicitly = do + -- See Note [implicit register in PPC PIC code] + -- on why we claim to use PIC register here + when (gopt Opt_PIC dflags) $ do + _ <- getPicBaseNat archWordSize + return () + + initialStackOffset = case gcp of + GCPDarwin -> 24 + GCPLinux -> 8 + -- size of linkage area + size of arguments, in bytes + stackDelta finalStack = case gcp of + GCPDarwin -> + roundTo 16 $ (24 +) $ max 32 $ sum $ + map (widthInBytes . typeWidth) argReps + GCPLinux -> roundTo 16 finalStack + + -- need to remove alignment information + args | PrimTarget mop <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init args0 + + | otherwise + = args0 + + argReps = map (cmmExprType dflags) args0 + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + move_sp_down finalStack + | delta > 64 = + toOL [STU II32 sp (AddrRegImm sp (ImmInt (-delta))), + DELTA (-delta)] + | otherwise = nilOL + where delta = stackDelta finalStack + move_sp_up finalStack + | delta > 64 = + toOL [ADD sp sp (RIImm (ImmInt delta)), + DELTA 0] + | otherwise = nilOL + where delta = stackDelta finalStack + + + passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) + passArguments ((arg,arg_ty):args) gprs fprs stackOffset + accumCode accumUsed | isWord64 arg_ty = + do + ChildCode64 code vr_lo <- iselExpr64 arg + let vr_hi = getHiVRegFromLo vr_lo + + case gcp of + GCPDarwin -> + do let storeWord vr (gpr:_) _ = MR gpr vr + storeWord vr [] offset + = ST II32 vr (AddrRegImm sp (ImmInt offset)) + passArguments args + (drop 2 gprs) + fprs + (stackOffset+8) + (accumCode `appOL` code + `snocOL` storeWord vr_hi gprs stackOffset + `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) + ((take 2 gprs) ++ accumUsed) + GCPLinux -> + do let stackOffset' = roundTo 8 stackOffset + stackCode = accumCode `appOL` code + `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) + `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) + regCode hireg loreg = + accumCode `appOL` code + `snocOL` MR hireg vr_hi + `snocOL` MR loreg vr_lo + + case gprs of + hireg : loreg : regs | even (length gprs) -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _skipped : hireg : loreg : regs -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _ -> -- only one or no regs left + passArguments args [] fprs (stackOffset'+8) + stackCode accumUsed + + passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed + | reg : _ <- regs = do + register <- getRegister arg + let code = case register of + Fixed _ freg fcode -> fcode `snocOL` MR reg freg + Any _ acode -> acode reg + stackOffsetRes = case gcp of + -- The Darwin ABI requires that we reserve + -- stack slots for register parameters + GCPDarwin -> stackOffset + stackBytes + -- ... the SysV ABI doesn't. + GCPLinux -> stackOffset + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + stackOffsetRes + (accumCode `appOL` code) + (reg : accumUsed) + | otherwise = do + (vr, code) <- getSomeReg arg + passArguments args + (drop nGprs gprs) + (drop nFprs fprs) + (stackOffset' + stackBytes) + (accumCode `appOL` code `snocOL` ST (cmmTypeSize rep) vr stackSlot) + accumUsed + where + stackOffset' = case gcp of + GCPDarwin -> + -- stackOffset is at least 4-byte aligned + -- The Darwin ABI is happy with that. + stackOffset + GCPLinux + -- ... the SysV ABI requires 8-byte + -- alignment for doubles. + | isFloatType rep && typeWidth rep == W64 -> + roundTo 8 stackOffset + | otherwise -> + stackOffset + stackSlot = AddrRegImm sp (ImmInt stackOffset') + (nGprs, nFprs, stackBytes, regs) + = case gcp of + GCPDarwin -> + case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- The Darwin ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + FF32 -> (1, 1, 4, fprs) + FF64 -> (2, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" + GCPLinux -> + case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) + II16 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- ... the SysV ABI doesn't. + FF32 -> (0, 1, 4, fprs) + FF64 -> (0, 1, 8, fprs) + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" + + moveResult reduceToFF32 = + case dest_regs of + [] -> nilOL + [dest] + | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) + | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) + | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, + MR r_dest r4] + | otherwise -> unitOL (MR r_dest r3) + where rep = cmmRegType dflags (CmmLocal dest) + r_dest = getRegisterReg platform (CmmLocal dest) + _ -> panic "genCCall' moveResult: Bad dest_regs" + + outOfLineMachOp mop = + do + dflags <- getDynFlags + mopExpr <- cmmMakeDynamicReference dflags CallReference $ + mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction + let mopLabelOrExpr = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + return (mopLabelOrExpr, reduce) + where + (functionName, reduce) = case mop of + MO_F32_Exp -> (fsLit "exp", True) + MO_F32_Log -> (fsLit "log", True) + MO_F32_Sqrt -> (fsLit "sqrt", True) + + MO_F32_Sin -> (fsLit "sin", True) + MO_F32_Cos -> (fsLit "cos", True) + MO_F32_Tan -> (fsLit "tan", True) + + MO_F32_Asin -> (fsLit "asin", True) + MO_F32_Acos -> (fsLit "acos", True) + MO_F32_Atan -> (fsLit "atan", True) + + MO_F32_Sinh -> (fsLit "sinh", True) + MO_F32_Cosh -> (fsLit "cosh", True) + MO_F32_Tanh -> (fsLit "tanh", True) + MO_F32_Pwr -> (fsLit "pow", True) + + MO_F64_Exp -> (fsLit "exp", False) + MO_F64_Log -> (fsLit "log", False) + MO_F64_Sqrt -> (fsLit "sqrt", False) + + MO_F64_Sin -> (fsLit "sin", False) + MO_F64_Cos -> (fsLit "cos", False) + MO_F64_Tan -> (fsLit "tan", False) + + MO_F64_Asin -> (fsLit "asin", False) + MO_F64_Acos -> (fsLit "acos", False) + MO_F64_Atan -> (fsLit "atan", False) + + MO_F64_Sinh -> (fsLit "sinh", False) + MO_F64_Cosh -> (fsLit "cosh", False) + MO_F64_Tanh -> (fsLit "tanh", False) + MO_F64_Pwr -> (fsLit "pow", False) + + MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False) + + MO_Memcpy -> (fsLit "memcpy", False) + MO_Memset -> (fsLit "memset", False) + MO_Memmove -> (fsLit "memmove", False) + + MO_BSwap w -> (fsLit $ bSwapLabel w, False) + MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_Clz w -> (fsLit $ clzLabel w, False) + MO_Ctz w -> (fsLit $ ctzLabel w, False) + MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) + MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _ ) -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock +genSwitch dflags expr ids + | gopt Opt_PIC dflags + = do + (reg,e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + lbl <- getNewLabelNat + dflags <- getDynFlags + dynRef <- cmmMakeDynamicReference dflags DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let code = e_code `appOL` t_code `appOL` toOL [ + SLW tmp reg (RIImm (ImmInt 2)), + LD II32 tmp (AddrRegReg tableReg tmp), + ADD tmp tmp (RIReg tableReg), + MTCTR tmp, + BCTR ids (Just lbl) + ] + return code + | otherwise + = do + (reg,e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + lbl <- getNewLabelNat + let code = e_code `appOL` toOL [ + SLW tmp reg (RIImm (ImmInt 2)), + ADDIS tmp tmp (HA (ImmCLbl lbl)), + LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), + MTCTR tmp, + BCTR ids (Just lbl) + ] + return code + +generateJumpTableForInstr :: DynFlags -> Instr + -> Maybe (NatCmmDecl CmmStatics Instr) +generateJumpTableForInstr dflags (BCTR ids (Just lbl)) = + let jumpTable + | gopt Opt_PIC dflags = map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry dflags) ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register + +condReg :: NatM CondCode -> NatM Register +condReg getCond = do + CondCode _ cond cond_code <- getCond + let +{- code dst = cond_code `appOL` toOL [ + BCC cond lbl1, + LI dst (ImmInt 0), + BCC ALWAYS lbl2, + NEWBLOCK lbl1, + LI dst (ImmInt 1), + BCC ALWAYS lbl2, + NEWBLOCK lbl2 + ]-} + code dst = cond_code + `appOL` negate_code + `appOL` toOL [ + MFCR dst, + RLWINM dst dst (bit + 1) 31 31 + ] + + negate_code | do_negate = unitOL (CRNOR bit bit bit) + | otherwise = nilOL + + (bit, do_negate) = case cond of + LTT -> (0, False) + LE -> (1, True) + EQQ -> (2, False) + GE -> (0, True) + GTT -> (1, False) + + NE -> (2, True) + + LU -> (0, False) + LEU -> (1, True) + GEU -> (0, True) + GU -> (1, False) + _ -> panic "PPC.CodeGen.codeReg: no match" + + return (Any II32 code) + +condIntReg cond x y = condReg (condIntCode cond x y) +condFltReg cond x y = condReg (condFltCode cond x y) + + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + + +{- +Wolfgang's PowerPC version of The Rules: + +A slightly modified version of The Rules to take advantage of the fact +that PowerPC instructions work on all registers and don't implicitly +clobber any fixed registers. + +* The only expression for which getRegister returns Fixed is (CmmReg reg). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + It may *not* modify global registers, unless the global + register happens to be the destination register. + It may not clobber any other registers. In fact, only ccalls clobber any + fixed registers. + Also, it may not modify the counter register (used by genCCall). + + Corollary: If a getRegister for a subexpression returns Fixed, you need + not move it to a fresh temporary before evaluating the next subexpression. + The Fixed register won't be modified. + Therefore, we don't need a counterpart for the x86's getStableReg on PPC. + +* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on + the value of the destination register. +-} + +trivialCode + :: Width + -> Bool + -> (Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialCode rep signed instr x (CmmLit (CmmInt y _)) + | Just imm <- makeImmediate rep signed y + = do + (src1, code1) <- getSomeReg x + let code dst = code1 `snocOL` instr dst src1 (RIImm imm) + return (Any (intSize rep) code) + +trivialCode rep _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) + return (Any (intSize rep) code) + +trivialCodeNoImm' :: Size -> (Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm' size instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 + return (Any size code) + +trivialCodeNoImm :: Size -> (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCodeNoImm size instr x y = trivialCodeNoImm' size (instr size) x y + + +trivialUCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register +trivialUCode rep instr x = do + (src, code) <- getSomeReg x + let code' dst = code `snocOL` instr dst src + return (Any rep code') + +-- There is no "remainder" instruction on the PPC, so we have to do +-- it the hard way. +-- The "div" parameter is the division instruction to use (DIVW or DIVWU) + +remainderCode :: Width -> (Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +remainderCode rep div x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let code dst = code1 `appOL` code2 `appOL` toOL [ + div dst src1 src2, + MULLW dst dst (RIReg src2), + SUBF dst dst src1 + ] + return (Any (intSize rep) code) + + +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP fromRep toRep x = do + (src, code) <- getSomeReg x + lbl <- getNewLabelNat + itmp <- getNewRegNat II32 + ftmp <- getNewRegNat FF64 + dflags <- getDynFlags + dynRef <- cmmMakeDynamicReference dflags DataReference lbl + Amode addr addr_code <- getAmode dynRef + let + code' dst = code `appOL` maybe_exts `appOL` toOL [ + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], + XORIS itmp src (ImmInt 0x8000), + ST II32 itmp (spRel dflags 3), + LIS itmp (ImmInt 0x4330), + ST II32 itmp (spRel dflags 2), + LD FF64 ftmp (spRel dflags 2) + ] `appOL` addr_code `appOL` toOL [ + LD FF64 dst addr, + FSUB FF64 dst ftmp dst + ] `appOL` maybe_frsp dst + + maybe_exts = case fromRep of + W8 -> unitOL $ EXTS II8 src src + W16 -> unitOL $ EXTS II16 src src + W32 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + maybe_frsp dst + = case toRep of + W32 -> unitOL $ FRSP dst dst + W64 -> nilOL + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + + return (Any (floatSize toRep) code') + +coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int _ toRep x = do + dflags <- getDynFlags + -- the reps don't really matter: F*->FF64 and II32->I* are no-ops + (src, code) <- getSomeReg x + tmp <- getNewRegNat FF64 + let + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIWZ tmp src, + -- store value (64bit) from FP to stack + ST FF64 tmp (spRel dflags 2), + -- read low word of value (high word is undefined) + LD II32 dst (spRel dflags 3)] + return (Any (intSize toRep) code') + +-- Note [.LCTOC1 in PPC PIC code] +-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table +-- to make the most of the PPC's 16-bit displacements. +-- As 16-bit signed offset is used (usually via addi/lwz instructions) +-- first element will have '-32768' offset against .LCTOC1. + +-- Note [implicit register in PPC PIC code] +-- PPC generates calls by labels in assembly +-- in form of: +-- bl puts+32768@plt +-- in this form it's not seen directly (by GHC NCG) +-- that r30 (PicBaseReg) is used, +-- but r30 is a required part of PLT code setup: +-- puts+32768@plt: +-- lwz r11,-30484(r30) ; offset in .LCTOC1 +-- mtctr r11 +-- bctr diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs new file mode 100644 index 00000000..0e4b1fd7 --- /dev/null +++ b/compiler/nativeGen/PPC/Cond.hs @@ -0,0 +1,61 @@ +module PPC.Cond ( + Cond(..), + condNegate, + condUnsigned, + condToSigned, + condToUnsigned, +) + +where + +import Panic + +data Cond + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq + + +condNegate :: Cond -> Cond +condNegate ALWAYS = panic "condNegate: ALWAYS" +condNegate EQQ = NE +condNegate GE = LTT +condNegate GEU = LU +condNegate GTT = LE +condNegate GU = LEU +condNegate LE = GTT +condNegate LEU = GU +condNegate LTT = GE +condNegate LU = GEU +condNegate NE = EQQ + +-- Condition utils +condUnsigned :: Cond -> Bool +condUnsigned GU = True +condUnsigned LU = True +condUnsigned GEU = True +condUnsigned LEU = True +condUnsigned _ = False + +condToSigned :: Cond -> Cond +condToSigned GU = GTT +condToSigned LU = LTT +condToSigned GEU = GE +condToSigned LEU = LE +condToSigned x = x + +condToUnsigned :: Cond -> Cond +condToUnsigned GTT = GU +condToUnsigned LTT = LU +condToUnsigned GE = GEU +condToUnsigned LE = LEU +condToUnsigned x = x diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs new file mode 100644 index 00000000..4e75f063 --- /dev/null +++ b/compiler/nativeGen/PPC/Instr.hs @@ -0,0 +1,617 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module PPC.Instr ( + archWordSize, + RI(..), + Instr(..), + maxSpillSlots, + allocMoreStack, + makeFarBranches +) + +where + +import PPC.Regs +import PPC.Cond +import Instruction +import Size +import TargetReg +import RegClass +import Reg + +import CodeGen.Platform +import BlockId +import DynFlags +import Cmm +import CmmInfo +import FastString +import CLabel +import Outputable +import Platform +import FastBool +import UniqFM (listToUFM, lookupUFM) +import UniqSupply + +import Control.Monad (replicateM) +import Data.Maybe (fromMaybe) + +-------------------------------------------------------------------------------- +-- Size of a PPC memory address, in bytes. +-- +archWordSize :: Size +archWordSize = II32 + + +-- | Instruction instance for powerpc +instance Instruction Instr where + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr + mkStackAllocInstr = ppc_mkStackAllocInstr + mkStackDeallocInstr = ppc_mkStackDeallocInstr + + +ppc_mkStackAllocInstr :: Platform -> Int -> Instr +ppc_mkStackAllocInstr platform amount + = case platformArch platform of + ArchPPC -> UPDATE_SP II32 (ImmInt (-amount)) + arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch + +ppc_mkStackDeallocInstr :: Platform -> Int -> Instr +ppc_mkStackDeallocInstr platform amount + = case platformArch platform of + ArchPPC -> UPDATE_SP II32 (ImmInt amount) + arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch + +-- +-- See note [extra spill slots] in X86/Instr.hs +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics PPC.Instr.Instr + -> UniqSM (NatCmmDecl statics PPC.Instr.Instr) + +allocMoreStack _ _ top@(CmmData _ _) = return top +allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do + let + infos = mapKeys info + entries = case code of + [] -> infos + BasicBlock entry _ : _ -- first block is the entry point + | entry `elem` infos -> infos + | otherwise -> entry : infos + + uniqs <- replicateM (length entries) getUniqueM + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: BlockEnv BlockId + new_blockmap = mapFromList (zip entries (map mkBlockId uniqs)) + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id [alloc, BCC ALWAYS new_blockid] + , BasicBlock new_blockid block' + ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r + -- BCTR might or might not be a non-local jump. For + -- "labeled-goto" we use JMP, and for "computed-goto" we + -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'. + = case insn of + JMP _ -> dealloc : insn : r + BCTR [] Nothing -> dealloc : insn : r + BCTR ids label -> BCTR (map (fmap retarget) ids) label : r + BCCFAR cond b -> BCCFAR cond (retarget b) : r + BCC cond b -> BCC cond (retarget b) : r + _ -> insn : r + -- BL and BCTRL are call-like instructions rather than + -- jumps, and are used only for C calls. + + retarget :: BlockId -> BlockId + retarget b + = fromMaybe b (mapLookup b new_blockmap) + + new_code + = concatMap insert_stack_insns code + + -- in + return (CmmProc info lbl live (ListGraph new_code)) + + +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +-- Register or immediate +data RI + = RIReg Reg + | RIImm Imm + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section CmmStatics + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- Loads and stores. + | LD Size Reg AddrMode -- Load size, dst, src + | LDFAR Size Reg AddrMode -- Load format, dst, src 32 bit offset + | LA Size Reg AddrMode -- Load arithmetic size, dst, src + | ST Size Reg AddrMode -- Store size, src, dst + | STFAR Size Reg AddrMode -- Store format, src, dst 32 bit offset + | STU Size Reg AddrMode -- Store with Update size, src, dst + | LIS Reg Imm -- Load Immediate Shifted dst, src + | LI Reg Imm -- Load Immediate dst, src + | MR Reg Reg -- Move Register dst, src -- also for fmr + + | CMP Size Reg RI -- size, src1, src2 + | CMPL Size Reg RI -- size, src1, src2 + + | BCC Cond BlockId + | BCCFAR Cond BlockId + | JMP CLabel -- same as branch, + -- but with CLabel instead of block ID + | MTCTR Reg + | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary + | BL CLabel [Reg] -- with list of argument regs + | BCTRL [Reg] + + | ADD Reg Reg RI -- dst, src1, src2 + | ADDC Reg Reg Reg -- (carrying) dst, src1, src2 + | ADDE Reg Reg Reg -- (extend) dst, src1, src2 + | ADDI Reg Reg Imm -- Add Immediate dst, src1, src2 + | ADDIS Reg Reg Imm -- Add Immediate Shifted dst, src1, src2 + | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 + | SUBFC Reg Reg Reg -- (carrying) dst, src1, src2 ; dst = src2 - src1 + | SUBFE Reg Reg Reg -- (extend) dst, src1, src2 ; dst = src2 - src1 + | MULLW Reg Reg RI + | DIVW Reg Reg Reg + | DIVWU Reg Reg Reg + + | MULLW_MayOflo Reg Reg Reg + -- dst = 1 if src1 * src2 overflows + -- pseudo-instruction; pretty-printed as: + -- mullwo. dst, src1, src2 + -- mfxer dst + -- rlwinm dst, dst, 2, 31,31 + + | AND Reg Reg RI -- dst, src1, src2 + | OR Reg Reg RI -- dst, src1, src2 + | XOR Reg Reg RI -- dst, src1, src2 + | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 + + | EXTS Size Reg Reg + + | NEG Reg Reg + | NOT Reg Reg + + | SLW Reg Reg RI -- shift left word + | SRW Reg Reg RI -- shift right word + | SRAW Reg Reg RI -- shift right arithmetic word + + | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask + + | FADD Size Reg Reg Reg + | FSUB Size Reg Reg Reg + | FMUL Size Reg Reg Reg + | FDIV Size Reg Reg Reg + | FNEG Reg Reg -- negate is the same for single and double prec. + + | FCMP Reg Reg + + | FCTIWZ Reg Reg -- convert to integer word + | FRSP Reg Reg -- reduce to single precision + -- (but destination is a FP register) + + | CRNOR Int Int Int -- condition register nor + | MFCR Reg -- move from condition register + + | MFLR Reg -- move from link register + | FETCHPC Reg -- pseudo-instruction: + -- bcl to next insn, mflr reg + + | LWSYNC -- memory barrier + + | UPDATE_SP Size Imm -- expand/shrink spill area on C stack + -- pseudo-instruction + + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage +ppc_regUsageOfInstr platform instr + = case instr of + LD _ reg addr -> usage (regAddr addr, [reg]) + LDFAR _ reg addr -> usage (regAddr addr, [reg]) + LA _ reg addr -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + STFAR _ reg addr -> usage (reg : regAddr addr, []) + STU _ reg addr -> usage (reg : regAddr addr, []) + LIS reg _ -> usage ([], [reg]) + LI reg _ -> usage ([], [reg]) + MR reg1 reg2 -> usage ([reg2], [reg1]) + CMP _ reg ri -> usage (reg : regRI ri,[]) + CMPL _ reg ri -> usage (reg : regRI ri,[]) + BCC _ _ -> noUsage + BCCFAR _ _ -> noUsage + MTCTR reg -> usage ([reg],[]) + BCTR _ _ -> noUsage + BL _ params -> usage (params, callClobberedRegs platform) + BCTRL params -> usage (params, callClobberedRegs platform) + + ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + ADDI reg1 reg2 _ -> usage ([reg2], [reg1]) + ADDIS reg1 reg2 _ -> usage ([reg2], [reg1]) + SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + MULLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + DIVW reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + DIVWU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) + + MULLW_MayOflo reg1 reg2 reg3 + -> usage ([reg2,reg3], [reg1]) + AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) + EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) + NEG reg1 reg2 -> usage ([reg2], [reg1]) + NOT reg1 reg2 -> usage ([reg2], [reg1]) + SLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SRW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + SRAW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) + RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) + + FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1]) + FNEG r1 r2 -> usage ([r2], [r1]) + FCMP r1 r2 -> usage ([r1,r2], []) + FCTIWZ r1 r2 -> usage ([r2], [r1]) + FRSP r1 r2 -> usage ([r2], [r1]) + MFCR reg -> usage ([], [reg]) + MFLR reg -> usage ([], [reg]) + FETCHPC reg -> usage ([], [reg]) + UPDATE_SP _ _ -> usage ([], [sp]) + _ -> noUsage + where + usage (src, dst) = RU (filter (interesting platform) src) + (filter (interesting platform) dst) + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) + = isFastTrue (freeReg platform i) + +interesting _ (RegReal (RealRegPair{})) + = panic "PPC.Instr.interesting: no reg pairs on this arch" + + + +-- | Apply a given mapping to all the register references in this +-- instruction. +ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +ppc_patchRegsOfInstr instr env + = case instr of + LD sz reg addr -> LD sz (env reg) (fixAddr addr) + LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr) + LA sz reg addr -> LA sz (env reg) (fixAddr addr) + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr) + STU sz reg addr -> STU sz (env reg) (fixAddr addr) + LIS reg imm -> LIS (env reg) imm + LI reg imm -> LI (env reg) imm + MR reg1 reg2 -> MR (env reg1) (env reg2) + CMP sz reg ri -> CMP sz (env reg) (fixRI ri) + CMPL sz reg ri -> CMPL sz (env reg) (fixRI ri) + BCC cond lbl -> BCC cond lbl + BCCFAR cond lbl -> BCCFAR cond lbl + MTCTR reg -> MTCTR (env reg) + BCTR targets lbl -> BCTR targets lbl + BL imm argRegs -> BL imm argRegs -- argument regs + BCTRL argRegs -> BCTRL argRegs -- cannot be remapped + ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) + ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3) + ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3) + ADDI reg1 reg2 imm -> ADDI (env reg1) (env reg2) imm + ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm + SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) + SUBFC reg1 reg2 reg3 -> SUBFC (env reg1) (env reg2) (env reg3) + SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) + MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri) + DIVW reg1 reg2 reg3 -> DIVW (env reg1) (env reg2) (env reg3) + DIVWU reg1 reg2 reg3 -> DIVWU (env reg1) (env reg2) (env reg3) + MULLW_MayOflo reg1 reg2 reg3 + -> MULLW_MayOflo (env reg1) (env reg2) (env reg3) + AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) + OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) + XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) + XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm + EXTS sz reg1 reg2 -> EXTS sz (env reg1) (env reg2) + NEG reg1 reg2 -> NEG (env reg1) (env reg2) + NOT reg1 reg2 -> NOT (env reg1) (env reg2) + SLW reg1 reg2 ri -> SLW (env reg1) (env reg2) (fixRI ri) + SRW reg1 reg2 ri -> SRW (env reg1) (env reg2) (fixRI ri) + SRAW reg1 reg2 ri -> SRAW (env reg1) (env reg2) (fixRI ri) + RLWINM reg1 reg2 sh mb me + -> RLWINM (env reg1) (env reg2) sh mb me + FADD sz r1 r2 r3 -> FADD sz (env r1) (env r2) (env r3) + FSUB sz r1 r2 r3 -> FSUB sz (env r1) (env r2) (env r3) + FMUL sz r1 r2 r3 -> FMUL sz (env r1) (env r2) (env r3) + FDIV sz r1 r2 r3 -> FDIV sz (env r1) (env r2) (env r3) + FNEG r1 r2 -> FNEG (env r1) (env r2) + FCMP r1 r2 -> FCMP (env r1) (env r2) + FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) + FRSP r1 r2 -> FRSP (env r1) (env r2) + MFCR reg -> MFCR (env reg) + MFLR reg -> MFLR (env reg) + FETCHPC reg -> FETCHPC (env reg) + _ -> instr + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + + +-------------------------------------------------------------------------------- +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +ppc_isJumpishInstr :: Instr -> Bool +ppc_isJumpishInstr instr + = case instr of + BCC{} -> True + BCCFAR{} -> True + BCTR{} -> True + BCTRL{} -> True + BL{} -> True + JMP{} -> True + _ -> False + + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +ppc_jumpDestsOfInstr :: Instr -> [BlockId] +ppc_jumpDestsOfInstr insn + = case insn of + BCC _ id -> [id] + BCCFAR _ id -> [id] + BCTR targets _ -> [id | Just id <- targets] + _ -> [] + + +-- | Change the destination of this jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +ppc_patchJumpInstr insn patchF + = case insn of + BCC cc id -> BCC cc (patchF id) + BCCFAR cc id -> BCCFAR cc (patchF id) + BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl + _ -> insn + + +-- ----------------------------------------------------------------------------- + +-- | An instruction to spill a register into a spill slot. +ppc_mkSpillInstr + :: DynFlags + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +ppc_mkSpillInstr dflags reg delta slot + = let platform = targetPlatform dflags + off = spillSlotToOffset slot + in + let sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcDouble -> FF64 + _ -> panic "PPC.Instr.mkSpillInstr: no match" + instr = case makeImmediate W32 True (off-delta) of + Just _ -> ST + Nothing -> STFAR -- pseudo instruction: 32 bit offsets + in instr sz reg (AddrRegImm sp (ImmInt (off-delta))) + +ppc_mkLoadInstr + :: DynFlags + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +ppc_mkLoadInstr dflags reg delta slot + = let platform = targetPlatform dflags + off = spillSlotToOffset slot + in + let sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcDouble -> FF64 + _ -> panic "PPC.Instr.mkLoadInstr: no match" + instr = case makeImmediate W32 True (off-delta) of + Just _ -> LD + Nothing -> LDFAR -- pseudo instruction: 32 bit offsets + in instr sz reg (AddrRegImm sp (ImmInt (off-delta))) + + +-- | The maximum number of bytes required to spill a register. PPC32 +-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and +-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike +-- x86. Note that AltiVec's vector registers are 128-bit wide so we +-- must not use this to spill them. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize) - 1 +-- = 0 -- useful for testing allocMoreStack + +-- | The number of bytes that the stack pointer should be aligned +-- to. This is 16 both on PPC32 and PPC64 at least for Darwin, but I'm +-- not sure this is correct for other OSes. +stackAlign :: Int +stackAlign = 16 + +-- | Convert a spill slot number to a *byte* offset, with no sign. +spillSlotToOffset :: Int -> Int +spillSlotToOffset slot + = 64 + spillSlotSize * slot + + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +ppc_takeDeltaInstr + :: Instr + -> Maybe Int + +ppc_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +ppc_isMetaInstr + :: Instr + -> Bool + +ppc_isMetaInstr instr + = case instr of + COMMENT{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +ppc_mkRegRegMoveInstr + :: Reg + -> Reg + -> Instr + +ppc_mkRegRegMoveInstr src dst + = MR dst src + + +-- | Make an unconditional jump instruction. +-- For architectures with branch delay slots, its ok to put +-- a NOP after the jump. Don't fill the delay slot with an +-- instruction that references regs or you'll confuse the +-- linear allocator. +ppc_mkJumpInstr + :: BlockId + -> [Instr] + +ppc_mkJumpInstr id + = [BCC ALWAYS id] + + +-- | Take the source and destination from this reg -> reg move instruction +-- or Nothing if it's not one +ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst) +ppc_takeRegRegMoveInstr _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Making far branches + +-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too +-- big, we have to work around this limitation. + +makeFarBranches + :: BlockEnv CmmStatics + -> [NatBasicBlock Instr] + -> [NatBasicBlock Instr] +makeFarBranches info_env blocks + | last blockAddresses < nearLimit = blocks + | otherwise = zipWith handleBlock blockAddresses blocks + where + blockAddresses = scanl (+) 0 $ map blockLen blocks + blockLen (BasicBlock _ instrs) = length instrs + + handleBlock addr (BasicBlock id instrs) + = BasicBlock id (zipWith makeFar [addr..] instrs) + + makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt + makeFar addr (BCC cond tgt) + | abs (addr - targetAddr) >= nearLimit + = BCCFAR cond tgt + | otherwise + = BCC cond tgt + where Just targetAddr = lookupUFM blockAddressMap tgt + makeFar _ other = other + + -- 8192 instructions are allowed; let's keep some distance, as + -- we have a few pseudo-insns that are pretty-printed as + -- multiple instructions, and it's just not worth the effort + -- to calculate things exactly + nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW + + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs new file mode 100644 index 00000000..876b11b0 --- /dev/null +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -0,0 +1,785 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PPC.Ppr ( + pprNatCmmDecl, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem, +) + +where + +import PPC.Regs +import PPC.Instr +import PPC.Cond +import PprBase +import Instruction +import Size +import Reg +import RegClass +import TargetReg + +import Cmm hiding (topInfoTable) +import BlockId + +import CLabel + +import Unique ( pprUnique, Uniquable(..) ) +import Platform +import FastString +import Outputable + +import Data.Word +import Data.Bits + + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc +pprNatCmmDecl (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats + +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + case topInfoTable proc of + Nothing -> + case blocks of + [] -> -- special case for split markers: + pprLabel lbl + blocks -> -- special case for code without info table: + pprSectionHeader Text $$ + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock top_info) blocks) + + Just (Statics info_lbl _) -> + sdocWithPlatform $ \platform -> + (if platformHasSubsectionsViaSymbols platform + then pprSectionHeader Text $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) + + +pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map pprInstr instrs) + where + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (Statics info_lbl info) -> + pprSectionHeader Text $$ + vcat (map pprData info) $$ + pprLabel info_lbl + + + +pprDatas :: CmmStatics -> SDoc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + +pprData :: CmmStatic -> SDoc +pprData (CmmString str) = pprASCII str +pprData (CmmUninitialised bytes) = keyword <> int bytes + where keyword = sdocWithPlatform $ \platform -> + case platformOS platform of + OSDarwin -> ptext (sLit ".space ") + _ -> ptext (sLit ".skip ") +pprData (CmmStaticLit lit) = pprDataItem lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext (sLit ".globl ") <> ppr lbl + +pprTypeAndSizeDecl :: CLabel -> SDoc +pprTypeAndSizeDecl lbl + = sdocWithPlatform $ \platform -> + if platformOS platform == OSLinux && externallyVisibleCLabel lbl + then ptext (sLit ".type ") <> + ppr lbl <> ptext (sLit ", @object") + else empty + +pprLabel :: CLabel -> SDoc +pprLabel lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl lbl + $$ (ppr lbl <> char ':') + + +pprASCII :: [Word8] -> SDoc +pprASCII str + = vcat (map do1 str) $$ do1 0 + where + do1 :: Word8 -> SDoc + do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = pprInstr instr + + +pprReg :: Reg -> SDoc + +pprReg r + = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u + RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u + where + ppr_reg_no :: Int -> SDoc + ppr_reg_no i = + sdocWithPlatform $ \platform -> + case platformOS platform of + OSDarwin -> + ptext + (case i of { + 0 -> sLit "r0"; 1 -> sLit "r1"; + 2 -> sLit "r2"; 3 -> sLit "r3"; + 4 -> sLit "r4"; 5 -> sLit "r5"; + 6 -> sLit "r6"; 7 -> sLit "r7"; + 8 -> sLit "r8"; 9 -> sLit "r9"; + 10 -> sLit "r10"; 11 -> sLit "r11"; + 12 -> sLit "r12"; 13 -> sLit "r13"; + 14 -> sLit "r14"; 15 -> sLit "r15"; + 16 -> sLit "r16"; 17 -> sLit "r17"; + 18 -> sLit "r18"; 19 -> sLit "r19"; + 20 -> sLit "r20"; 21 -> sLit "r21"; + 22 -> sLit "r22"; 23 -> sLit "r23"; + 24 -> sLit "r24"; 25 -> sLit "r25"; + 26 -> sLit "r26"; 27 -> sLit "r27"; + 28 -> sLit "r28"; 29 -> sLit "r29"; + 30 -> sLit "r30"; 31 -> sLit "r31"; + 32 -> sLit "f0"; 33 -> sLit "f1"; + 34 -> sLit "f2"; 35 -> sLit "f3"; + 36 -> sLit "f4"; 37 -> sLit "f5"; + 38 -> sLit "f6"; 39 -> sLit "f7"; + 40 -> sLit "f8"; 41 -> sLit "f9"; + 42 -> sLit "f10"; 43 -> sLit "f11"; + 44 -> sLit "f12"; 45 -> sLit "f13"; + 46 -> sLit "f14"; 47 -> sLit "f15"; + 48 -> sLit "f16"; 49 -> sLit "f17"; + 50 -> sLit "f18"; 51 -> sLit "f19"; + 52 -> sLit "f20"; 53 -> sLit "f21"; + 54 -> sLit "f22"; 55 -> sLit "f23"; + 56 -> sLit "f24"; 57 -> sLit "f25"; + 58 -> sLit "f26"; 59 -> sLit "f27"; + 60 -> sLit "f28"; 61 -> sLit "f29"; + 62 -> sLit "f30"; 63 -> sLit "f31"; + _ -> sLit "very naughty powerpc register" + }) + _ + | i <= 31 -> int i -- GPRs + | i <= 63 -> int (i-32) -- FPRs + | otherwise -> ptext (sLit "very naughty powerpc register") + + + +pprSize :: Size -> SDoc +pprSize x + = ptext (case x of + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "w" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprSize: no match") + + +pprCond :: Cond -> SDoc +pprCond c + = ptext (case c of { + ALWAYS -> sLit ""; + EQQ -> sLit "eq"; NE -> sLit "ne"; + LTT -> sLit "lt"; GE -> sLit "ge"; + GTT -> sLit "gt"; LE -> sLit "le"; + LU -> sLit "lt"; GEU -> sLit "ge"; + GU -> sLit "gt"; LEU -> sLit "le"; }) + + +pprImm :: Imm -> SDoc + +pprImm (ImmInt i) = int i +pprImm (ImmInteger i) = integer i +pprImm (ImmCLbl l) = ppr l +pprImm (ImmIndex l i) = ppr l <> char '+' <> int i +pprImm (ImmLit s) = s + +pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") + +pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b +pprImm (ImmConstantDiff a b) = pprImm a <> char '-' + <> lparen <> pprImm b <> rparen + +pprImm (LO i) + = sdocWithPlatform $ \platform -> + if platformOS platform == OSDarwin + then hcat [ text "lo16(", pprImm i, rparen ] + else pprImm i <> text "@l" + +pprImm (HI i) + = sdocWithPlatform $ \platform -> + if platformOS platform == OSDarwin + then hcat [ text "hi16(", pprImm i, rparen ] + else pprImm i <> text "@h" + +pprImm (HA i) + = sdocWithPlatform $ \platform -> + if platformOS platform == OSDarwin + then hcat [ text "ha16(", pprImm i, rparen ] + else pprImm i <> text "@ha" + + +pprAddr :: AddrMode -> SDoc +pprAddr (AddrRegReg r1 r2) + = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2 + +pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] + + +pprSectionHeader :: Section -> SDoc +pprSectionHeader seg = + sdocWithPlatform $ \platform -> + let osDarwin = platformOS platform == OSDarwin in + case seg of + Text -> text ".text\n\t.align 2" + Data -> text ".data\n\t.align 2" + ReadOnlyData + | osDarwin -> text ".const\n\t.align 2" + | otherwise -> text ".section .rodata\n\t.align 2" + RelocatableReadOnlyData + | osDarwin -> text ".const_data\n\t.align 2" + | otherwise -> text ".data\n\t.align 2" + UninitialisedData + | osDarwin -> text ".const_data\n\t.align 2" + | otherwise -> text ".section .bss\n\t.align 2" + ReadOnlyData16 + | osDarwin -> text ".const\n\t.align 4" + | otherwise -> text ".section .rodata\n\t.align 4" + OtherSection _ -> + panic "PprMach.pprSectionHeader: unknown section" + + +pprDataItem :: CmmLit -> SDoc +pprDataItem lit + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) + where + imm = litToImm lit + + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] + + ppr_item II64 (CmmInt x _) = + [ptext (sLit "\t.long\t") + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32)), + ptext (sLit "\t.long\t") + <> int (fromIntegral (fromIntegral x :: Word32))] + + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" + + +pprInstr :: Instr -> SDoc + +pprInstr (COMMENT _) = empty -- nuke 'em +{- +pprInstr (COMMENT s) = + if platformOS platform == OSLinux + then ptext (sLit "# ") <> ftext s + else ptext (sLit "; ") <> ftext s +-} +pprInstr (DELTA d) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) + +pprInstr (NEWBLOCK _) + = panic "PprMach.pprInstr: NEWBLOCK" + +pprInstr (LDATA _ _) + = panic "PprMach.pprInstr: LDATA" + +{- +pprInstr (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char '\t', + pprReg reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char '\t', + ptext (sLit "SLOT") <> parens (int slot), + comma, + pprReg reg] +-} + +pprInstr (LD sz reg addr) = hcat [ + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + ptext (sLit ", "), + pprAddr addr + ] + +pprInstr (LDFAR fmt reg (AddrRegImm source off)) = + sdocWithPlatform $ \platform -> vcat [ + pprInstr (ADDIS (tmpReg platform) source (HA off)), + pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + +pprInstr (LDFAR _ _ _) = + panic "PPC.Ppr.pprInstr LDFAR: no match" + +pprInstr (LA sz reg addr) = hcat [ + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + ptext (sLit ", "), + pprAddr addr + ] +pprInstr (ST sz reg addr) = hcat [ + char '\t', + ptext (sLit "st"), + pprSize sz, + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + ptext (sLit ", "), + pprAddr addr + ] +pprInstr (STFAR fmt reg (AddrRegImm source off)) = + sdocWithPlatform $ \platform -> vcat [ + pprInstr (ADDIS (tmpReg platform) source (HA off)), + pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] +pprInstr (STFAR _ _ _) = + panic "PPC.Ppr.pprInstr STFAR: no match" +pprInstr (STU sz reg addr) = hcat [ + char '\t', + ptext (sLit "st"), + pprSize sz, + ptext (sLit "u\t"), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + pprReg reg, + ptext (sLit ", "), + pprAddr addr + ] +pprInstr (LIS reg imm) = hcat [ + char '\t', + ptext (sLit "lis"), + char '\t', + pprReg reg, + ptext (sLit ", "), + pprImm imm + ] +pprInstr (LI reg imm) = hcat [ + char '\t', + ptext (sLit "li"), + char '\t', + pprReg reg, + ptext (sLit ", "), + pprImm imm + ] +pprInstr (MR reg1 reg2) + | reg1 == reg2 = empty + | otherwise = hcat [ + char '\t', + sdocWithPlatform $ \platform -> + case targetClassOfReg platform reg1 of + RcInteger -> ptext (sLit "mr") + _ -> ptext (sLit "fmr"), + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2 + ] +pprInstr (CMP sz reg ri) = hcat [ + char '\t', + op, + char '\t', + pprReg reg, + ptext (sLit ", "), + pprRI ri + ] + where + op = hcat [ + ptext (sLit "cmp"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] +pprInstr (CMPL sz reg ri) = hcat [ + char '\t', + op, + char '\t', + pprReg reg, + ptext (sLit ", "), + pprRI ri + ] + where + op = hcat [ + ptext (sLit "cmpl"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] +pprInstr (BCC cond blockid) = hcat [ + char '\t', + ptext (sLit "b"), + pprCond cond, + char '\t', + ppr lbl + ] + where lbl = mkAsmTempLabel (getUnique blockid) + +pprInstr (BCCFAR cond blockid) = vcat [ + hcat [ + ptext (sLit "\tb"), + pprCond (condNegate cond), + ptext (sLit "\t$+8") + ], + hcat [ + ptext (sLit "\tb\t"), + ppr lbl + ] + ] + where lbl = mkAsmTempLabel (getUnique blockid) + +pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel + char '\t', + ptext (sLit "b"), + char '\t', + ppr lbl + ] + +pprInstr (MTCTR reg) = hcat [ + char '\t', + ptext (sLit "mtctr"), + char '\t', + pprReg reg + ] +pprInstr (BCTR _ _) = hcat [ + char '\t', + ptext (sLit "bctr") + ] +pprInstr (BL lbl _) = hcat [ + ptext (sLit "\tbl\t"), + ppr lbl + ] +pprInstr (BCTRL _) = hcat [ + char '\t', + ptext (sLit "bctrl") + ] +pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri +pprInstr (ADDI reg1 reg2 imm) = hcat [ + char '\t', + ptext (sLit "addi"), + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprImm imm + ] +pprInstr (ADDIS reg1 reg2 imm) = hcat [ + char '\t', + ptext (sLit "addis"), + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprImm imm + ] + +pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) +pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) +pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr (SUBFC reg1 reg2 reg3) = pprLogic (sLit "subfc") reg1 reg2 (RIReg reg3) +pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) +pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri +pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri +pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) + +pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ + hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), + pprReg reg2, ptext (sLit ", "), + pprReg reg3 ], + hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ], + hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), + pprReg reg1, ptext (sLit ", "), + ptext (sLit "2, 31, 31") ] + ] + + -- for some reason, "andi" doesn't exist. + -- we'll use "andi." instead. +pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ + char '\t', + ptext (sLit "andi."), + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprImm imm + ] +pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri + +pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri +pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri + +pprInstr (XORIS reg1 reg2 imm) = hcat [ + char '\t', + ptext (sLit "xoris"), + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprImm imm + ] + +pprInstr (EXTS sz reg1 reg2) = hcat [ + char '\t', + ptext (sLit "exts"), + pprSize sz, + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2 + ] + +pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 +pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 + + +pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = + -- Handle the case where we are asked to shift a 32 bit register by + -- less than zero or more than 31 bits. We convert this into a clear + -- of the destination register. + -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900 + pprInstr (XOR reg1 reg2 (RIReg reg2)) + +pprInstr (SLW reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = + -- As aboce for SR, but for left shifts. + -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870 + pprInstr (XOR reg1 reg2 (RIReg reg2)) + +pprInstr (SRAW reg1 reg2 (RIImm (ImmInt i))) | i > 31 = + pprInstr (SRAW reg1 reg2 (RIImm (ImmInt 31))) + +pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) + +pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) + +pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) +pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ + ptext (sLit "\trlwinm\t"), + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + int sh, + ptext (sLit ", "), + int mb, + ptext (sLit ", "), + int me + ] + +pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 +pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 +pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 +pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 +pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 + +pprInstr (FCMP reg1 reg2) = hcat [ + char '\t', + ptext (sLit "fcmpu\tcr0, "), + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care + pprReg reg1, + ptext (sLit ", "), + pprReg reg2 + ] + +pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 +pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 + +pprInstr (CRNOR dst src1 src2) = hcat [ + ptext (sLit "\tcrnor\t"), + int dst, + ptext (sLit ", "), + int src1, + ptext (sLit ", "), + int src2 + ] + +pprInstr (MFCR reg) = hcat [ + char '\t', + ptext (sLit "mfcr"), + char '\t', + pprReg reg + ] + +pprInstr (MFLR reg) = hcat [ + char '\t', + ptext (sLit "mflr"), + char '\t', + pprReg reg + ] + +pprInstr (FETCHPC reg) = vcat [ + ptext (sLit "\tbcl\t20,31,1f"), + hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] + ] + +pprInstr LWSYNC = ptext (sLit "\tlwsync") + +pprInstr (UPDATE_SP fmt amount@(ImmInt offset)) + | fits16Bits offset = vcat [ + pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))), + pprInstr (STU fmt r0 (AddrRegImm sp amount)) + ] + +pprInstr (UPDATE_SP fmt amount) + = sdocWithPlatform $ \platform -> + let tmp = tmpReg platform in + vcat [ + pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))), + pprInstr (ADDIS tmp sp (HA amount)), + pprInstr (ADD tmp tmp (RIImm (LO amount))), + pprInstr (STU fmt r0 (AddrRegReg sp tmp)) + ] + +-- pprInstr _ = panic "pprInstr (ppc)" + + +pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc +pprLogic op reg1 reg2 ri = hcat [ + char '\t', + ptext op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprRI ri + ] + + +pprUnary :: LitString -> Reg -> Reg -> SDoc +pprUnary op reg1 reg2 = hcat [ + char '\t', + ptext op, + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2 + ] + + +pprBinaryF :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc +pprBinaryF op sz reg1 reg2 reg3 = hcat [ + char '\t', + ptext op, + pprFSize sz, + char '\t', + pprReg reg1, + ptext (sLit ", "), + pprReg reg2, + ptext (sLit ", "), + pprReg reg3 + ] + +pprRI :: RI -> SDoc +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + + +pprFSize :: Size -> SDoc +pprFSize FF64 = empty +pprFSize FF32 = char 's' +pprFSize _ = panic "PPC.Ppr.pprFSize: no match" + + -- limit immediate argument for shift instruction to range 0..31 +limitShiftRI :: RI -> RI +limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 = + panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." +limitShiftRI x = x + diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs new file mode 100644 index 00000000..c4724d41 --- /dev/null +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Machine-specific parts of the register allocator +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- +module PPC.RegInfo ( + JumpDest( DestBlockId ), getJumpDestBlockId, + canShortcut, + shortcutJump, + + shortcutStatics +) + +where + +#include "nativeGen/NCG.h" +#include "HsVersions.h" + +import PPC.Instr + +import BlockId +import Cmm +import CLabel + +import Unique + +data JumpDest = DestBlockId BlockId + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other + + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel + +shortBlockId fn blockid = + case fn blockid of + Nothing -> mkAsmTempLabel uq + Just (DestBlockId blockid') -> shortBlockId fn blockid' + where uq = getUnique blockid diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs new file mode 100644 index 00000000..a66ea36c --- /dev/null +++ b/compiler/nativeGen/PPC/Regs.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE CPP #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1994-2004 +-- +-- ----------------------------------------------------------------------------- + +module PPC.Regs ( + -- squeeze functions + virtualRegSqueeze, + realRegSqueeze, + + mkVirtualReg, + regDotColor, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + callClobberedRegs, + allMachRegNos, + classOfRealReg, + showReg, + + -- machine specific + allFPArgRegs, + fits16Bits, + makeImmediate, + fReg, + r0, sp, r3, r4, r27, r28, r30, + tmpReg, + f1, f20, f21, + + allocatableRegs + +) + +where + +#include "nativeGen/NCG.h" +#include "HsVersions.h" + +import Reg +import RegClass +import Size + +import Cmm +import CLabel ( CLabel ) +import Unique + +import CodeGen.Platform +import DynFlags +import Outputable +import FastBool +import FastTypes +import Platform + +import Data.Word ( Word8, Word16, Word32 ) +import Data.Int ( Int8, Int16, Int32 ) + + +-- squeese functions for the graph allocator ----------------------------------- + +-- | regSqueeze_class reg +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) + _other -> _ILIT(0) + + RcDouble + -> case vr of + VirtualRegD{} -> _ILIT(1) + VirtualRegF{} -> _ILIT(0) + _other -> _ILIT(0) + + _other -> _ILIT(0) + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> FastInt +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) -- first fp reg is 32 + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(0) + + _other -> _ILIT(0) + +mkVirtualReg :: Unique -> Size -> VirtualReg +mkVirtualReg u size + | not (isFloatSize size) = VirtualRegI u + | otherwise + = case size of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "mkVirtualReg" + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcDouble -> text "green" + RcDoubleSSE -> text "yellow" + + +-- immediates ------------------------------------------------------------------ +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + | LO Imm + | HI Imm + | HA Imm {- high halfword adjusted -} + + +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "PPC.Regs.litToImm: no match" + + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + AddrRegImm r (ImmInt n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + _ -> Nothing + + +-- registers ------------------------------------------------------------------- +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + +spRel :: DynFlags + -> Int -- desired stack offset in words, positive or negative + -> AddrMode + +spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) + + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs 0 = [] +argRegs 1 = map regSingle [3] +argRegs 2 = map regSingle [3,4] +argRegs 3 = map regSingle [3..5] +argRegs 4 = map regSingle [3..6] +argRegs 5 = map regSingle [3..7] +argRegs 6 = map regSingle [3..8] +argRegs 7 = map regSingle [3..9] +argRegs 8 = map regSingle [3..10] +argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" + + +allArgRegs :: [Reg] +allArgRegs = map regSingle [3..10] + + +-- these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +callClobberedRegs platform + = case platformOS platform of + OSDarwin -> map regSingle (0:[2..12] ++ map fReg [0..13]) + OSLinux -> map regSingle (0:[2..13] ++ map fReg [0..13]) + _ -> panic "PPC.Regs.callClobberedRegs: not defined for this architecture" + + +allMachRegNos :: [RegNo] +allMachRegNos = [0..63] + + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | otherwise = RcDouble + +classOfRealReg (RealRegPair{}) + = panic "regClass(ppr): no reg pairs on this architecture" + +showReg :: RegNo -> String +showReg n + | n >= 0 && n <= 31 = "%r" ++ show n + | n >= 32 && n <= 63 = "%f" ++ show (n - 32) + | otherwise = "%unknown_powerpc_real_reg_" ++ show n + + + +-- machine specific ------------------------------------------------------------ + +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + = case platformOS platform of + OSDarwin -> map (regSingle . fReg) [1..13] + OSLinux -> map (regSingle . fReg) [1..8] + _ -> panic "PPC.Regs.allFPArgRegs: not defined for this architecture" + +fits16Bits :: Integral a => a -> Bool +fits16Bits x = x >= -32768 && x < 32768 + +makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm +makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) + where + narrow W32 False = fromIntegral (fromIntegral x :: Word32) + narrow W16 False = fromIntegral (fromIntegral x :: Word16) + narrow W8 False = fromIntegral (fromIntegral x :: Word8) + narrow W32 True = fromIntegral (fromIntegral x :: Int32) + narrow W16 True = fromIntegral (fromIntegral x :: Int16) + narrow W8 True = fromIntegral (fromIntegral x :: Int8) + narrow _ _ = panic "PPC.Regs.narrow: no match" + + narrowed = narrow rep signed + + toI16 W32 True + | narrowed >= -32768 && narrowed < 32768 = Just narrowed + | otherwise = Nothing + toI16 W32 False + | narrowed >= 0 && narrowed < 65536 = Just narrowed + | otherwise = Nothing + toI16 _ _ = Just narrowed + + +{- +The PowerPC has 64 registers of interest; 32 integer registers and 32 floating +point registers. +-} + +fReg :: Int -> RegNo +fReg x = (32 + x) + +r0, sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg +r0 = regSingle 0 +sp = regSingle 1 +r3 = regSingle 3 +r4 = regSingle 4 +r27 = regSingle 27 +r28 = regSingle 28 +r30 = regSingle 30 +f1 = regSingle $ fReg 1 +f20 = regSingle $ fReg 20 +f21 = regSingle $ fReg 21 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = isFastTrue (freeReg platform i) + in map RealRegSingle $ filter isFree allMachRegNos + +-- temporary register for compiler use +tmpReg :: Platform -> Reg +tmpReg platform = + case platformArch platform of + ArchPPC -> regSingle 13 + _ -> panic "PPC.Regs.tmpReg: unknowm arch" diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs new file mode 100644 index 00000000..90a3b303 --- /dev/null +++ b/compiler/nativeGen/PprBase.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +module PprBase ( + castFloatToWord8Array, + castDoubleToWord8Array, + floatToBytes, + doubleToBytes +) + +where + +import qualified Data.Array.Unsafe as U ( castSTUArray ) +import Data.Array.ST + +import Control.Monad.ST + +import Data.Word + + + +-- ----------------------------------------------------------------------------- +-- Converting floating-point literals to integrals for printing + +castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) +castFloatToWord8Array = U.castSTUArray + +castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) +castDoubleToWord8Array = U.castSTUArray + +-- floatToBytes and doubleToBytes convert to the host's byte +-- order. Providing that we're not cross-compiling for a +-- target with the opposite endianness, this should work ok +-- on all targets. + +-- ToDo: this stuff is very similar to the shenanigans in PprAbs, +-- could they be merged? + +floatToBytes :: Float -> [Int] +floatToBytes f + = runST (do + arr <- newArray_ ((0::Int),3) + writeArray arr 0 f + arr <- castFloatToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + return (map fromIntegral [i0,i1,i2,i3]) + ) + +doubleToBytes :: Double -> [Int] +doubleToBytes d + = runST (do + arr <- newArray_ ((0::Int),7) + writeArray arr 0 d + arr <- castDoubleToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + i4 <- readArray arr 4 + i5 <- readArray arr 5 + i6 <- readArray arr 6 + i7 <- readArray arr 7 + return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7]) + ) diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs new file mode 100644 index 00000000..862306f0 --- /dev/null +++ b/compiler/nativeGen/Reg.hs @@ -0,0 +1,217 @@ +-- | An architecture independent description of a register. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. +-- +module Reg ( + RegNo, + Reg(..), + regPair, + regSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg +) + +where + +import Outputable +import Unique +import RegClass +import Data.List + +-- | An identifier for a primitive real machine register. +type RegNo + = Int + +-- VirtualRegs are virtual registers. The register allocator will +-- eventually have to map them into RealRegs, or into spill slots. +-- +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). +-- +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. +-- +-- Virtual regs can be of either class, so that info is attached. +-- +data VirtualReg + = VirtualRegI {-# UNPACK #-} !Unique + | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register + | VirtualRegF {-# UNPACK #-} !Unique + | VirtualRegD {-# UNPACK #-} !Unique + | VirtualRegSSE {-# UNPACK #-} !Unique + deriving (Eq, Show, Ord) + +instance Uniquable VirtualReg where + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u + VirtualRegSSE u -> u + +instance Outputable VirtualReg where + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u + + +renameVirtualReg :: Unique -> VirtualReg -> VirtualReg +renameVirtualReg u r + = case r of + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + VirtualRegSSE _ -> VirtualRegSSE u + + +classOfVirtualReg :: VirtualReg -> RegClass +classOfVirtualReg vr + = case vr of + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + VirtualRegSSE{} -> RcDoubleSSE + + +-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform +-- when supplied with the vreg for the lower-half of the quantity. +-- (NB. Not reversible). +getHiVirtualRegFromLo :: VirtualReg -> VirtualReg +getHiVirtualRegFromLo reg + = case reg of + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" + +getHiVRegFromLo :: Reg -> Reg +getHiVRegFromLo reg + = case reg of + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + + +------------------------------------------------------------------------------------ +-- | RealRegs are machine regs which are available for allocation, in +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. +-- +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. +-- +data RealReg + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) + +instance Uniquable RealReg where + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) + +instance Outputable RealReg where + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" + +regNosOfRealReg :: RealReg -> [RegNo] +regNosOfRealReg rr + = case rr of + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + + +realRegsAlias :: RealReg -> RealReg -> Bool +realRegsAlias rr1 rr2 + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + +-------------------------------------------------------------------------------- +-- | A register, either virtual or real +data Reg + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord) + +regSingle :: RegNo -> Reg +regSingle regNo = RegReal $ RealRegSingle regNo + +regPair :: RegNo -> RegNo -> Reg +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 + + +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- in the register allocator. +instance Uniquable Reg where + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + +-- | Print a reg in a generic manner +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. +instance Outputable Reg where + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr + + +isRealReg :: Reg -> Bool +isRealReg reg + = case reg of + RegReal _ -> True + RegVirtual _ -> False + +takeRealReg :: Reg -> Maybe RealReg +takeRealReg reg + = case reg of + RegReal rr -> Just rr + _ -> Nothing + + +isVirtualReg :: Reg -> Bool +isVirtualReg reg + = case reg of + RegReal _ -> False + RegVirtual _ -> True + +takeVirtualReg :: Reg -> Maybe VirtualReg +takeVirtualReg reg + = case reg of + RegReal _ -> Nothing + RegVirtual vr -> Just vr + + +-- | The patch function supplied by the allocator maps VirtualReg to RealReg +-- regs, but sometimes we want to apply it to plain old Reg. +-- +liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) +liftPatchFnToRegReg patchF reg + = case reg of + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs new file mode 100644 index 00000000..deb3ac1b --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs @@ -0,0 +1,154 @@ + +-- | Utils for calculating general worst, bound, squeese and free, functions. +-- +-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" +-- Michael Smith, Normal Ramsey, Glenn Holloway. +-- PLDI 2004 +-- +-- These general versions are not used in GHC proper because they are too slow. +-- Instead, hand written optimised versions are provided for each architecture +-- in MachRegs*.hs +-- +-- This code is here because we can test the architecture specific code against +-- it. +-- +module RegAlloc.Graph.ArchBase ( + RegClass(..), + Reg(..), + RegSub(..), + + worst, + bound, + squeese +) where +import UniqSet +import Unique + + +-- Some basic register classes. +-- These aren't nessesarally in 1-to-1 correspondance with the allocatable +-- RegClasses in MachRegs.hs +data RegClass + -- general purpose regs + = ClassG32 -- 32 bit GPRs + | ClassG16 -- 16 bit GPRs + | ClassG8 -- 8 bit GPRs + + -- floating point regs + | ClassF64 -- 64 bit FPRs + deriving (Show, Eq, Enum) + + +-- | A register of some class +data Reg + -- a register of some class + = Reg RegClass Int + + -- a sub-component of one of the other regs + | RegSub RegSub Reg + deriving (Show, Eq) + + +-- | so we can put regs in UniqSets +instance Uniquable Reg where + getUnique (Reg c i) + = mkRegSingleUnique + $ fromEnum c * 1000 + i + + getUnique (RegSub s (Reg c i)) + = mkRegSubUnique + $ fromEnum s * 10000 + fromEnum c * 1000 + i + + getUnique (RegSub _ (RegSub _ _)) + = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg." + + +-- | A subcomponent of another register +data RegSub + = SubL16 -- lowest 16 bits + | SubL8 -- lowest 8 bits + | SubL8H -- second lowest 8 bits + deriving (Show, Enum, Ord, Eq) + + +-- | Worst case displacement +-- +-- a node N of classN has some number of neighbors, +-- all of which are from classC. +-- +-- (worst neighbors classN classC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +-- +-- This should be hand coded/cached for each particular architecture, +-- because the compute time is very long.. +worst :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> Int -> RegClass -> RegClass -> Int + +worst regsOfClass regAlias neighbors classN classC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ uniqSetToList regs + + -- all the regs in classes N, C + regsN = regsOfClass classN + regsC = regsOfClass classC + + -- all the possible subsets of c which have size < m + regsS = filter (\s -> sizeUniqSet s >= 1 + && sizeUniqSet s <= neighbors) + $ powersetLS regsC + + -- for each of the subsets of C, the regs which conflict + -- with posiblities for N + regsS_conflict + = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS + + in maximum $ map sizeUniqSet $ regsS_conflict + + +-- | For a node N of classN and neighbors of classesC +-- (bound classN classesC) is the maximum number of potential +-- colors for N that can be lost by coloring its neighbors. +bound :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [RegClass] -> Int + +bound regsOfClass regAlias classN classesC + = let regAliasS regs = unionManyUniqSets + $ map regAlias + $ uniqSetToList regs + + regsC_aliases + = unionManyUniqSets + $ map (regAliasS . regsOfClass) classesC + + overlap = intersectUniqSets (regsOfClass classN) regsC_aliases + + in sizeUniqSet overlap + + +-- | The total squeese on a particular node with a list of neighbors. +-- +-- A version of this should be constructed for each particular architecture, +-- possibly including uses of bound, so that alised registers don't get +-- counted twice, as per the paper. +squeese :: (RegClass -> UniqSet Reg) + -> (Reg -> UniqSet Reg) + -> RegClass -> [(Int, RegClass)] -> Int + +squeese regsOfClass regAlias classN countCs + = sum + $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) + $ countCs + + +-- | powerset (for lists) +powersetL :: [a] -> [[a]] +powersetL = map concat . mapM (\x -> [[],[x]]) + + +-- | powersetLS (list of sets) +powersetLS :: Uniquable a => UniqSet a -> [UniqSet a] +powersetLS s = map mkUniqSet $ powersetL $ uniqSetToList s + diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs new file mode 100644 index 00000000..c5122693 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs @@ -0,0 +1,146 @@ + +-- | A description of the register set of the X86. +-- +-- This isn't used directly in GHC proper. +-- +-- See RegArchBase.hs for the reference. +-- See MachRegs.hs for the actual trivColorable function used in GHC. +-- +module RegAlloc.Graph.ArchX86 ( + classOfReg, + regsOfClass, + regName, + regAlias, + worst, + squeese, +) where +import RegAlloc.Graph.ArchBase (Reg(..), RegSub(..), RegClass(..)) +import UniqSet + + +-- | Determine the class of a register +classOfReg :: Reg -> RegClass +classOfReg reg + = case reg of + Reg c _ -> c + + RegSub SubL16 _ -> ClassG16 + RegSub SubL8 _ -> ClassG8 + RegSub SubL8H _ -> ClassG8 + + +-- | Determine all the regs that make up a certain class. +regsOfClass :: RegClass -> UniqSet Reg +regsOfClass c + = case c of + ClassG32 + -> mkUniqSet [ Reg ClassG32 i + | i <- [0..7] ] + + ClassG16 + -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) + | i <- [0..7] ] + + ClassG8 + -> unionUniqSets + (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) + (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) + + ClassF64 + -> mkUniqSet [ Reg ClassF64 i + | i <- [0..5] ] + + +-- | Determine the common name of a reg +-- returns Nothing if this reg is not part of the machine. +regName :: Reg -> Maybe String +regName reg + = case reg of + Reg ClassG32 i + | i <= 7-> Just $ [ "eax", "ebx", "ecx", "edx" + , "ebp", "esi", "edi", "esp" ] !! i + + RegSub SubL16 (Reg ClassG32 i) + | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx" + , "bp", "si", "di", "sp"] !! i + + RegSub SubL8 (Reg ClassG32 i) + | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i + + RegSub SubL8H (Reg ClassG32 i) + | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i + + _ -> Nothing + + +-- | Which regs alias what other regs. +regAlias :: Reg -> UniqSet Reg +regAlias reg + = case reg of + + -- 32 bit regs alias all of the subregs + Reg ClassG32 i + + -- for eax, ebx, ecx, eds + | i <= 3 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg + , RegSub SubL8 reg, RegSub SubL8H reg ] + + -- for esi, edi, esp, ebp + | 4 <= i && i <= 7 + -> mkUniqSet + $ [ Reg ClassG32 i, RegSub SubL16 reg ] + + -- 16 bit subregs alias the whole reg + RegSub SubL16 r@(Reg ClassG32 _) + -> regAlias r + + -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg + RegSub SubL8 r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] + + RegSub SubL8H r@(Reg ClassG32 _) + -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] + + -- fp + Reg ClassF64 _ + -> unitUniqSet reg + + _ -> error "regAlias: invalid register" + + +-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86 +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + ClassG32 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG16 + -> case classC of + ClassG32 -> min n 8 + ClassG16 -> min n 8 + ClassG8 -> min n 4 + ClassF64 -> 0 + + ClassG8 + -> case classC of + ClassG32 -> min (n*2) 8 + ClassG16 -> min (n*2) 8 + ClassG8 -> min n 8 + ClassF64 -> 0 + + ClassF64 + -> case classC of + ClassF64 -> min n 6 + _ -> 0 + +squeese :: RegClass -> [(Int, RegClass)] -> Int +squeese classN countCs + = sum (map (\(i, classC) -> worst i classN classC) countCs) + diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs new file mode 100644 index 00000000..69f0745d --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -0,0 +1,99 @@ +-- | Register coalescing. +module RegAlloc.Graph.Coalesce ( + regCoalesce, + slurpJoinMovs +) where +import RegAlloc.Liveness +import Instruction +import Reg + +import Cmm +import Bag +import Digraph +import UniqFM +import UniqSet +import UniqSupply + +import Data.List + + +-- | Do register coalescing on this top level thing +-- +-- For Reg -> Reg moves, if the first reg dies at the same time the +-- second reg is born then the mov only serves to join live ranges. +-- The two regs can be renamed to be the same and the move instruction +-- safely erased. +regCoalesce + :: Instruction instr + => [LiveCmmDecl statics instr] + -> UniqSM [LiveCmmDecl statics instr] + +regCoalesce code + = do + let joins = foldl' unionBags emptyBag + $ map slurpJoinMovs code + + let alloc = foldl' buildAlloc emptyUFM + $ bagToList joins + + let patched = map (patchEraseLive (sinkReg alloc)) code + + return patched + + +-- | Add a v1 = v2 register renaming to the map. +-- The register with the lowest lexical name is set as the +-- canonical version. +buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg +buildAlloc fm (r1, r2) + = let rmin = min r1 r2 + rmax = max r1 r2 + in addToUFM fm rmax rmin + + +-- | Determine the canonical name for a register by following +-- v1 = v2 renamings in this map. +sinkReg :: UniqFM Reg -> Reg -> Reg +sinkReg fm r + = case lookupUFM fm r of + Nothing -> r + Just r' -> sinkReg fm r' + + +-- | Slurp out mov instructions that only serve to join live ranges. +-- +-- During a mov, if the source reg dies and the destiation reg is +-- born then we can rename the two regs to the same thing and +-- eliminate the move. +slurpJoinMovs + :: Instruction instr + => LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpJoinMovs live + = slurpCmm emptyBag live + where + slurpCmm rs CmmData{} + = rs + + slurpCmm rs (CmmProc _ _ _ sccs) + = foldl' slurpBlock rs (flattenSCCs sccs) + + slurpBlock rs (BasicBlock _ instrs) + = foldl' slurpLI rs instrs + + slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr instr (Just live)) + | Just (r1, r2) <- takeRegRegMoveInstr instr + , elementOfUniqSet r1 $ liveDieRead live + , elementOfUniqSet r2 $ liveBorn live + + -- only coalesce movs between two virtuals for now, + -- else we end up with allocatable regs in the live + -- regs list.. + , isVirtualReg r1 && isVirtualReg r2 + = consBag (r1, r2) rs + + | otherwise + = rs + diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs new file mode 100644 index 00000000..05db68dd --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Graph coloring register allocator. +module RegAlloc.Graph.Main ( + regAlloc +) where +import qualified GraphColor as Color +import RegAlloc.Liveness +import RegAlloc.Graph.Spill +import RegAlloc.Graph.SpillClean +import RegAlloc.Graph.SpillCost +import RegAlloc.Graph.Stats +import RegAlloc.Graph.TrivColorable +import Instruction +import TargetReg +import RegClass +import Reg + +import UniqSupply +import UniqSet +import UniqFM +import Bag +import Outputable +import Platform +import DynFlags + +import Data.List +import Data.Maybe +import Control.Monad + + +-- | The maximum number of build\/spill cycles we'll allow. +-- +-- It should only take 3 or 4 cycles for the allocator to converge. +-- If it takes any longer than this it's probably in an infinite loop, +-- so it's better just to bail out and report a bug. +maxSpinCount :: Int +maxSpinCount = 10 + + +-- | The top level of the graph coloring register allocator. +regAlloc + :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation + -> UniqSet Int -- ^ set of available spill slots. + -> [LiveCmmDecl statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] ) + -- ^ code with registers allocated and stats for each stage of + -- allocation + +regAlloc dflags regsFree slotsFree code + = do + -- TODO: the regClass function is currently hard coded to the default + -- target architecture. Would prefer to determine this from dflags. + -- There are other uses of targetRegClass later in this module. + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) + + (code_final, debug_codeGraphs, _) + <- regAlloc_spin dflags 0 + triv + regsFree slotsFree [] code + + return ( code_final + , reverse debug_codeGraphs ) + + +-- | Perform solver iterations for the graph coloring allocator. +-- +-- We extract a register confict graph from the provided cmm code, +-- and try to colour it. If that works then we use the solution rewrite +-- the code with real hregs. If coloring doesn't work we add spill code +-- and try to colour it again. After `maxSpinCount` iterations we give up. +-- +regAlloc_spin + :: (Instruction instr, + Outputable instr, + Outputable statics) + => DynFlags + -> Int -- ^ Number of solver iterations we've already performed. + -> Color.Triv VirtualReg RegClass RealReg + -- ^ Function for calculating whether a register is trivially + -- colourable. + -> UniqFM (UniqSet RealReg) -- ^ Free registers that we can allocate. + -> UniqSet Int -- ^ Free stack slots that we can use. + -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to. + -> [LiveCmmDecl statics instr] -- ^ Liveness annotated code to allocate. + -> UniqSM ( [NatCmmDecl statics instr] + , [RegAllocStats statics instr] + , Color.Graph VirtualReg RegClass RealReg) + +regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code + = do + let platform = targetPlatform dflags + + -- If any of these dump flags are turned on we want to hang on to + -- intermediate structures in the allocator - otherwise tell the + -- allocator to ditch them early so we don't end up creating space leaks. + let dump = or + [ dopt Opt_D_dump_asm_regalloc_stages dflags + , dopt Opt_D_dump_asm_stats dflags + , dopt Opt_D_dump_asm_conflicts dflags ] + + -- Check that we're not running off down the garden path. + when (spinCount > maxSpinCount) + $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded." + ( text "It looks like the register allocator is stuck in an infinite loop." + $$ text "max cycles = " <> int maxSpinCount + $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr + $ uniqSetToList $ unionManyUniqSets + $ eltsUFM regsFree) + $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) + + -- Build the register conflict graph from the cmm code. + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph code + + -- VERY IMPORTANT: + -- We really do want the graph to be fully evaluated _before_ we + -- start coloring. If we don't do this now then when the call to + -- Color.colorGraph forces bits of it, the heap will be filled with + -- half evaluated pieces of graph and zillions of apply thunks. + seqGraph graph `seq` return () + + -- Build a map of the cost of spilling each instruction. + -- This is a lazy binding, so the map will only be computed if we + -- actually have to spill to the stack. + let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo + $ map (slurpSpillCostInfo platform) code + + -- The function to choose regs to leave uncolored. + let spill = chooseSpill spillCosts + + -- Record startup state in our log. + let stat1 + = if spinCount == 0 + then Just $ RegAllocStatsStart + { raLiveCmm = code + , raGraph = graph + , raSpillCosts = spillCosts } + else Nothing + + -- Try and color the graph. + let (graph_colored, rsSpill, rmCoalesce) + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (gopt Opt_RegsIterative dflags) + spinCount + regsFree triv spill graph + + -- Rewrite registers in the code that have been coalesced. + let patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + + let code_coalesced + = map (patchEraseLive patchF) code + + -- Check whether we've found a coloring. + if isEmptyUniqSet rsSpill + + -- Coloring was successful because no registers needed to be spilled. + then do + -- if -fasm-lint is turned on then validate the graph. + -- This checks for bugs in the graph allocator itself. + let graph_colored_lint = + if gopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + True -- Require all nodes to be colored. + graph_colored + else graph_colored + + -- Rewrite the code to use real hregs, using the colored graph. + let code_patched + = map (patchRegsFromGraph platform graph_colored_lint) + code_coalesced + + -- Clean out unneeded SPILL/RELOAD meta instructions. + -- The spill code generator just spills the entire live range + -- of a vreg, but it might not need to be on the stack for + -- its entire lifetime. + let code_spillclean + = map (cleanSpills platform) code_patched + + -- Strip off liveness information from the allocated code. + -- Also rewrite SPILL/RELOAD meta instructions into real machine + -- instructions along the way + let code_final + = map (stripLive dflags) code_spillclean + + -- Record what happened in this stage for debugging + let stat + = RegAllocStatsColored + { raCode = code + , raGraph = graph + , raGraphColored = graph_colored_lint + , raCoalesced = rmCoalesce + , raCodeCoalesced = code_coalesced + , raPatched = code_patched + , raSpillClean = code_spillclean + , raFinal = code_final + , raSRMs = foldl' addSRM (0, 0, 0) + $ map countSRMs code_spillclean } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList `seq` return () + + return ( code_final + , statList + , graph_colored_lint) + + -- Coloring was unsuccessful. We need to spill some register to the + -- stack, make a new graph, and try to color it again. + else do + -- if -fasm-lint is turned on then validate the graph + let graph_colored_lint = + if gopt Opt_DoAsmLinting dflags + then Color.validateGraph (text "") + False -- don't require nodes to be colored + graph_colored + else graph_colored + + -- Spill uncolored regs to the stack. + (code_spilled, slotsFree', spillStats) + <- regSpill platform code_coalesced slotsFree rsSpill + + -- Recalculate liveness information. + -- NOTE: we have to reverse the SCCs here to get them back into + -- the reverse-dependency order required by computeLiveness. + -- If they're not in the correct order that function will panic. + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) + code_spilled + + -- Record what happened in this stage for debugging. + let stat = + RegAllocStatsSpill + { raCode = code + , raGraph = graph_colored_lint + , raCoalesced = rmCoalesce + , raSpillStats = spillStats + , raSpillCosts = spillCosts + , raSpilled = code_spilled } + + -- Bundle up all the register allocator statistics. + -- .. but make sure to drop them on the floor if they're not + -- needed, otherwise we'll get a space leak. + let statList = + if dump + then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + else [] + + -- Ensure all the statistics are evaluated, to avoid space leaks. + seqList statList `seq` return () + + regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' + statList + code_relive + + +-- | Build a graph from the liveness and coalesce information in this code. +buildGraph + :: Instruction instr + => [LiveCmmDecl statics instr] + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) + +buildGraph code + = do + -- Slurp out the conflicts and reg->reg moves from this code. + let (conflictList, moveList) = + unzip $ map slurpConflicts code + + -- Slurp out the spill/reload coalesces. + let moveList2 = map slurpReloadCoalesce code + + -- Add the reg-reg conflicts to the graph. + let conflictBag = unionManyBags conflictList + let graph_conflict + = foldrBag graphAddConflictSet Color.initGraph conflictBag + + -- Add the coalescences edges to the graph. + let moveBag + = unionBags (unionManyBags moveList2) + (unionManyBags moveList) + + let graph_coalesce + = foldrBag graphAddCoalesce graph_conflict moveBag + + return graph_coalesce + + +-- | Add some conflict edges to the graph. +-- Conflicts between virtual and real regs are recorded as exclusions. +graphAddConflictSet + :: UniqSet Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddConflictSet set graph + = let virtuals = mkUniqSet + [ vr | RegVirtual vr <- uniqSetToList set ] + + graph1 = Color.addConflicts virtuals classOfVirtualReg graph + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) + graph1 + [ (vr, rr) + | RegVirtual vr <- uniqSetToList set + , RegReal rr <- uniqSetToList set] + + in graph2 + + +-- | Add some coalesence edges to the graph +-- Coalesences between virtual and real regs are recorded as preferences. +graphAddCoalesce + :: (Reg, Reg) + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg + +graphAddCoalesce (r1, r2) graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph + + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph + + -- We can't coalesce two real regs, but there could well be existing + -- hreg,hreg moves in the input code. We'll just ignore these + -- for coalescing purposes. + | RegReal _ <- r1 + , RegReal _ <- r2 + = graph + +graphAddCoalesce _ _ + = panic "graphAddCoalesce: bogus" + + +-- | Patch registers in code using the reg -> reg mapping in this graph. +patchRegsFromGraph + :: (Outputable statics, Outputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchRegsFromGraph platform graph code + = patchEraseLive patchF code + where + -- Function to lookup the hardreg for a virtual reg from the graph. + patchF reg + -- leave real regs alone. + | RegReal{} <- reg + = reg + + -- this virtual has a regular node in the graph. + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr + = case Color.nodeColor node of + Just color -> RegReal color + Nothing -> RegVirtual vr + + -- no node in the graph for this virtual, bad news. + | otherwise + = pprPanic "patchRegsFromGraph: register mapping failed." + ( text "There is no node in the graph for register " + <> ppr reg + $$ ppr code + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + graph) + + +----- +-- for when laziness just isn't what you wanted... +-- We need to deepSeq the whole graph before trying to colour it to avoid +-- space leaks. +seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () +seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) + +seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () +seqNodes ns + = case ns of + [] -> () + (n : ns) -> seqNode n `seq` seqNodes ns + +seqNode :: Color.Node VirtualReg RegClass RealReg -> () +seqNode node + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node))) + `seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node))) + +seqVirtualReg :: VirtualReg -> () +seqVirtualReg reg = reg `seq` () + +seqRealReg :: RealReg -> () +seqRealReg reg = reg `seq` () + +seqRegClass :: RegClass -> () +seqRegClass c = c `seq` () + +seqMaybeRealReg :: Maybe RealReg -> () +seqMaybeRealReg mr + = case mr of + Nothing -> () + Just r -> seqRealReg r + +seqVirtualRegList :: [VirtualReg] -> () +seqVirtualRegList rs + = case rs of + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs + +seqRealRegList :: [RealReg] -> () +seqRealRegList rs + = case rs of + [] -> () + (r : rs) -> seqRealReg r `seq` seqRealRegList rs + +seqList :: [a] -> () +seqList ls + = case ls of + [] -> () + (r : rs) -> r `seq` seqList rs + + diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs new file mode 100644 index 00000000..7267ef8e --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -0,0 +1,377 @@ + +-- | When there aren't enough registers to hold all the vregs we have to spill +-- some of those vregs to slots on the stack. This module is used modify the +-- code to use those slots. +module RegAlloc.Graph.Spill ( + regSpill, + SpillStats(..), + accSpillSL +) where +import RegAlloc.Liveness +import Instruction +import Reg +import Cmm hiding (RegSet) +import BlockId + +import MonadUtils +import State +import Unique +import UniqFM +import UniqSet +import UniqSupply +import Outputable +import Platform + +import Data.List +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- | Spill all these virtual regs to stack slots. +-- +-- TODO: See if we can split some of the live ranges instead of just globally +-- spilling the virtual reg. This might make the spill cleaner's job easier. +-- +-- TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction +-- when making spills. If an instr is using a spilled virtual we may be able to +-- address the spill slot directly. +-- +regSpill + :: Instruction instr + => Platform + -> [LiveCmmDecl statics instr] -- ^ the code + -> UniqSet Int -- ^ available stack slots + -> UniqSet VirtualReg -- ^ the regs to spill + -> UniqSM + ([LiveCmmDecl statics instr] + -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling + +regSpill platform code slotsFree regs + + -- Not enough slots to spill these regs. + | sizeUniqSet slotsFree < sizeUniqSet regs + = pprPanic "regSpill: out of spill slots!" + ( text " regs to spill = " <> ppr (sizeUniqSet regs) + $$ text " slots left = " <> ppr (sizeUniqSet slotsFree)) + + | otherwise + = do + -- Allocate a slot for each of the spilled regs. + let slots = take (sizeUniqSet regs) $ uniqSetToList slotsFree + let regSlotMap = listToUFM + $ zip (uniqSetToList regs) slots + + -- Grab the unique supply from the monad. + us <- getUniqueSupplyM + + -- Run the spiller on all the blocks. + let (code', state') = + runState (mapM (regSpill_top platform regSlotMap) code) + (initSpillS us) + + return ( code' + , minusUniqSet slotsFree (mkUniqSet slots) + , makeSpillStats state') + + +-- | Spill some registers to stack slots in a top-level thing. +regSpill_top + :: Instruction instr + => Platform + -> RegMap Int + -- ^ map of vregs to slots they're being spilled to. + -> LiveCmmDecl statics instr + -- ^ the top level thing. + -> SpillM (LiveCmmDecl statics instr) + +regSpill_top platform regSlotMap cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info + -> do + -- We should only passed Cmms with the liveness maps filled in, + -- but we'll create empty ones if they're not there just in case. + let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry + + -- The liveVRegsOnEntry contains the set of vregs that are live + -- on entry to each basic block. If we spill one of those vregs + -- we remove it from that set and add the corresponding slot + -- number to the liveSlotsOnEntry set. The spill cleaner needs + -- this information to erase unneeded spill and reload instructions + -- after we've done a successful allocation. + let liveSlotsOnEntry' :: Map BlockId (Set Int) + liveSlotsOnEntry' + = mapFoldWithKey patchLiveSlot + liveSlotsOnEntry liveVRegsOnEntry + + let info' + = LiveInfo static firstId + (Just liveVRegsOnEntry) + liveSlotsOnEntry' + + -- Apply the spiller to all the basic blocks in the CmmProc. + sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs + + return $ CmmProc info' label live sccs' + + where -- Given a BlockId and the set of registers live in it, + -- if registers in this block are being spilled to stack slots, + -- then record the fact that these slots are now live in those blocks + -- in the given slotmap. + patchLiveSlot + :: BlockId -> RegSet + -> Map BlockId (Set Int) -> Map BlockId (Set Int) + + patchLiveSlot blockId regsLive slotMap + = let + -- Slots that are already recorded as being live. + curSlotsLive = fromMaybe Set.empty + $ Map.lookup blockId slotMap + + moreSlotsLive = Set.fromList + $ catMaybes + $ map (lookupUFM regSlotMap) + $ uniqSetToList regsLive + + slotMap' + = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) + slotMap + + in slotMap' + + +-- | Spill some registers to stack slots in a basic block. +regSpill_block + :: Instruction instr + => Platform + -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. + -> LiveBasicBlock instr + -> SpillM (LiveBasicBlock instr) + +regSpill_block platform regSlotMap (BasicBlock i instrs) + = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs + return $ BasicBlock i (concat instrss') + + +-- | Spill some registers to stack slots in a single instruction. +-- If the instruction uses registers that need to be spilled, then it is +-- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta +-- instructions. +regSpill_instr + :: Instruction instr + => Platform + -> UniqFM Int -- ^ map of vregs to slots they're being spilled to. + -> LiveInstr instr + -> SpillM [LiveInstr instr] + +regSpill_instr _ _ li@(LiveInstr _ Nothing) + = do return [li] + +regSpill_instr platform regSlotMap + (LiveInstr instr (Just _)) + = do + -- work out which regs are read and written in this instr + let RU rlRead rlWritten = regUsageOfInstr platform instr + + -- sometimes a register is listed as being read more than once, + -- nub this so we don't end up inserting two lots of spill code. + let rsRead_ = nub rlRead + let rsWritten_ = nub rlWritten + + -- if a reg is modified, it appears in both lists, want to undo this.. + let rsRead = rsRead_ \\ rsWritten_ + let rsWritten = rsWritten_ \\ rsRead_ + let rsModify = intersect rsRead_ rsWritten_ + + -- work out if any of the regs being used are currently being spilled. + let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead + let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten + let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify + + -- rewrite the instr and work out spill code. + (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead + (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten + (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify + + let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3) + let prefixes = concat mPrefixes + let postfixes = concat mPostfixes + + -- final code + let instrs' = prefixes + ++ [LiveInstr instr3 Nothing] + ++ postfixes + + return $ instrs' + + +-- | Add a RELOAD met a instruction to load a value for an instruction that +-- writes to a vreg that is being spilled. +spillRead + :: Instruction instr + => UniqFM Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillRead regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , []) ) + + | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" + + +-- | Add a SPILL meta instruction to store a value for an instruction that +-- writes to a vreg that is being spilled. +spillWrite + :: Instruction instr + => UniqFM Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillWrite regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) } + + return ( instr' + , ( [] + , [LiveInstr (SPILL nReg slot) Nothing])) + + | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" + + +-- | Add both RELOAD and SPILL meta instructions for an instruction that +-- both reads and writes to a vreg that is being spilled. +spillModify + :: Instruction instr + => UniqFM Int + -> instr + -> Reg + -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) + +spillModify regSlotMap instr reg + | Just slot <- lookupUFM regSlotMap reg + = do (instr', nReg) <- patchInstr reg instr + + modify $ \s -> s + { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } + + return ( instr' + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , [LiveInstr (SPILL nReg slot) Nothing])) + + | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" + + +-- | Rewrite uses of this virtual reg in an instr to use a different +-- virtual reg. +patchInstr + :: Instruction instr + => Reg -> instr -> SpillM (instr, Reg) + +patchInstr reg instr + = do nUnique <- newUnique + + -- The register we're rewriting is suppoed to be virtual. + -- If it's not then something has gone horribly wrong. + let nReg + = case reg of + RegVirtual vr + -> RegVirtual (renameVirtualReg nUnique vr) + + RegReal{} + -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" + + let instr' = patchReg1 reg nReg instr + return (instr', nReg) + + +patchReg1 + :: Instruction instr + => Reg -> Reg -> instr -> instr + +patchReg1 old new instr + = let patchF r + | r == old = new + | otherwise = r + in patchRegsOfInstr instr patchF + + +-- Spiller monad -------------------------------------------------------------- +-- | State monad for the spill code generator. +type SpillM a + = State SpillS a + +-- | Spill code generator state. +data SpillS + = SpillS + { -- | Unique supply for generating fresh vregs. + stateUS :: UniqSupply + + -- | Spilled vreg vs the number of times it was loaded, stored. + , stateSpillSL :: UniqFM (Reg, Int, Int) } + + +-- | Create a new spiller state. +initSpillS :: UniqSupply -> SpillS +initSpillS uniqueSupply + = SpillS + { stateUS = uniqueSupply + , stateSpillSL = emptyUFM } + + +-- | Allocate a new unique in the spiller monad. +newUnique :: SpillM Unique +newUnique + = do us <- gets stateUS + case takeUniqFromSupply us of + (uniq, us') + -> do modify $ \s -> s { stateUS = us' } + return uniq + + +-- | Add a spill/reload count to a stats record for a register. +accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int) +accSpillSL (r1, s1, l1) (_, s2, l2) + = (r1, s1 + s2, l1 + l2) + + +-- Spiller stats -------------------------------------------------------------- +-- | Spiller statistics. +-- Tells us what registers were spilled. +data SpillStats + = SpillStats + { spillStoreLoad :: UniqFM (Reg, Int, Int) } + + +-- | Extract spiller statistics from the spiller state. +makeSpillStats :: SpillS -> SpillStats +makeSpillStats s + = SpillStats + { spillStoreLoad = stateSpillSL s } + + +instance Outputable SpillStats where + ppr stats + = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l) + $ eltsUFM (spillStoreLoad stats)) + diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs new file mode 100644 index 00000000..a81d76dd --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -0,0 +1,613 @@ + +-- | Clean out unneeded spill\/reload instructions. +-- +-- Handling of join points +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- B1: B2: +-- ... ... +-- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1 +-- ... A ... ... B ... +-- jump B3 jump B3 +-- +-- B3: ... C ... +-- RELOAD SLOT(0), %r1 +-- ... +-- +-- The Plan +-- ~~~~~~~~ +-- As long as %r1 hasn't been written to in A, B or C then we don't need +-- the reload in B3. +-- +-- What we really care about here is that on the entry to B3, %r1 will +-- always have the same value that is in SLOT(0) (ie, %r1 is _valid_) +-- +-- This also works if the reloads in B1\/B2 were spills instead, because +-- spilling %r1 to a slot makes that slot have the same value as %r1. +-- +module RegAlloc.Graph.SpillClean ( + cleanSpills +) where +import RegAlloc.Liveness +import Instruction +import Reg + +import BlockId +import Cmm +import UniqSet +import UniqFM +import Unique +import State +import Outputable +import Platform + +import Data.List +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- | The identification number of a spill slot. +-- A value is stored in a spill slot when we don't have a free +-- register to hold it. +type Slot = Int + + +-- | Clean out unneeded spill\/reloads from this top level thing. +cleanSpills + :: Instruction instr + => Platform + -> LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS + + +-- | Do one pass of cleaning. +cleanSpin + :: Instruction instr + => Platform + -> Int -- ^ Iteration number for the cleaner. + -> LiveCmmDecl statics instr -- ^ Liveness annotated code to clean. + -> CleanM (LiveCmmDecl statics instr) + +cleanSpin platform spinCount code + = do + -- Initialise count of cleaned spill and reload instructions. + modify $ \s -> s + { sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 + , sReloadedBy = emptyUFM } + + code_forward <- mapBlockTopM (cleanBlockForward platform) code + code_backward <- cleanTopBackward code_forward + + -- During the cleaning of each block we collected information about + -- what regs were valid across each jump. Based on this, work out + -- whether it will be safe to erase reloads after join points for + -- the next pass. + collateJoinPoints + + -- Remember how many spill and reload instructions we cleaned in this pass. + spills <- gets sCleanedSpillsAcc + reloads <- gets sCleanedReloadsAcc + modify $ \s -> s + { sCleanedCount = (spills, reloads) : sCleanedCount s } + + -- If nothing was cleaned in this pass or the last one + -- then we're done and it's time to bail out. + cleanedCount <- gets sCleanedCount + if take 2 cleanedCount == [(0, 0), (0, 0)] + then return code + + -- otherwise go around again + else cleanSpin platform (spinCount + 1) code_backward + + +------------------------------------------------------------------------------- +-- | Clean out unneeded reload instructions, +-- while walking forward over the code. +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockForward platform (BasicBlock blockId instrs) + = do + -- See if we have a valid association for the entry to this block. + jumpValid <- gets sJumpValid + let assoc = case lookupUFM jumpValid blockId of + Just assoc -> assoc + Nothing -> emptyAssoc + + instrs_reload <- cleanForward platform blockId assoc [] instrs + return $ BasicBlock blockId instrs_reload + + + +-- | Clean out unneeded reload instructions. +-- +-- Walking forwards across the code +-- On a reload, if we know a reg already has the same value as a slot +-- then we don't need to do the reload. +-- +cleanForward + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if + -- they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] + = return acc + +-- Rewrite live range joins via spill slots to just a spill and a reg-reg move +-- hopefully the spill will be also be cleaned in the next pass +cleanForward platform blockId assoc acc (li1 : li2 : instrs) + + | LiveInstr (SPILL reg1 slot1) _ <- li1 + , LiveInstr (RELOAD slot2 reg2) _ <- li2 + , slot1 == slot2 + = do + modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + cleanForward platform blockId assoc acc + $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing + : instrs + +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) + | Just (r1, r2) <- takeRegRegMoveInstr i1 + = if r1 == r2 + -- Erase any left over nop reg reg moves while we're here + -- this will also catch any nop moves that the previous case + -- happens to add. + then cleanForward platform blockId assoc acc instrs + + -- If r1 has the same value as some slots and we copy r1 to r2, + -- then r2 is now associated with those slots instead + else do let assoc' = addAssoc (SReg r1) (SReg r2) + $ delAssoc (SReg r2) + $ assoc + + cleanForward platform blockId assoc' (li : acc) instrs + + +cleanForward platform blockId assoc acc (li : instrs) + + -- Update association due to the spill. + | LiveInstr (SPILL reg slot) _ <- li + = let assoc' = addAssoc (SReg reg) (SSlot slot) + $ delAssoc (SSlot slot) + $ assoc + in cleanForward platform blockId assoc' (li : acc) instrs + + -- Clean a reload instr. + | LiveInstr (RELOAD{}) _ <- li + = do (assoc', mli) <- cleanReload platform blockId assoc li + case mli of + Nothing -> cleanForward platform blockId assoc' acc + instrs + + Just li' -> cleanForward platform blockId assoc' (li' : acc) + instrs + + -- Remember the association over a jump. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accJumpValid assoc) targets + cleanForward platform blockId assoc (li : acc) instrs + + -- Writing to a reg changes its value. + | LiveInstr instr _ <- li + , RU _ written <- regUsageOfInstr platform instr + = let assoc' = foldr delAssoc assoc (map SReg $ nub written) + in cleanForward platform blockId assoc' (li : acc) instrs + + + +-- | Try and rewrite a reload instruction to something more pleasing +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) + +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) + + -- If the reg we're reloading already has the same value as the slot + -- then we can erase the instruction outright. + | elemAssoc (SSlot slot) (SReg reg) assoc + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + return (assoc, Nothing) + + -- If we can find another reg with the same value as this slot then + -- do a move instead of a reload. + | Just reg2 <- findRegOfSlot assoc slot + = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } + + let assoc' = addAssoc (SReg reg) (SReg reg2) + $ delAssoc (SReg reg) + $ assoc + + return ( assoc' + , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) + + -- Gotta keep this instr. + | otherwise + = do -- Update the association. + let assoc' + = addAssoc (SReg reg) (SSlot slot) + -- doing the reload makes reg and slot the same value + $ delAssoc (SReg reg) + -- reg value changes on reload + $ assoc + + -- Remember that this block reloads from this slot. + accBlockReloadsSlot blockId slot + + return (assoc', Just li) + +cleanReload _ _ _ _ + = panic "RegSpillClean.cleanReload: unhandled instr" + + +------------------------------------------------------------------------------- +-- | Clean out unneeded spill instructions, +-- while walking backwards over the code. +-- +-- If there were no reloads from a slot between a spill and the last one +-- then the slot was never read and we don't need the spill. +-- +-- SPILL r0 -> s1 +-- RELOAD s1 -> r2 +-- SPILL r3 -> s1 <--- don't need this spill +-- SPILL r4 -> s1 +-- RELOAD s1 -> r5 +-- +-- Maintain a set of +-- "slots which were spilled to but not reloaded from yet" +-- +-- Walking backwards across the code: +-- a) On a reload from a slot, remove it from the set. +-- +-- a) On a spill from a slot +-- If the slot is in set then we can erase the spill, +-- because it won't be reloaded from until after the next spill. +-- +-- otherwise +-- keep the spill and add the slot to the set +-- +-- TODO: This is mostly inter-block +-- we should really be updating the noReloads set as we cross jumps also. +-- +-- TODO: generate noReloads from liveSlotsOnEntry +-- +cleanTopBackward + :: Instruction instr + => LiveCmmDecl statics instr + -> CleanM (LiveCmmDecl statics instr) + +cleanTopBackward cmm + = case cmm of + CmmData{} + -> return cmm + + CmmProc info label live sccs + | LiveInfo _ _ _ liveSlotsOnEntry <- info + -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs + return $ CmmProc info label live sccs' + + +cleanBlockBackward + :: Instruction instr + => Map BlockId (Set Int) + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) + +cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) + = do instrs_spill <- cleanBackward liveSlotsOnEntry emptyUniqSet [] instrs + return $ BasicBlock blockId instrs_spill + + + +cleanBackward + :: Instruction instr + => Map BlockId (Set Int) -- ^ Slots live on entry to each block + -> UniqSet Int -- ^ Slots that have been spilled, but not reloaded from + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ Instrs to clean (in forwards order) + -> CleanM [LiveInstr instr] -- ^ Cleaned instrs (in backwards order) + +cleanBackward liveSlotsOnEntry noReloads acc lis + = do reloadedBy <- gets sReloadedBy + cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis + + +cleanBackward' + :: Instruction instr + => Map BlockId (Set Int) + -> UniqFM [BlockId] + -> UniqSet Int + -> [LiveInstr instr] + -> [LiveInstr instr] + -> State CleanS [LiveInstr instr] + +cleanBackward' _ _ _ acc [] + = return acc + +cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) + + -- If nothing ever reloads from this slot then we don't need the spill. + | LiveInstr (SPILL _ slot) _ <- li + , Nothing <- lookupUFM reloadedBy (SSlot slot) + = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + | LiveInstr (SPILL _ slot) _ <- li + = if elementOfUniqSet slot noReloads + + -- We can erase this spill because the slot won't be read until + -- after the next one + then do + modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } + cleanBackward liveSlotsOnEntry noReloads acc instrs + + else do + -- This slot is being spilled to, but we haven't seen any reloads yet. + let noReloads' = addOneToUniqSet noReloads slot + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- if we reload from a slot then it's no longer unused + | LiveInstr (RELOAD slot _) _ <- li + , noReloads' <- delOneFromUniqSet noReloads slot + = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- If a slot is live in a jump target then assume it's reloaded there. + -- + -- TODO: A real dataflow analysis would do a better job here. + -- If the target block _ever_ used the slot then we assume + -- it always does, but if those reloads are cleaned the slot + -- liveness map doesn't get updated. + | LiveInstr instr _ <- li + , targets <- jumpDestsOfInstr instr + = do + let slotsReloadedByTargets + = Set.unions + $ catMaybes + $ map (flip Map.lookup liveSlotsOnEntry) + $ targets + + let noReloads' + = foldl' delOneFromUniqSet noReloads + $ Set.toList slotsReloadedByTargets + + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs + + -- some other instruction + | otherwise + = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs + + +-- | Combine the associations from all the inward control flow edges. +-- +collateJoinPoints :: CleanM () +collateJoinPoints + = modify $ \s -> s + { sJumpValid = mapUFM intersects (sJumpValidAcc s) + , sJumpValidAcc = emptyUFM } + +intersects :: [Assoc Store] -> Assoc Store +intersects [] = emptyAssoc +intersects assocs = foldl1' intersectAssoc assocs + + +-- | See if we have a reg with the same value as this slot in the association table. +findRegOfSlot :: Assoc Store -> Int -> Maybe Reg +findRegOfSlot assoc slot + | close <- closeAssoc (SSlot slot) assoc + , Just (SReg reg) <- find isStoreReg $ uniqSetToList close + = Just reg + + | otherwise + = Nothing + + +------------------------------------------------------------------------------- +-- | Cleaner monad. +type CleanM + = State CleanS + +-- | Cleaner state. +data CleanS + = CleanS + { -- | Regs which are valid at the start of each block. + sJumpValid :: UniqFM (Assoc Store) + + -- | Collecting up what regs were valid across each jump. + -- in the next pass we can collate these and write the results + -- to sJumpValid. + , sJumpValidAcc :: UniqFM [Assoc Store] + + -- | Map of (slot -> blocks which reload from this slot) + -- used to decide if whether slot spilled to will ever be + -- reloaded from on this path. + , sReloadedBy :: UniqFM [BlockId] + + -- | Spills and reloads cleaned each pass (latest at front) + , sCleanedCount :: [(Int, Int)] + + -- | Spills and reloads that have been cleaned in this pass so far. + , sCleanedSpillsAcc :: Int + , sCleanedReloadsAcc :: Int } + + +-- | Construct the initial cleaner state. +initCleanS :: CleanS +initCleanS + = CleanS + { sJumpValid = emptyUFM + , sJumpValidAcc = emptyUFM + + , sReloadedBy = emptyUFM + + , sCleanedCount = [] + + , sCleanedSpillsAcc = 0 + , sCleanedReloadsAcc = 0 } + + +-- | Remember the associations before a jump. +accJumpValid :: Assoc Store -> BlockId -> CleanM () +accJumpValid assocs target + = modify $ \s -> s { + sJumpValidAcc = addToUFM_C (++) + (sJumpValidAcc s) + target + [assocs] } + + +accBlockReloadsSlot :: BlockId -> Slot -> CleanM () +accBlockReloadsSlot blockId slot + = modify $ \s -> s { + sReloadedBy = addToUFM_C (++) + (sReloadedBy s) + (SSlot slot) + [blockId] } + + +------------------------------------------------------------------------------- +-- A store location can be a stack slot or a register +data Store + = SSlot Int + | SReg Reg + + +-- | Check if this is a reg store. +isStoreReg :: Store -> Bool +isStoreReg ss + = case ss of + SSlot _ -> False + SReg _ -> True + + +-- Spill cleaning is only done once all virtuals have been allocated to realRegs +instance Uniquable Store where + getUnique (SReg r) + | RegReal (RealRegSingle i) <- r + = mkRegSingleUnique i + + | RegReal (RealRegPair r1 r2) <- r + = mkRegPairUnique (r1 * 65535 + r2) + + | otherwise + = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," + ++ "only real regs expected." + + getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok + + +instance Outputable Store where + ppr (SSlot i) = text "slot" <> int i + ppr (SReg r) = ppr r + + +------------------------------------------------------------------------------- +-- Association graphs. +-- In the spill cleaner, two store locations are associated if they are known +-- to hold the same value. +-- +type Assoc a = UniqFM (UniqSet a) + +-- | An empty association +emptyAssoc :: Assoc a +emptyAssoc = emptyUFM + + +-- | Add an association between these two things. +addAssoc :: Uniquable a + => a -> a -> Assoc a -> Assoc a + +addAssoc a b m + = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b) + m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a) + in m2 + + +-- | Delete all associations to a node. +delAssoc :: (Outputable a, Uniquable a) + => a -> Assoc a -> Assoc a + +delAssoc a m + | Just aSet <- lookupUFM m a + , m1 <- delFromUFM m a + = foldUniqSet (\x m -> delAssoc1 x a m) m1 aSet + + | otherwise = m + + +-- | Delete a single association edge (a -> b). +delAssoc1 :: Uniquable a + => a -> a -> Assoc a -> Assoc a + +delAssoc1 a b m + | Just aSet <- lookupUFM m a + = addToUFM m a (delOneFromUniqSet aSet b) + + | otherwise = m + + +-- | Check if these two things are associated. +elemAssoc :: (Outputable a, Uniquable a) + => a -> a -> Assoc a -> Bool + +elemAssoc a b m + = elementOfUniqSet b (closeAssoc a m) + + +-- | Find the refl. trans. closure of the association from this point. +closeAssoc :: (Outputable a, Uniquable a) + => a -> Assoc a -> UniqSet a + +closeAssoc a assoc + = closeAssoc' assoc emptyUniqSet (unitUniqSet a) + where + closeAssoc' assoc visited toVisit + = case uniqSetToList toVisit of + + -- nothing else to visit, we're done + [] -> visited + + (x:_) + -- we've already seen this node + | elementOfUniqSet x visited + -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x) + + -- haven't seen this node before, + -- remember to visit all its neighbors + | otherwise + -> let neighbors + = case lookupUFM assoc x of + Nothing -> emptyUniqSet + Just set -> set + + in closeAssoc' assoc + (addOneToUniqSet visited x) + (unionUniqSets toVisit neighbors) + +-- | Intersect two associations. +intersectAssoc + :: Uniquable a + => Assoc a -> Assoc a -> Assoc a + +intersectAssoc a b + = intersectUFM_C (intersectUniqSets) a b + diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs new file mode 100644 index 00000000..97616baa --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -0,0 +1,288 @@ + +module RegAlloc.Graph.SpillCost ( + SpillCostRecord, + plusSpillCostRecord, + pprSpillCostRecord, + + SpillCostInfo, + zeroSpillCostInfo, + plusSpillCostInfo, + + slurpSpillCostInfo, + chooseSpill, + + lifeMapFromSpillCostInfo +) where +import RegAlloc.Liveness +import Instruction +import RegClass +import Reg + +import GraphBase + +import BlockId +import Cmm +import UniqFM +import UniqSet +import Digraph (flattenSCCs) +import Outputable +import Platform +import State + +import Data.List (nub, minimumBy) +import Data.Maybe + + +-- | Records the expected cost to spill some regster. +type SpillCostRecord + = ( VirtualReg -- register name + , Int -- number of writes to this reg + , Int -- number of reads from this reg + , Int) -- number of instrs this reg was live on entry to + + +-- | Map of `SpillCostRecord` +type SpillCostInfo + = UniqFM SpillCostRecord + + +-- | An empty map of spill costs. +zeroSpillCostInfo :: SpillCostInfo +zeroSpillCostInfo = emptyUFM + + +-- | Add two spill cost infos. +plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo +plusSpillCostInfo sc1 sc2 + = plusUFM_C plusSpillCostRecord sc1 sc2 + + +-- | Add two spill cost records. +plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord +plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) + | r1 == r2 = (r1, a1 + a2, b1 + b2, c1 + c2) + | otherwise = error "RegSpillCost.plusRegInt: regs don't match" + + +-- | Slurp out information used for determining spill costs. +-- +-- For each vreg, the number of times it was written to, read from, +-- and the number of instructions it was live on entry to (lifetime) +-- +slurpSpillCostInfo :: (Outputable instr, Instruction instr) + => Platform + -> LiveCmmDecl statics instr + -> SpillCostInfo + +slurpSpillCostInfo platform cmm + = execState (countCmm cmm) zeroSpillCostInfo + where + countCmm CmmData{} = return () + countCmm (CmmProc info _ _ sccs) + = mapM_ (countBlock info) + $ flattenSCCs sccs + + -- Lookup the regs that are live on entry to this block in + -- the info table from the CmmProc. + countBlock info (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , rsLiveEntry_virt <- takeVirtuals rsLiveEntry + = countLIs rsLiveEntry_virt instrs + + | otherwise + = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" + + countLIs _ [] + = return () + + -- Skip over comment and delta pseudo instrs. + countLIs rsLive (LiveInstr instr Nothing : lis) + | isMetaInstr instr + = countLIs rsLive lis + + | otherwise + = pprPanic "RegSpillCost.slurpSpillCostInfo" + $ text "no liveness information on instruction " <> ppr instr + + countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) + = do + -- Increment the lifetime counts for regs live on entry to this instr. + mapM_ incLifetime $ uniqSetToList rsLiveEntry + + -- Increment counts for what regs were read/written from. + let (RU read written) = regUsageOfInstr platform instr + mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read + mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written + + -- Compute liveness for entry to next instruction. + let liveDieRead_virt = takeVirtuals (liveDieRead live) + let liveDieWrite_virt = takeVirtuals (liveDieWrite live) + let liveBorn_virt = takeVirtuals (liveBorn live) + + let rsLiveAcross + = rsLiveEntry `minusUniqSet` liveDieRead_virt + + let rsLiveNext + = (rsLiveAcross `unionUniqSets` liveBorn_virt) + `minusUniqSet` liveDieWrite_virt + + countLIs rsLiveNext lis + + incDefs reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 1, 0, 0) + incUses reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 1, 0) + incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) + + +-- | Take all the virtual registers from this set. +takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg +takeVirtuals set + = mapUniqSet get_virtual + $ filterUniqSet isVirtualReg set + where + get_virtual (RegVirtual vr) = vr + get_virtual _ = panic "getVirt" + + +-- | Choose a node to spill from this graph +chooseSpill + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + +chooseSpill info graph + = let cost = spillCost_length info graph + node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) + $ eltsUFM $ graphMap graph + + in nodeId node + + +------------------------------------------------------------------------------- +-- | Chaitins spill cost function is: +-- +-- cost = sum loadCost * freq (u) + sum storeCost * freq (d) +-- u <- uses (v) d <- defs (v) +-- +-- There are no loops in our code at the momemnt, so we can set the freq's to 1. +-- +-- If we don't have live range splitting then Chaitins function performs badly +-- if we have lots of nested live ranges and very few registers. +-- +-- v1 v2 v3 +-- def v1 . +-- use v1 . +-- def v2 . . +-- def v3 . . . +-- use v1 . . . +-- use v3 . . . +-- use v2 . . +-- use v1 . +-- +-- defs uses degree cost +-- v1: 1 3 3 1.5 +-- v2: 1 2 3 1.0 +-- v3: 1 1 3 0.666 +-- +-- v3 has the lowest cost, but if we only have 2 hardregs and we insert +-- spill code for v3 then this isn't going to improve the colorability of +-- the graph. +-- +-- When compiling SHA1, which as very long basic blocks and some vregs +-- with very long live ranges the allocator seems to try and spill from +-- the inside out and eventually run out of stack slots. +-- +-- Without live range splitting, its's better to spill from the outside +-- in so set the cost of very long live ranges to zero +-- +{- +spillCost_chaitin + :: SpillCostInfo + -> Graph Reg RegClass Reg + -> Reg + -> Float + +spillCost_chaitin info graph reg + -- Spilling a live range that only lives for 1 instruction + -- isn't going to help us at all - and we definitely want to avoid + -- trying to re-spill previously inserted spill code. + | lifetime <= 1 = 1/0 + + -- It's unlikely that we'll find a reg for a live range this long + -- better to spill it straight up and not risk trying to keep it around + -- and have to go through the build/color cycle again. + | lifetime > allocatableRegsInClass (regClass reg) * 10 + = 0 + + -- Otherwise revert to chaitin's regular cost function. + | otherwise = fromIntegral (uses + defs) + / fromIntegral (nodeDegree graph reg) + where (_, defs, uses, lifetime) + = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg +-} + +-- Just spill the longest live range. +spillCost_length + :: SpillCostInfo + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Float + +spillCost_length info _ reg + | lifetime <= 1 = 1/0 + | otherwise = 1 / fromIntegral lifetime + where (_, _, _, lifetime) + = fromMaybe (reg, 0, 0, 0) + $ lookupUFM info reg + + +-- | Extract a map of register lifetimes from a `SpillCostInfo`. +lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) +lifeMapFromSpillCostInfo info + = listToUFM + $ map (\(r, _, _, life) -> (r, (r, life))) + $ eltsUFM info + + +-- | Determine the degree (number of neighbors) of this node which +-- have the same class. +nodeDegree + :: (VirtualReg -> RegClass) + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Int + +nodeDegree classOfVirtualReg graph reg + | Just node <- lookupUFM (graphMap graph) reg + + , virtConflicts + <- length + $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) + $ uniqSetToList + $ nodeConflicts node + + = virtConflicts + sizeUniqSet (nodeExclusions node) + + | otherwise + = 0 + + +-- | Show a spill cost record, including the degree from the graph +-- and final calulated spill cost. +pprSpillCostRecord + :: (VirtualReg -> RegClass) + -> (Reg -> SDoc) + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord + -> SDoc + +pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) + = hsep + [ pprReg (RegVirtual reg) + , ppr uses + , ppr defs + , ppr life + , ppr $ nodeDegree regClass graph reg + , text $ show $ (fromIntegral (uses + defs) + / fromIntegral (nodeDegree regClass graph reg) :: Float) ] + diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs new file mode 100644 index 00000000..8fada96e --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +-- | Carries interesting info for debugging / profiling of the +-- graph coloring register allocator. +module RegAlloc.Graph.Stats ( + RegAllocStats (..), + + pprStats, + pprStatsSpills, + pprStatsLifetimes, + pprStatsConflict, + pprStatsLifeConflict, + + countSRMs, addSRM +) where + +#include "nativeGen/NCG.h" + +import qualified GraphColor as Color +import RegAlloc.Liveness +import RegAlloc.Graph.Spill +import RegAlloc.Graph.SpillCost +import RegAlloc.Graph.TrivColorable +import Instruction +import RegClass +import Reg +import TargetReg + +import PprCmm() +import Outputable +import UniqFM +import UniqSet +import State + +import Data.List + + +-- | Holds interesting statistics from the register allocator. +data RegAllocStats statics instr + + -- Information about the initial conflict graph. + = RegAllocStatsStart + { -- | Initial code, with liveness. + raLiveCmm :: [LiveCmmDecl statics instr] + + -- | The initial, uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Information to help choose which regs to spill. + , raSpillCosts :: SpillCostInfo } + + + -- Information about an intermediate graph. + -- This is one that we couldn't color, so had to insert spill code + -- instruction stream. + | RegAllocStatsSpill + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Partially colored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | The regs that were coaleced. + , raCoalesced :: UniqFM VirtualReg + + -- | Spiller stats. + , raSpillStats :: SpillStats + + -- | Number of instructions each reg lives for. + , raSpillCosts :: SpillCostInfo + + -- | Code with spill instructions added. + , raSpilled :: [LiveCmmDecl statics instr] } + + + -- a successful coloring + | RegAllocStatsColored + { -- | Code we tried to allocate registers for. + raCode :: [LiveCmmDecl statics instr] + + -- | Uncolored graph. + , raGraph :: Color.Graph VirtualReg RegClass RealReg + + -- | Coalesced and colored graph. + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg + + -- | Regs that were coaleced. + , raCoalesced :: UniqFM VirtualReg + + -- | Code with coalescings applied. + , raCodeCoalesced :: [LiveCmmDecl statics instr] + + -- | Code with vregs replaced by hregs. + , raPatched :: [LiveCmmDecl statics instr] + + -- | Code with unneeded spill\/reloads cleaned out. + , raSpillClean :: [LiveCmmDecl statics instr] + + -- | Final code. + , raFinal :: [NatCmmDecl statics instr] + + -- | Spill\/reload\/reg-reg moves present in this code. + , raSRMs :: (Int, Int, Int) } + + +instance (Outputable statics, Outputable instr) + => Outputable (RegAllocStats statics instr) where + + ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> + text "# Start" + $$ text "# Native code with liveness information." + $$ ppr (raLiveCmm s) + $$ text "" + $$ text "# Initial register conflict graph." + $$ Color.dotGraph + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + (raGraph s) + + + ppr (s@RegAllocStatsSpill{}) = + text "# Spill" + + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) + $$ text "" + else empty) + + $$ text "# Spills inserted." + $$ ppr (raSpillStats s) + $$ text "" + + $$ text "# Code with spills inserted." + $$ ppr (raSpilled s) + + + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + = sdocWithPlatform $ \platform -> + text "# Colored" + + $$ text "# Code with liveness information." + $$ ppr (raCode s) + $$ text "" + + $$ text "# Register conflict graph (colored)." + $$ Color.dotGraph + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + (raGraphColored s) + $$ text "" + + $$ (if (not $ isNullUFM $ raCoalesced s) + then text "# Registers coalesced." + $$ (vcat $ map ppr $ ufmToList $ raCoalesced s) + $$ text "" + else empty) + + $$ text "# Native code after coalescings applied." + $$ ppr (raCodeCoalesced s) + $$ text "" + + $$ text "# Native code after register allocation." + $$ ppr (raPatched s) + $$ text "" + + $$ text "# Clean out unneeded spill/reloads." + $$ ppr (raSpillClean s) + $$ text "" + + $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." + $$ ppr (raFinal s) + $$ text "" + $$ text "# Score:" + $$ (text "# spills inserted: " <> int spills) + $$ (text "# reloads inserted: " <> int reloads) + $$ (text "# reg-reg moves remaining: " <> int moves) + $$ text "" + + +-- | Do all the different analysis on this list of RegAllocStats +pprStats + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + +pprStats stats graph + = let outSpills = pprStatsSpills stats + outLife = pprStatsLifetimes stats + outConflict = pprStatsConflict stats + outScatter = pprStatsLifeConflict stats graph + + in vcat [outSpills, outLife, outConflict, outScatter] + + +-- | Dump a table of how many spill loads \/ stores were inserted for each vreg. +pprStatsSpills + :: [RegAllocStats statics instr] -> SDoc + +pprStatsSpills stats + = let + finals = [ s | s@RegAllocStatsColored{} <- stats] + + -- sum up how many stores\/loads\/reg-reg-moves were left in the code + total = foldl' addSRM (0, 0, 0) + $ map raSRMs finals + + in ( text "-- spills-added-total" + $$ text "-- (stores, loads, reg_reg_moves_remaining)" + $$ ppr total + $$ text "") + + +-- | Dump a table of how long vregs tend to live for in the initial code. +pprStatsLifetimes + :: [RegAllocStats statics instr] -> SDoc + +pprStatsLifetimes stats + = let info = foldl' plusSpillCostInfo zeroSpillCostInfo + [ raSpillCosts s + | s@RegAllocStatsStart{} <- stats ] + + lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info + + in ( text "-- vreg-population-lifetimes" + $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)" + $$ (vcat $ map ppr $ eltsUFM lifeBins) + $$ text "\n") + + +binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) +binLifetimeCount fm + = let lifes = map (\l -> (l, (l, 1))) + $ map snd + $ eltsUFM fm + + in addListToUFM_C + (\(l1, c1) (_, c2) -> (l1, c1 + c2)) + emptyUFM + lifes + + +-- | Dump a table of how many conflicts vregs tend to have in the initial code. +pprStatsConflict + :: [RegAllocStats statics instr] -> SDoc + +pprStatsConflict stats + = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) + emptyUFM + $ map Color.slurpNodeConflictCount + [ raGraph s | s@RegAllocStatsStart{} <- stats ] + + in ( text "-- vreg-conflicts" + $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)" + $$ (vcat $ map ppr $ eltsUFM confMap) + $$ text "\n") + + +-- | For every vreg, dump it's how many conflicts it has and its lifetime +-- good for making a scatter plot. +pprStatsLifeConflict + :: [RegAllocStats statics instr] + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph + -> SDoc + +pprStatsLifeConflict stats graph + = let lifeMap = lifeMapFromSpillCostInfo + $ foldl' plusSpillCostInfo zeroSpillCostInfo + $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] + + scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of + Just (_, l) -> l + Nothing -> 0 + Just node = Color.lookupNode graph r + in parens $ hcat $ punctuate (text ", ") + [ doubleQuotes $ ppr $ Color.nodeId node + , ppr $ sizeUniqSet (Color.nodeConflicts node) + , ppr $ lifetime ]) + $ map Color.nodeId + $ eltsUFM + $ Color.graphMap graph + + in ( text "-- vreg-conflict-lifetime" + $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" + $$ (vcat scatter) + $$ text "\n") + + +-- | Count spill/reload/reg-reg moves. +-- Lets us see how well the register allocator has done. +countSRMs + :: Instruction instr + => LiveCmmDecl statics instr -> (Int, Int, Int) + +countSRMs cmm + = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) + + +countSRM_block + :: Instruction instr + => GenBasicBlock (LiveInstr instr) + -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) + +countSRM_block (BasicBlock i instrs) + = do instrs' <- mapM countSRM_instr instrs + return $ BasicBlock i instrs' + + +countSRM_instr + :: Instruction instr + => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) + +countSRM_instr li + | LiveInstr SPILL{} _ <- li + = do modify $ \(s, r, m) -> (s + 1, r, m) + return li + + | LiveInstr RELOAD{} _ <- li + = do modify $ \(s, r, m) -> (s, r + 1, m) + return li + + | LiveInstr instr _ <- li + , Just _ <- takeRegRegMoveInstr instr + = do modify $ \(s, r, m) -> (s, r, m + 1) + return li + + | otherwise + = return li + + +-- sigh.. +addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) +addSRM (s1, r1, m1) (s2, r2, m2) + = let !s = s1 + s2 + !r = r1 + r2 + !m = m1 + m2 + in (s, r, m) + diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs new file mode 100644 index 00000000..eba2e431 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE BangPatterns, CPP #-} + +module RegAlloc.Graph.TrivColorable ( + trivColorable, +) + +where + +#include "HsVersions.h" + +import RegClass +import Reg + +import GraphBase + +import UniqFM +import FastTypes +import Platform +import Panic + + +-- trivColorable --------------------------------------------------------------- + +-- trivColorable function for the graph coloring allocator +-- +-- This gets hammered by scanGraph during register allocation, +-- so needs to be fairly efficient. +-- +-- NOTE: This only works for arcitectures with just RcInteger and RcDouble +-- (which are disjoint) ie. x86, x86_64 and ppc +-- +-- The number of allocatable regs is hard coded in here so we can do +-- a fast comparison in trivColorable. +-- +-- It's ok if these numbers are _less_ than the actual number of free +-- regs, but they can't be more or the register conflict +-- graph won't color. +-- +-- If the graph doesn't color then the allocator will panic, but it won't +-- generate bad object code or anything nasty like that. +-- +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing +-- the unboxing is too slow for us here. +-- TODO: Is that still true? Could we use allocatableRegsInClass +-- without losing performance now? +-- +-- Look at includes/stg/MachRegs.h to get the numbers. +-- + + +-- Disjoint registers ---------------------------------------------------------- +-- +-- The definition has been unfolded into individual cases for speed. +-- Each architecture has a different register setup, so we use a +-- different regSqueeze function for each. +-- +accSqueeze + :: FastInt + -> FastInt + -> (reg -> FastInt) + -> UniqFM reg + -> FastInt + +accSqueeze count maxCount squeeze ufm = acc count (eltsUFM ufm) + where acc count [] = count + acc count _ | count >=# maxCount = count + acc count (r:rs) = acc (count +# squeeze r) rs + +{- Note [accSqueeze] +~~~~~~~~~~~~~~~~~~~~ +BL 2007/09 +Doing a nice fold over the UniqSet makes trivColorable use +32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs. +Therefore the UniqFM is made non-abstract and we use custom fold. + +MS 2010/04 +When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal +representation any more. But it is imperative that the assSqueeze stops +the folding if the count gets greater or equal to maxCount. We thus convert +UniqFM to a (lazy) list, do the fold and stops if necessary, which was +the most efficient variant tried. Benchmark compiling 10-times SHA1.lhs follows. +(original = previous implementation, folding = fold of the whole UFM, + lazyFold = the current implementation, + hackFold = using internal representation of Data.IntMap) + + original folding hackFold lazyFold + -O -fasm (used everywhere) 31.509s 30.387s 30.791s 30.603s + 100.00% 96.44% 97.72% 97.12% + -fregs-graph 67.938s 74.875s 62.673s 64.679s + 100.00% 110.21% 92.25% 95.20% + -fregs-iterative 89.761s 143.913s 81.075s 86.912s + 100.00% 160.33% 90.32% 96.83% + -fnew-codegen 38.225s 37.142s 37.551s 37.119s + 100.00% 97.17% 98.24% 97.11% + -fnew-codegen -fregs-graph 91.786s 91.51s 87.368s 86.88s + 100.00% 99.70% 95.19% 94.65% + -fnew-codegen -fregs-iterative 206.72s 343.632s 194.694s 208.677s + 100.00% 166.23% 94.18% 100.95% +-} + +trivColorable + :: Platform + -> (RegClass -> VirtualReg -> FastInt) + -> (RegClass -> RealReg -> FastInt) + -> Triv VirtualReg RegClass RealReg + +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions + | let !cALLOCATABLE_REGS_INTEGER + = iUnbox (case platformArch platform of + ArchX86 -> 3 + ArchX86_64 -> 5 + ArchPPC -> 16 + ArchSPARC -> 14 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER + (virtualRegSqueeze RcInteger) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER + (realRegSqueeze RcInteger) + exclusions + + = count3 <# cALLOCATABLE_REGS_INTEGER + +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions + | let !cALLOCATABLE_REGS_FLOAT + = iUnbox (case platformArch platform of + ArchX86 -> 0 + ArchX86_64 -> 0 + ArchPPC -> 0 + ArchSPARC -> 22 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT + (virtualRegSqueeze RcFloat) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT + (realRegSqueeze RcFloat) + exclusions + + = count3 <# cALLOCATABLE_REGS_FLOAT + +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions + | let !cALLOCATABLE_REGS_DOUBLE + = iUnbox (case platformArch platform of + ArchX86 -> 6 + ArchX86_64 -> 0 + ArchPPC -> 26 + ArchSPARC -> 11 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE + (virtualRegSqueeze RcDouble) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE + (realRegSqueeze RcDouble) + exclusions + + = count3 <# cALLOCATABLE_REGS_DOUBLE + +trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions + | let !cALLOCATABLE_REGS_SSE + = iUnbox (case platformArch platform of + ArchX86 -> 8 + ArchX86_64 -> 10 + ArchPPC -> 0 + ArchSPARC -> 0 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM _ _ _ -> panic "trivColorable ArchARM" + ArchARM64 -> panic "trivColorable ArchARM64" + ArchAlpha -> panic "trivColorable ArchAlpha" + ArchMipseb -> panic "trivColorable ArchMipseb" + ArchMipsel -> panic "trivColorable ArchMipsel" + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE + (virtualRegSqueeze RcDoubleSSE) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_SSE + (realRegSqueeze RcDoubleSSE) + exclusions + + = count3 <# cALLOCATABLE_REGS_SSE + + +-- Specification Code ---------------------------------------------------------- +-- +-- The trivColorable function for each particular architecture should +-- implement the following function, but faster. +-- + +{- +trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool +trivColorable classN conflicts exclusions + = let + + acc :: Reg -> (Int, Int) -> (Int, Int) + acc r (cd, cf) + = case regClass r of + RcInteger -> (cd+1, cf) + RcFloat -> (cd, cf+1) + _ -> panic "Regs.trivColorable: reg class not handled" + + tmp = foldUniqSet acc (0, 0) conflicts + (countInt, countFloat) = foldUniqSet acc tmp exclusions + + squeese = worst countInt classN RcInteger + + worst countFloat classN RcFloat + + in squeese < allocatableRegsInClass classN + +-- | Worst case displacement +-- node N of classN has n neighbors of class C. +-- +-- We currently only have RcInteger and RcDouble, which don't conflict at all. +-- This is a bit boring compared to what's in RegArchX86. +-- +worst :: Int -> RegClass -> RegClass -> Int +worst n classN classC + = case classN of + RcInteger + -> case classC of + RcInteger -> min n (allocatableRegsInClass RcInteger) + RcFloat -> 0 + + RcDouble + -> case classC of + RcFloat -> min n (allocatableRegsInClass RcFloat) + RcInteger -> 0 + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: [RegNo] +allocatableRegs + = let isFree i = isFastTrue (freeReg i) + in filter isFree allMachRegNos + + +-- | The number of regs in each class. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. +allocatableRegsInClass :: RegClass -> Int +allocatableRegsInClass cls + = case cls of + RcInteger -> allocatableRegsInteger + RcFloat -> allocatableRegsDouble + +allocatableRegsInteger :: Int +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs + +allocatableRegsFloat :: Int +allocatableRegsFloat + = length $ filter (\r -> regClass r == RcFloat + $ map RealReg allocatableRegs +-} diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs new file mode 100644 index 00000000..d4f124e2 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -0,0 +1,132 @@ + +-- | Put common type definitions here to break recursive module dependencies. + +module RegAlloc.Linear.Base ( + BlockAssignment, + + Loc(..), + regsOfLoc, + + -- for stats + SpillReason(..), + RegAllocStats(..), + + -- the allocator monad + RA_State(..), +) + +where + +import RegAlloc.Linear.StackMap +import RegAlloc.Liveness +import Reg + +import DynFlags +import Outputable +import Unique +import UniqFM +import UniqSupply + + +-- | Used to store the register assignment on entry to a basic block. +-- We use this to handle join points, where multiple branch instructions +-- target a particular label. We have to insert fixup code to make +-- the register assignments from the different sources match up. +-- +type BlockAssignment freeRegs + = BlockMap (freeRegs, RegMap Loc) + + +-- | Where a vreg is currently stored +-- A temporary can be marked as living in both a register and memory +-- (InBoth), for example if it was recently loaded from a spill location. +-- This makes it cheap to spill (no save instruction required), but we +-- have to be careful to turn this into InReg if the value in the +-- register is changed. + +-- This is also useful when a temporary is about to be clobbered. We +-- save it in a spill location, but mark it as InBoth because the current +-- instruction might still want to read it. +-- +data Loc + -- | vreg is in a register + = InReg !RealReg + + -- | vreg is held in a stack slot + | InMem {-# UNPACK #-} !StackSlot + + + -- | vreg is held in both a register and a stack slot + | InBoth !RealReg + {-# UNPACK #-} !StackSlot + deriving (Eq, Show, Ord) + +instance Outputable Loc where + ppr l = text (show l) + + +-- | Get the reg numbers stored in this Loc. +regsOfLoc :: Loc -> [RealReg] +regsOfLoc (InReg r) = [r] +regsOfLoc (InBoth r _) = [r] +regsOfLoc (InMem _) = [] + + +-- | Reasons why instructions might be inserted by the spiller. +-- Used when generating stats for -ddrop-asm-stats. +-- +data SpillReason + -- | vreg was spilled to a slot so we could use its + -- current hreg for another vreg + = SpillAlloc !Unique + + -- | vreg was moved because its hreg was clobbered + | SpillClobber !Unique + + -- | vreg was loaded from a spill slot + | SpillLoad !Unique + + -- | reg-reg move inserted during join to targets + | SpillJoinRR !Unique + + -- | reg-mem move inserted during join to targets + | SpillJoinRM !Unique + + +-- | Used to carry interesting stats out of the register allocator. +data RegAllocStats + = RegAllocStats + { ra_spillInstrs :: UniqFM [Int] } + + +-- | The register allocator state +data RA_State freeRegs + = RA_State + + { + -- | the current mapping from basic blocks to + -- the register assignments at the beginning of that block. + ra_blockassig :: BlockAssignment freeRegs + + -- | free machine registers + , ra_freeregs :: !freeRegs + + -- | assignment of temps to locations + , ra_assig :: RegMap Loc + + -- | current stack delta + , ra_delta :: Int + + -- | free stack slots for spilling + , ra_stack :: StackMap + + -- | unique supply for generating names for join point fixup blocks. + , ra_us :: UniqSupply + + -- | Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + , ra_spills :: [SpillReason] + , ra_DynFlags :: DynFlags } + + diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs new file mode 100644 index 00000000..a1a00ba5 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} + +module RegAlloc.Linear.FreeRegs ( + FR(..), + maxSpillSlots +) + +#include "HsVersions.h" + +where + +import Reg +import RegClass + +import DynFlags +import Panic +import Platform + +-- ----------------------------------------------------------------------------- +-- The free register set +-- This needs to be *efficient* +-- Here's an inefficient 'executable specification' of the FreeRegs data type: +-- +-- type FreeRegs = [RegNo] +-- noFreeRegs = 0 +-- releaseReg n f = if n `elem` f then f else (n : f) +-- initFreeRegs = allocatableRegs +-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f +-- allocateReg f r = filter (/= r) f + +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 + +import qualified PPC.Instr +import qualified SPARC.Instr +import qualified X86.Instr + +class Show freeRegs => FR freeRegs where + frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg] + frInitFreeRegs :: Platform -> freeRegs + frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs + +instance FR X86.FreeRegs where + frAllocateReg = \_ -> X86.allocateReg + frGetFreeRegs = X86.getFreeRegs + frInitFreeRegs = X86.initFreeRegs + frReleaseReg = \_ -> X86.releaseReg + +instance FR X86_64.FreeRegs where + frAllocateReg = \_ -> X86_64.allocateReg + frGetFreeRegs = X86_64.getFreeRegs + frInitFreeRegs = X86_64.initFreeRegs + frReleaseReg = \_ -> X86_64.releaseReg + +instance FR PPC.FreeRegs where + frAllocateReg = \_ -> PPC.allocateReg + frGetFreeRegs = \_ -> PPC.getFreeRegs + frInitFreeRegs = PPC.initFreeRegs + frReleaseReg = \_ -> PPC.releaseReg + +instance FR SPARC.FreeRegs where + frAllocateReg = SPARC.allocateReg + frGetFreeRegs = \_ -> SPARC.getFreeRegs + frInitFreeRegs = SPARC.initFreeRegs + frReleaseReg = SPARC.releaseReg + +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = case platformArch (targetPlatform dflags) of + ArchX86 -> X86.Instr.maxSpillSlots dflags + ArchX86_64 -> X86.Instr.maxSpillSlots dflags + ArchPPC -> PPC.Instr.maxSpillSlots dflags + ArchSPARC -> SPARC.Instr.maxSpillSlots dflags + ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchARM64 -> panic "maxSpillSlots ArchARM64" + ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" + ArchAlpha -> panic "maxSpillSlots ArchAlpha" + ArchMipseb -> panic "maxSpillSlots ArchMipseb" + ArchMipsel -> panic "maxSpillSlots ArchMipsel" + ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" + diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs new file mode 100644 index 00000000..07ff1ca8 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -0,0 +1,357 @@ + +-- | Handles joining of a jump instruction to its targets. + +-- The first time we encounter a jump to a particular basic block, we +-- record the assignment of temporaries. The next time we encounter a +-- jump to the same block, we compare our current assignment to the +-- stored one. They might be different if spilling has occurred in one +-- branch; so some fixup code will be required to match up the assignments. +-- +module RegAlloc.Linear.JoinToTargets (joinToTargets) where + +import RegAlloc.Linear.State +import RegAlloc.Linear.Base +import RegAlloc.Linear.FreeRegs +import RegAlloc.Liveness +import Instruction +import Reg + +import BlockId +import Digraph +import DynFlags +import Outputable +import Unique +import UniqFM +import UniqSet + + +-- | For a jump instruction at the end of a block, generate fixup code so its +-- vregs are in the correct regs for its destination. +-- +joinToTargets + :: (FR freeRegs, Instruction instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. + , instr) -- the original branch + -- instruction, but maybe + -- patched to jump + -- to a fixup block first. + +joinToTargets block_live id instr + + -- we only need to worry about jump instructions. + | not $ isJumpishInstr instr + = return ([], instr) + + | otherwise + = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + +----- +joinToTargets' + :: (FR freeRegs, Instruction instr) + => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + -- that are known to be live on the entry to each block. + + -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. + + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. + + -> [BlockId] -- ^ branch destinations still to consider. + + -> RegM freeRegs ([NatBasicBlock instr], instr) + +-- no more targets to consider. all done. +joinToTargets' _ new_blocks _ instr [] + = return (new_blocks, instr) + +-- handle a branch target. +joinToTargets' block_live new_blocks block_id instr (dest:dests) + = do + -- get the map of where the vregs are stored on entry to each basic block. + block_assig <- getBlockAssigR + + -- get the assignment on entry to the branch instruction. + assig <- getAssigR + + -- adjust the current assignment to remove any vregs that are not live + -- on entry to the destination block. + let Just live_set = mapLookup dest block_live + let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let adjusted_assig = filterUFM_Directly still_live assig + + -- and free up those registers which are now free. + let to_free = + [ r | (reg, loc) <- ufmToList assig + , not (elemUniqSet_Directly reg live_set) + , r <- regsOfLoc loc ] + + case mapLookup dest block_assig of + Nothing + -> joinToTargets_first + block_live new_blocks block_id instr dest dests + block_assig adjusted_assig to_free + + Just (_, dest_assig) + -> joinToTargets_again + block_live new_blocks block_id instr dest dests + adjusted_assig dest_assig + + +-- this is the first time we jumped to this block. +joinToTargets_first :: (FR freeRegs, Instruction instr) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> BlockAssignment freeRegs + -> RegMap Loc + -> [RealReg] + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_first block_live new_blocks block_id instr dest dests + block_assig src_assig + to_free + + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + -- free up the regs that are not live on entry to this block. + freeregs <- getFreeRegsR + let freeregs' = foldr (frReleaseReg platform) freeregs to_free + + -- remember the current assignment on entry to this block. + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + + joinToTargets' block_live new_blocks block_id instr dests + + +-- we've jumped to this block before +joinToTargets_again :: (Instruction instr, FR freeRegs) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> UniqFM Loc + -> UniqFM Loc + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_again + block_live new_blocks block_id instr dest dests + src_assig dest_assig + + -- the assignments already match, no problem. + | ufmToList dest_assig == ufmToList src_assig + = joinToTargets' block_live new_blocks block_id instr dests + + -- assignments don't match, need fixup code + | otherwise + = do + + -- make a graph of what things need to be moved where. + let graph = makeRegMovementGraph src_assig dest_assig + + -- look for cycles in the graph. This can happen if regs need to be swapped. + -- Note that we depend on the fact that this function does a + -- bottom up traversal of the tree-like portions of the graph. + -- + -- eg, if we have + -- R1 -> R2 -> R3 + -- + -- ie move value in R1 to R2 and value in R2 to R3. + -- + -- We need to do the R2 -> R3 move before R1 -> R2. + -- + let sccs = stronglyConnCompFromEdgedVerticesR graph + +{- -- debugging + pprTrace + ("joinToTargets: making fixup code") + (vcat [ text " in block: " <> ppr block_id + , text " jmp instruction: " <> ppr instr + , text " src assignment: " <> ppr src_assig + , text " dest assignment: " <> ppr dest_assig + , text " movement graph: " <> ppr graph + , text " sccs of graph: " <> ppr sccs + , text ""]) + (return ()) +-} + delta <- getDeltaR + fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + let fixUpInstrs = concat fixUpInstrs_ + + -- make a new basic block containing the fixup code. + -- A the end of the current block we will jump to the fixup one, + -- then that will jump to our original destination. + fixup_block_id <- getUniqueR + let block = BasicBlock (mkBlockId fixup_block_id) + $ fixUpInstrs ++ mkJumpInstr dest + +{- pprTrace + ("joinToTargets: fixup code is:") + (vcat [ ppr block + , text ""]) + (return ()) +-} + -- if we didn't need any fixups, then don't include the block + case fixUpInstrs of + [] -> joinToTargets' block_live new_blocks block_id instr dests + + -- patch the original branch instruction so it goes to our + -- fixup block instead. + _ -> let instr' = patchJumpInstr instr + (\bid -> if bid == dest + then mkBlockId fixup_block_id + else bid) -- no change! + + in joinToTargets' block_live (block : new_blocks) block_id instr' dests + + +-- | Construct a graph of register\/spill movements. +-- +-- Cyclic components seem to occur only very rarely. +-- +-- We cut some corners by not handling memory-to-memory moves. +-- This shouldn't happen because every temporary gets its own stack slot. +-- +makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])] +makeRegMovementGraph adjusted_assig dest_assig + = [ node | (vreg, src) <- ufmToList adjusted_assig + -- source reg might not be needed at the dest: + , Just loc <- [lookupUFM_Directly dest_assig vreg] + , node <- expandNode vreg src loc ] + + +-- | Expand out the destination, so InBoth destinations turn into +-- a combination of InReg and InMem. + +-- The InBoth handling is a little tricky here. If the destination is +-- InBoth, then we must ensure that the value ends up in both locations. +-- An InBoth destination must conflict with an InReg or InMem source, so +-- we expand an InBoth destination as necessary. +-- +-- An InBoth source is slightly different: we only care about the register +-- that the source value is in, so that we can move it to the destinations. +-- +expandNode + :: a + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [(a, Loc, [Loc])] + +expandNode vreg loc@(InReg src) (InBoth dst mem) + | src == dst = [(vreg, loc, [InMem mem])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + +expandNode vreg loc@(InMem src) (InBoth dst mem) + | src == mem = [(vreg, loc, [InReg dst])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + +expandNode _ (InBoth _ src) (InMem dst) + | src == dst = [] -- guaranteed to be true + +expandNode _ (InBoth src _) (InReg dst) + | src == dst = [] + +expandNode vreg (InBoth src _) dst + = expandNode vreg (InReg src) dst + +expandNode vreg src dst + | src == dst = [] + | otherwise = [(vreg, src, [dst])] + + +-- | Generate fixup code for a particular component in the move graph +-- This component tells us what values need to be moved to what +-- destinations. We have eliminated any possibility of single-node +-- cycles in expandNode above. +-- +handleComponent + :: Instruction instr + => Int -> instr -> SCC (Unique, Loc, [Loc]) + -> RegM freeRegs [instr] + +-- If the graph is acyclic then we won't get the swapping problem below. +-- In this case we can just do the moves directly, and avoid having to +-- go via a spill slot. +-- +handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove delta vreg src) dsts + + +-- Handle some cyclic moves. +-- This can happen if we have two regs that need to be swapped. +-- eg: +-- vreg source loc dest loc +-- (vreg1, InReg r1, [InReg r2]) +-- (vreg2, InReg r2, [InReg r1]) +-- +-- To avoid needing temp register, we just spill all the source regs, then +-- reaload them into their destination regs. +-- +-- Note that we can not have cycles that involve memory locations as +-- sources as single destination because memory locations (stack slots) +-- are allocated exclusively for a virtual register and therefore can not +-- require a fixup. +-- +handleComponent delta instr + (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest)) + -- dest list may have more than one element, if the reg is also InMem. + = do + -- spill the source into its slot + (instrSpill, slot) + <- spillR (RegReal sreg) vreg + + -- reload into destination reg + instrLoad <- loadR (RegReal dreg) slot + + remainingFixUps <- mapM (handleComponent delta instr) + (stronglyConnCompFromEdgedVerticesR rest) + + -- make sure to do all the reloads after all the spills, + -- so we don't end up clobbering the source values. + return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + +handleComponent _ _ (CyclicSCC _) + = panic "Register Allocator: handleComponent cyclic" + + +-- | Move a vreg between these two locations. +-- +makeMove + :: Instruction instr + => Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove delta vreg src dst + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + case (src, dst) of + (InReg s, InReg d) -> + do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) + (InMem s, InReg d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr dflags (RegReal d) delta s + (InReg s, InMem d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr dflags (RegReal s) delta d + _ -> + -- we don't handle memory to memory moves. + -- they shouldn't happen because we don't share + -- stack slots between vregs. + panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" + ++ show dst ++ ")" + ++ " we don't handle mem->mem moves.") + diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs new file mode 100644 index 00000000..d602d60d --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -0,0 +1,891 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- +-- The register allocator +-- +-- (c) The University of Glasgow 2004 +-- +----------------------------------------------------------------------------- + +{- +The algorithm is roughly: + + 1) Compute strongly connected components of the basic block list. + + 2) Compute liveness (mapping from pseudo register to + point(s) of death?). + + 3) Walk instructions in each basic block. We keep track of + (a) Free real registers (a bitmap?) + (b) Current assignment of temporaries to machine registers and/or + spill slots (call this the "assignment"). + (c) Partial mapping from basic block ids to a virt-to-loc mapping. + When we first encounter a branch to a basic block, + we fill in its entry in this table with the current mapping. + + For each instruction: + (a) For each temporary *read* by the instruction: + If the temporary does not have a real register allocation: + - Allocate a real register from the free list. If + the list is empty: + - Find a temporary to spill. Pick one that is + not used in this instruction (ToDo: not + used for a while...) + - generate a spill instruction + - If the temporary was previously spilled, + generate an instruction to read the temp from its spill loc. + (optimisation: if we can see that a real register is going to + be used soon, then don't use it for allocation). + + (b) For each real register clobbered by this instruction: + If a temporary resides in it, + If the temporary is live after this instruction, + Move the temporary to another (non-clobbered & free) reg, + or spill it to memory. Mark the temporary as residing + in both memory and a register if it was spilled (it might + need to be read by this instruction). + + (ToDo: this is wrong for jump instructions?) + + We do this after step (a), because if we start with + movq v1, %rsi + which is an instruction that clobbers %rsi, if v1 currently resides + in %rsi we want to get + movq %rsi, %freereg + movq %rsi, %rsi -- will disappear + instead of + movq %rsi, %freereg + movq %freereg, %rsi + + (c) Update the current assignment + + (d) If the instruction is a branch: + if the destination block already has a register assignment, + Generate a new block with fixup code and redirect the + jump to the new block. + else, + Update the block id->assignment mapping with the current + assignment. + + (e) Delete all register assignments for temps which are read + (only) and die here. Update the free register list. + + (f) Mark all registers clobbered by this instruction as not free, + and mark temporaries which have been spilled due to clobbering + as in memory (step (a) marks then as in both mem & reg). + + (g) For each temporary *written* by this instruction: + Allocate a real register as for (b), spilling something + else if necessary. + - except when updating the assignment, drop any memory + locations that the temporary was previously in, since + they will be no longer valid after this instruction. + + (h) Delete all register assignments for temps which are + written and die here (there should rarely be any). Update + the free register list. + + (i) Rewrite the instruction with the new mapping. + + (j) For each spilled reg known to be now dead, re-add its stack slot + to the free list. + +-} + +module RegAlloc.Linear.Main ( + regAlloc, + module RegAlloc.Linear.Base, + module RegAlloc.Linear.Stats + ) where + +#include "HsVersions.h" + + +import RegAlloc.Linear.State +import RegAlloc.Linear.Base +import RegAlloc.Linear.StackMap +import RegAlloc.Linear.FreeRegs +import RegAlloc.Linear.Stats +import RegAlloc.Linear.JoinToTargets +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 +import TargetReg +import RegAlloc.Liveness +import Instruction +import Reg + +import BlockId +import Cmm hiding (RegSet) + +import Digraph +import DynFlags +import Unique +import UniqSet +import UniqFM +import UniqSupply +import Outputable +import Platform + +import Data.Maybe +import Data.List +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- Top level of the register allocator + +-- Allocate registers +regAlloc + :: (Outputable instr, Instruction instr) + => DynFlags + -> LiveCmmDecl statics instr + -> UniqSM ( NatCmmDecl statics instr + , Maybe Int -- number of extra stack slots required, + -- beyond maxSpillSlots + , Maybe RegAllocStats) + +regAlloc _ (CmmData sec d) + = return + ( CmmData sec d + , Nothing + , Nothing ) + +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) + , Nothing + , Nothing ) + +regAlloc dflags (CmmProc static lbl live sccs) + | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static + = do + -- do register allocation on each component. + (final_blocks, stats, stack_use) + <- linearRegAlloc dflags entry_ids block_live sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output + let ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + let max_spill_slots = maxSpillSlots dflags + extra_stack + | stack_use > max_spill_slots + = Just (stack_use - max_spill_slots) + | otherwise + = Nothing + + return ( CmmProc info lbl live (ListGraph (first' : rest')) + , extra_stack + , Just stats) + +-- bogus. to make non-exhaustive match warning go away. +regAlloc _ (CmmProc _ _ _ _) + = panic "RegAllocLinear.regAlloc: no match" + + +-- ----------------------------------------------------------------------------- +-- Linear sweep to allocate registers + + +-- | Do register allocation on some basic blocks. +-- But be careful to allocate a block in an SCC only if it has +-- an entry in the block map or it is the first block. +-- +linearRegAlloc + :: (Outputable instr, Instruction instr) + => DynFlags + -> [BlockId] -- ^ entry points + -> BlockMap RegSet + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc dflags entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchARM64 -> panic "linearRegAlloc ArchARM64" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" + ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go f = linearRegAlloc' dflags f entry_ids block_live sccs + platform = targetPlatform dflags + +linearRegAlloc' + :: (FR freeRegs, Outputable instr, Instruction instr) + => DynFlags + -> freeRegs + -> [BlockId] -- ^ entry points + -> BlockMap RegSet -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) + +linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs + = do us <- getUniqueSupplyM + let (_, stack, stats, blocks) = + runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us + $ linearRA_SCCs entry_ids block_live [] sccs + return (blocks, stats, getStackUse stack) + + +linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) + => [BlockId] + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> [SCC (LiveBasicBlock instr)] + -> RegM freeRegs [NatBasicBlock instr] + +linearRA_SCCs _ _ blocksAcc [] + = return $ reverse blocksAcc + +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs entry_ids block_live + ((reverse blocks') ++ blocksAcc) + sccs + +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) + = do + blockss' <- process entry_ids block_live blocks [] (return []) False + linearRA_SCCs entry_ids block_live + (reverse (concat blockss') ++ blocksAcc) + sccs + +{- from John Dias's patch 2008/10/16: + The linear-scan allocator sometimes allocates a block + before allocating one of its predecessors, which could lead to + inconsistent allocations. Make it so a block is only allocated + if a predecessor has set the "incoming" assignments for the block, or + if it's the procedure's entry block. + + BL 2009/02: Careful. If the assignment for a block doesn't get set for + some reason then this function will loop. We should probably do some + more sanity checking to guard against this eventuality. +-} + +process :: (FR freeRegs, Instruction instr, Outputable instr) + => [BlockId] + -> BlockMap RegSet + -> [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + +process _ _ [] [] accum _ + = return $ reverse accum + +process entry_ids block_live [] next_round accum madeProgress + | not madeProgress + + {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. + pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." + ( text "Unreachable blocks:" + $$ vcat (map ppr next_round)) -} + = return $ reverse accum + + | otherwise + = process entry_ids block_live + next_round [] accum False + +process entry_ids block_live (b@(BasicBlock id _) : blocks) + next_round accum madeProgress + = do + block_assig <- getBlockAssigR + + if isJust (mapLookup id block_assig) + || id `elem` entry_ids + then do + b' <- processBlock block_live b + process entry_ids block_live blocks + next_round (b' : accum) True + + else process entry_ids block_live blocks + (b : next_round) accum madeProgress + + +-- | Do register allocation on this basic block +-- +processBlock + :: (FR freeRegs, Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ live regs on entry to each basic block + -> LiveBasicBlock instr -- ^ block to do register allocation on + -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated + +processBlock block_live (BasicBlock id instrs) + = do initBlock id block_live + (instrs', fixups) + <- linearRA block_live [] [] id instrs + return $ BasicBlock id instrs' : fixups + + +-- | Load the freeregs and current reg assignment into the RegM state +-- for the basic block with this BlockId. +initBlock :: FR freeRegs + => BlockId -> BlockMap RegSet -> RegM freeRegs () +initBlock id block_live + = do dflags <- getDynFlags + let platform = targetPlatform dflags + block_assig <- getBlockAssigR + case mapLookup id block_assig of + -- no prior info about this block: we must consider + -- any fixed regs to be allocated, but we can ignore + -- virtual regs (presumably this is part of a loop, + -- and we'll iterate again). The assignment begins + -- empty. + Nothing + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + case mapLookup id block_live of + Nothing -> + setFreeRegsR (frInitFreeRegs platform) + Just live -> + setFreeRegsR $ foldr (frAllocateReg platform) (frInitFreeRegs platform) [ r | RegReal r <- uniqSetToList live ] + setAssigR emptyRegMap + + -- load info about register assignments leading into this block. + Just (freeregs, assig) + -> do setFreeRegsR freeregs + setAssigR assig + + +-- | Do allocation for a sequence of instructions. +linearRA + :: (FR freeRegs, Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. + -> BlockId -- ^ id of the current block, for debugging. + -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. + + -> RegM freeRegs + ( [instr] -- instructions after register allocation + , [NatBasicBlock instr]) -- fresh blocks of fixup code. + + +linearRA _ accInstr accFixup _ [] + = return + ( reverse accInstr -- instrs need to be returned in the correct order. + , accFixup) -- it doesn't matter what order the fixup blocks are returned in. + + +linearRA block_live accInstr accFixups id (instr:instrs) + = do + (accInstr', new_fixups) <- raInsn block_live accInstr id instr + + linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + + +-- | Do allocation for a single instruction. +raInsn + :: (FR freeRegs, Outputable instr, Instruction instr) + => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> BlockId -- ^ the id of the current block, for debugging + -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. + -> RegM freeRegs + ( [instr] -- new instructions + , [NatBasicBlock instr]) -- extra fixup blocks + +raInsn _ new_instrs _ (LiveInstr ii Nothing) + | Just n <- takeDeltaInstr ii + = do setDeltaR n + return (new_instrs, []) + +raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) + | isMetaInstr ii + = return (i : new_instrs, []) + + +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) + = do + assig <- getAssigR + + -- If we have a reg->reg move between virtual registers, where the + -- src register is not live after this instruction, and the dst + -- register does not already have an assignment, + -- and the source register is assigned to a register, not to a spill slot, + -- then we can eliminate the instruction. + -- (we can't eliminate it if the source register is on the stack, because + -- we do not want to use one spill slot for different virtual registers) + case takeRegRegMoveInstr instr of + Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), + isVirtualReg dst, + not (dst `elemUFM` assig), + isRealReg src || isInReg src assig -> do + case src of + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) + -- if src is a fixed reg, then we just map dest to this + -- reg in the assignment. src must be an allocatable reg, + -- otherwise it wouldn't be in r_dying. + _virt -> case lookupUFM assig src of + Nothing -> panic "raInsn" + Just loc -> + setAssigR (addToUFM (delFromUFM assig src) dst loc) + + -- we have eliminated this instruction + {- + freeregs <- getFreeRegsR + assig <- getAssigR + pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) + $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do + -} + return (new_instrs, []) + + _ -> genRaInsn block_live new_instrs id instr + (uniqSetToList $ liveDieRead live) + (uniqSetToList $ liveDieWrite live) + +raInsn _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> ppr instr) + +-- ToDo: what can we do about +-- +-- R1 = x +-- jump I64[x] // [R1] +-- +-- where x is mapped to the same reg as R1. We want to coalesce x and +-- R1, but the register allocator doesn't know whether x will be +-- assigned to again later, in which case x and R1 should be in +-- different registers. Right now we assume the worst, and the +-- assignment to R1 will clobber x, so we'll spill x into another reg, +-- generating another reg->reg move. + + +isInReg :: Reg -> RegMap Loc -> Bool +isInReg src assig | Just (InReg _) <- lookupUFM assig src = True + | otherwise = False + + +genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockMap RegSet + -> [instr] + -> BlockId + -> instr + -> [Reg] + -> [Reg] + -> RegM freeRegs ([instr], [NatBasicBlock instr]) + +genRaInsn block_live new_instrs block_id instr r_dying w_dying = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case regUsageOfInstr platform instr of { RU read written -> + do + let real_written = [ rr | (RegReal rr) <- written ] + let virt_written = [ vr | (RegVirtual vr) <- written ] + + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read = nub [ vr | (RegVirtual vr) <- read ] + + -- debugging +{- freeregs <- getFreeRegsR + assig <- getAssigR + pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform }) trace "genRaInsn" + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do +-} + + -- (a), (b) allocate real regs for all regs read by this instruction. + (r_spills, r_allocd) <- + allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + + -- (c) save any temporaries which will be clobbered by this instruction + clobber_saves <- saveClobberedTemps real_written r_dying + + -- (d) Update block map for new destinations + -- NB. do this before removing dead regs from the assignment, because + -- these dead regs might in fact be live in the jump targets (they're + -- only dead in the code that follows in the current basic block). + (fixup_blocks, adjusted_instr) + <- joinToTargets block_live block_id instr + + -- (e) Delete all register assignments for temps which are read + -- (only) and die here. Update the free register list. + releaseRegs r_dying + + -- (f) Mark regs which are clobbered as unallocatable + clobberRegs real_written + + -- (g) Allocate registers for temporaries *written* (only) + (w_spills, w_allocd) <- + allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + + -- (h) Release registers for temps which are written here and not + -- used again. + releaseRegs w_dying + + let + -- (i) Patch the instruction + patch_map + = listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup + + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y + + + -- (j) free up stack slots for dead spilled regs + -- TODO (can't be bothered right now) + + -- erase reg->reg moves where the source and destination are the same. + -- If the src temp didn't die in this instr but happened to be allocated + -- to the same real reg as the destination, then we can erase the move anyway. + let squashed_instr = case takeRegRegMoveInstr patched_instr of + Just (src, dst) + | src == dst -> [] + _ -> [patched_instr] + + let code = squashed_instr ++ w_spills ++ reverse r_spills + ++ clobber_saves ++ new_instrs + +-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do +-- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do + + return (code, fixup_blocks) + + } + +-- ----------------------------------------------------------------------------- +-- releaseRegs + +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () +releaseRegs regs = do + dflags <- getDynFlags + let platform = targetPlatform dflags + assig <- getAssigR + free <- getFreeRegsR + let loop _ free _ | free `seq` False = undefined + loop assig free [] = do setAssigR assig; setFreeRegsR free; return () + loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig free (r:rs) = + case lookupUFM assig r of + Just (InBoth real _) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (InReg real) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> loop (delFromUFM assig r) free rs + loop assig free regs + + +-- ----------------------------------------------------------------------------- +-- Clobber real registers + +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- + +saveClobberedTemps + :: (Outputable instr, Instruction instr, FR freeRegs) + => [RealReg] -- real registers clobbered by this instruction + -> [Reg] -- registers which are no longer live after this insn + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. + +saveClobberedTemps [] _ + = return [] + +saveClobberedTemps clobbered dying + = do + assig <- getAssigR + let to_spill + = [ (temp,reg) + | (temp, InReg reg) <- ufmToList assig + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs + + where + clobber assig instrs [] + = return (instrs, assig) + + clobber assig instrs ((temp, reg) : rest) + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + freeRegs <- getFreeRegsR + let regclass = targetClassOfRealReg platform reg + freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs + + case filter (`notElem` clobbered) freeRegs_thisClass of + + -- (1) we have a free reg of the right class that isn't + -- clobbered by this instruction; use it to save the + -- clobbered value. + (my_reg : _) -> do + setFreeRegsR (frAllocateReg platform my_reg freeRegs) + + let new_assign = addToUFM assig temp (InReg my_reg) + let instr = mkRegRegMoveInstr platform + (RegReal reg) (RegReal my_reg) + + clobber new_assign (instr : instrs) rest + + -- (2) no free registers: spill the value + [] -> do + (spill, slot) <- spillR (RegReal reg) temp + + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + + let new_assign = addToUFM assig temp (InBoth reg slot) + + clobber new_assign (spill : instrs) rest + + + +-- | Mark all these real regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] + = return () + +clobberRegs clobbered + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + freeregs <- getFreeRegsR + setFreeRegsR $! foldr (frAllocateReg platform) freeregs clobbered + + assig <- getAssigR + setAssigR $! clobber assig (ufmToList assig) + + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest + +-- ----------------------------------------------------------------------------- +-- allocateRegsAndSpill + +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + +-- This function does several things: +-- For each temporary referred to by this instruction, +-- we allocate a real register (spilling another temporary if necessary). +-- We load the temporary up from memory if necessary. +-- We also update the register assignment in the process, and +-- the list of free registers and free stack slots. + +allocateRegsAndSpill + :: (FR freeRegs, Outputable instr, Instruction instr) + => Bool -- True <=> reading (load up spilled regs) + -> [VirtualReg] -- don't push these out + -> [instr] -- spill insns + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM freeRegs ( [instr] , [RealReg]) + +allocateRegsAndSpill _ _ spills alloc [] + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r:rs) + = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- NOTE: if the input to the NCG contains some + -- unreachable blocks with junk code, this panic + -- might be triggered. Make sure you only feed + -- sensible code into the NCG. In CmmPipeline we + -- call removeUnreachableBlocks at the end for this + -- reason. + + | otherwise -> doSpill WriteNew + + +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) + => Bool + -> [VirtualReg] + -> [instr] + -> [RealReg] + -> VirtualReg + -> [VirtualReg] + -> UniqFM Loc + -> SpillLoc + -> RegM freeRegs ([instr], [RealReg]) +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc + = do dflags <- getDynFlags + let platform = targetPlatform dflags + freeRegs <- getFreeRegsR + let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs + + case freeRegs_thisClass of + + -- case (2): we have a free register + (my_reg : _) -> + do spills' <- loadTemp r spill_loc my_reg spills + + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) + setFreeRegsR $ frAllocateReg platform my_reg freeRegs + + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let keep' = map getUnique keep + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp r spill_loc my_reg spills + let assig1 = addToUFM assig temp (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + + setAssigR assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + setAssigR assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp r spill_loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> text (show $ ufmToList assig) + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ] + + result + + +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). +loadTemp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp + -> RealReg -- the hreg to load the temp into + -> [instr] + -> RegM freeRegs [instr] + +loadTemp vreg (ReadMem slot) hreg spills + = do + insn <- loadR (RegReal hreg) slot + recordSpill (SpillLoad $ getUnique vreg) + return $ {- COMMENT (fsLit "spill load") : -} insn : spills + +loadTemp _ _ _ spills = + return spills + diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs new file mode 100644 index 00000000..b76fe79d --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -0,0 +1,60 @@ +-- | Free regs map for PowerPC +module RegAlloc.Linear.PPC.FreeRegs +where + +import PPC.Regs +import RegClass +import Reg + +import Outputable +import Platform + +import Data.Word +import Data.Bits +-- import Data.List + +-- The PowerPC has 32 integer and 32 floating point registers. +-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much +-- better. +-- Note that when getFreeRegs scans for free registers, it starts at register +-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered +-- registers are callee-saves, while the lower regs are caller-saves, so it +-- makes sense to start at the high end. +-- Apart from that, the code does nothing PowerPC-specific, so feel free to +-- add your favourite platform to the #if (if you have 64 registers but only +-- 32-bit words). + +data FreeRegs = FreeRegs !Word32 !Word32 + deriving( Show ) -- The Show is used in an ASSERT + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f + +releaseReg _ _ + = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform) + +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs g f) + | RcDouble <- cls = go f (0x80000000) 63 + | RcInteger <- cls = go g (0x80000000) 31 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) + where + go _ 0 _ = [] + go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1) + | otherwise = go x (m `shiftR` 1) $! i-1 + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f + +allocateReg _ _ + = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs new file mode 100644 index 00000000..6b6e67c6 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -0,0 +1,187 @@ + +-- | Free regs map for SPARC +module RegAlloc.Linear.SPARC.FreeRegs +where + +import SPARC.Regs +import RegClass +import Reg + +import CodeGen.Platform +import Outputable +import Platform +import FastBool + +import Data.Word +import Data.Bits +-- import Data.List + + +-------------------------------------------------------------------------------- +-- SPARC is like PPC, except for twinning of floating point regs. +-- When we allocate a double reg we must take an even numbered +-- float reg, as well as the one after it. + + +-- Holds bitmaps showing what registers are currently allocated. +-- The float and double reg bitmaps overlap, but we only alloc +-- float regs into the float map, and double regs into the double map. +-- +-- Free regs have a bit set in the corresponding bitmap. +-- +data FreeRegs + = FreeRegs + !Word32 -- int reg bitmap regs 0..31 + !Word32 -- float reg bitmap regs 32..63 + !Word32 -- double reg bitmap regs 32..63 + +instance Show FreeRegs where + show = showFreeRegs + +-- | A reg map where no regs are free to be allocated. +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 0 + + +-- | The initial set of free regs. +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr (releaseReg platform) noFreeRegs allocatableRegs + + +-- | Get all the free registers of this class. +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs cls (FreeRegs g f d) + | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 + | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 + | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) + where + go _ _ 0 _ + = [] + + go step bitmap mask ix + | bitmap .&. mask /= 0 + = ix : (go step bitmap (mask `shiftL` step) $! ix + step) + + | otherwise + = go step bitmap (mask `shiftL` step) $! ix + step + + +-- | Grab a register. +allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +allocateReg platform + reg@(RealRegSingle r) + (FreeRegs g f d) + + -- can't allocate free regs + | not $ isFastTrue (freeReg platform r) + = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) + + -- a general purpose reg + | r <= 31 + = let mask = complement (bitMask r) + in FreeRegs + (g .&. mask) + f + d + + -- a float reg + | r >= 32, r <= 63 + = let mask = complement (bitMask (r - 32)) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then complement (bitMask (r - 32)) + else complement (bitMask (r - 32 - 1)) + in FreeRegs + g + (f .&. mask) + (d .&. maskLow) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + +allocateReg _ + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = complement (bitMask (r1 - 32)) + mask2 = complement (bitMask (r2 - 32)) + in + FreeRegs + g + ((f .&. mask1) .&. mask2) + (d .&. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + + + +-- | Release a register from allocation. +-- The register liveness information says that most regs die after a C call, +-- but we still don't want to allocate to some of them. +-- +releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs +releaseReg platform + reg@(RealRegSingle r) + regs@(FreeRegs g f d) + + -- don't release pinned reg + | not $ isFastTrue (freeReg platform r) + = regs + + -- a general purpose reg + | r <= 31 + = let mask = bitMask r + in FreeRegs (g .|. mask) f d + + -- a float reg + | r >= 32, r <= 63 + = let mask = bitMask (r - 32) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then bitMask (r - 32) + else bitMask (r - 32 - 1) + in FreeRegs + g + (f .|. mask) + (d .|. maskLow) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + +releaseReg _ + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = bitMask (r1 - 32) + mask2 = bitMask (r2 - 32) + in + FreeRegs + g + ((f .|. mask1) .|. mask2) + (d .|. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + + + +bitMask :: Int -> Word32 +bitMask n = 1 `shiftL` n + + +showFreeRegs :: FreeRegs -> String +showFreeRegs regs + = "FreeRegs\n" + ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" + ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" + ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" + diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs new file mode 100644 index 00000000..85ea6771 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -0,0 +1,59 @@ + +-- | The assignment of virtual registers to stack slots + +-- We have lots of stack slots. Memory-to-memory moves are a pain on most +-- architectures. Therefore, we avoid having to generate memory-to-memory moves +-- by simply giving every virtual register its own stack slot. + +-- The StackMap stack map keeps track of virtual register - stack slot +-- associations and of which stack slots are still free. Once it has been +-- associated, a stack slot is never "freed" or removed from the StackMap again, +-- it remains associated until we are done with the current CmmProc. +-- +module RegAlloc.Linear.StackMap ( + StackSlot, + StackMap(..), + emptyStackMap, + getStackSlotFor, + getStackUse +) + +where + +import DynFlags +import UniqFM +import Unique + + +-- | Identifier for a stack slot. +type StackSlot = Int + +data StackMap + = StackMap + { -- | The slots that are still available to be allocated. + stackMapNextFreeSlot :: !Int + + -- | Assignment of vregs to stack slots. + , stackMapAssignment :: UniqFM StackSlot } + + +-- | An empty stack map, with all slots available. +emptyStackMap :: DynFlags -> StackMap +emptyStackMap _ = StackMap 0 emptyUFM + + +-- | If this vreg unique already has a stack assignment then return the slot number, +-- otherwise allocate a new slot, and update the map. +-- +getStackSlotFor :: StackMap -> Unique -> (StackMap, Int) + +getStackSlotFor fs@(StackMap _ reserved) reg + | Just slot <- lookupUFM reserved reg = (fs, slot) + +getStackSlotFor (StackMap freeSlot reserved) reg = + (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot) + +-- | Return the number of stack slots that were allocated +getStackUse :: StackMap -> Int +getStackUse (StackMap freeSlot _) = freeSlot + diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs new file mode 100644 index 00000000..287bdc65 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +-- | State monad for the linear register allocator. + +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. + +module RegAlloc.Linear.State ( + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + + recordSpill +) +where + +import RegAlloc.Linear.Stats +import RegAlloc.Linear.StackMap +import RegAlloc.Linear.Base +import RegAlloc.Liveness +import Instruction +import Reg + +import DynFlags +import Unique +import UniqSupply + +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +-- | The register allocator monad type. +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } + +instance Functor (RegM freeRegs) where + fmap = liftM + +instance Applicative (RegM freeRegs) where + pure = return + (<*>) = ap + +instance Monad (RegM freeRegs) where + m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } + return a = RegM $ \s -> (# s, a #) + +instance HasDynFlags (RegM a) where + getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #) + + +-- | Run a computation in the RegM register allocator monad. +runR :: DynFlags + -> BlockAssignment freeRegs + -> freeRegs + -> RegMap Loc + -> StackMap + -> UniqSupply + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) + +runR dflags block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] + , ra_DynFlags = dflags }) + of + (# state'@RA_State + { ra_blockassig = block_assig + , ra_stack = stack' } + , returned_thing #) + + -> (block_assig, stack', makeRAStats state', returned_thing) + + +-- | Make register allocator stats from its final state. +makeRAStats :: RA_State freeRegs -> RegAllocStats +makeRAStats state + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) } + + +spillR :: Instruction instr + => Reg -> Unique -> RegM freeRegs (instr, Int) + +spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> + let dflags = ra_DynFlags s + (stack',slot) = getStackSlotFor stack temp + instr = mkSpillInstr dflags reg delta slot + in + (# s{ra_stack=stack'}, (instr,slot) #) + + +loadR :: Instruction instr + => Reg -> Int -> RegM freeRegs instr + +loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + let dflags = ra_DynFlags s + in (# s, mkLoadInstr dflags reg delta slot #) + +getFreeRegsR :: RegM freeRegs freeRegs +getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> + (# s, freeregs #) + +setFreeRegsR :: freeRegs -> RegM freeRegs () +setFreeRegsR regs = RegM $ \ s -> + (# s{ra_freeregs = regs}, () #) + +getAssigR :: RegM freeRegs (RegMap Loc) +getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> + (# s, assig #) + +setAssigR :: RegMap Loc -> RegM freeRegs () +setAssigR assig = RegM $ \ s -> + (# s{ra_assig=assig}, () #) + +getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) +getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> + (# s, assig #) + +setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () +setBlockAssigR assig = RegM $ \ s -> + (# s{ra_blockassig = assig}, () #) + +setDeltaR :: Int -> RegM freeRegs () +setDeltaR n = RegM $ \ s -> + (# s{ra_delta = n}, () #) + +getDeltaR :: RegM freeRegs Int +getDeltaR = RegM $ \s -> (# s, ra_delta s #) + +getUniqueR :: RegM freeRegs Unique +getUniqueR = RegM $ \s -> + case takeUniqFromSupply (ra_us s) of + (uniq, us) -> (# s{ra_us = us}, uniq #) + + +-- | Record that a spill instruction was inserted, for profiling. +recordSpill :: SpillReason -> RegM freeRegs () +recordSpill spill + = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs new file mode 100644 index 00000000..83f5fbc9 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -0,0 +1,86 @@ +module RegAlloc.Linear.Stats ( + binSpillReasons, + countRegRegMovesNat, + pprStats +) + +where + +import RegAlloc.Linear.Base +import RegAlloc.Liveness +import Instruction + +import UniqFM +import Outputable + +import Data.List +import State + +-- | Build a map of how many times each reg was alloced, clobbered, loaded etc. +binSpillReasons + :: [SpillReason] -> UniqFM [Int] + +binSpillReasons reasons + = addListToUFM_C + (zipWith (+)) + emptyUFM + (map (\reason -> case reason of + SpillAlloc r -> (r, [1, 0, 0, 0, 0]) + SpillClobber r -> (r, [0, 1, 0, 0, 0]) + SpillLoad r -> (r, [0, 0, 1, 0, 0]) + SpillJoinRR r -> (r, [0, 0, 0, 1, 0]) + SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons) + + +-- | Count reg-reg moves remaining in this code. +countRegRegMovesNat + :: Instruction instr + => NatCmmDecl statics instr -> Int + +countRegRegMovesNat cmm + = execState (mapGenBlockTopM countBlock cmm) 0 + where + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs + return b + + countInstr instr + | Just _ <- takeRegRegMoveInstr instr + = do modify (+ 1) + return instr + + | otherwise + = return instr + + +-- | Pretty print some RegAllocStats +pprStats + :: Instruction instr + => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc + +pprStats code statss + = let -- sum up all the instrs inserted by the spiller + spills = foldl' (plusUFM_C (zipWith (+))) + emptyUFM + $ map ra_spillInstrs statss + + spillTotals = foldl' (zipWith (+)) + [0, 0, 0, 0, 0] + $ eltsUFM spills + + -- count how many reg-reg-moves remain in the code + moves = sum $ map countRegRegMovesNat code + + pprSpill (reg, spills) + = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills)) + + in ( text "-- spills-added-total" + $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)" + $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves]))) + $$ text "" + $$ text "-- spills-added" + $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)" + $$ (vcat $ map pprSpill + $ ufmToList spills) + $$ text "") + diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs new file mode 100644 index 00000000..0fcd6581 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -0,0 +1,51 @@ + +-- | Free regs map for i386 +module RegAlloc.Linear.X86.FreeRegs +where + +import X86.Regs +import RegClass +import Reg +import Panic +import Platform + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word32 + deriving Show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr releaseReg noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" + diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs new file mode 100644 index 00000000..c04fce96 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs @@ -0,0 +1,52 @@ + +-- | Free regs map for x86_64 +module RegAlloc.Linear.X86_64.FreeRegs +where + +import X86.Regs +import RegClass +import Reg +import Panic +import Platform + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word64 + deriving Show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr releaseReg noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" + + diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs new file mode 100644 index 00000000..167197d7 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -0,0 +1,999 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- The register liveness determinator +-- +-- (c) The University of Glasgow 2004-2013 +-- +----------------------------------------------------------------------------- + +module RegAlloc.Liveness ( + RegSet, + RegMap, emptyRegMap, + BlockMap, emptyBlockMap, + LiveCmmDecl, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + natCmmTopToLive + ) where +import Reg +import Instruction + +import BlockId +import Cmm hiding (RegSet) +import PprCmm() + +import Digraph +import DynFlags +import MonadUtils +import Outputable +import Platform +import UniqSet +import UniqFM +import UniqSupply +import Bag +import State +import FastString + +import Data.List +import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map + +----------------------------------------------------------------------------- +type RegSet = UniqSet Reg + +type RegMap a = UniqFM a + +emptyRegMap :: UniqFM a +emptyRegMap = emptyUFM + +type BlockMap a = BlockEnv a + + +-- | A top level thing which carries liveness information. +type LiveCmmDecl statics instr + = GenCmmDecl + statics + LiveInfo + [SCC (LiveBasicBlock instr)] + + +-- | The register allocator also wants to use SPILL/RELOAD meta instructions, +-- so we'll keep those here. +data InstrSR instr + -- | A real machine instruction + = Instr instr + + -- | spill this reg to a stack slot + | SPILL Reg Int + + -- | reload this reg from a stack slot + | RELOAD Int Reg + +instance Instruction instr => Instruction (InstrSR instr) where + regUsageOfInstr platform i + = case i of + Instr instr -> regUsageOfInstr platform instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] + + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) + + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False + + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] + + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i + + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing + + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False + + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) + + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) + + mkStackAllocInstr platform amount = + Instr (mkStackAllocInstr platform amount) + + mkStackDeallocInstr platform amount = + Instr (mkStackDeallocInstr platform amount) + + +-- | An instruction with liveness information. +data LiveInstr instr + = LiveInstr (InstrSR instr) (Maybe Liveness) + +-- | Liveness information. +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). + +data Liveness + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + + +-- | Stash regs live on entry to each basic block in the info part of the cmm code. +data LiveInfo + = LiveInfo + (BlockEnv CmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block + + +-- | A basic block with liveness information. +type LiveBasicBlock instr + = GenBasicBlock (LiveInstr instr) + + +instance Outputable instr + => Outputable (InstrSR instr) where + + ppr (Instr realInstr) + = ppr realInstr + + ppr (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + + ppr (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance Outputable instr + => Outputable (LiveInstr instr) where + + ppr (LiveInstr instr Nothing) + = ppr instr + + ppr (LiveInstr instr (Just live)) + = ppr instr + $$ (nest 8 + $ vcat + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) + +instance Outputable LiveInfo where + ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) + = (ppr mb_static) + $$ text "# entryIds = " <> ppr entryIds + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + + + +-- | map a function across all the basic blocks in this code +-- +mapBlockTop + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +mapBlockTop f cmm + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +-- +mapBlockTopM + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr) + +mapBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapBlockTopM f (CmmProc header label live sccs) + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label live sccs' + +mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' + +mapSCCM f (CyclicSCC xs) + = do xs' <- mapM f xs + return $ CyclicSCC xs' + + +-- map a function across all the basic blocks in this code +mapGenBlockTop + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)) + +mapGenBlockTop f cmm + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + + +-- | map a function across all the basic blocks in this code (monadic version) +mapGenBlockTopM + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))) + +mapGenBlockTopM _ cmm@(CmmData{}) + = return cmm + +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) + = do blocks' <- mapM f blocks + return $ CmmProc header label live (ListGraph blocks') + + +-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. +-- +slurpConflicts + :: Instruction instr + => LiveCmmDecl statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) + +slurpConflicts live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ _ sccs) + = foldl' (slurpSCC info) rs sccs + + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b + + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs + + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) + + | otherwise + = panic "Liveness.slurpConflicts: bad block" + + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) + + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis + + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) + + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) + + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans + + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis + + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis + + +-- | For spill\/reloads +-- +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 +-- +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- +-- +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmDecl statics instr + -> Bag (Reg, Reg) + +slurpReloadCoalesce live + = slurpCmm emptyBag live + + where + slurpCmm :: Bag (Reg, Reg) + -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] + -> Bag (Reg, Reg) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ _ sccs) + = slurpComp cs (flattenSCCs sccs) + + slurpComp :: Bag (Reg, Reg) + -> [LiveBasicBlock instr] + -> Bag (Reg, Reg) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) + + slurpCompM :: [LiveBasicBlock instr] + -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks + + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks + + slurpBlock :: Bool -> LiveBasicBlock instr + -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge between the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] + + +-- | Strip away liveness information, yielding NatCmmDecl +stripLive + :: (Outputable statics, Outputable instr, Instruction instr) + => DynFlags + -> LiveCmmDecl statics instr + -> NatCmmDecl statics instr + +stripLive dflags live + = stripCmm live + + where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) + => LiveCmmDecl statics instr -> NatCmmDecl statics instr + stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) + = let final_blocks = flattenSCCs sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + in CmmProc info label live + (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') + + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + stripCmm (CmmProc (LiveInfo info [] _ _) label live []) + = CmmProc info label live (ListGraph []) + + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) + +-- | Strip away liveness information from a basic block, +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. + +stripLiveBlock + :: Instruction instr + => DynFlags + -> LiveBasicBlock instr + -> NatBasicBlock instr + +stripLiveBlock dflags (BasicBlock i lis) + = BasicBlock i instrs' + + where (instrs', _) + = runState (spillNat [] lis) 0 + + spillNat acc [] + = return (reverse acc) + + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr dflags reg delta slot : acc) instrs + + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr dflags reg delta slot : acc) instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs + + +-- | Erase Delta instructions. + +eraseDeltasLive + :: Instruction instr + => LiveCmmDecl statics instr + -> LiveCmmDecl statics instr + +eraseDeltasLive cmm + = mapBlockTop eraseBlock cmm + where + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis + + +-- | Patch the registers in this code according to this register mapping. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. +patchEraseLive + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr + +patchEraseLive patchF cmm + = patchCmm cmm + where + patchCmm cmm@CmmData{} = cmm + + patchCmm (CmmProc info label live sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap + + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label live $ map patchSCC sccs + + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis + + patchInstrs [] = [] + patchInstrs (li : lis) + + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis + + | otherwise + = li' : patchInstrs lis + + where li' = patchRegsLiveInstr patchF li + + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True + + -- destination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True + + | otherwise = False + + +-- | Patch registers in this LiveInstr, including the liveness information. +-- +patchRegsLiveInstr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr + +patchRegsLiveInstr patchF li + = case li of + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live + , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live + , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) + + +-------------------------------------------------------------------------------- +-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information + +natCmmTopToLive + :: Instruction instr + => NatCmmDecl statics instr + -> LiveCmmDecl statics instr + +natCmmTopToLive (CmmData i d) + = CmmData i d + +natCmmTopToLive (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info [] Nothing Map.empty) lbl live [] + +natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) + = let first_id = blockId first + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids + entry_ids = filter (/= first_id) all_entry_ids + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + + in CmmProc (LiveInfo info (first_id : entry_ids) Nothing Map.empty) + lbl live sccsLive + + +-- +-- Compute the liveness graph of the set of basic blocks. Important: +-- we also discard any unreachable code here, starting from the entry +-- points (the first block in the list, and any blocks with info +-- tables). Unreachable code arises when code blocks are orphaned in +-- earlier optimisation passes, and may confuse the register allocator +-- by referring to registers that are not initialised. It's easy to +-- discard the unreachable code as part of the SCC pass, so that's +-- exactly what we do. (#7574) +-- +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [BlockId] + -> [SCC (NatBasicBlock instr)] + +sccBlocks blocks entries = map (fmap get_node) sccs + where + -- nodes :: [(NatBasicBlock instr, Unique, [Unique])] + nodes = [ (block, id, getOutEdges instrs) + | block@(BasicBlock id instrs) <- blocks ] + + g1 = graphFromEdgedVertices nodes + + reachable :: BlockSet + reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ] + + g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes + , id `setMember` reachable ] + + sccs = stronglyConnCompG g2 + + get_node (n, _, _) = n + + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs + + -- This is truly ugly, but I don't see a good alternative. + -- Digraph just has the wrong API. We want to identify nodes + -- by their keys (BlockId), but Digraph requires the whole + -- node: (NatBasicBlock, BlockId, [BlockId]). This takes + -- advantage of the fact that Digraph only looks at the key, + -- even though it asks for the whole triple. + roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ] + + + +-------------------------------------------------------------------------------- +-- Annotate code with register liveness information +-- +regLiveness + :: (Outputable instr, Instruction instr) + => Platform + -> LiveCmmDecl statics instr + -> UniqSM (LiveCmmDecl statics instr) + +regLiveness _ (CmmData i d) + = return $ CmmData i d + +regLiveness _ (CmmProc info lbl live []) + | LiveInfo static mFirst _ _ <- info + = return $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl live [] + +regLiveness platform (CmmProc info lbl live sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs + + in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl live ann_sccs + + +-- ----------------------------------------------------------------------------- +-- | Check ordering of Blocks +-- The computeLiveness function requires SCCs to be in reverse +-- dependent order. If they're not the liveness information will be +-- wrong, and we'll get a bad allocation. Better to check for this +-- precondition explicitly or some other poor sucker will waste a +-- day staring at bad assembly code.. +-- +checkIsReverseDependent + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + +checkIsReverseDependent sccs' + = go emptyUniqSet sccs' + + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] + + +-- | If we've compute liveness info for this code already we have to reverse +-- the SCCs in each top to get them back to the right order so we can do it again. +reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr +reverseBlocksInTops top + = case top of + CmmData{} -> top + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) + + +-- | Computing liveness +-- +-- On entry, the SCCs must be in "reverse" order: later blocks may transfer +-- control to earlier ones only, else `panic`. +-- +-- The SCCs returned are in the *opposite* order, which is exactly what we +-- want for the next pass. +-- +computeLiveness + :: (Outputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annontated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs + = case checkIsReverseDependent sccs of + Nothing -> livenessSCCs platform emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , ppr sccs]) + +livenessSCCs + :: Instruction instr + => Platform + -> BlockMap RegSet + -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] + -> ( [SCC (LiveBasicBlock instr)] + , BlockMap RegSet) + +livenessSCCs _ blockmap done [] + = (done, blockmap) + +livenessSCCs platform blockmap done (AcyclicSCC block : sccs) + = let (blockmap', block') = livenessBlock platform blockmap block + in livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs + +livenessSCCs platform blockmap done + (CyclicSCC blocks : sccs) = + livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs + where (blockmap', blocks') + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks + + iterateUntilUnchanged + :: (a -> b -> (a,c)) -> (a -> a -> Bool) + -> a -> b + -> (a,c) + + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") + + + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) + + linearLiveness = mapAccumL (livenessBlock platform) + + -- probably the least efficient way to compare two + -- BlockMaps for equality. + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, uniqSetToList elt) + + + +-- | Annotate a basic block with register liveness information. +-- +livenessBlock + :: Instruction instr + => Platform + -> BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) + +livenessBlock platform blockmap (BasicBlock block_id instrs) + = let + (regsLiveOnEntry, instrs1) + = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap + + instrs2 = livenessForward platform regsLiveOnEntry instrs1 + + output = BasicBlock block_id instrs2 + + in ( blockmap', output) + +-- | Calculate liveness going forwards, +-- filling in when regs are born + +livenessForward + :: Instruction instr + => Platform + -> RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] + +livenessForward _ _ [] = [] +livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) + | Nothing <- mLive + = li : livenessForward platform rsLiveEntry lis + + | Just live <- mLive + , RU _ written <- regUsageOfInstr platform instr + = let + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) + + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward platform rsLiveNext lis + +livenessForward _ _ _ = panic "RegLiveness.livenessForward: no match" + + +-- | Calculate liveness going backwards, +-- filling in when regs die, and what regs are live across each instruction + +livenessBack + :: Instruction instr + => Platform + -> RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) + +livenessBack _ liveregs _ done [] = (liveregs, done) + +livenessBack platform liveregs blockmap acc (instr : instrs) + = let (liveregs', instr') = liveness1 platform liveregs blockmap instr + in livenessBack platform liveregs' blockmap (instr' : acc) instrs + + +-- don't bother tagging comments or deltas with liveness +liveness1 + :: Instruction instr + => Platform + -> RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) + +liveness1 _ liveregs _ (LiveInstr instr _) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) + +liveness1 platform liveregs blockmap (LiveInstr instr _) + + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + !(RU read written) = regUsageOfInstr platform instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target + = case mapLookup target blockmap of + Just ra -> ra + Nothing -> emptyRegMap + + live_from_branch = unionManyUniqSets (map targetLiveRegs targets) + + liveregs_br = liveregs1 `unionUniqSets` live_from_branch + + -- registers that are live only in the branch targets should + -- be listed as dying here. + live_branch_only = live_from_branch `minusUniqSet` liveregs + r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets` + live_branch_only) + + diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs new file mode 100644 index 00000000..0c793173 --- /dev/null +++ b/compiler/nativeGen/RegClass.hs @@ -0,0 +1,33 @@ +-- | An architecture independent description of a register's class. +module RegClass + ( RegClass (..) ) + +where + +import Outputable +import Unique + + +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangable. +-- +data RegClass + = RcInteger + | RcFloat + | RcDouble + | RcDoubleSSE -- x86 only: the SSE regs are a separate class + deriving Eq + + +instance Uniquable RegClass where + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 + getUnique RcDoubleSSE = mkRegClassUnique 3 + +instance Outputable RegClass where + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" + ppr RcDoubleSSE = Outputable.text "S" diff --git a/compiler/nativeGen/SPARC/AddrMode.hs b/compiler/nativeGen/SPARC/AddrMode.hs new file mode 100644 index 00000000..bf4d4800 --- /dev/null +++ b/compiler/nativeGen/SPARC/AddrMode.hs @@ -0,0 +1,42 @@ + +module SPARC.AddrMode ( + AddrMode(..), + addrOffset +) + +where + +import SPARC.Imm +import SPARC.Base +import Reg + +-- addressing modes ------------------------------------------------------------ + +-- | Represents a memory address in an instruction. +-- Being a RISC machine, the SPARC addressing modes are very regular. +-- +data AddrMode + = AddrRegReg Reg Reg -- addr = r1 + r2 + | AddrRegImm Reg Imm -- addr = r1 + imm + + +-- | Add an integer offset to the address in an AddrMode. +-- +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + AddrRegImm r (ImmInt n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + AddrRegReg r (RegReal (RealRegSingle 0)) + | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) + | otherwise -> Nothing + + _ -> Nothing diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs new file mode 100644 index 00000000..96fb5e77 --- /dev/null +++ b/compiler/nativeGen/SPARC/Base.hs @@ -0,0 +1,75 @@ + +-- | Bits and pieces on the bottom of the module dependency tree. +-- Also import the required constants, so we know what we're using. +-- +-- In the interests of cross-compilation, we want to free ourselves +-- from the autoconf generated modules like main/Constants + +module SPARC.Base ( + wordLength, + wordLengthInBits, + spillAreaLength, + spillSlotSize, + extraStackArgsHere, + fits13Bits, + is32BitInteger, + largeOffsetError +) + +where + +import DynFlags +import Panic + +import Data.Int + + +-- On 32 bit SPARC, pointers are 32 bits. +wordLength :: Int +wordLength = 4 + +wordLengthInBits :: Int +wordLengthInBits + = wordLength * 8 + +-- Size of the available spill area +spillAreaLength :: DynFlags -> Int +spillAreaLength + = rESERVED_C_STACK_BYTES + +-- | We need 8 bytes because our largest registers are 64 bit. +spillSlotSize :: Int +spillSlotSize = 8 + + +-- | We (allegedly) put the first six C-call arguments in registers; +-- where do we start putting the rest of them? +extraStackArgsHere :: Int +extraStackArgsHere = 23 + + +{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} +-- | Check whether an offset is representable with 13 bits. +fits13Bits :: Integral a => a -> Bool +fits13Bits x = x >= -4096 && x < 4096 + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i + = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Sadness. +largeOffsetError :: (Integral a, Show a) => a -> b +largeOffsetError i + = panic ("ERROR: SPARC native-code generator cannot handle large offset (" + ++ show i ++ ");\nprobably because of large constant data structures;" ++ + "\nworkaround: use -fllvm on this module.\n") + + diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs new file mode 100644 index 00000000..bba849da --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -0,0 +1,679 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2013 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GADTs #-} +module SPARC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" +#include "../includes/MachDeps.h" + +-- NCG stuff: +import SPARC.Base +import SPARC.CodeGen.Sanity +import SPARC.CodeGen.Amode +import SPARC.CodeGen.CondCode +import SPARC.CodeGen.Gen64 +import SPARC.CodeGen.Gen32 +import SPARC.CodeGen.Base +import SPARC.Ppr () +import SPARC.Instr +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Regs +import SPARC.Stack +import Instruction +import Size +import NCGMonad + +-- Our intermediate code: +import BlockId +import Cmm +import CmmUtils +import Hoopl +import PIC +import Reg +import CLabel +import CPrim + +-- The rest: +import BasicTypes +import DynFlags +import FastString +import OrdList +import Outputable +import Platform +import Unique + +import Control.Monad ( mapAndUnzipM ) + +-- | Top level code generation +cmmTopCodeGen :: RawCmmDecl + -> NatM [NatCmmDecl CmmStatics Instr] + +cmmTopCodeGen (CmmProc info lab live graph) + = do let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec dat] -- no translation, we just use CmmStatic + + +-- | Do code generation on a single block of CMM code. +-- code generation may introduce new basic block boundaries, which +-- are indicated by the NEWBLOCK instruction. We must split up the +-- instruction stream into basic blocks again. Also, we extract +-- LDATAs here too. +basicBlockCodeGen :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl CmmStatics Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs + let + (top,other_blocks,statics) + = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + + -- do intra-block sanity checking + blocksChecked + = map (checkBlock block) + $ BasicBlock id top : other_blocks + + return (blocksChecked, statics) + + +-- | Convert some Cmm statements to SPARC instructions. +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + dflags <- getDynFlags + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode size reg src + | isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType dflags reg + size = cmmTypeSize ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode size addr src + | isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType dflags src + size = cmmTypeSize ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> do dflags <- getDynFlags + genSwitch dflags arg ids + CmmCall { cml_target = arg } -> genJump arg + + _ + -> panic "stmtToInstrs: statement should have been cps'd away" + + +{- +Now, given a tree (the argument to an CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) + + + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- getAmode addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + + +assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_IntCode _ reg src = do + dflags <- getDynFlags + r <- getRegister src + let dst = getRegisterReg (targetPlatform dflags) reg + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst + + + +-- Floating point assignment to memory +assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_FltCode pk addr src = do + dflags <- getDynFlags + Amode dst__2 code1 <- getAmode addr + (src__2, code2) <- getSomeReg src + tmp1 <- getNewRegNat pk + let + pk__2 = cmmExprType dflags src + code__2 = code1 `appOL` code2 `appOL` + if sizeToWidth pk == typeWidth pk__2 + then unitOL (ST pk src__2 dst__2) + else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 + , ST pk tmp1 dst__2] + return code__2 + +-- Floating point assignment to a register/temporary +assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_FltCode pk dstCmmReg srcCmmExpr = do + dflags <- getDynFlags + let platform = targetPlatform dflags + srcRegister <- getRegister srcCmmExpr + let dstReg = getRegisterReg platform dstCmmReg + + return $ case srcRegister of + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg + + + + +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock + +genJump (CmmLit (CmmLabel lbl)) + = return (toOL [CALL (Left target) 0 True, NOP]) + where + target = ImmCLbl lbl + +genJump tree + = do + (target, code) <- getSomeReg tree + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +SPARC: First, we have to ensure that the condition codes are set +according to the supplied comparison operation. We generate slightly +different code for floating point comparisons, because a floating +point operation cannot directly precede a @BF@. We assume the worst +and fill that slot with a @NOP@. + +SPARC: Do not fill the delay slots here; you will confuse the register +allocator. +-} + + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock + + + +genCondJump bid bool = do + CondCode is_float cond code <- getCondCode bool + return ( + code `appOL` + toOL ( + if is_float + then [NOP, BF cond False bid, NOP] + else [BI cond False bid, NOP] + ) + ) + + + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock +genSwitch dflags expr ids + | gopt Opt_PIC dflags + = error "MachCodeGen: sparc genSwitch PIC not finished\n" + + | otherwise + = do (e_reg, e_code) <- getSomeReg expr + + base_reg <- getNewRegNat II32 + offset_reg <- getNewRegNat II32 + dst <- getNewRegNat II32 + + label <- getNewLabelNat + + return $ e_code `appOL` + toOL + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg + , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg + + -- the addrs in the table are 32 bits wide.. + , SLL e_reg (RIImm $ ImmInt 2) offset_reg + + -- load and jump to the destination + , LD II32 (AddrRegReg base_reg offset_reg) dst + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label + , NOP ] + +generateJumpTableForInstr :: DynFlags -> Instr + -> Maybe (NatCmmDecl CmmStatics Instr) +generateJumpTableForInstr dflags (JMP_TBL _ ids label) = + let jumpTable = map (jumpTableEntry dflags) ids + in Just (CmmData ReadOnlyData (Statics label jumpTable)) +generateJumpTableForInstr _ _ = Nothing + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +{- + Now the biggest nightmare---calls. Most of the nastiness is buried in + @get_arg@, which moves the arguments to the correct registers/stack + locations. Apart from that, the code is easy. + + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + + + +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (PrimTarget MO_WriteBarrier) _ _ + = return $ nilOL + +genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ + = return $ nilOL + +genCCall target dest_regs args0 + = do + -- need to remove alignment information + let args | PrimTarget mop <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init args0 + + | otherwise + = args0 + + -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + ForeignTarget expr _ + -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + PrimTarget mop + -> do res <- outOfLineMachOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + Right mopExpr -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + + let transfer_code + = toOL (move_final vregs allArgRegs extraStackArgsHere) + + dflags <- getDynFlags + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code (targetPlatform dflags) dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg = do dflags <- getDynFlags + arg_to_int_vregs' dflags arg + +arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs' dflags arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType dflags arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + let pk = cmmExprType dflags arg + + case cmmTypeSize pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f1 (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 + + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + _ -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | Move args from the integer vregs into which they have been +-- marshalled, into %o0 .. %o5, and the rest onto the stack. +-- +move_final :: [Reg] -> [Reg] -> Int -> [Instr] + +-- all args done +move_final [] _ _ + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- destination regs. +-- +assign_code :: Platform -> [LocalReg] -> OrdList Instr + +assign_code _ [] = nilOL + +assign_code platform [dest] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg platform (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] + + | otherwise + = panic "SPARC.CodeGen.GenCCall: no match" + + in result + +assign_code _ _ + = panic "SPARC.CodeGen.GenCCall: no match" + + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineMachOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineMachOp mop + = do let functionName + = outOfLineMachOp_table mop + + dflags <- getDynFlags + mopExpr <- cmmMakeDynamicReference dflags CallReference + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineMachOp_table + :: CallishMachOp + -> FastString + +outOfLineMachOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_UF_Conv w -> fsLit $ word2FloatLabel w + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + MO_BSwap w -> fsLit $ bSwapLabel w + MO_PopCnt w -> fsLit $ popCntLabel w + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz w -> fsLit $ ctzLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _) -> unsupported + where unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs new file mode 100644 index 00000000..8d9a303f --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -0,0 +1,72 @@ +module SPARC.CodeGen.Amode ( + getAmode +) + +where + +import {-# SOURCE #-} SPARC.CodeGen.Gen32 +import SPARC.CodeGen.Base +import SPARC.AddrMode +import SPARC.Imm +import SPARC.Instr +import SPARC.Regs +import SPARC.Base +import NCGMonad +import Size + +import Cmm + +import OrdList + + +-- | Generate code to reference a memory address. +getAmode + :: CmmExpr -- ^ expr producing an address + -> NatM Amode + +getAmode tree@(CmmRegOff _ _) + = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) + +getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) + | fits13Bits (-i) + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (-(fromInteger i)) + return (Amode (AddrRegImm reg off) code) + + +getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) + | fits13Bits i + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (fromInteger i) + return (Amode (AddrRegImm reg off) code) + +getAmode (CmmMachOp (MO_Add _) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y + let + code = codeX `appOL` codeY + return (Amode (AddrRegReg regX regY) code) + +getAmode (CmmLit lit) + = do + let imm__2 = litToImm lit + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let code = toOL [ SETHI (HI imm__2) tmp1 + , OR False tmp1 (RIImm (LO imm__2)) tmp2] + + return (Amode (AddrRegReg tmp2 g0) code) + +getAmode other + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs new file mode 100644 index 00000000..270fd699 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -0,0 +1,117 @@ +module SPARC.CodeGen.Base ( + InstrBlock, + CondCode(..), + ChildCode64(..), + Amode(..), + + Register(..), + setSizeOfRegister, + + getRegisterReg, + mangleIndexTree +) + +where + +import SPARC.Instr +import SPARC.Cond +import SPARC.AddrMode +import SPARC.Regs +import Size +import Reg + +import CodeGen.Platform +import DynFlags +import Cmm +import PprCmmExpr () +import Platform + +import Outputable +import OrdList + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | a.k.a "Register64" +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. +-- +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified +-- +data ChildCode64 + = ChildCode64 + InstrBlock + Reg + + +-- | Holds code that references a memory address. +data Amode + = Amode + -- the AddrMode we can use in the instruction + -- that does the real load\/store. + AddrMode + + -- other setup code we have to run first before we can use the + -- above AddrMode. + InstrBlock + + + +-------------------------------------------------------------------------------- +-- | Code to produce a result into a register. +-- If the result must go in a specific register, it comes out as Fixed. +-- Otherwise, the parent can decide which register to put it in. +-- +data Register + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) + + +-- | Change the size field in a Register. +setSizeOfRegister + :: Register -> Size -> Register + +setSizeOfRegister reg size + = case reg of + Fixed _ reg code -> Fixed size reg code + Any _ codefn -> Any size codefn + + +-------------------------------------------------------------------------------- +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic + "SPARC.CodeGen.Base.getRegisterReg: global is in memory" + (ppr $ CmmGlobal mid) + + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr + +mangleIndexTree dflags (CmmRegOff reg off) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) + +mangleIndexTree _ _ + = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs new file mode 100644 index 00000000..cb10830f --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -0,0 +1,108 @@ +module SPARC.CodeGen.CondCode ( + getCondCode, + condIntCode, + condFltCode +) + +where + +import {-# SOURCE #-} SPARC.CodeGen.Gen32 +import SPARC.CodeGen.Base +import SPARC.Instr +import SPARC.Regs +import SPARC.Cond +import SPARC.Imm +import SPARC.Base +import NCGMonad +import Size + +import Cmm + +import OrdList +import Outputable + + +getCondCode :: CmmExpr -> NatM CondCode +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + MO_Eq _ -> condIntCode EQQ x y + MO_Ne _ -> condIntCode NE x y + + MO_S_Gt _ -> condIntCode GTT x y + MO_S_Ge _ -> condIntCode GE x y + MO_S_Lt _ -> condIntCode LTT x y + MO_S_Le _ -> condIntCode LE x y + + MO_U_Gt _ -> condIntCode GU x y + MO_U_Ge _ -> condIntCode GEU x y + MO_U_Lt _ -> condIntCode LU x y + MO_U_Le _ -> condIntCode LEU x y + + _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y])) + +getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other) + + + + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x (CmmLit (CmmInt y _)) + | fits13Bits y + = do + (src1, code) <- getSomeReg x + let + src2 = ImmInt (fromInteger y) + code' = code `snocOL` SUB False True src1 (RIImm src2) g0 + return (CondCode False cond code') + +condIntCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 + return (CondCode False cond code__2) + + +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condFltCode cond x y = do + dflags <- getDynFlags + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp <- getNewRegNat FF64 + let + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y + + code__2 = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + FCMP True (cmmTypeSize pk1) src1 src2 + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True FF64 tmp src2 + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True FF64 src1 tmp + return (CondCode True cond code__2) diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs new file mode 100644 index 00000000..1d4d1379 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -0,0 +1,153 @@ +-- | Expand out synthetic instructions into single machine instrs. +module SPARC.CodeGen.Expand ( + expandTop +) + +where + +import SPARC.Instr +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Regs +import SPARC.Ppr () +import Instruction +import Reg +import Size +import Cmm + + +import Outputable +import OrdList + +-- | Expand out synthetic instructions in this top level thing +expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr +expandTop top@(CmmData{}) + = top + +expandTop (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) + + +-- | Expand out synthetic instructions in this block +expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr + +expandBlock (BasicBlock label instrs) + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' + + +-- | Expand out some instructions +expandBlockInstrs :: [Instr] -> OrdList Instr +expandBlockInstrs [] = nilOL + +expandBlockInstrs (ii:is) + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is + + + +-- | In the SPARC instruction set the FP register pairs that are used +-- to hold 64 bit floats are refered to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. +-- +-- For example: +-- ldd [%l1], (%f0 | %f1) +-- +-- gets mapped to +-- ldd [$l1], %f0 +-- +remapRegPair :: Instr -> Instr +remapRegPair instr + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg + + RegReal (RealRegPair r1 r2) + + -- sanity checking + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + , r2 == r1 + 1 + -> RegReal (RealRegSingle r1) + + | otherwise + -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) + + RegVirtual _ + -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) + + in patchRegsOfInstr instr patchF + + + + +-- Expand out 64 bit load/stores into individual instructions to handle +-- possible double alignment problems. +-- +-- TODO: It'd be better to use a scratch reg instead of the add/sub thing. +-- We might be able to do this faster if we use the UA2007 instr set +-- instead of restricting ourselves to SPARC V9. +-- +expandMisalignedDoubles :: Instr -> OrdList Instr +expandMisalignedDoubles instr + + -- Translate to: + -- add g1,g2,g1 + -- ld [g1],%fn + -- ld [g1+4],%f(n+1) + -- sub g1,g2,g1 -- to restore g1 + | LD FF64 (AddrRegReg r1 r2) fReg <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , LD FF32 (AddrRegReg r1 g0) fReg + , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | LD FF64 addr fReg <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ LD FF32 addr fReg + , LD FF32 addr' (fRegHi fReg) ] + + -- Translate to: + -- add g1,g2,g1 + -- st %fn,[g1] + -- st %f(n+1),[g1+4] + -- sub g1,g2,g1 -- to restore g1 + | ST FF64 fReg (AddrRegReg r1 r2) <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , ST FF32 fReg (AddrRegReg r1 g0) + , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | ST FF64 fReg addr <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ ST FF32 fReg addr + , ST FF32 (fRegHi fReg) addr' ] + + -- some other instr + | otherwise + = unitOL instr + + + +-- | The the high partner for this float reg. +fRegHi :: Reg -> Reg +fRegHi (RegReal (RealRegSingle r1)) + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + = (RegReal $ RealRegSingle (r1 + 1)) + +-- Can't take high partner for non-low reg. +fRegHi reg + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs new file mode 100644 index 00000000..90fb4187 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -0,0 +1,692 @@ +-- | Evaluation of 32 bit values. +module SPARC.CodeGen.Gen32 ( + getSomeReg, + getRegister +) + +where + +import SPARC.CodeGen.CondCode +import SPARC.CodeGen.Amode +import SPARC.CodeGen.Gen64 +import SPARC.CodeGen.Base +import SPARC.Stack +import SPARC.Instr +import SPARC.Cond +import SPARC.AddrMode +import SPARC.Imm +import SPARC.Regs +import SPARC.Base +import NCGMonad +import Size +import Reg + +import Cmm + +import Control.Monad (liftM) +import DynFlags +import OrdList +import Outputable + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + + + +-- | Make code to evaluate a 32 bit expression. +-- +getRegister :: CmmExpr -> NatM Register + +getRegister (CmmReg reg) + = do dflags <- getDynFlags + let platform = targetPlatform dflags + return (Fixed (cmmTypeSize (cmmRegType dflags reg)) + (getRegisterReg platform reg) nilOL) + +getRegister tree@(CmmRegOff _ _) + = do dflags <- getDynFlags + getRegister (mangleIndexTree dflags tree) + +getRegister (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + + +-- Load a literal float into a float register. +-- The actual literal is stored in a new data area, and we load it +-- at runtime. +getRegister (CmmLit (CmmFloat f W32)) = do + + -- a label for the new data area + lbl <- getNewLabelNat + tmp <- getNewRegNat II32 + + let code dst = toOL [ + -- the data area + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], + + -- load the literal + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + + return (Any FF32 code) + +getRegister (CmmLit (CmmFloat d W64)) = do + lbl <- getNewLabelNat + tmp <- getNewRegNat II32 + let code dst = toOL [ + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], + SETHI (HI (ImmCLbl lbl)) tmp, + LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + return (Any FF64 code) + + +-- Unary machine ops +getRegister (CmmMachOp mop [x]) + = case mop of + -- Floating point negation ------------------------- + MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x + MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x + + + -- Integer negation -------------------------------- + MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x + MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x + + + -- Float word size conversion ---------------------- + MO_FF_Conv W64 W32 -> coerceDbl2Flt x + MO_FF_Conv W32 W64 -> coerceFlt2Dbl x + + + -- Float <-> Signed Int conversion ----------------- + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + + -- Unsigned integer word size conversions ---------- + + -- If it's the same size, then nothing needs to be done. + MO_UU_Conv from to + | from == to -> conversionNop (intSize to) x + + -- To narrow an unsigned word, mask out the high bits to simulate what would + -- happen if we copied the value into a smaller register. + MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + + -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 + -- case because the only way we can load it is via SETHI, which needs 2 ops. + -- Do some shifts to chop out the high bits instead. + MO_UU_Conv W32 W16 + -> do tmpReg <- getNewRegNat II32 + (xReg, xCode) <- getSomeReg x + let code dst + = xCode + `appOL` toOL + [ SLL xReg (RIImm $ ImmInt 16) tmpReg + , SRL tmpReg (RIImm $ ImmInt 16) dst] + + return $ Any II32 code + + -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- To widen an unsigned word we don't have to do anything. + -- Just leave it in the same register and mark the result as the new size. + MO_UU_Conv W8 W16 -> conversionNop (intSize W16) x + MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x + MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x + + + -- Signed integer word size conversions ------------ + + -- Mask out high bits when narrowing them + MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- Sign extend signed words when widening them. + MO_SS_Conv W8 W16 -> integerExtend W8 W16 x + MO_SS_Conv W8 W32 -> integerExtend W8 W32 x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + + _ -> panic ("Unknown unary mach op: " ++ show mop) + + +-- Binary machine ops +getRegister (CmmMachOp mop [x, y]) + = case mop of + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt W32 -> condIntReg GU x y + MO_U_Ge W32 -> condIntReg GEU x y + MO_U_Lt W32 -> condIntReg LU x y + MO_U_Le W32 -> condIntReg LEU x y + + MO_U_Gt W16 -> condIntReg GU x y + MO_U_Ge W16 -> condIntReg GEU x y + MO_U_Lt W16 -> condIntReg LU x y + MO_U_Le W16 -> condIntReg LEU x y + + MO_Add W32 -> trivialCode W32 (ADD False False) x y + MO_Sub W32 -> trivialCode W32 (SUB False False) x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_S_Quot W32 -> idiv True False x y + MO_U_Quot W32 -> idiv False False x y + + MO_S_Rem W32 -> irem True x y + MO_U_Rem W32 -> irem False x y + + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_F_Add w -> trivialFCode w FADD x y + MO_F_Sub w -> trivialFCode w FSUB x y + MO_F_Mul w -> trivialFCode w FMUL x y + MO_F_Quot w -> trivialFCode w FDIV x y + + MO_And rep -> trivialCode rep (AND False) x y + MO_Or rep -> trivialCode rep (OR False) x y + MO_Xor rep -> trivialCode rep (XOR False) x y + + MO_Mul rep -> trivialCode rep (SMUL False) x y + + MO_Shl rep -> trivialCode rep SLL x y + MO_U_Shr rep -> trivialCode rep SRL x y + MO_S_Shr rep -> trivialCode rep SRA x y + + _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) + where + + +getRegister (CmmLoad mem pk) = do + Amode src code <- getAmode mem + let + code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst + return (Any (cmmTypeSize pk) code__2) + +getRegister (CmmLit (CmmInt i _)) + | fits13Bits i + = let + src = ImmInt (fromInteger i) + code dst = unitOL (OR False g0 (RIImm src) dst) + in + return (Any II32 code) + +getRegister (CmmLit lit) + = let imm = litToImm lit + code dst = toOL [ + SETHI (HI imm) dst, + OR False dst (RIImm (LO imm)) dst] + in return (Any II32 code) + + +getRegister _ + = panic "SPARC.CodeGen.Gen32.getRegister: no match" + + +-- | sign extend and widen +integerExtend + :: Width -- ^ width of source expression + -> Width -- ^ width of result + -> CmmExpr -- ^ source expression + -> NatM Register + +integerExtend from to expr + = do -- load the expr into some register + (reg, e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + let bitCount + = case (from, to) of + (W8, W32) -> 24 + (W16, W32) -> 16 + (W8, W16) -> 24 + _ -> panic "SPARC.CodeGen.Gen32: no match" + let code dst + = e_code + + -- local shift word left to load the sign bit + `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp + + -- arithmetic shift right to sign extend + `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst + + return (Any (intSize to) code) + + +-- | For nop word format conversions we set the resulting value to have the +-- required size, but don't need to generate any actual code. +-- +conversionNop + :: Size -> CmmExpr -> NatM Register + +conversionNop new_rep expr + = do e_code <- getRegister expr + return (setSizeOfRegister e_code new_rep) + + + +-- | Generate an integer division instruction. +idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register + +-- For unsigned division with a 32 bit numerator, +-- we can just clear the Y register. +idiv False cc x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + +-- For _signed_ division with a 32 bit numerator, +-- we have to sign extend the numerator into the Y register. +idiv True cc x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend + , SRA tmp (RIImm (ImmInt 16)) tmp + + , WRY tmp g0 + , SDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + +-- | Do an integer remainder. +-- +-- NOTE: The SPARC v8 architecture manual says that integer division +-- instructions _may_ generate a remainder, depending on the implementation. +-- If so it is _recommended_ that the remainder is placed in the Y register. +-- +-- The UltraSparc 2007 manual says Y is _undefined_ after division. +-- +-- The SPARC T2 doesn't store the remainder, not sure about the others. +-- It's probably best not to worry about it, and just generate our own +-- remainders. +-- +irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register + +-- For unsigned operands: +-- Division is between a 64 bit numerator and a 32 bit denominator, +-- so we still have to clear the Y register. +irem False x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV False a_reg (RIReg b_reg) tmp_reg + , UMUL False tmp_reg (RIReg b_reg) tmp_reg + , SUB False False a_reg (RIReg tmp_reg) dst] + + return (Any II32 code) + + + +-- For signed operands: +-- Make sure to sign extend into the Y register, or the remainder +-- will have the wrong sign when the numerator is negative. +-- +-- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, +-- not the full 32. Not sure why this is, something to do with overflow? +-- If anyone cares enough about the speed of signed remainder they +-- can work it out themselves (then tell me). -- BL 2009/01/20 +irem True x y + = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp1_reg <- getNewRegNat II32 + tmp2_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , WRY tmp1_reg g0 + + , SDIV False a_reg (RIReg b_reg) tmp2_reg + , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg + , SUB False False a_reg (RIReg tmp2_reg) dst] + + return (Any II32 code) + + +imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register +imulMayOflo rep a b + = do + (a_reg, a_code) <- getSomeReg a + (b_reg, b_code) <- getSomeReg b + res_lo <- getNewRegNat II32 + res_hi <- getNewRegNat II32 + + let shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + let code dst = a_code `appOL` b_code `appOL` + toOL [ + SMUL False a_reg (RIReg b_reg) res_lo, + RDY res_hi, + SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, + SUB False False res_lo (RIReg res_hi) dst + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + +trivialCode + :: Width + -> (Reg -> RI -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialCode _ instr x (CmmLit (CmmInt y _)) + | fits13Bits y + = do + (src1, code) <- getSomeReg x + let + src2 = ImmInt (fromInteger y) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst + return (Any II32 code__2) + + +trivialCode _ instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst + return (Any II32 code__2) + + +trivialFCode + :: Width + -> (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + +trivialFCode pk instr x y = do + dflags <- getDynFlags + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp <- getNewRegNat FF64 + let + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y + + code__2 dst = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + instr (floatSize pk) src1 src2 dst + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr FF64 tmp src2 dst + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr FF64 src1 tmp dst + return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) + code__2) + + + +trivialUCode + :: Size + -> (RI -> Reg -> Instr) + -> CmmExpr + -> NatM Register + +trivialUCode size instr x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `snocOL` instr (RIReg src) dst + return (Any size code__2) + + +trivialUFCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register + +trivialUFCode pk instr x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `snocOL` instr src dst + return (Any pk code__2) + + + + +-- Coercions ------------------------------------------------------------------- + +-- | Coerce a integer value to floating point +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP width1 width2 x = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + ST (intSize width1) src (spRel (-2)), + LD (intSize width1) (spRel (-2)) dst, + FxTOy (intSize width1) (floatSize width2) dst dst] + return (Any (floatSize $ width2) code__2) + + + +-- | Coerce a floating point value to integer +-- +-- NOTE: On sparc v9 there are no instructions to move a value from an +-- FP register directly to an int register, so we have to use a load/store. +-- +coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register +coerceFP2Int width1 width2 x + = do let fsize1 = floatSize width1 + fsize2 = floatSize width2 + + isize2 = intSize width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fsize2 + + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fsize1 isize2 fsrc fdst + + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fsize2 fdst (spRel (-2)) + , LD isize2 (spRel (-2)) dst] + + return (Any isize2 code2) + + +-- | Coerce a double precision floating point value to single precision. +coerceDbl2Flt :: CmmExpr -> NatM Register +coerceDbl2Flt x = do + (src, code) <- getSomeReg x + return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) + + +-- | Coerce a single precision floating point value to double precision +coerceFlt2Dbl :: CmmExpr -> NatM Register +coerceFlt2Dbl x = do + (src, code) <- getSomeReg x + return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) + + + + +-- Condition Codes ------------------------------------------------------------- +-- +-- Evaluate a comparison, and get the result into a register. +-- +-- Do not fill the delay slots here. you will confuse the register allocator. +-- +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + return (Any II32 code__2) + +condIntReg EQQ x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + return (Any II32 code__2) + +condIntReg NE x (CmmLit (CmmInt 0 _)) = do + (src, code) <- getSomeReg x + let + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + return (Any II32 code__2) + +condIntReg NE x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + let + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + return (Any II32 code__2) + +condIntReg cond x y = do + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat + CondCode _ cond cond_code <- condIntCode cond x y + let + code__2 dst + = cond_code + `appOL` toOL + [ BI cond False bid1 + , NOP + + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid2] + + return (Any II32 code__2) + + +condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg cond x y = do + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat + + CondCode _ cond cond_code <- condFltCode cond x y + let + code__2 dst + = cond_code + `appOL` toOL + [ NOP + , BF cond False bid1 + , NOP + + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP + + , NEWBLOCK bid2 ] + + return (Any II32 code__2) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot new file mode 100644 index 00000000..43632c67 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -0,0 +1,16 @@ + +module SPARC.CodeGen.Gen32 ( + getSomeReg, + getRegister +) + +where + +import SPARC.CodeGen.Base +import NCGMonad +import Reg + +import Cmm + +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getRegister :: CmmExpr -> NatM Register diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs new file mode 100644 index 00000000..438deba0 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -0,0 +1,199 @@ +-- | Evaluation of 64 bit values on 32 bit platforms. +module SPARC.CodeGen.Gen64 ( + assignMem_I64Code, + assignReg_I64Code, + iselExpr64 +) + +where + +import {-# SOURCE #-} SPARC.CodeGen.Gen32 +import SPARC.CodeGen.Base +import SPARC.CodeGen.Amode +import SPARC.Regs +import SPARC.AddrMode +import SPARC.Imm +import SPARC.Instr +import SPARC.Ppr() +import NCGMonad +import Instruction +import Size +import Reg + +import Cmm + +import DynFlags +import OrdList +import Outputable + +-- | Code to assign a 64 bit value to memory. +assignMem_I64Code + :: CmmExpr -- ^ expr producing the destination address + -> CmmExpr -- ^ expr producing the source value. + -> NatM InstrBlock + +assignMem_I64Code addrTree valueTree + = do + ChildCode64 vcode rlo <- iselExpr64 valueTree + + (src, acode) <- getSomeReg addrTree + let + rhi = getHiVRegFromLo rlo + + -- Big-endian store + mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) + mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) + + code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo + +{- pprTrace "assignMem_I64Code" + (vcat [ text "addrTree: " <+> ppr addrTree + , text "valueTree: " <+> ppr valueTree + , text "vcode:" + , vcat $ map ppr $ fromOL vcode + , text "" + , text "acode:" + , vcat $ map ppr $ fromOL acode ]) + $ -} + return code + + +-- | Code to assign a 64 bit value to a register. +assignReg_I64Code + :: CmmReg -- ^ the destination register + -> CmmExpr -- ^ expr producing the source value + -> NatM InstrBlock + +assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree + = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeSize pk) + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + + return (vcode `snocOL` mov_hi `snocOL` mov_lo) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(sparc): invalid lvalue" + + + + +-- | Get the value of an expression into a 64 bit register. + +iselExpr64 :: CmmExpr -> NatM ChildCode64 + +-- Load a 64 bit word +iselExpr64 (CmmLoad addrTree ty) + | isWord64 ty + = do Amode amode addr_code <- getAmode addrTree + let result + + | AddrRegReg r1 r2 <- amode + = do rlo <- getNewRegNat II32 + tmp <- getNewRegNat II32 + let rhi = getHiVRegFromLo rlo + + return $ ChildCode64 + ( addr_code + `appOL` toOL + [ ADD False False r1 (RIReg r2) tmp + , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi + , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) + rlo + + | AddrRegImm r1 (ImmInt i) <- amode + = do rlo <- getNewRegNat II32 + let rhi = getHiVRegFromLo rlo + + return $ ChildCode64 + ( addr_code + `appOL` toOL + [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi + , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) + rlo + + | otherwise + = panic "SPARC.CodeGen.Gen64: no match" + + result + + +-- Add a literal to a 64 bit integer +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) + = do ChildCode64 code1 r1_lo <- iselExpr64 e1 + let r1_hi = getHiVRegFromLo r1_lo + + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + let code = code1 + `appOL` toOL + [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo + , ADD True False r1_hi (RIReg g0) r_dst_hi ] + + return $ ChildCode64 code r_dst_lo + + +-- Addition of II64 +iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) + = do ChildCode64 code1 r1_lo <- iselExpr64 e1 + let r1_hi = getHiVRegFromLo r1_lo + + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r2_hi = getHiVRegFromLo r2_lo + + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + let code = code1 + `appOL` code2 + `appOL` toOL + [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo + , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] + + return $ ChildCode64 code r_dst_lo + + +iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) + | isWord64 ty + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_lo = RegVirtual $ mkVirtualReg uq II32 + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + return ( + ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo + ) + +-- Convert something into II64 +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + -- compute expr and load it into r_dst_lo + (a_reg, a_code) <- getSomeReg expr + + dflags <- getDynFlags + let platform = targetPlatform dflags + code = a_code + `appOL` toOL + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] + + return $ ChildCode64 code r_dst_lo + + +iselExpr64 expr + = pprPanic "iselExpr64(sparc)" (ppr expr) + + + diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs new file mode 100644 index 00000000..81641326 --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -0,0 +1,67 @@ +-- | One ounce of sanity checking is worth 10000000000000000 ounces +-- of staring blindly at assembly code trying to find the problem.. +module SPARC.CodeGen.Sanity ( + checkBlock +) + +where + +import SPARC.Instr +import SPARC.Ppr () +import Instruction + +import Cmm + +import Outputable + + +-- | Enforce intra-block invariants. +-- +checkBlock :: CmmBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr + +checkBlock cmm block@(BasicBlock _ instrs) + | checkBlockInstrs instrs + = block + + | otherwise + = pprPanic + ("SPARC.CodeGen: bad block\n") + ( vcat [ text " -- cmm -----------------\n" + , ppr cmm + , text " -- native code ---------\n" + , ppr block ]) + + +checkBlockInstrs :: [Instr] -> Bool +checkBlockInstrs ii + + -- An unconditional jumps end the block. + -- There must be an unconditional jump in the block, otherwise + -- the register liveness determinator will get the liveness + -- information wrong. + -- + -- If the block ends with a cmm call that never returns + -- then there can be unreachable instructions after the jump, + -- but we don't mind here. + -- + | instr : NOP : _ <- ii + , isUnconditionalJump instr + = True + + -- All jumps must have a NOP in their branch delay slot. + -- The liveness determinator and register allocators aren't smart + -- enough to handle branch delay slots. + -- + | instr : NOP : is <- ii + , isJumpishInstr instr + = checkBlockInstrs is + + -- keep checking + | _:i2:is <- ii + = checkBlockInstrs (i2:is) + + -- this block is no good + | otherwise + = False diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs new file mode 100644 index 00000000..da414579 --- /dev/null +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -0,0 +1,52 @@ +module SPARC.Cond ( + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned +) + +where + +-- | Branch condition codes. +data Cond + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS + deriving Eq + + +condUnsigned :: Cond -> Bool +condUnsigned GU = True +condUnsigned LU = True +condUnsigned GEU = True +condUnsigned LEU = True +condUnsigned _ = False + + +condToSigned :: Cond -> Cond +condToSigned GU = GTT +condToSigned LU = LTT +condToSigned GEU = GE +condToSigned LEU = LE +condToSigned x = x + + +condToUnsigned :: Cond -> Cond +condToUnsigned GTT = GU +condToUnsigned LTT = LU +condToUnsigned GE = GEU +condToUnsigned LE = LEU +condToUnsigned x = x diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs new file mode 100644 index 00000000..cb53ba41 --- /dev/null +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -0,0 +1,65 @@ +module SPARC.Imm ( + -- immediate values + Imm(..), + strImmLit, + litToImm +) + +where + +import Cmm +import CLabel + +import Outputable + +-- | An immediate value. +-- Not all of these are directly representable by the machine. +-- Things like ImmLit are slurped out and put in a data segment instead. +-- +data Imm + = ImmInt Int + + -- Sigh. + | ImmInteger Integer + + -- AbstractC Label (with baggage) + | ImmCLbl CLabel + + -- Simple string + | ImmLit SDoc + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + + | LO Imm + | HI Imm + + +-- | Create a ImmLit containing this string. +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +-- | Convert a CmmLit to an Imm. +-- Narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. +-- +litToImm :: CmmLit -> Imm +litToImm lit + = case lit of + CmmInt i w -> ImmInteger (narrowS w i) + CmmFloat f W32 -> ImmFloat f + CmmFloat f W64 -> ImmDouble f + CmmLabel l -> ImmCLbl l + CmmLabelOff l off -> ImmIndex l off + + CmmLabelDiffOff l1 l2 off + -> ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) + + _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs new file mode 100644 index 00000000..fb8cc0ca --- /dev/null +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module SPARC.Instr ( + RI(..), + riZero, + + fpRelEA, + moveSp, + + isUnconditionalJump, + + Instr(..), + maxSpillSlots +) + +where + +import SPARC.Stack +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Cond +import SPARC.Regs +import SPARC.Base +import TargetReg +import Instruction +import RegClass +import Reg +import Size + +import CLabel +import CodeGen.Platform +import BlockId +import DynFlags +import Cmm +import FastString +import FastBool +import Outputable +import Platform + + +-- | Register or immediate +data RI + = RIReg Reg + | RIImm Imm + +-- | Check if a RI represents a zero value. +-- - a literal zero +-- - register %g0, which is always zero. +-- +riZero :: RI -> Bool +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (RegReal (RealRegSingle 0))) = True +riZero _ = False + + +-- | Calculate the effective address which would be used by the +-- corresponding fpRel sequence. +fpRelEA :: Int -> Reg -> Instr +fpRelEA n dst + = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst + + +-- | Code to shift the stack pointer by n words. +moveSp :: Int -> Instr +moveSp n + = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp + +-- | An instruction that will cause the one after it never to be exectuted +isUnconditionalJump :: Instr -> Bool +isUnconditionalJump ii + = case ii of + CALL{} -> True + JMP{} -> True + JMP_TBL{} -> True + BI ALWAYS _ _ -> True + BF ALWAYS _ _ -> True + _ -> False + + +-- | instance for sparc instruction set +instance Instruction Instr where + regUsageOfInstr = sparc_regUsageOfInstr + patchRegsOfInstr = sparc_patchRegsOfInstr + isJumpishInstr = sparc_isJumpishInstr + jumpDestsOfInstr = sparc_jumpDestsOfInstr + patchJumpInstr = sparc_patchJumpInstr + mkSpillInstr = sparc_mkSpillInstr + mkLoadInstr = sparc_mkLoadInstr + takeDeltaInstr = sparc_takeDeltaInstr + isMetaInstr = sparc_isMetaInstr + mkRegRegMoveInstr = sparc_mkRegRegMoveInstr + takeRegRegMoveInstr = sparc_takeRegRegMoveInstr + mkJumpInstr = sparc_mkJumpInstr + mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" + mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" + + +-- | SPARC instruction set. +-- Not complete. This is only the ones we need. +-- +data Instr + + -- meta ops -------------------------------------------------- + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code generation. + -- Will be extracted before pretty-printing. + | LDATA Section CmmStatics + + -- Start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + | DELTA Int + + -- real instrs ----------------------------------------------- + -- Loads and stores. + | LD Size AddrMode Reg -- size, src, dst + | ST Size Reg AddrMode -- size, src, dst + + -- Int Arithmetic. + -- x: add/sub with carry bit. + -- In SPARC V9 addx and friends were renamed addc. + -- + -- cc: modify condition codes + -- + | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + + | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst + | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst + + + -- The SPARC divide instructions perform 64bit by 32bit division + -- The Y register is xored into the first operand. + + -- On _some implementations_ the Y register is overwritten by + -- the remainder, so we have to make sure it is 0 each time. + + -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 + | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst + | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst + + | RDY Reg -- move contents of Y register to reg + | WRY Reg Reg -- Y <- src1 `xor` src2 + + -- Logic operations. + | AND Bool Reg RI Reg -- cc?, src1, src2, dst + | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst + | OR Bool Reg RI Reg -- cc?, src1, src2, dst + | ORN Bool Reg RI Reg -- cc?, src1, src2, dst + | XOR Bool Reg RI Reg -- cc?, src1, src2, dst + | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst + | SLL Reg RI Reg -- src1, src2, dst + | SRL Reg RI Reg -- src1, src2, dst + | SRA Reg RI Reg -- src1, src2, dst + + -- Load immediates. + | SETHI Imm Reg -- src, dst + + -- Do nothing. + -- Implemented by the assembler as SETHI 0, %g0, but worth an alias + | NOP + + -- Float Arithmetic. + -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single + -- instructions right up until we spit them out. + -- + | FABS Size Reg Reg -- src dst + | FADD Size Reg Reg Reg -- src1, src2, dst + | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst + | FDIV Size Reg Reg Reg -- src1, src2, dst + | FMOV Size Reg Reg -- src, dst + | FMUL Size Reg Reg Reg -- src1, src2, dst + | FNEG Size Reg Reg -- src, dst + | FSQRT Size Reg Reg -- src, dst + | FSUB Size Reg Reg Reg -- src1, src2, dst + | FxTOy Size Size Reg Reg -- src, dst + + -- Jumping around. + | BI Cond Bool BlockId -- cond, annul?, target + | BF Cond Bool BlockId -- cond, annul?, target + + | JMP AddrMode -- target + + -- With a tabled jump we know all the possible destinations. + -- We also need this info so we can work out what regs are live across the jump. + -- + | JMP_TBL AddrMode [Maybe BlockId] CLabel + + | CALL (Either Imm Reg) Int Bool -- target, args, terminal + + +-- | regUsage returns the sets of src and destination registers used +-- by a particular instruction. Machine registers that are +-- pre-allocated to stgRegs are filtered out, because they are +-- uninteresting from a register allocation standpoint. (We wouldn't +-- want them to end up on the free list!) As far as we are concerned, +-- the fixed registers simply don't exist (for allocation purposes, +-- anyway). + +-- regUsage doesn't need to do any trickery for jumps and such. Just +-- state precisely the regs read and written by that insn. The +-- consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage +sparc_regUsageOfInstr platform instr + = case instr of + LD _ addr reg -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + RDY rd -> usage ([], [rd]) + WRY r1 r2 -> usage ([r1, r2], []) + AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SETHI _ reg -> usage ([], [reg]) + FABS _ r1 r2 -> usage ([r1], [r2]) + FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FCMP _ _ r1 r2 -> usage ([r1, r2], []) + FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV _ r1 r2 -> usage ([r1], [r2]) + FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FNEG _ r1 r2 -> usage ([r1], [r2]) + FSQRT _ r1 r2 -> usage ([r1], [r2]) + FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FxTOy _ _ r1 r2 -> usage ([r1], [r2]) + + JMP addr -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) + + CALL (Left _ ) _ True -> noUsage + CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) + CALL (Right reg) _ True -> usage ([reg], []) + CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) + _ -> noUsage + + where + usage (src, dst) + = RU (filter (interesting platform) src) + (filter (interesting platform) dst) + + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + + +-- | Interesting regs are virtuals, or ones that are allocatable +-- by the register allocator. +interesting :: Platform -> Reg -> Bool +interesting platform reg + = case reg of + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) + + + +-- | Apply a given mapping to tall the register references in this instruction. +sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +sparc_patchRegsOfInstr instr env = case instr of + LD sz addr reg -> LD sz (fixAddr addr) (env reg) + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + + ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) + SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) + UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) + SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) + UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) + SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) + RDY rd -> RDY (env rd) + WRY r1 r2 -> WRY (env r1) (env r2) + AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) + ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) + OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) + ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) + XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) + XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + + SETHI imm reg -> SETHI imm (env reg) + + FABS s r1 r2 -> FABS s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMOV s r1 r2 -> FMOV s (env r1) (env r2) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) + + JMP addr -> JMP (fixAddr addr) + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l + + CALL (Left i) n t -> CALL (Left i) n t + CALL (Right r) n t -> CALL (Right (env r)) n t + _ -> instr + + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + + +-------------------------------------------------------------------------------- +sparc_isJumpishInstr :: Instr -> Bool +sparc_isJumpishInstr instr + = case instr of + BI{} -> True + BF{} -> True + JMP{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False + +sparc_jumpDestsOfInstr :: Instr -> [BlockId] +sparc_jumpDestsOfInstr insn + = case insn of + BI _ _ id -> [id] + BF _ _ id -> [id] + JMP_TBL _ ids _ -> [id | Just id <- ids] + _ -> [] + + +sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +sparc_patchJumpInstr insn patchF + = case insn of + BI cc annul id -> BI cc annul (patchF id) + BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l + _ -> insn + + +-------------------------------------------------------------------------------- +-- | Make a spill instruction. +-- On SPARC we spill below frame pointer leaving 2 words/spill +sparc_mkSpillInstr + :: DynFlags + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr + +sparc_mkSpillInstr dflags reg _ slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot + off_w = 1 + (off `div` 4) + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkSpillInstr" + + in ST sz reg (fpRel (negate off_w)) + + +-- | Make a spill reload instruction. +sparc_mkLoadInstr + :: DynFlags + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr + +sparc_mkLoadInstr dflags reg _ slot + = let platform = targetPlatform dflags + off = spillSlotToOffset dflags slot + off_w = 1 + (off `div` 4) + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkLoadInstr" + + in LD sz (fpRel (- off_w)) reg + + +-------------------------------------------------------------------------------- +-- | See if this instruction is telling us the current C stack delta +sparc_takeDeltaInstr + :: Instr + -> Maybe Int + +sparc_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +sparc_isMetaInstr + :: Instr + -> Bool + +sparc_isMetaInstr instr + = case instr of + COMMENT{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + +-- | Make a reg-reg move instruction. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. +-- +sparc_mkRegRegMoveInstr + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst + , srcClass == dstClass + = case srcClass of + RcInteger -> ADD False False src (RIReg g0) dst + RcDouble -> FMOV FF64 src dst + RcFloat -> FMOV FF32 src dst + _ -> panic "sparc_mkRegRegMoveInstr" + + | otherwise + = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" + + +-- | Check whether an instruction represents a reg-reg move. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. +-- +sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) +sparc_takeRegRegMoveInstr instr + = case instr of + ADD False False src (RIReg src2) dst + | g0 == src2 -> Just (src, dst) + + FMOV FF64 src dst -> Just (src, dst) + FMOV FF32 src dst -> Just (src, dst) + _ -> Nothing + + +-- | Make an unconditional branch instruction. +sparc_mkJumpInstr + :: BlockId + -> [Instr] + +sparc_mkJumpInstr id + = [BI ALWAYS False id + , NOP] -- fill the branch delay slot. diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs new file mode 100644 index 00000000..e9941b81 --- /dev/null +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module SPARC.Ppr ( + pprNatCmmDecl, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem +) + +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +import SPARC.Regs +import SPARC.Instr +import SPARC.Cond +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Base +import Instruction +import Reg +import Size +import PprBase + +import Cmm hiding (topInfoTable) +import PprCmm() +import CLabel +import BlockId + +import Unique ( Uniquable(..), pprUnique ) +import Outputable +import Platform +import FastString +import Data.Word + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc +pprNatCmmDecl (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats + +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + case topInfoTable proc of + Nothing -> + case blocks of + [] -> -- special case for split markers: + pprLabel lbl + blocks -> -- special case for code without info table: + pprSectionHeader Text $$ + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock top_info) blocks) + + Just (Statics info_lbl _) -> + sdocWithPlatform $ \platform -> + (if platformHasSubsectionsViaSymbols platform + then pprSectionHeader Text $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) + + +pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock info_env (BasicBlock blockid instrs) + = maybe_infotable $$ + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map pprInstr instrs) + where + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (Statics info_lbl info) -> + pprSectionHeader Text $$ + vcat (map pprData info) $$ + pprLabel info_lbl + + +pprDatas :: CmmStatics -> SDoc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + +pprData :: CmmStatic -> SDoc +pprData (CmmString str) = pprASCII str +pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes +pprData (CmmStaticLit lit) = pprDataItem lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext (sLit ".global ") <> ppr lbl + +pprTypeAndSizeDecl :: CLabel -> SDoc +pprTypeAndSizeDecl lbl + = sdocWithPlatform $ \platform -> + if platformOS platform == OSLinux && externallyVisibleCLabel lbl + then ptext (sLit ".type ") <> ppr lbl <> ptext (sLit ", @object") + else empty + +pprLabel :: CLabel -> SDoc +pprLabel lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl lbl + $$ (ppr lbl <> char ':') + + +pprASCII :: [Word8] -> SDoc +pprASCII str + = vcat (map do1 str) $$ do1 0 + where + do1 :: Word8 -> SDoc + do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = pprInstr instr + + +-- | Pretty print a register. +pprReg :: Reg -> SDoc +pprReg reg + = case reg of + RegVirtual vr + -> case vr of + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u + + RegReal rr + -> case rr of + RealRegSingle r1 + -> pprReg_ofRegNo r1 + + RealRegPair r1 r2 + -> text "(" <> pprReg_ofRegNo r1 + <> text "|" <> pprReg_ofRegNo r2 + <> text ")" + + + +-- | Pretty print a register name, based on this register number. +-- The definition has been unfolded so we get a jump-table in the +-- object code. This function is called quite a lot when emitting +-- the asm file.. +-- +pprReg_ofRegNo :: Int -> SDoc +pprReg_ofRegNo i + = ptext + (case i of { + 0 -> sLit "%g0"; 1 -> sLit "%g1"; + 2 -> sLit "%g2"; 3 -> sLit "%g3"; + 4 -> sLit "%g4"; 5 -> sLit "%g5"; + 6 -> sLit "%g6"; 7 -> sLit "%g7"; + 8 -> sLit "%o0"; 9 -> sLit "%o1"; + 10 -> sLit "%o2"; 11 -> sLit "%o3"; + 12 -> sLit "%o4"; 13 -> sLit "%o5"; + 14 -> sLit "%o6"; 15 -> sLit "%o7"; + 16 -> sLit "%l0"; 17 -> sLit "%l1"; + 18 -> sLit "%l2"; 19 -> sLit "%l3"; + 20 -> sLit "%l4"; 21 -> sLit "%l5"; + 22 -> sLit "%l6"; 23 -> sLit "%l7"; + 24 -> sLit "%i0"; 25 -> sLit "%i1"; + 26 -> sLit "%i2"; 27 -> sLit "%i3"; + 28 -> sLit "%i4"; 29 -> sLit "%i5"; + 30 -> sLit "%i6"; 31 -> sLit "%i7"; + 32 -> sLit "%f0"; 33 -> sLit "%f1"; + 34 -> sLit "%f2"; 35 -> sLit "%f3"; + 36 -> sLit "%f4"; 37 -> sLit "%f5"; + 38 -> sLit "%f6"; 39 -> sLit "%f7"; + 40 -> sLit "%f8"; 41 -> sLit "%f9"; + 42 -> sLit "%f10"; 43 -> sLit "%f11"; + 44 -> sLit "%f12"; 45 -> sLit "%f13"; + 46 -> sLit "%f14"; 47 -> sLit "%f15"; + 48 -> sLit "%f16"; 49 -> sLit "%f17"; + 50 -> sLit "%f18"; 51 -> sLit "%f19"; + 52 -> sLit "%f20"; 53 -> sLit "%f21"; + 54 -> sLit "%f22"; 55 -> sLit "%f23"; + 56 -> sLit "%f24"; 57 -> sLit "%f25"; + 58 -> sLit "%f26"; 59 -> sLit "%f27"; + 60 -> sLit "%f28"; 61 -> sLit "%f29"; + 62 -> sLit "%f30"; 63 -> sLit "%f31"; + _ -> sLit "very naughty sparc register" }) + + +-- | Pretty print a size for an instruction suffix. +pprSize :: Size -> SDoc +pprSize x + = ptext + (case x of + II8 -> sLit "ub" + II16 -> sLit "uh" + II32 -> sLit "" + II64 -> sLit "d" + FF32 -> sLit "" + FF64 -> sLit "d" + _ -> panic "SPARC.Ppr.pprSize: no match") + + +-- | Pretty print a size for an instruction suffix. +-- eg LD is 32bit on sparc, but LDD is 64 bit. +pprStSize :: Size -> SDoc +pprStSize x + = ptext + (case x of + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "" + II64 -> sLit "x" + FF32 -> sLit "" + FF64 -> sLit "d" + _ -> panic "SPARC.Ppr.pprSize: no match") + + +-- | Pretty print a condition code. +pprCond :: Cond -> SDoc +pprCond c + = ptext + (case c of + ALWAYS -> sLit "" + NEVER -> sLit "n" + GEU -> sLit "geu" + LU -> sLit "lu" + EQQ -> sLit "e" + GTT -> sLit "g" + GE -> sLit "ge" + GU -> sLit "gu" + LTT -> sLit "l" + LE -> sLit "le" + LEU -> sLit "leu" + NE -> sLit "ne" + NEG -> sLit "neg" + POS -> sLit "pos" + VC -> sLit "vc" + VS -> sLit "vs") + + +-- | Pretty print an address mode. +pprAddr :: AddrMode -> SDoc +pprAddr am + = case am of + AddrRegReg r1 (RegReal (RealRegSingle 0)) + -> pprReg r1 + + AddrRegReg r1 r2 + -> hcat [ pprReg r1, char '+', pprReg r2 ] + + AddrRegImm r1 (ImmInt i) + | i == 0 -> pprReg r1 + | not (fits13Bits i) -> largeOffsetError i + | otherwise -> hcat [ pprReg r1, pp_sign, int i ] + where + pp_sign = if i > 0 then char '+' else empty + + AddrRegImm r1 (ImmInteger i) + | i == 0 -> pprReg r1 + | not (fits13Bits i) -> largeOffsetError i + | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] + where + pp_sign = if i > 0 then char '+' else empty + + AddrRegImm r1 imm + -> hcat [ pprReg r1, char '+', pprImm imm ] + + +-- | Pretty print an immediate value. +pprImm :: Imm -> SDoc +pprImm imm + = case imm of + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> ppr l + ImmIndex l i -> ppr l <> char '+' <> int i + ImmLit s -> s + + ImmConstantSum a b + -> pprImm a <> char '+' <> pprImm b + + ImmConstantDiff a b + -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen + + LO i + -> hcat [ text "%lo(", pprImm i, rparen ] + + HI i + -> hcat [ text "%hi(", pprImm i, rparen ] + + -- these should have been converted to bytes and placed + -- in the data section. + ImmFloat _ -> ptext (sLit "naughty float immediate") + ImmDouble _ -> ptext (sLit "naughty double immediate") + + +-- | Pretty print a section \/ segment header. +-- On SPARC all the data sections must be at least 8 byte aligned +-- incase we store doubles in them. +-- +pprSectionHeader :: Section -> SDoc +pprSectionHeader seg = case seg of + Text -> text ".text\n\t.align 4" + Data -> text ".data\n\t.align 8" + ReadOnlyData -> text ".text\n\t.align 8" + RelocatableReadOnlyData + -> text ".text\n\t.align 8" + UninitialisedData -> text ".bss\n\t.align 8" + ReadOnlyData16 -> text ".data\n\t.align 16" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" + + +-- | Pretty print a data item. +pprDataItem :: CmmLit -> SDoc +pprDataItem lit + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) + where + imm = litToImm lit + + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] + ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" + + +-- | Pretty print an instruction. +pprInstr :: Instr -> SDoc + +-- nuke comments. +pprInstr (COMMENT _) + = empty + +pprInstr (DELTA d) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) + +-- Newblocks and LData should have been slurped out before producing the .s file. +pprInstr (NEWBLOCK _) + = panic "X86.Ppr.pprInstr: NEWBLOCK" + +pprInstr (LDATA _ _) + = panic "PprMach.pprInstr: LDATA" + +-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand +pprInstr (LD FF64 _ reg) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" + +pprInstr (LD size addr reg) + = hcat [ + ptext (sLit "\tld"), + pprSize size, + char '\t', + lbrack, + pprAddr addr, + pp_rbracket_comma, + pprReg reg + ] + +-- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand +pprInstr (ST FF64 reg _) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" + +-- no distinction is made between signed and unsigned bytes on stores for the +-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), +-- so we call a special-purpose pprSize for ST.. +pprInstr (ST size reg addr) + = hcat [ + ptext (sLit "\tst"), + pprStSize size, + char '\t', + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + rbrack + ] + + +pprInstr (ADD x cc reg1 ri reg2) + | not x && not cc && riZero ri + = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] + + | otherwise + = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 + + +pprInstr (SUB x cc reg1 ri reg2) + | not x && cc && reg2 == g0 + = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ] + + | not x && not cc && riZero ri + = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] + + | otherwise + = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 + +pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 + +pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 + +pprInstr (OR b reg1 ri reg2) + | not b && reg1 == g0 + = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ] + in case ri of + RIReg rrr | rrr == reg2 -> empty + _ -> doit + + | otherwise + = pprRegRIReg (sLit "or") b reg1 ri reg2 + +pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2 + +pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2 +pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2 + +pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 +pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 +pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 + +pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd +pprInstr (WRY reg1 reg2) + = ptext (sLit "\twr\t") + <> pprReg reg1 + <> char ',' + <> pprReg reg2 + <> char ',' + <> ptext (sLit "%y") + +pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 +pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 +pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2 +pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 + +pprInstr (SETHI imm reg) + = hcat [ + ptext (sLit "\tsethi\t"), + pprImm imm, + comma, + pprReg reg + ] + +pprInstr NOP + = ptext (sLit "\tnop") + +pprInstr (FABS size reg1 reg2) + = pprSizeRegReg (sLit "fabs") size reg1 reg2 + +pprInstr (FADD size reg1 reg2 reg3) + = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3 + +pprInstr (FCMP e size reg1 reg2) + = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2 + +pprInstr (FDIV size reg1 reg2 reg3) + = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3 + +pprInstr (FMOV size reg1 reg2) + = pprSizeRegReg (sLit "fmov") size reg1 reg2 + +pprInstr (FMUL size reg1 reg2 reg3) + = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3 + +pprInstr (FNEG size reg1 reg2) + = pprSizeRegReg (sLit "fneg") size reg1 reg2 + +pprInstr (FSQRT size reg1 reg2) + = pprSizeRegReg (sLit "fsqrt") size reg1 reg2 + +pprInstr (FSUB size reg1 reg2 reg3) + = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3 + +pprInstr (FxTOy size1 size2 reg1 reg2) + = hcat [ + ptext (sLit "\tf"), + ptext + (case size1 of + II32 -> sLit "ito" + FF32 -> sLit "sto" + FF64 -> sLit "dto" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + ptext + (case size2 of + II32 -> sLit "i\t" + II64 -> sLit "x\t" + FF32 -> sLit "s\t" + FF64 -> sLit "d\t" + _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), + pprReg reg1, comma, pprReg reg2 + ] + + +pprInstr (BI cond b blockid) + = hcat [ + ptext (sLit "\tb"), pprCond cond, + if b then pp_comma_a else empty, + char '\t', + ppr (mkAsmTempLabel (getUnique blockid)) + ] + +pprInstr (BF cond b blockid) + = hcat [ + ptext (sLit "\tfb"), pprCond cond, + if b then pp_comma_a else empty, + char '\t', + ppr (mkAsmTempLabel (getUnique blockid)) + ] + +pprInstr (JMP addr) = ptext (sLit "\tjmp\t") <> pprAddr addr +pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) + +pprInstr (CALL (Left imm) n _) + = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] + +pprInstr (CALL (Right reg) n _) + = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ] + + +-- | Pretty print a RI +pprRI :: RI -> SDoc +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + + +-- | Pretty print a two reg instruction. +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> SDoc +pprSizeRegReg name size reg1 reg2 + = hcat [ + char '\t', + ptext name, + (case size of + FF32 -> ptext (sLit "s\t") + FF64 -> ptext (sLit "d\t") + _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"), + + pprReg reg1, + comma, + pprReg reg2 + ] + + +-- | Pretty print a three reg instruction. +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc +pprSizeRegRegReg name size reg1 reg2 reg3 + = hcat [ + char '\t', + ptext name, + (case size of + FF32 -> ptext (sLit "s\t") + FF64 -> ptext (sLit "d\t") + _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"), + pprReg reg1, + comma, + pprReg reg2, + comma, + pprReg reg3 + ] + + +-- | Pretty print an instruction of two regs and a ri. +pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> SDoc +pprRegRIReg name b reg1 ri reg2 + = hcat [ + char '\t', + ptext name, + if b then ptext (sLit "cc\t") else char '\t', + pprReg reg1, + comma, + pprRI ri, + comma, + pprReg reg2 + ] + +{- +pprRIReg :: LitString -> Bool -> RI -> Reg -> SDoc +pprRIReg name b ri reg1 + = hcat [ + char '\t', + ptext name, + if b then ptext (sLit "cc\t") else char '\t', + pprRI ri, + comma, + pprReg reg1 + ] +-} + +{- +pp_ld_lbracket :: SDoc +pp_ld_lbracket = ptext (sLit "\tld\t[") +-} + +pp_rbracket_comma :: SDoc +pp_rbracket_comma = text "]," + + +pp_comma_lbracket :: SDoc +pp_comma_lbracket = text ",[" + + +pp_comma_a :: SDoc +pp_comma_a = text ",a" + diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs new file mode 100644 index 00000000..394389c4 --- /dev/null +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -0,0 +1,266 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1994-2004 +-- +-- ----------------------------------------------------------------------------- + +module SPARC.Regs ( + -- registers + showReg, + virtualRegSqueeze, + realRegSqueeze, + classOfRealReg, + allRealRegs, + + -- machine specific info + gReg, iReg, lReg, oReg, fReg, + fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, + + -- allocatable + allocatableRegs, + + -- args + argRegs, + allArgRegs, + callClobberedRegs, + + -- + mkVirtualReg, + regDotColor +) + +where + + +import CodeGen.Platform.SPARC +import Reg +import RegClass +import Size + +import Unique +import Outputable +import FastTypes +import FastBool + +{- + The SPARC has 64 registers of interest; 32 integer registers and 32 + floating point registers. The mapping of STG registers to SPARC + machine registers is defined in StgRegs.h. We are, of course, + prepared for any eventuality. + + The whole fp-register pairing thing on sparcs is a huge nuisance. See + includes/stg/MachRegs.h for a description of what's going on + here. +-} + + +-- | Get the standard name for the register with this number. +showReg :: RegNo -> String +showReg n + | n >= 0 && n < 8 = "%g" ++ show n + | n >= 8 && n < 16 = "%o" ++ show (n-8) + | n >= 16 && n < 24 = "%l" ++ show (n-16) + | n >= 24 && n < 32 = "%i" ++ show (n-24) + | n >= 32 && n < 64 = "%f" ++ show (n-32) + | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" + + +-- Get the register class of a certain real reg +classOfRealReg :: RealReg -> RegClass +classOfRealReg reg + = case reg of + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble + + +-- | regSqueeze_class reg +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) + _other -> _ILIT(0) + + RcFloat + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(2) + _other -> _ILIT(0) + + RcDouble + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(1) + _other -> _ILIT(0) + + _other -> _ILIT(0) + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> FastInt + +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(2) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(1) + + _other -> _ILIT(0) + +-- | All the allocatable registers in the machine, +-- including register pairs. +allRealRegs :: [RealReg] +allRealRegs + = [ (RealRegSingle i) | i <- [0..63] ] + ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] + + +-- | Get the regno for this sort of reg +gReg, lReg, iReg, oReg, fReg :: Int -> RegNo + +gReg x = x -- global regs +oReg x = (8 + x) -- output regs +lReg x = (16 + x) -- local regs +iReg x = (24 + x) -- input regs +fReg x = (32 + x) -- float regs + + +-- | Some specific regs used by the code generator. +g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg + +f6 = RegReal (RealRegSingle (fReg 6)) +f8 = RegReal (RealRegSingle (fReg 8)) +f22 = RegReal (RealRegSingle (fReg 22)) +f26 = RegReal (RealRegSingle (fReg 26)) +f27 = RegReal (RealRegSingle (fReg 27)) + +-- g0 is always zero, and writes to it vanish. +g0 = RegReal (RealRegSingle (gReg 0)) +g1 = RegReal (RealRegSingle (gReg 1)) +g2 = RegReal (RealRegSingle (gReg 2)) + +-- FP, SP, int and float return (from C) regs. +fp = RegReal (RealRegSingle (iReg 6)) +sp = RegReal (RealRegSingle (oReg 6)) +o0 = RegReal (RealRegSingle (oReg 0)) +o1 = RegReal (RealRegSingle (oReg 1)) +f0 = RegReal (RealRegSingle (fReg 0)) +f1 = RegReal (RealRegSingle (fReg 1)) + +-- | Produce the second-half-of-a-double register given the first half. +{- +fPair :: Reg -> Maybe Reg +fPair (RealReg n) + | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) + +fPair (VirtualRegD u) + = Just (VirtualRegHi u) + +fPair reg + = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) + Nothing +-} + + +-- | All the regs that the register allocator can allocate to, +-- with the the fixed use regs removed. +-- +allocatableRegs :: [RealReg] +allocatableRegs + = let isFree rr + = case rr of + RealRegSingle r + -> isFastTrue (freeReg r) + + RealRegPair r1 r2 + -> isFastTrue (freeReg r1) + && isFastTrue (freeReg r2) + + in filter isFree allRealRegs + + +-- | The registers to place arguments for function calls, +-- for some number of arguments. +-- +argRegs :: RegNo -> [Reg] +argRegs r + = case r of + 0 -> [] + 1 -> map (RegReal . RealRegSingle . oReg) [0] + 2 -> map (RegReal . RealRegSingle . oReg) [0,1] + 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] + 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] + 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] + 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] + _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" + + +-- | All all the regs that could possibly be returned by argRegs +-- +allArgRegs :: [Reg] +allArgRegs + = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] + + +-- These are the regs that we cannot assume stay alive over a C call. +-- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 +-- +callClobberedRegs :: [Reg] +callClobberedRegs + = map (RegReal . RealRegSingle) + ( oReg 7 : + [oReg i | i <- [0..5]] ++ + [gReg i | i <- [1..7]] ++ + [fReg i | i <- [0..31]] ) + + + +-- | Make a virtual reg with this size. +mkVirtualReg :: Unique -> Size -> VirtualReg +mkVirtualReg u size + | not (isFloatSize size) + = VirtualRegI u + + | otherwise + = case size of + FF32 -> VirtualRegF u + FF64 -> VirtualRegD u + _ -> panic "mkVReg" + + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + _other -> text "green" diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs new file mode 100644 index 00000000..123a3451 --- /dev/null +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -0,0 +1,69 @@ +module SPARC.ShortcutJump ( + JumpDest(..), getJumpDestBlockId, + canShortcut, + shortcutJump, + shortcutStatics, + shortBlockId +) + +where + +import SPARC.Instr +import SPARC.Imm + +import CLabel +import BlockId +import Cmm + +import Panic +import Unique + + + +data JumpDest + = DestBlockId BlockId + | DestImm Imm + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other + + + +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) +-- slightly dodgy, we're ignoring the second label, but this +-- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + + +shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel +shortBlockId fn blockid = + case fn blockid of + Nothing -> mkAsmTempLabel (getUnique blockid) + Just (DestBlockId blockid') -> shortBlockId fn blockid' + Just (DestImm (ImmCLbl lbl)) -> lbl + _other -> panic "shortBlockId" diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs new file mode 100644 index 00000000..629b1878 --- /dev/null +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -0,0 +1,57 @@ +module SPARC.Stack ( + spRel, + fpRel, + spillSlotToOffset, + maxSpillSlots +) + +where + +import SPARC.AddrMode +import SPARC.Regs +import SPARC.Base +import SPARC.Imm + +import DynFlags +import Outputable + +-- | Get an AddrMode relative to the address in sp. +-- This gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. +-- +spRel :: Int -- ^ stack offset in words, positive or negative + -> AddrMode + +spRel n = AddrRegImm sp (ImmInt (n * wordLength)) + + +-- | Get an address relative to the frame pointer. +-- This doesn't work work for offsets greater than 13 bits; we just hope for the best +-- +fpRel :: Int -> AddrMode +fpRel n + = AddrRegImm fp (ImmInt (n * wordLength)) + + +-- | Convert a spill slot number to a *byte* offset, with no sign. +-- +spillSlotToOffset :: DynFlags -> Int -> Int +spillSlotToOffset dflags slot + | slot >= 0 && slot < maxSpillSlots dflags + = 64 + spillSlotSize * slot + + | otherwise + = pprPanic "spillSlotToOffset:" + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) + + +-- | The maximum number of spill slots available on the C stack. +-- If we use up all of the slots, then we're screwed. +-- +-- Why do we reserve 64 bytes, instead of using the whole thing?? +-- -- BL 2009/02/15 +-- +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs new file mode 100644 index 00000000..8fe590f1 --- /dev/null +++ b/compiler/nativeGen/Size.hs @@ -0,0 +1,105 @@ +-- | Sizes on this architecture +-- A Size is a combination of width and class +-- +-- TODO: Rename this to "Format" instead of "Size" to reflect +-- the fact that it represents floating point vs integer. +-- +-- TODO: Signed vs unsigned? +-- +-- TODO: This module is currenly shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. +-- +module Size ( + Size(..), + intSize, + floatSize, + isFloatSize, + cmmTypeSize, + sizeToWidth, + sizeInBytes +) + +where + +import Cmm +import Outputable + +-- It looks very like the old MachRep, but it's now of purely local +-- significance, here in the native code generator. You can change it +-- without global consequences. +-- +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b +-- where the Size field encodes the ".l" part. + +-- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes +-- here. I've removed them from the x86 version, we'll see what happens --SDM + +-- ToDo: quite a few occurrences of Size could usefully be replaced by Width + +data Size + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + | FF80 + deriving (Show, Eq) + + +-- | Get the integer size of this width. +intSize :: Width -> Size +intSize width + = case width of + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> pprPanic "Size.intSize" (ppr other) + + +-- | Get the float size of this width. +floatSize :: Width -> Size +floatSize width + = case width of + W32 -> FF32 + W64 -> FF64 + other -> pprPanic "Size.floatSize" (ppr other) + + +-- | Check if a size represents a floating point value. +isFloatSize :: Size -> Bool +isFloatSize size + = case size of + FF32 -> True + FF64 -> True + FF80 -> True + _ -> False + + +-- | Convert a Cmm type to a Size. +cmmTypeSize :: CmmType -> Size +cmmTypeSize ty + | isFloatType ty = floatSize (typeWidth ty) + | otherwise = intSize (typeWidth ty) + + +-- | Get the Width of a Size. +sizeToWidth :: Size -> Width +sizeToWidth size + = case size of + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + FF80 -> W80 + +sizeInBytes :: Size -> Int +sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs new file mode 100644 index 00000000..96c17777 --- /dev/null +++ b/compiler/nativeGen/TargetReg.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} +-- | Hard wired things related to registers. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. +-- +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. +-- +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable +module TargetReg ( + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg +) + +where + +#include "HsVersions.h" + +import Reg +import RegClass +import Size + +import Outputable +import Unique +import FastTypes +import Platform + +import qualified X86.Regs as X86 +import qualified X86.RegInfo as X86 + +import qualified PPC.Regs as PPC + +import qualified SPARC.Regs as SPARC + +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.virtualRegSqueeze + ArchX86_64 -> X86.virtualRegSqueeze + ArchPPC -> PPC.virtualRegSqueeze + ArchSPARC -> SPARC.virtualRegSqueeze + ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" + ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" + ArchARM64 -> panic "targetVirtualRegSqueeze ArchARM64" + ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" + ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + + +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.realRegSqueeze + ArchX86_64 -> X86.realRegSqueeze + ArchPPC -> PPC.realRegSqueeze + ArchSPARC -> SPARC.realRegSqueeze + ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" + ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" + ArchARM64 -> panic "targetRealRegSqueeze ArchARM64" + ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" + ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" + ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" + ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" + ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" + +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of + ArchX86 -> X86.classOfRealReg platform + ArchX86_64 -> X86.classOfRealReg platform + ArchPPC -> PPC.classOfRealReg + ArchSPARC -> SPARC.classOfRealReg + ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" + ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" + ArchARM64 -> panic "targetClassOfRealReg ArchARM64" + ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" + ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" + ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" + ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" + ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" + +targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of + ArchX86 -> X86.mkVirtualReg + ArchX86_64 -> X86.mkVirtualReg + ArchPPC -> PPC.mkVirtualReg + ArchSPARC -> SPARC.mkVirtualReg + ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" + ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" + ArchARM64 -> panic "targetMkVirtualReg ArchARM64" + ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" + ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" + ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" + ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" + ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" + +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform + ArchPPC -> PPC.regDotColor + ArchSPARC -> SPARC.regDotColor + ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" + ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" + ArchARM64 -> panic "targetRegDotColor ArchARM64" + ArchAlpha -> panic "targetRegDotColor ArchAlpha" + ArchMipseb -> panic "targetRegDotColor ArchMipseb" + ArchMipsel -> panic "targetRegDotColor ArchMipsel" + ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" + ArchUnknown -> panic "targetRegDotColor ArchUnknown" + + +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg + = case reg of + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs new file mode 100644 index 00000000..531213dc --- /dev/null +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -0,0 +1,3002 @@ +{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, the +-- structure should not be too overwhelming. + +module X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) + +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" +#include "../includes/MachDeps.h" + +-- NCG stuff: +import X86.Instr +import X86.Cond +import X86.Regs +import X86.RegInfo +import CodeGen.Platform +import CPrim +import Debug ( DebugBlock(..) ) +import Instruction +import PIC +import NCGMonad +import Size +import Reg +import Platform + +-- Our intermediate code: +import BasicTypes +import BlockId +import Module ( primPackageKey ) +import PprCmm () +import CmmUtils +import Cmm +import Hoopl +import CLabel +import CoreSyn ( Tickish(..) ) +import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import ForeignCall ( CCallConv(..) ) +import OrdList +import Outputable +import Unique +import FastString +import FastBool ( isFastTrue ) +import DynFlags +import Util + +import Control.Monad +import Data.Bits +import Data.Int +import Data.Maybe +import Data.Word + +is32BitPlatform :: NatM Bool +is32BitPlatform = do + dflags <- getDynFlags + return $ target32Bit (targetPlatform dflags) + +sse2Enabled :: NatM Bool +sse2Enabled = do + dflags <- getDynFlags + return (isSse2Enabled dflags) + +sse4_2Enabled :: NatM Bool +sse4_2Enabled = do + dflags <- getDynFlags + return (isSse4_2Enabled dflags) + +if_sse2 :: NatM a -> NatM a -> NatM a +if_sse2 sse2 x87 = do + b <- sse2Enabled + if b then sse2 else x87 + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + dflags <- getDynFlags + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS $ targetPlatform dflags + + case picBaseMb of + Just picBase -> initializePicBase_x86 ArchX86 os picBase tops + Nothing -> return tops + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic + + +basicBlockCodeGen + :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl (Alignment, CmmStatics) Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span name) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col name + _ -> return nilOL + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + + +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock +stmtsToInstrs stmts + = do instrss <- mapM stmtToInstrs stmts + return (concatOL instrss) + + +stmtToInstrs :: CmmNode e x -> NatM InstrBlock +stmtToInstrs stmt = do + dflags <- getDynFlags + is32Bit <- is32BitPlatform + case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + CmmUnwind {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode size reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType dflags reg + size = cmmTypeSize ty + + CmmStore addr src + | isFloatType ty -> assignMem_FltCode size addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType dflags src + size = cmmTypeSize ty + + CmmUnsafeForeignCall target result_regs args + -> genCCall dflags is32Bit target result_regs args + + CmmBranch id -> genBranch id + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) + CmmSwitch arg ids -> do dflags <- getDynFlags + genSwitch dflags arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> do + dflags <- getDynFlags + genJump arg (jumpRegs dflags gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + + +jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] +jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] + where platform = targetPlatform dflags + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | a.k.a "Register64" +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. +-- +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified +-- +data ChildCode64 + = ChildCode64 + InstrBlock + Reg + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Size -> Register +swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code +swizzleRegisterRep (Any _ codefn) size = Any size codefn + + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> Bool -> CmmReg -> Reg + +getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk)) + = let sz = cmmTypeSize pk in + if isFloatSize sz && not use_sse2 + then RegVirtual (mkVirtualReg u FF80) + else RegVirtual (mkVirtualReg u sz) + +getRegisterReg platform _ (CmmGlobal mid) + = case globalRegMaybe platform mid of + Just reg -> RegReal $ reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + + +-- | Memory addressing modes passed up the tree. +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to an CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr +mangleIndexTree dflags reg off + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + Amode addr addr_code <- getAmode addrTree + ChildCode64 vcode rlo <- iselExpr64 valueTree + let + rhi = getHiVRegFromLo rlo + + -- Little-endian store + mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) + mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let + r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(i386): invalid lvalue" + + +iselExpr64 :: CmmExpr -> NatM ChildCode64 +iselExpr64 (CmmLit (CmmInt i _)) = do + (rlo,rhi) <- getNewRegPairNat II32 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do + Amode addr addr_code <- getAmode addrTree + (rlo,rhi) <- getNewRegPairNat II32 + let + mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) + mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) + return ( + ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo + ) + +iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty + = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) + +-- we handle addition, but rather badly +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + (rlo,rhi) <- getNewRegPairNat II32 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + r1hi = getHiVRegFromLo r1lo + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do + fn <- getAnyReg expr + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + code = fn r_dst_lo + return ( + ChildCode64 (code `snocOL` + MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) + r_dst_lo + ) + +iselExpr64 expr + = pprPanic "iselExpr64(i386)" (ppr expr) + + +-------------------------------------------------------------------------------- +getRegister :: CmmExpr -> NatM Register +getRegister e = do dflags <- getDynFlags + is32Bit <- is32BitPlatform + getRegister' dflags is32Bit e + +getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register + +getRegister' dflags is32Bit (CmmReg reg) + = case reg of + CmmGlobal PicBaseReg + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat (archWordSize is32Bit) + return (Fixed (archWordSize is32Bit) reg' nilOL) + _ -> + do use_sse2 <- sse2Enabled + let + sz = cmmTypeSize (cmmRegType dflags reg) + size | not use_sse2 && isFloatSize sz = FF80 + | otherwise = sz + -- + let platform = targetPlatform dflags + return (Fixed size (getRegisterReg platform use_sse2 reg) nilOL) + + +getRegister' dflags is32Bit (CmmRegOff r n) + = getRegister' dflags is32Bit $ mangleIndexTree dflags r n + +-- for 32-bit architectuers, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 (getHiVRegFromLo rlo) code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do + ChildCode64 code rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = + if_sse2 float_const_sse2 float_const_x87 + where + float_const_sse2 + | f == 0.0 = do + let + size = floatSize w + code dst = unitOL (XOR size (OpReg dst) (OpReg dst)) + -- I don't know why there are xorpd, xorps, and pxor instructions. + -- They all appear to do the same thing --SDM + return (Any size code) + + | otherwise = do + Amode addr code <- memConstant (widthInBytes w) lit + loadFloatAmode True w addr code + + float_const_x87 = case w of + W64 + | f == 0.0 -> + let code dst = unitOL (GLDZ dst) + in return (Any FF80 code) + + | f == 1.0 -> + let code dst = unitOL (GLD1 dst) + in return (Any FF80 code) + + _otherwise -> do + Amode addr code <- memConstant (widthInBytes w) lit + loadFloatAmode False w addr code + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II32 code) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II32) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), + CmmLit displacement]) + | not is32Bit = do + return $ Any II64 (\dst -> unitOL $ + LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) + +getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps + sse2 <- sse2Enabled + case mop of + MO_F_Neg w + | sse2 -> sse2NegCode w x + | otherwise -> trivialUFCode FF80 (GNEG FF80) x + + MO_S_Neg w -> triv_ucode NEGI (intSize w) + MO_Not w -> triv_ucode NOT (intSize w) + + -- Nop conversions + MO_UU_Conv W32 W8 -> toI8Reg W32 x + MO_SS_Conv W32 W8 -> toI8Reg W32 x + MO_UU_Conv W16 W8 -> toI8Reg W16 x + MO_SS_Conv W16 W8 -> toI8Reg W16 x + MO_UU_Conv W32 W16 -> toI16Reg W32 x + MO_SS_Conv W32 W16 -> toI16Reg W32 x + + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + + MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x + MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x + + -- widenings + MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x + MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x + MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x + + MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x + MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x + + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. + + MO_FF_Conv W32 W64 + | sse2 -> coerceFP2FP W64 x + | otherwise -> conversionNop FF80 x + + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x + + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x + + MO_V_Insert {} -> needLlvm + MO_V_Extract {} -> needLlvm + MO_V_Add {} -> needLlvm + MO_V_Sub {} -> needLlvm + MO_V_Mul {} -> needLlvm + MO_VS_Quot {} -> needLlvm + MO_VS_Rem {} -> needLlvm + MO_VS_Neg {} -> needLlvm + MO_VU_Quot {} -> needLlvm + MO_VU_Rem {} -> needLlvm + MO_VF_Insert {} -> needLlvm + MO_VF_Extract {} -> needLlvm + MO_VF_Add {} -> needLlvm + MO_VF_Sub {} -> needLlvm + MO_VF_Mul {} -> needLlvm + MO_VF_Quot {} -> needLlvm + MO_VF_Neg {} -> needLlvm + + _other -> pprPanic "getRegister" (pprMachOp mop) + where + triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register + triv_ucode instr size = trivialUCode size (instr size) x + + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intSize from) (OpReg reg) (OpReg dst) + return (Any (intSize to) code) + + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr + = do codefn <- getAnyReg expr + return (Any (intSize new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. + + toI16Reg = toI8Reg -- for now + + conversionNop :: Size -> CmmExpr -> NatM Register + conversionNop new_size expr + = do e_code <- getRegister' dflags is32Bit expr + return (swizzleRegisterRep e_code new_size) + + +getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps + sse2 <- sse2Enabled + case mop of + MO_F_Eq _ -> condFltReg is32Bit EQQ x y + MO_F_Ne _ -> condFltReg is32Bit NE x y + MO_F_Gt _ -> condFltReg is32Bit GTT x y + MO_F_Ge _ -> condFltReg is32Bit GE x y + MO_F_Lt _ -> condFltReg is32Bit LTT x y + MO_F_Le _ -> condFltReg is32Bit LE x y + + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt _ -> condIntReg GU x y + MO_U_Ge _ -> condIntReg GEU x y + MO_U_Lt _ -> condIntReg LU x y + MO_U_Le _ -> condIntReg LEU x y + + MO_F_Add w | sse2 -> trivialFCode_sse2 w ADD x y + | otherwise -> trivialFCode_x87 GADD x y + MO_F_Sub w | sse2 -> trivialFCode_sse2 w SUB x y + | otherwise -> trivialFCode_x87 GSUB x y + MO_F_Quot w | sse2 -> trivialFCode_sse2 w FDIV x y + | otherwise -> trivialFCode_x87 GDIV x y + MO_F_Mul w | sse2 -> trivialFCode_sse2 w MUL x y + | otherwise -> trivialFCode_x87 GMUL x y + + MO_Add rep -> add_code rep x y + MO_Sub rep -> sub_code rep x y + + MO_S_Quot rep -> div_code rep True True x y + MO_S_Rem rep -> div_code rep True False x y + MO_U_Quot rep -> div_code rep False True x y + MO_U_Rem rep -> div_code rep False False x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_Mul rep -> triv_op rep IMUL + MO_And rep -> triv_op rep AND + MO_Or rep -> triv_op rep OR + MO_Xor rep -> triv_op rep XOR + + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} + MO_Shl rep -> shift_code rep SHL x y {-False-} + MO_U_Shr rep -> shift_code rep SHR x y {-False-} + MO_S_Shr rep -> shift_code rep SAR x y {-False-} + + MO_V_Insert {} -> needLlvm + MO_V_Extract {} -> needLlvm + MO_V_Add {} -> needLlvm + MO_V_Sub {} -> needLlvm + MO_V_Mul {} -> needLlvm + MO_VS_Quot {} -> needLlvm + MO_VS_Rem {} -> needLlvm + MO_VS_Neg {} -> needLlvm + MO_VF_Insert {} -> needLlvm + MO_VF_Extract {} -> needLlvm + MO_VF_Add {} -> needLlvm + MO_VF_Sub {} -> needLlvm + MO_VF_Mul {} -> needLlvm + MO_VF_Quot {} -> needLlvm + MO_VF_Neg {} -> needLlvm + + _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) + where + -------------------- + triv_op width instr = trivialCode width op (Just op) x y + where op = instr (intSize width) + + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + imulMayOflo rep a b = do + (a_reg, a_code) <- getNonClobberedReg a + b_code <- getAnyReg b + let + shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + size = intSize rep + code = a_code `appOL` b_code eax `appOL` + toOL [ + IMUL2 size (OpReg a_reg), -- result in %edx:%eax + SAR size (OpImm (ImmInt shift_amt)) (OpReg eax), + -- sign extend lower part + SUB size (OpReg edx) (OpReg eax) + -- compare against upper + -- eax==0 if high part == sign extended low part + ] + return (Fixed size eax code) + + -------------------- + shift_code :: Width + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + + {- Case1: shift length as immediate -} + shift_code width instr x (CmmLit lit) = do + x_code <- getAnyReg x + let + size = intSize width + code dst + = x_code dst `snocOL` + instr size (OpImm (litToImm lit)) (OpReg dst) + return (Any size code) + + {- Case2: shift length is complex (non-immediate) + * y must go in %ecx. + * we cannot do y first *and* put its result in %ecx, because + %ecx might be clobbered by x. + * if we do y second, then x cannot be + in a clobbered reg. Also, we cannot clobber x's reg + with the instruction itself. + * so we can either: + - do y first, put its result in a fresh tmp, then copy it to %ecx later + - do y second and put its result into %ecx. x gets placed in a fresh + tmp. This is likely to be better, because the reg alloc can + eliminate this reg->reg move here (it won't eliminate the other one, + because the move is into the fixed %ecx). + -} + shift_code width instr x y{-amount-} = do + x_code <- getAnyReg x + let size = intSize width + tmp <- getNewRegNat size + y_code <- getAnyReg y + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr size (OpReg ecx) (OpReg tmp) + return (Fixed size tmp code) + + -------------------- + add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + add_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger y = add_int rep x y + add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y + where size = intSize rep + -- TODO: There are other interesting patterns we want to replace + -- with a LEA, e.g. `(x + offset) + (y << shift)`. + + -------------------- + sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + sub_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger (-y) = add_int rep x (-y) + sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y + + -- our three-operand add instruction: + add_int width x y = do + (x_reg, x_code) <- getSomeReg x + let + size = intSize width + imm = ImmInt (fromInteger y) + code dst + = x_code `snocOL` + LEA size + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + (OpReg dst) + -- + return (Any size code) + + ---------------------- + div_code width signed quotient x y = do + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + size = intSize width + widen | signed = CLTD size + | otherwise = XOR size (OpReg edx) (OpReg edx) + + instr | signed = IDIV + | otherwise = DIV + + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr size y_op] + + result | quotient = eax + | otherwise = edx + + return (Fixed size result code) + + +getRegister' _ _ (CmmLoad mem pk) + | isFloatType pk + = do + Amode addr mem_code <- getAmode mem + use_sse2 <- sse2Enabled + loadFloatAmode use_sse2 (typeWidth pk) addr mem_code + +getRegister' _ is32Bit (CmmLoad mem pk) + | is32Bit && not (isWord64 pk) + = do + code <- intLoadCode instr mem + return (Any size code) + where + width = typeWidth pk + size = intSize width + instr = case width of + W8 -> MOVZxL II8 + _other -> MOV size + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. + +-- Simpler memory load code on x86_64 +getRegister' _ is32Bit (CmmLoad mem pk) + | not is32Bit + = do + code <- intLoadCode (MOV size) mem + return (Any size code) + where size = intSize $ typeWidth pk + +getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) + = let + size = intSize width + + -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits + size1 = if is32Bit then size + else case size of + II64 -> II32 + _ -> size + code dst + = unitOL (XOR size1 (OpReg dst) (OpReg dst)) + in + return (Any size code) + + -- optimisation for loading small literals on x86_64: take advantage + -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit + -- instruction forms are shorter. +getRegister' dflags is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit) + = let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) + in + return (Any II64 code) + where + isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff + isBigLit _ = False + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model (see gcc docs, -mcmodel=small). + +getRegister' dflags _ (CmmLit lit) + = do let size = cmmTypeSize (cmmLitType dflags lit) + imm = litToImm lit + code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) + return (Any size code) + +getRegister' _ _ other + | isVecExpr other = needLlvm + | otherwise = pprPanic "getRegister(x86)" (ppr other) + + +intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr + -> NatM (Reg -> InstrBlock) +intLoadCode instr mem = do + Amode src mem_code <- getAmode mem + return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) + +-- Compute an expression into *any* register, adding the appropriate +-- move instruction if necessary. +getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock) +getAnyReg expr = do + r <- getRegister expr + anyReg r + +anyReg :: Register -> NatM (Reg -> InstrBlock) +anyReg (Any _ code) = return code +anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst) + +-- A bit like getSomeReg, but we want a reg that can be byte-addressed. +-- Fixed registers might not be byte-addressable, so we make sure we've +-- got a temporary, inserting an extra reg copy if necessary. +getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) +getByteReg expr = do + is32Bit <- is32BitPlatform + if is32Bit + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 + +-- Another variant: this time we want the result in a register that cannot +-- be modified by code to evaluate an arbitrary expression. +getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) +getNonClobberedReg expr = do + dflags <- getDynFlags + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + -- only certain regs can be clobbered + | reg `elem` instrClobberedRegs (targetPlatform dflags) + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + | otherwise -> + return (reg, code) + +reg2reg :: Size -> Reg -> Reg -> Instr +reg2reg size src dst + | size == FF80 = GMOV src dst + | otherwise = MOV size (OpReg src) (OpReg dst) + + +-------------------------------------------------------------------------------- +getAmode :: CmmExpr -> NatM Amode +getAmode e = do is32Bit <- is32BitPlatform + getAmode' is32Bit e + +getAmode' :: Bool -> CmmExpr -> NatM Amode +getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags + getAmode $ mangleIndexTree dflags r n + +getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), + CmmLit displacement]) + | not is32Bit + = return $ Amode (ripRel (litToImm displacement)) nilOL + + +-- This is all just ridiculous, since it carefully undoes +-- what mangleIndexTree has just done. +getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) + | is32BitLit is32Bit lit + -- ASSERT(rep == II32)??? + = do (x_reg, x_code) <- getSomeReg x + let off = ImmInt (-(fromInteger i)) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + +getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) + | is32BitLit is32Bit lit + -- ASSERT(rep == II32)??? + = do (x_reg, x_code) <- getSomeReg x + let off = litToImm lit + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + +-- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be +-- recognised by the next rule. +getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), + b@(CmmLit _)]) + = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) + +-- Matches: (x + offset) + (y << shift) +getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset, + CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + = x86_complex_amode (CmmReg x) y shift (fromIntegral offset) + +getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + = x86_complex_amode x y shift 0 + +getAmode' _ (CmmMachOp (MO_Add _) + [x, CmmMachOp (MO_Add _) + [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], + CmmLit (CmmInt offset _)]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + && is32BitInteger offset + = x86_complex_amode x y shift offset + +getAmode' _ (CmmMachOp (MO_Add _) [x,y]) + = x86_complex_amode x y 0 0 + +getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit + = return (Amode (ImmAddr (litToImm lit) 0) nilOL) + +getAmode' _ expr = do + (reg,code) <- getSomeReg expr + return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) + +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode +getSimpleAmode dflags is32Bit addr + | is32Bit = do + addr_code <- getAnyReg addr + addr_r <- getNewRegNat (intSize (wordWidth dflags)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + | otherwise = getAmode addr + +x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode +x86_complex_amode base index shift offset + = do (x_reg, x_code) <- getNonClobberedReg base + -- x must be in a temp, because it has to stay live over y_code + -- we could compre x_reg and y_reg and do something better here... + (y_reg, y_code) <- getSomeReg index + let + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; + n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) + code) + + + + +-- ----------------------------------------------------------------------------- +-- getOperand: sometimes any operand will do. + +-- getNonClobberedOperand: the value of the operand will remain valid across +-- the computation of an arbitrary expression, unless the expression +-- is computed directly into a register which the operand refers to +-- (see trivialCode where this function is used for an example). + +getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand (CmmLit lit) = do + use_sse2 <- sse2Enabled + if use_sse2 && isSuitableFloatingPointLit lit + then do + let CmmFloat _ w = lit + Amode addr code <- memConstant (widthInBytes w) lit + return (OpAddr addr, code) + else do + + is32Bit <- is32BitPlatform + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) + then return (OpImm (litToImm lit), nilOL) + else getNonClobberedOperand_generic (CmmLit lit) + +getNonClobberedOperand (CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + use_sse2 <- sse2Enabled + if (not (isFloatType pk) || use_sse2) + && (if is32Bit then not (isWord64 pk) else True) + then do + dflags <- getDynFlags + let platform = targetPlatform dflags + Amode src mem_code <- getAmode mem + (src',save_code) <- + if (amodeCouldBeClobbered platform src) + then do + tmp <- getNewRegNat (archWordSize is32Bit) + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA (archWordSize is32Bit) (OpAddr src) (OpReg tmp))) + else + return (src, nilOL) + return (OpAddr src', mem_code `appOL` save_code) + else do + getNonClobberedOperand_generic (CmmLoad mem pk) + +getNonClobberedOperand e = getNonClobberedOperand_generic e + +getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand_generic e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +amodeCouldBeClobbered :: Platform -> AddrMode -> Bool +amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) + +regClobbered :: Platform -> Reg -> Bool +regClobbered platform (RegReal (RealRegSingle rr)) = isFastTrue (freeReg platform rr) +regClobbered _ _ = False + +-- getOperand: the operand is not required to remain valid across the +-- computation of an arbitrary expression. +getOperand :: CmmExpr -> NatM (Operand, InstrBlock) + +getOperand (CmmLit lit) = do + use_sse2 <- sse2Enabled + if (use_sse2 && isSuitableFloatingPointLit lit) + then do + let CmmFloat _ w = lit + Amode addr code <- memConstant (widthInBytes w) lit + return (OpAddr addr, code) + else do + + is32Bit <- is32BitPlatform + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) + then return (OpImm (litToImm lit), nilOL) + else getOperand_generic (CmmLit lit) + +getOperand (CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + use_sse2 <- sse2Enabled + if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else + getOperand_generic (CmmLoad mem pk) + +getOperand e = getOperand_generic e + +getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getOperand_generic e = do + (reg, code) <- getSomeReg e + return (OpReg reg, code) + +isOperand :: Bool -> CmmExpr -> Bool +isOperand _ (CmmLoad _ _) = True +isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit + || isSuitableFloatingPointLit lit +isOperand _ _ = False + +memConstant :: Int -> CmmLit -> NatM Amode +memConstant align lit = do + lbl <- getNewLabelNat + dflags <- getDynFlags + (addr, addr_code) <- if target32Bit (targetPlatform dflags) + then do dynRef <- cmmMakeDynamicReference + dflags + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) + let code = + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) + `consOL` addr_code + return (Amode addr code) + + +loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register +loadFloatAmode use_sse2 w addr addr_code = do + let size = floatSize w + code dst = addr_code `snocOL` + if use_sse2 + then MOV size (OpAddr addr) (OpReg dst) + else GLD size addr dst + return (Any (if use_sse2 then size else FF80) code) + + +-- if we want a floating-point literal as an operand, we can +-- use it directly from memory. However, if the literal is +-- zero, we're better off generating it into a register using +-- xor. +isSuitableFloatingPointLit :: CmmLit -> Bool +isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 +isSuitableFloatingPointLit _ = False + +getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) +getRegOrMem e@(CmmLoad mem pk) = do + is32Bit <- is32BitPlatform + use_sse2 <- sse2Enabled + if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) +getRegOrMem e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +is32BitLit :: Bool -> CmmLit -> Bool +is32BitLit is32Bit (CmmInt i W64) + | not is32Bit + = -- assume that labels are in the range 0-2^31-1: this assumes the + -- small memory model (see gcc docs, -mcmodel=small). + is32BitInteger i +is32BitLit _ _ = True + + + + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- yes, they really do seem to want exactly the same! + +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + MO_F_Lt W32 -> condFltCode LTT x y + MO_F_Le W32 -> condFltCode LE x y + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode LTT x y + MO_F_Le W64 -> condFltCode LE x y + + _ -> condIntCode (machOpToCond mop) x y + +getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) + +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) + + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x y = do is32Bit <- is32BitPlatform + condIntCode' is32Bit cond x y + +condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +-- memory vs immediate +condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit) + | is32BitLit is32Bit lit = do + Amode x_addr x_code <- getAmode x + let + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr) + -- + return (CondCode False cond code) + +-- anything vs zero, using a mask +-- TODO: Add some sanity checking!!!! +condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) + | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit + = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intSize pk) (OpImm (ImmInteger mask)) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs zero +condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intSize pk) (OpReg x_reg) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs operand +condIntCode' is32Bit cond x y + | isOperand is32Bit y = do + dflags <- getDynFlags + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` y_code `snocOL` + CMP (cmmTypeSize (cmmExprType dflags x)) y_op (OpReg x_reg) + return (CondCode False cond code) +-- operand vs. anything: invert the comparison so that we can use a +-- single comparison instruction. + | isOperand is32Bit x + , Just revcond <- maybeFlipCond cond = do + dflags <- getDynFlags + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getOperand x + let + code = y_code `appOL` x_code `snocOL` + CMP (cmmTypeSize (cmmExprType dflags x)) x_op (OpReg y_reg) + return (CondCode False revcond code) + +-- anything vs anything +condIntCode' _ cond x y = do + dflags <- getDynFlags + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getRegOrMem x + let + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeSize (cmmExprType dflags x)) (OpReg y_reg) x_op + return (CondCode False cond code) + + + +-------------------------------------------------------------------------------- +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +condFltCode cond x y + = if_sse2 condFltCode_sse2 condFltCode_x87 + where + + condFltCode_x87 + = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do + (x_reg, x_code) <- getNonClobberedReg x + (y_reg, y_code) <- getSomeReg y + let + code = x_code `appOL` y_code `snocOL` + GCMP cond x_reg y_reg + -- The GCMP insn does the test and sets the zero flag if comparable + -- and true. Hence we always supply EQQ as the condition to test. + return (CondCode True EQQ code) + + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be + -- an operand, but the right must be a reg. We can probably do better + -- than this general case... + condFltCode_sse2 = do + dflags <- getDynFlags + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` + y_code `snocOL` + CMP (floatSize $ cmmExprWidth dflags x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. + return (CondCode True (condToUnsigned cond) code) + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock + + +-- integer assignment to memory + +-- specific case of adding/subtracting an integer to a particular address. +-- ToDo: catch other cases where we can use an operation directly on a memory +-- address. +assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, + CmmLit (CmmInt i _)]) + | addr == addr2, pk /= II64 || is32BitInteger i, + Just instr <- check op + = do Amode amode code_addr <- getAmode addr + let code = code_addr `snocOL` + instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) + return code + where + check (MO_Add _) = Just ADD + check (MO_Sub _) = Just SUB + check _ = Nothing + -- ToDo: more? + +-- general case +assignMem_IntCode pk addr src = do + is32Bit <- is32BitPlatform + Amode addr code_addr <- getAmode addr + (code_src, op_src) <- get_op_RI is32Bit src + let + code = code_src `appOL` + code_addr `snocOL` + MOV pk op_src (OpAddr addr) + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. + -- + return code + where + get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit + = return (nilOL, OpImm (litToImm lit)) + get_op_RI _ op + = do (reg,code) <- getNonClobberedReg op + return (code, OpReg reg) + + +-- Assign; dst is a reg, rhs is mem +assignReg_IntCode pk reg (CmmLoad src _) = do + load_code <- intLoadCode (MOV pk) src + dflags <- getDynFlags + let platform = targetPlatform dflags + return (load_code (getRegisterReg platform False{-no sse2-} reg)) + +-- dst is a reg, but src could be anything +assignReg_IntCode _ reg src = do + dflags <- getDynFlags + let platform = targetPlatform dflags + code <- getAnyReg src + return (code (getRegisterReg platform False{-no sse2-} reg)) + + +-- Floating point assignment to memory +assignMem_FltCode pk addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + use_sse2 <- sse2Enabled + let + code = src_code `appOL` + addr_code `snocOL` + if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr) + else GST pk src_reg addr + return code + +-- Floating point assignment to a register/temporary +assignReg_FltCode _ reg src = do + use_sse2 <- sse2Enabled + src_code <- getAnyReg src + dflags <- getDynFlags + let platform = targetPlatform dflags + return (src_code (getRegisterReg platform use_sse2 reg)) + + +genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock + +genJump (CmmLoad mem _) regs = do + Amode target code <- getAmode mem + return (code `snocOL` JMP (OpAddr target) regs) + +genJump (CmmLit lit) regs = do + return (unitOL (JMP (OpImm (litToImm lit)) regs)) + +genJump expr regs = do + (reg,code) <- getSomeReg expr + return (code `snocOL` JMP (OpReg reg) regs) + + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +I386: First, we have to ensure that the condition +codes are set according to the supplied comparison operation. +-} + +genCondJump + :: BlockId -- the branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock + +genCondJump id expr = do + is32Bit <- is32BitPlatform + genCondJump' is32Bit id expr + +genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock + +-- 64-bit integer comparisons on 32-bit +genCondJump' is32Bit true (CmmMachOp mop [e1,e2]) + | is32Bit, Just W64 <- maybeIntComparison mop = do + ChildCode64 code1 r1_lo <- iselExpr64 e1 + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r1_hi = getHiVRegFromLo r1_lo + r2_hi = getHiVRegFromLo r2_lo + cond = machOpToCond mop + Just cond' = maybeFlipCond cond + false <- getBlockIdNat + return $ code1 `appOL` code2 `appOL` toOL [ + CMP II32 (OpReg r2_hi) (OpReg r1_hi), + JXX cond true, + JXX cond' false, + CMP II32 (OpReg r2_lo) (OpReg r1_lo), + JXX cond true, + NEWBLOCK false ] + +genCondJump' _ id bool = do + CondCode is_float cond cond_code <- getCondCode bool + use_sse2 <- sse2Enabled + if not is_float || not use_sse2 + then + return (cond_code `snocOL` JXX cond id) + else do + lbl <- getBlockIdNat + + -- see comment with condFltReg + let code = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] + and_ordered = toOL [ + JXX PARITY lbl, + JXX cond id, + JXX ALWAYS lbl, + NEWBLOCK lbl + ] + return (cond_code `appOL` code) + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +genCCall + :: DynFlags + -> Bool -- 32 bit platform? + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +-- Unroll memcpy calls if the source and destination pointers are at +-- least DWORD aligned and the number of bytes to copy isn't too +-- large. Otherwise, call C's memcpy. +genCCall dflags is32Bit (PrimTarget MO_Memcpy) _ + [dst, src, + (CmmLit (CmmInt n _)), + (CmmLit (CmmInt align _))] + | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + return $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r (fromInteger n) + where + -- The number of instructions we will generate (approx). We need 2 + -- instructions per move. + insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) + + size = if align .&. 4 /= 0 then II32 else (archWordSize is32Bit) + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV size (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV size (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall dflags _ (PrimTarget MO_Memset) _ + [dst, + CmmLit (CmmInt c _), + CmmLit (CmmInt n _), + CmmLit (CmmInt align _)] + | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + return $ code_dst dst_r `appOL` go dst_r (fromInteger n) + where + (size, val) = case align .&. 3 of + 2 -> (II16, c2) + 0 -> (II32, c4) + _ -> (II8, c) + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + + -- The number of instructions we will generate (approx). We need 1 + -- instructions per move. + insns = (n + sizeBytes - 1) `div` sizeBytes + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Integer -> OrdList Instr + go dst i + -- TODO: Add movabs instruction and support 64-bit sets. + | i >= sizeBytes = -- This might be smaller than the below sizes + unitOL (MOV size (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL` + go dst (i - sizeBytes) + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL` + go dst (i - 4) + | i >= 2 = + unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL` + go dst (i - 2) + | i >= 1 = + unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL` + go dst (i - 1) + | otherwise = nilOL + where + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL + -- write barrier compiles to no code on x86/x86-64; + -- we keep it this long in order to prevent earlier optimisations. + +genCCall _ _ (PrimTarget MO_Touch) _ _ = return nilOL + +genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] = + case n of + 0 -> genPrefetch src $ PREFETCH NTA size + 1 -> genPrefetch src $ PREFETCH Lvl2 size + 2 -> genPrefetch src $ PREFETCH Lvl1 size + 3 -> genPrefetch src $ PREFETCH Lvl0 size + l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l) + -- the c / llvm prefetch convention is 0, 1, 2, and 3 + -- the x86 corresponding names are : NTA, 2 , 1, and 0 + where + size = archWordSize is32bit + -- need to know what register width for pointers! + genPrefetch inRegSrc prefetchCTor = + do + code_src <- getAnyReg inRegSrc + src_r <- getNewRegNat size + return $ code_src src_r `appOL` + (unitOL (prefetchCTor (OpAddr + ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) + -- prefetch always takes an address + +genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] = do + let platform = targetPlatform dflags + let dst_r = getRegisterReg platform False (CmmLocal dst) + case width of + W64 | is32Bit -> do + ChildCode64 vcode rlo <- iselExpr64 src + let dst_rhi = getHiVRegFromLo dst_r + rhi = getHiVRegFromLo rlo + return $ vcode `appOL` + toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi), + MOV II32 (OpReg rhi) (OpReg dst_r), + BSWAP II32 dst_rhi, + BSWAP II32 dst_r ] + W16 -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` + unitOL (BSWAP II32 dst_r) `appOL` + unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) + _ -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` unitOL (BSWAP size dst_r) + where + size = intSize width + +genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] + args@[src] = do + sse4_2 <- sse4_2Enabled + let platform = targetPlatform dflags + if sse4_2 + then do code_src <- getAnyReg src + src_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) + return $ code_src src_r `appOL` + (if width == W8 then + -- The POPCNT instruction doesn't take a r/m8 + unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` + unitOL (POPCNT II16 (OpReg src_r) dst_r) + else + unitOL (POPCNT size (OpReg src_r) dst_r)) `appOL` + (if width == W8 || width == W16 then + -- We used a 16-bit destination register above, + -- so zero-extend + unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) + else nilOL) + else do + targetExpr <- cmmMakeDynamicReference dflags + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall dflags is32Bit target dest_regs args + where + size = intSize width + lbl = mkCmmCodeLabel primPackageKey (fsLit (popCntLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] + | is32Bit && width == W64 = do + -- Fallback to `hs_clz64` on i386 + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall dflags is32Bit target dest_regs args + + | otherwise = do + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) + + -- The following insn sequence makes sure 'clz 0' has a defined value. + -- starting with Haswell, one could use the LZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSR size (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) + , CMOV NE size (OpReg tmp_r) dst_r + , XOR size (OpImm (ImmInt (bw-1))) (OpReg dst_r) + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + where + bw = widthInBits width + platform = targetPlatform dflags + size = if width == W8 then II16 else intSize width + lbl = mkCmmCodeLabel primPackageKey (fsLit (clzLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] + | is32Bit, width == W64 = do + ChildCode64 vcode rlo <- iselExpr64 src + let rhi = getHiVRegFromLo rlo + dst_r = getRegisterReg platform False (CmmLocal dst) + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp_r <- getNewRegNat size + + -- The following instruction sequence corresponds to the pseudo-code + -- + -- if (src) { + -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); + -- } else { + -- dst = 64; + -- } + return $ vcode `appOL` toOL + ([ MOV II32 (OpReg rhi) (OpReg tmp_r) + , OR II32 (OpReg rlo) (OpReg tmp_r) + , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) + , JXX EQQ lbl2 + , JXX ALWAYS lbl1 + + , NEWBLOCK lbl1 + , BSF II32 (OpReg rhi) dst_r + , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) + , BSF II32 (OpReg rlo) tmp_r + , CMOV NE II32 (OpReg tmp_r) dst_r + , JXX ALWAYS lbl2 + + , NEWBLOCK lbl2 + ]) + + | otherwise = do + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + let dst_r = getRegisterReg platform False (CmmLocal dst) + + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF size (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE size (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + where + bw = widthInBits width + platform = targetPlatform dflags + size = if width == W8 then II16 else intSize width + +genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do + targetExpr <- cmmMakeDynamicReference dflags + CallReference lbl + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) + genCCall dflags is32Bit target dest_regs args + where + lbl = mkCmmCodeLabel primPackageKey (fsLit (word2FloatLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat size + arg_code <- getAnyReg n + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code <- op_code dst_r arg amode + return $ addr_code `appOL` arg_code arg `appOL` code + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr) + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ toOL [ LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI size (OpReg arg) + , LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND size src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND size src dst + , NOT size dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR size src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR size src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr) + cmpxchg_code instrs = do + lbl <- getBlockIdNat + tmp <- getNewRegNat size + return $ toOL + [ MOV size (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl + , NEWBLOCK lbl + -- Keep old value so we can return it: + , MOV size (OpReg eax) (OpReg dst_r) + , MOV size (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG size (OpReg tmp) (OpAddr amode)) + , JXX NE lbl + ] + + size = intSize width + +genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do + load_code <- intLoadCode (MOV (intSize width)) addr + let platform = targetPlatform dflags + use_sse2 <- sse2Enabled + return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) + +genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + code <- assignMem_IntCode (intSize width) addr val + return $ code `snocOL` MFENCE + +genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + newval <- getNewRegNat size + newval_code <- getAnyReg new + oldval <- getNewRegNat size + oldval_code <- getAnyReg old + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code = toOL + [ MOV size (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG size (OpReg newval) (OpAddr amode)) + , MOV size (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + size = intSize width + +genCCall _ is32Bit target dest_regs args = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case (target, dest_regs) of + -- void return type prim op + (PrimTarget op, []) -> + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls + (PrimTarget op, [r]) + | not is32Bit -> outOfLineCmmOp op (Just r) args + | otherwise -> do + l1 <- getNewLabelNat + l2 <- getNewLabelNat + sse2 <- sse2Enabled + if sse2 + then + outOfLineCmmOp op (Just r) args + else case op of + MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args + MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args + + MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args + MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args + + MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args + MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args + + MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args + MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args + + _other_op -> outOfLineCmmOp op (Just r) args + + where + actuallyInlineFloatOp instr size [x] + = do res <- trivialUFCode size (instr size) x + any <- anyReg res + return (any (getRegisterReg platform False (CmmLocal r))) + + actuallyInlineFloatOp _ _ args + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + ++ show (length args) ++ ")" + + (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args + (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args + (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args + (PrimTarget (MO_Add2 width), [res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + let size = intSize width + lCode <- anyReg =<< trivialCode width (ADD_CC size) + (Just (ADD_CC size)) arg_x arg_y + let reg_l = getRegisterReg platform True (CmmLocal res_l) + reg_h = getRegisterReg platform True (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall: Wrong number of arguments/results for add2" + (PrimTarget (MO_AddIntC width), [res_r, res_c]) -> + addSubIntC platform ADD_CC (Just . ADD_CC) width res_r res_c args + (PrimTarget (MO_SubIntC width), [res_r, res_c]) -> + addSubIntC platform SUB_CC (const Nothing) width res_r res_c args + (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let size = intSize width + reg_h = getRegisterReg platform True (CmmLocal res_h) + reg_l = getRegisterReg platform True (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 size y_reg, + MOV size (OpReg rdx) (OpReg reg_h), + MOV size (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall: Wrong number of arguments/results for add2" + + _ -> if is32Bit + then genCCall32' dflags target dest_regs args + else genCCall64' dflags target dest_regs args + + where divOp1 platform signed width results [arg_x, arg_y] + = divOp platform signed width results Nothing arg_x arg_y + divOp1 _ _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp1" + divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] + = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y + divOp2 _ _ _ _ _ + = panic "genCCall: Wrong number of arguments for divOp2" + divOp platform signed width [res_q, res_r] + m_arg_x_high arg_x_low arg_y + = do let size = intSize width + reg_q = getRegisterReg platform True (CmmLocal res_q) + reg_r = getRegisterReg platform True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_low_code <- getAnyReg arg_x_low + x_high_code <- case m_arg_x_high of + Just arg_x_high -> + getAnyReg arg_x_high + Nothing -> + return $ const $ unitOL widen + return $ y_code `appOL` + x_low_code rax `appOL` + x_high_code rdx `appOL` + toOL [instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ _ _ _ + = panic "genCCall: Wrong number of results for divOp" + + addSubIntC platform instr mrevinstr width res_r res_c [arg_x, arg_y] + = do let size = intSize width + rCode <- anyReg =<< trivialCode width (instr size) + (mrevinstr size) arg_x arg_y + reg_tmp <- getNewRegNat II8 + let reg_c = getRegisterReg platform True (CmmLocal res_c) + reg_r = getRegisterReg platform True (CmmLocal res_r) + code = rCode reg_r `snocOL` + SETCC OFLO (OpReg reg_tmp) `snocOL` + MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + return code + addSubIntC _ _ _ _ _ _ _ + = panic "genCCall: Wrong number of arguments/results for addSubIntC" + +genCCall32' :: DynFlags + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32' dflags target dest_regs args = do + let + prom_args = map (maybePromoteCArg dflags W32) args + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + sizes = map (arg_size . cmmExprType dflags) (reverse args) + raw_arg_size = sum sizes + wORD_SIZE dflags + arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size + tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + use_sse2 <- sse2Enabled + push_codes <- mapM (push_arg use_sse2) (reverse prom_args) + delta <- getDeltaNat + MASSERT(delta == delta0 - tot_arg_size) + + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + ForeignTarget (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + ForeignTarget expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType dflags expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " + ++ "probably because too many return values." + + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- even if we are doing stdcall, though (#5052) + pop_size + | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size + | otherwise = tot_arg_size + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA delta0] + ) + setDeltaNat delta0 + + dflags <- getDynFlags + let platform = targetPlatform dflags + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] + | isFloatType ty = + if use_sse2 + then let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + sz = floatSize w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA (delta0 - b), + GST sz fake0 tmp_amode, + MOV sz (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA delta0] + else unitOL (GMOV fake0 r_dest) + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg platform use_sse2 (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size :: CmmType -> Int -- Width in bytes + arg_size ty = widthInBytes (typeWidth ty) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: Bool -> CmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg use_sse2 arg -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let + r_hi = getHiVRegFromLo r_lo + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + size = floatSize (typeWidth arg_ty) + in + if use_sse2 + then MOV size (OpReg reg) (OpAddr addr) + else GST size reg addr + ] + ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType dflags arg + size = arg_size arg_ty -- Byte size + +genCCall64' :: DynFlags + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64' dflags target dest_regs args = do + -- load up the register arguments + let prom_args = map (maybePromoteCArg dflags W32) args + + (stack_args, int_regs_used, fp_regs_used, load_args_code) + <- + if platformOS platform == OSMinGW32 + then load_args_win prom_args [] [] (allArgRegs platform) nilOL + else do (stack_args, aregs, fregs, load_args_code) + <- load_args prom_args (allIntArgRegs platform) (allFPArgRegs platform) nilOL + let fp_regs_used = reverse (drop (length fregs) (reverse (allFPArgRegs platform))) + int_regs_used = reverse (drop (length aregs) (reverse (allIntArgRegs platform))) + return (stack_args, int_regs_used, fp_regs_used, load_args_code) + + let + arg_regs_used = int_regs_used ++ fp_regs_used + arg_regs = [eax] ++ arg_regs_used + -- for annotating the call instruction with + sse_regs = length fp_regs_used + arg_stack_slots = if platformOS platform == OSMinGW32 + then length stack_args + length (allArgRegs platform) + else length stack_args + tot_arg_size = arg_size * arg_stack_slots + + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] + (real_size, adjust_rsp) <- + if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta - wORD_SIZE dflags) + return (tot_arg_size + wORD_SIZE dflags, toOL [ + SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), + DELTA (delta - wORD_SIZE dflags) ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + -- On Win64, we also have to leave stack space for the arguments + -- that we are passing in registers + lss_code <- if platformOS platform == OSMinGW32 + then leaveStackSpace (length (allArgRegs platform)) + else return nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- + case target of + ForeignTarget (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + ForeignTarget expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " + ++ "probably because too many return values." + + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- stdcall has callee do it, but is not supported on + -- x86_64 target (see #3336) + (if real_size==0 then [] else + [ADD (intSize (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg platform True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + lss_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + + where platform = targetPlatform dflags + arg_size = 8 -- always, at the mo + + load_args :: [CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) + -- no more regs to use + load_args [] aregs fregs code = return ([], aregs, fregs, code) + -- no more args to push + load_args (arg : rest) aregs fregs code + | isFloatType arg_rep = + case fregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest aregs rs (code `appOL` arg_code r) + | otherwise = + case aregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest rs fregs (code `appOL` arg_code r) + where + arg_rep = cmmExprType dflags arg + + push_this_arg = do + (args',ars,frs,code') <- load_args rest aregs fregs code + return (arg:args', ars, frs, code') + + load_args_win :: [CmmExpr] + -> [Reg] -- used int regs + -> [Reg] -- used FP regs + -> [(Reg, Reg)] -- (int, FP) regs avail for args + -> InstrBlock + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock) + load_args_win args usedInt usedFP [] code + = return (args, usedInt, usedFP, code) + -- no more regs to use + load_args_win [] usedInt usedFP _ code + = return ([], usedInt, usedFP, code) + -- no more args to push + load_args_win (arg : rest) usedInt usedFP + ((ireg, freg) : regs) code + | isFloatType arg_rep = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) (freg : usedFP) regs + (code `appOL` + arg_code freg `snocOL` + -- If we are calling a varargs function + -- then we need to define ireg as well + -- as freg + MOV II64 (OpReg freg) (OpReg ireg)) + | otherwise = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) usedFP regs + (code `appOL` arg_code ireg) + where + arg_rep = cmmExprType dflags arg + + push_args [] code = return code + push_args (arg:rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intSize (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp) , + DELTA (delta-arg_size), + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] + push_args rest code' + + | otherwise = do + ASSERT(width == W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType dflags arg + width = typeWidth arg_rep + + leaveStackSpace n = do + delta <- getDeltaNat + setDeltaNat (delta - n * arg_size) + return $ toOL [ + SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), + DELTA (delta - n * arg_size)] + +maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr +maybePromoteCArg dflags wto arg + | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + wfrom = cmmExprWidth dflags arg + +outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrBlock +outOfLineCmmOp mop res args + = do + dflags <- getDynFlags + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl + let target = ForeignTarget targetExpr + (ForeignConvention CCallConv [] [] CmmMayReturn) + + stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args') + where + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction + + args' = case mop of + MO_Memcpy -> init args + MO_Memset -> init args + MO_Memmove -> init args + _ -> args + + fn = case mop of + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + MO_F32_Pwr -> fsLit "powf" + + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + MO_F64_Pwr -> fsLit "pow" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + MO_PopCnt _ -> fsLit "popcnt" + MO_BSwap _ -> fsLit "bswap" + MO_Clz w -> fsLit $ clzLabel w + MO_Ctz _ -> unsupported + + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + + MO_UF_Conv _ -> unsupported + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + MO_Add2 {} -> unsupported + MO_AddIntC {} -> unsupported + MO_SubIntC {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + (MO_Prefetch_Data _ ) -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock + +genSwitch dflags expr ids + | gopt Opt_PIC dflags + = do + (reg,e_code) <- getSomeReg expr + lbl <- getNewLabelNat + dflags <- getDynFlags + dynRef <- cmmMakeDynamicReference dflags DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) + + return $ if target32Bit (targetPlatform dflags) + then e_code `appOL` t_code `appOL` toOL [ + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] + else case platformOS (targetPlatform dflags) of + OSDarwin -> + -- on Mac OS X/x86_64, put the jump table + -- in the text section to work around a + -- limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous + -- label in its section. + e_code `appOL` t_code `appOL` toOL [ + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids Text lbl + ] + _ -> + -- HACK: On x86_64 binutils<2.17 is only able + -- to generate PC32 relocations, hence we only + -- get 32-bit offsets in the jump table. As + -- these offsets are always negative we need + -- to properly sign extend them to 64-bit. + -- This hack should be removed in conjunction + -- with the hack in PprMach.hs/pprDataItem + -- once binutils 2.17 is standard. + e_code `appOL` t_code `appOL` toOL [ + MOVSxL II32 op (OpReg reg), + ADD (intSize (wordWidth dflags)) (OpReg reg) (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] + | otherwise + = do + (reg,e_code) <- getSomeReg expr + lbl <- getNewLabelNat + let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) + code = e_code `appOL` toOL [ + JMP_TBL op ids ReadOnlyData lbl + ] + return code + +generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) +generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) + = Just (createJumpTable dflags ids section lbl) +generateJumpTableForInstr _ _ = Nothing + +createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel + -> GenCmmDecl (Alignment, CmmStatics) h g +createJumpTable dflags ids section lbl + = let jumpTable + | gopt Opt_PIC dflags = + let jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry dflags) ids + in CmmData section (1, Statics lbl jumpTable) + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register + +condIntReg cond x y = do + CondCode _ cond cond_code <- condIntCode cond x y + tmp <- getNewRegNat II8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] + return (Any II32 code) + + + +condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87 + where + condFltReg_x87 = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp <- getNewRegNat II8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] + return (Any II32 code) + + condFltReg_sse2 = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp1 <- getNewRegNat (archWordSize is32Bit) + tmp2 <- getNewRegNat (archWordSize is32Bit) + let + -- We have to worry about unordered operands (eg. comparisons + -- against NaN). If the operands are unordered, the comparison + -- sets the parity flag, carry flag and zero flag. + -- All comparisons are supposed to return false for unordered + -- operands except for !=, which returns true. + -- + -- Optimisation: we don't have to test the parity flag if we + -- know the test has already excluded the unordered case: eg > + -- and >= test for a zero carry flag, which can only occur for + -- ordered operands. + -- + -- ToDo: by reversing comparisons we could avoid testing the + -- parity flag in more cases. + + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + +{- +The Rules of the Game are: + +* You cannot assume anything about the destination register dst; + it may be anything, including a fixed reg. + +* You may compute an operand into a fixed reg, but you may not + subsequently change the contents of that fixed reg. If you + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. + +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +-------------------- + +SDM's version of The Rules: + +* If getRegister returns Any, that means it can generate correct + code which places the result in any register, period. Even if that + register happens to be read during the computation. + + Corollary #1: this means that if you are generating code for an + operation with two arbitrary operands, you cannot assign the result + of the first operand into the destination register before computing + the second operand. The second operand might require the old value + of the destination register. + + Corollary #2: A function might be able to generate more efficient + code if it knows the destination register is a new temporary (and + therefore not read by any of the sub-computations). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) + In particular, it may *not* modify global registers, unless the global + register happens to be the destination register. +-} + +trivialCode :: Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode width instr m a b + = do is32Bit <- is32BitPlatform + trivialCode' is32Bit width instr m a b + +trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b + | is32BitLit is32Bit lit_a = do + b_code <- getAnyReg b + let + code dst + = b_code dst `snocOL` + revinstr (OpImm (litToImm lit_a)) (OpReg dst) + return (Any (intSize width) code) + +trivialCode' _ width instr _ a b + = genTrivialCode (intSize width) instr a b + +-- This is re-used for floating pt instructions too. +genTrivialCode :: Size -> (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +genTrivialCode rep instr a b = do + (b_op, b_code) <- getNonClobberedOperand b + a_code <- getAnyReg a + tmp <- getNewRegNat rep + let + -- We want the value of b to stay alive across the computation of a. + -- But, we want to calculate a straight into the destination register, + -- because the instruction only has two operands (dst := dst `op` src). + -- The troublesome case is when the result of b is in the same register + -- as the destination reg. In this case, we have to save b in a + -- new temporary across the computation of a. + code dst + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) (OpReg dst) + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op (OpReg dst) + return (Any rep code) + +regClashesWithOp :: Reg -> Operand -> Bool +reg `regClashesWithOp` OpReg reg2 = reg == reg2 +reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) +_ `regClashesWithOp` _ = False + +----------- + +trivialUCode :: Size -> (Operand -> Instr) + -> CmmExpr -> NatM Register +trivialUCode rep instr x = do + x_code <- getAnyReg x + let + code dst = + x_code dst `snocOL` + instr (OpReg dst) + return (Any rep code) + +----------- + +trivialFCode_x87 :: (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_x87 instr x y = do + (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too + (y_reg, y_code) <- getSomeReg y + let + size = FF80 -- always, on x87 + code dst = + x_code `appOL` + y_code `snocOL` + instr size x_reg y_reg dst + return (Any size code) + +trivialFCode_sse2 :: Width -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_sse2 pk instr x y + = genTrivialCode size (instr size) x y + where size = floatSize pk + + +trivialUFCode :: Size -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register +trivialUFCode size instr x = do + (x_reg, x_code) <- getSomeReg x + let + code dst = + x_code `snocOL` + instr x_reg dst + return (Any size code) + + +-------------------------------------------------------------------------------- +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87 + where + coerce_x87 = do + (x_reg, x_code) <- getSomeReg x + let + opc = case to of W32 -> GITOF; W64 -> GITOD; + n -> panic $ "coerceInt2FP.x87: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc x_reg dst + -- ToDo: works for non-II32 reps? + return (Any FF80 code) + + coerce_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD + n -> panic $ "coerceInt2FP.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intSize from) x_op dst + return (Any (floatSize to) code) + -- works even if the destination rep is Width -> CmmExpr -> NatM Register +coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 + where + coerceFP2Int_x87 = do + (x_reg, x_code) <- getSomeReg x + let + opc = case from of W32 -> GFTOI; W64 -> GDTOI + n -> panic $ "coerceFP2Int.x87: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc x_reg dst + -- ToDo: works for non-II32 reps? + return (Any (intSize to) code) + + coerceFP2Int_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ; + n -> panic $ "coerceFP2Init.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intSize to) x_op dst + return (Any (intSize to) code) + -- works even if the destination rep is CmmExpr -> NatM Register +coerceFP2FP to x = do + use_sse2 <- sse2Enabled + (x_reg, x_code) <- getSomeReg x + let + opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; + n -> panic $ "coerceFP2FP: unhandled width (" + ++ show n ++ ")" + | otherwise = GDTOF + code dst = x_code `snocOL` opc x_reg dst + return (Any (if use_sse2 then floatSize to else FF80) code) + +-------------------------------------------------------------------------------- + +sse2NegCode :: Width -> CmmExpr -> NatM Register +sse2NegCode w x = do + let sz = floatSize w + x_code <- getAnyReg x + -- This is how gcc does it, so it can't be that bad: + let + const | FF32 <- sz = CmmInt 0x80000000 W32 + | otherwise = CmmInt 0x8000000000000000 W64 + Amode amode amode_code <- memConstant (widthInBytes w) const + tmp <- getNewRegNat sz + let + code dst = x_code dst `appOL` amode_code `appOL` toOL [ + MOV sz (OpAddr amode) (OpReg tmp), + XOR sz (OpReg tmp) (OpReg dst) + ] + -- + return (Any sz code) + +isVecExpr :: CmmExpr -> Bool +isVecExpr (CmmMachOp (MO_V_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_V_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_V_Add {}) _) = True +isVecExpr (CmmMachOp (MO_V_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_V_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Rem {}) _) = True +isVecExpr (CmmMachOp (MO_VS_Neg {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Insert {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Add {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Sub {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Mul {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Quot {}) _) = True +isVecExpr (CmmMachOp (MO_VF_Neg {}) _) = True +isVecExpr (CmmMachOp _ [e]) = isVecExpr e +isVecExpr _ = False + +needLlvm :: NatM a +needLlvm = + sorry $ unlines ["The native code generator does not support vector" + ,"instructions. Please use -fllvm."] diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs new file mode 100644 index 00000000..586dabd8 --- /dev/null +++ b/compiler/nativeGen/X86/Cond.hs @@ -0,0 +1,68 @@ +module X86.Cond ( + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned, + maybeFlipCond +) + +where + +data Cond + = ALWAYS -- What's really used? ToDo + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | POS + | CARRY + | OFLO + | PARITY + | NOTPARITY + deriving Eq + +condUnsigned :: Cond -> Bool +condUnsigned GU = True +condUnsigned LU = True +condUnsigned GEU = True +condUnsigned LEU = True +condUnsigned _ = False + + +condToSigned :: Cond -> Cond +condToSigned GU = GTT +condToSigned LU = LTT +condToSigned GEU = GE +condToSigned LEU = LE +condToSigned x = x + + +condToUnsigned :: Cond -> Cond +condToUnsigned GTT = GU +condToUnsigned LTT = LU +condToUnsigned GE = GEU +condToUnsigned LE = LEU +condToUnsigned x = x + +-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the +-- arguments to the conditional @c@, and the new condition should be @c'@. +maybeFlipCond :: Cond -> Maybe Cond +maybeFlipCond cond = case cond of + EQQ -> Just EQQ + NE -> Just NE + LU -> Just GU + GU -> Just LU + LEU -> Just GEU + GEU -> Just LEU + LTT -> Just GTT + GTT -> Just LTT + LE -> Just GE + GE -> Just LE + _other -> Nothing diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs new file mode 100644 index 00000000..8677badb --- /dev/null +++ b/compiler/nativeGen/X86/Instr.hs @@ -0,0 +1,1051 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Machine-dependent assembly language +-- +-- (c) The University of Glasgow 1993-2004 +-- +----------------------------------------------------------------------------- + +module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest, + getJumpDestBlockId, canShortcut, shortcutStatics, + shortcutJump, i386_insert_ffrees, allocMoreStack, + maxSpillSlots, archWordSize) +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +import X86.Cond +import X86.Regs +import Instruction +import Size +import RegClass +import Reg +import TargetReg + +import BlockId +import CodeGen.Platform +import Cmm +import FastString +import FastBool +import Outputable +import Platform + +import BasicTypes (Alignment) +import CLabel +import DynFlags +import UniqSet +import Unique +import UniqSupply + +import Control.Monad +import Data.Maybe (fromMaybe) + +-- Size of an x86/x86_64 memory address, in bytes. +-- +archWordSize :: Bool -> Size +archWordSize is32Bit + | is32Bit = II32 + | otherwise = II64 + +-- | Instruction instance for x86 instruction set. +instance Instruction Instr where + regUsageOfInstr = x86_regUsageOfInstr + patchRegsOfInstr = x86_patchRegsOfInstr + isJumpishInstr = x86_isJumpishInstr + jumpDestsOfInstr = x86_jumpDestsOfInstr + patchJumpInstr = x86_patchJumpInstr + mkSpillInstr = x86_mkSpillInstr + mkLoadInstr = x86_mkLoadInstr + takeDeltaInstr = x86_takeDeltaInstr + isMetaInstr = x86_isMetaInstr + mkRegRegMoveInstr = x86_mkRegRegMoveInstr + takeRegRegMoveInstr = x86_takeRegRegMoveInstr + mkJumpInstr = x86_mkJumpInstr + mkStackAllocInstr = x86_mkStackAllocInstr + mkStackDeallocInstr = x86_mkStackDeallocInstr + + +-- ----------------------------------------------------------------------------- +-- Intel x86 instructions + +{- +Intel, in their infinite wisdom, selected a stack model for floating +point registers on x86. That might have made sense back in 1979 -- +nowadays we can see it for the nonsense it really is. A stack model +fits poorly with the existing nativeGen infrastructure, which assumes +flat integer and FP register sets. Prior to this commit, nativeGen +could not generate correct x86 FP code -- to do so would have meant +somehow working the register-stack paradigm into the register +allocator and spiller, which sounds very difficult. + +We have decided to cheat, and go for a simple fix which requires no +infrastructure modifications, at the expense of generating ropey but +correct FP code. All notions of the x86 FP stack and its insns have +been removed. Instead, we pretend (to the instruction selector and +register allocator) that x86 has six floating point registers, %fake0 +.. %fake5, which can be used in the usual flat manner. We further +claim that x86 has floating point instructions very similar to SPARC +and Alpha, that is, a simple 3-operand register-register arrangement. +Code generation and register allocation proceed on this basis. + +When we come to print out the final assembly, our convenient fiction +is converted to dismal reality. Each fake instruction is +independently converted to a series of real x86 instructions. +%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg +arithmetic operations, the two operands are pushed onto the top of the +FP stack, the operation done, and the result copied back into the +relevant register. There are only six %fake registers because 2 are +needed for the translation, and x86 has 8 in total. + +The translation is inefficient but is simple and it works. A cleverer +translation would handle a sequence of insns, simulating the FP stack +contents, would not impose a fixed mapping from %fake to %st regs, and +hopefully could avoid most of the redundant reg-reg moves of the +current translation. + +We might as well make use of whatever unique FP facilities Intel have +chosen to bless us with (let's not be churlish, after all). +Hence GLDZ and GLD1. Bwahahahahahahaha! +-} + +{- +Note [x86 Floating point precision] + +Intel's internal floating point registers are by default 80 bit +extended precision. This means that all operations done on values in +registers are done at 80 bits, and unless the intermediate values are +truncated to the appropriate size (32 or 64 bits) by storing in +memory, calculations in registers will give different results from +calculations which pass intermediate values in memory (eg. via +function calls). + +One solution is to set the FPU into 64 bit precision mode. Some OSs +do this (eg. FreeBSD) and some don't (eg. Linux). The problem here is +that this will only affect 64-bit precision arithmetic; 32-bit +calculations will still be done at 64-bit precision in registers. So +it doesn't solve the whole problem. + +There's also the issue of what the C library is expecting in terms of +precision. It seems to be the case that glibc on Linux expects the +FPU to be set to 80 bit precision, so setting it to 64 bit could have +unexpected effects. Changing the default could have undesirable +effects on other 3rd-party library code too, so the right thing would +be to save/restore the FPU control word across Haskell code if we were +to do this. + +gcc's -ffloat-store gives consistent results by always storing the +results of floating-point calculations in memory, which works for both +32 and 64-bit precision. However, it only affects the values of +user-declared floating point variables in C, not intermediate results. +GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision +flag). + +Another problem is how to spill floating point registers in the +register allocator. Should we spill the whole 80 bits, or just 64? +On an OS which is set to 64 bit precision, spilling 64 is fine. On +Linux, spilling 64 bits will round the results of some operations. +This is what gcc does. Spilling at 80 bits requires taking up a full +128 bit slot (so we get alignment). We spill at 80-bits and ignore +the alignment problems. + +In the future [edit: now available in GHC 7.0.1, with the -msse2 +flag], we'll use the SSE registers for floating point. This requires +a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision +float ops), which means P4 or Xeon and above. Using SSE will solve +all these problems, because the SSE registers use fixed 32 bit or 64 +bit precision. + +--SDM 1/2003 +-} + +data Instr + -- comment pseudo-op + = COMMENT FastString + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int String + + -- some static data spat out during code + -- generation. Will be extracted before + -- pretty-printing. + | LDATA Section (Alignment, CmmStatics) + + -- start a new basic block. Useful during + -- codegen, removed later. Preceding + -- instruction should be a jump, as per the + -- invariants for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for + -- benefit of subsequent passes + | DELTA Int + + -- Moves. + | MOV Size Operand Operand + | CMOV Cond Size Operand Reg + | MOVZxL Size Operand Operand -- size is the size of operand 1 + | MOVSxL Size Operand Operand -- size is the size of operand 1 + -- x86_64 note: plain mov into a 32-bit register always zero-extends + -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which + -- don't affect the high bits of the register. + + -- Load effective address (also a very useful three-operand add instruction :-) + | LEA Size Operand Operand + + -- Int Arithmetic. + | ADD Size Operand Operand + | ADC Size Operand Operand + | SUB Size Operand Operand + | SBB Size Operand Operand + + | MUL Size Operand Operand + | MUL2 Size Operand -- %edx:%eax = operand * %rax + | IMUL Size Operand Operand -- signed int mul + | IMUL2 Size Operand -- %edx:%eax = operand * %eax + + | DIV Size Operand -- eax := eax:edx/op, edx := eax:edx%op + | IDIV Size Operand -- ditto, but signed + + -- Int Arithmetic, where the effects on the condition register + -- are important. Used in specialized sequences such as MO_Add2. + -- Do not rewrite these instructions to "equivalent" ones that + -- have different effect on the condition register! (See #9013.) + | ADD_CC Size Operand Operand + | SUB_CC Size Operand Operand + + -- Simple bit-twiddling. + | AND Size Operand Operand + | OR Size Operand Operand + | XOR Size Operand Operand + | NOT Size Operand + | NEGI Size Operand -- NEG instruction (name clash with Cond) + | BSWAP Size Reg + + -- Shifts (amount may be immediate or %cl only) + | SHL Size Operand{-amount-} Operand + | SAR Size Operand{-amount-} Operand + | SHR Size Operand{-amount-} Operand + + | BT Size Imm Operand + | NOP + + -- x86 Float Arithmetic. + -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles + -- as single instructions right up until we spit them out. + -- all the 3-operand fake fp insns are src1 src2 dst + -- and furthermore are constrained to be fp regs only. + -- IMPORTANT: keep is_G_insn up to date with any changes here + | GMOV Reg Reg -- src(fpreg), dst(fpreg) + | GLD Size AddrMode Reg -- src, dst(fpreg) + | GST Size Reg AddrMode -- src(fpreg), dst + + | GLDZ Reg -- dst(fpreg) + | GLD1 Reg -- dst(fpreg) + + | GFTOI Reg Reg -- src(fpreg), dst(intreg) + | GDTOI Reg Reg -- src(fpreg), dst(intreg) + + | GITOF Reg Reg -- src(intreg), dst(fpreg) + | GITOD Reg Reg -- src(intreg), dst(fpreg) + + | GDTOF Reg Reg -- src(fpreg), dst(fpreg) + + | GADD Size Reg Reg Reg -- src1, src2, dst + | GDIV Size Reg Reg Reg -- src1, src2, dst + | GSUB Size Reg Reg Reg -- src1, src2, dst + | GMUL Size Reg Reg Reg -- src1, src2, dst + + -- FP compare. Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT] + -- Compare src1 with src2; set the Zero flag iff the numbers are + -- comparable and the comparison is True. Subsequent code must + -- test the %eflags zero flag regardless of the supplied Cond. + | GCMP Cond Reg Reg -- src1, src2 + + | GABS Size Reg Reg -- src, dst + | GNEG Size Reg Reg -- src, dst + | GSQRT Size Reg Reg -- src, dst + | GSIN Size CLabel CLabel Reg Reg -- src, dst + | GCOS Size CLabel CLabel Reg Reg -- src, dst + | GTAN Size CLabel CLabel Reg Reg -- src, dst + + | GFREE -- do ffree on all x86 regs; an ugly hack + + + -- SSE2 floating point: we use a restricted set of the available SSE2 + -- instructions for floating-point. + -- use MOV for moving (either movss or movsd (movlpd better?)) + | CVTSS2SD Reg Reg -- F32 to F64 + | CVTSD2SS Reg Reg -- F64 to F32 + | CVTTSS2SIQ Size Operand Reg -- F32 to I32/I64 (with truncation) + | CVTTSD2SIQ Size Operand Reg -- F64 to I32/I64 (with truncation) + | CVTSI2SS Size Operand Reg -- I32/I64 to F32 + | CVTSI2SD Size Operand Reg -- I32/I64 to F64 + + -- use ADD & SUB for arithmetic. In both cases, operands + -- are Operand Reg. + + -- SSE2 floating-point division: + | FDIV Size Operand Operand -- divisor, dividend(dst) + + -- use CMP for comparisons. ucomiss and ucomisd instructions + -- compare single/double prec floating point respectively. + + | SQRT Size Operand Reg -- src, dst + + + -- Comparison + | TEST Size Operand Operand + | CMP Size Operand Operand + | SETCC Cond Operand + + -- Stack Operations. + | PUSH Size Operand + | POP Size Operand + -- both unused (SDM): + -- | PUSHA + -- | POPA + + -- Jumping around. + | JMP Operand [Reg] -- including live Regs at the call + | JXX Cond BlockId -- includes unconditional branches + | JXX_GBL Cond Imm -- non-local version of JXX + -- Table jump + | JMP_TBL Operand -- Address to jump to + [Maybe BlockId] -- Blocks in the jump table + Section -- Data section jump table should be put in + CLabel -- Label of jump table + | CALL (Either Imm Reg) [Reg] + + -- Other things. + | CLTD Size -- sign extend %eax into %edx:%eax + + | FETCHGOT Reg -- pseudo-insn for ELF position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg + | FETCHPC Reg -- pseudo-insn for Darwin position-independent code + -- pretty-prints as + -- call 1f + -- 1: popl %reg + + -- bit counting instructions + | POPCNT Size Operand Reg -- [SSE4.2] count number of bits set to 1 + | BSF Size Operand Reg -- bit scan forward + | BSR Size Operand Reg -- bit scan reverse + + -- prefetch + | PREFETCH PrefetchVariant Size Operand -- prefetch Variant, addr size, address to prefetch + -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + + | LOCK Instr -- lock prefix + | XADD Size Operand Operand -- src (r), dst (r/m) + | CMPXCHG Size Operand Operand -- src (r), dst (r/m), eax implicit + | MFENCE + +data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 + + +data Operand + = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr AddrMode -- memory reference + + + +-- | Returns which registers are read and written as a (read, written) +-- pair. +x86_regUsageOfInstr :: Platform -> Instr -> RegUsage +x86_regUsageOfInstr platform instr + = case instr of + MOV _ src dst -> usageRW src dst + CMOV _ _ src dst -> mkRU (use_R src [dst]) [dst] + MOVZxL _ src dst -> usageRW src dst + MOVSxL _ src dst -> usageRW src dst + LEA _ src dst -> usageRW src dst + ADD _ src dst -> usageRM src dst + ADC _ src dst -> usageRM src dst + SUB _ src dst -> usageRM src dst + SBB _ src dst -> usageRM src dst + IMUL _ src dst -> usageRM src dst + IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] + MUL _ src dst -> usageRM src dst + MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] + DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] + IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] + ADD_CC _ src dst -> usageRM src dst + SUB_CC _ src dst -> usageRM src dst + AND _ src dst -> usageRM src dst + OR _ src dst -> usageRM src dst + + XOR _ (OpReg src) (OpReg dst) + | src == dst -> mkRU [] [dst] + + XOR _ src dst -> usageRM src dst + NOT _ op -> usageM op + BSWAP _ reg -> mkRU [reg] [reg] + NEGI _ op -> usageM op + SHL _ imm dst -> usageRM imm dst + SAR _ imm dst -> usageRM imm dst + SHR _ imm dst -> usageRM imm dst + BT _ _ src -> mkRUR (use_R src []) + + PUSH _ op -> mkRUR (use_R op []) + POP _ op -> mkRU [] (def_W op) + TEST _ src dst -> mkRUR (use_R src $! use_R dst []) + CMP _ src dst -> mkRUR (use_R src $! use_R dst []) + SETCC _ op -> mkRU [] (def_W op) + JXX _ _ -> mkRU [] [] + JXX_GBL _ _ -> mkRU [] [] + JMP op regs -> mkRUR (use_R op regs) + JMP_TBL op _ _ _ -> mkRUR (use_R op []) + CALL (Left _) params -> mkRU params (callClobberedRegs platform) + CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform) + CLTD _ -> mkRU [eax] [edx] + NOP -> mkRU [] [] + + GMOV src dst -> mkRU [src] [dst] + GLD _ src dst -> mkRU (use_EA src []) [dst] + GST _ src dst -> mkRUR (src : use_EA dst []) + + GLDZ dst -> mkRU [] [dst] + GLD1 dst -> mkRU [] [dst] + + GFTOI src dst -> mkRU [src] [dst] + GDTOI src dst -> mkRU [src] [dst] + + GITOF src dst -> mkRU [src] [dst] + GITOD src dst -> mkRU [src] [dst] + + GDTOF src dst -> mkRU [src] [dst] + + GADD _ s1 s2 dst -> mkRU [s1,s2] [dst] + GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst] + GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst] + GDIV _ s1 s2 dst -> mkRU [s1,s2] [dst] + + GCMP _ src1 src2 -> mkRUR [src1,src2] + GABS _ src dst -> mkRU [src] [dst] + GNEG _ src dst -> mkRU [src] [dst] + GSQRT _ src dst -> mkRU [src] [dst] + GSIN _ _ _ src dst -> mkRU [src] [dst] + GCOS _ _ _ src dst -> mkRU [src] [dst] + GTAN _ _ _ src dst -> mkRU [src] [dst] + + CVTSS2SD src dst -> mkRU [src] [dst] + CVTSD2SS src dst -> mkRU [src] [dst] + CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst] + CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst] + CVTSI2SS _ src dst -> mkRU (use_R src []) [dst] + CVTSI2SD _ src dst -> mkRU (use_R src []) [dst] + FDIV _ src dst -> usageRM src dst + + FETCHGOT reg -> mkRU [] [reg] + FETCHPC reg -> mkRU [] [reg] + + COMMENT _ -> noUsage + LOCATION{} -> noUsage + DELTA _ -> noUsage + + POPCNT _ src dst -> mkRU (use_R src []) [dst] + BSF _ src dst -> mkRU (use_R src []) [dst] + BSR _ src dst -> mkRU (use_R src []) [dst] + + -- note: might be a better way to do this + PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK i -> x86_regUsageOfInstr platform i + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) + MFENCE -> noUsage + + _other -> panic "regUsage: unrecognised instr" + where + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + + -- 2 operand form; first operand Read; second Written + usageRW :: Operand -> Operand -> RegUsage + usageRW op (OpReg reg) = mkRU (use_R op []) [reg] + usageRW op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) + usageRW _ _ = panic "X86.RegInfo.usageRW: no match" + + -- 2 operand form; first operand Read; second Modified + usageRM :: Operand -> Operand -> RegUsage + usageRM op (OpReg reg) = mkRU (use_R op [reg]) [reg] + usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) + usageRM _ _ = panic "X86.RegInfo.usageRM: no match" + + -- 2 operand form; first operand Modified; second Modified + usageMM :: Operand -> Operand -> RegUsage + usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] + usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] + usageMM _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: Operand -> Operand -> Operand -> RegUsage + usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] + usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] + usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + + -- 1 operand form; operand Modified + usageM :: Operand -> RegUsage + usageM (OpReg reg) = mkRU [reg] [reg] + usageM (OpAddr ea) = mkRUR (use_EA ea []) + usageM _ = panic "X86.RegInfo.usageM: no match" + + -- Registers defd when an operand is written. + def_W (OpReg reg) = [reg] + def_W (OpAddr _ ) = [] + def_W _ = panic "X86.RegInfo.def_W: no match" + + -- Registers used when an operand is read. + use_R (OpReg reg) tl = reg : tl + use_R (OpImm _) tl = tl + use_R (OpAddr ea) tl = use_EA ea tl + + -- Registers used to compute an effective address. + use_EA (ImmAddr _ _) tl = tl + use_EA (AddrBaseIndex base index _) tl = + use_base base $! use_index index tl + where use_base (EABaseReg r) tl = r : tl + use_base _ tl = tl + use_index EAIndexNone tl = tl + use_index (EAIndex i _) tl = i : tl + + mkRUR src = src' `seq` RU src' [] + where src' = filter (interesting platform) src + + mkRU src dst = src' `seq` dst' `seq` RU src' dst' + where src' = filter (interesting platform) src + dst' = filter (interesting platform) dst + +-- | Is this register interesting for the register allocator? +interesting :: Platform -> Reg -> Bool +interesting _ (RegVirtual _) = True +interesting platform (RegReal (RealRegSingle i)) = isFastTrue (freeReg platform i) +interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" + + + +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. +x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +x86_patchRegsOfInstr instr env + = case instr of + MOV sz src dst -> patch2 (MOV sz) src dst + CMOV cc sz src dst -> CMOV cc sz (patchOp src) (env dst) + MOVZxL sz src dst -> patch2 (MOVZxL sz) src dst + MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst + LEA sz src dst -> patch2 (LEA sz) src dst + ADD sz src dst -> patch2 (ADD sz) src dst + ADC sz src dst -> patch2 (ADC sz) src dst + SUB sz src dst -> patch2 (SUB sz) src dst + SBB sz src dst -> patch2 (SBB sz) src dst + IMUL sz src dst -> patch2 (IMUL sz) src dst + IMUL2 sz src -> patch1 (IMUL2 sz) src + MUL sz src dst -> patch2 (MUL sz) src dst + MUL2 sz src -> patch1 (MUL2 sz) src + IDIV sz op -> patch1 (IDIV sz) op + DIV sz op -> patch1 (DIV sz) op + ADD_CC sz src dst -> patch2 (ADD_CC sz) src dst + SUB_CC sz src dst -> patch2 (SUB_CC sz) src dst + AND sz src dst -> patch2 (AND sz) src dst + OR sz src dst -> patch2 (OR sz) src dst + XOR sz src dst -> patch2 (XOR sz) src dst + NOT sz op -> patch1 (NOT sz) op + BSWAP sz reg -> BSWAP sz (env reg) + NEGI sz op -> patch1 (NEGI sz) op + SHL sz imm dst -> patch1 (SHL sz imm) dst + SAR sz imm dst -> patch1 (SAR sz imm) dst + SHR sz imm dst -> patch1 (SHR sz imm) dst + BT sz imm src -> patch1 (BT sz imm) src + TEST sz src dst -> patch2 (TEST sz) src dst + CMP sz src dst -> patch2 (CMP sz) src dst + PUSH sz op -> patch1 (PUSH sz) op + POP sz op -> patch1 (POP sz) op + SETCC cond op -> patch1 (SETCC cond) op + JMP op regs -> JMP (patchOp op) regs + JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl + + GMOV src dst -> GMOV (env src) (env dst) + GLD sz src dst -> GLD sz (lookupAddr src) (env dst) + GST sz src dst -> GST sz (env src) (lookupAddr dst) + + GLDZ dst -> GLDZ (env dst) + GLD1 dst -> GLD1 (env dst) + + GFTOI src dst -> GFTOI (env src) (env dst) + GDTOI src dst -> GDTOI (env src) (env dst) + + GITOF src dst -> GITOF (env src) (env dst) + GITOD src dst -> GITOD (env src) (env dst) + + GDTOF src dst -> GDTOF (env src) (env dst) + + GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst) + GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst) + GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst) + GDIV sz s1 s2 dst -> GDIV sz (env s1) (env s2) (env dst) + + GCMP sz src1 src2 -> GCMP sz (env src1) (env src2) + GABS sz src dst -> GABS sz (env src) (env dst) + GNEG sz src dst -> GNEG sz (env src) (env dst) + GSQRT sz src dst -> GSQRT sz (env src) (env dst) + GSIN sz l1 l2 src dst -> GSIN sz l1 l2 (env src) (env dst) + GCOS sz l1 l2 src dst -> GCOS sz l1 l2 (env src) (env dst) + GTAN sz l1 l2 src dst -> GTAN sz l1 l2 (env src) (env dst) + + CVTSS2SD src dst -> CVTSS2SD (env src) (env dst) + CVTSD2SS src dst -> CVTSD2SS (env src) (env dst) + CVTTSS2SIQ sz src dst -> CVTTSS2SIQ sz (patchOp src) (env dst) + CVTTSD2SIQ sz src dst -> CVTTSD2SIQ sz (patchOp src) (env dst) + CVTSI2SS sz src dst -> CVTSI2SS sz (patchOp src) (env dst) + CVTSI2SD sz src dst -> CVTSI2SD sz (patchOp src) (env dst) + FDIV sz src dst -> FDIV sz (patchOp src) (patchOp dst) + + CALL (Left _) _ -> instr + CALL (Right reg) p -> CALL (Right (env reg)) p + + FETCHGOT reg -> FETCHGOT (env reg) + FETCHPC reg -> FETCHPC (env reg) + + NOP -> instr + COMMENT _ -> instr + LOCATION {} -> instr + DELTA _ -> instr + + JXX _ _ -> instr + JXX_GBL _ _ -> instr + CLTD _ -> instr + + POPCNT sz src dst -> POPCNT sz (patchOp src) (env dst) + BSF sz src dst -> BSF sz (patchOp src) (env dst) + BSR sz src dst -> BSR sz (patchOp src) (env dst) + + PREFETCH lvl size src -> PREFETCH lvl size (patchOp src) + + LOCK i -> LOCK (x86_patchRegsOfInstr i env) + XADD sz src dst -> patch2 (XADD sz) src dst + CMPXCHG sz src dst -> patch2 (CMPXCHG sz) src dst + MFENCE -> instr + + _other -> panic "patchRegs: unrecognised instr" + + where + patch1 :: (Operand -> a) -> Operand -> a + patch1 insn op = insn $! patchOp op + patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a + patch2 insn src dst = (insn $! patchOp src) $! patchOp dst + + patchOp (OpReg reg) = OpReg $! env reg + patchOp (OpImm imm) = OpImm imm + patchOp (OpAddr ea) = OpAddr $! lookupAddr ea + + lookupAddr (ImmAddr imm off) = ImmAddr imm off + lookupAddr (AddrBaseIndex base index disp) + = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp + where + lookupBase EABaseNone = EABaseNone + lookupBase EABaseRip = EABaseRip + lookupBase (EABaseReg r) = EABaseReg $! env r + + lookupIndex EAIndexNone = EAIndexNone + lookupIndex (EAIndex r i) = (EAIndex $! env r) i + + +-------------------------------------------------------------------------------- +x86_isJumpishInstr + :: Instr -> Bool + +x86_isJumpishInstr instr + = case instr of + JMP{} -> True + JXX{} -> True + JXX_GBL{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False + + +x86_jumpDestsOfInstr + :: Instr + -> [BlockId] + +x86_jumpDestsOfInstr insn + = case insn of + JXX _ id -> [id] + JMP_TBL _ ids _ _ -> [id | Just id <- ids] + _ -> [] + + +x86_patchJumpInstr + :: Instr -> (BlockId -> BlockId) -> Instr + +x86_patchJumpInstr insn patchF + = case insn of + JXX cc id -> JXX cc (patchF id) + JMP_TBL op ids section lbl + -> JMP_TBL op (map (fmap patchF) ids) section lbl + _ -> insn + + + + +-- ----------------------------------------------------------------------------- +-- | Make a spill instruction. +x86_mkSpillInstr + :: DynFlags + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +x86_mkSpillInstr dflags reg delta slot + = let off = spillSlotToOffset platform slot - delta + in + case targetClassOfReg platform reg of + RcInteger -> MOV (archWordSize is32Bit) + (OpReg reg) (OpAddr (spRel dflags off)) + RcDouble -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off)) + _ -> panic "X86.mkSpillInstr: no match" + where platform = targetPlatform dflags + is32Bit = target32Bit platform + +-- | Make a spill reload instruction. +x86_mkLoadInstr + :: DynFlags + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr + +x86_mkLoadInstr dflags reg delta slot + = let off = spillSlotToOffset platform slot - delta + in + case targetClassOfReg platform reg of + RcInteger -> MOV (archWordSize is32Bit) + (OpAddr (spRel dflags off)) (OpReg reg) + RcDouble -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg) + _ -> panic "X86.x86_mkLoadInstr" + where platform = targetPlatform dflags + is32Bit = target32Bit platform + +spillSlotSize :: Platform -> Int +spillSlotSize dflags = if is32Bit then 12 else 8 + where is32Bit = target32Bit dflags + +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1 +-- = 0 -- useful for testing allocMoreStack + +-- number of bytes that the stack pointer should be aligned to +stackAlign :: Int +stackAlign = 16 + +-- convert a spill slot number to a *byte* offset, with no sign: +-- decide on a per arch basis whether you are spilling above or below +-- the C stack pointer. +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = 64 + spillSlotSize platform * slot + +-------------------------------------------------------------------------------- + +-- | See if this instruction is telling us the current C stack delta +x86_takeDeltaInstr + :: Instr + -> Maybe Int + +x86_takeDeltaInstr instr + = case instr of + DELTA i -> Just i + _ -> Nothing + + +x86_isMetaInstr + :: Instr + -> Bool + +x86_isMetaInstr instr + = case instr of + COMMENT{} -> True + LOCATION{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + + + +-- | Make a reg-reg move instruction. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. +-- +x86_mkRegRegMoveInstr + :: Platform + -> Reg + -> Reg + -> Instr + +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of + RcInteger -> case platformArch platform of + ArchX86 -> MOV II32 (OpReg src) (OpReg dst) + ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst) + _ -> panic "x86_mkRegRegMoveInstr: Bad arch" + RcDouble -> GMOV src dst + RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst) + _ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match" + +-- | Check whether an instruction represents a reg-reg move. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. +-- +x86_takeRegRegMoveInstr + :: Instr + -> Maybe (Reg,Reg) + +x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) + = Just (r1,r2) + +x86_takeRegRegMoveInstr _ = Nothing + + +-- | Make an unconditional branch instruction. +x86_mkJumpInstr + :: BlockId + -> [Instr] + +x86_mkJumpInstr id + = [JXX ALWAYS id] + + +x86_mkStackAllocInstr + :: Platform + -> Int + -> Instr +x86_mkStackAllocInstr platform amount + = case platformArch platform of + ArchX86 -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp) + ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) + _ -> panic "x86_mkStackAllocInstr" + +x86_mkStackDeallocInstr + :: Platform + -> Int + -> Instr +x86_mkStackDeallocInstr platform amount + = case platformArch platform of + ArchX86 -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp) + ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp) + _ -> panic "x86_mkStackDeallocInstr" + +i386_insert_ffrees + :: [GenBasicBlock Instr] + -> [GenBasicBlock Instr] + +i386_insert_ffrees blocks + | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ] + = map insertGFREEs blocks + | otherwise + = blocks + where + insertGFREEs (BasicBlock id insns) + = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns) + +insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr] +insertBeforeNonlocalTransfers insert insns + = foldr p [] insns + where p insn r = case insn of + CALL _ _ -> insert : insn : r + JMP _ _ -> insert : insn : r + JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL" + _ -> insn : r + + +-- if you ever add a new FP insn to the fake x86 FP insn set, +-- you must update this too +is_G_instr :: Instr -> Bool +is_G_instr instr + = case instr of + GMOV{} -> True + GLD{} -> True + GST{} -> True + GLDZ{} -> True + GLD1{} -> True + GFTOI{} -> True + GDTOI{} -> True + GITOF{} -> True + GITOD{} -> True + GDTOF{} -> True + GADD{} -> True + GDIV{} -> True + GSUB{} -> True + GMUL{} -> True + GCMP{} -> True + GABS{} -> True + GNEG{} -> True + GSQRT{} -> True + GSIN{} -> True + GCOS{} -> True + GTAN{} -> True + GFREE -> panic "is_G_instr: GFREE (!)" + _ -> False + + +-- +-- Note [extra spill slots] +-- +-- If the register allocator used more spill slots than we have +-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more +-- C stack space on entry and exit from this proc. Therefore we +-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp" +-- before every non-local jump. +-- +-- This became necessary when the new codegen started bundling entire +-- functions together into one proc, because the register allocator +-- assigns a different stack slot to each virtual reg within a proc. +-- To avoid using so many slots we could also: +-- +-- - split up the proc into connected components before code generator +-- +-- - rename the virtual regs, so that we re-use vreg names and hence +-- stack slots for non-overlapping vregs. +-- +-- Note that when a block is both a non-local entry point (with an +-- info table) and a local branch target, we have to split it into +-- two, like so: +-- +-- +-- L: +-- +-- +-- becomes +-- +-- +-- L: +-- subl $rsp, N +-- jmp Lnew +-- Lnew: +-- +-- +-- and all branches pointing to L are retargetted to point to Lnew. +-- Otherwise, we would repeat the $rsp adjustment for each branch to +-- L. +-- +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics X86.Instr.Instr + -> UniqSM (NatCmmDecl statics X86.Instr.Instr) + +allocMoreStack _ _ top@(CmmData _ _) = return top +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + uniqs <- replicateM (length entries) getUniqueM + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize platform -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: BlockEnv BlockId + new_blockmap = mapFromList (zip entries (map mkBlockId uniqs)) + + insert_stack_insns (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap + = [ BasicBlock id [alloc, JXX ALWAYS new_blockid] + , BasicBlock new_blockid block' ] + | otherwise + = [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + JMP _ _ -> dealloc : insn : r + JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL" + _other -> x86_patchJumpInstr insn retarget : r + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insns code + -- in + return (CmmProc info lbl live (ListGraph new_code)) + + +data JumpDest = DestBlockId BlockId | DestImm Imm + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + +canShortcut :: Instr -> Maybe JumpDest +canShortcut (JXX ALWAYS id) = Just (DestBlockId id) +canShortcut (JMP (OpImm imm) _) = Just (DestImm imm) +canShortcut _ = Nothing + + +-- This helper shortcuts a sequence of branches. +-- The blockset helps avoid following cycles. +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn + where shortcutJump' fn seen insn@(JXX cc id) = + if setMember id seen then insn + else case fn id of + Nothing -> insn + Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') + Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) + where seen' = setInsert id seen + shortcutJump' _ _ other = other + +-- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) + -- slightly dodgy, we're ignoring the second label, but this + -- works with the way we use CmmLabelDiffOff for jump tables now. +shortcutStatic _ other_static + = other_static + +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> UniqSet Unique + -> BlockId + -> CLabel + +shortBlockId fn seen blockid = + case (elementOfUniqSet uq seen, fn blockid) of + (True, _) -> mkAsmTempLabel uq + (_, Nothing) -> mkAsmTempLabel uq + (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' + (_, Just (DestImm (ImmCLbl lbl))) -> lbl + (_, _other) -> panic "shortBlockId" + where uq = getUnique blockid diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs new file mode 100644 index 00000000..d76e1e90 --- /dev/null +++ b/compiler/nativeGen/X86/Ppr.hs @@ -0,0 +1,1279 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Pretty-printing assembly language +-- +-- (c) The University of Glasgow 1993-2005 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module X86.Ppr ( + pprNatCmmDecl, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem, +) + +where + +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +import X86.Regs +import X86.Instr +import X86.Cond +import Instruction +import Size +import Reg +import PprBase + + +import BlockId +import BasicTypes (Alignment) +import DynFlags +import Cmm hiding (topInfoTable) +import CLabel +import Unique ( pprUnique, Uniquable(..) ) +import Platform +import FastString +import Outputable + +import Data.Word + +import Data.Bits + +-- ----------------------------------------------------------------------------- +-- Printing this stuff out + +pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc +pprNatCmmDecl (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats + +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + sdocWithDynFlags $ \dflags -> + case topInfoTable proc of + Nothing -> + case blocks of + [] -> -- special case for split markers: + pprLabel lbl + blocks -> -- special case for code without info table: + pprSectionHeader Text $$ + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock top_info) blocks) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + pprSizeDecl lbl + + Just (Statics info_lbl _) -> + sdocWithPlatform $ \platform -> + (if platformHasSubsectionsViaSymbols platform + then pprSectionHeader Text $$ + ppr (mkDeadStripPreventer info_lbl) <> char ':' + else empty) $$ + vcat (map (pprBasicBlock top_info) blocks) $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + (if platformHasSubsectionsViaSymbols platform + then + -- See Note [Subsections Via Symbols] + text "\t.long " + <+> ppr info_lbl + <+> char '-' + <+> ppr (mkDeadStripPreventer info_lbl) + else empty) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$ + pprSizeDecl info_lbl + +-- | Output the ELF .size directive. +pprSizeDecl :: CLabel -> SDoc +pprSizeDecl lbl + = sdocWithPlatform $ \platform -> + if osElfTarget (platformOS platform) + then ptext (sLit "\t.size") <+> ppr lbl + <> ptext (sLit ", .-") <> ppr lbl + else empty + +pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock info_env (BasicBlock blockid instrs) + = sdocWithDynFlags $ \dflags -> + maybe_infotable $$ + pprLabel asmLbl $$ + vcat (map pprInstr instrs) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) + where + asmLbl = mkAsmTempLabel (getUnique blockid) + maybe_infotable = case mapLookup blockid info_env of + Nothing -> empty + Just (Statics info_lbl info) -> + pprSectionHeader Text $$ + infoTableLoc $$ + vcat (map pprData info) $$ + pprLabel info_lbl + -- Make sure the info table has the right .loc for the block + -- coming right after it. See [Note: Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr l + _other -> empty + +pprDatas :: (Alignment, CmmStatics) -> SDoc +pprDatas (align, (Statics lbl dats)) + = vcat (pprAlign align : pprLabel lbl : map pprData dats) + -- TODO: could remove if align == 1 + +pprData :: CmmStatic -> SDoc +pprData (CmmString str) = pprASCII str + +pprData (CmmUninitialised bytes) + = sdocWithPlatform $ \platform -> + if platformOS platform == OSDarwin then ptext (sLit ".space ") <> int bytes + else ptext (sLit ".skip ") <> int bytes + +pprData (CmmStaticLit lit) = pprDataItem lit + +pprGloblDecl :: CLabel -> SDoc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext (sLit ".globl ") <> ppr lbl + +pprTypeAndSizeDecl :: CLabel -> SDoc +pprTypeAndSizeDecl lbl + = sdocWithPlatform $ \platform -> + if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then ptext (sLit ".type ") <> ppr lbl <> ptext (sLit ", @object") + else empty + +pprLabel :: CLabel -> SDoc +pprLabel lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl lbl + $$ (ppr lbl <> char ':') + + +pprASCII :: [Word8] -> SDoc +pprASCII str + = vcat (map do1 str) $$ do1 0 + where + do1 :: Word8 -> SDoc + do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + +pprAlign :: Int -> SDoc +pprAlign bytes + = sdocWithPlatform $ \platform -> + ptext (sLit ".align ") <> int (alignment platform) + where + alignment platform = if platformOS platform == OSDarwin + then log2 bytes + else bytes + + log2 :: Int -> Int -- cache the common ones + log2 1 = 0 + log2 2 = 1 + log2 4 = 2 + log2 8 = 3 + log2 n = 1 + log2 (n `quot` 2) + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = pprInstr instr + + +pprReg :: Size -> Reg -> SDoc +pprReg s r + = case r of + RegReal (RealRegSingle i) -> + sdocWithPlatform $ \platform -> + if target32Bit platform then ppr32_reg_no s i + else ppr64_reg_no s i + RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u + RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u + RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u + where + ppr32_reg_no :: Size -> Int -> SDoc + ppr32_reg_no II8 = ppr32_reg_byte + ppr32_reg_no II16 = ppr32_reg_word + ppr32_reg_no _ = ppr32_reg_long + + ppr32_reg_byte i = ptext + (case i of { + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + _ -> sLit "very naughty I386 byte register" + }) + + ppr32_reg_word i = ptext + (case i of { + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + _ -> sLit "very naughty I386 word register" + }) + + ppr32_reg_long i = ptext + (case i of { + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + _ -> ppr_reg_float i + }) + + ppr64_reg_no :: Size -> Int -> SDoc + ppr64_reg_no II8 = ppr64_reg_byte + ppr64_reg_no II16 = ppr64_reg_word + ppr64_reg_no II32 = ppr64_reg_long + ppr64_reg_no _ = ppr64_reg_quad + + ppr64_reg_byte i = ptext + (case i of { + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! + 6 -> sLit "%bpl"; 7 -> sLit "%spl"; + 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; + 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; + 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; + 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; + _ -> sLit "very naughty x86_64 byte register" + }) + + ppr64_reg_word i = ptext + (case i of { + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; + 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; + 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; + 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; + _ -> sLit "very naughty x86_64 word register" + }) + + ppr64_reg_long i = ptext + (case i of { + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; + 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; + 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; + 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; + _ -> sLit "very naughty x86_64 register" + }) + + ppr64_reg_quad i = ptext + (case i of { + 0 -> sLit "%rax"; 1 -> sLit "%rbx"; + 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; + 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; + 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; + 8 -> sLit "%r8"; 9 -> sLit "%r9"; + 10 -> sLit "%r10"; 11 -> sLit "%r11"; + 12 -> sLit "%r12"; 13 -> sLit "%r13"; + 14 -> sLit "%r14"; 15 -> sLit "%r15"; + _ -> ppr_reg_float i + }) + +ppr_reg_float :: Int -> LitString +ppr_reg_float i = case i of + 16 -> sLit "%fake0"; 17 -> sLit "%fake1" + 18 -> sLit "%fake2"; 19 -> sLit "%fake3" + 20 -> sLit "%fake4"; 21 -> sLit "%fake5" + 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1" + 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3" + 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5" + 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7" + 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9" + 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11" + 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13" + 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15" + _ -> sLit "very naughty x86 register" + +pprSize :: Size -> SDoc +pprSize x + = ptext (case x of + II8 -> sLit "b" + II16 -> sLit "w" + II32 -> sLit "l" + II64 -> sLit "q" + FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) + FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) + FF80 -> sLit "t" + ) + +pprSize_x87 :: Size -> SDoc +pprSize_x87 x + = ptext $ case x of + FF32 -> sLit "s" + FF64 -> sLit "l" + FF80 -> sLit "t" + _ -> panic "X86.Ppr.pprSize_x87" + +pprCond :: Cond -> SDoc +pprCond c + = ptext (case c of { + GEU -> sLit "ae"; LU -> sLit "b"; + EQQ -> sLit "e"; GTT -> sLit "g"; + GE -> sLit "ge"; GU -> sLit "a"; + LTT -> sLit "l"; LE -> sLit "le"; + LEU -> sLit "be"; NE -> sLit "ne"; + NEG -> sLit "s"; POS -> sLit "ns"; + CARRY -> sLit "c"; OFLO -> sLit "o"; + PARITY -> sLit "p"; NOTPARITY -> sLit "np"; + ALWAYS -> sLit "mp"}) + + +pprImm :: Imm -> SDoc +pprImm (ImmInt i) = int i +pprImm (ImmInteger i) = integer i +pprImm (ImmCLbl l) = ppr l +pprImm (ImmIndex l i) = ppr l <> char '+' <> int i +pprImm (ImmLit s) = s + +pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") + +pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b +pprImm (ImmConstantDiff a b) = pprImm a <> char '-' + <> lparen <> pprImm b <> rparen + + + +pprAddr :: AddrMode -> SDoc +pprAddr (ImmAddr imm off) + = let pp_imm = pprImm imm + in + if (off == 0) then + pp_imm + else if (off < 0) then + pp_imm <> int off + else + pp_imm <> char '+' <> int off + +pprAddr (AddrBaseIndex base index displacement) + = sdocWithPlatform $ \platform -> + let + pp_disp = ppr_disp displacement + pp_off p = pp_disp <> char '(' <> p <> char ')' + pp_reg r = pprReg (archWordSize (target32Bit platform)) r + in + case (base, index) of + (EABaseNone, EAIndexNone) -> pp_disp + (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) + (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip")) + (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) + (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r + <> comma <> int i) + _ -> panic "X86.Ppr.pprAddr: no match" + + where + ppr_disp (ImmInt 0) = empty + ppr_disp imm = pprImm imm + + +pprSectionHeader :: Section -> SDoc +pprSectionHeader seg = + sdocWithPlatform $ \platform -> + case platformOS platform of + OSDarwin + | target32Bit platform -> + case seg of + Text -> text ".text\n\t.align 2" + Data -> text ".data\n\t.align 2" + ReadOnlyData -> text ".const\n\t.align 2" + RelocatableReadOnlyData + -> text ".const_data\n\t.align 2" + UninitialisedData -> text ".data\n\t.align 2" + ReadOnlyData16 -> text ".const\n\t.align 4" + OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" + | otherwise -> + case seg of + Text -> text ".text\n\t.align 3" + Data -> text ".data\n\t.align 3" + ReadOnlyData -> text ".const\n\t.align 3" + RelocatableReadOnlyData + -> text ".const_data\n\t.align 3" + UninitialisedData -> text ".data\n\t.align 3" + ReadOnlyData16 -> text ".const\n\t.align 4" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" + _ + | target32Bit platform -> + case seg of + Text -> text ".text\n\t.align 4,0x90" + Data -> text ".data\n\t.align 4" + ReadOnlyData -> text ".section .rodata\n\t.align 4" + RelocatableReadOnlyData + -> text ".section .data\n\t.align 4" + UninitialisedData -> text ".section .bss\n\t.align 4" + ReadOnlyData16 -> text ".section .rodata\n\t.align 16" + OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" + | otherwise -> + case seg of + Text -> text ".text\n\t.align 8" + Data -> text ".data\n\t.align 8" + ReadOnlyData -> text ".section .rodata\n\t.align 8" + RelocatableReadOnlyData + -> text ".section .data\n\t.align 8" + UninitialisedData -> text ".section .bss\n\t.align 8" + ReadOnlyData16 -> text ".section .rodata.cst16\n\t.align 16" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" + + + + +pprDataItem :: CmmLit -> SDoc +pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit + +pprDataItem' :: DynFlags -> CmmLit -> SDoc +pprDataItem' dflags lit + = vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) + where + platform = targetPlatform dflags + imm = litToImm lit + + -- These seem to be common: + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + + ppr_item II64 _ + = case platformOS platform of + OSDarwin + | target32Bit platform -> + case lit of + CmmInt x _ -> + [ptext (sLit "\t.long\t") + <> int (fromIntegral (fromIntegral x :: Word32)), + ptext (sLit "\t.long\t") + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32))] + _ -> panic "X86.Ppr.ppr_item: no match for II64" + | otherwise -> + [ptext (sLit "\t.quad\t") <> pprImm imm] + _ + | target32Bit platform -> + [ptext (sLit "\t.quad\t") <> pprImm imm] + | otherwise -> + -- x86_64: binutils can't handle the R_X86_64_PC64 + -- relocation type, which means we can't do + -- pc-relative 64-bit addresses. Fortunately we're + -- assuming the small memory model, in which all such + -- offsets will fit into 32 bits, so we have to stick + -- to 32-bit offset fields and modify the RTS + -- appropriately + -- + -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h + -- + case lit of + -- A relative relocation: + CmmLabelDiffOff _ _ _ -> + [ptext (sLit "\t.long\t") <> pprImm imm, + ptext (sLit "\t.long\t0")] + _ -> + [ptext (sLit "\t.quad\t") <> pprImm imm] + + ppr_item _ _ + = panic "X86.Ppr.ppr_item: no match" + + + +pprInstr :: Instr -> SDoc + +pprInstr (COMMENT _) = empty -- nuke 'em +{- +pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s +-} + +pprInstr (LOCATION file line col _name) + = ptext (sLit "\t.loc ") <> ppr file <+> ppr line <+> ppr col + +pprInstr (DELTA d) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) + +pprInstr (NEWBLOCK _) + = panic "PprMach.pprInstr: NEWBLOCK" + +pprInstr (LDATA _ _) + = panic "PprMach.pprInstr: LDATA" + +{- +pprInstr (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + pprUserReg reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + pprUserReg reg] +-} + +-- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. +-- The code generator catches most of these already, but not all. +pprInstr (MOV size (OpImm (ImmInt 0)) dst@(OpReg _)) + = pprInstr (XOR size' dst dst) + where size' = case size of + II64 -> II32 -- 32-bit version is equivalent, and smaller + _ -> size +pprInstr (MOV size src dst) + = pprSizeOpOp (sLit "mov") size src dst + +pprInstr (CMOV cc size src dst) + = pprCondOpReg (sLit "cmov") size cc src dst + +pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst + -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple + -- movl. But we represent it as a MOVZxL instruction, because + -- the reg alloc would tend to throw away a plain reg-to-reg + -- move, and we still want it to do that. + +pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst + -- zero-extension only needs to extend to 32 bits: on x86_64, + -- the remaining zero-extension to 64 bits is automatic, and the 32-bit + -- instruction is shorter. + +pprInstr (MOVSxL sizes src dst) + = sdocWithPlatform $ \platform -> + pprSizeOpOpCoerce (sLit "movs") sizes (archWordSize (target32Bit platform)) src dst + +-- here we do some patching, since the physical registers are only set late +-- in the code generation. +pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) + | reg1 == reg3 + = pprSizeOpOp (sLit "add") size (OpReg reg2) dst + +pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) + | reg2 == reg3 + = pprSizeOpOp (sLit "add") size (OpReg reg1) dst + +pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) + | reg1 == reg3 + = pprInstr (ADD size (OpImm displ) dst) + +pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst + +pprInstr (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp (sLit "dec") size dst +pprInstr (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp (sLit "inc") size dst +pprInstr (ADD size src dst) = pprSizeOpOp (sLit "add") size src dst +pprInstr (ADC size src dst) = pprSizeOpOp (sLit "adc") size src dst +pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst +pprInstr (SBB size src dst) = pprSizeOpOp (sLit "sbb") size src dst +pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 + +pprInstr (ADD_CC size src dst) + = pprSizeOpOp (sLit "add") size src dst +pprInstr (SUB_CC size src dst) + = pprSizeOpOp (sLit "sub") size src dst + +{- A hack. The Intel documentation says that "The two and three + operand forms [of IMUL] may also be used with unsigned operands + because the lower half of the product is the same regardless if + (sic) the operands are signed or unsigned. The CF and OF flags, + however, cannot be used to determine if the upper half of the + result is non-zero." So there. +-} + +-- Use a 32-bit instruction when possible as it saves a byte. +-- Notably, extracting the tag bits of a pointer has this form. +-- TODO: we could save a byte in a subsequent CMP instruction too, +-- but need something like a peephole pass for this +pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst) + | 0 <= mask && mask < 0xffffffff + = pprInstr (AND II32 src dst) +pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst +pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst + +pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst +pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst +pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst + +pprInstr (POPCNT size src dst) = pprOpOp (sLit "popcnt") size src (OpReg dst) +pprInstr (BSF size src dst) = pprOpOp (sLit "bsf") size src (OpReg dst) +pprInstr (BSR size src dst) = pprOpOp (sLit "bsr") size src (OpReg dst) + +pprInstr (PREFETCH NTA size src ) = pprSizeOp_ (sLit "prefetchnta") size src +pprInstr (PREFETCH Lvl0 size src) = pprSizeOp_ (sLit "prefetcht0") size src +pprInstr (PREFETCH Lvl1 size src) = pprSizeOp_ (sLit "prefetcht1") size src +pprInstr (PREFETCH Lvl2 size src) = pprSizeOp_ (sLit "prefetcht2") size src + +pprInstr (NOT size op) = pprSizeOp (sLit "not") size op +pprInstr (BSWAP size op) = pprSizeOp (sLit "bswap") size (OpReg op) +pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op + +pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst +pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst +pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst + +pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src + +pprInstr (CMP size src dst) + | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp (sLit "cmp") size src dst + where + -- This predicate is needed here and nowhere else + is_float FF32 = True + is_float FF64 = True + is_float FF80 = True + is_float _ = False + +pprInstr (TEST size src dst) = sdocWithPlatform $ \platform -> + let size' = case (src,dst) of + -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. + -- We can replace them by equivalent, but smaller instructions + -- by reducing the size of the immediate operand as far as possible. + -- (We could handle masks larger than a single byte too, + -- but it would complicate the code considerably + -- and tag checks are by far the most common case.) + (OpImm (ImmInteger mask), OpReg dstReg) + | 0 <= mask && mask < 256 -> minSizeOfReg platform dstReg + _ -> size + in pprSizeOpOp (sLit "test") size' src dst + where + minSizeOfReg platform (RegReal (RealRegSingle i)) + | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl + | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp + | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b + minSizeOfReg _ _ = size -- other + +pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op +pprInstr (POP size op) = pprSizeOp (sLit "pop") size op + +-- both unused (SDM): +-- pprInstr PUSHA = ptext (sLit "\tpushal") +-- pprInstr POPA = ptext (sLit "\tpopal") + +pprInstr NOP = ptext (sLit "\tnop") +pprInstr (CLTD II32) = ptext (sLit "\tcltd") +pprInstr (CLTD II64) = ptext (sLit "\tcqto") + +pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) + +pprInstr (JXX cond blockid) + = pprCondInstr (sLit "j") cond (ppr lab) + where lab = mkAsmTempLabel (getUnique blockid) + +pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) + +pprInstr (JMP (OpImm imm) _) = ptext (sLit "\tjmp ") <> pprImm imm +pprInstr (JMP op _) = sdocWithPlatform $ \platform -> + ptext (sLit "\tjmp *") <> pprOperand (archWordSize (target32Bit platform)) op +pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op []) +pprInstr (CALL (Left imm) _) = ptext (sLit "\tcall ") <> pprImm imm +pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform -> + ptext (sLit "\tcall *") <> pprReg (archWordSize (target32Bit platform)) reg + +pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op +pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op +pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op + +-- x86_64 only +pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2 +pprInstr (MUL2 size op) = pprSizeOp (sLit "mul") size op + +pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 + +pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to +pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to +pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to +pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to +pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to +pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to + + -- FETCHGOT for PIC on ELF platforms +pprInstr (FETCHGOT reg) + = vcat [ ptext (sLit "\tcall 1f"), + hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], + hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), + pprReg II32 reg ] + ] + + -- FETCHPC for PIC on Darwin/x86 + -- get the instruction pointer into a register + -- (Terminology note: the IP is called Program Counter on PPC, + -- and it's a good thing to use the same name on both platforms) +pprInstr (FETCHPC reg) + = vcat [ ptext (sLit "\tcall 1f"), + hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + ] + + +-- ----------------------------------------------------------------------------- +-- i386 floating-point + +-- Simulating a flat register set on the x86 FP stack is tricky. +-- you have to free %st(7) before pushing anything on the FP reg stack +-- so as to preclude the possibility of a FP stack overflow exception. +pprInstr g@(GMOV src dst) + | src == dst + = empty + | otherwise + = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + +-- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1) +pprInstr g@(GLD sz addr dst) + = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, + pprAddr addr, gsemi, gpop dst 1]) + +-- GST sz src addr ==> FLD dst ; FSTPsz addr +pprInstr g@(GST sz src addr) + | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist + = pprG g (hcat [gtab, + text "fst", pprSize_x87 sz, gsp, pprAddr addr]) + | otherwise + = pprG g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize_x87 sz, gsp, pprAddr addr]) + +pprInstr g@(GLDZ dst) + = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) +pprInstr g@(GLD1 dst) + = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) + +pprInstr (GFTOI src dst) + = pprInstr (GDTOI src dst) + +pprInstr g@(GDTOI src dst) + = pprG g (vcat [ + hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], + hcat [gtab, gpush src 0], + hcat [gtab, text "movzwl 4(%esp), ", reg, + text " ; orl $0xC00, ", reg], + hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"], + hcat [gtab, text "fistpl 0(%esp)"], + hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg], + hcat [gtab, text "addl $8, %esp"] + ]) + where + reg = pprReg II32 dst + +pprInstr (GITOF src dst) + = pprInstr (GITOD src dst) + +pprInstr g@(GITOD src dst) + = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, + text " ; fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) + +pprInstr g@(GDTOF src dst) + = pprG g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) + +{- Gruesome swamp follows. If you're unfortunate enough to have ventured + this far into the jungle AND you give a Rat's Ass (tm) what's going + on, here's the deal. Generate code to do a floating point comparison + of src1 and src2, of kind cond, and set the Zero flag if true. + + The complications are to do with handling NaNs correctly. We want the + property that if either argument is NaN, then the result of the + comparison is False ... except if we're comparing for inequality, + in which case the answer is True. + + Here's how the general (non-inequality) case works. As an + example, consider generating the an equality test: + + pushl %eax -- we need to mess with this + + fcomp and pop pushed src1 + -- Result of comparison is in FPU Status Register bits + -- C3 C2 and C0 + fstsw %ax -- Move FPU Status Reg to %ax + sahf -- move C3 C2 C0 from %ax to integer flag reg + -- now the serious magic begins + setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 + sete %al -- %al = if arg1 == arg2 then 1 else 0 + andb %ah,%al -- %al &= %ah + -- so %al == 1 iff (comparable && same); else it holds 0 + decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); + else %al == 0xFF, ZeroFlag=0 + -- the zero flag is now set as we desire. + popl %eax + + The special case of inequality differs thusly: + + setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0 + setne %al -- %al = if arg1 /= arg2 then 1 else 0 + orb %ah,%al -- %al = if (incomparable || different) then 1 else 0 + decb %al -- if (incomparable || different) then (%al == 0, ZF=1) + else (%al == 0xFF, ZF=0) +-} +pprInstr g@(GCMP cond src1 src2) + | case cond of { NE -> True; _ -> False } + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpe %ah"], + hcat [gtab, text "setne %al ; ", + text "orb %ah,%al ; decb %al ; popl %eax"] + ]) + | otherwise + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpo %ah"], + hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ", + text "andb %ah,%al ; decb %al ; popl %eax"] + ]) + where + {- On the 486, the flags set by FP compare are the unsigned ones! + (This looks like a HACK to me. WDP 96/03) + -} + fix_FP_cond :: Cond -> Cond + fix_FP_cond GE = GEU + fix_FP_cond GTT = GU + fix_FP_cond LTT = LU + fix_FP_cond LE = LEU + fix_FP_cond EQQ = EQQ + fix_FP_cond NE = NE + fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match" + -- there should be no others + + +pprInstr g@(GABS _ src dst) + = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) + +pprInstr g@(GNEG _ src dst) + = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) + +pprInstr g@(GSQRT sz src dst) + = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) + +pprInstr g@(GSIN sz l1 l2 src dst) + = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) + +pprInstr g@(GCOS sz l1 l2 src dst) + = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) + +pprInstr g@(GTAN sz l1 l2 src dst) + = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) + +-- In the translations for GADD, GMUL, GSUB and GDIV, +-- the first two cases are mere optimisations. The otherwise clause +-- generates correct code under all circumstances. + +pprInstr g@(GADD _ src1 src2 dst) + | src1 == dst + = pprG g (text "\t#GADD-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; faddp %st(0),", greg src1 1]) + | src2 == dst + = pprG g (text "\t#GADD-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; faddp %st(0),", greg src2 1]) + | otherwise + = pprG g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) + + +pprInstr g@(GMUL _ src1 src2 dst) + | src1 == dst + = pprG g (text "\t#GMUL-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fmulp %st(0),", greg src1 1]) + | src2 == dst + = pprG g (text "\t#GMUL-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fmulp %st(0),", greg src2 1]) + | otherwise + = pprG g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) + + +pprInstr g@(GSUB _ src1 src2 dst) + | src1 == dst + = pprG g (text "\t#GSUB-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fsubrp %st(0),", greg src1 1]) + | src2 == dst + = pprG g (text "\t#GSUB-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fsubp %st(0),", greg src2 1]) + | otherwise + = pprG g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) + + +pprInstr g@(GDIV _ src1 src2 dst) + | src1 == dst + = pprG g (text "\t#GDIV-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fdivrp %st(0),", greg src1 1]) + | src2 == dst + = pprG g (text "\t#GDIV-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fdivp %st(0),", greg src2 1]) + | otherwise + = pprG g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) + + +pprInstr GFREE + = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), + ptext (sLit "\tffree %st(4) ;ffree %st(5)") + ] + +-- Atomics + +pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i + +pprInstr MFENCE = ptext (sLit "\tmfence") + +pprInstr (XADD size src dst) = pprSizeOpOp (sLit "xadd") size src dst + +pprInstr (CMPXCHG size src dst) = pprSizeOpOp (sLit "cmpxchg") size src dst + +pprInstr _ + = panic "X86.Ppr.pprInstr: no match" + + +pprTrigOp :: String -> Bool -> CLabel -> CLabel + -> Reg -> Reg -> Size -> SDoc +pprTrigOp op -- fsin, fcos or fptan + isTan -- we need a couple of extra steps if we're doing tan + l1 l2 -- internal labels for us to use + src dst sz + = -- We'll be needing %eax later on + hcat [gtab, text "pushl %eax;"] $$ + -- tan is going to use an extra space on the FP stack + (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$ + -- First put the value in %st(0) and try to apply the op to it + hcat [gpush src 0, text ("; " ++ op)] $$ + -- Now look to see if C2 was set (overflow, |value| >= 2^63) + hcat [gtab, text "fnstsw %ax"] $$ + hcat [gtab, text "test $0x400,%eax"] $$ + -- If we were in bounds then jump to the end + hcat [gtab, text "je " <> ppr l1] $$ + -- Otherwise we need to shrink the value. Start by + -- loading pi, doubleing it (by adding it to itself), + -- and then swapping pi with the value, so the value we + -- want to apply op to is in %st(0) again + hcat [gtab, text "ffree %st(7); fldpi"] $$ + hcat [gtab, text "fadd %st(0),%st"] $$ + hcat [gtab, text "fxch %st(1)"] $$ + -- Now we have a loop in which we make the value smaller, + -- see if it's small enough, and loop if not + (ppr l2 <> char ':') $$ + hcat [gtab, text "fprem1"] $$ + -- My Debian libc uses fstsw here for the tan code, but I can't + -- see any reason why it should need to be different for tan. + hcat [gtab, text "fnstsw %ax"] $$ + hcat [gtab, text "test $0x400,%eax"] $$ + hcat [gtab, text "jne " <> ppr l2] $$ + hcat [gtab, text "fstp %st(1)"] $$ + hcat [gtab, text op] $$ + (ppr l1 <> char ':') $$ + -- Pop the 1.0 tan gave us + (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$ + -- Restore %eax + hcat [gtab, text "popl %eax;"] $$ + -- And finally make the result the right size + hcat [gtab, gcoerceto sz, gpop dst 1] + +-------------------------- + +-- coerce %st(0) to the specified size +gcoerceto :: Size -> SDoc +gcoerceto FF64 = empty +gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " +gcoerceto _ = panic "X86.Ppr.gcoerceto: no match" + +gpush :: Reg -> RegNo -> SDoc +gpush reg offset + = hcat [text "fld ", greg reg offset] + +gpop :: Reg -> RegNo -> SDoc +gpop reg offset + = hcat [text "fstp ", greg reg offset] + +greg :: Reg -> RegNo -> SDoc +greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')' + +gsemi :: SDoc +gsemi = text " ; " + +gtab :: SDoc +gtab = char '\t' + +gsp :: SDoc +gsp = char ' ' + +gregno :: Reg -> RegNo +gregno (RegReal (RealRegSingle i)) = i +gregno _ = --pprPanic "gregno" (ppr other) + 999 -- bogus; only needed for debug printing + +pprG :: Instr -> SDoc -> SDoc +pprG fake actual + = (char '#' <> pprGInstr fake) $$ actual + + +pprGInstr :: Instr -> SDoc +pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst +pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst +pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst + +pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst +pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst + +pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst +pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst + +pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst +pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst +pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst + +pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst +pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst +pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst +pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst +pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst +pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst +pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst + +pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst +pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst +pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst +pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst + +pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" + +pprDollImm :: Imm -> SDoc +pprDollImm i = ptext (sLit "$") <> pprImm i + + +pprOperand :: Size -> Operand -> SDoc +pprOperand s (OpReg r) = pprReg s r +pprOperand _ (OpImm i) = pprDollImm i +pprOperand _ (OpAddr ea) = pprAddr ea + + +pprMnemonic_ :: LitString -> SDoc +pprMnemonic_ name = + char '\t' <> ptext name <> space + + +pprMnemonic :: LitString -> Size -> SDoc +pprMnemonic name size = + char '\t' <> ptext name <> pprSize size <> space + + +pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> SDoc +pprSizeImmOp name size imm op1 + = hcat [ + pprMnemonic name size, + char '$', + pprImm imm, + comma, + pprOperand size op1 + ] + + +pprSizeOp_ :: LitString -> Size -> Operand -> SDoc +pprSizeOp_ name size op1 + = hcat [ + pprMnemonic_ name , + pprOperand size op1 + ] + +pprSizeOp :: LitString -> Size -> Operand -> SDoc +pprSizeOp name size op1 + = hcat [ + pprMnemonic name size, + pprOperand size op1 + ] + + +pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> SDoc +pprSizeOpOp name size op1 op2 + = hcat [ + pprMnemonic name size, + pprOperand size op1, + comma, + pprOperand size op2 + ] + + +pprOpOp :: LitString -> Size -> Operand -> Operand -> SDoc +pprOpOp name size op1 op2 + = hcat [ + pprMnemonic_ name, + pprOperand size op1, + comma, + pprOperand size op2 + ] + + +pprSizeReg :: LitString -> Size -> Reg -> SDoc +pprSizeReg name size reg1 + = hcat [ + pprMnemonic name size, + pprReg size reg1 + ] + + +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> SDoc +pprSizeRegReg name size reg1 reg2 + = hcat [ + pprMnemonic name size, + pprReg size reg1, + comma, + pprReg size reg2 + ] + + +pprRegReg :: LitString -> Reg -> Reg -> SDoc +pprRegReg name reg1 reg2 + = sdocWithPlatform $ \platform -> + hcat [ + pprMnemonic_ name, + pprReg (archWordSize (target32Bit platform)) reg1, + comma, + pprReg (archWordSize (target32Bit platform)) reg2 + ] + + +pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> SDoc +pprSizeOpReg name size op1 reg2 + = sdocWithPlatform $ \platform -> + hcat [ + pprMnemonic name size, + pprOperand size op1, + comma, + pprReg (archWordSize (target32Bit platform)) reg2 + ] + +pprCondOpReg :: LitString -> Size -> Cond -> Operand -> Reg -> SDoc +pprCondOpReg name size cond op1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprOperand size op1, + comma, + pprReg size reg2 + ] + +pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> SDoc +pprCondRegReg name size cond reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprReg size reg1, + comma, + pprReg size reg2 + ] + +pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> SDoc +pprSizeSizeRegReg name size1 size2 reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprSize size1, + pprSize size2, + space, + pprReg size1 reg1, + comma, + pprReg size2 reg2 + ] + +pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> SDoc +pprSizeSizeOpReg name size1 size2 op1 reg2 + = hcat [ + pprMnemonic name size2, + pprOperand size1 op1, + comma, + pprReg size2 reg2 + ] + +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc +pprSizeRegRegReg name size reg1 reg2 reg3 + = hcat [ + pprMnemonic name size, + pprReg size reg1, + comma, + pprReg size reg2, + comma, + pprReg size reg3 + ] + + +pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> SDoc +pprSizeAddrReg name size op dst + = hcat [ + pprMnemonic name size, + pprAddr op, + comma, + pprReg size dst + ] + + +pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> SDoc +pprSizeRegAddr name size src op + = hcat [ + pprMnemonic name size, + pprReg size src, + comma, + pprAddr op + ] + + +pprShift :: LitString -> Size -> Operand -> Operand -> SDoc +pprShift name size src dest + = hcat [ + pprMnemonic name size, + pprOperand II8 src, -- src is 8-bit sized + comma, + pprOperand size dest + ] + + +pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> SDoc +pprSizeOpOpCoerce name size1 size2 op1 op2 + = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, + pprOperand size1 op1, + comma, + pprOperand size2 op2 + ] + + +pprCondInstr :: LitString -> Cond -> SDoc -> SDoc +pprCondInstr name cond arg + = hcat [ char '\t', ptext name, pprCond cond, space, arg] + diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs new file mode 100644 index 00000000..39535634 --- /dev/null +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +module X86.RegInfo ( + mkVirtualReg, + regDotColor +) + +where + +#include "nativeGen/NCG.h" +#include "HsVersions.h" + +import Size +import Reg + +import Outputable +import Platform +import Unique + +import UniqFM +import X86.Regs + + +mkVirtualReg :: Unique -> Size -> VirtualReg +mkVirtualReg u size + = case size of + FF32 -> VirtualRegSSE u + FF64 -> VirtualRegSSE u + FF80 -> VirtualRegD u + _other -> VirtualRegI u + +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = let Just str = lookupUFM (regColors platform) reg + in text str + +regColors :: Platform -> UniqFM [Char] +regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) + +normalRegColors :: Platform -> [(Reg,String)] +normalRegColors platform + | target32Bit platform = [ (eax, "#00ff00") + , (ebx, "#0000ff") + , (ecx, "#00ffff") + , (edx, "#0080ff") ] + | otherwise = [ (rax, "#00ff00"), (eax, "#00ff00") + , (rbx, "#0000ff"), (ebx, "#0000ff") + , (rcx, "#00ffff"), (ecx, "#00ffff") + , (rdx, "#0080ff"), (edx, "#00ffff") + , (r8, "#00ff80") + , (r9, "#008080") + , (r10, "#0040ff") + , (r11, "#00ff40") + , (r12, "#008040") + , (r13, "#004080") + , (r14, "#004040") + , (r15, "#002080") ] + +fpRegColors :: [(Reg,String)] +fpRegColors = + [ (fake0, "#ff00ff") + , (fake1, "#ff00aa") + , (fake2, "#aa00ff") + , (fake3, "#aa00aa") + , (fake4, "#ff0055") + , (fake5, "#5500ff") ] + + ++ zip (map regSingle [24..39]) (repeat "red") diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs new file mode 100644 index 00000000..4162e2b7 --- /dev/null +++ b/compiler/nativeGen/X86/Regs.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} + +module X86.Regs ( + -- squeese functions for the graph allocator + virtualRegSqueeze, + realRegSqueeze, + + -- immediates + Imm(..), + strImmLit, + litToImm, + + -- addressing modes + AddrMode(..), + addrOffset, + + -- registers + spRel, + argRegs, + allArgRegs, + allIntArgRegs, + callClobberedRegs, + instrClobberedRegs, + allMachRegNos, + classOfRealReg, + showReg, + + -- machine specific + EABase(..), EAIndex(..), addrModeRegs, + + eax, ebx, ecx, edx, esi, edi, ebp, esp, + fake0, fake1, fake2, fake3, fake4, fake5, firstfake, + + rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp, + r8, r9, r10, r11, r12, r13, r14, r15, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15, + xmm, + + ripRel, + allFPArgRegs, + + allocatableRegs +) + +where + +#include "nativeGen/NCG.h" +#include "HsVersions.h" + +import CodeGen.Platform +import Reg +import RegClass + +import Cmm +import CLabel ( CLabel ) +import DynFlags +import Outputable +import Platform +import FastTypes +import FastBool + + +-- | regSqueeze_class reg +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) + _other -> _ILIT(0) + + RcDouble + -> case vr of + VirtualRegD{} -> _ILIT(1) + VirtualRegF{} -> _ILIT(0) + _other -> _ILIT(0) + + RcDoubleSSE + -> case vr of + VirtualRegSSE{} -> _ILIT(1) + _other -> _ILIT(0) + + _other -> _ILIT(0) + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> FastInt +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < firstfake -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo >= firstfake && regNo <= lastfake -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcDoubleSSE + -> case rr of + RealRegSingle regNo | regNo >= firstxmm -> _ILIT(1) + _otherwise -> _ILIT(0) + + _other -> _ILIT(0) + +-- ----------------------------------------------------------------------------- +-- Immediates + +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit SDoc -- Simple string + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + + +strImmLit :: String -> Imm +strImmLit s = ImmLit (text s) + + +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) + -- narrow to the width: a CmmInt might be out of + -- range, but we assume that ImmInteger only contains + -- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off) + = ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm _ = panic "X86.Regs.litToImm: no match" + +-- addressing modes ------------------------------------------------------------ + +data AddrMode + = AddrBaseIndex EABase EAIndex Displacement + | ImmAddr Imm Int + +data EABase = EABaseNone | EABaseReg Reg | EABaseRip +data EAIndex = EAIndexNone | EAIndex Reg Int +type Displacement = Imm + + +addrOffset :: AddrMode -> Int -> Maybe AddrMode +addrOffset addr off + = case addr of + ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) + + AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) + AddrBaseIndex r i (ImmInteger n) + -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) + + AddrBaseIndex r i (ImmCLbl lbl) + -> Just (AddrBaseIndex r i (ImmIndex lbl off)) + + AddrBaseIndex r i (ImmIndex lbl ix) + -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off))) + + _ -> Nothing -- in theory, shouldn't happen + + +addrModeRegs :: AddrMode -> [Reg] +addrModeRegs (AddrBaseIndex b i _) = b_regs ++ i_regs + where + b_regs = case b of { EABaseReg r -> [r]; _ -> [] } + i_regs = case i of { EAIndex r _ -> [r]; _ -> [] } +addrModeRegs _ = [] + + +-- registers ------------------------------------------------------------------- + +-- @spRel@ gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. @fpRel@, where +-- applicable, is the same but for the frame pointer. + + +spRel :: DynFlags + -> Int -- ^ desired stack offset in bytes, positive or negative + -> AddrMode +spRel dflags n + | target32Bit (targetPlatform dflags) + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) + | otherwise + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) + +-- The register numbers must fit into 32 bits on x86, so that we can +-- use a Word32 to represent the set of free registers in the register +-- allocator. + +firstfake, lastfake :: RegNo +firstfake = 16 +lastfake = 21 + +firstxmm :: RegNo +firstxmm = 24 + +lastxmm :: Platform -> RegNo +lastxmm platform + | target32Bit platform = 31 + | otherwise = 39 + +lastint :: Platform -> RegNo +lastint platform + | target32Bit platform = 7 -- not %r8..%r15 + | otherwise = 15 + +intregnos :: Platform -> [RegNo] +intregnos platform = [0 .. lastint platform] + +fakeregnos :: [RegNo] +fakeregnos = [firstfake .. lastfake] + +xmmregnos :: Platform -> [RegNo] +xmmregnos platform = [firstxmm .. lastxmm platform] + +floatregnos :: Platform -> [RegNo] +floatregnos platform = fakeregnos ++ xmmregnos platform + + +-- argRegs is the set of regs which are read for an n-argument call to C. +-- For archs which pass all args on the stack (x86), is empty. +-- Sparc passes up to the first 6 args in regs. +argRegs :: RegNo -> [Reg] +argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" + +-- | The complete set of machine registers. +allMachRegNos :: Platform -> [RegNo] +allMachRegNos platform = intregnos platform ++ floatregnos platform + +-- | Take the class of a register. +{-# INLINE classOfRealReg #-} +classOfRealReg :: Platform -> RealReg -> RegClass +-- On x86, we might want to have an 8-bit RegClass, which would +-- contain just regs 1-4 (the others don't have 8-bit versions). +-- However, we can get away without this at the moment because the +-- only allocatable integer regs are also 8-bit compatible (1, 3, 4). +classOfRealReg platform reg + = case reg of + RealRegSingle i + | i <= lastint platform -> RcInteger + | i <= lastfake -> RcDouble + | otherwise -> RcDoubleSSE + + RealRegPair{} -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" + +-- | Get the name of the register with this number. +showReg :: Platform -> RegNo -> String +showReg platform n + | n >= firstxmm = "%xmm" ++ show (n-firstxmm) + | n >= firstfake = "%fake" ++ show (n-firstfake) + | n >= 8 = "%r" ++ show n + | otherwise = regNames platform !! n + +regNames :: Platform -> [String] +regNames platform + = if target32Bit platform + then ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"] + else ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"] + + + +-- machine specific ------------------------------------------------------------ + + +{- +Intel x86 architecture: +- All registers except 7 (esp) are available for use. +- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). +- Registers 0-7 have 16-bit counterparts (ax, bx etc.) +- Registers 0-3 have 8 bit counterparts (ah, bh etc.) +- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable + fp registers, and 3-operand insns for them, and we translate this into + real stack-based x86 fp code after register allocation. + +The fp registers are all Double registers; we don't have any RcFloat class +regs. @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should +never generate them. +-} + +fake0, fake1, fake2, fake3, fake4, fake5, + eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg + +eax = regSingle 0 +ebx = regSingle 1 +ecx = regSingle 2 +edx = regSingle 3 +esi = regSingle 4 +edi = regSingle 5 +ebp = regSingle 6 +esp = regSingle 7 +fake0 = regSingle 16 +fake1 = regSingle 17 +fake2 = regSingle 18 +fake3 = regSingle 19 +fake4 = regSingle 20 +fake5 = regSingle 21 + + + +{- +AMD x86_64 architecture: +- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: + + 8 16 32 64 + --------------------- + al ax eax rax + bl bx ebx rbx + cl cx ecx rcx + dl dx edx rdx + sil si esi rsi + dil si edi rdi + bpl bp ebp rbp + spl sp esp rsp + r10b r10w r10d r10 + r11b r11w r11d r11 + r12b r12w r12d r12 + r13b r13w r13d r13 + r14b r14w r14d r14 + r15b r15w r15d r15 +-} + +rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, + r8, r9, r10, r11, r12, r13, r14, r15, + xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, + xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg + +rax = regSingle 0 +rbx = regSingle 1 +rcx = regSingle 2 +rdx = regSingle 3 +rsi = regSingle 4 +rdi = regSingle 5 +rbp = regSingle 6 +rsp = regSingle 7 +r8 = regSingle 8 +r9 = regSingle 9 +r10 = regSingle 10 +r11 = regSingle 11 +r12 = regSingle 12 +r13 = regSingle 13 +r14 = regSingle 14 +r15 = regSingle 15 +xmm0 = regSingle 24 +xmm1 = regSingle 25 +xmm2 = regSingle 26 +xmm3 = regSingle 27 +xmm4 = regSingle 28 +xmm5 = regSingle 29 +xmm6 = regSingle 30 +xmm7 = regSingle 31 +xmm8 = regSingle 32 +xmm9 = regSingle 33 +xmm10 = regSingle 34 +xmm11 = regSingle 35 +xmm12 = regSingle 36 +xmm13 = regSingle 37 +xmm14 = regSingle 38 +xmm15 = regSingle 39 + +ripRel :: Displacement -> AddrMode +ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm + + + -- so we can re-use some x86 code: +{- +eax = rax +ebx = rbx +ecx = rcx +edx = rdx +esi = rsi +edi = rdi +ebp = rbp +esp = rsp +-} + +xmm :: RegNo -> Reg +xmm n = regSingle (firstxmm+n) + + + + +-- | these are the regs which we cannot assume stay alive over a C call. +callClobberedRegs :: Platform -> [Reg] +-- caller-saves registers +callClobberedRegs platform + | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) + | platformOS platform == OSMinGW32 + = [rax,rcx,rdx,r8,r9,r10,r11] + ++ map regSingle (floatregnos platform) + | otherwise + -- all xmm regs are caller-saves + -- caller-saves registers + = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] + ++ map regSingle (floatregnos platform) + +allArgRegs :: Platform -> [(Reg, Reg)] +allArgRegs platform + | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9] + (map regSingle [firstxmm ..]) + | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch" + +allIntArgRegs :: Platform -> [Reg] +allIntArgRegs platform + | (platformOS platform == OSMinGW32) || target32Bit platform + = panic "X86.Regs.allIntArgRegs: not defined for this platform" + | otherwise = [rdi,rsi,rdx,rcx,r8,r9] + +allFPArgRegs :: Platform -> [Reg] +allFPArgRegs platform + | platformOS platform == OSMinGW32 + = panic "X86.Regs.allFPArgRegs: not defined for this platform" + | otherwise = map regSingle [firstxmm .. firstxmm+7] + +-- Machine registers which might be clobbered by instructions that +-- generate results into fixed registers, or need arguments in a fixed +-- register. +instrClobberedRegs :: Platform -> [Reg] +instrClobberedRegs platform + | target32Bit platform = [ eax, ecx, edx ] + | otherwise = [ rax, rcx, rdx ] + +-- + +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform + = let isFree i = isFastTrue (freeReg platform i) + in map RealRegSingle $ filter isFree (allMachRegNos platform) + diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs new file mode 100644 index 00000000..0c80ec72 --- /dev/null +++ b/compiler/parser/ApiAnnotation.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module ApiAnnotation ( + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments,getAndRemoveAnnotationComments, + ApiAnns, + ApiAnnKey, + AnnKeywordId(..), + AnnotationComment(..), + LRdrName -- Exists for haddocks only + ) where + +import RdrName +import Outputable +import SrcLoc +import qualified Data.Map as Map +import Data.Data + + +{- +Note [Api annotations] +~~~~~~~~~~~~~~~~~~~~~~ +In order to do source to source conversions using the GHC API, the +locations of all elements of the original source needs to be tracked. +The includes keywords such as 'let' / 'in' / 'do' etc as well as +punctuation such as commas and braces, and also comments. + +These are captured in a structure separate from the parse tree, and +returned in the pm_annotations field of the ParsedModule type. + +The non-comment annotations are stored indexed to the SrcSpan of the +AST element containing them, together with a AnnKeywordId value +identifying the specific keyword being captured. + +> type ApiAnnKey = (SrcSpan,AnnKeywordId) +> +> Map.Map ApiAnnKey SrcSpan + +So + +> let X = 1 in 2 *x + +would result in the AST element + + L span (HsLet (binds for x = 1) (2 * x)) + +and the annotations + + (span,AnnLet) having the location of the 'let' keyword + (span,AnnIn) having the location of the 'in' keyword + + +The comments are indexed to the SrcSpan of the lowest AST element +enclosing them + +> Map.Map SrcSpan [Located AnnotationComment] + +So the full ApiAnns type is + +> type ApiAnns = ( Map.Map ApiAnnKey SrcSpan +> , Map.Map SrcSpan [Located AnnotationComment]) + + +This is done in the lexer / parser as follows. + + +The PState variable in the lexer has the following variables added + +> annotations :: [(ApiAnnKey,[SrcSpan])], +> comment_q :: [Located AnnotationComment], +> annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + +The first and last store the values that end up in the ApiAnns value +at the end via Map.fromList + +The comment_q captures comments as they are seen in the token stream, +so that when they are ready to be allocated via the parser they are +available. + +The parser interacts with the lexer using the function + +> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () + +which takes the AST element SrcSpan, the annotation keyword and the +target SrcSpan. + +This adds the annotation to the `annotations` field of `PState` and +transfers any comments in `comment_q` to the `annotations_comments` +field. + +Parser +------ + +The parser implements a number of helper types and methods for the +capture of annotations + +> type AddAnn = (SrcSpan -> P ()) +> +> mj :: AnnKeywordId -> Located e -> (SrcSpan -> P ()) +> mj a l = (\s -> addAnnotation s a (gl l)) + +AddAnn represents the addition of an annotation a to a provided +SrcSpan, and `mj` constructs an AddAnn value. + +> ams :: Located a -> [AddAnn] -> P (Located a) +> ams a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return a + +So the production in Parser.y for the HsLet AST element is + + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) + (mj AnnLet $1:mj AnnIn $3 + :(fst $ unLoc $2)) } + +This adds an AnnLet annotation for 'let', an AnnIn for 'in', as well +as any annotations that may arise in the binds. This will include open +and closing braces if they are used to delimit the let expressions. + +The wiki page describing this feature is +https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations + +-} +-- --------------------------------------------------------------------- + +type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] + , Map.Map SrcSpan [Located AnnotationComment]) + +type ApiAnnKey = (SrcSpan,AnnKeywordId) + + +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan] +getAnnotation (anns,_) span ann + = case Map.lookup (span,ann) anns of + Nothing -> [] + Just ss -> ss + +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +-- The list is removed from the annotations. +getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId + -> ([SrcSpan],ApiAnns) +getAndRemoveAnnotation (anns,cs) span ann + = case Map.lookup (span,ann) anns of + Nothing -> ([],(anns,cs)) + Just ss -> (ss,(Map.delete (span,ann) anns,cs)) + +-- |Retrieve the comments allocated to the current 'SrcSpan' +-- +-- Note: A given 'SrcSpan' may appear in multiple AST elements, +-- beware of duplicates +getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] +getAnnotationComments (_,anns) span = + case Map.lookup span anns of + Just cs -> cs + Nothing -> [] + +-- |Retrieve the comments allocated to the current 'SrcSpan', and +-- remove them from the annotations +getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan + -> ([Located AnnotationComment],ApiAnns) +getAndRemoveAnnotationComments (anns,canns) span = + case Map.lookup span canns of + Just cs -> (cs,(anns,Map.delete span canns)) + Nothing -> ([],(anns,canns)) + +-- -------------------------------------------------------------------- + +-- | API Annotations exist so that tools can perform source to source +-- conversions of Haskell code. They are used to keep track of the +-- various syntactic keywords that are not captured in the existing +-- AST. +-- +-- The annotations, together with original source comments are made +-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. +-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in +-- @'DynFlags.DynFlags'@ before parsing. +-- +-- The wiki page describing this feature is +-- https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations +-- +-- Note: in general the names of these are taken from the +-- corresponding token, unless otherwise noted +-- See note [Api annotations] above for details of the usage +data AnnKeywordId + = AnnAs + | AnnAt + | AnnBang -- ^ '!' + | AnnBackquote -- ^ '`' + | AnnBy + | AnnCase -- ^ case or lambda case + | AnnClass + | AnnClose -- ^ '\#)' or '\#-}' etc + | AnnCloseC -- ^ '}' + | AnnCloseP -- ^ ')' + | AnnCloseS -- ^ ']' + | AnnColon + | AnnComma -- ^ as a list separator + | AnnCommaTuple -- ^ in a RdrName for a tuple + | AnnDarrow -- ^ '=>' + | AnnData + | AnnDcolon -- ^ '::' + | AnnDefault + | AnnDeriving + | AnnDo + | AnnDot -- ^ '.' + | AnnDotdot -- ^ '..' + | AnnElse + | AnnEqual + | AnnExport + | AnnFamily + | AnnForall + | AnnForeign + | AnnFunId -- ^ for function name in matches where there are + -- multiple equations for the function. + | AnnGroup + | AnnHeader -- ^ for CType + | AnnHiding + | AnnIf + | AnnImport + | AnnIn + | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' + | AnnInstance + | AnnLam + | AnnLarrow -- ^ '<-' + | AnnLet + | AnnMdo + | AnnMinus -- ^ '-' + | AnnModule + | AnnNewtype + | AnnName -- ^ where a name loses its location in the AST, this carries it + | AnnOf + | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc + | AnnOpenC -- ^ '{' + | AnnOpenP -- ^ '(' + | AnnOpenPE -- ^ '$(' + | AnnOpenPTE -- ^ '$$(' + | AnnOpenS -- ^ '[' + | AnnPackageName + | AnnPattern + | AnnProc + | AnnQualified + | AnnRarrow -- ^ '->' + | AnnRec + | AnnRole + | AnnSafe + | AnnSemi -- ^ ';' + | AnnSimpleQuote -- ^ ''' + | AnnStatic -- ^ 'static' + | AnnThen + | AnnThIdSplice -- ^ '$' + | AnnThIdTySplice -- ^ '$$' + | AnnThTyQuote -- ^ double ''' + | AnnTilde -- ^ '~' + | AnnTildehsh -- ^ '~#' + | AnnType + | AnnUnit -- ^ '()' for types + | AnnUsing + | AnnVal -- ^ e.g. INTEGER + | AnnValStr -- ^ String value, will need quotes when output + | AnnVbar -- ^ '|' + | AnnWhere + | Annlarrowtail -- ^ '-<' + | Annrarrowtail -- ^ '->' + | AnnLarrowtail -- ^ '-<<' + | AnnRarrowtail -- ^ '>>-' + | AnnEofPos + deriving (Eq,Ord,Data,Typeable,Show) + +instance Outputable AnnKeywordId where + ppr x = text (show x) + +-- --------------------------------------------------------------------- + +data AnnotationComment = + -- Documentation annotations + AnnDocCommentNext String -- ^ something beginning '-- |' + | AnnDocCommentPrev String -- ^ something beginning '-- ^' + | AnnDocCommentNamed String -- ^ something beginning '-- $' + | AnnDocSection Int String -- ^ a section heading + | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) + | AnnDocOptionsOld String -- ^ doc options declared "-- # ..."-style + | AnnLineComment String -- ^ comment starting by "--" + | AnnBlockComment String -- ^ comment in {- -} + deriving (Eq,Ord,Data,Typeable,Show) +-- Note: these are based on the Token versions, but the Token type is +-- defined in Lexer.x and bringing it in here would create a loop + +instance Outputable AnnotationComment where + ppr x = text (show x) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma', +-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh', +-- 'ApiAnnotation.AnnTilde' +-- - May have 'ApiAnnotation.AnnComma' when in a list +type LRdrName = Located RdrName diff --git a/compiler/parser/Ctype.hs b/compiler/parser/Ctype.hs new file mode 100644 index 00000000..6423218f --- /dev/null +++ b/compiler/parser/Ctype.hs @@ -0,0 +1,216 @@ +-- Character classification +{-# LANGUAGE CPP #-} +module Ctype + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where + +#include "HsVersions.h" + +import Data.Int ( Int32 ) +import Data.Bits ( Bits((.&.)) ) +import Data.Char ( ord, chr ) +import Panic + +-- Bit masks + +cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Int +cIdent = 1 +cSymbol = 2 +cAny = 4 +cSpace = 8 +cLower = 16 +cUpper = 32 +cDigit = 64 + +-- | The predicates below look costly, but aren't, GHC+GCC do a great job +-- at the big case below. + +{-# INLINE is_ctype #-} +is_ctype :: Int -> Char -> Bool +is_ctype mask c = (fromIntegral (charType c) .&. fromIntegral mask) /= (0::Int32) + +is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, + is_alphanum :: Char -> Bool +is_ident = is_ctype cIdent +is_symbol = is_ctype cSymbol +is_any = is_ctype cAny +is_space = is_ctype cSpace +is_lower = is_ctype cLower +is_upper = is_ctype cUpper +is_digit = is_ctype cDigit +is_alphanum = is_ctype (cLower+cUpper+cDigit) + +-- Utils + +hexDigit :: Char -> Int +hexDigit c | is_decdigit c = ord c - ord '0' + | otherwise = ord (to_lower c) - ord 'a' + 10 + +octDecDigit :: Char -> Int +octDecDigit c = ord c - ord '0' + +is_decdigit :: Char -> Bool +is_decdigit c + = c >= '0' && c <= '9' + +is_hexdigit :: Char -> Bool +is_hexdigit c + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + +is_octdigit :: Char -> Bool +is_octdigit c = c >= '0' && c <= '7' + +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + +to_lower :: Char -> Char +to_lower c + | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) + | otherwise = c + +-- | We really mean .|. instead of + below, but GHC currently doesn't do +-- any constant folding with bitops. *sigh* + +charType :: Char -> Int +charType c = case c of + '\0' -> 0 -- \000 + '\1' -> 0 -- \001 + '\2' -> 0 -- \002 + '\3' -> 0 -- \003 + '\4' -> 0 -- \004 + '\5' -> 0 -- \005 + '\6' -> 0 -- \006 + '\7' -> 0 -- \007 + '\8' -> 0 -- \010 + '\9' -> cSpace -- \t (not allowed in strings, so !cAny) + '\10' -> cSpace -- \n (ditto) + '\11' -> cSpace -- \v (ditto) + '\12' -> cSpace -- \f (ditto) + '\13' -> cSpace -- ^M (ditto) + '\14' -> 0 -- \016 + '\15' -> 0 -- \017 + '\16' -> 0 -- \020 + '\17' -> 0 -- \021 + '\18' -> 0 -- \022 + '\19' -> 0 -- \023 + '\20' -> 0 -- \024 + '\21' -> 0 -- \025 + '\22' -> 0 -- \026 + '\23' -> 0 -- \027 + '\24' -> 0 -- \030 + '\25' -> 0 -- \031 + '\26' -> 0 -- \032 + '\27' -> 0 -- \033 + '\28' -> 0 -- \034 + '\29' -> 0 -- \035 + '\30' -> 0 -- \036 + '\31' -> 0 -- \037 + '\32' -> cAny + cSpace -- + '\33' -> cAny + cSymbol -- ! + '\34' -> cAny -- " + '\35' -> cAny + cSymbol -- # + '\36' -> cAny + cSymbol -- $ + '\37' -> cAny + cSymbol -- % + '\38' -> cAny + cSymbol -- & + '\39' -> cAny + cIdent -- ' + '\40' -> cAny -- ( + '\41' -> cAny -- ) + '\42' -> cAny + cSymbol -- * + '\43' -> cAny + cSymbol -- + + '\44' -> cAny -- , + '\45' -> cAny + cSymbol -- - + '\46' -> cAny + cSymbol -- . + '\47' -> cAny + cSymbol -- / + '\48' -> cAny + cIdent + cDigit -- 0 + '\49' -> cAny + cIdent + cDigit -- 1 + '\50' -> cAny + cIdent + cDigit -- 2 + '\51' -> cAny + cIdent + cDigit -- 3 + '\52' -> cAny + cIdent + cDigit -- 4 + '\53' -> cAny + cIdent + cDigit -- 5 + '\54' -> cAny + cIdent + cDigit -- 6 + '\55' -> cAny + cIdent + cDigit -- 7 + '\56' -> cAny + cIdent + cDigit -- 8 + '\57' -> cAny + cIdent + cDigit -- 9 + '\58' -> cAny + cSymbol -- : + '\59' -> cAny -- ; + '\60' -> cAny + cSymbol -- < + '\61' -> cAny + cSymbol -- = + '\62' -> cAny + cSymbol -- > + '\63' -> cAny + cSymbol -- ? + '\64' -> cAny + cSymbol -- @ + '\65' -> cAny + cIdent + cUpper -- A + '\66' -> cAny + cIdent + cUpper -- B + '\67' -> cAny + cIdent + cUpper -- C + '\68' -> cAny + cIdent + cUpper -- D + '\69' -> cAny + cIdent + cUpper -- E + '\70' -> cAny + cIdent + cUpper -- F + '\71' -> cAny + cIdent + cUpper -- G + '\72' -> cAny + cIdent + cUpper -- H + '\73' -> cAny + cIdent + cUpper -- I + '\74' -> cAny + cIdent + cUpper -- J + '\75' -> cAny + cIdent + cUpper -- K + '\76' -> cAny + cIdent + cUpper -- L + '\77' -> cAny + cIdent + cUpper -- M + '\78' -> cAny + cIdent + cUpper -- N + '\79' -> cAny + cIdent + cUpper -- O + '\80' -> cAny + cIdent + cUpper -- P + '\81' -> cAny + cIdent + cUpper -- Q + '\82' -> cAny + cIdent + cUpper -- R + '\83' -> cAny + cIdent + cUpper -- S + '\84' -> cAny + cIdent + cUpper -- T + '\85' -> cAny + cIdent + cUpper -- U + '\86' -> cAny + cIdent + cUpper -- V + '\87' -> cAny + cIdent + cUpper -- W + '\88' -> cAny + cIdent + cUpper -- X + '\89' -> cAny + cIdent + cUpper -- Y + '\90' -> cAny + cIdent + cUpper -- Z + '\91' -> cAny -- [ + '\92' -> cAny + cSymbol -- backslash + '\93' -> cAny -- ] + '\94' -> cAny + cSymbol -- ^ + '\95' -> cAny + cIdent + cLower -- _ + '\96' -> cAny -- ` + '\97' -> cAny + cIdent + cLower -- a + '\98' -> cAny + cIdent + cLower -- b + '\99' -> cAny + cIdent + cLower -- c + '\100' -> cAny + cIdent + cLower -- d + '\101' -> cAny + cIdent + cLower -- e + '\102' -> cAny + cIdent + cLower -- f + '\103' -> cAny + cIdent + cLower -- g + '\104' -> cAny + cIdent + cLower -- h + '\105' -> cAny + cIdent + cLower -- i + '\106' -> cAny + cIdent + cLower -- j + '\107' -> cAny + cIdent + cLower -- k + '\108' -> cAny + cIdent + cLower -- l + '\109' -> cAny + cIdent + cLower -- m + '\110' -> cAny + cIdent + cLower -- n + '\111' -> cAny + cIdent + cLower -- o + '\112' -> cAny + cIdent + cLower -- p + '\113' -> cAny + cIdent + cLower -- q + '\114' -> cAny + cIdent + cLower -- r + '\115' -> cAny + cIdent + cLower -- s + '\116' -> cAny + cIdent + cLower -- t + '\117' -> cAny + cIdent + cLower -- u + '\118' -> cAny + cIdent + cLower -- v + '\119' -> cAny + cIdent + cLower -- w + '\120' -> cAny + cIdent + cLower -- x + '\121' -> cAny + cIdent + cLower -- y + '\122' -> cAny + cIdent + cLower -- z + '\123' -> cAny -- { + '\124' -> cAny + cSymbol -- | + '\125' -> cAny -- } + '\126' -> cAny + cSymbol -- ~ + '\127' -> 0 -- \177 + _ -> panic ("charType: " ++ show c) diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs new file mode 100644 index 00000000..387cbf8f --- /dev/null +++ b/compiler/parser/HaddockUtils.hs @@ -0,0 +1,32 @@ + +module HaddockUtils where + +import HsSyn +import SrcLoc + +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- Adding documentation to record fields (used in parsing). + +addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a +addFieldDoc (L l fld) doc + = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) + +addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] +addFieldDocs [] _ = [] +addFieldDocs (x:xs) doc = addFieldDoc x doc : xs + + +addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a +addConDoc decl Nothing = decl +addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) + +addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocs [] _ = [] +addConDocs [x] doc = [addConDoc x doc] +addConDocs (x:xs) doc = x : addConDocs xs doc + +addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocFirst [] _ = [] +addConDocFirst (x:xs) doc = addConDoc x doc : xs diff --git a/compiler/parser/Lexer.hs b/compiler/parser/Lexer.hs new file mode 100644 index 00000000..07df86e0 --- /dev/null +++ b/compiler/parser/Lexer.hs @@ -0,0 +1,2674 @@ +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 43 "compiler/parser/Lexer.x" #-} + +-- XXX The above flags turn off warnings in the generated code: +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- But alex still generates some code that causes the "lazy unlifted bindings" +-- warning, and old compilers don't know about it so we can't easily turn +-- it off, so for now we use the sledge hammer: +{-# OPTIONS_GHC -w #-} + +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module Lexer ( + Token(..), lexer, pragState, mkPState, PState(..), + P(..), ParseResult(..), getSrcLoc, + getPState, getDynFlags, withThisPackage, + failLocMsgP, failSpanMsgP, srcParseFail, + getMessages, + popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + extension, bangPatEnabled, datatypeContextsEnabled, + traditionalRecordSyntaxEnabled, + explicitForallEnabled, + inRulePrag, + explicitNamespacesEnabled, + patternSynonymsEnabled, + sccProfilingOn, hpcEnabled, + addWarning, + lexTokenStream, + addAnnotation,AddAnn,mkParensApiAnn + ) where + +-- base +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Char +import Data.List +import Data.Maybe +import Data.Ratio +import Data.Word + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- data/typeable +import Data.Data +import Data.Typeable + +-- compiler/utils +import Bag +import Outputable +import StringBuffer +import FastString +import UniqFM +import Util ( readRational ) + +-- compiler/main +import ErrUtils +import DynFlags + +-- compiler/basicTypes +import SrcLoc +import Module +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), + SourceText ) + +-- compiler/parser +import Ctype + +import ApiAnnotation + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\x8d\x00\x00\x00\xa9\x00\x00\x00\xb2\x00\x00\x00\xb7\x00\x00\x00\xd5\x00\x00\x00\xef\x00\x00\x00\x07\x01\x00\x00\xfe\x00\x00\x00\x3c\x01\x00\x00\x7a\x01\x00\x00\xd4\xff\xff\xff\x54\x00\x00\x00\xd7\xff\xff\xff\xda\xff\xff\xff\xa3\xff\xff\xff\xa4\xff\xff\xff\xf7\x01\x00\x00\x71\x02\x00\x00\xeb\x02\x00\x00\x92\xff\xff\xff\x65\x03\x00\x00\x93\xff\xff\xff\xb0\xff\xff\xff\xe5\xff\xff\xff\xe6\xff\xff\xff\xab\xff\xff\xff\xa8\xff\xff\xff\xad\xff\xff\xff\xb1\xff\xff\xff\xb6\xff\xff\xff\xa7\xff\xff\xff\xdf\x03\x00\x00\x19\x04\x00\x00\x86\x03\x00\x00\xac\xff\xff\xff\xae\xff\xff\xff\x21\x01\x00\x00\x3b\x01\x00\x00\x58\x01\x00\x00\xda\x01\x00\x00\x78\x01\x00\x00\xe8\x01\x00\x00\x64\x04\x00\x00\x30\x01\x00\x00\xed\xff\xff\xff\x7b\x04\x00\x00\x62\x01\x00\x00\xef\xff\xff\xff\xa1\x04\x00\x00\xfb\x04\x00\x00\x79\x05\x00\x00\xf5\x05\x00\x00\x71\x06\x00\x00\xed\x06\x00\x00\x69\x07\x00\x00\xe5\x07\x00\x00\x61\x08\x00\x00\x85\x00\x00\x00\xdd\x08\x00\x00\x5b\x09\x00\x00\x11\x00\x00\x00\x78\x00\x00\x00\xf9\x00\x00\x00\x24\x01\x00\x00\x7a\x00\x00\x00\x81\x00\x00\x00\x73\x02\x00\x00\xed\x02\x00\x00\x69\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x92\x00\x00\x00\x93\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x00\x00\x98\x00\x00\x00\xd6\x09\x00\x00\xfe\x09\x00\x00\x41\x0a\x00\x00\x69\x0a\x00\x00\xac\x0a\x00\x00\xd4\x0a\x00\x00\x17\x0b\x00\x00\x78\x05\x00\x00\xf4\x05\x00\x00\x70\x06\x00\x00\xec\x06\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x0b\x00\x00\xd1\x0b\x00\x00\x4b\x0c\x00\x00\xc5\x0c\x00\x00\x4f\x02\x00\x00\x3f\x0d\x00\x00\xa0\x00\x00\x00\xa1\x00\x00\x00\xbd\x0d\x00\x00\x9c\x00\x00\x00\xc9\x02\x00\x00\x37\x0e\x00\x00\x00\x00\x00\x00\xb5\x0e\x00\x00\x00\x00\x00\x00\x2f\x0f\x00\x00\xa9\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x10\x00\x00\x9d\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\xed\x11\x00\x00\x67\x12\x00\x00\xe1\x12\x00\x00\x5b\x13\x00\x00\xd5\x13\x00\x00\x4f\x14\x00\x00\xc9\x14\x00\x00\x43\x15\x00\x00\xa2\x00\x00\x00\xa7\x00\x00\x00\xa8\x00\x00\x00\xac\x00\x00\x00\x9d\x15\x00\x00\xc0\x15\x00\x00\x1c\x16\x00\x00\x3f\x16\x00\x00\x62\x16\x00\x00\x8a\x16\x00\x00\xcd\x16\x00\x00\xf0\x16\x00\x00\x15\x17\x00\x00\x8e\x17\x00\x00\x07\x18\x00\x00\x63\x18\x00\x00\x88\x18\x00\x00\x5b\x03\x00\x00\x9b\x18\x00\x00\xb5\x00\x00\x00\x9f\x04\x00\x00\x53\x05\x00\x00\xb8\x09\x00\x00\xe4\x18\x00\x00\xdd\x00\x00\x00\xd6\x05\x00\x00\xd1\x15\x00\x00\x2c\x0b\x00\x00\x52\x06\x00\x00\x4d\x0b\x00\x00\xce\x06\x00\x00\xad\x00\x00\x00\xb0\x00\x00\x00\xb1\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x47\x00\xa2\x00\xa0\x00\x52\x00\xaf\x00\x41\x00\x53\x00\x5e\x00\x63\x00\x43\x00\x66\x00\x41\x00\x41\x00\x41\x00\x73\x00\x75\x00\x40\x00\x16\x00\x18\x00\x26\x00\x19\x00\x25\x00\x1f\x00\x1d\x00\x20\x00\x12\x00\x60\x00\x11\x00\xbc\x00\xbc\x00\xb7\x00\xb7\x00\x41\x00\xaf\x00\xd2\x00\xae\x00\xb2\x00\xaf\x00\xaf\x00\xd1\x00\x91\x00\x92\x00\xaf\x00\xaf\x00\x96\x00\xaa\x00\xaf\x00\xaf\x00\xb6\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb3\x00\x97\x00\xaf\x00\xaf\x00\xaf\x00\xb0\x00\xaf\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\x94\x00\xaf\x00\x95\x00\xaf\x00\xa0\x00\x98\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x9a\x00\xac\x00\x9b\x00\xaf\x00\x41\x00\x53\x00\x5f\x00\x43\x00\x43\x00\x5c\x00\x41\x00\x41\x00\x41\x00\x41\x00\x44\x00\xff\xff\x13\x00\x43\x00\x62\x00\x41\x00\x41\x00\x41\x00\x41\x00\xff\xff\xff\xff\xff\xff\x43\x00\x62\x00\x41\x00\x41\x00\x41\x00\x41\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\x41\x00\x1e\x00\xff\xff\x64\x00\x10\x00\x78\x00\xff\xff\xff\xff\x6f\x00\x41\x00\x41\x00\x78\x00\x64\x00\x10\x00\x43\x00\x62\x00\x41\x00\x41\x00\x41\x00\x41\x00\x7c\x00\x7e\x00\x10\x00\x43\x00\x41\x00\x41\x00\x41\x00\x41\x00\x43\x00\x8e\x00\x41\x00\x41\x00\x41\x00\xa4\x00\x3f\x00\x45\x00\x46\x00\x41\x00\xa5\x00\xa6\x00\x64\x00\x48\x00\x55\x00\xa7\x00\xcb\x00\x73\x00\x41\x00\xcc\x00\xcd\x00\x00\x00\x10\x00\x41\x00\xc4\x00\xce\x00\x41\x00\xd0\x00\x00\x00\x00\x00\x43\x00\x10\x00\x41\x00\x41\x00\x41\x00\x78\x00\x10\x00\xb7\x00\xb7\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x42\x00\x41\x00\x0d\x00\x3e\x00\x44\x00\xff\xff\x42\x00\x42\x00\x42\x00\x00\x00\x41\x00\x61\x00\xc8\x00\x78\x00\x10\x00\x41\x00\x41\x00\x41\x00\x41\x00\x43\x00\x61\x00\x41\x00\x41\x00\x41\x00\x41\x00\xbc\x00\xbc\x00\x42\x00\x43\x00\x1c\x00\x41\x00\x41\x00\x41\x00\x21\x00\x00\x00\x00\x00\x00\x00\x41\x00\x8b\x00\x00\x00\x6e\x00\x00\x00\x41\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x61\x00\x65\x00\x00\x00\x41\x00\x00\x00\x42\x00\x00\x00\x10\x00\x00\x00\x0d\x00\xff\xff\x42\x00\x42\x00\x42\x00\x0d\x00\x00\x00\x10\x00\x00\x00\x00\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x41\x00\x00\x00\x00\x00\x42\x00\x43\x00\x00\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x28\x00\x00\x00\x28\x00\x00\x00\x0d\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x41\x00\x00\x00\x00\x00\x1a\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x0e\x00\x6d\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xa3\x00\xa1\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x0d\x00\x43\x00\x66\x00\x41\x00\x41\x00\x41\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x41\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x92\x00\x00\x00\x00\x00\x96\x00\x0f\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x93\x00\x00\x00\x95\x00\x00\x00\xa1\x00\x98\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x99\x00\x00\x00\x9b\x00\x67\x00\x67\x00\x67\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x2b\x00\x00\x00\x2b\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x13\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x69\x00\x69\x00\x69\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x76\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x78\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x6a\x00\x6a\x00\x6a\x00\x78\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x78\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x74\x00\x74\x00\x74\x00\x78\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x37\x00\x2c\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x37\x00\x22\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x22\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x9d\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xc5\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9e\x00\x9c\x00\x00\x00\xa8\x00\x9d\x00\x00\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\xc6\x00\xa8\x00\x00\x00\xa8\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\xff\xff\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x4b\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x4b\x00\x8a\x00\x36\x00\x36\x00\x36\x00\xc9\x00\x00\x00\x00\x00\x36\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x4f\x00\x89\x00\x37\x00\x37\x00\x37\x00\xcf\x00\x00\x00\x00\x00\x37\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x37\x00\x00\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x4f\x00\x88\x00\x36\x00\x36\x00\x36\x00\xcf\x00\x00\x00\x00\x00\x36\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x4c\x00\x81\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x80\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x7f\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x7d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x72\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x6c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\xff\xff\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x59\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x51\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x70\x00\x51\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x00\x00\x54\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x70\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\xaf\x00\x54\x00\x70\x00\x70\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\x56\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\x56\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x67\x00\x67\x00\x67\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x2a\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x2a\x00\x27\x00\xaf\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x27\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x69\x00\x69\x00\x69\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x6c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x68\x00\x68\x00\x68\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x72\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x74\x00\x74\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x69\x00\x69\x00\x69\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x22\x00\x36\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x36\x00\x36\x00\x36\x00\x39\x00\x3b\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x3a\x00\x36\x00\x36\x00\x36\x00\x38\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x00\x00\x7b\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9d\x00\x9d\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9d\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa2\x00\xa2\x00\xa2\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa3\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa9\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa9\x00\xa8\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\xa9\x00\x00\x00\xa9\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xaf\x00\xa9\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\x57\x00\xaf\x00\xaf\x00\xbb\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x8c\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\x75\x00\xaf\x00\xaf\x00\x82\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x83\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x8f\x00\xaf\x00\xaf\x00\x00\x00\xab\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x8d\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x85\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x87\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x85\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x84\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xb1\x00\xaf\x00\xaf\x00\x00\x00\x86\x00\x00\x00\xaf\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\x84\x00\xb4\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\xaf\x00\xb4\x00\xaf\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xb4\x00\x7a\x00\xb4\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x2c\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\xb4\x00\x2a\x00\xb4\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\xc7\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x30\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x2d\x00\x01\x00\x02\x00\x2d\x00\x04\x00\x05\x00\x2d\x00\x65\x00\x65\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x7d\x00\x61\x00\x2d\x00\x2d\x00\x69\x00\x6d\x00\x69\x00\x61\x00\x67\x00\x72\x00\x6e\x00\x0a\x00\x6e\x00\x30\x00\x31\x00\x30\x00\x31\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x2d\x00\x0a\x00\x09\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x09\x00\x0a\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x20\x00\x6c\x00\x0a\x00\x23\x00\x2d\x00\x24\x00\x0a\x00\x0a\x00\x23\x00\x20\x00\x05\x00\x2a\x00\x23\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x7c\x00\x7c\x00\x2d\x00\x09\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x23\x00\x21\x00\x2d\x00\x2d\x00\x20\x00\x23\x00\x23\x00\x23\x00\x2d\x00\x2d\x00\x23\x00\x23\x00\x7d\x00\x20\x00\x23\x00\x23\x00\xff\xff\x2d\x00\x20\x00\x23\x00\x23\x00\x05\x00\x23\x00\xff\xff\xff\xff\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x5e\x00\x2d\x00\x30\x00\x31\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\x7b\x00\x22\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\x7b\x00\x23\x00\x7c\x00\x2d\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x30\x00\x31\x00\x20\x00\x09\x00\x6c\x00\x0b\x00\x0c\x00\x0d\x00\x70\x00\xff\xff\xff\xff\xff\xff\x20\x00\x7c\x00\xff\xff\x2d\x00\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\xff\xff\x20\x00\xff\xff\x05\x00\xff\xff\x2d\x00\xff\xff\x7b\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x05\x00\xff\xff\xff\xff\x20\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x2d\x00\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\x7b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x02\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x5f\x00\x07\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x23\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x04\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x45\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x45\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x65\x00\x45\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x5c\x00\x5d\x00\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\x7c\x00\x45\x00\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\x70\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x70\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4b\x00\x4e\x00\x4b\x00\x50\x00\x50\x00\x4a\x00\x4a\x00\x50\x00\x4a\x00\x50\x00\x4a\x00\x49\x00\x49\x00\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x70\x00\x70\x00\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,210) [AlexAccNone,AlexAcc (alex_action_13),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_18),AlexAcc (alex_action_21),AlexAccNone,AlexAccNone,AlexAcc (alex_action_26),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_1),AlexAcc (alex_action_1),AlexAccPred (alex_action_2) ( isNormalComment )(AlexAccNone),AlexAccPred (alex_action_2) ( isNormalComment )(AlexAccNone),AlexAccPred (alex_action_2) ( isNormalComment )(AlexAccNone),AlexAccPred (alex_action_2) ( isNormalComment )(AlexAcc (alex_action_26)),AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )(AlexAccNone),AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )(AlexAcc (alex_action_26)),AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )(AlexAcc (alex_action_35)),AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )(AlexAcc (alex_action_37)),AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )(AlexAccPred (alex_action_39) ( ifExtension haddockEnabled )(AlexAccNone)),AlexAcc (alex_action_6),AlexAccPred (alex_action_7) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_7) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_7) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_7) ( atEOL )(AlexAcc (alex_action_26)),AlexAccPred (alex_action_7) ( atEOL )(AlexAcc (alex_action_26)),AlexAccPred (alex_action_7) ( atEOL )(AlexAcc (alex_action_83)),AlexAccPred (alex_action_7) ( atEOL )(AlexAcc (alex_action_83)),AlexAccPred (alex_action_8) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_8) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_8) ( atEOL )(AlexAccNone),AlexAccPred (alex_action_8) ( atEOL )(AlexAcc (alex_action_26)),AlexAccSkip,AlexAccPred (alex_action_10) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_10) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_14) ( notFollowedBy '-' )(AlexAccNone),AlexAccSkip,AlexAccPred (alex_action_16) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_16) (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone),AlexAccPred (alex_action_17) ( notFollowedBySymbol )(AlexAccNone),AlexAcc (alex_action_22),AlexAccPred (alex_action_23) ( known_pragma linePrags )(AlexAccNone),AlexAccPred (alex_action_23) ( known_pragma linePrags )(AlexAcc (alex_action_26)),AlexAccPred (alex_action_23) ( known_pragma linePrags )(AlexAccPred (alex_action_31) ( known_pragma oneWordPrags )(AlexAccPred (alex_action_32) ( known_pragma ignoredPrags )(AlexAccPred (alex_action_34) ( known_pragma fileHeaderPrags )(AlexAccNone)))),AlexAccPred (alex_action_23) ( known_pragma linePrags )(AlexAccPred (alex_action_31) ( known_pragma oneWordPrags )(AlexAccPred (alex_action_32) ( known_pragma ignoredPrags )(AlexAccPred (alex_action_36) ( known_pragma fileHeaderPrags )(AlexAccNone)))),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_26),AlexAcc (alex_action_26),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAccPred (alex_action_30) ( known_pragma twoWordPrags )(AlexAccNone),AlexAcc (alex_action_33),AlexAcc (alex_action_38),AlexAcc (alex_action_38),AlexAccPred (alex_action_40) ( ifExtension haddockEnabled )(AlexAccNone),AlexAccPred (alex_action_41) ( ifExtension parrEnabled )(AlexAccNone),AlexAccPred (alex_action_42) ( ifExtension parrEnabled )(AlexAccNone),AlexAccPred (alex_action_43) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_44) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_45) ( ifExtension thEnabled )(AlexAccPred (alex_action_57) ( ifExtension qqEnabled )(AlexAccNone)),AlexAccPred (alex_action_46) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_47) ( ifExtension thEnabled )(AlexAccPred (alex_action_57) ( ifExtension qqEnabled )(AlexAccNone)),AlexAccPred (alex_action_48) ( ifExtension thEnabled )(AlexAccPred (alex_action_57) ( ifExtension qqEnabled )(AlexAccNone)),AlexAccPred (alex_action_49) ( ifExtension thEnabled )(AlexAccPred (alex_action_57) ( ifExtension qqEnabled )(AlexAccNone)),AlexAccPred (alex_action_50) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_51) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_52) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_53) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_54) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_55) ( ifExtension thEnabled )(AlexAccNone),AlexAccPred (alex_action_56) ( ifExtension qqEnabled )(AlexAccNone),AlexAccPred (alex_action_57) ( ifExtension qqEnabled )(AlexAccNone),AlexAccPred (alex_action_58) ( ifExtension qqEnabled )(AlexAccNone),AlexAccPred (alex_action_59) ( ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol )(AlexAccNone),AlexAccPred (alex_action_60) ( ifExtension arrowsEnabled )(AlexAccNone),AlexAccPred (alex_action_61) ( ifExtension ipEnabled )(AlexAccNone),AlexAccPred (alex_action_62) ( ifExtension unboxedTuplesEnabled )(AlexAccNone),AlexAccPred (alex_action_63) ( ifExtension unboxedTuplesEnabled )(AlexAccNone),AlexAcc (alex_action_64),AlexAcc (alex_action_64),AlexAcc (alex_action_65),AlexAcc (alex_action_66),AlexAcc (alex_action_66),AlexAcc (alex_action_67),AlexAcc (alex_action_68),AlexAcc (alex_action_69),AlexAcc (alex_action_70),AlexAcc (alex_action_71),AlexAcc (alex_action_71),AlexAcc (alex_action_72),AlexAcc (alex_action_73),AlexAcc (alex_action_73),AlexAcc (alex_action_74),AlexAcc (alex_action_74),AlexAcc (alex_action_75),AlexAcc (alex_action_75),AlexAcc (alex_action_76),AlexAcc (alex_action_76),AlexAccPred (alex_action_77) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_78) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_79) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_80) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAcc (alex_action_81),AlexAcc (alex_action_82),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_83),AlexAcc (alex_action_84),AlexAcc (alex_action_84),AlexAcc (alex_action_85),AlexAcc (alex_action_85),AlexAccPred (alex_action_86) ( ifExtension binaryLiteralsEnabled )(AlexAccNone),AlexAcc (alex_action_87),AlexAcc (alex_action_88),AlexAccPred (alex_action_89) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_89) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_90) ( ifExtension negativeLiteralsEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_91) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_92) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAcc (alex_action_93),AlexAcc (alex_action_93),AlexAccPred (alex_action_94) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_94) ( ifExtension negativeLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_95) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_96) ( ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_97) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_98) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_99) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_100) ( ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_101) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_102) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_103) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_104) ( ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled )(AlexAccNone),AlexAccPred (alex_action_105) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_106) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_107) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAccPred (alex_action_108) ( ifExtension magicHashEnabled )(AlexAccNone),AlexAcc (alex_action_109),AlexAcc (alex_action_110)] +{-# LINE 512 "compiler/parser/Lexer.x" #-} + + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + + -- Pragmas, see note [Pragma source text] in BasicTypes + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITcore_prag SourceText -- hdaume: core annotations + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITvect_prag SourceText + | ITvect_scalar_prag SourceText + | ITnovect_prag SourceText + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon + | ITequal + | ITlam + | ITlcase + | ITvbar + | ITlarrow + | ITrarrow + | ITat + | ITtilde + | ITtildehsh + | ITdarrow + | ITminus + | ITbang + | ITstar + | ITdot + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + | ITprefixqvarsym (FastString,FastString) + | ITprefixqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + + | ITchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes + | ITinteger SourceText Integer -- Note [Literal source text] in BasicTypes + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes + | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITopenTExpQuote -- [|| + | ITcloseTExpQuote -- ||] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITidTyEscape FastString -- $$x + | ITparenTyEscape -- $$( + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- + + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token + + -- Documentation annotations + | ITdocCommentNext String -- something beginning '-- |' + | ITdocCommentPrev String -- something beginning '-- ^' + | ITdocCommentNamed String -- something beginning '-- $' + | ITdocSection Int String -- a section heading + | ITdocOptions String -- doc options (prune, ignore-exports, etc) + | ITdocOptionsOld String -- doc options declared "-- # ..."-style + | ITlineComment String -- comment starting by "--" + | ITblockComment String -- comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall, xbit ExplicitForallBit .|. + xbit InRulePragBit), + ( "mdo", ITmdo, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) +reservedSymsFM = listToUFM $ + map (\ (x,y,z) -> (mkFastString x,(y,z))) + [ ("..", ITdotdot, always) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, always) + ,("::", ITdcolon, always) + ,("=", ITequal, always) + ,("\\", ITlam, always) + ,("|", ITvbar, always) + ,("<-", ITlarrow, always) + ,("->", ITrarrow, always) + ,("@", ITat, always) + ,("~", ITtilde, always) + ,("~#", ITtildehsh, magicHashEnabled) + ,("=>", ITdarrow, always) + ,("-", ITminus, always) + ,("!", ITbang, always) + + -- For data T (a::*) = MkT + ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i) + -- For 'forall a . t' + ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) + + ,("-<", ITlarrowtail, arrowsEnabled) + ,(">-", ITrarrowtail, arrowsEnabled) + ,("-<<", ITLarrowtail, arrowsEnabled) + ,(">>-", ITRarrowtail, arrowsEnabled) + + ,("∷", ITdcolon, unicodeSyntaxEnabled) + ,("⇒", ITdarrow, unicodeSyntaxEnabled) + ,("∀", ITforall, unicodeSyntaxEnabled) + ,("→", ITrarrow, unicodeSyntaxEnabled) + ,("←", ITlarrow, unicodeSyntaxEnabled) + + ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + + ,("★", ITstar, unicodeSyntaxEnabled) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) + +special :: Token -> Action +special tok span _buf _len = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len = return (L span t) +layout_token t span _buf _len = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len = return (L span $! (f buf len)) + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +init_strtoken :: Int -> (String -> Token) -> Action +-- like strtoken, but drops the last N character(s) +init_strtoken drop f span buf len = + return (L span $! (f $! lexemeToString buf (len-drop))) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- extension relaxedLayout + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else failSpanMsgP (RealSrcSpan span) (text "Missing block") + +pop_and :: Action -> Action +pop_and act span buf len = do _ <- popLexState + act span buf len + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | haddockEnabled bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap +ifExtension pred bits _ _ _ = pred bits + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len = withLexedDocType (worker "") + where + worker commentAcc input docType oneLine = case alexGetChar' input of + Just ('\n', input') + | oneLine -> docCommentEnd input commentAcc docType buf span + | otherwise -> case checkIfCommentLine input' of + Just input -> worker ('\n':commentAcc) input docType False + Nothing -> docCommentEnd input commentAcc docType buf span + Just (c, input) -> worker (c:commentAcc) input docType oneLine + Nothing -> docCommentEnd input commentAcc docType buf span + + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = case alexGetChar' input of + Just ('-', input) -> case alexGetChar' input of + Just ('-', input) -> case alexGetChar' input of + Just (c, _) | c /= '-' -> Just input + _ -> Nothing + _ -> Nothing + _ -> Nothing + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len = do + b <- extension rawTokenStreamEnabled + if b then strtoken ITlineComment span buf len else lexToken + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: P (RealLocated Token) -> Action +nested_comment cont span buf len = do + input <- getInput + go (reverse $ lexemeToString buf len) (1::Int) input + where + go commentAcc 0 input = do + setInput input + b <- extension rawTokenStreamEnabled + if b + then docCommentEnd input commentAcc ITblockComment buf span + else cont + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input span + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +nested_doc_comment :: Action +nested_doc_comment span buf _len = withLexedDocType (go "") + where + go commentAcc input docType _ = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> + docCommentEnd input commentAcc docType buf span + Just (_,_) -> go ('-':commentAcc) input docType False + Just ('\123', input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> do + setInput input + let cont = do input <- getInput; go commentAcc input docType False + nested_comment cont span buf _len + Just (_,_) -> go ('\123':commentAcc) input docType False + Just (c,input) -> go (c:commentAcc) input docType False + +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + case prevChar buf ' ' of + '|' -> lexDocComment input ITdocCommentNext False + '^' -> lexDocComment input ITdocCommentPrev False + '$' -> lexDocComment input ITdocCommentNamed False + '*' -> lexDocSection 1 input + '#' -> lexDocComment input ITdocOptionsOld False + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection (n+1) input + Just (_, _) -> lexDocComment input (ITdocSection n) True + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToString buf len + return (L span (ITrules_prag src)) + +endPrag :: Action +endPrag span _buf _len = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> + RealSrcSpan -> P (RealLocated Token) +docCommentEnd input commentAcc docType buf span = do + setInput input + let (AI loc nextBuf) = input + comment = reverse commentAcc + span' = mkRealSrcSpan (realSrcSpanStart span) loc + last_len = byteDiff buf nextBuf + + span `seq` setLastToken span' last_len + return (L span' (docType comment)) + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" + +open_brace, close_brace :: Action +open_brace span _str _len = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lambdaCase <- extension lambdaCaseEnabled + keyword <- if lambdaCase + then do + lastTk <- getLastTk + return $ case lastTk of + Just ITlam -> ITlcase + _ -> ITcase + else + return ITcase + maybe_layout keyword + return $ L span keyword + Just (ITstatic, _) -> do + flags <- getDynFlags + if xopt Opt_StaticPointers flags + then return $ L span ITstatic + else return $ L span $ ITvarid fs + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, exts) -> do + extsEnabled <- extension $ \i -> exts .&. i /= 0 + if extsEnabled + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False +prefixqvarsym buf len = ITprefixqvarsym $! splitQualName buf len True +prefixqconsym buf len = ITprefixqconsym $! splitQualName buf len True + +varsym, consym :: Action +varsym = sym ITvarsym +consym = sym ITconsym + +sym :: (FastString -> Token) -> Action +sym con span buf len = + case lookupUFM reservedSymsFM fs of + Just (keyword, exts) -> do + extsEnabled <- extension exts + let !tk | extsEnabled = keyword + | otherwise = con fs + return $ L span tk + Nothing -> + return $ L span $! con fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral :: (String -> Integer -> Token) + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint (lexemeToString buf len) + $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + +-- some conveniences for use with tok_integral +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral ITinteger +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive +positive, negative :: (Integer -> Integer) +positive = id +negative = negate +decimal, octal, hexadecimal :: (Integer, Char -> Int) +decimal = (10,octDecDigit) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readRational can understand negative rationals, exponents, everything. +tok_float, tok_primfloat, tok_primdouble :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len = do + pos <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- extension alternativeLayoutRule + unless alr $ f t + where f ITdo = pushLexState layout_do + f ITmdo = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +-- +new_layout_context :: Bool -> Token -> Action +new_layout_context strict tok span _buf len = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol l - len + ctx <- getContext + nondecreasing <- extension nondecreasingIndentation + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do + setContext (Layout offset : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLine :: Int -> Action +setLine code span buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + _ <- popLexState + pushLexState code + lexToken + +setFile :: Int -> Action +setFile code span buf len = do + let file = mkFastString (go (lexemeToString (stepOn buf) (len-2))) + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok span _buf _len + = do input <- getInput + start <- getSrcLoc + tok <- go [] input + end <- getSrcLoc + return (L (mkRealSrcSpan start end) tok) + where go acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc)) + else case alexGetChar input of + Just (c,i) -> go (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" + + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +-- This stuff is horrible. I hates it. + +lex_string_tok :: Action +lex_string_tok span buf _len = do + tok <- lex_string "" + end <- getSrcLoc + (AI end bufEnd) <- getInput + let + tok' = case tok of + ITprimstring _ bs -> ITprimstring src bs + ITstring _ s -> ITstring src s + src = lexemeToString buf (cur bufEnd - cur buf) + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') + +lex_string :: String -> P Token +lex_string s = do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i + + Just ('"',i) -> do + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s + then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" + else let bs = unsafeMkByteString (reverse s) + in return (ITprimstring "" bs) + _other -> + return (ITstring "" (mkFastString (reverse s))) + else + return (ITstring "" (mkFastString (reverse s))) + + Just ('\\',i) + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751, #5425) + setInput i; lex_stringgap s + where next = alexGetChar' i + + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i + +lex_stringgap :: String -> P Token +lex_stringgap s = do + i <- getInput + c <- getCharOrFail i + case c of + '\\' -> lex_string s + c | c <= '\x7f' && is_space c -> lex_stringgap s + -- is_space only works for <= '\x7f' (#3751, #5425) + _other -> lit_error i + + +lex_char_tok :: Action +-- Here we are basically parsing character literals, such as 'x' or '\n' +-- but, when Template Haskell is on, we additionally spot +-- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively, +-- but WITHOUT CONSUMING the x or T part (the parser does that). +-- So we have to do two characters of lookahead: when we see 'x we need to +-- see if there's a trailing quote +lex_char_tok span buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = realSrcSpanStart span + case alexGetChar' i1 of + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok buf loc lit_ch + else lit_error i3 + + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok buf loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + let (AI end _) = i1 + return (L (mkRealSrcSpan loc end) ITsimpleQuote) + +finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok buf loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end bufEnd) <- getInput + let src = lexemeToString buf (cur bufEnd - cur buf) + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar src ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar src ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar src ch)) + +isAny :: Char -> Bool +isAny c | c > '\x7f' = isPrint c + | otherwise = is_any c + +lex_escape :: P Char +lex_escape = do + i0 <- getInput + c <- getCharOrFail i0 + case c of + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput + c <- getCharOrFail i1 + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + 'b' -> readNum is_bindigit 2 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> + case alexGetChar' i2 of + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 + +readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char +readNum is_digit base conv = do + i <- getInput + c <- getCharOrFail i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i + +readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char +readNum2 is_digit base conv i = do + input <- getInput + read i input + where read i input = do + case alexGetChar' input of + Just (c,input') | is_digit c -> do + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' + _other -> do + setInput input; return (chr i) + + +silly_escape_chars :: [(String, Char)] +silly_escape_chars = [ + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] + +-- before calling lit_error, ensure that the current input is pointing to +-- the position of the error in the buffer. This is so that we can report +-- a correct location to the user, but also so we can detect UTF-8 decoding +-- errors if they occur. +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" + +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do + case alexGetChar' i of + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on Trac #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start end buf "unterminated quasiquotation" + +-- ----------------------------------------------------------------------------- +-- Warnings + +warn :: WarningFlag -> SDoc -> Action +warn option warning srcspan _buf _len = do + addWarning option (RealSrcSpan srcspan) warning + lexToken + +warnThen :: WarningFlag -> SDoc -> Action -> Action +warnThen option warning action srcspan buf len = do + addWarning option (RealSrcSpan srcspan) warning + action srcspan buf len + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +data LayoutContext + = NoLayout + | Layout !Int + deriving Show + +data ParseResult a + = POk PState a + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + MsgDoc -- The error message + +data PState = PState { + buffer :: StringBuffer, + dflags :: DynFlags, + messages :: Messages, + last_tk :: Maybe Token, + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !ExtsBitmap, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [RealLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (RealLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: RealSrcSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See note [Api annotations] in ApiAnnotation.hs + annotations :: [(ApiAnnKey,[SrcSpan])], + comment_q :: [Located AnnotationComment], + annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = return + (<*>) = ap + +instance Monad P where + return = returnP + (>>=) = thenP + fail = failP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err + +failP :: String -> P a +failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) + +failMsgP :: String -> P a +failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) + +failSpanMsgP :: SrcSpan -> SDoc -> P a +failSpanMsgP span msg = P $ \_ -> PFailed span msg + +getPState :: P PState +getPState = P $ \s -> POk s s + +instance HasDynFlags P where + getDynFlags = P $ \s -> POk s (dflags s) + +withThisPackage :: (PackageKey -> a) -> P a +withThisPackage f + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg + +extension :: (ExtsBitmap -> Bool) -> P Bool +extension p = P $ \s -> POk s (p $! extsBitmap s) + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (extsBitmap s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () + +getSrcLoc :: P RealSrcLoc +getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setLastToken :: RealSrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: Token -> P () +setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () + +getLastTk :: P (Maybe Token) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +data AlexInput = AI RealSrcLoc StringBuffer + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + byte = fromIntegral $ ord adj_c + + non_graphic = '\x00' + upper = '\x01' + lower = '\x02' + digit = '\x03' + symbol = '\x04' + space = '\x05' + other_graphic = '\x06' + suffix = '\x07' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in basicTypes/Lexeme.hs + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> suffix -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic + +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (RealLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P RealSrcSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: RealLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [RealLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- for reasons of efficiency, flags indicating language extensions (eg, +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Word64 +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +data ExtBits + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ParrBit + | ArrowsBit + | ThBit + | IpBit + | ExplicitForallBit -- the 'forall' keyword and '.' symbol + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | KindSigsBit -- Kind signatures on type variables + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | DatatypeContextsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | InRulePragBit + | RawTokenStreamBit -- producing a token stream with all comments included + | SccProfilingOnBit + | HpcBit + | AlternativeLayoutRuleBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + deriving Enum + + +always :: ExtsBitmap -> Bool +always _ = True +parrEnabled :: ExtsBitmap -> Bool +parrEnabled = xtest ParrBit +arrowsEnabled :: ExtsBitmap -> Bool +arrowsEnabled = xtest ArrowsBit +thEnabled :: ExtsBitmap -> Bool +thEnabled = xtest ThBit +ipEnabled :: ExtsBitmap -> Bool +ipEnabled = xtest IpBit +explicitForallEnabled :: ExtsBitmap -> Bool +explicitForallEnabled = xtest ExplicitForallBit +bangPatEnabled :: ExtsBitmap -> Bool +bangPatEnabled = xtest BangPatBit +haddockEnabled :: ExtsBitmap -> Bool +haddockEnabled = xtest HaddockBit +magicHashEnabled :: ExtsBitmap -> Bool +magicHashEnabled = xtest MagicHashBit +-- kindSigsEnabled :: ExtsBitmap -> Bool +-- kindSigsEnabled = xtest KindSigsBit +unicodeSyntaxEnabled :: ExtsBitmap -> Bool +unicodeSyntaxEnabled = xtest UnicodeSyntaxBit +unboxedTuplesEnabled :: ExtsBitmap -> Bool +unboxedTuplesEnabled = xtest UnboxedTuplesBit +datatypeContextsEnabled :: ExtsBitmap -> Bool +datatypeContextsEnabled = xtest DatatypeContextsBit +qqEnabled :: ExtsBitmap -> Bool +qqEnabled = xtest QqBit +inRulePrag :: ExtsBitmap -> Bool +inRulePrag = xtest InRulePragBit +rawTokenStreamEnabled :: ExtsBitmap -> Bool +rawTokenStreamEnabled = xtest RawTokenStreamBit +alternativeLayoutRule :: ExtsBitmap -> Bool +alternativeLayoutRule = xtest AlternativeLayoutRuleBit +hpcEnabled :: ExtsBitmap -> Bool +hpcEnabled = xtest HpcBit +relaxedLayout :: ExtsBitmap -> Bool +relaxedLayout = xtest RelaxedLayoutBit +nondecreasingIndentation :: ExtsBitmap -> Bool +nondecreasingIndentation = xtest NondecreasingIndentationBit +sccProfilingOn :: ExtsBitmap -> Bool +sccProfilingOn = xtest SccProfilingOnBit +traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool +traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit + +explicitNamespacesEnabled :: ExtsBitmap -> Bool +explicitNamespacesEnabled = xtest ExplicitNamespacesBit +lambdaCaseEnabled :: ExtsBitmap -> Bool +lambdaCaseEnabled = xtest LambdaCaseBit +binaryLiteralsEnabled :: ExtsBitmap -> Bool +binaryLiteralsEnabled = xtest BinaryLiteralsBit +negativeLiteralsEnabled :: ExtsBitmap -> Bool +negativeLiteralsEnabled = xtest NegativeLiteralsBit +patternSynonymsEnabled :: ExtsBitmap -> Bool +patternSynonymsEnabled = xtest PatternSynonymsBit + +-- PState for parsing options pragmas +-- +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } + +-- create a parse state +-- +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +mkPState flags buf loc = + PState { + buffer = buf, + dflags = flags, + messages = emptyMessages, + last_tk = Nothing, + last_loc = mkRealSrcSpan loc loc, + last_len = 0, + loc = loc, + extsBitmap = bitmap, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = alrInitialLoc (fsLit ""), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + annotations = [], + comment_q = [], + annotations_comments = [] + } + where + bitmap = FfiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. InterruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. CApiFfiBit `setBitIf` xopt Opt_CApiFFI flags + .|. ParrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. ArrowsBit `setBitIf` xopt Opt_Arrows flags + .|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. IpBit `setBitIf` xopt Opt_ImplicitParams flags + .|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. HaddockBit `setBitIf` gopt Opt_Haddock flags + .|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. DatatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags + .|. HpcBit `setBitIf` gopt Opt_Hpc flags + .|. AlternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. RelaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags + .|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. SafeHaskellBit `setBitIf` safeImportsOn flags + .|. TraditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. ExplicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags + .|. LambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. BinaryLiteralsBit `setBitIf` xopt Opt_BinaryLiterals flags + .|. NegativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags + .|. PatternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags + -- + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () +addWarning option srcspan warning + = P $ \s@PState{messages=(ws,es), dflags=d} -> + let warning' = mkWarnMsg d srcspan alwaysQualify warning + ws' = if wopt option d then ws `snocBag` warning' else ws + in POk s{messages=(ws', es)} () + +getMessages :: PState -> Messages +getMessages PState{messages=ms} = ms + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, dflags = flags, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len) + +-- Push a new layout context at the indentation of the last token read. +-- This is only used at the outer level of a module when the 'module' +-- keyword is missing. +pushCurrentContext :: P () +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) : ctx} () + +getOffside :: P Ordering +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol loc in + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + compare offs n + _ -> GT + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: DynFlags + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> MsgDoc +srcParseErr dflags buf len + = if null token + then ptext (sLit "parse error (possibly incorrect indentation or mismatched brackets)") + else ptext (sLit "parse error on input") <+> quotes (text token) + $$ ppWhen (not th_enabled && token == "$") -- #7396 + (text "Perhaps you intended to use TemplateHaskell") + $$ ppWhen (token == "<-") + (text "Perhaps this statement should be within a 'do' block?") + where token = lexemeToString (offsetBytes (-len) buf) len + th_enabled = xopt Opt_TemplateHaskell dflags + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \PState{ buffer = buf, dflags = flags, last_len = len, + last_loc = last_loc } -> + PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len) + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: String -> P a +lexError str = do + loc <- getSrcLoc + (AI end buf) <- getInput + reportLexError loc end buf str + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer :: Bool -> (Located Token -> P a) -> P a +lexer queueComments cont = do + alr <- extension alternativeLayoutRule + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + case tok of + ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) + _ -> return () + + if (queueComments && isDocComment tok) + then queueComment (L (RealSrcSpan span) tok) + else return () + + if (queueComments && isComment tok) + then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont + else cont (L (RealSrcSpan span) tok) + +lexTokenAlr :: P (RealLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + dflags <- getDynFlags + let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags + thisLoc = getLoc t + thisCol = srcSpanStartCol thisLoc + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIntentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITccurly] + setNextToken t + return (L lastLoc ITocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + return (L thisLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen ITparenEscape = True +isALRopen ITparenTyEscape = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIntentation :: ALRLayout -> Bool +isNonDecreasingIntentation ALRLayoutDo = True +isNonDecreasingIntentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +lexToken :: P (RealLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkRealSrcSpan loc1 loc1 + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError loc1 loc2 buf "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkRealSrcSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes + case unLoc lt of + ITlineComment _ -> return lt + ITblockComment _ -> return lt + lt' -> do + setLastTk lt' + return lt + +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a +reportLexError loc1 loc2 buf str + | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream buf loc dflags = unP go initState + where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState = mkPState dflags' buf loc + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" (begin line_prag2) + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment lexToken) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList([ + ("rules", rulePrag), + ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))), + ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + -- Spelling variant + ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag s)), + ("source", strtoken (\s -> ITsource_prag s)), + ("warning", strtoken (\s -> ITwarning_prag s)), + ("deprecated", strtoken (\s -> ITdeprecated_prag s)), + ("scc", strtoken (\s -> ITscc_prag s)), + ("generated", strtoken (\s -> ITgenerated_prag s)), + ("core", strtoken (\s -> ITcore_prag s)), + ("unpack", strtoken (\s -> ITunpack_prag s)), + ("nounpack", strtoken (\s -> ITnounpack_prag s)), + ("ann", strtoken (\s -> ITann_prag s)), + ("vectorize", strtoken (\s -> ITvect_prag s)), + ("novectorize", strtoken (\s -> ITnovect_prag s)), + ("minimal", strtoken (\s -> ITminimal_prag s)), + ("overlaps", strtoken (\s -> IToverlaps_prag s)), + ("overlappable", strtoken (\s -> IToverlappable_prag s)), + ("overlapping", strtoken (\s -> IToverlapping_prag s)), + ("incoherent", strtoken (\s -> ITincoherent_prag s)), + ("ctype", strtoken (\s -> ITctype s))]) + +twoWordPrags = Map.fromList([ + ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))), + ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))), + ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))), + ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))), + ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))]) + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len + Nothing -> lexError "unknown pragma" + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "vectorise" -> "vectorize" + "novectorise" -> "novectorize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + + + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + +-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST element the annotation belongs to +type AddAnn = (SrcSpan -> P ()) + +addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +addAnnotation l a v = do + addAnnotationOnly l a v + allocateComments l + +addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +addAnnotationOnly l a v = P $ \s -> POk s { + annotations = ((l,a), [v]) : annotations s + } () + +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] + where + mj a l = (\s -> addAnnotation s a l) + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) + lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) + +queueComment :: Located Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +-- | Go through the @comment_q@ in @PState@ and remove all comments +-- that belong within the given span +allocateComments :: SrcSpan -> P () +allocateComments ss = P $ \s -> + let + (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) + (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest + comment_q' = before ++ after + newAnns = if null middle then [] + else [(ss,middle)] + in + POk s { + comment_q = comment_q' + , annotations_comments = newAnns ++ (annotations_comments s) + } () + +commentToAnnotation :: Located Token -> Located AnnotationComment +commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) +commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) +commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) +commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) +commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) +commentToAnnotation (L l (ITdocOptionsOld s)) = L l (AnnDocOptionsOld s) +commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) +commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _) = True +isComment (ITblockComment _) = True +isComment _ = False + +isDocComment :: Token -> Bool +isDocComment (ITdocCommentNext _) = True +isDocComment (ITdocCommentPrev _) = True +isDocComment (ITdocCommentNamed _) = True +isDocComment (ITdocSection _ _) = True +isDocComment (ITdocOptions _) = True +isDocComment (ITdocOptionsOld _) = True +isDocComment _ = False + + +bol,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag1b,line_prag2,line_prag2a,line_prag2b,option_prags :: Int +bol = 1 +layout = 2 +layout_do = 3 +layout_if = 4 +layout_left = 5 +line_prag1 = 6 +line_prag1a = 7 +line_prag1b = 8 +line_prag2 = 9 +line_prag2a = 10 +line_prag2b = 11 +option_prags = 12 +alex_action_1 = warn Opt_WarnTabs (text "Tab character") +alex_action_2 = nested_comment lexToken +alex_action_3 = lineCommentToken +alex_action_4 = lineCommentToken +alex_action_5 = lineCommentToken +alex_action_6 = lineCommentToken +alex_action_7 = lineCommentToken +alex_action_8 = lineCommentToken +alex_action_10 = begin line_prag1 +alex_action_13 = do_bol +alex_action_14 = hopefully_open_brace +alex_action_16 = begin line_prag1 +alex_action_17 = new_layout_context True ITvbar +alex_action_18 = pop +alex_action_19 = new_layout_context True ITvocurly +alex_action_20 = new_layout_context False ITvocurly +alex_action_21 = do_layout_left +alex_action_22 = begin bol +alex_action_23 = dispatch_pragmas linePrags +alex_action_24 = setLine line_prag1a +alex_action_25 = setFile line_prag1b +alex_action_26 = pop +alex_action_27 = setLine line_prag2a +alex_action_28 = setFile line_prag2b +alex_action_29 = pop +alex_action_30 = dispatch_pragmas twoWordPrags +alex_action_31 = dispatch_pragmas oneWordPrags +alex_action_32 = dispatch_pragmas ignoredPrags +alex_action_33 = endPrag +alex_action_34 = dispatch_pragmas fileHeaderPrags +alex_action_35 = multiline_doc_comment +alex_action_36 = nested_comment lexToken +alex_action_37 = lineCommentToken +alex_action_38 = warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") + (nested_comment lexToken) +alex_action_39 = multiline_doc_comment +alex_action_40 = nested_doc_comment +alex_action_41 = token ITopabrack +alex_action_42 = token ITcpabrack +alex_action_43 = token ITopenExpQuote +alex_action_44 = token ITopenTExpQuote +alex_action_45 = token ITopenExpQuote +alex_action_46 = token ITopenTExpQuote +alex_action_47 = token ITopenPatQuote +alex_action_48 = layout_token ITopenDecQuote +alex_action_49 = token ITopenTypQuote +alex_action_50 = token ITcloseQuote +alex_action_51 = token ITcloseTExpQuote +alex_action_52 = skip_one_varid ITidEscape +alex_action_53 = skip_two_varid ITidTyEscape +alex_action_54 = token ITparenEscape +alex_action_55 = token ITparenTyEscape +alex_action_56 = lex_quasiquote_tok +alex_action_57 = lex_quasiquote_tok +alex_action_58 = lex_qquasiquote_tok +alex_action_59 = special IToparenbar +alex_action_60 = special ITcparenbar +alex_action_61 = skip_one_varid ITdupipvarid +alex_action_62 = token IToubxparen +alex_action_63 = token ITcubxparen +alex_action_64 = special IToparen +alex_action_65 = special ITcparen +alex_action_66 = special ITobrack +alex_action_67 = special ITcbrack +alex_action_68 = special ITcomma +alex_action_69 = special ITsemi +alex_action_70 = special ITbackquote +alex_action_71 = open_brace +alex_action_72 = close_brace +alex_action_73 = idtoken qvarid +alex_action_74 = idtoken qconid +alex_action_75 = varid +alex_action_76 = idtoken conid +alex_action_77 = idtoken qvarid +alex_action_78 = idtoken qconid +alex_action_79 = varid +alex_action_80 = idtoken conid +alex_action_81 = idtoken qvarsym +alex_action_82 = idtoken qconsym +alex_action_83 = varsym +alex_action_84 = consym +alex_action_85 = tok_num positive 0 0 decimal +alex_action_86 = tok_num positive 2 2 binary +alex_action_87 = tok_num positive 2 2 octal +alex_action_88 = tok_num positive 2 2 hexadecimal +alex_action_89 = tok_num negative 1 1 decimal +alex_action_90 = tok_num negative 3 3 binary +alex_action_91 = tok_num negative 3 3 octal +alex_action_92 = tok_num negative 3 3 hexadecimal +alex_action_93 = strtoken tok_float +alex_action_94 = strtoken tok_float +alex_action_95 = tok_primint positive 0 1 decimal +alex_action_96 = tok_primint positive 2 3 binary +alex_action_97 = tok_primint positive 2 3 octal +alex_action_98 = tok_primint positive 2 3 hexadecimal +alex_action_99 = tok_primint negative 1 2 decimal +alex_action_100 = tok_primint negative 3 4 binary +alex_action_101 = tok_primint negative 3 4 octal +alex_action_102 = tok_primint negative 3 4 hexadecimal +alex_action_103 = tok_primword 0 2 decimal +alex_action_104 = tok_primword 2 4 binary +alex_action_105 = tok_primword 2 4 octal +alex_action_106 = tok_primword 2 4 hexadecimal +alex_action_107 = init_strtoken 1 tok_primfloat +alex_action_108 = init_strtoken 2 tok_primdouble +alex_action_109 = lex_char_tok +alex_action_110 = lex_string_tok +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 6 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 21 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif +{-# LINE 51 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetByte input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input'' len, _) -> + + + + AlexSkip input'' len + + (AlexLastAcc k input''' len, _) -> + + + + AlexToken input''' len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) + + check_accs (AlexAccPred a predx rest) + | predx user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + | otherwise + = check_accs rest + + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap f AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap f (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAccNone + | AlexAcc a + | AlexAccSkip + + | AlexAccPred a (AlexAccPred user) (AlexAcc a user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc a user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/compiler/parser/Lexer.x.source b/compiler/parser/Lexer.x.source new file mode 100644 index 00000000..7fbbd132 --- /dev/null +++ b/compiler/parser/Lexer.x.source @@ -0,0 +1,2671 @@ +----------------------------------------------------------------------------- +-- (c) The University of Glasgow, 2006 +-- +-- GHC's lexer for Haskell 2010 [1]. +-- +-- This is a combination of an Alex-generated lexer [2] from a regex +-- definition, with some hand-coded bits. [3] +-- +-- Completely accurate information about token-spans within the source +-- file is maintained. Every token has a start and end RealSrcLoc +-- attached to it. +-- +-- References: +-- [1] https://www.haskell.org/onlinereport/haskell2010/haskellch2.html +-- [2] http://www.haskell.org/alex/ +-- [3] https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/Parser +-- +----------------------------------------------------------------------------- + +-- ToDo / known bugs: +-- - parsing integers is a bit slow +-- - readRational is a bit slow +-- +-- Known bugs, that were also in the previous version: +-- - M... should be 3 tokens, not 1. +-- - pragma-end should be only valid in a pragma + +-- qualified operator NOTES. +-- +-- - If M.(+) is a single lexeme, then.. +-- - Probably (+) should be a single lexeme too, for consistency. +-- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. +-- - But we have to rule out reserved operators, otherwise (..) becomes +-- a different lexeme. +-- - Should we therefore also rule out reserved operators in the qualified +-- form? This is quite difficult to achieve. We don't do it for +-- qualified varids. + + +-- ----------------------------------------------------------------------------- +-- Alex "Haskell code fragment top" + +{ +-- XXX The above flags turn off warnings in the generated code: +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- But alex still generates some code that causes the "lazy unlifted bindings" +-- warning, and old compilers don't know about it so we can't easily turn +-- it off, so for now we use the sledge hammer: +{-# OPTIONS_GHC -w #-} + +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module Lexer ( + Token(..), lexer, pragState, mkPState, PState(..), + P(..), ParseResult(..), getSrcLoc, + getPState, getDynFlags, withThisPackage, + failLocMsgP, failSpanMsgP, srcParseFail, + getMessages, + popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + extension, bangPatEnabled, datatypeContextsEnabled, + traditionalRecordSyntaxEnabled, + explicitForallEnabled, + inRulePrag, + explicitNamespacesEnabled, + patternSynonymsEnabled, + sccProfilingOn, hpcEnabled, + addWarning, + lexTokenStream, + addAnnotation,AddAnn,mkParensApiAnn + ) where + +-- base +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Char +import Data.List +import Data.Maybe +import Data.Ratio +import Data.Word + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- data/typeable +import Data.Data +import Data.Typeable + +-- compiler/utils +import Bag +import Outputable +import StringBuffer +import FastString +import UniqFM +import Util ( readRational ) + +-- compiler/main +import ErrUtils +import DynFlags + +-- compiler/basicTypes +import SrcLoc +import Module +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), + SourceText ) + +-- compiler/parser +import Ctype + +import ApiAnnotation +} + +-- ----------------------------------------------------------------------------- +-- Alex "Character set macros" + +-- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs +-- Any changes here should likely be reflected there. +$unispace = \x05 -- Trick Alex into handling Unicode. See alexGetByte. +$nl = [\n\r\f] +$whitechar = [$nl\v\ $unispace] +$white_no_nl = $whitechar # \n -- TODO #8424 +$tab = \t + +$ascdigit = 0-9 +$unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetByte. +$decdigit = $ascdigit -- for now, should really be $digit (ToDo) +$digit = [$ascdigit $unidigit] + +$special = [\(\)\,\;\[\]\`\{\}] +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] +$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte. +$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] + +$unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetByte. +$asclarge = [A-Z] +$large = [$asclarge $unilarge] + +$unismall = \x02 -- Trick Alex into handling Unicode. See alexGetByte. +$ascsmall = [a-z] +$small = [$ascsmall $unismall \_] + +$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte. +$graphic = [$small $large $symbol $digit $special $unigraphic \"\'] + +$binit = 0-1 +$octit = 0-7 +$hexit = [$decdigit A-F a-f] + +$suffix = \x07 -- Trick Alex into handling Unicode. See alexGetByte. +-- TODO #10196. Only allow modifier letters in the suffix of an identifier. +$idchar = [$small $large $digit $suffix \'] + +$pragmachar = [$small $large $digit] + +$docsym = [\| \^ \* \$] + + +-- ----------------------------------------------------------------------------- +-- Alex "Regular expression macros" + +@varid = $small $idchar* -- variable identifiers +@conid = $large $idchar* -- constructor identifiers + +@varsym = ($symbol # \:) $symbol* -- variable (operator) symbol +@consym = \: $symbol* -- constructor (operator) symbol + +@decimal = $decdigit+ +@binary = $binit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+]? @decimal + +@qual = (@conid \.)+ +@qvarid = @qual @varid +@qconid = @qual @conid +@qvarsym = @qual @varsym +@qconsym = @qual @consym + +@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent + +-- normal signed numerical literals can only be explicitly negative, +-- not explicitly positive (contrast @exponent) +@negative = \- +@signed = @negative ? + + +-- ----------------------------------------------------------------------------- +-- Alex "Identifier" + +haskell :- + + +-- ----------------------------------------------------------------------------- +-- Alex "Rules" + +-- everywhere: skip whitespace +$white_no_nl+ ; +$tab+ { warn Opt_WarnTabs (text "Tab character") } + +-- Everywhere: deal with nested comments. We explicitly rule out +-- pragmas, "{-#", so that we don't accidentally treat them as comments. +-- (this can happen even though pragmas will normally take precedence due to +-- longest-match, because pragmas aren't valid in every state, but comments +-- are). We also rule out nested Haddock comments, if the -haddock flag is +-- set. + +"{-" / { isNormalComment } { nested_comment lexToken } + +-- Single-line comments are a bit tricky. Haskell 98 says that two or +-- more dashes followed by a symbol should be parsed as a varsym, so we +-- have to exclude those. + +-- Since Haddock comments aren't valid in every state, we need to rule them +-- out here. + +-- The following two rules match comments that begin with two dashes, but +-- continue with a different character. The rules test that this character +-- is not a symbol (in which case we'd have a varsym), and that it's not a +-- space followed by a Haddock comment symbol (docsym) (in which case we'd +-- have a Haddock comment). The rules then munch the rest of the line. + +"-- " ~[$docsym \#] .* { lineCommentToken } +"--" [^$symbol \ ] .* { lineCommentToken } + +-- Next, match Haddock comments if no -haddock flag + +"-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } { lineCommentToken } + +-- Now, when we've matched comments that begin with 2 dashes and continue +-- with a different character, we need to match comments that begin with three +-- or more dashes (which clearly can't be Haddock comments). We only need to +-- make sure that the first non-dash character isn't a symbol, and munch the +-- rest of the line. + +"---"\-* ~$symbol .* { lineCommentToken } + +-- Since the previous rules all match dashes followed by at least one +-- character, we also need to match a whole line filled with just dashes. + +"--"\-* / { atEOL } { lineCommentToken } + +-- We need this rule since none of the other single line comment rules +-- actually match this case. + +"-- " / { atEOL } { lineCommentToken } + +-- 'bol' state: beginning of a line. Slurp up all the whitespace (including +-- blank lines) until we find a non-whitespace character, then do layout +-- processing. +-- +-- One slight wibble here: what if the line begins with {-#? In +-- theory, we have to lex the pragma to see if it's one we recognise, +-- and if it is, then we backtrack and do_bol, otherwise we treat it +-- as a nested comment. We don't bother with this: if the line begins +-- with {-#, then we'll assume it's a pragma we know about and go for do_bol. + { + \n ; + ^\# (line)? { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n ; -- #!, for scripts + () { do_bol } +} + +-- after a layout keyword (let, where, do, of), we begin a new layout +-- context if the curly brace is missing. +-- Careful! This stuff is quite delicate. + { + \{ / { notFollowedBy '-' } { hopefully_open_brace } + -- we might encounter {-# here, but {- has been handled already + \n ; + ^\# (line)? { begin line_prag1 } +} + +-- after an 'if', a vertical bar starts a layout context for MultiWayIf + { + \| / { notFollowedBySymbol } { new_layout_context True ITvbar } + () { pop } +} + +-- do is treated in a subtly different way, see new_layout_context + () { new_layout_context True ITvocurly } + () { new_layout_context False ITvocurly } + +-- after a new layout context which was found to be to the left of the +-- previous context, we have generated a '{' token, and we now need to +-- generate a matching '}' token. + () { do_layout_left } + +<0,option_prags> \n { begin bol } + +"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } + { dispatch_pragmas linePrags } + +-- single-line line pragmas, of the form +-- # "" \n + @decimal { setLine line_prag1a } + \" [$graphic \ ]* \" { setFile line_prag1b } + .* { pop } + +-- Haskell-style line pragmas, of the form +-- {-# LINE "" #-} + @decimal { setLine line_prag2a } + \" [$graphic \ ]* \" { setFile line_prag2b } + "#-}"|"-}" { pop } + -- NOTE: accept -} at the end of a LINE pragma, for compatibility + -- with older versions of GHC which generated these. + +<0,option_prags> { + "{-#" $whitechar* $pragmachar+ + $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } + { dispatch_pragmas twoWordPrags } + + "{-#" $whitechar* $pragmachar+ / { known_pragma oneWordPrags } + { dispatch_pragmas oneWordPrags } + + -- We ignore all these pragmas, but don't generate a warning for them + "{-#" $whitechar* $pragmachar+ / { known_pragma ignoredPrags } + { dispatch_pragmas ignoredPrags } + + -- ToDo: should only be valid inside a pragma: + "#-}" { endPrag } +} + + { + "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } + { dispatch_pragmas fileHeaderPrags } + + "-- #" { multiline_doc_comment } +} + +<0> { + -- In the "0" mode we ignore these pragmas + "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } + { nested_comment lexToken } +} + +<0> { + "-- #" .* { lineCommentToken } +} + +<0,option_prags> { + "{-#" { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") + (nested_comment lexToken) } +} + +-- '0' state: ordinary lexemes + +-- Haddock comments + +<0,option_prags> { + "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment } + "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment } +} + +-- "special" symbols + +<0> { + "[:" / { ifExtension parrEnabled } { token ITopabrack } + ":]" / { ifExtension parrEnabled } { token ITcpabrack } +} + +<0> { + "[|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[||" / { ifExtension thEnabled } { token ITopenTExpQuote } + "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[e||" / { ifExtension thEnabled } { token ITopenTExpQuote } + "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } + "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } + "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } + "|]" / { ifExtension thEnabled } { token ITcloseQuote } + "||]" / { ifExtension thEnabled } { token ITcloseTExpQuote } + \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } + "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape } + "$(" / { ifExtension thEnabled } { token ITparenEscape } + "$$(" / { ifExtension thEnabled } { token ITparenTyEscape } + +-- For backward compatibility, accept the old dollar syntax + "[$" @varid "|" / { ifExtension qqEnabled } + { lex_quasiquote_tok } + + "[" @varid "|" / { ifExtension qqEnabled } + { lex_quasiquote_tok } + + -- qualified quasi-quote (#5555) + "[" @qvarid "|" / { ifExtension qqEnabled } + { lex_qquasiquote_tok } +} + +<0> { + "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol } + { special IToparenbar } + "|)" / { ifExtension arrowsEnabled } { special ITcparenbar } +} + +<0> { + \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } +} + +<0> { + "(#" / { ifExtension unboxedTuplesEnabled } + { token IToubxparen } + "#)" / { ifExtension unboxedTuplesEnabled } + { token ITcubxparen } +} + +<0,option_prags> { + \( { special IToparen } + \) { special ITcparen } + \[ { special ITobrack } + \] { special ITcbrack } + \, { special ITcomma } + \; { special ITsemi } + \` { special ITbackquote } + + \{ { open_brace } + \} { close_brace } +} + +<0,option_prags> { + @qvarid { idtoken qvarid } + @qconid { idtoken qconid } + @varid { varid } + @conid { idtoken conid } +} + +<0> { + @qvarid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid } + @qconid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid } + @varid "#"+ / { ifExtension magicHashEnabled } { varid } + @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid } +} + +-- ToDo: - move `var` and (sym) into lexical syntax? +-- - remove backquote from $special? +<0> { + @qvarsym { idtoken qvarsym } + @qconsym { idtoken qconsym } + @varsym { varsym } + @consym { consym } +} + +-- For the normal boxed literals we need to be careful +-- when trying to be close to Haskell98 +<0> { + -- Normal integral literals (:: Num a => a, from Integer) + @decimal { tok_num positive 0 0 decimal } + 0[bB] @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary } + 0[oO] @octal { tok_num positive 2 2 octal } + 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } + @negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal } + @negative 0[bB] @binary / { ifExtension negativeLiteralsEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary } + @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal } + @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal } + + -- Normal rational literals (:: Fractional a => a, from Rational) + @floating_point { strtoken tok_float } + @negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float } +} + +<0> { + -- Unboxed ints (:: Int#) and words (:: Word#) + -- It's simpler (and faster?) to give separate cases to the negatives, + -- especially considering octal/hexadecimal prefixes. + @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal } + 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary } + 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal } + 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal } + @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal } + @negative 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary } + @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal } + @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal } + + @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal } + 0[bB] @binary \# \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary } + 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal } + 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal } + + -- Unboxed floats and doubles (:: Float#, :: Double#) + -- prim_{float,double} work with signed literals + @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat } + @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble } +} + +-- Strings and chars are lexed by hand-written code. The reason is +-- that even if we recognise the string or char here in the regex +-- lexer, we would still have to parse the string afterward in order +-- to convert it to a String. +<0> { + \' { lex_char_tok } + \" { lex_string_tok } +} + + +-- ----------------------------------------------------------------------------- +-- Alex "Haskell code fragment bottom" + +{ + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + + -- Pragmas, see note [Pragma source text] in BasicTypes + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITcore_prag SourceText -- hdaume: core annotations + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITvect_prag SourceText + | ITvect_scalar_prag SourceText + | ITnovect_prag SourceText + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon + | ITequal + | ITlam + | ITlcase + | ITvbar + | ITlarrow + | ITrarrow + | ITat + | ITtilde + | ITtildehsh + | ITdarrow + | ITminus + | ITbang + | ITstar + | ITdot + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + | ITprefixqvarsym (FastString,FastString) + | ITprefixqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + + | ITchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes + | ITinteger SourceText Integer -- Note [Literal source text] in BasicTypes + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes + | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITopenTExpQuote -- [|| + | ITcloseTExpQuote -- ||] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITidTyEscape FastString -- $$x + | ITparenTyEscape -- $$( + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- + + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token + + -- Documentation annotations + | ITdocCommentNext String -- something beginning '-- |' + | ITdocCommentPrev String -- something beginning '-- ^' + | ITdocCommentNamed String -- something beginning '-- $' + | ITdocSection Int String -- a section heading + | ITdocOptions String -- doc options (prune, ignore-exports, etc) + | ITdocOptionsOld String -- doc options declared "-- # ..."-style + | ITlineComment String -- comment starting by "--" + | ITblockComment String -- comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall, xbit ExplicitForallBit .|. + xbit InRulePragBit), + ( "mdo", ITmdo, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) +reservedSymsFM = listToUFM $ + map (\ (x,y,z) -> (mkFastString x,(y,z))) + [ ("..", ITdotdot, always) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, always) + ,("::", ITdcolon, always) + ,("=", ITequal, always) + ,("\\", ITlam, always) + ,("|", ITvbar, always) + ,("<-", ITlarrow, always) + ,("->", ITrarrow, always) + ,("@", ITat, always) + ,("~", ITtilde, always) + ,("~#", ITtildehsh, magicHashEnabled) + ,("=>", ITdarrow, always) + ,("-", ITminus, always) + ,("!", ITbang, always) + + -- For data T (a::*) = MkT + ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i) + -- For 'forall a . t' + ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) + + ,("-<", ITlarrowtail, arrowsEnabled) + ,(">-", ITrarrowtail, arrowsEnabled) + ,("-<<", ITLarrowtail, arrowsEnabled) + ,(">>-", ITRarrowtail, arrowsEnabled) + + ,("∷", ITdcolon, unicodeSyntaxEnabled) + ,("⇒", ITdarrow, unicodeSyntaxEnabled) + ,("∀", ITforall, unicodeSyntaxEnabled) + ,("→", ITrarrow, unicodeSyntaxEnabled) + ,("←", ITlarrow, unicodeSyntaxEnabled) + + ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + + ,("★", ITstar, unicodeSyntaxEnabled) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) + +special :: Token -> Action +special tok span _buf _len = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len = return (L span t) +layout_token t span _buf _len = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len = return (L span $! (f buf len)) + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +init_strtoken :: Int -> (String -> Token) -> Action +-- like strtoken, but drops the last N character(s) +init_strtoken drop f span buf len = + return (L span $! (f $! lexemeToString buf (len-drop))) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- extension relaxedLayout + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else failSpanMsgP (RealSrcSpan span) (text "Missing block") + +pop_and :: Action -> Action +pop_and act span buf len = do _ <- popLexState + act span buf len + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | haddockEnabled bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap +ifExtension pred bits _ _ _ = pred bits + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len = withLexedDocType (worker "") + where + worker commentAcc input docType oneLine = case alexGetChar' input of + Just ('\n', input') + | oneLine -> docCommentEnd input commentAcc docType buf span + | otherwise -> case checkIfCommentLine input' of + Just input -> worker ('\n':commentAcc) input docType False + Nothing -> docCommentEnd input commentAcc docType buf span + Just (c, input) -> worker (c:commentAcc) input docType oneLine + Nothing -> docCommentEnd input commentAcc docType buf span + + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = case alexGetChar' input of + Just ('-', input) -> case alexGetChar' input of + Just ('-', input) -> case alexGetChar' input of + Just (c, _) | c /= '-' -> Just input + _ -> Nothing + _ -> Nothing + _ -> Nothing + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len = do + b <- extension rawTokenStreamEnabled + if b then strtoken ITlineComment span buf len else lexToken + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: P (RealLocated Token) -> Action +nested_comment cont span buf len = do + input <- getInput + go (reverse $ lexemeToString buf len) (1::Int) input + where + go commentAcc 0 input = do + setInput input + b <- extension rawTokenStreamEnabled + if b + then docCommentEnd input commentAcc ITblockComment buf span + else cont + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input span + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +nested_doc_comment :: Action +nested_doc_comment span buf _len = withLexedDocType (go "") + where + go commentAcc input docType _ = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> + docCommentEnd input commentAcc docType buf span + Just (_,_) -> go ('-':commentAcc) input docType False + Just ('\123', input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> do + setInput input + let cont = do input <- getInput; go commentAcc input docType False + nested_comment cont span buf _len + Just (_,_) -> go ('\123':commentAcc) input docType False + Just (c,input) -> go (c:commentAcc) input docType False + +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + case prevChar buf ' ' of + '|' -> lexDocComment input ITdocCommentNext False + '^' -> lexDocComment input ITdocCommentPrev False + '$' -> lexDocComment input ITdocCommentNamed False + '*' -> lexDocSection 1 input + '#' -> lexDocComment input ITdocOptionsOld False + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection (n+1) input + Just (_, _) -> lexDocComment input (ITdocSection n) True + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToString buf len + return (L span (ITrules_prag src)) + +endPrag :: Action +endPrag span _buf _len = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> + RealSrcSpan -> P (RealLocated Token) +docCommentEnd input commentAcc docType buf span = do + setInput input + let (AI loc nextBuf) = input + comment = reverse commentAcc + span' = mkRealSrcSpan (realSrcSpanStart span) loc + last_len = byteDiff buf nextBuf + + span `seq` setLastToken span' last_len + return (L span' (docType comment)) + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" + +open_brace, close_brace :: Action +open_brace span _str _len = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lambdaCase <- extension lambdaCaseEnabled + keyword <- if lambdaCase + then do + lastTk <- getLastTk + return $ case lastTk of + Just ITlam -> ITlcase + _ -> ITcase + else + return ITcase + maybe_layout keyword + return $ L span keyword + Just (ITstatic, _) -> do + flags <- getDynFlags + if xopt Opt_StaticPointers flags + then return $ L span ITstatic + else return $ L span $ ITvarid fs + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, exts) -> do + extsEnabled <- extension $ \i -> exts .&. i /= 0 + if extsEnabled + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False +prefixqvarsym buf len = ITprefixqvarsym $! splitQualName buf len True +prefixqconsym buf len = ITprefixqconsym $! splitQualName buf len True + +varsym, consym :: Action +varsym = sym ITvarsym +consym = sym ITconsym + +sym :: (FastString -> Token) -> Action +sym con span buf len = + case lookupUFM reservedSymsFM fs of + Just (keyword, exts) -> do + extsEnabled <- extension exts + let !tk | extsEnabled = keyword + | otherwise = con fs + return $ L span tk + Nothing -> + return $ L span $! con fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral :: (String -> Integer -> Token) + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint (lexemeToString buf len) + $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + +-- some conveniences for use with tok_integral +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral ITinteger +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive +positive, negative :: (Integer -> Integer) +positive = id +negative = negate +decimal, octal, hexadecimal :: (Integer, Char -> Int) +decimal = (10,octDecDigit) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readRational can understand negative rationals, exponents, everything. +tok_float, tok_primfloat, tok_primdouble :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len = do + pos <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- extension alternativeLayoutRule + unless alr $ f t + where f ITdo = pushLexState layout_do + f ITmdo = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +-- +new_layout_context :: Bool -> Token -> Action +new_layout_context strict tok span _buf len = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol l - len + ctx <- getContext + nondecreasing <- extension nondecreasingIndentation + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do + setContext (Layout offset : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLine :: Int -> Action +setLine code span buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + _ <- popLexState + pushLexState code + lexToken + +setFile :: Int -> Action +setFile code span buf len = do + let file = mkFastString (go (lexemeToString (stepOn buf) (len-2))) + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok span _buf _len + = do input <- getInput + start <- getSrcLoc + tok <- go [] input + end <- getSrcLoc + return (L (mkRealSrcSpan start end) tok) + where go acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc)) + else case alexGetChar input of + Just (c,i) -> go (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" + + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +-- This stuff is horrible. I hates it. + +lex_string_tok :: Action +lex_string_tok span buf _len = do + tok <- lex_string "" + end <- getSrcLoc + (AI end bufEnd) <- getInput + let + tok' = case tok of + ITprimstring _ bs -> ITprimstring src bs + ITstring _ s -> ITstring src s + src = lexemeToString buf (cur bufEnd - cur buf) + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') + +lex_string :: String -> P Token +lex_string s = do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i + + Just ('"',i) -> do + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s + then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" + else let bs = unsafeMkByteString (reverse s) + in return (ITprimstring "" bs) + _other -> + return (ITstring "" (mkFastString (reverse s))) + else + return (ITstring "" (mkFastString (reverse s))) + + Just ('\\',i) + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751, #5425) + setInput i; lex_stringgap s + where next = alexGetChar' i + + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i + +lex_stringgap :: String -> P Token +lex_stringgap s = do + i <- getInput + c <- getCharOrFail i + case c of + '\\' -> lex_string s + c | c <= '\x7f' && is_space c -> lex_stringgap s + -- is_space only works for <= '\x7f' (#3751, #5425) + _other -> lit_error i + + +lex_char_tok :: Action +-- Here we are basically parsing character literals, such as 'x' or '\n' +-- but, when Template Haskell is on, we additionally spot +-- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively, +-- but WITHOUT CONSUMING the x or T part (the parser does that). +-- So we have to do two characters of lookahead: when we see 'x we need to +-- see if there's a trailing quote +lex_char_tok span buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = realSrcSpanStart span + case alexGetChar' i1 of + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok buf loc lit_ch + else lit_error i3 + + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok buf loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + let (AI end _) = i1 + return (L (mkRealSrcSpan loc end) ITsimpleQuote) + +finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok buf loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end bufEnd) <- getInput + let src = lexemeToString buf (cur bufEnd - cur buf) + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar src ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar src ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar src ch)) + +isAny :: Char -> Bool +isAny c | c > '\x7f' = isPrint c + | otherwise = is_any c + +lex_escape :: P Char +lex_escape = do + i0 <- getInput + c <- getCharOrFail i0 + case c of + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput + c <- getCharOrFail i1 + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + 'b' -> readNum is_bindigit 2 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> + case alexGetChar' i2 of + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 + +readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char +readNum is_digit base conv = do + i <- getInput + c <- getCharOrFail i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i + +readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char +readNum2 is_digit base conv i = do + input <- getInput + read i input + where read i input = do + case alexGetChar' input of + Just (c,input') | is_digit c -> do + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' + _other -> do + setInput input; return (chr i) + + +silly_escape_chars :: [(String, Char)] +silly_escape_chars = [ + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] + +-- before calling lit_error, ensure that the current input is pointing to +-- the position of the error in the buffer. This is so that we can report +-- a correct location to the user, but also so we can detect UTF-8 decoding +-- errors if they occur. +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" + +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do + case alexGetChar' i of + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on Trac #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start end buf "unterminated quasiquotation" + +-- ----------------------------------------------------------------------------- +-- Warnings + +warn :: WarningFlag -> SDoc -> Action +warn option warning srcspan _buf _len = do + addWarning option (RealSrcSpan srcspan) warning + lexToken + +warnThen :: WarningFlag -> SDoc -> Action -> Action +warnThen option warning action srcspan buf len = do + addWarning option (RealSrcSpan srcspan) warning + action srcspan buf len + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +data LayoutContext + = NoLayout + | Layout !Int + deriving Show + +data ParseResult a + = POk PState a + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + MsgDoc -- The error message + +data PState = PState { + buffer :: StringBuffer, + dflags :: DynFlags, + messages :: Messages, + last_tk :: Maybe Token, + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !ExtsBitmap, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [RealLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (RealLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: RealSrcSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See note [Api annotations] in ApiAnnotation.hs + annotations :: [(ApiAnnKey,[SrcSpan])], + comment_q :: [Located AnnotationComment], + annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = return + (<*>) = ap + +instance Monad P where + return = returnP + (>>=) = thenP + fail = failP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err + +failP :: String -> P a +failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) + +failMsgP :: String -> P a +failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) + +failSpanMsgP :: SrcSpan -> SDoc -> P a +failSpanMsgP span msg = P $ \_ -> PFailed span msg + +getPState :: P PState +getPState = P $ \s -> POk s s + +instance HasDynFlags P where + getDynFlags = P $ \s -> POk s (dflags s) + +withThisPackage :: (PackageKey -> a) -> P a +withThisPackage f + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg + +extension :: (ExtsBitmap -> Bool) -> P Bool +extension p = P $ \s -> POk s (p $! extsBitmap s) + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (extsBitmap s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () + +getSrcLoc :: P RealSrcLoc +getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setLastToken :: RealSrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: Token -> P () +setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () + +getLastTk :: P (Maybe Token) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +data AlexInput = AI RealSrcLoc StringBuffer + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + byte = fromIntegral $ ord adj_c + + non_graphic = '\x00' + upper = '\x01' + lower = '\x02' + digit = '\x03' + symbol = '\x04' + space = '\x05' + other_graphic = '\x06' + suffix = '\x07' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in basicTypes/Lexeme.hs + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> suffix -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic + +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (RealLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P RealSrcSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: RealLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [RealLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- for reasons of efficiency, flags indicating language extensions (eg, +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Word64 +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +data ExtBits + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ParrBit + | ArrowsBit + | ThBit + | IpBit + | ExplicitForallBit -- the 'forall' keyword and '.' symbol + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | KindSigsBit -- Kind signatures on type variables + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | DatatypeContextsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | InRulePragBit + | RawTokenStreamBit -- producing a token stream with all comments included + | SccProfilingOnBit + | HpcBit + | AlternativeLayoutRuleBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + deriving Enum + + +always :: ExtsBitmap -> Bool +always _ = True +parrEnabled :: ExtsBitmap -> Bool +parrEnabled = xtest ParrBit +arrowsEnabled :: ExtsBitmap -> Bool +arrowsEnabled = xtest ArrowsBit +thEnabled :: ExtsBitmap -> Bool +thEnabled = xtest ThBit +ipEnabled :: ExtsBitmap -> Bool +ipEnabled = xtest IpBit +explicitForallEnabled :: ExtsBitmap -> Bool +explicitForallEnabled = xtest ExplicitForallBit +bangPatEnabled :: ExtsBitmap -> Bool +bangPatEnabled = xtest BangPatBit +haddockEnabled :: ExtsBitmap -> Bool +haddockEnabled = xtest HaddockBit +magicHashEnabled :: ExtsBitmap -> Bool +magicHashEnabled = xtest MagicHashBit +-- kindSigsEnabled :: ExtsBitmap -> Bool +-- kindSigsEnabled = xtest KindSigsBit +unicodeSyntaxEnabled :: ExtsBitmap -> Bool +unicodeSyntaxEnabled = xtest UnicodeSyntaxBit +unboxedTuplesEnabled :: ExtsBitmap -> Bool +unboxedTuplesEnabled = xtest UnboxedTuplesBit +datatypeContextsEnabled :: ExtsBitmap -> Bool +datatypeContextsEnabled = xtest DatatypeContextsBit +qqEnabled :: ExtsBitmap -> Bool +qqEnabled = xtest QqBit +inRulePrag :: ExtsBitmap -> Bool +inRulePrag = xtest InRulePragBit +rawTokenStreamEnabled :: ExtsBitmap -> Bool +rawTokenStreamEnabled = xtest RawTokenStreamBit +alternativeLayoutRule :: ExtsBitmap -> Bool +alternativeLayoutRule = xtest AlternativeLayoutRuleBit +hpcEnabled :: ExtsBitmap -> Bool +hpcEnabled = xtest HpcBit +relaxedLayout :: ExtsBitmap -> Bool +relaxedLayout = xtest RelaxedLayoutBit +nondecreasingIndentation :: ExtsBitmap -> Bool +nondecreasingIndentation = xtest NondecreasingIndentationBit +sccProfilingOn :: ExtsBitmap -> Bool +sccProfilingOn = xtest SccProfilingOnBit +traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool +traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit + +explicitNamespacesEnabled :: ExtsBitmap -> Bool +explicitNamespacesEnabled = xtest ExplicitNamespacesBit +lambdaCaseEnabled :: ExtsBitmap -> Bool +lambdaCaseEnabled = xtest LambdaCaseBit +binaryLiteralsEnabled :: ExtsBitmap -> Bool +binaryLiteralsEnabled = xtest BinaryLiteralsBit +negativeLiteralsEnabled :: ExtsBitmap -> Bool +negativeLiteralsEnabled = xtest NegativeLiteralsBit +patternSynonymsEnabled :: ExtsBitmap -> Bool +patternSynonymsEnabled = xtest PatternSynonymsBit + +-- PState for parsing options pragmas +-- +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } + +-- create a parse state +-- +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +mkPState flags buf loc = + PState { + buffer = buf, + dflags = flags, + messages = emptyMessages, + last_tk = Nothing, + last_loc = mkRealSrcSpan loc loc, + last_len = 0, + loc = loc, + extsBitmap = bitmap, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = alrInitialLoc (fsLit ""), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + annotations = [], + comment_q = [], + annotations_comments = [] + } + where + bitmap = FfiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. InterruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. CApiFfiBit `setBitIf` xopt Opt_CApiFFI flags + .|. ParrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. ArrowsBit `setBitIf` xopt Opt_Arrows flags + .|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. IpBit `setBitIf` xopt Opt_ImplicitParams flags + .|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. HaddockBit `setBitIf` gopt Opt_Haddock flags + .|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. DatatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags + .|. HpcBit `setBitIf` gopt Opt_Hpc flags + .|. AlternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. RelaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags + .|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. SafeHaskellBit `setBitIf` safeImportsOn flags + .|. TraditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. ExplicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags + .|. LambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. BinaryLiteralsBit `setBitIf` xopt Opt_BinaryLiterals flags + .|. NegativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags + .|. PatternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags + -- + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () +addWarning option srcspan warning + = P $ \s@PState{messages=(ws,es), dflags=d} -> + let warning' = mkWarnMsg d srcspan alwaysQualify warning + ws' = if wopt option d then ws `snocBag` warning' else ws + in POk s{messages=(ws', es)} () + +getMessages :: PState -> Messages +getMessages PState{messages=ms} = ms + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, dflags = flags, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len) + +-- Push a new layout context at the indentation of the last token read. +-- This is only used at the outer level of a module when the 'module' +-- keyword is missing. +pushCurrentContext :: P () +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) : ctx} () + +getOffside :: P Ordering +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol loc in + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + compare offs n + _ -> GT + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: DynFlags + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> MsgDoc +srcParseErr dflags buf len + = if null token + then ptext (sLit "parse error (possibly incorrect indentation or mismatched brackets)") + else ptext (sLit "parse error on input") <+> quotes (text token) + $$ ppWhen (not th_enabled && token == "$") -- #7396 + (text "Perhaps you intended to use TemplateHaskell") + $$ ppWhen (token == "<-") + (text "Perhaps this statement should be within a 'do' block?") + where token = lexemeToString (offsetBytes (-len) buf) len + th_enabled = xopt Opt_TemplateHaskell dflags + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \PState{ buffer = buf, dflags = flags, last_len = len, + last_loc = last_loc } -> + PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len) + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: String -> P a +lexError str = do + loc <- getSrcLoc + (AI end buf) <- getInput + reportLexError loc end buf str + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer :: Bool -> (Located Token -> P a) -> P a +lexer queueComments cont = do + alr <- extension alternativeLayoutRule + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + case tok of + ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) + _ -> return () + + if (queueComments && isDocComment tok) + then queueComment (L (RealSrcSpan span) tok) + else return () + + if (queueComments && isComment tok) + then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont + else cont (L (RealSrcSpan span) tok) + +lexTokenAlr :: P (RealLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + dflags <- getDynFlags + let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags + thisLoc = getLoc t + thisCol = srcSpanStartCol thisLoc + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIntentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITccurly] + setNextToken t + return (L lastLoc ITocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + return (L thisLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen ITparenEscape = True +isALRopen ITparenTyEscape = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIntentation :: ALRLayout -> Bool +isNonDecreasingIntentation ALRLayoutDo = True +isNonDecreasingIntentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +lexToken :: P (RealLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkRealSrcSpan loc1 loc1 + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError loc1 loc2 buf "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkRealSrcSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes + case unLoc lt of + ITlineComment _ -> return lt + ITblockComment _ -> return lt + lt' -> do + setLastTk lt' + return lt + +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a +reportLexError loc1 loc2 buf str + | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream buf loc dflags = unP go initState + where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState = mkPState dflags' buf loc + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" (begin line_prag2) + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment lexToken) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList([ + ("rules", rulePrag), + ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))), + ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + -- Spelling variant + ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag s)), + ("source", strtoken (\s -> ITsource_prag s)), + ("warning", strtoken (\s -> ITwarning_prag s)), + ("deprecated", strtoken (\s -> ITdeprecated_prag s)), + ("scc", strtoken (\s -> ITscc_prag s)), + ("generated", strtoken (\s -> ITgenerated_prag s)), + ("core", strtoken (\s -> ITcore_prag s)), + ("unpack", strtoken (\s -> ITunpack_prag s)), + ("nounpack", strtoken (\s -> ITnounpack_prag s)), + ("ann", strtoken (\s -> ITann_prag s)), + ("vectorize", strtoken (\s -> ITvect_prag s)), + ("novectorize", strtoken (\s -> ITnovect_prag s)), + ("minimal", strtoken (\s -> ITminimal_prag s)), + ("overlaps", strtoken (\s -> IToverlaps_prag s)), + ("overlappable", strtoken (\s -> IToverlappable_prag s)), + ("overlapping", strtoken (\s -> IToverlapping_prag s)), + ("incoherent", strtoken (\s -> ITincoherent_prag s)), + ("ctype", strtoken (\s -> ITctype s))]) + +twoWordPrags = Map.fromList([ + ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))), + ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))), + ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))), + ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))), + ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))]) + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len + Nothing -> lexError "unknown pragma" + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "vectorise" -> "vectorize" + "novectorise" -> "novectorize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + + + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + +-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST element the annotation belongs to +type AddAnn = (SrcSpan -> P ()) + +addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +addAnnotation l a v = do + addAnnotationOnly l a v + allocateComments l + +addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +addAnnotationOnly l a v = P $ \s -> POk s { + annotations = ((l,a), [v]) : annotations s + } () + +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] + where + mj a l = (\s -> addAnnotation s a l) + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) + lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) + +queueComment :: Located Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +-- | Go through the @comment_q@ in @PState@ and remove all comments +-- that belong within the given span +allocateComments :: SrcSpan -> P () +allocateComments ss = P $ \s -> + let + (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) + (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest + comment_q' = before ++ after + newAnns = if null middle then [] + else [(ss,middle)] + in + POk s { + comment_q = comment_q' + , annotations_comments = newAnns ++ (annotations_comments s) + } () + +commentToAnnotation :: Located Token -> Located AnnotationComment +commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) +commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) +commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) +commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) +commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) +commentToAnnotation (L l (ITdocOptionsOld s)) = L l (AnnDocOptionsOld s) +commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) +commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _) = True +isComment (ITblockComment _) = True +isComment _ = False + +isDocComment :: Token -> Bool +isDocComment (ITdocCommentNext _) = True +isDocComment (ITdocCommentPrev _) = True +isDocComment (ITdocCommentNamed _) = True +isDocComment (ITdocSection _ _) = True +isDocComment (ITdocOptions _) = True +isDocComment (ITdocOptionsOld _) = True +isDocComment _ = False +} diff --git a/compiler/parser/Parser.hs b/compiler/parser/Parser.hs new file mode 100644 index 00000000..393149cb --- /dev/null +++ b/compiler/parser/Parser.hs @@ -0,0 +1,10300 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location in +-- @ +module Parser (parseModule, parseImport, parseStatement, + parseDeclaration, parseExpression, parsePattern, + parseTypeSignature, + parseFullStmt, parseStmt, parseIdentifier, + parseType, parseHeader) where + +-- base +import Control.Monad ( unless, liftM ) +import GHC.Exts +import Data.Char +import Control.Monad ( mplus ) + +-- compiler/hsSyn +import HsSyn + +-- compiler/main +import HscTypes ( IsBootInterface, WarningTxt(..) ) +import DynFlags + +-- compiler/utils +import OrdList +import BooleanFormula ( BooleanFormula(..), mkTrue ) +import FastString +import Maybes ( orElse ) +import Outputable + +-- compiler/basicTypes +import RdrName +import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import DataCon ( DataCon, dataConName ) +import SrcLoc +import Module +import BasicTypes + +-- compiler/types +import Type ( funTyCon ) +import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) +import Class ( FunDep ) + +-- compiler/parser +import RdrHsSyn +import Lexer +import HaddockUtils +import ApiAnnotation + +-- compiler/typecheck +import TcEvidence ( emptyTcEvBinds ) + +-- compiler/prelude +import ForeignCall +import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) + +-- parser produced by Happy Version 1.19.4 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn15 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (Located (HsModule RdrName)) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (Located (HsModule RdrName)) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (()) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (()) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (Maybe (Located WarningTxt)) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (Maybe (Located WarningTxt)) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName]))) +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (Located (HsModule RdrName)) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (Located (HsModule RdrName)) +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: ((Maybe (Located [LIE RdrName]))) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> ((Maybe (Located [LIE RdrName]))) +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (OrdList (LIE RdrName)) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> (OrdList (LIE RdrName)) +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (Located ([AddAnn],ImpExpSubSpec)) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (Located ([AddAnn],ImpExpSubSpec)) +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: ([Located RdrName]) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> ([Located RdrName]) +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (([AddAnn],[LImportDecl RdrName])) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (([AddAnn],[LImportDecl RdrName])) +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: (LImportDecl RdrName) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> (LImportDecl RdrName) +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: ((([AddAnn],Maybe SourceText),IsBootInterface)) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> ((([AddAnn],Maybe SourceText),IsBootInterface)) +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: (([AddAnn],Bool)) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> (([AddAnn],Bool)) +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: (([AddAnn],Maybe FastString)) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> (([AddAnn],Maybe FastString)) +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: (([AddAnn],Bool)) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> (([AddAnn],Bool)) +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: (([AddAnn],Located (Maybe ModuleName))) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> (([AddAnn],Located (Maybe ModuleName))) +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: (Located (Maybe (Bool, Located [LIE RdrName]))) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> (Located (Maybe (Bool, Located [LIE RdrName]))) +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: (Located (Bool, Located [LIE RdrName])) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> (Located (Bool, Located [LIE RdrName])) +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: (Located Int) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> (Located Int) +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: (Located FixityDirection) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> (Located FixityDirection) +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (Located (OrdList (Located RdrName))) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> (Located (OrdList (Located RdrName))) +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: (LInstDecl RdrName) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> (LInstDecl RdrName) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: (Maybe (Located OverlapMode)) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> (Maybe (Located OverlapMode)) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: (Located ([AddAnn],FamilyInfo RdrName)) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> (Located ([AddAnn],FamilyInfo RdrName)) +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: (Located ([AddAnn],[LTyFamInstEqn RdrName])) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LTyFamInstEqn RdrName])) +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: (Located [LTyFamInstEqn RdrName]) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> (Located [LTyFamInstEqn RdrName]) +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: (Located ([AddAnn],LTyFamInstEqn RdrName)) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> (Located ([AddAnn],LTyFamInstEqn RdrName)) +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyIn60 :: ([AddAnn]) -> (HappyAbsSyn ) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> ([AddAnn]) +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +happyIn61 :: (LInstDecl RdrName) -> (HappyAbsSyn ) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> (LInstDecl RdrName) +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +happyIn62 :: (Located (AddAnn,NewOrData)) -> (HappyAbsSyn ) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> (Located (AddAnn,NewOrData)) +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +happyIn63 :: (Located ([AddAnn],Maybe (LHsKind RdrName))) -> (HappyAbsSyn ) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> (Located ([AddAnn],Maybe (LHsKind RdrName))) +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +happyIn64 :: (Located (Maybe (LHsContext RdrName), LHsType RdrName)) -> (HappyAbsSyn ) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> (Located (Maybe (LHsContext RdrName), LHsType RdrName)) +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +happyIn65 :: (Maybe (Located CType)) -> (HappyAbsSyn ) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> (Maybe (Located CType)) +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +happyIn66 :: (LDerivDecl RdrName) -> (HappyAbsSyn ) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> (LDerivDecl RdrName) +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +happyIn67 :: (LRoleAnnotDecl RdrName) -> (HappyAbsSyn ) +happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn ) -> (LRoleAnnotDecl RdrName) +happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut67 #-} +happyIn68 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn ) -> (Located [Located (Maybe FastString)]) +happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut68 #-} +happyIn69 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn ) -> (Located [Located (Maybe FastString)]) +happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut69 #-} +happyIn70 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) +happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn ) -> (Located (Maybe FastString)) +happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut70 #-} +happyIn71 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut71 #-} +happyIn72 :: ((Located RdrName, HsPatSynDetails (Located RdrName))) -> (HappyAbsSyn ) +happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn ) -> ((Located RdrName, HsPatSynDetails (Located RdrName))) +happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut72 #-} +happyIn73 :: ([Located RdrName]) -> (HappyAbsSyn ) +happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn ) -> ([Located RdrName]) +happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut73 #-} +happyIn74 :: (Located ([AddAnn] + , Located (OrdList (LHsDecl RdrName)))) -> (HappyAbsSyn ) +happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn74 #-} +happyOut74 :: (HappyAbsSyn ) -> (Located ([AddAnn] + , Located (OrdList (LHsDecl RdrName)))) +happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut74 #-} +happyIn75 :: (LSig RdrName) -> (HappyAbsSyn ) +happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn75 #-} +happyOut75 :: (HappyAbsSyn ) -> (LSig RdrName) +happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut75 #-} +happyIn76 :: (Located ([AddAnn] + ,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName + , LHsContext RdrName, LHsType RdrName))) -> (HappyAbsSyn ) +happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn76 #-} +happyOut76 :: (HappyAbsSyn ) -> (Located ([AddAnn] + ,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName + , LHsContext RdrName, LHsType RdrName))) +happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut76 #-} +happyIn77 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn77 #-} +happyOut77 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut77 #-} +happyIn78 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn78 #-} +happyOut78 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) +happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut78 #-} +happyIn79 :: (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn79 #-} +happyOut79 :: (HappyAbsSyn ) -> (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) +happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut79 #-} +happyIn80 :: (Located ([AddAnn] + ,(OrdList (LHsDecl RdrName)))) -> (HappyAbsSyn ) +happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn80 #-} +happyOut80 :: (HappyAbsSyn ) -> (Located ([AddAnn] + ,(OrdList (LHsDecl RdrName)))) +happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut80 #-} +happyIn81 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn81 #-} +happyOut81 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut81 #-} +happyIn82 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn82 #-} +happyOut82 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) +happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut82 #-} +happyIn83 :: (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn83 #-} +happyOut83 :: (HappyAbsSyn ) -> (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) +happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut83 #-} +happyIn84 :: (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn84 #-} +happyOut84 :: (HappyAbsSyn ) -> (Located ([AddAnn] + , OrdList (LHsDecl RdrName))) +happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut84 #-} +happyIn85 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn85 #-} +happyOut85 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) +happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut85 #-} +happyIn86 :: (Located ([AddAnn],OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn86 #-} +happyOut86 :: (HappyAbsSyn ) -> (Located ([AddAnn],OrdList (LHsDecl RdrName))) +happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut86 #-} +happyIn87 :: (Located ([AddAnn],HsLocalBinds RdrName)) -> (HappyAbsSyn ) +happyIn87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn87 #-} +happyOut87 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsLocalBinds RdrName)) +happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut87 #-} +happyIn88 :: (Located ([AddAnn],HsLocalBinds RdrName)) -> (HappyAbsSyn ) +happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn88 #-} +happyOut88 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsLocalBinds RdrName)) +happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut88 #-} +happyIn89 :: (OrdList (LRuleDecl RdrName)) -> (HappyAbsSyn ) +happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn89 #-} +happyOut89 :: (HappyAbsSyn ) -> (OrdList (LRuleDecl RdrName)) +happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut89 #-} +happyIn90 :: (LRuleDecl RdrName) -> (HappyAbsSyn ) +happyIn90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn90 #-} +happyOut90 :: (HappyAbsSyn ) -> (LRuleDecl RdrName) +happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut90 #-} +happyIn91 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) +happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn91 #-} +happyOut91 :: (HappyAbsSyn ) -> (([AddAnn],Maybe Activation)) +happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut91 #-} +happyIn92 :: (([AddAnn] + ,Activation)) -> (HappyAbsSyn ) +happyIn92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn92 #-} +happyOut92 :: (HappyAbsSyn ) -> (([AddAnn] + ,Activation)) +happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut92 #-} +happyIn93 :: (([AddAnn],[LRuleBndr RdrName])) -> (HappyAbsSyn ) +happyIn93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn93 #-} +happyOut93 :: (HappyAbsSyn ) -> (([AddAnn],[LRuleBndr RdrName])) +happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut93 #-} +happyIn94 :: ([LRuleBndr RdrName]) -> (HappyAbsSyn ) +happyIn94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn94 #-} +happyOut94 :: (HappyAbsSyn ) -> ([LRuleBndr RdrName]) +happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut94 #-} +happyIn95 :: (LRuleBndr RdrName) -> (HappyAbsSyn ) +happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn95 #-} +happyOut95 :: (HappyAbsSyn ) -> (LRuleBndr RdrName) +happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut95 #-} +happyIn96 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) +happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn96 #-} +happyOut96 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) +happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut96 #-} +happyIn97 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) +happyIn97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn97 #-} +happyOut97 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) +happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut97 #-} +happyIn98 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) +happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn98 #-} +happyOut98 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) +happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut98 #-} +happyIn99 :: (OrdList (LWarnDecl RdrName)) -> (HappyAbsSyn ) +happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn99 #-} +happyOut99 :: (HappyAbsSyn ) -> (OrdList (LWarnDecl RdrName)) +happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut99 #-} +happyIn100 :: (Located ([AddAnn],[Located FastString])) -> (HappyAbsSyn ) +happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn100 #-} +happyOut100 :: (HappyAbsSyn ) -> (Located ([AddAnn],[Located FastString])) +happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut100 #-} +happyIn101 :: (Located (OrdList (Located FastString))) -> (HappyAbsSyn ) +happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn101 #-} +happyOut101 :: (HappyAbsSyn ) -> (Located (OrdList (Located FastString))) +happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut101 #-} +happyIn102 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn102 #-} +happyOut102 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut102 #-} +happyIn103 :: (Located ([AddAnn],HsDecl RdrName)) -> (HappyAbsSyn ) +happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn103 #-} +happyOut103 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsDecl RdrName)) +happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut103 #-} +happyIn104 :: (Located CCallConv) -> (HappyAbsSyn ) +happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn104 #-} +happyOut104 :: (HappyAbsSyn ) -> (Located CCallConv) +happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut104 #-} +happyIn105 :: (Located Safety) -> (HappyAbsSyn ) +happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn105 #-} +happyOut105 :: (HappyAbsSyn ) -> (Located Safety) +happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut105 #-} +happyIn106 :: (Located ([AddAnn] + ,(Located FastString, Located RdrName, LHsType RdrName))) -> (HappyAbsSyn ) +happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn106 #-} +happyOut106 :: (HappyAbsSyn ) -> (Located ([AddAnn] + ,(Located FastString, Located RdrName, LHsType RdrName))) +happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut106 #-} +happyIn107 :: (([AddAnn],Maybe (LHsType RdrName))) -> (HappyAbsSyn ) +happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn107 #-} +happyOut107 :: (HappyAbsSyn ) -> (([AddAnn],Maybe (LHsType RdrName))) +happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut107 #-} +happyIn108 :: (([AddAnn],Maybe (LHsType RdrName))) -> (HappyAbsSyn ) +happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn108 #-} +happyOut108 :: (HappyAbsSyn ) -> (([AddAnn],Maybe (LHsType RdrName))) +happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut108 #-} +happyIn109 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn109 #-} +happyOut109 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut109 #-} +happyIn110 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn110 #-} +happyOut110 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut110 #-} +happyIn111 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn111 #-} +happyOut111 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut111 #-} +happyIn112 :: ((OrdList (LHsType RdrName))) -> (HappyAbsSyn ) +happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn112 #-} +happyOut112 :: (HappyAbsSyn ) -> ((OrdList (LHsType RdrName))) +happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut112 #-} +happyIn113 :: (Located ([AddAnn],HsBang)) -> (HappyAbsSyn ) +happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn113 #-} +happyOut113 :: (HappyAbsSyn ) -> (Located ([AddAnn],HsBang)) +happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut113 #-} +happyIn114 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn114 #-} +happyOut114 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut114 #-} +happyIn115 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn115 #-} +happyOut115 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut115 #-} +happyIn116 :: (LHsContext RdrName) -> (HappyAbsSyn ) +happyIn116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn116 #-} +happyOut116 :: (HappyAbsSyn ) -> (LHsContext RdrName) +happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut116 #-} +happyIn117 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn117 #-} +happyOut117 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut117 #-} +happyIn118 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn118 #-} +happyOut118 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut118 #-} +happyIn119 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn119 #-} +happyOut119 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut119 #-} +happyIn120 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn120 #-} +happyOut120 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut120 #-} +happyIn121 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn121 #-} +happyOut121 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut121 #-} +happyIn122 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn122 #-} +happyOut122 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut122 #-} +happyIn123 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn123 #-} +happyOut123 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut123 #-} +happyIn124 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn124 #-} +happyOut124 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut124 #-} +happyIn125 :: ([LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) +happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn125 #-} +happyOut125 :: (HappyAbsSyn ) -> ([LHsTyVarBndr RdrName]) +happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut125 #-} +happyIn126 :: (LHsTyVarBndr RdrName) -> (HappyAbsSyn ) +happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn126 #-} +happyOut126 :: (HappyAbsSyn ) -> (LHsTyVarBndr RdrName) +happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut126 #-} +happyIn127 :: (Located ([AddAnn],[Located (FunDep (Located RdrName))])) -> (HappyAbsSyn ) +happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn127 #-} +happyOut127 :: (HappyAbsSyn ) -> (Located ([AddAnn],[Located (FunDep (Located RdrName))])) +happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut127 #-} +happyIn128 :: (Located [Located (FunDep (Located RdrName))]) -> (HappyAbsSyn ) +happyIn128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn128 #-} +happyOut128 :: (HappyAbsSyn ) -> (Located [Located (FunDep (Located RdrName))]) +happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut128 #-} +happyIn129 :: (Located (FunDep (Located RdrName))) -> (HappyAbsSyn ) +happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn129 #-} +happyOut129 :: (HappyAbsSyn ) -> (Located (FunDep (Located RdrName))) +happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut129 #-} +happyIn130 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn130 #-} +happyOut130 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut130 #-} +happyIn131 :: (LHsKind RdrName) -> (HappyAbsSyn ) +happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn131 #-} +happyOut131 :: (HappyAbsSyn ) -> (LHsKind RdrName) +happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut131 #-} +happyIn132 :: (LHsKind RdrName) -> (HappyAbsSyn ) +happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn132 #-} +happyOut132 :: (HappyAbsSyn ) -> (LHsKind RdrName) +happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut132 #-} +happyIn133 :: (LHsKind RdrName) -> (HappyAbsSyn ) +happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn133 #-} +happyOut133 :: (HappyAbsSyn ) -> (LHsKind RdrName) +happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut133 #-} +happyIn134 :: (LHsKind RdrName) -> (HappyAbsSyn ) +happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn134 #-} +happyOut134 :: (HappyAbsSyn ) -> (LHsKind RdrName) +happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut134 #-} +happyIn135 :: ([LHsKind RdrName]) -> (HappyAbsSyn ) +happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn135 #-} +happyOut135 :: (HappyAbsSyn ) -> ([LHsKind RdrName]) +happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut135 #-} +happyIn136 :: (Located ([AddAnn] + ,[LConDecl RdrName])) -> (HappyAbsSyn ) +happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn136 #-} +happyOut136 :: (HappyAbsSyn ) -> (Located ([AddAnn] + ,[LConDecl RdrName])) +happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut136 #-} +happyIn137 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn137 #-} +happyOut137 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) +happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut137 #-} +happyIn138 :: (LConDecl RdrName) -> (HappyAbsSyn ) +happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn138 #-} +happyOut138 :: (HappyAbsSyn ) -> (LConDecl RdrName) +happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut138 #-} +happyIn139 :: (Located ([AddAnn],[LConDecl RdrName])) -> (HappyAbsSyn ) +happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn139 #-} +happyOut139 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LConDecl RdrName])) +happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut139 #-} +happyIn140 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn140 #-} +happyOut140 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) +happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut140 #-} +happyIn141 :: (LConDecl RdrName) -> (HappyAbsSyn ) +happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn141 #-} +happyOut141 :: (HappyAbsSyn ) -> (LConDecl RdrName) +happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut141 #-} +happyIn142 :: (Located ([AddAnn],[LHsTyVarBndr RdrName])) -> (HappyAbsSyn ) +happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn142 #-} +happyOut142 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LHsTyVarBndr RdrName])) +happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut142 #-} +happyIn143 :: (Located (Located RdrName, HsConDeclDetails RdrName)) -> (HappyAbsSyn ) +happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn143 #-} +happyOut143 :: (HappyAbsSyn ) -> (Located (Located RdrName, HsConDeclDetails RdrName)) +happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut143 #-} +happyIn144 :: ([LConDeclField RdrName]) -> (HappyAbsSyn ) +happyIn144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn144 #-} +happyOut144 :: (HappyAbsSyn ) -> ([LConDeclField RdrName]) +happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut144 #-} +happyIn145 :: ([LConDeclField RdrName]) -> (HappyAbsSyn ) +happyIn145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn145 #-} +happyOut145 :: (HappyAbsSyn ) -> ([LConDeclField RdrName]) +happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut145 #-} +happyIn146 :: (LConDeclField RdrName) -> (HappyAbsSyn ) +happyIn146 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn146 #-} +happyOut146 :: (HappyAbsSyn ) -> (LConDeclField RdrName) +happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut146 #-} +happyIn147 :: (Located (Maybe (Located [LHsType RdrName]))) -> (HappyAbsSyn ) +happyIn147 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn147 #-} +happyOut147 :: (HappyAbsSyn ) -> (Located (Maybe (Located [LHsType RdrName]))) +happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut147 #-} +happyIn148 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn148 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn148 #-} +happyOut148 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut148 #-} +happyIn149 :: (LDocDecl) -> (HappyAbsSyn ) +happyIn149 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn149 #-} +happyOut149 :: (HappyAbsSyn ) -> (LDocDecl) +happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut149 #-} +happyIn150 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn150 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn150 #-} +happyOut150 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut150 #-} +happyIn151 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn151 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn151 #-} +happyOut151 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut151 #-} +happyIn152 :: (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) +happyIn152 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn152 #-} +happyOut152 :: (HappyAbsSyn ) -> (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) +happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut152 #-} +happyIn153 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn153 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn153 #-} +happyOut153 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) +happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut153 #-} +happyIn154 :: (LGRHS RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn154 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn154 #-} +happyOut154 :: (HappyAbsSyn ) -> (LGRHS RdrName (LHsExpr RdrName)) +happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut154 #-} +happyIn155 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn155 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn155 #-} +happyOut155 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut155 #-} +happyIn156 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) +happyIn156 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn156 #-} +happyOut156 :: (HappyAbsSyn ) -> (([AddAnn],Maybe Activation)) +happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut156 #-} +happyIn157 :: (([AddAnn],Activation)) -> (HappyAbsSyn ) +happyIn157 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn157 #-} +happyOut157 :: (HappyAbsSyn ) -> (([AddAnn],Activation)) +happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut157 #-} +happyIn158 :: (Located (HsQuasiQuote RdrName)) -> (HappyAbsSyn ) +happyIn158 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn158 #-} +happyOut158 :: (HappyAbsSyn ) -> (Located (HsQuasiQuote RdrName)) +happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut158 #-} +happyIn159 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn159 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn159 #-} +happyOut159 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut159 #-} +happyIn160 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn160 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn160 #-} +happyOut160 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut160 #-} +happyIn161 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn161 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn161 #-} +happyOut161 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut161 #-} +happyIn162 :: (([Located a],Bool)) -> (HappyAbsSyn ) +happyIn162 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn162 #-} +happyOut162 :: (HappyAbsSyn ) -> (([Located a],Bool)) +happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut162 #-} +happyIn163 :: (Located (([AddAnn],SourceText),FastString)) -> (HappyAbsSyn ) +happyIn163 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn163 #-} +happyOut163 :: (HappyAbsSyn ) -> (Located (([AddAnn],SourceText),FastString)) +happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut163 #-} +happyIn164 :: (Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int)))) -> (HappyAbsSyn ) +happyIn164 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn164 #-} +happyOut164 :: (HappyAbsSyn ) -> (Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int)))) +happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut164 #-} +happyIn165 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn165 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn165 #-} +happyOut165 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut165 #-} +happyIn166 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn166 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn166 #-} +happyOut166 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut166 #-} +happyIn167 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn167 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn167 #-} +happyOut167 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut167 #-} +happyIn168 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn168 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn168 #-} +happyOut168 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut168 #-} +happyIn169 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn169 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn169 #-} +happyOut169 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut169 #-} +happyIn170 :: ([LHsCmdTop RdrName]) -> (HappyAbsSyn ) +happyIn170 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn170 #-} +happyOut170 :: (HappyAbsSyn ) -> ([LHsCmdTop RdrName]) +happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut170 #-} +happyIn171 :: (LHsCmdTop RdrName) -> (HappyAbsSyn ) +happyIn171 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn171 #-} +happyOut171 :: (HappyAbsSyn ) -> (LHsCmdTop RdrName) +happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut171 #-} +happyIn172 :: (([AddAnn],[LHsDecl RdrName])) -> (HappyAbsSyn ) +happyIn172 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn172 #-} +happyOut172 :: (HappyAbsSyn ) -> (([AddAnn],[LHsDecl RdrName])) +happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut172 #-} +happyIn173 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) +happyIn173 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn173 #-} +happyOut173 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) +happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut173 #-} +happyIn174 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn174 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn174 #-} +happyOut174 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut174 #-} +happyIn175 :: ([LHsTupArg RdrName]) -> (HappyAbsSyn ) +happyIn175 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn175 #-} +happyOut175 :: (HappyAbsSyn ) -> ([LHsTupArg RdrName]) +happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut175 #-} +happyIn176 :: ((SrcSpan,[LHsTupArg RdrName])) -> (HappyAbsSyn ) +happyIn176 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn176 #-} +happyOut176 :: (HappyAbsSyn ) -> ((SrcSpan,[LHsTupArg RdrName])) +happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut176 #-} +happyIn177 :: ([LHsTupArg RdrName]) -> (HappyAbsSyn ) +happyIn177 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn177 #-} +happyOut177 :: (HappyAbsSyn ) -> ([LHsTupArg RdrName]) +happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut177 #-} +happyIn178 :: (([AddAnn],HsExpr RdrName)) -> (HappyAbsSyn ) +happyIn178 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn178 #-} +happyOut178 :: (HappyAbsSyn ) -> (([AddAnn],HsExpr RdrName)) +happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut178 #-} +happyIn179 :: (Located [LHsExpr RdrName]) -> (HappyAbsSyn ) +happyIn179 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn179 #-} +happyOut179 :: (HappyAbsSyn ) -> (Located [LHsExpr RdrName]) +happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut179 #-} +happyIn180 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn180 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn180 #-} +happyOut180 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) +happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut180 #-} +happyIn181 :: (Located [[LStmt RdrName (LHsExpr RdrName)]]) -> (HappyAbsSyn ) +happyIn181 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn181 #-} +happyOut181 :: (HappyAbsSyn ) -> (Located [[LStmt RdrName (LHsExpr RdrName)]]) +happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut181 #-} +happyIn182 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn182 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn182 #-} +happyOut182 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) +happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut182 #-} +happyIn183 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) +happyIn183 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn183 #-} +happyOut183 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName))) +happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut183 #-} +happyIn184 :: (([AddAnn],HsExpr RdrName)) -> (HappyAbsSyn ) +happyIn184 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn184 #-} +happyOut184 :: (HappyAbsSyn ) -> (([AddAnn],HsExpr RdrName)) +happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut184 #-} +happyIn185 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn185 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn185 #-} +happyOut185 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) +happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut185 #-} +happyIn186 :: (Located [LStmt RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn186 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn186 #-} +happyOut186 :: (HappyAbsSyn ) -> (Located [LStmt RdrName (LHsExpr RdrName)]) +happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut186 #-} +happyIn187 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn187 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn187 #-} +happyOut187 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) +happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut187 #-} +happyIn188 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn188 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn188 #-} +happyOut188 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) +happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut188 #-} +happyIn189 :: (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn189 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn189 #-} +happyOut189 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)])) +happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut189 #-} +happyIn190 :: (LMatch RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn190 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn190 #-} +happyOut190 :: (HappyAbsSyn ) -> (LMatch RdrName (LHsExpr RdrName)) +happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut190 #-} +happyIn191 :: (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) +happyIn191 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn191 #-} +happyOut191 :: (HappyAbsSyn ) -> (Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName))) +happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut191 #-} +happyIn192 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn192 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn192 #-} +happyOut192 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) +happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut192 #-} +happyIn193 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn193 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn193 #-} +happyOut193 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) +happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut193 #-} +happyIn194 :: (Located [LGRHS RdrName (LHsExpr RdrName)]) -> (HappyAbsSyn ) +happyIn194 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn194 #-} +happyOut194 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName (LHsExpr RdrName)]) +happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut194 #-} +happyIn195 :: (Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn195 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn195 #-} +happyOut195 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)])) +happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut195 #-} +happyIn196 :: (LGRHS RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn196 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn196 #-} +happyOut196 :: (HappyAbsSyn ) -> (LGRHS RdrName (LHsExpr RdrName)) +happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut196 #-} +happyIn197 :: (LPat RdrName) -> (HappyAbsSyn ) +happyIn197 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn197 #-} +happyOut197 :: (HappyAbsSyn ) -> (LPat RdrName) +happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut197 #-} +happyIn198 :: (LPat RdrName) -> (HappyAbsSyn ) +happyIn198 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn198 #-} +happyOut198 :: (HappyAbsSyn ) -> (LPat RdrName) +happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut198 #-} +happyIn199 :: (LPat RdrName) -> (HappyAbsSyn ) +happyIn199 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn199 #-} +happyOut199 :: (HappyAbsSyn ) -> (LPat RdrName) +happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut199 #-} +happyIn200 :: ([LPat RdrName]) -> (HappyAbsSyn ) +happyIn200 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn200 #-} +happyOut200 :: (HappyAbsSyn ) -> ([LPat RdrName]) +happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut200 #-} +happyIn201 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn201 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn201 #-} +happyOut201 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) +happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut201 #-} +happyIn202 :: (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) -> (HappyAbsSyn ) +happyIn202 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn202 #-} +happyOut202 :: (HappyAbsSyn ) -> (Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)])) +happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut202 #-} +happyIn203 :: (Maybe (LStmt RdrName (LHsExpr RdrName))) -> (HappyAbsSyn ) +happyIn203 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn203 #-} +happyOut203 :: (HappyAbsSyn ) -> (Maybe (LStmt RdrName (LHsExpr RdrName))) +happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut203 #-} +happyIn204 :: (LStmt RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn204 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn204 #-} +happyOut204 :: (HappyAbsSyn ) -> (LStmt RdrName (LHsExpr RdrName)) +happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut204 #-} +happyIn205 :: (LStmt RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn205 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn205 #-} +happyOut205 :: (HappyAbsSyn ) -> (LStmt RdrName (LHsExpr RdrName)) +happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut205 #-} +happyIn206 :: (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -> (HappyAbsSyn ) +happyIn206 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn206 #-} +happyOut206 :: (HappyAbsSyn ) -> (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) +happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut206 #-} +happyIn207 :: (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) -> (HappyAbsSyn ) +happyIn207 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn207 #-} +happyOut207 :: (HappyAbsSyn ) -> (([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool))) +happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut207 #-} +happyIn208 :: (LHsRecField RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn208 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn208 #-} +happyOut208 :: (HappyAbsSyn ) -> (LHsRecField RdrName (LHsExpr RdrName)) +happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut208 #-} +happyIn209 :: (Located [LIPBind RdrName]) -> (HappyAbsSyn ) +happyIn209 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn209 #-} +happyOut209 :: (HappyAbsSyn ) -> (Located [LIPBind RdrName]) +happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut209 #-} +happyIn210 :: (LIPBind RdrName) -> (HappyAbsSyn ) +happyIn210 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn210 #-} +happyOut210 :: (HappyAbsSyn ) -> (LIPBind RdrName) +happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut210 #-} +happyIn211 :: (Located HsIPName) -> (HappyAbsSyn ) +happyIn211 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn211 #-} +happyOut211 :: (HappyAbsSyn ) -> (Located HsIPName) +happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut211 #-} +happyIn212 :: (([AddAnn],BooleanFormula (Located RdrName))) -> (HappyAbsSyn ) +happyIn212 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn212 #-} +happyOut212 :: (HappyAbsSyn ) -> (([AddAnn],BooleanFormula (Located RdrName))) +happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut212 #-} +happyIn213 :: (([AddAnn],BooleanFormula (Located RdrName))) -> (HappyAbsSyn ) +happyIn213 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn213 #-} +happyOut213 :: (HappyAbsSyn ) -> (([AddAnn],BooleanFormula (Located RdrName))) +happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut213 #-} +happyIn214 :: (([AddAnn],BooleanFormula (Located RdrName))) -> (HappyAbsSyn ) +happyIn214 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn214 #-} +happyOut214 :: (HappyAbsSyn ) -> (([AddAnn],BooleanFormula (Located RdrName))) +happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut214 #-} +happyIn215 :: (([AddAnn],BooleanFormula (Located RdrName))) -> (HappyAbsSyn ) +happyIn215 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn215 #-} +happyOut215 :: (HappyAbsSyn ) -> (([AddAnn],BooleanFormula (Located RdrName))) +happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut215 #-} +happyIn216 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn216 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn216 #-} +happyOut216 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut216 #-} +happyIn217 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn217 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn217 #-} +happyOut217 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut217 #-} +happyIn218 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn218 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn218 #-} +happyOut218 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut218 #-} +happyIn219 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn219 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn219 #-} +happyOut219 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut219 #-} +happyIn220 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn220 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn220 #-} +happyOut220 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut220 #-} +happyIn221 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn221 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn221 #-} +happyOut221 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut221 #-} +happyIn222 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn222 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn222 #-} +happyOut222 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut222 #-} +happyIn223 :: (Located DataCon) -> (HappyAbsSyn ) +happyIn223 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn223 #-} +happyOut223 :: (HappyAbsSyn ) -> (Located DataCon) +happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut223 #-} +happyIn224 :: (Located DataCon) -> (HappyAbsSyn ) +happyIn224 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn224 #-} +happyOut224 :: (HappyAbsSyn ) -> (Located DataCon) +happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut224 #-} +happyIn225 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn225 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn225 #-} +happyOut225 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut225 #-} +happyIn226 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn226 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn226 #-} +happyOut226 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut226 #-} +happyIn227 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn227 #-} +happyOut227 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut227 #-} +happyIn228 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn228 #-} +happyOut228 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut228 #-} +happyIn229 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn229 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn229 #-} +happyOut229 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut229 #-} +happyIn230 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn230 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn230 #-} +happyOut230 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut230 #-} +happyIn231 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn231 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn231 #-} +happyOut231 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut231 #-} +happyIn232 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn232 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn232 #-} +happyOut232 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut232 #-} +happyIn233 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn233 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn233 #-} +happyOut233 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut233 #-} +happyIn234 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn234 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn234 #-} +happyOut234 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut234 #-} +happyIn235 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn235 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn235 #-} +happyOut235 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut235 #-} +happyIn236 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn236 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn236 #-} +happyOut236 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut236 #-} +happyIn237 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn237 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn237 #-} +happyOut237 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut237 #-} +happyIn238 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn238 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn238 #-} +happyOut238 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut238 #-} +happyIn239 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn239 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn239 #-} +happyOut239 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut239 #-} +happyIn240 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn240 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn240 #-} +happyOut240 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut240 #-} +happyIn241 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn241 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn241 #-} +happyOut241 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut241 #-} +happyIn242 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn242 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn242 #-} +happyOut242 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut242 #-} +happyIn243 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn243 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn243 #-} +happyOut243 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut243 #-} +happyIn244 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn244 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn244 #-} +happyOut244 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut244 #-} +happyIn245 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn245 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn245 #-} +happyOut245 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut245 #-} +happyIn246 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn246 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn246 #-} +happyOut246 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut246 #-} +happyIn247 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn247 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn247 #-} +happyOut247 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut247 #-} +happyIn248 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn248 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn248 #-} +happyOut248 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut248 #-} +happyIn249 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn249 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn249 #-} +happyOut249 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut249 #-} +happyIn250 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn250 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn250 #-} +happyOut250 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut250 #-} +happyIn251 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn251 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn251 #-} +happyOut251 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut251 #-} +happyIn252 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn252 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn252 #-} +happyOut252 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut252 #-} +happyIn253 :: (Located FastString) -> (HappyAbsSyn ) +happyIn253 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn253 #-} +happyOut253 :: (HappyAbsSyn ) -> (Located FastString) +happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut253 #-} +happyIn254 :: (Located FastString) -> (HappyAbsSyn ) +happyIn254 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn254 #-} +happyOut254 :: (HappyAbsSyn ) -> (Located FastString) +happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut254 #-} +happyIn255 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn255 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn255 #-} +happyOut255 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut255 #-} +happyIn256 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn256 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn256 #-} +happyOut256 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut256 #-} +happyIn257 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn257 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn257 #-} +happyOut257 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut257 #-} +happyIn258 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn258 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn258 #-} +happyOut258 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut258 #-} +happyIn259 :: (Located HsLit) -> (HappyAbsSyn ) +happyIn259 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn259 #-} +happyOut259 :: (HappyAbsSyn ) -> (Located HsLit) +happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut259 #-} +happyIn260 :: (()) -> (HappyAbsSyn ) +happyIn260 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn260 #-} +happyOut260 :: (HappyAbsSyn ) -> (()) +happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut260 #-} +happyIn261 :: (Located ModuleName) -> (HappyAbsSyn ) +happyIn261 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn261 #-} +happyOut261 :: (HappyAbsSyn ) -> (Located ModuleName) +happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut261 #-} +happyIn262 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) +happyIn262 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn262 #-} +happyOut262 :: (HappyAbsSyn ) -> (([SrcSpan],Int)) +happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut262 #-} +happyIn263 :: (LHsDocString) -> (HappyAbsSyn ) +happyIn263 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn263 #-} +happyOut263 :: (HappyAbsSyn ) -> (LHsDocString) +happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut263 #-} +happyIn264 :: (LHsDocString) -> (HappyAbsSyn ) +happyIn264 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn264 #-} +happyOut264 :: (HappyAbsSyn ) -> (LHsDocString) +happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut264 #-} +happyIn265 :: (Located (String, HsDocString)) -> (HappyAbsSyn ) +happyIn265 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn265 #-} +happyOut265 :: (HappyAbsSyn ) -> (Located (String, HsDocString)) +happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut265 #-} +happyIn266 :: (Located (Int, HsDocString)) -> (HappyAbsSyn ) +happyIn266 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn266 #-} +happyOut266 :: (HappyAbsSyn ) -> (Located (Int, HsDocString)) +happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut266 #-} +happyIn267 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn267 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn267 #-} +happyOut267 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut267 #-} +happyIn268 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn268 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn268 #-} +happyOut268 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut268 #-} +happyIn269 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn269 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn269 #-} +happyOut269 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut269 #-} +happyInTok :: ((Located Token)) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x26\x00\x5b\x08\x3a\x2e\xe8\x20\xe2\x32\x23\x31\x0e\x29\x3a\x2e\x3a\x2e\x3f\x4a\x06\x46\x25\x00\xf2\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x03\x00\x00\x00\x00\x00\x00\x52\x08\x58\x08\x63\x08\x00\x00\x00\x00\x56\x08\x00\x00\x6a\x49\xcb\x07\x0c\x08\x00\x00\xf2\x38\x00\x00\x00\x00\x14\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x50\x00\x00\x00\x00\x00\x00\x0d\x08\x0b\x08\x00\x00\xf7\xff\x4e\x3d\xd2\x3c\x7e\x37\x66\x3a\x18\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x32\x00\x00\x00\x00\xbd\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x07\x08\x10\x8c\x03\x4b\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x07\x98\x10\x00\x00\xe2\x32\xe2\x32\xfa\x35\x00\x00\xed\x07\x00\x00\x00\x00\xfa\x07\xb5\x07\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x07\x00\x00\x00\x00\xe2\x32\x91\x04\xa5\x2d\x7c\x04\x52\x04\xfa\x35\x52\x04\xfa\x35\xc8\x07\x88\x01\xc4\x07\x66\x33\xfa\x35\x6e\x34\xfa\x35\xe4\x27\x79\x28\xba\x26\x25\x26\x7e\x36\xeb\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x32\xe2\x32\x06\x46\x43\x04\xe2\x32\x00\x00\xe2\x32\x00\x00\xe2\x32\xd8\x4c\xaf\x07\xc0\x07\x00\x00\xa7\x07\x5c\x1c\xcc\x07\xc3\x07\x00\x00\x00\x00\x00\x00\x3f\x04\xf8\x01\xd0\x07\x37\x00\xd0\x07\x8e\x4f\x90\x25\x00\x00\x95\x07\xfa\x35\x95\x07\x95\x07\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x49\x07\x08\xc7\x07\x18\x08\xe7\x04\x00\x00\x56\x3c\x4e\x00\x6e\x4f\xad\x07\x16\x4f\x16\x4f\x7e\x4e\x8e\x4d\x00\x08\xf2\x4d\xfa\x35\x00\x00\x00\x00\x00\x00\x00\x00\x91\x07\x91\x07\xe5\x07\x88\x07\x02\x08\x53\x20\x00\x00\x53\x20\xb8\x07\x00\x00\xa9\x07\x00\x00\xa4\x07\x00\x00\x18\x00\x7c\x03\xef\x07\xc6\x07\x29\x03\xc5\x07\x4a\x08\xbc\x07\x4a\x08\x4a\x08\xfa\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x35\x96\x07\x64\x0f\x93\x00\x00\x00\xd2\x00\x99\x07\x90\x00\x00\x00\xd2\x00\x7c\x00\x00\x00\xa2\x07\x95\x03\x7a\x50\x00\x01\x6d\x01\x00\x00\x43\x05\x43\x05\xb7\x07\x6e\x39\x6a\x49\x6a\x49\xd9\x02\x06\x46\xb6\x07\xb4\x07\xb3\x07\xb2\x07\xe7\x04\x06\x46\x6a\x49\xa6\x07\x9f\x07\x00\x00\x29\x03\x00\x00\xe2\x32\x00\x00\x8a\x45\x6a\x49\xac\x07\x74\x07\x00\x00\x9c\x07\x98\x10\xc2\x02\x83\x07\x00\x00\xe2\x32\x00\x00\x00\x00\x82\x07\x7f\x07\x79\x07\x78\x07\xfb\x24\x6e\x34\x00\x00\x00\x00\x4b\x4c\x92\x07\x00\x00\x81\x07\x6b\x07\x00\x00\x1e\x4e\xf2\x4d\x00\x00\x1f\x00\xf2\x4d\x0e\x45\xf2\x4d\x80\x07\x00\x00\xbb\x07\xd1\x23\xd1\x23\x5a\x50\x92\x44\xb3\x04\x00\x00\x00\x00\x00\x00\x00\x00\x63\x07\x5d\x07\x8b\x1c\x55\x03\x58\x07\x55\x07\x25\x07\x31\x07\xe8\x20\xe8\x20\x2b\x07\xf7\x0a\x28\x07\x00\x00\x00\x00\xe9\x05\x00\x00\x00\x00\x54\x03\x4a\x07\x00\x00\x00\x00\x66\x24\x00\x00\x49\x07\xa8\x01\x40\x07\x3f\x07\xe7\x00\x3c\x07\x27\x07\x00\x00\x00\x00\xfa\x35\x00\x00\x00\x00\xea\x33\x30\x04\xfa\x35\x1f\x07\x53\x07\x52\x07\x4d\x07\x00\x00\x00\x00\x10\x2d\x10\x2d\x42\x07\x00\x00\x84\x07\x21\x07\x16\x00\x00\x00\x21\x07\x8e\x30\x3d\x07\x00\x00\x73\x07\xfa\x35\xe2\x32\xc2\x4d\x00\x00\x00\x00\x00\x00\x16\x44\xe2\x32\xe2\x32\xe2\x32\xe2\x32\x1d\x07\x1a\x07\x3d\x03\x1e\x07\x1c\x07\xb9\x02\x1b\x07\x19\x07\x00\x00\x00\x00\x00\x00\x00\x00\x16\x44\x76\x38\x14\x07\x11\x07\x1c\x03\x00\x00\x17\x01\x18\x07\x00\x00\xa9\x02\x12\x07\x0f\x07\x0c\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x07\x00\x00\xb9\x01\x00\x00\x13\x07\x00\x00\xd9\x00\x00\x00\x5a\x50\x17\x07\x16\x07\x04\x07\xe8\x50\x00\x00\x0e\x48\x6a\x49\x00\x00\x6a\x49\x00\x00\x6a\x49\x16\x44\x6a\x49\x00\x00\x17\x47\xa3\x4a\x16\x44\x00\x00\xef\x06\xef\x06\xf0\x02\x47\x05\x00\x00\x00\x00\x4c\x07\x00\x00\x6a\x49\x6a\x49\x00\x00\x65\x4d\xf6\x06\xf2\x06\xee\x48\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x07\x00\x00\x16\x44\x00\x00\x00\x00\x61\x00\x00\x00\x27\x02\xf8\x06\x00\x00\x00\x00\x16\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x4d\x00\x00\x16\x44\x00\x00\x00\x00\x16\x44\xe9\x06\xee\x06\xec\x06\xf1\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x06\x00\x00\xe4\x06\x00\x07\x00\x00\x00\x00\x00\x00\x30\x04\x72\x00\xfd\x06\xe3\x06\x00\x00\x00\x00\x00\x00\xdf\x06\x00\x00\x00\x00\x00\x00\x2f\x07\xe2\x32\xe2\x32\xb3\x01\x00\x00\x9f\x01\xe2\x32\x00\x00\x00\x00\xfb\x06\x00\x00\x00\x00\xa3\x29\x85\x1f\xea\x33\xed\x06\x79\x28\x00\x00\xe2\x32\x7b\x2c\x79\x28\x00\x00\xe2\x32\x7b\x2c\x79\x28\x00\x00\xca\x06\x00\x00\x00\x00\x00\x00\x4f\x27\x00\x00\x76\x35\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\xe5\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x06\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x4f\x00\x00\x00\x00\xde\x06\x00\x00\xfa\x37\xeb\x06\xe8\x50\x14\x00\x93\x01\x00\x00\x00\x00\x8e\x0a\xe6\x2b\x77\x01\x00\x00\xe8\x06\x71\x01\x5b\x01\x72\x48\xea\x06\x00\x00\xe1\x06\xd9\x06\xa6\x06\xbe\x06\xd5\x06\xb8\x06\xb3\x06\xf6\x4e\xf6\x4e\x00\x00\xab\x06\xaa\x06\x0b\x13\x00\x00\x00\x00\xe2\x32\x79\x28\x32\x00\x6a\x49\x24\x00\x00\x00\xc3\x06\x02\x37\xc7\x06\xe8\x50\x00\x00\x00\x00\x2e\x00\x00\x00\xe2\x32\x8e\x30\x6a\x49\xf7\x06\x00\x00\xc5\x06\xa7\x06\x16\x44\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x06\x12\x00\x8d\x05\xbd\x06\x00\x00\xba\x06\x6a\x49\x9a\x43\x12\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x49\xb0\x50\x94\x06\x00\x00\xb0\x50\xf9\x2f\xf9\x2f\xdc\x06\x00\x00\xef\xff\x00\x00\x88\x06\x00\x00\x82\x06\x00\x00\x00\x00\x9e\x4e\x9e\x4e\x00\x00\x00\x00\x9e\x4e\xf2\x34\xb7\x06\xb4\x06\x2f\x03\xb2\x06\xe2\x32\x13\x03\x00\x00\x00\x00\x00\x00\xe2\x06\x00\x00\x47\x05\x00\x00\xe8\x20\x53\x20\x00\x00\x00\x00\x00\x00\x00\x00\x90\x06\xd2\x00\xd2\x00\x7c\x06\x00\x00\x00\x00\x4a\x08\xad\x06\x00\x00\x00\x00\x4a\x08\x00\x00\x00\x00\xac\x06\x00\x00\x00\x00\x00\x00\x81\x01\x00\x00\x00\x00\x57\x00\x8d\x06\xe2\x32\x26\x50\xc6\x06\x00\x00\x00\x00\x7f\x06\x00\x00\x92\x49\x00\x00\x9e\x06\x9a\x06\x93\x06\x92\x06\x06\x50\x00\x00\x00\x00\x6a\x49\x1e\x43\xc2\x06\x08\x4d\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x04\x00\x00\x00\x00\x00\x00\x6d\x06\x00\x00\x92\x47\x00\x00\x0a\x04\x00\x00\x8a\x06\xb6\x06\x00\x00\x00\x00\xfb\x03\x72\x06\x6a\x49\x6a\x49\x6a\x49\x7a\x06\xa2\x42\x6a\x49\xa3\x4a\xa2\x42\xaf\x06\xc0\x06\x78\x06\x24\x00\x00\x00\x79\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x42\x00\x00\x57\x06\x26\x42\x00\x00\x00\x00\x00\x00\x62\x06\x00\x00\xd0\x50\x00\x00\x45\x06\x00\x00\xd1\x23\xe2\x32\x00\x00\x00\x00\xaa\x41\x06\x50\x60\x06\x6a\x49\x6a\x49\x6a\x49\xaa\x41\x6a\x49\xa3\x4a\xaa\x41\x40\x06\xb3\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x4d\x32\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x58\x06\x6a\x49\x00\x00\x18\x00\x3a\x06\x00\x00\x5a\x06\x00\x00\x62\x2b\x3f\x06\x00\x00\x19\x06\x00\x00\x00\x00\xcd\x2a\x00\x00\x00\x00\x00\x00\xb8\x31\x00\x00\x64\x2f\xb8\x31\x00\x00\x00\x00\x79\x28\xc2\x4d\x00\x00\x00\x00\x00\x00\x2e\x41\x00\x00\x3d\x06\x38\x06\xab\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x4d\x78\x4c\x39\x06\x17\x06\x2e\x41\x00\x00\x08\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x31\x06\x7b\x06\x4e\x03\x2c\x06\x07\x06\x00\x00\x06\x06\x00\x00\x93\x02\x00\x00\x29\x06\x00\x00\x08\x4d\x00\x00\x00\x00\x23\x06\x00\x00\x00\x00\x00\x00\x00\x00\x26\x06\x00\x00\x33\x06\x00\x00\x00\x00\xdf\x03\x2e\x41\xcf\x2e\x00\x00\x00\x00\xb8\x31\xb8\x31\x56\x06\x22\x05\x38\x2a\x38\x2a\xb8\x31\x00\x00\x00\x00\x00\x00\x6a\x49\x6a\x49\xf6\x47\x00\x00\xf8\x05\xf8\x05\x00\x00\xb2\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x06\x20\x06\x6a\x49\x0f\x06\x32\x06\x00\x00\x30\x06\x00\x00\x5d\x06\x6b\x06\xf4\x05\x00\x00\x71\x02\x67\x06\xae\x03\x6a\x49\x6a\x49\xda\x3b\xb2\x40\x22\x00\xff\xff\x1f\x03\x36\x40\x00\x00\x00\x00\xb8\x31\x00\x00\x3c\x23\x3c\x23\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x22\xa7\x22\x00\x00\x00\x00\x00\x00\x84\x03\x00\x00\x2a\x06\xba\x3f\x00\x00\x00\x00\x00\x00\xeb\x02\x11\x06\x9a\x48\x00\x00\xb0\x50\xb5\x12\x00\x00\x00\x00\x03\x06\x00\x00\xe6\x05\x00\x00\x21\x06\x00\x00\x1b\x06\xdf\x02\x00\x00\x16\x06\x10\x06\x3b\x06\xbf\x02\x00\x00\x00\x00\x4e\x06\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x31\x04\x06\x00\x00\x00\x00\xd1\x23\xd1\x23\x00\x00\xba\x3f\x00\x00\x7a\x47\xfe\x46\x00\x00\x0a\x06\x00\x00\x58\x01\x00\x00\x00\x00\x6a\x49\x49\x01\x00\x00\x0e\x48\x00\x00\x00\x00\x57\x01\x00\x00\x1f\x06\xb8\x31\x3e\x3f\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x02\x21\x02\x71\x06\x71\x06\x00\x00\x00\x00\x5e\x3b\x02\x00\x00\x00\x2f\x06\x00\x00\x36\x06\x00\x00\x00\x00\xc2\x3e\xf3\x05\x00\x00\x82\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x31\xb8\x31\xb8\x31\x00\x00\x00\x00\x00\x00\x00\x00\x28\x06\xee\x05\x00\x00\xb8\x31\xbf\x05\x24\x06\x00\x00\x00\x00\x00\x00\x00\x00\x08\x4d\x00\x00\x00\x00\x00\x00\xc6\x05\x00\x00\x07\x4b\x4e\x03\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x1e\x06\x1e\x06\x00\x00\x4e\x03\xc4\x05\x00\x00\xdf\x02\xeb\x4b\xec\x05\x4e\x03\x00\x00\xbc\x05\xbd\x05\xb8\x31\xd9\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x05\x00\x00\x6a\x49\x00\x00\x00\x00\x6a\x49\xd0\x50\xc8\x05\xb5\x05\xb4\x05\x00\x00\x18\x00\xae\x05\xab\x05\xc9\x05\xb3\x05\xa9\x0b\xb2\x05\xb0\x05\x00\x00\x12\x22\x00\x00\xfd\x04\x6a\x49\x6a\x49\xe4\x07\x6a\x49\x00\x00\x00\x00\x00\x00\x7d\x21\x00\x00\x00\x00\x6a\x49\x21\x01\x00\x00\x18\x00\xab\x00\xaa\x05\x00\x00\x67\x00\xfb\xff\xc2\x3e\x00\x00\x0d\x00\xdf\x02\x00\x00\x53\x20\x53\x20\x18\x00\xa3\x05\x00\x00\x00\x00\x00\x00\xa1\x05\x4e\x03\x9e\x05\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x49\x00\x00\x00\x00\x04\x00\x00\x00\xb6\x05\x46\x3e\xb6\x05\x00\x00\x00\x00\x00\x00\x00\x00\x97\x05\xf7\xff\xca\x3d\xf8\x01\xf4\x03\x00\x00\x00\x00\xca\x3d\x71\x05\x9b\x05\x9a\x05\xea\x39\x68\x05\x00\x00\xb8\x31\x6b\x05\x00\x00\x00\x00\x08\x4d\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\x8b\x4b\x80\x05\x7a\x05\x7a\x05\x4e\x03\x31\x02\x00\x00\x85\x05\x00\x00\x00\x00\x9c\x05\x00\x00\x00\x00\x6a\x49\x6a\x49\x6a\x49\x00\x00\x59\x05\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x05\x00\x00\x00\x00\x00\x00\xc1\x05\xd2\x05\x00\x00\x00\x00\x72\x05\x4e\x03\x00\x00\x00\x00\x70\x05\x00\x00\x00\x00\xcc\x05\x86\x05\x00\x00\xe2\x3a\x44\x05\x6a\x49\x6a\x49\x00\x00\x00\x00\x00\x00\xb8\x4b\x00\x00\x27\x4b\x00\x00\x00\x00\xca\x3d\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x01\x00\xaf\x05\x7e\x12\x2e\x04\x52\x1b\xcd\x13\x58\x12\x15\x12\x09\x11\xde\x02\x84\x44\x03\x00\xe5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x04\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x05\x00\x00\x00\x00\x00\x00\xfb\x04\x00\x00\x4e\x0e\x00\x00\x00\x00\x00\x00\xbb\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x01\x6d\x44\x90\x43\x91\x0b\x5e\x0c\xf2\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x04\xc0\x04\xe4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x10\x00\x00\xe6\x1a\xc0\x1a\x83\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x1a\x0b\x05\xd2\x11\xbf\x04\x09\x05\x73\x1e\xf7\x04\x44\x1e\x00\x00\x00\x00\x00\x00\xd5\x1c\x13\x1e\xed\x0b\x04\x1e\x46\x0b\xe0\x0a\xba\x09\x27\x0a\xf8\xff\x71\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x1a\x28\x1c\x80\x43\x12\x05\x10\x1a\x00\x00\xea\x19\x00\x00\xa6\x19\x75\x0b\x00\x00\x8f\x05\x00\x00\x00\x00\xdf\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x04\xa5\x01\x66\x04\x42\x04\xeb\x03\x06\x0e\x46\x09\x00\x00\x00\x00\xc9\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x03\x00\x00\x00\x00\x00\x00\x00\x00\x04\x08\x00\x00\x00\x00\x00\x00\x81\x05\x00\x00\xd7\x45\x4f\x05\x18\x01\x5b\x04\x01\x05\x0f\x02\x46\x03\xc2\x03\x00\x00\x42\x03\x9b\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x05\x00\x00\x00\x00\x9a\x01\x00\x00\x14\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x04\xaa\x04\x7f\x05\x00\x00\x8e\x04\x00\x00\x5e\x04\x00\x00\x0e\x04\x68\x03\x60\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x1d\xc5\x04\x5f\x02\x00\x00\x00\x00\x46\x05\x00\x00\x00\x00\x00\x00\x40\x05\x00\x00\x00\x00\x35\x04\x00\x00\xfc\xff\x8b\xff\x5e\x01\x00\x00\x3b\x05\x39\x05\x00\x00\xbb\x0a\x63\x06\x7c\x45\xc1\x02\xdf\x33\x00\x00\x00\x00\x00\x00\x00\x00\x66\x05\xb8\x3c\xea\x44\x1a\x05\x00\x00\x00\x00\x82\x04\x00\x00\x20\x0b\x00\x00\xc1\x0c\xce\x07\x56\x05\x00\x00\x00\x00\x00\x00\x9c\x10\x99\xff\x00\x00\x00\x00\xff\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x0c\xed\x0b\x00\x00\x00\x00\xba\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x0f\xb5\x02\x00\x00\x00\x00\xaa\x02\xc3\x33\x97\x02\x00\x00\x00\x00\x00\x00\x8b\x07\x10\x07\xdc\x00\x41\x3a\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x90\x04\x00\x00\x00\x00\x00\x00\x00\x00\x21\x03\x9b\x02\x00\x00\x94\x0e\x00\x00\x00\x00\x00\x00\xd5\x04\xeb\x04\x00\x00\x99\xff\x00\x00\x00\x00\x00\x00\x13\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x1d\x00\x00\x00\x00\x92\x1c\xd8\x04\xe5\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x10\x83\x10\x00\x00\x00\x00\x00\x00\xf0\x04\x97\xff\x00\x00\xea\x04\x3f\x10\xb0\xff\x00\x00\x00\x00\x87\x0d\x7d\x19\x7b\x02\x00\x00\x00\x00\x00\x00\xef\x35\x3a\x19\x14\x19\xd0\x18\xa7\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x3a\x5c\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\xa3\x01\xe5\x44\x00\x00\xfd\x41\x00\x00\x89\x40\x94\x42\xf4\x1e\x00\x00\xa0\x00\x94\x4a\x20\x41\x00\x00\x00\x00\x00\x00\x8c\x04\x77\x05\x00\x00\x00\x00\x5d\x05\x00\x00\x60\x39\x68\x38\x00\x00\xfa\x01\x00\x00\x00\x00\x56\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x53\x02\x00\x00\x00\x00\x00\x00\x25\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x09\x00\x00\x9e\x3e\x00\x00\x00\x00\xbc\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x04\x87\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x04\x00\x00\x00\x00\x00\x00\x00\x00\x64\x18\x3e\x18\x79\x04\x00\x00\x00\x00\xfa\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x0f\x9a\x0a\x6c\x1c\xc6\x04\x14\x0e\x00\x00\xd1\x17\xbe\x0e\xad\x0d\x00\x00\x8e\x17\x7a\x0e\x47\x0d\x00\x00\x93\xff\x00\x00\x00\x00\x00\x00\xad\x0b\x00\x00\xac\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x62\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x02\x00\x00\x00\x00\x00\x00\x00\x00\x61\x0a\x00\x00\x5d\x01\x00\x00\x5c\x04\x00\x00\x00\x00\x0a\x03\x00\x00\x56\x04\x00\x00\x00\x00\x00\x00\x00\x00\x04\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x09\x8a\x0b\x00\x00\x00\x00\x00\x00\x94\x0e\x00\x00\x00\x00\x20\x0b\xe0\x0c\x00\x00\x0e\x07\xf9\xff\x00\x00\x00\x00\x66\x08\x00\x00\x59\x01\x00\x00\x00\x00\xec\xff\x00\x00\x68\x17\xaf\x0f\x70\x37\xe0\x04\x89\x02\xed\x04\x00\x00\xd7\x32\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x04\xa5\x02\x85\x03\xcd\x04\x00\x00\x00\x00\xea\x1d\xf9\x42\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x4e\x01\x00\x04\x00\x00\xc7\xff\x8a\x13\x47\x13\x9f\x04\x00\x00\x00\x00\x00\x00\x7f\x04\x00\x00\x89\x04\x00\x00\x00\x00\x25\x02\x5a\x10\x00\x00\x00\x00\xae\x04\xba\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x24\x17\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x04\x00\x00\xb2\x04\x00\x00\xb3\x03\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x04\x5d\x04\x3b\x04\x6f\x04\x00\x00\x00\x00\x5d\x03\x00\x00\x00\x00\x00\x00\x06\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x1b\xf3\xff\x37\x04\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x01\x00\x00\x00\x00\x56\x0c\xc8\x3c\x47\x04\xe2\x08\x00\x00\x34\x04\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x00\x00\x1c\x04\x00\x00\x00\x00\xf2\x03\x00\x00\x00\x00\x08\x04\x00\x00\xd0\x34\x49\x2b\xc2\x1f\x00\x00\x31\x3c\xc6\x1c\x03\x4a\x39\x3b\xcd\x03\xa8\x03\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x32\x00\x00\x00\x00\x44\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x5e\x03\x00\x00\x77\x09\xfb\x16\x00\x00\x00\x00\x49\x39\x3f\x01\x00\x00\x9c\x1d\x95\x1b\xbf\x1a\x0d\x42\xb2\x1c\x4e\x48\x85\x41\x00\x00\xfe\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x06\x00\x00\x1e\x03\x00\x00\x00\x00\xa3\x03\x00\x00\x49\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x11\x00\x00\x00\x00\x00\x00\x92\x16\x00\x00\x04\x13\x4e\x16\x00\x00\x00\x00\x7a\x0c\x62\x01\x00\x00\x00\x00\x00\x00\xa5\x3d\x00\x00\x00\x00\x00\x00\x9b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x06\xe7\x06\x00\x00\xd4\x01\x54\x3b\x00\x00\xfc\x04\x00\x00\x00\x00\x00\x00\x00\x00\xef\x03\x00\x00\x17\x00\x00\x00\x55\x01\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x03\x00\x00\x00\x00\x00\x00\x00\x00\x07\x04\xd3\x35\xc1\x12\x00\x00\x00\x00\x25\x16\xe2\x15\x00\x00\x00\x00\x01\x0f\x4c\x11\xbc\x15\x00\x00\x00\x00\x00\x00\xe9\x19\x13\x19\x91\x05\x00\x00\xbb\x02\xb3\x02\x00\x00\x99\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x03\x09\x03\xc0\xff\x00\x00\x45\x03\xe1\x02\x00\x00\x3d\x18\x67\x17\x91\x05\x11\x40\x44\x02\x32\x02\x00\x00\x3a\x0f\x00\x00\x00\x00\x78\x15\x00\x00\x95\x06\x1a\x06\x00\x00\xa4\x02\xc5\x02\x00\x00\x24\x05\xa9\x04\x00\x00\x00\x00\x00\x00\xe9\x02\x00\x00\x00\x00\x51\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x19\x01\x94\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x01\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x02\x00\x00\x00\x00\xac\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x15\x00\x00\x00\x00\x00\x00\xfc\x08\x81\x08\x00\x00\x59\x37\x00\x00\x2c\x04\x98\x03\x00\x00\x8a\x02\x00\x00\xbe\x01\x00\x00\x00\x00\x18\x06\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\xb4\x01\x00\x00\x6d\x02\x96\x1b\xe2\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x08\xa5\x03\x00\x00\x00\x00\x53\x0e\x48\x00\x00\x00\xf5\x01\x00\x00\xe9\x01\x00\x00\x00\x00\x21\x13\x00\x00\x00\x00\xc6\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x15\xe6\x14\xa2\x14\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x02\x75\x01\x00\x00\x79\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x02\x47\x00\x00\x00\x00\x00\x00\x00\x2f\x02\x00\x00\xee\x03\x70\x03\x00\x00\x43\x00\x0b\x02\x00\x00\x8f\x00\x7e\x00\xf6\x01\x36\x00\x00\x00\x00\x00\x00\x00\x36\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x16\x00\x00\x00\x00\xd3\x0f\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x72\x01\x00\x00\x00\x00\x00\x00\x06\x08\x00\x00\xc8\x01\x23\x05\xbb\x15\x94\x0e\xe5\x14\x00\x00\x00\x00\x00\x00\x9f\x05\x00\x00\x00\x00\xd8\x06\xd0\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x64\x13\x00\x00\x9d\x00\x8a\x00\x00\x00\x8e\x00\x08\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x04\x00\x00\x00\x00\xe4\xff\x00\x00\x26\x01\x57\x36\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\xff\xe7\x34\x47\x01\x33\x02\x00\x00\x00\x00\x86\x0d\x41\x01\x00\x00\x00\x00\xfc\x03\xe1\x00\x00\x00\x10\x14\x00\x00\x00\x00\x00\x00\x2a\x03\x00\x00\x00\x00\xd2\x01\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x0d\xce\x08\xdf\x07\x00\x00\x8d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\xff\x00\x00\x00\x00\xfc\x03\x5b\xff\x91\x05\x91\x05\x00\x00\x00\x00\x00\x00\x8a\x01\x00\x00\x8b\x02\x00\x00\x00\x00\xcb\x34\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xea\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\xfd\x00\x00\x00\x00\xea\xff\x00\x00\xf3\xff\x6d\xfd\x6a\xfd\x66\xfd\x56\xfd\x54\xfd\x55\xfd\x62\xfd\x53\xfd\x52\xfd\x51\xfd\x64\xfd\x63\xfd\x65\xfd\x61\xfd\x60\xfd\x50\xfd\x4f\xfd\x4e\xfd\x4d\xfd\x4c\xfd\x4b\xfd\x00\x00\x67\xfd\x69\xfd\x68\xfd\x00\x00\xbc\xff\x00\x00\xdd\xff\xec\xff\xbc\xff\x2d\xfd\x00\x00\x00\x00\x00\x00\xec\xfe\xe5\xfe\xd2\xfe\xc5\xfe\x00\x00\xd1\xfe\x9a\xfd\x93\xfd\x8c\xfd\xd0\xfe\x77\xfd\x73\xfd\xbb\xfe\xb2\xfe\x71\xfd\x70\xfd\x72\xfd\x00\x00\x00\x00\xf4\xfe\x29\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\xfd\x8b\xfd\x8e\xfd\x8d\xfd\xbf\xfd\xbc\xfe\xbd\xfe\xc3\xfe\x00\x00\x62\xfe\x61\xfe\x00\x00\xf2\xff\xb0\xfd\xa3\xfd\xaf\xfd\xf0\xff\xf1\xff\x7b\xfd\x5e\xfd\x5f\xfd\x5a\xfd\x57\xfd\xae\xfd\x47\xfd\x9f\xfd\x43\xfd\x40\xfd\x59\xfd\x4a\xfd\x48\xfd\x49\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x44\xfd\x58\xfd\x41\xfd\x46\xfd\x5b\xfd\x42\xfd\x45\xfd\x3c\xfe\x27\xfe\xcc\xfd\x5b\xfe\x5a\xfe\x00\x00\x00\x00\x4b\xfe\x43\xfe\x40\xfe\x3e\xfe\x31\xfe\x00\x00\x00\x00\xd1\xfd\xcf\xfd\x3d\xfe\xc0\xff\xc1\xff\x3b\xfe\x32\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x3f\xfd\x3e\xfd\x3a\xfe\x39\xfe\x3b\xfd\x3a\xfd\x3d\xfd\x3c\xfd\x39\xfd\x38\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\xfe\x00\x00\x23\xfe\x00\x00\x00\x00\x00\x00\xac\xff\x6c\xfe\x00\x00\x00\x00\x00\x00\x6a\xfd\xaa\xff\xa9\xff\xa8\xff\x00\x00\x00\x00\x66\xfe\x66\xfe\x66\xfe\xbd\xfd\x00\x00\xdf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xa2\xff\xa1\xff\xa0\xff\x63\xff\x9f\xff\x9e\xff\x78\xfe\x91\xff\x77\xfe\x80\xfe\x90\xff\x7b\xfe\x8f\xff\x7f\xfe\x7e\xfe\x7d\xfe\x7c\xfe\x00\x00\x6b\xff\x00\x00\x00\x00\x80\xff\x6a\xff\x00\x00\x00\x00\x00\x00\x29\xff\x14\xff\x19\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x30\xfd\x2f\xfd\x2e\xfd\x00\x00\x00\x00\xb9\xff\x00\x00\x00\x00\xbc\xff\xed\xff\xbc\xff\x00\x00\xe0\xff\xe2\xff\xbd\xff\xdf\xff\xa3\xff\x00\x00\x00\x00\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\xfd\xaa\xfd\xb4\xfd\x6f\xfd\xac\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x1a\xff\x00\x00\xb6\xfd\x00\x00\x15\xff\x00\x00\x00\x00\x2a\xff\x27\xff\x00\x00\x55\xff\x00\x00\x00\x00\x9c\xff\x00\x00\x00\x00\x00\x00\xe5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\xb6\xfe\x00\x00\xaf\xfe\x00\x00\x66\xff\x00\x00\x7e\xfd\x00\x00\x7f\xfd\x00\x00\x00\x00\x63\xff\x00\x00\xde\xfd\x1a\xfe\x5b\xfe\x00\x00\x00\x00\x7c\xfd\x00\x00\x7d\xfd\x79\xfd\x5c\xfd\x00\x00\x5d\xfd\x9f\xfd\x00\x00\x59\xfd\xa7\xfd\x32\xfd\x00\x00\x00\x00\xbe\xfd\xbc\xfd\xba\xfd\xb7\xfd\x00\x00\x00\x00\x65\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xff\x00\x00\x34\xff\x34\xff\x00\x00\x00\x00\x00\x00\xab\xff\x2d\xfe\x9d\xfd\x2e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x2f\xfe\x30\xfe\x00\x00\x20\xfe\xc1\xff\x00\x00\x00\x00\x5c\xfd\x5d\xfd\x00\x00\xa5\xfd\x00\x00\xfb\xfd\xfa\xfd\x00\x00\x10\xfe\x00\x00\x0f\xfe\xa2\xfd\xdc\xfd\x52\xfe\x41\xfe\xdb\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\xfe\xce\xfd\xd2\xfd\xd2\xfd\x00\x00\x50\xfe\xcb\xfd\x49\xfe\x00\x00\x54\xfe\x49\xfe\x00\x00\x00\x00\x51\xfe\x00\x00\x00\x00\x00\x00\xc9\xfd\x45\xfe\x4e\xfe\x4f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfe\xb2\xfd\xb1\xfd\xbf\xfe\xb6\xfe\x00\x00\xb5\xfe\x00\x00\x00\x00\xcb\xfe\x00\x00\x00\x00\x88\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x84\xfd\x85\xfd\xcd\xfe\x86\xfd\x87\xfd\x89\xfd\x8a\xfd\x00\x00\x95\xfd\x00\x00\x96\xfd\x00\x00\x88\xfe\x86\xfe\x2a\xfd\x00\x00\xf2\xfe\xf3\xfe\x00\x00\xb2\xfe\xb1\xfe\x00\x00\x00\x00\xd3\xfe\x00\x00\x90\xfd\x00\x00\x00\x00\x00\x00\x75\xfd\x00\x00\x00\x00\x00\x00\xcf\xfe\xda\xff\xd9\xff\x00\x00\xe7\xff\x35\xfd\x34\xfd\xbe\xff\xee\xfe\x00\x00\x00\x00\x81\xfd\x00\x00\x00\x00\x00\x00\xe1\xfe\xe2\xfe\xe3\xfe\xe4\xfe\xed\xfe\x00\x00\xb3\xfe\x00\x00\xf1\xfe\xf0\xfe\x00\x00\xf7\xfe\x00\x00\x00\x00\xce\xfe\xc9\xfe\x00\x00\xc8\xfe\x94\xfd\x91\xfd\x97\xfd\x99\xfd\x33\xfd\x92\xfd\x00\x00\xc7\xfe\x00\x00\x98\xfd\xca\xfe\x00\x00\x00\x00\x00\x00\xf4\xfe\x00\x00\xb7\xfe\xc4\xfe\xef\xff\xa6\xfd\xad\xfd\x6b\xfd\xa4\xfd\x9e\xfd\x7a\xfd\x5c\xfe\x5d\xfe\x5e\xfe\x5f\xfe\x60\xfe\xfa\xfe\x00\x00\xca\xfd\xc7\xfd\xc4\xfd\xc6\xfd\xcd\xfd\x42\xfe\x00\x00\x00\x00\x00\x00\xf6\xfd\xf4\xfd\xe3\xfd\x4a\xfe\x49\xfe\xe1\xfd\x36\xfd\x37\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xfd\x00\x00\x00\x00\x48\xfe\x47\xfe\x00\x00\xda\xfd\x56\xfe\x00\x00\x00\x00\xd8\xfd\xfc\xfe\x00\x00\x34\xfe\x0e\xfe\x00\x00\x00\x00\x33\xfe\x00\x00\x00\x00\x00\x00\x6c\xfd\x12\xfe\x15\xfe\x35\xfe\x16\xfe\x11\xfe\x36\xfe\x00\x00\x2c\xfe\x29\xfe\x2a\xfe\x1b\xfe\x00\x00\x00\x00\x28\xfe\x2b\xfe\x24\xfe\x22\xfe\x9b\xfd\x9c\xfd\x6d\xfe\x82\xfd\xa6\xff\x83\xfd\xa1\xfd\x00\x00\x6f\xfe\xf9\xfe\x00\x00\xe8\xfe\xde\xfe\x00\x00\xb2\xfe\x00\x00\x00\x00\x76\xfe\x35\xff\xfe\xfe\x75\xfe\x00\x00\xc1\xfd\x3d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xba\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\xfe\x00\x00\x6c\xfd\x18\xfe\x37\xfe\x38\xfe\x19\xfe\x00\x00\x00\x00\x00\x00\x69\xff\xfd\xfe\x00\x00\xde\xfe\x00\x00\xb2\xfe\x59\xfe\x79\xfe\x2d\xff\x71\xfe\x00\x00\x00\x00\x00\x00\x42\xff\xaa\xfe\x69\xff\x00\x00\x00\x00\x81\xff\x82\xff\x84\xff\x83\xff\x38\xff\x60\xff\x00\x00\x69\xff\x87\xff\x00\x00\x00\x00\x00\x00\x00\x00\x08\xff\x07\xff\x06\xff\x05\xff\x04\xff\x00\x00\x00\x00\x00\x00\x57\xff\x55\xff\x00\x00\x00\x00\x21\xff\x26\xff\x00\x00\x99\xff\x2b\xff\x13\xff\x00\x00\x12\xff\x9b\xff\x16\xff\x00\x00\x18\xff\x9a\xff\x1b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\xff\x7a\xfe\xba\xff\xb3\xff\xb8\xff\xe7\xff\xe3\xff\xa4\xff\xbe\xff\xe4\xff\xe1\xff\xbf\xff\xa5\xff\xd7\xff\x00\x00\x00\x00\xb5\xff\xb4\xff\x95\xff\x00\x00\x00\x00\x92\xff\x96\xff\x00\x00\x0e\xff\x0c\xff\x00\x00\x1c\xff\xb5\xfd\x17\xff\x00\x00\x0f\xff\x2c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x59\xff\x5a\xff\x54\xff\x00\x00\x56\xff\x00\x00\x0a\xff\x00\x00\x02\xff\x01\xff\x03\xff\x00\x00\x09\xff\x8d\xff\xe1\xfe\x00\x00\x7f\xff\x00\x00\x61\xff\x5f\xff\x5e\xff\x5b\xff\x5c\xff\x88\xff\x00\x00\x62\xff\x9d\xff\x89\xff\xae\xfe\xac\xfe\x00\x00\x8e\xff\x00\x00\x67\xff\x00\x00\x2d\xff\x73\xfe\x72\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x98\xfe\x84\xfe\x00\x00\x69\xff\x64\xff\x00\x00\x17\xfe\x78\xfd\xbb\xfd\xb9\xfd\xab\xfd\xb8\xfd\x00\x00\x64\xfe\x00\x00\x00\x00\x68\xfe\x6b\xfe\x51\xff\x00\x00\x4d\xff\xb2\xfe\x30\xff\xc2\xfd\x33\xff\x36\xff\x00\x00\x2f\xff\x32\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\xfe\x1d\xfe\x1f\xfe\x21\xfe\x26\xfe\x14\xfe\x13\xfe\x1a\xfe\x08\xfe\xf7\xfd\x07\xfe\x05\xfe\x02\xfe\x01\xfe\x00\x00\xf9\xfd\x1a\xfe\x0a\xfe\x0c\xfe\x09\xfe\x00\x00\x00\x00\xd9\xfd\x00\x00\xef\xfd\xeb\xfd\xfe\xfe\xf0\xfd\x00\x00\x00\x00\xf1\xfd\x00\x00\x4c\xfe\xd7\xfd\xd4\xfd\xd6\xfd\x4d\xfe\x57\xfe\x00\x00\xe4\xfd\x00\x00\x00\x00\xe2\xfd\x53\xfe\x00\x00\x00\x00\x3f\xfe\xc0\xfe\x6e\xfd\x00\x00\xb4\xfe\x00\x00\x00\x00\xa8\xfe\xa6\xfe\xa2\xfe\xa0\xfe\xa1\xfe\xa4\xfe\x00\x00\x00\x00\x00\x00\x2b\xfd\x00\x00\xef\xfe\x00\x00\x76\xfd\x8f\xfd\xdf\xfe\xe0\xfe\xd7\xff\x00\x00\xd0\xff\x00\x00\x2b\xfd\x2c\xfd\x29\xfd\xbe\xfe\x00\x00\x9f\xfe\x00\x00\xa5\xfe\x00\x00\xc6\xfe\xcc\xfe\x00\x00\xc8\xfd\xc5\xfd\xe0\xfd\xf5\xfd\x49\xfe\xd5\xfd\x00\x00\xf3\xfd\xee\xfd\x00\x00\x00\x00\xec\xfd\xf2\xfd\xfb\xfe\x00\x00\x0d\xfe\x00\xfe\x4b\xfd\x00\x00\x00\x00\x00\x00\xa7\xff\x80\xfd\xea\xfe\x00\x00\x00\x00\xd6\xfe\xd8\xfe\xda\xfe\xdc\xfe\xe9\xfe\x00\x00\xf8\xfe\x6e\xfe\xc0\xfd\x37\xff\xc3\xfd\x00\x00\x00\x00\x00\x00\xf6\xfe\x00\x00\x63\xfe\x00\x00\x65\xff\x98\xfe\x84\xfe\x29\xfd\x8b\xff\x00\x00\x84\xfe\x00\x00\x00\x00\x00\x00\xd6\xfe\x00\x00\xda\xfe\xdc\xfe\xe9\xfe\x00\x00\x2e\xff\x74\xfe\x00\x00\x43\xff\x46\xff\x46\xff\xa9\xfe\xaa\xfe\xaa\xfe\x39\xff\x3c\xff\x3c\xff\x5d\xff\x68\xff\x8c\xff\x00\x00\x76\xff\x00\x00\x00\x00\x0b\xff\xa0\xfd\x58\xff\x00\x00\x00\x00\x20\xff\x1e\xff\x00\x00\x00\x00\x25\xff\x23\xff\x00\x00\x11\xff\x00\x00\x0d\xff\x00\x00\x98\xff\x00\x00\x00\x00\xb6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\xe8\xff\xb1\xff\x93\xff\x94\xff\x10\xff\x24\xff\x00\x00\x00\x00\x1f\xff\x22\xff\x34\xff\x34\xff\xff\xfe\x00\x00\x7e\xff\x00\x00\x00\x00\x41\xff\x63\xff\x3d\xff\x00\x00\x40\xff\x6b\xff\x00\x00\x00\x00\xad\xfe\xab\xfe\x4c\xff\x47\xff\x00\x00\x4b\xff\x70\xff\x00\x00\x00\x00\x00\x00\x70\xfe\xeb\xfe\xdb\xfe\xd9\xfe\xd7\xfe\xd4\xfe\xd5\xfe\x95\xfe\x95\xfe\x8a\xff\x83\xfe\x00\x00\x92\xfe\x90\xfe\x8c\xfe\x86\xff\x84\xfe\x69\xfe\x6a\xfe\x00\x00\x00\x00\x4e\xff\x00\x00\xd4\xfe\xd5\xfe\xf8\xfd\x04\xfe\x03\xfe\x06\xfe\x00\x00\x00\x00\x00\x00\x0b\xfe\x58\xfe\xed\xfd\xea\xfd\x2d\xff\xe7\xfd\xe5\xfd\x00\x00\x00\x00\x00\x00\xc1\xfe\xa7\xfe\x9d\xfe\xa3\xfe\x00\x00\x87\xfe\x85\xfe\xb0\xfe\x00\x00\xd5\xff\xd2\xff\xd0\xff\xcd\xff\xce\xff\xcf\xff\x00\x00\xde\xff\xbc\xff\xbc\xff\xd1\xff\xd0\xff\xc9\xff\xc3\xff\x00\x00\x00\x00\x00\x00\xd0\xff\xd8\xff\x9c\xfe\x00\x00\x00\x00\x00\x00\xe8\xfd\xe6\xfd\xe9\xfd\xff\xfd\xfe\xfd\x00\x00\x50\xff\x00\x00\xf5\xfe\x85\xff\x00\x00\xb2\xfe\x00\x00\xb9\xfe\x00\x00\x82\xfe\x00\x00\x96\xfe\xa9\xfd\x00\x00\x00\x00\x00\x00\x44\xfd\x00\x00\x45\xff\x48\xff\x72\xff\x69\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x44\xff\x3b\xff\x3e\xff\x6e\xff\x3a\xff\x00\x00\x00\x00\x77\xff\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x28\xff\xaf\xff\x00\x00\xee\xff\xbc\xff\xbc\xff\x00\x00\x00\x00\xb2\xff\xbb\xff\xb0\xff\x00\x00\xd0\xff\x00\x00\x53\xff\x52\xff\x7b\xff\x7d\xff\x78\xff\x7a\xff\x7c\xff\x69\xff\x3f\xff\x69\xff\x00\x00\x69\xff\x71\xff\x74\xff\x49\xff\x9a\xfe\x41\xfd\x29\xfd\x00\x00\x00\x00\x95\xfe\x99\xfe\x81\xfe\x00\x00\x2b\xfd\x00\x00\x00\x00\x8b\xfe\x2b\xfd\x4f\xff\x00\x00\x00\x00\x55\xfe\x9e\xfe\x00\x00\xd6\xff\xca\xff\x00\x00\xc2\xff\xcb\xff\xcc\xff\x00\x00\xd3\xff\xdb\xff\xdc\xff\xd0\xff\x00\x00\xc4\xff\x00\x00\xc7\xff\x9b\xfe\x00\x00\xfd\xfd\x8e\xfe\x00\x00\x00\x00\x00\x00\x8d\xfe\x29\xfd\xb8\xfe\x97\xfe\xa8\xfd\x94\xfe\x00\x00\x73\xff\x4a\xff\x75\xff\x98\xfe\x84\xfe\x79\xff\x1d\xff\x00\x00\xd0\xff\xe6\xff\xe5\xff\x00\x00\xae\xff\x6d\xff\x84\xfe\x00\x00\x91\xfe\x8b\xfe\x2b\xfd\xe7\xfe\x8a\xfe\x46\xfe\xc8\xff\xc6\xff\x00\x00\xd4\xff\xd2\xff\xc5\xff\x8f\xfe\x00\x00\x6c\xff\xad\xff\x93\xfe"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x3a\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x06\x00\x0e\x00\x0f\x00\x10\x00\x7e\x00\x09\x00\x15\x00\x0b\x00\x07\x00\x08\x00\x76\x00\x77\x00\x01\x00\x30\x00\x30\x00\x00\x00\x0a\x00\x00\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x15\x00\x16\x00\x17\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x20\x00\x30\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x81\x00\x82\x00\x83\x00\x4f\x00\x50\x00\xa1\x00\x49\x00\x3a\x00\x2f\x00\x13\x00\x13\x00\xa1\x00\x33\x00\x34\x00\x7d\x00\x7e\x00\x49\x00\x38\x00\x52\x00\x4f\x00\x50\x00\x3c\x00\x0f\x00\x10\x00\x19\x00\x11\x00\x11\x00\x4b\x00\x4e\x00\xb5\x00\x4e\x00\x4a\x00\x4b\x00\x4e\x00\x84\x00\x0f\x00\x10\x00\xf9\x00\x5e\x00\x0f\x00\x10\x00\xfd\x00\x5e\x00\x0c\x00\x84\x00\x66\x00\xd2\x00\x4a\x00\x57\x00\x7c\x00\x7c\x00\x6c\x00\xb3\x00\x4e\x00\xb5\x00\x6b\x00\x00\x00\x72\x00\x6c\x00\x1c\x00\x7c\x00\x76\x00\x4b\x00\x4a\x00\x4b\x00\x4e\x00\x52\x00\x65\x00\xd8\x00\xd9\x00\x7c\x00\x60\x00\x8b\x00\x60\x00\x47\x00\x42\x00\x84\x00\x4e\x00\xe2\x00\xf3\x00\xe4\x00\x6c\x00\x6f\x00\x5d\x00\x5d\x00\x85\x00\xf8\x00\x84\x00\x8f\x00\x84\x00\xee\x00\xf7\x00\xfe\x00\xf5\x00\x85\x00\x86\x00\x87\x00\xf7\x00\x99\x00\x9a\x00\x15\x00\x8c\x00\x07\x00\x08\x00\x8f\x00\x61\x00\x91\x00\x92\x00\x7c\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\x16\x00\x17\x00\xf8\x00\x85\x00\x84\x00\x84\x00\x84\x00\x4a\x00\xfe\x00\x7b\x00\x20\x00\xe8\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xee\x00\x82\x00\x83\x00\xf8\x00\x62\x00\x1d\x00\x1e\x00\xc4\x00\x2f\x00\xfe\x00\x21\x00\x4e\x00\x33\x00\x34\x00\x47\x00\xcc\x00\xcd\x00\x38\x00\x60\x00\xd0\x00\xd1\x00\x3c\x00\xe8\x00\xc4\x00\x6c\x00\x5a\x00\x5b\x00\x5e\x00\xee\x00\x6b\x00\x7c\x00\xcc\x00\xcd\x00\x5b\x00\x47\x00\xd0\x00\xd1\x00\x47\x00\xe8\x00\xf8\x00\xf8\x00\xe6\x00\xe7\x00\xe8\x00\xee\x00\xfe\x00\xfe\x00\xe8\x00\x57\x00\xee\x00\x6b\x00\xf0\x00\xf1\x00\xee\x00\x48\x00\xf4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xf8\x00\xf8\x00\x50\x00\xfa\x00\xfb\x00\xee\x00\xfe\x00\xf0\x00\xf1\x00\x79\x00\x6b\x00\xf4\x00\xfc\x00\x6b\x00\xfc\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xf8\x00\x5b\x00\xfa\x00\xfb\x00\x48\x00\x5e\x00\x5d\x00\xf8\x00\x5f\x00\xfa\x00\xfb\x00\xf8\x00\x50\x00\xfa\x00\xfb\x00\x85\x00\x86\x00\x87\x00\x6b\x00\x13\x00\x14\x00\x15\x00\x8c\x00\x07\x00\x08\x00\x8f\x00\x30\x00\x91\x00\x92\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\x16\x00\x17\x00\xf8\x00\x60\x00\xf8\x00\x48\x00\xfa\x00\xfb\x00\xfe\x00\x61\x00\x20\x00\x4e\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xf8\x00\x60\x00\xfa\x00\xfb\x00\xf8\x00\xf8\x00\xfa\x00\xfb\x00\x2f\x00\xf5\x00\x6c\x00\xfe\x00\x33\x00\x34\x00\x49\x00\xcc\x00\xcd\x00\x38\x00\x7b\x00\xd0\x00\xd1\x00\x3c\x00\x39\x00\xc4\x00\x6c\x00\xda\x00\xdb\x00\x30\x00\x00\x00\x00\x00\xe5\x00\xcc\x00\xcd\x00\xe8\x00\x84\x00\xd0\x00\xd1\x00\xe5\x00\x4a\x00\xee\x00\xe8\x00\xe6\x00\xe7\x00\xe8\x00\x6e\x00\x6f\x00\xee\x00\xf5\x00\x57\x00\xee\x00\x6d\x00\xf0\x00\xf1\x00\xd2\x00\xf7\x00\x72\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\xd8\x00\xd9\x00\xdc\x00\xdd\x00\xee\x00\x66\x00\xf0\x00\xf1\x00\xf6\x00\x60\x00\xf4\x00\x6c\x00\xe4\x00\xf6\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xec\x00\xed\x00\x6b\x00\xef\x00\xee\x00\xe5\x00\xf5\x00\xf3\x00\xe8\x00\x00\x00\x81\x00\x82\x00\x83\x00\x5e\x00\xee\x00\x85\x00\x86\x00\x87\x00\x6e\x00\x6f\x00\x14\x00\x15\x00\x8c\x00\x07\x00\x08\x00\x8f\x00\x6b\x00\x91\x00\x92\x00\x5e\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\x16\x00\x17\x00\xe5\x00\x00\x00\x6b\x00\xe8\x00\x49\x00\x60\x00\x60\x00\x5e\x00\x20\x00\xee\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xe5\x00\x6b\x00\x6b\x00\xe8\x00\xf5\x00\x6b\x00\x6e\x00\x6f\x00\x2f\x00\xee\x00\x6e\x00\x6f\x00\x33\x00\x34\x00\x5e\x00\xcc\x00\xcd\x00\x38\x00\x66\x00\xd0\x00\xd1\x00\x3c\x00\x60\x00\xc4\x00\x6c\x00\xf9\x00\xe2\x00\x6b\x00\xe4\x00\xfd\x00\x72\x00\xcc\x00\xcd\x00\x6b\x00\x62\x00\xd0\x00\xd1\x00\xce\x00\xee\x00\xd0\x00\xd1\x00\xe6\x00\xe7\x00\xe8\x00\x6c\x00\x6e\x00\x6f\x00\x48\x00\x57\x00\xee\x00\x60\x00\xf0\x00\xf1\x00\x4e\x00\x6f\x00\x30\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x5e\x00\x6b\x00\xf5\x00\xe8\x00\xe8\x00\xee\x00\x7b\x00\xf0\x00\xf1\x00\xee\x00\xee\x00\xf4\x00\xf1\x00\x6b\x00\xf8\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xe2\x00\xfe\x00\xe4\x00\x60\x00\x6c\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x6e\x00\x6f\x00\x62\x00\xee\x00\x12\x00\x6b\x00\x85\x00\x86\x00\x87\x00\xc0\x00\xc1\x00\xe5\x00\x6c\x00\x8c\x00\xe8\x00\x08\x00\x8f\x00\xb5\x00\x91\x00\x92\x00\xee\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xe8\x00\x17\x00\xf1\x00\x0a\x00\xf9\x00\xe2\x00\xee\x00\xe4\x00\xfd\x00\xe2\x00\x20\x00\xe4\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xee\x00\xe6\x00\xe7\x00\xe8\x00\xee\x00\xda\x00\xdb\x00\xf9\x00\x2f\x00\xee\x00\xf3\x00\xfd\x00\x33\x00\x34\x00\xf7\x00\xcc\x00\xcd\x00\x38\x00\x61\x00\xd0\x00\xd1\x00\x3c\x00\x65\x00\xc4\x00\x67\x00\x51\x00\x52\x00\xe2\x00\x49\x00\xe4\x00\xf3\x00\xcc\x00\xcd\x00\x70\x00\xf7\x00\xd0\x00\xd1\x00\x4b\x00\x84\x00\xee\x00\x4e\x00\xe6\x00\xe7\x00\xe8\x00\xce\x00\x7f\x00\xd0\x00\xd1\x00\x57\x00\xee\x00\x54\x00\xf0\x00\xf1\x00\x55\x00\x56\x00\x57\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x5c\x00\xe2\x00\xe2\x00\xe4\x00\xe4\x00\xee\x00\x4b\x00\xf0\x00\xf1\x00\x4e\x00\xe2\x00\xf4\x00\xe4\x00\xee\x00\xee\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xf1\x00\x66\x00\x71\x00\xee\x00\x2d\x00\xe5\x00\x11\x00\x6c\x00\xe8\x00\x14\x00\x15\x00\xe7\x00\xe8\x00\x08\x00\xee\x00\x85\x00\x86\x00\x87\x00\xee\x00\xf5\x00\xf0\x00\xf1\x00\x8c\x00\x7a\x00\x7b\x00\x8f\x00\x15\x00\x91\x00\x92\x00\xf5\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xcc\x00\xcd\x00\xf2\x00\xf3\x00\xd0\x00\xd1\x00\x1c\x00\xf7\x00\x2f\x00\xe7\x00\xe8\x00\xf9\x00\x33\x00\x34\x00\x05\x00\xfd\x00\xee\x00\x38\x00\xf0\x00\xf1\x00\x65\x00\x3c\x00\xc9\x00\xca\x00\x35\x00\x36\x00\x37\x00\xce\x00\x00\x00\xd0\x00\xd1\x00\x70\x00\xe8\x00\xf6\x00\xc4\x00\x74\x00\xf0\x00\xf1\x00\xee\x00\x78\x00\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xc9\x00\xca\x00\xd0\x00\xd1\x00\x57\x00\xce\x00\xe5\x00\xd0\x00\xd1\x00\xe8\x00\xf8\x00\x66\x00\x71\x00\x72\x00\x73\x00\xee\x00\xfe\x00\x6c\x00\xf1\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xd6\x00\xe5\x00\xd8\x00\xd9\x00\xe8\x00\xee\x00\x66\x00\xf0\x00\xf1\x00\x29\x00\xee\x00\xf4\x00\x6c\x00\xf1\x00\x73\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x5d\x00\xe8\x00\x5f\x00\x66\x00\x85\x00\x86\x00\x87\x00\xee\x00\xf1\x00\x6c\x00\xf1\x00\x8c\x00\x66\x00\x08\x00\x8f\x00\xf9\x00\x91\x00\x92\x00\x6c\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\x72\x00\x73\x00\x9e\x00\xbf\x00\xc0\x00\xc1\x00\xf9\x00\x65\x00\xec\x00\xed\x00\x20\x00\xef\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x5d\x00\x70\x00\x5f\x00\xec\x00\xed\x00\x74\x00\xef\x00\x70\x00\x2f\x00\x78\x00\xf3\x00\x74\x00\x33\x00\x34\x00\xf7\x00\xcc\x00\xcd\x00\x38\x00\x47\x00\xd0\x00\xd1\x00\x3c\x00\x4b\x00\xc4\x00\x70\x00\xe6\x00\xe7\x00\xe8\x00\x74\x00\x84\x00\x5c\x00\xcc\x00\xcd\x00\xee\x00\x4b\x00\xd0\x00\xd1\x00\x4e\x00\x55\x00\x56\x00\x57\x00\xe6\x00\xe7\x00\xe8\x00\x4b\x00\x5c\x00\x47\x00\x4e\x00\x57\x00\xee\x00\x4b\x00\xf0\x00\xf1\x00\xe6\x00\xe7\x00\xe8\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x68\x00\xee\x00\x16\x00\x17\x00\x6c\x00\xee\x00\x71\x00\xf0\x00\xf1\x00\x84\x00\x75\x00\xf4\x00\xe6\x00\xe7\x00\xe8\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xe6\x00\xe7\x00\xe8\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xee\x00\x79\x00\x68\x00\x85\x00\x86\x00\x87\x00\x6c\x00\xcc\x00\xcd\x00\xf9\x00\x8c\x00\xd0\x00\xd1\x00\x8f\x00\xd3\x00\x91\x00\x92\x00\xf9\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x68\x00\x68\x00\xe0\x00\x9e\x00\x6c\x00\x6c\x00\x2a\x00\x2b\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\x15\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x84\x00\x20\x00\x86\x00\x87\x00\x23\x00\x24\x00\x25\x00\x26\x00\xd4\x00\xd5\x00\xd6\x00\xd3\x00\xd8\x00\xd9\x00\x4b\x00\x5d\x00\x2f\x00\x5f\x00\x4f\x00\xc4\x00\x33\x00\x34\x00\xde\x00\x93\x00\xe0\x00\x38\x00\x70\x00\xcc\x00\xcd\x00\x3c\x00\x74\x00\xd0\x00\xd1\x00\xe9\x00\x68\x00\xeb\x00\xec\x00\xed\x00\x6c\x00\xef\x00\x62\x00\x0c\x00\xf2\x00\xf3\x00\x66\x00\x5c\x00\x68\x00\x69\x00\xd8\x00\xd9\x00\x16\x00\x17\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x57\x00\x5d\x00\xe2\x00\x5f\x00\xe4\x00\xee\x00\xca\x00\xf0\x00\xf1\x00\xf5\x00\xce\x00\xf4\x00\xd0\x00\xd1\x00\xee\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xd8\x00\xd9\x00\x7a\x00\x7b\x00\xc3\x00\xc4\x00\x74\x00\x75\x00\x76\x00\x77\x00\x8f\x00\xe6\x00\xe7\x00\xe8\x00\xe5\x00\x84\x00\x4e\x00\xe8\x00\x50\x00\xee\x00\xd4\x00\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xf1\x00\x85\x00\x86\x00\x87\x00\x49\x00\xd4\x00\xd5\x00\xd6\x00\x8c\x00\xd8\x00\xd9\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x79\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x47\x00\x48\x00\x23\x00\x24\x00\x25\x00\x26\x00\x61\x00\x2a\x00\x2b\x00\x5d\x00\x65\x00\x5f\x00\x67\x00\x40\x00\x2f\x00\x62\x00\xda\x00\xdb\x00\x33\x00\x34\x00\x44\x00\x70\x00\x69\x00\x38\x00\x5d\x00\x74\x00\x5f\x00\x3c\x00\x37\x00\x78\x00\xd5\x00\xd6\x00\x28\x00\xd8\x00\xd9\x00\x3b\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xc4\x00\x8d\x00\x8e\x00\xe2\x00\xd6\x00\xe4\x00\xd8\x00\xd9\x00\xcc\x00\xcd\x00\x4c\x00\x4d\x00\xd0\x00\xd1\x00\x57\x00\xee\x00\xd8\x00\xd9\x00\x1a\x00\x5d\x00\x8f\x00\x5f\x00\x5d\x00\x62\x00\x5f\x00\x55\x00\xe2\x00\x66\x00\xe4\x00\x68\x00\x69\x00\xf1\x00\x0c\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x5d\x00\xee\x00\x5f\x00\x2b\x00\x5d\x00\xee\x00\x5f\x00\xf0\x00\xf1\x00\x4a\x00\x4b\x00\xf4\x00\xe6\x00\xe7\x00\xe8\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x5d\x00\xee\x00\x5f\x00\x55\x00\x85\x00\x86\x00\x87\x00\x04\x00\xb0\x00\xb1\x00\xb2\x00\x8c\x00\x8f\x00\xb5\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x1b\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x4b\x00\xe6\x00\xe7\x00\xe8\x00\xd2\x00\x8d\x00\x8e\x00\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\x62\x00\x2e\x00\x2f\x00\x5d\x00\x66\x00\x5f\x00\x68\x00\x69\x00\xe2\x00\x56\x00\xe4\x00\x38\x00\xd4\x00\xd5\x00\xd6\x00\x3c\x00\xd8\x00\xd9\x00\x47\x00\x48\x00\xee\x00\x42\x00\x43\x00\x4e\x00\x5d\x00\xf3\x00\x5f\x00\xf1\x00\xc4\x00\x8d\x00\x8e\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xcc\x00\xcd\x00\x49\x00\x30\x00\xd0\x00\xd1\x00\x52\x00\xd5\x00\xd6\x00\x8f\x00\xd8\x00\xd9\x00\x47\x00\x48\x00\x55\x00\x56\x00\x57\x00\x89\x00\x8a\x00\x8b\x00\xe2\x00\x5c\x00\xe4\x00\x16\x00\x17\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x89\x00\x8a\x00\x8b\x00\xee\x00\x45\x00\xee\x00\x30\x00\xf0\x00\xf1\x00\x6d\x00\x41\x00\xf4\x00\x5d\x00\x71\x00\x72\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x43\x00\x44\x00\x45\x00\x46\x00\x85\x00\x86\x00\x87\x00\x88\x00\xd4\x00\xd5\x00\xd6\x00\x8c\x00\xd8\x00\xd9\x00\x8f\x00\x15\x00\x91\x00\x92\x00\xb5\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x16\x00\x17\x00\x4a\x00\x4b\x00\xd5\x00\xd6\x00\xf5\x00\xd8\x00\xd9\x00\x2b\x00\x2d\x00\x2e\x00\xf5\x00\x2e\x00\x2f\x00\x53\x00\x54\x00\xe2\x00\xf5\x00\xe4\x00\xd8\x00\xd9\x00\x93\x00\x38\x00\xeb\x00\xec\x00\xed\x00\x3c\x00\xef\x00\xee\x00\xe2\x00\xac\x00\xe4\x00\x42\x00\x43\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xc4\x00\xf5\x00\xee\x00\x74\x00\x75\x00\x76\x00\x77\x00\x17\x00\xcc\x00\xcd\x00\xc9\x00\xca\x00\xd0\x00\xd1\x00\x04\x00\xce\x00\x93\x00\xd0\x00\xd1\x00\x39\x00\x3a\x00\xf6\x00\x93\x00\xac\x00\x62\x00\x9b\x00\xf7\x00\x32\x00\x66\x00\x70\x00\x68\x00\x69\x00\x27\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x59\x00\xe5\x00\x59\x00\x55\x00\xe8\x00\xee\x00\x19\x00\xf0\x00\xf1\x00\x55\x00\xee\x00\xf4\x00\xd9\x00\xf1\x00\xf6\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xf5\x00\x18\x00\x58\x00\x27\x00\x85\x00\x86\x00\x87\x00\x88\x00\x32\x00\x1f\x00\x9d\x00\x8c\x00\xba\x00\x8f\x00\x8f\x00\x15\x00\x91\x00\x92\x00\xf7\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\xeb\x00\xec\x00\xed\x00\xba\x00\xef\x00\xba\x00\x17\x00\xf2\x00\xf3\x00\x85\x00\xc9\x00\xca\x00\xf7\x00\x2e\x00\x2f\x00\xce\x00\x4a\x00\xd0\x00\xd1\x00\x07\x00\xd8\x00\xd9\x00\x66\x00\x38\x00\x66\x00\x07\x00\x19\x00\x3c\x00\x5e\x00\x84\x00\xe2\x00\x52\x00\xe4\x00\x42\x00\x55\x00\x47\x00\x57\x00\x6b\x00\xe5\x00\x7c\x00\xc4\x00\xe8\x00\xee\x00\x66\x00\x6c\x00\x85\x00\x54\x00\xee\x00\xcc\x00\xcd\x00\xf1\x00\x62\x00\xd0\x00\xd1\x00\x85\x00\x5c\x00\xd5\x00\xd6\x00\x69\x00\xd8\x00\xd9\x00\x66\x00\x71\x00\x72\x00\x4a\x00\x5e\x00\x75\x00\x76\x00\x66\x00\xe2\x00\x65\x00\xe4\x00\x5e\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x2b\x00\x5e\x00\x5d\x00\x5d\x00\xee\x00\xee\x00\x4a\x00\xf0\x00\xf1\x00\x4e\x00\x6c\x00\xf4\x00\x6b\x00\x66\x00\x2e\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x8f\x00\x6c\x00\x49\x00\x66\x00\x85\x00\x86\x00\x87\x00\x88\x00\x6c\x00\x65\x00\x0c\x00\x8c\x00\x66\x00\x09\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x49\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x7c\x00\x4e\x00\x07\x00\x55\x00\x56\x00\x57\x00\x19\x00\x23\x00\x2b\x00\x62\x00\x5c\x00\x2c\x00\x54\x00\x66\x00\x1a\x00\x68\x00\x69\x00\x42\x00\x61\x00\x4a\x00\x66\x00\x02\x00\x65\x00\x38\x00\x67\x00\x19\x00\x6c\x00\x3c\x00\x47\x00\x3e\x00\x3f\x00\x71\x00\x72\x00\x70\x00\x47\x00\x75\x00\x76\x00\x74\x00\x7b\x00\x47\x00\xc4\x00\x78\x00\x62\x00\xd5\x00\xd6\x00\x47\x00\xd8\x00\xd9\x00\xcc\x00\xcd\x00\x5c\x00\x07\x00\xd0\x00\xd1\x00\x8f\x00\x07\x00\xe2\x00\x4a\x00\xe4\x00\x19\x00\x47\x00\x84\x00\x47\x00\x62\x00\x6c\x00\x5c\x00\x85\x00\x66\x00\xee\x00\x68\x00\x69\x00\x4b\x00\x2d\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x55\x00\x66\x00\x84\x00\x62\x00\x85\x00\xee\x00\x2b\x00\xf0\x00\xf1\x00\x6b\x00\x66\x00\xf4\x00\x19\x00\x7c\x00\x65\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x62\x00\x85\x00\x5e\x00\x66\x00\x85\x00\x86\x00\x87\x00\x88\x00\x66\x00\x4a\x00\x6b\x00\x8c\x00\x8f\x00\x50\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x6d\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x54\x00\xd5\x00\xd6\x00\x62\x00\xd8\x00\xd9\x00\x5c\x00\xcb\x00\x79\x00\xcd\x00\x47\x00\x2c\x00\xd0\x00\x4b\x00\xe2\x00\x62\x00\xe4\x00\x07\x00\x19\x00\x66\x00\x50\x00\x68\x00\x69\x00\x38\x00\x5c\x00\x19\x00\xee\x00\x3c\x00\x61\x00\x3e\x00\x3f\x00\x4b\x00\x65\x00\xe5\x00\x67\x00\x6c\x00\xe8\x00\x19\x00\x4a\x00\x4a\x00\xc4\x00\x19\x00\xee\x00\x70\x00\xf0\x00\xf1\x00\x4a\x00\x74\x00\xcc\x00\xcd\x00\x4a\x00\x78\x00\xd0\x00\xd1\x00\x6d\x00\xd5\x00\xd6\x00\x62\x00\xd8\x00\xd9\x00\x8f\x00\x47\x00\x47\x00\x65\x00\x1a\x00\x7b\x00\x16\x00\x47\x00\xe2\x00\x47\x00\xe4\x00\x7b\x00\x47\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x7b\x00\x70\x00\x4b\x00\xee\x00\x4a\x00\xee\x00\x31\x00\xf0\x00\xf1\x00\x19\x00\x66\x00\xf4\x00\x4a\x00\x19\x00\x4a\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x6c\x00\x54\x00\x6d\x00\x66\x00\x85\x00\x86\x00\x87\x00\x88\x00\x66\x00\x4a\x00\x62\x00\x8c\x00\x7c\x00\x4a\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x47\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x47\x00\x54\x00\x4b\x00\x6c\x00\x4a\x00\x6c\x00\x4a\x00\xd5\x00\xd6\x00\x62\x00\xd8\x00\xd9\x00\x65\x00\x66\x00\x31\x00\x68\x00\x69\x00\x62\x00\x5e\x00\x49\x00\xe2\x00\x17\x00\xe4\x00\x38\x00\x69\x00\x6b\x00\x4b\x00\x3c\x00\x50\x00\x5e\x00\x6c\x00\x6c\x00\xee\x00\x66\x00\x62\x00\x66\x00\x6c\x00\x46\x00\x4a\x00\x0c\x00\xc4\x00\x6b\x00\x74\x00\x75\x00\x76\x00\x77\x00\x6d\x00\x5c\x00\xcc\x00\xcd\x00\x6d\x00\x6c\x00\xd0\x00\xd1\x00\x8f\x00\x74\x00\x75\x00\x76\x00\x77\x00\x56\x00\x56\x00\x64\x00\x8f\x00\x62\x00\x5e\x00\x66\x00\x65\x00\x66\x00\x66\x00\x68\x00\x69\x00\x66\x00\x68\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x66\x00\x66\x00\x6c\x00\x66\x00\x66\x00\xee\x00\x66\x00\xf0\x00\xf1\x00\x6d\x00\x15\x00\xf4\x00\x6d\x00\x4e\x00\x6b\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x0d\x00\x50\x00\x6c\x00\x47\x00\x85\x00\x86\x00\x87\x00\x88\x00\x47\x00\x47\x00\x7c\x00\x8c\x00\x8f\x00\x62\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x64\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x6c\x00\xd5\x00\xd6\x00\x66\x00\xd8\x00\xd9\x00\x68\x00\x8e\x00\x8c\x00\xd5\x00\xd6\x00\x8c\x00\xd8\x00\xd9\x00\xe2\x00\x66\x00\xe4\x00\x8c\x00\x66\x00\xd8\x00\xd9\x00\x64\x00\xe2\x00\x38\x00\xe4\x00\x62\x00\xee\x00\x3c\x00\x0d\x00\xe2\x00\x4a\x00\xe4\x00\xd8\x00\xd9\x00\xee\x00\x4e\x00\xd2\x00\x46\x00\xc2\x00\xc3\x00\xc4\x00\xee\x00\xe2\x00\x6c\x00\xe4\x00\x47\x00\xdc\x00\xdd\x00\xcc\x00\xcd\x00\x66\x00\x66\x00\xd0\x00\xd1\x00\xee\x00\xd5\x00\xd6\x00\x66\x00\xd8\x00\xd9\x00\x66\x00\x66\x00\xec\x00\xed\x00\x50\x00\xef\x00\x42\x00\x7b\x00\xe2\x00\xf3\x00\xe4\x00\x54\x00\x4e\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x47\x00\x47\x00\x47\x00\xee\x00\x47\x00\xee\x00\x31\x00\xf0\x00\xf1\x00\x4b\x00\x61\x00\xf4\x00\x6c\x00\x70\x00\x4b\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x47\x00\x47\x00\x1f\x00\x6b\x00\x85\x00\x86\x00\x87\x00\x88\x00\x6b\x00\x13\x00\x5e\x00\x8c\x00\x18\x00\x34\x00\x8f\x00\x15\x00\x91\x00\x92\x00\x96\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\x96\x00\x7b\x00\x11\x00\x23\x00\x96\x00\x65\x00\x49\x00\x4a\x00\x6c\x00\x62\x00\x61\x00\x2c\x00\x65\x00\x66\x00\x31\x00\x68\x00\x69\x00\x6c\x00\x55\x00\x56\x00\x57\x00\x7c\x00\x96\x00\x38\x00\x7b\x00\x5c\x00\x62\x00\x3c\x00\x7b\x00\x3e\x00\x96\x00\x51\x00\x68\x00\x69\x00\x4f\x00\x5d\x00\x96\x00\x4f\x00\xc2\x00\xc3\x00\xc4\x00\x62\x00\x6d\x00\x47\x00\x96\x00\x47\x00\x71\x00\x72\x00\xcc\x00\xcd\x00\x75\x00\x76\x00\xd0\x00\xd1\x00\x8f\x00\x4a\x00\x80\x00\x54\x00\x96\x00\x0c\x00\x00\x00\x0c\x00\x13\x00\x62\x00\x0c\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x8f\x00\xff\xff\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8f\x00\xff\xff\x8f\x00\x15\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xe2\x00\x67\x00\xe4\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\x38\x00\x70\x00\xff\xff\xee\x00\x3c\x00\x74\x00\xff\xff\xff\xff\xe2\x00\x78\x00\xe4\x00\xff\xff\xff\xff\xff\xff\x46\x00\x62\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xee\x00\xff\xff\x69\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xee\x00\x8f\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xff\xff\x3d\x00\xff\xff\xff\xff\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x7a\x00\x7b\x00\x8f\x00\x15\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x62\x00\xff\xff\xff\xff\xff\xff\x38\x00\xff\xff\x68\x00\x69\x00\x3c\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\x46\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xe2\x00\xe3\x00\xe4\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xee\x00\x8f\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x15\x00\xff\xff\x8f\x00\xff\xff\xf9\x00\xff\xff\xff\xff\xce\x00\xcf\x00\xd0\x00\xd1\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x86\x00\x87\x00\x88\x00\xf1\x00\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\x8f\x00\x15\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x20\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\xe2\x00\xff\xff\xe4\x00\x3c\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd8\x00\xd9\x00\xee\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\x15\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x9f\x00\xa0\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x86\x00\x87\x00\x88\x00\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\xc4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xc4\x00\x15\x00\xf7\x00\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9f\x00\xa0\x00\xff\xff\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\x62\x00\xf0\x00\xf1\x00\x65\x00\x66\x00\xf4\x00\x68\x00\x69\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xd0\x00\xd1\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xe2\x00\xd3\x00\xe4\x00\xff\xff\xff\xff\xe5\x00\xff\xff\x8f\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xee\x00\xdf\x00\xee\x00\xe1\x00\xff\xff\xf1\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x15\x00\xff\xff\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x62\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\x5c\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xee\x00\xcc\x00\xcd\x00\x15\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xd3\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xdf\x00\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x62\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xcc\x00\xcd\x00\xff\xff\x49\x00\xd0\x00\xd1\x00\xe2\x00\xe3\x00\xe4\x00\xff\xff\xad\x00\xae\x00\xaf\x00\x8f\x00\xff\xff\x55\x00\x56\x00\x57\x00\xee\x00\xb6\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xf9\x00\x15\x00\xff\xff\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\x6d\x00\xff\xff\xcc\x00\xcd\x00\x71\x00\x72\x00\xd0\x00\xd1\x00\x75\x00\x76\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9f\x00\xe6\x00\xe7\x00\xe8\x00\x8c\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xa9\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xf5\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xe3\x00\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\x8f\x00\xd0\x00\xd1\x00\x92\x00\xd3\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\x9f\x00\xff\xff\xff\xff\xff\xff\xa3\x00\xa4\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x49\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x52\x00\xff\xff\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\x66\x00\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\x6c\x00\xd0\x00\xd1\x00\xff\xff\xd3\x00\x71\x00\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\x9f\x00\xd8\x00\xd9\x00\xa2\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xc4\x00\xff\xff\xe2\x00\xce\x00\xe4\x00\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xff\xff\xff\xff\xe5\x00\xff\xff\xc4\x00\xe8\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xee\x00\xcc\x00\xcd\x00\xf1\x00\x8f\x00\xd0\x00\xd1\x00\xee\x00\xd3\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\x9f\x00\xff\xff\xff\xff\xa2\x00\xff\xff\xff\xff\x62\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x69\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x5f\x00\xff\xff\xc4\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xee\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\x8f\x00\xd0\x00\xd1\x00\xee\x00\xd3\x00\xff\xff\xff\xff\x8f\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\x9f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xe2\x00\xc4\x00\xe4\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xee\x00\xd0\x00\xd1\x00\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x9f\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x8f\x00\x8f\x00\xd0\x00\xd1\x00\xee\x00\xd3\x00\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xc4\x00\xc4\x00\x9f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x68\x00\x69\x00\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\x8f\x00\xd0\x00\xd1\x00\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xff\xff\xe1\x00\x15\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x62\x00\x5e\x00\xff\xff\x9f\x00\xff\xff\x62\x00\x63\x00\x69\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xe2\x00\xca\x00\xe4\x00\xff\xff\x15\x00\xce\x00\xff\xff\xd0\x00\xd1\x00\xc4\x00\xff\xff\xff\xff\xee\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\x8f\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xe5\x00\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xee\x00\xe1\x00\xff\xff\xf1\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x15\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xb7\x00\xe4\x00\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xd3\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xde\x00\xff\xff\xe0\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xe9\x00\xff\xff\xeb\x00\xec\x00\xed\x00\xc4\x00\xef\x00\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xe6\x00\xe7\x00\xe8\x00\xa6\x00\xa7\x00\xa8\x00\xff\xff\xff\xff\xee\x00\x49\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xbe\x00\x5c\x00\xff\xff\xff\xff\xff\xff\x15\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x66\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\x6c\x00\xd0\x00\xd1\x00\xff\xff\xff\xff\x71\x00\x72\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xad\x00\xae\x00\xaf\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xc4\x00\xb6\x00\xff\xff\xce\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xc4\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xe5\x00\xd0\x00\xd1\x00\xe8\x00\xe2\x00\xff\xff\xe4\x00\xec\x00\xed\x00\xee\x00\xef\x00\xff\xff\xf1\x00\xff\xff\xf3\x00\xff\xff\xee\x00\xff\xff\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xee\x00\x65\x00\xf0\x00\xf1\x00\x68\x00\x69\x00\xf4\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\x80\x00\x15\x00\xff\xff\xff\xff\xff\xff\x50\x00\xaa\x00\xab\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\x8f\x00\xff\xff\x5c\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\xcc\x00\xcd\x00\x75\x00\x76\x00\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xad\x00\xae\x00\xaf\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x15\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xaa\x00\xab\x00\xf4\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\xcc\x00\xcd\x00\x75\x00\x76\x00\xd0\x00\xd1\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xca\x00\xe6\x00\xe7\x00\xe8\x00\xce\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xbb\x00\xe5\x00\xbd\x00\xbe\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xee\x00\xff\xff\xff\xff\xf1\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xde\x00\xff\xff\xe0\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xbb\x00\xff\xff\xbd\x00\xbe\x00\xe9\x00\xff\xff\xeb\x00\xec\x00\xed\x00\xc4\x00\xef\x00\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xde\x00\xff\xff\xe0\x00\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbc\x00\xbd\x00\xbe\x00\xe9\x00\xff\xff\xeb\x00\xec\x00\xed\x00\xc4\x00\xef\x00\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xb3\x00\xb4\x00\xb5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x3c\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\x8c\x00\xd0\x00\xd1\x00\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x49\x00\xff\xff\x4b\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\x55\x00\x56\x00\x57\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x5c\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xcc\x00\xcd\x00\x71\x00\x72\x00\xd0\x00\xd1\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x49\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xaf\x00\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb6\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\xff\xff\x5e\x00\x75\x00\x76\x00\x61\x00\x62\x00\x63\x00\xc4\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\x8f\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xc4\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\x8f\x00\xf0\x00\xf1\x00\xd5\x00\xd6\x00\xf4\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xd5\x00\xd6\x00\xf4\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\x62\x00\xff\xff\xd0\x00\xd1\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x8f\x00\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xc4\x00\x15\x00\xff\xff\xee\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x49\x00\x4a\x00\x15\x00\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x5c\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xcc\x00\xcd\x00\x71\x00\x72\x00\xd0\x00\xd1\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x15\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\x66\x00\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\x6c\x00\xd0\x00\xd1\x00\x15\x00\x8f\x00\x71\x00\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\x68\x00\x69\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xb8\x00\xb9\x00\xff\xff\xff\xff\x62\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x68\x00\x69\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xb9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x8f\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xcc\x00\xcd\x00\xf4\x00\xff\xff\xd0\x00\xd1\x00\x8f\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x15\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xee\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xe2\x00\xc4\x00\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x15\x00\xcc\x00\xcd\x00\xff\xff\xee\x00\xd0\x00\xd1\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xcc\x00\xcd\x00\xff\xff\x8f\x00\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\x68\x00\x69\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x8f\x00\x8f\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\x68\x00\x69\x00\xf4\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xee\x00\xee\x00\xf0\x00\xf1\x00\xc4\x00\xff\xff\xf4\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\x15\x00\xd0\x00\xd1\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xd5\x00\xd6\x00\x15\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\x8f\x00\xd0\x00\xd1\x00\xff\xff\xc4\x00\xee\x00\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\x8f\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xc4\x00\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xcc\x00\xcd\x00\x8f\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xc4\x00\xf4\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\x99\x00\x9a\x00\xc4\x00\x9c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\x62\x00\xff\xff\xff\xff\xe6\x00\xe7\x00\xe8\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xee\x00\xff\xff\xf0\x00\xf1\x00\xff\xff\xff\xff\xf4\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xee\x00\x16\x00\xf0\x00\xf1\x00\xff\xff\x1a\x00\xf4\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x52\x00\xe4\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x8f\x00\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xec\x00\xed\x00\xee\x00\xef\x00\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\x8f\x00\xff\xff\xf7\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x52\x00\xe4\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\x62\x00\x68\x00\x69\x00\x4c\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\x8f\x00\xff\xff\x73\x00\x74\x00\xff\xff\x8f\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xc4\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\x49\x00\x4a\x00\x4b\x00\xee\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xee\x00\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x5e\x00\xff\xff\x55\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\x8f\x00\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x8f\x00\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xc4\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xc4\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xee\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xe2\x00\xff\xff\xe4\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x5e\x00\xff\xff\xff\xff\x56\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x8f\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x8f\x00\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xc4\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd5\x00\xd6\x00\x2c\x00\xd8\x00\xd9\x00\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\x62\x00\x68\x00\x69\x00\xff\xff\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x8f\x00\x69\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x8f\x00\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xc4\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd5\x00\xd6\x00\x2c\x00\xd8\x00\xd9\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xc4\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x8f\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x8f\x00\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xc4\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd5\x00\xd6\x00\x2c\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xff\xff\xe2\x00\x5f\x00\xe4\x00\xff\xff\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xee\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x8f\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xff\xff\x01\x00\x02\x00\xff\xff\x88\x00\x89\x00\x8a\x00\x8b\x00\xff\xff\x8d\x00\x0a\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd5\x00\xd6\x00\x2c\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\x4e\x00\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\x62\x00\x55\x00\x56\x00\x57\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\x50\x00\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\x57\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x55\x00\x56\x00\x57\x00\x66\x00\xff\xff\x68\x00\x69\x00\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\x50\x00\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\x57\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\x62\x00\x55\x00\x56\x00\x57\x00\x66\x00\xff\xff\x68\x00\x69\x00\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x5d\x00\x6c\x00\x6d\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\xff\xff\x8f\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xc4\x00\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\x5d\x00\x68\x00\x69\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xee\x00\x4e\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\x54\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x5d\x00\xe4\x00\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\x5d\x00\xff\xff\xff\xff\x5c\x00\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\x6d\x00\xff\xff\xff\xff\x74\x00\x71\x00\x72\x00\xff\xff\x78\x00\x75\x00\x76\x00\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\xff\xff\xff\xff\x56\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\x5d\x00\x68\x00\x69\x00\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x8f\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xc4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x56\x00\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xe2\x00\x5d\x00\xe4\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\x6d\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xc4\x00\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\xc4\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x8f\x00\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\x62\x00\xff\xff\x3b\x00\x3c\x00\x66\x00\xff\xff\x68\x00\x69\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\x64\x00\x65\x00\xee\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x8f\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x8f\x00\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xc4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xe2\x00\xff\xff\xe4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\x62\x00\xff\xff\x3b\x00\x3c\x00\x66\x00\xff\xff\x68\x00\x69\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\x64\x00\x65\x00\xee\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\x8f\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x8f\x00\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xc4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xe2\x00\xff\xff\xe4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\x3b\x00\x3c\x00\x62\x00\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xee\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\x5d\x00\x68\x00\x69\x00\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x8f\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xc4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\x56\x00\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xe2\x00\x5d\x00\xe4\x00\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x62\x00\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x56\x00\x65\x00\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xc4\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\x62\x00\xc4\x00\x3b\x00\x3c\x00\x66\x00\x62\x00\x68\x00\x69\x00\xe2\x00\x66\x00\xe4\x00\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xee\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\x8f\x00\x67\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\x3b\x00\x3c\x00\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\x56\x00\xff\xff\x66\x00\xff\xff\x68\x00\x69\x00\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\x68\x00\x69\x00\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\x8f\x00\x61\x00\xff\xff\x63\x00\xee\x00\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xd5\x00\xd6\x00\x2c\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xe4\x00\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\x02\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x0a\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x3b\x00\x3c\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x8f\x00\x90\x00\x78\x00\x16\x00\xff\xff\x94\x00\x95\x00\x02\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x0a\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x3b\x00\x3c\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x02\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x0a\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x3b\x00\x3c\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x02\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\x6f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xcb\x00\x2c\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xdd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe5\x00\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x54\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xff\xff\x16\x00\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x02\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x65\x00\xff\xff\x8f\x00\x90\x00\xff\xff\x0a\x00\xff\xff\x94\x00\x95\x00\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x7b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x65\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x6f\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\x02\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x0a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xcb\x00\x2c\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe5\x00\xff\xff\xff\xff\xe8\x00\x49\x00\xff\xff\xff\xff\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\x02\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x0a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\x13\x00\x78\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xdd\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xe5\x00\x73\x00\x74\x00\xe8\x00\xff\xff\x77\x00\x78\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\x02\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x48\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x16\x00\x77\x00\x78\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x16\x00\x77\x00\x78\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x16\x00\x77\x00\x78\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x16\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x16\x00\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\x57\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x16\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x50\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x57\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x16\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x16\x00\x74\x00\xff\xff\xff\xff\x1a\x00\x78\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\x02\x00\x2c\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\x16\x00\x74\x00\xff\xff\xff\xff\x1a\x00\x78\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\x16\x00\xff\xff\x48\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\x16\x00\x73\x00\xff\xff\xff\xff\x1a\x00\x77\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\x49\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x02\x00\xff\xff\xff\xff\x65\x00\x66\x00\x67\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x6f\x00\x70\x00\x71\x00\x72\x00\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x0a\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x6f\x00\x70\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x0a\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x6f\x00\x70\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x0a\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x6f\x00\x70\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x6f\x00\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x6f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x6f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x16\x00\xff\xff\xff\xff\x6f\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x0a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x6f\x00\x02\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x0a\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\xf7\x02\xf3\x00\xf4\x00\xf5\x00\x27\x00\x28\x00\xf6\x00\x10\x05\x11\x05\x64\x04\x07\x05\x29\x00\x76\x00\x2a\x00\xaf\x04\xf9\x00\x9f\x03\x85\x03\x0b\x03\xfa\x04\xd1\x03\x34\x02\xb5\x04\x34\x02\x02\x05\x62\x04\x63\x04\x64\x04\x76\x00\xfa\x00\xfb\x00\xfe\x04\x62\x04\x63\x04\x64\x04\x61\x04\x62\x04\x63\x04\x64\x04\xb5\x00\x25\x03\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\xf6\x04\xce\x01\xcf\x01\x14\x04\xf8\x03\x54\x03\x19\x03\xb7\x02\xcd\x00\xeb\xff\xeb\xff\x52\x02\xce\x00\xcf\x00\x3b\x04\x3c\x04\x67\x00\xd0\x00\xf2\x02\xf7\x03\xf8\x03\xb6\x00\xda\x04\x64\x04\x1c\x03\x57\x01\x39\x01\xe4\xfe\xb7\x03\x31\x02\xe4\xfe\x07\x03\x29\xfd\x29\xfd\x15\x05\xe1\x04\x64\x04\x99\x03\x89\xfe\x6c\x04\x64\x04\x13\x05\xb8\x04\x21\x01\x04\x05\x4a\x01\xb5\x02\x43\x03\xd1\x00\xfb\x04\xd2\x03\x4b\x01\x2b\x02\x9b\x01\x99\x01\x3f\x03\x34\x02\x72\x00\xb8\x03\x22\x01\xf3\x02\x75\x00\xe3\xfe\x07\x03\x29\xfd\xe3\xfe\x80\x02\xb6\x04\x86\x03\x39\x00\x26\x03\x35\x02\x1a\x03\x35\x02\x2a\x03\x3a\x01\xed\x00\x9c\x02\x87\x03\x66\x02\x3b\x00\x44\x03\x0c\x03\x2d\x00\xf8\x00\xee\x00\xd0\x01\xed\x00\x77\x00\xed\x00\x3c\x00\x53\x02\x3d\x04\x32\x02\xd2\x00\xd3\x00\xd4\x00\x53\x02\x74\x01\x81\x00\xdd\x04\xd5\x00\xb0\x04\xf9\x00\x77\x00\x55\x01\xd6\x00\x7a\x00\x81\x02\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\xfa\x00\xfb\x00\xd0\x01\xee\x00\xed\x00\x2e\x00\x2e\x00\x8e\x03\xd1\x01\x2b\x03\xb5\x00\xb8\x02\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\x10\x00\x5e\x04\xcf\x01\xd0\x01\xfe\x03\xb2\x04\xb3\x04\x86\x00\xcd\x00\x3d\x04\x62\x02\x9b\x01\xce\x00\xcf\x00\xbf\x02\x87\x00\x58\x00\xd0\x00\x35\x02\x59\x00\x5a\x00\xb6\x00\xf9\x03\x86\x00\x44\x03\xfa\x02\xfb\x02\x79\x03\x10\x00\x3f\x03\xff\x03\x87\x00\x58\x00\xf3\x03\xc4\x02\x59\x00\x5a\x00\xc8\x02\xf9\x03\xd0\x01\xd0\x01\x75\x01\x0e\x00\x0f\x00\x10\x00\x27\x03\x27\x03\xb8\x02\xd1\x00\x10\x00\xc0\x02\x62\x00\x63\x00\x10\x00\xb4\x03\x89\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\xd0\x01\x65\x04\x8e\x02\x66\x04\x67\x04\x10\x00\x27\x03\x62\x00\x63\x00\x05\x05\xc5\x02\x89\x00\x2b\x00\xc9\x02\x2b\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x65\x04\x01\x03\x66\x04\x67\x04\xb9\x03\xbb\x04\x6b\x04\x65\x04\x6c\x04\x66\x04\x67\x04\x65\x04\x8e\x02\x66\x04\x67\x04\xd2\x00\xd3\x00\xd4\x00\xbc\x04\xe5\x04\xe6\x04\x6f\x04\xd5\x00\xf8\x00\xf9\x00\x77\x00\xf7\x04\xd6\x00\x7a\x00\x34\x02\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\xfa\x00\xfb\x00\xd0\x01\xfc\x01\x65\x04\x48\x02\x66\x04\x67\x04\xd1\x01\xc2\x02\xb5\x00\x49\x02\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\x65\x04\x6f\x02\x66\x04\x67\x04\x65\x04\xd0\x01\x66\x04\x67\x04\xcd\x00\x01\x05\x29\xfd\x85\x04\xce\x00\xcf\x00\x67\x00\x87\x00\x58\x00\xd0\x00\xc3\x02\x59\x00\x5a\x00\xb6\x00\x1b\x01\x86\x00\x4a\x02\xbc\x01\xbd\x01\xf9\x04\x34\x02\x34\x02\xfc\x02\x87\x00\x58\x00\x0c\x01\xed\x00\x59\x00\x5a\x00\xfc\x02\x0b\x02\x10\x00\x0c\x01\x75\x01\x0e\x00\x0f\x00\xd0\x04\xd5\x01\x10\x00\xb8\x04\xd1\x00\x10\x00\xb7\x02\x62\x00\x63\x00\x63\x02\xbe\x01\x72\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x34\x02\xf0\x01\x39\x00\x64\x02\x65\x02\x10\x00\x0c\x02\x62\x00\x63\x00\xb1\x04\x35\x02\x89\x00\x0d\x02\xf1\x01\xde\x04\xd7\x00\xd8\x00\xd9\x00\xda\x00\xee\x01\x60\x00\xbc\x04\x61\x00\x3c\x00\xfc\x02\xbc\x04\x66\x02\x0c\x01\x34\x02\xcd\x01\xce\x01\xcf\x01\x92\x04\x10\x00\xd2\x00\xd3\x00\xd4\x00\xca\x03\xd5\x01\x12\x05\x6f\x04\xd5\x00\xfe\x00\xf9\x00\x77\x00\x93\x04\xd6\x00\x7a\x00\x9c\x04\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\xfa\x00\xfb\x00\xfd\x01\x34\x02\x9d\x04\x0c\x01\x67\x00\x35\x02\x35\x02\x3c\x03\xb5\x00\x10\x00\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\xfd\x01\x93\x04\x9d\x04\x0c\x01\xbd\x04\x3d\x03\x1c\x03\xd5\x01\xcd\x00\x10\x00\x44\x03\xd5\x01\xce\x00\xcf\x00\x3e\x03\x87\x00\x58\x00\xd0\x00\x4a\x01\x59\x00\x5a\x00\xb6\x00\x35\x02\x86\x00\x4b\x01\x99\x03\xd6\x01\x3f\x03\x3b\x00\xec\x04\x72\x00\x87\x00\x58\x00\x3d\x03\x00\x04\x59\x00\x5a\x00\x1c\x01\x3c\x00\x59\x00\x0a\x01\x75\x01\x0e\x00\x0f\x00\x01\x04\xf8\x01\xd5\x01\x4c\x02\xd1\x00\x10\x00\x35\x02\x62\x00\x63\x00\x4d\x02\x8d\x01\xc4\x04\xb9\x00\x88\x00\x0e\x00\xba\x00\x70\x03\x3f\x03\xcc\x04\x1d\x01\x13\x04\x10\x00\x8e\x01\x62\x00\x63\x00\x10\x00\x10\x00\x89\x00\x0d\x01\x71\x03\xd0\x01\xd7\x00\xd8\x00\xd9\x00\xda\x00\xd6\x01\xd1\x01\x3b\x00\x35\x02\x4e\x02\x8b\x04\xf4\x04\x59\x00\x0a\x01\xd4\x01\xd5\x01\x02\x02\x3c\x00\xdf\x04\x71\x03\xd2\x00\xd3\x00\xd4\x00\xa4\x03\x25\x02\xc4\x03\x03\x02\xd5\x00\x0c\x01\xda\x02\x77\x00\x7a\x04\xd6\x00\x7a\x00\x10\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\xf9\x02\xdb\x02\x0d\x01\x69\x04\x99\x03\xd6\x01\x10\x00\x3b\x00\xf1\x04\xd6\x01\xb5\x00\x3b\x00\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\x3c\x00\x26\x02\x0e\x00\x0f\x00\x3c\x00\xbc\x01\xbd\x01\x99\x03\xcd\x00\x10\x00\x83\x02\x5f\x04\xce\x00\xcf\x00\xae\x01\x87\x00\x58\x00\xd0\x00\x6c\x00\x59\x00\x5a\x00\xb6\x00\x1f\x01\x86\x00\x6e\x00\x11\x01\x12\x01\xd6\x01\x7b\x04\x3b\x00\x83\x02\x87\x00\x58\x00\x70\x00\xae\x01\x59\x00\x5a\x00\xe0\xfe\x82\x04\x3c\x00\xe0\xfe\x75\x01\x0e\x00\x0f\x00\x58\x01\x83\x04\x59\x00\x0a\x01\xd1\x00\x10\x00\xed\x02\x62\x00\x63\x00\x68\x00\x69\x00\x6a\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x6b\x00\xe6\x03\xf7\x01\x3b\x00\x3b\x00\x10\x00\xdf\xfe\x62\x00\x63\x00\xdf\xfe\xd6\x01\x89\x00\x3b\x00\x3c\x00\x3c\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x0d\x01\x0f\x05\x71\x00\x3c\x00\x98\x04\xf1\x03\x6d\x04\x10\x05\x0c\x01\x6e\x04\x6f\x04\x87\x02\x0f\x00\x59\x02\x10\x00\xd2\x00\xd3\x00\xd4\x00\x10\x00\x9a\x04\xaa\x01\x63\x00\xd5\x00\xf3\x04\x8a\x04\x77\x00\x76\x00\xd6\x00\x7a\x00\x9e\x04\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xb5\x00\x9f\x04\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\xdb\x04\x58\x00\xad\x01\x65\x00\x59\x00\x5a\x00\xaa\x04\xae\x01\xcd\x00\xa9\x01\x0f\x00\x99\x03\xce\x00\xcf\x00\xac\x04\x9a\x03\x10\x00\xd0\x00\xaa\x01\x63\x00\x3b\x04\xb6\x00\x13\x01\x14\x01\x07\x03\x08\x03\x09\x03\x09\x01\x56\x00\x59\x00\x0a\x01\x4d\x00\x4c\x03\x0d\x04\x86\x00\x4e\x00\x62\x00\x63\x00\x10\x00\x4f\x00\xaa\x01\x63\x00\x87\x00\x58\x00\x17\x01\x14\x01\x59\x00\x5a\x00\xd1\x00\x09\x01\x0b\x01\x59\x00\x0a\x01\x0c\x01\xd0\x01\x5d\x04\x11\x03\x12\x03\x13\x03\x10\x00\xff\x01\x5e\x04\x0d\x01\x8b\x04\x8c\x04\x59\x00\x0a\x01\xb9\x00\x88\x00\x0e\x00\xba\x00\x8d\x04\x0b\x01\x38\x00\x39\x00\x0c\x01\x10\x00\x08\x02\x62\x00\x63\x00\x1a\x04\x10\x00\x89\x00\x09\x02\x0d\x01\x26\x04\xd7\x00\xd8\x00\xd9\x00\xda\x00\xae\x04\x4c\x03\xaf\x04\x18\x02\xd2\x00\xd3\x00\xd4\x00\x10\x00\x0d\x01\x09\x02\xf8\x02\xd5\x00\x8c\x02\x59\x02\x77\x00\x31\x04\xd6\x00\x7a\x00\x4b\x01\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x25\x04\x13\x03\x5a\x02\x23\x02\x24\x02\x25\x02\x32\x04\xa9\x02\x11\x02\x60\x00\xb5\x00\x61\x00\xfc\x00\xfd\x00\xca\x00\xcb\x00\xcc\x00\x17\x04\x4d\x00\x18\x04\x11\x02\x60\x00\x4e\x00\x61\x00\xe9\x01\xcd\x00\x4f\x00\x83\x02\xea\x01\xce\x00\xcf\x00\xae\x01\x87\x00\x58\x00\xd0\x00\xe3\x02\x59\x00\x5a\x00\xb6\x00\xe4\x02\x86\x00\xe9\x01\x26\x02\x0e\x00\x0f\x00\xea\x01\x38\x04\x32\x01\x87\x00\x58\x00\x10\x00\xed\xfe\x59\x00\x5a\x00\xed\xfe\x68\x00\x69\x00\x6a\x00\x75\x01\x0e\x00\x0f\x00\x9b\x02\x6b\x00\xe7\x02\x9c\x02\xd1\x00\x10\x00\xe8\x02\x62\x00\x63\x00\x7b\x02\x0e\x00\x0f\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x0e\x02\x10\x00\xe2\x04\xfb\x00\x09\x02\x10\x00\x71\x00\x62\x00\x63\x00\x3e\x04\x74\x00\x89\x00\x7e\x02\x0e\x00\x0f\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xa7\x02\x10\x00\x38\x00\x39\x00\x81\x02\x0e\x00\x0f\x00\x75\x04\x83\x03\x84\x03\x85\x03\xe9\x04\x10\x00\x3f\x04\x1b\x02\xd2\x00\xd3\x00\xd4\x00\x09\x02\x57\x00\x58\x00\x31\x04\xd5\x00\x59\x00\x5a\x00\x77\x00\x5b\x00\xd6\x00\x7a\x00\x32\x04\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x55\x02\x61\x02\x5c\x00\x5b\x02\x4b\x01\x4b\x01\xa0\x04\xa1\x04\x0d\x00\x0e\x00\x0f\x00\x5d\x00\x76\x00\x5e\x00\x5f\x00\x60\x00\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xed\x00\xb5\x00\xef\x00\xf0\x00\xdc\x02\xca\x00\xcb\x00\xcc\x00\x02\x04\x62\x01\x37\x00\x33\x01\x38\x00\x39\x00\xba\x02\x1c\x04\xcd\x00\x1d\x04\xbb\x02\x86\x00\xce\x00\xcf\x00\x34\x01\x58\x04\x35\x01\xd0\x00\xe9\x01\x87\x00\x58\x00\xb6\x00\xea\x01\x59\x00\x5a\x00\x5d\x00\x7c\x01\x5e\x00\x5f\x00\x60\x00\x4b\x01\x61\x00\x2e\x00\x95\x03\x64\x00\x65\x00\xab\x02\xad\x03\x23\x01\x33\x00\x86\x03\x39\x00\xe3\x04\xfb\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\xd1\x00\x37\x04\x87\x03\x38\x04\x3b\x00\x10\x00\x08\x01\x62\x00\x63\x00\xb0\x03\x09\x01\x89\x00\x59\x00\x0a\x01\x3c\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x39\x04\x39\x00\x89\x04\x8a\x04\xc8\x03\xc9\x03\x5a\x04\x83\x03\x84\x03\x85\x03\x34\x00\x03\x01\x0e\x00\x0f\x00\x0b\x01\xd4\x03\x9b\x01\x0c\x01\x57\x04\x10\x00\x04\x04\x62\x01\x37\x00\x10\x00\x38\x00\x39\x00\x0d\x01\xd2\x00\xd3\x00\xd4\x00\xe1\x03\xcc\x02\x62\x01\x37\x00\xd5\x00\x38\x00\x39\x00\x77\x00\x76\x00\xd6\x00\x7a\x00\xd6\x03\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xb5\x00\x59\x01\xe0\x03\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6c\x00\xa3\x04\xa1\x04\x5c\x01\x8f\x04\x5d\x01\x6e\x00\xe3\x03\xcd\x00\x2e\x00\xbc\x01\xbd\x01\xce\x00\xcf\x00\xe9\x03\x90\x04\xd9\x01\xd0\x00\xe5\x03\x4e\x00\xe6\x03\xb6\x00\xec\x03\x4f\x00\x36\x00\x37\x00\xee\x03\x38\x00\x39\x00\xf5\x03\x8b\x04\x8c\x04\x59\x00\x0a\x01\x86\x00\x52\x01\x53\x01\x3a\x00\x8d\x04\x3b\x00\x38\x00\x39\x00\x87\x00\x58\x00\xbb\x02\xbc\x02\x59\x00\x5a\x00\xd1\x00\x3c\x00\x86\x03\x39\x00\x05\x04\xeb\x03\x34\x00\xec\x03\x42\x02\x2e\x00\x43\x02\x07\x04\x87\x03\xab\x02\x3b\x00\x23\x01\x33\x00\x0d\x01\x09\x04\xb9\x00\x88\x00\x0e\x00\xba\x00\x5c\x01\x3c\x00\x5d\x01\xfc\x04\x6d\x01\x10\x00\x6e\x01\x62\x00\x63\x00\x18\x01\x19\x01\x89\x00\x05\x01\x0e\x00\x0f\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x92\x01\x10\x00\x93\x01\x08\x04\xd2\x00\xd3\x00\xd4\x00\xdd\x02\x52\x04\x53\x04\x54\x04\xd5\x00\x34\x00\x55\x04\x77\x00\x76\x00\xd6\x00\x7a\x00\xe0\x02\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xb5\x00\xf0\x02\x0d\x00\x0e\x00\x0f\x00\xed\x04\x55\x01\x53\x01\x36\x00\x37\x00\x10\x00\x38\x00\x39\x00\x2e\x00\x1d\x04\x1e\x04\x5c\x01\xab\x02\x5d\x01\x23\x01\x33\x00\x3a\x00\xee\x02\x3b\x00\xd0\x00\xcd\x02\x62\x01\x37\x00\xb6\x00\x38\x00\x39\x00\x59\x01\x5a\x01\x3c\x00\x1f\x04\x20\x04\xf3\x02\x92\x01\x66\x02\x93\x01\xf8\x02\x86\x00\x57\x01\x53\x01\x75\x04\x83\x03\x84\x03\x85\x03\x76\x04\x87\x00\x58\x00\x67\x00\x05\x03\x59\x00\x5a\x00\xeb\x02\x36\x00\x37\x00\x34\x00\x38\x00\x39\x00\x59\x01\x95\x01\x68\x00\x69\x00\x6a\x00\x97\x02\x98\x02\x99\x02\x3a\x00\x6b\x00\x3b\x00\xe4\x01\xfb\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\xd1\x02\x98\x02\x99\x02\x3c\x00\x0c\x03\x10\x00\x10\x03\x62\x00\x63\x00\x68\x02\x14\x03\x89\x00\x62\x03\x71\x00\x72\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x29\x01\x2a\x01\x2b\x01\x2c\x01\xd2\x00\xd3\x00\x71\x02\x21\x04\xcf\x02\x62\x01\x37\x00\xd5\x00\x38\x00\x39\x00\x77\x00\x76\x00\x73\x02\x7a\x00\x31\x02\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\xe5\x01\xfb\x00\x07\x03\x05\x03\x36\x00\x37\x00\x40\x03\x38\x00\x39\x00\xc3\x04\x4d\x04\x4e\x04\x41\x03\x1d\x04\x1e\x04\x15\x01\x16\x01\x3a\x00\x4f\x03\x3b\x00\x86\x03\x39\x00\x75\x03\xd0\x00\xac\x01\x7c\x01\x60\x00\xb6\x00\x61\x00\x3c\x00\x87\x03\x79\x03\x3b\x00\x1f\x04\x24\x04\xb0\x02\xb1\x02\xb2\x02\xb3\x02\xb4\x02\x86\x00\x71\x03\x3c\x00\x97\x03\x83\x03\x84\x03\x85\x03\xdb\x02\x87\x00\x58\x00\x13\x01\x14\x01\x59\x00\x5a\x00\x94\x03\x09\x01\x2f\x02\x59\x00\x0a\x01\xdf\x02\xe0\x02\xe7\x01\x35\x02\x40\x02\x2e\x00\x55\x02\xb9\x01\x8f\x02\xab\x02\x9d\x02\x23\x01\x33\x00\xa1\x02\xb9\x00\x88\x00\x0e\x00\xba\x00\xae\x02\x0b\x01\xb4\x02\xc0\x02\x0c\x01\x10\x00\xd3\x02\x62\x00\x63\x00\xc6\x02\x10\x00\x89\x00\xc9\x02\x0d\x01\xd5\x02\xd7\x00\xd8\x00\xd9\x00\xda\x00\xd6\x02\x00\x01\x1f\x01\x27\x01\xd2\x00\xd3\x00\x71\x02\x21\x04\x37\x01\x5f\x01\x6b\x01\xd5\x00\x90\x01\x34\x00\x77\x00\x76\x00\x73\x02\x7a\x00\xab\x01\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\xac\x01\x7c\x01\x60\x00\x94\x01\x61\x00\x9c\x01\xf1\x00\xad\x01\x65\x00\xee\x00\x17\x01\x14\x01\xae\x01\x1d\x04\x1e\x04\x09\x01\x15\x05\x59\x00\x0a\x01\xd6\x03\x86\x03\x39\x00\x17\x05\xd0\x00\x04\x05\xd6\x03\xd8\x03\xb6\x00\x07\x05\xed\x00\x87\x03\xc1\x01\x3b\x00\xbf\x04\xc3\x01\x0d\x05\xc4\x01\xeb\x01\x0b\x01\xeb\x04\x86\x00\x0c\x01\x3c\x00\x0e\x05\xe5\x04\xee\x00\xf0\x04\x10\x00\x87\x00\x58\x00\x0d\x01\x2e\x00\x59\x00\x5a\x00\xee\x00\xf1\x04\x36\x00\x37\x00\xd9\x01\x38\x00\x39\x00\x41\xfd\xc6\x01\xc7\x01\x07\x03\x01\x05\xc8\x01\xc9\x01\xfe\x04\x3a\x00\x00\x05\x3b\x00\xba\x04\xb9\x00\x88\x00\x0e\x00\xba\x00\x93\x04\xc7\x04\x8b\xfd\xc9\x04\x3c\x00\x10\x00\xca\x04\x62\x00\x63\x00\xd0\x04\xcb\x04\x89\x00\xcc\x04\xce\x04\xd6\x04\xd7\x00\xd8\x00\xd9\x00\xda\x00\x34\x00\xcf\x04\xd7\x04\xd9\x04\xd2\x00\xd3\x00\x71\x02\x21\x04\xda\x04\xe1\x04\xf3\x00\xd5\x00\x75\x04\x78\x04\x77\x00\x76\x00\x73\x02\x7a\x00\x67\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x79\x04\x9b\x01\xd6\x03\x68\x00\x69\x00\x6a\x00\x1c\x03\x9a\x04\x9d\x04\x2e\x00\x6b\x00\x27\x04\x81\x04\x94\x04\x85\x04\x23\x01\x33\x00\x3a\x01\x6c\x00\xa9\x04\x4a\x01\xac\x04\xdd\x04\xd0\x00\x6e\x00\x0b\x04\x4b\x01\xb6\x00\x0c\x04\x28\x04\x29\x04\x71\x00\x72\x00\x70\x00\x0d\x04\x74\x00\x75\x00\x73\x00\x11\x04\x0f\x04\x86\x00\x76\x00\x12\x04\x36\x00\x37\x00\x10\x04\x38\x00\x39\x00\x87\x00\x58\x00\x16\x04\xd6\x03\x59\x00\x5a\x00\x34\x00\xd6\x03\x3a\x00\x1a\x04\x3b\x00\xd8\x03\x41\x04\xed\x00\x42\x04\x2e\x00\x43\x04\x46\x04\xee\x00\xab\x02\x3c\x00\x23\x01\x33\x00\x40\x03\x4f\x04\xb9\x00\x88\x00\x0e\x00\xba\x00\x58\x04\x5a\x04\xed\x00\x5c\x04\xee\x00\x10\x00\xaa\x02\x62\x00\x63\x00\x31\x02\x61\x04\x89\x00\x69\x04\xab\x03\x97\x03\xd7\x00\xd8\x00\xd9\x00\xda\x00\x9c\x03\xee\x00\xac\x03\xa2\x03\xd2\x00\xd3\x00\x71\x02\x2a\x04\xa3\x03\xaf\x03\xb0\x03\xd5\x00\x34\x00\xb3\x03\x77\x00\x76\x00\x73\x02\x7a\x00\xbb\x03\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\xcc\x03\x36\x00\x37\x00\xcf\x03\x38\x00\x39\x00\xc4\x03\xb1\x01\x50\x00\xb2\x01\xd1\x03\x27\x04\xb3\x01\xd4\x03\x3a\x00\x2e\x00\x3b\x00\xd6\x03\xd8\x03\xab\x02\xdc\x03\x23\x01\x33\x00\xd0\x00\xe0\x03\x1c\x03\x3c\x00\xb6\x00\x6c\x00\x28\x04\x2e\x04\xe3\x03\x8f\x04\xb4\x01\x6e\x00\xe9\x03\x0c\x01\xf0\x03\x65\xfd\x63\xfd\x86\x00\xf7\x03\x10\x00\x90\x04\x62\x00\x63\x00\x64\xfd\x4e\x00\x87\x00\x58\x00\xf3\x03\x4f\x00\x59\x00\x5a\x00\xf5\x03\x36\x00\x37\x00\xfd\x03\x38\x00\x39\x00\x34\x00\x02\x04\x04\x04\x97\x03\xf5\x02\x07\x04\xe2\x02\xe6\x02\x3a\x00\xe9\x02\x3b\x00\xf0\x02\xea\x02\xb9\x00\x88\x00\x0e\x00\xba\x00\x1b\x01\x70\x00\x05\x03\x3c\x00\x07\x03\x10\x00\xbe\x04\x62\x00\x63\x00\x0e\x03\x10\x03\x89\x00\x07\x03\x16\x03\x1e\x03\xd7\x00\xd8\x00\xd9\x00\xda\x00\x6e\xfd\x25\x03\x2d\x03\x30\x03\xd2\x00\xd3\x00\x71\x02\x2a\x04\x31\x03\x32\x03\x33\x03\xd5\x00\x34\x03\x35\x03\x77\x00\x76\x00\x73\x02\x7a\x00\x36\x03\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x37\x03\x4c\x03\x40\x03\x4e\x03\x46\x03\x4b\x01\x64\x03\x36\x00\x37\x00\x2e\x00\x38\x00\x39\x00\x30\x01\x31\x01\x28\x03\x32\x00\x33\x00\x2e\x00\x4f\x03\x6e\x03\x3a\x00\x75\x03\x3b\x00\xd0\x00\xb1\x03\x31\x02\x7b\x03\xb6\x00\x78\x03\x7d\x03\x77\x03\x7c\x03\x3c\x00\x4a\xfd\x7e\x03\x7f\x03\x80\x03\x70\x02\x90\x03\xf3\x00\x86\x00\xeb\x01\x9c\x03\x83\x03\x84\x03\x85\x03\x91\x03\xfa\x01\x87\x00\x58\x00\x92\x03\x8d\x03\x59\x00\x5a\x00\x34\x00\x9e\x03\x83\x03\x84\x03\x85\x03\xfb\x01\xfc\x01\x04\x02\x34\x00\x2e\x00\x01\x02\x05\x02\x30\x01\x31\x01\x06\x02\x32\x00\x33\x00\x07\x02\x0f\x02\xb9\x00\x88\x00\x0e\x00\xba\x00\x0a\x02\x16\x02\x10\x02\x17\x02\x19\x02\x10\x00\x1a\x02\x62\x00\x63\x00\x1c\x02\x2b\x02\x89\x00\x1d\x02\x9b\x01\x31\x02\xd7\x00\xd8\x00\xd9\x00\xda\x00\x37\x02\x38\x02\x46\x02\x3c\x02\xd2\x00\xd3\x00\x71\x02\x72\x02\x3d\x02\x3e\x02\x3f\x02\xd5\x00\x34\x00\x47\x02\x77\x00\x76\x00\x73\x02\x7a\x00\x4b\x02\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x46\x02\x36\x00\x37\x00\x4f\x02\x38\x00\x39\x00\x52\x02\x5e\x02\x57\x02\x36\x00\x37\x00\x59\x02\x38\x00\x39\x00\x3a\x00\x5f\x02\x3b\x00\x5d\x02\x60\x02\x86\x03\x39\x00\xcb\x01\x3a\x00\xd0\x00\x3b\x00\xcd\x01\x3c\x00\xb6\x00\x37\x02\x87\x03\x7b\x02\x3b\x00\x86\x03\x39\x00\x3c\x00\x86\x02\x63\x02\x78\x02\x75\x02\x76\x02\x77\x02\x3c\x00\x87\x03\x85\x02\x3b\x00\x87\x02\xb9\x03\x65\x02\x87\x00\x58\x00\x19\x02\x5a\xfd\x59\x00\x5a\x00\x3c\x00\x36\x00\x37\x00\x89\x02\x38\x00\x39\x00\x1a\x02\x8b\x02\xee\x01\x60\x00\x8e\x02\x61\x00\x3a\x01\x8f\x02\x3a\x00\x66\x02\x3b\x00\x9d\x02\x9f\x02\xb9\x00\x88\x00\x0e\x00\xba\x00\xa3\x02\xa4\x02\xa5\x02\x3c\x00\xa6\x02\x10\x00\x90\x02\x62\x00\x63\x00\xae\x02\xbe\x02\x89\x00\xc6\x02\x4d\x00\xcf\x02\xd7\x00\xd8\x00\xd9\x00\xda\x00\xd1\x02\xd3\x02\xd5\x02\xd8\x02\xd2\x00\xd3\x00\x71\x02\x72\x02\xd9\x02\x00\x01\xda\x02\xd5\x00\x05\x01\x02\x01\x77\x00\x76\x00\x73\x02\x7a\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\xff\xff\x1b\x01\x2d\x01\x2f\x01\xff\xff\x2e\x01\x67\x00\xc2\x04\x6f\xfd\x2e\x00\x55\x01\x27\x04\x30\x01\x31\x01\x2f\x01\x32\x00\x33\x00\x5e\x01\x68\x00\x69\x00\x6a\x00\x61\x01\xff\xff\xd0\x00\x8c\x01\x6b\x00\x2e\x00\xb6\x00\x8f\x01\xc5\x04\xff\xff\x9f\x01\x08\x05\x33\x00\xa0\x01\xa1\x01\xff\xff\xdd\xfd\x79\x02\x76\x02\x77\x02\x84\x01\x6f\x00\xd3\x01\xff\xff\xd4\x01\x71\x00\x72\x00\x87\x00\x58\x00\x74\x00\x75\x00\x59\x00\x5a\x00\x34\x00\xd9\x01\x09\x05\xe3\x01\xff\xff\xf3\x00\xff\xff\xf3\x00\xe7\x01\x2e\x00\xf3\x00\x00\x00\x30\x01\x31\x01\x00\x00\x32\x00\x33\x00\x34\x00\x00\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd3\x00\x71\x02\x2a\x04\x00\x00\x00\x00\x00\x00\xd5\x00\x34\x00\x00\x00\x77\x00\x76\x00\x73\x02\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x66\x01\x00\x00\x67\x01\x3a\x00\x68\x01\x3b\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\xd0\x00\x4d\x00\x00\x00\x3c\x00\xb6\x00\x4e\x00\x00\x00\x00\x00\x3a\x00\x4f\x00\x3b\x00\x00\x00\x00\x00\x00\x00\xa6\x04\x2e\x00\x00\x00\x86\x00\x00\x00\x00\x00\x3c\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x10\x00\x34\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x00\x00\x7f\x04\x00\x00\x00\x00\xd2\x00\xd3\x00\x71\x02\x72\x02\x00\x00\x00\x00\x00\x00\xd5\x00\x90\x04\x8a\x04\x77\x00\x76\x00\x73\x02\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x38\x03\x39\x03\x00\x00\x32\x00\x33\x00\x2e\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x0a\x05\x33\x00\xb6\x00\x00\x00\x00\x00\x36\x00\x37\x00\x1e\x03\x38\x00\x39\x00\xdb\x01\xbd\x01\xa7\x04\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x3a\x00\x1f\x03\x3b\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x3c\x00\x34\x00\xed\x03\x83\x03\x84\x03\x85\x03\x00\x00\x76\x00\x00\x00\x34\x00\x00\x00\x20\x03\x00\x00\x00\x00\x8b\x04\x8c\x04\x59\x00\x0a\x01\xb9\x00\x88\x00\x0e\x00\xba\x00\x8d\x04\x00\x00\x38\x00\x39\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd3\x00\x71\x02\x72\x02\x0d\x01\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x77\x00\x76\x00\x73\x02\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\xb5\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x3a\x00\x00\x00\x3b\x00\xb6\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x03\x39\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x87\x03\x00\x00\x3b\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x76\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x3d\x01\x3e\x01\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd3\x00\x71\x02\xc7\x03\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x77\x00\x00\x00\x73\x02\x7a\x00\x86\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x74\x02\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x82\x03\x83\x03\x84\x03\x85\x03\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x43\x01\x44\x01\x45\x01\x10\x00\x61\x00\x62\x00\x63\x00\x46\x01\x65\x00\x89\x00\x86\x00\x76\x00\x47\x01\x00\x00\x00\x00\x00\x00\x37\x03\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3e\x01\x00\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x2e\x00\x62\x00\x63\x00\x38\x03\x39\x03\x89\x00\x32\x00\x33\x00\x00\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\x2e\x03\x4f\x01\x00\x00\x50\x01\x00\x00\x00\x00\x00\x00\x09\x01\x00\x00\x59\x00\x0a\x01\x86\x00\x00\x00\x00\x00\x00\x00\x86\x03\x39\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x87\x03\x3f\x01\x3b\x00\x00\x00\x00\x00\x0b\x01\x00\x00\x34\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x40\x01\x10\x00\x41\x01\x00\x00\x0d\x01\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x43\x01\x7c\x01\x45\x01\x10\x00\x61\x00\x62\x00\x63\x00\x46\x01\x65\x00\x89\x00\x76\x00\x00\x00\x47\x01\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x76\x01\x77\x01\x00\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x37\x01\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x6b\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x3c\x00\x87\x00\x58\x00\x76\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x3f\x01\x6f\x00\x00\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x40\x01\x00\x00\x41\x01\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x00\x00\x2e\x00\x7a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x36\x00\x37\x00\x46\x03\x38\x00\x39\x00\xdb\x01\xbd\x01\x71\x01\x58\x00\x00\x00\x67\x00\x59\x00\x5a\x00\x3a\x00\x47\x03\x3b\x00\x00\x00\x65\x03\x66\x03\x67\x03\x34\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x3c\x00\x68\x03\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x72\x01\x0e\x00\x0f\x00\x20\x03\x76\x00\x00\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x6f\x00\x00\x00\x87\x00\x58\x00\x71\x00\x72\x00\x59\x00\x5a\x00\x74\x00\x75\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x01\x88\x00\x0e\x00\x0f\x00\x58\x02\x7e\x01\x00\x00\x00\x00\x00\x00\x10\x00\x7f\x01\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x69\x03\x36\x00\x37\x00\xda\x01\x38\x00\x39\x00\xdb\x01\xbd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xdc\x01\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x77\x00\x59\x00\x5a\x00\x96\x02\x3f\x01\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x80\x01\x00\x00\x00\x00\x00\x00\x81\x01\x82\x01\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x67\x00\x2e\x00\xbb\x01\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\xc1\x01\x00\x00\x00\x00\xc3\x01\x00\x00\xc4\x01\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x10\x00\x4a\x01\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x4b\x01\x59\x00\x5a\x00\x00\x00\x3f\x01\xc6\x01\xc8\x04\x00\x00\x00\x00\xc8\x01\xc9\x01\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x61\x01\x62\x01\x37\x00\x4f\x02\x38\x00\x39\x00\x53\x03\x2d\x03\x4e\x01\x4f\x01\x00\x00\x50\x01\x35\x00\x00\x00\x63\x01\x09\x01\x3b\x00\x59\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\xbc\x01\xbd\x01\x00\x00\x00\x00\x0b\x01\x00\x00\x86\x00\x0c\x01\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x10\x00\x87\x00\x58\x00\x0d\x01\x77\x00\x59\x00\x5a\x00\x3c\x00\x3f\x01\x00\x00\x00\x00\x85\x01\x7e\x00\x7f\x00\x80\x00\x81\x00\xbe\x01\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x4f\x02\x00\x00\x00\x00\x50\x02\x00\x00\x00\x00\x2e\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\xd9\x01\x2e\x00\xb7\x01\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\xb8\x01\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x02\x68\x02\x00\x00\x35\x00\x2e\x00\x22\x02\x69\x02\x92\x02\x31\x00\x6b\x02\x93\x02\x33\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x87\x00\x58\x00\x00\x00\x77\x00\x59\x00\x5a\x00\x3c\x00\x3f\x01\x00\x00\x00\x00\x34\x00\xea\x02\x7f\x00\x80\x00\x81\x00\xb9\x01\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x2b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x02\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x43\x04\x44\x04\x00\x00\x32\x00\x33\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x3a\x00\x86\x00\x3b\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x3c\x00\x59\x00\x5a\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x00\x00\x77\x00\x55\x03\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x7c\x02\x00\x00\x56\x03\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x86\x04\xf2\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x34\x00\x77\x00\x59\x00\x5a\x00\x3c\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x29\x02\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x77\x00\x5e\x03\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x35\x00\x86\x00\x56\x03\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x0b\x05\x33\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x00\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x34\x00\x59\x00\x5a\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x41\x01\x76\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x00\x00\x77\x00\x3b\x01\x3c\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x2e\x00\x7c\x02\x00\x00\x61\x03\x00\x00\x2e\x00\x22\x02\xe3\x01\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x86\x04\x87\x04\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x4d\x01\x4e\x01\x4f\x01\x3a\x00\x50\x01\x3b\x00\x00\x00\x76\x00\x09\x01\x00\x00\x59\x00\x0a\x01\x86\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x34\x00\x00\x00\x00\x00\x87\x00\x58\x00\x34\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x0b\x01\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x10\x00\x41\x01\x00\x00\x0d\x01\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x42\x01\x78\x01\x00\x00\x79\x01\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x89\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x76\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x03\x58\x03\x59\x03\x5a\x03\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x82\x00\x3b\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x5b\x03\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x86\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x5f\x03\x58\x03\x59\x03\x5a\x03\x33\x01\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x35\x01\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x03\x5d\x00\x00\x00\x5e\x00\x5f\x00\x60\x00\x86\x00\x61\x00\x00\x00\x00\x00\x64\x00\x65\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x2e\x00\x8e\x03\x30\x04\x92\x02\x31\x00\x6b\x02\x93\x02\x33\x00\x88\x00\x0e\x00\x0f\x00\x4b\x04\x59\x03\x5a\x03\x00\x00\x00\x00\x10\x00\x67\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x5b\x03\x6b\x00\x00\x00\x00\x00\x00\x00\x76\x00\x86\x00\x00\x00\x00\x00\x00\x00\x34\x00\x4a\x01\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x4b\x01\x59\x00\x5a\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\xac\x03\x66\x03\x67\x03\x82\x02\x4e\x01\x4f\x01\x00\x00\x50\x01\x94\x02\x68\x03\x00\x00\x09\x01\x00\x00\x59\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x86\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x87\x00\x58\x00\x00\x00\x0b\x01\x59\x00\x5a\x00\x0c\x01\x3a\x00\x00\x00\x3b\x00\x11\x02\x60\x00\x10\x00\x61\x00\x00\x00\x0d\x01\x00\x00\x83\x02\x00\x00\x3c\x00\x00\x00\xae\x01\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x10\x00\xd1\x04\x62\x00\x63\x00\xd2\x04\x33\x00\x89\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\xd3\x04\x76\x00\x00\x00\x00\x00\x00\x00\xb0\x01\x17\x03\x2d\x02\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x6b\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x02\x4a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x72\x00\x87\x00\x58\x00\x74\x00\x75\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x6b\x03\x66\x03\x67\x03\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x68\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x76\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x67\x00\xa5\x01\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x2c\x02\x2d\x02\x89\x00\x00\x00\x68\x00\x69\x00\x6a\x00\xa6\x01\xa7\x01\xa8\x01\xa9\x01\x6b\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x71\x00\x72\x00\x87\x00\x58\x00\x74\x00\x75\x00\x59\x00\x5a\x00\x00\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x02\x14\x01\x88\x00\x0e\x00\x0f\x00\x09\x01\x00\x00\x59\x00\x0a\x01\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x38\x02\x0b\x01\x39\x02\x85\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x10\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x33\x01\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x8c\x02\x00\x00\x35\x01\x82\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x00\x00\x39\x02\x85\x00\x5d\x00\x00\x00\x5e\x00\x5f\x00\x60\x00\x86\x00\x61\x00\x00\x00\x00\x00\x64\x00\x65\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x33\x01\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x34\x01\x00\x00\x35\x01\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x5d\x00\x00\x00\x5e\x00\x5f\x00\x60\x00\x86\x00\x61\x00\x00\x00\x00\x00\x64\x00\x65\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x49\x04\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x03\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x96\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x97\x01\x98\x01\x99\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\xb6\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x85\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\xb7\x00\x59\x00\x5a\x00\x77\x00\x00\x00\xb8\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x67\x00\x00\x00\x13\x04\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x68\x00\x69\x00\x6a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x6b\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x87\x00\x58\x00\x71\x00\x72\x00\x59\x00\x5a\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x85\x00\xb9\x00\x88\x00\x0e\x00\xba\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x67\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x51\x04\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x03\x6f\x00\x00\x00\x00\x00\x00\x00\x71\x00\x72\x00\x00\x00\xcc\x03\x74\x00\x75\x00\x81\x04\x2e\x00\x22\x02\x86\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x34\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x03\x00\x00\x00\x00\x00\x00\x2e\x00\xb6\x04\x86\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x34\x00\x62\x00\x63\x00\x36\x00\x37\x00\x89\x00\x38\x00\x39\x00\x00\x00\x00\x00\xf5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x76\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x36\x00\x37\x00\x89\x00\x38\x00\x39\x00\x00\x00\x00\x00\xf6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xc5\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xeb\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x77\x00\xd7\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x79\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x7c\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\xc0\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x7d\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x7e\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xa9\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x2f\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\xc2\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x48\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x4f\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x50\x04\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xa6\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\xd4\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\xa8\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xb4\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xc6\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xe4\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\x34\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x18\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x5d\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x60\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x6e\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\x35\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x72\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x73\x03\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x1d\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x1e\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\x46\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x1f\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x20\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x28\x02\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x68\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\x47\x04\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x69\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x6a\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x70\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x9d\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\xc0\x03\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\xa2\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xa3\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\xb0\x01\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\xc8\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x2e\x00\x00\x00\x59\x00\x5a\x00\xc1\x03\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x34\x00\x77\x00\x00\x00\x97\x04\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\xfb\x03\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x86\x00\x76\x00\x00\x00\x3c\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x00\x00\x89\x02\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x67\x00\x5f\x01\x76\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x77\x00\x6b\x00\x6f\x01\x7a\x00\x00\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x87\x00\x58\x00\x71\x00\x72\x00\x59\x00\x5a\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\xc1\x01\xc2\x01\x00\x00\xc3\x01\x00\x00\xc4\x01\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x76\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x62\x02\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x4b\x01\x59\x00\x5a\x00\x76\x00\x77\x00\xc6\x01\xc7\x01\x00\x00\x00\x00\xc8\x01\xc9\x01\x00\x00\x87\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\xbe\x03\x33\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x43\x02\x64\x03\x00\x00\x00\x00\x2e\x00\x87\x01\x7f\x00\x80\x00\x81\x00\x00\x00\xda\x03\x33\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x02\x44\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x34\x00\x86\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x87\x00\x58\x00\x89\x00\x00\x00\x59\x00\x5a\x00\x77\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x76\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x3f\x02\x7f\x00\x80\x00\x81\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x88\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x86\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x3c\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x3a\x00\x86\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x76\x00\x87\x00\x58\x00\x00\x00\x3c\x00\x59\x00\x5a\x00\xa1\x01\x7f\x00\x80\x00\x81\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\xca\x02\x7f\x00\x80\x00\x81\x00\x87\x00\x58\x00\x00\x00\x77\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x02\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\xc2\x03\x00\x00\x23\x01\x33\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x86\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x77\x00\x34\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x02\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x03\x03\x33\x00\x89\x00\x00\x00\x00\x00\x00\x00\x77\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x3a\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x10\x00\x3c\x00\x62\x00\x63\x00\x86\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x87\x00\x58\x00\x00\x00\x76\x00\x59\x00\x5a\x00\x84\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x36\x00\x37\x00\x76\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x87\x00\x58\x00\x00\x00\x77\x00\x59\x00\x5a\x00\x00\x00\x86\x00\x3c\x00\x00\x00\x00\x00\x8f\x01\x7f\x00\x80\x00\x81\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x77\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x86\x00\x00\x00\x93\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x87\x00\x58\x00\x77\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x7f\x00\x80\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x86\x00\x89\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x50\x03\x81\x00\x86\x00\x51\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\xf2\x01\x33\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x00\x00\x88\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x10\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x89\x00\x87\x00\x58\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x34\x02\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x75\x01\x0e\x00\x0f\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x10\x00\x14\x00\x62\x00\x63\x00\x00\x00\x15\x00\x89\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x2e\x00\x10\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x98\x00\x3b\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x35\x02\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x34\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x6b\x03\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\xdc\x03\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x02\x60\x00\x3c\x00\x61\x00\x00\x00\x00\x00\xad\x01\x65\x00\x00\x00\x34\x00\x00\x00\xae\x01\x8b\x00\x12\x00\x8c\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\xf3\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\xe0\x00\xbf\x00\x00\x00\xe1\x00\x00\x00\x14\x00\x00\x00\xe2\x00\x00\x00\x15\x00\xe3\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\xe5\x00\x94\x00\x95\x00\x96\x00\xe6\x00\xe7\x00\x00\x00\x00\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xc4\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x98\x00\x3b\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\xe0\x00\xbf\x00\x00\x00\xe1\x00\x00\x00\x14\x00\x00\x00\xe2\x00\x00\x00\x15\x00\xe3\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\xe5\x00\x94\x00\x95\x00\x96\x00\xe6\x00\xe7\x00\x00\x00\x00\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x23\x04\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\xe1\x00\x00\x00\x14\x00\x00\x00\x24\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x2c\x04\x2d\x04\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2e\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x23\x04\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\xe1\x00\x00\x00\x14\x00\x00\x00\x24\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x2c\x04\x2d\x04\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2e\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x1b\x02\x9f\x00\x00\x00\x00\x00\x09\x02\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x18\x02\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x09\x02\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x49\x01\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x4a\x01\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x4b\x01\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x7c\x01\x9f\x00\x00\x00\x00\x00\x4b\x01\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x49\x01\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x4a\x01\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x4b\x01\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x09\x02\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x84\x01\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x4c\x01\xa0\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\xc0\x00\x93\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xc5\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x03\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x6b\x03\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x5d\x03\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x92\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x03\x00\x00\x00\x00\xcd\x03\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x2e\x00\x32\x00\x33\x00\x97\x00\xdd\x03\x00\x00\x23\x01\x33\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x6b\x03\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x34\x00\x00\x00\x26\x00\x73\x00\x00\x00\x34\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x31\xfe\x31\xfe\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x31\xfe\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfe\x00\x00\x00\x00\x00\x00\x31\xfe\x00\x00\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x35\x00\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x00\x00\x00\x00\x31\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x31\xfe\x31\xfe\x31\xfe\x3c\x00\x00\x00\x31\xfe\x00\x00\x00\x00\x3c\x00\x31\xfe\x00\x00\x00\x00\x31\xfe\x31\xfe\x31\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfe\x31\xfe\x00\x00\x00\x00\x00\x00\x31\xfe\x00\x00\x31\xfe\x00\x00\x31\xfe\x00\x00\x31\xfe\x00\x00\x31\xfe\x00\x00\x00\x00\x00\x00\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x00\x00\x31\xfe\x00\x00\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x31\xfe\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x5d\x03\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x92\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x9b\x01\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x01\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x92\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\xb6\x03\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x8b\x00\x12\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x13\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x90\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x03\x00\x00\x00\x00\xcf\x03\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x7c\x02\x00\x00\x99\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x0e\x03\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x34\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x34\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x35\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x35\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x3c\x00\x8a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x3a\x00\x00\x00\x3b\x00\x8b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x02\x00\x00\x00\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x7d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x7c\x02\x00\x00\x00\x00\x8b\x01\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\xa6\x02\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x34\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x34\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x35\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x38\x00\x39\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x05\x00\x00\x00\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x2e\x00\x32\x00\x33\x00\x00\x00\xde\x03\x00\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\xf5\x04\x00\x00\x00\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x34\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x34\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x34\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x35\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x38\x00\x39\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x35\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\x53\x03\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x02\x00\x00\x00\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x21\x02\x00\x00\x00\x00\x00\x00\x2e\x00\x22\x02\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x34\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x34\x00\x8b\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x35\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x3a\x00\xf8\x04\x3b\x00\x00\x00\x2e\x00\x00\x00\x69\x02\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x3c\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\x9d\x00\x00\x00\x9e\x00\x34\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x50\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x00\x00\x3e\x00\x12\x00\x00\x00\xab\x00\xac\x00\xad\x00\xae\x00\x00\x00\xaf\x00\x13\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x6d\x02\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xfe\x00\x00\x00\x00\xe5\xfe\x00\x00\x22\x03\x00\x00\x23\x03\x00\x00\xe6\xfe\xc3\x01\x45\x00\xc4\x01\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x01\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x01\x24\x03\x4c\x00\x4d\x00\xc6\x01\xc7\x01\x00\x00\x4e\x00\xc8\x01\xc9\x01\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x04\x43\x00\x44\x00\x2e\x00\x00\x00\x69\x02\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\xc1\x01\xc2\x01\x2e\x00\xc3\x01\x45\x00\xc4\x01\x16\x03\x00\x00\x23\x01\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\xc5\x01\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x4b\x01\x00\x00\x4b\x00\x4c\x00\x4d\x00\xc6\x01\xc7\x01\x00\x00\x4e\x00\xc8\x01\xc9\x01\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x49\x03\x00\x00\x4a\x03\x00\x00\xe6\xfe\xc3\x01\x45\x00\xc4\x01\x3a\x00\x00\x00\x3b\x00\x00\x00\xe0\x01\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x01\x4b\x03\x4c\x00\x4d\x00\xc6\x01\xc7\x01\x00\x00\x4e\x00\xc8\x01\xc9\x01\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x04\x43\x00\x44\x00\x2e\x00\x00\x00\x69\x02\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x68\x00\x13\x02\x6a\x00\x92\x03\x00\x00\x23\x01\x33\x00\x6b\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x4a\x01\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x4b\x01\x00\x00\x4b\x00\x4c\x00\x4d\x00\x71\x00\x72\x00\x00\x00\x4e\x00\x00\x00\x75\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\xde\x01\x00\x00\xdf\x01\x00\x00\xe6\xfe\xc3\x01\x45\x00\xc4\x01\x3a\x00\x00\x00\x3b\x00\x00\x00\xe0\x01\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x01\xe2\x01\x4c\x00\x4d\x00\xc6\x01\xc7\x01\x00\x00\x4e\x00\xc8\x01\xc9\x01\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x03\x43\x00\x44\x00\x2e\x00\x00\x00\x69\x02\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x01\x00\x00\xad\x02\x00\x00\x2e\x00\xc3\x01\x45\x00\xc4\x01\x93\x03\x00\x00\x23\x01\x33\x00\xe0\x01\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\xe1\x01\xe2\x01\x4c\x00\x4d\x00\xc6\x01\xc7\x01\x00\x00\x4e\x00\xc8\x01\xc9\x01\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x00\x00\x00\x00\xef\x04\x00\x00\xe6\xfe\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x02\x4b\x00\x4c\x00\x4d\x00\x00\x00\x72\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\x43\x00\x44\x00\x2e\x00\x00\x00\x69\x02\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xb7\x01\x45\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x46\x00\x13\x02\x14\x02\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\xbb\x01\x00\x00\x34\x00\x00\x00\x4b\x01\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x35\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x02\x4b\x00\x4c\x00\x4d\x00\x00\x00\x72\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x2e\x00\xeb\x01\xbb\x03\x92\x02\x31\x00\x6b\x02\x93\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x2e\x00\x98\x03\x00\x00\x30\x00\x31\x00\x46\x00\x32\x00\x33\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x89\x04\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x94\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x35\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfe\x00\x00\x3c\x00\xe1\xfe\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\xe7\xfe\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x46\x00\x3b\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x01\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x26\x01\x27\x01\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x2e\x00\xf3\x01\xbf\x03\x92\x02\x31\x00\x6b\x02\x93\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x37\x01\xfe\xfe\x00\x00\x00\x00\xfe\xfe\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x46\x00\x00\x00\x00\x00\x6b\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x6f\x00\x00\x00\x00\x00\x4e\x00\x71\x00\x72\x00\x00\x00\x4f\x00\x74\x00\x75\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x94\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xb7\x01\x00\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x00\x00\xa0\x02\x14\x02\x00\x00\x00\x00\x45\x00\x00\x00\x2e\x00\xf0\x03\x00\x00\x30\x00\x31\x00\x46\x00\x32\x00\x33\x00\x00\x00\x47\x00\x00\x00\x48\x00\xcb\x01\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x34\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x35\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x46\x00\x3b\x00\x00\x00\x00\x00\x47\x00\xcd\x01\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x2e\x00\xb7\x01\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\xa3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xb7\x01\x45\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x46\x00\x00\x00\x80\x03\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x35\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x35\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x2e\x00\xb7\x01\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x81\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x04\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x97\x04\x35\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xb7\x01\x00\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x8b\x03\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x34\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x8e\x03\x45\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x96\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x43\x00\x44\x00\x2e\x00\x00\x00\x33\x04\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x2e\x00\x00\x00\x43\x00\x44\x00\xf4\x01\x00\x00\x23\x01\x33\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x30\x04\x6a\x02\x3c\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x34\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x34\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x6d\x02\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x3a\x00\x00\x00\x3b\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xeb\x01\x45\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x43\x00\x44\x00\x2e\x00\x00\x00\xbb\x03\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x2e\x00\x00\x00\x43\x00\x44\x00\xf5\x01\x00\x00\x23\x01\x33\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\xbf\x03\x6a\x02\x3c\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x34\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x34\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x96\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x6d\x02\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x3a\x00\x00\x00\x3b\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\xf3\x01\x45\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x43\x00\x44\x00\x2e\x00\x00\x00\x02\x03\x6a\x02\x00\x00\x6b\x02\x6c\x02\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x6d\x02\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x6e\x01\x00\x00\x30\x00\x31\x00\x3c\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x2e\x00\xc9\x01\x00\x00\x30\x00\x31\x00\x46\x00\x32\x00\x33\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x34\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x35\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x46\x00\x3b\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x6f\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x2e\x00\xcb\x01\x00\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2f\x00\x45\x00\x30\x00\x31\x00\x00\x00\x32\x00\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x35\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x2e\x00\x35\x00\x43\x00\x44\x00\xf6\x01\x2e\x00\x23\x01\x33\x00\x3a\x00\x9f\x02\x3b\x00\x23\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x3c\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x34\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x96\x02\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x43\x00\x44\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x45\x00\x00\x00\xa9\x02\x00\x00\x23\x01\x33\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3f\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x22\x01\x00\x00\x23\x01\x33\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x34\x00\x47\x00\x00\x00\x48\x00\x3c\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3b\x03\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x38\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x12\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x13\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xa3\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x53\x00\x54\x00\x4f\x00\x14\x00\x00\x00\x55\x00\x56\x00\x12\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x13\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x43\x00\x44\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xa5\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x12\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x13\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x43\x00\x44\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xfe\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x3b\x03\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x12\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x03\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x25\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\xb1\x01\x23\x00\xb2\x01\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\xbc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\xbd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x00\x00\xee\x01\x60\x00\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xe7\xfe\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x3e\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x54\x00\x00\x00\x14\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x12\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x48\x00\x00\x00\x49\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x51\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\xff\x01\x00\x00\x53\x00\x54\x00\x00\x00\x13\x00\x00\x00\x55\x00\x56\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x01\x03\x16\x00\x17\x00\x18\x00\xfe\x02\xff\x02\x00\x03\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xff\x01\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x25\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x01\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x12\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x13\x00\x25\x00\x70\x00\x71\x00\x72\x00\x26\x00\x73\x00\x74\x00\x75\x00\x27\x00\x76\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\xb1\x01\x23\x00\xb2\x01\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\xd8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x0c\x01\x67\x00\x00\x00\x00\x00\xee\x01\x60\x00\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x01\x00\x00\x00\x00\x00\x00\xb7\x01\x12\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x01\x13\x00\x25\x00\x70\x00\x71\x00\x72\x00\x00\x00\x73\x00\x00\x00\x75\x00\x71\x04\x76\x00\x00\x00\x14\x00\x00\x00\x72\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x73\x04\x00\x00\x00\x00\x00\x00\x71\x04\x00\x00\x00\x00\x14\x00\x00\x00\x72\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x73\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x01\x00\x00\xb2\x01\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\xec\x01\x6c\x00\x00\x00\x00\x00\x00\x00\x74\x01\x00\x00\x6e\x00\x00\x00\x00\x00\xed\x01\x00\x00\x74\x04\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\xb4\x01\x26\x00\x73\x00\x0c\x01\x00\x00\x27\x00\x76\x00\xee\x01\x60\x00\x10\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x74\x01\x12\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x00\x00\x27\x00\x76\x00\x00\x00\x14\x00\x00\x00\x72\x04\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x72\x04\x00\x00\x15\x00\xe8\x04\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x12\x00\x00\x00\x00\x00\x74\x01\xe9\x04\x6e\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x14\x00\x27\x00\x76\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x6c\x00\x12\x00\x00\x00\x00\x00\x74\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x14\x00\x27\x00\x76\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x12\x00\x00\x00\x00\x00\x74\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x14\x00\x27\x00\x76\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\xb6\x01\x12\x00\x00\x00\x00\x00\xb7\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x14\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x26\x00\x73\x00\x00\x00\x14\x00\x27\x00\x76\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x89\x03\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x8a\x03\x12\x00\x00\x00\x00\x00\x8b\x03\x9e\x03\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x14\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\xa1\x03\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x89\x03\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x8a\x03\x00\x00\x00\x00\x00\x00\x8b\x03\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x14\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x66\x01\x00\x00\x67\x01\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x8a\x03\x00\x00\x00\x00\x00\x00\x8b\x03\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x14\x00\x4e\x00\x00\x00\x00\x00\x15\x00\x4f\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x12\x00\x23\x00\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x08\x01\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x14\x00\x73\x00\x00\x00\x00\x00\x15\x00\x76\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x14\x00\x00\x00\x28\x02\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x14\x00\x26\x00\x00\x00\x00\x00\x15\x00\x27\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x67\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x12\x00\x00\x00\x00\x00\x52\x01\x4a\x01\x6e\x00\x00\x00\x00\x00\x13\x00\x00\x00\x4b\x01\x00\x00\x00\x00\x25\x00\x70\x00\x71\x00\x72\x00\x0f\x01\x00\x00\x00\x00\x14\x00\x00\x00\x10\x01\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x13\x00\x00\x00\x00\x00\x11\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x25\x00\x70\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x52\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x13\x00\x00\x00\x00\x00\x11\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x25\x00\x70\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x13\x00\x00\x00\x00\x00\x52\x01\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x25\x00\x70\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x25\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x25\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x15\x00\x25\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x02\x00\x00\x14\x00\x00\x00\x00\x00\x25\x00\x15\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x12\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x25\x00\x12\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x13\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x40\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (12, 726) [ + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241), + (242 , happyReduce_242), + (243 , happyReduce_243), + (244 , happyReduce_244), + (245 , happyReduce_245), + (246 , happyReduce_246), + (247 , happyReduce_247), + (248 , happyReduce_248), + (249 , happyReduce_249), + (250 , happyReduce_250), + (251 , happyReduce_251), + (252 , happyReduce_252), + (253 , happyReduce_253), + (254 , happyReduce_254), + (255 , happyReduce_255), + (256 , happyReduce_256), + (257 , happyReduce_257), + (258 , happyReduce_258), + (259 , happyReduce_259), + (260 , happyReduce_260), + (261 , happyReduce_261), + (262 , happyReduce_262), + (263 , happyReduce_263), + (264 , happyReduce_264), + (265 , happyReduce_265), + (266 , happyReduce_266), + (267 , happyReduce_267), + (268 , happyReduce_268), + (269 , happyReduce_269), + (270 , happyReduce_270), + (271 , happyReduce_271), + (272 , happyReduce_272), + (273 , happyReduce_273), + (274 , happyReduce_274), + (275 , happyReduce_275), + (276 , happyReduce_276), + (277 , happyReduce_277), + (278 , happyReduce_278), + (279 , happyReduce_279), + (280 , happyReduce_280), + (281 , happyReduce_281), + (282 , happyReduce_282), + (283 , happyReduce_283), + (284 , happyReduce_284), + (285 , happyReduce_285), + (286 , happyReduce_286), + (287 , happyReduce_287), + (288 , happyReduce_288), + (289 , happyReduce_289), + (290 , happyReduce_290), + (291 , happyReduce_291), + (292 , happyReduce_292), + (293 , happyReduce_293), + (294 , happyReduce_294), + (295 , happyReduce_295), + (296 , happyReduce_296), + (297 , happyReduce_297), + (298 , happyReduce_298), + (299 , happyReduce_299), + (300 , happyReduce_300), + (301 , happyReduce_301), + (302 , happyReduce_302), + (303 , happyReduce_303), + (304 , happyReduce_304), + (305 , happyReduce_305), + (306 , happyReduce_306), + (307 , happyReduce_307), + (308 , happyReduce_308), + (309 , happyReduce_309), + (310 , happyReduce_310), + (311 , happyReduce_311), + (312 , happyReduce_312), + (313 , happyReduce_313), + (314 , happyReduce_314), + (315 , happyReduce_315), + (316 , happyReduce_316), + (317 , happyReduce_317), + (318 , happyReduce_318), + (319 , happyReduce_319), + (320 , happyReduce_320), + (321 , happyReduce_321), + (322 , happyReduce_322), + (323 , happyReduce_323), + (324 , happyReduce_324), + (325 , happyReduce_325), + (326 , happyReduce_326), + (327 , happyReduce_327), + (328 , happyReduce_328), + (329 , happyReduce_329), + (330 , happyReduce_330), + (331 , happyReduce_331), + (332 , happyReduce_332), + (333 , happyReduce_333), + (334 , happyReduce_334), + (335 , happyReduce_335), + (336 , happyReduce_336), + (337 , happyReduce_337), + (338 , happyReduce_338), + (339 , happyReduce_339), + (340 , happyReduce_340), + (341 , happyReduce_341), + (342 , happyReduce_342), + (343 , happyReduce_343), + (344 , happyReduce_344), + (345 , happyReduce_345), + (346 , happyReduce_346), + (347 , happyReduce_347), + (348 , happyReduce_348), + (349 , happyReduce_349), + (350 , happyReduce_350), + (351 , happyReduce_351), + (352 , happyReduce_352), + (353 , happyReduce_353), + (354 , happyReduce_354), + (355 , happyReduce_355), + (356 , happyReduce_356), + (357 , happyReduce_357), + (358 , happyReduce_358), + (359 , happyReduce_359), + (360 , happyReduce_360), + (361 , happyReduce_361), + (362 , happyReduce_362), + (363 , happyReduce_363), + (364 , happyReduce_364), + (365 , happyReduce_365), + (366 , happyReduce_366), + (367 , happyReduce_367), + (368 , happyReduce_368), + (369 , happyReduce_369), + (370 , happyReduce_370), + (371 , happyReduce_371), + (372 , happyReduce_372), + (373 , happyReduce_373), + (374 , happyReduce_374), + (375 , happyReduce_375), + (376 , happyReduce_376), + (377 , happyReduce_377), + (378 , happyReduce_378), + (379 , happyReduce_379), + (380 , happyReduce_380), + (381 , happyReduce_381), + (382 , happyReduce_382), + (383 , happyReduce_383), + (384 , happyReduce_384), + (385 , happyReduce_385), + (386 , happyReduce_386), + (387 , happyReduce_387), + (388 , happyReduce_388), + (389 , happyReduce_389), + (390 , happyReduce_390), + (391 , happyReduce_391), + (392 , happyReduce_392), + (393 , happyReduce_393), + (394 , happyReduce_394), + (395 , happyReduce_395), + (396 , happyReduce_396), + (397 , happyReduce_397), + (398 , happyReduce_398), + (399 , happyReduce_399), + (400 , happyReduce_400), + (401 , happyReduce_401), + (402 , happyReduce_402), + (403 , happyReduce_403), + (404 , happyReduce_404), + (405 , happyReduce_405), + (406 , happyReduce_406), + (407 , happyReduce_407), + (408 , happyReduce_408), + (409 , happyReduce_409), + (410 , happyReduce_410), + (411 , happyReduce_411), + (412 , happyReduce_412), + (413 , happyReduce_413), + (414 , happyReduce_414), + (415 , happyReduce_415), + (416 , happyReduce_416), + (417 , happyReduce_417), + (418 , happyReduce_418), + (419 , happyReduce_419), + (420 , happyReduce_420), + (421 , happyReduce_421), + (422 , happyReduce_422), + (423 , happyReduce_423), + (424 , happyReduce_424), + (425 , happyReduce_425), + (426 , happyReduce_426), + (427 , happyReduce_427), + (428 , happyReduce_428), + (429 , happyReduce_429), + (430 , happyReduce_430), + (431 , happyReduce_431), + (432 , happyReduce_432), + (433 , happyReduce_433), + (434 , happyReduce_434), + (435 , happyReduce_435), + (436 , happyReduce_436), + (437 , happyReduce_437), + (438 , happyReduce_438), + (439 , happyReduce_439), + (440 , happyReduce_440), + (441 , happyReduce_441), + (442 , happyReduce_442), + (443 , happyReduce_443), + (444 , happyReduce_444), + (445 , happyReduce_445), + (446 , happyReduce_446), + (447 , happyReduce_447), + (448 , happyReduce_448), + (449 , happyReduce_449), + (450 , happyReduce_450), + (451 , happyReduce_451), + (452 , happyReduce_452), + (453 , happyReduce_453), + (454 , happyReduce_454), + (455 , happyReduce_455), + (456 , happyReduce_456), + (457 , happyReduce_457), + (458 , happyReduce_458), + (459 , happyReduce_459), + (460 , happyReduce_460), + (461 , happyReduce_461), + (462 , happyReduce_462), + (463 , happyReduce_463), + (464 , happyReduce_464), + (465 , happyReduce_465), + (466 , happyReduce_466), + (467 , happyReduce_467), + (468 , happyReduce_468), + (469 , happyReduce_469), + (470 , happyReduce_470), + (471 , happyReduce_471), + (472 , happyReduce_472), + (473 , happyReduce_473), + (474 , happyReduce_474), + (475 , happyReduce_475), + (476 , happyReduce_476), + (477 , happyReduce_477), + (478 , happyReduce_478), + (479 , happyReduce_479), + (480 , happyReduce_480), + (481 , happyReduce_481), + (482 , happyReduce_482), + (483 , happyReduce_483), + (484 , happyReduce_484), + (485 , happyReduce_485), + (486 , happyReduce_486), + (487 , happyReduce_487), + (488 , happyReduce_488), + (489 , happyReduce_489), + (490 , happyReduce_490), + (491 , happyReduce_491), + (492 , happyReduce_492), + (493 , happyReduce_493), + (494 , happyReduce_494), + (495 , happyReduce_495), + (496 , happyReduce_496), + (497 , happyReduce_497), + (498 , happyReduce_498), + (499 , happyReduce_499), + (500 , happyReduce_500), + (501 , happyReduce_501), + (502 , happyReduce_502), + (503 , happyReduce_503), + (504 , happyReduce_504), + (505 , happyReduce_505), + (506 , happyReduce_506), + (507 , happyReduce_507), + (508 , happyReduce_508), + (509 , happyReduce_509), + (510 , happyReduce_510), + (511 , happyReduce_511), + (512 , happyReduce_512), + (513 , happyReduce_513), + (514 , happyReduce_514), + (515 , happyReduce_515), + (516 , happyReduce_516), + (517 , happyReduce_517), + (518 , happyReduce_518), + (519 , happyReduce_519), + (520 , happyReduce_520), + (521 , happyReduce_521), + (522 , happyReduce_522), + (523 , happyReduce_523), + (524 , happyReduce_524), + (525 , happyReduce_525), + (526 , happyReduce_526), + (527 , happyReduce_527), + (528 , happyReduce_528), + (529 , happyReduce_529), + (530 , happyReduce_530), + (531 , happyReduce_531), + (532 , happyReduce_532), + (533 , happyReduce_533), + (534 , happyReduce_534), + (535 , happyReduce_535), + (536 , happyReduce_536), + (537 , happyReduce_537), + (538 , happyReduce_538), + (539 , happyReduce_539), + (540 , happyReduce_540), + (541 , happyReduce_541), + (542 , happyReduce_542), + (543 , happyReduce_543), + (544 , happyReduce_544), + (545 , happyReduce_545), + (546 , happyReduce_546), + (547 , happyReduce_547), + (548 , happyReduce_548), + (549 , happyReduce_549), + (550 , happyReduce_550), + (551 , happyReduce_551), + (552 , happyReduce_552), + (553 , happyReduce_553), + (554 , happyReduce_554), + (555 , happyReduce_555), + (556 , happyReduce_556), + (557 , happyReduce_557), + (558 , happyReduce_558), + (559 , happyReduce_559), + (560 , happyReduce_560), + (561 , happyReduce_561), + (562 , happyReduce_562), + (563 , happyReduce_563), + (564 , happyReduce_564), + (565 , happyReduce_565), + (566 , happyReduce_566), + (567 , happyReduce_567), + (568 , happyReduce_568), + (569 , happyReduce_569), + (570 , happyReduce_570), + (571 , happyReduce_571), + (572 , happyReduce_572), + (573 , happyReduce_573), + (574 , happyReduce_574), + (575 , happyReduce_575), + (576 , happyReduce_576), + (577 , happyReduce_577), + (578 , happyReduce_578), + (579 , happyReduce_579), + (580 , happyReduce_580), + (581 , happyReduce_581), + (582 , happyReduce_582), + (583 , happyReduce_583), + (584 , happyReduce_584), + (585 , happyReduce_585), + (586 , happyReduce_586), + (587 , happyReduce_587), + (588 , happyReduce_588), + (589 , happyReduce_589), + (590 , happyReduce_590), + (591 , happyReduce_591), + (592 , happyReduce_592), + (593 , happyReduce_593), + (594 , happyReduce_594), + (595 , happyReduce_595), + (596 , happyReduce_596), + (597 , happyReduce_597), + (598 , happyReduce_598), + (599 , happyReduce_599), + (600 , happyReduce_600), + (601 , happyReduce_601), + (602 , happyReduce_602), + (603 , happyReduce_603), + (604 , happyReduce_604), + (605 , happyReduce_605), + (606 , happyReduce_606), + (607 , happyReduce_607), + (608 , happyReduce_608), + (609 , happyReduce_609), + (610 , happyReduce_610), + (611 , happyReduce_611), + (612 , happyReduce_612), + (613 , happyReduce_613), + (614 , happyReduce_614), + (615 , happyReduce_615), + (616 , happyReduce_616), + (617 , happyReduce_617), + (618 , happyReduce_618), + (619 , happyReduce_619), + (620 , happyReduce_620), + (621 , happyReduce_621), + (622 , happyReduce_622), + (623 , happyReduce_623), + (624 , happyReduce_624), + (625 , happyReduce_625), + (626 , happyReduce_626), + (627 , happyReduce_627), + (628 , happyReduce_628), + (629 , happyReduce_629), + (630 , happyReduce_630), + (631 , happyReduce_631), + (632 , happyReduce_632), + (633 , happyReduce_633), + (634 , happyReduce_634), + (635 , happyReduce_635), + (636 , happyReduce_636), + (637 , happyReduce_637), + (638 , happyReduce_638), + (639 , happyReduce_639), + (640 , happyReduce_640), + (641 , happyReduce_641), + (642 , happyReduce_642), + (643 , happyReduce_643), + (644 , happyReduce_644), + (645 , happyReduce_645), + (646 , happyReduce_646), + (647 , happyReduce_647), + (648 , happyReduce_648), + (649 , happyReduce_649), + (650 , happyReduce_650), + (651 , happyReduce_651), + (652 , happyReduce_652), + (653 , happyReduce_653), + (654 , happyReduce_654), + (655 , happyReduce_655), + (656 , happyReduce_656), + (657 , happyReduce_657), + (658 , happyReduce_658), + (659 , happyReduce_659), + (660 , happyReduce_660), + (661 , happyReduce_661), + (662 , happyReduce_662), + (663 , happyReduce_663), + (664 , happyReduce_664), + (665 , happyReduce_665), + (666 , happyReduce_666), + (667 , happyReduce_667), + (668 , happyReduce_668), + (669 , happyReduce_669), + (670 , happyReduce_670), + (671 , happyReduce_671), + (672 , happyReduce_672), + (673 , happyReduce_673), + (674 , happyReduce_674), + (675 , happyReduce_675), + (676 , happyReduce_676), + (677 , happyReduce_677), + (678 , happyReduce_678), + (679 , happyReduce_679), + (680 , happyReduce_680), + (681 , happyReduce_681), + (682 , happyReduce_682), + (683 , happyReduce_683), + (684 , happyReduce_684), + (685 , happyReduce_685), + (686 , happyReduce_686), + (687 , happyReduce_687), + (688 , happyReduce_688), + (689 , happyReduce_689), + (690 , happyReduce_690), + (691 , happyReduce_691), + (692 , happyReduce_692), + (693 , happyReduce_693), + (694 , happyReduce_694), + (695 , happyReduce_695), + (696 , happyReduce_696), + (697 , happyReduce_697), + (698 , happyReduce_698), + (699 , happyReduce_699), + (700 , happyReduce_700), + (701 , happyReduce_701), + (702 , happyReduce_702), + (703 , happyReduce_703), + (704 , happyReduce_704), + (705 , happyReduce_705), + (706 , happyReduce_706), + (707 , happyReduce_707), + (708 , happyReduce_708), + (709 , happyReduce_709), + (710 , happyReduce_710), + (711 , happyReduce_711), + (712 , happyReduce_712), + (713 , happyReduce_713), + (714 , happyReduce_714), + (715 , happyReduce_715), + (716 , happyReduce_716), + (717 , happyReduce_717), + (718 , happyReduce_718), + (719 , happyReduce_719), + (720 , happyReduce_720), + (721 , happyReduce_721), + (722 , happyReduce_722), + (723 , happyReduce_723), + (724 , happyReduce_724), + (725 , happyReduce_725), + (726 , happyReduce_726) + ] + +happy_n_terms = 151 :: Int +happy_n_nonterms = 255 :: Int + +happyReduce_12 = happySpecReduce_1 0# happyReduction_12 +happyReduction_12 happy_x_1 + = case happyOut245 happy_x_1 of { happy_var_1 -> + happyIn15 + (happy_var_1 + )} + +happyReduce_13 = happySpecReduce_1 0# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut219 happy_x_1 of { happy_var_1 -> + happyIn15 + (happy_var_1 + )} + +happyReduce_14 = happySpecReduce_1 0# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut239 happy_x_1 of { happy_var_1 -> + happyIn15 + (happy_var_1 + )} + +happyReduce_15 = happySpecReduce_1 0# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOut226 happy_x_1 of { happy_var_1 -> + happyIn15 + (happy_var_1 + )} + +happyReduce_16 = happyMonadReduce 3# 0# happyReduction_16 +happyReduction_16 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) + [mj AnnOpenP happy_var_1,mj AnnRarrow happy_var_2,mj AnnCloseP happy_var_3])}}} + ) (\r -> happyReturn (happyIn15 r)) + +happyReduce_17 = happyMonadReduce 7# 1# happyReduction_17 +happyReduction_17 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut261 happy_x_3 of { happy_var_3 -> + case happyOut19 happy_x_4 of { happy_var_4 -> + case happyOut27 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + case happyOut20 happy_x_7 of { happy_var_7 -> + ( fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) + (snd $ snd happy_var_7) happy_var_4 happy_var_1) + ) + ([mj AnnModule happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))}}}}}}} + ) (\r -> happyReturn (happyIn16 r)) + +happyReduce_18 = happyMonadReduce 1# 1# happyReduction_18 +happyReduction_18 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut21 happy_x_1 of { happy_var_1 -> + ( fileSrcSpan >>= \ loc -> + ams (L loc (HsModule Nothing Nothing + (fst $ snd happy_var_1) (snd $ snd happy_var_1) Nothing Nothing)) + (fst happy_var_1))} + ) (\r -> happyReturn (happyIn16 r)) + +happyReduce_19 = happySpecReduce_1 2# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOut267 happy_x_1 of { happy_var_1 -> + happyIn17 + (happy_var_1 + )} + +happyReduce_20 = happySpecReduce_0 2# happyReduction_20 +happyReduction_20 = happyIn17 + (Nothing + ) + +happyReduce_21 = happyMonadReduce 0# 3# happyReduction_21 +happyReduction_21 (happyRest) tk + = happyThen (( pushCurrentContext) + ) (\r -> happyReturn (happyIn18 r)) + +happyReduce_22 = happyMonadReduce 3# 4# happyReduction_22 +happyReduction_22 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ajs (Just (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 (getDEPRECATED_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) + (mo happy_var_1:mc happy_var_3: (fst $ unLoc happy_var_2)))}}} + ) (\r -> happyReturn (happyIn19 r)) + +happyReduce_23 = happyMonadReduce 3# 4# happyReduction_23 +happyReduction_23 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ajs (Just (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 (getWARNING_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) + (mo happy_var_1:mc happy_var_3 : (fst $ unLoc happy_var_2)))}}} + ) (\r -> happyReturn (happyIn19 r)) + +happyReduce_24 = happySpecReduce_0 4# happyReduction_24 +happyReduction_24 = happyIn19 + (Nothing + ) + +happyReduce_25 = happySpecReduce_3 5# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn20 + ((moc happy_var_1:mcc happy_var_3:(fst happy_var_2) + , snd happy_var_2) + )}}} + +happyReduce_26 = happySpecReduce_3 5# happyReduction_26 +happyReduction_26 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn20 + ((fst happy_var_2, snd happy_var_2) + )} + +happyReduce_27 = happySpecReduce_3 6# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn21 + ((moc happy_var_1:mcc happy_var_3 + :(fst happy_var_2), snd happy_var_2) + )}}} + +happyReduce_28 = happySpecReduce_3 6# happyReduction_28 +happyReduction_28 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn21 + (([],snd happy_var_2) + )} + +happyReduce_29 = happySpecReduce_1 7# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn22 + ((fst happy_var_1 + ,(reverse $ snd happy_var_1,[])) + )} + +happyReduce_30 = happyMonadReduce 3# 7# happyReduction_30 +happyReduction_30 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + ( if null (snd happy_var_1) + then return ((mj AnnSemi happy_var_2:(fst happy_var_1)) + ,(reverse $ snd happy_var_1,happy_var_3)) + else do + { addAnnotation (gl $ head $ snd happy_var_1) + AnnSemi (gl happy_var_2) + ; return (fst happy_var_1 + ,(reverse $ snd happy_var_1,happy_var_3)) })}}} + ) (\r -> happyReturn (happyIn22 r)) + +happyReduce_31 = happySpecReduce_1 7# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn22 + (([],([],happy_var_1)) + )} + +happyReduce_32 = happySpecReduce_1 8# happyReduction_32 +happyReduction_32 happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn23 + (cvTopDecls happy_var_1 + )} + +happyReduce_33 = happyMonadReduce 7# 9# happyReduction_33 +happyReduction_33 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut261 happy_x_3 of { happy_var_3 -> + case happyOut19 happy_x_4 of { happy_var_4 -> + case happyOut27 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + case happyOut25 happy_x_7 of { happy_var_7 -> + ( fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 + )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])}}}}}}} + ) (\r -> happyReturn (happyIn24 r)) + +happyReduce_34 = happyMonadReduce 1# 9# happyReduction_34 +happyReduction_34 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut26 happy_x_1 of { happy_var_1 -> + ( fileSrcSpan >>= \ loc -> + return (L loc (HsModule Nothing Nothing happy_var_1 [] Nothing + Nothing)))} + ) (\r -> happyReturn (happyIn24 r)) + +happyReduce_35 = happySpecReduce_2 10# happyReduction_35 +happyReduction_35 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn25 + (snd happy_var_2 + )} + +happyReduce_36 = happySpecReduce_2 10# happyReduction_36 +happyReduction_36 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn25 + (snd happy_var_2 + )} + +happyReduce_37 = happySpecReduce_2 11# happyReduction_37 +happyReduction_37 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn26 + (snd happy_var_2 + )} + +happyReduce_38 = happySpecReduce_2 11# happyReduction_38 +happyReduction_38 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn26 + (snd happy_var_2 + )} + +happyReduce_39 = happyMonadReduce 3# 12# happyReduction_39 +happyReduction_39 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut28 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 ()) [mop happy_var_1,mcp happy_var_3] >> + return (Just (sLL happy_var_1 happy_var_3 (fromOL happy_var_2))))}}} + ) (\r -> happyReturn (happyIn27 r)) + +happyReduce_40 = happySpecReduce_0 12# happyReduction_40 +happyReduction_40 = happyIn27 + (Nothing + ) + +happyReduce_41 = happyMonadReduce 3# 13# happyReduction_41 +happyReduction_41 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_42 = happySpecReduce_1 13# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn28 + (happy_var_1 + )} + +happyReduce_43 = happyMonadReduce 5# 14# happyReduction_43 +happyReduction_43 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut29 happy_x_5 of { happy_var_5 -> + ( (addAnnotation (oll (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3)) + AnnComma (gl happy_var_4) ) >> + return (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 `appOL` happy_var_5))}}}}} + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_44 = happySpecReduce_3 14# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn29 + (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 + )}}} + +happyReduce_45 = happySpecReduce_1 14# happyReduction_45 +happyReduction_45 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn29 + (happy_var_1 + )} + +happyReduce_46 = happySpecReduce_2 15# happyReduction_46 +happyReduction_46 happy_x_2 + happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_2 of { happy_var_2 -> + happyIn30 + (happy_var_1 `appOL` happy_var_2 + )}} + +happyReduce_47 = happySpecReduce_0 15# happyReduction_47 +happyReduction_47 = happyIn30 + (nilOL + ) + +happyReduce_48 = happySpecReduce_1 16# happyReduction_48 +happyReduction_48 happy_x_1 + = case happyOut266 happy_x_1 of { happy_var_1 -> + happyIn31 + (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup n doc)) + )} + +happyReduce_49 = happySpecReduce_1 16# happyReduction_49 +happyReduction_49 happy_x_1 + = case happyOut265 happy_x_1 of { happy_var_1 -> + happyIn31 + (unitOL (sL1 happy_var_1 (IEDocNamed ((fst . unLoc) happy_var_1))) + )} + +happyReduce_50 = happySpecReduce_1 16# happyReduction_50 +happyReduction_50 happy_x_1 + = case happyOut263 happy_x_1 of { happy_var_1 -> + happyIn31 + (unitOL (sL1 happy_var_1 (IEDoc (unLoc happy_var_1))) + )} + +happyReduce_51 = happyMonadReduce 2# 17# happyReduction_51 +happyReduction_51 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut33 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 (mkModuleImpExp happy_var_1 + (snd $ unLoc happy_var_2))) + (fst $ unLoc happy_var_2))}} + ) (\r -> happyReturn (happyIn32 r)) + +happyReduce_52 = happyMonadReduce 2# 17# happyReduction_52 +happyReduction_52 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut261 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents happy_var_2)) + [mj AnnModule happy_var_1])}} + ) (\r -> happyReturn (happyIn32 r)) + +happyReduce_53 = happyMonadReduce 2# 17# happyReduction_53 +happyReduction_53 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut219 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 (IEVar happy_var_2)) + [mj AnnPattern happy_var_1])}} + ) (\r -> happyReturn (happyIn32 r)) + +happyReduce_54 = happySpecReduce_0 18# happyReduction_54 +happyReduction_54 = happyIn33 + (sL0 ([],ImpExpAbs) + ) + +happyReduce_55 = happySpecReduce_3 18# happyReduction_55 +happyReduction_55 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn33 + (sLL happy_var_1 happy_var_3 ([mop happy_var_1,mcp happy_var_3,mj AnnDotdot happy_var_2] + , ImpExpAll) + )}}} + +happyReduce_56 = happySpecReduce_2 18# happyReduction_56 +happyReduction_56 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn33 + (sLL happy_var_1 happy_var_2 ([mop happy_var_1,mcp happy_var_2],ImpExpList []) + )}} + +happyReduce_57 = happySpecReduce_3 18# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn33 + (sLL happy_var_1 happy_var_3 ([mop happy_var_1,mcp happy_var_3],ImpExpList (reverse happy_var_2)) + )}}} + +happyReduce_58 = happyMonadReduce 3# 19# happyReduction_58 +happyReduction_58 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut34 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + ( (aa (head happy_var_1) (AnnComma, happy_var_2)) >> + return (happy_var_3 : happy_var_1))}}} + ) (\r -> happyReturn (happyIn34 r)) + +happyReduce_59 = happySpecReduce_1 19# happyReduction_59 +happyReduction_59 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn34 + ([happy_var_1] + )} + +happyReduce_60 = happySpecReduce_1 20# happyReduction_60 +happyReduction_60 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn35 + (happy_var_1 + )} + +happyReduce_61 = happyMonadReduce 2# 20# happyReduction_61 +happyReduction_61 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_2 of { happy_var_2 -> + ( amms (mkTypeImpExp (sLL happy_var_1 happy_var_2 (unLoc happy_var_2))) + [mj AnnType happy_var_1,mj AnnVal happy_var_2])}} + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_62 = happySpecReduce_1 21# happyReduction_62 +happyReduction_62 happy_x_1 + = case happyOut245 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_63 = happySpecReduce_1 21# happyReduction_63 +happyReduction_63 happy_x_1 + = case happyOut219 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_64 = happyMonadReduce 3# 22# happyReduction_64 +happyReduction_64 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + ( if null (snd happy_var_1) + then return (mj AnnSemi happy_var_2:fst happy_var_1,happy_var_3 : snd happy_var_1) + else do + { addAnnotation (gl $ head $ snd happy_var_1) + AnnSemi (gl happy_var_2) + ; return (fst happy_var_1,happy_var_3 : snd happy_var_1) })}}} + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_65 = happyMonadReduce 2# 22# happyReduction_65 +happyReduction_65 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if null (snd happy_var_1) + then return ((mj AnnSemi happy_var_2:fst happy_var_1),snd happy_var_1) + else do + { addAnnotation (gl $ head $ snd happy_var_1) + AnnSemi (gl happy_var_2) + ; return happy_var_1})}} + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_66 = happySpecReduce_1 22# happyReduction_66 +happyReduction_66 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn37 + (([],[happy_var_1]) + )} + +happyReduce_67 = happySpecReduce_0 22# happyReduction_67 +happyReduction_67 = happyIn37 + (([],[]) + ) + +happyReduce_68 = happyMonadReduce 8# 23# happyReduction_68 +happyReduction_68 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut39 happy_x_2 of { happy_var_2 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + case happyOut42 happy_x_4 of { happy_var_4 -> + case happyOut41 happy_x_5 of { happy_var_5 -> + case happyOut261 happy_x_6 of { happy_var_6 -> + case happyOut43 happy_x_7 of { happy_var_7 -> + case happyOut44 happy_x_8 of { happy_var_8 -> + ( ams (L (comb4 happy_var_1 happy_var_6 (snd happy_var_7) happy_var_8) $ + ImportDecl { ideclSourceSrc = snd $ fst happy_var_2 + , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 + , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 + , ideclQualified = snd happy_var_4, ideclImplicit = False + , ideclAs = unLoc (snd happy_var_7) + , ideclHiding = unLoc happy_var_8 }) + ((mj AnnImport happy_var_1 : (fst $ fst happy_var_2) ++ fst happy_var_3 ++ fst happy_var_4 + ++ fst happy_var_5 ++ fst happy_var_7)))}}}}}}}} + ) (\r -> happyReturn (happyIn38 r)) + +happyReduce_69 = happySpecReduce_2 24# happyReduction_69 +happyReduction_69 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn39 + ((([mo happy_var_1,mc happy_var_2],Just (getSOURCE_PRAGs happy_var_1)) + ,True) + )}} + +happyReduce_70 = happySpecReduce_0 24# happyReduction_70 +happyReduction_70 = happyIn39 + ((([],Nothing),False) + ) + +happyReduce_71 = happySpecReduce_1 25# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn40 + (([mj AnnSafe happy_var_1],True) + )} + +happyReduce_72 = happySpecReduce_0 25# happyReduction_72 +happyReduction_72 = happyIn40 + (([],False) + ) + +happyReduce_73 = happySpecReduce_1 26# happyReduction_73 +happyReduction_73 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn41 + (([mj AnnPackageName happy_var_1] + ,Just (getSTRING happy_var_1)) + )} + +happyReduce_74 = happySpecReduce_0 26# happyReduction_74 +happyReduction_74 = happyIn41 + (([],Nothing) + ) + +happyReduce_75 = happySpecReduce_1 27# happyReduction_75 +happyReduction_75 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn42 + (([mj AnnQualified happy_var_1],True) + )} + +happyReduce_76 = happySpecReduce_0 27# happyReduction_76 +happyReduction_76 = happyIn42 + (([],False) + ) + +happyReduce_77 = happySpecReduce_2 28# happyReduction_77 +happyReduction_77 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut261 happy_x_2 of { happy_var_2 -> + happyIn43 + (([mj AnnAs happy_var_1,mj AnnVal happy_var_2] + ,sLL happy_var_1 happy_var_2 (Just (unLoc happy_var_2))) + )}} + +happyReduce_78 = happySpecReduce_0 28# happyReduction_78 +happyReduction_78 = happyIn43 + (([],noLoc Nothing) + ) + +happyReduce_79 = happySpecReduce_1 29# happyReduction_79 +happyReduction_79 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44 + (L (gl happy_var_1) (Just (unLoc happy_var_1)) + )} + +happyReduce_80 = happySpecReduce_0 29# happyReduction_80 +happyReduction_80 = happyIn44 + (noLoc Nothing + ) + +happyReduce_81 = happyMonadReduce 3# 30# happyReduction_81 +happyReduction_81 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut28 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (False, + sLL happy_var_1 happy_var_3 $ fromOL happy_var_2)) + [mop happy_var_1,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn45 r)) + +happyReduce_82 = happyMonadReduce 4# 30# happyReduction_82 +happyReduction_82 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut28 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 (True, + sLL happy_var_1 happy_var_4 $ fromOL happy_var_3)) + [mj AnnHiding happy_var_1,mop happy_var_2,mcp happy_var_4])}}}} + ) (\r -> happyReturn (happyIn45 r)) + +happyReduce_83 = happySpecReduce_0 31# happyReduction_83 +happyReduction_83 = happyIn46 + (noLoc 9 + ) + +happyReduce_84 = happyMonadReduce 1# 31# happyReduction_84 +happyReduction_84 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( checkPrecP (sL1 happy_var_1 (fromInteger (getINTEGER happy_var_1))))} + ) (\r -> happyReturn (happyIn46 r)) + +happyReduce_85 = happySpecReduce_1 32# happyReduction_85 +happyReduction_85 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn47 + (sL1 happy_var_1 InfixN + )} + +happyReduce_86 = happySpecReduce_1 32# happyReduction_86 +happyReduction_86 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn47 + (sL1 happy_var_1 InfixL + )} + +happyReduce_87 = happySpecReduce_1 32# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn47 + (sL1 happy_var_1 InfixR + )} + +happyReduce_88 = happyMonadReduce 3# 33# happyReduction_88 +happyReduction_88 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut235 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 ((unLoc happy_var_1) `appOL` unitOL happy_var_3)))}}} + ) (\r -> happyReturn (happyIn48 r)) + +happyReduce_89 = happySpecReduce_1 33# happyReduction_89 +happyReduction_89 happy_x_1 + = case happyOut235 happy_x_1 of { happy_var_1 -> + happyIn48 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_90 = happyMonadReduce 3# 34# happyReduction_90 +happyReduction_90 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut49 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn49 r)) + +happyReduce_91 = happyMonadReduce 2# 34# happyReduction_91 +happyReduction_91 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut49 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)}} + ) (\r -> happyReturn (happyIn49 r)) + +happyReduce_92 = happySpecReduce_1 34# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn49 + (happy_var_1 + )} + +happyReduce_93 = happySpecReduce_1 35# happyReduction_93 +happyReduction_93 happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sL1 happy_var_1 (TyClD (unLoc happy_var_1))) + )} + +happyReduce_94 = happySpecReduce_1 35# happyReduction_94 +happyReduction_94 happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sL1 happy_var_1 (TyClD (unLoc happy_var_1))) + )} + +happyReduce_95 = happySpecReduce_1 35# happyReduction_95 +happyReduction_95 happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sL1 happy_var_1 (InstD (unLoc happy_var_1))) + )} + +happyReduce_96 = happySpecReduce_1 35# happyReduction_96 +happyReduction_96 happy_x_1 + = case happyOut66 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sLL happy_var_1 happy_var_1 (DerivD (unLoc happy_var_1))) + )} + +happyReduce_97 = happySpecReduce_1 35# happyReduction_97 +happyReduction_97 happy_x_1 + = case happyOut67 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sL1 happy_var_1 (RoleAnnotD (unLoc happy_var_1))) + )} + +happyReduce_98 = happyMonadReduce 4# 35# happyReduction_98 +happyReduction_98 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut123 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { def <- checkValidDefaults happy_var_3 + ; amsu (sLL happy_var_1 happy_var_4 (DefD def)) + [mj AnnDefault happy_var_1 + ,mop happy_var_2,mcp happy_var_4] })}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_99 = happyMonadReduce 2# 35# happyReduction_99 +happyReduction_99 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut103 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 (snd $ unLoc happy_var_2)) + (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_100 = happyMonadReduce 3# 35# happyReduction_100 +happyReduction_100 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut98 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsu (sLL happy_var_1 happy_var_3 $ WarningD (Warnings (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_101 = happyMonadReduce 3# 35# happyReduction_101 +happyReduction_101 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut96 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsu (sLL happy_var_1 happy_var_3 $ WarningD (Warnings (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_102 = happyMonadReduce 3# 35# happyReduction_102 +happyReduction_102 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut89 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsu (sLL happy_var_1 happy_var_3 $ RuleD (HsRules (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_103 = happyMonadReduce 5# 35# happyReduction_103 +happyReduction_103 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut245 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsu (sLL happy_var_1 happy_var_5 $ VectD (HsVect (getVECT_PRAGs happy_var_1) happy_var_2 happy_var_4)) + [mo happy_var_1,mj AnnEqual happy_var_3 + ,mc happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_104 = happyMonadReduce 3# 35# happyReduction_104 +happyReduction_104 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut245 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsu (sLL happy_var_1 happy_var_3 $ VectD (HsNoVect (getNOVECT_PRAGs happy_var_1) happy_var_2)) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_105 = happyMonadReduce 4# 35# happyReduction_105 +happyReduction_105 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsu (sLL happy_var_1 happy_var_4 $ + VectD (HsVectTypeIn (getVECT_PRAGs happy_var_1) False happy_var_3 Nothing)) + [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_106 = happyMonadReduce 4# 35# happyReduction_106 +happyReduction_106 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsu (sLL happy_var_1 happy_var_4 $ + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs happy_var_1) True happy_var_3 Nothing)) + [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_107 = happyMonadReduce 6# 35# happyReduction_107 +happyReduction_107 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut227 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( amsu (sLL happy_var_1 happy_var_6 $ + VectD (HsVectTypeIn (getVECT_PRAGs happy_var_1) False happy_var_3 (Just happy_var_5))) + [mo happy_var_1,mj AnnType happy_var_2,mj AnnEqual happy_var_4,mc happy_var_6])}}}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_108 = happyMonadReduce 6# 35# happyReduction_108 +happyReduction_108 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut227 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( amsu (sLL happy_var_1 happy_var_6 $ + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs happy_var_1) True happy_var_3 (Just happy_var_5))) + [mo happy_var_1,mj AnnType happy_var_2,mj AnnEqual happy_var_4,mc happy_var_6])}}}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_109 = happyMonadReduce 4# 35# happyReduction_109 +happyReduction_109 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsu (sLL happy_var_1 happy_var_4 $ VectD (HsVectClassIn (getVECT_PRAGs happy_var_1) happy_var_3)) + [mo happy_var_1,mj AnnClass happy_var_2,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_110 = happySpecReduce_1 35# happyReduction_110 +happyReduction_110 happy_x_1 + = case happyOut102 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL happy_var_1 + )} + +happyReduce_111 = happySpecReduce_1 35# happyReduction_111 +happyReduction_111 happy_x_1 + = case happyOut150 happy_x_1 of { happy_var_1 -> + happyIn50 + (unLoc happy_var_1 + )} + +happyReduce_112 = happySpecReduce_1 35# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut160 happy_x_1 of { happy_var_1 -> + happyIn50 + (unitOL (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1) + )} + +happyReduce_113 = happyMonadReduce 4# 36# happyReduction_113 +happyReduction_113 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut64 happy_x_2 of { happy_var_2 -> + case happyOut127 happy_x_3 of { happy_var_3 -> + case happyOut80 happy_x_4 of { happy_var_4 -> + ( amms (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (snd $ unLoc happy_var_4)) + (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fst $ unLoc happy_var_4)))}}}} + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_114 = happyMonadReduce 4# 37# happyReduction_114 +happyReduction_114 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut117 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut115 happy_x_4 of { happy_var_4 -> + ( amms (mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4) + [mj AnnType happy_var_1,mj AnnEqual happy_var_3])}}}} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_115 = happyMonadReduce 5# 37# happyReduction_115 +happyReduction_115 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + case happyOut55 happy_x_5 of { happy_var_5 -> + ( amms (mkFamDecl (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_5) happy_var_3 + (snd $ unLoc happy_var_4)) + (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_116 = happyMonadReduce 5# 37# happyReduction_116 +happyReduction_116 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + case happyOut139 happy_x_4 of { happy_var_4 -> + case happyOut147 happy_x_5 of { happy_var_5 -> + ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 + Nothing (reverse (snd $ unLoc happy_var_4)) + (unLoc happy_var_5)) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_117 = happyMonadReduce 6# 37# happyReduction_117 +happyReduction_117 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + case happyOut136 happy_x_5 of { happy_var_5 -> + case happyOut147 happy_x_6 of { happy_var_6 -> + ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (unLoc happy_var_6) ) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_118 = happyMonadReduce 4# 37# happyReduction_118 +happyReduction_118 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + ( amms (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily happy_var_3 (snd $ unLoc happy_var_4)) + (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_119 = happyMonadReduce 4# 38# happyReduction_119 +happyReduction_119 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut54 happy_x_2 of { happy_var_2 -> + case happyOut121 happy_x_3 of { happy_var_3 -> + case happyOut84 happy_x_4 of { happy_var_4 -> + ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) + ; let cid = ClsInstDecl { cid_poly_ty = happy_var_3, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = happy_var_2 + , cid_datafam_insts = adts } + ; let err = text "In instance head:" <+> ppr happy_var_3 + ; checkNoPartialType err happy_var_3 + ; sequence_ [ checkNoPartialType err ty + | sig@(L _ (TypeSig _ ty _ )) <- sigs + , let err = text "in instance signature" <> colon + <+> quotes (ppr sig) ] + ; ams (L (comb3 happy_var_1 happy_var_3 happy_var_4) (ClsInstD { cid_inst = cid })) + (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) })}}}} + ) (\r -> happyReturn (happyIn53 r)) + +happyReduce_120 = happyMonadReduce 3# 38# happyReduction_120 +happyReduction_120 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + ( ams happy_var_3 (fst $ unLoc happy_var_3) + >> amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) + (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn53 r)) + +happyReduce_121 = happyMonadReduce 6# 38# happyReduction_121 +happyReduction_121 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut65 happy_x_3 of { happy_var_3 -> + case happyOut64 happy_x_4 of { happy_var_4 -> + case happyOut139 happy_x_5 of { happy_var_5 -> + case happyOut147 happy_x_6 of { happy_var_6 -> + ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 happy_var_4 + Nothing (reverse (snd $ unLoc happy_var_5)) + (unLoc happy_var_6)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_5)))}}}}}} + ) (\r -> happyReturn (happyIn53 r)) + +happyReduce_122 = happyMonadReduce 7# 38# happyReduction_122 +happyReduction_122 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut65 happy_x_3 of { happy_var_3 -> + case happyOut64 happy_x_4 of { happy_var_4 -> + case happyOut63 happy_x_5 of { happy_var_5 -> + case happyOut136 happy_x_6 of { happy_var_6 -> + case happyOut147 happy_x_7 of { happy_var_7 -> + ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 happy_var_4 + (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) (unLoc happy_var_7)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2 + :(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}} + ) (\r -> happyReturn (happyIn53 r)) + +happyReduce_123 = happyMonadReduce 2# 39# happyReduction_123 +happyReduction_123 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_124 = happyMonadReduce 2# 39# happyReduction_124 +happyReduction_124 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_125 = happyMonadReduce 2# 39# happyReduction_125 +happyReduction_125 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ajs (Just (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_126 = happyMonadReduce 2# 39# happyReduction_126 +happyReduction_126 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ajs (Just (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_127 = happySpecReduce_0 39# happyReduction_127 +happyReduction_127 = happyIn54 + (Nothing + ) + +happyReduce_128 = happySpecReduce_0 40# happyReduction_128 +happyReduction_128 = happyIn55 + (noLoc ([],OpenTypeFamily) + ) + +happyReduce_129 = happySpecReduce_2 40# happyReduction_129 +happyReduction_129 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn55 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,ClosedTypeFamily (reverse (snd $ unLoc happy_var_2))) + )}} + +happyReduce_130 = happySpecReduce_3 41# happyReduction_130 +happyReduction_130 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut57 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn56 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] + ,unLoc happy_var_2) + )}}} + +happyReduce_131 = happySpecReduce_3 41# happyReduction_131 +happyReduction_131 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_2 of { happy_var_2 -> + happyIn56 + (let L loc _ = happy_var_2 in + L loc ([],unLoc happy_var_2) + )} + +happyReduce_132 = happySpecReduce_3 41# happyReduction_132 +happyReduction_132 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn56 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 + ,mcc happy_var_3],[]) + )}}} + +happyReduce_133 = happySpecReduce_3 41# happyReduction_133 +happyReduction_133 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn56 + (let L loc _ = happy_var_2 in + L loc ([mj AnnDotdot happy_var_2],[]) + )} + +happyReduce_134 = happyMonadReduce 3# 42# happyReduction_134 +happyReduction_134 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut57 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + ( asl (unLoc happy_var_1) happy_var_2 (snd $ unLoc happy_var_3) + >> ams happy_var_3 (fst $ unLoc happy_var_3) + >> return (sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) : unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn57 r)) + +happyReduce_135 = happyMonadReduce 2# 42# happyReduction_135 +happyReduction_135 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut57 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}} + ) (\r -> happyReturn (happyIn57 r)) + +happyReduce_136 = happyMonadReduce 1# 42# happyReduction_136 +happyReduction_136 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut58 happy_x_1 of { happy_var_1 -> + ( ams happy_var_1 (fst $ unLoc happy_var_1) + >> return (sLL happy_var_1 happy_var_1 [snd $ unLoc happy_var_1]))} + ) (\r -> happyReturn (happyIn57 r)) + +happyReduce_137 = happyMonadReduce 3# 43# happyReduction_137 +happyReduction_137 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut117 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut114 happy_x_3 of { happy_var_3 -> + ( do { (eqn,ann) <- mkTyFamInstEqn happy_var_1 happy_var_3 + ; return (sLL happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:ann, sLL happy_var_1 happy_var_3 eqn)) })}}} + ) (\r -> happyReturn (happyIn58 r)) + +happyReduce_138 = happyMonadReduce 4# 44# happyReduction_138 +happyReduction_138 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily happy_var_3 + (snd $ unLoc happy_var_4))) + (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4)))}}}} + ) (\r -> happyReturn (happyIn59 r)) + +happyReduce_139 = happyMonadReduce 3# 44# happyReduction_139 +happyReduction_139 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut117 happy_x_2 of { happy_var_2 -> + case happyOut63 happy_x_3 of { happy_var_3 -> + ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) + OpenTypeFamily happy_var_2 (snd $ unLoc happy_var_3))) + (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn59 r)) + +happyReduce_140 = happyMonadReduce 4# 44# happyReduction_140 +happyReduction_140 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) + OpenTypeFamily happy_var_3 (snd $ unLoc happy_var_4))) + (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}} + ) (\r -> happyReturn (happyIn59 r)) + +happyReduce_141 = happyMonadReduce 2# 44# happyReduction_141 +happyReduction_141 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + ( ams happy_var_2 (fst $ unLoc happy_var_2) >> + amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2))) + (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn59 r)) + +happyReduce_142 = happyMonadReduce 3# 44# happyReduction_142 +happyReduction_142 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + ( ams happy_var_3 (fst $ unLoc happy_var_3) >> + amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3))) + (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn59 r)) + +happyReduce_143 = happySpecReduce_0 45# happyReduction_143 +happyReduction_143 = happyIn60 + ([] + ) + +happyReduce_144 = happySpecReduce_1 45# happyReduction_144 +happyReduction_144 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn60 + ([mj AnnFamily happy_var_1] + )} + +happyReduce_145 = happyMonadReduce 2# 46# happyReduction_145 +happyReduction_145 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + ( ams happy_var_2 (fst $ unLoc happy_var_2) >> + amms (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2)) + (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn61 r)) + +happyReduce_146 = happyMonadReduce 5# 46# happyReduction_146 +happyReduction_146 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + case happyOut139 happy_x_4 of { happy_var_4 -> + case happyOut147 happy_x_5 of { happy_var_5 -> + ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 + Nothing (reverse (snd $ unLoc happy_var_4)) + (unLoc happy_var_5)) + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}} + ) (\r -> happyReturn (happyIn61 r)) + +happyReduce_147 = happyMonadReduce 6# 46# happyReduction_147 +happyReduction_147 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + case happyOut63 happy_x_4 of { happy_var_4 -> + case happyOut136 happy_x_5 of { happy_var_5 -> + case happyOut147 happy_x_6 of { happy_var_6 -> + ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 + happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (unLoc happy_var_6)) + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}} + ) (\r -> happyReturn (happyIn61 r)) + +happyReduce_148 = happySpecReduce_1 47# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn62 + (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) + )} + +happyReduce_149 = happySpecReduce_1 47# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn62 + (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) + )} + +happyReduce_150 = happySpecReduce_0 48# happyReduction_150 +happyReduction_150 = happyIn63 + (noLoc ([],Nothing) + ) + +happyReduce_151 = happySpecReduce_2 48# happyReduction_151 +happyReduction_151 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { happy_var_2 -> + happyIn63 + (sLL happy_var_1 happy_var_2 ([mj AnnDcolon happy_var_1],Just (happy_var_2)) + )}} + +happyReduce_152 = happyMonadReduce 3# 49# happyReduction_152 +happyReduction_152 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut116 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnDarrow (gl happy_var_2) + >> (return (sLL happy_var_1 happy_var_3 (Just happy_var_1, happy_var_3))))}}} + ) (\r -> happyReturn (happyIn64 r)) + +happyReduce_153 = happySpecReduce_1 49# happyReduction_153 +happyReduction_153 happy_x_1 + = case happyOut117 happy_x_1 of { happy_var_1 -> + happyIn64 + (sL1 happy_var_1 (Nothing, happy_var_1) + )} + +happyReduce_154 = happyMonadReduce 4# 50# happyReduction_154 +happyReduction_154 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ajs (Just (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRING happy_var_2))) + (getSTRING happy_var_3)))) + [mo happy_var_1,mj AnnHeader happy_var_2,mj AnnVal happy_var_3,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn65 r)) + +happyReduce_155 = happyMonadReduce 3# 50# happyReduction_155 +happyReduction_155 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ajs (Just (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRING happy_var_2)))) + [mo happy_var_1,mj AnnVal happy_var_2,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn65 r)) + +happyReduce_156 = happySpecReduce_0 50# happyReduction_156 +happyReduction_156 = happyIn65 + (Nothing + ) + +happyReduce_157 = happyMonadReduce 4# 51# happyReduction_157 +happyReduction_157 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + case happyOut121 happy_x_4 of { happy_var_4 -> + ( do { + let err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr happy_var_4) + ; checkNoPartialType err happy_var_4 + ; ams (sLL happy_var_1 happy_var_4 (DerivDecl happy_var_4 happy_var_3)) + [mj AnnDeriving happy_var_1,mj AnnInstance happy_var_2] })}}}} + ) (\r -> happyReturn (happyIn66 r)) + +happyReduce_158 = happyMonadReduce 4# 52# happyReduction_158 +happyReduction_158 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut229 happy_x_3 of { happy_var_3 -> + case happyOut68 happy_x_4 of { happy_var_4 -> + ( amms (mkRoleAnnotDecl (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_3 (reverse (unLoc happy_var_4))) + [mj AnnType happy_var_1,mj AnnRole happy_var_2])}}}} + ) (\r -> happyReturn (happyIn67 r)) + +happyReduce_159 = happySpecReduce_0 53# happyReduction_159 +happyReduction_159 = happyIn68 + (noLoc [] + ) + +happyReduce_160 = happySpecReduce_1 53# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + happyIn68 + (happy_var_1 + )} + +happyReduce_161 = happySpecReduce_1 54# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn69 + (sLL happy_var_1 happy_var_1 [happy_var_1] + )} + +happyReduce_162 = happySpecReduce_2 54# happyReduction_162 +happyReduction_162 happy_x_2 + happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut70 happy_x_2 of { happy_var_2 -> + happyIn69 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 + )}} + +happyReduce_163 = happySpecReduce_1 55# happyReduction_163 +happyReduction_163 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn70 + (sL1 happy_var_1 $ Just $ getVARID happy_var_1 + )} + +happyReduce_164 = happySpecReduce_1 55# happyReduction_164 +happyReduction_164 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn70 + (sL1 happy_var_1 Nothing + )} + +happyReduce_165 = happyMonadReduce 4# 56# happyReduction_165 +happyReduction_165 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut72 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut197 happy_x_4 of { happy_var_4 -> + (ams ( let (name, args) = happy_var_2 + in sLL happy_var_1 happy_var_4 . ValD $ mkPatSynBind name args happy_var_4 + ImplicitBidirectional) + [mj AnnPattern happy_var_1,mj AnnEqual happy_var_3])}}}} + ) (\r -> happyReturn (happyIn71 r)) + +happyReduce_166 = happyMonadReduce 4# 56# happyReduction_166 +happyReduction_166 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut72 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut197 happy_x_4 of { happy_var_4 -> + (ams (let (name, args) = happy_var_2 + in sLL happy_var_1 happy_var_4 . ValD $ mkPatSynBind name args happy_var_4 Unidirectional) + [mj AnnPattern happy_var_1,mj AnnLarrow happy_var_3])}}}} + ) (\r -> happyReturn (happyIn71 r)) + +happyReduce_167 = happyMonadReduce 5# 56# happyReduction_167 +happyReduction_167 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut72 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut197 happy_x_4 of { happy_var_4 -> + case happyOut74 happy_x_5 of { happy_var_5 -> + ( do { let (name, args) = happy_var_2 + ; mg <- mkPatSynMatchGroup name (snd $ unLoc happy_var_5) + ; ams (sLL happy_var_1 happy_var_5 . ValD $ + mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)) + (mj AnnPattern happy_var_1:mj AnnLarrow happy_var_3:(fst $ unLoc happy_var_5)) + })}}}}} + ) (\r -> happyReturn (happyIn71 r)) + +happyReduce_168 = happySpecReduce_2 57# happyReduction_168 +happyReduction_168 happy_x_2 + happy_x_1 + = case happyOut221 happy_x_1 of { happy_var_1 -> + case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn72 + ((happy_var_1, PrefixPatSyn happy_var_2) + )}} + +happyReduce_169 = happySpecReduce_3 57# happyReduction_169 +happyReduction_169 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut247 happy_x_1 of { happy_var_1 -> + case happyOut225 happy_x_2 of { happy_var_2 -> + case happyOut247 happy_x_3 of { happy_var_3 -> + happyIn72 + ((happy_var_2, InfixPatSyn happy_var_1 happy_var_3) + )}}} + +happyReduce_170 = happySpecReduce_0 58# happyReduction_170 +happyReduction_170 = happyIn73 + ([] + ) + +happyReduce_171 = happySpecReduce_2 58# happyReduction_171 +happyReduction_171 happy_x_2 + happy_x_1 + = case happyOut247 happy_x_1 of { happy_var_1 -> + case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn73 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_172 = happyReduce 4# 59# happyReduction_172 +happyReduction_172 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut85 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn74 + (sLL happy_var_1 happy_var_4 ((mj AnnWhere happy_var_1:moc happy_var_2 + :mcc happy_var_4:(fst $ unLoc happy_var_3)),sL1 happy_var_3 (snd $ unLoc happy_var_3)) + ) `HappyStk` happyRest}}}} + +happyReduce_173 = happyReduce 4# 59# happyReduction_173 +happyReduction_173 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut85 happy_x_3 of { happy_var_3 -> + happyIn74 + (L (comb2 happy_var_1 happy_var_3) ((mj AnnWhere happy_var_1:(fst $ unLoc happy_var_3)) + ,sL1 happy_var_3 (snd $ unLoc happy_var_3)) + ) `HappyStk` happyRest}} + +happyReduce_174 = happyMonadReduce 4# 60# happyReduction_174 +happyReduction_174 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut76 happy_x_4 of { happy_var_4 -> + ( do { let (flag, qtvs, prov, req, ty) = snd $ unLoc happy_var_4 + ; let sig = PatSynSig happy_var_2 (flag, mkHsQTvs qtvs) prov req ty + ; checkValidPatSynSig sig + ; ams (sLL happy_var_1 happy_var_4 $ sig) + (mj AnnPattern happy_var_1:mj AnnDcolon happy_var_3:(fst $ unLoc happy_var_4)) })}}}} + ) (\r -> happyReturn (happyIn75 r)) + +happyReduce_175 = happyMonadReduce 4# 61# happyReduction_175 +happyReduction_175 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut76 happy_x_4 of { happy_var_4 -> + ( do { hintExplicitForall (getLoc happy_var_1) + ; let (_, qtvs', prov, req, ty) = snd $ unLoc happy_var_4 + ; return $ sLL happy_var_1 happy_var_4 + ((mj AnnForall happy_var_1:mj AnnDot happy_var_3:(fst $ unLoc happy_var_4)) + ,(Explicit, happy_var_2 ++ qtvs', prov, req ,ty)) })}}}} + ) (\r -> happyReturn (happyIn76 r)) + +happyReduce_176 = happyReduce 5# 61# happyReduction_176 +happyReduction_176 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut116 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut116 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut117 happy_x_5 of { happy_var_5 -> + happyIn76 + (sLL happy_var_1 happy_var_5 ([mj AnnDarrow happy_var_2,mj AnnDarrow happy_var_4] + ,(Implicit, [], happy_var_1, happy_var_3, happy_var_5)) + ) `HappyStk` happyRest}}}}} + +happyReduce_177 = happySpecReduce_3 61# happyReduction_177 +happyReduction_177 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut116 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + happyIn76 + (sLL happy_var_1 happy_var_3 ([mj AnnDarrow happy_var_2],(Implicit, [], happy_var_1, noLoc [], happy_var_3)) + )}}} + +happyReduce_178 = happySpecReduce_1 61# happyReduction_178 +happyReduction_178 happy_x_1 + = case happyOut117 happy_x_1 of { happy_var_1 -> + happyIn76 + (sL1 happy_var_1 ([],(Implicit, [], noLoc [], noLoc [], happy_var_1)) + )} + +happyReduce_179 = happySpecReduce_1 62# happyReduction_179 +happyReduction_179 happy_x_1 + = case happyOut59 happy_x_1 of { happy_var_1 -> + happyIn77 + (sLL happy_var_1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_180 = happySpecReduce_1 62# happyReduction_180 +happyReduction_180 happy_x_1 + = case happyOut151 happy_x_1 of { happy_var_1 -> + happyIn77 + (happy_var_1 + )} + +happyReduce_181 = happyMonadReduce 4# 62# happyReduction_181 +happyReduction_181 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut160 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut110 happy_x_4 of { happy_var_4 -> + ( do { (TypeSig l ty _) <- checkValSig happy_var_2 happy_var_4 + ; let err = text "in default signature" <> colon <+> + quotes (ppr ty) + ; checkNoPartialType err ty + ; ams (sLL happy_var_1 happy_var_4 $ unitOL (sLL happy_var_1 happy_var_4 $ SigD (GenericSig l ty))) + [mj AnnDefault happy_var_1,mj AnnDcolon happy_var_3] })}}}} + ) (\r -> happyReturn (happyIn77 r)) + +happyReduce_182 = happyMonadReduce 3# 63# happyReduction_182 +happyReduction_182 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut78 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut77 happy_x_3 of { happy_var_3 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unLoc happy_var_3)) + else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + ,(snd $ unLoc happy_var_1) `appOL` unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn78 r)) + +happyReduce_183 = happyMonadReduce 2# 63# happyReduction_183 +happyReduction_183 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut78 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}} + ) (\r -> happyReturn (happyIn78 r)) + +happyReduce_184 = happySpecReduce_1 63# happyReduction_184 +happyReduction_184 happy_x_1 + = case happyOut77 happy_x_1 of { happy_var_1 -> + happyIn78 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_185 = happySpecReduce_0 63# happyReduction_185 +happyReduction_185 = happyIn78 + (noLoc ([],nilOL) + ) + +happyReduce_186 = happySpecReduce_3 64# happyReduction_186 +happyReduction_186 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut78 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn79 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + )}}} + +happyReduce_187 = happySpecReduce_3 64# happyReduction_187 +happyReduction_187 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut78 happy_x_2 of { happy_var_2 -> + happyIn79 + (happy_var_2 + )} + +happyReduce_188 = happySpecReduce_2 65# happyReduction_188 +happyReduction_188 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn80 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_189 = happySpecReduce_0 65# happyReduction_189 +happyReduction_189 = happyIn80 + (noLoc ([],nilOL) + ) + +happyReduce_190 = happySpecReduce_1 66# happyReduction_190 +happyReduction_190 happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + happyIn81 + (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD (unLoc happy_var_1)))) + )} + +happyReduce_191 = happySpecReduce_1 66# happyReduction_191 +happyReduction_191 happy_x_1 + = case happyOut151 happy_x_1 of { happy_var_1 -> + happyIn81 + (happy_var_1 + )} + +happyReduce_192 = happyMonadReduce 3# 67# happyReduction_192 +happyReduction_192 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut82 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut81 happy_x_3 of { happy_var_3 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unLoc happy_var_3)) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return + (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + ,(snd $ unLoc happy_var_1) `appOL` unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_193 = happyMonadReduce 2# 67# happyReduction_193 +happyReduction_193 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut82 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}} + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_194 = happySpecReduce_1 67# happyReduction_194 +happyReduction_194 happy_x_1 + = case happyOut81 happy_x_1 of { happy_var_1 -> + happyIn82 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_195 = happySpecReduce_0 67# happyReduction_195 +happyReduction_195 = happyIn82 + (noLoc ([],nilOL) + ) + +happyReduce_196 = happySpecReduce_3 68# happyReduction_196 +happyReduction_196 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut82 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn83 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + )}}} + +happyReduce_197 = happySpecReduce_3 68# happyReduction_197 +happyReduction_197 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut82 happy_x_2 of { happy_var_2 -> + happyIn83 + (L (gl happy_var_2) (unLoc happy_var_2) + )} + +happyReduce_198 = happySpecReduce_2 69# happyReduction_198 +happyReduction_198 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut83 happy_x_2 of { happy_var_2 -> + happyIn84 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,(snd $ unLoc happy_var_2)) + )}} + +happyReduce_199 = happySpecReduce_0 69# happyReduction_199 +happyReduction_199 = happyIn84 + (noLoc ([],nilOL) + ) + +happyReduce_200 = happyMonadReduce 3# 70# happyReduction_200 +happyReduction_200 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut85 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut151 happy_x_3 of { happy_var_3 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unLoc happy_var_3)) + else do ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return ( + let { this = unLoc happy_var_3; + rest = snd $ unLoc happy_var_1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,these))))}}} + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_201 = happyMonadReduce 2# 70# happyReduction_201 +happyReduction_201 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut85 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1))) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}} + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_202 = happySpecReduce_1 70# happyReduction_202 +happyReduction_202 happy_x_1 + = case happyOut151 happy_x_1 of { happy_var_1 -> + happyIn85 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_203 = happySpecReduce_0 70# happyReduction_203 +happyReduction_203 = happyIn85 + (noLoc ([],nilOL) + ) + +happyReduce_204 = happySpecReduce_3 71# happyReduction_204 +happyReduction_204 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut85 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn86 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + )}}} + +happyReduce_205 = happySpecReduce_3 71# happyReduction_205 +happyReduction_205 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut85 happy_x_2 of { happy_var_2 -> + happyIn86 + (L (gl happy_var_2) (fst $ unLoc happy_var_2,snd $ unLoc happy_var_2) + )} + +happyReduce_206 = happyMonadReduce 1# 72# happyReduction_206 +happyReduction_206 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut86 happy_x_1 of { happy_var_1 -> + ( do { val_binds <- cvBindGroup (snd $ unLoc happy_var_1) + ; return (sL1 happy_var_1 (fst $ unLoc happy_var_1 + ,HsValBinds val_binds)) })} + ) (\r -> happyReturn (happyIn87 r)) + +happyReduce_207 = happySpecReduce_3 72# happyReduction_207 +happyReduction_207 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut209 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn87 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] + ,HsIPBinds (IPBinds (unLoc happy_var_2) + emptyTcEvBinds)) + )}}} + +happyReduce_208 = happySpecReduce_3 72# happyReduction_208 +happyReduction_208 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut209 happy_x_2 of { happy_var_2 -> + happyIn87 + (L (getLoc happy_var_2) ([] + ,HsIPBinds (IPBinds (unLoc happy_var_2) + emptyTcEvBinds)) + )} + +happyReduce_209 = happySpecReduce_2 73# happyReduction_209 +happyReduction_209 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut87 happy_x_2 of { happy_var_2 -> + happyIn88 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1 : (fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_210 = happySpecReduce_0 73# happyReduction_210 +happyReduction_210 = happyIn88 + (noLoc ([],emptyLocalBinds) + ) + +happyReduce_211 = happyMonadReduce 3# 74# happyReduction_211 +happyReduction_211 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut89 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut90 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `snocOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_212 = happyMonadReduce 2# 74# happyReduction_212 +happyReduction_212 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut89 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)}} + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_213 = happySpecReduce_1 74# happyReduction_213 +happyReduction_213 happy_x_1 + = case happyOut90 happy_x_1 of { happy_var_1 -> + happyIn89 + (unitOL happy_var_1 + )} + +happyReduce_214 = happySpecReduce_0 74# happyReduction_214 +happyReduction_214 = happyIn89 + (nilOL + ) + +happyReduce_215 = happyMonadReduce 6# 75# happyReduction_215 +happyReduction_215 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut91 happy_x_2 of { happy_var_2 -> + case happyOut93 happy_x_3 of { happy_var_3 -> + case happyOut160 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut159 happy_x_6 of { happy_var_6 -> + (ams (sLL happy_var_1 happy_var_6 $ (HsRule (L (gl happy_var_1) (getSTRING happy_var_1)) + ((snd happy_var_2) `orElse` AlwaysActive) + (snd happy_var_3) happy_var_4 placeHolderNames happy_var_6 + placeHolderNames)) + (mj AnnEqual happy_var_5 : (fst happy_var_2) ++ (fst happy_var_3)))}}}}}} + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_216 = happySpecReduce_0 76# happyReduction_216 +happyReduction_216 = happyIn91 + (([],Nothing) + ) + +happyReduce_217 = happySpecReduce_1 76# happyReduction_217 +happyReduction_217 happy_x_1 + = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn91 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_218 = happySpecReduce_3 77# happyReduction_218 +happyReduction_218 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn92 + (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3] + ,ActiveAfter (fromInteger (getINTEGER happy_var_2))) + )}}} + +happyReduce_219 = happyReduce 4# 77# happyReduction_219 +happyReduction_219 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn92 + (([mos happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3,mcs happy_var_4] + ,ActiveBefore (fromInteger (getINTEGER happy_var_3))) + ) `HappyStk` happyRest}}}} + +happyReduce_220 = happySpecReduce_3 77# happyReduction_220 +happyReduction_220 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn92 + (([mos happy_var_1,mj AnnTilde happy_var_2,mcs happy_var_3] + ,NeverActive) + )}}} + +happyReduce_221 = happySpecReduce_3 78# happyReduction_221 +happyReduction_221 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut94 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn93 + (([mj AnnForall happy_var_1,mj AnnDot happy_var_3],happy_var_2) + )}}} + +happyReduce_222 = happySpecReduce_0 78# happyReduction_222 +happyReduction_222 = happyIn93 + (([],[]) + ) + +happyReduce_223 = happySpecReduce_1 79# happyReduction_223 +happyReduction_223 happy_x_1 + = case happyOut95 happy_x_1 of { happy_var_1 -> + happyIn94 + ([happy_var_1] + )} + +happyReduce_224 = happySpecReduce_2 79# happyReduction_224 +happyReduction_224 happy_x_2 + happy_x_1 + = case happyOut95 happy_x_1 of { happy_var_1 -> + case happyOut94 happy_x_2 of { happy_var_2 -> + happyIn94 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_225 = happySpecReduce_1 80# happyReduction_225 +happyReduction_225 happy_x_1 + = case happyOut247 happy_x_1 of { happy_var_1 -> + happyIn95 + (sLL happy_var_1 happy_var_1 (RuleBndr happy_var_1) + )} + +happyReduce_226 = happyMonadReduce 5# 80# happyReduction_226 +happyReduction_226 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut247 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut114 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( ams (sLL happy_var_1 happy_var_5 (RuleBndrSig happy_var_2 + (mkHsWithBndrs happy_var_4))) + [mop happy_var_1,mj AnnDcolon happy_var_3,mcp happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn95 r)) + +happyReduce_227 = happyMonadReduce 3# 81# happyReduction_227 +happyReduction_227 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut96 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut97 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn96 r)) + +happyReduce_228 = happyMonadReduce 2# 81# happyReduction_228 +happyReduction_228 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut96 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)}} + ) (\r -> happyReturn (happyIn96 r)) + +happyReduce_229 = happySpecReduce_1 81# happyReduction_229 +happyReduction_229 happy_x_1 + = case happyOut97 happy_x_1 of { happy_var_1 -> + happyIn96 + (happy_var_1 + )} + +happyReduce_230 = happySpecReduce_0 81# happyReduction_230 +happyReduction_230 = happyIn96 + (nilOL + ) + +happyReduce_231 = happyMonadReduce 2# 82# happyReduction_231 +happyReduction_231 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut216 happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 (Warning (unLoc happy_var_1) (WarningTxt (noLoc "") $ snd $ unLoc happy_var_2))) + (fst $ unLoc happy_var_2))}} + ) (\r -> happyReturn (happyIn97 r)) + +happyReduce_232 = happyMonadReduce 3# 83# happyReduction_232 +happyReduction_232 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut98 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut99 happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn98 r)) + +happyReduce_233 = happyMonadReduce 2# 83# happyReduction_233 +happyReduction_233 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut98 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)}} + ) (\r -> happyReturn (happyIn98 r)) + +happyReduce_234 = happySpecReduce_1 83# happyReduction_234 +happyReduction_234 happy_x_1 + = case happyOut99 happy_x_1 of { happy_var_1 -> + happyIn98 + (happy_var_1 + )} + +happyReduce_235 = happySpecReduce_0 83# happyReduction_235 +happyReduction_235 = happyIn98 + (nilOL + ) + +happyReduce_236 = happyMonadReduce 2# 84# happyReduction_236 +happyReduction_236 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut216 happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { happy_var_2 -> + ( amsu (sLL happy_var_1 happy_var_2 $ (Warning (unLoc happy_var_1) (DeprecatedTxt (noLoc "") $ snd $ unLoc happy_var_2))) + (fst $ unLoc happy_var_2))}} + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_237 = happySpecReduce_1 85# happyReduction_237 +happyReduction_237 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn100 + (sL1 happy_var_1 ([],[L (gl happy_var_1) (getSTRING happy_var_1)]) + )} + +happyReduce_238 = happySpecReduce_3 85# happyReduction_238 +happyReduction_238 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut101 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn100 + (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) + )}}} + +happyReduce_239 = happyMonadReduce 3# 86# happyReduction_239 +happyReduction_239 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut101 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` + (L (gl happy_var_3) (getSTRING happy_var_3)))))}}} + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_240 = happySpecReduce_1 86# happyReduction_240 +happyReduction_240 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn101 + (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getSTRING happy_var_1))) + )} + +happyReduce_241 = happyMonadReduce 4# 87# happyReduction_241 +happyReduction_241 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut217 happy_x_2 of { happy_var_2 -> + case happyOut166 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 (AnnD $ HsAnnotation + (getANN_PRAGs happy_var_1) + (ValueAnnProvenance happy_var_2) happy_var_3)) + [mo happy_var_1,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn102 r)) + +happyReduce_242 = happyMonadReduce 5# 87# happyReduction_242 +happyReduction_242 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut232 happy_x_3 of { happy_var_3 -> + case happyOut166 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( ams (sLL happy_var_1 happy_var_5 (AnnD $ HsAnnotation + (getANN_PRAGs happy_var_1) + (TypeAnnProvenance happy_var_3) happy_var_4)) + [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn102 r)) + +happyReduce_243 = happyMonadReduce 4# 87# happyReduction_243 +happyReduction_243 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut166 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 (AnnD $ HsAnnotation + (getANN_PRAGs happy_var_1) + ModuleAnnProvenance happy_var_3)) + [mo happy_var_1,mj AnnModule happy_var_2,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn102 r)) + +happyReduce_244 = happyMonadReduce 4# 88# happyReduction_244 +happyReduction_244 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut104 happy_x_2 of { happy_var_2 -> + case happyOut105 happy_x_3 of { happy_var_3 -> + case happyOut106 happy_x_4 of { happy_var_4 -> + ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i -> + return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))}}}} + ) (\r -> happyReturn (happyIn103 r)) + +happyReduce_245 = happyMonadReduce 3# 88# happyReduction_245 +happyReduction_245 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut104 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_3 of { happy_var_3 -> + ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3); + return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })}}} + ) (\r -> happyReturn (happyIn103 r)) + +happyReduce_246 = happyMonadReduce 3# 88# happyReduction_246 +happyReduction_246 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut104 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_3 of { happy_var_3 -> + ( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i -> + return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))}}} + ) (\r -> happyReturn (happyIn103 r)) + +happyReduce_247 = happySpecReduce_1 89# happyReduction_247 +happyReduction_247 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn104 + (sLL happy_var_1 happy_var_1 StdCallConv + )} + +happyReduce_248 = happySpecReduce_1 89# happyReduction_248 +happyReduction_248 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn104 + (sLL happy_var_1 happy_var_1 CCallConv + )} + +happyReduce_249 = happySpecReduce_1 89# happyReduction_249 +happyReduction_249 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn104 + (sLL happy_var_1 happy_var_1 CApiConv + )} + +happyReduce_250 = happySpecReduce_1 89# happyReduction_250 +happyReduction_250 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn104 + (sLL happy_var_1 happy_var_1 PrimCallConv + )} + +happyReduce_251 = happySpecReduce_1 89# happyReduction_251 +happyReduction_251 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn104 + (sLL happy_var_1 happy_var_1 JavaScriptCallConv + )} + +happyReduce_252 = happySpecReduce_1 90# happyReduction_252 +happyReduction_252 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sLL happy_var_1 happy_var_1 PlayRisky + )} + +happyReduce_253 = happySpecReduce_1 90# happyReduction_253 +happyReduction_253 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sLL happy_var_1 happy_var_1 PlaySafe + )} + +happyReduce_254 = happySpecReduce_1 90# happyReduction_254 +happyReduction_254 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sLL happy_var_1 happy_var_1 PlayInterruptible + )} + +happyReduce_255 = happyReduce 4# 91# happyReduction_255 +happyReduction_255 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut244 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut110 happy_x_4 of { happy_var_4 -> + happyIn106 + (sLL happy_var_1 happy_var_4 ([mj AnnDcolon happy_var_3] + ,(L (getLoc happy_var_1) + (getSTRING happy_var_1), happy_var_2, happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_256 = happySpecReduce_3 91# happyReduction_256 +happyReduction_256 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut244 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut110 happy_x_3 of { happy_var_3 -> + happyIn106 + (sLL happy_var_1 happy_var_3 ([mj AnnDcolon happy_var_2] + ,(noLoc nilFS, happy_var_1, happy_var_3)) + )}}} + +happyReduce_257 = happySpecReduce_0 92# happyReduction_257 +happyReduction_257 = happyIn107 + (([],Nothing) + ) + +happyReduce_258 = happySpecReduce_2 92# happyReduction_258 +happyReduction_258 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut109 happy_x_2 of { happy_var_2 -> + happyIn107 + (([mj AnnDcolon happy_var_1],Just happy_var_2) + )}} + +happyReduce_259 = happySpecReduce_0 93# happyReduction_259 +happyReduction_259 = happyIn108 + (([],Nothing) + ) + +happyReduce_260 = happySpecReduce_2 93# happyReduction_260 +happyReduction_260 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { happy_var_2 -> + happyIn108 + (([mj AnnDcolon happy_var_1],Just happy_var_2) + )}} + +happyReduce_261 = happySpecReduce_1 94# happyReduction_261 +happyReduction_261 happy_x_1 + = case happyOut114 happy_x_1 of { happy_var_1 -> + happyIn109 + (sL1 happy_var_1 (mkImplicitHsForAllTy happy_var_1) + )} + +happyReduce_262 = happySpecReduce_1 95# happyReduction_262 +happyReduction_262 happy_x_1 + = case happyOut115 happy_x_1 of { happy_var_1 -> + happyIn110 + (sL1 happy_var_1 (mkImplicitHsForAllTy happy_var_1) + )} + +happyReduce_263 = happyMonadReduce 3# 96# happyReduction_263 +happyReduction_263 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut111 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut244 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) + AnnComma (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn111 r)) + +happyReduce_264 = happySpecReduce_1 96# happyReduction_264 +happyReduction_264 happy_x_1 + = case happyOut244 happy_x_1 of { happy_var_1 -> + happyIn111 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_265 = happySpecReduce_1 97# happyReduction_265 +happyReduction_265 happy_x_1 + = case happyOut109 happy_x_1 of { happy_var_1 -> + happyIn112 + (unitOL happy_var_1 + )} + +happyReduce_266 = happyMonadReduce 3# 97# happyReduction_266 +happyReduction_266 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut109 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut112 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return ((unitOL happy_var_1) `appOL` happy_var_3))}}} + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_267 = happySpecReduce_1 98# happyReduction_267 +happyReduction_267 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn113 + (sL1 happy_var_1 ([mj AnnBang happy_var_1] + ,HsSrcBang Nothing Nothing True) + )} + +happyReduce_268 = happySpecReduce_2 98# happyReduction_268 +happyReduction_268 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn113 + (sLL happy_var_1 happy_var_2 ([mo happy_var_1,mc happy_var_2] + ,HsSrcBang (Just $ getUNPACK_PRAGs happy_var_1) (Just True) False) + )}} + +happyReduce_269 = happySpecReduce_2 98# happyReduction_269 +happyReduction_269 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn113 + (sLL happy_var_1 happy_var_2 ([mo happy_var_1,mc happy_var_2] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs happy_var_1) (Just False) False) + )}} + +happyReduce_270 = happySpecReduce_3 98# happyReduction_270 +happyReduction_270 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn113 + (sLL happy_var_1 happy_var_3 ([mo happy_var_1,mc happy_var_2,mj AnnBang happy_var_3] + ,HsSrcBang (Just $ getUNPACK_PRAGs happy_var_1) (Just True) True) + )}}} + +happyReduce_271 = happySpecReduce_3 98# happyReduction_271 +happyReduction_271 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn113 + (sLL happy_var_1 happy_var_3 ([mo happy_var_1,mc happy_var_2,mj AnnBang happy_var_3] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs happy_var_1) (Just False) True) + )}}} + +happyReduce_272 = happyMonadReduce 4# 99# happyReduction_272 +happyReduction_272 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut114 happy_x_4 of { happy_var_4 -> + ( hintExplicitForall (getLoc happy_var_1) >> + ams (sLL happy_var_1 happy_var_4 $ mkExplicitHsForAllTy happy_var_2 + (noLoc []) happy_var_4) + [mj AnnForall happy_var_1,mj AnnDot happy_var_3])}}}} + ) (\r -> happyReturn (happyIn114 r)) + +happyReduce_273 = happyMonadReduce 3# 99# happyReduction_273 +happyReduction_273 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut116 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut114 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnDarrow (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 $ + mkQualifiedHsForAllTy happy_var_1 happy_var_3))}}} + ) (\r -> happyReturn (happyIn114 r)) + +happyReduce_274 = happyMonadReduce 3# 99# happyReduction_274 +happyReduction_274 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut211 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy (unLoc happy_var_1) happy_var_3)) + [mj AnnVal happy_var_1,mj AnnDcolon happy_var_2])}}} + ) (\r -> happyReturn (happyIn114 r)) + +happyReduce_275 = happySpecReduce_1 99# happyReduction_275 +happyReduction_275 happy_x_1 + = case happyOut117 happy_x_1 of { happy_var_1 -> + happyIn114 + (happy_var_1 + )} + +happyReduce_276 = happyMonadReduce 4# 100# happyReduction_276 +happyReduction_276 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut115 happy_x_4 of { happy_var_4 -> + ( hintExplicitForall (getLoc happy_var_1) >> + ams (sLL happy_var_1 happy_var_4 $ mkExplicitHsForAllTy happy_var_2 + (noLoc []) happy_var_4) + [mj AnnForall happy_var_1,mj AnnDot happy_var_3])}}}} + ) (\r -> happyReturn (happyIn115 r)) + +happyReduce_277 = happyMonadReduce 3# 100# happyReduction_277 +happyReduction_277 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut116 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut115 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnDarrow (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 $ + mkQualifiedHsForAllTy happy_var_1 happy_var_3))}}} + ) (\r -> happyReturn (happyIn115 r)) + +happyReduce_278 = happyMonadReduce 3# 100# happyReduction_278 +happyReduction_278 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut211 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy (unLoc happy_var_1) happy_var_3)) + [mj AnnVal happy_var_1,mj AnnDcolon happy_var_2])}}} + ) (\r -> happyReturn (happyIn115 r)) + +happyReduce_279 = happySpecReduce_1 100# happyReduction_279 +happyReduction_279 happy_x_1 + = case happyOut118 happy_x_1 of { happy_var_1 -> + happyIn115 + (happy_var_1 + )} + +happyReduce_280 = happyMonadReduce 3# 101# happyReduction_280 +happyReduction_280 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut119 happy_x_3 of { happy_var_3 -> + ( do { (anns,ctx) <- checkContext + (sLL happy_var_1 happy_var_3 $ HsEqTy happy_var_1 happy_var_3) + ; ams ctx (mj AnnTilde happy_var_2:anns) })}}} + ) (\r -> happyReturn (happyIn116 r)) + +happyReduce_281 = happyMonadReduce 1# 101# happyReduction_281 +happyReduction_281 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + ( do { (anns,ctx) <- checkContext happy_var_1 + ; if null (unLoc ctx) + then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) + else return () + ; ams ctx anns + })} + ) (\r -> happyReturn (happyIn116 r)) + +happyReduce_282 = happySpecReduce_1 102# happyReduction_282 +happyReduction_282 happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_283 = happySpecReduce_3 102# happyReduction_283 +happyReduction_283 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + happyIn117 + (sLL happy_var_1 happy_var_3 $ mkHsOpTy happy_var_1 happy_var_2 happy_var_3 + )}}} + +happyReduce_284 = happySpecReduce_3 102# happyReduction_284 +happyReduction_284 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + happyIn117 + (sLL happy_var_1 happy_var_3 $ mkHsOpTy happy_var_1 happy_var_2 happy_var_3 + )}}} + +happyReduce_285 = happyMonadReduce 3# 102# happyReduction_285 +happyReduction_285 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut114 happy_x_3 of { happy_var_3 -> + ( ams happy_var_1 [mj AnnRarrow happy_var_2] + >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy happy_var_1 happy_var_3) + [mj AnnRarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn117 r)) + +happyReduce_286 = happyMonadReduce 3# 102# happyReduction_286 +happyReduction_286 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut119 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsEqTy happy_var_1 happy_var_3) + [mj AnnTilde happy_var_2])}}} + ) (\r -> happyReturn (happyIn117 r)) + +happyReduce_287 = happyMonadReduce 4# 102# happyReduction_287 +happyReduction_287 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut226 happy_x_3 of { happy_var_3 -> + case happyOut117 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ mkHsOpTy happy_var_1 happy_var_3 happy_var_4) + [mj AnnSimpleQuote happy_var_2])}}}} + ) (\r -> happyReturn (happyIn117 r)) + +happyReduce_288 = happyMonadReduce 4# 102# happyReduction_288 +happyReduction_288 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut236 happy_x_3 of { happy_var_3 -> + case happyOut117 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ mkHsOpTy happy_var_1 happy_var_3 happy_var_4) + [mj AnnSimpleQuote happy_var_2])}}}} + ) (\r -> happyReturn (happyIn117 r)) + +happyReduce_289 = happySpecReduce_1 103# happyReduction_289 +happyReduction_289 happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + happyIn118 + (happy_var_1 + )} + +happyReduce_290 = happySpecReduce_2 103# happyReduction_290 +happyReduction_290 happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut264 happy_x_2 of { happy_var_2 -> + happyIn118 + (sLL happy_var_1 happy_var_2 $ HsDocTy happy_var_1 happy_var_2 + )}} + +happyReduce_291 = happySpecReduce_3 103# happyReduction_291 +happyReduction_291 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + happyIn118 + (sLL happy_var_1 happy_var_3 $ mkHsOpTy happy_var_1 happy_var_2 happy_var_3 + )}}} + +happyReduce_292 = happyReduce 4# 103# happyReduction_292 +happyReduction_292 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut264 happy_x_4 of { happy_var_4 -> + happyIn118 + (sLL happy_var_1 happy_var_4 $ HsDocTy (L (comb3 happy_var_1 happy_var_2 happy_var_3) (mkHsOpTy happy_var_1 happy_var_2 happy_var_3)) happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_293 = happySpecReduce_3 103# happyReduction_293 +happyReduction_293 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + happyIn118 + (sLL happy_var_1 happy_var_3 $ mkHsOpTy happy_var_1 happy_var_2 happy_var_3 + )}}} + +happyReduce_294 = happyReduce 4# 103# happyReduction_294 +happyReduction_294 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { happy_var_2 -> + case happyOut117 happy_x_3 of { happy_var_3 -> + case happyOut264 happy_x_4 of { happy_var_4 -> + happyIn118 + (sLL happy_var_1 happy_var_4 $ HsDocTy (L (comb3 happy_var_1 happy_var_2 happy_var_3) (mkHsOpTy happy_var_1 happy_var_2 happy_var_3)) happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_295 = happyMonadReduce 3# 103# happyReduction_295 +happyReduction_295 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut115 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsFunTy happy_var_1 happy_var_3) + [mj AnnRarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn118 r)) + +happyReduce_296 = happyMonadReduce 4# 103# happyReduction_296 +happyReduction_296 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut264 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut115 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsFunTy (L (comb2 happy_var_1 happy_var_2) + (HsDocTy happy_var_1 happy_var_2)) happy_var_4) + [mj AnnRarrow happy_var_3])}}}} + ) (\r -> happyReturn (happyIn118 r)) + +happyReduce_297 = happyMonadReduce 3# 103# happyReduction_297 +happyReduction_297 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut119 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsEqTy happy_var_1 happy_var_3) + [mj AnnTilde happy_var_2])}}} + ) (\r -> happyReturn (happyIn118 r)) + +happyReduce_298 = happyMonadReduce 4# 103# happyReduction_298 +happyReduction_298 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut226 happy_x_3 of { happy_var_3 -> + case happyOut117 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ mkHsOpTy happy_var_1 happy_var_3 happy_var_4) + [mj AnnSimpleQuote happy_var_2])}}}} + ) (\r -> happyReturn (happyIn118 r)) + +happyReduce_299 = happyMonadReduce 4# 103# happyReduction_299 +happyReduction_299 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut236 happy_x_3 of { happy_var_3 -> + case happyOut117 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ mkHsOpTy happy_var_1 happy_var_3 happy_var_4) + [mj AnnSimpleQuote happy_var_2])}}}} + ) (\r -> happyReturn (happyIn118 r)) + +happyReduce_300 = happySpecReduce_2 104# happyReduction_300 +happyReduction_300 happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { happy_var_2 -> + happyIn119 + (sLL happy_var_1 happy_var_2 $ HsAppTy happy_var_1 happy_var_2 + )}} + +happyReduce_301 = happySpecReduce_1 104# happyReduction_301 +happyReduction_301 happy_x_1 + = case happyOut120 happy_x_1 of { happy_var_1 -> + happyIn119 + (happy_var_1 + )} + +happyReduce_302 = happySpecReduce_1 105# happyReduction_302 +happyReduction_302 happy_x_1 + = case happyOut228 happy_x_1 of { happy_var_1 -> + happyIn120 + (sL1 happy_var_1 (HsTyVar (unLoc happy_var_1)) + )} + +happyReduce_303 = happyMonadReduce 1# 105# happyReduction_303 +happyReduction_303 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut241 happy_x_1 of { happy_var_1 -> + ( do { nwc <- namedWildcardsEnabled -- (See Note [Unit tuples]) + ; let tv@(Unqual name) = unLoc happy_var_1 + ; return $ if (startsWithUnderscore name && nwc) + then (sL1 happy_var_1 (HsNamedWildcardTy tv)) + else (sL1 happy_var_1 (HsTyVar tv)) })} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_304 = happyMonadReduce 2# 105# happyReduction_304 +happyReduction_304 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut113 happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 (HsBangTy (snd $ unLoc happy_var_1) happy_var_2)) + (fst $ unLoc happy_var_1))}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_305 = happyMonadReduce 3# 105# happyReduction_305 +happyReduction_305 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amms (checkRecordSyntax + (sLL happy_var_1 happy_var_3 $ HsRecTy happy_var_2)) + -- Constructor sigs only + [moc happy_var_1,mcc happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_306 = happyMonadReduce 2# 105# happyReduction_306 +happyReduction_306 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy + HsBoxedOrConstraintTuple []) + [mop happy_var_1,mcp happy_var_2])}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_307 = happyMonadReduce 5# 105# happyReduction_307 +happyReduction_307 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut124 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( addAnnotation (gl happy_var_2) AnnComma + (gl happy_var_3) >> + ams (sLL happy_var_1 happy_var_5 $ HsTupleTy + HsBoxedOrConstraintTuple (happy_var_2 : happy_var_4)) + [mop happy_var_1,mcp happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_308 = happyMonadReduce 2# 105# happyReduction_308 +happyReduction_308 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy HsUnboxedTuple []) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_309 = happyMonadReduce 3# 105# happyReduction_309 +happyReduction_309 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut124 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy HsUnboxedTuple happy_var_2) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_310 = happyMonadReduce 3# 105# happyReduction_310 +happyReduction_310 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsListTy happy_var_2) [mos happy_var_1,mcs happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_311 = happyMonadReduce 3# 105# happyReduction_311 +happyReduction_311 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsPArrTy happy_var_2) [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_312 = happyMonadReduce 3# 105# happyReduction_312 +happyReduction_312 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsParTy happy_var_2) [mop happy_var_1,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_313 = happyMonadReduce 5# 105# happyReduction_313 +happyReduction_313 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut131 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( ams (sLL happy_var_1 happy_var_5 $ HsKindSig happy_var_2 happy_var_4) + [mop happy_var_1,mj AnnDcolon happy_var_3,mcp happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_314 = happySpecReduce_1 105# happyReduction_314 +happyReduction_314 happy_x_1 + = case happyOut158 happy_x_1 of { happy_var_1 -> + happyIn120 + (sL1 happy_var_1 (HsQuasiQuoteTy (unLoc happy_var_1)) + )} + +happyReduce_315 = happyMonadReduce 3# 105# happyReduction_315 +happyReduction_315 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceTy happy_var_2) + [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_316 = happyMonadReduce 1# 105# happyReduction_316 +happyReduction_316 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + (ams (sLL happy_var_1 happy_var_1 $ mkHsSpliceTy $ sL1 happy_var_1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE happy_var_1)) + [mj AnnThIdSplice happy_var_1])} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_317 = happyMonadReduce 2# 105# happyReduction_317 +happyReduction_317 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar $ unLoc happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_318 = happyMonadReduce 6# 105# happyReduction_318 +happyReduction_318 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut114 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut124 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( addAnnotation (gl happy_var_3) AnnComma (gl happy_var_4) >> + ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy [] (happy_var_3 : happy_var_5)) + [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6])}}}}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_319 = happyMonadReduce 4# 105# happyReduction_319 +happyReduction_319 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut123 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy + placeHolderKind happy_var_3) + [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4])}}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_320 = happyMonadReduce 2# 105# happyReduction_320 +happyReduction_320 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut244 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar $ unLoc happy_var_2) + [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_321 = happyMonadReduce 5# 105# happyReduction_321 +happyReduction_321 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut124 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( addAnnotation (gl happy_var_2) AnnComma + (gl happy_var_3) >> + ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy + placeHolderKind (happy_var_2 : happy_var_4)) + [mos happy_var_1,mcs happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn120 r)) + +happyReduce_322 = happySpecReduce_1 105# happyReduction_322 +happyReduction_322 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn120 + (sLL happy_var_1 happy_var_1 $ HsTyLit $ HsNumTy (getINTEGERs happy_var_1) + (getINTEGER happy_var_1) + )} + +happyReduce_323 = happySpecReduce_1 105# happyReduction_323 +happyReduction_323 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn120 + (sLL happy_var_1 happy_var_1 $ HsTyLit $ HsStrTy (getSTRINGs happy_var_1) + (getSTRING happy_var_1) + )} + +happyReduce_324 = happySpecReduce_1 105# happyReduction_324 +happyReduction_324 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn120 + (sL1 happy_var_1 $ HsWildcardTy + )} + +happyReduce_325 = happySpecReduce_1 106# happyReduction_325 +happyReduction_325 happy_x_1 + = case happyOut109 happy_x_1 of { happy_var_1 -> + happyIn121 + (happy_var_1 + )} + +happyReduce_326 = happySpecReduce_1 107# happyReduction_326 +happyReduction_326 happy_x_1 + = case happyOut121 happy_x_1 of { happy_var_1 -> + happyIn122 + ([happy_var_1] + )} + +happyReduce_327 = happyMonadReduce 3# 107# happyReduction_327 +happyReduction_327 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut121 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 : happy_var_3))}}} + ) (\r -> happyReturn (happyIn122 r)) + +happyReduce_328 = happySpecReduce_1 108# happyReduction_328 +happyReduction_328 happy_x_1 + = case happyOut124 happy_x_1 of { happy_var_1 -> + happyIn123 + (happy_var_1 + )} + +happyReduce_329 = happySpecReduce_0 108# happyReduction_329 +happyReduction_329 = happyIn123 + ([] + ) + +happyReduce_330 = happySpecReduce_1 109# happyReduction_330 +happyReduction_330 happy_x_1 + = case happyOut114 happy_x_1 of { happy_var_1 -> + happyIn124 + ([happy_var_1] + )} + +happyReduce_331 = happyMonadReduce 3# 109# happyReduction_331 +happyReduction_331 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut114 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut124 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 : happy_var_3))}}} + ) (\r -> happyReturn (happyIn124 r)) + +happyReduce_332 = happySpecReduce_2 110# happyReduction_332 +happyReduction_332 happy_x_2 + happy_x_1 + = case happyOut126 happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + happyIn125 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_333 = happySpecReduce_0 110# happyReduction_333 +happyReduction_333 = happyIn125 + ([] + ) + +happyReduce_334 = happySpecReduce_1 111# happyReduction_334 +happyReduction_334 happy_x_1 + = case happyOut241 happy_x_1 of { happy_var_1 -> + happyIn126 + (sL1 happy_var_1 (UserTyVar (unLoc happy_var_1)) + )} + +happyReduce_335 = happyMonadReduce 5# 111# happyReduction_335 +happyReduction_335 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut131 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( ams (sLL happy_var_1 happy_var_5 (KindedTyVar happy_var_2 happy_var_4)) + [mop happy_var_1,mj AnnDcolon happy_var_3 + ,mcp happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn126 r)) + +happyReduce_336 = happySpecReduce_0 112# happyReduction_336 +happyReduction_336 = happyIn127 + (noLoc ([],[]) + ) + +happyReduce_337 = happySpecReduce_2 112# happyReduction_337 +happyReduction_337 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_2 of { happy_var_2 -> + happyIn127 + ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] + ,reverse (unLoc happy_var_2))) + )}} + +happyReduce_338 = happyMonadReduce 3# 113# happyReduction_338 +happyReduction_338 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut128 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut129 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn128 r)) + +happyReduce_339 = happySpecReduce_1 113# happyReduction_339 +happyReduction_339 happy_x_1 + = case happyOut129 happy_x_1 of { happy_var_1 -> + happyIn128 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_340 = happyMonadReduce 3# 114# happyReduction_340 +happyReduction_340 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut130 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut130 happy_x_3 of { happy_var_3 -> + ( ams (L (comb3 happy_var_1 happy_var_2 happy_var_3) + (reverse (unLoc happy_var_1), reverse (unLoc happy_var_3))) + [mj AnnRarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn129 r)) + +happyReduce_341 = happySpecReduce_0 115# happyReduction_341 +happyReduction_341 = happyIn130 + (noLoc [] + ) + +happyReduce_342 = happySpecReduce_2 115# happyReduction_342 +happyReduction_342 happy_x_2 + happy_x_1 + = case happyOut130 happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { happy_var_2 -> + happyIn130 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_343 = happySpecReduce_1 116# happyReduction_343 +happyReduction_343 happy_x_1 + = case happyOut132 happy_x_1 of { happy_var_1 -> + happyIn131 + (happy_var_1 + )} + +happyReduce_344 = happyMonadReduce 3# 116# happyReduction_344 +happyReduction_344 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut132 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut131 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsFunTy happy_var_1 happy_var_3) + [mj AnnRarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn131 r)) + +happyReduce_345 = happySpecReduce_1 117# happyReduction_345 +happyReduction_345 happy_x_1 + = case happyOut133 happy_x_1 of { happy_var_1 -> + happyIn132 + (happy_var_1 + )} + +happyReduce_346 = happySpecReduce_2 117# happyReduction_346 +happyReduction_346 happy_x_2 + happy_x_1 + = case happyOut132 happy_x_1 of { happy_var_1 -> + case happyOut133 happy_x_2 of { happy_var_2 -> + happyIn132 + (sLL happy_var_1 happy_var_2 $ HsAppTy happy_var_1 happy_var_2 + )}} + +happyReduce_347 = happySpecReduce_1 118# happyReduction_347 +happyReduction_347 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn133 + (sL1 happy_var_1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) + )} + +happyReduce_348 = happyMonadReduce 3# 118# happyReduction_348 +happyReduction_348 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsParTy happy_var_2) + [mop happy_var_1,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn133 r)) + +happyReduce_349 = happySpecReduce_1 118# happyReduction_349 +happyReduction_349 happy_x_1 + = case happyOut134 happy_x_1 of { happy_var_1 -> + happyIn133 + (happy_var_1 + )} + +happyReduce_350 = happySpecReduce_1 118# happyReduction_350 +happyReduction_350 happy_x_1 + = case happyOut241 happy_x_1 of { happy_var_1 -> + happyIn133 + (sL1 happy_var_1 $ HsTyVar (unLoc happy_var_1) + )} + +happyReduce_351 = happySpecReduce_1 119# happyReduction_351 +happyReduction_351 happy_x_1 + = case happyOut231 happy_x_1 of { happy_var_1 -> + happyIn134 + (sL1 happy_var_1 $ HsTyVar $ unLoc happy_var_1 + )} + +happyReduce_352 = happyMonadReduce 2# 119# happyReduction_352 +happyReduction_352 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar $ getRdrName unitTyCon) + [mop happy_var_1,mcp happy_var_2])}} + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_353 = happyMonadReduce 5# 119# happyReduction_353 +happyReduction_353 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut135 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( addAnnotation (gl happy_var_2) AnnComma (gl happy_var_3) >> + ams (sLL happy_var_1 happy_var_5 $ HsTupleTy HsBoxedTuple ( happy_var_2 : happy_var_4)) + [mop happy_var_1,mcp happy_var_5])}}}}} + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_354 = happyMonadReduce 3# 119# happyReduction_354 +happyReduction_354 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsListTy happy_var_2) + [mos happy_var_1,mcs happy_var_3])}}} + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_355 = happySpecReduce_1 120# happyReduction_355 +happyReduction_355 happy_x_1 + = case happyOut131 happy_x_1 of { happy_var_1 -> + happyIn135 + ([happy_var_1] + )} + +happyReduce_356 = happyMonadReduce 3# 120# happyReduction_356 +happyReduction_356 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut131 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut135 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 : happy_var_3))}}} + ) (\r -> happyReturn (happyIn135 r)) + +happyReduce_357 = happyReduce 4# 121# happyReduction_357 +happyReduction_357 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut137 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn136 + (L (comb2 happy_var_1 happy_var_3) + ([mj AnnWhere happy_var_1 + ,moc happy_var_2 + ,mcc happy_var_4] + , unLoc happy_var_3) + ) `HappyStk` happyRest}}}} + +happyReduce_358 = happyReduce 4# 121# happyReduction_358 +happyReduction_358 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut137 happy_x_3 of { happy_var_3 -> + happyIn136 + (L (comb2 happy_var_1 happy_var_3) + ([mj AnnWhere happy_var_1] + , unLoc happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_359 = happySpecReduce_0 121# happyReduction_359 +happyReduction_359 = happyIn136 + (noLoc ([],[]) + ) + +happyReduce_360 = happyMonadReduce 3# 122# happyReduction_360 +happyReduction_360 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut138 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut137 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) + >> return (L (comb2 happy_var_1 happy_var_3) (happy_var_1 : unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn137 r)) + +happyReduce_361 = happySpecReduce_1 122# happyReduction_361 +happyReduction_361 happy_x_1 + = case happyOut138 happy_x_1 of { happy_var_1 -> + happyIn137 + (L (gl happy_var_1) [happy_var_1] + )} + +happyReduce_362 = happySpecReduce_0 122# happyReduction_362 +happyReduction_362 = happyIn137 + (noLoc [] + ) + +happyReduce_363 = happyMonadReduce 3# 123# happyReduction_363 +happyReduction_363 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut222 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut109 happy_x_3 of { happy_var_3 -> + ( do { (anns,gadtDecl) <- mkGadtDecl (unLoc happy_var_1) happy_var_3 + ; ams (sLL happy_var_1 happy_var_3 $ gadtDecl) + (mj AnnDcolon happy_var_2:anns) })}}} + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_364 = happyMonadReduce 6# 123# happyReduction_364 +happyReduction_364 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut229 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut144 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut109 happy_x_6 of { happy_var_6 -> + ( do { cd <- mkDeprecatedGadtRecordDecl (comb2 happy_var_1 happy_var_6) happy_var_1 (noLoc happy_var_3) happy_var_6 + ; cd' <- checkRecordSyntax cd + ; ams (L (comb2 happy_var_1 happy_var_6) (unLoc cd')) + [moc happy_var_2,mcc happy_var_4,mj AnnDcolon happy_var_5] })}}}}}} + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_365 = happySpecReduce_3 124# happyReduction_365 +happyReduction_365 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut269 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut140 happy_x_3 of { happy_var_3 -> + happyIn139 + (L (comb2 happy_var_2 happy_var_3) ([mj AnnEqual happy_var_2] + ,addConDocs (unLoc happy_var_3) happy_var_1) + )}}} + +happyReduce_366 = happyMonadReduce 5# 125# happyReduction_366 +happyReduction_366 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut140 happy_x_1 of { happy_var_1 -> + case happyOut269 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut268 happy_x_4 of { happy_var_4 -> + case happyOut141 happy_x_5 of { happy_var_5 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_3) + >> return (sLL happy_var_1 happy_var_5 (addConDoc happy_var_5 happy_var_2 : addConDocFirst (unLoc happy_var_1) happy_var_4)))}}}}} + ) (\r -> happyReturn (happyIn140 r)) + +happyReduce_367 = happySpecReduce_1 125# happyReduction_367 +happyReduction_367 happy_x_1 + = case happyOut141 happy_x_1 of { happy_var_1 -> + happyIn140 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_368 = happyMonadReduce 6# 126# happyReduction_368 +happyReduction_368 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut269 happy_x_1 of { happy_var_1 -> + case happyOut142 happy_x_2 of { happy_var_2 -> + case happyOut116 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut143 happy_x_5 of { happy_var_5 -> + case happyOut268 happy_x_6 of { happy_var_6 -> + ( ams (let (con,details) = unLoc happy_var_5 in + addConDoc (L (comb4 happy_var_2 happy_var_3 happy_var_4 happy_var_5) (mkSimpleConDecl con + (snd $ unLoc happy_var_2) happy_var_3 details)) + (happy_var_1 `mplus` happy_var_6)) + (mj AnnDarrow happy_var_4:(fst $ unLoc happy_var_2)))}}}}}} + ) (\r -> happyReturn (happyIn141 r)) + +happyReduce_369 = happyMonadReduce 4# 126# happyReduction_369 +happyReduction_369 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut269 happy_x_1 of { happy_var_1 -> + case happyOut142 happy_x_2 of { happy_var_2 -> + case happyOut143 happy_x_3 of { happy_var_3 -> + case happyOut268 happy_x_4 of { happy_var_4 -> + ( ams ( let (con,details) = unLoc happy_var_3 in + addConDoc (L (comb2 happy_var_2 happy_var_3) (mkSimpleConDecl con + (snd $ unLoc happy_var_2) (noLoc []) details)) + (happy_var_1 `mplus` happy_var_4)) + (fst $ unLoc happy_var_2))}}}} + ) (\r -> happyReturn (happyIn141 r)) + +happyReduce_370 = happySpecReduce_3 127# happyReduction_370 +happyReduction_370 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn142 + (sLL happy_var_1 happy_var_3 ([mj AnnForall happy_var_1,mj AnnDot happy_var_3],happy_var_2) + )}}} + +happyReduce_371 = happySpecReduce_0 127# happyReduction_371 +happyReduction_371 = happyIn142 + (noLoc ([],[]) + ) + +happyReduce_372 = happyMonadReduce 1# 128# happyReduction_372 +happyReduction_372 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut119 happy_x_1 of { happy_var_1 -> + ( splitCon happy_var_1 >>= return.sLL happy_var_1 happy_var_1)} + ) (\r -> happyReturn (happyIn143 r)) + +happyReduce_373 = happySpecReduce_3 128# happyReduction_373 +happyReduction_373 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + case happyOut225 happy_x_2 of { happy_var_2 -> + case happyOut119 happy_x_3 of { happy_var_3 -> + happyIn143 + (sLL happy_var_1 happy_var_3 (happy_var_2, InfixCon happy_var_1 happy_var_3) + )}}} + +happyReduce_374 = happySpecReduce_0 129# happyReduction_374 +happyReduction_374 = happyIn144 + ([] + ) + +happyReduce_375 = happySpecReduce_1 129# happyReduction_375 +happyReduction_375 happy_x_1 + = case happyOut145 happy_x_1 of { happy_var_1 -> + happyIn144 + (happy_var_1 + )} + +happyReduce_376 = happyMonadReduce 5# 130# happyReduction_376 +happyReduction_376 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut146 happy_x_1 of { happy_var_1 -> + case happyOut269 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut268 happy_x_4 of { happy_var_4 -> + case happyOut145 happy_x_5 of { happy_var_5 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_3) >> + return ((addFieldDoc happy_var_1 happy_var_4) : addFieldDocs happy_var_5 happy_var_2))}}}}} + ) (\r -> happyReturn (happyIn145 r)) + +happyReduce_377 = happySpecReduce_1 130# happyReduction_377 +happyReduction_377 happy_x_1 + = case happyOut146 happy_x_1 of { happy_var_1 -> + happyIn145 + ([happy_var_1] + )} + +happyReduce_378 = happyMonadReduce 5# 131# happyReduction_378 +happyReduction_378 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut269 happy_x_1 of { happy_var_1 -> + case happyOut111 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut114 happy_x_4 of { happy_var_4 -> + case happyOut268 happy_x_5 of { happy_var_5 -> + ( ams (L (comb2 happy_var_2 happy_var_4) + (ConDeclField (reverse (unLoc happy_var_2)) happy_var_4 (happy_var_1 `mplus` happy_var_5))) + [mj AnnDcolon happy_var_3])}}}}} + ) (\r -> happyReturn (happyIn146 r)) + +happyReduce_379 = happySpecReduce_0 132# happyReduction_379 +happyReduction_379 = happyIn147 + (noLoc Nothing + ) + +happyReduce_380 = happyMonadReduce 2# 132# happyReduction_380 +happyReduction_380 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut231 happy_x_2 of { happy_var_2 -> + ( aljs ( let { L loc tv = happy_var_2 } + in (sLL happy_var_1 happy_var_2 (Just (sLL happy_var_1 happy_var_2 + [L loc (HsTyVar tv)])))) + [mj AnnDeriving happy_var_1])}} + ) (\r -> happyReturn (happyIn147 r)) + +happyReduce_381 = happyMonadReduce 3# 132# happyReduction_381 +happyReduction_381 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( aljs (sLL happy_var_1 happy_var_3 (Just (sLL happy_var_1 happy_var_3 []))) + [mj AnnDeriving happy_var_1,mop happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn147 r)) + +happyReduce_382 = happyMonadReduce 4# 132# happyReduction_382 +happyReduction_382 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( aljs (sLL happy_var_1 happy_var_4 (Just (sLL happy_var_1 happy_var_4 happy_var_3))) + [mj AnnDeriving happy_var_1,mop happy_var_2,mcp happy_var_4])}}}} + ) (\r -> happyReturn (happyIn147 r)) + +happyReduce_383 = happySpecReduce_1 133# happyReduction_383 +happyReduction_383 happy_x_1 + = case happyOut149 happy_x_1 of { happy_var_1 -> + happyIn148 + (sL1 happy_var_1 (DocD (unLoc happy_var_1)) + )} + +happyReduce_384 = happySpecReduce_1 134# happyReduction_384 +happyReduction_384 happy_x_1 + = case happyOut263 happy_x_1 of { happy_var_1 -> + happyIn149 + (sL1 happy_var_1 (DocCommentNext (unLoc happy_var_1)) + )} + +happyReduce_385 = happySpecReduce_1 134# happyReduction_385 +happyReduction_385 happy_x_1 + = case happyOut264 happy_x_1 of { happy_var_1 -> + happyIn149 + (sL1 happy_var_1 (DocCommentPrev (unLoc happy_var_1)) + )} + +happyReduce_386 = happySpecReduce_1 134# happyReduction_386 +happyReduction_386 happy_x_1 + = case happyOut265 happy_x_1 of { happy_var_1 -> + happyIn149 + (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocCommentNamed n doc) + )} + +happyReduce_387 = happySpecReduce_1 134# happyReduction_387 +happyReduction_387 happy_x_1 + = case happyOut266 happy_x_1 of { happy_var_1 -> + happyIn149 + (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocGroup n doc) + )} + +happyReduce_388 = happySpecReduce_1 135# happyReduction_388 +happyReduction_388 happy_x_1 + = case happyOut155 happy_x_1 of { happy_var_1 -> + happyIn150 + (happy_var_1 + )} + +happyReduce_389 = happyMonadReduce 3# 135# happyReduction_389 +happyReduction_389 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + case happyOut152 happy_x_3 of { happy_var_3 -> + ( do { let { e = sLL happy_var_1 happy_var_2 (SectionR (sL1 happy_var_1 (HsVar bang_RDR)) happy_var_2) }; + pat <- checkPattern empty e; + _ <- ams (sLL happy_var_1 happy_var_3 ()) + (fst $ unLoc happy_var_3); + return $ sLL happy_var_1 happy_var_3 $ unitOL $ sLL happy_var_1 happy_var_3 $ ValD $ + PatBind pat (snd $ unLoc happy_var_3) + placeHolderType + placeHolderNames + ([],[]) })}}} + ) (\r -> happyReturn (happyIn150 r)) + +happyReduce_390 = happyMonadReduce 3# 135# happyReduction_390 +happyReduction_390 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOut107 happy_x_2 of { happy_var_2 -> + case happyOut152 happy_x_3 of { happy_var_3 -> + ( do { (ann,r) <- checkValDef empty happy_var_1 (snd happy_var_2) happy_var_3; + let { l = comb2 happy_var_1 happy_var_3 }; + case r of { + (FunBind n _ _ _ _ _) -> + ams (L l ()) (mj AnnFunId n:(fst happy_var_2)) >> return () ; + (PatBind (L lh _lhs) _rhs _ _ _) -> + ams (L lh ()) (fst happy_var_2) >> return () } ; + _ <- ams (L l ()) (ann ++ (fst $ unLoc happy_var_3)); + return $! (sL l (unitOL $! (sL l $ ValD r))) })}}} + ) (\r -> happyReturn (happyIn150 r)) + +happyReduce_391 = happySpecReduce_1 135# happyReduction_391 +happyReduction_391 happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn150 + (sLL happy_var_1 happy_var_1 $ unitOL happy_var_1 + )} + +happyReduce_392 = happySpecReduce_1 135# happyReduction_392 +happyReduction_392 happy_x_1 + = case happyOut148 happy_x_1 of { happy_var_1 -> + happyIn150 + (sLL happy_var_1 happy_var_1 $ unitOL happy_var_1 + )} + +happyReduce_393 = happySpecReduce_1 136# happyReduction_393 +happyReduction_393 happy_x_1 + = case happyOut150 happy_x_1 of { happy_var_1 -> + happyIn151 + (happy_var_1 + )} + +happyReduce_394 = happySpecReduce_1 136# happyReduction_394 +happyReduction_394 happy_x_1 + = case happyOut169 happy_x_1 of { happy_var_1 -> + happyIn151 + (sLL happy_var_1 happy_var_1 $ unitOL (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1) + )} + +happyReduce_395 = happySpecReduce_3 137# happyReduction_395 +happyReduction_395 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOut88 happy_x_3 of { happy_var_3 -> + happyIn152 + (sL (comb3 happy_var_1 happy_var_2 happy_var_3) + ((mj AnnEqual happy_var_1 : (fst $ unLoc happy_var_3)) + ,GRHSs (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) + (snd $ unLoc happy_var_3)) + )}}} + +happyReduce_396 = happySpecReduce_2 137# happyReduction_396 +happyReduction_396 happy_x_2 + happy_x_1 + = case happyOut153 happy_x_1 of { happy_var_1 -> + case happyOut88 happy_x_2 of { happy_var_2 -> + happyIn152 + (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2 + ,GRHSs (reverse (unLoc happy_var_1)) + (snd $ unLoc happy_var_2)) + )}} + +happyReduce_397 = happySpecReduce_2 138# happyReduction_397 +happyReduction_397 happy_x_2 + happy_x_1 + = case happyOut153 happy_x_1 of { happy_var_1 -> + case happyOut154 happy_x_2 of { happy_var_2 -> + happyIn153 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_398 = happySpecReduce_1 138# happyReduction_398 +happyReduction_398 happy_x_1 + = case happyOut154 happy_x_1 of { happy_var_1 -> + happyIn153 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_399 = happyMonadReduce 4# 139# happyReduction_399 +happyReduction_399 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut185 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + ( ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4) + [mj AnnVbar happy_var_1,mj AnnEqual happy_var_3])}}}} + ) (\r -> happyReturn (happyIn154 r)) + +happyReduce_400 = happyMonadReduce 3# 140# happyReduction_400 +happyReduction_400 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut110 happy_x_3 of { happy_var_3 -> + ( do ty <- checkPartialTypeSignature happy_var_3 + ; s <- checkValSig happy_var_1 ty + ; _ <- ams (sLL happy_var_1 happy_var_3 ()) [mj AnnDcolon happy_var_2] + ; return (sLL happy_var_1 happy_var_3 $ unitOL (sLL happy_var_1 happy_var_3 $ SigD s)))}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_401 = happyMonadReduce 5# 140# happyReduction_401 +happyReduction_401 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut244 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut111 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut110 happy_x_5 of { happy_var_5 -> + ( do { ty <- checkPartialTypeSignature happy_var_5 + ; let sig = TypeSig (happy_var_1 : reverse (unLoc happy_var_3)) ty PlaceHolder + ; addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + ; ams (sLL happy_var_1 happy_var_5 $ toOL [ sLL happy_var_1 happy_var_5 $ SigD sig ]) + [mj AnnDcolon happy_var_4] })}}}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_402 = happyMonadReduce 3# 140# happyReduction_402 +happyReduction_402 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut46 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ toOL [ sLL happy_var_1 happy_var_3 $ SigD + (FixSig (FixitySig (fromOL $ unLoc happy_var_3) + (Fixity (unLoc happy_var_2) (unLoc happy_var_1)))) ]) + [mj AnnInfix happy_var_1,mj AnnVal happy_var_2])}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_403 = happySpecReduce_1 140# happyReduction_403 +happyReduction_403 happy_x_1 + = case happyOut75 happy_x_1 of { happy_var_1 -> + happyIn155 + (sLL happy_var_1 happy_var_1 $ unitOL $ sLL happy_var_1 happy_var_1 . SigD . unLoc $ happy_var_1 + )} + +happyReduce_404 = happyMonadReduce 4# 140# happyReduction_404 +happyReduction_404 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut156 happy_x_2 of { happy_var_2 -> + case happyOut245 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ unitOL (sLL happy_var_1 happy_var_4 $ SigD (InlineSig happy_var_3 + (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) + (snd happy_var_2))))) + ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]))}}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_405 = happyMonadReduce 6# 140# happyReduction_405 +happyReduction_405 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut156 happy_x_2 of { happy_var_2 -> + case happyOut245 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut112 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( ams ( + let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) + (EmptyInlineSpec, FunLike) (snd happy_var_2) + in sLL happy_var_1 happy_var_6 $ + toOL [ sLL happy_var_1 happy_var_6 $ SigD (SpecSig happy_var_3 (fromOL happy_var_5) inl_prag) ]) + (mo happy_var_1:mj AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_406 = happyMonadReduce 6# 140# happyReduction_406 +happyReduction_406 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut156 happy_x_2 of { happy_var_2 -> + case happyOut245 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut112 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( ams (sLL happy_var_1 happy_var_6 $ toOL [ sLL happy_var_1 happy_var_6 $ SigD (SpecSig happy_var_3 (fromOL happy_var_5) + (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) + (getSPEC_INLINE happy_var_1) (snd happy_var_2))) ]) + (mo happy_var_1:mj AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_407 = happyMonadReduce 4# 140# happyReduction_407 +happyReduction_407 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut121 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ unitOL (sLL happy_var_1 happy_var_4 + $ SigD (SpecInstSig (getSPEC_PRAGs happy_var_1) happy_var_3))) + [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_408 = happyMonadReduce 3# 140# happyReduction_408 +happyReduction_408 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut212 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ unitOL (sLL happy_var_1 happy_var_3 $ SigD (MinimalSig (getMINIMAL_PRAGs happy_var_1) (snd happy_var_2)))) + (mo happy_var_1:mc happy_var_3:fst happy_var_2))}}} + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_409 = happySpecReduce_0 141# happyReduction_409 +happyReduction_409 = happyIn156 + (([],Nothing) + ) + +happyReduce_410 = happySpecReduce_1 141# happyReduction_410 +happyReduction_410 happy_x_1 + = case happyOut157 happy_x_1 of { happy_var_1 -> + happyIn156 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_411 = happySpecReduce_3 142# happyReduction_411 +happyReduction_411 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn157 + (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3] + ,ActiveAfter (fromInteger (getINTEGER happy_var_2))) + )}}} + +happyReduce_412 = happyReduce 4# 142# happyReduction_412 +happyReduction_412 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn157 + (([mj AnnOpenS happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3 + ,mj AnnCloseS happy_var_4] + ,ActiveBefore (fromInteger (getINTEGER happy_var_3))) + ) `HappyStk` happyRest}}}} + +happyReduce_413 = happySpecReduce_1 143# happyReduction_413 +happyReduction_413 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (let { loc = getLoc happy_var_1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = mkUnqual varName quoter } + in sL1 happy_var_1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) + )} + +happyReduce_414 = happySpecReduce_1 143# happyReduction_414 +happyReduction_414 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (let { loc = getLoc happy_var_1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) + )} + +happyReduce_415 = happyMonadReduce 3# 144# happyReduction_415 +happyReduction_415 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut109 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ ExprWithTySig happy_var_1 happy_var_3 PlaceHolder) + [mj AnnDcolon happy_var_2])}}} + ) (\r -> happyReturn (happyIn159 r)) + +happyReduce_416 = happyMonadReduce 3# 144# happyReduction_416 +happyReduction_416 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_1 happy_var_3 placeHolderType + HsFirstOrderApp True) + [mj Annlarrowtail happy_var_2])}}} + ) (\r -> happyReturn (happyIn159 r)) + +happyReduce_417 = happyMonadReduce 3# 144# happyReduction_417 +happyReduction_417 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_3 happy_var_1 placeHolderType + HsFirstOrderApp False) + [mj Annrarrowtail happy_var_2])}}} + ) (\r -> happyReturn (happyIn159 r)) + +happyReduce_418 = happyMonadReduce 3# 144# happyReduction_418 +happyReduction_418 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_1 happy_var_3 placeHolderType + HsHigherOrderApp True) + [mj AnnLarrowtail happy_var_2])}}} + ) (\r -> happyReturn (happyIn159 r)) + +happyReduce_419 = happyMonadReduce 3# 144# happyReduction_419 +happyReduction_419 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsArrApp happy_var_3 happy_var_1 placeHolderType + HsHigherOrderApp False) + [mj AnnRarrowtail happy_var_2])}}} + ) (\r -> happyReturn (happyIn159 r)) + +happyReduce_420 = happySpecReduce_1 144# happyReduction_420 +happyReduction_420 happy_x_1 + = case happyOut160 happy_x_1 of { happy_var_1 -> + happyIn159 + (happy_var_1 + )} + +happyReduce_421 = happySpecReduce_1 145# happyReduction_421 +happyReduction_421 happy_x_1 + = case happyOut161 happy_x_1 of { happy_var_1 -> + happyIn160 + (happy_var_1 + )} + +happyReduce_422 = happyMonadReduce 3# 145# happyReduction_422 +happyReduction_422 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOut237 happy_x_2 of { happy_var_2 -> + case happyOut161 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 + (OpApp happy_var_1 happy_var_2 placeHolderFixity happy_var_3)) + [mj AnnVal happy_var_2])}}} + ) (\r -> happyReturn (happyIn160 r)) + +happyReduce_423 = happyMonadReduce 6# 146# happyReduction_423 +happyReduction_423 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut199 happy_x_2 of { happy_var_2 -> + case happyOut200 happy_x_3 of { happy_var_3 -> + case happyOut108 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut159 happy_x_6 of { happy_var_6 -> + ( ams (sLL happy_var_1 happy_var_6 $ HsLam (mkMatchGroup FromSource + [sLL happy_var_1 happy_var_6 $ Match Nothing (happy_var_2:happy_var_3) (snd happy_var_4) (unguardedGRHSs happy_var_6)])) + (mj AnnLam happy_var_1:mj AnnRarrow happy_var_5:(fst happy_var_4)))}}}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_424 = happyMonadReduce 4# 146# happyReduction_424 +happyReduction_424 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut87 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsLet (snd $ unLoc happy_var_2) happy_var_4) + (mj AnnLet happy_var_1:mj AnnIn happy_var_3 + :(fst $ unLoc happy_var_2)))}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_425 = happyMonadReduce 3# 146# happyReduction_425 +happyReduction_425 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut187 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsLamCase placeHolderType + (mkMatchGroup FromSource (snd $ unLoc happy_var_3))) + (mj AnnLam happy_var_1:mj AnnCase happy_var_2:(fst $ unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_426 = happyMonadReduce 8# 146# happyReduction_426 +happyReduction_426 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOut162 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut159 happy_x_5 of { happy_var_5 -> + case happyOut162 happy_x_6 of { happy_var_6 -> + case happyOutTok happy_x_7 of { happy_var_7 -> + case happyOut159 happy_x_8 of { happy_var_8 -> + ( checkDoAndIfThenElse happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 >> + ams (sLL happy_var_1 happy_var_8 $ mkHsIf happy_var_2 happy_var_5 happy_var_8) + (mj AnnIf happy_var_1:mj AnnThen happy_var_4 + :mj AnnElse happy_var_7 + :(map (\l -> mj AnnSemi l) (fst happy_var_3)) + ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))}}}}}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_427 = happyMonadReduce 2# 146# happyReduction_427 +happyReduction_427 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut195 happy_x_2 of { happy_var_2 -> + ( hintMultiWayIf (getLoc happy_var_1) >> + ams (sLL happy_var_1 happy_var_2 $ HsMultiIf + placeHolderType + (reverse $ snd $ unLoc happy_var_2)) + (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_428 = happyMonadReduce 4# 146# happyReduction_428 +happyReduction_428 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut187 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsCase happy_var_2 (mkMatchGroup + FromSource (snd $ unLoc happy_var_4))) + (mj AnnCase happy_var_1:mj AnnOf happy_var_3 + :(fst $ unLoc happy_var_4)))}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_429 = happyMonadReduce 2# 146# happyReduction_429 +happyReduction_429 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut165 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ NegApp happy_var_2 noSyntaxExpr) + [mj AnnMinus happy_var_1])}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_430 = happyMonadReduce 2# 146# happyReduction_430 +happyReduction_430 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut201 happy_x_2 of { happy_var_2 -> + ( ams (L (comb2 happy_var_1 happy_var_2) + (mkHsDo DoExpr (snd $ unLoc happy_var_2))) + (mj AnnDo happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_431 = happyMonadReduce 2# 146# happyReduction_431 +happyReduction_431 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut201 happy_x_2 of { happy_var_2 -> + ( ams (L (comb2 happy_var_1 happy_var_2) + (mkHsDo MDoExpr (snd $ unLoc happy_var_2))) + (mj AnnMdo happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_432 = happyMonadReduce 2# 146# happyReduction_432 +happyReduction_432 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut163 happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsSCC (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) + (fst $ fst $ unLoc happy_var_1))}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_433 = happyMonadReduce 2# 146# happyReduction_433 +happyReduction_433 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut164 happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsTickPragma (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) + (fst $ fst $ unLoc happy_var_1))}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_434 = happyMonadReduce 4# 146# happyReduction_434 +happyReduction_434 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + ( checkPattern empty happy_var_2 >>= \ p -> + checkCommand happy_var_4 >>= \ cmd -> + ams (sLL happy_var_1 happy_var_4 $ HsProc p (sLL happy_var_1 happy_var_4 $ HsCmdTop cmd placeHolderType + placeHolderType [])) + -- TODO: is LL right here? + [mj AnnProc happy_var_1,mj AnnRarrow happy_var_3])}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_435 = happyMonadReduce 4# 146# happyReduction_435 +happyReduction_435 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn (getCORE_PRAGs happy_var_1) (getSTRING happy_var_2) happy_var_4) + [mo happy_var_1,mj AnnVal happy_var_2 + ,mc happy_var_3])}}}} + ) (\r -> happyReturn (happyIn161 r)) + +happyReduce_436 = happySpecReduce_1 146# happyReduction_436 +happyReduction_436 happy_x_1 + = case happyOut165 happy_x_1 of { happy_var_1 -> + happyIn161 + (happy_var_1 + )} + +happyReduce_437 = happySpecReduce_1 147# happyReduction_437 +happyReduction_437 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn162 + (([happy_var_1],True) + )} + +happyReduce_438 = happySpecReduce_0 147# happyReduction_438 +happyReduction_438 = happyIn162 + (([],False) + ) + +happyReduce_439 = happyMonadReduce 3# 148# happyReduction_439 +happyReduction_439 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do scc <- getSCC happy_var_2 + ; return $ sLL happy_var_1 happy_var_3 + (([mo happy_var_1,mj AnnValStr happy_var_2 + ,mc happy_var_3],getSCC_PRAGs happy_var_1),scc))}}} + ) (\r -> happyReturn (happyIn163 r)) + +happyReduce_440 = happySpecReduce_3 148# happyReduction_440 +happyReduction_440 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn163 + (sLL happy_var_1 happy_var_3 (([mo happy_var_1,mj AnnVal happy_var_2 + ,mc happy_var_3],getSCC_PRAGs happy_var_1) + ,(getVARID happy_var_2)) + )}}} + +happyReduce_441 = happyReduce 10# 149# happyReduction_441 +happyReduction_441 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { happy_var_6 -> + case happyOutTok happy_x_7 of { happy_var_7 -> + case happyOutTok happy_x_8 of { happy_var_8 -> + case happyOutTok happy_x_9 of { happy_var_9 -> + case happyOutTok happy_x_10 of { happy_var_10 -> + happyIn164 + (sLL happy_var_1 happy_var_10 $ (([mo happy_var_1,mj AnnVal happy_var_2 + ,mj AnnVal happy_var_3,mj AnnColon happy_var_4 + ,mj AnnVal happy_var_5,mj AnnMinus happy_var_6 + ,mj AnnVal happy_var_7,mj AnnColon happy_var_8 + ,mj AnnVal happy_var_9,mc happy_var_10], + getGENERATED_PRAGs happy_var_1) + ,(getSTRING happy_var_2 + ,( fromInteger $ getINTEGER happy_var_3 + , fromInteger $ getINTEGER happy_var_5 + ) + ,( fromInteger $ getINTEGER happy_var_7 + , fromInteger $ getINTEGER happy_var_9 + ) + )) + ) `HappyStk` happyRest}}}}}}}}}} + +happyReduce_442 = happySpecReduce_2 150# happyReduction_442 +happyReduction_442 happy_x_2 + happy_x_1 + = case happyOut165 happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + happyIn165 + (sLL happy_var_1 happy_var_2 $ HsApp happy_var_1 happy_var_2 + )}} + +happyReduce_443 = happyMonadReduce 2# 150# happyReduction_443 +happyReduction_443 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsStatic happy_var_2) + [mj AnnStatic happy_var_1])}} + ) (\r -> happyReturn (happyIn165 r)) + +happyReduce_444 = happySpecReduce_1 150# happyReduction_444 +happyReduction_444 happy_x_1 + = case happyOut166 happy_x_1 of { happy_var_1 -> + happyIn165 + (happy_var_1 + )} + +happyReduce_445 = happyMonadReduce 3# 151# happyReduction_445 +happyReduction_445 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut245 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut166 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ EAsPat happy_var_1 happy_var_3) [mj AnnAt happy_var_2])}}} + ) (\r -> happyReturn (happyIn166 r)) + +happyReduce_446 = happyMonadReduce 2# 151# happyReduction_446 +happyReduction_446 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ ELazyPat happy_var_2) [mj AnnTilde happy_var_1])}} + ) (\r -> happyReturn (happyIn166 r)) + +happyReduce_447 = happySpecReduce_1 151# happyReduction_447 +happyReduction_447 happy_x_1 + = case happyOut167 happy_x_1 of { happy_var_1 -> + happyIn166 + (happy_var_1 + )} + +happyReduce_448 = happyMonadReduce 4# 152# happyReduction_448 +happyReduction_448 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut167 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut206 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { r <- mkRecConstrOrUpdate happy_var_1 (comb2 happy_var_2 happy_var_4) + (snd happy_var_3) + ; _ <- ams (sLL happy_var_1 happy_var_4 ()) (moc happy_var_2:mcc happy_var_4:(fst happy_var_3)) + ; checkRecordSyntax (sLL happy_var_1 happy_var_4 r) })}}}} + ) (\r -> happyReturn (happyIn167 r)) + +happyReduce_449 = happySpecReduce_1 152# happyReduction_449 +happyReduction_449 happy_x_1 + = case happyOut168 happy_x_1 of { happy_var_1 -> + happyIn167 + (happy_var_1 + )} + +happyReduce_450 = happySpecReduce_1 153# happyReduction_450 +happyReduction_450 happy_x_1 + = case happyOut211 happy_x_1 of { happy_var_1 -> + happyIn168 + (sL1 happy_var_1 (HsIPVar $! unLoc happy_var_1) + )} + +happyReduce_451 = happySpecReduce_1 153# happyReduction_451 +happyReduction_451 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn168 + (sL1 happy_var_1 (HsVar $! unLoc happy_var_1) + )} + +happyReduce_452 = happySpecReduce_1 153# happyReduction_452 +happyReduction_452 happy_x_1 + = case happyOut259 happy_x_1 of { happy_var_1 -> + happyIn168 + (sL1 happy_var_1 (HsLit $! unLoc happy_var_1) + )} + +happyReduce_453 = happySpecReduce_1 153# happyReduction_453 +happyReduction_453 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn168 + (sL (getLoc happy_var_1) (HsOverLit $! mkHsIntegral (getINTEGERs happy_var_1) + (getINTEGER happy_var_1) placeHolderType) + )} + +happyReduce_454 = happySpecReduce_1 153# happyReduction_454 +happyReduction_454 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn168 + (sL (getLoc happy_var_1) (HsOverLit $! mkHsFractional + (getRATIONAL happy_var_1) placeHolderType) + )} + +happyReduce_455 = happyMonadReduce 3# 153# happyReduction_455 +happyReduction_455 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut174 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (HsPar happy_var_2)) [mop happy_var_1,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_456 = happyMonadReduce 3# 153# happyReduction_456 +happyReduction_456 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut175 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (ExplicitTuple happy_var_2 Boxed)) + [mop happy_var_1,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_457 = happyMonadReduce 3# 153# happyReduction_457 +happyReduction_457 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut174 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (ExplicitTuple [L (gl happy_var_2) + (Present happy_var_2)] Unboxed)) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_458 = happyMonadReduce 3# 153# happyReduction_458 +happyReduction_458 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut175 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (ExplicitTuple happy_var_2 Unboxed)) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_459 = happyMonadReduce 3# 153# happyReduction_459 +happyReduction_459 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut178 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (snd happy_var_2)) (mos happy_var_1:mcs happy_var_3:(fst happy_var_2)))}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_460 = happyMonadReduce 3# 153# happyReduction_460 +happyReduction_460 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut184 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (snd happy_var_2)) (mo happy_var_1:mc happy_var_3:(fst happy_var_2)))}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_461 = happySpecReduce_1 153# happyReduction_461 +happyReduction_461 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn168 + (sL1 happy_var_1 EWildPat + )} + +happyReduce_462 = happySpecReduce_1 153# happyReduction_462 +happyReduction_462 happy_x_1 + = case happyOut169 happy_x_1 of { happy_var_1 -> + happyIn168 + (happy_var_1 + )} + +happyReduce_463 = happyMonadReduce 2# 153# happyReduction_463 +happyReduction_463 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut245 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_464 = happyMonadReduce 2# 153# happyReduction_464 +happyReduction_464 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut219 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_465 = happyMonadReduce 2# 153# happyReduction_465 +happyReduction_465 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_466 = happyMonadReduce 2# 153# happyReduction_466 +happyReduction_466 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut227 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ HsBracket (VarBr False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_467 = happyMonadReduce 3# 153# happyReduction_467 +happyReduction_467 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (ExpBr happy_var_2)) [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_468 = happyMonadReduce 3# 153# happyReduction_468 +happyReduction_468 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (TExpBr happy_var_2)) [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_469 = happyMonadReduce 3# 153# happyReduction_469 +happyReduction_469 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( checkNoPartialType + (text "in type brackets" <> colon + <+> quotes (text "[t|" <+> ppr happy_var_2 <+> text "|]")) happy_var_2 >> + ams (sLL happy_var_1 happy_var_3 $ HsBracket (TypBr happy_var_2)) [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_470 = happyMonadReduce 3# 153# happyReduction_470 +happyReduction_470 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut160 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( checkPattern empty happy_var_2 >>= \p -> + ams (sLL happy_var_1 happy_var_3 $ HsBracket (PatBr p)) + [mo happy_var_1,mc happy_var_3])}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_471 = happyMonadReduce 3# 153# happyReduction_471 +happyReduction_471 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut172 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsBracket (DecBrL (snd happy_var_2))) + (mo happy_var_1:mc happy_var_3:fst happy_var_2))}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_472 = happySpecReduce_1 153# happyReduction_472 +happyReduction_472 happy_x_1 + = case happyOut158 happy_x_1 of { happy_var_1 -> + happyIn168 + (sL1 happy_var_1 (HsQuasiQuoteE (unLoc happy_var_1)) + )} + +happyReduce_473 = happyMonadReduce 4# 153# happyReduction_473 +happyReduction_473 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { happy_var_2 -> + case happyOut170 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( ams (sLL happy_var_1 happy_var_4 $ HsArrForm happy_var_2 + Nothing (reverse happy_var_3)) + [mo happy_var_1,mc happy_var_4])}}}} + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_474 = happyMonadReduce 1# 154# happyReduction_474 +happyReduction_474 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( ams (sL1 happy_var_1 $ mkHsSpliceE + (sL1 happy_var_1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE happy_var_1)))) + [mj AnnThIdSplice happy_var_1])} + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_475 = happyMonadReduce 3# 154# happyReduction_475 +happyReduction_475 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceE happy_var_2) + [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])}}} + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_476 = happyMonadReduce 1# 154# happyReduction_476 +happyReduction_476 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( ams (sL1 happy_var_1 $ mkHsSpliceTE + (sL1 happy_var_1 $ HsVar (mkUnqual varName + (getTH_ID_TY_SPLICE happy_var_1)))) + [mj AnnThIdTySplice happy_var_1])} + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_477 = happyMonadReduce 3# 154# happyReduction_477 +happyReduction_477 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ mkHsSpliceTE happy_var_2) + [mj AnnOpenPTE happy_var_1,mj AnnCloseP happy_var_3])}}} + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_478 = happySpecReduce_2 155# happyReduction_478 +happyReduction_478 happy_x_2 + happy_x_1 + = case happyOut170 happy_x_1 of { happy_var_1 -> + case happyOut171 happy_x_2 of { happy_var_2 -> + happyIn170 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_479 = happySpecReduce_0 155# happyReduction_479 +happyReduction_479 = happyIn170 + ([] + ) + +happyReduce_480 = happyMonadReduce 1# 156# happyReduction_480 +happyReduction_480 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut168 happy_x_1 of { happy_var_1 -> + ( checkCommand happy_var_1 >>= \ cmd -> + return (sL1 happy_var_1 $ HsCmdTop cmd + placeHolderType placeHolderType []))} + ) (\r -> happyReturn (happyIn171 r)) + +happyReduce_481 = happySpecReduce_3 157# happyReduction_481 +happyReduction_481 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut173 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn172 + (([mj AnnOpenC happy_var_1 + ,mj AnnCloseC happy_var_3],happy_var_2) + )}}} + +happyReduce_482 = happySpecReduce_3 157# happyReduction_482 +happyReduction_482 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut173 happy_x_2 of { happy_var_2 -> + happyIn172 + (([],happy_var_2) + )} + +happyReduce_483 = happySpecReduce_0 158# happyReduction_483 +happyReduction_483 = happyIn173 + ([] + ) + +happyReduce_484 = happySpecReduce_1 158# happyReduction_484 +happyReduction_484 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn173 + (happy_var_1 + )} + +happyReduce_485 = happySpecReduce_1 159# happyReduction_485 +happyReduction_485 happy_x_1 + = case happyOut159 happy_x_1 of { happy_var_1 -> + happyIn174 + (happy_var_1 + )} + +happyReduce_486 = happySpecReduce_2 159# happyReduction_486 +happyReduction_486 happy_x_2 + happy_x_1 + = case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOut237 happy_x_2 of { happy_var_2 -> + happyIn174 + (sLL happy_var_1 happy_var_2 $ SectionL happy_var_1 happy_var_2 + )}} + +happyReduce_487 = happySpecReduce_2 159# happyReduction_487 +happyReduction_487 happy_x_2 + happy_x_1 + = case happyOut238 happy_x_1 of { happy_var_1 -> + case happyOut160 happy_x_2 of { happy_var_2 -> + happyIn174 + (sLL happy_var_1 happy_var_2 $ SectionR happy_var_1 happy_var_2 + )}} + +happyReduce_488 = happyMonadReduce 3# 159# happyReduction_488 +happyReduction_488 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut159 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut174 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ EViewPat happy_var_1 happy_var_3) [mj AnnRarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn174 r)) + +happyReduce_489 = happyMonadReduce 2# 160# happyReduction_489 +happyReduction_489 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOut176 happy_x_2 of { happy_var_2 -> + ( do { addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) + ; return ((sL1 happy_var_1 (Present happy_var_1)) : snd happy_var_2) })}} + ) (\r -> happyReturn (happyIn175 r)) + +happyReduce_490 = happyMonadReduce 2# 160# happyReduction_490 +happyReduction_490 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut262 happy_x_1 of { happy_var_1 -> + case happyOut177 happy_x_2 of { happy_var_2 -> + ( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst happy_var_1) + ; return + (map (\l -> L l missingTupArg) (fst happy_var_1) ++ happy_var_2) })}} + ) (\r -> happyReturn (happyIn175 r)) + +happyReduce_491 = happyMonadReduce 2# 161# happyReduction_491 +happyReduction_491 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut262 happy_x_1 of { happy_var_1 -> + case happyOut177 happy_x_2 of { happy_var_2 -> + ( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst happy_var_1) + ; return ( + (head $ fst happy_var_1 + ,(map (\l -> L l missingTupArg) (tail $ fst happy_var_1)) ++ happy_var_2)) })}} + ) (\r -> happyReturn (happyIn176 r)) + +happyReduce_492 = happyMonadReduce 2# 162# happyReduction_492 +happyReduction_492 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOut176 happy_x_2 of { happy_var_2 -> + ( addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) >> + return ((L (gl happy_var_1) (Present happy_var_1)) : snd happy_var_2))}} + ) (\r -> happyReturn (happyIn177 r)) + +happyReduce_493 = happySpecReduce_1 162# happyReduction_493 +happyReduction_493 happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + happyIn177 + ([L (gl happy_var_1) (Present happy_var_1)] + )} + +happyReduce_494 = happySpecReduce_0 162# happyReduction_494 +happyReduction_494 = happyIn177 + ([noLoc missingTupArg] + ) + +happyReduce_495 = happySpecReduce_1 163# happyReduction_495 +happyReduction_495 happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + happyIn178 + (([],ExplicitList placeHolderType Nothing [happy_var_1]) + )} + +happyReduce_496 = happySpecReduce_1 163# happyReduction_496 +happyReduction_496 happy_x_1 + = case happyOut179 happy_x_1 of { happy_var_1 -> + happyIn178 + (([],ExplicitList placeHolderType Nothing + (reverse (unLoc happy_var_1))) + )} + +happyReduce_497 = happySpecReduce_2 163# happyReduction_497 +happyReduction_497 happy_x_2 + happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn178 + (([mj AnnDotdot happy_var_2], + ArithSeq noPostTcExpr Nothing (From happy_var_1)) + )}} + +happyReduce_498 = happyReduce 4# 163# happyReduction_498 +happyReduction_498 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn178 + (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], + ArithSeq noPostTcExpr Nothing + (FromThen happy_var_1 happy_var_3)) + ) `HappyStk` happyRest}}}} + +happyReduce_499 = happySpecReduce_3 163# happyReduction_499 +happyReduction_499 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + happyIn178 + (([mj AnnDotdot happy_var_2], + ArithSeq noPostTcExpr Nothing + (FromTo happy_var_1 happy_var_3)) + )}}} + +happyReduce_500 = happyReduce 5# 163# happyReduction_500 +happyReduction_500 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut159 happy_x_5 of { happy_var_5 -> + happyIn178 + (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], + ArithSeq noPostTcExpr Nothing + (FromThenTo happy_var_1 happy_var_3 happy_var_5)) + ) `HappyStk` happyRest}}}}} + +happyReduce_501 = happyMonadReduce 3# 163# happyReduction_501 +happyReduction_501 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { happy_var_3 -> + ( checkMonadComp >>= \ ctxt -> + return ([mj AnnVbar happy_var_2], + mkHsComp ctxt (unLoc happy_var_3) happy_var_1))}}} + ) (\r -> happyReturn (happyIn178 r)) + +happyReduce_502 = happyMonadReduce 3# 164# happyReduction_502 +happyReduction_502 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut179 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut174 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) + AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (((:) $! happy_var_3) $! unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_503 = happyMonadReduce 3# 164# happyReduction_503 +happyReduction_503 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut174 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 [happy_var_3,happy_var_1]))}}} + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_504 = happySpecReduce_1 165# happyReduction_504 +happyReduction_504 happy_x_1 + = case happyOut181 happy_x_1 of { happy_var_1 -> + happyIn180 + (case (unLoc happy_var_1) of + [qs] -> sL1 happy_var_1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qs <- qss] + noSyntaxExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + )} + +happyReduce_505 = happyMonadReduce 3# 166# happyReduction_505 +happyReduction_505 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut182 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut181 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (reverse (unLoc happy_var_1) : unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn181 r)) + +happyReduce_506 = happySpecReduce_1 166# happyReduction_506 +happyReduction_506 happy_x_1 + = case happyOut182 happy_x_1 of { happy_var_1 -> + happyIn181 + (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] + )} + +happyReduce_507 = happyMonadReduce 3# 167# happyReduction_507 +happyReduction_507 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut182 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut183 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + ams (sLL happy_var_1 happy_var_3 ()) (fst $ unLoc happy_var_3) >> + return (sLL happy_var_1 happy_var_3 [sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) (reverse (unLoc happy_var_1)))]))}}} + ) (\r -> happyReturn (happyIn182 r)) + +happyReduce_508 = happyMonadReduce 3# 167# happyReduction_508 +happyReduction_508 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut182 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn182 r)) + +happyReduce_509 = happyMonadReduce 1# 167# happyReduction_509 +happyReduction_509 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut183 happy_x_1 of { happy_var_1 -> + ( ams happy_var_1 (fst $ unLoc happy_var_1) >> + return (sLL happy_var_1 happy_var_1 [L (getLoc happy_var_1) ((snd $ unLoc happy_var_1) [])]))} + ) (\r -> happyReturn (happyIn182 r)) + +happyReduce_510 = happySpecReduce_1 167# happyReduction_510 +happyReduction_510 happy_x_1 + = case happyOut205 happy_x_1 of { happy_var_1 -> + happyIn182 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_511 = happySpecReduce_2 168# happyReduction_511 +happyReduction_511 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + happyIn183 + (sLL happy_var_1 happy_var_2 ([mj AnnThen happy_var_1], \ss -> (mkTransformStmt ss happy_var_2)) + )}} + +happyReduce_512 = happyReduce 4# 168# happyReduction_512 +happyReduction_512 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + happyIn183 + (sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnBy happy_var_3],\ss -> (mkTransformByStmt ss happy_var_2 happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_513 = happyReduce 4# 168# happyReduction_513 +happyReduction_513 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + happyIn183 + (sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3], \ss -> (mkGroupUsingStmt ss happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_514 = happyReduce 6# 168# happyReduction_514 +happyReduction_514 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut159 happy_x_6 of { happy_var_6 -> + happyIn183 + (sLL happy_var_1 happy_var_6 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5], \ss -> (mkGroupByUsingStmt ss happy_var_4 happy_var_6)) + ) `HappyStk` happyRest}}}}}} + +happyReduce_515 = happySpecReduce_0 169# happyReduction_515 +happyReduction_515 = happyIn184 + (([],ExplicitPArr placeHolderType []) + ) + +happyReduce_516 = happySpecReduce_1 169# happyReduction_516 +happyReduction_516 happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + happyIn184 + (([],ExplicitPArr placeHolderType [happy_var_1]) + )} + +happyReduce_517 = happySpecReduce_1 169# happyReduction_517 +happyReduction_517 happy_x_1 + = case happyOut179 happy_x_1 of { happy_var_1 -> + happyIn184 + (([],ExplicitPArr placeHolderType + (reverse (unLoc happy_var_1))) + )} + +happyReduce_518 = happySpecReduce_3 169# happyReduction_518 +happyReduction_518 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + happyIn184 + (([mj AnnDotdot happy_var_2] + ,PArrSeq noPostTcExpr (FromTo happy_var_1 happy_var_3)) + )}}} + +happyReduce_519 = happyReduce 5# 169# happyReduction_519 +happyReduction_519 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut159 happy_x_5 of { happy_var_5 -> + happyIn184 + (([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] + ,PArrSeq noPostTcExpr (FromThenTo happy_var_1 happy_var_3 happy_var_5)) + ) `HappyStk` happyRest}}}}} + +happyReduce_520 = happySpecReduce_3 169# happyReduction_520 +happyReduction_520 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { happy_var_3 -> + happyIn184 + (([mj AnnVbar happy_var_2],mkHsComp PArrComp (unLoc happy_var_3) happy_var_1) + )}}} + +happyReduce_521 = happySpecReduce_1 170# happyReduction_521 +happyReduction_521 happy_x_1 + = case happyOut186 happy_x_1 of { happy_var_1 -> + happyIn185 + (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) + )} + +happyReduce_522 = happyMonadReduce 3# 171# happyReduction_522 +happyReduction_522 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut186 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma + (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}} + ) (\r -> happyReturn (happyIn186 r)) + +happyReduce_523 = happySpecReduce_1 171# happyReduction_523 +happyReduction_523 happy_x_1 + = case happyOut205 happy_x_1 of { happy_var_1 -> + happyIn186 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_524 = happySpecReduce_3 172# happyReduction_524 +happyReduction_524 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn187 + (sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) + ,(reverse (snd $ unLoc happy_var_2))) + )}}} + +happyReduce_525 = happySpecReduce_3 172# happyReduction_525 +happyReduction_525 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut188 happy_x_2 of { happy_var_2 -> + happyIn187 + (L (getLoc happy_var_2) (fst $ unLoc happy_var_2 + ,(reverse (snd $ unLoc happy_var_2))) + )} + +happyReduce_526 = happySpecReduce_2 172# happyReduction_526 +happyReduction_526 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn187 + (noLoc ([moc happy_var_1,mcc happy_var_2],[]) + )}} + +happyReduce_527 = happySpecReduce_2 172# happyReduction_527 +happyReduction_527 happy_x_2 + happy_x_1 + = happyIn187 + (noLoc ([],[]) + ) + +happyReduce_528 = happySpecReduce_1 173# happyReduction_528 +happyReduction_528 happy_x_1 + = case happyOut189 happy_x_1 of { happy_var_1 -> + happyIn188 + (sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + )} + +happyReduce_529 = happySpecReduce_2 173# happyReduction_529 +happyReduction_529 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + happyIn188 + (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_1:(fst $ unLoc happy_var_2)) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_530 = happyMonadReduce 3# 174# happyReduction_530 +happyReduction_530 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut189 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut190 happy_x_3 of { happy_var_3 -> + ( if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,[happy_var_3])) + else (ams (head $ snd $ unLoc happy_var_1) + (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) + >> return (sLL happy_var_1 happy_var_3 ([],happy_var_3 : (snd $ unLoc happy_var_1))) ))}}} + ) (\r -> happyReturn (happyIn189 r)) + +happyReduce_531 = happyMonadReduce 2# 174# happyReduction_531 +happyReduction_531 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut189 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else (ams (head $ snd $ unLoc happy_var_1) + (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) + >> return (sLL happy_var_1 happy_var_2 ([],snd $ unLoc happy_var_1))))}} + ) (\r -> happyReturn (happyIn189 r)) + +happyReduce_532 = happySpecReduce_1 174# happyReduction_532 +happyReduction_532 happy_x_1 + = case happyOut190 happy_x_1 of { happy_var_1 -> + happyIn189 + (sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_533 = happyMonadReduce 3# 175# happyReduction_533 +happyReduction_533 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut197 happy_x_1 of { happy_var_1 -> + case happyOut107 happy_x_2 of { happy_var_2 -> + case happyOut191 happy_x_3 of { happy_var_3 -> + (ams (sLL happy_var_1 happy_var_3 (Match Nothing [happy_var_1] (snd happy_var_2) + (snd $ unLoc happy_var_3))) + ((fst happy_var_2) ++ (fst $ unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn190 r)) + +happyReduce_534 = happySpecReduce_2 176# happyReduction_534 +happyReduction_534 happy_x_2 + happy_x_1 + = case happyOut192 happy_x_1 of { happy_var_1 -> + case happyOut88 happy_x_2 of { happy_var_2 -> + happyIn191 + (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2, + GRHSs (unLoc happy_var_1) (snd $ unLoc happy_var_2)) + )}} + +happyReduce_535 = happyMonadReduce 2# 177# happyReduction_535 +happyReduction_535 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut159 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 (unguardedRHS (comb2 happy_var_1 happy_var_2) happy_var_2)) + [mj AnnRarrow happy_var_1])}} + ) (\r -> happyReturn (happyIn192 r)) + +happyReduce_536 = happySpecReduce_1 177# happyReduction_536 +happyReduction_536 happy_x_1 + = case happyOut193 happy_x_1 of { happy_var_1 -> + happyIn192 + (sL1 happy_var_1 (reverse (unLoc happy_var_1)) + )} + +happyReduce_537 = happySpecReduce_2 178# happyReduction_537 +happyReduction_537 happy_x_2 + happy_x_1 + = case happyOut193 happy_x_1 of { happy_var_1 -> + case happyOut196 happy_x_2 of { happy_var_2 -> + happyIn193 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_538 = happySpecReduce_1 178# happyReduction_538 +happyReduction_538 happy_x_1 + = case happyOut196 happy_x_1 of { happy_var_1 -> + happyIn193 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_539 = happyMonadReduce 3# 179# happyReduction_539 +happyReduction_539 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut194 happy_x_1 of { happy_var_1 -> + case happyOut196 happy_x_2 of { happy_var_2 -> + case happyOut162 happy_x_3 of { happy_var_3 -> + ( ams (sL (comb2 happy_var_1 happy_var_2) (happy_var_2 : unLoc happy_var_1)) + (map (\l -> mj AnnSemi l) $ fst happy_var_3))}}} + ) (\r -> happyReturn (happyIn194 r)) + +happyReduce_540 = happyMonadReduce 2# 179# happyReduction_540 +happyReduction_540 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut196 happy_x_1 of { happy_var_1 -> + case happyOut162 happy_x_2 of { happy_var_2 -> + ( ams (sL1 happy_var_1 [happy_var_1]) + (map (\l -> mj AnnSemi l) $ fst happy_var_2))}} + ) (\r -> happyReturn (happyIn194 r)) + +happyReduce_541 = happySpecReduce_3 180# happyReduction_541 +happyReduction_541 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn195 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2) + )}}} + +happyReduce_542 = happySpecReduce_2 180# happyReduction_542 +happyReduction_542 happy_x_2 + happy_x_1 + = case happyOut194 happy_x_1 of { happy_var_1 -> + happyIn195 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_543 = happyMonadReduce 4# 181# happyReduction_543 +happyReduction_543 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut185 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut159 happy_x_4 of { happy_var_4 -> + ( ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4) + [mj AnnVbar happy_var_1,mj AnnRarrow happy_var_3])}}}} + ) (\r -> happyReturn (happyIn196 r)) + +happyReduce_544 = happyMonadReduce 1# 182# happyReduction_544 +happyReduction_544 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut159 happy_x_1 of { happy_var_1 -> + ( checkPattern empty happy_var_1)} + ) (\r -> happyReturn (happyIn197 r)) + +happyReduce_545 = happyMonadReduce 2# 182# happyReduction_545 +happyReduction_545 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + ( amms (checkPattern empty (sLL happy_var_1 happy_var_2 (SectionR + (sL1 happy_var_1 (HsVar bang_RDR)) happy_var_2))) + [mj AnnBang happy_var_1])}} + ) (\r -> happyReturn (happyIn197 r)) + +happyReduce_546 = happyMonadReduce 1# 183# happyReduction_546 +happyReduction_546 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut159 happy_x_1 of { happy_var_1 -> + ( checkPattern + (text "Possibly caused by a missing 'do'?") happy_var_1)} + ) (\r -> happyReturn (happyIn198 r)) + +happyReduce_547 = happyMonadReduce 2# 183# happyReduction_547 +happyReduction_547 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + ( amms (checkPattern + (text "Possibly caused by a missing 'do'?") + (sLL happy_var_1 happy_var_2 (SectionR (sL1 happy_var_1 (HsVar bang_RDR)) happy_var_2))) + [mj AnnBang happy_var_1])}} + ) (\r -> happyReturn (happyIn198 r)) + +happyReduce_548 = happyMonadReduce 1# 184# happyReduction_548 +happyReduction_548 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut166 happy_x_1 of { happy_var_1 -> + ( checkPattern empty happy_var_1)} + ) (\r -> happyReturn (happyIn199 r)) + +happyReduce_549 = happyMonadReduce 2# 184# happyReduction_549 +happyReduction_549 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + ( amms (checkPattern empty + (sLL happy_var_1 happy_var_2 (SectionR + (sL1 happy_var_1 (HsVar bang_RDR)) happy_var_2))) + [mj AnnBang happy_var_1])}} + ) (\r -> happyReturn (happyIn199 r)) + +happyReduce_550 = happySpecReduce_2 185# happyReduction_550 +happyReduction_550 happy_x_2 + happy_x_1 + = case happyOut199 happy_x_1 of { happy_var_1 -> + case happyOut200 happy_x_2 of { happy_var_2 -> + happyIn200 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_551 = happySpecReduce_0 185# happyReduction_551 +happyReduction_551 = happyIn200 + ([] + ) + +happyReduce_552 = happySpecReduce_3 186# happyReduction_552 +happyReduction_552 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut202 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn201 + (sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) + ,(reverse $ snd $ unLoc happy_var_2)) + )}}} + +happyReduce_553 = happySpecReduce_3 186# happyReduction_553 +happyReduction_553 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut202 happy_x_2 of { happy_var_2 -> + happyIn201 + (L (gl happy_var_2) (fst $ unLoc happy_var_2 + ,reverse $ snd $ unLoc happy_var_2) + )} + +happyReduce_554 = happyMonadReduce 3# 187# happyReduction_554 +happyReduction_554 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut202 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut204 happy_x_3 of { happy_var_3 -> + ( if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,happy_var_3 : (snd $ unLoc happy_var_1))) + else do + { ams (head $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(snd $ unLoc happy_var_1)) })}}} + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_555 = happyMonadReduce 2# 187# happyReduction_555 +happyReduction_555 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut202 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1),snd $ unLoc happy_var_1)) + else do + { ams (head $ snd $ unLoc happy_var_1) + [mj AnnSemi happy_var_2] + ; return happy_var_1 })}} + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_556 = happySpecReduce_1 187# happyReduction_556 +happyReduction_556 happy_x_1 + = case happyOut204 happy_x_1 of { happy_var_1 -> + happyIn202 + (sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_557 = happySpecReduce_0 187# happyReduction_557 +happyReduction_557 = happyIn202 + (noLoc ([],[]) + ) + +happyReduce_558 = happySpecReduce_1 188# happyReduction_558 +happyReduction_558 happy_x_1 + = case happyOut204 happy_x_1 of { happy_var_1 -> + happyIn203 + (Just happy_var_1 + )} + +happyReduce_559 = happySpecReduce_0 188# happyReduction_559 +happyReduction_559 = happyIn203 + (Nothing + ) + +happyReduce_560 = happySpecReduce_1 189# happyReduction_560 +happyReduction_560 happy_x_1 + = case happyOut205 happy_x_1 of { happy_var_1 -> + happyIn204 + (happy_var_1 + )} + +happyReduce_561 = happyMonadReduce 2# 189# happyReduction_561 +happyReduction_561 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut201 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ mkRecStmt (snd $ unLoc happy_var_2)) + (mj AnnRec happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn204 r)) + +happyReduce_562 = happyMonadReduce 3# 190# happyReduction_562 +happyReduction_562 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut198 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ mkBindStmt happy_var_1 happy_var_3) + [mj AnnLarrow happy_var_2])}}} + ) (\r -> happyReturn (happyIn205 r)) + +happyReduce_563 = happySpecReduce_1 190# happyReduction_563 +happyReduction_563 happy_x_1 + = case happyOut159 happy_x_1 of { happy_var_1 -> + happyIn205 + (sL1 happy_var_1 $ mkBodyStmt happy_var_1 + )} + +happyReduce_564 = happyMonadReduce 2# 190# happyReduction_564 +happyReduction_564 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut87 happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2$ LetStmt (snd $ unLoc happy_var_2)) + (mj AnnLet happy_var_1:(fst $ unLoc happy_var_2)))}} + ) (\r -> happyReturn (happyIn205 r)) + +happyReduce_565 = happySpecReduce_1 191# happyReduction_565 +happyReduction_565 happy_x_1 + = case happyOut207 happy_x_1 of { happy_var_1 -> + happyIn206 + (happy_var_1 + )} + +happyReduce_566 = happySpecReduce_0 191# happyReduction_566 +happyReduction_566 = happyIn206 + (([],([], False)) + ) + +happyReduce_567 = happyMonadReduce 3# 192# happyReduction_567 +happyReduction_567 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut208 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut207 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (case happy_var_3 of (ma,(flds, dd)) -> (ma,(happy_var_1 : flds, dd))))}}} + ) (\r -> happyReturn (happyIn207 r)) + +happyReduce_568 = happySpecReduce_1 192# happyReduction_568 +happyReduction_568 happy_x_1 + = case happyOut208 happy_x_1 of { happy_var_1 -> + happyIn207 + (([],([happy_var_1], False)) + )} + +happyReduce_569 = happySpecReduce_1 192# happyReduction_569 +happyReduction_569 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn207 + (([mj AnnDotdot happy_var_1],([], True)) + )} + +happyReduce_570 = happyMonadReduce 3# 193# happyReduction_570 +happyReduction_570 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut245 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut174 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ HsRecField happy_var_1 happy_var_3 False) + [mj AnnEqual happy_var_2])}}} + ) (\r -> happyReturn (happyIn208 r)) + +happyReduce_571 = happySpecReduce_1 193# happyReduction_571 +happyReduction_571 happy_x_1 + = case happyOut245 happy_x_1 of { happy_var_1 -> + happyIn208 + (sLL happy_var_1 happy_var_1 $ HsRecField happy_var_1 placeHolderPunRhs True + )} + +happyReduce_572 = happyMonadReduce 3# 194# happyReduction_572 +happyReduction_572 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut209 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut210 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> + return (let { this = happy_var_3; rest = unLoc happy_var_1 } + in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))}}} + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_573 = happyMonadReduce 2# 194# happyReduction_573 +happyReduction_573 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut209 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}} + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_574 = happySpecReduce_1 194# happyReduction_574 +happyReduction_574 happy_x_1 + = case happyOut210 happy_x_1 of { happy_var_1 -> + happyIn209 + (let this = happy_var_1 in this `seq` sL1 happy_var_1 [this] + )} + +happyReduce_575 = happyMonadReduce 3# 195# happyReduction_575 +happyReduction_575 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut211 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (IPBind (Left happy_var_1) happy_var_3)) + [mj AnnEqual happy_var_2])}}} + ) (\r -> happyReturn (happyIn210 r)) + +happyReduce_576 = happySpecReduce_1 196# happyReduction_576 +happyReduction_576 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn211 + (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) + )} + +happyReduce_577 = happySpecReduce_1 197# happyReduction_577 +happyReduction_577 happy_x_1 + = case happyOut213 happy_x_1 of { happy_var_1 -> + happyIn212 + (happy_var_1 + )} + +happyReduce_578 = happySpecReduce_0 197# happyReduction_578 +happyReduction_578 = happyIn212 + (([],mkTrue) + ) + +happyReduce_579 = happySpecReduce_1 198# happyReduction_579 +happyReduction_579 happy_x_1 + = case happyOut214 happy_x_1 of { happy_var_1 -> + happyIn213 + (happy_var_1 + )} + +happyReduce_580 = happySpecReduce_3 198# happyReduction_580 +happyReduction_580 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut214 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut213 happy_x_3 of { happy_var_3 -> + happyIn213 + (((mj AnnVbar happy_var_2:fst happy_var_1)++(fst happy_var_3) + ,Or [snd happy_var_1,snd happy_var_3]) + )}}} + +happyReduce_581 = happySpecReduce_1 199# happyReduction_581 +happyReduction_581 happy_x_1 + = case happyOut215 happy_x_1 of { happy_var_1 -> + happyIn214 + (happy_var_1 + )} + +happyReduce_582 = happySpecReduce_3 199# happyReduction_582 +happyReduction_582 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut215 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut214 happy_x_3 of { happy_var_3 -> + happyIn214 + (((mj AnnComma happy_var_2:fst happy_var_1)++(fst happy_var_3), And [snd happy_var_1,snd happy_var_3]) + )}}} + +happyReduce_583 = happySpecReduce_3 200# happyReduction_583 +happyReduction_583 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut213 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn215 + (((mop happy_var_1:mcp happy_var_3:(fst happy_var_2)),snd happy_var_2) + )}}} + +happyReduce_584 = happySpecReduce_1 200# happyReduction_584 +happyReduction_584 happy_x_1 + = case happyOut217 happy_x_1 of { happy_var_1 -> + happyIn215 + (([],Var happy_var_1) + )} + +happyReduce_585 = happySpecReduce_1 201# happyReduction_585 +happyReduction_585 happy_x_1 + = case happyOut217 happy_x_1 of { happy_var_1 -> + happyIn216 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_586 = happyMonadReduce 3# 201# happyReduction_586 +happyReduction_586 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut217 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut216 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_587 = happySpecReduce_1 202# happyReduction_587 +happyReduction_587 happy_x_1 + = case happyOut244 happy_x_1 of { happy_var_1 -> + happyIn217 + (happy_var_1 + )} + +happyReduce_588 = happySpecReduce_1 202# happyReduction_588 +happyReduction_588 happy_x_1 + = case happyOut221 happy_x_1 of { happy_var_1 -> + happyIn217 + (happy_var_1 + )} + +happyReduce_589 = happySpecReduce_1 203# happyReduction_589 +happyReduction_589 happy_x_1 + = case happyOut220 happy_x_1 of { happy_var_1 -> + happyIn218 + (happy_var_1 + )} + +happyReduce_590 = happySpecReduce_1 203# happyReduction_590 +happyReduction_590 happy_x_1 + = case happyOut223 happy_x_1 of { happy_var_1 -> + happyIn218 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + )} + +happyReduce_591 = happySpecReduce_1 204# happyReduction_591 +happyReduction_591 happy_x_1 + = case happyOut220 happy_x_1 of { happy_var_1 -> + happyIn219 + (happy_var_1 + )} + +happyReduce_592 = happySpecReduce_1 204# happyReduction_592 +happyReduction_592 happy_x_1 + = case happyOut224 happy_x_1 of { happy_var_1 -> + happyIn219 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + )} + +happyReduce_593 = happySpecReduce_1 205# happyReduction_593 +happyReduction_593 happy_x_1 + = case happyOut255 happy_x_1 of { happy_var_1 -> + happyIn220 + (happy_var_1 + )} + +happyReduce_594 = happyMonadReduce 3# 205# happyReduction_594 +happyReduction_594 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut257 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn220 r)) + +happyReduce_595 = happySpecReduce_1 206# happyReduction_595 +happyReduction_595 happy_x_1 + = case happyOut256 happy_x_1 of { happy_var_1 -> + happyIn221 + (happy_var_1 + )} + +happyReduce_596 = happyMonadReduce 3# 206# happyReduction_596 +happyReduction_596 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut258 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn221 r)) + +happyReduce_597 = happySpecReduce_1 206# happyReduction_597 +happyReduction_597 happy_x_1 + = case happyOut224 happy_x_1 of { happy_var_1 -> + happyIn221 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + )} + +happyReduce_598 = happySpecReduce_1 207# happyReduction_598 +happyReduction_598 happy_x_1 + = case happyOut221 happy_x_1 of { happy_var_1 -> + happyIn222 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_599 = happyMonadReduce 3# 207# happyReduction_599 +happyReduction_599 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut221 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { happy_var_3 -> + ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}} + ) (\r -> happyReturn (happyIn222 r)) + +happyReduce_600 = happyMonadReduce 2# 208# happyReduction_600 +happyReduction_600 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 unitDataCon) [mop happy_var_1,mcp happy_var_2])}} + ) (\r -> happyReturn (happyIn223 r)) + +happyReduce_601 = happyMonadReduce 3# 208# happyReduction_601 +happyReduction_601 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut262 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ tupleCon BoxedTuple (snd happy_var_2 + 1)) + (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}} + ) (\r -> happyReturn (happyIn223 r)) + +happyReduce_602 = happyMonadReduce 2# 208# happyReduction_602 +happyReduction_602 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn223 r)) + +happyReduce_603 = happyMonadReduce 3# 208# happyReduction_603 +happyReduction_603 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut262 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ tupleCon UnboxedTuple (snd happy_var_2 + 1)) + (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}} + ) (\r -> happyReturn (happyIn223 r)) + +happyReduce_604 = happySpecReduce_1 209# happyReduction_604 +happyReduction_604 happy_x_1 + = case happyOut223 happy_x_1 of { happy_var_1 -> + happyIn224 + (happy_var_1 + )} + +happyReduce_605 = happyMonadReduce 2# 209# happyReduction_605 +happyReduction_605 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 nilDataCon) [mos happy_var_1,mcs happy_var_2])}} + ) (\r -> happyReturn (happyIn224 r)) + +happyReduce_606 = happySpecReduce_1 210# happyReduction_606 +happyReduction_606 happy_x_1 + = case happyOut258 happy_x_1 of { happy_var_1 -> + happyIn225 + (happy_var_1 + )} + +happyReduce_607 = happyMonadReduce 3# 210# happyReduction_607 +happyReduction_607 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut256 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn225 r)) + +happyReduce_608 = happySpecReduce_1 211# happyReduction_608 +happyReduction_608 happy_x_1 + = case happyOut257 happy_x_1 of { happy_var_1 -> + happyIn226 + (happy_var_1 + )} + +happyReduce_609 = happyMonadReduce 3# 211# happyReduction_609 +happyReduction_609 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut255 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn226 r)) + +happyReduce_610 = happySpecReduce_1 212# happyReduction_610 +happyReduction_610 happy_x_1 + = case happyOut228 happy_x_1 of { happy_var_1 -> + happyIn227 + (happy_var_1 + )} + +happyReduce_611 = happyMonadReduce 2# 212# happyReduction_611 +happyReduction_611 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) + [mop happy_var_1,mcp happy_var_2])}} + ) (\r -> happyReturn (happyIn227 r)) + +happyReduce_612 = happyMonadReduce 2# 212# happyReduction_612 +happyReduction_612 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) + [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn227 r)) + +happyReduce_613 = happySpecReduce_1 213# happyReduction_613 +happyReduction_613 happy_x_1 + = case happyOut229 happy_x_1 of { happy_var_1 -> + happyIn228 + (happy_var_1 + )} + +happyReduce_614 = happyMonadReduce 3# 213# happyReduction_614 +happyReduction_614 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut262 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon BoxedTuple + (snd happy_var_2 + 1))) + (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_615 = happyMonadReduce 3# 213# happyReduction_615 +happyReduction_615 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut262 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon UnboxedTuple + (snd happy_var_2 + 1))) + (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_616 = happyMonadReduce 3# 213# happyReduction_616 +happyReduction_616 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) + [mop happy_var_1,mj AnnRarrow happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_617 = happyMonadReduce 2# 213# happyReduction_617 +happyReduction_617 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) [mos happy_var_1,mcs happy_var_2])}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_618 = happyMonadReduce 2# 213# happyReduction_618 +happyReduction_618 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( ams (sLL happy_var_1 happy_var_2 $ parrTyCon_RDR) [mo happy_var_1,mc happy_var_2])}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_619 = happyMonadReduce 3# 213# happyReduction_619 +happyReduction_619 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ getRdrName eqPrimTyCon) + [mop happy_var_1,mj AnnTildehsh happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_620 = happySpecReduce_1 214# happyReduction_620 +happyReduction_620 happy_x_1 + = case happyOut231 happy_x_1 of { happy_var_1 -> + happyIn229 + (happy_var_1 + )} + +happyReduce_621 = happyMonadReduce 3# 214# happyReduction_621 +happyReduction_621 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut233 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn229 r)) + +happyReduce_622 = happyMonadReduce 3# 214# happyReduction_622 +happyReduction_622 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) + [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn229 r)) + +happyReduce_623 = happySpecReduce_1 215# happyReduction_623 +happyReduction_623 happy_x_1 + = case happyOut233 happy_x_1 of { happy_var_1 -> + happyIn230 + (happy_var_1 + )} + +happyReduce_624 = happyMonadReduce 3# 215# happyReduction_624 +happyReduction_624 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut231 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_625 = happySpecReduce_1 216# happyReduction_625 +happyReduction_625 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn231 + (sL1 happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) + )} + +happyReduce_626 = happySpecReduce_1 216# happyReduction_626 +happyReduction_626 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn231 + (sL1 happy_var_1 $! mkQual tcClsName (getPREFIXQCONSYM happy_var_1) + )} + +happyReduce_627 = happySpecReduce_1 216# happyReduction_627 +happyReduction_627 happy_x_1 + = case happyOut232 happy_x_1 of { happy_var_1 -> + happyIn231 + (happy_var_1 + )} + +happyReduce_628 = happySpecReduce_1 217# happyReduction_628 +happyReduction_628 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (sL1 happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) + )} + +happyReduce_629 = happySpecReduce_1 218# happyReduction_629 +happyReduction_629 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn233 + (sL1 happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) + )} + +happyReduce_630 = happySpecReduce_1 218# happyReduction_630 +happyReduction_630 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn233 + (sL1 happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) + )} + +happyReduce_631 = happySpecReduce_1 218# happyReduction_631 +happyReduction_631 happy_x_1 + = case happyOut234 happy_x_1 of { happy_var_1 -> + happyIn233 + (happy_var_1 + )} + +happyReduce_632 = happySpecReduce_1 219# happyReduction_632 +happyReduction_632 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn234 + (sL1 happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) + )} + +happyReduce_633 = happySpecReduce_1 219# happyReduction_633 +happyReduction_633 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn234 + (sL1 happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) + )} + +happyReduce_634 = happySpecReduce_1 219# happyReduction_634 +happyReduction_634 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn234 + (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "*") + )} + +happyReduce_635 = happySpecReduce_1 219# happyReduction_635 +happyReduction_635 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn234 + (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "-") + )} + +happyReduce_636 = happySpecReduce_1 220# happyReduction_636 +happyReduction_636 happy_x_1 + = case happyOut236 happy_x_1 of { happy_var_1 -> + happyIn235 + (happy_var_1 + )} + +happyReduce_637 = happySpecReduce_1 220# happyReduction_637 +happyReduction_637 happy_x_1 + = case happyOut225 happy_x_1 of { happy_var_1 -> + happyIn235 + (happy_var_1 + )} + +happyReduce_638 = happySpecReduce_1 221# happyReduction_638 +happyReduction_638 happy_x_1 + = case happyOut251 happy_x_1 of { happy_var_1 -> + happyIn236 + (happy_var_1 + )} + +happyReduce_639 = happyMonadReduce 3# 221# happyReduction_639 +happyReduction_639 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut247 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn236 r)) + +happyReduce_640 = happySpecReduce_1 222# happyReduction_640 +happyReduction_640 happy_x_1 + = case happyOut239 happy_x_1 of { happy_var_1 -> + happyIn237 + (sL1 happy_var_1 $ HsVar (unLoc happy_var_1) + )} + +happyReduce_641 = happySpecReduce_1 222# happyReduction_641 +happyReduction_641 happy_x_1 + = case happyOut226 happy_x_1 of { happy_var_1 -> + happyIn237 + (sL1 happy_var_1 $ HsVar (unLoc happy_var_1) + )} + +happyReduce_642 = happySpecReduce_1 223# happyReduction_642 +happyReduction_642 happy_x_1 + = case happyOut240 happy_x_1 of { happy_var_1 -> + happyIn238 + (sL1 happy_var_1 $ HsVar (unLoc happy_var_1) + )} + +happyReduce_643 = happySpecReduce_1 223# happyReduction_643 +happyReduction_643 happy_x_1 + = case happyOut226 happy_x_1 of { happy_var_1 -> + happyIn238 + (sL1 happy_var_1 $ HsVar (unLoc happy_var_1) + )} + +happyReduce_644 = happySpecReduce_1 224# happyReduction_644 +happyReduction_644 happy_x_1 + = case happyOut248 happy_x_1 of { happy_var_1 -> + happyIn239 + (happy_var_1 + )} + +happyReduce_645 = happyMonadReduce 3# 224# happyReduction_645 +happyReduction_645 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut246 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn239 r)) + +happyReduce_646 = happySpecReduce_1 225# happyReduction_646 +happyReduction_646 happy_x_1 + = case happyOut249 happy_x_1 of { happy_var_1 -> + happyIn240 + (happy_var_1 + )} + +happyReduce_647 = happyMonadReduce 3# 225# happyReduction_647 +happyReduction_647 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut246 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn240 r)) + +happyReduce_648 = happySpecReduce_1 226# happyReduction_648 +happyReduction_648 happy_x_1 + = case happyOut243 happy_x_1 of { happy_var_1 -> + happyIn241 + (happy_var_1 + )} + +happyReduce_649 = happyMonadReduce 3# 227# happyReduction_649 +happyReduction_649 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut243 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])}}} + ) (\r -> happyReturn (happyIn242 r)) + +happyReduce_650 = happyMonadReduce 1# 227# happyReduction_650 +happyReduction_650 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( parseErrorSDoc (getLoc happy_var_1) + (vcat [ptext (sLit "Illegal symbol '.' in type"), + ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"), + ptext (sLit "extension to enable explicit-forall syntax: forall . ")]))} + ) (\r -> happyReturn (happyIn242 r)) + +happyReduce_651 = happySpecReduce_1 228# happyReduction_651 +happyReduction_651 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn243 + (sL1 happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) + )} + +happyReduce_652 = happySpecReduce_1 228# happyReduction_652 +happyReduction_652 happy_x_1 + = case happyOut253 happy_x_1 of { happy_var_1 -> + happyIn243 + (sL1 happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) + )} + +happyReduce_653 = happySpecReduce_1 228# happyReduction_653 +happyReduction_653 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn243 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "unsafe") + )} + +happyReduce_654 = happySpecReduce_1 228# happyReduction_654 +happyReduction_654 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn243 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "safe") + )} + +happyReduce_655 = happySpecReduce_1 228# happyReduction_655 +happyReduction_655 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn243 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "interruptible") + )} + +happyReduce_656 = happySpecReduce_1 229# happyReduction_656 +happyReduction_656 happy_x_1 + = case happyOut247 happy_x_1 of { happy_var_1 -> + happyIn244 + (happy_var_1 + )} + +happyReduce_657 = happyMonadReduce 3# 229# happyReduction_657 +happyReduction_657 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn244 r)) + +happyReduce_658 = happySpecReduce_1 230# happyReduction_658 +happyReduction_658 happy_x_1 + = case happyOut246 happy_x_1 of { happy_var_1 -> + happyIn245 + (happy_var_1 + )} + +happyReduce_659 = happyMonadReduce 3# 230# happyReduction_659 +happyReduction_659 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn245 r)) + +happyReduce_660 = happyMonadReduce 3# 230# happyReduction_660 +happyReduction_660 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut250 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}} + ) (\r -> happyReturn (happyIn245 r)) + +happyReduce_661 = happySpecReduce_1 231# happyReduction_661 +happyReduction_661 happy_x_1 + = case happyOut247 happy_x_1 of { happy_var_1 -> + happyIn246 + (happy_var_1 + )} + +happyReduce_662 = happySpecReduce_1 231# happyReduction_662 +happyReduction_662 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn246 + (sL1 happy_var_1 $! mkQual varName (getQVARID happy_var_1) + )} + +happyReduce_663 = happySpecReduce_1 231# happyReduction_663 +happyReduction_663 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn246 + (sL1 happy_var_1 $! mkQual varName (getPREFIXQVARSYM happy_var_1) + )} + +happyReduce_664 = happySpecReduce_1 232# happyReduction_664 +happyReduction_664 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (getVARID happy_var_1) + )} + +happyReduce_665 = happySpecReduce_1 232# happyReduction_665 +happyReduction_665 happy_x_1 + = case happyOut253 happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_666 = happySpecReduce_1 232# happyReduction_666 +happyReduction_666 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "unsafe") + )} + +happyReduce_667 = happySpecReduce_1 232# happyReduction_667 +happyReduction_667 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "safe") + )} + +happyReduce_668 = happySpecReduce_1 232# happyReduction_668 +happyReduction_668 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "interruptible") + )} + +happyReduce_669 = happySpecReduce_1 232# happyReduction_669 +happyReduction_669 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "forall") + )} + +happyReduce_670 = happySpecReduce_1 232# happyReduction_670 +happyReduction_670 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "family") + )} + +happyReduce_671 = happySpecReduce_1 232# happyReduction_671 +happyReduction_671 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn247 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "role") + )} + +happyReduce_672 = happySpecReduce_1 233# happyReduction_672 +happyReduction_672 happy_x_1 + = case happyOut251 happy_x_1 of { happy_var_1 -> + happyIn248 + (happy_var_1 + )} + +happyReduce_673 = happySpecReduce_1 233# happyReduction_673 +happyReduction_673 happy_x_1 + = case happyOut250 happy_x_1 of { happy_var_1 -> + happyIn248 + (happy_var_1 + )} + +happyReduce_674 = happySpecReduce_1 234# happyReduction_674 +happyReduction_674 happy_x_1 + = case happyOut252 happy_x_1 of { happy_var_1 -> + happyIn249 + (happy_var_1 + )} + +happyReduce_675 = happySpecReduce_1 234# happyReduction_675 +happyReduction_675 happy_x_1 + = case happyOut250 happy_x_1 of { happy_var_1 -> + happyIn249 + (happy_var_1 + )} + +happyReduce_676 = happySpecReduce_1 235# happyReduction_676 +happyReduction_676 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn250 + (sL1 happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) + )} + +happyReduce_677 = happySpecReduce_1 236# happyReduction_677 +happyReduction_677 happy_x_1 + = case happyOut252 happy_x_1 of { happy_var_1 -> + happyIn251 + (happy_var_1 + )} + +happyReduce_678 = happySpecReduce_1 236# happyReduction_678 +happyReduction_678 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn251 + (sL1 happy_var_1 $ mkUnqual varName (fsLit "-") + )} + +happyReduce_679 = happySpecReduce_1 237# happyReduction_679 +happyReduction_679 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn252 + (sL1 happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) + )} + +happyReduce_680 = happySpecReduce_1 237# happyReduction_680 +happyReduction_680 happy_x_1 + = case happyOut254 happy_x_1 of { happy_var_1 -> + happyIn252 + (sL1 happy_var_1 $ mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_681 = happySpecReduce_1 238# happyReduction_681 +happyReduction_681 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "as") + )} + +happyReduce_682 = happySpecReduce_1 238# happyReduction_682 +happyReduction_682 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "qualified") + )} + +happyReduce_683 = happySpecReduce_1 238# happyReduction_683 +happyReduction_683 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "hiding") + )} + +happyReduce_684 = happySpecReduce_1 238# happyReduction_684 +happyReduction_684 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "export") + )} + +happyReduce_685 = happySpecReduce_1 238# happyReduction_685 +happyReduction_685 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "label") + )} + +happyReduce_686 = happySpecReduce_1 238# happyReduction_686 +happyReduction_686 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "dynamic") + )} + +happyReduce_687 = happySpecReduce_1 238# happyReduction_687 +happyReduction_687 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "stdcall") + )} + +happyReduce_688 = happySpecReduce_1 238# happyReduction_688 +happyReduction_688 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "ccall") + )} + +happyReduce_689 = happySpecReduce_1 238# happyReduction_689 +happyReduction_689 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "capi") + )} + +happyReduce_690 = happySpecReduce_1 238# happyReduction_690 +happyReduction_690 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "prim") + )} + +happyReduce_691 = happySpecReduce_1 238# happyReduction_691 +happyReduction_691 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "javascript") + )} + +happyReduce_692 = happySpecReduce_1 238# happyReduction_692 +happyReduction_692 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn253 + (sL1 happy_var_1 (fsLit "group") + )} + +happyReduce_693 = happyMonadReduce 1# 239# happyReduction_693 +happyReduction_693 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( ams (sL1 happy_var_1 (fsLit "!")) [mj AnnBang happy_var_1])} + ) (\r -> happyReturn (happyIn254 r)) + +happyReduce_694 = happySpecReduce_1 239# happyReduction_694 +happyReduction_694 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn254 + (sL1 happy_var_1 (fsLit ".") + )} + +happyReduce_695 = happySpecReduce_1 239# happyReduction_695 +happyReduction_695 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn254 + (sL1 happy_var_1 (fsLit "*") + )} + +happyReduce_696 = happySpecReduce_1 240# happyReduction_696 +happyReduction_696 happy_x_1 + = case happyOut256 happy_x_1 of { happy_var_1 -> + happyIn255 + (happy_var_1 + )} + +happyReduce_697 = happySpecReduce_1 240# happyReduction_697 +happyReduction_697 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn255 + (sL1 happy_var_1 $! mkQual dataName (getQCONID happy_var_1) + )} + +happyReduce_698 = happySpecReduce_1 240# happyReduction_698 +happyReduction_698 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn255 + (sL1 happy_var_1 $! mkQual dataName (getPREFIXQCONSYM happy_var_1) + )} + +happyReduce_699 = happySpecReduce_1 241# happyReduction_699 +happyReduction_699 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn256 + (sL1 happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) + )} + +happyReduce_700 = happySpecReduce_1 242# happyReduction_700 +happyReduction_700 happy_x_1 + = case happyOut258 happy_x_1 of { happy_var_1 -> + happyIn257 + (happy_var_1 + )} + +happyReduce_701 = happySpecReduce_1 242# happyReduction_701 +happyReduction_701 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn257 + (sL1 happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) + )} + +happyReduce_702 = happySpecReduce_1 243# happyReduction_702 +happyReduction_702 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn258 + (sL1 happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) + )} + +happyReduce_703 = happySpecReduce_1 243# happyReduction_703 +happyReduction_703 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn258 + (sL1 happy_var_1 $ consDataCon_RDR + )} + +happyReduce_704 = happySpecReduce_1 244# happyReduction_704 +happyReduction_704 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 + )} + +happyReduce_705 = happySpecReduce_1 244# happyReduction_705 +happyReduction_705 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) + $ getSTRING happy_var_1 + )} + +happyReduce_706 = happySpecReduce_1 244# happyReduction_706 +happyReduction_706 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) + $ getPRIMINTEGER happy_var_1 + )} + +happyReduce_707 = happySpecReduce_1 244# happyReduction_707 +happyReduction_707 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) + $ getPRIMWORD happy_var_1 + )} + +happyReduce_708 = happySpecReduce_1 244# happyReduction_708 +happyReduction_708 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) + $ getPRIMCHAR happy_var_1 + )} + +happyReduce_709 = happySpecReduce_1 244# happyReduction_709 +happyReduction_709 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) + $ getPRIMSTRING happy_var_1 + )} + +happyReduce_710 = happySpecReduce_1 244# happyReduction_710 +happyReduction_710 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsFloatPrim $ getPRIMFLOAT happy_var_1 + )} + +happyReduce_711 = happySpecReduce_1 244# happyReduction_711 +happyReduction_711 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn259 + (sL1 happy_var_1 $ HsDoublePrim $ getPRIMDOUBLE happy_var_1 + )} + +happyReduce_712 = happySpecReduce_1 245# happyReduction_712 +happyReduction_712 happy_x_1 + = happyIn260 + (() + ) + +happyReduce_713 = happyMonadReduce 1# 245# happyReduction_713 +happyReduction_713 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (( popContext) + ) (\r -> happyReturn (happyIn260 r)) + +happyReduce_714 = happySpecReduce_1 246# happyReduction_714 +happyReduction_714 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn261 + (sL1 happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) + )} + +happyReduce_715 = happySpecReduce_1 246# happyReduction_715 +happyReduction_715 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn261 + (sL1 happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in + mkModuleNameFS + (mkFastString + (unpackFS mod ++ '.':unpackFS c)) + )} + +happyReduce_716 = happySpecReduce_2 247# happyReduction_716 +happyReduction_716 happy_x_2 + happy_x_1 + = case happyOut262 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn262 + (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) + )}} + +happyReduce_717 = happySpecReduce_1 247# happyReduction_717 +happyReduction_717 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn262 + (([gl happy_var_1],1) + )} + +happyReduce_718 = happyMonadReduce 1# 248# happyReduction_718 +happyReduction_718 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( return (sL1 happy_var_1 (HsDocString (mkFastString (getDOCNEXT happy_var_1)))))} + ) (\r -> happyReturn (happyIn263 r)) + +happyReduce_719 = happyMonadReduce 1# 249# happyReduction_719 +happyReduction_719 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( return (sL1 happy_var_1 (HsDocString (mkFastString (getDOCPREV happy_var_1)))))} + ) (\r -> happyReturn (happyIn264 r)) + +happyReduce_720 = happyMonadReduce 1# 250# happyReduction_720 +happyReduction_720 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( + let string = getDOCNAMED happy_var_1 + (name, rest) = break isSpace string + in return (sL1 happy_var_1 (name, HsDocString (mkFastString rest))))} + ) (\r -> happyReturn (happyIn265 r)) + +happyReduce_721 = happyMonadReduce 1# 251# happyReduction_721 +happyReduction_721 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( let (n, doc) = getDOCSECTION happy_var_1 in + return (sL1 happy_var_1 (n, HsDocString (mkFastString doc))))} + ) (\r -> happyReturn (happyIn266 r)) + +happyReduce_722 = happyMonadReduce 1# 252# happyReduction_722 +happyReduction_722 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + ( let string = getDOCNEXT happy_var_1 in + return (Just (sL1 happy_var_1 (HsDocString (mkFastString string)))))} + ) (\r -> happyReturn (happyIn267 r)) + +happyReduce_723 = happySpecReduce_1 253# happyReduction_723 +happyReduction_723 happy_x_1 + = case happyOut264 happy_x_1 of { happy_var_1 -> + happyIn268 + (Just happy_var_1 + )} + +happyReduce_724 = happySpecReduce_0 253# happyReduction_724 +happyReduction_724 = happyIn268 + (Nothing + ) + +happyReduce_725 = happySpecReduce_1 254# happyReduction_725 +happyReduction_725 happy_x_1 + = case happyOut263 happy_x_1 of { happy_var_1 -> + happyIn269 + (Just happy_var_1 + )} + +happyReduce_726 = happySpecReduce_0 254# happyReduction_726 +happyReduction_726 = happyIn269 + (Nothing + ) + +happyNewToken action sts stk + = (lexer True)(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ ITeof -> happyDoAction 150# tk action sts stk; + L _ ITunderscore -> cont 1#; + L _ ITas -> cont 2#; + L _ ITcase -> cont 3#; + L _ ITclass -> cont 4#; + L _ ITdata -> cont 5#; + L _ ITdefault -> cont 6#; + L _ ITderiving -> cont 7#; + L _ ITdo -> cont 8#; + L _ ITelse -> cont 9#; + L _ IThiding -> cont 10#; + L _ ITif -> cont 11#; + L _ ITimport -> cont 12#; + L _ ITin -> cont 13#; + L _ ITinfix -> cont 14#; + L _ ITinfixl -> cont 15#; + L _ ITinfixr -> cont 16#; + L _ ITinstance -> cont 17#; + L _ ITlet -> cont 18#; + L _ ITmodule -> cont 19#; + L _ ITnewtype -> cont 20#; + L _ ITof -> cont 21#; + L _ ITqualified -> cont 22#; + L _ ITthen -> cont 23#; + L _ ITtype -> cont 24#; + L _ ITwhere -> cont 25#; + L _ ITforall -> cont 26#; + L _ ITforeign -> cont 27#; + L _ ITexport -> cont 28#; + L _ ITlabel -> cont 29#; + L _ ITdynamic -> cont 30#; + L _ ITsafe -> cont 31#; + L _ ITinterruptible -> cont 32#; + L _ ITunsafe -> cont 33#; + L _ ITmdo -> cont 34#; + L _ ITfamily -> cont 35#; + L _ ITrole -> cont 36#; + L _ ITstdcallconv -> cont 37#; + L _ ITccallconv -> cont 38#; + L _ ITcapiconv -> cont 39#; + L _ ITprimcallconv -> cont 40#; + L _ ITjavascriptcallconv -> cont 41#; + L _ ITproc -> cont 42#; + L _ ITrec -> cont 43#; + L _ ITgroup -> cont 44#; + L _ ITby -> cont 45#; + L _ ITusing -> cont 46#; + L _ ITpattern -> cont 47#; + L _ ITstatic -> cont 48#; + L _ (ITinline_prag _ _ _) -> cont 49#; + L _ (ITspec_prag _) -> cont 50#; + L _ (ITspec_inline_prag _ _) -> cont 51#; + L _ (ITsource_prag _) -> cont 52#; + L _ (ITrules_prag _) -> cont 53#; + L _ (ITcore_prag _) -> cont 54#; + L _ (ITscc_prag _) -> cont 55#; + L _ (ITgenerated_prag _) -> cont 56#; + L _ (ITdeprecated_prag _) -> cont 57#; + L _ (ITwarning_prag _) -> cont 58#; + L _ (ITunpack_prag _) -> cont 59#; + L _ (ITnounpack_prag _) -> cont 60#; + L _ (ITann_prag _) -> cont 61#; + L _ (ITvect_prag _) -> cont 62#; + L _ (ITvect_scalar_prag _) -> cont 63#; + L _ (ITnovect_prag _) -> cont 64#; + L _ (ITminimal_prag _) -> cont 65#; + L _ (ITctype _) -> cont 66#; + L _ (IToverlapping_prag _) -> cont 67#; + L _ (IToverlappable_prag _) -> cont 68#; + L _ (IToverlaps_prag _) -> cont 69#; + L _ (ITincoherent_prag _) -> cont 70#; + L _ ITclose_prag -> cont 71#; + L _ ITdotdot -> cont 72#; + L _ ITcolon -> cont 73#; + L _ ITdcolon -> cont 74#; + L _ ITequal -> cont 75#; + L _ ITlam -> cont 76#; + L _ ITlcase -> cont 77#; + L _ ITvbar -> cont 78#; + L _ ITlarrow -> cont 79#; + L _ ITrarrow -> cont 80#; + L _ ITat -> cont 81#; + L _ ITtilde -> cont 82#; + L _ ITtildehsh -> cont 83#; + L _ ITdarrow -> cont 84#; + L _ ITminus -> cont 85#; + L _ ITbang -> cont 86#; + L _ ITstar -> cont 87#; + L _ ITlarrowtail -> cont 88#; + L _ ITrarrowtail -> cont 89#; + L _ ITLarrowtail -> cont 90#; + L _ ITRarrowtail -> cont 91#; + L _ ITdot -> cont 92#; + L _ ITocurly -> cont 93#; + L _ ITccurly -> cont 94#; + L _ ITvocurly -> cont 95#; + L _ ITvccurly -> cont 96#; + L _ ITobrack -> cont 97#; + L _ ITcbrack -> cont 98#; + L _ ITopabrack -> cont 99#; + L _ ITcpabrack -> cont 100#; + L _ IToparen -> cont 101#; + L _ ITcparen -> cont 102#; + L _ IToubxparen -> cont 103#; + L _ ITcubxparen -> cont 104#; + L _ IToparenbar -> cont 105#; + L _ ITcparenbar -> cont 106#; + L _ ITsemi -> cont 107#; + L _ ITcomma -> cont 108#; + L _ ITbackquote -> cont 109#; + L _ ITsimpleQuote -> cont 110#; + L _ (ITvarid _) -> cont 111#; + L _ (ITconid _) -> cont 112#; + L _ (ITvarsym _) -> cont 113#; + L _ (ITconsym _) -> cont 114#; + L _ (ITqvarid _) -> cont 115#; + L _ (ITqconid _) -> cont 116#; + L _ (ITqvarsym _) -> cont 117#; + L _ (ITqconsym _) -> cont 118#; + L _ (ITprefixqvarsym _) -> cont 119#; + L _ (ITprefixqconsym _) -> cont 120#; + L _ (ITdupipvarid _) -> cont 121#; + L _ (ITchar _ _) -> cont 122#; + L _ (ITstring _ _) -> cont 123#; + L _ (ITinteger _ _) -> cont 124#; + L _ (ITrational _) -> cont 125#; + L _ (ITprimchar _ _) -> cont 126#; + L _ (ITprimstring _ _) -> cont 127#; + L _ (ITprimint _ _) -> cont 128#; + L _ (ITprimword _ _) -> cont 129#; + L _ (ITprimfloat _) -> cont 130#; + L _ (ITprimdouble _) -> cont 131#; + L _ (ITdocCommentNext _) -> cont 132#; + L _ (ITdocCommentPrev _) -> cont 133#; + L _ (ITdocCommentNamed _) -> cont 134#; + L _ (ITdocSection _ _) -> cont 135#; + L _ ITopenExpQuote -> cont 136#; + L _ ITopenPatQuote -> cont 137#; + L _ ITopenTypQuote -> cont 138#; + L _ ITopenDecQuote -> cont 139#; + L _ ITcloseQuote -> cont 140#; + L _ ITopenTExpQuote -> cont 141#; + L _ ITcloseTExpQuote -> cont 142#; + L _ (ITidEscape _) -> cont 143#; + L _ ITparenEscape -> cont 144#; + L _ (ITidTyEscape _) -> cont 145#; + L _ ITparenTyEscape -> cont 146#; + L _ ITtyQuote -> cont 147#; + L _ (ITquasiQuote _) -> cont 148#; + L _ (ITqQuasiQuote _) -> cont 149#; + _ -> happyError' tk + }) + +happyError_ 150# tk = happyError' tk +happyError_ _ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => ((Located Token)) -> P a +happyError' tk = (\token -> happyError) tk + +parseModule = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut16 x)) + +parseImport = happySomeParser where + happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut38 x)) + +parseStatement = happySomeParser where + happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut204 x)) + +parseDeclaration = happySomeParser where + happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (happyOut50 x)) + +parseExpression = happySomeParser where + happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (happyOut159 x)) + +parsePattern = happySomeParser where + happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (happyOut197 x)) + +parseTypeSignature = happySomeParser where + happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (happyOut155 x)) + +parseFullStmt = happySomeParser where + happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (happyOut204 x)) + +parseStmt = happySomeParser where + happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (happyOut203 x)) + +parseIdentifier = happySomeParser where + happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (happyOut15 x)) + +parseType = happySomeParser where + happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (happyOut114 x)) + +parseHeader = happySomeParser where + happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (happyOut24 x)) + +happySeq = happyDoSeq + + +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getPREFIXQVARSYM (L _ (ITprefixqvarsym x)) = x +getPREFIXQCONSYM (L _ (ITprefixqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getINTEGER (L _ (ITinteger _ x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (L _ (ITidEscape x)) = x +getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) + +getDOCNEXT (L _ (ITdocCommentNext x)) = x +getDOCPREV (L _ (ITdocCommentPrev x)) = x +getDOCNAMED (L _ (ITdocCommentNamed x)) = x +getDOCSECTION (L _ (ITdocSection n x)) = (n, x) + +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getINTEGERs (L _ (ITinteger src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src + +-- See Note [Pragma source text] in BasicTypes for the following +getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getVECT_PRAGs (L _ (ITvect_prag src)) = src +getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src +getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src + + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then failSpanMsgP (getLoc lt) (text err) + else return s + +-- Utilities for combining source spans +comb2 :: Located a -> Located b -> SrcSpan +comb2 a b = a `seq` b `seq` combineLocs a b + +comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) + +comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 a b c d = a `seq` b `seq` c `seq` d `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d)) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` a `seq` L span a + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 = L noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState + unless mwiEnabled $ parseErrorSDoc span $ + text "Multi-way if-expressions need MultiWayIf turned on" + +-- Hint about if usage for beginners +hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) +hintIf span msg = do + mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState + if mwiEnabled + then parseErrorSDoc span $ text $ "parse error in if statement" + else parseErrorSDoc span $ text $ "parse error in if statement: "++msg + +-- Hint about explicit-forall, assuming UnicodeSyntax is on +hintExplicitForall :: SrcSpan -> P () +hintExplicitForall span = do + forall <- extension explicitForallEnabled + rulePrag <- extension inRulePrag + unless (forall || rulePrag) $ parseErrorSDoc span $ vcat + [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL + , text "Perhaps you intended to use RankNTypes or a similar language" + , text "extension to enable explicit-forall syntax: \x2200 . " + ] + +namedWildcardsEnabled :: P Bool +namedWildcardsEnabled = liftM ((Opt_NamedWildCards `xopt`) . dflags) getPState + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [Api annotations] +in ApiAnnotation.hs + +-} + +-- |Construct an AddAnn from the annotation keyword and the location +-- of the keyword +mj :: AnnKeywordId -> Located e -> AddAnn +mj a l = (\s -> addAnnotation s a (gl l)) + + +gl = getLoc + +-- |Add an annotation to the located element, and return the located +-- element as a pass through +aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) +aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a + +-- |Add an annotation to a located element resulting from a monadic action +am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) +am a (b,s) = do + av@(L l _) <- a + addAnnotation l b (gl s) + return av + +-- |Add a list of AddAnns to the given AST element +ams :: Located a -> [AddAnn] -> P (Located a) +ams a@(L l _) bs = mapM_ (\a -> a l) bs >> return a + + +-- |Add a list of AddAnns to the given AST element, where the AST element is the +-- result of a monadic action +amms :: P (Located a) -> [AddAnn] -> P (Located a) +amms a bs = do + av@(L l _) <- a + (mapM_ (\a -> a l) bs) >> return av + +-- |Add a list of AddAnns to the AST element, and return the element as a +-- OrdList +amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) +amsu a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return (unitOL a) + +-- |Synonyms for AddAnn versions of AnnOpen and AnnClose +mo,mc :: Located Token -> SrcSpan -> P () +mo ll = mj AnnOpen ll +mc ll = mj AnnClose ll + +moc,mcc :: Located Token -> SrcSpan -> P () +moc ll = mj AnnOpenC ll +mcc ll = mj AnnCloseC ll + +mop,mcp :: Located Token -> SrcSpan -> P () +mop ll = mj AnnOpenP ll +mcp ll = mj AnnCloseP ll + +mos,mcs :: Located Token -> SrcSpan -> P () +mos ll = mj AnnOpenS ll +mcs ll = mj AnnCloseS ll + +-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma +-- entry for each SrcSpan +mcommas :: [SrcSpan] -> [AddAnn] +mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss + +-- |Add the annotation to an AST element wrapped in a Just +ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan + -> P (Located (Maybe (Located a))) +ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a + +-- |Add all [AddAnn] to an AST element wrapped in a Just +aljs :: Located (Maybe (Located a)) -> [AddAnn] + -> P (Located (Maybe (Located a))) +aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a + +-- |Add all [AddAnn] to an AST element wrapped in a Just +ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a + +-- |Get the location of the last element of a OrdList, or noSrcSpan +oll :: OrdList (Located a) -> SrcSpan +oll l = + if isNilOL l then noSrcSpan + else getLoc (lastOL l) + +-- |Add a semicolon annotation in the right place in a list. If the +-- leading list is empty, add it to the tail +asl :: [Located a] -> Located b -> Located a -> P() +asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 8 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif +{-# LINE 46 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 67 "templates/GenericTemplate.hs" #-} + +{-# LINE 77 "templates/GenericTemplate.hs" #-} + +{-# LINE 86 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/compiler/parser/Parser.y.source b/compiler/parser/Parser.y.source new file mode 100644 index 00000000..861d5b98 --- /dev/null +++ b/compiler/parser/Parser.y.source @@ -0,0 +1,3196 @@ +-- -*-haskell-*- +-- --------------------------------------------------------------------------- +-- (c) The University of Glasgow 1997-2003 +--- +-- The GHC grammar. +-- +-- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 +-- --------------------------------------------------------------------------- + +{ +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location in +-- @ +module Parser (parseModule, parseImport, parseStatement, + parseDeclaration, parseExpression, parsePattern, + parseTypeSignature, + parseFullStmt, parseStmt, parseIdentifier, + parseType, parseHeader) where + +-- base +import Control.Monad ( unless, liftM ) +import GHC.Exts +import Data.Char +import Control.Monad ( mplus ) + +-- compiler/hsSyn +import HsSyn + +-- compiler/main +import HscTypes ( IsBootInterface, WarningTxt(..) ) +import DynFlags + +-- compiler/utils +import OrdList +import BooleanFormula ( BooleanFormula(..), mkTrue ) +import FastString +import Maybes ( orElse ) +import Outputable + +-- compiler/basicTypes +import RdrName +import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import DataCon ( DataCon, dataConName ) +import SrcLoc +import Module +import BasicTypes + +-- compiler/types +import Type ( funTyCon ) +import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) +import Class ( FunDep ) + +-- compiler/parser +import RdrHsSyn +import Lexer +import HaddockUtils +import ApiAnnotation + +-- compiler/typecheck +import TcEvidence ( emptyTcEvBinds ) + +-- compiler/prelude +import ForeignCall +import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) + +} + +{- +----------------------------------------------------------------------------- +14 Dec 2014 + +Conflicts: 48 shift/reduce + 1 reduce/reduce + +----------------------------------------------------------------------------- +20 Nov 2014 + +Conflicts: 60 shift/reduce + 12 reduce/reduce + +----------------------------------------------------------------------------- +25 June 2014 + +Conflicts: 47 shift/reduce + 1 reduce/reduce + +----------------------------------------------------------------------------- +12 October 2012 + +Conflicts: 43 shift/reduce + 1 reduce/reduce + +----------------------------------------------------------------------------- +24 February 2006 + +Conflicts: 33 shift/reduce + 1 reduce/reduce + +The reduce/reduce conflict is weird. It's between tyconsym and consym, and I +would think the two should never occur in the same context. + + -=chak + +----------------------------------------------------------------------------- +31 December 2006 + +Conflicts: 34 shift/reduce + 1 reduce/reduce + +The reduce/reduce conflict is weird. It's between tyconsym and consym, and I +would think the two should never occur in the same context. + + -=chak + +----------------------------------------------------------------------------- +6 December 2006 + +Conflicts: 32 shift/reduce + 1 reduce/reduce + +The reduce/reduce conflict is weird. It's between tyconsym and consym, and I +would think the two should never occur in the same context. + + -=chak + +----------------------------------------------------------------------------- +26 July 2006 + +Conflicts: 37 shift/reduce + 1 reduce/reduce + +The reduce/reduce conflict is weird. It's between tyconsym and consym, and I +would think the two should never occur in the same context. + + -=chak + +----------------------------------------------------------------------------- +Conflicts: 38 shift/reduce (1.25) + +10 for abiguity in 'if x then y else z + 1' [State 178] + (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) + 10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM + +1 for ambiguity in 'if x then y else z :: T' [State 178] + (shift parses as 'if x then y else (z :: T)', as per longest-parse rule) + +4 for ambiguity in 'if x then y else z -< e' [State 178] + (shift parses as 'if x then y else (z -< T)', as per longest-parse rule) + There are four such operators: -<, >-, -<<, >>- + + +2 for ambiguity in 'case v of { x :: T -> T ... } ' [States 11, 253] + Which of these two is intended? + case v of + (x::T) -> T -- Rhs is T + or + case v of + (x::T -> T) -> .. -- Rhs is ... + +10 for ambiguity in 'e :: a `b` c'. Does this mean [States 11, 253] + (e::a) `b` c, or + (e :: (a `b` c)) + As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases + Same duplication between states 11 and 253 as the previous case + +1 for ambiguity in 'let ?x ...' [State 329] + the parser can't tell whether the ?x is the lhs of a normal binding or + an implicit binding. Fortunately resolving as shift gives it the only + sensible meaning, namely the lhs of an implicit binding. + +1 for ambiguity in '{-# RULES "name" [ ... #-} [State 382] + we don't know whether the '[' starts the activation or not: it + might be the start of the declaration with the activation being + empty. --SDM 1/4/2002 + +1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 474] + since 'forall' is a valid variable name, we don't know whether + to treat a forall on the input as the beginning of a quantifier + or the beginning of the rule itself. Resolving to shift means + it's always treated as a quantifier, hence the above is disallowed. + This saves explicitly defining a grammar for the rule lhs that + doesn't include 'forall'. + +1 for ambiguity when the source file starts with "-- | doc". We need another + token of lookahead to determine if a top declaration or the 'module' keyword + follows. Shift parses as if the 'module' keyword follows. + +-- --------------------------------------------------------------------------- +-- Adding location info + +This is done using the three functions below, sL0, sL1 +and sLL. Note that these functions were mechanically +converted from the three macros that used to exist before, +namely L0, L1 and LL. + +They each add a SrcSpan to their argument. + + sL0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak + + sL1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + sLL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: sLL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +-- ----------------------------------------------------------------------------- +-- API Annotations + +A lot of the productions are now cluttered with calls to +aa,am,ams,amms etc. + +These are helper functions to make sure that the locations of the +various keywords such as do / let / in are captured for use by tools +that want to do source to source conversions, such as refactorers or +structured editors. + +The helper functions are defined at the bottom of this file. + +See + https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations and + https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations +for some background. + +-- ----------------------------------------------------------------------------- + +-} + +%token + '_' { L _ ITunderscore } -- Haskell keywords + 'as' { L _ ITas } + 'case' { L _ ITcase } + 'class' { L _ ITclass } + 'data' { L _ ITdata } + 'default' { L _ ITdefault } + 'deriving' { L _ ITderiving } + 'do' { L _ ITdo } + 'else' { L _ ITelse } + 'hiding' { L _ IThiding } + 'if' { L _ ITif } + 'import' { L _ ITimport } + 'in' { L _ ITin } + 'infix' { L _ ITinfix } + 'infixl' { L _ ITinfixl } + 'infixr' { L _ ITinfixr } + 'instance' { L _ ITinstance } + 'let' { L _ ITlet } + 'module' { L _ ITmodule } + 'newtype' { L _ ITnewtype } + 'of' { L _ ITof } + 'qualified' { L _ ITqualified } + 'then' { L _ ITthen } + 'type' { L _ ITtype } + 'where' { L _ ITwhere } + + 'forall' { L _ ITforall } -- GHC extension keywords + 'foreign' { L _ ITforeign } + 'export' { L _ ITexport } + 'label' { L _ ITlabel } + 'dynamic' { L _ ITdynamic } + 'safe' { L _ ITsafe } + 'interruptible' { L _ ITinterruptible } + 'unsafe' { L _ ITunsafe } + 'mdo' { L _ ITmdo } + 'family' { L _ ITfamily } + 'role' { L _ ITrole } + 'stdcall' { L _ ITstdcallconv } + 'ccall' { L _ ITccallconv } + 'capi' { L _ ITcapiconv } + 'prim' { L _ ITprimcallconv } + 'javascript' { L _ ITjavascriptcallconv } + 'proc' { L _ ITproc } -- for arrow notation extension + 'rec' { L _ ITrec } -- for arrow notation extension + 'group' { L _ ITgroup } -- for list transform extension + 'by' { L _ ITby } -- for list transform extension + 'using' { L _ ITusing } -- for list transform extension + 'pattern' { L _ ITpattern } -- for pattern synonyms + 'static' { L _ ITstatic } -- for static pointers extension + + '{-# INLINE' { L _ (ITinline_prag _ _ _) } + '{-# SPECIALISE' { L _ (ITspec_prag _) } + '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } + '{-# SOURCE' { L _ (ITsource_prag _) } + '{-# RULES' { L _ (ITrules_prag _) } + '{-# CORE' { L _ (ITcore_prag _) } -- hdaume: annotated core + '{-# SCC' { L _ (ITscc_prag _)} + '{-# GENERATED' { L _ (ITgenerated_prag _) } + '{-# DEPRECATED' { L _ (ITdeprecated_prag _) } + '{-# WARNING' { L _ (ITwarning_prag _) } + '{-# UNPACK' { L _ (ITunpack_prag _) } + '{-# NOUNPACK' { L _ (ITnounpack_prag _) } + '{-# ANN' { L _ (ITann_prag _) } + '{-# VECTORISE' { L _ (ITvect_prag _) } + '{-# VECTORISE_SCALAR' { L _ (ITvect_scalar_prag _) } + '{-# NOVECTORISE' { L _ (ITnovect_prag _) } + '{-# MINIMAL' { L _ (ITminimal_prag _) } + '{-# CTYPE' { L _ (ITctype _) } + '{-# OVERLAPPING' { L _ (IToverlapping_prag _) } + '{-# OVERLAPPABLE' { L _ (IToverlappable_prag _) } + '{-# OVERLAPS' { L _ (IToverlaps_prag _) } + '{-# INCOHERENT' { L _ (ITincoherent_prag _) } + '#-}' { L _ ITclose_prag } + + '..' { L _ ITdotdot } -- reserved symbols + ':' { L _ ITcolon } + '::' { L _ ITdcolon } + '=' { L _ ITequal } + '\\' { L _ ITlam } + 'lcase' { L _ ITlcase } + '|' { L _ ITvbar } + '<-' { L _ ITlarrow } + '->' { L _ ITrarrow } + '@' { L _ ITat } + '~' { L _ ITtilde } + '~#' { L _ ITtildehsh } + '=>' { L _ ITdarrow } + '-' { L _ ITminus } + '!' { L _ ITbang } + '*' { L _ ITstar } + '-<' { L _ ITlarrowtail } -- for arrow notation + '>-' { L _ ITrarrowtail } -- for arrow notation + '-<<' { L _ ITLarrowtail } -- for arrow notation + '>>-' { L _ ITRarrowtail } -- for arrow notation + '.' { L _ ITdot } + + '{' { L _ ITocurly } -- special symbols + '}' { L _ ITccurly } + vocurly { L _ ITvocurly } -- virtual open curly (from layout) + vccurly { L _ ITvccurly } -- virtual close curly (from layout) + '[' { L _ ITobrack } + ']' { L _ ITcbrack } + '[:' { L _ ITopabrack } + ':]' { L _ ITcpabrack } + '(' { L _ IToparen } + ')' { L _ ITcparen } + '(#' { L _ IToubxparen } + '#)' { L _ ITcubxparen } + '(|' { L _ IToparenbar } + '|)' { L _ ITcparenbar } + ';' { L _ ITsemi } + ',' { L _ ITcomma } + '`' { L _ ITbackquote } + SIMPLEQUOTE { L _ ITsimpleQuote } -- 'x + + VARID { L _ (ITvarid _) } -- identifiers + CONID { L _ (ITconid _) } + VARSYM { L _ (ITvarsym _) } + CONSYM { L _ (ITconsym _) } + QVARID { L _ (ITqvarid _) } + QCONID { L _ (ITqconid _) } + QVARSYM { L _ (ITqvarsym _) } + QCONSYM { L _ (ITqconsym _) } + PREFIXQVARSYM { L _ (ITprefixqvarsym _) } + PREFIXQCONSYM { L _ (ITprefixqconsym _) } + + IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension + + CHAR { L _ (ITchar _ _) } + STRING { L _ (ITstring _ _) } + INTEGER { L _ (ITinteger _ _) } + RATIONAL { L _ (ITrational _) } + + PRIMCHAR { L _ (ITprimchar _ _) } + PRIMSTRING { L _ (ITprimstring _ _) } + PRIMINTEGER { L _ (ITprimint _ _) } + PRIMWORD { L _ (ITprimword _ _) } + PRIMFLOAT { L _ (ITprimfloat _) } + PRIMDOUBLE { L _ (ITprimdouble _) } + + DOCNEXT { L _ (ITdocCommentNext _) } + DOCPREV { L _ (ITdocCommentPrev _) } + DOCNAMED { L _ (ITdocCommentNamed _) } + DOCSECTION { L _ (ITdocSection _ _) } + +-- Template Haskell +'[|' { L _ ITopenExpQuote } +'[p|' { L _ ITopenPatQuote } +'[t|' { L _ ITopenTypQuote } +'[d|' { L _ ITopenDecQuote } +'|]' { L _ ITcloseQuote } +'[||' { L _ ITopenTExpQuote } +'||]' { L _ ITcloseTExpQuote } +TH_ID_SPLICE { L _ (ITidEscape _) } -- $x +'$(' { L _ ITparenEscape } -- $( exp ) +TH_ID_TY_SPLICE { L _ (ITidTyEscape _) } -- $$x +'$$(' { L _ ITparenTyEscape } -- $$( exp ) +TH_TY_QUOTE { L _ ITtyQuote } -- ''T +TH_QUASIQUOTE { L _ (ITquasiQuote _) } +TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } + +%monad { P } { >>= } { return } +%lexer { (lexer True) } { L _ ITeof } +%tokentype { (Located Token) } + +-- Exported parsers +%name parseModule module +%name parseImport importdecl +%name parseStatement stmt +%name parseDeclaration topdecl +%name parseExpression exp +%name parsePattern pat +%name parseTypeSignature sigdecl +%name parseFullStmt stmt +%name parseStmt maybe_stmt +%name parseIdentifier identifier +%name parseType ctype +%partial parseHeader header +%% + +----------------------------------------------------------------------------- +-- Identifiers; one of the entry points +identifier :: { Located RdrName } + : qvar { $1 } + | qcon { $1 } + | qvarop { $1 } + | qconop { $1 } + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + [mj AnnOpenP $1,mj AnnRarrow $2,mj AnnCloseP $3] } + +----------------------------------------------------------------------------- +-- Module Header + +-- The place for module deprecation is really too restrictive, but if it +-- was allowed at its natural place just before 'module', we get an ugly +-- s/r conflict with the second alternative. Another solution would be the +-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, +-- either, and DEPRECATED is only expected to be used by people who really +-- know what they are doing. :-) + +module :: { Located (HsModule RdrName) } + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + (snd $ snd $7) $4 $1) + ) + ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } + | body2 + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule Nothing Nothing + (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) + (fst $1) } + +maybedocheader :: { Maybe LHsDocString } + : moduleheader { $1 } + | {- empty -} { Nothing } + +missing_module_keyword :: { () } + : {- empty -} {% pushCurrentContext } + +maybemodwarning :: { Maybe (Located WarningTxt) } + : '{-# DEPRECATED' strings '#-}' + {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))) + (mo $1:mc $3: (fst $ unLoc $2)) } + | '{-# WARNING' strings '#-}' + {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))) + (mo $1:mc $3 : (fst $ unLoc $2)) } + | {- empty -} { Nothing } + +body :: { ([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName])) } + : '{' top '}' { (moc $1:mcc $3:(fst $2) + , snd $2) } + | vocurly top close { (fst $2, snd $2) } + +body2 :: { ([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName])) } + : '{' top '}' { (moc $1:mcc $3 + :(fst $2), snd $2) } + | missing_module_keyword top close { ([],snd $2) } + +top :: { ([AddAnn] + ,([LImportDecl RdrName], [LHsDecl RdrName])) } + : importdecls { (fst $1 + ,(reverse $ snd $1,[]))} + | importdecls ';' cvtopdecls {% if null (snd $1) + then return ((mj AnnSemi $2:(fst $1)) + ,(reverse $ snd $1,$3)) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return (fst $1 + ,(reverse $ snd $1,$3)) }} + | cvtopdecls { ([],([],$1)) } + +cvtopdecls :: { [LHsDecl RdrName] } + : topdecls { cvTopDecls $1 } + +----------------------------------------------------------------------------- +-- Module declaration & imports only + +header :: { Located (HsModule RdrName) } + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + )) [mj AnnModule $2,mj AnnWhere $6] } + | header_body2 + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule Nothing Nothing $1 [] Nothing + Nothing)) } + +header_body :: { [LImportDecl RdrName] } + : '{' importdecls { snd $2 } + | vocurly importdecls { snd $2 } + +header_body2 :: { [LImportDecl RdrName] } + : '{' importdecls { snd $2 } + | missing_module_keyword importdecls { snd $2 } + +----------------------------------------------------------------------------- +-- The Export List + +maybeexports :: { (Maybe (Located [LIE RdrName])) } + : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> + return (Just (sLL $1 $> (fromOL $2))) } + | {- empty -} { Nothing } + +exportlist :: { OrdList (LIE RdrName) } + : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2) + >> return ($1 `appOL` $3) } + | exportlist1 { $1 } + +exportlist1 :: { OrdList (LIE RdrName) } + : expdoclist export expdoclist ',' exportlist1 + {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3)) + AnnComma (gl $4) ) >> + return ($1 `appOL` $2 `appOL` $3 `appOL` $5) } + | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } + | expdoclist { $1 } + +expdoclist :: { OrdList (LIE RdrName) } + : exp_doc expdoclist { $1 `appOL` $2 } + | {- empty -} { nilOL } + +exp_doc :: { OrdList (LIE RdrName) } + : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } + | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) } + | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) } + + + -- No longer allow things like [] and (,,,) to be exported + -- They are built in syntax, always available +export :: { OrdList (LIE RdrName) } + : qcname_ext export_subspec {% amsu (sLL $1 $> (mkModuleImpExp $1 + (snd $ unLoc $2))) + (fst $ unLoc $2) } + | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) + [mj AnnModule $1] } + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar $2)) + [mj AnnPattern $1] } + +export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } + : {- empty -} { sL0 ([],ImpExpAbs) } + | '(' '..' ')' { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2] + , ImpExpAll) } + | '(' ')' { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) } + | '(' qcnames ')' { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) } + +qcnames :: { [Located RdrName] } -- A reversed list + : qcnames ',' qcname_ext {% (aa (head $1) (AnnComma, $2)) >> + return ($3 : $1) } + | qcname_ext { [$1] } + +qcname_ext :: { Located RdrName } -- Variable or data constructor + -- or tagged type constructor + : qcname { $1 } + | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) + [mj AnnType $1,mj AnnVal $2] } + +-- Cannot pull into qcname_ext, as qcname is also used in expression. +qcname :: { Located RdrName } -- Variable or data constructor + : qvar { $1 } + | qcon { $1 } + +----------------------------------------------------------------------------- +-- Import Declarations + +-- import decls can be *empty*, or even just a string of semicolons +-- whereas topdecls must contain at least one topdecl. + +importdecls :: { ([AddAnn],[LImportDecl RdrName]) } + : importdecls ';' importdecl + {% if null (snd $1) + then return (mj AnnSemi $2:fst $1,$3 : snd $1) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return (fst $1,$3 : snd $1) } } + | importdecls ';' {% if null (snd $1) + then return ((mj AnnSemi $2:fst $1),snd $1) + else do + { addAnnotation (gl $ head $ snd $1) + AnnSemi (gl $2) + ; return $1} } + | importdecl { ([],[$1]) } + | {- empty -} { ([],[]) } + +importdecl :: { LImportDecl RdrName } + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + {% ams (L (comb4 $1 $6 (snd $7) $8) $ + ImportDecl { ideclSourceSrc = snd $ fst $2 + , ideclName = $6, ideclPkgQual = snd $5 + , ideclSource = snd $2, ideclSafe = snd $3 + , ideclQualified = snd $4, ideclImplicit = False + , ideclAs = unLoc (snd $7) + , ideclHiding = unLoc $8 }) + ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4 + ++ fst $5 ++ fst $7)) } + +maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1)) + ,True) } + | {- empty -} { (([],Nothing),False) } + +maybe_safe :: { ([AddAnn],Bool) } + : 'safe' { ([mj AnnSafe $1],True) } + | {- empty -} { ([],False) } + +maybe_pkg :: { ([AddAnn],Maybe FastString) } + : STRING { ([mj AnnPackageName $1] + ,Just (getSTRING $1)) } + | {- empty -} { ([],Nothing) } + +optqualified :: { ([AddAnn],Bool) } + : 'qualified' { ([mj AnnQualified $1],True) } + | {- empty -} { ([],False) } + +maybeas :: { ([AddAnn],Located (Maybe ModuleName)) } + : 'as' modid { ([mj AnnAs $1,mj AnnVal $2] + ,sLL $1 $> (Just (unLoc $2))) } + | {- empty -} { ([],noLoc Nothing) } + +maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } + : impspec { L (gl $1) (Just (unLoc $1)) } + | {- empty -} { noLoc Nothing } + +impspec :: { Located (Bool, Located [LIE RdrName]) } + : '(' exportlist ')' {% ams (sLL $1 $> (False, + sLL $1 $> $ fromOL $2)) + [mop $1,mcp $3] } + | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, + sLL $1 $> $ fromOL $3)) + [mj AnnHiding $1,mop $2,mcp $4] } + +----------------------------------------------------------------------------- +-- Fixity Declarations + +prec :: { Located Int } + : {- empty -} { noLoc 9 } + | INTEGER + {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) } + +infix :: { Located FixityDirection } + : 'infix' { sL1 $1 InfixN } + | 'infixl' { sL1 $1 InfixL } + | 'infixr' { sL1 $1 InfixR } + +ops :: { Located (OrdList (Located RdrName)) } + : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} + | op { sL1 $1 (unitOL $1) } + +----------------------------------------------------------------------------- +-- Top-Level Declarations + +topdecls :: { OrdList (LHsDecl RdrName) } + : topdecls ';' topdecl {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `appOL` $3) } + | topdecls ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | topdecl { $1 } + +topdecl :: { OrdList (LHsDecl RdrName) } + : cl_decl { unitOL (sL1 $1 (TyClD (unLoc $1))) } + | ty_decl { unitOL (sL1 $1 (TyClD (unLoc $1))) } + | inst_decl { unitOL (sL1 $1 (InstD (unLoc $1))) } + | stand_alone_deriving { unitOL (sLL $1 $> (DerivD (unLoc $1))) } + | role_annot { unitOL (sL1 $1 (RoleAnnotD (unLoc $1))) } + | 'default' '(' comma_types0 ')' {% do { def <- checkValidDefaults $3 + ; amsu (sLL $1 $> (DefD def)) + [mj AnnDefault $1 + ,mop $2,mcp $4] }} + | 'foreign' fdecl {% amsu (sLL $1 $> (snd $ unLoc $2)) + (mj AnnForeign $1:(fst $ unLoc $2)) } + | '{-# DEPRECATED' deprecations '#-}' {% amsu (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# WARNING' warnings '#-}' {% amsu (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# RULES' rules '#-}' {% amsu (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2))) + [mo $1,mc $3] } + | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4)) + [mo $1,mj AnnEqual $3 + ,mc $5] } + | '{-# NOVECTORISE' qvar '#-}' {% amsu (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2)) + [mo $1,mc $3] } + | '{-# VECTORISE' 'type' gtycon '#-}' + {% amsu (sLL $1 $> $ + VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing)) + [mo $1,mj AnnType $2,mc $4] } + + | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' + {% amsu (sLL $1 $> $ + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing)) + [mo $1,mj AnnType $2,mc $4] } + + | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' + {% amsu (sLL $1 $> $ + VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5))) + [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } + | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' + {% amsu (sLL $1 $> $ + VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5))) + [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } + + | '{-# VECTORISE' 'class' gtycon '#-}' + {% amsu (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3)) + [mo $1,mj AnnClass $2,mc $4] } + | annotation { unitOL $1 } + | decl_no_th { unLoc $1 } + + -- Template Haskell Extension + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp { unitOL (sLL $1 $> $ mkSpliceDecl $1) } + +-- Type classes +-- +cl_decl :: { LTyClDecl RdrName } + : 'class' tycl_hdr fds where_cls + {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) + (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } + +-- Type declarations (toplevel) +-- +ty_decl :: { LTyClDecl RdrName } + -- ordinary type synonyms + : 'type' type '=' ctypedoc + -- Note ctype, not sigtype, on the right of '=' + -- We allow an explicit for-all but we don't insert one + -- in type Foo a = (b,b) + -- Instead we just say b is out of scope + -- + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + {% amms (mkTySynonym (comb2 $1 $4) $2 $4) + [mj AnnType $1,mj AnnEqual $3] } + + -- type family declarations + | 'type' 'family' type opt_kind_sig where_type_family + -- Note the use of type for the head; this allows + -- infix type constructors to be declared + {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $5) $3 + (snd $ unLoc $4)) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)++(fst $ unLoc $5)) } + + -- ordinary data type or newtype declaration + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + Nothing (reverse (snd $ unLoc $4)) + (unLoc $5)) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc $1):(fst $ unLoc $4)) } + + -- ordinary GADT declaration + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + gadt_constrlist + deriving + {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 + (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6) ) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } + + -- data/newtype family + | 'data' 'family' type opt_kind_sig + {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (snd $ unLoc $4)) + (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } + +inst_decl :: { LInstDecl RdrName } + : 'instance' overlap_pragma inst_type where_inst + {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) + ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = $2 + , cid_datafam_insts = adts } + ; let err = text "In instance head:" <+> ppr $3 + ; checkNoPartialType err $3 + ; sequence_ [ checkNoPartialType err ty + | sig@(L _ (TypeSig _ ty _ )) <- sigs + , let err = text "in instance signature" <> colon + <+> quotes (ppr sig) ] + ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid })) + (mj AnnInstance $1 : (fst $ unLoc $4)) } } + + -- type instance declarations + | 'type' 'instance' ty_fam_inst_eqn + {% ams $3 (fst $ unLoc $3) + >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + + -- data/newtype instance declaration + | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving + {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4 + Nothing (reverse (snd $ unLoc $5)) + (unLoc $6)) + ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) } + + -- GADT instance declaration + | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig + gadt_constrlist + deriving + {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4 + (snd $ unLoc $5) (snd $ unLoc $6) (unLoc $7)) + ((fst $ unLoc $1):mj AnnInstance $2 + :(fst $ unLoc $5)++(fst $ unLoc $6)) } + +overlap_pragma :: { Maybe (Located OverlapMode) } + : '{-# OVERLAPPABLE' '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))) + [mo $1,mc $2] } + | '{-# OVERLAPPING' '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))) + [mo $1,mc $2] } + | '{-# OVERLAPS' '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))) + [mo $1,mc $2] } + | '{-# INCOHERENT' '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))) + [mo $1,mc $2] } + | {- empty -} { Nothing } + + +-- Closed type families + +where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } + : {- empty -} { noLoc ([],OpenTypeFamily) } + | 'where' ty_fam_inst_eqn_list + { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) + ,ClosedTypeFamily (reverse (snd $ unLoc $2))) } + +ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) } + : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] + ,unLoc $2) } + | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in + L loc ([],unLoc $2) } + | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 + ,mcc $3],[]) } + | vocurly '..' close { let L loc _ = $2 in + L loc ([mj AnnDotdot $2],[]) } + +ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } + : ty_fam_inst_eqns ';' ty_fam_inst_eqn + {% asl (unLoc $1) $2 (snd $ unLoc $3) + >> ams $3 (fst $ unLoc $3) + >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) } + | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) + >> return (sLL $1 $> (unLoc $1)) } + | ty_fam_inst_eqn {% ams $1 (fst $ unLoc $1) + >> return (sLL $1 $> [snd $ unLoc $1]) } + +ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } + : type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3 + ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } } + +-- Associated type family declarations +-- +-- * They have a different syntax than on the toplevel (no family special +-- identifier). +-- +-- * They also need to be separate from instances; otherwise, data family +-- declarations without a kind signature cause parsing conflicts with empty +-- data declarations. +-- +at_decl_cls :: { LHsDecl RdrName } + : -- data family declarations, with optional 'family' keyword + 'data' opt_family type opt_kind_sig + {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 + (snd $ unLoc $4))) + (mj AnnData $1:$2++(fst $ unLoc $4)) } + + -- type family declarations, with optional 'family' keyword + -- (can't use opt_instance because you get shift/reduce errors + | 'type' type opt_kind_sig + {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3) + OpenTypeFamily $2 (snd $ unLoc $3))) + (mj AnnType $1:(fst $ unLoc $3)) } + | 'type' 'family' type opt_kind_sig + {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) + OpenTypeFamily $3 (snd $ unLoc $4))) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } + + -- default type instances, with optional 'instance' keyword + | 'type' ty_fam_inst_eqn + {% ams $2 (fst $ unLoc $2) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) + (mj AnnType $1:(fst $ unLoc $2)) } + | 'type' 'instance' ty_fam_inst_eqn + {% ams $3 (fst $ unLoc $3) >> + amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) + (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + +opt_family :: { [AddAnn] } + : {- empty -} { [] } + | 'family' { [mj AnnFamily $1] } + +-- Associated type instances +-- +at_decl_inst :: { LInstDecl RdrName } + -- type instance declarations + : 'type' ty_fam_inst_eqn + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% ams $2 (fst $ unLoc $2) >> + amms (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)) + (mj AnnType $1:(fst $ unLoc $2)) } + + -- data/newtype instance declaration + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + Nothing (reverse (snd $ unLoc $4)) + (unLoc $5)) + ((fst $ unLoc $1):(fst $ unLoc $4)) } + + -- GADT instance declaration + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + gadt_constrlist + deriving + {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 + $3 (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6)) + ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } + +data_or_newtype :: { Located (AddAnn,NewOrData) } + : 'data' { sL1 $1 (mj AnnData $1,DataType) } + | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } + +opt_kind_sig :: { Located ([AddAnn],Maybe (LHsKind RdrName)) } + : { noLoc ([],Nothing) } + | '::' kind { sLL $1 $> ([mj AnnDcolon $1],Just ($2)) } + +-- tycl_hdr parses the header of a class or data type decl, +-- which takes the form +-- T a b +-- Eq a => T a +-- (Eq a, Ord b) => T a b +-- T Int [a] -- for associated types +-- Rather a lot of inlining here, else we get reduce/reduce errors +tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } + : context '=>' type {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> (return (sLL $1 $> (Just $1, $3))) + } + | type { sL1 $1 (Nothing, $1) } + +capi_ctype :: { Maybe (Located CType) } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' + {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2))) + (getSTRING $3)))) + [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } + + | '{-# CTYPE' STRING '#-}' + {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRING $2)))) + [mo $1,mj AnnVal $2,mc $3] } + + | { Nothing } + +----------------------------------------------------------------------------- +-- Stand-alone deriving + +-- Glasgow extension: stand-alone deriving declarations +stand_alone_deriving :: { LDerivDecl RdrName } + : 'deriving' 'instance' overlap_pragma inst_type + {% do { + let err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr $4) + ; checkNoPartialType err $4 + ; ams (sLL $1 $> (DerivDecl $4 $3)) + [mj AnnDeriving $1,mj AnnInstance $2] }} + +----------------------------------------------------------------------------- +-- Role annotations + +role_annot :: { LRoleAnnotDecl RdrName } +role_annot : 'type' 'role' oqtycon maybe_roles + {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) + [mj AnnType $1,mj AnnRole $2] } + +-- Reversed! +maybe_roles :: { Located [Located (Maybe FastString)] } +maybe_roles : {- empty -} { noLoc [] } + | roles { $1 } + +roles :: { Located [Located (Maybe FastString)] } +roles : role { sLL $1 $> [$1] } + | roles role { sLL $1 $> $ $2 : unLoc $1 } + +-- read it in as a varid for better error messages +role :: { Located (Maybe FastString) } +role : VARID { sL1 $1 $ Just $ getVARID $1 } + | '_' { sL1 $1 Nothing } + +-- Pattern synonyms + +-- Glasgow extension: pattern synonyms +pattern_synonym_decl :: { LHsDecl RdrName } + : 'pattern' pattern_synonym_lhs '=' pat + {%ams ( let (name, args) = $2 + in sLL $1 $> . ValD $ mkPatSynBind name args $4 + ImplicitBidirectional) + [mj AnnPattern $1,mj AnnEqual $3] + } + | 'pattern' pattern_synonym_lhs '<-' pat + {%ams (let (name, args) = $2 + in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) + [mj AnnPattern $1,mj AnnLarrow $3] } + | 'pattern' pattern_synonym_lhs '<-' pat where_decls + {% do { let (name, args) = $2 + ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) + ; ams (sLL $1 $> . ValD $ + mkPatSynBind name args $4 (ExplicitBidirectional mg)) + (mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5)) + }} + +pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) } + : con vars0 { ($1, PrefixPatSyn $2) } + | varid conop varid { ($2, InfixPatSyn $1 $3) } + +vars0 :: { [Located RdrName] } + : {- empty -} { [] } + | varid vars0 { $1 : $2 } + +where_decls :: { Located ([AddAnn] + , Located (OrdList (LHsDecl RdrName))) } + : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 + :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } + | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + ,sL1 $3 (snd $ unLoc $3)) } +pattern_synonym_sig :: { LSig RdrName } + : 'pattern' con '::' ptype + {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4 + ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty + ; checkValidPatSynSig sig + ; ams (sLL $1 $> $ sig) + (mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } } + +ptype :: { Located ([AddAnn] + ,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName + , LHsContext RdrName, LHsType RdrName)) } + : 'forall' tv_bndrs '.' ptype + {% do { hintExplicitForall (getLoc $1) + ; let (_, qtvs', prov, req, ty) = snd $ unLoc $4 + ; return $ sLL $1 $> + ((mj AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) + ,(Explicit, $2 ++ qtvs', prov, req ,ty)) }} + | context '=>' context '=>' type + { sLL $1 $> ([mj AnnDarrow $2,mj AnnDarrow $4] + ,(Implicit, [], $1, $3, $5)) } + | context '=>' type + { sLL $1 $> ([mj AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) } + | type + { sL1 $1 ([],(Implicit, [], noLoc [], noLoc [], $1)) } + +----------------------------------------------------------------------------- +-- Nested declarations + +-- Declaration in class bodies +-- +decl_cls :: { Located (OrdList (LHsDecl RdrName)) } +decl_cls : at_decl_cls { sLL $1 $> (unitOL $1) } + | decl { $1 } + + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtypedoc + {% do { (TypeSig l ty _) <- checkValSig $2 $4 + ; let err = text "in default signature" <> colon <+> + quotes (ppr ty) + ; checkNoPartialType err ty + ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty))) + [mj AnnDefault $1,mj AnnDcolon $3] } } + +decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed + : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] + >> return (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unLoc $3)) } + | decls_cls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl_cls { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist_cls + :: { Located ([AddAnn] + , OrdList (LHsDecl RdrName)) } -- Reversed + : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,snd $ unLoc $2) } + | vocurly decls_cls close { $2 } + +-- Class body +-- +where_cls :: { Located ([AddAnn] + ,(OrdList (LHsDecl RdrName))) } -- Reversed + -- No implicit parameters + -- May have type declarations + : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) + ,snd $ unLoc $2) } + | {- empty -} { noLoc ([],nilOL) } + +-- Declarations in instance bodies +-- +decl_inst :: { Located (OrdList (LHsDecl RdrName)) } +decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } + | decl { $1 } + +decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed + : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return + (sLL $1 $> (fst $ unLoc $1 + ,(snd $ unLoc $1) `appOL` unLoc $3)) } + | decls_inst ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl_inst { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist_inst + :: { Located ([AddAnn] + , OrdList (LHsDecl RdrName)) } -- Reversed + : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } + | vocurly decls_inst close { L (gl $2) (unLoc $2) } + +-- Instance body +-- +where_inst :: { Located ([AddAnn] + , OrdList (LHsDecl RdrName)) } -- Reversed + -- No implicit parameters + -- May have type declarations + : 'where' decllist_inst { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) + ,(snd $ unLoc $2)) } + | {- empty -} { noLoc ([],nilOL) } + +-- Declarations in binding groups other than classes and instances +-- +decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } + : decls ';' decl {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + , unLoc $3)) + else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return ( + let { this = unLoc $3; + rest = snd $ unLoc $1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + (sLL $1 $> (fst $ unLoc $1,these))) } + | decls ';' {% if isNilOL (snd $ unLoc $1) + then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1))) + else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] + >> return (sLL $1 $> (unLoc $1)) } + | decl { sL1 $1 ([],unLoc $1) } + | {- empty -} { noLoc ([],nilOL) } + +decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } + : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) + ,snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,snd $ unLoc $2) } + +-- Binding groups other than those of class and instance declarations +-- +binds :: { Located ([AddAnn],HsLocalBinds RdrName) } + -- May have implicit parameters + -- No type declarations + : decllist {% do { val_binds <- cvBindGroup (snd $ unLoc $1) + ; return (sL1 $1 (fst $ unLoc $1 + ,HsValBinds val_binds)) } } + + | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] + ,HsIPBinds (IPBinds (unLoc $2) + emptyTcEvBinds)) } + + | vocurly dbinds close { L (getLoc $2) ([] + ,HsIPBinds (IPBinds (unLoc $2) + emptyTcEvBinds)) } + + +wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) } + -- May have implicit parameters + -- No type declarations + : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) + ,snd $ unLoc $2) } + | {- empty -} { noLoc ([],emptyLocalBinds) } + + +----------------------------------------------------------------------------- +-- Transformation Rules + +rules :: { OrdList (LRuleDecl RdrName) } + : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `snocOL` $3) } + | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | rule { unitOL $1 } + | {- empty -} { nilOL } + +rule :: { LRuleDecl RdrName } + : STRING rule_activation rule_forall infixexp '=' exp + {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRING $1)) + ((snd $2) `orElse` AlwaysActive) + (snd $3) $4 placeHolderNames $6 + placeHolderNames)) + (mj AnnEqual $5 : (fst $2) ++ (fst $3)) } + +-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas +rule_activation :: { ([AddAnn],Maybe Activation) } + : {- empty -} { ([],Nothing) } + | rule_explicit_activation { (fst $1,Just (snd $1)) } + +rule_explicit_activation :: { ([AddAnn] + ,Activation) } -- In brackets + : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] + ,ActiveAfter (fromInteger (getINTEGER $2))) } + | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] + ,ActiveBefore (fromInteger (getINTEGER $3))) } + | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] + ,NeverActive) } + +rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) } + : 'forall' rule_var_list '.' { ([mj AnnForall $1,mj AnnDot $3],$2) } + | {- empty -} { ([],[]) } + +rule_var_list :: { [LRuleBndr RdrName] } + : rule_var { [$1] } + | rule_var rule_var_list { $1 : $2 } + +rule_var :: { LRuleBndr RdrName } + : varid { sLL $1 $> (RuleBndr $1) } + | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 + (mkHsWithBndrs $4))) + [mop $1,mj AnnDcolon $3,mcp $5] } + +----------------------------------------------------------------------------- +-- Warnings and deprecations (c.f. rules) + +warnings :: { OrdList (LWarnDecl RdrName) } + : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `appOL` $3) } + | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | warning { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +warning :: { OrdList (LWarnDecl RdrName) } + : namelist strings + {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2))) + (fst $ unLoc $2) } + +deprecations :: { OrdList (LWarnDecl RdrName) } + : deprecations ';' deprecation + {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return ($1 `appOL` $3) } + | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2) + >> return $1 } + | deprecation { $1 } + | {- empty -} { nilOL } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +deprecation :: { OrdList (LWarnDecl RdrName) } + : namelist strings + {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2))) + (fst $ unLoc $2) } + +strings :: { Located ([AddAnn],[Located FastString]) } + : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } + | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } + +stringlist :: { Located (OrdList (Located FastString)) } + : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> (unLoc $1 `snocOL` + (L (gl $3) (getSTRING $3)))) } + | STRING { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) } + +----------------------------------------------------------------------------- +-- Annotations +annotation :: { LHsDecl RdrName } + : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + (getANN_PRAGs $1) + (ValueAnnProvenance $2) $3)) + [mo $1,mc $4] } + + | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + (getANN_PRAGs $1) + (TypeAnnProvenance $3) $4)) + [mo $1,mj AnnType $2,mc $5] } + + | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + (getANN_PRAGs $1) + ModuleAnnProvenance $3)) + [mo $1,mj AnnModule $2,mc $4] } + + +----------------------------------------------------------------------------- +-- Foreign import and export declarations + +fdecl :: { Located ([AddAnn],HsDecl RdrName) } +fdecl : 'import' callconv safety fspec + {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } + | 'import' callconv fspec + {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3); + return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }} + | 'export' callconv fspec + {% mkExport $2 (snd $ unLoc $3) >>= \i -> + return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) } + +callconv :: { Located CCallConv } + : 'stdcall' { sLL $1 $> StdCallConv } + | 'ccall' { sLL $1 $> CCallConv } + | 'capi' { sLL $1 $> CApiConv } + | 'prim' { sLL $1 $> PrimCallConv} + | 'javascript' { sLL $1 $> JavaScriptCallConv } + +safety :: { Located Safety } + : 'unsafe' { sLL $1 $> PlayRisky } + | 'safe' { sLL $1 $> PlaySafe } + | 'interruptible' { sLL $1 $> PlayInterruptible } + +fspec :: { Located ([AddAnn] + ,(Located FastString, Located RdrName, LHsType RdrName)) } + : STRING var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $3] + ,(L (getLoc $1) + (getSTRING $1), $2, $4)) } + | var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $2] + ,(noLoc nilFS, $1, $3)) } + -- if the entity string is missing, it defaults to the empty string; + -- the meaning of an empty entity string depends on the calling + -- convention + +----------------------------------------------------------------------------- +-- Type signatures + +opt_sig :: { ([AddAnn],Maybe (LHsType RdrName)) } + : {- empty -} { ([],Nothing) } + | '::' sigtype { ([mj AnnDcolon $1],Just $2) } + +opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } + : {- empty -} { ([],Nothing) } + | '::' atype { ([mj AnnDcolon $1],Just $2) } + +sigtype :: { LHsType RdrName } -- Always a HsForAllTy, + -- to tell the renamer where to generalise + : ctype { sL1 $1 (mkImplicitHsForAllTy $1) } + -- Wrap an Implicit forall if there isn't one there already + +sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy + : ctypedoc { sL1 $1 (mkImplicitHsForAllTy $1) } + -- Wrap an Implicit forall if there isn't one there already + +sig_vars :: { Located [Located RdrName] } -- Returned in reversed order + : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) + AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | var { sL1 $1 [$1] } + +sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys + : sigtype { unitOL $1 } + | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return ((unitOL $1) `appOL` $3) } + +----------------------------------------------------------------------------- +-- Types + +strict_mark :: { Located ([AddAnn],HsBang) } + : '!' { sL1 $1 ([mj AnnBang $1] + ,HsSrcBang Nothing Nothing True) } + | '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2] + ,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) False) } + | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) False) } + | '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3] + ,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) True) } + | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3] + ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) True) } + -- Although UNPACK with no '!' is illegal, we get a + -- better error message if we parse it here + +-- A ctype is a for-all type +ctype :: { LHsType RdrName } + : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> + ams (sLL $1 $> $ mkExplicitHsForAllTy $2 + (noLoc []) $4) + [mj AnnForall $1,mj AnnDot $3] } + | context '=>' ctype {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> return (sLL $1 $> $ + mkQualifiedHsForAllTy $1 $3) } + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) + [mj AnnVal $1,mj AnnDcolon $2] } + | type { $1 } + +---------------------- +-- Notes for 'ctypedoc' +-- It would have been nice to simplify the grammar by unifying `ctype` and +-- ctypedoc` into one production, allowing comments on types everywhere (and +-- rejecting them after parsing, where necessary). This is however not possible +-- since it leads to ambiguity. The reason is the support for comments on record +-- fields: +-- data R = R { field :: Int -- ^ comment on the field } +-- If we allow comments on types here, it's not clear if the comment applies +-- to 'field' or to 'Int'. So we must use `ctype` to describe the type. + +ctypedoc :: { LHsType RdrName } + : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> + ams (sLL $1 $> $ mkExplicitHsForAllTy $2 + (noLoc []) $4) + [mj AnnForall $1,mj AnnDot $3] } + | context '=>' ctypedoc {% addAnnotation (gl $1) AnnDarrow (gl $2) + >> return (sLL $1 $> $ + mkQualifiedHsForAllTy $1 $3) } + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) + [mj AnnVal $1,mj AnnDcolon $2] } + | typedoc { $1 } + +---------------------- +-- Notes for 'context' +-- We parse a context as a btype so that we don't get reduce/reduce +-- errors in ctype. The basic problem is that +-- (Eq a, Ord a) +-- looks so much like a tuple type. We can't tell until we find the => + +-- We have the t1 ~ t2 form both in 'context' and in type, +-- to permit an individual equational constraint without parenthesis. +-- Thus for some reason we allow f :: a~b => blah +-- but not f :: ?x::Int => blah +context :: { LHsContext RdrName } + : btype '~' btype {% do { (anns,ctx) <- checkContext + (sLL $1 $> $ HsEqTy $1 $3) + ; ams ctx (mj AnnTilde $2:anns) } } + | btype {% do { (anns,ctx) <- checkContext $1 + ; if null (unLoc ctx) + then addAnnotation (gl $1) AnnUnit (gl $1) + else return () + ; ams ctx anns + } } + +type :: { LHsType RdrName } + : btype { $1 } + | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } + | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } + | btype '->' ctype {% ams $1 [mj AnnRarrow $2] + >> ams (sLL $1 $> $ HsFunTy $1 $3) + [mj AnnRarrow $2] } + | btype '~' btype {% ams (sLL $1 $> $ HsEqTy $1 $3) + [mj AnnTilde $2] } + -- see Note [Promotion] + | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) + [mj AnnSimpleQuote $2] } + | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) + [mj AnnSimpleQuote $2] } + +typedoc :: { LHsType RdrName } + : btype { $1 } + | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } + | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } + | btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } + | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } + | btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } + | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) + [mj AnnRarrow $2] } + | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2) + (HsDocTy $1 $2)) $4) + [mj AnnRarrow $3] } + | btype '~' btype {% ams (sLL $1 $> $ HsEqTy $1 $3) + [mj AnnTilde $2] } + -- see Note [Promotion] + | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) + [mj AnnSimpleQuote $2] } + | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) + [mj AnnSimpleQuote $2] } + +btype :: { LHsType RdrName } + : btype atype { sLL $1 $> $ HsAppTy $1 $2 } + | atype { $1 } + +atype :: { LHsType RdrName } + : ntgtycon { sL1 $1 (HsTyVar (unLoc $1)) } -- Not including unit tuples + | tyvar {% do { nwc <- namedWildcardsEnabled -- (See Note [Unit tuples]) + ; let tv@(Unqual name) = unLoc $1 + ; return $ if (startsWithUnderscore name && nwc) + then (sL1 $1 (HsNamedWildcardTy tv)) + else (sL1 $1 (HsTyVar tv)) } } + + | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) + (fst $ unLoc $1) } -- Constructor sigs only + | '{' fielddecls '}' {% amms (checkRecordSyntax + (sLL $1 $> $ HsRecTy $2)) + -- Constructor sigs only + [moc $1,mcc $3] } + | '(' ')' {% ams (sLL $1 $> $ HsTupleTy + HsBoxedOrConstraintTuple []) + [mop $1,mcp $2] } + | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsTupleTy + HsBoxedOrConstraintTuple ($2 : $4)) + [mop $1,mcp $5] } + | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) + [mo $1,mc $2] } + | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) + [mo $1,mc $3] } + | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } + | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } + | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } + | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) + [mop $1,mj AnnDcolon $3,mcp $5] } + | quasiquote { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) } + | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2) + [mj AnnOpenPE $1,mj AnnCloseP $3] } + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1)) + [mj AnnThIdSplice $1] } + -- see Note [Promotion] for the followings + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' + {% addAnnotation (gl $3) AnnComma (gl $4) >> + ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) + [mj AnnSimpleQuote $1,mop $2,mcp $6] } + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy + placeHolderKind $3) + [mj AnnSimpleQuote $1,mos $2,mcs $4] } + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) + [mj AnnSimpleQuote $1,mj AnnName $2] } + + -- Two or more [ty, ty, ty] must be a promoted list type, just as + -- if you had written '[ty, ty, ty] + -- (One means a list type, zero means the list type constructor, + -- so you have to quote those.) + | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma + (gl $3) >> + ams (sLL $1 $> $ HsExplicitListTy + placeHolderKind ($2 : $4)) + [mos $1,mcs $5] } + | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) + (getINTEGER $1) } + | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } + | '_' { sL1 $1 $ HsWildcardTy } + +-- An inst_type is what occurs in the head of an instance decl +-- e.g. (Foo a, Gaz b) => Wibble a b +-- It's kept as a single type, with a MonoDictTy at the right +-- hand corner, for convenience. +inst_type :: { LHsType RdrName } + : sigtype { $1 } + +inst_types1 :: { [LHsType RdrName] } + : inst_type { [$1] } + + | inst_type ',' inst_types1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return ($1 : $3) } + +comma_types0 :: { [LHsType RdrName] } -- Zero or more: ty,ty,ty + : comma_types1 { $1 } + | {- empty -} { [] } + +comma_types1 :: { [LHsType RdrName] } -- One or more: ty,ty,ty + : ctype { [$1] } + | ctype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return ($1 : $3) } + +tv_bndrs :: { [LHsTyVarBndr RdrName] } + : tv_bndr tv_bndrs { $1 : $2 } + | {- empty -} { [] } + +tv_bndr :: { LHsTyVarBndr RdrName } + : tyvar { sL1 $1 (UserTyVar (unLoc $1)) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) + [mop $1,mj AnnDcolon $3 + ,mcp $5] } + +fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } + : {- empty -} { noLoc ([],[]) } + | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] + ,reverse (unLoc $2))) } + +fds1 :: { Located [Located (FunDep (Located RdrName))] } + : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } + | fd { sL1 $1 [$1] } + +fd :: { Located (FunDep (Located RdrName)) } + : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) + (reverse (unLoc $1), reverse (unLoc $3))) + [mj AnnRarrow $2] } + +varids0 :: { Located [Located RdrName] } + : {- empty -} { noLoc [] } + | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } + +----------------------------------------------------------------------------- +-- Kinds + +kind :: { LHsKind RdrName } + : bkind { $1 } + | bkind '->' kind {% ams (sLL $1 $> $ HsFunTy $1 $3) + [mj AnnRarrow $2] } + +bkind :: { LHsKind RdrName } + : akind { $1 } + | bkind akind { sLL $1 $> $ HsAppTy $1 $2 } + +akind :: { LHsKind RdrName } + : '*' { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } + | '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2) + [mop $1,mcp $3] } + | pkind { $1 } + | tyvar { sL1 $1 $ HsTyVar (unLoc $1) } + +pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] + : qtycon { sL1 $1 $ HsTyVar $ unLoc $1 } + | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ getRdrName unitTyCon) + [mop $1,mcp $2] } + | '(' kind ',' comma_kinds1 ')' + {% addAnnotation (gl $2) AnnComma (gl $3) >> + ams (sLL $1 $> $ HsTupleTy HsBoxedTuple ( $2 : $4)) + [mop $1,mcp $5] } + | '[' kind ']' {% ams (sLL $1 $> $ HsListTy $2) + [mos $1,mcs $3] } + +comma_kinds1 :: { [LHsKind RdrName] } + : kind { [$1] } + | kind ',' comma_kinds1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return ($1 : $3) } + +{- Note [Promotion] + ~~~~~~~~~~~~~~~~ + +- Syntax of promoted qualified names +We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified +names. Moreover ticks are only allowed in types, not in kinds, for a +few reasons: + 1. we don't need quotes since we cannot define names in kinds + 2. if one day we merge types and kinds, tick would mean look in DataName + 3. we don't have a kind namespace anyway + +- Syntax of explicit kind polymorphism (IA0_TODO: not yet implemented) +Kind abstraction is implicit. We write +> data SList (s :: k -> *) (as :: [k]) where ... +because it looks like what we do in terms +> id (x :: a) = x + +- Name resolution +When the user write Zero instead of 'Zero in types, we parse it a +HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We +deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not +bounded in the type level, then we look for it in the term level (we +change its namespace to DataName, see Note [Demotion] in OccName). And +both become a HsTyVar ("Zero", DataName) after the renamer. + +-} + + +----------------------------------------------------------------------------- +-- Datatype declarations + +gadt_constrlist :: { Located ([AddAnn] + ,[LConDecl RdrName]) } -- Returned in order + : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) + ([mj AnnWhere $1 + ,moc $2 + ,mcc $4] + , unLoc $3) } + | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) + ([mj AnnWhere $1] + , unLoc $3) } + | {- empty -} { noLoc ([],[]) } + +gadt_constrs :: { Located [LConDecl RdrName] } + : gadt_constr ';' gadt_constrs + {% addAnnotation (gl $1) AnnSemi (gl $2) + >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr { L (gl $1) [$1] } + | {- empty -} { noLoc [] } + +-- We allow the following forms: +-- C :: Eq a => a -> T a +-- C :: forall a. Eq a => !a -> T a +-- D { x,y :: a } :: T a +-- forall a. Eq a => D { x,y :: a } :: T a + +gadt_constr :: { LConDecl RdrName } + -- Returns a list because of: C,D :: ty + : con_list '::' sigtype + {% do { (anns,gadtDecl) <- mkGadtDecl (unLoc $1) $3 + ; ams (sLL $1 $> $ gadtDecl) + (mj AnnDcolon $2:anns) } } + + -- Deprecated syntax for GADT record declarations + | oqtycon '{' fielddecls '}' '::' sigtype + {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 (noLoc $3) $6 + ; cd' <- checkRecordSyntax cd + ; ams (L (comb2 $1 $6) (unLoc cd')) + [moc $2,mcc $4,mj AnnDcolon $5] } } + +constrs :: { Located ([AddAnn],[LConDecl RdrName]) } + : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] + ,addConDocs (unLoc $3) $1)} + +constrs1 :: { Located [LConDecl RdrName] } + : constrs1 maybe_docnext '|' maybe_docprev constr + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) + >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } + | constr { sL1 $1 [$1] } + +constr :: { LConDecl RdrName } + : maybe_docnext forall context '=>' constr_stuff maybe_docprev + {% ams (let (con,details) = unLoc $5 in + addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con + (snd $ unLoc $2) $3 details)) + ($1 `mplus` $6)) + (mj AnnDarrow $4:(fst $ unLoc $2)) } + | maybe_docnext forall constr_stuff maybe_docprev + {% ams ( let (con,details) = unLoc $3 in + addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con + (snd $ unLoc $2) (noLoc []) details)) + ($1 `mplus` $4)) + (fst $ unLoc $2) } + +forall :: { Located ([AddAnn],[LHsTyVarBndr RdrName]) } + : 'forall' tv_bndrs '.' { sLL $1 $> ([mj AnnForall $1,mj AnnDot $3],$2) } + | {- empty -} { noLoc ([],[]) } + +constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } +-- We parse the constructor declaration +-- C t1 t2 +-- as a btype (treating C as a type constructor) and then convert C to be +-- a data constructor. Reason: it might continue like this: +-- C t1 t2 %: D Int +-- in which case C really would be a type constructor. We can't resolve this +-- ambiguity till we come across the constructor oprerator :% (or not, more usually) + : btype {% splitCon $1 >>= return.sLL $1 $> } + | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) } + +fielddecls :: { [LConDeclField RdrName] } + : {- empty -} { [] } + | fielddecls1 { $1 } + +fielddecls1 :: { [LConDeclField RdrName] } + : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 + {% addAnnotation (gl $1) AnnComma (gl $3) >> + return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) } + | fielddecl { [$1] } + +fielddecl :: { LConDeclField RdrName } + -- A list because of f,g :: Int + : maybe_docnext sig_vars '::' ctype maybe_docprev + {% ams (L (comb2 $2 $4) + (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5))) + [mj AnnDcolon $3] } + +-- We allow the odd-looking 'inst_type' in a deriving clause, so that +-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). +-- The 'C [a]' part is converted to an HsPredTy by checkInstType +-- We don't allow a context, but that's sorted out by the type checker. +deriving :: { Located (Maybe (Located [LHsType RdrName])) } + : {- empty -} { noLoc Nothing } + | 'deriving' qtycon {% aljs ( let { L loc tv = $2 } + in (sLL $1 $> (Just (sLL $1 $> + [L loc (HsTyVar tv)])))) + [mj AnnDeriving $1] } + | 'deriving' '(' ')' {% aljs (sLL $1 $> (Just (sLL $1 $> []))) + [mj AnnDeriving $1,mop $2,mcp $3] } + + | 'deriving' '(' inst_types1 ')' {% aljs (sLL $1 $> (Just (sLL $1 $> $3))) + [mj AnnDeriving $1,mop $2,mcp $4] } + -- Glasgow extension: allow partial + -- applications in derivings + +----------------------------------------------------------------------------- +-- Value definitions + +{- Note [Declaration/signature overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's an awkward overlap with a type signature. Consider + f :: Int -> Int = ...rhs... + Then we can't tell whether it's a type signature or a value + definition with a result signature until we see the '='. + So we have to inline enough to postpone reductions until we know. +-} + +{- + ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var + instead of qvar, we get another shift/reduce-conflict. Consider the + following programs: + + { (^^) :: Int->Int ; } Type signature; only var allowed + + { (^^) :: Int->Int = ... ; } Value defn with result signature; + qvar allowed (because of instance decls) + + We can't tell whether to reduce var to qvar until after we've read the signatures. +-} + +docdecl :: { LHsDecl RdrName } + : docdecld { sL1 $1 (DocD (unLoc $1)) } + +docdecld :: { LDocDecl } + : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } + | docprev { sL1 $1 (DocCommentPrev (unLoc $1)) } + | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } + | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } + +decl_no_th :: { Located (OrdList (LHsDecl RdrName)) } + : sigdecl { $1 } + + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar bang_RDR)) $2) }; + pat <- checkPattern empty e; + _ <- ams (sLL $1 $> ()) + (fst $ unLoc $3); + return $ sLL $1 $> $ unitOL $ sLL $1 $> $ ValD $ + PatBind pat (snd $ unLoc $3) + placeHolderType + placeHolderNames + ([],[]) } } + -- Turn it all into an expression so that + -- checkPattern can check that bangs are enabled + + | infixexp opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3; + let { l = comb2 $1 $> }; + case r of { + (FunBind n _ _ _ _ _) -> + ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; + (PatBind (L lh _lhs) _rhs _ _ _) -> + ams (L lh ()) (fst $2) >> return () } ; + _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); + return $! (sL l (unitOL $! (sL l $ ValD r))) } } + | pattern_synonym_decl { sLL $1 $> $ unitOL $1 } + | docdecl { sLL $1 $> $ unitOL $1 } + +decl :: { Located (OrdList (LHsDecl RdrName)) } + : decl_no_th { $1 } + + -- Why do we only allow naked declaration splices in top-level + -- declarations and not here? Short answer: because readFail009 + -- fails terribly with a panic in cvBindsAndSigs otherwise. + | splice_exp { sLL $1 $> $ unitOL (sLL $1 $> $ mkSpliceDecl $1) } + +rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } + : '=' exp wherebinds { sL (comb3 $1 $2 $3) + ((mj AnnEqual $1 : (fst $ unLoc $3)) + ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2) + (snd $ unLoc $3)) } + | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 + ,GRHSs (reverse (unLoc $1)) + (snd $ unLoc $2)) } + +gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] } + : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } + | gdrh { sL1 $1 [$1] } + +gdrh :: { LGRHS RdrName (LHsExpr RdrName) } + : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + [mj AnnVbar $1,mj AnnEqual $3] } + +sigdecl :: { Located (OrdList (LHsDecl RdrName)) } + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtypedoc + {% do ty <- checkPartialTypeSignature $3 + ; s <- checkValSig $1 ty + ; _ <- ams (sLL $1 $> ()) [mj AnnDcolon $2] + ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) } + + | var ',' sig_vars '::' sigtypedoc + {% do { ty <- checkPartialTypeSignature $5 + ; let sig = TypeSig ($1 : reverse (unLoc $3)) ty PlaceHolder + ; addAnnotation (gl $1) AnnComma (gl $2) + ; ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD sig ]) + [mj AnnDcolon $4] } } + + | infix prec ops + {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD + (FixSig (FixitySig (fromOL $ unLoc $3) + (Fixity (unLoc $2) (unLoc $1)))) ]) + [mj AnnInfix $1,mj AnnVal $2] } + + | pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 } + + | '{-# INLINE' activation qvar '#-}' + {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 + (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) + (snd $2))))) + ((mo $1:fst $2) ++ [mc $4]) } + + | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' + {% ams ( + let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) + (EmptyInlineSpec, FunLike) (snd $2) + in sLL $1 $> $ + toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag) ]) + (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) } + + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' + {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) + (mkInlinePragma (getSPEC_INLINE_PRAGs $1) + (getSPEC_INLINE $1) (snd $2))) ]) + (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) } + + | '{-# SPECIALISE' 'instance' inst_type '#-}' + {% ams (sLL $1 $> $ unitOL (sLL $1 $> + $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))) + [mo $1,mj AnnInstance $2,mc $4] } + + -- AZ TODO: Do we need locations in the name_formula_opt? + -- A minimal complete definition + | '{-# MINIMAL' name_boolformula_opt '#-}' + {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) (snd $2)))) + (mo $1:mc $3:fst $2) } + +activation :: { ([AddAnn],Maybe Activation) } + : {- empty -} { ([],Nothing) } + | explicit_activation { (fst $1,Just (snd $1)) } + +explicit_activation :: { ([AddAnn],Activation) } -- In brackets + : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] + ,ActiveAfter (fromInteger (getINTEGER $2))) } + | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 + ,mj AnnCloseS $4] + ,ActiveBefore (fromInteger (getINTEGER $3))) } + +----------------------------------------------------------------------------- +-- Expressions + +quasiquote :: { Located (HsQuasiQuote RdrName) } + : TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter } + in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + | TH_QQUASIQUOTE { let { loc = getLoc $1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + +exp :: { LHsExpr RdrName } + : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3 PlaceHolder) + [mj AnnDcolon $2] } + | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + HsFirstOrderApp True) + [mj Annlarrowtail $2] } + | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + HsFirstOrderApp False) + [mj Annrarrowtail $2] } + | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + HsHigherOrderApp True) + [mj AnnLarrowtail $2] } + | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + HsHigherOrderApp False) + [mj AnnRarrowtail $2] } + | infixexp { $1 } + +infixexp :: { LHsExpr RdrName } + : exp10 { $1 } + | infixexp qop exp10 {% ams (sLL $1 $> + (OpApp $1 $2 placeHolderFixity $3)) + [mj AnnVal $2] } + -- AnnVal annotation for NPlusKPat, which discards the operator + + +exp10 :: { LHsExpr RdrName } + : '\\' apat apats opt_asig '->' exp + {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource + [sLL $1 $> $ Match Nothing ($2:$3) (snd $4) (unguardedGRHSs $6)])) + (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) } + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) + (mj AnnLet $1:mj AnnIn $3 + :(fst $ unLoc $2)) } + | '\\' 'lcase' altslist + {% ams (sLL $1 $> $ HsLamCase placeHolderType + (mkMatchGroup FromSource (snd $ unLoc $3))) + (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> + ams (sLL $1 $> $ mkHsIf $2 $5 $8) + (mj AnnIf $1:mj AnnThen $4 + :mj AnnElse $7 + :(map (\l -> mj AnnSemi l) (fst $3)) + ++(map (\l -> mj AnnSemi l) (fst $6))) } + | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> + ams (sLL $1 $> $ HsMultiIf + placeHolderType + (reverse $ snd $ unLoc $2)) + (mj AnnIf $1:(fst $ unLoc $2)) } + | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup + FromSource (snd $ unLoc $4))) + (mj AnnCase $1:mj AnnOf $3 + :(fst $ unLoc $4)) } + | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) + [mj AnnMinus $1] } + + | 'do' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo DoExpr (snd $ unLoc $2))) + (mj AnnDo $1:(fst $ unLoc $2)) } + | 'mdo' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo MDoExpr (snd $ unLoc $2))) + (mj AnnMdo $1:(fst $ unLoc $2)) } + + | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + (fst $ fst $ unLoc $1) } + + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + (fst $ fst $ unLoc $1) } + + | 'proc' aexp '->' exp + {% checkPattern empty $2 >>= \ p -> + checkCommand $4 >>= \ cmd -> + ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType + placeHolderType [])) + -- TODO: is LL right here? + [mj AnnProc $1,mj AnnRarrow $3] } + + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRING $2) $4) + [mo $1,mj AnnVal $2 + ,mc $3] } + -- hdaume: core annotation + | fexp { $1 } + +optSemi :: { ([Located a],Bool) } + : ';' { ([$1],True) } + | {- empty -} { ([],False) } + +scc_annot :: { Located (([AddAnn],SourceText),FastString) } + : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 + ; return $ sLL $1 $> + (([mo $1,mj AnnValStr $2 + ,mc $3],getSCC_PRAGs $1),scc) } + | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 + ,mc $3],getSCC_PRAGs $1) + ,(getVARID $2)) } + +hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int))) } + : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + { sLL $1 $> $ (([mo $1,mj AnnVal $2 + ,mj AnnVal $3,mj AnnColon $4 + ,mj AnnVal $5,mj AnnMinus $6 + ,mj AnnVal $7,mj AnnColon $8 + ,mj AnnVal $9,mc $10], + getGENERATED_PRAGs $1) + ,(getSTRING $2 + ,( fromInteger $ getINTEGER $3 + , fromInteger $ getINTEGER $5 + ) + ,( fromInteger $ getINTEGER $7 + , fromInteger $ getINTEGER $9 + ) + )) + } + +fexp :: { LHsExpr RdrName } + : fexp aexp { sLL $1 $> $ HsApp $1 $2 } + | 'static' aexp {% ams (sLL $1 $> $ HsStatic $2) + [mj AnnStatic $1] } + | aexp { $1 } + +aexp :: { LHsExpr RdrName } + : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } + | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } + | aexp1 { $1 } + +aexp1 :: { LHsExpr RdrName } + : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) + (snd $3) + ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) + ; checkRecordSyntax (sLL $1 $> r) }} + | aexp2 { $1 } + +aexp2 :: { LHsExpr RdrName } + : ipvar { sL1 $1 (HsIPVar $! unLoc $1) } + | qcname { sL1 $1 (HsVar $! unLoc $1) } + | literal { sL1 $1 (HsLit $! unLoc $1) } +-- This will enable overloaded strings permanently. Normally the renamer turns HsString +-- into HsOverLit when -foverloaded-strings is on. +-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) +-- (getSTRING $1) placeHolderType) } + | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGERs $1) + (getINTEGER $1) placeHolderType) } + | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional + (getRATIONAL $1) placeHolderType) } + + -- N.B.: sections get parsed by these next two productions. + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't + -- correct Haskell (you'd have to write '((+ 3), (4 -))') + -- but the less cluttered version fell out of having texps. + | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } + | '(' tup_exprs ')' {% ams (sLL $1 $> (ExplicitTuple $2 Boxed)) + [mop $1,mcp $3] } + + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) + (Present $2)] Unboxed)) + [mo $1,mc $3] } + | '(#' tup_exprs '#)' {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed)) + [mo $1,mc $3] } + + | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } + | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } + | '_' { sL1 $1 EWildPat } + + -- Template Haskell Extension + | splice_exp { $1 } + + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] } + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]} + | '[t|' ctype '|]' {% checkNoPartialType + (text "in type brackets" <> colon + <+> quotes (text "[t|" <+> ppr $2 <+> text "|]")) $2 >> + ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] } + | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> + ams (sLL $1 $> $ HsBracket (PatBr p)) + [mo $1,mc $3] } + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) + (mo $1:mc $3:fst $2) } + | quasiquote { sL1 $1 (HsQuasiQuoteE (unLoc $1)) } + + -- arrow notation extension + | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2 + Nothing (reverse $3)) + [mo $1,mc $4] } + +splice_exp :: { LHsExpr RdrName } + : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE + (sL1 $1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1)))) + [mj AnnThIdSplice $1] } + | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) + [mj AnnOpenPE $1,mj AnnCloseP $3] } + | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE + (sL1 $1 $ HsVar (mkUnqual varName + (getTH_ID_TY_SPLICE $1)))) + [mj AnnThIdTySplice $1] } + | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) + [mj AnnOpenPTE $1,mj AnnCloseP $3] } + +cmdargs :: { [LHsCmdTop RdrName] } + : cmdargs acmd { $2 : $1 } + | {- empty -} { [] } + +acmd :: { LHsCmdTop RdrName } + : aexp2 {% checkCommand $1 >>= \ cmd -> + return (sL1 $1 $ HsCmdTop cmd + placeHolderType placeHolderType []) } + +cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) } + : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 + ,mj AnnCloseC $3],$2) } + | vocurly cvtopdecls0 close { ([],$2) } + +cvtopdecls0 :: { [LHsDecl RdrName] } + : {- empty -} { [] } + | cvtopdecls { $1 } + +----------------------------------------------------------------------------- +-- Tuple expressions + +-- "texp" is short for tuple expressions: +-- things that can appear unparenthesized as long as they're +-- inside parens or delimitted by commas +texp :: { LHsExpr RdrName } + : exp { $1 } + + -- Note [Parsing sections] + -- ~~~~~~~~~~~~~~~~~~~~~~~ + -- We include left and right sections here, which isn't + -- technically right according to the Haskell standard. + -- For example (3 +, True) isn't legal. + -- However, we want to parse bang patterns like + -- (!x, !y) + -- and it's convenient to do so here as a section + -- Then when converting expr to pattern we unravel it again + -- Meanwhile, the renamer checks that real sections appear + -- inside parens. + | infixexp qop { sLL $1 $> $ SectionL $1 $2 } + | qopm infixexp { sLL $1 $> $ SectionR $1 $2 } + + -- View patterns get parenthesized above + | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mj AnnRarrow $2] } + +-- Always at least one comma +tup_exprs :: { [LHsTupArg RdrName] } + : texp commas_tup_tail + {% do { addAnnotation (gl $1) AnnComma (fst $2) + ; return ((sL1 $1 (Present $1)) : snd $2) } } + + | commas tup_tail + {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) + ; return + (map (\l -> L l missingTupArg) (fst $1) ++ $2) } } + +-- Always starts with commas; always follows an expr +commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) } +commas_tup_tail : commas tup_tail + {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) + ; return ( + (head $ fst $1 + ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } } + +-- Always follows a comma +tup_tail :: { [LHsTupArg RdrName] } + : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> + return ((L (gl $1) (Present $1)) : snd $2) } + | texp { [L (gl $1) (Present $1)] } + | {- empty -} { [noLoc missingTupArg] } + +----------------------------------------------------------------------------- +-- List expressions + +-- The rules below are little bit contorted to keep lexps left-recursive while +-- avoiding another shift/reduce-conflict. +list :: { ([AddAnn],HsExpr RdrName) } + : texp { ([],ExplicitList placeHolderType Nothing [$1]) } + | lexps { ([],ExplicitList placeHolderType Nothing + (reverse (unLoc $1))) } + | texp '..' { ([mj AnnDotdot $2], + ArithSeq noPostTcExpr Nothing (From $1)) } + | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], + ArithSeq noPostTcExpr Nothing + (FromThen $1 $3)) } + | texp '..' exp { ([mj AnnDotdot $2], + ArithSeq noPostTcExpr Nothing + (FromTo $1 $3)) } + | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], + ArithSeq noPostTcExpr Nothing + (FromThenTo $1 $3 $5)) } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return ([mj AnnVbar $2], + mkHsComp ctxt (unLoc $3) $1) } + +lexps :: { Located [LHsExpr RdrName] } + : lexps ',' texp {% addAnnotation (gl $ head $ unLoc $1) + AnnComma (gl $2) >> + return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } + | texp ',' texp {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> [$3,$1]) } + +----------------------------------------------------------------------------- +-- List Comprehensions + +flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } + : pquals { case (unLoc $1) of + [qs] -> sL1 $1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qs <- qss] + noSyntaxExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + } + +pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } + : squals '|' pquals + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> + return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } + | squals { L (getLoc $1) [reverse (unLoc $1)] } + +squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last + -- one can "grab" the earlier ones + : squals ',' transformqual + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + ams (sLL $1 $> ()) (fst $ unLoc $3) >> + return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } + | squals ',' qual + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | transformqual {% ams $1 (fst $ unLoc $1) >> + return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } + | qual { sL1 $1 [$1] } +-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } +-- | '{|' pquals '|}' { sL1 $1 [$2] } + +-- It is possible to enable bracketing (associating) qualifier lists +-- by uncommenting the lines with {| |} above. Due to a lack of +-- consensus on the syntax, this feature is not being used until we +-- get user demand. + +transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) } + -- Function is applied to a list of stmts *in order* + : 'then' exp { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } + | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> (mkTransformByStmt ss $2 $4)) } + | 'then' 'group' 'using' exp + { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) } + + | 'then' 'group' 'by' exp 'using' exp + { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) } + +-- Note that 'group' is a special_id, which means that you can enable +-- TransformListComp while still using Data.List.group. However, this +-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict +-- in by choosing the "group by" variant, which is what we want. + +----------------------------------------------------------------------------- +-- Parallel array expressions + +-- The rules below are little bit contorted; see the list case for details. +-- Note that, in contrast to lists, we only have finite arithmetic sequences. +-- Moreover, we allow explicit arrays with no element (represented by the nil +-- constructor in the list case). + +parr :: { ([AddAnn],HsExpr RdrName) } + : { ([],ExplicitPArr placeHolderType []) } + | texp { ([],ExplicitPArr placeHolderType [$1]) } + | lexps { ([],ExplicitPArr placeHolderType + (reverse (unLoc $1))) } + | texp '..' exp { ([mj AnnDotdot $2] + ,PArrSeq noPostTcExpr (FromTo $1 $3)) } + | texp ',' exp '..' exp + { ([mj AnnComma $2,mj AnnDotdot $4] + ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) } + | texp '|' flattenedpquals + { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) } + +-- We are reusing `lexps' and `flattenedpquals' from the list case. + +----------------------------------------------------------------------------- +-- Guards + +guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } + : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } + +guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } + : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma + (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | qual { sL1 $1 [$1] } + +----------------------------------------------------------------------------- +-- Case alternatives + +altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } + : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse (snd $ unLoc $2))) } + | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 + ,(reverse (snd $ unLoc $2))) } + | '{' '}' { noLoc ([moc $1,mcc $2],[]) } + | vocurly close { noLoc ([],[]) } + +alts :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) + ,snd $ unLoc $2) } + +alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } + : alts1 ';' alt {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,[$3])) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } + | alts1 ';' {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,snd $ unLoc $1)) + else (ams (head $ snd $ unLoc $1) + (mj AnnSemi $2:(fst $ unLoc $1)) + >> return (sLL $1 $> ([],snd $ unLoc $1))) } + | alt { sL1 $1 ([],[$1]) } + +alt :: { LMatch RdrName (LHsExpr RdrName) } + : pat opt_sig alt_rhs {%ams (sLL $1 $> (Match Nothing [$1] (snd $2) + (snd $ unLoc $3))) + ((fst $2) ++ (fst $ unLoc $3))} + +alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } + : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, + GRHSs (unLoc $1) (snd $ unLoc $2)) } + +ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } + : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) + [mj AnnRarrow $1] } + | gdpats { sL1 $1 (reverse (unLoc $1)) } + +gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } + : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) } + | gdpat { sL1 $1 [$1] } + +-- optional semi-colons between the guards of a MultiWayIf, because we use +-- layout here, but we don't need (or want) the semicolon as a separator (#7783). +gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] } + : gdpatssemi gdpat optSemi {% ams (sL (comb2 $1 $2) ($2 : unLoc $1)) + (map (\l -> mj AnnSemi l) $ fst $3) } + | gdpat optSemi {% ams (sL1 $1 [$1]) + (map (\l -> mj AnnSemi l) $ fst $2) } + +-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to +-- generate the open brace in addition to the vertical bar in the lexer, and +-- we don't need it. +ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) } + : '{' gdpatssemi '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } + | gdpatssemi close { sL1 $1 ([],unLoc $1) } + +gdpat :: { LGRHS RdrName (LHsExpr RdrName) } + : '|' guardquals '->' exp + {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + [mj AnnVbar $1,mj AnnRarrow $3] } + +-- 'pat' recognises a pattern, including one with a bang at the top +-- e.g. "!x" or "!(x,y)" or "C a b" etc +-- Bangs inside are parsed as infix operator applications, so that +-- we parse them right when bang-patterns are off +pat :: { LPat RdrName } +pat : exp {% checkPattern empty $1 } + | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR + (sL1 $1 (HsVar bang_RDR)) $2))) + [mj AnnBang $1] } + +bindpat :: { LPat RdrName } +bindpat : exp {% checkPattern + (text "Possibly caused by a missing 'do'?") $1 } + | '!' aexp {% amms (checkPattern + (text "Possibly caused by a missing 'do'?") + (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2))) + [mj AnnBang $1] } + +apat :: { LPat RdrName } +apat : aexp {% checkPattern empty $1 } + | '!' aexp {% amms (checkPattern empty + (sLL $1 $> (SectionR + (sL1 $1 (HsVar bang_RDR)) $2))) + [mj AnnBang $1] } + +apats :: { [LPat RdrName] } + : apat apats { $1 : $2 } + | {- empty -} { [] } + +----------------------------------------------------------------------------- +-- Statement sequences + +stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } + : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) + ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? + | vocurly stmts close { L (gl $2) (fst $ unLoc $2 + ,reverse $ snd $ unLoc $2) } + +-- do { ;; s ; s ; ; s ;; } +-- The last Stmt should be an expression, but that's hard to enforce +-- here, because we need too much lookahead if we see do { e ; } +-- So we use BodyStmts throughout, and switch the last one over +-- in ParseUtils.checkDo instead +-- AZ: TODO check that we can retrieve multiple semis. + +stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } + : stmts ';' stmt {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + ,$3 : (snd $ unLoc $1))) + else do + { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] + ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} + + | stmts ';' {% if null (snd $ unLoc $1) + then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) + else do + { ams (head $ snd $ unLoc $1) + [mj AnnSemi $2] + ; return $1 } } + | stmt { sL1 $1 ([],[$1]) } + | {- empty -} { noLoc ([],[]) } + + +-- For typing stmts at the GHCi prompt, where +-- the input may consist of just comments. +maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } + : stmt { Just $1 } + | {- nothing -} { Nothing } + +stmt :: { LStmt RdrName (LHsExpr RdrName) } + : qual { $1 } + | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) + (mj AnnRec $1:(fst $ unLoc $2)) } + +qual :: { LStmt RdrName (LHsExpr RdrName) } + : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) + [mj AnnLarrow $2] } + | exp { sL1 $1 $ mkBodyStmt $1 } + | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2)) + (mj AnnLet $1:(fst $ unLoc $2)) } + +----------------------------------------------------------------------------- +-- Record Field Update/Construction + +fbinds :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } + : fbinds1 { $1 } + | {- empty -} { ([],([], False)) } + +fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) } + : fbind ',' fbinds1 + {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } + | fbind { ([],([$1], False)) } + | '..' { ([mj AnnDotdot $1],([], True)) } + +fbind :: { LHsRecField RdrName (LHsExpr RdrName) } + : qvar '=' texp {% ams (sLL $1 $> $ HsRecField $1 $3 False) + [mj AnnEqual $2] } + -- RHS is a 'texp', allowing view patterns (Trac #6038) + -- and, incidentaly, sections. Eg + -- f (R { x = show -> s }) = ... + + | qvar { sLL $1 $> $ HsRecField $1 placeHolderPunRhs True } + -- In the punning case, use a place-holder + -- The renamer fills in the final value + +----------------------------------------------------------------------------- +-- Implicit Parameter Bindings + +dbinds :: { Located [LIPBind RdrName] } + : dbinds ';' dbind + {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> + return (let { this = $3; rest = unLoc $1 } + in rest `seq` this `seq` sLL $1 $> (this : rest)) } + | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> + return (sLL $1 $> (unLoc $1)) } + | dbind { let this = $1 in this `seq` sL1 $1 [this] } +-- | {- empty -} { [] } + +dbind :: { LIPBind RdrName } +dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) + [mj AnnEqual $2] } + +ipvar :: { Located HsIPName } + : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } + +----------------------------------------------------------------------------- +-- Warnings and deprecations + +name_boolformula_opt :: { ([AddAnn],BooleanFormula (Located RdrName)) } + : name_boolformula { $1 } + | {- empty -} { ([],mkTrue) } + +name_boolformula :: { ([AddAnn],BooleanFormula (Located RdrName)) } + : name_boolformula_and { $1 } + | name_boolformula_and '|' name_boolformula + { ((mj AnnVbar $2:fst $1)++(fst $3) + ,Or [snd $1,snd $3]) } + +name_boolformula_and :: { ([AddAnn],BooleanFormula (Located RdrName)) } + : name_boolformula_atom { $1 } + | name_boolformula_atom ',' name_boolformula_and + { ((mj AnnComma $2:fst $1)++(fst $3), And [snd $1,snd $3]) } + +name_boolformula_atom :: { ([AddAnn],BooleanFormula (Located RdrName)) } + : '(' name_boolformula ')' { ((mop $1:mcp $3:(fst $2)),snd $2) } + | name_var { ([],Var $1) } + +namelist :: { Located [Located RdrName] } +namelist : name_var { sL1 $1 [$1] } + | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } + +name_var :: { Located RdrName } +name_var : var { $1 } + | con { $1 } + +----------------------------------------- +-- Data constructors +-- There are two different productions here as lifted list constructors +-- are parsed differently. + +qcon_nowiredlist :: { Located RdrName } + : gen_qcon { $1 } + | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +qcon :: { Located RdrName } + : gen_qcon { $1} + | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +gen_qcon :: { Located RdrName } + : qconid { $1 } + | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + +-- The case of '[:' ':]' is part of the production `parr' + +con :: { Located RdrName } + : conid { $1 } + | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + +con_list :: { Located [Located RdrName] } +con_list : con { sL1 $1 [$1] } + | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> + return (sLL $1 $> ($1 : unLoc $3)) } + +sysdcon_nolist :: { Located DataCon } -- Wired in data constructors + : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } + | '(' commas ')' {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1)) + (mop $1:mcp $3:(mcommas (fst $2))) } + | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } + | '(#' commas '#)' {% ams (sLL $1 $> $ tupleCon UnboxedTuple (snd $2 + 1)) + (mo $1:mc $3:(mcommas (fst $2))) } + +sysdcon :: { Located DataCon } + : sysdcon_nolist { $1 } + | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } + +conop :: { Located RdrName } + : consym { $1 } + | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qconop :: { Located RdrName } + : qconsym { $1 } + | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +---------------------------------------------------------------------------- +-- Type constructors + + +-- See Note [Unit tuples] in HsTypes for the distinction +-- between gtycon and ntgtycon +gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples + : ntgtycon { $1 } + | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) + [mop $1,mcp $2] } + | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) + [mo $1,mc $2] } + +ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples + : oqtycon { $1 } + | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple + (snd $2 + 1))) + (mop $1:mcp $3:(mcommas (fst $2))) } + | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple + (snd $2 + 1))) + (mo $1:mc $3:(mcommas (fst $2))) } + | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + [mop $1,mj AnnRarrow $2,mcp $3] } + | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } + | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } + | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) + [mop $1,mj AnnTildehsh $2,mcp $3] } + +oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; + -- These can appear in export lists + : qtycon { $1 } + | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) + [mop $1,mj AnnTilde $2,mcp $3] } + +qtyconop :: { Located RdrName } -- Qualified or unqualified + : qtyconsym { $1 } + | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qtycon :: { Located RdrName } -- Qualified or unqualified + : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } + | PREFIXQCONSYM { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) } + | tycon { $1 } + +tycon :: { Located RdrName } -- Unqualified + : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } + +qtyconsym :: { Located RdrName } + : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } + | tyconsym { $1 } + +-- Does not include "!", because that is used for strictness marks +-- or ".", because that separates the quantified type vars from the rest +tyconsym :: { Located RdrName } + : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } + | '*' { sL1 $1 $! mkUnqual tcClsName (fsLit "*") } + | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } + + +----------------------------------------------------------------------------- +-- Operators + +op :: { Located RdrName } -- used in infix decls + : varop { $1 } + | conop { $1 } + +varop :: { Located RdrName } + : varsym { $1 } + | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qop :: { LHsExpr RdrName } -- used in sections + : qvarop { sL1 $1 $ HsVar (unLoc $1) } + | qconop { sL1 $1 $ HsVar (unLoc $1) } + +qopm :: { LHsExpr RdrName } -- used in sections + : qvaropm { sL1 $1 $ HsVar (unLoc $1) } + | qconop { sL1 $1 $ HsVar (unLoc $1) } + +qvarop :: { Located RdrName } + : qvarsym { $1 } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +qvaropm :: { Located RdrName } + : qvarsym_no_minus { $1 } + | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + +----------------------------------------------------------------------------- +-- Type variables + +tyvar :: { Located RdrName } +tyvar : tyvarid { $1 } + +tyvarop :: { Located RdrName } +tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) + [mj AnnBackquote $1,mj AnnVal $2 + ,mj AnnBackquote $3] } + | '.' {% parseErrorSDoc (getLoc $1) + (vcat [ptext (sLit "Illegal symbol '.' in type"), + ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"), + ptext (sLit "extension to enable explicit-forall syntax: forall . ")]) + } + +tyvarid :: { Located RdrName } + : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } + +----------------------------------------------------------------------------- +-- Variables + +var :: { Located RdrName } + : varid { $1 } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + +qvar :: { Located RdrName } + : qvarid { $1 } + | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } + | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } +-- We've inlined qvarsym here so that the decision about +-- whether it's a qvar or a var can be postponed until +-- *after* we see the close paren. + +qvarid :: { Located RdrName } + : varid { $1 } + | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } + | PREFIXQVARSYM { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) } + +-- Note that 'role' and 'family' get lexed separately regardless of +-- the use of extensions. However, because they are listed here, this +-- is OK and they can be used as normal varids. +varid :: { Located RdrName } + : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } + | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } + | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } + | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} + | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } + | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } + | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } + +qvarsym :: { Located RdrName } + : varsym { $1 } + | qvarsym1 { $1 } + +qvarsym_no_minus :: { Located RdrName } + : varsym_no_minus { $1 } + | qvarsym1 { $1 } + +qvarsym1 :: { Located RdrName } +qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) } + +varsym :: { Located RdrName } + : varsym_no_minus { $1 } + | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } + +varsym_no_minus :: { Located RdrName } -- varsym not including '-' + : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } + | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } + + +-- These special_ids are treated as keywords in various places, +-- but as ordinary ids elsewhere. 'special_id' collects all these +-- except 'unsafe', 'interruptible', 'forall', 'family', and 'role', +-- whose treatment differs depending on context +special_id :: { Located FastString } +special_id + : 'as' { sL1 $1 (fsLit "as") } + | 'qualified' { sL1 $1 (fsLit "qualified") } + | 'hiding' { sL1 $1 (fsLit "hiding") } + | 'export' { sL1 $1 (fsLit "export") } + | 'label' { sL1 $1 (fsLit "label") } + | 'dynamic' { sL1 $1 (fsLit "dynamic") } + | 'stdcall' { sL1 $1 (fsLit "stdcall") } + | 'ccall' { sL1 $1 (fsLit "ccall") } + | 'capi' { sL1 $1 (fsLit "capi") } + | 'prim' { sL1 $1 (fsLit "prim") } + | 'javascript' { sL1 $1 (fsLit "javascript") } + | 'group' { sL1 $1 (fsLit "group") } + +special_sym :: { Located FastString } +special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } + | '.' { sL1 $1 (fsLit ".") } + | '*' { sL1 $1 (fsLit "*") } + +----------------------------------------------------------------------------- +-- Data constructors + +qconid :: { Located RdrName } -- Qualified or unqualified + : conid { $1 } + | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } + | PREFIXQCONSYM { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) } + +conid :: { Located RdrName } + : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } + +qconsym :: { Located RdrName } -- Qualified or unqualified + : consym { $1 } + | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } + +consym :: { Located RdrName } + : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } + + -- ':' means only list cons + | ':' { sL1 $1 $ consDataCon_RDR } + + +----------------------------------------------------------------------------- +-- Literals + +literal :: { Located HsLit } + : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 } + | STRING { sL1 $1 $ HsString (getSTRINGs $1) + $ getSTRING $1 } + | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1) + $ getPRIMINTEGER $1 } + | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) + $ getPRIMWORD $1 } + | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) + $ getPRIMCHAR $1 } + | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) + $ getPRIMSTRING $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 } + +----------------------------------------------------------------------------- +-- Layout + +close :: { () } + : vccurly { () } -- context popped in lexer. + | error {% popContext } + +----------------------------------------------------------------------------- +-- Miscellaneous (mostly renamings) + +modid :: { Located ModuleName } + : CONID { sL1 $1 $ mkModuleNameFS (getCONID $1) } + | QCONID { sL1 $1 $ let (mod,c) = getQCONID $1 in + mkModuleNameFS + (mkFastString + (unpackFS mod ++ '.':unpackFS c)) + } + +commas :: { ([SrcSpan],Int) } -- One or more commas + : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } + | ',' { ([gl $1],1) } + +----------------------------------------------------------------------------- +-- Documentation comments + +docnext :: { LHsDocString } + : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) } + +docprev :: { LHsDocString } + : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) } + +docnamed :: { Located (String, HsDocString) } + : DOCNAMED {% + let string = getDOCNAMED $1 + (name, rest) = break isSpace string + in return (sL1 $1 (name, HsDocString (mkFastString rest))) } + +docsection :: { Located (Int, HsDocString) } + : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in + return (sL1 $1 (n, HsDocString (mkFastString doc))) } + +moduleheader :: { Maybe LHsDocString } + : DOCNEXT {% let string = getDOCNEXT $1 in + return (Just (sL1 $1 (HsDocString (mkFastString string)))) } + +maybe_docprev :: { Maybe LHsDocString } + : docprev { Just $1 } + | {- empty -} { Nothing } + +maybe_docnext :: { Maybe LHsDocString } + : docnext { Just $1 } + | {- empty -} { Nothing } + +{ +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getPREFIXQVARSYM (L _ (ITprefixqvarsym x)) = x +getPREFIXQCONSYM (L _ (ITprefixqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getINTEGER (L _ (ITinteger _ x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (L _ (ITidEscape x)) = x +getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) + +getDOCNEXT (L _ (ITdocCommentNext x)) = x +getDOCPREV (L _ (ITdocCommentPrev x)) = x +getDOCNAMED (L _ (ITdocCommentNamed x)) = x +getDOCSECTION (L _ (ITdocSection n x)) = (n, x) + +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getINTEGERs (L _ (ITinteger src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src + +-- See Note [Pragma source text] in BasicTypes for the following +getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getVECT_PRAGs (L _ (ITvect_prag src)) = src +getVECT_SCALAR_PRAGs (L _ (ITvect_scalar_prag src)) = src +getNOVECT_PRAGs (L _ (ITnovect_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src + + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then failSpanMsgP (getLoc lt) (text err) + else return s + +-- Utilities for combining source spans +comb2 :: Located a -> Located b -> SrcSpan +comb2 a b = a `seq` b `seq` combineLocs a b + +comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) + +comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 a b c d = a `seq` b `seq` c `seq` d `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d)) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` a `seq` L span a + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 = L noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState + unless mwiEnabled $ parseErrorSDoc span $ + text "Multi-way if-expressions need MultiWayIf turned on" + +-- Hint about if usage for beginners +hintIf :: SrcSpan -> String -> P (LHsExpr RdrName) +hintIf span msg = do + mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState + if mwiEnabled + then parseErrorSDoc span $ text $ "parse error in if statement" + else parseErrorSDoc span $ text $ "parse error in if statement: "++msg + +-- Hint about explicit-forall, assuming UnicodeSyntax is on +hintExplicitForall :: SrcSpan -> P () +hintExplicitForall span = do + forall <- extension explicitForallEnabled + rulePrag <- extension inRulePrag + unless (forall || rulePrag) $ parseErrorSDoc span $ vcat + [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL + , text "Perhaps you intended to use RankNTypes or a similar language" + , text "extension to enable explicit-forall syntax: \x2200 . " + ] + +namedWildcardsEnabled :: P Bool +namedWildcardsEnabled = liftM ((Opt_NamedWildCards `xopt`) . dflags) getPState + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [Api annotations] +in ApiAnnotation.hs + +-} + +-- |Construct an AddAnn from the annotation keyword and the location +-- of the keyword +mj :: AnnKeywordId -> Located e -> AddAnn +mj a l = (\s -> addAnnotation s a (gl l)) + + +gl = getLoc + +-- |Add an annotation to the located element, and return the located +-- element as a pass through +aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) +aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a + +-- |Add an annotation to a located element resulting from a monadic action +am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) +am a (b,s) = do + av@(L l _) <- a + addAnnotation l b (gl s) + return av + +-- |Add a list of AddAnns to the given AST element +ams :: Located a -> [AddAnn] -> P (Located a) +ams a@(L l _) bs = mapM_ (\a -> a l) bs >> return a + + +-- |Add a list of AddAnns to the given AST element, where the AST element is the +-- result of a monadic action +amms :: P (Located a) -> [AddAnn] -> P (Located a) +amms a bs = do + av@(L l _) <- a + (mapM_ (\a -> a l) bs) >> return av + +-- |Add a list of AddAnns to the AST element, and return the element as a +-- OrdList +amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) +amsu a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return (unitOL a) + +-- |Synonyms for AddAnn versions of AnnOpen and AnnClose +mo,mc :: Located Token -> SrcSpan -> P () +mo ll = mj AnnOpen ll +mc ll = mj AnnClose ll + +moc,mcc :: Located Token -> SrcSpan -> P () +moc ll = mj AnnOpenC ll +mcc ll = mj AnnCloseC ll + +mop,mcp :: Located Token -> SrcSpan -> P () +mop ll = mj AnnOpenP ll +mcp ll = mj AnnCloseP ll + +mos,mcs :: Located Token -> SrcSpan -> P () +mos ll = mj AnnOpenS ll +mcs ll = mj AnnCloseS ll + +-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma +-- entry for each SrcSpan +mcommas :: [SrcSpan] -> [AddAnn] +mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss + +-- |Add the annotation to an AST element wrapped in a Just +ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan + -> P (Located (Maybe (Located a))) +ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a + +-- |Add all [AddAnn] to an AST element wrapped in a Just +aljs :: Located (Maybe (Located a)) -> [AddAnn] + -> P (Located (Maybe (Located a))) +aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a + +-- |Add all [AddAnn] to an AST element wrapped in a Just +ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a + +-- |Get the location of the last element of a OrdList, or noSrcSpan +oll :: OrdList (Located a) -> SrcSpan +oll l = + if isNilOL l then noSrcSpan + else getLoc (lastOL l) + +-- |Add a semicolon annotation in the right place in a list. If the +-- leading list is empty, add it to the tail +asl :: [Located a] -> Located b -> Located a -> P() +asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls + +} diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs new file mode 100644 index 00000000..3d3e9c97 --- /dev/null +++ b/compiler/parser/RdrHsSyn.hs @@ -0,0 +1,1518 @@ +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- Functions over HsSyn specialised to RdrName. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module RdrHsSyn ( + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkSpliceDecl, + mkRoleAnnotDecl, + mkClassDecl, + mkTyData, mkDataFamInst, + mkTySynonym, mkTyFamInstEqn, + mkTyFamInst, + mkFamDecl, + splitCon, mkInlinePragma, + mkPatSynMatchGroup, + mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkTyClD, mkInstD, + + cvBindGroup, + cvBindsAndSigs, + cvTopDecls, + placeHolderPunRhs, + + -- Stuff to do with Foreign declarations + mkImport, + parseCImport, + mkExport, + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkSimpleConDecl, + mkDeprecatedGadtRecordDecl, + mkATDefault, + + -- Bunch of functions in the parser monad for + -- checking and constructing values + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPattern, -- HsExp -> P HsPat + bang_RDR, + checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] + checkMonadComp, -- P (HsStmtContext RdrName) + checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName) + checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkPartialTypeSignature, + checkNoPartialType, + checkValidPatSynSig, + checkDoAndIfThenElse, + checkRecordSyntax, + checkValidDefaults, + parseErrorSDoc, + + -- Help with processing exports + ImpExpSubSpec(..), + mkModuleImpExp, + mkTypeImpExp + + ) where + +import HsSyn -- Lots of it +import Class ( FunDep ) +import CoAxiom ( Role, fsFromRole ) +import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, + isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace, + rdrNameSpace ) +import OccName ( tcClsName, isVarNameSpace ) +import Name ( Name ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..), InlineSpec(..), Origin(..), + SourceText ) +import TcEvidence ( idHsWrapper ) +import Lexer +import TysWiredIn ( unitTyCon, unitDataCon ) +import ForeignCall +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, + occNameString ) +import PrelNames ( forall_tv_RDR, allNameStrings ) +import DynFlags +import SrcLoc +import OrdList ( OrdList, fromOL ) +import Bag ( emptyBag, consBag ) +import Outputable +import FastString +import Maybes +import Util +import ApiAnnotation + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Monad + +import Text.ParserCombinators.ReadP as ReadP +import Data.Char + +import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) +import Data.List ( partition ) +import qualified Data.Set as Set ( fromList, difference, member ) + +#include "HsVersions.h" + + +{- ********************************************************************** + + Construction functions for Rdr stuff + + ********************************************************************* -} + +-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and +-- datacon by deriving them from the name of the class. We fill in the names +-- for the tycon and datacon corresponding to the class, by deriving them +-- from the name of the class itself. This saves recording the names in the +-- interface file (which would be equally good). + +-- Similarly for mkConDecl, mkClassOpSig and default-method names. + +-- *** See "THE NAMING STORY" in HsDecls **** + +mkTyClD :: LTyClDecl n -> LHsDecl n +mkTyClD (L loc d) = L loc (TyClD d) + +mkInstD :: LInstDecl n -> LHsDecl n +mkInstD (L loc d) = L loc (InstD d) + +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Located (a,[Located (FunDep (Located RdrName))]) + -> OrdList (LHsDecl RdrName) + -> P (LTyClDecl RdrName) + +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls + = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls + ; let cxt = fromMaybe (noLoc []) mcxt + ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + -- Partial type signatures are not allowed in a class definition + ; checkNoPartialSigs sigs cls + ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams + ; at_defs <- mapM (eitherToP . mkATDefault) at_insts + ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, + tcdFDs = snd (unLoc fds), tcdSigs = sigs, + tcdMeths = binds, + tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, + tcdFVs = placeHolderNames })) } + +mkATDefault :: LTyFamInstDecl RdrName + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +-- Take a type-family instance declaration and turn it into +-- a type-family default equation for a class declaration +-- We parse things as the former and use this function to convert to the latter +-- +-- We use the Either monad because this also called +-- from Convert.hs +mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) + | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e + = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats) + ; return (L loc (TyFamEqn { tfe_tycon = tc + , tfe_pats = tvs + , tfe_rhs = rhs })) } + +-- | Check that none of the given type signatures of the class definition +-- ('Located RdrName') are partial type signatures. An error will be reported +-- for each wildcard found in a (partial) type signature. We do this check +-- because we want the signatures in a class definition to be fully specified. +checkNoPartialSigs :: [LSig RdrName] -> Located RdrName -> P () +checkNoPartialSigs sigs cls_name = + sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err sig + | L _ sig@(TypeSig _ ty _) <- sigs + , let mb_loc = maybeLocation $ findWildcards ty ] + where err sig = + vcat [ text "The type signature of a class method cannot be partial:" + , ppr sig + , text "In the class declaration for " <> quotes (ppr cls_name) ] + +-- | Check that none of the given constructors contain a wildcard (like in a +-- partial type signature). An error will be reported for each wildcard found +-- in a (partial) constructor definition. We do this check because we want the +-- type of a constructor to be fully specified. +checkNoPartialCon :: [LConDecl RdrName] -> P () +checkNoPartialCon con_decls = + sequence_ [ whenIsJust mb_loc $ \loc -> parseErrorSDoc loc $ err cd + | L _ cd@(ConDecl { con_cxt = cxt, con_res = res, + con_details = details }) <- con_decls + , let mb_loc = maybeLocation $ + concatMap findWildcards (unLoc cxt) ++ + containsWildcardRes res ++ + concatMap findWildcards + (hsConDeclArgTys details) ] + where err con_decl = text "A constructor cannot have a partial type:" $$ + ppr con_decl + containsWildcardRes (ResTyGADT _ ty) = findWildcards ty + containsWildcardRes ResTyH98 = notFound + +-- | Check that the given type does not contain wildcards, and is thus not a +-- partial type. If it contains wildcards, report an error with the given +-- message. +checkNoPartialType :: SDoc -> LHsType RdrName -> P () +checkNoPartialType context_msg ty = + whenFound (findWildcards ty) $ \loc -> parseErrorSDoc loc err + where err = text "Wildcard not allowed" $$ context_msg + +-- | Represent wildcards found in a type. Used for reporting errors for types +-- that mustn't contain wildcards. +data FoundWildcard = Found { location :: SrcSpan } + | FoundNamed { location :: SrcSpan, _name :: RdrName } + +-- | Indicate that no wildcards were found. +notFound :: [FoundWildcard] +notFound = [] + +-- | Call the function (second argument), accepting the location of the +-- wildcard, on the first wildcard that was found, if any. +whenFound :: [FoundWildcard] -> (SrcSpan -> P ()) -> P () +whenFound (Found loc:_) f = f loc +whenFound (FoundNamed loc _:_) f = f loc +whenFound _ _ = return () + +-- | Extract the location of the first wildcard, if any. +maybeLocation :: [FoundWildcard] -> Maybe SrcSpan +maybeLocation fws = location <$> listToMaybe fws + +-- | Extract the named wildcards from the wildcards that were found. +namedWildcards :: [FoundWildcard] -> [RdrName] +namedWildcards fws = [name | FoundNamed _ name <- fws] + +-- | Split the found wildcards into a list of found unnamed wildcard and found +-- named wildcards. +splitUnnamedNamed :: [FoundWildcard] -> ([FoundWildcard], [FoundWildcard]) +splitUnnamedNamed = partition (\f -> case f of { Found _ -> True ; _ -> False}) + +-- | Return a list of the wildcards found while traversing the given type. +findWildcards :: LHsType RdrName -> [FoundWildcard] +findWildcards (L l ty) = case ty of + (HsForAllTy _ xtr _ (L _ ctxt) x) -> (map Found $ maybeToList xtr) ++ + concatMap go ctxt ++ go x + (HsAppTy x y) -> go x ++ go y + (HsFunTy x y) -> go x ++ go y + (HsListTy x) -> go x + (HsPArrTy x) -> go x + (HsTupleTy _ xs) -> concatMap go xs + (HsOpTy x _ y) -> go x ++ go y + (HsParTy x) -> go x + (HsIParamTy _ x) -> go x + (HsEqTy x y) -> go x ++ go y + (HsKindSig x y) -> go x ++ go y + (HsDocTy x _) -> go x + (HsBangTy _ x) -> go x + (HsRecTy xs) -> + concatMap (go . getBangType . cd_fld_type . unLoc) xs + (HsExplicitListTy _ xs) -> concatMap go xs + (HsExplicitTupleTy _ xs) -> concatMap go xs + (HsWrapTy _ x) -> go (noLoc x) + HsWildcardTy -> [Found l] + (HsNamedWildcardTy n) -> [FoundNamed l n] + -- HsTyVar, HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit + _ -> notFound + where go = findWildcards + +mkTyData :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe (Located [LHsType RdrName]) + -> P (LTyClDecl RdrName) +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv + = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdDataDefn = defn, + tcdFVs = placeHolderNames })) } + +mkDataDefn :: NewOrData + -> Maybe (Located CType) + -> Maybe (LHsContext RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe (Located [LHsType RdrName]) + -> P (HsDataDefn RdrName) +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + = do { checkDatatypeContext mcxt + ; checkNoPartialCon data_cons + ; whenIsJust maybe_deriv $ + \(L _ deriv) -> mapM_ (checkNoPartialType (errDeriv deriv)) deriv + ; let cxt = fromMaybe (noLoc []) mcxt + ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = cxt + , dd_cons = data_cons + , dd_kindSig = ksig + , dd_derivs = maybe_deriv }) } + where errDeriv deriv = text "In the deriving items:" <+> + pprHsContextNoArrow deriv + + +mkTySynonym :: SrcSpan + -> LHsType RdrName -- LHS + -> LHsType RdrName -- RHS + -> P (LTyClDecl RdrName) +mkTySynonym loc lhs rhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams + ; let err = text "In type synonym" <+> quotes (ppr tc) <> + colon <+> ppr rhs + ; checkNoPartialType err rhs + ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars + , tcdRhs = rhs, tcdFVs = placeHolderNames })) } + +mkTyFamInstEqn :: LHsType RdrName + -> LHsType RdrName + -> P (TyFamInstEqn RdrName,[AddAnn]) +mkTyFamInstEqn lhs rhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs + ; let err xhs = hang (text "In type family instance equation of" <+> + quotes (ppr tc) <> colon) + 2 (ppr xhs) + ; checkNoPartialType (err lhs) lhs + ; checkNoPartialType (err rhs) rhs + ; return (TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs tparams + , tfe_rhs = rhs }, + ann) } + +mkDataFamInst :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe (Located [LHsType RdrName]) + -> P (LInstDecl RdrName) +mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv + = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (DataFamInstD ( + DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams + , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } + +mkTyFamInst :: SrcSpan + -> LTyFamInstEqn RdrName + -> P (LInstDecl RdrName) +mkTyFamInst loc eqn + = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn + , tfid_fvs = placeHolderNames }))) + +mkFamDecl :: SrcSpan + -> FamilyInfo RdrName + -> LHsType RdrName -- LHS + -> Maybe (LHsKind RdrName) -- Optional kind signature + -> P (LTyClDecl RdrName) +mkFamDecl loc info lhs ksig + = do { (tc, tparams,ann) <- checkTyClHdr lhs + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams + ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc + , fdTyVars = tyvars, fdKindSig = ksig }))) } + where + equals_or_where = case info of + DataFamily -> empty + OpenTypeFamily -> empty + ClosedTypeFamily {} -> whereDots + +mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +-- If the user wrote +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if she wrote, say, +-- f x then behave as if she'd written $(f x) +-- ie a SpliceD +mkSpliceDecl lexpr@(L loc expr) + | HsQuasiQuoteE qq <- expr = QuasiQuoteD qq + | HsSpliceE is_typed splice <- expr = ASSERT( not is_typed ) + SpliceD (SpliceDecl (L loc splice) ExplicitSplice) + | otherwise = SpliceD (SpliceDecl (L loc splice) ImplicitSplice) + where + splice = mkHsSplice lexpr + +mkRoleAnnotDecl :: SrcSpan + -> Located RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> P (LRoleAnnotDecl RdrName) +mkRoleAnnotDecl loc tycon roles + = do { roles' <- mapM parse_role roles + ; return $ L loc $ RoleAnnotDecl tycon roles' } + where + role_data_type = dataTypeOf (undefined :: Role) + all_roles = map fromConstr $ dataTypeConstrs role_data_type + possible_roles = [(fsFromRole role, role) | role <- all_roles] + + parse_role (L loc_role Nothing) = return $ L loc_role Nothing + parse_role (L loc_role (Just role)) + = case lookup role possible_roles of + Just found_role -> return $ L loc_role $ Just found_role + Nothing -> + let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in + parseErrorSDoc loc_role + (text "Illegal role name" <+> quotes (ppr role) $$ + suggestions nearby) + + suggestions [] = empty + suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) + -- will this last case ever happen?? + suggestions list = hang (text "Perhaps you meant one of these:") + 2 (pprWithCommas (quotes . ppr) list) + +{- ********************************************************************** + + #cvBinds-etc# Converting to @HsBinds@, etc. + + ********************************************************************* -} + +-- | Function definitions are restructured here. Each is assumed to be recursive +-- initially, and non recursive definitions are discovered by the dependency +-- analyser. + + +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls decls = go (fromOL decls) + where + go :: [LHsDecl RdrName] -> [LHsDecl RdrName] + go [] = [] + go (L l (ValD b) : ds) = L l' (ValD b') : go ds' + where (L l' b', ds') = getMonoBind (L l b) ds + go (d : ds) = d : go ds + +-- Declaration list may only contain value bindings and signatures. +cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName) +cvBindGroup binding + = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding + ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) + return $ ValBindsIn mbs sigs } + +cvBindsAndSigs :: OrdList (LHsDecl RdrName) + -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName] + , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl]) +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigs fb = go (fromOL fb) + where + go [] = return (emptyBag, [], [], [], [], []) + go (L l (ValD b) : ds) + = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' + ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } + where + (b', ds') = getMonoBind (L l b) ds + go (L l decl : ds) + = do { (bs, ss, ts, tfis, dfis, docs) <- go ds + ; case decl of + SigD s + -> return (bs, L l s : ss, ts, tfis, dfis, docs) + TyClD (FamDecl t) + -> return (bs, ss, L l t : ts, tfis, dfis, docs) + InstD (TyFamInstD { tfid_inst = tfi }) + -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) + InstD (DataFamInstD { dfid_inst = dfi }) + -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) + DocD d + -> return (bs, ss, ts, tfis, dfis, L l d : docs) + SpliceD d + -> parseErrorSDoc l $ + hang (text "Declaration splices are allowed only" <+> + text "at the top level:") + 2 (ppr d) + _ -> pprPanic "cvBindsAndSigs" (ppr decl) } + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] + -> (LHsBind RdrName, [LHsDecl RdrName]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- All Haddock comments between equations inside the group are +-- discarded. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, + fun_matches = MG { mg_alts = mtchs1 } })) binds + | has_args mtchs1 + = go is_infix1 mtchs1 loc1 binds [] + where + go is_infix mtchs loc + (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, + fun_matches = MG { mg_alts = mtchs2 } })) : binds) _ + | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) + (combineSrcSpans loc loc2) binds [] + go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls' + go is_infix mtchs loc binds doc_decls + = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds) + -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments + +getMonoBind bind binds = (bind, binds) + +has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool +has_args [] = panic "RdrHsSyn:has_args" +has_args ((L _ (Match _ args _ _)) : _) = not (null args) + -- Don't group together FunBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). + +{- ********************************************************************** + + #PrefixToHS-utils# Utilities for conversion + + ********************************************************************* -} + +----------------------------------------------------------------------------- +-- splitCon + +-- When parsing data declarations, we sometimes inadvertently parse +-- a constructor application as a type (eg. in data T a b = C a b `D` E a b) +-- This function splits up the type application, adds any pending +-- arguments, and converts the type constructor back into a data constructor. + +splitCon :: LHsType RdrName + -> P (Located RdrName, HsConDeclDetails RdrName) +-- This gets given a "type" that should look like +-- C Int Bool +-- or C { x::Int, y::Bool } +-- and returns the pieces +splitCon ty + = split ty [] + where + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) + split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon []) + -- See Note [Unit tuples] in HsTypes + split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) + + mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) + mk_rest ts = PrefixCon ts + +recordPatSynErr :: SrcSpan -> LPat RdrName -> P a +recordPatSynErr loc pat = + parseErrorSDoc loc $ + text "record syntax not supported for pattern synonym declarations:" $$ + ppr pat + +mkPatSynMatchGroup :: Located RdrName + -> Located (OrdList (LHsDecl RdrName)) + -> P (MatchGroup RdrName (LHsExpr RdrName)) +mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; return $ mkMatchGroup FromSource matches } + where + fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr loc decl + ; match <- case details of + PrefixCon pats -> return $ Match Nothing pats Nothing rhs + InfixCon pat1 pat2 -> + return $ Match Nothing [pat1, pat2] Nothing rhs + RecCon{} -> recordPatSynErr loc pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl + + extraDeclErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must contain a single binding:" $$ + ppr decl + + wrongNameBindingErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> + quotes (ppr patsyn_name) $$ ppr decl + +mkDeprecatedGadtRecordDecl :: SrcSpan + -> Located RdrName + -> Located [LConDeclField RdrName] + -> LHsType RdrName + -> P (LConDecl RdrName) +-- This one uses the deprecated syntax +-- C { x,y ::Int } :: T a b +-- We give it a RecCon details right away +mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty + = do { data_con <- tyConToDataCon con_loc con + ; return (L loc (ConDecl { con_old_rec = True + , con_names = [data_con] + , con_explicit = Implicit + , con_qvars = mkHsQTvs [] + , con_cxt = noLoc [] + , con_details = RecCon flds + , con_res = ResTyGADT loc res_ty + , con_doc = Nothing })) } + +mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] + -> LHsContext RdrName -> HsConDeclDetails RdrName + -> ConDecl RdrName + +mkSimpleConDecl name qvars cxt details + = ConDecl { con_old_rec = False + , con_names = [name] + , con_explicit = Explicit + , con_qvars = mkHsQTvs qvars + , con_cxt = cxt + , con_details = details + , con_res = ResTyH98 + , con_doc = Nothing } + +mkGadtDecl :: [Located RdrName] + -> LHsType RdrName -- Always a HsForAllTy + -> P ([AddAnn], ConDecl RdrName) +mkGadtDecl names (L l ty) = do + let + (anns,ty') = flattenHsForAllTyKeepAnns ty + gadt <- mkGadtDecl' names (L l ty') + return (anns,gadt) + +mkGadtDecl' :: [Located RdrName] + -> LHsType RdrName -- Always a HsForAllTy + -> P (ConDecl RdrName) + +-- We allow C,D :: ty +-- and expand it as if it had been +-- C :: ty; D :: ty +-- (Just like type signatures in general.) +mkGadtDecl' _ ty@(L _ (HsForAllTy _ (Just l) _ _ _)) + = parseErrorSDoc l $ + text "A constructor cannot have a partial type:" $$ + ppr ty +mkGadtDecl' names (L ls (HsForAllTy imp Nothing qvars cxt tau)) + = return $ mk_gadt_con names + where + (details, res_ty) -- See Note [Sorting out the result type] + = case tau of + L _ (HsFunTy (L l (HsRecTy flds)) res_ty) + -> (RecCon (L l flds), res_ty) + _other -> (PrefixCon [], tau) + + mk_gadt_con names + = ConDecl { con_old_rec = False + , con_names = names + , con_explicit = imp + , con_qvars = qvars + , con_cxt = cxt + , con_details = details + , con_res = ResTyGADT ls res_ty + , con_doc = Nothing } +mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty) + +tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) +tyConToDataCon loc tc + | isTcOcc (rdrNameOcc tc) + = return (L loc (setRdrNameSpace tc srcDataName)) + | otherwise + = parseErrorSDoc loc (msg $$ extra) + where + msg = text "Not a data constructor:" <+> quotes (ppr tc) + extra | tc == forall_tv_RDR + = text "Perhaps you intended to use ExistentialQuantification" + | otherwise = empty + +-- | Note [Sorting out the result type] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In a GADT declaration which is not a record, we put the whole constr +-- type into the ResTyGADT for now; the renamer will unravel it once it +-- has sorted out operator fixities. Consider for example +-- C :: a :*: b -> a :*: b -> a :+: b +-- Initially this type will parse as +-- a :*: (b -> (a :*: (b -> (a :+: b)))) + +-- so it's hard to split up the arguments until we've done the precedence +-- resolution (in the renamer) On the other hand, for a record +-- { x,y :: Int } -> a :*: b +-- there is no doubt. AND we need to sort records out so that +-- we can bring x,y into scope. So: +-- * For PrefixCon we keep all the args in the ResTyGADT +-- * For RecCon we do not + +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +-- Same as checkTyVars, but in the P monad +checkTyVarsP pp_what equals_or_where tc tparms + = eitherToP $ checkTyVars pp_what equals_or_where tc tparms + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc +eitherToP (Right thing) = return thing +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] + -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName) +-- Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature) +-- We use the Either monad because it's also called (via mkATDefault) from +-- Convert.hs +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } + where + + -- Check that the name space is correct! + chk (L l (HsKindSig (L lv (HsTyVar tv)) k)) + | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) + chk (L l (HsTyVar tv)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) + chk t@(L loc _) + = Left (loc, + vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) + , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) + , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) + , nest 2 (pp_what <+> ppr tc + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) + +whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars +whereDots = ptext (sLit "where ...") +equalsDots = ptext (sLit "= ...") + +checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just (L loc c)) + = do allowed <- extension datatypeContextsEnabled + unless allowed $ + parseErrorSDoc loc + (text "Illegal datatype context (use DatatypeContexts):" <+> + pprHsContext c) + mapM_ (checkNoPartialType err) c + where err = text "In the context:" <+> pprHsContextNoArrow c + +checkRecordSyntax :: Outputable a => Located a -> P (Located a) +checkRecordSyntax lr@(L loc r) + = do allowed <- extension traditionalRecordSyntaxEnabled + if allowed + then return lr + else parseErrorSDoc loc + (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> + ppr r) + +checkTyClHdr :: LHsType RdrName + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsType RdrName], -- parameters of head symbol + [AddAnn]) -- API Annotation for HsParTy when stripping parens +-- Well-formedness check and decomposition of type and class heads. +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr ty + = goL ty [] [] + where + goL (L l ty) acc ann = go l ty acc ann + + go l (HsTyVar tc) acc ann + | isRdrTc tc = return (L l tc, acc, ann) + go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann + | isRdrTc tc = return (ltc, t1:t2:acc, ann) + go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l) + go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann + go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann) + -- See Note [Unit tuples] in HsTypes + go l _ _ _ + = parseErrorSDoc l (text "Malformed head of type or class declaration:" + <+> ppr ty) + +checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName) +checkContext (L l orig_t) + = check [] (L l orig_t) + where + check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type + = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () + + check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way + = check anns' ty + where anns' = if l == lp1 then anns + else (anns ++ mkParensApiAnn lp1) + + check _anns _ + = return ([],L l [L l orig_t]) -- no need for anns, returning original + +-- ------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkPattern msg e = checkLPat msg e + +checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName] +checkPatterns msg es = mapM (checkPattern msg) es + +checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkLPat msg e@(L l _) = checkPat msg l e [] + +checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] + -> P (LPat RdrName) +checkPat _ loc (L l (HsVar c)) args + | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) +checkPat msg loc e args -- OK to let this happen even if bang-patterns + -- are not enabled, because there is no valid + -- non-bang-pattern parse of (C ! e) + | Just (e', args') <- splitBang e + = do { args'' <- checkPatterns msg args' + ; checkPat msg loc e' (args'' ++ args) } +checkPat msg loc (L _ (HsApp f e)) args + = do p <- checkLPat msg e + checkPat msg loc f (p : args) +checkPat msg loc (L _ e) [] + = do p <- checkAPat msg loc e + return (L loc p) +checkPat msg loc e _ + = patFail msg loc (unLoc e) + +checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) +checkAPat msg loc e0 = do + pState <- getPState + let dynflags = dflags pState + case e0 of + EWildPat -> return (WildPat placeHolderType) + HsVar x -> return (VarPat x) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by the lexer + HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + NegApp (L l (HsOverLit pos_lit)) _ + -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) + + SectionR (L lb (HsVar bang)) e -- (! x) + | bang == bang_RDR + -> do { bang_on <- extension bangPatEnabled + ; if bang_on then do { e' <- checkLPat msg e + ; addAnnotation loc AnnBang lb + ; return (BangPat e') } + else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } + + ELazyPat e -> checkLPat msg e >>= (return . LazyPat) + EAsPat n e -> checkLPat msg e >>= (return . AsPat n) + -- view pattern is well-formed if the pattern is + EViewPat expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat expr p placeHolderType)) + ExprWithTySig e t _ -> do e <- checkLPat msg e + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + L _ (HsForAllTy Implicit _ _ + (L _ []) ty) -> ty + other -> other + return (SigPatIn e (mkHsWithBndrs t')) + + -- n+k patterns + OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ + (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L lloc lit)) + + OpApp l op _fix r -> do l <- checkLPat msg l + r <- checkLPat msg r + case op of + L cl (HsVar c) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail msg loc e0 + + HsPar e -> checkLPat msg e >>= (return . ParPat) + ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es + return (ListPat ps placeHolderType Nothing) + ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es + return (PArrPat ps placeHolderType) + + ExplicitTuple es b + | all tupArgPresent es -> do ps <- mapM (checkLPat msg) + [e | L _ (Present e) <- es] + return (TuplePat ps b []) + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) + + RecordCon c _ (HsRecFields fs dd) + -> do fs <- mapM (checkPatField msg) fs + return (ConPatIn c (RecCon (HsRecFields fs dd))) + HsSpliceE is_typed s | not is_typed + -> return (SplicePat s) + HsQuasiQuoteE q -> return (QuasiQuotePat q) + _ -> patFail msg loc e0 + +placeHolderPunRhs :: LHsExpr RdrName +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when debugging +placeHolderPunRhs = noLoc (HsVar pun_RDR) + +plus_RDR, bang_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +bang_RDR = mkUnqual varName (fsLit "!") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + +checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) + -> P (LHsRecField RdrName (LPat RdrName)) +checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) + +patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a +patFail msg loc e = parseErrorSDoc loc err + where err = text "Parse error in pattern:" <+> ppr e + $$ msg + + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: SDoc + -> LHsExpr RdrName + -> Maybe (LHsType RdrName) + -> Located (a,GRHSs RdrName (LHsExpr RdrName)) + -> P ([AddAnn],HsBind RdrName) + +checkValDef msg lhs (Just sig) grhss + -- x :: ty = rhs parses as a *pattern* binding + = checkPatBind msg (L (combineLocs lhs sig) + (ExprWithTySig lhs sig PlaceHolder)) grhss + +checkValDef msg lhs opt_sig g@(L l (_,grhss)) + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats, ann) -> + checkFunBind msg ann (getLoc lhs) + fun is_infix pats opt_sig (L l grhss) + Nothing -> checkPatBind msg lhs g } + +checkFunBind :: SDoc + -> [AddAnn] + -> SrcSpan + -> Located RdrName + -> Bool + -> [LHsExpr RdrName] + -> Maybe (LHsType RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) + -> P ([AddAnn],HsBind RdrName) +checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) + = do ps <- checkPatterns msg pats + let match_span = combineSrcSpans lhs_loc rhs_span + -- Add back the annotations stripped from any HsPar values in the lhs + -- mapM_ (\a -> a match_span) ann + return (ann,makeFunBind fun is_infix + [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)]) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. + +makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)] + -> HsBind RdrName +-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn is_infix ms + = FunBind { fun_id = fn, fun_infix = is_infix, + fun_matches = mkMatchGroup FromSource ms, + fun_co_fn = idHsWrapper, + bind_fvs = placeHolderNames, + fun_tick = [] } + +checkPatBind :: SDoc + -> LHsExpr RdrName + -> Located (a,GRHSs RdrName (LHsExpr RdrName)) + -> P ([AddAnn],HsBind RdrName) +checkPatBind msg lhs (L _ (_,grhss)) + = do { lhs <- checkPattern msg lhs + ; return ([],PatBind lhs grhss placeHolderType placeHolderNames + ([],[])) } + +checkValSig + :: LHsExpr RdrName + -> LHsType RdrName + -> P (Sig RdrName) +checkValSig (L l (HsVar v)) ty + | isUnqual v && not (isDataOcc (rdrNameOcc v)) + = return (TypeSig [L l v] ty PlaceHolder) +checkValSig lhs@(L l _) ty + = parseErrorSDoc l ((text "Invalid type signature:" <+> + ppr lhs <+> text "::" <+> ppr ty) + $$ text hint) + where + hint = if foreign_RDR `looks_like` lhs + then "Perhaps you meant to use ForeignFunctionInterface?" + else if default_RDR `looks_like` lhs + then "Perhaps you meant to use DefaultSignatures?" + else "Should be of form :: " + -- A common error is to forget the ForeignFunctionInterface flag + -- so check for that, and suggest. cf Trac #3805 + -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword + looks_like s (L _ (HsVar v)) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") + + +-- | Check that the default declarations do not contain wildcards in their +-- types, which we do not want as the types in the default declarations must +-- be fully specified. +checkValidDefaults :: [LHsType RdrName] -> P (DefaultDecl RdrName) +checkValidDefaults tys = mapM_ (checkNoPartialType err) tys >> return ret + where ret = DefaultDecl tys + err = text "In declaration:" <+> ppr ret + +-- | Check that the pattern synonym type signature does not contain wildcards. +checkValidPatSynSig :: Sig RdrName -> P (Sig RdrName) +checkValidPatSynSig psig@(PatSynSig _ _ prov req ty) + = mapM_ (checkNoPartialType err) (unLoc prov ++ unLoc req ++ [ty]) + >> return psig + where err = hang (text "In pattern synonym type signature: ") + 2 (ppr psig) +checkValidPatSynSig sig = return sig +-- Should only be called with a pattern synonym type signature + +-- | Check the validity of a partial type signature. We check the following +-- things: +-- +-- * There should only be one extra-constraints wildcard in the type +-- signature, i.e. the @_@ in @_ => a -> String@. +-- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@. +-- Extra-constraints wildcards are only allowed in the top-level context. +-- +-- * Named extra-constraints wildcards aren't allowed, +-- e.g. invalid: @(Show a, _x) => a -> String@. +-- +-- * There is only one extra-constraints wildcard in the context and it must +-- come last, e.g. invalid: @(_, Show a) => a -> String@ +-- or @(_, Show a, _) => a -> String@. +-- +-- * There should be no unnamed wildcards in the context. +-- +-- * Named wildcards occurring in the context must also occur in the monotype. +-- +-- An error is reported when an invalid wildcard is found. +checkPartialTypeSignature :: LHsType RdrName -> P (LHsType RdrName) +checkPartialTypeSignature fullTy = case fullTy of + + (L l (HsForAllTy flag extra bndrs (L lc ctxtP) ty)) -> do + -- Remove parens around types in the context + let ctxt = map ignoreParens ctxtP + -- Check that the type doesn't contain any more extra-constraints wildcards + checkNoExtraConstraintsWildcard ty + -- Named extra-constraints wildcards aren't allowed + whenIsJust (firstMatch isNamedWildcardTy ctxt) $ + \(L l _) -> err hintNamed l fullTy + -- There should be no more (extra-constraints) wildcards in the context. + -- If there was one at the end of the context, it is by now already + -- removed from the context and stored in the @extra@ field of the + -- 'HsForAllTy' by 'HsTypes.mkHsForAllTy'. + whenIsJust (firstMatch isWildcardTy ctxt) $ + \(L l _) -> err hintLast l fullTy + -- Find all wildcards in the context and the monotype, then divide + -- them in unnamed and named wildcards + let (unnamedInCtxt, namedInCtxt) = splitUnnamedNamed $ + concatMap findWildcards ctxt + (_ , namedInTy) = splitUnnamedNamed $ + findWildcards ty + -- Unnamed wildcards aren't allowed in the context + case unnamedInCtxt of + (Found lc : _) -> err hintUnnamedConstraint lc fullTy + _ -> return () + -- Calculcate the set of named wildcards in the context that aren't in the + -- monotype (tau) + let namedWildcardsNotInTau = Set.fromList (namedWildcards namedInCtxt) + `Set.difference` + Set.fromList (namedWildcards namedInTy) + -- Search for the first named wildcard that we encountered in the + -- context that isn't present in the monotype (we lose the order + -- in which they occur when using the Set directly). + case filter (\(FoundNamed _ name) -> Set.member name namedWildcardsNotInTau) + namedInCtxt of + (FoundNamed lc name:_) -> err (hintNamedNotInMonotype name) lc fullTy + _ -> return () + + -- Return the checked type + return $ L l (HsForAllTy flag extra bndrs (L lc ctxtP) ty) + + + ty -> do + checkNoExtraConstraintsWildcard ty + return ty + + where + ignoreParens (L _ (HsParTy ty)) = ty + ignoreParens ty = ty + + firstMatch :: (HsType a -> Bool) -> HsContext a -> Maybe (LHsType a) + firstMatch pred ctxt = listToMaybe (filter (pred . unLoc) ctxt) + + err hintSDoc lc ty = parseErrorSDoc lc $ + text "Invalid partial type signature:" $$ + ppr ty $$ hintSDoc + hintLast = sep [ text "An extra-constraints wildcard is only allowed" + , text "at the end of the constraints" ] + hintNamed = text "A named wildcard cannot occur as a constraint" + hintNested = sep [ text "An extra-constraints wildcard is only allowed" + , text "at the top-level of the signature" ] + hintUnnamedConstraint + = text "Wildcards are not allowed within the constraints" + hintNamedNotInMonotype name + = sep [ text "The named wildcard" <+> quotes (ppr name) <+> + text "is only allowed in the constraints" + , text "when it also occurs in the (mono)type" ] + + checkNoExtraConstraintsWildcard (L _ ty) = go ty + where + -- Report nested (named) extra-constraints wildcards + go' = go . unLoc + go (HsAppTy x y) = go' x >> go' y + go (HsFunTy x y) = go' x >> go' y + go (HsListTy x) = go' x + go (HsPArrTy x) = go' x + go (HsTupleTy _ xs) = mapM_ go' xs + go (HsOpTy x _ y) = go' x >> go' y + go (HsParTy x) = go' x + go (HsIParamTy _ x) = go' x + go (HsEqTy x y) = go' x >> go' y + go (HsKindSig x y) = go' x >> go' y + go (HsDocTy x _) = go' x + go (HsBangTy _ x) = go' x + go (HsRecTy xs) = mapM_ (go' . getBangType . cd_fld_type . unLoc) xs + go (HsExplicitListTy _ xs) = mapM_ go' xs + go (HsExplicitTupleTy _ xs) = mapM_ go' xs + go (HsWrapTy _ x) = go' (noLoc x) + go (HsForAllTy _ (Just l) _ _ _) = err hintNested l ty + go (HsForAllTy _ Nothing _ (L _ ctxt) x) + | Just (L l _) <- firstMatch isWildcardTy ctxt + = err hintNested l ty + | Just (L l _) <- firstMatch isNamedWildcardTy ctxt + = err hintNamed l ty + | otherwise = go' x + go _ = return () + + +checkDoAndIfThenElse :: LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> P () +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse + = do pState <- getPState + unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do + parseErrorSDoc (combineLocs guardExpr elseExpr) + (text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use DoAndIfThenElse?") + | otherwise = return () + where pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> + text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + text "else" <+> ppr elseExpr + + + -- The parser left-associates, so there should + -- not be any OpApps inside the e's +splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) +-- Splits (f ! g a b) into (f, [(! g), a, b]) +splitBang (L _ (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg)) + | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) + where + l' = combineLocs bang arg1 + (arg1,argns) = split_bang r_arg [] + split_bang (L _ (HsApp f e)) es = split_bang f (e:es) + split_bang e es = (e,es) +splitBang _ = Nothing + +isFunLhs :: LHsExpr RdrName + -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName],[AddAnn])) +-- A variable binding is parsed as a FunBind. +-- Just (fun, is_infix, arg_pats) if e is a function LHS +-- +-- The whole LHS is parsed as a single expression. +-- Any infix operators on the LHS will parse left-associatively +-- E.g. f !x y !z +-- will parse (rather strangely) as +-- (f ! x y) ! z +-- It's up to isFunLhs to sort out the mess +-- +-- a .!. !b + +isFunLhs e = go e [] [] + where + go (L loc (HsVar f)) es ann + | not (isRdrDataCon f) = return (Just (L loc f, False, es, ann)) + go (L _ (HsApp f e)) es ann = go f (e:es) ann + go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + + go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es ann + | Just (e',es') <- splitBang e + = do { bang_on <- extension bangPatEnabled + ; if bang_on then go e' (es' ++ es) ann + else return (Just (L loc' op, True, (l:r:es), ann)) } + -- No bangs; behave just like the next case + | not (isRdrDataCon op) -- We have found the function! + = return (Just (L loc' op, True, (l:r:es), ann)) + | otherwise -- Infix data con; keep going + = do { mb_l <- go l es ann + ; case mb_l of + Just (op', True, j : k : es', ann') + -> return (Just (op', True, j : op_app : es', ann')) + where + op_app = L loc (OpApp k (L loc' (HsVar op)) fix r) + _ -> return Nothing } + go _ _ _ = return Nothing + + +--------------------------------------------------------------------------- +-- Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a `MonadComp' context, +-- otherwise use the usual `ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + +-- ------------------------------------------------------------------------- +-- Checking arrow syntax. + +-- We parse arrow syntax as expressions and check for valid syntax below, +-- converting the expression into a pattern at the same time. + +checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) +checkCommand lc = locMap checkCmd lc + +locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) +locMap f (L l a) = f l a >>= (\b -> return $ L l b) + +checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) +checkCmd _ (HsArrApp e1 e2 ptt haat b) = + return $ HsCmdArrApp e1 e2 ptt haat b +checkCmd _ (HsArrForm e mf args) = + return $ HsCmdArrForm e mf args +checkCmd _ (HsApp e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) +checkCmd _ (HsLam mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') +checkCmd _ (HsPar e) = + checkCommand e >>= (\c -> return $ HsCmdPar c) +checkCmd _ (HsCase e mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') +checkCmd _ (HsIf cf ep et ee) = do + pt <- checkCommand et + pe <- checkCommand ee + return $ HsCmdIf cf ep pt pe +checkCmd _ (HsLet lb e) = + checkCommand e >>= (\c -> return $ HsCmdLet lb c) +checkCmd _ (HsDo DoExpr stmts ty) = + mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty) + +checkCmd _ (OpApp eLeft op _fixity eRight) = do + -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it + c1 <- checkCommand eLeft + c2 <- checkCommand eRight + let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] + return $ HsCmdArrForm op Nothing [arg1, arg2] + +checkCmd l e = cmdFail l e + +checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) +checkCmdLStmt = locMap checkCmdStmt + +checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) +checkCmdStmt _ (LastStmt e r) = + checkCommand e >>= (\c -> return $ LastStmt c r) +checkCmdStmt _ (BindStmt pat e b f) = + checkCommand e >>= (\c -> return $ BindStmt pat c b f) +checkCmdStmt _ (BodyStmt e t g ty) = + checkCommand e >>= (\c -> return $ BodyStmt c t g ty) +checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds +checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do + ss <- mapM checkCmdLStmt stmts + return $ stmt { recS_stmts = ss } +checkCmdStmt l stmt = cmdStmtFail l stmt + +checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) +checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do + ms' <- mapM (locMap $ const convert) ms + return $ mg { mg_alts = ms' } + where convert (Match mf pat mty grhss) = do + grhss' <- checkCmdGRHSs grhss + return $ Match mf pat mty grhss' + +checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) +checkCmdGRHSs (GRHSs grhss binds) = do + grhss' <- mapM checkCmdGRHS grhss + return $ GRHSs grhss' binds + +checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) +checkCmdGRHS = locMap $ const convert + where + convert (GRHS stmts e) = do + c <- checkCommand e +-- cmdStmts <- mapM checkCmdLStmt stmts + return $ GRHS {- cmdStmts -} stmts c + + +cmdFail :: SrcSpan -> HsExpr RdrName -> P a +cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) +cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a +cmdStmtFail loc e = parseErrorSDoc loc + (text "Parse error in command statement:" <+> ppr e) + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +checkPrecP :: Located Int -> P (Located Int) +checkPrecP (L l i) + | 0 <= i && i <= maxPrecedence = return (L l i) + | otherwise + = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) + +mkRecConstrOrUpdate + :: LHsExpr RdrName + -> SrcSpan + -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) + -> P (HsExpr RdrName) + +mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) + | isRdrDataCon c + = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp _ (fs,dd) + = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) + +mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg +mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } + +mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes + , inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- construct a foreign import declaration +-- +mkImport :: Located CCallConv + -> Located Safety + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty) + | Just loc <- maybeLocation $ findWildcards ty + = parseErrorSDoc loc $ + text "Wildcard not allowed" $$ + text "In foreign import declaration" <+> + quotes (ppr v) $$ ppr ty + | cconv == PrimCallConv = do + let funcTarget = CFunction (StaticTarget entity Nothing True) + importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget + (L loc (unpackFS entity)) + return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + | cconv == JavaScriptCallConv = do + let funcTarget = CFunction (StaticTarget entity Nothing True) + importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing + funcTarget (L loc (unpackFS entity)) + return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + | otherwise = do + case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v)) + (unpackFS entity) (L loc (unpackFS entity)) of + Nothing -> parseErrorSDoc loc (text "Malformed entity string") + Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + +-- the string "foo" is ambigous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: Located CCallConv -> Located Safety -> FastString -> String + -> Located SourceText + -> Maybe ForeignImport +parseCImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (mkFastString h))) <$> cimp nm)) + ] + skipSpaces + return r + + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + + mk h n = CImport cconv safety h n sourceText + + hdr_char c = not (isSpace c) -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ (do isFun <- case cconv of + L _ CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget cid' Nothing isFun))) + where + cid = return nm +++ + (do c <- satisfy id_first_char + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + +-- construct a foreign export declaration +-- +mkExport :: Located CCallConv + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkExport (L lc cconv) (L le entity, v, ty) = do + checkNoPartialType (ptext (sLit "In foreign export declaration") <+> + quotes (ppr v) $$ ppr ty) ty + return $ ForD (ForeignExport v ty noForeignExportCoercionYet + (CExport (L lc (CExportStatic entity' cconv)) + (L le (unpackFS entity)))) + where + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) + +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName] + +mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp n@(L l name) subs = + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) -> IEVar n + | otherwise -> IEThingAbs (L l nameT) + ImpExpAll -> IEThingAll (L l nameT) + ImpExpList xs -> IEThingWith (L l nameT) xs + + where + nameT = setRdrNameSpace name tcClsName + +mkTypeImpExp :: Located RdrName -> P (Located RdrName) +mkTypeImpExp name = + do allowed <- extension explicitNamespacesEnabled + if allowed + then return (fmap (`setRdrNameSpace` tcClsName) name) + else parseErrorSDoc (getLoc name) + (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") + +----------------------------------------------------------------------------- +-- Misc utils + +parseErrorSDoc :: SrcSpan -> SDoc -> P a +parseErrorSDoc span s = failSpanMsgP span s diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c new file mode 100644 index 00000000..d714a0cb --- /dev/null +++ b/compiler/parser/cutils.c @@ -0,0 +1,53 @@ +/* +These utility routines are used various +places in the GHC library. +*/ + +#include "Rts.h" + +#include "HsFFI.h" + +#include + +#ifdef HAVE_UNISTD_H +#include +#endif + +/* +Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner, +and causes gcc to require too many registers on x84 +*/ + +HsInt +ghc_strlen( HsPtr a ) +{ + return (strlen((char *)a)); +} + +HsInt +ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len ) +{ + return (memcmp((char *)a1, a2, len)); +} + +HsInt +ghc_memcmp_off( HsPtr a1, HsInt i, HsPtr a2, HsInt len ) +{ + return (memcmp((char *)a1 + i, a2, len)); +} + +void +enableTimingStats( void ) /* called from the driver */ +{ + RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; +} + +void +setHeapSize( HsInt size ) +{ + RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; + if (RtsFlags.GcFlags.maxHeapSize != 0 && + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + } +} diff --git a/compiler/parser/cutils.h b/compiler/parser/cutils.h new file mode 100644 index 00000000..c7c1867d --- /dev/null +++ b/compiler/parser/cutils.h @@ -0,0 +1,16 @@ +/* ----------------------------------------------------------------------------- + * + * Utility C functions. + * + * -------------------------------------------------------------------------- */ + +#include "HsFFI.h" + +// Out-of-line string functions, see PrimPacked.lhs +HsInt ghc_strlen( HsAddr a ); +HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len ); +HsInt ghc_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ); + + +void enableTimingStats( void ); +void setHeapSize( HsInt size ); diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs new file mode 100644 index 00000000..907640b4 --- /dev/null +++ b/compiler/prelude/ForeignCall.hs @@ -0,0 +1,345 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import FastString +import Binary +import Outputable +import Module +import BasicTypes ( SourceText ) + +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + {-! derive: Binary !-} + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving ( Eq, Show, Data, Typeable ) + -- Show used just for Show Lex.Token, I think + {-! derive: Binary !-} + +instance Outputable Safety where + ppr PlaySafe = ptext (sLit "safe") + ppr PlayInterruptible = ptext (sLit "interruptible") + ppr PlayRisky = ptext (sLit "unsafe") + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + CLabelString -- C Name of exported function + CCallConv + deriving (Data, Typeable) + {-! derive: Binary !-} + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + {-! derive: Binary !-} + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + CLabelString -- C-land name of label. + + (Maybe PackageKey) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data, Typeable ) + {-! derive: Binary !-} + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8 + +ToDo: The stdcall calling convention is x86 (win32) specific, +so perhaps we should emit a warning if it's being used on other +platforms. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the CallConv type in template haskell +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv + deriving (Eq, Data, Typeable) + {-! derive: Binary !-} + +instance Outputable CCallConv where + ppr StdCallConv = ptext (sLit "stdcall") + ppr CCallConv = ptext (sLit "ccall") + ppr CApiConv = ptext (sLit "capi") + ppr PrimCallConv = ptext (sLit "prim") + ppr JavaScriptCallConv = ptext (sLit "javascript") + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" +ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ ifPprDebug callconv, ppr_fun fun ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun (StaticTarget fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> pprCLabelString fn + + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +newtype Header = Header FastString + deriving (Eq, Data, Typeable) + +instance Outputable Header where + ppr (Header h) = quotes $ ppr h + +-- | A C type, used in CAPI FFI calls +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, +-- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', +-- 'ApiAnnotation.AnnClose' @'\#-}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data CType = CType SourceText -- Note [Pragma source text] in BasicTypes + (Maybe Header) -- header to include for this type + FastString -- the type itself + deriving (Data, Typeable) + +instance Outputable CType where + ppr (CType _ mh ct) = hDoc <+> ftext ct + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = do + putByte bh 0 + put_ bh PlayInterruptible = do + putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (CExportStatic aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget aa ab ac) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget aa ab ac) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + put_ bh PrimCallConv = do + putByte bh 2 + put_ bh CApiConv = do + putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + 1 -> do return StdCallConv + 2 -> do return PrimCallConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header h) = put_ bh h + get bh = do h <- get bh + return (Header h) diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs new file mode 100644 index 00000000..2303a8ed --- /dev/null +++ b/compiler/prelude/PrelInfo.hs @@ -0,0 +1,155 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} +-} + +{-# LANGUAGE CPP #-} +module PrelInfo ( + wiredInIds, ghcPrimIds, + primOpRules, builtinRules, + + ghcPrimExports, + wiredInThings, basicKnownKeyNames, + primOpId, + + -- Random other things + maybeCharLikeCon, maybeIntLikeCon, + + -- Class categories + isNumericClass, isStandardClass + + ) where + +#include "HsVersions.h" + +import PrelNames +import PrelRules +import Avail +import PrimOp +import DataCon +import Id +import MkId +import TysPrim +import TysWiredIn +import HscTypes +import Class +import TyCon +import Util +import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) + +import Data.Array + +{- +************************************************************************ +* * +\subsection[builtinNameInfo]{Lookup built-in names} +* * +************************************************************************ + +Notes about wired in things +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Wired-in things are Ids\/TyCons that are completely known to the compiler. + They are global values in GHC, (e.g. listTyCon :: TyCon). + +* A wired in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. + +* The name cache is initialised with (the names of) all wired-in things + +* The type checker sees if the Name is wired in before looking up + the name in the type environment. So the type envt itself contains + no wired in things. + +* MkIface prunes out wired-in things before putting them in an interface file. + So interface files never contain wired-in things. +-} + +wiredInThings :: [TyThing] +-- This list is used only to initialise HscMain.knownKeyNames +-- to ensure that when you say "Prelude.map" in your source code, you +-- get a Name with the correct known key (See Note [Known-key names]) +wiredInThings + = concat + [ -- Wired in TyCons and their implicit Ids + tycon_things + , concatMap implicitTyThings tycon_things + + -- Wired in Ids + , map AnId wiredInIds + + -- PrimOps + , map (AnId . primOpId) allThePrimOps + ] + where + tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons + ++ typeNatTyCons) + +{- +We let a lot of "non-standard" values be visible, so that we can make +sense of them in interface pragmas. It's cool, though they all have +"non-standard" names, so they won't get past the parser in user code. + +************************************************************************ +* * + PrimOpIds +* * +************************************************************************ +-} + +primOpIds :: Array Int Id +-- A cache of the PrimOp Ids, indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps ] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op + +{- +************************************************************************ +* * +\subsection{Export lists for pseudo-modules (GHC.Prim)} +* * +************************************************************************ + +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids. +-} + +ghcPrimExports :: [IfaceExport] +ghcPrimExports + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName . primOpId) allThePrimOps ++ + [ AvailTC n [n] + | tc <- funTyCon : primTyCons, let n = tyConName tc ] + +{- +************************************************************************ +* * +\subsection{Built-in keys} +* * +************************************************************************ + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +-} + +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey + +{- +************************************************************************ +* * +\subsection{Class predicates} +* * +************************************************************************ +-} + +isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys + +is_elem :: Eq a => a -> [a] -> Bool +is_elem = isIn "is_X_Class" diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs new file mode 100644 index 00000000..168578d8 --- /dev/null +++ b/compiler/prelude/PrelNames.hs @@ -0,0 +1,1956 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrelNames]{Definitions of prelude modules and names} + + +Nota Bene: all Names defined in here should come from the base package + + - ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName + + - Modules for prelude modules + e.g. pREL_Base :: Module + + - Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique + + - Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The may way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + + - RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). It's not necessary to know + the uniques for these guys, only their names + + +Note [Known-key names] +~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: + + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques + + 2. When we read an interface file, the read-in gubbins better have + the right uniques + +This is accomplished through a combination of mechanisms: + + 1. When parsing source code, the RdrName-decorated AST has some + RdrNames which are Exact. These are wired-in RdrNames where the + we could directly tell from the parsed syntax what Name to + use. For example, when we parse a [] in a type we can just insert + an Exact RdrName Name with the listTyConKey. + + Currently, I believe this is just an optimisation: it would be + equally valid to just output Orig RdrNames that correctly record + the module etc we expect the final Name to come from. However, + were we to eliminate isBuiltInOcc_maybe it would become essential + (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + TysWiredIn) are used to initialise the "OrigNameCache" in + IfaceEnv. This initialization ensures that when the type checker + or renamer (both of which use IfaceEnv) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples), we have + to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, we have to + rely on never having to look them up in that cache. + + This is accomplished through a variety of mechanisms: + + a) The parser recognises them specially and generates an + Exact Name (hence not looked up in the orig-name cache) + + b) The known infinite families of names are specially + serialised by BinIface.putName, with that special treatment + detected when we read back to ensure that we get back to the + correct uniques. + + Most of the infinite families cannot occur in source code, + so mechanisms (a,b) sufficies to ensure that they always have + the right Unique. In particular, implicit param TyCon names, + constraint tuples and Any TyCons cannot be mentioned by the + user. + + c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map + built-in syntax directly onto the corresponding name, rather + than trying to find it in the original-name cache. + + See also Note [Built-in syntax and the OrigNameCache] +-} + +{-# LANGUAGE CPP #-} + +module PrelNames ( + Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) where + +#include "HsVersions.h" + +import Module +import OccName +import RdrName +import Unique +import BasicTypes +import Name +import SrcLoc +import FastString +import Config ( cIntegerLibraryType, IntegerLibrary(..) ) +import Panic ( panic ) + +{- +************************************************************************ +* * + allNameStrings +* * +************************************************************************ +-} + +allNameStrings :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] + +{- +************************************************************************ +* * +\subsection{Local Names} +* * +************************************************************************ + +This *local* name is used by the interactive stuff +-} + +itName :: Unique -> SrcSpan -> Name +itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcSpan + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey + +{- +************************************************************************ +* * +\subsection{Known key Names} +* * +************************************************************************ + +This section tells what the compiler knows about the association of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in TysWiredIn etc. + +The names for DPH can come from one of multiple backend packages. At the point where +'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list +the names for multiple backends. That works out fine, although they use the same uniques, +as we are guaranteed to only load one backend; hence, only one of the different names +sharing a unique will be used. +-} + +basicKnownKeyNames :: [Name] +basicKnownKeyNames + = genericTyConNames + ++ [ -- Type constructors (synonyms especially) + ioTyConName, ioDataConName, + runMainIOName, + rationalTyConName, + stringTyConName, + ratioDataConName, + ratioTyConName, + integerTyConName, + + -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + alternativeClassName, + foldableClassName, + traversableClassName, + + -- Typeable + typeableClassName, + typeRepTyConName, + mkTyConName, + mkPolyTyConAppName, + mkAppTyName, + typeLitTypeRepName, + + + -- Numeric stuff + negateName, minusName, geName, eqName, + + -- Conversion functions + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, + + -- String stuff + fromStringName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Applicative/Alternative stuff + pureAName, + apAName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, + failMName, bindMName, thenMName, returnMName, + fmapName, + joinMName, + + -- MonadRec stuff + mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- GHC Extensions + groupWithName, + + -- Strings and lists + unpackCStringName, + unpackCStringFoldrName, unpackCStringUtf8Name, + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word8TyConName, word16TyConName, word32TyConName, word64TyConName, + + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, breakpointName, breakpointCondName, + breakpointAutoName, opaqueTyConName, + assertErrorName, runSTRepName, + printName, fstName, sndName, + + -- Integer + integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, + plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, + absIntegerName, signumIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, + compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName, + + -- Float/Double + rationalToFloatName, + rationalToDoubleName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Other classes + randomClassName, randomGenClassName, monadPlusClassName, + + -- Type-level naturals + knownNatClassName, knownSymbolClassName, + + -- Implicit parameters + ipClassName, + + -- Source locations + callStackDataConName, callStackTyConName, + srcLocDataConName, + + -- Annotation type checking + toAnnotationWrapperName + + -- The Ordering type + , orderingTyConName, ltDataConName, eqDataConName, gtDataConName + + -- The SPEC type for SpecConstr + , specTyConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- Plugins + , pluginTyConName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName + + -- StaticPtr + , staticPtrTyConName + , staticPtrDataConName, staticPtrInfoDataConName + + -- Fingerprint + , fingerprintDataConName + + ] ++ case cIntegerLibraryType of + IntegerGMP -> [integerSDataConName] + IntegerGMP2 -> [integerSDataConName] + IntegerSimple -> [] + +genericTyConNames :: [Name] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName + ] + +{- +************************************************************************ +* * +\subsection{Module names} +* * +************************************************************************ + + +--MetaHaskell Extension Add a new module here +-} + +pRELUDE :: Module +pRELUDE = mkBaseModule_ pRELUDE_NAME + +gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, + gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, + gHC_CONC, gHC_IO, gHC_IO_Exception, + gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, + tYPEABLE, tYPEABLE_INTERNAL, gENERICS, + rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module + +gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values +gHC_TYPES = mkPrimModule (fsLit "GHC.Types") +gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") +gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") +gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") + +gHC_BASE = mkBaseModule (fsLit "GHC.Base") +gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") +gHC_SHOW = mkBaseModule (fsLit "GHC.Show") +gHC_READ = mkBaseModule (fsLit "GHC.Read") +gHC_NUM = mkBaseModule (fsLit "GHC.Num") +gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") +gHC_LIST = mkBaseModule (fsLit "GHC.List") +gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") +dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_STRING = mkBaseModule (fsLit "Data.String") +dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") +dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") +dATA_MONOID = mkBaseModule (fsLit "Data.Monoid") +gHC_CONC = mkBaseModule (fsLit "GHC.Conc") +gHC_IO = mkBaseModule (fsLit "GHC.IO") +gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") +gHC_ST = mkBaseModule (fsLit "GHC.ST") +gHC_ARR = mkBaseModule (fsLit "GHC.Arr") +gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") +gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") +gHC_ERR = mkBaseModule (fsLit "GHC.Err") +gHC_REAL = mkBaseModule (fsLit "GHC.Real") +gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") +gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") +sYSTEM_IO = mkBaseModule (fsLit "System.IO") +dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") +gENERICS = mkBaseModule (fsLit "Data.Data") +rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") +lEX = mkBaseModule (fsLit "Text.Read.Lex") +gHC_INT = mkBaseModule (fsLit "GHC.Int") +gHC_WORD = mkBaseModule (fsLit "GHC.Word") +mONAD = mkBaseModule (fsLit "Control.Monad") +mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") +aRROW = mkBaseModule (fsLit "Control.Arrow") +cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") +gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") +rANDOM = mkBaseModule (fsLit "System.Random") +gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") +cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") +gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") +gHC_IP = mkBaseModule (fsLit "GHC.IP") + +gHC_PARR' :: Module +gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") + +gHC_SRCLOC :: Module +gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") + +gHC_STACK :: Module +gHC_STACK = mkBaseModule (fsLit "GHC.Stack") + +gHC_STATICPTR :: Module +gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") + +gHC_FINGERPRINT_TYPE :: Module +gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") + +mAIN, rOOT_MAIN :: Module +mAIN = mkMainModule_ mAIN_NAME +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation + +mkInteractiveModule :: Int -> Module +-- (mkInteractiveMoudule 9) makes module 'interactive:M9' +mkInteractiveModule n = mkModule interactivePackageKey (mkModuleName ("Ghci" ++ show n)) + +pRELUDE_NAME, mAIN_NAME :: ModuleName +pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") +mAIN_NAME = mkModuleNameFS (fsLit "Main") + +dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName +dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") +dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") + +mkPrimModule :: FastString -> Module +mkPrimModule m = mkModule primPackageKey (mkModuleNameFS m) + +mkIntegerModule :: FastString -> Module +mkIntegerModule m = mkModule integerPackageKey (mkModuleNameFS m) + +mkBaseModule :: FastString -> Module +mkBaseModule m = mkModule basePackageKey (mkModuleNameFS m) + +mkBaseModule_ :: ModuleName -> Module +mkBaseModule_ m = mkModule basePackageKey m + +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkModule thisGhcPackageKey (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcPackageKey m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainPackageKey (mkModuleNameFS m) + +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainPackageKey m + +{- +************************************************************************ +* * +\subsection{Constructing the names of tuples +* * +************************************************************************ +-} + +mkTupleModule :: TupleSort -> Module +mkTupleModule BoxedTuple = gHC_TUPLE +mkTupleModule ConstraintTuple = gHC_TUPLE +mkTupleModule UnboxedTuple = gHC_PRIM + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +forall_tv_RDR, dot_tv_RDR :: RdrName +forall_tv_RDR = mkUnqual tvName (fsLit "forall") +dot_tv_RDR = mkUnqual tvName (fsLit ".") + +eq_RDR, ge_RDR, ne_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +ne_RDR = varQual_RDR gHC_CLASSES (fsLit "/=") +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = dataQual_RDR gHC_TYPES (fsLit "LT") +eqTag_RDR = dataQual_RDR gHC_TYPES (fsLit "EQ") +gtTag_RDR = dataQual_RDR gHC_TYPES (fsLit "GT") + +eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR + :: RdrName +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName + +map_RDR, append_RDR :: RdrName +map_RDR = varQual_RDR gHC_BASE (fsLit "map") +append_RDR = varQual_RDR gHC_BASE (fsLit "++") + +foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +left_RDR, right_RDR :: RdrName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR, toEnum_RDR :: RdrName +fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") + +enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName + +ioDataCon_RDR :: RdrName +ioDataCon_RDR = nameRdrName ioDataConName + +eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, + unpackCStringUtf8_RDR :: RdrName +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name + +newStablePtr_RDR :: RdrName +newStablePtr_RDR = nameRdrName newStablePtrName + +bindIO_RDR, returnIO_RDR :: RdrName +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName + +fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR gHC_NUM (fsLit "*") +plus_RDR = varQual_RDR gHC_NUM (fsLit "+") + +fromString_RDR :: RdrName +fromString_RDR = nameRdrName fromStringName + +fromList_RDR, fromListN_RDR, toList_RDR :: RdrName +fromList_RDR = nameRdrName fromListName +fromListN_RDR = nameRdrName fromListNName +toList_RDR = nameRdrName toListName + +compose_RDR :: RdrName +compose_RDR = varQual_RDR gHC_BASE (fsLit ".") + +not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, + and_RDR, range_RDR, inRange_RDR, index_RDR, + unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") +succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") +pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") +minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") +maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") +range_RDR = varQual_RDR gHC_ARR (fsLit "range") +inRange_RDR = varQual_RDR gHC_ARR (fsLit "inRange") +index_RDR = varQual_RDR gHC_ARR (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize") + +readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, + readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName +readList_RDR = varQual_RDR gHC_READ (fsLit "readList") +readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") +readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") +parens_RDR = varQual_RDR gHC_READ (fsLit "parens") +choose_RDR = varQual_RDR gHC_READ (fsLit "choose") +lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") +expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") + +punc_RDR, ident_RDR, symbol_RDR :: RdrName +punc_RDR = dataQual_RDR lEX (fsLit "Punc") +ident_RDR = dataQual_RDR lEX (fsLit "Ident") +symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") + +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName +step_RDR = varQual_RDR rEAD_PREC (fsLit "step") +alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") +reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") +prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") +pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") + +showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, + showSpace_RDR, showParen_RDR :: RdrName +showList_RDR = varQual_RDR gHC_SHOW (fsLit "showList") +showList___RDR = varQual_RDR gHC_SHOW (fsLit "showList__") +showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") +showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") +showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") +showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") + +typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName +typeRep_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeRep#") +mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") +mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp") + +undefined_RDR :: RdrName +undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") + +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, isNewtypeName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, + noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + +unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") +unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") +unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") +unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") + +from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") +isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") +selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") + +noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity") +arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity") +prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") +rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") +notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") + + +fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR, + traverse_RDR, mempty_RDR, mappend_RDR :: RdrName +fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") +pure_RDR = nameRdrName pureAName +ap_RDR = nameRdrName apAName +foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") +foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") +traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") +mempty_RDR = varQual_RDR gHC_BASE (fsLit "mempty") +mappend_RDR = varQual_RDR gHC_BASE (fsLit "mappend") + +---------------------- +varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR + :: Module -> FastString -> RdrName +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) + +{- +************************************************************************ +* * +\subsection{Known-key names} +* * +************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. + +--MetaHaskell Extension add the constrs and the lower case case +-- guys as well (perhaps) e.g. see trueDataConName below +-} + +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + +runMainIOName :: Name +runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey + +orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name +orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey +ltDataConName = conName gHC_TYPES (fsLit "LT") ltDataConKey +eqDataConName = conName gHC_TYPES (fsLit "EQ") eqDataConKey +gtDataConName = conName gHC_TYPES (fsLit "GT") gtDataConKey + +specTyConName :: Name +specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey + +eitherTyConName, leftDataConName, rightDataConName :: Name +eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey +leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey +rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey + +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName :: Name + +v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey +pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey +dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey +par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey +d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey +noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + +repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey + +-- Base strings Strings +unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName, stringTyConName :: Name +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey +stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey + +-- The 'inline' function +inlineIdName :: Name +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey + +-- Base classes (Eq, Ord, Functor) +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey + +-- Class Monad +monadClassName, thenMName, bindMName, returnMName, failMName :: Name +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey +failMName = varQual gHC_BASE (fsLit "fail") failMClassOpKey + +-- Classes (Applicative, Foldable, Traversable) +applicativeClassName, foldableClassName, traversableClassName :: Name +applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey +foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey +traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey + + + +-- AMP additions + +joinMName, apAName, pureAName, alternativeClassName :: Name +joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey +apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey +pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey +alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey + +joinMIdKey, apAClassOpKey, pureAClassOpKey, alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +alternativeClassKey = mkPreludeMiscIdUnique 753 + + +-- Functions for GHC extensions +groupWithName :: Name +groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey + +-- Random PrelBase functions +fromStringName, otherwiseIdName, foldrName, buildName, augmentName, + mapName, appendName, assertName, + breakpointName, breakpointCondName, breakpointAutoName, + opaqueTyConName :: Name +fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey +otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey +foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey +mapName = varQual gHC_BASE (fsLit "map") mapIdKey +appendName = varQual gHC_BASE (fsLit "++") appendIdKey +assertName = varQual gHC_BASE (fsLit "assert") assertIdKey +breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey +breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey +breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey +opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey + +breakpointJumpName :: Name +breakpointJumpName + = mkInternalName + breakpointJumpIdKey + (mkOccNameFS varName (fsLit "breakpointJump")) + noSrcSpan +breakpointCondJumpName :: Name +breakpointCondJumpName + = mkInternalName + breakpointCondJumpIdKey + (mkOccNameFS varName (fsLit "breakpointCondJump")) + noSrcSpan +breakpointAutoJumpName :: Name +breakpointAutoJumpName + = mkInternalName + breakpointAutoJumpIdKey + (mkOccNameFS varName (fsLit "breakpointAutoJump")) + noSrcSpan + +-- PrelTup +fstName, sndName :: Name +fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey +sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey + +-- Module GHC.Num +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey + +integerTyConName, mkIntegerName, integerSDataConName, + integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, + plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, + absIntegerName, signumIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, + compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName :: Name +integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey +integerSDataConName = conName gHC_INTEGER_TYPE (fsLit n) integerSDataConKey + where n = case cIntegerLibraryType of + IntegerGMP -> "S#" + IntegerGMP2 -> "S#" + IntegerSimple -> panic "integerSDataConName evaluated for integer-simple" +mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey +integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey +integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey +word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey +int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey +plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey +smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey +wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey +integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey +integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey +minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey +negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey +eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey +neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey +absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey +signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey +leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey +gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey +ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey +geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey +compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey +quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey +divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey +quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey +remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey +divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey +modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey +floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey +doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey +encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey +encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey +decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey +gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey +lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey +andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey +orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey +xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey +complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey +shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey +shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey + +-- GHC.Real types and classes +rationalTyConName, ratioTyConName, ratioDataConName, realClassName, + integralClassName, realFracClassName, fractionalClassName, + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName :: Name +rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey + +-- PrelFloat classes +floatingClassName, realFloatClassName :: Name +floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey + +-- other GHC.Float functions +rationalToFloatName, rationalToDoubleName :: Name +rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + +-- Class Ix +ixClassName :: Name +ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +typeableClassName + , typeRepTyConName + , mkTyConName + , mkPolyTyConAppName + , mkAppTyName + , typeLitTypeRepName + :: Name +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +mkTyConName = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon") mkTyConKey +mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey +mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey +typeLitTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey + + + +-- Class Data +dataClassName :: Name +dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey + +-- Error module +assertErrorName :: Name +assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey + +-- Enum module (Enum, Bounded) +enumClassName, enumFromName, enumFromToName, enumFromThenName, + enumFromThenToName, boundedClassName :: Name +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey + +-- List functions +concatName, filterName, zipName :: Name +concatName = varQual gHC_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey + +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey + +-- Class Show +showClassName :: Name +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey + +-- Class Read +readClassName :: Name +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey + +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + +-- IO things +ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, + failIOName :: Name +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey + +-- IO things +printName :: Name +printName = varQual sYSTEM_IO (fsLit "print") printIdKey + +-- Int, Word, and Addr things +int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name +int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey +int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey +int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey +int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey + +-- Word module +word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name +word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey +word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey +word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey +word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey + +-- PrelPtr module +ptrTyConName, funPtrTyConName :: Name +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName, newStablePtrName :: Name +stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey + +-- PrelST module +runSTRepName :: Name +runSTRepName = varQual gHC_ST (fsLit "runSTRep") runSTRepIdKey + +-- Recursive-do notation +monadFixClassName, mfixName :: Name +monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey +mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey + +-- Arrow notation +arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name +arrAName = varQual aRROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey + +-- Monad comprehensions +guardMName, liftMName, mzipName :: Name +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + +-- Annotation type checking +toAnnotationWrapperName :: Name +toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName, randomClassName, randomGenClassName, + isStringClassName :: Name +monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey +randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey +isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey + +-- Type-level naturals +knownNatClassName :: Name +knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNameKey +knownSymbolClassName :: Name +knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey + +-- Implicit parameters +ipClassName :: Name +ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey + +-- Source Locations +callStackDataConName, callStackTyConName, srcLocDataConName :: Name +callStackDataConName + = conName gHC_STACK (fsLit "CallStack") callStackDataConKey +callStackTyConName + = tcQual gHC_STACK (fsLit "CallStack") callStackTyConKey +srcLocDataConName + = conName gHC_SRCLOC (fsLit "SrcLoc") srcLocDataConKey + +-- plugins +pLUGINS :: Module +pLUGINS = mkThisGhcModule (fsLit "Plugins") +pluginTyConName :: Name +pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey + +-- Static pointers +staticPtrInfoTyConName :: Name +staticPtrInfoTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey + +staticPtrInfoDataConName :: Name +staticPtrInfoDataConName = + conName gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey + +staticPtrTyConName :: Name +staticPtrTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey + +staticPtrDataConName :: Name +staticPtrDataConName = + conName gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey + +fingerprintDataConName :: Name +fingerprintDataConName = + conName gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey + +{- +************************************************************************ +* * +\subsection{Local helpers} +* * +************************************************************************ + +All these are original names; hence mkOrig +-} + +varQual, tcQual, clsQual :: Module -> FastString -> Unique -> Name +varQual = mk_known_key_name varName +tcQual = mk_known_key_name tcName +clsQual = mk_known_key_name clsName + +mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name +mk_known_key_name space modu str unique + = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan + +conName :: Module -> FastString -> Unique -> Name +conName modu occ unique + = mkExternalName unique modu (mkOccNameFS dataName occ) noSrcSpan + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +* * +************************************************************************ +--MetaHaskell extension hand allocate keys here +-} + +boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, + fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, + functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, + realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, + typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey + :: Unique +typeableClassKey = mkPreludeClassUnique 20 +typeable1ClassKey = mkPreludeClassUnique 21 +typeable2ClassKey = mkPreludeClassUnique 22 +typeable3ClassKey = mkPreludeClassUnique 23 +typeable4ClassKey = mkPreludeClassUnique 24 +typeable5ClassKey = mkPreludeClassUnique 25 +typeable6ClassKey = mkPreludeClassUnique 26 +typeable7ClassKey = mkPreludeClassUnique 27 + +monadFixClassKey :: Unique +monadFixClassKey = mkPreludeClassUnique 28 + +monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 + +isStringClassKey :: Unique +isStringClassKey = mkPreludeClassUnique 33 + +applicativeClassKey, foldableClassKey, traversableClassKey :: Unique +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 + +-- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence +knownNatClassNameKey :: Unique +knownNatClassNameKey = mkPreludeClassUnique 42 + +-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence +knownSymbolClassNameKey :: Unique +knownSymbolClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 + +ipClassNameKey :: Unique +ipClassNameKey = mkPreludeClassUnique 45 + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +* * +************************************************************************ +-} + +addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, + charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, + floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, + intTyConKey, int8TyConKey, int16TyConKey, int32PrimTyConKey, + int32TyConKey, int64PrimTyConKey, int64TyConKey, + integerTyConKey, + listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, + mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, + orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, + realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, + anyTyConKey, eqTyConKey, smallArrayPrimTyConKey, + smallMutableArrayPrimTyConKey :: Unique +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +funTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8TyConKey = mkPreludeTyConUnique 16 +int16TyConKey = mkPreludeTyConUnique 17 +int32PrimTyConKey = mkPreludeTyConUnique 18 +int32TyConKey = mkPreludeTyConUnique 19 +int64PrimTyConKey = mkPreludeTyConUnique 20 +int64TyConKey = mkPreludeTyConUnique 21 +integerTyConKey = mkPreludeTyConUnique 22 + +listTyConKey = mkPreludeTyConUnique 24 +foreignObjPrimTyConKey = mkPreludeTyConUnique 25 +weakPrimTyConKey = mkPreludeTyConUnique 27 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 +orderingTyConKey = mkPreludeTyConUnique 30 +mVarPrimTyConKey = mkPreludeTyConUnique 31 +ratioTyConKey = mkPreludeTyConUnique 32 +rationalTyConKey = mkPreludeTyConUnique 33 +realWorldTyConKey = mkPreludeTyConUnique 34 +stablePtrPrimTyConKey = mkPreludeTyConUnique 35 +stablePtrTyConKey = mkPreludeTyConUnique 36 +anyTyConKey = mkPreludeTyConUnique 37 +eqTyConKey = mkPreludeTyConUnique 38 +arrayArrayPrimTyConKey = mkPreludeTyConUnique 39 +mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 40 + +statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, + mutVarPrimTyConKey, ioTyConKey, + wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey, + word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, + liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, + typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey, voidPrimTyConKey :: Unique +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 +mutVarPrimTyConKey = mkPreludeTyConUnique 55 +ioTyConKey = mkPreludeTyConUnique 56 +voidPrimTyConKey = mkPreludeTyConUnique 57 +wordPrimTyConKey = mkPreludeTyConUnique 58 +wordTyConKey = mkPreludeTyConUnique 59 +word8TyConKey = mkPreludeTyConUnique 60 +word16TyConKey = mkPreludeTyConUnique 61 +word32PrimTyConKey = mkPreludeTyConUnique 62 +word32TyConKey = mkPreludeTyConUnique 63 +word64PrimTyConKey = mkPreludeTyConUnique 64 +word64TyConKey = mkPreludeTyConUnique 65 +liftedConKey = mkPreludeTyConUnique 66 +unliftedConKey = mkPreludeTyConUnique 67 +anyBoxConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 69 +boxityConKey = mkPreludeTyConUnique 70 +typeConKey = mkPreludeTyConUnique 71 +threadIdPrimTyConKey = mkPreludeTyConUnique 72 +bcoPrimTyConKey = mkPreludeTyConUnique 73 +ptrTyConKey = mkPreludeTyConUnique 74 +funPtrTyConKey = mkPreludeTyConUnique 75 +tVarPrimTyConKey = mkPreludeTyConUnique 76 + +-- Parallel array type constructor +parrTyConKey :: Unique +parrTyConKey = mkPreludeTyConUnique 82 + +-- dotnet interop +objectTyConKey :: Unique +objectTyConKey = mkPreludeTyConUnique 83 + +eitherTyConKey :: Unique +eitherTyConKey = mkPreludeTyConUnique 84 + +-- Super Kinds constructors +superKindTyConKey :: Unique +superKindTyConKey = mkPreludeTyConUnique 85 + +-- Kind constructors +liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, + unliftedTypeKindTyConKey, constraintKindTyConKey :: Unique +anyKindTyConKey = mkPreludeTyConUnique 86 +liftedTypeKindTyConKey = mkPreludeTyConUnique 87 +openTypeKindTyConKey = mkPreludeTyConUnique 88 +unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 +constraintKindTyConKey = mkPreludeTyConUnique 92 + +-- Coercion constructors +symCoercionTyConKey, transCoercionTyConKey, leftCoercionTyConKey, + rightCoercionTyConKey, instCoercionTyConKey, unsafeCoercionTyConKey, + csel1CoercionTyConKey, csel2CoercionTyConKey, cselRCoercionTyConKey + :: Unique +symCoercionTyConKey = mkPreludeTyConUnique 93 +transCoercionTyConKey = mkPreludeTyConUnique 94 +leftCoercionTyConKey = mkPreludeTyConUnique 95 +rightCoercionTyConKey = mkPreludeTyConUnique 96 +instCoercionTyConKey = mkPreludeTyConUnique 97 +unsafeCoercionTyConKey = mkPreludeTyConUnique 98 +csel1CoercionTyConKey = mkPreludeTyConUnique 99 +csel2CoercionTyConKey = mkPreludeTyConUnique 100 +cselRCoercionTyConKey = mkPreludeTyConUnique 101 + +pluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 + +unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, + opaqueTyConKey :: Unique +unknownTyConKey = mkPreludeTyConUnique 129 +unknown1TyConKey = mkPreludeTyConUnique 130 +unknown2TyConKey = mkPreludeTyConUnique 131 +unknown3TyConKey = mkPreludeTyConUnique 132 +opaqueTyConKey = mkPreludeTyConUnique 133 + +stringTyConKey :: Unique +stringTyConKey = mkPreludeTyConUnique 134 + +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, pTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + repTyConKey, rep1TyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +pTyConKey = mkPreludeTyConUnique 145 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +par0TyConKey = mkPreludeTyConUnique 150 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 +noSelTyConKey = mkPreludeTyConUnique 154 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + +-- Type-level naturals +typeNatKindConNameKey, typeSymbolKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, + typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey + :: Unique +typeNatKindConNameKey = mkPreludeTyConUnique 160 +typeSymbolKindConNameKey = mkPreludeTyConUnique 161 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 162 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 163 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 164 +typeNatLeqTyFamNameKey = mkPreludeTyConUnique 165 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 166 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 168 + +ntTyConKey:: Unique +ntTyConKey = mkPreludeTyConUnique 174 +coercibleTyConKey :: Unique +coercibleTyConKey = mkPreludeTyConUnique 175 + +proxyPrimTyConKey :: Unique +proxyPrimTyConKey = mkPreludeTyConUnique 176 + +specTyConKey :: Unique +specTyConKey = mkPreludeTyConUnique 177 + +smallArrayPrimTyConKey = mkPreludeTyConUnique 178 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179 + +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 180 + +staticPtrInfoTyConKey :: Unique +staticPtrInfoTyConKey = mkPreludeTyConUnique 181 + +typeRepTyConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 183 + +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 182 + +---------------- Template Haskell ------------------- +-- USES TyConUniques 200-299 +----------------------------------------------------- + +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + +unitTyConKey :: Unique +unitTyConKey = mkTupleTyConUnique BoxedTuple 0 + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +* * +************************************************************************ +-} + +charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, + floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, + ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, + ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +integerSDataConKey = mkPreludeDataConUnique 7 +nilDataConKey = mkPreludeDataConUnique 11 +ratioDataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 14 +trueDataConKey = mkPreludeDataConUnique 15 +wordDataConKey = mkPreludeDataConUnique 16 +ioDataConKey = mkPreludeDataConUnique 17 +integerDataConKey = mkPreludeDataConUnique 18 +eqBoxDataConKey = mkPreludeDataConUnique 19 + +-- Generic data constructors +crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +-- Data constructor for parallel arrays +parrDataConKey :: Unique +parrDataConKey = mkPreludeDataConUnique 24 + +leftDataConKey, rightDataConKey :: Unique +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ltDataConKey, eqDataConKey, gtDataConKey :: Unique +ltDataConKey = mkPreludeDataConUnique 27 +eqDataConKey = mkPreludeDataConUnique 28 +gtDataConKey = mkPreludeDataConUnique 29 + +coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticPtrInfoDataConKey :: Unique +staticPtrInfoDataConKey = mkPreludeDataConUnique 34 + +fingerprintDataConKey :: Unique +fingerprintDataConKey = mkPreludeDataConUnique 35 + +callStackDataConKey, srcLocDataConKey :: Unique +callStackDataConKey = mkPreludeDataConUnique 36 +srcLocDataConKey = mkPreludeDataConUnique 37 + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +* * +************************************************************************ +-} + +wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, irrefutPatErrorIdKey, eqStringIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, + runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, + realWorldPrimIdKey, recConErrorIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendIdKey, + unpackCStringFoldrIdKey, unpackCStringIdKey :: Unique +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +augmentIdKey = mkPreludeMiscIdUnique 2 +appendIdKey = mkPreludeMiscIdUnique 3 +buildIdKey = mkPreludeMiscIdUnique 4 +errorIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +irrefutPatErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +runtimeErrorIdKey = mkPreludeMiscIdUnique 13 +patErrorIdKey = mkPreludeMiscIdUnique 14 +realWorldPrimIdKey = mkPreludeMiscIdUnique 15 +recConErrorIdKey = mkPreludeMiscIdUnique 16 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 +unpackCStringIdKey = mkPreludeMiscIdUnique 20 +voidPrimIdKey = mkPreludeMiscIdUnique 21 + +unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, + returnIOIdKey, newStablePtrIdKey, + printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, + fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey, runSTRepIdKey :: Unique +unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +fstIdKey = mkPreludeMiscIdUnique 41 +sndIdKey = mkPreludeMiscIdUnique 42 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 +runSTRepIdKey = mkPreludeMiscIdUnique 45 + +mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, + integerToWordIdKey, integerToIntIdKey, + integerToWord64IdKey, integerToInt64IdKey, + word64ToIntegerIdKey, int64ToIntegerIdKey, + plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, + negateIntegerIdKey, + eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, + leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, + compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, + floatFromIntegerIdKey, doubleFromIntegerIdKey, + encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, + decodeDoubleIntegerIdKey, + gcdIntegerIdKey, lcmIntegerIdKey, + andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, + shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique +mkIntegerIdKey = mkPreludeMiscIdUnique 60 +smallIntegerIdKey = mkPreludeMiscIdUnique 61 +integerToWordIdKey = mkPreludeMiscIdUnique 62 +integerToIntIdKey = mkPreludeMiscIdUnique 63 +integerToWord64IdKey = mkPreludeMiscIdUnique 64 +integerToInt64IdKey = mkPreludeMiscIdUnique 65 +plusIntegerIdKey = mkPreludeMiscIdUnique 66 +timesIntegerIdKey = mkPreludeMiscIdUnique 67 +minusIntegerIdKey = mkPreludeMiscIdUnique 68 +negateIntegerIdKey = mkPreludeMiscIdUnique 69 +eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 +neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 +absIntegerIdKey = mkPreludeMiscIdUnique 72 +signumIntegerIdKey = mkPreludeMiscIdUnique 73 +leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 +gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 +ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 +geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 +compareIntegerIdKey = mkPreludeMiscIdUnique 78 +quotIntegerIdKey = mkPreludeMiscIdUnique 79 +remIntegerIdKey = mkPreludeMiscIdUnique 80 +divIntegerIdKey = mkPreludeMiscIdUnique 81 +modIntegerIdKey = mkPreludeMiscIdUnique 82 +divModIntegerIdKey = mkPreludeMiscIdUnique 83 +quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 +floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 +doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 +encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 +encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 +gcdIntegerIdKey = mkPreludeMiscIdUnique 89 +lcmIntegerIdKey = mkPreludeMiscIdUnique 90 +andIntegerIdKey = mkPreludeMiscIdUnique 91 +orIntegerIdKey = mkPreludeMiscIdUnique 92 +xorIntegerIdKey = mkPreludeMiscIdUnique 93 +complementIntegerIdKey = mkPreludeMiscIdUnique 94 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 +wordToIntegerIdKey = mkPreludeMiscIdUnique 97 +word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 +int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 +decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 + +rootMainKey, runMainKey :: Unique +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 + +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey :: Unique +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 +oneShotKey = mkPreludeMiscIdUnique 106 + +breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey, + breakpointJumpIdKey, breakpointCondJumpIdKey, + breakpointAutoJumpIdKey :: Unique +breakpointIdKey = mkPreludeMiscIdUnique 110 +breakpointCondIdKey = mkPreludeMiscIdUnique 111 +breakpointAutoIdKey = mkPreludeMiscIdUnique 112 +breakpointJumpIdKey = mkPreludeMiscIdUnique 113 +breakpointCondJumpIdKey = mkPreludeMiscIdUnique 114 +breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 115 + +inlineIdKey :: Unique +inlineIdKey = mkPreludeMiscIdUnique 120 + +mapIdKey, groupWithIdKey, dollarIdKey :: Unique +mapIdKey = mkPreludeMiscIdUnique 121 +groupWithIdKey = mkPreludeMiscIdUnique 122 +dollarIdKey = mkPreludeMiscIdUnique 123 + +coercionTokenIdKey :: Unique +coercionTokenIdKey = mkPreludeMiscIdUnique 124 + +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 130 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 + +-- dotnet interop +unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, + unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique +unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 +marshalObjectIdKey = mkPreludeMiscIdUnique 151 +marshalStringIdKey = mkPreludeMiscIdUnique 152 +unmarshalStringIdKey = mkPreludeMiscIdUnique 153 +checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 + +undefinedKey :: Unique +undefinedKey = mkPreludeMiscIdUnique 155 + +magicDictKey :: Unique +magicDictKey = mkPreludeMiscIdUnique 156 + +coerceKey :: Unique +coerceKey = mkPreludeMiscIdUnique 157 + +{- +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. +-} + + -- Just a place holder for unbound variables produced by the renamer: +unboundKey :: Unique +unboundKey = mkPreludeMiscIdUnique 160 + +fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, + enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, + enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, + failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, + fmapClassOpKey + :: Unique +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +failMClassOpKey = mkPreludeMiscIdUnique 170 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 + +-- Recursive do notation +mfixIdKey :: Unique +mfixIdKey = mkPreludeMiscIdUnique 175 + +-- Arrow notation +arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, + loopAIdKey :: Unique +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 + +fromStringClassOpKey :: Unique +fromStringClassOpKey = mkPreludeMiscIdUnique 186 + +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 + +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +mzipIdKey = mkPreludeMiscIdUnique 196 + +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 + +proxyHashKey :: Unique +proxyHashKey = mkPreludeMiscIdUnique 502 + +---------------- Template Haskell ------------------- +-- USES IdUniques 200-499 +----------------------------------------------------- + +-- Used to make `Typeable` dictionaries +mkTyConKey + , mkPolyTyConAppKey + , mkAppTyKey + , typeLitTypeRepKey + :: Unique +mkTyConKey = mkPreludeMiscIdUnique 503 +mkPolyTyConAppKey = mkPreludeMiscIdUnique 504 +mkAppTyKey = mkPreludeMiscIdUnique 505 +typeLitTypeRepKey = mkPreludeMiscIdUnique 506 + + +{- +************************************************************************ +* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [Unique] +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [Unique] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [Unique] +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, + traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). +-} + +derivableClassKeys :: [Unique] +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot new file mode 100644 index 00000000..0bd74d55 --- /dev/null +++ b/compiler/prelude/PrelNames.hs-boot @@ -0,0 +1,7 @@ +module PrelNames where + +import Module +import Unique + +mAIN :: Module +liftedTypeKindTyConKey :: Unique diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs new file mode 100644 index 00000000..12738dd4 --- /dev/null +++ b/compiler/prelude/PrelRules.hs @@ -0,0 +1,1345 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ConFold]{Constant Folder} + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. +-} + +{-# LANGUAGE CPP, RankNTypes #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} + +module PrelRules ( primOpRules, builtinRules ) where + +#include "HsVersions.h" +#include "../includes/MachDeps.h" + +import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) + +import CoreSyn +import MkCore +import Id +import Literal +import CoreSubst ( exprIsLiteral_maybe ) +import PrimOp ( PrimOp(..), tagToEnumKey ) +import TysWiredIn +import TysPrim +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe ) +import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) +import CoreUtils ( cheapEqExpr, exprIsHNF ) +import CoreUnfold ( exprIsConApp_maybe ) +import Type +import TypeRep +import OccName ( occNameFS ) +import PrelNames +import Maybes ( orElse ) +import Name ( Name, nameOccName ) +import Outputable +import FastString +import BasicTypes +import DynFlags +import Platform +import Util +import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) + +#if __GLASGOW_HASKELL__ >= 709 +import Control.Applicative ( Alternative(..) ) +#else +import Control.Applicative ( Applicative(..), Alternative(..) ) +#endif + +import Control.Monad +import Data.Bits as Bits +import qualified Data.ByteString as BS +import Data.Int +import Data.Ratio +import Data.Word + +{- +Note [Constant folding] +~~~~~~~~~~~~~~~~~~~~~~~ +primOpRules generates a rewrite rule for each primop +These rules do what is often called "constant folding" +E.g. the rules for +# might say + 4 +# 5 = 9 +Well, of course you'd need a lot of rules if you did it +like that, so we use a BuiltinRule instead, so that we +can match in any two literal values. So the rule is really +more like + (Lit x) +# (Lit y) = Lit (x+#y) +where the (+#) on the rhs is done at compile time + +That is why these rules are built in here. +-} + +primOpRules :: Name -> PrimOp -> Maybe CoreRule + -- ToDo: something for integer-shift ops? + -- NotOp +primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] +primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] + +-- Int operations +primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityDynFlags zeroi ] +primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityDynFlags zeroi + , equalArgs >> retLit zeroi ] +primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem zeroi + , identityDynFlags onei ] +primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero zeroi + , rightIdentityDynFlags onei + , equalArgs >> retLit onei ] +primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero zeroi + , do l <- getLiteral 1 + dflags <- getDynFlags + guard (l == onei dflags) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] +primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] +primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityDynFlags zeroi ] +primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityDynFlags zeroi + , equalArgs >> retLit zeroi ] +primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotIOp ] +primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] +primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) + , rightIdentityDynFlags zeroi ] +primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) + , rightIdentityDynFlags zeroi ] +primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical) + , rightIdentityDynFlags zeroi ] + +-- Word operations +primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityDynFlags zerow ] +primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityDynFlags zerow + , equalArgs >> retLit zerow ] +primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityDynFlags onew ] +primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityDynFlags onew ] +primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , rightIdentityDynFlags onew ] +primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem zerow ] +primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityDynFlags zerow ] +primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityDynFlags zerow + , equalArgs >> retLit zerow ] +primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotOp ] +primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ] +primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ] + +-- coercions +primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit + , inversePrimOp Int2WordOp ] +primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit + , inversePrimOp Word2IntOp ] +primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] +primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] +primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 ] +primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] +primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] +primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 ] +primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] +primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] +primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] +primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] +primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] +primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] +-- SUP: Not sure what the standard says about precision in the following 2 cases +primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] +primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] + +-- Float +primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] +primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] +primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + -- zeroElem zerof doesn't hold because of NaN +primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] +primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] + +-- Double +primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] +primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] +primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + -- zeroElem zerod doesn't hold because of NaN +primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] +primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] + +-- Relational operators + +primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] +primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] + +primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] + +primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] + +primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) +primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) +primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) +primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) +primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) +primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) + +primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) +primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) +primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) +primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) +primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) +primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) + +primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] +primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] + +primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] + +primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] +primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] + +primOpRules _ _ = Nothing + +{- +************************************************************************ +* * +\subsection{Doing the business} +* * +************************************************************************ +-} + +-- useful shorthands +mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule +mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) + +mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkRelOpRule nm cmp extra + = mkPrimOpRule nm 2 $ + binaryCmpLit cmp : equal_rule : extra + where + -- x `cmp` x does not depend on x, so + -- compute it for the arbitrary value 'True' + -- and use that result + equal_rule = do { equalArgs + ; dflags <- getDynFlags + ; return (if cmp True True + then trueValInt dflags + else falseValInt dflags) } + +{- Note [Rules for floating-point comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need different rules for floating-point values because for floats +it is not true that x = x (for NaNs); so we do not want the equal_rule +rule that mkRelOpRule uses. + +Note also that, in the case of equality/inequality, we do /not/ +want to switch to a case-expression. For example, we do not want +to convert + case (eqFloat# x 3.8#) of + True -> this + False -> that +to + case x of + 3.8#::Float# -> this + _ -> that +See Trac #9238. Reason: comparing floating-point values for equality +delicate, and we don't want to implement that delicacy in the code for +case expressions. So we make it an invariant of Core that a case +expression never scrutinises a Float# or Double#. + +This transformation is what the litEq rule does; +see Note [The litEq rule: converting equality to case]. +So we /refrain/ from using litEq for mkFloatingRelOpRule. +-} + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> Maybe CoreRule +-- See Note [Rules for floating-point comparisons] +mkFloatingRelOpRule nm cmp + = mkPrimOpRule nm 2 [binaryCmpLit cmp] + +-- common constants +zeroi, onei, zerow, onew :: DynFlags -> Literal +zeroi dflags = mkMachInt dflags 0 +onei dflags = mkMachInt dflags 1 +zerow dflags = mkMachWord dflags 0 +onew dflags = mkMachWord dflags 1 + +zerof, onef, twof, zerod, oned, twod :: Literal +zerof = mkMachFloat 0.0 +onef = mkMachFloat 1.0 +twof = mkMachFloat 2.0 +zerod = mkMachDouble 0.0 +oned = mkMachDouble 1.0 +twod = mkMachDouble 2.0 + +cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) + -> Literal -> Literal -> Maybe CoreExpr +cmpOp dflags cmp = go + where + done True = Just $ trueValInt dflags + done False = Just $ falseValInt dflags + + -- These compares are at different types + go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) + go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2) + go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2) + go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2) + go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2) + go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2) + go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2) + go _ _ = Nothing + +-------------------------- + +negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate +negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f)) +negOp _ (MachDouble 0.0) = Nothing +negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d)) +negOp dflags (MachInt i) = intResult dflags (-i) +negOp _ _ = Nothing + +complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement +complementOp dflags (MachWord i) = wordResult dflags (complement i) +complementOp dflags (MachInt i) = intResult dflags (complement i) +complementOp _ _ = Nothing + +-------------------------- +intOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2 = intOp2' . const + +intOp2' :: (Integral a, Integral b) + => (DynFlags -> a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2' op dflags (MachInt i1) (MachInt i2) = + let o = op dflags + in intResult dflags (fromInteger i1 `o` fromInteger i2) +intOp2' _ _ _ _ = Nothing -- Could find LitLit + +shiftRightLogical :: DynFlags -> Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical dflags x n + | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32) + | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64) + | otherwise = panic "shiftRightLogical: unsupported word size" + +-------------------------- +retLit :: (DynFlags -> Literal) -> RuleM CoreExpr +retLit l = do dflags <- getDynFlags + return $ Lit $ l dflags + +wordOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op dflags (MachWord w1) (MachWord w2) + = wordResult dflags (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing -- Could find LitLit + +wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr + -- Shifts take an Int; hence third arg of op is Int +-- See Note [Guarding against silly shifts] +wordShiftRule shift_op + = do { dflags <- getDynFlags + ; [e1, Lit (MachInt shift_len)] <- getArgs + ; case e1 of + _ | shift_len == 0 + -> return e1 + | shift_len < 0 || wordSizeInBits dflags < shift_len + -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy + ("Bad shift length" ++ show shift_len)) + Lit (MachWord x) + -> let op = shift_op dflags + in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len) + -- Do the shift at type Integer, but shift length is Int + _ -> mzero } + +wordSizeInBits :: DynFlags -> Integer +wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3) + +-------------------------- +floatOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal + -> Maybe (Expr CoreBndr) +floatOp2 op dflags (MachFloat f1) (MachFloat f2) + = Just (mkFloatVal dflags (f1 `op` f2)) +floatOp2 _ _ _ _ = Nothing + +-------------------------- +doubleOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal + -> Maybe (Expr CoreBndr) +doubleOp2 op dflags (MachDouble f1) (MachDouble f2) + = Just (mkDoubleVal dflags (f1 `op` f2)) +doubleOp2 _ _ _ _ = Nothing + +-------------------------- +{- Note [The litEq rule: converting equality to case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This stuff turns + n ==# 3# +into + case n of + 3# -> True + m -> False + +This is a Good Thing, because it allows case-of case things +to happen, and case-default absorption to happen. For +example: + + if (n ==# 3#) || (n ==# 4#) then e1 else e2 +will transform to + case n of + 3# -> e1 + 4# -> e1 + m -> e2 +(modulo the usual precautions to avoid duplicating e1) +-} + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleM CoreExpr +litEq is_eq = msum + [ do [Lit lit, expr] <- getArgs + dflags <- getDynFlags + do_lit_eq dflags lit expr + , do [expr, Lit lit] <- getArgs + dflags <- getDynFlags + do_lit_eq dflags lit expr ] + where + do_lit_eq dflags lit expr = do + guard (not (litIsLifted lit)) + return (mkWildCase expr (literalType lit) intPrimTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) + where + val_if_eq | is_eq = trueValInt dflags + | otherwise = falseValInt dflags + val_if_neq | is_eq = falseValInt dflags + | otherwise = trueValInt dflags + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Comparison -> RuleM CoreExpr +boundsCmp op = do + dflags <- getDynFlags + [a, b] <- getArgs + liftMaybe $ mkRuleFn dflags op a b + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: DynFlags -> Literal -> Bool +isMinBound _ (MachChar c) = c == minBound +isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags +isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64) +isMinBound _ (MachWord i) = i == 0 +isMinBound _ (MachWord64 i) = i == 0 +isMinBound _ _ = False + +isMaxBound :: DynFlags -> Literal -> Bool +isMaxBound _ (MachChar c) = c == maxBound +isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags +isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64) +isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags +isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64) +isMaxBound _ _ = False + + +-- Note that we *don't* warn the user about overflow. It's not done at +-- runtime either, and compilation of completely harmless things like +-- ((124076834 :: Word32) + (2147483647 :: Word32)) +-- would yield a warning. Instead we simply squash the value into the +-- *target* Int/Word range. +intResult :: DynFlags -> Integer -> Maybe CoreExpr +intResult dflags result = Just (mkIntVal dflags result') + where result' = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (fromInteger result :: Int32) + 8 -> toInteger (fromInteger result :: Int64) + w -> panic ("intResult: Unknown platformWordSize: " ++ show w) + +wordResult :: DynFlags -> Integer -> Maybe CoreExpr +wordResult dflags result = Just (mkWordVal dflags result') + where result' = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (fromInteger result :: Word32) + 8 -> toInteger (fromInteger result :: Word64) + w -> panic ("wordResult: Unknown platformWordSize: " ++ show w) + +inversePrimOp :: PrimOp -> RuleM CoreExpr +inversePrimOp primop = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId primop primop_id + return e + +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (mkPrimOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e + +idempotent :: RuleM CoreExpr +idempotent = do [e1, e2] <- getArgs + guard $ cheapEqExpr e1 e2 + return e1 + +{- +Note [Guarding against silly shifts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + import Data.Bits( (.|.), shiftL ) + chunkToBitmap :: [Bool] -> Word32 + chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +This optimises to: +Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> + case w1_sCT of _ { + [] -> __word 0; + : x_aAW xs_aAX -> + case x_aAW of _ { + GHC.Types.False -> + case w_sCS of wild2_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; + 9223372036854775807 -> __word 0 }; + GHC.Types.True -> + case GHC.Prim.>=# w_sCS 64 of _ { + GHC.Types.False -> + case w_sCS of wild3_Xh { + __DEFAULT -> + case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> + GHC.Prim.or# (GHC.Prim.narrow32Word# + (GHC.Prim.uncheckedShiftL# (__word 1) wild3_Xh)) + ww_sCW + }; + 9223372036854775807 -> + GHC.Prim.narrow32Word# +!!!!--> (GHC.Prim.uncheckedShiftL# (__word 1) 9223372036854775807) + }; + GHC.Types.True -> + case w_sCS of wild3_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; + 9223372036854775807 -> __word 0 + } } } } + +Note the massive shift on line "!!!!". It can't happen, because we've checked +that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this! +Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we +can't constant fold it, but if it gets to the assember we get + Error: operand type mismatch for `shl' + +So the best thing to do is to rewrite the shift with a call to error, +when the second arg is stupid. + +************************************************************************ +* * +\subsection{Vaguely generic functions} +* * +************************************************************************ +-} + +mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rm + = BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, + ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } + +newtype RuleM r = RuleM + { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } + +instance Functor RuleM where + fmap = liftM + +instance Applicative RuleM where + pure = return + (<*>) = ap + +instance Monad RuleM where + return x = RuleM $ \_ _ _ -> Just x + RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of + Nothing -> Nothing + Just r -> runRuleM (g r) dflags iu e + fail _ = mzero + +instance Alternative RuleM where + empty = mzero + (<|>) = mplus + +instance MonadPlus RuleM where + mzero = RuleM $ \_ _ _ -> Nothing + mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args -> + f1 dflags iu args `mplus` f2 dflags iu args + +instance HasDynFlags RuleM where + getDynFlags = RuleM $ \dflags _ _ -> Just dflags + +liftMaybe :: Maybe a -> RuleM a +liftMaybe Nothing = mzero +liftMaybe (Just x) = return x + +liftLit :: (Literal -> Literal) -> RuleM CoreExpr +liftLit f = liftLitDynFlags (const f) + +liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr +liftLitDynFlags f = do + dflags <- getDynFlags + [Lit lit] <- getArgs + return $ Lit (f dflags lit) + +removeOp32 :: RuleM CoreExpr +removeOp32 = do + dflags <- getDynFlags + if wordSizeInBits dflags == 32 + then do + [e] <- getArgs + return e + else mzero + +getArgs :: RuleM [CoreExpr] +getArgs = RuleM $ \_ _ args -> Just args + +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ -> Just iu + +-- return the n-th argument of this rule, if it is a literal +-- argument indices start from 0 +getLiteral :: Int -> RuleM Literal +getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of + (Lit l:_) -> Just l + _ -> Nothing + +unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit op = do + dflags <- getDynFlags + [Lit l] <- getArgs + liftMaybe $ op dflags (convFloating dflags l) + +binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit op = do + dflags <- getDynFlags + [Lit l1, Lit l2] <- getArgs + liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) + +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + dflags <- getDynFlags + binaryLit (\_ -> cmpOp dflags op) + +leftIdentity :: Literal -> RuleM CoreExpr +leftIdentity id_lit = leftIdentityDynFlags (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityDynFlags (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +leftIdentityDynFlags id_lit = do + dflags <- getDynFlags + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit dflags + return e2 + +rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +rightIdentityDynFlags id_lit = do + dflags <- getDynFlags + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit dflags + return e1 + +identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit + +leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr +leftZero zero = do + dflags <- getDynFlags + [Lit l1, _] <- getArgs + guard $ l1 == zero dflags + return $ Lit l1 + +rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr +rightZero zero = do + dflags <- getDynFlags + [_, Lit l2] <- getArgs + guard $ l2 == zero dflags + return $ Lit l2 + +zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr +zeroElem lit = leftZero lit `mplus` rightZero lit + +equalArgs :: RuleM () +equalArgs = do + [e1, e2] <- getArgs + guard $ e1 `cheapEqExpr` e2 + +nonZeroLit :: Int -> RuleM () +nonZeroLit n = getLiteral n >>= guard . not . isZeroLit + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: DynFlags -> Literal -> Literal +convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) = + MachFloat (toRational (fromRational f :: Float )) +convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) = + MachDouble (toRational (fromRational d :: Double)) +convFloating _ l = l + +guardFloatDiv :: RuleM () +guardFloatDiv = do + [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs + guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + +guardDoubleDiv :: RuleM () +guardDoubleDiv = do + [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs + guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] + && d2 /= 0 -- avoid NaN and Infinity/-Infinity +-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to +-- zero, but we might want to preserve the negative zero here which +-- is representable in Float/Double but not in (normalised) +-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? + +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (mkPrimOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: DynFlags -> Expr CoreBndr +trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] +falseValInt dflags = Lit $ zeroi dflags + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ltDataConId +eqVal = Var eqDataConId +gtVal = Var gtDataConId + +mkIntVal :: DynFlags -> Integer -> Expr CoreBndr +mkIntVal dflags i = Lit (mkMachInt dflags i) +mkWordVal :: DynFlags -> Integer -> Expr CoreBndr +mkWordVal dflags w = Lit (mkMachWord dflags w) +mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr +mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f)) +mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr +mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d)) + +matchPrimOpId :: PrimOp -> Id -> RuleM () +matchPrimOpId op id = do + op' <- liftMaybe $ isPrimOpId_maybe id + guard $ op == op' + +{- +************************************************************************ +* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +* * +************************************************************************ + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. +-} + +tagToEnumRule :: RuleM CoreExpr +-- If data T a = A | B | C +-- then tag2Enum# (T ty) 2# --> B ty +tagToEnumRule = do + [Type ty, Lit (MachInt i)] <- getArgs + case splitTyConApp_maybe ty of + Just (tycon, tc_args) | isEnumerationTyCon tycon -> do + let tag = fromInteger i + correct_tag dc = (dataConTag dc - fIRST_TAG) == tag + (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) + ASSERT(null rest) return () + return $ mkTyApps (Var (dataConWorkId dc)) tc_args + + -- See Note [tagToEnum#] + _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) + return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + +{- +For dataToTag#, we can reduce if either + + (a) the argument is a constructor + (b) the argument is a variable whose unfolding is a known constructor +-} + +dataToTagRule :: RuleM CoreExpr +dataToTagRule = a `mplus` b + where + a = do + [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + guard $ tag_to_enum `hasKey` tagToEnumKey + guard $ ty1 `eqType` ty2 + return tag -- dataToTag (tagToEnum x) ==> x + b = do + dflags <- getDynFlags + [_, val_arg] <- getArgs + in_scope <- getInScopeEnv + (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg + ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () + return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) + +{- +************************************************************************ +* * +\subsection{Rules for seq# and spark#} +* * +************************************************************************ +-} + +-- seq# :: forall a s . a -> State# s -> (# State# s, a #) +seqRule :: RuleM CoreExpr +seqRule = do + [ty_a, Type ty_s, a, s] <- getArgs + guard $ exprIsHNF a + return $ mkConApp (tupleCon UnboxedTuple 2) + [Type (mkStatePrimTy ty_s), ty_a, s, a] + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? + +{- +************************************************************************ +* * +\subsection{Built in rules} +* * +************************************************************************ + +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we get to code +generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole +set of bindings, which sorts out the dependency. Without -O we don't do any rule +rewriting so again we are fine. + +(This whole thing doesn't show up for non-built-in rules because their dependencies +are explicit.) +-} + +builtinRules :: [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules + = [BuiltinRule { ru_name = fsLit "AppendLitString", + ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit }, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, + ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags }, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, + ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict } + ] + ++ builtinIntegerRules + +builtinIntegerRules :: [CoreRule] +builtinIntegerRules = + [rule_IntToInteger "smallInteger" smallIntegerName, + rule_WordToInteger "wordToInteger" wordToIntegerName, + rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, + rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), + rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), + rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Prim "leInteger#" leIntegerPrimName (<=), + rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), + rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), + rule_binop_Prim "geInteger#" geIntegerPrimName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, + rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, + rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), + rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, + rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, + rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR, + -- See Note [Integer division constant folding] in libraries/base/GHC/Real.lhs + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_divop_one "divInteger" divIntegerName div, + rule_divop_one "modInteger" modIntegerName mod, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + -- These rules below don't actually have to be built in, but if we + -- put them in the Haskell source then we'd have to duplicate them + -- between all Integer implementations + rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, + rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, + rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, + rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, + rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, + rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, + rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp + ] + where rule_convert str name convert + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_convert convert } + rule_IntToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntToInteger } + rule_WordToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToInteger } + rule_Int64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Int64ToInteger } + rule_Word64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Word64ToInteger } + rule_unop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_unop op } + rule_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop op } + rule_divop_both str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } + rule_Int_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_binop op } + rule_binop_Prim str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Prim op } + rule_binop_Ordering str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Ordering op } + rule_encodeFloat str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_encodeFloat op } + rule_decodeDouble str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_decodeDouble } + rule_XToIntegerToX str name toIntegerName + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_XToIntegerToX toIntegerName } + rule_smallIntegerTo str name primOp + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_smallIntegerTo primOp } + rule_rationalTo str name mkLit + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_rationalTo mkLit } + +--------------------------------------------------- +-- The rule is this: +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- = unpackFoldrCString# "foobaz" c n + +match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_append_lit [Type ty1, + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] + | unpk `hasKey` unpackCStringFoldrIdKey && + c1 `cheapEqExpr` c2 + = ASSERT( ty1 `eqType` ty2 ) + Just (Var unpk `App` Type ty1 + `App` Lit (MachStr (s1 `BS.append` s2)) + `App` c1 + `App` n) + +match_append_lit _ = Nothing + +--------------------------------------------------- +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 + +match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), + Var unpk2 `App` Lit (MachStr s2)] + | unpk1 `hasKey` unpackCStringIdKey, + unpk2 `hasKey` unpackCStringIdKey + = Just (if s1 == s2 then trueValBool else falseValBool) + +match_eq_string _ _ = Nothing + + +--------------------------------------------------- +-- The rule is this: +-- inline f_ty (f a b c) = a b c +-- (if f has an unfolding, EVEN if it's a loop breaker) +-- +-- It's important to allow the argument to 'inline' to have args itself +-- (a) because its more forgiving to allow the programmer to write +-- inline f a b c +-- or inline (f a b c) +-- (b) because a polymorphic f wll get a type argument that the +-- programmer can't avoid +-- +-- Also, don't forget about 'inline's type argument! +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) + | (Var f, args1) <- collectArgs e, + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! + = Just (mkApps unf args1) + +match_inline _ = Nothing + + +-- See Note [magicDictId magic] in `basicTypes/MkId.lhs` +-- for a description of what is going on here. +match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] + | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap + , Just (dictTy, _) <- splitFunTy_maybe fieldTy + , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc + = Just + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a])) + `App` y + +match_magicDict _ = Nothing + +------------------------------------------------- +-- Integer rules +-- smallInteger (79::Int#) = 79::Integer +-- wordToInteger (79::Word#) = 79::Integer +-- Similarly Int64, Word64 + +match_IntToInteger :: RuleFun +match_IntToInteger _ id_unf fn [xl] + | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl + = case idType fn of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_IntToInteger: Id has the wrong type" +match_IntToInteger _ _ _ _ = Nothing + +match_WordToInteger :: RuleFun +match_WordToInteger _ id_unf id [xl] + | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_WordToInteger: Id has the wrong type" +match_WordToInteger _ _ _ _ = Nothing + +match_Int64ToInteger :: RuleFun +match_Int64ToInteger _ id_unf id [xl] + | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_Int64ToInteger: Id has the wrong type" +match_Int64ToInteger _ _ _ _ = Nothing + +match_Word64ToInteger :: RuleFun +match_Word64ToInteger _ id_unf id [xl] + | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl + = case idType id of + FunTy _ integerTy -> + Just (Lit (LitInteger x integerTy)) + _ -> + panic "match_Word64ToInteger: Id has the wrong type" +match_Word64ToInteger _ _ _ _ = Nothing + +------------------------------------------------- +match_Integer_convert :: Num a + => (DynFlags -> a -> Expr CoreBndr) + -> RuleFun +match_Integer_convert convert dflags id_unf _ [xl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + = Just (convert dflags (fromInteger x)) +match_Integer_convert _ _ _ _ _ = Nothing + +match_Integer_unop :: (Integer -> Integer) -> RuleFun +match_Integer_unop unop _ id_unf _ [xl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + = Just (Lit (LitInteger (unop x) i)) +match_Integer_unop _ _ _ _ _ = Nothing + +match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_binop binop _ id_unf _ [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (LitInteger (x `binop` y) i)) +match_Integer_binop _ _ _ _ _ = Nothing + +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_both + :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun +match_Integer_divop_both divop _ id_unf _ [xl,yl] + | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + , (r,s) <- x `divop` y + = Just $ mkConApp (tupleCon UnboxedTuple 2) + [Type t, + Type t, + Lit (LitInteger r t), + Lit (LitInteger s t)] +match_Integer_divop_both _ _ _ _ _ = Nothing + +-- This helper is used for the quot and rem functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_divop_one divop _ id_unf _ [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (LitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ _ _ = Nothing + +match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun +match_Integer_Int_binop binop _ id_unf _ [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) +match_Integer_Int_binop _ _ _ _ _ = Nothing + +match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun +match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) +match_Integer_binop_Prim _ _ _ _ _ = Nothing + +match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun +match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just $ case x `binop` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal +match_Integer_binop_Ordering _ _ _ _ _ = Nothing + +match_Integer_Int_encodeFloat :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl + = Just (mkLit $ encodeFloat x (fromInteger y)) +match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing + +--------------------------------------------------- +-- constant folding for Float/Double +-- +-- This turns +-- rationalToFloat n d +-- into a literal Float, and similarly for Doubles. +-- +-- it's important to not match d == 0, because that may represent a +-- literal "0/0" or similar, and we can't produce a literal value for +-- NaN or +-Inf +match_rationalTo :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_rationalTo mkLit _ id_unf _ [xl, yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (mkLit (fromRational (x % y))) +match_rationalTo _ _ _ _ _ = Nothing + +match_decodeDouble :: RuleFun +match_decodeDouble _ id_unf fn [xl] + | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl + = case idType fn of + FunTy _ (TyConApp _ [integerTy, intHashTy]) -> + case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkConApp (tupleCon UnboxedTuple 2) + [Type integerTy, + Type intHashTy, + Lit (LitInteger y integerTy), + Lit (MachInt (toInteger z))] + _ -> + panic "match_decodeDouble: Id has the wrong type" +match_decodeDouble _ _ _ _ = Nothing + +match_XToIntegerToX :: Name -> RuleFun +match_XToIntegerToX n _ _ _ [App (Var x) y] + | idName x == n + = Just y +match_XToIntegerToX _ _ _ _ _ = Nothing + +match_smallIntegerTo :: PrimOp -> RuleFun +match_smallIntegerTo primOp _ _ _ [App (Var x) y] + | idName x == smallIntegerName + = Just $ App (Var (mkPrimOpId primOp)) y +match_smallIntegerTo _ _ _ _ _ = Nothing diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs new file mode 100644 index 00000000..1b7e314f --- /dev/null +++ b/compiler/prelude/PrimOp.hs @@ -0,0 +1,636 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrimOp]{Primitive operations (machine-level)} +-} + +{-# LANGUAGE CPP #-} + +module PrimOp ( + PrimOp(..), PrimOpVecCat(..), allThePrimOps, + primOpType, primOpSig, + primOpTag, maxPrimOpTag, primOpOcc, + + tagToEnumKey, + + primOpOutOfLine, primOpCodeSize, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, primOpFixity, + + getPrimOpResultInfo, PrimOpResultInfo(..), + + PrimCall(..) + ) where + +#include "HsVersions.h" + +import TysPrim +import TysWiredIn + +import CmmType +import Demand +import Var ( TyVar ) +import OccName ( OccName, pprOccName, mkVarOccFS ) +import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) +import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, + typePrimRep ) +import BasicTypes ( Arity, Fixity(..), FixityDirection(..), TupleSort(..) ) +import ForeignCall ( CLabelString ) +import Unique ( Unique, mkPrimOpIdUnique ) +import Outputable +import FastTypes +import FastString +import Module ( PackageKey ) + +{- +************************************************************************ +* * +\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} +* * +************************************************************************ + +These are in \tr{state-interface.verb} order. +-} + +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" + +-- Used for the Ord instance + +primOpTag :: PrimOp -> Int +primOpTag op = iBox (tagOf_PrimOp op) + +-- supplies +-- tagOf_PrimOp :: PrimOp -> FastInt +#include "primop-tag.hs-incl" +tagOf_PrimOp _ = error "tagOf_PrimOp: unknown primop" + + +instance Eq PrimOp where + op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 + +instance Ord PrimOp where + op1 < op2 = tagOf_PrimOp op1 <# tagOf_PrimOp op2 + op1 <= op2 = tagOf_PrimOp op1 <=# tagOf_PrimOp op2 + op1 >= op2 = tagOf_PrimOp op1 >=# tagOf_PrimOp op2 + op1 > op2 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 + op1 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +data PrimOpVecCat = IntVec + | WordVec + | FloatVec + +-- An @Enum@-derived list would be better; meanwhile... (ToDo) + +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" + +tagToEnumKey :: Unique +tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) + +{- +************************************************************************ +* * +\subsection[PrimOp-info]{The essential info about each @PrimOp@} +* * +************************************************************************ + +The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may +refer to the primitive operation. The conventional \tr{#}-for- +unboxed ops is added on later. + +The reason for the funny characters in the names is so we do not +interfere with the programmer's Haskell name spaces. + +We use @PrimKinds@ for the ``type'' information, because they're +(slightly) more convenient to use than @TyCons@. +-} + +data PrimOpInfo + = Dyadic OccName -- string :: T -> T -> T + Type + | Monadic OccName -- string :: T -> T + Type + | Compare OccName -- string :: T -> T -> Int# + Type + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type + +mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo +mkDyadic str ty = Dyadic (mkVarOccFS str) ty +mkMonadic str ty = Monadic (mkVarOccFS str) ty +mkCompare str ty = Compare (mkVarOccFS str) ty + +mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty + +{- +************************************************************************ +* * +\subsubsection{Strictness} +* * +************************************************************************ + +Not all primops are strict! +-} + +primOpStrictness :: PrimOp -> Arity -> StrictSig + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Fixity} +* * +************************************************************************ +-} + +primOpFixity :: PrimOp -> Maybe Fixity +#include "primop-fixity.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +* * +************************************************************************ + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. +-} + +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" +primOpInfo _ = error "primOpInfo: unknown primop" + +{- +Here are a load of comments from the old primOp info: + +A @Word#@ is an unsigned @Int#@. + +@decodeFloat#@ is given w/ Integer-stuff (it's similar). + +@decodeDouble#@ is given w/ Integer-stuff (it's similar). + +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.lhs). + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) + +The following operation dereferences a weak pointer. The weak pointer +may have been finalized, so the operation returns a result code which +must be inspected before looking at the dereferenced value. + + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) + +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) + +The Int# returned is either + + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. + +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. + +\begin{verbatim} +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) +freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) +eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the IO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePtr@ +operation.) + +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + +Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. + + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +These primops are pretty weird. + + dataToTag# :: a -> Int (arg must be an evaluated data type) + tagToEnum# :: Int -> a (result type must be an enumerated type) + +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. + +************************************************************************ +* * + Which PrimOps are out-of-line +* * +************************************************************************ + +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. +-} + +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" + +{- +************************************************************************ +* * + Failure and side effects +* * +************************************************************************ + +Note [PrimOp can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both can_fail and has_side_effects mean that the primop has +some effect that is not captured entirely by its result value. + +---------- has_side_effects --------------------- +A primop "has_side_effects" if it has some *write* effect, visible +elsewhere + - writing to the world (I/O) + - writing to a mutable data structure (writeIORef) + - throwing a synchronous Haskell exception + +Often such primops have a type like + State -> input -> (State, output) +so the state token guarantees ordering. In general we rely *only* on +data dependencies of the state token to enforce write-effect ordering + + * NB1: if you inline unsafePerformIO, you may end up with + side-effecting ops whose 'state' output is discarded. + And programmers may do that by hand; see Trac #9390. + That is why we (conservatively) do not discard write-effecting + primops even if both their state and result is discarded. + + * NB2: We consider primops, such as raiseIO#, that can raise a + (Haskell) synchronous exception to "have_side_effects" but not + "can_fail". We must be careful about not discarding such things; + see the paper "A semantics for imprecise exceptions". + + * NB3: *Read* effects (like reading an IORef) don't count here, + because it doesn't matter if we don't do them, or do them more than + once. *Sequencing* is maintained by the data dependency of the state + token. + +---------- can_fail ---------------------------- +A primop "can_fail" if it can fail with an *unchecked* exception on +some elements of its input domain. Main examples: + division (fails on zero demoninator) + array indexing (fails if the index is out of bounds) + +An "unchecked exception" is one that is an outright error, (not +turned into a Haskell exception,) such as seg-fault or +divide-by-zero error. Such can_fail primops are ALWAYS surrounded +with a test that checks for the bad cases, but we need to be +very careful about code motion that might move it out of +the scope of the test. + +Note [Transformations affected by can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The can_fail and has_side_effects properties have the following effect +on program transformations. Summary table is followed by details. + + can_fail has_side_effects +Discard NO NO +Float in YES YES +Float out NO NO +Duplicate YES NO + +* Discarding. case (a `op` b) of _ -> rhs ===> rhs + You should not discard a has_side_effects primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + Arguably you should be able to discard this, since the + returned stat token is not used, but that relies on NEVER + inlining unsafePerformIO, and programmers sometimes write + this kind of stuff by hand (Trac #9390). So we (conservatively) + never discard a has_side_effects primop. + + However, it's fine to discard a can_fail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray#; it has can_fail, but not + has_side_effects; see Trac #5658 which was all about this. + Notice that indexIntArray# is (in a more general handling of + effects) read effect, but we don't care about that here, and + treat read effects as *not* has_side_effects. + + Similarly (a `/#` b) can be discarded. It can seg-fault or + cause a hardware exception, but not a synchronous Haskell + exception. + + + + Synchronous Haskell exceptions, e.g. from raiseIO#, are treated + as has_side_effects and hence are not discarded. + +* Float in. You can float a can_fail or has_side_effects primop + *inwards*, but not inside a lambda (see Duplication below). + +* Float out. You must not float a can_fail primop *outwards* lest + you escape the dynamic scope of the test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + + Nor can you float out a has_side_effects primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + +* Duplication. You cannot duplicate a has_side_effect primop. You + might wonder how this can occur given the state token threading, but + just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get + something like this + p = case readMutVar# s v of + (# s', r #) -> (S# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. Trac #3207 is real example of this happening. + + However, it's fine to duplicate a can_fail primop. That is really + the only difference between can_fail and has_side_effects. + +Note [Implementation: how can_fail/has_side_effects affect transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that that floating/duplication/discarding are done right +in the simplifier? + +Two main predicates on primpops test these flags: + primOpOkForSideEffects <=> not has_side_effects + primOpOkForSpeculation <=> not (has_side_effects || can_fail) + + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a can_fail or has_side_effects primop. The RHS of a + let-binding (which can float in and out freely) satisfies + exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation is false of can_fail and has_side_effects. + + * So can_fail and has_side_effects primops will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. + + * The no-duplicate thing is done via primOpIsCheap, by making + has_side_effects things (very very very) not-cheap! +-} + +primOpHasSideEffects :: PrimOp -> Bool +#include "primop-has-side-effects.hs-incl" + +primOpCanFail :: PrimOp -> Bool +#include "primop-can-fail.hs-incl" + +primOpOkForSpeculation :: PrimOp -> Bool + -- See Note [PrimOp can_fail and has_side_effects] + -- See comments with CoreUtils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkForSideEffects +primOpOkForSpeculation op + = primOpOkForSideEffects op + && not (primOpOutOfLine op || primOpCanFail op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them + +primOpOkForSideEffects :: PrimOp -> Bool +primOpOkForSideEffects op + = not (primOpHasSideEffects op) + +{- +Note [primOpIsCheap] +~~~~~~~~~~~~~~~~~~~~ +@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK +WARNING), we just borrow some other predicates for a +what-should-be-good-enough test. "Cheap" means willing to call it more +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. +-} + +primOpIsCheap :: PrimOp -> Bool +-- See Note [PrimOp can_fail and has_side_effects] +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. + +{- +************************************************************************ +* * + PrimOp code size +* * +************************************************************************ + +primOpCodeSize +~~~~~~~~~~~~~~ +Gives an indication of the code size of a primop, for the purposes of +calculating unfolding sizes; see CoreUnfold.sizeExpr. +-} + +primOpCodeSize :: PrimOp -> Int +#include "primop-code-size.hs-incl" + +primOpCodeSizeDefault :: Int +primOpCodeSizeDefault = 1 + -- CoreUnfold.primOpSize already takes into account primOpOutOfLine + -- and adds some further costs for the args in that case. + +primOpCodeSizeForeignCall :: Int +primOpCodeSizeForeignCall = 4 + +{- +************************************************************************ +* * + PrimOp types +* * +************************************************************************ +-} + +primOpType :: PrimOp -> Type -- you may want to use primOpSig instead +primOpType op + = case primOpInfo op of + Dyadic _occ ty -> dyadic_fun_ty ty + Monadic _occ ty -> monadic_fun_ty ty + Compare _occ ty -> compare_fun_ty ty + + GenPrimOp _occ tyvars arg_tys res_ty -> + mkForAllTys tyvars (mkFunTys arg_tys res_ty) + +primOpOcc :: PrimOp -> OccName +primOpOcc op = case primOpInfo op of + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ + +-- primOpSig is like primOpType but gives the result split apart: +-- (type variables, argument types, result type) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Monadic _occ ty -> ([], [ty], ty ) + Dyadic _occ ty -> ([], [ty,ty], ty ) + Compare _occ ty -> ([], [ty,ty], intPrimTy) + GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) + +data PrimOpResultInfo + = ReturnsPrim PrimRep + | ReturnsAlg TyCon + +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo op + = case (primOpInfo op) of + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) + Compare _ _ -> ReturnsPrim (tyConPrimRep intPrimTyCon) + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) + | otherwise -> ReturnsAlg tc + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple, though, which + -- gives rise to a ReturnAlg + +{- +We do not currently make use of whether primops are commutable. + +We used to try to move constants to the right hand side for strength +reduction. +-} + +{- +commutableOp :: PrimOp -> Bool +#include "primop-commutable.hs-incl" +-} + +-- Utils: + +dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type +dyadic_fun_ty ty = mkFunTys [ty, ty] ty +monadic_fun_ty ty = mkFunTy ty ty +compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy + +-- Output stuff: + +pprPrimOp :: PrimOp -> SDoc +pprPrimOp other_op = pprOccName (primOpOcc other_op) + +{- +************************************************************************ +* * +\subsubsection[PrimCall]{User-imported primitive calls} +* * +************************************************************************ +-} + +data PrimCall = PrimCall CLabelString PackageKey + +instance Outputable PrimCall where + ppr (PrimCall lbl pkgId) + = text "__primcall" <+> ppr pkgId <+> ppr lbl diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot new file mode 100644 index 00000000..6b92ef3d --- /dev/null +++ b/compiler/prelude/PrimOp.hs-boot @@ -0,0 +1,3 @@ +module PrimOp where + +data PrimOp diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs new file mode 100644 index 00000000..6cb1006c --- /dev/null +++ b/compiler/prelude/TysPrim.hs @@ -0,0 +1,787 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + + +\section[TysPrim]{Wired-in knowledge about primitive types} +-} + +{-# LANGUAGE CPP #-} + +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn +module TysPrim( + tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTy, betaTy, gammaTy, deltaTy, + openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, + kKiVar, + + -- Kind constructors... + superKindTyCon, superKind, anyKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyCon, + + superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + constraintKindTyConName, + + -- Kinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, + mkArrowKind, mkArrowKinds, + + funTyCon, funTyConName, + primTyCons, + + charPrimTyCon, charPrimTy, + intPrimTyCon, intPrimTy, + wordPrimTyCon, wordPrimTy, + addrPrimTyCon, addrPrimTy, + floatPrimTyCon, floatPrimTy, + doublePrimTyCon, doublePrimTy, + + voidPrimTyCon, voidPrimTy, + statePrimTyCon, mkStatePrimTy, + realWorldTyCon, realWorldTy, realWorldStatePrimTy, + + proxyPrimTyCon, mkProxyPrimTy, + + arrayPrimTyCon, mkArrayPrimTy, + byteArrayPrimTyCon, byteArrayPrimTy, + arrayArrayPrimTyCon, mkArrayArrayPrimTy, + smallArrayPrimTyCon, mkSmallArrayPrimTy, + mutableArrayPrimTyCon, mkMutableArrayPrimTy, + mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, + mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, + smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, + mutVarPrimTyCon, mkMutVarPrimTy, + + mVarPrimTyCon, mkMVarPrimTy, + tVarPrimTyCon, mkTVarPrimTy, + stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, + bcoPrimTyCon, bcoPrimTy, + weakPrimTyCon, mkWeakPrimTy, + threadIdPrimTyCon, threadIdPrimTy, + + int32PrimTyCon, int32PrimTy, + word32PrimTyCon, word32PrimTy, + + int64PrimTyCon, int64PrimTy, + word64PrimTyCon, word64PrimTy, + + eqPrimTyCon, -- ty1 ~# ty2 + eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) + + -- * Any + anyTy, anyTyCon, anyTypeOfKind, + + -- * SIMD +#include "primop-vector-tys-exports.hs-incl" + ) where + +#include "HsVersions.h" + +import Var ( TyVar, KindVar, mkTyVar ) +import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) +import OccName ( mkTyVarOccFS, mkTcOccFS ) +import TyCon +import TypeRep +import SrcLoc +import Unique ( mkAlphaTyVarUnique ) +import PrelNames +import FastString + +import Data.Char + +{- +************************************************************************ +* * +\subsection{Primitive type constructors} +* * +************************************************************************ +-} + +primTyCons :: [TyCon] +primTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , arrayArrayPrimTyCon + , smallArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int32PrimTyCon + , int64PrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , mutableArrayArrayPrimTyCon + , smallMutableArrayPrimTyCon + , mVarPrimTyCon + , tVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , statePrimTyCon + , voidPrimTyCon + , proxyPrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word32PrimTyCon + , word64PrimTyCon + , anyTyCon + , eqPrimTyCon + , eqReprPrimTyCon + + , liftedTypeKindTyCon + , unliftedTypeKindTyCon + , openTypeKindTyCon + , constraintKindTyCon + , superKindTyCon + , anyKindTyCon + +#include "primop-vector-tycons.hs-incl" + ] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + BuiltInSyntax + + +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon +int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon +word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon +proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon +eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon +eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon +smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon +smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ + +alphaTyVars is a list of type variables for use in templates: + ["a", "b", ..., "z", "t1", "t2", ... ] +-} + +tyVarList :: Kind -> [TyVar] +tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString name)) + noSrcSpan) kind + | u <- [2..], + let name | c <= 'z' = [c] + | otherwise = 't':show u + where c = chr (u-2 + ord 'a') + ] + +alphaTyVars :: [TyVar] +alphaTyVars = tyVarList liftedTypeKind + +betaTyVars :: [TyVar] +betaTyVars = tail alphaTyVars + +alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar +(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + +alphaTys :: [Type] +alphaTys = mkTyVarTys alphaTyVars +alphaTy, betaTy, gammaTy, deltaTy :: Type +(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys + + -- openAlphaTyVar is prepared to be instantiated + -- to a lifted or unlifted type variable. It's used for the + -- result type for "error", so that we can have (error Int# "Help") +openAlphaTyVars :: [TyVar] +openAlphaTyVar, openBetaTyVar :: TyVar +openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind + +openAlphaTy, openBetaTy :: Type +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar + +kKiVar :: KindVar +kKiVar = (tyVarList superKind) !! 10 + +{- +************************************************************************ +* * + FunTyCon +* * +************************************************************************ +-} + +funTyConName :: Name +funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon + +funTyCon :: TyCon +funTyCon = mkFunTyCon funTyConName $ + mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right + -- But if we do that we get kind errors when saying + -- instance Control.Arrow (->) + -- because the expected kind is (*->*->*). The trouble is that the + -- expected/actual stuff in the unifier does not go contra-variant, whereas + -- the kind sub-typing does. Sigh. It really only matters if you use (->) in + -- a prefix way, thus: (->) Int# Int#. And this is unusual. + -- because they are never in scope in the source + +-- One step to remove subkinding. +-- (->) :: * -> * -> * +-- but we should have (and want) the following typing rule for fully applied arrows +-- Gamma |- tau :: k1 k1 in {*, #} +-- Gamma |- sigma :: k2 k2 in {*, #, (#)} +-- ----------------------------------------- +-- Gamma |- tau -> sigma :: * +-- Currently we have the following rule which achieves more or less the same effect +-- Gamma |- tau :: ?? +-- Gamma |- sigma :: ? +-- -------------------------- +-- Gamma |- tau -> sigma :: * +-- In the end we don't want subkinding at all. + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ + +Note [SuperKind (BOX)] +~~~~~~~~~~~~~~~~~~~~~~ +Kinds are classified by "super-kinds". There is only one super-kind, namely BOX. + +Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX +Reason: we want to have kind equalities, thus (without the kind applications) + keq :: * ~ * = Eq# +Remember that + (~) :: forall (k:BOX). k -> k -> Constraint + (~#) :: forall (k:BOX). k -> k -> # + Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b + +So the full defn of keq is + keq :: (~) BOX * * = Eq# BOX * * + +So you can see it's convenient to have BOX:BOX +-} + +-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's +superKindTyCon, anyKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, + constraintKindTyCon + :: TyCon +superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + constraintKindTyConName + :: Name + +superKindTyCon = mkKindTyCon superKindTyConName superKind + -- See Note [SuperKind (BOX)] + +anyKindTyCon = mkKindTyCon anyKindTyConName superKind +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind +constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind + +-------------------------- +-- ... and now their names + +-- If you edit these, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon +anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon +liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon +openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon +unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon + +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name +mkPrimTyConName = mkPrimTcName BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim, + -- and use BuiltInSyntax, because they are never in scope in the source + +constraintKindTyConName -- Unlike the others, Constraint does *not* use BuiltInSyntax, + -- and can be imported/exported like any other type constructor + = mkPrimTcName UserSyntax (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon + + +mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkPrimTcName built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax + +kindTyConType :: TyCon -> Type +kindTyConType kind = TyConApp kind [] -- mkTyConApp isn't defined yet + +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind + +superKind = kindTyConType superKindTyCon +anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds] +liftedTypeKind = kindTyConType liftedTypeKindTyCon +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon +openTypeKind = kindTyConType openTypeKindTyCon +constraintKind = kindTyConType constraintKindTyCon + +-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = FunTy k1 k2 + +-- | Iterated application of 'mkArrowKind' +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds + +{- +************************************************************************ +* * +\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} +* * +************************************************************************ +-} + +-- only used herein +pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon +pcPrimTyCon name roles rep + = mkPrimTyCon name kind roles rep + where + kind = mkArrowKinds (map (const liftedTypeKind) roles) result_kind + result_kind = unliftedTypeKind + +pcPrimTyCon0 :: Name -> PrimRep -> TyCon +pcPrimTyCon0 name rep + = mkPrimTyCon name result_kind [] rep + where + result_kind = unliftedTypeKind + +charPrimTy :: Type +charPrimTy = mkTyConTy charPrimTyCon +charPrimTyCon :: TyCon +charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep + +intPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyCon +intPrimTyCon :: TyCon +intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep + +int32PrimTy :: Type +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon :: TyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep + +int64PrimTy :: Type +int64PrimTy = mkTyConTy int64PrimTyCon +int64PrimTyCon :: TyCon +int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep + +wordPrimTy :: Type +wordPrimTy = mkTyConTy wordPrimTyCon +wordPrimTyCon :: TyCon +wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep + +word32PrimTy :: Type +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon :: TyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep + +word64PrimTy :: Type +word64PrimTy = mkTyConTy word64PrimTyCon +word64PrimTyCon :: TyCon +word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep + +addrPrimTy :: Type +addrPrimTy = mkTyConTy addrPrimTyCon +addrPrimTyCon :: TyCon +addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep + +floatPrimTy :: Type +floatPrimTy = mkTyConTy floatPrimTyCon +floatPrimTyCon :: TyCon +floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep + +doublePrimTy :: Type +doublePrimTy = mkTyConTy doublePrimTyCon +doublePrimTyCon :: TyCon +doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep + +{- +************************************************************************ +* * +\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} +* * +************************************************************************ + +Note [The ~# TyCon) +~~~~~~~~~~~~~~~~~~~~ +There is a perfectly ordinary type constructor ~# that represents the type +of coercions (which, remember, are values). For example + Refl Int :: ~# * Int Int + +It is a kind-polymorphic type constructor like Any: + Refl Maybe :: ~# (* -> *) Maybe Maybe + +(~) only appears saturated. So we check that in CoreLint (and, in an +assertion, in Kind.typeKind). + +Note [The State# TyCon] +~~~~~~~~~~~~~~~~~~~~~~~ +State# is the primitive, unlifted type of states. It has one type parameter, +thus + State# RealWorld +or + State# s + +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. + +The type parameter to State# is intended to keep separate threads separate. +Even though this parameter is not used in the definition of State#, it is +given role Nominal to enforce its intended use. +-} + +mkStatePrimTy :: Type -> Type +mkStatePrimTy ty = TyConApp statePrimTyCon [ty] + +statePrimTyCon :: TyCon -- See Note [The State# TyCon] +statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep + +voidPrimTy :: Type +voidPrimTy = TyConApp voidPrimTyCon [] + +voidPrimTyCon :: TyCon +voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep + +mkProxyPrimTy :: Type -> Type -> Type +mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] + +proxyPrimTyCon :: TyCon +proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep + where kind = ForAllTy kv $ mkArrowKind k unliftedTypeKind + kv = kKiVar + k = mkTyVarTy kv + +eqPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The ~# TyCon] +eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep + where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind + kv = kKiVar + k = mkTyVarTy kv + +-- like eqPrimTyCon, but the type for *Representational* coercions +-- this should only ever appear as the type of a covar. Its role is +-- interpreted in coercionRole +eqReprPrimTyCon :: TyCon +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind + -- the roles really should be irrelevant! + [Nominal, Representational, Representational] VoidRep + where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind + kv = kKiVar + k = mkTyVarTy kv + +{- +RealWorld is deeply magical. It is *primitive*, but it is not +*unlifted* (hence ptrArg). We never manipulate values of type +RealWorld; it's only used in the type system, to parameterise State#. +-} + +realWorldTyCon :: TyCon +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep +realWorldTy :: Type +realWorldTy = mkTyConTy realWorldTyCon +realWorldStatePrimTy :: Type +realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld + +{- +Note: the ``state-pairing'' types are not truly primitive, so they are +defined in \tr{TysWiredIn.lhs}, not here. + +************************************************************************ +* * +\subsection[TysPrim-arrays]{The primitive array types} +* * +************************************************************************ +-} + +arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, + byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, + smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] PtrRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] PtrRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] PtrRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep +arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep +mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep +smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] PtrRep +smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] PtrRep + +mkArrayPrimTy :: Type -> Type +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] +byteArrayPrimTy :: Type +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkArrayArrayPrimTy :: Type +mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon +mkSmallArrayPrimTy :: Type -> Type +mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] +mkMutableArrayPrimTy :: Type -> Type -> Type +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy :: Type -> Type +mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy :: Type -> Type +mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] +mkSmallMutableArrayPrimTy :: Type -> Type -> Type +mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-mut-var]{The mutable variable type} +* * +************************************************************************ +-} + +mutVarPrimTyCon :: TyCon +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep + +mkMutVarPrimTy :: Type -> Type -> Type +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-synch-var]{The synchronizing variable type} +* * +************************************************************************ +-} + +mVarPrimTyCon :: TyCon +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep + +mkMVarPrimTy :: Type -> Type -> Type +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-stm-var]{The transactional variable type} +* * +************************************************************************ +-} + +tVarPrimTyCon :: TyCon +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep + +mkTVarPrimTy :: Type -> Type -> Type +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-stable-ptrs]{The stable-pointer type} +* * +************************************************************************ +-} + +stablePtrPrimTyCon :: TyCon +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep + +mkStablePtrPrimTy :: Type -> Type +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] + +{- +************************************************************************ +* * +\subsection[TysPrim-stable-names]{The stable-name type} +* * +************************************************************************ +-} + +stableNamePrimTyCon :: TyCon +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep + +mkStableNamePrimTy :: Type -> Type +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] + +{- +************************************************************************ +* * +\subsection[TysPrim-BCOs]{The ``bytecode object'' type} +* * +************************************************************************ +-} + +bcoPrimTy :: Type +bcoPrimTy = mkTyConTy bcoPrimTyCon +bcoPrimTyCon :: TyCon +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep + +{- +************************************************************************ +* * +\subsection[TysPrim-Weak]{The ``weak pointer'' type} +* * +************************************************************************ +-} + +weakPrimTyCon :: TyCon +weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep + +mkWeakPrimTy :: Type -> Type +mkWeakPrimTy v = TyConApp weakPrimTyCon [v] + +{- +************************************************************************ +* * +\subsection[TysPrim-thread-ids]{The ``thread id'' type} +* * +************************************************************************ + +A thread id is represented by a pointer to the TSO itself, to ensure +that they are always unique and we can always find the TSO for a given +thread id. However, this has the unfortunate consequence that a +ThreadId# for a given thread is treated as a root by the garbage +collector and can keep TSOs around for too long. + +Hence the programmer API for thread manipulation uses a weak pointer +to the thread id internally. +-} + +threadIdPrimTy :: Type +threadIdPrimTy = mkTyConTy threadIdPrimTyCon +threadIdPrimTyCon :: TyCon +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep + +{- +************************************************************************ +* * + Any +* * +************************************************************************ + +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any of kind forall k. k has these properties: + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency because 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other. See also #9097. + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Any, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables + For example length Any [] + See Note [Strangely-kinded void TyCons] + +Note [Any kinds] +~~~~~~~~~~~~~~~~ + +The type constructor AnyK (of sort BOX) is used internally only to zonk kind +variables with no constraints on them. It appears in similar circumstances to +Any, but at the kind level. For example: + + type family Length (l :: [k]) :: Nat + type instance Length [] = Zero + +Length is kind-polymorphic, and when applied to the empty (promoted) list it +will have the kind Length AnyK []. + +Note [Strangely-kinded void TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Any (Nil Any) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Any for kind * + Any(*->*) for kind *->* + etc +-} + +anyTyConName :: Name +anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + +anyTy :: Type +anyTy = mkTyConTy anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] + AbstractClosedSynFamilyTyCon + NoParentTyCon + where + kind = ForAllTy kKiVar (mkTyVarTy kKiVar) + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = TyConApp anyTyCon [kind] + +{- +************************************************************************ +* * +\subsection{SIMD vector types} +* * +************************************************************************ +-} + +#include "primop-vector-tys.hs-incl" diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs new file mode 100644 index 00000000..6181415b --- /dev/null +++ b/compiler/prelude/TysWiredIn.hs @@ -0,0 +1,859 @@ +{- +(c) The GRASP Project, Glasgow University, 1994-1998 + +\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} +-} + +{-# LANGUAGE CPP #-} + +-- | This module is about types that can be defined in Haskell, but which +-- must be wired into the compiler nonetheless. C.f module TysPrim +module TysWiredIn ( + -- * All wired in things + wiredInTyCons, isBuiltInOcc_maybe, + + -- * Bool + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon, + + -- * Ordering + ltDataCon, ltDataConId, + eqDataCon, eqDataConId, + gtDataCon, gtDataConId, + promotedOrderingTyCon, + promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, + + -- * Char + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, + + -- * Double + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + -- * Float + floatTyCon, floatDataCon, floatTy, floatTyConName, + + -- * Int + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + -- * Word + wordTyCon, wordDataCon, wordTyConName, wordTy, + + -- * List + listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, + listTyCon_RDR, consDataCon_RDR, listTyConName, + mkListTy, mkPromotedListTy, + + -- * Tuples + mkTupleTy, mkBoxedTupleTy, + tupleTyCon, tupleCon, + promotedTupleTyCon, promotedTupleDataCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedPairTyCon, unboxedPairDataCon, + + -- * Unit + unitTy, + + -- * Kinds + typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, + + -- * Parallel arrays + mkPArrTy, + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, + parrTyCon_RDR, parrTyConName, + + -- * Equality predicates + eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, + coercibleTyCon, coercibleDataCon, coercibleClass, + + mkWiredInTyConName -- This is used in TcTypeNats to define the + -- built-in functions for evaluation. + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} MkId( mkDataConWorkId ) + +-- friends: +import PrelNames +import TysPrim + +-- others: +import Constants ( mAX_TUPLE_SIZE ) +import Module ( Module ) +import Type ( mkTyConApp ) +import DataCon +import ConLike +import Var +import TyCon +import Class ( Class, mkClass ) +import TypeRep +import RdrName +import Name +import BasicTypes ( TupleSort(..), tupleSortBoxity, + Arity, RecFlag(..), Boxity(..) ) +import ForeignCall +import Unique ( incrUnique, mkTupleTyConUnique, + mkTupleDataConUnique, mkPArrDataConUnique ) +import Data.Array +import FastString +import Outputable +import Util +import BooleanFormula ( mkAnd ) + +alpha_tyvar :: [TyVar] +alpha_tyvar = [alphaTyVar] + +alpha_ty :: [Type] +alpha_ty = [alphaTy] + +{- +************************************************************************ +* * +\subsection{Wired in type constructors} +* * +************************************************************************ + +If you change which things are wired in, make sure you change their +names in PrelNames, so they use wTcQual, wDataQual, etc +-} + +-- This list is used only to define PrelInfo.wiredInThings. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes tuples, Any and implicit +-- parameter TyCons. Instead, we have a hack in lookupOrigNameCache to deal with +-- these names. +-- +-- See also Note [Known-key names] +wiredInTyCons :: [TyCon] + +wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because + -- it's defined in GHC.Base, and there's only + -- one of it. We put it in wiredInTyCons so + -- that it'll pre-populate the name cache, so + -- the special case in lookupOrigNameCache + -- doesn't need to look out for it + , boolTyCon + , charTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , wordTyCon + , listTyCon + , parrTyCon + , eqTyCon + , coercibleTyCon + , typeNatKindCon + , typeSymbolKindCon + ] + +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in modu fs unique tycon + = mkWiredInName modu (mkTcOccFS fs) unique + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in modu fs unique datacon + = mkWiredInName modu (mkDataOccFS fs) unique + (AConLike (RealDataCon datacon)) -- Relevant DataCon + built_in + +-- See Note [Kind-changing of (~) and Coercible] +eqTyConName, eqBoxDataConName :: Name +eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqBoxDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqBoxDataConKey eqBoxDataCon + +-- See Note [Kind-changing of (~) and Coercible] +coercibleTyConName, coercibleDataConName :: Name +coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon +coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon + +charTyConName, charDataConName, intTyConName, intDataConName :: Name +charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon +intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon + +boolTyConName, falseDataConName, trueDataConName :: Name +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon + +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +wordTyConName, wordDataConName, floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon +wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon +doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon + +-- Kinds +typeNatKindConName, typeSymbolKindConName :: Name +typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeNatKindCon +typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon + +parrTyConName, parrDataConName :: Name +parrTyConName = mkWiredInTyConName BuiltInSyntax + gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName UserSyntax + gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon + +boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName +parrTyCon_RDR = nameRdrName parrTyConName +eqTyCon_RDR = nameRdrName eqTyConName + +{- +************************************************************************ +* * +\subsection{mkWiredInTyCon} +* * +************************************************************************ +-} + +pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +-- Not an enumeration, not promotable +pcNonRecDataTyCon = pcTyCon False NonRecursive False + +-- This function assumes that the types it creates have all parameters at +-- Representational role! +pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon is_enum is_rec is_prom name cType tyvars cons + = buildAlgTyCon name + tyvars + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (DataTyCon cons is_enum) + is_rec + is_prom + False -- Not in GADT syntax + NoParentTyCon + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon = pcDataConWithFixity False + +pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n)) +-- The Name's unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. + +pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon + = data_con + where + data_con = mkDataCon dc_name declared_infix + (map (const HsNoBang) arg_tys) + [] -- No labelled fields + tyvars + [] -- No existential type variables + [] -- No equality spec + [] -- No theta + arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + tycon + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) + NoDataConRep -- Wired-in types are too simple to need wrappers + + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name + wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + wrk_name = mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ +-} + +typeNatKindCon, typeSymbolKindCon :: TyCon +-- data Nat +-- data Symbol +typeNatKindCon = pcTyCon False NonRecursive True typeNatKindConName Nothing [] [] +typeSymbolKindCon = pcTyCon False NonRecursive True typeSymbolKindConName Nothing [] [] + +typeNatKind, typeSymbolKind :: Kind +typeNatKind = TyConApp (promoteTyCon typeNatKindCon) [] +typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) [] + +{- +************************************************************************ +* * + Stuff for dealing with tuples +* * +************************************************************************ + +Note [How tuples work] See also Note [Known-key names] in PrelNames +~~~~~~~~~~~~~~~~~~~~~~ +* There are three families of tuple TyCons and corresponding + DataCons, (boxed, unboxed, and constraint tuples), expressed by the + type BasicTypes.TupleSort. + +* DataCons (and workers etc) for BoxedTuple and ConstraintTuple have + - distinct Uniques + - the same OccName + Using the same OccName means (hack!) that a single copy of the + runtime library code (info tables etc) works for both. + +* When looking up an OccName in the original-name cache + (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure + we get the right wired-in name. This guy can't tell the difference + betweeen BoxedTuple and ConstraintTuple (same OccName!), so tuples + are not serialised into interface files using OccNames at all. +-} + +isBuiltInOcc_maybe :: OccName -> Maybe Name +-- Built in syntax isn't "in scope" so these OccNames +-- map to wired-in Names with BuiltInSyntax +isBuiltInOcc_maybe occ + = case occNameString occ of + "[]" -> choose_ns listTyCon nilDataCon + ":" -> Just consDataConName + "[::]" -> Just parrTyConName + "(##)" -> choose_ns unboxedUnitTyCon unboxedUnitDataCon + "()" -> choose_ns unitTyCon unitDataCon + '(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest + '(':',':rest -> parse_tuple BoxedTuple 2 rest + _other -> Nothing + where + ns = occNameSpace occ + + parse_tuple sort n rest + | (',' : rest2) <- rest = parse_tuple sort (n+1) rest2 + | tail_matches sort rest = choose_ns (tupleTyCon sort n) + (tupleCon sort n) + | otherwise = Nothing + + tail_matches BoxedTuple ")" = True + tail_matches UnboxedTuple "#)" = True + tail_matches _ _ = False + + choose_ns tc dc + | isTcClsNameSpace ns = Just (getName tc) + | isDataConNameSpace ns = Just (getName dc) + | otherwise = Just (getName (dataConWorkId dc)) + +mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName +mkTupleOcc ns sort ar = mkOccName ns str + where + -- No need to cache these, the caching is done in mk_tuple + str = case sort of + UnboxedTuple -> '(' : '#' : commas ++ "#)" + BoxedTuple -> '(' : commas ++ ")" + ConstraintTuple -> '(' : commas ++ ")" + + commas = take (ar-1) (repeat ',') + + -- Cute hack: we reuse the standard tuple OccNames (and hence code) + -- for fact tuples, but give them different Uniques so they are not equal. + -- + -- You might think that this will go wrong because isBuiltInOcc_maybe won't + -- be able to tell the difference between boxed tuples and constraint tuples. BUT: + -- 1. Constraint tuples never occur directly in user code, so it doesn't matter + -- that we can't detect them in Orig OccNames originating from the user + -- programs (or those built by setRdrNameSpace used on an Exact tuple Name) + -- 2. Interface files have a special representation for tuple *occurrences* + -- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case + -- alternatives). Thus we don't rely on the OccName to figure out what kind + -- of tuple an occurrence was trying to use in these situations. + -- 3. We *don't* represent tuple data type declarations specially, so those + -- are still turned into wired-in names via isBuiltInOcc_maybe. But that's OK + -- because we don't actually need to declare constraint tuples thanks to this hack. + -- + -- So basically any OccName like (,,) flowing to isBuiltInOcc_maybe will always + -- refer to the standard boxed tuple. Cool :-) + + +tupleTyCon :: TupleSort -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) +tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) +tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) + +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i) + +promotedTupleDataCon :: TupleSort -> Arity -> TyCon +promotedTupleDataCon sort i = promoteDataCon (tupleCon sort i) + +tupleCon :: TupleSort -> Arity -> DataCon +tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleCon BoxedTuple i = snd (boxedTupleArr ! i) +tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i) +tupleCon ConstraintTuple i = snd (factTupleArr ! i) + +boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]] + +mk_tuple :: TupleSort -> Int -> (TyCon,DataCon) +mk_tuple sort arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc + prom_tc = case sort of + BoxedTuple -> Just (mkPromotedTyCon tycon (promoteKind tc_kind)) + UnboxedTuple -> Nothing + ConstraintTuple -> Nothing + + modu = mkTupleModule sort + tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind + res_kind = case sort of + BoxedTuple -> liftedTypeKind + UnboxedTuple -> unliftedTypeKind + ConstraintTuple -> constraintKind + + tyvars = take arity $ case sort of + BoxedTuple -> alphaTyVars + UnboxedTuple -> openAlphaTyVars + ConstraintTuple -> tyVarList constraintKind + + tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon + tyvar_tys = mkTyVarTys tyvars + dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique sort arity + dc_uniq = mkTupleDataConUnique sort arity + +unitTyCon :: TyCon +unitTyCon = tupleTyCon BoxedTuple 0 +unitDataCon :: DataCon +unitDataCon = head (tyConDataCons unitTyCon) +unitDataConId :: Id +unitDataConId = dataConWorkId unitDataCon + +pairTyCon :: TyCon +pairTyCon = tupleTyCon BoxedTuple 2 + +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon UnboxedTuple 0 +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleCon UnboxedTuple 0 + +unboxedSingletonTyCon :: TyCon +unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 +unboxedSingletonDataCon :: DataCon +unboxedSingletonDataCon = tupleCon UnboxedTuple 1 + +unboxedPairTyCon :: TyCon +unboxedPairTyCon = tupleTyCon UnboxedTuple 2 +unboxedPairDataCon :: DataCon +unboxedPairDataCon = tupleCon UnboxedTuple 2 + +{- +************************************************************************ +* * +\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} +* * +************************************************************************ +-} + +eqTyCon :: TyCon +eqTyCon = mkAlgTyCon eqTyConName + (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) + [kv, a, b] + [Nominal, Nominal, Nominal] + Nothing + [] -- No stupid theta + (DataTyCon [eqBoxDataCon] False) + NoParentTyCon + NonRecursive + False + Nothing -- No parent for constraint-kinded types + where + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + +eqBoxDataCon :: DataCon +eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon + where + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + args = [kv, a, b] + + +coercibleTyCon :: TyCon +coercibleTyCon = mkClassTyCon + coercibleTyConName kind tvs [Nominal, Representational, Representational] + rhs coercibleClass NonRecursive + where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + tvs = [kv, a, b] + rhs = DataTyCon [coercibleDataCon] False + +coercibleDataCon :: DataCon +coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon + where + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + args = [kv, a, b] + +coercibleClass :: Class +coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon + +charTy :: Type +charTy = mkTyConTy charTyCon + +charTyCon :: TyCon +charTyCon = pcNonRecDataTyCon charTyConName + (Just (CType "" Nothing (fsLit "HsChar"))) + [] [charDataCon] +charDataCon :: DataCon +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy :: Type +stringTy = mkListTy charTy -- convenience only + +intTy :: Type +intTy = mkTyConTy intTyCon + +intTyCon :: TyCon +intTyCon = pcNonRecDataTyCon intTyConName + (Just (CType "" Nothing (fsLit "HsInt"))) [] + [intDataCon] +intDataCon :: DataCon +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon + +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcNonRecDataTyCon wordTyConName + (Just (CType "" Nothing (fsLit "HsWord"))) [] + [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon + +floatTy :: Type +floatTy = mkTyConTy floatTyCon + +floatTyCon :: TyCon +floatTyCon = pcNonRecDataTyCon floatTyConName + (Just (CType "" Nothing (fsLit "HsFloat"))) [] + [floatDataCon] +floatDataCon :: DataCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon + +doubleTy :: Type +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon :: TyCon +doubleTyCon = pcNonRecDataTyCon doubleTyConName + (Just (CType "" Nothing (fsLit "HsDouble"))) [] + [doubleDataCon] + +doubleDataCon :: DataCon +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon + +{- +************************************************************************ +* * +\subsection[TysWiredIn-Bool]{The @Bool@ type} +* * +************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} +-} + +boolTy :: Type +boolTy = mkTyConTy boolTyCon + +boolTyCon :: TyCon +boolTyCon = pcTyCon True NonRecursive True boolTyConName + (Just (CType "" Nothing (fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] + +falseDataCon, trueDataCon :: DataCon +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId, trueDataConId :: Id +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing + [] [ltDataCon, eqDataCon, gtDataCon] + +ltDataCon, eqDataCon, gtDataCon :: DataCon +ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon +eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon +gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon + +ltDataConId, eqDataConId, gtDataConId :: Id +ltDataConId = dataConWorkId ltDataCon +eqDataConId = dataConWorkId eqDataCon +gtDataConId = dataConWorkId gtDataCon + +{- +************************************************************************ +* * +\subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)} +* * +************************************************************************ + +Special syntax, deeply wired in, but otherwise an ordinary algebraic +data types: +\begin{verbatim} +data [] a = [] | a : (List a) +data () = () +data (,) a b = (,,) a b +... +\end{verbatim} +-} + +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon :: TyCon +listTyCon = pcTyCon False Recursive True + listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon] + +mkPromotedListTy :: Type -> Type +mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] + +promotedListTyCon :: TyCon +promotedListTyCon = promoteTyCon listTyCon + +nilDataCon :: DataCon +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon + +consDataCon :: DataCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) + +{- +************************************************************************ +* * +\subsection[TysWiredIn-Tuples]{The @Tuple@ types} +* * +************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} +-} + +mkTupleTy :: TupleSort -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty +mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys + +-- | Build the type of a small tuple that holds the specified type of thing +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys + +unitTy :: Type +unitTy = mkTupleTy BoxedTuple [] + +{- +************************************************************************ +* * +\subsection[TysWiredIn-PArr]{The @[::]@ type} +* * +************************************************************************ + +Special syntax for parallel arrays needs some wired in definitions. +-} + +-- | Construct a type representing the application of the parallel array constructor +mkPArrTy :: Type -> Type +mkPArrTy ty = mkTyConApp parrTyCon [ty] + +-- | Represents the type constructor of parallel arrays +-- +-- * This must match the definition in @PrelPArr@ +-- +-- NB: Although the constructor is given here, it will not be accessible in +-- user code as it is not in the environment of any compiled module except +-- @PrelPArr@. +-- +parrTyCon :: TyCon +parrTyCon = pcNonRecDataTyCon parrTyConName Nothing alpha_tyvar [parrDataCon] + +parrDataCon :: DataCon +parrDataCon = pcDataCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [intTy, -- 1st argument: Int + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon + +-- | Check whether a type constructor is the constructor for parallel arrays +isPArrTyCon :: TyCon -> Bool +isPArrTyCon tc = tyConName tc == parrTyConName + +-- | Fake array constructors +-- +-- * These constructors are never really used to represent array values; +-- however, they are very convenient during desugaring (and, in particular, +-- in the pattern matching compiler) to treat array pattern just like +-- yet another constructor pattern +-- +parrFakeCon :: Arity -> DataCon +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i = parrFakeConArr!i + +-- pre-defined set of constructors +-- +parrFakeConArr :: Array Int DataCon +parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) + | i <- [0..mAX_TUPLE_SIZE]] + +-- build a fake parallel array constructor for the given arity +-- +mkPArrFakeCon :: Int -> DataCon +mkPArrFakeCon arity = data_con + where + data_con = pcDataCon name [tyvar] tyvarTys parrTyCon + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar + nameStr = mkFastString ("MkPArr" ++ show arity) + name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique + (AConLike (RealDataCon data_con)) UserSyntax + unique = mkPArrDataConUnique arity + +-- | Checks whether a data constructor is a fake constructor for parallel arrays +isPArrFakeCon :: DataCon -> Bool +isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) + +-- Promoted Booleans + +promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon :: TyCon +promotedBoolTyCon = promoteTyCon boolTyCon +promotedTrueDataCon = promoteDataCon trueDataCon +promotedFalseDataCon = promoteDataCon falseDataCon + +-- Promoted Ordering + +promotedOrderingTyCon + , promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + :: TyCon +promotedOrderingTyCon = promoteTyCon orderingTyCon +promotedLTDataCon = promoteDataCon ltDataCon +promotedEQDataCon = promoteDataCon eqDataCon +promotedGTDataCon = promoteDataCon gtDataCon diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot new file mode 100644 index 00000000..309dfa22 --- /dev/null +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -0,0 +1,9 @@ +module TysWiredIn where + +import {-# SOURCE #-} TyCon (TyCon) +import {-# SOURCE #-} TypeRep (Type) + + +eqTyCon, coercibleTyCon :: TyCon +typeNatKind, typeSymbolKind :: Type +mkBoxedTupleTy :: [Type] -> Type diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp new file mode 100644 index 00000000..909b17b7 --- /dev/null +++ b/compiler/prelude/primops.txt.pp @@ -0,0 +1,3034 @@ +----------------------------------------------------------------------- +-- +-- (c) 2010 The University of Glasgow +-- +-- Primitive Operations and Types +-- +-- For more information on PrimOps, see +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PrimOps +-- +----------------------------------------------------------------------- + +-- This file is processed by the utility program genprimopcode to produce +-- a number of include files within the compiler and optionally to produce +-- human-readable documentation. +-- +-- It should first be preprocessed. +-- +-- Information on how PrimOps are implemented and the steps necessary to +-- add a new one can be found in the Commentary: +-- +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PrimOps + +-- This file is divided into named sections, each containing or more +-- primop entries. Section headers have the format: +-- +-- section "section-name" {description} +-- +-- This information is used solely when producing documentation; it is +-- otherwise ignored. The description is optional. +-- +-- The format of each primop entry is as follows: +-- +-- primop internal-name "name-in-program-text" type category {description} attributes + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness info. + +-- The vector attribute is rather special. It takes a list of 3-tuples, each of +-- which is of the form . ELEM_TYPE is the type of +-- the elements in the vector; LENGTH is the length of the vector; and +-- SCALAR_TYPE is the scalar type used to inject to/project from vector +-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example, +-- to broadcast a scalar value to a vector whose elements are of type Int8, we +-- use an Int#. + +-- When a primtype or primop has a vector attribute, it is instantiated at each +-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to +-- define a family of types or primops. Vector support also adds three new +-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types +-- derived from the 3-tuple. For the 3-tuple , VECTOR expands to +-- Int64X2#, SCALAR expands to INT64, and VECTUPLE expands to (# INT64, INT64 +-- #). + +defaults + has_side_effects = False + out_of_line = False -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp + can_fail = False -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp + commutable = False + code_size = { primOpCodeSizeDefault } + strictness = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes } + fixity = Nothing + llvm_only = False + vector = [] + +-- Currently, documentation is produced using latex, so contents of +-- description fields should be legal latex. Descriptions can contain +-- matched pairs of embedded curly brackets. + +#include "MachDeps.h" + +-- We need platform defines (tests for mingw32 below). +#include "ghc_boot_platform.h" + +section "The word size story." + {Haskell98 specifies that signed integers (type {\tt Int}) + must contain at least 30 bits. GHC always implements {\tt + Int} using the primitive type {\tt Int\#}, whose size equals + the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. + This is normally set based on the {\tt config.h} parameter + {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64 + bits on 64-bit machines. However, it can also be explicitly + set to a smaller number, e.g., 31 bits, to allow the + possibility of using tag bits. Currently GHC itself has only + 32-bit and 64-bit variants, but 30 or 31-bit code can be + exported as an external core file for use in other back ends. + + GHC also implements a primitive unsigned integer type {\tt + Word\#} which always has the same number of bits as {\tt + Int\#}. + + In addition, GHC supports families of explicit-sized integers + and words at 8, 16, 32, and 64 bits, with the usual + arithmetic operations, comparisons, and a range of + conversions. The 8-bit and 16-bit sizes are always + represented as {\tt Int\#} and {\tt Word\#}, and the + operations implemented in terms of the the primops on these + types, with suitable range restrictions on the results (using + the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families + of primops. The 32-bit sizes are represented using {\tt + Int\#} and {\tt Word\#} when {\tt WORD\_SIZE\_IN\_BITS} + $\geq$ 32; otherwise, these are represented using distinct + primitive types {\tt Int32\#} and {\tt Word32\#}. These (when + needed) have a complete set of corresponding operations; + however, nearly all of these are implemented as external C + functions rather than as primops. Exactly the same story + applies to the 64-bit sizes. All of these details are hidden + under the {\tt PrelInt} and {\tt PrelWord} modules, which use + {\tt \#if}-defs to invoke the appropriate types and + operators. + + Word size also matters for the families of primops for + indexing/reading/writing fixed-size quantities at offsets + from an array base, address, or foreign pointer. Here, a + slightly different approach is taken. The names of these + primops are fixed, but their {\it types} vary according to + the value of {\tt WORD\_SIZE\_IN\_BITS}. For example, if word + size is at least 32 bits then an operator like + \texttt{indexInt32Array\#} has type {\tt ByteArray\# -> Int\# + -> Int\#}; otherwise it has type {\tt ByteArray\# -> Int\# -> + Int32\#}. This approach confines the necessary {\tt + \#if}-defs to this file; no conditional compilation is needed + in the files that expose these primops. + + Finally, there are strongly deprecated primops for coercing + between {\tt Addr\#}, the primitive type of machine + addresses, and {\tt Int\#}. These are pretty bogus anyway, + but will work on existing 32-bit and 64-bit GHC targets; they + are completely bogus when tag bits are used in {\tt Int\#}, + so are not available in this case. } + +-- Define synonyms for indexing ops. + +#if WORD_SIZE_IN_BITS < 32 +#define INT32 Int32# +#define WORD32 Word32# +#else +#define INT32 Int# +#define WORD32 Word# +#endif + +#if WORD_SIZE_IN_BITS < 64 +#define INT64 Int64# +#define WORD64 Word64# +#else +#define INT64 Int# +#define WORD64 Word# +#endif + +------------------------------------------------------------------------ +section "Char#" + {Operations on 31-bit characters.} +------------------------------------------------------------------------ + +primtype Char# + +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Int# +primop CharGeOp "geChar#" Compare Char# -> Char# -> Int# + +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Int# +primop CharLeOp "leChar#" Compare Char# -> Char# -> Int# + +primop OrdOp "ord#" GenPrimOp Char# -> Int# + with code_size = 0 + +------------------------------------------------------------------------ +section "Int#" + {Operations on native-size integers (30+ bits).} +------------------------------------------------------------------------ + +primtype Int# + +primop IntAddOp "+#" Dyadic + Int# -> Int# -> Int# + with commutable = True + fixity = infixl 6 + +primop IntSubOp "-#" Dyadic Int# -> Int# -> Int# + with fixity = infixl 6 + +primop IntMulOp "*#" + Dyadic Int# -> Int# -> Int# + {Low word of signed integer multiply.} + with commutable = True + fixity = infixl 7 + +primop IntMulMayOfloOp "mulIntMayOflo#" + Dyadic Int# -> Int# -> Int# + {Return non-zero if there is any possibility that the upper word of a + signed integer multiply might contain useful information. Return + zero only if you are completely sure that no overflow can occur. + On a 32-bit platform, the recommmended implementation is to do a + 32 x 32 -> 64 signed multiply, and subtract result[63:32] from + (result[31] >>signed 31). If this is zero, meaning that the + upper word is merely a sign extension of the lower one, no + overflow can occur. + + On a 64-bit platform it is not always possible to + acquire the top 64 bits of the result. Therefore, a recommended + implementation is to take the absolute value of both operands, and + return 0 iff bits[63:31] of them are zero, since that means that their + magnitudes fit within 31 bits, so the magnitude of the product must fit + into 62 bits. + + If in doubt, return non-zero, but do make an effort to create the + correct answer for small args, since otherwise the performance of + \texttt{(*) :: Integer -> Integer -> Integer} will be poor. + } + with commutable = True + +primop IntQuotOp "quotInt#" Dyadic + Int# -> Int# -> Int# + {Rounds towards zero.} + with can_fail = True + +primop IntRemOp "remInt#" Dyadic + Int# -> Int# -> Int# + {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} + with can_fail = True + +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with can_fail = True + +primop AndIOp "andI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop OrIOp "orI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop XorIOp "xorI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop NotIOp "notI#" Monadic Int# -> Int# + +primop IntNegOp "negateInt#" Monadic Int# -> Int# +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add signed integers reporting overflow. + First member of result is the sum truncated to an {\tt Int#}; + second member is zero if the true sum fits in an {\tt Int#}, + nonzero if overflow occurred (the sum is either too large + or too small to fit in an {\tt Int#}).} + with code_size = 2 + +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract signed integers reporting overflow. + First member of result is the difference truncated to an {\tt Int#}; + second member is zero if the true difference fits in an {\tt Int#}, + nonzero if overflow occurred (the difference is either too large + or too small to fit in an {\tt Int#}).} + with code_size = 2 + +primop IntGtOp ">#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntGeOp ">=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntEqOp "==#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntLtOp "<#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntLeOp "<=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + with code_size = 0 + +primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# + with code_size = 0 + +primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# +primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# + +primop Word2FloatOp "word2Float#" GenPrimOp Word# -> Float# +primop Word2DoubleOp "word2Double#" GenPrimOp Word# -> Double# + +primop ISllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop ISraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithmetic. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop ISrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +------------------------------------------------------------------------ +section "Word#" + {Operations on native-sized unsigned words (30+ bits).} +------------------------------------------------------------------------ + +primtype Word# + +primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +-- Returns (# high, low #) (or equivalently, (# carry, low #)) +primop WordAdd2Op "plusWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + +primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +-- Returns (# high, low #) +primop WordMul2Op "timesWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + +primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + +-- Takes high word of dividend, then low word of dividend, then divisor. +-- Requires that high word is not divisible by divisor. +primop WordQuotRem2Op "quotRemWord2#" GenPrimOp + Word# -> Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + +primop AndOp "and#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop OrOp "or#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop XorOp "xor#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop NotOp "not#" Monadic Word# -> Word# + +primop SllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# + with code_size = 0 + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Int# +primop WordGeOp "geWord#" Compare Word# -> Word# -> Int# +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Int# +primop WordNeOp "neWord#" Compare Word# -> Word# -> Int# +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int# +primop WordLeOp "leWord#" Compare Word# -> Word# -> Int# + +primop PopCnt8Op "popCnt8#" Monadic Word# -> Word# + {Count the number of set bits in the lower 8 bits of a word.} +primop PopCnt16Op "popCnt16#" Monadic Word# -> Word# + {Count the number of set bits in the lower 16 bits of a word.} +primop PopCnt32Op "popCnt32#" Monadic Word# -> Word# + {Count the number of set bits in the lower 32 bits of a word.} +primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word# + {Count the number of set bits in a 64-bit word.} +primop PopCntOp "popCnt#" Monadic Word# -> Word# + {Count the number of set bits in a word.} + +primop Clz8Op "clz8#" Monadic Word# -> Word# + {Count leading zeros in the lower 8 bits of a word.} +primop Clz16Op "clz16#" Monadic Word# -> Word# + {Count leading zeros in the lower 16 bits of a word.} +primop Clz32Op "clz32#" Monadic Word# -> Word# + {Count leading zeros in the lower 32 bits of a word.} +primop Clz64Op "clz64#" GenPrimOp WORD64 -> Word# + {Count leading zeros in a 64-bit word.} +primop ClzOp "clz#" Monadic Word# -> Word# + {Count leading zeros in a word.} + +primop Ctz8Op "ctz8#" Monadic Word# -> Word# + {Count trailing zeros in the lower 8 bits of a word.} +primop Ctz16Op "ctz16#" Monadic Word# -> Word# + {Count trailing zeros in the lower 16 bits of a word.} +primop Ctz32Op "ctz32#" Monadic Word# -> Word# + {Count trailing zeros in the lower 32 bits of a word.} +primop Ctz64Op "ctz64#" GenPrimOp WORD64 -> Word# + {Count trailing zeros in a 64-bit word.} +primop CtzOp "ctz#" Monadic Word# -> Word# + {Count trailing zeros in a word.} + +primop BSwap16Op "byteSwap16#" Monadic Word# -> Word# + {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } +primop BSwap32Op "byteSwap32#" Monadic Word# -> Word# + {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } +primop BSwap64Op "byteSwap64#" Monadic WORD64 -> WORD64 + {Swap bytes in a 64 bits of a word.} +primop BSwapOp "byteSwap#" Monadic Word# -> Word# + {Swap bytes in a word.} + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" Monadic Int# -> Int# +primop Narrow16IntOp "narrow16Int#" Monadic Int# -> Int# +primop Narrow32IntOp "narrow32Int#" Monadic Int# -> Int# +primop Narrow8WordOp "narrow8Word#" Monadic Word# -> Word# +primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word# +primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word# + + +#if WORD_SIZE_IN_BITS < 32 +------------------------------------------------------------------------ +section "Int32#" + {Operations on 32-bit integers ({\tt Int32\#}). This type is only used + if plain {\tt Int\#} has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primtype Int32# + +------------------------------------------------------------------------ +section "Word32#" + {Operations on 32-bit unsigned words. This type is only used + if plain {\tt Word\#} has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primtype Word32# + +#endif + + +#if WORD_SIZE_IN_BITS < 64 +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit unsigned words. This type is only used + if plain {\tt Int\#} has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primtype Int64# + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words. This type is only used + if plain {\tt Word\#} has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primtype Word64# + +#endif + +------------------------------------------------------------------------ +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Double# + +primop DoubleGtOp ">##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleGeOp ">=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleEqOp "==##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleNeOp "/=##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleLtOp "<##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleAddOp "+##" Dyadic + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 6 + +primop DoubleSubOp "-##" Dyadic Double# -> Double# -> Double# + with fixity = infixl 6 + +primop DoubleMulOp "*##" Dyadic + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 7 + +primop DoubleDivOp "/##" Dyadic + Double# -> Double# -> Double# + with can_fail = True + fixity = infixl 7 + +primop DoubleNegOp "negateDouble#" Monadic Double# -> Double# + +primop Double2IntOp "double2Int#" GenPrimOp Double# -> Int# + {Truncates a {\tt Double#} value to the nearest {\tt Int#}. + Results are undefined if the truncation if truncation yields + a value outside the range of {\tt Int#}.} + +primop Double2FloatOp "double2Float#" GenPrimOp Double# -> Float# + +primop DoubleExpOp "expDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleLogOp "logDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop DoubleSqrtOp "sqrtDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinOp "sinDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCosOp "cosDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanOp "tanDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAsinOp "asinDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop DoubleAcosOp "acosDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop DoubleAtanOp "atanDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinhOp "sinhDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCoshOp "coshDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanhOp "tanhDouble#" Monadic + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoublePowerOp "**##" Dyadic + Double# -> Double# -> Double# + {Exponentiation.} + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp + Double# -> (# Int#, Word#, Word#, Int# #) + {Convert to integer. + First component of the result is -1 or 1, indicating the sign of the + mantissa. The next two are the high and low 32 bits of the mantissa + respectively, and the last is the exponent.} + with out_of_line = True + +primop DoubleDecode_Int64Op "decodeDouble_Int64#" GenPrimOp + Double# -> (# INT64, Int# #) + {Decode {\tt Double\#} into mantissa and base-2 exponent.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Float# + +primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Int# +primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Int# + +primop FloatEqOp "eqFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatNeOp "neFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int# +primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int# + +primop FloatAddOp "plusFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatSubOp "minusFloat#" Dyadic Float# -> Float# -> Float# + +primop FloatMulOp "timesFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatDivOp "divideFloat#" Dyadic + Float# -> Float# -> Float# + with can_fail = True + +primop FloatNegOp "negateFloat#" Monadic Float# -> Float# + +primop Float2IntOp "float2Int#" GenPrimOp Float# -> Int# + {Truncates a {\tt Float#} value to the nearest {\tt Int#}. + Results are undefined if the truncation if truncation yields + a value outside the range of {\tt Int#}.} + +primop FloatExpOp "expFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatLogOp "logFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop FloatSqrtOp "sqrtFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinOp "sinFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCosOp "cosFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanOp "tanFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAsinOp "asinFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop FloatAcosOp "acosFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True + +primop FloatAtanOp "atanFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinhOp "sinhFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCoshOp "coshFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanhOp "tanhFloat#" Monadic + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatPowerOp "powerFloat#" Dyadic + Float# -> Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double# + +primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp + Float# -> (# Int#, Int# #) + {Convert to integers. + First {\tt Int\#} in result is the mantissa; second is the exponent.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Arrays" + {Operations on {\tt Array\#}.} +------------------------------------------------------------------------ + +primtype Array# a + +primtype MutableArray# s a + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, MutableArray# s a #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + has_side_effects = True + +primop SameMutableArrayOp "sameMutableArray#" GenPrimOp + MutableArray# s a -> MutableArray# s a -> Int# + +primop ReadArrayOp "readArray#" GenPrimOp + MutableArray# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + has_side_effects = True + can_fail = True + +primop WriteArrayOp "writeArray#" GenPrimOp + MutableArray# s a -> Int# -> a -> State# s -> State# s + {Write to specified index of mutable array.} + with + has_side_effects = True + can_fail = True + code_size = 2 -- card update too + +primop SizeofArrayOp "sizeofArray#" GenPrimOp + Array# a -> Int# + {Return the number of elements in the array.} + +primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp + MutableArray# s a -> Int# + {Return the number of elements in the array.} + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + can_fail = True + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutableArray# s a -> State# s -> (# State# s, Array# a #) + {Make a mutable array immutable, without copying.} + with + has_side_effects = True + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a -> State# s -> (# State# s, MutableArray# s a #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + has_side_effects = True + +primop CopyArrayOp "copyArray#" GenPrimOp + Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp + MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. The source and destination arrays can + refer to the same array. Both arrays must fully contain the + specified ranges, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CloneArrayOp "cloneArray#" GenPrimOp + Array# a -> Int# -> Int# -> Array# a + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp + MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop FreezeArrayOp "freezeArray#" GenPrimOp + MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop ThawArrayOp "thawArray#" GenPrimOp + Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CasArrayOp "casArray#" GenPrimOp + MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) + {Unsafe, machine-level atomic compare and swap on an element within an Array.} + with + out_of_line = True + has_side_effects = True + + +------------------------------------------------------------------------ +section "Small Arrays" + + {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works + just like an {\tt Array\#}, but with different space use and + performance characteristics (that are often useful with small + arrays). The {\tt SmallArray\#} and {\tt SmallMutableArray#} + lack a `card table'. The purpose of a card table is to avoid + having to scan every element of the array on each GC by + keeping track of which elements have changed since the last GC + and only scanning those that have changed. So the consequence + of there being no card table is that the representation is + somewhat smaller and the writes are somewhat faster (because + the card table does not need to be updated). The disadvantage + of course is that for a {\tt SmallMutableArray#} the whole + array has to be scanned on each GC. Thus it is best suited for + use cases where the mutable array is not long lived, e.g. + where a mutable array is initialised quickly and then frozen + to become an immutable {\tt SmallArray\#}. + } + +------------------------------------------------------------------------ + +primtype SmallArray# a + +primtype SmallMutableArray# s a + +primop NewSmallArrayOp "newSmallArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, SmallMutableArray# s a #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + has_side_effects = True + +primop SameSmallMutableArrayOp "sameSmallMutableArray#" GenPrimOp + SmallMutableArray# s a -> SmallMutableArray# s a -> Int# + +primop ReadSmallArrayOp "readSmallArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + has_side_effects = True + can_fail = True + +primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> a -> State# s -> State# s + {Write to specified index of mutable array.} + with + has_side_effects = True + can_fail = True + +primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp + SmallArray# a -> Int# + {Return the number of elements in the array.} + +primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp + SmallMutableArray# s a -> Int# + {Return the number of elements in the array.} + +primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp + SmallArray# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + can_fail = True + +primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp + SmallMutableArray# s a -> State# s -> (# State# s, SmallArray# a #) + {Make a mutable array immutable, without copying.} + with + has_side_effects = True + +primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp + SmallArray# a -> State# s -> (# State# s, SmallMutableArray# s a #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + has_side_effects = True + +-- The code_size is only correct for the case when the copy family of +-- primops aren't inlined. It would be nice to keep track of both. + +primop CopySmallArrayOp "copySmallArray#" GenPrimOp + SmallArray# a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. The source and destination arrays can + refer to the same array. Both arrays must fully contain the + specified ranges, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp + SmallArray# a -> Int# -> Int# -> SmallArray# a + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp + SmallArray# a -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CasSmallArrayOp "casSmallArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) + {Unsafe, machine-level atomic compare and swap on an element within an array.} + with + out_of_line = True + has_side_effects = True + +------------------------------------------------------------------------ +section "Byte Arrays" + {Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of + raw memory in the garbage-collected heap, which is not + scanned for pointers. It carries its own size (in bytes). + There are + three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for a + range of useful primitive data types. Each operation takes + an offset measured in terms of the size of the primitive type + being read or written.} + +------------------------------------------------------------------------ + +primtype ByteArray# + +primtype MutableByteArray# s + +primop NewByteArrayOp_Char "newByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread.} + with out_of_line = True + has_side_effects = True + +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Create a mutable byte array that the GC guarantees not to move.} + with out_of_line = True + has_side_effects = True + +primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp + Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.} + with out_of_line = True + has_side_effects = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArray# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp + MutableByteArray# s -> MutableByteArray# s -> Int# + +primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + {Shrink mutable byte array to new specified size (in bytes), in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by {\tt sizeofMutableArray\#}.} + with out_of_line = True + has_side_effects = True + +primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) + {Resize (unpinned) mutable byte array to new specified size (in bytes). + The returned {\tt MutableByteArray\#} is either the original + {\tt MutableByteArray\#} resized in-place or, if not possible, a newly + allocated (unpinned) {\tt MutableByteArray\#} (with the original content + copied over). + + To avoid undefined behaviour, the original {\tt MutableByteArray\#} shall + not be accessed anymore after a {\tt resizeMutableByteArray\#} has been + performed. Moreover, no reference to the old one should be kept in order + to allow garbage collection of the original {\tt MutableByteArray\#} in + case a new {\tt MutableByteArray\#} had to be allocated.} + with out_of_line = True + has_side_effects = True + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) + {Make a mutable byte array immutable, without copying.} + with + has_side_effects = True + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArray# -> Int# + {Return the size of the array in bytes.} + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# + {Return the size of the array in bytes.} + +primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp + ByteArray# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} + with can_fail = True + +primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp + ByteArray# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} + with can_fail = True + +primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp + ByteArray# -> Int# -> Int# + with can_fail = True + +primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp + ByteArray# -> Int# -> Word# + with can_fail = True + +primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp + ByteArray# -> Int# -> Addr# + with can_fail = True + +primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp + ByteArray# -> Int# -> Float# + with can_fail = True + +primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp + ByteArray# -> Int# -> Double# + with can_fail = True + +primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp + ByteArray# -> Int# -> StablePtr# a + with can_fail = True + +primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp + ByteArray# -> Int# -> Int# + {Read 8-bit integer; offset in bytes.} + with can_fail = True + +primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp + ByteArray# -> Int# -> Int# + {Read 16-bit integer; offset in 16-bit words.} + with can_fail = True + +primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp + ByteArray# -> Int# -> INT32 + {Read 32-bit integer; offset in 32-bit words.} + with can_fail = True + +primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp + ByteArray# -> Int# -> INT64 + {Read 64-bit integer; offset in 64-bit words.} + with can_fail = True + +primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp + ByteArray# -> Int# -> Word# + {Read 8-bit word; offset in bytes.} + with can_fail = True + +primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp + ByteArray# -> Int# -> Word# + {Read 16-bit word; offset in 16-bit words.} + with can_fail = True + +primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp + ByteArray# -> Int# -> WORD32 + {Read 32-bit word; offset in 32-bit words.} + with can_fail = True + +primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp + ByteArray# -> Int# -> WORD64 + {Read 64-bit word; offset in 64-bit words.} + with can_fail = True + +primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 8-bit character; offset in bytes.} + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 31-bit character; offset in 4-byte words.} + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Read intger; offset in words.} + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) + {Read word; offset in words.} + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #) + with has_side_effects = True + can_fail = True + +primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #) + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp + MutableByteArray# s -> Int# -> Char# -> State# s -> State# s + {Write 8-bit character; offset in bytes.} + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp + MutableByteArray# s -> Int# -> Char# -> State# s -> State# s + {Write 31-bit character; offset in 4-byte words.} + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp + MutableByteArray# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp + MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp + MutableByteArray# s -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp + MutableByteArray# s -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp + MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp + MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp + MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s + with can_fail = True + has_side_effects = True + +primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp + MutableByteArray# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp + MutableByteArray# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp + MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp + MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop CopyByteArrayOp "copyByteArray#" GenPrimOp + ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray# to the specified region in the MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked. + The two arrays must not be the same array in different states, but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4} + can_fail = True + +primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + can_fail = True + +primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp + ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray# to the memory range starting at the Addr#. + The ByteArray# and the memory region at Addr# must fully contain the + specified ranges, but this is not checked. The Addr# must not point into the + ByteArray# (e.g. if the ByteArray# were pinned), but this is not checked + either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4} + can_fail = True + +primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp + MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the MutableByteArray# to the memory range starting at the + Addr#. The MutableByteArray# and the memory region at Addr# must fully + contain the specified ranges, but this is not checked. The Addr# must not + point into the MutableByteArray# (e.g. if the MutableByteArray# were + pinned), but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4} + can_fail = True + +primop CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp + Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a memory range starting at the Addr# to the specified range in the + MutableByteArray#. The memory region at Addr# and the ByteArray# must fully + contain the specified ranges, but this is not checked. The Addr# must not + point into the MutableByteArray# (e.g. if the MutableByteArray# were pinned), + but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4} + can_fail = True + +primop SetByteArrayOp "setByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s + {Set the range of the MutableByteArray# to the specified character.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + can_fail = True + +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in Int units, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in Int units, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop CasByteArrayOp_Int "casIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, an offset in Int units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with has_side_effects = True + can_fail = True + +primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to subtract, + atomically substract the value to the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to AND, + atomically AND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to NAND, + atomically NAND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to OR, + atomically OR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to XOR, + atomically XOR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + + +------------------------------------------------------------------------ +section "Arrays of arrays" + {Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed} + arrays, such as {\tt ByteArray\#s}. Hence, it is not parameterised by the element types, + just like a {\tt ByteArray\#}, but it needs to be scanned during GC, just like an {\tt Array#}. + We represent an {\tt ArrayArray\#} exactly as a {\tt Array\#}, but provide element-type-specific + indexing, reading, and writing.} +------------------------------------------------------------------------ + +primtype ArrayArray# + +primtype MutableArrayArray# s + +primop NewArrayArrayOp "newArrayArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableArrayArray# s #) + {Create a new mutable array of arrays with the specified number of elements, + in the specified state thread, with each element recursively referring to the + newly created array.} + with + out_of_line = True + has_side_effects = True + +primop SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp + MutableArrayArray# s -> MutableArrayArray# s -> Int# + +primop UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp + MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #) + {Make a mutable array of arrays immutable, without copying.} + with + has_side_effects = True + +primop SizeofArrayArrayOp "sizeofArrayArray#" GenPrimOp + ArrayArray# -> Int# + {Return the number of elements in the array.} + +primop SizeofMutableArrayArrayOp "sizeofMutableArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# + {Return the number of elements in the array.} + +primop IndexArrayArrayOp_ByteArray "indexByteArrayArray#" GenPrimOp + ArrayArray# -> Int# -> ByteArray# + with can_fail = True + +primop IndexArrayArrayOp_ArrayArray "indexArrayArrayArray#" GenPrimOp + ArrayArray# -> Int# -> ArrayArray# + with can_fail = True + +primop ReadArrayArrayOp_ByteArray "readByteArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> State# s -> (# State# s, ByteArray# #) + with has_side_effects = True + can_fail = True + +primop ReadArrayArrayOp_MutableByteArray "readMutableByteArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + with has_side_effects = True + can_fail = True + +primop ReadArrayArrayOp_ArrayArray "readArrayArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> State# s -> (# State# s, ArrayArray# #) + with has_side_effects = True + can_fail = True + +primop ReadArrayArrayOp_MutableArrayArray "readMutableArrayArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) + with has_side_effects = True + can_fail = True + +primop WriteArrayArrayOp_ByteArray "writeByteArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> ByteArray# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteArrayArrayOp_MutableByteArray "writeMutableByteArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> MutableByteArray# s -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteArrayArrayOp_ArrayArray "writeArrayArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> ArrayArray# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteArrayArrayOp_MutableArrayArray "writeMutableArrayArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> MutableArrayArray# s -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop CopyArrayArrayOp "copyArrayArray#" GenPrimOp + ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the ArrayArray# to the specified region in the MutableArrayArray#. + Both arrays must fully contain the specified ranges, but this is not checked. + The two arrays must not be the same array in different states, but this is not checked either.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CopyMutableArrayArrayOp "copyMutableArrayArray#" GenPrimOp + MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the first MutableArrayArray# to the specified region in the second + MutableArrayArray#. + Both arrays must fully contain the specified ranges, but this is not checked.} + with + out_of_line = True + has_side_effects = True + can_fail = True + +------------------------------------------------------------------------ +section "Addr#" +------------------------------------------------------------------------ + +primtype Addr# + { An arbitrary machine address assumed to point outside + the garbage-collected heap. } + +pseudoop "nullAddr#" Addr# + { The null address. } + +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two {\tt Addr\#}s are so far apart that their + difference doesn't fit in an {\tt Int\#}.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the {\tt Addr\#} arg, treated like an {\tt Int\#}, + is divided by the {\tt Int\#} arg.} +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) +primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Strongly deprecated.} + with code_size = 0 +primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Strongly deprecated.} + with code_size = 0 +#endif + +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int# +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int# +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Int# +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int# + +primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 8-bit character; offset in bytes.} + with can_fail = True + +primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 31-bit character; offset in 4-byte words.} + with can_fail = True + +primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# + with can_fail = True + +primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# + with can_fail = True + +primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# + with can_fail = True + +primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# + with can_fail = True + +primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# + with can_fail = True + +primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a + with can_fail = True + +primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + with can_fail = True + +primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + with can_fail = True + +primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp + Addr# -> Int# -> INT32 + with can_fail = True + +primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp + Addr# -> Int# -> INT64 + with can_fail = True + +primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + with can_fail = True + +primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + with can_fail = True + +primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp + Addr# -> Int# -> WORD32 + with can_fail = True + +primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp + Addr# -> Int# -> WORD64 + with can_fail = True + +primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 8-bit character; offset in bytes.} + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 31-bit character; offset in 4-byte words.} + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Addr# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Float# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Double# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, INT32 #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, INT64 #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, WORD32 #) + with has_side_effects = True + can_fail = True + +primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, WORD64 #) + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp + Addr# -> Int# -> INT32 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp + Addr# -> Int# -> INT64 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp + Addr# -> Int# -> WORD32 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp + Addr# -> Int# -> WORD64 -> State# s -> State# s + with has_side_effects = True + can_fail = True + +------------------------------------------------------------------------ +section "Mutable variables" + {Operations on MutVar\#s.} +------------------------------------------------------------------------ + +primtype MutVar# s a + {A {\tt MutVar\#} behaves like a single-element mutable array.} + +primop NewMutVarOp "newMutVar#" GenPrimOp + a -> State# s -> (# State# s, MutVar# s a #) + {Create {\tt MutVar\#} with specified initial value in specified state thread.} + with + out_of_line = True + has_side_effects = True + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a -> State# s -> (# State# s, a #) + {Read contents of {\tt MutVar\#}. Result is not yet evaluated.} + with + has_side_effects = True + can_fail = True + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a -> a -> State# s -> State# s + {Write contents of {\tt MutVar\#}.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } -- for the write barrier + can_fail = True + +primop SameMutVarOp "sameMutVar#" GenPrimOp + MutVar# s a -> MutVar# s a -> Int# + +-- not really the right type, but we don't know about pairs here. The +-- correct type is +-- +-- MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #) +-- +primop AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp + MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #) + with + out_of_line = True + has_side_effects = True + can_fail = True + +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) + with + out_of_line = True + has_side_effects = True + +------------------------------------------------------------------------ +section "Exceptions" +------------------------------------------------------------------------ + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld + -> (# State# RealWorld, a #) + with + -- Catch is actually strict in its first argument + -- but we don't want to tell the strictness + -- analyser about that, so that exceptions stay inside it. + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop RaiseOp "raise#" GenPrimOp + a -> b + with + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + -- NB: result is bottom + out_of_line = True + has_side_effects = True + -- raise# certainly throws a Haskell exception and hence has_side_effects + -- It doesn't actually make much difference because the fact that it + -- returns bottom independently ensures that we are careful not to discard + -- it. But still, it's better to say the Right Thing. + +-- raiseIO# needs to be a primop, because exceptions in the IO monad +-- must be *precise* - we don't want the strictness analyser turning +-- one kind of bottom into another, as it is allowed to do in pure code. +-- +-- But we *do* want to know that it returns bottom after +-- being applied to two arguments, so that this function is strict in y +-- f x y | x>0 = raiseIO blah +-- | y>0 = return 1 +-- | otherwise = return 2 + +primop RaiseIOOp "raiseIO#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, b #) + with + strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes } + out_of_line = True + has_side_effects = True + +primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop MaskStatus "getMaskingState#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + has_side_effects = True + +------------------------------------------------------------------------ +section "STM-accessible Mutable Variables" +------------------------------------------------------------------------ + +primtype TVar# s a + +primop AtomicallyOp "atomically#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld -> (# State# RealWorld, a #) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +-- NB: retry#'s strictness information specifies it to return bottom. +-- This lets the compiler perform some extra simplifications, since retry# +-- will technically never return. +-- +-- This allows the simplifier to replace things like: +-- case retry# s1 +-- (# s2, a #) -> e +-- with: +-- retry# s1 +-- where 'e' would be unreachable anyway. See Trac #8091. +primop RetryOp "retry#" GenPrimOp + State# RealWorld -> (# State# RealWorld, a #) + with + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + out_of_line = True + has_side_effects = True + +primop CatchRetryOp "catchRetry#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply1Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop CatchSTMOp "catchSTM#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + with + strictness = { \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes } + out_of_line = True + has_side_effects = True + +primop Check "check#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, () #) ) + with + out_of_line = True + has_side_effects = True + +primop NewTVarOp "newTVar#" GenPrimOp + a + -> State# s -> (# State# s, TVar# s a #) + {Create a new {\tt TVar\#} holding a specified initial value.} + with + out_of_line = True + has_side_effects = True + +primop ReadTVarOp "readTVar#" GenPrimOp + TVar# s a + -> State# s -> (# State# s, a #) + {Read contents of {\tt TVar\#}. Result is not yet evaluated.} + with + out_of_line = True + has_side_effects = True + +primop ReadTVarIOOp "readTVarIO#" GenPrimOp + TVar# s a + -> State# s -> (# State# s, a #) + {Read contents of {\tt TVar\#} outside an STM transaction} + with + out_of_line = True + has_side_effects = True + +primop WriteTVarOp "writeTVar#" GenPrimOp + TVar# s a + -> a + -> State# s -> State# s + {Write contents of {\tt TVar\#}.} + with + out_of_line = True + has_side_effects = True + +primop SameTVarOp "sameTVar#" GenPrimOp + TVar# s a -> TVar# s a -> Int# + + +------------------------------------------------------------------------ +section "Synchronized Mutable Variables" + {Operations on {\tt MVar\#}s. } +------------------------------------------------------------------------ + +primtype MVar# s a + { A shared mutable variable ({\it not} the same as a {\tt MutVar\#}!). + (Note: in a non-concurrent implementation, {\tt (MVar\# a)} can be + represented by {\tt (MutVar\# (Maybe a))}.) } + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a #) + {Create new {\tt MVar\#}; initially empty.} + with + out_of_line = True + has_side_effects = True + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + {If {\tt MVar\#} is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + out_of_line = True + has_side_effects = True + +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of {\tt MVar\#}, and set {\tt MVar\#} empty.} + with + out_of_line = True + has_side_effects = True + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a -> a -> State# s -> State# s + {If {\tt MVar\#} is full, block until it becomes empty. + Then store value arg as its new contents.} + with + out_of_line = True + has_side_effects = True + +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a -> a -> State# s -> (# State# s, Int# #) + {If {\tt MVar\#} is full, immediately return with integer 0. + Otherwise, store value arg as {\tt MVar\#}'s new contents, and return with integer 1.} + with + out_of_line = True + has_side_effects = True + +primop ReadMVarOp "readMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + {If {\tt MVar\#} is empty, block until it becomes full. + Then read its contents without modifying the MVar, without possibility + of intervention from other threads.} + with + out_of_line = True + has_side_effects = True + +primop TryReadMVarOp "tryReadMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of {\tt MVar\#}.} + with + out_of_line = True + has_side_effects = True + +primop SameMVarOp "sameMVar#" GenPrimOp + MVar# s a -> MVar# s a -> Int# + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int# #) + {Return 1 if {\tt MVar\#} is empty; 0 otherwise.} + with + out_of_line = True + has_side_effects = True + +------------------------------------------------------------------------ +section "Delay/wait operations" +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + {Sleep specified number of microseconds.} + with + has_side_effects = True + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} + with + has_side_effects = True + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} + with + has_side_effects = True + out_of_line = True + +#ifdef mingw32_TARGET_OS +primop AsyncReadOp "asyncRead#" GenPrimOp + Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously read bytes from specified file descriptor.} + with + has_side_effects = True + out_of_line = True + +primop AsyncWriteOp "asyncWrite#" GenPrimOp + Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously write bytes from specified file descriptor.} + with + has_side_effects = True + out_of_line = True + +primop AsyncDoProcOp "asyncDoProc#" GenPrimOp + Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously perform procedure (first arg), passing it 2nd arg.} + with + has_side_effects = True + out_of_line = True + +#endif + +------------------------------------------------------------------------ +section "Concurrency primitives" +------------------------------------------------------------------------ + +primtype State# s + { {\tt State\#} is the primitive, unlifted type of states. It has + one type parameter, thus {\tt State\# RealWorld}, or {\tt State\# s}, + where s is a type variable. The only purpose of the type parameter + is to keep different state threads separate. It is represented by + nothing at all. } + +primtype RealWorld + { {\tt RealWorld} is deeply magical. It is {\it primitive}, but it is not + {\it unlifted} (hence {\tt ptrArg}). We never manipulate values of type + {\tt RealWorld}; it's only used in the type system, to parameterise {\tt State\#}. } + +primtype ThreadId# + {(In a non-concurrent implementation, this can be a singleton + type, whose (unique) value is returned by {\tt myThreadId\#}. The + other operations can be omitted.)} + +primop ForkOp "fork#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + has_side_effects = True + out_of_line = True + +primop ForkOnOp "forkOn#" GenPrimOp + Int# -> a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + has_side_effects = True + out_of_line = True + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + out_of_line = True + has_side_effects = True + +primop LabelThreadOp "labelThread#" GenPrimOp + ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + has_side_effects = True + +primop NoDuplicateOp "noDuplicate#" GenPrimOp + State# RealWorld -> State# RealWorld + with + out_of_line = True + has_side_effects = True + +primop ThreadStatusOp "threadStatus#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #) + with + out_of_line = True + has_side_effects = True + +------------------------------------------------------------------------ +section "Weak pointers" +------------------------------------------------------------------------ + +primtype Weak# b + +-- note that tyvar "o" denotes openAlphaTyVar + +primop MkWeakOp "mkWeak#" GenPrimOp + o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + has_side_effects = True + out_of_line = True + +primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp + o -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + has_side_effects = True + out_of_line = True + +primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp + Addr# -> Addr# -> Int# -> Addr# -> Weak# b + -> State# RealWorld -> (# State# RealWorld, Int# #) + { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C + function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If + {\tt flag} is zero, {\tt fptr} will be called with one argument, + {\tt ptr}. Otherwise, it will be called with two arguments, + {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns + 1 on success, or 0 if {\tt w} is already dead. } + with + has_side_effects = True + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) + with + has_side_effects = True + out_of_line = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, () #)) #) + with + has_side_effects = True + out_of_line = True + +primop TouchOp "touch#" GenPrimOp + o -> State# RealWorld -> State# RealWorld + with + code_size = { 0 } + has_side_effects = True + +------------------------------------------------------------------------ +section "Stable pointers and names" +------------------------------------------------------------------------ + +primtype StablePtr# a + +primtype StableName# a + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) + with + has_side_effects = True + out_of_line = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) + with + has_side_effects = True + out_of_line = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a -> StablePtr# a -> Int# + with + has_side_effects = True + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StableName# a #) + with + has_side_effects = True + out_of_line = True + +primop EqStableNameOp "eqStableName#" GenPrimOp + StableName# a -> StableName# b -> Int# + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a -> Int# + +------------------------------------------------------------------------ +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alistair Reid :) +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a -> a -> Int# + +------------------------------------------------------------------------ +section "Parallelism" +------------------------------------------------------------------------ + +primop ParOp "par#" GenPrimOp + a -> Int# + with + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluted strictly, which it should *not* be + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SeqOp "seq#" GenPrimOp + a -> State# s -> (# State# s, a #) + + -- why return the value? So that we can control sharing of seq'd + -- values: in + -- let x = e in x `seq` ... x ... + -- we don't want to inline x, so better to represent it as + -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + -- also it matches the type of rseq in the Eval monad. + +primop GetSparkOp "getSpark#" GenPrimOp + State# s -> (# State# s, Int#, a #) + with + has_side_effects = True + out_of_line = True + +primop NumSparks "numSparks#" GenPrimOp + State# s -> (# State# s, Int# #) + { Returns the number of sparks in the local spark pool. } + with + has_side_effects = True + out_of_line = True + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +primop ParGlobalOp "parGlobal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + has_side_effects = True + +primop ParLocalOp "parLocal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + has_side_effects = True + +primop ParAtOp "parAt#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + has_side_effects = True + +primop ParAtAbsOp "parAtAbs#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + has_side_effects = True + +primop ParAtRelOp "parAtRel#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + has_side_effects = True + +primop ParAtForNowOp "parAtForNow#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + has_side_effects = True + +-- copyable# and noFollow# are yet to be implemented (for GpH) +-- +--primop CopyableOp "copyable#" GenPrimOp +-- a -> Int# +-- with +-- has_side_effects = True +-- +--primop NoFollowOp "noFollow#" GenPrimOp +-- a -> Int# +-- with +-- has_side_effects = True + + +------------------------------------------------------------------------ +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} +------------------------------------------------------------------------ + +primop DataToTagOp "dataToTag#" GenPrimOp + a -> Int# + with + strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes } + + -- dataToTag# must have an evaluated argument + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for the bytecode interpreter and linker.} +------------------------------------------------------------------------ + +primtype BCO# + {Primitive bytecode type.} + +primop AddrToAnyOp "addrToAny#" GenPrimOp + Addr# -> (# a #) + {Convert an {\tt Addr\#} to a followable Any type.} + with + code_size = 0 + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + BCO# -> (# a #) + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO# #) + with + has_side_effects = True + out_of_line = True + +primop UnpackClosureOp "unpackClosure#" GenPrimOp + a -> (# Addr#, Array# b, ByteArray# #) + with + out_of_line = True + +primop GetApStackValOp "getApStackVal#" GenPrimOp + a -> Int# -> (# Int#, b #) + with + out_of_line = True + +------------------------------------------------------------------------ +section "Misc" + {These aren't nearly as wired in as Etc...} +------------------------------------------------------------------------ + +primop GetCCSOfOp "getCCSOf#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + +primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + { Returns the current {\tt CostCentreStack} (value is {\tt NULL} if + not profiling). Takes a dummy argument which can be used to + avoid the call to {\tt getCCCS\#} being floated out by the + simplifier, which would result in an uninformative stack + ("CAF"). } + +------------------------------------------------------------------------ +section "Etc" + {Miscellaneous built-ins} +------------------------------------------------------------------------ + +primtype Proxy# a + { The type constructor {\tt Proxy#} is used to bear witness to some + type variable. It's used when you want to pass around proxy values + for doing things like modelling type applications. A {\tt Proxy#} + is not only unboxed, it also has a polymorphic kind, and has no + runtime representation, being totally free. } + +pseudoop "proxy#" + Proxy# a + { Witness for an unboxed {\tt Proxy#} value, which has no runtime + representation. } + +pseudoop "seq" + a -> b -> b + { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and + otherwise equal to {\tt b}. {\tt seq} is usually introduced to + improve performance by avoiding unneeded laziness. + + A note on evaluation order: the expression {\tt seq a b} does + {\it not} guarantee that {\tt a} will be evaluated before {\tt b}. + The only guarantee given by {\tt seq} is that the both {\tt a} + and {\tt b} will be evaluated before {\tt seq} returns a value. + In particular, this means that {\tt b} may be evaluated before + {\tt a}. If you need to guarantee a specific order of evaluation, + you must use the function {\tt pseq} from the "parallel" package. } + +primtype Any + { The type constructor {\tt Any} is type to which you can unsafely coerce any + lifted type, and back. + + * It is lifted, and hence represented by a pointer + + * It does not claim to be a {\it data} type, and that's important for + the code generator, because the code gen may {\it enter} a data value + but never enters a function value. + + It's also used to instantiate un-constrained type variables after type + checking. For example, {\tt length} has type + + {\tt length :: forall a. [a] -> Int} + + and the list datacon for the empty list has type + + {\tt [] :: forall a. [a]} + + In order to compose these two terms as {\tt length []} a type + application is required, but there is no constraint on the + choice. In this situation GHC uses {\tt Any}: + + {\tt length (Any *) ([] (Any *))} + + Above, we print kinds explicitly, as if with + {\tt -fprint-explicit-kinds}. + + Note that {\tt Any} is kind polymorphic; its kind is thus + {\tt forall k. k}.} + +primtype AnyK + { The kind {\tt AnyK} is the kind level counterpart to {\tt Any}. In a + kind polymorphic setting, a similar example to the length of the empty + list can be given at the type level: + + {\tt type family Length (l :: [k]) :: Nat} + {\tt type instance Length [] = Zero} + + When {\tt Length} is applied to the empty (promoted) list it will have + the kind {\tt Length AnyK []}. + + {\tt AnyK} is currently not exported and cannot be used directly, but + you might see it in debug output from the compiler. + } + +pseudoop "unsafeCoerce#" + a -> b + { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That + is, it allows you to coerce any type into any other type. If you use this function, + you had better get it right, otherwise segmentation faults await. It is generally + used when you want to write a program that you know is well-typed, but where Haskell's + type system is not expressive enough to prove that it is well typed. + + The following uses of {\tt unsafeCoerce\#} are supposed to work (i.e. not lead to + spurious compile-time or run-time crashes): + + * Casting any lifted type to {\tt Any} + + * Casting {\tt Any} back to the real type + + * Casting an unboxed type to another unboxed type of the same size + (but not coercions between floating-point and integral types) + + * Casting between two types that have the same runtime representation. One case is when + the two types differ only in "phantom" type parameters, for example + {\tt Ptr Int} to {\tt Ptr Float}, or {\tt [Int]} to {\tt [Float]} when the list is + known to be empty. Also, a {\tt newtype} of a type {\tt T} has the same representation + at runtime as {\tt T}. + + Other uses of {\tt unsafeCoerce\#} are undefined. In particular, you should not use + {\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also + an algebraic data type. For example, do not cast {\tt Int->Int} to {\tt Bool}, even if + you later cast that {\tt Bool} back to {\tt Int->Int} before applying it. The reasons + have to do with GHC's internal representation details (for the congnoscenti, data values + can be entered but function closures cannot). If you want a safe type to cast things + to, use {\tt Any}, which is not an algebraic data type. + + } + +-- NB. It is tempting to think that casting a value to a type that it doesn't have is safe +-- as long as you don't "do anything" with the value in its cast form, such as seq on it. This +-- isn't the case: the compiler can insert seqs itself, and if these happen at the wrong type, +-- Bad Things Might Happen. See bug #1616: in this case we cast a function of type (a,b) -> (a,b) +-- to () -> () and back again. The strictness analyser saw that the function was strict, but +-- the wrapper had type () -> (), and hence the wrapper de-constructed the (), the worker re-constructed +-- a new (), with the result that the code ended up with "case () of (a,b) -> ...". + +primop TraceEventOp "traceEvent#" GenPrimOp + Addr# -> State# s -> State# s + { Emits an event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the .eventlog file, + or to stderr, depending on the runtime RTS flags. } + with + has_side_effects = True + out_of_line = True + +primop TraceMarkerOp "traceMarker#" GenPrimOp + Addr# -> State# s -> State# s + { Emits a marker event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the .eventlog file, + or to stderr, depending on the runtime RTS flags. } + with + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +section "Safe coercions" +------------------------------------------------------------------------ + +pseudoop "coerce" + Coercible a b => a -> b + { The function {\tt coerce} allows you to safely convert between values of + types that have the same representation with no run-time overhead. In the + simplest case you can use it instead of a newtype constructor, to go from + the newtype's concrete type to the abstract type. But it also works in + more complicated settings, e.g. converting a list of newtypes to a list of + concrete types. + } + +------------------------------------------------------------------------ +section "SIMD Vectors" + {Operations on SIMD vectors.} +------------------------------------------------------------------------ + +#define ALL_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define SIGNED_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define FLOAT_VECTOR_TYPES \ + [, \ + ,, \ + ,,] + +#define INT_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,,] + +primtype VECTOR + with llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecBroadcastOp "broadcast#" GenPrimOp + SCALAR -> VECTOR + { Broadcast a scalar to all elements of a vector. } + with llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecPackOp "pack#" GenPrimOp + VECTUPLE -> VECTOR + { Pack the elements of an unboxed tuple into a vector. } + with llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecUnpackOp "unpack#" GenPrimOp + VECTOR -> VECTUPLE + { Unpack the elements of a vector into an unboxed tuple. #} + with llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecInsertOp "insert#" GenPrimOp + VECTOR -> SCALAR -> Int# -> VECTOR + { Insert a scalar at the given position in a vector. } + with can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecAddOp "plus#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Add two vectors element-wise. } + with commutable = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecSubOp "minus#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Subtract two vectors element-wise. } + with llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecMulOp "times#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Multiply two vectors element-wise. } + with commutable = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecDivOp "divide#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Divide two vectors element-wise. } + with can_fail = True + llvm_only = True + vector = FLOAT_VECTOR_TYPES + +primop VecQuotOp "quot#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Rounds towards zero element-wise. } + with can_fail = True + llvm_only = True + vector = INT_VECTOR_TYPES + +primop VecRemOp "rem#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. } + with can_fail = True + llvm_only = True + vector = INT_VECTOR_TYPES + +primop VecNegOp "negate#" Monadic + VECTOR -> VECTOR + { Negate element-wise. } + with llvm_only = True + vector = SIGNED_VECTOR_TYPES + +primop VecIndexByteArrayOp "indexArray#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array. } + with can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecReadByteArrayOp "readArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecWriteByteArrayOp "writeArray#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in bytes. } + with can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecReadOffAddrOp "readOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in bytes. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in bytes. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + + +primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. } + with can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in scalar elements. } + with can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in scalar elements. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in scalar elements. } + with has_side_effects = True + can_fail = True + llvm_only = True + vector = ALL_VECTOR_TYPES + +------------------------------------------------------------------------ + +section "Prefetch" + {Prefetch operations: Note how every prefetch operation has a name + with the pattern prefetch*N#, where N is either 0,1,2, or 3. + + This suffix number, N, is the "locality level" of the prefetch, following the + convention in GCC and other compilers. + Higher locality numbers correspond to the memory being loaded in more + levels of the cpu cache, and being retained after initial use. The naming + convention follows the naming convention of the prefetch intrinsic found + in the GCC and Clang C compilers. + + On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic + with locality level N. The code generated by LLVM is target architecture + dependent, but should agree with the GHC NCG on x86 systems. + + On the Sparc and PPC native backends, prefetch*N is a No-Op. + + On the x86 NCG, N=0 will generate prefetchNTA, + N=1 generates prefetcht2, N=2 generates prefetcht1, and + N=3 generates prefetcht0. + + For streaming workloads, the prefetch*0 operations are recommended. + For workloads which do many reads or writes to a memory location in a short period of time, + prefetch*3 operations are recommended. + + For further reading about prefetch and associated systems performance optimization, + the instruction set and optimization manuals by Intel and other CPU vendors are + excellent starting place. + + + The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is + especially a helpful read, even if your software is meant for other CPU + architectures or vendor hardware. The manual can be found at + http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html . + + The {\tt prefetch*} family of operations has the order of operations + determined by passing around the {\tt State#} token. + + To get a "pure" version of these operations, use {\tt inlinePerformIO} which is quite safe in this context. + + It is important to note that while the prefetch operations will never change the + answer to a pure computation, They CAN change the memory locations resident + in a CPU cache and that may change the performance and timing characteristics + of an application. The prefetch operations are marked has_side_effects=True + to reflect that these operations have side effects with respect to the runtime + performance characteristics of the resulting code. Additionally, if the prefetchValue + operations did not have this attribute, GHC does a float out transformation that + results in a let/app violation, at least with the current design. + } + + + +------------------------------------------------------------------------ + + +--- the Int# argument for prefetch is the byte offset on the byteArray or Addr# + +--- +primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp + a -> State# s -> State# s + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + has_side_effects = True +---- + +primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp + a -> State# s -> State# s + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + has_side_effects = True +---- + +primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp + a -> State# s -> State# s + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + has_side_effects = True +---- + +primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp + a -> State# s -> State# s + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + has_side_effects = True + +------------------------------------------------------------------------ +--- --- +------------------------------------------------------------------------ + +thats_all_folks diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs new file mode 100644 index 00000000..cce83945 --- /dev/null +++ b/compiler/profiling/CostCentre.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +module CostCentre ( + CostCentre(..), CcName, IsCafCC(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, + noCCS, currentCCS, dontCareCCS, + noCCSAttached, isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import Binary +import Var +import Name +import Module +import Unique +import Outputable +import FastTypes +import SrcLoc +import FastString +import Util + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_key :: {-# UNPACK #-} !Int, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has a + -- Unique that is distinct from every other + -- CostCentre in the same module. + -- + -- XXX: should really be using Unique here, but we + -- need to derive Data below and there's no Data + -- instance for Unique. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan, + cc_is_caf :: IsCafCC -- see below + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving (Data, Typeable) + +type CcName = FastString + +data IsCafCC = NotCafCC | CafCC + deriving (Eq, Ord, Data, Typeable) + + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} + NormalCC {cc_key = n2, cc_mod = m2} + -- first key is module name, then the integer key + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) + +cmpCostCentre other_1 other_2 + = let + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 + in + if tag1 <# tag2 then LT else GT + where + tag_CC (NormalCC {}) = _ILIT(0) + tag_CC (AllCafsCC {}) = _ILIT(1) + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre +mkUserCC cc_name mod loc key + = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_is_caf = NotCafCC {-might be changed-} + } + +mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre +mkAutoCC id mod is_caf + = NormalCC { cc_key = getKey (getUnique id), + cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_is_caf = is_caf + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = NoCCS + + | CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentre] -- "extern" cost-centres + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + + +noCCS, currentCCS, dontCareCCS :: CostCentreStack + +noCCS = NoCCS +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +noCCSAttached :: CostCentreStack -> Bool +noCCSAttached NoCCS = True +noCCSAttached _ = False + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr NoCCS = ptext (sLit "NO_CCS") + ppr CurrentCCS = ptext (sLit "CCCS") + ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") + ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs") + + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr cc = getPprStyle $ \ sty -> + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc, + cc_is_caf = caf}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + ifPprDebug (ppr key), + pp_caf caf, + ifPprDebug (ppr loc) + ]) + +pp_caf :: IsCafCC -> SDoc +pp_caf CafCC = text "__C" +pp_caf _ = empty + +-- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, + cc_is_caf = is_caf}) + = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc" + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary IsCafCC where + put_ bh CafCC = do + putByte bh 0 + put_ bh NotCafCC = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + _ -> do return NotCafCC + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad ae) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh ae + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + ae <- get bh + return (NormalCC aa ab ac noSrcSpan ae) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. diff --git a/compiler/profiling/NOTES b/compiler/profiling/NOTES new file mode 100644 index 00000000..c50cf562 --- /dev/null +++ b/compiler/profiling/NOTES @@ -0,0 +1,301 @@ +Profiling Implementation Notes -- June/July/Sept 1994 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Simon and Will + +Pre-code-generator-ish +~~~~~~~~~~~~~~~~~~~~~~ + +* Automagic insertion of _sccs_ on... + + - If -auto is specified, add _scc_ on each *exported* top-level definition. + NB this includes CAFs. Done by addAutoCostCentres (Core-to-Core pass). + + - If -auto-all is specified, add _scc_ on *all* top-level definitions. + Done by same pass. + + - Always: just before code generation of module M, onto any CAF + which hasn't already got an explicit cost centre attached, pin + "AllCAFs-M". + + Done by finalStgMassageForProfiling (final STG-to-STG pass) + + Only the one-off costs of evaluating the CAFs will be attributed + to the AllCAFs-M cost centre. We hope that these costs will be + small; since the _scc_s are introduced automatically it's + confusing to attribute any significant costs to them. However if + there *are* significant one-off costs we'd better know about it. + + Why so late in the compilation process? We aren't *absolutely* + sure what is and isn't a CAF until *just* before code generation. + So we don't want to mark them as such until then. + + - Individual DICTs + + We do it in the desugarer, because that's the *only* point at + which we *know* exactly what bindings are introduced by + overloading. NB should include bindings for selected methods, eg + + f d = let op = _scc_ DICT op_sel d in + ...op...op...op + + The DICT CC ensures that: + (a) [minor] that the selection cost is separately attributed + (b) [major] that the cost of executing op is attributed to + its call site, eg + + ...(scc "a" op)...(scc "b" op)...(scc "c" op)... + +* Automagic "boxing" of higher-order args: + + finalStgMassageForProfiling (final STG-to-STG pass) + + This (as well as CAF stuff above) is really quite separate + from the other business of finalStgMassageForProfiling + (collecting up CostCentres that need to be + declared/registered). + + But throwing it all into the pot together means that we don't + have to have Yet Another STG Syntax Walker. + + Furthermore, these "boxes" are really just let-bindings that + many other parts of the compiler will happily substitute away! + Doing them at the very last instant prevents this. + + A down side of doing these so late is that we get lots of + "let"s, which if generated earlier and not substituted away, + could be floated outwards. Having them floated outwards would + lessen the chance of skewing profiling results (because of + gratuitous "let"s added by the compiler into the inner loop of + some program...). The allocation itself will be attributed to + profiling overhead; the only thing which'll be skewed is time measurement. + + So if we have, post-boxing-higher-order-args... + + _scc_ "foo" ( let f' = [f] \ [] f + in + map f' xs ) + + ... we want "foo" to be put in the thunk for "f'", but we want the + allocation cost (heap census stuff) to be attr to OVERHEAD. + + As an example of what could be improved + f = _scc_ "f" (g h) + To save dynamic allocation, we could have a static closure for h: + h_inf = _scc_ "f" h + f = _scc_ "f" (g h_inf) + + + + + +Code generator-ish +~~~~~~~~~~~~~~~~~~ + +(1) _Entry_ code for a closure *usually* sets CC from the closure, + at the fast entry point + + Exceptions: + + (a) Top-level subsumed functions (i.e., w/ no _scc_ on them) + + Refrain from setting CC from the closure + + (b) Constructors + + Again, refrain. (This is *new*) + + Reasons: (i) The CC will be zapped very shortly by the restore + of the enclosing CC when we return to the eval'ing "case". + (ii) Any intervening updates will indirect to this existing + constructor (...mumble... new update mechanism... mumble...) + +(2) "_scc_ cc expr" + + Set current CC to "cc". + No later "restore" of the previous CC is reqd. + +(3) "case e of { ...alts... }" expression (eval) + + Save CC before eval'ing scrutinee + Restore CC at the start of the case-alternative(s) + +(4) _Updates_ : updatee gets current CC + + (???? not sure this is OK yet 94/07/04) + + Reasons: + + * Constructors : want to be insensitive to return-in-heap vs + return-in-regs. For example, + + f x = _scc_ "f" (x, x) + + The pair (x,x) would get CC of "f" if returned-in-heap; + therefore, updatees should get CC of "f". + + * PAPs : Example: + + f x = _scc_ "f" (let g = \ y -> ... in g) + + At the moment of update (updatePAP?), CC is "f", which + is what we want to set it to if the "updatee" is entered + + When we enter the PAP ("please put the arguments back so I can + use them"), we restore the setup as at the moment the + arg-satisfaction check failed. + + Be careful! UPDATE_PAP is called from the arg-satis check, + which is before the fast entry point. So the cost centre + won't yet have been set from the closure which has just + been entered. Solution: in UPDATE_PAP see if the cost centre inside + the function closure which is being entered is "SUB"; if so, use + the current cost centre to update the updatee; otherwise use that + inside the function closure. (See the computation of cc_pap + in rule 16_l for lexical semantics.) + + +(5) CAFs + +CAFs get their own cost centre. Ie + + x = e +is transformed to + x = _scc_ "CAF:x" e + +Or sometimes we lump all the CAFs in a module together. +(Reporting issue or code-gen issue?) + + + +Hybrid stuff +~~~~~~~~~~~~ + +The problem: + + f = _scc_ "CAF:f" (let g = \xy -> ... + in (g,g)) + +Now, g has cost-centre "CAF:f", and is returned as part of +the result. So whenever the function embedded in the result +is called, the costs will accumulate to "CAF:f". This is +particularly (de)pressing for dictionaries, which contain lots +of functions. + +Solution: + + A. Whenever in case (1) above we would otherwise "set the CC from the + closure", we *refrain* from doing so if + (a) the closure is a function, not a thunk; and + (b) the cost-centre in the closure is a CAF cost centre. + + B. Whenever we enter a thunk [at least, one which might return a function] + we save the current cost centre in the update frame. Then, UPDATE_PAP + restores the saved cost centre from the update frame iff the cost + centre at the point of update (cc_pap in (4) above) is a CAF cost centre. + + It isn't necessary to save and possibly-restore the cost centre for + thunks which will certainly return a constructor, because the + cost centre is about to be restored anyway by the enclosing case. + +Both A and B are runtime tests. For A, consider: + + f = _scc_ "CAF:f" (g 2) + + h y = _scc_ "h" g (y+y) + + g x = let w = \p -> ... + in (w,w) + + +Now, in the call to g from h, the cost-centre on w will be "h", and +indeed all calls to the result of the call should be attributed to +"h". + + ... _scc_ "x1" (let (t,_) = h 2 in t 3) ... + + Costs of executing (w 3) attributed to "h". + +But in the call to g from f, the cost-centre on w will be +"CAF:f", and calls to w should be attributed to the call site. + + ..._scc_ "x2" (let (t,_) = f in t 3)... + + Costs of executing (w 3) attributed to "x2". + + + Remaining problem + +Consider + + _scc_ "CAF:f" (if expensive then g 2 else g 3) + +where g is a function with arity 2. In theory we should +restore the enclosing cost centre once we've reduced to +(g 2) or (g 3). In practice this is pretty tiresome; and pretty rare. + +A quick fix: given (_scc_ "CAF" e) where e might be function-valued +(in practice we usually know, because CAF sccs are top level), transform to + + _scc_ "CAF" (let f = e in f) + + + + + +============ + +scc cc x ===> x + + UNLESS + +(a) cc is a user-defined, non-dup'd cost + centre (so we care about entry counts) + +OR + +(b) cc is not a CAF/DICT cost centre and x is top-level subsumed + function. + [If x is lambda/let bound it'll have a cost centre + attached dynamically.] + + To repeat, the transformation is OK if + x is a not top-level subsumed function + OR + cc is a CAF/DICT cost centre and x is a top-level + subsumed function + + + +(scc cc e) x ===> (scc cc e x) + + OK????? IFF + +cc is not CAF/DICT --- remains to be proved!!!!!! +True for lex +False for eval +Can we tell which in hybrid? + +eg Is this ok? + + (scc "f" (scc "CAF" (\x.b))) y ==> (scc "f" (scc "CAF" (\x.b) y)) + + +\x -> (scc cc e) ===> (scc cc \x->e) + + OK IFF cc is not CAF/DICT + + +scc cc1 (scc cc2 e)) ===> scc cc2 e + + IFF not interested in cc1's entry count + AND cc2 is not CAF/DICT + +(scc cc1 ... (scc cc2 e) ...) ===> (scc cc1 ... e ...) + + IFF cc2 is CAF/DICT + AND e is a lambda not appearing as the RHS of a let + OR + e is a variable not bound to SUB + + diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs new file mode 100644 index 00000000..9fddc495 --- /dev/null +++ b/compiler/profiling/ProfInit.hs @@ -0,0 +1,46 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- Generate code to initialise cost centres +-- +-- ----------------------------------------------------------------------------- + +module ProfInit (profilingInitCode) where + +import CLabel +import CostCentre +import DynFlags +import Outputable +import FastString +import Module + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) + = sdocWithDynFlags $ \dflags -> + if not (gopt Opt_SccProfilingOn dflags) + then empty + else vcat + [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat ( + map emitRegisterCC local_CCs ++ + map emitRegisterCCS singleton_CCSs + )) + ] + where + emitRegisterCC cc = + ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi + where cc_lbl = ppr (mkCCLabel cc) + emitRegisterCCS ccs = + ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi + where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs new file mode 100644 index 00000000..dfa3d052 --- /dev/null +++ b/compiler/profiling/SCCfinal.hs @@ -0,0 +1,284 @@ +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- Modify and collect code generation for final STG program + +{- + This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. + + - Traverses the STG program collecting the cost centres. These are required + to declare the cost centres at the start of code generation. + + Note: because of cross-module unfolding, some of these cost centres may be + from other modules. + + - Puts on CAF cost-centres if the user has asked for individual CAF + cost-centres. +-} + +module SCCfinal ( stgMassageForProfiling ) where + +#include "HsVersions.h" + +import StgSyn + +import CostCentre -- lots of things +import Id +import Name +import Module +import UniqSupply ( UniqSupply ) +import ListSetOps ( removeDups ) +import Outputable +import DynFlags +import CoreSyn ( Tickish(..) ) +import FastString +import SrcLoc +import Util + +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +stgMassageForProfiling + :: DynFlags + -> Module -- module name + -> UniqSupply -- unique supply + -> [StgBinding] -- input + -> (CollectedCCs, [StgBinding]) + +stgMassageForProfiling dflags mod_name _us stg_binds + = let + ((local_ccs, extern_ccs, cc_stacks), + stg_binds2) + = initMM mod_name (do_top_bindings stg_binds) + + (fixed_ccs, fixed_cc_stacks) + = if gopt Opt_AutoSccsOnIndividualCafs dflags + then ([],[]) -- don't need "all CAFs" CC + else ([all_cafs_cc], [all_cafs_ccs]) + + local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs) + extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs) + in + ((fixed_ccs ++ local_ccs_no_dups, + extern_ccs_no_dups, + fixed_cc_stacks ++ cc_stacks), stg_binds2) + where + + span = mkGeneralSrcSpan (mkFastString "") -- XXX do better + all_cafs_cc = mkAllCafsCC mod_name span + all_cafs_ccs = mkSingletonCCS all_cafs_cc + + ---------- + do_top_bindings :: [StgBinding] -> MassageM [StgBinding] + + do_top_bindings [] = return [] + + do_top_bindings (StgNonRec b rhs : bs) = do + rhs' <- do_top_rhs b rhs + bs' <- do_top_bindings bs + return (StgNonRec b rhs' : bs') + + do_top_bindings (StgRec pairs : bs) = do + pairs2 <- mapM do_pair pairs + bs' <- do_top_bindings bs + return (StgRec pairs2 : bs') + where + do_pair (b, rhs) = do + rhs2 <- do_top_rhs b rhs + return (b, rhs2) + + ---------- + do_top_rhs :: Id -> StgRhs -> MassageM StgRhs + + do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] + (StgTick (ProfNote _cc False{-not tick-} _push) + (StgConApp con args))) + | not (isDllConApp dflags mod_name con args) + -- Trivial _scc_ around nothing but static data + -- Eliminate _scc_ ... and turn into StgRhsCon + + -- isDllConApp checks for LitLit args too + = return (StgRhsCon dontCareCCS con args) + + do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body) + = do + -- Top level CAF without a cost centre attached + -- Attach CAF cc (collect if individual CAF ccs) + caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags + then let cc = mkAutoCC binder modl CafCC + ccs = mkSingletonCCS cc + -- careful: the binder might be :Main.main, + -- which doesn't belong to module mod_name. + -- bug #249, tests prof001, prof002 + modl | Just m <- nameModule_maybe (idName binder) = m + | otherwise = mod_name + in do + collectNewCC cc + collectCCS ccs + return ccs + else + return all_cafs_ccs + body' <- do_expr body + return (StgRhsClosure caf_ccs bi fv u srt [] body') + + do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body) + = do body' <- do_expr body + return (StgRhsClosure dontCareCCS bi fv u srt args body') + + do_top_rhs _ (StgRhsCon _ con args) + -- Top-level (static) data is not counted in heap + -- profiles; nor do we set CCCS from it; so we + -- just slam in dontCareCostCentre + = return (StgRhsCon dontCareCCS con args) + + ------ + do_expr :: StgExpr -> MassageM StgExpr + + do_expr (StgLit l) = return (StgLit l) + + do_expr (StgApp fn args) + = return (StgApp fn args) + + do_expr (StgConApp con args) + = return (StgConApp con args) + + do_expr (StgOpApp con args res_ty) + = return (StgOpApp con args res_ty) + + do_expr (StgTick note@(ProfNote cc _ _) expr) = do + -- Ha, we found a cost centre! + collectCC cc + expr' <- do_expr expr + return (StgTick note expr') + + do_expr (StgTick ti expr) = do + expr' <- do_expr expr + return (StgTick ti expr') + + do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do + expr' <- do_expr expr + alts' <- mapM do_alt alts + return (StgCase expr' fv1 fv2 bndr srt alt_type alts') + where + do_alt (id, bs, use_mask, e) = do + e' <- do_expr e + return (id, bs, use_mask, e') + + do_expr (StgLet b e) = do + (b,e) <- do_let b e + return (StgLet b e) + + do_expr (StgLetNoEscape lvs1 lvs2 b e) = do + (b,e) <- do_let b e + return (StgLetNoEscape lvs1 lvs2 b e) + + do_expr other = pprPanic "SCCfinal.do_expr" (ppr other) + + ---------------------------------- + + do_let (StgNonRec b rhs) e = do + rhs' <- do_rhs rhs + e' <- do_expr e + return (StgNonRec b rhs',e') + + do_let (StgRec pairs) e = do + pairs' <- mapM do_pair pairs + e' <- do_expr e + return (StgRec pairs', e') + where + do_pair (b, rhs) = do + rhs2 <- do_rhs rhs + return (b, rhs2) + + ---------------------------------- + do_rhs :: StgRhs -> MassageM StgRhs + -- We play much the same game as we did in do_top_rhs above; + -- but we don't have to worry about cafs etc. + + -- throw away the SCC if we don't have to count entries. This + -- is a little bit wrong, because we're attributing the + -- allocation of the constructor to the wrong place (XXX) + -- We should really attach (PushCC cc CurrentCCS) to the rhs, + -- but need to reinstate PushCC for that. + do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt [] + (StgTick (ProfNote cc False{-not tick-} _push) + (StgConApp con args))) + = do collectCC cc + return (StgRhsCon currentCCS con args) + + do_rhs (StgRhsClosure _ bi fv u srt args expr) = do + expr' <- do_expr expr + return (StgRhsClosure currentCCS bi fv u srt args expr') + + do_rhs (StgRhsCon _ con args) + = return (StgRhsCon currentCCS con args) + + +-- ----------------------------------------------------------------------------- +-- Boring monad stuff for this + +newtype MassageM result + = MassageM { + unMassageM :: Module -- module name + -> CollectedCCs + -> (CollectedCCs, result) + } + +instance Functor MassageM where + fmap = liftM + +instance Applicative MassageM where + pure = return + (<*>) = ap + +instance Monad MassageM where + return x = MassageM (\_ ccs -> (ccs, x)) + (>>=) = thenMM + (>>) = thenMM_ + +-- the initMM function also returns the final CollectedCCs + +initMM :: Module -- module name, which we may consult + -> MassageM a + -> (CollectedCCs, a) + +initMM mod_name (MassageM m) = m mod_name ([],[],[]) + +thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b +thenMM_ :: MassageM a -> (MassageM b) -> MassageM b + +thenMM expr cont = MassageM $ \mod ccs -> + case unMassageM expr mod ccs of { (ccs2, result) -> + unMassageM (cont result) mod ccs2 } + +thenMM_ expr cont = MassageM $ \mod ccs -> + case unMassageM expr mod ccs of { (ccs2, _) -> + unMassageM cont mod ccs2 } + + +collectCC :: CostCentre -> MassageM () +collectCC cc + = MassageM $ \mod_name (local_ccs, extern_ccs, ccss) + -> if (cc `ccFromThisModule` mod_name) then + ((cc : local_ccs, extern_ccs, ccss), ()) + else -- must declare it "extern" + ((local_ccs, cc : extern_ccs, ccss), ()) + +-- Version of collectCC used when we definitely want to declare this +-- CC as local, even if its module name is not the same as the current +-- module name (eg. the special :Main module) see bug #249, #1472, +-- test prof001,prof002. +collectNewCC :: CostCentre -> MassageM () +collectNewCC cc + = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) + -> ((cc : local_ccs, extern_ccs, ccss), ()) + +collectCCS :: CostCentreStack -> MassageM () + +collectCCS ccs + = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) + -> ASSERT(not (noCCSAttached ccs)) + ((local_ccs, extern_ccs, ccs : ccss), ()) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs new file mode 100644 index 00000000..397780c8 --- /dev/null +++ b/compiler/rename/RnBinds.hs @@ -0,0 +1,1121 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnBinds]{Renaming and dependency analysis of bindings} + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). +-} + +{-# LANGUAGE CPP #-} + +module RnBinds ( + -- Renaming top-level bindings + rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, mkSigTvFn, + rnMatchGroup, rnGRHSs, rnGRHS, + makeMiniFixityEnv, MiniFixityEnv, + HsSigCtxt(..) + ) where + +import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) + +import HsSyn +import TcRnMonad +import TcEvidence ( emptyTcEvBinds ) +import RnTypes +import RnPat +import RnNames +import RnEnv +import DynFlags +import Module +import Name +import NameEnv +import NameSet +import RdrName ( RdrName, rdrNameOcc ) +import SrcLoc +import ListSetOps ( findDupsEq ) +import BasicTypes ( RecFlag(..) ) +import Digraph ( SCC(..) ) +import Bag +import Outputable +import FastString +import Data.List ( partition, sort ) +import Maybes ( orElse ) +import Control.Monad +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( traverse ) +#endif + +{- +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + + +************************************************************************ +* * +* naming conventions * +* * +************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +************************************************************************ +* * +* analysing polymorphic bindings (HsBindGroup, HsBind) +* * +************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBinds@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +************************************************************************ +* * +\subsubsection{ Top-level bindings} +* * +************************************************************************ +-} + +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnTopBindsLHS fix_env binds + = rnValBindsLHS (topRecNameMaker fix_env) binds + +rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnTopBindsRHS bound_names binds + = do { is_boot <- tcIsHsBootOrSig + ; if is_boot + then rnTopBindsBoot binds + else rnValBindsRHS (TopSigCtxt bound_names False) binds } + +rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnTopBindsBoot (ValBindsIn mbinds sigs) + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; (sigs', fvs) <- renameSigs HsBootCtxt sigs + ; return (ValBindsOut [] sigs', usesOnly fvs) } +rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) + +{- +********************************************************* +* * + HsLocalBinds +* * +********************************************************* +-} + +rnLocalBindsAndThen :: HsLocalBinds RdrName + -> (HsLocalBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen EmptyLocalBinds thing_inside + = thing_inside EmptyLocalBinds + +rnLocalBindsAndThen (HsValBinds val_binds) thing_inside + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds val_binds') + +rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do + (binds',fv_binds) <- rnIPBinds binds + (thing, fvs_thing) <- thing_inside (HsIPBinds binds') + return (thing, fvs_thing `plusFV` fv_binds) + +rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) +rnIPBinds (IPBinds ip_binds _no_dict_binds) = do + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) + +rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) +rnIPBind (IPBind ~(Left n) expr) = do + (expr',fvExpr) <- rnLExpr expr + return (IPBind (Left n) expr', fvExpr) + +{- +************************************************************************ +* * + ValBinds +* * +************************************************************************ +-} + +-- Renaming local binding groups +-- Does duplicate/shadow check +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds RdrName + -> RnM ([Name], HsValBindsLR Name RdrName) +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils + + -- We need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; let bound_names = collectHsValBinders binds' + -- There should be only Ids, but if there are any bogus + -- pattern synonyms, we'll collect them anyway, so that + -- we don't generate subsequent out-of-scope messages + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + + ; return (bound_names, binds') } + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHS :: NameMaker + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnValBindsLHS topP (ValBindsIn mbinds sigs) + = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds + ; return $ ValBindsIn mbinds' sigs } + where + bndrs = collectHsBindsBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) + +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope +-- +-- Does not bind the local fixity declarations +rnValBindsRHS :: HsSigCtxt + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) + +rnValBindsRHS ctxt (ValBindsIn mbinds sigs) + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs + ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds + ; case depAnalBinds binds_w_dus of + (anal_binds, anal_dus) -> return (valbind', valbind'_dus) + where + valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs + } + +rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) + +-- Wrapper for local binds +-- +-- The *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- The client is also responsible for bringing the fixities into scope +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS (LocalBindCtxt bound_names) binds + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnLocalValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [L loc sig + | L loc (FixSig sig) <- sigs] + + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do + + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + ; (result, result_fvs) <- thing_inside binds' + + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + implicit_uses = hsValBindsImplicits binds' + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSet` implicit_uses) + + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (allUses) + -- (2) the FVs of the thing-inside + all_uses = allUses dus `plusFV` result_fvs + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } + + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) + + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. + +makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls + where + add_one_sig env (L loc (FixitySig names fixity)) = + foldlM add_one env [ (loc,name_loc,name,fixity) + | L name_loc name <- names ] + + add_one env (loc, name_loc, name,fixity) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; + + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addErrAt name_loc (dupFixityDecl loc' name) + ; return env} + } + +dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl loc rdr_name + = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] + +--------------------- + +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> HsBind RdrName + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (HsBindLR Name RdrName) + +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) + = do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- rnBindPat name_maker pat + return (bind { pat_lhs = pat', bind_fvs = pat'_fvs }) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) + = do { name <- applyNameMaker name_maker rdr_name + ; return (bind { fun_id = name + , bind_fvs = placeHolderNamesTc }) } + +rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) + | isTopRecNameMaker name_maker + = do { addLocM checkConName rdrname + ; name <- lookupLocatedTopBndrRn rdrname -- Should be bound at top level already + ; return (PatSynBind psb{ psb_id = name }) } + + | otherwise -- Pattern synonym, not at top level + = do { addErr localPatternSynonymErr -- Complain, but make up a fake + -- name so that we can carry on + ; name <- applyNameMaker name_maker rdrname + ; return (PatSynBind psb{ psb_id = name }) } + where + localPatternSynonymErr :: SDoc + localPatternSynonymErr + = hang (ptext (sLit "Illegal pattern synonym declaration for") <+> quotes (ppr rdrname)) + 2 (ptext (sLit "Pattern synonym declarations are only valid at top level")) + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR Name RdrName + -> RnM (LHsBind Name, [Name], Uses) +rnLBind sig_fn (L loc bind) + = setSrcSpan loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return (L loc bind', bndrs, dus) } + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR Name RdrName + -> RnM (HsBind Name, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , bind_fvs = pat_fvs }) + = do { mod <- getModule + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss + + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs + fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + bndrs = collectPatBinders pat + bind' = bind { pat_rhs = grhss', + pat_rhs_ty = placeHolderType, bind_fvs = fvs' } + is_wild_pat = case pat of + L _ (WildPat {}) -> True + L _ (BangPat (L _ (WildPat {}))) -> True -- #9127 + _ -> False + + -- Warn if the pattern binds no variables, except for the + -- entirely-explicit idiom _ = rhs + -- which (a) is not that different from _v = rhs + -- (b) is sometimes used to give a type sig for, + -- or an occurrence of, a variable on the RHS + ; whenWOptM Opt_WarnUnusedBinds $ + when (null bndrs && not is_wild_pat) $ + addWarn $ unusedPatBindWarn bind' + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', bndrs, all_fvs) } + +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_infix = is_infix + , fun_matches = matches }) + -- invariant: no free vars here when it's a FunBind + = do { let plain_name = unLoc name + + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for Opt_ScopedTyVars + rnMatchGroup (FunRhs plain_name is_infix) + rnLExpr matches + ; when is_infix $ checkPrecMatch plain_name matches' + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind { fun_matches = matches' + , bind_fvs = fvs' }, + [plain_name], rhs_fvs) + } + +rnBind sig_fn (PatSynBind bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind Name RdrName + -> RnM (PatSynBind Name Name, [Name], Uses) +rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) + -- invariant: no free vars here when it's a FunBind + = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms + ; unless pattern_synonym_ok (addErr patternSynonymErr) + + ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + { (details', fvs) <- case details of + PrefixPatSyn vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupVar vars + ; return (PrefixPatSyn names, mkFVs (map unLoc names)) } + InfixPatSyn var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupVar var1 + ; name2 <- lookupVar var2 + -- ; checkPrecMatch -- TODO + ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) } + ; return ((pat', details'), fvs) } + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- rnMatchGroup PatSyn rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } + + ; mod <- getModule + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + + ; let bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_fvs = fvs' } + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', [name], fvs1) + -- See Note [Pattern synonym wrappers don't yield dependencies] + } + where + lookupVar = wrapLocM lookupOccRn + + patternSynonymErr :: SDoc + patternSynonymErr + = hang (ptext (sLit "Illegal pattern synonym declaration")) + 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension")) + +{- +Note [Pattern synonym wrappers don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a pattern synonym that has an explicit wrapper, +references in the wrapper definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: + +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the +type of 'P'. This step doesn't require knowing anything about 'f', +since the wrapper definition is not looked at. + +2. Typecheck the wrapper definition, which needs the typechecked +definition of 'f' to be in scope. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). + +-} + +--------------------- +depAnalBinds :: Bag (LHsBind Name, [Name], Uses) + -> ([(RecFlag, LHsBinds Name)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, map get_du sccs) + where + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nameSetElems uses) + (bagToList binds_w_dus) + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionNameSets [u | (_,_,u) <- binds_w_dus] + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: [a] -> [a] +-- y :: [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkSigTvFn :: [LSig Name] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body.. +mkSigTvFn sigs + = \n -> lookupNameEnv env n `orElse` [] + where + extractScopedTyVars :: LHsType Name -> [Name] + extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs + extractScopedTyVars _ = [] + + env :: NameEnv [Name] + env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty) -- Kind variables and type variables + | L _ (TypeSig names ty nwcs) <- sigs + , L _ name <- names] + -- Note the pattern-match on "Explicit"; we only bind + -- type variables from signatures with an explicit top-level for-all + +{- +@rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. +-} + +rnMethodBinds :: Name -- Class name + -> (Name -> [Name]) -- Signature tyvar function + -> LHsBinds RdrName + -> RnM (LHsBinds Name, FreeVars) + +rnMethodBinds cls sig_fn binds + = do { checkDupRdrNames meth_names + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } + where + meth_names = collectMethodBinders binds + do_one (binds,fvs) bind + = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind + ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } + +rnMethodBind :: Name + -> (Name -> [Name]) + -> LHsBindLR RdrName RdrName + -> RnM (Bag (LHsBindLR Name Name), FreeVars) +rnMethodBind cls sig_fn + (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix + , fun_matches = MG { mg_alts = matches + , mg_origin = origin } })) + = setSrcSpan loc $ do + sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name + let plain_name = unLoc sel_name + -- We use the selector name as the binder + + (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) + matches + let new_group = mkMatchGroupName origin new_matches + + when is_infix $ checkPrecMatch plain_name new_group + return (unitBag (L loc (bind { fun_id = sel_name + , fun_matches = new_group + , bind_fvs = fvs })), + fvs `addOneFV` plain_name) + -- The 'fvs' field isn't used for method binds + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBind _ _ (L loc bind@(PatBind {})) = do + addErrAt loc (methodBindErr bind) + return (emptyBag, emptyFVs) + +-- Associated pattern synonyms are not implemented yet +rnMethodBind _ _ (L loc bind@(PatSynBind {})) = do + addErrAt loc $ methodPatSynErr bind + return (emptyBag, emptyFVs) + +rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b) + +{- +************************************************************************ +* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +* * +************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\end{enumerate} + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. +-} + +renameSigs :: HsSigCtxt + -> [LSig RdrName] + -> RnM ([LSig Name], FreeVars) +-- Renames the signatures and performs error checks +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) + + ; checkDupMinimalSigs sigs + + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return (good_sigs, sig_fvs) } + +---------------------- +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) +-- FixitySig is renamed elsewhere. +renameSig _ (IdSig x) + = return (IdSig x, emptyFVs) -- Actually this never occurs + +renameSig ctxt sig@(TypeSig vs ty _) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + -- (named and anonymous) wildcards are bound here. + ; (wcs, ty') <- extractWildcards ty + ; bindLocatedLocalsFV wcs $ \wcs_new -> do { + (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty' + ; return (TypeSig new_vs new_ty wcs_new, fvs) } } + +renameSig ctxt sig@(GenericSig vs ty) + = do { defaultSigs_on <- xoptM Opt_DefaultSignatures + ; unless defaultSigs_on (addErr (defaultSigErr sig)) + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty, fvs) } + +renameSig _ (SpecInstSig src ty) + = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + ; return (SpecInstSig src new_ty,fvs) } + +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures +renameSig ctxt sig@(SpecSig v tys inl) + = do { new_v <- case ctxt of + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v + -- ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys + ; return (SpecSig new_v new_ty inl, fvs) } + where + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } + +renameSig ctxt sig@(InlineSig v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig new_v s, emptyFVs) } + +renameSig ctxt sig@(FixSig (FixitySig vs f)) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; return (FixSig (FixitySig new_vs f), emptyFVs) } + +renameSig ctxt sig@(MinimalSig s bf) + = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf + return (MinimalSig s new_bf, emptyFVs) + +renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty) + = do { v' <- lookupSigOccRn ctxt sig v + ; let doc = TypeSigCtx $ quotes (ppr v) + ; loc <- getSrcSpanM + + ; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req) + ; tv_bndrs <- case flag of + Implicit -> + return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned + Explicit -> + do { let heading = ptext (sLit "In the pattern synonym type signature") + <+> quotes (ppr sig) + ; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned + ; return qtvs } + Qualified -> panic "renameSig: Qualified" + + ; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do + { (prov', fvs1) <- rnContext doc prov + ; (req', fvs2) <- rnContext doc req + ; (ty', fvs3) <- rnLHsType doc ty + + ; let fvs = plusFVs [fvs1, fvs2, fvs3] + ; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }} + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +okHsSig :: HsSigCtxt -> LSig a -> Bool +okHsSig ctxt (L _ sig) + = case (sig, ctxt) of + (GenericSig {}, ClsDeclCtxt {}) -> True + (GenericSig {}, _) -> False + + (TypeSig {}, _) -> True + + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + + (FixSig {}, InstDeclCtxt {}) -> False + (FixSig {}, _) -> True + + (IdSig {}, TopSigCtxt {}) -> True + (IdSig {}, InstDeclCtxt {}) -> True + (IdSig {}, _) -> False + + (InlineSig {}, HsBootCtxt) -> False + (InlineSig {}, _) -> True + + (SpecSig {}, TopSigCtxt {}) -> True + (SpecSig {}, LocalBindCtxt {}) -> True + (SpecSig {}, InstDeclCtxt {}) -> True + (SpecSig {}, _) -> False + + (SpecInstSig {}, InstDeclCtxt {}) -> True + (SpecInstSig {}, _) -> False + + (MinimalSig {}, ClsDeclCtxt {}) -> True + (MinimalSig {}, _) -> False + +------------------- +findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig n _) = [(n,sig)] + expand_sig sig@(TypeSig ns _ _) = [(n,sig) | n <- ns] + expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] + expand_sig _ = [] + + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (GenericSig {}) (GenericSig {}) = True + mtch _ _ = False + +-- Warn about multiple MINIMAL signatures +checkDupMinimalSigs :: [LSig RdrName] -> RnM () +checkDupMinimalSigs sigs + = case filter isMinimalLSig sigs of + minSigs@(_:_:_) -> dupMinimalSigErr minSigs + _ -> return () + +{- +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ +-} + +rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> MatchGroup RdrName (Located (body RdrName)) + -> RnM (MatchGroup Name (Located (body Name)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) + = do { empty_case_ok <- xoptM Opt_EmptyCase + ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) + ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms + ; return (mkMatchGroupName origin new_ms, ms_fvs) } + +rnMatch :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LMatch RdrName (Located (body RdrName)) + -> RnM (LMatch Name (Located (body Name)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> Match RdrName (Located (body RdrName)) + -> RnM (Match Name (Located (body Name)), FreeVars) +rnMatch' ctxt rnBody match@(Match { m_fun_id_infix = mf, m_pats = pats + , m_type = maybe_rhs_sig, m_grhss = grhss }) + = do { -- Result type signatures are no longer supported + case maybe_rhs_sig of + Nothing -> return () + Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) + + -- Now the main event + -- note that there are no local ficity decls for matches + ; rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + ; let mf' = case (ctxt,mf) of + (FunRhs funid isinfix,Just (L lf _,_)) + -> Just (L lf funid,isinfix) + _ -> Nothing + ; return (Match { m_fun_id_infix = mf', m_pats = pats' + , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }} + +emptyCaseErr :: HsMatchContext Name -> SDoc +emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt) + 2 (ptext (sLit "Use EmptyCase to allow this")) + where + pp_ctxt = case ctxt of + CaseAlt -> ptext (sLit "case expression") + LambdaExpr -> ptext (sLit "\\case expression") + _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt + + +resSigErr :: Outputable body + => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc +resSigErr ctxt match ty + = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) + , nest 2 $ ptext (sLit + "Result signatures are no longer supported in pattern matches") + , pprMatchInCtxt ctxt match ] + +{- +************************************************************************ +* * +\subsubsection{Guarded right-hand sides (GRHSs)} +* * +************************************************************************ +-} + +rnGRHSs :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHSs RdrName (Located (body RdrName)) + -> RnM (GRHSs Name (Located (body Name)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs grhss binds) + = rnLocalBindsAndThen binds $ \ binds' -> do + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss + return (GRHSs grhss' binds', fvGRHSs) + +rnGRHS :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LGRHS RdrName (Located (body RdrName)) + -> RnM (LGRHS Name (Located (body Name)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHS RdrName (Located (body RdrName)) + -> RnM (GRHS Name (Located (body Name)), FreeVars) +rnGRHS' ctxt rnBody (GRHS guards rhs) + = do { pattern_guards_allowed <- xoptM Opt_PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs + + ; unless (pattern_guards_allowed || is_standard_guard guards') + (addWarn (nonStdGuardErr guards')) + + ; return (GRHS guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt _ _ _ _)] = True + is_standard_guard _ = False + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () +dupSigDeclErr pairs@((L loc name, sig) : _) + = addErrAt loc $ + vcat [ ptext (sLit "Duplicate") <+> what_it_is + <> ptext (sLit "s for") <+> quotes (ppr name) + , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] + where + what_it_is = hsSigDoc sig + +dupSigDeclErr [] = panic "dupSigDeclErr" + +misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr (L loc sig) + = addErrAt loc $ + sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] + +defaultSigErr :: Sig RdrName -> SDoc +defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:")) + 2 (ppr sig) + , ptext (sLit "Use DefaultSignatures to enable default signatures") ] + +methodBindErr :: HsBindLR RdrName RdrName -> SDoc +methodBindErr mbind + = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations")) + 2 (ppr mbind) + +methodPatSynErr :: HsBindLR RdrName RdrName -> SDoc +methodPatSynErr mbind + = hang (ptext (sLit "Pattern synonyms not allowed in class/instance declarations")) + 2 (ppr mbind) + +bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc +bindsInHsBootFile mbinds + = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) + 2 (ppr mbinds) + +nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc +nonStdGuardErr guards + = hang (ptext (sLit "accepting non-standard pattern guards (use PatternGuards to suppress this message)")) + 4 (interpp'SP guards) + +unusedPatBindWarn :: HsBind Name -> SDoc +unusedPatBindWarn bind + = hang (ptext (sLit "This pattern-binding binds no variables:")) + 2 (ppr bind) + +dupMinimalSigErr :: [LSig RdrName] -> RnM () +dupMinimalSigErr sigs@(L loc _ : _) + = addErrAt loc $ + vcat [ ptext (sLit "Multiple minimal complete definitions") + , ptext (sLit "at") <+> vcat (map ppr $ sort $ map getLoc sigs) + , ptext (sLit "Combine alternative minimal complete definitions with `|'") ] +dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs new file mode 100644 index 00000000..6f9ae932 --- /dev/null +++ b/compiler/rename/RnEnv.hs @@ -0,0 +1,1935 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +\section[RnEnv]{Environment manipulation for the renamer monad} +-} + +{-# LANGUAGE CPP #-} + +module RnEnv ( + newTopSrcBinder, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, + lookupTypeOccRn, lookupKindOccRn, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, + reportUnboundName, + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupSigCtxtOccRn, + + lookupFixityRn, lookupTyFixityRn, + lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, + greRdrName, + lookupSubBndrGREs, lookupConstructorFields, + lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, + lookupGreRn, lookupGreRn_maybe, + lookupGreLocalRn_maybe, + getLookupOccRn, addUsedRdrNames, + + newLocalBndrRn, newLocalBndrsRn, + bindLocalNames, bindLocalNamesFV, + MiniFixityEnv, + addLocalFixities, + bindLocatedLocalsFV, bindLocatedLocalsRn, + extendTyVarEnvFVRn, + + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, checkTupSize, + addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, + warnUnusedMatches, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, kindSigErr, perhapsForallMsg, + HsDocContext(..), docOfHsDocContext + ) where + +#include "HsVersions.h" + +import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe ) +import IfaceEnv +import HsSyn +import RdrName +import HscTypes +import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) +import TcRnMonad +import Id ( isRecordSelector ) +import Name +import NameSet +import NameEnv +import Avail +import Module +import ConLike +import DataCon ( dataConFieldLabels, dataConTyCon ) +import TyCon ( isTupleTyCon, tyConArity ) +import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) +import ErrUtils ( MsgDoc ) +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity ) +import SrcLoc +import Outputable +import Util +import Maybes +import BasicTypes ( TopLevelFlag(..) ) +import ListSetOps ( removeDups ) +import DynFlags +import FastString +import Control.Monad +import Data.List +import qualified Data.Set as Set +import ListSetOps ( minusList ) +import Constants ( mAX_TUPLE_SIZE ) + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedRdrName so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] +-} + +newTopSrcBinder :: Located RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in Convert.hs + do { let occ = nameOccName name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; this_mod <- getModule + ; updNameCache $ \ ns -> + let name' = mkExternalName (nameUnique name) this_mod occ loc + ns' = ns { nsNames = extendNameCache (nsNames ns) this_mod occ name' } + in (ns', name') } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt loc (badOrigBinding rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the badOrigBinding error message. + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ loc } + + | otherwise + = do { unless (not (isQual rdr_name)) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we we get a confusing "M.T is not in scope" error later + + ; stage <- getStage + ; env <- getGblEnv + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + else case tcg_impl_rdr_env env of + Just gr -> + -- We're compiling --sig-of, so resolve with respect to this + -- module. + -- See Note [Signature parameters in TcGblEnv and DynFlags] + do { case lookupGlobalRdrEnv gr (rdrNameOcc rdr_name) of + -- Be sure to override the loc so that we get accurate + -- information later + [GRE{ gre_name = n }] -> do + -- NB: Just adding this line will not work: + -- addUsedRdrName True gre rdr_name + -- see Note [Signature lazy interface loading] for + -- more details. + return (setNameLoc n loc) + _ -> do + { -- NB: cannot use reportUnboundName rdr_name + -- because it looks up in the wrong RdrEnv + -- ToDo: more helpful error messages + ; addErr (unknownNameErr (pprNonVarNameSpace + (occNameSpace (rdrNameOcc rdr_name))) rdr_name) + ; return (mkUnboundName rdr_name) + } + } + Nothing -> + -- Normal case + do { this_mod <- getModule + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the RnEnv. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (Trac #3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n) + unboundName WL_LocalTop n + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. +-- +-- There should never be a qualified name in a binding position in Haskell, +-- but there can be if we have read in an external-Core file. +-- The Haskell parser checks for the illegal qualified name in Haskell +-- source files, so we don't need to do so here. + +lookupTopBndrRn_maybe rdr_name + | Just name <- isExact_maybe rdr_name + = do { name' <- lookupExactOcc name; return (Just name') } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = do { loc <- getSrcSpanM + ; n <- newGlobalBinder rdr_mod rdr_occ loc + ; return (Just n)} + + | otherwise + = do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM Opt_TypeOperators + ; unless op_ok (addErr (opDeclErr rdr_name)) }) + + ; mb_gre <- lookupGreLocalRn_maybe rdr_name + ; case mb_gre of + Nothing -> return Nothing + Just gre -> return (Just $ gre_name gre) } + + +----------------------------------------------- +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This adds an error if the name cannot be found. +lookupExactOcc :: Name -> RnM Name +lookupExactOcc name + = do { result <- lookupExactOcc_either name + ; case result of + Left err -> do { addErr err + ; return name } + Right name' -> return name' } + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one. +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +-- See Note [Looking up Exact RdrNames] +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , Just tycon <- case thing of + ATyCon tc -> Just tc + AConLike (RealDataCon dc) -> Just (dataConTyCon dc) + _ -> Nothing + , isTupleTyCon tycon + = do { checkTupSize (tyConArity tycon) + ; return (Right name) } + + | isExternalName name + = return (Right name) + + | otherwise + = do { env <- getGlobalRdrEnv + ; let -- See Note [Splicing Exact names] + main_occ = nameOccName name + demoted_occs = case demoteOccName main_occ of + Just occ -> [occ] + Nothing -> [] + gres = [ gre | occ <- main_occ : demoted_occs + , gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] + ; case gres of + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else +#ifdef GHCI + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left exact_nm_err) + } +#else /* !GHCI */ + return (Left exact_nm_err) +#endif /* !GHCI */ + } + + [gre] -> return (Right (gre_name gre)) + _ -> return (Left dup_nm_err) + -- We can get more than one GRE here, if there are multiple + -- bindings for the same name. Sometimes they are caught later + -- by findLocalDupsRdrEnv, like in this example (Trac #8932): + -- $( [d| foo :: a->a; foo x = x |]) + -- foo = True + -- But when the names are totally identical, we panic (Trac #7241): + -- $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) + -- So, let's emit an error here, even if it will lead to duplication in some cases. + } + + where + exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") + , ptext (sLit "perhaps via newName, but did not bind it") + , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) + dup_nm_err = hang (ptext (sLit "Duplicate exact Name") <+> quotes (ppr $ nameOccName name)) + 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") + , ptext (sLit "perhaps via newName, but bound it multiple times") + , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) + +----------------------------------------------- +lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; lookupSubBndrOcc False -- False => we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + (ParentIs cls) doc rdr } + where + doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) + + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + +----------------------------------------------- +lookupConstructorFields :: Name -> RnM [Name] +-- Look up the fields of a given constructor +-- * For constructors from this module, use the record field env, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modles are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { RecFields field_env _ <- getRecFieldEnv + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupDataCon con_name + ; return (dataConFieldLabels con) } } + +----------------------------------------------- +-- Used for record construction and pattern matching +-- When the -XDisambiguateRecordFields flag is on, take account of the +-- constructor name to disambiguate which field to use; it's just the +-- same as for instance decls +-- +-- NB: Consider this: +-- module Foo where { data R = R { fld :: Int } } +-- module Odd where { import Foo; fld x = x { fld = 3 } } +-- Arguably this should work, because the reference to 'fld' is +-- unambiguous because there is only one field id 'fld' in scope. +-- But currently it's rejected. + +lookupSubBndrOcc :: Bool + -> Parent -- NoParent => just look it up as usual + -- ParentIs p => use p to disambiguate + -> SDoc -> RdrName + -> RnM Name +lookupSubBndrOcc warnIfDeprec parent doc rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = lookupExactOcc n + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = lookupOrig rdr_mod rdr_occ + + | otherwise -- Find all the things the rdr-name maps to + = do { -- and pick the one with the right parent namep + env <- getGlobalRdrEnv + ; case lookupSubBndrGREs env parent rdr_name of + -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! + -- The latter does pickGREs, but we want to allow 'x' + -- even if only 'M.x' is in scope + [gre] -> do { addUsedRdrName warnIfDeprec gre (used_rdr_name gre) + -- Add a usage; this is an *occurrence* site + ; return (gre_name gre) } + [] -> do { addErr (unknownSubordinateErr doc rdr_name) + ; return (mkUnboundName rdr_name) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (gre_name (head gres)) } } + where + -- Note [Usage for sub-bndrs] + used_rdr_name gre + | isQual rdr_name = rdr_name + | otherwise = greRdrName gre + +greRdrName :: GlobalRdrElt -> RdrName +greRdrName gre + = case gre_prov gre of + LocalDef -> unqual_rdr + Imported is -> used_rdr_name_from_is is + + where + occ = nameOccName (gre_name gre) + unqual_rdr = mkRdrUnqual occ + + used_rdr_name_from_is imp_specs -- rdr_name is unqualified + | not (all (is_qual . is_decl) imp_specs) + = unqual_rdr -- An unqualified import is available + | otherwise + = -- Only qualified imports available, so make up + -- a suitable qualifed name from the first imp_spec + ASSERT( not (null imp_specs) ) + mkRdrQual (is_as (is_decl (head imp_specs))) occ + +lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt] +-- If Parent = NoParent, just do a normal lookup +-- If Parent = Parent p then find all GREs that +-- (a) have parent p +-- (b) for Unqual, are in scope qualified or unqualified +-- for Qual, are in scope with that qualification +lookupSubBndrGREs env parent rdr_name + = case parent of + NoParent -> pickGREs rdr_name gres + ParentIs p + | isUnqual rdr_name -> filter (parent_is p) gres + | otherwise -> filter (parent_is p) (pickGREs rdr_name gres) + + where + gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + + parent_is p (GRE { gre_par = ParentIs p' }) = p == p' + parent_is _ _ = False + +{- +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by Template Haskell. See Note [Binders +in Template Haskell] in Convert. + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and Convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by Convert.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In RnEnv.newGlobalBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + RnEnv.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualifed M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + +getLookupOccRn :: RnM (Name -> Maybe Name) +getLookupOccRn + = do local_env <- getLocalRdrEnv + return (lookupLocalRdrOcc local_env . nameOccName) + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) +-- Just look in the local environment +lookupLocalOccThLvl_maybe name + = do { lcl_env <- getLclEnv + ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } + +lookupKindOccRn :: RdrName -> RnM Name +-- Looking up a name occurring in a kind +lookupKindOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } + +-- lookupPromotedOccRn looks up an optionally promoted RdrName. +lookupTypeOccRn :: RdrName -> RnM Name +-- see Note [Demotion] +lookupTypeOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of { + Just name -> return name ; + Nothing -> lookup_demoted rdr_name } } + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM Opt_DataKinds + ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_name of + Nothing -> reportUnboundName rdr_name + Just demoted_name + | data_kinds -> + do { whenWOptM Opt_WarnUntickedPromotedConstructors $ + addWarn (untickedPromConstrWarn demoted_name) + ; return demoted_name } + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } + + | otherwise + = reportUnboundName rdr_name + + where + suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean DataKinds?") + untickedPromConstrWarn name = + text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot + $$ + hsep [ text "Use" + , quotes (char '\'' <> ppr name) + , text "instead of" + , quotes (ppr name) <> dot ] + +{- +Note [Demotion] +~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) +-} + +-- Use this version to get tracing +-- +-- lookupOccRn_maybe, lookupOccRn_maybe' :: RdrName -> RnM (Maybe Name) +-- lookupOccRn_maybe rdr_name +-- = do { mb_res <- lookupOccRn_maybe' rdr_name +-- ; gbl_rdr_env <- getGlobalRdrEnv +-- ; local_rdr_env <- getLocalRdrEnv +-- ; traceRn $ text "lookupOccRn_maybe" <+> +-- vcat [ ppr rdr_name <+> ppr (getUnique (rdrNameOcc rdr_name)) +-- , ppr mb_res +-- , text "Lcl env" <+> ppr local_rdr_env +-- , text "Gbl env" <+> ppr [ (getUnique (nameOccName (gre_name (head gres'))),gres') | gres <- occEnvElts gbl_rdr_env +-- , let gres' = filter isLocalGRE gres, not (null gres') ] ] +-- ; return mb_res } + +lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of { + Just name -> return (Just name) ; + Nothing -> do + { mb_name <- lookupGlobalOccRn_maybe rdr_name + ; case mb_name of { + Just name -> return (Just name) ; + Nothing -> do + { ns <- lookupQualifiedNameGHCi rdr_name + -- This test is not expensive, + -- and only happens for failed lookups + ; case ns of + (n:_) -> return (Just n) -- Unlikely to be more than one...? + [] -> return Nothing } } } } } + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. Adds an error message if the RdrName is not in scope. +lookupGlobalOccRn rdr_name + = do { mb_name <- lookupGlobalOccRn_maybe rdr_name + ; case mb_name of + Just n -> return n + Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name) + ; unboundName WL_Global rdr_name } } + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all +-- C.f. Trac #9881 +lookupInfoOccRn rdr_name + | Just n <- isExact_maybe rdr_name -- e.g. (->) + = return [n] + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n <- lookupOrig rdr_mod rdr_occ + ; return [n] } + + | otherwise + = do { rdr_env <- getGlobalRdrEnv + ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) + ; qual_ns <- lookupQualifiedNameGHCi rdr_name + ; return (ns ++ (qual_ns `minusList` ns)) } + +lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure + +lookupGlobalOccRn_maybe rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = do { n' <- lookupExactOcc n; return (Just n') } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n <- lookupOrig rdr_mod rdr_occ + ; return (Just n) } + + | otherwise + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of + Nothing -> return Nothing + Just gre -> return (Just (gre_name gre)) } + + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn_maybe rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreRn :: RdrName -> RnM GlobalRdrElt +-- If not found, add error message, and return a fake GRE +lookupGreRn rdr_name + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of { + Just gre -> return gre ; + Nothing -> do + { traceRn (text "lookupGreRn" <+> ppr rdr_name) + ; name <- unboundName WL_Global rdr_name + ; return (GRE { gre_name = name, gre_par = NoParent, + gre_prov = LocalDef }) }}} + +lookupGreLocalRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn_maybe rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> return Nothing + [gre] -> do { addUsedRdrName True gre rdr_name + ; return (Just gre) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (Just (head gres)) } } + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see Trac #5867) + +* We do not report deprectations for locally-definded names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* addUsedRdrNames: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM () +-- Record usage of imported RdrNames +addUsedRdrName warnIfDeprec gre rdr + | isLocalGRE gre = return () -- No call to warnIfDeprecated + -- See Note [Handling of deprecations] + | otherwise = do { env <- getGblEnv + ; when warnIfDeprec $ warnIfDeprecated gre + ; updMutVar (tcg_used_rdrnames env) + (\s -> Set.insert rdr s) } + +addUsedRdrNames :: [RdrName] -> RnM () +-- Record used sub-binders +-- We don't check for imported-ness here, because it's inconvenient +-- and not stritly necessary. +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] +addUsedRdrNames rdrs + = do { env <- getGblEnv + ; updMutVar (tcg_used_rdrnames env) + (\s -> foldr Set.insert s rdrs) } + +warnIfDeprecated :: GlobalRdrElt -> RnM () +warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) }) + = do { dflags <- getDynFlags + ; when (wopt Opt_WarnWarningsDeprecations dflags) $ + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeprec iface gre of + Just txt -> addWarn (mk_msg txt) + Nothing -> return () } } + where + mk_msg txt = sep [ sep [ ptext (sLit "In the use of") + <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name) + , parens imp_msg <> colon ] + , ppr txt ] + + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + imp_mod = importSpecModule imp_spec + imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = Outputable.empty + | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod + + doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly") + +warnIfDeprecated _ = return () -- No deprecations for things defined locally + +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec iface gre + = mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing, + case gre_par gre of -- or its parent, is warn'd + ParentIs p -> mi_warn_fn iface p + NoParent -> Nothing + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +If we fail we just return Nothing, rather than bleating +about "attempting to use module ‘D’ (./D.hs) which is not loaded" +which is what loadSrcInterface does. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DONT do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO +-} + +lookupQualifiedNameGHCi :: RdrName -> RnM [Name] +lookupQualifiedNameGHCi rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod,occ) <- isQual_maybe rdr_name + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = do { res <- loadSrcInterface_maybe doc mod False Nothing + ; case res of + Succeeded ifaces + -> return [ name + | iface <- ifaces + , avail <- mi_exports iface + , name <- availNames avail + , nameOccName name == occ ] + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn (text "lookupQualifiedNameGHCi" <+> ppr rdr_name) + ; return [] } } + + | otherwise + = return [] + + doc = ptext (sLit "Need to find") <+> ppr rdr_name + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the reanamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet Bool | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* The Bool says whether the signature is ok for a class method + or record selector. Consider + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a +-} + +data HsSigCtxt + = TopSigCtxt NameSet Bool -- At top level, binding these names + -- See Note [Signatures for top level things] + -- Bool <=> ok to give sig for + -- class method or record selctor + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | InstDeclCtxt Name -- Intsance decl for this class + | HsBootCtxt -- Top level of a hs-boot file + | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types + -- in the group + +lookupSigOccRn :: HsSigCtxt + -> Sig RdrName + -> Located RdrName -> RnM (Located Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRn :: HsSigCtxt + -> SDoc -- ^ description of thing we're looking up, + -- like "type family" + -> Located RdrName -> RnM (Located Name) +lookupSigCtxtOccRn ctxt what + = wrapLocM $ \ rdr_name -> + do { mb_name <- lookupBindGroupOcc ctxt what rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundName rdr_name) } + Right name -> return name } + +lookupBindGroupOcc :: HsSigCtxt + -> SDoc + -> RdrName -> RnM (Either MsgDoc Name) +-- Looks up the RdrName, expecting it to resolve to one of the +-- bound names passed in. If not, return an appropriate error message +-- +-- See Note [Looking up signature names] +lookupBindGroupOcc ctxt what rdr_name + | Just n <- isExact_maybe rdr_name + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n' <- lookupOrig rdr_mod rdr_occ + ; return (Right n') } + + | otherwise + = case ctxt of + HsBootCtxt -> lookup_top (const True) True + TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok + RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) False + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt cls -> lookup_cls_op cls + where + lookup_cls_op cls + = do { env <- getGlobalRdrEnv + ; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name + ; case gres of + [] -> return (Left (unknownSubordinateErr doc rdr_name)) + (gre:_) -> return (Right (gre_name gre)) } + -- If there is more than one local GRE for the + -- same OccName 'f', that will be reported separately + -- as a duplicate top-level binding for 'f' + where + doc = ptext (sLit "method of class") <+> quotes (ppr cls) + + lookup_top keep_me meth_ok + = do { env <- getGlobalRdrEnv + ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; case filter (keep_me . gre_name) all_gres of + [] | null all_gres -> bale_out_with Outputable.empty + | otherwise -> bale_out_with local_msg + (gre:_) + | ParentIs {} <- gre_par gre + , not meth_ok + -> bale_out_with sub_msg + | otherwise + -> return (Right (gre_name gre)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of + Just n + | n `elemNameSet` bound_names -> return (Right n) + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with Outputable.empty } + + bale_out_with msg + = return (Left (sep [ ptext (sLit "The") <+> what + <+> ptext (sLit "for") <+> quotes (ppr rdr_name) + , nest 2 $ ptext (sLit "lacks an accompanying binding")] + $$ nest 2 msg)) + + local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where") + <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared") + + sub_msg = parens $ ptext (sLit "You cannot give a") <+> what + <+> ptext (sLit "for a record selector or class method") + + +--------------- +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what rdr_name + = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) + ; let (errs, names) = splitEithers mb_gres + ; when (null names) $ addErr (head errs) -- Bleat about one only + ; return names } + where + lookup = lookupBindGroupOcc ctxt what + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +{- +Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. + +********************************************************* +* * + Fixities +* * +********************************************************* + +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. +-} + +-------------------------------- +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly + +-------------------------------- +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl + +addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a +addLocalFixities mini_fix_env names thing_inside + = extendFixityEnv (mapMaybe find_fixity names) thing_inside + where + find_fixity name + = case lookupFsEnv mini_fix_env (occNameFS occ) of + Just (L _ fix) -> Just (name, FixItem occ fix) + Nothing -> Nothing + where + occ = nameOccName name + +{- +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the HIT or PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment +-} + +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name + | isUnboundName name + = return (Fixity minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (Trac #7937) + + | otherwise + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return fix ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + -- Local (and interactive) names are all in the + -- fixity env, and don't have entries in the HPT + then return defaultFixity + else lookup_imported } } } + where + lookup_imported + -- For imported names, we have to get their fixities by doing a + -- loadInterfaceForName, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + -- + -- loadInterfaceForName will find B.hi even if B is a hidden module, + -- and that's what we want. + = do { iface <- loadInterfaceForName doc name + ; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]) + ; return (mi_fix_fn iface (nameOccName name)) } + + doc = ptext (sLit "Checking fixity for") <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn (L _ n) = lookupFixityRn n + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. + +We treat the orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr Name)) return type +lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName std_name + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (HsVar std_name, emptyFVs) + else + -- Get the similarly named thing from the local environment + do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (HsVar usr_name, unitFV usr_name) } } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (map HsVar std_names, emptyFVs) + else + do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names + ; return (map HsVar usr_names, mkFVs usr_names) } } + +{- +********************************************************* +* * +\subsection{Binding} +* * +********************************************************* +-} + +newLocalBndrRn :: Located RdrName -> RnM Name +-- Used for non-top-level binders. These should +-- never be qualified. +newLocalBndrRn (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = return name -- This happens in code generated by Template Haskell + -- See Note [Binders in Template Haskell] in Convert.lhs + | otherwise + = do { unless (isUnqual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + ; uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + +newLocalBndrsRn :: [Located RdrName] -> RnM [Name] +newLocalBndrsRn = mapM newLocalBndrRn + +--------------------- +bindLocatedLocalsRn :: [Located RdrName] + -> ([Name] -> RnM a) + -> RnM a +bindLocatedLocalsRn rdr_names_w_loc enclosed_scope + = do { checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + + -- Make fresh Names and extend the environment + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindLocalNames names (enclosed_scope names) } + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names enclosed_scope + = do { lcl_env <- getLclEnv + ; let th_level = thLevel (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' }) + enclosed_scope } + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; return (result, delFVs names fvs) } + + +------------------------------------- + -- binLocalsFVRn is the same as bindLocalsRn + -- except that it deals with free vars +bindLocatedLocalsFV :: [Located RdrName] + -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) +bindLocatedLocalsFV rdr_names enclosed_scope + = bindLocatedLocalsRn rdr_names $ \ names -> + do (thing, fvs) <- enclosed_scope names + return (thing, delFVs names fvs) + +------------------------------------- + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- This function is used only in rnSourceDecl on InstDecl +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + +------------------------------------- +checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNames rdr_names_w_loc + = mapM_ (dupNamesErr getLoc) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group +checkDupNames names = check_dup_names (filterOut isSystemName names) + -- See Note [Binders in Template Haskell] in Convert + +check_dup_names :: [Name] -> RnM () +check_dup_names names + = mapM_ (dupNamesErr nameSrcSpan) dups + where + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + +--------------------- +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs get_loc_occ filtered_rdrs } + where + filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { check_dup_names filtered_names + ; checkShadowedOccs envs get_loc_occ filtered_names } + where + filtered_names = filterOut isSystemName names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ name = (nameSrcSpan name, nameOccName name) + +------------------------------------- +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) + -> (a -> (SrcSpan, OccName)) + -> [a] -> RnM () +checkShadowedOccs (global_env,local_env) get_loc_occ ns + = whenWOptM Opt_WarnNameShadowing $ + do { traceRn (text "shadow" <+> ppr (map get_loc_occ ns)) + ; mapM_ check_shadow ns } + where + check_shadow n + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See Trac #3262 + | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)] + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } + where + (loc,occ) = get_loc_occ n + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + complain [] = return () + complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs) + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf Trac #2723) + is_shadowed_gre gre@(GRE { gre_par = ParentIs _ }) + = do { dflags <- getDynFlags + ; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) + then do { is_fld <- is_rec_fld gre; return (not is_fld) } + else return True } + is_shadowed_gre _other = return True + + is_rec_fld gre -- Return True for record selector ids + | isLocalGRE gre = do { RecFields _ fld_set <- getRecFieldEnv + ; return (gre_name gre `elemNameSet` fld_set) } + | otherwise = do { sel_id <- tcLookupField (gre_name gre) + ; return (isRecordSelector sel_id) } + +{- +************************************************************************ +* * + What to do when a lookup fails +* * +************************************************************************ +-} + +data WhereLooking = WL_Any -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + +unboundName :: WhereLooking -> RdrName -> RnM Name +unboundName wl rdr = unboundNameX wl rdr Outputable.empty + +unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name +unboundNameX where_look rdr_name extra + = do { show_helpful_errors <- goptM Opt_HelpfulErrors + ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + err = unknownNameErr what rdr_name $$ extra + ; if not show_helpful_errors + then addErr err + else do { suggestions <- unknownNameSuggestErr where_look rdr_name + ; addErr (err $$ suggestions) } + ; return (mkUnboundName rdr_name) } + +unknownNameErr :: SDoc -> RdrName -> SDoc +unknownNameErr what rdr_name + = vcat [ hang (ptext (sLit "Not in scope:")) + 2 (what <+> quotes (ppr rdr_name)) + , extra ] + where + extra | rdr_name == forall_tv_RDR = perhapsForallMsg + | otherwise = Outputable.empty + +type HowInScope = Either SrcSpan ImpDeclSpec + -- Left loc => locally bound at loc + -- Right ispec => imported as specified by ispec + +unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc +unknownNameSuggestErr where_look tried_rdr_name + = do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + ; dflags <- getDynFlags + + ; let all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities + = [ (showPpr dflags r, (r, Left loc)) + | (r,loc) <- local_possibilities local_env ] + ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] + + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities + perhaps = ptext (sLit "Perhaps you meant") + extra_err = case suggest of + [] -> Outputable.empty + [p] -> perhaps <+> pp_item p + ps -> sep [ perhaps <+> ptext (sLit "one of these:") + , nest 2 (pprWithCommas pp_item ps) ] + ; return extra_err } + where + pp_item :: (RdrName, HowInScope) -> SDoc + pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined + where loc' = case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l)) + pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported + parens (ptext (sLit "imported from") <+> ppr (is_mod is)) + + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = Outputable.empty + where ns = rdrNameSpace rdr + + tried_occ = rdrNameOcc tried_rdr_name + tried_is_sym = isSymOcc tried_occ + tried_ns = occNameSpace tried_occ + tried_is_qual = isQual tried_rdr_name + + correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns + && isSymOcc occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Any -> True; _ -> False } + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- localRdrEnvElts env + , let occ = nameOccName name + , correct_name_space occ] + + gre_ok :: GlobalRdrElt -> Bool + gre_ok = case where_look of + WL_LocalTop -> isLocalGRE + _ -> \_ -> True + + global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + occ = nameOccName name + , correct_name_space occ + , (mod, how) <- quals_in_scope name (gre_prov gre) + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, pair) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + prov = gre_prov gre + occ = nameOccName name + rdr_unqual = mkRdrUnqual occ + , correct_name_space occ + , pair <- case (unquals_in_scope name prov, quals_only occ prov) of + (how:_, _) -> [ (rdr_unqual, how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: Name -> Provenance -> [HowInScope] + unquals_in_scope n LocalDef = [ Left (nameSrcSpan n) ] + unquals_in_scope _ (Imported is) = [ Right ispec + | i <- is, let ispec = is_decl i + , not (is_qual ispec) ] + + -------------------- + quals_in_scope :: Name -> Provenance -> [(ModuleName, HowInScope)] + -- Ones for which the qualified version is in scope + quals_in_scope n LocalDef = case nameModule_maybe n of + Nothing -> [] + Just m -> [(moduleName m, Left (nameSrcSpan n))] + quals_in_scope _ (Imported is) = [ (is_as ispec, Right ispec) + | i <- is, let ispec = is_decl i ] + + -------------------- + quals_only :: OccName -> Provenance -> [(RdrName, HowInScope)] + -- Ones for which *only* the qualified version is in scope + quals_only _ LocalDef = [] + quals_only occ (Imported is) = [ (mkRdrQual (is_as ispec) occ, Right ispec) + | i <- is, let ispec = is_decl i, is_qual ispec ] + +{- +************************************************************************ +* * +\subsection{Free variable manipulation} +* * +************************************************************************ +-} + +-- A useful utility +addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) +addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside + ; return (res, fvs1 `plusFV` fvs2) } + +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, plusFVs fvs_s) + +mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) +mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) +mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } + +-- because some of the rename functions are CPSed: +-- maps the function across the list from left to right; +-- collects all the free vars into one set +mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c) + -> [a] -> ([b] -> RnM c) -> RnM c + +mapFvRnCPS _ [] cont = cont [] +mapFvRnCPS f (x:xs) cont = f x $ \ x' -> + mapFvRnCPS f xs $ \ xs' -> + cont (x':xs') + +{- +************************************************************************ +* * +\subsection{Envt utility functions} +* * +************************************************************************ +-} + +warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedTopBinds gres + = whenWOptM Opt_WarnUnusedBinds + $ do env <- getGblEnv + let isBoot = tcg_src env == HsBootFile + let noParent gre = case gre_par gre of + NoParent -> True + ParentIs _ -> False + -- Don't warn about unused bindings with parents in + -- .hs-boot files, as you are sometimes required to give + -- unused bindings (trac #3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. + gres' = if isBoot then filter noParent gres + else gres + warnUnusedGREs gres' + +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches + +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = whenWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) + +------------------------- +-- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () +warnUnusedGREs gres + = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] + +warnUnusedLocals :: [Name] -> RnM () +warnUnusedLocals names + = warnUnusedBinds [(n,LocalDef) | n<-names] + +warnUnusedBinds :: [(Name,Provenance)] -> RnM () +warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names) + where reportable (name,_) + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = not (startsWithUnderscore (nameOccName name)) + +------------------------- + +warnUnusedName :: (Name, Provenance) -> RnM () +warnUnusedName (name, LocalDef) + = addUnusedWarning name (nameSrcSpan name) + (ptext (sLit "Defined but not used")) + +warnUnusedName (name, Imported is) + = mapM_ warn is + where + warn spec = addUnusedWarning name span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used") + +addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM () +addUnusedWarning name span msg + = addWarnAt span $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name)] + +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +addNameClashErrRn rdr_name gres + | all isLocalGRE gres -- If there are two or more *local* defns, we'll have reported + = return () -- that already, and we don't want an error cascade + | otherwise + = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name), + ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)]) + where + (np1:nps) = gres + msg1 = ptext (sLit "either") <+> mk_ref np1 + msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps] + mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre] + +shadowedNameWarn :: OccName -> [SDoc] -> SDoc +shadowedNameWarn occ shadowed_locs + = sep [ptext (sLit "This binding for") <+> quotes (ppr occ) + <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + +perhapsForallMsg :: SDoc +perhapsForallMsg + = vcat [ ptext (sLit "Perhaps you intended to use ExplicitForAll or similar flag") + , ptext (sLit "to enable explicit-forall syntax: forall . ")] + +unknownSubordinateErr :: SDoc -> RdrName -> SDoc +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc + +badOrigBinding :: RdrName -> SDoc +badOrigBinding name + = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + +dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () +dupNamesErr get_loc names + = addErrAt big_loc $ + vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)), + locations] + where + locs = map get_loc names + big_loc = foldr1 combineSrcSpans locs + locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sort locs)) + +kindSigErr :: Outputable a => a -> SDoc +kindSigErr thing + = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) + 2 (ptext (sLit "Perhaps you intended to use KindSignatures")) + +badQualBndrErr :: RdrName -> SDoc +badQualBndrErr rdr_name + = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name + +opDeclErr :: RdrName -> SDoc +opDeclErr n + = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n)) + 2 (ptext (sLit "Use TypeOperators to declare operators in type and declarations")) + +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)), + nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))]) + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +data HsDocContext + = TypeSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (Located RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (Located RdrName) + | TySynCtx (Located RdrName) + | TyFamilyCtx (Located RdrName) + | ConDeclCtx [Located RdrName] + | ClassDeclCtx (Located RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | GHCiCtx + | SpliceTypeCtx (LHsType RdrName) + | ClassInstanceCtx + | VectDeclCtx (Located RdrName) + | GenericCtx SDoc -- Maybe we want to use this more! + +docOfHsDocContext :: HsDocContext -> SDoc +docOfHsDocContext (GenericCtx doc) = doc +docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc +docOfHsDocContext PatCtx = text "In a pattern type-signature" +docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma" +docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration" +docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name +docOfHsDocContext DerivDeclCtx = text "In a deriving declaration" +docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name +docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon) +docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name) +docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name) + +docOfHsDocContext (ConDeclCtx [name]) + = text "In the definition of data constructor" <+> quotes (ppr name) +docOfHsDocContext (ConDeclCtx names) + = text "In the definition of data constructors" <+> interpp'SP names + +docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" <+> ppr name +docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature" +docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type") +docOfHsDocContext HsTypeCtx = text "In a type argument" +docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input") +docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty +docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances") +docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs new file mode 100644 index 00000000..0dab57d1 --- /dev/null +++ b/compiler/rename/RnExpr.hs @@ -0,0 +1,1360 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnExpr]{Renaming of expressions} + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module RnExpr ( + rnLExpr, rnExpr, rnStmts + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) + +import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + rnMatchGroup, rnGRHS, makeMiniFixityEnv) +import HsSyn +import TcRnMonad +import Module ( getModule ) +import RnEnv +import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) +import RnTypes +import RnPat +import DynFlags +import BasicTypes ( FixityDirection(..) ) +import PrelNames + +import Name +import NameSet +import RdrName +import UniqSet +import Data.List +import Util +import ListSetOps ( removeDups ) +import ErrUtils +import Outputable +import SrcLoc +import FastString +import Control.Monad +import TysWiredIn ( nilDataConName ) + +{- +************************************************************************ +* * +\subsubsection{Expressions} +* * +************************************************************************ +-} + +rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = return ([], acc) + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } + +-- Variables. We look up the variable and return the resulting name. + +rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr = wrapLocFstM rnExpr + +rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) + +finishHsVar :: Name -> RnM (HsExpr Name, FreeVars) +-- Separated from rnExpr because it's also used +-- when renaming infix expressions +finishHsVar name + = do { this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod name) $ + checkThLocalName name + ; return (HsVar name, unitFV name) } + +rnExpr (HsVar v) + = do { mb_name <- lookupOccRn_maybe v + ; case mb_name of { + Nothing -> do { if startsWithUnderscore (rdrNameOcc v) + then return (HsUnboundVar v, emptyFVs) + else do { n <- reportUnboundName v; finishHsVar n } } ; + Just name + | name == nilDataConName -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -> rnExpr (ExplicitList placeHolderType Nothing []) + + | otherwise + -> finishHsVar name }} + +rnExpr (HsIPVar v) + = return (HsIPVar v, emptyFVs) + +rnExpr (HsLit lit@(HsString src s)) + = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) + else do { + ; rnLit lit + ; return (HsLit lit, emptyFVs) } } + +rnExpr (HsLit lit) + = do { rnLit lit + ; return (HsLit lit, emptyFVs) } + +rnExpr (HsOverLit lit) + = do { (lit', fvs) <- rnOverLit lit + ; return (HsOverLit lit', fvs) } + +rnExpr (HsApp fun arg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) + = do { (e1', fv_e1) <- rnLExpr e1 + ; (e2', fv_e2) <- rnLExpr e2 + ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) + ; (op', fv_op) <- finishHsVar op_name + -- NB: op' is usually just a variable, but might be + -- an applicatoin (assert "Foo.hs:47") + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2' + ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } +rnExpr (OpApp _ other_op _ _) + = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:")) + 2 (ppr other_op) + , ptext (sLit "(Probably resulting from a Template Haskell splice)") ]) + +rnExpr (NegApp e _) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntaxName negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } + +------------------------------------------ +-- Template Haskell extensions +-- Don't ifdef-GHCI them because we want to fail gracefully +-- (not with an rnExpr crash) in a stage-1 compiler. +rnExpr e@(HsBracket br_body) = rnBracket e br_body + +rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice + + +rnExpr (HsQuasiQuoteE qq) + = do { lexpr' <- runQuasiQuoteExpr qq + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ; rnExpr (HsPar lexpr') } + +--------------------------------------------- +-- Sections +-- See Note [Parsing sections] in Parser.y +rnExpr (HsPar (L loc (section@(SectionL {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } + +rnExpr (HsPar (L loc (section@(SectionR {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } + +rnExpr (HsPar e) + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar e', fvs_e) } + +rnExpr expr@(SectionL {}) + = do { addErr (sectionErr expr); rnSection expr } +rnExpr expr@(SectionR {}) + = do { addErr (sectionErr expr); rnSection expr } + +--------------------------------------------- +rnExpr (HsCoreAnn src ann expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsCoreAnn src ann expr', fvs_expr) } + +rnExpr (HsSCC src lbl expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsSCC src lbl expr', fvs_expr) } +rnExpr (HsTickPragma src info expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsTickPragma src info expr', fvs_expr) } + +rnExpr (HsLam matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches + ; return (HsLam matches', fvMatch) } + +rnExpr (HsLamCase _arg matches) + = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches + -- ; return (HsLamCase arg matches', fvs_ms) } + ; return (HsLamCase placeHolderType matches', fvs_ms) } + +rnExpr (HsCase expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnExpr (HsLet binds expr) + = rnLocalBindsAndThen binds $ \binds' -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet binds' expr', fvExpr) } + +rnExpr (HsDo do_or_lc stmts _) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } + +rnExpr (ExplicitList _ _ exps) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (exps', fvs) <- rnExprs exps + ; if opt_OverloadedLists + then do { + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' + , fvs `plusFV` fvs') } + else + return (ExplicitList placeHolderType Nothing exps', fvs) } + +rnExpr (ExplicitPArr _ exps) + = do { (exps', fvs) <- rnExprs exps + ; return (ExplicitPArr placeHolderType exps', fvs) } + +rnExpr (ExplicitTuple tup_args boxity) + = do { checkTupleSection tup_args + ; checkTupSize (length tup_args) + ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args + ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } + where + rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) + , emptyFVs) + +rnExpr (RecordCon con_id _ rbinds) + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } + +rnExpr (RecordUpd expr rbinds _ _ _) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds + ; return (RecordUpd expr' rbinds' [] [] [], + fvExpr `plusFV` fvRbinds) } + +rnExpr (ExprWithTySig expr pty PlaceHolder) + = do { (wcs, pty') <- extractWildcards pty + ; bindLocatedLocalsFV wcs $ \wcs_new -> do { + (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty' + ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty'') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } } + +rnExpr (HsIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + +rnExpr (HsMultiIf _ty alts) + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts + -- ; return (HsMultiIf ty alts', fvs) } + ; return (HsMultiIf placeHolderType alts', fvs) } + +rnExpr (HsType a) + = do { (t, fvT) <- rnLHsType HsTypeCtx a + ; return (HsType t, fvT) } + +rnExpr (ArithSeq _ _ seq) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + else + return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } + +rnExpr (PArrSeq _ seq) + = do { (new_seq, fvs) <- rnArithSeq seq + ; return (PArrSeq noPostTcExpr new_seq, fvs) } + +{- +These three are pattern syntax appearing in expressions. +Since all the symbols are reservedops we can simply reject them. +We return a (bogus) EWildPat in each case. +-} + +rnExpr EWildPat = return (hsHoleExpr, emptyFVs) +rnExpr e@(EAsPat {}) = patSynErr e +rnExpr e@(EViewPat {}) = patSynErr e +rnExpr e@(ELazyPat {}) = patSynErr e + +{- +************************************************************************ +* * + Static values +* * +************************************************************************ + +For the static form we check that the free variables are all top-level +value bindings. This is done by checking that the name is external or +wired-in. See the Notes about the NameSorts in Name.hs. +-} + +rnExpr e@(HsStatic expr) = do + target <- fmap hscTarget getDynFlags + case target of + -- SPT entries are expected to exist in object code so far, and this is + -- not the case in interpreted mode. See bug #9878. + HscInterpreted -> addErr $ sep + [ text "The static form is not supported in interpreted mode." + , text "Please use -fobject-code." + ] + _ -> return () + (expr',fvExpr) <- rnLExpr expr + stage <- getStage + case stage of + Brack _ _ -> return () -- Don't check names if we are inside brackets. + -- We don't want to reject cases like: + -- \e -> [| static $(e) |] + -- if $(e) turns out to produce a legal expression. + Splice _ -> addErr $ sep + [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + _ -> do + let isTopLevelName n = isExternalName n || isWiredInName n + case nameSetElems $ filterNameSet + (\n -> not (isTopLevelName n || isUnboundName n)) + fvExpr of + [] -> return () + fvNonGlobal -> addErr $ cat + [ text $ "Only identifiers of top-level bindings can " + ++ "appear in the body of the static form:" + , nest 2 $ ppr e + , text "but the following identifiers were found instead:" + , nest 2 $ vcat $ map ppr fvNonGlobal + ] + return (HsStatic expr', fvExpr) + +{- +************************************************************************ +* * + Arrow notation +* * +************************************************************************ +-} + +rnExpr (HsProc pat body) + = newArrowScope $ + rnPat ProcExpr pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc pat' body', fvBody) } + +-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. +rnExpr e@(HsArrApp {}) = arrowFail e +rnExpr e@(HsArrForm {}) = arrowFail e + +rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) + -- HsWrap + +hsHoleExpr :: HsExpr Name +hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_")) + +arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +arrowFail e + = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:") + , nest 2 (ppr e) ]) + -- Return a place-holder hole, so that we can carry on + -- to report other errors + ; return (hsHoleExpr, emptyFVs) } + +---------------------- +-- See Note [Parsing sections] in Parser.y +rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnSection section@(SectionR op expr) + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } + +rnSection section@(SectionL expr op) + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } + +rnSection other = pprPanic "rnSection" (ppr other) + +{- +************************************************************************ +* * + Records +* * +************************************************************************ +-} + +rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName + -> RnM (HsRecordBinds Name, FreeVars) +rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) + = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds + ; (flds', fvss) <- mapAndUnzipM rn_field flds + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, + fvs `plusFV` plusFVs fvss) } + where + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } + +{- +************************************************************************ +* * + Arrow commands +* * +************************************************************************ +-} + +rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) +rnCmdArgs [] = return ([], emptyFVs) +rnCmdArgs (arg:args) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } + +rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) +rnCmdTop = wrapLocFstM rnCmdTop' + where + rnCmdTop' (HsCmdTop cmd _ _ _) + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetElems (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names + + ; return (HsCmdTop cmd' placeHolderType placeHolderType + (cmd_names `zip` cmd_names'), + fvCmd `plusFV` cmd_fvs) } + +rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd = wrapLocFstM rnCmd + +rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) + +rnCmd (HsCmdArrApp arrow arg _ ho rtl) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) } + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. + +-- infix form +rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) + = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) + ; let L _ (HsVar op_name) = op' + ; (arg1',fv_arg1) <- rnCmdTop arg1 + ; (arg2',fv_arg2) <- rnCmdTop arg2 + -- Deal with fixity + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpFormRn arg1' op' fixity arg2' + ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } + +rnCmd (HsCmdArrForm op fixity cmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) } + +rnCmd (HsCmdApp fun arg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } + +rnCmd (HsCmdLam matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + ; return (HsCmdLam matches', fvMatch) } + +rnCmd (HsCmdPar e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar e', fvs_e) } + +rnCmd (HsCmdCase expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnCmd (HsCmdIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + +rnCmd (HsCmdLet binds cmd) + = rnLocalBindsAndThen binds $ \ binds' -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet binds' cmd', fvExpr) } + +rnCmd (HsCmdDo stmts _) + = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo stmts' placeHolderType, fvs ) } + +rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd) + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + +methodNamesCmd :: HsCmd Name -> CmdNeeds + +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) + = emptyFVs +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) + = unitFV appAName +methodNamesCmd (HsCmdArrForm {}) = emptyFVs +methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd + +methodNamesCmd (HsCmdPar c) = methodNamesLCmd c + +methodNamesCmd (HsCmdIf _ _ c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam match) = methodNamesMatch match + +methodNamesCmd (HsCmdCase _ matches) + = methodNamesMatch matches `addOneFV` choiceAName + +--methodNamesCmd _ = emptyFVs + -- Other forms can't occur in commands, but it's not convenient + -- to error here so we just do what's convenient. + -- The type checker will complain later + +--------------------------------------------------- +methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars +methodNamesMatch (MG { mg_alts = ms }) + = plusFVs (map do_one ms) + where + do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss + +------------------------------------------------- +-- gaw 2004 +methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars +methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) + +------------------------------------------------- + +methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds +methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs + +--------------------------------------------------- +methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) + +--------------------------------------------------- +methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars +methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error + -- here so we just do what's convenient + +{- +************************************************************************ +* * + Arithmetic sequences +* * +************************************************************************ +-} + +rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) +rnArithSeq (From expr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } + +rnArithSeq (FromThen expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromTo expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromThenTo expr1 expr2 expr3) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } + +{- +************************************************************************ +* * +\subsubsection{@Stmt@s: in @do@ expressions} +* * +************************************************************************ +-} + +rnStmts :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) +-- Variables bound by the Stmts, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmts ctxt _ [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts + +rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt' thing_inside } + + | otherwise + = do { ((stmts1, (stmts2, thing)), fvs) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmts ctxt rnBody lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } + ; return (((stmts1 ++ stmts2), thing), fvs) } + +---------------------- +rnStmt :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LStmt RdrName (Located (body RdrName)) + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) +-- Variables bound by the Stmt, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt body' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs3) <- thing_inside (collectPatBinders pat') + ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- but it does not matter because the names are unique + +rnStmt _ _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do + { (thing, fvs) <- thing_inside (collectLocalBinders binds') + ; return (([L loc (LetStmt binds')], thing), fvs) } } + +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside + = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName + ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do + { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds)) + emptyNameSet segs + ; (thing, fvs_later) <- thing_inside bndrs + ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + +rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- rnLExpr using + + -- Rename the stmts and the 'by' expression + -- Keep track of the variables mentioned in the 'by' expression + ; ((stmts', (by', used_bndrs, thing)), fvs2) + <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> + do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by + ; (thing, fvs_thing) <- thing_inside bndrs + ; let fvs = fvs_by `plusFV` fvs_thing + used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free varaible + -- of the "thing inside", **or of the by-expression**, as used + ; return ((by', used_bndrs, thing), fvs) } + + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noSyntaxExpr, emptyFVs) + _ -> lookupStmtName ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 + bndr_map = used_bndrs `zip` used_bndrs + -- See Note [TransStmt binder map] in HsExpr + + ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) + ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op })], thing), all_fvs) } + +rnParallelStmts :: forall thing. HsStmtContext Name + -> SyntaxExpr Name + -> [ParStmtBlock RdrName RdrName] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([ParStmtBlock Name Name], thing), FreeVars) +-- Note [Renaming parallel Stmts] +rnParallelStmts ctxt return_op segs thing_inside + = do { orig_lcl_env <- getLocalRdrEnv + ; rn_segs orig_lcl_env [] segs } + where + rn_segs :: LocalRdrEnv + -> [Name] -> [ParStmtBlock RdrName RdrName] + -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + rn_segs _ bndrs_so_far [] + = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far + ; mapM_ dupErr dups + ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') + ; return (([], thing), fvs) } + + rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + = do { ((stmts', (used_bndrs, segs', thing)), fvs) + <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> + setLocalRdrEnv env $ do + { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; return ((used_bndrs, segs', thing), fvs) } + + ; let seg' = ParStmtBlock stmts' used_bndrs return_op + ; return ((seg':segs', thing), fvs) } + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr (head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmtCtxt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) + +{- +Note [Renaming parallel Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Renaming parallel statements is painful. Given, say + [ a+c | a <- as, bs <- bss + | c <- bs, a <- ds ] +Note that + (a) In order to report "Defined by not used" about 'bs', we must rename + each group of Stmts with a thing_inside whose FreeVars include at least {a,c} + + (b) We want to report that 'a' is illegally bound in both branches + + (c) The 'bs' in the second group must obviously not be captured by + the binding in the first group + +To satisfy (a) we nest the segements. +To satisfy (b) we check for duplicates just before thing_inside. +To satisfy (c) we reset the LocalRdrEnv each time. + +************************************************************************ +* * +\subsubsection{mdo expressions} +* * +************************************************************************ +-} + +type FwdRefs = NameSet +type Segment stmts = (Defs, + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] + + +-- wrapper that does both the left- and right-hand sides +rnRecStmtsAndThen :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen rnBody s cont + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) + ; bindLocalNamesFV bound_names $ + addLocalFixities fix_env bound_names $ do + + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) + ; return (res, fvs) }} + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv + -> LStmt RdrName body + -- rename LHS, and return its FVs + -- Warning: we will only need the FreeVars below in the case of a BindStmt, + -- so we don't bother to compute it accurately in the other cases + -> RnM [(LStmtLR Name RdrName body, FreeVars)] + +rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) + = return [(L loc (BodyStmt body a b c), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt body a)) + = return [(L loc (LastStmt body a), emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + return [(L loc (BindStmt pat' body a b), + fv_pat)] + +rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) + = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) + +rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt (HsValBinds binds')), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +-- XXX Do we need to do something with the return and mfix names? +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) + = panic "rn_rec_stmt LetStmt EmptyLocalBinds" + +rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv + -> [LStmt RdrName body] + -> RnM [(LStmtLR Name RdrName body, FreeVars)] +rn_rec_stmts_lhs fix_env stmts + = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts + ; let boundNames = collectLStmtsBinders (map fst ls) + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + ; checkDupNames boundNames + ; return ls } + + +-- right-hand-sides + +rn_rec_stmt :: (Outputable (body RdrName)) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] + -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars) + -> RnM [Segment (LStmt Name (Located (body Name)))] + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt +rn_rec_stmt rnBody _ (L loc (LastStmt body _), _) + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt body' ret_op))] } + +rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _) + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] } + +rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupSyntaxName bindMName + ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; let bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt pat' body' bind_op fail_op))] } + +rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _)), _) + = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) + +rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds')), _) + = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' + -- fixities and unused are handled above in rnRecStmtsAndThen + ; return [(duDefs du_binds, allUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] } + +-- no RecStmt case because they get flattened above when doing the LHSes +rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) + +rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) + +rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds), _) + = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" + +rn_rec_stmts :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] + -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] + -> RnM [Segment (LStmt Name (Located (body Name)))] +rn_rec_stmts rnBody bndrs stmts + = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts + ; return (concat segs_s) } + +--------------------------------------------- +segmentRecStmts :: SrcSpan -> HsStmtContext Name + -> Stmt Name body + -> [Segment (LStmt Name body)] -> FreeVars + -> ([LStmt Name body], FreeVars) + +segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + | null segs + = ([], fvs_later) + + | MDoExpr <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L loc $ + empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElems (defs `intersectNameSet` fvs_later) + , recS_rec_ids = nameSetElems (defs `intersectNameSet` uses) }] + , uses `plusFV` fvs_later) + + where + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- +addFwdRefs :: [Segment a] -> [Segment a] +-- So far the segments only have forward refs *within* the Stmt +-- (which happens for bind: x <- ...x...) +-- This function adds the cross-seg fwd ref info + +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) + where + mk_seg (defs, uses, fwds, stmts) (segs, later_defs) + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSet` defs + new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here + +{- +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } +-} + +glomSegments :: HsStmtContext Name + -> [Segment (LStmt Name body)] + -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts +-- See Note [Glomming segments] + +glomSegments _ [] = [] +glomSegments ctxt ((defs,uses,fwds,stmt) : segs) + -- Actually stmts will always be a singleton + = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others + where + segs' = glomSegments ctxt segs + (extras, others) = grab uses segs' + (ds, us, fs, ss) = unzip4 extras + + seg_defs = plusFVs ds `plusFV` defs + seg_uses = plusFVs us `plusFV` uses + seg_fwds = plusFVs fs `plusFV` fwds + seg_stmts = stmt : concat ss + + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) + +---------------------------------------------------- +segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt Name body], FreeVars) + +segsToStmts _ [] fvs_later = ([], fvs_later) +segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later + = ASSERT( not (null ss) ) + (new_stmt : later_stmts, later_uses `plusFV` uses) + where + (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt + rec_stmt = empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElems used_later + , recS_rec_ids = nameSetElems fwds } + non_rec = isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) + +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False + +emptyErr :: HsStmtContext Name -> SDoc +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt + +---------------------- +checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name + -> LStmt RdrName (Located (body RdrName)) + -> RnM (LStmt RdrName (Located (body RdrName))) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + PArrComp -> check_comp + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other + where + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of + BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } + +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext Name + -> LStmt RdrName (Located (body RdrName)) + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDynFlags + ; case okStmt dflags ctxt stmt of + IsValid -> return () + NotValid extra -> addErr (msg $$ extra) } + where + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext ctxt ] + +pprStmtCat :: Stmt a body -> SDoc +pprStmtCat (TransStmt {}) = ptext (sLit "transform") +pprStmtCat (LastStmt {}) = ptext (sLit "return expression") +pprStmtCat (BodyStmt {}) = ptext (sLit "body") +pprStmtCat (BindStmt {}) = ptext (sLit "binding") +pprStmtCat (LetStmt {}) = ptext (sLit "let") +pprStmtCat (RecStmt {}) = ptext (sLit "rec") +pprStmtCat (ParStmt {}) = ptext (sLit "parallel") + +------------ +emptyInvalid :: Validity -- Payload is the empty document +emptyInvalid = NotValid Outputable.empty + +okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: DynFlags -> HsStmtContext Name + -> Stmt RdrName (Located (body RdrName)) -> Validity +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to an generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity +okPatGuardStmt stmt + = case stmt of + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt (HsIPBinds {}) -> emptyInvalid + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | Opt_RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (ptext (sLit "Use RecursiveDo")) + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + TransStmt {} + | Opt_TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use TransformListComp")) + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) + +---------------- +okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + TransStmt {} -> emptyInvalid + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) + +--------- +checkTupleSection :: [LHsTupArg RdrName] -> RnM () +checkTupleSection args + = do { tuple_section <- xoptM Opt_TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } + where + msg = ptext (sLit "Illegal tuple section: use TupleSections") + +--------- +sectionErr :: HsExpr RdrName -> SDoc +sectionErr expr + = hang (ptext (sLit "A section must be enclosed in parentheses")) + 2 (ptext (sLit "thus:") <+> (parens (ppr expr))) + +patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"), + nest 4 (ppr e)]) + ; return (EWildPat, emptyFVs) } + +badIpBinds :: Outputable a => SDoc -> a -> SDoc +badIpBinds what binds + = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what) + 2 (ppr binds) diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot new file mode 100644 index 00000000..5419870d --- /dev/null +++ b/compiler/rename/RnExpr.hs-boot @@ -0,0 +1,18 @@ +module RnExpr where +import HsSyn +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) +import TcRnTypes +import SrcLoc ( Located ) +import Outputable ( Outputable ) + +rnLExpr :: LHsExpr RdrName + -> RnM (LHsExpr Name, FreeVars) + +rnStmts :: --forall thing body. + Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs new file mode 100644 index 00000000..9e53f493 --- /dev/null +++ b/compiler/rename/RnHsDoc.hs @@ -0,0 +1,23 @@ + +module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where + +import TcRnTypes +import HsSyn +import SrcLoc + + +rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) +rnMbLHsDoc mb_doc = case mb_doc of + Just doc -> do + doc' <- rnLHsDoc doc + return (Just doc') + Nothing -> return Nothing + +rnLHsDoc :: LHsDocString -> RnM LHsDocString +rnLHsDoc (L pos doc) = do + doc' <- rnHsDoc doc + return (L pos doc') + +rnHsDoc :: HsDocString -> RnM HsDocString +rnHsDoc (HsDocString s) = return (HsDocString s) + diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs new file mode 100644 index 00000000..58a743e0 --- /dev/null +++ b/compiler/rename/RnNames.hs @@ -0,0 +1,1805 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnNames]{Extracting imported and top-level names in scope} +-} + +{-# LANGUAGE CPP, NondecreasingIndentation #-} + +module RnNames ( + rnImports, getLocalNonValBinders, + rnExports, extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName + ) where + +#include "HsVersions.h" + +import DynFlags +import HsSyn +import TcEnv ( isBrackStage ) +import RnEnv +import RnHsDoc ( rnHsDoc ) +import LoadIface ( loadSrcInterface ) +import TcRnMonad +import PrelNames +import Module +import Name +import NameEnv +import NameSet +import Avail +import HscTypes +import RdrName +import Outputable +import Maybes +import SrcLoc +import BasicTypes ( TopLevelFlag(..) ) +import ErrUtils +import Util +import FastString +import ListSetOps + +import Control.Monad +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.List ( partition, (\\), find ) +import qualified Data.Set as Set +import System.FilePath (()) +import System.IO + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompliation being triggered: package trust. So we must check that all +packages a module tranitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +HscMain.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls +-- Do the non SOURCE ones first, so that we get a helpful warning for SOURCE +-- ones that are unnecessary +rnImports :: [LImportDecl RdrName] + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports imports = do + this_mod <- getModule + let (source, ordinary) = partition is_source_import imports + is_source_import d = ideclSource (unLoc d) + stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary + stuff2 <- mapAndReportM (rnImportDecl this_mod) source + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) + return (decls, rdr_env, imp_avails, hpc_usage) + + where + combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) + + plus (decl, gbl_env1, imp_avails1,hpc_usage1) + (decls, gbl_env2, imp_avails2,hpc_usage2) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2 ) + +rnImportDecl :: Module -> LImportDecl RdrName + -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_only, ideclImplicit = implicit + , ideclAs = as_mod, ideclHiding = imp_details })) + = setSrcSpan loc $ do + + when (isJust mb_pkg) $ do + pkg_imports <- xoptM Opt_PackageImports + when (not pkg_imports) $ addErr packageImportErr + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") + + -- Check for self-import, which confuses the typechecker (Trac #9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until TcIface.tcHiBootIface, which is too late to avoid + -- typechecker crashes. ToDo: what about indirect self-import? + -- But 'import {-# SOURCE #-} M' is ok, even if a bit odd + when (not want_boot && + imp_mod_name == moduleName this_mod && + (case mb_pkg of -- If we have import "" M, then we should + -- check that "" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and Trac #9997 + Nothing -> True + Just pkg_fs -> pkg_fs == fsLit "this" || + fsToPackageKey pkg_fs == modulePackageKey this_mod)) + (addErr (ptext (sLit "A module cannot import itself:") <+> ppr imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (False, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> whenWOptM Opt_WarnMissingImportList $ + addWarn (missingImportListWarn imp_mod_name) + + ifaces <- loadSrcInterface doc imp_mod_name want_boot mb_pkg + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( not want_boot && any mi_boot ifaces, ppr imp_mod_name ) do + + -- Another sanity check: we should not get multiple interfaces + -- if we're looking for an hi-boot file + WARN( want_boot && length ifaces /= 1, ppr imp_mod_name ) do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf (want_boot && any (not.mi_boot) ifaces && isOneShot (ghcMode dflags)) + (warnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (ptext (sLit "safe import can't be used as Safe Haskell isn't on!") + $+$ ptext (sLit $ "please enable Safe Haskell through either " + ++ "Safe, Trustworthy or Unsafe")) + + let + qual_mod_name = as_mod `orElse` imp_mod_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports ifaces imp_spec imp_details + + let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres) + from_this_mod gre = nameModule (gre_name gre) == this_mod + + -- True <=> import M () + import_all = case imp_details of + Just (is_hiding, L _ ls) -> not is_hiding && null ls + _ -> False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + let imports + = foldr plusImportAvails emptyImportAvails (map + (\iface -> + (calculateAvails dflags iface mod_safe' want_boot) { + imp_mods = unitModuleEnv (mi_module iface) + [(qual_mod_name, import_all, loc, mod_safe')] }) + ifaces) + + -- Complain if we import a deprecated module + whenWOptM Opt_WarnWarningsDeprecations ( + forM_ ifaces $ \iface -> + case mi_warns iface of + WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt + _ -> return () + ) + + let new_imp_decl = L loc (decl { ideclSafe = mod_safe' + , ideclHiding = new_imp_details }) + + return (new_imp_decl, gbl_env, imports, any mi_hpc ifaces) + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: DynFlags + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportAvails +calculateAvails dflags iface mod_safe' want_boot = + let imp_mod = mi_module iface + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + + orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps + | otherwise = dep_orphs deps + + finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) + imp_mod : dep_finsts deps + | otherwise = dep_finsts deps + + pkg = modulePackageKey (mi_module iface) + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) + | pkg == thisPackage dflags = + -- Imported module is from the home package + -- Take its dependent modules and add imp_mod itself + -- Take its dependent packages unchanged + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See LoadIface.loadHiBootInterface + ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust) + + | otherwise = + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) + , ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps, False) + + in ImportAvails { + imp_mods = emptyModuleEnv, -- this gets filled in later + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then map fst $ filter snd dependent_pkgs + else [], + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + + +warnRedundantSourceImport :: ModuleName -> SDoc +warnRedundantSourceImport mod_name + = ptext (sLit "Unnecessary {-# SOURCE #-} in the import of module") + <+> quotes (ppr mod_name) + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in HscTypes + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal name, not (as usual) an External one. + Otherwise the NameCache gets confused by a second allocation of + M.f. (We used to invent a fake module ThFake to avoid this, but + that had other problems, notably in getting the correct answer for + nameIsLocalOrFrom in lookupFixity. So we now leave tcg_module + unaffected.) + +2. We make them *shadow* the outer bindings. If we don't do that, + we'll get a complaint when extending the GlobalRdrEnv, saying that + there are two bindings for 'f'. There are several tricky points: + + * This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. + + * The *qualified* name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + * We only shadow *External* names (which come from the main module) + Do not shadow *Inernal* names because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + +3. We find out whether we are inside a [d| ... |] by testing the TH + stage. This is a slight hack, because the stage field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. +-} + +extendGlobalRdrEnvRn :: [AvailInfo] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn avails new_fixities + = do { (gbl_env, lcl_env) <- getEnvs + ; stage <- getStage + ; isGHCi <- getIsGHCi + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + th_bndrs = tcl_th_bndrs lcl_env + th_lvl = thLevel stage + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [Top-level Names in Template Haskell decl quotes] + inBracket = isBrackStage stage + lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + rdr_env2 = extendGlobalRdrEnv (isGHCi && not inBracket) rdr_env avails + -- Shadowing only applies for GHCi decls outside brackets + -- e.g. (Trac #4127a) + -- ghci> runQ [d| class C a where f :: a + -- f = True + -- instance C Int where f = 2 |] + -- We don't want the f=True to shadow the f class-op + + lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs + [ (n, (TopLevel, th_lvl)) + | n <- new_names ] } + fix_env' = foldl extend_fix_env fix_env new_names + dups = findLocalDupsRdrEnv rdr_env2 new_names + + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn (text "extendGlobalRdrEnvRn 1" <+> (ppr avails $$ (ppr dups))) + ; mapM_ (addDupDeclErr . map gre_name) dups + + ; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2)) + ; return (gbl_env', lcl_env3) } + where + new_names = concatMap availNames avails + new_occs = map nameOccName new_names + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env name + | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + occ = nameOccName name + +{- +@getLocalDeclBinders@ returns the names for an @HsDecl@. It's +used for source code. + + *** See "THE NAMING STORY" in HsDecls **** +-} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * pattern synonyms +-- * value signatures (in hs-boot files) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls) + ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails) + ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env + ; setEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; nti_avails <- concatMapM new_assoc inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs | is_boot = hs_boot_sig_bndrs + | otherwise = for_hs_bndrs ++ patsyn_hs_bndrs + ; val_avails <- mapM new_simple val_bndrs + + ; let avails = nti_avails ++ val_avails + new_bndrs = availsToNameSet avails `unionNameSet` + availsToNameSet tc_avails + ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails) + ; envs <- extendGlobalRdrEnvRn avails fixity_env + ; return (envs, new_bndrs) } } + where + ValBindsIn val_binds val_sigs = binds + + for_hs_bndrs :: [Located RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + patsyn_hs_bndrs :: [Located RdrName] + patsyn_hs_bndrs = hsPatSynBinders val_binds + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + hs_boot_sig_bndrs = [ L decl_loc (unLoc n) + | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns] + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: Located RdrName -> RnM AvailInfo + new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name + ; return (Avail nm) } + + new_tc tc_decl -- NOT for type/data instances + = do { let bndrs = hsLTyClDeclBinders tc_decl + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs + ; return (AvailTC main_name names) } + + new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] + new_assoc (L _ (TyFamInstD {})) = return [] + -- type instances don't bind new names + + new_assoc (L _ (DataFamInstD { dfid_inst = d })) + = do { avail <- new_di Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl + { cid_poly_ty = inst_ty + , cid_datafam_insts = adts } })) + | Just (_, _, L loc cls_rdr, _) <- + splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty) + = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr + ; mapM (new_di (Just cls_nm) . unLoc) adts } + | otherwise + = return [] -- Do not crash on ill-formed instances + -- Eg instance !Show Int Trac #3811c + + new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo + new_di mb_cls ti_decl + = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) + ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl) + ; return (AvailTC (unLoc main_name) sub_names) } + -- main_name is not bound here! + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take the mi_exports of M, and make + imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) +One entry for each Name that M exports; the AvailInfo describes just +that Name. + +The situation is made more complicated by associated types. E.g. + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } +Then M's export_avails are (recall the AvailTC invariant from Avails.hs) + C(C,T), T(T,T1,T2,T3) +Notice that T appears *twice*, once as a child and once as a parent. +From this we construct the imp_occ_env + C -> (C, C(C,T), Nothing + T -> (T, T(T,T1,T2,T3), Just C) + T1 -> (T1, T(T1,T2,T3), Nothing) -- similarly T2,T3 + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. +-} + +filterImports + :: [ModIface] + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports iface decl_spec Nothing + = return (Nothing, gresFromAvails prov (concatMap mi_exports iface)) + where + prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] + + +filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) + = do -- check for errors, convert RdrNames to Names + items1 <- mapM lookup_lie import_items + + let items2 :: [(LIE Name, AvailInfo)] + items2 = concat items1 + -- NB the AvailInfo may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + names = availsToNameSet (map snd items2) + keep n = not (n `elemNameSet` names) + pruned_avails = filterAvails keep all_avails + hiding_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] + + gres | want_hiding = gresFromAvails hiding_prov pruned_avails + | otherwise = concatMap (gresFromIE decl_spec) items2 + + return (Just (want_hiding, L l (map fst items2)), gres) + where + all_avails = concatMap mi_exports ifaces + + -- See Note [Dealing with imports] + imp_occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) + | a <- all_avails, n <- availNames a] + where + -- See example in Note [Dealing with imports] + -- 'combine' is only called for associated types which appear twice + -- in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + combine (name1, a1@(AvailTC p1 _), mp1) + (name2, a2@(AvailTC p2 _), mp2) + = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 ) + if p1 == name1 then (name1, a1, Just p2) + else (name1, a2, Just p1) + combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + + lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith BadImport + where + mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie (L loc ieRdr) + = do (stuff, warns) <- setSrcSpan loc $ + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) + mapM_ emit_warning warns + return [ (L loc ie, avail) | (ie,avail) <- stuff ] + where + -- Warn when importing T(..) if T was exported abstractly + emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ + addWarn (dodgyImportWarn n) + emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ + addWarn (missingImportListItem ieRdr) + emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $ + addWarn (lookup_err_msg BadImport) + + run_lookup :: IELookupM a -> TcRn (Maybe a) + run_lookup m = case m of + Failed err -> addErr (lookup_err_msg err) >> return Nothing + Succeeded a -> return (Just a) + + lookup_err_msg err = case err of + BadImport -> badImportItemErr (any mi_boot ifaces) decl_spec + ieRdr all_avails + IllegalImport -> illegalImportItemErr + QualImportError rdr -> qualImportItemErr rdr + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time construct an AvailInfo corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- We return a list here, because in the case of an import + -- item like C, if we are hiding, then C refers to *both* a + -- type/class and a data constructor. Moreover, when we import + -- data constructors of an associated family, we need separate + -- AvailInfos for the data constructors and the family (as they have + -- different parents). See Note [Dealing with imports] + lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ do + case ie of + IEVar (L l n) -> do + (name, avail, _) <- lookup_name n + return ([(IEVar (L l name), trimAvail avail name)], []) + + IEThingAll (L l tc) -> do + (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc + let warns | null (drop 1 subs) = [DodgyImport tc] + | not (is_qual decl_spec) = [MissingImportList] + | otherwise = [] + case mb_parent of + -- non-associated ty/cls + Nothing -> return ([(IEThingAll (L l name), avail)], warns) + -- associated ty + Just parent -> return ([(IEThingAll (L l name), + AvailTC name2 (subs \\ [name])), + (IEThingAll (L l name), + AvailTC parent [name])], + warns) + + IEThingAbs (L l tc) + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc_name = lookup_name tc + dc_name = lookup_name (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith BadImport + names -> return ([mkIEThingAbs l name | name <- names], []) + | otherwise + -> do nameAvail <- lookup_name tc + return ([mkIEThingAbs l nameAvail], []) + + IEThingWith (L l rdr_tc) rdr_ns -> do + (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc + + -- Look up the children in the sub-names of the parent + let subnames = case ns of -- The tc is first in ns, + [] -> [] -- if it is there at all + -- See the AvailTC Invariant in Avail.hs + (n1:ns1) | n1 == name -> ns1 + | otherwise -> ns + mb_children = lookupChildren subnames rdr_ns + + children <- if any isNothing mb_children + then failLookupWith BadImport + else return (catMaybes mb_children) + + case mb_parent of + -- non-associated ty/cls + Nothing -> return ([(IEThingWith (L l name) children, + AvailTC name (name:map unLoc children))], + []) + -- associated ty + Just parent -> return ([(IEThingWith (L l name) children, + AvailTC name (map unLoc children)), + (IEThingWith (L l name) children, + AvailTC parent [name])], + []) + + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed + -- all errors. + + where + mkIEThingAbs l (n, av, Nothing ) = (IEThingAbs (L l n), + trimAvail av n) + mkIEThingAbs l (n, _, Just parent) = (IEThingAbs (L l n), + AvailTC parent [n]) + + handle_bad_import m = catchIELookup m $ \err -> case err of + BadImport | want_hiding -> return ([], [BadImportW]) + _ -> failLookupWith err + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW + | MissingImportList + | DodgyImport RdrName + -- NB. use the RdrName for reporting a "dodgy" import + +data IELookupError + = QualImportError RdrName + | BadImport + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +greExportAvail :: GlobalRdrElt -> AvailInfo +greExportAvail gre + = case gre_par gre of + ParentIs p -> AvailTC p [me] + NoParent | isTyConName me -> AvailTC me [me] + | otherwise -> Avail me + where + me = gre_name gre + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 +plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) + +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail (Avail n) _ = Avail n +trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m] + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns -> + let left = filter keep ns in + if null left then rest else AvailTC tc left : rest + +-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, avail) + = gresFromAvail prov_fn avail + where + is_explicit = case ie of + IEThingAll (L _ name) -> \n -> n == name + _ -> \_ -> True + prov_fn name = Imported [imp_spec] + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } + item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n + add _ env = env + +findChildren :: NameEnv [Name] -> Name -> [Name] +findChildren env n = lookupNameEnv env n `orElse` [] + +lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)] +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + -- = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items + = map doOne rdr_items + where + doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of + Just n -> Just (L l n) + Nothing -> Nothing + + kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids] + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail + +{- +************************************************************************ +* * +\subsection{Export list processing} +* * +************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (Trac #5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +because F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +At one point I implemented a compromise: + * When constructing exports with no export list, or with module M( + module M ), we add the parent to the exports as well. + * But not when you see module M( f ), even if f is a + class method with a parent. + * Nor when you see module M( module N ), with N /= M. + +But the compromise seemed too much of a hack, so we backed it out. +You just have to use an explicit export list: + module M( F(..) ) where ... +-} + +type ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports + = ([LIE Name], -- Export items with Names + ExportOccMap, -- Tracks exported occurrence names + [AvailInfo]) -- The accumulated exported stuff + -- Not nub'd! + +emptyExportAccum :: ExportAccum +emptyExportAccum = ([], emptyOccEnv, []) + +type ExportOccMap = OccEnv (Name, IE RdrName) + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name + +rnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list + -> TcGblEnv + -> RnM TcGblEnv + + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +rnExports explicit_mod exports + tcg_env@(TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports }) + = unsetWOptM Opt_WarnWarningsDeprecations $ + -- Do not report deprecations arising from the export + -- list, to avoid bleating about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + do { + -- If the module header is omitted altogether, then behave + -- as if the user had written "module Main(main) where..." + -- EXCEPT in interactive mode, when we behave as if he had + -- written "module Main where ..." + -- Reason: don't want to complain about 'main' not in scope + -- in interactive mode + ; dflags <- getDynFlags + ; let real_exports + | explicit_mod = exports + | ghcLink dflags == LinkInMemory = Nothing + | otherwise + = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + + ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; let final_avails = nubAvails avails -- Combine families + + ; traceRn (text "rnExports: Exports:" <+> ppr final_avails) + + ; return (tcg_env { tcg_exports = final_avails, + tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly (availsToNameSet final_avails) }) } + +exports_from_avail :: Maybe (Located [LIE RdrName]) + -- Nothing => no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -> Module + -> RnM (Maybe [LIE Name], [AvailInfo]) + +exports_from_avail Nothing rdr_env _imports _this_mod + = -- The same as (module M) where M is the current module name, + -- so that's how we handle it. + let + avails = [ greExportAvail gre + | gre <- globalRdrEnvElts rdr_env + , isLocalGRE gre ] + in + return (Nothing, avails) + +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod + = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items + return (Just ie_names, exports) + where + do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum + do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + + kids_env :: NameEnv [Name] -- Maps a parent to its in-scope children + kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + + imported_modules = [ qual_name + | xs <- moduleEnvElts $ imp_mods imports, + (qual_name, _, _, _) <- xs ] + + exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum + exports_from_item acc@(ie_names, occs, exports) + (L loc (IEModuleContents (L lm mod))) + | let earlier_mods = [ mod + | (L _ (IEModuleContents (L _ mod))) <- ie_names ] + , mod `elem` earlier_mods -- Duplicate export of M + = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; + warnIf warn_dup_exports (dupModuleExport mod) ; + return acc } + + | otherwise + = do { implicit_prelude <- xoptM Opt_ImplicitPrelude + ; warnDodgyExports <- woptM Opt_WarnDodgyExports + ; let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gres = filter (isModuleExported implicit_prelude mod) + (globalRdrEnvElts rdr_env) + ; new_exports = map greExportAvail gres + ; names = map gre_name gres } + + ; checkErr exportValid (moduleNotImported mod) + ; warnIf (warnDodgyExports && exportValid && null names) + (nullModuleExport mod) + + ; addUsedRdrNames (concat [ [mkRdrQual mod occ, mkRdrUnqual occ] + | occ <- map nameOccName names ]) + -- The qualified and unqualified version of all of + -- these names are, in effect, used by this export + + ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; traceRn (vcat [ text "export mod" <+> ppr mod + , ppr new_exports ]) + ; return (L loc (IEModuleContents (L lm mod)) : ie_names, + occs', new_exports ++ exports) } + + exports_from_item acc@(lie_names, occs, exports) (L loc ie) + | isDoc ie + = do new_ie <- lookup_doc_ie ie + return (L loc new_ie : lie_names, occs, exports) + + | otherwise + = do (new_ie, avail) <- lookup_ie ie + if isUnboundName (ieName new_ie) + then return acc -- Avoid error cascade + else do + + occs' <- check_occs ie occs (availNames avail) + + return (L loc new_ie : lie_names, occs', avail : exports) + + ------------- + lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) + lookup_ie (IEVar (L l rdr)) + = do gre <- lookupGreRn rdr + return (IEVar (L l (gre_name gre)), greExportAvail gre) + + lookup_ie (IEThingAbs (L l rdr)) + = do gre <- lookupGreRn rdr + let name = gre_name gre + avail = greExportAvail gre + return (IEThingAbs (L l name), avail) + + lookup_ie ie@(IEThingAll (L l rdr)) + = do name <- lookupGlobalOccRn rdr + let kids = findChildren kids_env name + addUsedKids rdr kids + warnDodgyExports <- woptM Opt_WarnDodgyExports + when (null kids) $ + if isTyConName name + then when warnDodgyExports $ addWarn (dodgyExportWarn name) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (exportItemErr ie) + + return (IEThingAll (L l name), AvailTC name (name:kids)) + + lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs) + = do name <- lookupGlobalOccRn rdr + if isUnboundName name + then return (IEThingWith (L l name) [], AvailTC name [name]) + else do + let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs + if any isNothing mb_names + then do addErr (exportItemErr ie) + return (IEThingWith (L l name) [], AvailTC name [name]) + else do let names = catMaybes mb_names + addUsedKids rdr (map unLoc names) + return (IEThingWith (L l name) names + , AvailTC name (name:map unLoc names)) + + lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + + ------------- + lookup_doc_ie :: IE RdrName -> RnM (IE Name) + lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc + return (IEGroup lev rn_doc) + lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc + return (IEDoc rn_doc) + lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) + lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier + + -- In an export item M.T(A,B,C), we want to treat the uses of + -- A,B,C as if they were M.A, M.B, M.C + addUsedKids parent_rdr kid_names + = addUsedRdrNames $ map (mk_kid_rdr . nameOccName) kid_names + where + mk_kid_rdr = case isQual_maybe parent_rdr of + Nothing -> mkRdrUnqual + Just (modName, _) -> mkRdrQual modName + +isDoc :: IE RdrName -> Bool +isDoc (IEDoc _) = True +isDoc (IEDocNamed _) = True +isDoc (IEGroup _ _) = True +isDoc _ = False + +------------------------------- +isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool +-- True if the thing is in scope *both* unqualified, *and* with qualifier M +isModuleExported implicit_prelude mod (GRE { gre_name = name, gre_prov = prov }) + | implicit_prelude && isBuiltInSyntax name = False + -- Optimisation: filter out names for built-in syntax + -- They just clutter up the environment (esp tuples), and the parser + -- will generate Exact RdrNames for them, so the cluttered + -- envt is no use. To avoid doing this filter all the time, + -- we use -XNoImplicitPrelude as a clue that the filter is + -- worth while. Really, it's only useful for GHC.Base and GHC.Tuple. + -- + -- It's worth doing because it makes the environment smaller for + -- every module that imports the Prelude + | otherwise + = case prov of + LocalDef | Just name_mod <- nameModule_maybe name + -> moduleName name_mod == mod + | otherwise -> False + Imported is -> any unQualSpecOK is && any (qualSpecOK mod) is + +------------------------------- +check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs ie occs names -- 'names' are the entities specifed by 'ie' + = foldlM check occs names + where + check occs name + = case lookupOccEnv occs name_occ of + Nothing -> return (extendOccEnv occs name_occ (name, ie)) + + Just (name', ie') + | name == name' -- Duplicate export + -- But we don't want to warn if the same thing is exported + -- by two different module exports. See ticket #4478. + -> do unless (dupExport_ok name ie ie') $ do + warn_dup_exports <- woptM Opt_WarnDuplicateExports + warnIf warn_dup_exports (dupExportWarn name_occ ie ie') + return occs + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env name' name ie' ie) ; + return occs } + where + name_occ = nameOccName name + + +dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool +-- The Name is exported by both IEs. Is that ok? +-- "No" iff the name is mentioned explicitly in both IEs +-- or one of the IEs mentions the name *alone* +-- "Yes" otherwise +-- +-- Examples of "no": module M( f, f ) +-- module M( fmap, Functor(..) ) +-- module M( module Data.List, head ) +-- +-- Example of "yes" +-- module M( module A, module B ) where +-- import A( f ) +-- import B( f ) +-- +-- Example of "yes" (Trac #2436) +-- module M( C(..), T(..) ) where +-- class C a where { data T a } +-- instace C Int where { data T Int = TInt } +-- +-- Example of "yes" (Trac #2436) +-- module Foo ( T ) where +-- data family T a +-- module Bar ( T(..), module Foo ) where +-- import Foo +-- data instance T Int = TInt + +dupExport_ok n ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents _) = False -- module M + explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r) -- T(..) + explicit_in _ = True + + single (IEVar {}) = True + single (IEThingAbs {}) = True + single _ = False + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list + -> TcGblEnv -> RnM () +reportUnusedNames _export_decls gbl_env + = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) + ; warnUnusedImportDecls gbl_env + ; warnUnusedTopBinds unused_locals } + where + used_names :: NameSet + used_names = findUses (tcg_dus gbl_env) emptyNameSet + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used used_names) defined_names + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names (GRE {gre_name = name}) + = name `elemNameSet` used_names + || any (`elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: [GlobalRdrElt] + unused_locals = filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports +-} + +type ImportDeclUsage + = ( LImportDecl Name -- The import declaration + , [AvailInfo] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> RnM () +warnUnusedImportDecls gbl_env + = do { uses <- readMutVar (tcg_used_rdrnames gbl_env) + ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports rdr_env (Set.elems uses) + + ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses) + , ptext (sLit "Import usage") <+> ppr usage]) + ; whenWOptM Opt_WarnUnusedImports $ + mapM_ warnUnusedImport usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports usage } + +{- +Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data struture records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (Trac #7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The AvailInfos are the things imported from that decl (just a list, +not normalised). +-} + +type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap] + +findImportUsage :: [LImportDecl Name] + -> GlobalRdrEnv + -> [RdrName] + -> [ImportDeclUsage] + +findImportUsage imports rdr_env rdrs + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs + + unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) + = (decl, nubAvails used_avails, nameSetElems unused_imps) + where + used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` [] + -- srcSpanEnd: see Note [The ImportMap] + used_names = availsToNameSet used_avails + used_parents = mkNameSet [n | AvailTC n _ <- used_avails] + + unused_imps -- Not trivial; see eg Trac #7454 + = case imps of + Just (False, L _ imp_ies) -> + foldr (add_unused . unLoc) emptyNameSet imp_ies + _other -> emptyNameSet -- No explicit import list => no unused-name list + + add_unused :: IE Name -> NameSet -> NameSet + add_unused (IEVar (L _ n)) acc = add_unused_name n acc + add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc + add_unused (IEThingAll (L _ n)) acc = add_unused_all n acc + add_unused (IEThingWith (L _ p) ns) acc + = add_unused_with p (map unLoc ns) acc + add_unused _ acc = acc + + add_unused_name n acc + | n `elemNameSet` used_names = acc + | otherwise = acc `extendNameSet` n + add_unused_all n acc + | n `elemNameSet` used_names = acc + | n `elemNameSet` used_parents = acc + | otherwise = acc `extendNameSet` n + add_unused_with p ns acc + | all (`elemNameSet` acc1) ns = add_unused_name p acc1 + | otherwise = acc1 + where + acc1 = foldr add_unused_name acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + + +extendImportMap :: GlobalRdrEnv -> RdrName -> ImportMap -> ImportMap +-- For a used RdrName, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +extendImportMap rdr_env rdr imp_map + | [gre] <- lookupGRE_RdrName rdr rdr_env + , Imported imps <- gre_prov gre + = add_imp gre (bestImport imps) imp_map + | otherwise + = imp_map + where + add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap + add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map + = Map.insertWith add decl_loc [avail] imp_map + where + add _ avails = avail : avails -- add is really just a specialised (++) + decl_loc = srcSpanEnd (is_dloc imp_decl_spec) + -- For srcSpanEnd see Note [The ImportMap] + avail = greExportAvail gre + + bestImport :: [ImportSpec] -> ImportSpec + bestImport iss + = case partition isImpAll iss of + ([], imp_somes) -> textuallyFirst imp_somes + (imp_alls, _) -> textuallyFirst imp_alls + + textuallyFirst :: [ImportSpec] -> ImportSpec + textuallyFirst iss = case sortWith (is_dloc . is_decl) iss of + [] -> pprPanic "textuallyFirst" (ppr iss) + (is:_) -> is + + isImpAll :: ImportSpec -> Bool + isImpAll (ImpSpec { is_item = ImpAll }) = True + isImpAll _other = False + +warnUnusedImport :: ImportDeclUsage -> RnM () +warnUnusedImport (L loc decl, used, unused) + | Just (False,L _ []) <- ideclHiding decl + = return () -- Do not warn for 'import M()' + + | Just (True, L _ hides) <- ideclHiding decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () -- Note [Do not warn about Prelude hiding] + | null used = addWarnAt loc msg1 -- Nothing used; drop entire decl + | null unused = return () -- Everything imported is used; nop + | otherwise = addWarnAt loc msg2 -- Some imports are unused + where + msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used, + nest 2 (ptext (sLit "except perhaps to import instances from") + <+> quotes pp_mod), + ptext (sLit "To import instances alone, use:") + <+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ] + msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), + text "from module" <+> quotes pp_mod <+> pp_not_used] + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | ideclQualified decl = text "qualified" + | otherwise = Outputable.empty + pp_mod = ppr (unLoc (ideclName decl)) + pp_not_used = text "is redundant" + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (Trac #9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not disard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +printMinimalImports :: [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports imports_w_usage + = do { imports' <- mapM mk_minimal imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ + do { h <- openFile (mkFilename dflags this_mod) WriteMode + ; printForUser dflags h neverQualify (vcat (map ppr imports')) } + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d basefn + | otherwise = basefn + where + basefn = moduleNameString (moduleName this_mod) ++ ".imports" + + mk_minimal (L l decl, used, unused) + | null unused + , Just (False, _) <- ideclHiding decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = mb_pkg } = decl + ; ifaces <- loadSrcInterface doc mod_name is_boot mb_pkg + ; let lies = map (L l) (concatMap (to_ie ifaces) used) + ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: [ModIface] -> AvailInfo -> [IE Name] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie _ (Avail n) + = [IEVar (noLoc n)] + to_ie _ (AvailTC n [m]) + | n==m = [IEThingAbs (noLoc n)] + to_ie ifaces (AvailTC n ns) + = case [xs | iface <- ifaces + , AvailTC x xs <- mi_exports iface + , x == n + , x `elem` xs -- Note [Partial export] + ] of + [xs] | all_used xs -> [IEThingAll (noLoc n)] + | otherwise -> [IEThingWith (noLoc n) + (map noLoc (filter (/= n) ns))] + _other -> map (IEVar . noLoc) ns + where + all_used avail_occs = all (`elem` ns) avail_occs + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the (x `elem` xs) test when deciding what to generate. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +qualImportItemErr :: RdrName -> SDoc +qualImportItemErr rdr + = hang (ptext (sLit "Illegal qualified name in import item:")) + 2 (ppr rdr) + +badImportItemErrStd :: IsBootInterface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrStd is_boot decl_spec ie + = sep [ptext (sLit "Module"), quotes (ppr (is_mod decl_spec)), source_import, + ptext (sLit "does not export"), quotes (ppr ie)] + where + source_import | is_boot = ptext (sLit "(hi-boot interface)") + | otherwise = Outputable.empty + +badImportItemErrDataCon :: OccName + -> IsBootInterface + -> ImpDeclSpec + -> IE RdrName + -> SDoc +badImportItemErrDataCon dataType_occ is_boot decl_spec ie + = vcat [ ptext (sLit "In module") + <+> quotes (ppr (is_mod decl_spec)) + <+> source_import <> colon + , nest 2 $ quotes datacon + <+> ptext (sLit "is a data constructor of") + <+> quotes dataType + , ptext (sLit "To import it use") + , nest 2 $ quotes (ptext (sLit "import")) + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> parens_sp datacon) + , ptext (sLit "or") + , nest 2 $ quotes (ptext (sLit "import")) + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> ptext (sLit "(..)")) + ] + where + datacon_occ = rdrNameOcc $ ieName ie + datacon = parenSymOcc datacon_occ (ppr datacon_occ) + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + source_import | is_boot = ptext (sLit "(hi-boot interface)") + | otherwise = Outputable.empty + parens_sp d = parens (space <> d <> space) -- T( f,g ) + +badImportItemErr :: IsBootInterface + -> ImpDeclSpec + -> IE RdrName + -> [AvailInfo] + -> SDoc +badImportItemErr is_boot decl_spec ie avails + = case find checkIfDataCon avails of + Just con -> badImportItemErrDataCon (availOccName con) is_boot decl_spec ie + Nothing -> badImportItemErrStd is_boot decl_spec ie + where + checkIfDataCon (AvailTC _ ns) = + case find (\n -> importedFS == nameOccNameFS n) ns of + Just n -> isDataConName n + Nothing -> False + checkIfDataCon _ = False + availOccName = nameOccName . availName + nameOccNameFS = occNameFS . nameOccName + importedFS = occNameFS . rdrNameOcc $ ieName ie + +illegalImportItemErr :: SDoc +illegalImportItemErr = ptext (sLit "Illegal import item") + +dodgyImportWarn :: RdrName -> SDoc +dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item +dodgyExportWarn :: Name -> SDoc +dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item + +dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc +dodgyMsg kind tc + = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") + <+> quotes (ppr (IEThingAll (noLoc tc))) + <+> ptext (sLit "suggests that"), + quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"), + ptext (sLit "but it has none") ] + +exportItemErr :: IE RdrName -> SDoc +exportItemErr export_item + = sep [ ptext (sLit "The export item") <+> quotes (ppr export_item), + ptext (sLit "attempts to export constructors or class methods that are not visible here") ] + +exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName + -> MsgDoc +exportClashErr global_env name1 name2 ie1 ie2 + = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] + where + occ = nameOccName name1 + ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> ptext (sLit "exports") <+> + quotes (ppr name)) + 2 (pprNameProvenance (get_gre name))) + + -- get_gre finds a GRE for the Name, so that we can show its provenance + get_gre name + = case lookupGRE_Name global_env name of + (gre:_) -> gre + [] -> pprPanic "exportClashErr" (ppr name) + get_loc name = greSrcSpan (get_gre name) + (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 + then (name1, ie1, name2, ie2) + else (name2, ie2, name1, ie1) + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre + | Imported (is:_) <- gre_prov gre = is_dloc (is_decl is) + | otherwise = name_span + where + name_span = nameSrcSpan (gre_name gre) + +addDupDeclErr :: [Name] -> TcRn () +addDupDeclErr [] + = panic "addDupDeclErr: empty list" +addDupDeclErr names@(name : _) + = addErrAt (getSrcSpan (last sorted_names)) $ + -- Report the error at the later location + vcat [ptext (sLit "Multiple declarations of") <+> + quotes (ppr (nameOccName name)), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + ptext (sLit "Declared at:") <+> + vcat (map (ppr . nameSrcLoc) sorted_names)] + where + sorted_names = sortWith nameSrcLoc names + +dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + ptext (sLit "is exported by"), quotes (ppr ie1), + ptext (sLit "and"), quotes (ppr ie2)] + +dupModuleExport :: ModuleName -> SDoc +dupModuleExport mod + = hsep [ptext (sLit "Duplicate"), + quotes (ptext (sLit "Module") <+> ppr mod), + ptext (sLit "in export list")] + +moduleNotImported :: ModuleName -> SDoc +moduleNotImported mod + = ptext (sLit "The export item `module") <+> ppr mod <> + ptext (sLit "' is not imported") + +nullModuleExport :: ModuleName -> SDoc +nullModuleExport mod + = ptext (sLit "The export item `module") <+> ppr mod <> ptext (sLit "' exports nothing") + +missingImportListWarn :: ModuleName -> SDoc +missingImportListWarn mod + = ptext (sLit "The module") <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + +missingImportListItem :: IE RdrName -> SDoc +missingImportListItem ie + = ptext (sLit "The import item") <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") + +moduleWarn :: ModuleName -> WarningTxt -> SDoc +moduleWarn mod (WarningTxt _ txt) + = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), + nest 2 (vcat (map ppr txt)) ] +moduleWarn mod (DeprecatedTxt _ txt) + = sep [ ptext (sLit "Module") <+> quotes (ppr mod) + <+> ptext (sLit "is deprecated:"), + nest 2 (vcat (map ppr txt)) ] + +packageImportErr :: SDoc +packageImportErr + = ptext (sLit "Package-qualified imports are not enabled; use PackageImports") + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName :: RdrName -> TcRn () +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon :: RdrName -> SDoc +badDataCon name + = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs new file mode 100644 index 00000000..cdd180bc --- /dev/null +++ b/compiler/rename/RnPat.hs @@ -0,0 +1,754 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnPat]{Renaming of patterns} + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} + +module RnPat (-- main entry points + rnPat, rnPats, rnBindPat, rnPatAndThen, + + NameMaker, applyNameMaker, -- a utility for making names: + localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, + -- sometimes we want to make top (qualified) names. + isTopRecNameMaker, + + rnHsRecFields, HsRecFieldContext(..), + + -- CpsRn monad + CpsRn, liftCps, + + -- Literals + rnLit, rnOverLit, + + -- Pattern Error messages that are also used elsewhere + checkTupSize, patSigErr + ) where + +-- ENH: thin imports to only what is necessary for patterns + +import {-# SOURCE #-} RnExpr ( rnLExpr ) +import {-# SOURCE #-} RnSplice ( rnSplicePat ) +import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) + +#include "HsVersions.h" + +import HsSyn +import TcRnMonad +import TcHsSyn ( hsOverLitName ) +import RnEnv +import RnTypes +import DynFlags +import PrelNames +import TyCon ( tyConName ) +import ConLike +import DataCon ( dataConTyCon ) +import TypeRep ( TyThing(..) ) +import Name +import NameSet +import RdrName +import BasicTypes +import Util +import ListSetOps ( removeDups ) +import Outputable +import SrcLoc +import FastString +import Literal ( inCharRange ) +import TysWiredIn ( nilDataCon ) +import DataCon ( dataConName ) +import Control.Monad ( when, liftM, ap ) +import Data.Ratio + +{- +********************************************************* +* * + The CpsRn Monad +* * +********************************************************* + +Note [CpsRn monad] +~~~~~~~~~~~~~~~~~~ +The CpsRn monad uses continuation-passing style to support this +style of programming: + + do { ... + ; ns <- bindNames rs + ; ...blah... } + + where rs::[RdrName], ns::[Name] + +The idea is that '...blah...' + a) sees the bindings of ns + b) returns the free variables it mentions + so that bindNames can report unused ones + +In particular, + mapM rnPatAndThen [p1, p2, p3] +has a *left-to-right* scoping: it makes the binders in +p1 scope over p2,p3. +-} + +newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) } + -- See Note [CpsRn monad] + +instance Functor CpsRn where + fmap = liftM + +instance Applicative CpsRn where + pure = return + (<*>) = ap + +instance Monad CpsRn where + return x = CpsRn (\k -> k x) + (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) + +runCps :: CpsRn a -> RnM (a, FreeVars) +runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) + +liftCps :: RnM a -> CpsRn a +liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) + +liftCpsFV :: RnM (a, FreeVars) -> CpsRn a +liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing + ; (r,fvs2) <- k v + ; return (r, fvs1 `plusFV` fvs2) }) + +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +-- Set the location, and also wrap it around the value returned +wrapSrcSpanCps fn (L loc a) + = CpsRn (\k -> setSrcSpan loc $ + unCpsRn (fn a) $ \v -> + k (L loc v)) + +lookupConCps :: Located RdrName -> CpsRn (Located Name) +lookupConCps con_rdr + = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr + ; (r, fvs) <- k con_name + ; return (r, addOneFV fvs (unLoc con_name)) }) + -- We add the constructor name to the free vars + -- See Note [Patterns are uses] + +{- +Note [Patterns are uses] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + module Foo( f, g ) where + data T = T1 | T2 + + f T1 = True + f T2 = False + + g _ = T1 + +Arguably we should report T2 as unused, even though it appears in a +pattern, because it never occurs in a constructed position. See +Trac #7336. +However, implementing this in the face of pattern synonyms would be +less straightforward, since given two pattern synonyms + + pattern P1 <- P2 + pattern P2 <- () + +we need to observe the dependency between P1 and P2 so that type +checking can be done in the correct order (just like for value +bindings). Dependencies between bindings is analyzed in the renamer, +where we don't know yet whether P2 is a constructor or a pattern +synonym. So for now, we do report conid occurrences in patterns as +uses. + +********************************************************* +* * + Name makers +* * +********************************************************* + +Externally abstract type of name makers, +which is how you go from a RdrName to a Name +-} + +data NameMaker + = LamMk -- Lambdas + Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -fwarn-unused-matches is on) + + | LetMk -- Let bindings, incl top level + -- Do *not* check for unused bindings + TopLevelFlag + MiniFixityEnv + +topRecNameMaker :: MiniFixityEnv -> NameMaker +topRecNameMaker fix_env = LetMk TopLevel fix_env + +isTopRecNameMaker :: NameMaker -> Bool +isTopRecNameMaker (LetMk TopLevel _) = True +isTopRecNameMaker _ = False + +localRecNameMaker :: MiniFixityEnv -> NameMaker +localRecNameMaker fix_env = LetMk NotTopLevel fix_env + +matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt GhciStmtCtxt -> False + -- also, don't warn in pattern quotes, as there + -- is no RHS where the variables can be used! + ThPatQuote -> False + _ -> True + +rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName) + -> CpsRn (HsWithBndrs Name (LHsType Name)) +rnHsSigCps sig + = CpsRn (rnHsBndrSig PatCtx sig) + +newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) +newPatLName name_maker rdr_name@(L loc _) + = do { name <- newPatName name_maker rdr_name + ; return (L loc name) } + +newPatName :: NameMaker -> Located RdrName -> CpsRn Name +newPatName (LamMk report_unused) rdr_name + = CpsRn (\ thing_inside -> + do { name <- newLocalBndrRn rdr_name + ; (res, fvs) <- bindLocalNames [name] (thing_inside name) + ; when report_unused $ warnUnusedMatches [name] fvs + ; return (res, name `delFV` fvs) }) + +newPatName (LetMk is_top fix_env) rdr_name + = CpsRn (\ thing_inside -> + do { name <- case is_top of + NotTopLevel -> newLocalBndrRn rdr_name + TopLevel -> newTopSrcBinder rdr_name + ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here + -- See Note [View pattern usage] + addLocalFixities fix_env [name] $ + thing_inside name }) + + -- Note: the bindLocalNames is somewhat suspicious + -- because it binds a top-level name as a local name. + -- however, this binding seems to work, and it only exists for + -- the duration of the patterns and the continuation; + -- then the top-level name is added to the global env + -- before going on to the RHSes (see RnSource.lhs). + +{- +Note [View pattern usage] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let (r, (r -> x)) = x in ... +Here the pattern binds 'r', and then uses it *only* in the view pattern. +We want to "see" this use, and in let-bindings we collect all uses and +report unused variables at the binding level. So we must use bindLocalNames +here, *not* bindLocalNameFV. Trac #3943. + +********************************************************* +* * + External entry points +* * +********************************************************* + +There are various entry points to renaming patterns, depending on + (1) whether the names created should be top-level names or local names + (2) whether the scope of the names is entirely given in a continuation + (e.g., in a case or lambda, but not in a let or at the top-level, + because of the way mutually recursive bindings are handled) + (3) whether the a type signature in the pattern can bind + lexically-scoped type variables (for unpacking existential + type vars in data constructors) + (4) whether we do duplicate and unused variable checking + (5) whether there are fixity declarations associated with the names + bound by the patterns that need to be brought into scope with them. + + Rather than burdening the clients of this module with all of these choices, + we export the three points in this design space that we actually need: +-} + +-- ----------- Entry point 1: rnPats ------------------- +-- Binds local names; the scope of the bindings is entirely in the thing_inside +-- * allows type sigs to bind type vars +-- * local namemaker +-- * unused and duplicate checking +-- * no fixities +rnPats :: HsMatchContext Name -- for error messages + -> [LPat RdrName] + -> ([LPat Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPats ctxt pats thing_inside + = do { envs_before <- getRdrEnvs + + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + { -- Check for duplicated and shadowed names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + ; addErrCtxt doc_pat $ + checkDupAndShadowedNames envs_before $ + collectPatsBinders pats' + ; thing_inside pats' } } + where + doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt + +rnPat :: HsMatchContext Name -- for error messages + -> LPat RdrName + -> (LPat Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Variables bound by pattern do not + -- appear in the result FreeVars +rnPat ctxt pat thing_inside + = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') + +applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) +applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) + ; return n } + +-- ----------- Entry point 2: rnBindPat ------------------- +-- Binds local names; in a recursive scope that involves other bound vars +-- e.g let { (x, Just y) = e1; ... } in ... +-- * does NOT allows type sig to bind type vars +-- * local namemaker +-- * no unused and duplicate checking +-- * fixities might be coming in +rnBindPat :: NameMaker + -> LPat RdrName + -> RnM (LPat Name, FreeVars) + -- Returned FreeVars are the free variables of the pattern, + -- of course excluding variables bound by this pattern + +rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) + +{- +********************************************************* +* * + The main event +* * +********************************************************* +-} + +-- ----------- Entry point 3: rnLPatAndThen ------------------- +-- General version: parametrized by how you make new names + +rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name] +rnLPatsAndThen mk = mapM (rnLPatAndThen mk) + -- Despite the map, the monad ensures that each pattern binds + -- variables that may be mentioned in subsequent patterns in the list + +-------------------- +-- The workhorse +rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name) +rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat + +rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name) +rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) +rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } +rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } +rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } +rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat name) } + -- we need to bind pattern variables for view pattern expressions + -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) + +rnPatAndThen mk (SigPatIn pat sig) + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsSigCps sig + ; pat' <- rnLPatAndThen mk pat + ; return (SigPatIn pat' sig') } + +rnPatAndThen mk (LitPat lit) + | HsString src s <- lit + = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings) + ; if ovlStr + then rnPatAndThen mk + (mkNPat (noLoc (mkHsIsString src s placeHolderType)) + Nothing) + else normal_lit } + | otherwise = normal_lit + where + normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } + +rnPatAndThen _ (NPat (L l lit) mb_neg _eq) + = do { lit' <- liftCpsFV $ rnOverLit lit + ; mb_neg' <- liftCpsFV $ case mb_neg of + Nothing -> return (Nothing, emptyFVs) + Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName + ; return (Just neg, fvs) } + ; eq' <- liftCpsFV $ lookupSyntaxName eqName + ; return (NPat (L l lit') mb_neg' eq') } + +rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _) + = do { new_name <- newPatName mk rdr + ; lit' <- liftCpsFV $ rnOverLit lit + ; minus <- liftCpsFV $ lookupSyntaxName minusName + ; ge <- liftCpsFV $ lookupSyntaxName geName + ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) + (L l lit') ge minus) } + -- The Report says that n+k patterns must be in Integral + +rnPatAndThen mk (AsPat rdr pat) + = do { new_name <- newPatLName mk rdr + ; pat' <- rnLPatAndThen mk pat + ; return (AsPat new_name pat') } + +rnPatAndThen mk p@(ViewPat expr pat _ty) + = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns + ; checkErr vp_flag (badViewPat p) } + -- Because of the way we're arranging the recursive calls, + -- this will be in the right context + ; expr' <- liftCpsFV $ rnLExpr expr + ; pat' <- rnLPatAndThen mk pat + -- Note: at this point the PreTcType in ty can only be a placeHolder + -- ; return (ViewPat expr' pat' ty) } + ; return (ViewPat expr' pat' placeHolderType) } + +rnPatAndThen mk (ConPatIn con stuff) + -- rnConPatAndThen takes care of reconstructing the pattern + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM Opt_OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) + else rnConPatAndThen mk con stuff} + False -> rnConPatAndThen mk con stuff + +rnPatAndThen mk (ListPat pats _ _) + = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; case opt_OverloadedLists of + True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + ; return (ListPat pats' placeHolderType + (Just (placeHolderType, to_list_name)))} + False -> return (ListPat pats' placeHolderType Nothing) } + +rnPatAndThen mk (PArrPat pats _) + = do { pats' <- rnLPatsAndThen mk pats + ; return (PArrPat pats' placeHolderType) } + +rnPatAndThen mk (TuplePat pats boxed _) + = do { liftCps $ checkTupSize (length pats) + ; pats' <- rnLPatsAndThen mk pats + ; return (TuplePat pats' boxed []) } + +rnPatAndThen mk (SplicePat splice) + = do { eith <- liftCpsFV $ rnSplicePat splice + ; case eith of -- See Note [rnSplicePat] in RnSplice + Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed + Right already_renamed -> return already_renamed } + +rnPatAndThen mk (QuasiQuotePat qq) + = do { pat <- liftCps $ runQuasiQuotePat qq + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ; rnPatAndThen mk (ParPat pat) } + +rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) + + +-------------------- +rnConPatAndThen :: NameMaker + -> Located RdrName -- the constructor + -> HsConPatDetails RdrName + -> CpsRn (Pat Name) + +rnConPatAndThen mk con (PrefixCon pats) + = do { con' <- lookupConCps con + ; pats' <- rnLPatsAndThen mk pats + ; return (ConPatIn con' (PrefixCon pats')) } + +rnConPatAndThen mk con (InfixCon pat1 pat2) + = do { con' <- lookupConCps con + ; pat1' <- rnLPatAndThen mk pat1 + ; pat2' <- rnLPatAndThen mk pat2 + ; fixity <- liftCps $ lookupFixityRn (unLoc con') + ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } + +rnConPatAndThen mk con (RecCon rpats) + = do { con' <- lookupConCps con + ; rpats' <- rnHsRecPatsAndThen mk con' rpats + ; return (ConPatIn con' (RecCon rpats')) } + +-------------------- +rnHsRecPatsAndThen :: NameMaker + -> Located Name -- Constructor + -> HsRecFields RdrName (LPat RdrName) + -> CpsRn (HsRecFields Name (LPat Name)) +rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) VarPat hs_rec_fields + ; flds' <- mapM rn_field (flds `zip` [1..]) + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } + where + rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') + (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' })) } + + -- Suppress unused-match reporting for fields introduced by ".." + nested_mk Nothing mk _ = mk + nested_mk (Just _) mk@(LetMk {}) _ = mk + nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n)) + +{- +************************************************************************ +* * + Record fields +* * +************************************************************************ +-} + +data HsRecFieldContext + = HsRecFieldCon Name + | HsRecFieldPat Name + | HsRecFieldUpd + +rnHsRecFields + :: forall arg. + HsRecFieldContext + -> (RdrName -> arg) -- When punning, use this to build a new field + -> HsRecFields RdrName (Located arg) + -> RnM ([LHsRecField Name (Located arg)], FreeVars) + +-- This surprisingly complicated pass +-- a) looks up the field name (possibly using disambiguation) +-- b) fills in puns and dot-dot stuff +-- When we we've finished, we've renamed the LHS, but not the RHS, +-- of each x=e binding + +rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) + = do { pun_ok <- xoptM Opt_RecordPuns + ; disambig_ok <- xoptM Opt_DisambiguateRecordFields + ; parent <- check_disambiguation disambig_ok mb_con + ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; mapM_ (addErr . dupFieldErr ctxt) dup_flds + ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + + -- Check for an empty record update e {} + -- NB: don't complain about e { .. }, because rn_dotdot has done that already + ; case ctxt of + HsRecFieldUpd | Nothing <- dotdot + , null flds + -> addErr emptyUpdateErr + _ -> return () + + ; let all_flds | null dotdot_flds = flds1 + | otherwise = flds1 ++ dotdot_flds + ; return (all_flds, mkFVs (getFieldIds all_flds)) } + where + mb_con = case ctxt of + HsRecFieldCon con | not (isUnboundName con) -> Just con + HsRecFieldPat con | not (isUnboundName con) -> Just con + _ {- update or isUnboundName con -} -> Nothing + -- The unbound name test is because if the constructor + -- isn't in scope the constructor lookup will add an error + -- add an error, but still return an unbound name. + -- We don't want that to screw up the dot-dot fill-in stuff. + + doc = case mb_con of + Nothing -> ptext (sLit "constructor field name") + Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) + + rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld + , hsRecFieldArg = arg + , hsRecPun = pun })) + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld + ; arg' <- if pun + then do { checkErr pun_ok (badPun fld) + ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } + else return arg + ; return (L l (HsRecField { hsRecFieldId = fld' + , hsRecFieldArg = arg' + , hsRecPun = pun })) } + + rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat + -> Maybe Name -- The constructor (Nothing for an update + -- or out of scope constructor) + -> [LHsRecField Name (Located arg)] -- Explicit fields + -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields + rn_dotdot Nothing _mb_con _flds -- No ".." at all + = return [] + rn_dotdot (Just {}) Nothing _flds -- ".." on record update + = do { case ctxt of + HsRecFieldUpd -> addErr badDotDotUpd + _ -> return () + ; return [] } + rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match + = ASSERT( n == length flds ) + do { loc <- getSrcSpanM -- Rather approximate + ; dd_flag <- xoptM Opt_RecordWildCards + ; checkErr dd_flag (needFlagDotDot ctxt) + ; (rdr_env, lcl_env) <- getRdrEnvs + ; con_fields <- lookupConstructorFields con + ; when (null con_fields) (addErr (badDotDotCon con)) + ; let present_flds = getFieldIds flds + parent_tc = find_tycon rdr_env con + + -- For constructor uses (but not patterns) + -- the arg should be in scope (unqualified) + -- ignoring the record field itself + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope fld + = rdr `elemLocalRdrEnv` lcl_env + || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env + , case gre_par gre of + ParentIs p -> p /= parent_tc + _ -> True ] + where + rdr = mkRdrUnqual (nameOccName fld) + + dot_dot_gres = [ head gres + | fld <- con_fields + , not (fld `elem` present_flds) + , let gres = lookupGRE_Name rdr_env fld + , not (null gres) -- Check field is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope fld + _other -> True ] + + ; addUsedRdrNames (map greRdrName dot_dot_gres) + ; return [ L loc (HsRecField + { hsRecFieldId = L loc fld + , hsRecFieldArg = L loc (mk_arg arg_rdr) + , hsRecPun = False }) + | gre <- dot_dot_gres + , let fld = gre_name gre + arg_rdr = mkRdrUnqual (nameOccName fld) ] } + + check_disambiguation :: Bool -> Maybe Name -> RnM Parent + -- When disambiguation is on, + check_disambiguation disambig_ok mb_con + | disambig_ok, Just con <- mb_con + = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) } + | otherwise = return NoParent + + find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -} + -- Return the parent *type constructor* of the data constructor + -- That is, the parent of the data constructor. + -- That's the parent to use for looking up record fields. + find_tycon env con + | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con + = tyConName (dataConTyCon dc) -- Special case for [], which is built-in syntax + -- and not in the GlobalRdrEnv (Trac #8448) + | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con + = p + + | otherwise + = pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con)) + + dup_flds :: [[RdrName]] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups compare (getFieldIds flds) + +getFieldIds :: [LHsRecField id arg] -> [id] +getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds + +needFlagDotDot :: HsRecFieldContext -> SDoc +needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, + ptext (sLit "Use RecordWildCards to permit this")] + +badDotDotCon :: Name -> SDoc +badDotDotCon con + = vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con) + , nest 2 (ptext (sLit "The constructor has no labelled fields")) ] + +badDotDotUpd :: SDoc +badDotDotUpd = ptext (sLit "You cannot use `..' in a record update") + +emptyUpdateErr :: SDoc +emptyUpdateErr = ptext (sLit "Empty record update") + +badPun :: Located RdrName -> SDoc +badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), + ptext (sLit "Use NamedFieldPuns to permit this")] + +dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc +dupFieldErr ctxt dups + = hsep [ptext (sLit "duplicate field name"), + quotes (ppr (head dups)), + ptext (sLit "in record"), pprRFC ctxt] + +pprRFC :: HsRecFieldContext -> SDoc +pprRFC (HsRecFieldCon {}) = ptext (sLit "construction") +pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern") +pprRFC (HsRecFieldUpd {}) = ptext (sLit "update") + +{- +************************************************************************ +* * +\subsubsection{Literals} +* * +************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. +-} + +rnLit :: HsLit -> RnM () +rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) +rnLit _ = return () + +-- Turn a Fractional-looking literal which happens to be an integer into an +-- Integer-looking literal. +generalizeOverLitVal :: OverLitVal -> OverLitVal +generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val})) + | denominator val == 1 = HsIntegral src (numerator val) +generalizeOverLitVal lit = lit + +rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) +rnOverLit origLit + = do { opt_NumDecimals <- xoptM Opt_NumDecimals + ; let { lit@(OverLit {ol_val=val}) + | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} + | otherwise = origLit + } + ; let std_name = hsOverLitName val + ; (from_thing_name, fvs) <- lookupSyntaxName std_name + ; let rebindable = case from_thing_name of + HsVar v -> v /= std_name + _ -> panic "rnOverLit" + ; return (lit { ol_witness = from_thing_name + , ol_rebindable = rebindable + , ol_type = placeHolderType }, fvs) } + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +patSigErr :: Outputable a => a -> SDoc +patSigErr ty + = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) + $$ nest 4 (ptext (sLit "Use ScopedTypeVariables to permit it")) + +bogusCharError :: Char -> SDoc +bogusCharError c + = ptext (sLit "character literal out of range: '\\") <> char c <> char '\'' + +badViewPat :: Pat RdrName -> SDoc +badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat, + ptext (sLit "Use ViewPatterns to enable view patterns")] diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs new file mode 100644 index 00000000..b4117e87 --- /dev/null +++ b/compiler/rename/RnSource.hs @@ -0,0 +1,1584 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnSource]{Main pass of renamer} +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module RnSource ( + rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} RnExpr( rnLExpr ) +import {-# SOURCE #-} RnSplice ( rnSpliceDecl ) +import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) + +import HsSyn +import RdrName +import RnTypes +import RnBinds +import RnEnv +import RnNames +import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) +import TcAnnotations ( annCtxt ) +import TcRnMonad + +import ForeignCall ( CCallTarget(..) ) +import Module +import HscTypes ( Warnings(..), plusWarns ) +import Class ( FunDep ) +import PrelNames ( isUnboundName ) +import Name +import NameSet +import NameEnv +import Avail +import Outputable +import Bag +import BasicTypes ( RuleName ) +import FastString +import SrcLoc +import DynFlags +import HscTypes ( HscEnv, hsc_dflags ) +import ListSetOps ( findDupsEq, removeDups ) +import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) +import Util ( mapSnd ) + +import Control.Monad +import Data.List( partition, sortBy ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable (traverse) +#endif +import Maybes( orElse, mapMaybe ) + +{- +@rnSourceDecl@ `renames' declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: +\begin{enumerate} +\item +Checks that tyvars are used properly. This includes checking +for undefined tyvars, and tyvars in contexts that are ambiguous. +(Some of this checking has now been moved to module @TcMonoType@, +since we don't have functional dependency information at this point.) +\item +Checks that all variable occurrences are defined. +\item +Checks the @(..)@ etc constraints in the export list. +\end{enumerate} +-} + +-- Brings the binders of the group into scope in the appropriate places; +-- does NOT assume that anything is in scope already +rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +-- Rename a HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_docs = docs }) + = do { + -- (A) Process the fixity declarations, creating a mapping from + -- FastStrings to FixItems. + -- Also checks for duplcates. + local_fix_env <- makeMiniFixityEnv fix_decls ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- Aso step (C) depends on datacons and record fields + -- + -- * Pattern synonyms, becuase they (and data constructors) + -- are needed for rnTopBindLHS (Trac #9889) + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + setEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (C) Extract the mapping from data constructors to field names and + -- extend the record field env. + -- This depends on the data constructors and field names being in + -- scope from (B) above + inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do { + + -- (D) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope, + -- and on (C) for resolving record wild cards. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + -- bind the LHSes (and their fixities) in the global rdr environment + let { val_binders = collectHsIdBinders new_lhs ; + -- Not pattern-synonym binders, because we did + -- them in step (B) + all_bndrs = extendNameSetList tc_bndrs val_binders ; + val_avails = map Avail val_binders } ; + traceRn (text "rnSrcDecls" <+> ppr val_avails) ; + (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; + setEnvs (tcg_env, tcl_env) $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn (text "Start rnTyClDecls") ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls extra_deps tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn (text "Start rnmono") ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ; + traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + + -- (H) Rename Everything else + + (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; + (rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; + (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs9) <- rnList rnSpliceDecl splice_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + last_tcg_env <- getGblEnv ; + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_vects = rn_vect_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7, src_fvs8, + src_fvs9] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + } ; + + traceRn (text "finish rnSrc" <+> ppr rn_group) ; + traceRn (text "finish Dus" <+> ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} + +-- some utils because we do this a bunch above +-- compute and install the new env +inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a +inNewEnv env cont = do e <- env + setGblEnv e $ cont e + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstM f) xs + +{- +********************************************************* +* * + HsDoc stuff +* * +********************************************************* +-} + +rnDocDecl :: DocDecl -> RnM DocDecl +rnDocDecl (DocCommentNext doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) + +{- +********************************************************* +* * + Source-code fixity declarations +* * +********************************************************* +-} + +rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] +-- Rename the fixity decls, so we can put +-- the renamed decls in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +-- +-- The returned FixitySigs are not actually used for anything, +-- except perhaps the GHCi API +rnSrcFixityDecls bndr_set fix_decls + = do fix_decls <- mapM rn_decl fix_decls + return (concat fix_decls) + where + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> can give fixity for class decls and record selectors + + rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) + rn_decl (L loc (FixitySig fnames fixity)) + = do names <- mapM lookup_one fnames + return [ L loc (FixitySig name fixity) + | name <- names ] + + lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one (L name_loc rdr_name) + = setSrcSpan name_loc $ + -- this lookup will fail if the definition isn't local + do names <- lookupLocalTcNames sig_ctxt what rdr_name + return [ L name_loc name | name <- names ] + what = ptext (sLit "fixity signature") + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings +rnSrcWarnDecls _ [] + = return NoWarnings + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } + where + decls = concatMap (\(L _ d) -> wd_warnings d) decls' + + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> Can give deprecations for class ops and record sels + + rn_deprec (Warning rdr_names txt) + -- ensures that the names are defined locally + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + rdr_names + ; return [(nameOccName name, txt) | name <- names] } + + what = ptext (sLit "deprecation") + + warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) + decls + +findDupRdrNames :: [Located RdrName] -> [[Located RdrName]] +findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + +-- look for duplicates among the OccNames; +-- we check that the names are defined above +-- invt: the lists returned by findDupsEq always have at least two elements + +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl (L loc _) rdr_name + = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) +rnAnnDecl ann@(HsAnnotation s provenance expr) + = addErrCtxt (annCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; (expr', expr_fvs) <- setStage (Splice False) $ + rnLExpr expr + ; return (HsAnnotation s provenance' expr', + provenance_fvs `plusFV` expr_fvs) } + +rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance provenance = do + provenance' <- traverse lookupTopBndrRn provenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) +rnDefaultDecl (DefaultDecl tys) + = do { (tys', fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl tys', fvs) } + where + doc_str = DefaultDeclCtx + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) +rnHsForeignDecl (ForeignImport name ty _ spec) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRn name + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let packageKey = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageKey spec + + ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) } + +rnHsForeignDecl (ForeignExport name ty _ spec) + = do { name' <- lookupLocatedOccRn name + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty + ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundry we'll still +-- know where they're from. +-- +patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport +patchForeignImport packageKey (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec packageKey spec) src + +patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec +patchCImportSpec packageKey spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget packageKey callTarget + _ -> spec + +patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget +patchCCallTarget packageKey callTarget = + case callTarget of + StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi + ; return (TyFamInstD { tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi + ; return (DataFamInstD { dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { (cid', fvs) <- rnClsInstDecl cid + ; return (ClsInstD { cid_inst = cid' }, fvs) } + +rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) +rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag + , cid_datafam_insts = adts }) + -- Used for both source and interface file decls + = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty + ; case splitLHsInstDeclTy_maybe inst_ty' of { + Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds + , cid_sigs = [], cid_tyfam_insts = [] + , cid_overlap_mode = oflag + , cid_datafam_insts = [] } + , inst_fvs) ; + Just (inst_tyvars, _, L _ cls,_) -> + + do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + ktv_names = hsLKiTyVarNames inst_tyvars + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) + ; ((ats', adts', other_sigs'), more_fvs) + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts + ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs + ; return ( (ats', adts', other_sigs') + , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) } + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $ + rnMethodBinds cls (mkSigTvFn other_sigs') + mbinds + + -- Rename the SPECIALISE instance pramas + -- Annoyingly the type variables are not in scope here, + -- so that instance Eq a => Eq (T a) where + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + -- works OK. That's why we did the partition game above + -- + ; (spec_inst_prags', spec_inst_fvs) + <- renameSigs (InstDeclCtxt cls) spec_inst_prags + + ; let uprags' = spec_inst_prags' ++ other_sigs' + all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` spec_inst_fvs + `plusFV` inst_fvs + ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag + , cid_datafam_insts = adts' }, + all_fvs) } } } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). + +rnFamInstDecl :: HsDocContext + -> Maybe (Name, [Name]) + -> Located RdrName + -> [LHsType RdrName] + -> rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs', + FreeVars) +rnFamInstDecl doc mb_cls tycon pats payload rnPayload + = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon + ; let loc = case pats of + [] -> pprPanic "rnFamInstDecl" (ppr tycon) + (L loc _ : []) -> loc + (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) + (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats + + + ; rdr_env <- getLocalRdrEnv + ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names + ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names + -- All the free vars of the family patterns + -- with a sensible binding location + ; ((pats', payload'), fvs) + <- bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ + do { (pats', pat_fvs) <- rnLHsTypes doc pats + ; (payload', rhs_fvs) <- rnPayload doc payload + + -- See Note [Renaming associated types] + ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names + bad_tvs = case mb_cls of + Nothing -> [] + Just (_,cls_tkvs) -> filter is_bad cls_tkvs + + is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs + && not (cls_tkv `elemNameSet` lhs_names) + + ; unless (null bad_tvs) (badAssocRhs bad_tvs) + ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) } + + + ; let all_fvs = fvs `addOneFV` unLoc tycon' + ; return (tycon', + HsWB { hswb_cts = pats', hswb_kvs = kv_names, + hswb_tvs = tv_names, hswb_wcs = [] }, + payload', + all_fvs) } + -- type instance => use, hence addOneFV + +rnTyFamInstDecl :: Maybe (Name, [Name]) + -> TyFamInstDecl RdrName + -> RnM (TyFamInstDecl Name, FreeVars) +rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn + ; return (TyFamInstDecl { tfid_eqn = L loc eqn' + , tfid_fvs = fvs }, fvs) } + +rnTyFamInstEqn :: Maybe (Name, [Name]) + -> TyFamInstEqn RdrName + -> RnM (TyFamInstEqn Name, FreeVars) +rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = HsWB { hswb_cts = pats } + , tfe_rhs = rhs }) + = do { (tycon', pats', rhs', fvs) <- + rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = pats' + , tfe_rhs = rhs' }, fvs) } + +rnTyFamDefltEqn :: Name + -> TyFamDefltEqn RdrName + -> RnM (TyFamDefltEqn Name, FreeVars) +rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tyvars + , tfe_rhs = rhs }) + = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' -> + do { tycon' <- lookupFamInstName (Just cls) tycon + ; (rhs', fvs) <- rnLHsType ctx rhs + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = tyvars' + , tfe_rhs = rhs' }, fvs) } + where + ctx = TyFamilyCtx tycon + +rnDataFamInstDecl :: Maybe (Name, [Name]) + -> DataFamInstDecl RdrName + -> RnM (DataFamInstDecl Name, FreeVars) +rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon + , dfid_pats = HsWB { hswb_cts = pats } + , dfid_defn = defn }) + = do { (tycon', pats', defn', fvs) <- + rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn + ; return (DataFamInstDecl { dfid_tycon = tycon' + , dfid_pats = pats' + , dfid_defn = defn' + , dfid_fvs = fvs }, fvs) } + +-- Renaming of the associated types in instances. + +-- Rename associated type family decl in class +rnATDecls :: Name -- Class + -> [LFamilyDecl RdrName] + -> RnM ([LFamilyDecl Name], FreeVars) +rnATDecls cls at_decls + = rnList (rnFamDecl (Just cls)) at_decls + +rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames + decl RdrName -> -- an instance. rnTyFamInstDecl + RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> LHsTyVarBndrs Name + -> [Located (decl RdrName)] + -> RnM ([Located (decl Name)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in TcInstDcls +rnATInstDecls rnFun cls hs_tvs at_insts + = rnList (rnFun (Just (cls, tv_ns))) at_insts + where + tv_ns = hsLKiTyVarNames hs_tvs + -- See Note [Renaming associated types] + +{- +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. Trac #5515 + +The same thing applies to kind variables, of course (Trac #7938, #9574): + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> *) +Here 'o' is mentioned on the RHS of the Codomain function, but +not on the LHS. + +All this applies only for *instance* declarations. In *class* +declarations there is no RHS to worry about, and the class variables +can all be in scope (Trac #5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature, just like 'x'. +-} + +extendTyVarEnvForMethodBinds :: [Name] + -> RnM (LHsBinds Name, FreeVars) + -> RnM (LHsBinds Name, FreeVars) +-- For the method bindings in class and instance decls, we extend +-- the type variable environment iff -XScopedTypeVariables + +extendTyVarEnvForMethodBinds ktv_names thing_inside + = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables + ; if scoped_tvs then + extendTyVarEnvFVRn ktv_names thing_inside + else + thing_inside } + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) +rnSrcDerivDecl (DerivDecl ty overlap) + = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving + ; unless standalone_deriv_ok (addErr standaloneDerivErr) + ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty + ; return (DerivDecl ty' overlap, fvs) } + +standaloneDerivErr :: SDoc +standaloneDerivErr + = hang (ptext (sLit "Illegal standalone deriving declaration")) + 2 (ptext (sLit "Use StandaloneDeriving to enable this extension")) + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars) +rnHsRuleDecls (HsRules src rules) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules src rn_rules,fvs) } + +rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) +rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) + = do { let rdr_names_w_loc = map get_var vars + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule (unLoc rule_name) names lhs' fv_lhs' + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_lhs' `plusFV` fv_rhs') } } + where + get_var (L _ (RuleBndrSig v _)) = v + get_var (L _ (RuleBndr v)) = v + +bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name] + -> ([LRuleBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsRuleVars rule_name vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + doc = RuleCtx rule_name + + go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr (L loc n)) : vars') + + go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside + = rnHsBndrSig doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + +{- +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a transformation rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simmpler not to check at all, and that is why +check_e is commented out. +-} + +checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + +validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) +-- Nothing => OK +-- Just e => Not ok, and e is the offending expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl (L _ e) = check e + + check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsVar v) | v `notElem` foralls = Nothing + check other = Just other -- Failure + + -- Check an argument + checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] + +badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc +badRuleLhsErr name lhs bad_e + = sep [ptext (sLit "Rule") <+> ftext name <> colon, + nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, + ptext (sLit "in left-hand side:") <+> ppr lhs])] + $$ + ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd") + +{- +********************************************************* +* * +\subsection{Vectorisation declarations} +* * +********************************************************* +-} + +rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +-- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly +-- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. +rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) + = do { var' <- lookupLocatedOccRn var + ; (rhs', fv_rhs) <- rnLExpr rhs + ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') + } +rnHsVectDecl (HsVect _ _var _rhs) + = failWith $ vcat + [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma") + , ptext (sLit "must be an identifier") + ] +rnHsVectDecl (HsNoVect s var) + = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names + ; return (HsNoVect s var', unitFV (unLoc var')) + } +rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing) + = do { tycon' <- lookupLocatedOccRn tycon + ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon')) + } +rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon)) + = do { tycon' <- lookupLocatedOccRn tycon + ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon + ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon') + , mkFVs [unLoc tycon', unLoc rhs_tycon']) + } +rnHsVectDecl (HsVectTypeOut _ _ _) + = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" +rnHsVectDecl (HsVectClassIn s cls) + = do { cls' <- lookupLocatedOccRn cls + ; return (HsVectClassIn s cls', unitFV (unLoc cls')) + } +rnHsVectDecl (HsVectClassOut _) + = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" +rnHsVectDecl (HsVectInstIn instTy) + = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy + ; return (HsVectInstIn instTy', fvs) + } +rnHsVectDecl (HsVectInstOut _) + = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" + +{- +********************************************************* +* * +\subsection{Type, class and iface sig declarations} +* * +********************************************************* + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + + +Note [Extra dependencies from .hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following case: + + module A where + import B + data A1 = A1 B1 + + module B where + import {-# SOURCE #-} A + type DisguisedA1 = A1 + data B1 = B1 DisguisedA1 + +We do not follow type synonyms when building the dependencies for each datatype, +so we will not find out that B1 really depends on A1 (which means it depends on +itself). To handle this problem, at the moment we add dependencies to everything +that comes from an .hs-boot file. But we don't add those dependencies to +everything. Imagine module B above had another datatype declaration: + + data B2 = B2 Int + +Even though B2 has a dependency (on Int), all its dependencies are from things +that live on other packages. Since we don't have mutual dependencies across +packages, it is safe not to add the dependencies on the .hs-boot stuff to B2. + +See also Note [Grouping of type and class declarations] in TcTyClsDecls. +-} + +isInPackage :: PackageKey -> Name -> Bool +isInPackage pkgId nm = case nameModule_maybe nm of + Nothing -> False + Just m -> pkgId == modulePackageKey m +-- We use nameModule_maybe because we might be in a TH splice, in which case +-- there is no module name. In that case we cannot have mutual dependencies, +-- so it's fine to return False here. + +rnTyClDecls :: [Name] -> [TyClGroup RdrName] + -> RnM ([TyClGroup Name], FreeVars) +-- Rename the declarations and do depedency analysis on them +rnTyClDecls extra_deps tycl_ds + = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds) + ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs) + ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds) + ; thisPkg <- fmap thisPackage getDynFlags + ; let add_boot_deps :: FreeVars -> FreeVars + -- See Note [Extra dependencies from .hs-boot files] + add_boot_deps fvs | any (isInPackage thisPkg) (nameSetElems fvs) + = fvs `plusFV` mkFVs extra_deps + | otherwise + = fvs + + ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs + + sccs :: [SCC (LTyClDecl Name)] + sccs = depAnalTyClDecls ds_w_fvs' + + all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + + raw_groups = map flattenSCC sccs + -- See Note [Role annotations in the renamer] + (groups, orphan_roles) + = foldr (\group (groups_acc, orphans_acc) -> + let names = map (tcdName . unLoc) group + roles = mapMaybe (lookupNameEnv orphans_acc) names + orphans' = delListFromNameEnv orphans_acc names + -- there doesn't seem to be an interface to + -- do the above more efficiently + in ( TyClGroup { group_tyclds = group + , group_roles = roles } : groups_acc + , orphans' ) + ) + ([], role_annot_env) + raw_groups + + ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles) + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) + ; return (groups, all_fvs) } + +rnTyClDecl :: TyClDecl RdrName + -> RnM (TyClDecl Name, FreeVars) + +-- All flavours of type family declarations ("type family", "newtype family", +-- and "data family"), both top level and (for an associated type) +-- in a class decl +rnTyClDecl (FamDecl { tcdFam = decl }) + = do { (decl', fvs) <- rnFamDecl Nothing decl + ; return (FamDecl decl', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = fst (extractHsTyRdrTyVars rhs) + doc = TySynCtx tycon + ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) + ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ + \ tyvars' -> + do { (rhs', fvs) <- rnTySyn doc rhs + ; return ((tyvars', rhs'), fvs) } + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdRhs = rhs', tcdFVs = fvs }, fvs) } + +-- "data", "newtype" declarations +-- both top level and (for an associated type) in an instance decl +rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs) + ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' -> + do { (defn', fvs) <- rnDataDefn doc defn + ; return ((tyvars', defn'), fvs) } + ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdDataDefn = defn', tcdFVs = fvs }, fvs) } + +rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) + = do { lcls' <- lookupLocatedTopBndrRn lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) + <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' ats + ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs + ; let fvs = cxt_fvs `plusFV` + sig_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats', sigs'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', meth_fvs) + <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $ + -- No need to check for duplicate method signatures + -- since that is done by RnNames.extendGlobalRdrEnvRn + -- and the methods are already in scope + rnMethodBinds cls' (mkSigTvFn sigs') mbinds + + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdFVs = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet -- ^ of the decls in this group + -> [LRoleAnnotDecl RdrName] + -> RnM (NameEnv (LRoleAnnotDecl Name)) +rnRoleAnnots decl_names role_annots + = do { -- check for duplicates *before* renaming, to avoid lumping + -- together all the unboundNames + let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots + role_annots_cmp (L _ annot1) (L _ annot2) + = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2 + ; mapM_ dupRoleAnnotErr dup_annots + ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups + -- some of the role annots will be unbound; we don't wish + -- to include these + ; return $ mkNameEnv [ (name, ra) + | ra <- role_annots' + , let name = roleAnnotDeclName (unLoc ra) + , not (isUnboundName name) ] } + where + rn_role_annot1 (RoleAnnotDecl tycon roles) + = do { -- the name is an *occurrence*, but look it up only in the + -- decls defined in this group (see #10263) + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names) + (text "role annotation") + tycon + ; return $ RoleAnnotDecl tycon' roles } + +dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () +dupRoleAnnotErr [] = panic "dupRoleAnnotErr" +dupRoleAnnotErr list + = addErrAt loc $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot sorted_list) + where + sorted_list = sortBy cmp_annot list + (L loc first_decl : _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr loc) + + cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 + +orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM () +orphanRoleAnnotErr (L loc decl) + = addErrAt loc $ + hang (text "Role annotation for a type previously declared:") + 2 (ppr decl) $$ + parens (text "The role annotation must be given where" <+> + quotes (ppr $ roleAnnotDeclName decl) <+> + text "is declared.") + +rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars) +rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context, dd_cons = condecls + , dd_kindSig = sig, dd_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta doc) + + ; (sig', sig_fvs) <- rnLHsMaybeKind doc sig + ; (context', fvs1) <- rnContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context', dd_kindSig = sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True + + rn_derivs Nothing = return (Nothing, emptyFVs) + rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds + ; return (Just (L ld ds'), fvs) } + +badGadtStupidTheta :: HsDocContext -> SDoc +badGadtStupidTheta _ + = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), + ptext (sLit "(You can put a context on each contructor, though.)")] + +rnFamDecl :: Maybe Name + -- Just cls => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types + -> FamilyDecl RdrName + -> RnM (FamilyDecl Name, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdInfo = info, fdKindSig = kind }) + = do { ((tycon', tyvars', kind'), fv1) <- + bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind + ; return ((tycon', tyvars', kind'), fv_kind) } + ; (info', fv2) <- rn_info info + ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' + , fdInfo = info', fdKindSig = kind' } + , fv1 `plusFV` fv2) } + where + fmly_doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars kind + + rn_info (ClosedTypeFamily eqns) + = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns + -- no class context, + ; return (ClosedTypeFamily eqns', fvs) } + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +Trac #3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + +depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] +-- See Note [Dependency analysis of type and class decls] +depAnalTyClDecls ds_w_fvs + = stronglyConnCompFromEdgedVertices edges + where + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs)) + | (d, fvs) <- ds_w_fvs ] + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor + assoc_env = mkNameEnv $ concat assoc_env_list + assoc_env_list = do + (L _ d, _) <- ds_w_fvs + case d of + ClassDecl { tcdLName = L _ cls_name + , tcdATs = ats } + -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats + return [(fam_name, cls_name)] + DataDecl { tcdLName = L _ data_name + , tcdDataDefn = HsDataDefn { dd_cons = cons } } + -> do L _ dc <- cons + return $ zip (map unLoc $ con_names dc) (repeat data_name) + _ -> [] + +{- +Note [Dependency analysis of type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to do dependency analysis on type and class declarations +else we get bad error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + +This has a kind error, but the error message is better if you +check T first, (fixing its kind) and *then* S. If you do kind +inference together, you might get an error reported in S, which +is jolly confusing. See Trac #4875 + +Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. We exclude the annotations for unbound names in the annotation +environment to avoid spurious errors for orphaned annotations. + +We then (in rnTyClDecls) do a check for orphan role annotations (role +annotations without an accompanying type decl). The check works by folding +over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant +role declarations for each group, as well as diminishing the annotation +environment. After the fold is complete, anything left over in the name +environment must be an orphan, and errors are generated. + +An earlier version of this algorithm short-cut the orphan check by renaming +only with names declared in this module. But, this check is insufficient in +the case of staged module compilation (Template Haskell, GHCi). +See #8485. With the new lookup process (which includes types declared in other +modules), we get better error messages, too. + +********************************************************* +* * +\subsection{Support code for type/data declarations} +* * +********************************************************* +-} + +--------------- +badAssocRhs :: [Name] -> RnM () +badAssocRhs ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions") + <+> pprWithCommas (quotes . ppr) ns) + 2 (ptext (sLit "All such variables must be bound on the LHS"))) + +----------------- +rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) + +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) +rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs + , con_cxt = lcxt@(L loc cxt), con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) + = do { mapM_ (addLocM checkConName) names + ; when old_rec (addWarn (deprecRecSyntax decl)) + ; new_names <- mapM lookupLocatedTopBndrRn names + + -- For H98 syntax, the tvs are the existential ones + -- For GADT syntax, the tvs are all the quantified tyvars + -- Hence the 'filter' in the ResTyH98 case only + ; rdr_env <- getLocalRdrEnv + ; let arg_tys = hsConDeclArgTys details + (free_kvs, free_tvs) = case res_ty of + ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) + ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys) + + -- With an Explicit forall, check for unused binders + -- With Implicit, find the mentioned ones, and use them as binders + -- With Qualified, do the same as with Implicit, but give a warning + -- See Note [Context quantification] + ; new_tvs <- case expl of + Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) + Qualified -> do { warnContextQuantification (docOfHsDocContext doc) + (userHsTyVarBndrs loc free_tvs) + ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) } + Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs + ; return tvs } + + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do + { (new_context, fvs1) <- rnContext doc lcxt + ; (new_details, fvs2) <- rnConDeclDetails doc details + ; (new_details', new_res_ty, fvs3) + <- rnConResult doc (map unLoc new_names) new_details res_ty + ; return (decl { con_names = new_names, con_qvars = new_tyvars + , con_cxt = new_context, con_details = new_details' + , con_res = new_res_ty, con_doc = mb_doc' }, + fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + where + doc = ConDeclCtx names + get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) + +rnConResult :: HsDocContext -> [Name] + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> ResType (LHsType RdrName) + -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), + ResType (LHsType Name), FreeVars) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) +rnConResult doc _con details (ResTyGADT ls ty) + = do { (ty', fvs) <- rnLHsType doc ty + ; let (arg_tys, res_ty) = splitHsFunType ty' + -- We can finally split it up, + -- now the renamer has dealt with fixities + -- See Note [Sorting out the result type] in RdrHsSyn + + ; case details of + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + RecCon {} -> do { unless (null arg_tys) + (addErr (badRecResTy (docOfHsDocContext doc))) + ; return (details, ResTyGADT ls res_ty, fvs) } + + PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)} + +rnConDeclDetails + :: HsDocContext + -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName]) + -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars) +rnConDeclDetails doc (PrefixCon tys) + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } + +rnConDeclDetails doc (InfixCon ty1 ty2) + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } + +rnConDeclDetails doc (RecCon (L l fields)) + = do { (new_fields, fvs) <- rnConDeclFields doc fields + -- No need to check for duplicate fields + -- since that is done by RnNames.extendGlobalRdrEnvRn + ; return (RecCon (L l new_fields), fvs) } + +------------------------------------------------- +deprecRecSyntax :: ConDecl RdrName -> SDoc +deprecRecSyntax decl + = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names decl)) + <+> ptext (sLit "uses deprecated syntax") + , ptext (sLit "Instead, use the form") + , nest 2 (ppr decl) ] -- Pretty printer uses new form + +badRecResTy :: SDoc -> SDoc +badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc + +{- +********************************************************* +* * +\subsection{Support code for type/data declarations} +* * +********************************************************* + +Get the mapping from constructors to fields for this module. +It's convenient to do this after the data type decls have been renamed +-} + +extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv tycl_decls inst_decls + = do { tcg_env <- getGblEnv + ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons + ; return (tcg_env { tcg_field_env = field_env' }) } + where + -- we want to lookup: + -- (a) a datatype constructor + -- (b) a record field + -- knowing that they're from this module. + -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe, + -- which keeps only the local ones. + lookup x = do { x' <- lookupLocatedTopBndrRn x + ; return $ unLoc x'} + + all_data_cons :: [ConDecl RdrName] + all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs + , L _ con <- cons ] + all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) + <- tyClGroupConcat tycl_decls ] + ++ map dfid_defn (instDeclDataFamInsts inst_decls) + -- Do not forget associated types! + + get_con (ConDecl { con_names = cons, con_details = RecCon flds }) + (RecFields env fld_set) + = do { cons' <- mapM lookup cons + ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) + (unLoc flds)) + ; let env' = foldl (\e c -> extendNameEnv e c flds') env cons' + + fld_set' = extendNameSetList fld_set flds' + ; return $ (RecFields env' fld_set') } + get_con _ env = return env + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [Located (FunDep (Located RdrName))] + -> RnM [Located (FunDep (Located Name))] +rnFds fds + = mapM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (tys1', tys2') } + +rnHsTyVars :: [Located RdrName] -> RnM [Located Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) + +add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression) + case flag of + ExplicitSplice -> return () + ImplicitSplice -> do { th_on <- xoptM Opt_TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = ptext (sLit "Parse error: naked expression at top level") + $$ ptext (sLit "Perhaps you intended to use TemplateHaskell") + +add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes + = do { ds' <- runQuasiQuoteDecl qq + ; addl gp (ds' ++ ds) } + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d + = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds + | otherwise + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds + = addl (gp { hs_vects = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a] +add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss + +add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a] +add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" + +add_sig :: LSig a -> HsValBinds a -> HsValBinds a +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs new file mode 100644 index 00000000..e0ebd300 --- /dev/null +++ b/compiler/rename/RnSplice.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE CPP #-} + +module RnSplice ( + rnTopSpliceDecls, + rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, + rnBracket, + checkThLocalName + ) where + + +import Name +import NameSet +import HsSyn +import RdrName +import TcRnMonad +import Kind + +#ifdef GHCI +import ErrUtils ( dumpIfSet_dyn_printer ) +import Control.Monad ( unless, when ) +import DynFlags +import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName ) +import LoadIface ( loadInterfaceForName ) +import Module +import RnEnv +import RnPat ( rnPat ) +import RnSource ( rnSrcDecls, findSplice ) +import RnTypes ( rnLHsType ) +import SrcLoc +import TcEnv ( checkWellStaged, tcMetaTy ) +import Outputable +import BasicTypes ( TopLevelFlag, isTopLevel ) +import FastString +import Hooks + +import {-# SOURCE #-} RnExpr ( rnLExpr ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) +import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) +#endif + +#ifndef GHCI +rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket e _ = failTH e "Template Haskell bracket" + +rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls e = failTH e "Template Haskell top splice" + +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) +rnSpliceType e _ = failTH e "Template Haskell type splice" + +rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr _ e = failTH e "Template Haskell splice" + +rnSplicePat :: HsSplice RdrName -> RnM (Either (Pat RdrName) (Pat Name), FreeVars) +rnSplicePat e = failTH e "Template Haskell pattern splice" + +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl e = failTH e "Template Haskell declaration splice" +#else + +{- +********************************************************* +* * + Splices +* * +********************************************************* + +Note [Free variables of typed splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider renaming this: + f = ... + h = ...$(thing "f")... + +where the splice is a *typed* splice. The splice can expand into +literally anything, so when we do dependency analysis we must assume +that it might mention 'f'. So we simply treat all locally-defined +names as mentioned by any splice. This is terribly brutal, but I +don't see what else to do. For example, it'll mean that every +locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' +before 'f', and that will crash the type checker because 'f' isn't in +scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +Note [Renamer errors] +~~~~~~~~~~~~~~~~~~~~~ +It's important to wrap renamer calls in checkNoErrs, because the +renamer does not fail for out of scope variables etc. Instead it +returns a bogus term/type, so that it can report more than one error. +We don't want the type checker to see these bogus unbound variables. +-} + +rnSpliceGen :: Bool -- Typed splice? + -> (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice + -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending + -> HsSplice RdrName + -> RnM (a, FreeVars) +rnSpliceGen is_typed_splice run_splice pend_splice splice@(HsSplice _ expr) + = addErrCtxt (spliceCtxt (HsSpliceE is_typed_splice splice)) $ + setSrcSpan (getLoc expr) $ do + { stage <- getStage + ; case stage of + Brack pop_stage RnPendingTyped + -> do { checkTc is_typed_splice illegalUntypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (_pending_splice, result) = pend_splice splice' + ; return (result, fvs) } + + Brack pop_stage (RnPendingUntyped ps_var) + -> do { checkTc (not is_typed_splice) illegalTypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (pending_splice, result) = pend_splice splice' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pending_splice : ps) + ; return (result, fvs) } + + _ -> do { (splice', fvs1) <- setStage (Splice is_typed_splice) $ + rnSplice splice + + ; (result, fvs2) <- run_splice splice' + ; return (result, fvs1 `plusFV` fvs2) } } + +--------------------- +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +-- Not exported...used for all +rnSplice (HsSplice splice_name expr) + = do { checkTH expr "Template Haskell splice" + ; loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsSplice n' expr', fvs) } + +--------------------- +rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr is_typed splice + = rnSpliceGen is_typed run_expr_splice pend_expr_splice splice + where + pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name) + pend_expr_splice rn_splice@(HsSplice n e) + = (PendingRnExpSplice (PendSplice n e), HsSpliceE is_typed rn_splice) + + run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars) + run_expr_splice rn_splice@(HsSplice _ expr') + | is_typed -- Run it later, in the type checker + = do { -- Ugh! See Note [Splices] above + lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + + ; return (HsSpliceE is_typed rn_splice, lcl_names `plusFV` gbl_names) } + + | otherwise -- Run it here + = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') + + -- The splice must have type ExpQ + ; meta_exp_ty <- tcMetaTy expQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; expr2 <- runMetaE zonked_q_expr + ; showSplice "expression" expr (ppr expr2) + + ; (lexpr3, fvs) <- checkNoErrs $ + rnLExpr expr2 + ; return (unLoc lexpr3, fvs) } + +---------------------- +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) +rnSpliceType splice k + = rnSpliceGen False run_type_splice pend_type_splice splice + where + pend_type_splice rn_splice@(HsSplice n e) + = (PendingRnTypeSplice (PendSplice n e), HsSpliceTy rn_splice k) + + run_type_splice (HsSplice _ expr') + = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') + + ; meta_exp_ty <- tcMetaTy typeQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; hs_ty2 <- runMetaT zonked_q_expr + ; showSplice "type" expr (ppr hs_ty2) + + ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 + ; checkNoErrs $ rnLHsType doc hs_ty2 + -- checkNoErrs: see Note [Renamer errors] + } + ; return (unLoc hs_ty3, fvs) } + +{- +Note [rnSplicePat] +~~~~~~~~~~~~~~~~~~ +Renaming a pattern splice is a bit tricky, because we need the variables +bound in the pattern to be in scope in the RHS of the pattern. This scope +management is effectively done by using continuation-passing style in +RnPat, through the CpsRn monad. We don't wish to be in that monad here +(it would create import cycles and generally conflict with renaming other +splices), so we really want to return a (Pat RdrName) -- the result of +running the splice -- which can then be further renamed in RnPat, in +the CpsRn monad. + +The problem is that if we're renaming a splice within a bracket, we +*don't* want to run the splice now. We really do just want to rename +it to an HsSplice Name. Of course, then we can't know what variables +are bound within the splice, so pattern splices within brackets aren't +all that useful. + +In any case, when we're done in rnSplicePat, we'll either have a +Pat RdrName (the result of running a top-level splice) or a Pat Name +(the renamed nested splice). Thus, the awkward return type of +rnSplicePat. +-} + +-- | Rename a splice pattern. See Note [rnSplicePat] +rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) + , FreeVars) +rnSplicePat splice + = rnSpliceGen False run_pat_splice pend_pat_splice splice + where + pend_pat_splice rn_splice@(HsSplice n e) + = (PendingRnPatSplice (PendSplice n e), Right $ SplicePat rn_splice) + + run_pat_splice (HsSplice _ expr') + = do { expr <- getHooked runRnSpliceHook return >>= ($ expr') + + ; meta_exp_ty <- tcMetaTy patQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; pat <- runMetaP zonked_q_expr + ; showSplice "pattern" expr (ppr pat) + + ; return (Left $ unLoc pat, emptyFVs) } + +---------------------- +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl (SpliceDecl (L loc splice) flg) + = rnSpliceGen False run_decl_splice pend_decl_splice splice + where + pend_decl_splice rn_splice@(HsSplice n e) + = (PendingRnDeclSplice (PendSplice n e), SpliceDecl(L loc rn_splice) flg) + + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) + +rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +-- Declaration splice at the very top level of the module +rnTopSpliceDecls (HsSplice _ expr'') + = do { (expr, fvs) <- setStage (Splice False) $ + rnLExpr expr'' + + ; expr' <- getHooked runRnSpliceHook return >>= ($ expr) + + ; list_q <- tcMetaTy decsQTyConName -- Q [Dec] + ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr' list_q) + + -- Run the expression + ; decls <- runMetaD zonked_q_expr + ; traceSplice $ SpliceInfo True + "declarations" + (Just (getLoc expr)) + (Just $ ppr expr') + (vcat (map ppr decls)) + + ; return (decls,fvs) } + +{- +************************************************************************ +* * + Template Haskell brackets +* * +************************************************************************ +-} + +rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket e br_body + = addErrCtxt (quotationCtxtDoc br_body) $ + do { -- Check that Template Haskell is enabled and available + thEnabled <- xoptM Opt_TemplateHaskell + ; unless thEnabled $ + failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e + , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] ) + ; checkTH e "Template Haskell bracket" + + -- Check for nested brackets + ; cur_stage <- getStage + ; case cur_stage of + { Splice True -> checkTc (isTypedBracket br_body) illegalUntypedBracket + ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket + ; Comp -> return () + ; Brack {} -> failWithTc illegalBracket + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; case isTypedBracket br_body of + True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ + rn_bracket cur_stage br_body + ; return (HsBracket body', fvs_e) } + + False -> do { ps_var <- newMutVar [] + ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ + rn_bracket cur_stage br_body + ; pendings <- readMutVar ps_var + ; return (HsRnBracketOut body' pendings, fvs_e) } + } + +rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rn_bracket outer_stage br@(VarBr flg rdr_name) + = do { name <- lookupOccRn rdr_name + ; this_mod <- getModule + + ; case flg of + { -- Type variables can be quoted in TH. See #5721. + False -> return () + ; True | nameIsLocalOrFrom this_mod name -> + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name + ; case mb_bind_lvl of + { Nothing -> return () -- Can happen for data constructors, + -- but nothing needs to be done for them + + ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] + | isTopLevel top_lvl + -> when (isExternalName name) (keepAlive name) + | otherwise + -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage) + ; checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + } + } + ; True | otherwise -> -- Imported thing + discardResult (loadInterfaceForName msg name) + -- Reason for loadInterface: deprecation checking + -- assumes that the home interface is loaded, and + -- this is the only way that is going to happen + } + ; return (VarBr flg name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") + +rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr e', fvs) } + +rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) + +rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr t', fvs) } + +rn_bracket _ (DecBrL decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls [] group + -- The empty list is for extra dependencies coming from .hs-boot files + -- See Note [Extra dependencies from .hs-boot files] in RnSource + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + } + }} + +rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr e', fvs) } + +spliceCtxt :: HsExpr RdrName -> SDoc +spliceCtxt expr= hang (ptext (sLit "In the splice:")) 2 (ppr expr) + +showSplice :: String -> LHsExpr Name -> SDoc -> TcM () +-- Note that 'before' is *renamed* but not *typechecked* +-- Reason (a) less typechecking crap +-- (b) data constructors after type checking have been +-- changed to their *wrappers*, and that makes them +-- print always fully qualified +showSplice what before after = + traceSplice $ SpliceInfo False what Nothing (Just $ ppr before) after + +-- | The splice data to be logged +-- +-- duplicates code in TcSplice.lhs +data SpliceInfo + = SpliceInfo + { spliceIsDeclaration :: Bool + , spliceDescription :: String + , spliceLocation :: Maybe SrcSpan + , spliceSource :: Maybe SDoc + , spliceGenerated :: SDoc + } + +-- | outputs splice information for 2 flags which have different output formats: +-- `-ddump-splices` and `-dth-dec-file` +-- +-- This duplicates code in TcSplice.lhs +traceSplice :: SpliceInfo -> TcM () +traceSplice sd = do + loc <- case sd of + SpliceInfo { spliceLocation = Nothing } -> getSrcSpanM + SpliceInfo { spliceLocation = Just loc } -> return loc + traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc sd) + when (spliceIsDeclaration sd) $ do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file + (spliceCodeDoc loc sd) + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SpliceInfo -> SDoc + spliceDebugDoc loc sd + = let code = case spliceSource sd of + Nothing -> ending + Just b -> nest 2 b : ending + ending = [ text "======>", nest 2 (spliceGenerated sd) ] + in (vcat [ ppr loc <> colon + <+> text "Splicing" <+> text (spliceDescription sd) + , nest 2 (sep code) + ]) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SpliceInfo -> SDoc + spliceCodeDoc loc sd + = (vcat [ text "--" <+> ppr loc <> colon + <+> text "Splicing" <+> text (spliceDescription sd) + , sep [spliceGenerated sd] + ]) + +illegalBracket :: SDoc +illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)") + +illegalTypedBracket :: SDoc +illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.") + +illegalUntypedBracket :: SDoc +illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.") + +illegalTypedSplice :: SDoc +illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets") + +illegalUntypedSplice :: SDoc +illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets") + +quotedNameStageErr :: HsBracket RdrName -> SDoc +quotedNameStageErr br + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br + , ptext (sLit "must be used at the same stage at which is is bound")] + +quotationCtxtDoc :: HsBracket RdrName -> SDoc +quotationCtxtDoc br_body + = hang (ptext (sLit "In the Template Haskell quotation")) + 2 (ppr br_body) + +-- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc +-- spliceResultDoc expr +-- = vcat [ hang (ptext (sLit "In the splice:")) +-- 2 (char '$' <> pprParendExpr expr) +-- , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ] +#endif + +checkThLocalName :: Name -> RnM () +#ifndef GHCI /* GHCI and TH is off */ +-------------------------------------- +-- Check for cross-stage lifting +checkThLocalName _name + = return () + +#else /* GHCI and TH is on */ +checkThLocalName name + = do { traceRn (text "checkThLocalName" <+> ppr name) + ; mb_local_use <- getStageAndBindLevel name + ; case mb_local_use of { + Nothing -> return () ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_stage) -> + do { let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ + checkCrossStageLifting top_lvl name use_stage } } } + +-------------------------------------- +checkCrossStageLifting :: TopLevelFlag -> Name -> ThStage -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] + +checkCrossStageLifting top_lvl name (Brack _ (RnPendingUntyped ps_var)) + | isTopLevel top_lvl + -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + = when (isExternalName name) (keepAlive name) + -- See Note [Keeping things alive for Template Haskell] + + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + do { traceRn (text "checkCrossStageLifting" <+> ppr name) + ; -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnCrossStageSplice name : ps) } + +checkCrossStageLifting _ _ _ = return () +#endif /* GHCI */ + +{- +Note [Keeping things alive for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = x+1 + g y = [| f 3 |] + +Here 'f' is referred to from inside the bracket, which turns into data +and mentions only f's *name*, not 'f' itself. So we need some other +way to keep 'f' alive, lest it get dropped as dead code. That's what +keepAlive does. It puts it in the keep-alive set, which subsequently +ensures that 'f' stays as a top level binding. + +This must be done by the renamer, not the type checker (as of old), +because the type checker doesn't typecheck the body of untyped +brackets (Trac #8540). + +A thing can have a bind_lvl of outerLevel, but have an internal name: + foo = [d| op = 3 + bop = op + 1 |] +Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is +bound inside a bracket. That is because we don't even even record +binding levels for top-level things; the binding levels are in the +LocalRdrEnv. + +So the occurrence of 'op' in the rhs of 'bop' looks a bit like a +cross-stage thing, but it isn't really. And in fact we never need +to do anything here for top-level bound things, so all is fine, if +a bit hacky. + +For these chaps (which have Internal Names) we don't want to put +them in the keep-alive set. + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use+1 OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +where 'use' is the binding level of the 'n quote. (So inside the implied +bracket the level would be use+1.) + +Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (bind = 1, use = 1) + -- (whereas \x. f [| x |] might have been ok, by + -- cross-stage lifting + + \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) + + [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) +-} diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot new file mode 100644 index 00000000..ece78f84 --- /dev/null +++ b/compiler/rename/RnSplice.hs-boot @@ -0,0 +1,15 @@ +module RnSplice where + +import HsSyn +import TcRnMonad +import RdrName +import Name +import NameSet +import Kind + + +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) +rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) + , FreeVars ) +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs new file mode 100644 index 00000000..8ec23a6f --- /dev/null +++ b/compiler/rename/RnTypes.hs @@ -0,0 +1,1091 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[RnSource]{Main pass of renamer} +-} + +{-# LANGUAGE CPP #-} + +module RnTypes ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsKind, rnLHsKind, rnLHsMaybeKind, + rnHsSigType, rnLHsInstType, rnConDeclFields, + newTyVarNameRn, + + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Binding related stuff + warnContextQuantification, warnUnusedForAlls, + bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, + extractHsTyRdrTyVars, extractHsTysRdrTyVars, + extractRdrKindSigVars, extractDataDefnKindVars, + extractWildcards, filterInScope + ) where + +import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) +import {-# SOURCE #-} RnSplice( rnSpliceType ) + +import DynFlags +import HsSyn +import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) +import RnEnv +import TcRnMonad +import RdrName +import PrelNames +import TysPrim ( funTyConName ) +import Name +import SrcLoc +import NameSet + +import Util +import BasicTypes ( compareFixity, funTyFixity, negateFixity, + Fixity(..), FixityDirection(..) ) +import Outputable +import FastString +import Maybes +import Data.List ( nub, nubBy ) +import Control.Monad ( unless, when ) + +#include "HsVersions.h" + +{- +These type renamers are in a separate module, rather than in (say) RnSource, +to break several loop. + +********************************************************* +* * +\subsection{Renaming types} +* * +********************************************************* +-} + +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. +rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty + +rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +-- Rename the type in an instance or standalone deriving decl +rnLHsInstType doc_str ty + = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty + ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) + ; return (ty', fvs) } + where + good_inst_ty + | Just (_, _, L _ cls, _) <- + splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy ty) + , isTcOcc (rdrNameOcc cls) = True + | otherwise = False + +badInstTy :: LHsType RdrName -> SDoc +badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty + +{- +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +Note [Context quantification] +----------------------------- +Variables in type signatures are implicitly quantified +when (1) they are in a type signature not beginning +with "forall" or (2) in any qualified type T => R. +We are phasing out (2) since it leads to inconsistencies +(Trac #4426): + +data A = A (a -> a) is an error +data A = A (Eq a => a -> a) binds "a" +data A = A (Eq a => a -> b) binds "a" and "b" +data A = A (() => a -> b) binds "a" and "b" +f :: forall a. a -> b is an error +f :: forall a. () => a -> b is an error +f :: forall a. a -> (() => b) binds "a" and "b" + +The -fwarn-context-quantification flag warns about +this situation. See rnHsTyKi for case HsForAllTy Qualified. +-} + +rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind + -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi isType doc (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi isType doc ty + ; return (L loc ty', fvs) } + +rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsType = rnLHsTyKi True + +rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) +rnLHsKind = rnLHsTyKi False + +rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) + -> RnM (Maybe (LHsKind Name), FreeVars) +rnLHsMaybeKind _ Nothing + = return (Nothing, emptyFVs) +rnLHsMaybeKind doc (Just kind) + = do { (kind', fvs) <- rnLHsKind doc kind + ; return (Just kind', fvs) } + +rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) +rnHsType = rnHsTyKi True +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) +rnHsKind = rnHsTyKi False + +rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) + +rnHsTyKi isType doc ty@HsForAllTy{} + = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty) + +rnHsTyKi isType _ (HsTyVar rdr_name) + = do { name <- rnTyVar isType rdr_name + ; return (HsTyVar name, unitFV name) } + +-- If we see (forall a . ty), without foralls on, the forall will give +-- a sensible error message, but we don't want to complain about the dot too +-- Hence the jiggery pokery with ty1 +rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) + = ASSERT( isType ) setSrcSpan loc $ + do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- if ops_ok + then rnTyVar isType op + else do { addErr (opTyErr op ty) + ; return (mkUnboundName op) } -- Avoid double complaint + ; let l_op' = L loc op' + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + op' fix ty1' ty2' + ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } + +rnHsTyKi isType doc (HsParTy ty) + = do { (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsParTy ty', fvs) } + +rnHsTyKi isType doc (HsBangTy b ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsBangTy b ty', fvs) } + +rnHsTyKi _ doc ty@(HsRecTy flds) + = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) + 2 (ppr ty)) + ; (flds', fvs) <- rnConDeclFields doc flds + ; return (HsRecTy flds', fvs) } + +rnHsTyKi isType doc (HsFunTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + -- Might find a for-all as the arg of a function type + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + + -- Check for fixity rearrangements + ; res_ty <- if isType + then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + else return (HsFunTy ty1' ty2') + ; return (res_ty, fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc listTy@(HsListTy ty) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy)) + ; (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsListTy ty', fvs) } + +rnHsTyKi isType doc (HsKindSig ty k) + = ASSERT( isType ) + do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (badSigErr False doc ty) + ; (ty', fvs1) <- rnLHsType doc ty + ; (k', fvs2) <- rnLHsKind doc k + ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsPArrTy ty', fvs) } + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys + ; return (HsTupleTy tup_con tys', fvs) } + +-- Ensure that a type-level integer is nonnegative (#8306, #8412) +rnHsTyKi isType _ tyLit@(HsTyLit t) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds (addErr (dataKindsErr isType tyLit)) + ; when (negLit t) (addErr negLitErr) + ; return (HsTyLit t, emptyFVs) } + where + negLit (HsStrTy _ _) = False + negLit (HsNumTy _ i) = i < 0 + negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit + +rnHsTyKi isType doc (HsAppTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc (HsIParamTy n ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsIParamTy n ty', fvs) } + +rnHsTyKi isType doc (HsEqTy ty1 ty2) + = ASSERT( isType ) + do { (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType _ (HsSpliceTy sp k) + = ASSERT( isType ) + rnSpliceType sp k + +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy ty' haddock_doc', fvs) } + +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT( isType ) + do { ty <- runQuasiQuoteType qq + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ; rnHsType doc (HsParTy ty) } + +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT( isType ) + return (HsCoreTy ty, emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi _ _ (HsWrapTy {}) + = panic "rnHsTyKi" + +rnHsTyKi isType doc ty@(HsExplicitListTy k tys) + = ASSERT( isType ) + do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds (addErr (dataKindsErr isType ty)) + ; (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitListTy k tys', fvs) } + +rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) + = ASSERT( isType ) + do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds (addErr (dataKindsErr isType ty)) + ; (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitTupleTy kis tys', fvs) } + +rnHsTyKi _ _ HsWildcardTy = panic "rnHsTyKi HsWildcardTy" + -- Should be replaced by a HsNamedWildcardTy + +rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name) + = ASSERT( isType ) + do { name <- rnTyVar isType rdr_name + ; return (HsNamedWildcardTy name, unitFV name) } + +-------------- +rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName + -> RnM (HsType Name, FreeVars) +rnHsTyKiForAll isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty) + = ASSERT( isType ) do + -- Implicit quantifiction in source code (no kinds on tyvars) + -- Given the signature C => T we universally quantify + -- over FV(T) \ {in-scope-tyvars} + rdr_env <- getLocalRdrEnv + loc <- getSrcSpanM + let + (forall_kvs, forall_tvs) = filterInScope rdr_env $ + extractHsTysRdrTyVars (ty:ctxt) + -- In for-all types we don't bring in scope + -- kind variables mentioned in kind signatures + -- (Well, not yet anyway....) + -- f :: Int -> T (a::k) -- Not allowed + + -- The filterInScope is to ensure that we don't quantify over + -- type variables that are in scope; when GlasgowExts is off, + -- there usually won't be any, except for class signatures: + -- class C a where { op :: a -> a } + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs + + rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty + +rnHsTyKiForAll isType doc + fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty) + = ASSERT( isType ) do + rdr_env <- getLocalRdrEnv + loc <- getSrcSpanM + let + (forall_kvs, forall_tvs) = filterInScope rdr_env $ + extractHsTysRdrTyVars (ty:ctxt) + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs + in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype) + + -- See Note [Context quantification] + warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs + rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty + +rnHsTyKiForAll isType doc + ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau) + = ASSERT( isType ) do { -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not + let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) + in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) + ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) + forall_tyvars mentioned + ; traceRn (text "rnHsTyKiForAll:Exlicit" <+> vcat + [ppr forall_tyvars, ppr lctxt,ppr tau ]) + ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau } + +-- The following should never happen but keeps the completeness checker happy +rnHsTyKiForAll isType doc ty = rnHsTyKi isType doc ty +-------------- +rnTyVar :: Bool -> RdrName -> RnM Name +rnTyVar is_type rdr_name + | is_type = lookupTypeOccRn rdr_name + | otherwise = lookupKindOccRn rdr_name + + +-------------- +rnLHsTypes :: HsDocContext -> [LHsType RdrName] + -> RnM ([LHsType Name], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + +rnForAll :: HsDocContext -> HsExplicitFlag + -> Maybe SrcSpan -- Location of an extra-constraints wildcard + -> [RdrName] -- Kind variables + -> LHsTyVarBndrs RdrName -- Type variables + -> LHsContext RdrName -> LHsType RdrName + -> RnM (HsType Name, FreeVars) + +rnForAll doc exp extra kvs forall_tyvars ctxt ty + | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra + = rnHsType doc (unLoc ty) + -- One reason for this case is that a type like Int# + -- starts off as (HsForAllTy Implicit Nothing [] Int), in case + -- there is some quantification. Now that we have quantified + -- and discovered there are no type variables, it's nicer to turn + -- it into plain Int. If it were Int# instead of Int, we'd actually + -- get an error, because the body of a genuine for-all is + -- of kind *. + + | otherwise + = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> + do { (new_ctxt, fvs1) <- rnContext doc ctxt + ; (new_ty, fvs2) <- rnLHsType doc ty + ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } + -- Retain the same implicit/explicit flag as before + -- so that we can later print it correctly + +--------------- +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindHsTyVars :: HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [RdrName] -- Kind variables from scope + -> LHsTyVarBndrs RdrName -- Type variables + -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +-- (a) Bring kind variables into scope +-- both (i) passed in (kv_bndrs) +-- and (ii) mentioned in the kinds of tv_bndrs +-- (b) Bring type variables into scope +bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside + = do { rdr_env <- getLocalRdrEnv + ; let tvs = hsQTvBndrs tv_bndrs + kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs + , let (_, kvs) = extractHsTyRdrTyVars kind + , kv <- kvs ] + all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs) + all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs' + + overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ] + -- These variables appear both as kind and type variables + -- in the same declaration; eg type family T (x :: *) (y :: x) + -- We disallow this: too confusing! + + ; poly_kind <- xoptM Opt_PolyKinds + ; unless (poly_kind || null all_kvs) + (addErr (badKindBndrs doc all_kvs)) + ; unless (null overlap_kvs) + (addErr (overlappingKindVars doc overlap_kvs)) + + ; loc <- getSrcSpanM + ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs + ; bindLocalNamesFV kv_names $ + do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs + + rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) + rn_tv_bndr (L loc (UserTyVar rdr)) + = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; return (L loc (UserTyVar nm), emptyFVs) } + rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind)) + = do { sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badSigErr False doc kind) + ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; (kind', fvs) <- rnLHsKind doc kind + ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } + + -- Check for duplicate or shadowed tyvar bindrs + ; checkDupRdrNames tv_names_w_loc + ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + + ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs + ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ + do { inner_rdr_env <- getLocalRdrEnv + ; traceRn (text "bhtv" <+> vcat + [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs + , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs' + , ppr $ map (getUnique . rdrNameOcc) all_kvs' + , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ]) + ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } + ; return (res, fvs1 `plusFV` fvs2) } } + +newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name +newTyVarNameRn mb_assoc rdr_env loc rdr + | Just _ <- mb_assoc -- Use the same Name as the parent class decl + , Just n <- lookupLocalRdrEnv rdr_env rdr + = return n + | otherwise + = newLocalBndrRn (L loc rdr) + +-------------------------------- +rnHsBndrSig :: HsDocContext + -> HsWithBndrs RdrName (LHsType RdrName) + -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside + = do { sig_ok <- xoptM Opt_ScopedTypeVariables + ; unless sig_ok (badSigErr True doc ty) + ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty + ; name_env <- getLocalRdrEnv + ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs + , not (tv `elemLocalRdrEnv` name_env) ] + ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs + , not (kv `elemLocalRdrEnv` name_env) ] + ; (wcs, ty') <- extractWildcards ty + ; bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ + bindLocatedLocalsFV wcs $ \wcs_new -> + do { (ty'', fvs1) <- rnLHsType doc ty' + ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'', hswb_kvs = kv_names, + hswb_tvs = tv_names, hswb_wcs = wcs_new }) + ; return (res, fvs1 `plusFV` fvs2) } } + +overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc +overlappingKindVars doc kvs + = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> + ptext (sLit "also used as type variable") <> plural kvs + <> colon <+> pprQuotedList kvs + , docOfHsDocContext doc ] + +badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs doc kvs + = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs + <+> pprQuotedList kvs) + 2 (ptext (sLit "Perhaps you intended to use PolyKinds")) + , docOfHsDocContext doc ] + +badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () +badSigErr is_type doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ hang (ptext (sLit "Illegal") <+> what + <+> ptext (sLit "signature:") <+> quotes (ppr ty)) + 2 (ptext (sLit "Perhaps you intended to use") <+> flag) + , docOfHsDocContext doc ] + where + what | is_type = ptext (sLit "type") + | otherwise = ptext (sLit "kind") + flag | is_type = ptext (sLit "ScopedTypeVariables") + | otherwise = ptext (sLit "KindSignatures") + +dataKindsErr :: Bool -> HsType RdrName -> SDoc +dataKindsErr is_type thing + = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing)) + 2 (ptext (sLit "Perhaps you intended to use DataKinds")) + where + what | is_type = ptext (sLit "type") + | otherwise = ptext (sLit "kind") + +{- +********************************************************* +* * +\subsection{Contexts and predicates} +* * +********************************************************* +-} + +rnConDeclFields :: HsDocContext -> [LConDeclField RdrName] + -> RnM ([LConDeclField Name], FreeVars) +rnConDeclFields doc fields = mapFvRn (rnField doc) fields + +rnField :: HsDocContext -> LConDeclField RdrName + -> RnM (LConDeclField Name, FreeVars) +rnField doc (L l (ConDeclField names ty haddock_doc)) + = do { new_names <- mapM lookupLocatedTopBndrRn names + ; (new_ty, fvs) <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } + +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext doc (L loc cxt) + = do { (cxt', fvs) <- rnLHsTypes doc cxt + ; return (L loc cxt', fvs) } + +{- +************************************************************************ +* * + Fixities and precedence parsing +* * +************************************************************************ + +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator appications left-associatively, EXCEPT negation, which +we need to handle specially. +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. It's made rather tiresome +by the presence of ->, which is a separate syntactic construct. +-} + +--------------- +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name + -> RnM (HsType Name) + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) + = do { fix2 <- lookupTyFixityRn op2 + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy t1 (w2, op2) t2) + (unLoc op2) fix2 ty21 ty22 loc2 } + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + HsFunTy funTyConName funTyFixity ty21 ty22 loc2 + +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment + = return (mk1 ty1 ty2) + +--------------- +mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) + -> Name -> Fixity -> LHsType Name + -> (LHsType Name -> LHsType Name -> HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan + -> RnM (HsType Name) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 + | nofix_error = do { precParseErr (op1,fix1) (op2,fix2) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) + + | associate_right = do + new_e <- mkOpAppRn e12 op2 fix2 e2 + return (OpApp e11 op1 fix1 (L loc' new_e)) + where + loc'= combineLocs e12 e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = do precParseErr (negateName,negateFixity) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) + + | associate_right + = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 + return (NegApp (L loc' new_e) neg_name) + where + loc' = combineLocs neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (negateName, negateFixity) + return (OpApp e1 op1 fix1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT2( right_op_ok fix (unLoc e2), + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ) + return (OpApp e1 op fix e2) + +---------------------------- +get_op :: LHsExpr Name -> Name +get_op (L _ (HsVar n)) = n +get_op other = pprPanic "get_op" (ppr other) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operarand. So we just check that the right operand is OK +right_op_ok :: Fixity -> HsExpr Name -> Bool +right_op_ok fix1 (OpApp _ _ fix2 _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok _ _ + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + return (NegApp neg_arg neg_name) + +not_op_app :: HsExpr id -> Bool +not_op_app (OpApp _ _ _ _) = False +not_op_app _ = True + +--------------------------- +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) + op2 fix2 a2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsCmdArrForm op2 (Just fix2) [a1, a2]) + + | associate_right + = do new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsCmdArrForm op1 (Just fix1) + [a11, L loc (HsCmdTop (L loc new_c) + placeHolderType placeHolderType [])]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = return (HsCmdArrForm op (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name + -> RnM (Pat Name) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) + ; return (ConPatIn op2 (InfixCon p1 p2)) } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + return (ConPatIn op (InfixCon p1 p2)) + +not_op_pat :: Pat Name -> Bool +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat _ = True + +-------------------------------------- +checkPrecMatch :: Name -> MatchGroup Name body -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch op (MG { mg_alts = ms }) + = mapM_ check ms + where + check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _)) + = setSrcSpan (combineSrcSpans l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True + + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. + +checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do + op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (op, op_fix) + info1 = (unLoc op1, op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + unless inf_ok (precParseErr infol infor) + +checkPrec _ _ _ + = return () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr RdrName + -> LHsExpr Name -> LHsExpr Name -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp _ op fix _ -> go_for_it (get_op op) fix + NegApp _ _ -> go_for_it negateName negateFixity + _ -> return () + where + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do + op_fix@(Fixity op_prec _) <- lookupFixityRn op_name + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (op_name, op_fix) + (arg_op, arg_fix) section) + +-- Precedence-related error messages + +precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | isUnboundName n1 || isUnboundName n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ hang (ptext (sLit "Precedence parsing error")) + 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + ptext (sLit "in the same infix expression")]) + +sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM () +sectionPrecErr op@(n1,_) arg_op@(n2,_) section + | isUnboundName n1 || isUnboundName n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), + nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), + nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), + nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] + +ppr_opfix :: (Name, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | op == negateName = ptext (sLit "prefix `-'") + | otherwise = quotes (ppr op) + +{- +********************************************************* +* * +\subsection{Errors} +* * +********************************************************* +-} + +warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM () +warnUnusedForAlls in_doc bound mentioned_rdrs + = whenWOptM Opt_WarnUnusedMatches $ + mapM_ add_warn bound_but_not_used + where + bound_names = hsLTyVarLocNames bound + bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names + + add_warn (L loc tv) + = addWarnAt loc $ + vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) + , in_doc ] + +warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM () +warnContextQuantification in_doc tvs + = whenWOptM Opt_WarnContextQuantification $ + mapM_ add_warn tvs + where + add_warn (L loc tv) + = addWarnAt loc $ + vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+> + ptext (sLit "is implicitly quantified due to a context") $$ + ptext (sLit "Use explicit forall syntax instead.") $$ + ptext (sLit "This will become an error in GHC 7.12.") + , in_doc ] + +opTyErr :: RdrName -> HsType RdrName -> SDoc +opTyErr op ty@(HsOpTy ty1 _ _) + = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) + 2 extra + where + extra | op == dot_tv_RDR && forall_head ty1 + = perhapsForallMsg + | otherwise + = ptext (sLit "Use TypeOperators to allow operators in types") + + forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR + forall_head (L _ (HsAppTy ty _)) = forall_head ty + forall_head _other = False +opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) + +{- +************************************************************************ +* * + Finding the free type variables of a (HsType RdrName) +* * +************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type varaible and, more +recently, kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +In general we want to walk over a type, and find + * Its free type variables + * The free kind variables of any kind signatures in the type + +Hence we returns a pair (kind-vars, type vars) +See also Note [HsBSig binder lists] in HsTypes +-} + +type FreeKiTyVars = ([RdrName], [RdrName]) + +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env (kvs, tvs) + = (filterOut in_scope kvs, filterOut in_scope tvs) + where + in_scope tv = tv `elemLocalRdrEnv` rdr_env + +extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars +-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType +-- or the free (sort, kind) variables of a HsKind +-- It's used when making the for-alls explicit. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars ty + = case extract_lty ty ([],[]) of + (kvs, tvs) -> (nub kvs, nub tvs) + +extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars +-- See Note [Kind and type-variable binders] +extractHsTysRdrTyVars ty + = case extract_ltys ty ([],[]) of + (kvs, tvs) -> (nub kvs, nub tvs) + +extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName] +extractRdrKindSigVars Nothing = [] +extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[]))) + +extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName] +-- Get the scoped kind variables mentioned free in the constructor decls +-- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) +-- Here k should scope over the whole definition +extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig + , dd_cons = cons, dd_derivs = derivs }) + = fst $ extract_lctxt ctxt $ + extract_mb extract_lkind ksig $ + extract_mb (extract_ltys . unLoc) derivs $ + foldr (extract_con . unLoc) ([],[]) cons + where + extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc + extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs + , con_cxt = ctxt, con_details = details }) acc + = extract_hs_tv_bndrs qvs acc $ + extract_lctxt ctxt $ + extract_ltys (hsConDeclArgTys details) ([],[]) + + +extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars +extract_ltys tys acc = foldr extract_lty acc tys + +extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars +extract_mb _ Nothing acc = acc +extract_mb f (Just x) acc = f x acc + +extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of + (_, res_kvs) -> (res_kvs, acc_tvs) + -- Kinds shouldn't have sort signatures! + +extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lty (L _ ty) acc + = case ty of + HsTyVar tv -> extract_tv tv acc + HsBangTy _ ty -> extract_lty ty acc + HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc + flds + HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsListTy ty -> extract_lty ty acc + HsPArrTy ty -> extract_lty ty acc + HsTupleTy _ tys -> extract_ltys tys acc + HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsIParamTy _ ty -> extract_lty ty acc + HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) + HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc)) + HsParTy ty -> extract_lty ty acc + HsCoreTy {} -> acc -- The type is closed + HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables + HsSpliceTy {} -> acc -- Type splices mention no type variables + HsDocTy ty _ -> extract_lty ty acc + HsExplicitListTy _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ -> acc + HsWrapTy _ _ -> panic "extract_lty" + HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ + extract_lctxt cx $ + extract_lty ty ([],[]) + -- We deal with these to in a later stage, because they need to be + -- replaced by fresh HsTyVars. + HsWildcardTy -> acc + HsNamedWildcardTy _ -> acc + +extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars + -> FreeKiTyVars -> FreeKiTyVars +extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) + (acc_kvs, acc_tvs) -- Note accumulator comes first + (body_kvs, body_tvs) + | null tvs + = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) + | otherwise + = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs, + acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) + where + local_tvs = map hsLTyVarName tvs + (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs] + -- These kind variables are bound here if not bound further out + +extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_tv tv acc + | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs) + | otherwise = acc + +-- | Replace all unnamed wildcards in the given type with named wildcards. +-- These names are freshly generated, based on "_". Return a tuple of the +-- named wildcards that weren't already in scope (amongst them the named +-- wildcards the unnamed ones were converted into), and the type in which the +-- unnamed wildcards are replaced by named wildcards. +extractWildcards :: LHsType RdrName -> RnM ([Located RdrName], LHsType RdrName) +extractWildcards ty + = do { (nwcs, awcs, ty') <- go ty + ; rdr_env <- getLocalRdrEnv + -- Filter out named wildcards that are already in scope + ; let nwcs' = nubBy eqLocated $ filterOut (flip (elemLocalRdrEnv . unLoc) rdr_env) nwcs + ; return (nwcs' ++ awcs, ty') } + where + go orig@(L l ty) = case ty of + (HsForAllTy exp extra bndrs (L locCxt cxt) ty) -> + do (nwcs1, awcs1, cxt') <- extList cxt + (nwcs2, awcs2, ty') <- go ty + return (nwcs1 ++ nwcs2, awcs1 ++ awcs2, + L l (HsForAllTy exp extra bndrs (L locCxt cxt') ty')) + (HsAppTy ty1 ty2) -> go2 HsAppTy ty1 ty2 + (HsFunTy ty1 ty2) -> go2 HsFunTy ty1 ty2 + (HsListTy ty) -> go1 HsListTy ty + (HsPArrTy ty) -> go1 HsPArrTy ty + (HsTupleTy con tys) -> goList (HsTupleTy con) tys + (HsOpTy ty1 op ty2) -> go2 (\t1 t2 -> HsOpTy t1 op t2) ty1 ty2 + (HsParTy ty) -> go1 HsParTy ty + (HsIParamTy n ty) -> go1 (HsIParamTy n) ty + (HsEqTy ty1 ty2) -> go2 HsEqTy ty1 ty2 + (HsKindSig ty kind) -> go2 HsKindSig ty kind + (HsDocTy ty doc) -> go1 (flip HsDocTy doc) ty + (HsBangTy b ty) -> go1 (HsBangTy b) ty + (HsExplicitListTy ptk tys) -> goList (HsExplicitListTy ptk) tys + (HsExplicitTupleTy ptk tys) -> goList (HsExplicitTupleTy ptk) tys + HsWildcardTy -> do + uniq <- newUnique + let name = mkInternalName uniq (mkTyVarOcc "_") l + rdrName = nameRdrName name + return ([], [L l rdrName], L l $ HsNamedWildcardTy rdrName) + (HsNamedWildcardTy name) -> return ([L l name], [], orig) + -- HsQuasiQuoteTy, HsSpliceTy, HsRecTy, HsCoreTy, HsTyLit, HsWrapTy + _ -> return ([], [], orig) + where + go1 f t = do (nwcs, awcs, t') <- go t + return (nwcs, awcs, L l $ f t') + go2 f t1 t2 = + do (nwcs1, awcs1, t1') <- go t1 + (nwcs2, awcs2, t2') <- go t2 + return (nwcs1 ++ nwcs2, awcs1 ++ awcs2, L l $ f t1' t2') + extList l = do rec_res <- mapM go l + let (nwcs, awcs, tys') = + foldr (\(nwcs, awcs, ty) (nwcss, awcss, tys) -> + (nwcs ++ nwcss, awcs ++ awcss, ty : tys)) + ([], [], []) rec_res + return (nwcs, awcs, tys') + goList f tys = do (nwcs, awcs, tys') <- extList tys + return (nwcs, awcs, L l $ f tys') diff --git a/compiler/rename/rename.tex b/compiler/rename/rename.tex new file mode 100644 index 00000000..b3f8e1d7 --- /dev/null +++ b/compiler/rename/rename.tex @@ -0,0 +1,18 @@ +\documentstyle{report} +\input{lit-style} + +\begin{document} +\centerline{{\Large{rename}}} +\tableofcontents + +\input{Rename} % {Renaming and dependency analysis passes} +\input{RnSource} % {Main pass of renamer} +\input{RnMonad} % {The monad used by the renamer} +\input{RnEnv} % {Environment manipulation for the renamer monad} +\input{RnHsSyn} % {Specialisations of the @HsSyn@ syntax for the renamer} +\input{RnNames} % {Extracting imported and top-level names in scope} +\input{RnExpr} % {Renaming of expressions} +\input{RnBinds} % {Renaming and dependency analysis of bindings} +\input{RnIfaces} % {Cacheing and Renaming of Interfaces} + +\end{document} diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs new file mode 100644 index 00000000..fa517c2f --- /dev/null +++ b/compiler/simplCore/CSE.hs @@ -0,0 +1,336 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section{Common subexpression} +-} + +{-# LANGUAGE CPP #-} + +module CSE (cseProgram) where + +#include "HsVersions.h" + +import CoreSubst +import Var ( Var ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo, zapIdUsageInfo ) +import CoreUtils ( mkAltExpr + , exprIsTrivial + , stripTicksE, stripTicksT, stripTicksTopE, mkTick, mkTicks ) +import Type ( tyConAppArgs ) +import CoreSyn +import Outputable +import BasicTypes ( isAlwaysActive ) +import TrieMap + +import Data.List + +{- + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + x1 = C a b + x2 = C x1 b +we build up a reverse mapping: C a b -> x1 + C x1 b -> x2 +and apply that to the rest of the program. + +When we then see + y1 = C a b + y2 = C y1 b +we replace the C a b with x1. But then we *dont* want to +add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 +so that a subsequent binding + y2 = C y1 b +will get transformed to C x1 b, and then to x2. + +So we carry an extra var->var substitution which we apply *before* looking up in the +reverse mapping. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +We have to be careful about shadowing. +For example, consider + f = \x -> let y = x+x in + h = \x -> x+x + in ... + +Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no +shadowing, but it doesn't any more (it proved too hard), so we clone as we go. +We can simply add clones to the substitution already described. + +Note [Case binders 1] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... + +Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. +But that's not quite obvious. In general we want to keep it as (wild1:as), +but for CSE purpose that's a bad idea. + +So we add the binding (wild1 -> a) to the extra var->var mapping. +Notice this is exactly backwards to what the simplifier does, which is +to try to replaces uses of 'a' with uses of 'wild1' + +Note [Case binders 2] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + case (h x) of y -> ...(h x)... + +We'd like to replace (h x) in the alternative, by y. But because of +the preceding [Note: case binders 1], we only want to add the mapping + scrutinee -> case binder +to the reverse CSE mapping if the scrutinee is a non-trivial expression. +(If the scrutinee is a simple variable we want to add the mapping + case binder -> scrutinee +to the substitution + +Note [CSE for INLINE and NOINLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are some subtle interactions of CSE with functions that the user +has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.) +Consider + + yes :: Int {-# NOINLINE yes #-} + yes = undefined + + no :: Int {-# NOINLINE no #-} + no = undefined + + foo :: Int -> Int -> Int {-# NOINLINE foo #-} + foo m n = n + + {-# RULES "foo/no" foo no = id #-} + + bar :: Int -> Int + bar = foo yes + +We do not expect the rule to fire. But if we do CSE, then we risk +getting yes=no, and the rule does fire. Actually, it won't because +NOINLINE means that 'yes' will never be inlined, not even if we have +yes=no. So that's fine (now; perhaps in the olden days, yes=no would +have substituted even if 'yes' was NOINLINE. + +But we do need to take care. Consider + + {-# NOINLINE bar #-} + bar = -- Same rhs as foo + + foo = + +If CSE produces + foo = bar +then foo will never be inlined to (when it should be, if +is small). The conclusion here is this: + + We should not add + :-> bar + to the CSEnv if 'bar' has any constraints on when it can inline; + that is, if its 'activation' not always active. Otherwise we + might replace by 'bar', and then later be unable to see that it + really was . + +Note that we do not (currently) do CSE on the unfolding stored inside +an Id, even if is a 'stable' unfolding. That means that when an +unfolding happens, it is always faithful to what the stable unfolding +originally was. + + +Note [CSE for case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case f x of y { pat -> ...let y = f x in ... } +Then we can CSE the inner (f x) to y. In fact 'case' is like a strict +let-binding, and we can use cseRhs for dealing with the scrutinee. + +************************************************************************ +* * +\section{Common subexpression} +* * +************************************************************************ +-} + +cseProgram :: CoreProgram -> CoreProgram +cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds) + +cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) +cseBind env (NonRec b e) + = (env2, NonRec b'' e') + where + (env1, b') = addBinder env b + (env2, (b'', e')) = cseRhs env1 (b',e) + +cseBind env (Rec pairs) + = (env2, Rec pairs') + where + (bs,es) = unzip pairs + (env1, bs') = addRecBinders env bs + (env2, pairs') = mapAccumL cseRhs env1 (bs' `zip` es) + +cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, (OutBndr, OutExpr)) +cseRhs env (id',rhs) + = case lookupCSEnv env rhs'' of + Nothing + | always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs')) + | otherwise -> (env, (id', rhs')) + Just id + | always_active -> (extendCSSubst env id' id, (id', mkTicks ticks $ Var id)) + | otherwise -> (env, (id', mkTicks ticks $ Var id)) + -- In the Just case, we have + -- x = rhs + -- ... + -- x' = rhs + -- We are replacing the second binding with x'=x + -- and so must record that in the substitution so + -- that subsequent uses of x' are replaced with x, + -- See Trac #5996 + where + zapped_id = zapIdUsageInfo id' + -- Putting the Id into the environment makes it possible that + -- it'll become shared more than it is now, which would + -- invalidate (the usage part of) its demand info. This caused + -- Trac #100218. + -- Easiest thing is to zap the usage info; subsequently + -- performing late demand-analysis will restore it. Don't zap + -- the strictness info; it's not necessary to do so, and losing + -- it is bad for performance if you don't do late demand + -- analysis + + rhs' = cseExpr env rhs + + ticks = stripTicksT tickishFloatable rhs' + rhs'' = stripTicksE tickishFloatable rhs' + -- We don't want to lose the source notes when a common sub + -- expression gets eliminated. Hence we push all (!) of them on + -- top of the replaced sub-expression. This is probably not too + -- useful in practice, but upholds our semantics. + + always_active = isAlwaysActive (idInlineActivation id') + -- See Note [CSE for INLINE and NOINLINE] + +tryForCSE :: CSEnv -> InExpr -> OutExpr +tryForCSE env expr + | exprIsTrivial expr' = expr' -- No point + | Just smaller <- lookupCSEnv env expr'' = foldr mkTick (Var smaller) ticks + | otherwise = expr' + where + expr' = cseExpr env expr + expr'' = stripTicksE tickishFloatable expr' + ticks = stripTicksT tickishFloatable expr' + +cseExpr :: CSEnv -> InExpr -> OutExpr +cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) +cseExpr _ (Lit lit) = Lit lit +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Tick t e) = Tick t (cseExpr env e) +cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind env bind + in Let bind' (cseExpr env' e) +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr''' ty alts' + where + alts' = cseAlts env2 scrut' bndr bndr'' alts + (env1, bndr') = addBinder env bndr + bndr'' = zapIdOccInfo bndr' + -- The swizzling from Note [Case binders 2] may + -- cause a dead case binder to be alive, so we + -- play safe here and bring them all to life + (env2, (bndr''', scrut')) = cseRhs env1 (bndr'', scrut) + -- Note [CSE for case expressions] + +cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] + +cseAlts env scrut' bndr bndr' alts + = map cse_alt alts + where + scrut'' = stripTicksTopE tickishFloatable scrut' + (con_target, alt_env) + = case scrut'' of + Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] + -- map: bndr -> v' + + _ -> (bndr', extendCSEnv env scrut' bndr') -- See Note [Case binders 2] + -- map: scrut' -> bndr' + + arg_tys = tyConAppArgs (idType bndr) + + cse_alt (DataAlt con, args, rhs) + | not (null args) + -- Don't try CSE if there are no args; it just increases the number + -- of live vars. E.g. + -- case x of { True -> ....True.... } + -- Don't replace True by x! + -- Hence the 'null args', which also deal with literals and DEFAULT + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' con_expr con_target + con_expr = mkAltExpr (DataAlt con) args' arg_tys + + cse_alt (con, args, rhs) + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args + +{- +************************************************************************ +* * +\section{The CSE envt} +* * +************************************************************************ +-} + +type InExpr = CoreExpr -- Pre-cloning +type InBndr = CoreBndr +type InAlt = CoreAlt + +type OutExpr = CoreExpr -- Post-cloning +type OutBndr = CoreBndr +type OutAlt = CoreAlt + +data CSEnv = CS { cs_map :: CoreMap (OutExpr, Id) -- Key, value + , cs_subst :: Subst } + +emptyCSEnv :: CSEnv +emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe Id +lookupCSEnv (CS { cs_map = csmap }) expr + = case lookupCoreMap csmap expr of + Just (_,e) -> Just e + Nothing -> Nothing + +extendCSEnv :: CSEnv -> OutExpr -> Id -> CSEnv +extendCSEnv cse expr id + = cse { cs_map = extendCoreMap (cs_map cse) sexpr (sexpr,id) } + where sexpr = stripTicksE tickishFloatable expr + +csEnvSubst :: CSEnv -> Subst +csEnvSubst = cs_subst + +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x + +extendCSSubst :: CSEnv -> Id -> Id -> CSEnv +extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } + +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder cse v = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substBndrs (cs_subst cse) vs + +addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs new file mode 100644 index 00000000..1601dad3 --- /dev/null +++ b/compiler/simplCore/CallArity.hs @@ -0,0 +1,729 @@ +-- +-- Copyright (c) 2014 Joachim Breitner +-- + +module CallArity + ( callArityAnalProgram + , callArityRHS -- for testing + ) where + +import VarSet +import VarEnv +import DynFlags ( DynFlags ) + +import BasicTypes +import CoreSyn +import Id +import CoreArity ( typeArity ) +import CoreUtils ( exprIsHNF, exprIsTrivial ) +--import Outputable +import UnVarGraph +import Demand + +import Control.Arrow ( first, second ) + + +{- +%************************************************************************ +%* * + Call Arity Analyis +%* * +%************************************************************************ + +Note [Call Arity: The goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this analysis is to find out if we can eta-expand a local function, +based on how it is being called. The motivating example is this code, +which comes up when we implement foldl using foldr, and do list fusion: + + let go = \x -> let d = case ... of + False -> go (x+1) + True -> id + in \z -> d (x + z) + in go 1 0 + +If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of +partial function applications, which would be bad. + +The function `go` has a type of arity two, but only one lambda is manifest. +Furthermore, an analysis that only looks at the RHS of go cannot be sufficient +to eta-expand go: If `go` is ever called with one argument (and the result used +multiple times), we would be doing the work in `...` multiple times. + +So `callArityAnalProgram` looks at the whole let expression to figure out if +all calls are nice, i.e. have a high enough arity. It then stores the result in +the `calledArity` field of the `IdInfo` of `go`, which the next simplifier +phase will eta-expand. + +The specification of the `calledArity` field is: + + No work will be lost if you eta-expand me to the arity in `calledArity`. + +What we want to know for a variable +----------------------------------- + +For every let-bound variable we'd like to know: + 1. A lower bound on the arity of all calls to the variable, and + 2. whether the variable is being called at most once or possible multiple + times. + +It is always ok to lower the arity, or pretend that there are multiple calls. +In particular, "Minimum arity 0 and possible called multiple times" is always +correct. + + +What we want to know from an expression +--------------------------------------- + +In order to obtain that information for variables, we analyize expression and +obtain bits of information: + + I. The arity analysis: + For every variable, whether it is absent, or called, + and if called, which what arity. + + II. The Co-Called analysis: + For every two variables, whether there is a possibility that both are being + called. + We obtain as a special case: For every variables, whether there is a + possibility that it is being called twice. + +For efficiency reasons, we gather this information only for a set of +*interesting variables*, to avoid spending time on, e.g., variables from pattern matches. + +The two analysis are not completely independent, as a higher arity can improve +the information about what variables are being called once or multiple times. + +Note [Analysis I: The arity analyis] +------------------------------------ + +The arity analysis is quite straight forward: The information about an +expression is an + VarEnv Arity +where absent variables are bound to Nothing and otherwise to a lower bound to +their arity. + +When we analyize an expression, we analyize it with a given context arity. +Lambdas decrease and applications increase the incoming arity. Analysizing a +variable will put that arity in the environment. In lets or cases all the +results from the various subexpressions are lubed, which takes the point-wise +minimum (considering Nothing an infinity). + + +Note [Analysis II: The Co-Called analysis] +------------------------------------------ + +The second part is more sophisticated. For reasons explained below, it is not +sufficient to simply know how often an expression evalutes a variable. Instead +we need to know which variables are possibly called together. + +The data structure here is an undirected graph of variables, which is provided +by the abstract + UnVarGraph + +It is safe to return a larger graph, i.e. one with more edges. The worst case +(i.e. the least useful and always correct result) is the complete graph on all +free variables, which means that anything can be called together with anything +(including itself). + +Notation for the following: +C(e) is the co-called result for e. +G₁∪G₂ is the union of two graphs +fv is the set of free variables (conveniently the domain of the arity analysis result) +S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ } +S² is the complete graph on the set of variables S, S² = S×S +C'(e) is a variant for bound expression: + If e is called at most once, or it is and stays a thunk (after the analysis), + it is simply C(e). Otherwise, the expression can be called multiple times + and we return (fv e)² + +The interesting cases of the analysis: + * Var v: + No other variables are being called. + Return {} (the empty graph) + * Lambda v e, under arity 0: + This means that e can be evaluated many times and we cannot get + any useful co-call information. + Return (fv e)² + * Case alternatives alt₁,alt₂,...: + Only one can be execuded, so + Return (alt₁ ∪ alt₂ ∪...) + * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: + We get the results from both sides, with the argument evaluted at most once. + Additionally, anything called by e₁ can possibly be called with anything + from e₂. + Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂) + * App e₁ x: + As this is already in A-normal form, CorePrep will not separately lambda + bind (and hence share) x. So we conservatively assume multiple calls to x here + Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} + * Let v = rhs in body: + In addition to the results from the subexpressions, add all co-calls from + everything that the body calls together with v to everthing that is called + by v. + Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} + * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body + Tricky. + We assume that it is really mutually recursive, i.e. that every variable + calls one of the others, and that this is strongly connected (otherwise we + return an over-approximation, so that's ok), see note [Recursion and fixpointing]. + + Let V = {v₁,...vₙ}. + Assume that the vs have been analysed with an incoming demand and + cardinality consistent with the final result (this is the fixed-pointing). + Again we can use the results from all subexpressions. + In addition, for every variable vᵢ, we need to find out what it is called + with (call this set Sᵢ). There are two cases: + * If vᵢ is a function, we need to go through all right-hand-sides and bodies, + and collect every variable that is called together with any variable from V: + Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to + exclude it from this set: + Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) } + Finally, combine all this: + Return: C(body) ∪ + C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ + (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ) + +Using the result: Eta-Expansion +------------------------------- + +We use the result of these two analyses to decide whether we can eta-expand the +rhs of a let-bound variable. + +If the variable is already a function (exprIsHNF), and all calls to the +variables have a higher arity than the current manifest arity (i.e. the number +of lambdas), expand. + +If the variable is a thunk we must be careful: Eta-Expansion will prevent +sharing of work, so this is only safe if there is at most one call to the +function. Therefore, we check whether {v,v} ∈ G. + + Example: + + let n = case .. of .. -- A thunk! + in n 0 + n 1 + + vs. + + let n = case .. of .. + in case .. of T -> n 0 + F -> n 1 + + We are only allowed to eta-expand `n` if it is going to be called at most + once in the body of the outer let. So we need to know, for each variable + individually, that it is going to be called at most once. + + +Why the co-call graph? +---------------------- + +Why is it not sufficient to simply remember which variables are called once and +which are called multiple times? It would be in the previous example, but consider + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y + n 1) + False > n + in go 1 + False -> n + +vs. + + let n = case .. of .. + in case .. of + True -> let go = \y -> case .. of + True -> go (y+1) + False > n + in go 1 + False -> n + +In both cases, the body and the rhs of the inner let call n at most once. +But only in the second case that holds for the whole expression! The +crucial difference is that in the first case, the rhs of `go` can call +*both* `go` and `n`, and hence can call `n` multiple times as it recurses, +while in the second case find out that `go` and `n` are not called together. + + +Why co-call information for functions? +-------------------------------------- + +Although for eta-expansion we need the information only for thunks, we still +need to know whether functions are being called once or multiple times, and +together with what other functions. + + Example: + + let n = case .. of .. + f x = n (x+1) + in f 1 + f 2 + + vs. + + let n = case .. of .. + f x = n (x+1) + in case .. of T -> f 0 + F -> f 1 + + Here, the body of f calls n exactly once, but f itself is being called + multiple times, so eta-expansion is not allowed. + + +Note [Analysis type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The work-hourse of the analysis is the function `callArityAnal`, with the +following type: + + type CallArityRes = (UnVarGraph, VarEnv Arity) + callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + +and the following specification: + + ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr + + <=> + + Assume the expression `expr` is being passed `arity` arguments. Then it holds that + * The domain of `callArityEnv` is a subset of `interestingIds`. + * Any variable from `interestingIds` that is not mentioned in the `callArityEnv` + is absent, i.e. not called at all. + * Every call from `expr` to a variable bound to n in `callArityEnv` has at + least n value arguments. + * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`, + then in no execution of `expr` both are being called. + Furthermore, expr' is expr with the callArity field of the `IdInfo` updated. + + +Note [Which variables are interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The analysis would quickly become prohibitive expensive if we would analyse all +variables; for most variables we simply do not care about how often they are +called, i.e. variables bound in a pattern match. So interesting are variables that are + * top-level or let bound + * and possibly functions (typeArity > 0) + +Note [Taking boring variables into account] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If we decide that the variable bound in `let x = e1 in e2` is not interesting, +the analysis of `e2` will not report anything about `x`. To ensure that +`callArityBind` does still do the right thing we have to take that into account +everytime we would be lookup up `x` in the analysis result of `e2`. + * Instead of calling lookupCallArityRes, we return (0, True), indicating + that this variable might be called many times with no variables. + * Instead of checking `calledWith x`, we assume that everything can be called + with it. + * In the recursive case, when calclulating the `cross_calls`, if there is + any boring variable in the recursive group, we ignore all co-call-results + and directly go to a very conservative assumption. + +The last point has the nice side effect that the relatively expensive +integration of co-call results in a recursive groups is often skipped. This +helped to avoid the compile time blowup in some real-world code with large +recursive groups (#10293). + +Note [Recursion and fixpointing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For a mutually recursive let, we begin by + 1. analysing the body, using the same incoming arity as for the whole expression. + 2. Then we iterate, memoizing for each of the bound variables the last + analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes. + 3. We combine the analysis result from the body and the memoized results for + the arguments (if already present). + 4. For each variable, we find out the incoming arity and whether it is called + once, based on the the current analysis result. If this differs from the + memoized results, we re-analyse the rhs and update the memoized table. + 5. If nothing had to be reanalized, we are done. + Otherwise, repeat from step 3. + + +Note [Thunks in recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We never eta-expand a thunk in a recursive group, on the grounds that if it is +part of a recursive group, then it will be called multipe times. + +This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not +t1) in the follwing code: + + let go x = t1 + t1 = if ... then t2 else ... + t2 = if ... then go 1 else ... + in go 0 + +Detecting this would require finding out what variables are only ever called +from thunks. While this is certainly possible, we yet have to see this to be +relevant in the wild. + + +Note [Analysing top-level binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can eta-expand top-level-binds if they are not exported, as we see all calls +to them. The plan is as follows: Treat the top-level binds as nested lets around +a body representing “all external calls”, which returns a pessimistic +CallArityRes (the co-call graph is the complete graph, all arityies 0). + +Note [Trimming arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the Call Arity papers, we are working on an untyped lambda calculus with no +other id annotations, where eta-expansion is always possible. But this is not +the case for Core! + 1. We need to ensure the invariant + callArity e <= typeArity (exprType e) + for the same reasons that exprArity needs this invariant (see Note + [exprArity invariant] in CoreArity). + + If we are not doing that, a too-high arity annotation will be stored with + the id, confusing the simplifier later on. + + 2. Eta-expanding a right hand side might invalidate existing annotations. In + particular, if an id has a strictness annotation of <...><...>b, then + passing one argument to it will definitely bottom out, so the simplifier + will throw away additional parameters. This conflicts with Call Arity! So + we ensure that we never eta-expand such a value beyond the number of + arguments mentioned in the strictness signature. + See #10176 for a real-world-example. + +-} + +-- Main entry point + +callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram +callArityAnalProgram _dflags binds = binds' + where + (_, binds') = callArityTopLvl [] emptyVarSet binds + +-- See Note [Analysing top-level-binds] +callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind]) +callArityTopLvl exported _ [] + = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported]) + , [] ) +callArityTopLvl exported int1 (b:bs) + = (ae2, b':bs') + where + int2 = bindersOf b + exported' = filter isExportedId int2 ++ exported + int' = int1 `addInterestingBinds` b + (ae1, bs') = callArityTopLvl exported' int' bs + (ae2, b') = callArityBind (boringBinds b) ae1 int1 b + + +callArityRHS :: CoreExpr -> CoreExpr +callArityRHS = snd . callArityAnal 0 emptyVarSet + +-- The main analysis function. See Note [Analysis type signature] +callArityAnal :: + Arity -> -- The arity this expression is called with + VarSet -> -- The set of interesting variables + CoreExpr -> -- The expression to analyse + (CallArityRes, CoreExpr) + -- How this expression uses its interesting variables + -- and the expression with IdInfo updated + +-- The trivial base cases +callArityAnal _ _ e@(Lit _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Type _) + = (emptyArityRes, e) +callArityAnal _ _ e@(Coercion _) + = (emptyArityRes, e) +-- The transparent cases +callArityAnal arity int (Tick t e) + = second (Tick t) $ callArityAnal arity int e +callArityAnal arity int (Cast e co) + = second (\e -> Cast e co) $ callArityAnal arity int e + +-- The interesting case: Variables, Lambdas, Lets, Applications, Cases +callArityAnal arity int e@(Var v) + | v `elemVarSet` int + = (unitArityRes v arity, e) + | otherwise + = (emptyArityRes, e) + +-- Non-value lambdas are ignored +callArityAnal arity int (Lam v e) | not (isId v) + = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e + +-- We have a lambda that may be called multiple times, so its free variables +-- can all be co-called. +callArityAnal 0 int (Lam v e) + = (ae', Lam v e') + where + (ae, e') = callArityAnal 0 (int `delVarSet` v) e + ae' = calledMultipleTimes ae +-- We have a lambda that we are calling. decrease arity. +callArityAnal arity int (Lam v e) + = (ae, Lam v e') + where + (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e + +-- Application. Increase arity for the called expresion, nothing to know about +-- the second +callArityAnal arity int (App e (Type t)) + = second (\e -> App e (Type t)) $ callArityAnal arity int e +callArityAnal arity int (App e1 e2) + = (final_ae, App e1' e2') + where + (ae1, e1') = callArityAnal (arity + 1) int e1 + (ae2, e2') = callArityAnal 0 int e2 + -- If the argument is trivial (e.g. a variable), then it will _not_ be + -- let-bound in the Core to STG transformation (CorePrep actually), + -- so no sharing will happen here, and we have to assume many calls. + ae2' | exprIsTrivial e2 = calledMultipleTimes ae2 + | otherwise = ae2 + final_ae = ae1 `both` ae2' + +-- Case expression. +callArityAnal arity int (Case scrut bndr ty alts) + = -- pprTrace "callArityAnal:Case" + -- (vcat [ppr scrut, ppr final_ae]) + (final_ae, Case scrut' bndr ty alts') + where + (alt_aes, alts') = unzip $ map go alts + go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e + in (ae, (dc, bndrs, e')) + alt_ae = lubRess alt_aes + (scrut_ae, scrut') = callArityAnal 0 int scrut + -- See Note [Case and App: Which side to take?] + final_ae = scrut_ae `both` alt_ae + +-- For lets, use callArityBind +callArityAnal arity int (Let bind e) + = -- pprTrace "callArityAnal:Let" + -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ]) + (final_ae, Let bind' e') + where + int_body = int `addInterestingBinds` bind + (ae_body, e') = callArityAnal arity int_body e + (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind + +-- Which bindings should we look at? +-- See Note [Which variables are interesting] +isInteresting :: Var -> Bool +isInteresting v = 0 < length (typeArity (idType v)) + +interestingBinds :: CoreBind -> [Var] +interestingBinds = filter isInteresting . bindersOf + +boringBinds :: CoreBind -> VarSet +boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf + +addInterestingBinds :: VarSet -> CoreBind -> VarSet +addInterestingBinds int bind + = int `delVarSetList` bindersOf bind -- Possible shadowing + `extendVarSetList` interestingBinds bind + +-- Used for both local and top-level binds +-- Second argument is the demand from the body +callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind) +-- Non-recursive let +callArityBind boring_vars ae_body int (NonRec v rhs) + | otherwise + = -- pprTrace "callArityBind:NonRec" + -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity]) + (final_ae, NonRec v' rhs') + where + is_thunk = not (exprIsHNF rhs) + -- If v is boring, we will not find it in ae_body, but always assume (0, False) + boring = v `elemVarSet` boring_vars + + (arity, called_once) + | boring = (0, False) -- See Note [Taking boring variables into account] + | otherwise = lookupCallArityRes ae_body v + safe_arity | called_once = arity + | is_thunk = 0 -- A thunk! Do not eta-expand + | otherwise = arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity v safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs + + + ae_rhs'| called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + called_by_v = domRes ae_rhs' + called_with_v + | boring = domRes ae_body + | otherwise = calledWith ae_body v `delUnVarSet` v + final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body + + v' = v `setIdCallArity` trimmed_arity + + +-- Recursive let. See Note [Recursion and fixpointing] +callArityBind boring_vars ae_body int b@(Rec binds) + = -- (if length binds > 300 then + -- pprTrace "callArityBind:Rec" + -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ + (final_ae, Rec binds') + where + -- See Note [Taking boring variables into account] + any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds] + + int_body = int `addInterestingBinds` b + (ae_rhs, binds') = fix initial_binds + final_ae = bindersOf b `resDelList` ae_rhs + + initial_binds = [(i,Nothing,e) | (i,e) <- binds] + + fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) + fix ann_binds + | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ + any_change + = fix ann_binds' + | otherwise + = (ae, map (\(i, _, e) -> (i, e)) ann_binds') + where + aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ] + ae = callArityRecEnv any_boring aes_old ae_body + + rerun (i, mbLastRun, rhs) + | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae) + -- No call to this yet, so do nothing + = (False, (i, Nothing, rhs)) + + | Just (old_called_once, old_arity, _) <- mbLastRun + , called_once == old_called_once + , new_arity == old_arity + -- No change, no need to re-analize + = (False, (i, mbLastRun, rhs)) + + | otherwise + -- We previously analized this with a different arity (or not at all) + = let is_thunk = not (exprIsHNF rhs) + + safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups] + | otherwise = new_arity + + -- See Note [Trimming arity] + trimmed_arity = trimArity i safe_arity + + (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs + + ae_rhs' | called_once = ae_rhs + | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once + | otherwise = calledMultipleTimes ae_rhs + + in (True, (i `setIdCallArity` trimmed_arity, Just (called_once, new_arity, ae_rhs'), rhs')) + where + -- See Note [Taking boring variables into account] + (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False) + | otherwise = lookupCallArityRes ae i + + (changes, ann_binds') = unzip $ map rerun ann_binds + any_change = or changes + +-- Combining the results from body and rhs, (mutually) recursive case +-- See Note [Analysis II: The Co-Called analysis] +callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes +callArityRecEnv any_boring ae_rhss ae_body + = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $ + ae_new + where + vars = map fst ae_rhss + + ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body + + cross_calls + -- See Note [Taking boring variables into account] + | any_boring = completeGraph (domRes ae_combined) + -- Also, calculating cross_calls is expensive. Simply be conservative + -- if the mutually recursive group becomes too large. + | length ae_rhss > 25 = completeGraph (domRes ae_combined) + | otherwise = unionUnVarGraphs $ map cross_call ae_rhss + cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v + where + is_thunk = idCallArity v == 0 + -- What rhs are relevant as happening before (or after) calling v? + -- If v is a thunk, everything from all the _other_ variables + -- If v is not a thunk, everything can happen. + ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body + | otherwise = ae_combined + -- What do we want to know from these? + -- Which calls can happen next to any recursive call. + called_with_v + = unionUnVarSets $ map (calledWith ae_before_v) vars + called_by_v = domRes ae_rhs + + ae_new = first (cross_calls `unionUnVarGraph`) ae_combined + +-- See Note [Trimming arity] +trimArity :: Id -> Arity -> Arity +trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] + where + max_arity_by_type = length (typeArity (idType v)) + max_arity_by_strsig + | isBotRes result_info = length demands + | otherwise = a + + (demands, result_info) = splitStrictSig (idStrictness v) + +--------------------------------------- +-- Functions related to CallArityRes -- +--------------------------------------- + +-- Result type for the two analyses. +-- See Note [Analysis I: The arity analyis] +-- and Note [Analysis II: The Co-Called analysis] +type CallArityRes = (UnVarGraph, VarEnv Arity) + +emptyArityRes :: CallArityRes +emptyArityRes = (emptyUnVarGraph, emptyVarEnv) + +unitArityRes :: Var -> Arity -> CallArityRes +unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) + +resDelList :: [Var] -> CallArityRes -> CallArityRes +resDelList vs ae = foldr resDel ae vs + +resDel :: Var -> CallArityRes -> CallArityRes +resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) + +domRes :: CallArityRes -> UnVarSet +domRes (_, ae) = varEnvDom ae + +-- In the result, find out the minimum arity and whether the variable is called +-- at most once. +lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool) +lookupCallArityRes (g, ae) v + = case lookupVarEnv ae v of + Just a -> (a, not (v `elemUnVarSet` (neighbors g v))) + Nothing -> (0, False) + +calledWith :: CallArityRes -> Var -> UnVarSet +calledWith (g, _) v = neighbors g v + +addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes +addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`) + +-- Replaces the co-call graph by a complete graph (i.e. no information) +calledMultipleTimes :: CallArityRes -> CallArityRes +calledMultipleTimes res = first (const (completeGraph (domRes res))) res + +-- Used for application and cases +both :: CallArityRes -> CallArityRes -> CallArityRes +both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2 + +-- Used when combining results from alternative cases; take the minimum +lubRes :: CallArityRes -> CallArityRes -> CallArityRes +lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2) + +lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity +lubArityEnv = plusVarEnv_C min + +lubRess :: [CallArityRes] -> CallArityRes +lubRess = foldl lubRes emptyArityRes diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs new file mode 100644 index 00000000..e9c828da --- /dev/null +++ b/compiler/simplCore/CoreMonad.hs @@ -0,0 +1,880 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[CoreMonad]{The core pipeline monad} +-} + +{-# LANGUAGE CPP, UndecidableInstances #-} + +module CoreMonad ( + -- * Configuration of the core-to-core passes + CoreToDo(..), runWhen, runMaybe, + SimplifierMode(..), + FloatOutSwitches(..), + pprPassDetails, + + -- * Plugins + PluginPass, bindsOnlyPass, + + -- * Counting + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..), + + -- * The monad + CoreM, runCoreM, + + -- ** Reading from the monad + getHscEnv, getRuleBase, getModule, + getDynFlags, getOrigNameCache, getPackageFamInstEnv, + getPrintUnqualified, + + -- ** Writing to the monad + addSimplCount, + + -- ** Lifting into the monad + liftIO, liftIOWithCount, + liftIO1, liftIO2, liftIO3, liftIO4, + + -- ** Global initialization + reinitializeGlobals, + + -- ** Dealing with annotations + getAnnotations, getFirstAnnotations, + + -- ** Screen output + putMsg, putMsgS, errorMsg, errorMsgS, + fatalErrorMsg, fatalErrorMsgS, + debugTraceMsg, debugTraceMsgS, + dumpIfSet_dyn, + +#ifdef GHCI + -- * Getting 'Name's + thNameToGhcName +#endif + ) where + +#ifdef GHCI +import Name( Name ) +#endif +import CoreSyn +import HscTypes +import Module +import DynFlags +import StaticFlags +import Rules ( RuleBase ) +import BasicTypes ( CompilerPhase(..) ) +import Annotations + +import IOEnv hiding ( liftIO, failM, failWithM ) +import qualified IOEnv ( liftIO ) +import TcEnv ( tcLookupGlobal ) +import TcRnMonad ( initTcForLookup ) +import Var +import Outputable +import FastString +import qualified ErrUtils as Err +import Maybes +import UniqSupply +import UniqFM ( UniqFM, mapUFM, filterUFM ) +import MonadUtils + +import ListSetOps ( runs ) +import Data.List +import Data.Ord +import Data.Dynamic +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Word +import qualified Control.Applicative as A +import Control.Monad + +import Prelude hiding ( read ) + +#ifdef GHCI +import Control.Concurrent.MVar (MVar) +import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) +import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) +import qualified Language.Haskell.TH as TH +#else +saveLinkerGlobals :: IO () +saveLinkerGlobals = return () + +restoreLinkerGlobals :: () -> IO () +restoreLinkerGlobals () = return () +#endif + + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + Int -- Max iterations + SimplifierMode + | CoreDoPluginPass String PluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoStrictness + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoVectorisation + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier") + ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s + ppr CoreDoFloatInwards = ptext (sLit "Float inwards") + ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) + ppr CoreLiberateCase = ptext (sLit "Liberate case") + ppr CoreDoStaticArgs = ptext (sLit "Static argument") + ppr CoreDoCallArity = ptext (sLit "Called arity analysis") + ppr CoreDoStrictness = ptext (sLit "Demand analysis") + ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") + ppr CoreDoSpecialising = ptext (sLit "Specialise") + ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") + ppr CoreCSE = ptext (sLit "Common sub-expression") + ppr CoreDoVectorisation = ptext (sLit "Vectorisation") + ppr CoreDesugar = ptext (sLit "Desugar (before optimization)") + ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)") + ppr CoreTidy = ptext (sLit "Tidy Core") + ppr CorePrep = ptext (sLit "CorePrep") + ppr CoreDoPrintCore = ptext (sLit "Print core") + ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") + ppr CoreDoNothing = ptext (sLit "CoreDoNothing") + ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n + , ppr md ] +pprPassDetails _ = Outputable.empty + +data SimplifierMode -- See comments in SimplMonad + = SimplMode + { sm_names :: [String] -- Name(s) of the phase + , sm_phase :: CompilerPhase + , sm_rules :: Bool -- Whether RULES are enabled + , sm_inline :: Bool -- Whether inlining is enabled + , sm_case_case :: Bool -- Whether case-of-case is enabled + , sm_eta_expand :: Bool -- Whether eta-expansion is enabled + } + +instance Outputable SimplifierMode where + ppr (SimplMode { sm_phase = p, sm_names = ss + , sm_rules = r, sm_inline = i + , sm_eta_expand = eta, sm_case_case = cc }) + = ptext (sLit "SimplMode") <+> braces ( + sep [ ptext (sLit "Phase =") <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (sLit "inline") <> comma + , pp_flag r (sLit "rules") <> comma + , pp_flag eta (sLit "eta-expand") <> comma + , pp_flag cc (sLit "case-of-case") ]) + where + pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars + + floatOutConstants :: Bool, -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + floatOutOverSatApps :: Bool -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in SetLevels + } +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw + = ptext (sLit "FOS") <+> (braces $ + sep $ punctuate comma $ + [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw) + , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) + , ptext (sLit "OverSatApps =") <+> ppr (floatOutOverSatApps sw) ]) + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +{- +Note [RULEs enabled in SimplGently] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RULES are enabled when doing "gentle" simplification. Two reasons: + + * We really want the class-op cancellation to happen: + op (df d1 d2) --> $cop3 d1 d2 + because this breaks the mutual recursion between 'op' and 'df' + + * I wanted the RULE + lift String ===> ... + to work in Template Haskell when simplifying + splices, so we get simpler code for literal strings + +But watch out: list fusion can prevent floating. So use phase control +to switch off those rules until after floating. + + +************************************************************************ +* * + Types for Plugins +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type PluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +{- +************************************************************************ +* * + Counting and logging +* * +************************************************************************ +-} + +verboseSimplStats :: Bool +verboseSimplStats = opt_PprStyle_Debug -- For now, anyway + +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +-- Don't use Map.unionWith because that's lazy, and we want to +-- be pretty strict here! +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = case Map.lookup tick fm of + Nothing -> Map.insert tick 1 fm + Just n -> n1 `seq` Map.insert tick n1 fm + where + n1 = n+1 + + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount _ _ = panic "plusSimplCount" + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [ptext (sLit "Total ticks: ") <+> int tks, + blankLine, + pprTickCounts dts, + if verboseSimplStats then + vcat [blankLine, + ptext (sLit "Log (most recent first)"), + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [[(Tick,Int)]] -- Each group shares a comon tag + -- toList returns common tags adjacent + groups = runs same_tag (Map.toList counts) + same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 + +pprTickGroup :: [(Tick, Int)] -> SDoc +pprTickGroup group@((tick1,_):_) + = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) +pprTickGroup [] = panic "pprTickGroup" + +data Tick + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | BottomFound + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag BottomFound = 14 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString BottomFound = "BottomFound" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ + +{- +************************************************************************ +* * + Monad and carried data structure definitions +* * +************************************************************************ +-} + +newtype CoreState = CoreState { + cs_uniq_supply :: UniqSupply +} + +data CoreReader = CoreReader { + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, + cr_module :: Module, + cr_print_unqual :: PrintUnqualified, +#ifdef GHCI + cr_globals :: (MVar PersistentLinkerState, Bool) +#else + cr_globals :: () +#endif +} + +-- Note: CoreWriter used to be defined with data, rather than newtype. If it +-- is defined that way again, the cw_simpl_count field, at least, must be +-- strict to avoid a space leak (Trac #7702). +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +emptyWriter :: DynFlags -> CoreWriter +emptyWriter dflags = CoreWriter { + cw_simpl_count = zeroSimplCount dflags + } + +plusWriter :: CoreWriter -> CoreWriter -> CoreWriter +plusWriter w1 w2 = CoreWriter { + cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) + } + +type CoreIOEnv = IOEnv CoreReader + +-- | The monad used by Core-to-Core passes to access common state, register simplification +-- statistics and so on +newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) } + +instance Functor CoreM where + fmap f ma = do + a <- ma + return (f a) + +instance Monad CoreM where + return x = CoreM (\s -> nop s x) + mx >>= f = CoreM $ \s -> do + (x, s', w1) <- unCoreM mx s + (y, s'', w2) <- unCoreM (f x) s' + let w = w1 `plusWriter` w2 + return $ seq w (y, s'', w) + -- forcing w before building the tuple avoids a space leak + -- (Trac #7702) +instance A.Applicative CoreM where + pure = return + (<*>) = ap + (*>) = (>>) + +instance MonadPlus IO => A.Alternative CoreM where + empty = mzero + (<|>) = mplus + +-- For use if the user has imported Control.Monad.Error from MTL +-- Requires UndecidableInstances +instance MonadPlus IO => MonadPlus CoreM where + mzero = CoreM (const mzero) + m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs) + +instance MonadUnique CoreM where + getUniqueSupplyM = do + us <- getS cs_uniq_supply + let (us1, us2) = splitUniqSupply us + modifyS (\s -> s { cs_uniq_supply = us2 }) + return us1 + + getUniqueM = do + us <- getS cs_uniq_supply + let (u,us') = takeUniqFromSupply us + modifyS (\s -> s { cs_uniq_supply = us' }) + return u + +runCoreM :: HscEnv + -> RuleBase + -> UniqSupply + -> Module + -> PrintUnqualified + -> CoreM a + -> IO (a, SimplCount) +runCoreM hsc_env rule_base us mod print_unqual m = do + glbls <- saveLinkerGlobals + liftM extract $ runIOEnv (reader glbls) $ unCoreM m state + where + reader glbls = CoreReader { + cr_hsc_env = hsc_env, + cr_rule_base = rule_base, + cr_module = mod, + cr_globals = glbls, + cr_print_unqual = print_unqual + } + state = CoreState { + cs_uniq_supply = us + } + + extract :: (a, CoreState, CoreWriter) -> (a, SimplCount) + extract (value, _, writer) = (value, cw_simpl_count writer) + +{- +************************************************************************ +* * + Core combinators, not exported +* * +************************************************************************ +-} + +nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter) +nop s x = do + r <- getEnv + return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + +read :: (CoreReader -> a) -> CoreM a +read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r))) + +getS :: (CoreState -> a) -> CoreM a +getS f = CoreM (\s -> nop s (f s)) + +modifyS :: (CoreState -> CoreState) -> CoreM () +modifyS f = CoreM (\s -> nop (f s) ()) + +write :: CoreWriter -> CoreM () +write w = CoreM (\s -> return ((), s, w)) + +-- \subsection{Lifting IO into the monad} + +-- | Lift an 'IOEnv' operation into 'CoreM' +liftIOEnv :: CoreIOEnv a -> CoreM a +liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x)) + +instance MonadIO CoreM where + liftIO = liftIOEnv . IOEnv.liftIO + +-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' +liftIOWithCount :: IO (SimplCount, a) -> CoreM a +liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) + +{- +************************************************************************ +* * + Reader, writer and state accessors +* * +************************************************************************ +-} + +getHscEnv :: CoreM HscEnv +getHscEnv = read cr_hsc_env + +getRuleBase :: CoreM RuleBase +getRuleBase = read cr_rule_base + +getPrintUnqualified :: CoreM PrintUnqualified +getPrintUnqualified = read cr_print_unqual + +addSimplCount :: SimplCount -> CoreM () +addSimplCount count = write (CoreWriter { cw_simpl_count = count }) + +-- Convenience accessors for useful fields of HscEnv + +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv + +instance HasModule CoreM where + getModule = read cr_module + +-- | The original name cache is the current mapping from 'Module' and +-- 'OccName' to a compiler-wide unique 'Name' +getOrigNameCache :: CoreM OrigNameCache +getOrigNameCache = do + nameCacheRef <- fmap hsc_NC getHscEnv + liftIO $ fmap nsNames $ readIORef nameCacheRef + +getPackageFamInstEnv :: CoreM PackageFamInstEnv +getPackageFamInstEnv = do + hsc_env <- getHscEnv + eps <- liftIO $ hscEPS hsc_env + return $ eps_fam_inst_env eps + +{- +************************************************************************ +* * + Initializing globals +* * +************************************************************************ + +This is a rather annoying function. When a plugin is loaded, it currently +gets linked against a *newly loaded* copy of the GHC package. This would +not be a problem, except that the new copy has its own mutable state +that is not shared with that state that has already been initialized by +the original GHC package. + +(NB This mechanism is sufficient for granting plugins read-only access to +globals that are guaranteed to be initialized before the plugin is loaded. If +any further synchronization is necessary, I would suggest using the more +sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to +share a single instance of the global variable among the compiler and the +plugins. Perhaps we should migrate all global variables to use that mechanism, +for robustness... -- NSF July 2013) + +This leads to loaded plugins calling GHC code which pokes the static flags, +and then dying with a panic because the static flags *it* sees are uninitialized. + +There are two possible solutions: + 1. Export the symbols from the GHC executable from the GHC library and link + against this existing copy rather than a new copy of the GHC library + 2. Carefully ensure that the global state in the two copies of the GHC + library matches + +I tried 1. and it *almost* works (and speeds up plugin load times!) except +on Windows. On Windows the GHC library tends to export more than 65536 symbols +(see #5292) which overflows the limit of what we can export from the EXE and +causes breakage. + +(Note that if the GHC executable was dynamically linked this wouldn't be a +problem, because we could share the GHC library it links to.) + +We are going to try 2. instead. Unfortunately, this means that every plugin +will have to say `reinitializeGlobals` before it does anything, but never mind. + +I've threaded the cr_globals through CoreM rather than giving them as an +argument to the plugin function so that we can turn this function into +(return ()) without breaking any plugins when we eventually get 1. working. +-} + +reinitializeGlobals :: CoreM () +reinitializeGlobals = do + linker_globals <- read cr_globals + hsc_env <- getHscEnv + let dflags = hsc_dflags hsc_env + liftIO $ restoreLinkerGlobals linker_globals + liftIO $ setUnsafeGlobalDynFlags dflags + +{- +************************************************************************ +* * + Dealing with annotations +* * +************************************************************************ +-} + +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +-- +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. +-- +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per Unique. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +getFirstAnnotations deserialize guts + = liftM (mapUFM head . filterUFM (not . null)) + $ getAnnotations deserialize guts + +{- +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +************************************************************************ +* * + Direct screen output +* * +************************************************************************ +-} + +msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM () +msg how doc = do + dflags <- getDynFlags + liftIO $ how dflags doc + +-- | Output a String message to the screen +putMsgS :: String -> CoreM () +putMsgS = putMsg . text + +-- | Output a message to the screen +putMsg :: SDoc -> CoreM () +putMsg = msg Err.putMsg + +-- | Output a string error to the screen +errorMsgS :: String -> CoreM () +errorMsgS = errorMsg . text + +-- | Output an error to the screen +errorMsg :: SDoc -> CoreM () +errorMsg = msg Err.errorMsg + +-- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die +fatalErrorMsgS :: String -> CoreM () +fatalErrorMsgS = fatalErrorMsg . text + +-- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die +fatalErrorMsg :: SDoc -> CoreM () +fatalErrorMsg = msg Err.fatalErrorMsg + +-- | Output a string debugging message at verbosity level of @-v@ or higher +debugTraceMsgS :: String -> CoreM () +debugTraceMsgS = debugTraceMsg . text + +-- | Outputs a debugging message at verbosity level of @-v@ or higher +debugTraceMsg :: SDoc -> CoreM () +debugTraceMsg = msg (flip Err.debugTraceMsg 3) + +-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher +dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () +dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) + +{- +************************************************************************ +* * + Finding TyThings +* * +************************************************************************ +-} + +instance MonadThings CoreM where + lookupThing name = do + hsc_env <- getHscEnv + liftIO $ initTcForLookup hsc_env (tcLookupGlobal name) + +{- +************************************************************************ +* * + Template Haskell interoperability +* * +************************************************************************ +-} + +#ifdef GHCI +-- | Attempt to convert a Template Haskell name to one that GHC can +-- understand. Original TH names such as those you get when you use +-- the @'foo@ syntax will be translated to their equivalent GHC name +-- exactly. Qualified or unqualifed TH names will be dynamically bound +-- to names in the module being compiled, if possible. Exact TH names +-- will be bound to the name they represent, exactly. +thNameToGhcName :: TH.Name -> CoreM (Maybe Name) +thNameToGhcName th_name = do + hsc_env <- getHscEnv + liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name) +#endif diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs new file mode 100644 index 00000000..2f1b3187 --- /dev/null +++ b/compiler/simplCore/FloatIn.hs @@ -0,0 +1,561 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[FloatIn]{Floating Inwards pass} +* * +************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. +-} + +{-# LANGUAGE CPP #-} + +module FloatIn ( floatInwards ) where + +#include "HsVersions.h" + +import CoreSyn +import MkCore +import CoreUtils ( exprIsDupable, exprIsExpandable, exprType, + exprOkForSideEffects, mkTicks ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) +import Id ( isOneShotBndr, idType ) +import Var +import Type ( Type, isUnLiftedType, splitFunTy, applyTy ) +import VarSet +import Util +import UniqFM +import DynFlags +import Outputable +import Data.List( mapAccumL ) + +{- +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. +-} + +floatInwards :: DynFlags -> CoreProgram -> CoreProgram +floatInwards dflags = map fi_top_bind + where + fi_top_bind (NonRec binder rhs) + = NonRec binder (fiExpr dflags [] (freeVars rhs)) + fi_top_bind (Rec pairs) + = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] + +{- +************************************************************************ +* * +\subsection{Mail from Andr\'e [edited]} +* * +************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +SetLevels.lhs module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +************************************************************************ +* * +\subsection{Main floating-inwards code} +* * +************************************************************************ +-} + +type FreeVarSet = IdSet +type BoundVarSet = IdSet + +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +type FloatInBinds = [FloatInBind] + -- In reverse dependency order (innermost binder first) + +fiExpr :: DynFlags + -> FloatInBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co)) + = wrapFloats (drop_here ++ co_drop) $ + Cast (fiExpr dflags e_drop expr) co + where + [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop + +{- +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. +-} + +fiExpr dflags to_drop ann_expr@(_,AnnApp {}) + = mkTicks ticks $ wrapFloats drop_here $ wrapFloats extra_drop $ + mkApps (fiExpr dflags fun_drop ann_fun) + (zipWith (fiExpr dflags) arg_drops ann_args) + where + (ann_fun@(fun_fvs, _), ann_args, ticks) + = collectAnnArgsTicks tickishFloatable ann_expr + fun_ty = exprType (deAnnotate ann_fun) + ((_,extra_fvs), arg_fvs) = mapAccumL mk_arg_fvs (fun_ty, emptyVarSet) ann_args + + -- All this faffing about is so that we can get hold of + -- the types of the arguments, to pass to noFloatIntoRhs + mk_arg_fvs :: (Type, FreeVarSet) -> CoreExprWithFVs -> ((Type, FreeVarSet), FreeVarSet) + mk_arg_fvs (fun_ty, extra_fvs) (_, AnnType ty) + = ((applyTy fun_ty ty, extra_fvs), emptyVarSet) + + mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg) + | noFloatIntoRhs ann_arg arg_ty + = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet) + | otherwise + = ((res_ty, extra_fvs), arg_fvs) + where + (arg_ty, res_ty) = splitFunTy fun_ty + + drop_here : extra_drop : fun_drop : arg_drops + = sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop + +{- +Note [Do not destroy the let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Watch out for + f (x +# y) +We don't want to float bindings into here + f (case ... of { x -> x +# y }) +because that might destroy the let/app invariant, which requires +unlifted function arguments to be ok-for-speculation. + +Note [Floating in past a lambda group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We must be careful about floating inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +* Hack alert! We only float in through one-shot lambdas, + not (as you might guess) through lone big lambdas. + Reason: we float *out* past big lambdas (see the test in the Lam + case of FloatOut.floatExpr) and we don't want to float straight + back in again. + + It *is* important to float into one-shot lambdas, however; + see the remarks with noFloatIntoRhs. + +So we treat lambda in groups, using the following rule: + + Float in if (a) there is at least one Id, + and (b) there are no non-one-shot Ids + + Otherwise drop all the bindings outside the group. + +This is what the 'go' function in the AnnLam case is doing. + +Urk! if all are tyvars, and we don't float in, we may miss an + opportunity to float inside a nested case branch +-} + +fiExpr dflags to_drop lam@(_, AnnLam _ _) + | okToFloatInside bndrs -- Float in + -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088 + = mkLams bndrs (fiExpr dflags to_drop body) + + | otherwise -- Dump it all here + = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) + + where + (bndrs, body) = collectAnnBndrs lam + +{- +We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. +-} + +fiExpr dflags to_drop (_, AnnTick tickish expr) + | tickish `tickishScopesLike` SoftScope + = Tick tickish (fiExpr dflags to_drop expr) + + | otherwise -- Wimp out for now - we could push values in + = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) + +{- +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... v .. w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable further into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +Note [extra_fvs (1): avoid floating into RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider let x=\y....t... in body. We do not necessarily want to float +a binding for t into the RHS, because it'll immediately be floated out +again. (It won't go inside the lambda else we risk losing work.) +In letrec, we need to be more careful still. We don't want to transform + let x# = y# +# 1# + in + letrec f = \z. ...x#...f... + in ... +into + letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... +because now we can't float the let out again, because a letrec +can't have unboxed bindings. + +So we make "extra_fvs" which is the rhs_fvs of such bindings, and +arrange to dump bindings that bind extra_fvs before the entire let. + +Note [extra_fvs (2): free variables of rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x{rule mentioning y} = rhs in body +Here y is not free in rhs or body; but we still want to dump bindings +that bind y outside the let. So we augment extra_fvs with the +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. +-} + +fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) + = fiExpr dflags new_to_drop body + where + body_fvs = freeVarsOf body `delVarSet` id + rhs_ty = idType id + + rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] + extra_fvs | noFloatIntoRhs ann_rhs rhs_ty = rule_fvs `unionVarSet` rhs_fvs + | otherwise = rule_fvs + -- See Note [extra_fvs (1): avoid floating into RHS] + -- No point in floating in only to float straight out again + -- Ditto ok-for-speculation unlifted RHSs + + [shared_binds, extra_binds, rhs_binds, body_binds] + = sepBindsByDropPoint dflags False [extra_fvs, rhs_fvs, body_fvs] to_drop + + new_to_drop = body_binds ++ -- the bindings used only in the body + [FB (unitVarSet id) rhs_fvs' + (FloatLet (NonRec id rhs'))] ++ -- the new binding itself + extra_binds ++ -- bindings from extra_fvs + shared_binds -- the bindings used both in rhs and body + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiExpr dflags rhs_binds rhs + rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs + -- Don't forget the rule_fvs; the binding mentions them! + +fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) + = fiExpr dflags new_to_drop body + where + (ids, rhss) = unzip bindings + rhss_fvs = map freeVarsOf rhss + body_fvs = freeVarsOf body + + -- See Note [extra_fvs (1,2)] + rule_fvs = mapUnionVarSet idRuleAndUnfoldingVars ids + extra_fvs = rule_fvs `unionVarSet` + unionVarSets [ fvs | (fvs, rhs) <- rhss + , noFloatIntoExpr rhs ] + + (shared_binds:extra_binds:body_binds:rhss_binds) + = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop + + new_to_drop = body_binds ++ -- the bindings used only in the body + [FB (mkVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings)))] ++ + -- The new binding itself + extra_binds ++ -- Note [extra_fvs (1,2)] + shared_binds -- Used in more than one place + + rhs_fvs' = unionVarSets rhss_fvs `unionVarSet` + unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet` + rule_fvs -- Don't forget the rule variables! + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, CoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiExpr dflags to_drop rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] + +{- +For @Case@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~inside the scrutinee, (b)~inside one of the +alternatives/default [default FVs always {\em first}!]. + +Floating case expressions inward was added to fix Trac #5658: strict bindings +not floated in. In particular, this change allows array indexing operations, +which have a single DEFAULT alternative without any binders, to be floated +inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed +scalars also need to be floated inward, but unpacks have a single non-DEFAULT +alternative that binds the elements of the tuple. We now therefore also support +floating in cases with a single alternative that may bind values. +-} + +fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) + | isUnLiftedType (idType case_bndr) + , exprOkForSideEffects (deAnnotate scrut) + -- See PrimOp, Note [PrimOp can_fail and has_side_effects] + = wrapFloats shared_binds $ + fiExpr dflags (case_float : rhs_binds) rhs + where + case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs + (FloatCase scrut' case_bndr con alt_bndrs) + scrut' = fiExpr dflags scrut_binds scrut + [shared_binds, scrut_binds, rhs_binds] + = sepBindsByDropPoint dflags False [freeVarsOf scrut, rhs_fvs] to_drop + rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs) + scrut_fvs = freeVarsOf scrut + +fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ + Case (fiExpr dflags scrut_drops scrut) case_bndr ty + (zipWith fi_alt alts_drops_s alts) + where + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] + = sepBindsByDropPoint dflags False [scrut_fvs, all_alts_fvs] to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) = sepBindsByDropPoint dflags True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionVarSets alts_fvs + alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) + -- Delete case_bndr and args from free vars of rhs + -- to get free vars of alt + + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) + +okToFloatInside :: [Var] -> Bool +okToFloatInside bndrs = all ok bndrs + where + ok b = not (isId b) || isOneShotBndr b + -- Push the floats inside there are no non-one-shot value binders + +noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Type -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +-- Preconditio: rhs :: rhs_ty +noFloatIntoRhs rhs rhs_ty + = isUnLiftedType rhs_ty -- See Note [Do not destroy the let/app invariant] + || noFloatIntoExpr rhs + +noFloatIntoExpr :: AnnExpr' Var (UniqFM Var) -> Bool +noFloatIntoExpr (AnnLam bndr e) + = not (okToFloatInside (bndr:bndrs)) + -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088 + where + (bndrs, _) = collectAnnBndrs e + -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. + -- This makes a big difference for things like + -- f x# = let x = I# x# + -- in let j = \() -> ...x... + -- in if then normal-path else j () + -- If x is used only in the error case join point, j, we must float the + -- boxing constructor into it, else we box it every time which is very bad + -- news indeed. + +noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs) + -- We'd just float right back out again... + -- Should match the test in SimplEnv.doFloatFromRhs + +{- +************************************************************************ +* * +\subsection{@sepBindsByDropPoint@} +* * +************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. +-} + +sepBindsByDropPoint + :: DynFlags + -> Bool -- True <=> is case expression + -> [FreeVarSet] -- One set of FVs per drop point + -> FloatInBinds -- Candidate floaters + -> [FloatInBinds] -- FIRST one is bindings which must not be floated + -- inside any drop point; the rest correspond + -- one-to-one with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. + +type DropBox = (FreeVarSet, FloatInBinds) + +sepBindsByDropPoint _ _is_case drop_pts [] + = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens + +sepBindsByDropPoint dflags is_case drop_pts floaters + = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) + where + go :: FloatInBinds -> [DropBox] -> [FloatInBinds] + -- The *first* one in the argument list is the drop_here set + -- The FloatInBinds in the lists are in the reverse of + -- the normal FloatInBinds order; that is, they are the right way round! + + go [] drop_boxes = map (reverse . snd) drop_boxes + + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + (used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs + | (fvs, _) <- drop_boxes] + + drop_here = used_here || not can_push + + -- For case expressions we duplicate the binding if it is + -- reasonably small, and if it is not used in all the RHSs + -- This is good for situations like + -- let x = I# y in + -- case e of + -- C -> error x + -- D -> error x + -- E -> ...not mentioning x... + + n_alts = length used_in_flags + n_used_alts = count id used_in_flags -- returns number of Trues in list. + + can_push = n_used_alts == 1 -- Used in just one branch + || (is_case && -- We are looking at case alternatives + n_used_alts > 1 && -- It's used in more than one + n_used_alts < n_alts && -- ...but not all + floatIsDupable dflags bind) -- and we can duplicate the binding + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + go _ _ = panic "sepBindsByDropPoint/go" + + +floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs binds = mapUnionVarSet fbFVs binds + +fbFVs :: FloatInBind -> VarSet +fbFVs (FB _ fvs _) = fvs + +wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr +-- Remember FloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) + +floatIsDupable :: DynFlags -> FloatBind -> Bool +floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut +floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs +floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs new file mode 100644 index 00000000..7f920a23 --- /dev/null +++ b/compiler/simplCore/FloatOut.hs @@ -0,0 +1,592 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[FloatOut]{Float bindings outwards (towards the top level)} + +``Long-distance'' floating of bindings towards the top level. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module FloatOut ( floatOutwards ) where + +import CoreSyn +import CoreUtils +import MkCore +import CoreArity ( etaExpand ) +import CoreMonad ( FloatOutSwitches(..) ) + +import DynFlags +import ErrUtils ( dumpIfSet_dyn ) +import Id ( Id, idArity, isBottomingId ) +import Var ( Var ) +import SetLevels +import UniqSupply ( UniqSupply ) +import Bag +import Util +import Maybes +import Outputable +import FastString +import qualified Data.IntMap as M + +#include "HsVersions.h" + +{- + ----------------- + Overall game plan + ----------------- + +The Big Main Idea is: + + To float out sub-expressions that can thereby get outside + a non-one-shot value lambda, and hence may be shared. + + +To achieve this we may need to do two thing: + + a) Let-bind the sub-expression: + + f (g x) ==> let lvl = f (g x) in lvl + + Now we can float the binding for 'lvl'. + + b) More than that, we may need to abstract wrt a type variable + + \x -> ... /\a -> let v = ...a... in .... + + Here the binding for v mentions 'a' but not 'x'. So we + abstract wrt 'a', to give this binding for 'v': + + vp = /\a -> ...a... + v = vp a + + Now the binding for vp can float out unimpeded. + I can't remember why this case seemed important enough to + deal with, but I certainly found cases where important floats + didn't happen if we did not abstract wrt tyvars. + +With this in mind we can also achieve another goal: lambda lifting. +We can make an arbitrary (function) binding float to top level by +abstracting wrt *all* local variables, not just type variables, leaving +a binding that can be floated right to top level. Whether or not this +happens is controlled by a flag. + + +Random comments +~~~~~~~~~~~~~~~ + +At the moment we never float a binding out to between two adjacent +lambdas. For example: + +@ + \x y -> let t = x+x in ... +===> + \x -> let t = x+x in \y -> ... +@ +Reason: this is less efficient in the case where the original lambda +is never partially applied. + +But there's a case I've seen where this might not be true. Consider: +@ +elEm2 x ys + = elem' x ys + where + elem' _ [] = False + elem' x (y:ys) = x==y || elem' x ys +@ +It turns out that this generates a subexpression of the form +@ + \deq x ys -> let eq = eqFromEqDict deq in ... +@ +vwhich might usefully be separated to +@ + \deq -> let eq = eqFromEqDict deq in \xy -> ... +@ +Well, maybe. We don't do this at the moment. + + +************************************************************************ +* * +\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} +* * +************************************************************************ +-} + +floatOutwards :: FloatOutSwitches + -> DynFlags + -> UniqSupply + -> CoreProgram -> IO CoreProgram + +floatOutwards float_sws dflags us pgm + = do { + let { annotated_w_levels = setLevels float_sws pgm us ; + (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) + } ; + + dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + (vcat (map ppr annotated_w_levels)); + + let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; + + dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + (hcat [ int tlets, ptext (sLit " Lets floated to top level; "), + int ntlets, ptext (sLit " Lets floated elsewhere; from "), + int lams, ptext (sLit " Lambda groups")]); + + return (bagToList (unionManyBags binds_s')) + } + +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) +floatTopBind bind + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + Rec prs -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + NonRec {} -> (fs, float_bag `snocBag` bind') } + +{- +************************************************************************ +* * +\subsection[FloatOut-Bind]{Floating in a binding (the business end)} +* * +************************************************************************ +-} + +floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind) +floatBind (NonRec (TB var _) rhs) + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + + -- A tiresome hack: + -- see Note [Bottoming floats: eta expansion] in SetLevels + let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' + | otherwise = rhs' + + in (fs, rhs_floats, NonRec var rhs'') } + +floatBind (Rec pairs) + = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> + (fs, rhs_floats, Rec (concat new_pairs)) } + where + do_pair (TB name spec, rhs) + | isTopLvl dest_lvl -- See Note [floatBind for top level] + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + (fs, emptyFloats, addTopFloatPairs (flattenTopFloats rhs_floats) [(name, rhs')])} + | otherwise -- Note [Floating out of Rec rhss] + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (pairs, case_heres) -> + (fs, rhs_floats', (name, installUnderLambdas case_heres rhs') : pairs) }}} + where + dest_lvl = floatSpecLevel spec + +splitRecFloats :: Bag FloatBind -> ([(Id,CoreExpr)], Bag FloatBind) +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] (bagToList fs) + where + go prs (FloatLet (NonRec b r) : fs) = go ((b,r):prs) fs + go prs (FloatLet (Rec prs') : fs) = go (prs' ++ prs) fs + go prs fs = (prs, listToBag fs) + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go e = install floats e + +--------------- +floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) +floatList _ [] = (zeroStats, emptyFloats, []) +floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> + case floatList f as of { (fs_as, binds_as, bs) -> + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} + +{- +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See Trac #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + +Note [floatBind for top level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + + +************************************************************************ + +\subsection[FloatOut-Expr]{Floating in expressions} +* * +************************************************************************ +-} + +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here + (fsa, floats', install heres arg') }} + +----------------- + +{- Note [Floating past breakpoints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Notes from Peter Wortmann (re: #10052) + +"This case clearly means we're trying to float past a breakpoint..." + +Further: + +"Breakpoints as they currently exist are the only Tikish that is not +scoped, counting, and not splittable. + +This means that we can't: + - Simply float code out of it, because the payload must still be covered (scoped) + - Copy the tick, because it would change entry counts (here: duplicate breakpoints)" + +While this seems like an odd case, it can apparently occur in real +life: through the combination of optimizations + GHCi usage. For an +example, see #10052 as mentioned above. So not only does the +interpreter not like some compiler-generated things (like unboxed +tuples), the compiler doesn't like interpreter-introduced things! + +Also see Note [GHCi and -O] in GHC.hs. +-} + +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) + +floatExpr (App e a) + = case (floatExpr e) of { (fse, floats_e, e') -> + case (floatExpr a) of { (fsa, floats_a, a') -> + (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} + +floatExpr lam@(Lam (TB _ lam_spec) _) + = let (bndrs_w_lvls, body) = collectBinders lam + bndrs = [b | TB b _ <- bndrs_w_lvls] + bndr_lvl = floatSpecLevel lam_spec + -- All the binders have the same level + -- See SetLevels.lvlLamBndrs + in + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } + +floatExpr (Tick tickish expr) + | tickish `tickishScopesLike` SoftScope -- not scoped, can just float + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Tick tickish expr') } + + | not (tickishCounts tickish) || tickishCanSplit tickish + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + let -- Annotate bindings floated outwards past an scc expression + -- with the cc. We mark that cc as "duplicated", though. + annotated_defns = wrapTick (mkNoCount tickish) floating_defns + in + (fs, annotated_defns, Tick tickish expr') } + + -- Note [Floating past breakpoints] + | otherwise + = pprPanic "floatExpr tick" (ppr tickish) + +floatExpr (Cast expr co) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, Cast expr' co) } + +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatExpr body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` unitLetFloat dest_lvl bind' + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , Let bind' body') }} + where + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [(con@(DataAlt {}), bndrs, rhs)] <- alts + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (con, bs, rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } + +{- +Note [Avoiding unnecessary floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we want to avoid floating a let unnecessarily, because +it might worsen strictness: + let + x = ...(let y = e in y+y).... +Here y is demanded. If we float it outside the lazy 'x=..' then +we'd have to zap its demand info, and it may never be restored. + +So at a 'let' we leave the binding right where the are unless +the binding will escape a value lambda, e.g. + +(\x -> let y = fac 100 in y) + +That's what the partitionByMajorLevel does in the floatExpr (Let ...) +case. + +Notice, though, that we must take care to drop any bindings +from the body of the let that depend on the staying-put bindings. + +We used instead to do the partitionByMajorLevel on the RHS of an '=', +in floatRhs. But that was quite tiresome. We needed to test for +values or trival rhss, because (in particular) we don't want to insert +new bindings between the "=" and the "\". E.g. + f = \x -> let in +We do not want + f = let in \x -> +(a) The simplifier will immediately float it further out, so we may + as well do so right now; in general, keeping rhss as manifest + values is good +(b) If a float-in pass follows immediately, it might add yet more + bindings just after the '='. And some of them might (correctly) + be strict even though the 'let f' is lazy, because f, being a value, + gets its demand-info zapped by the simplifier. +And even all that turned out to be very fragile, and broke +altogether when profiling got in the way. + +So now we do the partition right at the (Let..) itself. + +************************************************************************ +* * +\subsection{Utility bits for floating stats} +* * +************************************************************************ + +I didn't implement this with unboxed numbers. I don't want to be too +strict in this stuff, as it is rarely turned on. (WDP 95/09) +-} + +data FloatStats + = FlS Int -- Number of top-floats * lambda groups they've been past + Int -- Number of non-top-floats * lambda groups they've been past + Int -- Number of lambda (groups) seen + +get_stats :: FloatStats -> (Int, Int, Int) +get_stats (FlS a b c) = (a, b, c) + +zeroStats :: FloatStats +zeroStats = FlS 0 0 0 + +sum_stats :: [FloatStats] -> FloatStats +sum_stats xs = foldr add_stats zeroStats xs + +add_stats :: FloatStats -> FloatStats -> FloatStats +add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) + = FlS (a1 + a2) (b1 + b2) (c1 + c2) + +add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats (FlS a b c) (FB tops others) + = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1) + +{- +************************************************************************ +* * +\subsection{Utility bits for floating} +* * +************************************************************************ + +Note [Representation of FloatBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatBinds types is somewhat important. We can get very large numbers +of floating bindings, often all destined for the top level. A typical example +is x = [4,2,5,2,5, .... ] +Then we get lots of small expressions like (fromInteger 4), which all get +lifted to top level. + +The trouble is that + (a) we partition these floating bindings *at every binding site* + (b) SetLevels introduces a new bindings site for every float +So we had better not look at each binding at each binding site! + +That is why MajorEnv is represented as a finite map. + +We keep the bindings destined for the *top* level separate, because +we float them out even if they don't escape a *value* lambda; see +partitionByMajorLevel. +-} + +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level + +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !MajorEnv -- Levels other than top + -- See Note [Representation of FloatBinds] + +instance Outputable FloatBinds where + ppr (FB fbs defs) + = ptext (sLit "FB") <+> (braces $ vcat + [ ptext (sLit "tops =") <+> ppr fbs + , ptext (sLit "non-tops =") <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops defs) + = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldrBag add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 + +flattenMajor :: MajorEnv -> Bag FloatBind +flattenMajor = M.fold (unionBags . flattenMinor) emptyBag + +flattenMinor :: MinorEnv -> Bag FloatBind +flattenMinor = M.fold unionBags emptyBag + +emptyFloats :: FloatBinds +emptyFloats = FB emptyBag M.empty + +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor) e b con bs + = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor) b + | isTopLvl lvl = FB (unitBag b) M.empty + | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) + +plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats (FB t1 l1) (FB t2 l2) + = FB (t1 `unionBags` t2) (l1 `plusMajor` l2) + +plusMajor :: MajorEnv -> MajorEnv -> MajorEnv +plusMajor = M.unionWith plusMinor + +plusMinor :: MinorEnv -> MinorEnv -> MinorEnv +plusMinor = M.unionWith unionBags + +install :: Bag FloatBind -> CoreExpr -> CoreExpr +install defn_groups expr + = foldrBag wrapFloat expr defn_groups + +partitionByLevel + :: Level -- Partitioning level + -> FloatBinds -- Defns to be divided into 2 piles... + -> (FloatBinds, -- Defns with level strictly < partition level, + Bag FloatBind) -- The rest + +{- +-- ---- partitionByMajorLevel ---- +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- +-- If we can get to the top level, say "yes" anyway. This means that +-- x = f e +-- transforms to +-- lvl = e +-- x = f lvl +-- which is as it should be + +partitionByMajorLevel (Level major _) (FB tops defns) + = (FB tops outer, heres `unionBags` flattenMajor inner) + where + (outer, mb_heres, inner) = M.splitLookup major defns + heres = case mb_heres of + Nothing -> emptyBag + Just h -> flattenMinor h +-} + +partitionByLevel (Level major minor) (FB tops defns) + = (FB tops (outer_maj `plusMajor` M.singleton major outer_min), + here_min `unionBags` flattenMinor inner_min + `unionBags` flattenMajor inner_maj) + + where + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns + (outer_min, mb_here_min, inner_min) = case mb_here_maj of + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns + here_min = mb_here_min `orElse` emptyBag + +wrapTick :: Tickish Id -> FloatBinds -> FloatBinds +wrapTick t (FB tops defns) + = FB (mapBag wrap_bind tops) (M.map (M.map wrap_defns) defns) + where + wrap_defns = mapBag wrap_one + + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + -- we don't need to wrap a tick around an HNF when we float it + -- outside a tick: that is an invariant of the tick semantics + -- Conversely, inlining of HNFs inside an SCC is allowed, and + -- indeed the HNF we're floating here might well be inlined back + -- again, and we don't want to end up with duplicate ticks. diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs new file mode 100644 index 00000000..1df14053 --- /dev/null +++ b/compiler/simplCore/LiberateCase.hs @@ -0,0 +1,408 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} +-} + +{-# LANGUAGE CPP #-} +module LiberateCase ( liberateCase ) where + +#include "HsVersions.h" + +import DynFlags +import CoreSyn +import CoreUnfold ( couldBeSmallEnoughToInline ) +import Id +import VarEnv +import Util ( notNull ) + +{- +The liberate-case transformation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module walks over @Core@, and looks for @case@ on free variables. +The criterion is: + if there is case on a free on the route to the recursive call, + then the recursive call is replaced with an unfolding. + +Example + + f = \ t -> case v of + V a b -> a : f t + +=> the inner f is replaced. + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> case v of + V a b -> a : f t + in f) t +(note the NEED for shadowing) + +=> Simplify + + f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> a : f t + in f t) + +Better code, because 'a' is free inside the inner letrec, rather +than needing projection from v. + +Note that this deals with *free variables*. SpecConstr deals with +*arguments* that are of known form. E.g. + + last [] = error + last (x:[]) = x + last (x:xs) = last xs + + +Note [Scrutinee with cast] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + f = \ t -> case (v `cast` co) of + V a b -> a : f t + +Exactly the same optimisation (unrolling one call to f) will work here, +despite the cast. See mk_alt_env in the Case branch of libCase. + + +Note [Only functions!] +~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code + + f = g (case v of V a b -> a : t f) + +where g is expensive. If we aren't careful, liberate case will turn this into + + f = g (case v of + V a b -> a : t (letrec f = g (case v of V a b -> a : f t) + in f) + ) + +Yikes! We evaluate g twice. This leads to a O(2^n) explosion +if g calls back to the same code recursively. + +Solution: make sure that we only do the liberate-case thing on *functions* + +To think about (Apr 94) +~~~~~~~~~~~~~~ +Main worry: duplicating code excessively. At the moment we duplicate +the entire binding group once at each recursive call. But there may +be a group of recursive calls which share a common set of evaluated +free variables, in which case the duplication is a plain waste. + +Another thing we could consider adding is some unfold-threshold thing, +so that we'll only duplicate if the size of the group rhss isn't too +big. + +Data types +~~~~~~~~~~ +The ``level'' of a binder tells how many +recursive defns lexically enclose the binding +A recursive defn "encloses" its RHS, not its +scope. For example: +\begin{verbatim} + letrec f = let g = ... in ... + in + let h = ... + in ... +\end{verbatim} +Here, the level of @f@ is zero, the level of @g@ is one, +and the level of @h@ is zero (NB not one). + + +************************************************************************ +* * + Top-level code +* * +************************************************************************ +-} + +liberateCase :: DynFlags -> CoreProgram -> CoreProgram +liberateCase dflags binds = do_prog (initEnv dflags) binds + where + do_prog _ [] = [] + do_prog env (bind:binds) = bind' : do_prog env' binds + where + (env', bind') = libCaseBind env bind + +{- +************************************************************************ +* * + Main payload +* * +************************************************************************ + +Bindings +~~~~~~~~ +-} + +libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind) + +libCaseBind env (NonRec binder rhs) + = (addBinders env [binder], NonRec binder (libCase env rhs)) + +libCaseBind env (Rec pairs) + = (env_body, Rec pairs') + where + binders = map fst pairs + + env_body = addBinders env binders + + pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] + + -- We extend the rec-env by binding each Id to its rhs, first + -- processing the rhs with an *un-extended* environment, so + -- that the same process doesn't occur for ever! + env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs + , rhs_small_enough binder rhs ] + -- localiseID : see Note [Need to localiseId in libCaseBind] + + + rhs_small_enough id rhs -- Note [Small enough] + = idArity id > 0 -- Note [Only functions!] + && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs) + (bombOutSize env) + +{- +Note [Need to localiseId in libCaseBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The call to localiseId is needed for two subtle reasons +(a) Reset the export flags on the binders so + that we don't get name clashes on exported things if the + local binding floats out to top level. This is most unlikely + to happen, since the whole point concerns free variables. + But resetting the export flag is right regardless. + +(b) Make the name an Internal one. External Names should never be + nested; if it were floated to the top level, we'd get a name + clash at code generation time. + +Note [Small enough] +~~~~~~~~~~~~~~~~~~~ +Consider + \fv. letrec + f = \x. BIG...(case fv of { (a,b) -> ...g.. })... + g = \y. SMALL...f... +Then we *can* do liberate-case on g (small RHS) but not for f (too big). +But we can choose on a item-by-item basis, and that's what the +rhs_small_enough call in the comprehension for env_rhs does. + +Expressions +~~~~~~~~~~~ +-} + +libCase :: LibCaseEnv + -> CoreExpr + -> CoreExpr + +libCase env (Var v) = libCaseId env v +libCase _ (Lit lit) = Lit lit +libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co +libCase env (App fun arg) = App (libCase env fun) (libCase env arg) +libCase env (Tick tickish body) = Tick tickish (libCase env body) +libCase env (Cast e co) = Cast (libCase env e) co + +libCase env (Lam binder body) + = Lam binder (libCase (addBinders env [binder]) body) + +libCase env (Let bind body) + = Let bind' (libCase env_body body) + where + (env_body, bind') = libCaseBind env bind + +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + where + env_alts = addBinders (mk_alt_env scrut) [bndr] + mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var + mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] + mk_alt_env _ = env + +libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) + -> (AltCon, [CoreBndr], CoreExpr) +libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) + +{- +Ids +~~~ +-} + +libCaseId :: LibCaseEnv -> Id -> CoreExpr +libCaseId env v + | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing + , notNull free_scruts -- with free vars scrutinised in RHS + = Let the_bind (Var v) + + | otherwise + = Var v + + where + rec_id_level = lookupLevel env v + free_scruts = freeScruts env rec_id_level + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> [Id] -- Ids that are scrutinised between the binding + -- of the recursive Id and here +freeScruts env rec_bind_lvl + = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env + , scrut_bind_lvl <= rec_bind_lvl + , scrut_at_lvl > rec_bind_lvl] + -- Note [When to specialise] + -- Note [Avoiding fruitless liberate-case] + +{- +Note [When to specialise] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x. letrec g = \y. case x of + True -> ... (f a) ... + False -> ... (g b) ... + +We get the following levels + f 0 + x 1 + g 1 + y 2 + +Then 'x' is being scrutinised at a deeper level than its binding, so +it's added to lc_sruts: [(x,1)] + +We do *not* want to specialise the call to 'f', because 'x' is not free +in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). + +We *do* want to specialise the call to 'g', because 'x' is free in g. +Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). + +Note [Avoiding fruitless liberate-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider also: + f = \x. case top_lvl_thing of + I# _ -> let g = \y. ... g ... + in ... + +Here, top_lvl_thing is scrutinised at a level (1) deeper than its +binding site (0). Nevertheless, we do NOT want to specialise the call +to 'g' because all the structure in its free variables is already +visible at the definition site for g. Hence, when considering specialising +an occurrence of 'g', we want to check that there's a scruted-var v st + + a) v's binding site is *outside* g + b) v's scrutinisation site is *inside* g + + +************************************************************************ +* * + Utility functions +* * +************************************************************************ +-} + +addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv +addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders + = env { lc_lvl_env = lvl_env' } + where + lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl) + +addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv +addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_rec_env = rec_env}) pairs + = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' } + where + lvl' = lvl + 1 + lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs] + +addScrutedVar :: LibCaseEnv + -> Id -- This Id is being scrutinised by a case expression + -> LibCaseEnv + +addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, + lc_scruts = scruts }) scrut_var + | bind_lvl < lvl + = env { lc_scruts = scruts' } + -- Add to scruts iff the scrut_var is being scrutinised at + -- a deeper level than its defn + + | otherwise = env + where + scruts' = (scrut_var, bind_lvl, lvl) : scruts + bind_lvl = case lookupVarEnv lvl_env scrut_var of + Just lvl -> lvl + Nothing -> topLevel + +lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind +lookupRecId env id = lookupVarEnv (lc_rec_env env) id + +lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel +lookupLevel env id + = case lookupVarEnv (lc_lvl_env env) id of + Just lvl -> lvl + Nothing -> topLevel + +{- +************************************************************************ +* * + The environment +* * +************************************************************************ +-} + +type LibCaseLevel = Int + +topLevel :: LibCaseLevel +topLevel = 0 + +data LibCaseEnv + = LibCaseEnv { + lc_dflags :: DynFlags, + + lc_lvl :: LibCaseLevel, -- Current level + -- The level is incremented when (and only when) going + -- inside the RHS of a (sufficiently small) recursive + -- function. + + lc_lvl_env :: IdEnv LibCaseLevel, + -- Binds all non-top-level in-scope Ids (top-level and + -- imported things have a level of zero) + + lc_rec_env :: IdEnv CoreBind, + -- Binds *only* recursively defined ids, to their own + -- binding group, and *only* in their own RHSs + + lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] + -- Each of these Ids was scrutinised by an enclosing + -- case expression, at a level deeper than its binding + -- level. + -- + -- The first LibCaseLevel is the *binding level* of + -- the scrutinised Id, + -- The second is the level *at which it was scrutinised*. + -- (see Note [Avoiding fruitless liberate-case]) + -- The former is a bit redundant, since you could always + -- look it up in lc_lvl_env, but it's just cached here + -- + -- The order is insignificant; it's a bag really + -- + -- There's one element per scrutinisation; + -- in principle the same Id may appear multiple times, + -- although that'd be unusual: + -- case x of { (a,b) -> ....(case x of ...) .. } + } + +initEnv :: DynFlags -> LibCaseEnv +initEnv dflags + = LibCaseEnv { lc_dflags = dflags, + lc_lvl = 0, + lc_lvl_env = emptyVarEnv, + lc_rec_env = emptyVarEnv, + lc_scruts = [] } + +-- Bomb-out size for deciding if +-- potential liberatees are too big. +-- (passed in from cmd-line args) +bombOutSize :: LibCaseEnv -> Maybe Int +bombOutSize = liberateCaseThreshold . lc_dflags diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs new file mode 100644 index 00000000..c15026c5 --- /dev/null +++ b/compiler/simplCore/OccurAnal.hs @@ -0,0 +1,1871 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +{-# LANGUAGE CPP, BangPatterns #-} + +module OccurAnal ( + occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + stripTicksTopE, mkTicks ) +import Id +import Name( localiseName ) +import BasicTypes +import Module( Module ) +import Coercion + +import VarSet +import VarEnv +import Var +import Demand ( argOneShots, argsOneShots ) +import Maybes ( orElse ) +import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) +import Unique +import UniqFM +import Util +import Outputable +import FastString +import Data.List +import Control.Arrow ( second ) + +{- +************************************************************************ +* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +occurAnalysePgm :: Module -- Used only in debug output + -> (Activation -> Bool) + -> [CoreRule] -> [CoreVect] -> VarSet + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds + | isEmptyVarEnv final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + occ_anald_glommed_binds + where + init_env = initOccEnv active_rule + (final_usage, occ_anald_binds) = go init_env binds + (_, occ_anald_glommed_binds) = occAnalRecBind init_env imp_rules_edges + (flattenBinds occ_anald_binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (Trac #9583 is an example) + + initial_uds = addIdOccs emptyDetails + (rulesFreeVars imp_rules `unionVarSet` + vectsFreeVars vects `unionVarSet` + vectVars) + -- The RULES and VECTORISE declarations keep things alive! (For VECTORISE declarations, + -- we only get them *until* the vectoriser runs. Afterwards, these dependencies are + -- reflected in 'vectors' — see Note [Vectorisation declarations and occurrences].) + + -- Note [Preventing loops due to imported functions rules] + imp_rules_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go _ [] + = (initial_uds, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env imp_rules_edges bind bs_usage + +occurAnalyseExpr :: CoreExpr -> CoreExpr + -- Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap + +occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr +occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap + +occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr +occurAnalyseExpr' enable_binder_swap expr + = snd (occAnal env expr) + where + env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap} + -- To be conservative, we say that all inlines and rules are active + all_active_rules = \_ -> True + +{- +************************************************************************ +* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +* * +************************************************************************ + +Bindings +~~~~~~~~ +-} + +occAnalBind :: OccEnv -- The incoming OccEnv + -> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs + -> CoreBind + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [CoreBind]) + +occAnalBind env imp_rules_edges (NonRec binder rhs) body_usage + = occAnalNonRecBind env imp_rules_edges binder rhs body_usage +occAnalBind env imp_rules_edges (Rec pairs) body_usage + = occAnalRecBind env imp_rules_edges pairs body_usage + +----------------- +occAnalNonRecBind :: OccEnv -> IdEnv IdSet -> Var -> CoreExpr + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalNonRecBind env imp_rules_edges binder rhs body_usage + | isTyVar binder -- A type let; we don't gather usage info + = (body_usage, [NonRec binder rhs]) + + | not (binder `usedIn` body_usage) -- It's not mentioned + = (body_usage, []) + + | otherwise -- It's mentioned in the body + = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) + where + (body_usage', tagged_binder) = tagBinder body_usage binder + (rhs_usage1, rhs') = occAnalNonRecRhs env tagged_binder rhs + rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) + rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder + -- See Note [Preventing loops due to imported functions rules] + +----------------- +occAnalRecBind :: OccEnv -> IdEnv IdSet -> [(Var,CoreExpr)] + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalRecBind env imp_rules_edges pairs body_usage + = foldr occAnalRec (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + where + bndr_set = mkVarSet (map fst pairs) + + sccs :: [SCC (Node Details)] + sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes + + nodes :: [Node Details] + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs + +{- +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope wherever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) + +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. + +The principle is that, regardless of rule firings, every variable is +always in scope. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + To that end, we build a Rec group for each cyclic strongly + connected component, + *treating f's rules as extra RHSs for 'f'*. + More concretely, the SCC analysis runs on a graph with an edge + from f -> g iff g is mentioned in + (a) f's rhs + (b) f's RULES + These are rec_edges. + + Under (b) we include variables free in *either* LHS *or* RHS of + the rule. The former might seems silly, but see Note [Rule + dependency info]. So in Example [eftInt], eftInt and eftIntFB + will be put in the same Rec, even though their 'main' RHSs are + both non-recursive. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a SpecInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in Simplify.lhs + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + +- rec_edges for the Rec block analysis +- loop_breaker_edges for the loop breaker analysis + + * Note [Finding rule RHS free vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} + So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. + However, tagZero can only be inlined in phase 1 and later, while + the RULE is only active *before* phase 1. So there's no problem. + + To make this work, we look for the RHS free vars only for + *active* rules. That's the reason for the occ_rule_act field + of the OccEnv. + + * Note [Weak loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... + } + + Remember that we simplify the RULES before any RHS (see Note + [Rules are visible in their own rec group] above). + + So we must *not* postInlineUnconditionally 'g', even though + its RHS turns out to be trivial. (I'm assuming that 'g' is + not choosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + g, because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: + + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g is a "missing free variable" of the Rec group + + A "missing free variable" x is one that is mentioned in an RHS or + INLINE or RULE of a binding in the Rec group, but where the + dependency on x may not show up in the loop_breaker_edges (see + note [Choosing loop breakers} above). + + A normal "strong" loop breaker has IAmLoopBreaker False. So + + Inline postInlineUnconditionally + IAmLoopBreaker False no no + IAmLoopBreaker True yes no + other yes yes + + The **sole** reason for this kind of loop breaker is so that + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) + +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add +dependency edges between the *local* FVS of the rule LHS and the +*local* FVS of the rule RHS. We don't do anything special for RULES on +local functions because the standard occurrence analysis stuff is +pretty good at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + +Note [Specialising imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In paricular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. +-} + +type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed + + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] + + , nd_inl :: IdSet -- Free variables of + -- the stable unfolding (if present and active) + -- or the RHS (if not) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds + -- but are *not* in nd_inl. These are the ones whose + -- dependencies might not be respected by loop_breaker_edges + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + } + +instance Outputable Details where + ppr nd = ptext (sLit "ND") <> braces + (sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd) + , ptext (sLit "uds =") <+> ppr (nd_uds nd) + , ptext (sLit "inl =") <+> ppr (nd_inl nd) + , ptext (sLit "weak =") <+> ppr (nd_weak nd) + , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) + ]) + +makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env imp_rules_edges bndr_set (bndr, rhs) + = (details, varUnique bndr, keysUFM node_fvs) + where + details = ND { nd_bndr = bndr + , nd_rhs = rhs' + , nd_uds = rhs_usage3 + , nd_weak = node_fvs `minusVarSet` inl_fvs + , nd_inl = inl_fvs + , nd_active_rule_fvs = active_rule_fvs } + + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + (rhs_usage1, rhs') = occAnalRecRhs env rhs + rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_usage3 = case mb_unf_fvs of + Just unf_fvs -> addIdOccs rhs_usage2 unf_fvs + Nothing -> rhs_usage2 + node_fvs = udFreeVars bndr_set rhs_usage3 + + -- Finding the free variables of the rules + is_active = occ_rule_act env :: Activation -> Bool + rules = filterOut isBuiltinRule (idCoreRules bndr) + rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rules_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, fvs) + | rule <- rules + , let fvs = exprFreeVars (ru_rhs rule) + `delVarSetList` ru_bndrs rule + , not (isEmptyVarSet fvs) ] + all_rule_fvs = rule_lhs_fvs `unionVarSet` rule_rhs_fvs + rule_rhs_fvs = mapUnionVarSet snd rules_w_fvs + rule_lhs_fvs = mapUnionVarSet (\ru -> exprsFreeVars (ru_args ru) + `delVarSetList` ru_bndrs ru) rules + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a] + + -- Finding the free variables of the INLINE pragma (if any) + unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag + mb_unf_fvs = stableUnfoldingVars unf + + -- Find the "nd_inl" free vars; for the loop-breaker phase + inl_fvs = case mb_unf_fvs of + Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS + Just unf_fvs -> unf_fvs + -- We could check for an *active* INLINE (returning + -- emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about + -- RULE activation), so we'd need more plumbing + +----------------------------- +occAnalRec :: SCC (Node Details) + -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) + + -- The NonRec case is just like a Let (NonRec ...) above +occAnalRec (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_uds}, _, _)) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- It's mentioned in the body + = (body_uds' +++ rhs_uds, + NonRec tagged_bndr rhs : binds) + where + (body_uds', tagged_bndr) = tagBinder body_uds bndr + + -- The Rec case is the interesting one + -- See Note [Loop breaking] +occAnalRec (CyclicSCC nodes) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- At this point we always build a single Rec + = -- pprTrace "occAnalRec" (vcat + -- [ text "tagged nodes" <+> ppr tagged_nodes + -- , text "lb edges" <+> ppr loop_breaker_edges]) + (final_uds, Rec pairs : binds) + + where + bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes] + bndr_set = mkVarSet bndrs + + ---------------------------- + -- Tag the binders with their occurrence info + tagged_nodes = map tag_node nodes + total_uds = foldl add_uds body_uds nodes + final_uds = total_uds `minusVarEnv` bndr_set + add_uds usage_so_far (nd, _, _) = usage_so_far +++ nd_uds nd + + tag_node :: Node Details -> Node Details + tag_node (details@ND { nd_bndr = bndr }, k, ks) + = (details { nd_bndr = setBinderOcc total_uds bndr }, k, ks) + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs tagged_nodes [] + | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_edges [] + -- If weak_fvs is empty, the loop_breaker_edges will include all + -- the edges in tagged_nodes, so there isn't any point in doing + -- a fresh SCC computation that will yield a single CyclicSCC result. + + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet (nd_weak . fstOf3) nodes + + -- See Note [Choosing loop breakers] for loop_breaker_edges + loop_breaker_edges = map mk_node tagged_nodes + mk_node (details@(ND { nd_inl = inl_fvs }), k, _) + = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs)) + + ------------------------------------ + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) + init_rule_fvs -- See Note [Finding rule RHS free vars] + = [ (b, trimmed_rule_fvs) + | (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs)] + +{- +@loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic +strongly connected component (there's guaranteed to be a cycle). It returns the +same pairs, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +type Binding = (Id,CoreExpr) + +mk_loop_breaker :: Node Details -> Binding +mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + = (setIdOccInfo bndr strongLoopBreaker, rhs) + +mk_non_loop_breaker :: VarSet -> Node Details -> Binding +-- See Note [Weak loop breakers] +mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + | bndr `elemVarSet` used_in_rules = (setIdOccInfo bndr weakLoopBreaker, rhs) + | otherwise = (bndr, rhs) + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs uds = intersectUFM_C (\b _ -> b) bndrs uds + +loopBreakNodes :: Int + -> VarSet -- All binders + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [Node Details] + -> [Binding] -- Append these to the end + -> [Binding] +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +loopBreakNodes depth bndr_set weak_fvs nodes binds + = go (stronglyConnCompFromEdgedVerticesR nodes) binds + where + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds + CyclicSCC [node] -> mk_loop_breaker node : binds + CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds + +reOrderNodes :: Int -> VarSet -> VarSet -> [Node Details] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- do SCC analysis on the rest, and recursively sort them out +reOrderNodes _ _ _ [] _ = panic "reOrderNodes" +reOrderNodes depth bndr_set weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$ + -- text "chosen" <+> ppr chosen_nodes) $ + loopBreakNodes new_depth bndr_set weak_fvs unchosen $ + (map mk_loop_breaker chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = choose_loop_breaker (score node) [node] [] nodes + + approximate_loop_breaker = depth >= 2 + new_depth | approximate_loop_breaker = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + + choose_loop_breaker :: Int -- Best score so far + -> [Node Details] -- Nodes with this score + -> [Node Details] -- Nodes with higher scores + -> [Node Details] -- Unprocessed nodes + -> ([Node Details], [Node Details]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in + choose_loop_breaker _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] + choose_loop_breaker loop_sc loop_nodes acc (node : nodes) + | sc < loop_sc -- Lower score so pick this new one + = choose_loop_breaker sc [node] (loop_nodes ++ acc) nodes + + | approximate_loop_breaker && sc == loop_sc + = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes + + | otherwise -- Higher score so don't pick it + = choose_loop_breaker loop_sc loop_nodes (node : acc) nodes + where + sc = score node + + score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker + score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) + | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker + + | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + + | Just be_very_keen <- hasStableCoreUnfolding_maybe (idUnfolding bndr) + = if be_very_keen then 6 -- Note [Loop breakers and INLINE/INLINEABLE pragmas] + else 3 + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + -- Note that this case hits all stable unfoldings, so we + -- never look at 'rhs' for stable unfoldings. That's right, because + -- 'rhs' is irrelevant for inlining things with a stable unfolding + + | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications] + + | exprIsTrivial rhs = 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + +-- If an Id is marked "never inline" then it makes a great loop breaker +-- The only reason for not checking that here is that it is rare +-- and I've never seen a situation where it makes a difference, +-- so it probably isn't worth the time to test on every binder +-- | isNeverActive (idInlinePragma bndr) = -10 + + | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined + + | canUnfold (realIdUnfolding bndr) = 1 + -- The Id has some kind of unfolding + -- Ignore loop-breaker-ness here because that is what we are setting! + + | otherwise = 0 + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifer moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app _ = False + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from Trac #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINEABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINEABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINEABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINEABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in TcInstDcls + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-looop breker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalRhs@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that ths +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. +-} + +occAnalRecRhs :: OccEnv -> CoreExpr -- Rhs + -> (UsageDetails, CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRecRhs env rhs = occAnal (rhsCtxt env) rhs + +occAnalNonRecRhs :: OccEnv + -> Id -> CoreExpr -- Binder and rhs + -- Binder is already tagged with occurrence info + -> (UsageDetails, CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalNonRecRhs env bndr rhs + = occAnal rhs_env rhs + where + -- See Note [Use one-shot info] + env1 = env { occ_one_shots = argOneShots OneShotLam dmd } + + -- See Note [Cascading inlines] + rhs_env | certainly_inline = env1 + | otherwise = rhsCtxt env1 + + certainly_inline -- See Note [Cascading inlines] + = case idOccInfo bndr of + OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable + _ -> False + + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) + +addIdOccs :: UsageDetails -> VarSet -> UsageDetails +addIdOccs usage id_set = foldVarSet add usage id_set + where + add v u | isId v = addOneOcc u v NoOccInfo + | otherwise = u + -- Give a non-committal binder info (i.e NoOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +{- +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. +If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates +indefinitely: + x = f y + k = Just x +inline ==> + k = Just (f y) +float ==> + x1 = f y + k = Just x1 + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + +Expressions +~~~~~~~~~~~ +-} + +occAnal :: OccEnv + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + CoreExpr) + +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var v) = (mkOneOcc env v False, expr) + -- At one stage, I gathered the idRuleVars for v here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ (Coercion co) + = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion variables] + +{- +Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. +-} + +occAnal env (Tick tickish body) + | tickish `tickishScopesLike` SoftScope + = (usage, Tick tickish body') + + | Breakpoint _ ids <- tickish + = (usage_lam +++ mkVarEnv (zip ids (repeat NoOccInfo)), Tick tickish body') + -- never substitute for any of the Ids in a Breakpoint + + | otherwise + = (usage_lam, Tick tickish body') + where + !(usage,body') = occAnal env body + -- for a non-soft tick scope, we can inline lambdas only + usage_lam = mapVarEnv markInsideLam usage + +occAnal env (Cast expr co) + = case occAnal env expr of { (usage, expr') -> + let usage1 = markManyIf (isRhsEnv env) usage + usage2 = addIdOccs usage1 (coVarsOfCo co) + -- See Note [Gather occurrences of coercion variables] + in (usage2, Cast expr' co) + -- If we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. + } + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +-- Ignore type variables altogether +-- (a) occurrences inside type lambdas only not marked as InsideLam +-- (b) type variables not in environment + +occAnal env (Lam x body) | isTyVar x + = case occAnal env body of { (body_usage, body') -> + (body_usage, Lam x body') + } + +-- For value lambdas we do a special hack. Consider +-- (\x. \y. ...x...) +-- If we did nothing, x is used inside the \y, so would be marked +-- as dangerous to dup. But in the common case where the abstraction +-- is applied to two arguments this is over-pessimistic. +-- So instead, we just mark each binder with its occurrence +-- info in the *body* of the multiple lambda. +-- Then, the simplifier is careful when partially applying lambdas. + +occAnal env expr@(Lam _ _) + = case occAnal env_body body of { (body_usage, body') -> + let + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + + really_final_usage + | all isOneShotBndr binders' = final_usage + | otherwise = mapVarEnv markInsideLam final_usage + in + (really_final_usage, mkLams tagged_binders body') } + where + (binders, body) = collectBinders expr + (env_body, binders') = oneShotGroup env binders + +occAnal env (Case scrut bndr ty alts) + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> + let + alts_usage = foldr combineAltsUsageDetails emptyDetails alts_usage_s + (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr + total_usage = scrut_usage +++ alts_usage1 + in + total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} + where + -- Note [Case binder usage] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- The case binder gets a usage of either "many" or "dead", never "one". + -- Reason: we like to inline single occurrences, to eliminate a binding, + -- but inlining a case binder *doesn't* eliminate a binding. + -- We *don't* want to transform + -- case x of w { (p,q) -> f w } + -- into + -- case x of w { (p,q) -> f (p,q) } + tag_case_bndr usage bndr + = case lookupVarEnv usage bndr of + Nothing -> (usage, setIdOccInfo bndr IAmDead) + Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo) + + alt_env = mkAltEnv env scrut bndr + occ_anal_alt = occAnalAlt alt_env + + occ_anal_scrut (Var v) (alt1 : other_alts) + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs + -- in an interesting context; the case has + -- at least one non-default alternative + occ_anal_scrut (Tick t e) alts + | t `tickishScopesLike` SoftScope + -- No reason to not look through all ticks here, but only + -- for soft-scoped ticks we can do so without having to + -- update returned occurance info (see occAnal) + = second (Tick t) $ occ_anal_scrut e alts + + occ_anal_scrut scrut _alts + = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt + +occAnal env (Let bind body) + = case occAnal env body of { (body_usage, body') -> + case occAnalBind env emptyVarEnv bind body_usage of { (final_usage, new_binds) -> + (final_usage, mkLets new_binds body') }} + +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 +++ uds2, arg':args') }}} + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) + -> (UsageDetails, Expr CoreBndr) +occAnalApp env (Var fun, args, ticks) + | null ticks = (uds, mkApps (Var fun) args') + | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') + where + uds = fun_uds +++ final_args_uds + + !(args_uds, args') = occAnalArgs env args one_shots + !final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "many", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + n_val_args = valArgCount args + fun_uds = mkOneOcc env fun (n_val_args > 0) + is_exp = isExpandableApp fun n_val_args + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- Simplify.prepareRhs + + one_shots = argsOneShots (idStrictness fun) n_val_args + -- See Note [Use one-shot info] + +occAnalApp env (fun, args, ticks) + = (fun_uds +++ args_uds, mkTicks ticks $ mkApps fun' args') + where + !(fun_uds, fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + !(args_uds, args') = occAnalArgs env args [] + +markManyIf :: Bool -- If this is true + -> UsageDetails -- Then do markMany on this + -> UsageDetails +markManyIf True uds = mapVarEnv markMany uds +markManyIf False uds = uds + +{- +Note [Use one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrrence analyser propagates one-shot-lambda information in two situation + * Applications: eg build (\cn -> blah) + Propagate one-shot info from the strictness signature of 'build' to + the \cn + + * Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + +Some of this is done by the demand analyser, but this way it happens +much earlier, taking advantage of the strictness signature of +imported functions. + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, beause it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) + -> CoreAlt + -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt (env, scrut_bind) (con, bndrs, rhs) + = case occAnal env rhs of { (rhs_usage1, rhs1) -> + let + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + -- See Note [Binders in case alternatives] + (alt_usg', rhs2) = + wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 + in + (alt_usg', (con, tagged_bndrs, rhs2)) } + +wrapAltRHS :: OccEnv + -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv + -> UsageDetails -- usage for entire alt (p -> rhs) + -> [Var] -- alt binders + -> CoreExpr -- alt RHS + -> (UsageDetails, CoreExpr) +wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs + | occ_binder_swap env + , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this + -- handles condition (a) in Note [Binder swap] + , not captured -- See condition (b) in Note [Binder swap] + = ( alt_usg' +++ let_rhs_usg + , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) + where + captured = any (`usedIn` let_rhs_usg) bndrs + -- The rhs of the let may include coercion variables + -- if the scrutinee was a cast, so we must gather their + -- usage. See Note [Gather occurrences of coercion variables] + (let_rhs_usg, let_rhs') = occAnal env let_rhs + (alt_usg', tagged_scrut_var) = tagBinder alt_usg scrut_var + +wrapAltRHS _ _ alt_usg _ alt_rhs + = (alt_usg, alt_rhs) + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- Tells about linearity + , occ_gbl_scrut :: GlobalScruts + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + , occ_binder_swap :: !Bool -- enable the binder_swap + -- See CorePrep Note [Dead code in CorePrep] + } + +type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] + +----------------------------- +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enought about the context to know what to do when +-- we encounter a contructor application or PAP. + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here + +instance Outputable OccEncl where + ppr OccRhs = ptext (sLit "occRhs") + ppr OccVanilla = ptext (sLit "occVanilla") + +type OneShots = [OneShotInfo] + -- [] No info + -- + -- one_shot_info:ctxt Analysing a function-valued expression that + -- will be applied as described by one_shot_info + +initOccEnv :: (Activation -> Bool) -> OccEnv +initOccEnv active_rule + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + , occ_gbl_scrut = emptyVarSet -- PE emptyVarEnv emptyVarSet + , occ_rule_act = active_rule + , occ_binder_swap = True } + +vanillaCtxt :: OccEnv -> OccEnv +vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } + +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +argCtxt env (one_shots:one_shots_s) + = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = OccRhs }) = True +isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False + +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] ) + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\cn -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out tranformations + +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] + where + go ctxt [] rev_bndrs + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs ) + + go [] bndrs rev_bndrs + = ( env { occ_one_shots = [], occ_encl = OccVanilla } + , reverse rev_bndrs ++ bndrs ) + + go ctxt (bndr:bndrs) rev_bndrs + | isId bndr + + = case ctxt of + [] -> go [] bndrs (bndr : rev_bndrs) + (one_shot : ctxt) -> go ctxt bndrs (bndr': rev_bndrs) + where + bndr' = updOneShotInfo bndr one_shot + | otherwise + = go ctxt bndrs (bndr:rev_bndrs) + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } + +transClosureFV :: UniqFM VarSet -> UniqFM VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (ufmToList env) + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = foldUFM unionVarSet emptyVarSet $ + intersectUFM_C (\x _ -> x) env s + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +We do these two transformations right here: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> let x=b in ri } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> let x = b |> sym co in ri } + + Why (2)? See Note [Case of cast] + +In both cases, in a particular alternative (pi -> ri), we only +add the binding if + (a) x occurs free in (pi -> ri) + (ie it occurs in ri, but is not bound in pi) + (b) the pi does not bind b (or the free vars of co) +We need (a) and (b) for the inserted binding to be correct. + +For the alternatives where we inject the binding, we can transfer +all x's OccInfo to b. And that is the point. + +Notice that + * The deliberate shadowing of 'x'. + * That (a) rapidly becomes false, so no bindings are injected. + +The reason for doing these transformations here is because it allows +us to adjust the OccInfo for 'x' and 'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If we do this in the Simplifier, we don't know whether 'x' is used + in ri, so we are forced to pessimistically zap b's OccInfo even + though it is typically dead (ie neither it nor x appear in the + ri). There's nothing actually wrong with zapping it, except that + it's kind of nice to know which variables are dead. My nose + tells me to keep this information as robustly as possible. + +The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding +{x=b}; it's Nothing if the binder-swap doesn't happen. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Note [Binder swap on GlobalId scrutinees] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the scrutinee is a GlobalId we must take care in two ways + + i) In order to *know* whether 'x' occurs free in the RHS, we need its + occurrence info. BUT, we don't gather occurrence info for + GlobalIds. That's the reason for the (small) occ_gbl_scrut env in + OccEnv is for: it says "gather occurrence info for these". + + ii) We must call localiseId on 'x' first, in case it's a GlobalId, or + has an External Name. See, for example, SimplEnv Note [Global Ids in + the substitution]. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See Trac #5028. + +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. +-} + +mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) +-- Does two things: a) makes the occ_one_shots = OccVanilla +-- b) extends the GlobalScruts if possible +-- c) returns a proxy mapping, binding the scrutinee +-- to the case binder, if possible +mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr + = case stripTicksTopE (const True) scrut of + Var v -> add_scrut v case_bndr' + Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) + -- See Note [Case of cast] + _ -> (env { occ_encl = OccVanilla }, Nothing) + + where + add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v } + , Just (localise v, rhs) ) + + case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings] + localise scrut_var = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var) + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLINE or NOINLINE pragmas! + +{- +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ +-} + +type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage + -- INVARIANT: never IAmDead + -- (Deadness is signalled by not being in the map at all) + +(+++), combineAltsUsageDetails + :: UsageDetails -> UsageDetails -> UsageDetails + +(+++) usage1 usage2 + = plusVarEnv_C addOccInfo usage1 usage2 + +combineAltsUsageDetails usage1 usage2 + = plusVarEnv_C orOccInfo usage1 usage2 + +addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails +addOneOcc usage id info + = plusVarEnv_C addOccInfo usage (unitVarEnv id info) + -- ToDo: make this more efficient + +emptyDetails :: UsageDetails +emptyDetails = (emptyVarEnv :: UsageDetails) + +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` details = isExportedId v || v `elemVarEnv` details + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have a +-- stable unfolding, used for join points +tagLamBinders usage binders = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tag_lam usage binders + tag_lam usage bndr = (usage2, setBinderOcc usage bndr) + where + usage1 = usage `delVarEnv` bndr + usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr) + | otherwise = usage1 + +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + IdWithOccInfo) -- Tagged binders + +tagBinder usage binder + = let + usage' = usage `delVarEnv` binder + binder' = setBinderOcc usage binder + in + usage' `seq` (usage', binder') + +setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr +setBinderOcc usage bndr + | isTyVar bndr = bndr + | isExportedId bndr = case idOccInfo bndr of + NoOccInfo -> bndr + _ -> setIdOccInfo bndr NoOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" + + | otherwise = setIdOccInfo bndr occ_info + where + occ_info = lookupVarEnv usage bndr `orElse` IAmDead + +{- +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails +mkOneOcc env id int_cxt + | isLocalId id + = unitVarEnv id (OneOcc False True int_cxt) + + | id `elemVarEnv` occ_gbl_scrut env + = unitVarEnv id NoOccInfo + + | otherwise + = emptyDetails + +markMany, markInsideLam :: OccInfo -> OccInfo + +markMany _ = NoOccInfo + +markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt +markInsideLam occ = occ + +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo + +addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + NoOccInfo -- Both branches are at least One + -- (Argument is never IAmDead) + +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case + +orOccInfo (OneOcc in_lam1 _ int_cxt1) + (OneOcc in_lam2 _ int_cxt2) + = OneOcc (in_lam1 || in_lam2) + False -- False, because it occurs in both branches + (int_cxt1 && int_cxt2) +orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + NoOccInfo diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs new file mode 100644 index 00000000..dc76df0e --- /dev/null +++ b/compiler/simplCore/SAT.hs @@ -0,0 +1,431 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +************************************************************************ + + Static Argument Transformation pass + +************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +We could possibly do the same for big lambdas, but we don't as +they will eventually be removed in later stages of the compiler, +therefore there is no penalty in keeping them. + +We only apply the SAT when the number of static args is > 2. This +produces few bad cases. See + should_transform +in saTransform. + +Here are the headline nofib results: + Size Allocs Runtime +Min +0.0% -13.7% -21.4% +Max +0.1% +0.0% +5.4% +Geometric Mean +0.0% -0.2% -6.9% + +The previous patch, to fix polymorphic floatout demand signatures, is +essential to make this work well! +-} + +{-# LANGUAGE CPP #-} +module SAT ( doStaticArgs ) where + +import Var +import CoreSyn +import CoreUtils +import Type +import Coercion +import Id +import Name +import VarEnv +import UniqSupply +import Util +import UniqFM +import VarSet +import Unique +import UniqSet +import Outputable + +import Data.List +import FastString + +#include "HsVersions.h" + +doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram +doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds + where + sat_bind_threaded_us us bind = + let (us1, us2) = splitUniqSupply us + in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet)) + +-- We don't bother to SAT recursive groups since it can lead +-- to massive code expansion: see Andre Santos' thesis for details. +-- This means we only apply the actual SAT to Rec groups of one element, +-- but we want to recurse into the others anyway to discover other binds +satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo) +satBind (NonRec binder expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (NonRec binder expr', finalizeApp expr_app sat_info_expr) +satBind (Rec [(binder, rhs)]) interesting_ids = do + let interesting_ids' = interesting_ids `addOneToUniqSet` binder + (rhs_binders, rhs_body) = collectBinders rhs + (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids' + let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders) + sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body + + shadowing = binder `elementOfUniqSet` interesting_ids + sat_info_rhs'' = if shadowing + then sat_info_rhs' `delFromUFM` binder -- For safety + else sat_info_rhs' + + bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder) + rhs_binders rhs_body' + return (bind', sat_info_rhs'') +satBind (Rec pairs) interesting_ids = do + let (binders, rhss) = unzip pairs + rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss + let (rhss', sat_info_rhss') = unzip rhss_SATed + return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') + +data App = VarApp Id | TypeApp Type | CoApp Coercion +data Staticness a = Static a | NotStatic + +type IdAppInfo = (Id, SATInfo) + +type SATInfo = [Staticness App] +type IdSATInfo = IdEnv SATInfo +emptyIdSATInfo :: IdSATInfo +emptyIdSATInfo = emptyUFM + +{- +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) + where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) +-} + +pprSATInfo :: SATInfo -> SDoc +pprSATInfo staticness = hcat $ map pprStaticness staticness + +pprStaticness :: Staticness App -> SDoc +pprStaticness (Static (VarApp _)) = ptext (sLit "SV") +pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") +pprStaticness (Static (CoApp _)) = ptext (sLit "SC") +pprStaticness NotStatic = ptext (sLit "NS") + + +mergeSATInfo :: SATInfo -> SATInfo -> SATInfo +mergeSATInfo l r = zipWith mergeSA l r + where + mergeSA NotStatic _ = NotStatic + mergeSA _ NotStatic = NotStatic + mergeSA (Static (VarApp v)) (Static (VarApp v')) + | v == v' = Static (VarApp v) + | otherwise = NotStatic + mergeSA (Static (TypeApp t)) (Static (TypeApp t')) + | t `eqType` t' = Static (TypeApp t) + | otherwise = NotStatic + mergeSA (Static (CoApp c)) (Static (CoApp c')) + | c `coreEqCoercion` c' = Static (CoApp c) + | otherwise = NotStatic + mergeSA _ _ = pprPanic "mergeSATInfo" $ + ptext (sLit "Left:") + <> pprSATInfo l <> ptext (sLit ", ") + <> ptext (sLit "Right:") + <> pprSATInfo r + +mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo +mergeIdSATInfo = plusUFM_C mergeSATInfo + +mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo +mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo + +bindersToSATInfo :: [Id] -> SATInfo +bindersToSATInfo vs = map (Static . binderToApp) vs + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v + +finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo +finalizeApp Nothing id_sat_info = id_sat_info +finalizeApp (Just (v, sat_info')) id_sat_info = + let sat_info'' = case lookupUFM id_sat_info v of + Nothing -> sat_info' + Just sat_info -> mergeSATInfo sat_info sat_info' + in extendVarEnv id_sat_info v sat_info'' + +satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo) +satTopLevelExpr expr interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (expr', finalizeApp expr_app sat_info_expr) + +satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) +satExpr var@(Var v) interesting_ids = do + let app_info = if v `elementOfUniqSet` interesting_ids + then Just (v, []) + else Nothing + return (var, emptyIdSATInfo, app_info) + +satExpr lit@(Lit _) _ = do + return (lit, emptyIdSATInfo, Nothing) + +satExpr (Lam binders body) interesting_ids = do + (body', sat_info, this_app) <- satExpr body interesting_ids + return (Lam binders body', finalizeApp this_app sat_info, Nothing) + +satExpr (App fn arg) interesting_ids = do + (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids + let satRemainder = boring fn' sat_info_fn + case fn_app of + Nothing -> satRemainder Nothing + Just (fn_id, fn_app_info) -> + -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) + let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) + in case arg of + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic + where + boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) + boring fn' sat_info_fn app_info = + do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids + let sat_info_arg' = finalizeApp arg_app sat_info_arg + sat_info = mergeIdSATInfo sat_info_fn sat_info_arg' + return (App fn' arg', sat_info, app_info) + +satExpr (Case expr bndr ty alts) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + let sat_info_expr' = finalizeApp expr_app sat_info_expr + + zipped_alts' <- mapM satAlt alts + let (alts', sat_infos_alts) = unzip zipped_alts' + return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) + where + satAlt (con, bndrs, expr) = do + (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids + return ((con, bndrs, expr'), sat_info_expr) + +satExpr (Let bind body) interesting_ids = do + (body', sat_info_body, body_app) <- satExpr body interesting_ids + (bind', sat_info_bind) <- satBind bind interesting_ids + return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app) + +satExpr (Tick tickish expr) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Tick tickish expr', sat_info_expr, expr_app) + +satExpr ty@(Type _) _ = do + return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) + +satExpr (Cast expr coercion) interesting_ids = do + (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids + return (Cast expr' coercion, sat_info_expr, expr_app) + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ +-} + +type SatM result = UniqSM result + +runSAT :: UniqSupply -> SatM a -> a +runSAT = initUs_ + +newUnique :: SatM Unique +newUnique = getUniqueM + +{- +************************************************************************ + + Static Argument Transformation Monad + +************************************************************************ + +To do the transformation, the game plan is to: + +1. Create a small nonrecursive RHS that takes the + original arguments to the function but discards + the ones that are static and makes a call to the + SATed version with the remainder. We intend that + this will be inlined later, removing the overhead + +2. Bind this nonrecursive RHS over the original body + WITH THE SAME UNIQUE as the original body so that + any recursive calls to the original now go via + the small wrapper + +3. Rebind the original function to a new one which contains + our SATed function and just makes a call to it: + we call the thing making this call the local body + +Example: transform this + + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> body[map] +to + map :: forall a b. (a->b) -> [a] -> [b] + map = /\ab. \(f:a->b) (as:[a]) -> + letrec map' :: [a] -> [b] + -- The "worker function + map' = \(as:[a]) -> + let map :: forall a' b'. (a -> b) -> [a] -> [b] + -- The "shadow function + map = /\a'b'. \(f':(a->b) (as:[a]). + map' as + in body[map] + in map' as + +Note [Shadow binding] +~~~~~~~~~~~~~~~~~~~~~ +The calls to the inner map inside body[map] should get inlined +by the local re-binding of 'map'. We call this the "shadow binding". + +But we can't use the original binder 'map' unchanged, because +it might be exported, in which case the shadow binding won't be +discarded as dead code after it is inlined. + +So we use a hack: we make a new SysLocal binder with the *same* unique +as binder. (Another alternative would be to reset the export flag.) + +Note [Binder type capture] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that in the inner map (the "shadow function"), the static arguments +are discarded -- it's as if they were underscores. Instead, mentions +of these arguments (notably in the types of dynamic arguments) are bound +by the *outer* lambdas of the main function. So we must make up fresh +names for the static arguments so that they do not capture variables +mentioned in the types of dynamic args. + +In the map example, the shadow function must clone the static type +argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a' +is bound by the outer forall. We clone f' too for consistency, but +that doesn't matter either way because static Id arguments aren't +mentioned in the shadow binding at all. + +If we don't we get something like this: + +[Exported] +[Arity 3] +GHC.Base.until = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + letrec { + sat_worker_s1aU :: a_aiK -> a_aiK + [] + sat_worker_s1aU = + \ (x_a6X :: a_aiK) -> + let { + sat_shadow_r17 :: forall a_a3O. + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + [] + sat_shadow_r17 = + \ (@ a_aiK) + (p_a6T :: a_aiK -> GHC.Types.Bool) + (f_a6V :: a_aiK -> a_aiK) + (x_a6X :: a_aiK) -> + sat_worker_s1aU x_a6X } in + case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X + }; } in + sat_worker_s1aU x_a6X + +Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK +type argument. This is bad because it means the application sat_worker_s1aU x_a6X +is not well typed. +-} + +saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body + | Just arg_staticness <- maybe_arg_staticness + , should_transform arg_staticness + = saTransform binder arg_staticness rhs_binders rhs_body + | otherwise + = return (Rec [(binder, mkLams rhs_binders rhs_body)]) + where + should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT + where + n_static_args = length (filter isStaticValue staticness) + +saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind +saTransform binder arg_staticness rhs_binders rhs_body + = do { shadow_lam_bndrs <- mapM clone binders_w_staticness + ; uniq <- newUnique + ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) } + where + -- Running example: foldr + -- foldr \alpha \beta c n xs = e, for some e + -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic] + -- rhs_binders = [\alpha, \beta, c, n, xs] + -- rhs_body = e + + binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) + -- Any extra args are assumed NotStatic + + non_static_args :: [Var] + -- non_static_args = [xs] + -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] + non_static_args = [v | (v, NotStatic) <- binders_w_staticness] + + clone (bndr, NotStatic) = return bndr + clone (bndr, _ ) = do { uniq <- newUnique + ; return (setVarUnique bndr uniq) } + + -- new_rhs = \alpha beta c n xs -> + -- let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs -> + -- sat_worker xs + -- in e + -- in sat_worker xs + mk_new_rhs uniq shadow_lam_bndrs + = mkLams rhs_binders $ + Let (Rec [(rec_body_bndr, rec_body)]) + local_body + where + local_body = mkVarApps (Var rec_body_bndr) non_static_args + + rec_body = mkLams non_static_args $ + Let (NonRec shadow_bndr shadow_rhs) rhs_body + + -- See Note [Binder type capture] + shadow_rhs = mkLams shadow_lam_bndrs local_body + -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs + + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body) + -- rec_body_bndr = sat_worker + + -- See Note [Shadow binding]; make a SysLocal + shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) + (idUnique binder) + (exprType shadow_rhs) + +isStaticValue :: Staticness App -> Bool +isStaticValue (Static (VarApp _)) = True +isStaticValue _ = False diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs new file mode 100644 index 00000000..1d91d383 --- /dev/null +++ b/compiler/simplCore/SetLevels.hs @@ -0,0 +1,1114 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{SetLevels} + + *************************** + Overview + *************************** + +1. We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). + +2. We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. + +3. We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. (This used to be done by the simplifier + but the latter now only ensures that there's no shadowing; indeed, even + that may not be true.) + + NOTE: this can't be done using the uniqAway idea, because the variable + must be unique in the whole program, not just its current scope, + because two variables in different scopes may float out to the + same top level place + + NOTE: Very tiresomely, we must apply this substitution to + the rules stored inside a variable too. + + We do *not* clone top-level bindings, because some of them must not change, + but we *do* clone bindings that are heading for the top level + +4. In the expression + case x of wild { p -> ...wild... } + we substitute x for wild in the RHS of the case alternatives: + case x of wild { p -> ...x... } + This means that a sub-expression involving x is not "trapped" inside the RHS. + And it's not inconvenient because we already have a substitution. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. +-} + +{-# LANGUAGE CPP #-} +module SetLevels ( + setLevels, + + Level(..), tOP_LEVEL, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, + + incMinorLvl, ltMajLvl, ltLvl, isTopLvl + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreMonad ( FloatOutSwitches(..) ) +import CoreUtils ( exprType, exprOkForSpeculation, exprIsBottom ) +import CoreArity ( exprBotStrictness_maybe ) +import CoreFVs -- all of it +import Coercion ( isCoVar ) +import CoreSubst ( Subst, emptySubst, substBndrs, substRecBndrs, + extendIdSubst, extendSubstWithVar, cloneBndrs, + cloneRecIdBndrs, substTy, substCo, substVarSet ) +import MkCore ( sortQuantVars ) +import Id +import IdInfo +import Var +import VarSet +import VarEnv +import Literal ( litIsTrivial ) +import Demand ( StrictSig ) +import Name ( getOccName, mkSystemVarName ) +import OccName ( occNameString ) +import Type ( isUnLiftedType, Type, mkPiTypes ) +import BasicTypes ( Arity, RecFlag(..) ) +import UniqSupply +import Util +import Outputable +import FastString + +{- +************************************************************************ +* * +\subsection{Level numbers} +* * +************************************************************************ +-} + +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + +data Level = Level Int -- Major level: number of enclosing value lambdas + Int -- Minor level: number of big-lambda and/or case + -- expressions between here and the nearest + -- enclosing value lambda + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with tihs level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l + +{- +The {\em level number} on a (type-)lambda-bound variable is the +nesting depth of the (type-)lambda which binds it. The outermost lambda +has level 1, so (Level 0 0) means that the variable is bound outside any lambda. + +On an expression, it's the maximum level number of its free +(type-)variables. On a let(rec)-bound variable, it's the level of its +RHS. On a case-bound variable, it's the number of enclosing lambdas. + +Top-level variables: level~0. Those bound on the RHS of a top-level +definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown +as ``subscripts'')... +\begin{verbatim} +a_0 = let b_? = ... in + x_1 = ... b ... in ... +\end{verbatim} + +The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). +That's meant to be the level number of the enclosing binder in the +final (floated) program. If the level number of a sub-expression is +less than that of the context, then it might be worth let-binding the +sub-expression so that it will indeed float. + +If you can float to level @Level 0 0@ worth doing so because then your +allocation becomes static instead of dynamic. We always start with +context @Level 0 0@. + + +Note [FloatOut inside INLINE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose: +to say "don't float anything out of here". That's exactly what we +want for the body of an INLINE, where we don't want to float anything +out at all. See notes with lvlMFE below. + +But, check this out: + +-- At one time I tried the effect of not float anything out of an InlineMe, +-- but it sometimes works badly. For example, consider PrelArr.done. It +-- has the form __inline (\d. e) +-- where e doesn't mention d. If we float this to +-- __inline (let x = e in \d. x) +-- things are bad. The inliner doesn't even inline it because it doesn't look +-- like a head-normal form. So it seems a lesser evil to let things float. +-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe +-- which discourages floating out. + +So the conclusion is: don't do any floating at all inside an InlineMe. +(In the above example, don't float the {x=e} out of the \d.) + +One particular case is that of workers: we don't want to float the +call to the worker outside the wrapper, otherwise the worker might get +inlined into the floated expression, and an importing module won't see +the worker at all. +-} + +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l + +tOP_LEVEL :: Level +tOP_LEVEL = Level 0 0 + +incMajorLvl :: Level -> Level +incMajorLvl (Level major _) = Level (major + 1) 0 + +incMinorLvl :: Level -> Level +incMinorLvl (Level major minor) = Level major (minor+1) + +maxLvl :: Level -> Level -> Level +maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) + | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 + | otherwise = l2 + +ltLvl :: Level -> Level -> Bool +ltLvl (Level maj1 min1) (Level maj2 min2) + = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) + +ltMajLvl :: Level -> Level -> Bool + -- Tells if one level belongs to a difft *lambda* level to another +ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 + +isTopLvl :: Level -> Bool +isTopLvl (Level 0 0) = True +isTopLvl _ = False + +instance Outputable Level where + ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] + +instance Eq Level where + (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2 + +{- +************************************************************************ +* * +\subsection{Main level-setting code} +* * +************************************************************************ +-} + +setLevels :: FloatOutSwitches + -> CoreProgram + -> UniqSupply + -> [LevelledBind] + +setLevels float_lams binds us + = initLvl us (do_them init_env binds) + where + init_env = initialEnv float_lams + + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + +lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) +lvlTopBind env (NonRec bndr rhs) + = do { rhs' <- lvlExpr env (freeVars rhs) + ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr] + ; return (NonRec bndr' rhs', env') } + +lvlTopBind env (Rec pairs) + = do let (bndrs,rhss) = unzip pairs + (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL bndrs + rhss' <- mapM (lvlExpr env' . freeVars) rhss + return (Rec (bndrs' `zip` rhss'), env') + +{- +************************************************************************ +* * +\subsection{Setting expression levels} +* * +************************************************************************ + +Note [Floating over-saturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (f x y), and (f x) is a redex (ie f's arity is 1), +we call (f x) an "over-saturated application" + +Should we float out an over-sat app, if can escape a value lambda? +It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2). +But we don't want to do it for class selectors, because the work saved +is minimal, and the extra local thunks allocated cost money. + +Arguably we could float even class-op applications if they were going to +top level -- but then they must be applied to a constant dictionary and +will almost certainly be optimised away anyway. +-} + +lvlExpr :: LevelEnv -- Context + -> CoreExprWithFVs -- Input expression + -> LvlM LevelledExpr -- Result expression + +{- +The @ctxt_lvl@ is, roughly, the level of the innermost enclosing +binder. Here's an example + + v = \x -> ...\y -> let r = case (..x..) of + ..x.. + in .. + +When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's +the level of @r@, even though it's inside a level-2 @\y@. It's +important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we +don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE +--- because it isn't a *maximal* free expression. + +If there were another lambda in @r@'s rhs, it would get level-2 as well. +-} + +lvlExpr env (_, AnnType ty) = return (Type (substTy (le_subst env) ty)) +lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) +lvlExpr env (_, AnnVar v) = return (lookupVar env v) +lvlExpr _ (_, AnnLit lit) = return (Lit lit) + +lvlExpr env (_, AnnCast expr (_, co)) = do + expr' <- lvlExpr env expr + return (Cast expr' (substCo (le_subst env) co)) + +lvlExpr env (_, AnnTick tickish expr) = do + expr' <- lvlExpr env expr + return (Tick tickish expr') + +lvlExpr env expr@(_, AnnApp _ _) = do + let + (fun, args) = collectAnnArgs expr + -- + case fun of + (_, AnnVar f) | floatOverSat env -- See Note [Floating over-saturated applications] + , arity > 0 + , arity < n_val_args + , Nothing <- isClassOpId_maybe f -> + do + let (lapp, rargs) = left (n_val_args - arity) expr [] + rargs' <- mapM (lvlMFE False env) rargs + lapp' <- lvlMFE False env lapp + return (foldl App lapp' rargs') + where + n_val_args = count (isValArg . deAnnotate) args + arity = idArity f + + -- separate out the PAP that we are floating from the extra + -- arguments, by traversing the spine until we have collected + -- (n_val_args - arity) value arguments. + left 0 e rargs = (e, rargs) + left n (_, AnnApp f a) rargs + | isValArg (deAnnotate a) = left (n-1) f (a:rargs) + | otherwise = left n f (a:rargs) + left _ _ _ = panic "SetLevels.lvlExpr.left" + + -- No PAPs that we can float: just carry on with the + -- arguments and the function. + _otherwise -> do + args' <- mapM (lvlMFE False env) args + fun' <- lvlExpr env fun + return (foldl App fun' args') + +-- We don't split adjacent lambdas. That is, given +-- \x y -> (x+1,y) +-- we don't float to give +-- \x -> let v = x+1 in \y -> (v,y) +-- Why not? Because partial applications are fairly rare, and splitting +-- lambdas makes them more expensive. + +lvlExpr env expr@(_, AnnLam {}) + = do { new_body <- lvlMFE True new_env body + ; return (mkLams new_bndrs new_body) } + where + (bndrs, body) = collectAnnBndrs expr + (env1, bndrs1) = substBndrsSL NonRecursive env bndrs + (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1 + -- At one time we called a special verion of collectBinders, + -- which ignored coercions, because we don't want to split + -- a lambda like this (\x -> coerce t (\s -> ...)) + -- This used to happen quite a bit in state-transformer programs, + -- but not nearly so much now non-recursive newtypes are transparent. + -- [See SetLevels rev 1.50 for a version with this approach.] + +lvlExpr env (_, AnnLet bind body) + = do { (bind', new_env) <- lvlBind env bind + ; body' <- lvlExpr new_env body + -- No point in going via lvlMFE here. If the binding is alive + -- (mentioned in body), and the whole let-expression doesn't + -- float, then neither will the body + ; return (Let bind' body') } + +lvlExpr env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) + = do { scrut' <- lvlMFE True env scrut + ; lvlCase env scrut_fvs scrut' case_bndr ty alts } + +------------------------------------------- +lvlCase :: LevelEnv -- Level of in-scope names/tyvars + -> VarSet -- Free vars of input scrutinee + -> LevelledExpr -- Processed scrutinee + -> Id -> Type -- Case binder and result type + -> [AnnAlt Id VarSet] -- Input alternatives + -> LvlM LevelledExpr -- Result expression +lvlCase env scrut_fvs scrut' case_bndr ty alts + | [(con@(DataAlt {}), bs, body)] <- alts + , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec] + , not (isTopLvl dest_lvl) -- Can't have top-level cases + = -- See Note [Floating cases] + -- Always float the case if possible + -- Unlike lets we don't insist that it escapes a value lambda + do { (rhs_env, (case_bndr':bs')) <- cloneVars NonRecursive env dest_lvl (case_bndr:bs) + -- We don't need to use extendCaseBndrLvlEnv here + -- because we are floating the case outwards so + -- no need to do the binder-swap thing + ; body' <- lvlMFE True rhs_env body + ; let alt' = (con, [TB b (StayPut dest_lvl) | b <- bs'], body') + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) } + + | otherwise -- Stays put + = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr] + alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty alts') } + where + incd_lvl = incMinorLvl (le_ctxt_lvl env) + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstact over type variables, hence const True + + lvl_alt alts_env (con, bs, rhs) + = do { rhs' <- lvlMFE True new_env rhs + ; return (con, bs', rhs') } + where + (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs + +{- +Note [Floating cases] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + data T a = MkT !a + f :: T Int -> blah + f x vs = case x of { MkT y -> + let f vs = ...(case y of I# w -> e)...f.. + in f vs +Here we can float the (case y ...) out , because y is sure +to be evaluated, to give + f x vs = case x of { MkT y -> + caes y of I# w -> + let f vs = ...(e)...f.. + in f vs + +That saves unboxing it every time round the loop. It's important in +some DPH stuff where we really want to avoid that repeated unboxing in +the inner loop. + +Things to note + * We can't float a case to top level + * It's worth doing this float even if we don't float + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. + * We only do this with a single-alternative case + +Note [Check the output scrutinee for okForSpec] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y { + A -> ....(case y of alts).... + } +Because of the binder-swap, the inner case will get substituted to +(case x of ..). So when testing whether the scrutinee is +okForSpecuation we must be careful to test the *result* scrutinee ('x' +in this case), not the *input* one 'y'. The latter *is* ok for +speculation here, but the former is not -- and indeed we can't float +the inner case out, at least not unless x is also evaluated at its +binding site. + +That's why we apply exprOkForSpeculation to scrut' and not to scrut. +-} + +lvlMFE :: Bool -- True <=> strict context [body of case or let] + -> LevelEnv -- Level of in-scope names/tyvars + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +-- lvlMFE is just like lvlExpr, except that it might let-bind +-- the expression, so that it can itself be floated. + +lvlMFE _ env (_, AnnType ty) + = return (Type (substTy (le_subst env) ty)) + +-- No point in floating out an expression wrapped in a coercion or note +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE strict_ctxt env (_, AnnTick t e) + = do { e' <- lvlMFE strict_ctxt env e + ; return (Tick t e') } + +lvlMFE strict_ctxt env (_, AnnCast e (_, co)) + = do { e' <- lvlMFE strict_ctxt env e + ; return (Cast e' (substCo (le_subst env) co)) } + +-- Note [Case MFEs] +lvlMFE True env e@(_, AnnCase {}) + = lvlExpr env e -- Don't share cases + +lvlMFE strict_ctxt env ann_expr@(fvs, _) + | isUnLiftedType (exprType expr) + -- Can't let-bind it; see Note [Unlifted MFEs] + -- This includes coercions, which we don't want to float anyway + -- NB: no need to substitute cos isUnLiftedType doesn't change + || notWorthFloating ann_expr abs_vars + || not float_me + = -- Don't float it out + lvlExpr env ann_expr + + | otherwise -- Float it out! + = do { expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr + ; var <- newLvlVar expr' is_bot + ; return (Let (NonRec (TB var (FloatMe dest_lvl)) expr') + (mkVarApps (Var var) abs_vars)) } + where + expr = deAnnotate ann_expr + is_bot = exprIsBottom expr -- Note [Bottoming floats] + dest_lvl = destLevel env fvs (isFunction ann_expr) is_bot + abs_vars = abstractVars dest_lvl env fvs + + -- A decision to float entails let-binding this thing, and we only do + -- that if we'll escape a value lambda, or will go to the top level. + float_me = dest_lvl `ltMajLvl` (le_ctxt_lvl env) -- Escapes a value lambda + -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl + -- see Note [Escaping a value lambda] + + || (isTopLvl dest_lvl -- Only float if we are going to the top level + && floatConsts env -- and the floatConsts flag is on + && not strict_ctxt) -- Don't float from a strict context + -- We are keen to float something to the top level, even if it does not + -- escape a lambda, because then it needs no allocation. But it's controlled + -- by a flag, because doing this too early loses opportunities for RULES + -- which (needless to say) are important in some nofib programs + -- (gcd is an example). + -- + -- Beware: + -- concat = /\ a -> foldr ..a.. (++) [] + -- was getting turned into + -- lvl = /\ a -> foldr ..a.. (++) [] + -- concat = /\ a -> lvl a + -- which is pretty stupid. Hence the strict_ctxt test + -- + -- Also a strict contxt includes uboxed values, and they + -- can't be bound at top level + +{- +Note [Unlifted MFEs] +~~~~~~~~~~~~~~~~~~~~ +We don't float unlifted MFEs, which potentially loses big opportunites. +For example: + \x -> f (h y) +where h :: Int -> Int# is expensive. We'd like to float the (h y) outside +the \x, but we don't because it's unboxed. Possible solution: box it. + +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl +Furthermore, we want to float a bottoming expression even if it has free +variables: + f = \x. g (let v = h x in error ("urk" ++ v)) +Then we'd like to abstact over 'x' can float the whole arg of g: + lvl = \x. let v = h x in error ("urk" ++ v) + f = \x. g (lvl x) +See Maessen's paper 1999 "Bottom extraction: factoring error handling out +of functional programs" (unpublished I think). + +When we do this, we set the strictness and arity of the new bottoming +Id, *immediately*, for two reasons: + + * To prevent the abstracted thing being immediately inlined back in again + via preInlineUnconditionally. The latter has a test for bottoming Ids + to stop inlining them, so we'd better make sure it *is* a bottoming Id! + + * So that it's properly exposed as such in the interface file, even if + this is all happening after strictness analysis. + +Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tiresomely, though, the simplifier has an invariant that the manifest +arity of the RHS should be the same as the arity; but we can't call +etaExpand during SetLevels because it works over a decorated form of +CoreExpr. So we do the eta expansion later, in FloatOut. + +Note [Case MFEs] +~~~~~~~~~~~~~~~~ +We don't float a case expression as an MFE from a strict context. Why not? +Because in doing so we share a tiny bit of computation (the switch) but +in exchange we build a thunk, which is bad. This case reduces allocation +by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem. +Doesn't change any other allocation at all. +-} + +annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id +-- See Note [Bottoming floats] for why we want to add +-- bottoming information right now +annotateBotStr id Nothing = id +annotateBotStr id (Just (arity, sig)) = id `setIdArity` arity + `setIdStrictness` sig + +notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool +-- Returns True if the expression would be replaced by +-- something bigger than it is now. For example: +-- abs_vars = tvars only: return True if e is trivial, +-- but False for anything bigger +-- abs_vars = [x] (an Id): return True for trivial, or an application (f x) +-- but False for (f x x) +-- +-- One big goal is that floating should be idempotent. Eg if +-- we replace e with (lvl79 x y) and then run FloatOut again, don't want +-- to replace (lvl79 x y) with (lvl83 x y)! + +notWorthFloating e abs_vars + = go e (count isId abs_vars) + where + go (_, AnnVar {}) n = n >= 0 + go (_, AnnLit lit) n = ASSERT( n==0 ) + litIsTrivial lit -- Note [Floating literals] + go (_, AnnTick t e) n = not (tickishIsCode t) && go e n + go (_, AnnCast e _) n = go e n + go (_, AnnApp e arg) n + | (_, AnnType {}) <- arg = go e n + | (_, AnnCoercion {}) <- arg = go e n + | n==0 = False + | is_triv arg = go e (n-1) + | otherwise = False + go _ _ = False + + is_triv (_, AnnLit {}) = True -- Treat all literals as trivial + is_triv (_, AnnVar {}) = True -- (ie not worth floating) + is_triv (_, AnnCast e _) = is_triv e + is_triv (_, AnnApp e (_, AnnType {})) = is_triv e + is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e + is_triv (_, AnnTick t e) = not (tickishIsCode t) && is_triv e + is_triv _ = False + +{- +Note [Floating literals] +~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to float Integer literals, so that they get shared, +rather than being allocated every time round the loop. +Hence the litIsTrivial. + +We'd *like* to share MachStr literal strings too, mainly so we could +CSE them, but alas can't do so directly because they are unlifted. + + +Note [Escaping a value lambda] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float even cheap expressions out of value lambdas, +because that saves allocation. Consider + f = \x. .. (\y.e) ... +Then we'd like to avoid allocating the (\y.e) every time we call f, +(assuming e does not mention x). + +An example where this really makes a difference is simplrun009. + +Another reason it's good is because it makes SpecContr fire on functions. +Consider + f = \x. ....(f (\y.e)).... +After floating we get + lvl = \y.e + f = \x. ....(f lvl)... +and that is much easier for SpecConstr to generate a robust specialisation for. + +The OLD CODE (given where this Note is referred to) prevents floating +of the example above, so I just don't understand the old code. I +don't understand the old comment either (which appears below). I +measured the effect on nofib of changing OLD CODE to 'True', and got +zeros everywhere, but a 4% win for 'puzzle'. Very small 0.5% loss for +'cse'; turns out to be because our arity analysis isn't good enough +yet (mentioned in Simon-nofib-notes). + +OLD comment was: + Even if it escapes a value lambda, we only + float if it's not cheap (unless it'll get all the + way to the top). I've seen cases where we + float dozens of tiny free expressions, which cost + more to allocate than to evaluate. + NB: exprIsCheap is also true of bottom expressions, which + is good; we don't want to share them + + It's only Really Bad to float a cheap expression out of a + strict context, because that builds a thunk that otherwise + would never be built. So another alternative would be to + add + || (strict_ctxt && not (exprIsBottom expr)) + to the condition above. We should really try this out. + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ + +The binding stuff works for top level too. +-} + +lvlBind :: LevelEnv + -> CoreBindWithFVs + -> LvlM (LevelledBind, LevelEnv) + +lvlBind env (AnnNonRec bndr rhs@(rhs_fvs,_)) + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) + -- so we will ignore this case for now + || not (profitableFloat env dest_lvl) + || (isTopLvl dest_lvl && isUnLiftedType (idType bndr)) + -- We can't float an unlifted binding to top level, so we don't + -- float it at all. It's a bit brutal, but unlifted bindings + -- aren't expensive either + = -- No float + do { rhs' <- lvlExpr env rhs + ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] + ; return (NonRec bndr' rhs', env') } + + -- Otherwise we are going to float + | null abs_vars + = do { -- No type abstraction; clone existing binder + rhs' <- lvlExpr (setCtxtLvl env dest_lvl) rhs + ; (env', [bndr']) <- cloneVars NonRecursive env dest_lvl [bndr] + ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') } + + | otherwise + = do { -- Yes, type abstraction; create a new binder, extend substitution, etc + rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs + ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') } + + where + bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot + is_bot = exprIsBottom (deAnnotate rhs) + +lvlBind env (AnnRec pairs) + | not (profitableFloat env dest_lvl) + = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) + (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs + ; rhss' <- mapM (lvlExpr env') rhss + ; return (Rec (bndrs' `zip` rhss'), env') } + + | null abs_vars + = do { (new_env, new_bndrs) <- cloneVars Recursive env dest_lvl bndrs + ; new_rhss <- mapM (lvlExpr (setCtxtLvl new_env dest_lvl)) rhss + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + +-- ToDo: when enabling the floatLambda stuff, +-- I think we want to stop doing this + | [(bndr,rhs)] <- pairs + , count isId abs_vars > 1 + = do -- Special case for self recursion where there are + -- several variables carried around: build a local loop: + -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars + -- This just makes the closures a bit smaller. If we don't do + -- this, allocation rises significantly on some programs + -- + -- We could elaborate it for the case where there are several + -- mutually functions, but it's quite a bit more complicated + -- + -- This all seems a bit ad hoc -- sigh + let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + rhs_lvl = le_ctxt_lvl rhs_env + + (rhs_env', [new_bndr]) <- cloneVars Recursive rhs_env rhs_lvl [bndr] + let + (lam_bndrs, rhs_body) = collectAnnBndrs rhs + (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs + (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1 + new_rhs_body <- lvlExpr body_env2 rhs_body + (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams lam_bndrs2 $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams lam_bndrs2 new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs1))] + , poly_env) + + | otherwise -- Non-null abs_vars + = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs + ; new_rhss <- mapM (lvlFloatRhs abs_vars dest_lvl new_env) rhss + ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , new_env) } + + where + (bndrs,rhss) = unzip pairs + + -- Finding the free vars of the binding group is annoying + bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs + | (bndr, (rhs_fvs,_)) <- pairs]) + `minusVarSet` + mkVarSet bndrs + + dest_lvl = destLevel env bind_fvs (all isFunction rhss) False + abs_vars = abstractVars dest_lvl env bind_fvs + +profitableFloat :: LevelEnv -> Level -> Bool +profitableFloat env dest_lvl + = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda + || isTopLvl dest_lvl -- Going all the way to top level + +---------------------------------------------------- +-- Three help functions for the type-abstraction case + +lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> CoreExprWithFVs + -> UniqSM (Expr LevelledBndr) +lvlFloatRhs abs_vars dest_lvl env rhs + = do { rhs' <- lvlExpr rhs_env rhs + ; return (mkLams abs_vars_w_lvls rhs') } + where + (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars + +{- +************************************************************************ +* * +\subsection{Deciding floatability} +* * +************************************************************************ +-} + +substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr]) +substAndLvlBndrs is_rec env lvl bndrs + = lvlBndrs subst_env lvl subst_bndrs + where + (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs + +substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar]) +-- So named only to avoid the name clash with CoreSubst.substBndrs +substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs + = ( env { le_subst = subst' + , le_env = foldl add_id id_env (bndrs `zip` bndrs') } + , bndrs') + where + (subst', bndrs') = case is_rec of + NonRecursive -> substBndrs subst bndrs + Recursive -> substRecBndrs subst bndrs + +lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr]) +-- Compute the levels for the binders of a lambda group +lvlLamBndrs env lvl bndrs + = lvlBndrs env new_lvl bndrs + where + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl + + is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) + -- The "probably" part says "don't float things out of a + -- probable one-shot lambda" + -- See Note [Computing one-shot info] in Demand.lhs + + +lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) +-- The binders returned are exactly the same as the ones passed, +-- apart from applying the substitution, but they are now paired +-- with a (StayPut level) +-- +-- The returned envt has ctxt_lvl updated to the new_lvl +-- +-- All the new binders get the same level, because +-- any floating binding is either going to float past +-- all or none. We never separate binders. +lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs + = ( env { le_ctxt_lvl = new_lvl + , le_lvl_env = foldl add_lvl lvl_env bndrs } + , lvld_bndrs) + where + lvld_bndrs = [TB bndr (StayPut new_lvl) | bndr <- bndrs] + add_lvl env v = extendVarEnv env v new_lvl + + -- Destination level is the max Id level of the expression + -- (We'll abstract the type variables, if any.) +destLevel :: LevelEnv -> VarSet + -> Bool -- True <=> is function + -> Bool -- True <=> is bottom + -> Level +destLevel env fvs is_function is_bot + | is_bot = tOP_LEVEL -- Send bottoming bindings to the top + -- regardless; see Note [Bottoming floats] + | Just n_args <- floatLams env + , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case + , is_function + , countFreeIds fvs <= n_args + = tOP_LEVEL -- Send functions to top level; see + -- the comments with isFunction + + | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars + -- will be abstracted + +isFunction :: CoreExprWithFVs -> Bool +-- The idea here is that we want to float *functions* to +-- the top level. This saves no work, but +-- (a) it can make the host function body a lot smaller, +-- and hence inlinable. +-- (b) it can also save allocation when the function is recursive: +-- h = \x -> letrec f = \y -> ...f...y...x... +-- in f x +-- becomes +-- f = \x y -> ...(f x)...y...x... +-- h = \x -> f x x +-- No allocation for f now. +-- We may only want to do this if there are sufficiently few free +-- variables. We certainly only want to do it for values, and not for +-- constructors. So the simple thing is just to look for lambdas +isFunction (_, AnnLam b e) | isId b = True + | otherwise = isFunction e +-- isFunction (_, AnnTick _ e) = isFunction e -- dubious +isFunction _ = False + +countFreeIds :: VarSet -> Int +countFreeIds = foldVarSet add 0 + where + add :: Var -> Int -> Int + add v n | isId v = n+1 + | otherwise = n + +{- +************************************************************************ +* * +\subsection{Free-To-Level Monad} +* * +************************************************************************ +-} + +type InVar = Var -- Pre cloning +type InId = Id -- Pre cloning +type OutVar = Var -- Post cloning +type OutId = Id -- Post cloning + +data LevelEnv + = LE { le_switches :: FloatOutSwitches + , le_ctxt_lvl :: Level -- The current level + , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids + , le_subst :: Subst -- Domain is pre-cloned TyVars and Ids + -- The Id -> CoreExpr in the Subst is ignored + -- (since we want to substitute a LevelledExpr for + -- an Id via le_env) but we do use the Co/TyVar substs + , le_env :: IdEnv ([OutVar], LevelledExpr) -- Domain is pre-cloned Ids + } + -- We clone let- and case-bound variables so that they are still + -- distinct when floated out; hence the le_subst/le_env. + -- (see point 3 of the module overview comment). + -- We also use these envs when making a variable polymorphic + -- because we want to float it out past a big lambda. + -- + -- The le_subst and le_env always implement the same mapping, but the + -- le_subst maps to CoreExpr and the le_env to LevelledExpr + -- Since the range is always a variable or type application, + -- there is never any difference between the two, but sadly + -- the types differ. The le_subst is used when substituting in + -- a variable's IdInfo; the le_env when we find a Var. + -- + -- In addition the le_env records a list of tyvars free in the + -- type application, just so we don't have to call freeVars on + -- the type application repeatedly. + -- + -- The domain of the both envs is *pre-cloned* Ids, though + -- + -- The domain of the le_lvl_env is the *post-cloned* Ids + +initialEnv :: FloatOutSwitches -> LevelEnv +initialEnv float_lams + = LE { le_switches = float_lams + , le_ctxt_lvl = tOP_LEVEL + , le_lvl_env = emptyVarEnv + , le_subst = emptySubst + , le_env = emptyVarEnv } + +floatLams :: LevelEnv -> Maybe Int +floatLams le = floatOutLambdas (le_switches le) + +floatConsts :: LevelEnv -> Bool +floatConsts le = floatOutConstants (le_switches le) + +floatOverSat :: LevelEnv -> Bool +floatOverSat le = floatOutOverSatApps (le_switches le) + +setCtxtLvl :: LevelEnv -> Level -> LevelEnv +setCtxtLvl env lvl = env { le_ctxt_lvl = lvl } + +-- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can +-- (see point 4 of the module overview comment) +extendCaseBndrEnv :: LevelEnv + -> Id -- Pre-cloned case binder + -> Expr LevelledBndr -- Post-cloned scrutinee + -> LevelEnv +extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) + case_bndr (Var scrut_var) + = le { le_subst = extendSubstWithVar subst case_bndr scrut_var + , le_env = add_id id_env (case_bndr, scrut_var) } +extendCaseBndrEnv env _ _ = env + +maxFvLevel :: (Var -> Bool) -> LevelEnv -> VarSet -> Level +maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set + = foldVarSet max_in tOP_LEVEL var_set + where + max_in in_var lvl + = foldr max_out lvl (case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> abs_vars + Nothing -> [in_var]) + + max_out out_var lvl + | max_me out_var = case lookupVarEnv lvl_env out_var of + Just lvl' -> maxLvl lvl' lvl + Nothing -> lvl + | otherwise = lvl -- Ignore some vars depending on max_me + +lookupVar :: LevelEnv -> Id -> LevelledExpr +lookupVar le v = case lookupVarEnv (le_env le) v of + Just (_, expr) -> expr + _ -> Var v + +abstractVars :: Level -> LevelEnv -> VarSet -> [OutVar] + -- Find the variables in fvs, free vars of the target expresion, + -- whose level is greater than the destination level + -- These are the ones we are going to abstract out +abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs + = map zap $ uniq $ sortQuantVars + [out_var | out_fv <- varSetElems (substVarSet subst in_fvs) + , out_var <- varSetElems (close out_fv) + , abstract_me out_var ] + -- NB: it's important to call abstract_me only on the OutIds the + -- come from substVarSet (not on fv, which is an InId) + where + uniq :: [Var] -> [Var] + -- Remove adjacent duplicates; the sort will have brought them together + uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs) + | otherwise = v1 : uniq (v2:vs) + uniq vs = vs + + abstract_me v = case lookupVarEnv lvl_env v of + Just lvl -> dest_lvl `ltLvl` lvl + Nothing -> False + + -- We are going to lambda-abstract, so nuke any IdInfo, + -- and add the tyvars of the Id (if necessary) + zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || + not (isEmptySpecInfo (idSpecialisation v)), + text "absVarsOf: discarding info on" <+> ppr v ) + setIdInfo v vanillaIdInfo + | otherwise = v + + close :: Var -> VarSet -- Close over variables free in the type + -- Result includes the input variable itself + close v = foldVarSet (unionVarSet . close) + (unitVarSet v) + (varTypeTyVars v) + +type LvlM result = UniqSM result + +initLvl :: UniqSupply -> UniqSM a -> a +initLvl = initUs_ + +newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] -> UniqSM (LevelEnv, [OutId]) +-- The envt is extended to bind the new bndrs to dest_lvl, but +-- the ctxt_lvl is unaffected +newPolyBndrs dest_lvl + env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + abs_vars bndrs + = ASSERT( all (not . isCoVar) bndrs ) -- What would we add to the CoSubst in this case. No easy answer. + do { uniqs <- getUniquesM + ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs + bndr_prs = bndrs `zip` new_bndrs + env' = env { le_lvl_env = foldl add_lvl lvl_env new_bndrs + , le_subst = foldl add_subst subst bndr_prs + , le_env = foldl add_id id_env bndr_prs } + ; return (env', new_bndrs) } + where + add_lvl env v' = extendVarEnv env v' dest_lvl + add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) + add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.lhs + mkSysLocal (mkFastString str) uniq poly_ty + where + str = "poly_" ++ occNameString (getOccName bndr) + poly_ty = mkPiTypes abs_vars (substTy subst (idType bndr)) + +newLvlVar :: LevelledExpr -- The RHS of the new binding + -> Bool -- Whether it is bottom + -> LvlM Id +newLvlVar lvld_rhs is_bot + = do { uniq <- getUniqueM + ; return (add_bot_info (mkLocalId (mk_name uniq) rhs_ty)) } + where + add_bot_info var -- We could call annotateBotStr always, but the is_bot + -- flag just tells us when we don't need to do so + | is_bot = annotateBotStr var (exprBotStrictness_maybe de_tagged_rhs) + | otherwise = var + de_tagged_rhs = deTagExpr lvld_rhs + rhs_ty = exprType de_tagged_rhs + mk_name uniq = mkSystemVarName uniq (mkFastString "lvl") + +cloneVars :: RecFlag -> LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) +-- Works for Ids, TyVars and CoVars +-- The dest_lvl is attributed to the binders in the new env, +-- but cloneVars doesn't affect the ctxt_lvl of the incoming env +cloneVars is_rec + env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) + dest_lvl vs + = do { us <- getUniqueSupplyM + ; let (subst', vs1) = case is_rec of + NonRecursive -> cloneBndrs subst us vs + Recursive -> cloneRecIdBndrs subst us vs + vs2 = map zap_demand_info vs1 -- See Note [Zapping the demand info] + prs = vs `zip` vs2 + env' = env { le_lvl_env = foldl add_lvl lvl_env vs2 + , le_subst = subst' + , le_env = foldl add_id id_env prs } + + ; return (env', vs2) } + where + add_lvl env v_cloned = extendVarEnv env v_cloned dest_lvl + +add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr) +add_id id_env (v, v1) + | isTyVar v = delVarEnv id_env v + | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1) + +zap_demand_info :: Var -> Var +zap_demand_info v + | isId v = zapIdDemandInfo v + | otherwise = v + +{- +Note [Zapping the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VERY IMPORTANT: we must zap the demand info if the thing is going to +float out, becuause it may be less demanded than at its original +binding site. Eg + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict; but if we float v to top level, it isn't any more. +-} diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs new file mode 100644 index 00000000..47891601 --- /dev/null +++ b/compiler/simplCore/SimplCore.hs @@ -0,0 +1,946 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SimplCore]{Driver for simplifying @Core@ programs} +-} + +{-# LANGUAGE CPP #-} + +module SimplCore ( core2core, simplifyExpr ) where + +#include "HsVersions.h" + +import DynFlags +import CoreSyn +import HscTypes +import CSE ( cseProgram ) +import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, + extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) +import PprCore ( pprCoreBindings, pprCoreExpr ) +import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import IdInfo +import CoreUtils ( coreBindsSize, coreBindsStats, exprSize, + mkTicks, stripTicksTop ) +import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult, + lintAnnots ) +import Simplify ( simplTopBinds, simplExpr, simplRules ) +import SimplUtils ( simplEnvForGHCi, activeRule ) +import SimplEnv +import SimplMonad +import CoreMonad +import qualified ErrUtils as Err +import FloatIn ( floatInwards ) +import FloatOut ( floatOutwards ) +import FamInstEnv +import Id +import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) +import VarSet +import VarEnv +import LiberateCase ( liberateCase ) +import SAT ( doStaticArgs ) +import Specialise ( specProgram) +import SpecConstr ( specConstrProgram) +import DmdAnal ( dmdAnalProgram ) +import CallArity ( callArityAnalProgram ) +import WorkWrap ( wwTopBinds ) +import Vectorise ( vectorise ) +import FastString +import SrcLoc +import Util + +import Maybes +import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import Outputable +import Control.Monad + +#ifdef GHCI +import DynamicLoading ( loadPlugins ) +import Plugins ( installCoreToDos ) +#endif + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts + = do { us <- mkSplitUniqSupply 's' + -- make sure all plugins are loaded + + ; let builtin_passes = getCoreToDo dflags + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $ + do { all_passes <- addPluginPasses builtin_passes + ; runCorePasses all_passes guts } + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + (pprSimplCount stats) + + ; return guts2 } + where + dflags = hsc_dflags hsc_env + home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts)) + hpt_rule_base = mkRuleBase home_pkg_rules + mod = mg_module guts + -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. + -- This is very convienent for the users of the monad (e.g. plugins do not have to + -- consume the ModGuts to find the module) but somewhat ugly because mg_module may + -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which + -- would mean our cached value would go out of date. + print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts) + +{- +************************************************************************ +* * + Generating the main optimisation pipeline +* * +************************************************************************ +-} + +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + call_arity = gopt Opt_CallArity dflags + strictness = gopt Opt_Strictness dflags + full_laziness = gopt Opt_FullLaziness dflags + do_specialise = gopt Opt_Specialise dflags + do_float_in = gopt Opt_FloatIn dflags + cse = gopt Opt_CSE dflags + spec_constr = gopt Opt_SpecConstr dflags + liberate_case = gopt Opt_LiberateCase dflags + late_dmd_anal = gopt Opt_LateDmdAnal dflags + static_args = gopt Opt_StaticArgumentTransformation dflags + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before phase + = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness + + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_inline = True + , sm_case_case = True } + + simpl_phase phase names iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify iter + (base_mode { sm_phase = Phase phase + , sm_names = names }) + + , maybe_rule_check (Phase phase) ] + + -- Vectorisation can introduce a fair few common sub expressions involving + -- DPH primitives. For example, see the Reverse test from dph-examples. + -- We need to eliminate these common sub expressions before their definitions + -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, + -- so we also run simpl_gently to inline them. + ++ (if gopt Opt_Vectorise dflags && phase == 3 + then [CoreCSE, simpl_gently] + else []) + + vectorisation + = runWhen (gopt Opt_Vectorise dflags) $ + CoreDoPasses [ simpl_gently, CoreDoVectorisation ] + + -- By default, we have 2 phases before phase 0. + + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + + -- Need phase 1 so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + | phase <- [phases, phases-1 .. 1] ] + + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify max_iter + (base_mode { sm_phase = InitialPhase + , sm_names = ["Gentle"] + , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] + , sm_inline = False + , sm_case_case = False }) + -- Don't do case-of-case transformations. + -- This makes full laziness work better + + -- New demand analyser + demand_analyser = (CoreDoPasses ([ + CoreDoStrictness, + CoreDoWorkerWrapper, + simpl_phase 0 ["post-worker-wrapper"] max_iter + ])) + + core_todo = + if opt_level == 0 then + [ vectorisation + , CoreDoSimplify max_iter + (base_mode { sm_phase = Phase 0 + , sm_names = ["Non-opt simplification"] }) + ] + + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- We run vectorisation here for now, but we might also try to run + -- it later + vectorisation, + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutOverSatApps = False }, + -- Was: gentleFloatOutSwitches + -- + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutOverSatApps yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen do_float_in CoreDoFloatInwards, + -- Run float-inwards immediately before the strictness analyser + -- Doing so pushes bindings nearer their use site and hence makes + -- them more likely to be strict. These bindings might only show + -- up after the inlining from simplification. Example in fulsom, + -- Csg.calc, where an arg of timesDouble thereby becomes strict. + + runWhen call_arity $ CoreDoPasses + [ CoreDoCallArity + , simpl_phase 0 ["post-call-arity"] max_iter + ], + + runWhen strictness demand_analyser, + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutOverSatApps = True }, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check (Phase 0), + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possiblility of shadowing + -- Reason: see Note [Shadowing] in SpecConstr.lhs + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check (Phase 0), + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter, + + runWhen late_dmd_anal $ CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + simpl_phase 0 ["post-late-ww"] max_iter + ], + + maybe_rule_check (Phase 0) + ] + +-- Loading plugins + +addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo] +#ifndef GHCI +addPluginPasses builtin_passes = return builtin_passes +#else +addPluginPasses builtin_passes + = do { hsc_env <- getHscEnv + ; named_plugins <- liftIO (loadPlugins hsc_env) + ; foldM query_plug builtin_passes named_plugins } + where + query_plug todos (_, plug, options) = installCoreToDos plug options todos +#endif + +{- +************************************************************************ +* * + The CoreToDo interpreter +* * +************************************************************************ +-} + +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts + do_pass guts pass + = do { showPass pass + ; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + ; endPass pass (mg_binds guts') (mg_rules guts') + ; return guts' } + +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass + +doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram + +doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} + doPassD liberateCase + +doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + doPassD floatInwards + +doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards f) + +doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} + doPassU doStaticArgs + +doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} + doPassD callArityAnalProgram + +doCorePass CoreDoStrictness = {-# SCC "NewStranal" #-} + doPassDFM dmdAnalProgram + +doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} + doPassDFU wwTopBinds + +doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} + specProgram + +doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} + specConstrProgram + +doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise + +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat +doCorePass CoreDoNothing = return +doCorePass (CoreDoPasses passes) = runCorePasses passes + +#ifdef GHCI +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass +#endif + +doCorePass pass = pprPanic "doCorePass" (ppr pass) + +{- +************************************************************************ +* * +\subsection{Core pass combinators} +* * +************************************************************************ +-} + +printCore :: DynFlags -> CoreProgram -> IO () +printCore dflags binds + = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) + +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = do + rb <- getRuleBase + dflags <- getDynFlags + liftIO $ Err.showPass dflags "RuleCheck" + liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (ruleCheckProgram current_phase pat rb (mg_binds guts)) + return guts + + +doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDUM do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + us <- getUniqueSupplyM + liftIO $ do_pass dflags us binds + +doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) + +doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) + +doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) + +doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassU do_pass = doPassDU (const do_pass) + +doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFM do_pass guts = do + dflags <- getDynFlags + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPassM (liftIO . do_pass dflags fam_envs) guts + +doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPassDFU do_pass guts = do + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + doPass (do_pass dflags fam_envs us) guts + +-- Most passes return no stats and don't change rules: these combinators +-- let us lift them to the full blown ModGuts+CoreM world +doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts +doPassM bind_f guts = do + binds' <- bind_f (mg_binds guts) + return (guts { mg_binds = binds' }) + +doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts +doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } + +-- Observer passes just peek; don't modify the bindings at all +observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts +observe do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + _ <- liftIO $ do_pass dflags binds + return binds + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +-- +-- Also used by Template Haskell +simplifyExpr dflags expr + = do { + ; Err.showPass dflags "Simplify" + + ; us <- mkSplitUniqSupply 's' + + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $ + simplExprGently (simplEnvForGHCi dflags) expr + + ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics" (pprSimplCount counts) + + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + (pprCoreExpr expr') + + ; return expr' + } + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplifierMode is SimplGently, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplifying the left-hand side of a RULE] above. The +-- simplifier does indeed do eta reduction (it's in Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv + ; us <- getUniqueSupplyM + ; rb <- getRuleBase + ; liftIOWithCount $ + simplifyPgmIO pass hsc_env us rb guts } + +simplifyPgmIO :: CoreToDo + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) + hsc_env us hpt_rule_base + guts@(ModGuts { mg_module = this_mod + , mg_rdr_env = rdr_env + , mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules + + ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && + dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + simpl_env = mkSimplEnv mode + active_rule = activeRule simpl_env + + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts_so_far binds rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = WARN( debugIsOn && (max_iterations > 2) + , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations + <+> ptext (sLit "iterations") + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds))) + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , sz == sz -- Force it + = do { + -- Occurrence analysis + let { -- Note [Vectorisation declarations and occurrences] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure + -- that the right-hand sides of vectorisation declarations are taken into + -- account during occurrence analysis. After the 'InitialPhase', we need to ensure + -- that the binders representing variable vectorisation declarations are kept alive. + -- (In contrast to automatically vectorised variables, their unvectorised versions + -- don't depend on them.) + vectVars = mkVarSet $ + catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr + | Vect bndr _ <- mg_vect_decls guts] + ++ + catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr + | bndr <- bindersOfBinds binds] + -- FIXME: This second comprehensions is only needed as long as we + -- have vectorised bindings where we get "Could NOT call + -- vectorised from original version". + ; (maybeVects, maybeVectVars) + = case sm_phase mode of + InitialPhase -> (mg_vect_decls guts, vectVars) + _ -> ([], vectVars) + ; tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_rule rules maybeVects maybeVectVars binds + } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings tagged_binds); + + -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in Rules.lhs + -- We need to do this regularly, because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + eps <- hscEPS hsc_env ; + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz $ + do { env1 <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplRules env1 Nothing rules + + ; return (getFloatBinds env1, rules1) } ; + + -- Stop if nothing happened; don't dump output + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; + lintPassResult hsc_env pass binds2 ; + + -- Loop + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } + | otherwise = panic "do_iteration" + where + (us1, us2) = splitUniqSupply us + + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) + +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" + +------------------- +dump_end_iteration :: DynFlags -> PrintUnqualified -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration dflags print_unqual iteration_no counts binds rules + = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules + where + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no + pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr + , pprSimplCount counts + , ptext (sLit "---- End of simplifier counts for") <+> hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to propagage any useful IdInfo on x_local to x_exported. + +STRICTNESS: if we have done strictness analysis, we want the strictness info on +x_local to transfer to x_exported. Hence the copyIdInfo call. + +RULES: we want to *add* any RULES for x_local to x_exported. + + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +he says. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might elminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ varEnvElts ind_env + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set = [] + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + = [(transferIdInfo exp_id bndr, + mkTicks ticks rhs), + (bndr, Var exp_id)] + | otherwise = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldr add_bind emptyVarEnv binds + where + add_bind :: CoreBind -> IndEnv -> IndEnv + add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env + add_bind (Rec pairs) env = foldr add_pair env pairs + + add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv + add_pair (exported_id, exported) env + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair _ env = env + +----------------- +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's IdInfo] + else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) + False + else + False + +----------------- +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's IdInfo] +hasShortableIdInfo id + = isEmptySpecInfo (specInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (unfoldingInfo info)) + where + info = idInfo id + +----------------- +transferIdInfo :: Id -> Id -> Id +-- See Note [Transferring IdInfo] +-- If we have +-- lcl_id = e; exp_id = lcl_id +-- and lcl_id has useful IdInfo, we don't want to discard it by going +-- gbl_id = e; lcl_id = gbl_id +-- Instead, transfer IdInfo from lcl_id to exp_id +-- Overwriting, rather than merging, seems to work ok. +transferIdInfo exported_id local_id + = modifyIdInfo transfer exported_id + where + local_info = idInfo local_id + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setUnfoldingInfo` unfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setSpecInfo` addSpecInfo (specInfo exp_info) new_info + new_info = setSpecInfoHead (idName exported_id) + (specInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs new file mode 100644 index 00000000..1c9c71ac --- /dev/null +++ b/compiler/simplCore/SimplEnv.hs @@ -0,0 +1,768 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[SimplMonad]{The simplifier Monad} +-} + +{-# LANGUAGE CPP #-} + +module SimplEnv ( + InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar, + OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar, + InCoercion, OutCoercion, + + -- The simplifier mode + setMode, getMode, updMode, + + -- Environments + SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, + zapSubstEnv, setSubstEnv, + getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, + getSimplRules, + + SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + + substExpr, + simplNonRecBndr, simplRecBndrs, + simplBinder, simplBinders, + substTy, substTyVar, getTvSubst, + getCvSubst, substCo, substCoVar, + + -- Floats + Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, + wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats, + doFloatFromRhs, getFloatBinds + ) where + +#include "HsVersions.h" + +import SimplMonad +import CoreMonad ( SimplifierMode(..) ) +import CoreSyn +import CoreUtils +import Var +import VarEnv +import VarSet +import OrdList +import Id +import qualified CoreSubst +import MkCore ( mkWildValBinder ) +import TysWiredIn +import qualified Type +import Type hiding ( substTy, substTyVarBndr, substTyVar ) +import qualified Coercion +import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr ) +import BasicTypes +import MonadUtils +import Outputable +import FastString +import Util + +import Data.List + +{- +************************************************************************ +* * +\subsection[Simplify-types]{Type declarations} +* * +************************************************************************ +-} + +type InBndr = CoreBndr +type InVar = Var -- Not yet cloned +type InId = Id -- Not yet cloned +type InType = Type -- Ditto +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type InCoercion = Coercion + +type OutBndr = CoreBndr +type OutVar = Var -- Cloned +type OutId = Id -- Cloned +type OutTyVar = TyVar -- Cloned +type OutType = Type -- Cloned +type OutCoercion = Coercion +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg + +{- +************************************************************************ +* * +\subsubsection{The @SimplEnv@ type} +* * +************************************************************************ +-} + +data SimplEnv + = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + + seMode :: SimplifierMode, + + -- The current substitution + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + + -- The current set of in-scope variables + -- They are all OutVars, and all bound in this module + seInScope :: InScopeSet, -- OutVars only + -- Includes all variables bound by seFloats + seFloats :: Floats + -- See Note [Simplifier floats] + } + +type StaticEnv = SimplEnv -- Just the static part is relevant + +pprSimplEnv :: SimplEnv -> SDoc +-- Used for debugging; selective +pprSimplEnv env + = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "IdSubst:") <+> ppr (seIdSubst env), + ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars) + ] + where + in_scope_vars = varEnvElts (getInScopeVars (seInScope env)) + ppr_one v | isId v = ppr v <+> ppr (idUnfolding v) + | otherwise = ppr v + +type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr + -- See Note [Extending the Subst] in CoreSubst + +data SimplSR + = DoneEx OutExpr -- Completed term + | DoneId OutId -- Completed term variable + | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv + SimplIdSubst + InExpr + +instance Outputable SimplSR where + ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e + ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v + ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (filter_env tv), ppr (filter_env id) -}] + -- where + -- fvs = exprFreeVars e + -- filter_env env = filterVarEnv_Directly keep env + -- keep uniq _ = uniq `elemUFM_Directly` fvs + +{- +Note [SimplEnv invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +seInScope: + The in-scope part of Subst includes *all* in-scope TyVars and Ids + The elements of the set may have better IdInfo than the + occurrences of in-scope Ids, and (more important) they will + have a correctly-substituted type. So we use a lookup in this + set to replace occurrences + + The Ids in the InScopeSet are replete with their Rules, + and as we gather info about the unfolding of an Id, we replace + it in the in-scope set. + + The in-scope set is actually a mapping OutVar -> OutVar, and + in case expressions we sometimes bind + +seIdSubst: + The substitution is *apply-once* only, because InIds and OutIds + can overlap. + For example, we generally omit mappings + a77 -> a77 + from the substitution, when we decide not to clone a77, but it's quite + legitimate to put the mapping in the substitution anyway. + + Furthermore, consider + let x = case k of I# x77 -> ... in + let y = case k of I# x77 -> ... in ... + and suppose the body is strict in both x and y. Then the simplifier + will pull the first (case k) to the top; so the second (case k) will + cancel out, mapping x77 to, well, x77! But one is an in-Id and the + other is an out-Id. + + Of course, the substitution *must* applied! Things in its domain + simply aren't necessarily bound in the result. + +* substId adds a binding (DoneId new_id) to the substitution if + the Id's unique has changed + + Note, though that the substitution isn't necessarily extended + if the type of the Id changes. Why not? Because of the next point: + +* We *always, always* finish by looking up in the in-scope set + any variable that doesn't get a DoneEx or DoneVar hit in the substitution. + Reason: so that we never finish up with a "old" Id in the result. + An old Id might point to an old unfolding and so on... which gives a space + leak. + + [The DoneEx and DoneVar hits map to "new" stuff.] + +* It follows that substExpr must not do a no-op if the substitution is empty. + substType is free to do so, however. + +* When we come to a let-binding (say) we generate new IdInfo, including an + unfolding, attach it to the binder, and add this newly adorned binder to + the in-scope set. So all subsequent occurrences of the binder will get + mapped to the full-adorned binder, which is also the one put in the + binding site. + +* The in-scope "set" usually maps x->x; we use it simply for its domain. + But sometimes we have two in-scope Ids that are synomyms, and should + map to the same target: x->x, y->x. Notably: + case y of x { ... } + That's why the "set" is actually a VarEnv Var +-} + +mkSimplEnv :: SimplifierMode -> SimplEnv +mkSimplEnv mode + = SimplEnv { seMode = mode + , seInScope = init_in_scope + , seFloats = emptyFloats + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv } + -- The top level "enclosing CC" is "SUBSUMED". + +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) + -- See Note [WildCard binders] + +{- +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be be *occurrences* of wild-id. For example, +MkCore.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. +-} + +getMode :: SimplEnv -> SimplifierMode +getMode env = seMode env + +setMode :: SimplifierMode -> SimplEnv -> SimplEnv +setMode mode env = env { seMode = mode } + +updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } + +--------------------- +extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env {seIdSubst = extendVarEnv subst var res} + +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res + = env {seTvSubst = extendVarEnv subst var res} + +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res + = env {seCvSubst = extendVarEnv subst var res} + +--------------------- +getInScope :: SimplEnv -> InScopeSet +getInScope env = seInScope env + +setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv +setInScopeSet env in_scope = env {seInScope = in_scope} + +setInScope :: SimplEnv -> SimplEnv -> SimplEnv +-- Set the in-scope set, and *zap* the floats +setInScope env env_with_scope + = env { seInScope = seInScope env_with_scope, + seFloats = emptyFloats } + +setFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Set the in-scope set *and* the floats +setFloats env env_with_floats + = env { seInScope = seInScope env_with_floats, + seFloats = seFloats env_with_floats } + +addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv + -- The new Ids are guaranteed to be freshly allocated +addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs + = env { seInScope = in_scope `extendInScopeSetList` vs, + seIdSubst = id_subst `delVarEnvList` vs } + -- Why delete? Consider + -- let x = a*b in (x, \x -> x+3) + -- We add [x |-> a*b] to the substitution, but we must + -- _delete_ it from the substitution when going inside + -- the (\x -> ...)! + +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} + +--------------------- +zapSubstEnv :: SimplEnv -> SimplEnv +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} + +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } + +mkContEx :: SimplEnv -> InExpr -> SimplSR +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e + +{- +************************************************************************ +* * +\subsection{Floats} +* * +************************************************************************ + +Note [Simplifier floats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The Floats is a bunch of bindings, classified by a FloatFlag. + +* All of them satisfy the let/app invariant + +Examples + + NonRec x (y:ys) FltLifted + Rec [(x,rhs)] FltLifted + + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? + NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n + + NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app +-} + +data Floats = Floats (OrdList OutBind) FloatFlag + -- See Note [Simplifier floats] + +data FloatFlag + = FltLifted -- All bindings are lifted and lazy + -- Hence ok to float to top level, or recursive + + | FltOkSpec -- All bindings are FltLifted *or* + -- strict (perhaps because unlifted, + -- perhaps because of a strict binder), + -- *and* ok-for-speculation + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + + | FltCareful -- At least one binding is strict (or unlifted) + -- and not guaranteed cheap + -- Do not float these bindings out of a lazy let + +instance Outputable Floats where + ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) + +instance Outputable FloatFlag where + ppr FltLifted = ptext (sLit "FltLifted") + ppr FltOkSpec = ptext (sLit "FltOkSpec") + ppr FltCareful = ptext (sLit "FltCareful") + +andFF :: FloatFlag -> FloatFlag -> FloatFlag +andFF FltCareful _ = FltCareful +andFF FltOkSpec FltCareful = FltCareful +andFF FltOkSpec _ = FltOkSpec +andFF FltLifted flt = flt + +doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs +doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) + = not (isNilOL fs) && want_to_float && can_float + where + want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs + -- See Note [Float when cheap or expandable] + can_float = case ff of + FltLifted -> True + FltOkSpec -> isNotTopLevel lvl && isNonRec rec + FltCareful -> isNotTopLevel lvl && isNonRec rec && str + +{- +Note [Float when cheap or expandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float a let from a let if the residual RHS is + a) cheap, such as (\x. blah) + b) expandable, such as (f b) if f is CONLIKE +But there are + - cheap things that are not expandable (eg \x. expensive) + - expandable things that are not cheap (eg (f b) where b is CONLIKE) +so we must take the 'or' of the two. +-} + +emptyFloats :: Floats +emptyFloats = Floats nilOL FltLifted + +unitFloat :: OutBind -> Floats +-- This key function constructs a singleton float with the right form +unitFloat bind = Floats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds + +addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv +-- Add a non-recursive binding and extend the in-scope set +-- The latter is important; the binder may already be in the +-- in-scope set (although it might also have been created with newId) +-- but it may now have more IdInfo +addNonRec env id rhs + = id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), + seInScope = extendInScopeSet (seInScope env) id } + +extendFloats :: SimplEnv -> OutBind -> SimplEnv +-- Add these bindings to the floats, and extend the in-scope env too +extendFloats env bind + = env { seFloats = seFloats env `addFlts` unitFloat bind, + seInScope = extendInScopeSetList (seInScope env) bndrs } + where + bndrs = bindersOf bind + +addFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Add the floats for env2 to env1; +-- *plus* the in-scope set for env2, which is bigger +-- than that for env1 +addFloats env1 env2 + = env1 {seFloats = seFloats env1 `addFlts` seFloats env2, + seInScope = seInScope env2 } + +addFlts :: Floats -> Floats -> Floats +addFlts (Floats bs1 l1) (Floats bs2 l2) + = Floats (bs1 `appOL` bs2) (l1 `andFF` l2) + +zapFloats :: SimplEnv -> SimplEnv +zapFloats env = env { seFloats = emptyFloats } + +addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv +-- Flattens the floats from env2 into a single Rec group, +-- prepends the floats from env1, and puts the result back in env2 +-- This is all very specific to the way recursive bindings are +-- handled; see Simplify.simplRecBind +addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) + = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) ) + env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} + +wrapFloats :: SimplEnv -> OutExpr -> OutExpr +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplEnv {seFloats = Floats bs _}) body + = foldrOL Let body bs + +getFloatBinds :: SimplEnv -> [CoreBind] +getFloatBinds (SimplEnv {seFloats = Floats bs _}) + = fromOL bs + +isEmptyFloats :: SimplEnv -> Bool +isEmptyFloats (SimplEnv {seFloats = Floats bs _}) + = isNilOL bs + +mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv +mapFloats env@SimplEnv { seFloats = Floats fs ff } fun + = env { seFloats = Floats (mapOL app fs) ff } + where + app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' + app (Rec bs) = Rec (map fun bs) + +{- +************************************************************************ +* * + Substitution of Vars +* * +************************************************************************ + +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurrence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) +-} + +substId :: SimplEnv -> InId -> SimplSR +-- Returns DoneEx only on a non-Var expression +substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] + Nothing -> DoneId (refineFromInScope in_scope v) + Just (DoneId v) -> DoneId (refineFromInScope in_scope v) + Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v) + Just res -> res -- DoneEx non-var, or ContEx + + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with better IdInfo +refineFromInScope :: InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalId v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( True, ppr v ) v -- This is an error! + | otherwise = v + +lookupRecBndr :: SimplEnv -> InId -> OutId +-- Look up an Id which has been put into the envt by simplRecBndrs, +-- but where we have not yet done its RHS +lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v + = case lookupVarEnv ids v of + Just (DoneId v) -> v + Just _ -> pprPanic "lookupRecBndr" (ppr v) + Nothing -> refineFromInScope in_scope v + +{- +************************************************************************ +* * +\section{Substituting an Id binder} +* * +************************************************************************ + + +* sinplBndr, simplBndrs: monadic version, only so that they + can be made strict via seq. + +-} + +------------- +simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplBinders env bndrs = mapAccumLM simplBinder env bndrs + +simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Used for lambda and case-bound variables +-- Clone Id if necessary, substitute type +-- Return with IdInfo already substituted, but (fragile) occurrence info zapped +-- The substitution is extended only if the variable is cloned, because +-- we *don't* need to use it to track occurrence info. +simplBinder env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr + ; seqTyVar tv `seq` return (env', tv) } + | otherwise = do { let (env', id) = substIdBndr env bndr + ; seqId id `seq` return (env', id) } + +simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- A non-recursive let binder +simplNonRecBndr env id + = do { let (env1, id1) = substIdBndr env id + ; seqId id1 `seq` return (env1, id1) } + +simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv +-- Recursive let binders +simplRecBndrs env@(SimplEnv {}) ids + = do { let (env1, ids1) = mapAccumL substIdBndr env ids + ; seqIds ids1 `seq` return env1 } + +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) +-- Clone Id if necessary, substitute its type +-- Return an Id with its +-- * Type substituted +-- * UnfoldingInfo, Rules, WorkerInfo zapped +-- * Fragile OccInfo (only) zapped: Note [Robust OccInfo] +-- * Robust info, retained especially arity and demand info, +-- so that they are available to occurrences that occur in an +-- earlier binding of a letrec +-- +-- For the robust info, see Note [Arity robustness] +-- +-- Augment the substitution if the unique changed +-- Extend the in-scope set with the new Id +-- +-- Similar to CoreSubst.substIdBndr, except that +-- the type of id_subst differs +-- all fragile info is zapped +substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id + = ASSERT2( not (isCoVar old_id), ppr old_id ) + (env { seInScope = in_scope `extendInScopeSet` new_id, + seIdSubst = new_subst }, new_id) + where + id1 = uniqAway in_scope old_id + id2 = substIdType env id1 + new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + new_subst | new_id /= old_id + = extendVarEnv id_subst old_id (DoneId new_id) + | otherwise + = delVarEnv id_subst old_id + +------------------------------------ +seqTyVar :: TyVar -> () +seqTyVar b = b `seq` () + +seqId :: Id -> () +seqId id = seqType (idType id) `seq` + idInfo id `seq` + () + +seqIds :: [Id] -> () +seqIds [] = () +seqIds (id:ids) = seqId id `seq` seqIds ids + +{- +Note [Arity robustness] +~~~~~~~~~~~~~~~~~~~~~~~ +We *do* transfer the arity from from the in_id of a let binding to the +out_id. This is important, so that the arity of an Id is visible in +its own RHS. For example: + f = \x. ....g (\y. f y).... +We can eta-reduce the arg to g, because f is a value. But that +needs to be visible. + +This interacts with the 'state hack' too: + f :: Bool -> IO Int + f = \x. case x of + True -> f y + False -> \s -> ... +Can we eta-expand f? Only if we see that f has arity 1, and then we +take advantage of the 'state hack' on the result of +(f y) :: State# -> (State#, Int) to expand the arity one more. + +There is a disadvantage though. Making the arity visible in the RHS +allows us to eta-reduce + f = \x -> f x +to + f = f +which technically is not sound. This is very much a corner case, so +I'm not worried about it. Another idea is to ensure that f's arity +never decreases; its arity started as 1, and we should never eta-reduce +below that. + + +Note [Robust OccInfo] +~~~~~~~~~~~~~~~~~~~~~ +It's important that we *do* retain the loop-breaker OccInfo, because +that's what stops the Id getting inlined infinitely, in the body of +the letrec. +-} + + +{- +************************************************************************ +* * + Impedence matching to type substitution +* * +************************************************************************ +-} + +getTvSubst :: SimplEnv -> TvSubst +getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) + = mkTvSubst in_scope tv_env + +getCvSubst :: SimplEnv -> CvSubst +getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = CvSubst in_scope tv_env cv_env + +substTy :: SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getTvSubst env) ty + +substTyVar :: SimplEnv -> TyVar -> Type +substTyVar env tv = Type.substTyVar (getTvSubst env) tv + +substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr env tv + = case Type.substTyVarBndr (getTvSubst env) tv of + (TvSubst in_scope' tv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getCvSubst env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getCvSubst env) co + +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + -- The tyVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +substExpr :: SimplEnv -> CoreExpr -> CoreExpr +-- See Note [Substitution in the simplifier] +substExpr (SimplEnv { seInScope = in_scope + , seTvSubst = tv_env + , seCvSubst = cv_env + , seIdSubst = id_env }) + = subst_expr in_scope tv_env cv_env id_env + where + subst_expr :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst + -> CoreExpr -> CoreExpr + subst_expr is tvs cvs id_env + = CoreSubst.substExpr (text "SimplEnv.substExpr") + (CoreSubst.mkGblSubst is tvs cvs lookup_id) + where + lookup_id in_scope v + = case lookupVarEnv id_env v of + Nothing -> Nothing + Just (DoneEx e) -> Just e + Just (DoneId v) -> Just (Var v) + Just (ContEx tv cv id e) -> Just (subst_expr in_scope tv cv id e) + +{- Note [Substitution in the simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In just one place (sigh) we need to lazily substitute over a CoreExpr. +For that we need CoreSubst.substExpr. But there is a difficulty: SimplEnv +has a SimplIdSubst, whose range is SimplSR, not just CoreExpr. + +So SimplEnv.substExpr has to perform impedence-matching, via the ambient +substitution provided by mkGblSubst. It seems like a lot of work for +a small thing. Previously we attempted to construct a (VarEnv CoreExpr) +from the SimplIdSubst, but that had absolutely terrible performance +(Trac #10370 comment:12). Then I tried to write a complete new substExpr +that used SimplIdSubst insead of (VarEnv CoreExpr), but that got out of +hand because we need to substitute over rules and unfoldings too +(Trac #5113, comment:7 and following). +-} + diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs new file mode 100644 index 00000000..451bf34f --- /dev/null +++ b/compiler/simplCore/SimplMonad.hs @@ -0,0 +1,218 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[SimplMonad]{The simplifier Monad} +-} + +module SimplMonad ( + -- The monad + SimplM, + initSmpl, traceSmpl, + getSimplRules, getFamEnvs, + + -- Unique supply + MonadUnique(..), newId, + + -- Counting + SimplCount, tick, freeTick, checkedTick, + getSimplCount, zeroSimplCount, pprSimplCount, + plusSimplCount, isZeroSimplCount + ) where + +import Id ( Id, mkSysLocal ) +import Type ( Type ) +import FamInstEnv ( FamInstEnv ) +import Rules ( RuleBase ) +import UniqSupply +import DynFlags +import CoreMonad +import Outputable +import FastString +import MonadUtils +import ErrUtils +import Control.Monad ( when, liftM, ap ) + +{- +************************************************************************ +* * +\subsection{Monad plumbing} +* * +************************************************************************ + +For the simplifier monad, we want to {\em thread} a unique supply and a counter. +(Command-line switches move around through the explicitly-passed SimplEnv.) +-} + +newtype SimplM result + = SM { unSM :: SimplTopEnv -- Envt that does not change much + -> UniqSupply -- We thread the unique supply because + -- constantly splitting it is rather expensive + -> SimplCount + -> IO (result, UniqSupply, SimplCount)} + -- we only need IO here for dump output + +data SimplTopEnv + = STE { st_flags :: DynFlags + , st_max_ticks :: Int -- Max #ticks in this simplifier run + -- Zero means infinity! + , st_rules :: RuleBase + , st_fams :: (FamInstEnv, FamInstEnv) } + +initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) + -> UniqSupply -- No init count; set to 0 + -> Int -- Size of the bindings, used to limit + -- the number of ticks we allow + -> SimplM a + -> IO (a, SimplCount) + +initSmpl dflags rules fam_envs us size m + = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) + return (result, count) + where + env = STE { st_flags = dflags, st_rules = rules + , st_max_ticks = computeMaxTicks dflags size + , st_fams = fam_envs } + +computeMaxTicks :: DynFlags -> Int -> Int +-- Compute the max simplifier ticks as +-- (base-size + pgm-size) * magic-multiplier * tick-factor/100 +-- where +-- magic-multiplier is a constant that gives reasonable results +-- base-size is a constant to deal with size-zero programs +computeMaxTicks dflags size + = fromInteger ((toInteger (size + base_size) + * toInteger (tick_factor * magic_multiplier)) + `div` 100) + where + tick_factor = simplTickFactor dflags + base_size = 100 + magic_multiplier = 40 + -- MAGIC NUMBER, multiplies the simplTickFactor + -- We can afford to be generous; this is really + -- just checking for loops, and shouldn't usually fire + -- A figure of 20 was too small: see Trac #553 + +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} + + +instance Functor SimplM where + fmap = liftM + +instance Applicative SimplM where + pure = returnSmpl + (<*>) = ap + (*>) = thenSmpl_ + +instance Monad SimplM where + (>>) = thenSmpl_ + (>>=) = thenSmpl + return = returnSmpl + +returnSmpl :: a -> SimplM a +returnSmpl e = SM (\_st_env us sc -> return (e, us, sc)) + +thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b +thenSmpl_ :: SimplM a -> SimplM b -> SimplM b + +thenSmpl m k + = SM $ \st_env us0 sc0 -> do + (m_result, us1, sc1) <- unSM m st_env us0 sc0 + unSM (k m_result) st_env us1 sc1 + +thenSmpl_ m k + = SM $ \st_env us0 sc0 -> do + (_, us1, sc1) <- unSM m st_env us0 sc0 + unSM k st_env us1 sc1 + +-- TODO: this specializing is not allowed +-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} + +traceSmpl :: String -> SDoc -> SimplM () +traceSmpl herald doc + = do { dflags <- getDynFlags + ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $ + printInfoForUser dflags alwaysQualify $ + hang (text herald) 2 doc } + +{- +************************************************************************ +* * +\subsection{The unique supply} +* * +************************************************************************ +-} + +instance MonadUnique SimplM where + getUniqueSupplyM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (us1, us2, sc)) + + getUniqueM + = SM (\_st_env us sc -> case takeUniqFromSupply us of + (u, us') -> return (u, us', sc)) + + getUniquesM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> return (uniqsFromSupply us1, us2, sc)) + +instance HasDynFlags SimplM where + getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc)) + +instance MonadIO SimplM where + liftIO m = SM $ \_ us sc -> do + x <- m + return (x, us, sc) + +getSimplRules :: SimplM RuleBase +getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc)) + +getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) +getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) + +newId :: FastString -> Type -> SimplM Id +newId fs ty = do uniq <- getUniqueM + return (mkSysLocal fs uniq ty) + +{- +************************************************************************ +* * +\subsection{Counting up what we've done} +* * +************************************************************************ +-} + +getSimplCount :: SimplM SimplCount +getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) + +tick :: Tick -> SimplM () +tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + +checkedTick :: Tick -> SimplM () +-- Try to take a tick, but fail if too many +checkedTick t + = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc + then pprPanic "Simplifier ticks exhausted" (msg sc) + else let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) + where + msg sc = vcat [ ptext (sLit "When trying") <+> ppr t + , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)") + , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed") + , pp_details sc + , pprSimplCount sc ] + pp_details sc + | hasDetailedCounts sc = empty + | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats") + + +freeTick :: Tick -> SimplM () +-- Record a tick, but don't add to the total tick count, which is +-- used to decide when nothing further has happened +freeTick t + = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc + in sc' `seq` return ((), us, sc')) diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs new file mode 100644 index 00000000..c7a3bc2c --- /dev/null +++ b/compiler/simplCore/SimplUtils.hs @@ -0,0 +1,2004 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[SimplUtils]{The simplifier utilities} +-} + +{-# LANGUAGE CPP #-} + +module SimplUtils ( + -- Rebuilding + mkLam, mkCase, prepareAlts, tryEtaExpandRhs, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, + + -- The continuation type + SimplCont(..), DupFlag(..), + isSimplified, + contIsDupable, contResultType, contHoleType, + contIsTrivial, contArgs, + countValArgs, countArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, + addValArgTo, addCastTo, addTyArgTo, + argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, + + abstractFloats + ) where + +#include "HsVersions.h" + +import SimplEnv +import CoreMonad ( SimplifierMode(..), Tick(..) ) +import MkCore ( sortQuantVars ) +import DynFlags +import CoreSyn +import qualified CoreSubst +import PprCore +import CoreFVs +import CoreUtils +import CoreArity +import CoreUnfold +import Name +import Id +import Var +import Demand +import SimplMonad +import Type hiding( substTy ) +import Coercion hiding( substCo, substTy ) +import DataCon ( dataConWorkId ) +import VarEnv +import VarSet +import BasicTypes +import Util +import MonadUtils +import Outputable +import FastString +import Pair +import ListSetOps ( minusList ) + +import Control.Monad ( when ) +import Data.List ( partition ) + +{- +************************************************************************ +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- An empty context, or + OutType -- Type of the + CallCtxt -- Tells if there is something interesting about + -- the context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + + | CastIt -- `cast` co + OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + SimplCont + + | ApplyToVal { -- arg + sc_dup :: DupFlag, -- See Note [DupFlag invariants] + sc_arg :: InExpr, -- The argument, + sc_env :: StaticEnv, -- and its static env + sc_cont :: SimplCont } + + | ApplyToTy { -- ty + sc_arg_ty :: OutType, -- Argument type + sc_hole_ty :: OutType, -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + sc_cont :: SimplCont } + + | Select -- case of alts + DupFlag -- See Note [DupFlag invariants] + InId [InAlt] StaticEnv -- The case binder, alts type, alts, and subst-env + SimplCont + + -- The two strict forms have no DupFlag, because we never duplicate them + | StrictBind -- (\x* \xs. e) + InId [InBndr] -- let x* = in e + InExpr StaticEnv -- is a special case + SimplCont + + | StrictArg -- f e1 ..en + ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus strictness flags for *further* args + CallCtxt -- Whether *this* argument position is interesting + SimplCont + + | TickIt + (Tickish Id) -- Tick tickish + SimplCont + +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both (ApplyToVal dup _ env k) + and (Select dup _ _ env k) +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty + (and and hence no need to re-simplify) +-} + +instance Outputable DupFlag where + ppr OkToDup = ptext (sLit "ok") + ppr NoDup = ptext (sLit "nodup") + ppr Simplified = ptext (sLit "simpl") + +instance Outputable SimplCont where + ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty + ppr (ApplyToTy { sc_arg_ty = ty + , sc_cont = cont }) = (ptext (sLit "ApplyToTy") <+> pprParendType ty) $$ ppr cont + ppr (ApplyToVal { sc_arg = arg + , sc_dup = dup + , sc_cont = cont }) = (ptext (sLit "ApplyToVal") <+> ppr dup <+> pprParendExpr arg) + $$ ppr cont + ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont + ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont + ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ + ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + ppr (CastIt co cont ) = (ptext (sLit "CastIt") <+> ppr co) $$ ppr cont + ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = ArgInfo { + ai_fun :: OutId, -- The function + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) + ai_type :: OutType, -- Type of (f a1 ... an) + + ai_rules :: [CoreRule], -- Rules for this function + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_strs :: [Bool], -- Strictness of remaining arguments + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline + -- Always infinite + } + +data ArgSpec + = ValArg OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal + | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy + , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) + | CastBy OutCoercion -- Cast by this; c.f. CastIt + +instance Outputable ArgSpec where + ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e + ppr (TyArg { as_arg_ty = ty }) = ptext (sLit "TyArg") <+> ppr ty + ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c + +addValArgTo :: ArgInfo -> OutExpr -> ArgInfo +addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai + , ai_type = funResultTy (ai_type ai) } + +addTyArgTo :: ArgInfo -> OutType -> ArgInfo +addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai + , ai_type = applyTy poly_fun_ty arg_ty } + where + poly_fun_ty = ai_type ai + arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } + +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai + , ai_type = pSnd (coercionKind co) } + +argInfoAppArgs :: [ArgSpec] -> [OutExpr] +argInfoAppArgs [] = [] +argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast +argInfoAppArgs (ValArg e : as) = e : argInfoAppArgs as +argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as + +pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont +pushSimplifiedArgs _env [] k = k +pushSimplifiedArgs env (arg : args) k + = case arg of + TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } + -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } + ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest } + CastBy c -> CastIt c rest + where + rest = pushSimplifiedArgs env args k + -- The env has an empty SubstEnv + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + go [] = Var fun + go (ValArg a : as) = go as `App` a + go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty + go (CastBy co : as) = mkCast (go as) co + + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt + +mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold +mkRhsStop ty = Stop ty RhsCtxt + +mkLazyArgStop :: OutType -> CallCtxt -> SimplCont +mkLazyArgStop ty cci = Stop ty cci + +------------------- +contIsRhsOrArg :: SimplCont -> Bool +contIsRhsOrArg (Stop {}) = True +contIsRhsOrArg (StrictBind {}) = True +contIsRhsOrArg (StrictArg {}) = True +contIsRhsOrArg _ = False + +contIsRhs :: SimplCont -> Bool +contIsRhs (Stop _ RhsCtxt) = True +contIsRhs _ = False + +------------------- +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] +contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto... +contIsDupable (CastIt _ k) = contIsDupable k +contIsDupable _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k +contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k +contIsTrivial (CastIt _ k) = contIsTrivial k +contIsTrivial _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _) = ty +contResultType (CastIt _ k) = contResultType k +contResultType (StrictBind _ _ _ _ k) = contResultType k +contResultType (StrictArg _ _ k) = contResultType k +contResultType (Select _ _ _ _ k) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt co _) = pFst (coercionKind co) +contHoleType (Select d b _ se _) = perhapsSubstTy d se (idType b) +contHoleType (StrictBind b _ _ se _) = substTy se (idType b) +contHoleType (StrictArg ai _ _) = funArgTy (ai_type ai) +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k }) + = mkFunTy (perhapsSubstTy dup se (exprType e)) + (contHoleType k) + +------------------- +countValArgs :: SimplCont -> Int +-- Count value arguments excluding coercions +countValArgs (ApplyToVal { sc_arg = arg, sc_cont = cont }) + | Coercion {} <- arg = countValArgs cont + | otherwise = 1 + countValArgs cont +countValArgs _ = 0 + +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, and other values +countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont +countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs _ = 0 + +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in CoreUnfold + lone (ApplyToVal {}) = False + lone (CastIt {}) = False + lone _ = True + + go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) + = go (is_interesting arg se : args) k + go args (ApplyToTy { sc_cont = k }) = go args k + go args (CastIt _ k) = go args k + go args k = (False, reverse args, k) + + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + + +------------------- +mkArgInfo :: Id + -> [CoreRule] -- Rules for function + -> Int -- Number of value args + -> SimplCont -- Context of the call + -> ArgInfo + +mkArgInfo fun rules n_val_args call_cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = rules, ai_encl = False + , ai_strs = vanilla_stricts + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty + , ai_rules = rules + , ai_encl = interestingArgContext rules call_cont + , ai_strs = add_type_str fun_ty arg_stricts + , ai_discs = arg_discounts } + where + fun_ty = idType fun + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_stricts, arg_stricts :: [Bool] + vanilla_stricts = repeat False + + arg_stricts + = case splitStrictSig (idStrictness fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok (see SimplUtils.analyseCont) + if isBotRes result_info then + map isStrictDmd demands -- Finite => result is bottom + else + map isStrictDmd demands ++ vanilla_stricts + | otherwise + -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands ) + vanilla_stricts -- Not enough args, or no strictness + + add_type_str :: Type -> [Bool] -> [Bool] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_str is done repeatedly (for each call); might be better + -- once-for-all in the function + -- But beware primops/datacons with no strictness + add_type_str _ [] = [] + add_type_str fun_ty strs -- Look through foralls + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions + = add_type_str fun_ty' strs + add_type_str fun_ty (str:strs) -- Add strict-type info + | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + = (str || isStrictType arg_ty) : add_type_str fun_ty' strs + add_type_str _ strs + = strs + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee, application etc.) then we +inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. +-} + +interestingCallContext :: SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext cont + = interesting cont + where + interesting (Select _ _bndr _ _ _) = CaseCtxt + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in CoreUnfold + interesting (StrictArg _ cci _) = cci + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt _ k) = interesting k + -- If this call is the arg of a strict function, the context + -- is a bit interesting. If we inline here, we may get useful + -- evaluation information to avoid repeated evals: e.g. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +interestingArgContext :: [CoreRule] -> SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f; hence the +-- call_cont argument to interestingArgContext +-- +-- The ai-rules flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +-- +-- The call_cont passed to interestingArgContext is the context of +-- the call itself, e.g. g in the example above +interestingArgContext rules call_cont + = notNull rules || enclosing_fn_has_rules + where + enclosing_fn_has_rules = go call_cont + + go (Select {}) = False + go (ApplyToVal {}) = False -- Shouldn't really happen + go (ApplyToTy {}) = False -- Ditto + go (StrictArg _ cci _) = interesting cci + go (StrictBind {}) = False -- ?? + go (CastIt _ c) = go c + go (Stop _ cci) = interesting cci + go (TickIt _ c) = go c + + interesting RuleArgCtxt = True + interesting _ = False + + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + | SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env + = case lookupVarEnv ids v of + Nothing -> go_var n (refineFromInScope in_scope v) + Just (DoneId v') -> go_var n (refineFromInScope in_scope v') + Just (DoneEx e) -> go (zapSubstEnv env) n e + Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit {}) = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn (Coercion _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = go env (n-1) e + | otherwise = ValueArg + go env n (Let _ e) = case go env n e of { ValueArg -> ValueArg; _ -> NonTrivArg } + go _ _ (Case {}) = NonTrivArg + + go_var n v + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] + | otherwise = TrivArg -- n==0, no useful unfolding + where + conlike_unfolding = isConLikeUnfolding (idUnfolding v) + +{- +************************************************************************ +* * + SimplifierMode +* * +************************************************************************ + +The SimplifierMode controls several switches; see its definition in +CoreMonad + sm_rules :: Bool -- Whether RULES are enabled + sm_inline :: Bool -- Whether inlining is enabled + sm_case_case :: Bool -- Whether case-of-case is enabled + sm_eta_expand :: Bool -- Whether eta-expansion is enabled +-} + +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = gopt Opt_EnableRewriteRules dflags + eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags + -- Do not do any inlining, in case we expose some unboxed + -- tuple stuff that confuses the bytecode interpreter + +updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode +-- See Note [Simplifying inside stable unfoldings] +updModeForStableUnfoldings inline_rule_act current_mode + = current_mode { sm_phase = phaseFromActivation inline_rule_act + , sm_inline = True + , sm_eta_expand = False } + -- For sm_rules, just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplifierMode -> SimplifierMode +-- See Note [Simplifying rules] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False + , sm_rules = False + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule, refrain from any inlining or applying of other RULES. + +Doing anything to the LHS is plain confusing, because it means that what the +rule matches is not what the user wrote. c.f. Trac #10595, and #10528. +Moreover, inlining (or applying rules) on rule LHSs risks introducing +Ticks into the LHS, which makes matching trickier. Trac #10665, #10745. + +Doing this to either side confounds tools like HERMIT, which seek to reason +about and apply the RULES as originally written. See Trac #10829. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating + e.g. ...(case f x of ...)... + ==> ...(case (case x of I# x# -> fw x#) of ...)... + ==> ...(case x of I# x# -> case fw x# of ...)... +and now the redex (f x) isn't floatable any more. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of an stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +continuation. +-} + +activeUnfolding :: SimplEnv -> Id -> Bool +activeUnfolding env + | not (sm_inline mode) = active_unfolding_minimal + | otherwise = case sm_phase mode of + InitialPhase -> active_unfolding_gentle + Phase n -> active_unfolding n + where + mode = getMode env + +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv +-- When matching in RULE, we want to "look through" an unfolding +-- (to see a constructor) if *rules* are on, even if *inlinings* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = (in_scope, id_unf) + where + in_scope = seInScope env + mode = getMode env + id_unf id | unf_is_active id = idUnfolding id + | otherwise = NoUnfolding + unf_is_active id + | not (sm_rules mode) = active_unfolding_minimal id + | otherwise = isActive (sm_phase mode) (idInlineActivation id) + +active_unfolding_minimal :: Id -> Bool +-- Compuslory unfoldings only +-- Ignore SimplGently, because we want to inline regardless; +-- the Id has no top-level binding at all +-- +-- NB: we used to have a second exception, for data con wrappers. +-- On the grounds that we use gentle mode for rule LHSs, and +-- they match better when data con wrappers are inlined. +-- But that only really applies to the trivial wrappers (like (:)), +-- and they are now constructed as Compulsory unfoldings (in MkId) +-- so they'll happen anyway. +active_unfolding_minimal id = isCompulsoryUnfolding (realIdUnfolding id) + +active_unfolding :: PhaseNum -> Id -> Bool +active_unfolding n id = isActiveIn n (idInlineActivation id) + +active_unfolding_gentle :: Id -> Bool +-- Anything that is early-active +-- See Note [Gentle mode] +active_unfolding_gentle id + = isInlinePragma prag + && isEarlyActive (inlinePragmaActivation prag) + -- NB: wrappers are not early-active + where + prag = idInlinePragma id + +---------------------- +activeRule :: SimplEnv -> Activation -> Bool +-- Nothing => No rules at all +activeRule env + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + where + mode = getMode env + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrenc of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until Phase 0 (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the intial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of f1. But if we inline it there +we'll lose the opportunity to inline at each of fInt's call sites. +The INLINE pragma will only inline when the application is saturated +for exactly this reason; and we don't want PreInlineUnconditionally +to second-guess it. A live example is Trac #3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +Note [Top-level botomming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings +preInlineUnconditionally dflags env top_lvl bndr rhs + | not active = False + | isStableUnfolding (idUnfolding bndr) = False -- Note [Stable unfoldings and preInlineUnconditionally] + | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] + | not (gopt Opt_SimplPreInlining dflags) = False + | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally] + | otherwise = case idOccInfo bndr of + IAmDead -> True -- Happens in ((\x.1) v) + OneOcc in_lam True int_cxt -> try_once in_lam int_cxt + _ -> False + where + mode = getMode env + active = isActive (sm_phase mode) act + -- See Note [pre/postInlineUnconditionally in gentle mode] + act = idInlineActivation bndr + try_once in_lam int_cxt -- There's one textual occurrence + | not in_lam = isNotTopLevel top_lvl || early_phase + | otherwise = int_cxt && canInlineInLam rhs + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = case sm_phase mode of + Phase 0 -> False + _ -> True +-- If we don't have this early_phase test, consider +-- x = length [1,2,3] +-- The full laziness pass carefully floats all the cons cells to +-- top level, and preInlineUnconditionally floats them all back in. +-- Result is (a) static allocation replaced by dynamic allocation +-- (b) many simplifier iterations because this tickles +-- a related problem; only one inlining per pass +-- +-- On the other hand, I have seen cases where top-level fusion is +-- lost if we don't inline top level thing (e.g. string constants) +-- Hence the test for phase zero (which is the phase for all the final +-- simplifications). Until phase zero we take no special notice of +-- top level things, but then we become more leery about inlining +-- them. + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +ocurrence(s) + +Note that we do this unconditional inlining only for trival RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. +-} + +postInlineUnconditionally + :: DynFlags -> SimplEnv -> TopLevelFlag + -> OutId -- The binder (an InId would be fine too) + -- (*not* a CoVar) + -> OccInfo -- From the InId + -> OutExpr + -> Unfolding + -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings +postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding + | not active = False + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | isExportedId bndr = False + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] + | exprIsTrivial rhs = True + | otherwise + = case occ_info of + -- The point of examining occ_info here is that for *non-values* + -- that occur outside a lambda, the call-site inliner won't have + -- a chance (because it doesn't know that the thing + -- only occurs once). The pre-inliner won't have gotten + -- it either, if the thing occurs in more than one branch + -- So the main target is things like + -- let x = f y in + -- case v of + -- True -> case x of ... + -- False -> case x of ... + -- This is very important in practice; e.g. wheel-seive1 doubles + -- in allocation if you miss this out + OneOcc in_lam _one_br int_cxt -- OneOcc => no code-duplication issue + -> smallEnoughToInline dflags unfolding -- Small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + -- + -- NB: Do NOT inline arbitrarily big things, even if one_br is True + -- Reason: doing so risks exponential behaviour. We simplify a big + -- expression, inline it, and simplify it again. But if the + -- very same thing happens in the big expression, we get + -- exponential cost! + -- PRINCIPLE: when we've already simplified an expression once, + -- make sure that we only inline it if it's reasonably small. + + && (not in_lam || + -- Outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + (isCheapUnfolding unfolding && int_cxt)) + -- isCheap => acceptable work duplication; in_lam may be true + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + + IAmDead -> True -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> False + +-- Here's an example that we don't handle well: +-- let f = if b then Left (\x.BIG) else Right (\y.BIG) +-- in \y. ....case f of {...} .... +-- Here f is used just once, and duplicating the case work is fine (exprIsCheap). +-- But +-- - We can't preInlineUnconditionally because that woud invalidate +-- the occ info for b. +-- - We can't postInlineUnconditionally because the RHS is big, and +-- that risks exponential behaviour +-- - We can't call-site inline, because the rhs is big +-- Alas! + + where + active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has an stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr +-- mkLam tries three things +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] + +mkLam [] body _cont + = return body +mkLam bndrs body cont + = do { dflags <- getDynFlags + ; mkLam' dflags bndrs body } + where + mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + mkLam' dflags bndrs (Cast body co) + | not (any bad bndrs) + -- Note [Casts and lambdas] + = do { lam <- mkLam' dflags bndrs body + ; return (mkCast lam (mkPiCos Representational bndrs co)) } + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mkLam' dflags bndrs body@(Lam {}) + = mkLam' dflags (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mkLam' dflags bndrs (Tick t expr) + | tickishFloatable t + = mkTick t <$> mkLam' dflags bndrs expr + + mkLam' dflags bndrs body + | gopt Opt_DoEtaReduction dflags + , Just etad_lam <- tryEtaReduce bndrs body + = do { tick (EtaReduction (head bndrs)) + ; return etad_lam } + + | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] + , gopt Opt_DoLambdaEtaExpansion dflags + , any isRuntimeVar bndrs + , let body_arity = exprEtaExpandArity dflags body + , body_arity > 0 + = do { tick (EtaExpansion (head bndrs)) + ; return (mkLams bndrs (etaExpand body_arity body)) } + + | otherwise + = return (mkLams bndrs body) + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\x. (\y. e) `cast` g1) `cast` g2 +There is a danger here that the two lambdas look separated, and the +full laziness pass might float an expression to between the two. + +So this equation in mkLam' floats the g1 out, thus: + (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) +where x:tx. + +In general, this floats casts outside lambdas, where (I hope) they +might meet and cancel with some other cast: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +Notice that it works regardless of 'e'. Originally it worked only +if 'e' was itself a lambda, but in some cases that resulted in +fruitless iteration in the simplifier. A good example was when +compiling Text.ParserCombinators.ReadPrec, where we had a definition +like (\x. Get `cast` g) +where Get is a constructor with nonzero arity. Then mkLam eta-expanded +the Get, and the next iteration eta-reduced it, and then eta-expanded +it again. + +Note also the side condition for the case of coercion binders. +It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) +because the latter is not well-kinded. + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) +-- See Note [Eta-expanding at let bindings] +tryEtaExpandRhs env bndr rhs + = do { dflags <- getDynFlags + ; (new_arity, new_rhs) <- try_expand dflags + + ; WARN( new_arity < old_id_arity, + (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_id_arity + <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) + -- Note [Arity decrease] in Simplify + return (new_arity, new_rhs) } + where + try_expand dflags + | exprIsTrivial rhs + = return (exprArity rhs, rhs) + + | sm_eta_expand (getMode env) -- Provided eta-expansion is on + , let new_arity1 = findRhsArity dflags bndr rhs old_arity + new_arity2 = idCallArity bndr + new_arity = max new_arity1 new_arity2 + , new_arity > old_arity -- And the current manifest arity isn't enough + = do { tick (EtaExpansion bndr) + ; return (new_arity, etaExpand new_arity rhs) } + | otherwise + = return (old_arity, rhs) + + old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs] + old_id_arity = idArity bndr + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in CoreArity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by Trac #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand do + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G beore, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in SimplUtils.abstractFloats, +but there is quite a bit of plumbing in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Note that + + * The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + + * We must do closeOverKinds. Example (Trac #10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. +-} + +abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats main_tvs body_env body + = ASSERT( notNull body_floats ) + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) } + where + main_tv_set = mkVarSet main_tvs + body_floats = getFloatBinds body_env + empty_subst = CoreSubst.mkEmptySubst (seInScope body_env) + + abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind) + abstract subst (NonRec id rhs) + = do { (poly_id, poly_app) <- mk_poly tvs_here id + ; let poly_rhs = mkLams tvs_here rhs' + subst' = CoreSubst.extendIdSubst subst id poly_app + ; return (subst', (NonRec poly_id poly_rhs)) } + where + rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = varSetElemsKvsFirst $ + intersectVarSet main_tv_set $ + closeOverKinds $ + exprSomeFreeVars isTyVar rhs' + + abstract subst (Rec prs) + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids + ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps) + poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs) + | rhs <- rhss] + ; return (subst', Rec (poly_ids `zip` poly_rhss)) } + where + (ids,rhss) = unzip prs + -- For a recursive group, it's a bit of a pain to work out the minimal + -- set of tyvars over which to abstract: + -- /\ a b c. let x = ...a... in + -- letrec { p = ...x...q... + -- q = .....p...b... } in + -- ... + -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + -- Since it's a pain, we just use the whole set, which is always safe + -- + -- If you ever want to be more selective, remember this bizarre case too: + -- x::a = x + -- Here, we must abstract 'x' over 'a'. + tvs_here = sortQuantVars main_tvs + + mk_poly tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs + mkLocalId poly_name poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. Eliminate alternatives that cannot match, including the + DEFAULT alternative. + +2. If the DEFAULT alternative can match only one possible constructor, + then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + +3. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +Here "cannot match" includes knowledge from GADTs + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! +-} + +prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +prepareAlts scrut case_bndr' alts + -- Case binder is needed just for its type. Note that as an + -- OutId, it has maximum information; this is important. + -- Test simpl013 is an example + = do { us <- getUniquesM + ; let (imposs_deflt_cons', refined_deflt, alts') + = filterAlts us (varType case_bndr') imposs_cons alts + (combining_done, imposs_deflt_cons'', alts'') + = combineIdenticalAlts imposs_deflt_cons' alts' + ; when refined_deflt $ tick (FillInCaseDefault case_bndr') + ; when combining_done $ tick (AltMerge case_bndr') + ; return (imposs_deflt_cons'', alts'') } + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + +{- Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.lhs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +NB: it's important that all this is done in [InAlt], *before* we work +on the alternatives themselves, because Simpify.simplAlt may zap the +occurrence info on the binders in the alternatives, which in turn +defeats combineIdenticalAlts (see Trac #7360). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (Trac #10538) + data T = A | B | C + + ... case x::T of + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the "impossible +constructors" for the DEFAULT alt is {A,B}, since if x is A or B we'll +take the other alternatives. But suppose we combine B into the DEFAULT, +to get + ... case x::T of + DEFAULT -> e1 + A -> e2 +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! +-} + + +combineIdenticalAlts :: [AltCon] -> [InAlt] -> (Bool, [AltCon], [InAlt]) +-- See Note [Combine identical alternatives] +-- See Note [Care with impossible-constructors when combining alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_cons ((_con1,bndrs1,rhs1) : con_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null eliminated_alts) -- alternative comes first + = (True, imposs_cons', deflt_alt : filtered_alts) + where + (eliminated_alts, filtered_alts) = partition identical_to_alt1 con_alts + deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) + imposs_cons' = imposs_cons `minusList` map fstOf3 eliminated_alts + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (_con,bndrs,rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (stripTicksT tickishFloatable . thirdOf3) eliminated_alts + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +mkCase tries these things + +1. Merge Nested Cases + + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + + which merges two cases in one case when -- the default alternative of + the outer case scrutises the same variable as the outer case. This + transformation is called Case Merging. It avoids that the same + variable is scrutinised multiple times. + +2. Eliminate Identity Case + + case e of ===> e + True -> True; + False -> False + + and similar friends. +-} + +mkCase, mkCase1, mkCase2 + :: DynFlags + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-------------------------------------------------- + +mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts) + | gopt Opt_CaseMerge dflags + , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) + <- stripTicksTop tickishFloatable deflt_rhs + , inner_scrut_var == outer_bndr + = do { tick (CaseMerge outer_bndr) + + ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) + (con, args, wrap_rhs rhs) + -- Simplifier's no-shadowing invariant should ensure + -- that outer_bndr is not shadowed by the inner patterns + wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs + -- The let is OK even for unboxed binders, + + wrapped_alts | isDeadBinder inner_bndr = inner_alts + | otherwise = map wrap_alt inner_alts + + merged_alts = mergeAlts outer_alts wrapped_alts + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + + ; fmap (mkTicks ticks) $ + mkCase1 dflags scrut outer_bndr alts_ty merged_alts + } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + +mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (stripTicksT tickishFloatable . thirdOf3) (tail alts) + identity_alt (con, args, rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + -- See Note [RHS casts] + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) [] = v == dataConWorkId con + -- Optimisation only + check_eq (Tick t e) alt args = tickishFloatable t && + check_eq e alt args + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp con (arg_tys ++ + varsToCoreExprs args) + check_eq _ _ _ = False + + arg_tys = map Type (tyConAppArgs (idType case_bndr)) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase2 _dflags scrut bndr alts_ty alts + = return (Case scrut bndr alts_ty alts) + +{- +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because it +happens bottom-up + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is corect, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. +-} diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs new file mode 100644 index 00000000..40a6ec03 --- /dev/null +++ b/compiler/simplCore/Simplify.hs @@ -0,0 +1,2977 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + +{-# LANGUAGE CPP #-} + +module Simplify ( simplTopBinds, simplExpr, simplRules ) where + +#include "HsVersions.h" + +import DynFlags +import SimplMonad +import Type hiding ( substTy, extendTvSubst, substTyVar ) +import SimplEnv +import SimplUtils +import FamInstEnv ( FamInstEnv ) +import Literal ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326 +import Id +import MkId ( seqId, voidPrimId ) +import MkCore ( mkImpossibleExpr, castBottomExpr ) +import IdInfo +import Name ( Name, mkSystemVarName, isExternalName ) +import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) +import OptCoercion ( optCoercion ) +import FamInstEnv ( topNormaliseType_maybe ) +import DataCon ( DataCon, dataConWorkId, dataConRepStrictness + , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG ) +--import TyCon ( isEnumerationTyCon ) -- temporalily commented out. See #8326 +import CoreMonad ( Tick(..), SimplifierMode(..) ) +import CoreSyn +import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd ) +import PprCore ( pprCoreExpr ) +import CoreUnfold +import CoreUtils +import CoreArity +--import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326 +import Rules ( mkSpecInfo, lookupRule, getRules ) +import TysPrim ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326 +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) +import MonadUtils ( foldlM, mapAccumLM, liftIO ) +import Maybes ( orElse ) +--import Unique ( hasKey ) -- temporalily commented out. See #8326 +import Control.Monad +import Outputable +import FastString +import Pair +import Util +import ErrUtils + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in SimplCore.lhs. + + +----------------------------------------- + *** IMPORTANT NOTE *** +----------------------------------------- +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + +----------------------------------------- + *** IMPORTANT NOTE *** +----------------------------------------- +Many parts of the simplifier return a bunch of "floats" as well as an +expression. This is wrapped as a datatype SimplUtils.FloatsWith. + +All "floats" are let-binds, not case-binds, but some non-rec lets may +be unlifted (with RHS ok-for-speculation). + + + +----------------------------------------- + ORGANISATION OF FUNCTIONS +----------------------------------------- +simplTopBinds + - simplify all top-level binders + - for NonRec, call simplRecOrTopPair + - for Rec, call simplRecBind + + + ------------------------------ +simplExpr (applied lambda) ==> simplNonRecBind +simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind +simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind + + ------------------------------ +simplRecBind [binders already simplfied] + - use simplRecOrTopPair on each pair in turn + +simplRecOrTopPair [binder already simplified] + Used for: recursive bindings (top level and nested) + top-level non-recursive bindings + Returns: + - check for PreInlineUnconditionally + - simplLazyBind + +simplNonRecBind + Used for: non-top-level non-recursive bindings + beta reductions (which amount to the same thing) + Because it can deal with strict arts, it takes a + "thing-inside" and returns an expression + + - check for PreInlineUnconditionally + - simplify binder, including its IdInfo + - if strict binding + simplStrictArg + mkAtomicArgs + completeNonRecX + else + simplLazyBind + addFloats + +simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder] + Used for: binding case-binder and constr args in a known-constructor case + - check for PreInLineUnconditionally + - simplify binder + - completeNonRecX + + ------------------------------ +simplLazyBind: [binder already simplified, RHS not] + Used for: recursive bindings (top level and nested) + top-level non-recursive bindings + non-top-level, but *lazy* non-recursive bindings + [must not be strict or unboxed] + Returns floats + an augmented environment, not an expression + - substituteIdInfo and add result to in-scope + [so that rules are available in rec rhs] + - simplify rhs + - mkAtomicArgs + - float if exposes constructor or PAP + - completeBind + + +completeNonRecX: [binder and rhs both simplified] + - if the the thing needs case binding (unlifted and not ok-for-spec) + build a Case + else + completeBind + addFloats + +completeBind: [given a simplified RHS] + [used for both rec and non-rec bindings, top level and not] + - try PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + + + +Right hand sides and arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In many ways we want to treat + (a) the right hand side of a let(rec), and + (b) a function argument +in the same way. But not always! In particular, we would +like to leave these arguments exactly as they are, so they +will match a RULE more easily. + + f (g x, h x) + g (+ x) + +It's harder to make the rule match if we ANF-ise the constructor, +or eta-expand the PAP: + + f (let { a = g x; b = h x } in (a,b)) + g (\y. + x y) + +On the other hand if we see the let-defns + + p = (g x, h x) + q = + x + +then we *do* want to ANF-ise and eta-expand, so that p and q +can be safely inlined. + +Even floating lets out is a bit dubious. For let RHS's we float lets +out if that exposes a value, so that the value can be inlined more vigorously. +For example + + r = let x = e in (x,x) + +Here, if we float the let out we'll expose a nice constructor. We did experiments +that showed this to be a generally good thing. But it was a bad thing to float +lets out unconditionally, because that meant they got allocated more often. + +For function arguments, there's less reason to expose a constructor (it won't +get inlined). Just possibly it might make a rule match, but I'm pretty skeptical. +So for the moment we don't float lets out of function arguments either. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv + +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a transformation rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See note [Glomming] in OccurAnal. + ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) + ; env2 <- simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return env2 } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv + simpl_binds env [] = return env + simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind + ; simpl_binds env' binds } + + simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs + simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) + ; simplRecOrTopPair env' TopLevel NonRecursive b b' r } + +{- +************************************************************************ +* * +\subsection{Lazy bindings} +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> TopLevelFlag + -> [(InId, InExpr)] + -> SimplM SimplEnv +simplRecBind env0 top_lvl pairs0 + = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 + ; env1 <- go (zapFloats env_with_info) triples + ; return (env0 `addRecFloats` env1) } + -- addFloats adds the floats from env1, + -- _and_ updates env0 with the in-scope set from env1 + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return env + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs + ; go env' pairs } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM SimplEnv -- Returns an env that includes the binding + +simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs + = do { dflags <- getDynFlags + ; trace_bind dflags $ + if preInlineUnconditionally dflags env top_lvl old_bndr rhs + -- Check for unconditional inline + then do tick (PreInlineUnconditionally old_bndr) + return (extendIdSubst env old_bndr (mkContEx env rhs)) + else simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env } + where + trace_bind dflags thing_inside + | not (dopt Opt_D_verbose_core2core dflags) + = thing_inside + | otherwise + = pprTrace "SimplBind" (ppr old_bndr) thing_inside + -- trace_bind emits a trace for each top-level binding, which + -- helps to locate the tracing for inlining and rule firing + +{- +simplLazyBind is used for + * [simplRecOrTopPair] recursive bindings (whether top level or not) + * [simplRecOrTopPair] top-level non-recursive bindings + * [simplNonRecE] non-top-level *lazy* non-recursive bindings + +Nota bene: + 1. It assumes that the binder is *already* simplified, + and is in scope, and its IdInfo too, except unfolding + + 2. It assumes that the binder type is lifted. + + 3. It does not check for pre-inline-unconditionally; + that should have been done already. +-} + +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, unfolding + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM SimplEnv +-- Precondition: rhs obeys the let/app invariant +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScope` env + (tvs, body) = case collectTyBinders rhs of + (tvs, body) | not_lam body -> (tvs,body) + | otherwise -> ([], rhs) + not_lam (Lam _ _) = False + not_lam (Tick t e) | not (tickishFloatable t) + = not_lam e -- eta-reduction could float + not_lam _ = True + -- Do not do the "abstract tyyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + + ; (body_env, tvs') <- simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in SimplUtils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + ; (body_env1, body1) <- simplExprF body_env body rhs_cont + -- ANF-ise a constructor or PAP rhs + ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1 + + ; (env', rhs') + <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) + then -- No floating, revert to body1 + do { rhs' <- mkLam tvs' (wrapFloats body_env1 body1) rhs_cont + ; return (env, rhs') } + + else if null tvs then -- Simple floating + do { tick LetFloatFromLet + ; return (addFloats env body_env2, body2) } + + else -- Do type-abstraction first + do { tick LetFloatFromLet + ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 + ; rhs' <- mkLam tvs' body3 rhs_cont + ; env' <- foldlM (addPolyBind top_lvl) env poly_binds + ; return (env', rhs') } + + ; completeBind env' top_lvl bndr bndr1 rhs' } + +{- +A specialised variant of simplNonRec used when the RHS is already simplified, +notably in knownCon. It uses case-binding where necessary. +-} + +simplNonRecX :: SimplEnv + -> InId -- Old binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv +-- Precondition: rhs satisfies the let/app invariant +simplNonRecX env bndr new_rhs + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + + | Coercion co <- new_rhs + = return (extendCvSubst env bndr co) + + | otherwise + = do { (env', bndr') <- simplBinder env bndr + ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } + -- simplNonRecX is only used for NotTopLevel things + +completeNonRecX :: TopLevelFlag -> SimplEnv + -> Bool + -> InId -- Old binder + -> OutId -- New binder + -> OutExpr -- Simplified RHS + -> SimplM SimplEnv +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn + +completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs + = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs + ; (env2, rhs2) <- + if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 + then do { tick LetFloatFromLet + ; return (addFloats env env1, rhs1) } -- Add the floats to the main env + else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS + ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 } + +{- +{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX + Doing so risks exponential behaviour, because new_rhs has been simplified once already + In the cases described by the folowing commment, postInlineUnconditionally will + catch many of the relevant cases. + -- This happens; for example, the case_bndr during case of + -- known constructor: case (a,b) of x { (p,q) -> ... } + -- Here x isn't mentioned in the RHS, so we don't want to + -- create the (dead) let-binding let x = (a,b) in ... + -- + -- Similarly, single occurrences can be inlined vigourously + -- e.g. case (f x, g y) of (a,b) -> .... + -- If a,b occur once we can avoid constructing the let binding for them. + + Furthermore in the case-binding case preInlineUnconditionally risks extra thunks + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. + + | preInlineUnconditionally env NotTopLevel bndr new_rhs + = thing_inside (extendIdSubst env bndr (DoneEx new_rhs)) +-} + +---------------------------------- +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Adds new floats to the env iff that allows us to return a good RHS +prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] + | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type + , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] + = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs + ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setDemandInfo` demandInfo info + info = idInfo id + +prepareRhs top_lvl env0 _ rhs0 + = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 + ; return (env1, rhs1) } + where + go n_val_args env (Cast rhs co) + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Cast rhs' co) } + go n_val_args env (App fun (Type ty)) + = do { (is_exp, env', rhs') <- go n_val_args env fun + ; return (is_exp, env', App rhs' (Type ty)) } + go n_val_args env (App fun arg) + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of + True -> do { (env'', arg') <- makeTrivial top_lvl env' arg + ; return (True, env'', App fun' arg') } + False -> return (False, env, App fun arg) } + go n_val_args env (Var fun) + = return (is_exp, env, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + + go n_val_args env (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Tick t rhs') } + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | not (tickishCounts t) || tickishCanSplit t + = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = seFloats $ env `addFloats` mapFloats env' tickIt + ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') } + + go _ env other + = return (False, env, other) + +{- +Note [Float coercions] +~~~~~~~~~~~~~~~~~~~~~~ +When we find the binding + x = e `cast` co +we'd like to transform it to + x' = e + x = x `cast` co -- A trivial binding +There's a chance that e will be a constructor application or function, or something +like that, so moving the coerion to the usage site may well cancel the coersions +and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + x = T m + go 0 = 0 + go n = case x of { T m -> go (n-m) } + -- This case should optimise + +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Float coercions (unlifted)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT don't do [Float coercions] if 'e' has an unlifted type. +This *can* happen: + + foo :: Int = (error (# Int,Int #) "urk") + `cast` CoUnsafe (# Int,Int #) Int + +If do the makeTrivial thing to the error call, we'll get + foo = case error (# Int,Int #) "urk" of v -> v `cast` ... +But 'v' isn't in scope! + +These strange casts can happen as a result of case-of-case + bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of + (# p,q #) -> p+q +-} + +makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec) +makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e + ; return (env', ValArg e') } +makeTrivialArg env arg = return (env, arg) -- CastBy, TyArg + +makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr + +makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo + -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +-- Returned SimplEnv has same substitution as incoming one +makeTrivialWithInfo top_lvl env info expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (env, expr) + | otherwise -- See Note [Take care] below + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name expr_ty info + ; env' <- completeNonRecX top_lvl env False var var expr + ; expr' <- simplVar env' var + ; return (env', expr') } + -- The simplVar is needed becase we're constructing a new binding + -- a = rhs + -- And if rhs is of form (rhs1 |> co), then we might get + -- a1 = rhs1 + -- a = a1 |> co + -- and now a's RHS is trivial and can be substituted out, and that + -- is what completeNonRecX will do + -- To put it another way, it's as if we'd simplified + -- let var = e in var + where + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl _ expr_ty + | isTopLevel top_lvl = not (isUnLiftedType expr_ty) + | otherwise = True + +{- +Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tih + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +A case in point is literal strings (a MachStr is not regarded as +trivial): + + foo = Ptr "blob"# + +We don't want to ANF-ise this. + +************************************************************************ +* * +\subsection{Completing a lazy binding} +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: SimplEnv + -> TopLevelFlag -- Flag stuck into unfolding + -> InId -- Old binder + -> OutId -> OutExpr -- New binder and RHS + -> SimplM SimplEnv +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Precondition: rhs obeys the let/app invariant +completeBind env top_lvl old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (extendCvSubst env old_bndr co) + _ -> return (addNonRec env new_bndr new_rhs) + + | otherwise + = ASSERT( isId new_bndr ) + do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in SimplUtils + ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs + + -- Simplify the unfolding + ; new_unfolding <- simplLetUnfolding env top_lvl old_bndr final_rhs old_unf + + ; dflags <- getDynFlags + ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info + final_rhs new_unfolding + + -- Inline and discard the binding + then do { tick (PostInlineUnconditionally old_bndr) + ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + else + do { let info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding + + -- Demand info: Note [Setting the demand info] + -- + -- We also have to nuke demand info if for some reason + -- eta-expansion *reduces* the arity of the binding to less + -- than that of the strictness sig. This can happen: see Note [Arity decrease]. + info3 | isEvaldUnfolding new_unfolding + || (case strictnessInfo info2 of + StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) + = zapDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + final_id = new_bndr `setIdInfo` info3 + + ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $ + return (addNonRec env final_id final_rhs) } } + -- The addNonRec adds it to the in-scope set too + +------------------------------ +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv +-- Add a new binding to the environment, complete with its unfolding +-- but *do not* do postInlineUnconditionally, because we have already +-- processed some of the scope of the binding +-- We still want the unfolding though. Consider +-- let +-- x = /\a. let y = ... in Just y +-- in body +-- Then we float the y-binding out (via abstractFloats and addPolyBind) +-- but 'x' may well then be inlined in 'body' in which case we'd like the +-- opportunity to inline 'y' too. +-- +-- INVARIANT: the arity is correct on the incoming binders + +addPolyBind top_lvl env (NonRec poly_id rhs) + = do { unfolding <- simplLetUnfolding env top_lvl poly_id rhs noUnfolding + -- Assumes that poly_id did not have an INLINE prag + -- which is perhaps wrong. ToDo: think about this + ; let final_id = setIdInfo poly_id $ + idInfo poly_id `setUnfoldingInfo` unfolding + + ; return (addNonRec env final_id rhs) } + +addPolyBind _ env bind@(Rec _) + = return (extendFloats env bind) + -- Hack: letrecs are more awkward, so we extend "by steam" + -- without adding unfoldings etc. At worst this leads to + -- more simplifier iterations + +{- Note [Arity decrease] +~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking the arity of a binding should not decrease. But it *can* +legitimately happen because of RULES. Eg + f = g Int +where g has arity 2, will have arity 2. But if there's a rewrite rule + g Int --> h +where h has arity 1, then f's arity will decrease. Here's a real-life example, +which is in the output of Specialise: + + Rec { + $dm {Arity 2} = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm #-} + + dInt = MkD .... opInt ... + opInt {Arity 1} = $dm dInt + + $s$dm {Arity 0} = \x. op dInt } + +Here opInt has arity 1; but when we apply the rule its arity drops to 0. +That's why Specialise goes to a little trouble to pin the right arity +on specialised functions too. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + +simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seFloats env) ) $ + do { (env', expr') <- simplExprF (zapFloats env) expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seFloats env')) $ + return (wrapFloats env' expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplExprF env e cont + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + {- , ppr (seFloats env) -} + ]) $ -} + simplExprF1 env e cont + +simplExprF1 :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplExprF1 env (Var v) cont = simplIdF env v cont +simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = simplTick env t expr cont +simplExprF1 env (Cast body co) cont = simplCast env body co cont +simplExprF1 env (Coercion co) cont = simplCoercionF env co cont +simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) + rebuild env (Type (substTy env ty)) cont + +simplExprF1 env (App fun arg) cont + = simplExprF env fun $ + case arg of + Type ty -> ApplyToTy { sc_arg_ty = substTy env ty + , sc_hole_ty = substTy env (exprType fun) + , sc_cont = cont } + _ -> ApplyToVal { sc_arg = arg, sc_env = env + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = simplLam env zapped_bndrs body cont + -- The main issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + (bndrs, body) = collectBinders expr + zapped_bndrs | need_to_zap = map zap bndrs + | otherwise = bndrs + + need_to_zap = any zappable_bndr (drop n_args bndrs) + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b + +simplExprF1 env (Case scrut bndr _ alts) cont + = simplExprF env scrut (Select NoDup bndr alts env cont) + +simplExprF1 env (Let (Rec pairs) body) cont + = do { env' <- simplRecBndrs env (map fst pairs) + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + + ; env'' <- simplRecBind env' NotTopLevel pairs + ; simplExprF env'' body cont } + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + = simplNonRecE env bndr (rhs, env) ([], body) cont + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = let opt_co = optCoercion (getCvSubst env) co + in seqCo opt_co `seq` return opt_co + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. + +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (env', expr') <- simplExprF env expr cont + ; return (env', mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (env', expr') <- simplExprF (zapFloats env) expr inc + ; let tickish' = simplTickish env tickish + ; (env'', expr'') <- rebuild (zapFloats env') + (wrapFloats env' expr') + (TickIt tickish' outc) + ; return (addFloats env env'', expr'') + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint n ids <- tickish + = Breakpoint n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont (CastIt co c) = (CastIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = id + getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant +-- only the in-scope set and floats should matter +rebuild env expr cont + = case cont of + Stop {} -> return (env, expr) + TickIt t cont -> rebuild env (mkTick t expr) cont + CastIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + + Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont + StrictArg info _ cont -> rebuildCall env (info `addValArgTo` expr) cont + + StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE + ; simplLam env' bs body cont } + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild env (App expr (Type ty)) cont + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} + -- See Note [Avoid redundant simplification] + | isSimplified dup_flag -> rebuild env (App expr arg) cont + | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg + ; rebuild env (App expr arg') cont } + + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- simplCoercion env co0 + ; cont1 <- addCoerce co1 cont0 + ; simplExprF env body cont1 } + where + addCoerce co cont = add_coerce co (coercionKind co) cont + + add_coerce _co (Pair s1 k1) cont -- co :: ty~ty + | s1 `eqType` k1 = return cont -- is a no-op + + add_coerce co1 (Pair s1 _k2) (CastIt co2 cont) + | (Pair _l1 t1) <- coercionKind co2 + -- e |> (g1 :: S1~L) |> (g2 :: L~T1) + -- ==> + -- e, if S1=T1 + -- e |> (g1 . g2 :: S1~T1) otherwise + -- + -- For example, in the initial form of a worker + -- we may find (coerce T (coerce S (\x.e))) y + -- and we'd like it to simplify to e[y/x] in one round + -- of simplification + , s1 `eqType` t1 = return cont -- The coerces cancel out + | otherwise = return (CastIt (mkTransCo co1 co2) cont) + + add_coerce co (Pair s1s2 _t1t2) cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + -- (f |> g) ty ---> (f ty) |> (g @ ty) + -- This implements the PushT rule from the paper + | Just (tyvar,_) <- splitForAllTy_maybe s1s2 + = ASSERT( isTyVar tyvar ) + do { cont' <- addCoerce new_cast tail + ; return (cont { sc_cont = cont' }) } + where + new_cast = mkInstCo co arg_ty + + add_coerce co (Pair s1s2 t1t2) (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = cont }) + | isFunTy s1s2 -- This implements the Push rule from the paper + , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg + -- (e |> (g :: s1s2 ~ t1->t2)) f + -- ===> + -- (e (f |> (arg g :: t1~s1)) + -- |> (res g :: s2->t2) + -- + -- t1t2 must be a function type, t1->t2, because it's applied + -- to something but s1s2 might conceivably not be + -- + -- When we build the ApplyTo we can't mix the out-types + -- with the InExpr in the argument, so we simply substitute + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- + -- Example of use: Trac #995 + = do { let arg' = substExpr arg_se arg + -- It's important that this is lazy, because this argument + -- may be disarded if turns out to be the argument of + -- (\_ -> e) This can make a huge difference; + -- see Trac #10527 + ; cont' <- addCoerce co2 cont + ; return (ApplyToVal { sc_arg = mkCast arg' (mkSymCo co1) + , sc_env = zapSubstEnv arg_se + , sc_dup = dup + , sc_cont = cont' }) } + where + -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and + -- t2 ~ s2 with left and right on the curried form: + -- (->) t1 t2 ~ (->) s1 s2 + [co1, co2] = decomposeCo 2 co + + add_coerce co _ cont = return (CastIt co cont) + +simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplArg env dup_flag arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { arg' <- simplExpr (arg_env `setInScope` env) arg + ; return (Simplified, zapSubstEnv arg_env, arg') } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ + +Note [Zap unfolding when beta-reducing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound variables can have stable unfoldings, such as + $j = \x. \b{Unf=Just x}. e +See Note [Case binders and join points] below; the unfolding for lets +us optimise e better. However when we beta-reduce it we want to +revert to using the actual value, otherwise we can end up in the +stupid situation of + let x = blah in + let b{Unf=Just x} = y + in ...b... +Here it'd be far better to drop the unfolding and use the actual RHS. +-} + +simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +simplLam env [] body cont = simplExprF env body cont + + -- Beta reduction + +simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } + +simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } + where + zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing] + | isId bndr, isStableUnfolding (realIdUnfolding bndr) + = setIdUnfolding bndr NoUnfolding + | otherwise = bndr + + -- discard a non-counting tick on a lambda. This may change the + -- cost attribution slightly (moving the allocation of the + -- lambda elsewhere), but we don't care: optimisation changes + -- cost attribution all the time. +simplLam env bndrs body (TickIt tickish cont) + | not (tickishCounts tickish) + = simplLam env bndrs body cont + + -- Not enough args, so there are real lambdas left to put in the result +simplLam env bndrs body cont + = do { (env', bndrs') <- simplLamBndrs env bndrs + ; body' <- simplExpr env' body + ; new_lam <- mkLam bndrs' body' cont + ; rebuild env' new_lam cont } + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------- +simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var) +-- Used for lambda binders. These sometimes have unfoldings added by +-- the worker/wrapper pass that must be preserved, because they can't +-- be reconstructed from context. For example: +-- f x = case x of (a,b) -> fw a b x +-- fw a b x{=(a,b)} = ... +-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. +simplLamBndr env bndr + | isId bndr && hasSomeUnfolding old_unf -- Special case + = do { (env1, bndr1) <- simplBinder env bndr + ; unf' <- simplUnfolding env1 NotTopLevel bndr old_unf + ; let bndr2 = bndr1 `setIdUnfolding` unf' + ; return (modifyInScope env1 bndr2, bndr2) } + + | otherwise + = simplBinder env bndr -- Normal case + where + old_unf = idUnfolding bndr + +------------------ +simplNonRecE :: SimplEnv + -> InBndr -- The binder + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> ([InBndr], InExpr) -- Body of the let/lambda + -- \xs.e + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive lets in expressions +-- * beta reduction +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process +-- +-- Precondition: rhs satisfies the let/app invariant +-- Note [CoreSyn let/app invariant] in CoreSyn +-- +-- The "body" of the binding comes as a pair of ([InId],InExpr) +-- representing a lambda; so we recurse back to simplLam +-- Why? Because of the binder-occ-info-zapping done before +-- the call to simplLam in simplExprF (Lam ...) + + -- First deal with type applications and type lets + -- (/\a. e) (Type ty) and (let a = Type ty in e) +simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont + = ASSERT( isTyVar bndr ) + do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg + ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } + +simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont + = do dflags <- getDynFlags + case () of + _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs + -> do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } + + | isStrictId bndr -- Includes coercions + -> simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) + + | otherwise + -> ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 + ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; simplLam env3 bndrs body cont } + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) + | otherwise + = case substId env var of + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e + +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplIdF env var cont + = case substId env var of + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + DoneId var1 -> completeCall env var1 cont + -- Note [zapSubstEnv] + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + +--------------------------------------------------------- +-- Dealing with a call site + +completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr) +completeCall env var cont + = do { ------------- Try inlining ---------------- + dflags <- getDynFlags + ; let (lone_variable, arg_infos, call_cont) = contArgs cont + n_val_args = length arg_infos + interesting_cont = interestingCallContext call_cont + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + lone_variable arg_infos interesting_cont + ; case maybe_inline of { + Just expr -- There is an inlining! + -> do { checkedTick (UnfoldingDone var) + ; dump_inline dflags expr cont + ; simplExprF (zapSubstEnv env) expr cont } + + ; Nothing -> do -- No inlining! + + { rule_base <- getSimplRules + ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont + ; rebuildCall env info cont + }}} + where + dump_inline dflags unfolding cont + | not (dopt Opt_D_dump_inlinings dflags) = return () + | not (dopt Opt_D_verbose_core2core dflags) + = when (isExternalName (idName var)) $ + liftIO $ printInfoForUser dflags alwaysQualify $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = liftIO $ printInfoForUser dflags alwaysQualify $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + +rebuildCall :: SimplEnv + -> ArgInfo + -> SimplCont + -> SimplM (SimplEnv, OutExpr) +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see SimplUtils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it + where -- again and again! + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +rebuildCall env info (CastIt co cont) + = rebuildCall env (addCastTo info co) cont + +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = rebuildCall env (info `addTyArgTo` arg_ty) cont + +rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty + , ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_cont = cont }) + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo info' arg) cont + + | str -- Strict argument + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setFloats` env) arg + (StrictArg info' cci cont) + -- Note [Shadowing] + + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScope` env) arg + (mkLazyArgStop (funArgTy fun_ty) cci) + ; rebuildCall env (addValArgTo info' arg') cont } + where + info' = info { ai_strs = strs, ai_discs = discs } + cci | encl_rules = RuleArgCtxt + | disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont -- No rules, common case + + | otherwise + = do { -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + ; let env' = zapSubstEnv env -- See Note [zapSubstEnv]; + -- and NB that 'rev_args' are all fully simplified + ; mb_rule <- tryRules env' rules fun (reverse rev_args) cont + ; case mb_rule of { + Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' + + -- Rules don't match + ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules + } } + +{- +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweeep. + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [ArgSpec] -> SimplCont + -> SimplM (Maybe (CoreExpr, SimplCont)) +-- The SimplEnv already has zapSubstEnv applied to it + +tryRules env rules fn args call_cont + | null rules + = return Nothing +{- Disabled until we fix #8326 + | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] + , [_type_arg, val_arg] <- args + , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont + , isDeadBinder bndr + = do { dflags <- getDynFlags + ; let enum_to_tag :: CoreAlt -> CoreAlt + -- Takes K -> e into tagK# -> e + -- where tagK# is the tag of constructor K + enum_to_tag (DataAlt con, [], rhs) + = ASSERT( isEnumerationTyCon (dataConTyCon con) ) + (LitAlt tag, [], rhs) + where + tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG)) + enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) + + new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts + new_bndr = setIdType bndr intPrimTy + -- The binder is dead, but should have the right type + ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } +-} + | otherwise + = do { dflags <- getDynFlags + ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) + fn (argInfoAppArgs args) rules of { + Nothing -> return Nothing ; -- No rule matches + Just (rule, rule_rhs) -> + do { checkedTick (RuleFired (ru_name rule)) + ; let cont' = pushSimplifiedArgs env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how many args the rule consumed + ; dump dflags rule rule_rhs + ; return (Just (rule_rhs, cont')) }}} + where + dump dflags rule rule_rhs + | dopt Opt_D_dump_rule_rewrites dflags + = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ru_name rule) + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> pprCoreExpr rule_rhs + , text "Cont: " <+> ppr call_cont ] + + | dopt Opt_D_dump_rule_firings dflags + = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ru_name rule) + + | otherwise + = return () + + log_rule dflags flag hdr details + = liftIO . dumpSDoc dflags alwaysQualify flag "" $ + sep [text hdr, nest 4 details] + +{- +Note [Optimising tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an enumeration data type: + + data Foo = A | B | C + +Then we want to transform + + case tagToEnum# x of ==> case x of + A -> e1 DEFAULT -> e1 + B -> e2 1# -> e2 + C -> e3 2# -> e3 + +thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT +alternative we retain it (remember it comes first). If not the case must +be exhaustive, and we reflect that in the transformed version by adding +a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. +See #8317. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in SimplUtils.prepareAlts has the effect of generalise this +idea to look for a case where we're scrutinising a variable, and we +know that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that SimplUtils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be elminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case elimination: lifted case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being used +as a strict 'let' (all isDeadBinder bndrs), we may want to do this +transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + + (a) 'e' is already evaluated (it may so if e is a variable) + Specifically we check (exprIsHNF e). In this case + we can just allocate the WHNF directly with a let. +or + (b) 'x' is not used at all and e is ok-for-speculation + The ok-for-spec bit checks that we don't lose any + exceptions or divergence. + + NB: it'd be *sound* to switch from case to let if the + scrutinee was not yet WHNF but was guaranteed to + converge; but sticking with case means we won't build a + thunk + +or + (c) 'x' is used strictly in the body, and 'e' is a variable + Then we can just substitute 'e' for 'x' in the body. + See Note [Eliminating redundant seqs] + +For (b), the "not used at all" test is important. Consider + case (case a ># b of { True -> (p,q); False -> (q,p) }) of + r -> blah +The scrutinee is ok-for-speculation (it looks inside cases), but we do +not want to transform to + let r = case a ># b of { True -> (p,q); False -> (q,p) } + in blah +because that builds an unnecessary thunk. + +Note [Eliminating redundant seqs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case x of r { _ -> ..r.. } +where 'r' is used strictly in (..r..), the case is effectively a 'seq' +on 'x', but since 'r' is used strictly anyway, we can safely transform to + (...x...) + +Note that this can change the error behaviour. For example, we might +transform + case x of { _ -> error "bad" } + --> error "bad" +which is might be puzzling if 'x' currently lambda-bound, but later gets +let-bound to (error "good"). + +Nevertheless, the paper "A semantics for imprecise exceptions" allows +this transformation. If you want to fix the evaluation order, use +'pseq'. See Trac #8900 for an example where the loss of this +transformation bit us in practice. + +See also Note [Empty case alternatives] in CoreSyn. + +Just for reference, the original code (added Jan 13) looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + +(This came up when fixing Trac #7542. See also Note [Eta reduction of +an eval'd function] in CoreUtils.) + + +Note [Case elimination: unlifted case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case a +# b of r -> ...r... +Then we do case-elimination (to make a let) followed by inlining, +to get + .....(a +# b).... +If we have + case indexArray# a i of r -> ...r... +we might like to do the same, and inline the (indexArray# a i). +But indexArray# is not okForSpeculation, so we don't build a let +in rebuildCase (lest it get floated *out*), so the inlining doesn't +happen either. + +This really isn't a big deal I think. The let can be + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (inceasing order) + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs bs rhs } + + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs + Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs bs rhs = ASSERT( null bs ) + do { env' <- simplNonRecX env case_bndr scrut + -- scrut is a constructor application, + -- hence satisfies let/app invariant + ; simplExprF env' rhs cont } + + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in PrimOp + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + | all_dead_bndrs + , if is_unlifted + then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case] + else exprIsHNF scrut -- See Note [Case elimination: lifted case] + || scrut_is_demanded_var scrut + = do { tick (CaseElim case_bndr) + ; env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in MkId + | is_plain_seq + = do { let scrut_ty = exprType scrut + rhs_ty = substTy env (exprType rhs) + out_args = [ TyArg { as_arg_ty = scrut_ty + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = applyTy seq_id_ty scrut_ty } + , ValArg scrut] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = env, sc_cont = cont } + env' = zapSubstEnv env + -- Lazily evaluated, so we don't do most of this + + ; rule_base <- getSimplRules + ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args rule_cont + ; case mb_rule of + Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + is_unlifted = isUnLiftedType (idType case_bndr) + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + seq_id_ty = idType seqId + + scrut_is_demanded_var :: CoreExpr -> Bool + -- See Note [Eliminating redundant seqs] + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + = do { -- Prepare the continuation; + -- The new subst_env is in place + (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont + + -- Simplify the alternatives + ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont + + ; dflags <- getDynFlags + ; let alts_ty' = contResultType dup_cont + ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts' + + -- Notice that rebuild gets the in-scope set from env', not alt_env + -- (which in any case is only build in simplAlts) + -- The case binder *not* scope over the whole returned case-expression + ; rebuild env' case_expr nodup_cont } + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyer; see +OccurAnal Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [Case alternative occ info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are simply reconstructing a case (the common case), we always +zap the occurrence info on the binders in the alternatives. Even +if the case binder is dead, the scrutinee is usually a variable, and *that* +can bring the case-alternative binders back to life. +See Note [Add unfolding for scrutinee] + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + + ... case e of x { DEFAULT -> rhs } ... + +where x::F Int. Then we'd like to rewrite (F Int) to Int, getting + + case e `cast` co of x'::Int + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. + +Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. + +Nota Bene: We only do the [Improving seq] transformation if the +case binder 'x' is actually used in the rhs; that is, if the case +is *not* a *pure* seq. + a) There is no point in adding the cast to a pure seq. + b) There is a good reason not to: doing so would interfere + with seq rules (Note [Built-in RULES for seq] in MkId). + In particular, this [Improving seq] thing *adds* a cast + while [Built-in RULES for seq] *removes* one, so they + just flip-flop. + +You might worry about + case v of x { __DEFAULT -> + ... case (v `cast` co) of y { I# -> ... }} +This is a pure seq (since x is unused), so [Improving seq] won't happen. +But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get + case v of x { __DEFAULT -> + ... case (x `cast` co) of y { I# -> ... }} +Now the outer case is not a pure seq, so [Improving seq] will happen, +and then the inner case will disappear. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) +-} + +simplAlts :: SimplEnv + -> OutExpr + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation +-- Like simplExpr, this just returns the simplified alternatives; +-- it does not return an environment +-- The returned alternatives can be empty, none are possible + +simplAlts env scrut case_bndr alts cont' + = do { let env0 = zapFloats env + + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut + case_bndr case_bndr1 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + + ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts + ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ + return (scrut', case_bndr', alts') } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq] + , Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) + = ASSERT( null bndrs ) + do { let env' = addBinderUnfolding env case_bndr' + (mkOtherCon imposs_deflt_cons) + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (DEFAULT, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) + = ASSERT( null bndrs ) + do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (LitAlt lit, [], rhs') } + +simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) + = do { -- Deal with the pattern-bound variables + -- Mark the ones that are in ! positions in the + -- data constructor as certainly-evaluated. + -- NB: simplLamBinders preserves this eval info + ; let vs_with_evals = add_evals (dataConRepStrictness con) + ; (env', vs') <- simplLamBndrs env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + + ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app + ; rhs' <- simplExprC env'' rhs cont' + ; return (DataAlt con, vs', rhs') } + where + -- add_evals records the evaluated-ness of the bound variables of + -- a case pattern. This is *important*. Consider + -- data T = T !Int !Int + -- + -- case x of { T a b -> T (a+1) b } + -- + -- We really must record that b is already evaluated so that we don't + -- go and re-evaluate it when constructing the result. + -- See Note [Data-con worker strictness] in MkId.lhs + add_evals the_strs + = go vs the_strs + where + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) + | isMarkedStrict str = evald_v : go vs' strs + | otherwise = zapped_v : go vs' strs + where + zapped_v = zapIdOccInfo v -- See Note [Case alternative occ info] + evald_v = zapped_v `setIdUnfolding` evaldUnfolding + go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) + + +addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv +addAltUnfoldings env scrut case_bndr con_app + = do { dflags <- getDynFlags + ; let con_app_unf = mkSimpleUnfolding dflags con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 = case scrut of + Just (Var v) -> addBinderUnfolding env1 v con_app_unf + Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ + mkSimpleUnfolding dflags (Cast con_app (mkSymCo co)) + _ -> env1 + + ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) + ; return env2 } + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = WARN( not (eqType (idType bndr) (exprType tmpl)), + ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccAnal has got rid of all such occcurrences +See Note [Binder swap] in OccAnal. + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimintation -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in SpecConstr; +see Note [Add scrutinee to ValueEnv too] in SpecConstr + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplEnv, OutExpr) + +knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont + = do { env' <- bind_args env bs dc_args + ; env'' <- bind_case_bndr env' + ; simplExprF env'' rhs cont } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return env' + + bind_args env' (b:bs') (Type ty : args) + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (arg : args) + = ASSERT( isId b ) + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant + ; bind_args env'' bs' args } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return env + | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut)) + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are aready OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifer might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr ) + return (env, mkImpossibleExpr (contResultType cont)) + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ +-} + +prepareCaseCont :: SimplEnv + -> [InAlt] -> SimplCont + -> SimplM (SimplEnv, + SimplCont, -- Dupable part + SimplCont) -- Non-dupable part +-- We are considering +-- K[case _ of { p1 -> r1; ...; pn -> rn }] +-- where K is some enclosing continuation for the case +-- Goal: split K into two pieces Kdup,Knodup so that +-- a) Kdup can be duplicated +-- b) Knodup[Kdup[e]] = K[e] +-- The idea is that we'll transform thus: +-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] } +-- +-- We may also return some extra bindings in SimplEnv (that scope over +-- the entire continuation) +-- +-- When case-of-case is off, just make the entire continuation non-dupable + +prepareCaseCont env alts cont + | not (sm_case_case (getMode env)) = return (env, mkBoringStop (contHoleType cont), cont) + | not (many_alts alts) = return (env, cont, mkBoringStop (contResultType cont)) + | otherwise = mkDupableCont env cont + where + many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative + many_alts [] = False -- See Note [Bottom alternatives] + many_alts [_] = False + many_alts (alt:alts) + | is_bot_alt alt = many_alts alts + | otherwise = not (all is_bot_alt alts) + + is_bot_alt (_,_,rhs) = exprIsBottom rhs + +{- +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away; and in some cases we would +not even create the join points (see Note [Single-alternative case]) +and we would keep the case-of-case which is silly. See Trac #4930. +-} + +mkDupableCont :: SimplEnv -> SimplCont + -> SimplM (SimplEnv, SimplCont, SimplCont) + +mkDupableCont env cont + | contIsDupable cont + = return (env, cont, mkBoringStop (contResultType cont)) + +mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableCont env (CastIt ty cont) + = do { (env', dup, nodup) <- mkDupableCont env cont + ; return (env', CastIt ty dup, nodup) } + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableCont env cont@(TickIt{}) + = return (env, mkBoringStop (contHoleType cont), cont) + +mkDupableCont env cont@(StrictBind {}) + = return (env, mkBoringStop (contHoleType cont), cont) + -- See Note [Duplicating StrictBind] + +mkDupableCont env (StrictArg info cci cont) + -- See Note [Duplicating StrictArg] + = do { (env', dup, nodup) <- mkDupableCont env cont + ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info) + ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } + +mkDupableCont env cont@(ApplyToTy { sc_cont = tail }) + = do { (env', dup_cont, nodup_cont) <- mkDupableCont env tail + ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) } + +mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont = cont }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont + ; (_, se', arg') <- simplArg env' dup se arg + ; (env'', arg'') <- makeTrivial NotTopLevel env' arg' + ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se' + , sc_dup = OkToDup, sc_cont = dup_cont } + ; return (env'', app_cont, nodup_cont) } + +mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) +-- See Note [Single-alternative case] +-- | not (exprIsDupable rhs && contIsDupable case_cont) +-- | not (isDeadBinder case_bndr) + | all isDeadBinder bs -- InIds + && not (isUnLiftedType (idType case_bndr)) + -- Note [Single-alternative-unlifted] + = return (env, mkBoringStop (contHoleType cont), cont) + +mkDupableCont env (Select _ case_bndr alts se cont) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + do { tick (CaseOfCase case_bndr) + ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont + -- NB: We call prepareCaseCont here. If there is only one + -- alternative, then dup_cont may be big, but that's ok + -- because we push it into the single alternative, and then + -- use mkDupableAlt to turn that simplified alternative into + -- a join point if it's too big to duplicate. + -- And this is important: see Note [Fusing case continuations] + + ; let alt_env = se `setInScope` env' + + ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' + ; return (env'', -- Note [Duplicated env] + Select OkToDup case_bndr' alts'' (zapSubstEnv env'') + (mkBoringStop (contHoleType nodup_cont)), + nodup_cont) } + + +mkDupableAlts :: SimplEnv -> OutId -> [InAlt] + -> SimplM (SimplEnv, [InAlt]) +-- Absorbs the continuation into the new alternatives + +mkDupableAlts env case_bndr' the_alts + = go env the_alts + where + go env0 [] = return (env0, []) + go env0 (alt:alts) + = do { (env1, alt') <- mkDupableAlt env0 case_bndr' alt + ; (env2, alts') <- go env1 alts + ; return (env2, alt' : alts' ) } + +mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) + -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) +mkDupableAlt env case_bndr (con, bndrs', rhs') = do + dflags <- getDynFlags + if exprIsDupable dflags rhs' -- Note [Small alternative rhs] + then return (env, (con, bndrs', rhs')) + else + do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineUnfolding Nothing rhs + rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' + + LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + + abstract_over bndr + | isTyVar bndr = True -- Abstract over all type variables just in case + | otherwise = not (isDeadBinder bndr) + -- The deadness info on the new Ids is preserved by simplBinders + + ; (final_bndrs', final_args) -- Note [Join point abstraction] + <- if (any isId used_bndrs') + then return (used_bndrs', varsToCoreExprs used_bndrs') + else do { rw_id <- newId (fsLit "w") voidPrimTy + ; return ([setOneShotLambda rw_id], [Var voidPrimId]) } + + ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty') + -- Note [Funky mkPiTypes] + + ; let -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + really_final_bndrs = map one_shot final_bndrs' + one_shot v | isId v = setOneShotLambda v + | otherwise = v + join_rhs = mkLams really_final_bndrs rhs' + join_arity = exprArity join_rhs + join_call = mkApps (Var join_bndr) final_args + + ; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs) + ; return (env', (con, bndrs', join_call)) } + -- See Note [Duplicated env] + +{- +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StricgtBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See Trac #4957 a fuller example. + +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutines the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lamba-bound unfoldings] in DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have an zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Small alternative rhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is worth checking for a small RHS because otherwise we +get extra let bindings that may cause an extra iteration of the simplifier to +inline back in place. Quite often the rhs is just a variable or constructor. +The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra +iterations because the version with the let bindings looked big, and so wasn't +inlined, but after the join points had been inlined it looked smaller, and so +was inlined. + +NB: we have to check the size of rhs', not rhs. +Duplicating a small InAlt might invalidate occurrence information +However, if it *is* dupable, we return the *un* simplified alternative, +because otherwise we'd need to pair it up with an empty subst-env.... +but we only have one env shared between all the alts. +(Remember we must zap the subst-env before re-simplifying something). +Rather than do this we simply agree to re-simplify the original (small) thing later. + +Note [Funky mkPiTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkPiTypes. If the contructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Join point abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnLiftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The original plan had (where E is a big argument) +e.g. f E [..hole..] + ==> let $j = \a -> f E a + in $j [..hole..] + +But this is terrible! Here's an example: + && E (case x of { T -> F; F -> T }) +Now, && is strict so we end up simplifying the case with + +an ArgOf continuation. If we let-bind it, we get + let $j = \v -> && E v + in simplExpr (case x of { T -> F; F -> T }) + (ArgOf (\r -> $j r) +And after simplifying more we get + let $j = \v -> && E v + in case x of { T -> $j F; F -> $j T } +Which is a Very Bad Thing + +What we do now is this + f E [..hole..] + ==> let a = E + in f a [..hole..] +Now if the thing in the hole is a case expression (which is when +we'll call mkDupableCont), we'll push the function call into the +branches, which is what we want. Now RULES for f may fire, and +call-pattern specialisation. Here's an example from Trac #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') +If we can push the call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this program. + +Here is the (&&) example: + && E (case x of { T -> F; F -> T }) + ==> let a = E in + case x of { T -> && a F; F -> && a T } +Much better! + +Notice that + * Arguments to f *after* the strict one are handled by + the ApplyToVal case of mkDupableCont. Eg + f [..hole..] E + + * We can only do the let-binding of E because the function + part of a StrictArg continuation is an explicit syntax + tree. In earlier versions we represented it as a function + (CoreExpr -> CoreEpxr) which we couldn't take apart. + +Do *not* duplicate StrictBind and StritArg continuations. We gain +nothing by propagating them into the expressions, and we do lose a +lot. + +The desire not to duplicate is the entire reason that +mkDupableCont returns a pair of continuations. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike StrictArg, there doesn't seem anything to gain from +duplicating a StrictBind continuation, so we don't. + + +Note [Single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This case is just like the ArgOf case. Here's an example: + data T a = MkT !a + ...(MkT (abs x))... +Then we get + case (case x of I# x' -> + case x' <# 0# of + True -> I# (negate# x') + False -> I# x') of y { + DEFAULT -> MkT y +Because the (case x) has only one alternative, we'll transform to + case x of I# x' -> + case (case x' <# 0# of + True -> I# (negate# x') + False -> I# x') of y { + DEFAULT -> MkT y +But now we do *NOT* want to make a join point etc, giving + case x of I# x' -> + let $j = \y -> MkT y + in case x' <# 0# of + True -> $j (I# (negate# x')) + False -> $j (I# x') +In this case the $j will inline again, but suppose there was a big +strict computation enclosing the orginal call to MkT. Then, it won't +"see" the MkT any more, because it's big and won't get duplicated. +And, what is worse, nothing was gained by the case-of-case transform. + +So, in circumstances like these, we don't want to build join points +and push the outer case into the branches of the inner one. Instead, +don't duplicate the continuation. + +When should we use this strategy? We should not use it on *every* +single-alternative case: + e.g. case (case ....) of (a,b) -> (# a,b #) +Here we must push the outer case into the inner one! +Other choices: + + * Match [(DEFAULT,_,_)], but in the common case of Int, + the alternative-filling-in code turned the outer case into + case (...) of y { I# _ -> MkT y } + + * Match on single alternative plus (not (isDeadBinder case_bndr)) + Rationale: pushing the case inwards won't eliminate the construction. + But there's a risk of + case (...) of y { (a,b) -> let z=(a,b) in ... } + Now y looks dead, but it'll come alive again. Still, this + seems like the best option at the moment. + + * Match on single alternative plus (all (isDeadBinder bndrs)) + Rationale: this is essentially seq. + + * Match when the rhs is *not* duplicable, and hence would lead to a + join point. This catches the disaster-case above. We can test + the *un-simplified* rhs, which is fine. It might get bigger or + smaller after simplification; if it gets smaller, this case might + fire next time round. NB also that we must test contIsDupable + case_cont *too, because case_cont might be big! + + HOWEVER: I found that this version doesn't work well, because + we can get let x = case (...) of { small } in ...case x... + When x is inlined into its full context, we find that it was a bad + idea to have pushed the outer case inside the (...) case. + +Note [Single-alternative-unlifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's another single-alternative where we really want to do case-of-case: + +data Mk1 = Mk1 Int# | Mk2 Int# + +M1.f = + \r [x_s74 y_s6X] + case + case y_s6X of tpl_s7m { + M1.Mk1 ipv_s70 -> ipv_s70; + M1.Mk2 ipv_s72 -> ipv_s72; + } + of + wild_s7c + { __DEFAULT -> + case + case x_s74 of tpl_s7n { + M1.Mk1 ipv_s77 -> ipv_s77; + M1.Mk2 ipv_s79 -> ipv_s79; + } + of + wild1_s7b + { __DEFAULT -> ==# [wild1_s7b wild_s7c]; + }; + }; + +So the outer case is doing *nothing at all*, other than serving as a +join-point. In this case we really want to do case-of-case and decide +whether to use a real join point or just duplicate the continuation: + + let $j s7c = case x of + Mk1 ipv77 -> (==) s7c ipv77 + Mk1 ipv79 -> (==) s7c ipv79 + in + case y of + Mk1 ipv70 -> $j ipv70 + Mk2 ipv72 -> $j ipv72 + +Hence: check whether the case binder's type is unlifted, because then +the outer case is *not* a seq. + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv-> TopLevelFlag + -> InId + -> OutExpr + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env top_lvl id new_rhs unf + | isStableUnfolding unf + = simplUnfolding env top_lvl id unf + | otherwise + = bottoming `seq` -- See Note [Force bottoming field] + do { dflags <- getDynFlags + ; return (mkUnfolding dflags InlineRhs (isTopLevel top_lvl) bottoming new_rhs) } + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + bottoming = isBottomingId id + +simplUnfolding :: SimplEnv-> TopLevelFlag -> InId -> Unfolding -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplUnfolding env top_lvl id unf + = case unf of + NoUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders rule_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- simplExpr rule_env expr + ; case guide of + UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok } -- Happens for INLINE things + -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok + , ug_boring_ok = inlineBoringOk expr' } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in TcInstDcls. + -- A test case is Trac #4138 + in return (mkCoreUnfolding src is_top_lvl expr' guide') + -- See Note [Top-level flag on inline rules] in CoreUnfold + + _other -- Happens for INLINABLE things + -> bottoming `seq` -- See Note [Force bottoming field] + do { dflags <- getDynFlags + ; return (mkUnfolding dflags src is_top_lvl bottoming expr') } } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + bottoming = isBottomingId id + is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + rule_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in SimplUtils + +{- +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's an stable unfolding on a loop breaker (which happens for +INLINEABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Loop breaking and RULES] in OccAnal. +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just (idName out_id)) old_rules + ; let final_id = out_id `setIdSpecialisation` mkSpecInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = specInfoRules (idSpecialisation in_id) + +simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule] +simplRules env mb_new_nm rules + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rule_env = updMode updModeForRules env' + ; args' <- mapM (simplExpr rule_env) args + ; rhs' <- simplExpr rule_env rhs + ; return (rule { ru_bndrs = bndrs' + , ru_fn = mb_new_nm `orElse` fn_name + , ru_args = args' + , ru_rhs = rhs' }) } diff --git a/compiler/simplCore/simplifier.tib b/compiler/simplCore/simplifier.tib new file mode 100644 index 00000000..18acd279 --- /dev/null +++ b/compiler/simplCore/simplifier.tib @@ -0,0 +1,771 @@ +% Andre: +% +% - I'd like the transformation rules to appear clearly-identified in +% a box of some kind, so they can be distinguished from the examples. +% + + + +\documentstyle[slpj,11pt]{article} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + +\begin{document} + +\title{How to simplify matters} + +\author{Simon Peyton Jones and Andre Santos\\ +Department of Computing Science, University of Glasgow, G12 8QQ \\ + @simonpj@@dcs.gla.ac.uk@ +} + +\maketitle + + +\section{Motivation} + +Quite a few compilers use the {\em compilation by transformation} idiom. +The idea is that as much of possible of the compilation process is +expressed as correctness-preserving transformations, each of which +transforms a program into a semantically-equivalent +program that (hopefully) executes more quickly or in less space. +Functional languages are particularly amenable to this approach because +they have a particularly rich family of possible transformations. +Examples of transformation-based compilers +include the Orbit compiler,[.kranz orbit thesis.] +Kelsey's compilers,[.kelsey thesis, hudak kelsey principles 1989.] +the New Jersey SML compiler,[.appel compiling with continuations.] +and the Glasgow Haskell compiler.[.ghc JFIT.] Of course many, perhaps most, +other compilers also use transformation to some degree. + +Compilation by transformation uses automatic transformations; that is, those +which can safely be applied automatically by a compiler. There +is also a whole approach to programming, which we might call {\em programming by transformation}, +in which the programmer manually transforms an inefficient specification into +an efficient program. This development process might be supported by +a programming environment in which does the book keeping, but the key steps +are guided by the programmer. We focus exclusively on automatic transformations +in this paper. + +Automatic program transformations seem to fall into two broad categories: +\begin{itemize} +\item {\bf Glamorous transformations} are global, sophisticated, +intellectually satisfying transformations, sometimes guided by some +interesting kind of analysis. +Examples include: +lambda lifting,[.johnsson lambda lifting.] +full laziness,[.hughes thesis, lester spe.] +closure conversion,[.appel jim 1989.] +deforestation,[.wadler 1990 deforestation, marlow wadler deforestation Glasgow92, chin phd 1990 march, gill launchbury.] +transformations based on strictness analysis,[.peyton launchbury unboxed.] +and so on. It is easy to write papers about these sorts of transformations. + +\item {\bf Humble transformations} are small, simple, local transformations, +which individually look pretty trivial. Here are two simple examples\footnote{ +The notation @E[]@ stands for an arbitrary expression with zero or more holes. +The notation @E[e]@ denotes @E[]@ with the holes filled in by the expression @e@. +We implicitly assume that no name-capture happens --- it's just +a short-hand, not an algorithm. +}: +@ + let x = y in E[x] ===> E[y] + + case (x:xs) of ===> E1[x,xs] + (y:ys) -> E1[y,ys] + [] -> E2 +@ +Transformations of this kind are almost embarassingly simple. How could +anyone write a paper about them? +\end{itemize} +This paper is about humble transformations, and how to implement them. +Although each individual +transformation is simple enough, there is a scaling issue: +there are a large number of candidate transformations to consider, and +there are a very large number of opportunities to apply them. + +In the Glasgow Haskell compiler, all humble transformations +are performed by the so-called {\em simplifier}. +Our goal in this paper is to give an overview of how the simplifier works, what +transformations it applies, and what issues arose in its design. + +\section{The language} + +Mutter mutter. Important points: +\begin{itemize} +\item Second order lambda calculus. +\item Arguments are variables. +\item Unboxed data types, and unboxed cases. +\end{itemize} +Less important points: +\begin{itemize} +\item Constructors and primitives are saturated. +\item if-then-else desugared to @case@ +\end{itemize} + +Give data type. + +\section{Transformations} + +This section lists all the transformations implemented by the simplifier. +Because it is a complete list, it is a long one. +We content ourselves with a brief statement of each transformation, +augmented with forward references to Section~\ref{sect:composing} +which gives examples of the ways in which the transformations can compose together. + +\subsection{Beta reduction} + +If a lambda abstraction is applied to an argument, we can simply +beta-reduce. This applies equally to ordinary lambda abstractions and +type abstractions: +@ + (\x -> E[x]) arg ===> E[arg] + (/\a -> E[a]) ty ===> E[ty] +@ +There is no danger of duplicating work because the argument is +guaranteed to be a simple variable or literal. + +\subsubsection{Floating applications inward} + +Applications can be floated inside a @let(rec)@ or @case@ expression. +This is a good idea, because they might find a lambda abstraction inside +to beta-reduce with: +@ + (let(rec) Bind in E) arg ===> let(rec) Bind in (E arg) + + (case E of {P1 -> E1;...; Pn -> En}) arg + ===> + case E of {P1 -> E1 arg; ...; Pn -> En arg} +@ + + + +\subsection{Transformations concerning @let(rec)@} + +\subsubsection{Floating @let@ out of @let@} + +It is sometimes useful to float a @let(rec)@ out of a @let(rec)@ right-hand +side: +@ + let x = let(rec) Bind in B1 ===> let(rec) Bind in + in B2 let x = B1 + in B2 + + + letrec x = let(rec) Bind in B1 ===> let(rec) Bind + in B2 x = B1 + in B2 +@ + +\subsubsection{Floating @case@ out of @let@} + + +\subsubsection{@let@ to @case@} + + +\subsection{Transformations concerning @case@} + +\subsubsection{Case of known constructor} + +If a @case@ expression scrutinises a constructor, +the @case@ can be eliminated. This transformation is a real +win: it eliminates a whole @case@ expression. +@ + case (C a1 .. an) of ===> E[a1..an] + ... + C b1 .. bn -> E[b1..bn] + ... +@ +If none of the constructors in the alternatives match, then +the default is taken: +@ + case (C a1 .. an) of ===> let y = C a1 .. an + ...[no alt matches C]... in E + y -> E +@ +There is an important variant of this transformation when +the @case@ expression scrutinises a {\em variable} +which is known to be bound to a constructor. +This situation can +arise for two reasons: +\begin{itemize} +\item An enclosing @let(rec)@ binding binds the variable to a constructor. +For example: +@ + let x = C p q in ... (case x of ...) ... +@ +\item An enclosing @case@ expression scrutinises the same variable. +For example: +@ + case x of + ... + C p q -> ... (case x of ...) ... + ... +@ +This situation is particularly common, as we discuss in Section~\ref{sect:repeated-evals}. +\end{itemize} +In each of these examples, @x@ is known to be bound to @C p q@ +at the inner @case@. The general rules are: +@ + case x of {...; C b1 .. bn -> E[b1..bn]; ...} +===> {x bound to C a1 .. an} + E[a1..an] + + case x of {...[no alts match C]...; y -> E[y]} +===> {x bound to C a1 .. an} + E[x] +@ + +\subsubsection{Dead alternative elimination} +@ + case x of + C a .. z -> E + ...[other alts]... +===> x *not* bound to C + case x of + ...[other alts]... +@ +We might know that @x@ is not bound to a particular constructor +because of an enclosing case: +@ + case x of + C a .. z -> E1 + other -> E2 +@ +Inside @E1@ we know that @x@ is bound to @C@. +However, if the type has more than two constructors, +inside @E2@ all we know is that @x@ is {\em not} bound to @C@. + +This applies to unboxed cases also, in the obvious way. + +\subsubsection{Case elimination} + +If we can prove that @x@ is not bottom, then this rule applies. +@ + case x of ===> E[x] + y -> E[y] +@ +We might know that @x@ is non-bottom because: +\begin{itemize} +\item @x@ has an unboxed type. +\item There's an enclosing case which scrutinises @x@. +\item It is bound to an expression which provably terminates. +\end{itemize} +Since this transformation can only improve termination, even if we apply it +when @x@ is not provably non-bottom, we provide a compiler flag to +enable it all the time. + +\subsubsection{Case of error} + +@ + case (error ty E) of Alts ===> error ty' E + where + ty' is type of whole case expression +@ + +Mutter about types. Mutter about variables bound to error. +Mutter about disguised forms of error. + +\subsubsection{Floating @let(rec)@ out of @case@} + +A @let(rec)@ binding can be floated out of a @case@ scrutinee: +@ + case (let(rec) Bind in E) of Alts ===> let(rec) Bind in + case E of Alts +@ +This increases the likelihood of a case-of-known-constructor transformation, +because @E@ is not hidden from the @case@ by the @let(rec)@. + +\subsubsection{Floating @case@ out of @case@} + +Analogous to floating a @let(rec)@ from a @case@ scrutinee is +floating a @case@ from a @case@ scrutinee. We have to be +careful, though, about code size. If there's only one alternative +in the inner case, things are easy: +@ + case (case E of {P -> R}) of ===> case E of {P -> case R of + Q1 -> S1 Q1 -> S1 + ... ... + Qm -> Sm Qm -> Sm} +@ +If there's more than one alternative there's a danger +that we'll duplicate @S1@...@Sm@, which might be a lot of code. +Our solution is to create a new local definition for each +alternative: +@ + case (case E of {P1 -> R1; ...; Pn -> Rn}) of + Q1 -> S1 + ... + Qm -> Sm +===> + let s1 = \x1 ... z1 -> S1 + ... + sm = \xm ... zm -> Sm + in + case E of + P1 -> case R1 of {Q1 -> s1 x1 ... z1; ...; Qm -> sm xm ... zm} + ... + Pn -> case Rn of {Q1 -> s1 x1 ... z1; ...; Qm -> sm xm ... zm} +@ +Here, @x1 ... z1@ are that subset of +variables bound by the pattern @Q1@ which are free in @S1@, and +similarly for the other @si@. + +Is this transformation a win? After all, we have introduced @m@ new +functions! Section~\ref{sect:join-points} discusses this point. + +\subsubsection{Case merging} + +@ + case x of + ...[some alts]... + other -> case x of + ...[more alts]... +===> + case x of + ...[some alts]... + ...[more alts]... +@ +Any alternatives in @[more alts]@ which are already covered by @[some alts]@ +should first be eliminated by the dead-alternative transformation. + + +\subsection{Constructor reuse} + + +\subsection{Inlining} + +The inlining transformtion is simple enough: +@ + let x = R in B[x] ===> B[R] +@ +Inlining is more conventionally used to describe the instantiation of a function +body at its call site, with arguments substituted for formal parameters. We treat +this as a two-stage process: inlining followed by beta reduction. Since we are +working with a higher-order language, not all the arguments may be available at every +call site, so separating inlining from beta reduction allows us to concentrate on +one problem at a time. + +The choice of exactly {\em which} bindings to inline has a major impact on efficiency. +Specifically, we need to consider the following factors: +\begin{itemize} +\item +Inlining a function at its call site, followed by some beta reduction, +very often exposes opportunities for further transformations. +We inline many simple arithmetic and boolean operators for this reason. +\item +Inlining can increase code size. +\item +Inlining can duplicate work, for example if a redex is inlined at more than one site. +Duplicating a single expensive redex can ruin a program's efficiency. +\end{itemize} + + +Our inlining strategy depends on the form of @R@: + +Mutter mutter. + + +\subsubsection{Dead code removal} + +If a @let@-bound variable is not used the binding can be dropped: +@ + let x = E in B ===> B + x not free in B +@ +A similar transformation applies for @letrec@-bound variables. +Programmers seldom write dead code, of course, but bindings often become dead when they +are inlined. + + + + +\section{Composing transformations} +\label{sect:composing} + +The really interesting thing about humble transformations is the way in which +they compose together to carry out substantial and useful transformations. +This section gives a collection of motivating examples, all of which have +shown up in real application programs. + +\subsection{Repeated evals} +\label{sect:repeated-evals} + +Example: x+x, as in unboxed paper. + + +\subsection{Lazy pattern matching} + +Lazy pattern matching is pretty inefficient. Consider: +@ + let (x,y) = E in B +@ +which desugars to: +@ + let t = E + x = case t of (x,y) -> x + y = case t of (x,y) -> y + in B +@ +This code allocates three thunks! However, if @B@ is strict in {\em either} +@x@ {\em or} @y@, then the strictness analyser will easily spot that +the binding for @t@ is strict, so we can do a @let@-to-@case@ transformation: +@ + case E of + (x,y) -> let t = (x,y) in + let x = case t of (x,y) -> x + y = case t of (x,y) -> y + in B +@ +whereupon the case-of-known-constructor transformation +eliminates the @case@ expressions in the right-hand side of @x@ and @y@, +and @t@ is then spotted as being dead, so we get +@ + case E of + (x,y) -> B +@ + +\subsection{Join points} +\label{sect:join-points} + +One motivating example is this: +@ + if (not x) then E1 else E2 +@ +After desugaring the conditional, and inlining the definition of +@not@, we get +@ + case (case x of True -> False; False -> True}) of + True -> E1 + False -> E2 +@ +Now, if we apply our case-of-case transformation we get: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> case False of {True -> e1; False -> e2} + False -> case True of {True -> e1; False -> e2} +@ +Now the case-of-known constructor transformation applies: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> e2 + False -> e1 +@ +Since there is now only one occurrence of @e1@ and @e2@ we can +inline them, giving just what we hoped for: +@ + case x of {True -> E2; False -> E1} +@ +The point is that the local definitions will often disappear again. + +\subsubsection{How join points occur} + +But what if they don't disappear? Then the definitions @s1@ ... @sm@ +play the role of ``join points''; they represent the places where +execution joins up again, having forked at the @case x@. The +``calls'' to the @si@ should really be just jumps. To see this more clearly +consider the expression +@ + if (x || y) then E1 else E2 +@ +A C compiler will ``short-circuit'' the +evaluation of the condition if @x@ turns out to be true +generate code, something like this: +@ + if (x) goto l1; + if (y) {...code for E2...} + l1: ...code for E1... +@ +In our setting, here's what will happen. First we desguar the +conditional, and inline the definition of @||@: +@ + case (case x of {True -> True; False -> y}) of + True -> E1 + False -> E2 +@ +Now apply the case-of-case transformation: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> case True of {True -> e1; False -> e2} + False -> case y of {True -> e1; False -> e2} +@ +Unlike the @not@ example, only one of the two inner case +simplifies, and we can therefore only inline @e2@, because +@e1@ is still mentioned twice\footnote{Unless the +inlining strategy decides that @E1@ is small enough to duplicate; +it is used in separate @case@ branches so there's no concern about duplicating +work. Here's another example of the way in which we make one part of the +simplifier (the inlining strategy) help with the work of another (@case@-expression +simplification.} +@ + let e1 = E1 + in + case x of + True -> e1 + False -> case y of {True -> e1; False -> e2} +@ +The code generator produces essentially the same code as +the C code given above. The binding for @e1@ turns into +just a label, which is jumped to from the two occurrences of @e1@. + +\subsubsection{Case of @error@} + +The case-of-error transformation is often exposed by the case-of-case +transformation. Consider +@ + case (hd xs) of + True -> E1 + False -> E2 +@ +After inlining @hd@, we get +@ + case (case xs of [] -> error "hd"; (x:_) -> x) of + True -> E1 + False -> E2 +@ +(I've omitted the type argument of @error@ to save clutter.) +Now doing case-of-case gives +@ + let e1 = E1 + e2 = E2 + in + case xs of + [] -> case (error "hd") of { True -> e1; False -> e2 } + (x:_) -> case x of { True -> e1; False -> e2 } +@ +Now the case-of-error transformation springs to life, after which +we can inline @e1@ and @e2@: +@ + case xs of + [] -> error "hd" + (x:_) -> case x of {True -> E1; False -> E2} +@ + +\subsection{Nested conditionals combined} + +Sometimes programmers write something which should be done +by a single @case@ as a sequence of tests: +@ + if x==0::Int then E0 else + if x==1 then E1 else + E2 +@ +After eliminating some redundant evals and doing the case-of-case +transformation we get +@ + case x of I# x# -> + case x# of + 0# -> E0 + other -> case x# of + 1# -> E1 + other -> E2 +@ +The case-merging transformation puts these together to get +@ + case x of I# x# -> + case x# of + 0# -> E0 + 1# -> E1 + other -> E2 +@ +Sometimes the sequence of tests cannot be eliminated from the source +code because of overloading: +@ + f :: Num a => a -> Bool + f 0 = True + f 3 = True + f n = False +@ +If we specialise @f@ to @Int@ we'll get the previous example again. + +\subsection{Error tests eliminated} + +The elimination of redundant alternatives, and then of redundant cases, +arises when we inline functions which do error checking. A typical +example is this: +@ + if (x `rem` y) == 0 then (x `div` y) else y +@ +Here, both @rem@ and @div@ do an error-check for @y@ being zero. +The second check is eliminated by the transformations. +After transformation the code becomes: +@ + case x of I# x# -> + case y of I# y# -> + case y of + 0# -> error "rem: zero divisor" + _ -> case x# rem# y# of + 0# -> case x# div# y# of + r# -> I# r# + _ -> y +@ + +\subsection{Atomic arguments} + +At this point it is possible to appreciate the usefulness of +the Core-language syntax requirement that arguments are atomic. +For example, suppose that arguments could be arbitrary expressions. +Here is a possible transformation: +@ + f (case x of (p,q) -> p) +===> f strict in its second argument + case x of (p,q) -> f (p,p) +@ +Doing this transformation would be useful, because now the +argument to @f@ is a simple variable rather than a thunk. +However, if arguments are atomic, this transformation becomes +just a special case of floating a @case@ out of a strict @let@: +@ + let a = case x of (p,q) -> p + in f a +===> (f a) strict in a + case x of (p,q) -> let a=p in f a +===> + case x of (p,q) -> f p +@ +There are many examples of this kind. For almost any transformation +involving @let@ there is a corresponding one involving a function +argument. The same effect is achieved with much less complexity +by restricting function arguments to be atomic. + +\section{Design} + +Dependency analysis +Occurrence analysis + +\subsection{Renaming and cloning} + +Every program-transformation system has to worry about name capture. +For example, here is an erroneous transformation: +@ + let y = E + in + (\x -> \y -> x + y) (y+3) +===> WRONG! + let y = E + in + (\y -> (y+3) + y) +@ +The transformation fails because the originally free-occurrence +of @y@ in the argument @y+3@ has been ``captured'' by the @\y@-abstraction. +There are various sophisticated solutions to this difficulty, but +we adopted a very simple one: we uniquely rename every locally-bound identifier +on every pass of the simplifier. +Since we are in any case producing an entirely new program (rather than side-effecting +an existing one) it costs very little extra to rename the identifiers as we go. + +So our example would become +@ + let y = E + in + (\x -> \y -> x + y) (y+3) +===> WRONG! + let y1 = E + in + (\y2 -> (y1+3) + y2) +@ +The simplifier accepts as input a program which has arbitrary bound +variable names, including ``shadowing'' (where a binding hides an +outer binding for the same identifier), but it produces a program in +which every bound identifier has a distinct name. + +Both the ``old'' and ``new'' identifiers have type @Id@, but when writing +type signatures for functions in the simplifier we use the types @InId@, for +identifiers from the input program, and @OutId@ for identifiers from the output program: +@ + type InId = Id + type OutId = Id +@ +This nomenclature extends naturally to expressions: a value of type @InExpr@ is an +expression whose identifiers are from the input-program name-space, and similarly +@OutExpr@. + + +\section{The simplifier} + +The basic algorithm followed by the simplifier is: +\begin{enumerate} +\item Analyse: perform occurrence analysis and dependency analysis. +\item Simplify: apply as many transformations as possible. +\item Iterate: perform the above two steps repeatedly until no further transformations are possible. +(A compiler flag allows the programmer to bound the maximum number of iterations.) +\end{enumerate} +We make a effort to apply as many transformations as possible in Step +2. To see why this is a good idea, just consider a sequence of +transformations in which each transformation enables the next. If +each iteration of Step 2 only performs one transformation, then the +entire program will to be re-analysed by Step 1, and re-traversed by +Step 2, for each transformation of the sequence. Sometimes this is +unavoidable, but it is often possible to perform a sequence of +transformtions in a single pass. + +The key function, which simplifies expressions, has the following type: +@ + simplExpr :: SimplEnv + -> InExpr -> [OutArg] + -> SmplM OutExpr +@ +The monad, @SmplM@ can quickly be disposed of. It has only two purposes: +\begin{itemize} +\item It plumbs around a supply of unique names, so that the simplifier can +easily invent new names. +\item It gathers together counts of how many of each kind of transformation +has been applied, for statistical purposes. These counts are also used +in Step 3 to decide when the simplification process has terminated. +\end{itemize} + +The signature can be understood like this: +\begin{itemize} +\item The environment, of type @SimplEnv@, provides information about +identifiers bound by the enclosing context. +\item The second and third arguments together specify the expression to be simplified. +\item The result is the simplified expression, wrapped up by the monad. +\end{itemize} +The simplifier's invariant is this: +$$ +@simplExpr@~env~expr~[a_1,\ldots,a_n] = expr[env]~a_1~\ldots~a_n +$$ +That is, the expression returned by $@simplExpr@~env~expr~[a_1,\ldots,a_n]$ +is semantically equal (although hopefully more efficient than) +$expr$, with the renamings in $env$ applied to it, applied to the arguments +$a_1,\ldots,a_n$. + +\subsection{Application and beta reduction} + +The arguments are carried ``inwards'' by @simplExpr@, as an accumulating parameter. +This is a convenient way of implementing the transformations which float +arguments inside a @let@ and @case@. This list of pending arguments +requires a new data type, @CoreArg@, along with its ``in'' and ``out'' synonyms, +because an argument might be a type or an atom: +@ +data CoreArg bindee = TypeArg UniType + | ValArg (CoreAtom bindee) + +type InArg = CoreArg InId +type OutArg = CoreArg OutId +@ +The equations for applications simply apply +the environment to the argument (to handle renaming) and put the result +on the argument stack, tagged to say whether it is a type argument or value argument: +@ + simplExpr env (CoApp fun arg) args + = simplExpr env fun (ValArg (simplAtom env arg) : args) + simplExpr env (CoTyApp fun ty) args + = simplExpr env fun (TypeArg (simplTy env ty) : args) +@ + + + + + + +\end{document} diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs new file mode 100644 index 00000000..b8804a47 --- /dev/null +++ b/compiler/simplStg/SimplStg.hs @@ -0,0 +1,89 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[SimplStg]{Driver for simplifying @STG@ programs} +-} + +{-# LANGUAGE CPP #-} + +module SimplStg ( stg2stg ) where + +#include "HsVersions.h" + +import StgSyn + +import CostCentre ( CollectedCCs ) +import SCCfinal ( stgMassageForProfiling ) +import StgLint ( lintStgBindings ) +import StgStats ( showStgStats ) +import UnariseStg ( unarise ) + +import DynFlags +import Module ( Module ) +import ErrUtils +import SrcLoc +import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) +import Outputable +import Control.Monad + +stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do + -> Module -- module name (profiling only) + -> [StgBinding] -- input... + -> IO ( [StgBinding] -- output program... + , CollectedCCs) -- cost centre information (declared and used) + +stg2stg dflags module_name binds + = do { showPass dflags "Stg2Stg" + ; us <- mkSplitUniqSupply 'g' + + ; when (dopt Opt_D_verbose_stg2stg dflags) + (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:")) + + ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds + + -- Do the main business! + ; let (us0, us1) = splitUniqSupply us' + ; (processed_binds, _, cost_centres) + <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags) + + ; let un_binds = unarise us1 processed_binds + + ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" + (pprStgBindings un_binds) + + ; return (un_binds, cost_centres) + } + + where + stg_linter = if gopt Opt_DoStgLinting dflags + then lintStgBindings + else ( \ _whodunnit binds -> binds ) + + ------------------------------------------- + do_stg_pass (binds, us, ccs) to_do + = let + (us1, us2) = splitUniqSupply us + in + case to_do of + D_stg_stats -> + trace (showStgStats binds) + end_pass us2 "StgStats" ccs binds + + StgDoMassageForProfiling -> + {-# SCC "ProfMassage" #-} + let + (collected_CCs, binds3) + = stgMassageForProfiling dflags module_name us1 binds + in + end_pass us2 "ProfMassage" collected_CCs binds3 + + end_pass us2 what ccs binds2 + = do -- report verbosely, if required + dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + (vcat (map ppr binds2)) + let linted_binds = stg_linter what binds2 + return (linted_binds, us2, ccs) + -- return: processed binds + -- UniqueSupply for the next guy to use + -- cost-centres to be declared/registered (specialised) + -- add to description of what's happened (reverse order) diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs new file mode 100644 index 00000000..dd1f5a64 --- /dev/null +++ b/compiler/simplStg/StgStats.hs @@ -0,0 +1,173 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[StgStats]{Gathers statistical information about programs} + + +The program gather statistics about +\begin{enumerate} +\item number of boxed cases +\item number of unboxed cases +\item number of let-no-escapes +\item number of non-updatable lets +\item number of updatable lets +\item number of applications +\item number of primitive applications +\item number of closures (does not include lets bound to constructors) +\item number of free variables in closures +%\item number of top-level functions +%\item number of top-level CAFs +\item number of constructors +\end{enumerate} +-} + +{-# LANGUAGE CPP #-} + +module StgStats ( showStgStats ) where + +#include "HsVersions.h" + +import StgSyn + +import Id (Id) +import Panic + +import Data.Map (Map) +import qualified Data.Map as Map + +data CounterType + = Literals + | Applications + | ConstructorApps + | PrimitiveApps + | LetNoEscapes + | StgCases + | FreeVariables + | ConstructorBinds Bool{-True<=>top-level-} + | ReEntrantBinds Bool{-ditto-} + | SingleEntryBinds Bool{-ditto-} + | UpdatableBinds Bool{-ditto-} + deriving (Eq, Ord) + +type Count = Int +type StatEnv = Map CounterType Count + +emptySE :: StatEnv +emptySE = Map.empty + +combineSE :: StatEnv -> StatEnv -> StatEnv +combineSE = Map.unionWith (+) + +combineSEs :: [StatEnv] -> StatEnv +combineSEs = foldr combineSE emptySE + +countOne :: CounterType -> StatEnv +countOne c = Map.singleton c 1 + +countN :: CounterType -> Int -> StatEnv +countN = Map.singleton + +{- +************************************************************************ +* * +\subsection{Top-level list of bindings (a ``program'')} +* * +************************************************************************ +-} + +showStgStats :: [StgBinding] -> String + +showStgStats prog + = "STG Statistics:\n\n" + ++ concat (map showc (Map.toList (gatherStgStats prog))) + where + showc (x,n) = (showString (s x) . shows n) "\n" + + s Literals = "Literals " + s Applications = "Applications " + s ConstructorApps = "ConstructorApps " + s PrimitiveApps = "PrimitiveApps " + s LetNoEscapes = "LetNoEscapes " + s StgCases = "StgCases " + s FreeVariables = "FreeVariables " + s (ConstructorBinds True) = "ConstructorBinds_Top " + s (ReEntrantBinds True) = "ReEntrantBinds_Top " + s (SingleEntryBinds True) = "SingleEntryBinds_Top " + s (UpdatableBinds True) = "UpdatableBinds_Top " + s (ConstructorBinds _) = "ConstructorBinds_Nested " + s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested " + s (SingleEntryBinds _) = "SingleEntryBinds_Nested " + s (UpdatableBinds _) = "UpdatableBinds_Nested " + +gatherStgStats :: [StgBinding] -> StatEnv + +gatherStgStats binds + = combineSEs (map (statBinding True{-top-level-}) binds) + +{- +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +statBinding :: Bool -- True <=> top-level; False <=> nested + -> StgBinding + -> StatEnv + +statBinding top (StgNonRec b rhs) + = statRhs top (b, rhs) + +statBinding top (StgRec pairs) + = combineSEs (map (statRhs top) pairs) + +statRhs :: Bool -> (Id, StgRhs) -> StatEnv + +statRhs top (_, StgRhsCon _ _ _) + = countOne (ConstructorBinds top) + +statRhs top (_, StgRhsClosure _ _ fv u _ _ body) + = statExpr body `combineSE` + countN FreeVariables (length fv) `combineSE` + countOne ( + case u of + ReEntrant -> ReEntrantBinds top + Updatable -> UpdatableBinds top + SingleEntry -> SingleEntryBinds top + ) + +{- +************************************************************************ +* * +\subsection{Expressions} +* * +************************************************************************ +-} + +statExpr :: StgExpr -> StatEnv + +statExpr (StgApp _ _) = countOne Applications +statExpr (StgLit _) = countOne Literals +statExpr (StgConApp _ _) = countOne ConstructorApps +statExpr (StgOpApp _ _ _) = countOne PrimitiveApps +statExpr (StgTick _ e) = statExpr e + +statExpr (StgLetNoEscape _ _ binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body `combineSE` + countOne LetNoEscapes + +statExpr (StgLet binds body) + = statBinding False{-not top-level-} binds `combineSE` + statExpr body + +statExpr (StgCase expr _ _ _ _ _ alts) + = statExpr expr `combineSE` + stat_alts alts `combineSE` + countOne StgCases + where + stat_alts alts + = combineSEs (map statExpr [ e | (_,_,_,e) <- alts ]) + +statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs new file mode 100644 index 00000000..87ce0ed9 --- /dev/null +++ b/compiler/simplStg/UnariseStg.hs @@ -0,0 +1,220 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2012 + + +Note [Unarisation] +~~~~~~~~~~~~~~~~~~ + +The idea of this pass is to translate away *all* unboxed-tuple binders. So for example: + +f (x :: (# Int, Bool #)) = f x + f (# 1, True #) + ==> +f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True + +It is important that we do this at the STG level and NOT at the core level +because it would be very hard to make this pass Core-type-preserving. + +STG fed to the code generators *must* be unarised because the code generators do +not support unboxed tuple binders natively. + + +Note [Unarisation and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Because of unarisation, the arity that will be recorded in the generated info table +for an Id may be larger than the idArity. Instead we record what we call the RepArity, +which is the Arity taking into account any expanded arguments, and corresponds to +the number of (possibly-void) *registers* arguments will arrive in. +-} + +{-# LANGUAGE CPP #-} + +module UnariseStg (unarise) where + +#include "HsVersions.h" + +import CoreSyn +import StgSyn +import VarEnv +import UniqSupply +import Id +import MkId (realWorldPrimId) +import Type +import TysWiredIn +import DataCon +import VarSet +import OccName +import Name +import Util +import Outputable +import BasicTypes + + +-- | A mapping from unboxed-tuple binders to the Ids they were expanded to. +-- +-- INVARIANT: Ids in the range don't have unboxed tuple types. +-- +-- Those in-scope variables without unboxed-tuple types are not present in +-- the domain of the mapping at all. +type UnariseEnv = VarEnv [Id] + +ubxTupleId0 :: Id +ubxTupleId0 = dataConWorkId (tupleCon UnboxedTuple 0) + +unarise :: UniqSupply -> [StgBinding] -> [StgBinding] +unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds + where -- See Note [Nullary unboxed tuple] in Type.lhs + init_env = unitVarEnv ubxTupleId0 [realWorldPrimId] + +unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding +unariseBinding us rho bind = case bind of + StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs) + StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) + (listSplitUniqSupply us) xrhss + +unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs +unariseRhs us rho rhs = case rhs of + StgRhsClosure ccs b_info fvs update_flag srt args expr + -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag + (unariseSRT rho srt) args' (unariseExpr us' rho' expr) + where (us', rho', args') = unariseIdBinders us rho args + StgRhsCon ccs con args + -> StgRhsCon ccs con (unariseArgs rho args) + +------------------------ +unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr +unariseExpr _ rho (StgApp f args) + | null args + , UbxTupleRep tys <- repType (idType f) + = -- Particularly important where (##) is concerned + -- See Note [Nullary unboxed tuple] + StgConApp (tupleCon UnboxedTuple (length tys)) + (map StgVarArg (unariseId rho f)) + + | otherwise + = StgApp f (unariseArgs rho args) + +unariseExpr _ _ (StgLit l) + = StgLit l + +unariseExpr _ rho (StgConApp dc args) + | isUnboxedTupleCon dc = StgConApp (tupleCon UnboxedTuple (length args')) args' + | otherwise = StgConApp dc args' + where + args' = unariseArgs rho args + +unariseExpr _ rho (StgOpApp op args ty) + = StgOpApp op (unariseArgs rho args) ty + +unariseExpr us rho (StgLam xs e) + = StgLam xs' (unariseExpr us' rho' e) + where + (us', rho', xs') = unariseIdBinders us rho xs + +unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts) + = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) + (unariseLives rho alts_lives) bndr (unariseSRT rho srt) + alt_ty' alts' + where + (us1, us2) = splitUniqSupply us + (alt_ty', alts') = unariseAlts us2 rho alt_ty bndr (repType (idType bndr)) alts + +unariseExpr us rho (StgLet bind e) + = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where + (us1, us2) = splitUniqSupply us + +unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e) + = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) + (unariseBinding us1 rho bind) (unariseExpr us2 rho e) + where + (us1, us2) = splitUniqSupply us + +unariseExpr us rho (StgTick tick e) + = StgTick tick (unariseExpr us rho e) + +------------------------ +unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> RepType -> [StgAlt] -> (AltType, [StgAlt]) +unariseAlts us rho alt_ty _ (UnaryRep _) alts + = (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts) + +unariseAlts us rho _ bndr (UbxTupleRep tys) ((DEFAULT, [], [], e) : _) + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) + where + (us2', rho', ys) = unariseIdBinder us rho bndr + uses = replicate (length ys) (not (isDeadBinder bndr)) + n = length tys + +unariseAlts us rho _ bndr (UbxTupleRep _) [(DataAlt _, ys, uses, e)] + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) + where + (us2', rho', ys', uses') = unariseUsedIdBinders us rho ys uses + rho'' = extendVarEnv rho' bndr ys' + n = length ys' + +unariseAlts _ _ _ _ (UbxTupleRep _) alts + = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts) + +-------------------------- +unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt +unariseAlt us rho (con, xs, uses, e) + = (con, xs', uses', unariseExpr us' rho' e) + where + (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses + +------------------------ +unariseSRT :: UnariseEnv -> SRT -> SRT +unariseSRT _ NoSRT = NoSRT +unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids) +unariseSRT _ (SRT {}) = panic "unariseSRT" + +unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars +unariseLives rho ids = concatMapVarSet (unariseId rho) ids + +unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg] +unariseArgs rho = concatMap (unariseArg rho) + +unariseArg :: UnariseEnv -> StgArg -> [StgArg] +unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x) +unariseArg _ (StgLitArg l) = [StgLitArg l] + +unariseIds :: UnariseEnv -> [Id] -> [Id] +unariseIds rho = concatMap (unariseId rho) + +unariseId :: UnariseEnv -> Id -> [Id] +unariseId rho x + | Just ys <- lookupVarEnv rho x + = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0 + , text "unariseId: not unboxed tuple" <+> ppr x ) + ys + + | otherwise + = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True + , text "unariseId: was unboxed tuple" <+> ppr x ) + [x] + +unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] + -> (UniqSupply, UnariseEnv, [Id], [Bool]) +unariseUsedIdBinders us rho xs uses + = case mapAccumL2 do_one us rho (zipEqual "unariseUsedIdBinders" xs uses) of + (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess)) + where + do_one us rho (x, use) = third3 (map (flip (,) use)) (unariseIdBinder us rho x) + +unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs + +unariseIdBinder :: UniqSupply -> UnariseEnv -> Id -> (UniqSupply, UnariseEnv, [Id]) +unariseIdBinder us rho x = case repType (idType x) of + UnaryRep _ -> (us, rho, [x]) + UbxTupleRep tys -> let (us0, us1) = splitUniqSupply us + ys = unboxedTupleBindersFrom us0 x tys + rho' = extendVarEnv rho x ys + in (us1, rho', ys) + +unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] +unboxedTupleBindersFrom us x tys = zipWith (mkSysLocal fs) (uniqsFromSupply us) tys + where fs = occNameFS (getOccName x) + +concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet +concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x] diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs new file mode 100644 index 00000000..99a35f32 --- /dev/null +++ b/compiler/specialise/Rules.hs @@ -0,0 +1,1192 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Transformation rules} +-} + +{-# LANGUAGE CPP #-} + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module Rules ( + -- * RuleBase + RuleBase, + + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'SpecInfo' rules + mkSpecInfo, extendSpecInfo, addSpecInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + lookupRule, mkRule, roughTopNames + ) where + +#include "HsVersions.h" + +import CoreSyn -- All of it +import CoreSubst +import OccurAnal ( occurAnalyseExpr ) +import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) +import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, + stripTicksTopT, stripTicksTopE ) +import PprCore ( pprRules ) +import Type ( Type, substTy, mkTvSubst ) +import TcType ( tcSplitTyConApp_maybe ) +import TysPrim ( anyTypeOfKind ) +import Coercion +import CoreTidy ( tidyRules ) +import Id +import IdInfo ( SpecInfo( SpecInfo ) ) +import Var +import VarEnv +import VarSet +import Name ( Name, NamedThing(..) ) +import NameEnv +import Unify ( ruleMatchTyX, MatchEnv(..) ) +import BasicTypes ( Activation, CompilerPhase, isActive, pprRuleName ) +import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags ) +import Outputable +import FastString +import Maybes +import Bag +import Util +import Data.List +import Data.Ord + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + DsBinds + +* TidyPgm strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the CoreMonad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the CoreMonad, and + (d) from its mutable variable + [Of coures this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A @CoreRule@ holds details of one rule for an @Id@, which +includes its specialisations. + +For example, if a rule for @f@ contains the mapping: +\begin{verbatim} + forall a b d. [Type (List a), Type b, Var d] ===> f' a b +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool dict ===> f' Int Bool +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. +-} + +mkRule :: Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' +mkRule is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = occurAnalyseExpr rhs, + ru_rough = roughTopNames args, + ru_auto = is_auto, ru_local = is_local } + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in PprCore because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortBy (comparing ru_name) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + SpecInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkSpecInfo :: [CoreRule] -> SpecInfo +mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) + +extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo +extendSpecInfo (SpecInfo rs1 fvs1) rs2 + = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1) + +addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo +addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) + = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id [] + = id +addIdSpecialisations id rules + = setIdSpecialisation id $ + extendSpecInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleBase -> Id -> [CoreRule] +-- See Note [Where rules are found] +getRules rule_base fn + = idCoreRules fn ++ imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] + +{- +Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in PrelRules.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- nameEnvElts rules ] + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] +-- See comments on matchRule +lookupRule dflags in_scope is_active fn args rules + = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule dflags in_scope is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + | opt_PprStyle_Debug = ppr rule + | otherwise = doubleQuotes (ftext (ru_name rule)) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [if opt_PprStyle_Debug then + ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) + else empty, + ptext (sLit "Rule 1:") <+> pp_rule rule1, + ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs + | otherwise = findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +-- This tests if one rule is more specific than another +-- We take the view that a BuiltinRule is less specific than +-- anything else, because we want user-define rules to "win" +-- In particular, class ops have a built-in rule, but we +-- any user-specific rules to win +-- eg (Trac #4397) +-- truncate :: (RealFrac a, Integral b) => a -> b +-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- double2Int :: Double -> Int +-- We want the specific RULE to beat the built-in class-op rule +isMoreSpecific (BuiltinRule {}) _ = False +isMoreSpecific (Rule {}) (BuiltinRule {}) = True +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2, ru_name = rule_name2 }) + = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution +-} + +------------------------------------ +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The bndrs and rhs is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the call: matchRule the_rule [e1,map e2 e3] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- Any 'surplus' arguments in the input are simply put on the end +-- of the output. + +matchRule dflags rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn dflags rule_env fn args of + Just expr -> Just expr + Nothing -> Nothing + +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise + = case matchN in_scope rule_name tpl_vars tpl_args args of + Nothing -> Nothing + Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ + rule_fn `mkApps` tpl_vals) + where + rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs) + -- We could do this when putting things into the rulebase, I guess + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -- ^ Target; can have more elements than the template + -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets] + [CoreExpr]) +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es + = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars + ; return (rs_binds subst, matched_es) } + where + init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars) + -- See Note [Template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args + go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + ; go menv subst1 ts es } + + lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr) + lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var + | isId tmpl_var + = case lookupVarEnv id_subst tmpl_var of + Just e -> (rs, e) + _ -> unbound tmpl_var + | otherwise + = case lookupVarEnv tv_subst tmpl_var of + Just ty -> (rs, Type ty) + Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty) + -- See Note [Unbound template type variables] + where + fake_ty = anyTypeOfKind kind + kind = Type.substTy (mkTvSubst in_scope tv_subst) (tyVarKind tmpl_var) + + unbound var = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ ptext (sLit "Variable:") <+> ppr var + , ptext (sLit "Rule") <+> pprRuleName rule_name + , ptext (sLit "Rule bndrs:") <+> ppr tmpl_vars + , ptext (sLit "LHS args:") <+> ppr tmpl_es + , ptext (sLit "Actual args:") <+> ppr target_es ] + +{- Note [Unbound template type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type synonyms with phantom args can give rise to unbound template type +variables. Consider this (Trac #10689, simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + +The rule looks like + foall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + +Matching the rule won't bind 'a', and legitimately so. We fudge by +pretending that 'a' is bound to (Any :: *). + +Note [Template binders] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by: + * Adding forall'd template binders to the in-scope set + +This works even if the template binder are already in scope +(in the target) because + + * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to + the target world. It is not applied recursively. + + * Having the template vars in the in-scope set ensures that in + example 2 above, the (\x.x) is cloned to (\x'. x'). + +In the past we used rnBndrL to clone the template variables if +they were already in scope. But (a) that's not necessary and (b) +it complicate the fancy footwork for Note [Unbound template type variables] + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleMatchEnv + = RV { rv_tmpls :: VarSet -- Template variables + , rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- domain disjoint from envR of rv_lcl + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdEnv CoreExpr -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: VarSet -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + +-- At one stage I tried to match even if there are more +-- template args than real args. + +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + + +match :: RuleMatchEnv + -> RuleSubst + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +-- We look through certain ticks. See note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) + | tickishFloatable t + = match renv subst' e1 e2 + where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match _ _ e@Tick{} _ + = pprPanic "Tick in rule" (ppr e) + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expresion. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match renv subst (Var v1) e2 = match_var renv subst v1 e2 + +match renv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +match renv subst e1 (Let bind e2) + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' }) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + e1 e2 + where + flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match renv subst (App f1 a1) (App f2 a2) + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } + +match renv subst (Lam x1 e1) e2 + | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 + = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2 + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 + ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted + } + +match renv subst (Type ty1) (Type ty2) + = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 + +match renv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst (CoVarCo cv) co + = match_var renv subst cv (Coercion co) +match_co renv subst (Refl r1 ty1) co + = case co of + Refl r2 ty2 + | r1 == r2 -> match_ty renv subst ty1 ty2 + _ -> Nothing +match_co renv subst (TyConAppCo r1 tc1 cos1) co2 + = case co2 of + TyConAppCo r2 tc2 cos2 + | r1 == r2 && tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing +match_co _ _ _co1 _co2 + -- Currently just deals with CoVarCo, TyConAppCo and Refl +#ifdef DEBUG + = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing +#else + = Nothing +#endif + +match_cos :: RuleMatchEnv + -> RuleSubst + -> [Coercion] + -> [Coercion] + -> Maybe RuleSubst +match_cos renv subst (co1:cos1) (co2:cos2) = + case match_co renv subst co1 co2 of + Just subst' -> match_cos renv subst' cos1 cos2 + Nothing -> Nothing +match_cos _ subst [] [] = Just subst +match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing + + +------------- +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv subst x1 x2 + = renv { rv_lcl = rnBndr2 rn_env x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + where + rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) + -- Typically this is a no-op, but it may matter if + -- there are some floated let-bindings + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] + = return subst +match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 + ; match_alts renv subst1 alts1 alts2 } + where + renv' = foldl mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + +match_alts _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = foldVarSet ((&&) . not_captured) True bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | v1' == rnOccR rn_env v2 + -> Just subst + + | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 + , v1' == v2' + -> Just subst + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) + = Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqExpr (rnInScopeSet rn_env) e1' e2' + then Just subst + else Nothing + + | otherwise + = -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | isEmptyVarSet let_bndrs = e2 + | otherwise = substExpr (text "match_tmpl_var") flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + menv = ME { me_tmpls = rv_tmpls renv, me_env = rv_lcl renv } + +{- +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to unconditionally look through Notes in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +cf Note [Notes in call patterns] in SpecConstr + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. ) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points. + (a) What if floating the binding captures a variable? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test "RuleFloatLet". + +Our cunning plan is this: + * Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound. + + * The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case) + + * When we encounter a let in the term to be matched, we + check that does not mention any locally bound (lambda, case) + variables. If so we fail + + * We use CoreSubst.substBind to freshen the binding, using an + in-scope set that is the original in-scope variables plus the + rs_bndrs (currently floated let-bindings). So in (a) above + we'll freshen the 'v' binding; in (b) above we'll freshen + the *second* 'v' binding. + + * We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = \$s\$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to \$wfoo is + \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> RuleBase -- ^ Database of rules + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram phase rule_pat rule_base binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rule_base = rule_base } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rule_base :: RuleBase +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (getRules (rc_rule_base env) fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = sdocWithDynFlags $ \dflags -> + rule_herald rule <> colon <+> rule_info dflags rule + + rule_herald (BuiltinRule { ru_name = name }) + = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = ptext (sLit "Rule") <+> doubleQuotes (ftext name) + + rule_info dflags rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs new file mode 100644 index 00000000..6a69136f --- /dev/null +++ b/compiler/specialise/SpecConstr.hs @@ -0,0 +1,2054 @@ +{- +ToDo [Oct 2013] +~~~~~~~~~~~~~~~ +1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim) +2. Nuke NoSpecConstr + + +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[SpecConstr]{Specialise over constructors} +-} + +{-# LANGUAGE CPP #-} + +module SpecConstr( + specConstrProgram +#ifdef GHCI + , SpecConstrAnnotation(..) +#endif + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreSubst +import CoreUtils +import CoreUnfold ( couldBeSmallEnoughToInline ) +import CoreFVs ( exprsFreeVars ) +import CoreMonad +import Literal ( litIsLifted ) +import HscTypes ( ModGuts(..) ) +import WwLib ( mkWorkerArgs ) +import DataCon +import Coercion hiding( substTy, substCo ) +import Rules +import Type hiding ( substTy ) +import TyCon ( isRecursiveTyCon, tyConName ) +import Id +import PprCore ( pprParendExpr ) +import MkCore ( mkImpossibleExpr ) +import Var +import VarEnv +import VarSet +import Name +import BasicTypes +import DynFlags ( DynFlags(..) ) +import StaticFlags ( opt_PprStyle_Debug ) +import Maybes ( orElse, catMaybes, isJust, isNothing ) +import Demand +import Serialized ( deserializeWithData ) +import Util +import Pair +import UniqSupply +import Outputable +import FastString +import UniqFM +import MonadUtils +import Control.Monad ( zipWithM ) +import Data.List +import PrelNames ( specTyConName ) + +-- See Note [Forcing specialisation] +#ifndef GHCI +type SpecConstrAnnotation = () +#else +import TyCon ( TyCon ) +import GHC.Exts( SpecConstrAnnotation(..) ) +#endif + +{- +----------------------------------------------------- + Game plan +----------------------------------------------------- + +Consider + drop n [] = [] + drop 0 xs = [] + drop n (x:xs) = drop (n-1) xs + +After the first time round, we could pass n unboxed. This happens in +numerical code too. Here's what it looks like in Core: + + drop n xs = case xs of + [] -> [] + (y:ys) -> case n of + I# n# -> case n# of + 0 -> [] + _ -> drop (I# (n# -# 1#)) xs + +Notice that the recursive call has an explicit constructor as argument. +Noticing this, we can make a specialised version of drop + + RULE: drop (I# n#) xs ==> drop' n# xs + + drop' n# xs = let n = I# n# in ...orig RHS... + +Now the simplifier will apply the specialisation in the rhs of drop', giving + + drop' n# xs = case xs of + [] -> [] + (y:ys) -> case n# of + 0 -> [] + _ -> drop' (n# -# 1#) xs + +Much better! + +We'd also like to catch cases where a parameter is carried along unchanged, +but evaluated each time round the loop: + + f i n = if i>0 || i>n then i else f (i*2) n + +Here f isn't strict in n, but we'd like to avoid evaluating it each iteration. +In Core, by the time we've w/wd (f is strict in i) we get + + f i# n = case i# ># 0 of + False -> I# i# + True -> case n of { I# n# -> + case i# ># n# of + False -> I# i# + True -> f (i# *# 2#) n + +At the call to f, we see that the argument, n is known to be (I# n#), +and n is evaluated elsewhere in the body of f, so we can play the same +trick as above. + + +Note [Reboxing] +~~~~~~~~~~~~~~~ +We must be careful not to allocate the same constructor twice. Consider + f p = (...(case p of (a,b) -> e)...p..., + ...let t = (r,s) in ...t...(f t)...) +At the recursive call to f, we can see that t is a pair. But we do NOT want +to make a specialised copy: + f' a b = let p = (a,b) in (..., ...) +because now t is allocated by the caller, then r and s are passed to the +recursive call, which allocates the (r,s) pair again. + +This happens if + (a) the argument p is used in other than a case-scrutinisation way. + (b) the argument to the call is not a 'fresh' tuple; you have to + look into its unfolding to see that it's a tuple + +Hence the "OR" part of Note [Good arguments] below. + +ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves +allocation, but does perhaps save evals. In the RULE we'd have +something like + + f (I# x#) = f' (I# x#) x# + +If at the call site the (I# x) was an unfolding, then we'd have to +rely on CSE to eliminate the duplicate allocation.... This alternative +doesn't look attractive enough to pursue. + +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +the conservative reboxing story prevents many useful functions from being +specialised. Example: + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) +Here the use of 'x' will clearly not require boxing in the specialised function. + +The strictness analyser has the same problem, in fact. Example: + f p@(a,b) = ... +If we pass just 'a' and 'b' to the worker, it might need to rebox the +pair to create (a,b). A more sophisticated analysis might figure out +precisely the cases in which this could happen, but the strictness +analyser does no such analysis; it just passes 'a' and 'b', and hopes +for the best. + +So my current choice is to make SpecConstr similarly aggressive, and +ignore the bad potential of reboxing. + + +Note [Good arguments] +~~~~~~~~~~~~~~~~~~~~~ +So we look for + +* A self-recursive function. Ignore mutual recursion for now, + because it's less common, and the code is simpler for self-recursion. + +* EITHER + + a) At a recursive call, one or more parameters is an explicit + constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + + OR + + b) At a recursive call, one or more parameters has an unfolding + that is an explicit constructor application + AND + That same parameter is scrutinised by a case somewhere in + the RHS of the function + AND + Those are the only uses of the parameter (see Note [Reboxing]) + + +What to abstract over +~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a complication with type arguments. If the call +site looks like + + f p = ...f ((:) [a] x xs)... + +then our specialised function look like + + f_spec x xs = let p = (:) [a] x xs in ....as before.... + +This only makes sense if either + a) the type variable 'a' is in scope at the top of f, or + b) the type variable 'a' is an argument to f (and hence fs) + +Actually, (a) may hold for value arguments too, in which case +we may not want to pass them. Supose 'x' is in scope at f's +defn, but xs is not. Then we'd like + + f_spec xs = let p = (:) [a] x xs in ....as before.... + +Similarly (b) may hold too. If x is already an argument at the +call, no need to pass it again. + +Finally, if 'a' is not in scope at the call site, we could abstract +it as we do the term variables: + + f_spec a x xs = let p = (:) [a] x xs in ...as before... + +So the grand plan is: + + * abstract the call site to a constructor-only pattern + e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3) + + * Find the free variables of the abstracted pattern + + * Pass these variables, less any that are in scope at + the fn defn. But see Note [Shadowing] below. + + +NOTICE that we only abstract over variables that are not in scope, +so we're in no danger of shadowing variables used in "higher up" +in f_spec's RHS. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +In this pass we gather up usage information that may mention variables +that are bound between the usage site and the definition site; or (more +seriously) may be bound to something different at the definition site. +For example: + + f x = letrec g y v = let x = ... + in ...(g (a,b) x)... + +Since 'x' is in scope at the call site, we may make a rewrite rule that +looks like + RULE forall a,b. g (a,b) x = ... +But this rule will never match, because it's really a different 'x' at +the call site -- and that difference will be manifest by the time the +simplifier gets to it. [A worry: the simplifier doesn't *guarantee* +no-shadowing, so perhaps it may not be distinct?] + +Anyway, the rule isn't actually wrong, it's just not useful. One possibility +is to run deShadowBinds before running SpecConstr, but instead we run the +simplifier. That gives the simplest possible program for SpecConstr to +chew on; and it virtually guarantees no shadowing. + +Note [Specialising for constant parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This one is about specialising on a *constant* (but not necessarily +constructor) argument + + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (+1) + +It produces + + lvl_rmV :: GHC.Base.Int -> GHC.Base.Int + lvl_rmV = + \ (ds_dlk :: GHC.Base.Int) -> + case ds_dlk of wild_alH { GHC.Base.I# x_alG -> + GHC.Base.I# (GHC.Prim.+# x_alG 1) + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sme of ds_Xlw { + __DEFAULT -> + case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz -> + T.$wfoo ww1_Xmz lvl_rmV + }; + 0 -> 0 + } + +The recursive call has lvl_rmV as its argument, so we could create a specialised copy +with that argument baked in; that is, not passed at all. Now it can perhaps be inlined. + +When is this worth it? Call the constant 'lvl' +- If 'lvl' has an unfolding that is a constructor, see if the corresponding + parameter is scrutinised anywhere in the body. + +- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding + parameter is applied (...to enough arguments...?) + + Also do this is if the function has RULES? + +Also + +Note [Specialising for lambda parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + foo :: Int -> (Int -> Int) -> Int + foo 0 f = 0 + foo m f = foo (f m) (\n -> n-m) + +This is subtly different from the previous one in that we get an +explicit lambda as the argument: + + T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) -> + GHC.Prim.Int# + T.$wfoo = + \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) -> + case ww_sm8 of ds_Xlr { + __DEFAULT -> + case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq -> + T.$wfoo + ww1_Xmq + (\ (n_ad3 :: GHC.Base.Int) -> + case n_ad3 of wild_alB { GHC.Base.I# x_alA -> + GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr) + }) + }; + 0 -> 0 + } + +I wonder if SpecConstr couldn't be extended to handle this? After all, +lambda is a sort of constructor for functions and perhaps it already +has most of the necessary machinery? + +Furthermore, there's an immediate win, because you don't need to allocate the lambda +at the call site; and if perchance it's called in the recursive call, then you +may avoid allocating it altogether. Just like for constructors. + +Looks cool, but probably rare...but it might be easy to implement. + + +Note [SpecConstr for casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a :: * + data instance T Int = T Int + + foo n = ... + where + go (T 0) = 0 + go (T n) = go (T (n-1)) + +The recursive call ends up looking like + go (T (I# ...) `cast` g) +So we want to spot the constructor application inside the cast. +That's why we have the Cast case in argToPat + +Note [Local recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a *local* recursive group, we can see all the calls to the +function, so we seed the specialisation loop from the calls in the +body, not from the calls in the RHS. Consider: + + bar m n = foo n (n,n) (n,n) (n,n) (n,n) + where + foo n p q r s + | n == 0 = m + | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s } + | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s } + | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s } + | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) } + +If we start with the RHSs of 'foo', we get lots and lots of specialisations, +most of which are not needed. But if we start with the (single) call +in the rhs of 'bar' we get exactly one fully-specialised copy, and all +the recursive calls go to this fully-specialised copy. Indeed, the original +function is later collected as dead code. This is very important in +specialising the loops arising from stream fusion, for example in NDP where +we were getting literally hundreds of (mostly unused) specialisations of +a local function. + +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +However, if we find any boring calls in the body, including *unsaturated* +ones, such as + letrec foo x y = ....foo... + in map foo xs +then we will end up calling the un-specialised function, so then we *should* +use the calls in the un-specialised RHS as seeds. We call these +"boring call patterns", and callsToPats reports if it finds any of these. + + +Note [Top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If all the bindings in a top-level recursive group are local (not +exported), then all the calls are in the rest of the top-level +bindings. This means we can specialise with those call patterns +instead of with the RHSs of the recursive group. + +(Question: maybe we should *also* use calls in the rest of the +top-level bindings as seeds? + +To get the call usage information, we work backwards through the +top-level bindings so we see the usage before we get to the binding of +the function. Before we can collect the usage though, we go through +all the bindings and add them to the environment. This is necessary +because usage is only tracked for functions in the environment. + +The actual seeding of the specialisation is very similar to Note [Local recursive group]. + + +Note [Do not specialise diverging functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Specialising a function that just diverges is a waste of code. +Furthermore, it broke GHC (simpl014) thus: + {-# STR Sb #-} + f = \x. case x of (a,b) -> f x +If we specialise f we get + f = \x. case x of (a,b) -> fspec a b +But fspec doesn't have decent strictness info. As it happened, +(f x) :: IO t, so the state hack applied and we eta expanded fspec, +and hence f. But now f's strictness is less than its arity, which +breaks an invariant. + + +Note [Forcing specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +With stream fusion and in other similar cases, we want to fully +specialise some (but not necessarily all!) loops regardless of their +size and the number of specialisations. + +We allow a library to do this, in one of two ways (one which is +deprecated): + + 1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body. + + 2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts, + and then add *that* type as a parameter to the loop body + +The reason #2 is deprecated is because it requires GHCi, which isn't +available for things like a cross compiler using stage1. + +Here's a (simplified) example from the `vector` package. You may bring +the special 'force specialization' type into scope by saying: + + import GHC.Types (SPEC(..)) + +or by defining your own type (again, deprecated): + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + +(Note this is the exact same definition of GHC.Types.SPEC, just +without the annotation.) + +After that, you say: + + foldl :: (a -> b -> a) -> a -> Stream b -> a + {-# INLINE foldl #-} + foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + +SpecConstr will spot the SPEC parameter and always fully specialise +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. + +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +sc_force to True when calling specLoop. This flag does four things: + * Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) + * Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) + * Specialise even for arguments that are not scrutinised in the loop + (see argToPat; Trac #4488) + * Only specialise on recursive types a finite number of times + (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation]) + +This flag is inherited for nested non-recursive bindings (which are likely to +be join points and hence should be fully specialised) but reset for nested +recursive bindings. + +What alternatives did I consider? Annotating the loop itself doesn't +work because (a) it is local and (b) it will be w/w'ed and having +w/w propagating annotations somehow doesn't seem like a good idea. The +types of the loop arguments really seem to be the most persistent +thing. + +Annotating the types that make up the loop state doesn't work, +either, because (a) it would prevent us from using types like Either +or tuples here, (b) we don't want to restrict the set of types that +can be used in Stream states and (c) some types are fixed by the user +(e.g., the accumulator here) but we still want to specialise as much +as possible. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it". But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' were strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn't strict +this doesn't look like a specialisable call. + +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of recursive constructors in each +function argument. If the maximum is greater than the specConstrRecursive limit, +do not specialise on that pattern. + +This is only necessary when ForceSpecConstr is on: otherwise the specConstrCount +will force termination anyway. + +See Trac #5550. + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type". It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray.) + +----------------------------------------------------- + Stuff not yet handled +----------------------------------------------------- + +Here are notes arising from Roman's work that I don't want to lose. + +Example 1 +~~~~~~~~~ + data T a = T !a + + foo :: Int -> T Int -> Int + foo 0 t = 0 + foo x t | even x = case t of { T n -> foo (x-n) t } + | otherwise = foo (x-1) t + +SpecConstr does no specialisation, because the second recursive call +looks like a boxed use of the argument. A pity. + + $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sFw = + \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) -> + case ww_sFo of ds_Xw6 [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] { + __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq; + 0 -> + case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] -> + case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] -> + $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy + } } }; + 0 -> 0 + +Example 2 +~~~~~~~~~ + data a :*: b = !a :*: !b + data T a = T !a + + foo :: (Int :*: T Int) -> Int + foo (0 :*: t) = 0 + foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) } + | otherwise = foo ((x-1) :*: t) + +Very similar to the previous one, except that the parameters are now in +a strict tuple. Before SpecConstr, we have + + $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int# + $wfoo_sG3 = + \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T + GHC.Base.Int) -> + case ww_sFU of ds_Xws [Just L] { + __DEFAULT -> + case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] { + __DEFAULT -> + case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1 + }; + 0 -> + case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] -> + case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] -> + $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2 + } } }; + 0 -> 0 } + +We get two specialisations: +"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB) + = Foo.$s$wfoo1 a_sFB sc_sGC ; +"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#} + Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp)) + = Foo.$s$wfoo y_aFp sc_sGC ; + +But perhaps the first one isn't good. After all, we know that tpl_B2 is +a T (I# x) really, because T is strict and Int has one constructor. (We can't +unbox the strict fields, because T is polymorphic!) + +************************************************************************ +* * +\subsection{Top level wrapper stuff} +* * +************************************************************************ +-} + +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do + dflags <- getDynFlags + us <- getUniqueSupplyM + annos <- getFirstAnnotations deserializeWithData guts + let binds' = reverse $ fst $ initUs us $ do + -- Note [Top-level recursive groups] + (env, binds) <- goEnv (initScEnv dflags annos) (mg_binds guts) + go env nullUsage (reverse binds) + + return (guts { mg_binds = binds' }) + where + goEnv env [] = return (env, []) + goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind + (env'', binds') <- goEnv env' binds + return (env'', bind' : binds') + + go _ _ [] = return [] + go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind + binds' <- go env usg' binds + return (bind' : binds') + +{- +************************************************************************ +* * +\subsection{Environment: goes downwards} +* * +************************************************************************ + +Note [Work-free values only in environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, so +that if we come across (case x of Just y ->...) we can reduce the +case from knowing that x is bound to a pair. + +But only *work-free* values are ok here. For example if the envt had + x -> Just (expensive v) +then we do NOT want to expand to + let y = expensive v in ... +because the x-binding still exists and we've now duplicated (expensive v). + +This seldom happens because let-bound constructor applications are +ANF-ised, but it can happen as a result of on-the-fly transformations in +SpecConstr itself. Here is Trac #7865: + + let { + a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=] ds_dgu [Dmd=] -> + (expensive x_af7, x_af7 + } } in + let { + ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + +When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) +and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. +(There are other occurrences of a'_shr.) No no no. + +It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned +into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) +but that's more work, so until its shown to be important I'm going to +leave it for now. +-} + +data ScEnv = SCE { sc_dflags :: DynFlags, + sc_size :: Maybe Int, -- Size threshold + sc_count :: Maybe Int, -- Max # of specialisations for any one fn + -- See Note [Avoiding exponential blowup] + + sc_recursive :: Int, -- Max # of specialisations over recursive type. + -- Stops ForceSpecConstr from diverging. + + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] + + sc_subst :: Subst, -- Current substitution + -- Maps InIds to OutExprs + + sc_how_bound :: HowBoundEnv, + -- Binds interesting non-top-level variables + -- Domain is OutVars (*after* applying the substitution) + + sc_vals :: ValueEnv, + -- Domain is OutIds (*after* applying the substitution) + -- Used even for top-level bindings (but not imported ones) + -- The range of the ValueEnv is *work-free* values + -- such as (\x. blah), or (Just v) + -- but NOT (Just (expensive v)) + -- See Note [Work-free values only in environment] + + sc_annotations :: UniqFM SpecConstrAnnotation + } + +--------------------- +-- As we go, we apply a substitution (sc_subst) to the current term +type InExpr = CoreExpr -- _Before_ applying the subst +type InVar = Var + +type OutExpr = CoreExpr -- _After_ applying the subst +type OutId = Id +type OutVar = Var + +--------------------- +type HowBoundEnv = VarEnv HowBound -- Domain is OutVars + +--------------------- +type ValueEnv = IdEnv Value -- Domain is OutIds +data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors + -- The AltCon is never DEFAULT + | LambdaVal -- Inlinable lambdas or PAPs + +instance Outputable Value where + ppr (ConVal con args) = ppr con <+> interpp'SP args + ppr LambdaVal = ptext (sLit "") + +--------------------- +initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv +initScEnv dflags anns + = SCE { sc_dflags = dflags, + sc_size = specConstrThreshold dflags, + sc_count = specConstrCount dflags, + sc_recursive = specConstrRecursive dflags, + sc_force = False, + sc_subst = emptySubst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, + sc_annotations = anns } + +data HowBound = RecFun -- These are the recursive functions for which + -- we seek interesting call patterns + + | RecArg -- These are those functions' arguments, or their sub-components; + -- we gather occurrence information for these + +instance Outputable HowBound where + ppr RecFun = text "RecFun" + ppr RecArg = text "RecArg" + +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + +lookupHowBound :: ScEnv -> Id -> Maybe HowBound +lookupHowBound env id = lookupVarEnv (sc_how_bound env) id + +scSubstId :: ScEnv -> Id -> CoreExpr +scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v + +scSubstTy :: ScEnv -> Type -> Type +scSubstTy env ty = substTy (sc_subst env) ty + +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + +zapScSubst :: ScEnv -> ScEnv +zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } + +extendScInScope :: ScEnv -> [Var] -> ScEnv + -- Bring the quantified variables into scope +extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars } + + -- Extend the substitution +extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv +extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr } + +extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv +extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs } + +extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv +extendHowBound env bndrs how_bound + = env { sc_how_bound = extendVarEnvList (sc_how_bound env) + [(bndr,how_bound) | bndr <- bndrs] } + +extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrsWith how_bound env bndrs + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs') + where + (subst', bndrs') = substBndrs (sc_subst env) bndrs + hb_env' = sc_how_bound env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs'] + +extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var) +extendBndrWith how_bound env bndr + = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound + +extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') + where + (subst', bndrs') = substRecBndrs (sc_subst env) bndrs + +extendBndr :: ScEnv -> Var -> (ScEnv, Var) +extendBndr env bndr = (env { sc_subst = subst' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr + +extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv +extendValEnv env _ Nothing = env +extendValEnv env id (Just cv) + | valueIsWorkFree cv -- Don't duplicate work!! Trac #7865 + = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env _ _ = env + +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) +-- When we encounter +-- case scrut of b +-- C x y -> ... +-- we want to bind b, to (C x y) +-- NB1: Extends only the sc_vals part of the envt +-- NB2: Kill the dead-ness info on the pattern binders x,y, since +-- they are potentially made alive by the [b -> C x y] binding +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') + where + live_case_bndr = not (isDeadBinder case_bndr) + env1 | Var v <- stripTicksTopE (const True) scrut + = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env1 case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + + cval = case con of + DEFAULT -> Nothing + LitAlt {} -> Just (ConVal con []) + DataAlt {} -> Just (ConVal con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + + +decreaseSpecCount :: ScEnv -> Int -> ScEnv +-- See Note [Avoiding exponential blowup] +decreaseSpecCount env n_specs + = env { sc_count = case sc_count env of + Nothing -> Nothing + Just n -> Just (n `div` (n_specs + 1)) } + -- The "+1" takes account of the original function; + -- See Note [Avoiding exponential blowup] + +--------------------------------------------------- +-- See Note [Forcing specialisation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool +forceSpecBndr :: ScEnv -> Var -> Bool + +#ifndef GHCI +ignoreType _ _ = False +ignoreDataCon _ _ = False +#else /* GHCI */ + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case tyConAppTyCon_maybe ty of + Just tycon -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr +#endif /* GHCI */ + +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | Just ty' <- coreView ty = forceSpecArgTy env ty' + +forceSpecArgTy env ty + | Just (tycon, tys) <- splitTyConApp_maybe ty + , tycon /= funTyCon + = tyConName tycon == specTyConName +#ifdef GHCI + || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr +#endif + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False + +{- +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See Trac #4908 for the live example. + +Note [Avoiding exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_count field of the ScEnv says how many times we are prepared to +duplicate a single function. But we must take care with recursive +specialisations. Consider + + let $j1 = let $j2 = let $j3 = ... + in + ...$j3... + in + ...$j2... + in + ...$j1... + +If we specialise $j1 then in each specialisation (as well as the original) +we can specialise $j2, and similarly $j3. Even if we make just *one* +specialisation of each, because we also have the original we'll get 2^n +copies of $j3, which is not good. + +So when recursively specialising we divide the sc_count by the number of +copies we are making at this level, including the original. + + +************************************************************************ +* * +\subsection{Usage information: flows upwards} +* * +************************************************************************ +-} + +data ScUsage + = SCU { + scu_calls :: CallEnv, -- Calls + -- The functions are a subset of the + -- RecFuns in the ScEnv + + scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences + } -- The domain is OutIds + +type CallEnv = IdEnv [Call] +data Call = Call Id [CoreArg] ValueEnv + -- The arguments of the call, together with the + -- env giving the constructor bindings at the call site + -- We keep the function mainly for debug output + +instance Outputable Call where + ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) + +nullUsage :: ScUsage +nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } + +combineCalls :: CallEnv -> CallEnv -> CallEnv +combineCalls = plusVarEnv_C (++) + where +-- plus cs ds | length res > 1 +-- = pprTrace "combineCalls" (vcat [ ptext (sLit "cs:") <+> ppr cs +-- , ptext (sLit "ds:") <+> ppr ds]) +-- res +-- | otherwise = res +-- where +-- res = cs ++ ds + +combineUsage :: ScUsage -> ScUsage -> ScUsage +combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), + scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } + +combineUsages :: [ScUsage] -> ScUsage +combineUsages [] = nullUsage +combineUsages us = foldr1 combineUsage us + +lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) +lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs + = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, + [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) + +data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument + | UnkOcc -- Used in some unknown way + + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) -- How the sub-components are used + +type DataConEnv a = UniqFM a -- Keyed by DataCon + +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~~ +An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, +is *only* taken apart or applied. + + Functions, literal: ScrutOcc emptyUFM + Data constructors: ScrutOcc subs, + +where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, +The domain of the UniqFM is the Unique of the data constructor + +The [ArgOcc] is the occurrences of the *pattern-bound* components +of the data structure. E.g. + data T a = forall b. MkT a b (b->a) +A pattern binds b, x::a, y::b, z::b->a, but not 'a'! + +-} + +instance Outputable ArgOcc where + ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs + ppr UnkOcc = ptext (sLit "unk-occ") + ppr NoOcc = ptext (sLit "no-occ") + +evalScrutOcc :: ArgOcc +evalScrutOcc = ScrutOcc emptyUFM + +-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so +-- that if the thing is scrutinised anywhere then we get to see that +-- in the overall result, even if it's also used in a boxed way +-- This might be too agressive; see Note [Reboxing] Alternative 3 +combineOcc :: ArgOcc -> ArgOcc -> ArgOcc +combineOcc NoOcc occ = occ +combineOcc occ NoOcc = occ +combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs +combineOcc UnkOcc UnkOcc = UnkOcc + +combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] +combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys + +setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage +-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee +-- is a variable, and an interesting variable +setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Tick _ e) occ = setScrutOcc env usg e occ +setScrutOcc env usg (Var v) occ + | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ } + | otherwise = usg +setScrutOcc _env usg _other _occ -- Catch-all + = usg + +{- +************************************************************************ +* * +\subsection{The main recursive function} +* * +************************************************************************ + +The main recursive function gathers up usage information, and +creates specialised versions of functions. +-} + +scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) + -- The unique supply is needed when we invent + -- a new name for the specialised function and its args + +scExpr env e = scExpr' env e + + +scExpr' env (Var v) = case scSubstId env v of + Var v' -> return (mkVarUsage env v' [], Var v') + e' -> scExpr (zapScSubst env) e' + +scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) +scExpr' _ e@(Lit {}) = return (nullUsage, e) +scExpr' env (Tick t e) = do (usg, e') <- scExpr env e + return (usg, Tick t e') +scExpr' env (Cast e co) = do (usg, e') <- scExpr env e + return (usg, mkCast e' (scSubstCo env co)) + -- Important to use mkCast here + -- See Note [SpecConstr call patterns] +scExpr' env e@(App _ _) = scApp env (collectArgs e) +scExpr' env (Lam b e) = do let (env', b') = extendBndr env b + (usg, e') <- scExpr env' e + return (usg, Lam b' e') + +scExpr' env (Case scrut b ty alts) + = do { (scrut_usg, scrut') <- scExpr env scrut + ; case isValue (sc_vals env) scrut' of + Just (ConVal con args) -> sc_con_app con args scrut' + _other -> sc_vanilla scrut_usg scrut' + } + where + sc_con_app con args scrut' -- Known constructor; simplify + = do { let (_, bs, rhs) = findAlt con alts + `orElse` (DEFAULT, [], mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + ; scExpr alt_env' rhs } + + sc_vanilla scrut_usg scrut' -- Normal case + = do { let (alt_env,b') = extendBndrWith RecArg env b + -- Record RecArg for the components + + ; (alt_usgs, alt_occs, alts') + <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts + + ; let scrut_occ = foldr combineOcc NoOcc alt_occs + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + -- The combined usage of the scrutinee is given + -- by scrut_occ, which is passed to scScrut, which + -- in turn treats a bare-variable scrutinee specially + + ; return (foldr combineUsage scrut_usg' alt_usgs, + Case scrut' b' (scSubstTy env ty) alts') } + + sc_alt env scrut' b' (con,bs,rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) + scrut_occ = case con of + DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) + _ -> ScrutOcc emptyUFM + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } + +scExpr' env (Let (NonRec bndr rhs) body) + | isTyVar bndr -- Type-lets may be created by doBeta + = scExpr' (extendScSubst env bndr rhs) body + + | otherwise + = do { let (body_env, bndr') = extendBndr env bndr + ; rhs_info <- scRecRhs env (bndr',rhs) + + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + -- Note [Local let bindings] + rhs' = ri_new_rhs rhs_info + body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') + + ; (body_usg, body') <- scExpr body_env3 body + + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + ; (spec_usg, specs) <- specNonRec env body_usg rhs_info + + ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } + `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] + mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') + } + + +-- A *local* recursive group: see Note [Local recursive groups] +scExpr' env (Let (Rec prs) body) + = do { let (bndrs,rhss) = unzip prs + (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + force_spec = any (forceSpecBndr env) bndrs' + -- Note [Forcing specialisation] + + ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; (body_usg, body') <- scExpr rhs_env2 body + + -- NB: start specLoop from body_usg + ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) + body_usg rhs_infos + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Local recursive groups] + + ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] + bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) + + ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, + Let bind' body') } + +{- +Note [Local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. + +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. +-} + +scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) + +scApp env (Var fn, args) -- Function is a variable + = ASSERT( not (null args) ) + do { args_w_usgs <- mapM (scExpr env) args + ; let (arg_usgs, args') = unzip args_w_usgs + arg_usg = combineUsages arg_usgs + ; case scSubstId env fn of + fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') + -- Do beta-reduction and try again + + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args') + + other_fn' -> return (arg_usg, mkApps other_fn' args') } + -- NB: doing this ignores any usage info from the substituted + -- function, but I don't think that matters. If it does + -- we can fix it. + where + doBeta :: OutExpr -> [OutExpr] -> OutExpr + -- ToDo: adjust for System IF + doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) + doBeta fn args = mkApps fn args + +-- The function is almost always a variable, but not always. +-- In particular, if this pass follows float-in, +-- which it may, we can get +-- (let f = ...f... in f) arg1 arg2 +scApp env (other_fn, args) + = do { (fn_usg, fn') <- scExpr env other_fn + ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } + +---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + -- I rather think we could use UnkOcc all the time + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- +scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) +scTopBindEnv env (Rec prs) + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs RecFun + + prs' = zip bndrs' rhss + ; return (rhs_env2, Rec prs') } + where + (bndrs,rhss) = unzip prs + +scTopBindEnv env (NonRec bndr rhs) + = do { let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) + ; return (env2, NonRec bndr' rhs) } + +---------------------- +scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) + +{- +scTopBind _ usage _ + | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False + = error "false" +-} + +scTopBind env body_usage (Rec prs) + | Just threshold <- sc_size env + , not force_spec + , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) + -- No specialisation + = do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } + + | otherwise -- Do specialisation + = do { rhs_infos <- mapM (scRecRhs env) prs + + ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) + body_usage rhs_infos + + ; return (body_usage `combineUsage` spec_usage, + Rec (concat (zipWith specInfoBinds rhs_infos specs))) } + where + (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs + -- Note [Forcing specialisation] + +scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions + = do { (rhs_usg', rhs') <- scExpr env rhs + ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } + +---------------------- +scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo +scRecRhs env (bndr,rhs) + = do { let (arg_bndrs,body) = collectBinders rhs + (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + ; (body_usg, body') <- scExpr body_env body + ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' + ; return (RI { ri_rhs_usg = rhs_usg + , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' + , ri_lam_bndrs = arg_bndrs, ri_lam_body = body + , ri_arg_occs = arg_occs }) } + -- The arg_occs says how the visible, + -- lambda-bound binders of the RHS are used + -- (including the TyVar binders) + -- Two pats are the same if they match both ways + +---------------------- +specInfoBinds :: RhsInfo -> [OneSpec] -> [(Id,CoreExpr)] +specInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) specs + = [(id,rhs) | OS _ _ id rhs <- specs] ++ + -- First the specialised bindings + + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding + where + rules = [r | OS _ r _ _ <- specs] + +{- +************************************************************************ +* * + The specialiser itself +* * +************************************************************************ +-} + +data RhsInfo + = RI { ri_fn :: OutId -- The binder + , ri_new_rhs :: OutExpr -- The specialised RHS (in current envt) + , ri_rhs_usg :: ScUsage -- Usage info from specialising RHS + + , ri_lam_bndrs :: [InVar] -- The *original* RHS (\xs.body) + , ri_lam_body :: InExpr -- Note [Specialise original body] + , ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body + } + +data SpecInfo = SI [OneSpec] -- The specialisations we have generated + + Int -- Length of specs; used for numbering them + + (Maybe ScUsage) -- Just cs => we have not yet used calls in the + -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Local recursive groups] + -- See Note [spec_usg includes rhs_usg] + + -- One specialisation: Rule plus definition +data OneSpec = OS CallPat -- Call pattern that generated this specialisation + CoreRule -- Rule connecting original id with the specialisation + OutId OutExpr -- Spec id + its rhs + + +---------------------- +specNonRec :: ScEnv + -> ScUsage -- Body usage + -> RhsInfo -- Structure info usage info for un-specialised RHS + -> UniqSM (ScUsage, [OneSpec]) -- Usage from RHSs (specialised and not) + -- plus details of specialisations + +specNonRec env body_usg rhs_info + = do { (spec_usg, SI specs _ _) <- specialise env (scu_calls body_usg) + rhs_info + (SI [] 0 (Just (ri_rhs_usg rhs_info))) + ; return (spec_usg, specs) } + +---------------------- +specRec :: TopLevelFlag -> ScEnv + -> ScUsage -- Body usage + -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs + -> UniqSM (ScUsage, [[OneSpec]]) -- Usage from all RHSs (specialised and not) + -- plus details of specialisations + +specRec top_lvl env body_usg rhs_infos + = do { (spec_usg, spec_infos) <- go seed_calls nullUsage init_spec_infos + ; return (spec_usg, [ s | SI s _ _ <- spec_infos ]) } + where + (seed_calls, init_spec_infos) -- Note [Top-level recursive groups] + | isTopLevel top_lvl + , any (isExportedId . ri_fn) rhs_infos -- Seed from RHSs + = (calls_in_rhss, [SI [] 0 Nothing | _ <- rhs_infos]) + | otherwise -- Seed from body only + = (scu_calls body_usg, [SI [] 0 (Just (ri_rhs_usg ri)) | ri <- rhs_infos]) + + calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos + + -- Loop, specialising, until you get no new specialisations + go seed_calls usg_so_far spec_infos + | isEmptyVarEnv seed_calls + = return (usg_so_far, spec_infos) + | otherwise + = do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos + ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg + extra_usg = combineUsages extra_usg_s + all_usg = usg_so_far `combineUsage` extra_usg + ; go (scu_calls extra_usg) all_usg new_spec_infos } + +---------------------- +specialise + :: ScEnv + -> CallEnv -- Info on newly-discovered calls to this function + -> RhsInfo + -> SpecInfo -- Original RHS plus patterns dealt with + -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage + +-- See Note [spec_usg includes rhs_usg] + +-- Note: this only generates *specialised* bindings +-- The original binding is added by specInfoBinds +-- +-- Note: the rhs here is the optimised version of the original rhs +-- So when we make a specialised copy of the RHS, we're starting +-- from an RHS whose nested functions have been optimised already. + +specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs + , ri_lam_body = body, ri_arg_occs = arg_occs }) + spec_info@(SI specs spec_count mb_unspec) + | isBottomingId fn -- Note [Do not specialise diverging functions] + -- and do not generate specialisation seeds from its RHS + = return (nullUsage, spec_info) + + | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] + || null arg_bndrs -- Only specialise functions + = case mb_unspec of -- Behave as if there was a single, boring call + Just rhs_usg -> return (rhs_usg, SI specs spec_count Nothing) + -- See Note [spec_usg includes rhs_usg] + Nothing -> return (nullUsage, spec_info) + + | Just all_calls <- lookupVarEnv bind_calls fn + = -- pprTrace "specialise entry {" (ppr fn <+> ppr (length all_calls)) $ + do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls + + -- Bale out if too many specialisations + ; let n_pats = length pats + spec_count' = n_pats + spec_count + ; case sc_count env of + Just max | not (sc_force env) && spec_count' > max + -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for + then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 + return (nullUsage, spec_info) + else return (nullUsage, spec_info) + where + msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) + , nest 2 (ptext (sLit "has") <+> + speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+> + ptext (sLit "but the limit is") <+> int max) ] + , ptext (sLit "Use -fspec-constr-count=n to set the bound") + , extra ] + extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations") + | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) + + _normal_case -> do { + +-- ; if (not (null pats) || isJust mb_unspec) then +-- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , text "good pats" <+> ppr pats]) $ +-- return () +-- else return () + + ; let spec_env = decreaseSpecCount env n_pats + ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) + (pats `zip` [spec_count..]) + -- See Note [Specialise original body] + + ; let spec_usg = combineUsages spec_usgs + + -- If there were any boring calls among the seeds (= all_calls), then those + -- calls will call the un-specialised function. So we should use the seeds + -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning + -- then in new_usg. + (new_usg, mb_unspec') + = case mb_unspec of + Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) + +-- ; pprTrace "specialise return }" (ppr fn +-- <+> ppr (scu_calls new_usg)) + ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } } + + + | otherwise -- No new seeds, so return nullUsage + = return (nullUsage, spec_info) + + +--------------------- +spec_one :: ScEnv + -> OutId -- Function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function + -> (CallPat, Int) + -> UniqSM (ScUsage, OneSpec) -- Rule and binding + +-- spec_one creates a specialised copy of the function, together +-- with a rule for using it. I'm very proud of how short this +-- function is, considering what it does :-). + +{- + Example + + In-scope: a, x::a + f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))... + [c::*, v::(b,c) are presumably bound by the (...) part] + ==> + f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] -> + (...entire body of f...) [b -> (b,c), + y -> ((:) (a,(b,c)) (x,v) hw)] + + RULE: forall b::* c::*, -- Note, *not* forall a, x + v::(b,c), + hw::[(a,(b,c))] . + + f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw +-} + +spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) + = do { spec_uniq <- getUniqueM + ; let spec_env = extendScSubstList (extendScInScope env qvars) + (arg_bndrs `zip` pats) + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ + -- We use fn_occ rather than fn in the rule_name string + -- as we don't want the uniq to end up in the rule, and + -- hence in the ABI, as that can cause spurious ABI + -- changes (#4012). + rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) + spec_name = mkInternalName spec_uniq spec_occ fn_loc +-- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- return () + + -- Specialise the body + ; (spec_usg, spec_body) <- scExpr spec_env body + +-- ; pprTrace "done spec_one}" (ppr fn) $ +-- return () + + -- And build the results + ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) + -- See Note [Transfer strictness] + `setIdStrictness` spec_str + `setIdArity` count isId spec_lam_args + spec_str = calcSpecStrictness fn spec_lam_args pats + -- Conditionally use result of new worker-wrapper transform + (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) qvars NoOneShotInfo body_ty + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted type and no args + + spec_rhs = mkLams spec_lam_args spec_body + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + rule = mkRule True {- Auto -} True {- Local -} + rule_name inline_act fn_name qvars pats rule_rhs + -- See Note [Transfer activation] + ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } + +calcSpecStrictness :: Id -- The original function + -> [Var] -> [CoreExpr] -- Call pattern + -> StrictSig -- Strictness of specialised thing +-- See Note [Transfer strictness] +calcSpecStrictness fn qvars pats + = mkClosedStrictSig spec_dmds topRes + where + spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + StrictSig (DmdType _ dmds _) = idStrictness fn + + dmd_env = go emptyVarEnv dmds pats + + go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv + go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats + go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats + go env _ _ = env + + go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv + go_one env d (Var v) = extendVarEnv_C bothDmd env v d + go_one env d e + | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict + , (Var _, args) <- collectArgs e = go env ds args + go_one env _ _ = env + +{- +Note [spec_usg includes rhs_usg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In calls to 'specialise', the returned ScUsage must include the rhs_usg in +the passed-in SpecInfo, unless there are no calls at all to the function. + +The caller can, indeed must, assume this. He should not combine in rhs_usg +himself, or he'll get rhs_usg twice -- and that can lead to an exponential +blowup of duplicates in the CallEnv. This is what gave rise to the massive +performace loss in Trac #8852. + +Note [Specialise original body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RhsInfo for a binding keeps the *original* body of the binding. We +must specialise that, *not* the result of applying specExpr to the RHS +(which is also kept in RhsInfo). Otherwise we end up specialising a +specialised RHS, and that can lead directly to exponential behaviour. + +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + This note is for SpecConstr, but exactly the same thing + happens in the overloading specialiser; see + Note [Auto-specialisation and RULES] in Specialise. + +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in Phase 0; after all, currently, the specConstr transformation is +only run after the simplifier has reached Phase 0, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialiation RULE, just like the main specialiser; + +This in turn means there is no point in specialising NOINLINE things, +so we test for that. + +Note [Transfer strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer strictness information from the original function to +the specialised one. Suppose, for example + + f has strictness SS + and a RULE f (a:as) b = f_spec a as b + +Now we want f_spec to have strictness LLS, otherwise we'll use call-by-need +when calling f_spec instead of call-by-value. And that can result in +unbounded worsening in space (cf the classic foldl vs foldl') + +See Trac #3437 for a good example. + +The function calcSpecStrictness performs the calculation. + + +************************************************************************ +* * +\subsection{Argument analysis} +* * +************************************************************************ + +This code deals with analysing call-site arguments to see whether +they are constructor applications. + +Note [Free type variables of the qvar types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a call (f @a x True), that we want to specialise, what variables should +we quantify over. Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them because (f @a) +can only be a well-typed application if its type is compatible with x, so any +variables free in x's type must be free in (f @a), and hence either be gathered +via 'a' itself, or be in scope at f's defn. Hence we just take + (exprsFreeVars pats). + +BUT phantom type synonyms can mess this reasoning up, + eg x::T b with type T b = Int +So we apply expandTypeSynonyms to the bound Ids. +See Trac # 5458. Yuk. + +Note [SpecConstr call patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "call patterns" that we collect is going to become the LHS of a RULE. +It's important that it doesn't have + e |> Refl +or + e |> g1 |> g2 +because both of these will be optimised by Simplify.simplRule. In the +former case such optimisation benign, because the rule will match more +terms; but in the latter we may lose a binding of 'g1' or 'g2', and +end up with a rule LHS that doesn't bind the template variables +(Trac #10602). + +The simplifier eliminates such things, but SpecConstr itself constructs +new terms by substituting. So the 'mkCast' in the Cast case of scExpr +is very important! +-} + +type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments + -- See Note [SpecConstr call patterns] + +callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat]) + -- Result has no duplicate patterns, + -- nor ones mentioned in done_pats + -- Bool indicates that there was at least one boring pattern +callsToPats env done_specs bndr_occs calls + = do { mb_pats <- mapM (callToPats env bndr_occs) calls + + ; let good_pats :: [(CallPat, ValueEnv)] + good_pats = catMaybes mb_pats + done_pats = [p | OS p _ _ _ <- done_specs] + is_done p = any (samePat p) done_pats + no_recursive = map fst (filterOut (is_too_recursive env) good_pats) + + ; return (any isNothing mb_pats, + filterOut is_done (nubBy samePat no_recursive)) } + +is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool + -- Count the number of recursive constructors in a call pattern, + -- filter out if there are more than the maximum. + -- This is only necessary if ForceSpecConstr is in effect: + -- otherwise specConstrCount will cause specialisation to terminate. + -- See Note [Limit recursive specialisation] +is_too_recursive env ((_,exprs), val_env) + = sc_force env && maximum (map go exprs) > sc_recursive env + where + go e + | Just (ConVal (DataAlt dc) args) <- isValue val_env e + , isRecursiveTyCon (dataConTyCon dc) + = 1 + sum (map go args) + + |App f a <- e + = go f + go a + + | otherwise + = 0 + +callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe (CallPat, ValueEnv)) + -- The [Var] is the variables to quantify over in the rule + -- Type variables come first, since they may scope + -- over the following term variables + -- The [CoreExpr] are the argument patterns for the rule +callToPats env bndr_occs (Call _ args con_env) + | length args < length bndr_occs -- Check saturated + = return Nothing + | otherwise + = do { let in_scope = substInScope (sc_subst env) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = varSetElems (exprsFreeVars pats) + in_scope_vars = getInScopeVars in_scope + qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs + -- Quantify over variables that are not in scope + -- at the call site + -- See Note [Free type variables of the qvar types] + -- See Note [Shadowing] at the top + + (tvs, ids) = partition isTyVar qvars + qvars' = tvs ++ map sanitise ids + -- Put the type variables first; the type of a term + -- variable may mention a type variable + + sanitise id = id `setIdType` expandTypeSynonyms (idType id) + -- See Note [Free type variables of the qvar types] + + ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ + if interesting + then return (Just ((qvars', pats), con_env)) + else return Nothing } + + -- argToPat takes an actual argument, and returns an abstracted + -- version, consisting of just the "constructor skeleton" of the + -- argument, with non-constructor sub-expression replaced by new + -- placeholder variables. For example: + -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) + +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site + -> ValueEnv -- ValueEnv at the call site + -> CoreArg -- A call arg (or component thereof) + -> ArgOcc + -> UniqSM (Bool, CoreArg) + +-- Returns (interesting, pat), +-- where pat is the pattern derived from the argument +-- interesting=True if the pattern is non-trivial (not a variable or type) +-- E.g. x:xs --> (True, x:xs) +-- f xs --> (False, w) where w is a fresh wildcard +-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard +-- \x. x+y --> (True, \x. x+y) +-- lvl7 --> (True, lvl7) if lvl7 is bound +-- somewhere further out + +argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ + = return (False, arg) + +argToPat env in_scope val_env (Tick _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- Note [Notes in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Notes in RULE matching] in Rules + +argToPat env in_scope val_env (Let _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- See Note [Matching lets] in Rule.lhs + -- Look through let expressions + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) + -- because the rule-matcher will look through the let. + +{- Disabled; see Note [Matching cases] in Rule.lhs +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs + = argToPat env in_scope val_env rhs arg_occ +-} + +argToPat env in_scope val_env (Cast arg co) arg_occ + | not (ignoreType env ty2) + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ + ; if not interesting then + wildCardPat ty2 + else do + { -- Make a wild-card pattern for the coercion + uniq <- getUniqueM + ; let co_name = mkSysTvName uniq (fsLit "sg") + co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + where + Pair ty1 ty2 = coercionKind co + + + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + + -- Check for a constructor application + -- NB: this *precedes* the Var case, so that we catch nullary constrs +argToPat env in_scope val_env arg arg_occ + | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs + ; return (True, + mkConApp dc (ty_args ++ args')) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs + | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env -> Just (repeat UnkOcc) + | otherwise -> Nothing + + -- Check if the argument is a variable that + -- (a) is used in an interesting way in the body + -- (b) we know what its value is + -- In that case it counts as "interesting" +argToPat env in_scope val_env (Var v) arg_occ + | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) + is_value, -- (b) + not (ignoreType env (varType v)) + = return (True, Var v) + where + is_value + | isLocalId v = v `elemInScopeSet` in_scope + && isJust (lookupVarEnv val_env v) + -- Local variables have values in val_env + | otherwise = isValueUnfolding (idUnfolding v) + -- Imports have unfoldings + +-- I'm really not sure what this comment means +-- And by not wild-carding we tend to get forall'd +-- variables that are in scope, which in turn can +-- expose the weakness in let-matching +-- See Note [Matching lets] in Rules + + -- Check for a variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! +-- argToPat _in_scope _val_env (Var v) _arg_occ +-- = return (False, Var v) + -- SLPJ : disabling this to avoid proliferation of versions + -- also works badly when thinking about seeding the loop + -- from the body of the let + -- f x y = letrec g z = ... in g (x,y) + -- We don't want to specialise for that *particular* x,y + + -- The default case: make a wild-card + -- We use this for coercions too +argToPat _env _in_scope _val_env arg _arg_occ + = wildCardPat (exprType arg) + +wildCardPat :: Type -> UniqSM (Bool, CoreArg) +wildCardPat ty + = do { uniq <- getUniqueM + ; let id = mkSysLocal (fsLit "sc") uniq ty + ; return (False, varToCoreExpr id) } + +argsToPats :: ScEnv -> InScopeSet -> ValueEnv + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) +argsToPats env in_scope val_env args occs + = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs + ; let (interesting_s, args') = unzip stuff + ; return (or interesting_s, args') } + +isValue :: ValueEnv -> CoreExpr -> Maybe Value +isValue _env (Lit lit) + | litIsLifted lit = Nothing + | otherwise = Just (ConVal (LitAlt lit) []) + +isValue env (Var v) + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point + + | not (isLocalId v) && isCheapUnfolding unf + = isValue env (unfoldingTemplate unf) + where + unf = idUnfolding v + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! + +isValue env (Lam b e) + | isTyVar b = case isValue env e of + Just _ -> Just LambdaVal + Nothing -> Nothing + | otherwise = Just LambdaVal + +isValue env (Tick t e) + | not (tickishIsCode t) + = isValue env e + +isValue _env expr -- Maybe it's a constructor application + | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr + = case isDataConWorkId_maybe fun of + + Just con | args `lengthAtLeast` dataConRepArity con + -- Check saturated; might be > because the + -- arity excludes type args + -> Just (ConVal (DataAlt con) args) + + _other | valArgCount args < idArity fun + -- Under-applied function + -> Just LambdaVal -- Partial application + + _other -> Nothing + +isValue _env _expr = Nothing + +valueIsWorkFree :: Value -> Bool +valueIsWorkFree LambdaVal = True +valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args + +samePat :: CallPat -> CallPat -> Bool +samePat (vs1, as1) (vs2, as2) + = all2 same as1 as2 + where + same (Var v1) (Var v2) + | v1 `elem` vs1 = v2 `elem` vs2 + | v2 `elem` vs2 = False + | otherwise = v1 == v2 + + same (Lit l1) (Lit l2) = l1==l2 + same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 + + same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True + same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes + same (Cast e1 _) e2 = same e1 e2 + same e1 (Tick _ e2) = same e1 e2 + same e1 (Cast e2 _) = same e1 e2 + + same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) + False -- Let, lambda, case should not occur + bad (Case {}) = True + bad (Let {}) = True + bad (Lam {}) = True + bad _other = False + +{- +Note [Ignore type differences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to generate specialisations where the call patterns +differ only in their type arguments! Not only is it utterly useless, +but it also means that (with polymorphic recursion) we can generate +an infinite number of specialisations. Example is Data.Sequence.adjustTree, +I think. +-} diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs new file mode 100644 index 00000000..473f86ff --- /dev/null +++ b/compiler/specialise/Specialise.hs @@ -0,0 +1,2143 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} +-} + +{-# LANGUAGE CPP #-} +module Specialise ( specProgram, specUnfolding ) where + +#include "HsVersions.h" + +import Id +import TcType hiding( substTy, extendTvSubstList ) +import Type hiding( substTy, extendTvSubstList ) +import Coercion( Coercion ) +import Module( Module ) +import CoreMonad +import qualified CoreSubst +import CoreUnfold +import VarSet +import VarEnv +import CoreSyn +import Rules +import PprCore ( pprParendExpr ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) +import UniqSupply +import Name +import MkId ( voidArgId, voidPrimId ) +import Maybes ( catMaybes, isJust ) +import BasicTypes +import HscTypes +import Bag +import DynFlags +import Util +import Outputable +import FastString +import State + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map + +{- +************************************************************************ +* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +* * +************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading. + +The specialisation pass works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result. However we don't actually *do* that +simplification. Rather, we leave it for the simplifier to do. If we +*did* do it, though, we'd get more call instances from the specialised +RHS. We can work out what they are by instantiating the call-instance +set from f's RHS with the types t1, t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recusion for non-overloaded functions which we +speciailise, but the recursive call should get specialised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated ouside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instancing the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +We do this. + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. Solution: float dictionary bindings +outwards along with call instances. + +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialision has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Still, there's no actual problem; it just means that we may not do all +the specialisation we could theoretically do. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + +*** Not currently done *** + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifer +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + +All this uses a single mechanism: the SpecEnv inside an Id + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The SpecEnv of an Id maps a list of types (the template) to an expression + + [Type] |-> Expr + +For example, if f has this SpecInfo: + + [Int, a] -> \d:Ord Int. f' a + +it means that we can replace the call + + f Int t ===> (\d. f' t) + +This chucks one dictionary away and proceeds with the +specialised version of f, namely f'. + + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguments with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f :: Eq [(a,b)] => ... + + +************************************************************************ +* * +\subsubsection{The new specialiser} +* * +************************************************************************ + +Our basic game plan is this. For let(rec) bound function + f :: (C a, D c) => (a,b,c,d) -> Bool + +* Find any specialised calls of f, (f ts ds), where + ts are the type arguments t1 .. t4, and + ds are the dictionary arguments d1 .. d2. + +* Add a new definition for f1 (say): + + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + + Note that we abstract over the unconstrained type arguments. + +* Add the mapping + + [t1,b,t3,d] |-> \d1 d2 -> f1 b d + + to the specialisations of f. This will be used by the + simplifier to replace calls + (f t1 t2 t3 t4) da db + by + (\d1 d1 -> f1 t2 t4) da db + + All the stuff about how many dictionaries to discard, and what types + to apply the specialised function to, are handled by the fact that the + SpecEnv contains a template for the result of the specialisation. + +We don't build *partial* specialisations for f. For example: + + f :: Eq a => a -> a -> Bool + {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} + +Here, little is gained by making a specialised copy of f. +There's a distinct danger that the specialised version would +first build a dictionary for (Eq b, Eq c), and then select the (==) +method from it! Even if it didn't, not a great deal is saved. + +We do, however, generate polymorphic, but not overloaded, specialisations: + + f :: Eq a => [a] -> b -> b -> b + ... SPECIALISE f :: [Int] -> b -> b -> b ... + +Hence, the invariant is this: + + *** no specialised version is overloaded *** + + +************************************************************************ +* * +\subsubsection{The exported function} +* * +************************************************************************ +-} + +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts@(ModGuts { mg_module = this_mod + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM dflags (go binds) + + -- Specialise imported functions + ; hpt_rules <- getRuleBase + ; let rule_base = extendRuleBaseList hpt_rules local_rules + ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet rule_base uds + + ; let final_binds | null spec_binds = binds' + | otherwise = Rec (flattenBinds spec_binds) : binds' + -- Note [Glom the bindings if imported functions are specialised] + + ; return (guts { mg_binds = final_binds + , mg_rules = new_rules ++ local_rules }) } + where + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_subst = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $ + bindersOfBinds binds + , se_interesting = emptyVarSet } + + go [] = return ([], emptyUDs) + go (bind:binds) = do (binds', uds) <- go binds + (bind', uds') <- specBind top_subst bind uds + return (bind' ++ binds', uds') + +specImports :: DynFlags + -> Module + -> VarSet -- Don't specialise these ones + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module and the home package + -- (but not external packages, which can change) + -> UsageDetails -- Calls for imported things, and floating bindings + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings and floating bindings +specImports dflags this_mod done rule_base uds + = do { let import_calls = varEnvElts (ud_calls uds) + ; (rules, spec_binds) <- go rule_base import_calls + ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) } + where + go _ [] = return ([], []) + go rb (CIS fn calls_for_fn : other_calls) + = do { (rules1, spec_binds1) <- specImport dflags this_mod done rb fn $ + Map.toList calls_for_fn + ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls + ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +specImport :: DynFlags + -> Module + -> VarSet -- Don't specialise these + -- See Note [Avoiding recursive specialisation] + -> RuleBase -- Rules from this module + -> Id -> [CallInfo] -- Imported function and calls for it + -> CoreM ( [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +specImport dflags this_mod done rb fn calls_for_fn + | fn `elemVarSet` done + = return ([], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function + + | null calls_for_fn -- We filtered out all the calls in deleteCallsMentioning + = return ([], []) + + | wantSpecImport dflags unfolding + , Just rhs <- maybeUnfoldingTemplate unfolding + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; hsc_env <- getHscEnv + ; eps <- liftIO $ hscEPS hsc_env + ; let full_rb = unionRuleBase rb (eps_rule_base eps) + rules_for_fn = getRules full_rb fn + + ; (rules1, spec_pairs, uds) <- runSpecM dflags $ + specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in we may get recursion, but + -- we rely on a global GlomBinds to sort that out later + -- See Note [Glom the bindings if imported functions are specialised] + + -- Now specialise any cascaded calls + ; (rules2, spec_binds2) <- -- pprTrace "specImport" (ppr fn $$ ppr uds $$ ppr rhs) $ + specImports dflags this_mod (extendVarSet done fn) + (extendRuleBaseList rb rules1) + uds + + ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) } + + | otherwise + = WARN( True, hang (ptext (sLit "specImport discarding:") <+> ppr fn <+> dcolon <+> ppr (idType fn)) + 2 ( (text "want:" <+> ppr (wantSpecImport dflags unfolding)) + $$ (text "stable:" <+> ppr (isStableUnfolding unfolding)) + $$ (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) ) ) + return ([], []) + where + unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers + +wantSpecImport :: DynFlags -> Unfolding -> Bool +-- See Note [Specialise imported INLINABLE things] +wantSpecImport dflags unf + = case unf of + NoUnfolding -> False + OtherCon {} -> False + DFunUnfolding {} -> True + CoreUnfolding { uf_src = src, uf_guidance = _guidance } + | gopt Opt_SpecialiseAggressively dflags -> True + | isStableSource src -> True + -- Specialise even INLINE things; it hasn't inlined yet, + -- so perhaps it never will. Moreover it may have calls + -- inside it that we want to specialise + | otherwise -> False -- Stable, not INLINE, hence INLINEABLE + +{- +Note [Specialise imported INLINABLE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What imported functions do we specialise? The basic set is + * DFuns and things with INLINABLE pragmas. +but with -fspecialise-aggressively we add + * Anything with an unfolding template + +Trac #8874 has a good example of why we want to auto-specialise DFuns. + +We have the -fspecialise-aggressively flag (usually off), because we +risk lots of orphan modules from over-vigorous specialisation. +However it's not a big deal: anything non-recursive with an +unfolding-template will probably have been inlined already. + +Note [Glom the bindings if imported functions are specialised] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an imported, *recursive*, INLINABLE function + f :: Eq a => a -> a + f = /\a \d x. ...(f a d)... +In the module being compiled we have + g x = f (x::Int) +Now we'll make a specialised function + f_spec :: Int -> Int + f_spec = \x -> ...(f Int dInt)... + {-# RULE f Int _ = f_spec #-} + g = \x. f Int dInt x +Note that f_spec doesn't look recursive +After rewriting with the RULE, we get + f_spec = \x -> ...(f_spec)... +BUT since f_spec was non-recursive before it'll *stay* non-recursive. +The occurrence analyser never turns a NonRec into a Rec. So we must +make sure that f_spec is recursive. Easiest thing is to make all +the specialisations for imported bindings recursive. + + +Note [Avoiding recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is the reason for the +'done' VarSet passed to specImports and specImport. + +************************************************************************ +* * +\subsubsection{@specExpr@: the main function} +* * +************************************************************************ +-} + +data SpecEnv + = SE { se_subst :: CoreSubst.Subst + -- We carry a substitution down: + -- a) we must clone any binding that might float outwards, + -- to avoid name clashes + -- b) we carry a type substitution to use when analysing + -- the RHS of specialised bindings (no type-let!) + + + , se_interesting :: VarSet + -- Dict Ids that we know something about + -- and hence may be worth specialising against + -- See Note [Interesting dictionary arguments] + } + +emptySpecEnv :: SpecEnv +emptySpecEnv = SE { se_subst = CoreSubst.emptySubst, se_interesting = emptyVarSet} + +specVar :: SpecEnv -> Id -> CoreExpr +specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v + +specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) + +---------------- First the easy cases -------------------- +specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) +specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) +specExpr env (Var v) = return (specVar env v, emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) +specExpr env (Cast e co) + = do { (e', uds) <- specExpr env e + ; return ((Cast e' (substCo env co)), uds) } +specExpr env (Tick tickish body) + = do { (body', uds) <- specExpr env body + ; return (Tick (specTickish env tickish) body', uds) } + +---------------- Applications might generate a call instance -------------------- +specExpr env expr@(App {}) + = go expr [] + where + go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg + (fun', uds_app) <- go fun (arg':args) + return (App fun' arg', uds_arg `plusUDs` uds_app) + + go (Var f) args = case specVar env f of + Var f' -> return (Var f', mkCallUDs env f' args) + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr env other + +---------------- Lambda/case require dumping of usage details -------------------- +specExpr env e@(Lam _ _) = do + (body', uds) <- specExpr env' body + let (free_uds, dumped_dbs) = dumpUDs bndrs' uds + return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds) + where + (bndrs, body) = collectBinders e + (env', bndrs') = substBndrs env bndrs + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings + +specExpr env (Case scrut case_bndr ty alts) + = do { (scrut', scrut_uds) <- specExpr env scrut + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase env scrut' case_bndr alts + ; return (Case scrut'' case_bndr' (substTy env ty) alts' + , scrut_uds `plusUDs` alts_uds) } + +---------------- Finally, let is the interesting case -------------------- +specExpr env (Let bind body) + = do { -- Clone binders + (rhs_env, body_env, bind') <- cloneBindSM env bind + + -- Deal with the body + ; (body', body_uds) <- specExpr body_env body + + -- Deal with the bindings + ; (binds', uds) <- specBind rhs_env bind' body_uds + + -- All done + ; return (foldr Let body' binds', uds) } + +specTickish :: SpecEnv -> Tickish Id -> Tickish Id +specTickish env (Breakpoint ix ids) + = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] + -- drop vars from the list if they have a non-variable substitution. + -- should never happen, but it's harmless to drop them anyway. +specTickish _ other_tickish = other_tickish + +specCase :: SpecEnv + -> CoreExpr -- Scrutinee, already done + -> Id -> [CoreAlt] + -> SpecM ( CoreExpr -- New scrutinee + , Id + , [CoreAlt] + , UsageDetails) +specCase env scrut' case_bndr [(con, args, rhs)] + | isDictId case_bndr -- See Note [Floating dictionaries out of cases] + , interestingDict env scrut' + , not (isDeadBinder case_bndr && null sc_args') + = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') + + ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') + [(con, args', Var sc_arg')] + | sc_arg' <- sc_args' ] + + -- Extend the substitution for RHS to map the *original* binders + -- to their floated verions. + mb_sc_flts :: [Maybe DictId] + mb_sc_flts = map (lookupVarEnv clone_env) args' + clone_env = zipVarEnv sc_args' sc_args_flt + subst_prs = (case_bndr, Var case_bndr_flt) + : [ (arg, Var sc_flt) + | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] + env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs + , se_interesting = se_interesting env_rhs `extendVarSetList` + (case_bndr_flt : sc_args_flt) } + + ; (rhs', rhs_uds) <- specExpr env_rhs' rhs + ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') + case_bndr_set = unitVarSet case_bndr_flt + sc_binds = [(NonRec sc_arg_flt sc_rhs, case_bndr_set) + | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] + flt_binds = scrut_bind : sc_binds + (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds + all_uds = flt_binds `addDictBinds` free_uds + alt' = (con, args', wrapDictBindsE dumped_dbs rhs') + ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } + where + (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) + sc_args' = filter is_flt_sc_arg args' + + clone_me bndr = do { uniq <- getUniqueM + ; return (mkUserLocal occ uniq ty loc) } + where + name = idName bndr + ty = idType bndr + occ = nameOccName name + loc = getSrcSpan name + + arg_set = mkVarSet args' + is_flt_sc_arg var = isId var + && not (isDeadBinder var) + && isDictTy var_ty + && not (tyVarsOfType var_ty `intersectsVarSet` arg_set) + where + var_ty = idType var + + +specCase env scrut case_bndr alts + = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts + ; return (scrut, case_bndr', alts', uds_alts) } + where + (env_alt, case_bndr') = substBndr env case_bndr + spec_alt (con, args, rhs) = do + (rhs', uds) <- specExpr env_rhs rhs + let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds + return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds) + where + (env_rhs, args') = substBndrs env_alt args + +{- +Note [Floating dictionaries out of cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g = \d. case d of { MkD sc ... -> ...(f sc)... } +Naively we can't float d2's binding out of the case expression, +because 'sc' is bound by the case, and that in turn means we can't +specialise f, which seems a pity. + +So we invert the case, by floating out a binding +for 'sc_flt' thus: + sc_flt = case d of { MkD sc ... -> sc } +Now we can float the call instance for 'f'. Indeed this is just +what'll happen if 'sc' was originally bound with a let binding, +but case is more efficient, and necessary with equalities. So it's +good to work with both. + +You might think that this won't make any difference, because the +call instance will only get nuked by the \d. BUT if 'g' itself is +specialised, then transitively we should be able to specialise f. + +In general, given + case e of cb { MkD sc ... -> ...(f sc)... } +we transform to + let cb_flt = e + sc_flt = case cb_flt of { MkD sc ... -> sc } + in + case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } + +The "_flt" things are the floated binds; we use the current substitution +to substitute sc -> sc_flt in the RHS + +************************************************************************ +* * + Dealing with a binding +* * +************************************************************************ +-} + +specBind :: SpecEnv -- Use this for RHSs + -> CoreBind + -> UsageDetails -- Info on how the scope of the binding + -> SpecM ([CoreBind], -- New bindings + UsageDetails) -- And info to pass upstream + +-- Returned UsageDetails: +-- No calls for binders of this bind +specBind rhs_env (NonRec fn rhs) body_uds + = do { (rhs', rhs_uds) <- specExpr rhs_env rhs + ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs + + ; let pairs = spec_defns ++ [(fn', rhs')] + -- fn' mentions the spec_defns in its rules, + -- so put the latter first + + combined_uds = body_uds1 `plusUDs` rhs_uds + -- This way round a call in rhs_uds of a function f + -- at type T will override a call of f at T in body_uds1; and + -- that is good because it'll tend to keep "earlier" calls + -- See Note [Specialisation of dictionary functions] + + (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds + -- See Note [From non-recursive to recursive] + + final_binds :: [DictBind] + final_binds + | isEmptyBag dump_dbs = [mkDB $ NonRec b r | (b,r) <- pairs] + | otherwise = [flattenDictBinds dump_dbs pairs] + + ; if float_all then + -- Rather than discard the calls mentioning the bound variables + -- we float this binding along with the others + return ([], free_uds `snocDictBinds` final_binds) + else + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (map fst final_binds, free_uds) } + + +specBind rhs_env (Rec pairs) body_uds + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss + ; let scope_uds = body_uds `plusUDs` rhs_uds + -- Includes binds and calls arising from rhss + + ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs + + ; (bndrs3, spec_defns3, uds3) + <- if null spec_defns1 -- Common case: no specialisation + then return (bndrs1, [], uds1) + else do { -- Specialisation occurred; do it again + (bndrs2, spec_defns2, uds2) + <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) + ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } + + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 + bind = flattenDictBinds dumped_dbs + (spec_defns3 ++ zip bndrs3 rhss') + + ; if float_all then + return ([], final_uds `snocDictBind` bind) + else + return ([fst bind], final_uds) } + + +--------------------------- +specDefns :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([Id], -- Original Ids with RULES added + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _env uds [] + = return ([], [], uds) +specDefns env uds ((bndr,rhs):pairs) + = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs + ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs + ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } + +--------------------------- +specDefn :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> Id -> CoreExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +specDefn env body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me + calls_for_me fn rhs + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `plusUDs` spec_uds) } + -- It's important that the `plusUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Maybe Module -- Just this_mod => specialising imported fn + -- Nothing => specialising local fn + -> SpecEnv + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> Id -> CoreExpr + -> SpecM ([CoreRule], -- New RULES for the fn + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- New usage details from the specialised RHSs + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not need to do this filtering. +-- See 'already_covered' + +specCalls mb_mod env rules_for_me calls_for_me fn rhs + -- The first case is the interesting one + | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas + && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args + && notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] + +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisation] for why we do not +-- switch off specialisation for inline functions + + = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr rules_for_me) $ + do { stuff <- mapM spec_call calls_for_me + ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) + ; return (spec_rules, spec_defns, plusUDList spec_uds) } + + | otherwise -- No calls or RHS doesn't fit our preconceptions + = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, + ptext (sLit "Missed specialisation opportunity for") + <+> ppr fn $$ _trace_doc ) + -- Note [Specialisation shape] + -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ + return ([], [], emptyUDs) + where + _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars + , ppr rhs_ids, ppr n_dicts + , ppr (idInlineActivation fn) ] + + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + (tyvars, theta, _) = tcSplitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn + + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs + + rhs_dict_ids = take n_dicts rhs_ids + body = mkLams (drop n_dicts rhs_ids) rhs_body + -- Glue back on the non-dict lambdas + + already_covered :: DynFlags -> [CoreExpr] -> Bool + already_covered dflags args -- Note [Specialisations already covered] + = isJust (lookupRule dflags + (CoreSubst.substInScope (se_subst env), realIdUnfolding) + (const True) + fn args rules_for_me) + + mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] + mk_ty_args [] poly_tvs + = ASSERT( null poly_tvs ) [] + mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) + = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs + mk_ty_args (Just ty : call_ts) poly_tvs + = Type ty : mk_ty_args call_ts poly_tvs + mk_ty_args (Nothing : _) [] = panic "mk_ty_args" + + ---------------------------------------------------------- + -- Specialise to one particular call pattern + spec_call :: CallInfo -- Call instance + -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition + UsageDetails, -- Usage details from specialised body + CoreRule)) -- Info for the Id's SpecEnv + spec_call (CallKey call_ts, (call_ds, _)) + = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) + + -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs + -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] + + -- Construct the new binding + -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) + -- PLUS the usage-details + -- { d1' = dx1; d2' = dx2 } + -- where d1', d2' are cloned versions of d1,d2, with the type substitution + -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 + -- + -- Note that the substitution is applied to the whole thing. + -- This is convenient, but just slightly fragile. Notably: + -- * There had better be no name clashes in a/b/c + do { let + -- poly_tyvars = [b] in the example above + -- spec_tyvars = [a,c] + -- ty_args = [t1,b,t3] + spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] + env1 = extendTvSubstList env spec_tv_binds + (rhs_env, poly_tyvars) = substBndrs env1 + [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] + + -- Clone rhs_dicts, including instantiating their types + ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids + ; let (rhs_env2, dx_binds, spec_dict_args) + = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids + ty_args = mk_ty_args call_ts poly_tyvars + rule_args = ty_args ++ map Var inst_dict_ids + rule_bndrs = poly_tyvars ++ inst_dict_ids + + ; dflags <- getDynFlags + ; if already_covered dflags rule_args then + return Nothing + else do + { -- Figure out the type of the specialised function + let body_ty = applyTypeToArgs rhs fn_type rule_args + (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted + | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs + = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId]) + | otherwise = (poly_tyvars, poly_tyvars) + spec_id_ty = mkPiTypes lam_args body_ty + + ; spec_f <- newSpecIdSM fn spec_id_ty + ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body) + ; let + -- The rule to put in the function's specialisation is: + -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b + herald = case mb_mod of + Nothing -- Specialising local fn + -> ptext (sLit "SPEC") + Just this_mod -- Specialising imoprted fn + -> ptext (sLit "SPEC/") <> ppr this_mod + + rule_name = mkFastString $ showSDocForUser dflags neverQualify $ + herald <+> ppr fn <+> hsep (map ppr_call_key_ty call_ts) + -- This name ends up in interface files, so use showSDocForUser, + -- otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + + spec_env_rule = mkRule True {- Auto generated -} is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + rule_bndrs + rule_args + (mkVarApps (Var spec_f) app_args) + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + final_uds = foldr consDictBind rhs_uds dx_binds + + -------------------------------------- + -- Add a suitable unfolding if the spec_inl_prag says so + -- See Note [Inline specialisations] + (spec_inl_prag, spec_unf) + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = (neverInlinePragma, noUnfolding) + -- See Note [Specialising imported functions] in OccurAnal + + | InlinePragma { inl_inline = Inlinable } <- inl_prag + = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding) + + | otherwise + = (inl_prag, specUnfolding dflags (se_subst env) + poly_tyvars (ty_args ++ spec_dict_args) + fn_unf) + + -------------------------------------- + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_f + spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) + `setInlinePragma` spec_inl_prag + `setIdUnfolding` spec_unf + + ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } } + +bindAuxiliaryDicts + :: SpecEnv + -> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions + -> [DictId] -- A cloned dict-id for each dict arg + -> (SpecEnv, -- Substitute for all orig_dicts + [DictBind], -- Auxiliary dict bindings + [CoreExpr]) -- Witnessing expressions (all trivial) +-- Bind any dictionary arguments to fresh names, to preserve sharing +bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting }) + orig_dict_ids call_ds inst_dict_ids + = (env', dx_binds, spec_dict_args) + where + (dx_binds, spec_dict_args) = go call_ds inst_dict_ids + env' = env { se_subst = CoreSubst.extendIdSubstList subst (orig_dict_ids `zip` spec_dict_args) + , se_interesting = interesting `unionVarSet` interesting_dicts } + + interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds + , interestingDict env dx ] + -- See Note [Make the new dictionaries interesting] + + go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr]) + go [] _ = ([], []) + go (dx:dxs) (dx_id:dx_ids) + | exprIsTrivial dx = (dx_binds, dx:args) + | otherwise = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args) + where + (dx_binds, args) = go dxs dx_ids + -- In the first case extend the substitution but not bindings; + -- in the latter extend the bindings but not the substitution. + -- For the former, note that we bind the *original* dict in the substitution, + -- overriding any d->dx_id binding put there by substBndrs + go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids) + +{- +Note [Make the new dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Important! We're going to substitute dx_id1 for d +and we want it to look "interesting", else we won't gather *any* +consequential calls. E.g. + f d = ...g d.... +If we specialise f for a call (f (dfun dNumInt)), we'll get +a consequent call (g d') with an auxiliary definition + d' = df dNumInt +We want that consequent call to look interesting + + +Note [From non-recursive to recursive] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the non-recursive case, if any dict-binds depend on 'fn' we might +have built a recursive knot + + f a d x = + MkUD { ud_binds = d7 = MkD ..f.. + , ud_calls = ...(f T d7)... } + +The we generate + + Rec { fs x = [T/a, d7/d] + f a d x = + RULE f T _ = fs + d7 = ...f... } + +Here the recursion is only through the RULE. + + +Note [Specialisation of dictionary functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a nasty example that bit us badly: see Trac #3591 + + class Eq a => C a + instance Eq [a] => C [a] + +--------------- + dfun :: Eq [a] -> C [a] + dfun a d = MkD a d (meth d) + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 + +None of these definitions is recursive. What happened was that we +generated a specialisation: + + RULE forall d. dfun T d = dT :: C [T] + dT = (MkD a d (meth d)) [T/a, d1/d] + = MkD T d1 (meth d1) + +But now we use the RULE on the RHS of d2, to get + + d2 = dT = MkD d1 (meth d1) + d1 = $p1 d2 + +and now d1 is bottom! The problem is that when specialising 'dfun' we +should first dump "below" the binding all floated dictionary bindings +that mention 'dfun' itself. So d2 and d3 (and hence d1) must be +placed below 'dfun', and thus unavailable to it when specialising +'dfun'. That in turn means that the call (dfun T d1) must be +discarded. On the other hand, the call (dfun T d4) is fine, assuming +d4 doesn't mention dfun. + +But look at this: + + class C a where { foo,bar :: [a] -> [a] } + + instance C Int where + foo x = r_bar x + bar xs = reverse xs + + r_bar :: C a => [a] -> [a] + r_bar xs = bar (xs ++ xs) + +That translates to: + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs } + +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, + which mentions r_bar +But we DO want to specialise r_bar at Int: + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + RULE r_bar Int _ = r_bar_Int + + r_bar_Int xs = bar Int $fCInt (xs ++ xs) + } + +Note that, because of its RULE, r_bar joins the recursive +group. (In this case it'll unravel a short moment later.) + + +Conclusion: we catch the nasty case using filter_dfuns in +callsForMe. To be honest I'm not 100% certain that this is 100% +right, but it works. Sigh. + + +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. There are two wrinkles + +1. We do the already-covered test in specDefn, not when we generate +the CallInfo in mkCallUDs. We used to test in the latter place, but +we now iterate the specialiser somewhat, and the Id at the call site +might therefore not have all the RULES that we can see in specDefn + +2. What about two specialisations where the second is an *instance* +of the first? If the more specific one shows up first, we'll generate +specialisations for both. If the *less* specific one shows up first, +we *don't* currently generate a specialisation for the more specific +one. (See the call to lookupRule in already_covered.) Reasons: + (a) lookupRule doesn't say which matches are exact (bad reason) + (b) if the earlier specialisation is user-provided, it's + far from clear that we should auto-specialise further + +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. + +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +This doesn't always work. One example I came across was this: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly exapmle, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is what we do with the InlinePragma of the original function + * Activation/RuleMatchInfo: both transferred to the + specialised function + * InlineSpec: + (a) An INLINE pragma is transferred + (b) An INLINABLE pragma is *not* transferred + +Why (a): transfer INLINE pragmas? The point of INLINE was precisely to +specialise the function at its call site, and arguably that's not so +important for the specialised copies. BUT *pragma-directed* +specialisation now takes place in the typechecker/desugarer, with +manually specified INLINEs. The specialisation here is automatic. +It'd be very odd if a function marked INLINE was specialised (because +of some local use), and then forever after (including importing +modules) the specialised version wasn't INLINEd. After all, the +programmer said INLINE! + +You might wonder why we specialise INLINE functions at all. After +all they should be inlined, right? Two reasons: + + * Even INLINE functions are sometimes not inlined, when they aren't + applied to interesting arguments. But perhaps the type arguments + alone are enough to specialise (even though the args are too boring + to trigger inlining), and it's certainly better to call the + specialised version. + + * The RHS of an INLINE function might call another overloaded function, + and we'd like to generate a specialised version of that function too. + This actually happens a lot. Consider + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINABLE replicateM_ #-} + replicateM_ d x ma = ... + The strictness analyser may transform to + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINE replicateM_ #-} + replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma + + $wreplicateM_ :: (Monad m) => Int# -> m a -> m () + {-# INLINABLE $wreplicateM_ #-} + $wreplicateM_ = ... + Now an importing module has a specialised call to replicateM_, say + (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! + This particular example had a huge effect on the call to replicateM_ + in nofib/shootout/n-body. + +Why (b): discard INLINEABLE pragmas? See Trac #4874 for persuasive examples. +Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int + f xs = letrec f' = ...f'... in f' +Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } +and we clearly want to inline f_spec at call sites. But if we still +have the big, un-optimised of f (albeit specialised) captured in an +INLINABLE pragma for f_spec, we won't get that optimisation. + +So we simply drop INLINABLE pragmas when specialising. It's not really +a complete solution; ignoring specalisation for now, INLINABLE functions +don't get properly strictness analysed, for example. But it works well +for examples involving specialisation, which is the dominant use of +INLINABLE. See Trac #4874. + + +************************************************************************ +* * +\subsubsection{UsageDetails and suchlike} +* * +************************************************************************ +-} + +data UsageDetails + = MkUD { + ud_binds :: !(Bag DictBind), + -- Floated dictionary bindings + -- The order is important; + -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 + -- (Remember, Bags preserve order in GHC.) + + ud_calls :: !CallDetails + + -- INVARIANT: suppose bs = bindersOf ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs + } + +instance Outputable UsageDetails where + ppr (MkUD { ud_binds = dbs, ud_calls = calls }) + = ptext (sLit "MkUD") <+> braces (sep (punctuate comma + [ptext (sLit "binds") <+> equals <+> ppr dbs, + ptext (sLit "calls") <+> equals <+> ppr calls])) + +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries) +type DictBind = (CoreBind, VarSet) + +type DictExpr = CoreExpr + +emptyUDs :: UsageDetails +emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv } + +------------------------------------------------------------ +type CallDetails = IdEnv CallInfoSet +newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument + +-- CallInfo uses a Map, thereby ensuring that +-- we record only one call instance for any key +-- +-- The list of types and dictionaries is guaranteed to +-- match the type of f +data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) + -- Range is dict args and the vars of the whole + -- call (including tyvars) + -- [*not* include the main id itself, of course] + +type CallInfo = (CallKey, ([DictExpr], VarSet)) + +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (ptext (sLit "CIS") <+> ppr fn) + 2 (ppr map) + +pprCallInfo :: Id -> CallInfo -> SDoc +pprCallInfo fn (CallKey mb_tys, (dxs, _)) + = hang (ppr fn) + 2 (fsep (map ppr_call_key_ty mb_tys ++ map pprParendExpr dxs)) + +ppr_call_key_ty :: Maybe Type -> SDoc +ppr_call_key_ty Nothing = char '_' +ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty + +instance Outputable CallKey where + ppr (CallKey ts) = ppr ts + +-- Type isn't an instance of Ord, so that we can control which +-- instance we use. That's tiresome here. Oh well +instance Eq CallKey where + k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False } + +instance Ord CallKey where + compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2 + where + cmp Nothing Nothing = EQ + cmp Nothing (Just _) = LT + cmp (Just _) Nothing = GT + cmp (Just t1) (Just t2) = cmpType t1 t2 + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 + +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = CIS f (calls1 `Map.union` calls2) + +callDetailsFVs :: CallDetails -> VarSet +callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls + +callInfoFVs :: CallInfoSet -> VarSet +callInfoFVs (CIS _ call_info) = Map.foldRight (\(_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info + +------------------------------------------------------------ +singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails +singleCall id tys dicts + = MkUD {ud_binds = emptyBag, + ud_calls = unitVarEnv id $ CIS id $ + Map.singleton (CallKey tys) (dicts, call_fvs) } + where + call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs + tys_fvs = tyVarsOfTypes (catMaybes tys) + -- The type args (tys) are guaranteed to be part of the dictionary + -- types, because they are just the constrained types, + -- and the dictionary is therefore sure to be bound + -- inside the binding for any type variables free in the type; + -- hence it's safe to neglect tyvars free in tys when making + -- the free-var set for this call + -- BUT I don't trust this reasoning; play safe and include tys_fvs + -- + -- We don't include the 'id' itself. + +mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails +mkCallUDs env f args + = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) + res + where + res = mkCallUDs' env f args + +mkCallUDs' env f args + | not (want_calls_for f) -- Imported from elsewhere + || null theta -- Not overloaded + = emptyUDs + + | not (all type_determines_value theta) + || not (spec_tys `lengthIs` n_tyvars) + || not ( dicts `lengthIs` n_dicts) + || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] + -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" _trace_doc + emptyUDs -- Not overloaded, or no specialisation wanted + + | otherwise + = -- pprTrace "mkCallUDs: keeping" _trace_doc + singleCall f spec_tys dicts + where + _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts + , ppr (map (interestingDict env) dicts)] + (tyvars, theta, _) = tcSplitSigmaTy (idType f) + constrained_tyvars = closeOverKinds (tyVarsOfTypes theta) + n_tyvars = length tyvars + n_dicts = length theta + + spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args] + dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] + + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing + + want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) + -- For imported things, we gather call instances if + -- there is an unfolding that we could in principle specialise + -- We might still decide not to use it (consulting dflags) + -- in specImports + -- Use 'realIdUnfolding' to ignore the loop-breaker flag! + + type_determines_value pred -- See Note [Type determines value] + = case classifyPredType pred of + ClassPred cls _ -> not (isIPClass cls) + TuplePred ps -> all type_determines_value ps + EqPred {} -> True + IrredPred {} -> True -- Things like (D []) where D is a + -- Constraint-ranged family; Trac #7785 + +{- +Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise if all overloading is on non-IP *class* params, +because these are the ones whose *type* determines their *value*. In +parrticular, with implicit params, the type args *don't* say what the +value of the implicit param is! See Trac #7101 + +However, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int +If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) +and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the IrredPred case in type_determines_value. +See Trac #7785. + +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Just that it has *some* structure. But what about +variables? + + * A variable might be imported, in which case its unfolding + will tell us whether it has useful structure + + * Local variables are cloned on the way down (to avoid clashes when + we float dictionaries), and cloning drops the unfolding + (cloneIdBndr). Moreover, we make up some new bindings, and it's a + nuisance to give them unfoldings. So we keep track of the + "interesting" dictionaries as a VarSet in SpecEnv. + We have to take care to put any new interesting dictionary + bindings in the set. + +We accidentally lost accurate tracking of local variables for a long +time, because cloned variables don't have unfoldings. But makes a +massive difference in a few cases, eg Trac #5113. For nofib as a +whole it's only a small win: 2.2% improvement in allocation for ansi, +1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +-} + +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- A dictionary argument is interesting if it has *some* structure +interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) + || isDataConWorkId v + || v `elemVarSet` se_interesting env +interestingDict _ (Type _) = False +interestingDict _ (Coercion _) = False +interestingDict env (App fn (Type _)) = interestingDict env fn +interestingDict env (App fn (Coercion _)) = interestingDict env fn +interestingDict env (Tick _ a) = interestingDict env a +interestingDict env (Cast e _) = interestingDict env e +interestingDict _ _ = True + +plusUDs :: UsageDetails -> UsageDetails -> UsageDetails +plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) + (MkUD {ud_binds = db2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 + , ud_calls = calls1 `unionCalls` calls2 } + +plusUDList :: [UsageDetails] -> UsageDetails +plusUDList = foldr plusUDs emptyUDs + +----------------------------- +_dictBindBndrs :: Bag DictBind -> [Id] +_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs + +-- | Construct a 'DictBind' from a 'CoreBind' +mkDB :: CoreBind -> DictBind +mkDB bind = (bind, bind_fvs bind) + +-- | Identify the free variables of a 'CoreBind' +bind_fvs :: CoreBind -> VarSet +bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) +bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs + where + bndrs = map fst prs + rhs_fvs = unionVarSets (map pair_fvs prs) + +pair_fvs :: (Id, CoreExpr) -> VarSet +pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr + -- Don't forget variables mentioned in the + -- rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear in the RHS + -- type T a = Int + -- x :: T a = 3 + +-- | Flatten a set of 'DictBind's and some other binding pairs into a single +-- recursive binding, including some additional bindings. +flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> DictBind +flattenDictBinds dbs pairs + = (Rec bindings, fvs) + where + (bindings, fvs) = foldrBag add + ([], emptyVarSet) + (dbs `snocBag` mkDB (Rec pairs)) + add (NonRec b r, fvs') (pairs, fvs) = + ((b,r) : pairs, fvs `unionVarSet` fvs') + add (Rec prs1, fvs') (pairs, fvs) = + (prs1 ++ pairs, fvs `unionVarSet` fvs') + +snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails +-- Add ud_binds to the tail end of the bindings in uds +snocDictBinds uds dbs + = uds { ud_binds = ud_binds uds `unionBags` + foldr consBag emptyBag dbs } + +consDictBind :: DictBind -> UsageDetails -> UsageDetails +consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } + +addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } + +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } + +wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] +wrapDictBinds dbs binds + = foldrBag add binds dbs + where + add (bind,_) binds = bind : binds + +wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr +wrapDictBindsE dbs expr + = foldrBag add expr dbs + where + add (bind,_) expr = Let bind expr + +---------------------- +dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) +-- Used at a lambda or case binder; just dump anything mentioning the binder +dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + | null bndrs = (uds, emptyBag) -- Common in case alternatives + | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs + +dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) +-- Used at a lambda or case binder; just dump anything mentioning the binder +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + (free_uds, dump_dbs, float_all) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsFor bndrs orig_calls + float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + +callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) +callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace ("callsForMe") + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- text "Orig calls =" <+> ppr orig_calls, + -- text "Dep set =" <+> ppr dep_set, + -- text "Calls for me =" <+> ppr calls_for_me]) $ + (uds_without_me, calls_for_me) + where + uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn } + calls_for_me = case lookupVarEnv orig_calls fn of + Nothing -> [] + Just (CIS _ calls) -> filter_dfuns (Map.toList calls) + + dep_set = foldlBag go (unitVarSet fn) orig_dbs + go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set + = extendVarSetList dep_set (bindersOf db) + | otherwise = dep_set + + -- Note [Specialisation of dictionary functions] + filter_dfuns | isDFunId fn = filter ok_call + | otherwise = \cs -> cs + + ok_call (_, (_,fvs)) = not (fvs `intersectsVarSet` dep_set) + +---------------------- +splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) +-- Returns (free_dbs, dump_dbs, dump_set) +splitDictBinds dbs bndr_set + = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs + -- Important that it's foldl not foldr; + -- we're accumulating the set of dumped ids in dump_set + where + split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) + | dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocBag` db, + extendVarSetList dump_idset (bindersOf bind)) + + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) + + +---------------------- +deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails +-- Remove calls *mentioning* bs +deleteCallsMentioning bs calls + = mapVarEnv filter_calls calls + where + filter_calls :: CallInfoSet -> CallInfoSet + filter_calls (CIS f calls) = CIS f (Map.filter keep_call calls) + keep_call (_, fvs) = not (fvs `intersectsVarSet` bs) + +deleteCallsFor :: [Id] -> CallDetails -> CallDetails +-- Remove calls *for* bs +deleteCallsFor bs calls = delVarEnvList calls bs + +{- +************************************************************************ +* * +\subsubsection{Boring helper functions} +* * +************************************************************************ +-} + +newtype SpecM a = SpecM (State SpecState a) + +data SpecState = SpecState { + spec_uniq_supply :: UniqSupply, + spec_dflags :: DynFlags + } + +instance Functor SpecM where + fmap = liftM + +instance Applicative SpecM where + pure = return + (<*>) = ap + +instance Monad SpecM where + SpecM x >>= f = SpecM $ do y <- x + case f y of + SpecM z -> + z + return x = SpecM $ return x + fail str = SpecM $ fail str + +instance MonadUnique SpecM where + getUniqueSupplyM + = SpecM $ do st <- get + let (us1, us2) = splitUniqSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us2 } + return us1 + + getUniqueM + = SpecM $ do st <- get + let (u,us') = takeUniqFromSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us' } + return u + +instance HasDynFlags SpecM where + getDynFlags = SpecM $ liftM spec_dflags get + +runSpecM :: DynFlags -> SpecM a -> CoreM a +runSpecM dflags (SpecM spec) + = do us <- getUniqueSupplyM + let initialState = SpecState { + spec_uniq_supply = us, + spec_dflags = dflags + } + return $ evalState spec initialState + +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) +mapAndCombineSM f (x:xs) = do (y, uds1) <- f x + (ys, uds2) <- mapAndCombineSM f xs + return (y:ys, uds1 `plusUDs` uds2) + +extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv +extendTvSubstList env tv_binds + = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds } + +substTy :: SpecEnv -> Type -> Type +substTy env ty = CoreSubst.substTy (se_subst env) ty + +substCo :: SpecEnv -> Coercion -> Coercion +substCo env co = CoreSubst.substCo (se_subst env) co + +substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) +substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) +substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) +-- Clone the binders of the bind; return new bind with the cloned binders +-- Return the substitution to use for RHSs, and the one to use for the body +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) + = do { us <- getUniqueSupplyM + ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr + interesting' | interestingDict env rhs + = interesting `extendVarSet` bndr' + | otherwise = interesting + ; return (env, env { se_subst = subst', se_interesting = interesting' } + , NonRec bndr' rhs) } + +cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) + = do { us <- getUniqueSupplyM + ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs) + env' = env { se_subst = subst' + , se_interesting = interesting `extendVarSetList` + [ v | (v,r) <- pairs, interestingDict env r ] } + ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } + +newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr +-- Make up completely fresh binders for the dictionaries +-- Their bindings are going to float outwards +newDictBndr env b = do { uniq <- getUniqueM + ; let n = idName b + ty' = substTy env (idType b) + ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } + +newSpecIdSM :: Id -> Type -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_id new_ty + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + ; return new_id } + +{- + Old (but interesting) stuff about unboxed bindings + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +What should we do when a value is specialised to a *strict* unboxed value? + + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t + +Could convert let to case: + + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t + +This may be undesirable since it forces evaluation here, but the value +may not be used in all branches of the body. In the general case this +transformation is impossible since the mutual recursion in a letrec +cannot be expressed as a case. + +There is also a problem with top-level unboxed values, since our +implementation cannot handle unboxed values at the top level. + +Solution: Lift the binding of the unboxed value and extract it when it +is used: + + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t + +Now give it to the simplifier and the _Lifting will be optimised away. + +The benfit is that we have given the specialised "unboxed" values a +very simplep lifted semantics and then leave it up to the simplifier to +optimise it --- knowing that the overheads will be removed in nearly +all cases. + +In particular, the value will only be evaluted in the branches of the +program which use it, rather than being forced at the point where the +value is bound. For example: + + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t + ==> + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t + +The binding for h can still be inlined in the one branch and the +_Lifting eliminated. + + +Question: When won't the _Lifting be eliminated? + +Answer: When they at the top-level (where it is necessary) or when +inlining would duplicate work (or possibly code depending on +options). However, the _Lifting will still be eliminated if the +strictness analyser deems the lifted binding strict. +-} diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs new file mode 100644 index 00000000..20bbf3b7 --- /dev/null +++ b/compiler/stgSyn/CoreToStg.hs @@ -0,0 +1,1189 @@ +{-# LANGUAGE CPP #-} + +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +-------------------------------------------------------------- +-- Converting Core to STG Syntax +-------------------------------------------------------------- + +-- And, as we have the info in hand, we may convert some lets to +-- let-no-escapes. + +module CoreToStg ( coreToStg, coreExprToStg ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreUtils ( exprType, findDefault ) +import CoreArity ( manifestArity ) +import StgSyn + +import Type +import TyCon +import MkId ( coercionTokenId ) +import Id +import IdInfo +import DataCon +import CostCentre ( noCCS ) +import VarSet +import VarEnv +import Module +import Name ( getOccName, isExternalName, nameOccName ) +import OccName ( occNameString, occNameFS ) +import BasicTypes ( Arity ) +import TysWiredIn ( unboxedUnitDataCon ) +import Literal +import Outputable +import MonadUtils +import FastString +import Util +import DynFlags +import ForeignCall +import Demand ( isSingleUsed ) +import PrimOp ( PrimCall(..) ) + +import Data.Maybe (isJust) +import Control.Monad (liftM, ap) + +-- Note [Live vs free] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- The actual Stg datatype is decorated with live variable information, as well +-- as free variable information. The two are not the same. Liveness is an +-- operational property rather than a semantic one. A variable is live at a +-- particular execution point if it can be referred to directly again. In +-- particular, a dead variable's stack slot (if it has one): +-- +-- - should be stubbed to avoid space leaks, and +-- - may be reused for something else. +-- +-- There ought to be a better way to say this. Here are some examples: +-- +-- let v = [q] \[x] -> e +-- in +-- ...v... (but no q's) +-- +-- Just after the `in', v is live, but q is dead. If the whole of that +-- let expression was enclosed in a case expression, thus: +-- +-- case (let v = [q] \[x] -> e in ...v...) of +-- alts[...q...] +-- +-- (ie `alts' mention `q'), then `q' is live even after the `in'; because +-- we'll return later to the `alts' and need it. +-- +-- Let-no-escapes make this a bit more interesting: +-- +-- let-no-escape v = [q] \ [x] -> e +-- in +-- ...v... +-- +-- Here, `q' is still live at the `in', because `v' is represented not by +-- a closure but by the current stack state. In other words, if `v' is +-- live then so is `q'. Furthermore, if `e' mentions an enclosing +-- let-no-escaped variable, then its free variables are also live if `v' is. + +-- Note [Collecting live CAF info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In this pass we also collect information on which CAFs are live for +-- constructing SRTs (see SRT.lhs). +-- +-- A top-level Id has CafInfo, which is +-- +-- - MayHaveCafRefs, if it may refer indirectly to +-- one or more CAFs, or +-- - NoCafRefs if it definitely doesn't +-- +-- The CafInfo has already been calculated during the CoreTidy pass. +-- +-- During CoreToStg, we then pin onto each binding and case expression, a +-- list of Ids which represents the "live" CAFs at that point. The meaning +-- of "live" here is the same as for live variables, see above (which is +-- why it's convenient to collect CAF information here rather than elsewhere). +-- +-- The later SRT pass takes these lists of Ids and uses them to construct +-- the actual nested SRTs, and replaces the lists of Ids with (offset,length) +-- pairs. + + +-- Note [Interaction of let-no-escape with SRTs] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider +-- +-- let-no-escape x = ...caf1...caf2... +-- in +-- ...x...x...x... +-- +-- where caf1,caf2 are CAFs. Since x doesn't have a closure, we +-- build SRTs just as if x's defn was inlined at each call site, and +-- that means that x's CAF refs get duplicated in the overall SRT. +-- +-- This is unlike ordinary lets, in which the CAF refs are not duplicated. +-- +-- We could fix this loss of (static) sharing by making a sort of pseudo-closure +-- for x, solely to put in the SRTs lower down. + +-- Note [What is a non-escaping let] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider: +-- +-- let x = fvs \ args -> e +-- in +-- if ... then x else +-- if ... then x else ... +-- +-- `x' is used twice (so we probably can't unfold it), but when it is +-- entered, the stack is deeper than it was when the definition of `x' +-- happened. Specifically, if instead of allocating a closure for `x', +-- we saved all `x's fvs on the stack, and remembered the stack depth at +-- that moment, then whenever we enter `x' we can simply set the stack +-- pointer(s) to these remembered (compile-time-fixed) values, and jump +-- to the code for `x'. +-- +-- All of this is provided x is: +-- 1. non-updatable - it must have at least one parameter (see Note +-- [Join point abstraction]); +-- 2. guaranteed to be entered before the stack retreats -- ie x is not +-- buried in a heap-allocated closure, or passed as an argument to +-- something; +-- 3. all the enters have exactly the right number of arguments, +-- no more no less; +-- 4. all the enters are tail calls; that is, they return to the +-- caller enclosing the definition of `x'. +-- +-- Under these circumstances we say that `x' is non-escaping. +-- +-- An example of when (4) does not hold: +-- +-- let x = ... +-- in case x of ...alts... +-- +-- Here, `x' is certainly entered only when the stack is deeper than when +-- `x' is defined, but here it must return to ...alts... So we can't just +-- adjust the stack down to `x''s recalled points, because that would lost +-- alts' context. +-- +-- Things can get a little more complicated. Consider: +-- +-- let y = ... +-- in let x = fvs \ args -> ...y... +-- in ...x... +-- +-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a +-- non-escaping way in ...y..., then `y' is non-escaping. +-- +-- `x' can even be recursive! Eg: +-- +-- letrec x = [y] \ [v] -> if v then x True else ... +-- in +-- ...(x b)... + +-- -------------------------------------------------------------- +-- Setting variable info: top-level, binds, RHSs +-- -------------------------------------------------------------- + +coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding] +coreToStg dflags this_mod pgm + = return pgm' + where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm + +coreExprToStg :: CoreExpr -> StgExpr +coreExprToStg expr + = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr) + + +coreTopBindsToStg + :: DynFlags + -> Module + -> IdEnv HowBound -- environment for the bindings + -> CoreProgram + -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) + +coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, []) +coreTopBindsToStg dflags this_mod env (b:bs) + = (env2, fvs2, b':bs') + where + -- Notice the mutually-recursive "knot" here: + -- env accumulates down the list of binds, + -- fvs accumulates upwards + (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs + +coreTopBindToStg + :: DynFlags + -> Module + -> IdEnv HowBound + -> FreeVarsInfo -- Info about the body + -> CoreBind + -> (IdEnv HowBound, FreeVarsInfo, StgBinding) + +coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs) + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet $! manifestArity rhs + + (stg_rhs, fvs') = + initLne env $ do + (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs) + return (stg_rhs, fvs') + + bind = StgNonRec id stg_rhs + in + ASSERT2(consistentCafInfo id bind, ppr id ) + -- NB: previously the assertion printed 'rhs' and 'bind' + -- as well as 'id', but that led to a black hole + -- where printing the assertion error tripped the + -- assertion again! + (env', fvs' `unionFVInfo` body_fvs, bind) + +coreTopBindToStg dflags this_mod env body_fvs (Rec pairs) + = ASSERT( not (null pairs) ) + let + binders = map fst pairs + + extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' + + (stg_rhss, fvs') + = initLne env' $ do + (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs + let fvs' = unionFVInfos fvss' + return (stg_rhss, fvs') + + bind = StgRec (zip binders stg_rhss) + in + ASSERT2(consistentCafInfo (head binders) bind, ppr binders) + (env', fvs' `unionFVInfo` body_fvs, bind) + + +-- Assertion helper: this checks that the CafInfo on the Id matches +-- what CoreToStg has figured out about the binding's SRT. The +-- CafInfo will be exact in all cases except when CorePrep has +-- floated out a binding, in which case it will be approximate. +consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool +consistentCafInfo id bind + = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) + safe + where + safe = id_marked_caffy || not binding_is_caffy + exact = id_marked_caffy == binding_is_caffy + id_marked_caffy = mayHaveCafRefs (idCafInfo id) + binding_is_caffy = stgBindHasCafRefs bind + is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" + +coreToTopStgRhs + :: DynFlags + -> Module + -> FreeVarsInfo -- Free var info for the scope of the binding + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo) + +coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) + = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs + ; lv_info <- freeVarsToLiveVars rhs_fvs + + ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs + stg_arity = stgRhsArity stg_rhs + ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, + rhs_fvs) } + where + bndr_info = lookupFVInfo scope_fv_info bndr + + -- It's vital that the arity on a top-level Id matches + -- the arity of the generated STG binding, else an importing + -- module will use the wrong calling convention + -- (Trac #2844 was an example where this happened) + -- NB1: we can't move the assertion further out without + -- blocking the "knot" tied in coreTopBindsToStg + -- NB2: the arity check is only needed for Ids with External + -- Names, because they are externally visible. The CorePrep + -- pass introduces "sat" things with Local Names and does + -- not bother to set their Arity info, so don't fail for those + arity_ok stg_arity + | isExternalName (idName bndr) = id_arity == stg_arity + | otherwise = True + id_arity = idArity bndr + mk_arity_msg stg_arity + = vcat [ppr bndr, + ptext (sLit "Id arity:") <+> ppr id_arity, + ptext (sLit "STG arity:") <+> ppr stg_arity] + +mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo + -> SRT -> Id -> StgBinderInfo -> StgExpr + -> StgRhs + +mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable + -- Dynamic StgConApps are updatable + where con_updateable con args = isDllConApp dflags this_mod con args + +-- --------------------------------------------------------------------------- +-- Expressions +-- --------------------------------------------------------------------------- + +coreToStgExpr + :: CoreExpr + -> LneM (StgExpr, -- Decorated STG expr + FreeVarsInfo, -- Its free vars (NB free, not live) + EscVarsSet) -- Its escapees, a subset of its free vars; + -- also a subset of the domain of the envt + -- because we are only interested in the escapees + -- for vars which might be turned into + -- let-no-escaped ones. + +-- The second and third components can be derived in a simple bottom up pass, not +-- dependent on any decisions about which variables will be let-no-escaped or +-- not. The first component, that is, the decorated expression, may then depend +-- on these components, but it in turn is not scrutinised as the basis for any +-- decisions. Hence no black holes. + +-- No LitInteger's should be left by the time this is called. CorePrep +-- should have converted them all to a real core representation. +coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger" +coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] [] +coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] [] + +coreToStgExpr expr@(App _ _) + = coreToStgApp Nothing f args ticks + where + (f, args, ticks) = myCollectArgs expr + +coreToStgExpr expr@(Lam _ _) + = let + (args, body) = myCollectBinders expr + args' = filterStgBinders args + in + extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do + (body, body_fvs, body_escs) <- coreToStgExpr body + let + fvs = args' `minusFVBinders` body_fvs + escs = body_escs `delVarSetList` args' + result_expr | null args' = body + | otherwise = StgLam args' body + + return (result_expr, fvs, escs) + +coreToStgExpr (Tick tick expr) + = do case tick of + HpcTick{} -> return () + ProfNote{} -> return () + SourceNote{} -> return () + Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" + (expr2, fvs, escs) <- coreToStgExpr expr + return (StgTick tick expr2, fvs, escs) + +coreToStgExpr (Cast expr _) + = coreToStgExpr expr + +-- Cases require a little more real work. + +coreToStgExpr (Case scrut _ _ []) + = coreToStgExpr scrut + -- See Note [Empty case alternatives] in CoreSyn If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. + + +coreToStgExpr (Case scrut bndr _ alts) = do + (alts2, alts_fvs, alts_escs) + <- extendVarEnvLne [(bndr, LambdaBound)] $ do + (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts + return ( alts2, + unionFVInfos fvs_s, + unionVarSets escs_s ) + let + -- Determine whether the default binder is dead or not + -- This helps the code generator to avoid generating an assignment + -- for the case binder (is extremely rare cases) ToDo: remove. + bndr' | bndr `elementOfFVInfo` alts_fvs = bndr + | otherwise = bndr `setIdOccInfo` IAmDead + + -- Don't consider the default binder as being 'live in alts', + -- since this is from the point of view of the case expr, where + -- the default binder is not free. + alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs + alts_escs_wo_bndr = alts_escs `delVarSet` bndr + + alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr + + -- We tell the scrutinee that everything + -- live in the alts is live in it, too. + (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info) + <- setVarsLiveInCont alts_lv_info $ do + (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut + scrut_lv_info <- freeVarsToLiveVars scrut_fvs + return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) + + return ( + StgCase scrut2 (getLiveVars scrut_lv_info) + (getLiveVars alts_lv_info) + bndr' + (mkSRT alts_lv_info) + (mkStgAltType bndr alts) + alts2, + scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, + alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs + -- You might think we should have scrut_escs, not + -- (getFVSet scrut_fvs), but actually we can't call, and + -- then return from, a let-no-escape thing. + ) + where + vars_alt (con, binders, rhs) + | DataAlt c <- con, c == unboxedUnitDataCon + = -- This case is a bit smelly. + -- See Note [Nullary unboxed tuple] in Type.lhs + -- where a nullary tuple is mapped to (State# World#) + ASSERT( null binders ) + do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs + ; return ((DEFAULT, [], [], rhs2), rhs_fvs, rhs_escs) } + | otherwise + = let -- Remove type variables + binders' = filterStgBinders binders + in + extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do + (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs + let + -- Records whether each param is used in the RHS + good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ] + + return ( (con, binders', good_use_mask, rhs2), + binders' `minusFVBinders` rhs_fvs, + rhs_escs `delVarSetList` binders' ) + -- ToDo: remove the delVarSet; + -- since escs won't include any of these binders + +-- Lets not only take quite a bit of work, but this is where we convert +-- then to let-no-escapes, if we wish. +-- (Meanwhile, we don't expect to see let-no-escapes...) + + +coreToStgExpr (Let bind body) = do + (new_let, fvs, escs, _) + <- mfix (\ ~(_, _, _, no_binder_escapes) -> + coreToStgLet no_binder_escapes bind body + ) + + return (new_let, fvs, escs) + +coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) + +mkStgAltType :: Id -> [CoreAlt] -> AltType +mkStgAltType bndr alts = case repType (idType bndr) of + UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of + Just tc | isUnLiftedTyCon tc -> PrimAlt tc + | isAbstractTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) + PolyAlt + Nothing -> PolyAlt + UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) + -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt + where + _is_poly_alt_tycon tc + = isFunTyCon tc + || isPrimTyCon tc -- "Any" is lifted but primitive + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict + -- function application where argument has a + -- type-family type + + -- Sometimes, the TyCon is a AbstractTyCon which may not have any + -- constructors inside it. Then we may get a better TyCon by + -- grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((DataAlt con, _, _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + ASSERT(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts + +-- --------------------------------------------------------------------------- +-- Applications +-- --------------------------------------------------------------------------- + +coreToStgApp + :: Maybe UpdateFlag -- Just upd <=> this application is + -- the rhs of a thunk binding + -- x = [...] \upd [] -> the_app + -- with specified update flag + -> Id -- Function + -> [CoreArg] -- Arguments + -> [Tickish Id] -- Debug ticks + -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) + + +coreToStgApp _ f args ticks = do + (args', args_fvs, ticks') <- coreToStgArgs args + how_bound <- lookupVarLne f + + let + n_val_args = valArgCount args + not_letrec_bound = not (isLetBound how_bound) + fun_fvs = singletonFVInfo f how_bound fun_occ + -- e.g. (f :: a -> int) (x :: a) + -- Here the free variables are "f", "x" AND the type variable "a" + -- coreToStgArgs will deal with the arguments recursively + + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + saturated = f_arity <= n_val_args + + fun_occ + | not_letrec_bound = noBinderInfo -- Uninteresting variable + | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call + | otherwise = stgUnsatOcc -- Unsaturated function or thunk + + fun_escs + | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting + | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly + -- saturated call doesn't escape + -- (let-no-escape applies to 'thunks' too) + + | otherwise = unitVarSet f -- Inexact application; it does escape + + -- At the moment of the call: + + -- either the function is *not* let-no-escaped, in which case + -- nothing is live except live_in_cont + -- or the function *is* let-no-escaped in which case the + -- variables it uses are live, but still the function + -- itself is not. PS. In this case, the function's + -- live vars should already include those of the + -- continuation, but it does no harm to just union the + -- two regardless. + + res_ty = exprType (mkApps (Var f) args) + app = case idDetails f of + DataConWorkId dc | saturated -> StgConApp dc args' + + -- Some primitive operator that might be implemented as a library call. + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty + + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _)) + -> ASSERT( saturated ) + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty + + -- A regular foreign call. + FCallId call -> ASSERT( saturated ) + StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') + _other -> StgApp f args' + fvs = fun_fvs `unionFVInfo` args_fvs + vars = fun_escs `unionVarSet` (getFVSet args_fvs) + -- All the free vars of the args are disqualified + -- from being let-no-escaped. + + tapp = foldr StgTick app (ticks ++ ticks') + + -- Forcing these fixes a leak in the code generator, noticed while + -- profiling for trac #4367 + app `seq` fvs `seq` seqVarSet vars `seq` return ( + tapp, + fvs, + vars + ) + + + +-- --------------------------------------------------------------------------- +-- Argument lists +-- This is the guy that turns applications into A-normal form +-- --------------------------------------------------------------------------- + +coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo, [Tickish Id]) +coreToStgArgs [] + = return ([], emptyFVInfo, []) + +coreToStgArgs (Type _ : args) = do -- Type argument + (args', fvs, ts) <- coreToStgArgs args + return (args', fvs, ts) + +coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder + = do { (args', fvs, ts) <- coreToStgArgs args + ; return (StgVarArg coercionTokenId : args', fvs, ts) } + +coreToStgArgs (Tick t e : args) + = ASSERT( not (tickishIsCode t) ) + do { (args', fvs, ts) <- coreToStgArgs (e : args) + ; return (args', fvs, t:ts) } + +coreToStgArgs (arg : args) = do -- Non-type argument + (stg_args, args_fvs, ticks) <- coreToStgArgs args + (arg', arg_fvs, _escs) <- coreToStgExpr arg + let + fvs = args_fvs `unionFVInfo` arg_fvs + + (aticks, arg'') = stripStgTicksTop tickishFloatable arg' + stg_arg = case arg'' of + StgApp v [] -> StgVarArg v + StgConApp con [] -> StgVarArg (dataConWorkId con) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg) + + -- WARNING: what if we have an argument like (v `cast` co) + -- where 'co' changes the representation type? + -- (This really only happens if co is unsafe.) + -- Then all the getArgAmode stuff in CgBindery will set the + -- cg_rep of the CgIdInfo based on the type of v, rather + -- than the type of 'co'. + -- This matters particularly when the function is a primop + -- or foreign call. + -- Wanted: a better solution than this hacky warning + let + arg_ty = exprType arg + stg_arg_ty = stgArgType stg_arg + bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty)) + || (map typePrimRep (flattenRepType (repType arg_ty)) + /= map typePrimRep (flattenRepType (repType stg_arg_ty))) + -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted), + -- and pass it to a function expecting an HValue (arg_ty). This is ok because + -- we can treat an unlifted value as lifted. But the other way round + -- we complain. + -- We also want to check if a pointer is cast to a non-ptr etc + + WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg ) + return (stg_arg : stg_args, fvs, ticks ++ aticks) + + +-- --------------------------------------------------------------------------- +-- The magic for lets: +-- --------------------------------------------------------------------------- + +coreToStgLet + :: Bool -- True <=> yes, we are let-no-escaping this let + -> CoreBind -- bindings + -> CoreExpr -- body + -> LneM (StgExpr, -- new let + FreeVarsInfo, -- variables free in the whole let + EscVarsSet, -- variables that escape from the whole let + Bool) -- True <=> none of the binders in the bindings + -- is among the escaping vars + +coreToStgLet let_no_escape bind body = do + (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) + <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do + + -- Do the bindings, setting live_in_cont to empty if + -- we ain't in a let-no-escape world + live_in_cont <- getVarsLiveInCont + ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) + <- setVarsLiveInCont (if let_no_escape + then live_in_cont + else emptyLiveInfo) + (vars_bind rec_body_fvs bind) + + -- Do the body + extendVarEnvLne env_ext $ do + (body2, body_fvs, body_escs) <- coreToStgExpr body + body_lv_info <- freeVarsToLiveVars body_fvs + + return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, + body2, body_fvs, body_escs, getLiveVars body_lv_info) + + + -- Compute the new let-expression + let + new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + | otherwise = StgLet bind2 body2 + + free_in_whole_let + = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs) + + live_in_whole_let + = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders) + + real_bind_escs = if let_no_escape then + bind_escs + else + getFVSet bind_fvs + -- Everything escapes which is free in the bindings + + let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders + + all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of + -- this let(rec) + + no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs) + + -- Debugging code as requested by Andrew Kennedy + checked_no_binder_escapes + | debugIsOn && not no_binder_escapes && any is_join_var binders + = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders) + False + | otherwise = no_binder_escapes + + -- Mustn't depend on the passed-in let_no_escape flag, since + -- no_binder_escapes is used by the caller to derive the flag! + return ( + new_let, + free_in_whole_let, + let_escs, + checked_no_binder_escapes + ) + where + set_of_binders = mkVarSet binders + binders = bindersOf bind + + mk_binding bind_lv_info binder rhs + = (binder, LetBound (NestedLet live_vars) (manifestArity rhs)) + where + live_vars | let_no_escape = addLiveVar bind_lv_info binder + | otherwise = unitLiveVar binder + -- c.f. the invariant on NestedLet + + vars_bind :: FreeVarsInfo -- Free var info for body of binding + -> CoreBind + -> LneM (StgBinding, + FreeVarsInfo, + EscVarsSet, -- free vars; escapee vars + LiveInfo, -- Vars and CAFs live in binding + [(Id, HowBound)]) -- extension to environment + + + vars_bind body_fvs (NonRec binder rhs) = do + (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs) + let + env_ext_item = mk_binding bind_lv_info binder rhs + + return (StgNonRec binder rhs2, + bind_fvs, escs, bind_lv_info, [env_ext_item]) + + + vars_bind body_fvs (Rec pairs) + = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) -> + let + rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + binders = map fst pairs + env_ext = [ mk_binding bind_lv_info b rhs + | (b,rhs) <- pairs ] + in + extendVarEnvLne env_ext $ do + (rhss2, fvss, lv_infos, escss) + <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs + let + bind_fvs = unionFVInfos fvss + bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos + escs = unionVarSets escss + + return (StgRec (binders `zip` rhss2), + bind_fvs, escs, bind_lv_info, env_ext) + + +is_join_var :: Id -> Bool +-- A hack (used only for compiler debuggging) to tell if +-- a variable started life as a join point ($j) +is_join_var j = occNameString (getOccName j) == "$j" + +coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> [Id] + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) + +coreToStgRhs scope_fv_info binders (bndr, rhs) = do + (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs + lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) + return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs, + rhs_fvs, lv_info, rhs_escs) + where + bndr_info = lookupFVInfo scope_fv_info bndr + +mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs = mkStgRhs' con_updateable + where con_updateable _ _ = False + +mkStgRhs' :: (DataCon -> [StgArg] -> Bool) + -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs + | StgLam bndrs body <- rhs + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + srt bndrs body + | StgConApp con args <- unticked_rhs + , not (con_updateable con args) + = StgRhsCon noCCS con args + | otherwise + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + upd_flag srt [] rhs + where + + (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs + + upd_flag | isSingleUsed (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable + + {- + SDM: disabled. Eval/Apply can't handle functions with arity zero very + well; and making these into simple non-updatable thunks breaks other + assumptions (namely that they will be entered only once). + + upd_flag | isPAP env rhs = ReEntrant + | otherwise = Updatable + +-- Detect thunks which will reduce immediately to PAPs, and make them +-- non-updatable. This has several advantages: +-- +-- - the non-updatable thunk behaves exactly like the PAP, +-- +-- - the thunk is more efficient to enter, because it is +-- specialised to the task. +-- +-- - we save one update frame, one stg_update_PAP, one update +-- and lots of PAP_enters. +-- +-- - in the case where the thunk is top-level, we save building +-- a black hole and futhermore the thunk isn't considered to +-- be a CAF any more, so it doesn't appear in any SRTs. +-- +-- We do it here, because the arity information is accurate, and we need +-- to do it before the SRT pass to save the SRT entries associated with +-- any top-level PAPs. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + +-} + +{- ToDo: + upd = if isOnceDem dem + then (if isNotTop toplev + then SingleEntry -- HA! Paydirt for "dem" + else + (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $ + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} + +-- --------------------------------------------------------------------------- +-- A little monad for this let-no-escaping pass +-- --------------------------------------------------------------------------- + +-- There's a lot of stuff to pass around, so we use this LneM monad to +-- help. All the stuff here is only passed *down*. + +newtype LneM a = LneM + { unLneM :: IdEnv HowBound + -> LiveInfo -- Vars and CAFs live in continuation + -> a + } + +type LiveInfo = (StgLiveVars, -- Dynamic live variables; + -- i.e. ones with a nested (non-top-level) binding + CafSet) -- Static live variables; + -- i.e. top-level variables that are CAFs or refer to them + +type EscVarsSet = IdSet +type CafSet = IdSet + +data HowBound + = ImportBound -- Used only as a response to lookupBinding; never + -- exists in the range of the (IdEnv HowBound) + + | LetBound -- A let(rec) in this module + LetInfo -- Whether top level or nested + Arity -- Its arity (local Ids don't have arity info at this point) + + | LambdaBound -- Used for both lambda and case + +data LetInfo + = TopLet -- top level things + | NestedLet LiveInfo -- For nested things, what is live if this + -- thing is live? Invariant: the binder + -- itself is always a member of + -- the dynamic set of its own LiveInfo + +isLetBound :: HowBound -> Bool +isLetBound (LetBound _ _) = True +isLetBound _ = False + +topLevelBound :: HowBound -> Bool +topLevelBound ImportBound = True +topLevelBound (LetBound TopLet _) = True +topLevelBound _ = False + +-- For a let(rec)-bound variable, x, we record LiveInfo, the set of +-- variables that are live if x is live. This LiveInfo comprises +-- (a) dynamic live variables (ones with a non-top-level binding) +-- (b) static live variabes (CAFs or things that refer to CAFs) +-- +-- For "normal" variables (a) is just x alone. If x is a let-no-escaped +-- variable then x is represented by a code pointer and a stack pointer +-- (well, one for each stack). So all of the variables needed in the +-- execution of x are live if x is, and are therefore recorded in the +-- LetBound constructor; x itself *is* included. +-- +-- The set of dynamic live variables is guaranteed ot have no further +-- let-no-escaped variables in it. + +emptyLiveInfo :: LiveInfo +emptyLiveInfo = (emptyVarSet,emptyVarSet) + +unitLiveVar :: Id -> LiveInfo +unitLiveVar lv = (unitVarSet lv, emptyVarSet) + +unitLiveCaf :: Id -> LiveInfo +unitLiveCaf caf = (emptyVarSet, unitVarSet caf) + +addLiveVar :: LiveInfo -> Id -> LiveInfo +addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs) + +unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo +unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2) + +mkSRT :: LiveInfo -> SRT +mkSRT (_, cafs) = SRTEntries cafs + +getLiveVars :: LiveInfo -> StgLiveVars +getLiveVars (lvs, _) = lvs + +-- The std monad functions: + +initLne :: IdEnv HowBound -> LneM a -> a +initLne env m = unLneM m env emptyLiveInfo + + + +{-# INLINE thenLne #-} +{-# INLINE returnLne #-} + +returnLne :: a -> LneM a +returnLne e = LneM $ \_ _ -> e + +thenLne :: LneM a -> (a -> LneM b) -> LneM b +thenLne m k = LneM $ \env lvs_cont + -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont + +instance Functor LneM where + fmap = liftM + +instance Applicative LneM where + pure = return + (<*>) = ap + +instance Monad LneM where + return = returnLne + (>>=) = thenLne + +instance MonadFix LneM where + mfix expr = LneM $ \env lvs_cont -> + let result = unLneM (expr result) env lvs_cont + in result + +-- Functions specific to this monad: + +getVarsLiveInCont :: LneM LiveInfo +getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont + +setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a +setVarsLiveInCont new_lvs_cont expr + = LneM $ \env _lvs_cont + -> unLneM expr env new_lvs_cont + +extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a +extendVarEnvLne ids_w_howbound expr + = LneM $ \env lvs_cont + -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont + +lookupVarLne :: Id -> LneM HowBound +lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v + +lookupBinding :: IdEnv HowBound -> Id -> HowBound +lookupBinding env v = case lookupVarEnv env v of + Just xx -> xx + Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound + + +-- The result of lookupLiveVarsForSet, a set of live variables, is +-- only ever tacked onto a decorated expression. It is never used as +-- the basis of a control decision, which might give a black hole. + +freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo +freeVarsToLiveVars fvs = LneM freeVarsToLiveVars' + where + freeVarsToLiveVars' _env live_in_cont = live_info + where + live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs + lvs_from_fvs = map do_one (allFreeIds fvs) + + do_one (v, how_bound) + = case how_bound of + ImportBound -> unitLiveCaf v -- Only CAF imports are + -- recorded in fvs + LetBound TopLet _ + | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v + | otherwise -> emptyLiveInfo + + LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v + -- (see the invariant on NestedLet) + + _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case + + +-- --------------------------------------------------------------------------- +-- Free variable information +-- --------------------------------------------------------------------------- + +type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) + -- The Var is so we can gather up the free variables + -- as a set. + -- + -- The HowBound info just saves repeated lookups; + -- we look up just once when we encounter the occurrence. + -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids + -- Imported Ids without CAF refs are simply + -- not put in the FreeVarsInfo for an expression. + -- See singletonFVInfo and freeVarsToLiveVars + -- + -- StgBinderInfo records how it occurs; notably, we + -- are interested in whether it only occurs in saturated + -- applications, because then we don't need to build a + -- curried version. + -- If f is mapped to noBinderInfo, that means + -- that f *is* mentioned (else it wouldn't be in the + -- IdEnv at all), but perhaps in an unsaturated applications. + -- + -- All case/lambda-bound things are also mapped to + -- noBinderInfo, since we aren't interested in their + -- occurrence info. + -- + -- For ILX we track free var info for type variables too; + -- hence VarEnv not IdEnv + +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = emptyVarEnv + +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +-- Don't record non-CAF imports at all, to keep free-var sets small +singletonFVInfo id ImportBound info + | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info) + | otherwise = emptyVarEnv +singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info) + +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2 + +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs + +minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo +minusFVBinders vs fv = foldr minusFVBinder fv vs + +minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo +minusFVBinder v fv = fv `delVarEnv` v + -- When removing a binder, remember to add its type variables + -- c.f. CoreFVs.delBinderFV + +elementOfFVInfo :: Id -> FreeVarsInfo -> Bool +elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id) + +lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo +-- Find how the given Id is used. +-- Externally visible things may be used any old how +lookupFVInfo fvs id + | isExternalName (idName id) = noBinderInfo + | otherwise = case lookupVarEnv fvs id of + Nothing -> noBinderInfo + Just (_,_,info) -> info + +allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids +allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids + where + ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs] + +-- Non-top-level things only, both type variables and ids +getFVs :: FreeVarsInfo -> [Var] +getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, + not (topLevelBound how_bound) ] + +getFVSet :: FreeVarsInfo -> VarSet +getFVSet fvs = mkVarSet (getFVs fvs) + +plusFVInfo :: (Var, HowBound, StgBinderInfo) + -> (Var, HowBound, StgBinderInfo) + -> (Var, HowBound, StgBinderInfo) +plusFVInfo (id1,hb1,info1) (id2,hb2,info2) + = ASSERT(id1 == id2 && hb1 `check_eq_how_bound` hb2) + (id1, hb1, combineStgBinderInfo info1 info2) + +-- The HowBound info for a variable in the FVInfo should be consistent +check_eq_how_bound :: HowBound -> HowBound -> Bool +check_eq_how_bound ImportBound ImportBound = True +check_eq_how_bound LambdaBound LambdaBound = True +check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2 +check_eq_how_bound _ _ = False + +check_eq_li :: LetInfo -> LetInfo -> Bool +check_eq_li (NestedLet _) (NestedLet _) = True +check_eq_li TopLet TopLet = True +check_eq_li _ _ = False + +-- Misc. + +filterStgBinders :: [Var] -> [Var] +filterStgBinders bndrs = filter isId bndrs + +myCollectBinders :: Expr Var -> ([Var], Expr Var) +myCollectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs (Cast e _) = go bs e + go bs e = (reverse bs, e) + +myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) + -- We assume that we only have variables + -- in the function position by now +myCollectArgs expr + = go expr [] [] + where + go (Var v) as ts = (v, as, ts) + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts = ASSERT( all isTypeArg as ) + go e as (t:ts) -- ticks can appear in type apps + go (Cast e _) as ts = go e as ts + go (Lam b e) as ts + | isTyVar b = go e as ts -- Note [Collect args] + go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) + +-- Note [Collect args] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- This big-lambda case occurred following a rather obscure eta expansion. +-- It all seems a bit yukky to me. + +stgArity :: Id -> HowBound -> Arity +stgArity _ (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity _ LambdaBound = 0 diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs new file mode 100644 index 00000000..b415b4f2 --- /dev/null +++ b/compiler/stgSyn/StgLint.hs @@ -0,0 +1,533 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[StgLint]{A ``lint'' pass to check for Stg correctness} +-} + +{-# LANGUAGE CPP #-} + +module StgLint ( lintStgBindings ) where + +import StgSyn + +import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import Id ( Id, idType, isLocalId ) +import VarSet +import DataCon +import CoreSyn ( AltCon(..) ) +import PrimOp ( primOpType ) +import Literal ( literalType ) +import Maybes +import Name ( getSrcLoc ) +import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) +import TypeRep +import Type +import TyCon +import Util +import SrcLoc +import Outputable +import FastString +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ( Applicative(..) ) +#endif +import Control.Monad +import Data.Function + +#include "HsVersions.h" + +{- +Checks for + (a) *some* type errors + (b) locally-defined variables used but not defined + + +Note: unless -dverbose-stg is on, display of lint errors will result +in "panic: bOGUS_LVs". + +WARNING: +~~~~~~~~ + +This module has suffered bit-rot; it is likely to yield lint errors +for Stg code that is currently perfectly acceptable for code +generation. Solution: don't use it! (KSW 2000-05). + + +************************************************************************ +* * +\subsection{``lint'' for various constructs} +* * +************************************************************************ + +@lintStgBindings@ is the top-level interface function. +-} + +lintStgBindings :: String -> [StgBinding] -> [StgBinding] + +lintStgBindings whodunnit binds + = {-# SCC "StgLint" #-} + case (initL (lint_binds binds)) of + Nothing -> binds + Just msg -> pprPanic "" (vcat [ + ptext (sLit "*** Stg Lint ErrMsgs: in") <+> + text whodunnit <+> ptext (sLit "***"), + msg, + ptext (sLit "*** Offending Program ***"), + pprStgBindings binds, + ptext (sLit "*** End of Offense ***")]) + where + lint_binds :: [StgBinding] -> LintM () + + lint_binds [] = return () + lint_binds (bind:binds) = do + binders <- lintStgBinds bind + addInScopeVars binders $ + lint_binds binds + +lintStgArg :: StgArg -> LintM (Maybe Type) +lintStgArg (StgLitArg lit) = return (Just (literalType lit)) +lintStgArg (StgVarArg v) = lintStgVar v + +lintStgVar :: Id -> LintM (Maybe Kind) +lintStgVar v = do checkInScope v + return (Just (idType v)) + +lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders +lintStgBinds (StgNonRec binder rhs) = do + lint_binds_help (binder,rhs) + return [binder] + +lintStgBinds (StgRec pairs) + = addInScopeVars binders $ do + mapM_ lint_binds_help pairs + return binders + where + binders = [b | (b,_) <- pairs] + +lint_binds_help :: (Id, StgRhs) -> LintM () +lint_binds_help (binder, rhs) + = addLoc (RhsOf binder) $ do + -- Check the rhs + _maybe_rhs_ty <- lintStgRhs rhs + + -- Check binder doesn't have unlifted type + checkL (not (isUnLiftedType binder_ty)) + (mkUnLiftedTyMsg binder rhs) + + -- Check match to RHS type + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of + -- Nothing -> return () + -- Just rhs_ty -> checkTys binder_ty + -- rhs_ty + --- (mkRhsMsg binder rhs_ty) + + return () + where + binder_ty = idType binder + +lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact + +lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr) + = lintStgExpr expr + +lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr) + = addLoc (LambdaBodyOf binders) $ + addInScopeVars binders $ runMaybeT $ do + body_ty <- MaybeT $ lintStgExpr expr + return (mkFunTys (map idType binders) body_ty) + +lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do + arg_tys <- mapM (MaybeT . lintStgArg) args + MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) + where + con_ty = dataConRepType con + +lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact + +lintStgExpr (StgLit l) = return (Just (literalType l)) + +lintStgExpr e@(StgApp fun args) = runMaybeT $ do + fun_ty <- MaybeT $ lintStgVar fun + arg_tys <- mapM (MaybeT . lintStgArg) args + MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) + +lintStgExpr e@(StgConApp con args) = runMaybeT $ do + arg_tys <- mapM (MaybeT . lintStgArg) args + MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) + where + con_ty = dataConRepType con + +lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do + arg_tys <- mapM (MaybeT . lintStgArg) args + MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) + where + op_ty = primOpType op + +lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do + -- We don't have enough type information to check + -- the application for StgFCallOp and StgPrimCallOp; ToDo + _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args + return res_ty + +lintStgExpr (StgLam bndrs _) = do + addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs) + return Nothing + +lintStgExpr (StgLet binds body) = do + binders <- lintStgBinds binds + addLoc (BodyOfLetRec binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgLetNoEscape _ _ binds body) = do + binders <- lintStgBinds binds + addLoc (BodyOfLetRec binders) $ + addInScopeVars binders $ + lintStgExpr body + +lintStgExpr (StgTick _ expr) = lintStgExpr expr + +lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do + _ <- MaybeT $ lintStgExpr scrut + + in_scope <- MaybeT $ liftM Just $ + case alts_type of + AlgAlt tc -> check_bndr tc >> return True + PrimAlt tc -> check_bndr tc >> return True + UbxTupAlt _ -> return False -- Binder is always dead in this case + PolyAlt -> return True + + MaybeT $ addInScopeVars [bndr | in_scope] $ + lintStgAlts alts scrut_ty + where + scrut_ty = idType bndr + UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple + check_bndr tc = case tyConAppTyCon_maybe scrut_rep of + Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr + Nothing -> addErrL bad_bndr + where + bad_bndr = mkDefltMsg bndr tc + +lintStgAlts :: [StgAlt] + -> Type -- Type of scrutinee + -> LintM (Maybe Type) -- Just ty => type is accurage + +lintStgAlts alts scrut_ty = do + maybe_result_tys <- mapM (lintAlt scrut_ty) alts + + -- Check the result types + case catMaybes (maybe_result_tys) of + [] -> return Nothing + + (first_ty:_tys) -> do -- mapM_ check tys + return (Just first_ty) + where + -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) + -- We can't check that the alternatives have the + -- same type, because they don't, with unsafeCoerce# + +lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) +lintAlt _ (DEFAULT, _, _, rhs) + = lintStgExpr rhs + +lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do + checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty) + lintStgExpr rhs + +lintAlt scrut_ty (DataAlt con, args, _, rhs) = do + case splitTyConApp_maybe scrut_ty of + Just (tycon, tys_applied) | isAlgTyCon tycon && + not (isNewTyCon tycon) -> do + let + cons = tyConDataCons tycon + arg_tys = dataConInstArgTys con tys_applied + -- This does not work for existential constructors + + checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) + checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args) + when (isVanillaDataCon con) $ + mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) + return () + _ -> + addErrL (mkAltMsg1 scrut_ty) + + addInScopeVars args $ + lintStgExpr rhs + where + check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg) + + -- elem: yes, the elem-list here can sometimes be long-ish, + -- but as it's use-once, probably not worth doing anything different + -- We give it its own copy, so it isn't overloaded. + elem _ [] = False + elem x (y:ys) = x==y || elem x ys + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +newtype LintM a = LintM + { unLintM :: [LintLocInfo] -- Locations + -> IdSet -- Local vars in scope + -> Bag MsgDoc -- Error messages so far + -> (a, Bag MsgDoc) -- Result and error messages (if any) + } + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + +dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) +dumpLoc (RhsOf v) = + (srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' ) +dumpLoc (LambdaBodyOf bs) = + (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' ) + +dumpLoc (BodyOfLetRec bs) = + (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' ) + + +pp_binders :: [Id] -> SDoc +pp_binders bs + = sep (punctuate comma (map pp_binder bs)) + where + pp_binder b + = hsep [ppr b, dcolon, ppr (idType b)] + +initL :: LintM a -> Maybe MsgDoc +initL (LintM m) + = case (m [] emptyVarSet emptyBag) of { (_, errs) -> + if isEmptyBag errs then + Nothing + else + Just (vcat (punctuate blankLine (bagToList errs))) + } + +instance Functor LintM where + fmap = liftM + +instance Applicative LintM where + pure = return + (<*>) = ap + +instance Monad LintM where + return a = LintM $ \_loc _scope errs -> (a, errs) + (>>=) = thenL + (>>) = thenL_ + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k = LintM $ \loc scope errs + -> case unLintM m loc scope errs of + (r, errs') -> unLintM (k r) loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k = LintM $ \loc scope errs + -> case unLintM m loc scope errs of + (_, errs') -> unLintM k loc scope errs' + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = addErrL msg + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) + +addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc +addErr errs_so_far msg locs + = errs_so_far `snocBag` mk_msg locs + where + mk_msg (loc:_) = let (l,hdr) = dumpLoc loc + in mkLocMessage SevWarning l (hdr $$ msg) + mk_msg [] = msg + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m = LintM $ \loc scope errs + -> unLintM m (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m = LintM $ \loc scope errs + -> -- We check if these "new" ids are already + -- in scope, i.e., we have *shadowing* going on. + -- For now, it's just a "trace"; we may make + -- a real error out of it... + let + new_set = mkVarSet ids + in +-- After adding -fliberate-case, Simon decided he likes shadowed +-- names after all. WDP 94/07 +-- (if isEmptyVarSet shadowed +-- then id +-- else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $ + unLintM m loc (scope `unionVarSet` new_set) errs + +{- +Checking function applications: we only check that the type has the +right *number* of arrows, we don't actually compare the types. This +is because we can't expect the types to be equal - the type +applications and type lambdas that we use to calculate accurate types +have long since disappeared. +-} + +checkFunApp :: Type -- The function type + -> [Type] -- The arg type(s) + -> MsgDoc -- Error message + -> LintM (Maybe Type) -- Just ty => result type is accurate + +checkFunApp fun_ty arg_tys msg + = do { case mb_msg of + Just msg -> addErrL msg + Nothing -> return () + ; return mb_ty } + where + (mb_ty, mb_msg) = cfa True fun_ty arg_tys + + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? + + cfa accurate fun_ty [] -- Args have run out; that's fine + = (if accurate then Just fun_ty else Nothing, Nothing) + + cfa accurate fun_ty arg_tys@(arg_ty':arg_tys') + | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + = if accurate && not (arg_ty `stgEqType` arg_ty') + then (Nothing, Just msg) -- Arg type mismatch + else cfa accurate res_ty arg_tys' + + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty + = cfa False fun_ty' arg_tys + + | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty + , isNewTyCon tc + = if length tc_args < tyConArity tc + then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg ) + (Nothing, Nothing) -- This is odd, but I've seen it + else cfa False (newTyConInstRhs tc tc_args) arg_tys + + | Just tc <- tyConAppTyCon_maybe fun_ty + , not (isTypeFamilyTyCon tc) -- Definite error + = (Nothing, Just msg) -- Too many args + + | otherwise + = (Nothing, Nothing) + +stgEqType :: Type -> Type -> Bool +-- Compare types, but crudely because we have discarded +-- both casts and type applications, so types might look +-- different but be the same. So reply "True" if in doubt. +-- "False" means that the types are definitely different. +-- +-- Fundamentally this is a losing battle because of unsafeCoerce + +stgEqType orig_ty1 orig_ty2 + = gos (repType orig_ty1) (repType orig_ty2) + where + gos :: RepType -> RepType -> Bool + gos (UbxTupleRep tys1) (UbxTupleRep tys2) + = equalLength tys1 tys2 && and (zipWith go tys1 tys2) + gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2 + gos _ _ = False + + go :: UnaryType -> UnaryType -> Bool + go ty1 ty2 + | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 + , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 + , let res = if tc1 == tc2 + then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) + = if res then True + else + pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) + False + + | otherwise = True -- Conservatively say "fine". + -- Type variables in particular + +checkInScope :: Id -> LintM () +checkInScope id = LintM $ \loc scope errs + -> if isLocalId id && not (id `elemVarSet` scope) then + ((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc) + else + ((), errs) + +checkTys :: Type -> Type -> MsgDoc -> LintM () +checkTys ty1 ty2 msg = LintM $ \loc _scope errs + -> if (ty1 `stgEqType` ty2) + then ((), errs) + else ((), addErr errs msg loc) + +_mkCaseAltMsg :: [StgAlt] -> MsgDoc +_mkCaseAltMsg _alts + = ($$) (text "In some case alternatives, type of alternatives not all same:") + (Outputable.empty) -- LATER: ppr alts + +mkDefltMsg :: Id -> TyCon -> MsgDoc +mkDefltMsg bndr tc + = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) + (ppr bndr $$ ppr (idType bndr) $$ ppr tc) + +mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc +mkFunAppMsg fun_ty arg_tys expr + = vcat [text "In a function application, function type doesn't match arg types:", + hang (ptext (sLit "Function type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)), + hang (ptext (sLit "Expression:")) 4 (ppr expr)] + +mkRhsConMsg :: Type -> [Type] -> MsgDoc +mkRhsConMsg fun_ty arg_tys + = vcat [text "In a RHS constructor application, con type doesn't match arg types:", + hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))] + +mkAltMsg1 :: Type -> MsgDoc +mkAltMsg1 ty + = ($$) (text "In a case expression, type of scrutinee does not match patterns") + (ppr ty) + +mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc +mkAlgAltMsg2 ty con + = vcat [ + text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr ty, + ppr con + ] + +mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc +mkAlgAltMsg3 con alts + = vcat [ + text "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr con, + ppr alts + ] + +mkAlgAltMsg4 :: Type -> Id -> MsgDoc +mkAlgAltMsg4 ty arg + = vcat [ + text "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr ty, + ppr arg + ] + +_mkRhsMsg :: Id -> Type -> MsgDoc +_mkRhsMsg binder ty + = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), + ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], + hsep [ptext (sLit "Rhs type:"), ppr ty] + ] + +mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc +mkUnLiftedTyMsg binder rhs + = (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+> + ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder))) + $$ + (ptext (sLit "RHS:") <+> ppr rhs) diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs new file mode 100644 index 00000000..6c6d4bfb --- /dev/null +++ b/compiler/stgSyn/StgSyn.hs @@ -0,0 +1,808 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} + +This data type represents programs just before code generation (conversion to +@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style +being one that happens to be ideally suited to spineless tagless code +generation. +-} + +{-# LANGUAGE CPP #-} + +module StgSyn ( + GenStgArg(..), + GenStgLiveVars, + + GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgAlt, AltType(..), + + UpdateFlag(..), isUpdatable, + + StgBinderInfo, + noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, + combineStgBinderInfo, + + -- a set of synonyms for the most common (only :-) parameterisation + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, StgAlt, + + -- StgOp + StgOp(..), + + -- SRTs + SRT(..), + + -- utils + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + isDllConApp, + stgArgType, + stripStgTicksTop, + + pprStgBinding, pprStgBindings, + pprStgLVs + ) where + +#include "HsVersions.h" + +import Bitmap +import CoreSyn ( AltCon, Tickish ) +import CostCentre ( CostCentreStack ) +import DataCon +import DynFlags +import FastString +import ForeignCall ( ForeignCall ) +import Id +import IdInfo ( mayHaveCafRefs ) +import Literal ( Literal, literalType ) +import Module ( Module ) +import Outputable +import Packages ( isDllName ) +import Platform +import PprCore ( {- instances -} ) +import PrimOp ( PrimOp, PrimCall ) +import TyCon ( PrimRep(..) ) +import TyCon ( TyCon ) +import Type ( Type ) +import Type ( typePrimRep ) +import UniqSet +import Unique ( Unique ) +import Util +import VarSet ( IdSet, isEmptyVarSet ) + +{- +************************************************************************ +* * +\subsection{@GenStgBinding@} +* * +************************************************************************ + +As usual, expressions are interesting; other things are boring. Here +are the boring things [except note the @GenStgRhs@], parameterised +with respect to binder and occurrence information (just as in +@CoreSyn@): + +There is one SRT for each group of bindings. +-} + +data GenStgBinding bndr occ + = StgNonRec bndr (GenStgRhs bndr occ) + | StgRec [(bndr, GenStgRhs bndr occ)] + +{- +************************************************************************ +* * +\subsection{@GenStgArg@} +* * +************************************************************************ +-} + +data GenStgArg occ + = StgVarArg occ + | StgLitArg Literal + +-- | Does this constructor application refer to +-- anything in a different *Windows* DLL? +-- If so, we can't allocate it statically +isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool +isDllConApp dflags this_mod con args + | platformOS (targetPlatform dflags) == OSMinGW32 + = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args + | otherwise = False + where + -- NB: typePrimRep is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) + is_dll_arg :: StgArg -> Bool + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) + && isDllName dflags this_pkg this_mod (idName v) + is_dll_arg _ = False + + this_pkg = thisPackage dflags + +-- True of machine addresses; these are the things that don't +-- work across DLLs. The key point here is that VoidRep comes +-- out False, so that a top level nullary GADT constructor is +-- False for isDllConApp +-- data T a where +-- T1 :: T Int +-- gives +-- T1 :: forall a. (a~Int) -> T a +-- and hence the top-level binding +-- $WT1 :: T Int +-- $WT1 = T1 Int (Coercion (Refl Int)) +-- The coercion argument here gets VoidRep +isAddrRep :: PrimRep -> Bool +isAddrRep AddrRep = True +isAddrRep PtrRep = True +isAddrRep _ = False + +-- | Type of an @StgArg@ +-- +-- Very half baked becase we have lost the type arguments. +stgArgType :: StgArg -> Type +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit + + +-- | Strip ticks of a given type from an STG expression +stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr) +stripStgTicksTop p = go [] + where go ts (StgTick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + + +{- +************************************************************************ +* * +\subsection{STG expressions} +* * +************************************************************************ + +The @GenStgExpr@ data type is parameterised on binder and occurrence +info, as before. + +************************************************************************ +* * +\subsubsection{@GenStgExpr@ application} +* * +************************************************************************ + +An application is of a function to a list of atoms [not expressions]. +Operationally, we want to push the arguments on the stack and call the +function. (If the arguments were expressions, we would have to build +their closures first.) + +There is no constructor for a lone variable; it would appear as +@StgApp var [] _@. +-} + +type GenStgLiveVars occ = UniqSet occ + +data GenStgExpr bndr occ + = StgApp + occ -- function + [GenStgArg occ] -- arguments; may be empty + +{- +************************************************************************ +* * +\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} +* * +************************************************************************ + +There are a specialised forms of application, for constructors, +primitives, and literals. +-} + + | StgLit Literal + + -- StgConApp is vital for returning unboxed tuples + -- which can't be let-bound first + | StgConApp DataCon + [GenStgArg occ] -- Saturated + + | StgOpApp StgOp -- Primitive op or foreign call + [GenStgArg occ] -- Saturated + Type -- Result type + -- We need to know this so that we can + -- assign result registers + +{- +************************************************************************ +* * +\subsubsection{@StgLam@} +* * +************************************************************************ + +StgLam is used *only* during CoreToStg's work. Before CoreToStg has +finished it encodes (\x -> e) as (let f = \x -> e in f) +-} + + | StgLam + [bndr] + StgExpr -- Body of lambda + +{- +************************************************************************ +* * +\subsubsection{@GenStgExpr@: case-expressions} +* * +************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +-} + + | StgCase + (GenStgExpr bndr occ) + -- the thing to examine + + (GenStgLiveVars occ) + -- Live vars of whole case expression, + -- plus everything that happens after the case + -- i.e., those which mustn't be overwritten + + (GenStgLiveVars occ) + -- Live vars of RHSs (plus what happens afterwards) + -- i.e., those which must be saved before eval. + -- + -- note that an alt's constructor's + -- binder-variables are NOT counted in the + -- free vars for the alt's RHS + + bndr -- binds the result of evaluating the scrutinee + + SRT -- The SRT for the continuation + + AltType + + [GenStgAlt bndr occ] + -- The DEFAULT case is always *first* + -- if it is there at all + +{- +************************************************************************ +* * +\subsubsection{@GenStgExpr@: @let(rec)@-expressions} +* * +************************************************************************ + +The various forms of let(rec)-expression encode most of the +interesting things we want to do. +\begin{enumerate} +\item +\begin{verbatim} +let-closure x = [free-vars] [args] expr +in e +\end{verbatim} +is equivalent to +\begin{verbatim} +let x = (\free-vars -> \args -> expr) free-vars +\end{verbatim} +\tr{args} may be empty (and is for most closures). It isn't under +circumstances like this: +\begin{verbatim} +let x = (\y -> y+z) +\end{verbatim} +This gets mangled to +\begin{verbatim} +let-closure x = [z] [y] (y+z) +\end{verbatim} +The idea is that we compile code for @(y+z)@ in an environment in which +@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an +offset from the stack pointer. + +(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +\item +\begin{verbatim} +let-constructor x = Constructor [args] +in e +\end{verbatim} + +(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +\item +Letrec-expressions are essentially the same deal as +let-closure/let-constructor, so we use a common structure and +distinguish between them with an @is_recursive@ boolean flag. + +\item +\begin{verbatim} +let-unboxed u = an arbitrary arithmetic expression in unboxed values +in e +\end{verbatim} +All the stuff on the RHS must be fully evaluated. +No function calls either! + +(We've backed away from this toward case-expressions with +suitably-magical alts ...) + +\item +~[Advanced stuff here! Not to start with, but makes pattern matching +generate more efficient code.] + +\begin{verbatim} +let-escapes-not fail = expr +in e' +\end{verbatim} +Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, +or pass it to another function. All @e'@ will ever do is tail-call @fail@. +Rather than build a closure for @fail@, all we need do is to record the stack +level at the moment of the @let-escapes-not@; then entering @fail@ is just +a matter of adjusting the stack pointer back down to that point and entering +the code for it. + +Another example: +\begin{verbatim} +f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 +\end{verbatim} + +(A let-escapes-not is an @StgLetNoEscape@.) + +\item +We may eventually want: +\begin{verbatim} +let-literal x = Literal +in e +\end{verbatim} +\end{enumerate} + +And so the code for let(rec)-things: +-} + + | StgLet + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body + + | StgLetNoEscape -- remember: ``advanced stuff'' + (GenStgLiveVars occ) -- Live in the whole let-expression + -- Mustn't overwrite these stack slots + -- _Doesn't_ include binders of the let(rec). + + (GenStgLiveVars occ) -- Live in the right hand sides (only) + -- These are the ones which must be saved on + -- the stack if they aren't there already + -- _Does_ include binders of the let(rec) if recursive. + + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body + +{- +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations} +%* * +%************************************************************************ + +Finally for @hpc@ expressions we introduce a new STG construct. +-} + + | StgTick + (Tickish bndr) + (GenStgExpr bndr occ) -- sub expression + +-- END of GenStgExpr + +{- +************************************************************************ +* * +\subsection{STG right-hand sides} +* * +************************************************************************ + +Here's the rest of the interesting stuff for @StgLet@s; the first +flavour is for closures: +-} + +data GenStgRhs bndr occ + = StgRhsClosure + CostCentreStack -- CCS to be attached (default is CurrentCCS) + StgBinderInfo -- Info about how this binder is used (see below) + [occ] -- non-global free vars; a list, rather than + -- a set, because order is important + !UpdateFlag -- ReEntrant | Updatable | SingleEntry + SRT -- The SRT reference + [bndr] -- arguments; if empty, then not a function; + -- as above, order is important. + (GenStgExpr bndr occ) -- body + +{- +An example may be in order. Consider: +\begin{verbatim} +let t = \x -> \y -> ... x ... y ... p ... q in e +\end{verbatim} +Pulling out the free vars and stylising somewhat, we get the equivalent: +\begin{verbatim} +let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q +\end{verbatim} +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are +offsets from @Node@ into the closure, and the code ptr for the closure +will be exactly that in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but important): +-} + + | StgRhsCon + CostCentreStack -- CCS to be attached (default is CurrentCCS). + -- Top-level (static) ones will end up with + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS + -- from static closure. + DataCon -- constructor + [GenStgArg occ] -- args + +stgRhsArity :: StgRhs -> Int +stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) + = ASSERT( all isId bndrs ) length bndrs + -- The arity never includes type parameters, but they should have gone by now +stgRhsArity (StgRhsCon _ _ _) = 0 + +stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool +stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs +stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) + +rhsHasCafRefs :: GenStgRhs bndr Id -> Bool +rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) + = isUpdatable upd || nonEmptySRT srt +rhsHasCafRefs (StgRhsCon _ _ args) + = any stgArgHasCafRefs args + +stgArgHasCafRefs :: GenStgArg Id -> Bool +stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id) +stgArgHasCafRefs _ = False + +-- Here's the @StgBinderInfo@ type, and its combining op: + +data StgBinderInfo + = NoStgBinderInfo + | SatCallsOnly -- All occurrences are *saturated* *function* calls + -- This means we don't need to build an info table and + -- slow entry code for the thing + -- Thunks never get this value + +noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo +noBinderInfo = NoStgBinderInfo +stgUnsatOcc = NoStgBinderInfo +stgSatOcc = SatCallsOnly + +satCallsOnly :: StgBinderInfo -> Bool +satCallsOnly SatCallsOnly = True +satCallsOnly NoStgBinderInfo = False + +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo +combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly +combineStgBinderInfo _ _ = NoStgBinderInfo + +-------------- +pp_binder_info :: StgBinderInfo -> SDoc +pp_binder_info NoStgBinderInfo = empty +pp_binder_info SatCallsOnly = ptext (sLit "sat-only") + +{- +************************************************************************ +* * +\subsection[Stg-case-alternatives]{STG case alternatives} +* * +************************************************************************ + +Very like in @CoreSyntax@ (except no type-world stuff). + +The type constructor is guaranteed not to be abstract; that is, we can +see its representation. This is important because the code generator +uses it to determine return conventions etc. But it's not trivial +where there's a moduule loop involved, because some versions of a type +constructor might not have all the constructors visible. So +mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the +constructors or literals (which are guaranteed to have the Real McCoy) +rather than from the scrutinee type. +-} + +type GenStgAlt bndr occ + = (AltCon, -- alts: data constructor, + [bndr], -- constructor's parameters, + [Bool], -- "use mask", same length as + -- parameters; a True in a + -- param's position if it is + -- used in the ... + GenStgExpr bndr occ) -- ...right-hand side. + +data AltType + = PolyAlt -- Polymorphic (a type variable) + | UbxTupAlt Int -- Unboxed tuple of this arity + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts + +{- +************************************************************************ +* * +\subsection[Stg]{The Plain STG parameterisation} +* * +************************************************************************ + +This happens to be the only one we use at the moment. +-} + +type StgBinding = GenStgBinding Id Id +type StgArg = GenStgArg Id +type StgLiveVars = GenStgLiveVars Id +type StgExpr = GenStgExpr Id Id +type StgRhs = GenStgRhs Id Id +type StgAlt = GenStgAlt Id Id + +{- +************************************************************************ +* * +\subsubsection[UpdateFlag-datatype]{@UpdateFlag@} +* * +************************************************************************ + +This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. + +A @ReEntrant@ closure may be entered multiple times, but should not be +updated or blackholed. An @Updatable@ closure should be updated after +evaluation (and may be blackholed during evaluation). A @SingleEntry@ +closure will only be entered once, and so need not be updated but may +safely be blackholed. +-} + +data UpdateFlag = ReEntrant | Updatable | SingleEntry + +instance Outputable UpdateFlag where + ppr u = char $ case u of + ReEntrant -> 'r' + Updatable -> 'u' + SingleEntry -> 's' + +isUpdatable :: UpdateFlag -> Bool +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True + +{- +************************************************************************ +* * +\subsubsection{StgOp} +* * +************************************************************************ + +An StgOp allows us to group together PrimOps and ForeignCalls. +It's quite useful to move these around together, notably +in StgOpApp and COpStmt. +-} + +data StgOp + = StgPrimOp PrimOp + + | StgPrimCallOp PrimCall + + | StgFCallOp ForeignCall Unique + -- The Unique is occasionally needed by the C pretty-printer + -- (which lacks a unique supply), notably when generating a + -- typedef for foreign-export-dynamic + +{- +************************************************************************ +* * +\subsubsection[Static Reference Tables]{@SRT@} +* * +************************************************************************ + +There is one SRT per top-level function group. Each local binding and +case expression within this binding group has a subrange of the whole +SRT, expressed as an offset and length. + +In CoreToStg we collect the list of CafRefs at each SRT site, which is later +converted into the length and offset form by the SRT pass. +-} + +data SRT + = NoSRT + | SRTEntries IdSet + -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} + -- generated by computeSRTs + +nonEmptySRT :: SRT -> Bool +nonEmptySRT NoSRT = False +nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs) +nonEmptySRT _ = True + +pprSRT :: SRT -> SDoc +pprSRT (NoSRT) = ptext (sLit "_no_srt_") +pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids +pprSRT (SRT off _ _) = parens (ppr off <> comma <> text "*bitmap*") + +{- +************************************************************************ +* * +\subsection[Stg-pretty-printing]{Pretty-printing} +* * +************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's +hoping he likes terminators instead... Ditto for case alternatives. +-} + +pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) + => GenStgBinding bndr bdee -> SDoc + +pprGenStgBinding (StgNonRec bndr rhs) + = hang (hsep [pprBndr LetBind bndr, equals]) + 4 (ppr rhs <> semi) + +pprGenStgBinding (StgRec pairs) + = vcat $ ifPprDebug (ptext $ sLit "{- StgRec (begin) -}") : + map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] + where + ppr_bind (bndr, expr) + = hang (hsep [pprBndr LetBind bndr, equals]) + 4 (ppr expr <> semi) + +pprStgBinding :: StgBinding -> SDoc +pprStgBinding bind = pprGenStgBinding bind + +pprStgBindings :: [StgBinding] -> SDoc +pprStgBindings binds = vcat (map pprGenStgBinding binds) + +instance (Outputable bdee) => Outputable (GenStgArg bdee) where + ppr = pprStgArg + +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgBinding bndr bdee) where + ppr = pprGenStgBinding + +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgExpr bndr bdee) where + ppr = pprStgExpr + +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgRhs bndr bdee) where + ppr rhs = pprStgRhs rhs + +pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc +pprStgArg (StgVarArg var) = ppr var +pprStgArg (StgLitArg con) = ppr con + +pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) + => GenStgExpr bndr bdee -> SDoc +-- special case +pprStgExpr (StgLit lit) = ppr lit + +-- general case +pprStgExpr (StgApp func args) + = hang (ppr func) 4 (sep (map (ppr) args)) + +pprStgExpr (StgConApp con args) + = hsep [ ppr con, brackets (interppSP args)] + +pprStgExpr (StgOpApp op args _) + = hsep [ pprStgOp op, brackets (interppSP args)] + +pprStgExpr (StgLam bndrs body) + = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) + <+> ptext (sLit "->"), + pprStgExpr body ] + where ppr_list = brackets . fsep . punctuate comma + +-- special case: let v = +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +{- +pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + = ($$) + (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "), + ppr cc, + pp_binder_info bi, + ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), + ppr upd_flag, ptext (sLit " ["), + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, ptext (sLit "} in")]])) + (ppr expr) +-} + +-- special case: let ... in let ... + +pprStgExpr (StgLet bind expr@(StgLet _ _)) + = ($$) + (sep [hang (ptext (sLit "let {")) + 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])]) + (ppr expr) + +-- general case +pprStgExpr (StgLet bind expr) + = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind), + hang (ptext (sLit "} in ")) 2 (ppr expr)] + +pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) + = sep [hang (ptext (sLit "let-no-escape {")) + 2 (pprGenStgBinding bind), + hang (ptext (sLit "} in ") <> + ifPprDebug ( + nest 4 ( + hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + char ']']))) + 2 (ppr expr)] + +pprStgExpr (StgTick tickish expr) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprShowTicks dflags + then sep [ ppr tickish, pprStgExpr expr ] + else pprStgExpr expr + + +pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) + = sep [sep [ptext (sLit "case"), + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (dcolon <+> ppr alt_type)]), + ptext (sLit "of"), pprBndr CaseBind bndr, char '{'], + ifPprDebug ( + nest 4 ( + hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + ptext (sLit "]; "), + pprMaybeSRT srt])), + nest 2 (vcat (map pprStgAlt alts)), + char '}'] + +pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) + => GenStgAlt bndr occ -> SDoc +pprStgAlt (con, params, _use_mask, expr) + = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")]) + 4 (ppr expr <> semi) + +pprStgOp :: StgOp -> SDoc +pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgPrimCallOp op)= ppr op +pprStgOp (StgFCallOp op _) = ppr op + +instance Outputable AltType where + ppr PolyAlt = ptext (sLit "Polymorphic") + ppr (UbxTupAlt n) = ptext (sLit "UbxTup") <+> ppr n + ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc + ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc + +pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc +pprStgLVs lvs + = getPprStyle $ \ sty -> + if userStyle sty || isEmptyUniqSet lvs then + empty + else + hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] + +pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) + => GenStgRhs bndr bdee -> SDoc + +-- special case +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func [])) + = hcat [ ppr cc, + pp_binder_info bi, + brackets (ifPprDebug (ppr free_var)), + ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] + +-- general case +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) + = sdocWithDynFlags $ \dflags -> + hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, + pp_binder_info bi, + ifPprDebug (brackets (interppSP free_vars)), + char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) + 4 (ppr body) + +pprStgRhs (StgRhsCon cc con args) + = hcat [ ppr cc, + space, ppr con, ptext (sLit "! "), brackets (interppSP args)] + +pprMaybeSRT :: SRT -> SDoc +pprMaybeSRT (NoSRT) = empty +pprMaybeSRT srt = ptext (sLit "srt:") <> pprSRT srt diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs new file mode 100644 index 00000000..f1fe7f76 --- /dev/null +++ b/compiler/stranal/DmdAnal.hs @@ -0,0 +1,1210 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + + ----------------- + A demand analysis + ----------------- +-} + +{-# LANGUAGE CPP #-} + +module DmdAnal ( dmdAnalProgram ) where + +#include "HsVersions.h" + +import DynFlags +import WwLib ( findTypeShape, deepSplitProductType_maybe ) +import Demand -- All of it +import CoreSyn +import Outputable +import VarEnv +import BasicTypes +import FastString +import Data.List +import DataCon +import Id +import CoreUtils ( exprIsHNF, exprType, exprIsTrivial ) +import TyCon +import Type +import FamInstEnv +import Util +import Maybes ( isJust ) +import TysWiredIn ( unboxedPairDataCon ) +import TysPrim ( realWorldStatePrimTy ) +import ErrUtils ( dumpIfSet_dyn ) +import Name ( getName, stableNameCmp ) +import Data.Function ( on ) + +{- +************************************************************************ +* * +\subsection{Top level stuff} +* * +************************************************************************ +-} + +dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +dmdAnalProgram dflags fam_envs binds + = do { + let { binds_plus_dmds = do_prog binds } ; + dumpIfSet_dyn dflags Opt_D_dump_strsigs "Strictness signatures" $ + dumpStrSig binds_plus_dmds ; + return binds_plus_dmds + } + where + do_prog :: CoreProgram -> CoreProgram + do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds + +-- Analyse a (group of) top-level binding(s) +dmdAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +dmdAnalTopBind sigs (NonRec id rhs) + = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2) + where + ( _, _, _, rhs1) = dmdAnalRhs TopLevel Nothing sigs id rhs + (sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1 + -- Do two passes to improve CPR information + -- See comments with ignore_cpr_info in mk_sig_ty + -- and with extendSigsWithLam + +dmdAnalTopBind sigs (Rec pairs) + = (sigs', Rec pairs') + where + (sigs', _, pairs') = dmdFix TopLevel sigs pairs + -- We get two iterations automatically + -- c.f. the NonRec case above + +{- +************************************************************************ +* * +\subsection{The analyser itself} +* * +************************************************************************ + +Note [Ensure demand is strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important not to analyse e with a lazy demand because +a) When we encounter case s of (a,b) -> + we demand s with U(d1d2)... but if the overall demand is lazy + that is wrong, and we'd need to reduce the demand on s, + which is inconvenient +b) More important, consider + f (let x = R in x+x), where f is lazy + We still want to mark x as demanded, because it will be when we + enter the let. If we analyse f's arg with a Lazy demand, we'll + just mark x as Lazy +c) The application rule wouldn't be right either + Evaluating (f x) in a L demand does *not* cause + evaluation of f in a C(L) demand! +-} + +-- If e is complicated enough to become a thunk, its contents will be evaluated +-- at most once, so oneify it. +dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand +dmdTransformThunkDmd e + | exprIsTrivial e = id + | otherwise = oneifyDmd + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See |-* relation in the companion paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr -> (BothDmdArg, CoreExpr) +dmdAnalStar env dmd e + | (cd, defer_and_use) <- toCleanDmd dmd (exprType e) + , (dmd_ty, e') <- dmdAnal env cd e + = (postProcessDmdTypeM defer_and_use dmd_ty, e') + +-- Main Demand Analsysis machinery +dmdAnal, dmdAnal' :: AnalEnv + -> CleanDemand -- The main one takes a *CleanDemand* + -> CoreExpr -> (DmdType, CoreExpr) + +-- The CleanDemand is always strict and not absent +-- See Note [Ensure demand is strict] + +dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ + dmdAnal' env d e + +dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit) +dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = (nopDmdType, Coercion co) + +dmdAnal' env dmd (Var var) + = (dmdTransform env var dmd, Var var) + +dmdAnal' env dmd (Cast e co) + = (dmd_ty, Cast e' co) + where + (dmd_ty, e') = dmdAnal env dmd e + +{- ----- I don't get this, so commenting out ------- + to_co = pSnd (coercionKind co) + dmd' + | Just tc <- tyConAppTyCon_maybe to_co + , isRecursiveTyCon tc = cleanEvalDmd + | otherwise = dmd + -- This coerce usually arises from a recursive + -- newtype, and we don't want to look inside them + -- for exactly the same reason that we don't look + -- inside recursive products -- we might not reach + -- a fixpoint. So revert to a vanilla Eval demand +-} + +dmdAnal' env dmd (Tick t e) + = (dmd_ty, Tick t e') + where + (dmd_ty, e') = dmdAnal env dmd e + +dmdAnal' env dmd (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = dmdAnal env dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal' env dmd (App fun arg) + = -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (Trac #10288) + let + call_dmd = mkCallDmd dmd + (fun_ty, fun') = dmdAnal env call_dmd fun + (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg + in +-- pprTrace "dmdAnal:app" (vcat +-- [ text "dmd =" <+> ppr dmd +-- , text "expr =" <+> ppr (App fun arg) +-- , text "fun dmd_ty =" <+> ppr fun_ty +-- , text "arg dmd =" <+> ppr arg_dmd +-- , text "arg dmd_ty =" <+> ppr arg_ty +-- , text "res dmd_ty =" <+> ppr res_ty +-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) + (res_ty `bothDmdType` arg_ty, App fun' arg') + +-- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@ +dmdAnal' env dmd (Lam var body) + | isTyVar var + = let + (body_ty, body') = dmdAnal env dmd body + in + (body_ty, Lam var body') + + | otherwise + = let (body_dmd, defer_and_use@(_,one_shot)) = peelCallDmd dmd + -- body_dmd - a demand to analyze the body + -- one_shot - one-shotness of the lambda + -- hence, cardinality of its free vars + + env' = extendSigsWithLam env var + (body_ty, body') = dmdAnal env' body_dmd body + (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty one_shot var + in + (postProcessUnsat defer_and_use lam_ty, Lam var' body') + +dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) + -- Only one alternative with a product constructor + | let tycon = dataConTyCon dc + , isProductTyCon tycon + , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon + = let + env_w_tc = env { ae_rec_tc = rec_tc' } + env_alt = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig + case_bndr_sig = cprProdSig (dataConRepArity dc) + -- cprProdSig: inside the alternative, the case binder has the CPR property. + -- Meaning that a case on it will successfully cancel. + -- Example: + -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 } + -- f False x = I# 3 + -- + -- We want f to have the CPR property: + -- f b x = case fw b x of { r -> I# r } + -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + -- fw False x = 3 + + (rhs_ty, rhs') = dmdAnal env_alt dmd rhs + (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs + (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + alt_ty3 | io_hack_reqd dc bndrs = deferAfterIO alt_ty2 + | otherwise = alt_ty2 + + -- Compute demand on the scrutinee + -- See Note [Demand on scrutinee of a product case] + scrut_dmd = mkProdDmd (addDataConStrictness dc id_dmds) + (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut + res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty + case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + bndrs' = setBndrsDemandInfo bndrs id_dmds + in +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "dmd" <+> ppr dmd +-- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') +-- , text "scrut_dmd" <+> ppr scrut_dmd +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) + +dmdAnal' env dmd (Case scrut case_bndr ty alts) + = let -- Case expression with multiple alternatives + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts + (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut + (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr + res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty + in +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_tys" <+> ppr alt_tys +-- , text "alt_ty" <+> ppr alt_ty +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty alts') + +dmdAnal' env dmd (Let (NonRec id rhs) body) + = (body_ty2, Let (NonRec id2 annotated_rhs) body') + where + (sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs + (body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body + (body_ty1, id2) = annotateBndr env body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv + + -- Annotate top-level lambdas at RHS basing on the aggregated demand info + -- See Note [Annotating lambdas at right-hand side] + annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs' + + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + +dmdAnal' env dmd (Let (Rec pairs) body) + = let + (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs + (body_ty, body') = dmdAnal env' dmd body + body_ty1 = deleteFVs body_ty (map fst pairs) + body_ty2 = addLazyFVs body_ty1 lazy_fv + in + body_ty2 `seq` + (body_ty2, Let (Rec pairs') body') + +io_hack_reqd :: DataCon -> [Var] -> Bool +-- Note [IO hack in the demand analyser] +-- +-- There's a hack here for I/O operations. Consider +-- case foo x s of { (# s, r #) -> y } +-- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O +-- operation that simply terminates the program (not in an erroneous way)? +-- In that case we should not evaluate y before the call to 'foo'. +-- Hackish solution: spot the IO-like situation and add a virtual branch, +-- as if we had +-- case foo x s of +-- (# s, r #) -> y +-- other -> return () +-- So the 'y' isn't necessarily going to be evaluated +-- +-- A more complete example (Trac #148, #1592) where this shows up is: +-- do { let len = ; +-- ; when (...) (exitWith ExitSuccess) +-- ; print len } +io_hack_reqd con bndrs + | (bndr:_) <- bndrs + = con == unboxedPairDataCon && + idType bndr `eqType` realWorldStatePrimTy + | otherwise + = False + +annLamWithShotness :: Demand -> CoreExpr -> CoreExpr +annLamWithShotness d e + | Just u <- cleanUseDmd_maybe d + = go u e + | otherwise = e + where + go u e + | Just (c, u') <- peelUseCall u + , Lam bndr body <- e + = if isTyVar bndr + then Lam bndr (go u body) + else Lam (setOneShotness c bndr) (go u' body) + | otherwise + = e + +setOneShotness :: Count -> Id -> Id +setOneShotness One bndr = setOneShotLambda bndr +setOneShotness Many bndr = bndr + +dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) +dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) + | null bndrs -- Literals, DEFAULT, and nullary constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + = (rhs_ty, (con, [], rhs')) + + | otherwise -- Non-nullary data constructors + , (rhs_ty, rhs') <- dmdAnal env dmd rhs + , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs + , let case_bndr_dmd = findIdDemand alt_ty case_bndr + id_dmds = addCaseBndrDmd case_bndr_dmd dmds + = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) + +{- Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When figuring out the demand on the scrutinee of a product case, +we use the demands of the case alternative, i.e. id_dmds. +But note that these include the demand on the case binder; +see Note [Demand on case-alternative binders] in Demand.hs. +This is crucial. Example: + f x = case x of y { (a,b) -> k y a } +If we just take scrut_demand = U(L,A), then we won't pass x to the +worker, so the worker will rebuild + x = (a, absent-error) +and that'll crash. + +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + +Note [Annotating lambdas at right-hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Let us take a look at the following example: + +g f = let x = 100 + h = \y -> f x y + in h 5 + +One can see that |h| is called just once, therefore the RHS of h can +be annotated as a one-shot lambda. This is done by the function +annLamWithShotness *a posteriori*, i.e., basing on the aggregated +usage demand on |h| from the body of |let|-expression, which is C1(U) +in this case. + +In other words, for locally-bound lambdas we can infer +one-shotness. +-} + + +{- +Note [Add demands for strict constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo (X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' too look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time +around the 'go' loop (which would otherwise happen, since 'foo' is not +strict in 'a'). It is sound for the wrapper to pass an unboxed arg +because X is strict, so its argument must be evaluated. And if we +*don't* pass an unboxed argument, we can't even repair it by adding a +`seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + +We add these extra strict demands to the demand on the *scrutinee* of +the case expression; hence the use of addDataConStrictness when +forming scrut_dmd. The case alternatives aren't strict in their +sub-components, but simply evaluating the scrutinee to HNF does force +those sub-components. + + +************************************************************************ +* * + Demand transformer +* * +************************************************************************ +-} + +dmdTransform :: AnalEnv -- The strictness environment + -> Id -- The function + -> CleanDemand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform env var dmd + | isDataConWorkId var -- Data constructor + = dmdTransformDataConSig (idArity var) (idStrictness var) dmd + + | gopt Opt_DmdTxDictSel (ae_dflags env), + Just _ <- isClassOpId_maybe var -- Dictionary component selector + = dmdTransformDictSelSig (idStrictness var) dmd + + | isGlobalId var -- Imported function + = let res = dmdTransformSig (idStrictness var) dmd in +-- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + res + + | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing + , let fn_ty = dmdTransformSig sig dmd + = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ + if isTopLevel top_lvl + then fn_ty -- Don't record top level things + else addVarDmd fn_ty var (mkOnceUsedDmd dmd) + + | otherwise -- Local non-letrec-bound thing + = unitVarDmd var (mkOnceUsedDmd dmd) + +{- +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, + [(Id,CoreExpr)]) -- Binders annotated with stricness info + +dmdFix top_lvl env orig_pairs + = (updSigEnv env (sigEnv final_env), lazy_fv, pairs') + -- Return to original virgin state, keeping new signatures + where + bndrs = map fst orig_pairs + initial_env = addInitialSigs top_lvl env bndrs + (final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs + + loop :: Int + -> AnalEnv -- Already contains the current sigs + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n env pairs + = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $ + loop' n env pairs + + loop' n env pairs + | found_fixpoint + = (env', lazy_fv, pairs') + -- Note: return pairs', not pairs. pairs' is the result of + -- processing the RHSs with sigs (= sigs'), whereas pairs + -- is the result of processing the RHSs with the *previous* + -- iteration of sigs. + + | n >= 10 + = -- pprTrace "dmdFix loop" (ppr n <+> (vcat + -- [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id, + -- lookupVarEnv (sigEnv env') id) + -- | (id,_) <- pairs], + -- text "env:" <+> ppr env, + -- text "binds:" <+> pprCoreBinding (Rec pairs)])) + (env, lazy_fv, orig_pairs) -- Safe output + -- The lazy_fv part is really important! orig_pairs has no strictness + -- info, including nothing about free vars. But if we have + -- letrec f = ....y..... in ...f... + -- where 'y' is free in f, we must record that y is mentioned, + -- otherwise y will get recorded as absent altogether + + | otherwise + = loop (n+1) (nonVirgin env') pairs' + where + found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs + + ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, lazy_fv) (id,rhs) + = ((env', lazy_fv'), (id', rhs')) + where + (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id sig + + same_sig sigs sigs' var = lookup sigs var == lookup sigs' var + lookup sigs var = case lookupVarEnv sigs var of + Just (sig,_) -> sig + Nothing -> pprPanic "dmdFix" (ppr var) + +-- Non-recursive bindings +dmdAnalRhs :: TopLevelFlag + -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive + -> AnalEnv -> Id -> CoreExpr + -> (StrictSig, DmdEnv, Id, CoreExpr) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. +dmdAnalRhs top_lvl rec_flag env id rhs + | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] + , let fn_str = getStrictness env fn + fn_fv | isLocalId fn = unitVarEnv fn topDmd + | otherwise = emptyDmdEnv + -- Note [Remember to demand the function itself] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- fn_fv: don't forget to produce a demand for fn itself + -- Lacking this caused Trac #9128 + -- The demand is very conservative (topDmd), but that doesn't + -- matter; trivial bindings are usually inlined, so it only + -- kicks in for top-level bindings and NOINLINE bindings + = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs) + + | otherwise + = (sig_ty, lazy_fv, id', mkLams bndrs' body') + where + (bndrs, body) = collectBinders rhs + env_body = foldl extendSigsWithLam env bndrs + (body_ty, body') = dmdAnal env_body body_dmd body + body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info + (DmdType rhs_fv rhs_dmds rhs_res, bndrs') + = annotateLamBndrs env (isDFunId id) body_ty' bndrs + sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res') + id' = set_idStrictness env id sig_ty + -- See Note [NOINLINE and strictness] + + -- See Note [Product demands for function body] + body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of + Nothing -> cleanEvalDmd + Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc) + + -- See Note [Lazy and unleashable free variables] + -- See Note [Aggregated demand for cardinality] + rhs_fv1 = case rec_flag of + Just bs -> reuseEnv (delVarEnvList rhs_fv bs) + Nothing -> rhs_fv + + (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 + + rhs_res' = trimCPRInfo trim_all trim_sums rhs_res + trim_all = is_thunk && not_strict + trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types] + + -- See Note [CPR for thunks] + is_thunk = not (exprIsHNF rhs) + not_strict + = isTopLevel top_lvl -- Top level and recursive things don't + || isJust rec_flag -- get their demandInfo set at all + || not (isStrictDmd (idDemandInfo id) || ae_virgin env) + -- See Note [Optimistic CPR in the "virgin" case] + +unpackTrivial :: CoreExpr -> Maybe Id +-- Returns (Just v) if the arg is really equal to v, modulo +-- casts, type applications etc +-- See Note [Demand analysis for trivial right-hand sides] +unpackTrivial (Var v) = Just v +unpackTrivial (Cast e _) = unpackTrivial e +unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e +unpackTrivial (App e a) | isTypeArg a = unpackTrivial e +unpackTrivial _ = Nothing + +{- +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a +special case for right-hand sides that are "trivial", namely variables, +casts, type applications, and the like. + +Note that this can mean that 'foo' has an arity that is smaller than that +indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then +foo's arity will be zero (see Note [exprArity invariant] in CoreArity), +but its demand signature will be that of plusInt. A small example is the +test case of Trac #8963. + + +Note [Product demands for function body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This example comes from shootout/binary_trees: + + Main.check' = \ b z ds. case z of z' { I# ip -> + case ds_d13s of + Main.Nil -> z' + Main.Node s14k s14l s14m -> + Main.check' (not b) + (Main.check' b + (case b { + False -> I# (-# s14h s14k); + True -> I# (+# s14h s14k) + }) + s14l) + s14m } } } + +Here we *really* want to unbox z, even though it appears to be used boxed in +the Nil case. Partly the Nil case is not a hot path. But more specifically, +the whole function gets the CPR property if we do. + +So for the demand on the body of a RHS we use a product demand if it's +a product type. + +************************************************************************ +* * +\subsection{Strictness signatures and types} +* * +************************************************************************ +-} + +unitVarDmd :: Var -> Demand -> DmdType +unitVarDmd var dmd + = DmdType (unitVarEnv var dmd) [] topRes + +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds res) var dmd + = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res + +addLazyFVs :: DmdType -> DmdEnv -> DmdType +addLazyFVs dmd_ty lazy_fvs + = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs + -- Using bothDmdType (rather than just both'ing the envs) + -- is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the lazy_fv filtering in dmdAnalRhs. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- L demand doesn't get both'd with the Bot coming up from the inner + -- call to f. So we just get an L demand for x for g. + +{- +Note [Do not strictify the argument dictionaries of a dfun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving dfuns, so we do the +conservative thing and refrain from strictifying a dfun's argument +dictionaries. +-} + +setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] +setBndrsDemandInfo (b:bs) (d:ds) + | isTyVar b = b : setBndrsDemandInfo bs (d:ds) + | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds +setBndrsDemandInfo [] ds = ASSERT( null ds ) [] +setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) + +annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) +-- The returned env has the var deleted +-- The returned var is annotated with demand info +-- according to the result demand of the provided demand type +-- No effect on the argument demands +annotateBndr env dmd_ty var + | isId var = (dmd_ty', setIdDemandInfo var dmd) + | otherwise = (dmd_ty, var) + where + (dmd_ty', dmd) = findBndrDmd env False dmd_ty var + +annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var]) +annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs + where + annotate dmd_ty bndr + | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty Many bndr + | otherwise = (dmd_ty, bndr) + +annotateLamIdBndr :: AnalEnv + -> DFunFlag -- is this lambda at the top of the RHS of a dfun? + -> DmdType -- Demand type of body + -> Count -- One-shot-ness of the lambda + -> Id -- Lambda binder + -> (DmdType, -- Demand type of lambda + Id) -- and binder annotated with demand + +annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = ASSERT( isId id ) + -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ + (final_ty, setOneShotness one_shot (setIdDemandInfo id dmd)) + where + -- Watch out! See note [Lambda-bound unfoldings] + final_ty = case maybeUnfoldingTemplate (idUnfolding id) of + Nothing -> main_ty + Just unf -> main_ty `bothDmdType` unf_ty + where + (unf_ty, _) = dmdAnalStar env dmd unf + + main_ty = addDemand dmd dmd_ty' + (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id + +deleteFVs :: DmdType -> [Var] -> DmdType +deleteFVs (DmdType fvs dmds res) bndrs + = DmdType (delVarEnvList fvs bndrs) dmds res + +{- +Note [CPR for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we do not do CPR for let-bindings that + * non-top level + * bind a sum type +Reason: I found that in some benchmarks we were losing let-no-escapes, +which messed it all up. Example + let j = \x. .... + in case y of + True -> j False + False -> j True +If we w/w this we get + let j' = \x. .... + in case y of + True -> case j' False of { (# a #) -> Just a } + False -> case j' True of { (# a #) -> Just a } +Notice that j' is not a let-no-escape any more. + +However this means in turn that the *enclosing* function +may be CPR'd (via the returned Justs). But in the case of +sums, there may be Nothing alternatives; and that messes +up the sum-type CPR. + +Conclusion: only do this for products. It's still not +guaranteed OK for products, but sums definitely lose sometimes. + +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function). E.g. + + let r = case expensive of + (a,b) -> (b,a) + in ... + +If we marked r as having the CPR property, then we'd w/w into + + let $wr = \() -> case expensive of + (a,b) -> (# b, a #) + r = case $wr () of + (# b,a #) -> (b,a) + in ... + +But now r is a thunk, which won't be inlined, so we are no further ahead. +But consider + + f x = let r = case expensive of (a,b) -> (b,a) + in if foo r then r else (x,x) + +Does f have the CPR property? Well, no. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +The difficulty with this is that we need the strictness type to +look at the body... but we now need the body to calculate the demand +on the variable, so we can decide whether its strictness type should +have a CPR in it or not. Simple solution: + a) use strictness info from the previous iteration + b) make sure we do at least 2 iterations, by doing a second + round for top-level non-recs. Top level recs will get at + least 2 iterations except for totally-bottom functions + which aren't very interesting anyway. + +NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. + +Note [Optimistic CPR in the "virgin" case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand and strictness info are initialized by top elements. However, +this prevents from inferring a CPR property in the first pass of the +analyser, so we keep an explicit flag ae_virgin in the AnalEnv +datatype. + +We can't start with 'not-demanded' (i.e., top) because then consider + f x = let + t = ... I# x + in + if ... then t else I# y else f x' + +In the first iteration we'd have no demand info for x, so assume +not-demanded; then we'd get TopRes for f's CPR info. Next iteration +we'd see that t was demanded, and so give it the CPR property, but by +now f has TopRes, so it will stay TopRes. Instead, by checking the +ae_virgin flag at the first time round, we say 'yes t is demanded' the +first time. + +However, this does mean that for non-recursive bindings we must +iterate twice to be sure of not getting over-optimistic CPR info, +in the case where t turns out to be not-demanded. This is handled +by dmdAnalTopBind. + + +Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The strictness analyser used to have a HACK which ensured that NOINLNE +things were not strictness-analysed. The reason was unsafePerformIO. +Left to itself, the strictness analyser would discover this strictness +for unsafePerformIO: + unsafePerformIO: C(U(AV)) +But then consider this sub-expression + unsafePerformIO (\s -> let r = f x in + case writeIORef v r s of (# s1, _ #) -> + (# s1, r #) +The strictness analyser will now find that r is sure to be eval'd, +and may then hoist it out. This makes tests/lib/should_run/memo002 +deadlock. + +Solving this by making all NOINLINE things have no strictness info is overkill. +In particular, it's overkill for runST, which is perfectly respectable. +Consider + f x = runST (return x) +This should be strict in x. + +So the new plan is to define unsafePerformIO using the 'lazy' combinator: + + unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is +magically NON-STRICT, and is inlined after strictness analysis. So +unsafePerformIO will look non-strict, and that's what we want. + +Now we don't need the hack in the strictness analyser. HOWEVER, this +decision does mean that even a NOINLINE function is not entirely +opaque: some aspect of its implementation leaks out, notably its +strictness. For example, if you have a function implemented by an +error stub, but which has RULES, you may want it not to be eliminated +in favour of error! + +Note [Lazy and unleasheable free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We put the strict and once-used FVs in the DmdType of the Id, so +that at its call sites we unleash demands on its strict fvs. +An example is 'roll' in imaginary/wheel-sieve2 +Something like this: + roll x = letrec + go y = if ... then roll (x-1) else x+1 + in + go ms +We want to see that roll is strict in x, which is because +go is called. So we put the DmdEnv for x in go's DmdType. + +Another example: + + f :: Int -> Int -> Int + f x y = let t = x+1 + h z = if z==0 then t else + if z==1 then x+1 else + x + h (z-1) + in h y + +Calling h does indeed evaluate x, but we can only see +that if we unleash a demand on x at the call site for t. + +Incidentally, here's a place where lambda-lifting h would +lose the cigar --- we couldn't see the joint strictness in t/x + + ON THE OTHER HAND +We don't want to put *all* the fv's from the RHS into the +DmdType, because that makes fixpointing very slow --- the +DmdType gets full of lazy demands that are slow to converge. + + +Note [Lamba-bound unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a lambda-bound variable to carry an unfolding, a facility that is used +exclusively for join points; see Note [Case binders and join points]. If so, +we must be careful to demand-analyse the RHS of the unfolding! Example + \x. \y{=Just x}. +Then if uses 'y', then transitively it uses 'x', and we must not +forget that fact, otherwise we might make 'x' absent when it isn't. + + +************************************************************************ +* * +\subsection{Strictness signatures} +* * +************************************************************************ +-} + +type DFunFlag = Bool -- indicates if the lambda being considered is in the + -- sequence of lambdas at the top of the RHS of a dfun +notArgOfDfun :: DFunFlag +notArgOfDfun = False + +data AnalEnv + = AE { ae_dflags :: DynFlags + , ae_sigs :: SigEnv + , ae_virgin :: Bool -- True on first iteration only + -- See Note [Initialising strictness] + , ae_rec_tc :: RecTcChecker + , ae_fam_envs :: FamInstEnvs + } + + -- We use the se_env to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +type SigEnv = VarEnv (StrictSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = ptext (sLit "AE") <+> braces (vcat + [ ptext (sLit "ae_virgin =") <+> ppr virgin + , ptext (sLit "ae_sigs =") <+> ppr env ]) + +emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv +emptyAnalEnv dflags fam_envs + = AE { ae_dflags = dflags + , ae_sigs = emptySigEnv + , ae_virgin = True + , ae_rec_tc = initRecTc + , ae_fam_envs = fam_envs + } + +emptySigEnv :: SigEnv +emptySigEnv = emptyVarEnv + +sigEnv :: AnalEnv -> SigEnv +sigEnv = ae_sigs + +updSigEnv :: AnalEnv -> SigEnv -> AnalEnv +updSigEnv env sigs = env { ae_sigs = sigs } + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +getStrictness :: AnalEnv -> Id -> StrictSig +getStrictness env fn + | isGlobalId fn = idStrictness fn + | Just (sig, _) <- lookupSigEnv env fn = sig + | otherwise = nopSig + +addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +-- See Note [Initialising strictness] +addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids + = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl)) + | id <- ids ] } + where + init_sig | virgin = \_ -> botSig + | otherwise = idStrictness + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +extendSigsWithLam :: AnalEnv -> Id -> AnalEnv +-- Extend the AnalEnv when we meet a lambda binder +extendSigsWithLam env id + | isId id + , isStrictDmd (idDemandInfo id) || ae_virgin env + -- See Note [Optimistic CPR in the "virgin" case] + -- See Note [Initial CPR for strict binders] + , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id + = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) + + | otherwise + = env + +addDataConStrictness :: DataCon -> [Demand] -> [Demand] +-- See Note [Add demands for strict constructors] +addDataConStrictness con ds + = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds ) + zipWith add ds strs + where + strs = dataConRepStrictness con + add dmd str | isMarkedStrict str = dmd `bothDmd` seqDmd + | otherwise = dmd + -- Yes, even if 'dmd' is Absent! + +findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) +-- Return the demands on the Ids in the [Var] +findBndrsDmds env dmd_ty bndrs + = go dmd_ty bndrs + where + go dmd_ty [] = (dmd_ty, []) + go dmd_ty (b:bs) + | isId b = let (dmd_ty1, dmds) = go dmd_ty bs + (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b + in (dmd_ty2, dmd : dmds) + | otherwise = go dmd_ty bs + +findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) +-- See Note [Trimming a demand to a type] in Demand.lhs +findBndrDmd env arg_of_dfun dmd_ty id + = (dmd_ty', dmd') + where + dmd' = killUsageDemand (ae_dflags env) $ + strictify $ + trimToType starting_dmd (findTypeShape fam_envs id_ty) + + (dmd_ty', starting_dmd) = peelFV dmd_ty id + + id_ty = idType id + + strictify dmd + | gopt Opt_DictsStrict (ae_dflags env) + -- We never want to strictify a recursive let. At the moment + -- annotateBndr is only call for non-recursive lets; if that + -- changes, we need a RecFlag parameter and another guard here. + , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] + = strictifyDictDmd id_ty dmd + | otherwise + = dmd + + fam_envs = ae_fam_envs env + +set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id +set_idStrictness env id sig + = setIdStrictness id (killUsageSig (ae_dflags env) sig) + +dumpStrSig :: CoreProgram -> SDoc +dumpStrSig binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id) + | otherwise = empty + +{- +Note [Initial CPR for strict binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CPR is initialized for a lambda binder in an optimistic manner, i.e, +if the binder is used strictly and at least some of its components as +a product are used, which is checked by the value of the absence +demand. + +If the binder is marked demanded with a strict demand, then give it a +CPR signature, because in the likely event that this is a lambda on a +fn defn [we only use this when the lambda is being consumed with a +call demand], it'll be w/w'd and so it will be CPR-ish. E.g. + + f = \x::(Int,Int). if ...strict in x... then + x + else + (a,b) +We want f to have the CPR property because x does, by the time f has been w/w'd + +Also note that we only want to do this for something that definitely +has product type, else we may get over-optimistic CPR results +(e.g. from \x -> x!). + + +Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See section 9.2 (Finding fixpoints) of the paper. + +Our basic plan is to initialise the strictness of each Id in a +recursive group to "bottom", and find a fixpoint from there. However, +this group B might be inside an *enclosing* recursiveb group A, in +which case we'll do the entire fixpoint shebang on for each iteration +of A. This can be illustrated by the following example: + +Example: + + f [] = [] + f (x:xs) = let g [] = f xs + g (y:ys) = y+1 : g ys + in g (h x) + +At each iteration of the fixpoint for f, the analyser has to find a +fixpoint for the enclosed function g. In the meantime, the demand +values for g at each iteration for f are *greater* than those we +encountered in the previous iteration for f. Therefore, we can begin +the fixpoint for g not with the bottom value but rather with the +result of the previous analysis. I.e., when beginning the fixpoint +process for g, we can start from the demand signature computed for g +previously and attached to the binding occurrence of g. + +To speed things up, we initialise each iteration of A (the enclosing +one) from the result of the last one, which is neatly recorded in each +binder. That way we make use of earlier iterations of the fixpoint +algorithm. (Cunning plan.) + +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. +-} diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs new file mode 100644 index 00000000..7a94c1b3 --- /dev/null +++ b/compiler/stranal/WorkWrap.hs @@ -0,0 +1,478 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} +-} + +{-# LANGUAGE CPP #-} +module WorkWrap ( wwTopBinds ) where + +import CoreSyn +import CoreUnfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) +import CoreUtils ( exprType, exprIsHNF ) +import CoreArity ( exprArity ) +import Var +import Id +import IdInfo +import UniqSupply +import BasicTypes +import DynFlags +import VarEnv ( isEmptyVarEnv ) +import Demand +import WwLib +import Util +import Outputable +import FamInstEnv +import MonadUtils + +#include "HsVersions.h" + +{- +We take Core bindings whose binders have: + +\begin{enumerate} + +\item Strictness attached (by the front-end of the strictness +analyser), and / or + +\item Constructed Product Result information attached by the CPR +analysis pass. + +\end{enumerate} + +and we return some ``plain'' bindings which have been +worker/wrapper-ified, meaning: + +\begin{enumerate} + +\item Functions have been split into workers and wrappers where +appropriate. If a function has both strictness and CPR properties +then only one worker/wrapper doing both transformations is produced; + +\item Binders' @IdInfos@ have been updated to reflect the existence of +these workers/wrappers (this is where we get STRICTNESS and CPR pragma +info for exported values). +\end{enumerate} +-} + +wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram + +wwTopBinds dflags fam_envs us top_binds + = initUs_ us $ do + top_binds' <- mapM (wwBind dflags fam_envs) top_binds + return (concat top_binds') + +{- +************************************************************************ +* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +* * +************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... +-} + +wwBind :: DynFlags + -> FamInstEnvs + -> CoreBind + -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind dflags fam_envs (NonRec binder rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs + return [NonRec b e | (b,e) <- new_pairs] + -- Generated bindings must be non-recursive + -- because the original binding was. + +wwBind dflags fam_envs (Rec pairs) + = return . Rec <$> concatMapM do_one pairs + where + do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs + tryWW dflags fam_envs Recursive binder new_rhs + +{- +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. +-} + +wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr + +wwExpr _ _ e@(Type {}) = return e +wwExpr _ _ e@(Coercion {}) = return e +wwExpr _ _ e@(Lit {}) = return e +wwExpr _ _ e@(Var {}) = return e + +wwExpr dflags fam_envs (Lam binder expr) + = Lam binder <$> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (App f a) + = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a + +wwExpr dflags fam_envs (Tick note expr) + = Tick note <$> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Cast expr co) = do + new_expr <- wwExpr dflags fam_envs expr + return (Cast new_expr co) + +wwExpr dflags fam_envs (Let bind expr) + = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr + +wwExpr dflags fam_envs (Case expr binder ty alts) = do + new_expr <- wwExpr dflags fam_envs expr + new_alts <- mapM ww_alt alts + return (Case new_expr binder ty new_alts) + where + ww_alt (con, binders, rhs) = do + new_rhs <- wwExpr dflags fam_envs rhs + return (con, binders, new_rhs) + +{- +************************************************************************ +* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +* * +************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +The only reason this is monadised is for the unique supply. + +Note [Don't w/w INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to refrain from w/w-ing an INLINE function (ie one +with a stable unfolding) because the wrapper will then overwrite the +old stable unfolding with the wrapper code. + +Furthermore, if the programmer has marked something as INLINE, +we may lose by w/w'ing it. + +If the strictness analyser is run twice, this test also prevents +wrappers (which are INLINEd) from being re-done. (You can end up with +several liked-named Ids bouncing around at the same time---absolute +mischief.) + +Notice that we refrain from w/w'ing an INLINE function even if it is +in a recursive group. It might not be the loop breaker. (We could +test for loop-breaker-hood, but I'm not sure that ever matters.) + +Note [Worker-wrapper for INLINABLE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int -> a + f x y = ....f.... + +where f is strict in y, we might get a more efficient loop by w/w'ing +f. But that would make a new unfolding which would overwrite the old +one! So the function would no longer be ININABLE, and in particular +will not be specialised at call sites in other modules. + +This comes in practice (Trac #6056). + +Solution: do the w/w for strictness analysis, but transfer the Stable +unfolding to the *worker*. So we will get something like this: + + {-# INLINE[0] f #-} + f :: Ord a => [a] -> Int -> a + f d x y = case y of I# y' -> fw d x y' + + {-# INLINABLE[0] fw #-} + fw :: Ord a => [a] -> Int# -> a + fw d x y' = let y = I# y' in ...f... + +How do we "transfer the unfolding"? Easy: by using the old one, wrapped +in work_fn! See CoreUnfold.mkWorkerUnfolding. + +Note [Activation for INLINABLE worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Follows on from Note [Worker-wrapper for INLINABLE functions] +It is *vital* that if the worker gets an INLINABLE pragma (from the +original function), then the worker has the same phase activation as +the wrapper (or later). That is necessary to allow the wrapper to +inline into the worker's unfolding: see SimplUtils +Note [Simplifying inside stable unfoldings]. + +Notihng is lost by giving the worker the same activation as the +worker, because the worker won't have any chance of inlining until the +wrapper does; there's no point in giving it an earlier activation. + +Note [Don't w/w inline small non-loop-breaker things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we refrain from w/w-ing *small* functions, which are not +loop breakers, because they'll inline anyway. But we must take care: +it may look small now, but get to be big later after other inlining +has happened. So we take the precaution of adding an INLINE pragma to +any such functions. + +I made this change when I observed a big function at the end of +compilation with a useful strictness signature but no w-w. (It was +small during demand analysis, we refrained from w/w, and then got big +when something was inlined in its rhs.) When I measured it on nofib, +it didn't make much difference; just a few percent improved allocation +on one benchmark (bspt/Euclid.space). But nothing got worse. + +There is an infelicity though. We may get something like + f = g val +==> + g x = case gw x of r -> I# r + + f {- InlineStable, Template = g val -} + f = case gw x of r -> I# r + +The code for f duplicates that for g, without any real benefit. It +won't really be executed, because calls to f will go via the inlining. + +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? It must not be active +earlier than the current Activation of the Id (eg it might have a +NOINLINE pragma). But in fact strictness analysis happens fairly +late in the pipeline, and we want to prioritise specialisations over +strictness. Eg if we have + module Foo where + f :: Num a => a -> Int -> a + f n 0 = n -- Strict in the Int, hence wrapper + f n x = f (n+n) (x-1) + + g :: Int -> Int + g x = f x x -- Provokes a specialisation for f + + module Bar where + import Foo + + h :: Int -> Int + h x = f 3 x + +Then we want the specialisation for 'f' to kick in before the wrapper does. + +Now in fact the 'gentle' simplification pass encourages this, by +having rules on, but inlinings off. But that's kind of lucky. It seems +more robust to give the wrapper an Activation of (ActiveAfter 0), +so that it becomes active in an importing module at the same time that +it appears in the first place in the defining module. + +At one stage I tried making the wrapper inlining always-active, and +that had a very bad effect on nofib/imaginary/x2n1; a wrapper was +inlined before the specialisation fired. +-} + +tryWW :: DynFlags + -> FamInstEnvs + -> RecFlag + -> Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards + -- are already ww'd + -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW dflags fam_envs is_rec fn_id rhs + | isNeverActive inline_act + -- No point in worker/wrappering if the thing is never inlined! + -- Because the no-inline prag will prevent the wrapper ever + -- being inlined at a call site. + -- + -- Furthermore, don't even expose strictness info + = return [ (fn_id, rhs) ] + + | not loop_breaker + , Just stable_unf <- certainlyWillInline dflags fn_unf + = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] + -- Note [Don't w/w inline small non-loop-breaker, or INLINE, things] + -- NB: use idUnfolding because we don't want to apply + -- this criterion to a loop breaker! + + | is_fun + = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs + + | is_thunk -- See Note [Thunk splitting] + = splitThunk dflags fam_envs is_rec new_fn_id rhs + + | otherwise + = return [ (new_fn_id, rhs) ] + + where + loop_breaker = isStrongLoopBreaker (occInfo fn_info) + fn_info = idInfo fn_id + inline_act = inlinePragmaActivation (inlinePragInfo fn_info) + fn_unf = unfoldingInfo fn_info + + -- In practice it always will have a strictness + -- signature, even if it's a uninformative one + strict_sig = strictnessInfo fn_info + StrictSig (DmdType env wrap_dmds res_info) = strict_sig + + -- new_fn_id has the DmdEnv zapped. + -- (a) it is never used again + -- (b) it wastes space + -- (c) it becomes incorrect as things are cloned, because + -- we don't push the substitution into it + new_fn_id | isEmptyVarEnv env = fn_id + | otherwise = fn_id `setIdStrictness` + mkClosedStrictSig wrap_dmds res_info + + is_fun = notNull wrap_dmds + is_thunk = not is_fun && not (exprIsHNF rhs) + + +--------------------- +splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr + -> UniqSM [(Id, CoreExpr)] +splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do + -- The arity should match the signature + stuff <- mkWwBodies dflags fam_envs fun_ty wrap_dmds res_info one_shots + case stuff of + Just (work_demands, wrap_fn, work_fn) -> do + work_uniq <- getUniqueM + let work_rhs = work_fn rhs + work_prag = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = inl_inline inl_prag + , inl_sat = Nothing + , inl_act = wrap_act + , inl_rule = FunLike } + -- idl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] + -- idl_act: see Note [Activation for INLINABLE workers] + -- inl_rule: it does not make sense for workers to be constructorlike. + + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlinePragma` work_prag + + `setIdUnfolding` mkWorkerUnfolding dflags work_fn (unfoldingInfo fn_info) + -- See Note [Worker-wrapper for INLINABLE functions] + + `setIdStrictness` mkClosedStrictSig work_demands work_res_info + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + `setIdArity` exprArity work_rhs + -- Set the arity so that the Core Lint check that the + -- arity is consistent with the demand type goes through + + wrap_act = ActiveAfter 0 + wrap_rhs = wrap_fn work_id + wrap_prag = InlinePragma { inl_src = "{-# INLINE" + , inl_inline = Inline + , inl_sat = Nothing + , inl_act = wrap_act + , inl_rule = rule_match_info } + -- See Note [Wrapper activation] + -- The RuleMatchInfo is (and must be) unaffected + + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule wrap_rhs arity + `setInlinePragma` wrap_prag + `setIdOccInfo` NoOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule + + return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] + -- Worker first, because wrapper mentions it + + Nothing -> return [(fn_id, rhs)] + where + fun_ty = idType fn_id + inl_prag = inlinePragInfo fn_info + rule_match_info = inlinePragmaRuleMatchInfo inl_prag + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas + + work_res_info | isBotRes res_info = botRes -- Cpr stuff done by wrapper + | otherwise = topRes + + one_shots = get_one_shots rhs + +-- If the original function has one-shot arguments, it is important to +-- make the wrapper and worker have corresponding one-shot arguments too. +-- Otherwise we spuriously float stuff out of case-expression join points, +-- which is very annoying. +get_one_shots :: Expr Var -> [OneShotInfo] +get_one_shots (Lam b e) + | isId b = idOneShotInfo b : get_one_shots e + | otherwise = get_one_shots e +get_one_shots (Tick _ e) = get_one_shots e +get_one_shots _ = [] + +{- +Note [Do not split void functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this rather common form of binding: + $j = \x:Void# -> ...no use of x... + +Since x is not used it'll be marked as absent. But there is no point +in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs. + +If x has a more interesting type (eg Int, or Int#), there *is* a point +in w/w so that we don't pass the argument at all. + +Note [Thunk splitting] +~~~~~~~~~~~~~~~~~~~~~~ +Suppose x is used strictly (never mind whether it has the CPR +property). + + let + x* = x-rhs + in body + +splitThunk transforms like this: + + let + x* = case x-rhs of { I# a -> I# a } + in body + +Now simplifier will transform to + + case x-rhs of + I# a -> let x* = I# a + in body + +which is what we want. Now suppose x-rhs is itself a case: + + x-rhs = case e of { T -> I# a; F -> I# b } + +The join point will abstract over a, rather than over (which is +what would have happened before) which is fine. + +Notice that x certainly has the CPR property now! + +In fact, splitThunk uses the function argument w/w splitting +function, so that if x's demand is deeper (say U(U(L,L),L)) +then the splitting will go deeper too. +-} + +-- See Note [Thunk splitting] +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x = e +-- in case x of +-- I# y -> let x = I# y in x } +-- See comments above. Is it not beautifully short? +-- Moreover, it works just as well when there are +-- several binders, and if the binders are lifted +-- E.g. x = e +-- --> x = let x = e in +-- case x of (a,b) -> let x = (a,b) in x + +splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)] +splitThunk dflags fam_envs is_rec fn_id rhs + = do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id] + ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] + ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive + return res + else return [(fn_id, rhs)] } diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs new file mode 100644 index 00000000..8c96afad --- /dev/null +++ b/compiler/stranal/WwLib.hs @@ -0,0 +1,770 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser} +-} + +{-# LANGUAGE CPP #-} + +module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs + , deepSplitProductType_maybe, findTypeShape + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreUtils ( exprType, mkCast ) +import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, + setIdUnfolding, + setIdInfo, idOneShotInfo, setIdOneShotInfo + ) +import IdInfo ( vanillaIdInfo ) +import DataCon +import Demand +import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID ) +import MkId ( voidArgId, voidPrimId ) +import TysPrim ( voidPrimTy ) +import TysWiredIn ( tupleCon ) +import Type +import Coercion hiding ( substTy, substTyVarBndr ) +import FamInstEnv +import BasicTypes ( TupleSort(..), OneShotInfo(..), worstOneShot ) +import Literal ( absentLiteralOf ) +import TyCon +import UniqSupply +import Unique +import Maybes +import Util +import Outputable +import DynFlags +import FastString + +{- +************************************************************************ +* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +* * +************************************************************************ + +Here's an example. The original function is: + +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = \/\ a -> \ x ys -> + case x of + I# x# -> $wg a x# ys + -- call the worker; don't forget the type args! + +-- worker +$wg :: forall a . Int# -> [a] -> a + +$wg = \/\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: + +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} + +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + + +************************************************************************ +* * +\subsection{The worker wrapper core} +* * +************************************************************************ + +@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. +-} + +mkWwBodies :: DynFlags + -> FamInstEnvs + -> Type -- Type of original function + -> [Demand] -- Strictness of original function + -> DmdResult -- Info about function result + -> [OneShotInfo] -- One-shot-ness of the function, value args only + -> UniqSM (Maybe ([Demand], -- Demands for worker (value) args + Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr)) -- Worker body, lacking the original function rhs + +-- wrap_fn_args E = \x y -> E +-- work_fn_args E = E x y + +-- wrap_fn_str E = case x of { (a,b) -> +-- case a of { (a1,a2) -> +-- E a1 a2 b y }} +-- work_fn_str E = \a2 a2 b y -> +-- let a = (a1,a2) in +-- let x = (a,b) in +-- E + +mkWwBodies dflags fam_envs fun_ty demands res_info one_shots + = do { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo) + all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info + ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args + + -- Do CPR w/w. See Note [Always do CPR w/w] + ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) <- mkWWcpr fam_envs res_ty res_info + + ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty + worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] + wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var + worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args + + ; if useful1 && not (only_one_void_argument) || useful2 + then return (Just (worker_args_dmds, wrapper_body, worker_body)) + else return Nothing + } + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS + where + -- Note [Do not split void functions] + only_one_void_argument + | [d] <- demands + , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty + , isAbsDmd d && isVoidTy arg_ty1 + = True + | otherwise + = False + +{- +Note [Always do CPR w/w] +~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we refrained from doing CPR w/w for thunks, on the grounds that +we might duplicate work. But that is already handled by the demand analyser, +which doesn't give the CPR proprety if w/w might waste work: see +Note [CPR for thunks] in DmdAnal. + +And if something *has* been given the CPR property and we don't w/w, it's +a disaster, because then the enclosing function might say it has the CPR +property, but now doesn't and there a cascade of disaster. A good example +is Trac #5920. + + +************************************************************************ +* * +\subsection{Making wrapper args} +* * +************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. +-} + +mkWorkerArgs :: DynFlags -> [Var] + -> OneShotInfo -- Whether all arguments are one-shot + -> Type -- Type of body + -> ([Var], -- Lambda bound args + [Var]) -- Args at call site +mkWorkerArgs dflags args all_one_shot res_ty + | any isId args || not needsAValueLambda + = (args, args) + | otherwise + = (args ++ [newArg], args ++ [voidPrimId]) + where + needsAValueLambda = + isUnLiftedType res_ty + || not (gopt Opt_FunToThunk dflags) + -- see Note [Protecting the last value argument] + + -- see Note [All One-Shot Arguments of a Worker] + newArg = setIdOneShotInfo voidArgId all_one_shot + +{- +Note [Protecting the last value argument] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the user writes (\_ -> E), they might be intentionally disallowing +the sharing of E. Since absence analysis and worker-wrapper are keen +to remove such unused arguments, we add in a void argument to prevent +the function from becoming a thunk. + +The user can avoid adding the void argument with the -ffun-to-thunk +flag. However, this can create sharing, which may be bad in two ways. 1) It can +create a space leak. 2) It can prevent inlining *under a lambda*. If w/w +removes the last argument from a function f, then f now looks like a thunk, and +so f can't be inlined *under a lambda*. + +Note [All One-Shot Arguments of a Worker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, derived join-points are just lambda-lifted thunks, whose +only argument is of the unit type and is never used. This might +interfere with the absence analysis, basing on which results these +never-used arguments are eliminated in the worker. The additional +argument `all_one_shot` of `mkWorkerArgs` is to prevent this. + +Example. Suppose we have + foo = \p(one-shot) q(one-shot). y + 3 +Then we drop the unused args to give + foo = \pq. $wfoo void# + $wfoo = \void(one-shot). y + 3 + +But suppse foo didn't have all one-shot args: + foo = \p(not-one-shot) q(one-shot). expensive y + 3 +Then we drop the unused args to give + foo = \pq. $wfoo void# + $wfoo = \void(not-one-shot). y + 3 + +If we made the void-arg one-shot we might inline an expensive +computation for y, which would be terrible! + + +************************************************************************ +* * +\subsection{Coercion stuff} +* * +************************************************************************ + +We really want to "look through" coerces. +Reason: I've seen this situation: + + let f = coerce T (\s -> E) + in \x -> case x of + p -> coerce T' f + q -> \s -> E2 + r -> coerce T' f + +If only we w/w'd f, we'd get + let f = coerce T (\s -> fw s) + fw = \s -> E + in ... + +Now we'll inline f to get + + let fw = \s -> E + in \x -> case x of + p -> fw + q -> \s -> E2 + r -> fw + +Now we'll see that fw has arity 1, and will arity expand +the \x to get what we want. +-} + +-- mkWWargs just does eta expansion +-- is driven off the function type and arity. +-- It chomps bites off foralls, arrows, newtypes +-- and keeps repeating that until it's satisfied the supplied arity + +mkWWargs :: TvSubst -- Freshening substitution to apply to the type + -- See Note [Freshen type variables] + -> Type -- The type of the function + -> [(Demand,OneShotInfo)] -- Demands and one-shot info for value arguments + -> UniqSM ([Var], -- Wrapper args + CoreExpr -> CoreExpr, -- Wrapper fn + CoreExpr -> CoreExpr, -- Worker fn + Type) -- Type of wrapper body + +mkWWargs subst fun_ty arg_info + | null arg_info + = return ([], id, id, substTy subst fun_ty) + + | ((dmd,one_shot):arg_info') <- arg_info + , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + = do { uniq <- getUniqueM + ; let arg_ty' = substTy subst arg_ty + id = mk_wrap_arg uniq arg_ty' dmd one_shot + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst fun_ty' arg_info' + ; return (id : wrap_args, + Lam id . wrap_fn_args, + work_fn_args . (`App` varToCoreExpr id), + res_ty) } + + | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty + = do { let (subst', tv') = substTyVarBndr subst tv + -- This substTyVarBndr clones the type variable when necy + -- See Note [Freshen type variables] + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst' fun_ty' arg_info + ; return (tv' : wrap_args, + Lam tv' . wrap_fn_args, + work_fn_args . (`App` Type (mkTyVarTy tv')), + res_ty) } + + | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty + -- The newtype case is for when the function has + -- a newtype after the arrow (rare) + -- + -- It's also important when we have a function returning (say) a pair + -- wrapped in a newtype, at least if CPR analysis can look + -- through such newtypes, which it probably can since they are + -- simply coerces. + + = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) + <- mkWWargs subst rep_ty arg_info + ; return (wrap_args, + \e -> Cast (wrap_fn_args e) (mkSymCo co), + \e -> work_fn_args (Cast e co), + res_ty) } + + | otherwise + = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand + return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow + +applyToVars :: [Var] -> CoreExpr -> CoreExpr +applyToVars vars fn = mkVarApps fn vars + +mk_wrap_arg :: Unique -> Type -> Demand -> OneShotInfo -> Id +mk_wrap_arg uniq ty dmd one_shot + = mkSysLocal (fsLit "w") uniq ty + `setIdDemandInfo` dmd + `setIdOneShotInfo` one_shot + +{- +Note [Freshen type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wen we do a worker/wrapper split, we must not use shadowed names, +else we'll get + f = /\ a /\a. fw a a +which is obviously wrong. Type variables can can in principle shadow, +within a type (e.g. forall a. a -> forall a. a->a). But type +variables *are* mentioned in , so we must substitute. + +That's why we carry the TvSubst through mkWWargs + +************************************************************************ +* * +\subsection{Strictness stuff} +* * +************************************************************************ +-} + +mkWWstr :: DynFlags + -> FamInstEnvs + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM (Bool, -- Is this useful + [Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing +mkWWstr _ _ [] + = return (False, [], nop_fn, nop_fn) + +mkWWstr dflags fam_envs (arg : args) = do + (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg + (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args + return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2) + +{- +Note [Unpacking arguments with product and polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The argument is unpacked in a case if it has a product type and has a +strict *and* used demand put on it. I.e., arguments, with demands such +as the following ones: + + + + +will be unpacked, but + + or + +will not, because the pieces aren't used. This is quite important otherwise +we end up unpacking massive tuples passed to the bottoming function. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + +Does 'main' print "error 1" or "error no"? We don't really want 'f' +to unbox its second argument. This actually happened in GHC's onwn +source code, in Packages.applyPackageFlag, which ended up un-boxing +the enormous DynFlags tuple, and being strict in the +as-yet-un-filled-in pkgState files. +-} + +---------------------- +-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) +-- * wrap_fn assumes wrap_arg is in scope, +-- brings into scope work_args (via cases) +-- * work_fn assumes work_args are in scope, a +-- brings into scope wrap_arg (via lets) +mkWWstr_one :: DynFlags -> FamInstEnvs -> Var + -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) +mkWWstr_one dflags fam_envs arg + | isTyVar arg + = return (False, [arg], nop_fn, nop_fn) + + -- See Note [Worker-wrapper for bottoming functions] + | isAbsDmd dmd + , Just work_fn <- mk_absent_let dflags arg + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + --- (that's what mk_absent_let does) + = return (True, [], nop_fn, work_fn) + + -- See Note [Worthy functions for Worker-Wrapper split] + | isSeqDmd dmd -- `seq` demand; evaluate in wrapper in the hope + -- of dropping seqs in the worker + = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding + -- Tell the worker arg that it's sure to be evaluated + -- so that internal seqs can be dropped + in return (True, [arg_w_unf], mk_seq_case arg, nop_fn) + -- Pass the arg, anyway, even if it is in theory discarded + -- Consider + -- f x y = x `seq` y + -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker + -- we ABSOLUTELY MUST record that x is evaluated in the wrapper. + -- Something like: + -- f x y = x `seq` fw y + -- fw y = let x{Evald} = error "oops" in (x `seq` y) + -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and + -- we end up evaluating the absent thunk. + -- But the Evald flag is pretty weird, and I worry that it might disappear + -- during simplification, so for now I've just nuked this whole case + + | isStrictDmd dmd + , Just cs <- splitProdDmd_maybe dmd + -- See Note [Unpacking arguments with product and polymorphic demands] + , Just (data_con, inst_tys, inst_con_arg_tys, co) + <- deepSplitProductType_maybe fam_envs (idType arg) + , cs `equalLength` inst_con_arg_tys + -- See Note [mkWWstr and unsafeCoerce] + = do { (uniq1:uniqs) <- getUniquesM + ; let unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys + unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs + unbox_fn = mkUnpackCase (Var arg) co uniq1 + data_con unpk_args + rebox_fn = Let (NonRec arg con_app) + con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args_w_ds + ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } + -- Don't pass the arg, rebox instead + + | otherwise -- Other cases + = return (False, [arg], nop_fn, nop_fn) + + where + dmd = idDemandInfo arg + one_shot = idOneShotInfo arg + -- If the wrapper argument is a one-shot lambda, then + -- so should (all) the corresponding worker arguments be + -- This bites when we do w/w on a case join point + set_worker_arg_info worker_arg demand + = worker_arg `setIdDemandInfo` demand + `setIdOneShotInfo` one_shot + +---------------------- +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body + +{- +Note [mkWWstr and unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By using unsafeCoerce, it is possible to make the number of demands fail to +match the number of constructor arguments; this happened in Trac #8037. +If so, the worker/wrapper split doesn't work right and we get a Core Lint +bug. The fix here is simply to decline to do w/w if that happens. + +************************************************************************ +* * + Type scrutiny that is specfic to demand analysis +* * +************************************************************************ + +Note [Do not unpack class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + f :: Ord a => [a] -> Int -> a + {-# INLINABLE f #-} +and we worker/wrapper f, we'll get a worker with an INLINALBE pragma +(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which +can still be specialised by the type-class specialiser, something like + fw :: Ord a => [a] -> Int# -> a + +BUT if f is strict in the Ord dictionary, we might unpack it, to get + fw :: (a->a->Bool) -> [a] -> Int# -> a +and the type-class specialiser can't specialise that. An example is +Trac #6056. + +Moreover, dictinoaries can have a lot of fields, so unpacking them can +increase closure sizes. + +Conclusion: don't unpack dictionaries. +-} + +deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion) +-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +deepSplitProductType_maybe fam_envs ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkReflCo Representational ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , Just con <- isDataProductTyCon_maybe tc + , not (isClassTyCon tc) -- See Note [Do not unpack class dictionaries] + = Just (con, tc_args, dataConInstArgTys con tc_args, co) +deepSplitProductType_maybe _ _ = Nothing + +deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion) +-- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) +-- then dc @ tys (args::arg_tys) :: rep_ty +-- co :: ty ~ rep_ty +deepSplitCprType_maybe fam_envs con_tag ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkReflCo Representational ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , isDataTyCon tc + , let cons = tyConDataCons tc + , cons `lengthAtLeast` con_tag -- This might not be true if we import the + -- type constructor via a .hs-bool file (#8743) + , let con = cons !! (con_tag - fIRST_TAG) + = Just (con, tc_args, dataConInstArgTys con tc_args, co) +deepSplitCprType_maybe _ _ _ = Nothing + +findTypeShape :: FamInstEnvs -> Type -> TypeShape +-- Uncover the arrow and product shape of a type +-- The data type TypeShape is defined in Demand +-- See Note [Trimming a demand to a type] in Demand +findTypeShape fam_envs ty + | Just (_, ty') <- splitForAllTy_maybe ty + = findTypeShape fam_envs ty' + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tc + = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) + + | Just (_, res) <- splitFunTy_maybe ty + = TsFun (findTypeShape fam_envs res) + + | Just (_, ty') <- topNormaliseType_maybe fam_envs ty + = findTypeShape fam_envs ty' + + | otherwise + = TsUnk + +{- +************************************************************************ +* * +\subsection{CPR stuff} +* * +************************************************************************ + + +@mkWWcpr@ takes the worker/wrapper pair produced from the strictness +info and adds in the CPR transformation. The worker returns an +unboxed tuple containing non-CPR components. The wrapper takes this +tuple and re-produces the correct structured output. + +The non-CPR results appear ordered in the unboxed tuple as if by a +left-to-right traversal of the result structure. +-} + +mkWWcpr :: FamInstEnvs + -> Type -- function body type + -> DmdResult -- CPR analysis results + -> UniqSM (Bool, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper + CoreExpr -> CoreExpr, -- New worker + Type) -- Type of worker's body + +mkWWcpr fam_envs body_ty res + = case returnsCPR_maybe res of + Nothing -> return (False, id, id, body_ty) -- No CPR info + Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty + -> mkWWcpr_help stuff + | otherwise + -- See Note [non-algebraic or open body type warning] + -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) + return (False, id, id, body_ty) + +mkWWcpr_help :: (DataCon, [Type], [Type], Coercion) + -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) + +mkWWcpr_help (data_con, inst_tys, arg_tys, co) + | [arg_ty1] <- arg_tys + , isUnLiftedType arg_ty1 + -- Special case when there is a single result of unlifted type + -- + -- Wrapper: case (..call worker..) of x -> C x + -- Worker: case ( ..body.. ) of C x -> x + = do { (work_uniq : arg_uniq : _) <- getUniquesM + ; let arg = mk_ww_local arg_uniq arg_ty1 + con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co + + ; return ( True + , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)] + , \ body -> mkUnpackCase body co work_uniq data_con [arg] (Var arg) + , arg_ty1 ) } + + | otherwise -- The general case + -- Wrapper: case (..call worker..) of (# a, b #) -> C a b + -- Worker: case ( ...body... ) of C a b -> (# a, b #) + = do { (work_uniq : uniqs) <- getUniquesM + ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys) + ubx_tup_con = tupleCon UnboxedTuple (length arg_tys) + ubx_tup_ty = exprType ubx_tup_app + ubx_tup_app = mkConApp2 ubx_tup_con arg_tys args + con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co + + ; return (True + , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)] + , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app + , ubx_tup_ty ) } + +mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co uniq Con args body) +-- returns +-- case e |> co of bndr { Con args -> body } + +mkUnpackCase (Tick tickish e) co uniq con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co uniq con args body) +mkUnpackCase scrut co uniq boxing_con unpk_args body + = Case casted_scrut bndr (exprType body) + [(DataAlt boxing_con, unpk_args, body)] + where + casted_scrut = scrut `mkCast` co + bndr = mk_ww_local uniq (exprType casted_scrut) + +{- +Note [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + + +Note [Profiling and unpacking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the original function looked like + f = \ x -> {-# SCC "foo" #-} E + +then we want the CPR'd worker to look like + \ x -> {-# SCC "foo" #-} (case E of I# x -> x) +and definitely not + \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) + +This transform doesn't move work or allocation +from one cost centre to another. + +Later [SDM]: presumably this is because we want the simplifier to +eliminate the case, and the scc would get in the way? I'm ok with +including the case itself in the cost centre, since it is morally +part of the function (post transformation) anyway. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ + +Note [Absent errors] +~~~~~~~~~~~~~~~~~~~~ +We make a new binding for Ids that are marked absent, thus + let x = absentError "x :: Int" +The idea is that this binding will never be used; but if it +buggily is used we'll get a runtime error message. + +Coping with absence for *unlifted* types is important; see, for +example, Trac #4306. For these we find a suitable literal, +using Literal.absentLiteralOf. We don't have literals for +every primitive type, so the function is partial. + + [I did try the experiment of using an error thunk for unlifted + things too, relying on the simplifier to drop it as dead code, + by making absentError + (a) *not* be a bottoming Id, + (b) be "ok for speculation" + But that relies on the simplifier finding that it really + is dead code, which is fragile, and indeed failed when + profiling is on, which disables various optimisations. So + using a literal will do.] +-} + +mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let dflags arg + | not (isUnLiftedType arg_ty) + = Just (Let (NonRec arg abs_rhs)) + | Just tc <- tyConAppTyCon_maybe arg_ty + , Just lit <- absentLiteralOf tc + = Just (Let (NonRec arg (Lit lit))) + | arg_ty `eqType` voidPrimTy + = Just (Let (NonRec arg (Var voidPrimId))) + | otherwise + = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) + Nothing + where + arg_ty = idType arg + abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg + msg = showSDoc dflags (ppr arg <+> ppr (idType arg)) + +mk_seq_case :: Id -> CoreExpr -> CoreExpr +mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] + +sanitiseCaseBndr :: Id -> Id +-- The argument we are scrutinising has the right type to be +-- a case binder, so it's convenient to re-use it for that purpose. +-- But we *must* throw away all its IdInfo. In particular, the argument +-- will have demand info on it, and that demand info may be incorrect for +-- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... } +-- Quite likely ww_arg isn't used in '...'. The case may get discarded +-- if the case binder says "I'm demanded". This happened in a situation +-- like (x+y) `seq` .... +sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo + +mk_ww_local :: Unique -> Type -> Id +mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs new file mode 100644 index 00000000..117ef7b3 --- /dev/null +++ b/compiler/typecheck/FamInst.hs @@ -0,0 +1,401 @@ +-- The @FamInst@ type: family instance heads + +{-# LANGUAGE CPP, GADTs #-} + +module FamInst ( + FamInstEnvs, tcGetFamInstEnvs, + checkFamInstConsistency, tcExtendLocalFamInstEnv, + tcLookupFamInst, + tcLookupDataFamInst, tcLookupDataFamInst_maybe, + tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, + newFamInst + ) where + +import HscTypes +import FamInstEnv +import InstEnv( roughMatchTcs ) +import Coercion hiding ( substTy ) +import TcEvidence +import LoadIface +import TcRnMonad +import TyCon +import CoAxiom +import DynFlags +import Module +import Outputable +import UniqFM +import FastString +import Util +import RdrName +import DataCon ( dataConName ) +import Maybes +import TcMType +import TcType +import Name +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Arrow ( first, second ) + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Making a FamInst +* * +************************************************************************ +-} + +-- All type variables in a FamInst must be fresh. This function +-- creates the fresh variables and applies the necessary substitution +-- It is defined here to avoid a dependency from FamInstEnv on the monad +-- code. + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst +-- Freshen the type variables of the FamInst branches +-- Called from the vectoriser monad too, hence the rather general type +newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch + , co_ax_tc = fam_tc }) + | CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs } <- branch + = do { (subst, tvs') <- freshenTyVarBndrs tvs + ; return (FamInst { fi_fam = tyConName fam_tc + , fi_flavor = flavor + , fi_tcs = roughMatchTcs lhs + , fi_tvs = tvs' + , fi_tys = substTys subst lhs + , fi_rhs = substTy subst rhs + , fi_axiom = axiom }) } + +{- +************************************************************************ +* * + Optimised overlap checking for family instances +* * +************************************************************************ + +For any two family instance modules that we import directly or indirectly, we +check whether the instances in the two modules are consistent, *unless* we can +be certain that the instances of the two modules have already been checked for +consistency during the compilation of modules that we import. + +Why do we need to check? Consider + module X1 where module X2 where + data T1 data T2 + type instance F T1 b = Int type instance F a T2 = Char + f1 :: F T1 a -> Int f2 :: Char -> F a T2 + f1 x = x f2 x = x + +Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. +Notice that neither instance is an orphan. + +How do we know which pairs of modules have already been checked? Any pair of +modules where both modules occur in the `HscTypes.dep_finsts' set (of the +`HscTypes.Dependencies') of one of our directly imported modules must have +already been checked. Everything else, we check now. (So that we can be +certain that the modules in our `HscTypes.dep_finsts' are consistent.) +-} + +-- The optimisation of overlap tests is based on determining pairs of modules +-- whose family instances need to be checked for consistency. +-- +data ModulePair = ModulePair Module Module + +-- canonical order of the components of a module pair +-- +canon :: ModulePair -> (Module, Module) +canon (ModulePair m1 m2) | m1 < m2 = (m1, m2) + | otherwise = (m2, m1) + +instance Eq ModulePair where + mp1 == mp2 = canon mp1 == canon mp2 + +instance Ord ModulePair where + mp1 `compare` mp2 = canon mp1 `compare` canon mp2 + +instance Outputable ModulePair where + ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2) + +-- Sets of module pairs +-- +type ModulePairSet = Map ModulePair () + +listToSet :: [ModulePair] -> ModulePairSet +listToSet l = Map.fromList (zip l (repeat ())) + +checkFamInstConsistency :: [Module] -> [Module] -> TcM () +checkFamInstConsistency famInstMods directlyImpMods + = do { dflags <- getDynFlags + ; (eps, hpt) <- getEpsAndHpt + + ; let { -- Fetch the iface of a given module. Must succeed as + -- all directly imported modules must already have been loaded. + modIface mod = + case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of + Nothing -> panic "FamInst.checkFamInstConsistency" + Just iface -> iface + + ; hmiModule = mi_module . hm_iface + ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) + | hmi <- eltsUFM hpt] + ; groups = map (dep_finsts . mi_deps . modIface) + directlyImpMods + ; okPairs = listToSet $ concatMap allPairs groups + -- instances of okPairs are consistent + ; criticalPairs = listToSet $ allPairs famInstMods + -- all pairs that we need to consider + ; toCheckPairs = Map.keys $ criticalPairs `Map.difference` okPairs + -- the difference gives us the pairs we need to check now + } + + ; mapM_ (check hpt_fam_insts) toCheckPairs + } + where + allPairs [] = [] + allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms + + check hpt_fam_insts (ModulePair m1 m2) + = do { env1 <- getFamInsts hpt_fam_insts m1 + ; env2 <- getFamInsts hpt_fam_insts m2 + ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) + (famInstEnvElts env1) } + +getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv +getFamInsts hpt_fam_insts mod + | Just env <- lookupModuleEnv hpt_fam_insts mod = return env + | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) + ; eps <- getEps + ; return (expectJust "checkFamInstConsistency" $ + lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } + where + doc = ppr mod <+> ptext (sLit "is a family-instance module") + +{- +************************************************************************ +* * + Lookup +* * +************************************************************************ + +Look up the instance tycon of a family instance. + +The match may be ambiguous (as we know that overlapping instances have +identical right-hand sides under overlapping substitutions - see +'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used +for matching must be equal to or be more specific than those of the family +instance declaration. We pick one of the matches in case of ambiguity; as +the right-hand sides are identical under the match substitution, the choice +does not matter. + +Return the instance tycon and its type instance. For example, if we have + + tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') + +then we have a coercion (ie, type instance of family instance coercion) + + :Co:R42T Int :: T [Int] ~ :R42T Int + +which implies that :R42T was declared as 'data instance T [a]'. +-} + +tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch +tcLookupFamInst fam_envs tycon tys + | not (isOpenFamilyTyCon tycon) + = Nothing + | otherwise + = case lookupFamInstEnv fam_envs tycon tys of + match : _ -> Just match + [] -> Nothing + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion +tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) +tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $ + instNewTyCon_maybe tc tys + +-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if +-- there is no data family to unwrap. +tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] + -> (TyCon, [TcType], TcCoercion) +tcLookupDataFamInst fam_inst_envs tc tc_args + | Just (rep_tc, rep_args, co) + <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + = (rep_tc, rep_args, TcCoercion co) + | otherwise + = (tc, tc_args, mkTcRepReflCo (mkTyConApp tc tc_args)) + +tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] + -> Maybe (TyCon, [TcType], Coercion) +-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) +-- and returns a coercion between the two: co :: F [a] ~R FList a +tcLookupDataFamInst_maybe fam_inst_envs tc tc_args + | isDataFamilyTyCon tc + , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args + , FamInstMatch { fim_instance = rep_fam + , fim_tys = rep_args } <- match + , let co_tc = famInstAxiom rep_fam + rep_tc = dataFamInstRepTyCon rep_fam + co = mkUnbranchedAxInstCo Representational co_tc rep_args + = Just (rep_tc, rep_args, co) + + | otherwise + = Nothing + +-- | Get rid of top-level newtypes, potentially looking through newtype +-- instances. Only unwraps newtypes that are in scope. This is used +-- for solving for `Coercible` in the solver. This version is careful +-- not to unwrap data/newtype instances if it can't continue unwrapping. +-- Such care is necessary for proper error messages. +-- +-- Does not look through type families. Does not normalise arguments to a +-- tycon. +-- +-- Always produces a representational coercion. +tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs + -> GlobalRdrEnv + -> Type + -> Maybe (TcCoercion, Type) +tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty +-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe + = fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty + where + stepper + = unwrap_newtype + `composeSteppers` + \ rec_nts tc tys -> + case tcLookupDataFamInst_maybe faminsts tc tys of + Just (tc', tys', co) -> + modifyStepResultCo (co `mkTransCo`) + (unwrap_newtype rec_nts tc' tys') + Nothing -> NS_Done + + unwrap_newtype rec_nts tc tys + | data_cons_in_scope tc + = unwrapNewTypeStepper rec_nts tc tys + + | otherwise + = NS_Done + + data_cons_in_scope :: TyCon -> Bool + data_cons_in_scope tc + = isWiredInName (tyConName tc) || + (not (isAbstractTyCon tc) && all in_scope data_con_names) + where + data_con_names = map dataConName (tyConDataCons tc) + in_scope dc = not $ null $ lookupGRE_Name rdr_env dc + +{- +************************************************************************ +* * + Extending the family instance environment +* * +************************************************************************ +-} + +-- Add new locally-defined family instances +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a +tcExtendLocalFamInstEnv fam_insts thing_inside + = do { env <- getGblEnv + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } + ; setGblEnv env' thing_inside + } + +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] +-- in FamInstEnv.lhs +addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { traceTc "addLocalFamInst" (ppr fam_inst) + + ; isGHCi <- getIsGHCi + ; mod <- getModule + ; traceTc "alfi" (ppr mod $$ ppr isGHCi) + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + -- See Note [Override identical instances in GHCi] in HscTypes + ; let home_fie' + | isGHCi = deleteFromFamInstEnv home_fie fam_inst + | otherwise = home_fie + + -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie') + home_fie'' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls + ; no_conflict <- checkForConflicts inst_envs fam_inst + ; if no_conflict then + return (home_fie'', fam_inst : my_fis) + else + return (home_fie, my_fis) } + +{- +************************************************************************ +* * + Checking an instance against conflicts with an instance env +* * +************************************************************************ + +Check whether a single family instance conflicts with those in two instance +environments (one for the EPS and one for the HPT). +-} + +checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts inst_envs fam_inst + = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + no_conflicts = null conflicts + ; traceTc "checkForConflicts" $ + vcat [ ppr (map fim_instance conflicts) + , ppr fam_inst + -- , ppr inst_envs + ] + ; unless no_conflicts $ conflictInstErr fam_inst conflicts + ; return no_conflicts } + +conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +conflictInstErr fam_inst conflictingMatch + | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch + = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:")) + [fam_inst, confInst] + | otherwise + = panic "conflictInstErr" + +addFamInstsErr :: SDoc -> [FamInst] -> TcRn () +addFamInstsErr herald insts + = ASSERT( not (null insts) ) + setSrcSpan srcSpan $ addErr $ + hang herald + 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 + | fi <- sorted ]) + where + getSpan = getSrcLoc . famInstAxiom + sorted = sortWith getSpan insts + fi1 = head sorted + srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + -- The sortWith just arranges that instances are dislayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users + +tcGetFamInstEnvs :: TcM FamInstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/compiler/typecheck/Flattening-notes b/compiler/typecheck/Flattening-notes new file mode 100644 index 00000000..2aa92437 --- /dev/null +++ b/compiler/typecheck/Flattening-notes @@ -0,0 +1,32 @@ +ToDo: + +* inert_funeqs, inert_eqs: keep only the CtEvidence. + They are all CFunEqCans, CTyEqCans + +* Consider individual data types for CFunEqCan etc + +* Collapse CNonCanonical and CIrredCan + * RAE: I think it would be better to split off CNonCanonical into its own + type, and remove it completely from Ct. Then, we would keep CIrredCan + +The coercion solver +~~~~~~~~~~~~~~~~~~~~ +Our hope. In GHC currently drawn from {G,W,D}, but with the coercion +solver the flavours become pairs + { (k,l) | k <- {G,W,D}, l <- {Nom,Rep} } + +But can + a -(G,R)-> Int +rewrite + b -(G,R)-> T a +? + +Well, it depends on the roles at which T uses its arguments :-(. +So it may not be enough just to look at (flavour,role) pairs? + +RAE: This is true, but it is taken care of by being careful in the +flattening algorithm. Flattening (T a) looks at the roles of +T's parameters, and chooses the role for flattening `a` appropriately. +This is why there must be the [Role] parameter to flattenMany. +Of course, this non-uniform rewriting may gum up the proof works. + diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs new file mode 100644 index 00000000..dc2549b0 --- /dev/null +++ b/compiler/typecheck/FunDeps.hs @@ -0,0 +1,621 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + + +FunDeps - functional dependencies + +It's better to read it as: "if we know these, then we're going to know these" +-} + +{-# LANGUAGE CPP #-} + +module FunDeps ( + FDEq (..), + Equation(..), pprEquation, + improveFromInstEnv, improveFromAnother, + checkInstCoverage, checkFunDeps, + pprFundeps + ) where + +#include "HsVersions.h" + +import Name +import Var +import Class +import Type +import Unify +import InstEnv +import VarSet +import VarEnv +import Outputable +import ErrUtils( Validity(..), allValid ) +import SrcLoc +import Util +import FastString + +import Data.List ( nubBy ) +import Data.Maybe ( isJust ) + +{- +************************************************************************ +* * +\subsection{Generate equations from functional dependencies} +* * +************************************************************************ + + +Each functional dependency with one variable in the RHS is responsible +for generating a single equality. For instance: + class C a b | a -> b +The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha + FDEq { fd_pos = 1 + , fd_ty_left = Bool + , fd_ty_right = alpha } +However notice that a functional dependency may have more than one variable +in the RHS which will create more than one FDEq. Example: + class C a b c | a -> b c + [Wanted] C Int alpha alpha + [Wanted] C Int Bool beta +Will generate: + fd1 = FDEq { fd_pos = 1, fd_ty_left = alpha, fd_ty_right = Bool } and + fd2 = FDEq { fd_pos = 2, fd_ty_left = alpha, fd_ty_right = beta } + +We record the paremeter position so that can immediately rewrite a constraint +using the produced FDEqs and remove it from our worklist. + + +INVARIANT: Corresponding types aren't already equal +That is, there exists at least one non-identity equality in FDEqs. + +Assume: + class C a b c | a -> b c + instance C Int x x +And: [Wanted] C Int Bool alpha +We will /match/ the LHS of fundep equations, producing a matching substitution +and create equations for the RHS sides. In our last example we'd have generated: + ({x}, [fd1,fd2]) +where + fd1 = FDEq 1 Bool x + fd2 = FDEq 2 alpha x +To ``execute'' the equation, make fresh type variable for each tyvar in the set, +instantiate the two types with these fresh variables, and then unify or generate +a new constraint. In the above example we would generate a new unification +variable 'beta' for x and produce the following constraints: + [Wanted] (Bool ~ beta) + [Wanted] (alpha ~ beta) + +Notice the subtle difference between the above class declaration and: + class C a b c | a -> b, a -> c +where we would generate: + ({x},[fd1]),({x},[fd2]) +This means that the template variable would be instantiated to different +unification variables when producing the FD constraints. + +Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' +-} + +data Equation loc + = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars + , fd_eqs :: [FDEq] -- and then make these equal + , fd_pred1, fd_pred2 :: PredType -- The Equation arose from combining these two constraints + , fd_loc :: loc } + +data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position + , fd_ty_left :: Type + , fd_ty_right :: Type } + +instance Outputable FDEq where + ppr (FDEq { fd_pos = p, fd_ty_left = tyl, fd_ty_right = tyr }) + = parens (int p <> comma <+> ppr tyl <> comma <+> ppr tyr) + +{- +Given a bunch of predicates that must hold, such as + + C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 + +improve figures out what extra equations must hold. +For example, if we have + + class C a b | a->b where ... + +then improve will return + + [(t1,t2), (t4,t5)] + +NOTA BENE: + + * improve does not iterate. It's possible that when we make + t1=t2, for example, that will in turn trigger a new equation. + This would happen if we also had + C t1 t7, C t2 t8 + If t1=t2, we also get t7=t8. + + improve does *not* do this extra step. It relies on the caller + doing so. + + * The equations unify types that are not already equal. So there + is no effect iff the result of improve is empty +-} + +instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type +-- A simpler version of instFD_WithPos to be used in checking instance coverage etc. +instFD (ls,rs) tvs tys + = (map lookup ls, map lookup rs) + where + env = zipVarEnv tvs tys + lookup tv = lookupVarEnv_NF env tv + +instFD_WithPos :: FunDep TyVar -> [TyVar] -> [Type] -> ([Type], [(Int,Type)]) +-- Returns a FunDep between the types accompanied along with their +-- position (<=0) in the types argument list. +instFD_WithPos (ls,rs) tvs tys + = (map (snd . lookup) ls, map lookup rs) + where + ind_tys = zip [0..] tys + env = zipVarEnv tvs ind_tys + lookup tv = lookupVarEnv_NF env tv + +zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true + -> [Type] + -> [(Int,Type)] + -> [FDEq] +-- Create a list of FDEqs from two lists of types, making sure +-- that the types are not equal. +zipAndComputeFDEqs discard (ty1:tys1) ((i2,ty2):tys2) + | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 + | otherwise = FDEq { fd_pos = i2 + , fd_ty_left = ty1 + , fd_ty_right = ty2 } : zipAndComputeFDEqs discard tys1 tys2 +zipAndComputeFDEqs _ _ _ = [] + +-- Improve a class constraint from another class constraint +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +improveFromAnother :: PredType -- Template item (usually given, or inert) + -> PredType -- Workitem [that can be improved] + -> [Equation ()] +-- Post: FDEqs always oriented from the other to the workitem +-- Equations have empty quantified variables +improveFromAnother pred1 pred2 + | Just (cls1, tys1) <- getClassPredTys_maybe pred1 + , Just (cls2, tys2) <- getClassPredTys_maybe pred2 + , tys1 `lengthAtLeast` 2 && cls1 == cls2 + = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = () } + | let (cls_tvs, cls_fds) = classTvsFds cls1 + , fd <- cls_fds + , let (ltys1, rs1) = instFD fd cls_tvs tys1 + (ltys2, irs2) = instFD_WithPos fd cls_tvs tys2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 irs2 + , not (null eqs) ] + +improveFromAnother _ _ = [] + + +-- Improve a class constraint from instance declarations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +pprEquation :: Equation a -> SDoc +pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) + = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])] + +improveFromInstEnv :: InstEnvs + -> PredType + -> [Equation SrcSpan] -- Needs to be an Equation because + -- of quantified variables +-- Post: Equations oriented from the template (matching instance) to the workitem! +improveFromInstEnv _inst_env pred + | not (isClassPred pred) + = panic "improveFromInstEnv: not a class predicate" +improveFromInstEnv inst_env pred + | Just (cls, tys) <- getClassPredTys_maybe pred + , tys `lengthAtLeast` 2 + , let (cls_tvs, cls_fds) = classTvsFds cls + instances = classInstances inst_env cls + rough_tcs = roughMatchTcs tys + = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs + , fd_pred1 = p_inst, fd_pred2=pred + , fd_loc = getSrcSpan (is_dfun ispec) } + | fd <- cls_fds -- Iterate through the fundeps first, + -- because there often are none! + , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + -- Trim the rough_tcs based on the head of the fundep. + -- Remember that instanceCantMatch treats both argumnents + -- symmetrically, so it's ok to trim the rough_tcs, + -- rather than trimming each inst_tcs in turn + , ispec <- instances + , (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec + emptyVarSet tys trimmed_tcs -- NB: orientation + , let p_inst = mkClassPred cls (is_tys ispec) + ] +improveFromInstEnv _ _ = [] + + +checkClsFD :: FunDep TyVar -> [TyVar] -- One functional dependency from the class + -> ClsInst -- An instance template + -> TyVarSet -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -- TyVarSet are extra tyvars that can be instantiated + -> [([TyVar], [FDEq])] + +checkClsFD fd clas_tvs + (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) + extra_qtvs tys_actual rough_tcs_actual + +-- 'qtvs' are the quantified type variables, the ones which an be instantiated +-- to make the types match. For example, given +-- class C a b | a->b where ... +-- instance C (Maybe x) (Tree x) where .. +-- +-- and an Inst of form (C (Maybe t1) t2), +-- then we will call checkClsFD with +-- +-- is_qtvs = {x}, is_tys = [Maybe x, Tree x] +-- tys_actual = [Maybe t1, t2] +-- +-- We can instantiate x to t1, and then we want to force +-- (Tree x) [t1/x] ~ t2 +-- +-- This function is also used when matching two Insts (rather than an Inst +-- against an instance decl. In that case, qtvs is empty, and we are doing +-- an equality check +-- +-- This function is also used by InstEnv.badFunDeps, which needs to *unify* +-- For the one-sided matching case, the qtvs are just from the template, +-- so we get matching + + | instanceCantMatch rough_tcs_inst rough_tcs_actual + = [] -- Filter out ones that can't possibly match, + + | otherwise + = ASSERT2( length tys_inst == length tys_actual && + length tys_inst == length clas_tvs + , ppr tys_inst <+> ppr tys_actual ) + + case tcUnifyTys bind_fn ltys1 ltys2 of + Nothing -> [] + Just subst | isJust (tcUnifyTys bind_fn rtys1' rtys2') + -- Don't include any equations that already hold. + -- Reason: then we know if any actual improvement has happened, + -- in which case we need to iterate the solver + -- In making this check we must taking account of the fact that any + -- qtvs that aren't already instantiated can be instantiated to anything + -- at all + -- NB: We can't do this 'is-useful-equation' check element-wise + -- because of: + -- class C a b c | a -> b c + -- instance C Int x x + -- [Wanted] C Int alpha Int + -- We would get that x -> alpha (isJust) and x -> Int (isJust) + -- so we would produce no FDs, which is clearly wrong. + -> [] + + | null fdeqs + -> [] + + | otherwise + -> [(meta_tvs, fdeqs)] + -- We could avoid this substTy stuff by producing the eqn + -- (qtvs, ls1++rs1, ls2++rs2) + -- which will re-do the ls1/ls2 unification when the equation is + -- executed. What we're doing instead is recording the partial + -- work of the ls1/ls2 unification leaving a smaller unification problem + where + rtys1' = map (substTy subst) rtys1 + irs2' = map (\(i,x) -> (i,substTy subst x)) irs2 + rtys2' = map snd irs2' + + fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2' + -- Don't discard anything! + -- We could discard equal types but it's an overkill to call + -- eqType again, since we know for sure that /at least one/ + -- equation in there is useful) + + meta_tvs = [ setVarType tv (substTy subst (varType tv)) + | tv <- qtvs, tv `notElemTvSubst` subst ] + -- meta_tvs are the quantified type variables + -- that have not been substituted out + -- + -- Eg. class C a b | a -> b + -- instance C Int [y] + -- Given constraint C Int z + -- we generate the equation + -- ({y}, [y], z) + -- + -- But note (a) we get them from the dfun_id, so they are *in order* + -- because the kind variables may be mentioned in the + -- type variabes' kinds + -- (b) we must apply 'subst' to the kinds, in case we have + -- matched out a kind variable, but not a type variable + -- whose kind mentions that kind variable! + -- Trac #6015, #6068 + where + qtv_set = mkVarSet qtvs + bind_fn tv | tv `elemVarSet` qtv_set = BindMe + | tv `elemVarSet` extra_qtvs = BindMe + | otherwise = Skolem + + (ltys1, rtys1) = instFD fd clas_tvs tys_inst + (ltys2, irs2) = instFD_WithPos fd clas_tvs tys_actual + +{- +************************************************************************ +* * + The Coverage condition for instance declarations +* * +************************************************************************ + +Note [Coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Example + class C a b | a -> b + instance theta => C t1 t2 + +For the coverage condition, we check + (normal) fv(t2) `subset` fv(t1) + (liberal) fv(t2) `subset` oclose(fv(t1), theta) + +The liberal version ensures the self-consistency of the instance, but +it does not guarantee termination. Example: + + class Mul a b c | a b -> c where + (.*.) :: a -> b -> c + + instance Mul Int Int Int where (.*.) = (*) + instance Mul Int Float Float where x .*. y = fromIntegral x * y + instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v + +In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). +But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) + +But it is a mistake to accept the instance because then this defn: + f = \ b x y -> if b then x .*. [y] else y +makes instance inference go into a loop, because it requires the constraint + Mul a [b] b +-} + +checkInstCoverage :: Bool -- Be liberal + -> Class -> [PredType] -> [Type] + -> Validity +-- "be_liberal" flag says whether to use "liberal" coverage of +-- See Note [Coverage Condition] below +-- +-- Return values +-- Nothing => no problems +-- Just msg => coverage problem described by msg + +checkInstCoverage be_liberal clas theta inst_taus + = allValid (map fundep_ok fds) + where + (tyvars, fds) = classTvsFds clas + fundep_ok fd + | if be_liberal then liberal_ok else conservative_ok + = IsValid + | otherwise + = NotValid msg + where + (ls,rs) = instFD fd tyvars inst_taus + ls_tvs = tyVarsOfTypes ls + rs_tvs = tyVarsOfTypes rs + + conservative_ok = rs_tvs `subVarSet` closeOverKinds ls_tvs + liberal_ok = rs_tvs `subVarSet` oclose theta (closeOverKinds ls_tvs) + -- closeOverKinds: see Note [Closing over kinds in coverage] + + msg = vcat [ -- text "ls_tvs" <+> ppr ls_tvs + -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) + -- , text "theta" <+> ppr theta + -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) + -- , text "rs_tvs" <+> ppr rs_tvs + sep [ ptext (sLit "The") + <+> ppWhen be_liberal (ptext (sLit "liberal")) + <+> ptext (sLit "coverage condition fails in class") + <+> quotes (ppr clas) + , nest 2 $ ptext (sLit "for functional dependency:") + <+> quotes (pprFunDep fd) ] + , sep [ ptext (sLit "Reason: lhs type")<>plural ls <+> pprQuotedList ls + , nest 2 $ + (if isSingleton ls + then ptext (sLit "does not") + else ptext (sLit "do not jointly")) + <+> ptext (sLit "determine rhs type")<>plural rs + <+> pprQuotedList rs ] + , ppWhen (not be_liberal && liberal_ok) $ + ptext (sLit "Using UndecidableInstances might help") ] + +{- Note [Closing over kinds in coverage] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a fundep (a::k) -> b +Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, +then fixing x really fixes k2 as well, and so k2 should be added to +the lhs tyvars in the fundep check. + +Example (Trac #8391), using liberal coverage + data Foo a = ... -- Foo :: forall k. k -> * + class Bar a b | a -> b + instance Bar a (Foo a) + + In the instance decl, (a:k) does fix (Foo k a), but only if we notice + that (a:k) fixes k. Trac #10109 is another example. + +Here is a more subtle example, from HList-0.4.0.0 (Trac #10564) + + class HasFieldM (l :: k) r (v :: Maybe *) + | l r -> v where ... + class HasFieldM1 (b :: Maybe [*]) (l :: k) r v + | b l r -> v where ... + class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) + | e1 l -> r + + data Label :: k -> * + type family LabelsOf (a :: [*]) :: * + + instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) + => HasFieldM l (r xs) v where + +Is the instance OK? Does {l,r,xs} determine v? Well: + + * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, + plus the fundep "| el l -> r" in class HMameberM, + we get {l,k,xs} -> b + + * Note the 'k'!! We must call closeOverKinds on the seed set + ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b + fundep won't fire. This was the reason for #10564. + + * So starting from seeds {l,r,xs,k} we do oclose to get + first {l,r,xs,k,b}, via the HMemberM constraint, and then + {l,r,xs,k,b,v}, via the HasFieldM1 constraint. + + * And that fixes v. + +However, we must closeOverKinds whenever augmenting the seed set +in oclose! Consider Trac #10109: + + data Succ a -- Succ :: forall k. k -> * + class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab + instance (Add a b ab) => Add (Succ {k1} (a :: k1)) + b + (Succ {k3} (ab :: k3}) + +We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. +Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to +closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all +the variables free in (Succ {k3} ab). + +Bottom line: + * closeOverKinds on initial seeds (in checkInstCoverage) + * and closeOverKinds whenever extending those seeds (in oclose) + +Note [The liberal coverage condition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(oclose preds tvs) closes the set of type variables tvs, +wrt functional dependencies in preds. The result is a superset +of the argument set. For example, if we have + class C a b | a->b where ... +then + oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} +because if we know x and y then that fixes z. + +We also use equality predicates in the predicates; if we have an +assumption `t1 ~ t2`, then we use the fact that if we know `t1` we +also know `t2` and the other way. + eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} + +oclose is used (only) when checking the coverage condition for +an instance declaration +-} + +oclose :: [PredType] -> TyVarSet -> TyVarSet +-- See Note [The liberal coverage condition] +oclose preds fixed_tvs + | null tv_fds = fixed_tvs -- Fast escape hatch for common case. + | otherwise = loop fixed_tvs + where + loop fixed_tvs + | new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs + | otherwise = loop new_fixed_tvs + where new_fixed_tvs = foldl extend fixed_tvs tv_fds + + extend fixed_tvs (ls,rs) + | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs + | otherwise = fixed_tvs + -- closeOverKinds: see Note [Closing over kinds in coverage] + + tv_fds :: [(TyVarSet,TyVarSet)] + tv_fds = [ (tyVarsOfTypes ls, tyVarsOfTypes rs) + | pred <- preds + , (ls, rs) <- determined pred ] + + determined :: PredType -> [([Type],[Type])] + determined pred + = case classifyPredType pred of + ClassPred cls tys -> + do let (cls_tvs, cls_fds) = classTvsFds cls + fd <- cls_fds + return (instFD fd cls_tvs tys) + EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] + TuplePred ts -> concatMap determined ts + _ -> [] + +{- +************************************************************************ +* * + Check that a new instance decl is OK wrt fundeps +* * +************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches +-} + +checkFunDeps :: InstEnvs -> ClsInst + -> Maybe [ClsInst] -- Nothing <=> ok + -- Just dfs <=> conflict with dfs +-- Check whether adding DFunId would break functional-dependency constraints +-- Used only for instance decls defined in the module being compiled +checkFunDeps inst_envs ispec + | null bad_fundeps = Nothing + | otherwise = Just bad_fundeps + where + (ins_tvs, clas, ins_tys) = instanceHead ispec + ins_tv_set = mkVarSet ins_tvs + cls_inst_env = classInstances inst_envs clas + bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys + +badFunDeps :: [ClsInst] -> Class + -> TyVarSet -> [Type] -- Proposed new instance type + -> [ClsInst] +badFunDeps cls_insts clas ins_tv_set ins_tys + = nubBy eq_inst $ + [ ispec | fd <- fds, -- fds is often empty, so do this first! + let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, + ispec <- cls_insts, + notNull (checkClsFD fd clas_tvs ispec ins_tv_set ins_tys trimmed_tcs) + ] + where + (clas_tvs, fds) = classTvsFds clas + rough_tcs = roughMatchTcs ins_tys + eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 + -- An single instance may appear twice in the un-nubbed conflict list + -- because it may conflict with more than one fundep. E.g. + -- class C a b c | a -> b, a -> c + -- instance C Int Bool Bool + -- instance C Int Char Char + -- The second instance conflicts with the first by *both* fundeps + +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +-- Computing rough_tcs for a particular fundep +-- class C a b c | a -> b where ... +-- For each instance .... => C ta tb tc +-- we want to match only on the type ta; so our +-- rough-match thing must similarly be filtered. +-- Hence, we Nothing-ise the tb and tc types right here +trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs + = zipWith select clas_tvs mb_tcs + where + select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc + | otherwise = Nothing diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs new file mode 100644 index 00000000..a37f8b79 --- /dev/null +++ b/compiler/typecheck/Inst.hs @@ -0,0 +1,617 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @Inst@ type: dictionaries or method instances +-} + +{-# LANGUAGE CPP #-} + +module Inst ( + deeplySkolemise, + deeplyInstantiate, instCall, instStupidTheta, + emitWanted, emitWanteds, + + newOverloadedLit, mkOverLit, + + newClsInst, + tcGetInsts, tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, + tcSyntaxName, + + -- Simple functions over evidence variables + tyVarsOfWC, tyVarsOfBag, + tyVarsOfCt, tyVarsOfCts, + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) +import {-# SOURCE #-} TcUnify( unifyType ) + +import FastString +import HsSyn +import TcHsSyn +import TcRnMonad +import TcEnv +import TcEvidence +import InstEnv +import FunDeps +import TcMType +import Type +import Coercion ( Role(..) ) +import TcType +import HscTypes +import Class( Class ) +import MkId( mkDictFunId ) +import Id +import Name +import Var ( EvVar ) +import VarEnv +import VarSet +import PrelNames +import SrcLoc +import DynFlags +import Bag +import Util +import Outputable +import Control.Monad( unless ) +import Data.Maybe( isJust ) + +{- +************************************************************************ +* * + Emitting constraints +* * +************************************************************************ +-} + +emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar] +emitWanteds origin theta = mapM (emitWanted origin) theta + +emitWanted :: CtOrigin -> TcPredType -> TcM EvVar +emitWanted origin pred + = do { loc <- getCtLoc origin + ; ev <- newEvVar pred + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc } + ; return ev } + +newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) +-- Used when Name is the wired-in name for a wired-in class method, +-- so the caller knows its type for sure, which should be of form +-- forall a. C a => +-- newMethodFromName is supposed to instantiate just the outer +-- type variable and constraint + +newMethodFromName origin name inst_ty + = do { id <- tcLookupId name + -- Use tcLookupId not tcLookupGlobalId; the method is almost + -- always a class op, but with -XRebindableSyntax GHC is + -- meant to find whatever thing is in scope, and that may + -- be an ordinary function. + + ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id) + (the_tv:rest) = tvs + subst = zipOpenTvSubst [the_tv] [inst_ty] + + ; wrap <- ASSERT( null rest && isSingleton theta ) + instCall origin [inst_ty] (substTheta subst theta) + ; return (mkHsWrap wrap (HsVar id)) } + +{- +************************************************************************ +* * + Deep instantiation and skolemisation +* * +************************************************************************ + +Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +deeplySkolemise decomposes and skolemises a type, returning a type +with all its arrows visible (ie not buried under foralls) + +Examples: + + deeplySkolemise (Int -> forall a. Ord a => blah) + = ( wp, [a], [d:Ord a], Int -> blah ) + where wp = \x:Int. /\a. \(d:Ord a). x + + deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) + where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x + +In general, + if deeplySkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds tvs, evs + +ToDo: this eta-abstraction plays fast and loose with termination, + because it can introduce extra lambdas. Maybe add a `seq` to + fix this +-} + +deeplySkolemise + :: TcSigmaType + -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType) + +deeplySkolemise ty + | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys + ; (subst, tvs1) <- tcInstSkolTyVars tvs + ; ev_vars1 <- newEvVars (substTheta subst theta) + ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty') + ; return ( mkWpLams ids1 + <.> mkWpTyLams tvs1 + <.> mkWpLams ev_vars1 + <.> wrap + <.> mkWpEvVarApps ids1 + , tvs1 ++ tvs2 + , ev_vars1 ++ ev_vars2 + , mkFunTys arg_tys rho ) } + + | otherwise + = return (idHsWrapper, [], [], ty) + +deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha +-- In general if +-- if deeplyInstantiate ty = (wrap, rho) +-- and e :: ty +-- then wrap e :: rho + +deeplyInstantiate orig ty + | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty + = do { (subst, tvs') <- tcInstTyVars tvs + ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys) + ; let theta' = substTheta subst theta + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig + , text "type" <+> ppr ty + , text "with" <+> ppr tvs' + , text "args:" <+> ppr ids1 + , text "theta:" <+> ppr theta' ]) + ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho) + ; return (mkWpLams ids1 + <.> wrap2 + <.> wrap1 + <.> mkWpEvVarApps ids1, + mkFunTys arg_tys rho2) } + + | otherwise = return (idHsWrapper, ty) + +{- +************************************************************************ +* * + Instantiating a call +* * +************************************************************************ +-} + +---------------- +instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper +-- Instantiate the constraints of a call +-- (instCall o tys theta) +-- (a) Makes fresh dictionaries as necessary for the constraints (theta) +-- (b) Throws these dictionaries into the LIE +-- (c) Returns an HsWrapper ([.] tys dicts) + +instCall orig tys theta + = do { dict_app <- instCallConstraints orig theta + ; return (dict_app <.> mkWpTyApps tys) } + +---------------- +instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper +-- Instantiates the TcTheta, puts all constraints thereby generated +-- into the LIE, and returns a HsWrapper to enclose the call site. + +instCallConstraints orig preds + | null preds + = return idHsWrapper + | otherwise + = do { evs <- mapM go preds + ; traceTc "instCallConstraints" (ppr evs) + ; return (mkWpEvApps evs) } + where + go pred + | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut + = do { co <- unifyType ty1 ty2 + ; return (EvCoercion co) } + | otherwise + = do { ev_var <- emitWanted modified_orig pred + ; return (EvId ev_var) } + where + -- Coercible constraints appear as normal class constraints, but + -- are aggressively canonicalized and manipulated during solving. + -- The final equality to solve may barely resemble the initial + -- constraint. Here, we remember the initial constraint in a + -- CtOrigin for better error messages. It's perhaps worthwhile + -- considering making this approach general, for other class + -- constraints, too. + modified_orig + | Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred + = CoercibleOrigin ty1 ty2 + | otherwise + = orig + +---------------- +instStupidTheta :: CtOrigin -> TcThetaType -> TcM () +-- Similar to instCall, but only emit the constraints in the LIE +-- Used exclusively for the 'stupid theta' of a data constructor +instStupidTheta orig theta + = do { _co <- instCallConstraints orig theta -- Discard the coercion + ; return () } + +{- +************************************************************************ +* * + Literals +* * +************************************************************************ + +In newOverloadedLit we convert directly to an Int or Integer if we +know that's what we want. This may save some time, by not +temporarily generating overloaded literals, but it won't catch all +cases (the rest are caught in lookupInst). +-} + +newOverloadedLit :: CtOrigin + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit orig lit res_ty + = do dflags <- getDynFlags + newOverloadedLit' dflags orig lit res_ty + +newOverloadedLit' :: DynFlags + -> CtOrigin + -> HsOverLit Name + -> TcRhoType + -> TcM (HsOverLit TcId) +newOverloadedLit' dflags orig + lit@(OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = meth_name }) res_ty + + | not rebindable + , Just expr <- shortCutLit dflags val res_ty + -- Do not generate a LitInst for rebindable syntax. + -- Reason: If we do, tcSimplify will call lookupInst, which + -- will call tcSyntaxName, which does unification, + -- which tcSimplify doesn't like + = return (lit { ol_witness = expr, ol_type = res_ty + , ol_rebindable = rebindable }) + + | otherwise + = do { hs_lit <- mkOverLit val + ; let lit_ty = hsLitType hs_lit + ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty) + -- Overloaded literals must have liftedTypeKind, because + -- we're instantiating an overloaded function here, + -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 + -- However this'll be picked up by tcSyntaxOp if necessary + ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit)) + ; return (lit { ol_witness = witness, ol_type = res_ty + , ol_rebindable = rebindable }) } + +------------ +mkOverLit :: OverLitVal -> TcM HsLit +mkOverLit (HsIntegral src i) + = do { integer_ty <- tcMetaTy integerTyConName + ; return (HsInteger src i integer_ty) } + +mkOverLit (HsFractional r) + = do { rat_ty <- tcMetaTy rationalTyConName + ; return (HsRat r rat_ty) } + +mkOverLit (HsIsString src s) = return (HsString src s) + +{- +************************************************************************ +* * + Re-mappable syntax + + Used only for arrow syntax -- find a way to nuke this +* * +************************************************************************ + +Suppose we are doing the -XRebindableSyntax thing, and we encounter +a do-expression. We have to find (>>) in the current environment, which is +done by the rename. Then we have to check that it has the same type as +Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had +this: + + (>>) :: HB m n mn => m a -> n b -> mn b + +So the idea is to generate a local binding for (>>), thus: + + let then72 :: forall a b. m a -> m b -> m b + then72 = ...something involving the user's (>>)... + in + ...the do-expression... + +Now the do-expression can proceed using then72, which has exactly +the expected type. + +In fact tcSyntaxName just generates the RHS for then72, because we only +want an actual binding in the do-expression case. For literals, we can +just use the expression inline. +-} + +tcSyntaxName :: CtOrigin + -> TcType -- Type to instantiate it at + -> (Name, HsExpr Name) -- (Standard name, user name) + -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in HsExpr + +tcSyntaxName orig ty (std_nm, HsVar user_nm) + | std_nm == user_nm + = do rhs <- newMethodFromName orig std_nm ty + return (std_nm, rhs) + +tcSyntaxName orig ty (std_nm, user_nm_expr) = do + std_id <- tcLookupId std_nm + let + -- C.f. newMethodAtLoc + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + sigma1 = substTyWith [tv] [ty] tau + -- Actually, the "tau-type" might be a sigma-type in the + -- case of locally-polymorphic methods. + + addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do + + -- Check that the user-supplied thing has the + -- same type as the standard one. + -- Tiresome jiggling because tcCheckSigma takes a located expression + span <- getSrcSpanM + expr <- tcPolyExpr (L span user_nm_expr) sigma1 + return (std_nm, unLoc expr) + +syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv + -> TcRn (TidyEnv, SDoc) +syntaxNameCtxt name orig ty tidy_env + = do { inst_loc <- getCtLoc orig + ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) + <+> ptext (sLit "(needed by a syntactic construct)") + , nest 2 (ptext (sLit "has the required type:") + <+> ppr (tidyType tidy_env ty)) + , nest 2 (pprArisingAt inst_loc) ] + ; return (tidy_env, msg) } + +{- +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag +getOverlapFlag overlap_mode + = do { dflags <- getDynFlags + ; let overlap_ok = xopt Opt_OverlappingInstances dflags + incoherent_ok = xopt Opt_IncoherentInstances dflags + use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags + , overlapMode = x } + default_oflag | incoherent_ok = use (Incoherent "") + | overlap_ok = use (Overlaps "") + | otherwise = use (NoOverlap "") + + final_oflag = setOverlapModeMaybe default_oflag overlap_mode + ; return final_oflag } + +tcGetInsts :: TcM [ClsInst] +-- Gets the local class instances. +tcGetInsts = fmap tcg_insts getGblEnv + +newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcM ClsInst +newClsInst overlap_mode dfun_name tvs theta clas tys + = do { (subst, tvs') <- freshenTyVarBndrs tvs + -- Be sure to freshen those type variables, + -- so they are sure not to appear in any lookup + ; let tys' = substTys subst tys + theta' = substTheta subst theta + dfun = mkDictFunId dfun_name tvs' theta' clas tys' + -- Substituting in the DFun type just makes sure that + -- we are using TyVars rather than TcTyVars + -- Not sure if this is really the right place to do so, + -- but it'll do fine + ; oflag <- getOverlapFlag overlap_mode + ; return (mkLocalInstance dfun oflag tvs' clas tys') } + +tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; env <- getGblEnv + ; (inst_env', cls_insts') <- foldlM addLocalInst + (tcg_inst_env env, tcg_insts env) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +-- If overwrite_inst, then we can overwrite a direct match +addLocalInst (home_ie, my_insts) ispec + = do { + -- Instantiate the dfun type so that we extend the instance + -- envt with completely fresh template variables + -- This is important because the template variables must + -- not overlap with anything in the things being looked up + -- (since we do unification). + -- + -- We use tcInstSkolType because we don't want to allocate fresh + -- *meta* type variables. + -- + -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because + -- these variables must be bindable by tcUnifyTys. See + -- the call to tcUnifyTys in InstEnv, and the special + -- treatment that instanceBindFun gives to isOverlappableTyVar + -- This is absurdly delicate. + + -- Load imported instances, so that we report + -- duplicates correctly + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; tcg_env <- getGblEnv + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + -- See Note [Override identical instances in GHCi] + ; let home_ie' + | isGHCi = deleteFromInstEnv home_ie ispec + | otherwise = home_ie + + (_tvs, cls, tys) = instanceHead ispec + -- If we're compiling sig-of and there's an external duplicate + -- instance, silently ignore it (that's the instance we're + -- implementing!) NB: we still count local duplicate instances + -- as errors. + -- See Note [Signature files and type class instances] + global_ie + | isJust (tcg_sig_of tcg_env) = emptyInstEnv + | otherwise = eps_inst_env eps + inst_envs = InstEnvs { ie_global = global_ie + , ie_local = home_ie' + , ie_visible = tcg_visible_orphan_mods tcg_env } + (matches, _, _) = lookupInstEnv inst_envs cls tys + dups = filter (identicalClsInstHead ispec) (map fst matches) + + -- Check functional dependencies + ; case checkFunDeps inst_envs ispec of + Just specs -> funDepErr ispec specs + Nothing -> return () + + -- Check for duplicate instance decls. + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } + +{- +Note [Signature files and type class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instances in signature files do not have an effect when compiling: +when you compile a signature against an implementation, you will +see the instances WHETHER OR NOT the instance is declared in +the file (this is because the signatures go in the EPS and we +can't filter them out easily.) This is also why we cannot +place the instance in the hi file: it would show up as a duplicate, +and we don't have instance reexports anyway. + +However, you might find them useful when typechecking against +a signature: the instance is a way of indicating to GHC that +some instance exists, in case downstream code uses it. + +Implementing this is a little tricky. Consider the following +situation (sigof03): + + module A where + instance C T where ... + + module ASig where + instance C T + +When compiling ASig, A.hi is loaded, which brings its instances +into the EPS. When we process the instance declaration in ASig, +we should ignore it for the purpose of doing a duplicate check, +since it's not actually a duplicate. But don't skip the check +entirely, we still want this to fail (tcfail221): + + module ASig where + instance C T + instance C T + +Note that in some situations, the interface containing the type +class instances may not have been loaded yet at all. The usual +situation when A imports another module which provides the +instances (sigof02m): + + module A(module B) where + import B + +See also Note [Signature lazy interface loading]. We can't +rely on this, however, since sometimes we'll have spurious +type class instances in the EPS, see #9422 (sigof02dm) + +************************************************************************ +* * + Errors and tracing +* * +************************************************************************ +-} + +traceDFuns :: [ClsInst] -> TcRn () +traceDFuns ispecs + = traceTc "Adding instances:" (vcat (map pp ispecs)) + where + pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) + 2 (ppr ispec) + -- Print the dfun name itself too + +funDepErr :: ClsInst -> [ClsInst] -> TcRn () +funDepErr ispec ispecs + = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:")) + (ispec : ispecs) + +dupInstErr :: ClsInst -> ClsInst -> TcRn () +dupInstErr ispec dup_ispec + = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) + [ispec, dup_ispec] + +addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () +addClsInstsErr herald ispecs + = setSrcSpan (getSrcSpan (head sorted)) $ + addErr (hang herald 2 (pprInstances sorted)) + where + sorted = sortWith getSrcLoc ispecs + -- The sortWith just arranges that instances are dislayed in order + -- of source location, which reduced wobbling in error messages, + -- and is better for users + +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting free tyvars ------------------------- +tyVarsOfCt :: Ct -> TcTyVarSet +tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv +tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk +tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys +tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) + +tyVarsOfCts :: Cts -> TcTyVarSet +tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet + +tyVarsOfWC :: WantedConstraints -> TyVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) + = tyVarsOfCts simple `unionVarSet` + tyVarsOfBag tyVarsOfImplic implic `unionVarSet` + tyVarsOfCts insol + +tyVarsOfImplic :: Implication -> TyVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyVarsOfImplic (Implic { ic_skols = skols + , ic_given = givens, ic_wanted = wanted }) + = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens)) + `delVarSetList` skols + +tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet +tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs new file mode 100644 index 00000000..688a1e93 --- /dev/null +++ b/compiler/typecheck/TcAnnotations.hs @@ -0,0 +1,69 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[TcAnnotations]{Typechecking annotations} +-} + +{-# LANGUAGE CPP #-} + +module TcAnnotations ( tcAnnotations, annCtxt ) where + +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runAnnotation ) +import Module +import DynFlags +import Control.Monad ( when ) +#endif + +import HsSyn +import Annotations +import Name +import TcRnMonad +import SrcLoc +import Outputable + +import FastString + +#ifndef GHCI + +tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +-- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268 +tcAnnotations [] = return [] +tcAnnotations anns@(L loc _ : _) + = do { setSrcSpan loc $ addWarnTc $ + (ptext (sLit "Ignoring ANN annotation") <> plural anns <> comma + <+> ptext (sLit "because this is a stage-1 compiler or doesn't support GHCi")) + ; return [] } + +#else + +tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] +-- GHCI exists, typecheck the annotations +tcAnnotations anns = mapM tcAnnotation anns + +tcAnnotation :: LAnnDecl Name -> TcM Annotation +tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do + -- Work out what the full target of this annotation was + mod <- getModule + let target = annProvenanceToTarget mod provenance + + -- Run that annotation and construct the full Annotation data structure + setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do + -- See #10826 -- Annotations allow one to bypass Safe Haskell. + dflags <- getDynFlags + when (safeLanguageOn dflags) $ failWithTc safeHsErr + runAnnotation target expr + where + safeHsErr = vcat [ ptext (sLit "Annotations are not compatible with Safe Haskell.") + , ptext (sLit "See https://ghc.haskell.org/trac/ghc/ticket/10826") ] + +annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod +#endif + +annCtxt :: OutputableBndr id => AnnDecl id -> SDoc +annCtxt ann + = hang (ptext (sLit "In the annotation:")) 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs new file mode 100644 index 00000000..9ad65722 --- /dev/null +++ b/compiler/typecheck/TcArrows.hs @@ -0,0 +1,422 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Typecheck arrow notation +-} + +{-# LANGUAGE RankNTypes #-} + +module TcArrows ( tcProc ) where + +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) + +import HsSyn +import TcMatches +import TcHsSyn( hsLPatType ) +import TcType +import TcMType +import TcBinds +import TcPat +import TcUnify +import TcRnMonad +import TcEnv +import TcEvidence +import Id( mkLocalId ) +import Inst +import Name +import Coercion ( Role(..) ) +import TysWiredIn +import VarSet +import TysPrim +import BasicTypes( Arity ) +import SrcLoc +import Outputable +import FastString +import Util + +import Control.Monad + +{- +Note [Arrow overivew] +~~~~~~~~~~~~~~~~~~~~~ +Here's a summary of arrows and how they typecheck. First, here's +a cut-down syntax: + + expr ::= .... + | proc pat cmd + + cmd ::= cmd exp -- Arrow application + | \pat -> cmd -- Arrow abstraction + | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 + | ... -- If, case in the usual way + + cmd_type ::= carg_type --> type + + carg_type ::= () + | (type, carg_type) + +Note that + * The 'exp' in an arrow form can mention only + "arrow-local" variables + + * An "arrow-local" variable is bound by an enclosing + cmd binding form (eg arrow abstraction) + + * A cmd_type is here written with a funny arrow "-->", + The bit on the left is a carg_type (command argument type) + which itself is a nested tuple, finishing with () + + * The arrow-tail operator (e1 -< e2) means + (| e1 <<< arr snd |) e2 + + +************************************************************************ +* * + Proc +* * +************************************************************************ +-} + +tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr + -> TcRhoType -- Expected type of whole proc expression + -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) + +tcProc pat cmd exp_ty + = newArrowScope $ + do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ + tcCmdTop cmd_env cmd (unitTy, res_ty) + ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; return (pat', cmd', res_co) } + +{- +************************************************************************ +* * + Commands +* * +************************************************************************ +-} + +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type +type CmdArgType = TcTauType -- carg_type, a nested tuple + +data CmdEnv + = CmdEnv { + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + } + +mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType +mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] + +--------------------------------------- +tcCmdTop :: CmdEnv + -> LHsCmdTop Name + -> CmdType + -> TcM (LHsCmdTop TcId) + +tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) + = setSrcSpan loc $ + do { cmd' <- tcCmd env cmd cmd_ty + ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names + ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } +---------------------------------------- +tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) + -- The main recursive function +tcCmd env (L loc cmd) res_ty + = setSrcSpan loc $ do + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } + +tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) +tc_cmd env (HsCmdPar cmd) res_ty + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar cmd') } + +tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsCmdLet binds' (L body_loc body')) } + +tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ do + (scrut', scrut_ty) <- tcInferRho scrut + matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty + return (HsCmdCase scrut' matches') + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = mc_body } + mc_body body res_ty' = tcCmd env body (stk, res_ty') + +tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcMonoExpr pred boolTy + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf Nothing pred' b1' b2') + } + +tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if + = do { pred_ty <- newFlexiTyVarTy openTypeKind + -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r + -- because we're going to apply it to the environment, not + -- the return value. + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] + ; let r_ty = mkTyVarTy r_tv + ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty + ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) + (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty + ; return (HsCmdIf (Just fun') pred' b1' b2') + } + +------------------------------------------- +-- Arrow application +-- (f -< a) or (f -<< a) +-- +-- D |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -< arg :: stk --> t2 +-- +-- D,G |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -<< arg :: stk --> t2 +-- +-- (plus -<< requires ArrowApply) + +tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newFlexiTyVarTy openTypeKind + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + + ; arg' <- tcMonoExpr arg arg_ty + + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } + where + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. + -- See Note [Escaping the arrow scope] in TcRnTypes + select_arrow_scope tc = case ho_app of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + +------------------------------------------- +-- Command application +-- +-- D,G |- exp : t +-- D;G |-a cmd : (t,stk) --> res +-- ----------------------------- +-- D;G |-a cmd exp : stk --> res + +tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { arg_ty <- newFlexiTyVarTy openTypeKind + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcMonoExpr arg arg_ty + ; return (HsCmdApp fun' arg') } + +------------------------------------------- +-- Lambda +-- +-- D;G,x:t |-a cmd : stk --> res +-- ------------------------------ +-- D;G |-a (\x.cmd) : (t,stk) --> res + +tc_cmd env + (HsCmdLam (MG { mg_alts = [L mtch_loc + (match@(Match _ pats _maybe_rhs_sig grhss))], + mg_origin = origin })) + (cmd_stk, res_ty) + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats arg_tys $ + tc_grhss grhss cmd_stk' res_ty + + ; let match' = L mtch_loc (Match Nothing pats' Nothing grhss') + arg_tys = map hsLPatType pats' + cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys + , mg_res_ty = res_ty, mg_origin = origin }) + ; return (mkHsCmdCast co cmd') } + where + n_pats = length pats + match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? + pg_ctxt = PatGuard match_ctxt + + tc_grhss (GRHSs grhss binds) stk_ty res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs grhss' binds') } + + tc_grhs stk_ty res_ty (GRHS guards body) + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk_ty, res_ty) + ; return (GRHS guards' rhs') } + +------------------------------------------- +-- Do notation + +tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) + = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } + + +----------------------------------------------------------------- +-- Arrow ``forms'' (| e c1 .. cn |) +-- +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 +-- ... +-- -> an (e, stkn) tn +-- -> a (e, stk) t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t + +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args + ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' + mkFunTys cmd_tys $ + mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty + ; expr' <- tcPolyExpr expr e_ty + ; return (HsCmdArrForm expr' fixity cmd_args') } + + where + tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) + tc_cmd_arg cmd + = do { arr_ty <- newFlexiTyVarTy arrowTyConKind + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + +----------------------------------------------------------------- +-- Base case for illegal commands +-- This is where expressions that aren't commands get rejected + +tc_cmd _ cmd _ + = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), + ptext (sLit "was found where an arrow command was expected")]) + + +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) +matchExpectedCmdArgs 0 ty + = return (mkTcNomReflCo ty, [], ty) +matchExpectedCmdArgs n ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 + ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + +{- +************************************************************************ +* * + Stmts +* * +************************************************************************ +-} + +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker +tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } + +tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + +tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + zipWithM tcCheckId tup_names tup_elt_tys + + ; thing <- thing_inside res_ty + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + + ; return (emptyRecStmtId { recS_stmts = stmts' + , recS_later_ids = later_ids + , recS_later_rets = later_rets + , recS_rec_ids = rec_ids + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } + +{- +************************************************************************ +* * + Helpers +* * +************************************************************************ +-} + +mkPairTy :: Type -> Type -> Type +mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] + +arrowTyConKind :: Kind -- *->*->* +arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind + +{- +************************************************************************ +* * + Errors +* * +************************************************************************ +-} + +cmdCtxt :: HsCmd Name -> SDoc +cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs new file mode 100644 index 00000000..43e1f221 --- /dev/null +++ b/compiler/typecheck/TcBinds.hs @@ -0,0 +1,1636 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcBinds]{TcBinds} +-} + +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} + +module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, + tcHsBootSigs, tcPolyCheck, + PragFun, tcSpecPrags, tcVectDecls, mkPragFun, + TcSigInfo(..), TcSigFun, + instTcTySig, instTcTySigFromId, findScopedTyVars, + badBootDeclErr, mkExport ) where + +import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) +import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind ) +import DynFlags +import HsSyn +import HscTypes( isHsBootOrSig ) +import TcRnMonad +import TcEnv +import TcUnify +import TcSimplify +import TcEvidence +import TcHsType +import TcPat +import TcMType +import ConLike +import FamInstEnv( normaliseType ) +import FamInst( tcGetFamInstEnvs ) +import Type( pprSigmaTypeExtraCts ) +import TyCon +import TcType +import TysPrim +import Id +import Var +import VarSet +import VarEnv( TidyEnv ) +import Module +import Name +import NameSet +import NameEnv +import SrcLoc +import Bag +import ListSetOps +import ErrUtils +import Digraph +import Maybes +import Util +import BasicTypes +import Outputable +import FastString +import Type(mkStrLitTy) +import PrelNames(ipClassName) +import TcValidity (checkValidType) + +import Control.Monad +import Data.List (partition) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Type-checking bindings} +* * +************************************************************************ + +@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because +it needs to know something about the {\em usage} of the things bound, +so that it can create specialisations of them. So @tcBindsAndThen@ +takes a function which, given an extended environment, E, typechecks +the scope of the bindings returning a typechecked thing and (most +important) an LIE. It is this LIE which is then used as the basis for +specialising the things bound. + +@tcBindsAndThen@ also takes a "combiner" which glues together the +bindings and the "thing" to make a new "thing". + +The real work is done by @tcBindWithSigsAndThen@. + +Recursive and non-recursive binds are handled in essentially the same +way: because of uniques there are no scoping issues left. The only +difference is that non-recursive bindings can bind primitive values. + +Even for non-recursive binding groups we add typings for each binder +to the LVE for the following reason. When each individual binding is +checked the type of its LHS is unified with that of its RHS; and +type-checking the LHS of course requires that the binder is in scope. + +At the top-level the LIE is sure to contain nothing but constant +dictionaries, which we resolve at the module level. + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm +-} + +tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) +-- The TcGblEnv contains the new tcg_binds and tcg_spects +-- The TcLclEnv has an extended type envt for the new bindings +tcTopBinds (ValBindsOut binds sigs) + = do { -- Pattern synonym bindings populate the global environment + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ + do { gbl <- getGblEnv + ; lcl <- getLclEnv + ; return (gbl, lcl) } + ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids + + ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd) + (tcg_binds tcg_env) + binds' + , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } } + + ; return (tcg_env', tcl_env) } + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive LHsBinds + +tcTopBinds (ValBindsIn {}) = panic "tcTopBinds" + +tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv +tcRecSelBinds (ValBindsOut binds sigs) + = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv) + ; let tcg_env' + | isHsBootOrSig (tcg_src tcg_env) = tcg_env + | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd) + (tcg_binds tcg_env) + rec_sel_binds } + -- Do not add the code for record-selector bindings when + -- compiling hs-boot files + ; return tcg_env' } +tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" + +tcHsBootSigs :: HsValBinds Name -> TcM [Id] +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr + ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + where + tc_boot_sig (TypeSig lnames ty _) = mapM f lnames + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty) } + -- Notice that we make GlobalIds, not LocalIds + tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) +tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) + +badBootDeclErr :: MsgDoc +badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") + +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) + +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } + +tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside + ; return (HsValBinds (ValBindsOut binds' sigs), thing) } +tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" + +tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside + = do { ipClass <- tcLookupClass ipClassName + ; (given_ips, ip_binds') <- + mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + -- See Note [Implicit parameter untouchables] + ; (ev_binds, result) <- checkConstraints (IPSkol ips) + [] given_ips thing_inside + + ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } + where + ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds] + + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) + = do { ty <- newFlexiTyVarTy openTypeKind + ; let p = mkStrLitTy $ hsIPNameFS ip + ; ip_id <- newDict ipClass [ p, ty ] + ; expr' <- tcMonoExpr expr ty + ; let d = toDict ipClass p ty `fmap` expr' + ; return (ip_id, (IPBind (Right ip_id) d)) } + tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" + + -- Coerces a `t` into a dictionry for `IP "x" t`. + -- co : t -> IP "x" t + toDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + wrapIP $ mkClassPred ipClass [x,ty] + +{- +Note [Implicit parameter untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We add the type variables in the types of the implicit parameters +as untouchables, not so much because we really must not unify them, +but rather because we otherwise end up with constraints like this + Num alpha, Implic { wanted = alpha ~ Int } +The constraint solver solves alpha~Int by unification, but then +doesn't float that solved constraint out (it's not an unsolved +wanted). Result disaster: the (Num alpha) is again solved, this +time by defaulting. No no no. + +However [Oct 10] this is all handled automatically by the +untouchable-range idea. + +Note [Placeholder PatSyn kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #9161) + + {-# LANGUAGE PatternSynonyms, DataKinds #-} + pattern A = () + b :: A + b = undefined + +Here, the type signature for b mentions A. But A is a pattern +synonym, which is typechecked (for very good reasons; a view pattern +in the RHS may mention a value binding) as part of a group of +bindings. It is entirely resonable to reject this, but to do so +we need A to be in the kind environment when kind-checking the signature for B. + +Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding + A -> AGlobal (AConLike (PatSynCon _|_)) +to the environment. Then TcHsType.tcTyVar will find A in the kind environment, +and will give a 'wrongThingErr' as a result. But the lookup of A won't fail. + +The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in +tcTyVar, doesn't look inside the TcTyThing. +-} + +tcValBinds :: TopLevelFlag + -> [(RecFlag, LHsBinds Name)] -> [LSig Name] + -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) + +tcValBinds top_lvl binds sigs thing_inside + = do { -- Typecheck the signature + ; (poly_ids, sig_fn, nwc_tvs) <- tcExtendKindEnv2 patsyn_placeholder_kinds $ + -- See Note [Placeholder PatSyn kinds] + tcTySigs sigs + + ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) + + -- Extend the envt right away with all + -- the Ids declared with type signatures + -- Use tcExtendIdEnv3 to avoid extending the TcIdBinder stack + ; tcExtendIdEnv3 [(idName id, id) | id <- poly_ids] (mkVarSet nwc_tvs) $ do + { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do + { thing <- thing_inside + -- See Note [Pattern synonym wrappers don't yield dependencies] + ; patsyn_workers <- mapM tcPatSynBuilderBind patsyns + ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} + where + patsyns + = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds] + patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds] + = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ] + placeholder_patsyn_tything + = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" + +------------------------ +tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun + -> [(RecFlag, LHsBinds Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time +-- Here a "strongly connected component" has the strightforward +-- meaning of a group of bindings that mention each other, +-- ignoring type signatures (that part comes later) + +tcBindGroups _ _ _ [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group $ + tcBindGroups top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +------------------------ +tc_group :: forall thing. + TopLevelFlag -> TcSigFun -> PragFun + -> (RecFlag, LHsBinds Name) -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside + -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + = do { let bind = case bagToList binds of + [bind] -> bind + [] -> panic "tc_group: empty list of binds" + _ -> panic "tc_group: NonRecursive binds is not a singleton bag" + ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside + ; return ( [(NonRecursive, bind')], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + = -- To maximise polymorphism, we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) + do { traceTc "tc_group rec" (pprLHsBinds binds) + ; when hasPatSyn $ recursivePatSynErr binds + ; (binds1, thing) <- go sccs + ; return ([(Recursive, binds1)], thing) } + -- Rec them all together + where + hasPatSyn = anyBag (isPatSyn . unLoc) binds + isPatSyn PatSynBind{} = True + isPatSyn _ = False + + sccs :: [SCC (LHsBind Name)] + sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds) + + go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing) + go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc + ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 $ + go sccs + ; return (binds1 `unionBags` binds2, thing) } + go [] = do { thing <- thing_inside; return (emptyBag, thing) } + + tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] + tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds + + tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive + +recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a +recursivePatSynErr binds + = failWithTc $ + hang (ptext (sLit "Recursive pattern synonym definition with following bindings:")) + 2 (vcat $ map pprLBind . bagToList $ binds) + where + pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> + pprLoc loc + +tc_single :: forall thing. + TopLevelFlag -> TcSigFun -> PragFun + -> LHsBind Name -> TcM thing + -> TcM (LHsBinds TcId, thing) +tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside + = do { (pat_syn, aux_binds) <- tc_pat_syn_decl + ; let tything = AConLike (PatSynCon pat_syn) + ; thing <- tcExtendGlobalEnv [tything] thing_inside + ; return (aux_binds, thing) + } + where + tc_pat_syn_decl = case sig_fn name of + Nothing -> tcInferPatSynDecl psb + Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi + Just _ -> panic "tc_single" + +tc_single top_lvl sig_fn prag_fn lbind thing_inside + = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn + NonRecursive NonRecursive + [lbind] + ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside + ; return (binds1, thing) } + +-- | No signature or a partial signature +noCompleteSig :: Maybe TcSigInfo -> Bool +noCompleteSig Nothing = True +noCompleteSig (Just sig) = isPartialSig sig + +------------------------ +mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)] + +type BKey = Int -- Just number off the bindings + +mkEdges sig_fn binds + = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ]) + | (bind, key) <- keyd_binds + ] + where + no_sig :: Name -> Bool + no_sig n = noCompleteSig (sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- collectHsBindBinders bind ] + +------------------------ +tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> [LHsBind Name] -- None are PatSynBind + -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) + +-- Typechecks a single bunch of values bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. +-- +-- Knows nothing about the scope of the bindings +-- None of the bindings are pattern synonyms + +tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list + = setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do + -- Set up main recover; take advantage of any type sigs + + { traceTc "------------------------------------------------" Outputable.empty + ; traceTc "Bindings for {" (ppr binder_names) + ; dflags <- getDynFlags + ; type_env <- getLclTypeEnv + ; let plan = decideGeneralisationPlan dflags type_env + binder_names bind_list sig_fn + ; traceTc "Generalisation plan" (ppr plan) + ; result@(tc_binds, poly_ids, _) <- case plan of + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list + CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind + + -- Check whether strict bindings are ok + -- These must be non-recursive etc, and are not generalised + -- They desugar to a case expression in the end + ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids + ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group + , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] + ]) + + ; return result } + where + binder_names = collectHsBindListBinders bind_list + loc = foldr1 combineSrcSpans (map getLoc bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all + +------------------ +tcPolyNoGen -- No generalisation whatsoever + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> PragFun -> TcSigFun + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) + +tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list + ; mono_ids' <- mapM tc_mono_info mono_infos + ; return (binds', mono_ids', NotTopLevel) } + where + tc_mono_info (name, _, mono_id) + = do { mono_ty' <- zonkTcType (idType mono_id) + -- Zonk, mainly to expose unboxed types to checkStrictBinds + ; let mono_id' = setIdType mono_id mono_ty' + ; _specs <- tcSpecPrags mono_id' (prag_fn name) + ; return mono_id' } + -- NB: tcPrags generates error messages for + -- specialisation pragmas for non-overloaded sigs + -- Indeed that is why we call it here! + -- So we can safely ignore _specs + +------------------ +tcPolyCheck :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> PragFun -> TcSigInfo + -> LHsBind Name + -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) +-- There is just one binding, +-- it binds a single variable, +-- it has a signature, +tcPolyCheck rec_tc prag_fn + sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped + , sig_nwcs = sig_nwcs, sig_theta = theta + , sig_tau = tau, sig_loc = loc }) + bind + = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards + do { ev_vars <- newEvVars theta + ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) + prag_sigs = prag_fn (idName poly_id) + tvs = map snd tvs_w_scoped + ; (ev_binds, (binds', [mono_info])) + <- setSrcSpan loc $ + checkConstraints skol_info tvs ev_vars $ + tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind] + + ; spec_prags <- tcSpecPrags poly_id prag_sigs + ; poly_id <- addInlinePrags poly_id prag_sigs + + ; let (_, _, mono_id) = mono_info + export = ABE { abe_wrap = idHsWrapper + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags } + abs_bind = L loc $ AbsBinds + { abs_tvs = tvs + , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds + , abs_exports = [export], abs_binds = binds' } + closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel + | otherwise = NotTopLevel + ; return (unitBag abs_bind, [poly_id], closed) } + +tcPolyCheck _rec_tc _prag_fn sig _bind + = pprPanic "tcPolyCheck" (ppr sig) + +------------------ +tcPolyInfer + :: RecFlag -- Whether it's recursive after breaking + -- dependencies based on type signatures + -> PragFun -> TcSigFun + -> Bool -- True <=> apply the monomorphism restriction + -> Bool -- True <=> free vars have closed types + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) +tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list + = do { (((binds', mono_infos), tclvl), wanted) + <- captureConstraints $ + captureTcLevel $ + tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list + + ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] + ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) + ; (qtvs, givens, mr_bites, ev_binds) + <- simplifyInfer tclvl mono name_taus wanted + + ; inferred_theta <- zonkTcThetaType (map evVarPred givens) + ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta) + mono_infos + + ; loc <- getSrcSpanM + ; let poly_ids = map abe_poly exports + final_closed | closed && not mr_bites = TopLevel + | otherwise = NotTopLevel + abs_bind = L loc $ + AbsBinds { abs_tvs = qtvs + , abs_ev_vars = givens, abs_ev_binds = ev_binds + , abs_exports = exports, abs_binds = binds' } + + ; traceTc "Binding:" (ppr final_closed $$ + ppr (poly_ids `zip` map idType poly_ids)) + ; return (unitBag abs_bind, poly_ids, final_closed) } + -- poly_ids are guaranteed zonked by mkExport + +-------------- +mkExport :: PragFun + -> [TyVar] -> TcThetaType -- Both already zonked + -> MonoBindInfo + -> TcM (ABExport Id) +-- Only called for generalisation plan IferGen, not by CheckGen or NoGen +-- +-- mkExport generates exports with +-- zonked type variables, +-- zonked poly_ids +-- The former is just because no further unifications will change +-- the quantified type variables, so we can fix their final form +-- right now. +-- The latter is needed because the poly_ids are used to extend the +-- type environment; see the invariant on TcEnv.tcExtendIdEnv + +-- Pre-condition: the qtvs and theta are already zonked + +mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id) + = do { mono_ty <- zonkTcType (idType mono_id) + + ; poly_id <- case mb_sig of + Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty + Just (TcPatSynInfo _) -> panic "mkExport" + Just sig | isPartialSig sig + -> do { final_theta <- completeTheta inferred_theta sig + ; mkInferredPolyId poly_name qtvs final_theta mono_ty } + | otherwise + -> return (sig_id sig) + + -- NB: poly_id has a zonked type + ; poly_id <- addInlinePrags poly_id prag_sigs + ; spec_prags <- tcSpecPrags poly_id prag_sigs + -- tcPrags requires a zonked poly_id + + ; let sel_poly_ty = mkSigmaTy qtvs inferred_theta mono_ty + ; traceTc "mkExport: check sig" + (vcat [ ppr poly_name, ppr sel_poly_ty, ppr (idType poly_id) ]) + + -- Perform the impedence-matching and ambiguity check + -- right away. If it fails, we want to fail now (and recover + -- in tcPolyBinds). If we delay checking, we get an error cascade. + -- Remember we are in the tcPolyInfer case, so the type envt is + -- closed (unless we are doing NoMonoLocalBinds in which case all bets + -- are off) + -- See Note [Impedence matching] + ; (wrap, wanted) <- addErrCtxtM (mk_bind_msg inferred True poly_name (idType poly_id)) $ + captureConstraints $ + tcSubType_NC sig_ctxt sel_poly_ty (idType poly_id) + ; ev_binds <- simplifyTop wanted + + ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = SpecPrags spec_prags }) } + where + inferred = isNothing mb_sig + prag_sigs = prag_fn poly_name + sig_ctxt = InfSigCtxt poly_name + +mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id +-- In the inference case (no signature) this stuff figures out +-- the right type variables and theta to quantify over +-- See Note [Validity of inferred types] +mkInferredPolyId poly_name qtvs theta mono_ty + = do { fam_envs <- tcGetFamInstEnvs + + ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, + -- (see Note [Lazy flattening] in TcFlatten) so do it + -- here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + + my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty)) + -- Include kind variables! Trac #7916 + + my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order + my_theta = filter (quantifyPred my_tvs2) theta + inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty + + ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ + checkValidType (InfSigCtxt poly_name) inferred_poly_ty + + ; return (mkLocalId poly_name inferred_poly_ty) } + +mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env poly_ty + ; return (tidy_env', mk_msg tidy_ty) } + where + mk_msg ty = vcat [ ptext (sLit "When checking that") <+> quotes (ppr poly_name) + <+> ptext (sLit "has the") <+> what <+> ptext (sLit "type") + , nest 2 (ppr poly_name <+> dcolon <+> ppr ty) + , ppWhen want_ambig $ + ptext (sLit "Probable cause: the inferred type is ambiguous") ] + what | inferred = ptext (sLit "inferred") + | otherwise = ptext (sLit "specified") + + +-- | Report the inferred constraints for an extra-constraints wildcard/hole as +-- an error message, unless the PartialTypeSignatures flag is enabled. In this +-- case, the extra inferred constraints are accepted without complaining. +-- Returns the annotated constraints combined with the inferred constraints. +completeTheta :: TcThetaType -> TcSigInfo -> TcM TcThetaType +completeTheta _ (TcPatSynInfo _) + = panic "Extra-constraints wildcard not supported in a pattern signature" +completeTheta inferred_theta + sig@(TcSigInfo { sig_id = poly_id + , sig_extra_cts = mb_extra_cts + , sig_theta = annotated_theta }) + | Just loc <- mb_extra_cts + = do { annotated_theta <- zonkTcThetaType annotated_theta + ; let inferred_diff = minusList inferred_theta annotated_theta + final_theta = annotated_theta ++ inferred_diff + ; partial_sigs <- xoptM Opt_PartialTypeSignatures + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty + ; case partial_sigs of + True | warn_partial_sigs -> reportWarning $ makeIntoWarning msg + | otherwise -> return () + False -> reportError msg + ; return final_theta } + + | otherwise + = zonkTcThetaType annotated_theta + -- No extra-constraints wildcard means no extra constraints will be added + -- to the context, so just return the possibly empty (zonked) + -- annotated_theta. + where + pts_hint = text "To use the inferred type, enable PartialTypeSignatures" + mk_msg inferred_diff suppress_hint + = vcat [ hang ((text "Found hole") <+> quotes (char '_')) + 2 (text "with inferred constraints:") + <+> pprTheta inferred_diff + , if suppress_hint then empty else pts_hint + , typeSigCtxt (idName poly_id) sig ] + +{- +Note [Partial type signatures and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a partial type signature, like + f :: _ -> Int +then we *always* use the InferGen plan, and hence tcPolyInfer. +We do this even for a local binding with -XMonoLocalBinds. +Reasons: + * The TcSigInfo for 'f' has a unification variable for the '_', + whose TcLevel is one level deeper than the current level. + (See pushTcLevelM in tcTySig.) But NoGen doesn't increase + the TcLevel like InferGen, so we lose the level invariant. + + * The signature might be f :: forall a. _ -> a + so it really is polymorphic. It's not clear what it would + mean to use NoGen on this, and indeed the ASSERT in tcLhs, + in the (Just sig) case, checks that if there is a signature + then we are using LetLclBndr, and hence a nested AbsBinds with + increased TcLevel + +It might be possible to fix these difficulties somehow, but there +doesn't seem much point. Indeed, adding a partial type signature is a +way to get per-binding inferred generalisation. + +Note [Validity of inferred types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to check inferred type for validity, in case it uses language +extensions that are not turned on. The principle is that if the user +simply adds the inferred type to the program source, it'll compile fine. +See #8883. + +Examples that might fail: + - an inferred theta that requires type equalities e.g. (F a ~ G b) + or multi-parameter type classes + - an inferred type that includes unboxed tuples + +However we don't do the ambiguity check (checkValidType omits it for +InfSigCtxt) because the impedence-matching stage, which follows +immediately, will do it and we don't want two error messages. +Moreover, because of the impedence matching stage, the ambiguity-check +suggestion of -XAllowAmbiguiousTypes will not work. + + +Note [Impedence matching] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f 0 x = x + f n x = g [] (not x) + + g [] y = f 10 y + g _ y = f 9 y + +After typechecking we'll get + f_mono_ty :: a -> Bool -> Bool + g_mono_ty :: [b] -> Bool -> Bool +with constraints + (Eq a, Num a) + +Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. +The types we really want for f and g are + f :: forall a. (Eq a, Num a) => a -> Bool -> Bool + g :: forall b. [b] -> Bool -> Bool + +We can get these by "impedence matching": + tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) + tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) + + f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f + g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g + +Suppose the shared quantified tyvars are qtvs and constraints theta. +Then we want to check that + f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty +and the proof is the impedence matcher. + +Notice that the impedence matcher may do defaulting. See Trac #7173. + +It also cleverly does an ambiguity check; for example, rejecting + f :: F a -> a +where F is a non-injective type function. +-} + +type PragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun +mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] + where + prs = mapMaybe get_sig sigs + + get_sig :: LSig Name -> Maybe (Located Name, LSig Name) + get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl)) + get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl)) + get_sig _ = Nothing + + add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function + | Just ar <- lookupNameEnv ar_env n, + Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar } + -- add arity only for real INLINE pragmas, not INLINABLE + | otherwise = inl_prag + + prag_env :: NameEnv [LSig Name] + prag_env = foldl add emptyNameEnv prs + add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldrBag lhsBindArity emptyNameEnv binds + +lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + +------------------ +tcSpecPrags :: Id -> [LSig Name] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALSE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) + ; unless (null bad_sigs) warn_discarded_sigs + ; pss <- mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s) + + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + +-------------- +tcSpec :: TcId -> Sig Name -> TcM [TcSpecPrag] +tcSpec poly_id prag@(SpecSig fun_name hs_tys inl) + -- The Name fun_name in the SpecSig may not be the same as that of the poly_id + -- Example: SPECIALISE for a class method: the Name in the SpecSig is + -- for the selector Id, but the poly_id is something like $cop + -- However we want to use fun_name in the error message, since that is + -- what the user wrote (Trac #8537) + = addErrCtxt (spec_ctxt prag) $ + do { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys + ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) + (ptext (sLit "SPECIALISE pragma for non-overloaded function") + <+> quotes (ppr fun_name)) + -- Note [SPECIALISE pragmas] + ; wraps <- mapM (tcSubType sig_ctxt (idType poly_id)) spec_tys + ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] } + where + name = idName poly_id + poly_ty = idType poly_id + sig_ctxt = FunSigCtxt name + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpec _ prag = pprPanic "tcSpec" (ppr prag) + +-------------- +tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +-- SPECIALISE pragmas for imported things +tcImpPrags prags + = do { this_mod <- getModule + ; dflags <- getDynFlags + ; if (not_specialising dflags) then + return [] + else do + { pss <- mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) + | (L loc prag@(SpecSig (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] + ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't wnat complaints about lack of INLINABLE pragmas + not_specialising dflags + | not (gopt Opt_Specialise dflags) = True + | otherwise = case hscTarget dflags of + HscNothing -> True + HscInterpreted -> True + _other -> False + +tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag] +tcImpSpec (name, prag) + = do { id <- tcLookupId name + ; unless (isAnyInlinePragma (idInlinePragma id)) + (addWarnTc (impSpecErr name)) + ; tcSpec id prag } + +impSpecErr :: Name -> SDoc +impSpecErr name + = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) + 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") + , parens $ sep + [ ptext (sLit "or its defining module") <+> quotes (ppr mod) + , ptext (sLit "was compiled without -O")]]) + where + mod = nameModule name + +-------------- +tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) +tcVectDecls decls + = do { decls' <- mapM (wrapLocM tcVect) decls + ; let ids = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl] + dups = findDupsEq (==) ids + ; mapM_ reportVectDups dups + ; traceTcConstraints "End of tcVectDecls" + ; return decls' + } + where + reportVectDups (first:_second:_more) + = addErrAt (getSrcSpan first) $ + ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first + reportVectDups _ = return () + +-------------- +tcVect :: VectDecl Name -> TcM (VectDecl TcId) +-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised +-- type of the original definition as this requires internals of the vectoriser not available +-- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single +-- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType' +-- from the vectoriser here. +tcVect (HsVect s name rhs) + = addErrCtxt (vectCtxt name) $ + do { var <- wrapLocM tcLookupId name + ; let L rhs_loc (HsVar rhs_var_name) = rhs + ; rhs_id <- tcLookupId rhs_var_name + ; return $ HsVect s var (L rhs_loc (HsVar rhs_id)) + } + +{- OLD CODE: + -- turn the vectorisation declaration into a single non-recursive binding + ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] + sigFun = const Nothing + pragFun = mkPragFun [] (unitBag bind) + + -- perform type inference (including generalisation) + ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind] + + ; traceTc "tcVect inferred type" $ ppr (varType id') + ; traceTc "tcVect bindings" $ ppr binds + + -- add all bindings, including the type variable and dictionary bindings produced by type + -- generalisation to the right-hand side of the vectorisation declaration + ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds + ; let [bind'] = bagToList actualBinds + MatchGroup + [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))] + _ = (fun_matches . unLoc) bind' + rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs') + + -- We return the type-checked 'Id', to propagate the inferred signature + -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls + ; return $ HsVect (L loc id') (Just rhsWrapped) + } + -} +tcVect (HsNoVect s name) + = addErrCtxt (vectCtxt name) $ + do { var <- wrapLocM tcLookupId name + ; return $ HsNoVect s var + } +tcVect (HsVectTypeIn _ isScalar lname rhs_name) + = addErrCtxt (vectCtxt lname) $ + do { tycon <- tcLookupLocatedTyCon lname + ; checkTc ( not isScalar -- either we have a non-SCALAR declaration + || isJust rhs_name -- or we explicitly provide a vectorised type + || tyConArity tycon == 0 -- otherwise the type constructor must be nullary + ) + scalarTyConMustBeNullary + + ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name + ; return $ HsVectTypeOut isScalar tycon rhs_tycon + } +tcVect (HsVectTypeOut _ _ _) + = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" +tcVect (HsVectClassIn _ lname) + = addErrCtxt (vectCtxt lname) $ + do { cls <- tcLookupLocatedClass lname + ; return $ HsVectClassOut cls + } +tcVect (HsVectClassOut _) + = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'" +tcVect (HsVectInstIn linstTy) + = addErrCtxt (vectCtxt linstTy) $ + do { (cls, tys) <- tcHsVectInst linstTy + ; inst <- tcLookupInstance cls tys + ; return $ HsVectInstOut inst + } +tcVect (HsVectInstOut _) + = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" + +vectCtxt :: Outputable thing => thing -> SDoc +vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing + +scalarTyConMustBeNullary :: MsgDoc +scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) +recoveryCode binder_names sig_fn + = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return (emptyBag, poly_ids, if all is_closed poly_ids + then TopLevel else NotTopLevel) } + where + mk_dummy name + | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up + | otherwise = return (mkLocalId name forall_a_a) -- No signature + + is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id)) + +forall_a_a :: TcType +forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) + +{- +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} + +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. + +************************************************************************ +* * +\subsection{tcMonoBind} +* * +************************************************************************ + +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. + +Note [Pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~ +The rule for typing pattern bindings is this: + + ..sigs.. + p = e + +where 'p' binds v1..vn, and 'e' may mention v1..vn, +typechecks exactly like + + ..sigs.. + x = e -- Inferred type + v1 = case x of p -> v1 + .. + vn = case x of p -> vn + +Note that + (f :: forall a. a -> a) = id +should not typecheck because + case id of { (f :: forall a. a->a) -> f } +will not typecheck. +-} + +tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec + -> [LHsBind Name] + -> TcM (LHsBinds TcId, [MonoBindInfo]) + +tcMonoBinds is_rec sig_fn no_gen + [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + -- Single function binding, + | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS + , Nothing <- sig_fn name -- ...with no type signature + = -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { rhs_ty <- newFlexiTyVarTy openTypeKind + ; mono_id <- newNoSigLetBndr no_gen name rhs_ty + ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + -- We extend the error context even for a non-recursive + -- function so that in type error messages we show the + -- type of the thing whose rhs we are type checking + tcMatchesFun name inf matches rhs_ty + + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, + fun_matches = matches', bind_fvs = fvs, + fun_co_fn = co_fn, fun_tick = [] }, + [(name, Nothing, mono_id)]) } + +tcMonoBinds _ sig_fn no_gen binds + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_info = getMonoBindInfo tc_binds + rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info + , noCompleteSig mb_sig ] + -- A monomorphic binding for each term variable that lacks + -- a type sig. (Ones with a sig are already in scope.) + + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendIdEnv2 rhs_id_env $ + mapM (wrapLocM tcRhs) tc_binds + ; return (listToBag binds', mono_info) } + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name)) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType + +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) + | Just sig <- sig_fn name + = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False } + , ppr name ) + -- { f :: ty; f x = e } is always done via CheckGen (full signature) + -- or InferGen (partial signature) + -- see Note [Partial type signatures and generalisation] + -- Both InferGen and CheckGen gives rise to LetLclBndr + do { mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name (sig_tau sig) + ; addErrCtxt (typeSigCtxt name sig) $ + emitWildcardHoleConstraints (sig_nwcs sig) + ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } + + | otherwise + = do { mono_ty <- newFlexiTyVarTy openTypeKind + ; mono_id <- newNoSigLetBndr no_gen name mono_ty + ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) } + +-- TODOT: emit Hole Constraints for wildcards +tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $ + mapM lookup_info (collectPatBinders pat) + + -- After typechecking the pattern, look up the binder + -- names, which the pattern has brought into scope. + lookup_info :: Name -> TcM MonoBindInfo + lookup_info name = do { mono_id <- tcLookupId name + ; return (name, sig_fn name, mono_id) } + + ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer tc_pat + + ; return (TcPatBind infos pat' grhss pat_ty) } + +tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible + +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind TcId) +-- When we are doing pattern bindings, or multiple function bindings at a time +-- we *don't* bring any scoped type variables into scope +-- Wny not? They are not completely rigid. +-- That's why we have the special case for a single FunBind in tcMonoBinds +tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches) + = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + tcExtendTyVarEnv2 tvsAndNwcs $ + -- NotTopLevel: it's a monomorphic binding + do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) + ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf + matches (idType mono_id) + ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf + , fun_matches = matches' + , fun_co_fn = co_fn + , bind_fvs = placeHolderNamesTc + , fun_tick = [] }) } + where + tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig] + ++ sig_nwcs sig) mb_sig + +tcRhs (TcPatBind infos pat' grhss pat_ty) + = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $ + -- NotTopLevel: it's a monomorphic binding + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) + ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty + , bind_fvs = placeHolderNamesTc + , pat_ticks = ([],[]) }) } + + +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest + +{- +************************************************************************ +* * + Signatures +* * +************************************************************************ + +Type signatures are tricky. See Note [Signature skolems] in TcType + +@tcSigs@ checks the signatures for validity, and returns a list of +{\em freshly-instantiated} signatures. That is, the types are already +split up, and have fresh type variables installed. All non-type-signature +"RenamedSigs" are ignored. + +The @TcSigInfo@ contains @TcTypes@ because they are unified with +the variable's type, and after that checked to see whether they've +been instantiated. + +Note [Scoped tyvars] +~~~~~~~~~~~~~~~~~~~~ +The -XScopedTypeVariables flag brings lexically-scoped type variables +into scope for any explicitly forall-quantified type variables: + f :: forall a. a -> a + f x = e +Then 'a' is in scope inside 'e'. + +However, we do *not* support this + - For pattern bindings e.g + f :: forall a. a->a + (f,g) = e + +Note [Signature skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +When instantiating a type signature, we do so with either skolems or +SigTv meta-type variables depending on the use_skols boolean. This +variable is set True when we are typechecking a single function +binding; and False for pattern bindings and a group of several +function bindings. + +Reason: in the latter cases, the "skolems" can be unified together, + so they aren't properly rigid in the type-refinement sense. +NB: unless we are doing H98, each function with a sig will be done + separately, even if it's mutually recursive, so use_skols will be True + + +Note [Only scoped tyvars are in the TyVarEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are careful to keep only the *lexically scoped* type variables in +the type environment. Why? After all, the renamer has ensured +that only legal occurrences occur, so we could put all type variables +into the type env. + +But we want to check that two distinct lexically scoped type variables +do not map to the same internal type variable. So we need to know which +the lexically-scoped ones are... and at the moment we do that by putting +only the lexically scoped ones into the environment. + +Note [Instantiate sig with fresh variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's vital to instantiate a type signature with fresh variables. +For example: + type T = forall a. [a] -> [a] + f :: T; + f = g where { g :: T; g = } + + We must not use the same 'a' from the defn of T at both places!! +(Instantiation is only necessary because of type synonyms. Otherwise, +it's all cool; each signature has distinct type variables from the renamer.) + +Note [Fail eagerly on bad signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a type signaure is wrong, fail immediately: + + * the type sigs may bind type variables, so proceeding without them + can lead to a cascade of errors + + * the type signature might be ambiguous, in which case checking + the code against the signature will give a very similar error + to the ambiguity error. + +ToDo: this means we fall over if any type sig +is wrong (eg at the top level of the module), +which is over-conservative +-} + +tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar]) +tcTySigs hs_sigs + = checkNoErrs $ -- See Note [Fail eagerly on bad signatures] + do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs + ; let ty_sigs = concat ty_sigs_s + poly_ids = [id | TcSigInfo{ sig_id = id } <- ty_sigs] + env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs] + ; return (poly_ids, lookupNameEnv env, concat tyvarsl) } + +tcTySig :: LSig Name -> TcM ([TcSigInfo], [TcTyVar]) +tcTySig (L _ (IdSig id)) + = do { sig <- instTcTySigFromId id + ; return ([sig], []) } +tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs)) + = setSrcSpan loc $ + pushTcLevelM $ + do { nwc_tvs <- mapM newWildcardVarMetaKind wcs -- Generate fresh meta vars for the wildcards + ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty + ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs)) + (map unLoc names) + ; return (sigs, nwc_tvs) } + where + extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra + extra_cts _ = Nothing + +tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty)) + = setSrcSpan loc $ + do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty + ; let ctxt = FunSigCtxt name + ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do + { ty' <- tcHsSigType ctxt ty + ; req' <- tcHsContext req + ; prov' <- tcHsContext prov + + ; qtvs' <- mapM zonkQuantifiedTyVar qtvs' + + ; let (_, pat_ty) = tcSplitFunTys ty' + univ_set = tyVarsOfType pat_ty + (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs' + + ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty' + ; let tpsi = TPSI{ patsig_name = name, + patsig_tau = ty', + patsig_ex = ex_tvs, + patsig_univ = univ_tvs, + patsig_prov = prov', + patsig_req = req' } + ; return ([TcPatSynInfo tpsi], []) }} +tcTySig _ = return ([], []) + +instTcTySigFromId :: Id -> TcM TcSigInfo +instTcTySigFromId id + = do { let loc = getSrcSpan id + ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc) + (idType id) + ; return (TcSigInfo { sig_id = id, sig_loc = loc + , sig_tvs = [(Nothing, tv) | tv <- tvs] + , sig_nwcs = [] + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = Nothing + , sig_partial = False }) } + +instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType + -> Maybe SrcSpan -- Just loc <=> an extra-constraints + -- wildcard is present at location loc. + -> [(Name, TcTyVar)] -> Name -> TcM TcSigInfo +instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name + = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty + ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty + , sig_loc = loc + , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs + , sig_nwcs = nwcs + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = extra_cts + , sig_partial = isJust extra_cts || not (null nwcs) }) } + +------------------------------- +data GeneralisationPlan + = NoGen -- No generalisation, no AbsBinds + + | InferGen -- Implicit generalisation; there is an AbsBinds + Bool -- True <=> apply the MR; generalise only unconstrained type vars + Bool -- True <=> bindings mention only variables with closed types + -- See Note [Bindings with closed types] in TcRnTypes + + | CheckGen (LHsBind Name) TcSigInfo + -- One binding with a signature + -- Explicit generalisation; there is an AbsBinds + +-- A consequence of the no-AbsBinds choice (NoGen) is that there is +-- no "polymorphic Id" and "monmomorphic Id"; there is just the one + +instance Outputable GeneralisationPlan where + ppr NoGen = ptext (sLit "NoGen") + ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c + ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s + +decideGeneralisationPlan + :: DynFlags -> TcTypeEnv -> [Name] + -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan +decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn + | strict_pat_binds = NoGen + | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig + -- See Note [Partial type signatures and generalisation] + then infer_plan + else CheckGen lbind sig + | mono_local_binds = NoGen + | otherwise = infer_plan + where + infer_plan = InferGen mono_restriction closed_flag + bndr_set = mkNameSet bndr_names + binds = map unLoc lbinds + + strict_pat_binds = any isStrictHsBind binds + -- Strict patterns (top level bang or unboxed tuple) must not + -- be polymorphic, because we are going to force them + -- See Trac #4498, #8762 + + mono_restriction = xopt Opt_MonomorphismRestriction dflags + && any restricted binds + + is_closed_ns :: NameSet -> Bool -> Bool + is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns + -- ns are the Names referred to from the RHS of this bind + + is_closed_id :: Name -> Bool + -- See Note [Bindings with closed types] in TcRnTypes + is_closed_id name + | name `elemNameSet` bndr_set + = True -- Ignore binders in this groups, of course + | Just thing <- lookupNameEnv type_env name + = case thing of + ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line + ATyVar {} -> False -- In-scope type variables + AGlobal {} -> True -- are not closed! + _ -> pprPanic "is_closed_id" (ppr name) + | otherwise + = WARN( isInternalName name, ppr name ) True + -- The free-var set for a top level binding mentions + -- imported things too, so that we can report unused imports + -- These won't be in the local type env. + -- Ditto class method etc from the current module + + closed_flag = foldr (is_closed_ns . bind_fvs) True binds + + mono_local_binds = xopt Opt_MonoLocalBinds dflags + && not closed_flag + + no_sig n = noCompleteSig (sig_fn n) + + -- With OutsideIn, all nested bindings are monomorphic + -- except a single function binding with a signature + one_funbind_with_sig + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds + , Just sig <- sig_fn (unLoc v) + = Just (lbind, sig) + | otherwise + = Nothing + + -- The Haskell 98 monomorphism resetriction + restricted (PatBind {}) = True + restricted (VarBind { var_id = v }) = no_sig v + restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m + && no_sig (unLoc v) + restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind" + restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds" + + restricted_match (MG { mg_alts = L _ (Match _ [] _ _) : _ }) = True + restricted_match _ = False + -- No args => like a pattern binding + -- Some args => a function binding + +------------------- +checkStrictBinds :: TopLevelFlag -> RecFlag + -> [LHsBind Name] + -> LHsBinds TcId -> [Id] + -> TcM () +-- Check that non-overloaded unlifted bindings are +-- a) non-recursive, +-- b) not top level, +-- c) not a multiple-binding group (more or less implied by (a)) + +checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids + | unlifted_bndrs || any_strict_pat -- This binding group must be matched strictly + = do { checkTc (isNotTopLevel top_lvl) + (strictBindErr "Top-level" unlifted_bndrs orig_binds) + ; checkTc (isNonRec rec_group) + (strictBindErr "Recursive" unlifted_bndrs orig_binds) + + ; checkTc (all is_monomorphic (bagToList tc_binds)) + (polyBindErr orig_binds) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. Trac #6078. + + ; checkTc (isSingleton orig_binds) + (strictBindErr "Multiple" unlifted_bndrs orig_binds) + + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + ; checkTc (not any_pat_looks_lazy) + (unliftedMustBeBang orig_binds) } + | otherwise + = traceTc "csb2" (ppr poly_ids) >> + return () + where + unlifted_bndrs = any is_unlifted poly_ids + any_strict_pat = any (isStrictHsBind . unLoc) orig_binds + any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds + + is_unlifted id = case tcSplitSigmaTy (idType id) of + (_, _, rho) -> isUnLiftedType rho + -- For the is_unlifted check, we need to look inside polymorphism + -- and overloading. E.g. x = (# 1, True #) + -- would get type forall a. Num a => (# a, Bool #) + -- and we want to reject that. See Trac #9140 + + is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) + = null tvs && null evs + is_monomorphic _ = True + +unliftedMustBeBang :: [LHsBind Name] -> SDoc +unliftedMustBeBang binds + = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") + 2 (vcat (map ppr binds)) + +polyBindErr :: [LHsBind Name] -> SDoc +polyBindErr binds + = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) + 2 (vcat [vcat (map ppr binds), + ptext (sLit "Probable fix: use a bang pattern")]) + +strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc +strictBindErr flavour unlifted_bndrs binds + = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) + 2 (vcat (map ppr binds)) + where + msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types") + | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings") + +{- +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +************************************************************************ +* * +\subsection[TcBinds-errors]{Error contexts and messages} +* * +************************************************************************ +-} + +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc +patMonoBindsCtxt pat grhss + = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) + +typeSigCtxt :: Name -> TcSigInfo -> SDoc +typeSigCtxt _ (TcPatSynInfo _) + = panic "Should only be called with a TcSigInfo" +typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs + , sig_theta = theta, sig_tau = tau + , sig_extra_cts = extra_cts }) + = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon + , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts) + (mkSigmaTy (map snd tvs) theta tau)) ] diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs new file mode 100644 index 00000000..806f651c --- /dev/null +++ b/compiler/typecheck/TcCanonical.hs @@ -0,0 +1,1723 @@ +{-# LANGUAGE CPP #-} + +module TcCanonical( + canonicalize, + unifyDerived, + + StopOrContinue(..), stopWith, continueWith + ) where + +#include "HsVersions.h" + +import TcRnTypes +import TcType +import Type +import Kind +import TcFlatten +import TcSMonad +import TcEvidence +import Class +import TyCon +import TypeRep +import Coercion +import FamInstEnv ( FamInstEnvs ) +import FamInst ( tcTopNormaliseNewTypeTF_maybe ) +import Var +import DataCon ( dataConName ) +import Name( isSystemName, nameOccName ) +import OccName( OccName ) +import Outputable +import Control.Monad +import DynFlags( DynFlags ) +import VarSet +import RdrName + +import Pair +import Util +import MonadUtils ( zipWith3M, zipWith3M_ ) +import Data.List ( zip4 ) +import BasicTypes +import Data.Maybe ( isJust ) +import FastString + +{- +************************************************************************ +* * +* The Canonicaliser * +* * +************************************************************************ + +Note [Canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~ + +Canonicalization converts a simple constraint to a canonical form. It is +unary (i.e. treats individual constraints one at a time), does not do +any zonking, but lives in TcS monad because it needs to create fresh +variables (for flattening) and consult the inerts (for efficiency). + +The execution plan for canonicalization is the following: + + 1) Decomposition of equalities happens as necessary until we reach a + variable or type family in one side. There is no decomposition step + for other forms of constraints. + + 2) If, when we decompose, we discover a variable on the head then we + look at inert_eqs from the current inert for a substitution for this + variable and contine decomposing. Hence we lazily apply the inert + substitution if it is needed. + + 3) If no more decomposition is possible, we deeply apply the substitution + from the inert_eqs and continue with flattening. + + 4) During flattening, we examine whether we have already flattened some + function application by looking at all the CTyFunEqs with the same + function in the inert set. The reason for deeply applying the inert + substitution at step (3) is to maximise our chances of matching an + already flattened family application in the inert. + +The net result is that a constraint coming out of the canonicalization +phase cannot be rewritten any further from the inerts (but maybe /it/ can +rewrite an inert or still interact with an inert in a further phase in the +simplifier. + +Note [Caching for canonicals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our plan with pre-canonicalization is to be able to solve a constraint +really fast from existing bindings in TcEvBinds. So one may think that +the condition (isCNonCanonical) is not necessary. However consider +the following setup: + +InertSet = { [W] d1 : Num t } +WorkList = { [W] d2 : Num t, [W] c : t ~ Int} + +Now, we prioritize equalities, but in our concrete example +(should_run/mc17.hs) the first (d2) constraint is dealt with first, +because (t ~ Int) is an equality that only later appears in the +worklist since it is pulled out from a nested implication +constraint. So, let's examine what happens: + + - We encounter work item (d2 : Num t) + + - Nothing is yet in EvBinds, so we reach the interaction with inerts + and set: + d2 := d1 + and we discard d2 from the worklist. The inert set remains unaffected. + + - Now the equation ([W] c : t ~ Int) is encountered and kicks-out + (d1 : Num t) from the inerts. Then that equation gets + spontaneously solved, perhaps. We end up with: + InertSet : { [G] c : t ~ Int } + WorkList : { [W] d1 : Num t} + + - Now we examine (d1), we observe that there is a binding for (Num + t) in the evidence binds and we set: + d1 := d2 + and end up in a loop! + +Now, the constraints that get kicked out from the inert set are always +Canonical, so by restricting the use of the pre-canonicalizer to +NonCanonical constraints we eliminate this danger. Moreover, for +canonical constraints we already have good caching mechanisms +(effectively the interaction solver) and we are interested in reducing +things like superclasses of the same non-canonical constraint being +generated hence I don't expect us to lose a lot by introducing the +(isCNonCanonical) restriction. + +A similar situation can arise in TcSimplify, at the end of the +solve_wanteds function, where constraints from the inert set are +returned as new work -- our substCt ensures however that if they are +not rewritten by subst, they remain canonical and hence we will not +attempt to solve them from the EvBinds. If on the other hand they did +get rewritten and are now non-canonical they will still not match the +EvBinds, so we are again good. +-} + +-- Top-level canonicalization +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +canonicalize :: Ct -> TcS (StopOrContinue Ct) +canonicalize ct@(CNonCanonical { cc_ev = ev }) + = do { traceTcS "canonicalize (non-canonical)" (ppr ct) + ; {-# SCC "canEvVar" #-} + canEvNC ev } + +canonicalize (CDictCan { cc_ev = ev + , cc_class = cls + , cc_tyargs = xis }) + = {-# SCC "canClass" #-} + canClass ev cls xis -- Do not add any superclasses +canonicalize (CTyEqCan { cc_ev = ev + , cc_tyvar = tv + , cc_rhs = xi + , cc_eq_rel = eq_rel }) + = {-# SCC "canEqLeafTyVarEq" #-} + canEqTyVar ev eq_rel NotSwapped tv xi xi + +canonicalize (CFunEqCan { cc_ev = ev + , cc_fun = fn + , cc_tyargs = xis1 + , cc_fsk = fsk }) + = {-# SCC "canEqLeafFunEq" #-} + canCFunEqCan ev fn xis1 fsk + +canonicalize (CIrredEvCan { cc_ev = ev }) + = canIrred ev +canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) + = canHole ev occ hole + +canEvNC :: CtEvidence -> TcS (StopOrContinue Ct) +-- Called only for non-canonical EvVars +canEvNC ev + = case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) + canClassNC ev cls tys + EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) + canEqNC ev eq_rel ty1 ty2 + TuplePred tys -> do traceTcS "canEvNC:tup" (ppr tys) + canTuple ev tys + IrredPred {} -> do traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) + canIrred ev +{- +************************************************************************ +* * +* Tuple Canonicalization +* * +************************************************************************ +-} + +canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct) +canTuple ev tys + = do { traceTcS "can_pred" (text "TuplePred!") + ; let xcomp = EvTupleMk + xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] + ; xCtEvidence ev (XEvTerm tys xcomp xdecomp) + ; stopWith ev "Decomposed tuple constraint" } + +{- +************************************************************************ +* * +* Class Canonicalization +* * +************************************************************************ +-} + +canClass, canClassNC + :: CtEvidence + -> Class -> [Type] -> TcS (StopOrContinue Ct) +-- Precondition: EvVar is class evidence + +-- The canClassNC version is used on non-canonical constraints +-- and adds superclasses. The plain canClass version is used +-- for already-canonical class constraints (but which might have +-- been subsituted or somthing), and hence do not need superclasses + +canClassNC ev cls tys + = canClass ev cls tys + `andWhenContinue` emitSuperclasses + +canClass ev cls tys + = -- all classes do *nominal* matching + ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) + do { (xis, cos) <- flattenMany FM_FlattenAll ev (repeat Nominal) tys + ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos + xi = mkClassPred cls xis + mk_ct new_ev = CDictCan { cc_ev = new_ev + , cc_tyargs = xis, cc_class = cls } + ; mb <- rewriteEvidence ev xi co + ; traceTcS "canClass" (vcat [ ppr ev <+> ppr cls <+> ppr tys + , ppr xi, ppr mb ]) + ; return (fmap mk_ct mb) } + +emitSuperclasses :: Ct -> TcS (StopOrContinue Ct) +emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls }) + -- Add superclasses of this one here, See Note [Adding superclasses]. + -- But only if we are not simplifying the LHS of a rule. + = do { newSCWorkFromFlavored ev cls xis_new + -- Arguably we should "seq" the coercions if they are derived, + -- as we do below for emit_kind_constraint, to allow errors in + -- superclasses to be executed if deferred to runtime! + ; continueWith ct } +emitSuperclasses _ = panic "emit_superclasses of non-class!" + +{- +Note [Adding superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since dictionaries are canonicalized only once in their lifetime, the +place to add their superclasses is canonicalisation (The alternative +would be to do it during constraint solving, but we'd have to be +extremely careful to not repeatedly introduced the same superclass in +our worklist). Here is what we do: + +For Givens: + We add all their superclasses as Givens. + +For Wanteds: + Generally speaking we want to be able to add superclasses of + wanteds for two reasons: + + (1) Oportunities for improvement. Example: + class (a ~ b) => C a b + Wanted constraint is: C alpha beta + We'd like to simply have C alpha alpha. Similar + situations arise in relation to functional dependencies. + + (2) To have minimal constraints to quantify over: + For instance, if our wanted constraint is (Eq a, Ord a) + we'd only like to quantify over Ord a. + + To deal with (1) above we only add the superclasses of wanteds + which may lead to improvement, that is: equality superclasses or + superclasses with functional dependencies. + + We deal with (2) completely independently in TcSimplify. See + Note [Minimize by SuperClasses] in TcSimplify. + + + Moreover, in all cases the extra improvement constraints are + Derived. Derived constraints have an identity (for now), but + we don't do anything with their evidence. For instance they + are never used to rewrite other constraints. + + See also [New Wanted Superclass Work] in TcInteract. + + +For Deriveds: + We do nothing. + +Here's an example that demonstrates why we chose to NOT add +superclasses during simplification: [Comes from ticket #4497] + + class Num (RealOf t) => Normed t + type family RealOf x + +Assume the generated wanted constraint is: + RealOf e ~ e, Normed e +If we were to be adding the superclasses during simplification we'd get: + Num uf, Normed e, RealOf e ~ e, RealOf e ~ uf +==> + e ~ uf, Num uf, Normed e, RealOf e ~ e +==> [Spontaneous solve] + Num uf, Normed uf, RealOf uf ~ uf + +While looks exactly like our original constraint. If we add the superclass again we'd loop. +By adding superclasses definitely only once, during canonicalisation, this situation can't +happen. +-} + +newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS () +-- Returns superclasses, see Note [Adding superclasses] +newSCWorkFromFlavored flavor cls xis + | isDerived flavor + = return () -- Deriveds don't yield more superclasses because we will + -- add them transitively in the case of wanteds. + + | isGiven flavor + = do { let sc_theta = immSuperClasses cls xis + xev_decomp x = zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] + xev = XEvTerm { ev_preds = sc_theta + , ev_comp = panic "Can't compose for given!" + , ev_decomp = xev_decomp } + ; xCtEvidence flavor xev } + + | isEmptyVarSet (tyVarsOfTypes xis) + = return () -- Wanteds with no variables yield no deriveds. + -- See Note [Improvement from Ground Wanteds] + + | otherwise -- Wanted case, just add those SC that can lead to improvement. + = do { let sc_rec_theta = transSuperClasses cls xis + impr_theta = filter is_improvement_pty sc_rec_theta + loc = ctEvLoc flavor + ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta + ; mapM_ (emitNewDerived loc) impr_theta } + +is_improvement_pty :: PredType -> Bool +-- Either it's an equality, or has some functional dependency +is_improvement_pty ty = go (classifyPredType ty) + where + go (EqPred NomEq t1 t2) = not (t1 `tcEqType` t2) + go (EqPred ReprEq _ _) = False + go (ClassPred cls _tys) = not $ null fundeps + where (_,fundeps) = classTvsFds cls + go (TuplePred ts) = any is_improvement_pty ts + go (IrredPred {}) = True -- Might have equalities after reduction? + +{- +************************************************************************ +* * +* Irreducibles canonicalization +* * +************************************************************************ +-} + +canIrred :: CtEvidence -> TcS (StopOrContinue Ct) +-- Precondition: ty not a tuple and no other evidence form +canIrred old_ev + = do { let old_ty = ctEvPred old_ev + ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty) + ; (xi,co) <- flatten FM_FlattenAll old_ev old_ty -- co :: xi ~ old_ty + ; rewriteEvidence old_ev xi co `andWhenContinue` \ new_ev -> + do { -- Re-classify, in case flattening has improved its shape + ; case classifyPredType (ctEvPred new_ev) of + ClassPred cls tys -> canClassNC new_ev cls tys + TuplePred tys -> canTuple new_ev tys + EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 + _ -> continueWith $ + CIrredEvCan { cc_ev = new_ev } } } + +canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) +canHole ev occ hole_sort + = do { let ty = ctEvPred ev + ; (xi,co) <- flatten FM_SubstOnly ev ty -- co :: xi ~ ty + ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> + do { emitInsoluble (CHoleCan { cc_ev = new_ev + , cc_occ = occ + , cc_hole = hole_sort }) + ; stopWith new_ev "Emit insoluble hole" } } + +{- +************************************************************************ +* * +* Equalities +* * +************************************************************************ +-} + +canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) +canEqNC ev eq_rel ty1 ty2 + = can_eq_nc ev eq_rel ty1 ty1 ty2 ty2 + +can_eq_nc + :: CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue Ct) +can_eq_nc ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + = do { traceTcS "can_eq_nc" $ + vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc' rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } + +can_eq_nc' + :: GlobalRdrEnv -- needed to see which newtypes are in scope + -> FamInstEnvs -- needed to unwrap data instances + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue Ct) + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc' _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- tcView ty1 = can_eq_nc ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- tcView ty2 = can_eq_nc ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + +-- Type family on LHS or RHS take priority over tyvars, +-- so that tv ~ F ty gets flattened +-- Otherwise F a ~ F a might not get solved! +can_eq_nc' _rdr_env _envs ev eq_rel (TyConApp fn1 tys1) _ ty2 ps_ty2 + | isTypeFamilyTyCon fn1 + = can_eq_fam_nc ev eq_rel NotSwapped fn1 tys1 ty2 ps_ty2 +can_eq_nc' _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyConApp fn2 tys2) _ + | isTypeFamilyTyCon fn2 + = can_eq_fam_nc ev eq_rel IsSwapped fn2 tys2 ty1 ps_ty1 + +-- When working with ReprEq, unwrap newtypes next. +-- Otherwise, a ~ Id a wouldn't get solved +can_eq_nc' rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2 + | Just (co, ty1') <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + = can_eq_newtype_nc rdr_env ev NotSwapped co ty1 ty1' ty2 ps_ty2 +can_eq_nc' rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _ + | Just (co, ty2') <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + = can_eq_newtype_nc rdr_env ev IsSwapped co ty2 ty2' ty1 ps_ty1 + +-- Type variable on LHS or RHS are next +can_eq_nc' _rdr_env _envs ev eq_rel (TyVarTy tv1) _ ty2 ps_ty2 + = canEqTyVar ev eq_rel NotSwapped tv1 ty2 ps_ty2 +can_eq_nc' _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) _ + = canEqTyVar ev eq_rel IsSwapped tv2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc' _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ + | l1 == l2 + = do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (EvCoercion $ + mkTcReflCo (eqRelRole eq_rel) ty1) + ; stopWith ev "Equal LitTy" } + +-- Decomposable type constructor applications +-- Synonyms and type functions (which are not decomposable) +-- have already been dealt with +can_eq_nc' _rdr_env _envs ev eq_rel (TyConApp tc1 tys1) _ (TyConApp tc2 tys2) _ + | isDecomposableTyCon tc1 + , isDecomposableTyCon tc2 + = canDecomposableTyConApp ev eq_rel tc1 tys1 tc2 tys2 + +can_eq_nc' _rdr_env _envs ev eq_rel (TyConApp tc1 _) ps_ty1 (FunTy {}) ps_ty2 + | isDecomposableTyCon tc1 + -- The guard is important + -- e.g. (x -> y) ~ (F x y) where F has arity 1 + -- should not fail, but get the app/app case + = canEqHardFailure ev eq_rel ps_ty1 ps_ty2 + +can_eq_nc' _rdr_env _envs ev eq_rel (FunTy s1 t1) _ (FunTy s2 t2) _ + = do { canDecomposableTyConAppOK ev eq_rel funTyCon [s1,t1] [s2,t2] + ; stopWith ev "Decomposed FunTyCon" } + +can_eq_nc' _rdr_env _envs ev eq_rel (FunTy {}) ps_ty1 (TyConApp tc2 _) ps_ty2 + | isDecomposableTyCon tc2 + = canEqHardFailure ev eq_rel ps_ty1 ps_ty2 + +can_eq_nc' _rdr_env _envs ev eq_rel s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ + | CtWanted { ctev_loc = loc, ctev_evar = orig_ev } <- ev + = do { let (tvs1,body1) = tcSplitForAllTys s1 + (tvs2,body2) = tcSplitForAllTys s2 + ; if not (equalLength tvs1 tvs2) then + canEqHardFailure ev eq_rel s1 s2 + else + do { traceTcS "Creating implication for polytype equality" $ ppr ev + ; ev_term <- deferTcSForAllEq (eqRelRole eq_rel) + loc (tvs1,body1) (tvs2,body2) + ; setEvBind orig_ev ev_term + ; stopWith ev "Deferred polytype equality" } } + | otherwise + = do { traceTcS "Ommitting decomposition of given polytype equality" $ + pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] + ; stopWith ev "Discard given polytype equality" } + +can_eq_nc' _rdr_env _envs ev eq_rel ty1@(AppTy {}) _ ty2 _ + | isGiven ev = try_decompose_app ev eq_rel ty1 ty2 + | otherwise = can_eq_wanted_app ev eq_rel ty1 ty2 +can_eq_nc' _rdr_env _envs ev eq_rel ty1 _ ty2@(AppTy {}) _ + | isGiven ev = try_decompose_app ev eq_rel ty1 ty2 + | otherwise = can_eq_wanted_app ev eq_rel ty1 ty2 + +-- Everything else is a definite type error, eg LitTy ~ TyConApp +can_eq_nc' _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 + = canEqHardFailure ev eq_rel ps_ty1 ps_ty2 + +------------ +can_eq_fam_nc :: CtEvidence -> EqRel -> SwapFlag + -> TyCon -> [TcType] + -> TcType -> TcType + -> TcS (StopOrContinue Ct) +-- Canonicalise a non-canonical equality of form (F tys ~ ty) +-- or the swapped version thereof +-- Flatten both sides and go round again +can_eq_fam_nc ev eq_rel swapped fn tys rhs ps_rhs + = do { (xi_lhs, co_lhs) <- flattenFamApp FM_FlattenAll ev fn tys + ; rewriteEqEvidence ev eq_rel swapped xi_lhs rhs co_lhs + (mkTcReflCo (eqRelRole eq_rel) rhs) + `andWhenContinue` \ new_ev -> + can_eq_nc new_ev eq_rel xi_lhs xi_lhs rhs ps_rhs } + +{- +Note [Eager reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + +and + + [W] X ~R X + +Naively, we would start unwrapping X and end up in a loop. Instead, +we do this eager reflexivity check. This is necessary only for representational +equality because the flattener technology deals with the similar case +(recursive type families) for nominal equality. + +As an alternative, suppose we also have + + newtype Y = MkY (Int -> Y) + +and now wish to prove + + [W] X ~R Y + +This new Wanted will loop, expanding out the newtypes ever deeper looking +for a solid match or a solid discrepancy. Indeed, there is something +appropriate to this looping, because X and Y *do* have the same representation, +in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized +coercion will ever witness it. This loop won't actually cause GHC to hang, +though, because of the stack-blowing check in can_eq_newtype_nc, along +with the fact that rewriteEqEvidence bumps the stack depth. + +Note [AppTy reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider trying to prove (f a) ~R (f a). The AppTys in there can't +be decomposed, because representational equality isn't congruent with respect +to AppTy. So, when canonicalising the equality above, we get stuck and +would normally produce a CIrredEvCan. However, we really do want to +be able to solve (f a) ~R (f a). So, in the representational case only, +we do a reflexivity check. + +(This would be sound in the nominal case, but unnecessary, and I [Richard +E.] am worried that it would slow down the common case.) +-} + +------------------------ +-- | We're able to unwrap a newtype. Update the bits accordingly. +can_eq_newtype_nc :: GlobalRdrEnv + -> CtEvidence -- ^ :: ty1 ~ ty2 + -> SwapFlag + -> TcCoercion -- ^ :: ty1 ~ ty1' + -> TcType -- ^ ty1 + -> TcType -- ^ ty1' + -> TcType -- ^ ty2 + -> TcType -- ^ ty2, with type synonyms + -> TcS (StopOrContinue Ct) +can_eq_newtype_nc rdr_env ev swapped co ty1 ty1' ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co, ppr ty1', ppr ty2 ] + + -- check for blowing our stack: + -- See Note [Eager reflexivity check] for an example of + -- when this is necessary + ; dflags <- getDynFlags + ; if isJust $ subGoalDepthExceeded (maxSubGoalDepth dflags) + (ctLocDepth (ctEvLoc ev)) + then do { emitInsoluble (mkNonCanonical ev) + ; stopWith ev "unwrapping newtypes blew stack" } + else do + { if ty1 `eqType` ty2 -- See Note [Eager reflexivity check] + then canEqReflexive ev ReprEq ty1 + else do + { markDataConsAsUsed rdr_env (tyConAppTyCon ty1) + -- we have actually used the newtype constructor here, so + -- make sure we don't warn about importing it! + + ; rewriteEqEvidence ev ReprEq swapped ty1' ps_ty2 + (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) + `andWhenContinue` \ new_ev -> + can_eq_nc new_ev ReprEq ty1' ty1' ty2 ps_ty2 }}} + +-- | Mark all the datacons of the given 'TyCon' as used in this module, +-- avoiding "redundant import" warnings. +markDataConsAsUsed :: GlobalRdrEnv -> TyCon -> TcS () +markDataConsAsUsed rdr_env tc = addUsedRdrNamesTcS + [ mkRdrQual (is_as (is_decl imp_spec)) occ + | dc <- tyConDataCons tc + , let dc_name = dataConName dc + occ = nameOccName dc_name + , gre : _ <- return $ lookupGRE_Name rdr_env dc_name + , Imported (imp_spec:_) <- return $ gre_prov gre ] + +------------------------------------------------- +can_eq_wanted_app :: CtEvidence -> EqRel -> TcType -> TcType + -> TcS (StopOrContinue Ct) +-- One or the other is an App; neither is a type variable +-- See Note [Canonicalising type applications] +can_eq_wanted_app ev eq_rel ty1 ty2 + = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 + ; rewriteEqEvidence ev eq_rel NotSwapped xi1 xi2 co1 co2 + `andWhenContinue` \ new_ev -> + try_decompose_app new_ev eq_rel xi1 xi2 } + +--------- +try_decompose_app :: CtEvidence -> EqRel + -> TcType -> TcType -> TcS (StopOrContinue Ct) +-- Preconditions: one or the other is an App; +-- but neither is a type variable +-- so can't turn it into an application if it +-- doesn't look like one already +-- See Note [Canonicalising type applications] +try_decompose_app ev eq_rel ty1 ty2 + = case eq_rel of + NomEq -> try_decompose_nom_app ev ty1 ty2 + ReprEq -> try_decompose_repr_app ev ty1 ty2 + +--------- +try_decompose_repr_app :: CtEvidence + -> TcType -> TcType -> TcS (StopOrContinue Ct) +-- Preconditions: like try_decompose_app, but also +-- ev has a representational +try_decompose_repr_app ev ty1 ty2 + | ty1 `eqType` ty2 -- See Note [AppTy reflexivity check] + = canEqReflexive ev ReprEq ty1 + + | AppTy {} <- ty1 + = canEqFailure ev ReprEq ty1 ty2 + + | AppTy {} <- ty2 + = canEqFailure ev ReprEq ty1 ty2 + + | otherwise -- flattening in can_eq_wanted_app exposed some TyConApps! + = ASSERT2( isJust (tcSplitTyConApp_maybe ty1) || isJust (tcSplitTyConApp_maybe ty2) + , ppr ty1 $$ ppr ty2 ) -- If this assertion fails, we may fall + -- into an infinite loop + canEqNC ev ReprEq ty1 ty2 + +--------- +try_decompose_nom_app :: CtEvidence + -> TcType -> TcType -> TcS (StopOrContinue Ct) +-- Preconditions: like try_decompose_app, but also +-- ev has a nominal role +try_decompose_nom_app ev ty1 ty2 + | AppTy s1 t1 <- ty1 + = case tcSplitAppTy_maybe ty2 of + Nothing -> canEqHardFailure ev NomEq ty1 ty2 + Just (s2,t2) -> do_decompose s1 t1 s2 t2 + + | AppTy s2 t2 <- ty2 + = case tcSplitAppTy_maybe ty1 of + Nothing -> canEqHardFailure ev NomEq ty1 ty2 + Just (s1,t1) -> do_decompose s1 t1 s2 t2 + + | otherwise -- Neither is an AppTy; but one or other started that way + -- (precondition to can_eq_wanted_app) + -- So presumably one has become a TyConApp, which + -- is good: See Note [Canonicalising type applications] + = ASSERT2( isJust (tcSplitTyConApp_maybe ty1) || isJust (tcSplitTyConApp_maybe ty2) + , ppr ty1 $$ ppr ty2 ) -- If this assertion fails, we may fall + -- into an infinite loop (Trac #9971) + canEqNC ev NomEq ty1 ty2 + where + -- do_decompose is like xCtEvidence, but recurses + -- to try_decompose_nom_app to decompose a chain of AppTys + do_decompose s1 t1 s2 t2 + | CtDerived { ctev_loc = loc } <- ev + = do { emitNewDerived loc (mkTcEqPred t1 t2) + ; canEqNC ev NomEq s1 s2 } + | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev + = do { ev_s <- newWantedEvVarNC loc (mkTcEqPred s1 s2) + ; co_t <- unifyWanted loc Nominal t1 t2 + ; let co = mkTcAppCo (ctEvCoercion ev_s) co_t + ; setEvBind evar (EvCoercion co) + ; canEqNC ev_s NomEq s1 s2 } + | CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- ev + = do { let co = evTermCoercion ev_tm + co_s = mkTcLRCo CLeft co + co_t = mkTcLRCo CRight co + ; evar_s <- newGivenEvVar loc (mkTcEqPred s1 s2, EvCoercion co_s) + ; evar_t <- newGivenEvVar loc (mkTcEqPred t1 t2, EvCoercion co_t) + ; emitWorkNC [evar_t] + ; canEqNC evar_s NomEq s1 s2 } + | otherwise -- Can't happen + = error "try_decompose_app" + +------------------------ +canDecomposableTyConApp :: CtEvidence -> EqRel + -> TyCon -> [TcType] + -> TyCon -> [TcType] + -> TcS (StopOrContinue Ct) +-- See Note [Decomposing TyConApps] +canDecomposableTyConApp ev eq_rel tc1 tys1 tc2 tys2 + | tc1 == tc2 + , length tys1 == length tys2 + = if eq_rel == NomEq || ctEvFlavour ev /= Given || isDistinctTyCon tc1 + -- See Note [Decomposing newtypes] + then do { traceTcS "canDecomposableTyConApp" + (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) + ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 + ; stopWith ev "Decomposed TyConApp" } + else canEqFailure ev eq_rel ty1 ty2 + + -- Fail straight away for better error messages + -- See Note [Use canEqFailure in canDecomposableTyConApp] + | isDataFamilyTyCon tc1 || isDataFamilyTyCon tc2 + = canEqFailure ev eq_rel ty1 ty2 + | otherwise + = canEqHardFailure ev eq_rel ty1 ty2 + where + ty1 = mkTyConApp tc1 tys1 + ty2 = mkTyConApp tc2 tys2 + +{- +Note [Use canEqFailure in canDecomposableTyConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must use canEqFailure, not canEqHardFailure here, because there is +the possibility of success if working with a representational equality. +Here is the case: + + type family TF a where TF Char = Bool + data family DF a + newtype instance DF Bool = MkDF Int + +Suppose we are canonicalising (Int ~R DF (T a)), where we don't yet +know `a`. This is *not* a hard failure, because we might soon learn +that `a` is, in fact, Char, and then the equality succeeds. + +Note [Decomposing newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [NthCo and newtypes] in Coercion, we can't use +NthCo on representational coercions over newtypes. So we avoid doing +so. + +But is it sensible to decompose *Wanted* constraints over newtypes? +Yes. By the time we reach canDecomposableTyConApp, we know that any +newtypes that can be unwrapped have been. So, without importing more +constructors, say, we know there is no way forward other than decomposition. +So we take the one route we have available. This *does* mean that +importing a newtype's constructor might make code that previously +compiled fail to do so. (If that newtype is perversely recursive, say.) +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon -> [TcType] -> [TcType] + -> TcS () +-- Precondition: tys1 and tys2 are the same length, hence "OK" +canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 + = case ev of + CtDerived { ctev_loc = loc } + -> unifyDeriveds loc tc_roles tys1 tys2 + + CtWanted { ctev_evar = evar, ctev_loc = loc } + -> do { cos <- zipWith3M (unifyWanted loc) tc_roles tys1 tys2 + ; setEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) } + + CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } + -> do { let ev_co = evTermCoercion ev_tm + ; given_evs <- newGivenEvVars loc $ + [ ( mkTcEqPredRole r ty1 ty2 + , EvCoercion (mkTcNthCo i ev_co) ) + | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] + , r /= Phantom ] + ; emitWorkNC given_evs } + where + role = eqRelRole eq_rel + tc_roles = tyConRolesX role tc + +-- | Call when canonicalizing an equality fails, but if the equality is +-- representational, there is some hope for the future. +-- Examples in Note [Flatten irreducible representational equalities] +canEqFailure :: CtEvidence -> EqRel + -> TcType -> TcType -> TcS (StopOrContinue Ct) +canEqFailure ev ReprEq ty1 ty2 + = do { -- See Note [Flatten irreducible representational equalities] + (xi1, co1) <- flatten FM_FlattenAll ev ty1 + ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 + ; traceTcS "canEqFailure with ReprEq" $ + vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] + ; if xi1 `eqType` ty1 && xi2 `eqType` ty2 + then continueWith (CIrredEvCan { cc_ev = ev }) -- co1/2 must be refl + else rewriteEqEvidence ev ReprEq NotSwapped xi1 xi2 co1 co2 + `andWhenContinue` \ new_ev -> + can_eq_nc new_ev ReprEq xi1 xi1 xi2 xi2 } +canEqFailure ev NomEq ty1 ty2 = canEqHardFailure ev NomEq ty1 ty2 + +-- | Call when canonicalizing an equality fails with utterly no hope. +canEqHardFailure :: CtEvidence -> EqRel + -> TcType -> TcType -> TcS (StopOrContinue Ct) +-- See Note [Make sure that insolubles are fully rewritten] +canEqHardFailure ev eq_rel ty1 ty2 + = do { (s1, co1) <- flatten FM_SubstOnly ev ty1 + ; (s2, co2) <- flatten FM_SubstOnly ev ty2 + ; rewriteEqEvidence ev eq_rel NotSwapped s1 s2 co1 co2 + `andWhenContinue` \ new_ev -> + do { emitInsoluble (mkNonCanonical new_ev) + ; stopWith new_ev "Definitely not equal" }} + +{- +Note [Flatten irreducible representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we can't make any progress with a representational equality, but +we haven't given up all hope, we must flatten before producing the +CIrredEvCan. There are two reasons to do this: + + * See case in Note [Use canEqFailure in canDecomposableTyConApp]. + Flattening here can expose that we know enough information to unwrap + a newtype. + + * This case, which was encountered in the testsuite (T9117_3): + + work item: [W] c1: f a ~R g a + inert set: [G] c2: g ~R f + + In can_eq_app, we try to flatten the LHS of c1. This causes no effect, + because `f` cannot be rewritten. So, we go to can_eq_flat_app. Without + flattening the RHS, the reflexivity check fails, and we give up. However, + flattening the RHS rewrites `g` to `f`, the reflexivity check succeeds, + and we go on to glory. + +Note [Decomposing TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (T s1 t1 ~ T s2 t2), then we can just decompose to + (s1 ~ s2, t1 ~ t2) +and push those back into the work list. But if + s1 = K k1 s2 = K k2 +then we will jus decomopose s1~s2, and it might be better to +do so on the spot. An important special case is where s1=s2, +and we get just Refl. + +So canDecomposableTyCon is a fast-path decomposition that uses +unifyWanted etc to short-cut that work. + +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple things is to see if ty2 is of form (s2 t2), and +decompose. By this time s1 and s2 can't be saturated type +function applications, because those have been dealt with +by an earlier equation in can_eq_nc, so it is always sound to +decompose. + +However, over-eager decomposition gives bad error messages +for things like + a b ~ Maybe c + e f ~ p -> q +Suppose (in the first example) we already know a~Array. Then if we +decompose the application eagerly, yielding + a ~ Maybe + b ~ c +we get an error "Can't match Array ~ Maybe", +but we'd prefer to get "Can't match Array b ~ Maybe c". + +So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of +replacing (a b) by (Array b), before using try_decompose_app to +decompose it. + +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Kick out insolubles] in TcInteract. +And if we don't do this there is a bad danger that +TcSimplify.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose Given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like? So instead we simply discard +this given evidence. + + +Note [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + +Note [No top-level newtypes on RHS of representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we're in this situation: + + work item: [W] c1 : a ~R b + inert: [G] c2 : b ~R Id a + +where + newtype Id a = Id a + +Further, suppose flattening `a` doesn't do anything. Then, we'll flatten the +RHS of c1 and have a new [W] c3 : a ~R Id a. If we just blindly proceed, we'll +fail in canEqTyVar2 with an occurs-check. What we really need to do is to +unwrap the `Id a` in the RHS. This is exactly analogous to the requirement for +no top-level type families on the RHS of a nominal equality. The only +annoyance is that the flattener doesn't do this work for us when flattening +the RHS, so we have to catch this case here and then go back to the beginning +of can_eq_nc. We know that this can't loop forever because we require that +flattening the RHS actually made progress. (If it didn't, then we really +*should* fail with an occurs-check!) + +Note [Occurs check error] +~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an occurs check error, are we necessarily hosed? Say our +tyvar is tv1 and the type it appears in is xi2. Because xi2 is function +free, then if we're computing w.r.t. nominal equality, then, yes, we're +hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. +representational equality, this is a little subtler. Once again, (a ~R [a]) +is a bad thing, but (a ~R N a) for a newtype N might be just fine. This +means also that (a ~ b a) might be fine, because `b` might become a newtype. + +So, we must check: does tv1 appear in xi2 under any type constructor that +is generative w.r.t. representational equality? That's what isTyVarUnderDatatype +does. (The other name I considered, isTyVarUnderTyConGenerativeWrtReprEq was +a bit verbose. And the shorter name gets the point across.) + +See also #10715, which induced this addition. + +-} + +canCFunEqCan :: CtEvidence + -> TyCon -> [TcType] -- LHS + -> TcTyVar -- RHS + -> TcS (StopOrContinue Ct) +-- ^ Canonicalise a CFunEqCan. We know that +-- the arg types are already flat, +-- and the RHS is a fsk, which we must *not* substitute. +-- So just substitute in the LHS +canCFunEqCan ev fn tys fsk + = do { (tys', cos) <- flattenMany FM_FlattenAll ev (repeat Nominal) tys + -- cos :: tys' ~ tys + ; let lhs_co = mkTcTyConAppCo Nominal fn cos + -- :: F tys' ~ F tys + new_lhs = mkTyConApp fn tys' + fsk_ty = mkTyVarTy fsk + ; rewriteEqEvidence ev NomEq NotSwapped new_lhs fsk_ty + lhs_co (mkTcNomReflCo fsk_ty) + `andWhenContinue` \ ev' -> + do { extendFlatCache fn tys' (ctEvCoercion ev', fsk_ty, ctEvFlavour ev') + ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn + , cc_tyargs = tys', cc_fsk = fsk }) } } + +--------------------- +canEqTyVar :: CtEvidence -> EqRel -> SwapFlag + -> TcTyVar + -> TcType -> TcType + -> TcS (StopOrContinue Ct) +-- A TyVar on LHS, but so far un-zonked +canEqTyVar ev eq_rel swapped tv1 ty2 ps_ty2 -- ev :: tv ~ s2 + = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr ty2 $$ ppr swapped) + ; let fmode = mkFlattenEnv FM_FlattenAll ev -- the FM_ param is ignored + ; mb_yes <- flattenTyVarOuter fmode tv1 + ; case mb_yes of + { Right (ty1, co1) -> -- co1 :: ty1 ~ tv1 + do { traceTcS "canEqTyVar2" + (vcat [ ppr tv1, ppr ty2, ppr swapped + , ppr ty1 , ppUnless (isDerived ev) (ppr co1)]) + ; rewriteEqEvidence ev eq_rel swapped ty1 ps_ty2 + co1 (mkTcReflCo (eqRelRole eq_rel) ps_ty2) + `andWhenContinue` \ new_ev -> + can_eq_nc new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + + ; Left tv1' -> + do { -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten + -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True } + -- Flatten the RHS less vigorously, to avoid gratuitous flattening + -- True <=> xi2 should not itself be a type-function application + ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 -- co2 :: xi2 ~ ps_ty2 + -- Use ps_ty2 to preserve type synonyms if poss + ; traceTcS "canEqTyVar flat LHS" + (vcat [ ppr tv1, ppr tv1', ppr ty2, ppr swapped, ppr xi2 ]) + ; dflags <- getDynFlags + ; case eq_rel of + -- See Note [No top-level newtypes on RHS of representational equalities] + ReprEq + | Just (tc2, _) <- tcSplitTyConApp_maybe xi2 + , isNewTyCon tc2 + , not (ps_ty2 `eqType` xi2) + -> do { let xi1 = mkTyVarTy tv1' + role = eqRelRole eq_rel + ; traceTcS "canEqTyVar exposed newtype" + (vcat [ ppr tv1', ppr ps_ty2, ppr xi2, ppr tc2 ]) + ; rewriteEqEvidence ev eq_rel swapped xi1 xi2 + (mkTcReflCo role xi1) co2 + `andWhenContinue` \ new_ev -> + can_eq_nc new_ev eq_rel xi1 xi1 xi2 xi2 } + _ -> canEqTyVar2 dflags ev eq_rel swapped tv1' xi2 co2 } } } + +canEqTyVar2 :: DynFlags + -> CtEvidence -- olhs ~ orhs (or, if swapped, orhs ~ olhs) + -> EqRel + -> SwapFlag + -> TcTyVar -- olhs + -> TcType -- nrhs + -> TcCoercion -- nrhs ~ orhs + -> TcS (StopOrContinue Ct) +-- LHS is an inert type variable, +-- and RHS is fully rewritten, but with type synonyms +-- preserved as much as possible + +canEqTyVar2 dflags ev eq_rel swapped tv1 xi2 co2 + | Just tv2 <- getTyVar_maybe xi2 + = canEqTyVarTyVar ev eq_rel swapped tv1 tv2 co2 + + | OC_OK xi2' <- occurCheckExpand dflags tv1 xi2 -- No occurs check + = do { let k1 = tyVarKind tv1 + k2 = typeKind xi2' + ; rewriteEqEvidence ev eq_rel swapped xi1 xi2' co1 co2 + -- Ensure that the new goal has enough type synonyms + -- expanded by the occurCheckExpand; hence using xi2' here + -- See Note [occurCheckExpand] + `andWhenContinue` \ new_ev -> + if k2 `isSubKind` k1 + then -- Establish CTyEqCan kind invariant + -- Reorientation has done its best, but the kinds might + -- simply be incompatible + continueWith (CTyEqCan { cc_ev = new_ev + , cc_tyvar = tv1, cc_rhs = xi2' + , cc_eq_rel = eq_rel }) + else incompatibleKind new_ev xi1 k1 xi2' k2 } + + | otherwise -- Occurs check error + = rewriteEqEvidence ev eq_rel swapped xi1 xi2 co1 co2 + `andWhenContinue` \ new_ev -> + if eq_rel == NomEq || isTyVarUnderDatatype tv1 xi2 + -- See Note [Occurs check error] + + then do { emitInsoluble (mkNonCanonical new_ev) + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + ; stopWith new_ev "Occurs check" } + + -- A representational equality with an occurs-check problem isn't + -- insoluble! For example: + -- a ~R b a + -- We might learn that b is the newtype Id. + -- But, the occurs-check certainly prevents the equality from being + -- canonical, and we might loop if we were to use it in rewriting. + else do { traceTcS "Occurs-check in representational equality" + (ppr xi1 $$ ppr xi2) + ; continueWith (CIrredEvCan { cc_ev = new_ev }) } + where + xi1 = mkTyVarTy tv1 + co1 = mkTcReflCo (eqRelRole eq_rel) xi1 + + + +canEqTyVarTyVar :: CtEvidence -- tv1 ~ orhs (or orhs ~ tv1, if swapped) + -> EqRel + -> SwapFlag + -> TcTyVar -> TcTyVar -- tv2, tv2 + -> TcCoercion -- tv2 ~ orhs + -> TcS (StopOrContinue Ct) +-- Both LHS and RHS rewrote to a type variable, +-- If swapped = NotSwapped, then +-- rw_orhs = tv1, rw_olhs = orhs +-- rw_nlhs = tv2, rw_nrhs = xi1 +-- See Note [Canonical orientation for tyvar/tyvar equality constraints] +canEqTyVarTyVar ev eq_rel swapped tv1 tv2 co2 + | tv1 == tv2 + = do { when (isWanted ev) $ + ASSERT( tcCoercionRole co2 == eqRelRole eq_rel ) + setEvBind (ctev_evar ev) (EvCoercion (maybeSym swapped co2)) + ; stopWith ev "Equal tyvars" } + + | incompat_kind = incompat + | isFmvTyVar tv1 = do_fmv swapped tv1 xi1 xi2 co1 co2 + | isFmvTyVar tv2 = do_fmv (flipSwap swapped) tv2 xi2 xi1 co2 co1 + | same_kind = if swap_over then do_swap else no_swap + | k1_sub_k2 = do_swap -- Note [Kind orientation for CTyEqCan] + | otherwise = no_swap -- k2_sub_k1 + where + xi1 = mkTyVarTy tv1 + xi2 = mkTyVarTy tv2 + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + co1 = mkTcReflCo (eqRelRole eq_rel) xi1 + k1_sub_k2 = k1 `isSubKind` k2 + k2_sub_k1 = k2 `isSubKind` k1 + same_kind = k1_sub_k2 && k2_sub_k1 + incompat_kind = not (k1_sub_k2 || k2_sub_k1) + + no_swap = canon_eq swapped tv1 xi1 xi2 co1 co2 + do_swap = canon_eq (flipSwap swapped) tv2 xi2 xi1 co2 co1 + + canon_eq swapped tv1 xi1 xi2 co1 co2 + -- ev : tv1 ~ orhs (not swapped) or orhs ~ tv1 (swapped) + -- co1 : xi1 ~ tv1 + -- co2 : xi2 ~ tv2 + = do { mb <- rewriteEqEvidence ev eq_rel swapped xi1 xi2 co1 co2 + ; let mk_ct ev' = CTyEqCan { cc_ev = ev', cc_tyvar = tv1 + , cc_rhs = xi2 , cc_eq_rel = eq_rel } + ; return (fmap mk_ct mb) } + + -- See Note [Orient equalities with flatten-meta-vars on the left] in TcFlatten + do_fmv swapped tv1 xi1 xi2 co1 co2 + | same_kind + = canon_eq swapped tv1 xi1 xi2 co1 co2 + | otherwise -- Presumably tv1 `subKind` tv2, which is the wrong way round + = ASSERT2( k1_sub_k2, ppr tv1 $$ ppr tv2 ) + ASSERT2( isWanted ev, ppr ev ) -- Only wanteds have flatten meta-vars + do { tv_ty <- newFlexiTcSTy (tyVarKind tv1) + ; new_ev <- newWantedEvVarNC (ctEvLoc ev) + (mkTcEqPredRole (eqRelRole eq_rel) + tv_ty xi2) + ; emitWorkNC [new_ev] + ; canon_eq swapped tv1 xi1 tv_ty co1 (ctEvCoercion new_ev `mkTcTransCo` co2) } + + incompat + = rewriteEqEvidence ev eq_rel swapped xi1 xi2 (mkTcNomReflCo xi1) co2 + `andWhenContinue` \ ev' -> + incompatibleKind ev' xi1 k1 xi2 k2 + + swap_over + -- If tv1 is touchable, swap only if tv2 is also + -- touchable and it's strictly better to update the latter + -- But see Note [Avoid unnecessary swaps] + | Just lvl1 <- metaTyVarTcLevel_maybe tv1 + = case metaTyVarTcLevel_maybe tv2 of + Nothing -> False + Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True + | lvl1 `strictlyDeeperThan` lvl2 -> False + | otherwise -> nicer_to_update_tv2 + + -- So tv1 is not a meta tyvar + -- If only one is a meta tyvar, put it on the left + -- This is not because it'll be solved; but because + -- the floating step looks for meta tyvars on the left + | isMetaTyVar tv2 = True + + -- So neither is a meta tyvar + + -- If only one is a flatten tyvar, put it on the left + -- See Note [Eliminate flat-skols] + | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True + + | otherwise = False + + nicer_to_update_tv2 + = (isSigTyVar tv1 && not (isSigTyVar tv2)) + || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1))) + +-- | Solve a reflexive equality constraint +canEqReflexive :: CtEvidence -- ty ~ ty + -> EqRel + -> TcType -- ty + -> TcS (StopOrContinue Ct) -- always Stop +canEqReflexive ev eq_rel ty + = do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (EvCoercion $ + mkTcReflCo (eqRelRole eq_rel) ty) + ; stopWith ev "Solved by reflexivity" } + +incompatibleKind :: CtEvidence -- t1~t2 + -> TcType -> TcKind + -> TcType -> TcKind -- s1~s2, flattened and zonked + -> TcS (StopOrContinue Ct) +-- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint +-- CIrredEvCan (NOT CTyEqCan or CFunEqCan) +-- for the type equality; and continue with the kind equality constraint. +-- When the latter is solved, it'll kick out the irreducible equality for +-- a second attempt at solving +-- +-- See Note [Equalities with incompatible kinds] + +incompatibleKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible kinds] + = ASSERT( isKind k1 && isKind k2 ) + do { traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2]) + + -- Create a derived kind-equality, and solve it + ; emitNewDerived kind_co_loc (mkTcEqPred k1 k2) + + -- Put the not-currently-soluble thing into the inert set + ; continueWith (CIrredEvCan { cc_ev = new_ev }) } + where + loc = ctEvLoc new_ev + kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc)) + +{- +Note [Canonical orientation for tyvar/tyvar equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a ~ b where both 'a' and 'b' are TcTyVars, which way +round should be oriented in the CTyEqCan? The rules, implemented by +canEqTyVarTyVar, are these + + * If either is a flatten-meta-variables, it goes on the left. + + * If one is a strict sub-kind of the other e.g. + (alpha::?) ~ (beta::*) + orient them so RHS is a subkind of LHS. That way we will replace + 'a' with 'b', correctly narrowing the kind. + This establishes the subkind invariant of CTyEqCan. + + * Put a meta-tyvar on the left if possible + alpha[3] ~ r + + * If both are meta-tyvars, put the more touchable one (deepest level + number) on the left, so there is the best chance of unifying it + alpha[3] ~ beta[2] + + * If both are meta-tyvars and both at the same level, put a SigTv + on the right if possible + alpha[2] ~ beta[2](sig-tv) + That way, when we unify alpha := beta, we don't lose the SigTv flag. + + * Put a meta-tv with a System Name on the left if possible so it + gets eliminated (improves error messages) + + * If one is a flatten-skolem, put it on the left so that it is + substituted out Note [Elminate flat-skols] + fsk ~ a + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infnite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-time to (a ~ c). If we then swap it before +aeding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + +Note [Eliminate flat-skols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have [G] Num (F [a]) +then we flatten to + [G] Num fsk + [G] F [a] ~ fsk +where fsk is a flatten-skolem (FlatSkol). Suppose we have + type instance F [a] = a +then we'll reduce the second constraint to + [G] a ~ fsk +and then replace all uses of 'a' with fsk. That's bad because +in error messages intead of saying 'a' we'll say (F [a]). In all +places, including those where the programmer wrote 'a' in the first +place. Very confusing! See Trac #7862. + +Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate +the fsk. + +Note [Equalities with incompatible kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +canEqLeaf is about to make a CTyEqCan or CFunEqCan; but both have the +invariant that LHS and RHS satisfy the kind invariants for CTyEqCan, +CFunEqCan. What if we try to unify two things with incompatible +kinds? + +eg a ~ b where a::*, b::*->* +or a ~ b where a::*, b::k, k is a kind variable + +The CTyEqCan compatKind invariant is important. If we make a CTyEqCan +for a~b, then we might well *substitute* 'b' for 'a', and that might make +a well-kinded type ill-kinded; and that is bad (eg typeKind can crash, see +Trac #7696). + +So instead for these ill-kinded equalities we generate a CIrredCan, +and put it in the inert set, which keeps it out of the way until a +subsequent substitution (on kind variables, say) re-activates it. + +NB: it is important that the types s1,s2 are flattened and zonked + so that their kinds k1, k2 are inert wrt the substitution. That + means that they can only become the same if we change the inert + set, which in turn will kick out the irreducible equality + E.g. it is WRONG to make an irred (a:k1)~(b:k2) + if we already have a substitution k1:=k2 + +NB: it's important that the new CIrredCan goes in the inert set rather +than back into the work list. We used to do the latter, but that led +to an infinite loop when we encountered it again, and put it back in +the work list again. + +See also Note [Kind orientation for CTyEqCan] and + Note [Kind orientation for CFunEqCan] in TcRnTypes + +Note [Type synonyms and canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat type synonym applications as xi types, that is, they do not +count as type function applications. However, we do need to be a bit +careful with type synonyms: like type functions they may not be +generative or injective. However, unlike type functions, they are +parametric, so there is no problem in expanding them whenever we see +them, since we do not need to know anything about their arguments in +order to expand them; this is what justifies not having to treat them +as specially as type function applications. The thing that causes +some subtleties is that we prefer to leave type synonym applications +*unexpanded* whenever possible, in order to generate better error +messages. + +If we encounter an equality constraint with type synonym applications +on both sides, or a type synonym application on one side and some sort +of type application on the other, we simply must expand out the type +synonyms in order to continue decomposing the equality constraint into +primitive equality constraints. For example, suppose we have + + type F a = [Int] + +and we encounter the equality + + F a ~ [b] + +In order to continue we must expand F a into [Int], giving us the +equality + + [Int] ~ [b] + +which we can then decompose into the more primitive equality +constraint + + Int ~ b. + +However, if we encounter an equality constraint with a type synonym +application on one side and a variable on the other side, we should +NOT (necessarily) expand the type synonym, since for the purpose of +good error messages we want to leave type synonyms unexpanded as much +as possible. Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar. + + +Note [occurCheckExpand] +~~~~~~~~~~~~~~~~~~~~~~~ +There is a subtle point with type synonyms and the occurs check that +takes place for equality constraints of the form tv ~ xi. As an +example, suppose we have + + type F a = Int + +and we come across the equality constraint + + a ~ F a + +This should not actually fail the occurs check, since expanding out +the type synonym results in the legitimate equality constraint a ~ +Int. We must actually do this expansion, because unifying a with F a +will lead the type checker into infinite loops later. Put another +way, canonical equality constraints should never *syntactically* +contain the LHS variable in the RHS type. However, we don't always +need to expand type synonyms when doing an occurs check; for example, +the constraint + + a ~ F b + +is obviously fine no matter what F expands to. And in this case we +would rather unify a with F b (rather than F b's expansion) in order +to get better error messages later. + +So, when doing an occurs check with a type synonym application on the +RHS, we use some heuristics to find an expansion of the RHS which does +not contain the variable from the LHS. In particular, given + + a ~ F t1 ... tn + +we first try expanding each of the ti to types which no longer contain +a. If this turns out to be impossible, we next try expanding F +itself, and so on. See Note [Occurs check expansion] in TcType +-} + +{- +************************************************************************ +* * + Evidence transformation +* * +************************************************************************ +-} + +{- +Note [xCtEvidence] +~~~~~~~~~~~~~~~~~~ +A call might look like this: + + xCtEvidence ev evidence-transformer + + ev is Given => use ev_decomp to create new Givens for ev_preds, + and return them + + ev is Wanted => create new wanteds for ev_preds, + use ev_comp to bind ev, + return fresh wanteds (ie ones not cached in inert_cans or solved) + + ev is Derived => create new deriveds for ev_preds + (unless cached in inert_cans or solved) + +Note: The [CtEvidence] returned is a subset of the subgoal-preds passed in + Ones that are already cached are not returned + +Example + ev : Tree a b ~ Tree c d + xCtEvidence ev [a~c, b~d] (XEvTerm { ev_comp = \[c1 c2]. c1 c2 + , ev_decomp = \c. [nth 1 c, nth 2 c] }) + (\fresh-goals. stuff) + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. We don't worry +about caching, but we don't expect complicated calculations among Givens. +It is important to bind each given: + class (a~b) => C a b where .... + f :: C a b => .... +Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. +But that superclass selector can't (yet) appear in a coercion +(see evTermCoercion), so the easy thing is to bind it to an Id. + +See Note [Coercion evidence terms] in TcEvidence. +-} + +xCtEvidence :: CtEvidence -- Original evidence + -> XEvTerm -- Instructions about how to manipulate evidence + -> TcS () + +xCtEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc }) + (XEvTerm { ev_preds = ptys, ev_comp = comp_fn }) + = do { new_evars <- mapM (newWantedEvVar loc) ptys + ; setEvBind evar (comp_fn (map (ctEvTerm . fst) new_evars)) + ; emitWorkNC (freshGoals new_evars) } + -- Note the "NC": these are fresh goals, not necessarily canonical + +xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc }) + (XEvTerm { ev_preds = ptys, ev_decomp = decomp_fn }) + = ASSERT( equalLength ptys (decomp_fn tm) ) + do { given_evs <- newGivenEvVars loc (ptys `zip` decomp_fn tm) + ; emitWorkNC given_evs } + +xCtEvidence (CtDerived { ctev_loc = loc }) + (XEvTerm { ev_preds = ptys }) + = mapM_ (emitNewDerived loc) ptys + +----------------------------- +data StopOrContinue a + = ContinueWith a -- The constraint was not solved, although it may have + -- been rewritten + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + +instance Functor StopOrContinue where + fmap f (ContinueWith x) = ContinueWith (f x) + fmap _ (Stop ev s) = Stop ev s + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = ptext (sLit "Stop") <> parens s <+> ppr ev + ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w + +continueWith :: a -> TcS (StopOrContinue a) +continueWith = return . ContinueWith + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +andWhenContinue :: TcS (StopOrContinue a) + -> (a -> TcS (StopOrContinue b)) + -> TcS (StopOrContinue b) +andWhenContinue tcs1 tcs2 + = do { r <- tcs1 + ; case r of + Stop ev s -> return (Stop ev s) + ContinueWith ct -> tcs2 ct } +infixr 0 `andWhenContinue` -- allow chaining with ($) + +rewriteEvidence :: CtEvidence -- old evidence + -> TcPredType -- new predicate + -> TcCoercion -- Of type :: new predicate ~ + -> TcS (StopOrContinue CtEvidence) +-- Returns Just new_ev iff either (i) 'co' is reflexivity +-- or (ii) 'co' is not reflexivity, and 'new_pred' not cached +-- In either case, there is nothing new to do with new_ev +{- + rewriteEvidence old_ev new_pred co +Main purpose: create new evidence for new_pred; + unless new_pred is cached already +* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev +* If old_ev was wanted, create a binding for old_ev, in terms of new_ev +* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev +* Returns Nothing if new_ev is already cached + + Old evidence New predicate is Return new evidence + flavour of same flavor + ------------------------------------------------------------------- + Wanted Already solved or in inert Nothing + or Derived Not Just new_evidence + + Given Already in inert Nothing + Not Just new_evidence + +Note [Rewriting with Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the coercion is just reflexivity then you may re-use the same +variable. But be careful! Although the coercion is Refl, new_pred +may reflect the result of unification alpha := ty, so new_pred might +not _look_ the same as old_pred, and it's vital to proceed from now on +using new_pred. + +The flattener preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + -} + + +rewriteEvidence old_ev@(CtDerived { ctev_loc = loc }) new_pred _co + = -- If derived, don't even look at the coercion. + -- This is very important, DO NOT re-order the equations for + -- rewriteEvidence to put the isTcReflCo test first! + -- Why? Because for *Derived* constraints, c, the coercion, which + -- was produced by flattening, may contain suspended calls to + -- (ctEvTerm c), which fails for Derived constraints. + -- (Getting this wrong caused Trac #7384.) + do { mb_ev <- newDerived loc new_pred + ; case mb_ev of + Just new_ev -> continueWith new_ev + Nothing -> stopWith old_ev "Cached derived" } + +rewriteEvidence old_ev new_pred co + | isTcReflCo co -- See Note [Rewriting with Refl] + = return (ContinueWith (old_ev { ctev_pred = new_pred })) + +rewriteEvidence ev@(CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co + = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) -- See Note [Bind new Givens immediately] + ; return (ContinueWith new_ev) } + where + -- mkEvCast optimises ReflCo + new_tm = mkEvCast old_tm (tcDowngradeRole Representational + (ctEvRole ev) + (mkTcSymCo co)) + +rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co + = do { (new_ev, freshness) <- newWantedEvVar loc new_pred + ; MASSERT( tcCoercionRole co == ctEvRole ev ) + ; setEvBind evar (mkEvCast (ctEvTerm new_ev) + (tcDowngradeRole Representational (ctEvRole ev) co)) + ; case freshness of + Fresh -> continueWith new_ev + Cached -> stopWith ev "Cached wanted" } + + +rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> EqRel + -> SwapFlag + -> TcType -> TcType -- New predicate nlhs ~ nrhs + -- Should be zonked, because we use typeKind on nlhs/nrhs + -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs + -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs + -> TcS (StopOrContinue CtEvidence) -- Of type nlhs ~ nrhs +-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) +-- we generate +-- If not swapped +-- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co +-- If 'swapped' +-- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co +-- +-- For (Wanted w) we do the dual thing. +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co +-- If swapped +-- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co +-- +-- It's all a form of rewwriteEvidence, specialised for equalities +rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co + | CtDerived {} <- old_ev + = do { mb <- newDerived loc' new_pred + ; case mb of + Just new_ev -> continueWith new_ev + Nothing -> stopWith old_ev "Cached derived" } + + | NotSwapped <- swapped + , isTcReflCo lhs_co -- See Note [Rewriting with Refl] + , isTcReflCo rhs_co + = return (ContinueWith (old_ev { ctev_pred = new_pred })) + + | CtGiven { ctev_evtm = old_tm } <- old_ev + = do { let new_tm = EvCoercion (lhs_co + `mkTcTransCo` maybeSym swapped (evTermCoercion old_tm) + `mkTcTransCo` mkTcSymCo rhs_co) + ; new_ev <- newGivenEvVar loc' (new_pred, new_tm) + -- See Note [Bind new Givens immediately] + ; return (ContinueWith new_ev) } + + | CtWanted { ctev_evar = evar } <- old_ev + = do { new_evar <- newWantedEvVarNC loc' new_pred + ; let co = maybeSym swapped $ + mkTcSymCo lhs_co + `mkTcTransCo` ctEvCoercion new_evar + `mkTcTransCo` rhs_co + ; setEvBind evar (EvCoercion co) + ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) + ; return (ContinueWith new_evar) } + + | otherwise + = panic "rewriteEvidence" + where + new_pred = mkTcEqPredRole (eqRelRole eq_rel) nlhs nrhs + + -- equality is like a type class. Bumping the depth is necessary because + -- of recursive newtypes, where "reducing" a newtype can actually make + -- it bigger. See Note [Eager reflexivity check] in TcCanonical before + -- considering changing this behavior. + loc' = bumpCtLocDepth CountConstraints (ctEvLoc old_ev) + +{- Note [unifyWanted and unifyDerived] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When decomposing equalities we often create new wanted constraints for +(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. +Similar remarks apply for Derived. + +Rather than making an equality test (which traverses the structure of the +type, perhaps fruitlessly, unifyWanted traverses the common structure, and +bales out when it finds a difference by creating a new Wanted constraint. +But where it succeeds in finding common structure, it just builds a coercion +to reflect it. +-} + +unifyWanted :: CtLoc -> Role -> TcType -> TcType -> TcS TcCoercion +-- Return coercion witnessing the equality of the two types, +-- emitting new work equalities where necessary to achieve that +-- Very good short-cut when the two types are equal, or nearly so +-- See Note [unifyWanted and unifyDerived] +-- The returned coercion's role matches the input parameter +unifyWanted _ Phantom ty1 ty2 = return (mkTcPhantomCo ty1 ty2) +unifyWanted loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy s1 t1) (FunTy s2 t2) + = do { co_s <- unifyWanted loc role s1 s2 + ; co_t <- unifyWanted loc role t1 t2 + ; return (mkTcTyConAppCo role funTyCon [co_s,co_t]) } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2, isDecomposableTyCon tc1, tys1 `equalLength` tys2 + , (not (isNewTyCon tc1) && not (isDataFamilyTyCon tc1)) || role == Nominal + -- don't look under newtypes! + = do { cos <- zipWith3M (unifyWanted loc) (tyConRolesX role tc1) tys1 tys2 + ; return (mkTcTyConAppCo role tc1 cos) } + go (TyVarTy tv) ty2 + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty1' -> go ty1' ty2 + Nothing -> bale_out } + go ty1 (TyVarTy tv) + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty2' -> go ty1 ty2' + Nothing -> bale_out } + go _ _ = bale_out + + bale_out = do { ev <- newWantedEvVarNC loc (mkTcEqPredRole role + orig_ty1 orig_ty2) + ; emitWorkNC [ev] + ; return (ctEvCoercion ev) } + +unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 + +unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () +-- See Note [unifyWanted and unifyDerived] +unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 + +unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () +-- Create new Derived and put it in the work list +-- Should do nothing if the two types are equal +-- See Note [unifyWanted and unifyDerived] +unify_derived _ Phantom _ _ = return () +unify_derived loc role orig_ty1 orig_ty2 + = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + + go (FunTy s1 t1) (FunTy s2 t2) + = do { unify_derived loc role s1 s2 + ; unify_derived loc role t1 t2 } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2, isDecomposableTyCon tc1, tys1 `equalLength` tys2 + , (not (isNewTyCon tc1) && not (isDataFamilyTyCon tc1)) || role == Nominal + = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 + go (TyVarTy tv) ty2 + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty1' -> go ty1' ty2 + Nothing -> bale_out } + go ty1 (TyVarTy tv) + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of + Just ty2' -> go ty1 ty2' + Nothing -> bale_out } + go _ _ = bale_out + + bale_out = emitNewDerived loc (mkTcEqPredRole role orig_ty1 orig_ty2) + +maybeSym :: SwapFlag -> TcCoercion -> TcCoercion +maybeSym IsSwapped co = mkTcSymCo co +maybeSym NotSwapped co = co diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs new file mode 100644 index 00000000..9aeed892 --- /dev/null +++ b/compiler/typecheck/TcClassDcl.hs @@ -0,0 +1,425 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Typechecking class declarations +-} + +{-# LANGUAGE CPP #-} + +module TcClassDcl ( tcClassSigs, tcClassDecl2, + findMethodBind, instantiateMethod, tcInstanceMethodBody, + tcClassMinimalDef, + HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, + tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr + ) where + +#include "HsVersions.h" + +import HsSyn +import TcEnv +import TcPat( addInlinePrags ) +import TcEvidence( HsWrapper, idHsWrapper ) +import TcBinds +import TcUnify +import TcHsType +import TcMType +import Type ( getClassPredTys_maybe ) +import TcType +import TcRnMonad +import BuildTyCl( TcMethInfo ) +import Class +import Id +import Name +import NameEnv +import NameSet +import Var +import Outputable +import SrcLoc +import Maybes +import BasicTypes +import Bag +import FastString +import BooleanFormula +import Util + +import Control.Monad + +{- +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at at time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synomym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + +************************************************************************ +* * + Type-checking the class op signatures +* * +************************************************************************ +-} + +tcClassSigs :: Name -- Name of the class + -> [LSig Name] + -> LHsBinds Name + -> TcM ([TcMethInfo], -- Exactly one for each method + NameEnv Type) -- Types of the generic-default methods +tcClassSigs clas sigs def_methods + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] + ; sequence_ [ failWithTc (badMethodErr clas n) + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] + -- Value binding for non class-method (ie no TypeSig) + + ; sequence_ [ failWithTc (badGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + -- Generic signature without value binding + + ; traceTc "tcClassSigs 2" (ppr clas) + ; return (op_info, gen_dm_env) } + where + vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty _) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + + tc_sig genop_env (op_names, op_hs_ty) + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope + ; traceTc "ClsSig 2" (ppr op_names) + ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } + where + f nm | nm `elemNameEnv` genop_env = GenericDM + | nm `elem` dm_bind_names = VanillaDM + | otherwise = NoDM + + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcClassSigType gen_hs_ty + ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } + +{- +************************************************************************ +* * + Class Declarations +* * +************************************************************************ +-} + +tcClassDecl2 :: LTyClDecl Name -- The class declaration + -> TcM (LHsBinds Id) + +tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + do { clas <- tcLookupLocatedClass class_name + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + ; let + (tyvars, _, _, op_items) = classBigSig clas + prag_fn = mkPragFun sigs default_binds + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + ; this_dict <- newEvVar pred + + ; traceTc "TIM2" (ppr sigs) + ; let tc_dm = tcDefMeth clas clas_tyvars + this_dict default_binds + sig_fn prag_fn + + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ + mapM tc_dm op_items + + ; return (unionManyBags dm_binds) } + +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) + +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name + -> HsSigFun -> PragFun -> ClassOpItem + -> TcM (LHsBinds TcId) +-- Generate code for polymorphic default methods only (hence DefMeth) +-- (Generic default methods have turned into instance decls by now.) +-- This is incompatible with Hugs, which expects a polymorphic +-- default method for every class op, regardless of whether or not +-- the programmer supplied an explicit default decl for the class. +-- (If necessary we can fix that, but we don't have a convenient Id to hand.) +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) + = case dm_info of + NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags + ; return emptyBag } + DefMeth dm_name -> tc_dm dm_name + GenDefMeth dm_name -> tc_dm dm_name + where + sel_name = idName sel_id + prags = prag_fn sel_name + (dm_bind,bndr_loc) = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) + + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- The "local_dm_ty" is precisely the type in the above + -- type signatures, ie with no "forall a. C a =>" prefix + + tc_dm dm_name + = do { dm_id <- tcLookupId dm_name + ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name) + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; dm_id_w_inline <- addInlinePrags dm_id prags + ; spec_prags <- tcSpecPrags dm_id prags + + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) + hs_ty = lookupHsSig hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + + ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name + ; warnTc (not (null spec_prags)) + (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + <+> quotes (ppr sel_name)) + + ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] + dm_id_w_inline local_dm_sig idHsWrapper + IsDefaultMethod dm_bind + + ; return (unitBag tc_bind) } + +--------------- +tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] + -> Id -> TcSigInfo + -> HsWrapper -- See Note [Instance method signatures] in TcInstDcls + -> TcSpecPrags -> LHsBind Name + -> TcM (LHsBind Id) +tcInstanceMethodBody skol_info tyvars dfun_ev_vars + meth_id local_meth_sig wrapper + specs (L loc bind) + = do { let local_meth_id = case local_meth_sig of + TcSigInfo{ sig_id = meth_id } -> meth_id + _ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig) + lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) + -- Substitute the local_meth_name for the binder + -- NB: the binding is always a FunBind + ; (ev_binds, (tc_bind, _, _)) + <- checkConstraints skol_info tyvars dfun_ev_vars $ + tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind + + ; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id + , abe_mono = local_meth_id, abe_prags = specs } + full_bind = AbsBinds { abs_tvs = tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = ev_binds + , abs_binds = tc_bind } + + ; return (L loc full_bind) } + where + no_prag_fn _ = [] -- No pragmas for local_meth_id; + -- they are all for meth_id + +--------------- +tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef +tcClassMinimalDef _clas sigs op_info + = case findMinimalDef sigs of + Nothing -> return defMindef + Just mindef -> do + -- Warn if the given mindef does not imply the default one + -- That is, the given mindef should at least ensure that the + -- class ops without default methods are required, since we + -- have no way to fill them in otherwise + whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ + (\bf -> addWarnTc (warningMinimalDefIncomplete bf)) + return mindef + where + -- By default require all methods without a default + -- implementation whose names don't start with '_' + defMindef :: ClassMinimalDef + defMindef = mkAnd [ mkVar name + | (name, NoDM, _) <- op_info + , not (startsWithUnderscore (getOccName name)) ] + +instantiateMethod :: Class -> Id -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = ASSERT( ok_first_pred ) local_meth_ty + where + (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length sel_tyvars == length inst_tys ) + substTyWith sel_tyvars inst_tys sel_rho + + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + +--------------------------- +type HsSigFun = NameEnv (LHsType Name) + +emptyHsSigs :: HsSigFun +emptyHsSigs = emptyNameEnv + +mkHsSigFun :: [LSig Name] -> HsSigFun +mkHsSigFun sigs = mkNameEnv [(n, hs_ty) + | L _ (TypeSig ns hs_ty _) <- sigs + , L _ n <- ns ] + +lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) +lookupHsSig = lookupNameEnv + +--------------------------- +findMethodBind :: Name -- Selector name + -> LHsBinds Name -- A group of bindings + -> Maybe (LHsBind Name, SrcSpan) + -- Returns the binding, and the binding + -- site of the method binder +findMethodBind sel_name binds + = foldlBag mplus Nothing (mapBag f binds) + where + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name + = Just (bind, bndr_loc) + f _other = Nothing + +--------------------------- +findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef +findMinimalDef = firstJusts . map toMinimalDef + where + toMinimalDef :: LSig Name -> Maybe ClassMinimalDef + toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf) + toMinimalDef _ = Nothing + +{- +Note [Polymorphic methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Foo a where + op :: forall b. Ord b => a -> b -> b -> b + instance Foo c => Foo [c] where + op = e + +When typechecking the binding 'op = e', we'll have a meth_id for op +whose type is + op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b + +So tcPolyBinds must be capable of dealing with nested polytypes; +and so it is. See TcBinds.tcMonoBinds (with type-sig case). + +Note [Silly default-method bind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we pass the default method binding to the type checker, it must +look like op2 = e +not $dmop2 = e +otherwise the "$dm" stuff comes out error messages. But we want the +"$dm" to come out in the interface file. So we typecheck the former, +and wrap it in a let, thus + $dmop2 = let op2 = e in op2 +This makes the error messages right. + + +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcMkDeclCtxt :: TyClDecl Name -> SDoc +tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, + ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] + +tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a +tcAddDeclCtxt decl thing_inside + = addErrCtxt (tcMkDeclCtxt decl) thing_inside + +badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "does not have a method"), quotes (ppr op)] + +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + +{- +badGenericInstanceType :: LHsBinds Name -> SDoc +badGenericInstanceType binds + = vcat [ptext (sLit "Illegal type pattern in the generic bindings"), + nest 2 (ppr binds)] + +missingGenericInstances :: [Name] -> SDoc +missingGenericInstances missing + = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing + +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc +dupGenericInsts tc_inst_infos + = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"), + nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), + ptext (sLit "All the type patterns for a generic type constructor must be identical") + ] + where + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) +-} +badDmPrag :: Id -> Sig Name -> TcM () +badDmPrag sel_id prag + = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") + <+> quotes (ppr sel_id) + <+> ptext (sLit "lacks an accompanying binding")) + +warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete mindef + = vcat [ ptext (sLit "The MINIMAL pragma does not require:") + , nest 2 (pprBooleanFormulaNice mindef) + , ptext (sLit "but there is no default implementation.") ] diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs new file mode 100644 index 00000000..c9ce0f63 --- /dev/null +++ b/compiler/typecheck/TcDefaults.hs @@ -0,0 +1,98 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[TcDefaults]{Typechecking \tr{default} declarations} +-} + +module TcDefaults ( tcDefaults ) where + +import HsSyn +import Name +import Class +import TcRnMonad +import TcEnv +import TcHsType +import TcSimplify +import TcType +import PrelNames +import DynFlags +import SrcLoc +import Data.Maybe +import Outputable +import FastString + +tcDefaults :: [LDefaultDecl Name] + -> TcM (Maybe [Type]) -- Defaulting types to heave + -- into Tc monad for later use + -- in Disambig. + +tcDefaults [] + = getDeclaredDefaultTys -- No default declaration, so get the + -- default types from the envt; + -- i.e. use the current ones + -- (the caller will put them back there) + -- It's important not to return defaultDefaultTys here (which + -- we used to do) because in a TH program, tcDefaults [] is called + -- repeatedly, once for each group of declarations between top-level + -- splices. We don't want to carefully set the default types in + -- one group, only for the next group to ignore them and install + -- defaultDefaultTys + +tcDefaults [L _ (DefaultDecl [])] + = return (Just []) -- Default declaration specifying no types + +tcDefaults [L locn (DefaultDecl mono_tys)] + = setSrcSpan locn $ + addErrCtxt defaultDeclCtxt $ + do { ovl_str <- xoptM Opt_OverloadedStrings + ; num_class <- tcLookupClass numClassName + ; is_str_class <- tcLookupClass isStringClassName + ; let deflt_clss | ovl_str = [num_class, is_str_class] + | otherwise = [num_class] + + ; tau_tys <- mapM (tc_default_ty deflt_clss) mono_tys + + ; return (Just tau_tys) } + +tcDefaults decls@(L locn (DefaultDecl _) : _) + = setSrcSpan locn $ + failWithTc (dupDefaultDeclErr decls) + + +tc_default_ty :: [Class] -> LHsType Name -> TcM Type +tc_default_ty deflt_clss hs_ty + = do { ty <- tcHsSigType DefaultDeclCtxt hs_ty + ; checkTc (isTauTy ty) (polyDefErr hs_ty) + + -- Check that the type is an instance of at least one of the deflt_clss + ; oks <- mapM (check_instance ty) deflt_clss + ; checkTc (or oks) (badDefaultTy ty deflt_clss) + ; return ty } + +check_instance :: Type -> Class -> TcM Bool + -- Check that ty is an instance of cls + -- We only care about whether it worked or not; return a boolean +check_instance ty cls + = do { (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]]) + ; return (isJust mb_res) } + +defaultDeclCtxt :: SDoc +defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration") + +dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc +dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) + = hang (ptext (sLit "Multiple default declarations")) + 2 (vcat (map pp dup_things)) + where + pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn +dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" + +polyDefErr :: LHsType Name -> SDoc +polyDefErr ty + = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty) + +badDefaultTy :: Type -> [Class] -> SDoc +badDefaultTy ty deflt_clss + = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + 2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs new file mode 100644 index 00000000..06fbadf8 --- /dev/null +++ b/compiler/typecheck/TcDeriv.hs @@ -0,0 +1,2123 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Handles @deriving@ clauses on @data@ declarations. +-} + +{-# LANGUAGE CPP #-} + +module TcDeriv ( tcDeriving ) where + +#include "HsVersions.h" + +import HsSyn +import DynFlags + +import TcRnMonad +import FamInst +import TcErrors( reportAllUnsolved ) +import TcValidity( validDerivPred ) +import TcEnv +import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn ) +import TcClassDcl( tcAddDeclCtxt ) -- Small helper +import TcGenDeriv -- Deriv stuff +import TcGenGenerics +import InstEnv +import Inst +import FamInstEnv +import TcHsType +import TcMType +import TcSimplify +import LoadIface( loadInterfaceForName ) +import Module( getModule ) + +import RnNames( extendGlobalRdrEnvRn ) +import RnBinds +import RnEnv +import RnSource ( addTcgDUs ) +import HscTypes +import Avail + +import Unify( tcUnifyTy ) +import Class +import Type +import ErrUtils +import DataCon +import Maybes +import RdrName +import Name +import NameSet +import TyCon +import TcType +import Var +import VarSet +import PrelNames +import SrcLoc +import Util +import Outputable +import FastString +import Bag +import Pair + +import Control.Monad +import Data.List + +{- +************************************************************************ +* * + Overview +* * +************************************************************************ + +Overall plan +~~~~~~~~~~~~ +1. Convert the decls (i.e. data/newtype deriving clauses, + plus standalone deriving) to [EarlyDerivSpec] + +2. Infer the missing contexts for the InferTheta's + +3. Add the derived bindings, generating InstInfos +-} + +-- DerivSpec is purely local to this module +data DerivSpec theta = DS { ds_loc :: SrcSpan + , ds_name :: Name -- DFun name + , ds_tvs :: [TyVar] + , ds_theta :: theta + , ds_cls :: Class + , ds_tys :: [Type] + , ds_tc :: TyCon + , ds_tc_args :: [Type] + , ds_overlap :: Maybe OverlapMode + , ds_newtype :: Bool } + -- This spec implies a dfun declaration of the form + -- df :: forall tvs. theta => C tys + -- The Name is the name for the DFun we'll build + -- The tyvars bind all the variables in the theta + -- For type families, the tycon in + -- in ds_tys is the *family* tycon + -- in ds_tc, ds_tc_args is the *representation* tycon + -- For non-family tycons, both are the same + + -- the theta is either the given and final theta, in standalone deriving, + -- or the not-yet-simplified list of constraints together with their origin + + -- ds_newtype = True <=> Generalised Newtype Deriving (GND) + -- False <=> Vanilla deriving + +{- +Example: + + newtype instance T [a] = MkT (Tree a) deriving( C s ) +==> + axiom T [a] = :RTList a + axiom :RTList a = Tree a + + DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] + , ds_tc = :RTList, ds_tc_args = [a] + , ds_newtype = True } +-} + +type DerivContext = Maybe ThetaType + -- Nothing <=> Vanilla deriving; infer the context of the instance decl + -- Just theta <=> Standalone deriving: context supplied by programmer + +data PredOrigin = PredOrigin PredType CtOrigin +type ThetaOrigin = [PredOrigin] + +mkPredOrigin :: CtOrigin -> PredType -> PredOrigin +mkPredOrigin origin pred = PredOrigin pred origin + +mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin +mkThetaOrigin origin = map (mkPredOrigin origin) + +data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin) + | GivenTheta (DerivSpec ThetaType) + -- InferTheta ds => the context for the instance should be inferred + -- In this case ds_theta is the list of all the constraints + -- needed, such as (Eq [a], Eq a), together with a suitable CtLoc + -- to get good error messages. + -- The inference process is to reduce this to a simpler form (e.g. + -- Eq a) + -- + -- GivenTheta ds => the exact context for the instance is supplied + -- by the programmer; it is ds_theta + +forgetTheta :: EarlyDerivSpec -> DerivSpec () +forgetTheta (InferTheta spec) = spec { ds_theta = () } +forgetTheta (GivenTheta spec) = spec { ds_theta = () } + +earlyDSLoc :: EarlyDerivSpec -> SrcSpan +earlyDSLoc (InferTheta spec) = ds_loc spec +earlyDSLoc (GivenTheta spec) = ds_loc spec + +splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType]) +splitEarlyDerivSpec [] = ([],[]) +splitEarlyDerivSpec (InferTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) +splitEarlyDerivSpec (GivenTheta spec : specs) = + case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) + +pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc +pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, + ds_cls = c, ds_tys = tys, ds_theta = rhs }) + = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] + <+> equals <+> ppr rhs) + +instance Outputable theta => Outputable (DerivSpec theta) where + ppr = pprDerivSpec + +instance Outputable EarlyDerivSpec where + ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)") + ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)") + +instance Outputable PredOrigin where + ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging + +{- +Inferring missing contexts +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving (Eq) + +[NOTE: See end of these comments for what to do with + data (C a, D b) => T a b = ... +] + +We want to come up with an instance declaration of the form + + instance (Ping a, Pong b, ...) => Eq (T a b) where + x == y = ... + +It is pretty easy, albeit tedious, to fill in the code "...". The +trick is to figure out what the context for the instance decl is, +namely @Ping@, @Pong@ and friends. + +Let's call the context reqd for the T instance of class C at types +(a,b, ...) C (T a b). Thus: + + Eq (T a b) = (Ping a, Pong b, ...) + +Now we can get a (recursive) equation from the @data@ decl: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + +Foo and Bar may have explicit instances for @Eq@, in which case we can +just substitute for them. Alternatively, either or both may have +their @Eq@ instances given by @deriving@ clauses, in which case they +form part of the system of equations. + +Now all we need do is simplify and solve the equations, iterating to +find the least fixpoint. Notice that the order of the arguments can +switch around, as here in the recursive calls to T. + +Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. + +We start with: + + Eq (T a b) = {} -- The empty set + +Next iteration: + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b u {} u {} u {} + = Eq a u Ping b + +Next iteration: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b + u (Eq b u Ping a) + u (Eq a u Ping a) + + = Eq a u Ping b u Eq b u Ping a + +The next iteration gives the same result, so this is the fixpoint. We +need to make a canonical form of the RHS to ensure convergence. We do +this by simplifying the RHS to a form in which + + - the classes constrain only tyvars + - the list is sorted by tyvar (major key) and then class (minor key) + - no duplicates, of course + +So, here are the synonyms for the ``equation'' structures: + + +Note [Data decl contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) + +We will need an instance decl like: + + instance (Read a, RealFloat a) => Read (Complex a) where + ... + +The RealFloat in the context is because the read method for Complex is bound +to construct a Complex, and doing that requires that the argument type is +in RealFloat. + +But this ain't true for Show, Eq, Ord, etc, since they don't construct +a Complex; they only take them apart. + +Our approach: identify the offending classes, and add the data type +context to the instance decl. The "offending classes" are + + Read, Enum? + +FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that +pattern matching against a constructor from a data type with a context +gives rise to the constraints for that context -- or at least the thinned +version. So now all classes are "offending". + +Note [Newtype deriving] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + class C a b + instance C [a] Char + newtype T = T Char deriving( C [a] ) + +Notice the free 'a' in the deriving. We have to fill this out to + newtype T = T Char deriving( forall a. C [a] ) + +And then translate it to: + instance C [a] Char => C [a] T where ... + + +Note [Newtype deriving superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See also Trac #1220 for an interesting exchange on newtype +deriving and superclasses.) + +The 'tys' here come from the partial application in the deriving +clause. The last arg is the new instance type. + +We must pass the superclasses; the newtype might be an instance +of them in a different way than the representation type +E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) +Then the Show instance is not done via Coercible; it shows + Foo 3 as "Foo 3" +The Num instance is derived via Coercible, but the Show superclass +dictionary must the Show instance for Foo, *not* the Show dictionary +gotten from the Num dictionary. So we must build a whole new dictionary +not just use the Num one. The instance we want is something like: + instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where + (+) = ((+)@a) + ...etc... +There may be a coercion needed which we get from the tycon for the newtype +when the dict is constructed in TcInstDcls.tcInstDecl2 + + +Note [Unused constructors and deriving clauses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #3221. Consider + data T = T1 | T2 deriving( Show ) +Are T1 and T2 unused? Well, no: the deriving clause expands to mention +both of them. So we gather defs/uses from deriving just like anything else. + +************************************************************************ +* * +\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} +* * +************************************************************************ +-} + +tcDeriving :: [LTyClDecl Name] -- All type constructors + -> [LInstDecl Name] -- All instance declarations + -> [LDerivDecl Name] -- All stand-alone deriving declarations + -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name) +tcDeriving tycl_decls inst_decls deriv_decls + = recoverM (do { g <- getGblEnv + ; return (g, emptyBag, emptyValBindsOut)}) $ + do { -- Fish the "deriving"-related information out of the TcEnv + -- And make the necessary "equations". + is_boot <- tcIsHsBootOrSig + ; traceTc "tcDeriving" (ppr is_boot) + + ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + ; traceTc "tcDeriving 1" (ppr early_specs) + + -- for each type, determine the auxliary declarations that are common + -- to multiple derivations involving that type (e.g. Generic and + -- Generic1 should use the same TcGenGenerics.MetaTyCons) + ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs + + ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs + ; insts1 <- mapM (genInst commonAuxs) given_specs + + -- the stand-alone derived instances (@insts1@) are used when inferring + -- the contexts for "deriving" clauses' instances (@infer_specs@) + ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $ + inferInstanceContexts infer_specs + + ; insts2 <- mapM (genInst commonAuxs) final_specs + + ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) + ; loc <- getSrcSpanM + ; let (binds, newTyCons, famInsts, extraInstances) = + genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + + ; dflags <- getDynFlags + + ; (inst_info, rn_binds, rn_dus) <- + renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds + + ; unless (isEmptyBag inst_info) $ + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds newTyCons famInsts)) + + ; let all_tycons = map ATyCon (bagToList newTyCons) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ + tcExtendLocalFamInstEnv (bagToList famInsts) $ + tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv + ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs) + ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } + where + ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name + -> Bag TyCon -- ^ Empty data constructors + -> Bag FamInst -- ^ Rep type family instances + -> SDoc + ddump_deriving inst_infos extra_binds repMetaTys repFamInsts + = hang (ptext (sLit "Derived instances:")) + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) + $$ ppr extra_binds) + $$ hangP "Generic representation:" ( + hangP "Generated datatypes for meta-information:" + (vcat (map ppr (bagToList repMetaTys))) + $$ hangP "Representation types:" + (vcat (map pprRepTy (bagToList repFamInsts)))) + + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x + +{- +genTypeableTyConReps :: DynFlags -> + [LTyClDecl Name] -> + [LInstDecl Name] -> + TcM (Bag (LHsBind RdrName, LSig RdrName)) +genTypeableTyConReps dflags decls insts = + do tcs1 <- mapM tyConsFromDecl decls + tcs2 <- mapM tyConsFromInst insts + return $ listToBag [ genTypeableTyConRep dflags loc tc + | (loc,tc) <- concat (tcs1 ++ tcs2) ] + where + + tyConFromDataCon (L l n) = do dc <- tcLookupDataCon n + return (do tc <- promoteDataCon_maybe dc + return (l,tc)) + + -- Promoted data constructors from a data declaration, or + -- a data-family instance. + tyConsFromDataRHS = fmap catMaybes + . mapM tyConFromDataCon + . concatMap (con_names . unLoc) + . dd_cons + + -- Tycons from a data-family declaration; not promotable. + tyConFromDataFamDecl FamilyDecl { fdLName = L loc name } = + do tc <- tcLookupTyCon name + return (loc,tc) + + + -- tycons from a type-level declaration + tyConsFromDecl (L _ d) + + -- data or newtype declaration: promoted tycon, tycon, promoted ctrs. + | isDataDecl d = + do let L loc name = tcdLName d + tc <- tcLookupTyCon name + promotedCtrs <- tyConsFromDataRHS (tcdDataDefn d) + let tyCons = (loc,tc) : promotedCtrs + + return (case promotableTyCon_maybe tc of + Nothing -> tyCons + Just kc -> (loc,kc) : tyCons) + + -- data family: just the type constructor; these are not promotable. + | isDataFamilyDecl d = + do res <- tyConFromDataFamDecl (tcdFam d) + return [res] + + -- class: the type constructors of associated data families + | isClassDecl d = + let isData FamilyDecl { fdInfo = DataFamily } = True + isData _ = False + + in mapM tyConFromDataFamDecl (filter isData (map unLoc (tcdATs d))) + + | otherwise = return [] + + + tyConsFromInst (L _ d) = + case d of + ClsInstD ci -> fmap concat + $ mapM (tyConsFromDataRHS . dfid_defn . unLoc) + $ cid_datafam_insts ci + DataFamInstD dfi -> tyConsFromDataRHS (dfid_defn dfi) + TyFamInstD {} -> return [] +-} + +-- Prints the representable type family instance +pprRepTy :: FamInst -> SDoc +pprRepTy fi@(FamInst { fi_tys = lhs }) + = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + equals <+> ppr rhs + where rhs = famInstRHS fi + +-- As of 24 April 2012, this only shares MetaTyCons between derivations of +-- Generic and Generic1; thus the types and logic are quite simple. +type CommonAuxiliary = MetaTyCons +type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type? + +commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff) +commonAuxiliaries = foldM snoc ([], emptyBag) where + snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon}) + | getUnique cls `elem` [genClassKey, gen1ClassKey] = + extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm) + | otherwise = return acc + where extendComAux m -- don't run m if its already in the accumulator + | any ((rep_tycon ==) . fst) cas = return acc + | otherwise = do (ca, new_stuff) <- m + return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff) + +renameDeriv :: Bool + -> [InstInfo RdrName] + -> Bag (LHsBind RdrName, LSig RdrName) + -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) +renameDeriv is_boot inst_infos bagBinds + | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings + -- The inst-info bindings will all be empty, but it's easier to + -- just use rn_inst_info to change the type appropriately + = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos + ; return ( listToBag rn_inst_infos + , emptyValBindsOut, usesOnly (plusFVs fvs)) } + + | otherwise + = discardWarnings $ -- Discard warnings about unused bindings etc + setXOptM Opt_EmptyCase $ -- Derived decls (for empty types) can have + -- case x of {} + setXOptM Opt_ScopedTypeVariables $ -- Derived decls (for newtype-deriving) can + setXOptM Opt_KindSignatures $ -- used ScopedTypeVariables & KindSignatures + do { + -- Bring the extra deriving stuff into scope + -- before renaming the instances themselves + ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds + ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) + ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds + ; let bndrs = collectHsValBinders rn_aux_lhs + ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ; + ; setEnvs envs $ + do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs + ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos + ; return (listToBag rn_inst_infos, rn_aux, + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } + + where + rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) + rn_inst_info + inst_info@(InstInfo { iSpec = inst + , iBinds = InstBindings + { ib_binds = binds + , ib_tyvars = tyvars + , ib_pragmas = sigs + , ib_extensions = exts -- Only for type-checking + , ib_derived = sa } }) + = ASSERT( null sigs ) + bindLocalNamesFV tyvars $ + do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds + ; let binds' = InstBindings { ib_binds = rn_binds + , ib_tyvars = tyvars + , ib_pragmas = [] + , ib_extensions = exts + , ib_derived = sa } + ; return (inst_info { iBinds = binds' }, fvs) } + +{- +Note [Newtype deriving and unused constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (see Trac #1954): + + module Bug(P) where + newtype P a = MkP (IO a) deriving Monad + +If you compile with -fwarn-unused-binds you do not expect the warning +"Defined but not used: data consructor MkP". Yet the newtype deriving +code does not explicitly mention MkP, but it should behave as if you +had written + instance Monad P where + return x = MkP (return x) + ...etc... + +So we want to signal a user of the data constructor 'MkP'. +This is the reason behind the (Maybe Name) part of the return type +of genInst. + +************************************************************************ +* * + From HsSyn to DerivSpec +* * +************************************************************************ + +@makeDerivSpecs@ fishes around to find the info about needed derived instances. +-} + +makeDerivSpecs :: Bool + -> [LTyClDecl Name] + -> [LInstDecl Name] + -> [LDerivDecl Name] + -> TcM [EarlyDerivSpec] +makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls + ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls + ; let eqns = eqns1 ++ eqns2 ++ eqns3 + + ; if is_boot then -- No 'deriving' at all in hs-boot files + do { unless (null eqns) (add_deriv_err (head eqns)) + ; return [] } + else return eqns } + where + add_deriv_err eqn + = setSrcSpan (earlyDSLoc eqn) $ + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) + +------------------------------------------------------------------ +deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] +deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name + , tcdDataDefn = HsDataDefn { dd_derivs = preds } })) + = tcAddDeclCtxt decl $ + do { tc <- tcLookupTyCon tc_name + ; let tvs = tyConTyVars tc + tys = mkTyVarTys tvs + + ; case preds of + Just (L _ preds') -> concatMapM (deriveTyData tvs tc tys) preds' + Nothing -> return [] } + +deriveTyDecl _ = return [] + +------------------------------------------------------------------ +deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec] +deriveInstDecl (L _ (TyFamInstD {})) = return [] +deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst })) + = deriveFamInst fam_inst +deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) + = concatMapM (deriveFamInst . unLoc) fam_insts + +------------------------------------------------------------------ +deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec] +deriveFamInst decl@(DataFamInstDecl + { dfid_tycon = L _ tc_name, dfid_pats = pats + , dfid_defn + = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) }) + = tcAddDataFamInstCtxt decl $ + do { fam_tc <- tcLookupTyCon tc_name + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ + -- kcDataDefn defn: see Note [Finding the LHS patterns] + \ tvs' pats' _ -> + concatMapM (deriveTyData tvs' fam_tc pats') preds } + +deriveFamInst _ = return [] + +{- +Note [Finding the LHS patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind polymorphism is in play, we need to be careful. Here is +Trac #9359: + data Cmp a where + Sup :: Cmp a + V :: a -> Cmp a + + data family CmpInterval (a :: Cmp k) (b :: Cmp k) :: * + data instance CmpInterval (V c) Sup = Starting c deriving( Show ) + +So CmpInterval is kind-polymorphic, but the data instance is not + CmpInterval :: forall k. Cmp k -> Cmp k -> * + data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show ) + +Hence, when deriving the type patterns in deriveFamInst, we must kind +check the RHS (the data constructor 'Starting c') as well as the LHS, +so that we correctly see the instantiation to *. +-} + +------------------------------------------------------------------ +deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] +-- Standalone deriving declarations +-- e.g. deriving instance Show a => Show (T a) +-- Rather like tcLocalInstDecl +deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) + = setSrcSpan loc $ + addErrCtxt (standaloneCtxt deriv_ty) $ + do { traceTc "Standalone deriving decl for" (ppr deriv_ty) + ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty + ; traceTc "Standalone deriving;" $ vcat + [ text "tvs:" <+> ppr tvs + , text "theta:" <+> ppr theta + , text "cls:" <+> ppr cls + , text "tys:" <+> ppr inst_tys ] + -- C.f. TcInstDcls.tcLocalInstDecl1 + ; checkTc (not (null inst_tys)) derivingNullaryErr + + ; let cls_tys = take (length inst_tys - 1) inst_tys + inst_ty = last inst_tys + ; traceTc "Standalone deriving:" $ vcat + [ text "class:" <+> ppr cls + , text "class types:" <+> ppr cls_tys + , text "type:" <+> ppr inst_ty ] + + ; case tcSplitTyConApp_maybe inst_ty of + Just (tc, tc_args) + | className cls == typeableClassName + -> do warn <- woptM Opt_WarnDerivingTypeable + when warn + $ addWarnTc + $ text "Standalone deriving `Typeable` has no effect." + return [] + + | isAlgTyCon tc -- All other classes + -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode) + tvs cls cls_tys tc tc_args (Just theta) + ; return [spec] } + + _ -> -- Complain about functions, primitive types, etc, + failWithTc $ derivingThingErr False cls cls_tys inst_ty $ + ptext (sLit "The last argument of the instance must be a data or newtype application") + } + + +------------------------------------------------------------------ +deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance + -- Can be a data instance, hence [Type] args + -> LHsType Name -- The deriving predicate + -> TcM [EarlyDerivSpec] +-- The deriving clause of a data or newtype declaration +-- I.e. not standalone deriving +deriveTyData tvs tc tc_args (L loc deriv_pred) + = setSrcSpan loc $ -- Use the location of the 'deriving' item + do { (deriv_tvs, cls, cls_tys, cls_arg_kind) + <- tcExtendTyVarEnv tvs $ + tcHsDeriv deriv_pred + -- Deriving preds may (now) mention + -- the type variables for the type constructor, hence tcExtendTyVarenv + -- The "deriv_pred" is a LHsType to take account of the fact that for + -- newtype deriving we allow deriving (forall a. C [a]). + + -- Typeable is special, because Typeable :: forall k. k -> Constraint + -- so the argument kind 'k' is not decomposable by splitKindFunTys + -- as is the case for all other derivable type classes + ; if className cls == typeableClassName + then do warn <- woptM Opt_WarnDerivingTypeable + when warn + $ addWarnTc + $ text "Deriving `Typeable` has no effect." + return [] + else + + do { -- Given data T a b c = ... deriving( C d ), + -- we want to drop type variables from T so that (C d (T a)) is well-kinded + let (arg_kinds, _) = splitKindFunTys cls_arg_kind + n_args_to_drop = length arg_kinds + n_args_to_keep = tyConArity tc - n_args_to_drop + args_to_drop = drop n_args_to_keep tc_args + tc_args_to_keep = take n_args_to_keep tc_args + inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) + dropped_tvs = tyVarsOfTypes args_to_drop + + -- Match up the kinds, and apply the resulting kind substitution + -- to the types. See Note [Unify kinds in deriving] + -- We are assuming the tycon tyvars and the class tyvars are distinct + mb_match = tcUnifyTy inst_ty_kind cls_arg_kind + Just kind_subst = mb_match + (univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $ + mkVarSet deriv_tvs `unionVarSet` + tyVarsOfTypes tc_args_to_keep + univ_kvs' = filter (`notElemTvSubst` kind_subst) univ_kvs + (subst', univ_tvs') = mapAccumL substTyVarBndr kind_subst univ_tvs + final_tc_args = substTys subst' tc_args_to_keep + final_cls_tys = substTys subst' cls_tys + + ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred + , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) + , ppr n_args_to_keep, ppr n_args_to_drop + , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match + , ppr final_tc_args, ppr final_cls_tys ]) + + -- Check that the result really is well-kinded + ; checkTc (n_args_to_keep >= 0 && isJust mb_match) + (derivingKindErr tc cls cls_tys cls_arg_kind) + + ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ]) + + ; checkTc (allDistinctTyVars args_to_drop && -- (a) and (b) + not (any (`elemVarSet` dropped_tvs) univ_tvs)) -- (c) + (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args)) + -- Check that + -- (a) The args to drop are all type variables; eg reject: + -- data instance T a Int = .... deriving( Monad ) + -- (b) The args to drop are all *distinct* type variables; eg reject: + -- class C (a :: * -> * -> *) where ... + -- data instance T a a = ... deriving( C ) + -- (c) The type class args, or remaining tycon args, + -- do not mention any of the dropped type variables + -- newtype T a s = ... deriving( ST s ) + -- newtype K a a = ... deriving( Monad ) + + ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') + cls final_cls_tys tc final_tc_args Nothing + ; return [spec] } } + + +{- +Note [Unify kinds in deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (Trac #8534) + data T a b = MkT a deriving( Functor ) + -- where Functor :: (*->*) -> Constraint + +So T :: forall k. * -> k -> *. We want to get + instance Functor (T * (a:*)) where ... +Notice the '*' argument to T. + +Moreover, as well as instantiating T's kind arguments, we may need to instantiate +C's kind args. Consider (Trac #8865): + newtype T a b = MkT (Either a b) deriving( Category ) +where + Category :: forall k. (k -> k -> *) -> Constraint +We need to generate the instance + instance Category * (Either a) where ... +Notice the '*' argument to Category. + +So we need to + * drop arguments from (T a b) to match the number of + arrows in the (last argument of the) class; + * and then *unify* kind of the remaining type against the + expected kind, to figure out how to instantiate C's and T's + kind arguments. + +In the two examples, + * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) + i.e. (k -> *) ~ (* -> *) to find k:=*. + yielding k:=* + + * we unify kind-of( Either ) ~ kind-of( Category ) + i.e. (* -> * -> *) ~ (k -> k -> k) + yielding k:=* + +Now we get a kind substitution. We then need to: + + 1. Remove the substituted-out kind variables from the quantified kind vars + + 2. Apply the substitution to the kinds of quantified *type* vars + (and extend the substitution to reflect this change) + + 3. Apply that extended substitution to the non-dropped args (types and + kinds) of the type and class + +Forgetting step (2) caused Trac #8893: + data V a = V [a] deriving Functor + data P (x::k->*) (a:k) = P (x a) deriving Functor + data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor + +When deriving Functor for P, we unify k to *, but we then want +an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) +and similarly for C. Notice the modified kind of x, both at binding +and occurrence sites. +-} + +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] + -> Class -> [Type] + -> TyCon -> [Type] + -> DerivContext -- Just => context supplied (standalone deriving) + -- Nothing => context inferred (deriving on data decl) + -> TcRn EarlyDerivSpec +-- Make the EarlyDerivSpec for an instance +-- forall tvs. theta => cls (tys ++ [ty]) +-- where the 'theta' is optional (that's the Maybe part) +-- Assumes that this declaration is well-kinded + +mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta + = do { -- Find the instance of a data family + -- Note [Looking up family instances for deriving] + fam_envs <- tcGetFamInstEnvs + ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args + + -- If it's still a data family, the lookup failed; i.e no instance exists + ; when (isDataFamilyTyCon rep_tc) + (bale_out (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tc_args))) + + -- For standalone deriving (mtheta /= Nothing), + -- check that all the data constructors are in scope. + ; rdr_env <- getGlobalRdrEnv + ; let data_con_names = map dataConName (tyConDataCons rep_tc) + hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && + (isAbstractTyCon rep_tc || + any not_in_scope data_con_names) + not_in_scope dc = null (lookupGRE_Name rdr_env dc) + + -- Make a Qual RdrName that will do for each DataCon + -- so we can report it as used (Trac #7969) + data_con_rdrs = [ mkRdrQual (is_as (is_decl imp_spec)) occ + | dc_name <- data_con_names + , let occ = nameOccName dc_name + gres = lookupGRE_Name rdr_env dc_name + , not (null gres) + , Imported (imp_spec:_) <- [gre_prov (head gres)] ] + + ; addUsedRdrNames data_con_rdrs + ; unless (isNothing mtheta || not hidden_data_cons) + (bale_out (derivingHiddenErr tycon)) + + ; dflags <- getDynFlags + ; if isDataTyCon rep_tc then + mkDataTypeEqn dflags overlap_mode tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta + else + mkNewTypeEqn dflags overlap_mode tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta } + where + bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) + +{- +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declarations. + +Note [Deriving, type families, and partial applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are no type families, it's quite easy: + + newtype S a = MkS [a] + -- :CoS :: S ~ [] -- Eta-reduced + + instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + +When type familes are involved it's trickier: + + data family T a b + newtype instance T Int a = MkT [a] deriving( Eq, Monad ) + -- :RT is the representation type for (T Int a) + -- :Co:RT :: :RT ~ [] -- Eta-reduced! + -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! + + instance Eq [a] => Eq (T Int a) -- easy by coercion + -- d1 :: Eq [a] + -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) + + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + -- d1 :: Monad [] + -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) + +Note the need for the eta-reduced rule axioms. After all, we can +write it out + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + return x = MkT [x] + ... etc ... + +See Note [Eta reduction for data family axioms] in TcInstDcls. + + +************************************************************************ +* * + Deriving data types +* * +************************************************************************ +-} + +mkDataTypeEqn :: DynFlags + -> Maybe OverlapMode + -> [Var] -- Universally quantified type variables in the instance + -> Class -- Class for which we need to derive an instance + -> [Type] -- Other parameters to the class except the last + -> TyCon -- Type constructor for which the instance is requested + -- (last parameter to the type class) + -> [Type] -- Parameters to the type constructor + -> TyCon -- rep of the above (for type families) + -> [Type] -- rep of the above + -> DerivContext -- Context of the instance, for standalone deriving + -> TcRn EarlyDerivSpec -- Return 'Nothing' if error + +mkDataTypeEqn dflags overlap_mode tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta + = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of + -- NB: pass the *representation* tycon to checkSideConditions + NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg) + DerivableClassError msg -> bale_out msg + CanDerive -> go_for_it + DerivableViaInstance -> go_for_it + where + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta + bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) + +mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class + -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext + -> TcM EarlyDerivSpec +mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta + = do loc <- getSrcSpanM + dfun_name <- new_dfun_name cls tycon + case mtheta of + Nothing -> do --Infer context + inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args + return $ InferTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tc, ds_tc_args = rep_tc_args + , ds_theta = inferred_constraints + , ds_overlap = overlap_mode + , ds_newtype = False } + Just theta -> do -- Specified context + return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tc, ds_tc_args = rep_tc_args + , ds_theta = theta + , ds_overlap = overlap_mode + , ds_newtype = False } + where + inst_tys = [mkTyConApp tycon tc_args] + +---------------------- + +inferConstraints :: Class -> [TcType] + -> TyCon -> [TcType] + -> TcM ThetaOrigin +-- Generate a sufficiently large set of constraints that typechecking the +-- generated method definitions should succeed. This set will be simplified +-- before being used in the instance declaration +inferConstraints cls inst_tys rep_tc rep_tc_args + | cls `hasKey` genClassKey -- Generic constraints are easy + = return [] + + | cls `hasKey` gen1ClassKey -- Gen1 needs Functor + = ASSERT(length rep_tc_tvs > 0) -- See Note [Getting base classes] + do { functorClass <- tcLookupClass functorClassName + ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) } + + | otherwise -- The others are a bit more complicated + = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) + do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints]) + ; return (stupid_constraints ++ extra_constraints + ++ sc_constraints + ++ arg_constraints) } + where + arg_constraints = con_arg_constraints cls get_std_constrained_tys + + -- Constraints arising from the arguments of each constructor + con_arg_constraints cls' get_constrained_tys + = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty]) + | data_con <- tyConDataCons rep_tc + , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con ) + zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys + dataConInstOrigArgTys data_con all_rep_tc_args + , not (isUnLiftedType arg_ty) + , inner_ty <- get_constrained_tys arg_ty ] + + -- No constraints for unlifted types + -- See Note [Deriving and unboxed types] + + -- For functor-like classes, two things are different + -- (a) We recurse over argument types to generate constraints + -- See Functor examples in TcGenDeriv + -- (b) The rep_tc_args will be one short + is_functor_like = getUnique cls `elem` functorLikeClassKeys + || onlyOneAndTypeConstr inst_tys + onlyOneAndTypeConstr [inst_ty] = + typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind + onlyOneAndTypeConstr _ = False + + get_std_constrained_tys :: Type -> [Type] + get_std_constrained_tys ty + | is_functor_like = deepSubtypesContaining last_tv ty + | otherwise = [ty] + + rep_tc_tvs = tyConTyVars rep_tc + last_tv = last rep_tc_tvs + all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like + = rep_tc_args ++ [mkTyVarTy last_tv] + | otherwise = rep_tc_args + + -- Constraints arising from superclasses + -- See Note [Superclasses of derived instance] + sc_constraints = mkThetaOrigin DerivOrigin $ + substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) (classSCTheta cls) + + -- Stupid constraints + stupid_constraints = mkThetaOrigin DerivOrigin $ + substTheta subst (tyConStupidTheta rep_tc) + subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args + + -- Extra Data constraints + -- The Data class (only) requires that for + -- instance (...) => Data (T t1 t2) + -- IF t1:*, t2:* + -- THEN (Data t1, Data t2) are among the (...) constraints + -- Reason: when the IF holds, we generate a method + -- dataCast2 f = gcast2 f + -- and we need the Data constraints to typecheck the method + extra_constraints + | cls `hasKey` dataClassKey + , all (isLiftedTypeKind . typeKind) rep_tc_args + = [mkPredOrigin DerivOrigin (mkClassPred cls [ty]) | ty <- rep_tc_args] + | otherwise + = [] + +{- +Note [Getting base classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functor and Typeable are defined in package 'base', and that is not available +when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in +ghc-prim does not use Functor or Typeable implicitly via these lookups. + +Note [Deriving and unboxed types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have some special hacks to support things like + data T = MkT Int# deriving ( Show ) + +Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int +(which we know how to show). It's a bit ad hoc. + +Note [Deriving any class] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Classic uses of a deriving clause, or a standalone-deriving declaration, are +for: + * a built-in class like Eq or Show, for which GHC knows how to generate + the instance code + * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving + +The DeriveAnyClass extension adds a third way to derive instances, based on +empty instance declarations. + +The canonical use case is in combination with GHC.Generics and default method +signatures. These allow us have have instance declarations be empty, but still +useful, e.g. + + data T a = ...blah..blah... deriving( Generic ) + instance C a => C (T a) -- No 'where' clause + +where C is some "random" user-defined class. + +This boilerplate code can be replaced by the more compact + + data T a = ...blah..blah... deriving( Generic, C ) + +if DeriveAnyClass is enabled. + +This is not restricted to Generics; any class can be derived, simply giving +rise to an empty instance. + +Unfortunately, it is not clear how to determine the context (in case of +standard deriving; in standalone deriving, the user provides the context). +GHC uses the same heuristic for figuring out the class context that it uses for +Eq in the case of *-kinded classes, and for Functor in the case of +* -> *-kinded classes. That may not be optimal or even wrong. But in such +cases, standalone deriving can still be used. +-} + +------------------------------------------------------------------ +-- Check side conditions that dis-allow derivability for particular classes +-- This is *apart* from the newtype-deriving mechanism +-- +-- Here we get the representation tycon in case of family instances as it has +-- the data constructors - but we need to be careful to fall back to the +-- family tycon (with indexes) in error messages. + +data DerivStatus = CanDerive + | DerivableClassError SDoc -- Standard class, but can't do it + | DerivableViaInstance -- See Note [Deriving any class] + | NonDerivableClass SDoc -- Non-standard class + +checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] + -> TyCon -> [Type] -- tycon and its parameters + -> DerivStatus +checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args + | Just cond <- sideConditions mtheta cls + = case (cond (dflags, rep_tc, rep_tc_args)) of + NotValid err -> DerivableClassError err -- Class-specific error + IsValid | null cls_tys -> CanDerive -- All derivable classes are unary, so + -- cls_tys (the type args other than last) + -- should be null + | otherwise -> DerivableClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s ) + | otherwise = maybe DerivableViaInstance NonDerivableClass + (canDeriveAnyClass dflags rep_tc cls) + +classArgsErr :: Class -> [Type] -> SDoc +classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") + +nonStdErr :: Class -> SDoc +nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class") + +sideConditions :: DerivContext -> Class -> Maybe Condition +sideConditions mtheta cls + | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) + | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond` + cond_std `andCond` + cond_args cls) + | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond` + cond_vanilla `andCond` + cond_functorOK True) + | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond` + cond_vanilla `andCond` + cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types + | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond` + cond_vanilla `andCond` + cond_functorOK False) + | cls_key == genClassKey = Just (checkFlag Opt_DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_RepresentableOk) + | cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_Representable1Ok) + | otherwise = Nothing + where + cls_key = getUnique cls + cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one, + -- and monotype arguments + cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but + -- allow no data cons or polytype arguments + +type Condition = (DynFlags, TyCon, [Type]) -> Validity + -- first Bool is whether or not we are allowed to derive Data and Typeable + -- second Bool is whether or not we are allowed to derive Functor + -- TyCon is the *representation* tycon if the data type is an indexed one + -- [Type] are the type arguments to the (representation) TyCon + -- Nothing => OK + +orCond :: Condition -> Condition -> Condition +orCond c1 c2 tc + = case (c1 tc, c2 tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid (x $$ ptext (sLit " or") $$ y) + -- Both fail + +andCond :: Condition -> Condition -> Condition +andCond c1 c2 tc = c1 tc `andValid` c2 tc + +cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; + -- if standalone, we just say "yes, go for it" + -> Bool -- True <=> permissive: allow higher rank + -- args and no data constructors + -> Condition +cond_stdOK (Just _) _ _ + = IsValid -- Don't check these conservative conditions for + -- standalone deriving; just generate the code + -- and let the typechecker handle the result +cond_stdOK Nothing permissive (_, rep_tc, _) + | null data_cons + , not permissive = NotValid (no_cons_why rep_tc $$ suggestion) + | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) + | otherwise = IsValid + where + suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") + data_cons = tyConDataCons rep_tc + con_whys = getInvalids (map check_con data_cons) + + check_con :: DataCon -> Validity + check_con con + | not (isVanillaDataCon con) + = NotValid (badCon con (ptext (sLit "has existentials or constraints in its type"))) + | not (permissive || all isTauTy (dataConOrigArgTys con)) + = NotValid (badCon con (ptext (sLit "has a higher-rank type"))) + | otherwise + = IsValid + +no_cons_why :: TyCon -> SDoc +no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> + ptext (sLit "must have at least one data constructor") + +cond_RepresentableOk :: Condition +cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args + +cond_Representable1Ok :: Condition +cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args + +cond_enumOrProduct :: Class -> Condition +cond_enumOrProduct cls = cond_isEnumeration `orCond` + (cond_isProduct `andCond` cond_args cls) + +cond_args :: Class -> Condition +-- For some classes (eg Eq, Ord) we allow unlifted arg types +-- by generating specialised code. For others (eg Data) we don't. +cond_args cls (_, tc, _) + = case bad_args of + [] -> IsValid + (ty:_) -> NotValid (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) + 2 (ptext (sLit "for type") <+> quotes (ppr ty))) + where + bad_args = [ arg_ty | con <- tyConDataCons tc + , arg_ty <- dataConOrigArgTys con + , isUnLiftedType arg_ty + , not (ok_ty arg_ty) ] + + cls_key = classKey cls + ok_ty arg_ty + | cls_key == eqClassKey = check_in arg_ty ordOpTbl + | cls_key == ordClassKey = check_in arg_ty ordOpTbl + | cls_key == showClassKey = check_in arg_ty boxConTbl + | otherwise = False -- Read, Ix etc + + check_in :: Type -> [(Type,a)] -> Bool + check_in arg_ty tbl = any (eqType arg_ty . fst) tbl + + +cond_isEnumeration :: Condition +cond_isEnumeration (_, rep_tc, _) + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = sep [ quotes (pprSourceTyCon rep_tc) <+> + ptext (sLit "must be an enumeration type") + , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] + -- See Note [Enumeration types] in TyCon + +cond_isProduct :: Condition +cond_isProduct (_, rep_tc, _) + | isProductTyCon rep_tc = IsValid + | otherwise = NotValid why + where + why = quotes (pprSourceTyCon rep_tc) <+> + ptext (sLit "must have precisely one constructor") + +functorLikeClassKeys :: [Unique] +functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] + +cond_functorOK :: Bool -> Condition +-- OK for Functor/Foldable/Traversable class +-- Currently: (a) at least one argument +-- (b) don't use argument contravariantly +-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) +-- (d) optionally: don't use function types +-- (e) no "stupid context" on data type +cond_functorOK allowFunctions (_, rep_tc, _) + | null tc_tvs + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters")) + + | not (null bad_stupid_theta) + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) + + | otherwise + = allValid (map check_con data_cons) + where + tc_tvs = tyConTyVars rep_tc + Just (_, last_tv) = snocView tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` tyVarsOfType pred + + data_cons = tyConDataCons rep_tc + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) + + check_universal :: DataCon -> Validity + check_universal con + | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) + , tv `elem` dataConUnivTyVars con + , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con)) + = IsValid -- See Note [Check that the type variable is truly universal] + | otherwise + = NotValid (badCon con existential) + + ft_check :: DataCon -> FFoldType Validity + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid (badCon con functions) + , ft_tup = \_ xs -> allValid xs + , ft_ty_app = \_ x -> x + , ft_bad_app = NotValid (badCon con wrong_arg) + , ft_forall = \_ x -> x } + + existential = ptext (sLit "must be truly polymorphic in the last argument of the data type") + covariant = ptext (sLit "must not use the type variable in a function argument") + functions = ptext (sLit "must not contain function types") + wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") + +checkFlag :: ExtensionFlag -> Condition +checkFlag flag (dflags, _, _) + | xopt flag dflags = IsValid + | otherwise = NotValid why + where + why = ptext (sLit "You need ") <> text flag_str + <+> ptext (sLit "to derive an instance for this class") + flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of + [s] -> s + other -> pprPanic "checkFlag" (ppr other) + +std_class_via_coercible :: Class -> Bool +-- These standard classes can be derived for a newtype +-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_coercible clas + = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] + -- Not Read/Show because they respect the type + -- Not Enum, because newtypes are never in Enum + + +non_coercible_class :: Class -> Bool +-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by Coercible, +-- even with -XGeneralizedNewtypeDeriving +-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived +-- instance behave differently if there's a non-lawful Applicative out there. +-- Besides, with roles, Coercible-deriving Traversable is ill-roled. +non_coercible_class cls + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey, gen1ClassKey, typeableClassKey + , traversableClassKey ]) + +new_dfun_name :: Class -> TyCon -> TcM Name +new_dfun_name clas tycon -- Just a simple wrapper + = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon + ; newDFunName clas [mkTyConApp tycon []] loc } + -- The type passed to newDFunName is only used to generate + -- a suitable string; hence the empty type arg list + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + +{- +Note [Check that the type variable is truly universal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Functor, Foldable, Traversable, we must check that the *last argument* +of the type constructor is used truly universally quantified. Example + + data T a b where + T1 :: a -> b -> T a b -- Fine! Vanilla H-98 + T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' + T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic + T4 :: Ord b => b -> T a b -- No! 'b' is constrained + T5 :: b -> T b b -- No! 'b' is constrained + T6 :: T a (b,b) -- No! 'b' is constrained + +Notice that only the first of these constructors is vanilla H-98. We only +need to take care about the last argument (b in this case). See Trac #8678. +Eg. for T1-T3 we can write + + fmap f (T1 a b) = T1 a (f b) + fmap f (T2 b c) = T2 (f b) c + fmap f (T3 x) = T3 (f x) + + +Note [Superclasses of derived instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a derived instance decl needs the superclasses of the derived +class too. So if we have + data T a = ...deriving( Ord ) +then the initial context for Ord (T a) should include Eq (T a). Often this is +redundant; we'll also generate an Ord constraint for each constructor argument, +and that will probably generate enough constraints to make the Eq (T a) constraint +be satisfied too. But not always; consider: + + data S a = S + instance Eq (S a) + instance Ord (S a) + + data T a = MkT (S a) deriving( Ord ) + instance Num a => Eq (T a) + +The derived instance for (Ord (T a)) must have a (Num a) constraint! +Similarly consider: + data T a = MkT deriving( Data, Typeable ) +Here there *is* no argument field, but we must nevertheless generate +a context for the Data instances: + instance Typable a => Data (T a) where ... + + +************************************************************************ +* * + Deriving newtypes +* * +************************************************************************ +-} + +mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class + -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] + -> DerivContext + -> TcRn EarlyDerivSpec +mkNewTypeEqn dflags overlap_mode tvs + cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta +-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... + | ASSERT( length cls_tys + 1 == classArity cls ) + might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass) + || std_class_via_coercible cls) + = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds) + dfun_name <- new_dfun_name cls tycon + loc <- getSrcSpanM + case mtheta of + Just theta -> return $ GivenTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_theta = theta + , ds_overlap = overlap_mode + , ds_newtype = True } + Nothing -> return $ InferTheta $ DS + { ds_loc = loc + , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs + , ds_cls = cls, ds_tys = inst_tys + , ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_theta = all_preds + , ds_overlap = overlap_mode + , ds_newtype = True } + | otherwise + = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of + -- Error with standard class + DerivableClassError msg + | might_derive_via_coercible -> bale_out (msg $$ suggest_nd) + | otherwise -> bale_out msg + -- Must use newtype deriving or DeriveAnyClass + NonDerivableClass _msg + -- Too hard, even with newtype deriving + | newtype_deriving -> bale_out cant_derive_err + -- Try newtype deriving! + | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd) + | otherwise -> bale_out non_std + -- CanDerive/DerivableViaInstance + _ -> do when (newtype_deriving && deriveAnyClass) $ + addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled") + , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ]) + go_for_it + where + newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags + deriveAnyClass = xopt Opt_DeriveAnyClass dflags + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args + rep_tycon rep_tc_args mtheta + bale_out = bale_out' newtype_deriving + bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty + + non_std = nonStdErr cls + suggest_nd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension") + + -- Here is the plan for newtype derivings. We see + -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) + -- where t is a type, + -- ak+1...an is a suffix of a1..an, and are all tyars + -- ak+1...an do not occur free in t, nor in the s1..sm + -- (C s1 ... sm) is a *partial applications* of class C + -- with the last parameter missing + -- (T a1 .. ak) matches the kind of C's last argument + -- (and hence so does t) + -- The latter kind-check has been done by deriveTyData already, + -- and tc_args are already trimmed + -- + -- We generate the instance + -- instance forall ({a1..ak} u fvs(s1..sm)). + -- C s1 .. sm t => C s1 .. sm (T a1...ak) + -- where T a1...ap is the partial application of + -- the LHS of the correct kind and p >= k + -- + -- NB: the variables below are: + -- tc_tvs = [a1, ..., an] + -- tyvars_to_keep = [a1, ..., ak] + -- rep_ty = t ak .. an + -- deriv_tvs = fvs(s1..sm) \ tc_tvs + -- tys = [s1, ..., sm] + -- rep_fn' = t + -- + -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + -- We generate the instance + -- instance Monad (ST s) => Monad (T s) where + + nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon)) + -- For newtype T a b = MkT (S a a b), the TyCon machinery already + -- eta-reduces the representation type, so we know that + -- T a ~ S a a + -- That's convenient here, because we may have to apply + -- it to fewer than its original complement of arguments + + -- Note [Newtype representation] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Need newTyConRhs (*not* a recursive representation finder) + -- to get the representation type. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args + rep_tys = cls_tys ++ [rep_inst_ty] + rep_pred = mkClassPred cls rep_tys + rep_pred_o = mkPredOrigin DerivOrigin rep_pred + -- rep_pred is the representation dictionary, from where + -- we are gong to get all the methods for the newtype + -- dictionary + + + -- Next we figure out what superclass dictionaries to use + -- See Note [Newtype deriving superclasses] above + + cls_tyvars = classTyVars cls + dfun_tvs = tyVarsOfTypes inst_tys + inst_ty = mkTyConApp tycon tc_args + inst_tys = cls_tys ++ [inst_ty] + sc_theta = + mkThetaOrigin DerivOrigin $ + substTheta (zipOpenTvSubst cls_tyvars inst_tys) (classSCTheta cls) + + + -- Next we collect Coercible constaints between + -- the Class method types, instantiated with the representation and the + -- newtype type; precisely the constraints required for the + -- calls to coercible that we are going to generate. + coercible_constraints = + [ let (Pair t1 t2) = mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty meth + in mkPredOrigin (DerivOriginCoerce meth t1 t2) (mkCoerciblePred t1 t2) + | meth <- classMethods cls ] + + -- If there are no tyvars, there's no need + -- to abstract over the dictionaries we need + -- Example: newtype T = MkT Int deriving( C ) + -- We get the derived instance + -- instance C T + -- rather than + -- instance C Int => C T + all_preds = rep_pred_o : coercible_constraints ++ sc_theta -- NB: rep_pred comes first + + ------------------------------------------------------------------- + -- Figuring out whether we can only do this newtype-deriving thing + + -- See Note [Determining whether newtype-deriving is appropriate] + might_derive_via_coercible + = not (non_coercible_class cls) + && eta_ok + && ats_ok +-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] + + -- Check that eta reduction is OK + eta_ok = nt_eta_arity <= length rep_tc_args + -- The newtype can be eta-reduced to match the number + -- of type argument actually supplied + -- newtype T a b = MkT (S [a] b) deriving( Monad ) + -- Here the 'b' must be the same in the rep type (S [a] b) + -- And the [a] must not mention 'b'. That's all handled + -- by nt_eta_rity. + + ats_ok = null (classATs cls) + -- No associated types for the class, because we don't + -- currently generate type 'instance' decls; and cannot do + -- so for 'data' instance decls + + cant_derive_err + = vcat [ ppUnless eta_ok eta_msg + , ppUnless ats_ok ats_msg ] + eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") + ats_msg = ptext (sLit "the class has associated types") + +{- +Note [Recursive newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype deriving works fine, even if the newtype is recursive. +e.g. newtype S1 = S1 [T1 ()] + newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) +Remember, too, that type families are currently (conservatively) given +a recursive flag, so this also allows newtype deriving to work +for type famillies. + +We used to exclude recursive types, because we had a rather simple +minded way of generating the instance decl: + newtype A = MkA [A] + instance Eq [A] => Eq A -- Makes typechecker loop! +But now we require a simple context, so it's ok. + +Note [Determining whether newtype-deriving is appropriate] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see + newtype NT = MkNT Foo + deriving C +we have to decide how to perform the deriving. Do we do newtype deriving, +or do we do normal deriving? In general, we prefer to do newtype deriving +wherever possible. So, we try newtype deriving unless there's a glaring +reason not to. + +Note that newtype deriving might fail, even after we commit to it. This +is because the derived instance uses `coerce`, which must satisfy its +`Coercible` constraint. This is different than other deriving scenarios, +where we're sure that the resulting instance will type-check. + +************************************************************************ +* * +\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations} +* * +************************************************************************ + +A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv) +terms, which is the final correct RHS for the corresponding original +equation. +\begin{itemize} +\item +Each (k,TyVarTy tv) in a solution constrains only a type +variable, tv. + +\item +The (k,TyVarTy tv) pairs in a solution are canonically +ordered by sorting on type varible, tv, (major key) and then class, k, +(minor key) +\end{itemize} +-} + +inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType] + +inferInstanceContexts [] = return [] + +inferInstanceContexts infer_specs + = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs) + ; iterate_deriv 1 initial_solutions } + where + ------------------------------------------------------------------ + -- The initial solutions for the equations claim that each + -- instance has an empty context; this solution is certainly + -- in canonical form. + initial_solutions :: [ThetaType] + initial_solutions = [ [] | _ <- infer_specs ] + + ------------------------------------------------------------------ + -- iterate_deriv calculates the next batch of solutions, + -- compares it with the current one; finishes if they are the + -- same, otherwise recurses with the new solutions. + -- It fails if any iteration fails + iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] + iterate_deriv n current_solns + | n > 20 -- Looks as if we are in an infinite loop + -- This can happen if we have -XUndecidableInstances + -- (See TcSimplify.tcSimplifyDeriv.) + = pprPanic "solveDerivEqns: probable loop" + (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) + | otherwise + = do { -- Extend the inst info from the explicit instance decls + -- with the current set of solutions, and simplify each RHS + inst_specs <- zipWithM newDerivClsInst current_solns infer_specs + ; new_solns <- checkNoErrs $ + extendLocalInstEnv inst_specs $ + mapM gen_soln infer_specs + + ; if (current_solns `eqSolution` new_solns) then + return [ spec { ds_theta = soln } + | (spec, soln) <- zip infer_specs current_solns ] + else + iterate_deriv (n+1) new_solns } + + eqSolution = eqListBy (eqListBy eqType) + + ------------------------------------------------------------------ + gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType + gen_soln (DS { ds_loc = loc, ds_tvs = tyvars + , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) + = setSrcSpan loc $ + addErrCtxt (derivInstCtxt the_pred) $ + do { theta <- simplifyDeriv the_pred tyvars deriv_rhs + -- checkValidInstance tyvars theta clas inst_tys + -- Not necessary; see Note [Exotic derived instance contexts] + + ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) + -- Claim: the result instance declaration is guaranteed valid + -- Hence no need to call: + -- checkValidInstance tyvars theta clas inst_tys + ; return (sortBy cmpType theta) } -- Canonicalise before returning the solution + where + the_pred = mkClassPred clas inst_tys + +------------------------------------------------------------------ +newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst +newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) + = newClsInst overlap_mode dfun_name tvs theta clas tys + +extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in TcInstDcls +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + +{- +*********************************************************************************** +* * +* Simplify derived constraints +* * +*********************************************************************************** +-} + +simplifyDeriv :: PredType + -> [TyVar] + -> ThetaOrigin -- Wanted + -> TcM ThetaType -- Needed +-- Given instance (wanted) => C inst_ty +-- Simplify 'wanted' as much as possibles +-- Fail if not possible +simplifyDeriv pred tvs theta + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + -- The constraint solving machinery + -- expects *TcTyVars* not TyVars. + -- We use *non-overlappable* (vanilla) skolems + -- See Note [Overlap and deriving] + + ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + skol_set = mkVarSet tvs_skols + doc = ptext (sLit "deriving") <+> parens (ppr pred) + + ; wanted <- mapM (\(PredOrigin t o) -> newSimpleWanted o (substTy skol_subst t)) theta + + ; traceTc "simplifyDeriv" $ + vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] + ; (residual_wanted, _ev_binds1) + <- solveWantedsTcM (mkSimpleWC wanted) + -- Post: residual_wanted are already zonked + + ; let (good, bad) = partitionBagWith get_good (wc_simple residual_wanted) + -- See Note [Exotic derived instance contexts] + get_good :: Ct -> Either PredType Ct + get_good ct | validDerivPred skol_set p + , isWantedCt ct = Left p + -- NB: residual_wanted may contain unsolved + -- Derived and we stick them into the bad set + -- so that reportUnsolved may decide what to do with them + | otherwise = Right ct + where p = ctPred ct + + -- If we are deferring type errors, simply ignore any insoluble + -- constraints. They'll come up again when we typecheck the + -- generated instance declaration + ; defer <- goptM Opt_DeferTypeErrors + ; unless defer (reportAllUnsolved (residual_wanted { wc_simple = bad })) + + ; let min_theta = mkMinimalBySCs (bagToList good) + ; return (substTheta subst_skol min_theta) } + +{- +Note [Overlap and deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider some overlapping instances: + data Show a => Show [a] where .. + data Show [Char] where ... + +Now a data type with deriving: + data T a = MkT [a] deriving( Show ) + +We want to get the derived instance + instance Show [a] => Show (T a) where... +and NOT + instance Show a => Show (T a) where... +so that the (Show (T Char)) instance does the Right Thing + +It's very like the situation when we're inferring the type +of a function + f x = show [x] +and we want to infer + f :: Show [a] => a -> String + +BOTTOM LINE: use vanilla, non-overlappable skolems when inferring + the context for the derived instance. + Hence tcInstSkolTyVars not tcInstSuperSkolTyVars + +Note [Exotic derived instance contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a 'derived' instance declaration, we *infer* the context. It's a +bit unclear what rules we should apply for this; the Haskell report is +silent. Obviously, constraints like (Eq a) are fine, but what about + data T f a = MkT (f a) deriving( Eq ) +where we'd get an Eq (f a) constraint. That's probably fine too. + +One could go further: consider + data T a b c = MkT (Foo a b c) deriving( Eq ) + instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) + +Notice that this instance (just) satisfies the Paterson termination +conditions. Then we *could* derive an instance decl like this: + + instance (C Int a, Eq b, Eq c) => Eq (T a b c) +even though there is no instance for (C Int a), because there just +*might* be an instance for, say, (C Int Bool) at a site where we +need the equality instance for T's. + +However, this seems pretty exotic, and it's quite tricky to allow +this, and yet give sensible error messages in the (much more common) +case where we really want that instance decl for C. + +So for now we simply require that the derived instance context +should have only type-variable constraints. + +Here is another example: + data Fix f = In (f (Fix f)) deriving( Eq ) +Here, if we are prepared to allow -XUndecidableInstances we +could derive the instance + instance Eq (f (Fix f)) => Eq (Fix f) +but this is so delicate that I don't think it should happen inside +'deriving'. If you want this, write it yourself! + +NB: if you want to lift this condition, make sure you still meet the +termination conditions! If not, the deriving mechanism generates +larger and larger constraints. Example: + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate + instance (Show (Succ a), Show a) => Show (Seq a) +and then + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +The bottom line +~~~~~~~~~~~~~~~ +Allow constraints which consist only of type variables, with no repeats. + + +************************************************************************ +* * +\subsection[TcDeriv-normal-binds]{Bindings for the various classes} +* * +************************************************************************ + +After all the trouble to figure out the required context for the +derived instance declarations, all that's left is to chug along to +produce them. They will then be shoved into @tcInstDecls2@, which +will do all its usual business. + +There are lots of possibilities for code to generate. Here are +various general remarks. + +PRINCIPLES: +\begin{itemize} +\item +We want derived instances of @Eq@ and @Ord@ (both v common) to be +``you-couldn't-do-better-by-hand'' efficient. + +\item +Deriving @Show@---also pretty common--- should also be reasonable good code. + +\item +Deriving for the other classes isn't that common or that big a deal. +\end{itemize} + +PRAGMATICS: + +\begin{itemize} +\item +Deriving @Ord@ is done mostly with the 1.3 @compare@ method. + +\item +Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. + +\item +We {\em normally} generate code only for the non-defaulted methods; +there are some exceptions for @Eq@ and (especially) @Ord@... + +\item +Sometimes we use a @_con2tag_@ function, which returns a data +constructor's numeric (@Int#@) tag. These are generated by +@gen_tag_n_con_binds@, and the heuristic for deciding if one of +these is around is given by @hasCon2TagFun@. + +The examples under the different sections below will make this +clearer. + +\item +Much less often (really just for deriving @Ix@), we use a +@_tag2con_@ function. See the examples. + +\item +We use the renamer!!! Reason: we're supposed to be +producing @LHsBinds Name@ for the methods, but that means +producing correctly-uniquified code on the fly. This is entirely +possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. +So, instead, we produce @MonoBinds RdrName@ then heave 'em through +the renamer. What a great hack! +\end{itemize} +-} + +-- Generate the InstInfo for the required instance paired with the +-- *representation* tycon for that instance, +-- plus any auxiliary bindings required +-- +-- Representation tycons differ from the tycon in the instance signature in +-- case of instances for indexed families. +-- +genInst :: CommonAuxiliaries + -> DerivSpec ThetaType + -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) +genInst comauxs + spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys + , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) + | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] + = do { inst_spec <- newDerivClsInst theta spec + ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty]) + ; return ( InstInfo + { iSpec = inst_spec + , iBinds = InstBindings + { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty + , ib_tyvars = map Var.varName tvs -- Scope over bindings + , ib_pragmas = [] + , ib_extensions = [ Opt_ImpredicativeTypes + , Opt_RankNTypes ] + , ib_derived = True } } + , emptyBag + , Just $ getName $ head $ tyConDataCons rep_tycon ) } + -- See Note [Newtype deriving and unused constructors] + + | otherwise + = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas + dfun_name rep_tycon + (lookup rep_tycon comauxs) + ; inst_spec <- newDerivClsInst theta spec + ; traceTc "newder" (ppr inst_spec) + ; let inst_info = InstInfo { iSpec = inst_spec + , iBinds = InstBindings + { ib_binds = meth_binds + , ib_tyvars = map Var.varName tvs + , ib_pragmas = [] + , ib_extensions = [] + , ib_derived = True } } + ; return ( inst_info, deriv_stuff, Nothing ) } + where + rhs_ty = newTyConInstRhs rep_tycon rep_tc_args + +genDerivStuff :: SrcSpan -> Class -> Name -> TyCon + -> Maybe CommonAuxiliary + -> TcM (LHsBinds RdrName, BagDerivStuff) +genDerivStuff loc clas dfun_name tycon comaux_maybe + | let ck = classKey clas + , ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic + = let gk = if ck == genClassKey then Gen0 else Gen1 + -- TODO NSF: correctly identify when we're building Both instead of One + Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst + in do + (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) + return (binds, unitBag (DerivFamInst faminst)) + + | otherwise -- Non-monadic generators + = do { dflags <- getDynFlags + ; fix_env <- getDataConFixityFun tycon + ; return (genDerivedBinds dflags fix_env clas loc tycon) } + +getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) +-- If the TyCon is locally defined, we want the local fixity env; +-- but if it is imported (which happens for standalone deriving) +-- we need to get the fixity env from the interface file +-- c.f. RnEnv.lookupFixity, and Trac #9830 +getDataConFixityFun tc + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then do { fix_env <- getFixityEnv + ; return (lookupFixity fix_env) } + else do { iface <- loadInterfaceForName doc name + -- Should already be loaded! + ; return (mi_fix_fn iface . nameOccName) } } + where + name = tyConName tc + doc = ptext (sLit "Data con fixities for") <+> ppr name + +{- +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasse to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Hsakell". + + +************************************************************************ +* * +\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} +* * +************************************************************************ +-} + +derivingNullaryErr :: MsgDoc +derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes") + +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc +derivingKindErr tc cls cls_tys cls_kind + = hang (ptext (sLit "Cannot derive well-kinded instance of form") + <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) + 2 (ptext (sLit "Class") <+> quotes (ppr cls) + <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) + +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc +derivingEtaErr cls cls_tys inst_ty + = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), + nest 2 (ptext (sLit "instance (...) =>") + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + +derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc +derivingThingErr newtype_deriving clas tys ty why + = sep [(hang (ptext (sLit "Can't make a derived instance of")) + 2 (quotes (ppr pred)) + $$ nest 2 extra) <> colon, + nest 2 why] + where + extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)") + | otherwise = Outputable.empty + pred = mkClassPred clas (tys ++ [ty]) + +derivingHiddenErr :: TyCon -> SDoc +derivingHiddenErr tc + = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + 2 (ptext (sLit "so you cannot derive an instance for it")) + +standaloneCtxt :: LHsType Name -> SDoc +standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) + 2 (quotes (ppr ty)) + +derivInstCtxt :: PredType -> MsgDoc +derivInstCtxt pred + = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs new file mode 100644 index 00000000..ca04a711 --- /dev/null +++ b/compiler/typecheck/TcEnv.hs @@ -0,0 +1,918 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan + +module TcEnv( + TyThing(..), TcTyThing(..), TcId, + + -- Instance environment, and InstInfo type + InstInfo(..), iDFunId, pprInstInfoDetails, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, + InstBindings(..), + + -- Global environment + tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, + tcExtendGlobalValEnv, + tcLookupLocatedGlobal, tcLookupGlobal, + tcLookupField, tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupAxiom, + + -- Local environment + tcExtendKindEnv, tcExtendKindEnv2, + tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendLetEnv, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3, + tcExtendIdBndrs, tcExtendGhciIdEnv, + + tcLookup, tcLookupLocated, tcLookupLocalIds, + tcLookupId, tcLookupTyVar, + tcLookupLcl_maybe, + getScopedTyVarBinds, getInLocalScope, + wrongThingErr, pprBinders, + + tcExtendRecEnv, -- For knot-tying + + -- Instances + tcLookupInstance, tcGetInstEnvs, + + -- Rules + tcExtendRules, + + -- Defaults + tcGetDefaultTys, + + -- Global type variables + tcGetGlobalTyVars, zapLclTypeEnv, + + -- Template Haskell stuff + checkWellStaged, tcMetaTy, thLevel, + topIdLvl, isBrackStage, + + -- New Ids + newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName, + mkStableIdFromString, mkStableIdFromName, + mkWrapperName + ) where + +#include "HsVersions.h" + +import HsSyn +import IfaceEnv +import TcRnMonad +import TcMType +import TcType +import LoadIface +import PrelNames +import TysWiredIn +import Id +import IdInfo( IdDetails(VanillaId) ) +import Var +import VarSet +import RdrName +import InstEnv +import DataCon ( DataCon ) +import PatSyn ( PatSyn ) +import ConLike +import TyCon +import CoAxiom +import TypeRep +import Class +import Name +import NameEnv +import VarEnv +import HscTypes +import DynFlags +import SrcLoc +import BasicTypes hiding( SuccessFlag(..) ) +import Module +import Outputable +import Encoding +import FastString +import ListSetOps +import Util +import Maybes( MaybeErr(..) ) +import Data.IORef +import Data.List + +{- +************************************************************************ +* * +* tcLookupGlobal * +* * +************************************************************************ + +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. +-} + +tcLookupLocatedGlobal :: Located Name -> TcM TyThing +-- c.f. IfaceEnvEnv.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing +-- The Name is almost always an ExternalName, but not always +-- In GHCi, we may make command-line bindings (ghci> let x = True) +-- that bind a GlobalId, but with an InternalName +tcLookupGlobal name + = do { -- Try local envt + env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of { + Just thing -> return thing ; + Nothing -> + + -- Should it have been in the local envt? + if nameIsLocalOrFrom (tcg_mod env) name + then notFound name -- Internal names can happen in GHCi + else + + -- Try home package table and external package table + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return thing + Failed msg -> failWithTc msg + }}} + +tcLookupField :: Name -> TcM Id -- Returns the selector Id +tcLookupField name + = tcLookupId name -- Note [Record field lookup] + +{- Note [Record field lookup] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think we should have tcLookupGlobal here, since record fields +are always top level. But consider + f = e { f = True } +Then the renamer (which does not keep track of what is a record selector +and what is not) will rename the definition thus + f_7 = e { f_7 = True } +Now the type checker will find f_7 in the *local* type environment, not +the global (imported) one. It's wrong, of course, but we want to report a tidy +error, not in TcEnv.notFound. -} + +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon name = do + thing <- tcLookupGlobal name + case thing of + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr "data constructor" (AGlobal thing) name + +tcLookupPatSyn :: Name -> TcM PatSyn +tcLookupPatSyn name = do + thing <- tcLookupGlobal name + case thing of + AConLike (PatSynCon ps) -> return ps + _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + +tcLookupConLike :: Name -> TcM ConLike +tcLookupConLike name = do + thing <- tcLookupGlobal name + case thing of + AConLike cl -> return cl + _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name + +tcLookupClass :: Name -> TcM Class +tcLookupClass name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls + _ -> wrongThingErr "class" (AGlobal thing) name + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name = do + thing <- tcLookupGlobal name + case thing of + ATyCon tc -> return tc + _ -> wrongThingErr "type constructor" (AGlobal thing) name + +tcLookupAxiom :: Name -> TcM (CoAxiom Branched) +tcLookupAxiom name = do + thing <- tcLookupGlobal name + case thing of + ACoAxiom ax -> return ax + _ -> wrongThingErr "axiom" (AGlobal thing) name + +tcLookupLocatedGlobalId :: Located Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedClass :: Located Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: Located Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Find the instance that exactly matches a type class application. The class arguments must be precisely +-- the same as in the instance declaration (modulo renaming). +-- +tcLookupInstance :: Class -> [Type] -> TcM ClsInst +tcLookupInstance cls tys + = do { instEnv <- tcGetInstEnvs + ; case lookupUniqueInstEnv instEnv cls tys of + Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err + Right (inst, tys) + | uniqueTyVars tys -> return inst + | otherwise -> failWithTc errNotExact + } + where + errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)") + + uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys) + where + extractTyVar (TyVarTy tv) = tv + extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar" + +tcGetInstEnvs :: TcM InstEnvs +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetInstEnvs = do { eps <- getEps + ; env <- getGblEnv + ; return (InstEnvs { ie_global = eps_inst_env eps + , ie_local = tcg_inst_env env + , ie_visible = tcg_visible_orphan_mods env }) } + +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal + +{- +************************************************************************ +* * + Extending the global environment +* * +************************************************************************ +-} + +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + + +tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r + -- Extend the global environment with some TyThings that can be obtained + -- via implicitTyThings from other entities in the environment. Examples + -- are dfuns, famInstTyCons, data cons, etc. + -- These TyThings are not added to tcg_tcs. +tcExtendGlobalEnvImplicit things thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } + +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, + tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + +tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a + -- Same deal as tcExtendGlobalEnv, but for Ids +tcExtendGlobalValEnv ids thing_inside + = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside + +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs +tcExtendRecEnv gbl_stuff thing_inside + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } + +{- +************************************************************************ +* * +\subsection{The local environment} +* * +************************************************************************ +-} + +tcLookupLocated :: Located Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + +tcLookup :: Name -> TcM TcTyThing +tcLookup name = do + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of + Just thing -> return thing + Nothing -> AGlobal <$> tcLookupGlobal name + +tcLookupTyVar :: Name -> TcM TcTyVar +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } + +tcLookupId :: Name -> TcM Id +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) +tcLookupId name = do + thing <- tcLookup name + case thing of + ATcId { tct_id = id} -> return id + AGlobal (AnId id) -> return id + _ -> pprPanic "tcLookupId" (ppr name) + +tcLookupLocalIds :: [Name] -> TcM [TcId] +-- We expect the variables to all be bound, and all at +-- the same level as the lookup. Only used in one place... +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (tcl_env env)) ns) } + where + lookup lenv name + = case lookupNameEnv lenv name of + Just (ATcId { tct_id = id }) -> id + _ -> pprPanic "tcLookupLocalIds" (ppr name) + +getInLocalScope :: TcM (Name -> Bool) + -- Ids only +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } + +tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r +-- Used only during kind checking, for TcThings that are +-- AThing or APromotionErr +-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr +tcExtendKindEnv2 things thing_inside + = updLclEnv upd_env thing_inside + where + upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } + +tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r +tcExtendKindEnv name_kind_prs + = tcExtendKindEnv2 [(n, AThing k) | (n,k) <- name_kind_prs] + +----------------------- +-- Scoped type and kind variables +tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r +tcExtendTyVarEnv tvs thing_inside + = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside + +tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r +tcExtendTyVarEnv2 binds thing_inside + = do { stage <- getStage + ; tc_extend_local_env (NotTopLevel, thLevel stage) + [(name, ATyVar name tv) | (name, tv) <- binds] $ + do { env <- getLclEnv + ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } + ; setLclEnv env' thing_inside }} + where + add_tidy_tvs env = foldl add env binds + + -- We initialise the "tidy-env", used for tidying types before printing, + -- by building a reverse map from the in-scope type variables to the + -- OccName that the programmer originally used for them + add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv + add (env,subst) (name, tyvar) + = case tidyOccName env (nameOccName name) of + (env', occ') -> (env', extendVarEnv subst tyvar tyvar') + where + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' + +getScopedTyVarBinds :: TcM [(Name, TcTyVar)] +getScopedTyVarBinds + = do { lcl_env <- getLclEnv + ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] } + +{- +Note [Initialising the type environment for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcExtendGhciIdEnv extends the local type environemnt with GHCi +identifiers (from ic_tythings), bound earlier in the interaction. +They may have free type variables (RuntimeUnk things), and if we don't +register these free TyVars as global TyVars then the typechecker will +try to quantify over them and fall over in zonkQuantifiedTyVar. +So we must add any free TyVars to the typechecker's global +TyVar set. That is most conveniently done here, using the local function +tcExtendLocalTypeEnv. + +Note especially that + + * tcExtendGhciIdEnv extends the local type env, tcl_env + That's important because some are not closed (ie have free tyvars) + and the compiler assumes that the global type env (tcg_type_env) has + no free tyvars. Actually, only ones with Internal names can be non-closed + so we jsut add those + + * The tct_closed flag depends on whether the thing has free (RuntimeUnk) + type variables + + * It will also does tcExtendGlobalTyVars; this is important + because of those RuntimeUnk variables + + * It does not extend the local RdrEnv (tcl_rdr), because the things are + already in the GlobalRdrEnv. Extending the local RdrEnv isn't terrible, + but it means there is an entry for the same Name in both global and local + RdrEnvs, and that lead to duplicate "perhaps you meant..." suggestions + (e.g. T5564). + + We don't bother with the tcl_th_bndrs environment either. + + * NB: all these TcTyThings will be in the global type envt (tcg_type_env) as + well. We are just shadowing them here to deal with the global tyvar + stuff. That's why we can simply drop the External-Name ones; they + will be found in the global envt +-} + +tcExtendGhciIdEnv :: [TyThing] -> TcM a -> TcM a +-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction +-- See Note [Initialising the type environment for GHCi] +tcExtendGhciIdEnv ids thing_inside + = do { lcl_env <- tcExtendLocalTypeEnv tc_ty_things emptyVarSet + ; setLclEnv lcl_env thing_inside } + where + tc_ty_things = [ (name, ATcId { tct_id = id + , tct_closed = is_top id }) + | AnId id <- ids + , let name = idName id + , isInternalName name ] + is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel + | otherwise = NotTopLevel + +tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a +-- Used for both top-level value bindings and and nested let/where-bindings +tcExtendLetEnv top_lvl closed ids thing_inside + = do { stage <- getStage + ; tc_extend_local_env (top_lvl, thLevel stage) + [ (idName id, ATcId { tct_id = id + , tct_closed = closed }) + | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] thing_inside } + +tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +tcExtendIdEnv ids thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] + thing_inside + +tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a +tcExtendIdEnv1 name id thing_inside + = tcExtendIdEnv2 [(name,id)] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel] + thing_inside + +tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +-- Do *not* extend the tcl_bndrs stack +-- The tct_closed flag really doesn't matter +-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) +tcExtendIdEnv2 names_w_ids thing_inside + = tcExtendIdEnv3 names_w_ids emptyVarSet thing_inside + +-- | 'tcExtendIdEnv2', but don't bind the 'TcId's in the 'TyVarSet' argument. +tcExtendIdEnv3 :: [(Name,TcId)] -> TyVarSet -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) +tcExtendIdEnv3 names_w_ids not_actually_free thing_inside + = do { stage <- getStage + ; tc_extend_local_env2 (NotTopLevel, thLevel stage) + [ (name, ATcId { tct_id = id + , tct_closed = NotTopLevel }) + | (name,id) <- names_w_ids] not_actually_free $ + thing_inside } + +tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a +tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + +tc_extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcM a -> TcM a +tc_extend_local_env thlvl extra_env thing_inside = + tc_extend_local_env2 thlvl extra_env emptyVarSet thing_inside + +tc_extend_local_env2 :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] + -> TyVarSet -> TcM a -> TcM a +tc_extend_local_env2 thlvl extra_env not_actually_free thing_inside +-- Precondition: the argument list extra_env has TcTyThings +-- that ATcId or ATyVar, but nothing else +-- +-- Invariant: the ATcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in zonkQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyVarsOfTypes is ok without looking through refs + +-- The second argument of type TyVarSet is a set of type variables +-- that are bound together with extra_env and should not be regarded +-- as free in the types of extra_env. + = do { traceTc "env2" (ppr extra_env) + ; env1 <- tcExtendLocalTypeEnv extra_env not_actually_free + ; let env2 = extend_local_env thlvl extra_env env1 + ; setLclEnv env2 thing_inside } + where + extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv + -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously + -- Reason for extending LocalRdrEnv: after running a TH splice we need + -- to do renaming. + extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env + , tcl_th_bndrs = th_bndrs }) + = env { tcl_rdr = extendLocalRdrEnvList rdr_env + [ n | (n, _) <- pairs, isInternalName n ] + -- The LocalRdrEnv contains only non-top-level names + -- (GlobalRdrEnv handles the top level) + , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs + [(n, thlvl) | (n, ATcId {}) <- pairs] } + +tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TyVarSet -> TcM TcLclEnv +tcExtendLocalTypeEnv tc_ty_things not_actually_free + | isEmptyVarSet extra_tvs + = do { lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) <- getLclEnv + ; return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) } + | otherwise + = do { lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) <- getLclEnv + ; global_tvs <- readMutVar (tcl_tyvars lcl_env) + ; new_g_var <- newMutVar (global_tvs `unionVarSet` extra_tvs) + ; return (lcl_env { tcl_tyvars = new_g_var + , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) } + where + extra_tvs = foldr get_tvs emptyVarSet tc_ty_things `minusVarSet` not_actually_free + + get_tvs (_, ATcId { tct_id = id, tct_closed = closed }) tvs + = case closed of + TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) + tvs + NotTopLevel -> tvs `unionVarSet` id_tvs + where id_tvs = tyVarsOfType (idType id) + + get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars] + = tvs `unionVarSet` tyVarsOfType (tyVarKind tv) `extendVarSet` tv + + get_tvs (_, AThing k) tvs = tvs `unionVarSet` tyVarsOfType k + + get_tvs (_, AGlobal {}) tvs = tvs + get_tvs (_, APromotionErr {}) tvs = tvs + + -- Note [Global TyVars] + -- It's important to add the in-scope tyvars to the global tyvar set + -- as well. Consider + -- f (_::r) = let g y = y::r in ... + -- Here, g mustn't be generalised. This is also important during + -- class and instance decls, when we mustn't generalise the class tyvars + -- when typechecking the methods. + -- + -- Nor must we generalise g over any kind variables free in r's kind + +zapLclTypeEnv :: TcM a -> TcM a +zapLclTypeEnv thing_inside + = do { tvs_var <- newTcRef emptyVarSet + ; let upd env = env { tcl_env = emptyNameEnv + , tcl_rdr = emptyLocalRdrEnv + , tcl_tyvars = tvs_var } + ; updLclEnv upd thing_inside } + +{- +************************************************************************ +* * +\subsection{Rules} +* * +************************************************************************ +-} + +tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not source + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv + ; let + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } + ; setGblEnv env' thing_inside } + +{- +************************************************************************ +* * + Meta level +* * +************************************************************************ +-} + +checkWellStaged :: SDoc -- What the stage check is for + -> ThLevel -- Binding level (increases inside brackets) + -> ThLevel -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_lvl + | use_lvl >= bind_lvl -- OK! Used later than bound + = return () -- E.g. \x -> [| $(f x) |] + + | bind_lvl == outerLevel -- GHC restriction on top level splices + = stageRestrictionError pp_thing + + | otherwise -- Badly staged + = failWithTc $ -- E.g. \x -> $(f x) + ptext (sLit "Stage error:") <+> pp_thing <+> + hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, + ptext (sLit "but used at stage") <+> ppr use_lvl] + +stageRestrictionError :: SDoc -> TcM a +stageRestrictionError pp_thing + = failWithTc $ + sep [ ptext (sLit "GHC stage restriction:") + , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice or annotation,") + , ptext (sLit "and must be imported, not defined locally")])] + +topIdLvl :: Id -> ThLevel +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are prcessing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = outerLevel + | otherwise = impLevel + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name = do + t <- tcLookupTyCon tc_name + return (mkTyConApp t []) + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + +{- +************************************************************************ +* * + getDefaultTys +* * +************************************************************************ +-} + +tcGetDefaultTys :: TcM ([Type], -- Default types + (Bool, -- True <=> Use overloaded strings + Bool)) -- True <=> Use extended defaulting rules +tcGetDefaultTys + = do { dflags <- getDynFlags + ; let ovl_strings = xopt Opt_OverloadedStrings dflags + extended_defaults = xopt Opt_ExtendedDefaultRules dflags + -- See also Trac #1974 + flags = (ovl_strings, extended_defaults) + + ; mb_defaults <- getDeclaredDefaultTys + ; case mb_defaults of { + Just tys -> return (tys, flags) ; + -- User-supplied defaults + Nothing -> do + + -- No use-supplied default + -- Use [Integer, Double], plus modifications + { integer_ty <- tcMetaTy integerTyConName + ; checkWiredInTyCon doubleTyCon + ; string_ty <- tcMetaTy stringTyConName + ; let deflt_tys = opt_deflt extended_defaults unitTy -- Note [Default unitTy] + ++ [integer_ty, doubleTy] + ++ opt_deflt ovl_strings string_ty + ; return (deflt_tys, flags) } } } + where + opt_deflt True ty = [ty] + opt_deflt False _ = [] + +{- +Note [Default unitTy] +~~~~~~~~~~~~~~~~~~~~~ +In interative mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See Trac #1200. + + +************************************************************************ +* * +\subsection{The InstInfo type} +* * +************************************************************************ + +The InstInfo type summarises the information in an instance declaration + + instance c => k (t tvs) where b + +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. +-} + +data InstInfo a + = InstInfo { + iSpec :: ClsInst, -- Includes the dfun id. Its forall'd type + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! + } + +iDFunId :: InstInfo a -> DFunId +iDFunId info = instanceDFunId (iSpec info) + +data InstBindings a + = InstBindings + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + + , ib_binds :: (LHsBinds a) -- Bindings for the instance methods + + , ib_pragmas :: [LSig a] -- User pragmas recorded for generating + -- specialised instances + + , ib_extensions :: [ExtensionFlag] -- Any extra extensions that should + -- be enabled when type-checking this + -- instance; needed for + -- GeneralizedNewtypeDeriving + + , ib_derived :: Bool + -- True <=> This code was generated by GHC from a deriving clause + -- or standalone deriving declaration + -- Used only to improve error messages + } + +instance OutputableBndr a => Outputable (InstInfo a) where + ppr = pprInstInfoDetails + +pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc +pprInstInfoDetails info + = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where")) + 2 (details (iBinds info)) + where + details (InstBindings { ib_binds = b }) = pprLHsBinds b + +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) +simpleInstInfoClsTy info = case instanceHead (iSpec info) of + (_, cls, [ty]) -> (cls, ty) + _ -> panic "simpleInstInfoClsTy" + +simpleInstInfoTy :: InstInfo a -> Type +simpleInstInfoTy info = snd (simpleInstInfoClsTy info) + +simpleInstInfoTyCon :: InstInfo a -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) + +{- +Make a name for the dict fun for an instance decl. It's an *external* +name, like otber top-level names, and hence must be made with newGlobalBinder. +-} + +newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name +newDFunName clas tys loc + = do { is_boot <- tcIsHsBootOrSig + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) + ; newGlobalBinder mod dfun_occ loc } + +{- +Make a name for the representation tycon of a family instance. It's an +*external* name, like other top-level names, and hence must be made with +newGlobalBinder. +-} + +newFamInstTyConName :: Located Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] + +newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name +newFamInstAxiomName loc name branches + = mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches) + +mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name +mk_fam_inst_name adaptOcc loc tc_name tyss + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + intercalate "|" ty_strings + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod (adaptOcc occ) loc } + where + ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss + +{- +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. +-} + +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + name <- mkWrapperName "stable" str + let occ = mkVarOccFS name :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedLocalId VanillaId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) + +mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) + => String -> String -> m FastString +mkWrapperName what nameBase + = do dflags <- getDynFlags + thisMod <- getModule + let -- Note [Generating fresh names for ccall wrapper] + wrapperRef = nextWrapperNum dflags + pkg = packageKeyString (modulePackageKey thisMod) + mod = moduleNameString (moduleName thisMod) + wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + mod_env' = extendModuleEnv mod_env thisMod (num+1) + in (mod_env', num) + let components = [what, show wrapperNum, pkg, mod, nameBase] + return $ mkFastString $ zEncodeString $ intercalate ":" components + +{- +Note [Generating fresh names for FFI wrappers] + +We used to use a unique, rather than nextWrapperNum, to distinguish +between FFI wrapper functions. However, the wrapper names that we +generate are external names. This means that if a call to them ends up +in an unfolding, then we can't alpha-rename them, and thus if the +unique randomly changes from one compile to another then we get a +spurious ABI change (#4012). + +The wrapper counter has to be per-module, not global, so that the number we end +up using is not dependent on the modules compiled before the current one. +-} + +{- +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +pprBinders :: [Name] -> SDoc +-- Used in error messages +-- Use quotes for a single one; they look a bit "busy" for several +pprBinders [bndr] = quotes (ppr bndr) +pprBinders bndrs = pprWithCommas ppr bndrs + +notFound :: Name -> TcM TyThing +notFound name + = do { lcl_env <- getLclEnv + ; let stage = tcl_th_ctxt lcl_env + ; case stage of -- See Note [Out of scope might be a staging error] + Splice {} -> stageRestrictionError (quotes (ppr name)) + _ -> failWithTc $ + vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> + ptext (sLit "is not in scope during type checking, but it passed the renamer"), + ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] + -- Take case: printing the whole gbl env can + -- cause an infinite loop, in the case where we + -- are in the middle of a recursive TyCon/Class group; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another + } + +wrongThingErr :: String -> TcTyThing -> Name -> TcM a +-- It's important that this only calls pprTcTyThingCategory, which in +-- turn does not look at the details of the TcTyThing. +-- See Note [Placeholder PatSyn kinds] in TcBinds +wrongThingErr expected thing name + = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + ptext (sLit "used as a") <+> text expected) + +{- +Note [Out of scope might be a staging error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = 3 + data T = MkT $(foo x) + +This is really a staging error, because we can't run code involving 'x'. +But in fact the type checker processes types first, so 'x' won't even be +in the type envt when we look for it in $(foo x). So inside splices we +report something missing from the type env as a staging error. +See Trac #5752 and #5795. +-} diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot new file mode 100644 index 00000000..4d291e27 --- /dev/null +++ b/compiler/typecheck/TcEnv.hs-boot @@ -0,0 +1,6 @@ +{- +>module TcEnv where +>import TcRnTypes +> +>tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-} diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs new file mode 100644 index 00000000..63ad847c --- /dev/null +++ b/compiler/typecheck/TcErrors.hs @@ -0,0 +1,1611 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +module TcErrors( + reportUnsolved, reportAllUnsolved, + warnDefaulting, + + solverDepthErrorTcS + ) where + +#include "HsVersions.h" + +import TcRnTypes +import TcRnMonad +import TcMType +import TcType +import TypeRep +import Type +import Kind ( isKind ) +import Unify ( tcMatchTys ) +import Module +import FamInst +import Inst +import InstEnv +import TyCon +import DataCon +import TcEvidence +import Name +import RdrName ( lookupGRE_Name, GlobalRdrEnv ) +import Id +import Var +import VarSet +import VarEnv +import NameEnv +import Bag +import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg, isWarning ) +import BasicTypes +import Util +import FastString +import Outputable +import SrcLoc +import DynFlags +import StaticFlags ( opt_PprStyle_Debug ) +import ListSetOps ( equivClasses ) + +import Control.Monad ( when ) +import Data.Maybe +import Data.List ( partition, mapAccumL, nub, sortBy ) + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors. TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; defer_holes <- goptM Opt_DeferTypedHoles + ; warn_holes <- woptM Opt_WarnTypedHoles + ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + ; report_unsolved (Just binds_var) defer_errors defer_holes + warn_holes warn_partial_sigs wanted + ; getTcEvBinds binds_var } + +reportAllUnsolved :: WantedConstraints -> TcM () +-- Report all unsolved goals, even if -fdefer-type-errors is on +-- See Note [Deferring coercion errors to runtime] +reportAllUnsolved wanted = do + warn_holes <- woptM Opt_WarnTypedHoles + warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures + report_unsolved Nothing False False warn_holes warn_partial_sigs wanted + +report_unsolved :: Maybe EvBindsVar -- cec_binds + -> Bool -- cec_defer_type_errors + -> Bool -- cec_defer_holes + -> Bool -- cec_warn_holes + -> Bool -- cec_warn_partial_type_signatures + -> WantedConstraints -> TcM () +-- Important precondition: +-- WantedConstraints are fully zonked and unflattened, that is, +-- zonkWC has already been applied to these constraints. +report_unsolved mb_binds_var defer_errors defer_holes warn_holes + warn_partial_sigs wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted) + + ; env0 <- tcInitTidyEnv + + -- If we are deferring we are going to need /all/ evidence around, + -- including the evidence produced by unflattening (zonkWC) + ; let tidy_env = tidyFreeTyVars env0 free_tvs + free_tvs = tyVarsOfWC wanted + err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = defer_errors + , cec_defer_holes = defer_holes + , cec_warn_holes = warn_holes + , cec_warn_partial_type_signatures = warn_partial_sigs + , cec_suppress = False -- See Note [Suppressing error messages] + , cec_binds = mb_binds_var } + + ; traceTc "reportUnsolved (after unflattening):" $ + vcat [ pprTvBndrs (varSetElems free_tvs) + , ppr wanted ] + + ; reportWanteds err_ctxt wanted } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +data ReportErrCtxt + = CEC { cec_encl :: [Implication] -- Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + , cec_binds :: Maybe EvBindsVar + -- Nothinng <=> Report all errors, including holes; no bindings + -- Just ev <=> make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'ev' for unsolved constraints + + , cec_defer_type_errors :: Bool -- True <=> -fdefer-type-errors + -- Defer type errors until runtime + -- Irrelevant if cec_binds = Nothing + + , cec_defer_holes :: Bool -- True <=> -fdefer-typed-holes + -- Turn typed holes into runtime errors + -- Irrelevant if cec_binds = Nothing + + , cec_warn_holes :: Bool -- True <=> -fwarn-typed-holes + -- Controls whether typed holes produce warnings + , cec_warn_partial_type_signatures :: Bool + -- True <=> -fwarn-partial-type-signatures + -- Controls whether holes in partial type + -- signatures produce warnings + , cec_suppress :: Bool -- True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +{- +Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors. Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the simple constraints here. Sometimes the + simple-constraint errors are a knock-on effect of the insolubles. +-} + +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_insol = ic_insoluble, ic_info = info }) + | BracketSkol <- info + , not ic_insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise + = reportWanteds ctxt' wanted + where + (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + (env2, info') = tidySkolemInfo env1 info + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env2) given + , ic_info = info' } + ctxt' = ctxt { cec_tidy = env2 + , cec_encl = implic' : cec_encl ctxt + , cec_binds = case cec_binds ctxt of + Nothing -> Nothing + Just {} -> Just evb } + +reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () +reportWanteds ctxt wanted@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) + = do { reportSimples ctxt (mapBag (tidyCt env) insol_given) + ; reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted) + ; reportSimples ctxt2 (mapBag (tidyCt env) simples) + -- All the Derived ones have been filtered out of simples + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as errors + -- See Note [Do not report derived but soluble errors] + ; mapBagM_ (reportImplic ctxt1) implics } + -- NB ctxt1: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a given insoluble here (= inaccessible code) + where + (insol_given, insol_wanted) = partitionBag isGivenCt insols + env = cec_tidy ctxt + + -- See Note [Suppressing error messages] + suppress0 = cec_suppress ctxt + suppress1 = suppress0 || not (isEmptyBag insol_given) + suppress2 = suppress0 || insolubleWC wanted + ctxt1 = ctxt { cec_suppress = suppress1 } + ctxt2 = ctxt { cec_suppress = suppress2 } + +reportSimples :: ReportErrCtxt -> Cts -> TcM () +reportSimples ctxt simples -- Here 'simples' includes insolble goals + = traceTc "reportSimples" (vcat [ ptext (sLit "Simples =") <+> ppr simples + , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) + >> tryReporters + [ -- First deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + ("Utterly wrong", utterly_wrong, True, mkGroupReporter mkEqErr) + , ("Holes", is_hole, False, mkHoleReporter mkHoleError) + + -- Report equalities of form (a~ty). They are usually + -- skolem-equalities, and they cause confusing knock-on + -- effects in other errors; see test T4093b. + , ("Skolem equalities", skolem_eq, True, mkSkolReporter) + + -- Other equalities; also confusing knock on effects + , ("Equalities", is_equality, True, mkGroupReporter mkEqErr) + + , ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) + , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) + ] + panicReporter ctxt (bagToList simples) + -- TuplePreds should have been expanded away by the constraint + -- simplifier, so they shouldn't show up at this point + where + utterly_wrong, skolem_eq, is_hole, is_dict, + is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool + + utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2 + utterly_wrong _ _ = False + + is_hole ct _ = isHoleCt ct + + skolem_eq _ (EqPred NomEq ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 + skolem_eq _ _ = False + + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + +--------------- +isRigid, isRigidOrSkol :: Type -> Bool +isRigid ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + +isRigidOrSkol ty + | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv + | otherwise = isRigid ty + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isTypeFamilyTyCon tc -> Just tc + _ -> Nothing + + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = ReportErrCtxt -> [Ct] -> TcM () +type ReporterSpec + = ( String -- Name + , Ct -> PredTree -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself + +panicReporter :: Reporter +panicReporter _ cts + | null cts = return () + | otherwise = pprPanic "reportSimples" (ppr cts) + +mkSkolReporter :: Reporter +-- Suppress duplicates with the same LHS +mkSkolReporter ctxt cts + = mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts) + where + cmp_lhs_type ct1 ct2 + = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of + (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> + (eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2) + _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) + +mkHoleReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter +-- Reports errors one at a time +mkHoleReporter mk_err ctxt + = mapM_ $ \ct -> + do { err <- mk_err ctxt ct + ; maybeReportHoleError ctxt err + ; maybeAddDeferredHoleBinding ctxt err ct } + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints +-- Group together errors from same location, +-- and report only the first (to avoid a cascade) +mkGroupReporter mk_err ctxt cts + = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts) + where + cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) + +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt + -> [Ct] -> TcM () +reportGroup mk_err ctxt cts + = do { err <- mk_err ctxt cts + ; maybeReportError ctxt err + ; mapM_ (maybeAddDeferredBinding ctxt err) cts } + -- Add deferred bindings for all + -- But see Note [Always warn with -fdefer-type-errors] + +maybeReportHoleError :: ReportErrCtxt -> ErrMsg -> TcM () +maybeReportHoleError ctxt err + -- When -XPartialTypeSignatures is on, warnings (instead of errors) are + -- generated for holes in partial type signatures. Unless + -- -fwarn_partial_type_signatures is not on, in which case the messages are + -- discarded. + | isWarning err + = when (cec_warn_partial_type_signatures ctxt) + (reportWarning err) + | cec_defer_holes ctxt + = when (cec_warn_holes ctxt) + (reportWarning (makeIntoWarning err)) + | otherwise + = reportError err + +maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () +-- Report the error and/or make a deferred binding for it +maybeReportError ctxt err + -- See Note [Always warn with -fdefer-type-errors] + | cec_defer_type_errors ctxt + = reportWarning (makeIntoWarning err) + | cec_suppress ctxt + = return () + | otherwise + = reportError err + +addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +addDeferredBinding ctxt err ct + | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct + -- Only add deferred bindings for Wanted constraints + , Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings + = do { dflags <- getDynFlags + ; let err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" + + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +maybeAddDeferredHoleBinding ctxt err ct + | cec_defer_holes ctxt && isTypedHoleCt ct + = addDeferredBinding ctxt err ct + | otherwise + = return () + +maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +maybeAddDeferredBinding ctxt err ct + | cec_defer_type_errors ctxt + = addDeferredBinding ctxt err ct + | otherwise + = return () + +tryReporters :: [ReporterSpec] -> Reporter -> Reporter +-- Use the first reporter in the list whose predicate says True +tryReporters reporters deflt ctxt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go ctxt reporters cts + ; traceTc "tryReporters }" empty } + where + go ctxt [] cts = deflt ctxt cts + go ctxt ((str, pred, suppress_after, reporter) : rs) cts + | null yeses = do { traceTc "tryReporters: no" (text str) + ; go ctxt rs cts } + | otherwise = do { traceTc "tryReporters: yes" (text str <+> ppr yeses) + ; reporter ctxt yeses :: TcM () + ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt } + ; go ctxt' rs nos } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have + -- -fdefer-type-errors + -- But suppress their error messages + where + (yeses, nos) = partition keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) + +-- Add the "arising from..." part to a message about bunch of dicts +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = hang msg 2 (pprArising orig) + +pprWithArising :: [Ct] -> (CtLoc, SDoc) +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = (loc, addArising (ctLocOrigin loc) + (pprTheta [ctPred ct])) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprArisingAt (ctLoc ct')) + +mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg +mkErrorMsg ctxt ct msg + = do { let tcl_env = ctLocEnv (ctLoc ct) + ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) + ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info } + +type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan) + +getUserGivens :: ReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = ctxt}) + = reverse $ + [ (givens, info, no_eqs, tcl_loc env) + | Implic { ic_given = givens, ic_env = env + , ic_no_eqs = no_eqs, ic_info = info } <- ctxt + , not (null givens) ] + +{- +Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +This is an easy design choice to change; just flip the order of the +first two equations for maybeReportError + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! Again, an easy choice to change. + + +Note [Do not report derived but soluble errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wc_simples include Derived constraints that have not been solved, but are +not insoluble (in that case they'd be in wc_insols). We do not want to report +these as errors: + +* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have + an unsolved [D] Eq a, and we do not want to report that; it's just noise. + +* Functional dependencies. For givens, consider + class C a b | a -> b + data T a where + MkT :: C a d => [d] -> T a + f :: C a b => T a -> F Int + f (MkT xs) = length xs + Then we get a [D] b~d. But there *is* a legitimate call to + f, namely f (MkT [True]) :: T Bool, in which b=d. So we should + not reject the program. + + For wanteds, something similar + data T a where + MkT :: C Int b => a -> b -> T a + g :: C Int c => c -> () + f :: T a -> () + f (MkT x y) = g x + Here we get [G] C Int b, [W] C Int a, hence [D] a~b. + But again f (MkT True True) is a legitimate call. + +(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose +derived superclasses between iterations of the solver.) + +For functional dependencies, here is a real example, +stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs + + class C a b | a -> b + g :: C a b => a -> b -> () + f :: C a b => a -> b -> () + f xa xb = + let loop = g xa + in loop xb + +We will first try to infer a type for loop, and we will succeed: + C a b' => b' -> () +Subsequently, we will type check (loop xb) and all is good. But, +recall that we have to solve a final implication constraint: + C a b => (C a b' => .... cts from body of loop .... )) +And now we have a problem as we will generate an equality b ~ b' and fail to +solve it. + + +************************************************************************ +* * + Irreducible predicate errors +* * +************************************************************************ +-} + +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } + where + (ct1:_) = cts + orig = ctLocOrigin (ctLoc ct1) + givens = getUserGivens ctxt + msg = couldNotDeduce givens (map ctPred cts, orig) + +---------------- +mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkHoleError ctxt ct@(CHoleCan { cc_occ = occ }) + = do { partial_sigs <- xoptM Opt_PartialTypeSignatures + ; let tyvars = varSetElems (tyVarsOfCt ct) + tyvars_msg = map loc_msg tyvars + msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ)) + 2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct))) + , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) + , if in_typesig && not partial_sigs then pts_hint else empty ] + ; (ctxt, binds_doc) <- relevantBindings False ctxt ct + -- The 'False' means "don't filter the bindings; see Trac #8191 + ; errMsg <- mkErrorMsg ctxt ct (msg $$ binds_doc) + ; if in_typesig && partial_sigs + then return $ makeIntoWarning errMsg + else return errMsg } + where + in_typesig = not $ isTypedHoleCt ct + pts_hint = ptext (sLit "To use the inferred type, enable PartialTypeSignatures") + loc_msg tv + = case tcTyVarDetails tv of + SkolemTv {} -> quotes (ppr tv) <+> skol_msg + MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable") + det -> pprTcTyVarDetails det + where + skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) + +mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) + +---------------- +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) } + where + (ct1:_) = cts + orig = ctLocOrigin (ctLoc ct1) + preds = map ctPred cts + givens = getUserGivens ctxt + msg | null givens + = addArising orig $ + sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + , nest 2 (pprTheta preds) ] + | otherwise + = couldNotDeduce givens (preds, orig) + +{- +************************************************************************ +* * + Equality errors +* * +************************************************************************ + +Note [Inaccessible code] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + T1 :: T a + T2 :: T Bool + + f :: (a ~ Int) => T a -> Int + f T1 = 3 + f T2 = 4 -- Unreachable code + +Here the second equation is unreachable. The original constraint +(a~Int) from the signature gets rewritten by the pattern-match to +(Bool~Int), so the danger is that we report the error as coming from +the *signature* (Trac #7293). So, for Given errors we replace the +env (and hence src-loc) on its CtLoc with that from the immediately +enclosing implication. +-} + +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Wanted constraints only! +mkEqErr1 ctxt ct + | isGiven ev + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct + ; let (given_loc, given_msg) = mk_given (cec_encl ctxt) + ; dflags <- getDynFlags + ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg) + (ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code] + Nothing ty1 ty2 } + + | otherwise -- Wanted or derived + = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct + ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + ; rdr_env <- getGlobalRdrEnv + ; fam_envs <- tcGetFamInstEnvs + ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig + coercible_msg = case ctEvEqRel ev of + NomEq -> empty + ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; dflags <- getDynFlags + ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) + ; mkEqErr_help dflags (ctxt {cec_tidy = env1}) + (wanted_msg $$ coercible_msg $$ binds_msg) + ct is_oriented ty1 ty2 } + where + ev = ctEvidence ct + loc = ctEvLoc ev + (ty1, ty2) = getEqPredTys (ctEvPred ev) + + mk_given :: [Implication] -> (CtLoc, SDoc) + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the implication. See Note [Inaccessible code] + mk_given [] = (loc, empty) + mk_given (implic : _) = (setCtLocEnv loc (ic_env implic) + , hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ic_info implic))) + + -- If the types in the error message are the same as the types + -- we are unifying, don't add the extra expected/actual message + mk_wanted_extra orig@(TypeEqOrigin {}) + = mkExpectedActualMsg ty1 ty2 orig + + mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) + = (Nothing, msg1 $$ msg2) + where + msg1 = hang (ptext (sLit "When matching types")) + 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) + msg2 = case sub_o of + TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o) + _ -> empty + + mk_wanted_extra orig@(FunDepOrigin1 {}) = (Nothing, pprArising orig) + mk_wanted_extra orig@(FunDepOrigin2 {}) = (Nothing, pprArising orig) + mk_wanted_extra orig@(DerivOriginCoerce _ oty1 oty2) + = (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2) + mk_wanted_extra orig@(CoercibleOrigin oty1 oty2) + -- if the origin types are the same as the final types, don't + -- clutter output with repetitive information + | not (oty1 `eqType` ty1 && oty2 `eqType` ty2) && + not (oty1 `eqType` ty2 && oty2 `eqType` ty1) + = (Nothing, pprArising orig $+$ mkRoleSigs oty1 oty2) + | otherwise + -- still print role sigs even if types line up + = (Nothing, mkRoleSigs oty1 oty2) + mk_wanted_extra _ = (Nothing, empty) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> SDoc +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr s1) <+> text "have;") + 2 (text "we must assume that the role is nominal") + | otherwise + = empty + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , null (lookupGRE_Name rdr_env dc_name) + = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = length tys >= tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +-- | Make a listing of role signatures for all the parameterised tycons +-- used in the provided types +mkRoleSigs :: Type -> Type -> SDoc +mkRoleSigs ty1 ty2 + = ppUnless (null role_sigs) $ + hang (text "Relevant role signatures:") + 2 (vcat role_sigs) + where + tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 + role_sigs = mapMaybe ppr_role_sig tcs + + ppr_role_sig tc + | null roles -- if there are no parameters, don't bother printing + = Nothing + | otherwise + = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles + where + roles = tyConRoles tc + +mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help dflags ctxt extra ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1 + | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2 + where + swapped = fmap flipSwap oriented + +reportEqErr :: ReportErrCtxt -> SDoc + -> Ct + -> Maybe SwapFlag -- Nothing <=> not sure + -> TcType -> TcType -> TcM ErrMsg +reportEqErr ctxt extra1 ct oriented ty1 ty2 + = do { let extra2 = mkEqInfoMsg ct ty1 ty2 + ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extra2, extra1]) } + +mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct + -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg +-- tv1 and ty2 are already tidied +mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2 + | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; + -- see TcCanonical.canEqTyVarTyVar + || isSigTyVar tv1 && not (isTyVarTy ty2) + || ctEqRel ct == ReprEq && not (isTyVarUnderDatatype tv1 ty2) + -- the cases below don't really apply to ReprEq (except occurs check) + = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 + , extra ]) + + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a SigTv, else it'd have been unified + | not (k2 `tcIsSubKind` k1) -- Kind error + = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) + + | OC_Occurs <- occ_check_expand + , ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2 + -- See Note [Occurs check error] in TcCanonical + = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") + 2 (sep [ppr ty1, char '~', ppr ty2]) + extra2 = mkEqInfoMsg ct ty1 ty2 + ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) } + + | OC_Forall <- occ_check_expand + = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2) + , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ] + ; mkErrorMsg ctxt ct msg } + + -- If the immediately-enclosing implication has 'tv' a skolem, and + -- we know by now its an InferSkol kind of skolem, then presumably + -- it started life as a SigTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2 + , extraTyVarInfo ctxt tv1 ty2 + , extra ]) + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols + , not (null esc_skols) + = do { let msg = misMatchMsg oriented eq_rel ty1 ty2 + esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols + <+> pprQuotedList esc_skols + , ptext (sLit "would escape") <+> + if isSingleton esc_skols then ptext (sLit "its scope") + else ptext (sLit "their scope") ] + tv_extra = vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then ptext (sLit "This (rigid, skolem) type variable is") + else ptext (sLit "These (rigid, skolem) type variables are")) + <+> ptext (sLit "bound by") + , nest 2 $ ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] + ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) } + + -- Nastiest case: attempt to unify an untouchable variable + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic + = do { let msg = misMatchMsg oriented eq_rel ty1 ty2 + tclvl_extra + = nest 2 $ + sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") + , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given + , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] + tv_extra = extraTyVarInfo ctxt tv1 ty2 + add_sig = suggestAddSig ctxt ty1 ty2 + ; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) } + + | otherwise + = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2 + -- This *can* happen (Trac #6123, and test T2627b) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, because F is a type function. + where + occ_check_expand = occurCheckExpand dflags tv1 ty2 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + ty1 = mkTyVarTy tv1 + eq_rel = ctEqRel ct + +mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ct ty1 ty2 + = tyfun_msg $$ ambig_msg + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + + ambig_msg | isJust mb_fun1 || isJust mb_fun2 + = snd (mkAmbigMsg ct) + | otherwise = empty + + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + = ptext (sLit "NB:") <+> quotes (ppr tc1) + <+> ptext (sLit "is a type function, and may not be injective") + | otherwise = empty + +isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool +-- See Note [Reporting occurs-check errors] +isUserSkolem ctxt tv + = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) + where + is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) + = tv `elem` sks && is_user_skol_info skol_info + + is_user_skol_info (InferSkol {}) = False + is_user_skol_info _ = True + +misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND ctxt ct oriented ty1 ty2 + | null givens || + (isRigid ty1 && isRigid ty2) || + isGivenCt ct + -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + = misMatchMsg oriented eq_rel ty1 ty2 + | otherwise + = couldNotDeduce givens ([eq_pred], orig) + where + eq_rel = ctEqRel ct + givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs] + -- Keep only UserGivens that have some equalities + + (eq_pred, orig) = case eq_rel of + NomEq -> ( mkTcEqPred ty1 ty2 + , TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 }) + ReprEq -> ( mkCoerciblePred ty1 ty2 + , CoercibleOrigin ty1 ty2 ) + +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce givens (wanteds, orig) + = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds) + , vcat (pp_givens givens)] + +pp_givens :: [UserGiven] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (ptext (sLit "from the context")) g + : map (ppr_given (ptext (sLit "or from"))) gs + where + ppr_given herald (gs, skol_info, _, loc) + = hang (herald <+> pprEvVarTheta gs) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) + +extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarInfo ctxt tv1 ty2 + = nest 2 (tv_extra tv1 $$ ty_extra ty2) + where + implics = cec_encl ctxt + ty_extra ty = case tcGetTyVar_maybe ty of + Just tv -> tv_extra tv + Nothing -> empty + + tv_extra tv | isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 ty2 + | null inferred_bndrs + = empty + | [bndr] <- inferred_bndrs + = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr) + | otherwise + = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs) + where + inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) + get_inf ty | Just tv <- tcGetTyVar_maybe ty + , isTcTyVar tv, isSkolemTyVar tv + , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv + = map fst prs + | otherwise + = [] + +kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy +kindErrorMsg ty1 ty2 + = vcat [ ptext (sLit "Kind incompatibility when matching types:") + , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 + , ppr ty2 <+> dcolon <+> ppr k2 ]) ] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-------------------- +misMatchMsg :: Maybe SwapFlag -> EqRel -> TcType -> TcType -> SDoc +-- Types are already tidy +-- If oriented then ty1 is actual, ty2 is expected +misMatchMsg oriented eq_rel ty1 ty2 + | Just IsSwapped <- oriented + = misMatchMsg (Just NotSwapped) eq_rel ty2 ty1 + | Just NotSwapped <- oriented + = sep [ text "Couldn't match" <+> repr1 <+> text "expected" <+> + what <+> quotes (ppr ty2) + , nest (12 + extra_space) $ + text "with" <+> repr2 <+> text "actual" <+> what <+> quotes (ppr ty1) + , sameOccExtra ty2 ty1 ] + | otherwise + = sep [ text "Couldn't match" <+> repr1 <+> what <+> quotes (ppr ty1) + , nest (15 + extra_space) $ + text "with" <+> repr2 <+> quotes (ppr ty2) + , sameOccExtra ty1 ty2 ] + where + what | isKind ty1 = ptext (sLit "kind") + | otherwise = ptext (sLit "type") + + (repr1, repr2, extra_space) = case eq_rel of + NomEq -> (empty, empty, 0) + ReprEq -> (text "representation of", text "that of", 10) + +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc) +-- NotSwapped means (actual, expected), IsSwapped is the reverse +mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty) + | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty) + | otherwise = (Nothing, msg) + where + msg = vcat [ text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg" + +sameOccExtra :: TcType -> TcType -> SDoc +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtra ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + | otherwise + = empty + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> ptext (sLit "is defined at")) + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainPackageKey) $ + nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ]) + where + pkg = modulePackageKey mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- +Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +This initially came up in Trac #8968, concerning pattern synonyms. + +Note [Disambiguating (X ~ X) errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #8278 + +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer somethiing like + f :: forall a. a -> [a] +with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not +one bound by the programmer! Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + +Note [Non-injective type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very confusing to get a message like + Couldn't match expected type `Depend s' + against inferred type `Depend s1' +so mkTyFunInfoMsg adds: + NB: `Depend' is type function, and hence may not be injective + +Warn of loopy local equalities that were dropped. + + +************************************************************************ +* * + Type-class errors +* * +************************************************************************ +-} + +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts + = ASSERT( not (null cts) ) + do { inst_envs <- tcGetInstEnvs + ; let (ct1:_) = cts -- ct1 just for its location + min_cts = elim_superclasses cts + ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts + ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- But we report only one of them (hence 'head') because they all + -- have the same source-location origin, to try avoid a cascade + -- of error from one location + ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; mkErrorMsg ctxt ct1 err } + where + no_givens = null (getUserGivens ctxt) + + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct))) + + lookup_cls_inst inst_envs ct + = do { tys_flat <- mapM quickFlattenTy tys + -- Note [Flattening in error message generation] + ; return (ct, lookupInstEnv inst_envs clas tys_flat) } + where + (clas, tys) = getClassPredTys (ctPred ct) + + + -- When simplifying [W] Ord (Set a), we need + -- [W] Eq a, [W] Ord a + -- but we really only want to report the latter + elim_superclasses cts + = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts + where + min_preds = mkMinimalBySCs (map ctPred cts) + +mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM (ReportErrCtxt, SDoc) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) + | null matches -- No matches but perhaps several unifiers + = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct + ; (ctxt, binds_msg) <- relevantBindings True ctxt ct + ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg) + ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) } + + | not safe_haskell -- Some matches => overlap errors + = return (ctxt, overlap_msg) + + | otherwise + = return (ctxt, safe_haskell_msg) + where + orig = ctLocOrigin (ctLoc ct) + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + givens = getUserGivens ctxt + all_tyvars = all isTyVarTy tys + + cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg + = vcat [ addArising orig no_inst_msg + , vcat (pp_givens givens) + , ppWhen (has_ambig_tvs && not (null unifiers && null givens)) + (vcat [ ambig_msg, binds_msg, potential_msg ]) + , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ] + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + hang (if isSingleton unifiers + then ptext (sLit "Note: there is a potential instance available:") + else ptext (sLit "Note: there are several potential instances:")) + 2 (ppr_insts (sortBy fuzzyClsInstCmp unifiers)) + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + add_to_ctxt_fixes has_ambig_tvs + | not has_ambig_tvs && all_tyvars + , (orig:origs) <- usefulContext ctxt pred + = [sep [ ptext (sLit "add") <+> pprParendType pred + <+> ptext (sLit "to the context of") + , nest 2 $ ppr_skol orig $$ + vcat [ ptext (sLit "or") <+> ppr_skol orig + | orig <- origs ] ] ] + | otherwise = [] + + ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) + ppr_skol skol_info = ppr skol_info + + no_inst_msg + | null givens && null matches + = ptext (sLit "No instance for") + <+> pprParendType pred + $$ if type_has_arrow pred + then nest 2 $ ptext (sLit "(maybe you haven't applied enough arguments to a function?)") + else empty + + | otherwise + = ptext (sLit "Could not deduce") <+> pprParendType pred + + type_has_arrow (TyVarTy _) = False + type_has_arrow (AppTy t1 t2) = type_has_arrow t1 || type_has_arrow t2 + type_has_arrow (TyConApp _ ts) = or $ map type_has_arrow ts + type_has_arrow (FunTy _ _) = True + type_has_arrow (ForAllTy _ t) = type_has_arrow t + type_has_arrow (LitTy _) = False + + drv_fixes = case orig of + DerivOrigin -> [drv_fix] + DerivOriginDC {} -> [drv_fix] + DerivOriginCoerce {} -> [drv_fix] + _ -> [] + + drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,")) + 2 (ptext (sLit "so you can specify the instance context yourself")) + + -- Normal overlap error + overlap_msg + = ASSERT( not (null matches) ) + vcat [ addArising orig (ptext (sLit "Overlapping instances for") + <+> pprType (mkClassPred clas tys)) + + , ppUnless (null matching_givens) $ + sep [ptext (sLit "Matching givens (or their superclasses):") + , nest 2 (vcat matching_givens)] + + , sep [ptext (sLit "Matching instances:"), + nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + + , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ ptext (sLit "There exists a (perhaps superclass) match:") + , nest 2 (vcat (pp_givens givens))] + + , ppWhen (isSingleton matches) $ + parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+> + quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))) + , ppWhen (null (matching_givens)) $ + vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances") + , ptext (sLit "when compiling the other instance declarations")] + ])] + where + ispecs = [ispec | (ispec, _) <- matches] + + givens = getUserGivens ctxt + matching_givens = mapMaybe matchable givens + + matchable (evvars,skol_info,_,loc) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) + where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) + ev_var_matches ty = case getClassPredTys_maybe ty of + Just (clas', tys') + | clas' == clas + , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + -> True + | otherwise + -> any ev_var_matches (immSuperClasses clas' tys') + Nothing -> False + + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg + = ASSERT( length matches > 1 ) + vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") + <+> pprType (mkClassPred clas tys)) + , sep [ptext (sLit "The matching instance is:"), + nest 2 (pprInstance $ head ispecs)] + , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" + , ptext $ sLit "overlap instances from the same module, however it" + , ptext $ sLit "overlaps the following instances from different modules:" + , nest 2 (vcat [pprInstances $ tail ispecs]) + ] + ] + +usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo] +usefulContext ctxt pred + = go (cec_encl ctxt) + where + pred_tvs = tyVarsOfType pred + go [] = [] + go (ic : ics) + = case ic_info ic of + -- Do not suggest adding constraints to an *inferred* type signature! + SigSkol (InfSigCtxt {}) _ -> rest + info -> info : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") + , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts insts + = pprInstances (take 3 insts) $$ dot_dot_message + where + n_extra = length insts - 3 + dot_dot_message + | n_extra <= 0 = empty + | otherwise = ptext (sLit "...plus") + <+> speakNOf n_extra (ptext (sLit "other")) + +---------------------- +quickFlattenTy :: TcType -> TcM TcType +-- See Note [Flattening in error message generation] +quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' +quickFlattenTy ty@(TyVarTy {}) = return ty +quickFlattenTy ty@(ForAllTy {}) = return ty -- See +quickFlattenTy ty@(LitTy {}) = return ty + -- Don't flatten because of the danger or removing a bound variable +quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 + ; fy2 <- quickFlattenTy ty2 + ; return (AppTy fy1 fy2) } +quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 + ; fy2 <- quickFlattenTy ty2 + ; return (FunTy fy1 fy2) } +quickFlattenTy (TyConApp tc tys) + | not (isTypeFamilyTyCon tc) + = do { fys <- mapM quickFlattenTy tys + ; return (TyConApp tc fys) } + | otherwise + = do { let (funtys,resttys) = splitAt (tyConArity tc) tys + -- Ignore the arguments of the type family funtys + ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys)) + ; flat_resttys <- mapM quickFlattenTy resttys + ; return (foldl AppTy (mkTyVarTy v) flat_resttys) } + +{- +Note [Flattening in error message generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (C (Maybe (F x))), where F is a type function, and we have +instances + C (Maybe Int) and C (Maybe a) +Since (F x) might turn into Int, this is an overlap situation, and +indeed (because of flattening) the main solver will have refrained +from solving. But by the time we get to error message generation, we've +un-flattened the constraint. So we must *re*-flatten it before looking +up in the instance environment, lest we only report one matching +instance when in fact there are two. + +Re-flattening is pretty easy, because we don't need to keep track of +evidence. We don't re-use the code in TcCanonical because that's in +the TcS monad, and we are in TcM here. + +Note [Quick-flatten polytypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from +flattening any further. After all, there can be no instance declarations +that match such things. And flattening under a for-all is problematic +anyway; consider C (forall a. F a) + +Note [Suggest -fprint-explicit-kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (Trac #9171) + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. +This test suggests -fprint-explicit-kinds when all the ambiguous type +variables are kind variables. +-} + +mkAmbigMsg :: Ct -> (Bool, SDoc) +mkAmbigMsg ct + | null ambig_tkvs = (False, empty) + | otherwise = (True, msg) + where + ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct) + ambig_tkvs = varSetElems ambig_tkv_set + (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs + + msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems] + = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + , ptext (sLit "Use :print or :force to determine these types")] + + | not (null ambig_tvs) + = pp_ambig (ptext (sLit "type")) ambig_tvs + + | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds + = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs + , sdocWithDynFlags suggest_explicit_kinds ] + + pp_ambig what tkvs + = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs + <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous") + + is_or_are [_] = text "is" + is_or_are _ = text "are" + + suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds] + | gopt Opt_PrintExplicitKinds dflags = empty + | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments") + +pprSkol :: SkolemInfo -> SrcLoc -> SDoc +pprSkol UnkSkol _ + = ptext (sLit "is an unknown type variable") +pprSkol skol_info tv_loc + = sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + +getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +-- Get the skolem info for a type variable +-- from the implication constraint that binds it +getSkolemInfo [] tv + = pprPanic "No skolem info:" (ppr tv) + +getSkolemInfo (implic:implics) tv + | tv `elem` ic_skols implic = ic_info implic + | otherwise = getSkolemInfo implics tv + +----------------------- +-- relevantBindings looks at the value environment and finds values whose +-- types mention any of the offending type variables. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf Trac #8233) + +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See Trac #8191 + -> ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, SDoc) +relevantBindings want_filtering ctxt ct + = do { dflags <- getDynFlags + ; (tidy_env', docs, discards) + <- go (cec_tidy ctxt) (maxRelevantBinds dflags) + emptyVarSet [] False + (tcl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones + + ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) + ; let doc = hang (ptext (sLit "Relevant bindings include")) + 2 (vcat docs $$ max_msg) + max_msg | discards + = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)") + | otherwise = empty + + ; if null docs + then return (ctxt, empty) + else do { traceTc "rb" doc + ; return (ctxt { cec_tidy = tidy_env' }, doc) } } + where + loc = ctLoc ct + lcl_env = ctLocEnv loc + ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + extra_tvs = case ctLocOrigin loc of + KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2] + _ -> emptyVarSet + + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc] + -> Bool -- True <=> some filtered out due to lack of fuel + -> [TcIdBinder] + -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out + -- because of lack of fuel + go tidy_env _ _ docs discards [] + = return (tidy_env, reverse docs, discards) + go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) + ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyVarsOfType tidy_ty + doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (ptext (sLit "bound at") + <+> ppr (getSrcLoc id)))] + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not opt_PprStyle_Debug + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then go tidy_env n_left tvs_seen docs discards tc_bndrs + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then go tidy_env n_left tvs_seen docs discards tc_bndrs + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions aleady-seen type variables, so discard it + then go tidy_env n_left tvs_seen docs True tc_bndrs + + -- Keep this binding, decrement fuel + else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } + +----------------------- +warnDefaulting :: Cts -> Type -> TcM () +warnDefaulting wanteds default_ty + = do { warn_default <- woptM Opt_WarnTypeDefaults + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyVars env0 $ + tyVarsOfCts wanteds + tidy_wanteds = mapBag (tidyCt tidy_env) wanteds + (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) + warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") + <+> quotes (ppr default_ty)) + 2 ppr_wanteds + ; setCtLoc loc $ warnTc warn_default warn_msg } + +{- +Note [Runtime skolems] +~~~~~~~~~~~~~~~~~~~~~~ +We want to give a reasonably helpful error message for ambiguity +arising from *runtime* skolems in the debugger. These +are created by in RtClosureInspect.zonkRTTIType. + +************************************************************************ +* * + Error from the canonicaliser + These ones are called *during* constraint simplification +* * +************************************************************************ +-} + +solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a +solverDepthErrorTcS cnt ev + = setCtLoc loc $ + do { pred <- zonkTcType (ctEvPred ev) + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred) + tidy_pred = tidyType tidy_env pred + ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) } + where + loc = ctEvLoc ev + depth = ctLocDepth loc + value = subGoalCounterValue cnt depth + msg CountConstraints = + vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int value + , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] + msg CountTyFunApps = + vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value + , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ] diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs new file mode 100644 index 00000000..70baef46 --- /dev/null +++ b/compiler/typecheck/TcEvidence.hs @@ -0,0 +1,1118 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module TcEvidence ( + + -- HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCast, + mkWpFun, idHsWrapper, isIdHsWrapper, pprHsWrapper, + + -- Evidence bindings + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, + EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors, + EvLit(..), evTermCoercion, + EvTypeable(..), + EvCallStack(..), + + -- TcCoercion + TcCoercion(..), LeftOrRight(..), pickLR, + mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, + mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, + mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, + tcDowngradeRole, mkTcTransAppCo, + mkTcAxiomRuleCo, mkTcPhantomCo, + tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, + isTcReflCo, getTcCoVar_maybe, + tcCoercionRole, eqVarRole, + unwrapIP, wrapIP + ) where +#include "HsVersions.h" + +import Var +import Coercion +import PprCore () -- Instance OutputableBndr TyVar +import TypeRep -- Knows type representation +import TcType +import Type +import TyCon +import Class( Class ) +import CoAxiom +import PrelNames +import VarEnv +import VarSet +import Name + +import Util +import Bag +import Pair +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +import Data.Traversable (traverse, sequenceA) +#endif +import qualified Data.Data as Data +import Outputable +import FastString +import SrcLoc +import Data.IORef( IORef ) + +{- +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| TcCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An TcCoercion is simply a Coercion whose free variables have the +boxed type (a ~ b). After we are done with typechecking the +desugarer finds the free variables, unboxes them, and creates a +resulting real Coercion with kosher free variables. + +We can use most of the Coercion "smart constructors" to build TcCoercions. +However, mkCoVarCo will not work! The equivalent is mkTcCoVarCo. + +The data type is similar to Coercion.Coercion, with the following +differences + * Most important, TcLetCo adds let-bindings for coercions. + This is what lets us unify two for-all types and generate + equality constraints underneath + + * The kind of a TcCoercion is t1 ~ t2 (resp. Coercible t1 t2) + of a Coercion is t1 ~# t2 (resp. t1 ~#R t2) + + * UnsafeCo aren't required, but we do have TcPhantomCo + + * Representation invariants are weaker: + - we are allowed to have type synonyms in TcTyConAppCo + - the first arg of a TcAppCo can be a TcTyConAppCo + - TcSubCo is not applied as deep as done with mkSubCo + Reason: they'll get established when we desugar to Coercion + + * TcAxiomInstCo has a [TcCoercion] parameter, and not a [Type] parameter. + This differs from the formalism, but corresponds to AxiomInstCo (see + [Coercion axioms applied to coercions]). + +Note [mkTcTransAppCo] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + co1 :: a ~R Maybe + co2 :: b ~R Int + +and we want + + co3 :: a b ~R Maybe Int + +This seems sensible enough. But, we can't let (co3 = co1 co2), because +that's ill-roled! Note that mkTcAppCo requires a *nominal* second coercion. + +The way around this is to use transitivity: + + co3 = (co1 _N) ; (Maybe co2) :: a b ~R Maybe Int + +Or, it's possible everything is the other way around: + + co1' :: Maybe ~R a + co2' :: Int ~R b + +and we want + + co3' :: Maybe Int ~R a b + +then + + co3' = (Maybe co2') ; (co1' _N) + +This is exactly what `mkTcTransAppCo` builds for us. Information for all +the arguments tends to be to hand at call sites, so it's quicker than +using, say, tcCoercionKind. +-} + +data TcCoercion + = TcRefl Role TcType + | TcTyConAppCo Role TyCon [TcCoercion] + | TcAppCo TcCoercion TcCoercion + | TcForAllCo TyVar TcCoercion + | TcCoVarCo EqVar + | TcAxiomInstCo (CoAxiom Branched) Int [TcCoercion] -- Int specifies branch number + -- See [CoAxiom Index] in Coercion.lhs + -- This is number of types and coercions are expected to match to CoAxiomRule + -- (i.e., the CoAxiomRules are always fully saturated) + | TcAxiomRuleCo CoAxiomRule [TcType] [TcCoercion] + | TcPhantomCo TcType TcType + | TcSymCo TcCoercion + | TcTransCo TcCoercion TcCoercion + | TcNthCo Int TcCoercion + | TcLRCo LeftOrRight TcCoercion + | TcSubCo TcCoercion + | TcCastCo TcCoercion TcCoercion -- co1 |> co2 + | TcLetCo TcEvBinds TcCoercion + | TcCoercion Coercion -- embed a Core Coercion + deriving (Data.Data, Data.Typeable) + +isEqVar :: Var -> Bool +-- Is lifted coercion variable (only!) +isEqVar v = case tyConAppTyCon_maybe (varType v) of + Just tc -> tc `hasKey` eqTyConKey + Nothing -> False + +isTcReflCo_maybe :: TcCoercion -> Maybe TcType +isTcReflCo_maybe (TcRefl _ ty) = Just ty +isTcReflCo_maybe _ = Nothing + +isTcReflCo :: TcCoercion -> Bool +isTcReflCo (TcRefl {}) = True +isTcReflCo _ = False + +getTcCoVar_maybe :: TcCoercion -> Maybe CoVar +getTcCoVar_maybe (TcCoVarCo v) = Just v +getTcCoVar_maybe _ = Nothing + +mkTcReflCo :: Role -> TcType -> TcCoercion +mkTcReflCo = TcRefl + +mkTcNomReflCo :: TcType -> TcCoercion +mkTcNomReflCo = TcRefl Nominal + +mkTcRepReflCo :: TcType -> TcCoercion +mkTcRepReflCo = TcRefl Representational + +mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion +mkTcFunCo role co1 co2 = mkTcTyConAppCo role funTyCon [co1, co2] + +mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion +mkTcTyConAppCo role tc cos -- No need to expand type synonyms + -- See Note [TcCoercions] + | Just tys <- traverse isTcReflCo_maybe cos + = TcRefl role (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TcTyConAppCo role tc cos + +-- input coercion is Nominal +-- mkSubCo will do some normalisation. We do not do it for TcCoercions, but +-- defer that to desugaring; just to reduce the code duplication a little bit +mkTcSubCo :: TcCoercion -> TcCoercion +mkTcSubCo co = ASSERT2( tcCoercionRole co == Nominal, ppr co) + TcSubCo co + +-- See Note [Role twiddling functions] in Coercion +-- | Change the role of a 'TcCoercion'. Returns 'Nothing' if this isn't +-- a downgrade. +tcDowngradeRole_maybe :: Role -- desired role + -> Role -- current role + -> TcCoercion -> Maybe TcCoercion +tcDowngradeRole_maybe Representational Nominal = Just . mkTcSubCo +tcDowngradeRole_maybe Nominal Representational = const Nothing +tcDowngradeRole_maybe Phantom _ + = panic "tcDowngradeRole_maybe Phantom" + -- not supported (not needed at the moment) +tcDowngradeRole_maybe _ Phantom = const Nothing +tcDowngradeRole_maybe _ _ = Just + +-- See Note [Role twiddling functions] in Coercion +-- | Change the role of a 'TcCoercion'. Panics if this isn't a downgrade. +tcDowngradeRole :: Role -- ^ desired role + -> Role -- ^ current role + -> TcCoercion -> TcCoercion +tcDowngradeRole r1 r2 co + = case tcDowngradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "tcDowngradeRole" (ppr r1 <+> ppr r2 <+> ppr co) + +-- | If the EqRel is ReprEq, makes a TcSubCo; otherwise, does nothing. +-- Note that the input coercion should always be nominal. +maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion +maybeTcSubCo NomEq = id +maybeTcSubCo ReprEq = mkTcSubCo + +mkTcAxInstCo :: Role -> CoAxiom br -> Int -> [TcType] -> TcCoercion +mkTcAxInstCo role ax index tys + | ASSERT2( not (role == Nominal && ax_role == Representational) , ppr (ax, tys) ) + arity == n_tys = tcDowngradeRole role ax_role $ + TcAxiomInstCo ax_br index rtys + | otherwise = ASSERT( arity < n_tys ) + tcDowngradeRole role ax_role $ + foldl TcAppCo (TcAxiomInstCo ax_br index (take arity rtys)) + (drop arity rtys) + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + arity = length $ coAxBranchTyVars branch + ax_role = coAxiomRole ax + arg_roles = coAxBranchRoles branch + rtys = zipWith mkTcReflCo (arg_roles ++ repeat Nominal) tys + +mkTcAxiomRuleCo :: CoAxiomRule -> [TcType] -> [TcCoercion] -> TcCoercion +mkTcAxiomRuleCo = TcAxiomRuleCo + +mkTcUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [TcType] -> TcCoercion +mkTcUnbranchedAxInstCo role ax tys + = mkTcAxInstCo role ax 0 tys + +mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion +-- No need to deal with TyConApp on the left; see Note [TcCoercions] +-- Second coercion *must* be nominal +mkTcAppCo (TcRefl r ty1) (TcRefl _ ty2) = TcRefl r (mkAppTy ty1 ty2) +mkTcAppCo co1 co2 = TcAppCo co1 co2 + +-- | Like `mkTcAppCo`, but allows the second coercion to be other than +-- nominal. See Note [mkTcTransAppCo]. Role r3 cannot be more stringent +-- than either r1 or r2. +mkTcTransAppCo :: Role -- ^ r1 + -> TcCoercion -- ^ co1 :: ty1a ~r1 ty1b + -> TcType -- ^ ty1a + -> TcType -- ^ ty1b + -> Role -- ^ r2 + -> TcCoercion -- ^ co2 :: ty2a ~r2 ty2b + -> TcType -- ^ ty2a + -> TcType -- ^ ty2b + -> Role -- ^ r3 + -> TcCoercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b +mkTcTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 +-- How incredibly fiddly! Is there a better way?? + = case (r1, r2, r3) of + (_, _, Phantom) + -> mkTcPhantomCo (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) + (_, _, Nominal) + -> ASSERT( r1 == Nominal && r2 == Nominal ) + mkTcAppCo co1 co2 + (Nominal, Nominal, Representational) + -> mkTcSubCo (mkTcAppCo co1 co2) + (_, Nominal, Representational) + -> ASSERT( r1 == Representational ) + mkTcAppCo co1 co2 + (Nominal, Representational, Representational) + -> go (mkTcSubCo co1) + (_ , _, Representational) + -> ASSERT( r1 == Representational && r2 == Representational ) + go co1 + where + go co1_repr + | Just (tc1b, tys1b) <- tcSplitTyConApp_maybe ty1b + , nextRole ty1b == r2 + = (co1_repr `mkTcAppCo` mkTcNomReflCo ty2a) `mkTcTransCo` + (mkTcTyConAppCo Representational tc1b + (zipWith mkTcReflCo (tyConRolesX Representational tc1b) tys1b + ++ [co2])) + + | Just (tc1a, tys1a) <- tcSplitTyConApp_maybe ty1a + , nextRole ty1a == r2 + = (mkTcTyConAppCo Representational tc1a + (zipWith mkTcReflCo (tyConRolesX Representational tc1a) tys1a + ++ [co2])) + `mkTcTransCo` + (co1_repr `mkTcAppCo` mkTcNomReflCo ty2b) + + | otherwise + = pprPanic "mkTcTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b + , ppr r2, ppr co2, ppr ty2a, ppr ty2b + , ppr r3 ]) + +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcSymCo co@(TcRefl {}) = co +mkTcSymCo (TcSymCo co) = co +mkTcSymCo co = TcSymCo co + +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcTransCo (TcRefl {}) co = co +mkTcTransCo co (TcRefl {}) = co +mkTcTransCo co1 co2 = TcTransCo co1 co2 + +mkTcNthCo :: Int -> TcCoercion -> TcCoercion +mkTcNthCo n (TcRefl r ty) = TcRefl r (tyConAppArgN n ty) +mkTcNthCo n co = TcNthCo n co + +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcLRCo lr (TcRefl r ty) = TcRefl r (pickLR lr (tcSplitAppTy ty)) +mkTcLRCo lr co = TcLRCo lr co + +mkTcPhantomCo :: TcType -> TcType -> TcCoercion +mkTcPhantomCo = TcPhantomCo + +mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion +mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys + +mkTcForAllCo :: Var -> TcCoercion -> TcCoercion +-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) +mkTcForAllCo tv (TcRefl r ty) = ASSERT( isTyVar tv ) TcRefl r (mkForAllTy tv ty) +mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co + +mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion +mkTcForAllCos tvs (TcRefl r ty) = ASSERT( all isTyVar tvs ) TcRefl r (mkForAllTys tvs ty) +mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs + +mkTcCoVarCo :: EqVar -> TcCoercion +-- ipv :: s ~ t (the boxed equality type) or Coercible s t (the boxed representational equality type) +mkTcCoVarCo ipv = TcCoVarCo ipv + -- Previously I checked for (ty ~ ty) and generated Refl, + -- but in fact ipv may not even (visibly) have a (t1 ~ t2) type, because + -- the constraint solver does not substitute in the types of + -- evidence variables as it goes. In any case, the optimisation + -- will be done in the later zonking phase + +tcCoercionKind :: TcCoercion -> Pair Type +tcCoercionKind co = go co + where + go (TcRefl _ ty) = Pair ty ty + go (TcLetCo _ co) = go co + go (TcCastCo _ co) = case getEqPredTys (pSnd (go co)) of + (ty1,ty2) -> Pair ty1 ty2 + go (TcTyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) + go (TcAppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (TcForAllCo tv co) = mkForAllTy tv <$> go co + go (TcCoVarCo cv) = eqVarKind cv + go (TcAxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + Pair tys1 tys2 = sequenceA (map go cos) + in ASSERT( cos `equalLength` tvs ) + Pair (substTyWith tvs tys1 (coAxNthLHS ax ind)) + (substTyWith tvs tys2 (coAxBranchRHS branch)) + go (TcPhantomCo ty1 ty2) = Pair ty1 ty2 + go (TcSymCo co) = swap (go co) + go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2)) + go (TcNthCo d co) = tyConAppArgN d <$> go co + go (TcLRCo lr co) = (pickLR lr . tcSplitAppTy) <$> go co + go (TcSubCo co) = go co + go (TcAxiomRuleCo ax ts cs) = + case coaxrProves ax ts (map tcCoercionKind cs) of + Just res -> res + Nothing -> panic "tcCoercionKind: malformed TcAxiomRuleCo" + go (TcCoercion co) = coercionKind co + +eqVarRole :: EqVar -> Role +eqVarRole cv = getEqPredRole (varType cv) + +eqVarKind :: EqVar -> Pair Type +eqVarKind cv + | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) + = ASSERT(tc `hasKey` eqTyConKey) + Pair ty1 ty2 + | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv)) + +tcCoercionRole :: TcCoercion -> Role +tcCoercionRole = go + where + go (TcRefl r _) = r + go (TcTyConAppCo r _ _) = r + go (TcAppCo co _) = go co + go (TcForAllCo _ co) = go co + go (TcCoVarCo cv) = eqVarRole cv + go (TcAxiomInstCo ax _ _) = coAxiomRole ax + go (TcPhantomCo _ _) = Phantom + go (TcSymCo co) = go co + go (TcTransCo co1 _) = go co1 -- same as go co2 + go (TcNthCo n co) = let Pair ty1 _ = tcCoercionKind co + (tc, _) = tcSplitTyConApp ty1 + in nthRole (go co) tc n + go (TcLRCo _ _) = Nominal + go (TcSubCo _) = Representational + go (TcAxiomRuleCo c _ _) = coaxrRole c + go (TcCastCo c _) = go c + go (TcLetCo _ c) = go c + go (TcCoercion co) = coercionRole co + + +coVarsOfTcCo :: TcCoercion -> VarSet +-- Only works on *zonked* coercions, because of TcLetCo +coVarsOfTcCo tc_co + = go tc_co + where + go (TcRefl _ _) = emptyVarSet + go (TcTyConAppCo _ _ cos) = mapUnionVarSet go cos + go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcCastCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcForAllCo _ co) = go co + go (TcCoVarCo v) = unitVarSet v + go (TcAxiomInstCo _ _ cos) = mapUnionVarSet go cos + go (TcPhantomCo _ _) = emptyVarSet + go (TcSymCo co) = go co + go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcNthCo _ co) = go co + go (TcLRCo _ co) = go co + go (TcSubCo co) = go co + go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs + `minusVarSet` get_bndrs bs + go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call + -- to evVarsOfTerm in the DEBUG check of setEvBind + go (TcAxiomRuleCo _ _ cos) = mapUnionVarSet go cos + go (TcCoercion co) = -- the use of coVarsOfTcCo in dsTcCoercion will + -- fail if there are any proper, unlifted covars + ASSERT( isEmptyVarSet (coVarsOfCo co) ) + emptyVarSet + + -- We expect only coercion bindings, so use evTermCoercion + go_bind :: EvBind -> VarSet + go_bind (EvBind _ tm) = go (evTermCoercion tm) + + get_bndrs :: Bag EvBind -> VarSet + get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet + +-- Pretty printing + +instance Outputable TcCoercion where + ppr = pprTcCo + +pprTcCo, pprParendTcCo :: TcCoercion -> SDoc +pprTcCo co = ppr_co TopPrec co +pprParendTcCo co = ppr_co TyConPrec co + +ppr_co :: TyPrec -> TcCoercion -> SDoc +ppr_co _ (TcRefl r ty) = angleBrackets (ppr ty) <> ppr_role r + +ppr_co p co@(TcTyConAppCo _ tc [_,_]) + | tc `hasKey` funTyConKey = ppr_fun_co p co + +ppr_co p (TcTyConAppCo r tc cos) = pprTcApp p ppr_co tc cos <> ppr_role r +ppr_co p (TcLetCo bs co) = maybeParen p TopPrec $ + sep [ptext (sLit "let") <+> braces (ppr bs), ppr co] +ppr_co p (TcAppCo co1 co2) = maybeParen p TyConPrec $ + pprTcCo co1 <+> ppr_co TyConPrec co2 +ppr_co p (TcCastCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 <+> ptext (sLit "|>") <+> ppr_co FunPrec co2 +ppr_co p co@(TcForAllCo {}) = ppr_forall_co p co + +ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) + +ppr_co p (TcAxiomInstCo con ind cos) + = pprPrefixApp p (ppr (getName con) <> brackets (ppr ind)) (map pprParendTcCo cos) + +ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 + <+> ptext (sLit ";") + <+> ppr_co FunPrec co2 +ppr_co p (TcPhantomCo t1 t2) = pprPrefixApp p (ptext (sLit "PhantomCo")) [pprParendType t1, pprParendType t2] +ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] +ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] +ppr_co p (TcLRCo lr co) = pprPrefixApp p (ppr lr) [pprParendTcCo co] +ppr_co p (TcSubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendTcCo co] +ppr_co p (TcAxiomRuleCo co ts ps) = maybeParen p TopPrec + $ ppr_tc_axiom_rule_co co ts ps +ppr_co p (TcCoercion co) = pprPrefixApp p (text "Core co:") [ppr co] + +ppr_tc_axiom_rule_co :: CoAxiomRule -> [TcType] -> [TcCoercion] -> SDoc +ppr_tc_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps) + where + ppTs [] = Outputable.empty + ppTs [t] = ptext (sLit "@") <> ppr_type TopPrec t + ppTs ts = ptext (sLit "@") <> + parens (hsep $ punctuate comma $ map pprType ts) + + ppPs [] = Outputable.empty + ppPs [p] = pprParendTcCo p + ppPs (p : ps) = ptext (sLit "(") <+> pprTcCo p $$ + vcat [ ptext (sLit ",") <+> pprTcCo q | q <- ps ] $$ + ptext (sLit ")") + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +ppr_fun_co :: TyPrec -> TcCoercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split :: TcCoercion -> [SDoc] + split (TcTyConAppCo _ f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: TyPrec -> TcCoercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) + +{- +************************************************************************ +* * + HsWrapper +* * +************************************************************************ +-} + +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + + | WpFun HsWrapper HsWrapper TcType TcType + -- (WpFun wrap1 wrap2 t1 t2)[e] = \(x:t1). wrap2[ e wrap1[x] ] :: t2 + -- So note that if wrap1 :: exp_arg <= act_arg + -- wrap2 :: act_res <= exp_res + -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) + -- This isn't the same as for mkTcFunCo, but it has to be this way + -- because we can't use 'sym' to flip around these HsWrappers + + | WpCast TcCoercion -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + -- At role Representational + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + deriving (Data.Data, Data.Typeable) + + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper +mkWpFun WpHole WpHole _ _ = WpHole +mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 t2 = WpFun co1 co2 t1 t2 + +mkWpCast :: TcCoercion -> HsWrapper +mkWpCast co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) + WpCast co + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mkWpEvApps (map EvId vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +mkWpLams :: [Var] -> HsWrapper +mkWpLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False + +{- +************************************************************************ +* * + Evidence bindings +* * +************************************************************************ +-} + +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + + deriving( Data.Typeable ) + +data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique + -- The Unique is only for debug printing + +instance Data.Data TcEvBinds where + -- Placeholder; we can't travers into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: VarEnv EvBind + } -- Map from evidence variables to evidence terms + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv } + +extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap +extendEvBinds bs v t + = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) } + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds bs + = foldVarEnv consBag emptyBag (ev_bind_varenv bs) + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind = EvBind EvVar EvTerm + +data EvTerm + = EvId EvId -- Any sort of evidence Id, including coercions + + | EvCoercion TcCoercion -- (Boxed) coercion bindings + -- See Note [Coercion evidence terms] + + | EvCast EvTerm TcCoercion -- d |> co, the coercion being at role representational + + | EvDFunApp DFunId -- Dictionary instance application + [Type] [EvTerm] + + | EvTupleSel EvTerm Int -- n'th component of the tuple, 0-indexed + + | EvTupleMk [EvTerm] -- tuple built from this stuff + + | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors + -- See Note [Deferring coercion errors to runtime] + -- in TcSimplify + + | EvSuperClass EvTerm Int -- n'th superclass. Used for both equalities and + -- dictionaries, even though the former have no + -- selector Id. We count up from _0_ + + | EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes. + -- Note [KnownNat & KnownSymbol and EvLit] + + | EvTypeable EvTypeable -- Dictionary for `Typeable` + + | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters + + deriving( Data.Data, Data.Typeable ) + +-- | Instructions on how to make a 'Typeable' dictionary. +data EvTypeable + = EvTypeableTyCon TyCon [Kind] + -- ^ Dicitionary for concrete type constructors. + + | EvTypeableTyApp (EvTerm,Type) (EvTerm,Type) + -- ^ Dictionary for type applications; this is used when we have + -- a type expression starting with a type variable (e.g., @Typeable (f a)@) + + | EvTypeableTyLit Type + -- ^ Dictionary for a type literal. + + deriving ( Data.Data, Data.Typeable ) + +data EvLit + = EvNum Integer + | EvStr FastString + deriving( Data.Data, Data.Typeable ) + +-- | Evidence for @CallStack@ implicit parameters. +data EvCallStack + -- See Note [Overview of implicit CallStacks] + = EvCsEmpty + | EvCsPushCall Name RealSrcSpan EvTerm + -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at + -- @loc@, in a calling context @stk@. + | EvCsTop FastString RealSrcSpan EvTerm + -- ^ @EvCsTop name loc stk@ represents a use of an implicit parameter + -- @?name@, occurring at @loc@, in a calling context @stk@. + deriving( Data.Data, Data.Typeable ) + +{- +Note [Coercion evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "coercion evidence term" takes one of these forms + co_tm ::= EvId v where v :: t1 ~ t2 + | EvCoercion co + | EvCast co_tm co + +We do quite often need to get a TcCoercion from an EvTerm; see +'evTermCoercion'. + +INVARIANT: The evidence for any constraint with type (t1~t2) is +a coercion evidence term. Consider for example + [G] d :: F Int a +If we have + ax7 a :: F Int a ~ (a ~ Bool) +then we do NOT generate the constraint + [G] (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding + g1 :: a~Bool = g |> ax7 a +and the constraint + [G] g1 :: a~Bool +See Trac [7238] and Note [Bind new Givens immediately] in TcSMonad + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + + +Note [KnownNat & KnownSymbol and EvLit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A part of the type-level literals implementation are the classes +"KnownNat" and "KnownSymbol", which provide a "smart" constructor for +defining singleton values. Here is the key stuff from GHC.TypeLits + + class KnownNat (n :: Nat) where + natSing :: SNat n + + newtype SNat (n :: Nat) = SNat Integer + +Conceptually, this class has infinitely many instances: + + instance KnownNat 0 where natSing = SNat 0 + instance KnownNat 1 where natSing = SNat 1 + instance KnownNat 2 where natSing = SNat 2 + ... + +In practice, we solve `KnownNat` predicates in the type-checker +(see typecheck/TcInteract.hs) because we can't have infinately many instances. +The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like `KnownNat`---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for `KnownNat` is just a value of the representation type, +wrapped in two newtype constructors: one to make it into a `SNat` value, +and another to make it into a `KnownNat` dictionary. + +Also note that `natSing` and `SNat` are never actually exposed from the +library---they are just an implementation detail. Instead, users see +a more convenient function, defined in terms of `natSing`: + + natVal :: KnownNat n => proxy n -> Integer + +The reason we don't use this directly in the class is that it is simpler +and more efficient to pass around an integer rather than an entier function, +especialy when the `KnowNat` evidence is packaged up in an existential. + +The story for kind `Symbol` is analogous: + * class KnownSymbol + * newtype SSymbol + * Evidence: EvLit (EvStr n) + + +Note [Overview of implicit CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations) + +The goal of CallStack evidence terms is to reify locations +in the program source as runtime values, without any support +from the RTS. We accomplish this by assigning a special meaning +to implicit parameters of type GHC.Stack.CallStack. A use of +a CallStack IP, e.g. + + head [] = error (show (?loc :: CallStack)) + head (x:_) = x + +will be solved with the source location that gave rise to the IP +constraint (here, the use of ?loc). If there is already +a CallStack IP in scope, e.g. passed-in as an argument + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?loc :: CallStack)) + head (x:_) = x + +we will push the new location onto the CallStack that was passed +in. These two cases are reflected by the EvCallStack evidence +type. In the first case, we will create an evidence term + + EvCsTop "?loc" EvCsEmpty + +and in the second we'll have a given constraint + + [G] d :: IP "loc" CallStack + +in scope, and will create an evidence term + + EvCsTop "?loc" d + +When we call a function that uses a CallStack IP, e.g. + + f = head xs + +we create an evidence term + + EvCsPushCall "head" EvCsEmpty + +again pushing onto a given evidence term if one exists. + +This provides a lightweight mechanism for building up call-stacks +explicitly, but is notably limited by the fact that the stack will +stop at the first function whose type does not include a CallStack IP. +For example, using the above definition of head: + + f :: [a] -> a + f = head + + g = f [] + +the resulting CallStack will include use of ?loc inside head and +the call to head inside f, but NOT the call to f inside g, because f +did not explicitly request a CallStack. + +Important Details: +- GHC should NEVER report an insoluble CallStack constraint. + +- A CallStack (defined in GHC.Stack) is a [(String, SrcLoc)], where the String + is the name of the binder that is used at the SrcLoc. SrcLoc is defined in + GHC.SrcLoc and contains the package/module/file name, as well as the full + source-span. Both CallStack and SrcLoc are kept abstract so only GHC can + construct new values. + +- Consider the use of ?stk in: + + head :: (?stk :: CallStack) => [a] -> a + head [] = error (show ?stk) + + When solving the use of ?stk we'll have a given + + [G] d :: IP "stk" CallStack + + in scope. In the interaction phase, GHC would normally solve the use of ?stk + directly from the given, i.e. re-using the dicionary. But this is NOT what we + want! We want to generate a *new* CallStack with ?loc's SrcLoc pushed onto + the given CallStack. So we must take care in TcInteract.interactDict to + prioritize solving wanted CallStacks. + +- We will automatically solve any wanted CallStack regardless of the name of the + IP, i.e. + + f = show (?stk :: CallStack) + g = show (?loc :: CallStack) + + are both valid. However, we will only push new SrcLocs onto existing + CallStacks when the IP names match, e.g. in + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?stk :: CallStack)) + + the printed CallStack will NOT include head's call-site. This reflects the + standard scoping rules of implicit-parameters. (See TcInteract.interactDict) + +- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. + The desugarer will need to unwrap the IP newtype before pushing a new + call-site onto a given stack (See DsBinds.dsEvCallStack) + +- We only want to intercept constraints that arose due to the use of an IP or a + function call. In particular, we do NOT want to intercept the + + (?stk :: CallStack) => [a] -> a + ~ + (?stk :: CallStack) => [a] -> a + + constraint that arises from the ambiguity check on `head`s type signature. + (See TcEvidence.isCallStackIP) +-} + +mkEvCast :: EvTerm -> TcCoercion -> EvTerm +mkEvCast ev lco + | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco])) + isTcReflCo lco = ev + | otherwise = EvCast ev lco + +mkEvTupleSelectors :: EvTerm -> [TcPredType] -> [(TcPredType, EvTerm)] +mkEvTupleSelectors ev preds = zipWith mk_pr preds [0..] + where + mk_pr pred i = (pred, EvTupleSel ev i) + +mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)] +mkEvScSelectors ev cls tys + = zipWith mk_pr (immSuperClasses cls tys) [0..] + where + mk_pr pred i = (pred, EvSuperClass ev i) + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +isEmptyTcEvBinds (EvBinds b) = isEmptyBag b +isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" + + +evTermCoercion :: EvTerm -> TcCoercion +-- Applied only to EvTerms of type (s~t) +-- See Note [Coercion evidence terms] +evTermCoercion (EvId v) = mkTcCoVarCo v +evTermCoercion (EvCoercion co) = co +evTermCoercion (EvCast tm co) = TcCastCo (evTermCoercion tm) co +evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm) + +evVarsOfTerm :: EvTerm -> VarSet +evVarsOfTerm (EvId v) = unitVarSet v +evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co +evVarsOfTerm (EvDFunApp _ _ evs) = evVarsOfTerms evs +evVarsOfTerm (EvTupleSel v _) = evVarsOfTerm v +evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v +evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co +evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs +evVarsOfTerm (EvDelayedError _ _) = emptyVarSet +evVarsOfTerm (EvLit _) = emptyVarSet +evVarsOfTerm (EvTypeable ev) = evVarsOfTypeable ev +evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs + +evVarsOfTerms :: [EvTerm] -> VarSet +evVarsOfTerms = mapUnionVarSet evVarsOfTerm + +evVarsOfTypeable :: EvTypeable -> VarSet +evVarsOfTypeable ev = + case ev of + EvTypeableTyCon _ _ -> emptyVarSet + EvTypeableTyApp e1 e2 -> evVarsOfTerms (map fst [e1,e2]) + EvTypeableTyLit _ -> emptyVarSet + +evVarsOfCallStack :: EvCallStack -> VarSet +evVarsOfCallStack cs = case cs of + EvCsEmpty -> emptyVarSet + EvCsTop _ _ tm -> evVarsOfTerm tm + EvCsPushCall _ _ tm -> evVarsOfTerm tm + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn + +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +-- In debug mode, print the wrapper +-- otherwise just print what's inside +pprHsWrapper doc wrap + = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> + help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + <+> pprParendTcCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + + pp_bndr v = pprBndr LambdaBind v <> dot + + add_parens, no_parens :: SDoc -> Bool -> SDoc + add_parens d True = parens d + add_parens d False = d + no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) + +instance Outputable EvBind where + ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ] + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + +instance Outputable EvTerm where + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs + ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvLit l) = ppr l + ppr (EvCallStack cs) = ppr cs + ppr (EvDelayedError ty msg) = ptext (sLit "error") + <+> sep [ char '@' <> ppr ty, ppr msg ] + ppr (EvTypeable ev) = ppr ev + +instance Outputable EvLit where + ppr (EvNum n) = integer n + ppr (EvStr s) = text (show s) + +instance Outputable EvTypeable where + ppr ev = + case ev of + EvTypeableTyCon tc ks -> parens (ppr tc <+> sep (map ppr ks)) + EvTypeableTyApp t1 t2 -> parens (ppr (fst t1) <+> ppr (fst t2)) + EvTypeableTyLit x -> ppr x + +instance Outputable EvCallStack where + ppr EvCsEmpty + = ptext (sLit "[]") + ppr (EvCsTop name loc tm) + = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm + ppr (EvCsPushCall name loc tm) + = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm + +---------------------------------------------------------------------- +-- Helper functions for dealing with IP newtype-dictionaries +---------------------------------------------------------------------- + +-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary +-- to expose the underlying value. We expect the 'Type' to have the form +-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`. +unwrapIP :: Type -> Coercion +unwrapIP ty = + case unwrapNewTyCon_maybe tc of + Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys + Nothing -> pprPanic "unwrapIP" $ + text "The dictionary for" <+> quotes (ppr tc) + <+> text "is not a newtype!" + where + (tc, tys) = splitTyConApp ty + +-- | Create a 'Coercion' that wraps a value in an implicit-parameter +-- dictionary. See 'unwrapIP'. +wrapIP :: Type -> Coercion +wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs new file mode 100644 index 00000000..96ab8a96 --- /dev/null +++ b/compiler/typecheck/TcExpr.hs @@ -0,0 +1,1584 @@ +{- +c% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcExpr]{Typecheck an expression} +-} + +{-# LANGUAGE CPP #-} + +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, + tcSyntaxOp, tcCheckId, + addExprErrCtxt) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) +#ifdef GHCI +import DsMeta( liftStringName, liftName ) +#endif + +import HsSyn +import TcHsSyn +import TcRnMonad +import TcUnify +import BasicTypes +import Inst +import TcBinds +import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) +import TcEnv +import TcArrows +import TcMatches +import TcHsType +import TcPatSyn( tcPatSynBuilderOcc ) +import TcPat +import TcMType +import TcType +import DsMonad +import Id +import ConLike +import DataCon +import RdrName +import Name +import TyCon +import Type +import TcEvidence +import Var +import VarSet +import VarEnv +import TysWiredIn +import TysPrim( intPrimTy, addrPrimTy ) +import PrimOp( tagToEnumKey ) +import PrelNames +import DynFlags +import SrcLoc +import Util +import ListSetOps +import Maybes +import ErrUtils +import Outputable +import FastString +import Control.Monad +import Class(classTyCon) +import Data.Function +import Data.List +import qualified Data.Set as Set + +{- +************************************************************************ +* * +\subsection{Main wrappers} +* * +************************************************************************ +-} + +tcPolyExpr, tcPolyExprNC + :: LHsExpr Name -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr TcId) -- Generalised expr with expected type + +-- tcPolyExpr is a convenient place (frequent but not too frequent) +-- place to add context information. +-- The NC version does not do so, usually because the caller wants +-- to do so himself. + +tcPolyExpr expr res_ty + = addExprErrCtxt expr $ + do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty } + +tcPolyExprNC expr res_ty + = do { traceTc "tcPolyExprNC" (ppr res_ty) + ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho -> + tcMonoExprNC expr rho + ; return (mkLHsWrap gen_fn expr') } + +--------------- +tcMonoExpr, tcMonoExprNC + :: LHsExpr Name -- Expression to type check + -> TcRhoType -- Expected type (could be a type variable) + -- Definitely no foralls at the top + -> TcM (LHsExpr TcId) + +tcMonoExpr expr res_ty + = addErrCtxt (exprCtxt expr) $ + tcMonoExprNC expr res_ty + +tcMonoExprNC (L loc expr) res_ty + = ASSERT( not (isSigmaTy res_ty) ) + setSrcSpan loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +--------------- +tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +-- Infer a *rho*-type. This is, in effect, a special case +-- for ids and partial applications, so that if +-- f :: Int -> (forall a. a -> a) -> Int +-- then we can infer +-- f 3 :: (forall a. a -> a) -> Int +-- And that in turn is useful +-- (a) for the function part of any application (see tcApp) +-- (b) for the special rule for '$' +tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) + +tcInferRhoNC (L loc expr) + = setSrcSpan loc $ + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } + +tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId) +tcHole occ res_ty + = do { ty <- newFlexiTyVarTy liftedTypeKind + ; name <- newSysName occ + ; let ev = mkLocalId name ty + ; loc <- getCtLoc HoleOrigin + ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ + , cc_hole = ExprHole } + ; emitInsoluble can + ; tcWrapResult (HsVar ev) ty res_ty } + +{- +************************************************************************ +* * + tcExpr: the main expression typechecker +* * +************************************************************************ +-} + +tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) +tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check + = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) + +tcExpr (HsVar name) res_ty = tcCheckId name res_ty + +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty + +tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit + ; tcWrapResult (HsLit lit) lit_ty res_ty } + +tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar expr') } + +tcExpr (HsSCC src lbl expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsSCC src lbl expr') } + +tcExpr (HsTickPragma src info expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsTickPragma src info expr') } + +tcExpr (HsCoreAnn src lbl expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsCoreAnn src lbl expr') } + +tcExpr (HsOverLit lit) res_ty + = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty + ; return (HsOverLit lit') } + +tcExpr (NegApp expr neg_expr) res_ty + = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr + (mkFunTy res_ty res_ty) + ; expr' <- tcMonoExpr expr res_ty + ; return (NegApp expr' neg_expr') } + +tcExpr (HsIPVar x) res_ty + = do { let origin = IPOccOrigin x + ; ipClass <- tcLookupClass ipClassName + {- Implicit parameters must have a *tau-type* not a. + type scheme. We enforce this by creating a fresh + type variable as its type. (Because res_ty may not + be a tau-type.) -} + ; ip_ty <- newFlexiTyVarTy openTypeKind + ; let ip_name = mkStrLitTy (hsIPNameFS x) + ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) + ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } + where + -- Coerces a dictionary for `IP "x" t` into `t`. + fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + unwrapIP $ mkClassPred ipClass [x,ty] + +tcExpr (HsLam match) res_ty + = do { (co_fn, match') <- tcMatchLambda match res_ty + ; return (mkHsWrap co_fn (HsLam match')) } + +tcExpr e@(HsLamCase _ matches) res_ty + = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty + ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty + ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' } + where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e) + , ptext (sLit "requires")] + match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } + +tcExpr (ExprWithTySig expr sig_ty wcs) res_ty + = do { nwc_tvs <- mapM newWildcardVarMetaKind wcs + ; tcExtendTyVarEnv nwc_tvs $ do { + sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty + ; (gen_fn, expr') + <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> + + -- Remember to extend the lexical type-variable environment + -- See Note [More instantiated than scoped] in TcBinds + tcExtendTyVarEnv2 + [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $ + + tcMonoExprNC expr res_ty + + ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty + + ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty + ; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $ + emitWildcardHoleConstraints (zip wcs nwc_tvs) + ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } } + +tcExpr (HsType ty) _ + = failWithTc (text "Can't handle type argument:" <+> ppr ty) + -- This is the syntax for type applications that I was planning + -- but there are difficulties (e.g. what order for type args) + -- so it's not enabled yet. + -- Can't eliminate it altogether from the parser, because the + -- same parser parses *patterns*. +tcExpr (HsUnboundVar v) res_ty + = tcHole (rdrNameOcc v) res_ty + +{- +************************************************************************ +* * + Infix operators and sections +* * +************************************************************************ + +Note [Left sections] +~~~~~~~~~~~~~~~~~~~~ +Left sections, like (4 *), are equivalent to + \ x -> (*) 4 x, +or, if PostfixOperators is enabled, just + (*) 4 +With PostfixOperators we don't actually require the function to take +two arguments at all. For example, (x `not`) means (not x); you get +postfix operators! Not Haskell 98, but it's less work and kind of +useful. + +Note [Typing rule for ($)] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +People write + runST $ blah +so much, where + runST :: (forall s. ST s a) -> a +that I have finally given in and written a special type-checking +rule just for saturated appliations of ($). + * Infer the type of the first argument + * Decompose it; should be of form (arg2_ty -> res_ty), + where arg2_ty might be a polytype + * Use arg2_ty to typecheck arg2 + +Note [Typing rule for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow + x `seq` (# p,q #) +which suggests this type for seq: + seq :: forall (a:*) (b:??). a -> b -> b, +with (b:??) meaning that be can be instantiated with an unboxed tuple. +But that's ill-kinded! Function arguments can't be unboxed tuples. +And indeed, you could not expect to do this with a partially-applied +'seq'; it's only going to work when it's fully applied. so it turns +into + case x of _ -> (# p,q #) + +For a while I slid by by giving 'seq' an ill-kinded type, but then +the simplifier eta-reduced an application of seq and Lint blew up +with a kind error. It seems more uniform to treat 'seq' as it it +was a language construct. + +See Note [seqId magic] in MkId, and +-} + +tcExpr (OpApp arg1 op fix arg2) res_ty + | (L loc (HsVar op_name)) <- op + , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] + = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind + ; let arg2_ty = res_ty + ; arg1' <- tcArg op (arg1, arg1_ty, 1) + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; op_id <- tcLookupId op_name + ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id)) + ; return $ OpApp arg1' op' fix arg2' } + + | (L loc (HsVar op_name)) <- op + , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + = do { traceTc "Application rule" (ppr op) + ; (arg1', arg1_ty) <- tcInferRho arg1 + + ; let doc = ptext (sLit "The first argument of ($) takes") + ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty + + -- We have (arg1 $ arg2) + -- So: arg1_ty = arg2_ty -> op_res_ty + -- where arg2_ty maybe polymorphic; that's the point + + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; co_b <- unifyType op_res_ty res_ty -- op_res ~ res + + -- Make sure that the argument type has kind '*' + -- ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r + -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 + -- (which gives a seg fault) + -- We do this by unifying with a MetaTv; but of course + -- it must allow foralls in the type it unifies with (hence ReturnTv)! + -- + -- The *result* type can have any kind (Trac #8739), + -- so we don't need to check anything for that + ; a2_tv <- newReturnTyVar liftedTypeKind + ; let a2_ty = mkTyVarTy a2_tv + ; co_a <- unifyType arg2_ty a2_ty -- arg2 ~ a2 + + ; op_id <- tcLookupId op_name + ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id)) + ; return $ + OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $ + mkLHsWrapCo co_arg1 arg1') + op' fix + (mkLHsWrapCo co_a arg2') } + + | otherwise + = do { traceTc "Non Application rule" (ppr op) + ; (op', op_ty) <- tcInferFun op + ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty + ; co_res <- unifyType op_res_ty res_ty + ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys + ; return $ mkHsWrapCo co_res $ + OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } + +-- Right sections, equivalent to \ x -> x `op` expr, or +-- \ x -> op x expr + +tcExpr (SectionR op arg2) res_ty + = do { (op', op_ty) <- tcInferFun op + ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty + ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; return $ mkHsWrapCo co_res $ + SectionR (mkLHsWrapCo co_fn op') arg2' } + +tcExpr (SectionL arg1 op) res_ty + = do { (op', op_ty) <- tcInferFun op + ; dflags <- getDynFlags -- Note [Left sections] + ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 + | otherwise = 2 + + ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty + ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty + ; arg1' <- tcArg op (arg1, arg1_ty, 1) + ; return $ mkHsWrapCo co_res $ + SectionL arg1' (mkLHsWrapCo co_fn op') } + +tcExpr (ExplicitTuple tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let tup_tc = tupleTyCon (boxityNormalTupleSort boxity) (length tup_args) + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + ; tup_args1 <- tcTupArgs tup_args arg_tys + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } + + | otherwise + = -- The tup_args are a mixture of Present and Missing (for tuple sections) + do { let kind = case boxity of { Boxed -> liftedTypeKind + ; Unboxed -> openTypeKind } + arity = length tup_args + tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity + + ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind + ; let actual_res_ty + = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args] + (mkTyConApp tup_tc arg_tys) + + ; coi <- unifyType actual_res_ty res_ty + + -- Handle tuple sections where + ; tup_args1 <- tcTupArgs tup_args arg_tys + + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } + +tcExpr (ExplicitList _ witness exprs) res_ty + = case witness of + Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') } + + Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') } + where tc_elt elt_ty expr = tcPolyExpr expr elt_ty + +tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } + where + tc_elt elt_ty expr = tcPolyExpr expr elt_ty + +{- +************************************************************************ +* * + Let, case, if, do +* * +************************************************************************ +-} + +tcExpr (HsLet binds expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet binds' expr') } + +tcExpr (HsCase scrut matches) exp_ty + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + (scrut', scrut_ty) <- tcInferRho scrut + + ; traceTc "HsCase" (ppr scrut_ty) + ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty + ; return (HsCase scrut' matches') } + where + match_ctxt = MC { mc_what = CaseAlt, + mc_body = tcBody } + +tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcMonoExpr pred boolTy + ; b1' <- tcMonoExpr b1 res_ty + ; b2' <- tcMonoExpr b2 res_ty + ; return (HsIf Nothing pred' b1' b2') } + +tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] + = do { pred_ty <- newFlexiTyVarTy openTypeKind + ; b1_ty <- newFlexiTyVarTy openTypeKind + ; b2_ty <- newFlexiTyVarTy openTypeKind + ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcMonoExpr b1 b1_ty + ; b2' <- tcMonoExpr b2 b2_ty + -- Fundamentally we are just typing (ifThenElse e1 e2 e3) + -- so maybe we should use the code for function applications + -- (which would allow ifThenElse to be higher rank). + -- But it's a little awkward, so I'm leaving it alone for now + -- and it maintains uniformity with other rebindable syntax + ; return (HsIf (Just fun') pred' b1' b2') } + +tcExpr (HsMultiIf _ alts) res_ty + = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + ; return $ HsMultiIf res_ty alts' } + where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + +tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty + +tcExpr (HsProc pat cmd) res_ty + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } + +tcExpr (HsStatic expr) res_ty + = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName + ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty + ; (expr', lie) <- captureConstraints $ + addErrCtxt (hang (ptext (sLit "In the body of a static form:")) + 2 (ppr expr) + ) $ + tcPolyExprNC expr expr_ty + -- Require the type of the argument to be Typeable. + -- The evidence is not used, but asking the constraint ensures that + -- the current implementation is as restrictive as future versions + -- of the StaticPointers extension. + ; typeableClass <- tcLookupClass typeableClassName + ; _ <- emitWanted StaticOrigin $ + mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + -- Insert the static form in a global list for later validation. + ; stWC <- tcg_static_wc <$> getGblEnv + ; updTcRef stWC (andWC lie) + ; return $ mkHsWrapCo co $ HsStatic expr' + } + +{- +Note [Rebindable syntax for if] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' uses the most flexible possible type +for conditionals: + ifThenElse :: p -> b1 -> b2 -> res +to support expressions like this: + + ifThenElse :: Maybe a -> (a -> b) -> b -> b + ifThenElse (Just a) f _ = f a + ifThenElse Nothing _ e = e + + example :: String + example = if Just 2 + then \v -> show v + else "No value" + + +************************************************************************ +* * + Record construction and update +* * +************************************************************************ +-} + +tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty + = do { data_con <- tcLookupDataCon con_name + + -- Check for missing fields + ; checkMissingFields data_con rbinds + + ; (con_expr, con_tau) <- tcInferId con_name + ; let arity = dataConSourceArity data_con + (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity + con_id = dataConWrapId data_con + + ; co_res <- unifyType actual_res_ty res_ty + ; rbinds' <- tcRecordBinds data_con arg_tys rbinds + ; return $ mkHsWrapCo co_res $ + RecordCon (L loc con_id) con_expr rbinds' } + +{- +Note [Type of a record update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main complication with RecordUpd is that we need to explicitly +handle the *non-updated* fields. Consider: + + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } + + upd :: T a b c -> (b',c) -> T a b' c + upd t x = t { fb = x} + +The result type should be (T a b' c) +not (T a b c), because 'b' *is not* mentioned in a non-updated field +not (T a b' c'), because 'c' *is* mentioned in a non-updated field +NB that it's not good enough to look at just one constructor; we must +look at them all; cf Trac #3219 + +After all, upd should be equivalent to: + upd t x = case t of + MkT1 p q -> MkT1 p x + MkT2 a b -> MkT2 p b + MkT3 d -> error ... + +So we need to give a completely fresh type to the result record, +and then constrain it by the fields that are *not* updated ("p" above). +We call these the "fixed" type variables, and compute them in getFixedTyVars. + +Note that because MkT3 doesn't contain all the fields being updated, +its RHS is simply an error, so it doesn't impose any type constraints. +Hence the use of 'relevant_cont'. + +Note [Implicit type sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also take into account any "implicit" non-update fields. For example + data T a b where { MkT { f::a } :: T a a; ... } +So the "real" type of MkT is: forall ab. (a~b) => a -> T a b + +Then consider + upd t x = t { f=x } +We infer the type + upd :: T a b -> a -> T a b + upd (t::T a b) (x::a) + = case t of { MkT (co:a~b) (_:a) -> MkT co x } +We can't give it the more general type + upd :: T a b -> c -> T c b + +Note [Criteria for update] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow update for existentials etc, provided the updated +field isn't part of the existential. For example, this should be ok. + data T a where { MkT { f1::a, f2::b->b } :: T a } + f :: T a -> b -> T b + f t b = t { f1=b } + +The criterion we use is this: + + The types of the updated fields + mention only the universally-quantified type variables + of the data constructor + +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in TcTyClsDecls), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + +In principle one could go further, and allow + g :: T a -> T a + g t = t { f2 = \x -> x } +because the expression is polymorphic...but that seems a bridge too far. + +Note [Data family example] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + data instance T (a,b) = MkT { x::a, y::b } + ---> + data :TP a b = MkT { a::a, y::b } + coTP a b :: T (a,b) ~ :TP a b + +Suppose r :: T (t1,t2), e :: t3 +Then r { x=e } :: T (t3,t1) + ---> + case r |> co1 of + MkT x y -> MkT e y |> co2 + where co1 :: T (t1,t2) ~ :TP t1 t2 + co2 :: :TP t3 t2 ~ T (t3,t2) +The wrapping with co2 is done by the constructor wrapper for MkT + +Outgoing invariants +~~~~~~~~~~~~~~~~~~~ +In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): + + * cons are the data constructors to be updated + + * in_inst_tys, out_inst_tys have same length, and instantiate the + *representation* tycon of the data cons. In Note [Data + family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] +-} + +tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty + = ASSERT( notNull upd_fld_names ) + do { + -- STEP 0 + -- Check that the field names are really field names + ; sel_ids <- mapM tcLookupField upd_fld_names + -- The renamer has already checked that + -- selectors are all in scope + ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) + | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, + not (isRecordSelector sel_id), -- Excludes class ops + let L loc fld_name = hsRecFieldId (unLoc fld) ] + ; unless (null bad_guys) (sequence bad_guys >> failM) + + -- STEP 1 + -- Figure out the tycon and data cons from the first field name + ; let -- It's OK to use the non-tc splitters here (for a selector) + sel_id : _ = sel_ids + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label + -- NB: for a data type family, the tycon is the instance tycon + + relevant_cons = filter is_relevant data_cons + is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names + -- A constructor is only relevant to this process if + -- it contains *all* the fields that are being updated + -- Other ones will cause a runtime error if they occur + + -- Take apart a representative constructor + con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + con1_flds = dataConFieldLabels con1 + con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) + + -- Step 2 + -- Check that at least one constructor has all the named fields + -- i.e. has an empty set of bad fields returned by badFields + ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons) + + -- STEP 3 Note [Criteria for update] + -- Check that each updated field is polymorphic; that is, its type + -- mentions only the universally-quantified variables of the data con + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + upd_flds1_w_tys = filter is_updated flds1_w_tys + is_updated (fld,_) = fld `elem` upd_fld_names + + bad_upd_flds = filter bad_fld upd_flds1_w_tys + con1_tv_set = mkVarSet con1_tvs + bad_fld (fld, ty) = fld `elem` upd_fld_names && + not (tyVarsOfType ty `subVarSet` con1_tv_set) + ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + + -- STEP 4 Note [Type of a record update] + -- Figure out types for the scrutinee and result + -- Both are of form (T a b c), with fresh type variables, but with + -- common variables where the scrutinee and result must have the same type + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs + + mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) + -- Deals with instantiation of kind variables + -- c.f. TcMType.tcInstTyVars + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type + = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + | otherwise -- Fresh type, of correct kind + = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv new_ty, new_ty) } + + ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs + ; let result_inst_tys = mkTyVarTys con1_tvs' + + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst + (con1_tvs `zip` result_inst_tys) + + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys + + ; co_res <- unifyType rec_res_ty res_ty + + -- STEP 5 + -- Typecheck the thing to be updated, and the bindings + ; record_expr' <- tcMonoExpr record_expr scrut_ty + ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds + + -- STEP 6: Deal with the stupid theta + ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) + ; instStupidTheta RecordUpdOrigin theta' + + -- Step 7: make a cast for the scrutinee, in the case that it's from a type family + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys) + | otherwise + = idHsWrapper + -- Phew! + ; return $ mkHsWrapCo co_res $ + RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' + relevant_cons scrut_inst_tys result_inst_tys } + where + upd_fld_names = hsRecFields rbinds + + getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet + -- These tyvars must not change across the updates + getFixedTyVars tvs1 cons + = mkVarSet [tv1 | con <- cons + , let (tvs, theta, arg_tys, _) = dataConSig con + flds = dataConFieldLabels con + fixed_tvs = exactTyVarsOfTypes fixed_tys + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyVarsOfTypes theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implicit type sharing] + + fixed_tys = [ty | (fld,ty) <- zip flds arg_tys + , not (fld `elem` upd_fld_names)] + , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs + , tv `elemVarSet` fixed_tvs ] + +{- +************************************************************************ +* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +* * +************************************************************************ +-} + +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty + +tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar + ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) + (idName enumFromToP) elt_ty + ; return $ mkHsWrapCo coi + (PArrSeq enum_from_to (FromTo expr1' expr2')) } + +tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; expr3' <- tcPolyExpr expr3 elt_ty + ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar + ; eft <- newMethodFromName (PArrSeqOrigin seq) + (idName enumFromThenToP) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi + (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } + +tcExpr (PArrSeq _ _) _ + = panic "TcExpr.tcExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer shouldn't have + -- let it through + +{- +************************************************************************ +* * + Template Haskell +* * +************************************************************************ +-} + +tcExpr (HsSpliceE is_ty splice) res_ty + = ASSERT( is_ty ) -- Untyped splices are expanded by the renamer + tcSpliceExpr splice res_ty + +tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty +tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty + +{- +************************************************************************ +* * + Catch-all +* * +************************************************************************ +-} + +tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) + -- Include ArrForm, ArrApp, which shouldn't appear at all + -- Also HsTcBracketOut, HsQuasiQuoteE + +{- +************************************************************************ +* * + Arithmetic sequences [a..b] etc +* * +************************************************************************ +-} + +tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType + -> TcM (HsExpr TcId) + +tcArithSeq witness seq@(From expr) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <- tcPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; expr3' <- tcPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType + -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id)) +arithSeqEltType Nothing res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (coi, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; return (coi, elt_ty, Just fl') } + +{- +************************************************************************ +* * + Applications +* * +************************************************************************ +-} + +tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args + -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args + +tcApp (L _ (HsPar e)) args res_ty + = tcApp e args res_ty + +tcApp (L _ (HsApp e1 e2)) args res_ty + = tcApp e1 (e2:args) res_ty -- Accumulate the arguments + +tcApp (L loc (HsVar fun)) args res_ty + | fun `hasKey` tagToEnumKey + , [arg] <- args + = tcTagToEnum loc fun arg res_ty + + | fun `hasKey` seqIdKey + , [arg1,arg2] <- args + = tcSeq loc fun arg1 arg2 res_ty + +tcApp fun args res_ty + = do { -- Type-check the function + ; (fun1, fun_tau) <- tcInferFun fun + + -- Extract its argument types + ; (co_fun, expected_arg_tys, actual_res_ty) + <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau + + -- Typecheck the result, thereby propagating + -- info (if any) from result into the argument types + -- Both actual_res_ty and res_ty are deeply skolemised + -- Rather like tcWrapResult, but (perhaps for historical reasons) + -- we do this before typechecking the arguments + ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $ + tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty + + -- Typecheck the arguments + ; args1 <- tcArgs fun args expected_arg_tys + + -- Assemble the result + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = mkLHsWrap wrap_res (foldl mkHsApp fun2 args1) + + ; return (unLoc app) } + + +mk_app_msg :: LHsExpr Name -> SDoc +mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) + , ptext (sLit "is applied to")] + +---------------- +tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +-- Infer and instantiate the type of a function +tcInferFun (L loc (HsVar name)) + = do { (fun, ty) <- setSrcSpan loc (tcInferId name) + -- Don't wrap a context around a plain Id + ; return (L loc fun, ty) } + +tcInferFun fun + = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun) + + -- Zonk the function type carefully, to expose any polymorphism + -- E.g. (( \(x::forall a. a->a). blah ) e) + -- We can see the rank-2 type of the lambda in time to generalise e + ; fun_ty' <- zonkTcType fun_ty + + ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' + ; return (mkLHsWrap wrap fun, rho) } + +---------------- +tcArgs :: LHsExpr Name -- The function (for error messages) + -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types + -> TcM [LHsExpr TcId] -- Resulting args + +tcArgs fun args expected_arg_tys + = mapM (tcArg fun) (zip3 args expected_arg_tys [1..]) + +---------------- +tcArg :: LHsExpr Name -- The function (for error messages) + -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type + -> TcM (LHsExpr TcId) -- Resulting argument +tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) + (tcPolyExprNC arg ty) + +---------------- +tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId] +tcTupArgs args tys + = ASSERT( equalLength args tys ) mapM go (args `zip` tys) + where + go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) + go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (L l (Present expr')) } + +---------------- +unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType + -> TcM (TcCoercion, [TcSigmaType], TcRhoType) +-- A wrapper for matchExpectedFunTys +unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty + where + herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes") + +--------------------------- +tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) +-- Typecheck a syntax operator, checking that it has the specified type +-- The operator is always a variable at this stage (i.e. renamer output) +-- This version assumes res_ty is a monotype +tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op + ; tcWrapResult expr rho res_ty } +tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) + +{- +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. This is when we might detect a +too-few args situation. (One can think of cases when the opposite +order would give a better error message.) +experimenting with putting this first. + +Here's an example where it actually makes a real difference + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) + + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) + +With the change, f1 will type-check, because the 'Char' info from +the signature is propagated into MkQ's argument. With the check +in the other order, the extra signature in f2 is reqd. + + +************************************************************************ +* * + tcInferId +* * +************************************************************************ +-} + +tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) +tcCheckId name res_ty + = do { (expr, actual_res_ty) <- tcInferId name + ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) + ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $ + tcWrapResult expr actual_res_ty res_ty } + +------------------------ +tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType) +-- Infer type, and deeply instantiate +tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n + +------------------------ +tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) +-- Look up an occurrence of an Id, and instantiate it (deeply) + +tcInferIdWithOrig orig id_name + | id_name `hasKey` tagToEnumKey + = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument")) + -- tcApp catches the case (tagToEnum# arg) + + | id_name `hasKey` assertIdKey + = do { dflags <- getDynFlags + ; if gopt Opt_IgnoreAsserts dflags + then tc_infer_id orig id_name + else tc_infer_assert dflags orig } + + | otherwise + = tc_infer_id orig id_name + +tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType) +-- Deal with an occurrence of 'assert' +-- See Note [Adding the implicit parameter to 'assert'] +tc_infer_assert dflags orig + = do { sloc <- getSrcSpanM + ; assert_error_id <- tcLookupId assertErrorName + ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id) + ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of + Nothing -> pprPanic "assert type" (ppr id_rho) + Just arg_res -> arg_res + ; ASSERT( arg_ty `tcEqType` addrPrimTy ) + return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id))) + (L sloc (srcSpanPrimLit dflags sloc)) + , res_ty) } + +tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) +-- Return type is deeply instantiated +tc_infer_id orig id_name + = do { thing <- tcLookup id_name + ; case thing of + ATcId { tct_id = id } + -> do { check_naughty id -- Note [Local record selectors] + ; checkThLocalId id + ; inst_normal_id id } + + AGlobal (AnId id) + -> do { check_naughty id + ; inst_normal_id id } + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + AGlobal (AConLike cl) -> case cl of + RealDataCon con -> inst_data_con con + PatSynCon ps -> tcPatSynBuilderOcc orig ps + + _ -> failWithTc $ + ppr thing <+> ptext (sLit "used where a value identifier was expected") } + where + inst_normal_id id + = do { (wrap, rho) <- deeplyInstantiate orig (idType id) + ; return (mkHsWrap wrap (HsVar id), rho) } + + inst_data_con con + -- For data constructors, + -- * Must perform the stupid-theta check + -- * No need to deeply instantiate because type has all foralls at top + = do { let wrap_id = dataConWrapId con + (tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id) + ; (subst, tvs') <- tcInstTyVars tvs + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + rho' = substTy subst rho + ; wrap <- instCall orig tys' theta' + ; addDataConStupidTheta con tys' + ; return (mkHsWrap wrap (HsVar wrap_id), rho') } + + check_naughty id + | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id) + | otherwise = return () + +srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId +srcSpanPrimLit dflags span + = HsLit (HsStringPrim "" (unsafeMkByteString + (showSDocOneLine dflags (ppr span)))) + +{- +Note [Adding the implicit parameter to 'assert'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27" +e1 e2). This isn't really the Right Thing because there's no way to +"undo" if you want to see the original source code in the typechecker +output. We'll have fix this in due course, when we care more about +being able to reconstruct the exact original program. + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude, because it relies on our +knowing *now* that the type is ok, which in turn relies on the +eager-unification part of the type checker pushing enough information +here. In theory the Right Thing to do is to have a new form of +constraint but I definitely cannot face that! And it works ok as-is. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +When data type families are involved it's a bit more complicated. + data family F a + data instance F [Int] = A | B | C +Then we want to generate something like + tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] +Usually that coercion is hidden inside the wrappers for +constructors of F [Int] but here we have to do it explicitly. + +It's all grotesquely complicated. +-} + +tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name + -> TcRhoType -> TcM (HsExpr TcId) +-- (seq e1 e2) :: res_ty +-- We need a special typing rule because res_ty can be unboxed +tcSeq loc fun_name arg1 arg2 res_ty + = do { fun <- tcLookupId fun_name + ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1) + ; arg2' <- tcMonoExpr arg2 res_ty + ; let fun' = L loc (HsWrap ty_args (HsVar fun)) + ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty + ; return (HsApp (L loc (HsApp fun' arg1')) arg2') } + +tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) +-- tagToEnum# :: forall a. Int# -> a +-- See Note [tagToEnum#] Urgh! +tcTagToEnum loc fun_name arg res_ty + = do { fun <- tcLookupId fun_name + ; ty' <- zonkTcType res_ty + + -- Check that the type is algebraic + ; let mb_tc_app = tcSplitTyConApp_maybe ty' + Just (tc, tc_args) = mb_tc_app + ; checkTc (isJust mb_tc_app) + (mk_error ty' doc1) + + -- Look through any type family + ; fam_envs <- tcGetFamInstEnvs + ; let (rep_tc, rep_args, coi) = tcLookupDataFamInst fam_envs tc tc_args + -- coi :: tc tc_args ~ rep_tc rep_args + + ; checkTc (isEnumerationTyCon rep_tc) + (mk_error ty' doc2) + + ; arg' <- tcMonoExpr arg intPrimTy + ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) + rep_ty = mkTyConApp rep_tc rep_args + + ; return (mkHsWrapCoR (mkTcSymCo coi) $ HsApp fun' arg') } + -- coi is a Representational coercion + where + doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") + , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] + doc2 = ptext (sLit "Result type must be an enumeration type") + + mk_error :: TcType -> SDoc -> SDoc + mk_error ty what + = hang (ptext (sLit "Bad call to tagToEnum#") + <+> ptext (sLit "at type") <+> ppr ty) + 2 what + +{- +************************************************************************ +* * + Template Haskell checks +* * +************************************************************************ +-} + +checkThLocalId :: Id -> TcM () +#ifndef GHCI /* GHCI and TH is off */ +-------------------------------------- +-- Check for cross-stage lifting +checkThLocalId _id + = return () + +#else /* GHCI and TH is on */ +checkThLocalId id + = do { mb_local_use <- getStageAndBindLevel (idName id) + ; case mb_local_use of + Just (top_lvl, bind_lvl, use_stage) + | thLevel use_stage > bind_lvl + , isNotTopLevel top_lvl + -> checkCrossStageLifting id use_stage + _ -> return () -- Not a locally-bound thing, or + -- no cross-stage link + } + +-------------------------------------- +checkCrossStageLifting :: Id -> ThStage -> TcM () +-- If we are inside brackets, and (use_lvl > bind_lvl) +-- we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] +-- There is no error-checking to do, because the renamer did that + +checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + do { let id_ty = idType id + ; checkTc (isTauTy id_ty) (polySpliceErr id) + -- If x is polymorphic, its occurrence sites might + -- have different instantiations, so we can't use plain + -- 'x' as the splice proxy name. I don't know how to + -- solve this, and it's probably unimportant, so I'm + -- just going to flag an error for now + + ; lift <- if isStringTy id_ty then + do { sid <- tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] + ; return (HsVar sid) } + else + setConstraintVar lie_var $ + -- Put the 'lift' constraint into the right LIE + newMethodFromName (OccurrenceOf (idName id)) + DsMeta.liftName id_ty + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; let pending_splice = PendSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) + ; writeMutVar ps_var (pending_splice : ps) + + ; return () } + +checkCrossStageLifting _ _ = return () + +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) +#endif /* GHCI */ + +{- +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.lhs + +Local record selectors +~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. + + +************************************************************************ +* * +\subsection{Record bindings} +* * +************************************************************************ + +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. + +For each binding field = value + +3. Instantiate the field type (from the field label) using the type + envt from step 2. + +4 Type check the value using tcArg, passing the field type as + the expected argument type. + +This extends OK when the field types are universally quantified. +-} + +tcRecordBinds + :: DataCon + -> [TcType] -- Expected type for each field + -> HsRecordBinds Name + -> TcM (HsRecordBinds TcId) + +tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } + where + flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys + do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl + , hsRecFieldArg = rhs })) + | Just field_ty <- assocMaybe flds_w_tys field_lbl + = addErrCtxt (fieldCtxt field_lbl) $ + do { rhs' <- tcPolyExprNC rhs field_ty + ; let field_id = mkUserLocal (nameOccName field_lbl) + (nameUnique field_lbl) + field_ty loc + -- Yuk: the field_id has the *unique* of the selector Id + -- (so we can find it easily) + -- but is a LocalId with the appropriate type of the RHS + -- (so the desugarer knows the type of local binder to make) + ; return (Just (L l (fld { hsRecFieldId = L loc field_id + , hsRecFieldArg = rhs' }))) } + | otherwise + = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl) + ; return Nothing } + +checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () +checkMissingFields data_con rbinds + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields + = if any isBanged field_strs then + -- Illegal if any arg is strict + addErrTc (missingStrictFields data_con []) + else + return () + + | otherwise = do -- A record + unless (null missing_s_fields) + (addErrTc (missingStrictFields data_con missing_s_fields)) + + warn <- woptM Opt_WarnMissingFields + unless (not (warn && notNull missing_ns_fields)) + (warnTc True (missingFields data_con missing_ns_fields)) + + where + missing_s_fields + = [ fl | (fl, str) <- field_info, + isBanged str, + not (fl `elem` field_names_used) + ] + missing_ns_fields + = [ fl | (fl, str) <- field_info, + not (isBanged str), + not (fl `elem` field_names_used) + ] + + field_names_used = hsRecFields rbinds + field_labels = dataConFieldLabels data_con + + field_info = zipEqual "missingFields" + field_labels + field_strs + + field_strs = dataConSrcBangs data_con + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +Boring and alphabetical: +-} + +addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a +addExprErrCtxt expr = addErrCtxt (exprCtxt expr) + +exprCtxt :: LHsExpr Name -> SDoc +exprCtxt expr + = hang (ptext (sLit "In the expression:")) 2 (ppr expr) + +fieldCtxt :: Name -> SDoc +fieldCtxt field_name + = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") + +funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc +funAppCtxt fun arg arg_no + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) + 2 (quotes (ppr arg)) + +funResCtxt :: Bool -- There is at least one argument + -> HsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, MsgDoc) +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +-- +-- Used for naked variables too; but with has_args = False +funResCtxt has_args fun fun_res_ty env_ty tidy_env + = do { fun_res' <- zonkTcType fun_res_ty + ; env' <- zonkTcType env_ty + ; let (args_fun, res_fun) = tcSplitFunTys fun_res' + (args_env, res_env) = tcSplitFunTys env' + n_fun = length args_fun + n_env = length args_env + info | n_fun == n_env = Outputable.empty + | n_fun > n_env + , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too few arguments") + | has_args + , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too many arguments") + | otherwise = Outputable.empty -- Never suggest that a naked variable is + -- applied to too many args! + ; return (tidy_env, info) } + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + +badFieldTypes :: [(Name,TcType)] -> SDoc +badFieldTypes prs + = hang (ptext (sLit "Record update for insufficiently polymorphic field") + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + +badFieldsUpd + :: HsRecFields Name a -- Field names that don't belong to a single datacon + -> [DataCon] -- Data cons of the type which the first field name belongs to + -> SDoc +badFieldsUpd rbinds data_cons + = hang (ptext (sLit "No constructor has all these fields:")) + 2 (pprQuotedList conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(Name, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . head) $ groupBy ((==) `on` snd) growingSets + + aMember = ASSERT( not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(Name, [Bool])] + membership = sortMembership $ + map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ + hsRecFields rbinds + + fieldLabelSets :: [Set.Set Name] + fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = length . filter id + +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See Trac #7989. +-} + +naughtyRecordSel :: TcId -> SDoc +naughtyRecordSel sel_id + = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext (sLit "as a function due to escaped type variables") $$ + ptext (sLit "Probable fix: use pattern-matching syntax instead") + +notSelector :: Name -> SDoc +notSelector field + = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] + +missingStrictFields :: DataCon -> [FieldLabel] -> SDoc +missingStrictFields con fields + = header <> rest + where + rest | null fields = Outputable.empty -- Happens for non-record constructors + -- with strict fields + | otherwise = colon <+> pprWithCommas ppr fields + + header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> + ptext (sLit "does not have the required strict field(s)") + +missingFields :: DataCon -> [FieldLabel] -> SDoc +missingFields con fields + = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") + <+> pprWithCommas ppr fields + +-- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot new file mode 100644 index 00000000..acd5d8a7 --- /dev/null +++ b/compiler/typecheck/TcExpr.hs-boot @@ -0,0 +1,26 @@ +module TcExpr where +import HsSyn ( HsExpr, LHsExpr ) +import Name ( Name ) +import TcType ( TcType, TcRhoType, TcSigmaType ) +import TcRnTypes( TcM, TcId, CtOrigin ) + +tcPolyExpr :: + LHsExpr Name + -> TcSigmaType + -> TcM (LHsExpr TcId) + +tcMonoExpr, tcMonoExprNC :: + LHsExpr Name + -> TcRhoType + -> TcM (LHsExpr TcId) + +tcInferRho, tcInferRhoNC :: + LHsExpr Name + -> TcM (LHsExpr TcId, TcRhoType) + +tcSyntaxOp :: CtOrigin + -> HsExpr Name + -> TcType + -> TcM (HsExpr TcId) + +tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs new file mode 100644 index 00000000..2c72c930 --- /dev/null +++ b/compiler/typecheck/TcFlatten.hs @@ -0,0 +1,1590 @@ +{-# LANGUAGE CPP #-} + +module TcFlatten( + FlattenEnv(..), FlattenMode(..), mkFlattenEnv, + flatten, flattenMany, flatten_many, + flattenFamApp, flattenTyVarOuter, + unflatten, + eqCanRewrite, eqCanRewriteFR, canRewriteOrSame, + CtFlavourRole, ctEvFlavourRole, ctFlavourRole + ) where + +#include "HsVersions.h" + +import TcRnTypes +import TcType +import Type +import TcEvidence +import TyCon +import TypeRep +import Kind( isSubKind ) +import Coercion ( tyConRolesX ) +import Var +import VarEnv +import NameEnv +import Outputable +import VarSet +import TcSMonad as TcS +import DynFlags( DynFlags ) + +import Util +import Bag +import FastString +import Control.Monad( when, liftM ) +import MonadUtils ( zipWithAndUnzipM ) +import GHC.Exts ( inline ) + +{- +Note [The flattening story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A CFunEqCan is either of form + [G] : F xis ~ fsk -- fsk is a FlatSkol + [W] x : F xis ~ fmv -- fmv is a unification variable, + -- but untouchable, + -- with MetaInfo = FlatMetaTv + where + x is the witness variable + fsk/fmv is a flatten skolem + xis are function-free + CFunEqCans are always [Wanted], or [Given], never [Derived] + + fmv untouchable just means that in a CTyVarEq, say, + fmv ~ Int + we do NOT unify fmv. + +* KEY INSIGHTS: + + - A given flatten-skolem, fsk, is known a-priori to be equal to + F xis (the LHS), with evidence + + - A unification flatten-skolem, fmv, stands for the as-yet-unknown + type to which (F xis) will eventually reduce + +* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 + then xis1 /= xis2 + i.e. at most one CFunEqCan with a particular LHS + +* Each canonical CFunEqCan x : F xis ~ fsk/fmv has its own + distinct evidence variable x and flatten-skolem fsk/fmv. + Why? We make a fresh fsk/fmv when the constraint is born; + and we never rewrite the RHS of a CFunEqCan. + +* Function applications can occur in the RHS of a CTyEqCan. No reason + not allow this, and it reduces the amount of flattening that must occur. + +* Flattening a type (F xis): + - If we are flattening in a Wanted/Derived constraint + then create new [W] x : F xis ~ fmv + else create new [G] x : F xis ~ fsk + with fresh evidence variable x and flatten-skolem fsk/fmv + + - Add it to the work list + + - Replace (F xis) with fsk/fmv in the type you are flattening + + - You can also add the CFunEqCan to the "flat cache", which + simply keeps track of all the function applications you + have flattened. + + - If (F xis) is in the cache already, just + use its fsk/fmv and evidence x, and emit nothing. + + - No need to substitute in the flat-cache. It's not the end + of the world if we start with, say (F alpha ~ fmv1) and + (F Int ~ fmv2) and then find alpha := Int. Athat will + simply give rise to fmv1 := fmv2 via [Interacting rule] below + +* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv + - Flatten xis (to substitute any tyvars; there are already no functions) + cos :: xis ~ flat_xis + - New wanted x2 :: F flat_xis ~ fsk/fmv + - Add new wanted to flat cache + - Discharge x = F cos ; x2 + +* Unification flatten-skolems, fmv, ONLY get unified when either + a) The CFunEqCan takes a step, using an axiom + b) During un-flattening + They are never unified in any other form of equality. + For example [W] ffmv ~ Int is stuck; it does not unify with fmv. + +* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. + That would destroy the invariant about the shape of a CFunEqCan, + and it would risk wanted/wanted interactions. The only way we + learn information about fsk is when the CFunEqCan takes a step. + + However we *do* substitute in the LHS of a CFunEqCan (else it + would never get to fire!) + +* [Interacting rule] + (inert) [W] x1 : F tys ~ fmv1 + (work item) [W] x2 : F tys ~ fmv2 + Just solve one from the other: + x2 := x1 + fmv2 := fmv1 + This just unites the two fsks into one. + Always solve given from wanted if poss. + +* [Firing rule: wanteds] + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ rhs + + Dischard fmv: + fmv := alpha + x := ax_co ; sym x2 + [W] x2 : alpha ~ rhs (Non-canonical) + discharging the work item. This is the way that fmv's get + unified; even though they are "untouchable". + + NB: this deals with the case where fmv appears in xi, which can + happen; it just happens through the non-canonical stuff + + Possible short cut (shortCutReduction) if rhs = G rhs_tys, + where G is a type function. Then + - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) + - Add G rhs_xis ~ fmv to flat cache + - New wanted [W] x2 : G rhs_xis ~ fmv + - Discharge x := co ; G cos ; x2 + +* [Firing rule: givens] + (work item) [G] g : F tys ~ fsk + instantiate axiom: co : F tys ~ rhs + + Now add non-canonical (since rhs is not flat) + [G] (sym g ; co) : fsk ~ rhs + + Short cut (shortCutReduction) for when rhs = G rhs_tys and G is a type function + [G] (co ; g) : G tys ~ fsk + But need to flatten tys: flat_cos : tys ~ flat_tys + [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk + + +Why given-fsks, alone, doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. + + [W] w : alpha ~ [F alpha Int] + +---> flatten + w = ...w'... + [W] w' : alpha ~ [fsk] + [G] : F alpha Int ~ fsk + +--> unify (no occurs check) + alpha := [fsk] + +But since fsk = F alpha Int, this is really an occurs check error. If +that is all we know about alpha, we will succeed in constraint +solving, producing a program with an infinite type. + +Even if we did finally get (g : fsk ~ Boo)l by solving (F alpha Int ~ fsk) +using axiom, zonking would not see it, so (x::alpha) sitting in the +tree will get zonked to an infinite type. (Zonking always only does +refl stuff.) + +Why flatten-meta-vars, alone doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at Simple13, with unification-fmvs only + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fmv] + [W] x : F a ~ fmv + +--> subst a in x + x = F g' ; x2 + [W] x2 : F [fmv] ~ fmv + +And now we have an evidence cycle between g' and x! + +If we used a given instead (ie current story) + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fsk] + [G] : F a ~ fsk + +---> Substitute for a + [G] g' : a ~ [fsk] + [G] F (sym g'); : F [fsk] ~ fsk + + +Why is it right to treat fmv's differently to ordinary unification vars? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + f :: forall a. a -> a -> Bool + g :: F Int -> F Int -> Bool + +Consider + f (x:Int) (y:Bool) +This gives alpha~Int, alpha~Bool. There is an inconsistency, +but really only one error. SherLoc may tell you which location +is most likely, based on other occurrences of alpha. + +Consider + g (x:Int) (y:Bool) +Here we get (F Int ~ Int, F Int ~ Bool), which flattens to + (fmv ~ Int, fmv ~ Bool) +But there are really TWO separate errors. We must not complain +about Int~Bool. Moreover these two errors could arise in entirely +unrelated parts of the code. (In the alpha case, there must be +*some* connection (eg v:alpha in common envt).) + +Note [Orient equalities with flatten-meta-vars on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This example comes from IndTypesPerfMerge + +From the ambiguity check for + f :: (F a ~ a) => a +we get: + [G] F a ~ a + [W] F alpha ~ alpha, alpha ~ a + + From Givens we get + [G] F a ~ fsk, fsk ~ a + + Now if we flatten we get + [W] alpha ~ fmv, F alpha ~ fmv, alpha ~ a + + Now, processing the first one first, choosing alpha := fmv + [W] F fmv ~ fmv, fmv ~ a + + And now we are stuck. We must either *unify* fmv := a, or + use the fmv ~ a to rewrite F fmv ~ fmv, so we can make it + meet up with the given F a ~ blah. + +Solution: always put fmvs on the left, so we get + [W] fmv ~ alpha, F alpha ~ fmv, alpha ~ a + The point is that fmvs are very uninformative, so doing alpha := fmv + is a bad idea. We want to use other constraints on alpha first. + + +Note [Derived constraints from wanted CTyEqCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this type ambiguous: (Foo e ~ Maybe e) => Foo e + (indexed-types/should_fail/T4093a) + + [G] Foo e ~ Maybe e + [W] Foo e ~ Foo ee -- ee is a unification variable + [W] Foo ee ~ Maybe ee) +--- + [G] Foo e ~ fsk + [G] fsk ~ Maybe e + + [W] Foo e ~ fmv1 + [W] Foo ee ~ fmv2 + [W] fmv1 ~ fmv2 + [W] fmv2 ~ Maybe ee + +---> fmv1 := fsk by matching LHSs + [W] Foo ee ~ fmv2 + [W] fsk ~ fmv2 + [W] fmv2 ~ Maybe ee + +---> + [W] Foo ee ~ fmv2 + [W] fmv2 ~ Maybe e + [W] fmv2 ~ Maybe ee + +Now maybe we shuld get [D] e ~ ee, and then we'd solve it entirely. +But if in a smilar situation we got [D] Int ~ Bool we'd be back +to complaining about wanted/wanted interactions. Maybe this arises +also for fundeps? + +Here's another example: + f :: [a] -> [b] -> blah + f (e1 :: F Int) (e2 :: F Int) + + we get + F Int ~ fmv + fmv ~ [alpha] + fmv ~ [beta] + + We want: alpha := beta (which might unlock something else). If we + generated [D] [alpha] ~ [beta] we'd be good here. + +Current story: we don't generate these derived constraints. We could, but +we'd want to make them very weak, so we didn't get the Int~Bool complaint. + + +************************************************************************ +* * +* Other notes (Oct 14) + I have not revisted these, but I didn't want to discard them +* * +************************************************************************ + + +Try: rewrite wanted with wanted only for fmvs (not all meta-tyvars) + +But: fmv ~ alpha[0] + alpha[0] ~ fmv’ +Now we don’t see that fmv ~ fmv’, which is a problem for injectivity detection. + +Conclusion: rewrite wanteds with wanted for all untouchables. + +skol ~ untch, must re-orieint to untch ~ skol, so that we can use it to rewrite. + + + +************************************************************************ +* * +* Examples + Here is a long series of examples I had to work through +* * +************************************************************************ + +Simple20 +~~~~~~~~ +axiom F [a] = [F a] + + [G] F [a] ~ a +--> + [G] fsk ~ a + [G] [F a] ~ fsk (nc) +--> + [G] F a ~ fsk2 + [G] fsk ~ [fsk2] + [G] fsk ~ a +--> + [G] F a ~ fsk2 + [G] a ~ [fsk2] + [G] fsk ~ a + + +----------------------------------- + +---------------------------------------- +indexed-types/should_compile/T44984 + + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha + +flatten +~~~~~~~ + fmv0 := F Bool + fmv1 := H (F Bool) + fmv2 := H alpha + alpha := F Bool +plus + fmv1 ~ fmv2 + +But these two are equal under the above assumptions. +Solve by Refl. + + +--- under plan B, namely solve fmv1:=fmv2 eagerly --- + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 fmv2 := fmv1 + + fmv0 ~ alpha + +flatten + fmv0 := F Bool + fmv1 := H fmv0 = H (F Bool) + retain H alpha ~ fmv2 + because fmv2 has been filled + alpha := F Bool + + +---------------------------- +indexed-types/should_failt/T4179 + +after solving + [W] fmv_1 ~ fmv_2 + [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) + [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) + +---------------------------------------- +indexed-types/should_fail/T7729a + +a) [W] BasePrimMonad (Rand m) ~ m1 +b) [W] tt m1 ~ BasePrimMonad (Rand m) + +---> process (b) first + BasePrimMonad (Ramd m) ~ fmv_atH + fmv_atH ~ tt m1 + +---> now process (a) + m1 ~ s_atH ~ tt m1 -- An obscure occurs check + + +---------------------------------------- +typecheck/TcTypeNatSimple + +Original constraint + [W] x + y ~ x + alpha (non-canonical) +==> + [W] x + y ~ fmv1 (CFunEqCan) + [W] x + alpha ~ fmv2 (CFuneqCan) + [W] fmv1 ~ fmv2 (CTyEqCan) + +(sigh) + +---------------------------------------- +indexed-types/should_fail/GADTwrong1 + + [G] Const a ~ () +==> flatten + [G] fsk ~ () + work item: Const a ~ fsk +==> fire top rule + [G] fsk ~ () + work item fsk ~ () + +Surely the work item should rewrite to () ~ ()? Well, maybe not; +it'a very special case. More generally, our givens look like +F a ~ Int, where (F a) is not reducible. + + +---------------------------------------- +indexed_types/should_fail/T8227: + +Why using a different can-rewrite rule in CFunEqCan heads +does not work. + +Assuming NOT rewriting wanteds with wanteds + + Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk + [W] fmv_aBk ~ fsk_aBh + + [G] Scalar fsk_aBg ~ fsk_aBh + [G] V a ~ f_aBg + + Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk + fmv_aBi, fmv_aBk are flatten unificaiton variables + + Work item: [W] V fsk_aBh ~ fmv_aBi + +Note that the inert wanteds are cyclic, because we do not rewrite +wanteds with wanteds. + + +Then we go into a loop when normalise the work-item, because we +use rewriteOrSame on the argument of V. + +Conclusion: Don't make canRewrite context specific; instead use +[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. + + +---------------------------------------- + +Here is a somewhat similar case: + + type family G a :: * + + blah :: (G a ~ Bool, Eq (G a)) => a -> a + blah = error "urk" + + foo x = blah x + +For foo we get + [W] Eq (G a), G a ~ Bool +Flattening + [W] G a ~ fmv, Eq fmv, fmv ~ Bool +We can't simplify away the Eq Bool unless we substitute for fmv. +Maybe that doesn't matter: we would still be left with unsolved +G a ~ Bool. + +-------------------------- +Trac #9318 has a very simple program leading to + + [W] F Int ~ Int + [W] F Int ~ Bool + +We don't want to get "Error Int~Bool". But if fmv's can rewrite +wanteds, we will + + [W] fmv ~ Int + [W] fmv ~ Bool +---> + [W] Int ~ Bool + + +************************************************************************ +* * +* The main flattening functions +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~~~~ + flatten ty ==> (xi, cc) + where + xi has no type functions, unless they appear under ForAlls + + cc = Auxiliary given (equality) constraints constraining + the fresh type variables in xi. Evidence for these + is always the identity coercion, because internally the + fresh flattening skolem variables are actually identified + with the types they have been generated to stand in for. + +Note that it is flatten's job to flatten *every type function it sees*. +flatten is only called on *arguments* to type functions, by canEqGiven. + +Recall that in comments we use alpha[flat = ty] to represent a +flattening skolem variable alpha which has been generated to stand in +for ty. + +----- Example of flattening a constraint: ------ + flatten (List (F (G Int))) ==> (xi, cc) + where + xi = List alpha + cc = { G Int ~ beta[flat = G Int], + F beta ~ alpha[flat = F beta] } +Here + * alpha and beta are 'flattening skolem variables'. + * All the constraints in cc are 'given', and all their coercion terms + are the identity. + +NB: Flattening Skolems only occur in canonical constraints, which +are never zonked, so we don't need to worry about zonking doing +accidental unflattening. + +Note that we prefer to leave type synonyms unexpanded when possible, +so when the flattener encounters one, it first asks whether its +transitive expansion contains any type function applications. If so, +it expands the synonym and proceeds; if not, it simply returns the +unexpanded synonym. + +Note [Flattener EqRels] +~~~~~~~~~~~~~~~~~~~~~~~ +When flattening, we need to know which equality relation -- nominal +or representation -- we should be respecting. The only difference is +that we rewrite variables by representational equalities when fe_eq_rel +is ReprEq. + +-} + +data FlattenEnv + = FE { fe_mode :: FlattenMode + , fe_loc :: CtLoc + , fe_flavour :: CtFlavour + , fe_eq_rel :: EqRel } -- See Note [Flattener EqRels] + +data FlattenMode -- Postcondition for all three: inert wrt the type substitution + = FM_FlattenAll -- Postcondition: function-free + + | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] + -- Postcondition: + -- * tyvar is only mentioned in result under a rigid path + -- e.g. [a] is ok, but F a won't happen + -- * If flat_top is True, top level is not a function application + -- (but under type constructors is ok e.g. [F a]) + + | FM_SubstOnly -- See Note [Flattening under a forall] + +mkFlattenEnv :: FlattenMode -> CtEvidence -> FlattenEnv +mkFlattenEnv fm ctev = FE { fe_mode = fm + , fe_loc = ctEvLoc ctev + , fe_flavour = ctEvFlavour ctev + , fe_eq_rel = ctEvEqRel ctev } + +feRole :: FlattenEnv -> Role +feRole = eqRelRole . fe_eq_rel + +{- +Note [Lazy flattening] +~~~~~~~~~~~~~~~~~~~~~~ +The idea of FM_Avoid mode is to flatten less aggressively. If we have + a ~ [F Int] +there seems to be no great merit in lifting out (F Int). But if it was + a ~ [G a Int] +then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, +which gets rid of the occurs-check problem. (For the flat_top Bool, see +comments above and at call sites.) + +HOWEVER, the lazy flattening actually seems to make type inference go +*slower*, not faster. perf/compiler/T3064 is a case in point; it gets +*dramatically* worse with FM_Avoid. I think it may be because +floating the types out means we normalise them, and that often makes +them smaller and perhaps allows more re-use of previously solved +goals. But to be honest I'm not absolutely certain, so I am leaving +FM_Avoid in the code base. What I'm removing is the unique place +where it is *used*, namely in TcCanonical.canEqTyVar. + +See also Note [Conservative unification check] in TcUnify, which gives +other examples where lazy flattening caused problems. + +Bottom line: FM_Avoid is unused for now (Nov 14). +Note: T5321Fun got faster when I disabled FM_Avoid + T5837 did too, but it's pathalogical anyway + +Note [Phantoms in the flattener] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + +data Proxy p = Proxy + +and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` +is really irrelevant -- it will be ignored when solving for representational +equality later on. So, we omit flattening `ty` entirely. This may +violate the expectation of "xi"s for a bit, but the canonicaliser will +soon throw out the phantoms when decomposing a TyConApp. (Or, the +canonicaliser will emit an insoluble, in which case the unflattened version +yields a better error message anyway.) + +Note [flatten_many performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In programs with lots of type-level evaluation, flatten_many becomes +part of a tight loop. For example, see test perf/compiler/T9872a, which +calls flatten_many a whopping 7,106,808 times. It is thus important +that flatten_many be efficient. + +Performance testing showed that the current implementation is indeed +efficient. It's critically important that zipWithAndUnzipM be +specialized to TcS, and it's also quite helpful to actually `inline` +it. On test T9872a, here are the allocation stats (Dec 16, 2014): + + * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap + * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap + * Specialized, inlined: 6,281,539,792 bytes allocated in the heap + +To improve performance even further, flatten_many_nom is split off +from flatten_many, as nominal equality is the common case. This would +be natural to write using mapAndUnzipM, but even inlined, that function +is not as performant as a hand-written loop. + + * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap + * hand-written recursion: 5,848,602,848 bytes allocated in the heap + +If you make any change here, pay close attention to the T9872{a,b,c} tests +and T5321Fun. + +If we need to make this yet more performant, a possible way forward is to +duplicate the flattener code for the nominal case, and make that case +faster. This doesn't seem quite worth it, yet. + +-} + +------------------ +flatten :: FlattenMode -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) +flatten mode ev ty + = runFlatten (flatten_one fmode ty) + where + fmode = mkFlattenEnv mode ev + +flattenMany :: FlattenMode -> CtEvidence -> [Role] + -> [TcType] -> TcS ([Xi], [TcCoercion]) +-- Flatten a bunch of types all at once. Roles on the coercions returned +-- always match the corresponding roles passed in. +flattenMany mode ev roles tys + = runFlatten (flatten_many fmode roles tys) + where + fmode = mkFlattenEnv mode ev + +flattenFamApp :: FlattenMode -> CtEvidence + -> TyCon -> [TcType] -> TcS (Xi, TcCoercion) +flattenFamApp mode ev tc tys + = runFlatten (flatten_fam_app fmode tc tys) + where + fmode = mkFlattenEnv mode ev + +------------------ +flatten_many :: FlattenEnv -> [Role] -> [Type] -> TcS ([Xi], [TcCoercion]) +-- Coercions :: Xi ~ Type, at roles given +-- Returns True iff (no flattening happened) +-- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused, +-- we merely want (a) Given/Solved/Derived/Wanted info +-- (b) the GivenLoc/WantedLoc for when we create new evidence +flatten_many fmode roles tys +-- See Note [flatten_many performance] + = inline zipWithAndUnzipM go roles tys + where + go Nominal ty = flatten_one (setFEEqRel fmode NomEq) ty + go Representational ty = flatten_one (setFEEqRel fmode ReprEq) ty + go Phantom ty = -- See Note [Phantoms in the flattener] + return (ty, mkTcPhantomCo ty ty) + +-- | Like 'flatten_many', but assumes that every role is nominal. +flatten_many_nom :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion]) +flatten_many_nom _ [] = return ([], []) +-- See Note [flatten_many performance] +flatten_many_nom fmode (ty:tys) + = ASSERT( fe_eq_rel fmode == NomEq ) + do { (xi, co) <- flatten_one fmode ty + ; (xis, cos) <- flatten_many_nom fmode tys + ; return (xi:xis, co:cos) } + +------------------ +flatten_one :: FlattenEnv -> TcType -> TcS (Xi, TcCoercion) +-- Flatten a type to get rid of type function applications, returning +-- the new type-function-free type, and a collection of new equality +-- constraints. See Note [Flattening] for more detail. +-- +-- Postcondition: Coercion :: Xi ~ TcType +-- The role on the result coercion matches the EqRel in the FlattenEnv + +flatten_one fmode xi@(LitTy {}) = return (xi, mkTcReflCo (feRole fmode) xi) + +flatten_one fmode (TyVarTy tv) + = flattenTyVar fmode tv + +flatten_one fmode (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten_one fmode ty1 + ; case (fe_eq_rel fmode, nextRole xi1) of + (NomEq, _) -> flatten_rhs xi1 co1 NomEq + (ReprEq, Nominal) -> flatten_rhs xi1 co1 NomEq + (ReprEq, Representational) -> flatten_rhs xi1 co1 ReprEq + (ReprEq, Phantom) -> + return (mkAppTy xi1 ty2, co1 `mkTcAppCo` mkTcNomReflCo ty2) } + where + flatten_rhs xi1 co1 eq_rel2 + = do { (xi2,co2) <- flatten_one (setFEEqRel fmode eq_rel2) ty2 + ; traceTcS "flatten/appty" + (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ + ppr co1 $$ ppr xi2 $$ ppr co2) + ; let role1 = feRole fmode + role2 = eqRelRole eq_rel2 + ; return ( mkAppTy xi1 xi2 + , mkTcTransAppCo role1 co1 xi1 ty1 + role2 co2 xi2 ty2 + role1 ) } -- output should match fmode + +flatten_one fmode (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten_one fmode ty1 + ; (xi2,co2) <- flatten_one fmode ty2 + ; return (mkFunTy xi1 xi2, mkTcFunCo (feRole fmode) co1 co2) } + +flatten_one fmode (TyConApp tc tys) + + -- Expand type synonyms that mention type families + -- on the RHS; see Note [Flattening synonyms] + | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys' + = case fe_mode fmode of + FM_FlattenAll | anyNameEnv isTypeFamilyTyCon (tyConsOfType rhs) + -> flatten_one fmode expanded_ty + | otherwise + -> flattenTyConApp fmode tc tys + _ -> flattenTyConApp fmode tc tys + + -- Otherwise, it's a type function application, and we have to + -- flatten it away as well, and generate a new given equality constraint + -- between the application and a newly generated flattening skolem variable. + | isTypeFamilyTyCon tc + = flatten_fam_app fmode tc tys + + -- For * a normal data type application + -- * data family application + -- we just recursively flatten the arguments. + | otherwise +-- FM_Avoid stuff commented out; see Note [Lazy flattening] +-- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid +-- FE { fe_mode = FM_Avoid tv _ } +-- -> fmode { fe_mode = FM_Avoid tv False } +-- _ -> fmode + = flattenTyConApp fmode tc tys + +flatten_one fmode ty@(ForAllTy {}) +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (tvs, rho) = splitForAllTys ty + ; (rho', co) <- flatten_one (setFEMode fmode FM_SubstOnly) rho + -- Substitute only under a forall + -- See Note [Flattening under a forall] + ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } + +flattenTyConApp :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion) +flattenTyConApp fmode tc tys + = do { (xis, cos) <- case fe_eq_rel fmode of + NomEq -> flatten_many_nom fmode tys + ReprEq -> flatten_many fmode (tyConRolesX role tc) tys + ; return (mkTyConApp tc xis, mkTcTyConAppCo role tc cos) } + where + role = feRole fmode + +{- +Note [Flattening synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Not expanding synonyms aggressively improves error messages, and +keeps types smaller. But we need to take care. + +Suppose + type T a = a -> a +and we want to flatten the type (T (F a)). Then we can safely flatten +the (F a) to a skolem, and return (T fsk). We don't need to expand the +synonym. This works because TcTyConAppCo can deal with synonyms +(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. + +But (Trac #8979) for + type T a = (F a, a) where F is a type function +we must expand the synonym in (say) T Int, to expose the type function +to the flattener. + + +Note [Flattening under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert substitution + (b) MUST NOT flatten type family applications +Hence FMSubstOnly. + +For (a) consider c ~ a, a ~ T (forall b. (b, [c])) +If we don't apply the c~a substitution to the second constraint +we won't see the occurs-check error. + +For (b) consider (a ~ forall b. F a b), we don't want to flatten +to (a ~ forall b.fsk, F a b ~ fsk) +because now the 'b' has escaped its scope. We'd have to flatten to + (a ~ forall b. fsk b, forall b. F a b ~ fsk b) +and we have not begun to think about how to make that work! + +************************************************************************ +* * + Flattening a type-family application +* * +************************************************************************ +-} + +flatten_fam_app, flatten_exact_fam_app, flatten_exact_fam_app_fully + :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion) + -- flatten_fam_app can be over-saturated + -- flatten_exact_fam_app is exactly saturated + -- flatten_exact_fam_app_fully lifts out the application to top level + -- Postcondition: Coercion :: Xi ~ F tys +flatten_fam_app fmode tc tys -- Can be over-saturated + = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys + ; (xi1, co1) <- flatten_exact_fam_app fmode tc tys1 + -- co1 :: xi1 ~ F tys1 + + -- all Nominal roles b/c the tycon is oversaturated + ; (xis_rest, cos_rest) <- flatten_many fmode (repeat Nominal) tys_rest + -- cos_res :: xis_rest ~ tys_rest + ; return ( mkAppTys xi1 xis_rest -- NB mkAppTys: rhs_xi might not be a type variable + -- cf Trac #5655 + , mkTcAppCos co1 cos_rest -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys) + ) } + +flatten_exact_fam_app fmode tc tys + = case fe_mode fmode of + FM_FlattenAll -> flatten_exact_fam_app_fully fmode tc tys + + FM_SubstOnly -> do { (xis, cos) <- flatten_many fmode roles tys + ; return ( mkTyConApp tc xis + , mkTcTyConAppCo (feRole fmode) tc cos ) } + + FM_Avoid tv flat_top -> + do { (xis, cos) <- flatten_many fmode roles tys + ; if flat_top || tv `elemVarSet` tyVarsOfTypes xis + then flatten_exact_fam_app_fully fmode tc tys + else return ( mkTyConApp tc xis + , mkTcTyConAppCo (feRole fmode) tc cos ) } + where + -- These are always going to be Nominal for now, + -- but not if #8177 is implemented + roles = tyConRolesX (feRole fmode) tc + +flatten_exact_fam_app_fully fmode tc tys + -- See Note [Reduce type family applications eagerly] + = try_to_reduce tc tys False id $ + do { (xis, cos) <- flatten_many_nom (setFEEqRel (setFEMode fmode FM_FlattenAll) NomEq) tys + ; let ret_co = mkTcTyConAppCo (feRole fmode) tc cos + -- ret_co :: F xis ~ F tys + + ; mb_ct <- lookupFlatCache tc xis + ; case mb_ct of + Just (co, rhs_ty, flav) -- co :: F xis ~ fsk + | (flav, NomEq) `canRewriteOrSameFR` (feFlavourRole fmode) + -> -- Usable hit in the flat-cache + -- We certainly *can* use a Wanted for a Wanted + do { traceTcS "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty $$ ppr co) + ; (fsk_xi, fsk_co) <- flatten_one fmode rhs_ty + -- The fsk may already have been unified, so flatten it + -- fsk_co :: fsk_xi ~ fsk + ; return (fsk_xi, fsk_co `mkTcTransCo` + maybeTcSubCo (fe_eq_rel fmode) + (mkTcSymCo co) `mkTcTransCo` + ret_co) } + -- :: fsk_xi ~ F xis + + -- Try to reduce the family application right now + -- See Note [Reduce type family applications eagerly] + _ -> try_to_reduce tc xis True (`mkTcTransCo` ret_co) $ + do { let fam_ty = mkTyConApp tc xis + ; (ev, fsk) <- newFlattenSkolem (fe_flavour fmode) + (fe_loc fmode) + fam_ty + ; let fsk_ty = mkTyVarTy fsk + co = ctEvCoercion ev + ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) + + -- The new constraint (F xis ~ fsk) is not necessarily inert + -- (e.g. the LHS may be a redex) so we must put it in the work list + ; let ct = CFunEqCan { cc_ev = ev + , cc_fun = tc + , cc_tyargs = xis + , cc_fsk = fsk } + ; emitFlatWork ct + + ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev) + ; return (fsk_ty, maybeTcSubCo (fe_eq_rel fmode) + (mkTcSymCo co) + `mkTcTransCo` ret_co) } + } + + where + try_to_reduce :: TyCon -- F, family tycon + -> [Type] -- args, not necessarily flattened + -> Bool -- add to the flat cache? + -> ( TcCoercion -- :: xi ~ F args + -> TcCoercion ) -- what to return from outer function + -> TcS (Xi, TcCoercion) -- continuation upon failure + -> TcS (Xi, TcCoercion) + try_to_reduce tc tys cache update_co k + = do { mb_match <- matchFam tc tys + ; case mb_match of + Just (norm_co, norm_ty) + -> do { traceTcS "Eager T.F. reduction success" $ + vcat [ppr tc, ppr tys, ppr norm_ty, ppr cache] + ; (xi, final_co) <- flatten_one fmode norm_ty + ; let co = norm_co `mkTcTransCo` mkTcSymCo final_co + ; when cache $ + extendFlatCache tc tys (co, xi, fe_flavour fmode) + ; return (xi, update_co $ mkTcSymCo co) } + Nothing -> k } + +{- Note [Reduce type family applications eagerly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we come across a type-family application like (Append (Cons x Nil) t), +then, rather than flattening to a skolem etc, we may as well just reduce +it on the spot to (Cons x t). This saves a lot of intermediate steps. +Examples that are helped are tests T9872, and T5321Fun. + +Performance testing indicates that it's best to try this *twice*, once +before flattening arguments and once after flattening arguments. +Adding the extra reduction attempt before flattening arguments cut +the allocation amounts for the T9872{a,b,c} tests by half. Testing +also indicated that the early reduction should not use the flat-cache, +but that the later reduction should. It's possible that with more +examples, we might learn that these knobs should be set differently. + +Once we've got a flat rhs, we extend the flatten-cache to record the +result. Doing so can save lots of work when the same redex shows up +more than once. Note that we record the link from the redex all the +way to its *final* value, not just the single step reduction. + +************************************************************************ +* * + Flattening a type variable +* * +************************************************************************ + + +Note [The inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Definition [Can-rewrite relation] +A "can-rewrite" relation between flavours, written f1 >= f2, is a +binary relation with the following properties + + R1. >= is transitive + R2. If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 + +Lemma. If f1 >= f then f1 >= f1 +Proof. By property (R2), with f1=f2 + +Definition [Generalised substitution] +A "generalised substitution" S is a set of triples (a -f-> t), where + a is a type variable + t is a type + f is a flavour +such that + (WF1) if (a -f1-> t1) in S + (a -f2-> t2) in S + then neither (f1 >= f2) nor (f2 >= f1) hold + (WF2) if (a -f-> t) is in S, then t /= a + +Definition [Applying a generalised substitution] +If S is a generalised substitution + S(f,a) = t, if (a -fs-> t) in S, and fs >= f + = a, otherwise +Application extends naturally to types S(f,t), modulo roles. +See Note [Flavours with roles]. + +Theorem: S(f,a) is well defined as a function. +Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, + and f1 >= f and f2 >= f + Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF) + +Notation: repeated application. + S^0(f,t) = t + S^(n+1)(f,t) = S(f, S^n(t)) + +Definition: inert generalised substitution +A generalised substitution S is "inert" iff + + (IG1) there is an n such that + for every f,t, S^n(f,t) = S^(n+1)(f,t) + + (IG2) if (b -f-> t) in S, and f >= f, then S(f,t) = t + that is, each individual binding is "self-stable" + +---------------------------------------------------------------- +Our main invariant: + the inert CTyEqCans should be an inert generalised substitution +---------------------------------------------------------------- + +Note that inertness is not the same as idempotence. To apply S to a +type, you may have to apply it recursive. But inertness does +guarantee that this recursive use will terminate. + +---------- The main theorem -------------- + Suppose we have a "work item" + a -fw-> t + and an inert generalised substitution S, + such that + (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) + (T3) a not in t -- No occurs check in the work item + + (K1) if (a -fs-> s) is in S then not (fw >= fs) + (K2) if (b -fs-> s) is in S, where b /= a, then + (K2a) not (fs >= fs) + or (K2b) not (fw >= fs) + or (K2c) a not in s + (K3) If (b -fs-> s) is in S with (fw >= fs), then + (K3a) If the role of fs is nominal: s /= a + (K3b) If the role of fs is representational: EITHER + a not in s, OR + the path from the top of s to a includes at least one non-newtype + + then the extended substition T = S+(a -fw-> t) + is an inert generalised substitution. + +The idea is that +* (T1-2) are guaranteed by exhaustively rewriting the work-item + with S(fw,_). + +* T3 is guaranteed by a simple occurs-check on the work item. + +* (K1-3) are the "kick-out" criteria. (As stated, they are really the + "keep" criteria.) If the current inert S contains a triple that does + not satisfy (K1-3), then we remove it from S by "kicking it out", + and re-processing it. + +* Note that kicking out is a Bad Thing, because it means we have to + re-process a constraint. The less we kick out, the better. + TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed + this but haven't done the empirical study to check. + +* Assume we have G>=G, G>=W, D>=D, and that's all. Then, when performing + a unification we add a new given a -G-> ty. But doing so does NOT require + us to kick out an inert wanted that mentions a, because of (K2a). This + is a common case, hence good not to kick out. + +* Lemma (L1): The conditions of the Main Theorem imply that there is no + (a fs-> t) in S, s.t. (fs >= fw). + Proof. Suppose the contrary (fs >= fw). Then because of (T1), + S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we + have (a -fs-> a) in S, which contradicts (WF2). + +* The extended substitution satisfies (WF1) and (WF2) + - (K1) plus (L1) guarantee that the extended substiution satisfies (WF1). + - (T3) guarantees (WF2). + +* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), + T^1(f,t), T^2(f,T).... must pass through the new work item infnitely + often, since the substution without the work item is inert; and must + pass through at least one of the triples in S infnitely often. + + - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), + and hence this triple never plays a role in application S(f,a). + It is always safe to extend S with such a triple. + + (NB: we could strengten K1) in this way too, but see K3. + + - (K2b): If this holds, we can't pass through this triple infinitely + often, because if we did then fs>=f, fw>=f, hence fs>=fw, + contradicting (L1), or fw>=fs contradicting K2b. + + - (K2c): if a not in s, we hae no further opportunity to apply the + work item. + + NB: this reasoning isn't water tight. + +Key lemma to make it watertight. + Under the conditions of the Main Theorem, + forall f st fw >= f, a is not in S^k(f,t), for any k + +Also, consider roles more carefully. See Note [Flavours with roles]. + +Completeness +~~~~~~~~~~~~~ +K3: completeness. (K3) is not necessary for the extended substitution +to be inert. In fact K1 could be made stronger by saying + ... then (not (fw >= fs) or not (fs >= fs)) +But it's not enough for S to be inert; we also want completeness. +That is, we want to be able to solve all soluble wanted equalities. +Suppose we have + + work-item b -G-> a + inert-item a -W-> b + +Assuming (G >= W) but not (W >= W), this fulfills all the conditions, +so we could extend the inerts, thus: + + inert-items b -G-> a + a -W-> b + +But if we kicked-out the inert item, we'd get + + work-item a -W-> b + inert-item b -G-> a + +Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. +So we add one more clause to the kick-out criteria + +Another way to understand (K3) is that we treat an inert item + a -f-> b +in the same way as + b -f-> a +So if we kick out one, we should kick out the other. The orientation +is somewhat accidental. + +When considering roles, we also need the second clause (K3b). Consider + + inert-item a -W/R-> b c + work-item c -G/N-> a + +The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. +We've satisfied conditions (T1)-(T3) and (K1) and (K2). If all we had were +condition (K3a), then we would keep the inert around and add the work item. +But then, consider if we hit the following: + + work-item2 b -G/N-> Id + +where + + newtype Id x = Id x + +For similar reasons, if we only had (K3a), we wouldn't kick the +representational inert out. And then, we'd miss solving the inert, which +now reduced to reflexivity. The solution here is to kick out representational +inerts whenever the tyvar of a work item is "exposed", where exposed means +not under some proper data-type constructor, like [] or Maybe. See +isTyVarExposed in TcType. This is encoded in (K3b). + +Note [Flavours with roles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The system described in Note [The inert equalities] discusses an abstract +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Derived, Given}; and the equality relation (often called +role), taken from {NomEq, ReprEq}. When substituting w.r.t. the inert set, +as described in Note [The inert equalities], we must be careful to respect +roles. For example, if we have + + inert set: a -G/R-> Int + b -G/R-> Bool + + type role T nominal representational + +and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT +T Int Bool. The reason is that T's first parameter has a nominal role, and +thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of +subsitution means that the proof in Note [The inert equalities] may need +to be revisited, but we don't think that the end conclusion is wrong. +-} + +flattenTyVar :: FlattenEnv -> TcTyVar -> TcS (Xi, TcCoercion) +-- "Flattening" a type variable means to apply the substitution to it +-- The substitution is actually the union of +-- * the unifications that have taken place (either before the +-- solver started, or in TcInteract.solveByUnification) +-- * the CTyEqCans held in the inert set +-- +-- Postcondition: co : xi ~ tv +flattenTyVar fmode tv + = do { mb_yes <- flattenTyVarOuter fmode tv + ; case mb_yes of + Left tv' -> -- Done + do { traceTcS "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv')) + ; return (ty', mkTcReflCo (feRole fmode) ty') } + where + ty' = mkTyVarTy tv' + + Right (ty1, co1) -- Recurse + -> do { (ty2, co2) <- flatten_one fmode ty1 + ; traceTcS "flattenTyVar3" (ppr tv $$ ppr ty2) + ; return (ty2, co2 `mkTcTransCo` co1) } + } + +flattenTyVarOuter :: FlattenEnv -> TcTyVar + -> TcS (Either TyVar (TcType, TcCoercion)) +-- Look up the tyvar in +-- a) the internal MetaTyVar box +-- b) the tyvar binds +-- c) the inerts +-- Return (Left tv') if it is not found, tv' has a properly zonked kind +-- (Right (ty, co) if found, with co :: ty ~ tv; + +flattenTyVarOuter fmode tv + | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) + = Left `liftM` flattenTyVarFinal fmode tv + -- So ty contains refernces to the non-TcTyVar a + + | otherwise + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of { + Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) + ; return (Right (ty, mkTcReflCo (feRole fmode) ty)) } ; + Nothing -> + + -- Try in the inert equalities + -- See Definition [Applying a generalised substitution] + do { ieqs <- getInertEqs + ; case lookupVarEnv ieqs tv of + Just (ct:_) -- If the first doesn't work, + -- the subsequent ones won't either + | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct + , ctEvFlavourRole ctev `eqCanRewriteFR` feFlavourRole fmode + -> do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) + ; let rewrite_co1 = mkTcSymCo (ctEvCoercion ctev) + rewrite_co = case (ctEvEqRel ctev, fe_eq_rel fmode) of + (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) + -- if this ASSERT fails, then + -- eqCanRewriteFR answered incorrectly + rewrite_co1 + (NomEq, NomEq) -> rewrite_co1 + (NomEq, ReprEq) -> mkTcSubCo rewrite_co1 + + ; return (Right (rhs_ty, rewrite_co)) } + -- NB: ct is Derived then fmode must be also, hence + -- we are not going to touch the returned coercion + -- so ctEvCoercion is fine. + + _other -> Left `liftM` flattenTyVarFinal fmode tv + } } } + +flattenTyVarFinal :: FlattenEnv -> TcTyVar -> TcS TyVar +flattenTyVarFinal fmode tv + = -- Done, but make sure the kind is zonked + do { let kind = tyVarKind tv + kind_fmode = setFEMode fmode FM_SubstOnly + ; (new_knd, _kind_co) <- flatten_one kind_fmode kind + ; return (setVarType tv new_knd) } + +{- +Note [An alternative story for the inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This entire note is just background, left here in case we ever want + to return the the previousl state of affairs) + +We used (GHC 7.8) to have this story for the inert substitution inert_eqs + + * 'a' is not in fvs(ty) + * They are *inert* in the weaker sense that there is no infinite chain of + (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc + +This means that flattening must be recursive, but it does allow + [G] a ~ [b] + [G] b ~ Maybe c + +This avoids "saturating" the Givens, which can save a modest amount of work. +It is easy to implement, in TcInteract.kick_out, by only kicking out an inert +only if (a) the work item can rewrite the inert AND + (b) the inert cannot rewrite the work item + +This is signifcantly harder to think about. It can save a LOT of work +in occurs-check cases, but we don't care about them much. Trac #5837 +is an example; all the constraints here are Givens + + [G] a ~ TF (a,Int) + --> + work TF (a,Int) ~ fsk + inert fsk ~ a + + ---> + work fsk ~ (TF a, TF Int) + inert fsk ~ a + + ---> + work a ~ (TF a, TF Int) + inert fsk ~ a + + ---> (attempting to flatten (TF a) so that it does not mention a + work TF a ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (substitute for a) + work TF (fsk2, TF Int) ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (top-level reduction, re-orient) + work fsk2 ~ (TF fsk2, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (attempt to flatten (TF fsk2) to get rid of fsk2 + work TF fsk2 ~ fsk3 + work fsk2 ~ (fsk3, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> + work TF fsk2 ~ fsk3 + inert fsk2 ~ (fsk3, TF Int) + inert a ~ ((fsk3, TF Int), TF Int) + inert fsk ~ ((fsk3, TF Int), TF Int) + +Because the incoming given rewrites all the inert givens, we get more and +more duplication in the inert set. But this really only happens in pathalogical +casee, so we don't care. +-} + +eqCanRewrite :: CtEvidence -> CtEvidence -> Bool +eqCanRewrite ev1 ev2 = ctEvFlavourRole ev1 `eqCanRewriteFR` ctEvFlavourRole ev2 + +-- | Whether or not one 'Ct' can rewrite another is determined by its +-- flavour and its equality relation +type CtFlavourRole = (CtFlavour, EqRel) + +-- | Extract the flavour and role from a 'CtEvidence' +ctEvFlavourRole :: CtEvidence -> CtFlavourRole +ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) + +-- | Extract the flavour and role from a 'Ct' +ctFlavourRole :: Ct -> CtFlavourRole +ctFlavourRole = ctEvFlavourRole . cc_ev + +-- | Extract the flavour and role from a 'FlattenEnv' +feFlavourRole :: FlattenEnv -> CtFlavourRole +feFlavourRole (FE { fe_flavour = flav, fe_eq_rel = eq_rel }) + = (flav, eq_rel) + +eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Very important function! +-- See Note [eqCanRewrite] +eqCanRewriteFR (Given, NomEq) (_, _) = True +eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True +eqCanRewriteFR _ _ = False + +canRewriteOrSame :: CtEvidence -> CtEvidence -> Bool +-- See Note [canRewriteOrSame] +canRewriteOrSame ev1 ev2 = ev1 `eqCanRewrite` ev2 || + ctEvFlavourRole ev1 == ctEvFlavourRole ev2 + +canRewriteOrSameFR :: CtFlavourRole -> CtFlavourRole -> Bool +canRewriteOrSameFR fr1 fr2 = fr1 `eqCanRewriteFR` fr2 || fr1 == fr2 + +{- +Note [eqCanRewrite] +~~~~~~~~~~~~~~~~~~~ +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form +tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of +a can-rewrite relation, see Definition [Can-rewrite relation] + +At the moment we don't allow Wanteds to rewrite Wanteds, because that can give +rise to very confusing type error messages. A good example is Trac #8450. +Here's another + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +Accordingly, we also don't let Deriveds rewrite Deriveds. + +With the solver handling Coercible constraints like equality constraints, +the rewrite conditions must take role into account, never allowing +a representational equality to rewrite a nominal one. + +Note [canRewriteOrSame] +~~~~~~~~~~~~~~~~~~~~~~~ +canRewriteOrSame is similar but + * returns True for Wanted/Wanted. + * works for all kinds of constraints, not just CTyEqCans +See the call sites for explanations. + +************************************************************************ +* * + Unflattening +* * +************************************************************************ + +An unflattening example: + [W] F a ~ alpha +flattens to + [W] F a ~ fmv (CFunEqCan) + [W] fmv ~ alpha (CTyEqCan) +We must solve both! +-} + +unflatten :: Cts -> Cts -> TcS Cts +unflatten tv_eqs funeqs + = do { dflags <- getDynFlags + ; tclvl <- getTcLevel + + ; traceTcS "Unflattening" $ braces $ + vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs + , ptext (sLit "Tv eqs =") <+> pprCts tv_eqs ] + + -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check + -- See Note [Unflatten using funeqs first] + ; funeqs <- foldrBagM (unflatten_funeq dflags) emptyCts funeqs + ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) + + -- Step 2: unify the irreds, if possible + ; tv_eqs <- foldrBagM (unflatten_eq dflags tclvl) emptyCts tv_eqs + ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) + + -- Step 3: fill any remaining fmvs with fresh unification variables + ; funeqs <- mapBagM finalise_funeq funeqs + ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) + + -- Step 4: remove any irreds that look like ty ~ ty + ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs + + ; let all_flat = tv_eqs `andCts` funeqs + ; traceTcS "Unflattening done" $ braces (pprCts all_flat) + + ; return all_flat } + where + ---------------- + unflatten_funeq :: DynFlags -> Ct -> Cts -> TcS Cts + unflatten_funeq dflags ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis + , cc_fsk = fmv, cc_ev = ev }) rest + = do { -- fmv should be a flatten meta-tv; we now fix its final + -- value, and then zonking will eliminate it + filled <- tryFill dflags fmv (mkTyConApp tc xis) ev + ; return (if filled then rest else ct `consCts` rest) } + + unflatten_funeq _ other_ct _ + = pprPanic "unflatten_funeq" (ppr other_ct) + + ---------------- + finalise_funeq :: Ct -> TcS Ct + finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) + = do { demoteUnfilledFmv fmv + ; return (mkNonCanonical ev) } + finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) + + ---------------- + unflatten_eq :: DynFlags -> TcLevel -> Ct -> Cts -> TcS Cts + unflatten_eq dflags tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest + | isFmvTyVar tv + = do { lhs_elim <- tryFill dflags tv rhs ev + ; if lhs_elim then return rest else + do { rhs_elim <- try_fill dflags tclvl ev rhs (mkTyVarTy tv) + ; if rhs_elim then return rest else + return (ct `consCts` rest) } } + + | otherwise + = return (ct `consCts` rest) + + unflatten_eq _ _ ct _ = pprPanic "unflatten_irred" (ppr ct) + + ---------------- + finalise_eq :: Ct -> Cts -> TcS Cts + finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv + , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest + | isFmvTyVar tv + = do { ty1 <- zonkTcTyVar tv + ; ty2 <- zonkTcType rhs + ; let is_refl = ty1 `tcEqType` ty2 + ; if is_refl then do { when (isWanted ev) $ + setEvBind (ctEvId ev) + (EvCoercion $ + mkTcReflCo (eqRelRole eq_rel) rhs) + ; return rest } + else return (mkNonCanonical ev `consCts` rest) } + | otherwise + = return (mkNonCanonical ev `consCts` rest) + + finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) + + ---------------- + try_fill dflags tclvl ev ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 + , isTouchableOrFmv tclvl tv1 + , typeKind ty1 `isSubKind` tyVarKind tv1 + = tryFill dflags tv1 ty2 ev + | otherwise + = return False + +tryFill :: DynFlags -> TcTyVar -> TcType -> CtEvidence -> TcS Bool +-- (tryFill tv rhs ev) sees if 'tv' is an un-filled MetaTv +-- If so, and if tv does not appear in 'rhs', set tv := rhs +-- bind the evidence (which should be a CtWanted) to Refl +-- and return True. Otherwise return False +tryFill dflags tv rhs ev + = ASSERT2( not (isGiven ev), ppr ev ) + do { is_filled <- isFilledMetaTyVar tv + ; if is_filled then return False else + do { rhs' <- zonkTcType rhs + ; case occurCheckExpand dflags tv rhs' of + OC_OK rhs'' -- Normal case: fill the tyvar + -> do { when (isWanted ev) $ + setEvBind (ctEvId ev) + (EvCoercion (mkTcReflCo (ctEvRole ev) rhs'')) + ; setWantedTyBind tv rhs'' + ; return True } + + _ -> -- Occurs check + return False } } + +{- +Note [Unflatten using funeqs first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + [W] G a ~ Int + [W] F (G a) ~ G a + +do not want to end up with + [W} F Int ~ Int +because that might actually hold! Better to end up with the two above +unsolved constraints. The flat form will be + + G a ~ fmv1 (CFunEqCan) + F fmv1 ~ fmv2 (CFunEqCan) + fmv1 ~ Int (CTyEqCan) + fmv1 ~ fmv2 (CTyEqCan) + +Flatten using the fun-eqs first. +-} + +-- | Change the 'EqRel' in a 'FlattenEnv'. Avoids allocating a +-- new 'FlattenEnv' where possible. +setFEEqRel :: FlattenEnv -> EqRel -> FlattenEnv +setFEEqRel fmode@(FE { fe_eq_rel = old_eq_rel }) new_eq_rel + | old_eq_rel == new_eq_rel = fmode + | otherwise = fmode { fe_eq_rel = new_eq_rel } + +-- | Change the 'FlattenMode' in a 'FlattenEnv'. Avoids allocating +-- a new 'FlattenEnv' where possible. +setFEMode :: FlattenEnv -> FlattenMode -> FlattenEnv +setFEMode fmode@(FE { fe_mode = old_mode }) new_mode + | old_mode `eq` new_mode = fmode + | otherwise = fmode { fe_mode = new_mode } + where + FM_FlattenAll `eq` FM_FlattenAll = True + FM_SubstOnly `eq` FM_SubstOnly = True + FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 + _ `eq` _ = False diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs new file mode 100644 index 00000000..b3871623 --- /dev/null +++ b/compiler/typecheck/TcForeign.hs @@ -0,0 +1,548 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + +\section[TcForeign]{Typechecking \tr{foreign} declarations} + +A foreign declaration is used to either give an externally +implemented function a Haskell type (and calling interface) or +give a Haskell function an external calling interface. Either way, +the range of argument and result types these functions can accommodate +is restricted to what the outside world understands (read C), and this +module checks to see if a foreign declaration has got a legal type. +-} + +{-# LANGUAGE CPP #-} + +module TcForeign + ( tcForeignImports + , tcForeignExports + + -- Low-level exports for hooks + , isForeignImport, isForeignExport + , tcFImport, tcFExport + , tcForeignImports' + , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes + , normaliseFfiType + , nonIOok, mustBeIO + , checkSafe, noCheckSafe + , tcForeignExports' + , tcCheckFEType + ) where + +#include "HsVersions.h" + +import HsSyn + +import TcRnMonad +import TcHsType +import TcExpr +import TcEnv + +import FamInst +import FamInstEnv +import Coercion +import Type +import TypeRep +import ForeignCall +import ErrUtils +import Id +import Name +import RdrName +import DataCon +import TyCon +import TcType +import PrelNames +import DynFlags +import Outputable +import Platform +import SrcLoc +import Bag +import FastString +import Hooks + +import Control.Monad + +-- Defines a binding +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport _ _ _ _)) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport _ _ _ _)) = True +isForeignExport _ = False + +{- +Note [Don't recur in normaliseFfiType'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +normaliseFfiType' is the workhorse for normalising a type used in a foreign +declaration. If we have + +newtype Age = MkAge Int + +we want to see that Age -> IO () is the same as Int -> IO (). But, we don't +need to recur on any type parameters, because no paramaterized types (with +interesting parameters) are marshalable! The full list of marshalable types +is in the body of boxedMarshalableTyCon in TcType. The only members of that +list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled +the same way regardless of type parameter. So, no need to recur into +parameters. + +Similarly, we don't need to look in AppTy's, because nothing headed by +an AppTy will be marshalable. + +Note [FFI type roles] +~~~~~~~~~~~~~~~~~~~~~ +The 'go' helper function within normaliseFfiType' always produces +representational coercions. But, in the "children_only" case, we need to +use these coercions in a TyConAppCo. Accordingly, the roles on the coercions +must be twiddled to match the expectation of the enclosing TyCon. However, +we cannot easily go from an R coercion to an N one, so we forbid N roles +on FFI type constructors. Currently, only two such type constructors exist: +IO and FunPtr. Thus, this is not an onerous burden. + +If we ever want to lift this restriction, we would need to make 'go' take +the target role as a parameter. This wouldn't be hard, but it's a complication +not yet necessary and so is not yet implemented. +-} + +-- normaliseFfiType takes the type from an FFI declaration, and +-- evaluates any type synonyms, type functions, and newtypes. However, +-- we are only allowed to look through newtypes if the constructor is +-- in scope. We return a bag of all the newtype constructors thus found. +-- Always returns a Representational coercion +normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType ty + = do fam_envs <- tcGetFamInstEnvs + normaliseFfiType' fam_envs ty + +normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) +normaliseFfiType' env ty0 = go initRecTc ty0 + where + go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) + go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms + = go rec_nts ty' + + go rec_nts ty@(TyConApp tc tys) + -- We don't want to look through the IO newtype, even if it is + -- in scope, so we have a special case for it: + | tc_key `elem` [ioTyConKey, funPtrTyConKey] + -- These *must not* have nominal roles on their parameters! + -- See Note [FFI type roles] + = children_only + + | isNewTyCon tc -- Expand newtypes + , Just rec_nts' <- checkRecTc rec_nts tc + -- See Note [Expanding newtypes] in TyCon.lhs + -- We can't just use isRecursiveTyCon; sometimes recursion is ok: + -- newtype T = T (Ptr T) + -- Here, we don't reject the type for being recursive. + -- If this is a recursive newtype then it will normally + -- be rejected later as not being a valid FFI type. + = do { rdr_env <- getGlobalRdrEnv + ; case checkNewtypeFFI rdr_env tc of + Nothing -> nothing + Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs + ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } + + | isFamilyTyCon tc -- Expand open tycons + , (co, ty) <- normaliseTcApp env Representational tc tys + , not (isReflCo co) + = do (co', ty', gres) <- go rec_nts ty + return (mkTransCo co co', ty', gres) + + | otherwise + = nothing -- see Note [Don't recur in normaliseFfiType'] + where + tc_key = getUnique tc + children_only + = do xs <- mapM (go rec_nts) tys + let (cos, tys', gres) = unzip3 xs + -- the (repeat Representational) is because 'go' always + -- returns R coercions + cos' = zipWith3 downgradeRole (tyConRoles tc) + (repeat Representational) cos + return ( mkTyConAppCo Representational tc cos' + , mkTyConApp tc tys', unionManyBags gres) + nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys + nt_rhs = newTyConInstRhs tc tys + nothing = return (Refl Representational ty, ty, emptyBag) + + go rec_nts (FunTy ty1 ty2) + = do (coi1,nty1,gres1) <- go rec_nts ty1 + (coi2,nty2,gres2) <- go rec_nts ty2 + return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2) + + go rec_nts (ForAllTy tyvar ty1) + = do (coi,nty1,gres1) <- go rec_nts ty1 + return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1) + + go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag) + go _ ty@(LitTy {}) = return (Refl Representational ty, ty, emptyBag) + go _ ty@(AppTy {}) = return (Refl Representational ty, ty, emptyBag) + -- See Note [Don't recur in normaliseFfiType'] + +checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt +checkNewtypeFFI rdr_env tc + | Just con <- tyConSingleDataCon_maybe tc + , [gre] <- lookupGRE_Name rdr_env (dataConName con) + = Just gre -- See Note [Newtype constructor usage in foreign declarations] + | otherwise + = Nothing + +{- +Note [Newtype constructor usage in foreign declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC automatically "unwraps" newtype constructors in foreign import/export +declarations. In effect that means that a newtype data constructor is +used even though it is not mentioned expclitly in the source, so we don't +want to report it as "defined but not used" or "imported but not used". +eg newtype D = MkD Int + foreign import foo :: D -> IO () +Here 'MkD' us used. See Trac #7408. + +GHC also expands type functions during this process, so it's not enough +just to look at the free variables of the declaration. +eg type instance F Bool = D + foreign import bar :: F Bool -> IO () +Here again 'MkD' is used. + +So we really have wait until the type checker to decide what is used. +That's why tcForeignImports and tecForeignExports return a (Bag GRE) +for the newtype constructors they see. Then TcRnDriver can add them +to the module's usages. + + +************************************************************************ +* * +\subsection{Imports} +* * +************************************************************************ +-} + +tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) +tcForeignImports decls + = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) + +tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignImports' decls + = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ + filter isForeignImport decls + ; return (ids, decls, unionManyBags gres) } + +tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt) +tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) + = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + (_, t_ty) = tcSplitForAllTys norm_sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty + id = mkLocalId nm sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so TcHsSyn.zonkForeignExports ignores it). + + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl' + ; return (id, L dloc fi_decl, gres) } +tcFImport d = pprPanic "tcFImport" (ppr d) + +-- ------------ Checking types for foreign import ---------------------- + +tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) + -- Foreign import label + = do checkCg checkCOrAsmOrLlvmOrInterp + -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) + check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) + cconv' <- checkCConv cconv + return (CImport (L lc cconv') safety mh l src) + +tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do + -- Foreign wrapper (former f.e.d.) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of + [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys + checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty + where + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty + _ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected"))) + return (CImport (L lc cconv') safety mh CWrapper src) + +tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh + (CFunction target) src) + | isDynamicTarget target = do -- Foreign import dynamic + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + case arg_tys of -- The first arg must be Ptr or FunPtr + [] -> + addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected"))) + (arg1_ty:arg_tys) -> do + dflags <- getDynFlags + let curried_res_ty = foldr FunTy res_ty arg_tys + check (isFFIDynTy curried_res_ty arg1_ty) + (illegalForeignTyErr argument) + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + | cconv == PrimCallConv = do + dflags <- getDynFlags + checkTc (xopt Opt_GHCForeignImportPrim dflags) + (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + checkCg checkCOrAsmOrLlvmOrInterp + checkCTarget target + checkTc (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty + return idecl + | otherwise = do -- Normal foreign import + checkCg checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv cconv + checkCTarget target + dflags <- getDynFlags + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys + checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty + checkMissingAmpersand dflags arg_tys res_ty + case target of + StaticTarget _ _ False + | not (null arg_tys) -> + addErrTc (text "`value' imports cannot have function types") + _ -> return () + return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + + +-- This makes a convenient place to check +-- that the C identifier is valid for C +checkCTarget :: CCallTarget -> TcM () +checkCTarget (StaticTarget str _ _) = do + checkCg checkCOrAsmOrLlvmOrInterp + checkTc (isCLabelString str) (badCName str) + +checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" + + +checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () +checkMissingAmpersand dflags arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty && + wopt Opt_WarnDodgyForeignImports dflags + = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection{Exports} +* * +************************************************************************ +-} + +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) +tcForeignExports decls = + getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) + +tcForeignExports' :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) +-- For the (Bag GlobalRdrElt) result, +-- see Note [Newtype constructor usage in foreign declarations] +tcForeignExports' decls + = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) + where + combine (binds, fs, gres1) (L loc fe) = do + (b, f, gres2) <- setSrcSpan loc (tcFExport fe) + return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) + +tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) +tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) + = addErrCtxt (foreignDeclCtxt fo) $ do + + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcPolyExpr (nlHsVar nm) sig_ty + + (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty + + spec' <- tcCheckFEType norm_sig_ty spec + + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). + + + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres) +tcFExport d = pprPanic "tcFExport" (ppr d) + +-- ------------ Checking argument types for foreign export ---------------------- + +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport +tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do + checkCg checkCOrAsmOrLlvm + checkTc (isCLabelString str) (badCName str) + cconv' <- checkCConv cconv + checkForeignArgs isFFIExternalTy arg_tys + checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (L l (CExportStatic str cconv')) src) + where + -- Drop the foralls before inspecting n + -- the structure of the foreign type. + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty + +{- +************************************************************************ +* * +\subsection{Miscellaneous} +* * +************************************************************************ +-} + +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () +checkForeignArgs pred tys = mapM_ go tys + where + go ty = check (pred ty) (illegalForeignTyErr argument) + +------------ Checking result types for foreign calls ---------------------- +-- | Check that the type has the form +-- (IO t) or (t) , and that t satisfies the given predicate. +-- When calling this function, any newtype wrappers (should) have been +-- already dealt with by normaliseFfiType. +-- +-- We also check that the Safe Haskell condition of FFI imports having +-- results in the IO monad holds. +-- +checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () +checkForeignRes non_io_result_ok check_safe pred_res_ty ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) (illegalForeignTyErr result) + + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected")) + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ illegalForeignTyErr result msg + + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer + + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (illegalForeignTyErr result safeHsErr) + + -- sucess! non-IO return is fine + _ -> return () } + where + safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + +nonIOok, mustBeIO :: Bool +nonIOok = True +mustBeIO = False + +checkSafe, noCheckSafe :: Bool +checkSafe = True +noCheckSafe = False + +-- Checking a supported backend is in use + +checkCOrAsmOrLlvm :: HscTarget -> Validity +checkCOrAsmOrLlvm HscC = IsValid +checkCOrAsmOrLlvm HscAsm = IsValid +checkCOrAsmOrLlvm HscLlvm = IsValid +checkCOrAsmOrLlvm _ + = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") + +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity +checkCOrAsmOrLlvmOrInterp HscC = IsValid +checkCOrAsmOrLlvmOrInterp HscAsm = IsValid +checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid +checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid +checkCOrAsmOrLlvmOrInterp _ + = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") + +checkCg :: (HscTarget -> Validity) -> TcM () +checkCg check = do + dflags <- getDynFlags + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + IsValid -> return () + NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) + +-- Calling conventions + +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv +checkCConv StdCallConv = do dflags <- getDynFlags + let platform = targetPlatform dflags + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ + addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv +checkCConv JavaScriptCallConv = do dflags <- getDynFlags + if platformArch (targetPlatform dflags) == ArchJavaScript + then return JavaScriptCallConv + else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") + return JavaScriptCallConv + +-- Warnings + +check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check IsValid _ = return () +check (NotValid doc) err_fn = addErrTc (err_fn doc) + +illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr arg_or_res extra + = hang msg 2 extra + where + msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res + , ptext (sLit "type in foreign declaration:")] + +-- Used for 'arg_or_res' argument to illegalForeignTyErr +argument, result :: SDoc +argument = text "argument" +result = text "result" + +badCName :: CLabelString -> MsgDoc +badCName target + = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] + +foreignDeclCtxt :: ForeignDecl Name -> SDoc +foreignDeclCtxt fo + = hang (ptext (sLit "When checking declaration:")) + 2 (ppr fo) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs new file mode 100644 index 00000000..958adcd0 --- /dev/null +++ b/compiler/typecheck/TcGenDeriv.hs @@ -0,0 +1,2280 @@ +{- + % +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +TcGenDeriv: Generating derived instance declarations + +This module is nominally ``subordinate'' to @TcDeriv@, which is the +``official'' interface to deriving-related things. + +This is where we do all the grimy bindings' generation. +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +module TcGenDeriv ( + BagDerivStuff, DerivStuff(..), + + canDeriveAnyClass, + genDerivedBinds, + FFoldType(..), functorLikeTraverse, + deepSubtypesContaining, foldDataConArgs, + mkCoerceClassMethEqn, + gen_Newtype_binds, + genAuxBinds, + ordOpTbl, boxConTbl, + mkRdrFunBind + ) where + +#include "HsVersions.h" + +import HsSyn +import RdrName +import BasicTypes +import DataCon +import Name + +import DynFlags +import PrelInfo +import FamInstEnv( FamInst ) +import MkCore ( eRROR_ID ) +import PrelNames hiding (error_RDR) +import MkId ( coerceId ) +import PrimOp +import SrcLoc +import TyCon +import TcType +import TysPrim +import TysWiredIn +import Type +import Class +import TypeRep +import VarSet +import VarEnv +import State +import Util +import Var +#if __GLASGOW_HASKELL__ < 709 +import MonadUtils +#endif +import Outputable +import Lexeme +import FastString +import Pair +import Bag +import TcEnv (InstInfo) +import StaticFlags( opt_PprStyle_Debug ) + +import ListSetOps ( assocMaybe ) +import Data.List ( partition, intersperse ) +import Data.Maybe ( isNothing ) + +type BagDerivStuff = Bag DerivStuff + +data AuxBindSpec + = DerivCon2Tag TyCon -- The con2Tag for given TyCon + | DerivTag2Con TyCon -- ...ditto tag2Con + | DerivMaxTag TyCon -- ...and maxTag + deriving( Eq ) + -- All these generate ZERO-BASED tag operations + -- I.e first constructor has tag 0 + +data DerivStuff -- Please add this auxiliary stuff + = DerivAuxBind AuxBindSpec + + -- Generics + | DerivTyCon TyCon -- New data types + | DerivFamInst FamInst -- New type family instances + + -- New top-level auxiliary bindings + | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB + | DerivInst (InstInfo RdrName) -- New, auxiliary instances + +{- +************************************************************************ +* * + Top level function +* * +************************************************************************ +-} + +genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) +genDerivedBinds dflags fix_env clas loc tycon + | Just gen_fn <- assocMaybe gen_list (getUnique clas) + = gen_fn loc tycon + + | otherwise + -- Deriving any class simply means giving an empty instance, so no + -- bindings have to be generated. + = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas) + , ppr "genDerivStuff: bad derived class" <+> ppr clas ) + (emptyBag, emptyBag) + + where + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] + gen_list = [ (eqClassKey, gen_Eq_binds) + , (ordClassKey, gen_Ord_binds) + , (enumClassKey, gen_Enum_binds) + , (boundedClassKey, gen_Bounded_binds) + , (ixClassKey, gen_Ix_binds) + , (showClassKey, gen_Show_binds fix_env) + , (readClassKey, gen_Read_binds fix_env) + , (dataClassKey, gen_Data_binds dflags) + , (functorClassKey, gen_Functor_binds) + , (foldableClassKey, gen_Foldable_binds) + , (traversableClassKey, gen_Traversable_binds) ] + + +-- Nothing: we can (try to) derive it via Generics +-- Just s: we can't, reason s +canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc +canDeriveAnyClass dflags _tycon clas = + let b `orElse` s = if b then Nothing else Just (ptext (sLit s)) + Just m <> _ = Just m + Nothing <> n = n + -- We can derive a given class for a given tycon via Generics iff + in -- 1) The class is not a "standard" class (like Show, Functor, etc.) + (not (getUnique clas `elem` standardClassKeys) `orElse` "") + -- 2) Opt_DeriveAnyClass is on + <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass") + +{- +************************************************************************ +* * + Eq instances +* * +************************************************************************ + +Here are the heuristics for the code we generate for @Eq@. Let's +assume we have a data type with some (possibly zero) nullary data +constructors and some ordinary, non-nullary ones (the rest, also +possibly zero of them). Here's an example, with both \tr{N}ullary and +\tr{O}rdinary data cons. + + data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... + +* For the ordinary constructors (if any), we emit clauses to do The + Usual Thing, e.g.,: + + (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 + (==) (O2 a1) (O2 a2) = a1 == a2 + (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 + + Note: if we're comparing unlifted things, e.g., if 'a1' and + 'a2' are Float#s, then we have to generate + case (a1 `eqFloat#` a2) of r -> r + for that particular test. + +* If there are a lot of (more than en) nullary constructors, we emit a + catch-all clause of the form: + + (==) a b = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + case (a# ==# b#) of { + r -> r }}} + + If con2tag gets inlined this leads to join point stuff, so + it's better to use regular pattern matching if there aren't too + many nullary constructors. "Ten" is arbitrary, of course + +* If there aren't any nullary constructors, we emit a simpler + catch-all: + + (==) a b = False + +* For the @(/=)@ method, we normally just use the default method. + If the type is an enumeration type, we could/may/should? generate + special code that calls @con2tag_Foo@, much like for @(==)@ shown + above. + +We thought about doing this: If we're also deriving 'Ord' for this +tycon, we generate: + instance ... Eq (Foo ...) where + (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} + (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } +However, that requires that (Ord ) was put in the context +for the instance decl, which it probably wasn't, so the decls +produced don't get through the typechecker. +-} + +gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Eq_binds loc tycon + = (method_binds, aux_binds) + where + all_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons + + -- If there are ten or more (arbitrary number) nullary constructors, + -- use the con2tag stuff. For small types it's better to use + -- ordinary pattern matching. + (tag_match_cons, pat_match_cons) + | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) + | otherwise = ([], all_cons) + + no_tag_match_cons = null tag_match_cons + + fall_through_eqn + | no_tag_match_cons -- All constructors have arguments + = case pat_match_cons of + [] -> [] -- No constructors; no fall-though case + [_] -> [] -- One constructor; no fall-though case + _ -> -- Two or more constructors; add fall-through of + -- (==) _ _ = False + [([nlWildPat, nlWildPat], false_Expr)] + + | otherwise -- One or more tag_match cons; add fall-through of + -- extract tags compare for equality + = [([a_Pat, b_Pat], + untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds | no_tag_match_cons = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon + + method_binds = listToBag [eq_bind, ne_bind] + eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn) + ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) + + ------------------------------------------------------------------ + pats_etc data_con + = let + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed + + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con + in + ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) + where + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + where + nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b)) + +{- +************************************************************************ +* * + Ord instances +* * +************************************************************************ + +Note [Generating Ord instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose constructors are K1..Kn, and some are nullary. +The general form we generate is: + +* Do case on first argument + case a of + K1 ... -> rhs_1 + K2 ... -> rhs_2 + ... + Kn ... -> rhs_n + _ -> nullary_rhs + +* To make rhs_i + If i = 1, 2, n-1, n, generate a single case. + rhs_2 case b of + K1 {} -> LT + K2 ... -> ...eq_rhs(K2)... + _ -> GT + + Otherwise do a tag compare against the bigger range + (because this is the one most likely to succeed) + rhs_3 case tag b of tb -> + if 3 <# tg then GT + else case b of + K3 ... -> ...eq_rhs(K3).... + _ -> LT + +* To make eq_rhs(K), which knows that + a = K a1 .. av + b = K b1 .. bv + we just want to compare (a1,b1) then (a2,b2) etc. + Take care on the last field to tail-call into comparing av,bv + +* To make nullary_rhs generate this + case con2tag a of a# -> + case con2tag b of -> + a# `compare` b# + +Several special cases: + +* Two or fewer nullary constructors: don't generate nullary_rhs + +* Be careful about unlifted comparisons. When comparing unboxed + values we can't call the overloaded functions. + See function unliftedOrdOp + +Note [Do not rely on compare] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a bad idea to define only 'compare', and build the other binary +comparisons on top of it; see Trac #2130, #4019. Reason: we don't +want to laboriously make a three-way comparison, only to extract a +binary result, something like this: + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True + +So for sufficiently small types (few constructors, or all nullary) +we generate all methods; for large ones we just use 'compare'. +-} + +data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT + +------------ +ordMethRdr :: OrdOp -> RdrName +ordMethRdr op + = case op of + OrdCompare -> compare_RDR + OrdLT -> lt_RDR + OrdLE -> le_RDR + OrdGE -> ge_RDR + OrdGT -> gt_RDR + +------------ +ltResult :: OrdOp -> LHsExpr RdrName +-- Knowing a LHsExpr RdrName +-- Knowing a=b, what is the result for a `op` b? +eqResult OrdCompare = eqTag_Expr +eqResult OrdLT = false_Expr +eqResult OrdLE = true_Expr +eqResult OrdGE = true_Expr +eqResult OrdGT = false_Expr + +------------ +gtResult :: OrdOp -> LHsExpr RdrName +-- Knowing a>b, what is the result for a `op` b? +gtResult OrdCompare = gtTag_Expr +gtResult OrdLT = false_Expr +gtResult OrdLE = false_Expr +gtResult OrdGE = true_Expr +gtResult OrdGT = true_Expr + +------------ +gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Ord_binds loc tycon + | null tycon_data_cons -- No data-cons => invoke bale-out case + = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag) + | otherwise + = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds) + where + aux_binds | single_con_type = emptyBag + | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon + + -- Note [Do not rely on compare] + other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors + || null non_nullary_cons -- Or it's an enumeration + = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT]) + | otherwise + = emptyBag + + get_tag con = dataConTag con - fIRST_TAG + -- We want *zero-based* tags, because that's what + -- con2Tag returns (generated by untag_Expr)! + + tycon_data_cons = tyConDataCons tycon + single_con_type = isSingleton tycon_data_cons + (first_con : _) = tycon_data_cons + (last_con : _) = reverse tycon_data_cons + first_tag = get_tag first_con + last_tag = get_tag last_con + + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons + + + mkOrdOp :: OrdOp -> LHsBind RdrName + -- Returns a binding op a b = ... compares a and b according to op .... + mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op) + + mkOrdOpRhs :: OrdOp -> LHsExpr RdrName + mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op + | length nullary_cons <= 2 -- Two nullary or fewer, so use cases + = nlHsCase (nlHsVar a_RDR) $ + map (mkOrdOpAlt op) tycon_data_cons + -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... + -- C2 x -> case b of C2 x -> ....comopare x.... } + + | null non_nullary_cons -- All nullary, so go straight to comparing tags + = mkTagCmp op + + | otherwise -- Mixed nullary and non-nullary + = nlHsCase (nlHsVar a_RDR) $ + (map (mkOrdOpAlt op) non_nullary_cons + ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)]) + + + mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) + -- Make the alternative (Ki a1 a2 .. av -> + mkOrdOpAlt op data_con + = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con) + where + as_needed = take (dataConSourceArity data_con) as_RDRs + data_con_RDR = getRdrName data_con + + mkInnerRhs op data_con + | single_con_type + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] + + | tag == first_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (ltResult op) ] + | tag == last_tag + = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (gtResult op) ] + + | tag == first_tag + 1 + = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op) + , mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (ltResult op) ] + | tag == last_tag - 1 + = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op) + , mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (gtResult op) ] + + | tag > last_tag `div` 2 -- lower range is larger + = untag_Expr tycon [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) + (gtResult op) $ -- Definitely GT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (ltResult op) ] + + | otherwise -- upper range is larger + = untag_Expr tycon [(b_RDR, bh_RDR)] $ + nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) + (ltResult op) $ -- Definitely LT + nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con + , mkSimpleHsAlt nlWildPat (gtResult op) ] + where + tag = get_tag data_con + tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag))) + + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) + -- First argument 'a' known to be built with K + -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) + mkInnerEqAlt op data_con + = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $ + mkCompareFields tycon op (dataConOrigArgTys data_con) + where + data_con_RDR = getRdrName data_con + bs_needed = take (dataConSourceArity data_con) bs_RDRs + + mkTagCmp :: OrdOp -> LHsExpr RdrName + -- Both constructors known to be nullary + -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# + mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ + unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR + +mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName +-- Generates nested comparisons for (a1,a2...) against (b1,b2,...) +-- where the ai,bi have the given types +mkCompareFields tycon op tys + = go tys as_RDRs bs_RDRs + where + go [] _ _ = eqResult op + go [ty] (a:_) (b:_) + | isUnLiftedType ty = unliftedOrdOp tycon ty op a b + | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) + go (ty:tys) (a:as) (b:bs) = mk_compare ty a b + (ltResult op) + (go tys as bs) + (gtResult op) + go _ _ _ = panic "mkCompareFields" + + -- (mk_compare ty a b) generates + -- (case (compare a b) of { LT -> ; EQ -> ; GT -> }) + -- but with suitable special cases for + mk_compare ty a b lt eq gt + | isUnLiftedType ty + = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + | otherwise + = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) + [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt, + mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq, + mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt] + where + a_expr = nlHsVar a + b_expr = nlHsVar b + (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty + +unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName +unliftedOrdOp tycon ty op a b + = case op of + OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr + ltTag_Expr eqTag_Expr gtTag_Expr + OrdLT -> wrap lt_op + OrdLE -> wrap le_op + OrdGE -> wrap ge_op + OrdGT -> wrap gt_op + where + (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty + wrap prim_op = genPrimOpApp a_expr prim_op b_expr + a_expr = nlHsVar a + b_expr = nlHsVar b + +unliftedCompare :: RdrName -> RdrName + -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare + -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results + -> LHsExpr RdrName +-- Return (if a < b then lt else if a == b then eq else gt) +unliftedCompare lt_op eq_op a_expr b_expr lt eq gt + = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $ + -- Test (<) first, not (==), because the latter + -- is true less often, so putting it first would + -- mean more tests (dynamically) + nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt + +nlConWildPat :: DataCon -> LPat RdrName +-- The pattern (K {}) +nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) + (RecCon (HsRecFields { rec_flds = [] + , rec_dotdot = Nothing }))) + +{- +************************************************************************ +* * + Enum instances +* * +************************************************************************ + +@Enum@ can only be derived for enumeration types. For a type +\begin{verbatim} +data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} + +we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). + +\begin{verbatim} +instance ... Enum (Foo ...) where + succ x = toEnum (1 + fromEnum x) + pred x = toEnum (fromEnum x - 1) + + toEnum i = tag2con_Foo i + + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] + + -- or, really... + enumFrom a + = case con2tag_Foo a of + a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) + + enumFromThen a b + = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] + + -- or, really... + enumFromThen a b + = case con2tag_Foo a of { a# -> + case con2tag_Foo b of { b# -> + map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) + }} +\end{verbatim} + +For @enumFromTo@ and @enumFromThenTo@, we use the default methods. +-} + +gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Enum_binds loc tycon + = (method_binds, aux_binds) + where + method_binds = listToBag [ + succ_enum, + pred_enum, + to_enum, + enum_from, + enum_from_then, + from_enum + ] + aux_binds = listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] + + occ_nm = getOccString tycon + + succ_enum + = mk_easy_FunBind loc succ_RDR [a_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") + (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsIntLit 1])) + + pred_enum + = mk_easy_FunBind loc pred_RDR [a_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, + nlHsVarApps intDataCon_RDR [ah_RDR]]) + (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") + (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsLit (HsInt "-1" (-1))])) + + to_enum + = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ + nlHsIf (nlHsApps and_RDR + [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], + nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) + (nlHsVarApps (tag2con_RDR tycon) [a_RDR]) + (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) + + enum_from + = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + nlHsApps map_RDR + [nlHsVar (tag2con_RDR tycon), + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVar (maxtag_RDR tycon)))] + + enum_from_then + = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + nlHsPar (enum_from_then_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR]) + (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsVarApps intDataCon_RDR [bh_RDR]]) + (nlHsIntLit 0) + (nlHsVar (maxtag_RDR tycon)) + )) + + from_enum + = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + (nlHsVarApps intDataCon_RDR [ah_RDR]) + +{- +************************************************************************ +* * + Bounded instances +* * +************************************************************************ +-} + +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Bounded_binds loc tycon + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) + where + data_cons = tyConDataCons tycon + + ----- enum-flavored: --------------------------- + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + + data_con_1 = head data_cons + data_con_N = last data_cons + data_con_1_RDR = getRdrName data_con_1 + data_con_N_RDR = getRdrName data_con_N + + ----- single-constructor-flavored: ------------- + arity = dataConSourceArity data_con_1 + + min_bound_1con = mkHsVarBind loc minBound_RDR $ + nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) + max_bound_1con = mkHsVarBind loc maxBound_RDR $ + nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) + +{- +************************************************************************ +* * + Ix instances +* * +************************************************************************ + +Deriving @Ix@ is only possible for enumeration types and +single-constructor types. We deal with them in turn. + +For an enumeration type, e.g., +\begin{verbatim} + data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} +things go not too differently from @Enum@: +\begin{verbatim} +instance ... Ix (Foo ...) where + range (a, b) + = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] + + -- or, really... + range (a, b) + = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + map tag2con_Foo (enumFromTo (I# a#) (I# b#)) + }} + + -- Generate code for unsafeIndex, because using index leads + -- to lots of redundant range tests + unsafeIndex c@(a, b) d + = case (con2tag_Foo d -# con2tag_Foo a) of + r# -> I# r# + + inRange (a, b) c + = let + p_tag = con2tag_Foo c + in + p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b + + -- or, really... + inRange (a, b) c + = case (con2tag_Foo a) of { a_tag -> + case (con2tag_Foo b) of { b_tag -> + case (con2tag_Foo c) of { c_tag -> + if (c_tag >=# a_tag) then + c_tag <=# b_tag + else + False + }}} +\end{verbatim} +(modulo suitable case-ification to handle the unlifted tags) + +For a single-constructor type (NB: this includes all tuples), e.g., +\begin{verbatim} + data Foo ... = MkFoo a b Int Double c c +\end{verbatim} +we follow the scheme given in Figure~19 of the Haskell~1.2 report +(p.~147). +-} + +gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) + +gen_Ix_binds loc tycon + | isEnumerationTyCon tycon + = ( enum_ixes + , listToBag $ map DerivAuxBind + [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) + | otherwise + = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) + where + -------------------------------------------------------------- + enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] + + enum_range + = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + untag_Expr tycon [(a_RDR, ah_RDR)] $ + untag_Expr tycon [(b_RDR, bh_RDR)] $ + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR])) + + enum_index + = mk_easy_FunBind loc unsafeIndex_RDR + [noLoc (AsPat (noLoc c_RDR) + (nlTuplePat [a_Pat, nlWildPat] Boxed)), + d_Pat] ( + untag_Expr tycon [(a_RDR, ah_RDR)] ( + untag_Expr tycon [(d_RDR, dh_RDR)] ( + let + rhs = nlHsVarApps intDataCon_RDR [c_RDR] + in + nlHsCase + (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) + [mkSimpleHsAlt (nlVarPat c_RDR) rhs] + )) + ) + + enum_inRange + = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + untag_Expr tycon [(a_RDR, ah_RDR)] ( + untag_Expr tycon [(b_RDR, bh_RDR)] ( + untag_Expr tycon [(c_RDR, ch_RDR)] ( + nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) ( + (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)) + ) {-else-} ( + false_Expr + )))) + + -------------------------------------------------------------- + single_con_ixes + = listToBag [single_con_range, single_con_index, single_con_inRange] + + data_con + = case tyConSingleDataCon_maybe tycon of -- just checking... + Nothing -> panic "get_Ix_binds" + Just dc -> dc + + con_arity = dataConSourceArity data_con + data_con_RDR = getRdrName data_con + + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + cs_needed = take con_arity cs_RDRs + + con_pat xs = nlConVarPat data_con_RDR xs + con_expr = nlHsVarApps data_con_RDR cs_needed + + -------------------------------------------------------------- + single_con_range + = mk_easy_FunBind loc range_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ + noLoc (mkHsComp ListComp stmts con_expr) + where + stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed + + mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) + (nlHsApp (nlHsVar range_RDR) + (mkLHsVarTuple [a,b])) + + ---------------- + single_con_index + = mk_easy_FunBind loc unsafeIndex_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) + where + -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) + mk_index [] = nlHsIntLit 0 + mk_index [(l,u,i)] = mk_one l u i + mk_index ((l,u,i) : rest) + = genOpApp ( + mk_one l u i + ) plus_RDR ( + genOpApp ( + (nlHsApp (nlHsVar unsafeRangeSize_RDR) + (mkLHsVarTuple [l,u])) + ) times_RDR (mk_index rest) + ) + mk_one l u i + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] + + ------------------ + single_con_inRange + = mk_easy_FunBind loc inRange_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] $ + foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) + where + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] + +{- +************************************************************************ +* * + Read instances +* * +************************************************************************ + +Example + + infix 4 %% + data T = Int %% Int + | T1 { f1 :: Int } + | T2 T + +instance Read T where + readPrec = + parens + ( prec 4 ( + do x <- ReadP.step Read.readPrec + expectP (Symbol "%%") + y <- ReadP.step Read.readPrec + return (x %% y)) + +++ + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application + do expectP (Ident "T1") + expectP (Punc '{') + expectP (Ident "f1") + expectP (Punc '=') + x <- ReadP.reset Read.readPrec + expectP (Punc '}') + return (T1 { f1 = x })) + +++ + prec appPrec ( + do expectP (Ident "T2") + x <- ReadP.step Read.readPrec + return (T2 x)) + ) + + readListPrec = readListPrecDefault + readList = readListDefault + + +Note [Use expectP] +~~~~~~~~~~~~~~~~~~ +Note that we use + expectP (Ident "T1") +rather than + Ident "T1" <- lexP +The latter desugares to inline code for matching the Ident and the +string, and this can be very voluminous. The former is much more +compact. Cf Trac #7258, although that also concerned non-linearity in +the occurrence analyser, a separate issue. + +Note [Read for empty data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we get for this? (Trac #7931) + data Emp deriving( Read ) -- No data constructors + +Here we want + read "[]" :: [Emp] to succeed, returning [] +So we do NOT want + instance Read Emp where + readPrec = error "urk" +Rather we want + instance Read Emp where + readPred = pfail -- Same as choose [] + +Because 'pfail' allows the parser to backtrack, but 'error' doesn't. +These instances are also useful for Read (Either Int Emp), where +we want to be able to parse (Left 3) just fine. +-} + +gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) + +gen_Read_binds get_fixity loc tycon + = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) + where + ----------------------------------------------------------------------- + default_readlist + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + + default_readlistprec + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + ----------------------------------------------------------------------- + + data_cons = tyConDataCons tycon + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons + + read_prec = mkHsVarBind loc readPrec_RDR + (nlHsApp (nlHsVar parens_RDR) read_cons) + + read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types] + | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) + read_non_nullary_cons = map read_non_nullary_con non_nullary_cons + + read_nullary_cons + = case nullary_cons of + [] -> [] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] + _ -> [nlHsApp (nlHsVar choose_RDR) + (nlList (map mk_pair nullary_cons))] + -- NB For operators the parens around (:=:) are matched by the + -- enclosing "parens" call, so here we must match the naked + -- data_con_str con + + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str + where + con_str = data_con_str con + -- For nullary constructors we must match Ident s for normal constrs + -- and Symbol s for operators + + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + + read_non_nullary_con data_con + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser + where + body = result_expr data_con as_needed + con_str = data_con_str data_con + + prefix_parser = mk_parser prefix_prec prefix_stmts body + + read_prefix_con + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str + + read_infix_con + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + + infix_stmts -- a %% b, or a `T` b + = [read_a1] + ++ read_infix_con + ++ [read_a2] + + record_stmts -- T { f1 = a, f2 = b } + = read_prefix_con + ++ [read_punc "{"] + ++ concat (intersperse [read_punc ","] field_stmts) + ++ [read_punc "}"] + + field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed + + con_arity = dataConSourceArity data_con + labels = dataConFieldLabels data_con + dc_nm = getName data_con + is_infix = dataConIsInfix data_con + is_record = length labels > 0 + as_needed = take con_arity as_RDRs + read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) + (read_a1:read_a2:_) = read_args + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) + + ------------------------------------------------------------------------ + -- Helpers + ------------------------------------------------------------------------ + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + -- See Note [Use expectP] + ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") + symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") + read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") + + data_con_str con = occNameString (getOccName con) + + read_arg a ty = ASSERT( not (isUnLiftedType ty) ) + noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + + read_field lbl a = read_lbl lbl ++ + [read_punc "=", + noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))] + + -- When reading field labels we might encounter + -- a = 3 + -- _a = 3 + -- or (#) = 4 + -- Note the parens! + read_lbl lbl | isSym lbl_str + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] + | otherwise + = ident_h_pat lbl_str + where + lbl_str = occNameString (getOccName lbl) + +{- +************************************************************************ +* * + Show instances +* * +************************************************************************ + +Example + + infixr 5 :^: + + data Tree a = Leaf a | Tree a :^: Tree a + + instance (Show a) => Show (Tree a) where + + showsPrec d (Leaf m) = showParen (d > app_prec) showStr + where + showStr = showString "Leaf " . showsPrec (app_prec+1) m + + showsPrec d (u :^: v) = showParen (d > up_prec) showStr + where + showStr = showsPrec (up_prec+1) u . + showString " :^: " . + showsPrec (up_prec+1) v + -- Note: right-associativity of :^: ignored + + up_prec = 5 -- Precedence of :^: + app_prec = 10 -- Application has precedence one more than + -- the most tightly-binding operator +-} + +gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) + +gen_Show_binds get_fixity loc tycon + = (listToBag [shows_prec, show_list], emptyBag) + where + ----------------------------------------------------------------------- + show_list = mkHsVarBind loc showList_RDR + (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) + ----------------------------------------------------------------------- + data_cons = tyConDataCons tycon + shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons) + + pats_etc data_con + | nullary_con = -- skip the showParen junk... + ASSERT(null bs_needed) + ([nlWildPat, con_pat], mk_showString_app op_con_str) + | otherwise = + ([a_Pat, con_pat], + showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR + (nlHsLit (HsInt "" con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) + where + data_con_RDR = getRdrName data_con + con_arity = dataConSourceArity data_con + bs_needed = take con_arity bs_RDRs + arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed + con_pat = nlConVarPat data_con_RDR bs_needed + nullary_con = con_arity == 0 + labels = dataConFieldLabels data_con + lab_fields = length labels + record_syntax = lab_fields > 0 + + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + con_str = occNameString dc_occ_nm + op_con_str = wrapOpParens con_str + backquote_str = wrapOpBackquotes con_str + + show_thingies + | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] + | record_syntax = mk_showString_app (op_con_str ++ " {") : + show_record_args ++ [mk_showString_app "}"] + | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args + + show_label l = mk_showString_app (nm ++ " = ") + -- Note the spaces around the "=" sign. If we + -- don't have them then we get Foo { x=-1 } and + -- the "=-" parses as a single lexeme. Only the + -- space after the '=' is necessary, but it + -- seems tidier to have them both sides. + where + occ_nm = getOccName l + nm = wrapOpParens (occNameString occ_nm) + + show_args = zipWith show_arg bs_needed arg_tys + (show_arg1:show_arg2:_) = show_args + show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args + + -- Assumption for record syntax: no of fields == no of + -- labelled fields (and in same order) + show_record_args = concat $ + intersperse [mk_showString_app ", "] $ + [ [show_label lbl, arg] + | (lbl,arg) <- zipEqual "gen_Show_binds" + labels show_args ] + + -- Generates (showsPrec p x) for argument x, but it also boxes + -- the argument first if necessary. Note that this prints unboxed + -- things without any '#' decorations; could change that if need be + show_arg b arg_ty = nlHsApps showsPrec_RDR + [nlHsLit (HsInt "" arg_prec), + box_if_necy "Show" tycon (nlHsVar b) arg_ty] + + -- Fixity stuff + is_infix = dataConIsInfix data_con + con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm + arg_prec | record_syntax = 0 -- Record fields don't need parens + | otherwise = con_prec_plus_one + +wrapOpParens :: String -> String +wrapOpParens s | isSym s = '(' : s ++ ")" + | otherwise = s + +wrapOpBackquotes :: String -> String +wrapOpBackquotes s | isSym s = s + | otherwise = '`' : s ++ "`" + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +mk_showString_app :: String -> LHsExpr RdrName +mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) + +getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer +getPrec is_infix get_fixity nm + | not is_infix = appPrecedence + | otherwise = getPrecedence get_fixity nm + +appPrecedence :: Integer +appPrecedence = fromIntegral maxPrecedence + 1 + -- One more than the precedence of the most + -- tightly-binding operator + +getPrecedence :: (Name -> Fixity) -> Name -> Integer +getPrecedence get_fixity nm + = case get_fixity nm of + Fixity x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here + +{- +************************************************************************ +* * + Data instances +* * +************************************************************************ + +From the data type + + data T a b = T1 a b | T2 + +we generate + + $cT1 = mkDataCon $dT "T1" Prefix + $cT2 = mkDataCon $dT "T2" Prefix + $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] + -- the [] is for field labels. + + instance (Data a, Data b) => Data (T a b) where + gfoldl k z (T1 a b) = z T `k` a `k` b + gfoldl k z T2 = z T2 + -- ToDo: add gmapT,Q,M, gfoldr + + gunfold k z c = case conIndex c of + I# 1# -> k (k (z T1)) + I# 2# -> z T2 + + toConstr (T1 _ _) = $cT1 + toConstr T2 = $cT2 + + dataTypeOf _ = $dT + + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * +-} + +gen_Data_binds :: DynFlags + -> SrcSpan + -> TyCon -- For data families, this is the + -- *representation* TyCon + -> (LHsBinds RdrName, -- The method bindings + BagDerivStuff) -- Auxiliary bindings +gen_Data_binds dflags loc rep_tc + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] + `unionBags` gcast_binds, + -- Auxiliary definitions: the data type and constructors + listToBag ( DerivHsBind (genDataTyCon) + : map (DerivHsBind . genDataDataCon) data_cons)) + where + data_cons = tyConDataCons rep_tc + n_cons = length data_cons + one_constr = n_cons == 1 + + genDataTyCon :: (LHsBind RdrName, LSig RdrName) + genDataTyCon -- $dT + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) + where + rdr_name = mk_data_type_name rep_tc + sig_ty = nlHsTyVar dataType_RDR + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc] + rhs = nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) + `nlHsApp` nlList constrs + + genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) + genDataDataCon dc -- $cT1 etc + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) + where + rdr_name = mk_constr_name dc + sig_ty = nlHsTyVar constr_RDR + rhs = nlHsApps mkConstr_RDR constr_args + + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType + nlHsLit (mkHsString (occNameString dc_occ)), -- String name + nlList labels, -- Field labels + nlHsVar fixity] -- Fixity + + labels = map (nlHsLit . mkHsString . getOccString) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + + ------------ gfoldl + gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) + + gfoldl_eqn con + = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], + foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) + where + con_name :: RdrName + con_name = getRdrName con + as_needed = take (dataConSourceArity con) as_RDRs + mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) + + ------------ gunfold + gunfold_bind = mk_FunBind loc + gunfold_RDR + [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], + gunfold_rhs)] + + gunfold_rhs + | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) + + gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp + (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR + [nlLitPat (HsIntPrim "" (toInteger tag))] + where + tag = dataConTag dc + + ------------ toConstr + toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons) + to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc)) + + ------------ dataTypeOf + dataTypeOf_bind = mk_easy_FunBind + loc + dataTypeOf_RDR + [nlWildPat] + (nlHsVar (mk_data_type_name rep_tc)) + + ------------ gcast1/2 + -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * + -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * + -- (or nothing if T has neither of these two types) + + -- But care is needed for data families: + -- If we have data family D a + -- data instance D (a,b,c) = A | B deriving( Data ) + -- and we want instance ... => Data (D [(a,b,c)]) where ... + -- then we need dataCast1 x = gcast1 x + -- because D :: * -> * + -- even though rep_tc has kind * -> * -> * -> * + -- Hence looking for the kind of fam_tc not rep_tc + -- See Trac #4896 + tycon_kind = case tyConFamInst_maybe rep_tc of + Just (fam_tc, _) -> tyConKind fam_tc + Nothing -> tyConKind rep_tc + gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = emptyBag + mk_gcast dataCast_RDR gcast_RDR + = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) + + +kind1, kind2 :: Kind +kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind +kind2 = liftedTypeKind `mkArrowKind` kind1 + +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, + constr_RDR, dataType_RDR, + eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , + eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , + eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , + eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , + eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , + eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") +gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") + +eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") +ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") +leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") +gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") +geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") + +eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") +ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) +leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") +gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) +geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") + +eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") +ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") +leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") +gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") +geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") + +eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") +ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") +leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") +gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") +geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") + +eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") +ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") +leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") +gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") +geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") + +eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") +ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) +leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") +gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) +geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") + +{- +************************************************************************ +* * + Functor instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +For the data type: + + data T a = T1 Int a | T2 (T a) + +We generate the instance: + + instance Functor T where + fmap f (T1 b1 a) = T1 b1 (f a) + fmap f (T2 ta) = T2 (fmap f ta) + +Notice that we don't simply apply 'fmap' to the constructor arguments. +Rather + - Do nothing to an argument whose type doesn't mention 'a' + - Apply 'f' to an argument of type 'a' + - Apply 'fmap f' to other arguments +That's why we have to recurse deeply into the constructor argument types, +rather than just one level, as we typically do. + +What about types with more than one type parameter? In general, we only +derive Functor for the last position: + + data S a b = S1 [b] | S2 (a, T a b) + instance Functor (S a) where + fmap f (S1 bs) = S1 (fmap f bs) + fmap f (S2 (p,q)) = S2 (a, fmap f q) + +However, we have special cases for + - tuples + - functions + +More formally, we write the derivation of fmap code over type variable +'a for type 'b as ($fmap 'a 'b). In this general notation the derived +instance for T is: + + instance Functor T where + fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) + fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) + + $(fmap 'a 'b) = \x -> x -- when b does not contain a + $(fmap 'a 'a) = f + $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2) + $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2 + $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b)) + +For functions, the type parameter 'a can occur in a contravariant position, +which means we need to derive a function like: + + cofmap :: (a -> b) -> (f b -> f a) + +This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: + + $(cofmap 'a 'b) = \x -> x -- when b does not contain a + $(cofmap 'a 'a) = error "type variable in contravariant position" + $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) + $(cofmap 'a '[b]) = map $(cofmap 'a 'b) + $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2 + $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b)) + +Note that the code produced by $(fmap _ _) is always a higher order function, +with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern +matching on the type, this means create a lambda function (see the (,) case above). +The resulting code for fmap can look a bit weird, for example: + + data X a = X (a,Int) + -- generated instance + instance Functor X where + fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x + +The optimizer should be able to simplify this code by simple inlining. + +An older version of the deriving code tried to avoid these applied +lambda functions by producing a meta level function. But the function to +be mapped, `f`, is a function on the code level, not on the meta level, +so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion. +It is better to produce too many lambdas than to eta expand, see ticket #7436. +-} + +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Functor_binds loc tycon + = (unitBag fmap_bind, emptyBag) + where + data_cons = tyConDataCons tycon + fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns + + fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_fmap con + + eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] + (error_Expr "Void fmap")] + | otherwise = map fmap_eqn data_cons + + ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName)) + ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- fmap f = \x -> x + , ft_var = return f_Expr -- fmap f = f + , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b)) + gg <- g + hh <- h + mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b)) + , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) + gg <- sequence gs + mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g + , ft_forall = \_ g -> g + , ft_bad_app = panic "in other argument" + , ft_co_var = panic "contravariant" } + + -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... + match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName] + -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) + match_for_con = mkSimpleConMatch $ + \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. + +{- +Utility functions related to Functor deriving. + +Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. +This function works like a fold: it makes a value of type 'a' in a bottom up way. +-} + +-- Generic traversal for Functor deriving +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a -- Does not contain variable + , ft_var :: a -- The variable itself + , ft_co_var :: a -- The variable itself, contravariantly + , ft_fun :: a -> a -> a -- Function type + , ft_tup :: TupleSort -> [a] -> a -- Tuple type + , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument + , ft_bad_app :: a -- Type app, variable other than in last argument + , ft_forall :: TcTyVar -> a -> a -- Forall type + } + +functorLikeTraverse :: forall a. + TyVar -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> a +functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = fst (go False ty) + where + go :: Bool -- Covariant or contravariant context + -> Type + -> (a, Bool) -- (result of type a, does type contain var) + + go co ty | Just ty' <- coreView ty = go co ty' + go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) + go co (FunTy x y) | isPredTy x = go co y + | xc || yc = (caseFun xr yr,True) + where (xr,xc) = go (not co) x + (yr,yc) = go co y + go co (AppTy x y) | xc = (caseWrongArg, True) + | yc = (caseTyApp x yr, True) + where (_, xc) = go co x + (yr,yc) = go co y + go co ty@(TyConApp con args) + | not (or xcs) = (caseTrivial, False) -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True) + | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty + | otherwise = case splitAppTy_maybe ty of -- T (..no var..) ty + Nothing -> (caseWrongArg, True) -- Non-decomposable (eg type function) + Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True) + where + (xrs,xcs) = unzip (map (go co) args) + go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x + go _ _ = (caseTrivial,False) + +-- Return all syntactic subterms of ty that contain var somewhere +-- These are the things that should appear in instance constraints +deepSubtypesContaining :: TyVar -> Type -> [TcType] +deepSubtypesContaining tv + = functorLikeTraverse tv + (FT { ft_triv = [] + , ft_var = [] + , ft_fun = (++) + , ft_tup = \_ xs -> concat xs + , ft_ty_app = (:) + , ft_bad_app = panic "in other argument" + , ft_co_var = panic "contravariant" + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs }) + + +foldDataConArgs :: FFoldType a -> DataCon -> [a] +-- Fold over the arguments of the datacon +foldDataConArgs ft con + = map (functorLikeTraverse tv ft) (dataConOrigArgTys con) + where + Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) + -- Argument to derive for, 'a in the above description + -- The validity and kind checks have ensured that + -- the Just will match and a::* + +-- Make a HsLam using a fresh variable from a State monad +mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) + -> State [RdrName] (LHsExpr RdrName) +-- (mkSimpleLam fn) returns (\x. fn(x)) +mkSimpleLam lam = do + (n:names) <- get + put names + body <- lam (nlHsVar n) + return (mkHsLam [nlVarPat n] body) + +mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName + -> State [RdrName] (LHsExpr RdrName)) + -> State [RdrName] (LHsExpr RdrName) +mkSimpleLam2 lam = do + (n1:n2:names) <- get + put names + body <- lam (nlHsVar n1) (nlHsVar n2) + return (mkHsLam [nlVarPat n1,nlVarPat n2] body) + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) + -> [LPat RdrName] + -> DataCon + -> [LHsExpr RdrName] + -> m (LMatch RdrName (LHsExpr RdrName)) +mkSimpleConMatch fold extra_pats con insides = do + let con_name = getRdrName con + let vars_needed = takeList insides as_RDRs + let pat = nlConVarPat con_name vars_needed + rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) + return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] + -> m (LMatch RdrName (LHsExpr RdrName))) + -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName) +mkSimpleTupleCase match_for_con sort insides x = do + let con = tupleCon sort (length insides) + match <- match_for_con [] con insides + return $ nlHsCase x [match] + +{- +************************************************************************ +* * + Foldable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html + +* * +************************************************************************ + +Deriving Foldable instances works the same way as Functor instances, +only Foldable instances are not possible for function types at all. +Here the derived instance for the type T above is: + + instance Foldable T where + foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) ) + +The cases are: + + $(foldr 'a 'b) = \x z -> z -- when b does not contain a + $(foldr 'a 'a) = f + $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) + $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 + +Note that the arguments to the real foldr function are the wrong way around, +since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). +-} + +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Foldable_binds loc tycon + = (listToBag [foldr_bind, foldMap_bind], emptyBag) + where + data_cons = tyConDataCons tycon + + foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns + eqns = map foldr_eqn data_cons + foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldr con + + foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) + foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_foldMap con + + ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName)) + ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z + , ft_var = return f_Expr -- foldr f = f + , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...) + mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x + , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x) + mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x] + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant" + , ft_fun = panic "function" + , ft_bad_app = panic "in other argument" } + + match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z)) + + ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName)) + ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty + , ft_var = return f_Expr -- foldMap f = f + , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,) + mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg + , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant" + , ft_fun = panic "function" + , ft_bad_app = panic "in other argument" } + + match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $ + case xs of + [] -> mempty_Expr + xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs + +{- +************************************************************************ +* * + Traversable instances + + see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html +* * +************************************************************************ + +Again, Traversable is much like Functor and Foldable. + +The cases are: + + $(traverse 'a 'b) = pure -- when b does not contain a + $(traverse 'a 'a) = f + $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2 + $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 + +Note that the generated code is not as efficient as it could be. For instance: + + data T a = T Int a deriving Traversable + +gives the function: traverse f (T x y) = T <$> pure x <*> f y +instead of: traverse f (T x y) = T x <$> f y +-} + +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +gen_Traversable_binds loc tycon + = (unitBag traverse_bind, emptyBag) + where + data_cons = tyConDataCons tycon + + traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns + eqns = map traverse_eqn data_cons + traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs + where + parts = sequence $ foldDataConArgs ft_trav con + + + ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName)) + ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x + , ft_var = return f_Expr -- traverse f = f x + , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) -> + gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> .. + mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g + , ft_forall = \_ g -> g + , ft_co_var = panic "contravariant" + , ft_fun = panic "function" + , ft_bad_app = panic "in other argument" } + + -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ... + match_for_con = mkSimpleConMatch $ + \con_name xs -> return $ mkApCon (nlHsVar con_name) xs + + -- ((Con <$> x1) <*> x2) <*> .. + mkApCon con [] = nlHsApps pure_RDR [con] + mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs + where appAp x y = nlHsApps ap_RDR [x,y] + +{- +************************************************************************ +* * + Newtype-deriving instances +* * +************************************************************************ + +We take every method in the original instance and `coerce` it to fit +into the derived instance. We need a type annotation on the argument +to `coerce` to make it obvious what instantiation of the method we're +coercing from. + +See #8503 for more discussion. +-} + +mkCoerceClassMethEqn :: Class -- the class being derived + -> [TyVar] -- the tvs in the instance head + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type (already eta-reduced) + -> Id -- the method to look at + -> Pair Type +mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id + = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty) + where + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys) + rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty)) + (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id) + + changeLast :: [a] -> a -> [a] + changeLast [] _ = panic "changeLast" + changeLast [_] x = [x] + changeLast (x:xs) x' = x : changeLast xs x' + + +gen_Newtype_binds :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type (already eta-reduced) + -> LHsBinds RdrName +gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty + = listToBag $ zipWith mk_bind + (classMethods cls) + (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls)) + where + coerce_RDR = getRdrName coerceId + mk_bind :: Id -> Pair Type -> LHsBind RdrName + mk_bind id (Pair tau_ty user_ty) + = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr] + where + meth_RDR = getRdrName id + rhs_expr + = ( nlHsVar coerce_RDR + `nlHsApp` + (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty')) + `nlExprWithTySig` toHsType user_ty + -- Open the representation type here, so that it's forall'ed type + -- variables refer to the ones bound in the user_ty + (_, _, tau_ty') = tcSplitSigmaTy tau_ty + + nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName + nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder) + +{- +************************************************************************ +* * +\subsection{Generating extra binds (@con2tag@ and @tag2con@)} +* * +************************************************************************ + +\begin{verbatim} +data Foo ... = ... + +con2tag_Foo :: Foo ... -> Int# +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unlifted) +\end{verbatim} + +The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) +fiddling around. +-} + +genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) +genAuxBindSpec loc (DerivCon2Tag tycon) + = (mk_FunBind loc rdr_name eqns, + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + where + rdr_name = con2tag_RDR tycon + + sig_ty = HsCoreTy $ + mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ + mkParentType tycon `mkFunTy` intPrimTy + + lots_of_constructors = tyConFamilySize tycon > 8 + -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS + -- but we don't do vectored returns any more. + + eqns | lots_of_constructors = [get_tag_eqn] + | otherwise = map mk_eqn (tyConDataCons tycon) + + get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) + + mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName) + mk_eqn con = ([nlWildConPat con], + nlHsLit (HsIntPrim "" + (toInteger ((dataConTag con) - fIRST_TAG)))) + +genAuxBindSpec loc (DerivTag2Con tycon) + = (mk_FunBind loc rdr_name + [([nlConVarPat intDataCon_RDR [a_RDR]], + nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + where + sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ + intTy `mkFunTy` mkParentType tycon + + rdr_name = tag2con_RDR tycon + +genAuxBindSpec loc (DerivMaxTag tycon) + = (mkHsVarBind loc rdr_name rhs, + L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + where + rdr_name = maxtag_RDR tycon + sig_ty = HsCoreTy intTy + rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag)) + max_tag = case (tyConDataCons tycon) of + data_cons -> toInteger ((length data_cons) - fIRST_TAG) + +type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings + ( Bag (LHsBind RdrName, LSig RdrName) + -- Extra bindings (used by Generic only) + , Bag TyCon -- Extra top-level datatypes + , Bag (FamInst) -- Extra family instances + , Bag (InstInfo RdrName)) -- Extra instances + +genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff +genAuxBinds loc b = genAuxBinds' b2 where + (b1,b2) = partitionBagWith splitDerivAuxBind b + splitDerivAuxBind (DerivAuxBind x) = Left x + splitDerivAuxBind x = Right x + + rm_dups = foldrBag dup_check emptyBag + dup_check a b = if anyBag (== a) b then b else consBag a b + + genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff + genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) + , emptyBag, emptyBag, emptyBag) + f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff + f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before + f (DerivHsBind b) = add1 b + f (DerivTyCon t) = add2 t + f (DerivFamInst t) = add3 t + f (DerivInst i) = add4 i + + add1 x (a,b,c,d) = (x `consBag` a,b,c,d) + add2 x (a,b,c,d) = (a,x `consBag` b,c,d) + add3 x (a,b,c,d) = (a,b,x `consBag` c,d) + add4 x (a,b,c,d) = (a,b,c,x `consBag` d) + +mk_data_type_name :: TyCon -> RdrName -- "$tT" +mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc + +mk_constr_name :: DataCon -> RdrName -- "$cC" +mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc + +mkParentType :: TyCon -> Type +-- Turn the representation tycon of a family into +-- a use of its family constructor +mkParentType tc + = case tyConFamInst_maybe tc of + Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) + Just (fam_tc,tys) -> mkTyConApp fam_tc tys + +{- +************************************************************************ +* * +\subsection{Utility bits for generating bindings} +* * +************************************************************************ +-} + +mk_FunBind :: SrcSpan -> RdrName + -> [([LPat RdrName], LHsExpr RdrName)] + -> LHsBind RdrName +mk_FunBind loc fun pats_and_exprs + = mkRdrFunBind (L loc fun) matches + where + matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + +mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName +mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') + where + -- Catch-all eqn looks like + -- fmap = error "Void fmap" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See Trac #4302 + matches' = if null matches + then [mkMatch [] (error_Expr str) emptyLocalBinds] + else matches + str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + +box_if_necy :: String -- The class involved + -> TyCon -- The tycon involved + -> LHsExpr RdrName -- The argument + -> Type -- The argument type + -> LHsExpr RdrName -- Boxed version of the arg +-- See Note [Deriving and unboxed types] +box_if_necy cls_str tycon arg arg_ty + | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg + | otherwise = arg + where + box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty + +--------------------- +primOrdOps :: String -- The class involved + -> TyCon -- The tycon involved + -> Type -- The type + -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) +-- See Note [Deriving and unboxed types] +primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty + +ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] +ordOpTbl + = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] + +boxConTbl :: [(Type, RdrName)] +boxConTbl + = [(charPrimTy , getRdrName charDataCon ) + ,(intPrimTy , getRdrName intDataCon ) + ,(wordPrimTy , getRdrName wordDataCon ) + ,(floatPrimTy , getRdrName floatDataCon ) + ,(doublePrimTy, getRdrName doubleDataCon) + ] + +assoc_ty_id :: String -- The class involved + -> TyCon -- The tycon involved + -> [(Type,a)] -- The table + -> Type -- The type + -> a -- The result of the lookup +assoc_ty_id cls_str _ tbl ty + | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> + text "for primitive type" <+> ppr ty) + | otherwise = head res + where + res = [id | (ty',id) <- tbl, ty `eqType` ty'] + +----------------------------------------------------------------------- + +and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +and_Expr a b = genOpApp a and_RDR b + +----------------------------------------------------------------------- + +eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +eq_Expr tycon ty a b + | not (isUnLiftedType ty) = genOpApp a eq_RDR b + | otherwise = genPrimOpApp a prim_eq b + where + (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty + +untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName +untag_Expr _ [] expr = expr +untag_Expr tycon ((untag_this, put_tag_here) : more) expr + = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} + [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] + +enum_from_to_Expr + :: LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName +enum_from_then_to_Expr + :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName + +enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 + +showParen_Expr + :: LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName + +showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 + +nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName + +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty +nested_compose_Expr [e] = parenify e +nested_compose_Expr (e:es) + = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) + +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +error_Expr :: String -> LHsExpr RdrName +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) + +-- illegal_Expr is used when signalling error conditions in the RHS of a derived +-- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr RdrName +illegal_Expr meth tp msg = + nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) + +-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you +-- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName +illegal_toEnum_tag tp maxtag = + nlHsApp (nlHsVar error_RDR) + (nlHsApp (nlHsApp (nlHsVar append_RDR) + (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar a_RDR)) + (nlHsApp (nlHsApp + (nlHsVar append_RDR) + (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar maxtag)) + (nlHsLit (mkHsString ")")))))) + +parenify :: LHsExpr RdrName -> LHsExpr RdrName +parenify e@(L _ (HsVar _)) = e +parenify e = mkHsPar e + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName +genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) + +genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName +genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) + +a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR + :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +f_RDR = mkVarUnqual (fsLit "f") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + +a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, + false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName +a_Expr = nlHsVar a_RDR +-- b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +f_Expr = nlHsVar f_RDR +z_Expr = nlHsVar z_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR +fmap_Expr = nlHsVar fmap_RDR +pure_Expr = nlHsVar pure_RDR +mempty_Expr = nlHsVar mempty_RDR +foldMap_Expr = nlHsVar foldMap_RDR +traverse_Expr = nlHsVar traverse_RDR + +a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName +a_Pat = nlVarPat a_RDR +b_Pat = nlVarPat b_RDR +c_Pat = nlVarPat c_RDR +d_Pat = nlVarPat d_RDR +f_Pat = nlVarPat f_RDR +k_Pat = nlVarPat k_RDR +z_Pat = nlVarPat z_RDR + +minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName +minusInt_RDR = getRdrName (primOpId IntSubOp ) +tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) +error_RDR = getRdrName eRROR_ID + +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +-- Generates Orig s RdrName, for the binding positions +con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc +tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc +maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc + +mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun + +mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName +-- ^ Make a top-level binder name for an auxiliary binding for a parent name +-- See Note [Auxiliary binders] +mkAuxBinderName parent occ_fun + = mkRdrUnqual (occ_fun uniq_parent_occ) + where + uniq_parent_occ = mkOccName (occNameSpace parent_occ) uniq_string + + uniq_string + | opt_PprStyle_Debug + = showSDocUnsafe (ppr parent_occ <> underscore <> ppr parent_uniq) + | otherwise + = show parent_uniq + -- The debug thing is just to generate longer, but perhaps more perspicuous, names + + parent_uniq = nameUnique parent + parent_occ = nameOccName parent + +{- +Note [Auxiliary binders] +~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to make a top-level auxiliary binding. E.g. for comparison we haev + + instance Ord T where + compare a b = $con2tag a `compare` $con2tag b + + $con2tag :: T -> Int + $con2tag = ...code.... + +Of course these top-level bindings should all have distinct name, and we are +generating RdrNames here. We can't just use the TyCon or DataCon to distinguish +because with standalone deriving two imported TyCons might both be called T! +(See Trac #7947.) + +So we use the *unique* from the parent name (T in this example) as part of the +OccName we generate for the new binding. + +In the past we used mkDerivedRdrName name occ_fun, which made an original name +But: (a) that does not work well for standalone-deriving either + (b) an unqualified name is just fine, provided it can't clash with user code +-} diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs new file mode 100644 index 00000000..2c90c17b --- /dev/null +++ b/compiler/typecheck/TcGenGenerics.hs @@ -0,0 +1,883 @@ +{- +(c) The University of Glasgow 2011 + + +The deriving code for the Generic class +(equivalent to the code in TcGenDeriv, for other classes) +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +module TcGenGenerics (canDoGenerics, canDoGenerics1, + GenericKind(..), + MetaTyCons, genGenericMetaTyCons, + gen_Generic_binds, get_gen1_constrained_tys) where + +import DynFlags +import HsSyn +import Type +import Kind ( isKind ) +import TcType +import TcGenDeriv +import DataCon +import TyCon +import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) +import FamInst +import Module ( Module, moduleName, moduleNameString ) +import IfaceEnv ( newGlobalBinder ) +import Name hiding ( varName ) +import RdrName +import BasicTypes +import TysWiredIn +import PrelNames +import InstEnv +import TcEnv +import MkId +import TcRnMonad +import HscTypes +import ErrUtils( Validity(..), andValid ) +import BuildTyCl +import SrcLoc +import Bag +import VarSet (elemVarSet) +import Outputable +import FastString +import Util + +import Control.Monad (mplus,forM) + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{Bindings for the new generic deriving mechanism} +* * +************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} +-} + +gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module + -> TcM (LHsBinds RdrName, FamInst) +gen_Generic_binds gk tc metaTyCons mod = do + repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod + return (mkBindsRep gk tc, repTyInsts) + +genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) +genGenericMetaTyCons tc mod = + do loc <- getSrcSpanM + let + tc_name = tyConName tc + tc_cons = tyConDataCons tc + tc_arits = map dataConSourceArity tc_cons + + tc_occ = nameOccName tc_name + d_occ = mkGenD tc_occ + c_occ m = mkGenC tc_occ m + s_occ m n = mkGenS tc_occ m n + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs + NonRecursive + False -- Not promotable + False -- Not GADT syntax + NoParentTyCon + + d_name <- newGlobalBinder mod d_occ loc + c_names <- forM (zip [0..] tc_cons) $ \(m,_) -> + newGlobalBinder mod (c_occ m) loc + s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n -> + newGlobalBinder mod (s_occ m n) loc + + let metaDTyCon = mkTyCon d_name + metaCTyCons = map mkTyCon c_names + metaSTyCons = map (map mkTyCon) s_names + + metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + + -- pprTrace "rep0" (ppr rep0_tycon) $ + (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts + +-- both the tycon declarations and related instances +metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff +metaTyConsToDerivStuff tc metaDts = + do loc <- getSrcSpanM + dflags <- getDynFlags + dClas <- tcLookupClass datatypeClassName + let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc + d_dfun_name <- new_dfun_name dClas tc + cClas <- tcLookupClass constructorClassName + c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] + sClas <- tcLookupClass selectorClassName + s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc + | _ <- x ] + | x <- metaS metaDts ]) + fix_env <- getFixityEnv + + let + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc + mk_inst clas tc dfun_name + = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) + OverlapFlag { overlapMode = (NoOverlap "") + , isSafeOverlap = safeLanguageOn dflags } + [] clas tys + where + tys = [mkTyConTy tc] + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mk_inst dClas d_metaTycon d_dfun_name + d_binds = InstBindings { ib_binds = dBinds + , ib_tyvars = [] + , ib_pragmas = [] + , ib_extensions = [] + , ib_derived = True } + d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) + + -- Constructor + c_metaTycons = metaC metaDts + c_insts = [ mk_inst cClas c ds + | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] + c_binds = [ InstBindings { ib_binds = c + , ib_tyvars = [] + , ib_pragmas = [] + , ib_extensions = [] + , ib_derived = True } + | c <- cBinds ] + c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) + | (is,bs) <- myZip1 c_insts c_binds ] + + -- Selector + s_metaTycons = metaS metaDts + s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) + (myZip2 s_metaTycons s_dfun_names) + s_binds = [ [ InstBindings { ib_binds = s + , ib_tyvars = [] + , ib_pragmas = [] + , ib_extensions = [] + , ib_derived = True } + | s <- ss ] | ss <- sBinds ] + s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is + , iBinds = bs}))) + (myZip2 s_insts s_binds) + + myZip1 :: [a] -> [b] -> [(a,b)] + myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 + + myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] + myZip2 l1 l2 = + ASSERT(and (zipWith (>=) (map length l1) (map length l2))) + [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] + + return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) + `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) + +{- +************************************************************************ +* * +\subsection{Generating representation types} +* * +************************************************************************ +-} + +get_gen1_constrained_tys :: TyVar -> Type -> [Type] +-- called by TcDeriv.inferConstraints; generates a list of types, each of which +-- must be a Functor in order for the Generic1 instance to work. +get_gen1_constrained_tys argVar + = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] + , ata_par1 = [], ata_rec1 = const [] + , ata_comp = (:) } + +{- + +Note [Requirements for deriving Generic and Rep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the following, T, Tfun, and Targ are "meta-variables" ranging over type +expressions. + +(Generic T) and (Rep T) are derivable for some type expression T if the +following constraints are satisfied. + + (a) T = (D v1 ... vn) with free variables v1, v2, ..., vn where n >= 0 v1 + ... vn are distinct type variables. Cf #5939. + + (b) D is a type constructor *value*. In other words, D is either a type + constructor or it is equivalent to the head of a data family instance (up to + alpha-renaming). + + (c) D cannot have a "stupid context". + + (d) The right-hand side of D cannot include unboxed types, existential types, + or universally quantified types. + + (e) T :: *. + +(Generic1 T) and (Rep1 T) are derivable for some type expression T if the +following constraints are satisfied. + + (a),(b),(c),(d) As above. + + (f) T must expect arguments, and its last parameter must have kind *. + + We use `a' to denote the parameter of D that corresponds to the last + parameter of T. + + (g) For any type-level application (Tfun Targ) in the right-hand side of D + where the head of Tfun is not a tuple constructor: + + (b1) `a' must not occur in Tfun. + + (b2) If `a' occurs in Targ, then Tfun :: * -> *. + +-} + +canDoGenerics :: TyCon -> [Type] -> Validity +-- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a +-- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn). +-- +-- Check (b) from Note [Requirements for deriving Generic and Rep] is taken +-- care of because canDoGenerics is applied to rep tycons. +-- +-- It returns Nothing if deriving is possible. It returns (Just reason) if not. +canDoGenerics tc tc_args + = mergeErrors ( + -- Check (c) from Note [Requirements for deriving Generic and Rep]. + (if (not (null (tyConStupidTheta tc))) + then (NotValid (tc_name <+> text "must not have a datatype context")) + else IsValid) : + -- Check (a) from Note [Requirements for deriving Generic and Rep]. + -- + -- Data family indices can be instantiated; the `tc_args` here are + -- the representation tycon args + (if (all isTyVarTy (filterOut isKind tc_args)) + then IsValid + else NotValid (tc_name <+> text "must not be instantiated;" <+> + text "try deriving `" <> tc_name <+> tc_tys <> + text "' instead")) + -- See comment below + : (map bad_con (tyConDataCons tc))) + where + -- The tc can be a representation tycon. When we want to display it to the + -- user (in an error message) we should print its parent + (tc_name, tc_tys) = case tyConParent tc of + FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr + (tys ++ drop (length tys) tc_args))) + _ -> (ppr tc, hsep (map ppr (tyConTyVars tc))) + + -- Check (d) from Note [Requirements for deriving Generic and Rep]. + -- + -- If any of the constructors has an unboxed type as argument, + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) + then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments")) + else (if (not (isVanillaDataCon dc)) + then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) + else IsValid) + + -- Nor can we do the job if it's an existential data constructor, + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) + +mergeErrors :: [Validity] -> Validity +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid s + NotValid s' -> NotValid (s <> text ", and" $$ s') +mergeErrors (IsValid : t) = mergeErrors t + +-- A datatype used only inside of canDoGenerics1. It's the result of analysing +-- a type term. +data Check_for_CanDoGenerics1 = CCDG1 + { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in + -- this type? + , _ccdg1_errors :: Validity -- errors generated by this type + } + +{- + +Note [degenerate use of FFoldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use foldDataConArgs here only for its ability to treat tuples +specially. foldDataConArgs also tracks covariance (though it assumes all +higher-order type parameters are covariant) and has hooks for special handling +of functions and polytypes, but we do *not* use those. + +The key issue is that Generic1 deriving currently offers no sophisticated +support for functions. For example, we cannot handle + + data F a = F ((a -> Int) -> Int) + +even though a is occurring covariantly. + +In fact, our rule is harsh: a is simply not allowed to occur within the first +argument of (->). We treat (->) the same as any other non-tuple tycon. + +Unfortunately, this means we have to track "the parameter occurs in this type" +explicitly, even though foldDataConArgs is also doing this internally. + +-} + +-- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived +-- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn). +-- +-- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep] +-- are taken care of by the call to canDoGenerics. +-- +-- It returns Nothing if deriving is possible. It returns (Just reason) if not. +canDoGenerics1 :: TyCon -> [Type] -> Validity +canDoGenerics1 rep_tc tc_args = + canDoGenerics rep_tc tc_args `andValid` additionalChecks + where + additionalChecks + -- check (f) from Note [Requirements for deriving Generic and Rep] + | null (tyConTyVars rep_tc) = NotValid $ + ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters") + + | otherwise = mergeErrors $ concatMap check_con data_cons + + data_cons = tyConDataCons rep_tc + check_con con = case check_vanilla con of + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con + + bad :: DataCon -> SDoc -> SDoc + bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + + check_vanilla :: DataCon -> Validity + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid (bad con existential) + + bmzero = CCDG1 False IsValid + bmbad con s = CCDG1 True $ NotValid $ bad con s + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) + + -- check (g) from Note [degenerate use of FFoldType] + ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 + ft_check con = FT + { ft_triv = bmzero + + , ft_var = caseVar, ft_co_var = caseVar + + -- (component_0,component_1,...,component_n) + , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) + then bmbad con wrong_arg + else foldr bmplus bmzero components + + -- (dom -> rng), where the head of ty is not a tuple tycon + , ft_fun = \dom rng -> -- cf #8516 + if _ccdg1_hasParam dom + then bmbad con wrong_arg + else bmplus dom rng + + -- (ty arg), where head of ty is neither (->) nor a tuple constructor and + -- the parameter of interest does not occur in ty + , ft_ty_app = \_ arg -> arg + + , ft_bad_app = bmbad con wrong_arg + , ft_forall = \_ body -> body -- polytypes are handled elsewhere + } + where + caseVar = CCDG1 True IsValid + + + existential = text "must not have existential arguments" + wrong_arg = text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + +{- +************************************************************************ +* * +\subsection{Generating the RHS of a generic default method} +* * +************************************************************************ +-} + +type US = Int -- Local unique supply, just a plain Int +type Alt = (LPat RdrName, LHsExpr RdrName) + +-- GenericKind serves to mark if a datatype derives Generic (Gen0) or +-- Generic1 (Gen1). +data GenericKind = Gen0 | Gen1 + +-- as above, but with a payload of the TyCon's name for "the" parameter +data GenericKind_ = Gen0_ | Gen1_ TyVar + +-- as above, but using a single datacon's name for "the" parameter +data GenericKind_DC = Gen0_DC | Gen1_DC TyVar + +forgetArgVar :: GenericKind_DC -> GenericKind +forgetArgVar Gen0_DC = Gen0 +forgetArgVar Gen1_DC{} = Gen1 + +-- When working only within a single datacon, "the" parameter's name should +-- match that datacon's name for it. +gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC +gk2gkDC Gen0_ _ = Gen0_DC +gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d + + + +-- Bindings for the Generic instance +mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName +mkBindsRep gk tycon = + unitBag (mkRdrFunBind (L loc from01_RDR) from_matches) + `unionBags` + unitBag (mkRdrFunBind (L loc to01_RDR) to_matches) + where + from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + (from01_RDR, to01_RDR) = case gk of + Gen0 -> (from_RDR, to_RDR) + Gen1 -> (from1_RDR, to1_RDR) + + -- Recurse over the sum first + from_alts, to_alts :: [Alt] + (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons + where gk_ = case gk of + Gen0 -> Gen0_ + Gen1 -> ASSERT(length tyvars >= 1) + Gen1_ (last tyvars) + where tyvars = tyConTyVars tycon + +-------------------------------------------------------------------------------- +-- The type synonym instance and synonym +-- type instance Rep (D a b) = Rep_D a b +-- type Rep_D a b = ...representation type for D ... +-------------------------------------------------------------------------------- + +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> TyCon -- The type to generate representation for + -> MetaTyCons -- Metadata datatypes to refer to + -> Module -- Used as the location of the new RepTy + -> TcM (FamInst) -- Generated representation0 coercion +tc_mkRepFamInsts gk tycon metaDts mod = + -- Consider the example input tycon `D`, where data D a b = D_ a + -- Also consider `R:DInt`, where { data family D x y :: * -> * + -- ; data instance D Int a b = D_ a } + do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) + fam_tc <- case gk of + Gen0 -> tcLookupTyCon repTyConName + Gen1 -> tcLookupTyCon rep1TyConName + + ; let -- `tyvars` = [a,b] + (tyvars, gk_) = case gk of + Gen0 -> (all_tyvars, Gen0_) + Gen1 -> ASSERT(not $ null all_tyvars) + (init all_tyvars, Gen1_ $ last all_tyvars) + where all_tyvars = tyConTyVars tycon + + tyvar_args = mkTyVarTys tyvars + + appT :: [Type] + appT = case tyConFamInst_maybe tycon of + -- `appT` = D Int a b (data families case) + Just (famtycon, apps) -> + -- `fam` = D + -- `apps` = [Int, a, b] + let allApps = case gk of + Gen0 -> apps + Gen1 -> ASSERT(not $ null apps) + init apps + in [mkTyConApp famtycon allApps] + -- `appT` = D a b (normal case) + Nothing -> [mkTyConApp tycon tyvar_args] + + -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; repTy <- tc_mkRepTy gk_ tycon metaDts + + -- `rep_name` is a name we generate for the synonym + ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R + in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon))) + (nameSrcSpan (tyConName tycon)) + + ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy + ; newFamInst SynFamilyInst axiom } + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- + +-- | See documentation of 'argTyFold'; that function uses the fields of this +-- type to interpret the structure of a type when that type is considered as an +-- argument to a constructor that is being represented with 'Rep1'. +data ArgTyAlg a = ArgTyAlg + { ata_rec0 :: (Type -> a) + , ata_par1 :: a, ata_rec1 :: (Type -> a) + , ata_comp :: (Type -> a -> a) + } + +-- | @argTyFold@ implements a generalised and safer variant of the @arg@ +-- function from Figure 3 in . @arg@ +-- is conceptually equivalent to: +-- +-- > arg t = case t of +-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t +-- > App f [t'] | +-- > representable1 f && +-- > t' == argVar -> Rec1 f +-- > App f [t'] | +-- > representable1 f && +-- > t' has tyvars -> f :.: (arg t') +-- > _ -> Rec0 t +-- +-- where @argVar@ is the last type variable in the data type declaration we are +-- finding the representation for. +-- +-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to +-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and +-- @:.:@. +-- +-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for +-- some data types. The problematic case is when @t@ is an application of a +-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the +-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in +-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some +-- representable1 checks have been relaxed, and others were moved to +-- @canDoGenerics1@. +argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a +argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, + ata_par1 = mkPar1, ata_rec1 = mkRec1, + ata_comp = mkComp}) = + -- mkRec0 is the default; use it if there is no interesting structure + -- (e.g. occurrences of parameters or recursive occurrences) + \t -> maybe (mkRec0 t) id $ go t where + go :: Type -> -- type to fold through + Maybe a -- the result (e.g. representation type), unless it's trivial + go t = isParam `mplus` isApp where + + isParam = do -- handles parameters + t' <- getTyVar_maybe t + Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter + else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 + + isApp = do -- handles applications + (phi, beta) <- tcSplitAppTy_maybe t + + let interesting = argVar `elemVarSet` exactTyVarsOfType beta + + -- Does it have no interesting structure to represent? + if not interesting then Nothing + else -- Is the argument the parameter? Special case for mkRec1. + if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi + else mkComp phi `fmap` go beta -- It must be a composition. + + +tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 + GenericKind_ + -- The type to generate representation for + -> TyCon + -- Metadata datatypes to refer to + -> MetaTyCons + -- Generated representation0 type + -> TcM Type +tc_mkRepTy gk_ tycon metaDts = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + nS1 <- tcLookupTyCon noSelTyConName + rec0 <- tcLookupTyCon rec0TyConName + rec1 <- tcLookupTyCon rec1TyConName + par1 <- tcLookupTyCon par1TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + comp <- tcLookupTyCon compTyConName + + let mkSum' a b = mkTyConApp plus [a,b] + mkProd a b = mkTyConApp times [a,b] + mkComp a b = mkTyConApp comp [a,b] + mkRec0 a = mkTyConApp rec0 [a] + mkRec1 a = mkTyConApp rec1 [a] + mkPar1 = mkTyConTy par1 + mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] + mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) + (null (dataConFieldLabels a))] + -- This field has no label + mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] + -- This field has a label + mkS False d a = mkTyConApp s1 [d, a] + + -- Sums and products are done in the same way for both Rep and Rep1 + sumP [] = mkTyConTy v1 + sumP l = ASSERT(length metaCTyCons == length l) + foldBal mkSum' [ mkC i d a + | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] + -- The Bool is True if this constructor has labelled fields + prod :: Int -> [Type] -> Bool -> Type + prod i [] _ = ASSERT(length metaSTyCons > i) + ASSERT(length (metaSTyCons !! i) == 0) + mkTyConTy u1 + prod i l b = ASSERT(length metaSTyCons > i) + ASSERT(length l == length (metaSTyCons !! i)) + foldBal mkProd [ arg d t b + | (d,t) <- zip (metaSTyCons !! i) l ] + + arg :: Type -> Type -> Bool -> Type + arg d t b = mkS b d $ case gk_ of + -- Here we previously used Par0 if t was a type variable, but we + -- realized that we can't always guarantee that we are wrapping-up + -- all type variables in Par0. So we decided to stop using Par0 + -- altogether, and use Rec0 all the time. + Gen0_ -> mkRec0 t + Gen1_ argVar -> argPar argVar t + where + -- Builds argument represention for Rep1 (more complicated due to + -- the presence of composition). + argPar argVar = argTyFold argVar $ ArgTyAlg + {ata_rec0 = mkRec0, ata_par1 = mkPar1, + ata_rec1 = mkRec1, ata_comp = mkComp} + + + metaDTyCon = mkTyConTy (metaD metaDts) + metaCTyCons = map mkTyConTy (metaC metaDts) + metaSTyCons = map (map mkTyConTy) (metaS metaDts) + + return (mkD tycon) + +-------------------------------------------------------------------------------- +-- Meta-information +-------------------------------------------------------------------------------- + +data MetaTyCons = MetaTyCons { -- One meta datatype per datatype + metaD :: TyCon + -- One meta datatype per constructor + , metaC :: [TyCon] + -- One meta datatype per selector per constructor + , metaS :: [[TyCon]] } + +instance Outputable MetaTyCons where + ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) + +metaTyCons2TyCons :: MetaTyCons -> Bag TyCon +metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) + + +-- Bindings for Datatype, Constructor, and Selector instances +mkBindsMetaD :: FixityEnv -> TyCon + -> ( LHsBinds RdrName -- Datatype instance + , [LHsBinds RdrName] -- Constructor instances + , [[LHsBinds RdrName]]) -- Selector instances +mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) + where + mkBag l = foldr1 unionBags + [ unitBag (mkRdrFunBind (L loc name) matches) + | (name, matches) <- l ] + dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) + , (moduleName_RDR, moduleName_matches)] + ++ ifElseEmpty (isNewTyCon tycon) + [ (isNewtypeName_RDR, isNewtype_matches) ] ) + + allConBinds = map conBinds datacons + conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] + ++ ifElseEmpty (dataConIsInfix c) + [ (conFixity_RDR, conFixity_matches c) ] + ++ ifElseEmpty (length (dataConFieldLabels c) > 0) + [ (conIsRecord_RDR, conIsRecord_matches c) ] + ) + + ifElseEmpty p x = if p then x else [] + fixity c = case lookupFixity fix_env (dataConName c) of + Fixity n InfixL -> buildFix n leftAssocDataCon_RDR + Fixity n InfixR -> buildFix n rightAssocDataCon_RDR + Fixity n InfixN -> buildFix n notAssocDataCon_RDR + buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc + , nlHsIntLit (toInteger n)] + + allSelBinds = map (map selBinds) datasels + selBinds s = mkBag [(selName_RDR, selName_matches s)] + + loc = srcLocSpan (getSrcLoc tycon) + mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] + datacons = tyConDataCons tycon + datasels = map dataConFieldLabels datacons + + tyConName_user = case tyConFamInst_maybe tycon of + Just (ptycon, _) -> tyConName ptycon + Nothing -> tyConName tycon + + dtName_matches = mkStringLHS . occNameString . nameOccName + $ tyConName_user + moduleName_matches = mkStringLHS . moduleNameString . moduleName + . nameModule . tyConName $ tycon + isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + + conName_matches c = mkStringLHS . occNameString . nameOccName + . dataConName $ c + conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] + conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + + selName_matches s = mkStringLHS (occNameString (nameOccName s)) + + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: GenericKind_ -- Generic or Generic1? + -> US -- Base for generating unique names + -> TyCon -- The type constructor + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _ _ tycon [] = ([from_alt], [to_alt]) + where + from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) + to_alt = (mkM1_P nlWildPat, makeError errMsgTo) + -- These M1s are meta-information for the datatype + makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) + tyConStr = occNameString (nameOccName (tyConName tycon)) + errMsgFrom = "No generic representation for empty datatype " ++ tyConStr + errMsgTo = "No values for empty datatype " ++ tyConStr + +-- Datatype with at least one constructor +mkSum gk_ us _ datacons = + -- switch the payload of gk_ to be datacon-centric instead of tycon-centric + unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d + | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum gk_ us i n datacon = (from_alt, to_alt) + where + gk = forgetArgVar gk_ + + -- Existentials already excluded + argTys = dataConOrigArgTys datacon + n_args = dataConSourceArity datacon + + datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys + datacon_vars = map fst datacon_varTys + us' = us + n_args + + datacon_rdr = getRdrName datacon + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys)) + + to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs) + -- These M1s are meta-information for the datatype + to_alt_rhs = case gk_ of + Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars + Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys + where + argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where + converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar unK1_RDR, + ata_par1 = nlHsVar unPar1_RDR, + ata_rec1 = const $ nlHsVar unRec1_RDR, + ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) + `nlHsCompose` nlHsVar unComp1_RDR} + + + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names + -> [(RdrName, Type)] -- List of variables matched on the lhs and their types + -> LHsExpr RdrName -- Resulting product expression +mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map (wrapArg_E gk_) varTys + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName +wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var]) + -- This M1 is meta-information for the selector +wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var + -- This M1 is meta-information for the selector + where converter = argTyFold argVar $ ArgTyAlg + {ata_rec0 = const $ nlHsVar k1DataCon_RDR, + ata_par1 = nlHsVar par1DataCon_RDR, + ata_rec1 = const $ nlHsVar rec1DataCon_RDR, + ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` + (nlHsVar fmap_RDR `nlHsApp` cnv)} + + + +-- Build a product pattern +mkProd_P :: GenericKind -- Gen0 or Gen1 + -> US -- Base for unique names + -> [RdrName] -- List of variables to match + -> LPat RdrName -- Resulting product pattern +mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P gk _ vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map (wrapArg_P gk) vars + prod a b = prodDataCon_RDR `nlConPat` [a,b] + +wrapArg_P :: GenericKind -> RdrName -> LPat RdrName +wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector +wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v] + +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat RdrName -> LPat RdrName +mkM1_P p = m1DataCon_RDR `nlConPat` [p] + +nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +nlHsCompose x y = compose_RDR `nlHsApps` [x, y] + +-- | Variant of foldr1 for producing balanced lists +foldBal :: (a -> a -> a) -> [a] -> a +foldBal op = foldBal' op (error "foldBal: empty list") + +foldBal' :: (a -> a -> a) -> a -> [a] -> a +foldBal' _ x [] = x +foldBal' _ _ [y] = y +foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal' op x a `op` foldBal' op x b diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs new file mode 100644 index 00000000..6e742f24 --- /dev/null +++ b/compiler/typecheck/TcHsSyn.hs @@ -0,0 +1,1535 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker + +This module is an extension of @HsSyn@ syntax, for use in the type +checker. +-} + +{-# LANGUAGE CPP #-} + +module TcHsSyn ( + mkHsConApp, mkHsDictLet, mkHsApp, + hsLitType, hsLPatType, hsPatType, + mkHsAppTy, mkSimpleHsAlt, + nlHsIntLit, + shortCutLit, hsOverLitName, + conLikeResTy, + + -- re-exported from TcMonad + TcId, TcIdSet, + + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, zonkTyBndrsX, + emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, + zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, + ) where + +#include "HsVersions.h" + +import HsSyn +import Id +import TcRnMonad +import PrelNames +import TypeRep -- We can see the representation of types +import TcType +import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar ) +import TcEvidence +import Coercion +import TysPrim +import TysWiredIn +import Type +import ConLike +import DataCon +import PatSyn( patSynInstResTy ) +import Name +import NameSet +import Var +import VarSet +import VarEnv +import DynFlags +import Literal +import BasicTypes +import Maybes +import SrcLoc +import Bag +import FastString +import Outputable +import Util +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( traverse ) +#endif + +{- +************************************************************************ +* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +* * +************************************************************************ + +Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@, +then something is wrong. +-} + +hsLPatType :: OutPat Id -> Type +hsLPatType (L _ pat) = hsPatType pat + +hsPatType :: Pat Id -> Type +hsPatType (ParPat pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat var) = idType var +hsPatType (BangPat pat) = hsLPatType pat +hsPatType (LazyPat pat) = hsLPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var _) = idType (unLoc var) +hsPatType (ViewPat _ _ ty) = ty +hsPatType (ListPat _ ty Nothing) = mkListTy ty +hsPatType (ListPat _ _ (Just (ty,_))) = ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys +hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) + = conLikeResTy con tys +hsPatType (SigPatOut _ ty) = ty +hsPatType (NPat (L _ lit) _ _) = overLitType lit +hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) +hsPatType (CoPat _ _ ty) = ty +hsPatType p = pprPanic "hsPatType" (ppr p) + +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +hsLitType :: HsLit -> TcType +hsLitType (HsChar _ _) = charTy +hsLitType (HsCharPrim _ _) = charPrimTy +hsLitType (HsString _ _) = stringTy +hsLitType (HsStringPrim _ _) = addrPrimTy +hsLitType (HsInt _ _) = intTy +hsLitType (HsIntPrim _ _) = intPrimTy +hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord64Prim _ _) = word64PrimTy +hsLitType (HsInteger _ _ ty) = ty +hsLitType (HsRat _ ty) = ty +hsLitType (HsFloatPrim _) = floatPrimTy +hsLitType (HsDoublePrim _) = doublePrimTy + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit dflags (HsIntegral src i) ty + | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt src i)) + | isWordTy ty && inWordRange dflags i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) + | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + +shortCutLit _ (HsFractional f) ty + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) + | otherwise = Nothing + +shortCutLit _ (HsIsString src s) ty + | isStringTy ty = Just (HsLit (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit -> HsExpr Id +mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName + +{- +************************************************************************ +* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +* * +************************************************************************ + +The rest of the zonking is done *after* typechecking. +The main zonking pass runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type + +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. + +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy + +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. +-} + +type UnboundTyVarZonker = TcTyVar-> TcM Type + -- How to zonk an unbound type variable + -- Note [Zonking the LHS of a RULE] + +data ZonkEnv + = ZonkEnv + UnboundTyVarZonker + (TyVarEnv TyVar) -- + (IdEnv Var) -- What variables are in scope + -- Maps an Id or EvVar to its zonked version; both have the same Name + -- Note that all evidence (coercion variables as well as dictionaries) + -- are kept in the ZonkEnv + -- Only *type* abstraction is done by side effect + -- Is only consulted lazily; hence knot-tying + +instance Outputable ZonkEnv where + ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env)) + + +emptyZonkEnv :: ZonkEnv +emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping + +mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv +mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv + +extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv +extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids + = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids]) + +extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv +extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id + = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id) + +extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv +extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty + = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env + +mkTyVarZonkEnv :: [TyVar] -> ZonkEnv +mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv + +setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv +setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env + +zonkEnvIds :: ZonkEnv -> [Id] +zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env + +zonkIdOcc :: ZonkEnv -> TcId -> Id +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separate chunk. +zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id + | isLocalVar id = lookupVarEnv env id `orElse` id + | otherwise = id + +zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] +zonkIdOccs env ids = map (zonkIdOcc env) ids + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndr :: ZonkEnv -> TcId -> TcM Id +zonkIdBndr env id + = do ty' <- zonkTcTypeToType env (idType id) + return (Id.setIdType id ty') + +zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] +zonkIdBndrs env ids = mapM (zonkIdBndr env) ids + +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids + +zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) +zonkEvBndrsX = mapAccumLM zonkEvBndrX + +zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) +-- Works for dictionaries and coercions +zonkEvBndrX env var + = do { var' <- zonkEvBndr env var + ; return (extendIdZonkEnv1 env var', var') } + +zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr env var + = do { let var_ty = varType var + ; ty <- + {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} + zonkTcTypeToType env var_ty + ; return (setVarType var ty) } + +zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar +zonkEvVarOcc env v = zonkIdOcc env v + +zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) +zonkTyBndrsX = mapAccumLM zonkTyBndrX + +zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced +zonkTyBndrX env tv + = do { ki <- zonkTcTypeToType env (tyVarKind tv) + ; let tv' = mkTyVar (tyVarName tv) ki + ; return (extendTyZonkEnv1 env tv', tv') } + +zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) +zonkTopExpr e = zonkExpr emptyZonkEnv e + +zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) +zonkTopLExpr e = zonkLExpr emptyZonkEnv e + +zonkTopDecls :: Bag EvBind + -> LHsBinds TcId -> Bag OccName -> NameSet + -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> TcM ([Id], + Bag EvBind, + LHsBinds Id, + [LForeignDecl Id], + [LTcSpecPrag], + [LRuleDecl Id], + [LVectDecl Id]) +zonkTopDecls ev_binds binds exports sig_ns rules vects imp_specs fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + + -- Warn about missing signatures + -- Do this only when we we have a type to offer + ; warn_missing_sigs <- woptM Opt_WarnMissingSigs + ; warn_only_exported <- woptM Opt_WarnMissingExportedSigs + ; let sig_warn + | warn_only_exported = topSigWarnIfExported exports sig_ns + | warn_missing_sigs = topSigWarn sig_ns + | otherwise = noSigWarn + + ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; vects' <- zonkVects env2 vects + ; specs' <- zonkLTcSpecPrags env2 imp_specs + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } + +--------------------------------------------- +zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) +zonkLocalBinds env EmptyLocalBinds + = return (env, EmptyLocalBinds) + +zonkLocalBinds _ (HsValBinds (ValBindsIn {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs + ; let sig_warn | not warn_missing_sigs = noSigWarn + | otherwise = localSigWarn sig_ns + sig_ns = getTypeSigNames vb + ; (env1, new_binds) <- go env sig_warn binds + ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } + where + go env _ [] + = return (env, []) + go env sig_warn ((r,b):bs) + = do { (env1, b') <- zonkRecMonoBinds env sig_warn b + ; (env2, bs') <- go env1 sig_warn bs + ; return (env2, (r,b'):bs') } + +zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do + new_binds <- mapM (wrapLocM zonk_ip_bind) binds + let + env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds] + (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds + return (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) + where + zonk_ip_bind (IPBind n e) + = do n' <- mapIPNameTc (zonkIdBndr env) n + e' <- zonkLExpr env e + return (IPBind n' e') + +--------------------------------------------- +zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) +zonkRecMonoBinds env sig_warn binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds) + ; binds' <- zonkMonoBinds env1 sig_warn binds + ; return (env1, binds') }) + +--------------------------------------------- +type SigWarn = Bool -> [Id] -> TcM () + -- Missing-signature warning + -- The Bool is True for an AbsBinds, False otherwise + +noSigWarn :: SigWarn +noSigWarn _ _ = return () + +topSigWarnIfExported :: Bag OccName -> NameSet -> SigWarn +topSigWarnIfExported exported sig_ns _ ids + = mapM_ (topSigWarnIdIfExported exported sig_ns) ids + +topSigWarnIdIfExported :: Bag OccName -> NameSet -> Id -> TcM () +topSigWarnIdIfExported exported sig_ns id + | getOccName id `elemBag` exported + = topSigWarnId sig_ns id + | otherwise + = return () + +topSigWarn :: NameSet -> SigWarn +topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids + +topSigWarnId :: NameSet -> Id -> TcM () +-- The NameSet is the Ids that *lack* a signature +-- We have to do it this way round because there are +-- lots of top-level bindings that are generated by GHC +-- and that don't have signatures +topSigWarnId sig_ns id + | idName id `elemNameSet` sig_ns = warnMissingSig msg id + | otherwise = return () + where + msg = ptext (sLit "Top-level binding with no type signature:") + +localSigWarn :: NameSet -> SigWarn +localSigWarn sig_ns is_abs_bind ids + | not is_abs_bind = return () + | otherwise = mapM_ (localSigWarnId sig_ns) ids + +localSigWarnId :: NameSet -> Id -> TcM () +-- NameSet are the Ids that *have* type signatures +localSigWarnId sig_ns id + | not (isSigmaTy (idType id)) = return () + | idName id `elemNameSet` sig_ns = return () + | otherwise = warnMissingSig msg id + where + msg = ptext (sLit "Polymorphic local binding with no type signature:") + +warnMissingSig :: SDoc -> Id -> TcM () +warnMissingSig msg id + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) + ; addWarnTcM (env1, mk_msg tidy_ty) } + where + mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] + +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) +zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds + +zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id) +zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn) + +zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) +zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; sig_warn False (collectPatBinders new_pat) + ; new_grhss <- zonkGRHSs env zonkLExpr grhss + ; new_ty <- zonkTcTypeToType env ty + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } + +zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) + = do { new_var <- zonkIdBndr env var + ; sig_warn False [new_var] + ; new_expr <- zonkLExpr env expr + ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) } + +zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms + , fun_co_fn = co_fn }) + = do { new_var <- zonkIdBndr env var + ; sig_warn False [new_var] + ; (env1, new_co_fn) <- zonkCoFn env co_fn + ; new_ms <- zonkMatchGroup env1 zonkLExpr ms + ; return (bind { fun_id = L loc new_var, fun_matches = new_ms + , fun_co_fn = new_co_fn }) } + +zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs + , abs_ev_binds = ev_binds + , abs_exports = exports + , abs_binds = val_binds }) + = ASSERT( all isImmutableTyVar tyvars ) + do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds + ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> + do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds) + ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds + ; new_exports <- mapM (zonkExport env3) exports + ; return (new_val_binds, new_exports) } + ; sig_warn True (map abe_poly new_exports) + ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind }) } + where + zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id + , abe_mono = mono_id, abe_prags = prags }) + = do new_poly_id <- zonkIdBndr env poly_id + (_, new_wrap) <- zonkCoFn env wrap + new_prags <- zonkSpecPrags env prags + return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id + , abe_mono = zonkIdOcc env mono_id + , abe_prags = new_prags }) + +zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) + = do { id' <- zonkIdBndr env id + ; details' <- zonkPatSynDetails env details + ;(env1, lpat') <- zonkPat env lpat + ; (_env2, dir') <- zonkPatSynDir env1 dir + ; return $ PatSynBind $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } + +zonkPatSynDetails :: ZonkEnv + -> HsPatSynDetails (Located TcId) + -> TcM (HsPatSynDetails (Located Id)) +zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) + +zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) +zonkPatSynDir env Unidirectional = return (env, Unidirectional) +zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) +zonkPatSynDir env (ExplicitBidirectional mg) = do + mg' <- zonkMatchGroup env zonkLExpr mg + return (env, ExplicitBidirectional mg') + +zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags +zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps + ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] +zonkLTcSpecPrags env ps + = mapM zonk_prag ps + where + zonk_prag (L loc (SpecPrag id co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} +* * +************************************************************************ +-} + +zonkMatchGroup :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) +zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin }) + = do { ms' <- mapM (zonkMatch env zBody) ms + ; arg_tys' <- zonkTcTypeToTypes env arg_tys + ; res_ty' <- zonkTcTypeToType env res_ty + ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) } + +zonkMatch :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) +zonkMatch env zBody (L loc (Match mf pats _ grhss)) + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 zBody grhss + ; return (L loc (Match mf new_pats Nothing new_grhss)) } + +------------------------------------------------------------------------- +zonkGRHSs :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) + +zonkGRHSs env zBody (GRHSs grhss binds) = do + (new_env, new_binds) <- zonkLocalBinds env binds + let + zonk_grhs (GRHS guarded rhs) + = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded + new_rhs <- zBody env2 rhs + return (GRHS new_guarded new_rhs) + new_grhss <- mapM (wrapLocM zonk_grhs) grhss + return (GRHSs new_grhss new_binds) + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] +zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) +zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) + +zonkLExprs env exprs = mapM (zonkLExpr env) exprs +zonkLExpr env expr = wrapLocM (zonkExpr env) expr + +zonkExpr env (HsVar id) + = return (HsVar (zonkIdOcc env id)) + +zonkExpr _ (HsIPVar id) + = return (HsIPVar id) + +zonkExpr env (HsLit (HsRat f ty)) + = do new_ty <- zonkTcTypeToType env ty + return (HsLit (HsRat f new_ty)) + +zonkExpr _ (HsLit lit) + = return (HsLit lit) + +zonkExpr env (HsOverLit lit) + = do { lit' <- zonkOverLit env lit + ; return (HsOverLit lit') } + +zonkExpr env (HsLam matches) + = do new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLam new_matches) + +zonkExpr env (HsLamCase arg matches) + = do new_arg <- zonkTcTypeToType env arg + new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLamCase new_arg new_matches) + +zonkExpr env (HsApp e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (HsApp new_e1 new_e2) + +zonkExpr _ e@(HsRnBracketOut _ _) + = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) + +zonkExpr env (HsTcBracketOut body bs) + = do bs' <- mapM zonk_b bs + return (HsTcBracketOut body bs') + where + zonk_b (PendSplice n e) = do e' <- zonkLExpr env e + return (PendSplice n e') + +zonkExpr _ (HsSpliceE t s) = WARN( True, ppr s ) -- Should not happen + return (HsSpliceE t s) + +zonkExpr env (OpApp e1 op fixity e2) + = do new_e1 <- zonkLExpr env e1 + new_op <- zonkLExpr env op + new_e2 <- zonkLExpr env e2 + return (OpApp new_e1 new_op fixity new_e2) + +zonkExpr env (NegApp expr op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkExpr env op + return (NegApp new_expr new_op) + +zonkExpr env (HsPar e) + = do new_e <- zonkLExpr env e + return (HsPar new_e) + +zonkExpr env (SectionL expr op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkLExpr env op + return (SectionL new_expr new_op) + +zonkExpr env (SectionR op expr) + = do new_op <- zonkLExpr env op + new_expr <- zonkLExpr env expr + return (SectionR new_op new_expr) + +zonkExpr env (ExplicitTuple tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple new_tup_args boxed) } + where + zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e + ; return (L l (Present e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t + ; return (L l (Missing t')) } + +zonkExpr env (HsCase expr ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLExpr ms + return (HsCase new_expr new_ms) + +zonkExpr env (HsIf e0 e1 e2 e3) + = do { new_e0 <- fmapMaybeM (zonkExpr env) e0 + ; new_e1 <- zonkLExpr env e1 + ; new_e2 <- zonkLExpr env e2 + ; new_e3 <- zonkLExpr env e3 + ; return (HsIf new_e0 new_e1 new_e2 new_e3) } + +zonkExpr env (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocM zonk_alt) alts + ; ty' <- zonkTcTypeToType env ty + ; return $ HsMultiIf ty' alts' } + where zonk_alt (GRHS guard expr) + = do { (env', guard') <- zonkStmts env zonkLExpr guard + ; expr' <- zonkLExpr env' expr + ; return $ GRHS guard' expr' } + +zonkExpr env (HsLet binds expr) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_expr <- zonkLExpr new_env expr + return (HsLet new_binds new_expr) + +zonkExpr env (HsDo do_or_lc stmts ty) + = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts + new_ty <- zonkTcTypeToType env ty + return (HsDo do_or_lc new_stmts new_ty) + +zonkExpr env (ExplicitList ty wit exprs) + = do new_ty <- zonkTcTypeToType env ty + new_wit <- zonkWit env wit + new_exprs <- zonkLExprs env exprs + return (ExplicitList new_ty new_wit new_exprs) + where zonkWit _ Nothing = return Nothing + zonkWit env (Just fln) = do new_fln <- zonkExpr env fln + return (Just new_fln) + +zonkExpr env (ExplicitPArr ty exprs) + = do new_ty <- zonkTcTypeToType env ty + new_exprs <- zonkLExprs env exprs + return (ExplicitPArr new_ty new_exprs) + +zonkExpr env (RecordCon data_con con_expr rbinds) + = do { new_con_expr <- zonkExpr env con_expr + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordCon data_con new_con_expr new_rbinds) } + +zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys) + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } + +zonkExpr env (ExprWithTySigOut e ty) + = do { e' <- zonkLExpr env e + ; return (ExprWithTySigOut e' ty) } + +zonkExpr _ (ExprWithTySig _ _ _) = panic "zonkExpr env:ExprWithTySig" + +zonkExpr env (ArithSeq expr wit info) + = do new_expr <- zonkExpr env expr + new_wit <- zonkWit env wit + new_info <- zonkArithSeq env info + return (ArithSeq new_expr new_wit new_info) + where zonkWit _ Nothing = return Nothing + zonkWit env (Just fln) = do new_fln <- zonkExpr env fln + return (Just new_fln) + +zonkExpr env (PArrSeq expr info) + = do new_expr <- zonkExpr env expr + new_info <- zonkArithSeq env info + return (PArrSeq new_expr new_info) + +zonkExpr env (HsSCC src lbl expr) + = do new_expr <- zonkLExpr env expr + return (HsSCC src lbl new_expr) + +zonkExpr env (HsTickPragma src info expr) + = do new_expr <- zonkLExpr env expr + return (HsTickPragma src info new_expr) + +-- hdaume: core annotations +zonkExpr env (HsCoreAnn src lbl expr) + = do new_expr <- zonkLExpr env expr + return (HsCoreAnn src lbl new_expr) + +-- arrow notation extensions +zonkExpr env (HsProc pat body) + = do { (env1, new_pat) <- zonkPat env pat + ; new_body <- zonkCmdTop env1 body + ; return (HsProc new_pat new_body) } + +-- StaticPointers extension +zonkExpr env (HsStatic expr) + = HsStatic <$> zonkLExpr env expr + +zonkExpr env (HsWrap co_fn expr) + = do (env1, new_co_fn) <- zonkCoFn env co_fn + new_expr <- zonkExpr env1 expr + return (HsWrap new_co_fn new_expr) + +zonkExpr _ (HsUnboundVar v) + = return (HsUnboundVar v) + +zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) + +------------------------------------------------------------------------- + +zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) +zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) + +zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd + +zonkCmd env (HsCmdCast co cmd) + = do { co' <- zonkTcCoToCo env co + ; cmd' <- zonkCmd env cmd + ; return (HsCmdCast co' cmd') } +zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_ty <- zonkTcTypeToType env ty + return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + +zonkCmd env (HsCmdArrForm op fixity args) + = do new_op <- zonkLExpr env op + new_args <- mapM (zonkCmdTop env) args + return (HsCmdArrForm new_op fixity new_args) + +zonkCmd env (HsCmdApp c e) + = do new_c <- zonkLCmd env c + new_e <- zonkLExpr env e + return (HsCmdApp new_c new_e) + +zonkCmd env (HsCmdLam matches) + = do new_matches <- zonkMatchGroup env zonkLCmd matches + return (HsCmdLam new_matches) + +zonkCmd env (HsCmdPar c) + = do new_c <- zonkLCmd env c + return (HsCmdPar new_c) + +zonkCmd env (HsCmdCase expr ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLCmd ms + return (HsCmdCase new_expr new_ms) + +zonkCmd env (HsCmdIf eCond ePred cThen cElse) + = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond + ; new_ePred <- zonkLExpr env ePred + ; new_cThen <- zonkLCmd env cThen + ; new_cElse <- zonkLCmd env cElse + ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd env (HsCmdLet binds cmd) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_cmd <- zonkLCmd new_env cmd + return (HsCmdLet new_binds new_cmd) + +zonkCmd env (HsCmdDo stmts ty) + = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts + new_ty <- zonkTcTypeToType env ty + return (HsCmdDo new_stmts new_ty) + + + + + +zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) +zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd + +zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) +zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) + = do new_cmd <- zonkLCmd env cmd + new_stack_tys <- zonkTcTypeToType env stack_tys + new_ty <- zonkTcTypeToType env ty + new_ids <- mapSndM (zonkExpr env) ids + return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) + +------------------------------------------------------------------------- +zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; return (env2, WpCompose c1' c2') } +zonkCoFn env (WpFun c1 c2 t1 t2) = do { (env1, c1') <- zonkCoFn env c1 + ; (env2, c2') <- zonkCoFn env1 c2 + ; t1' <- zonkTcTypeToType env2 t1 + ; t2' <- zonkTcTypeToType env2 t2 + ; return (env2, WpFun c1' c2' t1' t2') } +zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co + ; return (env, WpCast co') } +zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev + ; return (env', WpEvLam ev') } +zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg + ; return (env, WpEvApp arg') } +zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) + do { (env', tv') <- zonkTyBndrX env tv + ; return (env', WpTyLam tv') } +zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty + ; return (env, WpTyApp ty') } +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs + ; return (env1, WpLet bs') } + +------------------------------------------------------------------------- +zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) +zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) + = do { ty' <- zonkTcTypeToType env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_type = ty' }) } + +------------------------------------------------------------------------- +zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) + +zonkArithSeq env (From e) + = do new_e <- zonkLExpr env e + return (From new_e) + +zonkArithSeq env (FromThen e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromThen new_e1 new_e2) + +zonkArithSeq env (FromTo e1 e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromTo new_e1 new_e2) + +zonkArithSeq env (FromThenTo e1 e2 e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (FromThenTo new_e1 new_e2 new_e3) + + +------------------------------------------------------------------------- +zonkStmts :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) +zonkStmts env _ [] = return (env, []) +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s + ; (env2, ss') <- zonkStmts env1 zBody ss + ; return (env2, s' : ss') } + +zonkStmt :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) +zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) + = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs + ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] + env1 = extendIdZonkEnv env new_binders + ; new_mzip <- zonkExpr env1 mzip_op + ; new_bind <- zonkExpr env1 bind_op + ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } + where + zonk_branch (ParStmtBlock stmts bndrs return_op) + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts + ; new_return <- zonkExpr env1 return_op + ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } + +zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id + , recS_later_rets = later_rets, recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty }) + = do { new_rvs <- zonkIdBndrs env rvs + ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty + ; new_ret_id <- zonkExpr env ret_id + ; new_mfix_id <- zonkExpr env mfix_id + ; new_bind_id <- zonkExpr env bind_id + ; let env1 = extendIdZonkEnv env new_rvs + ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts + -- Zonk the ret-expressions in an envt that + -- has the polymorphic bindings in the envt + ; new_later_rets <- mapM (zonkExpr env2) later_rets + ; new_rec_rets <- mapM (zonkExpr env2) rec_rets + ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed + RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } + +zonkStmt env zBody (BodyStmt body then_op guard_op ty) + = do new_body <- zBody env body + new_then <- zonkExpr env then_op + new_guard <- zonkExpr env guard_op + new_ty <- zonkTcTypeToType env ty + return (env, BodyStmt new_body new_then new_guard new_ty) + +zonkStmt env zBody (LastStmt body ret_op) + = do new_body <- zBody env body + new_ret <- zonkExpr env ret_op + return (env, LastStmt new_body new_ret) + +zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) + = do { (env', stmts') <- zonkStmts env zonkLExpr stmts + ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using + ; return_op' <- zonkExpr env' return_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op + ; let env'' = extendIdZonkEnv env' (map snd binderMap') + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } + where + zonkBinderMapEntry env (oldBinder, newBinder) = do + let oldBinder' = zonkIdOcc env oldBinder + newBinder' <- zonkIdBndr env newBinder + return (oldBinder', newBinder') + +zonkStmt env _ (LetStmt binds) + = do (env1, new_binds) <- zonkLocalBinds env binds + return (env1, LetStmt new_binds) + +zonkStmt env zBody (BindStmt pat body bind_op fail_op) + = do { new_body <- zBody env body + ; (env1, new_pat) <- zonkPat env pat + ; new_bind <- zonkExpr env bind_op + ; new_fail <- zonkExpr env fail_op + ; return (env1, BindStmt new_pat new_body new_bind new_fail) } + +------------------------------------------------------------------------- +zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) +zonkRecFields env (HsRecFields flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld) + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldId = new_id + , hsRecFieldArg = new_expr })) } + +------------------------------------------------------------------------- +mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a + -> TcM (Either (Located HsIPName) b) +mapIPNameTc _ (Left x) = return (Left x) +mapIPNameTc f (Right x) = do r <- f x + return (Right r) + +{- +************************************************************************ +* * +\subsection[BackSubst-Pats]{Patterns} +* * +************************************************************************ +-} + +zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat env pat = wrapLocSndM (zonk_pat env) pat + +zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id) +zonk_pat env (ParPat p) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat p') } + +zonk_pat env (WildPat ty) + = do { ty' <- zonkTcTypeToType env ty + ; return (env, WildPat ty') } + +zonk_pat env (VarPat v) + = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv1 env v', VarPat v') } + +zonk_pat env (LazyPat pat) + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat pat') } + +zonk_pat env (BangPat pat) + = do { (env', pat') <- zonkPat env pat + ; return (env', BangPat pat') } + +zonk_pat env (AsPat (L loc v) pat) + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat + ; return (env', AsPat (L loc v') pat') } + +zonk_pat env (ViewPat expr pat ty) + = do { expr' <- zonkLExpr env expr + ; (env', pat') <- zonkPat env pat + ; ty' <- zonkTcTypeToType env ty + ; return (env', ViewPat expr' pat' ty') } + +zonk_pat env (ListPat pats ty Nothing) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' Nothing) } + +zonk_pat env (ListPat pats ty (Just (ty2,wit))) + = do { wit' <- zonkExpr env wit + ; ty2' <- zonkTcTypeToType env ty2 + ; ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } + +zonk_pat env (PArrPat pats ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', PArrPat pats' ty') } + +zonk_pat env (TuplePat pats boxed tys) + = do { tys' <- mapM (zonkTcTypeToType env) tys + ; (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed tys') } + +zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars + , pat_dicts = evs, pat_binds = binds + , pat_args = args, pat_wrap = wrapper }) + = ASSERT( all isImmutableTyVar tyvars ) + do { new_tys <- mapM (zonkTcTypeToType env) tys + ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_binds) <- zonkTcEvBinds env1 binds + ; (env3, new_wrapper) <- zonkCoFn env2 wrapper + ; (env', new_args) <- zonkConStuff env3 args + ; return (env', p { pat_arg_tys = new_tys, + pat_tvs = new_tyvars, + pat_dicts = new_evs, + pat_binds = new_binds, + pat_args = new_args, + pat_wrap = new_wrapper}) } + +zonk_pat env (LitPat lit) = return (env, LitPat lit) + +zonk_pat env (SigPatOut pat ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pat') <- zonkPat env pat + ; return (env', SigPatOut pat' ty') } + +zonk_pat env (NPat (L l lit) mb_neg eq_expr) + = do { lit' <- zonkOverLit env lit + ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg + ; eq_expr' <- zonkExpr env eq_expr + ; return (env, NPat (L l lit') mb_neg' eq_expr') } + +zonk_pat env (NPlusKPat (L loc n) (L l lit) e1 e2) + = do { n' <- zonkIdBndr env n + ; lit' <- zonkOverLit env lit + ; e1' <- zonkExpr env e1 + ; e2' <- zonkExpr env e2 + ; return (extendIdZonkEnv1 env n', + NPlusKPat (L loc n') (L l lit') e1' e2') } + +zonk_pat env (CoPat co_fn pat ty) + = do { (env', co_fn') <- zonkCoFn env co_fn + ; (env'', pat') <- zonkPat env' (noLoc pat) + ; ty' <- zonkTcTypeToType env'' ty + ; return (env'', CoPat co_fn' (unLoc pat') ty') } + +zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: ZonkEnv + -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId)) + -> TcM (ZonkEnv, + HsConDetails (OutPat Id) (HsRecFields id (OutPat Id))) +zonkConStuff env (PrefixCon pats) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } + +zonkConStuff env (InfixCon p1 p2) + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } + +zonkConStuff env (RecCon (HsRecFields rpats dd)) + = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) + ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' })) + rpats pats' + ; return (env', RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking + +--------------------------- +zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id]) +zonkPats env [] = return (env, []) +zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } + +{- +************************************************************************ +* * +\subsection[BackSubst-Foreign]{Foreign exports} +* * +************************************************************************ +-} + +zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] +zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls + +zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) +zonkForeignExport env (ForeignExport i _hs_ty co spec) = + return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec) +zonkForeignExport _ for_imp + = return for_imp -- Foreign imports don't need zonking + +zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] +zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs + +zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) +zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) + = do { unbound_tkv_set <- newMutVar emptyVarSet + ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set) + -- See Note [Zonking the LHS of a RULE] + + ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars + + ; new_lhs <- zonkLExpr env_inside lhs + ; new_rhs <- zonkLExpr env_inside rhs + + ; unbound_tkvs <- readMutVar unbound_tkv_set + + ; let final_bndrs :: [LRuleBndr Var] + final_bndrs = map (noLoc . RuleBndr . noLoc) + (varSetElemsKvsFirst unbound_tkvs) + ++ new_bndrs + + ; return $ + HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs } + where + zonk_bndr env (L l (RuleBndr (L loc v))) + = do { (env', v') <- zonk_it env v + ; return (env', L l (RuleBndr (L loc v'))) } + zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig" + + zonk_it env v + | isId v = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv1 env v', v') } + | otherwise = ASSERT( isImmutableTyVar v) + zonkTyBndrX env v + -- DV: used to be return (env,v) but that is plain + -- wrong because we may need to go inside the kind + -- of v and zonk there! + +zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] +zonkVects env = mapM (wrapLocM (zonkVect env)) + +zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) +zonkVect env (HsVect s v e) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; e' <- zonkLExpr env e + ; return $ HsVect s v' e' + } +zonkVect env (HsNoVect s v) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsNoVect s v' + } +zonkVect _env (HsVectTypeOut s t rt) + = return $ HsVectTypeOut s t rt +zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" +zonkVect _env (HsVectClassOut c) + = return $ HsVectClassOut c +zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn" +zonkVect _env (HsVectInstOut i) + = return $ HsVectInstOut i +zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" + +{- +************************************************************************ +* * + Constraints and evidence +* * +************************************************************************ +-} + +zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm +zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) + return (EvId (zonkIdOcc env v)) +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co + ; return (EvCoercion co') } +zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm + ; co' <- zonkTcCoToCo env co + ; return (mkEvCast tm' co') } +zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm + ; return (EvTupleSel tm' n) } +zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms + ; return (EvTupleMk tms') } +zonkEvTerm _ (EvLit l) = return (EvLit l) + +zonkEvTerm env (EvTypeable ev) = + fmap EvTypeable $ + case ev of + EvTypeableTyCon tc ks -> return (EvTypeableTyCon tc ks) + EvTypeableTyApp t1 t2 -> do e1 <- zonk t1 + e2 <- zonk t2 + return (EvTypeableTyApp e1 e2) + EvTypeableTyLit t -> EvTypeableTyLit `fmap` zonkTcTypeToType env t + where + zonk (ev,t) = do ev' <- zonkEvTerm env ev + t' <- zonkTcTypeToType env t + return (ev',t') + +zonkEvTerm env (EvCallStack cs) + = case cs of + EvCsEmpty -> return (EvCallStack cs) + EvCsTop n l tm -> do { tm' <- zonkEvTerm env tm + ; return (EvCallStack (EvCsTop n l tm')) } + EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm + ; return (EvCallStack (EvCsPushCall n l tm')) } + +zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d + ; return (EvSuperClass d' n) } +zonkEvTerm env (EvDFunApp df tys tms) + = do { tys' <- zonkTcTypeToTypes env tys + ; tms' <- mapM (zonkEvTerm env) tms + ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } +zonkEvTerm env (EvDelayedError ty msg) + = do { ty' <- zonkTcTypeToType env ty + ; return (EvDelayedError ty' msg) } + +zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) +zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var + ; return (env', EvBinds bs') } +zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs + ; return (env', EvBinds bs') } + +zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) +zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref + ; zonkEvBinds env (evBindMapBinds bs) } + +zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) +zonkEvBinds env binds + = {-# SCC "zonkEvBinds" #-} + fixM (\ ~( _, new_binds) -> do + { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds) + ; binds' <- mapBagM (zonkEvBind env1) binds + ; return (env1, binds') }) + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldrBag add [] + add (EvBind var _) vars = var : vars + +zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind +zonkEvBind env (EvBind var term) + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg Trac #5030) + ; let ty' = idType var' + + ; case getEqPredTys_maybe ty' of + Just (r, ty1, ty2) | ty1 `eqType` ty2 + -> return (EvBind var' (EvCoercion (mkTcReflCo r ty1))) + _other -> do { term' <- zonkEvTerm env term + ; return (EvBind var' term') } } + +{- +************************************************************************ +* * + Zonking types +* * +************************************************************************ + +Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo a (C a)) +and we do not want to zap the unbound tyvar 'a' to (), because +that limits the applicability of the rule. Instead, we +want to quantify over it! + +It's easiest to get zonkTvCollecting to gather the free tyvars +here. Attempts to do so earlier are tiresome, because (a) the data +type is big and (b) finding the free type vars of an expression is +necessarily monadic operation. (consider /\a -> f @ b, where b is +side-effected to a) + +And that in turn is why ZonkEnv carries the function to use for +type variables! + +Note [Zonking mutable unbound type or kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an +arbitrary type. We know if they are unbound even though we don't carry an +environment, because at the binding site for a variable we bind the mutable +var to a fresh immutable one. So the mutable store plays the role of an +environment. If we come across a mutable variable that isn't so bound, it +must be completely free. We zonk the expected kind to make sure we don't get +some unbound meta variable as the kind. + +Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both +type and kind variables. Consider the following datatype: + + data Phantom a = Phantom Int + +The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and +`k` are unbound variables. We want to zonk this to +(forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if +we have a type or a kind variable; for kind variables we just return AnyK (and +not the ill-kinded Any BOX). + +Note [Optimise coercion zonkind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When optimising evidence binds we may come across situations where +a coercion looks like + cv = ReflCo ty +or cv1 = cv2 +where the type 'ty' is big. In such cases it is a waste of time to zonk both + * The variable on the LHS + * The coercion on the RHS +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. + +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) +-} + +zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_env + RuntimeUnk {} -> lookup_in_env + FlatSkol ty -> zonkTcTypeToType env ty + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> do { kind <- {-# SCC "zonkKind1" #-} + zonkTcTypeToType env (tyVarKind tv) + ; zonk_unbound_tyvar (setTyVarKind tv kind) } + Indirect ty -> do { zty <- zonkTcTypeToType env ty + -- Small optimisation: shortern-out indirect steps + -- so that the old type may be more easily collected. + ; writeMutVar ref (Indirect zty) + ; return zty } } + | otherwise + = lookup_in_env + where + lookup_in_env -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> return (mkTyVarTy tv) + Just tv' -> return (mkTyVarTy tv') + +zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type +zonkTcTypeToType env ty + = go ty + where + go (TyConApp tc tys) = do tys' <- mapM go tys + return (mkTyConApp tc tys') + -- Establish Type invariants + -- See Note [Zonking inside the knot] in TcHsType + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + + -- The two interesting cases! + go (TyVarTy tv) = zonkTyVarOcc env tv + + go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) + do { (env', tv') <- zonkTyBndrX env tv + ; ty' <- zonkTcTypeToType env' ty + ; return (ForAllTy tv' ty') } + +zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] +zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys + +zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkCoToCo env co + = go co + where + go (Refl r ty) = mkReflCo r <$> zonkTcTypeToType env ty + go (TyConAppCo r tc args) = mkTyConAppCo r tc <$> mapM go args + go (AppCo co arg) = mkAppCo <$> go co <*> go arg + go (AxiomInstCo ax ind args) = AxiomInstCo ax ind <$> mapM go args + go (UnivCo s r ty1 ty2) = mkUnivCo s r <$> zonkTcTypeToType env ty1 + <*> zonkTcTypeToType env ty2 + go (SymCo co) = mkSymCo <$> go co + go (TransCo co1 co2) = mkTransCo <$> go co1 <*> go co2 + go (NthCo n co) = mkNthCo n <$> go co + go (LRCo lr co) = mkLRCo lr <$> go co + go (InstCo co arg) = mkInstCo <$> go co <*> zonkTcTypeToType env arg + go (SubCo co) = mkSubCo <$> go co + go (AxiomRuleCo ax ts cs) = AxiomRuleCo ax <$> mapM (zonkTcTypeToType env) ts + <*> mapM go cs + + -- The two interesting cases! + go (CoVarCo cv) = return (mkCoVarCo $ zonkIdOcc env cv) + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { (env', tv') <- zonkTyBndrX env tv + ; co' <- zonkCoToCo env' co + ; return (mkForAllCo tv' co') } + +zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker +-- This variant collects unbound type variables in a mutable variable +-- Works on both types and kinds +zonkTvCollecting unbound_tv_set tv + = do { poly_kinds <- xoptM Opt_PolyKinds + ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv + else do + { tv' <- zonkQuantifiedTyVar tv + ; tv_set <- readMutVar unbound_tv_set + ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') + ; return (mkTyVarTy tv') } } + +zonkTypeZapping :: UnboundTyVarZonker +-- This variant is used for everything except the LHS of rules +-- It zaps unbound type variables to (), or some other arbitrary type +-- Works on both types and kinds +zonkTypeZapping tv + = do { let ty = if isKindVar tv + -- ty is actually a kind, zonk to AnyK + then anyKind + else anyTypeOfKind (defaultKind (tyVarKind tv)) + ; writeMetaTyVar tv ty + ; return ty } + + +zonkTcCoToCo :: ZonkEnv -> TcCoercion -> TcM TcCoercion +-- NB: zonking often reveals that the coercion is an identity +-- in which case the Refl-ness can propagate up to the top +-- which in turn gives more efficient desugaring. So it's +-- worth using the 'mk' smart constructors on the RHS +zonkTcCoToCo env co + = go co + where + go (TcLetCo bs co) = do { (env', bs') <- zonkTcEvBinds env bs + ; co' <- zonkTcCoToCo env' co + ; return (TcLetCo bs' co') } + go (TcCoVarCo cv) = return (mkTcCoVarCo (zonkEvVarOcc env cv)) + go (TcRefl r ty) = do { ty' <- zonkTcTypeToType env ty + ; return (TcRefl r ty') } + go (TcTyConAppCo r tc cos) + = do { cos' <- mapM go cos; return (mkTcTyConAppCo r tc cos') } + go (TcAxiomInstCo ax ind cos) + = do { cos' <- mapM go cos; return (TcAxiomInstCo ax ind cos') } + go (TcAppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTcAppCo co1' co2') } + go (TcCastCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (TcCastCo co1' co2') } + go (TcPhantomCo ty1 ty2) = do { ty1' <- zonkTcTypeToType env ty1 + ; ty2' <- zonkTcTypeToType env ty2 + ; return (TcPhantomCo ty1' ty2') } + go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') } + go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') } + go (TcLRCo lr co) = do { co' <- go co; return (mkTcLRCo lr co') } + go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTcTransCo co1' co2') } + go (TcForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkTcForAllCo tv co') } + go (TcSubCo co) = do { co' <- go co; return (mkTcSubCo co') } + go (TcAxiomRuleCo co ts cs) = do { ts' <- zonkTcTypeToTypes env ts + ; cs' <- mapM go cs + ; return (TcAxiomRuleCo co ts' cs') + } + go (TcCoercion co) = do { co' <- zonkCoToCo env co + ; return (TcCoercion co') } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs new file mode 100644 index 00000000..937b5e8e --- /dev/null +++ b/compiler/typecheck/TcHsType.hs @@ -0,0 +1,1669 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcMonoType]{Typechecking user-specified @MonoTypes@} +-} + +{-# LANGUAGE CPP #-} + +module TcHsType ( + tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, + tcHsInstHead, + UserTypeCtxt(..), + + -- Type checking type and class decls + kcLookupKind, kcTyClTyVars, tcTyClTyVars, + tcHsConArgType, tcDataKindSig, + tcClassSigType, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + kcHsTyVarBndrs, tcHsTyVarBndrs, + tcHsLiftedType, tcHsOpenType, + tcLHsType, tcCheckLHsType, + tcHsContext, tcInferApps, tcHsArgTys, + + kindGeneralize, checkKind, + + -- Sort-checking kinds + tcLHsKind, + + -- Pattern type signatures + tcHsPatSigType, tcPatSig + ) where + +#include "HsVersions.h" + +import HsSyn +import TcRnMonad +import TcEvidence( HsWrapper ) +import TcEnv +import TcMType +import TcValidity +import TcUnify +import TcIface +import TcType +import Type +import TypeRep( Type(..) ) -- For the mkNakedXXX stuff +import Kind +import RdrName( lookupLocalRdrOcc ) +import Var +import VarSet +import TyCon +import ConLike +import DataCon +import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) +import Class +import Name +import NameEnv +import TysWiredIn +import BasicTypes +import SrcLoc +import DynFlags ( ExtensionFlag( Opt_DataKinds ), getDynFlags ) +import Unique +import UniqSupply +import Outputable +import FastString +import Util + +import Data.Maybe( isNothing ) +import Control.Monad ( unless, when, zipWithM ) +import PrelNames( ipClassName, funTyConKey, allNameStrings ) + +{- + ---------------------------- + General notes + ---------------------------- + +Generally speaking we now type-check types in three phases + + 1. kcHsType: kind check the HsType + *includes* performing any TH type splices; + so it returns a translated, and kind-annotated, type + + 2. dsHsType: convert from HsType to Type: + perform zonking + expand type synonyms [mkGenTyApps] + hoist the foralls [tcHsType] + + 3. checkValidType: check the validity of the resulting type + +Often these steps are done one after the other (tcHsSigType). +But in mutually recursive groups of type and class decls we do + 1 kind-check the whole group + 2 build TyCons/Classes in a knot-tied way + 3 check the validity of types in the now-unknotted TyCons/Classes + +For example, when we find + (forall a m. m a -> m a) +we bind a,m to kind varibles and kind-check (m a -> m a). This makes +a get kind *, and m get kind *->*. Now we typecheck (m a -> m a) in +an environment that binds a and m suitably. + +The kind checker passed to tcHsTyVars needs to look at enough to +establish the kind of the tyvar: + * For a group of type and class decls, it's just the group, not + the rest of the program + * For a tyvar bound in a pattern type signature, its the types + mentioned in the other type signatures in that bunch of patterns + * For a tyvar bound in a RULE, it's the type signatures on other + universally quantified variables in the rule + +Note that this may occasionally give surprising results. For example: + + data T a b = MkT (a b) + +Here we deduce a::*->*, b::* +But equally valid would be a::(*->*)-> *, b::*->* + + +Validity checking +~~~~~~~~~~~~~~~~~ +Some of the validity check could in principle be done by the kind checker, +but not all: + +- During desugaring, we normalise by expanding type synonyms. Only + after this step can we check things like type-synonym saturation + e.g. type T k = k Int + type S a = a + Then (T S) is ok, because T is saturated; (T S) expands to (S Int); + and then S is saturated. This is a GHC extension. + +- Similarly, also a GHC extension, we look through synonyms before complaining + about the form of a class or instance declaration + +- Ambiguity checks involve functional dependencies, and it's easier to wait + until knots have been resolved before poking into them + +Also, in a mutually recursive group of types, we can't look at the TyCon until we've +finished building the loop. So to keep things simple, we postpone most validity +checking until step (3). + +Knot tying +~~~~~~~~~~ +During step (1) we might fault in a TyCon defined in another module, and it might +(via a loop) refer back to a TyCon defined in this module. So when we tie a big +knot around type declarations with ARecThing, so that the fault-in code can get +the TyCon being defined. + + +************************************************************************ +* * + Check types AND do validity checking +* * +************************************************************************ +-} + +tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type + -- NB: it's important that the foralls that come from the top-level + -- HsForAllTy in hs_ty occur *first* in the returned type. + -- See Note [Scoped] with TcSigInfo +tcHsSigType ctxt hs_ty + = addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $ + tcHsSigTypeNC ctxt hs_ty + +tcHsSigTypeNC ctxt (L loc hs_ty) + = setSrcSpan loc $ -- The "In the type..." context + -- comes from the caller; hence "NC" + do { kind <- case expectedKindInCtxt ctxt of + Nothing -> newMetaKindVar + Just k -> return k + -- The kind is checked by checkValidType, and isn't necessarily + -- of kind * in a Template Haskell quote eg [t| Maybe |] + + -- Generalise here: see Note [Kind generalisation] + ; ty <- tcCheckHsTypeAndGen hs_ty kind + + -- Zonk to expose kind information to checkValidType + ; ty <- zonkSigType ty + ; checkValidType ctxt ty + ; return ty } + +----------------- +tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) +-- Like tcHsSigTypeNC, but for an instance head. +tcHsInstHead user_ctxt lhs_ty@(L loc hs_ty) + = setSrcSpan loc $ -- The "In the type..." context comes from the caller + do { inst_ty <- tc_inst_head hs_ty + ; kvs <- zonkTcTypeAndFV inst_ty + ; kvs <- kindGeneralize kvs + ; inst_ty <- zonkSigType (mkForAllTys kvs inst_ty) + ; checkValidInstance user_ctxt lhs_ty inst_ty } + +tc_inst_head :: HsType Name -> TcM TcType +tc_inst_head (HsForAllTy _ _ hs_tvs hs_ctxt hs_ty) + = tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { ctxt <- tcHsContext hs_ctxt + ; ty <- tc_lhs_type hs_ty ekConstraint -- Body for forall has kind Constraint + ; return (mkSigmaTy tvs ctxt ty) } + +tc_inst_head hs_ty + = tc_hs_type hs_ty ekConstraint + +----------------- +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind) +-- Like tcHsSigTypeNC, but for the ...deriving( C t1 ty2 ) clause +-- Returns the C, [ty1, ty2, and the kind of C's *next* argument +-- E.g. class C (a::*) (b::k->k) +-- data T a b = ... deriving( C Int ) +-- returns ([k], C, [k, Int], k->k) +-- Also checks that (C ty1 ty2 arg) :: Constraint +-- if arg has a suitable kind +tcHsDeriv hs_ty + = do { arg_kind <- newMetaKindVar + ; ty <- tcCheckHsTypeAndGen hs_ty (mkArrowKind arg_kind constraintKind) + ; ty <- zonkSigType ty + ; arg_kind <- zonkSigType arg_kind + ; let (tvs, pred) = splitForAllTys ty + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys, arg_kind) + Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } + +-- Used for 'VECTORISE [SCALAR] instance' declarations +-- +tcHsVectInst :: LHsType Name -> TcM (Class, [Type]) +tcHsVectInst ty + | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty + = do { (cls, cls_kind) <- tcClass cls_name + ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys + ; return (cls, arg_tys) } + | otherwise + = failWithTc $ ptext (sLit "Malformed instance type") + +{- + These functions are used during knot-tying in + type and class declarations, when we have to + separate kind-checking, desugaring, and validity checking + + +************************************************************************ +* * + The main kind checker: no validity checks here +* * +************************************************************************ + + First a couple of simple wrappers for kcHsType +-} + +tcClassSigType :: LHsType Name -> TcM Type +tcClassSigType lhs_ty@(L _ hs_ty) + = addTypeCtxt lhs_ty $ + do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind + ; zonkSigType ty } + +tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type +-- Permit a bang, but discard it +tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) + -- Newtypes can't have bangs, but we don't check that + -- until checkValidDataCon, so do not want to crash here + +tcHsConArgType DataType bty = tcHsOpenType (getBangType bty) + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd + +--------------------------- +tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +tcHsArgTys what tys kinds + = sequence [ addTypeCtxt ty $ + tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] + +tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +-- Just like tcHsArgTys but without the addTypeCtxt +tc_hs_arg_tys what tys kinds + = sequence [ tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] + +--------------------------- +tcHsOpenType, tcHsLiftedType :: LHsType Name -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType ty = addTypeCtxt ty $ tc_lhs_type ty ekOpen +tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType Name -> Kind -> TcM Type +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + tc_lhs_type hs_ty (EK exp_kind expectedKindMsg) + +tcLHsType :: LHsType Name -> TcM (TcType, TcKind) +-- Called from outside: set the context +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) + +--------------------------- +tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type +-- Input type is HsType, not LhsType; the caller adds the context +-- Typecheck a type signature, and kind-generalise it +-- The result is not necessarily zonked, and has not been checked for validity +tcCheckHsTypeAndGen hs_ty kind + = do { ty <- tc_hs_type hs_ty (EK kind expectedKindMsg) + ; traceTc "tcCheckHsTypeAndGen" (ppr hs_ty) + ; kvs <- zonkTcTypeAndFV ty + ; kvs <- kindGeneralize kvs + ; return (mkForAllTys kvs ty) } + +{- +Like tcExpr, tc_hs_type takes an expected kind which it unifies with +the kind it figures out. When we don't know what kind to expect, we use +tc_lhs_type_fresh, to first create a new meta kind variable and use that as +the expected kind. +-} + +tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type ty = + do { kv <- newMetaKindVar + ; r <- tc_lhs_type ty (EK kv expectedKindMsg) + ; return (r, kv) } + +tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType +tc_lhs_type (L span ty) exp_kind + = setSrcSpan span $ + do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind) + ; tc_hs_type ty exp_kind } + +tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] +tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds + +------------------------------------------ +tc_fun_type :: HsType Name -> LHsType Name -> LHsType Name -> ExpKind -> TcM TcType +-- We need to recognise (->) so that we can construct a FunTy, +-- *and* we need to do by looking at the Name, not the TyCon +-- (see Note [Zonking inside the knot]). For example, +-- consider f :: (->) Int Int (Trac #7312) +tc_fun_type ty ty1 ty2 exp_kind@(EK _ ctxt) + = do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt) + ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) + ; checkExpectedKind ty liftedTypeKind exp_kind + ; return (mkFunTy ty1' ty2') } + +------------------------------------------ +tc_hs_type :: HsType Name -> ExpKind -> TcM TcType +tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer +tc_hs_type ty@(HsBangTy {}) _ + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210) + = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) +tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + +---------- Functions and applications +tc_hs_type hs_ty@(HsTyVar name) exp_kind + = do { (ty, k) <- tcTyVar name + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + +tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind + = tc_fun_type ty ty1 ty2 exp_kind + +tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind + | op `hasKey` funTyConKey + = tc_fun_type hs_ty ty1 ty2 exp_kind + | otherwise + = do { (op', op_kind) <- tcTyVar op + ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind + ; return (mkNakedAppTys op' tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind +-- | L _ (HsTyVar fun) <- fun_ty +-- , fun `hasKey` funTyConKey +-- , [fty1,fty2] <- arg_tys +-- = tc_fun_type hs_ty fty1 fty2 exp_kind +-- | otherwise + = do { (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty + ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind + ; return (mkNakedAppTys fun_ty' arg_tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + -- This looks fragile; how do we *know* that fun_ty isn't + -- a TyConApp, say (which is never supposed to appear in the + -- function position of an AppTy)? + where + (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + +--------- Foralls +tc_hs_type hs_ty@(HsForAllTy _ _ hs_tvs context ty) exp_kind@(EK exp_k _) + | isConstraintKind exp_k + = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) + + | otherwise + = tcHsTyVarBndrs hs_tvs $ \ tvs' -> + -- Do not kind-generalise here! See Note [Kind generalisation] + do { ctxt' <- tcHsContext context + ; ty' <- if null (unLoc context) then -- Plain forall, no context + tc_lhs_type ty exp_kind -- Why exp_kind? See Note [Body kind of forall] + else + -- If there is a context, then this forall is really a + -- _function_, so the kind of the result really is * + -- The body kind (result of the function can be * or #, hence ekOpen + do { checkExpectedKind hs_ty liftedTypeKind exp_kind + ; tc_lhs_type ty ekOpen } + ; return (mkSigmaTy tvs' ctxt' ty') } + +--------- Lists, arrays, and tuples +tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon listTyCon + ; return (mkListTy tau_ty) } + +tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon parrTyCon + ; return (mkPArrTy tau_ty) } + +-- See Note [Distinguishing tuple kinds] in HsTypes +-- See Note [Inferring tuple kinds] +tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt) + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | Just tup_sort <- tupKindSort_maybe exp_k + = traceTc "tc_hs_type tuple" (ppr hs_tys) >> + tc_tuple hs_ty tup_sort hs_tys exp_kind + | otherwise + = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) + ; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys + ; kinds <- mapM zonkTcKind kinds + -- Infer each arg type separately, because errors can be + -- confusing if we give them a shared kind. Eg Trac #7410 + -- (Either Int, Int), we do not want to get an error saying + -- "the second argument of a tuple should have kind *->*" + + ; let (arg_kind, tup_sort) + = case [ (k,s) | k <- kinds + , Just s <- [tupKindSort_maybe k] ] of + ((k,s) : _) -> (k,s) + [] -> (liftedTypeKind, BoxedTuple) + -- In the [] case, it's not clear what the kind is, so guess * + + ; sequence_ [ setSrcSpan loc $ + checkExpectedKind ty kind + (expArgKind (ptext (sLit "a tuple")) arg_kind n) + | (ty@(L loc _),kind,n) <- zip3 hs_tys kinds [1..] ] + + ; finish_tuple hs_ty tup_sort tys exp_kind } + + +tc_hs_type hs_ty@(HsTupleTy hs_tup_sort tys) exp_kind + = tc_tuple hs_ty tup_sort tys exp_kind + where + tup_sort = case hs_tup_sort of -- Fourth case dealt with above + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + + +--------- Promoted lists and tuples +tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let taus = map fst tks + ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks + ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind + ; return (foldr (mk_cons kind) (mk_nil kind) taus) } + where + mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] + +tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let n = length tys + kind_con = promotedTupleTyCon BoxedTuple n + ty_con = promotedTupleDataCon BoxedTuple n + (taus, ks) = unzip tks + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind hs_ty tup_k exp_kind + ; return (mkTyConApp ty_con (ks ++ taus)) } + +--------- Constraint types +tc_hs_type ipTy@(HsIParamTy n ty) exp_kind + = do { ty' <- tc_lhs_type ty ekLifted + ; checkExpectedKind ipTy constraintKind exp_kind + ; ipClass <- tcLookupClass ipClassName + ; let n' = mkStrLitTy $ hsIPNameFS n + ; return (mkClassPred ipClass [n',ty']) + } + +tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind + = do { (ty1', kind1) <- tc_infer_lhs_type ty1 + ; (ty2', kind2) <- tc_infer_lhs_type ty2 + ; checkExpectedKind ty2 kind2 + (EK kind1 msg_fn) + ; checkExpectedKind ty constraintKind exp_kind + ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) } + where + msg_fn pkind = ptext (sLit "The left argument of the equality had kind") + <+> quotes (pprKind pkind) + +--------- Misc +tc_hs_type (HsKindSig ty sig_k) exp_kind + = do { sig_k' <- tcLHsKind sig_k + ; checkExpectedKind ty sig_k' exp_kind + ; tc_lhs_type ty (EK sig_k' msg_fn) } + where + msg_fn pkind = ptext (sLit "The signature specified kind") + <+> quotes (pprKind pkind) + +tc_hs_type (HsCoreTy ty) exp_kind + = do { checkExpectedKind ty (typeKind ty) exp_kind + ; return ty } + + +-- This should never happen; type splices are expanded by the renamer +tc_hs_type ty@(HsSpliceTy {}) _exp_kind + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) + +tc_hs_type (HsWrapTy {}) _exp_kind + = panic "tc_hs_type HsWrapTy" -- We kind checked something twice + +tc_hs_type hs_ty@(HsTyLit (HsNumTy _ n)) exp_kind + = do { checkExpectedKind hs_ty typeNatKind exp_kind + ; checkWiredInTyCon typeNatKindCon + ; return (mkNumLitTy n) } + +tc_hs_type hs_ty@(HsTyLit (HsStrTy _ s)) exp_kind + = do { checkExpectedKind hs_ty typeSymbolKind exp_kind + ; checkWiredInTyCon typeSymbolKindCon + ; return (mkStrLitTy s) } + + +tc_hs_type HsWildcardTy _ = panic "tc_hs_type HsWildcardTy" +-- unnamed wildcards should have been replaced by named wildcards + +tc_hs_type hs_ty@(HsNamedWildcardTy name) exp_kind + = do { (ty, k) <- tcTyVar name + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | isConstraintKind k = Just ConstraintTuple + | isLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType Name -> TupleSort -> [LHsType Name] -> ExpKind -> TcM TcType +tc_tuple hs_ty tup_sort tys exp_kind + = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) + ; finish_tuple hs_ty tup_sort tau_tys exp_kind } + where + arg_kind = case tup_sort of + BoxedTuple -> liftedTypeKind + UnboxedTuple -> openTypeKind + ConstraintTuple -> constraintKind + cxt_doc = case tup_sort of + BoxedTuple -> ptext (sLit "a tuple") + UnboxedTuple -> ptext (sLit "an unboxed tuple") + ConstraintTuple -> ptext (sLit "a constraint tuple") + +finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType +finish_tuple hs_ty tup_sort tau_tys exp_kind + = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind) + ; checkExpectedKind hs_ty res_kind exp_kind + ; checkWiredInTyCon tycon + ; return (mkTyConApp tycon tau_tys) } + where + tycon = tupleTyCon tup_sort (length tau_tys) + res_kind = case tup_sort of + UnboxedTuple -> unliftedTypeKind + BoxedTuple -> liftedTypeKind + ConstraintTuple -> constraintKind + +--------------------------- +tcInferApps :: Outputable a + => a + -> TcKind -- Function kind + -> [LHsType Name] -- Arg types + -> TcM ([TcType], TcKind) -- Kind-checked args +tcInferApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args + ; args' <- tc_lhs_types args_w_kinds + ; return (args', res_kind) } + +tcCheckApps :: Outputable a + => HsType Name -- The type being checked (for err messages only) + -> a -- The function + -> TcKind -> [LHsType Name] -- Fun kind and arg types + -> ExpKind -- Expected kind + -> TcM [TcType] +tcCheckApps hs_ty the_fun fun_kind args exp_kind + = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args + ; checkExpectedKind hs_ty res_kind exp_kind + ; return arg_tys } + +--------------------------- +splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) +splitFunKind the_fun fun_kind args + = go 1 fun_kind args + where + go _ fk [] = return ([], fk) + go arg_no fk (arg:args) + = do { mb_fk <- matchExpectedFunKind fk + ; case mb_fk of + Nothing -> failWithTc too_many_args + Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args + ; let exp_kind = expArgKind (quotes the_fun) ak arg_no + ; return ((arg, exp_kind) : aks, rk) } } + + too_many_args = quotes the_fun <+> + ptext (sLit "is applied to too many type arguments") + + +--------------------------- +tcHsContext :: LHsContext Name -> TcM [PredType] +tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt) + +tcHsLPredType :: LHsType Name -> TcM PredType +tcHsLPredType pred = tc_lhs_type pred ekConstraint + +--------------------------- +tcTyVar :: Name -> TcM (TcType, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in TcTyClsDecls +tcTyVar name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; case thing of + ATyVar _ tv + | isKindVar tv + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr tv) + <+> ptext (sLit "used as a type")) + | otherwise + -> return (mkTyVarTy tv, tyVarKind tv) + + AThing kind -> do { tc <- get_loopy_tc name + ; inst_tycon (mkNakedTyConApp tc) kind } + -- mkNakedTyConApp: see Note [Zonking inside the knot] + + AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) + + AGlobal (AConLike (RealDataCon dc)) + | Just tc <- promoteDataCon_maybe dc + -> do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds $ promotionErr name NoDataKinds + ; inst_tycon (mkTyConApp tc) (tyConKind tc) } + | otherwise -> failWithTc (ptext (sLit "Data constructor") <+> quotes (ppr dc) + <+> ptext (sLit "comes from an un-promotable type") + <+> quotes (ppr (dataConTyCon dc))) + + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr "type" thing name } + where + get_loopy_tc name + = do { env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of + Just (ATyCon tc) -> return tc + _ -> return (aThingErr "tcTyVar" name) } + + inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind) + -- Instantiate the polymorphic kind + -- Lazy in the TyCon + inst_tycon mk_tc_app kind + | null kvs + = return (mk_tc_app [], ki_body) + | otherwise + = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) + ; ks <- mapM (const newMetaKindVar) kvs + ; return (mk_tc_app ks, substKiWith kvs ks ki_body) } + where + (kvs, ki_body) = splitForAllTys kind + +tcClass :: Name -> TcM (Class, TcKind) +tcClass cls -- Must be a class + = do { thing <- tcLookup cls + ; case thing of + AThing kind -> return (aThingErr "tcClass" cls, kind) + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc + -> return (cls, tyConKind tc) + _ -> wrongThingErr "class" thing cls } + + +aThingErr :: String -> Name -> b +-- The type checker for types is sometimes called simply to +-- do *kind* checking; and in that case it ignores the type +-- returned. Which is a good thing since it may not be available yet! +aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) + +{- +Note [Zonking inside the knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are checking the argument types of a data constructor. We +must zonk the types before making the DataCon, because once built we +can't change it. So we must traverse the type. + +BUT the parent TyCon is knot-tied, so we can't look at it yet. + +So we must be careful not to use "smart constructors" for types that +look at the TyCon or Class involved. + + * Hence the use of mkNakedXXX functions. These do *not* enforce + the invariants (for example that we use (FunTy s t) rather + than (TyConApp (->) [s,t])). + + * Ditto in zonkTcType (which may be applied more than once, eg to + squeeze out kind meta-variables), we are careful not to look at + the TyCon. + + * We arrange to call zonkSigType *once* right at the end, and it + does establish the invariants. But in exchange we can't look + at the result (not even its structure) until we have emerged + from the "knot". + + * TcHsSyn.zonkTcTypeToType also can safely check/establish + invariants. + +This is horribly delicate. I hate it. A good example of how +delicate it is can be seen in Trac #7903. +-} + +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * without satisfying the invariants of TyConApp +-- A subsequent zonking will establish the invariants +mkNakedTyConApp tc tys = TyConApp tc tys + +mkNakedAppTys :: Type -> [Type] -> Type +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +zonkSigType :: TcType -> TcM TcType +-- Zonk the result of type-checking a user-written type signature +-- It may have kind variables in it, but no meta type variables +-- Because of knot-typing (see Note [Zonking inside the knot]) +-- it may need to establish the Type invariants; +-- hence the use of mkTyConApp and mkAppTy +zonkSigType ty + = go ty + where + go (TyConApp tc tys) = do tys' <- mapM go tys + return (mkTyConApp tc tys') + -- Key point: establish Type invariants! + -- See Note [Zonking inside the knot] + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + + -- The two interesting cases! + go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar + -- Ordinary (non Tc) tyvars occur inside quantified types + + go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv + ; ty' <- go ty + ; return (ForAllTy tv' ty') } + +{- +Note [Body kind of a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analyis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +Moreover if we have a signature + f :: Int# +then we represent it as (HsForAll Implicit [] [] Int#). And this must +be legal! We can't drop the empty forall until *after* typechecking +the body because of kind polymorphism: + Typeable :: forall k. k -> Constraint + data Apply f t = Apply (f t) + -- Apply :: forall k. (k -> *) -> k -> * + instance Typeable Apply where ... +Then the dfun has type + df :: forall k. Typeable ((k->*) -> k -> *) (Apply k) + + f :: Typeable Apply + + f :: forall (t:k->*) (a:k). t a -> t a + + class C a b where + op :: a b -> Typeable Apply + + data T a = MkT (Typeable Apply) + | T2 a + T :: * -> * + MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a + + f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int + f :: (forall a. a -> Typeable Apply) -> Int + +So we *must* keep the HsForAll on the instance type + HsForAll Implicit [] [] (Typeable Apply) +so that we do kind generalisation on it. + +Really we should check that it's a type of value kind +{*, Constraint, #}, but I'm not doing that yet +Example that should be rejected: + f :: (forall (a:*->*). a) Int + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the Check the arguments again to give good error messages +in eg. `(Maybe, Maybe)` + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. + +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * It zonks any kinds. The returned type should have no mutable kind + or type variables (hence returning Type not TcType): + - any unconstrained kind variables are defaulted to AnyK just + as in TcHsSyn. + - there are no mutable type variables because we are + kind-checking a type + Reason: the returned type may be put in a TyCon or DataCon where + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to AnyK when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as + (a) spurious ! annotations. + (b) a class used as a type + +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encounter the unconstrained kappa, we +want to default it to '*', not to AnyK. + + +Help functions for type applications +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +addTypeCtxt :: LHsType Name -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. + -- Omit invisble ones and ones user's won't grok +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = ptext (sLit "In the type") <+> quotes (ppr ty) + +{- +************************************************************************ +* * + Type-variable binders +* * +************************************************************************ +-} + +mkKindSigVar :: Name -> TcM KindVar +-- Use the specified name; don't clone it +mkKindSigVar n + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Just (AThing k) + | Just kvar <- getTyVar_maybe k + -> return kvar + _ -> return $ mkTcTyVar n superKind (SkolemTv False) } + +kcScopedKindVars :: [Name] -> TcM a -> TcM a +-- Given some tyvar binders like [a (b :: k -> *) (c :: k)] +-- bind each scoped kind variable (k in this case) to a fresh +-- kind skolem variable +kcScopedKindVars kv_ns thing_inside + = do { kvs <- mapM (\n -> newSigTyVar n superKind) kv_ns + -- NB: use mutable signature variables + ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } + +-- | Kind-check a 'LHsTyVarBndrs'. If the decl under consideration has a complete, +-- user-supplied kind signature (CUSK), generalise the result. Used in 'getInitialKind' +-- and in kind-checking. See also Note [Complete user-supplied kind signatures] in +-- HsDecls. +kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK + -> LHsTyVarBndrs Name + -> TcM (Kind, r) -- ^ the result kind, possibly with other info + -> TcM (Kind, r) -- ^ The full kind of the thing being declared, + -- with the other info +kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = do { kvs <- if cusk + then mapM mkKindSigVar kv_ns + else mapM (\n -> newSigTyVar n superKind) kv_ns + ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ + do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs + ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside + ; let full_kind = mkArrowKinds (map snd nks) res_kind + kvs = filter (not . isMetaTyVar) $ + varSetElems $ tyVarsOfType full_kind + gen_kind = if cusk + then mkForAllTys kvs full_kind + else full_kind + ; return (gen_kind, stuff) } } + where + kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) + kc_hs_tv (UserTyVar n) + = do { mb_thing <- tcLookupLcl_maybe n + ; kind <- case mb_thing of + Just (AThing k) -> return k + _ | cusk -> return liftedTypeKind + | otherwise -> newMetaKindVar + ; return (n, kind) } + kc_hs_tv (KindedTyVar (L _ n) k) + = do { kind <- tcLHsKind k + -- In an associated type decl, the type variable may already + -- be in scope; in that case we want to make sure its kind + -- matches the one declared here + ; mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Nothing -> return () + Just (AThing ks) -> checkKind kind ks + Just thing -> pprPanic "check_in_scope" (ppr thing) + ; return (n, kind) } + +tcHsTyVarBndrs :: LHsTyVarBndrs Name + -> ([TcTyVar] -> TcM r) + -> TcM r +-- Bind the kind variables to fresh skolem variables +-- and type variables to skolems, each with a meta-kind variable kind +tcHsTyVarBndrs (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = do { kvs <- mapM mkKindSigVar kv_ns + ; tcExtendTyVarEnv kvs $ do + { tvs <- mapM tcHsTyVarBndr hs_tvs + ; traceTc "tcHsTyVarBndrs {" (vcat [ text "Hs kind vars:" <+> ppr kv_ns + , text "Hs type vars:" <+> ppr hs_tvs + , text "Kind vars:" <+> ppr kvs + , text "Type vars:" <+> ppr tvs ]) + ; res <- tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs)) + ; traceTc "tcHsTyVarBndrs }" (vcat [ text "Hs kind vars:" <+> ppr kv_ns + , text "Hs type vars:" <+> ppr hs_tvs + , text "Kind vars:" <+> ppr kvs + , text "Type vars:" <+> ppr tvs ]) + ; return res } } + +tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar +-- Return a type variable +-- initialised with a kind variable. +-- Typically the Kind inside the HsTyVarBndr will be a tyvar with a mutable kind +-- in it. +-- +-- If the variable is already in scope return it, instead of introducing a new +-- one. This can occur in +-- instance C (a,b) where +-- type F (a,b) c = ... +-- Here a,b will be in scope when processing the associated type instance for F. +-- See Note [Associated type tyvar names] in Class +tcHsTyVarBndr (L _ hs_tv) + = do { let name = hsTyVarName hs_tv + ; mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of { + Just (ATyVar _ tv) -> return tv ; + _ -> do + { kind <- case hs_tv of + UserTyVar {} -> newMetaKindVar + KindedTyVar _ kind -> tcLHsKind kind + ; return ( mkTcTyVar name kind (SkolemTv False)) } } } + +------------------ +kindGeneralize :: TyVarSet -> TcM [KindVar] +kindGeneralize tkvs + = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked + ; quantifyTyVars gbl_tvs (filterVarSet isKindVar tkvs) } + -- ToDo: remove the (filter isKindVar) + -- Any type variables in tkvs will be in scope, + -- and hence in gbl_tvs, so after removing gbl_tvs + -- we should only have kind variables left + -- + -- BUT there is a smelly case (to be fixed when TH is reorganised) + -- f t = [| e :: $t |] + -- When typechecking the body of the bracket, we typecheck $t to a + -- unification variable 'alpha', with no biding forall. We don't + -- want to kind-quantify it! + +{- +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. +-} + +-------------------- +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Unpack it, and attribute those kinds to the type variables +-- Extend the env with bindings for the tyvars, taken from +-- the kind of the tycon/class. Give it to the thing inside, and +-- check the result kind matches +kcLookupKind :: Name -> TcM Kind +kcLookupKind nm + = do { tc_ty_thing <- tcLookup nm + ; case tc_ty_thing of + AThing k -> return k + AGlobal (ATyCon tc) -> return (tyConKind tc) + _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } + +kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a +-- Used for the type variables of a type or class decl, +-- when doing the initial kind-check. +kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = kcScopedKindVars kvs $ + do { tc_kind <- kcLookupKind name + ; let (_, mono_kind) = splitForAllTys tc_kind + -- if we have a FullKindSignature, the tc_kind may already + -- be generalized. The kvs get matched up while kind-checking + -- the types in kc_tv, below + (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) mono_kind + -- There should be enough arrows, because + -- getInitialKinds used the tcdTyVars + ; name_ks <- zipWithM kc_tv hs_tvs arg_ks + ; tcExtendKindEnv name_ks thing_inside } + where + -- getInitialKind has already gotten the kinds of these type + -- variables, but tiresomely we need to check them *again* + -- to match the kind variables they mention against the ones + -- we've freshly brought into scope + kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) + kc_tv (L _ (UserTyVar n)) exp_k + = return (n, exp_k) + kc_tv (L _ (KindedTyVar (L _ n) hs_k)) exp_k + = do { k <- tcLHsKind hs_k + ; checkKind k exp_k + ; return (n, exp_k) } + +----------------------- +tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl + -> ([TyVar] -> Kind -> TcM a) -> TcM a +-- Used for the type variables of a type or class decl, +-- on the second pass when constructing the final result +-- (tcTyClTyVars T [a,b] thing_inside) +-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- calls thing_inside with arguments +-- [k1,k2,a,b] (k2 -> *) +-- having also extended the type environment with bindings +-- for k1,k2,a,b +-- +-- No need to freshen the k's because they are just skolem +-- constants here, and we are at top level anyway. +tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside + = kcScopedKindVars hs_kvs $ -- Bind scoped kind vars to fresh kind univ vars + -- There may be fewer of these than the kvs of + -- the type constructor, of course + do { thing <- tcLookup tycon + ; let { kind = case thing of + AThing kind -> kind + _ -> panic "tcTyClTyVars" + -- We only call tcTyClTyVars during typechecking in + -- TcTyClDecls, where the local env is extended with + -- the generalized_env (mapping Names to AThings). + ; (kvs, body) = splitForAllTys kind + ; (kinds, res) = splitKindFunTysN (length hs_tvs) body } + ; tvs <- zipWithM tc_hs_tv hs_tvs kinds + ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) } + where + -- In the case of associated types, the renamer has + -- ensured that the names are in commmon + -- e.g. class C a_29 where + -- type T b_30 a_29 :: * + -- Here the a_29 is shared + tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) + tc_hs_tv (L _ (KindedTyVar (L _ n) hs_k)) kind + = do { tc_kind <- tcLHsKind hs_k + ; checkKind kind tc_kind + ; return (mkTyVar n kind) } + +----------------------------------- +tcDataKindSig :: Kind -> TcM [TyVar] +-- GADT decls can have a (perhaps partial) kind signature +-- e.g. data T :: * -> * -> * where ... +-- This function makes up suitable (kinded) type variables for +-- the argument kinds, and checks that the result kind is indeed *. +-- We use it also to make up argument type variables for for data instances. +tcDataKindSig kind + = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) + ; span <- getSrcSpanM + ; us <- newUniqueSupply + ; rdr_env <- getLocalRdrEnv + ; let uniqs = uniqsFromSupply us + occs = [ occ | str <- allNameStrings + , let occ = mkOccName tvName str + , isNothing (lookupLocalRdrOcc rdr_env occ) ] + -- Note [Avoid name clashes for associated data types] + + ; return [ mk_tv span uniq occ kind + | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] } + where + (arg_kinds, res_kind) = splitKindFunTys kind + mk_tv loc uniq occ kind + = mkTyVar (mkInternalName uniq occ loc) kind + +badKindSig :: Kind -> SDoc +badKindSig kind + = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) + 2 (ppr kind) + +{- +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get + class C a b where + data D b a0 +(NB: the tidying happens in the conversion to IfaceSyn, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. + + +************************************************************************ +* * + Scoped type variables +* * +************************************************************************ + + +tcAddScopedTyVars is used for scoped type variables added by pattern +type signatures + e.g. \ ((x::a), (y::a)) -> x+y +They never have explicit kinds (because this is source-code only) +They are mutable (because they can get bound to a more specific type). + +Usually we kind-infer and expand type splices, and then +tupecheck/desugar the type. That doesn't work well for scoped type +variables, because they scope left-right in patterns. (e.g. in the +example above, the 'a' in (y::a) is bound by the 'a' in (x::a). + +The current not-very-good plan is to + * find all the types in the patterns + * find their free tyvars + * do kind inference + * bring the kinded type vars into scope + * BUT throw away the kind-checked type + (we'll kind-check it again when we type-check the pattern) + +This is bad because throwing away the kind checked type throws away +its splices. But too bad for now. [July 03] + +Historical note: + We no longer specify that these type variables must be univerally + quantified (lots of email on the subject). If you want to put that + back in, you need to + a) Do a checkSigTyVars after thing_inside + b) More insidiously, don't pass in expected_ty, else + we unify with it too early and checkSigTyVars barfs + Instead you have to pass in a fresh ty var, and unify + it with expected_ty afterwards +-} + +tcHsPatSigType :: UserTypeCtxt + -> HsWithBndrs Name (LHsType Name) -- The type signature + -> TcM ( Type -- The signature + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , [(Name, TcTyVar)] ) -- The wildcards +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) result signatures e.g. g x :: Int = e +-- (c) RULE forall bndrs e.g. forall (x::Int). f x = x + +tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, + hswb_tvs = sig_tvs, hswb_wcs = sig_wcs }) + = addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $ + do { kvs <- mapM new_kv sig_kvs + ; tvs <- mapM new_tv sig_tvs + ; nwc_tvs <- mapM newWildcardVarMetaKind sig_wcs + ; let nwc_binds = sig_wcs `zip` nwc_tvs + ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) + ; sig_ty <- tcExtendTyVarEnv2 (ktv_binds ++ nwc_binds) $ + tcHsLiftedType hs_ty + ; sig_ty <- zonkSigType sig_ty + ; checkValidType ctxt sig_ty + ; emitWildcardHoleConstraints (zip sig_wcs nwc_tvs) + ; return (sig_ty, ktv_binds, nwc_binds) } + where + new_kv name = new_tkv name superKind + new_tv name = do { kind <- newMetaKindVar + ; new_tkv name kind } + + new_tkv name kind -- See Note [Pattern signature binders] + = case ctxt of + RuleSigCtxt {} -> return (mkTcTyVar name kind (SkolemTv False)) + _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] + +tcPatSig :: Bool -- True <=> pattern binding + -> HsWithBndrs Name (LHsType Name) + -> TcSigmaType + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name, TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + [(Name, TcTyVar)], -- The wildcards + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty +tcPatSig in_pat_bind sig res_ty + = do { (sig_ty, sig_tvs, sig_nwcs) <- tcHsPatSigType PatSigCtxt sig + -- sig_tvs are the type variables free in 'sig', + -- and not already in scope. These are the ones + -- that should be brought into scope + + ; if null sig_tvs then do { + -- Just do the subsumption check and return + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubType_NC PatSigCtxt res_ty sig_ty + ; return (sig_ty, [], sig_nwcs, wrap) + } else do + -- Type signature binds at least one scoped type variable + + -- A pattern binding cannot bind scoped type variables + -- It is more convenient to make the test here + -- than in the renamer + { when in_pat_bind (addErr (patBindSigErr sig_tvs)) + + -- Check that all newly-in-scope tyvars are in fact + -- constrained by the pattern. This catches tiresome + -- cases like + -- type T a = Int + -- f :: Int -> Int + -- f (x :: T a) = ... + -- Here 'a' doesn't get a binding. Sigh + ; let bad_tvs = [ tv | (_, tv) <- sig_tvs + , not (tv `elemVarSet` exactTyVarsOfType sig_ty) ] + ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) + + -- Now do a subsumption check of the pattern signature against res_ty + ; wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubType_NC PatSigCtxt res_ty sig_ty + + -- Phew! + ; return (sig_ty, sig_tvs, sig_nwcs, wrap) + } } + where + mk_msg sig_ty tidy_env + = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty + ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty + ; let msg = vcat [ hang (ptext (sLit "When checking that the pattern signature:")) + 4 (ppr sig_ty) + , nest 2 (hang (ptext (sLit "fits the type of its context:")) + 2 (ppr res_ty)) ] + ; return (tidy_env, msg) } + +patBindSigErr :: [(Name, TcTyVar)] -> SDoc +patBindSigErr sig_tvs + = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + <+> pprQuotedList (map fst sig_tvs)) + 2 (ptext (sLit "in a pattern binding signature")) + +{- +Note [Pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T a (a->Int) + f (T x (f :: a->Int) = blah) + +Here + * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that that it retains its identity, and + TcErrors.getSkolemInfo can thereby find the binding site for the skolem. + + * The type signature pattern (f :: a->Int) binds "a" -> a_sig in the envt + + * Then unificaiton makes a_sig := a_sk + +That's why we must make a_sig a MetaTv (albeit a SigTv), +not a SkolemTv, so that it can unify to a_sk. + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. + +Note [Unifying SigTvs] +~~~~~~~~~~~~~~~~~~~~~~ +ALAS we have no decent way of avoiding two SigTvs getting unified. +Consider + f (x::(a,b)) (y::c)) = [fst x, y] +Here we'd really like to complain that 'a' and 'c' are unified. But +for the reasons above we can't make a,b,c into skolems, so they +are just SigTvs that can unify. And indeed, this would be ok, + f x (y::c) = case x of + (x1 :: a1, True) -> [x,y] + (x1 :: a2, False) -> [x,y,y] +Here the type of x's first component is called 'a1' in one branch and +'a2' in the other. We could try insisting on the same OccName, but +they definitely won't have the sane lexical Name. + +I think we could solve this by recording in a SigTv a list of all the +in-scope variables that it should not unify with, but it's fiddly. + + +************************************************************************ +* * + Checking kinds +* * +************************************************************************ + +We would like to get a decent error message from + (a) Under-applied type constructors + f :: (Maybe, Maybe) + (b) Over-applied type constructors + f :: Int x -> Int x +-} + +-- The ExpKind datatype means "expected kind" and contains +-- some info about just why that kind is expected, to improve +-- the error message on a mis-match +data ExpKind = EK TcKind (TcKind -> SDoc) + -- The second arg is function that takes a *tidied* version + -- of the first arg, and produces something like + -- "Expected kind k" + -- "Expected a constraint" + -- "The argument of Maybe should have kind k" + +instance Outputable ExpKind where + ppr (EK k f) = f k + +ekLifted, ekOpen, ekConstraint :: ExpKind +ekLifted = EK liftedTypeKind expectedKindMsg +ekOpen = EK openTypeKind expectedKindMsg +ekConstraint = EK constraintKind expectedKindMsg + +expectedKindMsg :: TcKind -> SDoc +expectedKindMsg pkind + | isConstraintKind pkind = ptext (sLit "Expected a constraint") + | isOpenTypeKind pkind = ptext (sLit "Expected a type") + | otherwise = ptext (sLit "Expected kind") <+> quotes (pprKind pkind) + +-- Build an ExpKind for arguments +expArgKind :: SDoc -> TcKind -> Int -> ExpKind +expArgKind exp kind arg_no = EK kind msg_fn + where + msg_fn pkind + = sep [ ptext (sLit "The") <+> speakNth arg_no + <+> ptext (sLit "argument of") <+> exp + , nest 2 $ ptext (sLit "should have kind") + <+> quotes (pprKind pkind) ] + +unifyKinds :: SDoc -> [(TcType, TcKind)] -> TcM TcKind +unifyKinds fun act_kinds + = do { kind <- newMetaKindVar + ; let check (arg_no, (ty, act_kind)) + = checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) + ; mapM_ check (zip [1..] act_kinds) + ; return kind } + +checkKind :: TcKind -> TcKind -> TcM () +checkKind act_kind exp_kind + = do { mb_subk <- unifyKindX act_kind exp_kind + ; case mb_subk of + Just EQ -> return () + _ -> unifyKindMisMatch act_kind exp_kind } + +checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () +-- A fancy wrapper for 'unifyKindX', which tries +-- to give decent error messages. +-- (checkExpectedKind ty act_kind exp_kind) +-- checks that the actual kind act_kind is compatible +-- with the expected kind exp_kind +-- The first argument, ty, is used only in the error message generation +checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) + = do { mb_subk <- unifyKindX act_kind exp_kind + + -- Kind unification only generates definite errors + ; case mb_subk of { + Just LT -> return () ; -- act_kind is a sub-kind of exp_kind + Just EQ -> return () ; -- The two are equal + _other -> do + + { -- So there's an error + -- Now to find out what sort + exp_kind <- zonkTcKind exp_kind + ; act_kind <- zonkTcKind act_kind + ; traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr exp_kind) + ; env0 <- tcInitTidyEnv + ; dflags <- getDynFlags + ; let (exp_as, _) = splitKindFunTys exp_kind + (act_as, _) = splitKindFunTys act_kind + n_exp_as = length exp_as + n_act_as = length act_as + n_diff_as = n_act_as - n_exp_as + + (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind + (env2, tidy_act_kind) = tidyOpenKind env1 act_kind + + occurs_check + | Just act_tv <- tcGetTyVar_maybe act_kind + = check_occ act_tv exp_kind + | Just exp_tv <- tcGetTyVar_maybe exp_kind + = check_occ exp_tv act_kind + | otherwise + = False + + check_occ tv k = case occurCheckExpand dflags tv k of + OC_Occurs -> True + _bad -> False + + err | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind + = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is unlifted") + + | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind + = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is lifted") + + | occurs_check -- Must precede the "more args expected" check + = ptext (sLit "Kind occurs check") $$ more_info + + | n_exp_as < n_act_as -- E.g. [Maybe] + = vcat [ ptext (sLit "Expecting") <+> + speakN n_diff_as <+> ptext (sLit "more argument") + <> (if n_diff_as > 1 then char 's' else empty) + <+> ptext (sLit "to") <+> quotes (ppr ty) + , more_info ] + + -- Now n_exp_as >= n_act_as. In the next two cases, + -- n_exp_as == 0, and hence so is n_act_as + | otherwise -- E.g. Monad [Int] + = more_info + + more_info = sep [ ek_ctxt tidy_exp_kind <> comma + , nest 2 $ ptext (sLit "but") <+> quotes (ppr ty) + <+> ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] + + ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2) + ; failWithTcM (env2, err) } } } + +{- +************************************************************************ +* * + Sort checking kinds +* * +************************************************************************ + +tcLHsKind converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +It fails when the kinds are not well-formed (eg. data A :: * Int), or if there +are non-promotable or non-fully applied kinds. +-} + +tcLHsKind :: LHsKind Name -> TcM Kind +tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + tc_lhs_kind k + +tc_lhs_kind :: LHsKind Name -> TcM Kind +tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) + +-- The main worker +tc_hs_kind :: HsKind Name -> TcM Kind +tc_hs_kind (HsTyVar tc) = tc_kind_var_app tc [] +tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] + +tc_hs_kind (HsParTy ki) = tc_lhs_kind ki + +tc_hs_kind (HsFunTy ki1 ki2) = + do kappa_ki1 <- tc_lhs_kind ki1 + kappa_ki2 <- tc_lhs_kind ki2 + return (mkArrowKind kappa_ki1 kappa_ki2) + +tc_hs_kind (HsListTy ki) = + do kappa <- tc_lhs_kind ki + checkWiredInTyCon listTyCon + return $ mkPromotedListTy kappa + +tc_hs_kind (HsTupleTy _ kis) = + do kappas <- mapM tc_lhs_kind kis + checkWiredInTyCon tycon + return $ mkTyConApp tycon kappas + where + tycon = promotedTupleTyCon BoxedTuple (length kis) + +-- Argument not kind-shaped +tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k) + +-- Special case for kind application +tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) +tc_kind_app (HsTyVar tc) kis = do { arg_kis <- mapM tc_lhs_kind kis + ; tc_kind_var_app tc arg_kis } +tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> + ptext (sLit "is not a kind constructor")) + +tc_kind_var_app :: Name -> [Kind] -> TcM Kind +-- Special case for * and Constraint kinds +-- They are kinds already, so we don't need to promote them +tc_kind_var_app name arg_kis + | name == liftedTypeKindTyConName + || name == constraintKindTyConName + = do { unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + ; thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "tc_kind_var_app 1" } + +-- General case +tc_kind_var_app name arg_kis + = do { thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) + -> do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds $ addErr (dataKindsErr name) + ; case promotableTyCon_maybe tc of + Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc + -> return (mkTyConApp prom_tc arg_kis) + Just _ -> tycon_err tc "is not fully applied" + Nothing -> tycon_err tc "is not promotable" } + + -- A lexically scoped kind variable + ATyVar _ kind_var + | not (isKindVar kind_var) + -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr kind_var) + <+> ptext (sLit "used as a kind")) + | not (null arg_kis) -- Kind variables always have kind BOX, + -- so cannot be applied to anything + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name) + <+> ptext (sLit "cannot appear in a function position")) + | otherwise + -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) + + -- It is in scope, but not what we expected + AThing _ + | isTyVarName name + -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr name) + <+> ptext (sLit "used in a kind")) + | otherwise + -> failWithTc (hang (ptext (sLit "Type constructor") <+> quotes (ppr name) + <+> ptext (sLit "used in a kind")) + 2 (ptext (sLit "inside its own recursive group"))) + + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr "promoted type" thing name + -- This really should not happen + } + where + tycon_err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") + <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) + +dataKindsErr :: Name -> SDoc +dataKindsErr name + = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr name)) + 2 (ptext (sLit "Perhaps you intended to use DataKinds")) + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> ptext (sLit "cannot be used here")) + 2 (parens reason)) + where + reason = case err of + FamDataConPE -> ptext (sLit "it comes from a data family instance") + NoDataKinds -> ptext (sLit "Perhaps you intended to use DataKinds") + _ -> ptext (sLit "it is defined and used in the same recursive group") + +{- +************************************************************************ +* * + Scoped type variables +* * +************************************************************************ +-} + +badPatSigTvs :: TcType -> [TyVar] -> SDoc +badPatSigTvs sig_ty bad_tvs + = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, + quotes (pprWithCommas ppr bad_tvs), + ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty), + ptext (sLit "but are actually discarded by a type synonym") ] + , ptext (sLit "To fix this, expand the type synonym") + , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] + +unifyKindMisMatch :: TcKind -> TcKind -> TcM a +unifyKindMisMatch ki1 ki2 = do + ki1' <- zonkTcKind ki1 + ki2' <- zonkTcKind ki2 + let msg = hang (ptext (sLit "Couldn't match kind")) + 2 (sep [quotes (ppr ki1'), + ptext (sLit "against"), + quotes (ppr ki2')]) + failWithTc msg diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs new file mode 100644 index 00000000..5a4a91af --- /dev/null +++ b/compiler/typecheck/TcInstDcls.hs @@ -0,0 +1,1531 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +TcInstDecls: Typechecking instance declarations +-} + +{-# LANGUAGE CPP #-} + +module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where + +#include "HsVersions.h" + +import HsSyn +import TcBinds +import TcTyClsDecls +import TcClassDcl( tcClassDecl2, + HsSigFun, lookupHsSig, mkHsSigFun, + findMethodBind, instantiateMethod, tcInstanceMethodBody ) +import TcPat ( addInlinePrags ) +import TcRnMonad +import TcValidity +import TcMType +import TcType +import BuildTyCl +import Inst +import InstEnv +import FamInst +import FamInstEnv +import TcDeriv +import TcEnv +import TcHsType +import TcUnify +import Coercion ( pprCoAxiom ) +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) +import Type +import TcEvidence +import TyCon +import CoAxiom +import DataCon +import Class +import Var +import VarEnv +import VarSet +import PrelNames ( typeableClassName, genericClassNames ) +import Bag +import BasicTypes +import DynFlags +import ErrUtils +import FastString +import HscTypes ( isHsBootOrSig ) +import Id +import MkId +import Name +import NameSet +import Outputable +import SrcLoc +import Util +import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) + +import Control.Monad +import Maybes ( isNothing, isJust, whenIsJust ) +import Data.List ( mapAccumL, partition ) + +{- +Typechecking instance declarations is done in two passes. The first +pass, made by @tcInstDecls1@, collects information to be used in the +second pass. + +This pre-processed info includes the as-yet-unprocessed bindings +inside the instance declaration. These are type-checked in the second +pass, when the class-instance envs and GVE contain all the info from +all the instance and value decls. Indeed that's the reason we need +two passes over the instance decls. + + +Note [How instance declarations are translated] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is how we translation instance declarations into Core + +Running example: + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = +===> + -- Method selectors + op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b + op1 = ... + op2 = ... + + -- Default methods get the 'self' dictionary as argument + -- so they can call other methods at the same type + -- Default methods get the same type as their method selector + $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b + $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). + -- NB: type variables 'a' and 'b' are *both* in scope in + -- Note [Tricky type variable scoping] + + -- A top-level definition for each instance method + -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma + {-# INLINE [2] op1_i #-} -- From the instance decl bindings + op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + local_op1 = + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in + -- Note [Tricky type variable scoping] + + in local_op1 a d + + op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) + + -- The dictionary function itself + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions + df_i :: forall a. C a -> C [a] + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) + -- But see Note [Default methods in instances] + -- We can't apply the type checker to the default-method call + + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} + +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Note that df_i may be mutually recursive with both op1_i and op2_i. + It's crucial that df_i is not chosen as the loop breaker, even + though op1_i has a (user-specified) INLINE pragma. + +* Instead the idea is to inline df_i into op1_i, which may then select + methods from the MkC record, and thereby break the recursion with + df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at + the same type, it won't mention df_i, so there won't be recursion in + the first place.) + +* If op1_i is marked INLINE by the user there's a danger that we won't + inline df_i in it, and that in turn means that (since it'll be a + loop-breaker because df_i isn't), op1_i will ironically never be + inlined. But this is OK: the recursion breaking happens by way of + a RULE (the magic ClassOp rule above), and RULES work inside InlineRule + unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils + +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that + extracts the right piece iff its argument satisfies + exprIsConApp_maybe. This is done in MkId mkDictSelId + + * We make 'df' CONLIKE, so that shared uses still match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one element +of {superclasses + methods}), then we use a different strategy. + + class C a where op :: a -> a + instance C a => C [a] where op = + +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + MkC :: forall a. (a->a) -> C a + MkC = /\a.\op. op |> (sym Co:C a) + +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . + +Instead, we simply rely on the fact that casts are cheap: + + $df :: forall a. C a => C [a] + {-# INLINE df #-} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) + + $cop_list :: forall a. C a => [a] -> [a] + $cop_list = + +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. + +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +Trac #4138 for an example (although the regression reported there +wasn't due to the indirection). + +There is an awkward wrinkle though: we want to be very +careful when we have + instance C a => C [a] where + {-# INLINE op #-} + op = ... +then we'll get an INLINE pragma on $cop_list but it's important that +$cop_list only inlines when it's applied to *two* arguments (the +dictionary and the list argument). So we must not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (Trac #3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... + + class DeepSeq a where + deepSeq :: a -> b -> b + + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. + +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + instance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be executing this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +call 'nullFail' just like the example above. The DoCon package also +does the same thing; it shows up in module Fraction.hs. + +Conclusion: when typechecking the methods in a C [a] instance, we want to +treat the 'a' as an *existential* type variable, in the sense described +by Note [Binding when looking up instances]. That is why isOverlappableTyVar +responds True to an InstSkol, which is the kind of skolem we use in +tcInstDecl2. + + +Note [Tricky type variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In our example + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = + + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = + +note that 'a' and 'b' are *both* in scope in , but only 'a' is +in scope in . In particular, we must make sure that 'b' is in +scope when typechecking . This is achieved by subFunTys, +which brings appropriate tyvars into scope. This happens for both + and for , but that doesn't matter: the *renamer* will have +complained if 'b' is mentioned in . + + + +************************************************************************ +* * +\subsection{Extracting instance decls} +* * +************************************************************************ + +Gather up the instance declarations from their various sources +-} + +tcInstDecls1 -- Deal with both source-code and imported instance decls + :: [LTyClDecl Name] -- For deriving stuff + -> [LInstDecl Name] -- Source code instance decls + -> [LDerivDecl Name] -- Source code stand-alone deriving decls + -> TcM (TcGblEnv, -- The full inst env + [InstInfo Name], -- Source-code instance decls to process; + -- contains all dfuns for this module + HsValBinds Name) -- Supporting bindings for derived instances + +tcInstDecls1 tycl_decls inst_decls deriv_decls + = checkNoErrs $ + do { -- Stop if addInstInfos etc discovers any errors + -- (they recover, so that we get more than one error each + -- round) + + -- Do class and family instance declarations + ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls + ; let (local_infos_s, fam_insts_s) = unzip stuff + fam_insts = concat fam_insts_s + local_infos' = concat local_infos_s + -- Handwritten instances of the poly-kinded Typeable class are + -- forbidden, so we handle those separately + (typeable_instances, local_infos) + = partition bad_typeable_instance local_infos' + + ; addClsInsts local_infos $ + addFamInsts fam_insts $ + do { -- Compute instances from "deriving" clauses; + -- This stuff computes a context for the derived instance + -- decl, so it needs to know about all the instances possible + -- NB: class instance declarations can contain derivings as + -- part of associated data type declarations + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, because that may give + -- more errors still + + ; traceTc "tcDeriving" Outputable.empty + ; th_stage <- getStage -- See Note [Deriving inside TH brackets ] + ; (gbl_env, deriv_inst_info, deriv_binds) + <- if isBrackStage th_stage + then do { gbl_env <- getGblEnv + ; return (gbl_env, emptyBag, emptyValBindsOut) } + else tcDeriving tycl_decls inst_decls deriv_decls + + -- Fail if there are any handwritten instance of poly-kinded Typeable + ; mapM_ typeable_err typeable_instances + + -- Check that if the module is compiled with -XSafe, there are no + -- hand written instances of old Typeable as then unsafe casts could be + -- performed. Derived instances are OK. + ; dflags <- getDynFlags + ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of + _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x) + _ -> return () + + -- As above but for Safe Inference mode. + ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of + _ | genInstCheck x -> recordUnsafeInfer + _ | overlapCheck x -> recordUnsafeInfer + _ -> return () + + ; return ( gbl_env + , bagToList deriv_inst_info ++ local_infos + , deriv_binds) + }} + where + -- Separate the Typeable instances from the rest + bad_typeable_instance i + = typeableClassName == is_cls_nm (iSpec i) + + + overlapCheck ty = case overlapMode (is_flag $ iSpec ty) of + NoOverlap _ -> False + _ -> True + genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames + genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) + + -- Report an error or a warning for a `Typeable` instances. + -- If we are workikng on an .hs-boot file, we just report a warning, + -- and ignore the instance. We do this, to give users a chance to fix + -- their code. + typeable_err i = + setSrcSpan (getSrcSpan (iSpec i)) $ + do env <- getGblEnv + if isHsBootOrSig (tcg_src env) + then + do warn <- woptM Opt_WarnDerivingTypeable + when warn $ addWarnTc $ vcat + [ ptext (sLit "`Typeable` instances in .hs-boot files are ignored.") + , ptext (sLit "This warning will become an error in future versions of the compiler.") + ] + else addErrTc $ ptext (sLit "Class `Typeable` does not support user-specified instances.") + +addClsInsts :: [InstInfo Name] -> TcM a -> TcM a +addClsInsts infos thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside + +addFamInsts :: [FamInst] -> TcM a -> TcM a +-- Extend (a) the family instance envt +-- (b) the type envt with stuff from data type decls +addFamInsts fam_insts thing_inside + = tcExtendLocalFamInstEnv fam_insts $ + tcExtendGlobalEnv things $ + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; tcg_env <- tcAddImplicits things + ; setGblEnv tcg_env thing_inside } + where + axioms = map (toBranchedAxiom . famInstAxiom) fam_insts + tycons = famInstsRepTyCons fam_insts + things = map ATyCon tycons ++ map ACoAxiom axioms + +{- +Note [Deriving inside TH brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a declaration bracket + [d| data T = A | B deriving( Show ) |] + +there is really no point in generating the derived code for deriving( +Show) and then type-checking it. This will happen at the call site +anyway, and the type check should never fail! Moreover (Trac #6005) +the scoping of the generated code inside the bracket does not seem to +work out. + +The easy solution is simply not to generate the derived instances at +all. (A less brutal solution would be to generate them with no +bindings.) This will become moot when we shift to the new TH plan, so +the brutal solution will do. +-} + +tcLocalInstDecl :: LInstDecl Name + -> TcM ([InstInfo Name], [FamInst]) + -- A source-file instance declaration + -- Type-check all the stuff before the "where" + -- + -- We check for respectable instance type, and context +tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) + = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl) + ; return ([], [fam_inst]) } + +tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) + = do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl) + ; return ([], [fam_inst]) } + +tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) + = do { (insts, fam_insts) <- tcClsInstDecl (L loc decl) + ; return (insts, fam_insts) } + +tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) +tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode + , cid_datafam_insts = adts })) + = setSrcSpan loc $ + addErrCtxt (instDeclCtxt1 poly_ty) $ + do { is_boot <- tcIsHsBootOrSig + ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) + badBootDeclErr + + ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty + ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + mb_info = Just (clas, mini_env) + + -- Next, process any associated types. + ; traceTc "tcLocalInstDecl" (ppr poly_ty) + ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $ + mapAndRecoverM (tcTyFamInstDecl mb_info) ats + ; datafam_insts <- tcExtendTyVarEnv tyvars $ + mapAndRecoverM (tcDataFamInstDecl mb_info) adts + + -- Check for missing associated types and build them + -- from their defaults (if available) + ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSet` + mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) + ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) + (classATItems clas) + + -- Finally, construct the Core representation of the instance. + -- (This no longer includes the associated types.) + ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) + -- Dfun location is that of instance *header* + + ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta + clas inst_tys + ; let inst_info = InstInfo { iSpec = ispec + , iBinds = InstBindings + { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings + , ib_pragmas = uprags + , ib_extensions = [] + , ib_derived = False } } + + ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } + + +tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instatiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTy subst' rhs_ty + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElemsKvsFirst tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) + +{- +************************************************************************ +* * + Type checking family instances +* * +************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). +-} + +tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable + -> Located Name -> TcM TyCon +tcFamInstDeclCombined mb_clsinfo fam_tc_lname + = do { -- Type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; traceTc "tcFamInstDecl" (ppr fam_tc_lname) + ; type_families <- xoptM Opt_TypeFamilies + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl fam_tc_lname + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Look up the family TyCon and check for validity including + -- check that toplevel type instances are not for associated types. + ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname + ; when (isNothing mb_clsinfo && -- Not in a class decl + isTyConAssoc fam_tc) -- but an associated type + (addErr $ assocInClassErr fam_tc_lname) + + ; return fam_tc } + +tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable + -> LTyFamInstDecl Name -> TcM FamInst + -- "type instance" +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) + = setSrcSpan loc $ + tcAddTyFamInstCtxt decl $ + do { let fam_lname = tfe_tycon (unLoc eqn) + ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname + + -- (0) Check it's an open type family + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym group + ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn + + -- (2) check for validity + ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch + + -- (3) construct coercion axiom + ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) + [co_ax_branch] + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } + +tcDataFamInstDecl :: Maybe (Class, VarEnv Type) + -> LDataFamInstDecl Name -> TcM FamInst + -- "newtype instance" and "data instance" +tcDataFamInstDecl mb_clsinfo + (L loc decl@(DataFamInstDecl + { dfid_pats = pats + , dfid_tycon = fam_tc_name + , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt, dd_cons = cons } })) + = setSrcSpan loc $ + tcAddDataFamInstCtxt decl $ + do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name + + -- Check that the family declaration is for the right kind + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) + + -- Kind check type patterns + ; tcFamTyPats (famTyConShape fam_tc) pats + (kcDataDefn defn) $ + \tvs' pats' res_kind -> do + + { -- Check that left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + checkValidFamPats fam_tc tvs' pats' + -- Check that type patterns match class instance head, if any + ; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats' + + -- Result kind must be '*' (otherwise, we have too few patterns) + ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) + + ; stupid_theta <- tcHsContext ctxt + ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons + + -- Construct representation tycon + ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' + ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc + ; let orig_res_ty = mkTyConApp fam_tc pats' + + ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) -> + do { data_cons <- tcConDecls new_or_data rec_rep_tc + (tvs', orig_res_ty) cons + ; tc_rhs <- case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + -- freshen tyvars + ; let (eta_tvs, eta_pats) = eta_reduce tvs' pats' + axiom = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats + (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) + parent = FamInstTyCon axiom fam_tc pats' + roles = map (const Nominal) tvs' + rep_tc = buildAlgTyCon rep_tc_name tvs' roles + (fmap unLoc cType) stupid_theta + tc_rhs + Recursive + False -- No promotable to the kind level + gadt_syntax parent + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom + ; return (rep_tc, fam_inst) } + + -- Remember to check validity; no recursion to worry about here + ; checkValidTyCon rep_tc + ; return fam_inst } } + where + -- See Note [Eta reduction for data family axioms] + -- [a,b,c,d].T [a] c Int c d ==> [a,b,c]. T [a] c Int c + eta_reduce tvs pats = go (reverse tvs) (reverse pats) + go (tv:tvs) (pat:pats) + | Just tv' <- getTyVar_maybe pat + , tv == tv' + , not (tv `elemVarSet` tyVarsOfTypes pats) + = go tvs pats + go tvs pats = (reverse tvs, reverse pats) + +{- +Note [Eta reduction for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. From the 'newtype instance' you might +think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The type-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +This eta reduction happens both for data instances and newtype instances. + +See Note [Newtype eta] in TyCon. + + + +************************************************************************ +* * + Type-checking instance declarations, pass 2 +* * +************************************************************************ +-} + +tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] + -> TcM (LHsBinds Id) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls + ; let dm_binds = unionManyBags dm_binds_s + + -- (b) instance declarations + ; let dm_ids = collectHsBindsBinders dm_binds + -- Add the default method Ids (again) + -- See Note [Default methods and instances] + ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $ + mapM tcInstDecl2 inst_decls + + -- Done + ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } + +{- +See Note [Default methods and instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method Ids are already in the type environment (see Note +[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they +don't have their InlinePragmas yet. Usually that would not matter, +because the simplifier propagates information from binding site to +use. But, unusually, when compiling instance decls we *copy* the +INLINE pragma from the default method to the method for that +particular operation (see Note [INLINE and default methods] below). + +So right here in tcInstDecls2 we must re-extend the type envt with +the default method Ids replete with their INLINE pragmas. Urk. +-} + +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) + -- Returns a binding for the dfun +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + do { -- Instantiate the instance decl with skolem constants + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] + ; let (clas, inst_tys) = tcSplitDFunHead inst_head + (class_tyvars, sc_theta, _, op_items) = classBigSig clas + sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta + + ; dfun_ev_vars <- newEvVars dfun_theta + + ; sc_ev_vars <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + + -- Typecheck the methods + ; (meth_ids, meth_binds) + <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars + inst_tys spec_inst_info + op_items ibinds + + -- Create the result bindings + ; self_dict <- newDict clas inst_tys + ; let class_tc = classTyCon clas + [dict_constr] = tyConDataCons class_tc + dict_bind = mkVarBind self_dict (L loc con_app_args) + + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = wrapId (mkWpTyApps inst_tys) + (dataConWrapId dict_constr) + con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys + con_app_args = foldl app_to_meth con_app_scs meth_ids + + app_to_meth :: HsExpr Id -> Id -> HsExpr Id + app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) + + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys + + -- Do not inline the dfun; instead give it a magic DFunFunfolding + dfun_spec_prags + | isNewTyCon class_tc = SpecPrags [] + -- Newtype dfuns just inline unconditionally, + -- so don't attempt to specialise them + | otherwise + = SpecPrags spec_inst_prags + + export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id + , abe_mono = self_dict, abe_prags = dfun_spec_prags } + -- NB: see Note [SPECIALISE instance pragmas] + main_bind = AbsBinds { abs_tvs = inst_tyvars + , abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = emptyTcEvBinds + , abs_binds = unitBag dict_bind } + + ; return (unitBag (L loc main_bind) `unionBags` + listToBag meth_binds) + } + where + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id + +------------------------------ +tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType + -> TcM [EvVar] +-- See Note [Silent superclass arguments] +tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta + | null inst_tyvars && null dfun_ev_vars + = emitWanteds ScOrigin sc_theta + + | otherwise + = do { -- Check that all superclasses can be deduced from + -- the originally-specified dfun arguments + ; _ <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ + emitWanteds ScOrigin sc_theta + + ; return (map (find dfun_ev_vars) sc_theta) } + where + n_silent = dfunNSilent dfun_id + orig_ev_vars = drop n_silent dfun_ev_vars + + find [] pred + = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred) + find (ev:evs) pred + | pred `eqPred` evVarPred ev = ev + | otherwise = find evs pred + +---------------------- +mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper) +mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ + -- Base the local_meth_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty + + ; case lookupHsSig sig_fn sel_name of + Just lhs_ty -- There is a signature in the instance declaration + -- See Note [Instance method signatures] + -> setSrcSpan (getLoc lhs_ty) $ + do { inst_sigs <- xoptM Opt_InstanceSigs + ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty) + ; sig_ty <- tcHsSigType (FunSigCtxt sel_name) lhs_ty + ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty + ; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $ + tcSubType (FunSigCtxt sel_name) poly_sig_ty poly_meth_ty + ; return (poly_meth_id, tc_sig, hs_wrap) } + + Nothing -- No type signature + -> do { tc_sig <- instTcTySigFromId local_meth_id + ; return (poly_meth_id, tc_sig, idHsWrapper) } } + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! + where + sel_name = idName sel_id + sel_occ = nameOccName sel_name + local_meth_ty = instantiateMethod clas sel_id inst_tys + poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty + theta = map idType dfun_ev_vars + +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt sel_name sig_ty meth_ty env0 + = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty + ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty + ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name)) + 2 (vcat [ ptext (sLit "is more general than its signature in the class") + , ptext (sLit "Instance sig:") <+> ppr sig_ty + , ptext (sLit " Class sig:") <+> ppr meth_ty ]) + ; return (env2, msg) } + +misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig name hs_ty + = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + , ptext (sLit "(Use InstanceSigs to allow this)") ] + +------------------------------ +tcSpecInstPrags :: DFunId -> InstBindings Name + -> TcM ([Located TcSpecPrag], PragFun) +tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; return (spec_inst_prags, mkPragFun uprags binds) } + +{- +Note [Instance method signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XInstanceSigs we allow the user to supply a signature for the +method in an instance declaration. Here is an artificial example: + + data Age = MkAge Int + instance Ord Age where + compare :: a -> a -> Bool + compare = error "You can't compare Ages" + +We achieve this by building a TcSigInfo for the method, whether or not +there is an instance method signature, and using that to typecheck +the declaration (in tcInstanceMethodBody). That means, conveniently, +that the type variables bound in the signature will scope over the body. + +What about the check that the instance method signature is more +polymorphic than the instantiated class method type? We just do a +tcSubType call in mkMethIds, and use the HsWrapper thus generated in +the method AbsBind. It's very like the tcSubType impedence-matching +call in mkExport. We have to pass the HsWrapper into +tcInstanceMethodBody. + + +Note [Silent superclass arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #3731, #4809, #5751, #5913, #6117, which all +describe somewhat more complicated situations, but ones +encountered in practice. + + THE PROBLEM + +The problem is that it is all too easy to create a class whose +superclass is bottom when it should not be. + +Consider the following (extreme) situation: + class C a => D a where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) +Although this looks wrong (assume D [a] to prove D [a]), it is only a +more extreme case of what happens with recursive dictionaries, and it +can, just about, make sense because the methods do some work before +recursing. + +To implement the dfunD we must generate code for the superclass C [a], +which we had better not get by superclass selection from the supplied +argument: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. + +Otherwise if we later encounter a situation where +we have a [Wanted] dw::D [a] we might solve it thus: + dw := dfunD dw +Which is all fine except that now ** the superclass C is bottom **! + +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + + THE SOLUTION + +Our solution to this problem "silent superclass arguments". We pass +to each dfun some ``silent superclass arguments’’, which are the +immediate superclasses of the dictionary we are trying to +construct. In our example: + dfun :: forall a. C [a] -> D [a] -> D [a] + dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... +Notice the extra (dc :: C [a]) argument compared to the previous version. + +This gives us: + + ----------------------------------------------------------- + DFun Superclass Invariant + ~~~~~~~~~~~~~~~~~~~~~~~~ + In the body of a DFun, every superclass argument to the + returned dictionary is + either * one of the arguments of the DFun, + or * constant, bound at top level + ----------------------------------------------------------- + +This net effect is that it is safe to treat a dfun application as +wrapping a dictionary constructor around its arguments (in particular, +a dfun never picks superclasses from the arguments under the +dictionary constructor). No superclass is hidden inside a dfun +application. + +The extra arguments required to satisfy the DFun Superclass Invariant +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. + +In our example, if we had [Wanted] dw :: D [a] we would get via the instance: + dw := dfun d1 d2 + [Wanted] (d1 :: C [a]) + [Wanted] (d2 :: D [a]) + +And now, though we *can* solve: + d2 := dw +That's fine; and we solve d1:C[a] separately. + +Test case SCLoop tests this fix. + +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: + + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = + +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + +Note that + + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See Trac #7797. + + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcInstanceMethods. +-} + +tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag +tcSpecInst dfun_id prag@(SpecInstSig _src hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty + ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys + + ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" + +{- +************************************************************************ +* * + Type-checking an instance method +* * +************************************************************************ + +tcInstanceMethod +- Make the method bindings, as a [(NonRec, HsBinds)], one per method +- Remembering to use fresh Name (the instance method Name) as the binder +- Bring the instance method Ids into scope, for the benefit of tcInstSig +- Use sig_fn mapping instance method Name -> instance tyvars +- Ditto prag_fn +- Use tcValBinds to do the checking +-} + +tcInstanceMethods :: DFunId -> Class -> [TcTyVar] + -> [EvVar] + -> [TcType] + -> ([Located TcSpecPrag], PragFun) + -> [(Id, DefMeth)] + -> InstBindings Name + -> TcM ([Id], [LHsBind Id]) + -- The returned inst_meth_ids all have types starting + -- forall tvs. theta => ... +tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys + (spec_inst_prags, prag_fn) + op_items (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs + , ib_pragmas = sigs + , ib_extensions = exts + , ib_derived = is_derived }) + = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $ + -- The lexical_tvs scope over the 'where' part + do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; let hs_sig_fn = mkHsSigFun sigs + ; checkMinimalDefinition + ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items } + where + set_exts :: [ExtensionFlag] -> TcM a -> TcM a + set_exts es thing = foldr setXOptM thing es + + ---------------------- + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) + tc_item sig_fn (sel_id, dm_info) + = case findMethodBind (idName sel_id) binds of + Just (user_bind, bndr_loc) + -> tc_body sig_fn sel_id user_bind bndr_loc + Nothing -> do { traceTc "tc_def" (ppr sel_id) + ; tc_default sig_fn sel_id dm_info } + + ---------------------- + tc_body :: HsSigFun -> Id -> LHsBind Name + -> SrcSpan -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id rn_bind bndr_loc + = add_meth_ctxt sel_id rn_bind $ + do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) + ; (meth_id, local_meth_sig, hs_wrap) + <- setSrcSpan bndr_loc $ + mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + ; let prags = prag_fn (idName sel_id) + ; meth_id1 <- addInlinePrags meth_id prags + ; spec_prags <- tcSpecPrags meth_id1 prags + ; bind <- tcInstanceMethodBody InstSkol + tyvars dfun_ev_vars + meth_id1 local_meth_sig hs_wrap + (mk_meth_spec_prags meth_id1 spec_prags) + rn_bind + ; return (meth_id1, bind) } + + ---------------------- + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) + + tc_default sig_fn sel_id (GenDefMeth dm_name) + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name + ; tc_body sig_fn sel_id meth_bind inst_loc } + + tc_default sig_fn sel_id NoDefMeth -- No default method at all + = do { traceTc "tc_def: warn" (ppr sel_id) + ; (meth_id, _, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + ; dflags <- getDynFlags + ; return (meth_id, + mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags)) } + where + error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) + error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc (HsLit (HsStringPrim "" + (unsafeMkByteString (error_string dflags)))) + meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) + error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ]) + lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars + + tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method + = do { -- Build the typechecked version directly, + -- without calling typecheck_method; + -- see Note [Default methods in instances] + -- Generate /\as.\ds. let self = df as ds + -- in $dm inst_tys self + -- The 'let' is necessary only because HsSyn doesn't allow + -- you to apply a function to a dictionary *expression*. + + ; self_dict <- newDict clas inst_tys + ; let self_ev_bind = EvBind self_dict + (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) + + ; (meth_id, local_meth_sig, hs_wrap) + <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + ; dm_id <- tcLookupId dm_name + ; let dm_inline_prag = idInlinePragma dm_id + rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ + HsVar dm_id + + local_meth_id = sig_id local_meth_sig + meth_bind = mkVarBind local_meth_id (L inst_loc rhs) + meth_id1 = meth_id `setInlinePragma` dm_inline_prag + -- Copy the inline pragma (if any) from the default + -- method to this version. Note [INLINE and default methods] + + + export = ABE { abe_wrap = hs_wrap, abe_poly = meth_id1 + , abe_mono = local_meth_id + , abe_prags = mk_meth_spec_prags meth_id1 [] } + bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars + , abs_exports = [export] + , abs_ev_binds = EvBinds (unitBag self_ev_bind) + , abs_binds = unitBag meth_bind } + -- Default methods in an instance declaration can't have their own + -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but + -- currently they are rejected with + -- "INLINE pragma lacks an accompanying binding" + + ; return (meth_id1, L inst_loc bind) } + + ---------------------- + mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id + -- There are two sources: + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. + mk_meth_spec_prags meth_id spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] + + inst_loc = getSrcSpan dfun_id + + -- For instance decls that come from deriving clauses + -- we want to print out the full source code if there's an error + -- because otherwise the user won't see the code at all + add_meth_ctxt sel_id rn_bind thing + | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing + | otherwise = thing + + ---------------------- + + -- check if one of the minimal complete definitions is satisfied + checkMinimalDefinition + = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + warnUnsatisifiedMinimalDefinition + where + methodExists meth = isJust (findMethodBind meth binds) + +mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) +mkGenericDefMethBind clas inst_tys sel_id dm_name + = -- A generic default method + -- If the method is defined generically, we only have to call the + -- dm_name. + do { dflags <- getDynFlags + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + (vcat [ppr clas <+> ppr inst_tys, + nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) + + ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id)) + [mkSimpleMatch [] rhs]) } + where + rhs = nlHsVar dm_name + +---------------------- +wrapId :: HsWrapper -> id -> HsExpr id +wrapId wrapper id = mkHsWrap wrapper (HsVar id) + +derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc +derivBindCtxt sel_id clas tys _bind + = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id) + , nest 2 (ptext (sLit "in a derived instance for") + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] + +warnMissingMethodOrAT :: String -> Name -> TcM () +warnMissingMethodOrAT what name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name)))) + ; warnTc (warn -- Warn only if -fwarn-missing-methods + && not (startsWithUnderscore (getOccName name))) + -- Don't warn about _foo methods + (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for") + <+> quotes (ppr name)) } + +warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM () +warnUnsatisifiedMinimalDefinition mindef + = do { warn <- woptM Opt_WarnMissingMethods + ; warnTc warn message + } + where + message = vcat [ptext (sLit "No explicit implementation for") + ,nest 2 $ pprBooleanFormulaNice mindef + ] + +{- +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + +Note [Default methods in instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + class Baz v x where + foo :: x -> x + foo y = + + instance Baz Int Int + +From the class decl we get + + $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = + +Notice that the type is ambiguous. That's fine, though. The instance +decl generates + + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo Int Int $dBazIntInt + +BUT this does mean we must generate the dictionary translation of +fooIntInt directly, rather than generating source-code and +type-checking it. That was the bug in Trac #1061. In any case it's +less work to generate the translated version! + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Default methods need special case. They are supposed to behave rather like +macros. For exmample + + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + -- op1 via default method + op2 b x = + +The instance declaration should behave + + just as if 'op1' had been defined with the + code, and INLINE pragma, from its original + definition. + +That is, just as if you'd written + + instance Foo Int where + op2 b x = + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + +So for the above example we generate: + + {-# INLINE $dmop1 #-} + -- $dmop1 has an InlineCompulsory unfolding + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = $dmop1 $fFooInt + + $cop2 = + +Note carefully: + +* We *copy* any INLINE pragma from the default method $dmop1 to the + instance $cop1. Otherwise we'll just inline the former in the + latter and stop, which isn't what the user expected + +* Regardless of its pragma, we give the default method an + unfolding with an InlineCompulsory source. That means + that it'll be inlined at every use site, notably in + each instance declaration, such as $cop1. This inlining + must happen even though + a) $dmop1 is not saturated in $cop1 + b) $cop1 itself has an INLINE pragma + + It's vital that $dmop1 *is* inlined in this way, to allow the mutual + recursion between $fooInt and $cop1 to be broken + +* To communicate the need for an InlineCompulsory to the desugarer + (which makes the Unfoldings), we use the IsDefaultMethod constructor + in TcSpecPrags. + + +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +instDeclCtxt1 :: LHsType Name -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (case unLoc hs_inst_ty of + HsForAllTy _ _ _ _ (L _ ty') -> ppr ty' + _ -> ppr hs_inst_ty) -- Don't expect this +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = inst_decl_ctxt (ppr (mkClassPred cls tys)) + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for")) + 2 (quotes doc) + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + +tooFewParmsErr :: Arity -> SDoc +tooFewParmsErr arity + = ptext (sLit "Family instance has too few parameters; expected") <+> + ppr arity + +assocInClassErr :: Located Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + +badFamInstDecl :: Located Name -> SDoc +badFamInstDecl tc_name + = vcat [ ptext (sLit "Illegal family instance for") <+> + quotes (ppr tc_name) + , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs new file mode 100644 index 00000000..3adfd793 --- /dev/null +++ b/compiler/typecheck/TcInteract.hs @@ -0,0 +1,2249 @@ +{-# LANGUAGE CPP #-} + +module TcInteract ( + solveSimpleGivens, -- Solves [EvVar],GivenLoc + solveSimpleWanteds -- Solves Cts + ) where + +#include "HsVersions.h" + +import BasicTypes () +import HsTypes ( hsIPNameFS ) +import FastString +import TcCanonical +import TcFlatten +import VarSet +import Type +import Kind (isKind, isConstraintKind ) +import Unify +import InstEnv( lookupInstEnv, instanceDFunId ) +import CoAxiom(sfInteractTop, sfInteractInert) + +import Var +import TcType +import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey + , typeableClassName, callStackTyConKey ) +import Id( idType ) +import Class +import TyCon +import FunDeps +import FamInst +import Inst( tyVarsOfCt ) + +import TcEvidence +import Outputable + +import TcRnTypes +import TcErrors +import TcSMonad +import Bag + +import Data.List( partition, foldl', deleteFirstsBy ) + +import VarEnv + +import Control.Monad +import Pair (Pair(..)) +import Unique( hasKey ) +import DynFlags +import Util + +{- +********************************************************************** +* * +* Main Interaction Solver * +* * +********************************************************************** + +Note [Basic Simplifier Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Pick an element from the WorkList if there exists one with depth + less than our context-stack depth. + +2. Run it down the 'stage' pipeline. Stages are: + - canonicalization + - inert reactions + - spontaneous reactions + - top-level intreactions + Each stage returns a StopOrContinue and may have sideffected + the inerts or worklist. + + The threading of the stages is as follows: + - If (Stop) is returned by a stage then we start again from Step 1. + - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to + the next stage in the pipeline. +4. If the element has survived (i.e. ContinueWith x) the last stage + then we add him in the inerts and jump back to Step 1. + +If in Step 1 no such element exists, we have exceeded our context-stack +depth and will simply fail. + +Note [Unflatten after solving the simple wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We unflatten after solving the wc_simples of an implication, and before attempting +to float. This means that + + * The fsk/fmv flatten-skolems only survive during solveSimples. We don't + need to worry about then across successive passes over the constraint tree. + (E.g. we don't need the old ic_fsk field of an implication. + + * When floating an equality outwards, we don't need to worry about floating its + associated flattening constraints. + + * Another tricky case becomes easy: Trac #4935 + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + + Obviously this is soluble with gamma := F c a b, and unflattening + will do exactly that after solving the simple constraints and before + attempting the implications. Before, when we were not unflattening, + we had to push Wanted funeqs in as new givens. Yuk! + + Another example that becomes easy: indexed_types/should_fail/T7786 + [W] BuriedUnder sub k Empty ~ fsk + [W] Intersect fsk inv ~ s + [w] xxx[1] ~ s + [W] forall[2] . (xxx[1] ~ Empty) + => Intersect (BuriedUnder sub k Empty) inv ~ Empty + +Note [Running plugins on unflattened wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There is an annoying mismatch between solveSimpleGivens and +solveSimpleWanteds, because the latter needs to fiddle with the inert +set, unflatten and and zonk the wanteds. It passes the zonked wanteds +to runTcPluginsWanteds, which produces a replacement set of wanteds, +some additional insolubles and a flag indicating whether to go round +the loop again. If so, prepareInertsForImplications is used to remove +the previous wanteds (which will still be in the inert set). Note +that prepareInertsForImplications will discard the insolubles, so we +must keep track of them separately. +-} + +solveSimpleGivens :: CtLoc -> [EvVar] -> TcS () +solveSimpleGivens loc givens + | null givens -- Shortcut for common case + = return () + | otherwise + = go (map mk_given_ct givens) + where + mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evtm = EvId ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc }) + go givens = do { solveSimples (listToBag givens) + ; new_givens <- runTcPluginsGiven + ; when (notNull new_givens) (go new_givens) + } + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +solveSimpleWanteds = go emptyBag + where + go insols0 wanteds + = do { solveSimples wanteds + ; (implics, tv_eqs, fun_eqs, insols, others) <- getUnsolvedInerts + ; unflattened_eqs <- unflatten tv_eqs fun_eqs + -- See Note [Unflatten after solving the simple wanteds] + + ; zonked <- zonkSimples (others `andCts` unflattened_eqs) + -- Postcondition is that the wl_simples are zonked + + ; (wanteds', insols', rerun) <- runTcPluginsWanted zonked + -- See Note [Running plugins on unflattened wanteds] + ; let all_insols = insols0 `unionBags` insols `unionBags` insols' + ; if rerun then do { updInertTcS prepareInertsForImplications + ; go all_insols wanteds' } + else return (WC { wc_simple = wanteds' + , wc_insol = all_insols + , wc_impl = implics }) } + + +-- The main solver loop implements Note [Basic Simplifier Plan] +--------------------------------------------------------------- +solveSimples :: Cts -> TcS () +-- Returns the final InertSet in TcS +-- Has no effect on work-list or residual-iplications +-- The constraints are initially examined in left-to-right order + +solveSimples cts + = {-# SCC "solveSimples" #-} + do { dyn_flags <- getDynFlags + ; updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts) + ; solve_loop (maxSubGoalDepth dyn_flags) } + where + solve_loop max_depth + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem max_depth + ; case sel of + NoWorkRemaining -- Done, successfuly (modulo frozen) + -> return () + MaxDepthExceeded cnt ct -- Failure, depth exceeded + -> wrapErrTcS $ solverDepthErrorTcS cnt (ctEvidence ct) + NextWorkItem ct -- More work, loop around! + -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } } + + +-- | Extract the (inert) givens and invoke the plugins on them. +-- Remove solved givens from the inert set and emit insolubles, but +-- return new work produced so that 'solveSimpleGivens' can feed it back +-- into the main solver. +runTcPluginsGiven :: TcS [Ct] +runTcPluginsGiven = do + (givens,_,_) <- fmap splitInertCans getInertCans + if null givens + then return [] + else do + p <- runTcPlugins (givens,[],[]) + let (solved_givens, _, _) = pluginSolvedCts p + updInertCans (removeInertCts solved_givens) + mapM_ emitInsoluble (pluginBadCts p) + return (pluginNewCts p) + +-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on +-- them and produce an updated bag of wanteds (possibly with some new +-- work) and a bag of insolubles. The boolean indicates whether +-- 'solveSimpleWanteds' should feed the updated wanteds back into the +-- main solver. +runTcPluginsWanted :: Cts -> TcS (Cts, Cts, Bool) +runTcPluginsWanted zonked_wanteds + | isEmptyBag zonked_wanteds = return (zonked_wanteds, emptyBag, False) + | otherwise = do + (given,derived,_) <- fmap splitInertCans getInertCans + p <- runTcPlugins (given, derived, bagToList zonked_wanteds) + let (solved_givens, solved_deriveds, solved_wanteds) = pluginSolvedCts p + (_, _, wanteds) = pluginInputCts p + updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) + mapM_ setEv solved_wanteds + return ( listToBag $ pluginNewCts p ++ wanteds + , listToBag $ pluginBadCts p + , notNull (pluginNewCts p) ) + where + setEv :: (EvTerm,Ct) -> TcS () + setEv (ev,ct) = case ctEvidence ct of + CtWanted {ctev_evar = evar} -> setEvBind evar ev + _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" + +-- | A triple of (given, derived, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct], [Ct]) + +-- | A solved triple of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) + +-- | Represents collections of constraints generated by typechecker +-- plugins +data TcPluginProgress = TcPluginProgress + { pluginInputCts :: SplitCts + -- ^ Original inputs to the plugins with solved/bad constraints + -- removed, but otherwise unmodified + , pluginSolvedCts :: SolvedCts + -- ^ Constraints solved by plugins + , pluginBadCts :: [Ct] + -- ^ Constraints reported as insoluble by plugins + , pluginNewCts :: [Ct] + -- ^ New constraints emitted by plugins + } + +-- | Starting from a triple of (given, derived, wanted) constraints, +-- invoke each of the typechecker plugins in turn and return +-- +-- * the remaining unmodified constraints, +-- * constraints that have been solved, +-- * constraints that are insoluble, and +-- * new work. +-- +-- Note that new work generated by one plugin will not be seen by +-- other plugins on this pass (but the main constraint solver will be +-- re-invoked and they will see it later). There is no check that new +-- work differs from the original constraints supplied to the plugin: +-- the plugin itself should perform this check if necessary. +runTcPlugins :: SplitCts -> TcS TcPluginProgress +runTcPlugins all_cts = do + gblEnv <- getGblEnv + foldM do_plugin initialProgress (tcg_tc_plugins gblEnv) + where + do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin p solver = do + result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress + progress p (TcPluginContradiction bad_cts) = + p { pluginInputCts = discard bad_cts (pluginInputCts p) + , pluginBadCts = bad_cts ++ pluginBadCts p + } + progress p (TcPluginOk solved_cts new_cts) = + p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + } + + initialProgress = TcPluginProgress all_cts ([], [], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys, zs) = + (xs `without` cts, ys `without` cts, zs `without` cts) + + without :: [Ct] -> [Ct] -> [Ct] + without = deleteFirstsBy eqCt + + eqCt :: Ct -> Ct -> Bool + eqCt c c' = case (ctEvidence c, ctEvidence c') of + (CtGiven pred _ _, CtGiven pred' _ _) -> pred `eqType` pred' + (CtWanted pred _ _, CtWanted pred' _ _) -> pred `eqType` pred' + (CtDerived pred _ , CtDerived pred' _ ) -> pred `eqType` pred' + (_ , _ ) -> False + + add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts + add xs scs = foldl' addOne scs xs + + addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts + addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, deriveds, wanteds) + CtDerived{} -> (givens, ct:deriveds, wanteds) + CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) + + +type WorkItem = Ct +type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) + +data SelectWorkItem + = NoWorkRemaining -- No more work left (effectively we're done!) + | MaxDepthExceeded SubGoalCounter Ct + -- More work left to do but this constraint has exceeded + -- the maximum depth for one of the subgoal counters and we + -- must stop + | NextWorkItem Ct -- More work left, here's the next item to look at + +selectNextWorkItem :: SubGoalDepth -- Max depth allowed + -> TcS SelectWorkItem +selectNextWorkItem max_depth + = updWorkListTcS_return pick_next + where + pick_next :: WorkList -> (SelectWorkItem, WorkList) + pick_next wl + = case selectWorkItem wl of + (Nothing,_) + -> (NoWorkRemaining,wl) -- No more work + (Just ct, new_wl) + | Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (ctLoc ct)) -- Depth exceeded + -> (MaxDepthExceeded cnt ct,new_wl) + (Just ct, new_wl) + -> (NextWorkItem ct, new_wl) -- New workitem and worklist + +runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline + -> WorkItem -- The work item + -> TcS () +-- Run this item down the pipeline, leaving behind new work and inerts +runSolverPipeline pipeline workItem + = do { initial_is <- getTcSInerts + ; traceTcS "Start solver pipeline {" $ + vcat [ ptext (sLit "work item = ") <+> ppr workItem + , ptext (sLit "inerts = ") <+> ppr initial_is] + + ; bumpStepCountTcS -- One step for each constraint processed + ; final_res <- run_pipeline pipeline (ContinueWith workItem) + + ; final_is <- getTcSInerts + ; case final_res of + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline (discharged) }" + (ptext (sLit "inerts =") <+> ppr final_is) + ; return () } + ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert")) + ; traceTcS "End solver pipeline (not discharged) }" $ + vcat [ ptext (sLit "final_item =") <+> ppr ct + , pprTvBndrs (varSetElems $ tyVarsOfCt ct) + , ptext (sLit "inerts =") <+> ppr final_is] + ; insertInertItemTcS ct } + } + where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct + -> TcS (StopOrContinue Ct) + run_pipeline [] res = return res + run_pipeline _ (Stop ev s) = return (Stop ev s) + run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) + = do { traceTcS ("runStage " ++ stg_name ++ " {") + (text "workitem = " <+> ppr ct) + ; res <- stg ct + ; traceTcS ("end stage " ++ stg_name ++ " }") empty + ; run_pipeline stgs res } + +{- +Example 1: + Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) + Reagent: a ~ [b] (given) + +React with (c~d) ==> IR (ContinueWith (a~[b])) True [] +React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] +React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] + +Example 2: + Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} + Reagent: a ~w [b] + +React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] +React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) +etc. + +Example 3: + Inert: {a ~ Int, F Int ~ b} (given) + Reagent: F a ~ b (wanted) + +React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] +React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing +-} + +thePipeline :: [(String,SimplifierStage)] +thePipeline = [ ("canonicalization", TcCanonical.canonicalize) + , ("interact with inerts", interactWithInertsStage) + , ("top-level reactions", topReactionsStage) ] + +{- +********************************************************************************* +* * + The interact-with-inert Stage +* * +********************************************************************************* + +Note [The Solver Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We always add Givens first. So you might think that the solver has +the invariant + + If the work-item is Given, + then the inert item must Given + +But this isn't quite true. Suppose we have, + c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int +After processing the first two, we get + c1: [G] beta ~ [alpha], c2 : [W] blah +Now, c3 does not interact with the the given c1, so when we spontaneously +solve c3, we must re-react it with the inert set. So we can attempt a +reaction between inert c2 [W] and work-item c3 [G]. + +It *is* true that [Solver Invariant] + If the work-item is Given, + AND there is a reaction + then the inert item must Given +or, equivalently, + If the work-item is Given, + and the inert item is Wanted/Derived + then there is no reaction +-} + +-- Interaction result of WorkItem <~> Ct + +type StopNowFlag = Bool -- True <=> stop after this interaction + +interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) +-- Precondition: if the workitem is a CTyEqCan then it will not be able to +-- react with anything at this stage. + +interactWithInertsStage wi + = do { inerts <- getTcSInerts + ; let ics = inert_cans inerts + ; case wi of + CTyEqCan {} -> interactTyVarEq ics wi + CFunEqCan {} -> interactFunEq ics wi + CIrredEvCan {} -> interactIrred ics wi + CDictCan {} -> interactDict ics wi + _ -> pprPanic "interactWithInerts" (ppr wi) } + -- CHoleCan are put straight into inert_frozen, so never get here + -- CNonCanonical have been canonicalised + +data InteractResult = IRKeep | IRReplace | IRDelete +instance Outputable InteractResult where + ppr IRKeep = ptext (sLit "keep") + ppr IRReplace = ptext (sLit "replace") + ppr IRDelete = ptext (sLit "delete") + +solveOneFromTheOther :: CtEvidence -- Inert + -> CtEvidence -- WorkItem + -> TcS (InteractResult, StopNowFlag) +-- Preconditions: +-- 1) inert and work item represent evidence for the /same/ predicate +-- 2) ip/class/irred evidence (no coercions) only +solveOneFromTheOther ev_i ev_w + | isDerived ev_w + = return (IRKeep, True) + + | isDerived ev_i -- The inert item is Derived, we can just throw it away, + -- The ev_w is inert wrt earlier inert-set items, + -- so it's safe to continue on from this point + = return (IRDelete, False) + + | CtWanted { ctev_evar = ev_id } <- ev_w + = do { setEvBind ev_id (ctEvTerm ev_i) + ; return (IRKeep, True) } + + | CtWanted { ctev_evar = ev_id } <- ev_i + = do { setEvBind ev_id (ctEvTerm ev_w) + ; return (IRReplace, True) } + + | otherwise -- If both are Given, we already have evidence; no need to duplicate + -- But the work item *overrides* the inert item (hence IRReplace) + -- See Note [Shadowing of Implicit Parameters] + = return (IRReplace, True) + +{- +********************************************************************************* +* * + interactIrred +* * +********************************************************************************* +-} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) + +interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) + | let pred = ctEvPred ev_w + (matching_irreds, others) = partitionBag (\ct -> ctPred ct `tcEqType` pred) + (inert_irreds inerts) + , (ct_i : rest) <- bagToList matching_irreds + , let ctev_i = ctEvidence ct_i + = ASSERT( null rest ) + do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w + ; case inert_effect of + IRKeep -> return () + IRDelete -> updInertIrreds (\_ -> others) + IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem) + -- These const upd's assume that solveOneFromTheOther + -- has no side effects on InertCans + ; if stop_now then + return (Stop ev_w (ptext (sLit "Irred equal") <+> parens (ppr inert_effect))) + ; else + continueWith workItem } + + | otherwise + = continueWith workItem + +interactIrred _ wi = pprPanic "interactIrred" (ppr wi) + +{- +********************************************************************************* +* * + interactDict +* * +********************************************************************************* +-} + +interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) +interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) + -- don't ever try to solve CallStack IPs directly from other dicts, + -- we always build new dicts instead. + -- See Note [Overview of implicit CallStacks] + | [_ip, ty] <- tys + , isWanted ev_w + , Just mkEvCs <- isCallStackIP (ctEvLoc ev_w) cls ty + = do let ev_cs = + case lookupInertDict inerts (ctEvLoc ev_w) cls tys of + Just ev | isGiven ev -> mkEvCs (ctEvTerm ev) + _ -> mkEvCs (EvCallStack EvCsEmpty) + + -- now we have ev_cs :: CallStack, but the evidence term should + -- be a dictionary, so we have to coerce ev_cs to a + -- dictionary for `IP ip CallStack` + let ip_ty = mkClassPred cls tys + let ev_tm = mkEvCast (EvCallStack ev_cs) (TcCoercion $ wrapIP ip_ty) + addSolvedDict ev_w cls tys + setEvBind (ctEvId ev_w) ev_tm + stopWith ev_w "Wanted CallStack IP" + + | Just ctev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + = do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w + ; case inert_effect of + IRKeep -> return () + IRDelete -> updInertDicts $ \ ds -> delDict ds cls tys + IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem + ; if stop_now then + return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect))) + else + continueWith workItem } + + | cls `hasKey` ipClassNameKey + , isGiven ev_w + = interactGivenIP inerts workItem + + | otherwise + = do { mapBagM_ (addFunDepWork workItem) (findDictsByClass (inert_dicts inerts) cls) + -- Standard thing: create derived fds and keep on going. Importantly we don't + -- throw workitem back in the worklist because this can cause loops (see #5236) + ; continueWith workItem } + +interactDict _ wi = pprPanic "interactDict" (ppr wi) + +interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- Work item is Given (?x:ty) +-- See Note [Shadowing of Implicit Parameters] +interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls + , cc_tyargs = tys@(ip_str:_) }) + = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } + ; stopWith ev "Given IP" } + where + dicts = inert_dicts inerts + ip_dicts = findDictsByClass dicts cls + other_ip_dicts = filterBag (not . is_this_ip) ip_dicts + filtered_dicts = addDictsByClass dicts cls other_ip_dicts + + -- Pick out any Given constraints for the same implicit parameter + is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) + = isGiven ev && ip_str `tcEqType` ip_str' + is_this_ip _ = False + +interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) + +addFunDepWork :: Ct -> Ct -> TcS () +addFunDepWork work_ct inert_ct + = do { let fd_eqns :: [Equation CtLoc] + fd_eqns = [ eqn { fd_loc = derived_loc } + | eqn <- improveFromAnother inert_pred work_pred ] + ; rewriteWithFunDeps fd_eqns + -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok + -- NB: We do create FDs for given to report insoluble equations that arise + -- from pairs of Givens, and also because of floating when we approximate + -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs + -- Also see Note [When improvement happens] + } + where + work_pred = ctPred work_ct + inert_pred = ctPred inert_ct + work_loc = ctLoc work_ct + inert_loc = ctLoc inert_ct + derived_loc = work_loc { ctl_origin = FunDepOrigin1 work_pred work_loc + inert_pred inert_loc } + +{- +Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we add a new +*given* implicit parameter to the inert set, it replaces any existing +givens for the same implicit parameter. + +This works for the normal cases but it has an odd side effect +in some pathological programs like this: + +-- This is accepted, the second parameter shadows +f1 :: (?x :: Int, ?x :: Char) => Char +f1 = ?x + +-- This is rejected, the second parameter shadows +f2 :: (?x :: Int, ?x :: Char) => Int +f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wnated constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constratits for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. + + +********************************************************************************* +* * + interactFunEq +* * +********************************************************************************* +-} + +interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- Try interacting the work item with the inert set +interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc + , cc_tyargs = args, cc_fsk = fsk }) + | Just (CFunEqCan { cc_ev = ev_i, cc_fsk = fsk_i }) <- matching_inerts + = if ev_i `canRewriteOrSame` ev + then -- Rewrite work-item using inert + do { traceTcS "reactFunEq (discharge work item):" $ + vcat [ text "workItem =" <+> ppr workItem + , text "inertItem=" <+> ppr ev_i ] + ; reactFunEq ev_i fsk_i ev fsk + ; stopWith ev "Inert rewrites work item" } + else -- Rewrite intert using work-item + do { traceTcS "reactFunEq (rewrite inert item):" $ + vcat [ text "workItem =" <+> ppr workItem + , text "inertItem=" <+> ppr ev_i ] + ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args workItem + -- Do the updInertFunEqs before the reactFunEq, so that + -- we don't kick out the inertItem as well as consuming it! + ; reactFunEq ev fsk ev_i fsk_i + ; stopWith ev "Work item rewrites inert" } + + | Just ops <- isBuiltInSynFamTyCon_maybe tc + = do { let matching_funeqs = findFunEqsByTyCon funeqs tc + ; let interact = sfInteractInert ops args (lookupFlattenTyVar eqs fsk) + do_one (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = iev }) + = mapM_ (unifyDerived (ctEvLoc iev) Nominal) + (interact iargs (lookupFlattenTyVar eqs ifsk)) + do_one ct = pprPanic "interactFunEq" (ppr ct) + ; mapM_ do_one matching_funeqs + ; traceTcS "builtInCandidates 1: " $ vcat [ ptext (sLit "Candidates:") <+> ppr matching_funeqs + , ptext (sLit "TvEqs:") <+> ppr eqs ] + ; return (ContinueWith workItem) } + + | otherwise + = return (ContinueWith workItem) + where + eqs = inert_eqs inerts + funeqs = inert_funeqs inerts + matching_inerts = findFunEqs funeqs tc args + +interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi) + +lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType +-- ^ Look up a flatten-tyvar in the inert nominal TyVarEqs; +-- this is used only when dealing with a CFunEqCan +lookupFlattenTyVar inert_eqs ftv + = case lookupVarEnv inert_eqs ftv of + Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _) -> rhs + _ -> mkTyVarTy ftv + +reactFunEq :: CtEvidence -> TcTyVar -- From this :: F tys ~ fsk1 + -> CtEvidence -> TcTyVar -- Solve this :: F tys ~ fsk2 + -> TcS () +reactFunEq from_this fsk1 (CtGiven { ctev_evtm = tm, ctev_loc = loc }) fsk2 + = do { let fsk_eq_co = mkTcSymCo (evTermCoercion tm) + `mkTcTransCo` ctEvCoercion from_this + -- :: fsk2 ~ fsk1 + fsk_eq_pred = mkTcEqPred (mkTyVarTy fsk2) (mkTyVarTy fsk1) + ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co) + ; emitWorkNC [new_ev] } + +reactFunEq from_this fuv1 (CtWanted { ctev_evar = evar }) fuv2 + = dischargeFmv evar fuv2 (ctEvCoercion from_this) (mkTyVarTy fuv1) + +reactFunEq _ _ solve_this@(CtDerived {}) _ + = pprPanic "reactFunEq" (ppr solve_this) + +{- +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + i) Will set g2 := g1 `cast` g3 + ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. + + +Note [Efficient Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are interacting two FunEqCans with the same LHS: + (inert) ci :: (F ty ~ xi_i) + (work) cw :: (F ty ~ xi_w) +We prefer to keep the inert (else we pass the work item on down +the pipeline, which is a bit silly). If we keep the inert, we +will (a) discharge 'cw' + (b) produce a new equality work-item (xi_w ~ xi_i) +Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): + new_work :: xi_w ~ xi_i + cw := ci ; sym new_work +Why? Consider the simplest case when xi1 is a type variable. If +we generate xi1~xi2, porcessing that constraint will kick out 'ci'. +If we generate xi2~xi1, there is less chance of that happening. +Of course it can and should still happen if xi1=a, xi1=Int, say. +But we want to avoid it happening needlessly. + +Similarly, if we *can't* keep the inert item (because inert is Wanted, +and work is Given, say), we prefer to orient the new equality (xi_i ~ +xi_w). + +Note [Carefully solve the right CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ---- OLD COMMENT, NOW NOT NEEDED + ---- because we now allow multiple + ---- wanted FunEqs with the same head +Consider the constraints + c1 :: F Int ~ a -- Arising from an application line 5 + c2 :: F Int ~ Bool -- Arising from an application line 10 +Suppose that 'a' is a unification variable, arising only from +flattening. So there is no error on line 5; it's just a flattening +variable. But there is (or might be) an error on line 10. + +Two ways to combine them, leaving either (Plan A) + c1 :: F Int ~ a -- Arising from an application line 5 + c3 :: a ~ Bool -- Arising from an application line 10 +or (Plan B) + c2 :: F Int ~ Bool -- Arising from an application line 10 + c4 :: a ~ Bool -- Arising from an application line 5 + +Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error +on the *totally innocent* line 5. An example is test SimpleFail16 +where the expected/actual message comes out backwards if we use +the wrong plan. + +The second is the right thing to do. Hence the isMetaTyVarTy +test when solving pairwise CFunEqCan. + + +********************************************************************************* +* * + interactTyVarEq +* * +********************************************************************************* +-} + +interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) +-- CTyEqCans are always consumed, so always returns Stop +interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv + , cc_rhs = rhs + , cc_ev = ev + , cc_eq_rel = eq_rel }) + | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } + <- findTyEqs inerts tv + , ev_i `canRewriteOrSame` ev + , rhs_i `tcEqType` rhs ] + = -- Inert: a ~ b + -- Work item: a ~ b + do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (ctEvTerm ev_i) + ; stopWith ev "Solved from inert" } + + | Just tv_rhs <- getTyVar_maybe rhs + , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } + <- findTyEqs inerts tv_rhs + , ev_i `canRewriteOrSame` ev + , rhs_i `tcEqType` mkTyVarTy tv ] + = -- Inert: a ~ b + -- Work item: b ~ a + do { when (isWanted ev) $ + setEvBind (ctev_evar ev) + (EvCoercion (mkTcSymCo (ctEvCoercion ev_i))) + ; stopWith ev "Solved from inert (r)" } + + | otherwise + = do { tclvl <- getTcLevel + ; if canSolveByUnification tclvl ev eq_rel tv rhs + then do { solveByUnification ev tv rhs + ; n_kicked <- kickOutRewritable Given NomEq tv + -- Given because the tv := xi is given + -- NomEq because only nom. equalities are solved + -- by unification + ; return (Stop ev (ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked)) } + + else do { traceTcS "Can't solve tyvar equality" + (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) + , ppWhen (isMetaTyVar tv) $ + nest 4 (text "TcLevel of" <+> ppr tv + <+> text "is" <+> ppr (metaTyVarTcLevel tv)) + , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) + , text "TcLevel =" <+> ppr tclvl ]) + ; n_kicked <- kickOutRewritable (ctEvFlavour ev) + (ctEvEqRel ev) + tv + ; updInertCans (\ ics -> addInertCan ics workItem) + ; return (Stop ev (ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked)) } } + +interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) + +-- @trySpontaneousSolve wi@ solves equalities where one side is a +-- touchable unification variable. +-- Returns True <=> spontaneous solve happened +canSolveByUnification :: TcLevel -> CtEvidence -> EqRel + -> TcTyVar -> Xi -> Bool +canSolveByUnification tclvl gw eq_rel tv xi + | ReprEq <- eq_rel -- we never solve representational equalities this way. + = False + + | isGiven gw -- See Note [Touchables and givens] + = False + + | isTouchableMetaTyVar tclvl tv + = case metaTyVarInfo tv of + SigTv -> is_tyvar xi + _ -> True + + | otherwise -- Untouchable + = False + where + is_tyvar xi + = case tcGetTyVar_maybe xi of + Nothing -> False + Just tv -> case tcTyVarDetails tv of + MetaTv { mtv_info = info } + -> case info of + SigTv -> True + _ -> False + SkolemTv {} -> True + FlatSkol {} -> False + RuntimeUnk -> True + +solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () +-- Solve with the identity coercion +-- Precondition: kind(xi) is a sub-kind of kind(tv) +-- Precondition: CtEvidence is Wanted or Derived +-- Precondition: CtEvidence is nominal +-- See [New Wanted Superclass Work] to see why solveByUnification +-- must work for Derived as well as Wanted +-- Returns: workItem where +-- workItem = the new Given constraint +-- +-- NB: No need for an occurs check here, because solveByUnification always +-- arises from a CTyEqCan, a *canonical* constraint. Its invariants +-- say that in (a ~ xi), the type variable a does not appear in xi. +-- See TcRnTypes.Ct invariants. +-- +-- Post: tv is unified (by side effect) with xi; +-- we often write tv := xi +solveByUnification wd tv xi + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, + text "Coercion:" <+> pprEq tv_ty xi, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] + + ; let xi' = defaultKind xi + -- We only instantiate kind unification variables + -- with simple kinds like *, not OpenKind or ArgKind + -- cf TcUnify.uUnboundKVar + + ; setWantedTyBind tv xi' + ; when (isWanted wd) $ + setEvBind (ctEvId wd) (EvCoercion (mkTcNomReflCo xi')) } + + +ppr_kicked :: Int -> SDoc +ppr_kicked 0 = empty +ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) + +kickOutRewritable :: CtFlavour -- Flavour of the equality that is + -- being added to the inert set + -> EqRel -- of the new equality + -> TcTyVar -- The new equality is tv ~ ty + -> TcS Int +kickOutRewritable new_flavour new_eq_rel new_tv + | not ((new_flavour, new_eq_rel) `eqCanRewriteFR` (new_flavour, new_eq_rel)) + = return 0 -- If new_flavour can't rewrite itself, it can't rewrite + -- anything else, so no need to kick out anything + -- This is a common case: wanteds can't rewrite wanteds + + | otherwise + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out new_flavour new_eq_rel new_tv ics + ; setInertCans ics' + ; updWorkListTcS (appendWorkList kicked_out) + + ; unless (isEmptyWorkList kicked_out) $ + csTraceTcS $ + hang (ptext (sLit "Kick out, tv =") <+> ppr new_tv) + 2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out) + , text "n-kept fun-eqs =" <+> int (sizeFunEqMap (inert_funeqs ics')) + , ppr kicked_out ]) + ; return (workListSize kicked_out) } + +kick_out :: CtFlavour -> EqRel -> TcTyVar -> InertCans -> (WorkList, InertCans) +kick_out new_flavour new_eq_rel new_tv (IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols }) + = (kicked_out, inert_cans_in) + where + -- NB: Notice that don't rewrite + -- inert_solved_dicts, and inert_solved_funeqs + -- optimistically. But when we lookup we have to + -- take the substitution into account + inert_cans_in = IC { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_insols = insols_in } + + kicked_out = WL { wl_eqs = tv_eqs_out + , wl_funeqs = feqs_out + , wl_rest = bagToList (dicts_out `andCts` irs_out + `andCts` insols_out) + , wl_implics = emptyBag } + + (tv_eqs_out, tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap + (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_irred irreds + (insols_out, insols_in) = partitionBag kick_out_ct insols + -- Kick out even insolubles; see Note [Kick out insolubles] + + can_rewrite :: CtEvidence -> Bool + can_rewrite = ((new_flavour, new_eq_rel) `eqCanRewriteFR`) . ctEvFlavourRole + + kick_out_ct :: Ct -> Bool + kick_out_ct ct = kick_out_ctev (ctEvidence ct) + + kick_out_ctev :: CtEvidence -> Bool + kick_out_ctev ev = can_rewrite ev + && new_tv `elemVarSet` tyVarsOfType (ctEvPred ev) + -- See Note [Kicking out inert constraints] + + kick_out_irred :: Ct -> Bool + kick_out_irred ct = can_rewrite (cc_ev ct) + && new_tv `elemVarSet` closeOverKinds (tyVarsOfCt ct) + -- See Note [Kicking out Irreds] + + kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList) + -> ([Ct], TyVarEnv EqualCtList) + kick_out_eqs eqs (acc_out, acc_in) + = (eqs_out ++ acc_out, case eqs_in of + [] -> acc_in + (eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in) + where + (eqs_in, eqs_out) = partition keep_eq eqs + + -- implements criteria K1-K3 in Note [The inert equalities] in TcFlatten + keep_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty, cc_ev = ev + , cc_eq_rel = eq_rel }) + | tv == new_tv + = not (can_rewrite ev) -- (K1) + + | otherwise + = check_k2 && check_k3 + where + check_k2 = not (ev `eqCanRewrite` ev) + || not (can_rewrite ev) + || not (new_tv `elemVarSet` tyVarsOfType rhs_ty) + + check_k3 + | can_rewrite ev + = case eq_rel of + NomEq -> not (rhs_ty `eqType` mkTyVarTy new_tv) + ReprEq -> not (isTyVarExposed new_tv rhs_ty) + + | otherwise + = True + + keep_eq ct = pprPanic "keep_eq" (ppr ct) + +{- +Note [Kicking out inert constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a new (a -> ty) inert, we want to kick out an existing inert +constraint if + a) the new constraint can rewrite the inert one + b) 'a' is free in the inert constraint (so that it *will*) + rewrite it if we kick it out. + +For (b) we use tyVarsOfCt, which returns the type variables /and +the kind variables/ that are directly visible in the type. Hence we +will have exposed all the rewriting we care about to make the most +precise kinds visible for matching classes etc. No need to kick out +constraints that mention type variables whose kinds contain this +variable! (Except see Note [Kicking out Irreds].) + +Note [Kicking out Irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is an awkward special case for Irreds. When we have a +kind-mis-matched equality constraint (a:k1) ~ (ty:k2), we turn it into +an Irred (see Note [Equalities with incompatible kinds] in +TcCanonical). So in this case the free kind variables of k1 and k2 +are not visible. More precisely, the type looks like + (~) k1 (a:k1) (ty:k2) +because (~) has kind forall k. k -> k -> Constraint. So the constraint +itself is ill-kinded. We can "see" k1 but not k2. That's why we use +closeOverKinds to make sure we see k2. + +This is not pretty. Maybe (~) should have kind + (~) :: forall k1 k1. k1 -> k2 -> Constraint + +Note [Kick out insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. +Then we really want to rewrite the insouluble to [Int] ~ [[Int]]. +Now it can be decomposed. Otherwise we end up with a "Can't match +[Int] ~ [[Int]]" which is true, but a bit confusing because the +outer type constructors match. + + +Note [Avoid double unifications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The spontaneous solver has to return a given which mentions the unified unification +variable *on the left* of the equality. Here is what happens if not: + Original wanted: (a ~ alpha), (alpha ~ Int) +We spontaneously solve the first wanted, without changing the order! + given : a ~ alpha [having unified alpha := a] +Now the second wanted comes along, but he cannot rewrite the given, so we simply continue. +At the end we spontaneously solve that guy, *reunifying* [alpha := Int] + +We avoid this problem by orienting the resulting given so that the unification +variable is on the left. [Note that alternatively we could attempt to +enforce this at canonicalization] + +See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding +double unifications is the main reason we disallow touchable +unification variables as RHS of type family equations: F xis ~ alpha. + + + +Note [Superclasses and recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Overlaps with Note [SUPERCLASS-LOOP 1] + Note [SUPERCLASS-LOOP 2] + Note [Recursive instances and superclases] + ToDo: check overlap and delete redundant stuff + +Right before adding a given into the inert set, we must +produce some more work, that will bring the superclasses +of the given into scope. The superclass constraints go into +our worklist. + +When we simplify a wanted constraint, if we first see a matching +instance, we may produce new wanted work. To (1) avoid doing this work +twice in the future and (2) to handle recursive dictionaries we may ``cache'' +this item as given into our inert set WITHOUT adding its superclass constraints, +otherwise we'd be in danger of creating a loop [In fact this was the exact reason +for doing the isGoodRecEv check in an older version of the type checker]. + +But now we have added partially solved constraints to the worklist which may +interact with other wanteds. Consider the example: + +Example 1: + + class Eq b => Foo a b --- 0-th selector + instance Eq a => Foo [a] a --- fooDFun + +and wanted (Foo [t] t). We are first going to see that the instance matches +and create an inert set that includes the solved (Foo [t] t) but not its superclasses: + d1 :_g Foo [t] t d1 := EvDFunApp fooDFun d3 +Our work list is going to contain a new *wanted* goal + d3 :_w Eq t + +Ok, so how do we get recursive dictionaries, at all: + +Example 2: + + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + d1 :_w Eq (D []) + +by instance decl, holds if + d2 :_w Eq [D []] + where d1 = dfEqD d2 + +*BUT* we have an inert set which gives us (no superclasses): + d1 :_g Eq (D []) +By the instance declaration of Eq we can show the 'd2' goal if + d3 :_w Eq (D []) + where d2 = dfEqList d3 + d1 = dfEqD d2 +Now, however this wanted can interact with our inert d1 to set: + d3 := d1 +and solve the goal. Why was this interaction OK? Because, if we chase the +evidence of d1 ~~> dfEqD d2 ~~-> dfEqList d3, so by setting d3 := d1 we +are really setting + d3 := dfEqD2 (dfEqList d3) +which is FINE because the use of d3 is protected by the instance function +applications. + +So, our strategy is to try to put solved wanted dictionaries into the +inert set along with their superclasses (when this is meaningful, +i.e. when new wanted goals are generated) but solve a wanted dictionary +from a given only in the case where the evidence variable of the +wanted is mentioned in the evidence of the given (recursively through +the evidence binds) in a protected way: more instance function applications +than superclass selectors. + +Here are some more examples from GHC's previous type checker + + +Example 3: +This code arises in the context of "Scrap Your Boilerplate with Class" + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char -- dfunData1 + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) -- dfunSat + + instance Data Maybe a => Foo a -- dfunFoo1 + instance Foo a => Foo [a] -- dfunFoo2 + instance Foo [Char] -- dfunFoo3 + +Consider generating the superclasses of the instance declaration + instance Foo a => Foo [a] + +So our problem is this + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass + +We may add the given in the inert set, along with its superclasses +[assuming we don't fail because there is a matching instance, see + topReactionsStage, given case ] + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + WorkList + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + WorkList + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList: + [W] d3 : Data Maybe t + [W] d4 : Foo [t] + +Now, we can just solve d3 from d01; d3 := d01 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] + WorkList: + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 + + d0 :_g Foo t + d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 + d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 + d4 :_g Foo [t] d4 := dfunFoo2 d5 + d5 :_g Foo t d5 := dfunFoo1 d7 + WorkList: + d7 :_w Data Maybe t + d6 :_g Data Maybe [t] + d8 :_g Data Maybe t d8 := EvDictSuperClass d5 0 + d01 :_g Data Maybe t + +Now, two problems: + [1] Suppose we pick d8 and we react him with d01. Which of the two givens should + we keep? Well, we *MUST NOT* drop d01 because d8 contains recursive evidence + that must not be used (look at case interactInert where both inert and workitem + are givens). So we have several options: + - Drop the workitem always (this will drop d8) + This feels very unsafe -- what if the work item was the "good" one + that should be used later to solve another wanted? + - Don't drop anyone: the inert set may contain multiple givens! + [This is currently implemented] + +The "don't drop anyone" seems the most safe thing to do, so now we come to problem 2: + [2] We have added both d6 and d01 in the inert set, and we are interacting our wanted + d7. Now the [isRecDictEv] function in the ineration solver + [case inert-given workitem-wanted] will prevent us from interacting d7 := d8 + precisely because chasing the evidence of d8 leads us to an unguarded use of d7. + + So, no interaction happens there. Then we meet d01 and there is no recursion + problem there [isRectDictEv] gives us the OK to interact and we do solve d7 := d01! + +Note [SUPERCLASS-LOOP 1] +~~~~~~~~~~~~~~~~~~~~~~~~ +We have to be very, very careful when generating superclasses, lest we +accidentally build a loop. Here's an example: + + class S a + + class S a => C a where { opc :: a -> a } + class S b => D b where { opd :: b -> b } + + instance C Int where + opc = opd + + instance D Int where + opd = opc + +From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} +Simplifying, we may well get: + $dfCInt = :C ds1 (opd dd) + dd = $dfDInt + ds1 = $p1 dd +Notice that we spot that we can extract ds1 from dd. + +Alas! Alack! We can do the same for (instance D Int): + + $dfDInt = :D ds2 (opc dc) + dc = $dfCInt + ds2 = $p1 dc + +And now we've defined the superclass in terms of itself. +Two more nasty cases are in + tcrun021 + tcrun033 + +Solution: + - Satisfy the superclass context *all by itself* + (tcSimplifySuperClasses) + - And do so completely; i.e. no left-over constraints + to mix with the constraints arising from method declarations + + +Note [SUPERCLASS-LOOP 2] +~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be careful when adding "the constaint we are trying to prove". +Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the +superclasses of C [a] to avails. But we must not overwrite the binding +for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just +build a loop! + +Here's another variant, immortalised in tcrun020 + class Monad m => C1 m + class C1 m => C2 m x + instance C2 Maybe Bool +For the instance decl we need to build (C1 Maybe), and it's no good if +we run around and add (C2 Maybe Bool) and its superclasses to the avails +before we search for C1 Maybe. + +Here's another example + class Eq b => Foo a b + instance Eq a => Foo [a] a +If we are reducing + (Foo [t] t) + +we'll first deduce that it holds (via the instance decl). We must not +then overwrite the Eq t constraint with a superclass selection! + +At first I had a gross hack, whereby I simply did not add superclass constraints +in addWanted, though I did for addGiven and addIrred. This was sub-optimal, +because it lost legitimate superclass sharing, and it still didn't do the job: +I found a very obscure program (now tcrun021) in which improvement meant the +simplifier got two bites a the cherry... so something seemed to be an Stop +first time, but reducible next time. + +Now we implement the Right Solution, which is to check for loops directly +when adding superclasses. It's a bit like the occurs check in unification. + +Note [Recursive instances and superclases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code, which arises in the context of "Scrap Your +Boilerplate with Class". + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) + + instance Data Maybe a => Foo a + instance Foo a => Foo [a] + instance Foo [Char] + +In the instance for Foo [a], when generating evidence for the superclasses +(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]). +Using the instance for Data, we therefore need + (Sat (Maybe [a], Data Maybe a) +But we are given (Foo a), and hence its superclass (Data Maybe a). +So that leaves (Sat (Maybe [a])). Using the instance for Sat means +we need (Foo [a]). And that is the very dictionary we are bulding +an instance for! So we must put that in the "givens". So in this +case we have + Given: Foo a, Foo [a] + Wanted: Data Maybe [a] + +BUT we must *not not not* put the *superclasses* of (Foo [a]) in +the givens, which is what 'addGiven' would normally do. Why? Because +(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted +by selecting a superclass from Foo [a], which simply makes a loop. + +On the other hand we *must* put the superclasses of (Foo a) in +the givens, as you can see from the derivation described above. + +Conclusion: in the very special case of tcSimplifySuperClasses +we have one 'given' (namely the "this" dictionary) whose superclasses +must not be added to 'givens' by addGiven. + +There is a complication though. Suppose there are equalities + instance (Eq a, a~b) => Num (a,b) +Then we normalise the 'givens' wrt the equalities, so the original +given "this" dictionary is cast to one of a different type. So it's a +bit trickier than before to identify the "special" dictionary whose +superclasses must not be added. See test + indexed-types/should_run/EqInInstance + +We need a persistent property of the dictionary to record this +special-ness. Current I'm using the InstLocOrigin (a bit of a hack, +but cool), which is maintained by dictionary normalisation. +Specifically, the InstLocOrigin is + NoScOrigin +then the no-superclass thing kicks in. WATCH OUT if you fiddle +with InstLocOrigin! + + +************************************************************************ +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see Trac #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of FunDeps.lhs (nicer +now!). +-} + +rewriteWithFunDeps :: [Equation CtLoc] -> TcS () +-- NB: The returned constraints are all Derived +-- Post: returns no trivial equalities (identities) and all EvVars returned are fresh +rewriteWithFunDeps eqn_pred_locs + = mapM_ instFunDepEqn eqn_pred_locs + +instFunDepEqn :: Equation CtLoc -> TcS () +-- Post: Returns the position index as well as the corresponding FunDep equality +instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) + = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution + ; mapM_ (do_one subst) eqs } + where + do_one subst (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 }) + = unifyDerived loc Nominal $ + Pair (Type.substTy subst ty1) (Type.substTy subst ty2) + +{- +********************************************************************************* +* * + The top-reaction Stage +* * +********************************************************************************* +-} + +topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) +topReactionsStage wi + = do { inerts <- getTcSInerts + ; tir <- doTopReact inerts wi + ; case tir of + ContinueWith wi -> return (ContinueWith wi) + Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } + +doTopReact :: InertSet -> WorkItem -> TcS (StopOrContinue Ct) +-- The work item does not react with the inert set, so try interaction with top-level +-- instances. Note: +-- +-- (a) The place to add superclasses in not here in doTopReact stage. +-- Instead superclasses are added in the worklist as part of the +-- canonicalization process. See Note [Adding superclasses]. +-- +-- (b) See Note [Given constraint that matches an instance declaration] +-- for some design decisions for given dictionaries. + +doTopReact inerts work_item + = do { traceTcS "doTopReact" (ppr work_item) + ; case work_item of + CDictCan {} -> doTopReactDict inerts work_item + CFunEqCan {} -> doTopReactFunEq work_item + _ -> -- Any other work item does not react with any top-level equations + return (ContinueWith work_item) } + +-------------------- +doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) +-- Try to use type-class instance declarations to simplify the constraint +doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls + , cc_tyargs = xis }) + | not (isWanted fl) -- Never use instances for Given or Derived constraints + = try_fundeps_and_return + + | Just ev <- lookupSolvedDict inerts loc cls xis -- Cached + = do { setEvBind dict_id (ctEvTerm ev); + ; stopWith fl "Dict/Top (cached)" } + + | otherwise -- Not cached + = do { lkup_inst_res <- matchClassInst inerts cls xis loc + ; case lkup_inst_res of + GenInst wtvs ev_term -> do { addSolvedDict fl cls xis + ; solve_from_instance wtvs ev_term } + NoInstance -> try_fundeps_and_return } + where + dict_id = ASSERT( isWanted fl ) ctEvId fl + pred = mkClassPred cls xis + loc = ctEvLoc fl + + solve_from_instance :: [CtEvidence] -> EvTerm -> TcS (StopOrContinue Ct) + -- Precondition: evidence term matches the predicate workItem + solve_from_instance evs ev_term + | null evs + = do { traceTcS "doTopReact/found nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term + ; stopWith fl "Dict/Top (solved, no new work)" } + | otherwise + = do { traceTcS "doTopReact/found non-nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term + ; let mk_new_wanted ev + = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc }) + ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs)) + ; stopWith fl "Dict/Top (solved, more work)" } + + -- We didn't solve it; so try functional dependencies with + -- the instance environment, and return + -- NB: even if there *are* some functional dependencies against the + -- instance environment, there might be a unique match, and if + -- so we make sure we get on and solve it first. See Note [Weird fundeps] + try_fundeps_and_return + = do { instEnvs <- getInstEnvs + ; let fd_eqns :: [Equation CtLoc] + fd_eqns = [ fd { fd_loc = loc { ctl_origin = FunDepOrigin2 pred (ctl_origin loc) + inst_pred inst_loc } } + | fd@(FDEqn { fd_loc = inst_loc, fd_pred1 = inst_pred }) + <- improveFromInstEnv instEnvs pred ] + ; rewriteWithFunDeps fd_eqns + ; continueWith work_item } + +doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) + +-------------------- +doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) +doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args , cc_fsk = fsk }) + = ASSERT(isTypeFamilyTyCon fam_tc) -- No associated data families + -- have reached this far + ASSERT( not (isDerived old_ev) ) -- CFunEqCan is never Derived + -- Look up in top-level instances, or built-in axiom + do { match_res <- matchFam fam_tc args -- See Note [MATCHING-SYNONYMS] + ; case match_res of { + Nothing -> do { try_improvement; continueWith work_item } ; + Just (ax_co, rhs_ty) + + -- Found a top-level instance + + | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty + , isTypeFamilyTyCon tc + , tc_args `lengthIs` tyConArity tc -- Short-cut + -> shortCutReduction old_ev fsk ax_co tc tc_args + -- Try shortcut; see Note [Short cut for top-level reaction] + + | isGiven old_ev -- Not shortcut + -> do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co + -- final_co :: fsk ~ rhs_ty + ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty, + EvCoercion final_co) + ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty + ; stopWith old_ev "Fun/Top (given)" } + + | not (fsk `elemVarSet` tyVarsOfType rhs_ty) + -> do { dischargeFmv (ctEvId old_ev) fsk ax_co rhs_ty + ; traceTcS "doTopReactFunEq" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr ax_co ] + ; stopWith old_ev "Fun/Top (wanted)" } + + | otherwise -- We must not assign ufsk := ...ufsk...! + -> do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk) + ; new_ev <- newWantedEvVarNC loc (mkTcEqPred alpha_ty rhs_ty) + ; emitWorkNC [new_ev] + -- By emitting this as non-canonical, we deal with all + -- flattening, occurs-check, and ufsk := ufsk issues + ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev) + -- ax_co :: fam_tc args ~ rhs_ty + -- ev :: alpha ~ rhs_ty + -- ufsk := alpha + -- final_co :: fam_tc args ~ alpha + ; dischargeFmv (ctEvId old_ev) fsk final_co alpha_ty + ; traceTcS "doTopReactFunEq (occurs)" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr final_co + , text "new_ev:" <+> ppr new_ev ] + ; stopWith old_ev "Fun/Top (wanted)" } } } + where + loc = ctEvLoc old_ev + deeper_loc = bumpCtLocDepth CountTyFunApps loc + + try_improvement + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { inert_eqs <- getInertEqs + ; let eqns = sfInteractTop ops args (lookupFlattenTyVar inert_eqs fsk) + ; mapM_ (unifyDerived loc Nominal) eqns } + | otherwise + = return () + +doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) + +shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion + -> TyCon -> [TcType] -> TcS (StopOrContinue Ct) +shortCutReduction old_ev fsk ax_co fam_tc tc_args + | isGiven old_ev + = ASSERT( ctEvEqRel old_ev == NomEq ) + runFlatten $ + do { let fmode = mkFlattenEnv FM_FlattenAll old_ev + ; (xis, cos) <- flatten_many fmode (repeat Nominal) tc_args + -- ax_co :: F args ~ G tc_args + -- cos :: xis ~ tc_args + -- old_ev :: F args ~ fsk + -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk + + ; new_ev <- newGivenEvVar deeper_loc + ( mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) + , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos + `mkTcTransCo` mkTcSymCo ax_co + `mkTcTransCo` ctEvCoercion old_ev) ) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } + ; emitFlatWork new_ct + ; stopWith old_ev "Fun/Top (given, shortcut)" } + + | otherwise + = ASSERT( not (isDerived old_ev) ) -- Caller ensures this + ASSERT( ctEvEqRel old_ev == NomEq ) + runFlatten $ + do { let fmode = mkFlattenEnv FM_FlattenAll old_ev + ; (xis, cos) <- flatten_many fmode (repeat Nominal) tc_args + -- ax_co :: F args ~ G tc_args + -- cos :: xis ~ tc_args + -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk + -- new_ev :: G xis ~ fsk + -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev + + ; new_ev <- newWantedEvVarNC loc (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)) + ; setEvBind (ctEvId old_ev) + (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos) + `mkTcTransCo` ctEvCoercion new_ev)) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } + ; emitFlatWork new_ct + ; stopWith old_ev "Fun/Top (wanted, shortcut)" } + where + loc = ctEvLoc old_ev + deeper_loc = bumpCtLocDepth CountTyFunApps loc + +dischargeFmv :: EvVar -> TcTyVar -> TcCoercion -> TcType -> TcS () +-- (dischargeFmv x fmv co ty) +-- [W] x :: F tys ~ fuv +-- co :: F tys ~ ty +-- Precondition: fuv is not filled, and fuv `notElem` ty +-- +-- Then set fuv := ty, +-- set x := co +-- kick out any inert things that are now rewritable +dischargeFmv evar fmv co xi + = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr evar $$ ppr fmv $$ ppr xi ) + do { setWantedTyBind fmv xi + ; setEvBind evar (EvCoercion co) + ; n_kicked <- kickOutRewritable Given NomEq fmv + ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) } + +{- +Note [Cached solved FunEqs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When trying to solve, say (FunExpensive big-type ~ ty), it's important +to see if we have reduced (FunExpensive big-type) before, lest we +simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover +we must use `canRewriteOrSame` because both uses might (say) be Wanteds, +and we *still* want to save the re-computation. + +Note [MATCHING-SYNONYMS] +~~~~~~~~~~~~~~~~~~~~~~~~ +When trying to match a dictionary (D tau) to a top-level instance, or a +type family equation (F taus_1 ~ tau_2) to a top-level family instance, +we do *not* need to expand type synonyms because the matcher will do that for us. + + +Note [RHS-FAMILY-SYNONYMS] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RHS of a family instance is represented as yet another constructor which is +like a type synonym for the real RHS the programmer declared. Eg: + type instance F (a,a) = [a] +Becomes: + :R32 a = [a] -- internal type synonym introduced + F (a,a) ~ :R32 a -- instance + +When we react a family instance with a type family equation in the work list +we keep the synonym-using RHS without expansion. + +Note [FunDep and implicit parameter reactions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, our story of interacting two dictionaries (or a dictionary +and top-level instances) for functional dependencies, and implicit +paramters, is that we simply produce new Derived equalities. So for example + + class D a b | a -> b where ... + Inert: + d1 :g D Int Bool + WorkItem: + d2 :w D Int alpha + + We generate the extra work item + cv :d alpha ~ Bool + where 'cv' is currently unused. However, this new item can perhaps be + spontaneously solved to become given and react with d2, + discharging it in favour of a new constraint d2' thus: + d2' :w D Int Bool + d2 := d2' |> D Int cv + Now d2' can be discharged from d1 + +We could be more aggressive and try to *immediately* solve the dictionary +using those extra equalities, but that requires those equalities to carry +evidence and derived do not carry evidence. + +If that were the case with the same inert set and work item we might dischard +d2 directly: + + cv :w alpha ~ Bool + d2 := d1 |> D Int cv + +But in general it's a bit painful to figure out the necessary coercion, +so we just take the first approach. Here is a better example. Consider: + class C a b c | a -> b +And: + [Given] d1 : C T Int Char + [Wanted] d2 : C T beta Int +In this case, it's *not even possible* to solve the wanted immediately. +So we should simply output the functional dependency and add this guy +[but NOT its superclasses] back in the worklist. Even worse: + [Given] d1 : C T Int beta + [Wanted] d2: C T beta Int +Then it is solvable, but its very hard to detect this on the spot. + +It's exactly the same with implicit parameters, except that the +"aggressive" approach would be much easier to implement. + +Note [When improvement happens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We fire an improvement rule when + + * Two constraints match (modulo the fundep) + e.g. C t1 t2, C t1 t3 where C a b | a->b + The two match because the first arg is identical + +Note that we *do* fire the improvement if one is Given and one is Derived (e.g. a +superclass of a Wanted goal) or if both are Given. + +Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + +When solving the superclasses of the (C (Maybe a) a) instance, we get + Given: C a b ... and hance by superclasses, (G a, L a b) + Wanted: G (Maybe a) +Use the instance decl to get + Wanted: C a b' +The (C a b') is inert, so we generate its Derived superclasses (L a b'), +and now we need improvement between that derived superclass an the Given (L a b) + +Test typecheck/should_fail/FDsFromGivens also shows why it's a good idea to +emit Derived FDs for givens as well. + +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fudeps from both instance decls; but it also +matches a *unique* instance decl, and we should go ahead and +pick that one right now. Otherwise, if we don't, it ends up +unsolved in the inert set and is reported as an error. + +Trac #7875 is a case in point. + +Note [Overriding implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (?x::a) -> Bool -> a + + g v = let ?x::Int = 3 + in (f v, let ?x::Bool = True in f v) + +This should probably be well typed, with + g :: Bool -> (Int, Bool) + +So the inner binding for ?x::Bool *overrides* the outer one. +Hence a work-item Given overrides an inert-item Given. + +Note [Given constraint that matches an instance declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do when we discover that one (or more) top-level +instances match a given (or solved) class constraint? We have +two possibilities: + + 1. Reject the program. The reason is that there may not be a unique + best strategy for the solver. Example, from the OutsideIn(X) paper: + instance P x => Q [x] + instance (x ~ y) => R [x] y + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + + will generate the impliation constraint: + Q [a] => (Q [beta], R beta [a]) + If we react (Q [beta]) with its top-level axiom, we end up with a + (P beta), which we have no way of discharging. On the other hand, + if we react R beta [a] with the top-level we get (beta ~ a), which + is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is + now solvable by the given Q [a]. + + However, this option is restrictive, for instance [Example 3] from + Note [Recursive instances and superclases] will fail to work. + + 2. Ignore the problem, hoping that the situations where there exist indeed + such multiple strategies are rare: Indeed the cause of the previous + problem is that (R [x] y) yields the new work (x ~ y) which can be + *spontaneously* solved, not using the givens. + +We are choosing option 2 below but we might consider having a flag as well. + + +Note [New Wanted Superclass Work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the case of wanted constraints, we may add some superclasses +as new given work. The reason is: + + To allow FD-like improvement for type families. Assume that + we have a class + class C a b | a -> b + and we have to solve the implication constraint: + C a b => C a beta + Then, FD improvement can help us to produce a new wanted (beta ~ b) + + We want to have the same effect with the type family encoding of + functional dependencies. Namely, consider: + class (F a ~ b) => C a b + Now suppose that we have: + given: C a b + wanted: C a beta + By interacting the given we will get given (F a ~ b) which is not + enough by itself to make us discharge (C a beta). However, we + may create a new derived equality from the super-class of the + wanted constraint (C a beta), namely derived (F a ~ beta). + Now we may interact this with given (F a ~ b) to get: + derived : beta ~ b + But 'beta' is a touchable unification variable, and hence OK to + unify it with 'b', replacing the derived evidence with the identity. + + This requires trySpontaneousSolve to solve *derived* + equalities that have a touchable in their RHS, *in addition* + to solving wanted equalities. + +We also need to somehow use the superclasses to quantify over a minimal, +constraint see note [Minimize by Superclasses] in TcSimplify. + + +Finally, here is another example where this is useful. + +Example 1: +---------- + class (F a ~ b) => C a b +And we are given the wanteds: + w1 : C a b + w2 : C a c + w3 : b ~ c +We surely do *not* want to quantify over (b ~ c), since if someone provides +dictionaries for (C a b) and (C a c), these dictionaries can provide a proof +of (b ~ c), hence no extra evidence is necessary. Here is what will happen: + + Step 1: We will get new *given* superclass work, + provisionally to our solving of w1 and w2 + + g1: F a ~ b, g2 : F a ~ c, + w1 : C a b, w2 : C a c, w3 : b ~ c + + The evidence for g1 and g2 is a superclass evidence term: + + g1 := sc w1, g2 := sc w2 + + Step 2: The givens will solve the wanted w3, so that + w3 := sym (sc w1) ; sc w2 + + Step 3: Now, one may naively assume that then w2 can be solve from w1 + after rewriting with the (now solved equality) (b ~ c). + + But this rewriting is ruled out by the isGoodRectDict! + +Conclusion, we will (correctly) end up with the unsolved goals + (C a b, C a c) + +NB: The desugarer needs be more clever to deal with equalities + that participate in recursive dictionary bindings. +-} + +data LookupInstResult + = NoInstance + | GenInst [CtEvidence] EvTerm + +instance Outputable LookupInstResult where + ppr NoInstance = text "NoInstance" + ppr (GenInst ev t) = text "GenInst" <+> ppr ev <+> ppr t + + +matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult + +matchClassInst _ clas [ ty ] _ + | className clas == knownNatClassName + , Just n <- isNumLitTy ty = makeDict (EvNum n) + + | className clas == knownSymbolClassName + , Just s <- isStrLitTy ty = makeDict (EvStr s) + + where + {- This adds a coercion that will convert the literal into a dictionary + of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] + in TcEvidence. The coercion happens in 2 steps: + + Integer -> SNat n -- representation of literal to singleton + SNat n -> KnownNat n -- singleton to dictionary + + The process is mirrored for Symbols: + String -> SSymbol n + SSymbol n -> KnownSymbol n + -} + makeDict evLit + | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] + -- co_dict :: KnownNat n ~ SNat n + , [ meth ] <- classMethods clas + , Just tcRep <- tyConAppTyCon_maybe -- SNat + $ funResultTy -- SNat n + $ dropForAlls -- KnownNat n => SNat n + $ idType meth -- forall n. KnownNat n => SNat n + , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] + -- SNat n ~ Integer + = return (GenInst [] $ mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))) + + | otherwise + = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas))) + +matchClassInst _ clas [k,t] loc + | className clas == typeableClassName = matchTypeableClass clas k t loc + +matchClassInst inerts clas tys loc + = do { dflags <- getDynFlags + ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred + , text "inerts=" <+> ppr inerts ] + ; instEnvs <- getInstEnvs + ; case lookupInstEnv instEnvs clas tys of + ([], _, _) -- Nothing matches + -> do { traceTcS "matchClass not matching" $ + vcat [ text "dict" <+> ppr pred ] + ; return NoInstance } + + ([(ispec, inst_tys)], [], _) -- A single match + | not (xopt Opt_IncoherentInstances dflags) + , not (isEmptyBag unifiable_givens) + -> -- See Note [Instance and Given overlap] + do { traceTcS "Delaying instance application" $ + vcat [ text "Work item=" <+> pprType (mkClassPred clas tys) + , text "Relevant given dictionaries=" <+> ppr unifiable_givens ] + ; return NoInstance } + + | otherwise + -> do { let dfun_id = instanceDFunId ispec + ; traceTcS "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one dfun_id inst_tys } + + (matches, _, _) -- More than one matches + -- Defer any reactions of a multitude + -- until we learn more about the reagent + -> do { traceTcS "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NoInstance } } + where + pred = mkClassPred clas tys + + match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult + -- See Note [DFunInstType: instantiating types] in InstEnv + match_one dfun_id mb_inst_tys + = do { checkWellStagedDFun pred dfun_id loc + ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys + ; let (theta, _) = tcSplitPhiTy dfun_phi + ; if null theta then + return (GenInst [] (EvDFunApp dfun_id tys [])) + else do + { evc_vars <- instDFunConstraints loc theta + ; let new_ev_vars = freshGoals evc_vars + -- new_ev_vars are only the real new variables that can be emitted + dfun_app = EvDFunApp dfun_id tys (map (ctEvTerm . fst) evc_vars) + ; return $ GenInst new_ev_vars dfun_app } } + + unifiable_givens :: Cts + unifiable_givens = filterBag matchable $ + findDictsByClass (inert_dicts $ inert_cans inerts) clas + + matchable (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_ev = fl }) + | isGiven fl + , Just {} <- tcUnifyTys bind_meta_tv tys sys + = ASSERT( clas_g == clas ) True + | otherwise = False -- No overlap with a solved, already been taken care of + -- by the overlap check with the instance environment. + + matchable ct = pprPanic "Expecting dictionary!" (ppr ct) + + bind_meta_tv :: TcTyVar -> BindFlag + -- Any meta tyvar may be unified later, so we treat it as + -- bindable when unifying with givens. That ensures that we + -- conservatively assume that a meta tyvar might get unified with + -- something that matches the 'given', until demonstrated + -- otherwise. + bind_meta_tv tv | isMetaTyVar tv = BindMe + | otherwise = Skolem + +{- Note [Instance and Given overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example, from the OutsideIn(X) paper: + instance P x => Q [x] + instance (x ~ y) => R y [x] + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + +This will generate the impliation constraint: + Q [a] => (Q [beta], R beta [a]) +If we react (Q [beta]) with its top-level axiom, we end up with a +(P beta), which we have no way of discharging. On the other hand, +if we react R beta [a] with the top-level we get (beta ~ a), which +is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is +now solvable by the given Q [a]. + +The solution is that: + In matchClassInst (and thus in topReact), we return a matching + instance only when there is no Given in the inerts which is + unifiable to this particular dictionary. + + We treat any meta-tyvar as "unifiable" for this purpose, + *including* untouchable ones + +The end effect is that, much as we do for overlapping instances, we +delay choosing a class instance if there is a possibility of another +instance OR a given to match our constraint later on. This fixes +Trac #4981 and #5002. + +Other notes: + +* This is arguably not easy to appear in practice due to our + aggressive prioritization of equality solving over other + constraints, but it is possible. I've added a test case in + typecheck/should-compile/GivenOverlapping.hs + +* Another "live" example is Trac #10195 + +* We ignore the overlap problem if -XIncoherentInstances is in force: + see Trac #6002 for a worked-out example where this makes a + difference. + +* Moreover notice that our goals here are different than the goals of + the top-level overlapping checks. There we are interested in + validating the following principle: + + If we inline a function f at a site where the same global + instance environment is available as the instance environment at + the definition site of f then we should get the same behaviour. + + But for the Given Overlap check our goal is just related to completeness of + constraint solving. +-} + +-- | Assumes that we've checked that this is the 'Typeable' class, +-- and it was applied to the correc arugment. +matchTypeableClass :: Class -> Kind -> Type -> CtLoc -> TcS LookupInstResult +matchTypeableClass clas _k t loc + + -- See Note [No Typeable for qualified types] + | isForAllTy t = return NoInstance + -- Is the type of the form `C => t`? + | Just (t1,_) <- splitFunTy_maybe t, + isConstraintKind (typeKind t1) = return NoInstance + + | Just (tc, ks) <- splitTyConApp_maybe t + , all isKind ks = doTyCon tc ks + | Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt + | Just _ <- isNumLitTy t = mkSimpEv (EvTypeableTyLit t) + | Just _ <- isStrLitTy t = mkSimpEv (EvTypeableTyLit t) + | otherwise = return NoInstance + + where + -- Representation for type constructor applied to some kinds + doTyCon tc ks = + case mapM kindRep ks of + Nothing -> return NoInstance + Just kReps -> mkSimpEv (EvTypeableTyCon tc kReps) + + {- Representation for an application of a type to a type-or-kind. + This may happen when the type expression starts with a type variable. + Example (ignoring kind parameter): + Typeable (f Int Char) --> + (Typeable (f Int), Typeable Char) --> + (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) + Typeable f + -} + doTyApp f tk + | isKind tk = return NoInstance -- We can't solve until we know the ctr. + | otherwise = + do ct1 <- subGoal f + ct2 <- subGoal tk + let realSubs = [ c | (c,Fresh) <- [ct1,ct2] ] + return $ GenInst realSubs + $ EvTypeable $ EvTypeableTyApp (getEv ct1,f) (getEv ct2,tk) + + + -- Representation for concrete kinds. We just use the kind itself, + -- but first check to make sure that it is "simple" (i.e., made entirely + -- out of kind constructors). + kindRep ki = do (_,ks) <- splitTyConApp_maybe ki + mapM_ kindRep ks + return ki + + getEv (ct,_fresh) = ctEvTerm ct + + -- Emit a `Typeable` constraint for the given type. + subGoal ty = do let goal = mkClassPred clas [ typeKind ty, ty ] + newWantedEvVar loc goal + + mkSimpEv ev = return (GenInst [] (EvTypeable ev)) + +{- Note [No Typeable for polytype or for constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not support impredicative typeable, such as + Typeable (forall a. a->a) + Typeable (Eq a => a -> a) + Typeable (() => Int) + Typeable (((),()) => Int) + +See Trac #9858. For forall's the case is clear: we simply don't have +a TypeRep for them. For qualified but not polymorphic types, like +(Eq a => a -> a), things are murkier. But: + + * We don't need a TypeRep for these things. TypeReps are for + monotypes only. + + * Perhaps we could treat `=>` as another type constructor for `Typeable` + purposes, and thus support things like `Eq Int => Int`, however, + at the current state of affairs this would be an odd exception as + no other class works with impredicative types. + For now we leave it off, until we have a better story for impredicativity. +-} + +-- | Is the constraint for an implicit CallStack parameter? +isCallStackIP :: CtLoc -> Class -> Type -> Maybe (EvTerm -> EvCallStack) +isCallStackIP loc cls ty + | Just (tc, []) <- splitTyConApp_maybe ty + , cls `hasKey` ipClassNameKey && tc `hasKey` callStackTyConKey + = occOrigin (ctLocOrigin loc) + where + -- We only want to grab constraints that arose due to the use of an IP or a + -- function call. See Note [Overview of implicit CallStacks] + occOrigin (OccurrenceOf n) + = Just (EvCsPushCall n locSpan) + occOrigin (IPOccOrigin n) + = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan) + occOrigin _ + = Nothing + locSpan + = ctLocSpan loc +isCallStackIP _ _ _ + = Nothing diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs new file mode 100644 index 00000000..ebab25ea --- /dev/null +++ b/compiler/typecheck/TcMType.hs @@ -0,0 +1,1022 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Monadic type operations + +This module contains monadic operations over types that contain +mutable type variables +-} + +{-# LANGUAGE CPP #-} + +module TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, + + -------------------------------- + -- Creating new mutable type variables + newFlexiTyVar, + newFlexiTyVarTy, -- Kind -> TcM TcType + newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newReturnTyVar, newReturnTyVarTy, + newMetaKindVar, newMetaKindVars, + mkTcTyVarName, cloneMetaTyVar, + + newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newEq, newDict, + newTcEvBinds, addTcEvBind, + newSimpleWanted, newSimpleWanteds, + + -------------------------------- + -- Instantiation + tcInstTyVars, newSigTyVar, + tcInstType, + tcInstSkolTyVars, tcInstSuperSkolTyVarsX, + tcInstSigTyVarsLoc, tcInstSigTyVars, + tcInstSkolType, + tcSkolDFunType, tcSuperSkolTyVars, + + instSkolTyVars, freshenTyVarBndrs, + + -------------------------------- + -- Zonking and tidying + zonkTcPredType, zonkTidyTcType, zonkTidyOrigin, + tidyEvVar, tidyCt, tidySkolemInfo, + skolemiseUnboundMetaTyVar, + zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkTcTypeAndFV, + zonkQuantifiedTyVar, quantifyTyVars, + zonkTcTyVarBndr, zonkTcType, zonkTcTypes, zonkTcThetaType, + + zonkTcKind, defaultKindVarToStar, + zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, + + tcGetGlobalTyVars, + + -------------------------------- + -- (Named) Wildcards + newWildcardVar, newWildcardVarMetaKind + ) where + +#include "HsVersions.h" + +-- friends: +import TypeRep +import TcType +import Type +import Class +import Var +import VarEnv + +-- others: +import TcRnMonad -- TcType, amongst others +import Id +import Name +import VarSet +import PrelNames +import DynFlags +import Util +import Outputable +import FastString +import SrcLoc +import Bag + +import Control.Monad +import Data.List ( partition, mapAccumL ) + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +mkKindName :: Unique -> Name +mkKindName unique = mkSystemName unique kind_var_occ + +kind_var_occ :: OccName -- Just one for all MetaKindVars + -- They may be jiggled by tidying +kind_var_occ = mkOccName tvName "k" + +newMetaKindVar :: TcM TcKind +newMetaKindVar = do { uniq <- newUnique + ; details <- newMetaDetails (TauTv False) + ; let kv = mkTcTyVar (mkKindName uniq) superKind details + ; return (mkTyVarTy kv) } + +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) + +{- +************************************************************************ +* * + Evidence variables; range over constraints we can abstract over +* * +************************************************************************ +-} + +newEvVars :: TcThetaType -> TcM [EvVar] +newEvVars theta = mapM newEvVar theta + +-------------- + +newEvVar :: TcPredType -> TcM EvVar +-- Creates new *rigid* variables for predicates +newEvVar ty = do { name <- newSysName (predTypeOccName ty) + ; return (mkLocalId name ty) } + +newEq :: TcType -> TcType -> TcM EvVar +newEq ty1 ty2 + = do { name <- newSysName (mkVarOccFS (fsLit "cobox")) + ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case classifyPredType ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + EqPred _ _ _ -> mkVarOccFS (fsLit "cobox") + TuplePred _ -> mkVarOccFS (fsLit "tup") + IrredPred _ -> mkVarOccFS (fsLit "irred") + +{- +********************************************************************************* +* * +* Wanted constraints +* * +********************************************************************************* +-} + +newSimpleWanted :: CtOrigin -> PredType -> TcM Ct +newSimpleWanted orig pty + = do loc <- getCtLoc orig + v <- newEvVar pty + return $ mkNonCanonical $ + CtWanted { ctev_evar = v + , ctev_pred = pty + , ctev_loc = loc } + +newSimpleWanteds :: CtOrigin -> ThetaType -> TcM [Ct] +newSimpleWanteds orig = mapM (newSimpleWanted orig) + +{- +************************************************************************ +* * + SkolemTvs (immutable) +* * +************************************************************************ +-} + +tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables + -> TcType -- Type to instantiate + -> TcM ([TcTyVar], TcThetaType, TcType) -- Result + -- (type vars (excl coercion vars), preds (incl equalities), rho) +tcInstType inst_tyvars ty + = case tcSplitForAllTys ty of + ([], rho) -> let -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + (theta, tau) = tcSplitPhiTy rho + in + return ([], theta, tau) + + (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTy subst rho) + ; return (tyvars', theta, tau) } + +tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) +-- Instantiate a type signature with skolem constants. +-- We could give them fresh names, but no need to do so +tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty + +tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) +-- Make skolem constants, but do *not* give them new names, as above +-- Moreover, make them "super skolems"; see comments with superSkolemTv +-- see Note [Kind substitution when instantiating] +-- Precondition: tyvars should be ordered (kind vars first) +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) + +tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) +tcSuperSkolTyVar subst tv + = (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) + where + kind = substTy subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + +tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVars = tcInstSkolTyVars' False emptyTvSubst + +tcInstSuperSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTvSubst + +tcInstSuperSkolTyVarsX :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst + +tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +-- Get the location from the monad; this is a complete freshening operation +tcInstSkolTyVars' overlappable subst tvs + = do { loc <- getSrcSpanM + ; instSkolTyVarsX (mkTcSkolTyVar loc overlappable) subst tvs } + +mkTcSkolTyVar :: SrcSpan -> Bool -> Unique -> Name -> Kind -> TcTyVar +mkTcSkolTyVar loc overlappable uniq old_name kind + = mkTcTyVar (mkInternalName uniq (getOccName old_name) loc) + kind + (SkolemTv overlappable) + +tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) +-- We specify the location +tcInstSigTyVarsLoc loc = instSkolTyVars (mkTcSkolTyVar loc False) + +tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) +-- Get the location from the TyVar itself, not the monad +tcInstSigTyVars + = instSkolTyVars mk_tv + where + mk_tv uniq old_name kind + = mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False) + +tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) +-- Instantiate a type with fresh skolem constants +-- Binding location comes from the monad +tcInstSkolType ty = tcInstType tcInstSkolTyVars ty + +------------------ +freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +-- ^ Give fresh uniques to a bunch of TyVars, but they stay +-- as TyVars, rather than becoming TcTyVars +-- Used in FamInst.newFamInst, and Inst.newClsInst +freshenTyVarBndrs = instSkolTyVars mk_tv + where + mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind + +------------------ +instSkolTyVars :: (Unique -> Name -> Kind -> TyVar) + -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +instSkolTyVars mk_tv = instSkolTyVarsX mk_tv emptyTvSubst + +instSkolTyVarsX :: (Unique -> Name -> Kind -> TyVar) + -> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +instSkolTyVarsX mk_tv = mapAccumLM (instSkolTyVarX mk_tv) + +instSkolTyVarX :: (Unique -> Name -> Kind -> TyVar) + -> TvSubst -> TyVar -> TcRnIf gbl lcl (TvSubst, TyVar) +instSkolTyVarX mk_tv subst tyvar + = do { uniq <- newUnique + ; let new_tv = mk_tv uniq old_name kind + ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } + where + old_name = tyVarName tyvar + kind = substTy subst (tyVarKind tyvar) + +{- +Note [Kind substitution when instantiating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we instantiate a bunch of kind and type variables, first we +expect them to be sorted (kind variables first, then type variables). +Then we have to instantiate the kind variables, build a substitution +from old variables to the new variables, then instantiate the type +variables substituting the original kind. + +Exemple: If we want to instantiate + [(k1 :: BOX), (k2 :: BOX), (a :: k1 -> k2), (b :: k1)] +we want + [(?k1 :: BOX), (?k2 :: BOX), (?a :: ?k1 -> ?k2), (?b :: ?k1)] +instead of the buggous + [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)] + + +************************************************************************ +* * + MetaTvs (meta type variables; mutable) +* * +************************************************************************ +-} + +newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newMetaTyVar meta_info kind + = do { uniq <- newUnique + ; let name = mkTcTyVarName uniq s + s = case meta_info of + ReturnTv -> fsLit "r" + TauTv True -> fsLit "w" + TauTv False -> fsLit "t" + FlatMetaTv -> fsLit "fmv" + SigTv -> fsLit "a" + ; details <- newMetaDetails meta_info + ; return (mkTcTyVar name kind details) } + +newNamedMetaTyVar :: Name -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedMetaTyVar name meta_info kind + = do { details <- newMetaDetails meta_info + ; return (mkTcTyVar name kind details) } + +newSigTyVar :: Name -> Kind -> TcM TcTyVar +newSigTyVar name kind + = do { uniq <- newUnique + ; let name' = setNameUnique name uniq + -- Use the same OccName so that the tidy-er + -- doesn't gratuitously rename 'a' to 'a0' etc + ; details <- newMetaDetails SigTv + ; return (mkTcTyVar name' kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_tclvl = tclvl }) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = ASSERT( isTcTyVar tv ) + do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; let name' = setNameUnique (tyVarName tv) uniq + details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + ; return (mkTcTyVar name' (tyVarKind tv) details') } + +mkTcTyVarName :: Unique -> FastString -> Name +mkTcTyVarName uniq str = mkSysTvName uniq str + +-- Works for both type and kind variables +readMetaTyVar :: TyVar -> TcM MetaDetails +readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) + readMutVar (metaTvRef tyvar) + +isFilledMetaTyVar :: TyVar -> TcM Bool +-- True of a filled-in (Indirect) meta type variable +isFilledMetaTyVar tv + | not (isTcTyVar tv) = return False + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isIndirect details) } + | otherwise = return False + +isUnfilledMetaTyVar :: TyVar -> TcM Bool +-- True of a un-filled-in (Flexi) meta type variable +isUnfilledMetaTyVar tv + | not (isTcTyVar tv) = return False + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isFlexi details) } + | otherwise = return False + +-------------------- +-- Works with both type and kind variables +writeMetaTyVar :: TcTyVar -> TcType -> TcM () +-- Write into a currently-empty MetaTyVar + +writeMetaTyVar tyvar ty + | not debugIsOn + = writeMetaTyVarRef tyvar (metaTvRef tyvar) ty + +-- Everything from here on only happens if DEBUG is on + | not (isTcTyVar tyvar) + = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) + return () + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) + return () + +-------------------- +writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () +-- Here the tyvar is for error checking only; +-- the ref cell must be for the same tyvar +writeMetaTyVarRef tyvar ref ty + | not debugIsOn + = do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + ; writeMutVar ref (Indirect ty) } + +-- Everything from here on only happens if DEBUG is on + | otherwise + = do { meta_details <- readMutVar ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcKind tv_kind + ; zonked_ty_kind <- zonkTcKind ty_kind + + -- Check for double updates + ; ASSERT2( isFlexi meta_details, + hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr meta_details) ) + + traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + ; writeMutVar ref (Indirect ty) + ; when ( not (isPredTy tv_kind) + -- Don't check kinds for updates to coercion variables + && not (zonked_ty_kind `tcIsSubKind` zonked_tv_kind)) + $ WARN( True, hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) ) ) + (return ()) } + where + tv_kind = tyVarKind tyvar + ty_kind = typeKind ty + +{- +************************************************************************ +* * + MetaTvs: TauTvs +* * +************************************************************************ +-} + +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newMetaTyVar (TauTv False) kind + +newFlexiTyVarTy :: Kind -> TcM TcType +newFlexiTyVarTy kind = do + tc_tyvar <- newFlexiTyVar kind + return (TyVarTy tc_tyvar) + +newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] +newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) + +newReturnTyVar :: Kind -> TcM TcTyVar +newReturnTyVar kind = newMetaTyVar ReturnTv kind + +newReturnTyVarTy :: Kind -> TcM TcType +newReturnTyVarTy kind = TyVarTy <$> newReturnTyVar kind + +tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar]) +-- Instantiate with META type variables +-- Note that this works for a sequence of kind and type +-- variables. Eg [ (k:BOX), (a:k->k) ] +-- Gives [ (k7:BOX), (a8:k7->k7) ] +tcInstTyVars tyvars = mapAccumLM tcInstTyVarX emptyTvSubst tyvars + -- emptyTvSubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +tcInstTyVarX subst tyvar + = do { uniq <- newUnique + ; details <- newMetaDetails (TauTv False) + ; let name = mkSystemName uniq (getOccName tyvar) + kind = substTy subst (tyVarKind tyvar) + new_tv = mkTcTyVar name kind details + ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } + +{- +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is give the free vars of a type that we +are about to wrap in a forall. + +It takes these free type/kind variables and + 1. Zonks them and remove globals + 2. Partitions into type and kind variables (kvs1, tvs) + 3. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) + 4. Calls zonkQuantifiedTyVar on each + +Step (3) is often unimportant, because the kind variable is often +also free in the type. Eg + Typeable k (a::k) +has free vars {k,a}. But the type (see Trac #7916) + (f::k->*) (a::k) +has free vars {f,a}, but we must add 'k' as well! Hence step (3). +-} + +quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- The input is a mixture of type and kind variables; a kind variable k +-- may occur *after* a tyvar mentioning k in its kind +-- Can be given a mixture of TcTyVars and TyVars, in the case of +-- associated type declarations + +quantifyTyVars gbl_tvs tkvs + = do { tkvs <- zonkTyVarsAndFV tkvs + ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs + ; let (kvs, tvs) = partitionVarSet isKindVar (closeOverKinds tkvs `minusVarSet` gbl_tvs) + -- NB kinds of tvs are zonked by zonkTyVarsAndFV + kvs2 = varSetElems kvs + qtvs = varSetElems tvs + + -- In the non-PolyKinds case, default the kind variables + -- to *, and zonk the tyvars as usual. Notice that this + -- may make quantifyTyVars return a shorter list + -- than it was passed, but that's ok + ; poly_kinds <- xoptM Opt_PolyKinds + ; qkvs <- if poly_kinds + then return kvs2 + else do { let (meta_kvs, skolem_kvs) = partition is_meta kvs2 + is_meta kv = isTcTyVar kv && isMetaTyVar kv + ; mapM_ defaultKindVarToStar meta_kvs + ; return skolem_kvs } -- should be empty + + ; mapM zonk_quant (qkvs ++ qtvs) } + -- Because of the order, any kind variables + -- mentioned in the kinds of the type variables refer to + -- the now-quantified versions + where + zonk_quant tkv + | isTcTyVar tkv = zonkQuantifiedTyVar tkv + | otherwise = return tkv + -- For associated types, we have the class variables + -- in scope, and they are TyVars not TcTyVars + +zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +-- The quantified type variables often include meta type variables +-- we want to freeze them into ordinary type variables, and +-- default their kind (e.g. from OpenTypeKind to TypeKind) +-- -- see notes with Kind.defaultKind +-- The meta tyvar is updated to point to the new skolem TyVar. Now any +-- bound occurrences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. +zonkQuantifiedTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + SkolemTv {} -> do { kind <- zonkTcKind (tyVarKind tv) + ; return $ setTyVarKind tv kind } + -- It might be a skolem type variable, + -- for example from a user type signature + + MetaTv { mtv_ref = ref } -> + do when debugIsOn $ do + -- [Sept 04] Check for non-empty. + -- See note [Silly Type Synonym] + cts <- readMutVar ref + case cts of + Flexi -> return () + Indirect ty -> WARN( True, ppr tv $$ ppr ty ) + return () + skolemiseUnboundMetaTyVar tv vanillaSkolemTv + _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk + +defaultKindVarToStar :: TcTyVar -> TcM Kind +-- We have a meta-kind: unify it with '*' +defaultKindVarToStar kv + = do { ASSERT( isKindVar kv && isMetaTyVar kv ) + writeMetaTyVar kv liftedTypeKind + ; return liftedTypeKind } + +skolemiseUnboundMetaTyVar :: TcTyVar -> TcTyVarDetails -> TcM TyVar +-- We have a Meta tyvar with a ref-cell inside it +-- Skolemise it, including giving it a new Name, so that +-- we are totally out of Meta-tyvar-land +-- We create a skolem TyVar, not a regular TyVar +-- See Note [Zonking to Skolem] +skolemiseUnboundMetaTyVar tv details + = ASSERT2( isMetaTyVar tv, ppr tv ) + do { span <- getSrcSpanM -- Get the location from "here" + -- ie where we are generalising + ; uniq <- newUnique -- Remove it from TcMetaTyVar unique land + ; kind <- zonkTcKind (tyVarKind tv) + ; let tv_name = getOccName tv + new_tv_name = if isWildcardVar tv + then generaliseWildcardVarName tv_name + else tv_name + final_name = mkInternalName uniq new_tv_name span + final_kind = defaultKind kind + final_tv = mkTcTyVar final_name final_kind details + + ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + where + -- If a wildcard type called _a is generalised, we rename it to w_a + generaliseWildcardVarName :: OccName -> OccName + generaliseWildcardVarName name | startsWithUnderscore name + = mkOccNameFS (occNameSpace name) (appendFS (fsLit "w") (occNameFS name)) + generaliseWildcardVarName name = name + +{- +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem. The skolem is rigid +(which we require for a quantified variable), but is still a TcTyVar that the +simplifier knows how to deal with. + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + [Note Sept 04: now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () + +************************************************************************ +* * + Zonking types +* * +************************************************************************ + +@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. +To improve subsequent calls to the same function it writes the zonked set back into +the environment. +-} + +tcGetGlobalTyVars :: TcM TcTyVarSet +tcGetGlobalTyVars + = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv + ; gbl_tvs <- readMutVar gtv_var + ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs + ; writeMutVar gtv_var gbl_tvs' + ; return gbl_tvs' } + where + +zonkTcTypeAndFV :: TcType -> TcM TyVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty = do { ty <- zonkTcType ty; return (tyVarsOfType ty) } + +zonkTyVar :: TyVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv + | otherwise = return (mkTyVarTy tv) + -- Hackily, when typechecking type and class decls + -- we have TyVars in scopeadded (only) in + -- TcHsType.tcTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet +zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) + +zonkTcTyVars :: [TcTyVar] -> TcM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyVarKind :: TyVar -> TcM TyVar +zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTcTypes :: [TcType] -> TcM [TcType] +zonkTcTypes tys = mapM zonkTcType tys + +zonkTcThetaType :: TcThetaType -> TcM TcThetaType +zonkTcThetaType theta = mapM zonkTcPredType theta + +zonkTcPredType :: TcPredType -> TcM TcPredType +zonkTcPredType = zonkTcType + +{- +************************************************************************ +* * + Zonking constraints +* * +************************************************************************ +-} + +zonkImplication :: Implication -> TcM (Bag Implication) +zonkImplication implic@(Implic { ic_skols = skols + , ic_given = given + , ic_wanted = wanted + , ic_info = info }) + = do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds! + -- as Trac #7230 showed + ; given' <- mapM zonkEvVar given + ; info' <- zonkSkolemInfo info + ; wanted' <- zonkWCRec wanted + ; if isEmptyWC wanted' + then return emptyBag + else return $ unitBag $ + implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' } } + +zonkEvVar :: EvVar -> TcM EvVar +zonkEvVar var = do { ty' <- zonkTcType (varType var) + ; return (setVarType var ty') } + + +zonkWC :: WantedConstraints -> TcM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> TcM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) + = do { simple' <- zonkSimples simple + ; implic' <- flatMapBagM zonkImplication implic + ; insol' <- zonkSimples insol + ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) } + +zonkSimples :: Cts -> TcM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt' cts + ; traceTc "zonkSimples done:" (ppr cts') + ; return cts' } + +zonkCt' :: Ct -> TcM Ct +zonkCt' ct = zonkCt ct + +zonkCt :: Ct -> TcM Ct +zonkCt ct@(CHoleCan { cc_ev = ev }) + = do { ev' <- zonkCtEvidence ev + ; return $ ct { cc_ev = ev' } } +zonkCt ct + = do { fl' <- zonkCtEvidence (cc_ev ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> TcM CtEvidence +zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred'}) } +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } +zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred' }) } + +zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo +zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty') } +zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfo skol_info = return skol_info + +{- +************************************************************************ +* * +\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} +* * +* For internal use only! * +* * +************************************************************************ +-} + +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> TcM TcId +zonkId id + = do { ty' <- zonkTcType (idType id) + ; return (Id.setIdType id ty') } + +-- For unbound, mutable tyvars, zonkType uses the function given to it +-- For tyvars bound at a for-all, zonkType zonks them to an immutable +-- type variable and zonks the kind too + +zonkTcType :: TcType -> TcM TcType +zonkTcType ty + = go ty + where + go (TyConApp tc tys) = do tys' <- mapM go tys + return (TyConApp tc tys') + -- Do NOT establish Type invariants, because + -- doing so is strict in the TyCOn. + -- See Note [Zonking inside the knot] in TcHsType + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + -- OK to do this because only strict in the structure + -- not in the TyCon. + -- See Note [Zonking inside the knot] in TcHsType + + -- The two interesting cases! + go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar + -- Ordinary (non Tc) tyvars occur inside quantified types + + go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv + ; ty' <- go ty + ; return (ForAllTy tv' ty') } + +zonkTcTyVarBndr :: TcTyVar -> TcM TcTyVar +-- A tyvar binder is never a unification variable (MetaTv), +-- rather it is always a skolems. BUT it may have a kind +-- that has not yet been zonked, and may include kind +-- unification variables. +zonkTcTyVarBndr tyvar + = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do + updateTyVarKindM zonkTcType tyvar + +zonkTcTyVar :: TcTyVar -> TcM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) do + case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + FlatSkol ty -> zonkTcType ty + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> zonkTcType ty } + where + zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv + ; return (TyVarTy z_tv) } + +{- +************************************************************************ +* * + Zonking kinds +* * +************************************************************************ +-} + +zonkTcKind :: TcKind -> TcM TcKind +zonkTcKind k = zonkTcType k + +{- +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenType env ty') } + +zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) +zonkTidyOrigin env (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfo skol_info + ; let (env1, skol_info2) = tidySkolemInfo env skol_info1 + ; return (env1, GivenOrigin skol_info2) } +zonkTidyOrigin env (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType env act + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( env2, TypeEqOrigin { uo_actual = act', uo_expected = exp' }) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' ty2' orig') } +zonkTidyOrigin env (CoercibleOrigin ty1 ty2) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; return (env2, CoercibleOrigin ty1' ty2') } +zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; return (env2, FunDepOrigin1 p1' l1 p2' l2) } +zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; (env3, o1') <- zonkTidyOrigin env2 o1 + ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env orig = return (env, orig) + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +-- Also converts it to non-canonical +tidyCt env ct + = case ct of + CHoleCan { cc_ev = ev } + -> ct { cc_ev = tidy_ev env ev } + _ -> mkNonCanonical (tidy_ev env (ctEvidence ct)) + where + tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence + -- NB: we do not tidy the ctev_evtm/var field because we don't + -- show it in error messages + tidy_ev env ctev@(CtGiven { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtWanted { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtDerived { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + +---------------- +tidyEvVar :: TidyEnv -> EvVar -> EvVar +tidyEvVar env var = setVarType var (tidyType env (varType var)) + +---------------- +tidySkolemInfo :: TidyEnv -> SkolemInfo -> (TidyEnv, SkolemInfo) +tidySkolemInfo env (SigSkol cx ty) + = (env', SigSkol cx ty') + where + (env', ty') = tidyOpenType env ty + +tidySkolemInfo env (InferSkol ids) + = (env', InferSkol ids') + where + (env', ids') = mapAccumL do_one env ids + do_one env (name, ty) = (env', (name, ty')) + where + (env', ty') = tidyOpenType env ty + +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = (env1, UnifyForAllSkol skol_tvs' ty') + where + env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs) + (env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs + ty' = tidyType env2 ty + +tidySkolemInfo env info = (env, info) + +{- +************************************************************************ +* * + (Named) Wildcards +* * +************************************************************************ +-} + +-- | Create a new meta var with the given kind. This meta var should be used +-- to replace a wildcard in a type. Such a wildcard meta var can be +-- distinguished from other meta vars with the 'isWildcardVar' function. +newWildcardVar :: Name -> Kind -> TcM TcTyVar +newWildcardVar name kind = newNamedMetaTyVar name (TauTv True) kind + +-- | Create a new meta var (which can unify with a type of any kind). This +-- meta var should be used to replace a wildcard in a type. Such a wildcard +-- meta var can be distinguished from other meta vars with the 'isWildcardVar' +-- function. +newWildcardVarMetaKind :: Name -> TcM TcTyVar +newWildcardVarMetaKind name = do kind <- newMetaKindVar + newWildcardVar name kind + +-- | Return 'True' if the argument is a meta var created for a wildcard (by +-- 'newWildcardVar' or 'newWildcardVarMetaKind'). +isWildcardVar :: TcTyVar -> Bool +isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True +isWildcardVar _ = False diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs new file mode 100644 index 00000000..13d01c83 --- /dev/null +++ b/compiler/typecheck/TcMatches.hs @@ -0,0 +1,860 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +TcMatches: Typecheck some @Matches@ +-} + +{-# LANGUAGE CPP, RankNTypes #-} + +module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, + TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt + ) where + +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, + tcMonoExpr, tcMonoExprNC, tcPolyExpr ) + +import HsSyn +import BasicTypes +import TcRnMonad +import TcEnv +import TcPat +import TcMType +import TcType +import TcBinds +import TcUnify +import Name +import TysWiredIn +import Id +import TyCon +import TysPrim +import TcEvidence +import Outputable +import Util +import SrcLoc +import FastString + +-- Create chunkified tuple tybes for monad comprehensions +import MkCore + +import Control.Monad + +#include "HsVersions.h" + +{- +************************************************************************ +* * +\subsection{tcMatchesFun, tcMatchesCase} +* * +************************************************************************ + +@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a +@FunMonoBind@. The second argument is the name of the function, which +is used in error messages. It checks that all the equations have the +same number of arguments before using @tcMatches@ to do the work. + +Note [Polymorphic expected type for tcMatchesFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcMatchesFun may be given a *sigma* (polymorphic) type +so it must be prepared to use tcGen to skolemise it. +See Note [sig_tau may be polymorphic] in TcPat. +-} + +tcMatchesFun :: Name -> Bool + -> MatchGroup Name (LHsExpr Name) + -> TcSigmaType -- Expected type of function + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) + -- Returns type of body +tcMatchesFun fun_name inf matches exp_ty + = do { -- Check that they all have the same no of arguments + -- Location is in the monad, set the caller so that + -- any inter-equation error messages get some vaguely + -- sensible location. Note: we have to do this odd + -- ann-grabbing, because we don't always have annotations in + -- hand when we call tcMatchesFun... + traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) + ; checkArgs fun_name matches + + ; (wrap_gen, (wrap_fun, group)) + <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho -> + -- Note [Polymorphic expected type for tcMatchesFun] + matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty matches + ; return (wrap_gen <.> wrap_fun, group) } + where + arity = matchGroupArity matches + herald = ptext (sLit "The equation(s) for") + <+> quotes (ppr fun_name) <+> ptext (sLit "have") + match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody } + +{- +@tcMatchesCase@ doesn't do the argument-count check because the +parser guarantees that each equation has exactly one argument. +-} + +tcMatchesCase :: (Outputable (body Name)) => + TcMatchCtxt body -- Case context + -> TcRhoType -- Type of scrutinee + -> MatchGroup Name (Located (body Name)) -- The case alternatives + -> TcRhoType -- Type of whole case expressions + -> TcM (MatchGroup TcId (Located (body TcId))) -- Translated alternatives + +tcMatchesCase ctxt scrut_ty matches res_ty + | isEmptyMatchGroup matches -- Allow empty case expressions + = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty, mg_origin = mg_origin matches }) + + | otherwise + = tcMatches ctxt [scrut_ty] res_ty matches + +tcMatchLambda :: MatchGroup Name (LHsExpr Name) -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) +tcMatchLambda match res_ty + = matchFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty match + where + n_pats = matchGroupArity match + herald = sep [ ptext (sLit "The lambda expression") + <+> quotes (pprSetDepth (PartWay 1) $ + pprMatches (LambdaExpr :: HsMatchContext Name) match), + -- The pprSetDepth makes the abstraction print briefly + ptext (sLit "has")] + match_ctxt = MC { mc_what = LambdaExpr, + mc_body = tcBody } + +-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. + +tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType + -> TcM (GRHSs TcId (LHsExpr TcId)) +-- Used for pattern bindings +tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty + where + match_ctxt = MC { mc_what = PatBindRhs, + mc_body = tcBody } + +matchFunTys + :: SDoc -- See Note [Herald for matchExpecteFunTys] in TcUnify + -> Arity + -> TcRhoType + -> ([TcSigmaType] -> TcRhoType -> TcM a) + -> TcM (HsWrapper, a) + +-- Written in CPS style for historical reasons; +-- could probably be un-CPSd, like matchExpectedTyConApp + +matchFunTys herald arity res_ty thing_inside + = do { (co, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty + ; res <- thing_inside pat_tys res_ty + ; return (coToHsWrapper (mkTcSymCo co), res) } + +{- +************************************************************************ +* * +\subsection{tcMatch} +* * +************************************************************************ +-} + +tcMatches :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> MatchGroup Name (Located (body Name)) + -> TcM (MatchGroup TcId (Located (body TcId))) + +data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: Located (body Name) -- Type checker for a body of + -- an alternative + -> TcRhoType + -> TcM (Located (body TcId)) } + +tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin }) + = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in + do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches + ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty, mg_origin = origin }) } + +------------- +tcMatch :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> LMatch Name (Located (body Name)) + -> TcM (LMatch TcId (Located (body TcId))) + +tcMatch ctxt pat_tys rhs_ty match + = wrapLocM (tc_match ctxt pat_tys rhs_ty) match + where + tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss) + = add_match_ctxt match $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ + tc_grhss ctxt maybe_rhs_sig grhss rhs_ty + ; return (Match Nothing pats' Nothing grhss') } + + tc_grhss ctxt Nothing grhss rhs_ty + = tcGRHSs ctxt grhss rhs_ty -- No result signature + + -- Result type sigs are no longer supported + tc_grhss _ (Just {}) _ _ + = panic "tc_ghrss" -- Rejected by renamer + + -- For (\x -> e), tcExpr has already said "In the expresssion \x->e" + -- so we don't want to add "In the lambda abstraction \x->e" + add_match_ctxt match thing_inside + = case mc_what ctxt of + LambdaExpr -> thing_inside + m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside + +------------- +tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType + -> TcM (GRHSs TcId (Located (body TcId))) + +-- Notice that we pass in the full res_ty, so that we get +-- good inference from simple things like +-- f = \(x::forall a.a->a) -> +-- We used to force it to be a monotype when there was more than one guard +-- but we don't need to do that any more + +tcGRHSs ctxt (GRHSs grhss binds) res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss + + ; return (GRHSs grhss' binds') } + +------------- +tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name)) + -> TcM (GRHS TcId (Located (body TcId))) + +tcGRHS ctxt res_ty (GRHS guards rhs) + = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ + mc_body ctxt rhs + ; return (GRHS guards' rhs') } + where + stmt_ctxt = PatGuard (mc_what ctxt) + +{- +************************************************************************ +* * +\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} +* * +************************************************************************ +-} + +tcDoStmts :: HsStmtContext Name + -> [LStmt Name (LHsExpr Name)] + -> TcRhoType + -> TcM (HsExpr TcId) -- Returns a HsDo +tcDoStmts ListComp stmts res_ty + = do { (co, elt_ty) <- matchExpectedListTy res_ty + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty + ; return $ mkHsWrapCo co (HsDo ListComp stmts' list_ty) } + +tcDoStmts PArrComp stmts res_ty + = do { (co, elt_ty) <- matchExpectedPArrTy res_ty + ; let parr_ty = mkPArrTy elt_ty + ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty + ; return $ mkHsWrapCo co (HsDo PArrComp stmts' parr_ty) } + +tcDoStmts DoExpr stmts res_ty + = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; return (HsDo DoExpr stmts' res_ty) } + +tcDoStmts MDoExpr stmts res_ty + = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; return (HsDo MDoExpr stmts' res_ty) } + +tcDoStmts MonadComp stmts res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; return (HsDo MonadComp stmts' res_ty) } + +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) + +tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) +tcBody body res_ty + = do { traceTc "tcBody" (ppr res_ty) + ; body' <- tcMonoExpr body res_ty + ; return body' + } + +{- +************************************************************************ +* * +\subsection{tcStmts} +* * +************************************************************************ +-} + +type TcExprStmtChecker = TcStmtChecker HsExpr +type TcCmdStmtChecker = TcStmtChecker HsCmd + +type TcStmtChecker body + = forall thing. HsStmtContext Name + -> Stmt Name (Located (body Name)) + -> TcRhoType -- Result type for comprehension + -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt TcId (Located (body TcId)), thing) + +tcStmts :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> TcM [LStmt TcId (Located (body TcId))] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> (TcRhoType -> TcM thing) + -> TcM ([LStmt TcId (Located (body TcId))], thing) + +-- Note the higher-rank type. stmt_chk is applied at different +-- types in the equations for tcStmts + +tcStmtsAndThen _ _ [] res_ty thing_inside + = do { thing <- thing_inside res_ty + ; return ([], thing) } + +-- LetStmts are handled uniformly, regardless of context +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside + = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside + ; return (L loc (LetStmt binds') : stmts', thing) } + +-- For the vanilla case, handle the location-setting part +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside + = do { (stmt', (stmts', thing)) <- + setSrcSpan loc $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ + thing_inside + ; return (L loc stmt' : stmts', thing) } + +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside + = do { guard' <- tcMonoExpr guard boolTy + ; thing <- thing_inside res_ty + ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } + +tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcGuardStmt _ stmt _ _ + = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- List comprehensions and PArrays +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill +-- b) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt + +tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) + -> TcExprStmtChecker + +tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside + = do { body' <- tcMonoExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + +-- A generator, pat <- rhs +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside + = do { pat_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside elt_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +-- A boolean guard +tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside + = do { rhs' <- tcMonoExpr rhs boolTy + ; thing <- thing_inside elt_ty + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + +-- ParStmt: See notes with tcMcStmt +tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside + = do { (pairs', thing) <- loop bndr_stmts_s + ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) } + where + -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) + loop [] = do { thing <- thing_inside elt_ty + ; return ([], thing) } -- matching in the branches + + loop (ParStmtBlock stmts names _ : pairs) + = do { (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + do { ids <- tcLookupLocalIds names + ; (pairs', thing) <- loop pairs + ; return (ids, pairs', thing) } + ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) } + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcExprStmtChecker + +tcMcStmt _ (LastStmt body return_op) res_ty thing_inside + = do { a_ty <- newFlexiTyVarTy liftedTypeKind + ; return_op' <- tcSyntaxOp MCompOrigin return_op + (a_ty `mkFunTy` res_ty) + ; body' <- tcMonoExprNC body a_ty + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt body' return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; pat_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op + (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- if isIrrefutableHsPat pat + then return noSyntaxExpr + else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty) + + ; rhs' <- tcMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside new_res_ty + + ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + test_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcMonoExpr rhs test_ty + ; guard_op' <- tcSyntaxOp MCompOrigin guard_op + (mkFunTy test_ty rhs_ty) + ; then_op' <- tcSyntaxOp MCompOrigin then_op + (mkFunTys [rhs_ty, new_res_ty] res_ty) + ; thing <- thing_inside new_res_ty + ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m1_ty <- newFlexiTyVarTy star_star_kind + ; m2_ty <- newFlexiTyVarTy star_star_kind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy star_star_kind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; return_op' <- tcSyntaxOp MCompOrigin return_op $ + (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty' + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty) + `mkFunTy` res_ty + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noSyntaxExpr + _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ + mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ + (alphaTy `mkFunTy` betaTy) + `mkFunTy` (n_app alphaTy) + `mkFunTy` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + --------------- Bulding the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_fmap = fmap_op', trS_form = form }, thing) } + +-- A parallel set of comprehensions +-- [ (g x, h x) | ... ; let g v = ... +-- | ... ; let h v = ... ] +-- +-- It's possible that g,h are overloaded, so we need to feed the LIE from the +-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). +-- Similarly if we had an existential pattern match: +-- +-- data T = forall a. Show a => C a +-- +-- [ (show x, show y) | ... ; C x <- ... +-- | ... ; C y <- ... ] +-- +-- Then we need the LIE from (show x, show y) to be simplified against +-- the bindings for x and y. +-- +-- It's difficult to do this in parallel, so we rely on the renamer to +-- ensure that g,h and x,y don't duplicate, and simply grow the environment. +-- So the binders of the first parallel group will be in scope in the second +-- group. But that's fine; there's no shadowing to worry about. +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m_ty <- newFlexiTyVarTy star_star_kind + + ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkFunTy` + (m_ty `mkAppTy` betaTy) + `mkFunTy` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty + + ; (blocks', thing) <- loop m_ty bndr_stmts_s + + -- Typecheck bind: + ; let tys = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks'] + tuple_ty = mk_tuple_ty tys + + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + (m_ty `mkAppTy` tuple_ty) + `mkFunTy` (tuple_ty `mkFunTy` res_ty) + `mkFunTy` res_ty + + ; return (ParStmt blocks' mzip_op' bind_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + -- loop :: Type -- m_ty + -- -> [([LStmt Name], [Name])] + -- -> TcM ([([LStmt TcId], [TcId])], thing) + loop _ [] = do { thing <- thing_inside res_ty + ; return ([], thing) } -- matching in the branches + + loop m_ty (ParStmtBlock stmts names return_op : pairs) + = do { -- type dummy since we don't know all binder types yet + id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names + ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys + ; (stmts', (ids, return_op', pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' -> + do { ids <- tcLookupLocalIds names + ; let tup_ty = mkBigCoreVarTupTy ids + ; return_op' <- tcSyntaxOp MCompOrigin return_op + (tup_ty `mkFunTy` m_tup_ty') + ; (pairs', thing) <- loop m_ty pairs + ; return (ids, return_op', pairs', thing) } + ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- + +tcDoStmt :: TcExprStmtChecker + +tcDoStmt _ (LastStmt body _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + +tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + -- This level of generality is needed for using do-notation + -- in full generality; see Trac #1537 + + -- I'd like to put this *after* the tcSyntaxOp + -- (see Note [Treat rebindable syntax first], but that breaks + -- the rigidity info for GADTs. When we move to the new story + -- for GADTs, we can move this after tcSyntaxOp + rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; pat_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp DoOrigin bind_op + (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) + + -- If (but only if) the pattern can fail, + -- typecheck the 'fail' operator + ; fail_op' <- if isIrrefutableHsPat pat + then return noSyntaxExpr + else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) + + ; rhs' <- tcMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside new_res_ty + + ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + + +tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside + = do { -- Deal with rebindable syntax; + -- (>>) :: rhs_ty -> new_res_ty -> res_ty + -- See also Note [Treat rebindable syntax first] + rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; then_op' <- tcSyntaxOp DoOrigin then_op + (mkFunTys [rhs_ty, new_res_ty] res_ty) + + ; rhs' <- tcMonoExprNC rhs rhs_ty + ; thing <- thing_inside new_res_ty + ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } + +tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names, recS_ret_fn = ret_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) + res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + tup_ty = mkBigCoreTupTy tup_elt_tys + + ; tcExtendIdEnv tup_ids $ do + { stmts_ty <- newFlexiTyVarTy liftedTypeKind + ; (stmts', (ret_op', tup_rets)) + <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> + do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys + -- Unify the types of the "final" Ids (which may + -- be polymorphic) with those of "knot-tied" Ids + ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty) + ; return (ret_op', tup_rets) } + + ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind + ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op + (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty) + + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp DoOrigin bind_op + (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) + + ; thing <- thing_inside new_res_ty + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), + ppr later_ids <+> ppr (map idType later_ids)] + ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' + , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' + , recS_later_rets = [], recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty }, thing) + }} + +tcDoStmt _ stmt _ _ + = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) + +{- +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcMonoExprNC rhs). +Otherwise the error shows up when cheking the rebindable syntax, and +the expected/inferred stuff is back to front (see Trac #3613). + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ + +@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same +number of args are used in each equation. +-} + +checkArgs :: Name -> MatchGroup Name body -> TcM () +checkArgs _ (MG { mg_alts = [] }) + = return () +checkArgs fun (MG { mg_alts = match1:matches }) + | null bad_matches + = return () + | otherwise + = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> + ptext (sLit "have different numbers of arguments"), + nest 2 (ppr (getLoc match1)), + nest 2 (ppr (getLoc (head bad_matches)))]) + where + n_args1 = args_in_match match1 + bad_matches = [m | m <- matches, args_in_match m /= n_args1] + + args_in_match :: LMatch Name body -> Int + args_in_match (L _ (Match _ pats _ _)) = length pats diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot new file mode 100644 index 00000000..50bad30a --- /dev/null +++ b/compiler/typecheck/TcMatches.hs-boot @@ -0,0 +1,16 @@ +module TcMatches where +import HsSyn ( GRHSs, MatchGroup, LHsExpr ) +import TcEvidence( HsWrapper ) +import Name ( Name ) +import TcType ( TcRhoType ) +import TcRnTypes( TcM, TcId ) +--import SrcLoc ( Located ) + +tcGRHSsPat :: GRHSs Name (LHsExpr Name) + -> TcRhoType + -> TcM (GRHSs TcId (LHsExpr TcId)) + +tcMatchesFun :: Name -> Bool + -> MatchGroup Name (LHsExpr Name) + -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs new file mode 100644 index 00000000..b4790bf8 --- /dev/null +++ b/compiler/typecheck/TcPat.hs @@ -0,0 +1,1178 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +TcPat: Typechecking patterns +-} + +{-# LANGUAGE CPP, RankNTypes #-} + +module TcPat ( tcLetPat, TcSigFun, TcPragFun + , TcSigInfo(..), TcPatSynInfo(..) + , findScopedTyVars, isPartialSig + , LetBndrSpec(..), addInlinePrags, warnPrags + , tcPat, tcPats, newNoSigLetBndr + , addDataConStupidTheta, badFieldCon, polyPatSig ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho) + +import HsSyn +import TcHsSyn +import TcRnMonad +import Inst +import Id +import Var +import Name +import NameSet +import TcEnv +--import TcExpr +import TcMType +import TcValidity( arityErr ) +import TcType +import TcUnify +import TcHsType +import TysWiredIn +import TcEvidence +import TyCon +import DataCon +import PatSyn +import ConLike +import PrelNames +import BasicTypes hiding (SuccessFlag(..)) +import DynFlags +import SrcLoc +import Util +import Outputable +import FastString +import Control.Monad + +{- +************************************************************************ +* * + External interface +* * +************************************************************************ +-} + +tcLetPat :: TcSigFun -> LetBndrSpec + -> LPat Name -> TcSigmaType + -> TcM a + -> TcM (LPat TcId, a) +tcLetPat sig_fn no_gen pat pat_ty thing_inside + = tc_lpat pat pat_ty penv thing_inside + where + penv = PE { pe_lazy = True + , pe_ctxt = LetPat sig_fn no_gen } + +----------------- +tcPats :: HsMatchContext Name + -> [LPat Name] -- Patterns, + -> [TcSigmaType] -- and their types + -> TcM a -- and the checker for the body + -> TcM ([LPat TcId], a) + +-- This is the externally-callable wrapper function +-- Typecheck the patterns, extend the environment to bind the variables, +-- do the thing inside, use any existentially-bound dictionaries to +-- discharge parts of the returning LIE, and deal with pattern type +-- signatures + +-- 1. Initialise the PatState +-- 2. Check the patterns +-- 3. Check the body +-- 4. Check that no existentials escape + +tcPats ctxt pats pat_tys thing_inside + = tc_lpats penv pats pat_tys thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt } + +tcPat :: HsMatchContext Name + -> LPat Name -> TcSigmaType + -> TcM a -- Checker for body, given + -- its result type + -> TcM (LPat TcId, a) +tcPat ctxt pat pat_ty thing_inside + = tc_lpat pat pat_ty penv thing_inside + where + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt } + + +----------------- +data PatEnv + = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed + , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears + } + +data PatCtxt + = LamPat -- Used for lambdas, case etc + (HsMatchContext Name) + + | LetPat -- Used only for let(rec) pattern bindings + -- See Note [Typing patterns in pattern bindings] + TcSigFun -- Tells type sig if any + LetBndrSpec -- True <=> no generalisation of this let + +data LetBndrSpec + = LetLclBndr -- The binder is just a local one; + -- an AbsBinds will provide the global version + + | LetGblBndr TcPragFun -- Genrealisation plan is NoGen, so there isn't going + -- to be an AbsBinds; So we must bind the global version + -- of the binder right away. + -- Oh, and dhhere is the inline-pragma information + +makeLazy :: PatEnv -> PatEnv +makeLazy penv = penv { pe_lazy = True } + +inPatBind :: PatEnv -> Bool +inPatBind (PE { pe_ctxt = LetPat {} }) = True +inPatBind (PE { pe_ctxt = LamPat {} }) = False + +--------------- +type TcPragFun = Name -> [LSig Name] +type TcSigFun = Name -> Maybe TcSigInfo + +data TcSigInfo + = TcSigInfo { + sig_id :: TcId, -- *Polymorphic* binder for this value... + + sig_tvs :: [(Maybe Name, TcTyVar)], + -- Instantiated type and kind variables + -- Just n <=> this skolem is lexically in scope with name n + -- See Note [Binding scoped type variables] + + sig_nwcs :: [(Name, TcTyVar)], + -- Instantiated wildcard variables + + sig_theta :: TcThetaType, -- Instantiated theta + + sig_extra_cts :: Maybe SrcSpan, -- Just loc <=> An extra-constraints + -- wildcard was present. Any extra + -- constraints inferred during + -- type-checking will be added to the + -- partial type signature. Stores the + -- location of the wildcard. + + sig_tau :: TcSigmaType, -- Instantiated tau + -- See Note [sig_tau may be polymorphic] + + sig_loc :: SrcSpan, -- The location of the signature + + sig_partial :: Bool -- True <=> a partial type signature + -- containing wildcards + } + | TcPatSynInfo TcPatSynInfo + +data TcPatSynInfo + = TPSI { + patsig_name :: Name, + patsig_tau :: TcSigmaType, + patsig_ex :: [TcTyVar], + patsig_prov :: TcThetaType, + patsig_univ :: [TcTyVar], + patsig_req :: TcThetaType + } + +findScopedTyVars -- See Note [Binding scoped type variables] + :: LHsType Name -- The HsType + -> TcType -- The corresponding Type: + -- uses same Names as the HsType + -> [TcTyVar] -- The instantiated forall variables of the Type + -> [(Maybe Name, TcTyVar)] -- In 1-1 correspondence with the instantiated vars +findScopedTyVars hs_ty sig_ty inst_tvs + = zipWith find sig_tvs inst_tvs + where + find sig_tv inst_tv + | tv_name `elemNameSet` scoped_names = (Just tv_name, inst_tv) + | otherwise = (Nothing, inst_tv) + where + tv_name = tyVarName sig_tv + + scoped_names = mkNameSet (hsExplicitTvs hs_ty) + (sig_tvs,_) = tcSplitForAllTys sig_ty + +instance NamedThing TcSigInfo where + getName TcSigInfo{ sig_id = id } = idName id + getName (TcPatSynInfo tpsi) = patsig_name tpsi + +instance Outputable TcSigInfo where + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau }) + = ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) + , ppr (map fst tyvars) ] + ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi + +instance Outputable TcPatSynInfo where + ppr (TPSI{ patsig_name = name}) = ppr name + +isPartialSig :: TcSigInfo -> Bool +isPartialSig = sig_partial + +{- +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature may +be a subset of the *quantified type variables* of the signatures, for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *inital* ones! + +* Even aside from kind polymorphism, tere may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +The function findScopedTyVars takes + * hs_ty: the original HsForAllTy + * sig_ty: the corresponding Type (which is guaranteed to use the same Names + as the HsForAllTy) + * inst_tvs: the skolems instantiated from the forall's in sig_ty +It returns a [(Maybe Name, TcTyVar)], in 1-1 correspondence with inst_tvs +but with a (Just n) for the lexically scoped name of each in-scope tyvar. + +Note [sig_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that "sig_tau" might actually be a polymorphic type, +if the original function had a signature like + forall a. Eq a => forall b. Ord b => .... +But that's ok: tcMatchesFun (called by tcRhs) can deal with that +It happens, too! See Note [Polymorphic methods] in TcClassDcl. + +Note [Existential check] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns can't bind existentials. They arise in two ways: + * Let bindings let { C a b = e } in b + * Twiddle patterns f ~(C a b) = e +The pe_lazy field of PatEnv says whether we are inside a lazy +pattern (perhaps deeply) + +If we aren't inside a lazy pattern then we can bind existentials, +but we need to be careful about "extra" tyvars. Consider + (\C x -> d) : pat_ty -> res_ty +When looking for existential escape we must check that the existential +bound by C don't unify with the free variables of pat_ty, OR res_ty +(or of course the environment). Hence we need to keep track of the +res_ty free vars. + + +************************************************************************ +* * + Binders +* * +************************************************************************ +-} + +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercion, TcId) +-- (coi, xp) = tcPatBndr penv x pat_ty +-- Then coi : pat_ty ~ typeof(xp) +-- +tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty + -- See Note [Typing patterns in pattern bindings] + | LetGblBndr prags <- no_gen + , Just sig <- lookup_sig bndr_name + = do { bndr_id <- addInlinePrags (sig_id sig) (prags bndr_name) + ; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id)) + ; co <- unifyPatType (idType bndr_id) pat_ty + ; return (co, bndr_id) } + + | otherwise + = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty + ; traceTc "tcPatBndr(no-sig)" (ppr bndr_id $$ ppr (idType bndr_id)) + ; return (mkTcNomReflCo pat_ty, bndr_id) } + +tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty + = do { bndr <- mkLocalBinder bndr_name pat_ty + ; return (mkTcNomReflCo pat_ty, bndr) } + +------------ +newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId +-- In the polymorphic case (no_gen = LetLclBndr), generate a "monomorphic version" +-- of the Id; the original name will be bound to the polymorphic version +-- by the AbsBinds +-- In the monomorphic case (no_gen = LetBglBndr) there is no AbsBinds, and we +-- use the original name directly +newNoSigLetBndr LetLclBndr name ty + =do { mono_name <- newLocalName name + ; mkLocalBinder mono_name ty } +newNoSigLetBndr (LetGblBndr prags) name ty + = do { id <- mkLocalBinder name ty + ; addInlinePrags id (prags name) } + +---------- +addInlinePrags :: TcId -> [LSig Name] -> TcM TcId +addInlinePrags poly_id prags + = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) + ; tc_inl inl_sigs } + where + inl_sigs = filter isInlineLSig prags + tc_inl [] = return poly_id + tc_inl (L loc (InlineSig _ prag) : other_inls) + = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; return (poly_id `setInlinePragma` prag) } + tc_inl _ = panic "tc_inl" + + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + +warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () +warnPrags id bad_sigs herald + = addWarnTc (hang (herald <+> quotes (ppr id)) + 2 (ppr_sigs bad_sigs)) + where + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) + +----------------- +mkLocalBinder :: Name -> TcType -> TcM TcId +mkLocalBinder name ty + = return (Id.mkLocalId name ty) + +{- +Note [Typing patterns in pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are typing a pattern binding + pat = rhs +Then the PatCtxt will be (LetPat sig_fn let_bndr_spec). + +There can still be signatures for the binders: + data T = MkT (forall a. a->a) Int + x :: forall a. a->a + y :: Int + MkT x y = + +Two cases, dealt with by the LetPat case of tcPatBndr + + * If we are generalising (generalisation plan is InferGen or + CheckGen), then the let_bndr_spec will be LetLclBndr. In that case + we want to bind a cloned, local version of the variable, with the + type given by the pattern context, *not* by the signature (even if + there is one; see Trac #7268). The mkExport part of the + generalisation step will do the checking and impedence matching + against the signature. + + * If for some some reason we are not generalising (plan = NoGen), the + LetBndrSpec will be LetGblBndr. In that case we must bind the + global version of the Id, and do so with precisely the type given + in the signature. (Then we unify with the type from the pattern + context type. + + +************************************************************************ +* * + The main worker functions +* * +************************************************************************ + +Note [Nesting] +~~~~~~~~~~~~~~ +tcPat takes a "thing inside" over which the pattern scopes. This is partly +so that tcPat can extend the environment for the thing_inside, but also +so that constraints arising in the thing_inside can be discharged by the +pattern. + +This does not work so well for the ErrCtxt carried by the monad: we don't +want the error-context for the pattern to scope over the RHS. +Hence the getErrCtxt/setErrCtxt stuff in tcMultiple +-} + +-------------------- +type Checker inp out = forall r. + inp + -> PatEnv + -> TcM r + -> TcM (out, r) + +tcMultiple :: Checker inp out -> Checker [inp] [out] +tcMultiple tc_pat args penv thing_inside + = do { err_ctxt <- getErrCtxt + ; let loop _ [] + = do { res <- thing_inside + ; return ([], res) } + + loop penv (arg:args) + = do { (p', (ps', res)) + <- tc_pat arg penv $ + setErrCtxt err_ctxt $ + loop penv args + -- setErrCtxt: restore context before doing the next pattern + -- See note [Nesting] above + + ; return (p':ps', res) } + + ; loop penv args } + +-------------------- +tc_lpat :: LPat Name + -> TcSigmaType + -> PatEnv + -> TcM a + -> TcM (LPat TcId, a) +tc_lpat (L span pat) pat_ty penv thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + thing_inside + ; return (L span pat', res) } + +tc_lpats :: PatEnv + -> [LPat Name] -> [TcSigmaType] + -> TcM a + -> TcM ([LPat TcId], a) +tc_lpats penv pats tys thing_inside + = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) + tcMultiple (\(p,t) -> tc_lpat p t) + (zipEqual "tc_lpats" pats tys) + penv thing_inside + +-------------------- +tc_pat :: PatEnv + -> Pat Name + -> TcSigmaType -- Fully refined result type + -> TcM a -- Thing inside + -> TcM (Pat TcId, -- Translated pattern + a) -- Result of thing inside + +tc_pat penv (VarPat name) pat_ty thing_inside + = do { (co, id) <- tcPatBndr penv name pat_ty + ; res <- tcExtendIdEnv1 name id thing_inside + ; return (mkHsWrapPatCo co (VarPat id) pat_ty, res) } + +tc_pat penv (ParPat pat) pat_ty thing_inside + = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + ; return (ParPat pat', res) } + +tc_pat penv (BangPat pat) pat_ty thing_inside + = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside + ; return (BangPat pat', res) } + +tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside + = do { (pat', (res, pat_ct)) + <- tc_lpat pat pat_ty (makeLazy penv) $ + captureConstraints thing_inside + -- Ignore refined penv', revert to penv + + ; emitConstraints pat_ct + -- captureConstraints/extendConstraints: + -- see Note [Hopping the LIE in lazy patterns] + + -- Check there are no unlifted types under the lazy pattern + ; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $ + lazyUnliftedPatErr lpat + + -- Check that the expected pattern type is itself lifted + ; pat_ty' <- newFlexiTyVarTy liftedTypeKind + ; _ <- unifyType pat_ty pat_ty' + + ; return (LazyPat pat', res) } + +tc_pat _ p@(QuasiQuotePat _) _ _ + = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p) + +tc_pat _ (WildPat _) pat_ty thing_inside + = do { res <- thing_inside + ; return (WildPat pat_ty, res) } + +tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside + = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat pat (idType bndr_id) penv thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + +tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside + = do { + -- Morally, expr must have type `forall a1...aN. OPT' -> B` + -- where overall_pat_ty is an instance of OPT'. + -- Here, we infer a rho type for it, + -- which replaces the leading foralls and constraints + -- with fresh unification variables. + ; (expr',expr'_inferred) <- tcInferRho expr + + -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty` + -- NOTE: this forces pat_ty to be a monotype (because we use a unification + -- variable to find it). this means that in an example like + -- (view -> f) where view :: _ -> forall b. b + -- we will only be able to use view at one instantation in the + -- rest of the view + ; (expr_co, pat_ty) <- tcInfer $ \ pat_ty -> + unifyType expr'_inferred (mkFunTy overall_pat_ty pat_ty) + + -- pattern must have pat_ty + ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside + + ; return (ViewPat (mkLHsWrapCo expr_co expr') pat' overall_pat_ty, res) } + +-- Type signatures in patterns +-- See Note [Pattern coercions] below +tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside + = do { (inner_ty, tv_binds, nwc_binds, wrap) <- tcPatSig (inPatBind penv) + sig_ty pat_ty + ; (pat', res) <- tcExtendTyVarEnv2 (tv_binds ++ nwc_binds) $ + tc_lpat pat inner_ty penv thing_inside + ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } + +------------------------ +-- Lists, tuples, arrays +tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside + = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + pats penv thing_inside + ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + } + +tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside + = do { list_pat_ty <- newFlexiTyVarTy liftedTypeKind + ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty) + ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy list_pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + pats penv thing_inside + ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res) + } + +tc_pat penv (PArrPat pats _) pat_ty thing_inside + = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + pats penv thing_inside + ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) + } + +tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside + = do { let tc = tupleTyCon (boxityNormalTupleSort boxity) (length pats) + ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) pat_ty + ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside + + ; dflags <- getDynFlags + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + ; let + unmangled_result = TuplePat pats' boxity arg_tys + -- pat_ty /= pat_ty iff coi /= IdCo + possibly_mangled_result + | gopt Opt_IrrefutableTuples dflags && + isBoxed boxity = LazyPat (noLoc unmangled_result) + | otherwise = unmangled_result + + ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced + return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) + } + +------------------------ +-- Data constructors +tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside + = tcConPat penv con pat_ty arg_pats thing_inside + +------------------------ +-- Literal patterns +tc_pat _ (LitPat simple_lit) pat_ty thing_inside + = do { let lit_ty = hsLitType simple_lit + ; co <- unifyPatType lit_ty pat_ty + -- coi is of kind: pat_ty ~ lit_ty + ; res <- thing_inside + ; return ( mkHsWrapPatCo co (LitPat simple_lit) pat_ty + , res) } + +------------------------ +-- Overloaded patterns: n, and n+k +tc_pat _ (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside + = do { let orig = LiteralOrigin over_lit + ; lit' <- newOverloadedLit orig over_lit pat_ty + ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy) + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing -- Positive literal + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty) + ; return (Just neg') } + ; res <- thing_inside + ; return (NPat (L l lit') mb_neg' eq', res) } + +tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside + = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; let pat_ty' = idType bndr_id + orig = LiteralOrigin lit + ; lit' <- newOverloadedLit orig lit pat_ty' + + -- The '>=' and '-' parts are re-mappable syntax + ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy) + ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty') + ; let pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit') ge' minus' + + -- The Report says that n+k patterns must be in Integral + -- We may not want this when using re-mappable syntax, though (ToDo?) + ; icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty']] + + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + ; return (mkHsWrapPatCo co pat' pat_ty, res) } + +tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut + +---------------- +unifyPatType :: TcType -> TcType -> TcM TcCoercion +-- In patterns we want a coercion from the +-- context type (expected) to the actual pattern type +-- But we don't want to reverse the args to unifyType because +-- that controls the actual/expected stuff in error messages +unifyPatType actual_ty expected_ty + = do { coi <- unifyType actual_ty expected_ty + ; return (mkTcSymCo coi) } + +{- +Note [Hopping the LIE in lazy patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a lazy pattern, we must *not* discharge constraints from the RHS +from dictionaries bound in the pattern. E.g. + f ~(C x) = 3 +We can't discharge the Num constraint from dictionaries bound by +the pattern C! + +So we have to make the constraints from thing_inside "hop around" +the pattern. Hence the captureConstraints and emitConstraints. + +The same thing ensures that equality constraints in a lazy match +are not made available in the RHS of the match. For example + data T a where { T1 :: Int -> T Int; ... } + f :: T a -> Int -> a + f ~(T1 i) y = y +It's obviously not sound to refine a to Int in the right +hand side, because the arugment might not match T1 at all! + +Finally, a lazy pattern should not bind any existential type variables +because they won't be in scope when we do the desugaring + + +************************************************************************ +* * + Most of the work for constructors is here + (the rest is in the ConPatIn case of tc_pat) +* * +************************************************************************ + +[Pattern matching indexed data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following declarations: + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +and a case expression + + case x :: Map (Int, c) w of MapPair m -> ... + +As explained by [Wrappers for data instance tycons] in MkIds.lhs, the +worker/wrapper types for MapPair are + + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is +:R123Map, which means the straight use of boxySplitTyConApp would give a type +error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls +boxySplitTyConApp with the family tycon Map instead, which gives us the family +type list {(Int, c), w}. To get the correct split for :R123Map, we need to +unify the family type list {(Int, c), w} with the instance types {(a, b), v} +(provided by tyConFamInst_maybe together with the family tycon). This +unification yields the substitution [a -> Int, b -> c, v -> w], which gives us +the split arguments for the representation tycon :R123Map as {Int, c, w} + +In other words, boxySplitTyConAppWithFamily implicitly takes the coercion + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +moving between representation and family type into account. To produce type +correct Core, this coercion needs to be used to case the type of the scrutinee +from the family to the representation type. This is achieved by +unwrapFamInstScrutinee using a CoPat around the result pattern. + +Now it might appear seem as if we could have used the previous GADT type +refinement infrastructure of refineAlt and friends instead of the explicit +unification and CoPat generation. However, that would be wrong. Why? The +whole point of GADT refinement is that the refinement is local to the case +alternative. In contrast, the substitution generated by the unification of +the family type list and instance types needs to be propagated to the outside. +Imagine that in the above example, the type of the scrutinee would have been +(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the +substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the +instantiation of x with (a, b) must be global; ie, it must be valid in *all* +alternatives of the case expression, whereas in the GADT case it might vary +between alternatives. + +RIP GADT refinement: refinements have been replaced by the use of explicit +equality constraints that are used in conjunction with implication constraints +to express the local scope of GADT refinements. +-} + +-- Running example: +-- MkT :: forall a b c. (a~[b]) => b -> c -> T a +-- with scrutinee of type (T ty) + +tcConPat :: PatEnv -> Located Name + -> TcRhoType -- Type of the pattern + -> HsConPatDetails Name -> TcM a + -> TcM (Pat TcId, a) +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside + = do { con_like <- tcLookupConLike con_name + ; case con_like of + RealDataCon data_con -> tcDataConPat penv con_lname data_con + pat_ty arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn + pat_ty arg_pats thing_inside + } + +tcDataConPat :: PatEnv -> Located Name -> DataCon + -> TcRhoType -- Type of the pattern + -> HsConPatDetails Name -> TcM a + -> TcM (Pat TcId, a) +tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside + = do { let tycon = dataConTyCon data_con + -- For data families this is the representation tycon + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + header = L con_span (RealDataCon data_con) + + -- Instantiate the constructor type variables [a->ty] + -- This may involve doing a family-instance coercion, + -- and building a wrapper + ; (wrap, ctxt_res_tys) <- matchExpectedPatTy (matchExpectedConTy tycon) pat_ty + + -- Add the stupid theta + ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys + + ; checkExistentials ex_tvs penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX + (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs + -- Get location from monad, not from ex_tvs + + ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys + -- pat_ty' is type of the actual constructor application + -- pat_ty' /= pat_ty iff coi /= IdCo + + arg_tys' = substTys tenv arg_tys + + ; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec + , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' ]) + ; if null ex_tvs && null eq_spec && null theta + then do { -- The common case; no class bindings etc + -- (see Note [Arrows and patterns]) + (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' + arg_pats penv thing_inside + ; let res_pat = ConPatOut { pat_con = header, + pat_tvs = [], pat_dicts = [], + pat_binds = emptyTcEvBinds, + pat_args = arg_pats', + pat_arg_tys = ctxt_res_tys, + pat_wrap = idHsWrapper } + + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + + else do -- The general case, with existential, + -- and local equality constraints + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' + no_equalities = not (any isEqPred theta') + skol_info = case pe_ctxt penv of + LamPat mc -> PatSkol (RealDataCon data_con) mc + LetPat {} -> UnkSkol -- Doesn't matter + + ; gadts_on <- xoptM Opt_GADTs + ; families_on <- xoptM Opt_TypeFamilies + ; checkTc (no_equalities || gadts_on || families_on) + (text "A pattern match on a GADT requires the" <+> + text "GADTs or TypeFamilies language extension") + -- Trac #2905 decided that a *pattern-match* of a GADT + -- should require the GADT language flag. + -- Re TypeFamilies see also #7156 + + ; given <- newEvVars theta' + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' given $ + tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside + + ; let res_pat = ConPatOut { pat_con = header, + pat_tvs = ex_tvs', + pat_dicts = given, + pat_binds = ev_binds, + pat_args = arg_pats', + pat_arg_tys = ctxt_res_tys, + pat_wrap = idHsWrapper } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) + } } + +tcPatSynPat :: PatEnv -> Located Name -> PatSyn + -> TcRhoType -- Type of the pattern + -> HsConPatDetails Name -> TcM a + -> TcM (Pat TcId, a) +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside + = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn + + ; (subst, univ_tvs') <- tcInstTyVars univ_tvs + + ; checkExistentials ex_tvs penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; let ty' = substTy tenv ty + arg_tys' = substTys tenv arg_tys + prov_theta' = substTheta tenv prov_theta + req_theta' = substTheta tenv req_theta + + ; wrap <- coToHsWrapper <$> unifyType ty' pat_ty + ; traceTc "tcPatSynPat" (ppr pat_syn $$ + ppr pat_ty $$ + ppr ty' $$ + ppr ex_tvs' $$ + ppr prov_theta' $$ + ppr req_theta' $$ + ppr arg_tys') + + ; prov_dicts' <- newEvVars prov_theta' + + ; let skol_info = case pe_ctxt penv of + LamPat mc -> PatSkol (PatSynCon pat_syn) mc + LetPat {} -> UnkSkol -- Doesn't matter + + ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' + ; traceTc "instCall" (ppr req_wrap) + + ; traceTc "checkConstraints {" Outputable.empty + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' prov_dicts' $ + tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside + + ; traceTc "checkConstraints }" (ppr ev_binds) + ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, + pat_tvs = ex_tvs', + pat_dicts = prov_dicts', + pat_binds = ev_binds, + pat_args = arg_pats', + pat_arg_tys = mkTyVarTys univ_tvs', + pat_wrap = req_wrap } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + +---------------------------- +matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercion, a)) + -> TcRhoType -> TcM (HsWrapper, a) +-- See Note [Matching polytyped patterns] +-- Returns a wrapper : pat_ty ~ inner_ty +matchExpectedPatTy inner_match pat_ty + | null tvs && null theta + = do { (co, res) <- inner_match pat_ty + ; return (coToHsWrapper (mkTcSymCo co), res) } + -- The Sym is because the inner_match returns a coercion + -- that is the other way round to matchExpectedPatTy + + | otherwise + = do { (subst, tvs') <- tcInstTyVars tvs + ; wrap1 <- instCall PatOrigin (mkTyVarTys tvs') (substTheta subst theta) + ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau) + ; return (wrap2 <.> wrap1, arg_tys) } + where + (tvs, theta, tau) = tcSplitSigmaTy pat_ty + +---------------------------- +matchExpectedConTy :: TyCon -- The TyCon that this data + -- constructor actually returns + -> TcRhoType -- The type of the pattern + -> TcM (TcCoercion, [TcSigmaType]) +-- See Note [Matching constructor patterns] +-- Returns a coercion : T ty1 ... tyn ~ pat_ty +-- This is the same way round as matchExpectedListTy etc +-- but the other way round to matchExpectedPatTy +matchExpectedConTy data_tc pat_ty + | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc + -- Comments refer to Note [Matching constructor patterns] + -- co_tc :: forall a. T [a] ~ T7 a + = do { (subst, tvs') <- tcInstTyVars (tyConTyVars data_tc) + -- tys = [ty1,ty2] + + ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, + ppr (tyConTyVars data_tc), + ppr fam_tc, ppr fam_args]) + ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty + -- co1 : T (ty1,ty2) ~ pat_ty + + ; let tys' = mkTyVarTys tvs' + co2 = mkTcUnbranchedAxInstCo Nominal co_tc tys' + -- co2 : T (ty1,ty2) ~ T7 ty1 ty2 + + ; return (mkTcSymCo co2 `mkTcTransCo` co1, tys') } + + | otherwise + = matchExpectedTyConApp data_tc pat_ty + -- coi : T tys ~ pat_ty + +{- +Note [Matching constructor patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (coi, tys) = matchExpectedConType data_tc pat_ty + + * In the simple case, pat_ty = tc tys + + * If pat_ty is a polytype, we want to instantiate it + This is like part of a subsumption check. Eg + f :: (forall a. [a]) -> blah + f [] = blah + + * In a type family case, suppose we have + data family T a + data instance T (p,q) = A p | B q + Then we'll have internally generated + data T7 p q = A p | B q + axiom coT7 p q :: T (p,q) ~ T7 p q + + So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that + coi = coi2 . coi1 : T7 t ~ pat_ty + coi1 : T (ty1,ty2) ~ pat_ty + coi2 : T7 ty1 ty2 ~ T (ty1,ty2) + + For families we do all this matching here, not in the unifier, + because we never want a whisper of the data_tycon to appear in + error messages; it's a purely internal thing +-} + +tcConArgs :: ConLike -> [TcSigmaType] + -> Checker (HsConPatDetails Name) (HsConPatDetails Id) + +tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside + = do { checkTc (con_arity == no_of_args) -- Check correct arity + (arityErr "Constructor" con_like con_arity no_of_args) + ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys + ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys + penv thing_inside + ; return (PrefixCon arg_pats', res) } + where + con_arity = conLikeArity con_like + no_of_args = length arg_pats + +tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside + = do { checkTc (con_arity == 2) -- Check correct arity + (arityErr "Constructor" con_like con_arity 2) + ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check + ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] + penv thing_inside + ; return (InfixCon p1' p2', res) } + where + con_arity = conLikeArity con_like + +tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside + = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside + ; return (RecCon (HsRecFields rpats' dd), res) } + where + tc_field :: Checker (LHsRecField FieldLabel (LPat Name)) + (LHsRecField TcId (LPat TcId)) + tc_field (L l (HsRecField field_lbl pat pun)) penv thing_inside + = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl + ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside + ; return (L l (HsRecField sel_id pat' pun), res) } + + find_field_ty :: FieldLabel -> TcM (Id, TcType) + find_field_ty field_lbl + = case [ty | (f,ty) <- field_tys, f == field_lbl] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). If this happens, just fail, + -- otherwise we get crashes later (Trac #8570), and similar: + -- f (R { foo = (a,b) }) = a+b + -- If foo isn't one of R's fields, we don't want to crash when + -- typechecking the "a+b". + [] -> failWith (badFieldCon con_like field_lbl) + + -- The normal case, when the field comes from the right constructor + (pat_ty : extras) -> + ASSERT( null extras ) + do { sel_id <- tcLookupField field_lbl + ; return (sel_id, pat_ty) } + + field_tys :: [(FieldLabel, TcType)] + field_tys = case con_like of + RealDataCon data_con -> zip (dataConFieldLabels data_con) arg_tys + -- Don't use zipEqual! If the constructor isn't really a record, then + -- dataConFieldLabels will be empty (and each field in the pattern + -- will generate an error below). + PatSynCon{} -> [] + +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) +tcConArg (arg_pat, arg_ty) penv thing_inside + = tc_lpat arg_pat arg_ty penv thing_inside + +addDataConStupidTheta :: DataCon -> [TcType] -> TcM () +-- Instantiate the "stupid theta" of the data con, and throw +-- the constraints into the constraint set +addDataConStupidTheta data_con inst_tys + | null stupid_theta = return () + | otherwise = instStupidTheta origin inst_theta + where + origin = OccurrenceOf (dataConName data_con) + -- The origin should always report "occurrence of C" + -- even when C occurs in a pattern + stupid_theta = dataConStupidTheta data_con + tenv = mkTopTvSubst (dataConUnivTyVars data_con `zip` inst_tys) + -- NB: inst_tys can be longer than the univ tyvars + -- because the constructor might have existentials + inst_theta = substTheta tenv stupid_theta + +{- +Note [Arrows and patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Oct 07) Arrow noation has the odd property that it involves +"holes in the scope". For example: + expr :: Arrow a => a () Int + expr = proc (y,z) -> do + x <- term -< y + expr' -< x + +Here the 'proc (y,z)' binding scopes over the arrow tails but not the +arrow body (e.g 'term'). As things stand (bogusly) all the +constraints from the proc body are gathered together, so constraints +from 'term' will be seen by the tcPat for (y,z). But we must *not* +bind constraints from 'term' here, because the desugarer will not make +these bindings scope over 'term'. + +The Right Thing is not to confuse these constraints together. But for +now the Easy Thing is to ensure that we do not have existential or +GADT constraints in a 'proc', and to short-cut the constraint +simplification for such vanilla patterns so that it binds no +constraints. Hence the 'fast path' in tcConPat; but it's also a good +plan for ordinary vanilla patterns to bypass the constraint +simplification step. + +************************************************************************ +* * + Note [Pattern coercions] +* * +************************************************************************ + +In principle, these program would be reasonable: + + f :: (forall a. a->a) -> Int + f (x :: Int->Int) = x 3 + + g :: (forall a. [a]) -> Bool + g [] = True + +In both cases, the function type signature restricts what arguments can be passed +in a call (to polymorphic ones). The pattern type signature then instantiates this +type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we +generate the translated term + f = \x' :: (forall a. a->a). let x = x' Int in x 3 + +From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. +And it requires a significant amount of code to implement, because we need to decorate +the translated pattern with coercion functions (generated from the subsumption check +by tcSub). + +So for now I'm just insisting on type *equality* in patterns. No subsumption. + +Old notes about desugaring, at a time when pattern coercions were handled: + +A SigPat is a type coercion and must be handled one at at time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + + +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) + +----------------------------------------------- +checkExistentials :: [TyVar] -> PatEnv -> TcM () + -- See Note [Arrows and patterns] +checkExistentials [] _ = return () +checkExistentials _ (PE { pe_ctxt = LetPat {}}) = failWithTc existentialLetPat +checkExistentials _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat +checkExistentials _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat +checkExistentials _ _ = return () + +existentialLazyPat :: SDoc +existentialLazyPat + = hang (ptext (sLit "An existential or GADT data constructor cannot be used")) + 2 (ptext (sLit "inside a lazy (~) pattern")) + +existentialProcPat :: SDoc +existentialProcPat + = ptext (sLit "Proc patterns cannot use existential or GADT data constructors") + +existentialLetPat :: SDoc +existentialLetPat + = vcat [text "My brain just exploded", + text "I can't handle pattern bindings for existential or GADT data constructors.", + text "Instead, use a case-expression, or do-notation, to unpack the constructor."] + +badFieldCon :: ConLike -> Name -> SDoc +badFieldCon con field + = hsep [ptext (sLit "Constructor") <+> quotes (ppr con), + ptext (sLit "does not have field"), quotes (ppr field)] + +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) + 2 (ppr sig_ty) + +lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () +lazyUnliftedPatErr pat + = failWithTc $ + hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) + 2 (ppr pat) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs new file mode 100644 index 00000000..8e97f5b9 --- /dev/null +++ b/compiler/typecheck/TcPatSyn.hs @@ -0,0 +1,585 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcPatSyn]{Typechecking pattern synonym declarations} +-} + +{-# LANGUAGE CPP #-} + +module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl + , tcPatSynBuilderBind, tcPatSynBuilderOcc + ) where + +import HsSyn +import TcPat +import TcRnMonad +import TcEnv +import TcMType +import TysPrim +import Name +import SrcLoc +import PatSyn +import NameSet +import Panic +import Outputable +import FastString +import Var +import Id +import IdInfo( IdDetails(..) ) +import TcBinds +import BasicTypes +import TcSimplify +import TcUnify +import TcType +import TcEvidence +import BuildTyCl +import VarSet +import MkId +import VarEnv +import Inst +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid +#endif +import Bag +import Util +import Data.Maybe +import Control.Monad (forM) + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Type checking a pattern synonym +* * +************************************************************************ +-} + +tcInferPatSynDecl :: PatSynBind Name Name + -> TcM (PatSyn, LHsBinds Id) +tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, + psb_def = lpat, psb_dir = dir } + = setSrcSpan loc $ + do { traceTc "tcInferPatSynDecl {" $ ppr name + ; tcCheckPatSynPat lpat + + ; let (arg_names, is_infix) = case details of + PrefixPatSyn names -> (map unLoc names, False) + InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) + ; (((lpat', (args, pat_ty)), tclvl), wanted) + <- captureConstraints $ + captureTcLevel $ + do { pat_ty <- newFlexiTyVarTy openTypeKind + ; tcPat PatSyn lpat pat_ty $ + do { args <- mapM tcLookupId arg_names + ; return (args, pat_ty) } } + + ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args + + ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False named_taus wanted + + ; (ex_vars, prov_dicts) <- tcCollectEx lpat' + ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs + ex_tvs = varSetElems ex_vars + prov_theta = map evVarPred prov_dicts + req_theta = map evVarPred req_dicts + + ; traceTc "tcInferPatSynDecl }" $ ppr name + ; tc_patsyn_finish lname dir is_infix lpat' + (univ_tvs, req_theta, ev_binds, req_dicts) + (ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts) + (zip args $ repeat idHsWrapper) + pat_ty } + +tcCheckPatSynDecl :: PatSynBind Name Name + -> TcPatSynInfo + -> TcM (PatSyn, LHsBinds Id) +tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, + psb_def = lpat, psb_dir = dir } + TPSI{ patsig_tau = tau, + patsig_ex = ex_tvs, patsig_univ = univ_tvs, + patsig_prov = prov_theta, patsig_req = req_theta } + = setSrcSpan loc $ + do { traceTc "tcCheckPatSynDecl" $ + ppr (ex_tvs, prov_theta) $$ + ppr (univ_tvs, req_theta) $$ + ppr arg_tys $$ + ppr tau + ; tcCheckPatSynPat lpat + + ; req_dicts <- newEvVars req_theta + + -- TODO: find a better SkolInfo + ; let skol_info = SigSkol (FunSigCtxt name) (mkFunTys arg_tys pat_ty) + + ; let (arg_names, is_infix) = case details of + PrefixPatSyn names -> (map unLoc names, False) + InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) + + ; let ty_arity = length arg_tys + ; checkTc (length arg_names == ty_arity) + (wrongNumberOfParmsErr ty_arity) + + -- Typecheck the pattern against pat_ty, then unify the type of args + -- against arg_tys, with ex_tvs changed to SigTyVars. + -- We get out of this: + -- * The evidence bindings for the requested theta: req_ev_binds + -- * The typechecked pattern: lpat' + -- * The arguments, type-coerced to the SigTyVars: wrapped_args + -- * The instantiation of ex_tvs to pass to the success continuation: ex_tys + -- * The provided theta substituted with the SigTyVars: prov_theta' + ; (implic1, req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <- + buildImplication skol_info univ_tvs req_dicts $ + tcPat PatSyn lpat pat_ty $ do + { ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs + ; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $ + zipTyEnv ex_tvs (map mkTyVarTy ex_sigtvs) + ; let ex_tys = substTys subst $ map mkTyVarTy ex_tvs + prov_theta' = substTheta subst prov_theta + ; wrapped_args <- forM (zipEqual "tcCheckPatSynDecl" arg_names arg_tys) $ \(arg_name, arg_ty) -> do + { arg <- tcLookupId arg_name + ; let arg_ty' = substTy subst arg_ty + ; coi <- unifyType (varType arg) arg_ty' + ; return (setVarType arg arg_ty, coToHsWrapper coi) } + ; return (ex_tys, prov_theta', wrapped_args) } + + ; (ex_vars_rhs, prov_dicts_rhs) <- tcCollectEx lpat' + ; let ex_tvs_rhs = varSetElems ex_vars_rhs + + -- Check that prov_theta' can be satisfied with the dicts from the pattern + ; (implic2, prov_ev_binds, prov_dicts) <- + buildImplication skol_info ex_tvs_rhs prov_dicts_rhs $ do + { let origin = PatOrigin -- TODO + ; emitWanteds origin prov_theta' } + + -- Solve the constraints now, because we are about to make a PatSyn, + -- which should not contain unification variables and the like (Trac #10997) + -- Since all the inputs are implications the returned bindings will be empty + ; _ <- simplifyTop (emptyWC `addImplics` (implic1 `unionBags` implic2)) + + ; traceTc "tcCheckPatSynDecl }" $ ppr name + ; tc_patsyn_finish lname dir is_infix lpat' + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts) + wrapped_args + pat_ty } + where + (arg_tys, pat_ty) = tcSplitFunTys tau + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr ty_arity + = ptext (sLit "Number of pattern synonym arguments doesn't match type; expected") + <+> ppr ty_arity + +------------------------- +-- Shared by both tcInferPatSyn and tcCheckPatSyn +tc_patsyn_finish :: Located Name + -> HsPatSynDir Name + -> Bool + -> LPat Id + -> ([TcTyVar], [PredType], TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar]) + -> [(Var, HsWrapper)] + -> TcType + -> TcM (PatSyn, LHsBinds Id) +tc_patsyn_finish lname dir is_infix lpat' + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) + wrapped_args + pat_ty + = do { -- Zonk everything. We are about to build a final PatSyn + -- so there had better be no unification variables in there + univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs + ; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs + ; prov_theta <- zonkTcThetaType prov_theta + ; req_theta <- zonkTcThetaType req_theta + ; pat_ty <- zonkTcType pat_ty + ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args + ; let qtvs = univ_tvs ++ ex_tvs + theta = prov_theta ++ req_theta + arg_tys = map (varType . fst) wrapped_args + + ; traceTc "tc_patsyn_finish {" $ + ppr (unLoc lname) $$ ppr (unLoc lpat') $$ + ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ + ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$ + ppr wrapped_args $$ + ppr pat_ty + + -- Make the 'matcher' + ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) + wrapped_args -- Not necessarily zonked + pat_ty + + -- Make the 'builder' + ; builder_id <- mkPatSynBuilderId dir lname qtvs theta arg_tys pat_ty + + -- Make the PatSyn itself + ; let patSyn = mkPatSyn (unLoc lname) is_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys + pat_ty + matcher_id builder_id + + ; return (patSyn, matcher_bind) } + where + zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper) + -- The HsWrapper will get zonked later, as part of the LHsBinds + zonk_wrapped_arg (arg_id, wrap) = do { arg_id <- zonkId arg_id + ; return (arg_id, wrap) } + +{- +************************************************************************ +* * + Constructing the "matcher" Id and its binding +* * +************************************************************************ +-} + +tcPatSynMatcher :: Located Name + -> LPat Id + -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar]) + -> [(Var, HsWrapper)] + -> TcType + -> TcM ((Id, Bool), LHsBinds Id) +-- See Note [Matchers and builders for pattern synonyms] in PatSyn +tcPatSynMatcher (L loc name) lpat + (univ_tvs, req_theta, req_ev_binds, req_dicts) + (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts) + wrapped_args pat_ty + = do { uniq <- newUnique + ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc + res_tv = mkTcTyVar tv_name openTypeKind (SkolemTv False) + is_unlifted = null wrapped_args && null prov_dicts + res_ty = mkTyVarTy res_tv + (cont_arg_tys, cont_args) + | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId]) + | otherwise = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg) + | (arg, wrap) <- wrapped_args + ] + cont_ty = mkSigmaTy ex_tvs prov_theta $ + mkFunTys cont_arg_tys res_ty + + fail_ty = mkFunTy voidPrimTy res_ty + + ; matcher_name <- newImplicitBinder name mkMatcherOcc + ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty + ; cont <- newSysLocalId (fsLit "cont") cont_ty + ; fail <- newSysLocalId (fsLit "fail") fail_ty + + ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty + matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma + -- See Note [Exported LocalIds] in Id + + cont_dicts = map nlHsVar prov_dicts + cont' = mkLHsWrap (mkWpLet prov_ev_binds) $ + nlHsTyApps cont ex_tys (cont_dicts ++ cont_args) + + fail' = nlHsApps fail [nlHsVar voidPrimId] + + args = map nlVarPat [scrutinee, cont, fail] + lwpat = noLoc $ WildPat pat_ty + cases = if isIrrefutableHsPat lpat + then [mkSimpleHsAlt lpat cont'] + else [mkSimpleHsAlt lpat cont', + mkSimpleHsAlt lwpat fail'] + body = mkLHsWrap (mkWpLet req_ev_binds) $ + L (getLoc lpat) $ + HsCase (nlHsVar scrutinee) $ + MG{ mg_alts = cases + , mg_arg_tys = [pat_ty] + , mg_res_ty = res_ty + , mg_origin = Generated + } + body' = noLoc $ + HsLam $ + MG{ mg_alts = [mkSimpleMatch args body] + , mg_arg_tys = [pat_ty, cont_ty, res_ty] + , mg_res_ty = res_ty + , mg_origin = Generated + } + match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds + mg = MG{ mg_alts = [match] + , mg_arg_tys = [] + , mg_res_ty = res_ty + , mg_origin = Generated + } + + ; let bind = FunBind{ fun_id = L loc matcher_id + , fun_infix = False + , fun_matches = mg + , fun_co_fn = idHsWrapper + , bind_fvs = emptyNameSet + , fun_tick = [] } + matcher_bind = unitBag (noLoc bind) + + ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) + ; traceTc "tcPatSynMatcher" (ppr matcher_bind) + + ; return ((matcher_id, is_unlifted), matcher_bind) } + + +isUnidirectional :: HsPatSynDir a -> Bool +isUnidirectional Unidirectional = True +isUnidirectional ImplicitBidirectional = False +isUnidirectional ExplicitBidirectional{} = False + +{- +************************************************************************ +* * + Constructing the "builder" Id +* * +************************************************************************ +-} + +mkPatSynBuilderId :: HsPatSynDir a -> Located Name + -> [TyVar] -> ThetaType -> [Type] -> Type + -> TcM (Maybe (Id, Bool)) +mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty + | isUnidirectional dir + = return Nothing + | otherwise + = do { builder_name <- newImplicitBinder name mkBuilderOcc + ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) + builder_id = mkExportedLocalId VanillaId builder_name builder_sigma + -- See Note [Exported LocalIds] in Id + ; return (Just (builder_id, need_dummy_arg)) } + where + builder_arg_tys | need_dummy_arg = [voidPrimTy] + | otherwise = arg_tys + need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta + +tcPatSynBuilderBind :: PatSynBind Name Name + -> TcM (LHsBinds Id) +-- See Note [Matchers and builders for pattern synonyms] in PatSyn +tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat + , psb_dir = dir, psb_args = details } + | isUnidirectional dir + = return emptyBag + + | isNothing mb_match_group -- Can't invert the pattern + = setSrcSpan (getLoc lpat) $ failWithTc $ + hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression")) + 2 (ppr lpat) + + | otherwise + = do { patsyn <- tcLookupPatSyn name + ; let (worker_id, need_dummy_arg) = fromMaybe (panic "mkPatSynWrapper") $ + patSynBuilder patsyn + + ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds + mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy] + | otherwise = mg + + ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id) + bind = FunBind { fun_id = L loc (idName worker_id) + , fun_infix = False + , fun_matches = mg' + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNamesTc + , fun_tick = [] } + + sig = TcSigInfo{ sig_id = worker_id + , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs + , sig_theta = worker_theta + , sig_tau = worker_tau + , sig_loc = noSrcSpan + , sig_extra_cts = Nothing + , sig_partial = False + , sig_nwcs = [] + } + + ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) + ; traceTc "tcPatSynDecl worker" $ ppr worker_binds + ; return worker_binds } + where + Just mg = mb_match_group + mb_match_group = case dir of + Unidirectional -> Nothing + ExplicitBidirectional mg -> Just mg + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) + + mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name) + mk_mg body = mkMatchGroupName Generated [wrapper_match] + where + wrapper_args = [L loc (VarPat n) | L loc n <- args] + wrapper_match = mkMatch wrapper_args body EmptyLocalBinds + + args = case details of + PrefixPatSyn args -> args + InfixPatSyn arg1 arg2 -> [arg1, arg2] + +tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType) +-- The result type should be fully instantiated +tcPatSynBuilderOcc orig ps + | Just (builder_id, add_void_arg) <- builder + = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id) + ; let inst_fun = mkHsWrap wrap (HsVar builder_id) + ; if add_void_arg + then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId) + , tcFunResultTy rho ) + else return ( inst_fun, rho ) } + + | otherwise -- Unidirectional + = failWithTc $ + ptext (sLit "non-bidirectional pattern synonym") + <+> quotes (ppr name) <+> ptext (sLit "used in an expression") + where + name = patSynName ps + builder = patSynBuilder ps + +{- +************************************************************************ +* * + Helper functions +* * +************************************************************************ + +Note [As-patterns in pattern synonym definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The rationale for rejecting as-patterns in pattern synonym definitions +is that an as-pattern would introduce nonindependent pattern synonym +arguments, e.g. given a pattern synonym like: + + pattern K x y = x@(Just y) + +one could write a nonsensical function like + + f (K Nothing x) = ... + +or + g (K (Just True) False) = ... +-} + +tcCheckPatSynPat :: LPat Name -> TcM () +tcCheckPatSynPat = go + where + go :: LPat Name -> TcM () + go = addLocM go1 + + go1 :: Pat Name -> TcM () + go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) + go1 VarPat{} = return () + go1 WildPat{} = return () + go1 p@(AsPat _ _) = asPatInPatSynErr p + go1 (LazyPat pat) = go pat + go1 (ParPat pat) = go pat + go1 (BangPat pat) = go pat + go1 (PArrPat pats _) = mapM_ go pats + go1 (ListPat pats _ _) = mapM_ go pats + go1 (TuplePat pats _ _) = mapM_ go pats + go1 LitPat{} = return () + go1 NPat{} = return () + go1 (SigPatIn pat _) = go pat + go1 (ViewPat _ pat _) = go pat + go1 p@SplicePat{} = thInPatSynErr p + go1 p@QuasiQuotePat{} = thInPatSynErr p + go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p + go1 ConPatOut{} = panic "ConPatOut in output of renamer" + go1 SigPatOut{} = panic "SigPatOut in output of renamer" + go1 CoPat{} = panic "CoPat in output of renamer" + +asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +asPatInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) + 2 (ppr pat) + +thInPatSynErr :: OutputableBndr name => Pat name -> TcM a +thInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:")) + 2 (ppr pat) + +nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +nPlusKPatInPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:")) + 2 (ppr pat) + +tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name) +tcPatToExpr args = go + where + lhsVars = mkNameSet (map unLoc args) + + go :: LPat Name -> Maybe (LHsExpr Name) + go (L loc (ConPatIn conName info)) + = do { let con = L loc (HsVar (unLoc conName)) + ; exprs <- mapM go (hsConPatArgs info) + ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs } + go (L loc p) = fmap (L loc) $ go1 p + + go1 :: Pat Name -> Maybe (HsExpr Name) + go1 (VarPat var) + | var `elemNameSet` lhsVars = return $ HsVar var + | otherwise = Nothing + go1 (LazyPat pat) = fmap HsPar $ go pat + go1 (ParPat pat) = fmap HsPar $ go pat + go1 (BangPat pat) = fmap HsPar $ go pat + go1 (PArrPat pats ptt) + = do { exprs <- mapM go pats + ; return $ ExplicitPArr ptt exprs } + go1 (ListPat pats ptt reb) + = do { exprs <- mapM go pats + ; return $ ExplicitList ptt (fmap snd reb) exprs } + go1 (TuplePat pats box _) + = do { exprs <- mapM go pats + ; return (ExplicitTuple (map (noLoc . Present) exprs) box) + } + go1 (LitPat lit) = return $ HsLit lit + go1 (NPat (L _ n) Nothing _) = return $ HsOverLit n + go1 (NPat (L _ n) (Just neg) _) + = return $ noLoc neg `HsApp` noLoc (HsOverLit n) + go1 (SigPatIn pat (HsWB ty _ _ wcs)) + = do { expr <- go pat + ; return $ ExprWithTySig expr ty wcs } + go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" + go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" + go1 (CoPat{}) = panic "CoPat in output of renamer" + go1 _ = Nothing + +-- Walk the whole pattern and for all ConPatOuts, collect the +-- existentially-bound type variables and evidence binding variables. +-- +-- These are used in computing the type of a pattern synonym and also +-- in generating matcher functions, since success continuations need +-- to be passed these pattern-bound evidences. +tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar]) +tcCollectEx = return . go + where + go :: LPat Id -> (TyVarSet, [EvVar]) + go = go1 . unLoc + + go1 :: Pat Id -> (TyVarSet, [EvVar]) + go1 (LazyPat p) = go p + go1 (AsPat _ p) = go p + go1 (ParPat p) = go p + go1 (BangPat p) = go p + go1 (ListPat ps _ _) = mconcat . map go $ ps + go1 (TuplePat ps _ _) = mconcat . map go $ ps + go1 (PArrPat ps _) = mconcat . map go $ ps + go1 (ViewPat _ p _) = go p + go1 (QuasiQuotePat qq) = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq + go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $ + goConDetails $ pat_args con + go1 (SigPatOut p _) = go p + go1 (CoPat _ p _) = go1 p + go1 (NPlusKPat n k geq subtract) + = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract + go1 _ = mempty + + goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar]) + goConDetails (PrefixCon ps) = mconcat . map go $ ps + goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2 + goConDetails (RecCon HsRecFields{ rec_flds = flds }) + = mconcat . map goRecFd $ flds + + goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar]) + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot new file mode 100644 index 00000000..102404a0 --- /dev/null +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -0,0 +1,18 @@ +module TcPatSyn where + +import Name ( Name ) +import Id ( Id ) +import HsSyn ( PatSynBind, LHsBinds ) +import TcRnTypes ( TcM ) +import PatSyn ( PatSyn ) +import TcPat ( TcPatSynInfo ) + +tcInferPatSynDecl :: PatSynBind Name Name + -> TcM (PatSyn, LHsBinds Id) + +tcCheckPatSynDecl :: PatSynBind Name Name + -> TcPatSynInfo + -> TcM (PatSyn, LHsBinds Id) + +tcPatSynBuilderBind :: PatSynBind Name Name + -> TcM (LHsBinds Id) diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs new file mode 100644 index 00000000..5acf1b89 --- /dev/null +++ b/compiler/typecheck/TcPluginM.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} +-- | This module provides an interface for typechecker plugins to +-- access select functions of the 'TcM', principally those to do with +-- reading parts of the state. +module TcPluginM ( +#ifdef GHCI + -- * Basic TcPluginM functionality + TcPluginM, + tcPluginIO, + tcPluginTrace, + unsafeTcPluginTcM, + + -- * Finding Modules and Names + FindResult(..), + findImportedModule, + lookupOrig, + + -- * Looking up Names in the typechecking environment + tcLookupGlobal, + tcLookupTyCon, + tcLookupDataCon, + tcLookupClass, + tcLookup, + tcLookupId, + + -- * Getting the TcM state + getTopEnv, + getEnvs, + getInstEnvs, + getFamInstEnvs, + matchFam, + + -- * Type variables + newFlexiTyVar, + isTouchableTcPluginM, + + -- * Zonking + zonkTcType, + zonkCt +#endif + ) where + +#ifdef GHCI +import qualified TcRnMonad +import qualified TcSMonad +import qualified TcEnv +import qualified TcMType +import qualified Inst +import qualified FamInst +import qualified IfaceEnv +import qualified Finder + +import FamInstEnv ( FamInstEnv ) +import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, TcPluginM + , unsafeTcPluginTcM, liftIO, traceTc ) +import TcMType ( TcTyVar, TcType ) +import TcEnv ( TcTyThing ) +import TcEvidence ( TcCoercion ) + +import Module +import Name +import TyCon +import DataCon +import Class +import HscTypes +import Outputable +import Type +import Id +import InstEnv +import FastString + + +-- | Perform some IO, typically to interact with an external tool. +tcPluginIO :: IO a -> TcPluginM a +tcPluginIO a = unsafeTcPluginTcM (liftIO a) + +-- | Output useful for debugging the compiler. +tcPluginTrace :: String -> SDoc -> TcPluginM () +tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) + + +findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult +findImportedModule mod_name mb_pkg = do + hsc_env <- getTopEnv + tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg + +lookupOrig :: Module -> OccName -> TcPluginM Name +lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod + + +tcLookupGlobal :: Name -> TcPluginM TyThing +tcLookupGlobal = unsafeTcPluginTcM . TcEnv.tcLookupGlobal + +tcLookupTyCon :: Name -> TcPluginM TyCon +tcLookupTyCon = unsafeTcPluginTcM . TcEnv.tcLookupTyCon + +tcLookupDataCon :: Name -> TcPluginM DataCon +tcLookupDataCon = unsafeTcPluginTcM . TcEnv.tcLookupDataCon + +tcLookupClass :: Name -> TcPluginM Class +tcLookupClass = unsafeTcPluginTcM . TcEnv.tcLookupClass + +tcLookup :: Name -> TcPluginM TcTyThing +tcLookup = unsafeTcPluginTcM . TcEnv.tcLookup + +tcLookupId :: Name -> TcPluginM Id +tcLookupId = unsafeTcPluginTcM . TcEnv.tcLookupId + + +getTopEnv :: TcPluginM HscEnv +getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv + +getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) +getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs + +getInstEnvs :: TcPluginM InstEnvs +getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs + +getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) +getFamInstEnvs = unsafeTcPluginTcM FamInst.tcGetFamInstEnvs + +matchFam :: TyCon -> [Type] -> TcPluginM (Maybe (TcCoercion, TcType)) +matchFam tycon args = unsafeTcPluginTcM $ TcSMonad.matchFamTcM tycon args + + +newFlexiTyVar :: Kind -> TcPluginM TcTyVar +newFlexiTyVar = unsafeTcPluginTcM . TcMType.newFlexiTyVar + +isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool +isTouchableTcPluginM = unsafeTcPluginTcM . TcRnMonad.isTouchableTcM + + +zonkTcType :: TcType -> TcPluginM TcType +zonkTcType = unsafeTcPluginTcM . TcMType.zonkTcType + +zonkCt :: Ct -> TcPluginM Ct +zonkCt = unsafeTcPluginTcM . TcMType.zonkCt +#endif diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs new file mode 100644 index 00000000..fe319d05 --- /dev/null +++ b/compiler/typecheck/TcRnDriver.hs @@ -0,0 +1,2171 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcMovectle]{Typechecking a whole module} +-} + +{-# LANGUAGE CPP, NondecreasingIndentation #-} + +module TcRnDriver ( +#ifdef GHCI + tcRnStmt, tcRnExpr, tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, + isGHCiMonad, + runTcInteractive, -- Used by GHC API clients (Trac #8878) +#endif + tcRnLookupName, + tcRnGetInfo, + tcRnModule, tcRnModuleTcRnM, + tcTopSrcDecls, + ) where + +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runQuasi, traceSplice, SpliceInfo(..) ) +import RnSplice ( rnTopSpliceDecls ) +#endif + +import DynFlags +import StaticFlags +import HsSyn +import PrelNames +import RdrName +import TcHsSyn +import TcExpr +import TcRnMonad +import TcEvidence +import PprTyThing( pprTyThing ) +import Coercion( pprCoAxiom ) +import FamInst +import InstEnv +import FamInstEnv +import TcAnnotations +import TcBinds +import HeaderInfo ( mkPrelImports ) +import TcDefaults +import TcEnv +import TcRules +import TcForeign +import TcInstDcls +import TcIface +import TcMType +import MkIface +import TcSimplify +import TcTyClsDecls +import LoadIface +import RnNames +import RnEnv +import RnSource +import ErrUtils +import Id +import IdInfo( IdDetails( VanillaId ) ) +import VarEnv +import Module +import UniqFM +import Name +import NameEnv +import NameSet +import Avail +import TyCon +import SrcLoc +import HscTypes +import ListSetOps +import Outputable +import ConLike +import DataCon +import Type +import Class +import CoAxiom +import Annotations +import Data.List ( sortBy ) +import Data.Ord +#ifdef GHCI +import BasicTypes hiding( SuccessFlag(..) ) +import TcType ( isUnitTy, isTauTy ) +import TcHsType +import TcMatches +import RnTypes +import RnExpr +import MkId +import TidyPgm ( globaliseAndTidyId ) +import TysWiredIn ( unitTy, mkListTy ) +import DynamicLoading ( loadPlugins ) +import Plugins ( tcPlugin ) +#endif +import TidyPgm ( mkBootModDetailsTc ) + +import FastString +import Maybes +import Util +import Bag + +import Control.Monad + +#include "HsVersions.h" + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages, Maybe TcGblEnv) + +tcRnModule hsc_env hsc_src save_rn_syntax + parsedModule@HsParsedModule {hpm_module=L loc this_module} + | RealSrcSpan real_loc <- loc + = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; + + ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ + tcRnModuleTcRnM hsc_env hsc_src parsedModule pair } + + | otherwise + = return ((emptyBag, unitBag err_msg), Nothing) + + where + err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ + text "Module does not have a RealSrcSpan:" <+> ppr this_mod + + this_pkg = thisPackage (hsc_dflags hsc_env) + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkModule this_pkg mod, mod_loc) + + | otherwise -- 'module M where' is omitted + = (mAIN, srcLocSpan (srcSpanStart loc)) + + +-- To be called at the beginning of renaming hsig files. +-- If we're processing a signature, load up the RdrEnv +-- specified by sig-of so that +-- when we process top-level bindings, we pull in the right +-- original names. We also need to add in dependencies from +-- the implementation (orphans, family instances, packages), +-- similar to how rnImportDecl handles things. +-- ToDo: Handle SafeHaskell +tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv +tcRnSignature dflags hsc_src + = do { tcg_env <- getGblEnv ; + case tcg_sig_of tcg_env of { + Just sof + | hsc_src /= HsigFile -> do + { addErr (ptext (sLit "Illegal -sig-of specified for non hsig")) + ; return tcg_env + } + | otherwise -> do + { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof + ; let { gr = mkGlobalRdrEnv + (gresFromAvails LocalDef (mi_exports sig_iface)) + ; avails = calculateAvails dflags + sig_iface False{- safe -} False{- boot -} } + ; return (tcg_env + { tcg_impl_rdr_env = Just gr + , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails + }) + } ; + Nothing + | HsigFile <- hsc_src + , HscNothing <- hscTarget dflags -> do + { return tcg_env + } + | HsigFile <- hsc_src -> do + { addErr (ptext (sLit "Missing -sig-of for hsig")) + ; failM } + | otherwise -> return tcg_env + } + } + +checkHsigIface :: HscEnv -> TcGblEnv -> TcRn () +checkHsigIface hsc_env tcg_env + = case tcg_impl_rdr_env tcg_env of + Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env + ; checkHsigIface' gr sig_details + } + Nothing -> return () + +checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn () +checkHsigIface' gr + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports} + = do { traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + ; mapM_ check_export sig_exports + ; unless (null sig_fam_insts) $ + panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ + "instances in hsig files yet...") + ; mapM_ check_inst sig_insts + ; failIfErrsM + } + where + check_export sig_avail + -- Skip instances, we'll check them later + | name `elem` dfun_names = return () + | otherwise = do + { -- Lookup local environment only (don't want to accidentally pick + -- up the backing copy.) We consult tcg_type_env because we want + -- to pick up wired in names too (which get dropped by the iface + -- creation process); it's OK for a signature file to mention + -- a wired in name. + env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of + Nothing + -- All this means is no local definition is available: but we + -- could have created the export this way: + -- + -- module ASig(f) where + -- import B(f) + -- + -- In this case, we have to just lookup the identifier in + -- the backing implementation and make sure it matches. + | [GRE { gre_name = name' }] + <- lookupGlobalRdrEnv gr (nameOccName name) + , name == name' -> return () + -- TODO: Possibly give a different error if the identifier + -- is exported, but it's a different original name + | otherwise -> addErrAt (nameSrcSpan name) + (missingBootThing False name "exported by") + Just sig_thing -> do { + -- We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env. + ; r <- tcLookupImported_maybe name + ; case r of + Failed err -> addErr err + Succeeded real_thing -> checkBootDeclM False sig_thing real_thing + }} + where + name = availName sig_avail + + dfun_names = map getName sig_insts + + -- In general, for hsig files we can't assume that the implementing + -- file actually implemented the instances (they may be reexported + -- from elsewhere. Where should we look for the instances? We do + -- the same as we would otherwise: consult the EPS. This isn't + -- perfect (we might conclude the module exports an instance + -- when it doesn't, see #9422), but we will never refuse to compile + -- something + check_inst :: ClsInst -> TcM () + check_inst sig_inst + = do eps <- getEps + when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $ + addErrTc (instMisMatch False sig_inst) + +tcRnModuleTcRnM :: HscEnv + -> HscSource + -> HsParsedModule + -> (Module, SrcSpan) + -> TcRn TcGblEnv +-- Factored out separately so that a Core plugin can +-- call the type checker directly +tcRnModuleTcRnM hsc_env hsc_src + (HsParsedModule { + hpm_module = + (L loc (HsModule maybe_mod export_ies + import_decls local_decls mod_deprec + maybe_doc_hdr)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ + do { let { dflags = hsc_dflags hsc_env } ; + + tcg_env <- tcRnSignature dflags hsc_src ; + setGblEnv tcg_env $ do { + + -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM Opt_ImplicitPrelude; + let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } ; + + whenWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; + + tcg_env <- {-# SCC "tcRnImports" #-} + tcRnImports hsc_env (prel_imports ++ import_decls) ; + + -- If the whole module is warned about or deprecated + -- (via mod_deprec) record that in tcg_warns. If we do thereby add + -- a WarnAll, it will override any subseqent depracations added to tcg_warns + let { tcg_env1 = case mod_deprec of + Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt } + Nothing -> tcg_env + } ; + + setGblEnv tcg_env1 $ do { + + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; + + let { exports_occs = + maybe emptyBag + (listToBag . map (rdrNameOcc . ieName . unLoc) . unLoc) + export_ies + } ; + + -- Rename and type check the declarations + traceRn (text "rn1a") ; + tcg_env <- if isHsBootOrSig hsc_src then + tcRnHsBootDecls hsc_src local_decls + else + {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls boot_iface exports_occs local_decls ; + setGblEnv tcg_env $ do { + + -- Process the export list + traceRn (text "rn4a: before exports"); + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + traceRn (text "rn4b: after exports") ; + + -- Check that main is exported (must be after rnExports) + checkMainExported tcg_env ; + + -- Compare the hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_iface ; + + -- Compare the hsig tcg_env with the real thing + checkHsigIface hsc_env tcg_env ; + + -- Nub out type class instances now that we've checked them, + -- if we're compiling an hsig with sig-of. + -- See Note [Signature files and type class instances] + tcg_env <- (case tcg_sig_of tcg_env of + Just _ -> return tcg_env { + tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] + } + Nothing -> return tcg_env) ; + + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings + + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; + + -- Report unused names + reportUnusedNames export_ies tcg_env ; + + -- add extra source files to tcg_dependent_files + addDependentFiles src_files ; + + -- Dump output and return + tcDump tcg_env ; + return tcg_env + }}}} + +implicitPreludeWarn :: SDoc +implicitPreludeWarn + = ptext (sLit "Module `Prelude' implicitly imported") + +{- +************************************************************************ +* * + Import declarations +* * +************************************************************************ +-} + +tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv +tcRnImports hsc_env import_decls + = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; + + ; this_mod <- getModule + ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) + ; dep_mods = imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file. This + -- filtering also ensures that we don't see instances from + -- modules batch (@--make@) compiled before this one, but + -- which are not below this one. + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = rn_imports, + tcg_visible_orphan_mods = foldl extendModuleSet + (tcg_visible_orphan_mods gbl) + (imp_orphs imports), + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { + + ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + (imp_orphs imports) + + -- Check type-family consistency + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + + ; getGblEnv } } + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ +-} + +tcRnSrcDecls :: ModDetails -> Bag OccName -> [LHsDecl RdrName] -> TcM TcGblEnv + -- Returns the variables free in the decls + -- Reason: solely to report unused imports and bindings +tcRnSrcDecls boot_iface exports decls + = do { -- Do all the declarations + ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + ; traceTc "Tc8" empty ; + ; setEnvs (tcg_env, tcl_env) $ + do { + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ; + + -- Finish simplifying class constraints + -- + -- simplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- that checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + new_ev_binds <- {-# SCC "simplifyTop" #-} + simplifyTop (andWC stWC lie) ; + traceTc "Tc9" empty ; + + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + let { TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env + ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; + + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- {-# SCC "zonkTopDecls" #-} + zonkTopDecls all_ev_binds binds exports sig_ns rules vects + imp_specs fords ; + + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } } ; + + setGlobalTypeEnv tcg_env' final_type_env + + } } + +tc_rn_src_decls :: ModDetails + -> [LHsDecl RdrName] + -> TcM (TcGblEnv, TcLclEnv) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +tc_rn_src_decls boot_details ds + = {-# SCC "tc_rn_src_decls" #-} + do { (first_group, group_tail) <- findSplice ds + -- If ds is [] we get ([], Nothing) + + -- The extra_deps are needed while renaming type and class declarations + -- See Note [Extra dependencies from .hs-boot files] in RnSource + ; let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } + -- Deal with decls up to, but not including, the first splice + ; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group + -- rnTopSrcDecls fails if there are any errors + +#ifdef GHCI + -- Get TH-generated top-level declarations and make sure they don't + -- contain any splices since we don't handle that at the moment + ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + ; th_ds <- readTcRef th_topdecls_var + ; writeTcRef th_topdecls_var [] + + ; (tcg_env, rn_decls) <- + if null th_ds + then return (tcg_env, rn_decls) + else do { (th_group, th_group_tail) <- findSplice th_ds + ; case th_group_tail of + { Nothing -> return () ; + ; Just (SpliceDecl (L loc _) _, _) + -> setSrcSpan loc $ + addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls")) + } ; + + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ + rnTopSrcDecls extra_deps th_group + + -- Dump generated top-level declarations + ; let msg = "top-level declarations added with addTopDecls" + ; traceSplice $ SpliceInfo True + msg + Nothing + Nothing + (ppr th_rn_decls) + + ; return (tcg_env, appendGroups rn_decls th_rn_decls) + } +#endif /* GHCI */ + + -- Type check all declarations + ; (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls + + -- If there is no splice, we're nearly done + ; setEnvs (tcg_env, tcl_env) $ + case group_tail of + { Nothing -> do { tcg_env <- checkMain -- Check for `main' +#ifdef GHCI + -- Run all module finalizers + ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + ; modfinalizers <- readTcRef th_modfinalizers_var + ; writeTcRef th_modfinalizers_var [] + ; mapM_ runQuasi modfinalizers +#endif /* GHCI */ + ; return (tcg_env, tcl_env) + } + +#ifndef GHCI + -- There shouldn't be a splice + ; Just (SpliceDecl {}, _) -> + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") + } +#else + -- If there's a splice, we must carry on + ; Just (SpliceDecl (L _ splice) _, rest_ds) -> + do { -- Rename the splice expression, and get its supporting decls + (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice) + + -- Glue them on the front of the remaining decls and loop + ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) + } + } +#endif /* GHCI */ + } + +{- +************************************************************************ +* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +* * +************************************************************************ +-} + +tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv +tcRnHsBootDecls hsc_src decls + = do { (first_group, group_tail) <- findSplice decls + + -- Rename the declarations + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls [] first_group + -- The empty list is for extra dependencies coming from .hs-boot files + -- See Note [Extra dependencies from .hs-boot files] in RnSource + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { + + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d + Nothing -> return () + ; mapM_ (badBootDecl hsc_src "foreign") for_decls + ; mapM_ (badBootDecl hsc_src "default") def_decls + ; mapM_ (badBootDecl hsc_src "rule") rule_decls + ; mapM_ (badBootDecl hsc_src "vect") vect_decls + + -- Typecheck type/class/isntance decls + ; traceTc "Tc2 (boot)" empty + ; (tcg_env, inst_infos, _deriv_binds) + <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + -- Don't add the dictionaries for hsig, we don't actually want + -- to /define/ the instance + ; type_env2 | HsigFile <- hsc_src = type_env1 + | otherwise = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 + }} + ; traceTc "boot" (ppr lie); return gbl_env } + +badBootDecl :: HscSource -> String -> Located decl -> TcM () +badBootDecl hsc_src what (L loc _) + = addErrAt loc (char 'A' <+> text what + <+> ptext (sLit "declaration is not (currently) allowed in a") + <+> (case hsc_src of + HsBootFile -> ptext (sLit "hs-boot") + HsigFile -> ptext (sLit "hsig") + _ -> panic "badBootDecl: should be an hsig or hs-boot file") + <+> ptext (sLit "file")) + +{- +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} + +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. +-- +-- The bindings we return give bindings for the dfuns defined in the +-- hs-boot file, such as $fbEqT = $fEqT + +checkHiBootIface + tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, + tcg_insts = local_insts, + tcg_type_env = local_type_env, tcg_exports = local_exports }) + boot_details + | HsBootFile <- hs_src -- Current module is already a hs-boot file! + = return tcg_env + + | otherwise + = do { mb_dfun_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + ; let dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one + -- so that if the source module reads in an interface unfolding + -- mentioning one of the dfuns from the boot module, then it + -- can "see" that boot dfun. See Trac #4003 + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [Maybe (Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. + +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env, md_exports = boot_exports }) + = do { traceTc "checkHiBootIface" $ vcat + [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] + + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports + + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... + + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + + ; failIfErrsM + + ; return mb_dfun_prs } + + where + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + + -- Check that the actual module exports the same thing + | not (null missing_names) + = addErrAt (nameSrcSpan (head missing_names)) + (missingBootThing True (head missing_names) "exported by") + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing = return () + + -- Check that the actual module also defines the thing, and + -- then compare the definitions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = checkBootDeclM True boot_thing real_thing + + | otherwise + = addErrTc (missingBootThing True name "defined in") + where + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + + dfun_names = map getName boot_insts + + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_inst :: ClsInst -> TcM (Maybe (Id, Id)) + -- Returns a pair of the boot dfun in terms of the equivalent real dfun + check_inst boot_inst + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `eqType` boot_inst_ty ] of + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_inst" <+> ppr boot_inst + , text "boot_inst_ty" <+> ppr boot_inst_ty + ]) + ; addErrTc (instMisMatch True boot_inst); return Nothing } + (dfun:_) -> return (Just (local_boot_dfun, dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun + local_boot_dfun = Id.mkExportedLocalId VanillaId (idName boot_dfun) boot_inst_ty + + +-- This has to compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +checkBootDeclM is_boot boot_thing real_thing + = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> + addErrAt (nameSrcSpan (getName boot_thing)) + (bootMisMatch is_boot err real_thing boot_thing) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: TyThing -> TyThing -> Maybe SDoc + +checkBootDecl (AnId id1) (AnId id2) + = ASSERT(id1 == id2) + check (idType id1 `eqType` idType id2) + (text "The two types are different") + +checkBootDecl (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon tc1 tc2 + +checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = Just empty -- probably shouldn't happen + +-- | Combines two potential error messages +andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc +Nothing `andThenCheck` msg = msg +msg `andThenCheck` Nothing = msg +Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) +infixr 0 `andThenCheck` + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, return the provided check +checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc +checkUnless True _ = Nothing +checkUnless False k = k + +-- | Run the check provided for every pair of elements in the lists. +-- The provided SDoc should name the element type, in the plural. +checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc + -> Maybe SDoc +checkListBy check_fun as bs whats = go [] as bs + where + herald = text "The" <+> whats <+> text "do not match" + + go [] [] [] = Nothing + go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) + go docs (x:xs) (y:ys) = case check_fun x y of + Just doc -> go (doc:docs) xs ys + Nothing -> go docs xs ys + go _ _ _ = Just (hang (herald <> colon) + 2 (text "There are different numbers of" <+> whats)) + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, fail with the given SDoc. +check :: Bool -> SDoc -> Maybe SDoc +check True _ = Nothing +check False doc = Just doc + +-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. +checkSuccess :: Maybe SDoc +checkSuccess = Nothing + +---------------- +checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc +checkBootTyCon tc1 tc2 + | not (eqKind (tyConKind tc1) (tyConKind tc2)) + = Just $ text "The types have different kinds" -- First off, check the kind + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = let + eqSig (id1, def_meth1) (id2, def_meth2) + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "are different") `andThenCheck` + check (eqTypeX env op_ty1 op_ty2) + (text "The types of" <+> pname1 <+> + text "are different") `andThenCheck` + check (def_meth1 == def_meth2) + (text "The default methods associated with" <+> pname1 <+> + text "are different") + where + name1 = idName id1 + name2 = idName id2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) + op_ty2 = funResultTy rho_ty2 + + eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = checkBootTyCon tc1 tc2 `andThenCheck` + check (eqATDef def_ats1 def_ats2) + (text "The associated type defaults differ") + + -- Ignore the location of the defaults + eqATDef Nothing Nothing = True + eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + eqATDef _ _ = False + + eqFD (as1,bs1) (as2,bs2) = + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + in + check (roles1 == roles2) roles_msg `andThenCheck` + -- Checks kind of class + check (eqListBy eqFD clas_fds1 clas_fds2) + (text "The functional dependencies do not match") `andThenCheck` + checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $ + -- Above tests for an "abstract" class + check (eqListBy (eqPredX env) sc_theta1 sc_theta2) + (text "The class constraints do not match") `andThenCheck` + checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` + checkListBy eqAT ats1 ats2 (text "associated types") + + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = ASSERT(tc1 == tc2) + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say + + | Just fam_flav1 <- famTyConFlav_maybe tc1 + , Just fam_flav2 <- famTyConFlav_maybe tc2 + = ASSERT(tc1 == tc2) + let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True + eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True + eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True + eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 + eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 + eqFamFlav _ _ = False + in + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqFamFlav fam_flav1 fam_flav2) empty -- nothing interesting to say + + | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = ASSERT(tc1 == tc2) + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqListBy (eqPredX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + (text "The datatype contexts do not match") `andThenCheck` + eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) + + | otherwise = Just empty -- two very different types -- should be obvious + where + roles1 = tyConRoles tc1 + roles2 = tyConRoles tc2 + roles_msg = text "The roles do not match." <+> + (text "Roles default to" <+> + quotes (text "representational") <+> text "in boot files") + + eqAlgRhs tc (AbstractTyCon dis1) rhs2 + | dis1 = check (isDistinctAlgRhs rhs2) --Check compatibility + (text "The natures of the declarations for" <+> + quotes (ppr tc) <+> text "are different") + | otherwise = checkSuccess + eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess + eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") + eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition") + + eqCon c1 c2 + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "differ") `andThenCheck` + check (dataConIsInfix c1 == dataConIsInfix c2) + (text "The fixities of" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqListBy eqHsBang + (dataConSrcBangs c1) (dataConSrcBangs c2)) + (text "The strictness annotations for" <+> pname1 <+> + text "differ") `andThenCheck` + check (dataConFieldLabels c1 == dataConFieldLabels c2) + (text "The record label lists for" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqType (dataConUserType c1) (dataConUserType c2)) + (text "The types for" <+> pname1 <+> text "differ") + where + name1 = dataConName c1 + name2 = dataConName c2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + + eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) + (CoAxiom { co_ax_branches = branches2 }) + = brListLength branches1 == brListLength branches2 + && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2) + + eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 + = eqListBy (eqTypeX env) lhs1 lhs2 && + eqTypeX env rhs1 rhs2 + + | otherwise = False + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +---------------- +missingBootThing :: Bool -> Name -> String -> SDoc +missingBootThing is_boot name what + = ppr name <+> ptext (sLit "is exported by the") <+> + (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) + <+> ptext (sLit "file, but not") + <+> text what <+> ptext (sLit "the module") + +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch is_boot extra_info real_thing boot_thing + = vcat [ppr real_thing <+> + ptext (sLit "has conflicting definitions in the module"), + ptext (sLit "and its") <+> + (if is_boot then ptext (sLit "hs-boot file") + else ptext (sLit "hsig file")), + ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing, + (if is_boot + then ptext (sLit "Boot file: ") + else ptext (sLit "Hsig file: ")) + <+> PprTyThing.pprTyThing boot_thing, + extra_info] + +instMisMatch :: Bool -> ClsInst -> SDoc +instMisMatch is_boot inst + = hang (ppr inst) + 2 (ptext (sLit "is defined in the") <+> + (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) + <+> ptext (sLit "file, but not in the module itself")) + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ + +tcRnGroup takes a bunch of top-level source-code declarations, and + * renames them + * gets supporting declarations from interface files + * typechecks them + * zonks them + * and augments the TcGblEnv with the results + +In Template Haskell it may be called repeatedly for each group of +declarations. It expects there to be an incoming TcGblEnv in the +monad; it augments it and returns the new TcGblEnv. +-} + +------------------------------------------------ +rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +-- Fails if there are any errors +rnTopSrcDecls extra_deps group + = do { -- Rename the source decls + traceTc "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; + traceTc "rn13" empty ; + + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; + + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; + + return (tcg_env', rn_decls) + } + +{- +************************************************************************ +* * + tcTopSrcDecls +* * +************************************************************************ +-} + +tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls boot_details + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_valds = val_binds }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc "Tc3" empty ; + (tcg_env, inst_infos, deriv_binds) + <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ; + setGblEnv tcg_env $ do { + + + -- Generate Applicative/Monad proposal (AMP) warnings + traceTc "Tc3b" empty ; + + -- Foreign import declarations next. + traceTc "Tc4" empty ; + (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { + + -- Default declarations + traceTc "Tc4a" empty ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; + setEnvs tc_envs $ do { + + -- Value declarations next + traceTc "Tc5" empty ; + tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; + setEnvs tc_envs $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Vectorisation declarations + vects <- tcVectDecls vect_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; + let { all_binds = inst_binds `unionBags` + foe_binds + + ; fo_gres = fi_gres `unionBags` foe_gres + ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) + emptyFVs fo_gres + ; fo_rdr_names :: [RdrName] + ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres + + ; sig_names = mkNameSet (collectHsValBinders val_binds) + `minusNameSet` getTypeSigNames val_binds + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names + , tcg_rules = tcg_rules tcg_env + ++ flattenRuleDecls rules + , tcg_vects = tcg_vects tcg_env ++ vects + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + + addUsedRdrNames fo_rdr_names ; + return (tcg_env', tcl_env) + }}}}}} + where + gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName] + -- For *imported* newtype data constructors, we want to + -- make sure that at least one of the imports for them is used + -- See Note [Newtype constructor usage in foreign declarations] + gre_to_rdr_name gre rdrs + = case gre_prov gre of + LocalDef -> rdrs + Imported [] -> panic "gre_to_rdr_name: Imported []" + Imported (is : _) -> mkRdrQual modName occName : rdrs + where + modName = is_as (is_decl is) + occName = nameOccName (gre_name gre) + +--------------------------- +tcTyClsInstDecls :: ModDetails + -> [TyClGroup Name] + -> [LInstDecl Name] + -> [LDerivDecl Name] + -> TcM (TcGblEnv, -- The full inst env + [InstInfo Name], -- Source-code instance decls to process; + -- contains all dfuns for this module + HsValBinds Name) -- Supporting bindings for derived instances + +tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls + = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE) + | lid <- inst_decls, con <- get_cons lid ] $ + -- Note [AFamDataCon: not promoting data family constructors] + do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + ; setGblEnv tcg_env $ + tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls } + where + -- get_cons extracts the *constructor* bindings of the declaration + get_cons :: LInstDecl Name -> [Name] + get_cons (L _ (TyFamInstD {})) = [] + get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid + get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) + = concatMap (get_fi_cons . unLoc) fids + + get_fi_cons :: DataFamInstDecl Name -> [Name] + get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) + = map unLoc $ concatMap (con_names . unLoc) cons + +{- +Note [AFamDataCon: not promoting data family constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T Int = MkT + data Proxy (a :: k) + data S = MkS (Proxy 'MkT) + +Is it ok to use the promoted data family instance constructor 'MkT' in +the data declaration for S? No, we don't allow this. It *might* make +sense, but at least it would mean that we'd have to interleave +typechecking instances and data types, whereas at present we do data +types *then* instances. + +So to check for this we put in the TcLclEnv a binding for all the family +constructors, bound to AFamDataCon, so that if we trip over 'MkT' when +type checking 'S' we'll produce a decent error message. + + +************************************************************************ +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMain :: TcM TcGblEnv +-- If we are in module Main, check that 'main' is defined. +checkMain + = do { tcg_env <- getGblEnv ; + dflags <- getDynFlags ; + check_main dflags tcg_env + } + +check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv +check_main dflags tcg_env + | mod /= main_mod + = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> + return tcg_env + + | otherwise + = do { mb_main <- lookupGlobalOccRn_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) + ; complain_no_main + ; return tcg_env } ; + Just main_name -> do + + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; main_expr + <- addErrCtxt mainCtxt $ + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name, + tcg_binds = tcg_binds tcg_env + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + }) + }}} + where + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_fn = getMainFun dflags + + complain_no_main | ghcLink dflags == LinkInMemory = return () + | otherwise = failWithTc noMainMsg + -- In interactive mode, don't worry about the absence of 'main' + -- In other modes, fail altogether, so that we don't go on + -- and complain a second time when processing the export list. + + mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn + noMainMsg = ptext (sLit "The") <+> pp_main_fn + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn = ppMainFn main_fn + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case mainFunIs dflags of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + +checkMainExported :: TcGblEnv -> TcM () +checkMainExported tcg_env + = case tcg_main tcg_env of + Nothing -> return () -- not the main module + Just main_name -> + do { dflags <- getDynFlags + ; let main_mod = mainModIs dflags + ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ + ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> + ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) } + +ppMainFn :: RdrName -> SDoc +ppMainFn main_fn + | rdrNameOcc main_fn == mainOcc + = ptext (sLit "IO action") <+> quotes (ppr main_fn) + | otherwise + = ptext (sLit "main IO action") <+> quotes (ppr main_fn) + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") + +{- +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +The function that the RTS invokes is always :Main.main, which we call +root_main_id. (Because GHC allows the user to have a module not +called Main as the main module, we can't rely on the main function +being called "Main.main". That's why root_main_id has a fixed module +":Main".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in MkIface, les we +get two defns for 'main' in the interface file! + + +********************************************************* +* * + GHCi stuff +* * +********************************************************* +-} + +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) +-- Initialise the tcg_inst_env with instances from all home modules. +-- This mimics the more selective call to hptInstances in tcRnImports +runTcInteractive hsc_env thing_inside + = initTcInteractive hsc_env $ withTcPlugins hsc_env $ + do { traceTc "setInteractiveContext" $ + vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) + , text "ic_rn_gbl_env (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + ; let getOrphans m = fmap (concatMap (\iface -> mi_module iface + : dep_orphs (mi_deps iface))) + (loadSrcInterface (text "runTcInteractive") m + False Nothing) + ; ic_visible_mods <- fmap concat . forM (ic_imports icxt) $ \i -> + case i of + IIModule n -> getOrphans n + IIDecl i -> getOrphans (unLoc (ideclName i)) + ; gbl_env <- getGblEnv + ; let gbl_env' = gbl_env { + tcg_rdr_env = ic_rn_gbl_env icxt + , tcg_type_env = type_env + , tcg_inst_env = extendInstEnvList + (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) + home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_field_env = RecFields (mkNameEnv con_fields) + (mkNameSet (concatMap snd con_fields)) + -- setting tcg_field_env is necessary + -- to make RecordWildCards work (test: ghci049) + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + , tcg_visible_orphan_mods = mkModuleSet ic_visible_mods + -- I guess there's a risk ic_imports will be + -- desynchronized with the true RdrEnv; probably + -- should insert some ASSERTs somehow. + -- TODO: Cache this + } + + ; setGblEnv gbl_env' $ + tcExtendGhciIdEnv ty_things $ -- See Note [Initialising the type environment for GHCi] + thing_inside } -- in TcEnv + where + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) + + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + ty_things = ic_tythings icxt + + type_env1 = mkTypeEnvWithImplicits ty_things + type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + + con_fields = [ (dataConName c, dataConFieldLabels c) + | ATyCon t <- ty_things + , c <- tyConDataCons t ] + + +#ifdef GHCI +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound +-- values, coerced to (). +tcRnStmt :: HscEnv -> GhciLStmt RdrName + -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) +tcRnStmt hsc_env rdr_stmt + = runTcInteractive hsc_env $ do { + + -- The real work is done here + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + + traceTc "tcs 1" empty ; + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] in HscTypes + +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out + +-------------------------------------------------- -} + + traceOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + return (global_ids, zonked_expr, fix_env) + } + where + bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + +{- +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + +Here is the grand plan, implemented in tcUserStmt + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error +-} + +-- | A plan is an attempt to lift some code into the IO monad. +type PlanResult = ([Id], LHsExpr Id) +type Plan = TcM PlanResult + +-- | Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans :: [Plan] -> TcM PlanResult +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcLIE_ (runPlans ps) p + +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environment'. +-- +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in HscTypes for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. +tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (BodyStmt expr _ _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq loc + matches = [mkMatch [] rn_expr emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] + let_stmt = L loc $ LetStmt $ HsValBinds $ + ValBindsOut [(NonRecursive,unitBag the_bind)] [] + + -- [it <- e] + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) + (nlHsApp ghciStep rn_expr) + (HsVar bindIOName) noSyntaxExpr + + -- [; print it] + print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + + -- The plans are: + -- A. [it <- e; print it] but not if it::() + -- B. [it <- e] + -- C. [let it = e; print it] + -- + -- Ensure that type errors don't get deferred when type checking the + -- naked expression. Deferring type errors here is unhelpful because the + -- expression gets evaluated right away anyway. It also would potentially + -- emit two redundant type-error warnings, one from each plan. + ; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [ + -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; when (isUnitTy $ it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } ] + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! + ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump (ppr rn_stmt) ; + + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 + | otherwise = rn_stmt + + ; opt_pr_flag <- goptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders gi_stmt -- One binder + = [mk_print_result_plan gi_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) + ; return (plan, fix_env) } + where + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) noSyntaxExpr + placeHolderType + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [()]'. +tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + let { + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ; + names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ; + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; + let { -- mk_return builds the expression + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + } ; + return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo GhciStmtCtxt stmts io_ret_ty)) + } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr Name) +getGhciStepIO = do + ghciTy <- getGHCiMonad + fresh_a <- newUnique + let a_tv = mkTcTyVarName fresh_a (fsLit "a") + ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + stepTy :: LHsType Name -- Renamed, so needs all binders in place + stepTy = noLoc $ HsForAllTy Implicit Nothing + (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] + , hsq_kvs = [] }) + (noLoc []) + (nlHsFunTy ghciM ioM) + step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy [] + return step + +isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) +isGHCiMonad hsc_env ty + = runTcInteractive hsc_env $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = gre_name n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + + Just _ -> failWithTc $ text "Ambigous type!" + Nothing -> failWithTc $ text ("Can't find type:" ++ ty) + +-- tcRnExpr just finds the type of an expression + +tcRnExpr :: HscEnv + -> LHsExpr RdrName + -> IO (Messages, Maybe Type) +-- Type checks the expression and returns its most general type +tcRnExpr hsc_env rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) + uniq <- newUnique ; + let { fresh_it = itName uniq (getLoc rdr_expr) } ; + (((_tc_expr, res_ty), tclvl), lie) <- captureConstraints $ + captureTcLevel $ + tcInferRho rn_expr ; + ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ + {-# SCC "simplifyInfer" #-} + simplifyInfer tclvl + False {- No MR for now -} + [(fresh_it, res_ty)] + lie ; + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ; + + -- Ignore the dictionary bindings + _ <- simplifyInteractive (andWC stWC lie_top) ; + + let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; + ty <- zonkTcType all_expr_ty ; + + -- We normalise type families, so that the type of an expression is the + -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac + -- #10321 for further discussion. + fam_envs <- tcGetFamInstEnvs ; + -- normaliseType returns a coercion which we discard, so the Role is + -- irrelevant + return (snd (normaliseType fam_envs Nominal ty)) + } + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl RdrName] + -> IO (Messages, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- decls. In contract tcRnImports *extends* the TcGblEnv. +tcRnImportDecls hsc_env import_decls + = runTcInteractive hsc_env $ + do { gbl_env <- updGblEnv zap_rdr_env $ + tcRnImports hsc_env import_decls + ; return (tcg_rdr_env gbl_env) } + where + zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } + +-- tcRnType just finds the kind of a type + +tcRnType :: HscEnv + -> Bool -- Normalise the returned type + -> LHsType RdrName + -> IO (Messages, Maybe (Type, Kind)) +tcRnType hsc_env normalise rdr_type + = runTcInteractive hsc_env $ + setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (wcs, rdr_type') <- extractWildcards rdr_type + ; (rn_type, wcs) <- bindLocatedLocalsRn wcs $ \wcs_new -> do { + ; (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type' + ; failIfErrsM + ; return (rn_type, wcs_new) } + + -- Now kind-check the type + -- It can have any rank or kind + ; nwc_tvs <- mapM newWildcardVarMetaKind wcs + ; ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType GhciCtxt rn_type + + ; ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs + ; return (snd (normaliseType fam_envs Nominal ty)) } + -- normaliseType returns a coercion + -- which we discard, so the Role is irrelevant + else return ty ; + + ; return (ty', typeKind ty) } + +{- +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type. This gives the right default behaviour at +the GHCi prompt, where if you say ":k T", and T has a polymorphic +kind, you'd like to see that polymorphism. Of course. If T isn't +kind-polymorphic you won't get anything unexpected, but the apparent +*loss* of polymorphism, for types that you know are polymorphic, is +quite surprising. See Trac #7688 for a discussion. + + +************************************************************************ +* * + tcRnDeclsi +* * +************************************************************************ + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} + +tcRnDeclsi :: HscEnv + -> [LHsDecl RdrName] + -> IO (Messages, Maybe TcGblEnv) + +tcRnDeclsi hsc_env local_decls = + runTcInteractive hsc_env $ do + + ((tcg_env, tclcl_env), lie) <- + captureConstraints $ tc_rn_src_decls emptyModDetails local_decls + setEnvs (tcg_env, tclcl_env) $ do + + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef + + new_ev_binds <- simplifyTop (andWC stWC lie) + + failIfErrsM + let TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env + all_ev_binds = cur_ev_binds `unionBags` new_ev_binds + + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds emptyBag sig_ns rules vects + imp_specs fords + + let --global_ids = map globaliseAndTidyId bind_ids + final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids + tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } + + setGlobalTypeEnv tcg_env' final_type_env + +#endif /* GHCi */ + +{- +************************************************************************ +* * + More GHCi stuff, to do with browsing and getting info +* * +************************************************************************ +-} + +#ifdef GHCI +-- | ASSUMES that the module is either in the 'HomePackageTable' or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (ptext (sLit "getModuleInterface")) mod + +tcRnLookupRdrName :: HscEnv -> Located RdrName + -> IO (Messages, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpan loc $ + do { -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + ; names_s <- mapM lookupInfoOccRn rdr_names + ; let names = concat names_s + ; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name))) + ; return names } +#endif + +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) +tcRnLookupName hsc_env name + = runTcInteractive hsc_env $ + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + +tcRnGetInfo :: HscEnv + -> Name + -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst])) + +-- Used to implement :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; return (thing, fixity, cls_insts, fam_insts) } + +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) +lookupInsts (ATyCon tc) + = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + + -- Return only the instances relevant to the given thing, i.e. + -- the instances whose head contains the thing's name. + ; let cls_insts = + [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec + , tc_name `elemNameSet` orphNamesOfClsInst ispec ] + ; let fam_insts = + [ fispec + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , tc_name `elemNameSet` orphNamesOfFamInst fispec ] + ; return (cls_insts, fam_insts) } + where + tc_name = tyConName tc + +lookupInsts _ = return ([],[]) + +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ do + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + this_pkg = thisPackage (hsc_dflags hsc_env) + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) + , let name = gre_name gre + , from_external_package name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") + + from_external_package name -- True <=> the Name comes from some other package + -- (not the home package, not the interactive package) + | Just mod <- nameModule_maybe name + , modulePackageKey mod /= this_pkg -- Not the home package + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + + +{- +************************************************************************ +* * + Degugging output +* * +************************************************************************ +-} + +rnDump :: SDoc -> TcRn () +-- Dump, with a banner, if -ddump-rn +rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } + +tcDump :: TcGblEnv -> TcRn () +tcDump env + = do { dflags <- getDynFlags ; + + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (printForUserTcRn short_dump) ; + + -- Dump bindings if -ddump-tc + traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) + } + where + short_dump = pprTcGblEnv env + full_dump = pprLHsBinds (tcg_binds env) + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords + +-- It's unpleasant having both pprModGuts and pprModDetails here +pprTcGblEnv :: TcGblEnv -> SDoc +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_vects = vects, + tcg_imports = imports }) + = vcat [ ppr_types insts type_env + , ppr_tycons fam_insts type_env + , ppr_insts insts + , ppr_fam_insts fam_insts + , vcat (map ppr rules) + , vcat (map ppr vects) + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageKeyCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output + cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) + +ppr_types :: [ClsInst] -> TypeEnv -> SDoc +ppr_types insts type_env + = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) + where + dfun_ids = map instanceDFunId insts + ids = [id | id <- typeEnvIds type_env, want_sig id] + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocalId id && + isExternalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc. + -- The isExternalName ignores local dictionary and method bindings + -- that the type checker has invented. Top-level user-defined things + -- have External names. + +ppr_tycons :: [FamInst] -> TypeEnv -> SDoc +ppr_tycons fam_insts type_env + = vcat [ text "TYPE CONSTRUCTORS" + , nest 2 (ppr_tydecls tycons) + , text "COERCION AXIOMS" + , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] + where + fi_tycons = famInstsRepTyCons fam_insts + tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] + want_tycon tycon | opt_PprStyle_Debug = True + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts [] = empty +ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) + +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts [] = empty +ppr_fam_insts fam_insts = + text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) + +ppr_sigs :: [Var] -> SDoc +ppr_sigs ids + -- Print type signatures; sort by OccName + = vcat (map ppr_sig (sortBy (comparing getOccName) ids)) + where + ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) + +ppr_tydecls :: [TyCon] -> SDoc +ppr_tydecls tycons + -- Print type constructor info; sort by OccName + = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) + where + ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] + +{- +******************************************************************************** + +Type Checker Plugins + +******************************************************************************** +-} + +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + do plugins <- liftIO (loadTcPlugins hsc_env) + case plugins of + [] -> m -- Common fast case + _ -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins + -- This ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + startPlugin (TcPlugin start solve stop) = + do s <- runTcPluginM start + return (solve s, stop s) + +loadTcPlugins :: HscEnv -> IO [TcPlugin] +#ifndef GHCI +loadTcPlugins _ = return [] +#else +loadTcPlugins hsc_env = + do named_plugins <- loadPlugins hsc_env + return $ catMaybes $ map load_plugin named_plugins + where + load_plugin (_, plug, opts) = tcPlugin plug opts +#endif diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs new file mode 100644 index 00000000..dd700111 --- /dev/null +++ b/compiler/typecheck/TcRnMonad.hs @@ -0,0 +1,1444 @@ +{- +(c) The University of Glasgow 2006 + + +Functions for working with the typechecker environment (setters, getters...). +-} + +{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TcRnMonad( + module TcRnMonad, + module TcRnTypes, + module IOEnv + ) where + +#include "HsVersions.h" + +import TcRnTypes -- Re-export all +import IOEnv -- Re-export all +import TcEvidence + +import HsSyn hiding (LIE) +import HscTypes +import Module +import RdrName +import Name +import Type + +import TcType +import InstEnv +import FamInstEnv +import PrelNames + +import Var +import Id +import VarSet +import VarEnv +import ErrUtils +import SrcLoc +import NameEnv +import NameSet +import Bag +import Outputable +import UniqSupply +import UniqFM +import DynFlags +import StaticFlags +import FastString +import Panic +import Util +import Annotations +import BasicTypes( TopLevelFlag ) + +import Control.Exception +import Data.IORef +import qualified Data.Set as Set +import Control.Monad + +#ifdef GHCI +import qualified Data.Map as Map +#endif + +{- +************************************************************************ +* * + initTc +* * +************************************************************************ +-} + +-- | Setup the initial typechecking environment +initTc :: HscEnv + -> HscSource + -> Bool -- True <=> retain renamed syntax trees + -> Module + -> RealSrcSpan + -> TcM r + -> IO (Messages, Maybe r) + -- Nothing => error thrown by the thing inside + -- (error messages should have been printed already) + +initTc hsc_env hsc_src keep_rn_syntax mod loc do_this + = do { errs_var <- newIORef (emptyBag, emptyBag) ; + tvs_var <- newIORef emptyVarSet ; + keep_var <- newIORef emptyNameSet ; + used_rdr_var <- newIORef Set.empty ; + th_var <- newIORef False ; + th_splice_var<- newIORef False ; + infer_var <- newIORef True ; + lie_var <- newIORef emptyWC ; + dfun_n_var <- newIORef emptyOccSet ; + type_env_var <- case hsc_type_env_var hsc_env of { + Just (_mod, te_var) -> return te_var ; + Nothing -> newIORef emptyNameEnv } ; + + dependent_files_var <- newIORef [] ; + static_wc_var <- newIORef emptyWC ; +#ifdef GHCI + th_topdecls_var <- newIORef [] ; + th_topnames_var <- newIORef emptyNameSet ; + th_modfinalizers_var <- newIORef [] ; + th_state_var <- newIORef Map.empty ; +#endif /* GHCI */ + let { + dflags = hsc_dflags hsc_env ; + + maybe_rn_syntax :: forall a. a -> Maybe a ; + maybe_rn_syntax empty_val + | keep_rn_syntax = Just empty_val + | otherwise = Nothing ; + + gbl_env = TcGblEnv { +#ifdef GHCI + tcg_th_topdecls = th_topdecls_var, + tcg_th_topnames = th_topnames_var, + tcg_th_modfinalizers = th_modfinalizers_var, + tcg_th_state = th_state_var, +#endif /* GHCI */ + + tcg_mod = mod, + tcg_src = hsc_src, + tcg_sig_of = getSigOf dflags (moduleName mod), + tcg_impl_rdr_env = Nothing, + tcg_rdr_env = emptyGlobalRdrEnv, + tcg_fix_env = emptyNameEnv, + tcg_field_env = RecFields emptyNameEnv emptyNameSet, + tcg_default = Nothing, + tcg_type_env = emptyNameEnv, + tcg_type_env_var = type_env_var, + tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_ann_env = emptyAnnEnv, + tcg_visible_orphan_mods = mkModuleSet [mod], + tcg_th_used = th_var, + tcg_th_splice_used = th_splice_var, + tcg_exports = [], + tcg_imports = emptyImportAvails, + tcg_used_rdrnames = used_rdr_var, + tcg_dus = emptyDUs, + + tcg_rn_imports = [], + tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_decls = maybe_rn_syntax emptyRnGroup, + + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_tcs = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_patsyns = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing, + tcg_safeInfer = infer_var, + tcg_dependent_files = dependent_files_var, + tcg_tc_plugins = [], + tcg_static_wc = static_wc_var + } ; + lcl_env = TcLclEnv { + tcl_errs = errs_var, + tcl_loc = loc, -- Should be over-ridden very soon! + tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, + tcl_th_ctxt = topStage, + tcl_th_bndrs = emptyNameEnv, + tcl_arrow_ctxt = NoArrowCtxt, + tcl_env = emptyNameEnv, + tcl_bndrs = [], + tcl_tidy = emptyTidyEnv, + tcl_tyvars = tvs_var, + tcl_lie = lie_var, + tcl_tclvl = topTcLevel + } ; + } ; + + -- OK, here's the business end! + maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } ; + + -- Check for unsolved constraints + lie <- readIORef lie_var ; + if isEmptyWC lie + then return () + else pprPanic "initTc: unsolved constraints" (ppr lie) ; + + -- Collect any error messages + msgs <- readIORef errs_var ; + + let { final_res | errorsFound dflags msgs = Nothing + | otherwise = maybe_res } ; + + return (msgs, final_res) + } + + +initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) +-- Initialise the type checker monad for use in GHCi +initTcInteractive hsc_env thing_inside + = initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + (realSrcLocSpan interactive_src_loc) + thing_inside + where + interactive_src_loc = mkRealSrcLoc (fsLit "") 1 1 + +initTcForLookup :: HscEnv -> TcM a -> IO a +-- The thing_inside is just going to look up something +-- in the environment, so we don't need much setup +initTcForLookup hsc_env thing_inside + = do { (msgs, m) <- initTcInteractive hsc_env thing_inside + ; case m of + Nothing -> throwIO $ mkSrcErr $ snd msgs + Just x -> return x } + +{- +************************************************************************ +* * + Initialisation +* * +************************************************************************ +-} + +initTcRnIf :: Char -- Tag for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside + = do { us <- mkSplitUniqSupply uniq_tag ; + ; us_var <- newIORef us ; + + ; let { env = Env { env_top = hsc_env, + env_us = us_var, + env_gbl = gbl_env, + env_lcl = lcl_env} } + + ; runIOEnv env thing_inside + } + +{- +************************************************************************ +* * + Simple accessors +* * +************************************************************************ +-} + +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + +getTopEnv :: TcRnIf gbl lcl HscEnv +getTopEnv = do { env <- getEnv; return (env_top env) } + +getGblEnv :: TcRnIf gbl lcl gbl +getGblEnv = do { env <- getEnv; return (env_gbl env) } + +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> + env { env_gbl = upd gbl }) + +setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) + +getLclEnv :: TcRnIf gbl lcl lcl +getLclEnv = do { env <- getEnv; return (env_lcl env) } + +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> + env { env_lcl = upd lcl }) + +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a +setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +getEnvs :: TcRnIf gbl lcl (gbl, lcl) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a +setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) + +-- Command-line flags + +xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool +xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } + +doptM :: DumpFlag -> TcRnIf gbl lcl Bool +doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } + +goptM :: GeneralFlag -> TcRnIf gbl lcl Bool +goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } + +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } + +setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) + +unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetGOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = gopt_unset (hsc_dflags top) flag}} ) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} ) + +-- | Do it flag is true +whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenDOptM flag thing_inside = do b <- doptM flag + when b thing_inside + +whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenGOptM flag thing_inside = do b <- goptM flag + when b thing_inside + +whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenWOptM flag thing_inside = do b <- woptM flag + when b thing_inside + +whenXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +whenXOptM flag thing_inside = do b <- xoptM flag + when b thing_inside + +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } + +withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a +withDoDynamicToo m = do env <- getEnv + let dflags = extractDynFlags env + dflags' = dynamicTooMkDynamicDynFlags dflags + env' = replaceDynFlags env dflags' + setEnv env' m + +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } + +-- | Update the external package state. Returns the second result of the +-- modifier function. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do + traceIf (text "updating EPS") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var upd_fn + +-- | Update the external package state. +-- +-- This is an atomic operation and forces evaluation of the modified EPS in +-- order to avoid space leaks. +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = do + traceIf (text "updating EPS_") + eps_var <- getEpsVar + atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } + +{- +************************************************************************ +* * + Arrow scopes +* * +************************************************************************ +-} + +newArrowScope :: TcM a -> TcM a +newArrowScope + = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updLclEnv $ \ env -> + case tcl_arrow_ctxt env of + NoArrowCtxt -> env + ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt + , tcl_lie = lie + , tcl_rdr = rdr_env } + +{- +************************************************************************ +* * + Unique supply +* * +************************************************************************ +-} + +newUnique :: TcRnIf gbl lcl Unique +newUnique + = do { env <- getEnv ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; + case takeUniqFromSupply us of { (uniq, us') -> do { + writeMutVar u_var us' ; + return $! uniq }}} + -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving + -- a chain of unevaluated supplies behind. + -- NOTE 2: we use the uniq in the supply from the MutVar directly, and + -- throw away one half of the new split supply. This is safe because this + -- is the only place we use that unique. Using the other half of the split + -- supply is safer, but slower. + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; + case splitUniqSupply us of { (us1,us2) -> do { + writeMutVar u_var us1 ; + return us2 }}} + +newLocalName :: Name -> TcM Name +newLocalName name = newName (nameOccName name) + +newName :: OccName -> TcM Name +newName occ + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; return (mkInternalName uniq occ loc) } + +newSysName :: OccName -> TcM Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId +newSysLocalId fs ty + = do { u <- newUnique + ; return (mkSysLocal fs u ty) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + +instance MonadUnique (IOEnv (Env gbl lcl)) where + getUniqueM = newUnique + getUniqueSupplyM = newUniqueSupply + +{- +************************************************************************ +* * + Debugging +* * +************************************************************************ +-} + +newTcRef :: a -> TcRnIf gbl lcl (TcRef a) +newTcRef = newMutVar + +readTcRef :: TcRef a -> TcRnIf gbl lcl a +readTcRef = readMutVar + +writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () +writeTcRef = writeMutVar + +updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () +-- Returns () +updTcRef ref fn = liftIO $ do { old <- readIORef ref + ; writeIORef ref (fn old) } + +updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a +-- Returns previous value +updTcRefX ref fn = liftIO $ do { old <- readIORef ref + ; writeIORef ref (fn old) + ; return old } + +{- +************************************************************************ +* * + Debugging +* * +************************************************************************ +-} + +traceTc :: String -> SDoc -> TcRn () +traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc) + +-- | Typechecker trace +traceTcN :: Int -> SDoc -> TcRn () +traceTcN level doc + = do dflags <- getDynFlags + when (level <= traceLevel dflags && not opt_NoDebugOutput) $ + traceOptTcRn Opt_D_dump_tc_trace doc + +traceRn :: SDoc -> TcRn () +traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace + +-- | Output a doc if the given 'DumpFlag' is set. +-- +-- By default this logs to stdout +-- However, if the `-ddump-to-file` flag is set, +-- then this will dump output to a file +-- +-- Just a wrapper for 'dumpSDoc' +traceOptTcRn :: DumpFlag -> SDoc -> TcRn () +traceOptTcRn flag doc + = do { dflags <- getDynFlags + ; when (dopt flag dflags) (traceTcRn flag doc) + } + +traceTcRn :: DumpFlag -> SDoc -> TcRn () +-- ^ Unconditionally dump some trace output +-- +-- The DumpFlag is used only to set the output filename +-- for --dump-to-file, not to decide whether or not to output +-- That part is done by the caller +traceTcRn flag doc + = do { real_doc <- prettyDoc doc + ; dflags <- getDynFlags + ; printer <- getPrintUnqualified dflags + ; liftIO $ dumpSDoc dflags printer flag "" real_doc } + where + -- Add current location if opt_PprStyle_Debug + prettyDoc :: SDoc -> TcRn SDoc + prettyDoc doc = if opt_PprStyle_Debug + then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } + else return doc -- The full location is usually way too much + + +getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified +getPrintUnqualified dflags + = do { rdr_env <- getGlobalRdrEnv + ; return $ mkPrintUnqualified dflags rdr_env } + +-- | Like logInfoTcRn, but for user consumption +printForUserTcRn :: SDoc -> TcRn () +printForUserTcRn doc + = do { dflags <- getDynFlags + ; printer <- getPrintUnqualified dflags + ; liftIO (printInfoForUser dflags printer doc) } + +-- | Typechecker debug +debugDumpTcRn :: SDoc -> TcRn () +debugDumpTcRn doc = unless opt_NoDebugOutput $ + traceOptTcRn Opt_D_dump_tc doc + +{- +traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is +available. Alas, they behave inconsistently with the other stuff; +e.g. are unaffected by -dump-to-file. +-} + +traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs + + +traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () +traceOptIf flag doc + = whenDOptM flag $ -- No RdrEnv available, so qualify everything + do { dflags <- getDynFlags + ; liftIO (putMsg dflags doc) } + +{- +************************************************************************ +* * + Typechecker global environment +* * +************************************************************************ +-} + +setModule :: Module -> TcRn a -> TcRn a +setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside + +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule + ; return (isInteractiveModule mod) } + +getGHCiMonad :: TcRn Name +getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } + +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + +tcIsHsBootOrSig :: TcRn Bool +tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } + +getGlobalRdrEnv :: TcRn GlobalRdrEnv +getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } + +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + +getImports :: TcRn ImportAvails +getImports = do { env <- getGblEnv; return (tcg_imports env) } + +getFixityEnv :: TcRn FixityEnv +getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } + +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a +extendFixityEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> + env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) + +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +getDeclaredDefaultTys :: TcRn (Maybe [Type]) +getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } + +addDependentFiles :: [FilePath] -> TcRn () +addDependentFiles fs = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fs ++ dep_files) + +{- +************************************************************************ +* * + Error management +* * +************************************************************************ +-} + +getSrcSpanM :: TcRn SrcSpan + -- Avoid clash with Name.getSrcLoc +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) } + +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan (RealSrcSpan real_loc) thing_inside + = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside +-- Don't overwrite useful info with useless: +setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside + +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a + +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + setSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) + +-- Reporting errors + +getErrsVar :: TcRn (TcRef Messages) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: MsgDoc -> TcRn () -- Ignores the context stack +addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } + +failWith :: MsgDoc -> TcRn a +failWith msg = addErr msg >> failM + +addErrAt :: SrcSpan -> MsgDoc -> TcRn () +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- tcInitTidyEnv + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } + +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () +addErrs msgs = mapM_ add msgs + where + add (loc,msg) = addErrAt loc msg + +checkErr :: Bool -> MsgDoc -> TcRn () +-- Add the error if the bool is False +checkErr ok msg = unless ok (addErr msg) + +warnIf :: Bool -> MsgDoc -> TcRn () +warnIf True msg = addWarn msg +warnIf False _ = return () + +addMessages :: Messages -> TcRn () +addMessages (m_warns, m_errs) + = do { errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `unionBags` m_warns, + errs `unionBags` m_errs) } + +discardWarnings :: TcRn a -> TcRn a +-- Ignore warnings inside the thing inside; +-- used to ignore-unused-variable warnings inside derived code +discardWarnings thing_inside + = do { errs_var <- getErrsVar + ; (old_warns, _) <- readTcRef errs_var ; + + ; result <- thing_inside + + -- Revert warnings to old_warns + ; (_new_warns, new_errs) <- readTcRef errs_var + ; writeTcRef errs_var (old_warns, new_errs) + + ; return result } + +{- +************************************************************************ +* * + Shared error message stuff: renamer and typechecker +* * +************************************************************************ +-} + +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + return $ mkLongErrMsg dflags loc printer msg extra } + +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err + = do { traceTc "Adding error:" (pprLocErrMsg err) ; + errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns, errs `snocBag` err) } + +reportWarning :: ErrMsg -> TcRn () +reportWarning warn + = do { traceTc "Adding warning:" (pprLocErrMsg warn) ; + errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `snocBag` warn, errs) } + +try_m :: TcRn r -> TcRn (Either IOEnvFailure r) +-- Does try_m, with a debug-trace on failure +try_m thing + = do { mb_r <- tryM thing ; + case mb_r of + Left exn -> do { traceTc "tryTc/recoverM recovering from" $ + text (showException exn) + ; return mb_r } + Right _ -> return mb_r } + +----------------------- +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first + -> TcRn r +-- Errors in 'thing' are retained +recoverM recover thing + = do { mb_res <- try_m thing ; + case mb_res of + Left _ -> recover + Right res -> return res } + + +----------------------- +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +-- Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM _ [] = return [] +mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x) + ; rs <- mapAndRecoverM f xs + ; return (case mb_r of + Left _ -> rs + Right r -> r:rs) } + +-- | Succeeds if applying the argument to all members of the lists succeeds, +-- but nevertheless runs it on all arguments, to collect all errors. +mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] +mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs) + +----------------------- +tryTc :: TcRn a -> TcRn (Messages, Maybe a) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) +tryTc m + = do { errs_var <- newTcRef emptyMessages ; + res <- try_m (setErrsVar errs_var m) ; + msgs <- readTcRef errs_var ; + return (msgs, case res of + Left _ -> Nothing + Right val -> Just val) + -- The exception is always the IOEnv built-in + -- in exception; see IOEnv.failM + } + +----------------------- +tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) +-- Run the thing, returning +-- Just r, if m succceeds with no error messages +-- Nothing, if m fails, or if it succeeds but has error messages +-- Either way, the messages are returned; even in the Just case +-- there might be warnings +tryTcErrs thing + = do { (msgs, res) <- tryTc thing + ; dflags <- getDynFlags + ; let errs_found = errorsFound dflags msgs + ; return (msgs, case res of + Nothing -> Nothing + Just val | errs_found -> Nothing + | otherwise -> Just val) + } + +----------------------- +tryTcLIE :: TcM a -> TcM (Messages, Maybe a) +-- Just like tryTcErrs, except that it ensures that the LIE +-- for the thing is propagated only if there are no errors +-- Hence it's restricted to the type-check monad +tryTcLIE thing_inside + = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ; + ; case mb_res of + Nothing -> return (msgs, Nothing) + Just val -> do { emitConstraints lie; return (msgs, Just val) } + } + +----------------------- +tryTcLIE_ :: TcM r -> TcM r -> TcM r +-- (tryTcLIE_ r m) tries m; +-- if m succeeds with no error messages, it's the answer +-- otherwise tryTcLIE_ drops everything from m and tries r instead. +tryTcLIE_ recover main + = do { (msgs, mb_res) <- tryTcLIE main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } + +----------------------- +checkNoErrs :: TcM r -> TcM r +-- (checkNoErrs m) succeeds iff m succeeds and generates no errors +-- If m fails then (checkNoErrsTc m) fails. +-- If m succeeds, it checks whether m generated any errors messages +-- (it might have recovered internally) +-- If so, it fails too. +-- Regardless, any errors generated by m are propagated to the enclosing context. +checkNoErrs main + = do { (msgs, mb_res) <- tryTcLIE main + ; addMessages msgs + ; case mb_res of + Nothing -> failM + Just val -> return val + } + +whenNoErrs :: TcM () -> TcM () +whenNoErrs thing = ifErrsM (return ()) thing + +ifErrsM :: TcRn r -> TcRn r -> TcRn r +-- ifErrsM bale_out normal +-- does 'bale_out' if there are errors in errors collection +-- otherwise does 'normal' +ifErrsM bale_out normal + = do { errs_var <- getErrsVar ; + msgs <- readTcRef errs_var ; + dflags <- getDynFlags ; + if errorsFound dflags msgs then + bale_out + else + normal } + +failIfErrsM :: TcRn () +-- Useful to avoid error cascades +failIfErrsM = ifErrsM failM (return ()) + +checkTH :: Outputable a => a -> String -> TcRn () +#ifdef GHCI +checkTH _ _ = return () -- OK +#else +checkTH e what = failTH e what -- Raise an error in a stage-1 compiler +#endif + +failTH :: Outputable a => a -> String -> TcRn x +failTH e what -- Raise an error in a stage-1 compiler + = failWithTc (vcat [ hang (char 'A' <+> text what + <+> ptext (sLit "requires GHC with interpreter support:")) + 2 (ppr e) + , ptext (sLit "Perhaps you are using a stage-1 compiler?") ]) + +{- +************************************************************************ +* * + Context management for the type checker +* * +************************************************************************ +-} + +getErrCtxt :: TcM [ErrCtxt] +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } + +setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) + +addErrCtxt :: MsgDoc -> TcM a -> TcM a +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) + +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) + +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts) + +-- Helper function for the above +updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a +updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> + env { tcl_ctxt = upd ctxt }) + +popErrCtxt :: TcM a -> TcM a +popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) + +getCtLoc :: CtOrigin -> TcM CtLoc +getCtLoc origin + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin + , ctl_env = env + , ctl_depth = initialSubGoalDepth }) } + +setCtLoc :: CtLoc -> TcM a -> TcM a +-- Set the SrcSpan and error context from the CtLoc +setCtLoc (CtLoc { ctl_env = lcl }) thing_inside + = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl + , tcl_bndrs = tcl_bndrs lcl + , tcl_ctxt = tcl_ctxt lcl }) + thing_inside + +{- +************************************************************************ +* * + Error message generation (type checker) +* * +************************************************************************ + + The addErrTc functions add an error message, but do not cause failure. + The 'M' variants pass a TidyEnv that has already been used to + tidy up the message; we then use it to tidy the context messages +-} + +addErrTc :: MsgDoc -> TcM () +addErrTc err_msg = do { env0 <- tcInitTidyEnv + ; addErrTcM (env0, err_msg) } + +addErrsTc :: [MsgDoc] -> TcM () +addErrsTc err_msgs = mapM_ addErrTc err_msgs + +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () +addErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + add_err_tcm tidy_env err_msg loc ctxt } + +-- Return the error message, instead of reporting it straight away +mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg +mkErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + err_info <- mkErrInfo tidy_env ctxt ; + mkLongErrAt loc err_msg err_info } + +-- The failWith functions add an error message and cause failure + +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail +failWithTc err_msg + = addErrTc err_msg >> failM + +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail +failWithTcM local_and_msg + = addErrTcM local_and_msg >> failM + +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true +checkTc True _ = return () +checkTc False err = failWithTc err + +-- Warnings have no 'M' variant, nor failure + +warnTc :: Bool -> MsgDoc -> TcM () +warnTc warn_if_true warn_msg + | warn_if_true = addWarnTc warn_msg + | otherwise = return () + +addWarnTc :: MsgDoc -> TcM () +addWarnTc msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM (env0, msg) } + +addWarnTcM :: (TidyEnv, MsgDoc) -> TcM () +addWarnTcM (env0, msg) + = do { ctxt <- getErrCtxt ; + err_info <- mkErrInfo env0 ctxt ; + add_warn msg err_info } + +addWarn :: MsgDoc -> TcRn () +addWarn msg = add_warn msg Outputable.empty + +addWarnAt :: SrcSpan -> MsgDoc -> TcRn () +addWarnAt loc msg = add_warn_at loc msg Outputable.empty + +add_warn :: MsgDoc -> MsgDoc -> TcRn () +add_warn msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at loc msg extra_info } + +add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at loc msg extra_info + = do { dflags <- getDynFlags ; + printer <- getPrintUnqualified dflags ; + let { warn = mkLongWarnMsg dflags loc printer + msg extra_info } ; + reportWarning warn } + +tcInitTidyEnv :: TcM TidyEnv +tcInitTidyEnv + = do { lcl_env <- getLclEnv + ; return (tcl_tidy lcl_env) } + +{- +----------------------------------- + Other helper functions +-} + +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan + -> [ErrCtxt] + -> TcM () +add_err_tcm tidy_env err_msg loc ctxt + = do { err_info <- mkErrInfo tidy_env ctxt ; + addLongErrAt loc err_msg err_info } + +mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc +-- Tidy the error info, trimming excessive contexts +mkErrInfo env ctxts +-- | opt_PprStyle_Debug -- In -dppr-debug style the output +-- = return empty -- just becomes too voluminous + | otherwise + = go 0 env ctxts + where + go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc + go _ _ [] = return Outputable.empty + go n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug + = do { (env', msg) <- ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go n' env' ctxts + ; return (msg $$ rest) } + | otherwise + = go n env ctxts + +mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts +mAX_CONTEXTS = 3 + +-- debugTc is useful for monadic debugging code + +debugTc :: TcM () -> TcM () +debugTc thing + | debugIsOn = thing + | otherwise = return () + +{- +************************************************************************ +* * + Type constraints +* * +************************************************************************ +-} + +newTcEvBinds :: TcM EvBindsVar +newTcEvBinds = do { ref <- newTcRef emptyEvBindMap + ; uniq <- newUnique + ; return (EvBindsVar ref uniq) } + +addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM () +-- Add a binding to the TcEvBinds by side effect +addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm + = do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id + , text "ev_tm =" <+> ppr ev_tm ] + ; bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) } + +getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) +getTcEvBinds (EvBindsVar ev_ref _) + = do { bnds <- readTcRef ev_ref + ; return (evBindMapBinds bnds) } + +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readTcRef dfun_n_var + ; let occ = fn set + ; writeTcRef dfun_n_var (extendOccSet set occ) + ; return occ } + +getConstraintVar :: TcM (TcRef WantedConstraints) +getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } + +setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a +setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) + +emitConstraints :: WantedConstraints -> TcM () +emitConstraints ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`andWC` ct) } + +emitSimple :: Ct -> TcM () +emitSimple ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` unitBag ct) } + +emitSimples :: Cts -> TcM () +emitSimples cts + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addSimples` cts) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } + +emitImplications :: Bag Implication -> TcM () +emitImplications ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` ct) } + +emitInsoluble :: Ct -> TcM () +emitInsoluble ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addInsols` unitBag ct) ; + v <- readTcRef lie_var ; + traceTc "emitInsoluble" (ppr v) } + +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +captureConstraints thing_inside + = do { lie_var <- newTcRef emptyWC ; + res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) + thing_inside ; + lie <- readTcRef lie_var ; + return (res, lie) } + +captureTcLevel :: TcM a -> TcM (a, TcLevel) +captureTcLevel thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) + thing_inside + ; return (res, tclvl') } + +pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints) +pushLevelAndCaptureConstraints thing_inside + = do { env <- getLclEnv + ; lie_var <- newTcRef emptyWC ; + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; res <- setLclEnv (env { tcl_tclvl = tclvl' + , tcl_lie = lie_var }) + thing_inside + ; lie <- readTcRef lie_var + ; return (res, tclvl', lie) } + +pushTcLevelM :: TcM a -> TcM a +pushTcLevelM thing_inside + = do { env <- getLclEnv + ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; setLclEnv (env { tcl_tclvl = tclvl' }) + thing_inside } + +getTcLevel :: TcM TcLevel +getTcLevel = do { env <- getLclEnv + ; return (tcl_tclvl env) } + +setTcLevel :: TcLevel -> TcM a -> TcM a +setTcLevel tclvl thing_inside + = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside + +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv + = do { env <- getLclEnv + ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) } + +getLclTypeEnv :: TcM TcTypeEnv +getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } + +setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a +-- Set the local type envt, but do *not* disturb other fields, +-- notably the lie_var +setLclTypeEnv lcl_env thing_inside + = updLclEnv upd thing_inside + where + upd env = env { tcl_env = tcl_env lcl_env, + tcl_tyvars = tcl_tyvars lcl_env } + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceTc (msg ++ ": LIE:") (ppr lie) + } + +emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM () +emitWildcardHoleConstraints wcs + = do { ctLoc <- getCtLoc HoleOrigin + ; forM_ wcs $ \(name, tv) -> do { + ; let real_span = case nameSrcSpan name of + RealSrcSpan span -> span + UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints" + (ppr name <+> quotes (ftext str)) + -- Wildcards are defined locally, and so have RealSrcSpans + ctLoc' = setCtLocSpan ctLoc real_span + ty = mkTyVarTy tv + ev = mkLocalId name ty + can = CHoleCan { cc_ev = CtWanted ty ev ctLoc' + , cc_occ = occName name + , cc_hole = TypeHole } + ; emitInsoluble can } } + +{- +************************************************************************ +* * + Template Haskell context +* * +************************************************************************ +-} + +recordThUse :: TcM () +recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } + +recordThSpliceUse :: TcM () +recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } + +keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set +keepAlive name + = do { env <- getGblEnv + ; traceRn (ptext (sLit "keep alive") <+> ppr name) + ; updTcRef (tcg_keep env) (`extendNameSet` name) } + +getStage :: TcM ThStage +getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } + +getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) +getStageAndBindLevel name + = do { env <- getLclEnv; + ; case lookupNameEnv (tcl_th_bndrs env) name of + Nothing -> return Nothing + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } + +setStage :: ThStage -> TcM a -> TcRn a +setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) + +{- +************************************************************************ +* * + Safe Haskell context +* * +************************************************************************ +-} + +-- | Mark that safe inference has failed +recordUnsafeInfer :: TcM () +recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- readIORef (tcg_safeInfer tcg_env) + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_Safe + | otherwise -> Sf_None + s -> s + +{- +************************************************************************ +* * + Stuff for the renamer's local env +* * +************************************************************************ +-} + +getLocalRdrEnv :: RnM LocalRdrEnv +getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } + +setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a +setLocalRdrEnv rdr_env thing_inside + = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside + +{- +************************************************************************ +* * + Stuff for interface decls +* * +************************************************************************ +-} + +mkIfLclEnv :: Module -> SDoc -> IfLclEnv +mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, + if_loc = loc, + if_tv_env = emptyUFM, + if_id_env = emptyUFM } + +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; let { if_env = IfGblEnv { + if_rec_types = Just (tcg_mod tcg_env, get_type_env) + } + ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } + ; setEnvs (if_env, ()) thing_inside } + +initIfaceCheck :: HscEnv -> IfG a -> IO a +-- Used when checking the up-to-date-ness of the old Iface +-- Initialise the environment with no useful info at all +initIfaceCheck hsc_env do_this + = do let rec_types = case hsc_type_env_var hsc_env of + Just (mod,var) -> Just (mod, readTcRef var) + Nothing -> Nothing + gbl_env = IfGblEnv { if_rec_types = rec_types } + initTcRnIf 'i' hsc_env gbl_env () do_this + +initIfaceTc :: ModIface + -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a +-- Used when type-checking checking an up-to-date interface file +-- No type envt from the current module, but we do know the module dependencies +initIfaceTc iface do_this + = do { tc_env_var <- newTcRef emptyTypeEnv + ; let { gbl_env = IfGblEnv { + if_rec_types = Just (mod, readTcRef tc_env_var) + } ; + ; if_lenv = mkIfLclEnv mod doc + } + ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) + } + where + mod = mi_module iface + doc = ptext (sLit "The interface for") <+> quotes (ppr mod) + +initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } + +-------------------- +failIfM :: MsgDoc -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldnt happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg + ; dflags <- getDynFlags + ; liftIO (log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) full_msg) + ; failM } + +-------------------- +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) +-- Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It returns Nothing if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign + +forkM_maybe doc thing_inside + -- NB: Don't share the mutable env_us with the interleaved thread since env_us + -- does not get updated atomically (e.g. in newUnique and newUniqueSupply). + = do { child_us <- newUniqueSupply + ; child_env_us <- newMutVar child_us + -- see Note [Masking exceptions in forkM_maybe] + ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM $ + updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ + thing_inside + ; case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + whenDOptM Opt_D_dump_if_trace $ do + dflags <- getDynFlags + let msg = hang (text "forkM failed:" <+> doc) + 2 (text (show exn)) + liftIO $ log_action dflags dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + }} + +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = do { mb_res <- forkM_maybe doc thing_inside + ; return (case mb_res of + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc + Just r -> r) } + +{- +Note [Masking exceptions in forkM_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using GHC-as-API it must be possible to interrupt snippets of code +executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible +by throwing an asynchronous interrupt to the GHC thread. However, there is a +subtle problem: runStmt first typechecks the code before running it, and the +exception might interrupt the type checker rather than the code. Moreover, the +typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and +more importantly might be inside an exception handler inside that +unsafeInterleaveIO. If that is the case, the exception handler will rethrow the +asynchronous exception as a synchronous exception, and the exception will end +up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed +discussion). We don't currently know a general solution to this problem, but +we can use uninterruptibleMask_ to avoid the situation. +-} diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs new file mode 100644 index 00000000..30395176 --- /dev/null +++ b/compiler/typecheck/TcRnTypes.hs @@ -0,0 +1,2161 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + + +Various types used during typechecking, please see TcRnMonad as well for +operations on these types. You probably want to import it, instead of this +module. + +All the monads exported here are built on top of the same IOEnv monad. The +monad functions like a Reader monad in the way it passes the environment +around. This is done to allow the environment to be manipulated in a stack +like fashion when entering expressions... ect. + +For state that is global and should be returned at the end (e.g not part +of the stack mechanism), you should use an TcRef (= IORef) to store them. +-} + +{-# LANGUAGE CPP, ExistentialQuantification #-} + +module TcRnTypes( + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, + + -- The environment types + Env(..), + TcGblEnv(..), TcLclEnv(..), + IfGblEnv(..), IfLclEnv(..), + + -- Ranamer types + ErrCtxt, RecFieldEnv(..), + ImportAvails(..), emptyImportAvails, plusImportAvails, + WhereFrom(..), mkModDeps, + + -- Typechecker types + TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..), + pprTcTyThingCategory, pprPECategory, + + -- Desugaring types + DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..), + DsMetaEnv, DsMetaVal(..), + + -- Template Haskell + ThStage(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage, + ThLevel, impLevel, outerLevel, thLevel, + + -- Arrows + ArrowCtxt(..), + + -- Canonical constraints + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, + isEmptyCts, isCTyEqCan, isCFunEqCan, + isCDictCan_Maybe, isCFunEqCan_maybe, + isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, + isGivenCt, isHoleCt, isTypedHoleCt, isPartialTypeSigCt, + ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, + mkNonCanonical, mkNonCanonicalCt, + ctEvPred, ctEvLoc, ctEvEqRel, + ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth, + + WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols, + dropDerivedWC, + + Implication(..), + SubGoalCounter(..), + SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, + bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, + ctLocDepth, bumpCtLocDepth, + setCtLocOrigin, setCtLocEnv, setCtLocSpan, + CtOrigin(..), pprCtOrigin, + pushErrCtxt, pushErrCtxtSameOrigin, + + SkolemInfo(..), + + CtEvidence(..), + mkGivenLoc, + isWanted, isGiven, isDerived, + ctEvRole, + + -- Constraint solver plugins + TcPlugin(..), TcPluginResult(..), TcPluginSolver, + TcPluginM, runTcPluginM, unsafeTcPluginTcM, + + CtFlavour(..), ctEvFlavour, + + -- Pretty printing + pprEvVarTheta, + pprEvVars, pprEvVarWithType, + pprArising, pprArisingAt, + + -- Misc other types + TcId, TcIdSet, HoleSort(..) + + ) where + +#include "HsVersions.h" + +import HsSyn +import CoreSyn +import HscTypes +import TcEvidence +import Type +import CoAxiom ( Role ) +import Class ( Class ) +import TyCon ( TyCon ) +import ConLike ( ConLike(..) ) +import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) +import PatSyn ( PatSyn, patSynType ) +import TysWiredIn ( coercibleClass ) +import TcType +import Annotations +import InstEnv +import FamInstEnv +import IOEnv +import RdrName +import Name +import NameEnv +import NameSet +import Avail +import Var +import VarEnv +import Module +import SrcLoc +import VarSet +import ErrUtils +import UniqFM +import UniqSupply +import BasicTypes +import Bag +import DynFlags +import Outputable +import ListSetOps +import FastString +import GHC.Fingerprint + +import Data.Set (Set) +import Control.Monad (ap, liftM) + +#ifdef GHCI +import Data.Map ( Map ) +import Data.Dynamic ( Dynamic ) +import Data.Typeable ( TypeRep ) + +import qualified Language.Haskell.TH as TH +#endif + +{- +************************************************************************ +* * + Standard monad definition for TcRn + All the combinators for the monad can be found in TcRnMonad +* * +************************************************************************ + +The monad itself has to be defined here, because it is mentioned by ErrCtxt +-} + +type TcRnIf a b = IOEnv (Env a b) +type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference +type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff +type IfG = IfM () -- Top level +type IfL = IfM IfLclEnv -- Nested +type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring + +-- TcRn is the type-checking and renaming monad: the main monad that +-- most type-checking takes place in. The global environment is +-- 'TcGblEnv', which tracks all of the top-level type-checking +-- information we've accumulated while checking a module, while the +-- local environment is 'TcLclEnv', which tracks local information as +-- we move inside expressions. + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn + +-- We 'stack' these envs through the Reader like monad infastructure +-- as we move into an expression (although the change is focused in +-- the lcl type). +data Env gbl lcl + = Env { + env_top :: HscEnv, -- Top-level stuff that never changes + -- Includes all info about imported things + + env_us :: {-# UNPACK #-} !(IORef UniqSupply), + -- Unique supply for local varibles + + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled + + env_lcl :: lcl -- Nested stuff; changes as we go into + } + +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + replaceDynFlags env dflags + = env {env_top = replaceDynFlags (env_top env) dflags} + +instance ContainsModule gbl => ContainsModule (Env gbl lcl) where + extractModule env = extractModule (env_gbl env) + + +{- +************************************************************************ +* * + The interface environments + Used when dealing with IfaceDecls +* * +************************************************************************ +-} + +data IfGblEnv + = IfGblEnv { + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + if_rec_types :: Maybe (Module, IfG TypeEnv) + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + if_mod :: Module, + + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + + if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings + -- (and coercions) + if_id_env :: UniqFM Id -- Nested id binding + } + +{- +************************************************************************ +* * + Desugarer monad +* * +************************************************************************ + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +-} + +-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding +-- variables found in 'Data.Array.Parallel'. +-- +data PArrBuiltin + = PArrBuiltin + { lengthPVar :: Var -- ^ lengthP + , replicatePVar :: Var -- ^ replicateP + , singletonPVar :: Var -- ^ singletonP + , mapPVar :: Var -- ^ mapP + , filterPVar :: Var -- ^ filterP + , zipPVar :: Var -- ^ zipP + , crossMapPVar :: Var -- ^ crossMapP + , indexPVar :: Var -- ^ (!:) + , emptyPVar :: Var -- ^ emptyP + , appPVar :: Var -- ^ (+:+) + , enumFromToPVar :: Var -- ^ enumFromToP + , enumFromThenToPVar :: Var -- ^ enumFromThenToP + } + +data DsGblEnv + = DsGblEnv + { ds_mod :: Module -- For SCC profiling + , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_unqual :: PrintUnqualified + , ds_msgs :: IORef Messages -- Warning messages + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + , ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim' + -- iff '-fvectorise' flag was given as well as + -- exported entities of 'Data.Array.Parallel' iff + -- '-XParallelArrays' was given; otherwise, empty + , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' + , ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))] + -- ^ Bindings resulted from floating static forms + } + +instance ContainsModule DsGblEnv where + extractModule = ds_mod + +data DsLclEnv = DsLclEnv { + dsl_meta :: DsMetaEnv, -- Template Haskell bindings + dsl_loc :: SrcSpan -- to put in pattern-matching error msgs + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = DsBound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | DsSplice (HsExpr Id) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + + +{- +************************************************************************ +* * + Global typechecker environment +* * +************************************************************************ +-} + +-- | 'TcGblEnv' describes the top-level of the module at the +-- point at which the typechecker is finished work. +-- It is this structure that is handed on to the desugarer +-- For state that needs to be updated during the typechecking +-- phase and returned at end, use a 'TcRef' (= 'IORef'). +data TcGblEnv + = TcGblEnv { + tcg_mod :: Module, -- ^ Module being compiled + tcg_src :: HscSource, + -- ^ What kind of module (regular Haskell, hs-boot, ext-core) + tcg_sig_of :: Maybe Module, + -- ^ Are we being compiled as a signature of an implementation? + tcg_impl_rdr_env :: Maybe GlobalRdrEnv, + -- ^ Environment used only during -sig-of for resolving top level + -- bindings. See Note [Signature parameters in TcGblEnv and DynFlags] + + tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming + tcg_default :: Maybe [Type], + -- ^ Types used for defaulting. @Nothing@ => no @default@ decl + + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module + tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module + -- See Note [The interactive package] in HscTypes + + tcg_type_env :: TypeEnv, + -- ^ Global type env for the module we are compiling now. All + -- TyCons and Classes (for this module) end up in here right away, + -- along with their derived constructors, selectors. + -- + -- (Ids defined in this module start in the local envt, though they + -- move to the global envt during zonking) + -- + -- NB: for what "things in this module" means, see + -- Note [The interactive package] in HscTypes + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) + + tcg_inst_env :: InstEnv, + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts + tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances + tcg_ann_env :: AnnEnv, -- ^ And for annotations + + tcg_visible_orphan_mods :: ModuleSet, + -- ^ The set of orphan modules which transitively reachable from + -- direct imports. We use this to figure out if an orphan instance + -- in the global InstEnv should be considered visible. + -- See Note [Instance lookup and orphan instances] in InstEnv + + -- Now a bunch of things about this module that are simply + -- accumulated, but never consulted until the end. + -- Nevertheless, it's convenient to accumulate them along + -- with the rest of the info from this module. + tcg_exports :: [AvailInfo], -- ^ What is exported + tcg_imports :: ImportAvails, + -- ^ Information about what was imported from where, including + -- things bound in this module. Also store Safe Haskell info + -- here about transative trusted packaage requirements. + + tcg_dus :: DefUses, -- ^ What is defined in this module and what is used. + tcg_used_rdrnames :: TcRef (Set RdrName), + -- See Note [Tracking unused binding and imports] + + tcg_keep :: TcRef NameSet, + -- ^ Locally-defined top-level names to keep alive. + -- + -- "Keep alive" means give them an Exported flag, so that the + -- simplifier does not discard them as dead code, and so that they + -- are exposed in the interface file (but not to export to the + -- user). + -- + -- Some things, like dict-fun Ids and default-method Ids are "born" + -- with the Exported flag on, for exactly the above reason, but some + -- we only discover as we go. Specifically: + -- + -- * The to/from functions for generic data types + -- + -- * Top-level variables appearing free in the RHS of an orphan + -- rule + -- + -- * Top-level variables appearing free in a TH bracket + + tcg_th_used :: TcRef Bool, + -- ^ @True@ <=> Template Haskell syntax used. + -- + -- We need this so that we can generate a dependency on the + -- Template Haskell package, because the desugarer is going + -- to emit loads of references to TH symbols. The reference + -- is implicit rather than explicit, so we have to zap a + -- mutable variable. + + tcg_th_splice_used :: TcRef Bool, + -- ^ @True@ <=> A Template Haskell splice was used. + -- + -- Splices disable recompilation avoidance (see #481) + + tcg_dfun_n :: TcRef OccSet, + -- ^ Allows us to choose unique DFun names. + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fields are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + + tcg_rn_exports :: Maybe [Located (IE Name)], + tcg_rn_imports :: [LImportDecl Name], + -- Keep the renamed imports regardless. They are not + -- voluminous and are needed if you want to report unused imports + + tcg_rn_decls :: Maybe (HsGroup Name), + -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed + -- decls. + + tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + +#ifdef GHCI + tcg_th_topdecls :: TcRef [LHsDecl RdrName], + -- ^ Top-level declarations from addTopDecls + + tcg_th_topnames :: TcRef NameSet, + -- ^ Exact names bound in top-level declarations in tcg_th_topdecls + + tcg_th_modfinalizers :: TcRef [TH.Q ()], + -- ^ Template Haskell module finalizers + + tcg_th_state :: TcRef (Map TypeRep Dynamic), + -- ^ Template Haskell state +#endif /* GHCI */ + + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) + -- in the declarations for a single GHCi command. + -- For the latter, see Note [The interactive package] in HscTypes + tcg_binds :: LHsBinds Id, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids + tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_anns :: [Annotation], -- ...Annotations + tcg_tcs :: [TyCon], -- ...TyCons and Classes + tcg_insts :: [ClsInst], -- ...Instances + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + + tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the + -- prog uses hpc instrumentation. + + tcg_main :: Maybe Name, -- ^ The Name of the main + -- function, if this module is + -- the main module. + tcg_safeInfer :: TcRef Bool, -- Has the typechecker + -- inferred this module + -- as -XSafe (Safe Haskell) + + -- | A list of user-defined plugins for the constraint solver. + tcg_tc_plugins :: [TcPluginSolver], + + tcg_static_wc :: TcRef WantedConstraints + -- ^ Wanted constraints of static forms. + } + +-- Note [Signature parameters in TcGblEnv and DynFlags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When compiling signature files, we need to know which implementation +-- we've actually linked against the signature. There are three seemingly +-- redundant places where this information is stored: in DynFlags, there +-- is sigOf, and in TcGblEnv, there is tcg_sig_of and tcg_impl_rdr_env. +-- Here's the difference between each of them: +-- +-- * DynFlags.sigOf is global per invocation of GHC. If we are compiling +-- with --make, there may be multiple signature files being compiled; in +-- which case this parameter is a map from local module name to implementing +-- Module. +-- +-- * HscEnv.tcg_sig_of is global per the compilation of a single file, so +-- it is simply the result of looking up tcg_mod in the DynFlags.sigOf +-- parameter. It's setup in TcRnMonad.initTc. This prevents us +-- from having to repeatedly do a lookup in DynFlags.sigOf. +-- +-- * HscEnv.tcg_impl_rdr_env is a RdrEnv that lets us look up names +-- according to the sig-of module. It's setup in TcRnDriver.tcRnSignature. +-- Here is an example showing why we need this map: +-- +-- module A where +-- a = True +-- +-- module ASig where +-- import B +-- a :: Bool +-- +-- module B where +-- b = False +-- +-- When we compile ASig --sig-of main:A, the default +-- global RdrEnv (tcg_rdr_env) has an entry for b, but not for a +-- (we never imported A). So we have to look in a different environment +-- to actually get the original name. +-- +-- By the way, why do we need to do the lookup; can't we just use A:a +-- as the name directly? Well, if A is reexporting the entity from another +-- module, then the original name needs to be the real original name: +-- +-- module C where +-- a = True +-- +-- module A(a) where +-- import C + +instance ContainsModule TcGblEnv where + extractModule env = tcg_mod env + +data RecFieldEnv + = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* + -- to the fields for that constructor + NameSet -- Set of all fields declared *in this module*; + -- used to suppress name-shadowing complaints + -- when using record wild cards + -- E.g. let fld = e in C {..} + -- This is used when dealing with ".." notation in record + -- construction and pattern matching. + -- The FieldEnv deals *only* with constructors defined in *this* + -- module. For imported modules, we get the same info from the + -- TypeEnv + +{- +Note [Tracking unused binding and imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We gather two sorts of usage information + * tcg_dus (defs/uses) + Records *defined* Names (local, top-level) + and *used* Names (local or imported) + + Used (a) to report "defined but not used" + (see RnNames.reportUnusedNames) + (b) to generate version-tracking usage info in interface + files (see MkIface.mkUsedNames) + This usage info is mainly gathered by the renamer's + gathering of free-variables + + * tcg_used_rdrnames + Records used *imported* (not locally-defined) RdrNames + Used only to report unused import declarations + Notice that they are RdrNames, not Names, so we can + tell whether the reference was qualified or unqualified, which + is esssential in deciding whether a particular import decl + is unnecessary. This info isn't present in Names. + + +************************************************************************ +* * + The local typechecker environment +* * +************************************************************************ + +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the tcg_type_env + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the tcg_type_env + * Locally defined top-level Ids + +Why? Because they are now Ids not TcIds. This final GlobalEnv is + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module +-} + +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer + = TcLclEnv { + tcl_loc :: RealSrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_tclvl :: TcLevel, -- Birthplace for new unification variables + + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_th_bndrs :: ThBindEnv, -- Binding level of in-scope Names + -- defined in this module (not imported) + + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module + + tcl_bndrs :: [TcIdBinder], -- Stack of locally-bound Ids, innermost on top + -- Used only for error reporting + + tcl_tidy :: TidyEnv, -- Used for tidying types; contains all + -- in-scope type variables (but not term variables) + + tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" + -- Namely, the in-scope TyVars bound in tcl_env, + -- plus the tyvars mentioned in the types of Ids bound + -- in tcl_lenv. + -- Why mutable? see notes with tcGetGlobalTyVars + + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors + } + +type TcTypeEnv = NameEnv TcTyThing + +type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) + -- Domain = all Ids bound in this module (ie not imported) + -- The TopLevelFlag tells if the binding is syntactically top level. + -- We need to know this, because the cross-stage persistence story allows + -- cross-stage at arbitrary types if the Id is bound at top level. + -- + -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being + -- bound at top level! See Note [Template Haskell levels] in TcSplice + +data TcIdBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the bindind is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) + +{- Note [Given Insts] + ~~~~~~~~~~~~~~~~~~ +Because of GADTs, we have to pass inwards the Insts provided by type signatures +and existential contexts. Consider + data T a where { T1 :: b -> b -> T [b] } + f :: Eq a => T a -> Bool + f (T1 x y) = [x]==[y] + +The constructor T1 binds an existential variable 'b', and we need Eq [b]. +Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we +pass it inwards. + +-} + +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in 'TcGblEnv' which are updated during typechecking and +-- returned at the end. +type TcRef a = IORef a +-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? +type TcId = Id +type TcIdSet = IdSet + +--------------------------- +-- Template Haskell stages and levels +--------------------------- + +data ThStage -- See Note [Template Haskell state diagram] in TcSplice + = Splice -- Inside a top-level splice splice + -- This code will be run *at compile time*; + -- the result replaces the splice + -- Binding level = 0 + Bool -- True if in a typed splice, False otherwise + + | Comp -- Ordinary Haskell code + -- Binding level = 1 + + | Brack -- Inside brackets + ThStage -- Enclosing stage + PendingStuff + +data PendingStuff + = RnPendingUntyped -- Renaming the inside of an *untyped* bracket + (TcRef [PendingRnSplice]) -- Pending splices in here + + | RnPendingTyped -- Renaming the inside of a *typed* bracket + + | TcPending -- Typechecking the inside of a typed bracket + (TcRef [PendingTcSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here + +topStage, topAnnStage, topSpliceStage :: ThStage +topStage = Comp +topAnnStage = Splice False +topSpliceStage = Splice False + +instance Outputable ThStage where + ppr (Splice _) = text "Splice" + ppr Comp = text "Comp" + ppr (Brack s _) = text "Brack" <> parens (ppr s) + +type ThLevel = Int + -- NB: see Note [Template Haskell levels] in TcSplice + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + -- NB: ThLevel is one greater than the 'n' in Fig 2 of the + -- original "Template meta-programming for Haskell" paper + +impLevel, outerLevel :: ThLevel +impLevel = 0 -- Imported things; they can be used inside a top level splice +outerLevel = 1 -- Things defined outside brackets + +thLevel :: ThStage -> ThLevel +thLevel (Splice _) = 0 +thLevel Comp = 1 +thLevel (Brack s _) = thLevel s + 1 + +--------------------------- +-- Arrow-notation context +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +data ArrowCtxt -- Note [Escaping the arrow scope] + = NoArrowCtxt + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) + + +--------------------------- +-- TcTyThing +--------------------------- + +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId { -- Ids defined in this module; may not be fully zonked + tct_id :: TcId, + tct_closed :: TopLevelFlag } -- See Note [Bindings with closed types] + + | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type + -- variable is bound. We only need the Name + -- for error-message purposes; it is the corresponding + -- Name in the domain of the envt + + | AThing TcKind -- Used temporarily, during kind checking, for the + -- tycons and clases in this recursive group + -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see + -- Note [Type checking recursive type and class declarations] + + | APromotionErr PromotionErr + +data PromotionErr + = TyConPE -- TyCon used in a kind before we are ready + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] in TcRnDriver + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls + | NoDataKinds -- -XDataKinds not enabled + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = pprTyThing g + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon + <> ppr (varType (tct_id elt)) <> comma + <+> ppr (tct_closed elt)) + ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv + ppr (AThing k) = text "AThing" <+> ppr k + ppr (APromotionErr err) = text "APromotionErr" <+> ppr err + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr FamDataConPE = text "FamDataConPE" + ppr RecDataConPE = text "RecDataConPE" + ppr NoDataKinds = text "NoDataKinds" + +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing +pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable") +pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier") +pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing") +pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe + +pprPECategory :: PromotionErr -> SDoc +pprPECategory ClassPE = ptext (sLit "Class") +pprPECategory TyConPE = ptext (sLit "Type constructor") +pprPECategory FamDataConPE = ptext (sLit "Data constructor") +pprPECategory RecDataConPE = ptext (sLit "Data constructor") +pprPECategory NoDataKinds = ptext (sLit "Data constructor") + +{- +Note [Bindings with closed types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g ys = map not ys + in ... + +Can we generalise 'g' under the OutsideIn algorithm? Yes, +because all g's free variables are top-level; that is they themselves +have no free type variables, and it is the type variables in the +environment that makes things tricky for OutsideIn generalisation. + +Definition: + + A variable is "closed", and has tct_closed set to TopLevel, + iff + a) all its free variables are imported, or are themselves closed + b) generalisation is not restricted by the monomorphism restriction + +Under OutsideIn we are free to generalise a closed let-binding. +This is an extension compared to the JFP paper on OutsideIn, which +used "top-level" as a proxy for "closed". (It's not a good proxy +anyway -- the MR can make a top-level binding with a free type +variable.) + +Note that: + * A top-level binding may not be closed, if it suffer from the MR + + * A nested binding may be closed (eg 'g' in the example we started with) + Indeed, that's the point; whether a function is defined at top level + or nested is orthogonal to the question of whether or not it is closed + + * A binding may be non-closed because it mentions a lexically scoped + *type variable* Eg + f :: forall a. blah + f x = let g y = ...(y::a)... +-} + +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction + + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display + +{- +************************************************************************ +* * + Operations over ImportAvails +* * +************************************************************************ +-} + +-- | 'ImportAvails' summarises what was imported from where, irrespective of +-- whether the imported things are actually used or not. It is used: +-- +-- * when processing the export list, +-- +-- * when constructing usage info for the interface file, +-- +-- * to identify the list of directly imported modules for initialisation +-- purposes and for optimised overlap checking of family instances, +-- +-- * when figuring out what things are really unused +-- +data ImportAvails + = ImportAvails { + imp_mods :: ImportedMods, + -- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)], + -- ^ Domain is all directly-imported modules + -- The 'ModuleName' is what the module was imported as, e.g. in + -- @ + -- import Foo as Bar + -- @ + -- it is @Bar@. + -- + -- The 'Bool' means: + -- + -- - @True@ => import was @import Foo ()@ + -- + -- - @False@ => import was some other form + -- + -- Used + -- + -- (a) to help construct the usage information in the interface + -- file; if we import something we need to recompile if the + -- export version changes + -- + -- (b) to specify what child modules to initialise + -- + -- We need a full ModuleEnv rather than a ModuleNameEnv here, + -- because we might be importing modules of the same name from + -- different packages. (currently not the case, but might be in the + -- future). + + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: [PackageKey], + -- ^ Packages needed by the module being compiled, whether directly, + -- or via other modules in this package, or via modules imported + -- from other packages. + + imp_trust_pkgs :: [PackageKey], + -- ^ This is strictly a subset of imp_dep_pkgs and records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- While perhaps making imp_dep_pkgs a tuple of (PackageKey, Bool) + -- where True for the bool indicates the package is required to be + -- trusted is the more logical design, doing so complicates a lot + -- of code not concerned with Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [RnNames . Trust Own Package] + + imp_orphs :: [Module], + -- ^ Orphan modules below us in the import tree (and maybe including + -- us for imported modules) + + imp_finsts :: [Module] + -- ^ Family instance modules below us in the import tree (and maybe + -- including us for imported modules) + } + +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleNameEnv (ModuleName, IsBootInterface) +mkModDeps deps = foldl add emptyUFM deps + where + add env elt@(m,_) = addToUFM env m elt + +emptyImportAvails :: ImportAvails +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = [], + imp_trust_pkgs = [], + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a separate ImportAvails structure +-- and then union them all together with this function. +plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails +plusImportAvails + (ImportAvails { imp_mods = mods1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, + imp_orphs = orphs1, imp_finsts = finsts1 }) + (ImportAvails { imp_mods = mods2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, + imp_orphs = orphs2, imp_finsts = finsts2 }) + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } + where + plus_mod_dep (m1, boot1) (m2, boot2) + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that + +{- +************************************************************************ +* * +\subsection{Where from} +* * +************************************************************************ + +The @WhereFrom@ type controls where the renamer looks for an interface file +-} + +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin; + -- See Note [Care with plugin imports] in LoadIface + +instance Outputable WhereFrom where + ppr (ImportByUser is_boot) | is_boot = ptext (sLit "{- SOURCE -}") + | otherwise = empty + ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") + ppr ImportByPlugin = ptext (sLit "{- PLUGIN -}") + +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} + +-- The syntax of xi types: +-- xi ::= a | T xis | xis -> xis | ... | forall a. tau +-- Two important notes: +-- (i) No type families, unless we are under a ForAll +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms +-- will not contain any type functions, unless we are under a ForAll. +-- We enforce the structure of Xi types when we flatten (TcCanonical) + +type Xi = Type -- In many comments, "xi" ranges over Xi + +type Cts = Bag Ct + +data Ct + -- Atomic canonical constraints + = CDictCan { -- e.g. Num xi + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_class :: Class, + cc_tyargs :: [Xi] -- cc_tyargs are function-free, hence Xi + } + + | CIrredEvCan { -- These stand for yet-unusable predicates + cc_ev :: CtEvidence -- See Note [Ct/evidence invariant] + -- The ctev_pred of the evidence is + -- of form (tv xi1 xi2 ... xin) + -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails + -- or (F tys ~ ty) where the CFunEqCan kind invariant fails + -- See Note [CIrredEvCan constraints] + } + + | CTyEqCan { -- tv ~ rhs + -- Invariants: + -- * See Note [Applying the inert substitution] in TcFlatten + -- * tv not in tvs(rhs) (occurs check) + -- * If tv is a TauTv, then rhs has no foralls + -- (this avoids substituting a forall for the tyvar in other types) + -- * typeKind ty `subKind` typeKind tv + -- See Note [Kind orientation for CTyEqCan] + -- * rhs is not necessarily function-free, + -- but it has no top-level function. + -- E.g. a ~ [F b] is fine + -- but a ~ F b is not + -- * If the equality is representational, rhs has no top-level newtype + -- See Note [No top-level newtypes on RHS of representational + -- equalities] in TcCanonical + -- * If rhs is also a tv, then it is oriented to give best chance of + -- unification happening; eg if rhs is touchable then lhs is too + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_tyvar :: TcTyVar, + cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) + -- See invariants above + cc_eq_rel :: EqRel + } + + | CFunEqCan { -- F xis ~ fsk + -- Invariants: + -- * isTypeFamilyTyCon cc_fun + -- * typeKind (F xis) = tyVarKind fsk + -- * always Nominal role + -- * always Given or Wanted, never Derived + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_fun :: TyCon, -- A type function + + cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) + -- Either under-saturated or exactly saturated + -- *never* over-saturated (because if so + -- we should have decomposed) + + cc_fsk :: TcTyVar -- [Given] always a FlatSkol skolem + -- [Wanted] always a FlatMetaTv unification variable + -- See Note [The flattening story] in TcFlatten + } + + | CNonCanonical { -- See Note [NonCanonical Semantics] + cc_ev :: CtEvidence + } + + | CHoleCan { -- Treated as an "insoluble" constraint + -- See Note [Insoluble constraints] + cc_ev :: CtEvidence, + cc_occ :: OccName, -- The name of this hole + cc_hole :: HoleSort -- The sort of this hole (expr, type, ...) + } + +-- | Used to indicate which sort of hole we have. +data HoleSort = ExprHole -- ^ A hole in an expression (TypedHoles) + | TypeHole -- ^ A hole in a type (PartialTypeSignatures) + +{- +Note [Kind orientation for CTyEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an equality (t:* ~ s:Open), we can't solve it by updating t:=s, +ragardless of how touchable 't' is, because the kinds don't work. + +Instead we absolutely must re-orient it. Reason: if that gets into the +inert set we'll start replacing t's by s's, and that might make a +kind-correct type into a kind error. After re-orienting, +we may be able to solve by updating s:=t. + +Hence in a CTyEqCan, (t:k1 ~ xi:k2) we require that k2 is a subkind of k1. + +If the two have incompatible kinds, we just don't use a CTyEqCan at all. +See Note [Equalities with incompatible kinds] in TcCanonical + +We can't require *equal* kinds, because + * wanted constraints don't necessarily have identical kinds + eg alpha::? ~ Int + * a solved wanted constraint becomes a given + +Note [Kind orientation for CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For (F xis ~ rhs) we require that kind(lhs) is a subkind of kind(rhs). +This really only maters when rhs is an Open type variable (since only type +variables have Open kinds): + F ty ~ (a:Open) +which can happen, say, from + f :: F a b + f = undefined -- The a:Open comes from instantiating 'undefined' + +Note that the kind invariant is maintained by rewriting. +Eg wanted1 rewrites wanted2; if both were compatible kinds before, + wanted2 will be afterwards. Similarly givens. + +Caveat: + - Givens from higher-rank, such as: + type family T b :: * -> * -> * + type instance T Bool = (->) + + f :: forall a. ((T a ~ (->)) => ...) -> a -> ... + flop = f (...) True + Whereas we would be able to apply the type instance, we would not be able to + use the given (T Bool ~ (->)) in the body of 'flop' + + +Note [CIrredEvCan constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CIrredEvCan constraints are used for constraints that are "stuck" + - we can't solve them (yet) + - we can't use them to solve other constraints + - but they may become soluble if we substitute for some + of the type variables in the constraint + +Example 1: (c Int), where c :: * -> Constraint. We can't do anything + with this yet, but if later c := Num, *then* we can solve it + +Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable + We don't want to use this to substitute 'b' for 'a', in case + 'k' is subequently unifed with (say) *->*, because then + we'd have ill-kinded types floating about. Rather we want + to defer using the equality altogether until 'k' get resolved. + +Note [Ct/evidence invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, + ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) +This holds by construction; look at the unique place where CDictCan is +built (in TcCanonical). + +In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in +the evidence may *not* be fully zonked; we are careful not to look at it +during constraint solving. See Note [Evidence field of CtEvidence] +-} + +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical ev = CNonCanonical { cc_ev = ev } + +mkNonCanonicalCt :: Ct -> Ct +mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } + +ctEvidence :: Ct -> CtEvidence +ctEvidence = cc_ev + +ctLoc :: Ct -> CtLoc +ctLoc = ctEvLoc . ctEvidence + +ctPred :: Ct -> PredType +-- See Note [Ct/evidence invariant] +ctPred ct = ctEvPred (cc_ev ct) + +-- | Get the flavour of the given 'Ct' +ctFlavour :: Ct -> CtFlavour +ctFlavour = ctEvFlavour . ctEvidence + +-- | Get the equality relation for the given 'Ct' +ctEqRel :: Ct -> EqRel +ctEqRel = ctEvEqRel . ctEvidence + +dropDerivedWC :: WantedConstraints -> WantedConstraints +-- See Note [Dropping derived constraints] +dropDerivedWC wc@(WC { wc_simple = simples }) + = wc { wc_simple = filterBag isWantedCt simples } + -- The wc_impl implications are already (recursively) filtered + +{- +Note [Dropping derived constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we discard derived constraints at the end of constraint solving; +see dropDerivedWC. For example + * If we have an unsolved (Ord a), we don't want to complain about + an unsolved (Eq a) as well. + +But we keep Derived *insoluble* constraints because they indicate a solid, +comprehensible error. Particularly: + + * Insolubles Givens indicate unreachable code + + * Insoluble kind equalities (e.g. [D] * ~ (* -> *)) may arise from + a type equality a ~ Int#, say + + * Insoluble derived wanted equalities (e.g. [D] Int ~ Bool) may + arise from functional dependency interactions. We are careful + to keep a good CtOrigin on such constraints (FunDepOrigin1, FunDepOrigin2) + so that we can produce a good error message (Trac #9612) + +Since we leave these Derived constraints in the residual WantedConstraints, +we must filter them out when we re-process the WantedConstraint, +in TcSimplify.solve_wanteds. + + +************************************************************************ +* * + CtEvidence + The "flavor" of a canonical constraint +* * +************************************************************************ +-} + +isWantedCt :: Ct -> Bool +isWantedCt = isWanted . cc_ev + +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . cc_ev + +isDerivedCt :: Ct -> Bool +isDerivedCt = isDerived . cc_ev + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCIrredEvCan :: Ct -> Bool +isCIrredEvCan (CIrredEvCan {}) = True +isCIrredEvCan _ = False + +isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) +isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) +isCFunEqCan_maybe _ = Nothing + +isCFunEqCan :: Ct -> Bool +isCFunEqCan (CFunEqCan {}) = True +isCFunEqCan _ = False + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False + +isHoleCt:: Ct -> Bool +isHoleCt (CHoleCan {}) = True +isHoleCt _ = False + +isTypedHoleCt :: Ct -> Bool +isTypedHoleCt (CHoleCan { cc_hole = ExprHole }) = True +isTypedHoleCt _ = False + +isPartialTypeSigCt :: Ct -> Bool +isPartialTypeSigCt (CHoleCan { cc_hole = TypeHole }) = True +isPartialTypeSigCt _ = False + +instance Outputable Ct where + ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) + where ct_sort = case ct of + CTyEqCan {} -> "CTyEqCan" + CFunEqCan {} -> "CFunEqCan" + CNonCanonical {} -> "CNonCanonical" + CDictCan {} -> "CDictCan" + CIrredEvCan {} -> "CIrredEvCan" + CHoleCan {} -> "CHoleCan" + +singleCt :: Ct -> Cts +singleCt = unitBag + +andCts :: Cts -> Cts -> Cts +andCts = unionBags + +listToCts :: [Ct] -> Cts +listToCts = listToBag + +ctsElts :: Cts -> [Ct] +ctsElts = bagToList + +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag + +extendCtsList :: Cts -> [Ct] -> Cts +extendCtsList cts xs | null xs = cts + | otherwise = cts `unionBags` listToBag xs + +andManyCts :: [Cts] -> Cts +andManyCts = unionManyBags + +emptyCts :: Cts +emptyCts = emptyBag + +isEmptyCts :: Cts -> Bool +isEmptyCts = isEmptyBag + +pprCts :: Cts -> SDoc +pprCts cts = vcat (map ppr (bagToList cts)) + +{- +************************************************************************ +* * + Wanted constraints + These are forced to be in TcRnTypes because + TcLclEnv mentions WantedConstraints + WantedConstraint mentions CtLoc + CtLoc mentions ErrCtxt + ErrCtxt mentions TcM +* * +v%************************************************************************ +-} + +data WantedConstraints + = WC { wc_simple :: Cts -- Unsolved constraints, all wanted + , wc_impl :: Bag Implication + , wc_insol :: Cts -- Insoluble constraints, can be + -- wanted, given, or derived + -- See Note [Insoluble constraints] + } + +emptyWC :: WantedConstraints +emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag } + +mkSimpleWC :: [Ct] -> WantedConstraints +mkSimpleWC cts + = WC { wc_simple = listToBag cts, wc_impl = emptyBag, wc_insol = emptyBag } + +isEmptyWC :: WantedConstraints -> Bool +isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n }) + = isEmptyBag f && isEmptyBag i && isEmptyBag n + +insolubleWC :: WantedConstraints -> Bool +-- True if there are any insoluble constraints in the wanted bag. Ignore +-- constraints arising from PartialTypeSignatures to solve as much of the +-- constraints as possible before reporting the holes. +insolubleWC wc = not (isEmptyBag (filterBag (not . isPartialTypeSigCt) + (wc_insol wc))) + || anyBag ic_insol (wc_impl wc) + +andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints +andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 }) + (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 }) + = WC { wc_simple = f1 `unionBags` f2 + , wc_impl = i1 `unionBags` i2 + , wc_insol = n1 `unionBags` n2 } + +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + +addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints +addSimples wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + +addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } + +addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints +addInsols wc cts + = wc { wc_insol = wc_insol wc `unionBags` cts } + +instance Outputable WantedConstraints where + ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n}) + = ptext (sLit "WC") <+> braces (vcat + [ ppr_bag (ptext (sLit "wc_simple")) s + , ppr_bag (ptext (sLit "wc_insol")) n + , ppr_bag (ptext (sLit "wc_impl")) i ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldrBag (($$) . ppr) empty bag) + +{- +************************************************************************ +* * + Implication constraints +* * +************************************************************************ +-} + +data Implication + = Implic { + ic_tclvl :: TcLevel, -- TcLevel: unification variables + -- free in the environment + + ic_skols :: [TcTyVar], -- Introduced skolems + ic_info :: SkolemInfo, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_given :: [EvVar], -- Given evidence variables + -- (order does not matter) + -- See Invariant (GivenInv) in TcType + + ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure + -- False <=> ic_givens might have equalities + + ic_env :: TcLclEnv, -- Gives the source location and error context + -- for the implicatdion, and hence for all the + -- given evidence variables + + ic_wanted :: WantedConstraints, -- The wanted + ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true + + ic_binds :: EvBindsVar -- Points to the place to fill in the + -- abstraction and bindings + } + +instance Outputable Implication where + ppr (Implic { ic_tclvl = tclvl, ic_skols = skols + , ic_given = given, ic_no_eqs = no_eqs + , ic_wanted = wanted, ic_insol = insol + , ic_binds = binds, ic_info = info }) + = hang (ptext (sLit "Implic") <+> lbrace) + 2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl + , ptext (sLit "Skolems =") <+> pprTvBndrs skols + , ptext (sLit "No-eqs =") <+> ppr no_eqs + , ptext (sLit "Insol =") <+> ppr insol + , hang (ptext (sLit "Given =")) 2 (pprEvVars given) + , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) + , ptext (sLit "Binds =") <+> ppr binds + , pprSkolInfo info ] <+> rbrace) + +{- +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem varibles bound in ic_skols are all freah when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + +Note [Skolems in an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems in an implication are not there to perform a skolem escape +check. That happens because all the environment variables are in the +untouchables, and therefore cannot be unified with anything at all, +let alone the skolems. + +Instead, ic_skols is used only when considering floating a constraint +outside the implication in TcSimplify.floatEqualities or +TcSimplify.approximateImplications + +Note [Insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the errors that we get during canonicalization are best +reported when all constraints have been simplified as much as +possible. For instance, assume that during simplification the +following constraints arise: + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta + +When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail +we will simply see a message: + 'Can't construct the infinite type beta ~ uf1 beta' +and the user has no idea what the uf1 variable is. + +Instead our plan is that we will NOT fail immediately, but: + (1) Record the "frozen" error in the ic_insols field + (2) Isolate the offending constraint from the rest of the inerts + (3) Keep on simplifying/canonicalizing + +At the end, we will hopefully have substituted uf1 := F alpha, and we +will be able to report a more informative error: + 'Can't construct the infinite type beta ~ F alpha beta' + +Insoluble constraints *do* include Derived constraints. For example, +a functional dependency might give rise to [D] Int ~ Bool, and we must +report that. If insolubles did not contain Deriveds, reportErrors would +never see it. + + +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) + +pprEvVarTheta :: [EvVar] -> SDoc +pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) + +pprEvVarWithType :: EvVar -> SDoc +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) + +{- +************************************************************************ +* * + CtEvidence +* * +************************************************************************ + +Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During constraint solving we never look at the type of ctev_evtm, or +ctev_evar; instead we look at the cte_pred field. The evtm/evar field +may be un-zonked. +-} + +data CtEvidence + = CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evtm :: EvTerm -- See Note [Evidence field of CtEvidence] + , ctev_loc :: CtLoc } + -- Truly given, not depending on subgoals + -- NB: Spontaneous unifications belong here + + | CtWanted { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] + , ctev_loc :: CtLoc } + -- Wanted goal + + | CtDerived { ctev_pred :: TcPredType + , ctev_loc :: CtLoc } + -- A goal that we don't really have to solve and can't immediately + -- rewrite anything other than a derived (there's no evidence!) + -- but if we do manage to solve it may help in solving other goals. + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred = ctev_pred + +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc = ctev_loc + +-- | Get the equality relation relevant for a 'CtEvidence' +ctEvEqRel :: CtEvidence -> EqRel +ctEvEqRel = predTypeEqRel . ctEvPred + +-- | Get the role relevant for a 'CtEvidence' +ctEvRole :: CtEvidence -> Role +ctEvRole = eqRelRole . ctEvEqRel + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm (CtGiven { ctev_evtm = tm }) = tm +ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev +ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" + (ppr ctev) + +ctEvCoercion :: CtEvidence -> TcCoercion +-- ctEvCoercion ev = evTermCoercion (ctEvTerm ev) +ctEvCoercion (CtGiven { ctev_evtm = tm }) = evTermCoercion tm +ctEvCoercion (CtWanted { ctev_evar = v }) = mkTcCoVarCo v +ctEvCoercion ctev@(CtDerived {}) = pprPanic "ctEvCoercion: derived constraint cannot have id" + (ppr ctev) + +ctEvId :: CtEvidence -> TcId +ctEvId (CtWanted { ctev_evar = ev }) = ev +ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) + +instance Outputable CtEvidence where + ppr fl = case fl of + CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty + CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty + CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + where ppr_pty = dcolon <+> ppr (ctEvPred fl) + +isWanted :: CtEvidence -> Bool +isWanted (CtWanted {}) = True +isWanted _ = False + +isGiven :: CtEvidence -> Bool +isGiven (CtGiven {}) = True +isGiven _ = False + +isDerived :: CtEvidence -> Bool +isDerived (CtDerived {}) = True +isDerived _ = False + +{- +%************************************************************************ +%* * + CtFlavour +%* * +%************************************************************************ + +Just an enum type that tracks whether a constraint is wanted, derived, +or given, when we need to separate that info from the constraint itself. + +-} + +data CtFlavour = Given | Wanted | Derived + deriving Eq + +instance Outputable CtFlavour where + ppr Given = text "[G]" + ppr Wanted = text "[W]" + ppr Derived = text "[D]" + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtGiven {}) = Given +ctEvFlavour (CtDerived {}) = Derived + +{- +************************************************************************ +* * + SubGoalDepth +* * +************************************************************************ + +Note [SubGoalDepth] +~~~~~~~~~~~~~~~~~~~ +The 'SubGoalCounter' takes care of stopping the constraint solver from looping. +Because of the different use-cases of regular constaints and type function +applications, there are two independent counters. Therefore, this datatype is +abstract. See Note [WorkList] + +Each counter starts at zero and increases. + +* The "dictionary constraint counter" counts the depth of type class + instance declarations. Example: + [W] d{7} : Eq [Int] + That is d's dictionary-constraint depth is 7. If we use the instance + $dfEqList :: Eq a => Eq [a] + to simplify it, we get + d{7} = $dfEqList d'{8} + where d'{8} : Eq Int, and d' has dictionary-constraint depth 8. + + For civilised (decidable) instance declarations, each increase of + depth removes a type constructor from the type, so the depth never + gets big; i.e. is bounded by the structural depth of the type. + + The flag -fcontext-stack=n (not very well named!) fixes the maximium + level. + +* The "type function reduction counter" does the same thing when resolving +* qualities involving type functions. Example: + Assume we have a wanted at depth 7: + [W] d{7} : F () ~ a + If thre is an type function equation "F () = Int", this would be rewritten to + [W] d{8} : Int ~ a + and remembered as having depth 8. + + Again, without UndecidableInstances, this counter is bounded, but without it + can resolve things ad infinitum. Hence there is a maximum level. But we use a + different maximum, as we expect possibly many more type function reductions + in sensible programs than type class constraints. + + The flag -ftype-function-depth=n fixes the maximium level. +-} + +data SubGoalCounter = CountConstraints | CountTyFunApps + +data SubGoalDepth -- See Note [SubGoalDepth] + = SubGoalDepth + {-# UNPACK #-} !Int -- Dictionary constraints + {-# UNPACK #-} !Int -- Type function reductions + deriving (Eq, Ord) + +instance Outputable SubGoalDepth where + ppr (SubGoalDepth c f) = angleBrackets $ + char 'C' <> colon <> int c <> comma <> + char 'F' <> colon <> int f + +initialSubGoalDepth :: SubGoalDepth +initialSubGoalDepth = SubGoalDepth 0 0 + +maxSubGoalDepth :: DynFlags -> SubGoalDepth +maxSubGoalDepth dflags = SubGoalDepth (ctxtStkDepth dflags) (tyFunStkDepth dflags) + +bumpSubGoalDepth :: SubGoalCounter -> SubGoalDepth -> SubGoalDepth +bumpSubGoalDepth CountConstraints (SubGoalDepth c f) = SubGoalDepth (c+1) f +bumpSubGoalDepth CountTyFunApps (SubGoalDepth c f) = SubGoalDepth c (f+1) + +subGoalCounterValue :: SubGoalCounter -> SubGoalDepth -> Int +subGoalCounterValue CountConstraints (SubGoalDepth c _) = c +subGoalCounterValue CountTyFunApps (SubGoalDepth _ f) = f + +subGoalDepthExceeded :: SubGoalDepth -> SubGoalDepth -> Maybe SubGoalCounter +subGoalDepthExceeded (SubGoalDepth mc mf) (SubGoalDepth c f) + | c > mc = Just CountConstraints + | f > mf = Just CountTyFunApps + | otherwise = Nothing + +-- | Checks whether the evidence can be used to solve a goal with the given minimum depth +-- See Note [Preventing recursive dictionaries] +ctEvCheckDepth :: Class -> CtLoc -> CtEvidence -> Bool +ctEvCheckDepth cls target ev + | isWanted ev + , cls == coercibleClass -- The restriction applies only to Coercible + = ctLocDepth target <= ctLocDepth (ctEvLoc ev) + | otherwise = True + +{- +Note [Preventing recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this will go away when we start treating Coercible as an equality. + +We have some classes where it is not very useful to build recursive +dictionaries (Coercible, at the moment). So we need the constraint solver to +prevent that. We conservatively ensure this property using the subgoal depth of +the constraints: When solving a Coercible constraint at depth d, we do not +consider evidence from a depth <= d as suitable. + +Therefore we need to record the minimum depth allowed to solve a CtWanted. This +is done in the SubGoalDepth field of CtWanted. Most code now uses mkCtWanted, +which initializes it to initialSubGoalDepth (i.e. 0); but when requesting a +Coercible instance (requestCoercible in TcInteract), we bump the current depth +by one and use that. + +There are two spots where wanted contraints attempted to be solved +using existing constraints: lookupInertDict and lookupSolvedDict in +TcSMonad. Both use ctEvCheckDepth to make the check. That function +ensures that a Given constraint can always be used to solve a goal +(i.e. they are at depth infinity, for our purposes) + + +************************************************************************ +* * + CtLoc +* * +************************************************************************ + +The 'CtLoc' gives information about where a constraint came from. +This is important for decent error message reporting because +dictionaries don't appear in the original source code. +type will evolve... +-} + +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_depth :: !SubGoalDepth } + -- The TcLclEnv includes particularly + -- source location: tcl_loc :: RealSrcSpan + -- context: tcl_ctxt :: [ErrCtxt] + -- binder stack: tcl_bndrs :: [TcIdBinders] + -- level: tcl_tclvl :: TcLevel + +mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc tclvl skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = env { tcl_tclvl = tclvl } + , ctl_depth = initialSubGoalDepth } + +ctLocEnv :: CtLoc -> TcLclEnv +ctLocEnv = ctl_env + +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth + +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin + +ctLocSpan :: CtLoc -> RealSrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl + +setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc }) + +bumpCtLocDepth :: SubGoalCounter -> CtLoc -> CtLoc +bumpCtLocDepth cnt loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth cnt d } + +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } + +setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc +setCtLocEnv ctl env = ctl { ctl_env = env } + +pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc +-- Just add information w/o updating the origin! +pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pprArising :: CtOrigin -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq and FunDep origins +pprArising (TypeEqOrigin {}) = empty +pprArising orig = pprCtOrigin orig + +pprArisingAt :: CtLoc -> SDoc +pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ pprCtOrigin o + , text "at" <+> ppr (tcl_loc lcl)] + +{- +************************************************************************ +* * + SkolemInfo +* * +************************************************************************ +-} + +-- SkolemInfo gives the origin of *given* constraints +-- a) type variables are skolemised +-- b) an implication constraint is generated +data SkolemInfo + = SigSkol UserTypeCtxt -- A skolem that is created by instantiating + Type -- a programmer-supplied type signature + -- Location of the binding site is on the TyVar + + -- The rest are for non-scoped skolems + | ClsSkol Class -- Bound at a class decl + | InstSkol -- Bound at an instance decl + | DataSkol -- Bound at a data type declaration + | FamInstSkol -- Bound at a family instance decl + | PatSkol -- An existential type variable bound by a pattern for + ConLike -- a data constructor with an existential type. + (HsMatchContext Name) + -- e.g. data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. + + | ArrowSkol -- An arrow form (see TcArrows) + + | IPSkol [HsIPName] -- Binding site of an implicit parameter + + | RuleSkol RuleName -- The LHS of a RULE + + | InferSkol [(Name,TcType)] + -- We have inferred a type for these (mutually-recursivive) + -- polymorphic Ids, and are now checking that their RHS + -- constraints are satisfied. + + | BracketSkol -- Template Haskell bracket + + | UnifyForAllSkol -- We are unifying two for-all types + [TcTyVar] -- The instantiated skolem variables + TcType -- The instantiated type *inside* the forall + + | UnkSkol -- Unhelpful info (until I improve it) + +instance Outputable SkolemInfo where + ppr = pprSkolInfo + +pprSkolInfo :: SkolemInfo -> SDoc +-- Complete the sentence "is a rigid type variable bound by..." +pprSkolInfo (SigSkol (FunSigCtxt f) ty) + = hang (ptext (sLit "the type signature for")) + 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) +pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon) + 2 (ppr ty) +pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter binding") <> plural ips <+> ptext (sLit "for") + <+> pprWithCommas ppr ips +pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) +pprSkolInfo InstSkol = ptext (sLit "the instance declaration") +pprSkolInfo DataSkol = ptext (sLit "the data type declaration") +pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration") +pprSkolInfo BracketSkol = ptext (sLit "a Template Haskell bracket") +pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name) +pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") +pprSkolInfo (PatSkol cl mc) = case cl of + RealDataCon dc -> sep [ ptext (sLit "a pattern with constructor") + , nest 2 $ ppr dc <+> dcolon + <+> pprType (dataConUserType dc) <> comma + -- pprType prints forall's regardless of -fprint-explict-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... + , ptext (sLit "in") <+> pprMatchContext mc ] + PatSynCon ps -> sep [ ptext (sLit "a pattern with pattern synonym") + , nest 2 $ ppr ps <+> dcolon + <+> pprType (patSynType ps) <> comma + , ptext (sLit "in") <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") + , vcat [ ppr name <+> dcolon <+> ppr ty + | (name,ty) <- ids ]] +pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) + +-- UnkSkol +-- For type variables the others are dealt with by pprSkolTvBinding. +-- For Insts, these cases should not happen +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") + +{- +************************************************************************ +* * + CtOrigin +* * +************************************************************************ +-} + +data CtOrigin + = GivenOrigin SkolemInfo + + -- All the others are for *wanted* constraints + | OccurrenceOf Name -- Occurrence of an overloaded identifier + | AppOrigin -- An application of some kind + + | SpecPragOrigin Name -- Specialisation pragma for identifier + + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType } + | KindEqOrigin + TcType TcType -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this + | CoercibleOrigin TcType TcType -- a Coercible constraint + + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + + | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation + + | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc + | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] + | SectionOrigin + | TupleOrigin -- (..,..) + | ExprSigOrigin -- e :: ty + | PatSigOrigin -- p :: ty + | PatOrigin -- Instantiating a polytyped pattern at a constructor + | RecordUpdOrigin + | ViewPatOrigin + + | ScOrigin -- Typechecking superclasses of an instance declaration + | DerivOrigin -- Typechecking deriving + | DerivOriginDC DataCon Int + -- Checking constraints arising from this data con and field index + | DerivOriginCoerce Id Type Type + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + | StandAloneDerivOrigin -- Typechecking stand-alone deriving + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression + | MCompOrigin -- Arising from a monad comprehension + | IfOrigin -- Arising from an if statement + | ProcOrigin -- Arising from a proc expression + | AnnOrigin -- An annotation + + | FunDepOrigin1 -- A functional dependency from combining + PredType CtLoc -- This constraint arising from ... + PredType CtLoc -- and this constraint arising from ... + + | FunDepOrigin2 -- A functional dependency from combining + PredType CtOrigin -- This constraint arising from ... + PredType SrcSpan -- and this instance + -- We only need a CtOrigin on the first, because the location + -- is pinned on the entire error message + + | HoleOrigin + | UnboundOccurrenceOf RdrName + | ListOrigin -- An overloaded list + | StaticOrigin -- A static form + +ctoHerald :: SDoc +ctoHerald = ptext (sLit "arising from") + +pprCtOrigin :: CtOrigin -> SDoc + +pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk + +pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2) + = hang (ctoHerald <+> ptext (sLit "a functional dependency between constraints:")) + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprArisingAt loc1) + , hang (quotes (ppr pred2)) 2 (pprArisingAt loc2) ]) + +pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) + = hang (ctoHerald <+> ptext (sLit "a functional dependency between:")) + 2 (vcat [ hang (ptext (sLit "constraint") <+> quotes (ppr pred1)) + 2 (pprArising orig1 ) + , hang (ptext (sLit "instance") <+> quotes (ppr pred2)) + 2 (ptext (sLit "at") <+> ppr loc2) ]) + +pprCtOrigin (KindEqOrigin t1 t2 _) + = hang (ctoHerald <+> ptext (sLit "a kind equality arising from")) + 2 (sep [ppr t1, char '~', ppr t2]) + +pprCtOrigin (UnboundOccurrenceOf name) + = ctoHerald <+> ptext (sLit "an undeclared identifier") <+> quotes (ppr name) + +pprCtOrigin (DerivOriginDC dc n) + = hang (ctoHerald <+> ptext (sLit "the") <+> speakNth n + <+> ptext (sLit "field of") <+> quotes (ppr dc)) + 2 (parens (ptext (sLit "type") <+> quotes (ppr ty))) + where + ty = dataConOrigArgTys dc !! (n-1) + +pprCtOrigin (DerivOriginCoerce meth ty1 ty2) + = hang (ctoHerald <+> ptext (sLit "the coercion of the method") <+> quotes (ppr meth)) + 2 (sep [ text "from type" <+> quotes (ppr ty1) + , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) + +pprCtOrigin (CoercibleOrigin ty1 ty2) + = hang (ctoHerald <+> text "trying to show that the representations of") + 2 (quotes (ppr ty1) <+> text "and" $$ + quotes (ppr ty2) <+> text "are the same") + +pprCtOrigin simple_origin + = ctoHerald <+> pprCtO simple_origin + +---------------- +pprCtO :: CtOrigin -> SDoc -- Ones that are short one-liners +pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] +pprCtO AppOrigin = ptext (sLit "an application") +pprCtO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)] +pprCtO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)] +pprCtO RecordUpdOrigin = ptext (sLit "a record update") +pprCtO ExprSigOrigin = ptext (sLit "an expression type signature") +pprCtO PatSigOrigin = ptext (sLit "a pattern type signature") +pprCtO PatOrigin = ptext (sLit "a pattern") +pprCtO ViewPatOrigin = ptext (sLit "a view pattern") +pprCtO IfOrigin = ptext (sLit "an if statement") +pprCtO (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)] +pprCtO (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)] +pprCtO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)] +pprCtO SectionOrigin = ptext (sLit "an operator section") +pprCtO TupleOrigin = ptext (sLit "a tuple") +pprCtO NegateOrigin = ptext (sLit "a use of syntactic negation") +pprCtO ScOrigin = ptext (sLit "the superclasses of an instance declaration") +pprCtO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") +pprCtO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") +pprCtO DefaultOrigin = ptext (sLit "a 'default' declaration") +pprCtO DoOrigin = ptext (sLit "a do statement") +pprCtO MCompOrigin = ptext (sLit "a statement in a monad comprehension") +pprCtO ProcOrigin = ptext (sLit "a proc expression") +pprCtO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] +pprCtO AnnOrigin = ptext (sLit "an annotation") +pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") +pprCtO ListOrigin = ptext (sLit "an overloaded list") +pprCtO StaticOrigin = ptext (sLit "a static form") +pprCtO _ = panic "pprCtOrigin" + +{- +Constraint Solver Plugins +------------------------- +-} + +type TcPluginSolver = [Ct] -- given + -> [Ct] -- derived + -> [Ct] -- wanted + -> TcPluginM TcPluginResult + +newtype TcPluginM a = TcPluginM (TcM a) + +instance Functor TcPluginM where + fmap = liftM + +instance Applicative TcPluginM where + pure = return + (<*>) = ap + +instance Monad TcPluginM where + return x = TcPluginM (return x) + fail x = TcPluginM (fail x) + TcPluginM m >>= k = + TcPluginM (do a <- m + let TcPluginM m1 = k a + m1) + +runTcPluginM :: TcPluginM a -> TcM a +runTcPluginM (TcPluginM m) = m + +-- | This function provides an escape for direct access to +-- the 'TcM` monad. It should not be used lightly, and +-- the provided 'TcPluginM' API should be favoured instead. +unsafeTcPluginTcM :: TcM a -> TcPluginM a +unsafeTcPluginTcM = TcPluginM + +data TcPlugin = forall s. TcPlugin + { tcPluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + + , tcPluginSolve :: s -> TcPluginSolver + -- ^ Solve some constraints. + -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. + + , tcPluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + +data TcPluginResult + = TcPluginContradiction [Ct] + -- ^ The plugin found a contradiction. + -- The returned constraints are removed from the inert set, + -- and recorded as insoluable. + + | TcPluginOk [(EvTerm,Ct)] [Ct] + -- ^ The first field is for constraints that were solved. + -- These are removed from the inert set, + -- and the evidence for them is recorded. + -- The second field contains new work, that should be processed by + -- the constraint solver. diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs new file mode 100644 index 00000000..96de43ea --- /dev/null +++ b/compiler/typecheck/TcRules.hs @@ -0,0 +1,237 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +TcRules: Typechecking transformation rules +-} + +module TcRules ( tcRules ) where + +import HsSyn +import TcRnMonad +import TcSimplify +import TcMType +import TcType +import TcHsType +import TcExpr +import TcEnv +import TcEvidence( TcEvBinds(..) ) +import Type +import Id +import Name +import SrcLoc +import Outputable +import FastString +import Data.List( partition ) + +{- +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the typ of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + +Note [Simplifying RULE constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the LHS of transformation rules we only simplify only equalities, +but not dictionaries. We want to keep dictionaries unsimplified, to +serve as the available stuff for the RHS of the rule. We *do* want to +simplify equalities, however, to detect ill-typed rules that cannot be +applied. + +Implementation: the TcSFlags carried by the TcSMonad controls the +amount of simplification, so simplifyRuleLhs just sets the flag +appropriately. + +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the agument type of g. So we +revert to SimplCheck when going under an implication. + + +------------------------ So the plan is this ----------------------- + +* Step 1: Simplify the LHS and RHS constraints all together in one bag + We do this to discover all unification equalities + +* Step 2: Zonk the ORIGINAL lhs constraints, and partition them into + the ones we will quantify over, and the others + +* Step 3: Decide on the type variables to quantify over + +* Step 4: Simplify the LHS and RHS constraints separately, using the + quantified constraints as givens +-} + +tcRules :: [LRuleDecls Name] -> TcM [LRuleDecls TcId] +tcRules decls = mapM (wrapLocM tcRuleDecls) decls + +tcRuleDecls :: RuleDecls Name -> TcM (RuleDecls TcId) +tcRuleDecls (HsRules src decls) + = do { tc_decls <- mapM (wrapLocM tcRule) decls + ; return (HsRules src tc_decls) } + +tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) +tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) + = addErrCtxt (ruleCtxt $ unLoc name) $ + do { traceTc "---- Rule ------" (ppr name) + + -- Note [Typechecking rules] + ; (vars, bndr_wanted) <- captureConstraints $ + tcRuleBndrs hs_bndrs + -- bndr_wanted constraints can include wildcard hole + -- constraints, which we should not forget about. + -- It may mention the skolem type variables bound by + -- the RULE. c.f. Trac #10072 + + ; let (id_bndrs, tv_bndrs) = partition isId vars + ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) + <- tcExtendTyVarEnv tv_bndrs $ + tcExtendIdEnv id_bndrs $ + do { ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) + ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) + ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } + + ; (lhs_evs, other_lhs_wanted) <- simplifyRule (unLoc name) + (bndr_wanted `andWC` lhs_wanted) + rhs_wanted + + -- Now figure out what to quantify over + -- c.f. TcSimplify.simplifyInfer + -- We quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- We also need to get the completely-uconstrained tyvars of + -- the LHS, lest they otherwise get defaulted to Any; but we do that + -- during zonking (see TcHsSyn.zonkRule) + + ; let tpl_ids = lhs_evs ++ id_bndrs + forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) + ; gbls <- tcGetGlobalTyVars -- Even though top level, there might be top-level + -- monomorphic bindings from the MR; test tc111 + ; qtkvs <- quantifyTyVars gbls forall_tvs + ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ unLoc name) + , ppr forall_tvs + , ppr qtkvs + , ppr rule_ty + , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- Simplify the RHS constraints + ; lcl_env <- getLclEnv + ; rhs_binds_var <- newTcEvBinds + ; emitImplication $ Implic { ic_tclvl = topTcLevel + , ic_skols = qtkvs + , ic_no_eqs = False + , ic_given = lhs_evs + , ic_wanted = rhs_wanted + , ic_insol = insolubleWC rhs_wanted + , ic_binds = rhs_binds_var + , ic_info = RuleSkol (unLoc name) + , ic_env = lcl_env } + + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + ; lhs_binds_var <- newTcEvBinds + ; emitImplication $ Implic { ic_tclvl = topTcLevel + , ic_skols = qtkvs + , ic_no_eqs = False + , ic_given = lhs_evs + , ic_wanted = other_lhs_wanted + , ic_insol = insolubleWC other_lhs_wanted + , ic_binds = lhs_binds_var + , ic_info = RuleSkol (unLoc name) + , ic_env = lcl_env } + + ; return (HsRule name act + (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids)) + (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs + (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) } + +tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var] +tcRuleBndrs [] + = return [] +tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs) + = do { ty <- newFlexiTyVarTy openTypeKind + ; vars <- tcRuleBndrs rule_bndrs + ; return (mkLocalId name ty : vars) } +tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) +-- e.g x :: a->a +-- The tyvar 'a' is brought into scope first, just as if you'd written +-- a::*, x :: a->a + = do { let ctxt = RuleSigCtxt name + ; (id_ty, tv_prs, _) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name id_ty + tvs = map snd tv_prs + -- tcHsPatSigType returns (Name,TyVar) pairs + -- for for RuleSigCtxt their Names are not + -- cloned, so we get (n, tv-with-name-n) pairs + -- See Note [Pattern signature binders] in TcHsType + + -- The type variables scope over subsequent bindings; yuk + ; vars <- tcExtendTyVarEnv tvs $ + tcRuleBndrs rule_bndrs + ; return (tvs ++ id : vars) } + +ruleCtxt :: FastString -> SDoc +ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> + doubleQuotes (ftext name) diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs new file mode 100644 index 00000000..4c9ab2f4 --- /dev/null +++ b/compiler/typecheck/TcSMonad.hs @@ -0,0 +1,1808 @@ +{-# LANGUAGE CPP, TypeFamilies #-} + +-- Type definitions for the constraint solver +module TcSMonad ( + + -- The work list + WorkList(..), isEmptyWorkList, emptyWorkList, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, appendWorkList, selectWorkItem, + workListSize, + updWorkListTcS, updWorkListTcS_return, + runFlatten, emitFlatWork, + + -- The TcS monad + TcS, runTcS, runTcSWithEvBinds, + failTcS, tryTcS, nestTcS, nestImplicTcS, recoverTcS, + + runTcPluginTcS, addUsedRdrNamesTcS, deferTcSForAllEq, + + -- Tracing etc + panicTcS, traceTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + + -- Evidence creation and transformation + XEvTerm(..), + Freshness(..), freshGoals, isFresh, + + newTcEvBinds, newWantedEvVar, newWantedEvVarNC, + setWantedTyBind, reportUnifications, + setEvBind, + newEvVar, newGivenEvVar, newGivenEvVars, + newDerived, emitNewDerived, + instDFunConstraints, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getTcEvBinds, getTcLevel, + getTcEvBindsMap, + + -- Inerts + InertSet(..), InertCans(..), + updInertTcS, updInertCans, updInertDicts, updInertIrreds, + getNoGivenEqs, setInertCans, getInertEqs, getInertCans, + emptyInert, getTcSInerts, setTcSInerts, + getUnsolvedInerts, checkAllSolved, + splitInertCans, removeInertCts, + prepareInertsForImplications, + addInertCan, insertInertItemTcS, insertFunEq, + emitInsoluble, emitWorkNC, + EqualCtList, + + -- Inert CDictCans + lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts, + + -- Inert CTyEqCans + findTyEqs, + + -- Inert solved dictionaries + addSolvedDict, lookupSolvedDict, + + -- The flattening cache + lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems + + -- Inert CFunEqCans + updInertFunEqs, findFunEq, sizeFunEqMap, + findFunEqsByTyCon, findFunEqs, partitionFunEqs, + + instDFunType, -- Instantiation + + -- MetaTyVars + newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, + cloneMetaTyVar, demoteUnfilledFmv, + + TcLevel, isTouchableMetaTyVarTcS, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, + zonkTyVarsAndFV, zonkTcType, zonkTcTyVar, zonkSimples, + + -- References + newTcRef, readTcRef, updTcRef, + + -- Misc + getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, + matchFam, matchFamTcM, + checkWellStagedDFun, + pprEq -- Smaller utils, re-exported from TcM + -- TODO (DV): these are only really used in the + -- instance matcher in TcSimplify. I am wondering + -- if the whole instance matcher simply belongs + -- here +) where + +#include "HsVersions.h" + +import HscTypes + +import Inst +import InstEnv +import FamInst +import FamInstEnv + +import qualified TcRnMonad as TcM +import qualified TcMType as TcM +import qualified TcEnv as TcM + ( checkWellStaged, topIdLvl, tcGetDefaultTys ) +import Kind +import TcType +import DynFlags +import Type + +import TcEvidence +import Class +import TyCon + +import Name +import RdrName (RdrName, GlobalRdrEnv) +import RnEnv (addUsedRdrNames) +import Var +import VarEnv +import VarSet +import Outputable +import Bag +import UniqSupply + +import FastString +import Util +import Id +import TcRnTypes + +import Unique +import UniqFM +import Maybes ( orElse, firstJusts ) + +import TrieMap +import Control.Arrow ( first ) +import Control.Monad( ap, when, unless, MonadPlus(..) ) +import MonadUtils +import Data.IORef +import Data.List ( partition, foldl' ) + +#ifdef DEBUG +import Digraph +#endif + +{- +************************************************************************ +* * +* Worklists * +* Canonical and non-canonical constraints that the simplifier has to * +* work on. Including their simplification depths. * +* * +* * +************************************************************************ + +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A WorkList contains canonical and non-canonical items (of all flavors). +Notice that each Ct now has a simplification depth. We may +consider using this depth for prioritization as well in the future. + +As a simple form of priority queue, our worklist separates out +equalities (wl_eqs) from the rest of the canonical constraints, +so that it's easier to deal with them first, but the separation +is not strictly necessary. Notice that non-canonical constraints +are also parts of the worklist. + +Note [The flattening work list] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "flattening work list", held in the tcs_flat_work field of TcSEnv, +is a list of CFunEqCans generated during flattening. The key idea +is this. Consider flattening (Eq (F (G Int) (H Bool)): + * The flattener recursively calls itself on sub-terms before building + the main term, so it will encounter the terms in order + G Int + H Bool + F (G Int) (H Bool) + flattening to sub-goals + w1: G Int ~ fuv0 + w2: H Bool ~ fuv1 + w3: F fuv0 fuv1 ~ fuv2 + + * Processing w3 first is BAD, because we can't reduce i t,so it'll + get put into the inert set, and later kicked out when w1, w2 are + solved. In Trac #9872 this led to inert sets containing hundreds + of suspended calls. + + * So we want to process w1, w2 first. + + * So you might think that we should just use a FIFO deque for the work-list, + so that putting adding goals in order w1,w2,w3 would mean we processed + w1 first. + + * BUT suppose we have 'type instance G Int = H Char'. Then processing + w1 leads to a new goal + w4: H Char ~ fuv0 + We do NOT want to put that on the far end of a deque! Instead we want + to put it at the *front* of the work-list so that we continue to work + on it. + +So the work-list structure is this: + + * The wl_funeqs is a LIFO stack; we push new goals (such as w4) on + top (extendWorkListFunEq), and take new work from the top + (selectWorkItem). + + * When flattening, emitFlatWork pushes new flattening goals (like + w1,w2,w3) onto the flattening work list, tcs_flat_work, another + push-down stack. + + * When we finish flattening, we *reverse* the tcs_flat_work stack + onto the wl_funeqs stack (which brings w1 to the top). + +The function runFlatten initialised the tcs_flat_work stack, and reverses +it onto wl_fun_eqs at the end. + +-} + +-- See Note [WorkList priorities] +data WorkList + = WL { wl_eqs :: [Ct] + , wl_funeqs :: [Ct] -- LIFO stack of goals + , wl_rest :: [Ct] + , wl_implics :: Bag Implication -- See Note [Residual implications] + } + +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList + (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1, wl_implics = implics1 }) + (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2, wl_implics = implics2 }) + = WL { wl_eqs = eqs1 ++ eqs2 + , wl_funeqs = funeqs1 ++ funeqs2 + , wl_rest = rest1 ++ rest2 + , wl_implics = implics1 `unionBags` implics2 } + + +workListSize :: WorkList -> Int +workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) + = length eqs + length funeqs + length rest + +extendWorkListEq :: Ct -> WorkList -> WorkList +extendWorkListEq ct wl + = wl { wl_eqs = ct : wl_eqs wl } + +extendWorkListFunEq :: Ct -> WorkList -> WorkList +extendWorkListFunEq ct wl + = wl { wl_funeqs = ct : wl_funeqs wl } + +extendWorkListNonEq :: Ct -> WorkList -> WorkList +-- Extension by non equality +extendWorkListNonEq ct wl + = wl { wl_rest = ct : wl_rest wl } + +extendWorkListImplic :: Implication -> WorkList -> WorkList +extendWorkListImplic implic wl + = wl { wl_implics = implic `consBag` wl_implics wl } + +extendWorkListCt :: Ct -> WorkList -> WorkList +-- Agnostic +extendWorkListCt ct wl + = case classifyPredType (ctPred ct) of + EqPred NomEq ty1 _ + | Just (tc,_) <- tcSplitTyConApp_maybe ty1 + , isTypeFamilyTyCon tc + -> extendWorkListFunEq ct wl + EqPred {} + -> extendWorkListEq ct wl + + _ -> extendWorkListNonEq ct wl + +extendWorkListCts :: [Ct] -> WorkList -> WorkList +-- Agnostic +extendWorkListCts cts wl = foldr extendWorkListCt wl cts + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs + , wl_rest = rest, wl_implics = implics }) + = null eqs && null rest && null funeqs && isEmptyBag implics + +emptyWorkList :: WorkList +emptyWorkList = WL { wl_eqs = [], wl_rest = [] + , wl_funeqs = [], wl_implics = emptyBag } + +selectWorkItem :: WorkList -> (Maybe Ct, WorkList) +selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) + = case (eqs,feqs,rest) of + (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts }) + (_,ct:fes,_) -> (Just ct, wl { wl_funeqs = fes }) + (_,_,ct:cts) -> (Just ct, wl { wl_rest = cts }) + (_,_,_) -> (Nothing,wl) + +-- Pretty printing +instance Outputable WorkList where + ppr (WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest, wl_implics = implics }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs) $ + ptext (sLit "Eqs =") <+> vcat (map ppr eqs) + , ppUnless (null feqs) $ + ptext (sLit "Funeqs =") <+> vcat (map ppr feqs) + , ppUnless (null rest) $ + ptext (sLit "Non-eqs =") <+> vcat (map ppr rest) + , ppUnless (isEmptyBag implics) $ + ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics)) + ]) + +emitFlatWork :: Ct -> TcS () +-- See Note [The flattening work list] +emitFlatWork ct + = TcS $ \env -> + do { let flat_ref = tcs_flat_work env + ; TcM.updTcRef flat_ref (ct :) } + +runFlatten :: TcS a -> TcS a +-- Run thing_inside (which does flattening), and put all +-- the work it generates onto the main work list +-- See Note [The flattening work list] +runFlatten (TcS thing_inside) + = TcS $ \env -> + do { let flat_ref = tcs_flat_work env + ; old_flats <- TcM.updTcRefX flat_ref (\_ -> []) + ; res <- thing_inside env + ; new_flats <- TcM.updTcRefX flat_ref (\_ -> old_flats) + ; TcM.updTcRef (tcs_worklist env) (add_flats new_flats) + ; return res } + where + add_flats new_flats wl + = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } + + add_funeqs [] wl = wl + add_funeqs (f:fs) wl = add_funeqs fs (f:wl) + -- add_funeqs fs ws = reverse fs ++ ws + -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] + -- = [f3,f2,f1,w1,w2,w3,w4] + +{- +************************************************************************ +* * +* Inert Sets * +* * +* * +************************************************************************ + +Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + + * All canonical + + * No two dictionaries with the same head + * No two CIrreds with the same type + + * Family equations inert wrt top-level family axioms + + * Dictionaries have no matching top-level instance + + * Given family or dictionary constraints don't mention touchable + unification variables + + * Non-CTyEqCan constraints are fully rewritten with respect + to the CTyEqCan equalities (modulo canRewrite of course; + eg a wanted cannot rewrite a given) + + * CTyEqCan equalities: see Note [Applying the inert substitution] + in TcFlatten + +Note [Type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-family equations, of form (ev : F tys ~ ty), live in three places + + * The work-list, of course + + * The inert_flat_cache. This is used when flattening, to get maximal + sharing. It contains lots of things that are still in the work-list. + E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the + work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work + list. Now if we flatten w2 before we get to w3, we still want to + share that (G a). + + Because it contains work-list things, DO NOT use the flat cache to solve + a top-level goal. Eg in the above example we don't want to solve w3 + using w3 itself! + + * The inert_funeqs are un-solved but fully processed and in the InertCans. +-} + +-- All Given (fully known) or Wanted or Derived +-- See Note [Detailed InertCans Invariants] for more +data InertCans + = IC { inert_eqs :: TyVarEnv EqualCtList + -- All CTyEqCans with NomEq; index is the LHS tyvar + + , inert_funeqs :: FunEqMap Ct + -- All CFunEqCans; index is the whole family head type. + + , inert_dicts :: DictMap Ct + -- Dictionaries only, index is the class + -- NB: index is /not/ the whole type because FD reactions + -- need to match the class but not necessarily the whole type. + + , inert_irreds :: Cts + -- Irreducible predicates + + , inert_insols :: Cts + -- Frozen errors (as non-canonicals) + } + +type EqualCtList = [Ct] +{- +Note [EqualCtList invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * All are equalities + * All these equalities have the same LHS + * The list is never empty + * No element of the list can rewrite any other + + From the fourth invariant it follows that the list is + - A single Given, or + - Any number of Wanteds and/or Deriveds +-} + +-- The Inert Set +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted, Derived (no Solved) + -- Sometimes called "the inert set" + + , inert_flat_cache :: FunEqMap (TcCoercion, TcType, CtFlavour) + -- See Note [Type family equations] + -- If F tys :-> (co, ty, ev), + -- then co :: F tys ~ ty + -- + -- Just a hash-cons cache for use when flattening only + -- These include entirely un-processed goals, so don't use + -- them to solve a top-level goal, else you may end up solving + -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache + -- when allocating a new flatten-skolem. + -- Not necessarily inert wrt top-level equations (or inert_cans) + + , inert_solved_dicts :: DictMap CtEvidence + -- Of form ev :: C t1 .. tn + -- Always the result of using a top-level instance declaration + -- - Used to avoid creating a new EvVar when we have a new goal + -- that we have solved in the past + -- - Stored not necessarily as fully rewritten + -- (ToDo: rewrite lazily when we lookup) + } + +instance Outputable InertCans where + ppr ics = vcat [ ptext (sLit "Equalities:") + <+> pprCts (foldVarEnv (\eqs rest -> listToBag eqs `andCts` rest) + emptyCts (inert_eqs ics)) + , ptext (sLit "Type-function equalities:") + <+> pprCts (funEqsToBag (inert_funeqs ics)) + , ptext (sLit "Dictionaries:") + <+> pprCts (dictsToBag (inert_dicts ics)) + , ptext (sLit "Irreds:") + <+> pprCts (inert_irreds ics) + , text "Insolubles =" <+> -- Clearly print frozen errors + braces (vcat (map ppr (Bag.bagToList $ inert_insols ics))) + ] + +instance Outputable InertSet where + ppr is = vcat [ ppr $ inert_cans is + , text "Solved dicts" <+> vcat (map ppr (bagToList (dictsToBag (inert_solved_dicts is)))) ] + +emptyInert :: InertSet +emptyInert + = IS { inert_cans = IC { inert_eqs = emptyVarEnv + , inert_dicts = emptyDicts + , inert_funeqs = emptyFunEqs + , inert_irreds = emptyCts + , inert_insols = emptyCts + } + , inert_flat_cache = emptyFunEqs + , inert_solved_dicts = emptyDictMap } + +--------------- +addInertCan :: InertCans -> Ct -> InertCans +-- Precondition: item /is/ canonical +addInertCan ics item@(CTyEqCan {}) + = ics { inert_eqs = add_eq (inert_eqs ics) item } + where + add_eq :: TyVarEnv EqualCtList -> Ct -> TyVarEnv EqualCtList + add_eq old_list it + = extendVarEnv_C (\old_eqs _new_eqs -> it : old_eqs) + old_list (cc_tyvar it) [it] + +addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) + = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } + +addInertCan ics item@(CIrredEvCan {}) + = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } + -- The 'False' is because the irreducible constraint might later instantiate + -- to an equality. + -- But since we try to simplify first, if there's a constraint function FC with + -- type instance FC Int = Show + -- we'll reduce a constraint (FC Int a) to Show a, and never add an inert irreducible + +addInertCan ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) + = ics { inert_dicts = addDict (inert_dicts ics) cls tys item } + +addInertCan _ item + = pprPanic "upd_inert set: can't happen! Inserting " $ + ppr item -- Can't be CNonCanonical, CHoleCan, + -- because they only land in inert_insols + +-------------- +insertInertItemTcS :: Ct -> TcS () +-- Add a new item in the inerts of the monad +insertInertItemTcS item + = do { traceTcS "insertInertItemTcS {" $ + text "Trying to insert new inert item:" <+> ppr item + + ; updInertCans (\ics -> addInertCan ics item) + + ; traceTcS "insertInertItemTcS }" $ empty } + +addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS () +-- Add a new item in the solved set of the monad +addSolvedDict item cls tys + | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!) + = return () + | otherwise + = do { traceTcS "updSolvedSetTcs:" $ ppr item + ; updInertTcS $ \ ics -> + ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } + +updInertTcS :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertTcS upd_fn + = do { is_var <- getTcSInertsRef + ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } + +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } + +updInertCans :: (InertCans -> InertCans) -> TcS () +-- Modify the inert set with the supplied function +updInertCans upd_fn + = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertDicts upd_fn + = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } + +updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertFunEqs upd_fn + = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } + +updInertIrreds :: (Cts -> Cts) -> TcS () +-- Modify the inert set with the supplied function +updInertIrreds upd_fn + = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } + + +prepareInertsForImplications :: InertSet -> (InertSet) +-- See Note [Preparing inert set for implications] +prepareInertsForImplications is@(IS { inert_cans = cans }) + = is { inert_cans = getGivens cans + , inert_flat_cache = emptyFunEqs } -- See Note [Do not inherit the flat cache] + where + getGivens (IC { inert_eqs = eqs + , inert_irreds = irreds + , inert_funeqs = funeqs + , inert_dicts = dicts }) + = IC { inert_eqs = filterVarEnv is_given_ecl eqs + , inert_funeqs = filterFunEqs isGivenCt funeqs + , inert_irreds = Bag.filterBag isGivenCt irreds + , inert_dicts = filterDicts isGivenCt dicts + , inert_insols = emptyCts } + + is_given_ecl :: EqualCtList -> Bool + is_given_ecl (ct:rest) | isGivenCt ct = ASSERT( null rest ) True + is_given_ecl _ = False + +{- +Note [Do not inherit the flat cache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to inherit the flat cache when processing nested +implications. Consider + a ~ F b, forall c. b~Int => blah +If we have F b ~ fsk in the flat-cache, and we push that into the +nested implication, we might miss that F b can be rewritten to F Int, +and hence perhpas solve it. Moreover, the fsk from outside is +flattened out after solving the outer level, but and we don't +do that flattening recursively. + +Note [Preparing inert set for implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before solving the nested implications, we trim the inert set, +retaining only Givens. These givens can be used when solving +the inner implications. + +There might be cases where interactions between wanteds at different levels +could help to solve a constraint. For example + + class C a b | a -> b + (C Int alpha), (forall d. C d blah => C Int a) + +If we pushed the (C Int alpha) inwards, as a given, it can produce a +fundep (alpha~a) and this can float out again and be used to fix +alpha. (In general we can't float class constraints out just in case +(C d blah) might help to solve (C Int a).) But we ignore this possiblity. + +For Derived constraints we don't have evidence, so we do not turn +them into Givens. There can *be* deriving CFunEqCans; see Trac #8129. +-} + +getInertEqs :: TcS (TyVarEnv EqualCtList) +getInertEqs + = do { inert <- getTcSInerts + ; return (inert_eqs (inert_cans inert)) } + +getUnsolvedInerts :: TcS ( Bag Implication + , Cts -- Tyvar eqs: a ~ ty + , Cts -- Fun eqs: F a ~ ty + , Cts -- Insoluble + , Cts ) -- All others +getUnsolvedInerts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds, inert_dicts = idicts + , inert_insols = insols } <- getInertCans + + ; let unsolved_tv_eqs = foldVarEnv (\cts rest -> + foldr add_if_unsolved rest cts) + emptyCts tv_eqs + unsolved_fun_eqs = foldFunEqs add_if_unsolved fun_eqs emptyCts + unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + + others = unsolved_irreds `unionBags` unsolved_dicts + + ; implics <- getWorkListImplics + + ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, insols, others) } + -- Keep even the given insolubles + -- so that we can report dead GADT pattern match branches + where + add_if_unsolved :: Ct -> Cts -> Cts + add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts + | otherwise = cts + + is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived + +getNoGivenEqs :: TcLevel -- TcLevel of this implication + -> [TcTyVar] -- Skolems of this implication + -> TcS Bool -- True <=> definitely no residual given equalities +-- See Note [When does an implication have given equalities?] +getNoGivenEqs tclvl skol_tvs + = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds, inert_funeqs = funeqs }) + <- getInertCans + ; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet + + has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False iirreds + || foldVarEnv ((||) . eqs_given_here local_fsks) False ieqs + + ; traceTcS "getNoGivenEqs" (vcat [ppr has_given_eqs, ppr inerts]) + ; return (not has_given_eqs) } + where + eqs_given_here :: VarSet -> EqualCtList -> Bool + eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }] + -- Givens are always a sigleton + = not (skolem_bound_here local_fsks tv) && ev_given_here ev + eqs_given_here _ _ = False + + ev_given_here :: CtEvidence -> Bool + -- True for a Given bound by the curent implication, + -- i.e. the current level + ev_given_here ev + = isGiven ev + && tclvl == tcl_tclvl (ctl_env (ctEvLoc ev)) + + add_fsk :: Ct -> VarSet -> VarSet + add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct + , isGiven ev = extendVarSet fsks tv + | otherwise = fsks + + skol_tv_set = mkVarSet skol_tvs + skolem_bound_here local_fsks tv -- See Note [Let-bound skolems] + = case tcTyVarDetails tv of + SkolemTv {} -> tv `elemVarSet` skol_tv_set + FlatSkol {} -> not (tv `elemVarSet` local_fsks) + _ -> False + +{- +Note [When does an implication have given equalities?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an implication + beta => alpha ~ Int +where beta is a unification variable that has already been unified +to () in an outer scope. Then we can float the (alpha ~ Int) out +just fine. So when deciding whether the givens contain an equality, +we should canonicalise first, rather than just looking at the original +givens (Trac #8644). + +So we simply look at the inert, canonical Givens and see if there are +any equalities among them, the calculation of has_given_eqs. There +are some wrinkles: + + * We must know which ones are bound in *this* implication and which + are bound further out. We can find that out from the TcLevel + of the Given, which is itself recorded in the tcl_tclvl field + of the TcLclEnv stored in the Given (ev_given_here). + + What about interactions between inner and outer givens? + - Outer given is rewritten by an inner given, then there must + have been an inner given equality, hence the “given-eq” flag + will be true anyway. + + - Inner given rewritten by outer, retains its level (ie. The inner one) + + * We must take account of *potential* equalities, like the one above: + beta => ...blah... + If we still don't know what beta is, we conservatively treat it as potentially + becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. + + * When flattening givens, we generate Given equalities like + : F [a] ~ f, + with Refl evidence, and we *don't* want those to count as an equality + in the givens! After all, the entire flattening business is just an + internal matter, and the evidence does not mention any of the 'givens' + of this implication. So we do not treat inert_funeqs as a 'given equality'. + + * See Note [Let-bound skolems] for another wrinkle + + * We do *not* need to worry about representational equalities, because + these do not affect the ability to float constraints. + +Note [Let-bound skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +If * the inert set contains a canonical Given CTyEqCan (a ~ ty) +and * 'a' is a skolem bound in this very implication, b + +then: +a) The Given is pretty much a let-binding, like + f :: (a ~ b->c) => a -> a + Here the equality constraint is like saying + let a = b->c in ... + It is not adding any new, local equality information, + and hence can be ignored by has_given_eqs + +b) 'a' will have been completely substituted out in the inert set, + so we can safely discard it. Notably, it doesn't need to be + returned as part of 'fsks' + +For an example, see Trac #9211. +-} + +splitInertCans :: InertCans -> ([Ct], [Ct], [Ct]) +-- ^ Extract the (given, derived, wanted) inert constraints +splitInertCans iCans = (given,derived,wanted) + where + allCts = foldDicts (:) (inert_dicts iCans) + $ foldFunEqs (:) (inert_funeqs iCans) + $ concat (varEnvElts (inert_eqs iCans)) + + (derived,other) = partition isDerivedCt allCts + (wanted,given) = partition isWantedCt other + +removeInertCts :: [Ct] -> InertCans -> InertCans +-- ^ Remove inert constraints from the 'InertCans', for use when a +-- typechecker plugin wishes to discard a given. +removeInertCts cts icans = foldl' removeInertCt icans cts + +removeInertCt :: InertCans -> Ct -> InertCans +removeInertCt is ct = + case ct of + + CDictCan { cc_class = cl, cc_tyargs = tys } -> + is { inert_dicts = delDict (inert_dicts is) cl tys } + + CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> + is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } + + CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> + is { inert_eqs = delTyEq (inert_eqs is) x ty } + + CIrredEvCan {} -> panic "removeInertCt: CIrredEvCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + CHoleCan {} -> panic "removeInertCt: CHoleCan" + + +checkAllSolved :: TcS Bool +-- True if there are no unsolved wanteds +-- Ignore Derived for this purpose, unless in insolubles +checkAllSolved + = do { is <- getTcSInerts + + ; let icans = inert_cans is + unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans) + unsolved_dicts = foldDicts ((||) . isWantedCt) + (inert_dicts icans) False + unsolved_funeqs = foldFunEqs ((||) . isWantedCt) + (inert_funeqs icans) False + unsolved_eqs = foldVarEnv ((||) . any isWantedCt) False + (inert_eqs icans) + + ; return (not (unsolved_eqs || unsolved_irreds + || unsolved_dicts || unsolved_funeqs + || not (isEmptyBag (inert_insols icans)))) } + +lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) +lookupFlatCache fam_tc tys + = do { IS { inert_flat_cache = flat_cache + , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (firstJusts [lookup_inerts inert_funeqs, + lookup_flats flat_cache]) } + where + lookup_inerts inert_funeqs + | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk }) + <- findFunEqs inert_funeqs fam_tc tys + = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) + | otherwise = Nothing + + lookup_flats flat_cache = findFunEq flat_cache fam_tc tys + + +lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) +-- Is this exact predicate type cached in the solved or canonicals of the InertSet? +lookupInInerts loc pty + | ClassPred cls tys <- classifyPredType pty + = do { inerts <- getTcSInerts + ; return (lookupSolvedDict inerts loc cls tys `mplus` + lookupInertDict (inert_cans inerts) loc cls tys) } + | otherwise -- NB: No caching for equalities, IPs, holes, or errors + = return Nothing + +lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +lookupInertDict (IC { inert_dicts = dicts }) loc cls tys + = case findDict dicts cls tys of + Just ct | let ev = ctEvidence ct + , ctEvCheckDepth cls loc ev + -> Just ev + _ -> Nothing + +lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys + = case findDict solved cls tys of + Just ev | ctEvCheckDepth cls loc ev -> Just ev + _ -> Nothing + +{- +************************************************************************ +* * + TyEqMap +* * +************************************************************************ +-} + +type TyEqMap a = TyVarEnv a + +findTyEqs :: InertCans -> TyVar -> EqualCtList +findTyEqs icans tv = lookupVarEnv (inert_eqs icans) tv `orElse` [] + +delTyEq :: TyEqMap EqualCtList -> TcTyVar -> TcType -> TyEqMap EqualCtList +delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv + where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 + isThisOne _ = False + +{- +************************************************************************ +* * + TcAppMap, DictMap, FunEqMap +* * +************************************************************************ +-} + +type TcAppMap a = UniqFM (ListMap TypeMap a) + -- Indexed by tycon then the arg types + -- Used for types and classes; hence UniqFM + +emptyTcAppMap :: TcAppMap a +emptyTcAppMap = emptyUFM + +findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a +findTcApp m u tys = do { tys_map <- lookupUFM m u + ; lookupTM tys tys_map } + +delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a +delTcApp m cls tys = adjustUFM (deleteTM tys) m cls + +insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a +insertTcApp m cls tys ct = alterUFM alter_tm m cls + where + alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) + +-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b +-- mapTcApp f = mapUFM (mapTM f) + +filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct +filterTcAppMap f m + = mapUFM do_tm m + where + do_tm tm = foldTM insert_mb tm emptyTM + insert_mb ct tm + | f ct = insertTM tys ct tm + | otherwise = tm + where + tys = case ct of + CFunEqCan { cc_tyargs = tys } -> tys + CDictCan { cc_tyargs = tys } -> tys + _ -> pprPanic "filterTcAppMap" (ppr ct) + +tcAppMapToBag :: TcAppMap a -> Bag a +tcAppMapToBag m = foldTcAppMap consBag m emptyBag + +foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b +foldTcAppMap k m z = foldUFM (foldTM k) z m + +------------------------- +type DictMap a = TcAppMap a + +emptyDictMap :: DictMap a +emptyDictMap = emptyTcAppMap + +-- sizeDictMap :: DictMap a -> Int +-- sizeDictMap m = foldDicts (\ _ x -> x+1) m 0 + +findDict :: DictMap a -> Class -> [Type] -> Maybe a +findDict m cls tys = findTcApp m (getUnique cls) tys + +findDictsByClass :: DictMap a -> Class -> Bag a +findDictsByClass m cls + | Just tm <- lookupUFM m cls = foldTM consBag tm emptyBag + | otherwise = emptyBag + +delDict :: DictMap a -> Class -> [Type] -> DictMap a +delDict m cls tys = delTcApp m (getUnique cls) tys + +addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a +addDict m cls tys item = insertTcApp m (getUnique cls) tys item + +addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct +addDictsByClass m cls items + = addToUFM m cls (foldrBag add emptyTM items) + where + add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm + add ct _ = pprPanic "addDictsByClass" (ppr ct) + +filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct +filterDicts f m = filterTcAppMap f m + +partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) +partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) + where + k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) + | otherwise = (yeses, add ct noes) + add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m + = addDict m cls tys ct + add ct _ = pprPanic "partitionDicts" (ppr ct) + +dictsToBag :: DictMap a -> Bag a +dictsToBag = tcAppMapToBag + +foldDicts :: (a -> b -> b) -> DictMap a -> b -> b +foldDicts = foldTcAppMap + +emptyDicts :: DictMap a +emptyDicts = emptyTcAppMap + +------------------------ +type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair + +emptyFunEqs :: TcAppMap a +emptyFunEqs = emptyTcAppMap + +sizeFunEqMap :: FunEqMap a -> Int +sizeFunEqMap m = foldFunEqs (\ _ x -> x+1) m 0 + +findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEq m tc tys = findTcApp m (getUnique tc) tys + +findFunEqs :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEqs m tc tys = findTcApp m (getUnique tc) tys + +funEqsToBag :: FunEqMap a -> Bag a +funEqsToBag m = foldTcAppMap consBag m emptyBag + +findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] +-- Get inert function equation constraints that have the given tycon +-- in their head. Not that the constraints remain in the inert set. +-- We use this to check for derived interactions with built-in type-function +-- constructors. +findFunEqsByTyCon m tc + | Just tm <- lookupUFM m tc = foldTM (:) tm [] + | otherwise = [] + +foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b +foldFunEqs = foldTcAppMap + +-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b +-- mapFunEqs = mapTcApp + +filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct +filterFunEqs = filterTcAppMap + +insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a +insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val + +-- insertFunEqCt :: FunEqMap Ct -> Ct -> FunEqMap Ct +-- insertFunEqCt m ct@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) +-- = insertFunEq m tc tys ct +-- insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct) + +partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) +-- Optimise for the case where the predicate is false +-- partitionFunEqs is called only from kick-out, and kick-out usually +-- kicks out very few equalities, so we want to optimise for that case +partitionFunEqs f m = (yeses, foldr del m yeses) + where + yeses = foldTcAppMap k m [] + k ct yeses | f ct = ct : yeses + | otherwise = yeses + del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m + = delFunEq m tc tys + del ct _ = pprPanic "partitionFunEqs" (ppr ct) + +delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a +delFunEq m tc tys = delTcApp m (getUnique tc) tys + +{- +************************************************************************ +* * +* The TcS solver monad * +* * +************************************************************************ + +Note [The TcS monad] +~~~~~~~~~~~~~~~~~~~~ +The TcS monad is a weak form of the main Tc monad + +All you can do is + * fail + * allocate new variables + * fill in evidence variables + +Filling in a dictionary evidence variable means to create a binding +for it, so TcS carries a mutable location where the binding can be +added. This is initialised from the innermost implication constraint. +-} + +data TcSEnv + = TcSEnv { + tcs_ev_binds :: EvBindsVar, + + tcs_unified :: IORef Bool, + -- The "dirty-flag" Bool is set True when + -- we unify a unification variable + + tcs_count :: IORef Int, -- Global step count + + tcs_inerts :: IORef InertSet, -- Current inert set + + -- The main work-list and the flattening worklist + -- See Note [Work list priorities] and + -- Note [The flattening work list] + tcs_worklist :: IORef WorkList, -- Current worklist + tcs_flat_work :: IORef [Ct] -- Flattening worklist + } + +--------------- +newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } + +instance Functor TcS where + fmap f m = TcS $ fmap f . unTcS m + +instance Applicative TcS where + pure = return + (<*>) = ap + +instance Monad TcS where + return x = TcS (\_ -> return x) + fail err = TcS (\_ -> fail err) + m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) + +instance MonadUnique TcS where + getUniqueSupplyM = wrapTcS getUniqueSupplyM + +-- Basic functionality +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +wrapTcS :: TcM a -> TcS a +-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, +-- and TcS is supposed to have limited functionality +wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds + +wrapErrTcS :: TcM a -> TcS a +-- The thing wrapped should just fail +-- There's no static check; it's up to the user +-- Having a variant for each error message is too painful +wrapErrTcS = wrapTcS + +wrapWarnTcS :: TcM a -> TcS a +-- The thing wrapped should just add a warning, or no-op +-- There's no static check; it's up to the user +wrapWarnTcS = wrapTcS + +failTcS, panicTcS :: SDoc -> TcS a +failTcS = wrapTcS . TcM.failWith +panicTcS doc = pprPanic "TcCanonical" doc + +traceTcS :: String -> SDoc -> TcS () +traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) + +runTcPluginTcS :: TcPluginM a -> TcS a +runTcPluginTcS = wrapTcS . runTcPluginM + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +csTraceTcS :: SDoc -> TcS () +csTraceTcS doc + = wrapTcS $ csTraceTcM 1 (return doc) + +traceFireTcS :: CtEvidence -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS ev doc + = TcS $ \env -> csTraceTcM 1 $ + do { n <- TcM.readTcRef (tcs_count env) + ; tclvl <- TcM.getTcLevel + ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl + <> ppr (ctLocDepth (ctEvLoc ev))) + <+> doc <> colon) + 4 (ppr ev)) } + +csTraceTcM :: Int -> TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM trace_level mk_doc + = do { dflags <- getDynFlags + ; when ( (dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags) + && trace_level <= traceLevel dflags ) $ + do { msg <- mk_doc + ; TcM.traceTcRn Opt_D_dump_cs_trace msg } } + +runTcS :: TcS a -- What to run + -> TcM (a, Bag EvBind) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds ev_binds_var tcs + = do { unified_var <- TcM.newTcRef False + ; step_count <- TcM.newTcRef 0 + ; inert_var <- TcM.newTcRef is + ; wl_var <- TcM.newTcRef emptyWorkList + ; fw_var <- TcM.newTcRef (panic "Flat work list") + + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_worklist = wl_var + , tcs_flat_work = fw_var } + + -- Run the computation + ; res <- unTcS tcs env + + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) + +#ifdef DEBUG + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; checkForCyclicBinds ev_binds +#endif + + ; return res } + where + is = emptyInert + +#ifdef DEBUG +checkForCyclicBinds :: Bag EvBind -> TcM () +checkForCyclicBinds ev_binds + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind b _) = isEqVar b + + edges :: [(EvBind, EvVar, [EvVar])] + edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] +#endif + +nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a +nestImplicTcS ref inner_tclvl (TcS thing_inside) + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = inerts { inert_flat_cache = emptyFunEqs } + -- See Note [Do not inherit the flat cache] + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_fw_var <- TcM.newTcRef (panic "Flat work list") + ; let nest_env = TcSEnv { tcs_ev_binds = ref + , tcs_unified = unified_var + , tcs_count = count + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var + , tcs_flat_work = new_fw_var } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env + +#ifdef DEBUG + -- Perform a check that the thing_inside did not cause cycles + ; ev_binds <- TcM.getTcEvBinds ref + ; checkForCyclicBinds ev_binds +#endif + + ; return res } + +recoverTcS :: TcS a -> TcS a -> TcS a +recoverTcS (TcS recovery_code) (TcS thing_inside) + = TcS $ \ env -> + TcM.recoverM (recovery_code env) (thing_inside env) + +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, and solved dictionaries +-- But have no effect on the InertCans, or on the inert_flat_cache +-- (the latter because the thing inside a nestTcS does unflattening) +nestTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; res <- thing_inside nest_env + + ; new_inerts <- TcM.readTcRef new_inert_var + ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] + (inerts { inert_solved_dicts = inert_solved_dicts new_inerts }) + + ; return res } + +tryTcS :: TcS a -> TcS a +-- Like runTcS, but from within the TcS monad +-- Completely fresh inerts and worklist, be careful! +-- Moreover, we will simply throw away all the evidence generated. +tryTcS (TcS thing_inside) + = TcS $ \env -> + do { is_var <- TcM.newTcRef emptyInert + ; unified_var <- TcM.newTcRef False + ; ev_binds_var <- TcM.newTcEvBinds + ; wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_inerts = is_var + , tcs_worklist = wl_var } + ; thing_inside nest_env } + +{- +Note [Propagate the solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really quite important that nestTcS does not discard the solved +dictionaries from the thing_inside. +Consider + Eq [a] + forall b. empty => Eq [a] +We solve the simple (Eq [a]), under nestTcS, and then turn our attention to +the implications. It's definitely fine to use the solved dictionaries on +the inner implications, and it can make a signficant performance difference +if you do so. +-} + +-- Getters and setters of TcEnv fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- Getter of inerts and worklist +getTcSInertsRef :: TcS (IORef InertSet) +getTcSInertsRef = TcS (return . tcs_inerts) + +getTcSWorkListRef :: TcS (IORef WorkList) +getTcSWorkListRef = TcS (return . tcs_worklist) + +getTcSInerts :: TcS InertSet +getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) + +setTcSInerts :: InertSet -> TcS () +setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) } + +getWorkListImplics :: TcS (Bag Implication) +getWorkListImplics + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; return (wl_implics wl_curr) } + +updWorkListTcS :: (WorkList -> WorkList) -> TcS () +updWorkListTcS f + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; let new_work = f wl_curr + ; wrapTcS (TcM.writeTcRef wl_var new_work) } + +updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a +-- Process the work list, returning a depleted work list, +-- plus a value extracted from it (typically a work item removed from it) +updWorkListTcS_return f + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; traceTcS "updWorkList" (ppr wl_curr) + ; let (res,new_work) = f wl_curr + ; wrapTcS (TcM.writeTcRef wl_var new_work) + ; return res } + +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = do { traceTcS "Emitting fresh work" (vcat (map ppr evs)) + ; updWorkListTcS (extendWorkListCts (map mkNonCanonical evs)) } + +emitInsoluble :: Ct -> TcS () +-- Emits a non-canonical constraint that will stand for a frozen error in the inerts. +emitInsoluble ct + = do { traceTcS "Emit insoluble" (ppr ct) + ; updInertTcS add_insol } + where + this_pred = ctPred ct + add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) }) + | already_there = is + | otherwise = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } } + where + already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols + -- See Note [Do not add duplicate derived insolubles] + +newTcRef :: a -> TcS (TcRef a) +newTcRef x = wrapTcS (TcM.newTcRef x) + +readTcRef :: TcRef a -> TcS a +readTcRef ref = wrapTcS (TcM.readTcRef ref) + +updTcRef :: TcRef a -> (a->a) -> TcS () +updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) + +getTcEvBinds :: TcS EvBindsVar +getTcEvBinds = TcS (return . tcs_ev_binds) + +getTcLevel :: TcS TcLevel +getTcLevel = wrapTcS TcM.getTcLevel + +getTcEvBindsMap :: TcS EvBindMap +getTcEvBindsMap + = do { EvBindsVar ev_ref _ <- getTcEvBinds + ; wrapTcS $ TcM.readTcRef ev_ref } + +setWantedTyBind :: TcTyVar -> TcType -> TcS () +-- Add a type binding +-- We never do this twice! +setWantedTyBind tv ty + | ASSERT2( isMetaTyVar tv, ppr tv ) + isFmvTyVar tv + = ASSERT2( isMetaTyVar tv, ppr tv ) + wrapTcS (TcM.writeMetaTyVar tv ty) + -- Write directly into the mutable tyvar + -- Flatten meta-vars are born and die locally + + | otherwise + = TcS $ \ env -> + do { TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.writeMetaTyVar tv ty + ; TcM.writeTcRef (tcs_unified env) True } + +reportUnifications :: TcS a -> TcS (Bool, a) +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef False + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; dirty <- TcM.readTcRef inner_unified + ; return (dirty, res) } + +getDefaultInfo :: TcS ([Type], (Bool, Bool)) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys + +-- Just get some environments needed for instance looking up and matching +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getInstEnvs :: TcS InstEnvs +getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs + +getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) +getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs + +getTopEnv :: TcS HscEnv +getTopEnv = wrapTcS $ TcM.getTopEnv + +getGblEnv :: TcS TcGblEnv +getGblEnv = wrapTcS $ TcM.getGblEnv + +-- Setting names as used (used in the deriving of Coercible evidence) +-- Too hackish to expose it to TcS? In that case somehow extract the used +-- constructors from the result of solveInteract +addUsedRdrNamesTcS :: [RdrName] -> TcS () +addUsedRdrNamesTcS names = wrapTcS $ addUsedRdrNames names + +-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS () +checkWellStagedDFun pred dfun_id loc + = wrapTcS $ TcM.setCtLoc loc $ + do { use_stage <- TcM.getStage + ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } + where + pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred) + bind_lvl = TcM.topIdLvl dfun_id + +pprEq :: TcType -> TcType -> SDoc +pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 + +isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool +isTouchableMetaTyVarTcS tv + = do { tclvl <- getTcLevel + ; return $ isTouchableMetaTyVar tclvl tv } + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- wrapTcS (TcM.readTcRef ref) + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + _ -> return Nothing + +isFilledMetaTyVar :: TcTyVar -> TcS Bool +isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) + +zonkTyVarsAndFV :: TcTyVarSet -> TcS TcTyVarSet +zonkTyVarsAndFV tvs = wrapTcS (TcM.zonkTyVarsAndFV tvs) + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = wrapTcS (TcM.zonkTcType ty) + +zonkTcTyVar :: TcTyVar -> TcS TcType +zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) + +zonkSimples :: Cts -> TcS Cts +zonkSimples cts = wrapTcS (TcM.zonkSimples cts) + +{- +Note [Do not add duplicate derived insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *must* add an insoluble (Int ~ Bool) even if there is +one such there already, because they may come from distinct call +sites. Not only do we want an error message for each, but with +-fdefer-type-errors we must generate evidence for each. But for +*derived* insolubles, we only want to report each one once. Why? + +(a) A constraint (C r s t) where r -> s, say, may generate the same fundep + equality many times, as the original constraint is sucessively rewritten. + +(b) Ditto the successive iterations of the main solver itself, as it traverses + the constraint tree. See example below. + +Also for *given* insolubles we may get repeated errors, as we +repeatedly traverse the constraint tree. These are relatively rare +anyway, so removing duplicates seems ok. (Alternatively we could take +the SrcLoc into account.) + +Note that the test does not need to be particularly efficient because +it is only used if the program has a type error anyway. + +Example of (b): assume a top-level class and instance declaration: + + class D a b | a -> b + instance D [a] [a] + +Assume we have started with an implication: + + forall c. Eq c => { wc_simple = D [c] c [W] } + +which we have simplified to: + + forall c. Eq c => { wc_simple = D [c] c [W] + , wc_insols = (c ~ [c]) [D] } + +For some reason, e.g. because we floated an equality somewhere else, +we might try to re-solve this implication. If we do not do a +dropDerivedWC, then we will end up trying to solve the following +constraints the second time: + + (D [c] c) [W] + (c ~ [c]) [D] + +which will result in two Deriveds to end up in the insoluble set: + + wc_simple = D [c] c [W] + wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] +-} + +-- Flatten skolems +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +newFlattenSkolem :: CtFlavour -> CtLoc + -> TcType -- F xis + -> TcS (CtEvidence, TcTyVar) -- [W] x:: F xis ~ fsk +newFlattenSkolem Given loc fam_ty + = do { fsk <- wrapTcS $ + do { uniq <- TcM.newUnique + ; let name = TcM.mkTcTyVarName uniq (fsLit "fsk") + ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } + ; let ev = CtGiven { ctev_pred = mkTcEqPred fam_ty (mkTyVarTy fsk) + , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty) + , ctev_loc = loc } + ; return (ev, fsk) } + +newFlattenSkolem _ loc fam_ty -- Make a wanted + = do { fuv <- wrapTcS $ + do { uniq <- TcM.newUnique + ; ref <- TcM.newMutVar Flexi + ; let details = MetaTv { mtv_info = FlatMetaTv + , mtv_ref = ref + , mtv_tclvl = fskTcLevel } + name = TcM.mkTcTyVarName uniq (fsLit "s") + ; return (mkTcTyVar name (typeKind fam_ty) details) } + ; ev <- newWantedEvVarNC loc (mkTcEqPred fam_ty (mkTyVarTy fuv)) + ; return (ev, fuv) } + +extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () +extendFlatCache tc xi_args stuff + = do { dflags <- getDynFlags + ; when (gopt Opt_FlatCache dflags) $ + updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> + is { inert_flat_cache = insertFunEq fc tc xi_args stuff } } + +-- Instantiations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcType) +instDFunType dfun_id mb_inst_tys + = wrapTcS $ go dfun_tvs mb_inst_tys (mkTopTvSubst []) + where + (dfun_tvs, dfun_phi) = tcSplitForAllTys (idType dfun_id) + + go :: [TyVar] -> [DFunInstType] -> TvSubst -> TcM ([TcType], TcType) + go [] [] subst = return ([], substTy subst dfun_phi) + go (tv:tvs) (Just ty : mb_tys) subst + = do { (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty) + ; return (ty : tys, phi) } + go (tv:tvs) (Nothing : mb_tys) subst + = do { ty <- instFlexiTcSHelper (tyVarName tv) (substTy subst (tyVarKind tv)) + -- Don't forget to instantiate the kind! + -- cf TcMType.tcInstTyVarX + ; (tys, phi) <- go tvs mb_tys (extendTvSubst subst tv ty) + ; return (ty : tys, phi) } + go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys) + +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + +demoteUnfilledFmv :: TcTyVar -> TcS () +-- If a flatten-meta-var is still un-filled, +-- turn it into an ordinary meta-var +demoteUnfilledFmv fmv + = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv + ; unless is_filled $ + do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) + ; TcM.writeMetaTyVar fmv tv_ty } } + +instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) +instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) + where + inst_one subst tv + = do { ty' <- instFlexiTcSHelper (tyVarName tv) + (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv ty', ty') } + +instFlexiTcSHelper :: Name -> Kind -> TcM TcType +instFlexiTcSHelper tvname kind + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails (TauTv False) + ; let name = setNameUnique tvname uniq + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType +instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k) + + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data XEvTerm + = XEvTerm { ev_preds :: [PredType] -- New predicate types + , ev_comp :: [EvTerm] -> EvTerm -- How to compose evidence + , ev_decomp :: EvTerm -> [EvTerm] -- How to decompose evidence + -- In both ev_comp and ev_decomp, the [EvTerm] is 1-1 with ev_preds + -- and each EvTerm has type of the corresponding EvPred + } + +data Freshness = Fresh | Cached + +isFresh :: Freshness -> Bool +isFresh Fresh = True +isFresh Cached = False + +freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence] +freshGoals mns = [ ctev | (ctev, Fresh) <- mns ] + +setEvBind :: EvVar -> EvTerm -> TcS () +setEvBind the_ev tm + = do { tc_evbinds <- getTcEvBinds + ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } + +newTcEvBinds :: TcS EvBindsVar +newTcEvBinds = wrapTcS TcM.newTcEvBinds + +newEvVar :: TcPredType -> TcS EvVar +newEvVar pred = wrapTcS (TcM.newEvVar pred) + +newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence +-- Make a new variable of the given PredType, +-- immediately bind it to the given term +-- and return its CtEvidence +-- Precondition: this is not a kind equality +-- See Note [Do not create Given kind equalities] +newGivenEvVar loc (pred, rhs) + = ASSERT2( not (isKindEquality pred), ppr pred $$ pprCtOrigin (ctLocOrigin loc) ) + do { new_ev <- newEvVar pred + ; setEvBind new_ev rhs + ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) } + +newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] +-- Like newGivenEvVar, but automatically discard kind equalities +-- See Note [Do not create Given kind equalities] +newGivenEvVars loc pts = mapM (newGivenEvVar loc) (filterOut (isKindEquality . fst) pts) + +isKindEquality :: TcPredType -> Bool +-- See Note [Do not create Given kind equalities] +isKindEquality pred = case classifyPredType pred of + EqPred _ t1 _ -> isKind t1 + _ -> False + +{- Note [Do not create Given kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not want to create a Given kind equality like + + [G] kv ~ k -- kv is a skolem kind variable + -- Reason we don't yet support non-Refl kind equalities + +This showed up in Trac #8566, where we had a data type + data I (u :: U *) (r :: [*]) :: * where + A :: I (AA t as) r -- Existential k +so A has type + A :: forall (u:U *) (r:[*]) Universal + (k:BOX) (t:k) (as:[U *]). Existential + (u ~ AA * k t as) => I u r + +There is no direct kind equality, but in a pattern match where 'u' is +instantiated to, say, (AA * kk (t1:kk) as1), we'd decompose to get + k ~ kk, t ~ t1, as ~ as1 +This is bad. We "fix" this by simply ignoring the Given kind equality +But the Right Thing is to add kind equalities! + +But note (Trac #8705) that we *do* create Given (non-canonical) equalities +with un-equal kinds, e.g. + [G] t1::k1 ~ t2::k2 -- k1 and k2 are un-equal kinds +Reason: k1 or k2 might be unification variables that have already been +unified (at this point we have not canonicalised the types), so we want +to emit this t1~t2 as a (non-canonical) Given in the work-list. If k1/k2 +have been unified, we'll find that when we canonicalise it, and the +t1~t2 information may be crucial (Trac #8705 is an example). + +If it turns out that k1 and k2 are really un-equal, then it'll end up +as an Irreducible (see Note [Equalities with incompatible kinds] in +TcCanonical), and will do no harm. +-} + +newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC loc pty + = do { new_ev <- newEvVar pty + ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })} + +newWantedEvVar :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness) +-- For anything except ClassPred, this is the same as newWantedEvVarNC +newWantedEvVar loc pty + = do { mb_ct <- lookupInInerts loc pty + ; case mb_ct of + Just ctev | not (isDerived ctev) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return (ctev, Cached) } + _ -> do { ctev <- newWantedEvVarNC loc pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev + ; return (ctev, Fresh) } } + +emitNewDerived :: CtLoc -> TcPredType -> TcS () +-- Create new Derived and put it in the work list +emitNewDerived loc pred + = do { mb_ev <- newDerived loc pred + ; case mb_ev of + Nothing -> return () + Just ev -> do { traceTcS "Emitting [D]" (ppr ev) + ; updWorkListTcS (extendWorkListCt (mkNonCanonical ev)) } } + +newDerived :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) +-- Returns Nothing if cached, +-- Just pred if not cached +newDerived loc pred + = do { mb_ct <- lookupInInerts loc pred + ; return (case mb_ct of + Just {} -> Nothing + Nothing -> Just (CtDerived { ctev_pred = pred, ctev_loc = loc })) } + +instDFunConstraints :: CtLoc -> TcThetaType -> TcS [(CtEvidence, Freshness)] +instDFunConstraints loc = mapM (newWantedEvVar loc) + + +matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType)) +matchFam tycon args = wrapTcS $ matchFamTcM tycon args + +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (TcCoercion, TcType)) +-- Given (F tys) return (ty, co), where co :: F tys ~ ty +matchFamTcM tycon args + = do { fam_envs <- FamInst.tcGetFamInstEnvs + ; return $ fmap (first TcCoercion) $ + reduceTyFamApp_maybe fam_envs Nominal tycon args } + +{- +Note [Residual implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wl_implics in the WorkList are the residual implication +constraints that are generated while solving or canonicalising the +current worklist. Specifically, when canonicalising + (forall a. t1 ~ forall a. t2) +from which we get the implication + (forall a. t1 ~ t2) +See TcSMonad.deferTcSForAllEq +-} + +-- Deferring forall equalities as implications +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +deferTcSForAllEq :: Role -- Nominal or Representational + -> CtLoc -- Original wanted equality flavor + -> ([TyVar],TcType) -- ForAll tvs1 body1 + -> ([TyVar],TcType) -- ForAll tvs2 body2 + -> TcS EvTerm +-- Some of this functionality is repeated from TcUnify, +-- consider having a single place where we create fresh implications. +deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2) + = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1 + ; let tys = mkTyVarTys skol_tvs + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 + skol_info = UnifyForAllSkol skol_tvs phi1 + eq_pred = case role of + Nominal -> mkTcEqPred phi1 phi2 + Representational -> mkCoerciblePred phi1 phi2 + Phantom -> panic "deferTcSForAllEq Phantom" + ; (ctev, freshness) <- newWantedEvVar loc eq_pred + ; coe_inside <- case freshness of + Cached -> return (ctEvCoercion ctev) + Fresh -> do { ev_binds_var <- newTcEvBinds + ; env <- wrapTcS $ TcM.getLclEnv + ; let ev_binds = TcEvBinds ev_binds_var + new_ct = mkNonCanonical ctev + new_co = ctEvCoercion ctev + new_tclvl = pushTcLevel (tcl_tclvl env) + ; let wc = WC { wc_simple = singleCt new_ct + , wc_impl = emptyBag + , wc_insol = emptyCts } + imp = Implic { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_given = [] + , ic_wanted = wc + , ic_insol = False + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } + ; updWorkListTcS (extendWorkListImplic imp) + ; return (TcLetCo ev_binds new_co) } + + ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) } + diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs new file mode 100644 index 00000000..01da61f9 --- /dev/null +++ b/compiler/typecheck/TcSimplify.hs @@ -0,0 +1,1464 @@ +{-# LANGUAGE CPP #-} + +module TcSimplify( + simplifyInfer, + quantifyPred, growThetaTyVars, + simplifyAmbiguityCheck, + simplifyDefault, + simplifyRule, simplifyTop, simplifyInteractive, + solveWantedsTcM + ) where + +#include "HsVersions.h" + +import TcRnTypes +import TcRnMonad +import TcErrors +import TcMType as TcM +import TcType +import TcSMonad as TcS +import TcInteract +import Kind ( isKind, isSubKind, defaultKind_maybe ) +import Inst +import Type ( classifyPredType, isIPClass, PredTree(..) + , getClassPredTys_maybe, EqRel(..) ) +import TyCon ( isTypeFamilyTyCon ) +import Class ( Class ) +import Id ( idType ) +import Var +import Unique +import VarSet +import TcEvidence +import Name +import Bag +import ListSetOps +import Util +import PrelInfo +import PrelNames +import Control.Monad ( unless ) +import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes ) ) +import Class ( classKey ) +import BasicTypes ( RuleName ) +import Outputable +import FastString +import TrieMap () -- DV: for now +import Data.List( partition ) + +{- +********************************************************************************* +* * +* External interface * +* * +********************************************************************************* +-} + +simplifyTop :: WantedConstraints -> TcM (Bag EvBind) +-- Simplify top-level constraints +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ev_binds_var <- TcM.newTcEvBinds + ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top + ; binds1 <- TcRnMonad.getTcEvBinds ev_binds_var + ; traceTc "End simplifyTop }" empty + + ; traceTc "reportUnsolved {" empty + ; binds2 <- reportUnsolved zonked_final_wc + ; traceTc "reportUnsolved }" empty + + ; return (binds1 `unionBags` binds2) } + +simpl_top :: WantedConstraints -> TcS WantedConstraints + -- See Note [Top-level Defaulting Plan] +simpl_top wanteds + = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) + -- This is where the main work happens + ; try_tyvar_defaulting wc_first_go } + where + try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints + try_tyvar_defaulting wc + | isEmptyWC wc + = return wc + | otherwise + = do { free_tvs <- TcS.zonkTyVarsAndFV (tyVarsOfWC wc) + ; let meta_tvs = varSetElems (filterVarSet isMetaTyVar free_tvs) + -- zonkTyVarsAndFV: the wc_first_go is not yet zonked + -- filter isMetaTyVar: we might have runtime-skolems in GHCi, + -- and we definitely don't want to try to assign to those! + + ; meta_tvs' <- mapM defaultTyVar meta_tvs -- Has unification side effects + ; if meta_tvs' == meta_tvs -- No defaulting took place; + -- (defaulting returns fresh vars) + then try_class_defaulting wc + else do { wc_residual <- nestTcS (solveWantedsAndDrop wc) + -- See Note [Must simplify after defaulting] + ; try_class_defaulting wc_residual } } + + try_class_defaulting :: WantedConstraints -> TcS WantedConstraints + try_class_defaulting wc + | isEmptyWC wc + = return wc + | otherwise -- See Note [When to do type-class defaulting] + = do { something_happened <- applyDefaultingRules (approximateWC wc) + -- See Note [Top-level Defaulting Plan] + ; if something_happened + then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) + ; try_class_defaulting wc_residual } + else return wc } + +{- +Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: Trac #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (Trac #5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! Trac #7967 was due to this. + +Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + simple constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraint has + finished. This is the current story. + +Option (i) had many disadvantages: + a) First it was deep inside the actual solver, + b) Second it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this see Note [Default while Inferring]) + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (i), implemented at SimplifyTop. Namely: + - First have a go at solving the residual constraint of the whole program + - Try to approximate it with a simple constraint + - Figure out derived defaulting equations for that simple constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted constraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wanteds + = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) + ; ev_binds_var <- TcM.newTcEvBinds + ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top + ; traceTc "End simplifyAmbiguityCheck }" empty + + -- Normally report all errors; but with -XAllowAmbiguousTypes + -- report only insoluble ones, since they represent genuinely + -- inaccessible code + ; allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes + ; traceTc "reportUnsolved(ambig) {" empty + ; unless (allow_ambiguous && not (insolubleWC zonked_final_wc)) + (discardResult (reportUnsolved zonked_final_wc)) + ; traceTc "reportUnsolved(ambig) }" empty + + ; return () } + +------------------ +simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) +simplifyInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds + +------------------ +simplifyDefault :: ThetaType -- Wanted; has no type variables in it + -> TcM () -- Succeeds iff the constraint is soluble +simplifyDefault theta + = do { traceTc "simplifyInteractive" empty + ; wanted <- newSimpleWanteds DefaultOrigin theta + ; (unsolved, _binds) <- solveWantedsTcM (mkSimpleWC wanted) + + ; traceTc "reportUnsolved {" empty + -- See Note [Deferring coercion errors to runtime] + ; reportAllUnsolved unsolved + -- Postcondition of solveWantedsTcM is that returned + -- constraints are zonked. So Precondition of reportUnsolved + -- is true. + ; traceTc "reportUnsolved }" empty + + ; return () } + +{- +********************************************************************************* +* * +* Inference +* * +*********************************************************************************** + +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + captureConstraints (captureTcLevel (tcMonoBinds...)) + in TcBinds.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_tclvl. + +This ensures that the implication constraint we generate, if any, +has a strictly-increased level compared to the ambient level outside +the let binding. +-} + +simplifyInfer :: TcLevel -- Used when generating the constraints + -> Bool -- Apply monomorphism restriction + -> [(Name, TcTauType)] -- Variables to be generalised, + -- and their tau-types + -> WantedConstraints + -> TcM ([TcTyVar], -- Quantify over these type variables + [EvVar], -- ... and these constraints + Bool, -- The monomorphism restriction did something + -- so the results type is not as general as + -- it could be + TcEvBinds) -- ... binding these evidence variables +simplifyInfer rhs_tclvl apply_mr name_taus wanteds + | isEmptyWC wanteds + = do { gbl_tvs <- tcGetGlobalTyVars + ; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus)) + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], False, emptyTcEvBinds) } + + | otherwise + = do { traceTc "simplifyInfer {" $ vcat + [ ptext (sLit "binds =") <+> ppr name_taus + , ptext (sLit "rhs_tclvl =") <+> ppr rhs_tclvl + , ptext (sLit "apply_mr =") <+> ppr apply_mr + , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds + ] + + -- Historical note: Before step 2 we used to have a + -- HORRIBLE HACK described in Note [Avoid unecessary + -- constraint simplification] but, as described in Trac + -- #4361, we have taken in out now. That's why we start + -- with step 2! + + -- Step 2) First try full-blown solving + + -- NB: we must gather up all the bindings from doing + -- this solving; hence (runTcSWithEvBinds ev_binds_var). + -- And note that since there are nested implications, + -- calling solveWanteds will side-effect their evidence + -- bindings, so we can't just revert to the input + -- constraint. + + ; ev_binds_var <- TcM.newTcEvBinds + ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var (solveWanteds wanteds) + ; wanted_transformed_incl_derivs <- zonkWC wanted_transformed_incl_derivs + + -- Step 4) Candidates for quantification are an approximation of wanted_transformed + -- NB: Already the fixpoint of any unifications that may have happened + -- NB: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + + ; tc_lcl_env <- TcRnMonad.getLclEnv + ; null_ev_binds_var <- TcM.newTcEvBinds + ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs + ; quant_pred_candidates -- Fully zonked + <- if insolubleWC wanted_transformed_incl_derivs + then return [] -- See Note [Quantification with errors] + -- NB: must include derived errors in this test, + -- hence "incl_derivs" + + else do { let quant_cand = approximateWC wanted_transformed + meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand)) + ; gbl_tvs <- tcGetGlobalTyVars + -- Miminise quant_cand. We are not interested in any evidence + -- produced, because we are going to simplify wanted_transformed + -- again later. All we want here is the predicates over which to + -- quantify. + -- + -- If any meta-tyvar unifications take place (unlikely), we'll + -- pick that up later. + + + ; WC { wc_simple = simples } + <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds null_ev_binds_var $ + do { mapM_ (promoteAndDefaultTyVar rhs_tclvl gbl_tvs) meta_tvs + -- See Note [Promote _and_ default when inferring] + ; solveSimpleWanteds quant_cand } + + ; return [ ctEvPred ev | ct <- bagToList simples + , let ev = ctEvidence ct + , isWanted ev ] } + + -- NB: quant_pred_candidates is already the fixpoint of any + -- unifications that may have happened + + ; zonked_taus <- mapM (TcM.zonkTcType . snd) name_taus + ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus + ; (promote_tvs, qtvs, bound, mr_bites) <- decideQuantification apply_mr quant_pred_candidates zonked_tau_tvs + + ; outer_tclvl <- TcRnMonad.getTcLevel + ; runTcSWithEvBinds null_ev_binds_var $ -- runTcS just to get the types right :-( + mapM_ (promoteTyVar outer_tclvl) (varSetElems promote_tvs) + + ; let minimal_simple_preds = mkMinimalBySCs bound + -- See Note [Minimize by Superclasses] + skol_info = InferSkol [ (name, mkSigmaTy [] minimal_simple_preds ty) + | (name, ty) <- name_taus ] + -- Don't add the quantified variables here, because + -- they are also bound in ic_skols and we want them to be + -- tidied uniformly + + ; minimal_bound_ev_vars <- mapM TcM.newEvVar minimal_simple_preds + ; let implic = Implic { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_no_eqs = False + , ic_given = minimal_bound_ev_vars + , ic_wanted = wanted_transformed + , ic_insol = False + , ic_binds = ev_binds_var + , ic_info = skol_info + , ic_env = tc_lcl_env } + ; emitImplication implic + + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ + vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates + , ptext (sLit "zonked_taus") <+> ppr zonked_taus + , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs + , ptext (sLit "promote_tvs=") <+> ppr promote_tvs + , ptext (sLit "bound =") <+> ppr bound + , ptext (sLit "minimal_bound =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v) + | v <- minimal_bound_ev_vars] + , ptext (sLit "mr_bites =") <+> ppr mr_bites + , ptext (sLit "qtvs =") <+> ppr qtvs + , ptext (sLit "implic =") <+> ppr implic ] + + ; return ( qtvs, minimal_bound_ev_vars + , mr_bites, TcEvBinds ev_binds_var) } + +{- +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + * Take the global tyvars, and "grow" them using the equality constraints + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta + These are the mono_tvs + + * Take the free vars of the tau-type (zonked_tau_tvs) and "grow" them + using all the constraints, but knocking out the mono_tvs + + The result is poly_qtvs, which we will quantify over. + + * Filter the constraints using quantifyPred and the poly_qtvs + +If the MR does apply, mono_tvs includes all the constrained tyvars, +and the quantified constraints are empty. +-} + +decideQuantification :: Bool -> [PredType] -> TcTyVarSet + -> TcM ( TcTyVarSet -- Promote these + , [TcTyVar] -- Do quantify over these + , [PredType] -- and these + , Bool ) -- Did the MR bite? +-- See Note [Deciding quantification] +decideQuantification apply_mr constraints zonked_tau_tvs + | apply_mr -- Apply the Monomorphism restriction + = do { gbl_tvs <- tcGetGlobalTyVars + ; let mono_tvs = gbl_tvs `unionVarSet` constrained_tvs + mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs + promote_tvs = constrained_tvs `unionVarSet` (zonked_tau_tvs `intersectVarSet` gbl_tvs) + ; qtvs <- quantifyTyVars mono_tvs zonked_tau_tvs + ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs, ppr qtvs]) + ; return (promote_tvs, qtvs, [], mr_bites) } + + | otherwise + = do { gbl_tvs <- tcGetGlobalTyVars + ; let mono_tvs = growThetaTyVars (filter isEqPred constraints) gbl_tvs + poly_qtvs = growThetaTyVars constraints zonked_tau_tvs + `minusVarSet` mono_tvs + theta = filter (quantifyPred poly_qtvs) constraints + promote_tvs = mono_tvs `intersectVarSet` (constrained_tvs `unionVarSet` zonked_tau_tvs) + ; qtvs <- quantifyTyVars mono_tvs poly_qtvs + ; traceTc "decideQuantification 2" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs, ppr poly_qtvs, ppr qtvs, ppr theta]) + ; return (promote_tvs, qtvs, theta, False) } + where + constrained_tvs = tyVarsOfTypes constraints + +------------------ +quantifyPred :: TyVarSet -- Quantifying over these + -> PredType -> Bool -- True <=> quantify over this wanted +quantifyPred qtvs pred + = case classifyPredType pred of + ClassPred cls tys + | isIPClass cls -> True -- See note [Inheriting implicit parameters] + | otherwise -> tyVarsOfTypes tys `intersectsVarSet` qtvs + EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2 + -- representational equality is like a class constraint + EqPred ReprEq ty1 ty2 -> tyVarsOfTypes [ty1, ty2] `intersectsVarSet` qtvs + IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs + TuplePred {} -> False + where + -- Only quantify over (F tys ~ ty) if tys mentions a quantifed variable + -- In particular, quanitifying over (F Int ~ ty) is a bit like quantifying + -- over (Eq Int); the instance should kick in right here + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + +------------------ +growThetaTyVars :: ThetaType -> TyVarSet -> TyVarSet +-- See Note [Growing the tau-tvs using constraints] +growThetaTyVars theta tvs + | null theta = tvs + | isEmptyVarSet seed_tvs = tvs + | otherwise = fixVarSet mk_next seed_tvs + where + seed_tvs = tvs `unionVarSet` tyVarsOfTypes ips + (ips, non_ips) = partition isIPPred theta + -- See note [Inheriting implicit parameters] + mk_next tvs = foldr grow_one tvs non_ips + grow_one pred tvs + | pred_tvs `intersectsVarSet` tvs = tvs `unionVarSet` pred_tvs + | otherwise = tvs + where + pred_tvs = tyVarsOfType pred + +{- +Note [Growing the tau-tvs using constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(growThetaTyVars insts tvs) is the result of extending the set + of tyvars tvs using all conceivable links from pred + +E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} +Then growThetaTyVars preds tvs = {a,b,c} + +Notice that + growThetaTyVars is conservative if v might be fixed by vs + => v `elem` grow(vs,C) + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See the predicate quantifyPred. + +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints, we abandon all attempts to find a context to quantify +over, and instead make the function fully-polymorphic in whatever +type we have found. For two reasons + a) Minimise downstream errors + b) Avoid spurious errors from this function + +But NB that we must include *derived* errors in the check. Example: + (a::*) ~ Int# +We get an insoluble derived error *~#, and we don't want to discard +it before doing the isInsolubleWC test! (Trac #8262) + +Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints and +we have not observed code breaking because of the lack of defaulting in inference so +we don't do it for now. + + + +Note [Minimize by Superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over a constraint, in simplifyInfer we need to +quantify over a constraint that is minimal in some sense: For +instance, if the final wanted constraint is (Eq alpha, Ord alpha), +we'd like to quantify over Ord alpha, because we can just get Eq alpha +from superclass selection from Ord alpha. This minimization is what +mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint +to check the original wanted. + + +Note [Avoid unecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with Trac #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessarily simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + + instance C t => C [t] where .. + + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the constraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + + +********************************************************************************* +* * +* RULES * +* * +*********************************************************************************** + +See note [Simplifying RULE constraints] in TcRule + +Note [RULE quantification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding which equalities to quantify over is tricky: + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * But we do want to quantify over things like (a ~ F b), where + F is a type function. + +The difficulty is that it's hard to tell what is insoluble! +So we see whether the simplificaiotn step yielded any type errors, +and if so refrain from quantifying over *any* equalites. +-} + +simplifyRule :: RuleName + -> WantedConstraints -- Constraints from LHS + -> WantedConstraints -- Constraints from RHS + -> TcM ([EvVar], WantedConstraints) -- LHS evidence variables +-- See Note [Simplifying RULE constraints] in TcRule +simplifyRule name lhs_wanted rhs_wanted + = do { -- We allow ourselves to unify environment + -- variables: runTcS runs with topTcLevel + (resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted) + -- Post: these are zonked and unflattened + + ; zonked_lhs_simples <- TcM.zonkSimples (wc_simple lhs_wanted) + ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_simples + quantify_me -- Note [RULE quantification over equalities] + | insolubleWC resid_wanted = quantify_insol + | otherwise = quantify_normal + + quantify_insol ct = not (isEqPred (ctPred ct)) + + quantify_normal ct + | EqPred NomEq t1 t2 <- classifyPredType (ctPred ct) + = not (t1 `tcEqType` t2) + | otherwise + = True + + ; traceTc "simplifyRule" $ + vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples + , text "q_cts" <+> ppr q_cts + , text "non_q_cts" <+> ppr non_q_cts ] + + ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) + , lhs_wanted { wc_simple = non_q_cts }) } + +{- +********************************************************************************* +* * +* Main Simplifier * +* * +*********************************************************************************** + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +Note [Zonk after solving] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We zonk the result immediately after constraint solving, for two reasons: + +a) because zonkWC generates evidence, and this is the moment when we + have a suitable evidence variable to hand. + +Note that *after* solving the constraints are typically small, so the +overhead is not great. +-} + +solveWantedsTcMWithEvBinds :: EvBindsVar + -> WantedConstraints + -> (WantedConstraints -> TcS WantedConstraints) + -> TcM WantedConstraints +-- Returns a *zonked* result +-- We zonk when we finish primarily to un-flatten out any +-- flatten-skolems etc introduced by canonicalisation of +-- types involving type funuctions. Happily the result +-- is typically much smaller than the input, indeed it is +-- often empty. +solveWantedsTcMWithEvBinds ev_binds_var wc tcs_action + = do { traceTc "solveWantedsTcMWithEvBinds" $ text "wanted=" <+> ppr wc + ; wc2 <- runTcSWithEvBinds ev_binds_var (tcs_action wc) + ; zonkWC wc2 } + -- See Note [Zonk after solving] + +solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) +-- Zonk the input constraints, and simplify them +-- Return the evidence binds in the BagEvBinds result +-- Discards all Derived stuff in result +-- Postcondition: fully zonked and unflattened constraints +solveWantedsTcM wanted + = do { ev_binds_var <- TcM.newTcEvBinds + ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solveWantedsAndDrop + ; binds <- TcRnMonad.getTcEvBinds ev_binds_var + ; return (wanteds', binds) } + +solveWantedsAndDrop :: WantedConstraints -> TcS (WantedConstraints) +-- Since solveWanteds returns the residual WantedConstraints, +-- it should always be called within a runTcS or something similar, +solveWantedsAndDrop wanted = do { wc <- solveWanteds wanted + ; return (dropDerivedWC wc) } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +-- so that the inert set doesn't mindlessly propagate. +-- NB: wc_simples may be wanted /or/ derived now +solveWanteds wanteds + = do { traceTcS "solveWanteds {" (ppr wanteds) + + -- Try the simple bit, including insolubles. Solving insolubles a + -- second time round is a bit of a waste; but the code is simple + -- and the program is wrong anyway, and we don't run the danger + -- of adding Derived insolubles twice; see + -- TcSMonad Note [Do not add duplicate derived insolubles] + ; traceTcS "solveSimples {" empty + ; solved_simples_wanteds <- solveSimples wanteds + ; traceTcS "solveSimples end }" (ppr solved_simples_wanteds) + + -- solveWanteds iterates when it is able to float equalities + -- equalities out of one or more of the implications. + ; final_wanteds <- simpl_loop 1 solved_simples_wanteds + + ; bb <- getTcEvBindsMap + ; traceTcS "solveWanteds }" $ + vcat [ text "final wc =" <+> ppr final_wanteds + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wanteds } + +solveSimples :: WantedConstraints -> TcS WantedConstraints +-- Solve the wc_simple and wc_insol components of the WantedConstraints +-- Do not affect the inerts +solveSimples (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) + = nestTcS $ + do { let all_simples = simples `unionBags` filterBag (not . isDerivedCt) insols + -- See Note [Dropping derived constraints] in TcRnTypes for + -- why the insolubles may have derived constraints + ; wc <- solveSimpleWanteds all_simples + ; return ( wc { wc_impl = implics `unionBags` wc_impl wc } ) } + +simpl_loop :: Int + -> WantedConstraints + -> TcS WantedConstraints +simpl_loop n wanteds@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) + | n > 10 + = do { traceTcS "solveWanteds: loop!" empty + ; return wanteds } + + | otherwise + = do { traceTcS "simpl_loop, iteration" (int n) + ; (floated_eqs, unsolved_implics) <- solveNestedImplications implics + + ; if isEmptyBag floated_eqs + then return (wanteds { wc_impl = unsolved_implics }) + else + + do { -- Put floated_eqs into the current inert set before looping + (unifs_happened, solve_simple_res) + <- reportUnifications $ + solveSimples (WC { wc_simple = floated_eqs `unionBags` simples + -- Put floated_eqs first so they get solved first + , wc_insol = emptyBag, wc_impl = emptyBag }) + + ; let new_wanteds = solve_simple_res `andWC` + WC { wc_simple = emptyBag + , wc_insol = insols + , wc_impl = unsolved_implics } + + ; if not unifs_happened -- See Note [Cutting off simpl_loop] + && isEmptyBag (wc_impl solve_simple_res) + then return new_wanteds + else simpl_loop (n+1) new_wanteds } } + +solveNestedImplications :: Bag Implication + -> TcS (Cts, Bag Implication) +-- Precondition: the TcS inerts may contain unsolved simples which have +-- to be converted to givens before we go inside a nested implication. +solveNestedImplications implics + | isEmptyBag implics + = return (emptyBag, emptyBag) + | otherwise + = do { +-- inerts <- getTcSInerts +-- ; let thinner_inerts = prepareInertsForImplications inerts +-- -- See Note [Preparing inert set for implications] +-- + traceTcS "solveNestedImplications starting {" empty +-- vcat [ text "original inerts = " <+> ppr inerts +-- , text "thinner_inerts = " <+> ppr thinner_inerts ] + + ; (floated_eqs, unsolved_implics) + <- flatMapBagPairM solveImplication implics + + -- ... and we are back in the original TcS inerts + -- Notice that the original includes the _insoluble_simples so it was safe to ignore + -- them in the beginning of this function. + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "all floated_eqs =" <+> ppr floated_eqs + , text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return (floated_eqs, unsolved_implics) } + +solveImplication :: Implication -- Wanted + -> TcS (Cts, -- All wanted or derived floated equalities: var = type + Bag Implication) -- Unsolved rest (always empty or singleton) +-- Precondition: The TcS monad contains an empty worklist and given-only inerts +-- which after trying to solve this implication we must restore to their original value +solveImplication imp@(Implic { ic_tclvl = tclvl + , ic_binds = ev_binds + , ic_skols = skols + , ic_given = givens + , ic_wanted = wanteds + , ic_info = info + , ic_env = env }) + = do { inerts <- getTcSInerts + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) + + -- Solve the nested constraints + ; (no_given_eqs, residual_wanted) + <- nestImplicTcS ev_binds tclvl $ + do { solveSimpleGivens (mkGivenLoc tclvl info env) givens + + ; residual_wanted <- solveWanteds wanteds + -- solveWanteds, *not* solveWantedsAndDrop, because + -- we want to retain derived equalities so we can float + -- them out in floatEqualities + + ; no_eqs <- getNoGivenEqs tclvl skols + + ; return (no_eqs, residual_wanted) } + + ; (floated_eqs, final_wanted) + <- floatEqualities skols no_given_eqs residual_wanted + + ; let res_implic | isEmptyWC final_wanted -- && no_given_eqs + = emptyBag -- Reason for the no_given_eqs: we don't want to + -- lose the "inaccessible code" error message + -- BUT: final_wanted still has the derived insolubles + -- so it should be fine + | otherwise + = unitBag (imp { ic_no_eqs = no_given_eqs + , ic_wanted = dropDerivedWC final_wanted + , ic_insol = insolubleWC final_wanted }) + + ; evbinds <- getTcEvBindsMap + ; traceTcS "solveImplication end }" $ vcat + [ text "no_given_eqs =" <+> ppr no_given_eqs + , text "floated_eqs =" <+> ppr floated_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ] + + ; return (floated_eqs, res_implic) } + +{- +Note [Cutting off simpl_loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very important not to iterate in simpl_loop unless there is a chance +of progress. Trac #8474 is a classic example: + + * There's a deeply-nested chain of implication constraints. + ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int + + * From the innermost one we get a [D] alpha ~ Int, + but alpha is untouchable until we get out to the outermost one + + * We float [D] alpha~Int out (it is in floated_eqs), but since alpha + is untouchable, the solveInteract in simpl_loop makes no progress + + * So there is no point in attempting to re-solve + ?yn:betan => [W] ?x:Int + because we'll just get the same [D] again + + * If we *do* re-solve, we'll get an ininite loop. It is cut off by + the fixed bound of 10, but solving the next takes 10*10*...*10 (ie + exponentially many) iterations! + +Conclusion: we should iterate simpl_loop iff we will get more 'givens' +in the inert set when solving the nested implications. That is the +result of prepareInertsForImplications is larger. How can we tell +this? + +Consider floated_eqs (all wanted or derived): + +(a) [W/D] CTyEqCan (a ~ ty). This can give rise to a new given only by causing + a unification. So we count those unifications. + +(b) [W] CFunEqCan (F tys ~ xi). Even though these are wanted, they + are pushed in as givens by prepareInertsForImplications. See Note + [Preparing inert set for implications] in TcSMonad. But because + of that very fact, we won't generate another copy if we iterate + simpl_loop. So we iterate if there any of these +-} + +promoteTyVar :: TcLevel -> TcTyVar -> TcS () +-- When we float a constraint out of an implication we must restore +-- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType +-- See Note [Promoting unification variables] +promoteTyVar tclvl tv + | isFloatedTouchableMetaTyVar tclvl tv + = do { cloned_tv <- TcS.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; setWantedTyBind tv (mkTyVarTy rhs_tv) } + | otherwise + = return () + +promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TyVar -> TcS () +-- See Note [Promote _and_ default when inferring] +promoteAndDefaultTyVar tclvl gbl_tvs tv + = do { tv1 <- if tv `elemVarSet` gbl_tvs + then return tv + else defaultTyVar tv + ; promoteTyVar tclvl tv1 } + +defaultTyVar :: TcTyVar -> TcS TcTyVar +-- Precondition: MetaTyVars only +-- See Note [DefaultTyVar] +defaultTyVar the_tv + | Just default_k <- defaultKind_maybe (tyVarKind the_tv) + = do { tv' <- TcS.cloneMetaTyVar the_tv + ; let new_tv = setTyVarKind tv' default_k + ; traceTcS "defaultTyVar" (ppr the_tv <+> ppr new_tv) + ; setWantedTyBind the_tv (mkTyVarTy new_tv) + ; return new_tv } + -- Why not directly derived_pred = mkTcEqPred k default_k? + -- See Note [DefaultTyVar] + -- We keep the same TcLevel on tv' + + | otherwise = return the_tv -- The common case + +approximateWC :: WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts +-- See Note [ApproximateWC] +approximateWC wc + = float_wc emptyVarSet wc + where + float_wc :: TcTyVarSet -> WantedConstraints -> Cts + float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) + = filterBag is_floatable simples `unionBags` + do_bag (float_implic new_trapping_tvs) implics + where + new_trapping_tvs = fixVarSet grow trapping_tvs + is_floatable ct = tyVarsOfCt ct `disjointVarSet` new_trapping_tvs + + grow tvs = foldrBag grow_one tvs simples + grow_one ct tvs | ct_tvs `intersectsVarSet` tvs = tvs `unionVarSet` ct_tvs + | otherwise = tvs + where + ct_tvs = tyVarsOfCt ct + + float_implic :: TcTyVarSet -> Implication -> Cts + float_implic trapping_tvs imp + | ic_no_eqs imp -- No equalities, so float + = float_wc new_trapping_tvs (ic_wanted imp) + | otherwise -- Don't float out of equalities + = emptyCts -- See Note [ApproximateWC] + where + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + do_bag :: (a -> Bag c) -> Bag a -> Bag c + do_bag f = foldrBag (unionBags.f) emptyBag + +{- +Note [ApproximateWC] +~~~~~~~~~~~~~~~~~~~~ +approximateWC takes a constraint, typically arising from the RHS of a +let-binding whose type we are *inferring*, and extracts from it some +*simple* constraints that we might plausibly abstract over. Of course +the top-level simple constraints are plausible, but we also float constraints +out from inside, if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that that might be defaulted. + +There are two caveats: + +1. We do *not* float anything out if the implication binds equality + constraints, because that defeats the OutsideIn story. Consider + data T a where + TInt :: T Int + MkT :: T a + + f TInt = 3::Int + + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + +2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default the kind of OpenKind and ArgKind etc to *. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind ArgKind, +and that won't match the typeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An important point is that if the type variable tv has kind k and the +default is default_k we do not simply generate [D] (k ~ default_k) because: + + (1) k may be ArgKind and default_k may be * so we will fail + + (2) We need to rewrite all occurrences of the tv to be a type + variable with the right kind and we choose to do this by rewriting + the type variable /itself/ by a new variable which does have the + right kind. + +Note [Promote _and_ default when inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are inferring a type, we simplify the constraint, and then use +approximateWC to produce a list of candidate constraints. Then we MUST + + a) Promote any meta-tyvars that have been floated out by + approximateWC, to restore invariant (MetaTvInv) described in + Note [TcLevel and untouchable type variables] in TcType. + + b) Default the kind of any meta-tyyvars that are not mentioned in + in the environment. + +To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we +have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it +should! If we don't solve the constraint, we'll stupidly quantify over +(C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over +(b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. +Trac #7641 is a simpler example. + +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(MetaTvInv) from Note [TcLevel and untouchable type variables] in TcType. for the +leftover implication. + +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + + class C x y | x -> y where + op :: x -> y -> () + + instance C [a] [a] + + type family F a :: * + + h :: F Int -> () + h = undefined + + data TEx where + TEx :: a -> TEx + + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + + +Note [Solving Family Equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After we are done with simplification we may be left with constraints of the form: + [Wanted] F xis ~ beta +If 'beta' is a touchable unification variable not already bound in the TyBinds +then we'd like to create a binding for it, effectively "defaulting" it to be 'F xis'. + +When is it ok to do so? + 1) 'beta' must not already be defaulted to something. Example: + + [Wanted] F Int ~ beta <~ Will default [beta := F Int] + [Wanted] F Char ~ beta <~ Already defaulted, can't default again. We + have to report this as unsolved. + + 2) However, we must still do an occurs check when defaulting (F xis ~ beta), to + set [beta := F xis] only if beta is not among the free variables of xis. + + 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS + of type family equations. See Inert Set invariants in TcInteract. + +This solving is now happening during zonking, see Note [Unflattening while zonking] +in TcMType. + + +********************************************************************************* +* * +* Floating equalities * +* * +********************************************************************************* + +Note [Float Equalities out of Implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For ordinary pattern matches (including existentials) we float +equalities out of implications, for instance: + data T where + MkT :: Eq a => a -> T + f x y = case x of MkT _ -> (y::Int) +We get the implication constraint (x::T) (y::alpha): + forall a. [untouchable=alpha] Eq a => alpha ~ Int +We want to float out the equality into a scope where alpha is no +longer untouchable, to solve the implication! + +But we cannot float equalities out of implications whose givens may +yield or contain equalities: + + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a + + h :: T a -> a -> Int + + f x y = case x of + T1 -> y::Int + T2 -> y::Bool + T3 -> h x y + +We generate constraint, for (x::T alpha) and (y :: beta): + [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch + [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch + (alpha ~ beta) -- From 3rd branch + +If we float the equality (beta ~ Int) outside of the first implication and +the equality (beta ~ Bool) out of the second we get an insoluble constraint. +But if we just leave them inside the implications we unify alpha := beta and +solve everything. + +Principle: + We do not want to float equalities out which may + need the given *evidence* to become soluble. + +Consequence: classes with functional dependencies don't matter (since there is +no evidence for a fundep equality), but equality superclasses do matter (since +they carry evidence). +-} + +floatEqualities :: [TcTyVar] -> Bool + -> WantedConstraints + -> TcS (Cts, WantedConstraints) +-- Main idea: see Note [Float Equalities out of Implications] +-- +-- Precondition: the wc_simple of the incoming WantedConstraints are +-- fully zonked, so that we can see their free variables +-- +-- Postcondition: The returned floated constraints (Cts) are only +-- Wanted or Derived and come from the input wanted +-- ev vars or deriveds +-- +-- Also performs some unifications (via promoteTyVar), adding to +-- monadically-carried ty_binds. These will be used when processing +-- floated_eqs later +-- +-- Subtleties: Note [Float equalities from under a skolem binding] +-- Note [Skolem escape] +floatEqualities skols no_given_eqs wanteds@(WC { wc_simple = simples }) + | not no_given_eqs -- There are some given equalities, so don't float + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + | otherwise + = do { outer_tclvl <- TcS.getTcLevel + ; mapM_ (promoteTyVar outer_tclvl) (varSetElems (tyVarsOfCts float_eqs)) + -- See Note [Promoting unification variables] + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols + , text "Simples =" <+> ppr simples + , text "Floated eqs =" <+> ppr float_eqs ]) + ; return (float_eqs, wanteds { wc_simple = remaining_simples }) } + where + skol_set = mkVarSet skols + (float_eqs, remaining_simples) = partitionBag float_me simples + + float_me :: Ct -> Bool + float_me ct -- The constraint is un-flattened and de-cannonicalised + | let pred = ctPred ct + , EqPred NomEq ty1 ty2 <- classifyPredType pred + , tyVarsOfType pred `disjointVarSet` skol_set + , useful_to_float ty1 ty2 + = True + | otherwise + = False + + -- Float out alpha ~ ty, or ty ~ alpha + -- which might be unified outside + -- See Note [Do not float kind-incompatible equalities] + useful_to_float ty1 ty2 + = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of + (Just tv1, _) | isMetaTyVar tv1 + , k2 `isSubKind` k1 + -> True + (_, Just tv2) | isMetaTyVar tv2 + , k1 `isSubKind` k2 + -> True + _ -> False + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +{- +Note [Do not float kind-incompatible equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (t::* ~ s::*->*), we'll get a Derived insoluble equality. +If we float the equality outwards, we'll get *another* Derived +insoluble equality one level out, so the same error will be reported +twice. So we refrain from floating such equalities + +Note [Float equalities from under a skolem binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Which of the simple equalities can we float out? Obviously, only +ones that don't mention the skolem-bound variables. But that is +over-eager. Consider + [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int +The second constraint doesn't mention 'a'. But if we float it +we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that +beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll +we left with the constraint + [2] forall a. a ~ gamma'[1] +which is insoluble because gamma became untouchable. + +Solution: float only constraints that stand a jolly good chance of +being soluble simply by being floated, namely ones of form + a ~ ty +where 'a' is a currently-untouchable unification variable, but may +become touchable by being floated (perhaps by more than one level). + +We had a very complicated rule previously, but this is nice and +simple. (To see the notes, look at this Note in a version of +TcSimplify prior to Oct 2014). + +Note [Skolem escape] +~~~~~~~~~~~~~~~~~~~~ +You might worry about skolem escape with all this floating. +For example, consider + [2] forall a. (a ~ F beta[2] delta, + Maybe beta[2] ~ gamma[1]) + +The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and +solve with gamma := beta. But what if later delta:=Int, and + F b Int = b. +Then we'd get a ~ beta[2], and solve to get beta:=a, and now the +skolem has escaped! + +But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] +to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. + + +********************************************************************************* +* * +* Defaulting and disamgiguation * +* * +********************************************************************************* +-} + +applyDefaultingRules :: Cts -> TcS Bool + -- True <=> I did some defaulting, reflected in ty_binds + +-- Return some extra derived equalities, which express the +-- type-class default choice. +applyDefaultingRules wanteds + | isEmptyBag wanteds + = return False + | otherwise + = do { traceTcS "applyDefaultingRules { " $ + text "wanteds =" <+> ppr wanteds + + ; info@(default_tys, _) <- getDefaultInfo + ; let groups = findDefaultableGroups info wanteds + ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups + , text "info=" <+> ppr info ] + ; something_happeneds <- mapM (disambigGroup default_tys) groups + + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) + + ; return (or something_happeneds) } + +findDefaultableGroups + :: ( [Type] + , (Bool,Bool) ) -- (Overloaded strings, extended default rules) + -> Cts -- Unsolved (wanted or derived) + -> [[(Ct,Class,TcTyVar)]] +findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds + | null default_tys = [] + | otherwise = defaultable_groups + where + defaultable_groups = filter is_defaultable_group groups + groups = equivClasses cmp_tv unaries + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints + + (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds) + -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable * (a:*)) (Trac #8931) + find_unary cc + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , Just (kinds, ty) <- snocView tys + , all isKind kinds + , Just tv <- tcGetTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + bad_tvs :: TcTyVarSet -- TyVars mentioned by non-unaries + bad_tvs = mapUnionVarSet tyVarsOfCt non_unaries + + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + is_defaultable_group ds@((_,_,tv):_) + = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] + b2 = not (tv `elemVarSet` bad_tvs) + b4 = defaultable_classes [cls | (_,cls,_) <- ds] + in (b1 && b2 && b4) + is_defaultable_group [] = panic "defaultable_group" + + defaultable_classes clss + | extended_defaults = any isInteractiveClass clss + | otherwise = all is_std_class clss && (any is_num_class clss) + + -- In interactive mode, or with -XExtendedDefaultRules, + -- we default Show a to Show () to avoid graututious errors on "show []" + isInteractiveClass cls + = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) + + is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + -- is_num_class adds IsString to the standard numeric classes, + -- when -foverloaded-strings is enabled + + is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + -- Similarly is_std_class + +------------------------------ +disambigGroup :: [Type] -- The default types + -> [(Ct, Class, TcTyVar)] -- All classes of the form (C a) + -- sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds + +disambigGroup [] _grp + = return False +disambigGroup (default_ty:default_tys) group + = do { traceTcS "disambigGroup {" (ppr group $$ ppr default_ty) + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; given_ev_var <- TcS.newEvVar (mkTcEqPred (mkTyVarTy the_tv) default_ty) + ; tclvl <- TcS.getTcLevel + ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ + do { solveSimpleGivens loc [given_ev_var] + ; residual_wanted <- solveSimpleWanteds wanteds + ; return (isEmptyWC residual_wanted) } + + ; if success then + -- Success: record the type variable binding, and return + do { setWantedTyBind the_tv default_ty + ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; traceTcS "disambigGroup succeeded }" (ppr default_ty) + ; return True } + else + -- Failure: try with the next type + do { traceTcS "disambigGroup failed, will try other default types }" + (ppr default_ty) + ; disambigGroup default_tys group } } + where + wanteds = listToBag (map fstOf3 group) + ((_,_,the_tv):_) = group + loc = CtLoc { ctl_origin = GivenOrigin UnkSkol + , ctl_env = panic "disambigGroup:env" + , ctl_depth = initialSubGoalDepth } + +{- +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig +-} diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs new file mode 100644 index 00000000..d14d1144 --- /dev/null +++ b/compiler/typecheck/TcSplice.hs @@ -0,0 +1,1754 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +TcSplice: Template Haskell splices +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TcSplice( + -- These functions are defined in stage1 and stage2 + -- The raise civilised errors in stage1 + tcSpliceExpr, tcTypedBracket, tcUntypedBracket, + runQuasiQuoteExpr, runQuasiQuotePat, + runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation, + +#ifdef GHCI + -- These ones are defined only in stage2, and are + -- called only in stage2 (ie GHCI is on) + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, traceSplice, SpliceInfo(..), + defaultRunMeta, runMeta' +#endif + ) where + +#include "HsVersions.h" + +import HsSyn +import Annotations +import Name +import TcRnMonad +import RdrName +import TcType + +#ifdef GHCI +import HscMain + -- These imports are the reason that TcSplice + -- is very high up the module hierarchy + +import HscTypes +import Convert +import RnExpr +import RnEnv +import RnTypes +import TcExpr +import TcHsSyn +import TcSimplify +import TcUnify +import Type +import Kind +import NameSet +import TcEnv +import TcMType +import TcHsType +import TcIface +import TypeRep +import FamInst +import FamInstEnv +import InstEnv +import NameEnv +import PrelNames +import OccName +import Hooks +import Var +import Module +import LoadIface +import Class +import Inst +import TyCon +import CoAxiom +import PatSyn ( patSynName ) +import ConLike +import DataCon +import TcEvidence( TcEvBinds(..) ) +import Id +import IdInfo +import DsExpr +import DsMonad +import Serialized +import ErrUtils +import SrcLoc +import Util +import Data.List ( mapAccumL ) +import Unique +import VarSet ( isEmptyVarSet ) +import Data.Maybe +import BasicTypes hiding( SuccessFlag(..) ) +import Maybes( MaybeErr(..) ) +import DynFlags +import Panic +import Lexeme +import FastString +import Outputable +import Control.Monad ( when ) + +import DsMeta +import qualified Language.Haskell.TH as TH +-- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH + +-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler +import GHC.Desugar ( AnnotationWrapper(..) ) + +import qualified Data.Map as Map +import Data.Dynamic ( fromDynamic, toDyn ) +import Data.Typeable ( typeOf, Typeable ) +import Data.Data (Data) +import GHC.Exts ( unsafeCoerce# ) +#endif + +{- +************************************************************************ +* * +\subsection{Main interface + stubs for the non-GHCI case +* * +************************************************************************ +-} + +tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) +tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) +tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) + -- None of these functions add constraints to the LIE + +runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) +runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) +runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] + +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation + +#ifndef GHCI +tcTypedBracket x _ = failTH x "Template Haskell bracket" +tcUntypedBracket x _ _ = failTH x "Template Haskell bracket" +tcSpliceExpr e _ = failTH e "Template Haskell splice" + +runQuasiQuoteExpr q = failTH q "quasiquote" +runQuasiQuotePat q = failTH q "pattern quasiquote" +runQuasiQuoteType q = failTH q "type quasiquote" +runQuasiQuoteDecl q = failTH q "declaration quasiquote" +runAnnotation _ q = failTH q "annotation" + +#else + -- The whole of the rest of the file is the else-branch (ie stage2 only) + +{- +Note [How top-level splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level splices (those not inside a [| .. |] quotation bracket) are handled +very straightforwardly: + + 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) + + 2. runMetaT: desugar, compile, run it, and convert result back to + HsSyn RdrName (of the appropriate flavour, eg HsType RdrName, + HsExpr RdrName etc) + + 3. treat the result as if that's what you saw in the first place + e.g for HsType, rename and kind-check + for HsExpr, rename and type-check + + (The last step is different for decls, because they can *only* be + top-level: we return the result of step 2.) + +Note [How brackets and nested splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nested splices (those inside a [| .. |] quotation bracket), +are treated quite differently. + +Remember, there are two forms of bracket + typed [|| e ||] + and untyped [| e |] + +The life cycle of a typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s RnPendingTyped) + * Rename the body + * Result is still a HsBracket + + * When typechecking: + * Set the ThStage to (Brack s (TcPending ps_var lie_var)) + * Typecheck the body, and throw away the elaborated result + * Nested splices (which must be typed) are typechecked, and + the results accumulated in ps_var; their constraints + accumulate in lie_var + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + +The life cycle of a un-typed bracket: + * Starts as HsBracket + + * When renaming: + * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) + * Rename the body + * Nested splices (which must be untyped) are renamed, and the + results accumulated in ps_var + * Result is still (HsRnBracketOut rn_body pending_splices) + + * When typechecking a HsRnBracketOut + * Typecheck the pending_splices individually + * Ignore the body of the bracket; just check that the context + expects a bracket of that type (e.g. a [p| pat |] bracket should + be in a context needing a (Q Pat) + * Result is a HsTcBracketOut rn_brack pending_splices + where rn_brack is the incoming renamed bracket + + +In both cases, desugaring happens like this: + * HsTcBracketOut is desugared by DsMeta.dsBracket. It + + a) Extends the ds_meta environment with the PendingSplices + attached to the bracket + + b) Converts the quoted (HsExpr Name) to a CoreExpr that, when + run, will produce a suitable TH expression/type/decl. This + is why we leave the *renamed* expression attached to the bracket: + the quoted expression should not be decorated with all the goop + added by the type checker + + * Each splice carries a unique Name, called a "splice point", thus + ${n}(e). The name is initialised to an (Unqual "splice") when the + splice is created; the renamer gives it a unique. + + * When DsMeta (used to desugar the body of the bracket) comes across + a splice, it looks up the splice's Name, n, in the ds_meta envt, + to find an (HsExpr Id) that should be substituted for the splice; + it just desugars it to get a CoreExpr (DsMeta.repSplice). + +Example: + Source: f = [| Just $(g 3) |] + The [| |] part is a HsBracket + + Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsBracketOut, containing *renamed* + (not typechecked) expression + The "s7" is the "splice point"; the (g Int 3) part + is a typechecked expression + + Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + + +Note [Template Haskell state diagram] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the ThStages, s, their corresponding level numbers +(the result of (thLevel s)), and their state transitions. +The top level of the program is stage Comp: + + Start here + | + V + ----------- $ ------------ $ + | Comp | ---------> | Splice | -----| + | 1 | | 0 | <----| + ----------- ------------ + ^ | ^ | + $ | | [||] $ | | [||] + | v | v + -------------- ---------------- + | Brack Comp | | Brack Splice | + | 2 | | 1 | + -------------- ---------------- + +* Normal top-level declarations start in state Comp + (which has level 1). + Annotations start in state Splice, since they are + treated very like a splice (only without a '$') + +* Code compiled in state Splice (and only such code) + will be *run at compile time*, with the result replacing + the splice + +* The original paper used level -1 instead of 0, etc. + +* The original paper did not allow a splice within a + splice, but there is no reason not to. This is the + $ transition in the top right. + +Note [Template Haskell levels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Imported things are impLevel (= 0) + +* However things at level 0 are not *necessarily* imported. + eg $( \b -> ... ) here b is bound at level 0 + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at outerLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +When a variable is used, we compare + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + + To track top-level-ness we use the ThBindEnv in TcLclEnv + + For example: + f = ... + g1 = $(map ...) is OK + g2 = $(f ...) is not OK; because we havn't compiled f yet + + +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- See Note [How brackets and nested splices are handled] +-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) +tcTypedBracket brack@(TExpBr expr) res_ty + = addErrCtxt (quotationCtxtDoc brack) $ + do { cur_stage <- getStage + ; ps_ref <- newMutVar [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Typecheck expr to make sure it is valid, + -- Throw away the typechecked expression but return its type. + -- We'll typecheck it again when we splice it in somewhere + ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ + tcInferRhoNC expr + -- NC for no context; tcBracket does that + + ; meta_ty <- tcTExpTy expr_ty + ; co <- unifyType meta_ty res_ty + ; ps' <- readMutVar ps_ref + ; texpco <- tcLookupId unsafeTExpCoerceName + ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) + (noLoc (HsTcBracketOut brack ps'))))) } +tcTypedBracket other_brack _ + = pprPanic "tcTypedBracket" (ppr other_brack) + +-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) +tcUntypedBracket brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + ; ps' <- mapM tcPendingSplice ps + ; meta_ty <- tcBrackTy brack + ; co <- unifyType meta_ty res_ty + ; traceTc "tc_bracket done untyped" (ppr meta_ty) + ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) } + +--------------- +tcBrackTy :: HsBracket Name -> TcM TcType +tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) +tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) +tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) +tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec] +tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) +tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL" +tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" + +--------------- +tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice +tcPendingSplice (PendingRnExpSplice (PendSplice n expr)) + = do { res_ty <- tcMetaTy expQTyConName + ; tc_pending_splice n expr res_ty } +tcPendingSplice (PendingRnPatSplice (PendSplice n expr)) + = do { res_ty <- tcMetaTy patQTyConName + ; tc_pending_splice n expr res_ty } +tcPendingSplice (PendingRnTypeSplice (PendSplice n expr)) + = do { res_ty <- tcMetaTy typeQTyConName + ; tc_pending_splice n expr res_ty } +tcPendingSplice (PendingRnDeclSplice (PendSplice n expr)) + = do { res_ty <- tcMetaTy decsQTyConName + ; tc_pending_splice n expr res_ty } + +tcPendingSplice (PendingRnCrossStageSplice n) + -- Behave like $(lift x); not very pretty + = do { res_ty <- tcMetaTy expQTyConName + ; tc_pending_splice n (nlHsApp (nlHsVar liftName) (nlHsVar n)) res_ty } + +--------------- +tc_pending_splice :: Name -> LHsExpr Name -> TcRhoType -> TcM PendingTcSplice +tc_pending_splice splice_name expr res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (PendSplice splice_name expr') } + +--------------- +-- Takes a type tau and returns the type Q (TExp tau) +tcTExpTy :: TcType -> TcM TcType +tcTExpTy tau = do + q <- tcLookupTyCon qTyConName + texp <- tcLookupTyCon tExpTyConName + return (mkTyConApp q [mkTyConApp texp [tau]]) + +{- +************************************************************************ +* * +\subsection{Splicing an expression} +* * +************************************************************************ +-} + +tcSpliceExpr splice@(HsSplice name expr) res_ty + = addErrCtxt (spliceCtxtDoc splice) $ + setSrcSpan (getLoc expr) $ do + { stage <- getStage + ; case stage of + Splice {} -> tcTopSplice expr res_ty + Comp -> tcTopSplice expr res_ty + Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty } + +tcNestedSplice :: ThStage -> PendingStuff -> Name + -> LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) + -- See Note [How brackets and nested splices are handled] + -- A splice inside brackets +tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty + = do { meta_exp_ty <- tcTExpTy res_ty + ; expr' <- setStage pop_stage $ + setConstraintVar lie_var $ + tcMonoExpr expr meta_exp_ty + ; untypeq <- tcLookupId unTypeQName + ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendSplice splice_name expr'' : ps) + + -- The returned expression is ignored; it's in the pending splices + ; return (panic "tcSpliceExpr") } + +tcNestedSplice _ _ splice_name _ _ + = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) + +tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) +tcTopSplice expr res_ty + = do { -- Typecheck the expression, + -- making sure it has type Q (T res_ty) + meta_exp_ty <- tcTExpTy res_ty + ; zonked_q_expr <- tcTopSpliceExpr True $ + tcMonoExpr expr meta_exp_ty + + -- Run the expression + ; expr2 <- runMetaE zonked_q_expr + ; showSplice False "expression" expr (ppr expr2) + + -- Rename and typecheck the spliced-in expression, + -- making sure it has type res_ty + -- These steps should never fail; this is a *typed* splice + ; addErrCtxt (spliceResultDoc expr) $ do + { (exp3, _fvs) <- rnLExpr expr2 + ; exp4 <- tcMonoExpr exp3 res_ty + ; return (unLoc exp4) } } + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +quotationCtxtDoc :: HsBracket Name -> SDoc +quotationCtxtDoc br_body + = hang (ptext (sLit "In the Template Haskell quotation")) + 2 (ppr br_body) + +spliceCtxtDoc :: HsSplice Name -> SDoc +spliceCtxtDoc splice + = hang (ptext (sLit "In the Template Haskell splice")) + 2 (pprTypedSplice splice) + +spliceResultDoc :: LHsExpr Name -> SDoc +spliceResultDoc expr + = sep [ ptext (sLit "In the result of the splice:") + , nest 2 (char '$' <> pprParendExpr expr) + , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] + +------------------- +tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) +-- Note [How top-level splices are handled] +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +-- Note that set the level to Splice, regardless of the original level, +-- before typechecking the expression. For example: +-- f x = $( ...$(g 3) ... ) +-- The recursive call to tcMonoExpr will simply expand the +-- inner escape before dealing with the outer one + +tcTopSpliceExpr isTypedSplice tc_action + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + unsetGOptM Opt_DeferTypeErrors $ + -- Don't defer type errors. Not only are we + -- going to run this code, but we do an unsafe + -- coerce, so we get a seg-fault if, say we + -- splice a type into a place where an expression + -- is expected (Trac #7276) + setStage (Splice isTypedSplice) $ + do { -- Typecheck the expression + (expr', lie) <- captureConstraints tc_action + + -- Solve the constraints + ; const_binds <- simplifyTop lie + + -- Zonk it and tie the knot of dictionary bindings + ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +runAnnotation target expr = do + -- Find the classes we want instances for in order to call toAnnotationWrapper + loc <- getSrcSpanM + data_class <- tcLookupClass dataClassName + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + zonked_wrapped_expr' <- tcTopSpliceExpr False $ + do { (expr', expr_ty) <- tcInferRhoNC expr + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcTopSpliceExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let specialised_to_annotation_wrapper_expr + = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id)) + ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + serialized <- runMetaAW zonked_wrapped_expr' + return Annotation { + ann_target = target, + ann_value = serialized + } + +convertAnnotationWrapper :: AnnotationWrapper -> Either MsgDoc Serialized +convertAnnotationWrapper annotation_wrapper = Right $ + case annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` serialized + + +{- +************************************************************************ +* * + Quasi-quoting +* * +************************************************************************ + +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GHC "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). + +Briefly, one writes + [p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose +type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be +defined in another module, because we are going to run it here. It's +a bit like a TH splice: + $(p "stuff") + +However, you can do this in patterns as well as terms. Because of this, +the splice is run by the *renamer* rather than the type checker. + +************************************************************************ +* * +\subsubsection{Quasiquotation} +* * +************************************************************************ + +See Note [Quasi-quote overview] in TcSplice. +-} + +runQuasiQuote :: Outputable hs_syn + => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String + -> Name -- Of type QuasiQuoter -> String -> Q th_syn + -> Name -- Name of th_syn type + -> String -- Description of splice type + -> (MetaHook RnM -> LHsExpr Id -> RnM hs_syn) + -> RnM hs_syn +runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty descr meta_req + = do { -- Drop the leading "$" from the quoter name, if present + -- This is old-style syntax, now deprecated + -- NB: when removing this backward-compat, remove + -- the matching code in Lexer.x (around line 310) + let occ_str = occNameString (rdrNameOcc quoter) + ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this + if head occ_str /= '$' then return quoter + else do { addWarn (deprecatedDollar quoter) + ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) } + + ; quoter' <- lookupOccRn quoter + -- We use lookupOcc rather than lookupGlobalOcc because in the + -- erroneous case of \x -> [x| ...|] we get a better error message + -- (stage restriction rather than out of scope). + + ; when (isUnboundName quoter') failM + -- If 'quoter' is not in scope, proceed no further + -- The error message was generated by lookupOccRn, but it then + -- succeeds with an "unbound name", which makes the subsequent + -- attempt to run the quote fail in a confusing way + + -- Check that the quoter is not locally defined, otherwise the TH + -- machinery will not be able to run the quasiquote. + ; this_mod <- getModule + ; let is_local = nameIsLocalOrFrom this_mod quoter' + ; checkTc (not is_local) (quoteStageError quoter') + + ; traceTc "runQQ" (ppr quoter <+> ppr is_local) + ; HsQuasiQuote quoter'' _ quote' <- getHooked runQuasiQuoteHook return >>= + ($ HsQuasiQuote quoter' q_span quote) + + -- Build the expression + ; let quoterExpr = L q_span $! HsVar $! quoter'' + ; let quoteExpr = L q_span $! HsLit $! HsString "" quote' + ; let expr = L q_span $ + HsApp (L q_span $ + HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr + ; meta_exp_ty <- tcMetaTy meta_ty + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr meta_exp_ty) + + -- Run the expression + ; result <- runMeta meta_req zonked_q_expr + ; showSplice (descr == "declarations") descr quoteExpr (ppr result) + + ; return result } + +runQuasiQuoteExpr qq + = runQuasiQuote qq quoteExpName expQTyConName "expression" metaRequestE +runQuasiQuotePat qq + = runQuasiQuote qq quotePatName patQTyConName "pattern" metaRequestP +runQuasiQuoteType qq + = runQuasiQuote qq quoteTypeName typeQTyConName "type" metaRequestT +runQuasiQuoteDecl qq + = runQuasiQuote qq quoteDecName decsQTyConName "declarations" metaRequestD + +quoteStageError :: Name -> SDoc +quoteStageError quoter + = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter, + nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))] + +deprecatedDollar :: RdrName -> SDoc +deprecatedDollar quoter + = hang (ptext (sLit "Deprecated syntax:")) + 2 (ptext (sLit "quasiquotes no longer need a dollar sign:") + <+> ppr quoter) + +{- +************************************************************************ +* * +\subsection{Running an expression} +* * +************************************************************************ +-} + +runQuasi :: TH.Q a -> TcM a +runQuasi act = TH.runQ act + +runQResult :: (a -> String) -> (SrcSpan -> a -> b) -> SrcSpan -> TH.Q a -> TcM b +runQResult show_th f expr_span hval + = do { th_result <- TH.runQ hval + ; traceTc "Got TH result:" (text (show_th th_result)) + ; return (f expr_span th_result) } + +----------------- +runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn) + -> LHsExpr Id + -> TcM hs_syn +runMeta unwrap e + = do { h <- getHooked runMetaHook defaultRunMeta + ; unwrap h e } + +defaultRunMeta :: MetaHook TcM +defaultRunMeta (MetaE r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr) +defaultRunMeta (MetaP r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat) +defaultRunMeta (MetaT r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType) +defaultRunMeta (MetaD r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls) +defaultRunMeta (MetaAW r) + = fmap r . runMeta' False (const empty) (const (return . convertAnnotationWrapper)) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the users code + +---------------- +runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper + -> TcM Serialized +runMetaAW = runMeta metaRequestAW + +runMetaE :: LHsExpr Id -- Of type (Q Exp) + -> TcM (LHsExpr RdrName) +runMetaE = runMeta metaRequestE + +runMetaP :: LHsExpr Id -- Of type (Q Pat) + -> TcM (LPat RdrName) +runMetaP = runMeta metaRequestP + +runMetaT :: LHsExpr Id -- Of type (Q Type) + -> TcM (LHsType RdrName) +runMetaT = runMeta metaRequestT + +runMetaD :: LHsExpr Id -- Of type Q [Dec] + -> TcM [LHsDecl RdrName] +runMetaD = runMeta metaRequestD + +--------------- +runMeta' :: Bool -- Whether code should be printed in the exception message + -> (hs_syn -> SDoc) -- how to print the code + -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that + -> TcM hs_syn -- Of type t +runMeta' show_code ppr_hs run_and_convert expr + = do { traceTc "About to run" (ppr expr) + ; recordThSpliceUse -- seems to be the best place to do this, + -- we catch all kinds of splices and annotations. + + -- Check that we've had no errors of any sort so far. + -- For example, if we found an error in an earlier defn f, but + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry ont. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see Trac #5358 for an example that fell over when trying to + -- reify a function with a "?" kind in it. (These don't occur + -- in type-correct programs. + ; failIfErrsM + + -- Desugar + ; ds_expr <- initDsTc (dsLExpr expr) + -- Compile and link it; might fail if linking fails + ; hsc_env <- getTopEnv + ; src_span <- getSrcSpanM + ; traceTc "About to run (desugared)" (ppr ds_expr) + ; either_hval <- tryM $ liftIO $ + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr + ; case either_hval of { + Left exn -> fail_with_exn "compile and link" exn ; + Right hval -> do + + { -- Coerce it to Q t, and run it + + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-cacthing thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the try + -- + -- See Note [Exceptions in TH] + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) + ; case mb_result of + Left err -> failWithTc err + Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) + ; return $! result } } + + ; case either_tval of + Right v -> return v + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> fail_with_exn "run" se -- Exception + }}} + where + -- see Note [Concealed TH exceptions] + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then text "Code:" <+> ppr expr else empty] + failWithTc msg + +{- +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Supppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see TcSplice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will triger panic (Trac #8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + + +To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} + +instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where + qNewName s = do { u <- newUnique + ; let i = getKey u + ; return (TH.mkNameU s i) } + + -- 'msg' is forced to ensure exceptions don't escape, + -- see Note [Exceptions in TH] + qReport True msg = seqList msg $ addErr (text msg) + qReport False msg = seqList msg $ addWarn (text msg) + + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageKeyString (modulePackageKey m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + + qLookupName = lookupName + qReify = reify + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. c.f. tryTcLIE_ + qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } + + qRunIO io = liftIO io + + qAddDependentFile fp = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + qAddTopDecls thds = do + l <- getSrcSpanM + let either_hval = convertToHsDecls l thds + ds <- case either_hval of + Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn + Right ds -> return ds + mapM_ (checkTopDecl . unLoc) ds + th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + updTcRef th_topdecls_var (\topds -> ds ++ topds) + where + checkTopDecl :: HsDecl RdrName -> TcM () + checkTopDecl (ValD binds) + = mapM_ bindName (collectHsBindBinders binds) + checkTopDecl (SigD _) + = return () + checkTopDecl (ForD (ForeignImport (L _ name) _ _ _)) + = bindName name + checkTopDecl _ + = addErr $ text "Only function, value, and foreign import declarations may be added with addTopDecl" + + bindName :: RdrName -> TcM () + bindName (Exact n) + = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } + + bindName name = + addErr $ + hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + + qAddModFinalizer fin = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var (\fins -> fin:fins) + + qGetQ :: forall a. Typeable a => IOEnv (Env TcGblEnv TcLclEnv) (Maybe a) + qGetQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + -- ToDo: convert @undefined :: a@ to @proxy :: Proxy a@ when + -- we drop support for GHC 7.6. + return (Map.lookup (typeOf (undefined :: a)) th_state >>= fromDynamic) + + qPutQ x = do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + +{- +************************************************************************ +* * +\subsection{Errors and contexts} +* * +************************************************************************ +-} + +-- Note that 'before' is *renamed* but not *typechecked* +-- Reason (a) less typechecking crap +-- (b) data constructors after type checking have been +-- changed to their *wrappers*, and that makes them +-- print always fully qualified +showSplice :: Bool -> String -> LHsExpr Name -> SDoc -> TcM () +showSplice isDec what before after = + traceSplice $ SpliceInfo isDec what Nothing (Just $ ppr before) after + +-- | The splice data to be logged +-- +-- duplicates code in RnSplice.lhs +data SpliceInfo + = SpliceInfo + { spliceIsDeclaration :: Bool + , spliceDescription :: String + , spliceLocation :: Maybe SrcSpan + , spliceSource :: Maybe SDoc + , spliceGenerated :: SDoc + } + +-- | outputs splice information for 2 flags which have different output formats: +-- `-ddump-splices` and `-dth-dec-file` +-- +-- This duplicates code in RnSplice.lhs +traceSplice :: SpliceInfo -> TcM () +traceSplice sd = do + loc <- case sd of + SpliceInfo { spliceLocation = Nothing } -> getSrcSpanM + SpliceInfo { spliceLocation = Just loc } -> return loc + traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc sd) + when (spliceIsDeclaration sd) $ do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file + (spliceCodeDoc loc sd) + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SpliceInfo -> SDoc + spliceDebugDoc loc sd + = let code = case spliceSource sd of + Nothing -> ending + Just b -> nest 2 b : ending + ending = [ text "======>", nest 2 (spliceGenerated sd) ] + in (vcat [ ppr loc <> colon + <+> text "Splicing" <+> text (spliceDescription sd) + , nest 2 (sep code) + ]) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SpliceInfo -> SDoc + spliceCodeDoc loc sd + = (vcat [ text "--" <+> ppr loc <> colon + <+> text "Splicing" <+> text (spliceDescription sd) + , sep [spliceGenerated sd] + ]) + +{- +************************************************************************ +* * + Instance Testing +* * +************************************************************************ +-} + +reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] +reifyInstances th_nm th_tys + = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") + <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ + do { loc <- getSrcSpanM + ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) + -- #9262 says to bring vars into scope, like in HsForAllTy case + -- of rnHsTyKi + ; let (kvs, tvs) = extractHsTyRdrTyVars rdr_ty + tv_bndrs = userHsTyVarBndrs loc tvs + hs_tvbs = mkHsQTvs tv_bndrs + -- Rename to HsType Name + ; ((rn_tvbs, rn_ty), _fvs) + <- bindHsTyVars doc Nothing kvs hs_tvbs $ \ rn_tvbs -> + do { (rn_ty, fvs) <- rnLHsType doc rdr_ty + ; return ((rn_tvbs, rn_ty), fvs) } + ; (ty, _kind) <- tcHsTyVarBndrs rn_tvbs $ \ _tvs -> + tcLHsType rn_ty + ; ty <- zonkTcTypeToType emptyZonkEnv ty + -- Substitute out the meta type variables + -- In particular, the type might have kind + -- variables inside it (Trac #7477) + + ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty)) + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See Trac #7910 + | Just cls <- tyConClass_maybe tc + -> do { inst_envs <- tcGetInstEnvs + ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys + ; traceTc "reifyInstances1" (ppr matches) + ; reifyClassInstances cls (map fst matches ++ unifies) } + | isOpenFamilyTyCon tc + -> do { inst_envs <- tcGetFamInstEnvs + ; let matches = lookupFamInstEnv inst_envs tc tys + ; traceTc "reifyInstances2" (ppr matches) + ; reifyFamilyInstances tc (map fim_instance matches) } + _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty)) + 2 (ptext (sLit "is not a class constraint or type family application"))) } + where + doc = ClassInstanceCtx + bale_out msg = failWithTc msg + + cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) + cvt loc th_ty = case convertToHsType loc th_ty of + Left msg -> failWithTc msg + Right ty -> return ty + +{- +************************************************************************ +* * + Reification +* * +************************************************************************ +-} + +lookupName :: Bool -- True <=> type namespace + -- False <=> value namespace + -> String -> TcM (Maybe TH.Name) +lookupName is_type_name s + = do { lcl_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv lcl_env rdr_name of + Just n -> return (Just (reifyName n)) + Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name + ; return (fmap reifyName mb_nm) } } + where + th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' + + occ_fs :: FastString + occ_fs = mkFastString (TH.nameBase th_name) + + occ :: OccName + occ | is_type_name + = if isLexCon occ_fs then mkTcOccFS occ_fs + else mkTyVarOccFS occ_fs + | otherwise + = if isLexCon occ_fs then mkDataOccFS occ_fs + else mkVarOccFS occ_fs + + rdr_name = case TH.nameModule th_name of + Nothing -> mkRdrUnqual occ + Just mod -> mkRdrQual (mkModuleName mod) occ + +getThing :: TH.Name -> TcM TcTyThing +getThing th_name + = do { name <- lookupThName th_name + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) + ; tcLookupTh name } + -- ToDo: this tcLookup could fail, which would give a + -- rather unhelpful error message + where + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" + +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { thing <- getThing th_name + ; reifyThing thing } + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (listToMaybe names) } + where + lookup rdr_name + = do { -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing -> lookupGlobalOccRn_maybe rdr_name } + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of { + Just thing -> return thing; + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + if nameIsLocalOrFrom (tcg_mod gbl_env) name + then -- It's defined in this module + failWithTc (notInEnv name) + + else + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return (AGlobal thing) + Failed msg -> failWithTc msg + }}}} + +notInScope :: TH.Name -> SDoc +notInScope th_name = quotes (text (TH.pprint th_name)) <+> + ptext (sLit "is not in scope at a reify") + -- Ugh! Rather an indirect way to display the name + +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + ptext (sLit "is not in the type environment at a reify") + +------------------------------ +reifyRoles :: TH.Name -> TcM [TH.Role] +reifyRoles th_name + = do { thing <- getThing th_name + ; case thing of + AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) + _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing)) + } + where + reify_role Nominal = TH.NominalR + reify_role Representational = TH.RepresentationalR + reify_role Phantom = TH.PhantomR + +------------------------------ +reifyThing :: TcTyThing -> TcM TH.Info +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = do { ty <- reifyType (idType id) + ; fix <- reifyFixity (idName id) + ; let v = reifyName id + ; case idDetails id of + ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) + _ -> return (TH.VarI v ty Nothing fix) + } + +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AConLike (RealDataCon dc))) + = do { let name = dataConName dc + ; ty <- reifyType (idType (dataConWrapId dc)) + ; fix <- reifyFixity name + ; return (TH.DataConI (reifyName name) ty + (reifyName (dataConOrigTyCon dc)) fix) + } +reifyThing (AGlobal (AConLike (PatSynCon ps))) + = noTH (sLit "pattern synonyms") (ppr $ patSynName ps) + +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + -- though it may be incomplete + ; ty2 <- reifyType ty1 + ; fix <- reifyFixity (idName id) + ; return (TH.VarI (reifyName id) ty2 Nothing fix) } + +reifyThing (ATyVar tv tv1) + = do { ty1 <- zonkTcTyVar tv1 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) + +------------------------------------------- +reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs }) + -- remove kind patterns (#8884) + = do { args' <- mapM reifyType (filter (not . isKind) args) + ; rhs' <- reifyType rhs + ; return (TH.TySynEqn args' rhs') } + +reifyTyCon :: TyCon -> TcM TH.Info +reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + + | isFunTyCon tc + = return (TH.PrimTyConI (reifyName tc) 2 False) + + | isPrimTyCon tc + = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) + + | isFamilyTyCon tc + = do { let tvs = tyConTyVars tc + kind = tyConKind tc + + -- we need the *result kind* (see #8884) + (kvs, mono_kind) = splitForAllTys kind + -- tyConArity includes *kind* params + (_, res_kind) = splitKindFunTysN (tyConArity tc - length kvs) + mono_kind + ; kind' <- fmap Just (reifyKind res_kind) + + ; tvs' <- reifyTyVars tvs + ; flav' <- reifyFamFlavour tc + ; case flav' of + { Left flav -> -- open type/data family + do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.FamilyD flav (reifyName tc) tvs' kind') + instances) } + ; Right eqns -> -- closed type family + return (TH.FamilyI + (TH.ClosedTypeFamilyD (reifyName tc) tvs' kind' eqns) + []) } } + + | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs + ; tvs' <- reifyTyVars tvs + ; return (TH.TyConI + (TH.TySynD (reifyName tc) tvs' rhs')) + } + + | otherwise + = do { cxt <- reifyCxt (tyConStupidTheta tc) + ; let tvs = tyConTyVars tc + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) + ; r_tvs <- reifyTyVars tvs + ; let name = reifyName tc + deriv = [] -- Don't know about deriving + decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv + | otherwise = TH.DataD cxt name r_tvs cons deriv + ; return (TH.TyConI decl) } + +reifyDataCon :: [Type] -> DataCon -> TcM TH.Con +-- For GADTs etc, see Note [Reifying data constructors] +reifyDataCon tys dc + = do { let (tvs, theta, arg_tys, _) = dataConSig dc + subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs + (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs) + theta' = substTheta subst' theta + arg_tys' = substTys subst' arg_tys + stricts = map reifyStrict (dataConSrcBangs dc) + fields = dataConFieldLabels dc + name = reifyName dc + + ; r_arg_tys <- reifyTypes arg_tys' + + ; let main_con | not (null fields) + = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys) + | dataConIsInfix dc + = ASSERT( length arg_tys == 2 ) + TH.InfixC (s1,r_a1) name (s2,r_a2) + | otherwise + = TH.NormalC name (stricts `zip` r_arg_tys) + [r_a1, r_a2] = r_arg_tys + [s1, s2] = stricts + + ; ASSERT( length arg_tys == length stricts ) + if null ex_tvs' && null theta then + return main_con + else do + { cxt <- reifyCxt theta' + ; ex_tvs'' <- reifyTyVars ex_tvs' + ; return (TH.ForallC ex_tvs'' cxt main_con) } } + +------------------------------ +reifyClass :: Class -> TcM TH.Info +reifyClass cls + = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) + ; ops <- concatMapM reify_op op_stuff + ; tvs' <- reifyTyVars tvs + ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops + ; return (TH.ClassI dec insts ) } + where + (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds + reify_op (op, def_meth) + = do { ty <- reifyType (idType op) + ; let nm' = reifyName op + ; case def_meth of + GenDefMeth gdm_nm -> + do { gdm_id <- tcLookupId gdm_nm + ; gdm_ty <- reifyType (idType gdm_id) + ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] } + _ -> return [TH.SigD nm' ty] } + +------------------------------ +-- | Annotate (with TH.SigT) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to annotate type patterns for poly-kinded tyvars in +-- reifying class and type instances. See #8953 and th/T8953. +annotThType :: Bool -- True <=> annotate + -> TypeRep.Type -> TH.Type -> TcM TH.Type + -- tiny optimization: if the type is annotated, don't annotate again. +annotThType _ _ th_ty@(TH.SigT {}) = return th_ty +annotThType True ty th_ty + | not $ isEmptyVarSet $ tyVarsOfType ty + = do { let ki = typeKind ty + ; th_ki <- reifyKind ki + ; return (TH.SigT th_ty th_ki) } +annotThType _ _ th_ty = return th_ty + +-- | For every *type* variable (not *kind* variable) in the input, +-- report whether or not the tv is poly-kinded. This is used to eventually +-- feed into 'annotThType'. +mkIsPolyTvs :: [TyVar] -> [Bool] +mkIsPolyTvs tvs = [ is_poly_tv tv | tv <- tvs + , not (isKindVar tv) ] + where + is_poly_tv tv = not $ isEmptyVarSet $ tyVarsOfType $ tyVarKind tv + +------------------------------ +reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] +reifyClassInstances cls insts + = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts + where + tvs = classTyVars cls + +reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- this list contains flags only for *type* + -- variables, not *kind* variables + -> ClsInst -> TcM TH.Dec +reifyClassInstance is_poly_tvs i + = do { cxt <- reifyCxt (drop n_silent theta) + ; let types_only = filterOut isKind types + ; thtypes <- reifyTypes types_only + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs types_only thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes + ; return $ (TH.InstanceD cxt head_ty []) } + where + (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) + dfun = instanceDFunId i + n_silent = dfunNSilent dfun + +------------------------------ +reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] +reifyFamilyInstances fam_tc fam_insts + = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts + where + fam_tvs = tyConTyVars fam_tc + +reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- this list contains flags only for *type* + -- variables, not *kind* variables + -> FamInst -> TcM TH.Dec +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_fam = fam + , fi_tys = lhs + , fi_rhs = rhs }) + = case flavor of + SynFamilyInst -> + -- remove kind patterns (#8884) + do { let lhs_types_only = filterOut isKind lhs + ; th_lhs <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only + th_lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (reifyName fam) + (TH.TySynEqn annot_th_lhs th_rhs)) } + + DataFamilyInst rep_tc -> + do { let tvs = tyConTyVars rep_tc + fam' = reifyName fam + + -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See Trac #9692 + -- See Note [Eta reduction for data family axioms] + -- in TcInstDcls + (_rep_tc, rep_tc_args) = splitTyConApp rhs + etad_tyvars = dropList rep_tc_args tvs + eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) + ; let types_only = filterOut isKind eta_expanded_lhs + ; th_tys <- reifyTypes types_only + ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; return (if isNewTyCon rep_tc + then TH.NewtypeInstD [] fam' annot_th_tys (head cons) [] + else TH.DataInstD [] fam' annot_th_tys cons []) } + +------------------------------ +reifyType :: TypeRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty@(ForAllTy _ _) = reify_for_all ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } +reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here +reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } +reifyType ty@(FunTy t1 t2) + | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } + +reify_for_all :: TypeRep.Type -> TcM TH.Type +reify_for_all ty + = do { cxt' <- reifyCxt cxt; + ; tau' <- reifyType tau + ; tvs' <- reifyTyVars tvs + ; return (TH.ForallT tvs' cxt' tau') } + where + (tvs, cxt, tau) = tcSplitSigmaTy ty + +reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) + +reifyTypes :: [Type] -> TcM [TH.Type] +reifyTypes = mapM reifyType + +reifyKind :: Kind -> TcM TH.Kind +reifyKind ki + = do { let (kis, ki') = splitKindFunTys ki + ; ki'_rep <- reifyNonArrowKind ki' + ; kis_rep <- mapM reifyKind kis + ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) } + where + reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT + | isConstraintKind k = return TH.ConstraintT + reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v)) + reifyNonArrowKind (ForAllTy _ k) = reifyKind k + reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis + reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1 + ; k2' <- reifyKind k2 + ; return (TH.AppT k1' k2') + } + reifyNonArrowKind k = noTH (sLit "this kind") (ppr k) + +reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind +reify_kc_app kc kis + = fmap (mkThAppTs r_kc) (mapM reifyKind kis) + where + r_kc | Just tc <- isPromotedTyCon_maybe kc + , isTupleTyCon tc = TH.TupleT (tyConArity kc) + | kc `hasKey` listTyConKey = TH.ListT + | otherwise = TH.ConT (reifyName kc) + +reifyCxt :: [PredType] -> TcM [TH.Pred] +reifyCxt = mapM reifyPred + +reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep +reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) + +reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn]) +reifyFamFlavour tc + | isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam + | isDataFamilyTyCon tc = return $ Left TH.DataFam + + -- this doesn't really handle abstract closed families, but let's not worry + -- about that now + | Just ax <- isClosedSynFamilyTyCon_maybe tc + = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax + ; return $ Right eqns } + + | otherwise + = panic "TcSplice.reifyFamFlavour: not a type family" + +reifyTyVars :: [TyVar] + -> TcM [TH.TyVarBndr] +reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs + where + -- even if the kind is *, we need to include a kind annotation, + -- in case a poly-kind would be inferred without the annotation. + -- See #8953 or test th/T8953 + reify_tv tv = TH.KindedTV name <$> reifyKind kind + where + kind = tyVarKind tv + name = reifyName tv + +{- +Note [Kind annotations on TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A poly-kinded tycon sometimes needs a kind annotation to be unambiguous. +For example: + + type family F a :: k + type instance F Int = (Proxy :: * -> *) + type instance F Bool = (Proxy :: (* -> *) -> *) + +It's hard to figure out where these annotations should appear, so we do this: +Suppose the tycon is applied to n arguments. We strip off the first n +arguments of the tycon's kind. If there are any variables left in the result +kind, we put on a kind annotation. But we must be slightly careful: it's +possible that the tycon's kind will have fewer than n arguments, in the case +that the concrete application instantiates a result kind variable with an +arrow kind. So, if we run out of arguments, we conservatively put on a kind +annotation anyway. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algoritm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we conservatively choose to put the annotation +in. + +See #8953 and test th/T8953. +-} + +reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes (removeKinds tc_kind tys) + ; maybe_sig_t (mkThAppTs r_tc tys') } + where + arity = tyConArity tc + tc_kind = tyConKind tc + r_tc | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` eqTyConKey = TH.EqualityT + | otherwise = TH.ConT (reifyName tc) + + -- See Note [Kind annotations on TyConApps] + maybe_sig_t th_type + | needs_kind_sig + = do { let full_kind = typeKind (mkTyConApp tc tys) + ; th_full_kind <- reifyKind full_kind + ; return (TH.SigT th_type th_full_kind) } + | otherwise + = return th_type + + needs_kind_sig + | Just result_ki <- peel_off_n_args tc_kind (length tys) + = not $ isEmptyVarSet $ kiVarsOfKind result_ki + | otherwise + = True + + peel_off_n_args :: Kind -> Arity -> Maybe Kind + peel_off_n_args k 0 = Just k + peel_off_n_args k n + | Just (_, res_k) <- splitForAllTy_maybe k + = peel_off_n_args res_k (n-1) + | Just (_, res_k) <- splitFunTy_maybe k + = peel_off_n_args res_k (n-1) + | otherwise + = Nothing + + removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type] + removeKinds (FunTy k1 k2) (h:t) + | isSuperKind k1 = removeKinds k2 t + | otherwise = h : removeKinds k2 t + removeKinds (ForAllTy v k) (h:t) + | isSuperKind (varType v) = removeKinds k t + | otherwise = h : removeKinds k t + removeKinds _ tys = tys + +reifyPred :: TypeRep.PredType -> TcM TH.Pred +reifyPred ty + -- We could reify the implicit paramter as a class but it seems + -- nicer to support them properly... + | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty) + | otherwise = reifyType ty + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) + -- Many of the things we reify have local bindings, and + -- NameL's aren't supposed to appear in binding positions, so + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. + where + name = getName thing + mod = ASSERT( isExternalName name ) nameModule name + pkg_str = packageKeyString (modulePackageKey mod) + mod_str = moduleNameString (moduleName mod) + occ_str = occNameString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | otherwise = pprPanic "reifyName" (ppr name) + +------------------------------ +reifyFixity :: Name -> TcM TH.Fixity +reifyFixity name + = do { fix <- lookupFixityRn name + ; return (conv_fix fix) } + where + conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d) + conv_dir BasicTypes.InfixR = TH.InfixR + conv_dir BasicTypes.InfixL = TH.InfixL + conv_dir BasicTypes.InfixN = TH.InfixN + +reifyStrict :: DataCon.HsSrcBang -> TH.Strict +reifyStrict HsNoBang = TH.NotStrict +reifyStrict (HsSrcBang _ _ False) = TH.NotStrict +reifyStrict (HsSrcBang _ (Just True) True) = TH.Unpacked +reifyStrict (HsSrcBang _ _ True) = TH.IsStrict +reifyStrict HsStrict = TH.IsStrict +reifyStrict (HsUnpack {}) = TH.Unpacked + +------------------------------ +lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget +lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) +lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) + = return $ ModuleTarget $ + mkModule (stringToPackageKey $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + +reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +------------------------------ +modToTHMod :: Module -> TH.Module +modToTHMod m = TH.Module (TH.PkgName $ packageKeyString $ modulePackageKey m) + (TH.ModName $ moduleNameString $ moduleName m) + +reifyModule :: TH.Module -> TcM TH.ModuleInfo +reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do + this_mod <- getModule + let reifMod = mkModule (stringToPackageKey pkgString) (mkModuleName mString) + if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod + where + reifyThisModule = do + usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports + return $ TH.ModuleInfo usages + + reifyFromIface reifMod = do + iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod + let usages = [modToTHMod m | usage <- mi_usages iface, + Just m <- [usageToModule (modulePackageKey reifMod) usage] ] + return $ TH.ModuleInfo usages + + usageToModule :: PackageKey -> Usage -> Maybe Module + usageToModule _ (UsageFile {}) = Nothing + usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn + usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m + +------------------------------ +mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type +mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys + +noTH :: LitString -> SDoc -> TcM a +noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> + ptext (sLit "in Template Haskell:"), + nest 2 d]) + +ppr_th :: TH.Ppr a => a -> SDoc +ppr_th x = text (TH.pprint x) + +{- +Note [Reifying data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Template Haskell syntax is rich enough to express even GADTs, +provided we do so in the equality-predicate form. So a GADT +like + + data T a where + MkT1 :: a -> T [a] + MkT2 :: T Int + +will appear in TH syntax like this + + data T a = forall b. (a ~ [b]) => MkT1 b + | (a ~ Int) => MkT2 +-} + +#endif /* GHCI */ diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot new file mode 100644 index 00000000..f039bde1 --- /dev/null +++ b/compiler/typecheck/TcSplice.hs-boot @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} + +module TcSplice where +import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, + HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) +import HsExpr ( PendingRnSplice ) +import Name ( Name ) +import RdrName ( RdrName ) +import TcRnTypes( TcM, TcId ) +import TcType ( TcRhoType ) +import Annotations ( Annotation, CoreAnnTarget ) + +#ifdef GHCI +import Id ( Id ) +import qualified Language.Haskell.TH as TH +import Outputable (SDoc) +import SrcLoc (SrcSpan) +#endif + +tcSpliceExpr :: HsSplice Name + -> TcRhoType + -> TcM (HsExpr TcId) + +tcUntypedBracket :: HsBracket Name + -> [PendingRnSplice] + -> TcRhoType + -> TcM (HsExpr TcId) +tcTypedBracket :: HsBracket Name + -> TcRhoType + -> TcM (HsExpr TcId) + +runQuasiQuoteDecl :: HsQuasiQuote RdrName -> TcM [LHsDecl RdrName] +runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) +runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) +runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation + +#ifdef GHCI +tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) + +runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) +runMetaP :: LHsExpr Id -> TcM (LPat RdrName) +runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) +runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +runQuasi :: TH.Q a -> TcM a + +data SpliceInfo + = SpliceInfo + { spliceIsDeclaration :: Bool + , spliceDescription :: String + , spliceLocation :: Maybe SrcSpan + , spliceSource :: Maybe SDoc + , spliceGenerated :: SDoc + } +traceSplice :: SpliceInfo -> TcM () +#endif diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs new file mode 100644 index 00000000..c9aacfd1 --- /dev/null +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -0,0 +1,2315 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +TcTyClsDecls: Typecheck type and class declarations +-} + +{-# LANGUAGE CPP, TupleSections #-} + +module TcTyClsDecls ( + tcTyAndClassDecls, tcAddImplicits, + + -- Functions used by TcInstDcls to check + -- data/type family instance declarations + kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, + tcFamTyPats, tcTyFamInstEqn, famTyConShape, + tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, + wrongKindOfFamily, dataConCtxt, badDataConTyCon + ) where + +#include "HsVersions.h" + +import HsSyn +import HscTypes +import BuildTyCl +import TcRnMonad +import TcEnv +import TcValidity +import TcHsSyn +import TcSimplify( growThetaTyVars ) +import TcBinds( tcRecSelBinds ) +import TcTyDecls +import TcClassDcl +import TcHsType +import TcMType +import TcType +import TysWiredIn( unitTy ) +import FamInst +import FamInstEnv( isDominatedBy, mkCoAxBranch, mkBranchedCoAxiom ) +import Coercion( pprCoAxBranch, ltRole ) +import Type +import TypeRep -- for checkValidRoles +import Kind +import Class +import CoAxiom +import TyCon +import DataCon +import Id +import MkCore ( rEC_SEL_ERROR_ID ) +import IdInfo +import Var +import VarEnv +import VarSet +import Module +import Name +import NameSet +import NameEnv +import Outputable +import Maybes +import Unify +import Util +import SrcLoc +import ListSetOps +import Digraph +import DynFlags +import FastString +import Unique ( mkBuiltinUnique ) +import BasicTypes + +import Bag +import Control.Monad +import Data.List + +{- +************************************************************************ +* * +\subsection{Type checking for type and class declarations} +* * +************************************************************************ + +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::BOX). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + +Note [Check role annotations in a second pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Role inference potentially depends on the types of all of the datacons declared +in a mutually recursive group. The validity of a role annotation, in turn, +depends on the result of role inference. Because the types of datacons might +be ill-formed (see #7175 and Note [Checking GADT return types]) we must check +*all* the tycons in a group for validity before checking *any* of the roles. +Thus, we take two passes over the resulting tycons, first checking for general +validity and then checking for valid role annotations. +-} + +tcTyAndClassDecls :: ModDetails + -> [TyClGroup Name] -- Mutually-recursive groups in dependency order + -> TcM TcGblEnv -- Input env extended by types and classes + -- and their implicit Ids,DataCons +-- Fails if there are any errors +tcTyAndClassDecls boot_details tyclds_s + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + fold_env tyclds_s -- Type check each group in dependency order folding the global env + where + fold_env :: [TyClGroup Name] -> TcM TcGblEnv + fold_env [] = getGblEnv + fold_env (tyclds:tyclds_s) + = do { tcg_env <- tcTyClGroup boot_details tyclds + ; setGblEnv tcg_env $ fold_env tyclds_s } + -- remaining groups are typecheck in the extended global env + +tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv +-- Typecheck one strongly-connected component of type and class decls +tcTyClGroup boot_details tyclds + = do { -- Step 1: kind-check this group and returns the final + -- (possibly-polymorphic) kind of each TyCon and Class + -- See Note [Kind checking for type and class decls] + names_w_poly_kinds <- kcTyClGroup tyclds + ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + ; let role_annots = extractRoleAnnots tyclds + decls = group_tyclds tyclds + ; tyclss <- fixM $ \ rec_tyclss -> do + { is_boot <- tcIsHsBootOrSig + ; let rec_flags = calcRecFlags boot_details is_boot + role_annots rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [Recusion and promoting data constructors] + -- we will have failed already in kcTyClGroup, so no worries here + ; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $ + + -- Also extend the local type envt with bindings giving + -- the (polymorphic) kind of each knot-tied TyCon or Class + -- See Note [Type checking recursive type and class declarations] + tcExtendKindEnv names_w_poly_kinds $ + + -- Kind and type check declarations for this group + concatMapM (tcTyClDecl rec_flags) decls } + + -- Step 3: Perform the validity check + -- We can do this now because we are done with the recursive knot + -- Do it before Step 4 (adding implicit things) because the latter + -- expects well-formed TyCons + ; tcExtendGlobalEnv tyclss $ do + { traceTc "Starting validity check" (ppr tyclss) + ; checkNoErrs $ + mapM_ (recoverM (return ()) . checkValidTyCl) tyclss + -- We recover, which allows us to report multiple validity errors + -- the checkNoErrs is necessary to fix #7175. + ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss + -- See Note [Check role annotations in a second pass] + + -- Step 4: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $ + tcAddImplicits tyclss } } + +tcAddImplicits :: [TyThing] -> TcM TcGblEnv +tcAddImplicits tyclss + = tcExtendGlobalEnvImplicit implicit_things $ + tcRecSelBinds rec_sel_binds + where + implicit_things = concatMap implicitTyThings tyclss + rec_sel_binds = mkRecSelBinds tyclss + +zipRecTyClss :: [(Name, Kind)] + -> [TyThing] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the things bound by decls +-- being careful not to look at the [TyThing] +-- The TyThings in the result list must have a visible ATyCon, +-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +zipRecTyClss kind_pairs rec_things + = [ (name, ATyCon (get name)) | (name, _kind) <- kind_pairs ] + where + rec_type_env :: TypeEnv + rec_type_env = mkTypeEnv rec_things + + get name = case lookupTypeEnv rec_type_env name of + Just (ATyCon tc) -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +{- +************************************************************************ +* * + Kind checking +* * +************************************************************************ + +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the *data* type, class, + and closed type family decls, and extend the kind environment (which is + in the TcLclEnv) + + 2. Dependency-analyse the type *synonyms* (which must be non-recursive), + and kind-check them in dependency order. Extend the kind envt. + + 3. Kind check the data type and class decls + +Synonyms are treated differently to data type and classes, +because a type synonym can be an unboxed type + type Foo = Int# +and a kind variable can't unify with UnboxedTypeKind +So we infer their kinds in dependency order + +We need to kind check all types in the mutually recursive group +before we know the kind of the type variables. For example: + + class C a where + op :: D b => a -> b -> b + + class D c where + bop :: (Monad c) => ... + +Here, the kind of the locally-polymorphic type variable "b" +depends on *all the uses of class D*. For example, the use of +Monad c in bop's type signature means that D must have kind Type->Type. + +However type synonyms work differently. They can have kinds which don't +just involve (->) and *: + type R = Int# -- Kind # + type S a = Array# a -- Kind * -> # + type T a b = (# a,b #) -- Kind * -> * -> (# a,b #) +So we must infer their kinds from their right-hand sides *first* and then +use them, whereas for the mutually recursive data types D we bring into +scope kind bindings D -> k, where k is a kind variable, and do inference. + +Open type families +~~~~~~~~~~~~~~~~~~ +This treatment of type synonyms only applies to Haskell 98-style synonyms. +General type functions can be recursive, and hence, appear in `alg_decls'. + +The kind of an open type family is solely determinded by its kind signature; +hence, only kind signatures participate in the construction of the initial +kind environment (as constructed by `getInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). +-} + +kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] +-- Kind check this group, kind generalize, and return the resulting local env +-- This bindds the TyCons and Classes of the group, but not the DataCons +-- See Note [Kind checking for type and class decls] +kcTyClGroup (TyClGroup { group_tyclds = decls }) + = do { mod <- getModule + ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for non-synonyms + -- 2. Kind-check synonyms, and bind kinds of those synonyms + -- 3. Kind-check non-synonyms + -- 4. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + -- Step 1: Bind kind variables for non-synonyms + ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls + ; initial_kinds <- getInitialKinds non_syn_decls + ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds) + + -- Step 2: Set initial envt, kind-check the synonyms + ; lcl_env <- tcExtendKindEnv2 initial_kinds $ + kcSynDecls (calcSynCycles syn_decls) + + -- Step 3: Set extended envt, kind-check the non-synonyms + ; setLclEnv lcl_env $ + mapM_ kcLTyClDecl non_syn_decls + + -- Step 4: generalisation + -- Kind checking done for this group + -- Now we have to kind generalize the flexis + ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls + + ; traceTc "kcTyClGroup result" (ppr res) + ; return res } + + where + generalise :: TcTypeEnv -> Name -> TcM (Name, Kind) + -- For polymorphic things this is a no-op + generalise kind_env name + = do { let kc_kind = case lookupNameEnv kind_env name of + Just (AThing k) -> k + _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) + ; kvs <- kindGeneralize (tyVarsOfType kc_kind) + ; kc_kind' <- zonkTcKind kc_kind -- Make sure kc_kind' has the final, + -- skolemised kind variables + ; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ]) + ; return (name, mkForAllTys kvs kc_kind') } + + generaliseTCD :: TcTypeEnv -> LTyClDecl Name -> TcM [(Name, Kind)] + generaliseTCD kind_env (L _ decl) + | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl + = do { first <- generalise kind_env name + ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats + ; return (first : rest) } + + | FamDecl { tcdFam = fam } <- decl + = do { res <- generaliseFamDecl kind_env fam + ; return [res] } + + | otherwise + = do { res <- generalise kind_env (tcdName decl) + ; return [res] } + + generaliseFamDecl :: TcTypeEnv -> FamilyDecl Name -> TcM (Name, Kind) + generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) + = generalise kind_env name + +mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)] +mk_thing_env [] = [] +mk_thing_env (decl : decls) + | L _ (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) <- decl + = (nm, APromotionErr ClassPE) : + (map (, APromotionErr TyConPE) $ map (unLoc . fdLName . unLoc) ats) ++ + (mk_thing_env decls) + + | otherwise + = (tcdName (unLoc decl), APromotionErr TyConPE) : + (mk_thing_env decls) + +getInitialKinds :: [LTyClDecl Name] -> TcM [(Name, TcTyThing)] +getInitialKinds decls + = tcExtendKindEnv2 (mk_thing_env decls) $ + do { pairss <- mapM (addLocM getInitialKind) decls + ; return (concat pairss) } + +getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)] +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return (tc, AThing k) +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> kv3) +-- +-- This pass deals with (ie incorporates into the kind it produces) +-- * The kind signatures on type-variable binders +-- * The result kinds signature on a TyClDecl +-- +-- ALSO for each datacon, return (dc, APromotionErr RecDataConPE) +-- Note [ARecDataCon: Recursion and promoting data constructors] +-- +-- No family instances are passed to getInitialKinds + +getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) + = do { (cl_kind, inner_prs) <- + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ + do { inner_prs <- getFamDeclInitialKinds ats + ; return (constraintKind, inner_prs) } + ; let main_pr = (name, AThing cl_kind) + ; return (main_pr : inner_prs) } + +getInitialKind decl@(DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig + , dd_cons = cons' } }) + = let cons = cons' -- AZ list monad coming + in + do { (decl_kind, _) <- + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ + do { res_k <- case m_sig of + Just ksig -> tcLHsKind ksig + Nothing -> return liftedTypeKind + ; return (res_k, ()) } + ; let main_pr = (name, AThing decl_kind) + inner_prs = [ (unLoc con, APromotionErr RecDataConPE) + | L _ con' <- cons, con <- con_names con' ] + ; return (main_pr : inner_prs) } + +getInitialKind (FamDecl { tcdFam = decl }) + = getFamDeclInitialKind decl + +getInitialKind decl@(SynDecl {}) + = pprPanic "getInitialKind" (ppr decl) + +--------------------------------- +getFamDeclInitialKinds :: [LFamilyDecl Name] -> TcM [(Name, TcTyThing)] +getFamDeclInitialKinds decls + = tcExtendKindEnv2 [ (n, APromotionErr TyConPE) + | L _ (FamilyDecl { fdLName = L _ n }) <- decls] $ + concatMapM (addLocM getFamDeclInitialKind) decls + +getFamDeclInitialKind :: FamilyDecl Name + -> TcM [(Name, TcTyThing)] +getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdKindSig = ksig }) + = do { (fam_kind, _) <- + kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ + do { res_k <- case ksig of + Just k -> tcLHsKind k + Nothing + | famDeclHasCusk decl -> return liftedTypeKind + | otherwise -> newMetaKindVar + ; return (res_k, ()) } + ; return [ (name, AThing fam_kind) ] } + +---------------- +kcSynDecls :: [SCC (LTyClDecl Name)] + -> TcM TcLclEnv -- Kind bindings +kcSynDecls [] = getLclEnv +kcSynDecls (group : groups) + = do { (n,k) <- kcSynDecl1 group + ; lcl_env <- tcExtendKindEnv [(n,k)] (kcSynDecls groups) + ; return lcl_env } + +kcSynDecl1 :: SCC (LTyClDecl Name) + -> TcM (Name,TcKind) -- Kind bindings +kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl +kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } + -- Fail here to avoid error cascade + -- of out-of-scope tycons + +kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) +kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name + , tcdRhs = rhs }) + -- Returns a possibly-unzonked kind + = tcAddDeclCtxt decl $ + do { (syn_kind, _) <- + kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ + do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)) + ; (_, rhs_kind) <- tcLHsType rhs + ; traceTc "kcd2" (ppr name) + ; return (rhs_kind, ()) } + ; return (name, syn_kind) } +kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) + +------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl Name -> TcM () + -- See Note [Kind checking for type and class decls] +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl + +kcTyClDecl :: TyClDecl Name -> TcM () +-- This function is used solely for its side effect on kind variables +-- NB kind signatures on the type variables and +-- result kind signature have aready been dealt with +-- by getInitialKind, so we can ignore them here. + +kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = defn }) + | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn + = mapM_ (wrapLocM kcConDecl) cons + -- hs_tvs and dd_kindSig already dealt with in getInitialKind + -- If dd_kindSig is Just, this must be a GADT-style decl, + -- (see invariants of DataDefn declaration) + -- so (a) we don't need to bring the hs_tvs into scope, because the + -- ConDecls bind all their own variables + -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it + + | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn + = kcTyClTyVars name hs_tvs $ + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM kcConDecl) cons } + +kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl) + +kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdCtxt = ctxt, tcdSigs = sigs }) + = kcTyClTyVars name hs_tvs $ + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM kc_sig) sigs } + where + kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty) + kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig _ = return () + +-- closed type families look at their equations, but other families don't +-- do anything here +kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name + , fdTyVars = hs_tvs + , fdInfo = ClosedTypeFamily eqns })) + = do { tc_kind <- kcLookupKind fam_tc_name + ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) + ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } +kcTyClDecl (FamDecl {}) = return () + +------------------- +kcConDecl :: ConDecl Name -> TcM () +kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details + , con_res = res }) + = addErrCtxt (dataConCtxtName names) $ + -- the 'False' says that the existentials don't have a CUSK, as the + -- concept doesn't really apply here. We just need to bring the variables + -- into scope! + do { _ <- kcHsTyVarBndrs False ex_tvs $ + do { _ <- tcHsContext ex_ctxt + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) + ; _ <- tcConRes res + ; return (panic "kcConDecl", ()) } + ; return () } + +{- +Note [Recursion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> AThing + K -> ARecDataCon + +ANothing is only used for DataCons, and only used during type checking +in tcTyClGroup. + + +************************************************************************ +* * +\subsection{Type checking} +* * +************************************************************************ + +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +kind-checking the RHS of T's decl, we *do* need to know T's kind (so +that we can correctly elaboarate (T k f a). How can we get T's kind +without looking at T? Delicate answer: during tcTyClDecl, we extend + + *Global* env with T -> ATyCon (the (not yet built) TyCon for T) + *Local* env with T -> AThing (polymorphic kind of T) + +Then: + + * During TcHsType.kcTyVar we look in the *local* env, to get the + known kind for T. + + * But in TcHsType.ds_type (and ds_var_app in particular) we look in + the *global* env to get the TyCon. But we must be careful not to + force the TyCon or we'll get a loop. + +This fancy footwork (with two bindings for T) is only necesary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. +-} + +tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing] +tcTyClDecl rec_info (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ + traceTc "tcTyAndCl-x" (ppr decl) >> + tcTyClDecl1 NoParentTyCon rec_info decl + + -- "type family" declarations +tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing] +tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) + = tcFamDecl1 parent fd + + -- "type" synonym declaration +tcTyClDecl1 _parent rec_info + (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs }) + = ASSERT( isNoParent _parent ) + tcTyClTyVars tc_name tvs $ \ tvs' kind -> + tcTySynRhs rec_info tc_name tvs' kind rhs + + -- "data/newtype" declaration +tcTyClDecl1 _parent rec_info + (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn }) + = ASSERT( isNoParent _parent ) + tcTyClTyVars tc_name tvs $ \ tvs' kind -> + tcDataDefn rec_info tc_name tvs' kind defn + +tcTyClDecl1 _parent rec_info + (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs + , tcdCtxt = ctxt, tcdMeths = meths + , tcdFDs = fundeps, tcdSigs = sigs + , tcdATs = ats, tcdATDefs = at_defs }) + = ASSERT( isNoParent _parent ) + do { (clas, tvs', gen_dm_env) <- fixM $ \ ~(clas,_,_) -> + tcTyClTyVars class_name tvs $ \ tvs' kind -> + do { MASSERT( isConstraintKind kind ) + -- This little knot is just so we can get + -- hold of the name of the class TyCon, which we + -- need to look up its recursiveness + ; let tycon_name = tyConName (classTyCon clas) + tc_isrec = rti_is_rec rec_info tycon_name + roles = rti_roles rec_info tycon_name + + ; ctxt' <- tcHsContext ctxt + ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' + -- Squeeze out any kind unification variables + ; fds' <- mapM (addLocM tc_fundep) fundeps + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths + ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; clas <- buildClass + class_name tvs' roles ctxt' fds' at_stuff + sig_stuff mindef tc_isrec + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds') + ; return (clas, tvs', gen_dm_env) } + + ; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + ; class_ats = map ATyCon (classATs clas) } + + ; return (ATyCon (classTyCon clas) : gen_dm_ids ++ class_ats ) } + -- NB: Order is important due to the call to `mkGlobalThings' when + -- tying the the type and class declaration type checking knot. + where + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tc_fd_tyvar . unLoc) tvs1 ; + ; tvs2' <- mapM (tc_fd_tyvar . unLoc) tvs2 ; + ; return (tvs1', tvs2') } + tc_fd_tyvar name -- Scoped kind variables are bound to unification variables + -- which are now fixed, so we can zonk + = do { tv <- tcLookupTyVar name + ; ty <- zonkTyVarOcc emptyZonkEnv tv + -- Squeeze out any kind unification variables + ; case getTyVar_maybe ty of + Just tv' -> return tv' + Nothing -> pprPanic "tc_fd_tyvar" (ppr name $$ ppr tv $$ ppr ty) } + +tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing] +tcFamDecl1 parent + (FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { traceTc "open type family:" (ppr tc_name) + ; checkFamFlag tc_name + ; tycon <- buildFamilyTyCon tc_name tvs' OpenSynFamilyTyCon kind parent + ; return [ATyCon tycon] } + +tcFamDecl1 parent + (FamilyDecl { fdInfo = ClosedTypeFamily eqns + , fdLName = lname@(L _ tc_name), fdTyVars = tvs }) +-- Closed type families are a little tricky, because they contain the definition +-- of both the type family and the equations for a CoAxiom. +-- Note: eqns might be empty, in a hs-boot file! + = do { traceTc "closed type family:" (ppr tc_name) + -- the variables in the header have no scope: + ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> + return (tvs', kind) + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + + -- Process the equations, creating CoAxBranches + ; tc_kind <- kcLookupKind tc_name + ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) + + ; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns + + -- we need the tycon that we will be creating, but it's in scope. + -- just look it up. + ; fam_tc <- tcLookupLocatedTyCon lname + + -- create a CoAxiom, with the correct src location. It is Vitally + -- Important that we do not pass the branches into + -- newFamInstAxiomName. They have types that have been zonked inside + -- the knot and we will die if we look at them. This is OK here + -- because there will only be one axiom, so we don't need to + -- differentiate names. + -- See [Zonking inside the knot] in TcHsType + ; loc <- getSrcSpanM + ; co_ax_name <- newFamInstAxiomName loc tc_name [] + + -- mkBranchedCoAxiom will fail on an empty list of branches, but + -- we'll never look at co_ax in this case + ; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches + + -- now, finally, build the TyCon + ; let syn_rhs = if null eqns + then AbstractClosedSynFamilyTyCon + else ClosedSynFamilyTyCon co_ax + ; tycon <- buildFamilyTyCon tc_name tvs' syn_rhs kind parent + + ; let result = if null eqns + then [ATyCon tycon] + else [ATyCon tycon, ACoAxiom co_ax] + ; return result } +-- We check for instance validity later, when doing validity checking for +-- the tycon + +tcFamDecl1 parent + (FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { traceTc "data family:" (ppr tc_name) + ; checkFamFlag tc_name + ; extra_tvs <- tcDataKindSig kind + ; let final_tvs = tvs' ++ extra_tvs -- we may not need these + roles = map (const Nominal) final_tvs + tycon = buildAlgTyCon tc_name final_tvs roles Nothing [] + DataFamilyTyCon Recursive + False -- Not promotable to the kind level + True -- GADT syntax + parent + ; return [ATyCon tycon] } + +tcTySynRhs :: RecTyInfo + -> Name + -> [TyVar] -> Kind + -> LHsType Name -> TcM [TyThing] +tcTySynRhs rec_info tc_name tvs kind hs_ty + = do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; let roles = rti_roles rec_info tc_name + ; tycon <- buildSynonymTyCon tc_name tvs roles rhs_ty kind + ; return [ATyCon tycon] } + +tcDataDefn :: RecTyInfo -> Name + -> [TyVar] -> Kind + -> HsDataDefn Name -> TcM [TyThing] + -- NB: not used for newtype/data instances (whether associated or not) +tcDataDefn rec_info tc_name tvs kind + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt, dd_kindSig = mb_ksig + , dd_cons = cons' }) + = let cons = cons' -- AZ List monad coming + in do { extra_tvs <- tcDataKindSig kind + ; let final_tvs = tvs ++ extra_tvs + roles = rti_roles rec_info tc_name + ; stupid_tc_theta <- tcHsContext ctxt + ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta + ; kind_signatures <- xoptM Opt_KindSignatures + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + + -- Check that we don't use kind signatures without Glasgow extensions + ; case mb_ksig of + Nothing -> return () + Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name) + ; tc_kind <- tcLHsKind hs_k + ; checkKind kind tc_kind + ; return () } + + ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons + + ; tycon <- fixM $ \ tycon -> do + { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons + ; tc_rhs <- + if null cons && is_boot -- In a hs-boot file, empty cons means + then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract + else case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) + ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType) + stupid_theta tc_rhs + (rti_is_rec rec_info tc_name) + (rti_promotable rec_info) + gadt_syntax NoParentTyCon) } + ; return [ATyCon tycon] } + +{- +************************************************************************ +* * + Typechecking associated types (in class decls) + (including the associated-type defaults) +* * +************************************************************************ + +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following is an example of associated type defaults: + class C a where + data D a + + type F a b :: * + type F a Z = [a] -- Default + type F a (S n) = F a n -- Default + +Note that: + - We can have more than one default definition for a single associated type, + as long as they do not overlap (same rules as for instances) + - We can get default definitions only for type families, not data families +-} + +tcClassATs :: Name -- The class name (not knot-tied) + -> TyConParent -- The class parent of this associated type + -> [LFamilyDecl Name] -- Associated types. + -> [LTyFamDefltEqn Name] -- Associated type defaults. + -> TcM [ClassATItem] +tcClassATs class_name parent ats at_defs + = do { -- Complain about associated type defaults for non associated-types + sequence_ [ failWithTc (badATErr class_name n) + | n <- map at_def_tycon at_defs + , not (n `elemNameSet` at_names) ] + ; mapM tc_at ats } + where + at_def_tycon :: LTyFamDefltEqn Name -> Name + at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) + + at_fam_name :: LFamilyDecl Name -> Name + at_fam_name (L _ decl) = unLoc (fdLName decl) + + at_names = mkNameSet (map at_fam_name ats) + + at_defs_map :: NameEnv [LTyFamDefltEqn Name] + -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (at_def_tycon at_def) [at_def]) + emptyNameEnv at_defs + + tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } + +------------------------- +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon + -> [LTyFamDefltEqn Name] -- ^ Defaults + -> TcM (Maybe (Type, SrcSpan)) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (ptext (sLit "More than one default declaration for") + <+> ppr (tfe_tycon (unLoc d1))) + +tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name + , tfe_pats = hs_tvs + , tfe_rhs = rhs })] + = setSrcSpan loc $ + tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> + do { traceTc "tcDefaultAssocDecl" (ppr tc_name) + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc + ; ASSERT( fam_name == tc_name ) + checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) + (wrongNumberOfParmsErr fam_pat_arity) + ; rhs_ty <- tcCheckLHsType rhs rhs_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; let fam_tc_tvs = tyConTyVars fam_tc + subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) + ; return ( ASSERT( equalLength fam_tc_tvs tvs ) + Just (substTy subst rhs_ty, loc) ) } + -- We check for well-formedness and validity later, in checkValidClass + +------------------------- +kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () +kcTyFamInstEqn fam_tc_shape + (L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty })) + = setSrcSpan loc $ + discardResult $ + tc_fam_ty_pats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) + +tcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM CoAxBranch +-- Needs to be here, not in TcInstDcls, because closed families +-- (typechecked here) have TyFamInstEqns +tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) + (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name + , tfe_pats = pats + , tfe_rhs = hs_ty })) + = setSrcSpan loc $ + tcFamTyPats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) $ + \tvs' pats' res_kind -> + do { checkTc (fam_tc_name == eqn_tc_name) + (wrongTyFamName fam_tc_name eqn_tc_name) + ; rhs_ty <- tcCheckLHsType hs_ty res_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> ppr tvs') + -- don't print out the pats here, as they might be zonked inside the knot + ; return (mkCoAxBranch tvs' pats' rhs_ty loc) } + +kcDataDefn :: HsDataDefn Name -> TcKind -> TcM () +-- Used for 'data instance' only +-- Ordinary 'data' is handled by kcTyClDec +kcDataDefn (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k + = do { _ <- tcHsContext ctxt + ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons + -- See Note [Failing early in kcDataDefn] + ; kcResultKind mb_kind res_k } + +------------------ +kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind Nothing res_k + = checkKind res_k liftedTypeKind + -- type family F a + -- defaults to type family F a :: * +kcResultKind (Just k) res_k + = do { k' <- tcLHsKind k + ; checkKind k' res_k } + +{- +Kind check type patterns and kind annotate the embedded type variables. + type instance F [a] = rhs + + * Here we check that a type instance matches its kind signature, but we do + not check whether there is a pattern for each type index; the latter + check is only required for type synonym instances. + +Note [tc_fam_ty_pats vs tcFamTyPats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tc_fam_ty_pats does the type checking of the patterns, but it doesn't +zonk or generate any desugaring. It is used when kind-checking closed +type families. + +tcFamTyPats type checks the patterns, zonks, and then calls thing_inside +to generate a desugaring. It is used during type-checking (not kind-checking). + +Note [Type-checking type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking the patterns of a family instance declaration, we can't +rely on using the family TyCon, because this is sometimes called +from within a type-checking knot. (Specifically for closed type families.) +The type FamTyConShape gives just enough information to do the job. + +The "arity" field of FamTyConShape is the *visible* arity of the family +type constructor, i.e. what the users sees and writes, not including kind +arguments. + +See also Note [tc_fam_ty_pats vs tcFamTyPats] + +Note [Failing early in kcDataDefn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl +calls tcConDecl, which checks that the return type of a GADT-like constructor +is actually an instance of the type head. Without the checkNoErrs, potentially +two bad things could happen: + + 1) Duplicate error messages, because tcConDecl will be called again during + *type* checking (as opposed to kind checking) + 2) If we just keep blindly forging forward after both kind checking and type + checking, we can get a panic in rejigConRes. See Trac #8368. +-} + +----------------- +type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] + +famTyConShape :: TyCon -> FamTyConShape +famTyConShape fam_tc + = ( tyConName fam_tc + , length (filterOut isKindVar (tyConTyVars fam_tc)) + , tyConKind fam_tc ) + +tc_fam_ty_pats :: FamTyConShape + -> HsWithBndrs Name [LHsType Name] -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored + -> TcM ([Kind], [Type], Kind) +-- Check the type patterns of a type or data family instance +-- type instance F = +-- The 'tyvars' are the free type variables of pats +-- +-- NB: The family instance declaration may be an associated one, +-- nested inside an instance decl, thus +-- instance C [a] where +-- type F [a] = ... +-- In that case, the type variable 'a' will *already be in scope* +-- (and, if C is poly-kinded, so will its kind parameter). + +tc_fam_ty_pats (name, arity, kind) + (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) + kind_checker + = do { let (fam_kvs, fam_body) = splitForAllTys kind + + -- We wish to check that the pattern has the right number of arguments + -- in checkValidFamPats (in TcValidity), so we can do the check *after* + -- we're done with the knot. But, the splitKindFunTysN below will panic + -- if there are *too many* patterns. So, we do a preliminary check here. + -- Note that we don't have enough information at hand to do a full check, + -- as that requires the full declared arity of the family, which isn't + -- nearby. + ; checkTc (length arg_pats == arity) $ + wrongNumberOfParmsErr arity + + -- Instantiate with meta kind vars + ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs + ; loc <- getSrcSpanM + ; let (arg_kinds, res_kind) + = splitKindFunTysN (length arg_pats) $ + substKiWith fam_kvs fam_arg_kinds fam_body + hs_tvs = HsQTvs { hsq_kvs = kvars + , hsq_tvs = userHsTyVarBndrs loc tvars } + + -- Kind-check and quantify + -- See Note [Quantifying over family patterns] + ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> + do { kind_checker res_kind + ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } + + ; return (fam_arg_kinds, typats, res_kind) } + +-- See Note [tc_fam_ty_pats vs tcFamTyPats] +tcFamTyPats :: FamTyConShape + -> HsWithBndrs Name [LHsType Name] -- patterns + -> (TcKind -> TcM ()) -- kind-checker for RHS + -> ([TKVar] -- Kind and type variables + -> [TcType] -- Kind and type arguments + -> Kind -> TcM a) + -> TcM a +tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside + = do { (fam_arg_kinds, typats, res_kind) + <- tc_fam_ty_pats fam_shape pats kind_checker + ; let all_args = fam_arg_kinds ++ typats + + -- Find free variables (after zonking) and turn + -- them into skolems, so that we don't subsequently + -- replace a meta kind var with AnyK + -- Very like kindGeneralize + ; qtkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes all_args) + + -- Zonk the patterns etc into the Type world + ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs + ; all_args' <- zonkTcTypeToTypes ze all_args + ; res_kind' <- zonkTcTypeToType ze res_kind + + ; traceTc "tcFamTyPats" (ppr name) + -- don't print out too much, as we might be in the knot + ; tcExtendTyVarEnv qtkvs' $ + thing_inside qtkvs' all_args' res_kind' } + +{- +Note [Quantifying over family patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to quantify over two different lots of kind variables: + +First, the ones that come from the kinds of the tyvar args of +tcTyVarBndrsKindGen, as usual + data family Dist a + + -- Proxy :: forall k. k -> * + data instance Dist (Proxy a) = DP + -- Generates data DistProxy = DP + -- ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a + -- The 'k' comes from the tcTyVarBndrsKindGen (a::k) + +Second, the ones that come from the kind argument of the type family +which we pick up using the (tyVarsOfTypes typats) in the result of +the thing_inside of tcHsTyvarBndrsGen. + -- Any :: forall k. k + data instance Dist Any = DA + -- Generates data DistAny k = DA + -- ax7 k :: Dist k (Any k) ~ DistAny k + -- The 'k' comes from kindGeneralizeKinds (Any k) + +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:BOX, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind variables +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + + +************************************************************************ +* * + Data types +* * +************************************************************************ +-} + +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool +dataDeclChecks tc_name new_or_data stupid_theta cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM Opt_GADTSyntax + ; let gadt_syntax = consUseGadtSyntax cons + ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) + ; return gadt_syntax } + + +----------------------------------- +consUseGadtSyntax :: [LConDecl a] -> Bool +consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ _ }) : _) = True +consUseGadtSyntax _ = False + -- All constructors have same shape + +----------------------------------- +tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type) + -> [LConDecl Name] -> TcM [DataCon] +tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) cons + = concatMapM (addLocM $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl) + cons + +tcConDecl :: NewOrData + -> TyCon -- Representation tycon + -> [TyVar] -> Type -- Return type template (with its template tyvars) + -- (tvs, T tys), where T is the family TyCon + -> ConDecl Name + -> TcM [DataCon] + +tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types + (ConDecl { con_names = names + , con_qvars = hs_tvs, con_cxt = hs_ctxt + , con_details = hs_details, con_res = hs_res_ty }) + = addErrCtxt (dataConCtxtName names) $ + do { traceTc "tcConDecl 1" (ppr names) + ; (ctxt, arg_tys, res_ty, field_lbls, stricts) + <- tcHsTyVarBndrs hs_tvs $ \ _ -> + do { ctxt <- tcHsContext hs_ctxt + ; details <- tcConArgs new_or_data hs_details + ; res_ty <- tcConRes hs_res_ty + ; let (field_lbls, btys) = details + (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + } + + -- Generalise the kind variables (returning quantified TcKindVars) + -- and quantify the type variables (substituting their kinds) + -- REMEMBER: 'tkvs' are: + -- ResTyH98: the *existential* type variables only + -- ResTyGADT: *all* the quantified type variables + -- c.f. the comment on con_qvars in HsDecls + ; tkvs <- case res_ty of + ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) + (tyVarsOfTypes (ctxt++arg_tys)) + ResTyGADT _ res_ty -> quantifyTyVars emptyVarSet + (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + + -- Zonk to Types + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs + ; arg_tys <- zonkTcTypeToTypes ze arg_tys + ; ctxt <- zonkTcTypeToTypes ze ctxt + ; res_ty <- case res_ty of + ResTyH98 -> return ResTyH98 + ResTyGADT ls ty -> ResTyGADT ls <$> zonkTcTypeToType ze ty + + ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty + + ; fam_envs <- tcGetFamInstEnvs + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfix name hs_details res_ty + ; buildDataCon fam_envs name is_infix + stricts field_lbls + univ_tvs ex_tvs eq_preds ctxt arg_tys + res_ty' rep_tycon + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; mapM buildOneDataCon names + } + + +tcConIsInfix :: Name + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> ResType Type + -> TcM Bool +tcConIsInfix _ details ResTyH98 + = case details of + InfixCon {} -> return True + _ -> return False +tcConIsInfix con details (ResTyGADT _ _) + = case details of + InfixCon {} -> return True + RecCon {} -> return False + PrefixCon arg_tys -- See Note [Infix GADT cons] + | isSymOcc (getOccName con) + , [_ty1,_ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (con `elemNameEnv` fix_env) } + | otherwise -> return False + + + +tcConArgs :: NewOrData -> HsConDeclDetails Name + -> TcM ([Name], [(TcType, HsSrcBang)]) +tcConArgs new_or_data (PrefixCon btys) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return ([], btys') } +tcConArgs new_or_data (InfixCon bty1 bty2) + = do { bty1' <- tcConArg new_or_data bty1 + ; bty2' <- tcConArg new_or_data bty2 + ; return ([], [bty1', bty2']) } +tcConArgs new_or_data (RecCon fields) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (field_names, btys') } + where + -- We need a one-to-one mapping from field_names to btys + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) + explode (ns,ty) = zip (map unLoc ns) (repeat ty) + exploded = concatMap explode combined + (field_names,btys) = unzip exploded + +tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang) +tcConArg new_or_data bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcHsConArgType new_or_data bty + ; traceTc "tcConArg 2" (ppr bty) + ; return (arg_ty, getBangStrictness bty) } + +tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) +tcConRes ResTyH98 = return ResTyH98 +tcConRes (ResTyGADT ls res_ty) = do { res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT ls res_ty') } + +{- +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int + + +Note [Checking GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a delicacy around checking the return types of a datacon. The +central problem is dealing with a declaration like + + data T a where + MkT :: a -> Q a + +Note that the return type of MkT is totally bogus. When creating the T +tycon, we also need to create the MkT datacon, which must have a "rejigged" +return type. That is, the MkT datacon's type must be transformed to have +a uniform return type with explicit coercions for GADT-like type parameters. +This rejigging is what rejigConRes does. The problem is, though, that checking +that the return type is appropriate is much easier when done over *Type*, +not *HsType*. + +So, we want to make rejigConRes lazy and then check the validity of the return +type in checkValidDataCon. But, if the return type is bogus, rejigConRes can't +work -- it will have a failed pattern match. Luckily, if we run +checkValidDataCon before ever looking at the rejigged return type +(checkValidDataCon checks the dataConUserType, which is not rejigged!), we +catch the error before forcing the rejigged type and panicking. +-} + +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. + -- data instance T [a] b c = ... + -- gives template ([a,b,c], T [a] b c) + -> [TyVar] -- where MkT :: forall x y z. ... + -> ResType Type + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [(TyVar,Type)], -- Equality predicates + Type) -- Typechecked return type + -- We don't check that the TyCon given in the ResTy is + -- the same as the parent tycon, because checkValidDataCon will do it + +rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98 + = (tmpl_tvs, dc_tvs, [], res_ty) + -- In H98 syntax the dc_tvs are the existential ones + -- data T a b c = forall d e. MkT ... + -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs + +rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT _ res_ty) + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z + -- Then we generate + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) + = (univ_tvs, ex_tvs, eq_spec, res_ty) + where + Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty + -- This 'Just' pattern is sure to match, because if not + -- checkValidDataCon will complain first. + -- See Note [Checking GADT return types] + + -- /Lazily/ figure out the univ_tvs etc + -- Each univ_tv is either a dc_tv or a tmpl_tv + (univ_tvs, eq_spec) = foldr choose ([], []) tmpl_tvs + choose tmpl (univs, eqs) + | Just ty <- lookupTyVar subst tmpl + = case tcGetTyVar_maybe ty of + Just tv | not (tv `elem` univs) + -> (tv:univs, eqs) + _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) + where -- see Note [Substitution in template variables kinds] + new_tmpl = updateTyVarKind (substTy subst) tmpl + | otherwise = pprPanic "tcResultType" (ppr res_ty) + ex_tvs = dc_tvs `minusList` univ_tvs + +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data List a = Nil | Cons a (List a) +data SList s as where + SNil :: SList s Nil + +We call tcResultType with + tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)] + res_tmpl = SList k s as + res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1)) + +We get subst: + k -> k1 + s -> s1 + as -> Nil k1 + +Now we want to find out the universal variables and the equivalences +between some of them and types (GADT). + +In this example, k and s are mapped to exactly variables which are not +already present in the universal set, so we just add them without any +coercion. + +But 'as' is mapped to 'Nil k1', so we add 'as' to the universal set, +and add the equivalence with 'Nil k1' in 'eqs'. + +The problem is that with kind polymorphism, as's kind may now contain +kind variables, and we have to apply the template substitution to it, +which is why we create new_tmpl. + +The template substitution only maps kind variables to kind variables, +since GADTs are not kind indexed. + +************************************************************************ +* * + Validity checking +* * +************************************************************************ + +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. +-} + +checkClassCycleErrs :: Class -> TcM () +checkClassCycleErrs cls = mapM_ recClsErr (calcClassCycles cls) + +checkValidTyCl :: TyThing -> TcM () +checkValidTyCl thing + = setSrcSpan (getSrcSpan thing) $ + addTyThingCtxt thing $ + case thing of + ATyCon tc -> checkValidTyCon tc + AnId _ -> return () -- Generic default methods are checked + -- with their parent class + ACoAxiom _ -> return () -- Axioms checked with their parent + -- closed family tycon + _ -> pprTrace "checkValidTyCl" (ppr thing) $ return () + +------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. +-- +-- Note that we allow existentials to match because the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential + +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | Just cl <- tyConClass_maybe tc + = checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + = checkValidType syn_ctxt syn_rhs + + | Just fam_flav <- famTyConFlav_maybe tc + = case fam_flav of + { ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ + ptext (sLit "You may omit the equations in a closed type family") $$ + ptext (sLit "only in a .hs-boot file") } + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise + = do { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM Opt_ExistentialQuantification + ; gadt_ok <- xoptM Opt_GADTs + ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups } + + where + syn_ctxt = TySynCtxt name + name = tyConName tc + data_cons = tyConDataCons tc + + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + cmp_fld (f1,_) (f2,_) = f1 `compare` f2 + get_fields con = dataConFieldLabels con `zip` repeat con + -- dataConFieldLabels may return the empty list, which is fine + + -- See Note [GADT record selectors] in MkId.lhs + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types BOTH WAYS ROUND. + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + check_fields ((label, con1) : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + where + (tvs1, _, _, res1) = dataConSig con1 + ts1 = mkVarSet tvs1 + fty1 = dataConFieldType con1 label + + checkOne (_, con2) -- Do it bothways to ensure they are structurally identical + = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2 + ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 } + where + (tvs2, _, _, res2) = dataConSig con2 + ts2 = mkVarSet tvs2 + fty2 = dataConFieldType con2 label + check_fields [] = panic "checkValidTyCon/check_fields []" + +checkValidClosedCoAxiom :: CoAxiom Branched -> TcM () +checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) + = tcAddClosedTypeFamilyDeclCtxt tc $ + do { brListFoldlM_ check_accessibility [] branches + ; void $ brListMapM (checkValidTyFamInst Nothing tc) branches } + where + check_accessibility :: [CoAxBranch] -- prev branches (in reverse order) + -> CoAxBranch -- cur branch + -> TcM [CoAxBranch] -- cur : prev + -- Check whether the branch is dominated by earlier + -- ones and hence is inaccessible + check_accessibility prev_branches cur_branch + = do { when (cur_branch `isDominatedBy` prev_branches) $ + addWarnAt (coAxBranchSpan cur_branch) $ + inaccessibleCoAxBranch tc cur_branch + ; return (cur_branch : prev_branches) } + +checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet + -> Type -> Type -> Type -> Type -> TcM () +checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 + = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) + ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } + where + mb_subst1 = tcMatchTy tvs1 res1 res2 + mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 + +------------------------------- +checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () +checkValidDataCon dflags existential_ok tc con + = setSrcSpan (srcLocSpan (getSrcLoc con)) $ + addErrCtxt (dataConCtxt con) $ + do { -- Check that the return type of the data constructor + -- matches the type constructor; eg reject this: + -- data T a where { MkT :: Bogus a } + -- c.f. Note [Check role annotations in a second pass] + -- and Note [Checking GADT return types] + let tc_tvs = tyConTyVars tc + res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) + orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) + res_ty_tmpl + orig_res_ty)) + (badDataConTyCon con res_ty_tmpl orig_res_ty) + + -- Check that the result type is a *monotype* + -- e.g. reject this: MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidMonoType orig_res_ty + + -- Check all argument types for validity + ; checkValidType ctxt (dataConUserType con) + + -- Extra checks for newtype data constructors + ; when (isNewTyCon tc) (checkNewDataCon con) + + -- Check that UNPACK pragmas and bangs work out + -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" + -- data T = MkT {-# UNPACK #-} !a -- Can't unpack + ; mapM_ check_bang (zip3 (dataConSrcBangs con) (dataConImplBangs con) [1..]) + + -- Check that existentials are allowed if they are used + ; checkTc (existential_ok || isVanillaDataCon con) + (badExistential con) + + -- Check that we aren't doing GADT type refinement on kind variables + -- e.g reject data T (a::k) where + -- T1 :: T Int + -- T2 :: T Maybe + ; checkTc (not (any (isKindVar . fst) (dataConEqSpec con))) + (badGadtKindCon con) + + ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con)) + } + where + ctxt = ConArgCtxt (dataConName con) + check_bang (HsSrcBang _ (Just want_unpack) has_bang, rep_bang, n) + | want_unpack, not has_bang + = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) + | want_unpack + , case rep_bang of { HsUnpack {} -> False; _ -> True } + , not (gopt Opt_OmitInterfacePragmas dflags) + -- If not optimising, se don't unpack, so don't complain! + -- See MkId.dataConArgRep, the (HsBang True) case + = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma"))) + + check_bang _ + = return () + + bad_bang n herald + = hang herald 2 (ptext (sLit "on the") <+> speakNth n + <+> ptext (sLit "argument of") <+> quotes (ppr con)) +------------------------------- +checkNewDataCon :: DataCon -> TcM () +-- Further checks for the data constructor of a newtype +checkNewDataCon con + = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) + -- One argument + + ; check_con (null eq_spec) $ + ptext (sLit "A newtype constructor must have a return type of form T a1 ... an") + -- Return type is (T a b c) + + ; check_con (null theta) $ + ptext (sLit "A newtype constructor cannot have a context in its type") + + ; check_con (null ex_tvs) $ + ptext (sLit "A newtype constructor cannot have existential type variables") + -- No existentials + + ; checkTc (not (any isBanged (dataConSrcBangs con))) + (newtypeStrictError con) + -- No strictness + } + where + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + check_con what msg + = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) + +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods + ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses + ; nullary_type_classes <- xoptM Opt_NullaryTypeClasses + ; fundep_classes <- xoptM Opt_FunctionalDependencies + + -- Check that the class is unary, unless multiparameter type classes + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, Trac #8993) + ; checkTc (multi_param_type_classes || cls_arity == 1 || + (nullary_type_classes && cls_arity == 0)) + (classArityErr cls_arity cls) + ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. + ; checkClassCycleErrs cls + + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff + + -- Check the associated type defaults are well-formed and instantiated + ; mapM_ check_at_defs at_stuff } + where + (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls + cls_arity = count isTypeVar tyvars -- Ignore kind variables + cls_tv_set = mkVarSet tyvars + mini_env = zipVarEnv tyvars (mkTyVarTys tyvars) + + check_op constrained_class_methods (sel_id, dm) + = addErrCtxt (classOpCtxt sel_id tau) $ do + { checkValidTheta ctxt (tail theta) + -- The 'tail' removes the initial (C a) from the + -- class itself, leaving just the method type + + ; traceTc "class op type" (ppr op_ty <+> ppr tau) + ; checkValidType ctxt tau + + -- Check that the method type mentions a class variable + -- But actually check that the variables *reachable from* + -- the method type include a class variable. + -- Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + ; check_mentions (growThetaTyVars theta (tyVarsOfType tau)) + (ptext (sLit "class method") <+> quotes (ppr sel_id)) + + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () + } + where + ctxt = FunSigCtxt op_name + op_name = idName sel_id + op_ty = idType sel_id + (_,theta1,tau1) = tcSplitSigmaTy op_ty + (_,theta2,tau2) = tcSplitSigmaTy tau1 + (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2) + | otherwise = (theta1, mkPhiTy (tail theta1) tau1) + -- Ugh! The function might have a type like + -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2 + -- With -XConstrainedClassMethods, we want to allow this, even though the inner + -- forall has an (Eq a) constraint. Whereas in general, each constraint + -- in the context of a for-all must mention at least one quantified + -- type variable. What a mess! + + check_at_defs (ATI fam_tc m_dflt_rhs) + = do { check_mentions (mkVarSet fam_tvs) $ + ptext (sLit "associated type") <+> quotes (ppr fam_tc) + ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> + checkValidTyFamEqn (Just (cls, mini_env)) fam_tc + fam_tvs (mkTyVarTys fam_tvs) rhs loc } + where + fam_tvs = tyConTyVars fam_tc + + check_mentions :: TyVarSet -> SDoc -> TcM () + -- Check that the thing (method or associated type) mentions at least + -- one of the class type variables + -- The check is disabled for nullary type classes, + -- since there is no possible ambiguity (Trac #10020) + check_mentions thing_tvs thing_doc + = checkTc (cls_arity == 0 || thing_tvs `intersectsVarSet` cls_tv_set) + (noClassTyVarErr cls thing_doc) + +checkFamFlag :: Name -> TcM () +-- Check that we don't use families without -XTypeFamilies +-- The parser won't even parse them, but I suppose a GHC API +-- client might have a go! +checkFamFlag tc_name + = do { idx_tys <- xoptM Opt_TypeFamilies + ; checkTc idx_tys err_msg } + where + err_msg = hang (ptext (sLit "Illegal family declaration for") <+> quotes (ppr tc_name)) + 2 (ptext (sLit "Use TypeFamilies to allow indexed type families")) + +{- +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check for the methods (in +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes Trac #9415, #9739 + +************************************************************************ +* * + Checking role validity +* * +************************************************************************ +-} + +checkValidRoleAnnots :: RoleAnnots -> TyThing -> TcM () +checkValidRoleAnnots role_annots thing + = case thing of + { ATyCon tc + | isTypeSynonymTyCon tc -> check_no_roles + | isFamilyTyCon tc -> check_no_roles + | isAlgTyCon tc -> check_roles + where + name = tyConName tc + + -- Role annotations are given only on *type* variables, but a tycon stores + -- roles for all variables. So, we drop the kind roles (which are all + -- Nominal, anyway). + tyvars = tyConTyVars tc + roles = tyConRoles tc + (kind_vars, type_vars) = span isKindVar tyvars + type_roles = dropList kind_vars roles + role_annot_decl_maybe = lookupRoleAnnots role_annots name + + check_roles + = whenIsJust role_annot_decl_maybe $ + \decl@(L loc (RoleAnnotDecl _ the_role_annots)) -> + addRoleAnnotCtxt name $ + setSrcSpan loc $ do + { role_annots_ok <- xoptM Opt_RoleAnnotations + ; checkTc role_annots_ok $ needXRoleAnnotations tc + ; checkTc (type_vars `equalLength` the_role_annots) + (wrongNumberOfRoles type_vars decl) + ; _ <- zipWith3M checkRoleAnnot type_vars the_role_annots type_roles + -- Representational or phantom roles for class parameters + -- quickly lead to incoherence. So, we require + -- IncoherentInstances to have them. See #8773. + ; incoherent_roles_ok <- xoptM Opt_IncoherentInstances + ; checkTc ( incoherent_roles_ok + || (not $ isClassTyCon tc) + || (all (== Nominal) type_roles)) + incoherentRoles + + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + + check_no_roles + = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl + ; _ -> return () } + +checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 + = when (r1 /= r2) $ + addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 + +-- This is a double-check on the role inference algorithm. It is only run when +-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in CoreLint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just rhs <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ arg_tys } + -- See Note [Role-checking data constructor arguments] in TcTyDecls + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal)) + role_env = univ_roles `plusVarEnv` ex_roles + + check_ty_roles env role (TyVarTy tv) + = case lookupVarEnv env tv of + Just role' -> unless (role' `ltRole` role || role' == role) $ + report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> + ptext (sLit "cannot have role") <+> ppr role <+> + ptext (sLit "because it was assigned role") <+> ppr role' + Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> + ptext (sLit "missing in environment") + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy tv ty) + = check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error doc + = addErrTc $ vcat [ptext (sLit "Internal error in role inference:"), + doc, + ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] + +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + +mkDefaultMethodIds :: [TyThing] -> [Id] +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds things + = [ mkExportedLocalId VanillaId dm_name (idType sel_id) + | ATyCon tc <- things + , Just cls <- [tyConClass_maybe tc] + , (sel_id, DefMeth dm_name) <- classOpItems cls ] + +{- +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (because they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. +-} + +mkRecSelBinds :: [TyThing] -> HsValBinds Name +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications +mkRecSelBinds tycons + = ValBindsOut [(NonRecursive, b) | b <- binds] sigs + where + (sigs, binds) = unzip rec_sels + rec_sels = map mkRecSelBind [ (tc,fld) + | ATyCon tc <- tycons + , fld <- tyConFields tc ] + +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) +mkRecSelBind (tycon, sel_name) + = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + where + loc = getSrcSpan sel_name + sel_id = mkExportedLocalId rec_details sel_name sel_ty + rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + all_cons = tyConDataCons tycon + cons_w_field = [ con | con <- all_cons + , sel_name `elem` dataConFieldLabels con ] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = dataConFieldType con1 sel_name + data_ty = dataConOrigResTy con1 + data_tvs = tyVarsOfType data_ty + is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) + (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys (varSetElemsKvsFirst $ + data_tvs `extendVarSetList` field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau + + -- Make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind = mkTopFunBind Generated sel_lname alts + where + alts | is_naughty = [mkSimpleMatch [] unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt + mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + (L loc (HsVar field_var)) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = noLoc (HsRecField { hsRecFieldId = sel_lname + , hsRecFieldArg = L loc (VarPat field_var) + , hsRecPun = False }) + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | all dealt_with all_cons = [] + | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] + (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID))) + (L loc (HsLit msg_lit)))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + -- NB: we need to pass type args for the *representation* TyCon + -- to dataConCannotMatch, hence the calculation of inst_tys + -- This matters in data families + -- data instance T Int a where + -- A :: { fld :: Int } -> T Int Bool + -- B :: { fld :: Int } -> T Int Char + dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con + inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1) + + unit_rhs = mkLHsTupleExpr [] + msg_lit = HsStringPrim "" $ unsafeMkByteString $ + occNameString (getOccName sel_name) + +--------------- +tyConFields :: TyCon -> [FieldLabel] +tyConFields tc + | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) + | otherwise = [] + +{- +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a record has a polymorphic field, we pull the foralls out to the front. + data T = MkT { f :: forall a. [a] -> a } +Then f :: forall a. T -> [a] -> a +NOT f :: T -> forall a. [a] -> a + +This is horrid. It's only needed in deeply obscure cases, which I hate. +The only case I know is test tc163, which is worth looking at. It's far +from clear that this test should succeed at all! + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a + +For naughty selectors we make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + T3 :: T Int + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + T3 -> error "T3 does not have field f" + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by appying the eq_spec to the univ_tvs of the data con. + +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a +tcAddTyFamInstCtxt decl + = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) + +tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a +tcAddDataFamInstCtxt decl + = tcAddFamInstCtxt (pprDataFamInstFlavour decl <+> ptext (sLit "instance")) + (unLoc (dfid_tycon decl)) + +tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a +tcAddFamInstCtxt flavour tycon thing_inside + = addErrCtxt ctxt thing_inside + where + ctxt = hsep [ptext (sLit "In the") <+> flavour + <+> ptext (sLit "declaration for"), + quotes (ppr tycon)] + +tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a +tcAddClosedTypeFamilyDeclCtxt tc + = addErrCtxt ctxt + where + ctxt = ptext (sLit "In the equations for closed type family") <+> + quotes (ppr tc) + +resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc +resultTypeMisMatch field_name con1 con2 + = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, + ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma], + nest 2 $ ptext (sLit "but have different result types")] + +fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc +fieldTypeMisMatch field_name con1 con2 + = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, + ptext (sLit "give different types for field"), quotes (ppr field_name)] + +dataConCtxtName :: [Located Name] -> SDoc +dataConCtxtName [con] + = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) +dataConCtxtName con + = ptext (sLit "In the definition of data constructors") <+> interpp'SP con + +dataConCtxt :: Outputable a => a -> SDoc +dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) + +classOpCtxt :: Var -> Type -> SDoc +classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), + nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] + +classArityErr :: Int -> Class -> SDoc +classArityErr n cls + | n == 0 = mkErr "No" "no-parameter" + | otherwise = mkErr "Too many" "multi-parameter" + where + mkErr howMany allowWhat = + vcat [ptext (sLit $ howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (ptext (sLit $ "Use MultiParamTypeClasses to allow " + ++ allowWhat ++ " classes"))] + +classFunDepsErr :: Class -> SDoc +classFunDepsErr cls + = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), + parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))] + +noClassTyVarErr :: Class -> SDoc -> SDoc +noClassTyVarErr clas what + = sep [ptext (sLit "The") <+> what, + ptext (sLit "mentions none of the type or kind variables of the class") <+> + quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] + +recSynErr :: [LTyClDecl Name] -> TcRn () +recSynErr syn_decls + = setSrcSpan (getLoc (head sorted_decls)) $ + addErr (sep [ptext (sLit "Cycle in type synonym declarations:"), + nest 2 (vcat (map ppr_decl sorted_decls))]) + where + sorted_decls = sortLocated syn_decls + ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl + +recClsErr :: [TyCon] -> TcRn () +recClsErr cycles + = addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"), + nest 2 (hsep (intersperse (text "->") (map ppr cycles)))]) + +badDataConTyCon :: DataCon -> Type -> Type -> SDoc +badDataConTyCon data_con res_ty_tmpl actual_res_ty + = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> + ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) + 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) + +badGadtKindCon :: DataCon -> SDoc +badGadtKindCon data_con + = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) + <+> ptext (sLit "cannot be GADT-like in its *kind* arguments")) + 2 (ppr data_con <+> dcolon <+> ppr (dataConUserType data_con)) + +badGadtDecl :: Name -> SDoc +badGadtDecl tc_name + = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) + , nest 2 (parens $ ptext (sLit "Use GADTs to allow GADTs")) ] + +badExistential :: DataCon -> SDoc +badExistential con + = hang (ptext (sLit "Data constructor") <+> quotes (ppr con) <+> + ptext (sLit "has existential type variables, a context, or a specialised result type")) + 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) + , parens $ ptext (sLit "Use ExistentialQuantification or GADTs to allow this") ]) + +badStupidTheta :: Name -> SDoc +badStupidTheta tc_name + = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) + +newtypeConError :: Name -> Int -> SDoc +newtypeConError tycon n + = sep [ptext (sLit "A newtype must have exactly one constructor,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] + +newtypeStrictError :: DataCon -> SDoc +newtypeStrictError con + = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] + +newtypeFieldErr :: DataCon -> Int -> SDoc +newtypeFieldErr con_name n_flds + = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), + nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds] + +badSigTyDecl :: Name -> SDoc +badSigTyDecl tc_name + = vcat [ ptext (sLit "Illegal kind signature") <+> + quotes (ppr tc_name) + , nest 2 (parens $ ptext (sLit "Use KindSignatures to allow kind signatures")) ] + +emptyConDeclsErr :: Name -> SDoc +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), + nest 2 $ ptext (sLit "(EmptyDataDecls permits this)")] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily + where + kindOfFamily | isTypeFamilyTyCon family = text "type family" + | isDataFamilyTyCon family = text "data family" + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr max_args + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr max_args + +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (ptext (sLit "Mismatched type name in type family instance.")) + 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name + , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) + +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch tc fi + = ptext (sLit "Overlapped type family instance equation:") $$ + (pprCoAxBranch tc fi) + +badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot var annot inferred + = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) + 2 (sep [ ptext (sLit "Annotation says"), ppr annot + , ptext (sLit "but role"), ppr inferred + , ptext (sLit "is required") ]) + +wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) + = hang (ptext (sLit "Wrong number of roles listed in role annotation;") $$ + ptext (sLit "Expected") <+> (ppr $ length tyvars) <> comma <+> + ptext (sLit "got") <+> (ppr $ length annots) <> colon) + 2 (ppr d) + +illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM () +illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) + = setErrCtxt [] $ + setSrcSpan loc $ + addErrTc (ptext (sLit "Illegal role annotation for") <+> ppr tycon <> char ';' $$ + ptext (sLit "they are allowed only for datatypes and classes.")) + +needXRoleAnnotations :: TyCon -> SDoc +needXRoleAnnotations tc + = ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$ + ptext (sLit "did you intend to use RoleAnnotations?") + +incoherentRoles :: SDoc +incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") $$ + (text "Use IncoherentInstances to allow this; bad role found") + +addTyThingCtxt :: TyThing -> TcM a -> TcM a +addTyThingCtxt thing + = addErrCtxt ctxt + where + name = getName thing + flav = case thing of + ATyCon tc + | isClassTyCon tc -> ptext (sLit "class") + | isTypeFamilyTyCon tc -> ptext (sLit "type family") + | isDataFamilyTyCon tc -> ptext (sLit "data family") + | isTypeSynonymTyCon tc -> ptext (sLit "type") + | isNewTyCon tc -> ptext (sLit "newtype") + | isDataTyCon tc -> ptext (sLit "data") + + _ -> pprTrace "addTyThingCtxt strange" (ppr thing) + Outputable.empty + + ctxt = hsep [ ptext (sLit "In the"), flav + , ptext (sLit "declaration for"), quotes (ppr name) ] + +addRoleAnnotCtxt :: Name -> TcM a -> TcM a +addRoleAnnotCtxt name + = addErrCtxt $ + text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs new file mode 100644 index 00000000..f7cde08c --- /dev/null +++ b/compiler/typecheck/TcTyDecls.hs @@ -0,0 +1,849 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + + +Analysis functions over data types. Specficially, detecting recursive types. + +This stuff is only used for source-code decls; it's recorded in interface +files for imported data types. +-} + +{-# LANGUAGE CPP #-} + +module TcTyDecls( + calcRecFlags, RecTyInfo(..), + calcSynCycles, calcClassCycles, + RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots + ) where + +#include "HsVersions.h" + +import TypeRep +import HsSyn +import Class +import Type +import Kind +import HscTypes +import TyCon +import DataCon +import Var +import Name +import NameEnv +import VarEnv +import VarSet +import NameSet +import Coercion ( ltRole ) +import Avail +import Digraph +import BasicTypes +import SrcLoc +import Outputable +import UniqSet +import Util +import Maybes +import Data.List + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +import Control.Monad + +{- +************************************************************************ +* * + Cycles in class and type synonym declarations +* * +************************************************************************ + +Checking for class-decl loops is easy, because we don't allow class decls +in interface files. + +We allow type synonyms in hi-boot files, but we *trust* hi-boot files, +so we don't check for loops that involve them. So we only look for synonym +loops in the module being compiled. + +We check for type synonym and class cycles on the *source* code. +Main reasons: + + a) Otherwise we'd need a special function to extract type-synonym tycons + from a type, whereas we already have the free vars pinned on the decl + + b) If we checked for type synonym loops after building the TyCon, we + can't do a hoistForAllTys on the type synonym rhs, (else we fall into + a black hole) which seems unclean. Apart from anything else, it'd mean + that a type-synonym rhs could have for-alls to the right of an arrow, + which means adding new cases to the validity checker + + Indeed, in general, checking for cycles beforehand means we need to + be less careful about black holes through synonym cycles. + +The main disadvantage is that a cycle that goes via a type synonym in an +.hi-boot file can lead the compiler into a loop, because it assumes that cycles +only occur entirely within the source code of the module being compiled. +But hi-boot files are trusted anyway, so this isn't much worse than (say) +a kind error. + +[ NOTE ---------------------------------------------- +If we reverse this decision, this comment came from tcTyDecl1, and should + go back there + -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting, + -- which requires looking through synonyms... and therefore goes into a loop + -- on (erroneously) recursive synonyms. + -- Solution: do not hoist synonyms, because they'll be hoisted soon enough + -- when they are substituted + +We'd also need to add back in this definition + +synonymTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all +-- Return a list of synonym tycons +synonymTyConsOfType ty + = nameEnvElts (go ty) + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyVarTy v) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (ForAllTy _ ty) = go ty + + go_tc tc tys | isTypeSynonymTyCon tc = extendNameEnv (go_s tys) + (tyConName tc) tc + | otherwise = go_s tys + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys +---------------------------------------- END NOTE ] +-} + +mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] +mkSynEdges syn_decls = [ (ldecl, name, nameSetElems fvs) + | ldecl@(L _ (SynDecl { tcdLName = L _ name + , tcdFVs = fvs })) <- syn_decls ] + +calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] +calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges + +{- +Note [Superclass cycle check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't allow cycles via superclasses because it would result in the +type checker looping when it canonicalises a class constraint (superclasses +are added during canonicalisation). More precisely, given a constraint + C ty1 .. tyn +we want to instantiate all of C's superclasses, transitively, and +that set must be finite. So if + class (D b, E b a) => C a b +then when we encounter the constraint + C ty1 ty2 +we'll instantiate the superclasses + (D ty2, E ty2 ty1) +and then *their* superclasses, and so on. This set must be finite! + +It is OK for superclasses to be type synonyms for other classes, so +must "look through" type synonyms. Eg + type X a = C [a] + class X a => C a -- No! Recursive superclass! + +We want definitions such as: + + class C cls a where cls a => a -> a + class C D a => D a where + +to be accepted, even though a naive acyclicity check would reject the +program as having a cycle between D and its superclass. Why? Because +when we instantiate + D ty1 +we get the superclas + C D ty1 +and C has no superclasses, so we have terminated with a finite set. + +More precisely, the rule is this: the superclasses sup_C of a class C +are rejected iff: + + C \elem expand(sup_C) + +Where expand is defined as follows: + +(1) expand(a ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN) + +(2) expand(D ty1 ... tyN) = {D} + \union sup_D[ty1/x1, ..., tyP/xP] + \union expand(ty(P+1)) ... \union expand(tyN) + where (D x1 ... xM) is a class, P = min(M,N) + +(3) expand(T ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN) + where T is not a class + +Eqn (1) is conservative; when there's a type variable at the head, +look in all the argument types. Eqn (2) expands superclasses; the +third component of the union is like Eqn (1). Eqn (3) happens mainly +when the context is a (constraint) tuple, such as (Eq a, Show a). + +Furthermore, expand always looks through type synonyms. +-} + +calcClassCycles :: Class -> [[TyCon]] +calcClassCycles cls + = nubBy eqAsCycle $ + expandTheta (unitUniqSet cls) [classTyCon cls] (classSCTheta cls) [] + where + -- The last TyCon in the cycle is always the same as the first + eqAsCycle xs ys = any (xs ==) (cycles (tail ys)) + cycles xs = take n . map (take n) . tails . cycle $ xs + where n = length xs + + -- No more superclasses to expand ==> no problems with cycles + -- See Note [Superclass cycle check] + expandTheta :: UniqSet Class -- Path of Classes to here in set form + -> [TyCon] -- Path to here + -> ThetaType -- Superclass work list + -> [[TyCon]] -- Input error paths + -> [[TyCon]] -- Final error paths + expandTheta _ _ [] = id + expandTheta seen path (pred:theta) = expandType seen path pred . expandTheta seen path theta + + expandType seen path (TyConApp tc tys) + -- Expand unsaturated classes to their superclass theta if they are yet unseen. + -- If they have already been seen then we have detected an error! + | Just cls <- tyConClass_maybe tc + , let (env, remainder) = papp (classTyVars cls) tys + rest_tys = either (const []) id remainder + = if cls `elementOfUniqSet` seen + then (reverse (classTyCon cls:path):) + . flip (foldr (expandType seen path)) tys + else expandTheta (addOneToUniqSet seen cls) (tc:path) + (substTys (mkTopTvSubst env) (classSCTheta cls)) + . flip (foldr (expandType seen path)) rest_tys + + -- For synonyms, try to expand them: some arguments might be + -- phantoms, after all. We can expand with impunity because at + -- this point the type synonym cycle check has already happened. + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , let (env, remainder) = papp tvs tys + rest_tys = either (const []) id remainder + = expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) + . flip (foldr (expandType seen path)) rest_tys + + -- For non-class, non-synonyms, just check the arguments + | otherwise + = flip (foldr (expandType seen path)) tys + + expandType _ _ (TyVarTy {}) = id + expandType _ _ (LitTy {}) = id + expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2 + expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2 + expandType seen path (ForAllTy _tv t) = expandType seen path t + + papp :: [TyVar] -> [Type] -> ([(TyVar, Type)], Either [TyVar] [Type]) + papp [] tys = ([], Right tys) + papp tvs [] = ([], Left tvs) + papp (tv:tvs) (ty:tys) = ((tv, ty):env, remainder) + where (env, remainder) = papp tvs tys + +{- +************************************************************************ +* * + Deciding which type constructors are recursive +* * +************************************************************************ + +Identification of recursive TyCons +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to +@TyThing@s. + +Identifying a TyCon as recursive serves two purposes + +1. Avoid infinite types. Non-recursive newtypes are treated as +"transparent", like type synonyms, after the type checker. If we did +this for all newtypes, we'd get infinite types. So we figure out for +each newtype whether it is "recursive", and add a coercion if so. In +effect, we are trying to "cut the loops" by identifying a loop-breaker. + +2. Avoid infinite unboxing. This has nothing to do with newtypes. +Suppose we have + data T = MkT Int T + f (MkT x t) = f t +Well, this function diverges, but we don't want the strictness analyser +to diverge. But the strictness analyser will diverge because it looks +deeper and deeper into the structure of T. (I believe there are +examples where the function does something sane, and the strictness +analyser still diverges, but I can't see one now.) + +Now, concerning (1), the FC2 branch currently adds a coercion for ALL +newtypes. I did this as an experiment, to try to expose cases in which +the coercions got in the way of optimisations. If it turns out that we +can indeed always use a coercion, then we don't risk recursive types, +and don't need to figure out what the loop breakers are. + +For newtype *families* though, we will always have a coercion, so they +are always loop breakers! So you can easily adjust the current +algorithm by simply treating all newtype families as loop breakers (and +indeed type families). I think. + + + +For newtypes, we label some as "recursive" such that + + INVARIANT: there is no cycle of non-recursive newtypes + +In any loop, only one newtype need be marked as recursive; it is +a "loop breaker". Labelling more than necessary as recursive is OK, +provided the invariant is maintained. + +A newtype M.T is defined to be "recursive" iff + (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl) + (b) it is declared in a source file, but that source file has a + companion hi-boot file which declares the type + or (c) one can get from T's rhs to T via type + synonyms, or non-recursive newtypes *in M* + e.g. newtype T = MkT (T -> Int) + +(a) is conservative; declarations in hi-boot files are always + made loop breakers. That's why in (b) we can restrict attention + to tycons in M, because any loops through newtypes outside M + will be broken by those newtypes +(b) ensures that a newtype is not treated as a loop breaker in one place +and later as a non-loop-breaker. This matters in GHCi particularly, when +a newtype T might be embedded in many types in the environment, and then +T's source module is compiled. We don't want T's recursiveness to change. + +The "recursive" flag for algebraic data types is irrelevant (never consulted) +for types with more than one constructor. + + +An algebraic data type M.T is "recursive" iff + it has just one constructor, and + (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl) + (b) it is declared in a source file, but that source file has a + companion hi-boot file which declares the type + or (c) one can get from its arg types to T via type synonyms, + or by non-recursive newtypes or non-recursive product types in M + e.g. data T = MkT (T -> Int) Bool +Just like newtype in fact + +A type synonym is recursive if one can get from its +right hand side back to it via type synonyms. (This is +reported as an error.) + +A class is recursive if one can get from its superclasses +back to it. (This is an error too.) + +Hi-boot types +~~~~~~~~~~~~~ +A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs +and will respond True to isAbstractTyCon. The idea is that we treat these as if one +could get from these types to anywhere. So when we see + + module Baz where + import {-# SOURCE #-} Foo( T ) + newtype S = MkS T + +then we mark S as recursive, just in case. What that means is that if we see + + import Baz( S ) + newtype R = MkR S + +then we don't need to look inside S to compute R's recursiveness. Since S is imported +(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file, +and that means that some data type will be marked recursive along the way. So R is +unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary) + +This in turn means that we grovel through fewer interface files when computing +recursiveness, because we need only look at the type decls in the module being +compiled, plus the outer structure of directly-mentioned types. +-} + +data RecTyInfo = RTI { rti_promotable :: Bool + , rti_roles :: Name -> [Role] + , rti_is_rec :: Name -> RecFlag } + +calcRecFlags :: ModDetails -> Bool -- hs-boot file? + -> RoleAnnots -> [TyThing] -> RecTyInfo +-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. +-- Any type constructors in boot_names are automatically considered loop breakers +calcRecFlags boot_details is_boot mrole_env tyclss + = RTI { rti_promotable = is_promotable + , rti_roles = roles + , rti_is_rec = is_rec } + where + rec_tycon_names = mkNameSet (map tyConName all_tycons) + all_tycons = mapMaybe getTyCon tyclss + -- Recursion of newtypes/data types can happen via + -- the class TyCon, so tyclss includes the class tycons + + is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons + + roles = inferRoles is_boot mrole_env all_tycons + + ----------------- Recursion calculation ---------------- + is_rec n | n `elemNameSet` rec_names = Recursive + | otherwise = NonRecursive + + boot_name_set = availsToNameSet (md_exports boot_details) + rec_names = boot_name_set `unionNameSet` + nt_loop_breakers `unionNameSet` + prod_loop_breakers + + + ------------------------------------------------- + -- NOTE + -- These edge-construction loops rely on + -- every loop going via tyclss, the types and classes + -- in the module being compiled. Stuff in interface + -- files should be correctly marked. If not (e.g. a + -- type synonym in a hi-boot file) we can get an infinite + -- loop. We could program round this, but it'd make the code + -- rather less nice, so I'm not going to do that yet. + + single_con_tycons = [ tc | tc <- all_tycons + , not (tyConName tc `elemNameSet` boot_name_set) + -- Remove the boot_name_set because they are + -- going to be loop breakers regardless. + , isSingleton (tyConDataCons tc) ] + -- Both newtypes and data types, with exactly one data constructor + + (new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons + -- NB: we do *not* call isProductTyCon because that checks + -- for vanilla-ness of data constructors; and that depends + -- on empty existential type variables; and that is figured + -- out by tcResultType; which uses tcMatchTy; which uses + -- coreView; which calls coreExpandTyCon_maybe; which uses + -- the recursiveness of the TyCon. Result... a black hole. + -- YUK YUK YUK + + --------------- Newtypes ---------------------- + nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges) + is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers + -- is_rec_nt is a locally-used helper function + + nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] + + mk_nt_edges nt -- Invariant: nt is a newtype + = [ tc | tc <- nameEnvElts (tyConsOfType (new_tc_rhs nt)) + -- tyConsOfType looks through synonyms + , tc `elem` new_tycons ] + -- If not (tc `elem` new_tycons) we know that either it's a local *data* type, + -- or it's imported. Either way, it can't form part of a newtype cycle + + --------------- Product types ---------------------- + prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges) + + prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons] + + mk_prod_edges tc -- Invariant: tc is a product tycon + = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc))) + + mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (nameEnvElts (tyConsOfType ty)) + + mk_prod_edges2 ptc tc + | tc `elem` prod_tycons = [tc] -- Local product + | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype + then [] + else mk_prod_edges1 ptc (new_tc_rhs tc) + -- At this point we know that either it's a local non-product data type, + -- or it's imported. Either way, it can't form part of a cycle + | otherwise = [] + +new_tc_rhs :: TyCon -> Type +new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables + +getTyCon :: TyThing -> Maybe TyCon +getTyCon (ATyCon tc) = Just tc +getTyCon _ = Nothing + +findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] +-- Finds a set of tycons that cut all loops +findLoopBreakers deps + = go [(tc,tc,ds) | (tc,ds) <- deps] + where + go edges = [ name + | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges, + name <- tyConName tc : go edges'] + +{- +************************************************************************ +* * + Promotion calculation +* * +************************************************************************ + +See Note [Checking whether a group is promotable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only want to promote a TyCon if all its data constructors +are promotable; it'd be very odd to promote some but not others. + +But the data constructors may mention this or other TyCons. + +So we treat the recursive uses as all OK (ie promotable) and +do one pass to check that each TyCon is promotable. + +Currently type synonyms are not promotable, though that +could change. +-} + +isPromotableTyCon :: NameSet -> TyCon -> Bool +isPromotableTyCon rec_tycons tc + = isAlgTyCon tc -- Only algebraic; not even synonyms + -- (we could reconsider the latter) + && ok_kind (tyConKind tc) + && case algTyConRhs tc of + DataTyCon { data_cons = cs } -> all ok_con cs + NewTyCon { data_con = c } -> ok_con c + AbstractTyCon {} -> False + DataFamilyTyCon {} -> False + + where + ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res + where -- Checks for * -> ... -> * -> * + (args, res) = splitKindFunTys kind + + -- See Note [Promoted data constructors] in TyCon + ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs + && null eq_spec -- No constraints + && null theta + && all (isPromotableType rec_tycons) orig_arg_tys + where + (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con + + +isPromotableType :: NameSet -> Type -> Bool +-- Must line up with DataCon.promoteType +-- But the function lives here because we must treat the +-- *recursive* tycons as promotable +isPromotableType rec_tcs con_arg_ty + = go con_arg_ty + where + go (TyConApp tc tys) = tys `lengthIs` tyConArity tc + && (tyConName tc `elemNameSet` rec_tcs + || isJust (promotableTyCon_maybe tc)) + && all go tys + go (FunTy arg res) = go arg && go res + go (TyVarTy {}) = True + go _ = False + +{- +************************************************************************ +* * + Role annotations +* * +************************************************************************ +-} + +type RoleAnnots = NameEnv (LRoleAnnotDecl Name) + +extractRoleAnnots :: TyClGroup Name -> RoleAnnots +extractRoleAnnots (TyClGroup { group_roles = roles }) + = mkNameEnv [ (tycon, role_annot) + | role_annot@(L _ (RoleAnnotDecl (L _ tycon) _)) <- roles ] + +emptyRoleAnnots :: RoleAnnots +emptyRoleAnnots = emptyNameEnv + +lookupRoleAnnots :: RoleAnnots -> Name -> Maybe (LRoleAnnotDecl Name) +lookupRoleAnnots = lookupNameEnv + +{- +************************************************************************ +* * + Role inference +* * +************************************************************************ + +Note [Role inference] +~~~~~~~~~~~~~~~~~~~~~ +The role inference algorithm datatype definitions to infer the roles on the +parameters. Although these roles are stored in the tycons, we can perform this +algorithm on the built tycons, as long as we don't peek at an as-yet-unknown +roles field! Ah, the magic of laziness. + +First, we choose appropriate initial roles. For families and classes, roles +(including initial roles) are N. For datatypes, we start with the role in the +role annotation (if any), or otherwise use Phantom. This is done in +initialRoleEnv1. + +The function irGroup then propagates role information until it reaches a +fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a +monad RoleM, which is a combination reader and state monad. In its state are +the current RoleEnv, which gets updated by role propagation, and an update +bit, which we use to know whether or not we've reached the fixpoint. The +environment of RoleM contains the tycon whose parameters we are inferring, and +a VarEnv from parameters to their positions, so we can update the RoleEnv. +Between tycons, this reader information is missing; it is added by +addRoleInferenceInfo. + +There are two kinds of tycons to consider: algebraic ones (excluding classes) +and type synonyms. (Remember, families don't participate -- all their parameters +are N.) An algebraic tycon processes each of its datacons, in turn. Note that +a datacon's universally quantified parameters might be different from the parent +tycon's parameters, so we use the datacon's univ parameters in the mapping from +vars to positions. Note also that we don't want to infer roles for existentials +(they're all at N, too), so we put them in the set of local variables. As an +optimisation, we skip any tycons whose roles are already all Nominal, as there +nowhere else for them to go. For synonyms, we just analyse their right-hand sides. + +irType walks through a type, looking for uses of a variable of interest and +propagating role information. Because anything used under a phantom position +is at phantom and anything used under a nominal position is at nominal, the +irType function can assume that anything it sees is at representational. (The +other possibilities are pruned when they're encountered.) + +The rest of the code is just plumbing. + +How do we know that this algorithm is correct? It should meet the following +specification: + +Let Z be a role context -- a mapping from variables to roles. The following +rules define the property (Z |- t : r), where t is a type and r is a role: + +Z(a) = r' r' <= r +------------------------- RCVar +Z |- a : r + +---------- RCConst +Z |- T : r -- T is a type constructor + +Z |- t1 : r +Z |- t2 : N +-------------- RCApp +Z |- t1 t2 : r + +forall i<=n. (r_i is R or N) implies Z |- t_i : r_i +roles(T) = r_1 .. r_n +---------------------------------------------------- RCDApp +Z |- T t_1 .. t_n : R + +Z, a:N |- t : r +---------------------- RCAll +Z |- forall a:k.t : r + + +We also have the following rules: + +For all datacon_i in type T, where a_1 .. a_n are universally quantified +and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, +then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, +then roles(T) = r_1 .. r_n + +roles(->) = R, R +roles(~#) = N, N + +With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, +called from checkValidTycon. + +Note [Role-checking data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: Eq b => F a -> (a->a) -> T (G a) + +Then we want to check the roles at which 'a' is used +in MkT's type. We want to work on the user-written type, +so we need to take into account + * the arguments: (F a) and (a->a) + * the context: C a b + * the result type: (G a) -- this is in the eq_spec +-} + +type RoleEnv = NameEnv [Role] -- from tycon names to roles + +-- This, and any of the functions it calls, must *not* look at the roles +-- field of a tycon we are inferring roles about! +-- See Note [Role inference] +inferRoles :: Bool -> RoleAnnots -> [TyCon] -> Name -> [Role] +inferRoles is_boot annots tycons + = let role_env = initialRoleEnv is_boot annots tycons + role_env' = irGroup role_env tycons in + \name -> case lookupNameEnv role_env' name of + Just roles -> roles + Nothing -> pprPanic "inferRoles" (ppr name) + +initialRoleEnv :: Bool -> RoleAnnots -> [TyCon] -> RoleEnv +initialRoleEnv is_boot annots = extendNameEnvList emptyNameEnv . + map (initialRoleEnv1 is_boot annots) + +initialRoleEnv1 :: Bool -> RoleAnnots -> TyCon -> (Name, [Role]) +initialRoleEnv1 is_boot annots_env tc + | isFamilyTyCon tc = (name, map (const Nominal) tyvars) + | isAlgTyCon tc = (name, default_roles) + | isTypeSynonymTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + where name = tyConName tc + tyvars = tyConTyVars tc + (kvs, tvs) = span isKindVar tyvars + + -- if the number of annotations in the role annotation decl + -- is wrong, just ignore it. We check this in the validity check. + role_annots + = case lookupNameEnv annots_env name of + Just (L _ (RoleAnnotDecl _ annots)) + | annots `equalLength` tvs -> map unLoc annots + _ -> map (const Nothing) tvs + default_roles = map (const Nominal) kvs ++ + zipWith orElse role_annots (repeat default_role) + + default_role + | isClassTyCon tc = Nominal + | is_boot = Representational + | otherwise = Phantom + +irGroup :: RoleEnv -> [TyCon] -> RoleEnv +irGroup env tcs + = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in + if update + then irGroup env' tcs + else env' + +irTyCon :: TyCon -> RoleM () +irTyCon tc + | isAlgTyCon tc + = do { old_roles <- lookupRoles tc + ; unless (all (== Nominal) old_roles) $ -- also catches data families, + -- which don't want or need role inference + do { whenIsJust (tyConClass_maybe tc) (irClass tc_name) + ; addRoleInferenceInfo tc_name (tyConTyVars tc) $ + mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 + ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }} + + | Just ty <- synTyConRhs_maybe tc + = addRoleInferenceInfo tc_name (tyConTyVars tc) $ + irType emptyVarSet ty + + | otherwise + = return () + + where + tc_name = tyConName tc + +-- any type variable used in an associated type must be Nominal +irClass :: Name -> Class -> RoleM () +irClass tc_name cls + = addRoleInferenceInfo tc_name cls_tvs $ + mapM_ ir_at (classATs cls) + where + cls_tvs = classTyVars cls + cls_tv_set = mkVarSet cls_tvs + + ir_at at_tc + = mapM_ (updateRole Nominal) (varSetElems nvars) + where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set + +-- See Note [Role inference] +irDataCon :: Name -> DataCon -> RoleM () +irDataCon tc_name datacon + = addRoleInferenceInfo tc_name univ_tvs $ + mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ arg_tys) + -- See Note [Role-checking data constructor arguments] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon + ex_var_set = mkVarSet ex_tvs + +irType :: VarSet -> Type -> RoleM () +irType = go + where + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> mark_nominal lcls t2 + go lcls (TyConApp tc tys) + = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (FunTy t1 t2) = go lcls t1 >> go lcls t2 + go lcls (ForAllTy tv ty) = go (extendVarSet lcls tv) ty + go _ (LitTy {}) = return () + + go_app _ Phantom _ = return () -- nothing to do here + go_app lcls Nominal ty = mark_nominal lcls ty -- all vars below here are N + go_app lcls Representational ty = go lcls ty + + mark_nominal lcls ty = let nvars = tyVarsOfType ty `minusVarSet` lcls in + mapM_ (updateRole Nominal) (varSetElems nvars) + +-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps +lookupRolesX :: TyCon -> RoleM [Role] +lookupRolesX tc + = do { roles <- lookupRoles tc + ; return $ roles ++ repeat Nominal } + +-- gets the roles either from the environment or the tycon +lookupRoles :: TyCon -> RoleM [Role] +lookupRoles tc + = do { env <- getRoleEnv + ; case lookupNameEnv env (tyConName tc) of + Just roles -> return roles + Nothing -> return $ tyConRoles tc } + +-- tries to update a role; won't ever update a role "downwards" +updateRole :: Role -> TyVar -> RoleM () +updateRole role tv + = do { var_ns <- getVarNs + ; case lookupVarEnv var_ns tv of + { Nothing -> pprPanic "updateRole" (ppr tv) + ; Just n -> do + { name <- getTyConName + ; updateRoleEnv name n role }}} + +-- the state in the RoleM monad +data RoleInferenceState = RIS { role_env :: RoleEnv + , update :: Bool } + +-- the environment in the RoleM monad +type VarPositions = VarEnv Int +data RoleInferenceInfo = RII { var_ns :: VarPositions + , name :: Name } + +-- See [Role inference] +newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo + -> RoleInferenceState + -> (a, RoleInferenceState) } + +instance Functor RoleM where + fmap = liftM + +instance Applicative RoleM where + pure = return + (<*>) = ap + +instance Monad RoleM where + return x = RM $ \_ state -> (x, state) + a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in + unRM (f a') m_info state' + +runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) +runRoleM env thing = (env', update) + where RIS { role_env = env', update = update } = snd $ unRM thing Nothing state + state = RIS { role_env = env, update = False } + +addRoleInferenceInfo :: Name -> [TyVar] -> RoleM a -> RoleM a +addRoleInferenceInfo name tvs thing + = RM $ \_nothing state -> ASSERT( isNothing _nothing ) + unRM thing (Just info) state + where info = RII { var_ns = mkVarEnv (zip tvs [0..]), name = name } + +getRoleEnv :: RoleM RoleEnv +getRoleEnv = RM $ \_ state@(RIS { role_env = env }) -> (env, state) + +getVarNs :: RoleM VarPositions +getVarNs = RM $ \m_info state -> + case m_info of + Nothing -> panic "getVarNs" + Just (RII { var_ns = var_ns }) -> (var_ns, state) + +getTyConName :: RoleM Name +getTyConName = RM $ \m_info state -> + case m_info of + Nothing -> panic "getTyConName" + Just (RII { name = name }) -> (name, state) + + +updateRoleEnv :: Name -> Int -> Role -> RoleM () +updateRoleEnv name n role + = RM $ \_ state@(RIS { role_env = role_env }) -> ((), + case lookupNameEnv role_env name of + Nothing -> pprPanic "updateRoleEnv" (ppr name) + Just roles -> let (before, old_role : after) = splitAt n roles in + if role `ltRole` old_role + then let roles' = before ++ role : after + role_env' = extendNameEnv role_env name roles' in + RIS { role_env = role_env', update = True } + else state ) diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs new file mode 100644 index 00000000..ad00946f --- /dev/null +++ b/compiler/typecheck/TcType.hs @@ -0,0 +1,1770 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcType]{Types used in the typechecker} + +This module provides the Type interface for front-end parts of the +compiler. These parts + + * treat "source types" as opaque: + newtypes, and predicates are meaningful. + * look through usage types + +The "tc" prefix is for "TypeChecker", because the type checker +is the principal client. +-} + +{-# LANGUAGE CPP #-} + +module TcType ( + -------------------------------- + -- Types + TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, + TcTyVar, TcTyVarSet, TcKind, TcCoVar, + + -- TcLevel + TcLevel(..), topTcLevel, pushTcLevel, + strictlyDeeperThan, sameDepthAs, fskTcLevel, + + -------------------------------- + -- MetaDetails + UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt, + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, + MetaDetails(Flexi, Indirect), MetaInfo(..), + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, isReturnTyVar, + isAmbiguousTyVar, metaTvRef, metaTyVarInfo, + isFlexi, isIndirect, isRuntimeUnkSkol, + isTypeVar, isKindVar, + metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, + isTouchableMetaTyVar, isTouchableOrFmv, + isFloatedTouchableMetaTyVar, + canUnifyWithPolyType, + + -------------------------------- + -- Builders + mkPhiTy, mkSigmaTy, mkTcEqPred, mkTcReprEqPred, mkTcEqPredRole, + + -------------------------------- + -- Splitters + -- These are important because they do not look through newtypes + tcView, + tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, + tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, + tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, + tcGetTyVar_maybe, tcGetTyVar, nextRole, + tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe, + + --------------------------------- + -- Predicates. + -- Again, newtypes are opaque + eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, + pickyEqType, tcEqType, tcEqKind, + isSigmaTy, isRhoTy, isOverloadedTy, + isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, + isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isPredTy, isTyVarClassPred, isTyVarExposed, isTyVarUnderDatatype, + + --------------------------------- + -- Misc type manipulators + deNoteType, occurCheckExpand, OccCheckResult(..), + orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo, + orphNamesOfTypes, orphNamesOfCoCon, + getDFunTyKey, + evVarPred_maybe, evVarPred, + + --------------------------------- + -- Predicate types + mkMinimalBySCs, transSuperClasses, immSuperClasses, + + -- * Finding type instances + tcTyFamInsts, + + -- * Finding "exact" (non-dead) type variables + exactTyVarsOfType, exactTyVarsOfTypes, + + --------------------------------- + -- Foreign import and export + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool + isFFILabelTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool + isFunPtrTy, -- :: Type -> Bool + tcSplitIOType_maybe, -- :: Type -> Maybe Type + + -------------------------------- + -- Rexported from Kind + Kind, typeKind, + unliftedTypeKind, liftedTypeKind, + openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, + isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, + tcIsSubKind, splitKindFunTys, defaultKind, + + -------------------------------- + -- Rexported from Type + Type, PredType, ThetaType, + mkForAllTy, mkForAllTys, + mkFunTy, mkFunTys, zipFunTys, + mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, + + isClassPred, isEqPred, isIPPred, + mkClassPred, + isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, + mkEqPred, + + -- Type substitutions + TvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTvSubst, + mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, + mkTopTvSubst, notElemTvSubst, unionTvSubst, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr, + extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, + Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, + + isUnLiftedType, -- Source types are always lifted + isUnboxedTupleType, -- Ditto + isPrimitiveType, + + tyVarsOfType, tyVarsOfTypes, closeOverKinds, + tcTyVarsOfType, tcTyVarsOfTypes, + + pprKind, pprParendKind, pprSigmaType, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, + pprTheta, pprThetaArrowTy, pprClassPred + + ) where + +#include "HsVersions.h" + +-- friends: +import Kind +import TypeRep +import Class +import Var +import ForeignCall +import VarSet +import Coercion +import Type +import TyCon +import CoAxiom + +-- others: +import DynFlags +import Name -- hiding (varName) + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? +import NameSet +import VarEnv +import PrelNames +import TysWiredIn +import BasicTypes +import Util +import Maybes +import ListSetOps +import Outputable +import FastString +import ErrUtils( Validity(..), isValid ) + +import Data.IORef +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +{- +************************************************************************ +* * +\subsection{Types} +* * +************************************************************************ + +The type checker divides the generic Type world into the +following more structured beasts: + +sigma ::= forall tyvars. phi + -- A sigma type is a qualified type + -- + -- Note that even if 'tyvars' is empty, theta + -- may not be: e.g. (?x::Int) => Int + + -- Note that 'sigma' is in prenex form: + -- all the foralls are at the front. + -- A 'phi' type has no foralls to the right of + -- an arrow + +phi :: theta => rho + +rho ::= sigma -> rho + | tau + +-- A 'tau' type has no quantification anywhere +-- Note that the args of a type constructor must be taus +tau ::= tyvar + | tycon tau_1 .. tau_n + | tau_1 tau_2 + | tau_1 -> tau_2 + +-- In all cases, a (saturated) type synonym application is legal, +-- provided it expands to the required form. +-} + +type TcTyVar = TyVar -- Used only during type inference +type TcCoVar = CoVar -- Used only during type inference; mutable +type TcType = Type -- A TcType can have mutable type variables + -- Invariant on ForAllTy in TcTypes: + -- forall a. T + -- a cannot occur inside a MutTyVar in T; that is, + -- T is "flattened" before quantifying over a + +-- These types do not have boxy type variables in them +type TcPredType = PredType +type TcThetaType = ThetaType +type TcSigmaType = TcType +type TcRhoType = TcType -- Note [TcRhoType] +type TcTauType = TcType +type TcKind = Kind +type TcTyVarSet = TyVarSet + +{- +Note [TcRhoType] +~~~~~~~~~~~~~~~~ +A TcRhoType has no foralls or contexts at the top, or to the right of an arrow + YES (forall a. a->a) -> Int + NO forall a. a -> Int + NO Eq a => a -> a + NO Int -> forall a. a -> Int + + +************************************************************************ +* * +\subsection{TyVarDetails} +* * +************************************************************************ + +TyVarDetails gives extra info about type variables, used during type +checking. It's attached to mutable type variables only. +It's knot-tied back to Var.lhs. There is no reason in principle +why Var.lhs shouldn't actually have the definition, but it "belongs" here. + +Note [Signature skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + f :: forall a. [a] -> Int + f (x::b : xs) = 3 + +Here 'b' is a lexically scoped type variable, but it turns out to be +the same as the skolem 'a'. So we have a special kind of skolem +constant, SigTv, which can unify with other SigTvs. They are used +*only* for pattern type signatures. + +Similarly consider + data T (a:k1) = MkT (S a) + data S (b:k2) = MkS (T b) +When doing kind inference on {S,T} we don't want *skolems* for k1,k2, +because they end up unifying; we want those SigTvs again. + +Note [ReturnTv] +~~~~~~~~~~~~~~~ +We sometimes want to convert a checking algorithm into an inference +algorithm. An easy way to do this is to "check" that a term has a +metavariable as a type. But, we must be careful to allow that metavariable +to unify with *anything*. (Well, anything that doesn't fail an occurs-check.) +This is what ReturnTv means. + +For example, if we have + + (undefined :: (forall a. TF1 a ~ TF2 a => a)) x + +we'll call (tcInfer . tcExpr) on the function expression. tcInfer will +create a ReturnTv to represent the expression's type. We really need this +ReturnTv to become set to (forall a. TF1 a ~ TF2 a => a) despite the fact +that this type mentions type families and is a polytype. + +However, we must also be careful to make sure that the ReturnTvs really +always do get unified with something -- we don't want these floating +around in the solver. So, we check after running the checker to make +sure the ReturnTv is filled. If it's not, we set it to a TauTv. + +We can't ASSERT that no ReturnTvs hit the solver, because they +can if there's, say, a kind error that stops checkTauTvUpdate from +working. This happens in test case typecheck/should_fail/T5570, for +example. + +See also the commentary on #9404. +-} + +-- A TyVarDetails is inside a TyVar +data TcTyVarDetails + = SkolemTv -- A skolem + Bool -- True <=> this skolem type variable can be overlapped + -- when looking up instances + -- See Note [Binding when looking up instances] in InstEnv + + | FlatSkol -- A flatten-skolem. It stands for the TcType, and zonking + TcType -- will replace it by that type. + -- See Note [The flattening story] in TcFlatten + + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi + -- interactive context + + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] + +vanillaSkolemTv, superSkolemTv :: TcTyVarDetails +-- See Note [Binding when looking up instances] in InstEnv +vanillaSkolemTv = SkolemTv False -- Might be instantiated +superSkolemTv = SkolemTv True -- Treat this as a completely distinct type + +----------------------------- +data MetaDetails + = Flexi -- Flexi type variables unify to become Indirects + | Indirect TcType + +instance Outputable MetaDetails where + ppr Flexi = ptext (sLit "Flexi") + ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty + +data MetaInfo + = TauTv Bool -- This MetaTv is an ordinary unification variable + -- A TauTv is always filled in with a tau-type, which + -- never contains any ForAlls. + -- The boolean is true when the meta var originates + -- from a wildcard. + + | ReturnTv -- Can unify with *anything*. Used to convert a + -- type "checking" algorithm into a type inference algorithm. + -- See Note [ReturnTv] + + | SigTv -- A variant of TauTv, except that it should not be + -- unified with a type, only with a type variable + -- SigTvs are only distinguished to improve error messages + -- see Note [Signature skolems] + -- The MetaDetails, if filled in, will + -- always be another SigTv or a SkolemTv + + | FlatMetaTv -- A flatten meta-tyvar + -- It is a meta-tyvar, but it is always untouchable, with level 0 + -- See Note [The flattening story] in TcFlatten + +------------------------------------- +-- UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need to an expression has that type + +data UserTypeCtxt + = FunSigCtxt Name -- Function type signature + -- Also used for types in SPECIALISE pragmas + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | RuleSigCtxt Name -- LHS of a RULE forall + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | ResSigCtxt -- Result type sig + -- f x :: t = .... + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Types in a default declaration + | InstDeclCtxt -- An instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | ThBrackCtxt -- Template Haskell type brackets [t| ... |] + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt -- GHCi command :kind + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: => a -> a + | DataTyCtxt Name -- Theta part of a data decl + -- data => T a = MkT a + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. + + +************************************************************************ +* * + Untoucable type variables +* * +************************************************************************ +-} + +newtype TcLevel = TcLevel Int deriving( Eq ) + -- See Note [TcLevel and untouchable type variables] for what this Int is + +{- +Note [TcLevel and untouchable type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and each Implication + has a level number (of type TcLevel) + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number of an Implication is + STRICTLY GREATER THAN that of its parent + + (MetaTvInv) The level number of a unification variable is + LESS THAN OR EQUAL TO that of its parent + implication + +* A unification variable is *touchable* if its level number + is EQUAL TO that of its immediate parent implication. + +* INVARIANT + (GivenInv) The free variables of the ic_given of an + implication are all untouchable; ie their level + numbers are LESS THAN the ic_tclvl of the implication + + +Note [Skolem escape prevention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only unify touchable unification variables. Because of +(MetaTvInv), there can be no occurrences of the variable further out, +so the unification can't cause the skolems to escape. Example: + data T = forall a. MkT a (a->Int) + f x (MkT v f) = length [v,x] +We decide (x::alpha), and generate an implication like + [1]forall a. (a ~ alpha[0]) +But we must not unify alpha:=a, because the skolem would escape. + +For the cases where we DO want to unify, we rely on floating the +equality. Example (with same T) + g x (MkT v f) = x && True +We decide (x::alpha), and generate an implication like + [1]forall a. (Bool ~ alpha[0]) +We do NOT unify directly, bur rather float out (if the constraint +does not mention 'a') to get + (Bool ~ alpha[0]) /\ [1]forall a.() +and NOW we can unify alpha. + +The same idea of only unifying touchables solves another problem. +Suppose we had + (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) +In this example, beta is touchable inside the implication. The +first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside +the implication where a new constraint + uf ~ beta +emerges. If we (wrongly) spontaneously solved it to get uf := beta, +the whole implication disappears but when we pop out again we are left with +(F Int ~ uf) which will be unified by our final zonking stage and +uf will get unified *once more* to (F Int). +-} + +fskTcLevel :: TcLevel +fskTcLevel = TcLevel 0 -- 0 = Outside the outermost level: + -- flatten skolems + +topTcLevel :: TcLevel +topTcLevel = TcLevel 1 -- 1 = outermost level + +pushTcLevel :: TcLevel -> TcLevel +pushTcLevel (TcLevel us) = TcLevel (us+1) + +strictlyDeeperThan :: TcLevel -> TcLevel -> Bool +strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) + = tv_tclvl > ctxt_tclvl + +sameDepthAs :: TcLevel -> TcLevel -> Bool +sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl + -- So <= would be equivalent + +checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool +-- Checks (MetaTvInv) from Note [TcLevel and untouchable type variables] +checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl >= tv_tclvl + +instance Outputable TcLevel where + ppr (TcLevel us) = ppr us + +{- +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +-- For debugging +pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") +pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") +pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) + = pp_info <> colon <> ppr tclvl + where + pp_info = case info of + ReturnTv -> ptext (sLit "ret") + TauTv True -> ptext (sLit "twc") + TauTv False -> ptext (sLit "tau") + SigTv -> ptext (sLit "sig") + FlatMetaTv -> ptext (sLit "fuv") + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) +pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") +pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) +pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") +pprUserTypeCtxt PatSigCtxt = ptext (sLit "a pattern type signature") +pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") +pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") +pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration") +pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") +pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") +pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") +pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") +pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) + +pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The is either empty or "the ambiguity check for" +pprSigCtxt ctxt extra pp_ty + = sep [ ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon + , nest 2 (pp_sig ctxt) ] + where + pp_sig (FunSigCtxt n) = pp_n_colon n + pp_sig (ConArgCtxt n) = pp_n_colon n + pp_sig (ForSigCtxt n) = pp_n_colon n + pp_sig _ = pp_ty + + pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty + +{- +************************************************************************ +* * + Finding type family instances +* * +************************************************************************ +-} + +-- | Finds outermost type-family applications occuring in a type, +-- after expanding synonyms. +tcTyFamInsts :: Type -> [(TyCon, [Type])] +tcTyFamInsts ty + | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty +tcTyFamInsts (TyVarTy _) = [] +tcTyFamInsts (TyConApp tc tys) + | isTypeFamilyTyCon tc = [(tc, tys)] + | otherwise = concat (map tcTyFamInsts tys) +tcTyFamInsts (LitTy {}) = [] +tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty + +{- +************************************************************************ +* * + The "exact" free variables of a type +* * +************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! +Here's the example that Ralf Laemmel showed me: + foo :: (forall a. C u a -> C u a) -> u + mappend :: Monoid u => u -> u -> u + + bar :: Monoid u => u + bar = foo (\t -> t `mappend` t) +We have to generalise at the arg to f, and we don't +want to capture the constraint (Monad (C u a)) because +it appears to mention a. Pretty silly, but it was useful to him. + +exactTyVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It's also used in the +smart-app checking code --- see TcExpr.tcIdApp + +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. +-} + +exactTyVarsOfType :: Type -> TyVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (LitTy {}) = emptyVarSet + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + +exactTyVarsOfTypes :: [Type] -> TyVarSet +exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType + +{- +************************************************************************ +* * + Predicates +* * +************************************************************************ +-} + +isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool +isTouchableOrFmv ctxt_tclvl tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } + -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, + ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) + case info of + FlatMetaTv -> True + _ -> tv_tclvl `sameDepthAs` ctxt_tclvl + _ -> False + +isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_tclvl tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_tclvl } + -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, + ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) + tv_tclvl `sameDepthAs` ctxt_tclvl + _ -> False + +isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isFloatedTouchableMetaTyVar ctxt_tclvl tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl + _ -> False + +isImmutableTyVar :: TyVar -> Bool +isImmutableTyVar tv + | isTcTyVar tv = isSkolemTyVar tv + | otherwise = True + +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, + isMetaTyVar, isAmbiguousTyVar, + isFmvTyVar, isFskTyVar, isFlattenTyVar, isReturnTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable that can be filled in + -- with a type constructor application; in particular, + -- not a SigTv + = ASSERT( isTcTyVar tv) + case tcTyVarDetails tv of + MetaTv { mtv_info = SigTv } -> False + _ -> True + +isFmvTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +-- | True of both given and wanted flatten-skolems (fak and usk) +isFlattenTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + FlatSkol {} -> True + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +-- | True of FlatSkol skolems only +isFskTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + FlatSkol {} -> True + _ -> False + +isSkolemTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> False + _other -> True + +isOverlappableTyVar tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + SkolemTv overlappable -> overlappable + _ -> False + +isMetaTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> True + _ -> False + +isReturnTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = ReturnTv } -> True + _ -> False + +-- isAmbiguousTyVar is used only when reporting type errors +-- It picks out variables that are unbound, namely meta +-- type variables and the RuntimUnk variables created by +-- RtClosureInspect.zonkRTTIType. These are "ambiguous" in +-- the sense that they stand for an as-yet-unknown type +isAmbiguousTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> True + RuntimeUnk {} -> True + _ -> False + +isMetaTyVarTy :: TcType -> Bool +isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv +isMetaTyVarTy _ = False + +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +metaTyVarTcLevel :: TcTyVar -> TcLevel +metaTyVarTcLevel tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> tclvl + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel +metaTyVarTcLevel_maybe tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> Just tclvl + _ -> Nothing + +setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar +setMetaTyVarTcLevel tv tclvl + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +isSigTyVar :: Var -> Bool +isSigTyVar tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = SigTv } -> True + _ -> False + +metaTvRef :: TyVar -> IORef MetaDetails +metaTvRef tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTvRef" (ppr tv) + +isFlexi, isIndirect :: MetaDetails -> Bool +isFlexi Flexi = True +isFlexi _ = False + +isIndirect (Indirect _) = True +isIndirect _ = False + +isRuntimeUnkSkol :: TyVar -> Bool +-- Called only in TcErrors; see Note [Runtime skolems] there +isRuntimeUnkSkol x + | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True + | otherwise = False + +{- +************************************************************************ +* * +\subsection{Tau, sigma and rho} +* * +************************************************************************ +-} + +mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) + +mkPhiTy :: [PredType] -> Type -> Type +mkPhiTy theta ty = foldr mkFunTy ty theta + +mkTcEqPred :: TcType -> TcType -> Type +-- During type checking we build equalities between +-- type variables with OpenKind or ArgKind. Ultimately +-- they will all settle, but we want the equality predicate +-- itself to have kind '*'. I think. +-- +-- But for now we call mkTyConApp, not mkEqPred, because the invariants +-- of the latter might not be satisfied during type checking. +-- Notably when we form an equalty (a : OpenKind) ~ (Int : *) +-- +-- But this is horribly delicate: what about type variables +-- that turn out to be bound to Int#? +mkTcEqPred ty1 ty2 + = mkTyConApp eqTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +-- | Make a representational equality predicate +mkTcReprEqPred :: TcType -> TcType -> Type +mkTcReprEqPred ty1 ty2 + = mkTyConApp coercibleTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +-- | Make an equality predicate at a given role. The role must not be Phantom. +mkTcEqPredRole :: Role -> TcType -> TcType -> Type +mkTcEqPredRole Nominal = mkTcEqPred +mkTcEqPredRole Representational = mkTcReprEqPred +mkTcEqPredRole Phantom = panic "mkTcEqPredRole Phantom" + +-- @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. + +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- tcView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (ForAllTy {}) = False + +isTauTyCon :: TyCon -> Bool +-- Returns False for type synonyms whose expansion is a polytype +isTauTyCon tc + | Just (_, rhs) <- synTyConDefn_maybe tc = isTauTy rhs + | otherwise = True + +--------------- +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (FunTy _ _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm + +{- +************************************************************************ +* * +\subsection{Expanding and splitting} +* * +************************************************************************ + +These tcSplit functions are like their non-Tc analogues, but + *) they do not look through newtypes + +However, they are non-monadic and do not follow through mutable type +variables. It's up to you to make sure this doesn't matter. +-} + +tcSplitForAllTys :: Type -> ([TyVar], Type) +tcSplitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +tcIsForAllTy :: Type -> Bool +tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False + +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty + | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy arg res) + | isPredTy arg = Just (arg, res) +tcSplitPredFunTy_maybe _ + = Nothing + +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) + +tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTy ty = case tcSplitForAllTys ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + +----------------------- +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) +-- Looks for a *non-trivial* quantified type, under zero or more function arrows +-- By "non-trivial" we mean either tyvars or constraints are non-empty + +tcDeepSplitSigmaTy_maybe ty + | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing + +----------------------- +tcTyConAppTyCon :: Type -> TyCon +tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) + +tcTyConAppArgs :: Type -> [Type] +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) + +tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) + -- Newtypes are opaque, so they may be split + -- However, predicates are not treated + -- as tycon applications by the type checker +tcSplitTyConApp_maybe _ = Nothing + +----------------------- +tcSplitFunTys :: Type -> ([Type], Type) +tcSplitFunTys ty = case tcSplitFunTy_maybe ty of + Nothing -> ([], ty) + Just (arg,res) -> (arg:args, res') + where + (args,res') = tcSplitFunTys res + +tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) +tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' +tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the typeKind guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () + +tcSplitFunTysN + :: TcRhoType + -> Arity -- N: Number of desired args + -> ([TcSigmaType], -- Arg types (N or fewer) + TcSigmaType) -- The rest of the type + +tcSplitFunTysN ty n_args + | n_args == 0 + = ([], ty) + | Just (arg,res) <- tcSplitFunTy_maybe ty + = case tcSplitFunTysN res (n_args - 1) of + (args, res) -> (arg:args, res) + | otherwise + = ([], ty) + +tcSplitFunTy :: Type -> (Type, Type) +tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Type +tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type +tcFunResultTy ty = snd (tcSplitFunTy ty) + +----------------------- +tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) +tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty + +tcSplitAppTy :: Type -> (Type, Type) +tcSplitAppTy ty = case tcSplitAppTy_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitAppTy" (pprType ty) + +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + +----------------------- +tcGetTyVar_maybe :: Type -> Maybe TyVar +tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe _ = Nothing + +tcGetTyVar :: String -> Type -> TyVar +tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) + +tcIsTyVarTy :: Type -> Bool +tcIsTyVarTy ty = isJust (tcGetTyVar_maybe ty) + +----------------------- +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m +-- +-- Also NB splitFunTys, not tcSplitFunTys; +-- the latter specifically stops at PredTy arguments, +-- and we don't want to do that here +tcSplitDFunTy ty + = case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, theta, clas, tys) }}} + +tcSplitDFunHead :: Type -> (Class, [Type]) +tcSplitDFunHead = getClassPredTys + +tcInstHeadTyNotSynonym :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must not be type synonyms, but everywhere else type synonyms +-- are transparent, so we need a special function here +tcInstHeadTyNotSynonym ty + = case ty of + TyConApp tc _ -> not (isTypeSynonymTyCon tc) + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- These must be a constructor applied to type variable arguments. +-- But we allow kind instantiations. +tcInstHeadTyAppAllTyVars ty + | Just ty' <- tcView ty -- Look through synonyms + = tcInstHeadTyAppAllTyVars ty' + | otherwise + = case ty of + TyConApp _ tys -> ok (filter (not . isKind) tys) -- avoid kinds + FunTy arg res -> ok [arg, res] + _ -> False + where + -- Check that all the types are type variables, + -- and that each is distinct + ok tys = equalLength tvs tys && hasNoDups tvs + where + tvs = mapMaybe get_tv tys + + get_tv (TyVarTy tv) = Just tv -- through synonyms + get_tv _ = Nothing + +tcEqKind :: TcKind -> TcKind -> Bool +tcEqKind = tcEqType + +tcEqType :: TcType -> TcType -> Bool +-- tcEqType is a proper, sensible type-equality function, that does +-- just what you'd expect The function Type.eqType (currently) has a +-- grotesque hack that makes OpenKind = *, and that is NOT what we +-- want in the type checker! Otherwise, for example, TcCanonical.reOrient +-- thinks the LHS and RHS have the same kinds, when they don't, and +-- fails to re-orient. That in turn caused Trac #8553. + +tcEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env t1 t2 | Just t1' <- tcView t1 = go env t1' t2 + | Just t2' <- tcView t2 = go env t1 t2' + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2) + && go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False + +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +pickyEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2) + && go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False + +{- +Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occurCheckExpand b (F Int b) = Just [Int] +but + occurCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occurCheckExpand b (F (G b)) = F Char +even though we could also expand F to get rid of b. + +See also Note [occurCheckExpand] in TcCanonical +-} + +data OccCheckResult a + = OC_OK a + | OC_Forall + | OC_NonTyVar + | OC_Occurs + +instance Functor OccCheckResult where + fmap = liftM + +instance Applicative OccCheckResult where + pure = return + (<*>) = ap + +instance Monad OccCheckResult where + return x = OC_OK x + OC_OK x >>= k = k x + OC_Forall >>= _ = OC_Forall + OC_NonTyVar >>= _ = OC_NonTyVar + OC_Occurs >>= _ = OC_Occurs + +occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type +-- See Note [Occurs check expansion] +-- Check whether +-- a) the given variable occurs in the given type. +-- b) there is a forall in the type (unless we have -XImpredicativeTypes +-- or it's a ReturnTv +-- c) if it's a SigTv, ty should be a tyvar +-- +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. + +occurCheckExpand dflags tv ty + | MetaTv { mtv_info = SigTv } <- details + = go_sig_tv ty + | fast_check ty = return ty + | otherwise = go ty + where + details = ASSERT2( isTcTyVar tv, ppr tv ) tcTyVarDetails tv + + impredicative = canUnifyWithPolyType dflags details (tyVarKind tv) + + -- Check 'ty' is a tyvar, or can be expanded into one + go_sig_tv ty@(TyVarTy {}) = OC_OK ty + go_sig_tv ty | Just ty' <- tcView ty = go_sig_tv ty' + go_sig_tv _ = OC_NonTyVar + + -- True => fine + fast_check (LitTy {}) = True + fast_check (TyVarTy tv') = tv /= tv' + fast_check (TyConApp _ tys) = all fast_check tys + fast_check (FunTy arg res) = fast_check arg && fast_check res + fast_check (AppTy fun arg) = fast_check fun && fast_check arg + fast_check (ForAllTy tv' ty) = impredicative + && fast_check (tyVarKind tv') + && (tv == tv' || fast_check ty) + + go t@(TyVarTy tv') | tv == tv' = OC_Occurs + | otherwise = return t + go ty@(LitTy {}) = return ty + go (AppTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkAppTy ty1' ty2') } + go (FunTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkFunTy ty1' ty2') } + go ty@(ForAllTy tv' body_ty) + | not impredicative = OC_Forall + | not (fast_check (tyVarKind tv')) = OC_Occurs + -- Can't expand away the kinds unless we create + -- fresh variables which we don't want to do at this point. + -- In principle fast_check might fail because of a for-all + -- but we don't yet have poly-kinded tyvars so I'm not + -- going to worry about that now + | tv == tv' = return ty + | otherwise = do { body' <- go body_ty + ; return (ForAllTy tv' body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go ty@(TyConApp tc tys) + = case do { tys <- mapM go tys; return (mkTyConApp tc tys) } of + OC_OK ty -> return ty -- First try to eliminate the tyvar from the args + bad | Just ty' <- tcView ty -> go ty' + | otherwise -> bad + -- Failing that, try to expand a synonym + +canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> TcKind -> Bool +canUnifyWithPolyType dflags details kind + = case details of + MetaTv { mtv_info = ReturnTv } -> True -- See Note [ReturnTv] + MetaTv { mtv_info = SigTv } -> False + MetaTv { mtv_info = TauTv _ } -> xopt Opt_ImpredicativeTypes dflags + || isOpenTypeKind kind + -- Note [OpenTypeKind accepts foralls] + _other -> True + -- We can have non-meta tyvars in given constraints + +{- +Note [OpenTypeKind accepts foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a common paradigm: + foo :: (forall a. a -> a) -> Int + foo = error "urk" +To make this work we need to instantiate 'error' with a polytype. +A similar case is + bar :: Bool -> (forall a. a->a) -> Int + bar True = \x. (x 3) + bar False = error "urk" +Here we need to instantiate 'error' with a polytype. + +But 'error' has an OpenTypeKind type variable, precisely so that +we can instantiate it with Int#. So we also allow such type variables +to be instantiated with foralls. It's a bit of a hack, but seems +straightforward. + +************************************************************************ +* * +\subsection{Predicate types} +* * +************************************************************************ + +Deconstructors and tests on predicate types +-} + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred ty = case getClassPredTys_maybe ty of + Just (_, tys) -> all isTyVarTy tys + _ -> False + +evVarPred_maybe :: EvVar -> Maybe PredType +evVarPred_maybe v = if isPredTy ty then Just ty else Nothing + where ty = varType v + +evVarPred :: EvVar -> PredType +evVarPred var + | debugIsOn + = case evVarPred_maybe var of + Just pred -> pred + Nothing -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var)) + | otherwise + = varType var + +-- Superclasses + +mkMinimalBySCs :: [PredType] -> [PredType] +-- Remove predicates that can be deduced from others by superclasses +mkMinimalBySCs ptys = [ ploc | ploc <- ptys + , ploc `not_in_preds` rec_scs ] + where + rec_scs = concatMap trans_super_classes ptys + not_in_preds p ps = not (any (eqPred p) ps) + + trans_super_classes pred -- Superclasses of pred, excluding pred itself + = case classifyPredType pred of + ClassPred cls tys -> transSuperClasses cls tys + TuplePred ts -> concatMap trans_super_classes ts + _ -> [] + +transSuperClasses :: Class -> [Type] -> [PredType] +transSuperClasses cls tys -- Superclasses of (cls tys), + -- excluding (cls tys) itself + = concatMap trans_sc (immSuperClasses cls tys) + where + trans_sc :: PredType -> [PredType] + -- (trans_sc p) returns (p : p's superclasses) + trans_sc p = case classifyPredType p of + ClassPred cls tys -> p : transSuperClasses cls tys + TuplePred ps -> concatMap trans_sc ps + _ -> [p] + +immSuperClasses :: Class -> [Type] -> [PredType] +immSuperClasses cls tys + = substTheta (zipTopTvSubst tyvars tys) sc_theta + where + (tyvars,sc_theta,_,_) = classBigSig cls + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ +-} + +isSigmaTy :: TcType -> Bool +-- isSigmaTy returns true of any qualified type. It doesn't +-- *necessarily* have any foralls. E.g +-- f :: (?x::Int) => Int -> Int +isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' +isSigmaTy (ForAllTy _ _) = True +isSigmaTy (FunTy a _) = isPredTy a +isSigmaTy _ = False + +isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] +isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' +isRhoTy (ForAllTy {}) = False +isRhoTy (FunTy a r) = not (isPredTy a) && isRhoTy r +isRhoTy _ = True + +isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindLocalMethods +isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False + +isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, + isUnitTy, isCharTy, isAnyTy :: Type -> Bool +isFloatTy = is_tc floatTyConKey +isDoubleTy = is_tc doubleTyConKey +isIntegerTy = is_tc integerTyConKey +isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey +isBoolTy = is_tc boolTyConKey +isUnitTy = is_tc unitTyConKey +isCharTy = is_tc charTyConKey +isAnyTy = is_tc anyTyConKey + +-- | Does a type represent a floating-point number? +isFloatingTy :: Type -> Bool +isFloatingTy ty = isFloatTy ty || isDoubleTy ty + +-- | Is a type 'String'? +isStringTy :: Type -> Bool +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + _ -> False + +is_tc :: Unique -> Type -> Bool +-- Newtypes are opaque to this +is_tc uniq ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> uniq == getUnique tc + Nothing -> False + +-- | Does the given tyvar appear in the given type outside of any +-- non-newtypes? Assume we're looking for @a@. Says "yes" for +-- @a@, @N a@, @b a@, @a b@, @b (N a)@. Says "no" for +-- @[a]@, @Maybe a@, @T a@, where @N@ is a newtype and @T@ is a datatype. +isTyVarExposed :: TcTyVar -> TcType -> Bool +isTyVarExposed tv (TyVarTy tv') = tv == tv' +isTyVarExposed tv (TyConApp tc tys) + | isNewTyCon tc = any (isTyVarExposed tv) tys + | otherwise = False +isTyVarExposed _ (LitTy {}) = False +isTyVarExposed _ (FunTy {}) = False +isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun + || isTyVarExposed tv arg +isTyVarExposed _ (ForAllTy {}) = False + +-- | Does the given tyvar appear under a type generative w.r.t. +-- representational equality? See Note [Occurs check error] in +-- TcCanonical for the motivation for this function. +isTyVarUnderDatatype :: TcTyVar -> TcType -> Bool +isTyVarUnderDatatype tv = go False + where + go under_dt ty | Just ty' <- tcView ty = go under_dt ty' + go under_dt (TyVarTy tv') = under_dt && (tv == tv') + go under_dt (TyConApp tc tys) = let under_dt' = under_dt || + isGenerativeTyCon tc + Representational + in any (go under_dt') tys + go _ (LitTy {}) = False + go _ (FunTy arg res) = go True arg || go True res + go under_dt (AppTy fun arg) = go under_dt fun || go under_dt arg + go under_dt (ForAllTy tv' inner_ty) + | tv' == tv = False + | otherwise = go under_dt inner_ty + +{- +************************************************************************ +* * +\subsection{Misc} +* * +************************************************************************ +-} + +deNoteType :: Type -> Type +-- Remove all *outermost* type synonyms and other notes +deNoteType ty | Just ty' <- tcView ty = deNoteType ty' +deNoteType ty = ty + +tcTyVarsOfType :: Type -> TcTyVarSet +-- Just the *TcTyVars* free in the type +-- (Types.tyVarsOfTypes finds all free TyVars) +tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv + else emptyVarSet +tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfType (LitTy {}) = emptyVarSet +tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res +tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg +tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar + -- We do sometimes quantify over skolem TcTyVars + +tcTyVarsOfTypes :: [Type] -> TyVarSet +tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType + +{- +Find the free tycons and classes of a type. This is used in the front +end of the compiler. +-} + +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' + -- Look through type synonyms (Trac #4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon + `unionNameSet` orphNamesOfTypes tys +orphNamesOfType (FunTy arg res) = orphNamesOfTyCon funTyCon -- NB! See Trac #8535 + `unionNameSet` orphNamesOfType arg + `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg +orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty + +orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet +orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes = orphNamesOfThings orphNamesOfType + +orphNamesOfDFunHead :: Type -> NameSet +-- Find the free type constructors and classes +-- of the head of the dfun instance type +-- The 'dfun_head_type' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfDFunHead dfun_ty + = case tcSplitSigmaTy dfun_ty of + (_, _, head_ty) -> orphNamesOfType head_ty + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl _ ty) = orphNamesOfType ty +orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (UnivCo _ _ ty1 ty2) = orphNamesOfType ty1 `unionNameSet` orphNamesOfType ty2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSet` orphNamesOfType ty +orphNamesOfCo (SubCo co) = orphNamesOfCo co +orphNamesOfCo (AxiomRuleCo _ ts cs) = orphNamesOfTypes ts `unionNameSet` + orphNamesOfCos cs + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = orphNamesOfThings orphNamesOfCo + +orphNamesOfCoCon :: CoAxiom br -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches + +orphNamesOfCoAxBranches :: BranchList CoAxBranch br -> NameSet +orphNamesOfCoAxBranches = brListFoldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet + +orphNamesOfCoAxBranch :: CoAxBranch -> NameSet +orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) + = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs + +{- +************************************************************************ +* * +\subsection[TysWiredIn-ext-type]{External types} +* * +************************************************************************ + +The compiler's foreign function interface supports the passing of a +restricted set of types as arguments and results (the restricting factor +being the ) +-} + +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) +-- (tcSplitIOType_maybe t) returns Just (IO,t',co) +-- if co : t ~ IO t' +-- returns Nothing otherwise +tcSplitIOType_maybe ty + = case tcSplitTyConApp_maybe ty of + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey -> + Just (io_tycon, io_res_ty) + _ -> + Nothing + +isFFITy :: Type -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty empty) + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty empty + +isFFIExternalTy :: Type -> Validity +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty empty + +isFFIImportResultTy :: DynFlags -> Type -> Validity +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty empty + +isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty empty + +isFFIDynTy :: Type -> Type -> Validity +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma + , ptext (sLit " Actual:") <+> ppr ty ]) + +isFFILabelTy :: Type -> Validity +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty extra + where + ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + extra = ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or the well-known type +-- Any, which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty empty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity +-- Checks for valid result type for a 'foreign import prim' +-- Currently it must be an unlifted type, including unboxed tuples. +isFFIPrimResultTy dflags ty + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty empty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty = isValid (checkRepTyCon (`hasKey` funPtrTyConKey) ty empty) + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon :: (TyCon -> Bool) -> Type -> SDoc -> Validity +checkRepTyCon check_tc ty extra + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) + | check_tc tc -> IsValid + | otherwise -> NotValid (msg $$ extra) + Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type") $$ extra) + where + msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call") + mk_nt_reason tc tys + | null tys = ptext (sLit "because its data construtor is not in scope") + | otherwise = ptext (sLit "because the data construtor for") + <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") + nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Bool +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Bool +legalFIResultTyCon dflags tc + | tc == unitTyCon = True + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Bool +legalFEResultTyCon tc + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +legalFFITyCon :: TyCon -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +legalFFITyCon tc + | isUnLiftedTyCon tc = True + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc + +marshalableTyCon :: DynFlags -> TyCon -> Bool +marshalableTyCon dflags tc + | (xopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + && case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + _ -> True) + = True + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Bool +boxedMarshalableTyCon tc + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] + = True + + | otherwise = False + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + | xopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + = True + | otherwise + = False + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple result types '... -> (# , , #)' +legalFIPrimResultTyCon dflags tc + | xopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && (isUnboxedTupleTyCon tc + || case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + _ -> True) + = True + | otherwise + = False + +{- +Note [Marshalling VoidRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it +-} diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot new file mode 100644 index 00000000..656c4242 --- /dev/null +++ b/compiler/typecheck/TcType.hs-boot @@ -0,0 +1,7 @@ +module TcType where +import Outputable( SDoc ) + +data MetaDetails + +data TcTyVarDetails +pprTcTyVarDetails :: TcTyVarDetails -> SDoc diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs new file mode 100644 index 00000000..9815958d --- /dev/null +++ b/compiler/typecheck/TcTypeNats.hs @@ -0,0 +1,691 @@ +module TcTypeNats + ( typeNatTyCons + , typeNatCoAxiomRules + , BuiltInSynFamily(..) + + , typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + ) where + +import Type +import Pair +import TcType ( TcType, tcEqType ) +import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon, TyConParent(..) ) +import Coercion ( Role(..) ) +import TcRnTypes ( Xi ) +import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) ) +import Name ( Name, BuiltInSyntax(..) ) +import TysWiredIn ( typeNatKind, typeSymbolKind + , mkWiredInTyConName + , promotedBoolTyCon + , promotedFalseDataCon, promotedTrueDataCon + , promotedOrderingTyCon + , promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + ) +import TysPrim ( tyVarList, mkArrowKinds ) +import PrelNames ( gHC_TYPELITS + , typeNatAddTyFamNameKey + , typeNatMulTyFamNameKey + , typeNatExpTyFamNameKey + , typeNatLeqTyFamNameKey + , typeNatSubTyFamNameKey + , typeNatCmpTyFamNameKey + , typeSymbolCmpTyFamNameKey + ) +import FastString ( FastString, fsLit ) +import qualified Data.Map as Map +import Data.Maybe ( isJust ) + +{------------------------------------------------------------------------------- +Built-in type constructors for functions on type-lelve nats +-} + +typeNatTyCons :: [TyCon] +typeNatTyCons = + [ typeNatAddTyCon + , typeNatMulTyCon + , typeNatExpTyCon + , typeNatLeqTyCon + , typeNatSubTyCon + , typeNatCmpTyCon + , typeSymbolCmpTyCon + ] + +typeNatAddTyCon :: TyCon +typeNatAddTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamAdd + , sfInteractTop = interactTopAdd + , sfInteractInert = interactInertAdd + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon + +typeNatSubTyCon :: TyCon +typeNatSubTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamSub + , sfInteractTop = interactTopSub + , sfInteractInert = interactInertSub + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "-") + typeNatSubTyFamNameKey typeNatSubTyCon + +typeNatMulTyCon :: TyCon +typeNatMulTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamMul + , sfInteractTop = interactTopMul + , sfInteractInert = interactInertMul + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon + +typeNatExpTyCon :: TyCon +typeNatExpTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = matchFamExp + , sfInteractTop = interactTopExp + , sfInteractInert = interactInertExp + } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "^") + typeNatExpTyFamNameKey typeNatExpTyCon + +typeNatLeqTyCon :: TyCon +typeNatLeqTyCon = + mkFamilyTyCon name + (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind) + (take 2 $ tyVarList typeNatKind) + (BuiltInSynFamTyCon ops) + NoParentTyCon + + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "<=?") + typeNatLeqTyFamNameKey typeNatLeqTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamLeq + , sfInteractTop = interactTopLeq + , sfInteractInert = interactInertLeq + } + +typeNatCmpTyCon :: TyCon +typeNatCmpTyCon = + mkFamilyTyCon name + (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind) + (take 2 $ tyVarList typeNatKind) + (BuiltInSynFamTyCon ops) + NoParentTyCon + + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpNat") + typeNatCmpTyFamNameKey typeNatCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpNat + , sfInteractTop = interactTopCmpNat + , sfInteractInert = \_ _ _ _ -> [] + } + +typeSymbolCmpTyCon :: TyCon +typeSymbolCmpTyCon = + mkFamilyTyCon name + (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind) + (take 2 $ tyVarList typeSymbolKind) + (BuiltInSynFamTyCon ops) + NoParentTyCon + + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") + typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpSymbol + , sfInteractTop = interactTopCmpSymbol + , sfInteractInert = \_ _ _ _ -> [] + } + + + + + +-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat +mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon +mkTypeNatFunTyCon2 op tcb = + mkFamilyTyCon op + (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind) + (take 2 $ tyVarList typeNatKind) + (BuiltInSynFamTyCon tcb) + NoParentTyCon + + + + +{------------------------------------------------------------------------------- +Built-in rules axioms +-------------------------------------------------------------------------------} + +-- If you add additional rules, please remember to add them to +-- `typeNatCoAxiomRules` also. +axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + , axSub0R + :: CoAxiomRule + +axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ + \x y -> Just $ num (x + y) + +axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ + \x y -> Just $ num (x * y) + +axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ + \x y -> Just $ num (x ^ y) + +axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ + \x y -> Just $ bool (x <= y) + +axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon + $ \x y -> Just $ ordering (compare x y) + +axCmpSymbolDef = + CoAxiomRule + { coaxrName = fsLit "CmpSymbolDef" + , coaxrTypeArity = 2 + , coaxrAsmpRoles = [] + , coaxrRole = Nominal + , coaxrProves = \ts cs -> + case (ts,cs) of + ([s,t],[]) -> + do x <- isStrLitTy s + y <- isStrLitTy t + return (mkTyConApp typeSymbolCmpTyCon [s,t] === + ordering (compare x y)) + _ -> Nothing + } + +axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ + \x y -> fmap num (minus x y) + +axAdd0L = mkAxiom1 "Add0L" $ \t -> (num 0 .+. t) === t +axAdd0R = mkAxiom1 "Add0R" $ \t -> (t .+. num 0) === t +axSub0R = mkAxiom1 "Sub0R" $ \t -> (t .-. num 0) === t +axMul0L = mkAxiom1 "Mul0L" $ \t -> (num 0 .*. t) === num 0 +axMul0R = mkAxiom1 "Mul0R" $ \t -> (t .*. num 0) === num 0 +axMul1L = mkAxiom1 "Mul1L" $ \t -> (num 1 .*. t) === t +axMul1R = mkAxiom1 "Mul1R" $ \t -> (t .*. num 1) === t +axExp1L = mkAxiom1 "Exp1L" $ \t -> (num 1 .^. t) === num 1 +axExp0R = mkAxiom1 "Exp0R" $ \t -> (t .^. num 0) === num 1 +axExp1R = mkAxiom1 "Exp1R" $ \t -> (t .^. num 1) === t +axLeqRefl = mkAxiom1 "LeqRefl" $ \t -> (t <== t) === bool True +axCmpNatRefl = mkAxiom1 "CmpNatRefl" + $ \t -> (cmpNat t t) === ordering EQ +axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" + $ \t -> (cmpSymbol t t) === ordering EQ +axLeq0L = mkAxiom1 "Leq0L" $ \t -> (num 0 <== t) === bool True + +typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule +typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) + [ axAddDef + , axMulDef + , axExpDef + , axLeqDef + , axCmpNatDef + , axCmpSymbolDef + , axAdd0L + , axAdd0R + , axMul0L + , axMul0R + , axMul1L + , axMul1R + , axExp1L + , axExp0R + , axExp1R + , axLeqRefl + , axCmpNatRefl + , axCmpSymbolRefl + , axLeq0L + , axSubDef + ] + + + +{------------------------------------------------------------------------------- +Various utilities for making axioms and types +-------------------------------------------------------------------------------} + +(.+.) :: Type -> Type -> Type +s .+. t = mkTyConApp typeNatAddTyCon [s,t] + +(.-.) :: Type -> Type -> Type +s .-. t = mkTyConApp typeNatSubTyCon [s,t] + +(.*.) :: Type -> Type -> Type +s .*. t = mkTyConApp typeNatMulTyCon [s,t] + +(.^.) :: Type -> Type -> Type +s .^. t = mkTyConApp typeNatExpTyCon [s,t] + +(<==) :: Type -> Type -> Type +s <== t = mkTyConApp typeNatLeqTyCon [s,t] + +cmpNat :: Type -> Type -> Type +cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] + +cmpSymbol :: Type -> Type -> Type +cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t] + +(===) :: Type -> Type -> Pair Type +x === y = Pair x y + +num :: Integer -> Type +num = mkNumLitTy + +boolKind :: Kind +boolKind = mkTyConApp promotedBoolTyCon [] + +bool :: Bool -> Type +bool b = if b then mkTyConApp promotedTrueDataCon [] + else mkTyConApp promotedFalseDataCon [] + +isBoolLitTy :: Type -> Maybe Bool +isBoolLitTy tc = + do (tc,[]) <- splitTyConApp_maybe tc + case () of + _ | tc == promotedFalseDataCon -> return False + | tc == promotedTrueDataCon -> return True + | otherwise -> Nothing + +orderingKind :: Kind +orderingKind = mkTyConApp promotedOrderingTyCon [] + +ordering :: Ordering -> Type +ordering o = + case o of + LT -> mkTyConApp promotedLTDataCon [] + EQ -> mkTyConApp promotedEQDataCon [] + GT -> mkTyConApp promotedGTDataCon [] + +isOrderingLitTy :: Type -> Maybe Ordering +isOrderingLitTy tc = + do (tc1,[]) <- splitTyConApp_maybe tc + case () of + _ | tc1 == promotedLTDataCon -> return LT + | tc1 == promotedEQDataCon -> return EQ + | tc1 == promotedGTDataCon -> return GT + | otherwise -> Nothing + +known :: (Integer -> Bool) -> TcType -> Bool +known p x = case isNumLitTy x of + Just a -> p a + Nothing -> False + + + + +-- For the definitional axioms +mkBinAxiom :: String -> TyCon -> + (Integer -> Integer -> Maybe Type) -> CoAxiomRule +mkBinAxiom str tc f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrTypeArity = 2 + , coaxrAsmpRoles = [] + , coaxrRole = Nominal + , coaxrProves = \ts cs -> + case (ts,cs) of + ([s,t],[]) -> do x <- isNumLitTy s + y <- isNumLitTy t + z <- f x y + return (mkTyConApp tc [s,t] === z) + _ -> Nothing + } + + + +mkAxiom1 :: String -> (Type -> Pair Type) -> CoAxiomRule +mkAxiom1 str f = + CoAxiomRule + { coaxrName = fsLit str + , coaxrTypeArity = 1 + , coaxrAsmpRoles = [] + , coaxrRole = Nominal + , coaxrProves = \ts cs -> + case (ts,cs) of + ([s],[]) -> return (f s) + _ -> Nothing + } + + +{------------------------------------------------------------------------------- +Evaluation +-------------------------------------------------------------------------------} + +matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamAdd [s,t] + | Just 0 <- mbX = Just (axAdd0L, [t], t) + | Just 0 <- mbY = Just (axAdd0R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axAddDef, [s,t], num (x + y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamAdd _ = Nothing + +matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamSub [s,t] + | Just 0 <- mbY = Just (axSub0R, [s], s) + | Just x <- mbX, Just y <- mbY, Just z <- minus x y = + Just (axSubDef, [s,t], num z) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamSub _ = Nothing + +matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamMul [s,t] + | Just 0 <- mbX = Just (axMul0L, [t], num 0) + | Just 0 <- mbY = Just (axMul0R, [s], num 0) + | Just 1 <- mbX = Just (axMul1L, [t], t) + | Just 1 <- mbY = Just (axMul1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axMulDef, [s,t], num (x * y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamMul _ = Nothing + +matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamExp [s,t] + | Just 0 <- mbY = Just (axExp0R, [s], num 1) + | Just 1 <- mbX = Just (axExp1L, [t], num 1) + | Just 1 <- mbY = Just (axExp1R, [s], s) + | Just x <- mbX, Just y <- mbY = + Just (axExpDef, [s,t], num (x ^ y)) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamExp _ = Nothing + +matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamLeq [s,t] + | Just 0 <- mbX = Just (axLeq0L, [t], bool True) + | Just x <- mbX, Just y <- mbY = + Just (axLeqDef, [s,t], bool (x <= y)) + | tcEqType s t = Just (axLeqRefl, [s], bool True) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamLeq _ = Nothing + +matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpNat [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpNatDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ) + where mbX = isNumLitTy s + mbY = isNumLitTy t +matchFamCmpNat _ = Nothing + +matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpSymbol [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpSymbolDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) + where mbX = isStrLitTy s + mbY = isStrLitTy t +matchFamCmpSymbol _ = Nothing + + +{------------------------------------------------------------------------------- +Interact with axioms +-------------------------------------------------------------------------------} + +interactTopAdd :: [Xi] -> Xi -> [Pair Type] +interactTopAdd [s,t] r + | Just 0 <- mbZ = [ s === num 0, t === num 0 ] -- (s + t ~ 0) => (s ~ 0, t ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y] -- (5 + t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x] -- (s + 5 ~ 8) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopAdd _ _ = [] + +{- +Note [Weakened interaction rule for subtraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A simpler interaction here might be: + + `s - t ~ r` --> `t + r ~ s` + +This would enable us to reuse all the code for addition. +Unfortunately, this works a little too well at the moment. +Consider the following example: + + 0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0) + +This (correctly) spots that the constraint cannot be solved. + +However, this may be a problem if the constraint did not +need to be solved in the first place! Consider the following example: + +f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5 +f = id + +Currently, GHC is strict while evaluating functions, so this does not +work, because even though the `If` should evaluate to `5 - 0`, we +also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`, +which fails. + +So, for the time being, we only add an improvement when the RHS is a constant, +which happens to work OK for the moment, although clearly we need to do +something more general. +-} +interactTopSub :: [Xi] -> Xi -> [Pair Type] +interactTopSub [s,t] r + | Just z <- mbZ = [ s === (num z .+. t) ] -- (s - t ~ 5) => (5 + t ~ s) + where + mbZ = isNumLitTy r +interactTopSub _ _ = [] + + + + + +interactTopMul :: [Xi] -> Xi -> [Pair Type] +interactTopMul [s,t] r + | Just 1 <- mbZ = [ s === num 1, t === num 1 ] -- (s * t ~ 1) => (s ~ 1, t ~ 1) + | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y] -- (3 * t ~ 15) => (t ~ 5) + | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x] -- (s * 3 ~ 15) => (s ~ 5) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopMul _ _ = [] + +interactTopExp :: [Xi] -> Xi -> [Pair Type] +interactTopExp [s,t] r + | Just 0 <- mbZ = [ s === num 0 ] -- (s ^ t ~ 0) => (s ~ 0) + | Just x <- mbX, Just z <- mbZ, Just y <- logExact z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3) + | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3) + where + mbX = isNumLitTy s + mbY = isNumLitTy t + mbZ = isNumLitTy r +interactTopExp _ _ = [] + +interactTopLeq :: [Xi] -> Xi -> [Pair Type] +interactTopLeq [s,t] r + | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) + where + mbY = isNumLitTy t + mbZ = isBoolLitTy r +interactTopLeq _ _ = [] + +interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] +interactTopCmpNat [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpNat _ _ = [] + +interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopCmpSymbol [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpSymbol _ _ = [] + + + + +{------------------------------------------------------------------------------- +Interaction with inerts +-------------------------------------------------------------------------------} + +interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertAdd [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertAdd _ _ _ _ = [] + +interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertSub [x1,y1] z1 [x2,y2] z2 + | sameZ && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 +interactInertSub _ _ _ _ = [] + +interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertMul [x1,y1] z1 [x2,y2] z2 + | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertMul _ _ _ _ = [] + +interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertExp [x1,y1] z1 [x2,y2] z2 + | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ] + | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ] + where sameZ = tcEqType z1 z2 + +interactInertExp _ _ _ _ = [] + + +interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertLeq [x1,y1] z1 [x2,y2] z2 + | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ] + | bothTrue && tcEqType y1 x2 = [ (x1 <== y2) === bool True ] + | bothTrue && tcEqType y2 x1 = [ (x2 <== y1) === bool True ] + where bothTrue = isJust $ do True <- isBoolLitTy z1 + True <- isBoolLitTy z2 + return () + +interactInertLeq _ _ _ _ = [] + + + + + + + + +{- ----------------------------------------------------------------------------- +These inverse functions are used for simplifying propositions using +concrete natural numbers. +----------------------------------------------------------------------------- -} + +-- | Subtract two natural numbers. +minus :: Integer -> Integer -> Maybe Integer +minus x y = if x >= y then Just (x - y) else Nothing + +-- | Compute the exact logarithm of a natural number. +-- The logarithm base is the second argument. +logExact :: Integer -> Integer -> Maybe Integer +logExact x y = do (z,True) <- genLog x y + return z + + +-- | Divide two natural numbers. +divide :: Integer -> Integer -> Maybe Integer +divide _ 0 = Nothing +divide x y = case divMod x y of + (a,0) -> Just a + _ -> Nothing + +-- | Compute the exact root of a natural number. +-- The second argument specifies which root we are computing. +rootExact :: Integer -> Integer -> Maybe Integer +rootExact x y = do (z,True) <- genRoot x y + return z + + + +{- | Compute the the n-th root of a natural number, rounded down to +the closest natural number. The boolean indicates if the result +is exact (i.e., True means no rounding was done, False means rounded down). +The second argument specifies which root we are computing. -} +genRoot :: Integer -> Integer -> Maybe (Integer, Bool) +genRoot _ 0 = Nothing +genRoot x0 1 = Just (x0, True) +genRoot x0 root = Just (search 0 (x0+1)) + where + search from to = let x = from + div (to - from) 2 + a = x ^ root + in case compare a x0 of + EQ -> (x, True) + LT | x /= from -> search x to + | otherwise -> (from, False) + GT | x /= to -> search from x + | otherwise -> (from, False) + +{- | Compute the logarithm of a number in the given base, rounded down to the +closest integer. The boolean indicates if we the result is exact +(i.e., True means no rounding happened, False means we rounded down). +The logarithm base is the second argument. -} +genLog :: Integer -> Integer -> Maybe (Integer, Bool) +genLog x 0 = if x == 1 then Just (0, True) else Nothing +genLog _ 1 = Nothing +genLog 0 _ = Nothing +genLog x base = Just (exactLoop 0 x) + where + exactLoop s i + | i == 1 = (s,True) + | i < base = (s,False) + | otherwise = + let s1 = s + 1 + in s1 `seq` case divMod i base of + (j,r) + | r == 0 -> exactLoop s1 j + | otherwise -> (underLoop s1 j, False) + + underLoop s i + | i < base = s + | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) + + + + + + + diff --git a/compiler/typecheck/TcTypeNats.hs-boot b/compiler/typecheck/TcTypeNats.hs-boot new file mode 100644 index 00000000..12f3e41b --- /dev/null +++ b/compiler/typecheck/TcTypeNats.hs-boot @@ -0,0 +1,5 @@ +module TcTypeNats where + +import TyCon (TyCon) + +typeNatTyCons :: [TyCon] diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs new file mode 100644 index 00000000..3de91055 --- /dev/null +++ b/compiler/typecheck/TcUnify.hs @@ -0,0 +1,1327 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Type subsumption and unification +-} + +{-# LANGUAGE CPP #-} + +module TcUnify ( + -- Full-blown subsumption + tcWrapResult, tcGen, + tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC, + checkConstraints, buildImplication, + + -- Various unifications + unifyType, unifyTypeList, unifyTheta, + unifyKindX, + + -------------------------------- + -- Holes + tcInfer, + matchExpectedListTy, + matchExpectedPArrTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchExpectedFunKind, + wrapFunResCoercion + + ) where + +#include "HsVersions.h" + +import HsSyn +import TypeRep +import TcMType +import TcRnMonad +import TcType +import Type +import TcEvidence +import Name ( isSystemName ) +import Inst +import Kind +import TyCon +import TysWiredIn +import Var +import VarEnv +import VarSet +import ErrUtils +import DynFlags +import BasicTypes +import Maybes ( isJust ) +import Bag +import Util +import Outputable +import FastString + +import Control.Monad + +{- +************************************************************************ +* * + matchExpected functions +* * +************************************************************************ + +Note [Herald for matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'herald' always looks like: + "The equation(s) for 'f' have" + "The abstraction (\x.e) takes" + "The section (+ x) expects" + "The function 'f' is applied to" + +This is used to construct a message of form + + The abstraction `\Just 1 -> ...' takes two arguments + but its type `Maybe a -> a' has only one + + The equation(s) for `f' have two arguments + but its type `Maybe a -> a' has only one + + The section `(f 3)' requires 'f' to take two arguments + but its type `Int -> Int' has only one + + The function 'f' is applied to two arguments + but its type `Int -> Int' has only one + +Note [matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchExpectedFunTys checks that an (Expected rho) has the form +of an n-ary function. It passes the decomposed type to the +thing_inside, and returns a wrapper to coerce between the two types + +It's used wherever a language construct must have a functional type, +namely: + A lambda expression + A function definition + An operator section + +This is not (currently) where deep skolemisation occurs; +matchExpectedFunTys does not skolmise nested foralls in the +expected type, because it expects that to have been done already +-} + +matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] + -> Arity + -> TcRhoType + -> TcM (TcCoercion, [TcSigmaType], TcRhoType) + +-- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r) +-- then co : ty ~ (t1 -> ... -> tn -> ty_r) +-- +-- Does not allocate unnecessary meta variables: if the input already is +-- a function, we just take it apart. Not only is this efficient, +-- it's important for higher rank: the argument might be of form +-- (forall a. ty) -> other +-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd +-- hide the forall inside a meta-variable + +matchExpectedFunTys herald arity orig_ty + = go arity orig_ty + where + -- If go n ty = (co, [t1,..,tn], ty_r) + -- then co : ty ~ t1 -> .. -> tn -> ty_r + + go n_req ty + | n_req == 0 = return (mkTcNomReflCo ty, [], ty) + + go n_req ty + | Just ty' <- tcView ty = go n_req ty' + + go n_req (FunTy arg_ty res_ty) + | not (isPredTy arg_ty) + = do { (co, tys, ty_r) <- go (n_req-1) res_ty + ; return (mkTcFunCo Nominal (mkTcNomReflCo arg_ty) co, arg_ty:tys, ty_r) } + + go n_req ty@(TyVarTy tv) + | ASSERT( isTcTyVar tv) isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go n_req ty' + Flexi -> defer n_req ty (isReturnTyVar tv) } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf Trac #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also Trac #9605. + go n_req ty = addErrCtxtM mk_ctxt $ + defer n_req ty False + + ------------ + -- If we decide that a ReturnTv (see Note [ReturnTv] in TcType) should + -- really be a function type, then we need to allow the argument and + -- result types also to be ReturnTvs. + defer n_req fun_ty is_return + = do { arg_tys <- mapM new_ty_var_ty (nOfThem n_req openTypeKind) + -- See Note [Foralls to left of arrow] + ; res_ty <- new_ty_var_ty openTypeKind + ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) + ; return (co, arg_tys, res_ty) } + where + new_ty_var_ty | is_return = newReturnTyVarTy + | otherwise = newFlexiTyVarTy + + ------------ + mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_ty + ; let (args, _) = tcSplitFunTys ty + n_actual = length args + (env'', orig_ty') = tidyOpenType env' orig_ty + ; return (env'', mk_msg orig_ty' ty n_actual) } + + mk_msg orig_ty ty n_args + = herald <+> speakNOf arity (ptext (sLit "argument")) <> comma $$ + if n_args == arity + then ptext (sLit "its type is") <+> quotes (pprType orig_ty) <> + comma $$ + ptext (sLit "it is specialized to") <+> quotes (pprType ty) + else sep [ptext (sLit "but its type") <+> quotes (pprType ty), + if n_args == 0 then ptext (sLit "has none") + else ptext (sLit "has only") <+> speakN n_args] + +{- +Note [Foralls to left of arrow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f (x :: forall a. a -> a) = x +We give 'f' the type (alpha -> beta), and then want to unify +the alpha with (forall a. a->a). We want to the arg and result +of (->) to have openTypeKind, and this also permits foralls, so +we are ok. +-} + +---------------------- +matchExpectedListTy :: TcRhoType -> TcM (TcCoercion, TcRhoType) +-- Special case for lists +matchExpectedListTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } + +---------------------- +matchExpectedPArrTy :: TcRhoType -> TcM (TcCoercion, TcRhoType) +-- Special case for parrs +matchExpectedPArrTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty + ; return (co, elt_ty) } + +--------------------- +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * + -> TcRhoType -- orig_ty + -> TcM (TcCoercion, -- T k1 k2 k3 a b c ~ orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c + +-- It's used for wired-in tycons, so we call checkWiredInTyCon +-- Precondition: never called with FunTyCon +-- Precondition: input type :: * +-- Postcondition: (T k1 k2 k3 a b c) is well-kinded + +matchExpectedTyConApp tc orig_ty + = go orig_ty + where + go ty + | Just ty' <- tcView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkTcNomReflCo ty, args) + + go (TyVarTy tv) + | ASSERT( isTcTyVar tv) isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- If the common case does not occur, instantiate a template + -- T k1 .. kn t1 .. tm, and unify with the original type + -- Doing it this way ensures that the types we return are + -- kind-compatible with T. For example, suppose we have + -- matchExpectedTyConApp T (f Maybe) + -- where data T a = MkT a + -- Then we don't want to instantate T's data constructors with + -- (a::*) ~ Maybe + -- because that'll make types that are utterly ill-kinded. + -- This happened in Trac #7368 + defer = ASSERT2( isSubOpenTypeKind res_kind, ppr tc ) + do { kappa_tys <- mapM (const newMetaKindVar) kvs + ; let arg_kinds' = map (substKiWith kvs kappa_tys) arg_kinds + ; tau_tys <- mapM newFlexiTyVarTy arg_kinds' + ; co <- unifyType (mkTyConApp tc (kappa_tys ++ tau_tys)) orig_ty + ; return (co, kappa_tys ++ tau_tys) } + + (kvs, body) = splitForAllTys (tyConKind tc) + (arg_kinds, res_kind) = splitKindFunTys body + +---------------------- +matchExpectedAppTy :: TcRhoType -- orig_ty + -> TcM (TcCoercion, -- m a ~ orig_ty + (TcSigmaType, TcSigmaType)) -- Returns m, a +-- If the incoming type is a mutable type variable of kind k, then +-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. + +matchExpectedAppTy orig_ty + = go orig_ty + where + go ty + | Just ty' <- tcView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) + + go (TyVarTy tv) + | ASSERT( isTcTyVar tv) isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- Defer splitting by generating an equality constraint + defer = do { ty1 <- newFlexiTyVarTy kind1 + ; ty2 <- newFlexiTyVarTy kind2 + ; co <- unifyType (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } + + orig_kind = typeKind orig_ty + kind1 = mkArrowKind liftedTypeKind (defaultKind orig_kind) + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + -- The defaultKind is a bit smelly. If you remove it, + -- try compiling f x = do { x } + -- and you'll get a kind mis-match. It smells, but + -- not enough to lose sleep over. + +{- +************************************************************************ +* * + Subsumption checking +* * +************************************************************************ + +Note [Subsumption checking: tcSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the tcSubType calls have the form + tcSubType actual_ty expected_ty +which checks + actual_ty <= expected_ty + +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. I.e. that + + actual ty is more polymorphic than expected_ty + +It returns a coercion function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +There are a number of wrinkles (below). + +Notice that Wrinkle 1 and 2 both require eta-expansion, which technically +may increase termination. We just put up with this, in exchange for getting +more predicatble type inference. + +Wrinkle 1: Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) +(see section 4.6 of "Practical type inference for higher rank types") +So we must deeply-skolemise the RHS before we instantiate the LHS. + +That is why tc_sub_type starts with a call to tcGen (which does the +deep skolemisation), and then calls the DS variant (which assumes +that expected_ty is deeply skolemised) + +Wrinkle 2: Note [Co/contra-variance of subsumption checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider g :: (Int -> Int) -> Int + f1 :: (forall a. a -> a) -> Int + f1 = g + + f2 :: (forall a. a -> a) -> Int + f2 x = g x +f2 will typecheck, and it would be odd/fragile if f1 did not. +But f1 will only typecheck if we have that + (Int->Int) -> Int <= (forall a. a->a) -> Int +And that is only true if we do the full co/contravariant thing +in the subsumption check. That happens in the FunTy case of +tc_sub_type_ds, and is the sole reason for the WpFun form of +HsWrapper. + +Another powerful reason for doing this co/contra stuff is visible +in Trac #9569, involving instantiation of constraint variables, +and again involving eta-expansion. + +Wrinkle 3: Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider tc150: + f y = \ (x::forall a. a->a). blah +The following happens: +* We will infer the type of the RHS, ie with a res_ty = alpha. +* Then the lambda will split alpha := beta -> gamma. +* And then we'll check tcSubType IsSwapped beta (forall a. a->a) + +So it's important that we unify beta := forall a. a->a, rather than +skolemising the type. +-} + +tcSubType :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubType ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + tcSubType_NC ctxt ty_actual ty_expected + +tcSubTypeDS :: UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper +-- Just like tcSubType, but with the additional precondition that +-- ty_expected is deeply skolemised (hence "DS") +tcSubTypeDS ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + tcSubTypeDS_NC ctxt ty_actual ty_expected + + +addSubTypeCtxt :: TcType -> TcType -> TcM a -> TcM a +addSubTypeCtxt ty_actual ty_expected thing_inside + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself + | otherwise + = addErrCtxtM mk_msg thing_inside + where + mk_msg tidy_env + = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected + ; let msg = vcat [ hang (ptext (sLit "When checking that:")) + 4 (ppr ty_actual) + , nest 2 (hang (ptext (sLit "is more polymorphic than:")) + 2 (ppr ty_expected)) ] + ; return (tidy_env, msg) } + +--------------- +-- The "_NC" variants do not add a typechecker-error context; +-- the caller is assumed to do that + +tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubType_NC ctxt ty_actual ty_expected + = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tc_sub_type origin ctxt ty_actual ty_expected } + where + origin = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected } + +tcSubTypeDS_NC :: UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper +tcSubTypeDS_NC ctxt ty_actual ty_expected + = do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) + ; tc_sub_type_ds origin ctxt ty_actual ty_expected } + where + origin = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected } + +--------------- +tc_sub_type :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tc_sub_type origin ctxt ty_actual ty_expected + | isTyVarTy ty_actual -- See Note [Higher rank types] + = do { cow <- uType origin ty_actual ty_expected + ; return (coToHsWrapper cow) } + + | otherwise -- See Note [Deep skolemisation] + = do { (sk_wrap, inner_wrap) <- tcGen ctxt ty_expected $ \ _ sk_rho -> + tc_sub_type_ds origin ctxt ty_actual sk_rho + ; return (sk_wrap <.> inner_wrap) } + +--------------- +tc_sub_type_ds :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper +-- Just like tcSubType, but with the additional precondition that +-- ty_expected is deeply skolemised +tc_sub_type_ds origin ctxt ty_actual ty_expected + | Just (act_arg, act_res) <- tcSplitFunTy_maybe ty_actual + , Just (exp_arg, exp_res) <- tcSplitFunTy_maybe ty_expected + = -- See Note [Co/contra-variance of subsumption checking] + do { res_wrap <- tc_sub_type_ds origin ctxt act_res exp_res + ; arg_wrap <- tc_sub_type origin ctxt exp_arg act_arg + ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) } + -- arg_wrap :: exp_arg ~ act_arg + -- res_wrap :: act-res ~ exp_res + + | (tvs, theta, in_rho) <- tcSplitSigmaTy ty_actual + , not (null tvs && null theta) + = do { (subst, tvs') <- tcInstTyVars tvs + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + in_rho' = substTy subst in_rho + ; in_wrap <- instCall origin tys' theta' + ; body_wrap <- tcSubTypeDS_NC ctxt in_rho' ty_expected + ; return (body_wrap <.> in_wrap) } + + | otherwise -- Revert to unification + = do { cow <- uType origin ty_actual ty_expected + ; return (coToHsWrapper cow) } + +----------------- +tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) +tcWrapResult expr actual_ty res_ty + = do { cow <- tcSubTypeDS GenSigCtxt actual_ty res_ty + -- Both types are deeply skolemised + ; return (mkHsWrap cow expr) } + +----------------------------------- +wrapFunResCoercion + :: [TcType] -- Type of args + -> HsWrapper -- HsExpr a -> HsExpr b + -> TcM HsWrapper -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) +wrapFunResCoercion arg_tys co_fn_res + | isIdHsWrapper co_fn_res + = return idHsWrapper + | null arg_tys + = return co_fn_res + | otherwise + = do { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys + ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) } + +----------------------------------- +-- | Infer a type using a type "checking" function by passing in a ReturnTv, +-- which can unify with *anything*. See also Note [ReturnTv] in TcType +tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) +tcInfer tc_check + = do { ret_tv <- newReturnTyVar openTypeKind + ; res <- tc_check (mkTyVarTy ret_tv) + ; details <- readMetaTyVar ret_tv + ; res_ty <- case details of + Indirect ty -> return ty + Flexi -> -- Checking was uninformative + do { traceTc "Defaulting un-filled ReturnTv to a TauTv" (ppr ret_tv) + ; tau_ty <- newFlexiTyVarTy openTypeKind + ; writeMetaTyVar ret_tv tau_ty + ; return tau_ty } + ; return (res, res_ty) } + +{- +************************************************************************ +* * +\subsection{Generalisation} +* * +************************************************************************ +-} + +tcGen :: UserTypeCtxt -> TcType + -> ([TcTyVar] -> TcRhoType -> TcM result) + -> TcM (HsWrapper, result) + -- The expression has type: spec_ty -> expected_ty + +tcGen ctxt expected_ty thing_inside + -- We expect expected_ty to be a forall-type + -- If not, the call is a no-op + = do { traceTc "tcGen" Outputable.empty + ; (wrap, tvs', given, rho') <- deeplySkolemise expected_ty + + ; when debugIsOn $ + traceTc "tcGen" $ vcat [ + text "expected_ty" <+> ppr expected_ty, + text "inst ty" <+> ppr tvs' <+> ppr rho' ] + + -- Generally we must check that the "forall_tvs" havn't been constrained + -- The interesting bit here is that we must include the free variables + -- of the expected_ty. Here's an example: + -- runST (newVar True) + -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) + -- for (newVar True), with s fresh. Then we unify with the runST's arg type + -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. + -- So now s' isn't unconstrained because it's linked to a. + -- + -- However [Oct 10] now that the untouchables are a range of + -- TcTyVars, all this is handled automatically with no need for + -- extra faffing around + + -- Use the *instantiated* type in the SkolemInfo + -- so that the names of displayed type variables line up + ; let skol_info = SigSkol ctxt (mkPiTypes given rho') + + ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ + thing_inside tvs' rho' + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + +checkConstraints :: SkolemInfo + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (TcEvBinds, result) + +checkConstraints skol_info skol_tvs given thing_inside + | null skol_tvs && null given + = do { res <- thing_inside; return (emptyTcEvBinds, res) } + -- Just for efficiency. We check every function argument with + -- tcPolyExpr, which uses tcGen and hence checkConstraints. + + | otherwise + = do { (implics, ev_binds, result) <- buildImplication skol_info skol_tvs given thing_inside + ; emitImplications implics + ; return (ev_binds, result) } + +buildImplication :: SkolemInfo + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (Bag Implication, TcEvBinds, result) +buildImplication skol_info skol_tvs given thing_inside + = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) + ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) + do { (result, tclvl, wanted) <- pushLevelAndCaptureConstraints thing_inside + + ; if isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + then + return (emptyBag, emptyTcEvBinds, result) + else do + { ev_binds_var <- newTcEvBinds + ; env <- getLclEnv + ; let implic = Implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_no_eqs = False + , ic_given = given + , ic_wanted = wanted + , ic_insol = insolubleWC wanted + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } + + ; return (unitBag implic, TcEvBinds ev_binds_var, result) } } + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyType :: TcTauType -> TcTauType -> TcM TcCoercion +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType ty1 ty2 = uType origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } + +--------------- +unifyPred :: PredType -> PredType -> TcM TcCoercion +-- Actual and expected types +unifyPred = unifyType + +--------------- +unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercion] +-- Actual and expected types +unifyTheta theta1 theta2 + = do { checkTc (equalLength theta1 theta2) + (vcat [ptext (sLit "Contexts differ in length"), + nest 2 $ parens $ ptext (sLit "Use RelaxedPolyRec to allow this")]) + ; zipWithM unifyPred theta1 theta2 } + +{- +@unifyTypeList@ takes a single list of @TauType@s and unifies them +all together. It is used, for example, when typechecking explicit +lists, when all the elts should be of the same type. +-} + +unifyTypeList :: [TcTauType] -> TcM () +unifyTypeList [] = return () +unifyTypeList [_] = return () +unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2 + ; unifyTypeList tys } + +{- +************************************************************************ +* * + uType and friends +* * +************************************************************************ + +uType is the heart of the unifier. Each arg occurs twice, because +we want to report errors in terms of synomyms if possible. The first of +the pair is used in error messages only; it is always the same as the +second, except that if the first is a synonym then the second may be a +de-synonym'd version. This way we get better error messages. +-} + +------------ +uType, uType_defer + :: CtOrigin + -> TcType -- ty1 is the *actual* type + -> TcType -- ty2 is the *expected* type + -> TcM TcCoercion + +-------------- +-- It is always safe to defer unification to the main constraint solver +-- See Note [Deferred unification] +uType_defer origin ty1 ty2 + = do { eqv <- newEq ty1 ty2 + ; loc <- getCtLoc origin + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_evar = eqv + , ctev_pred = mkTcEqPred ty1 ty2 + , ctev_loc = loc } + + -- Error trace only + -- NB. do *not* call mkErrInfo unless tracing is on, because + -- it is hugely expensive (#5631) + ; whenDOptM Opt_D_dump_tc_trace $ do + { ctxt <- getErrCtxt + ; doc <- mkErrInfo emptyTidyEnv ctxt + ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, + ppr ty2, pprCtOrigin origin, doc]) + } + ; return (mkTcCoVarCo eqv) } + +-------------- +-- unify_np (short for "no push" on the origin stack) does the work +uType origin orig_ty1 orig_ty2 + = do { tclvl <- getTcLevel + ; traceTc "u_tys " $ vcat + [ text "tclvl" <+> ppr tclvl + , sep [ ppr orig_ty1, text "~", ppr orig_ty2] + , pprCtOrigin origin] + ; co <- go orig_ty1 orig_ty2 + ; if isTcReflCo co + then traceTc "u_tys yields no coercion" Outputable.empty + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } + where + go :: TcType -> TcType -> TcM TcCoercion + -- The arguments to 'go' are always semantically identical + -- to orig_ty{1,2} except for looking through type synonyms + + -- Variables; go for uVar + -- Note that we pass in *original* (before synonym expansion), + -- so that type variables tend to get filled in with + -- the most informative version of the type + go (TyVarTy tv1) ty2 + = do { lookup_res <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> go ty1 ty2 + Unfilled ds1 -> uUnfilledVar origin NotSwapped tv1 ds1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> go ty1 ty2 + Unfilled ds2 -> uUnfilledVar origin IsSwapped tv2 ds2 ty1 } + + -- See Note [Expanding synonyms during unification] + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See Trac #4535. + go ty1 ty2 + | Just ty1' <- tcView ty1 = go ty1' ty2 + | Just ty2' <- tcView ty2 = go ty1 ty2' + + -- Functions (or predicate functions) just check the two parts + go (FunTy fun1 arg1) (FunTy fun2 arg2) + = do { co_l <- uType origin fun1 fun2 + ; co_r <- uType origin arg1 arg2 + ; return $ mkTcFunCo Nominal co_l co_r } + + -- Always defer if a type synonym family (type function) + -- is involved. (Data families behave rigidly.) + go ty1@(TyConApp tc1 _) ty2 + | isTypeFamilyTyCon tc1 = uType_defer origin ty1 ty2 + go ty1 ty2@(TyConApp tc2 _) + | isTypeFamilyTyCon tc2 = uType_defer origin ty1 ty2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, length tys1 == length tys2 + = do { cos <- zipWithM (uType origin) tys1 tys2 + ; return $ mkTcTyConAppCo Nominal tc1 cos } + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkTcNomReflCo ty + + -- See Note [Care with type applications] + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go (AppTy s1 t1) (AppTy s2 t2) + = go_app s1 t1 s2 t2 + + go (AppTy s1 t1) (TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = ASSERT( isDecomposableTyCon tc2 ) + go_app s1 t1 (TyConApp tc2 ts2') t2' + + go (TyConApp tc1 ts1) (AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = ASSERT( isDecomposableTyCon tc1 ) + go_app (TyConApp tc1 ts1') t1' s2 t2 + + -- Anything else fails + -- E.g. unifying for-all types, which is relative unusual + go ty1 ty2 = uType_defer origin ty1 ty2 -- failWithMisMatch origin + + ------------------ + go_app s1 t1 s2 t2 + = do { co_s <- uType origin s1 s2 -- See Note [Unifying AppTy] + ; co_t <- uType origin t1 t2 + ; return $ mkTcAppCo co_s co_t } + +{- +Note [Care with type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note: type applications need a bit of care! +They can match FunTy and TyConApp, so use splitAppTy_maybe +NB: we've already dealt with type variables and Notes, +so if one type is an App the other one jolly well better be too + +Note [Unifying AppTy] +~~~~~~~~~~~~~~~~~~~~~ +Consider unifying (m Int) ~ (IO Int) where m is a unification variable +that is now bound to (say) (Bool ->). Then we want to report + "Can't unify (Bool -> Int) with (IO Int) +and not + "Can't unify ((->) Bool) with IO" +That is why we use the "_np" variant of uType, which does not alter the error +message. + +Note [Mismatched type lists and application decomposition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find two TyConApps, you might think that the argument lists +are guaranteed equal length. But they aren't. Consider matching + w (T x) ~ Foo (T x y) +We do match (w ~ Foo) first, but in some circumstances we simply create +a deferred constraint; and then go ahead and match (T x ~ T x y). +This came up in Trac #3950. + +So either + (a) either we must check for identical argument kinds + when decomposing applications, + + (b) or we must be prepared for ill-kinded unification sub-problems + +Currently we adopt (b) since it seems more robust -- no need to maintain +a global invariant. + +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user + + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. + +Note [Deferred Unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, +and yet its consistency is undetermined. Previously, there was no way to still +make it consistent. So a mismatch error was issued. + +Now these unfications are deferred until constraint simplification, where type +family instances and given equations may (or may not) establish the consistency. +Deferred unifications are of the form + F ... ~ ... +or x ~ ... +where F is a type function and x is a type variable. +E.g. + id :: x ~ y => x -> y + id e = e + +involves the unfication x = y. It is deferred until we bring into account the +context x ~ y to establish that it holds. + +If available, we defer original types (rather than those where closed type +synonyms have already been expanded via tcCoreView). This is, as usual, to +improve error messages. + + +************************************************************************ +* * + uVar and friends +* * +************************************************************************ + +@uVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. +-} + +uUnfilledVar :: CtOrigin + -> SwapFlag + -> TcTyVar -> TcTyVarDetails -- Tyvar 1 + -> TcTauType -- Type 2 + -> TcM TcCoercion +-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar +-- It might be a skolem, or untouchable, or meta + +uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) + | tv1 == tv2 -- Same type variable => no-op + = return (mkTcNomReflCo (mkTyVarTy tv1)) + + | otherwise -- Distinct type variables + = do { lookup2 <- lookupTcTyVar tv2 + ; case lookup2 of + Filled ty2' -> uUnfilledVar origin swapped tv1 details1 ty2' + Unfilled details2 -> uUnfilledVars origin swapped tv1 details1 tv2 details2 + } + +uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type variable + = case details1 of + MetaTv { mtv_ref = ref1 } + -> do { dflags <- getDynFlags + ; mb_ty2' <- checkTauTvUpdate dflags tv1 non_var_ty2 + ; case mb_ty2' of + Just ty2' -> updateMeta tv1 ref1 ty2' + Nothing -> do { traceTc "Occ/kind defer" + (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + $$ ppr non_var_ty2 $$ ppr (typeKind non_var_ty2)) + ; defer } + } + + _other -> do { traceTc "Skolem defer" (ppr tv1); defer } -- Skolems of all sorts + where + defer = unSwap swapped (uType_defer origin) (mkTyVarTy tv1) non_var_ty2 + -- Occurs check or an untouchable: just defer + -- NB: occurs check isn't necessarily fatal: + -- eg tv1 occured in type family parameter + +---------------- +uUnfilledVars :: CtOrigin + -> SwapFlag + -> TcTyVar -> TcTyVarDetails -- Tyvar 1 + -> TcTyVar -> TcTyVarDetails -- Tyvar 2 + -> TcM TcCoercion +-- Invarant: The type variables are distinct, +-- Neither is filled in yet + +uUnfilledVars origin swapped tv1 details1 tv2 details2 + = do { traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 + <+> text "with" <+> ppr k2) + ; mb_sub_kind <- unifyKindX k1 k2 + ; case mb_sub_kind of { + Nothing -> unSwap swapped (uType_defer origin) (mkTyVarTy tv1) ty2 ; + Just sub_kind -> + + case (sub_kind, details1, details2) of + -- k1 < k2, so update tv2 + (LT, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 + + -- k2 < k1, so update tv1 + (GT, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 + + -- k1 = k2, so we are free to update either way + (EQ, MetaTv { mtv_info = i1, mtv_ref = ref1 }, + MetaTv { mtv_info = i2, mtv_ref = ref2 }) + | nicer_to_update_tv1 tv1 i1 i2 -> updateMeta tv1 ref1 ty2 + | otherwise -> updateMeta tv2 ref2 ty1 + (EQ, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 + (EQ, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 + + -- Can't do it in-place, so defer + -- This happens for skolems of all sorts + (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } } + where + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + ty1 = mkTyVarTy tv1 + ty2 = mkTyVarTy tv2 + +nicer_to_update_tv1 :: TcTyVar -> MetaInfo -> MetaInfo -> Bool +nicer_to_update_tv1 _ _ SigTv = True +nicer_to_update_tv1 _ SigTv _ = False +nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) + -- Try not to update SigTvs; and try to update sys-y type + -- variables in preference to ones gotten (say) by + -- instantiating a polymorphic function with a user-written + -- type sig + +---------------- +checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) +-- (checkTauTvUpdate tv ty) +-- We are about to update the TauTv/ReturnTv tv with ty. +-- Check (a) that tv doesn't occur in ty (occurs check) +-- (b) that kind(ty) is a sub-kind of kind(tv) +-- +-- We have two possible outcomes: +-- (1) Return the type to update the type variable with, +-- [we know the update is ok] +-- (2) Return Nothing, +-- [the update might be dodgy] +-- +-- Note that "Nothing" does not mean "definite error". For example +-- type family F a +-- type instance F Int = Int +-- consider +-- a ~ F a +-- This is perfectly reasonable, if we later get a ~ Int. For now, though, +-- we return Nothing, leaving it to the later constraint simplifier to +-- sort matters out. + +checkTauTvUpdate dflags tv ty + | SigTv <- info + = ASSERT( not (isTyVarTy ty) ) + return Nothing + | otherwise + = do { ty1 <- zonkTcType ty + ; sub_k <- unifyKindX (tyVarKind tv) (typeKind ty1) + ; case sub_k of + Nothing -> return Nothing + Just LT -> return Nothing + _ | is_return_tv -> if tv `elemVarSet` tyVarsOfType ty1 + then return Nothing + else return (Just ty1) + _ | defer_me ty1 -- Quick test + -> -- Failed quick test so try harder + case occurCheckExpand dflags tv ty1 of + OC_OK ty2 | defer_me ty2 -> return Nothing + | otherwise -> return (Just ty2) + _ -> return Nothing + | otherwise -> return (Just ty1) } + where + details = ASSERT2( isMetaTyVar tv, ppr tv ) tcTyVarDetails tv + info = mtv_info details + is_return_tv = isReturnTyVar tv + impredicative = canUnifyWithPolyType dflags details (tyVarKind tv) + + defer_me :: TcType -> Bool + -- Checks for (a) occurrence of tv + -- (b) type family applications + -- See Note [Conservative unification check] + defer_me (LitTy {}) = False + defer_me (TyVarTy tv') = tv == tv' + defer_me (TyConApp tc tys) = isTypeFamilyTyCon tc || any defer_me tys + defer_me (FunTy arg res) = defer_me arg || defer_me res + defer_me (AppTy fun arg) = defer_me fun || defer_me arg + defer_me (ForAllTy _ ty) = not impredicative || defer_me ty + +{- +Note [Conservative unification check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unifying (tv ~ rhs), w try to avoid creating deferred constraints +only for efficiency. However, we do not unify (the defer_me check) if + a) There's an occurs check (tv is in fvs(rhs)) + b) There's a type-function call in 'rhs' + +If we fail defer_me we use occurCheckExpand to try to make it pass, +(see Note [Type synonyms and the occur check]) and then use defer_me +again to check. Example: Trac #4917) + a ~ Const a b +where type Const a b = a. We can solve this immediately, even when +'a' is a skolem, just by expanding the synonym. + +We always defer type-function calls, even if it's be perfectly safe to +unify, eg (a ~ F [b]). Reason: this ensures that the constraint +solver gets to see, and hence simplify the type-function call, which +in turn might simplify the type of an inferred function. Test ghci046 +is a case in point. + +More mysteriously, test T7010 gave a horrible error + T7010.hs:29:21: + Couldn't match type `Serial (ValueTuple Float)' with `IO Float' + Expected type: (ValueTuple Vector, ValueTuple Vector) + Actual type: (ValueTuple Vector, ValueTuple Vector) +because an insoluble type function constraint got mixed up with +a soluble one when flattening. I never fully understood this, but +deferring type-function applications made it go away :-(. +T5853 also got a less-good error message with more aggressive +unification of type functions. + +Moreover the Note [Type family sharing] gives another reason, but +again I'm not sure if it's really valid. + +Note [Type synonyms and the occur check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking we try to update a variable with type synonyms not +expanded, which improves later error messages, unless looking +inside a type synonym may help resolve a spurious occurs check +error. Consider: + type A a = () + + f :: (A a -> a -> ()) -> () + f = \ _ -> () + + x :: () + x = f (\ x p -> p x) + +We will eventually get a constraint of the form t ~ A t. The ok function above will +properly expand the type (A t) to just (), which is ok to be unified with t. If we had +unified with the original type A t, we would lead the type checker into an infinite loop. + +Hence, if the occurs check fails for a type synonym application, then (and *only* then), +the ok function expands the synonym to detect opportunities for occurs check success using +the underlying definition of the type synonym. + +The same applies later on in the constraint interaction code; see TcInteract, +function @occ_check_ok@. + +Note [Type family sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid eagerly unifying type variables to types that contain function symbols, +because this may lead to loss of sharing, and in turn, in very poor performance of the +constraint simplifier. Assume that we have a wanted constraint: +{ + m1 ~ [F m2], + m2 ~ [F m3], + m3 ~ [F m4], + D m1, + D m2, + D m3 +} +where D is some type class. If we eagerly unify m1 := [F m2], m2 := [F m3], m3 := [F m4], +then, after zonking, our constraint simplifier will be faced with the following wanted +constraint: +{ + D [F [F [F m4]]], + D [F [F m4]], + D [F m4] +} +which has to be flattened by the constraint solver. In the absence of +a flat-cache, this may generate a polynomially larger number of +flatten skolems and the constraint sets we are working with will be +polynomially larger. + +Instead, if we defer the unifications m1 := [F m2], etc. we will only +be generating three flatten skolems, which is the maximum possible +sharing arising from the original constraint. That's why we used to +use a local "ok" function, a variant of TcType.occurCheckExpand. + +HOWEVER, we *do* now have a flat-cache, which effectively recovers the +sharing, so there's no great harm in losing it -- and it's generally +more efficient to do the unification up-front. +-} + +data LookupTyVarResult -- The result of a lookupTcTyVar call + = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv + | Filled TcType + +lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult +lookupTcTyVar tyvar + | MetaTv { mtv_ref = ref } <- details + = do { meta_details <- readMutVar ref + ; case meta_details of + Indirect ty -> return (Filled ty) + Flexi -> do { is_touchable <- isTouchableTcM tyvar + -- Note [Unifying untouchables] + ; if is_touchable then + return (Unfilled details) + else + return (Unfilled vanillaSkolemTv) } } + | otherwise + = return (Unfilled details) + where + details = ASSERT2( isTcTyVar tyvar, ppr tyvar ) + tcTyVarDetails tyvar + +updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM TcCoercion +updateMeta tv1 ref1 ty2 + = do { writeMetaTyVarRef tv1 ref1 ty2 + ; return (mkTcNomReflCo ty2) } + +{- +Note [Unifying untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat an untouchable type variable as if it was a skolem. That +ensures it won't unify with anything. It's a slight had, because +we return a made-up TcTyVarDetails, but I think it works smoothly. + + +************************************************************************ +* * + Kind unification +* * +************************************************************************ + +Unifying kinds is much, much simpler than unifying types. + +One small wrinkle is that as far as the user is concerned, types of kind +Constraint should only be allowed to occur where we expect *exactly* that kind. +We SHOULD NOT allow a type of kind fact to appear in a position expecting +one of argTypeKind or openTypeKind. + +The situation is different in the core of the compiler, where we are perfectly +happy to have types of kind Constraint on either end of an arrow. + +Note [Kind variables can be untouchable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must use the careful function lookupTcTyVar to see if a kind +variable is filled or unifiable. It checks for touchablity, and kind +variables can certainly be untouchable --- for example the variable +might be bound outside an enclosing existental pattern match that +binds an inner kind variable, which we don't want to escape outside. + +This, or something closely related, was the cause of Trac #8985. + +Note [Unifying kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather hackily, kind variables can be TyVars not just TcTyVars. +Main reason is in + data instance T (D (x :: k)) = ...con-decls... +Here we bring into scope a kind variable 'k', and use it in the +con-decls. BUT the con-decls will be finished and frozen, and +are not amenable to subsequent substitution, so it makes sense +to have the *final* kind-variable (a KindVar, not a TcKindVar) in +scope. So at least during kind unification we can encounter a +KindVar. + +Hence the isTcTyVar tests before calling lookupTcTyVar. +-} + +matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) +-- Like unifyFunTy, but does not fail; instead just returns Nothing + +matchExpectedFunKind (FunTy arg_kind res_kind) + = return (Just (arg_kind,res_kind)) + +matchExpectedFunKind (TyVarTy kvar) + | isTcTyVar kvar, isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> matchExpectedFunKind fun_kind + Flexi -> + do { arg_kind <- newMetaKindVar + ; res_kind <- newMetaKindVar + ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) + ; return (Just (arg_kind,res_kind)) } } + +matchExpectedFunKind _ = return Nothing + +----------------- +unifyKindX :: TcKind -- k1 (actual) + -> TcKind -- k2 (expected) + -> TcM (Maybe Ordering) + -- Returns the relation between the kinds + -- Just LT <=> k1 is a sub-kind of k2 + -- Nothing <=> incomparable + +-- unifyKindX deals with the top-level sub-kinding story +-- but recurses into the simpler unifyKindEq for any sub-terms +-- The sub-kinding stuff only applies at top level + +unifyKindX (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindX kv1 k2 +unifyKindX k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindX kv2 k1 + +unifyKindX k1 k2 -- See Note [Expanding synonyms during unification] + | Just k1' <- tcView k1 = unifyKindX k1' k2 + | Just k2' <- tcView k2 = unifyKindX k1 k2' + +unifyKindX (TyConApp kc1 []) (TyConApp kc2 []) + | kc1 == kc2 = return (Just EQ) + | kc1 `tcIsSubKindCon` kc2 = return (Just LT) + | kc2 `tcIsSubKindCon` kc1 = return (Just GT) + | otherwise = return Nothing + +unifyKindX k1 k2 = unifyKindEq k1 k2 + -- In all other cases, let unifyKindEq do the work + +------------------- +uKVar :: SwapFlag -> (TcKind -> TcKind -> TcM (Maybe Ordering)) + -> MetaKindVar -> TcKind -> TcM (Maybe Ordering) +uKVar swapped unify_kind kv1 k2 + | isTcTyVar kv1 + = do { lookup_res <- lookupTcTyVar kv1 -- See Note [Kind variables can be untouchable] + ; case lookup_res of + Filled k1 -> unSwap swapped unify_kind k1 k2 + Unfilled ds1 -> uUnfilledKVar kv1 ds1 k2 } + + | otherwise -- See Note [Unifying kind variables] + = uUnfilledKVar kv1 vanillaSkolemTv k2 + +------------------- +uUnfilledKVar :: MetaKindVar -> TcTyVarDetails -> TcKind -> TcM (Maybe Ordering) +uUnfilledKVar kv1 ds1 (TyVarTy kv2) + | kv1 == kv2 + = return (Just EQ) + + | isTcTyVar kv2 + = do { lookup_res <- lookupTcTyVar kv2 + ; case lookup_res of + Filled k2 -> uUnfilledKVar kv1 ds1 k2 + Unfilled ds2 -> uUnfilledKVars kv1 ds1 kv2 ds2 } + + | otherwise -- See Note [Unifying kind variables] + = uUnfilledKVars kv1 ds1 kv2 vanillaSkolemTv + +uUnfilledKVar kv1 ds1 non_var_k2 + = case ds1 of + MetaTv { mtv_info = SigTv } + -> return Nothing + MetaTv { mtv_ref = ref1 } + -> do { k2a <- zonkTcKind non_var_k2 + ; let k2b = defaultKind k2a + -- MetaKindVars must be bound only to simple kinds + + ; dflags <- getDynFlags + ; case occurCheckExpand dflags kv1 k2b of + OC_OK k2c -> do { writeMetaTyVarRef kv1 ref1 k2c; return (Just EQ) } + _ -> return Nothing } + _ -> return Nothing + +------------------- +uUnfilledKVars :: MetaKindVar -> TcTyVarDetails + -> MetaKindVar -> TcTyVarDetails + -> TcM (Maybe Ordering) +-- kv1 /= kv2 +uUnfilledKVars kv1 ds1 kv2 ds2 + = case (ds1, ds2) of + (MetaTv { mtv_info = i1, mtv_ref = r1 }, + MetaTv { mtv_info = i2, mtv_ref = r2 }) + | nicer_to_update_tv1 kv1 i1 i2 -> do_update kv1 r1 kv2 + | otherwise -> do_update kv2 r2 kv1 + (MetaTv { mtv_ref = r1 }, _) -> do_update kv1 r1 kv2 + (_, MetaTv { mtv_ref = r2 }) -> do_update kv2 r2 kv1 + _ -> return Nothing + where + do_update kv1 r1 kv2 + = do { writeMetaTyVarRef kv1 r1 (mkTyVarTy kv2); return (Just EQ) } + +--------------------------- +unifyKindEq :: TcKind -> TcKind -> TcM (Maybe Ordering) +-- Unify two kinds looking for equality not sub-kinding +-- So it returns Nothing or (Just EQ) only +unifyKindEq (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindEq kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindEq kv2 k1 + +unifyKindEq (FunTy a1 r1) (FunTy a2 r2) + = do { mb1 <- unifyKindEq a1 a2; mb2 <- unifyKindEq r1 r2 + ; return (if isJust mb1 && isJust mb2 then Just EQ else Nothing) } + +unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) + | kc1 == kc2 + = ASSERT(length k1s == length k2s) + -- Should succeed since the kind constructors are the same, + -- and the kinds are sort-checked, thus fully applied + do { mb_eqs <- zipWithM unifyKindEq k1s k2s + ; return (if all isJust mb_eqs + then Just EQ + else Nothing) } + +unifyKindEq _ _ = return Nothing diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot new file mode 100644 index 00000000..2acecd6d --- /dev/null +++ b/compiler/typecheck/TcUnify.hs-boot @@ -0,0 +1,9 @@ +module TcUnify where +import TcType ( TcTauType ) +import TcRnTypes ( TcM ) +import TcEvidence ( TcCoercion ) + +-- This boot file exists only to tie the knot between +-- TcUnify and Inst + +unifyType :: TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs new file mode 100644 index 00000000..b844f3e6 --- /dev/null +++ b/compiler/typecheck/TcValidity.hs @@ -0,0 +1,1359 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module TcValidity ( + Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, + expectedKindInCtxt, + checkValidTheta, checkValidFamPats, + checkValidInstance, validDerivPred, + checkInstTermination, checkValidTyFamInst, checkTyFamFreeness, + checkValidTyFamEqn, checkConsistentFamInst, + arityErr, badATErr, ClsInfo + ) where + +#include "HsVersions.h" + +-- friends: +import TcUnify ( tcSubType_NC ) +import TcSimplify ( simplifyAmbiguityCheck ) +import TypeRep +import TcType +import TcMType +import TysWiredIn ( coercibleClass ) +import Type +import Unify( tcMatchTyX ) +import Kind +import CoAxiom +import Class +import TyCon + +-- others: +import HsSyn -- HsType +import TcRnMonad -- TcType, amongst others +import FunDeps +import Name +import VarEnv +import VarSet +import ErrUtils +import DynFlags +import Util +import ListSetOps +import SrcLoc +import Outputable +import FastString + +import Control.Monad +import Data.Maybe +import Data.List ( (\\) ) + +{- +************************************************************************ +* * + Checking for ambiguity +* * +************************************************************************ +-} + +checkAmbiguity :: UserTypeCtxt -> Type -> TcM () +checkAmbiguity ctxt ty + | GhciCtxt <- ctxt -- Allow ambiguous types in GHCi's :kind command + = return () -- E.g. type family T a :: * -- T :: forall k. k -> * + -- Then :k T should work in GHCi, not complain that + -- (T k) is ambiguous! + + | InfSigCtxt {} <- ctxt -- See Note [Validity of inferred types] in TcBinds + = return () + + | otherwise + = do { traceTc "Ambiguity check for" (ppr ty) + ; let free_tkvs = varSetElemsKvsFirst (closeOverKinds (tyVarsOfType ty)) + ; (subst, _tvs) <- tcInstSkolTyVars free_tkvs + ; let ty' = substTy subst ty + -- The type might have free TyVars, esp when the ambiguity check + -- happens during a call to checkValidType, + -- so we skolemise them as TcTyVars. + -- Tiresome; but the type inference engine expects TcTyVars + -- NB: The free tyvar might be (a::k), so k is also free + -- and we must skolemise it as well. Hence closeOverKinds. + -- (Trac #9222) + + -- Solve the constraints eagerly because an ambiguous type + -- can cause a cascade of further errors. Since the free + -- tyvars are skolemised, we can safely use tcSimplifyTop + ; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $ + captureConstraints $ + tcSubType_NC ctxt ty' ty' + ; simplifyAmbiguityCheck ty wanted + + ; traceTc "Done ambiguity check for" (ppr ty) } + where + mk_msg ty tidy_env + = do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes + ; (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty + ; return (tidy_env', mk_msg tidy_ty $$ ppWhen (not allow_ambiguous) ambig_msg) } + where + mk_msg ty = pprSigCtxt ctxt (ptext (sLit "the ambiguity check for")) (ppr ty) + ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") + +{- +************************************************************************ +* * + Checking validity of a user-defined type +* * +************************************************************************ + +When dealing with a user-written type, we first translate it from an HsType +to a Type, performing kind checking, and then check various things that should +be true about it. We don't want to perform these checks at the same time +as the initial translation because (a) they are unnecessary for interface-file +types and (b) when checking a mutually recursive group of type and class decls, +we can't "look" at the tycons/classes yet. Also, the checks are are rather +diverse, and used to really mess up the other code. + +One thing we check for is 'rank'. + + Rank 0: monotypes (no foralls) + Rank 1: foralls at the front only, Rank 0 inside + Rank 2: foralls at the front, Rank 1 on left of fn arrow, + + basic ::= tyvar | T basic ... basic + + r2 ::= forall tvs. cxt => r2a + r2a ::= r1 -> r2a | basic + r1 ::= forall tvs. cxt => r0 + r0 ::= r0 -> r0 | basic + +Another thing is to check that type synonyms are saturated. +This might not necessarily show up in kind checking. + type A i = i + data T k = MkT (k Int) + f :: T A -- BAD! +-} + +checkValidType :: UserTypeCtxt -> Type -> TcM () +-- Checks that the type is valid for the given context +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + ; rankn_flag <- xoptM Opt_RankNTypes + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | otherwise = r + + rank1 = gen_rank r1 + rank0 = gen_rank r0 + + r0 = rankZeroMonoType + r1 = LimitedRank True r0 + + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + PatSigCtxt -> rank0 + RuleSigCtxt _ -> rank1 + TySynCtxt _ -> rank0 + + ExprSigCtxt -> rank1 + FunSigCtxt _ -> rank1 + InfSigCtxt _ -> ArbitraryRank -- Inferred type + ConArgCtxt _ -> rank1 -- We are given the type of the entire + -- constructor, hence rank 1 + + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + ThBrackCtxt -> rank1 + GhciCtxt -> ArbitraryRank + _ -> panic "checkValidType" + -- Can't happen; not used for *user* sigs + + -- Check the internal validity of the type itself + ; check_type ctxt rank ty + + -- Check that the thing has kind Type, and is lifted if necessary. + -- Do this *after* check_type, because we can't usefully take + -- the kind of an ill-formed type such as (a~Int) + ; check_kind ctxt ty + + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } + +checkValidMonoType :: Type -> TcM () +checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty + + +check_kind :: UserTypeCtxt -> TcType -> TcM () +-- Check that the type's kind is acceptable for the context +check_kind ctxt ty + | TySynCtxt {} <- ctxt + , returnsConstraintKind actual_kind + = do { ck <- xoptM Opt_ConstraintKinds + ; if ck + then when (isConstraintKind actual_kind) + (do { dflags <- getDynFlags + ; check_pred_ty dflags ctxt ty }) + else addErrTc (constraintSynErr actual_kind) } + + | Just k <- expectedKindInCtxt ctxt + = checkTc (tcIsSubKind actual_kind k) (kindErr actual_kind) + + | otherwise + = return () -- Any kind will do + where + actual_kind = typeKind ty + +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind +expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do +expectedKindInCtxt ThBrackCtxt = Nothing +expectedKindInCtxt GhciCtxt = Nothing +expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind +expectedKindInCtxt InstDeclCtxt = Just constraintKind +expectedKindInCtxt SpecInstCtxt = Just constraintKind +expectedKindInCtxt _ = Just openTypeKind + +{- +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes +-} + +data Rank = ArbitraryRank -- Any rank ok + + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments + + | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype + + | MustBeMonoType -- Monotype regardless of flags + +rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank +rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")) +tyConArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use ImpredicativeTypes")) +synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use LiberalTypeSynonyms")) + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False + +---------------------------------------- +check_mono_type :: UserTypeCtxt -> Rank + -> KindOrType -> TcM () -- No foralls anywhere + -- No unlifted types of any kind +check_mono_type ctxt rank ty + | isKind ty = return () -- IA0_NOTE: Do we need to check kinds? + | otherwise + = do { check_type ctxt rank ty + ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } + +check_type :: UserTypeCtxt -> Rank -> Type -> TcM () +-- The args say what the *type context* requires, independent +-- of *flag* settings. You test the flag settings at usage sites. +-- +-- Rank is allowed rank for function args +-- Rank 0 means no for-alls anywhere + +check_type ctxt rank ty + | not (null tvs && null theta) + = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) + -- Reject e.g. (Maybe (?x::Int => Int)), + -- with a decent error message + ; check_valid_theta ctxt theta + ; check_type ctxt rank tau -- Allow foralls to right of arrow + ; checkAmbiguity ctxt ty } + where + (tvs, theta, tau) = tcSplitSigmaTy ty + +check_type _ _ (TyVarTy _) = return () + +check_type ctxt rank (FunTy arg_ty res_ty) + = do { check_type ctxt arg_rank arg_ty + ; check_type ctxt res_rank res_ty } + where + (arg_rank, res_rank) = funArgResRank rank + +check_type ctxt rank (AppTy ty1 ty2) + = do { check_arg_type ctxt rank ty1 + ; check_arg_type ctxt rank ty2 } + +check_type ctxt rank ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = check_syn_tc_app ctxt rank ty tc tys + | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys + | otherwise = mapM_ (check_arg_type ctxt rank) tys + +check_type _ _ (LitTy {}) = return () + +check_type _ _ ty = pprPanic "check_type" (ppr ty) + +---------------------------------------- +check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType + -> TyCon -> [KindOrType] -> TcM () +-- Used for type synonyms and type synonym families, +-- which must be saturated, +-- but not data families, which need not be saturated +check_syn_tc_app ctxt rank ty tc tys + | tc_arity <= n_args -- Saturated + -- Check that the synonym has enough args + -- This applies equally to open and closed synonyms + -- It's OK to have an *over-applied* type synonym + -- data Tree a b = ... + -- type Foo a = Tree [a] + -- f :: Foo a b -> ... + = do { -- See Note [Liberal type synonyms] + ; liberal <- xoptM Opt_LiberalTypeSynonyms + ; if not liberal || isTypeFamilyTyCon tc then + -- For H98 and synonym families, do check the type args + mapM_ check_arg tys + + else -- In the liberal case (only for closed syns), expand then check + case tcView ty of + Just ty' -> check_type ctxt rank ty' + Nothing -> pprPanic "check_tau_type" (ppr ty) } + + | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in + -- GHCi :kind commands; see Trac #7586 + = mapM_ check_arg tys + + | otherwise + = failWithTc (arityErr flavour (tyConName tc) tc_arity n_args) + where + flavour | isTypeFamilyTyCon tc = "Type family" + | otherwise = "Type synonym" + n_args = length tys + tc_arity = tyConArity tc + check_arg | isTypeFamilyTyCon tc = check_arg_type ctxt rank + | otherwise = check_mono_type ctxt synArgMonoType + +---------------------------------------- +check_ubx_tuple :: UserTypeCtxt -> KindOrType + -> [KindOrType] -> TcM () +check_ubx_tuple ctxt ty tys + = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples + ; checkTc ub_tuples_allowed (ubxArgTyErr ty) + + ; impred <- xoptM Opt_ImpredicativeTypes + ; let rank' = if impred then ArbitraryRank else tyConArgMonoType + -- c.f. check_arg_type + -- However, args are allowed to be unlifted, or + -- more unboxed tuples, so can't use check_arg_ty + ; mapM_ (check_type ctxt rank') tys } + +---------------------------------------- +check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () +-- The sort of type that can instantiate a type variable, +-- or be the argument of a type constructor. +-- Not an unboxed tuple, but now *can* be a forall (since impredicativity) +-- Other unboxed types are very occasionally allowed as type +-- arguments depending on the kind of the type constructor +-- +-- For example, we want to reject things like: +-- +-- instance Ord a => Ord (forall s. T s a) +-- and +-- g :: T s (forall b.b) +-- +-- NB: unboxed tuples can have polymorphic or unboxed args. +-- This happens in the workers for functions returning +-- product types with polymorphic components. +-- But not in user code. +-- Anyway, they are dealt with by a special case in check_tau_type + +check_arg_type ctxt rank ty + | isKind ty = return () -- IA0_NOTE: Do we need to check a kind? + | otherwise + = do { impred <- xoptM Opt_ImpredicativeTypes + ; let rank' = case rank of -- Predictive => must be monotype + MustBeMonoType -> MustBeMonoType -- Monotype, regardless + _other | impred -> ArbitraryRank + | otherwise -> tyConArgMonoType + -- Make sure that MustBeMonoType is propagated, + -- so that we don't suggest -XImpredicativeTypes in + -- (Ord (forall a.a)) => a -> a + -- and so that if it Must be a monotype, we check that it is! + + ; check_type ctxt rank' ty + ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } + -- NB the isUnLiftedType test also checks for + -- T State# + -- where there is an illegal partial application of State# (which has + -- kind * -> #); see Note [The kind invariant] in TypeRep + +---------------------------------------- +forAllTyErr :: Rank -> Type -> SDoc +forAllTyErr rank ty + = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty) + , suggestion ] + where + suggestion = case rank of + LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types") + MonoType d -> d + _ -> Outputable.empty -- Polytype is always illegal + +unliftedArgErr, ubxArgTyErr :: Type -> SDoc +unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty] +ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr ty] + +kindErr :: Kind -> SDoc +kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind] + +{- +Note [Liberal type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* +doing validity checking. This allows us to instantiate a synonym defn +with a for-all type, or with a partially-applied type synonym. + e.g. type T a b = a + type S m = m () + f :: S (T Int) +Here, T is partially applied, so it's illegal in H98. But if you +expand S first, then T we get just + f :: Int +which is fine. + +IMPORTANT: suppose T is a type synonym. Then we must do validity +checking on an appliation (T ty1 ty2) + + *either* before expansion (i.e. check ty1, ty2) + *or* after expansion (i.e. expand T ty1 ty2, and then check) + BUT NOT BOTH + +If we do both, we get exponential behaviour!! + + data TIACons1 i r c = c i ::: r c + type TIACons2 t x = TIACons1 t (TIACons1 t x) + type TIACons3 t x = TIACons2 t (TIACons1 t x) + type TIACons4 t x = TIACons2 t (TIACons2 t x) + type TIACons7 t x = TIACons4 t (TIACons3 t x) + + +************************************************************************ +* * +\subsection{Checking a theta or source type} +* * +************************************************************************ + +Note [Implicit parameters in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Implicit parameters _only_ allowed in type signatures; not in instance +decls, superclasses etc. The reason for not allowing implicit params in +instances is a bit subtle. If we allowed + instance (?x::Int, Eq a) => Foo [a] where ... +then when we saw + (e :: (?x::Int) => t) +it would be unclear how to discharge all the potential uses of the ?x +in e. For example, a constraint Foo [Int] might come out of e, and +applying the instance decl would show up two uses of ?x. Trac #8912. +-} + +checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () +checkValidTheta ctxt theta + = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) + +------------------------- +check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM () +check_valid_theta _ [] + = return () +check_valid_theta ctxt theta + = do { dflags <- getDynFlags + ; warnTc (wopt Opt_WarnDuplicateConstraints dflags && + notNull dups) (dupPredWarn dups) + ; mapM_ (check_pred_ty dflags ctxt) theta } + where + (_,dups) = removeDups cmpPred theta + +------------------------- +check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM () +-- Check the validity of a predicate in a signature +-- Do not look through any type synonyms; any constraint kinded +-- type synonyms have been checked at their definition site +-- C.f. Trac #9838 + +check_pred_ty dflags ctxt pred + = do { checkValidMonoType pred + ; check_pred_help False dflags ctxt pred } + +check_pred_help :: Bool -- True <=> under a type synonym + -> DynFlags -> UserTypeCtxt + -> PredType -> TcM () +check_pred_help under_syn dflags ctxt pred + | Just pred' <- coreView pred + = check_pred_help True dflags ctxt pred' + | otherwise + = case classifyPredType pred of + ClassPred cls tys -> check_class_pred dflags ctxt pred cls tys + EqPred NomEq _ _ -> check_eq_pred dflags pred + EqPred ReprEq ty1 ty2 -> check_repr_eq_pred dflags ctxt pred ty1 ty2 + TuplePred tys -> check_tuple_pred under_syn dflags ctxt pred tys + IrredPred _ -> check_irred_pred under_syn dflags ctxt pred + +check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () +check_class_pred dflags ctxt pred cls tys + = do { -- Class predicates are valid in all contexts + ; checkTc (arity == n_tys) arity_err + + ; checkTc (not (isIPClass cls) || okIPCtxt ctxt) + (badIPPred pred) + + -- Check the form of the argument types + ; check_class_pred_tys dflags ctxt pred tys + } + where + class_name = className cls + arity = classArity cls + n_tys = length tys + arity_err = arityErr "Class" class_name arity n_tys + +check_eq_pred :: DynFlags -> PredType -> TcM () +check_eq_pred dflags pred + = -- Equational constraints are valid in all contexts if type + -- families are permitted + checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) + (eqPredTyErr pred) + +check_repr_eq_pred :: DynFlags -> UserTypeCtxt -> PredType + -> TcType -> TcType -> TcM () +check_repr_eq_pred dflags ctxt pred ty1 ty2 + = check_class_pred_tys dflags ctxt pred tys + where + tys = [ty1, ty2] + +check_tuple_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () +check_tuple_pred under_syn dflags ctxt pred ts + = do { -- See Note [ConstraintKinds in predicates] + checkTc (under_syn || xopt Opt_ConstraintKinds dflags) + (predTupleErr pred) + ; mapM_ (check_pred_help under_syn dflags ctxt) ts } + -- This case will not normally be executed because without + -- -XConstraintKinds tuple types are only kind-checked as * + +check_irred_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> TcM () +check_irred_pred under_syn dflags ctxt pred + -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint + -- where X is a type function + = do { -- If it looks like (x t1 t2), require ConstraintKinds + -- see Note [ConstraintKinds in predicates] + -- But (X t1 t2) is always ok because we just require ConstraintKinds + -- at the definition site (Trac #9838) + checkTc (under_syn || xopt Opt_ConstraintKinds dflags || not (tyvar_head pred)) + (predIrredErr pred) + + -- Make sure it is OK to have an irred pred in this context + -- See Note [Irreducible predicates in superclasses] + ; checkTc (xopt Opt_UndecidableInstances dflags || not (dodgy_superclass ctxt)) + (predIrredBadCtxtErr pred) } + where + dodgy_superclass ctxt + = case ctxt of { ClassSCCtxt _ -> True; InstDeclCtxt -> True; _ -> False } + +{- Note [ConstraintKinds in predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't check for -XConstraintKinds under a type synonym, because that +was done at the type synonym definition site; see Trac #9838 +e.g. module A where + type C a = (Eq a, Ix a) -- Needs -XConstraintKinds + module B where + import A + f :: C a => a -> a -- Does *not* need -XConstraintKinds + +Note [Irreducible predicates in superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Allowing irreducible predicates in class superclasses is somewhat dangerous +because we can write: + + type family Fooish x :: * -> Constraint + type instance Fooish () = Foo + class Fooish () a => Foo a where + +This will cause the constraint simplifier to loop because every time we canonicalise a +(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately +solved to add+canonicalise another (Foo a) constraint. + +It is equally dangerous to allow them in instance heads because in that case the +Paterson conditions may not detect duplication of a type variable or size change. -} + +------------------------- +check_class_pred_tys :: DynFlags -> UserTypeCtxt + -> PredType -> [KindOrType] -> TcM () +check_class_pred_tys dflags ctxt pred kts + = checkTc pred_ok (predTyVarErr pred $$ how_to_allow) + where + (_, tys) = span isKind kts -- see Note [Kind polymorphic type classes] + flexible_contexts = xopt Opt_FlexibleContexts dflags + undecidable_ok = xopt Opt_UndecidableInstances dflags + + pred_ok = case ctxt of + SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine + InstDeclCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys + -- Further checks on head and theta in + -- checkInstTermination + _ -> flexible_contexts || all tyvar_head tys + how_to_allow = parens (ptext (sLit "Use FlexibleContexts to permit this")) + + +------------------------- +tyvar_head :: Type -> Bool +tyvar_head ty -- Haskell 98 allows predicates of form + | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) + | otherwise -- where a is a type variable + = case tcSplitAppTy_maybe ty of + Just (ty, _) -> tyvar_head ty + Nothing -> False + +------------------------- +okIPCtxt :: UserTypeCtxt -> Bool + -- See Note [Implicit parameters in instance decls] +okIPCtxt (ClassSCCtxt {}) = False +okIPCtxt (InstDeclCtxt {}) = False +okIPCtxt (SpecInstCtxt {}) = False +okIPCtxt _ = True + +badIPPred :: PredType -> SDoc +badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) + +{- +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +MultiParam check: + + class C f where... -- C :: forall k. k -> Constraint + instance C Maybe where... + + The dictionary gets type [C * Maybe] even if it's not a MultiParam + type class. + +Flexibility check: + + class C f where... -- C :: forall k. k -> Constraint + data D a = D a + instance C D where + + The dictionary gets type [C * (D *)]. IA0_TODO it should be + generalized actually. + +Note [The ambiguity check for type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +checkAmbiguity is a check on user-supplied type signatures. It is +*purely* there to report functions that cannot possibly be called. So for +example we want to reject: + f :: C a => Int +The idea is there can be no legal calls to 'f' because every call will +give rise to an ambiguous constraint. We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. Indeed, the flag +-XAllowAmbiguousTypes switches off the ambiguity check. + +What about things like this: + class D a b | a -> b where .. + h :: D Int b => Int +The Int may well fix 'b' at the call site, so that signature should +not be rejected. Moreover, using *visible* fundeps is too +conservative. Consider + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a +Here h's type looks ambiguous in 'b', but here's a legal call: + ...(h [True])... +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that fixes 'beta' via D's +fundep! + +Behind all these special cases there is a simple guiding principle. +Consider + + f :: + f = ...blah... + + g :: + g = f + +You would think that the definition of g would surely typecheck! +After all f has exactly the same type, and g=f. But in fact f's type +is instantiated and the instantiated constraints are solved against +the originals, so in the case an ambiguous type it won't work. +Consider our earlier example f :: C a => Int. Then in g's definition, +we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), +and fail. + +So in fact we use this as our *definition* of ambiguity. We use a +very similar test for *inferred* types, to ensure that they are +unambiguous. See Note [Impedence matching] in TcBinds. + +This test is very conveniently implemented by calling + tcSubType +This neatly takes account of the functional dependecy stuff above, +and implicit parameter (see Note [Implicit parameters and ambiguity]). + +What about this, though? + g :: C [a] => Int +Is every call to 'g' ambiguous? After all, we might have + intance C [a] where ... +at the call site. So maybe that type is ok! Indeed even f's +quintessentially ambiguous type might, just possibly be callable: +with -XFlexibleInstances we could have + instance C a where ... +and now a call could be legal after all! Well, we'll reject this +unless the instance is available *here*. + +Side note: the ambiguity check is only used for *user* types, not for +types coming from inteface files. The latter can legitimately have +ambiguous types. Example + + class S a where s :: a -> (Int,Int) + instance S Char where s _ = (1,1) + f:: S a => [a] -> Int -> (Int,Int) + f (_::[a]) x = (a*x,b) + where (a,b) = s (undefined::a) + +Here the worker for f gets the type + fw :: forall a. S a => Int -> (# Int, Int #) + +Note [Implicit parameters and ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only a *class* predicate can give rise to ambiguity +An *implicit parameter* cannot. For example: + foo :: (?x :: [a]) => Int + foo = length ?x +is fine. The call site will suppply a particular 'x' + +Furthermore, the type variables fixed by an implicit parameter +propagate to the others. E.g. + foo :: (Show a, ?x::[a]) => Int + foo = show (?x++?x) +The type of foo looks ambiguous. But it isn't, because at a call site +we might have + let ?x = 5::Int in foo +and all is well. In effect, implicit parameters are, well, parameters, +so we can take their type variables into account as part of the +"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. +-} + +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc +checkThetaCtxt ctxt theta + = vcat [ptext (sLit "In the context:") <+> pprTheta theta, + ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] + +eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predIrredBadCtxtErr :: PredType -> SDoc +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprType pred + $$ + parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) +predTyVarErr pred = hang (ptext (sLit "Non type-variable argument")) + 2 (ptext (sLit "in the constraint:") <+> pprType pred) +predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType pred) + 2 (parens constraintKindsMsg) +predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred) + 2 (parens constraintKindsMsg) +predIrredBadCtxtErr pred = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) + <+> ptext (sLit "in a superclass/instance context")) + 2 (parens undecidableMsg) + +constraintSynErr :: Type -> SDoc +constraintSynErr kind = hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr kind)) + 2 (parens constraintKindsMsg) + +dupPredWarn :: [[PredType]] -> SDoc +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprType (map head dups) + +arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc +arityErr kind name n m + = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"), + n_arguments <> comma, text "but has been given", + if m==0 then text "none" else int m] + where + n_arguments | n == 0 = ptext (sLit "no arguments") + | n == 1 = ptext (sLit "1 argument") + | True = hsep [int n, ptext (sLit "arguments")] + +{- +************************************************************************ +* * +\subsection{Checking for a decent instance head type} +* * +************************************************************************ + +@checkValidInstHead@ checks the type {\em and} its syntactic constraints: +it must normally look like: @instance Foo (Tycon a b c ...) ...@ + +The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ +flag is on, or (2)~the instance is imported (they must have been +compiled elsewhere). In these cases, we let them go through anyway. + +We can also have instances for functions: @instance Foo (a -> b) ...@. +-} + +checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () +checkValidInstHead ctxt clas cls_args + = do { dflags <- getDynFlags + + ; checkTc (clas `notElem` abstractClasses) + (instTypeErr clas cls_args abstract_class_msg) + + -- Check language restrictions; + -- but not for SPECIALISE isntance pragmas + ; let ty_args = dropWhile isKind cls_args + ; unless spec_inst_prag $ + do { checkTc (xopt Opt_TypeSynonymInstances dflags || + all tcInstHeadTyNotSynonym ty_args) + (instTypeErr clas cls_args head_type_synonym_msg) + ; checkTc (xopt Opt_FlexibleInstances dflags || + all tcInstHeadTyAppAllTyVars ty_args) + (instTypeErr clas cls_args head_type_args_tyvars_msg) + ; checkTc (xopt Opt_MultiParamTypeClasses dflags || + length ty_args == 1 || -- Only count type arguments + (xopt Opt_NullaryTypeClasses dflags && + null ty_args)) + (instTypeErr clas cls_args head_one_type_msg) } + + -- May not contain type family applications + ; mapM_ checkTyFamFreeness ty_args + + ; mapM_ checkValidMonoType ty_args + -- For now, I only allow tau-types (not polytypes) in + -- the head of an instance decl. + -- E.g. instance C (forall a. a->a) is rejected + -- One could imagine generalising that, but I'm not sure + -- what all the consequences might be + } + + where + spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } + + head_type_synonym_msg = parens ( + text "All instance types must be of the form (T t1 ... tn)" $$ + text "where T is not a synonym." $$ + text "Use TypeSynonymInstances if you want to disable this.") + + head_type_args_tyvars_msg = parens (vcat [ + text "All instance types must be of the form (T a1 ... an)", + text "where a1 ... an are *distinct type variables*,", + text "and each type variable appears at most once in the instance head.", + text "Use FlexibleInstances if you want to disable this."]) + + head_one_type_msg = parens ( + text "Only one type can be given in an instance head." $$ + text "Use MultiParamTypeClasses if you want to allow more, or zero.") + + abstract_class_msg = + text "The class is abstract, manual instances are not permitted." + +abstractClasses :: [ Class ] +abstractClasses = [ coercibleClass ] -- See Note [Coercible Instances] + +instTypeErr :: Class -> [Type] -> SDoc -> SDoc +instTypeErr cls tys msg + = hang (hang (ptext (sLit "Illegal instance declaration for")) + 2 (quotes (pprClassPred cls tys))) + 2 msg + +{- +validDeivPred checks for OK 'deriving' context. See Note [Exotic +derived instance contexts] in TcDeriv. However the predicate is +here because it uses sizeTypes, fvTypes. + +Also check for a bizarre corner case, when the derived instance decl +would look like + instance C a b => D (T a) where ... +Note that 'b' isn't a parameter of T. This gives rise to all sorts of +problems; in particular, it's hard to compare solutions for equality +when finding the fixpoint, and that means the inferContext loop does +not converge. See Trac #5287. +-} + +validDerivPred :: TyVarSet -> PredType -> Bool +validDerivPred tv_set pred + = case classifyPredType pred of + ClassPred _ tys -> check_tys tys + TuplePred ps -> all (validDerivPred tv_set) ps + EqPred {} -> False -- reject equality constraints + _ -> True -- Non-class predicates are ok + where + check_tys tys = hasNoDups fvs + && sizeTypes tys == length fvs + && all (`elemVarSet` tv_set) fvs + fvs = fvType pred + +{- +************************************************************************ +* * +\subsection{Checking instance for termination} +* * +************************************************************************ +-} + +checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type + -> TcM ([TyVar], ThetaType, Class, [Type]) +checkValidInstance ctxt hs_type ty + | Just (clas,inst_tys) <- getClassPredTys_maybe tau + , inst_tys `lengthIs` classArity clas + = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) + ; checkValidTheta ctxt theta + + -- The Termination and Coverate Conditions + -- Check that instance inference will terminate (if we care) + -- For Haskell 98 this will already have been done by checkValidTheta, + -- but as we may be using other extensions we need to check. + -- + -- Note that the Termination Condition is *more conservative* than + -- the checkAmbiguity test we do on other type signatures + -- e.g. Bar a => Bar Int is ambiguous, but it also fails + -- the termination condition, because 'a' appears more often + -- in the constraint than in the head + ; undecidable_ok <- xoptM Opt_UndecidableInstances + ; if undecidable_ok + then checkAmbiguity ctxt ty + else checkInstTermination inst_tys theta + + ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of + IsValid -> return () -- Check succeeded + NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) + + ; return (tvs, theta, clas, inst_tys) } + + | otherwise + = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau) + where + (tvs, theta, tau) = tcSplitSigmaTy ty + + -- The location of the "head" of the instance + head_loc = case hs_type of + L _ (HsForAllTy _ _ _ _ (L loc _)) -> loc + L loc _ -> loc + +{- +Note [Paterson conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Termination test: the so-called "Paterson conditions" (see Section 5 of +"Understanding functionsl dependencies via Constraint Handling Rules, +JFP Jan 2007). + +We check that each assertion in the context satisfies: + (1) no variable has more occurrences in the assertion than in the head, and + (2) the assertion has fewer constructors and variables (taken together + and counting repetitions) than the head. +This is only needed with -fglasgow-exts, as Haskell 98 restrictions +(which have already been checked) guarantee termination. + +The underlying idea is that + + for any ground substitution, each assertion in the + context has fewer type constructors than the head. +-} + +checkInstTermination :: [TcType] -> ThetaType -> TcM () +-- See Note [Paterson conditions] +checkInstTermination tys theta + = check_preds theta + where + fvs = fvTypes tys + size = sizeTypes tys + + check_preds :: [PredType] -> TcM () + check_preds preds = mapM_ check preds + + check :: PredType -> TcM () + check pred + = case classifyPredType pred of + TuplePred preds -> check_preds preds -- Look inside tuple predicates; Trac #8359 + EqPred {} -> return () -- You can't get from equalities + -- to class predicates, so this is safe + _other -- ClassPred, IrredPred + | not (null bad_tvs) + -> addErrTc (predUndecErr pred (nomoreMsg bad_tvs) $$ parens undecidableMsg) + | sizePred pred >= size + -> addErrTc (predUndecErr pred smallerMsg $$ parens undecidableMsg) + | otherwise + -> return () + where + bad_tvs = filterOut isKindVar (fvType pred \\ fvs) + -- Rightly or wrongly, we only check for + -- excessive occurrences of *type* variables. + -- e.g. type instance Demote {T k} a = T (Demote {k} (Any {k})) + +predUndecErr :: PredType -> SDoc -> SDoc +predUndecErr pred msg = sep [msg, + nest 2 (ptext (sLit "in the constraint:") <+> pprType pred)] + +nomoreMsg :: [TcTyVar] -> SDoc +nomoreMsg tvs + = sep [ ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) + , (if isSingleton tvs then ptext (sLit "occurs") + else ptext (sLit "occur")) + <+> ptext (sLit "more often than in the instance head") ] + +smallerMsg, undecidableMsg, constraintKindsMsg :: SDoc +smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") +undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") +constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") + +{- +Note [Associated type instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow this: + class C a where + type T x a + instance C Int where + type T (S y) Int = y + type T Z Int = Char + +Note that + a) The variable 'x' is not bound by the class decl + b) 'x' is instantiated to a non-type-variable in the instance + c) There are several type instance decls for T in the instance + +All this is fine. Of course, you can't give any *more* instances +for (T ty Int) elsewhere, because it's an *associated* type. + +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + class C a b where + type T a x b + + instance C [p] Int + type T [p] y Int = (p,y,y) -- Induces the family instance TyCon + -- type TR p y = (p,y,y) + +So we + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int + +We do *not* assume (at this point) the the bound variables of +the assoicated type instance decl are the same as for the parent +instance decl. So, for example, + + instance C [p] Int + type T [q] y Int = ... + +would work equally well. Reason: making the *kind* variables line +up is much harder. Example (Trac #7282): + class Foo (xs :: [k]) where + type Bar xs :: * + + instance Foo '[] where + type Bar '[] = Int +Here the instance decl really looks like + instance Foo k ('[] k) where + type Bar k ('[] k) = Int +but the k's are not scoped, and hence won't match Uniques. + +So instead we just match structure, with tcMatchTyX, and check +that distinct type variables match 1-1 with distinct type variables. + +HOWEVER, we *still* make the instance type variables scope over the +type instances, to pick up non-obvious kinds. Eg + class Foo (a :: k) where + type F a + instance Foo (b :: k -> k) where + type F b = Int +Here the instance is kind-indexed and really looks like + type F (k->k) (b::k->k) = Int +But if the 'b' didn't scope, we would make F's instance too +poly-kinded. +-} + +-- | Extra information needed when type-checking associated types. The 'Class' is +-- the enclosing class, and the @VarEnv Type@ maps class variables to their +-- instance types. +type ClsInfo = (Class, VarEnv Type) + +checkConsistentFamInst + :: Maybe ( Class + , VarEnv Type ) -- ^ Class of associated type + -- and instantiation of class TyVars + -> TyCon -- ^ Family tycon + -> [TyVar] -- ^ Type variables of the family instance + -> [Type] -- ^ Type patterns from instance + -> TcM () +-- See Note [Checking consistent instantiation] + +checkConsistentFamInst Nothing _ _ _ = return () +checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys + = do { -- Check that the associated type indeed comes from this class + checkTc (Just clas == tyConAssoc_maybe fam_tc) + (badATErr (className clas) (tyConName fam_tc)) + + -- See Note [Checking consistent instantiation] in TcTyClsDecls + -- Check right to left, so that we spot type variable + -- inconsistencies before (more confusing) kind variables + ; discardResult $ foldrM check_arg emptyTvSubst $ + tyConTyVars fam_tc `zip` at_tys } + where + at_tv_set = mkVarSet at_tvs + + check_arg :: (TyVar, Type) -> TvSubst -> TcM TvSubst + check_arg (fam_tc_tv, at_ty) subst + | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv + = case tcMatchTyX at_tv_set subst at_ty inst_ty of + Just subst | all_distinct subst -> return subst + _ -> failWithTc $ wrongATArgErr at_ty inst_ty + -- No need to instantiate here, because the axiom + -- uses the same type variables as the assocated class + | otherwise + = return subst -- Allow non-type-variable instantiation + -- See Note [Associated type instances] + + all_distinct :: TvSubst -> Bool + -- True if all the variables mapped the substitution + -- map to *distinct* type *variables* + all_distinct subst = go [] at_tvs + where + go _ [] = True + go acc (tv:tvs) = case lookupTyVar subst tv of + Nothing -> go acc tvs + Just ty | Just tv' <- tcGetTyVar_maybe ty + , tv' `notElem` acc + -> go (tv' : acc) tvs + _other -> False + +badATErr :: Name -> Name -> SDoc +badATErr clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "does not have an associated type"), quotes (ppr op)] + +wrongATArgErr :: Type -> Type -> SDoc +wrongATArgErr ty instTy = + sep [ ptext (sLit "Type indexes must match class instance head") + , ptext (sLit "Found") <+> quotes (ppr ty) + <+> ptext (sLit "but expected") <+> quotes (ppr instTy) + ] + +{- +************************************************************************ +* * + Checking type instance well-formedness and termination +* * +************************************************************************ +-} + +-- Check that a "type instance" is well-formed (which includes decidability +-- unless -XUndecidableInstances is given). +-- +checkValidTyFamInst :: Maybe ( Class, VarEnv Type ) + -> TyCon -> CoAxBranch -> TcM () +checkValidTyFamInst mb_clsinfo fam_tc + (CoAxBranch { cab_tvs = tvs, cab_lhs = typats + , cab_rhs = rhs, cab_loc = loc }) + = checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc + +-- | Do validity checks on a type family equation, including consistency +-- with any enclosing class instance head, termination, and lack of +-- polytypes. +checkValidTyFamEqn :: Maybe ClsInfo + -> TyCon -- ^ of the type family + -> [TyVar] -- ^ bound tyvars in the equation + -> [Type] -- ^ type patterns + -> Type -- ^ rhs + -> SrcSpan + -> TcM () +checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc + = setSrcSpan loc $ + do { checkValidFamPats fam_tc tvs typats + + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See Trac #9357 + ; mapM_ checkValidMonoType typats + ; checkValidMonoType rhs + + -- We have a decidable instance unless otherwise permitted + ; undecidable_ok <- xoptM Opt_UndecidableInstances + ; unless undecidable_ok $ + mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) + + -- Check that type patterns match the class instance head + ; checkConsistentFamInst mb_clsinfo fam_tc tvs typats } + +-- Make sure that each type family application is +-- (1) strictly smaller than the lhs, +-- (2) mentions no type variable more often than the lhs, and +-- (3) does not contain any further type family instances. +-- +checkFamInstRhs :: [Type] -- lhs + -> [(TyCon, [Type])] -- type family instances + -> [MsgDoc] +checkFamInstRhs lhsTys famInsts + = mapMaybe check famInsts + where + size = sizeTypes lhsTys + fvs = fvTypes lhsTys + check (tc, tys) + | not (all isTyFamFree tys) + = Just (famInstUndecErr famInst nestedMsg $$ parens undecidableMsg) + | not (null bad_tvs) + = Just (famInstUndecErr famInst (nomoreMsg bad_tvs) $$ parens undecidableMsg) + | size <= sizeTypes tys + = Just (famInstUndecErr famInst smallerAppMsg $$ parens undecidableMsg) + | otherwise + = Nothing + where + famInst = TyConApp tc tys + bad_tvs = filterOut isKindVar (fvTypes tys \\ fvs) + -- Rightly or wrongly, we only check for + -- excessive occurrences of *type* variables. + -- e.g. type instance Demote {T k} a = T (Demote {k} (Any {k})) + +checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () +-- Patterns in a 'type instance' or 'data instance' decl should +-- a) contain no type family applications +-- (vanilla synonyms are fine, though) +-- b) properly bind all their free type variables +-- e.g. we disallow (Trac #7536) +-- type T a = Int +-- type instance F (T a) = a +-- c) Have the right number of patterns +checkValidFamPats fam_tc tvs ty_pats + = ASSERT( length ty_pats == tyConArity fam_tc ) + -- A family instance must have exactly the same number of type + -- parameters as the family declaration. You can't write + -- type family F a :: * -> * + -- type instance F Int y = y + -- because then the type (F Int) would be like (\y.y) + -- But this is checked at the time the axiom is created + do { mapM_ checkTyFamFreeness ty_pats + ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs + ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) } + +-- Ensure that no type family instances occur in a type. +checkTyFamFreeness :: Type -> TcM () +checkTyFamFreeness ty + = checkTc (isTyFamFree ty) $ + tyFamInstIllegalErr ty + +-- Check that a type does not contain any type family applications. +-- +isTyFamFree :: Type -> Bool +isTyFamFree = null . tcTyFamInsts + +-- Error messages + +tyFamInstIllegalErr :: Type -> SDoc +tyFamInstIllegalErr ty + = hang (ptext (sLit "Illegal type synonym family application in instance") <> + colon) 2 $ + ppr ty + +famInstUndecErr :: Type -> SDoc -> SDoc +famInstUndecErr ty msg + = sep [msg, + nest 2 (ptext (sLit "in the type family application:") <+> + pprType ty)] + +famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc +famPatErr fam_tc tvs pats + = hang (ptext (sLit "Family instance purports to bind type variable") <> plural tvs + <+> pprQuotedList tvs) + 2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:")) + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ..."))) + +nestedMsg, smallerAppMsg :: SDoc +nestedMsg = ptext (sLit "Nested type family application") +smallerAppMsg = ptext (sLit "Application is no smaller than the instance head") + +{- +************************************************************************ +* * +\subsection{Auxiliary functions} +* * +************************************************************************ +-} + +-- Free variables of a type, retaining repetitions, and expanding synonyms +fvType :: Type -> [TyVar] +fvType ty | Just exp_ty <- tcView ty = fvType exp_ty +fvType (TyVarTy tv) = [tv] +fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] +fvType (FunTy arg res) = fvType arg ++ fvType res +fvType (AppTy fun arg) = fvType fun ++ fvType arg +fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) + +fvTypes :: [Type] -> [TyVar] +fvTypes tys = concat (map fvType tys) + +sizeType :: Type -> Int +-- Size of a type: the number of variables and constructors +sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty +sizeType (TyVarTy {}) = 1 +sizeType (TyConApp _ tys) = sizeTypes tys + 1 +sizeType (LitTy {}) = 1 +sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 +sizeType (AppTy fun arg) = sizeType fun + sizeType arg +sizeType (ForAllTy _ ty) = sizeType ty + +sizeTypes :: [Type] -> Int +-- IA0_NOTE: Avoid kinds. +sizeTypes xs = sum (map sizeType tys) + where tys = filter (not . isKind) xs + +-- Size of a predicate +-- +-- We are considering whether class constraints terminate. +-- Equality constraints and constraints for the implicit +-- parameter class always termiante so it is safe to say "size 0". +-- (Implicit parameter constraints always terminate because +-- there are no instances for them---they are only solved by +-- "local instances" in expressions). +-- See Trac #4200. +sizePred :: PredType -> Int +sizePred ty = goClass ty + where + goClass p | isIPPred p = 0 + | otherwise = go (classifyPredType p) + + go (ClassPred _ tys') = sizeTypes tys' + go (EqPred {}) = 0 + go (TuplePred ts) = sum (map goClass ts) + go (IrredPred ty) = sizeType ty + +{- +Note [Paterson conditions on PredTypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are considering whether *class* constraints terminate +(see Note [Paterson conditions]). Precisely, the Paterson conditions +would have us check that "the constraint has fewer constructors and variables +(taken together and counting repetitions) than the head.". + +However, we can be a bit more refined by looking at which kind of constraint +this actually is. There are two main tricks: + + 1. It seems like it should be OK not to count the tuple type constructor + for a PredType like (Show a, Eq a) :: Constraint, since we don't + count the "implicit" tuple in the ThetaType itself. + + In fact, the Paterson test just checks *each component* of the top level + ThetaType against the size bound, one at a time. By analogy, it should be + OK to return the size of the *largest* tuple component as the size of the + whole tuple. + + 2. Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See Trac #4200. + +NB: we don't want to detect PredTypes in sizeType (and then call +sizePred on them), or we might get an infinite loop if that PredType +is irreducible. See Trac #5581. +-} diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs new file mode 100644 index 00000000..f15f930d --- /dev/null +++ b/compiler/types/Class.hs @@ -0,0 +1,299 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module Class ( + Class, + ClassOpItem, DefMeth (..), + ClassATItem(..), + ClassMinimalDef, + defMethSpecOfDefMeth, + + FunDep, pprFundeps, pprFunDep, + + mkClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classAllSelIds, classSCSelId, classMinimalDef + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) +import {-# SOURCE #-} TypeRep ( Type, PredType ) +import Var +import Name +import BasicTypes +import Unique +import Util +import SrcLoc +import Outputable +import FastString +import BooleanFormula (BooleanFormula) + +import Data.Typeable (Typeable) +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in TypeRep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + classSCTheta :: [PredType], -- Immediate superclasses, + classSCSels :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + classATStuff :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + classOpStuff :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + classMinimalDef :: ClassMinimalDef + } + deriving Typeable + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', + +-- For details on above see note [Api annotations] in ApiAnnotation +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMeth) + -- Selector function; contains unfolding + -- Default-method info + +data DefMeth = NoDefMeth -- No default method + | DefMeth Name -- A polymorphic default method + | GenDefMeth Name -- A generic default method + deriving Eq + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, SrcSpan)) + -- Default associated type (if any) from this template + -- Note [Associated type defaults] + +type ClassMinimalDef = BooleanFormula Name -- Required methods + +-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in +-- the `DefMeth` constructor of the `DefMeth`. +defMethSpecOfDefMeth :: DefMeth -> DefMethSpec +defMethSpecOfDefMeth meth + = case meth of + NoDefMeth -> NoDM + DefMeth _ -> VanillaDM + GenDefMeth _ -> GenericDM + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: [TyVar] + -> [([TyVar], [TyVar])] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = tyConUnique tycon, + className = tyConName tycon, + classTyVars = tyvars, + classFunDeps = fds, + classSCTheta = super_classes, + classSCSels = superdict_sels, + classATStuff = at_stuff, + classOpStuff = op_stuff, + classMinimalDef = mindef, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similary 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in TcTyClsDecls) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class {classSCSels = sc_sels}) + = sc_sels ++ classMethods c + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classSCSels = sc_sels }) n + = ASSERT( n >= 0 && n < length sc_sels ) + sc_sels !! n + +classMethods :: Class -> [Id] +classMethods (Class {classOpStuff = op_stuff}) + = [op_sel | (op_sel, _) <- op_stuff] + +classOpItems :: Class -> [ClassOpItem] +classOpItems = classOpStuff + +classATs :: Class -> [TyCon] +classATs (Class { classATStuff = at_stuff }) + = [tc | ATI tc _ <- at_stuff] + +classATItems :: Class -> [ClassATItem] +classATItems = classATStuff + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c + = (classTyVars c, classFunDeps c) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, + classSCSels = sc_sels, classOpStuff = op_stuff}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classSCTheta = sc_theta, classSCSels = sc_sels, + classATStuff = ats, classOpStuff = op_stuff}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Ord Class where + c1 <= c2 = classKey c1 <= classKey c2 + c1 < c2 = classKey c1 < classKey c2 + c1 >= c2 = classKey c1 >= classKey c2 + c1 > c2 = classKey c1 > classKey c2 + compare c1 c2 = classKey c1 `compare` classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +instance Outputable DefMeth where + ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n + ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n + ppr NoDefMeth = empty -- No default method + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs new file mode 100644 index 00000000..a3e2bb22 --- /dev/null +++ b/compiler/types/CoAxiom.hs @@ -0,0 +1,532 @@ +-- (c) The University of Glasgow 2012 + +{-# LANGUAGE CPP, DeriveDataTypeable, GADTs, ScopedTypeVariables #-} + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module CoAxiom ( + Branched, Unbranched, BranchIndex, BranchList(..), + toBranchList, fromBranchList, + toBranchedList, toUnbranchedList, + brListLength, brListNth, brListMap, brListFoldr, brListMapM, + brListFoldlM_, brListZipWith, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), Eqn, + BuiltInSynFamily(..), trivialBuiltInFamily + ) where + +import {-# SOURCE #-} TypeRep ( Type ) +import {-# SOURCE #-} TyCon ( TyCon ) +import Outputable +import FastString +import Name +import Unique +import Var +import Util +import Binary +import Pair +import BasicTypes +import Data.Typeable ( Typeable ) +import SrcLoc +import qualified Data.Data as Data + +#include "HsVersions.h" + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow type family instance groups, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type instance where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: BOX) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Branched instance checking] in FamInstEnv.hs. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances declared with "type instance ...", not +"type instance where". Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The list of branches +is stored using a special form of list, declared below, that ensures that the +type variable is accurate. + +As of this writing (Dec 2012), it would not be appropriate to use a promoted +type as the phantom type, so we use empty datatypes. We wish to have GHC +remain compilable with GHC 7.2.1. If you are revising this code and GHC no +longer needs to remain compatible with GHC 7.2.x, then please update this +code to use promoted types. + + +************************************************************************ +* * + Branch lists +* * +************************************************************************ +-} + +type BranchIndex = Int -- The index of the branch in the list of branches + -- Counting from zero + +-- the phantom type labels +data Unbranched deriving Typeable +data Branched deriving Typeable + +data BranchList a br where + FirstBranch :: a -> BranchList a br + NextBranch :: a -> BranchList a br -> BranchList a Branched + +-- convert to/from lists +toBranchList :: [a] -> BranchList a Branched +toBranchList [] = pprPanic "toBranchList" empty +toBranchList [b] = FirstBranch b +toBranchList (h:t) = NextBranch h (toBranchList t) + +fromBranchList :: BranchList a br -> [a] +fromBranchList (FirstBranch b) = [b] +fromBranchList (NextBranch h t) = h : (fromBranchList t) + +-- convert from any BranchList to a Branched BranchList +toBranchedList :: BranchList a br -> BranchList a Branched +toBranchedList (FirstBranch b) = FirstBranch b +toBranchedList (NextBranch h t) = NextBranch h t + +-- convert from any BranchList to an Unbranched BranchList +toUnbranchedList :: BranchList a br -> BranchList a Unbranched +toUnbranchedList (FirstBranch b) = FirstBranch b +toUnbranchedList _ = pprPanic "toUnbranchedList" empty + +-- length +brListLength :: BranchList a br -> Int +brListLength (FirstBranch _) = 1 +brListLength (NextBranch _ t) = 1 + brListLength t + +-- lookup +brListNth :: BranchList a br -> BranchIndex -> a +brListNth (FirstBranch b) 0 = b +brListNth (NextBranch h _) 0 = h +brListNth (NextBranch _ t) n = brListNth t (n-1) +brListNth _ _ = pprPanic "brListNth" empty + +-- map, fold +brListMap :: (a -> b) -> BranchList a br -> [b] +brListMap f (FirstBranch b) = [f b] +brListMap f (NextBranch h t) = f h : (brListMap f t) + +brListFoldr :: (a -> b -> b) -> b -> BranchList a br -> b +brListFoldr f x (FirstBranch b) = f b x +brListFoldr f x (NextBranch h t) = f h (brListFoldr f x t) + +brListMapM :: Monad m => (a -> m b) -> BranchList a br -> m [b] +brListMapM f (FirstBranch b) = f b >>= \fb -> return [fb] +brListMapM f (NextBranch h t) = do { fh <- f h + ; ft <- brListMapM f t + ; return (fh : ft) } + +brListFoldlM_ :: forall a b m br. Monad m + => (a -> b -> m a) -> a -> BranchList b br -> m () +brListFoldlM_ f z brs = do { _ <- go z brs + ; return () } + where go :: forall br'. Monad m => a -> BranchList b br' -> m a + go acc (FirstBranch b) = f acc b + go acc (NextBranch h t) = do { fh <- f acc h + ; go fh t } + +-- zipWith +brListZipWith :: (a -> b -> c) -> BranchList a br1 -> BranchList b br2 -> [c] +brListZipWith f (FirstBranch a) (FirstBranch b) = [f a b] +brListZipWith f (FirstBranch a) (NextBranch b _) = [f a b] +brListZipWith f (NextBranch a _) (FirstBranch b) = [f a b] +brListZipWith f (NextBranch a ta) (NextBranch b tb) = f a b : brListZipWith f ta tb + +-- pretty-printing + +instance Outputable a => Outputable (BranchList a br) where + ppr = ppr . fromBranchList + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on +the unification algorithm.) Although we could theoretically compute +compatibility on the fly, this is silly, so we store it in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- unique identifier + , co_ax_name :: Name -- name for pretty-printing + , co_ax_role :: Role -- role of the axiom's equality + , co_ax_tc :: TyCon -- the head of the LHS patterns + , co_ax_branches :: BranchList CoAxBranch br + -- the branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + deriving Typeable + +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + , cab_rhs :: Type -- Right-hand side of the equality + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Typeable + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranchedList branches) implicit + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranchedList branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = brListNth bs index + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length $ cab_tvs $ coAxiomNthBranch ax index + +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> BranchList CoAxBranch br +coAxiomBranches = co_ax_branches + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = branches }) + | FirstBranch br <- branches + = Just br + | otherwise + = Nothing + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = FirstBranch br }) = br + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility checking] in FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables (where possible) as the +enclosing class or instance. Consider + class C a b where + type F x b + type F [y] b = ... -- Second param must be b + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +Similarly in the CoAxBranch for the default decl for F in the +class decl, we use the same 'b' to make the same check easy. + +So, unlike FamInsts, there is no expectation that the cab_tvs +are fresh wrt each other, or any other CoAxBranch. + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in HscTypes +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration +-} + +instance Eq (CoAxiom br) where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord (CoAxiom br) where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = getUnique a `compare` getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance Outputable (CoAxiom br) where + ppr = ppr . getName + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- See Note [Roles] in Coercion +-- defined here to avoid cyclic dependency with Coercion +data Role = Nominal | Representational | Phantom + deriving (Eq, Data.Data, Data.Typeable) + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in RdrHsSyn +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: + + forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 + +My intention is to reuse these for both (~) and (~#). +The short-term plan is to use this datatype to represent the type-nat axioms. +In the longer run, it may be good to unify this and `CoAxiom`, +as `CoAxiom` is the special case when there are no assumptions. +-} + +-- | A more explicit representation for `t1 ~ t2`. +type Eqn = Pair Type + +-- | For now, we work only with nominal equality. +data CoAxiomRule = CoAxiomRule + { coaxrName :: FastString + , coaxrTypeArity :: Int -- number of type argumentInts + , coaxrAsmpRoles :: [Role] -- roles of parameter equations + , coaxrRole :: Role -- role of resulting equation + , coaxrProves :: [Type] -> [Eqn] -> Maybe Eqn + -- ^ coaxrProves returns @Nothing@ when it doesn't like + -- the supplied arguments. When this happens in a coercion + -- that means that the coercion is ill-formed, and Core Lint + -- checks for that. + } deriving Typeable + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Uniquable CoAxiomRule where + getUnique = getUnique . coaxrName + +instance Eq CoAxiomRule where + x == y = coaxrName x == coaxrName y + +instance Ord CoAxiomRule where + compare x y = compare (coaxrName x) (coaxrName y) + +instance Outputable CoAxiomRule where + ppr = ppr . coaxrName + + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + , sfInteractTop :: [Type] -> Type -> [Eqn] + , sfInteractInert :: [Type] -> Type -> + [Type] -> Type -> [Eqn] + } + +-- Provides default implementations that do nothing. +trivialBuiltInFamily :: BuiltInSynFamily +trivialBuiltInFamily = BuiltInSynFamily + { sfMatchFam = \_ -> Nothing + , sfInteractTop = \_ _ -> [] + , sfInteractInert = \_ _ _ _ -> [] + } diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs new file mode 100644 index 00000000..2a3da3bd --- /dev/null +++ b/compiler/types/Coercion.hs @@ -0,0 +1,2012 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'CoreSyn.Expr' for +-- more on System FC and how coercions fit into it. +-- +module Coercion ( + -- * Main data type + Coercion(..), Var, CoVar, + LeftOrRight(..), pickLR, + Role(..), ltRole, + + -- ** Functions over coercions + coVarKind, coVarRole, + coercionType, coercionKind, coercionKinds, isReflCo, + isReflCo_maybe, coercionRole, coercionKindRole, + mkCoercionType, + + -- ** Constructing coercions + mkReflCo, mkCoVarCo, + mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstLHS, mkAxInstRHS, + mkUnbranchedAxInstRHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCoFlexible, mkTyConAppCo, mkFunCo, + mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo, + mkNewTypeCo, downgradeRole, + mkAxiomRuleCo, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, + modifyStepResultCo, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX_maybe, + + decomposeCo, getCoVar_maybe, + splitAppCo_maybe, + splitForAllCo_maybe, + nthRole, tyConRolesX, + setNominalRole_maybe, + + -- ** Coercion variables + mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar, + isEmptyCvSubst, zapCvSubstEnv, getCvInScope, + substCo, substCos, substCoVar, substCoVars, + substCoWithTy, substCoWithTys, + cvTvSubst, tvCvSubst, mkCvSubst, zipOpenCvSubst, + substTy, extendTvSubst, + extendCvSubstAndInScope, extendTvSubstAndInScope, + substTyVarBndr, substCoVarBndr, + + -- ** Lifting + liftCoMatch, liftCoSubstTyVar, liftCoSubstWith, + + -- ** Comparison + coreEqCoercion, coreEqCoercion2, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + applyCo, + ) where + +#include "HsVersions.h" + +import Unify ( MatchEnv(..), matchList ) +import TypeRep +import qualified Type +import Type hiding( substTy, substTyVarBndr, extendTvSubst ) +import TyCon +import CoAxiom +import Var +import VarEnv +import VarSet +import Binary +import Maybes ( orElse ) +import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan ) +import OccName ( parenSymOcc ) +import Util +import BasicTypes +import Outputable +import Unique +import Pair +import SrcLoc +import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative hiding ( empty ) +import Data.Traversable (traverse, sequenceA) +#endif +import FastString +import ListSetOps + +import qualified Data.Data as Data hiding ( TyCon ) +import Control.Arrow ( first ) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. P, N, and R stand for coercions of the + -- given role. e stands for a coercion of a specific unknown role (think + -- "role polymorphism"). "e" stands for an explicit role parameter + -- indicating role e. _ stands for a parameter that is not a Role or + -- Coercion. + + -- These ones mirror the shape of types + = -- Refl :: "e" -> _ -> e + Refl Role Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (Refl Representational _), not (SubCo (Refl Nominal _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + + | AppCo Coercion Coercion -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyVar Coercion -- forall a. g + -- :: _ -> e -> e + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> [N] -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] + + -- see Note [UnivCo] + | UnivCo FastString Role Type Type -- :: "e" -> _ -> _ -> e + -- the FastString is just a note for provenance + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + -- The number of types and coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + | AxiomRuleCo CoAxiomRule [Type] [Coercion] + + -- These are destructors + + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- See Note [NthCo and newtypes] + + | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion Type + -- :: e -> _ -> e + + | SubCo Coercion -- Turns a ~N into a ~R + -- :: N -> R + deriving (Data.Data, Data.Typeable) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data LeftOrRight = CLeft | CRight + deriving( Eq, Data.Data, Data.Typeable ) + +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Coercions have the following invariant + Refl is always lifted as far as possible. + +You might think that a consequencs is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky. +Currently, the situation is as follows: + + ForAllCo TyVar Coercion + +represents a coercion between polymorphic types, with the rule + + v : k g : t1 ~ t2 + ---------------------------------------------- + ForAllCo v g : (all v:k . t1) ~ (all v:k . t2) + +Note that it's only necessary to coerce between polymorphic types +where the type variables have identical kinds, because equality on +kinds is trivial. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Kind coercions] +~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: * -> *, and g :: A ~ B +Then the coercion + TyConAppCo T [g] T g : T A ~ T B + +Now suppose S :: forall k. k -> *, and g :: A ~ B +Then the coercion + TyConAppCo S [Refl *, g] T <*> g : T * A ~ T * B + +Notice that the arguments to TyConAppCo are coercions, but the first +represents a *kind* coercion. Now, we don't allow any non-trivial kind +coercions, so it's an invariant that any such kind coercions are Refl. +Lint checks this. + +However it's inconvenient to insist that these kind coercions are always +*structurally* (Refl k), because the key function exprIsConApp_maybe +pushes coercions into constructor arguments, so + C k ty e |> g +may turn into + C (Nth 0 g) .... +Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [UnivCo] +~~~~~~~~~~~~~ +The UnivCo ("universal coercion") serves two rather separate functions: + - the implementation for unsafeCoerce# + - placeholder for phantom parameters in a TyConAppCo + +At Representational, it asserts that two (possibly unrelated) +types have the same representation and can be casted to one another. +This form is necessary for unsafeCoerce#. + +For optimisation purposes, it is convenient to allow UnivCo to appear +at Nominal role. If we have + +data Foo a = MkFoo (F a) -- F is a type family + +and we want an unsafe coercion from Foo Int to Foo Bool, then it would +be nice to have (TyConAppCo Foo (UnivCo Nominal Int Bool)). So, we allow +Nominal UnivCo's. + +At Phantom role, it is used as an argument to TyConAppCo in the place +of a phantom parameter (a type parameter unused in the type definition). + +For example: + +data Q a = MkQ Int + +We want a coercion for (Q Bool) ~R (Q Char). + +(TyConAppCo Representational Q [UnivCo Phantom Bool Char]) does the trick. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + +newtype Age = MkAge Int + +Nominal: All arguments must have role Nominal. Why? So that Foo Age ~N Foo Int +does *not* hold. + +Representational: All arguments must have the roles corresponding to the +result of tyConRoles on the TyCon. This is the whole point of having +roles on the TyCon to begin with. So, we can have Foo Age ~R Foo Int, +if Foo's parameter has role R. + +If a Representational TyConAppCo is over-saturated (which is otherwise fine), +the spill-over arguments must all be at Nominal. This corresponds to the +behavior for AppCo. + +Phantom: All arguments must have role Phantom. This one isn't strictly +necessary for soundness, but this choice removes ambiguity. + + + +The rules here also dictate what the parameters to mkTyConAppCo. + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +************************************************************************ +* * +\subsection{Coercion variables} +* * +************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +isCoVar :: Var -> Bool +isCoVar v = isCoVarType (varType v) + +isCoVarType :: Type -> Bool +isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality + = case splitTyConApp_maybe ty of + Just (tc,tys) -> (tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) + && tys `lengthAtLeast` 2 + Nothing -> False + +tyCoVarsOfCo :: Coercion -> VarSet +-- Extracts type and coercion variables from a coercion +tyCoVarsOfCo (Refl _ ty) = tyVarsOfType ty +tyCoVarsOfCo (TyConAppCo _ _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv +tyCoVarsOfCo (CoVarCo v) = unitVarSet v +tyCoVarsOfCo (AxiomInstCo _ _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (UnivCo _ _ ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co +tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty +tyCoVarsOfCo (SubCo co) = tyCoVarsOfCo co +tyCoVarsOfCo (AxiomRuleCo _ ts cs) = tyVarsOfTypes ts `unionVarSet` tyCoVarsOfCos cs + +tyCoVarsOfCos :: [Coercion] -> VarSet +tyCoVarsOfCos = mapUnionVarSet tyCoVarsOfCo + +coVarsOfCo :: Coercion -> VarSet +-- Extract *coerction* variables only. Tiresome to repeat the code, but easy. +coVarsOfCo (Refl _ _) = emptyVarSet +coVarsOfCo (TyConAppCo _ _ cos) = coVarsOfCos cos +coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (ForAllCo _ co) = coVarsOfCo co +coVarsOfCo (CoVarCo v) = unitVarSet v +coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos +coVarsOfCo (UnivCo _ _ _ _) = emptyVarSet +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co _) = coVarsOfCo co +coVarsOfCo (SubCo co) = coVarsOfCo co +coVarsOfCo (AxiomRuleCo _ _ cos) = coVarsOfCos cos + +coVarsOfCos :: [Coercion] -> VarSet +coVarsOfCos = mapUnionVarSet coVarsOfCo + +coercionSize :: Coercion -> Int +coercionSize (Refl _ ty) = typeSize ty +coercionSize (TyConAppCo _ _ cos) = 1 + sum (map coercionSize cos) +coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 +coercionSize (ForAllCo _ co) = 1 + coercionSize co +coercionSize (CoVarCo _) = 1 +coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos) +coercionSize (UnivCo _ _ ty1 ty2) = typeSize ty1 + typeSize ty2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ tys cos) = 1 + sum (map typeSize tys) + + sum (map coercionSize cos) + +{- +************************************************************************ +* * + Tidying coercions +* * +************************************************************************ +-} + +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go (Refl r ty) = Refl r (tidyType env ty) + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) + where + (envp, tvp) = tidyTyVarBndr env tv + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (AxiomInstCo con ind cos) = let args = tidyCos env cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo s r ty1 ty2) = (UnivCo s r $! tidyType env ty1) $! tidyType env ty2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty + go (SubCo co) = SubCo $! go co + + go (AxiomRuleCo ax tys cos) = let tys1 = map (tidyType env) tys + cos1 = tidyCos env cos + in tys1 `seqList` cos1 `seqList` + AxiomRuleCo ax tys1 cos1 + + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) + +{- +************************************************************************ +* * + Pretty-printing coercions +* * +************************************************************************ + +@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ +function is defined to use this. @pprParendCo@ is the same, except it +puts parens around the type, except for the atomic cases. +@pprParendCo@ works just by setting the initial context precedence +very high. +-} + +instance Outputable Coercion where + ppr = pprCo + +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = ppr_co TopPrec co +pprParendCo co = ppr_co TyConPrec co + +ppr_co :: TyPrec -> Coercion -> SDoc +ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r + +ppr_co p co@(TyConAppCo _ tc [_,_]) + | tc `hasKey` funTyConKey = ppr_fun_co p co + +ppr_co _ (TyConAppCo r tc cos) = pprTcApp TyConPrec ppr_co tc cos <> ppr_role r +ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ + pprCo co1 <+> ppr_co TyConPrec co2 +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co +ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co p (AxiomInstCo con index cos) + = pprPrefixApp p (ppr (getName con) <> brackets (ppr index)) + (map (ppr_co TyConPrec) cos) + +ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ + case trans_co_list co [] of + [] -> panic "ppr_co" + (co:cos) -> sep ( ppr_co FunPrec co + : [ char ';' <+> ppr_co FunPrec co | co <- cos]) +ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ + pprParendCo co <> ptext (sLit "@") <> pprType ty + +ppr_co p (UnivCo s r ty1 ty2) = pprPrefixApp p (ptext (sLit "UnivCo") <+> ftext s <+> ppr r) + [pprParendType ty1, pprParendType ty2] +ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] +ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] +ppr_co p (AxiomRuleCo co ts cs) = maybeParen p TopPrec $ + ppr_axiom_rule_co co ts cs + +ppr_axiom_rule_co :: CoAxiomRule -> [Type] -> [Coercion] -> SDoc +ppr_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps) + where + ppTs [] = Outputable.empty + ppTs [t] = ptext (sLit "@") <> ppr_type TopPrec t + ppTs ts = ptext (sLit "@") <> + parens (hsep $ punctuate comma $ map pprType ts) + + ppPs [] = Outputable.empty + ppPs [p] = pprParendCo p + ppPs (p : ps) = ptext (sLit "(") <+> pprCo p $$ + vcat [ ptext (sLit ",") <+> pprCo q | q <- ps ] $$ + ptext (sLit ")") + + + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +trans_co_list :: Coercion -> [Coercion] -> [Coercion] +trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) +trans_co_list co cos = co : cos + +instance Outputable LeftOrRight where + ppr CLeft = ptext (sLit "Left") + ppr CRight = ptext (sLit "Right") + +ppr_fun_co :: TyPrec -> Coercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split :: Coercion -> [SDoc] + split (TyConAppCo _ f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: TyPrec -> Coercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) + +pprCoAxiom :: CoAxiom br -> SDoc +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (ptext (sLit "axiom") <+> ppr ax <+> dcolon) + 2 (vcat (map (pprCoAxBranch tc) $ fromBranchList branches)) + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + = hang (pprUserForAll tvs) + 2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs))) + +pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc +pprCoAxBranchHdr ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) index + | CoAxBranch { cab_lhs = tys, cab_loc = loc } <- coAxiomNthBranch ax index + = hang (pprTypeApp fam_tc tys) + 2 (ptext (sLit "-- Defined") <+> ppr_loc loc) + where + ppr_loc loc + | isGoodSrcSpan loc + = ptext (sLit "at") <+> ppr (srcSpanStart loc) + + | otherwise + = ptext (sLit "in") <+> + quotes (ppr (nameModule name)) + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ +-} + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] +decomposeCo :: Arity -> Coercion -> [Coercion] +decomposeCo arity co + = [mkNthCo n co | n <- [0..(arity-1)] ] + -- Remember, Nth is zero-indexed + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- first result has role equal to input; second result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) +splitAppCo_maybe (TyConAppCo r tc cos) + | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc + , Just (cos', co') <- snocView cos + , Just co'' <- setNominalRole_maybe co' + = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps! + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl +splitAppCo_maybe (Refl r ty) + | Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (Refl r ty1, Refl Nominal ty2) +splitAppCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co) +splitForAllCo_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarKind :: CoVar -> (Type,Type) +coVarKind cv + | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = ASSERT(tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) + (ty1,ty2) + | otherwise = panic "coVarKind, non coercion variable" + +coVarRole :: CoVar -> Role +coVarRole cv + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "coVarRole: unknown tycon" (ppr cv) + + where + tc = case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = panic "mkCoercionType" + +isReflCo :: Coercion -> Bool +isReflCo (Refl {}) = True +isReflCo _ = False + +isReflCo_maybe :: Coercion -> Maybe Type +isReflCo_maybe (Refl _ ty) = Just ty +isReflCo_maybe _ = Nothing + +{- +************************************************************************ +* * + Building coercions +* * +************************************************************************ + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the conversion +isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. The result +(if it exists) is always Nominal. The input can be at any role. It works on a +"best effort" basis, as it should never be strictly necessary to upgrade a coercion +during compilation. It is currently only used within GHC in splitAppCo_maybe. In order +to be a proper inverse of mkAppCo, the second coercion that splitAppCo_maybe returns +must be nominal. But, it's conceivable that splitAppCo_maybe is operating over a +TyConAppCo that uses a representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, it is +not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. +(Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the GHC +API, as he was decomposing Core casts. The Core casts use representational coercions, +as they must, but his use case required nominal coercions (he was building a GADT). +So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as appropriate? +I (Richard E.) have decided not to do this, because upgrading a role is bizarre and +a caller should have to ask for this behavior explicitly. +-} + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +mkCoVarCo cv + | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1 + | otherwise = CoVarCo cv + where + (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv + +mkReflCo :: Role -> Type -> Coercion +mkReflCo = Refl + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys + | arity == n_tys = downgradeRole role ax_role $ AxiomInstCo ax_br index rtys + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + foldl AppCo (AxiomInstCo ax_br index (take arity rtys)) + (drop arity rtys) + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + arity = length $ coAxBranchTyVars branch + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + ax_role = coAxiomRole ax + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> Coercion +mkUnbranchedAxInstCo role ax tys + = mkAxInstCo role ax 0 tys + +mkAxInstLHS, mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstLHS ax index tys + | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs } <- coAxiomNthBranch ax index + , (tys1, tys2) <- splitAtList tvs tys + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp (coAxiomTyCon ax) (substTysWith tvs tys1 lhs ++ tys2) + +mkAxInstRHS ax index tys + | CoAxBranch { cab_tvs = tvs, cab_rhs = rhs } <- coAxiomNthBranch ax index + , (tys1, tys2) <- splitAtList tvs tys + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys (substTyWith tvs tys1 rhs) tys2 + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -> Coercion -> Coercion +mkAppCo co1 co2 = mkAppCoFlexible co1 Nominal co2 +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs. + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second 'Coercion's role is given, making this more flexible than +-- 'mkAppCo'. +mkAppCoFlexible :: Coercion -> Role -> Coercion -> Coercion +mkAppCoFlexible (Refl r ty1) _ (Refl _ ty2) + = Refl r (mkAppTy ty1 ty2) +mkAppCoFlexible (Refl r ty1) r2 co2 + | Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) + = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 r2 co2] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... +mkAppCoFlexible (TyConAppCo r tc cos) r2 co + = case r of + Nominal -> ASSERT( r2 == Nominal ) + TyConAppCo Nominal tc (cos ++ [co]) + Representational -> TyConAppCo Representational tc (cos ++ [co']) + where new_role = (tyConRolesX Representational tc) !! (length cos) + co' = downgradeRole new_role r2 co + Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co]) + +mkAppCoFlexible co1 _r2 co2 = ASSERT( _r2 == Nominal ) + AppCo co1 co2 + + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion -> [Coercion] -> Coercion +mkAppCos co1 cos = foldl mkAppCo co1 cos + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos + = mkAppCos (liftCoSubst r tv_co_prs rhs_ty) leftover_cos + + | Just tys <- traverse isReflCo_maybe cos + = Refl r (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +-- | Make a function 'Coercion' between two other 'Coercion's +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo r co1 co2 = mkTyConAppCo r funTyCon [co1, co2] + +-- | Make a 'Coercion' which binds a variable within an inner 'Coercion' +mkForAllCo :: Var -> Coercion -> Coercion +-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) +mkForAllCo tv (Refl r ty) = ASSERT( isTyVar tv ) Refl r (mkForAllTy tv ty) +mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co + +------------------------------- + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co@(Refl {}) = co +mkSymCo (UnivCo s r ty1 ty2) = UnivCo s r ty2 ty1 +mkSymCo (SymCo co) = co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo (Refl {}) co = co +mkTransCo co (Refl {}) = co +mkTransCo co1 co2 = TransCo co1 co2 + +-- the Role is the desired one. It is the caller's responsibility to make +-- sure this request is reasonable +mkNthCoRole :: Role -> Int -> Coercion -> Coercion +mkNthCoRole role n co + = downgradeRole role nth_role $ nth_co + where + nth_co = mkNthCo n co + nth_role = coercionRole nth_co + +mkNthCo :: Int -> Coercion -> Coercion +mkNthCo n (Refl r ty) = ASSERT( ok_tc_app ty n ) + Refl r' (tyConAppArgN n ty) + where tc = tyConAppTyCon ty + r' = nthRole r tc n +mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) + NthCo n co + where + Pair _ty1 _ty2 = coercionKind co + + +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty)) +mkLRCo lr co = LRCo lr co + +ok_tc_app :: Type -> Int -> Bool +ok_tc_app ty n = case splitTyConApp_maybe ty of + Just (_, tys) -> tys `lengthExceeds` n + Nothing -> False + +-- | Instantiates a 'Coercion' with a 'Type' argument. +mkInstCo :: Coercion -> Type -> Coercion +mkInstCo co ty = InstCo co ty + +-- | Manufacture an unsafe coercion from thin air. +-- Currently (May 14) this is used only to implement the +-- @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Type -> Type -> Coercion +mkUnsafeCo = mkUnivCo (fsLit "mkUnsafeCo") Representational + +mkUnivCo :: FastString -> Role -> Type -> Type -> Coercion +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = Refl role ty1 + | otherwise = UnivCo prov role ty1 ty2 + +mkAxiomRuleCo :: CoAxiomRule -> [Type] -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- input coercion is Nominal; see also Note [Role twiddling functions] +mkSubCo :: Coercion -> Coercion +mkSubCo (Refl Nominal ty) = Refl Representational ty +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (UnivCo s Nominal ty1 ty2) = UnivCo s Representational ty1 ty2 +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) + SubCo co + +-- only *downgrades* a role. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- desired role + -> Role -- current role + -> Coercion -> Maybe Coercion +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Nominal Representational _ = Nothing +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (mkPhantomCo co) +downgradeRole_maybe _ Phantom _ = Nothing +downgradeRole_maybe _ _ co = Just co + +-- panics if the requested conversion is not a downgrade. +-- See also Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +-- Converts a coercion to be nominal, if possible. +-- See also Note [Role twiddling functions] +setNominalRole_maybe :: Coercion -> Maybe Coercion +setNominalRole_maybe co + | Nominal <- coercionRole co = Just co +setNominalRole_maybe (SubCo co) = Just co +setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty +setNominalRole_maybe (TyConAppCo Representational tc coes) + = do { cos' <- mapM setNominalRole_maybe coes + ; return $ TyConAppCo Nominal tc cos' } +setNominalRole_maybe (UnivCo s Representational ty1 ty2) = Just $ UnivCo s Nominal ty1 ty2 + -- We do *not* promote UnivCo Phantom, as that's unsafe. + -- UnivCo Nominal is no more unsafe than UnivCo Representational +setNominalRole_maybe (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2 +setNominalRole_maybe (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe co1 <*> pure co2 +setNominalRole_maybe (ForAllCo tv co) + = ForAllCo tv <$> setNominalRole_maybe co +setNominalRole_maybe (NthCo n co) + = NthCo n <$> setNominalRole_maybe co +setNominalRole_maybe (InstCo co ty) + = InstCo <$> setNominalRole_maybe co <*> pure ty +setNominalRole_maybe _ = Nothing + +-- takes any coercion and turns it into a Phantom coercion +mkPhantomCo :: Coercion -> Coercion +mkPhantomCo co + | Just ty <- isReflCo_maybe co = Refl Phantom ty + | Pair ty1 ty2 <- coercionKind co = UnivCo (fsLit "mkPhantomCo") Phantom ty1 ty2 + -- don't optimise here... wait for OptCoercion + +-- All input coercions are assumed to be Nominal, +-- or, if Role is Phantom, the Coercion can be Phantom, too. +applyRole :: Role -> Coercion -> Coercion +applyRole Nominal = id +applyRole Representational = mkSubCo +applyRole Phantom = mkPhantomCo + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith applyRole (tyConRolesX Representational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimiately concerned with the implementation +-- of TyConAppCo +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRoles tc ++ repeat Nominal +tyConRolesX role _ = repeat role + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesX Representational tc) !! n + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +-- See note [Newtype coercions] in TyCon +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCo :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCo name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = FirstBranch branch } + where branch = CoAxBranch { cab_loc = getSrcSpan name + , cab_tvs = tvs + , cab_lhs = mkTyVarTys tvs + , cab_roles = roles + , cab_rhs = rhs_ty + , cab_incomps = [] } + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkForAllCo v co + | otherwise = mkFunCo r (mkReflCo r (varType v)) co + +-- The first coercion *must* be Nominal. +mkCoCast :: Coercion -> Coercion -> Coercion +-- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2) +mkCoCast c g + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + where + -- g :: (s1 ~# s2) ~# (t1 ~# t2) + -- g1 :: s1 ~# t1 + -- g2 :: s2 ~# t2 + [_reflk, g1, g2] = decomposeCo 3 g + -- Remember, (~#) :: forall k. k -> k -> * + -- so it takes *three* arguments, not two + +{- +************************************************************************ +* * + Newtypes +* * +************************************************************************ +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just ( applyTysX tvs ty tys + , mkUnbranchedAxInstCo Representational co_tc tys) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX_maybe'. +type NormaliseStepper = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX_maybe'. +data NormaliseStepResult + = NS_Done -- ^ nothing more to do + | NS_Abort -- ^ utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type Coercion -- ^ we stepped, yielding new bits; + -- ^ co :: old type ~ new type + +modifyStepResultCo :: (Coercion -> Coercion) + -> NormaliseStepResult -> NormaliseStepResult +modifyStepResultCo f (NS_Step rec_nts ty co) = NS_Step rec_nts ty (f co) +modifyStepResultCo _ result = result + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +composeSteppers :: NormaliseStepper -> NormaliseStepper + -> NormaliseStepper +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX_maybe'. +topNormaliseTypeX_maybe :: NormaliseStepper -> Type -> Maybe (Coercion, Type) +topNormaliseTypeX_maybe stepper + = go initRecTc Nothing + where + go rec_nts mb_co1 ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' co2 + -> go rec_nts' (mb_co1 `trans` co2) ty' + + NS_Done -> all_done + NS_Abort -> Nothing + + | otherwise + = all_done + where + all_done | Just co <- mb_co1 = Just (co, ty) + | otherwise = Nothing + + Nothing `trans` co2 = Just co2 + (Just co1) `trans` co2 = Just (co1 `mkTransCo` co2) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@, or responds False to ok_tc. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe ty = Just (co, ty') +-- +-- then (a) @co : ty0 ~ ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- +topNormaliseNewType_maybe ty + = topNormaliseTypeX_maybe unwrapNewTypeStepper ty + +{- +************************************************************************ +* * + Equality of coercions +* * +************************************************************************ +-} + +-- | Determines syntactic equality of coercions +coreEqCoercion :: Coercion -> Coercion -> Bool +coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 + where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) + +coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool +coreEqCoercion2 env (Refl eq1 ty1) (Refl eq2 ty2) = eq1 == eq2 && eqTypeX env ty1 ty2 +coreEqCoercion2 env (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2) + = eq1 == eq2 && tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 + +coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 + +coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2) + = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2 + +coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2) + = rnOccL env cv1 == rnOccR env cv2 + +coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) + = con1 == con2 + && ind1 == ind2 + && all2 (coreEqCoercion2 env) cos1 cos2 + +-- the provenance string is just a note, so don't use in comparisons +coreEqCoercion2 env (UnivCo _ r1 ty11 ty12) (UnivCo _ r2 ty21 ty22) + = r1 == r2 && eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 + +coreEqCoercion2 env (SymCo co1) (SymCo co2) + = coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 + +coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 +coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) + = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 + +coreEqCoercion2 env (SubCo co1) (SubCo co2) + = coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (AxiomRuleCo a1 ts1 cs1) (AxiomRuleCo a2 ts2 cs2) + = a1 == a2 && all2 (eqTypeX env) ts1 ts2 && all2 (coreEqCoercion2 env) cs1 cs2 + +coreEqCoercion2 _ _ _ = False + +{- +************************************************************************ +* * + Substitution of coercions +* * +************************************************************************ +-} + +-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when +-- doing a \"lifting\" substitution) +type CvSubstEnv = VarEnv Coercion + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +data CvSubst + = CvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- Substitution of types + CvSubstEnv -- Substitution of coercions + +instance Outputable CvSubst where + ppr (CvSubst ins tenv cenv) + = brackets $ sep[ ptext (sLit "CvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv), + nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ] + +emptyCvSubst :: CvSubst +emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv + +isEmptyCvSubst :: CvSubst -> Bool +isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +getCvInScope :: CvSubst -> InScopeSet +getCvInScope (CvSubst in_scope _ _) = in_scope + +zapCvSubstEnv :: CvSubst -> CvSubst +zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv + +cvTvSubst :: CvSubst -> TvSubst +cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs + +tvCvSubst :: TvSubst -> CvSubst +tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv + +extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst +extendTvSubst (CvSubst in_scope tenv cenv) tv ty + = CvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstAndInScope :: CvSubst -> TyVar -> Type -> CvSubst +extendTvSubstAndInScope (CvSubst in_scope tenv cenv) tv ty + = CvSubst (in_scope `extendInScopeSetSet` tyVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendCvSubstAndInScope :: CvSubst -> CoVar -> Coercion -> CvSubst +-- Also extends the in-scope set +extendCvSubstAndInScope (CvSubst in_scope tenv cenv) cv co + = CvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfCo co) + tenv + (extendVarEnv cenv cv co) + +substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar) +substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) + -- In that case, mkCoVarCo will return a ReflCoercion, and + -- we want to substitute that (not new_var) for old_var + new_co = mkCoVarCo new_var + no_change = new_var == old_var && not (isReflCo new_co) + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var)) + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) +substTyVarBndr (CvSubst in_scope tenv cenv) old_var + = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of + (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var) + +mkCvSubst :: InScopeSet -> [(Var,Coercion)] -> CvSubst +mkCvSubst in_scope prs = CvSubst in_scope Type.emptyTvSubstEnv (mkVarEnv prs) + +zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst +zipOpenCvSubst vs cos + | debugIsOn && (length vs /= length cos) + = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst + | otherwise + = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) + +substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion +substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] + +substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithTys in_scope tvs tys co + | debugIsOn && (length tvs /= length tys) + = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co + | otherwise + = ASSERT( length tvs == length tys ) + substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co + +-- | Substitute within a 'Coercion' +substCo :: CvSubst -> Coercion -> Coercion +substCo subst co | isEmptyCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +substCos :: CvSubst -> [Coercion] -> [Coercion] +substCos subst cos | isEmptyCvSubst subst = cos + | otherwise = map (substCo subst) cos + +substTy :: CvSubst -> Type -> Type +substTy subst = Type.substTy (cvTvSubst subst) + +subst_co :: CvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = Coercion.substTy subst + + go :: Coercion -> Coercion + go (Refl eq ty) = Refl eq $! go_ty ty + go (TyConAppCo eq tc cos) = let args = map go cos + in args `seqList` TyConAppCo eq tc args + go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 + go (ForAllCo tv co) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllCo tv' $! subst_co subst' co + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos + go (UnivCo s r ty1 ty2) = (UnivCo s r $! go_ty ty1) $! go_ty ty2 + go (SymCo co) = mkSymCo (go co) + go (TransCo co1 co2) = mkTransCo (go co1) (go co2) + go (NthCo d co) = mkNthCo d (go co) + go (LRCo lr co) = mkLRCo lr (go co) + go (InstCo co ty) = mkInstCo (go co) $! go_ty ty + go (SubCo co) = mkSubCo (go co) + go (AxiomRuleCo co ts cs) = let ts1 = map go_ty ts + cs1 = map go cs + in ts1 `seqList` cs1 `seqList` + AxiomRuleCo co ts1 cs1 + + + +substCoVar :: CvSubst -> CoVar -> Coercion +substCoVar (CvSubst in_scope _ cenv) cv + | Just co <- lookupVarEnv cenv cv = co + | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 + | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) + ASSERT( isCoVar cv ) CoVarCo cv + +substCoVars :: CvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupTyVar :: CvSubst -> TyVar -> Maybe Type +lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv + +lookupCoVar :: CvSubst -> Var -> Maybe Coercion +lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v + +{- +************************************************************************ +* * + "Lifting" substitution + [(TyVar,Coercion)] -> Type -> Coercion +* * +************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = MkK (a -> Maybe a) + g :: T t1 ~ K t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +Note [Substituting kinds in liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to take care with kind polymorphism. Suppose + K :: forall k (a:k). (forall b:k. a -> b) -> T k a + +Now given (K @kk1 @ty1 v) |> g) where + g :: T kk1 ty1 ~ T kk2 ty2 +we want to compute + (forall b:k a->b) [ Nth 0 g/k, Nth 1 g/a ] +Notice that we MUST substitute for 'k'; this happens in +liftCoSubstTyVarBndr. But what should we substitute? +We need to take b's kind 'k' and return a Kind, not a Coercion! + +Happily we can do this because we know that all kind coercions +((Nth 0 g) in this case) are Refl. So we need a special purpose + subst_kind: LiftCoSubst -> Kind -> Kind +that expects a Refl coercion (or something equivalent to Refl) +when it looks up a kind variable. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftCoSubst = LCS InScopeSet LiftCoEnv + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions* + -- That's the whole point of this function! + +liftCoSubstWith :: Role -> [TyVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (zipEqual "liftCoSubstWith" tvs cos) ty + +liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion +liftCoSubst r prs ty + | null prs = Refl r ty + | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs))) + (mkVarEnv prs)) r ty + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' + +-- The Role parameter is the _desired_ role +ty_co_subst :: LiftCoSubst -> Role -> Type -> Coercion +ty_co_subst subst role ty + = go role ty + where + go Phantom ty = lift_phantom ty + go role (TyVarTy tv) = liftCoSubstTyVar subst role tv + `orElse` Refl role (TyVarTy tv) + -- A type variable from a non-cloned forall + -- won't be in the substitution + go role (AppTy ty1 ty2) = mkAppCo (go role ty1) (go Nominal ty2) + go role (TyConApp tc tys) = mkTyConAppCo role tc + (zipWith go (tyConRolesX role tc) tys) + -- IA0_NOTE: Do we need to do anything + -- about kind instantiations? I don't think + -- so. see Note [Kind coercions] + go role (FunTy ty1 ty2) = mkFunCo role (go role ty1) (go role ty2) + go role (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' role ty) + where + (subst', v') = liftCoSubstTyVarBndr subst v + go role ty@(LitTy {}) = ASSERT( role == Nominal ) + mkReflCo role ty + + lift_phantom ty = mkUnivCo (fsLit "lift_phantom") + Phantom (liftCoSubstLeft subst ty) + (liftCoSubstRight subst ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail (i.e., return Nothing) for two separate reasons: + 1) The variable is not in the substutition + 2) The coercion found is of too low a role + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail for reason 2) in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing for reason 2) is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. Bottom line: if +you find that liftCoSubst is doing weird things (like leaving out-of-scope +variables lying around), disable coercion optimization (bypassing matchAxiom) +and use downgradeRole instead of downgradeRole_maybe. The panic will then happen, +and you may learn something useful. +-} + +liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LCS _ cenv) r tv + = do { co <- lookupVarEnv cenv tv + ; let co_role = coercionRole co -- could theoretically take this as + -- a parameter, but painful + ; downgradeRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] + +liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) +liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var + = (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var) + where + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (Refl Nominal (TyVarTy new_var)) + + no_change = no_kind_change && (new_var == old_var) + + new_var1 = uniqAway in_scope old_var + + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) + new_var | no_kind_change = new_var1 + | otherwise = setTyVarKind new_var1 (subst_kind subst old_ki) + +-- map every variable to the type on the *left* of its mapped coercion +liftCoSubstLeft :: LiftCoSubst -> Type -> Type +liftCoSubstLeft (LCS in_scope cenv) ty + = Type.substTy (mkTvSubst in_scope (mapVarEnv (pFst . coercionKind) cenv)) ty + +-- same, but to the type on the right +liftCoSubstRight :: LiftCoSubst -> Type -> Type +liftCoSubstRight (LCS in_scope cenv) ty + = Type.substTy (mkTvSubst in_scope (mapVarEnv (pSnd . coercionKind) cenv)) ty + +subst_kind :: LiftCoSubst -> Kind -> Kind +-- See Note [Substituting kinds in liftCoSubst] +subst_kind subst@(LCS _ cenv) kind + = go kind + where + go (LitTy n) = n `seq` LitTy n + go (TyVarTy kv) = subst_kv kv + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + go (ForAllTy tv ty) = case liftCoSubstTyVarBndr subst tv of + (subst', tv') -> + ForAllTy tv' $! (subst_kind subst' ty) + + subst_kv kv + | Just co <- lookupVarEnv cenv kv + , let co_kind = coercionKind co + = ASSERT2( pFst co_kind `eqKind` pSnd co_kind, ppr kv $$ ppr co ) + pFst co_kind + | otherwise + = TyVarTy kv + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe LiftCoSubst +liftCoMatch tmpls ty co + = case ty_co_match menv emptyVarEnv ty co of + Just cenv -> Just (LCS in_scope cenv) + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -> LiftCoEnv -> Type -> Coercion -> Maybe LiftCoEnv +ty_co_match menv subst ty co + | Just ty' <- coreView ty = ty_co_match menv subst ty' co + + -- Match a type variable against a non-refl coercion +ty_co_match menv cenv (TyVarTy tv1) co + | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 + = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co + then Just cenv + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co)) + then Nothing -- occurs check failed + else return (extendVarEnv cenv tv1' co) + -- BAY: I don't think we need to do any kind matching here yet + -- (compare 'match'), but we probably will when moving to SHE. + + | otherwise -- tv1 is not a template ty var, so the only thing it + -- can match is a reflexivity coercion for itself. + -- But that case is dealt with already + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + +ty_co_match menv subst (AppTy ty1 ty2) co + | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = do { subst' <- ty_co_match menv subst ty1 co1 + ; ty_co_match menv subst' ty2 co2 } + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) + | tc1 == tc2 = ty_co_matches menv subst tys cos + +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) + | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos + +ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) + = ty_co_match menv' subst ty co + where + menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } + +ty_co_match menv subst ty co + | Just co' <- pushRefl co = ty_co_match menv subst ty co' + | otherwise = Nothing + +ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv +ty_co_matches menv = matchList (ty_co_match menv) + +pushRefl :: Coercion -> Maybe Coercion +pushRefl (Refl Nominal (AppTy ty1 ty2)) + = Just (AppCo (Refl Nominal ty1) (Refl Nominal ty2)) +pushRefl (Refl r (FunTy ty1 ty2)) + = Just (TyConAppCo r funTyCon [Refl r ty1, Refl r ty2]) +pushRefl (Refl r (TyConApp tc tys)) + = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) +pushRefl (Refl r (ForAllTy tv ty)) = Just (ForAllCo tv (Refl r ty)) +pushRefl _ = Nothing + +{- +************************************************************************ +* * + Sequencing on coercions +* * +************************************************************************ +-} + +seqCo :: Coercion -> () +seqCo (Refl eq ty) = eq `seq` seqType ty +seqCo (TyConAppCo eq tc cos) = eq `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv co) = tv `seq` seqCo co +seqCo (CoVarCo cv) = cv `seq` () +seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos +seqCo (UnivCo s r ty1 ty2) = s `seq` r `seq` seqType ty1 `seq` seqType ty2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo _ co) = seqCo co +seqCo (LRCo _ co) = seqCo co +seqCo (InstCo co ty) = seqCo co `seq` seqType ty +seqCo (SubCo co) = seqCo co +seqCo (AxiomRuleCo _ ts cs) = seqTypes ts `seq` seqCos cs + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +************************************************************************ +* * + The kind of a type, and of a coercion +* * +************************************************************************ + +Note [Computing a coercion kind and role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To compute a coercion's kind is straightforward: see coercionKind. +But to compute a coercion's role, in the case for NthCo we need +its kind as well. So if we have two separate functions (one for kinds +and one for roles) we can get exponentially bad behaviour, since each +NthCo node makes a separate call to coercionKind, which traverses the +sub-tree again. This was part of the problem in Trac #9233. + +Solution: compute both together; hence coercionKindRole. We keep a +separate coercionKind function because it's a bit more efficient if +the kind is all you want. +-} + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: Coercion -> Pair Type +coercionKind co = go co + where + go (Refl _ ty) = Pair ty ty + go (TyConAppCo _ tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) + go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (ForAllCo tv co) = mkForAllTy tv <$> go co + go (CoVarCo cv) = toPair $ coVarKind cv + go (AxiomInstCo ax ind cos) + | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Pair tys1 tys2 <- sequenceA (map go cos) + = ASSERT( cos `equalLength` tvs ) -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + Pair (substTyWith tvs tys1 (mkTyConApp (coAxiomTyCon ax) lhs)) + (substTyWith tvs tys2 rhs) + go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 + go (SymCo co) = swap $ go co + go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go (NthCo d co) = tyConAppArgN d <$> go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co + go (InstCo aco ty) = go_app aco [ty] + go (SubCo co) = go co + go (AxiomRuleCo ax tys cos) = + case coaxrProves ax tys (map go cos) of + Just res -> res + Nothing -> panic "coercionKind: Malformed coercion" + + go_app :: Coercion -> [Type] -> Pair Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co ty) tys = go_app co (ty:tys) + go_app co tys = (`applyTys` tys) <$> go co + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +-- Why both at once? See Note [Computing a coercion kind and role] +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole = go + where + go (Refl r ty) = (Pair ty ty, r) + go (TyConAppCo r tc cos) + = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r) + go (AppCo co1 co2) + = let (tys1, r1) = go co1 in + (mkAppTy <$> tys1 <*> coercionKind co2, r1) + go (ForAllCo tv co) + = let (tys, r) = go co in + (mkForAllTy tv <$> tys, r) + go (CoVarCo cv) = (toPair $ coVarKind cv, coVarRole cv) + go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) + go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) + go (SymCo co) = first swap $ go co + go (TransCo co1 co2) + = let (tys1, r) = go co1 in + (Pair (pFst tys1) (pSnd $ coercionKind co2), r) + go (NthCo d co) + = let (Pair t1 t2, r) = go co + (tc1, args1) = splitTyConApp t1 + (_tc2, args2) = splitTyConApp t2 + in + ASSERT( tc1 == _tc2 ) + ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) + go co@(LRCo {}) = (coercionKind co, Nominal) + go (InstCo co ty) = go_app co [ty] + go (SubCo co) = (coercionKind co, Representational) + go co@(AxiomRuleCo ax _ _) = (coercionKind co, coaxrRole ax) + + go_app :: Coercion -> [Type] -> (Pair Type, Role) + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co ty) tys = go_app co (ty:tys) + go_app co tys + = let (pair, r) = go co in + ((`applyTys` tys) <$> pair, r) + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = snd . coercionKindRole + -- There's not a better way to do this, because NthCo needs the *kind* + -- and role of its argument. Luckily, laziness should generally avoid + -- the need for computing kinds in other cases. + +{- +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In Trac #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up Trac #5631. +So it's very important to do the substitution simultaneously. + +cf Type.applyTys (which in fact we call here) +-} + +applyCo :: Type -> Coercion -> Type +-- Gives the type of (e co) where e :: (a~b) => ty +applyCo ty co | Just ty' <- coreView ty = applyCo ty' co +applyCo (FunTy _ ty) _ = ty +applyCo _ _ = panic "applyCo" + +{- +Note [Kind coercions] +~~~~~~~~~~~~~~~~~~~~~ +Kind coercions are only of the form: Refl kind. They are only used to +instantiate kind polymorphic type constructors in TyConAppCo. Remember +that kind instantiation only happens with TyConApp, not AppTy. +-} diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs new file mode 100644 index 00000000..373dd5c9 --- /dev/null +++ b/compiler/types/FamInstEnv.hs @@ -0,0 +1,1074 @@ +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-} + +module FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, + mkImportedFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, + identicalFamInstHead, famInstEnvElts, familyInstances, orphNamesOfFamInst, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + computeAxiomIncomps, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, + isDominatedBy, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, + reduceTyFamApp_maybe, chooseBranch, + + -- Flattening + flattenTys + ) where + +#include "HsVersions.h" + +import InstEnv +import Unify +import Type +import TcType ( orphNamesOfTypes ) +import TypeRep +import TyCon +import Coercion +import CoAxiom +import VarSet +import VarEnv +import Name +import UniqFM +import Outputable +import Maybes +import TrieMap +import Unique +import Util +import Var +import Pair +import SrcLoc +import NameSet +import FastString + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom introduced + -- by this family instance + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + -- Like ClsInsts, these variables are always + -- fresh. See Note [Template tyvars are fresh] + -- in InstEnv + + , fi_tys :: [Type] -- and its arg types + -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom + + , fi_rhs :: Type -- the RHS, with its freshened vars + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +-- Prints the FamInst as a family instance declaration +-- NB: FamInstEnv.pprFamInst is used only for internal, debug printing +-- See pprTyThing.pprFamInst for printing for the user +pprFamInst :: FamInst -> SDoc +pprFamInst famInst + = hang (pprFamInstHdr famInst) + 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax) + , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) ]) + where + ax = fi_axiom famInst + +pprFamInstHdr :: FamInst -> SDoc +pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) + = pprTyConSort <+> pp_instance <+> pp_head + where + -- For *associated* types, say "type T Int = blah" + -- For *top level* type instances, say "type instance T Int = blah" + pp_instance + | isTyConAssoc fam_tc = empty + | otherwise = ptext (sLit "instance") + + (fam_tc, etad_lhs_tys) = famInstSplitLHS fi + vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys + + pp_head | DataFamilyInst rep_tc <- flavor + , isAlgTyCon rep_tc + , let extra_tvs = dropList etad_lhs_tys (tyConTyVars rep_tc) + , not (null extra_tvs) + = getPprStyle $ \ sty -> + if debugStyle sty + then vanilla_pp_head -- With -dppr-debug just show it as-is + else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs) + -- Without -dppr-debug, eta-expand + -- See Trac #8674 + -- (This is probably over the top now that we use this + -- only for internal debug printing; PprTyThing.pprFamInst + -- is used for user-level printing.) + | otherwise + = vanilla_pp_head + + pprTyConSort = case flavor of + SynFamilyInst -> ptext (sLit "type") + DataFamilyInst tycon + | isDataTyCon tycon -> ptext (sLit "data") + | isNewTyCon tycon -> ptext (sLit "newtype") + | isAbstractTyCon tycon -> ptext (sLit "data") + | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxiom { co_ax_branches = + ~(FirstBranch ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_rhs = rhs })) }) = axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv maps a family name to the list of known instances for that family. + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using contructors +and pattern matching. + +Neverthless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in Simplify + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two. The reason +for this eta-reduction is decribed in TcInstDcls + Note [Eta reduction for data family axioms] +-} + +type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances + -- See Note [FamInstEnv] + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +newtype FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + +instance Outputable FamilyInstEnv where + ppr (FamIE fs) = ptext (sLit "FamIE") <+> vcat (map ppr fs) + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts fi = [elt | FamIE elts <- eltsUFM fi, elt <- elts] + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUFM env fam of + Just (FamIE insts) -> insts + Nothing -> [] + +-- | Collects the names of the concrete types and type constructors that +-- make up the LHS of a type family instance, including the family +-- name itself. +-- +-- For instance, given `type family Foo a b`: +-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst fam_inst + = orphNamesOfTypes (concat (brListMap cab_lhs (coAxiomBranches axiom))) + `extendNameSet` getName (coAxiomTyCon axiom) + where + axiom = fi_axiom fam_inst + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) + = addToUFM_C add inst_env cls_nm (FamIE [ins_item]) + where + add (FamIE items) _ = FamIE (ins_item:items) + +deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +-- Used only for overriding in GHCi +deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) + = adjustUFM adjust inst_env fam_nm + where + adjust :: FamilyInstEnv -> FamilyInstEnv + adjust (FamIE items) + = FamIE (filterOut (identicalFamInstHead fam_inst) items) + +identicalFamInstHead :: FamInst -> FamInst -> Bool +-- ^ True when the LHSs are identical +-- Used for overriding in GHCi +identicalFamInstHead (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) + = coAxiomTyCon ax1 == coAxiomTyCon ax2 + && brListLength brs1 == brListLength brs2 + && and (brListZipWith identical_branch brs1 brs2) + where + brs1 = coAxiomBranches ax1 + brs2 = coAxiomBranches ax2 + + identical_branch br1 br2 + = isJust (tcMatchTys tvs1 lhs1 lhs2) + && isJust (tcMatchTys tvs2 lhs2 lhs1) + where + tvs1 = mkVarSet (coAxBranchTyVars br1) + tvs2 = mkVarSet (coAxBranchTyVars br2) + lhs1 = coAxBranchLHS br1 + lhs2 = coAxBranchLHS br2 + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +Note [Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x +type instance where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = case tcUnifyTysFG instanceBindFun lhs1 lhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTy subst rhs1 `eqType` Type.substTy subst rhs2 + -> True + _ -> False + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in CoAxiom +computeAxiomIncomps :: CoAxiom br -> CoAxiom br +computeAxiomIncomps ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = go [] branches } + where + go :: [CoAxBranch] -> BranchList CoAxBranch br -> BranchList CoAxBranch br + go prev_branches (FirstBranch br) + = FirstBranch (br { cab_incomps = mk_incomps br prev_branches }) + go prev_branches (NextBranch br tail) + = let br' = br { cab_incomps = mk_incomps br prev_branches } in + NextBranch br' (go (br' : prev_branches) tail) + + mk_incomps :: CoAxBranch -> [CoAxBranch] -> [CoAxBranch] + mk_incomps br = filter (not . compatibleBranches br) + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See Trac #7524. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [Type] -- LHS patterns + -> Type -- RHS + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs lhs rhs loc + = CoAxBranch { cab_tvs = tvs1 + , cab_lhs = tidyTypes env lhs + , cab_roles = map (const Nominal) tvs1 + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs + -- See Note [Tidy axioms when we build them] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = computeAxiomIncomps $ + CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = toBranchList branches } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = FirstBranch (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Name -> [TyVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched +mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = FirstBranch (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs lhs_tys rhs_ty (getSrcSpan ax_name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys }) + = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env match + where + match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] + + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TvSubst + +lookup_fam_inst_env' -- The worker, local to this module + :: MatchFun + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam + , Just (FamIE insts) <- lookupUFM ie fam + = find insts -- The common case + | otherwise = [] + where + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 }) + : find rest + + -- No match => try next + | otherwise + = find rest + + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see Note [Eta reduction + for data family axioms] in TcInstDcls. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_tvs = tvs, cab_lhs = tys }) + = isJust $ tcMatchTys (mkVarSet tvs) tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normlise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use normaliseTcArgs first. +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families + +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = fam_inst + , fim_tys = inst_tys } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let ax = famInstAxiom fam_inst + co = mkUnbranchedAxInstCo role ax inst_tys + ty = pSnd (coercionKind co) + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyCon_maybe tc + , Just (ind, inst_tys) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys + ty = pSnd (coercionKind co) + in Just (co, ty) + + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,ty) <- sfMatchFam ax tys + = let co = mkAxiomRuleCo coax ts [] + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] -> Maybe (BranchIndex, [Type]) +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys) <- findBranch (fromBranchList branches) 0 target_tys + ; return (ind, inst_tys ++ extra_tys) } + +-- The axiom must *not* be oversaturated +findBranch :: [CoAxBranch] -- branches to check + -> BranchIndex -- index of current branch + -> [Type] -- target types + -> Maybe (BranchIndex, [Type]) +findBranch (CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs, cab_incomps = incomps } + : rest) ind target_tys + = case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | all (isSurelyApart + . tcUnifyTysFG instanceBindFun flattened_target + . coAxBranchLHS) incomps + -> -- matching worked & we're apart from all incompatible branches. success + Just (ind, substTyVars subst tpl_tvs) + + -- failure. keep looking + _ -> findBranch rest (ind+1) target_tys + + where isSurelyApart SurelyApart = True + isSurelyApart _ = False + + flattened_target = flattenTys in_scope target_tys + in_scope = mkInScopeSet (unionVarSets $ + map (tyVarsOfTypes . coAxBranchLHS) incomps) + +-- fail if no branches left +findBranch [] _ _ = Nothing + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty = case topNormaliseType_maybe env ty of + Just (_co, ty') -> ty' + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * newtypes +-- using appropriate coercions. Specifically, if +-- topNormaliseType_maybe env ty = Maybe (co, ty') +-- then +-- (a) co :: ty ~ ty' +-- (b) ty' is not a newtype, and is not a type-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Its a bit like Type.repType, but handles type families too +-- The coercion returned is always an R coercion + +topNormaliseType_maybe env ty + = topNormaliseTypeX_maybe stepper ty + where + stepper + = unwrapNewTypeStepper + `composeSteppers` + \ rec_nts tc tys -> + let (args_co, ntys) = normaliseTcArgs env Representational tc tys in + case reduceTyFamApp_maybe env Representational tc ntys of + Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co) + Nothing -> NS_Done + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + | isTypeSynonymTyCon tc + , Just (tenv, rhs, ntys') <- tcExpandTyCon_maybe tc ntys + , (co2, ninst_rhs) <- normaliseType env role (Type.substTy (mkTopTvSubst tenv) rhs) + = if isReflCo co2 then (args_co, mkTyConApp tc ntys) + else (args_co `mkTransCo` co2, mkAppTys ninst_rhs ntys') + + | Just (first_co, ty') <- reduceTyFamApp_maybe env role tc ntys + , (rest_co,nty) <- normaliseType env role ty' + = (args_co `mkTransCo` first_co `mkTransCo` rest_co, nty) + + | otherwise -- No unique matching family instance exists; + -- we do not do anything + = (args_co, mkTyConApp tc ntys) + + where + (args_co, ntys) = normaliseTcArgs env role tc tys + + +--------------- +normaliseTcArgs :: FamInstEnvs -- environment with family instances + -> Role -- desired role of output coercion + -> TyCon -> [Type] -- tc tys + -> (Coercion, [Type]) -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys +normaliseTcArgs env role tc tys + = (mkTyConAppCo role tc cois, ntys) + where + (cois, ntys) = zipWithAndUnzip (normaliseType env) (tyConRolesX role tc) tys + +--------------- +normaliseType :: FamInstEnvs -- environment with family instances + -> Role -- desired role of output coercion + -> Type -- old type + -> (Coercion, Type) -- (coercion,new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Try to not to disturb type syonyms if possible + +normaliseType env role (TyConApp tc tys) + = normaliseTcApp env role tc tys +normaliseType _env role ty@(LitTy {}) = (mkReflCo role ty, ty) +normaliseType env role (AppTy ty1 ty2) + = let (coi1,nty1) = normaliseType env role ty1 + (coi2,nty2) = normaliseType env Nominal ty2 + in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) +normaliseType env role (FunTy ty1 ty2) + = let (coi1,nty1) = normaliseType env role ty1 + (coi2,nty2) = normaliseType env role ty2 + in (mkFunCo role coi1 coi2, mkFunTy nty1 nty2) +normaliseType env role (ForAllTy tyvar ty1) + = let (coi,nty1) = normaliseType env role ty1 + in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) +normaliseType _ role ty@(TyVarTy _) + = (mkReflCo role ty,ty) + +{- +************************************************************************ +* * + Flattening +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ + +As described in +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we sometimes need to flatten core types before unifying them. Flattening +means replacing all top-level uses of type functions with fresh variables, +taking care to preserve sharing. That is, the type (Either (F a b) (F a b)) should +flatten to (Either c c), never (Either c d). + +Defined here because of module dependencies. +-} + +type FlattenMap = TypeMap TyVar + +-- See Note [Flattening] +flattenTys :: InScopeSet -> [Type] -> [Type] +flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys + where + -- when we hit a type function, we replace it with a fresh variable + -- but, we need to make sure that this fresh variable isn't mentioned + -- *anywhere* in the types we're flattening, even if locally-bound in + -- a forall. That way, we can ensure consistency both within and outside + -- of that forall. + all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys + +coreFlattenTys :: InScopeSet -> FlattenMap -> [Type] -> (FlattenMap, [Type]) +coreFlattenTys in_scope = go [] + where + go rtys m [] = (m, reverse rtys) + go rtys m (ty : tys) + = let (m', ty') = coreFlattenTy in_scope m ty in + go (ty' : rtys) m' tys + +coreFlattenTy :: InScopeSet -> FlattenMap -> Type -> (FlattenMap, Type) +coreFlattenTy in_scope = go + where + go m ty | Just ty' <- coreView ty = go m ty' + + go m ty@(TyVarTy {}) = (m, ty) + go m (AppTy ty1 ty2) = let (m1, ty1') = go m ty1 + (m2, ty2') = go m1 ty2 in + (m2, AppTy ty1' ty2') + go m (TyConApp tc tys) + -- NB: Don't just check if isFamilyTyCon: this catches *data* families, + -- which are generative and thus can be preserved during flattening + | not (isGenerativeTyCon tc Nominal) + = let (m', tv) = coreFlattenTyFamApp in_scope m tc tys in + (m', mkTyVarTy tv) + + | otherwise + = let (m', tys') = coreFlattenTys in_scope m tys in + (m', mkTyConApp tc tys') + + go m (FunTy ty1 ty2) = let (m1, ty1') = go m ty1 + (m2, ty2') = go m1 ty2 in + (m2, FunTy ty1' ty2') + + -- Note to RAE: this will have to be changed with kind families + go m (ForAllTy tv ty) = let (m', ty') = go m ty in + (m', ForAllTy tv ty') + + go m ty@(LitTy {}) = (m, ty) + +coreFlattenTyFamApp :: InScopeSet -> FlattenMap + -> TyCon -- type family tycon + -> [Type] -- args + -> (FlattenMap, TyVar) +coreFlattenTyFamApp in_scope m fam_tc fam_args + = case lookupTypeMap m fam_ty of + Just tv -> (m, tv) + -- we need fresh variables here, but this is called far from + -- any good source of uniques. So, we generate one from thin + -- air, using the arbitrary prime number 71 as a seed + Nothing -> let tyvar_unique = deriveUnique (getUnique fam_tc) 71 + tyvar_name = mkSysTvName tyvar_unique (fsLit "fl") + tv = uniqAway in_scope $ mkTyVar tyvar_name (typeKind fam_ty) + m' = extendTypeMap m fam_ty tv in + (m', tv) + where fam_ty = TyConApp fam_tc fam_args + +allTyVarsInTys :: [Type] -> VarSet +allTyVarsInTys [] = emptyVarSet +allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys + +allTyVarsInTy :: Type -> VarSet +allTyVarsInTy = go + where + go (TyVarTy tv) = unitVarSet tv + go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (TyConApp _ tys) = allTyVarsInTys tys + go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (ForAllTy tv ty) = (go (tyVarKind tv)) `unionVarSet` + unitVarSet tv `unionVarSet` + (go ty) -- don't remove tv + go (LitTy {}) = emptyVarSet diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs new file mode 100644 index 00000000..2959dc6f --- /dev/null +++ b/compiler/types/InstEnv.hs @@ -0,0 +1,1034 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to TcInstDcls and TcDeriv. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + instanceDFunId, tidyClsInstDFun, instanceRoughTcs, + fuzzyClsInstCmp, + + IsOrphan(..), isOrphan, notOrphan, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, + memberInstEnv, instIsVisible, + classInstances, orphNamesOfClsInst, instanceBindFun, + instanceCantMatch, roughMatchTcs + ) where + +#include "HsVersions.h" + +import Module +import Class +import Var +import VarSet +import Name +import NameSet +import TcType +import TyCon +import Unify +import Outputable +import ErrUtils +import BasicTypes +import UniqFM +import Util +import Id +import Binary +import FastString +import Data.Data ( Data, Typeable ) +import Data.Maybe ( isJust, isNothing ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid +#endif + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +data ClsInst + = ClsInst { -- Used for "rough matching"; see Note [Rough-match field] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + is_cls_nm :: Name -- Class name + , is_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + -- See Note [Silent superclass arguments] in TcInstDcls + -- for how to map the DFun's type back to the source + -- language instance decl + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + } + deriving (Data, Typeable) + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` + mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + where + cmp (Nothing, Nothing) = EQ + cmp (Nothing, Just _) = LT + cmp (Just _, Nothing) = GT + cmp (Just x, Just y) = stableNameCmp x y + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in lookupInstEnv'. + +Note [Rough-match field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_cls_nm, is_tcs fields allow a "rough match" to be done +*without* poking inside the DFunId. Poking the DFunId forces +us to suck in all the type constructors etc it involves, +which is a total waste of time if it has no chance of matching +So the Name, [Maybe Name] fields allow us to say "definitely +does not match", based only on the Name. + +In is_tcs, + Nothing means that this type arg is a type variable + + (Just n) means that this type arg is a + TyConApp with a type constructor of n. + This is always a real tycon, never a synonym! + (Two different synonyms might match, but two + different real tycons can't.) + NB: newtypes are not transparent, though! + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the fast-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +tidyClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs = is_tcs + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) + , ifPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = getPprStyle $ \ sty -> + let dfun_ty = idType dfun + (tvs, theta, res_ty) = tcSplitSigmaTy dfun_ty + theta_to_print = drop (dfunNSilent dfun) theta + -- See Note [Silent superclass arguments] in TcInstDcls + ty_to_print | debugStyle sty = dfun_ty + | otherwise = mkSigmaTy tvs theta_to_print res_ty + in ptext (sLit "instance") <+> ppr flag <+> pprSigmaType ty_to_print + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyavs from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) + = (tvs, cls, tys) + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId +mkLocalInstance dfun oflag tvs cls tys + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one :: [NameSet] -> IsOrphan + choose_one nss = case nameSetElems (unionNameSets nss) of + [] -> IsOrphan + (n : _) -> NotOrphan (nameOccName n) + +mkImportedInstance :: Name + -> [Maybe Name] + -> DFunId + -> OverlapFlag + -> IsOrphan + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedInstance cls_nm mb_tcs dfun oflag orphan + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (tyConName tc) + Nothing -> Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +{- +************************************************************************ +* * + Orphans +* * +************************************************************************ +-} + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +-- See Note [Orphans] +data IsOrphan + = IsOrphan + | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood + -- In that case, the instance is fingerprinted as part + -- of the definition of 'n's definition + deriving (Data, Typeable) + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + +{- +Note [Orphans] +~~~~~~~~~~~~~~ +Class instances, rules, and family instances are divided into orphans +and non-orphans. Roughly speaking, an instance/rule is an orphan if +its left hand side mentions nothing defined in this module. Orphan-hood +has two major consequences + + * A module that contains orphans is called an "orphan module". If + the module being compiled depends (transitively) on an oprhan + module M, then M.hi is read in regardless of whether M is oherwise + needed. This is to ensure that we don't miss any instance decls in + M. But it's painful, because it means we need to keep track of all + the orphan modules below us. + + * A non-orphan is not finger-printed separately. Instead, for + fingerprinting purposes it is treated as part of the entity it + mentions on the LHS. For example + data T = T1 | T2 + instance Eq T where .... + The instance (Eq T) is incorprated as part of T's fingerprint. + + In constrast, orphans are all fingerprinted together in the + mi_orph_hash field of the ModIface. + + See MkIface.addFingerprints. + +Orphan-hood is computed + * For class instances: + when we make a ClsInst + (because it is needed during instance lookup) + + * For rules and family instances: + when we generate an IfaceRule (MkIface.coreRuleToIfaceRule) + or IfaceFamInst (MkIface.instanceToIfaceInst) + +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (see MkIface.instanceToIfaceInst, which implements this) +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + +newtype ClsInstEnv + = ClsIE [ClsInst] -- The instances for a particular class, in any order + +instance Outputable ClsInstEnv where + ppr (ClsIE is) = pprInstances is + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts] + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + | isInteractiveModule mod = True + | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods + | otherwise = True + where + mod = nameModule (idName (is_dfun ispec)) + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUFM env cls of + Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts + Nothing -> [] + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst = orphNamesOfDFunHead . idType . instanceDFunId + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in TcRnDriver +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalClsInstHead ins_item) items) + (lookupUFM inst_env cls_nm) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUFM adjust inst_env cls_nm + where + adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insenstive to alpha-renaming +identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tvs = tvs1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tvs = tvs2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys (mkVarSet tvs1) tys1 tys2) + && isJust (tcMatchTys (mkVarSet tvs2) tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. Trac #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + + * Find all instances I that match the target constraint; that is, the + target constraint is a substitution instance of I. These instance + declarations are the candidates. + + * Find all non-candidate instances that unify with the target + constraint. Such non-candidates instances might match when the + target constraint is further instantiated. If all of them are + incoherent, proceed; if not, the search fails. + + * Eliminate any candidate IX for which both of the following hold: + * There is another candidate IY that is strictly more specific; + that is, IY is a substitution instance of IX but not vice versa. + + * Either IX is overlappable or IY is overlapping. + + * If only one candidate remains, pick it. Otherwise if all remaining + candidates are incoherent, pick an arbitrary candidate. Otherwise fail. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely chosing a generic instance when a more specific one +exists. + +--Jeff +v +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , Bool) -- True if error condition caused by + -- SafeHaskell condition. + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +-- +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either MsgDoc (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ ptext (sLit "flexible type variable:") <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys) + +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [ClsInst]) -- These don't match but do unify +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +lookupInstEnv' ie vis_mods cls tys + = lookup ie + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + -------------- + lookup env = case lookupUFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts) -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs + , is_tys = tpl_tys, is_flag = oflag }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- See Note [Instance lookup and orphan instances] + + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tv_set tpl_tys tys + = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] and Note [Incoherent instances] + | Incoherent _ <- overlapMode oflag + = find ms us rest + + | otherwise + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tv_set, + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTys instanceBindFun tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest + where + tpl_tv_set = mkVarSet tpl_tvs + + ---------------- + lookup_tv :: TvSubst -> TyVar -> DFunInstType + -- See Note [DFunInstType: instantiating types] + lookup_tv subst tv = case lookupTyVar subst tv of + Just ty -> Just ty + Nothing -> Nothing + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +lookupInstEnv (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls tys + = (final_matches, final_unifs, safe_fail) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + pruned_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + (final_matches, safe_fail) + = case pruned_matches of + [match] -> check_safe match all_matches + _ -> (pruned_matches, False) + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | is_incoherent m -> [] + _ -> all_unifs + + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe match@(inst,_) others + = case isSafeOverlap (is_flag inst) of + -- most specific isn't from a Safe module so OK + False -> ([match], False) + -- otherwise we make sure it only overlaps instances from + -- the same module + True -> (go [] others, True) + where + go bad [] = match:bad + go bad (i@(x,_):unchecked) = + if inSameMod x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + +--------------- +is_incoherent :: InstMatch -> Bool +is_incoherent (inst, _) = case overlapMode (is_flag inst) of + Incoherent _ -> True + _ -> False + +--------------- +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item (old_item : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_item `can_override` old_item + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_item `can_override` new_item + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | is_incoherent old_item -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | is_incoherent new_item -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items + where + + new_beats_old = new_item `more_specific_than` old_item + old_beats_new = old_item `more_specific_than` new_item + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + (instA,_) `more_specific_than` (instB,_) + = isJust (tcMatchTys (mkVarSet (is_tvs instB)) + (is_tys instB) (is_tys instA)) + + (instA, _) `can_override` (instB, _) + = hasOverlappingFlag (overlapMode (is_flag instA)) + || hasOverlappableFlag (overlapMode (is_flag instB)) + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: Trac #9242. + -- Previous change: Trac #3877, Dec 10. + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are are others. + + + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: TyVar -> BindFlag +instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] + +{- +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The key_tys can contain skolem constants, and we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd +complain, saying that the choice of instance depended on the instantiation +of 'a'; but of course it isn't *going* to be instantiated. + +We do this only for isOverlappableTyVar skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs new file mode 100644 index 00000000..a3e30a69 --- /dev/null +++ b/compiler/types/Kind.hs @@ -0,0 +1,301 @@ +-- (c) The University of Glasgow 2006-2012 + +{-# LANGUAGE CPP #-} +module Kind ( + -- * Main data type + SuperKind, Kind, typeKind, + + -- Kinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, + mkArrowKind, mkArrowKinds, + + -- Kind constructors... + anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, + unliftedTypeKindTyCon, constraintKindTyCon, + + -- Super Kinds + superKind, superKindTyCon, + + pprKind, pprParendKind, + + -- ** Deconstructing Kinds + kindAppResult, synTyConResKind, + splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + + -- ** Predicates on Kinds + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isConstraintKind, isConstraintOrLiftedKind, returnsConstraintKind, + isKind, isKindVar, + isSuperKind, isSuperKindTyCon, + isLiftedTypeKindCon, isConstraintKindCon, + isAnyKind, isAnyKindCon, + okArrowArgKind, okArrowResultKind, + + isSubOpenTypeKind, isSubOpenTypeKindKey, + isSubKind, isSubKindCon, + tcIsSubKind, tcIsSubKindCon, + defaultKind, defaultKind_maybe, + + -- ** Functions on variables + kiVarsOfKind, kiVarsOfKinds + + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) + +import TypeRep +import TysPrim +import TyCon +import VarSet +import PrelNames +import Outputable +import Maybes( orElse ) +import Util +import FastString + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and *. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + Ord a ~ (a -> a) +so on the left we have Constraint, and on the right we have *. +See Trac #7451. + +Bottom line: although '*' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. Hence cmpTc treats them as equal. +-} + +-- | Essentially 'funResultTy' on kinds handling pi-types too +kindFunResult :: SDoc -> Kind -> KindOrType -> Kind +kindFunResult _ (FunTy _ res) _ = res +kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res +#ifdef DEBUG +kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc) +#else +-- Without DEBUG, doc becomes an unsed arg, and will be optimised away +kindFunResult _ _ _ = panic "kindFunResult" +#endif + +kindAppResult :: SDoc -> Kind -> [Type] -> Kind +kindAppResult _ k [] = k +kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as + +-- | Essentially 'splitFunTys' on kinds +splitKindFunTys :: Kind -> ([Kind],Kind) +splitKindFunTys (FunTy a r) = case splitKindFunTys r of + (as, k) -> (a:as, k) +splitKindFunTys k = ([], k) + +splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) +splitKindFunTy_maybe (FunTy a r) = Just (a,r) +splitKindFunTy_maybe _ = Nothing + +-- | Essentially 'splitFunTysN' on kinds +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN 0 k = ([], k) +splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of + (as, k) -> (a:as, k) +splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon) + (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) + +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +isOpenTypeKind, isUnliftedTypeKind, + isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool + +isOpenTypeKindCon, isUnliftedTypeKindCon, + isSubOpenTypeKindCon, isConstraintKindCon, + isLiftedTypeKindCon, isAnyKindCon, isSuperKindTyCon :: TyCon -> Bool + + +isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey +isAnyKindCon tc = tyConUnique tc == anyKindTyConKey +isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey +isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey +isSuperKindTyCon tc = tyConUnique tc == superKindTyConKey + +isAnyKind (TyConApp tc _) = isAnyKindCon tc +isAnyKind _ = False + +isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc +isOpenTypeKind _ = False + +isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc +isUnliftedTypeKind _ = False + +isConstraintKind (TyConApp tc _) = isConstraintKindCon tc +isConstraintKind _ = False + +isConstraintOrLiftedKind (TyConApp tc _) + = isConstraintKindCon tc || isLiftedTypeKindCon tc +isConstraintOrLiftedKind _ = False + +returnsConstraintKind :: Kind -> Bool +returnsConstraintKind (ForAllTy _ k) = returnsConstraintKind k +returnsConstraintKind (FunTy _ k) = returnsConstraintKind k +returnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc +returnsConstraintKind _ = False + +-------------------------------------------- +-- Kinding for arrow (->) +-- Says when a kind is acceptable on lhs or rhs of an arrow +-- arg -> res + +okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool +okArrowArgKindCon = isSubOpenTypeKindCon +okArrowResultKindCon = isSubOpenTypeKindCon + +okArrowArgKind, okArrowResultKind :: Kind -> Bool +okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc +okArrowArgKind _ = False + +okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc +okArrowResultKind _ = False + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where we don't want the +-- Constraint kind to be a subkind of anything +-- After type-checking (in core), Constraint is a subkind of openTypeKind + +isSubOpenTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc +isSubOpenTypeKind _ = False + +isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc) + +isSubOpenTypeKindKey :: Unique -> Bool +isSubOpenTypeKindKey uniq + = uniq == openTypeKindTyConKey + || uniq == unliftedTypeKindTyConKey + || uniq == liftedTypeKindTyConKey + || uniq == constraintKindTyConKey -- Needed for error (Num a) "blah" + -- and so that (Ord a -> Eq a) is well-kinded + -- and so that (# Eq a, Ord b #) is well-kinded + -- See Note [Kind Constraint and kind *] + +-- | Is this a kind (i.e. a type-of-types)? +isKind :: Kind -> Bool +isKind k = isSuperKind (typeKind k) + +isSubKind :: Kind -> Kind -> Bool +-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ +-- Sub-kinding is extremely simple and does not look +-- under arrrows or type constructors + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) + | isPromotedTyCon kc1 || isPromotedTyCon kc2 + -- handles promoted kinds (List *, Nat, etc.) + = eqKind k1 k2 + + | otherwise -- handles usual kinds (*, #, (#), etc.) + = ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) + kc1 `isSubKindCon` kc2 + +isSubKind k1 k2 = eqKind k1 k2 + +isSubKindCon :: TyCon -> TyCon -> Bool +-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +isSubKindCon kc1 kc2 + | kc1 == kc2 = True + | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 + | isConstraintKindCon kc1 = isLiftedTypeKindCon kc2 + | isLiftedTypeKindCon kc1 = isConstraintKindCon kc2 + -- See Note [Kind Constraint and kind *] + | otherwise = False + +------------------------- +-- Hack alert: we need a tiny variant for the typechecker +-- Reason: f :: Int -> (a~b) +-- g :: forall (c::Constraint). Int -> c +-- h :: Int => Int +-- We want to reject these, even though Constraint is +-- a sub-kind of OpenTypeKind. It must be a sub-kind of OpenTypeKind +-- *after* the typechecker +-- a) So that (Ord a -> Eq a) is a legal type +-- b) So that the simplifer can generate (error (Eq a) "urk") +-- Moreover, after the type checker, Constraint and * +-- are identical; see Note [Kind Constraint and kind *] +-- +-- Easiest way to reject is simply to make Constraint a compliete +-- below OpenTypeKind when type checking + +tcIsSubKind :: Kind -> Kind -> Bool +tcIsSubKind k1 k2 + | isConstraintKind k1 = isConstraintKind k2 + | isConstraintKind k2 = isConstraintKind k1 + | otherwise = isSubKind k1 k2 + +tcIsSubKindCon :: TyCon -> TyCon -> Bool +tcIsSubKindCon kc1 kc2 + | isConstraintKindCon kc1 = isConstraintKindCon kc2 + | isConstraintKindCon kc2 = isConstraintKindCon kc1 + | otherwise = isSubKindCon kc1 kc2 + +------------------------- +defaultKind :: Kind -> Kind +defaultKind_maybe :: Kind -> Maybe Kind +-- ^ Used when generalising: default OpenKind and ArgKind to *. +-- See "Type#kind_subtyping" for more information on what that means + +-- When we generalise, we make generic type variables whose kind is +-- simple (* or *->* etc). So generic type variables (other than +-- built-in constants like 'error') always have simple kinds. This is important; +-- consider +-- f x = True +-- We want f to get type +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::ArgKind). a -> Bool +-- because that would allow a call like (f 3#) as well as (f True), +-- and the calling conventions differ. +-- This defaulting is done in TcMType.zonkTcTyVarBndr. +-- +-- The test is really whether the kind is strictly above '*' +defaultKind_maybe (TyConApp kc _args) + | isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind +defaultKind_maybe _ = Nothing + +defaultKind k = defaultKind_maybe k `orElse` k + +-- Returns the free kind variables in a kind +kiVarsOfKind :: Kind -> VarSet +kiVarsOfKind = tyVarsOfType + +kiVarsOfKinds :: [Kind] -> VarSet +kiVarsOfKinds = tyVarsOfTypes diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs new file mode 100644 index 00000000..c889f8a7 --- /dev/null +++ b/compiler/types/OptCoercion.hs @@ -0,0 +1,741 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module OptCoercion ( optCoercion, checkAxInstCo ) where + +#include "HsVersions.h" + +import Coercion +import Type hiding( substTyVarBndr, substTy, extendTvSubst ) +import TcType ( exactTyVarsOfType ) +import TyCon +import CoAxiom +import Var +import VarSet +import FamInstEnv ( flattenTys ) +import VarEnv +import StaticFlags ( opt_NoOptCoercion ) +import Outputable +import Pair +import FastString +import Util +import Unify +import ListSetOps +import InstEnv +import Control.Monad ( zipWithM ) + +{- +************************************************************************ +* * + Optimising coercions +* * +************************************************************************ + +Note [Subtle shadowing in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we optimising a coercion + optCoercion (forall (co_X5:t1~t2). ...co_B1...) +The co_X5 is a wild-card; the bound variable of a coercion for-all +should never appear in the body of the forall. Indeed we often +write it like this + optCoercion ( (t1~t2) => ...co_B1... ) + +Just because it's a wild-card doesn't mean we are free to choose +whatever variable we like. For example it'd be wrong for optCoercion +to return + forall (co_B1:t1~t2). ...co_B1... +because now the co_B1 (which is really free) has been captured, and +subsequent substitutions will go wrong. That's why we can't use +mkCoPredTy in the ForAll case, where this note appears. + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. +-} + +optCoercion :: CvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion env co + | opt_NoOptCoercion = substCo env co + | otherwise = opt_co1 env False co + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. +opt_co1 :: CvSubst + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co +{- +opt_co env sym co + = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ + co1 `seq` + pprTrace "opt_co done }" (ppr co1) $ + (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co) + $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) ) + WARN( not (coreEqCoercion co1 simple_result), + (text "env=" <+> ppr env) $$ + (text "input=" <+> ppr co) $$ + (text "simple=" <+> ppr simple_result) $$ + (text "opt=" <+> ppr co1) ) + co1) + where + co1 = opt_co' env sym co + same_co_kind = s1 `eqType` s2 && t1 `eqType` t2 + Pair s t = coercionKind (substCo env co) + (s1,t1) | sym = (t,s) + | otherwise = (s,t) + Pair s2 t2 = coercionKind co1 + + simple_result | sym = mkSymCo (substCo env co) + | otherwise = substCo env co +-} + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: CvSubst + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: CvSubst -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4 env sym False r co + + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4 :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4 env _ rep r (Refl _r ty) + = ASSERT( r == _r ) + Refl (chooseRole rep r) (substTy env ty) + +opt_co4 env sym rep r (SymCo co) = opt_co4 env (not sym) rep r co + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesX Representational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesX r tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4 env sym rep r co1) + (opt_co4 env sym False Nominal co2) +opt_co4 env sym rep r (ForAllCo tv co) + = case substTyVarBndr env tv of + (env', tv') -> mkForAllCo tv' (opt_co4 env' sym rep r co) + -- Use the "mk" functions to check for nested Refls + +opt_co4 env sym rep r (CoVarCo cv) + | Just co <- lookupCoVar env cv + = opt_co4 (zapCvSubstEnv env) sym rep r co + + | Just cv1 <- lookupInScope (getCvInScope env) cv + = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym (CoVarCo cv1) + -- cv1 might have a substituted kind! + + | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) + ASSERT( isCoVar cv ) + wrapRole rep r $ wrapSym sym (CoVarCo cv) + +opt_co4 env sym rep r (AxiomInstCo con ind cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4 env sym rep r (UnivCo s _r oty1 oty2) + = ASSERT( r == _r ) + opt_univ env s (chooseRole rep r) a b + where + (a,b) = if sym then (oty2,oty1) else (oty1,oty2) + +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 + in_scope = getCvInScope env + +opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co + +opt_co4 env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = ASSERT( r == Nominal ) + opt_co4 env sym rep Nominal (pickLR lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = ASSERT( r == Nominal ) + if rep + then opt_co4 (zapCvSubstEnv env) False True Nominal (pickLR lr pr_co) + else pickLR lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4 env sym False Nominal co + +opt_co4 env sym rep r (InstCo co ty) + -- See if the first arg is already a forall + -- ...then we can just extend the current substitution + | Just (tv, co_body) <- splitForAllCo_maybe co + = opt_co4 (extendTvSubst env tv ty') sym rep r co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution + | Just (tv, co'_body) <- splitForAllCo_maybe co' + = substCoWithTy (getCvInScope env) tv ty' co'_body + + | otherwise = InstCo co' ty' + where + co' = opt_co4 env sym rep r co + ty' = substTy env ty + +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4 env sym True Nominal co + +-- XXX: We could add another field to CoAxiomRule that +-- would allow us to do custom simplifications. +opt_co4 env sym rep r (AxiomRuleCo co ts cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ + wrapSym sym $ + AxiomRuleCo co (map (substTy env) ts) + (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: CvSubst -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = if sym + then opt_univ env (fsLit "opt_phantom") Phantom ty2 ty1 + else opt_univ env (fsLit "opt_phantom") Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +opt_univ :: CvSubst -> FastString -> Role -> Type -> Type -> Coercion +opt_univ env prov role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + = mkTyConAppCo role tc1 (zipWith3 (opt_univ env prov) (tyConRolesX role tc1) tys1 tys2) + + | Just (l1, r1) <- splitAppTy_maybe oty1 + , Just (l2, r2) <- splitAppTy_maybe oty2 + , typeKind l1 `eqType` typeKind l2 -- kind(r1) == kind(r2) by consequence + = let role' = if role == Phantom then Phantom else Nominal in + -- role' is to comform to mkAppCo's precondition + mkAppCo (opt_univ env prov role l1 l2) (opt_univ env prov role' r1 r2) + + | Just (tv1, ty1) <- splitForAllTy_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_maybe oty2 + , tyVarKind tv1 `eqType` tyVarKind tv2 -- rule out a weird unsafeCo + = case substTyVarBndr2 env tv1 tv2 of { (env1, env2, tv') -> + let ty1' = substTy env1 ty1 + ty2' = substTy env2 ty2 in + mkForAllCo tv' (opt_univ (zapCvSubstEnv2 env1 env2) prov role ty1' ty2') } + + | otherwise + = mkUnivCo prov role (substTy env oty1) (substTy env oty2) + +------------- +-- NthCo must be handled separately, because it's the one case where we can't +-- tell quickly what the component coercion's role is from the containing +-- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, +-- we just look for nested NthCo's, which can happen in practice. +opt_nth_co :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_nth_co env sym rep r = go [] + where + go ns (NthCo n co) = go (n:ns) co + -- previous versions checked if the tycon is decomposable. This + -- is redundant, because a non-decomposable tycon under an NthCo + -- is entirely bogus. See docs/core-spec/core-spec.pdf. + go ns co + = opt_nths ns co + + -- input coercion is *not* yet sym'd or opt'd + opt_nths [] co = opt_co4 env sym rep r co + opt_nths (n:ns) (TyConAppCo _ _ cos) = opt_nths ns (cos `getNth` n) + + -- here, the co isn't a TyConAppCo, so we opt it, hoping to get + -- a TyConAppCo as output. We don't know the role, so we use + -- opt_co1. This is slightly annoying, because opt_co1 will call + -- coercionRole, but as long as we don't have a long chain of + -- NthCo's interspersed with some other coercion former, we should + -- be OK. + opt_nths ns co = opt_nths' ns (opt_co1 env sym co) + + -- input coercion *is* sym'd and opt'd + opt_nths' [] co + = if rep && (r == Nominal) + -- propagate the SubCo: + then opt_co4 (zapCvSubstEnv env) False True r co + else co + opt_nths' (n:ns) (TyConAppCo _ _ cos) = opt_nths' ns (cos `getNth` n) + opt_nths' ns co = wrapRole rep r (mk_nths ns co) + + mk_nths [] co = co + mk_nths (n:ns) co = mk_nths ns (mkNthCo n co) + +------------- +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqType` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + TyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + = fireTransRule "TrPushApp" in_co1 in_co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = ASSERT( length cos1 == length cos2 ) + fireTransRule "EtaCompL" co1 co2 $ + TyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = ASSERT( length cos1 == length cos2 ) + fireTransRule "EtaCompR" co1 co2 $ + TyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = fireTransRule "EtaAppL" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = fireTransRule "EtaAppR" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +-- Push transitivity inside forall +opt_trans_rule is co1 co2 + | Just (tv1,r1) <- splitForAllCo_maybe co1 + , Just (tv2,r2) <- etaForAllCo_maybe co2 + , let r2' = substCoWithTy is' tv2 (mkTyVarTy tv1) r2 + is' = is `extendInScopeSet` tv1 + = fireTransRule "EtaAllL" co1 co2 $ + mkForAllCo tv1 (opt_trans2 is' r1 r2') + + | Just (tv2,r2) <- splitForAllCo_maybe co2 + , Just (tv1,r1) <- etaForAllCo_maybe co1 + , let r1' = substCoWithTy is' tv1 (mkTyVarTy tv2) r1 + is' = is `extendInScopeSet` tv2 + = fireTransRule "EtaAllR" co1 co2 $ + mkForAllCo tv1 (opt_trans2 is' r1' r2) + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- See Note [Why call checkAxInstCo during optimisation] + -- TrPushSymAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , Just cos2 <- matchAxiom sym con ind co2 + , True <- sym + , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , Just cos2 <- matchAxiom sym con ind co2 + , False <- sym + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , Just cos1 <- matchAxiom (not sym) con ind co1 + , True <- sym + , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , Just cos1 <- matchAxiom (not sym) con ind co1 + , False <- sym + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , ind1 == ind2 + , sym1 == not sym2 + , let branch = coAxiomNthBranch con1 ind1 + qtvs = coAxBranchTyVars branch + lhs = coAxNthLHS con1 ind1 + rhs = coAxBranchRHS branch + pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! + +opt_trans_rule _ co1 co2 -- Identity rule + | (Pair ty1 _, r) <- coercionKindRole co1 + , Pair _ ty2 <- coercionKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + Refl r ty2 + +opt_trans_rule _ _ _ = Nothing + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $ + Just res + +{- +Note [Conflict checking with AxiomInstCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::BOX. k -> k -> Bool +axEqual :: { forall k::BOX. forall a::k. Equal k a a ~ True + ; forall k::BOX. forall a::k. forall b::k. Equal k a b ~ False } + +We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ +False) and that all is OK. But, all is not OK: we want to use the first branch +of the axiom in this case, not the second. The problem is that the parameters +of the first branch can unify with the supplied coercions, thus meaning that +the first branch should be taken. See also Note [Branched instance checking] +in types/FamInstEnv.lhs. + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. +-} + +-- | Check to make sure that an AxInstCo is internally consistent. +-- Returns the conflicting branch, if it exists +-- See Note [Conflict checking with AxiomInstCo] +checkAxInstCo :: Coercion -> Maybe CoAxBranch +-- defined here to avoid dependencies in Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in CoreLint +checkAxInstCo (AxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + incomps = coAxBranchIncomps branch + tys = map (pFst . coercionKind) cos + subst = zipOpenTvSubst tvs tys + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps + where + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b +checkAxInstCo _ = Nothing + +----------- +wrapSym :: SymFlag -> Coercion -> Coercion +wrapSym sym co | sym = SymCo co + | otherwise = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r +----------- +-- takes two tyvars and builds env'ts to map them to the same tyvar +substTyVarBndr2 :: CvSubst -> TyVar -> TyVar + -> (CvSubst, CvSubst, TyVar) +substTyVarBndr2 env tv1 tv2 + = case substTyVarBndr env tv1 of + (env1, tv1') -> (env1, extendTvSubstAndInScope env tv2 (mkTyVarTy tv1'), tv1') + +zapCvSubstEnv2 :: CvSubst -> CvSubst -> CvSubst +zapCvSubstEnv2 env1 env2 = mkCvSubst (is1 `unionInScope` is2) [] + where is1 = getCvInScope env1 + is2 = getCvInScope env2 +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, ind, cos) <- isAxiom_maybe co + = Just (not sym, con, ind, cos) +isAxiom_maybe (AxiomInstCo con ind cos) + = Just (False, con, ind, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] +-- If we succeed in matching, then *all the quantified type variables are bound* +-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail +matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co + = let (CoAxBranch { cab_tvs = qtvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs }) = coAxiomNthBranch ax ind in + case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of + Nothing -> Nothing + Just subst -> zipWithM (liftCoSubstTyVar subst) roles qtvs + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + Pair _ x1 = coercionKind co1 + Pair x2 _ = coercionKind co2 + +------------- +etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +-- Try to make the coercion be of form (forall tv. co) +etaForAllCo_maybe co + | Just (tv, r) <- splitForAllCo_maybe co + = Just (tv, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_maybe ty1 + , Just (tv2, _) <- splitForAllTy_maybe ty2 + , tyVarKind tv1 `eqKind` tyVarKind tv2 + = Just (tv1, mkInstCo co (mkTyVarTy tv1)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | isDecomposableTyCon tc + , Pair ty1 ty2 <- coercionKind co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , let n = length tys1 + = ASSERT( tc == tc1 ) + ASSERT( n == length tys2 ) + Just (decomposeCo n co) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 +-} diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs new file mode 100644 index 00000000..ac915c82 --- /dev/null +++ b/compiler/types/TyCon.hs @@ -0,0 +1,1851 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module TyCon( + -- * Main TyCon data types + TyCon, FieldLabel, + + AlgTyConRhs(..), visibleDataCons, + TyConParent(..), isNoParent, + FamTyConFlav(..), Role(..), + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkPromotedTyCon, + + -- ** Predicates on TyCons + isAlgTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isTypeSynonymTyCon, + isDecomposableTyCon, + isPromotedDataCon, isPromotedTyCon, + isPromotedDataCon_maybe, isPromotedTyCon_maybe, + promotableTyCon_maybe, promoteTyCon, + + isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyCon_maybe, + isBuiltInSynFamTyCon_maybe, + isUnLiftedTyCon, + isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, + isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, + isRecursiveTyCon, + isImplicitTyCon, + + -- ** Extracting information out of TyCons + tyConName, + tyConKind, + tyConUnique, + tyConTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConRoles, + tyConParent, + tyConTuple_maybe, tyConClass_maybe, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, famTyConFlav_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + tupleTyConBoxity, tupleTyConSort, tupleTyConArity, + + -- ** Manipulating TyCons + tcExpandTyCon_maybe, coreExpandTyCon_maybe, + makeTyConAbstract, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + tyConPrimRep, isVoidRep, isGcPtrRep, + primRepSizeW, primElemRepSizeB, + + -- * Recursion breaking + RecTcChecker, initRecTc, checkRecTc + +) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) + +import Var +import Class +import BasicTypes +import DynFlags +import ForeignCall +import Name +import NameSet +import CoAxiom +import PrelNames +import Maybes +import Outputable +import Constants +import Util +import qualified Data.Data as Data +import Data.Typeable (Typeable) + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +* In the future we might want to support + * injective type families (allow decomposition) + but we don't at the moment [2013] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in MkId.lhs + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as he did with type + synonym families. He just sees constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~ R:TInt + + The R:TInt is the "representation TyCons". + It has an AlgTyConParent of + FamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data family axioms] in TcInstDcls + +* The data contructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~ R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConParent of + + FamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced inot + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is only used for overlap checking + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a TyConParent of AssocFamilyTyCon, which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyvars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +************************************************************************ +* * +\subsection{The data type} +* * +************************************************************************ +-} + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data TyCon + = -- | The function type constructor, @(->)@ + FunTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + } + + -- | Algebraic type constructors, which are defined to be those + -- arising @data@ type and @newtype@ declarations. All these + -- constructors are lifted and boxed. See 'AlgTyConRhs' for more + -- information. + | AlgTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the + -- type constructor. + -- Invariant: length tyvars = arity + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcRec :: RecFlag, -- ^ Tells us whether the data type is part + -- of a mutually-recursive group or not + + algTcParent :: TyConParent, -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + -- See also 'synTcParent' + + tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any + } + + -- | Represents the infinite family of tuple type constructors, + -- @()@, @(a,b)@, @(# a, b #)@ etc. + | TupleTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTupleSort :: TupleSort,-- ^ Is this a boxed, unboxed or constraint + -- tuple? + + tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this + -- TyCon. Includes implicit kind variables. + -- Invariant: + -- length tyConTyVars = tyConArity + + dataCon :: DataCon, -- ^ Corresponding tuple data constructor + + tcPromoted :: Maybe TyCon + -- ^ Nothing for unboxed tuples + } + + -- | Represents type synonyms + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this + -- TyCon. Includes implicit kind variables. + -- Invariant: length tyConTyVars = tyConArity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type -- ^ Contains information about the expansion + -- of the synonym + } + + -- | Represents type families + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the + -- type constructor. + -- Invariant: length tyvars = arity + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in 'algTyConRhs.NewTyCon' + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: TyConParent -- ^ TyCon of enclosing class for + -- associated type families + + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds + | PrimTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + primTyConRep :: PrimRep,-- ^ Many primitive tycons are unboxed, but + -- some are boxed (represented by + -- pointers). This 'PrimRep' holds that + -- information. Only relevant if tyConKind = * + + isUnLifted :: Bool -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, + tyConKind :: Kind, -- ^ Translated type of the data constructor + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon -- ^ Corresponding data constructor + } + + -- | Represents promoted type constructor. + | PromotedTyCon { + tyConUnique :: Unique, -- ^ Same Unique as the type constructor + tyConName :: Name, -- ^ Same Name as the type constructor + tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + tyConKind :: Kind, -- ^ Always TysPrim.superKind + ty_con :: TyCon -- ^ Corresponding type constructor + } + + deriving Typeable + +-- | Names of the fields in an algebraic record type +type FieldLabel = Name + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + Bool -- True <=> It's definitely a distinct data type, + -- equal only to itself; ie not a newtype + -- False <=> Not sure + -- See Note [AbstractTyCon and type equality] + + -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + | DataFamilyTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in DataCon.mkDataCon) + + is_enum :: Bool -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check Trac #1072. + } + +{- +Note [AbstractTyCon and type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO +-} + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons DataFamilyTyCon {} = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] + +-- ^ Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. We use 'TyConParent' for both algebraic and synonym +-- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's. +data TyConParent + = -- | An ordinary type constructor has no parent. + NoParentTyCon + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in TypeRep + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + + -- | An *associated* type of a class. + | AssocFamilyTyCon + Class -- The class in whose declaration the family is declared + -- See Note [Associated families and their parent class] + + -- | Type constructors representing an instance of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | FamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- Generally of kind T ty1 ty2 ~ R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see TcInstDcls + -- Note [Eta reduction for data family axioms] + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- Match in length the tyConTyVars of the family TyCon + + -- E.g. data intance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = FamInstTyCon T [a] co + +instance Outputable TyConParent where + ppr NoParentTyCon = text "No parent" + ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls + ppr (AssocFamilyTyCon cls) = + text "Class parent (assoc. family)" <+> ppr cls + ppr (FamInstTyCon _ tc tys) = + text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) + +-- | Checks the invariants of a 'TyConParent' given the appropriate type class +-- name, if any +okParent :: Name -> TyConParent -> Bool +okParent _ NoParentTyCon = True +okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) +okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) +okParent _ (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys + +isNoParent :: TyConParent -> Bool +isNoParent NoParentTyCon = True +isNoParent _ = False + +-------------------- + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | An open type synonym family e.g. @type family F x y :: * -> *@ + OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon + (CoAxiom Branched) -- The one axiom for this family + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +{- +Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A data constructor can be promoted to become a type constructor, +via the PromotedTyCon alternative in TyCon. + +* Only data constructors with + (a) no kind polymorphism + (b) no constraints in its type (eg GADTs) + are promoted. Existentials are ok; see Trac #7347. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* The *kind* of a promoted DataCon may be polymorphic. Example: + type of DataCon Just :: forall (a:*). a -> Maybe a + kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a + The kind is not identical to the type, because of the */box + kind signature on the forall'd variable; so the tyConKind field of + PromotedTyCon is not identical to the dataConUserType of the + DataCon. But it's the same modulo changing the variable kinds, + done by DataCon.promoteType. + +* Small note: We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + MkT :: (Bool,Bool) -> T + *not* + MkT :: Bool -> Bool -> T + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See Trac #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. + +In the case that the right hand side is a type application +ending with the same type variables as the left hand side, we +"eta-contract" the coercion. So if we had + + newtype S a = MkT [a] + +then we would generate the arity 0 axiom CoS : S ~ []. The +primary reason we do this is to make newtype deriving cleaner. + +In the paper we'd write + axiom CoT : (forall t. T t) ~ (forall t. [t]) +and then when we used CoT at a particular type, s, we'd say + CoT @ s +which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal (to Core)? + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to ([], Froogle), so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. The cached field is +only used in coreExpandTyCon_maybe. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we get: + w2 :: Foo T + w2 = w1 +And now Lint complains unless Foo T == Foo [], and that requires T==[] + +This point carries over to the newtype coercion, because we need to +say + w2 = w1 `cast` Foo CoT + +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + +************************************************************************ +* * +\subsection{PrimRep} +* * +************************************************************************ + +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width (cmm/CmmType) is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W80 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. +data PrimRep + = VoidRep + | PtrRep + | IntRep -- ^ Signed, word-sized value + | WordRep -- ^ Unsigned, word-sized value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Eq, Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep PtrRep = True +isGcPtrRep _ = False + +-- | Find the size of a 'PrimRep', in words +primRepSizeW :: DynFlags -> PrimRep -> Int +primRepSizeW _ IntRep = 1 +primRepSizeW _ WordRep = 1 +primRepSizeW dflags Int64Rep = wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW dflags Word64Rep = wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW _ FloatRep = 1 -- NB. might not take a full word +primRepSizeW dflags DoubleRep = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +primRepSizeW _ AddrRep = 1 +primRepSizeW _ PtrRep = 1 +primRepSizeW _ VoidRep = 0 +primRepSizeW dflags (VecRep len rep) = len * primElemRepSizeB rep `quot` wORD_SIZE dflags + +primElemRepSizeB :: PrimElemRep -> Int +primElemRepSizeB Int8ElemRep = 1 +primElemRepSizeB Int16ElemRep = 2 +primElemRepSizeB Int32ElemRep = 4 +primElemRepSizeB Int64ElemRep = 8 +primElemRepSizeB Word8ElemRep = 1 +primElemRepSizeB Word16ElemRep = 2 +primElemRepSizeB Word32ElemRep = 4 +primElemRepSizeB Word64ElemRep = 8 +primElemRepSizeB FloatElemRep = 4 +primElemRepSizeB DoubleElemRep = 8 + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +-- | Given the name of the function type constructor and it's kind, create the +-- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want +-- this functionality +mkFunTyCon :: Name -> Kind -> TyCon +mkFunTyCon name kind + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConKind = kind, + tyConArity = 2 + } + +-- | This is the making of an algebraic 'TyCon'. Notably, you have to +-- pass in the generic (in the -XGenerics sense) information about the +-- type constructor - you can get hold of it easily (see Generics +-- module) +mkAlgTyCon :: Name + -> Kind -- ^ Kind of the resulting 'TyCon' + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. + -- Arity is inferred from the length of this + -- list + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about dat aconstructors + -> TyConParent + -> RecFlag -- ^ Is the 'TyCon' recursive? + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> Maybe TyCon -- ^ Promoted version + -> TyCon +mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcRec = is_rec, + algTcGadtSyntax = gadt_syn, + tcPromoted = prom_tc + } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class + -> RecFlag -> TyCon +mkClassTyCon name kind tyvars roles rhs clas is_rec + = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas) + is_rec False + Nothing -- Class TyCons are not pormoted + +mkTupleTyCon :: Name + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the tuple + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> Maybe TyCon -- ^ Promoted version + -> TyCon +mkTupleTyCon name kind arity tyvars con sort prom_tc + = TupleTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConKind = kind, + tyConArity = arity, + tyConTupleSort = sort, + tyConTyVars = tyvars, + dataCon = con, + tcPromoted = prom_tc + } + +-- | Create an unlifted primitive 'TyCon', such as @Int#@ +mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon +mkPrimTyCon name kind roles rep + = mkPrimTyCon' name kind roles rep True + +-- | Kind constructors +mkKindTyCon :: Name -> Kind -> TyCon +mkKindTyCon name kind + = mkPrimTyCon' name kind [] VoidRep True + +-- | Create a lifted primitive 'TyCon' such as @RealWorld@ +mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon +mkLiftedPrimTyCon name kind roles rep + = mkPrimTyCon' name kind roles rep False + +mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep -> Bool -> TyCon +mkPrimTyCon' name kind roles rep is_unlifted + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length roles, + tcRoles = roles, + primTyConRep = rep, + isUnLifted = is_unlifted + } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> Kind -> [TyVar] -> [Role] -> Type -> TyCon +mkSynonymTyCon name kind tyvars roles rhs + = SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tcRoles = roles, + synTcRhs = rhs + } + +-- | Create a type family 'TyCon' +mkFamilyTyCon:: Name -> Kind -> [TyVar] -> FamTyConFlav -> TyConParent + -> TyCon +mkFamilyTyCon name kind tyvars flav parent + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConKind = kind + , tyConArity = length tyvars + , tyConTyVars = tyvars + , famTcFlav = flav + , famTcParent = parent + } + + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> [Role] -> TyCon +mkPromotedDataCon con name unique kind roles + = PromotedDataCon { + tyConName = name, + tyConUnique = unique, + tyConArity = arity, + tcRoles = roles, + tyConKind = kind, + dataCon = con + } + where + arity = length roles + +-- | Create a promoted type constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the type constructor itself +mkPromotedTyCon :: TyCon -> Kind -> TyCon +mkPromotedTyCon tc kind + = PromotedTyCon { + tyConName = getName tc, + tyConUnique = getUnique tc, + tyConArity = tyConArity tc, + tyConKind = kind, + ty_con = tc + } + +isFunTyCon :: TyCon -> Bool +isFunTyCon (FunTyCon {}) = True +isFunTyCon _ = False + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True +isAbstractTyCon _ = False + +-- | Make an algebraic 'TyCon' abstract. Panics if the supplied 'TyCon' is not +-- algebraic +makeTyConAbstract :: TyCon -> TyCon +makeTyConAbstract tc@(AlgTyCon { algTcRhs = rhs }) + = tc { algTcRhs = AbstractTyCon (isDistinctAlgRhs rhs) } +makeTyConAbstract tc = pprPanic "makeTyConAbstract" (ppr tc) + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (PrimTyCon {}) = True +isPrimTyCon _ = False + +-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can +-- only be true for primitive and unboxed-tuple 'TyCon's +isUnLiftedTyCon :: TyCon -> Bool +isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted +isUnLiftedTyCon (TupleTyCon {tyConTupleSort = sort}) + = not (isBoxed (tupleSortBoxity sort)) +isUnLiftedTyCon _ = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (AlgTyCon {}) = True +isAlgTyCon (TupleTyCon {}) = True +isAlgTyCon _ = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples and type family 'TyCon's. But it is +-- not guaranteed to return @True@ in all cases that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon {} -> True + NewTyCon {} -> False + DataFamilyTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) +isDataTyCon _ = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) +-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) +-- See also Note [Decomposing equalities] in TcCanonical +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon _ Phantom = False +isInjectiveTyCon (FunTyCon {}) _ = True +isInjectiveTyCon (AlgTyCon {}) Nominal = True +isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs +isInjectiveTyCon (TupleTyCon {}) _ = True +isInjectiveTyCon (SynonymTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (PrimTyCon {}) _ = True +isInjectiveTyCon (PromotedDataCon {}) _ = True +isInjectiveTyCon (PromotedTyCon {ty_con = tc}) r + = isInjectiveTyCon tc r + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T tys ~X t), then (t's head ~X T). +-- See also Note [Decomposing equalities] in TcCanonical +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon = isInjectiveTyCon + -- as it happens, generativity and injectivity coincide, but there's + -- no a priori reason this must be the case + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (DataFamilyTyCon {}) = False +isGenInjAlgRhs (AbstractTyCon distinct) = distinct +isGenInjAlgRhs (NewTyCon {}) = False + +-- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to +-- themselves, even via coercions (except for unsafeCoerce). +-- This excludes newtypes, type functions, type synonyms. +-- It relates directly to the FC consistency story: +-- If the axioms are consistent, +-- and co : S tys ~ T tys, and S,T are "distinct" TyCons, +-- then S=T. +-- Cf Note [Pruning dead case alternatives] in Unify +isDistinctTyCon :: TyCon -> Bool +isDistinctTyCon (AlgTyCon {algTcRhs = rhs}) = isDistinctAlgRhs rhs +isDistinctTyCon (FunTyCon {}) = True +isDistinctTyCon (TupleTyCon {}) = True +isDistinctTyCon (PrimTyCon {}) = True +isDistinctTyCon (PromotedDataCon {}) = True +isDistinctTyCon _ = False + +isDistinctAlgRhs :: AlgTyConRhs -> Bool +isDistinctAlgRhs (DataTyCon {}) = True +isDistinctAlgRhs (DataFamilyTyCon {}) = False +isDistinctAlgRhs (AbstractTyCon distinct) = distinct +isDistinctAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands +-- into, and (possibly) a coercion from the representation type to the @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) +unwrapNewTyCon_maybe _ = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, + nt_etad_rhs = (tvs,rhs) }}) + = Just (tvs, rhs, co) +unwrapNewTyConEtad_maybe _ = Nothing + +isProductTyCon :: TyCon -> Bool +-- True of datatypes or newtypes that have +-- one, vanilla, data constructor +isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of + DataTyCon{ data_cons = [data_con] } + -> isVanillaDataCon data_con + NewTyCon {} -> True + _ -> False +isProductTyCon (TupleTyCon {}) = True +isProductTyCon _ = False + + +isDataProductTyCon_maybe :: TyCon -> Maybe DataCon +-- True of datatypes (not newtypes) with +-- one, vanilla, data constructor +isDataProductTyCon_maybe (AlgTyCon { algTcRhs = DataTyCon { data_cons = cons } }) + | [con] <- cons -- Singleton + , isVanillaDataCon con -- Vanilla + = Just con +isDataProductTyCon_maybe (TupleTyCon { dataCon = con }) + = Just con +isDataProductTyCon_maybe _ = Nothing + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False + + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +isDecomposableTyCon :: TyCon -> Bool +-- True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective? +-- Specifically NOT true of synonyms (open and otherwise) +-- Ultimately we may have injective associated types +-- in which case this test will become more interesting +-- +-- It'd be unusual to call isDecomposableTyCon on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +isDecomposableTyCon (SynonymTyCon {}) = False +isDecomposableTyCon (FamilyTyCon {}) = False +isDecomposableTyCon _other = True + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in TyCon +isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res +isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0 +isEnumerationTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True +isOpenFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon {}) = True +isTypeFamilyTyCon _ = False + +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False + +-- leave out abstract closed families here +isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyCon_maybe + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon ax}) = Just ax +isClosedSynFamilyTyCon_maybe _ = Nothing + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isDataFamilyTyCon _ = False + +-- | Are we able to extract informationa 'TyVar' to class argument list +-- mappping from a given 'TyCon'? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc tc = isJust (tyConAssoc_maybe tc) + +tyConAssoc_maybe :: TyCon -> Maybe Class +tyConAssoc_maybe tc = case tyConParent tc of + AssocFamilyTyCon cls -> Just cls + _ -> Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (TupleTyCon {}) = True +isTupleTyCon _ = False + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) = + not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False + +-- | Extract the boxity of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConBoxity :: TyCon -> Boxity +tupleTyConBoxity tc = tupleSortBoxity (tyConTupleSort tc) + +-- | Extract the 'TupleSort' of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConSort :: TyCon -> TupleSort +tupleTyConSort tc = tyConTupleSort tc + +-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConArity :: TyCon -> Arity +tupleTyConArity tc = tyConArity tc + +-- | Is this a recursive 'TyCon'? +isRecursiveTyCon :: TyCon -> Bool +isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True +isRecursiveTyCon _ = False + +promotableTyCon_maybe :: TyCon -> Maybe TyCon +promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom +promotableTyCon_maybe (TupleTyCon { tcPromoted = prom }) = prom +promotableTyCon_maybe _ = Nothing + +promoteTyCon :: TyCon -> TyCon +promoteTyCon tc = case promotableTyCon_maybe tc of + Just prom_tc -> prom_tc + Nothing -> pprPanic "promoteTyCon" (ppr tc) + +-- | Is this a PromotedTyCon? +isPromotedTyCon :: TyCon -> Bool +isPromotedTyCon (PromotedTyCon {}) = True +isPromotedTyCon _ = False + +-- | Retrieves the promoted TyCon if this is a PromotedTyCon; +isPromotedTyCon_maybe :: TyCon -> Maybe TyCon +isPromotedTyCon_maybe (PromotedTyCon { ty_con = tc }) = Just tc +isPromotedTyCon_maybe _ = Nothing + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (TupleTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (PromotedTyCon {}) = True +isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (AlgTyCon {}) = False +isImplicitTyCon (FamilyTyCon { famTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (FamilyTyCon {}) = False +isImplicitTyCon (SynonymTyCon {}) = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +tcExpandTyCon_maybe, coreExpandTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application + +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' +tcExpandTyCon_maybe (SynonymTyCon { tyConTyVars = tvs + , synTcRhs = rhs }) tys + = expand tvs rhs tys +tcExpandTyCon_maybe _ _ = Nothing + +--------------- + +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- not only closed synonyms like 'tcExpandTyCon_maybe', +-- but also non-recursive @newtype@s +coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys + + +---------------- +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion +expand tvs rhs tys + = case n_tvs `compare` length tys of + LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) + EQ -> Just (tvs `zip` tys, rhs, []) + GT -> Nothing + where + n_tvs = length tvs + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) + = Just cons +tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) + = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) + = Just [con] +tyConDataCons_maybe _ + = Nothing + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = + length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = 0 +tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity}) + = DataTyCon { data_cons = [con], is_enum = arity == 0 } +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> const_role Representational + ; AlgTyCon { tcRoles = roles } -> roles + ; TupleTyCon {} -> const_role Representational + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; PromotedTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) + = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) + = length (fst tvs_rhs) +newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +-- | Find the primitive representation of a 'TyCon' +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep +tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@ +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (TupleTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. In any +-- other case, the function panics +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) + = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) + = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) + = Just c +tyConSingleDataCon_maybe _ + = Nothing + +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +-- Returns (Just con) for single-constructor *algebraic* data types +-- *not* newtypes +tyConSingleAlgDataCon_maybe (TupleTyCon {dataCon = c}) + = Just c +tyConSingleAlgDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons= [c] }}) + = Just c +tyConSingleAlgDataCon_maybe _ + = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True +isClassTyCon _ = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas +tyConClass_maybe _ = Nothing + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (TupleTyCon {tyConTupleSort = sort}) = Just sort +tyConTuple_maybe _ = Nothing + +---------------------------------------------------------------------------- +tyConParent :: TyCon -> TyConParent +tyConParent (AlgTyCon {algTcParent = parent}) = parent +tyConParent (FamilyTyCon {famTcParent = parent}) = parent +tyConParent _ = NoParentTyCon + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon tc = case tyConParent tc of + FamInstTyCon {} -> True + _ -> False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe tc + = case tyConParent tc of + FamInstTyCon ax f ts -> Just (f, ts, ax) + _ -> Nothing + +-- | If this 'TyCon' is that of a family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe tc + = case tyConParent tc of + FamInstTyCon _ f ts -> Just (f, ts) + _ -> Nothing + +-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe tc + = case tyConParent tc of + FamInstTyCon co _ _ -> Just co + _ -> Nothing + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. + +The strictness analyser needs @Ord@. It is a lexicographic order with +the property @(a<=b) || (b<=a)@. +-} + +instance Eq TyCon where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord TyCon where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = getUnique a `compare` getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) + +pprPromotionQuote :: TyCon -> SDoc +pprPromotionQuote (PromotedDataCon {}) = char '\'' -- Quote promoted DataCons + -- in types +pprPromotionQuote (PromotedTyCon {}) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty -- However, we don't quote TyCons + -- in kinds e.g. + -- type family T a :: Bool -> * + -- cf Trac #5952. + -- Except with -dppr-debug + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that we can expand T, even though it's recursive. +And we can expand Id (Id Int), even though the Id shows up +twice at the outer level. + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bale out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +The function that manages this is checkRecTc. +-} + +newtype RecTcChecker = RC NameSet + +initRecTc :: RecTcChecker +initRecTc = RC emptyNameSet + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC rec_nts) tc + | not (isRecursiveTyCon tc) = Just (RC rec_nts) + | tc_name `elemNameSet` rec_nts = Nothing + | otherwise = Just (RC (extendNameSet rec_nts tc_name)) + where + tc_name = tyConName tc diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot new file mode 100644 index 00000000..5d27fa0b --- /dev/null +++ b/compiler/types/TyCon.hs-boot @@ -0,0 +1,12 @@ +module TyCon where + +import Name (Name) +import Unique (Unique) + +data TyCon + +tyConName :: TyCon -> Name +tyConUnique :: TyCon -> Unique +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs new file mode 100644 index 00000000..854776c3 --- /dev/null +++ b/compiler/types/Type.hs @@ -0,0 +1,1749 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Main functions for manipulating types and type-related things +module Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, + + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, + splitFunTys, splitFunTysN, + funResultTy, funArgTy, zipFunTys, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, + + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + mkPiKinds, mkPiType, mkPiTypes, + applyTy, applyTys, applyTysD, applyTysX, dropForAlls, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + + coAxNthLHS, + + -- (Newtypes) + newTyConInstRhs, + + -- Pred types + mkFamilyTyConApp, + isDictLikeTy, + mkEqPred, mkCoerciblePred, mkPrimEqPred, mkReprPrimEqPred, + mkClassPred, + isClassPred, isEqPred, + isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, + + -- Deconstructing predicate types + PredTree(..), EqRel(..), eqRelRole, classifyPredType, + getClassPredTys, getClassPredTys_maybe, + getEqPredTys, getEqPredTys_maybe, getEqPredRole, + predTypeEqRel, + + -- ** Common type constructors + funTyCon, + + -- ** Predicates on types + isTypeVar, isKindVar, allDistinctTyVars, isForAllTy, + isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, + + -- (Lifting and boxity) + isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, + isPrimitiveType, isStrictType, + + -- * Main data types representing Kinds + -- $kind_subtyping + Kind, SimpleKind, MetaKindVar, + + -- ** Finding the kind of a type + typeKind, + + -- ** Common Kinds and SuperKinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, + constraintKind, superKind, + + -- ** Common Kind type constructors + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + constraintKindTyCon, anyKindTyCon, + + -- * Type free variables + tyVarsOfType, tyVarsOfTypes, closeOverKinds, + expandTypeSynonyms, + typeSize, varSetElemsKvsFirst, + + -- * Type comparison + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, + eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, tcView, + + UnaryType, RepType(..), flattenRepType, repType, + tyConsOfType, + + -- * Type representation for the code generator + typePrimRep, typeRepArity, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTvSubst, + + mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTvSubstEnv, getTvInScope, + extendTvInScope, extendTvInScopeList, + extendTvSubst, extendTvSubstList, + isInScope, composeTvSubst, zipTyEnv, + isEmptyTvSubst, unionTvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substTyWith, substTysWith, substTheta, + substTyVar, substTyVars, substTyVarBndr, + cloneTyVarBndr, deShadowTy, lookupTyVar, + substKiWith, substKisWith, + + -- * Pretty-printing + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, + pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, + pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprSourceTyCon, + TyPrec(..), maybeParen, pprSigmaTypeExtraCts, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTyVarOcc, + tidyTopType, + tidyKind, + ) where + +#include "HsVersions.h" + +-- We import the representation and primitive functions from TypeRep. +-- Many things are reexported, but not the representation! + +import Kind +import TypeRep + +-- friends: +import Var +import VarEnv +import VarSet +import NameEnv + +import Class +import TyCon +import TysPrim +import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind ) +import PrelNames ( eqTyConKey, coercibleTyConKey, + ipClassNameKey, openTypeKindTyConKey, + constraintKindTyConKey, liftedTypeKindTyConKey ) +import CoAxiom + +-- others +import Unique ( Unique, hasKey ) +import BasicTypes ( Arity, RepArity ) +import Util +import ListSetOps ( getNth ) +import Outputable +import FastString + +import Maybes ( orElse ) +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) + +infixr 3 `mkFunTy` -- Associates to the right + +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of it's abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ +-} + +{-# INLINE coreView #-} +coreView :: Type -> Maybe Type +-- ^ In Core, we \"look through\" non-recursive newtypes and 'PredTypes': this +-- function tries to obtain a different view of the supplied type given this +-- +-- Strips off the /top layer only/ of a type to give +-- its underlying representation type. +-- Returns Nothing if there is nothing to look through. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! +coreView _ = Nothing + +----------------------------------------------- +{-# INLINE tcView #-} +tcView :: Type -> Maybe Type +-- ^ Similar to 'coreView', but for the type checker, which just looks through synonyms +tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') +tcView _ = Nothing + -- You might think that tcView belows in TcType rather than Type, but unfortunately + -- it is needed by Unify, which is turn imported by Coercion (for MatchEnv and matchList). + -- So we will leave it here to avoid module loops. + +----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +expandTypeSynonyms ty + = go ty + where + go (TyConApp tc tys) + | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | otherwise + = TyConApp tc (map go tys) + go (LitTy l) = LitTy l + go (TyVarTy tv) = TyVarTy tv + go (AppTy t1 t2) = mkAppTy (go t1) (go t2) + go (FunTy t1 t2) = FunTy (go t1) (go t2) + go (ForAllTy tv t) = ForAllTy tv (go t) + +{- +************************************************************************ +* * +\subsection{Constructor-specific functions} +* * +************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ +-} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe _ = Nothing + +allDistinctTyVars :: [KindOrType] -> Bool +allDistinctTyVars tkvs = go emptyVarSet tkvs + where + go _ [] = True + go so_far (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` so_far -> False + | otherwise -> go (so_far `extendVarSet` tv) tys + +{- +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In constrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (Trac #9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +This really only applies to the type checker; in Core, '=>' and '->' +are the same, as are 'Constraint' and '*'. But for now I've put +the test in repSplitAppTy_maybe, which applies throughout, because +the other calls to splitAppTy are in Unify, which is also used by +the type checker (e.g. when matching type-function equations). +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe ty | Just ty' <- coreView ty + = splitAppTy_maybe ty' +splitAppTy_maybe ty = repSplitAppTy_maybe ty + +------------- +repSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done +repSplitAppTy_maybe (FunTy ty1 ty2) + | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] + | otherwise = Just (TyConApp funTyCon [ty1], ty2) +repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +repSplitAppTy_maybe (TyConApp tc tys) + | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +repSplitAppTy_maybe _other = Nothing +------------- +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | isDecomposableTyCon tc = 0 + | otherwise = tyConArity tc + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp funTyCon [], [ty1,ty2]) + split orig_ty _ args = (orig_ty, args) + +{- + LitTy + ~~~~~ +-} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- tcView ty = isNumLitTy ty1 +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- tcView ty = isStrLitTy ty1 +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +{- +--------------------------------------------------------------------- + FunTy + ~~~~~ +-} + +mkFunTy :: Type -> Type -> Type +-- ^ Creates a function type from the given argument and result type +mkFunTy arg res = FunTy arg res + +mkFunTys :: [Type] -> Type -> Type +mkFunTys tys ty = foldr mkFunTy ty tys + +isFunTy :: Type -> Bool +isFunTy ty = isJust (splitFunTy_maybe ty) + +splitFunTy :: Type -> (Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) + +splitFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempts to extract the argument and result types from a type +splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe _ = Nothing + +splitFunTys :: Type -> ([Type], Type) +splitFunTys ty = split [] ty ty + where + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args _ (FunTy arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) + +splitFunTysN :: Int -> Type -> ([Type], Type) +-- ^ Split off exactly the given number argument types, and panics if that is not possible +splitFunTysN 0 ty = ([], ty) +splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty ) + case splitFunTy ty of { (arg, res) -> + case splitFunTysN (n-1) res of { (args, res) -> + (arg:args, res) }} + +-- | Splits off argument types from the given type and associating +-- them with the things in the input list from left to right. The +-- final result type is returned, along with the resulting pairs of +-- objects and types, albeit with the list of pairs in reverse order. +-- Panics if there are not enough argument types for the input list. +zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type) +zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty + where + split acc [] nty _ = (reverse acc, nty) + split acc xs nty ty + | Just ty' <- coreView ty = split acc xs nty ty' + split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res + split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) + +funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty | Just ty' <- coreView ty = funResultTy ty' +funResultTy (FunTy _arg res) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty | Just ty' <- coreView ty = funArgTy ty' +funArgTy (FunTy arg _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) + +{- +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | The same as @fst . splitTyConApp@ +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (FunTy {}) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing + +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (FunTy arg res) = Just [arg,res] +tyConAppArgs_maybe _ = Nothing + + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +tyConAppArgN :: Int -> Type -> Type +-- Executing Nth +tyConAppArgN n ty + = case tyConAppArgs_maybe ty of + Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n + Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' +splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitTyConApp_maybe _ = Nothing + +-- | What is the role assigned to the next parameter of this type? Usually, +-- this will be 'Nominal', but if the type is a 'TyConApp', we may be able to +-- do better. The type does *not* have to be well-kinded when applied for this +-- to work! +nextRole :: Type -> Role +nextRole ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , let num_tys = length tys + , num_tys < tyConArity tc + = tyConRoles tc `getNth` num_tys + + | otherwise + = Nominal + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + +{- +--------------------------------------------------------------------- + SynTy + ~~~~~ + +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + + + Representation types + ~~~~~~~~~~~~~~~~~~~~ + +Note [Nullary unboxed tuple] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We represent the nullary unboxed tuple as the unary (but void) type +Void#. The reason for this is that the ReprArity is never +less than the Arity (as it would otherwise be for a function type like +(# #) -> Int). + +As a result, ReprArity is always strictly positive if Arity is. This +is important because it allows us to distinguish at runtime between a +thunk and a function takes a nullary unboxed tuple as an argument! +-} + +type UnaryType = Type + +data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple]) + | UnaryRep UnaryType + +flattenRepType :: RepType -> [UnaryType] +flattenRepType (UbxTupleRep tys) = tys +flattenRepType (UnaryRep ty) = [ty] + +-- | Looks through: +-- +-- 1. For-alls +-- 2. Synonyms +-- 3. Predicates +-- 4. All newtypes, including recursive ones, but not newtype families +-- +-- It's useful in the back end of the compiler. +repType :: Type -> RepType +repType ty + = go initRecTc ty + where + go :: RecTcChecker -> Type -> RepType + go rec_nts ty -- Expand predicates and synonyms + | Just ty' <- coreView ty + = go rec_nts ty' + + go rec_nts (ForAllTy _ ty) -- Drop foralls + = go rec_nts ty + + go rec_nts (TyConApp tc tys) -- Expand newtypes + | isNewTyCon tc + , tys `lengthAtLeast` tyConArity tc + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon + = go rec_nts' (newTyConInstRhs tc tys) + + | isUnboxedTupleTyCon tc + = if null tys + then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple] + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys) + + go _ ty = UnaryRep ty + + +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> NameEnv TyCon +tyConsOfType ty + = go ty + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go ty | Just ty' <- tcView ty = go ty' + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (ForAllTy _ ty) = go ty + + go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + +-- ToDo: this could be moved to the code generator, using splitTyConApp instead +-- of inspecting the type directly. + +-- | Discovers the primitive representation of a more abstract 'UnaryType' +typePrimRep :: UnaryType -> PrimRep +typePrimRep ty + = case repType ty of + UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) + UnaryRep rep -> case rep of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- See Note [AppTy rep] + TyVarTy _ -> PtrRep + _ -> pprPanic "typePrimRep: UnaryRep" (ppr ty) + +typeRepArity :: Arity -> Type -> RepArity +typeRepArity 0 _ = 0 +typeRepArity n ty = case repType ty of + UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2 + _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty)) + +isVoidTy :: Type -> Bool +-- True if the type has zero width +isVoidTy ty = case repType ty of + UnaryRep (TyConApp tc _) -> isVoidRep (tyConPrimRep tc) + _ -> False + +{- +Note [AppTy rep] +~~~~~~~~~~~~~~~~ +Types of the form 'f a' must be of kind *, not #, so we are guaranteed +that they are represented by pointers. The reason is that f must have +kind (kk -> kk) and kk cannot be unlifted; see Note [The kind invariant] +in TypeRep. + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ +-} + +mkForAllTy :: TyVar -> Type -> Type +mkForAllTy tyvar ty + = ForAllTy tyvar ty + +-- | Wraps foralls over the type using the provided 'TyVar's from left to right +mkForAllTys :: [TyVar] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +mkPiKinds :: [TyVar] -> Kind -> Kind +-- mkPiKinds [k1, k2, (a:k1 -> *)] k2 +-- returns forall k1 k2. (k1 -> *) -> k2 +mkPiKinds [] res = res +mkPiKinds (tv:tvs) res + | isKindVar tv = ForAllTy tv (mkPiKinds tvs res) + | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) + +mkPiType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or a forall type, depending +-- on whether it is given a type variable or a term variable. +mkPiTypes :: [Var] -> Type -> Type +-- ^ 'mkPiType' for multiple type or value arguments + +mkPiType v ty + | isId v = mkFunTy (varType v) ty + | otherwise = mkForAllTy v ty + +mkPiTypes vs ty = foldr mkPiType ty vs + +isForAllTy :: Type -> Bool +isForAllTy (ForAllTy _ _) = True +isForAllTy _ = False + +-- | Attempts to take a forall type apart, returning the bound type variable +-- and the remainder of the type +splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe ty = splitFAT_m ty + where + splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty' + splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m _ = Nothing + +-- | Attempts to take a forall type apart, returning all the immediate such bound +-- type variables and the remainder of the type. Always suceeds, even if that means +-- returning an empty list of 'TyVar's +splitForAllTys :: Type -> ([TyVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Equivalent to @snd . splitForAllTys@ +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) + +{- +-- (mkPiType now in CoreUtils) + +applyTy, applyTys +~~~~~~~~~~~~~~~~~ +-} + +-- | Instantiate a forall type with one or more type arguments. +-- Used when we have a polymorphic function applied to type args: +-- +-- > f t1 t2 +-- +-- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression. +-- Panics if no application is possible. +applyTy :: Type -> KindOrType -> Type +applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty +applyTy _ _ = panic "applyTy" + +applyTys :: Type -> [KindOrType] -> Type +-- ^ This function is interesting because: +-- +-- 1. The function may have more for-alls than there are args +-- +-- 2. Less obviously, it may have fewer for-alls +-- +-- For case 2. think of: +-- +-- > applyTys (forall a.a) [forall b.b, Int] +-- +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +applyTys ty args = applyTysD empty ty args + +applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version +applyTysD _ orig_fun_ty [] = orig_fun_ty +applyTysD doc orig_fun_ty arg_tys + | n_tvs == n_args -- The vastly common case + = substTyWith tvs arg_tys rho_ty + | n_tvs > n_args -- Too many for-alls + = substTyWith (take n_args tvs) arg_tys + (mkForAllTys (drop n_args tvs) rho_ty) + | otherwise -- Too many type args + = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty $$ ppr arg_tys ) -- Zero case gives infinite loop! + applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) + (drop n_tvs arg_tys) + where + (tvs, rho_ty) = splitForAllTys orig_fun_ty + n_tvs = length tvs + n_args = length arg_tys + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys +applyTysX tvs body_ty arg_tys + = ASSERT2( length arg_tys >= n_tvs, ppr tvs $$ ppr body_ty $$ ppr arg_tys ) + mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) + (drop n_tvs arg_tys) + where + n_tvs = length tvs + +{- +************************************************************************ +* * + Pred +* * +************************************************************************ + +Predicates on PredType +-} + +isPredTy :: Type -> Bool + -- NB: isPredTy is used when printing types, which can happen in debug printing + -- during type checking of not-fully-zonked types. So it's not cool to say + -- isConstraintKind (typeKind ty) because absent zonking the type might + -- be ill-kinded, and typeKind crashes + -- Hence the rather tiresome story here +isPredTy ty = go ty [] + where + go :: Type -> [KindOrType] -> Bool + go (AppTy ty1 ty2) args = go ty1 (ty2 : args) + go (TyConApp tc tys) args = go_k (tyConKind tc) (tys ++ args) + go (TyVarTy tv) args = go_k (tyVarKind tv) args + go _ _ = False + + go_k :: Kind -> [KindOrType] -> Bool + -- True <=> kind is k1 -> .. -> kn -> Constraint + go_k k [] = isConstraintKind k + go_k (FunTy _ k1) (_ :args) = go_k k1 args + go_k (ForAllTy kv k1) (k2:args) = go_k (substKiWith [kv] [k2] k1) args + go_k _ _ = False -- Typeable * Int :: Constraint + +isClassPred, isEqPred, isIPPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tyCon | isClassTyCon tyCon -> True + _ -> False +isEqPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> tyCon `hasKey` eqTyConKey + _ -> False + +isIPPred ty = case tyConAppTyCon_maybe ty of + Just tc -> isIPTyCon tc + _ -> False + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassNameKey + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassNameKey + -- Class and it corresponding TyCon have the same Unique + +isIPPred_maybe :: Type -> Maybe (FastString, Type) +isIPPred_maybe ty = + do (tc,[t1,t2]) <- splitTyConApp_maybe ty + guard (isIPTyCon tc) + x <- isStrLitTy t1 + return (x,t2) + +{- +Make PredTypes + +--------------------- Equality types --------------------------------- +-} + +-- | Creates a type equality predicate +mkEqPred :: Type -> Type -> PredType +mkEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) + TyConApp eqTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +mkCoerciblePred :: Type -> Type -> PredType +mkCoerciblePred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) + TyConApp coercibleTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + TyConApp eqPrimTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + TyConApp eqReprPrimTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +-- --------------------- Dictionary types --------------------------------- + +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = TyConApp (classTyCon clas) tys + +isDictTy :: Type -> Bool +isDictTy = isClassPred + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- coreView ty = isDictLikeTy ty' +isDictLikeTy ty = case splitTyConApp_maybe ty of + Just (tc, tys) | isClassTyCon tc -> True + | isTupleTyCon tc -> all isDictLikeTy tys + _other -> False + +{- +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + + +Decomposing PredType +-} + +-- | A choice of equality relation. This is separate from the type 'Role' +-- because 'Phantom' does not define a (non-trivial) equality relation. +data EqRel = NomEq | ReprEq + deriving (Eq, Ord) + +instance Outputable EqRel where + ppr NomEq = text "nominal equality" + ppr ReprEq = text "representational equality" + +eqRelRole :: EqRel -> Role +eqRelRole NomEq = Nominal +eqRelRole ReprEq = Representational + +data PredTree = ClassPred Class [Type] + | EqPred EqRel Type Type + | TuplePred [PredType] + | IrredPred PredType + +classifyPredType :: PredType -> PredTree +classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of + Just (tc, tys) | tc `hasKey` coercibleTyConKey + , let [_, ty1, ty2] = tys + -> EqPred ReprEq ty1 ty2 + Just (tc, tys) | tc `hasKey` eqTyConKey + , let [_, ty1, ty2] = tys + -> EqPred NomEq ty1 ty2 + -- NB: Coercible is also a class, so this check must come *after* + -- the Coercible check + Just (tc, tys) | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + Just (tc, tys) | isTupleTyCon tc + -> TuplePred tys + _ -> IrredPred ev_ty + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, (_ : ty1 : ty2 : tys)) -> + ASSERT( null tys && (tc `hasKey` eqTyConKey + || tc `hasKey` coercibleTyConKey) ) + (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, ty1, ty2]) + | tc `hasKey` eqTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` coercibleTyConKey -> Just (Representational, ty1, ty2) + _ -> Nothing + +getEqPredRole :: PredType -> Role +getEqPredRole ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, _]) + | tc `hasKey` eqTyConKey -> Nominal + | tc `hasKey` coercibleTyConKey -> Representational + _ -> pprPanic "getEqPredRole" (ppr ty) + +-- | Get the equality relation relevant for a pred type. +predTypeEqRel :: PredType -> EqRel +predTypeEqRel ty + | Just (tc, _) <- splitTyConApp_maybe ty + , tc `hasKey` coercibleTyConKey + = ReprEq + | otherwise + = NomEq + +{- +%************************************************************************ +%* * + Size +* * +************************************************************************ +-} + +typeSize :: Type -> Int +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy _ t) = 1 + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys ) + zipTopTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | See "Type#type_classification" for what an unlifted type is +isUnLiftedType :: Type -> Bool + -- isUnLiftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them + +isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' +isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType _ = False + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of + Just tc -> isUnboxedTupleTyCon tc + _ -> False + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors. Closed type constructors are those +-- with a fixed right hand side, as opposed to e.g. associated types +isClosedAlgType :: Type -> Bool +isClosedAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc) + -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True + _other -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnLiftedType'. + +isStrictType :: Type -> Bool +isStrictType = isUnLiftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy tv ty) = seqType (tyVarKind tv) `seq` seqType ty + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ +-} + +eqKind :: Kind -> Kind -> Bool +-- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] +eqKind = eqType + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +-- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] +eqType t1 t2 = isEqual $ cmpType t1 t2 + +instance Eq Type where + (==) = eqType + +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 + +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 + +eqPred :: PredType -> PredType -> Bool +eqPred = eqType + +eqPredX :: RnEnv2 -> PredType -> PredType -> Bool +eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2 + +eqTyVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2 +-- Check that the tyvar lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqTyVarBndrs env [] [] + = Just env +eqTyVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) + = eqTyVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqTyVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +cmpType :: Type -> Type -> Ordering +-- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] +cmpType t1 t2 = cmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) + +cmpTypes :: [Type] -> [Type] -> Ordering +cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2)) + +cmpPred :: PredType -> PredType -> Ordering +cmpPred p1 p2 = cmpTypeX rn_env p1 p2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType p1 `unionVarSet` tyVarsOfType p2)) + +cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse +cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 + | Just t2' <- coreView t2 = cmpTypeX env t1 t2' +-- We expand predicate types, because in Core-land we have +-- lots of definitions like +-- fOrdBool :: Ord Bool +-- fOrdBool = D:Ord .. .. .. +-- So the RHS has a data type + +cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 +cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) + `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 +cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 +cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 +cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `cmpTc` tc2) `thenCmp` cmpTypesX env tys1 tys2 +cmpTypeX _ (LitTy l1) (LitTy l2) = compare l1 l2 + + -- Deal with the rest: TyVarTy < AppTy < FunTy < LitTy < TyConApp < ForAllTy < PredTy +cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT + +cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT +cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT + +cmpTypeX _ (LitTy _) (TyVarTy _) = GT +cmpTypeX _ (LitTy _) (AppTy _ _) = GT +cmpTypeX _ (LitTy _) (FunTy _ _) = GT + +cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT +cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (LitTy _) = GT + +cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT +cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (LitTy _) = GT +cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTypeX _ _ _ = LT + +------------- +cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +cmpTypesX _ [] [] = EQ +cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2 +cmpTypesX _ [] _ = LT +cmpTypesX _ _ [] = GT + +------------- +cmpTc :: TyCon -> TyCon -> Ordering +-- Here we treat * and Constraint as equal +-- See Note [Kind Constraint and kind *] in Kinds.lhs +-- +-- Also we treat OpenTypeKind as equal to either * or # +-- See Note [Comparison with OpenTypeKind] +cmpTc tc1 tc2 + | u1 == openTypeKindTyConKey, isSubOpenTypeKindKey u2 = EQ + | u2 == openTypeKindTyConKey, isSubOpenTypeKindKey u1 = EQ + | otherwise = nu1 `compare` nu2 + where + u1 = tyConUnique tc1 + nu1 = if u1==constraintKindTyConKey then liftedTypeKindTyConKey else u1 + u2 = tyConUnique tc2 + nu2 = if u2==constraintKindTyConKey then liftedTypeKindTyConKey else u2 + +{- +Note [Comparison with OpenTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In PrimOpWrappers we have things like + PrimOpWrappers.mkWeak# = /\ a b c. Prim.mkWeak# a b c +where + Prim.mkWeak# :: forall (a:Open) b c. a -> b -> c + -> State# RealWorld -> (# State# RealWorld, Weak# b #) +Now, eta reduction will turn the definition into + PrimOpWrappers.mkWeak# = Prim.mkWeak# +which is kind-of OK, but now the types aren't really equal. So HACK HACK +we pretend (in Core) that Open is equal to * or #. I hate this. + +Note [cmpTypeX] +~~~~~~~~~~~~~~~ + +When we compare foralls, we should look at the kinds. But if we do so, +we get a corelint error like the following (in +libraries/ghc-prim/GHC/PrimopWrappers.hs): + + Binder's type: forall (o_abY :: *). + o_abY + -> GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.State# GHC.Prim.RealWorld + Rhs type: forall (a_12 :: ?). + a_12 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.State# GHC.Prim.RealWorld + +This is why we don't look at the kind. Maybe we should look if the +kinds are compatible. + +-- cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) +-- = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp` +-- cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 + +************************************************************************ +* * + Type substitutions +* * +************************************************************************ +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTvSubst in_scope env1 env2 + = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TvSubst in_scope env1 + +emptyTvSubst :: TvSubst +emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv + +isEmptyTvSubst :: TvSubst -> Bool + -- See Note [Extending the TvSubstEnv] in TypeRep +isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst +mkTvSubst = TvSubst + +getTvSubstEnv :: TvSubst -> TvSubstEnv +getTvSubstEnv (TvSubst _ env) = env + +getTvInScope :: TvSubst -> InScopeSet +getTvInScope (TvSubst in_scope _) = in_scope + +isInScope :: Var -> TvSubst -> Bool +isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope + +notElemTvSubst :: CoVar -> TvSubst -> Bool +notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) + +setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst +setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv + +zapTvSubstEnv :: TvSubst -> TvSubst +zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv + +extendTvInScope :: TvSubst -> Var -> TvSubst +extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv + +extendTvInScopeList :: TvSubst -> [Var] -> TvSubst +extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv + +extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst +extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) + +extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst +extendTvSubstList (TvSubst in_scope tenv) tvs tys + = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) + +unionTvSubst :: TvSubst -> TvSubst -> TvSubst +-- Works when the ranges are disjoint +unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) + TvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + +-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- Note [Generating the in-scope set for a substitution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we want to substitute [a -> ty1, b -> ty2] I used to +-- think it was enough to generate an in-scope set that includes +-- fv(ty1,ty2). But that's not enough; we really should also take the +-- free vars of the type we are substituting into! Example: +-- (forall b. (a,b,x)) [a -> List b] +-- Then if we use the in-scope set {b}, there is a danger we will rename +-- the forall'd variable to 'x' by mistake, getting this: +-- (forall x. (List b, x, x) +-- Urk! This means looking at all the calls to mkOpenTvSubst.... + + +-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming +-- environment, hence "open" +mkOpenTvSubst :: TvSubstEnv -> TvSubst +mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv + +-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming +-- environment, hence "open" +zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst +zipOpenTvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + | otherwise + = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) + +-- | Called when doing top-level substitutions. Here we expect that the +-- free vars of the range of the substitution will be empty. +mkTopTvSubst :: [(TyVar, Type)] -> TvSubst +mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) + +zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst +zipTopTvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + | otherwise + = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) + +zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv + | otherwise + = zip_ty_env tyvars tys emptyVarEnv + +-- Later substitutions in the list over-ride earlier ones, +-- but there should be no loops +zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv +zip_ty_env [] [] env = env +zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" +zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env +-- zip_ty_env _ _ env = env + +instance Outputable TvSubst where + ppr (TvSubst ins tenv) + = brackets $ sep[ ptext (sLit "TvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] + +{- +************************************************************************ +* * + Performing type or kind substitutions +* * +************************************************************************ +-} + +-- | Type substitution making use of an 'TvSubst' that +-- is assumed to be open, see 'zipOpenTvSubst' +substTyWith :: [TyVar] -> [Type] -> Type -> Type +substTyWith tvs tys = ASSERT( length tvs == length tys ) + substTy (zipOpenTvSubst tvs tys) + +substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind +substKiWith = substTyWith + +-- | Type substitution making use of an 'TvSubst' that +-- is assumed to be open, see 'zipOpenTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( length tvs == length tys ) + substTys (zipOpenTvSubst tvs tys) + +substKisWith :: [KindVar] -> [Kind] -> [Kind] -> [Kind] +substKisWith = substTysWith + +-- | Substitute within a 'Type' +substTy :: TvSubst -> Type -> Type +substTy subst ty | isEmptyTvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +substTys :: TvSubst -> [Type] -> [Type] +substTys subst tys | isEmptyTvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +substTheta :: TvSubst -> ThetaType -> ThetaType +substTheta subst theta + | isEmptyTvSubst subst = theta + | otherwise = map (substTy subst) theta + +-- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet' +deShadowTy :: TyVarSet -> Type -> Type +deShadowTy tvs ty + = subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty + where + in_scope = mkInScopeSet tvs + +subst_ty :: TvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (LitTy n) = n `seq` LitTy n + go (TyVarTy tv) = substTyVar subst tv + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (ForAllTy tv ty) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllTy tv' $! (subst_ty subst' ty) + +substTyVar :: TvSubst -> TyVar -> Type +substTyVar (TvSubst _ tenv) tv + | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] + | otherwise = ASSERT( isTyVar tv ) TyVarTy tv -- in TypeRep + -- We do not require that the tyvar is in scope + -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) + -- and it's a nuisance to bring all the free vars of tau into + -- scope --- and then force that thunk at every tyvar + -- Instead we have an ASSERT in substTyVarBndr to check for capture + +substTyVars :: TvSubst -> [TyVar] -> [Type] +substTyVars subst tvs = map (substTyVar subst) tvs + +lookupTyVar :: TvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubst] in TypeRep +lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv + +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope tenv) old_var + = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) + (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TvSubst] in TypeRep + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ updateTyVarKind (substTy subst) old_var + -- The uniqAway part makes sure the new variable is not already in scope + +cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) +cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq + = (TvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')), tv') + where + tv' = setVarUnique tv uniq -- Simply set the unique; the kind + -- has no type variables to worry about + +{- +---------------------------------------------------- +-- Kind Stuff + +Kinds +~~~~~ + +For the description of subkinding in GHC, see + http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeType#Kinds +-} + +type MetaKindVar = TyVar -- invariant: MetaKindVar will always be a + -- TcTyVar with details MetaTv (TauTv ...) ... +-- meta kind var constructors and functions are in TcType + +type SimpleKind = Kind + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ +-} + +typeKind :: Type -> Kind +typeKind orig_ty = go orig_ty + where + + go ty@(TyConApp tc tys) + | isPromotedTyCon tc + = ASSERT( tyConArity tc == length tys ) superKind + | otherwise + = kindAppResult (ptext (sLit "typeKind 1") <+> ppr ty $$ ppr orig_ty) + (tyConKind tc) tys + + go ty@(AppTy fun arg) = kindAppResult (ptext (sLit "typeKind 2") <+> ppr ty $$ ppr orig_ty) + (go fun) [arg] + go (LitTy l) = typeLiteralKind l + go (ForAllTy _ ty) = go ty + go (TyVarTy tyvar) = tyVarKind tyvar + go _ty@(FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypeKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isSuperKind k = k + | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind + where + k = go res + +typeLiteralKind :: TyLit -> Kind +typeLiteralKind l = + case l of + NumTyLit _ -> typeNatKind + StrTyLit _ -> typeSymbolKind + +{- +Kind inference +~~~~~~~~~~~~~~ +During kind inference, a kind variable unifies only with +a "simple kind", sk + sk ::= * | sk1 -> sk2 +For example + data T a = MkT a (T Int#) +fails. We give T the kind (k -> *), and the kind variable k won't unify +with # (the kind of Int#). + +Type inference +~~~~~~~~~~~~~~ +When creating a fresh internal type variable, we give it a kind to express +constraints on it. E.g. in (\x->e) we make up a fresh type variable for x, +with kind ??. + +During unification we only bind an internal type variable to a type +whose kind is lower in the sub-kind hierarchy than the kind of the tyvar. + +When unifying two internal type variables, we collect their kind constraints by +finding the GLB of the two. Since the partial order is a tree, they only +have a glb if one is a sub-kind of the other. In that case, we bind the +less-informative one to the more informative one. Neat, eh? +-} diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot new file mode 100644 index 00000000..587454e3 --- /dev/null +++ b/compiler/types/Type.hs-boot @@ -0,0 +1,9 @@ +module Type where +import {-# SOURCE #-} TypeRep( Type, Kind ) +import Var + +isPredTy :: Type -> Bool + +typeKind :: Type -> Kind +substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind +eqKind :: Kind -> Kind -> Bool diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs new file mode 100644 index 00000000..c546df65 --- /dev/null +++ b/compiler/types/TypeRep.hs @@ -0,0 +1,943 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[TypeRep]{Type - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + TyCon imports Class + TypeRep + TysPrim imports TypeRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# OPTIONS_HADDOCK hide #-} +-- We expose the relevant stuff from this module via the Type module + +module TypeRep ( + TyThing(..), + Type(..), + TyLit(..), + KindOrType, Kind, SuperKind, + PredType, ThetaType, -- Synonyms + + -- Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, + + -- Pretty-printing + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, + pprTyThing, pprTyThingCategory, pprSigmaType, pprSigmaTypeExtraCts, + pprTheta, pprForAll, pprUserForAll, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, suppressKinds, + TyPrec(..), maybeParen, pprTcApp, + pprPrefixApp, pprArrowChain, ppr_type, + + -- Free variables + tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, + tidyOpenTyVar, tidyOpenTyVars, + tidyTyVarOcc, + tidyTopType, + tidyKind, + + -- Substitutions + TvSubst(..), TvSubstEnv + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon( dataConTyCon ) +import ConLike ( ConLike(..) ) +import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop + +-- friends: +import Var +import VarEnv +import VarSet +import Name +import BasicTypes +import TyCon +import Class +import CoAxiom + +-- others +import PrelNames +import Outputable +import FastString +import Util +import DynFlags + +-- libraries +import Data.List( mapAccumL, partition ) +import qualified Data.Data as Data hiding ( TyCon ) + +{- +************************************************************************ +* * +\subsection{The data type} +* * +************************************************************************ +-} + +-- | The key representation of types within the compiler + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Type + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy -- See Note [AppTy invariant] + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' + -- + -- 2) Argument type + + | TyConApp -- See Note [AppTy invariant] + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated appliations of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | FunTy + Type + Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ + -- See Note [Equality-constrained types] + + | ForAllTy + Var -- Type or kind variable + Type -- ^ A polymorphic type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + deriving (Data.Data, Data.Typeable) + + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data, Data.Typeable) + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +-- Invariant: a kind is always in one of these forms: +-- +-- > FunTy k1 k2 +-- > TyConApp PrimTyCon [...] +-- > TyVar kv -- (during inference only) +-- > ForAll ... -- (for top-level coercions) +type Kind = Type + +-- | "Super kinds", used to help encode 'Kind's as types. +-- Invariant: a super kind is always of this form: +-- +-- > TyConApp SuperKindTyCon ... +type SuperKind = Type + +{- +Note [The kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The kinds + # UnliftedTypeKind + OpenKind super-kind of *, # + +can never appear under an arrow or type constructor in a kind; they +can only be at the top level of a kind. It follows that primitive TyCons, +which have a naughty pseudo-kind + State# :: * -> # +must always be saturated, so that we can never get a type whose kind +has a UnliftedTypeKind or ArgTypeKind underneath an arrow. + +Nor can we abstract over a type variable with any of these kinds. + + k :: = kk | # | ArgKind | (#) | OpenKind + kk :: = * | kk -> kk | T kk1 ... kkn + +So a type variable can only be abstracted kk. + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + + +Note [Equality-constrained types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type forall ab. (a ~ [b]) => blah +is encoded like this: + + ForAllTy (a:*) $ ForAllTy (b:*) $ + FunTy (TyConApp (~) [a, [b]]) $ + blah + +------------------------------------- + Note [PredTy] +-} + +-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to have +-- this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + +************************************************************************ +* * + Simple constructors +* * +************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy = TyVarTy + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +-- Some basic functions, put here to break loops eg with the pretty printer + +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey +isLiftedTypeKind _ = False + +-- | Is this a super-kind (i.e. a type-of-kinds)? +isSuperKind :: Type -> Bool +isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey +isSuperKind _ = False + +isTypeVar :: Var -> Bool +isTypeVar v = isTKVar v && not (isSuperKind (varType v)) + +isKindVar :: Var -> Bool +isKindVar v = isTKVar v && isSuperKind (varType v) + +{- +************************************************************************ +* * + Free variables of types and coercions +* * +************************************************************************ +-} + +tyVarsOfType :: Type -> VarSet +-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym +-- tyVarsOfType returns only the free variables of a type +-- For example, tyVarsOfType (a::k) returns {a}, not including the +-- kind variable {k} +tyVarsOfType (TyVarTy v) = unitVarSet v +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (LitTy {}) = emptyVarSet +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + `unionVarSet` tyVarsOfType (tyVarKind tyvar) + +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes = mapUnionVarSet tyVarsOfType + +closeOverKinds :: TyVarSet -> TyVarSet +-- Add the kind variables free in the kinds +-- of the tyvars in the given set +closeOverKinds tvs + = foldVarSet (\tv ktvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` ktvs) + tvs tvs + +varSetElemsKvsFirst :: VarSet -> [TyVar] +-- {k1,a,k2,b} --> [k1,k2,a,b] +varSetElemsKvsFirst set + = kvs ++ tvs + where + (kvs, tvs) = partition isKindVar (varSetElems set) + +{- +************************************************************************ +* * + TyThing +* * +************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A typecheckable-thing, essentially anything that has a name +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + deriving (Eq, Ord) + +instance Outputable TyThing where + ppr = pprTyThing + +pprTyThing :: TyThing -> SDoc +pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory (ATyCon tc) + | isClassTyCon tc = ptext (sLit "Class") + | otherwise = ptext (sLit "Type constructor") +pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") +pprTyThingCategory (AnId _) = ptext (sLit "Identifier") +pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") +pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") + + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = getName cl + +{- +************************************************************************ +* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +* * +************************************************************************ +-} + +-- | Type substitution +-- +-- #tvsubst_invariant# +-- The following invariants must hold of a 'TvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reached a fixed point. +data TvSubst + = TvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TvSubst (with the apply-once + -- invariant discussed in Note [Apply Once]), and also independently + -- in the middle of matching, and unification (see Types.Unify) + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +{- +Note [Apply Once] +~~~~~~~~~~~~~~~~~ +We use TvSubsts to instantiate things, and we might instantiate + forall a b. ty +\with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + *************************************************** + *** So a TvSubst must be applied precisely once *** + *************************************************** + +A TvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the TvSubstEnv is empty: +if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- +then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + + + +************************************************************************ +* * + Pretty-printing types + + Defined very early because of debug printing in assertions +* * +************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the pretty printer +operates the following precedene structre: + Type constructor application binds more tightly than + Oerator applications which bind more tightly than + Function arrow + +So we might see a :+: T b -> c +meaning (a :+: (T b)) -> c + +Maybe operator applications should bind a bit less tightly? + +Anyway, that's the current story, and it is used consistently for Type and HsType +-} + +data TyPrec -- See Note [Prededence in types] + + = TopPrec -- No parens + | FunPrec -- Function args; no parens for tycon apps + | TyOpPrec -- Infix operator + | TyConPrec -- Tycon args; no parens for atomic + deriving( Eq, Ord ) + +maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +------------------ +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_type TopPrec ty +pprParendType ty = ppr_type TyConPrec ty + +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +-- pprTheta [pred] = pprPred pred -- I'm in two minds about this +pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy [] = empty +pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow + -- TyOpPrec: Num a => a -> a does not need parens + -- bug (a :~: b) => a -> b currently does + -- Trac # 9658 +pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) + <+> darrow + -- Notice 'fsep' here rather that 'sep', so that + -- type contexts don't get displayed in a giant column + -- Rather than + -- instance (Eq a, + -- Eq b, + -- Eq c, + -- Eq d, + -- Eq e, + -- Eq f, + -- Eq g, + -- Eq h, + -- Eq i, + -- Eq j, + -- Eq k, + -- Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + -- we get + -- + -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, + -- Eq j, Eq k, Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + +pprThetaArrowTyExtra :: ThetaType -> SDoc +pprThetaArrowTyExtra [] = text "_" <+> darrow +pprThetaArrowTyExtra preds = parens (fsep (punctuate comma xs)) <+> darrow + where xs = (map (ppr_type TopPrec) preds) ++ [text "_"] +------------------ +instance Outputable Type where + ppr ty = pprType ty + +instance Outputable TyLit where + ppr = pprTyLit + +------------------ + -- OK, here's the main printer + +ppr_type :: TyPrec -> Type -> SDoc +ppr_type _ (TyVarTy tv) = ppr_tvar tv +ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys +ppr_type p (LitTy l) = ppr_tylit p l +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty + +ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ + ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 + +ppr_type p fun_ty@(FunTy ty1 ty2) + | isPredTy ty1 + = ppr_forall_type p fun_ty + | otherwise + = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2) + where + -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + ppr_fun_tail (FunTy ty1 ty2) + | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + + +ppr_forall_type :: TyPrec -> Type -> SDoc +ppr_forall_type p ty + = maybeParen p FunPrec $ ppr_sigma_type True False ty + -- True <=> we always print the foralls on *nested* quantifiers + -- Opt_PrintExplicitForalls only affects top-level quantifiers + -- False <=> we don't print an extra-constraints wildcard + +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + = parenSymOcc (getOccName tv) (ppr tv) + +ppr_tylit :: TyPrec -> TyLit -> SDoc +ppr_tylit _ tl = + case tl of + NumTyLit n -> integer n + StrTyLit s -> text (show s) + +------------------- +ppr_sigma_type :: Bool -> Bool -> Type -> SDoc +-- First Bool <=> Show the foralls unconditionally +-- Second Bool <=> Show an extra-constraints wildcard +ppr_sigma_type show_foralls_unconditionally extra_cts ty + = sep [ if show_foralls_unconditionally + then pprForAll tvs + else pprUserForAll tvs + , if extra_cts + then pprThetaArrowTyExtra ctxt + else pprThetaArrowTy ctxt + , pprType tau ] + where + (tvs, rho) = split1 [] ty + (ctxt, tau) = split2 [] rho + + split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) + + split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 + split2 ps ty = (reverse ps, ty) + +pprSigmaType :: Type -> SDoc +pprSigmaType ty = ppr_sigma_type False False ty + +pprSigmaTypeExtraCts :: Bool -> Type -> SDoc +pprSigmaTypeExtraCts = ppr_sigma_type False + +pprUserForAll :: [TyVar] -> SDoc +-- Print a user-level forall; see Note [WHen to print foralls] +pprUserForAll tvs + = sdocWithDynFlags $ \dflags -> + ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ + pprForAll tvs + where + tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv))) + +pprForAll :: [TyVar] -> SDoc +pprForAll [] = empty +pprForAll tvs = forAllLit <+> pprTvBndrs tvs <> dot + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) + +pprTvBndr :: TyVar -> SDoc +pprTvBndr tv + | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) + where + kind = tyVarKind tv + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see Trac #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See Trac #2766. +-} + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys = pprTyTcApp TopPrec tc tys + -- We have to use ppr on the TyCon (not its name) + -- so that we get promotion quotes in the right place + +pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc +-- Used for types only; so that we can make a +-- special case for type-level lists +pprTyTcApp p tc tys + | tc `hasKey` ipClassNameKey + , [LitTy (StrTyLit n),ty] <- tys + = maybeParen p FunPrec $ + char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + + | tc `hasKey` consDataConKey + , [_kind,ty1,ty2] <- tys + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitKinds dflags then pprTcApp p ppr_type tc tys + else pprTyList p ty1 ty2 + + | otherwise + = pprTcApp p ppr_type tc tys + +pprTcApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +-- Used for both types and coercions, hence polymorphism +pprTcApp _ pp tc [ty] + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + +pprTcApp p pp tc tys + | isTupleTyCon tc && tyConArity tc == length tys + = pprTupleApp p pp tc tys + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , isTupleTyCon dc_tc + , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 + ty_args = drop arity tys -- Drop the kind args + , ty_args `lengthIs` arity -- Result is saturated + = pprPromotionQuote tc <> + (tupleParens (tupleTyConSort dc_tc) $ + sep (punctuate comma (map (pp TopPrec) ty_args))) + + | otherwise + = sdocWithDynFlags (pprTcApp_help p pp tc tys) + +pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +-- Print a saturated tuple +pprTupleApp p pp tc tys + | null tys + , ConstraintTuple <- tupleTyConSort tc + = maybeParen p TopPrec $ + ppr tc <+> dcolon <+> ppr (tyConKind tc) + | otherwise + = pprPromotionQuote tc <> + tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + +pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc +-- This one has accss to the DynFlags +pprTcApp_help p pp tc tys dflags + | not (isSymOcc (nameOccName (tyConName tc))) + = pprPrefixApp p (ppr tc) (map (pp TyConPrec) tys_wo_kinds) + + | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; + -- we know nothing of precedence though + = pprInfixApp p pp (ppr tc) ty1 ty2 + + | tc `hasKey` liftedTypeKindTyConKey + || tc `hasKey` unliftedTypeKindTyConKey + = ASSERT( null tys ) ppr tc -- Do not wrap *, # in parens + + | otherwise + = pprPrefixApp p (parens (ppr tc)) (map (pp TyConPrec) tys_wo_kinds) + where + tys_wo_kinds = suppressKinds dflags (tyConKind tc) tys + +------------------ +suppressKinds :: DynFlags -> Kind -> [a] -> [a] +-- Given the kind of a TyCon, and the args to which it is applied, +-- suppress the args that are kind args +-- C.f. Note [Suppressing kinds] in IfaceType +suppressKinds dflags kind xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress kind xs + where + suppress (ForAllTy _ kind) (_ : xs) = suppress kind xs + suppress (FunTy _ res) (x:xs) = x : suppress res xs + suppress _ xs = xs + +---------------- +pprTyList :: TyPrec -> Type -> Type -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +pprTyList p ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_type TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) -> maybeParen p FunPrec $ + hang (ppr_type FunPrec ty1) + 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: Type -> ([Type], Maybe Type) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (TyConApp tc tys) + | tc `hasKey` consDataConKey + , [_kind, ty1,ty2] <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `hasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +---------------- +pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp p pp pp_tc ty1 ty2 + = maybeParen p TyOpPrec $ + sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] + +pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) + +---------------- +pprArrowChain :: TyPrec -> [SDoc] -> SDoc +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] + +{- +************************************************************************ +* * +\subsection{TidyType} +* * +************************************************************************ + +Tidying is here because it has a special case for FlatSkol +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs + +tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyVarBndr tidy_env@(occ_env, subst) tyvar + = case tidyOccName occ_env occ1 of + (tidy', occ') -> ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarKind (setTyVarName tyvar name') kind' + name' = tidyNameOcc name occ' + kind' = tidyKind tidy_env (tyVarKind tyvar) + where + name = tyVarName tyvar + occ = getOccName name + -- System Names are for unification variables; + -- when we tidy them we give them a trailing "0" (or 1 etc) + -- so that they don't take precedence for the un-modified name + -- Plus, indicating a unification variable in this way is a + -- helpful clue for users + occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0") + | otherwise = occ + + +--------------- +tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyVars (full_occ_env, var_env) (varSetElems tyvars)) + + --------------- +tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars + +--------------- +tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +-- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyTyVarBndr' +tidyOpenTyVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder + +--------------- +tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar +tidyTyVarOcc (_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) + where + (envp, tvp) = tidyTyVarBndr env tv + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType (trimmed_occ_env, var_env) ty) + where + (env'@(_, var_env), tvs') = tidyOpenTyVars env (varSetElems (tyVarsOfType ty)) + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type. + +--------------- +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TypeRep.hs-boot new file mode 100644 index 00000000..94832b1a --- /dev/null +++ b/compiler/types/TypeRep.hs-boot @@ -0,0 +1,12 @@ +module TypeRep where + +import Outputable (Outputable) + +data Type +data TyThing + +type PredType = Type +type Kind = Type +type SuperKind = Type + +instance Outputable Type diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs new file mode 100644 index 00000000..02d3792c --- /dev/null +++ b/compiler/types/Unify.hs @@ -0,0 +1,744 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module Unify ( + -- Matching of types: + -- the "tc" prefix indicates that matching always + -- respects newtypes (rather than looking through them) + tcMatchTy, tcMatchTys, tcMatchTyX, + ruleMatchTyX, tcMatchPreds, + + MatchEnv(..), matchList, + + typesCantMatch, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTys, BindFlag(..), + + UnifyResultM(..), UnifyResult, tcUnifyTysFG + + ) where + +#include "HsVersions.h" + +import Var +import VarEnv +import VarSet +import Kind +import Type +import TyCon +import TypeRep +import Util + +import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ + + +Matching is much tricker than you might think. + +1. The substitution we generate binds the *template type variables* + which are given to us explicitly. + +2. We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + + That is what the RnEnv2 is for; it does the alpha-renaming + that makes it as if a and b were the same variable. + Initialising the RnEnv2, so that it can generate a fresh + binder when necessary, entails knowing the free variables of + both types. + +3. We must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where x is the template type variable. Then we do not want to + bind x to a/b! This is a kind of occurs check. + The necessary locals accumulate in the RnEnv2. +-} + +data MatchEnv + = ME { me_tmpls :: VarSet -- Template variables + , me_env :: RnEnv2 -- Renaming envt for nested foralls + } -- In-scope set includes template variables + -- Nota Bene: MatchEnv isn't specific to Types. It is used + -- for matching terms and coercions as well as types + +tcMatchTy :: TyVarSet -- Template tyvars + -> Type -- Template + -> Type -- Target + -> Maybe TvSubst -- One-shot; in principle the template + -- variables could be free in the target + +tcMatchTy tmpls ty1 ty2 + = case match menv emptyTvSubstEnv ty1 ty2 of + Just subst_env -> Just (TvSubst in_scope subst_env) + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2) + -- We're assuming that all the interesting + -- tyvars in ty1 are in tmpls + +tcMatchTys :: TyVarSet -- Template tyvars + -> [Type] -- Template + -> [Type] -- Target + -> Maybe TvSubst -- One-shot; in principle the template + -- variables could be free in the target + +tcMatchTys tmpls tys1 tys2 + = case match_tys menv emptyTvSubstEnv tys1 tys2 of + Just subst_env -> Just (TvSubst in_scope subst_env) + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfTypes tys2) + -- We're assuming that all the interesting + -- tyvars in tys1 are in tmpls + +-- This is similar, but extends a substitution +tcMatchTyX :: TyVarSet -- Template tyvars + -> TvSubst -- Substitution to extend + -> Type -- Template + -> Type -- Target + -> Maybe TvSubst +tcMatchTyX tmpls (TvSubst in_scope subst_env) ty1 ty2 + = case match menv subst_env ty1 ty2 of + Just subst_env -> Just (TvSubst in_scope subst_env) + Nothing -> Nothing + where + menv = ME {me_tmpls = tmpls, me_env = mkRnEnv2 in_scope} + +tcMatchPreds + :: [TyVar] -- Bind these + -> [PredType] -> [PredType] + -> Maybe TvSubstEnv +tcMatchPreds tmpls ps1 ps2 + = matchList (match menv) emptyTvSubstEnv ps1 ps2 + where + menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars } + in_scope_tyvars = mkInScopeSet (tyVarsOfTypes ps1 `unionVarSet` tyVarsOfTypes ps2) + +-- This one is called from the expression matcher, which already has a MatchEnv in hand +ruleMatchTyX :: MatchEnv + -> TvSubstEnv -- Substitution to extend + -> Type -- Template + -> Type -- Target + -> Maybe TvSubstEnv + +ruleMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2 -- Rename for export + +-- Now the internals of matching + +-- | Workhorse matching function. Our goal is to find a substitution +-- on all of the template variables (specified by @me_tmpls menv@) such +-- that @ty1@ and @ty2@ unify. This substitution is accumulated in @subst@. +-- If a variable is not a template variable, we don't attempt to find a +-- substitution for it; it must match exactly on both sides. Furthermore, +-- only @ty1@ can have template variables. +-- +-- This function handles binders, see 'RnEnv2' for more details on +-- how that works. +match :: MatchEnv -- For the most part this is pushed downwards + -> TvSubstEnv -- Substitution so far: + -- Domain is subset of template tyvars + -- Free vars of range is subset of + -- in-scope set of the RnEnv2 + -> Type -> Type -- Template and target respectively + -> Maybe TvSubstEnv + +match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 + | Just ty2' <- coreView ty2 = match menv subst ty1 ty2' + +match menv subst (TyVarTy tv1) ty2 + | Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound + = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2 + -- ty1 has no locally-bound variables, hence nukeRnEnvL + then Just subst + else Nothing -- ty2 doesn't match + + | tv1' `elemVarSet` me_tmpls menv + = if any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2)) + then Nothing -- Occurs check + -- ezyang: Is this really an occurs check? It seems + -- to just reject matching \x. A against \x. x (maintaining + -- the invariant that the free vars of the range of @subst@ + -- are a subset of the in-scope set in @me_env menv@.) + else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) + -- Note [Matching kinds] + ; return (extendVarEnv subst1 tv1' ty2) } + + | otherwise -- tv1 is not a template tyvar + = case ty2 of + TyVarTy tv2 | tv1' == rnOccR rn_env tv2 -> Just subst + _ -> Nothing + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + +match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) + = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2) + ; match menv' subst' ty1 ty2 } + where -- Use the magic of rnBndr2 to go under the binders + menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } + +match menv subst (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 = match_tys menv subst tys1 tys2 +match menv subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) + = do { subst' <- match menv subst ty1a ty2a + ; match menv subst' ty1b ty2b } +match menv subst (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + -- 'repSplit' used because the tcView stuff is done above + = do { subst' <- match menv subst ty1a ty2a + ; match menv subst' ty1b ty2b } + +match _ subst (LitTy x) (LitTy y) | x == y = return subst + +match _ _ _ _ + = Nothing + + + +-------------- +match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv +-- Match the kind of the template tyvar with the kind of Type +-- Note [Matching kinds] +match_kind menv subst k1 k2 + | k2 `isSubKind` k1 + = return subst + + | otherwise + = match menv subst k1 k2 + +-- Note [Matching kinds] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- For ordinary type variables, we don't want (m a) to match (n b) +-- if say (a::*) and (b::*->*). This is just a yes/no issue. +-- +-- For coercion kinds matters are more complicated. If we have a +-- coercion template variable co::a~[b], where a,b are presumably also +-- template type variables, then we must match co's kind against the +-- kind of the actual argument, so as to give bindings to a,b. +-- +-- In fact I have no example in mind that *requires* this kind-matching +-- to instantiate template type variables, but it seems like the right +-- thing to do. C.f. Note [Matching variable types] in Rules.lhs + +-------------- +match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv +match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2 + +-------------- +matchList :: (env -> a -> b -> Maybe env) + -> env -> [a] -> [b] -> Maybe env +matchList _ subst [] [] = Just subst +matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b + ; matchList fn subst' as bs } +matchList _ _ _ _ = Nothing + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +Suppose x::T X. Then *in Haskell* it's impossible to construct a (non-bottom) +value of type (T X) using T1. But *in FC* it's quite possible. The newtype +gives a coercion + CoX :: X ~ Int +So (T CoX) :: T X ~ T Int; hence (T1 `cast` sym (T CoX)) is a non-bottom value +of type (T X) constructed with T1. Hence + ANSWER = NO we can't prune the T1 branch (surprisingly) + +Furthermore, this can even happen; see Trac #1251. GHC's newtype-deriving +mechanism uses a cast, just as above, to move from one dictionary to another, +in effect giving the programmer access to CoX. + +Finally, suppose x::T Y. Then *even in FC* we can't construct a +non-bottom value of type (T Y) using T1. That's because we can get +from Y to Char, but not to Int. + + +Here's a related question. data Eq a b where EQ :: Eq a a +Consider + case x of { EQ -> ... } + +Suppose x::Eq Int Char. Is the alternative dead? Clearly yes. + +What about x::Eq Int a, in a context where we have evidence that a~Char. +Then again the alternative is dead. + + + Summary + +We are really doing a test for unsatisfiability of the type +constraints implied by the match. And that is clearly, in general, a +hard thing to do. + +However, since we are simply dropping dead code, a conservative test +suffices. There is a continuum of tests, ranging from easy to hard, that +drop more and more dead code. + +For now we implement a very simple test: type variables match +anything, type functions (incl newtypes) match anything, and only +distinct data types fail to match. We can elaborate later. +-} + +typesCantMatch :: [(Type,Type)] -> Bool +typesCantMatch prs = any (\(s,t) -> cant_match s t) prs + where + cant_match :: Type -> Type -> Bool + cant_match t1 t2 + | Just t1' <- coreView t1 = cant_match t1' t2 + | Just t2' <- coreView t2 = cant_match t1 t2' + + cant_match (FunTy a1 r1) (FunTy a2 r2) + = cant_match a1 a2 || cant_match r1 r2 + + cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | isDistinctTyCon tc1 && isDistinctTyCon tc2 + = tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2) + + cant_match (FunTy {}) (TyConApp tc _) = isDistinctTyCon tc + cant_match (TyConApp tc _) (FunTy {}) = isDistinctTyCon tc + -- tc can't be FunTyCon by invariant + + cant_match (AppTy f1 a1) ty2 + | Just (f2, a2) <- repSplitAppTy_maybe ty2 + = cant_match f1 f2 || cant_match a1 a2 + cant_match ty1 (AppTy f2 a2) + | Just (f1, a1) <- repSplitAppTy_maybe ty1 + = cant_match f1 f2 || cant_match a1 a2 + + cant_match (LitTy x) (LitTy y) = x /= y + + cant_match _ _ = False -- Safe! + +-- Things we could add; +-- foralls +-- look through newtypes +-- take account of tyvar bindings (EQ example above) + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: + +type instance F x x = Int +type instance F [y] y = Bool + +If we also have + +type instance Looper = [Looper] + +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). + +See also Trac #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. + +Note [Unifying with skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we discover that two types unify if and only if a skolem variable is +substituted, we can't properly unify the types. But, that skolem variable +may later be instantiated with a unifyable type. So, we return maybeApart +in these cases. + +Note [Lists of different lengths are MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is unusual to call tcUnifyTys or tcUnifyTysFG with lists of different +lengths. The place where we know this can happen is from compatibleBranches in +FamInstEnv, when checking data family instances. Data family instances may be +eta-reduced; see Note [Eta reduction for data family axioms] in TcInstDcls. + +We wish to say that + + D :: * -> * -> * + axDF1 :: D Int ~ DFInst1 + axDF2 :: D Int Bool ~ DFInst2 + +overlap. If we conclude that lists of different lengths are SurelyApart, then +it will look like these do *not* overlap, causing disaster. See Trac #9371. + +In usages of tcUnifyTys outside of family instances, we always use tcUnifyTys, +which can't tell the difference between MaybeApart and SurelyApart, so those +usages won't notice this design choice. +-} + +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe TvSubst -- A regular one-shot (idempotent) substitution +-- Simple unification of two types; all type variables are bindable +tcUnifyTy ty1 ty2 + = case initUM (const BindMe) (unify emptyTvSubstEnv ty1 ty2) of + Unifiable subst_env -> Just (niFixTvSubst subst_env) + _other -> Nothing + +----------------- +tcUnifyTys :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TvSubst -- A regular one-shot (idempotent) substitution +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG bind_fn tys1 tys2 of + Unifiable subst -> Just subst + _ -> Nothing + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Fine-grained unification] +type UnifyResult = UnifyResultM TvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of an most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + +-- See Note [Fine-grained unification] +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 + = initUM bind_fn $ + do { subst <- unifyList emptyTvSubstEnv tys1 tys2 + + -- Find the fixed point of the resulting non-idempotent substitution + ; return (niFixTvSubst subst) } + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is harder than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitition to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in Trac #9106. + +This is the reason for extending env with [f:k -> f:*], in the +definition of env' in niFixTvSubst +-} + +niFixTvSubst :: TvSubstEnv -> TvSubst +-- Find the idempotent fixed point of the non-idempotent substitution +-- See Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixTvSubst env = f env + where + f env | not_fixpoint = f (mapVarEnv (substTy subst') env) + | otherwise = subst + where + not_fixpoint = foldVarSet ((||) . in_domain) False all_range_tvs + in_domain tv = tv `elemVarEnv` env + + range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet env + all_range_tvs = closeOverKinds range_tvs + subst = mkTvSubst (mkInScopeSet all_range_tvs) env + + -- env' extends env by replacing any free type with + -- that same tyvar with a substituted kind + -- See note [Finding the substitution fixpoint] + env' = extendVarEnvList env [ (rtv, mkTyVarTy $ setTyVarKind rtv $ + substTy subst $ tyVarKind rtv) + | rtv <- varSetElems range_tvs + , not (in_domain rtv) ] + subst' = mkTvSubst (mkInScopeSet all_range_tvs) env' + +niSubstTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +-- This is used in the occurs check, before extending the substitution +niSubstTvSet subst tvs + = foldVarSet (unionVarSet . get) emptyVarSet tvs + where + get tv = case lookupVarEnv subst tv of + Nothing -> unitVarSet tv + Just ty -> niSubstTvSet subst (tyVarsOfType ty) + +{- +************************************************************************ +* * + The workhorse +* * +************************************************************************ +-} + +unify :: TvSubstEnv -- An existing substitution to extend + -> Type -> Type -- Types to be unified, and witness of their equality + -> UM TvSubstEnv -- Just the extended substitution, + -- Nothing if unification failed +-- We do not require the incoming substitution to be idempotent, +-- nor guarantee that the outgoing one is. That's fixed up by +-- the wrappers. + +-- Respects newtypes, PredTypes + +-- in unify, any NewTcApps/Preds should be taken at face value +unify subst (TyVarTy tv1) ty2 = uVar subst tv1 ty2 +unify subst ty1 (TyVarTy tv2) = uVar subst tv2 ty1 + +unify subst ty1 ty2 | Just ty1' <- tcView ty1 = unify subst ty1' ty2 +unify subst ty1 ty2 | Just ty2' <- tcView ty2 = unify subst ty1 ty2' + +unify subst (TyConApp tyc1 tys1) (TyConApp tyc2 tys2) + | tyc1 == tyc2 + = unify_tys subst tys1 tys2 + +unify subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) + = do { subst' <- unify subst ty1a ty2a + ; unify subst' ty1b ty2b } + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables and Notes, + -- so if one type is an App the other one jolly well better be too +unify subst (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + = do { subst' <- unify subst ty1a ty2a + ; unify subst' ty1b ty2b } + +unify subst ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + = do { subst' <- unify subst ty1a ty2a + ; unify subst' ty1b ty2b } + +unify subst (LitTy x) (LitTy y) | x == y = return subst + +unify _ _ _ = surelyApart + -- ForAlls?? + +------------------------------ +unify_tys :: TvSubstEnv -> [Type] -> [Type] -> UM TvSubstEnv +unify_tys subst xs ys = unifyList subst xs ys + +unifyList :: TvSubstEnv -> [Type] -> [Type] -> UM TvSubstEnv +unifyList subst orig_xs orig_ys + = go subst orig_xs orig_ys + where + go subst [] [] = return subst + go subst (x:xs) (y:ys) = do { subst' <- unify subst x y + ; go subst' xs ys } + go subst _ _ = maybeApart subst -- See Note [Lists of different lengths are MaybeApart] + +--------------------------------- +uVar :: TvSubstEnv -- An existing substitution to extend + -> TyVar -- Type variable to be unified + -> Type -- with this type + -> UM TvSubstEnv + +uVar subst tv1 ty + = -- Check to see whether tv1 is refined by the substitution + case (lookupVarEnv subst tv1) of + Just ty' -> unify subst ty' ty -- Yes, call back into unify' + Nothing -> uUnrefined subst -- No, continue + tv1 ty ty + +uUnrefined :: TvSubstEnv -- An existing substitution to extend + -> TyVar -- Type variable to be unified + -> Type -- with this type + -> Type -- (version w/ expanded synonyms) + -> UM TvSubstEnv + +-- We know that tv1 isn't refined + +uUnrefined subst tv1 ty2 ty2' + | Just ty2'' <- tcView ty2' + = uUnrefined subst tv1 ty2 ty2'' -- Unwrap synonyms + -- This is essential, in case we have + -- type Foo a = a + -- and then unify a ~ Foo a + +uUnrefined subst tv1 ty2 (TyVarTy tv2) + | tv1 == tv2 -- Same type variable + = return subst + + -- Check to see whether tv2 is refined + | Just ty' <- lookupVarEnv subst tv2 + = uUnrefined subst tv1 ty' ty' + + | otherwise + + = do { -- So both are unrefined; unify the kinds + ; subst' <- unify subst (tyVarKind tv1) (tyVarKind tv2) + + -- And then bind one or the other, + -- depending on which is bindable + -- NB: unlike TcUnify we do not have an elaborate sub-kinding + -- story. That is relevant only during type inference, and + -- (I very much hope) is not relevant here. + ; b1 <- tvBindFlag tv1 + ; b2 <- tvBindFlag tv2 + ; let ty1 = TyVarTy tv1 + ; case (b1, b2) of + (Skolem, Skolem) -> maybeApart subst' -- See Note [Unification with skolems] + (BindMe, _) -> return (extendVarEnv subst' tv1 ty2) + (_, BindMe) -> return (extendVarEnv subst' tv2 ty1) } + +uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable + | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') + = maybeApart subst -- Occurs check + -- See Note [Fine-grained unification] + | otherwise + = do { subst' <- unify subst k1 k2 + -- Note [Kinds Containing Only Literals] + ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss + where + k1 = tyVarKind tv1 + k2 = typeKind ty2' + +bindTv :: TvSubstEnv -> TyVar -> Type -> UM TvSubstEnv +bindTv subst tv ty -- ty is not a type variable + = do { b <- tvBindFlag tv + ; case b of + Skolem -> maybeApart subst -- See Note [Unification with skolems] + BindMe -> return $ extendVarEnv subst tv ty + } + +{- +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +data BindFlag + = BindMe -- A regular type variable + + | Skolem -- This type variable is a skolem constant + -- Don't bind it; it only matches itself + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +newtype UM a = UM { unUM :: (TyVar -> BindFlag) + -> UnifyResultM a } + +instance Functor UM where + fmap = liftM + +instance Applicative UM where + pure = return + (<*>) = ap + +instance Monad UM where + return a = UM (\_tvs -> Unifiable a) + fail _ = UM (\_tvs -> SurelyApart) -- failed pattern match + m >>= k = UM (\tvs -> case unUM m tvs of + Unifiable v -> unUM (k v) tvs + MaybeApart v -> + case unUM (k v) tvs of + Unifiable v' -> MaybeApart v' + other -> other + SurelyApart -> SurelyApart) + +initUM :: (TyVar -> BindFlag) -> UM a -> UnifyResultM a +initUM badtvs um = unUM um badtvs + +tvBindFlag :: TyVar -> UM BindFlag +tvBindFlag tv = UM (\tv_fn -> Unifiable (tv_fn tv)) + +maybeApart :: TvSubstEnv -> UM TvSubstEnv +maybeApart subst = UM (\_tv_fn -> MaybeApart subst) + +surelyApart :: UM a +surelyApart = UM (\_tv_fn -> SurelyApart) diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs new file mode 100644 index 00000000..95feaed9 --- /dev/null +++ b/compiler/utils/Bag.hs @@ -0,0 +1,266 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Bag: an unordered collection with duplicates +-} + +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +module Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, + mapBag, + elemBag, lengthBag, + filterBag, partitionBag, partitionBagWith, + concatBag, foldBag, foldrBag, foldlBag, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, + listToBag, bagToList, + foldrBagM, foldlBagM, mapBagM, mapBagM_, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM, mapAccumBagLM + ) where + +import Outputable +import Util + +import MonadUtils +import Data.Data +import Data.List ( partition ) + +infixr 3 `consBag` +infixl 3 `snocBag` + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty + deriving Typeable + +emptyBag :: Bag a +emptyBag = EmptyBag + +unitBag :: a -> Bag a +unitBag = UnitBag + +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + +elemBag :: Eq a => a -> Bag a -> Bool +elemBag _ EmptyBag = False +elemBag x (UnitBag y) = x == y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListBag ys) = any (x ==) ys + +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs + +-- This one is a bit stricter! The bag will get completely evaluated. + +unionBags :: Bag a -> Bag a -> Bag a +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +consBag :: a -> Bag a -> Bag a +snocBag :: Bag a -> a -> Bag a + +consBag elt bag = (unitBag elt) `unionBags` bag +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag :: Bag a -> Bool +isEmptyBag EmptyBag = True +isEmptyBag _ = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag _) = True +isSingletonBag (TwoBags _ _) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag _ EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListBag vs) = listToBag (filter pred vs) + +anyBag :: (a -> Bool) -> Bag a -> Bool +anyBag _ EmptyBag = False +anyBag p (UnitBag v) = p v +anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 +anyBag p (ListBag xs) = any p xs + +concatBag :: Bag (Bag a) -> Bag a +concatBag EmptyBag = EmptyBag +concatBag (UnitBag b) = b +concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2 +concatBag (ListBag bs) = unionManyBags bs + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) + = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBag pred b1 + (sat2, fail2) = partitionBag pred b2 +partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partition pred vs + + +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred vs + +foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative + -> (a -> r) -- Replace UnitBag with this + -> r -- Replace EmptyBag with this + -> Bag a + -> r + +{- Standard definition +foldBag t u e EmptyBag = e +foldBag t u e (UnitBag x) = u x +foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) +foldBag t u e (ListBag xs) = foldr (t.u) e xs +-} + +-- More tail-recursive definition, exploiting associativity of "t" +foldBag _ _ e EmptyBag = e +foldBag t u e (UnitBag x) = u x `t` e +foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 +foldBag t u e (ListBag xs) = foldr (t.u) e xs + +foldrBag :: (a -> r -> r) -> r + -> Bag a + -> r + +foldrBag _ z EmptyBag = z +foldrBag k z (UnitBag x) = k x z +foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 +foldrBag k z (ListBag xs) = foldr k z xs + +foldlBag :: (r -> a -> r) -> r + -> Bag a + -> r + +foldlBag _ z EmptyBag = z +foldlBag k z (UnitBag x) = k z x +foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 +foldlBag k z (ListBag xs) = foldl k z xs + +foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b +foldrBagM _ z EmptyBag = return z +foldrBagM k z (UnitBag x) = k x z +foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } +foldrBagM k z (ListBag xs) = foldrM k z xs + +foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b +foldlBagM _ z EmptyBag = return z +foldlBagM k z (UnitBag x) = k z x +foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 } +foldlBagM k z (ListBag xs) = foldlM k z xs + +mapBag :: (a -> b) -> Bag a -> Bag b +mapBag _ EmptyBag = EmptyBag +mapBag f (UnitBag x) = UnitBag (f x) +mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) +mapBag f (ListBag xs) = ListBag (map f xs) + +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM _ EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do r <- f x + return (UnitBag r) +mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 + r2 <- mapBagM f b2 + return (TwoBags r1 r2) +mapBagM f (ListBag xs) = do rs <- mapM f xs + return (ListBag rs) + +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x + return (UnitBag r, UnitBag s) +mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 + (r2,s2) <- mapAndUnzipBagM f b2 + return (TwoBags r1 r2, TwoBags s1 s2) +mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs + let (rs,ss) = unzip ts + return (ListBag rs, ListBag ss) + +mapAccumBagLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining funcction + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> m (acc, Bag y) -- ^ final state, outputs +mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) +mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } +mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 + ; (s2, b2') <- mapAccumBagLM f s1 b2 + ; return (s2, TwoBags b1' b2') } +mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs + ; return (s', ListBag xs') } + +listToBag :: [a] -> Bag a +listToBag [] = EmptyBag +listToBag vs = ListBag vs + +bagToList :: Bag a -> [a] +bagToList b = foldrBag (:) [] b + +instance (Outputable a) => Outputable (Bag a) where + ppr bag = braces (pprWithCommas ppr (bagToList bag)) + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs new file mode 100644 index 00000000..6a4becf6 --- /dev/null +++ b/compiler/utils/Binary.hs @@ -0,0 +1,938 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_GHC -O -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module Binary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + SymbolTable, Dictionary, + + openBinMem, +-- closeBin, + + seekBin, + seekBy, + tellBin, + castBin, + + writeBinMem, + readBinMem, + + fingerprintBinMem, + computeFingerprint, + + isEOFBin, + + putAt, getAt, + + -- for writing instances: + putByte, + getByte, + + -- lazy Bin I/O + lazyGet, + lazyPut, + + ByteArray(..), + getByteArray, + putByteArray, + + UserData(..), getUserData, setUserData, + newReadState, newWriteState, + putDictionary, getDictionary, putFS, + ) where + +#include "HsVersions.h" + +-- The *host* architecture version: +#include "../includes/MachDeps.h" + +import {-# SOURCE #-} Name (Name) +import FastString +import Panic +import UniqFM +import FastMutInt +import Fingerprint +import BasicTypes +import SrcLoc + +import Foreign +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Time +import Data.Typeable +import Data.Typeable.Internal +import Control.Monad ( when ) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import ExtsCompat46 +import GHC.Word ( Word8(..) ) + +import GHC.IO ( IO(..) ) + +type BinArray = ForeignPtr Word8 + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + _off_r :: !FastMutInt, -- the current offset + _sz_r :: !FastMutInt, -- size of the array (cached) + _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put_ bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +seekBy :: BinHandle -> Int -> IO () +seekBy h@(BinMem _ ix_r sz_r _) off = do + sz <- readFastMutInt sz_r + ix <- readFastMutInt ix_r + let ix' = ix + off + if (ix' >= sz) + then do expandBin h ix'; writeFastMutInt ix_r ix' + else writeFastMutInt ix_r ix' + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem _ ix_r sz_r _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- mallocForeignPtrBytes (filesize*2) + count <- withForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem (BinMem _ ix_r _ arr_r) = do + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \p -> fingerprintData p ix + +computeFingerprint :: Binary a + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint + +computeFingerprint put_name a = do + bh <- openBinMem (3*1024) -- just less than a block + bh <- return $ setUserData bh $ newWriteState put_name putFS + put_ bh a + fingerprintBinMem bh + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ _ sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putWord8 h w + else do arr <- readIORef arr_r + withForeignPtr arr $ \p -> pokeByteOff p ix w + writeFastMutInt ix_r (ix+1) + return () + +getWord8 :: BinHandle -> IO Word8 +getWord8 (BinMem _ ix_r sz_r arr_r) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- withForeignPtr arr $ \p -> peekByteOff p ix + writeFastMutInt ix_r (ix+1) + return w + +putByte :: BinHandle -> Word8 -> IO () +putByte bh w = put_ bh w + +getByte :: BinHandle -> IO Word8 +getByte = getWord8 + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + put_ = putWord8 + get = getWord8 + +instance Binary Word16 where + put_ h w = do -- XXX too slow.. inline putWord8? + putByte h (fromIntegral (w `shiftR` 8)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + + +instance Binary Word32 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 24)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + +instance Binary Word64 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 56)) + putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + w5 <- getWord8 h + w6 <- getWord8 h + w7 <- getWord8 h + w8 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ h w = put_ h (fromIntegral w :: Word16) + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + put_ h w = put_ h (fromIntegral w :: Word32) + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +instance Binary Int64 where + put_ h w = put_ h (fromIntegral w :: Word64) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + if (len < 0xff) + then putByte bh (fromIntegral len :: Word8) + else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32) + mapM_ (put_ bh) l + get bh = do + b <- getByte bh + len <- if b == 0xff + then get bh + else return (fromIntegral b :: Word32) + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +--to quote binary-0.3 on this code idea, +-- +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianess and word size. +-- +-- This makes it hard (impossible) to make an equivalent instance +-- with code that is compilable with non-GHC. Do we need any instance +-- Binary Integer, and if so, does it have to be blazing fast? Or can +-- we just change this instance to be portable like the rest of the +-- instances? (binary package has code to steal for that) +-- +-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs + +instance Binary Integer where + -- XXX This is hideous + put_ bh i = put_ bh (show i) + get bh = do str <- get bh + case reads str of + [(i, "")] -> return i + _ -> fail ("Binary Integer: got " ++ show str) + + {- + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) +-} + +-- As for the rest of this code, even though this module +-- exports it, it doesn't seem to be used anywhere else +-- in GHC! + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + + +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +instance (Integral a, Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +instance Binary (Bin a) where + put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32) + get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32))) + +-- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh (TyCon _ p m n) = do + put_ bh (p,m,n) + get bh = do + (p,m,n) <- get bh + return (mkTyCon3 p m n) + +instance Binary TypeRep where + put_ bh type_rep = do + let (ty_con, child_type_reps) = splitTyConApp type_rep + put_ bh ty_con + put_ bh child_type_reps + get bh = do + ty_con <- get bh + child_type_reps <- get bh + return (mkTyConApp ty_con child_type_reps) + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt + getAt bh { _off_r = off_r } p_a + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +data UserData = + UserData { + -- for *deserialising* only: + ud_get_name :: BinHandle -> IO Name, + ud_get_fs :: BinHandle -> IO FastString, + + -- for *serialising* only: + ud_put_name :: BinHandle -> Name -> IO (), + ud_put_fs :: BinHandle -> FastString -> IO () + } + +newReadState :: (BinHandle -> IO Name) + -> (BinHandle -> IO FastString) + -> UserData +newReadState get_name get_fs + = UserData { ud_get_name = get_name, + ud_get_fs = get_fs, + ud_put_name = undef "put_name", + ud_put_fs = undef "put_fs" + } + +newWriteState :: (BinHandle -> Name -> IO ()) + -> (BinHandle -> FastString -> IO ()) + -> UserData +newWriteState put_name put_fs + = UserData { ud_get_name = undef "get_name", + ud_get_fs = undef "get_fs", + ud_put_name = put_name, + ud_put_fs = put_fs + } + +noUserData :: a +noUserData = undef "UserData" + +undef :: String -> a +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict))) + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- On disk, the symbol table is an array of IfaceExtName, when +-- reading it in we turn it into a SymbolTable. + +type SymbolTable = Array Int Name + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: BinHandle -> FastString -> IO () +putFS bh fs = putBS bh $ fastStringToByteString fs + +getFS :: BinHandle -> IO FastString +getFS bh = do bs <- getBS bh + return $! mkFastStringByteString bs + +putBS :: BinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + let + go n | n == l = return () + | otherwise = do + b <- peekElemOff (castPtr ptr) n + putByte bh b + go (n+1) + go 0 + +{- -- possible faster version, not quite there yet: +getBS bh@BinMem{} = do + (I# l) <- get bh + arr <- readIORef (arr_r bh) + off <- readFastMutInt (off_r bh) + return $! (mkFastSubBytesBA# arr off l) +-} +getBS :: BinHandle -> IO ByteString +getBS bh = do + l <- get bh + fp <- mallocForeignPtrBytes l + withForeignPtr fp $ \ptr -> do + let go n | n == l = return $ BS.fromForeignPtr fp 0 l + | otherwise = do + b <- getByte bh + pokeElemOff ptr n b + go (n+1) + -- + go 0 + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case getUserData bh of + UserData { ud_put_fs = put_fs } -> put_fs bh f + + get bh = + case getUserData bh of + UserData { ud_get_fs = get_fs } -> get_fs bh + +-- Here to avoid loop + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore aa) = do + putByte bh 2 + put_ bh aa + put_ bh (ActiveAfter ab) = do + putByte bh 3 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do aa <- get bh + return (ActiveBefore aa) + _ -> do ab <- get bh + return (ActiveAfter ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma s a b c d) = do + put_ bh s + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + s <- get bh + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma s a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary DefMethSpec where + put_ bh NoDM = putByte bh 0 + put_ bh VanillaDM = putByte bh 1 + put_ bh GenericDM = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapMode where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt s w) = do + putByte bh 0 + put_ bh s + put_ bh w + put_ bh (DeprecatedTxt s d) = do + putByte bh 1 + put_ bh s + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + w <- get bh + return (WarningTxt s w) + _ -> do s <- get bh + d <- get bh + return (DeprecatedTxt s d) + +instance Binary a => Binary (GenLocated SrcSpan a) where + put_ bh (L l x) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return (L l x) + +instance Binary SrcSpan where + put_ bh (RealSrcSpan ss) = do + putByte bh 0 + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + put_ bh (UnhelpfulSpan s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkSrcSpan (mkSrcLoc f sl sc) + (mkSrcLoc f el ec)) + _ -> do s <- get bh + return (UnhelpfulSpan s) diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs new file mode 100644 index 00000000..5925bdb7 --- /dev/null +++ b/compiler/utils/BooleanFormula.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} + +module BooleanFormula ( + BooleanFormula(..), + mkFalse, mkTrue, mkAnd, mkOr, mkVar, + isFalse, isTrue, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice + ) where + +import Data.List ( nub, intersperse ) +import Data.Data +#if __GLASGOW_HASKELL__ < 709 +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) +#endif + +import MonadUtils +import Outputable +import Binary + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +data BooleanFormula a = Var a | And [BooleanFormula a] | Or [BooleanFormula a] + deriving (Eq, Data, Typeable, Functor, Foldable, Traversable) + +mkVar :: a -> BooleanFormula a +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula a +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula a +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: Eq a => [BooleanFormula a] -> BooleanFormula a +mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: BooleanFormula a -> Maybe [BooleanFormula a] + fromAnd (And xs) = Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + fromAnd (Or []) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + fromAnd x = Just [x] + mkAnd' [x] = x + mkAnd' xs = And xs + +mkOr :: Eq a => [BooleanFormula a] -> BooleanFormula a +mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr (Or xs) = Just xs + fromOr (And []) = Nothing + fromOr x = Just [x] + mkOr' [x] = x + mkOr' xs = Or xs + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpresion elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula a -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula a -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f) xs +eval f (Or xs) = any (eval f) xs + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (simplify f) xs) +simplify f (Or xs) = mkOr (map (simplify f) xs) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq a => BooleanFormula a -> a -> Bool +Var x `impliesAtom` y = x == y +And xs `impliesAtom` y = any (`impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (`impliesAtom` y) xs + +implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool +x `implies` Var y = x `impliesAtom` y +x `implies` And ys = all (x `implies`) ys +x `implies` Or ys = any (x `implies`) ys + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> a -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) $ empty + go p (And xs) = pprAnd p (map (go 3) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2) xs) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse (text "|") + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance Outputable a => Outputable (BooleanFormula a) where + pprPrec = pprBooleanFormula pprPrec + +---------------------------------------------------------------------- +-- Binary +---------------------------------------------------------------------- + +instance Binary a => Binary (BooleanFormula a) where + put_ bh (Var x) = putByte bh 0 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh xs + put_ bh (Or xs) = putByte bh 2 >> put_ bh xs + + get bh = do + h <- getByte bh + case h of + 0 -> Var <$> get bh + 1 -> And <$> get bh + _ -> Or <$> get bh diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs new file mode 100644 index 00000000..40b9759a --- /dev/null +++ b/compiler/utils/BufWrite.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- +-- Fast write-buffered Handles +-- +-- (c) The University of Glasgow 2005-2006 +-- +-- This is a simple abstraction over Handles that offers very fast write +-- buffering, but without the thread safety that Handles provide. It's used +-- to save time in Pretty.printDoc. +-- +----------------------------------------------------------------------------- + +module BufWrite ( + BufHandle(..), + newBufHandle, + bPutChar, + bPutStr, + bPutFS, + bPutFZS, + bPutLitString, + bFlush, + ) where + +import FastString +import FastTypes +import FastMutInt + +import Control.Monad ( when ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char ( ord ) +import Foreign +import Foreign.C.String +import System.IO + +-- ----------------------------------------------------------------------------- + +data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) + {-#UNPACK#-}!FastMutInt + Handle + +newBufHandle :: Handle -> IO BufHandle +newBufHandle hdl = do + ptr <- mallocBytes buf_size + r <- newFastMutInt + writeFastMutInt r 0 + return (BufHandle ptr r hdl) + +buf_size :: Int +buf_size = 8192 + +bPutChar :: BufHandle -> Char -> IO () +bPutChar b@(BufHandle buf r hdl) !c = do + i <- readFastMutInt r + if (i >= buf_size) + then do hPutBuf hdl buf buf_size + writeFastMutInt r 0 + bPutChar b c + else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) + writeFastMutInt r (i+1) + +bPutStr :: BufHandle -> String -> IO () +bPutStr (BufHandle buf r hdl) !str = do + i <- readFastMutInt r + loop str i + where loop _ i | i `seq` False = undefined + loop "" i = do writeFastMutInt r i; return () + loop (c:cs) i + | i >= buf_size = do + hPutBuf hdl buf buf_size + loop (c:cs) 0 + | otherwise = do + pokeElemOff buf i (fromIntegral (ord c)) + loop cs (i+1) + +bPutFS :: BufHandle -> FastString -> IO () +bPutFS b fs = bPutBS b $ fastStringToByteString fs + +bPutFZS :: BufHandle -> FastZString -> IO () +bPutFZS b fs = bPutBS b $ fastZStringToByteString fs + +bPutBS :: BufHandle -> ByteString -> IO () +bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b + +bPutCStringLen :: BufHandle -> CStringLen -> IO () +bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do + i <- readFastMutInt r + if (i + len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl ptr len + else bPutCStringLen b cstr + else do + copyBytes (buf `plusPtr` i) ptr len + writeFastMutInt r (i + len) + +bPutLitString :: BufHandle -> LitString -> FastInt -> IO () +bPutLitString b@(BufHandle buf r hdl) a len_ = a `seq` do + let len = iBox len_ + i <- readFastMutInt r + if (i+len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl a len + else bPutLitString b a len_ + else do + copyBytes (buf `plusPtr` i) a len + writeFastMutInt r (i+len) + +bFlush :: BufHandle -> IO () +bFlush (BufHandle buf r hdl) = do + i <- readFastMutInt r + when (i > 0) $ hPutBuf hdl buf i + free buf + return () diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs new file mode 100644 index 00000000..8f5df0ce --- /dev/null +++ b/compiler/utils/Digraph.hs @@ -0,0 +1,652 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +module Digraph( + Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, + + SCC(..), Node, flattenSCC, flattenSCCs, + stronglyConnCompG, + topologicalSortG, dfsTopSortG, + verticesG, edgesG, hasVertexG, + reachableG, reachablesG, transposeG, + outdegreeG, indegreeG, + vertexGroupsG, emptyG, + componentsG, + + findCycle, + + -- For backwards compatability with the simpler version of Digraph + stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, + + -- No friendly interface yet, not used but exported to avoid warnings + tabulate, preArr, + components, undirected, + back, cross, forward, + path, + bcc, do_label, bicomps, collect + ) where + +#include "HsVersions.h" + +------------------------------------------------------------------------------ +-- A version of the graph algorithms described in: +-- +-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' +-- by David King and John Launchbury +-- +-- Also included is some additional code for printing tree structures ... +------------------------------------------------------------------------------ + + +import Util ( minWith, count ) +import Outputable +import Maybes ( expectJust ) +import MonadUtils ( allM ) + +-- Extensions +import Control.Monad ( filterM, liftM, liftM2 ) +import Control.Monad.ST + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List hiding (transpose) +import Data.Ord +import Data.Array.ST +import qualified Data.Map as Map +import qualified Data.Set as Set + +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ + +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n +-} + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex + } + +data Edge node = Edge node node + +type Node key payload = (payload, key, [key]) + -- The payload is user data, just carried around in this module + -- The keys are ordered + -- The [key] are the dependencies of the node; + -- it's ok to have extra keys in the dependencies that + -- are not the key of any Node in the graph + +emptyGraph :: Graph a +emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) + +graphFromVerticesAndAdjacency + :: Ord key + => [(node, key)] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (node, key) +graphFromVerticesAndAdjacency [] _ = emptyGraph +graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) + where key_extractor = snd + (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) + reduced_edges = map key_vertex_pair edges + graph = buildG bounds reduced_edges + +graphFromEdgedVertices + :: Ord key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which arent + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVertices [] = emptyGraph +graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) + where key_extractor (_, k, _) = k + (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor + graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes] + +reduceNodesIntoVertices + :: Ord key + => [node] + -> (node -> key) + -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)]) +reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes) + where + max_v = length nodes - 1 + bounds = (0, max_v) :: (Vertex, Vertex) + + sorted_nodes = sortBy (comparing key_extractor) nodes + numbered_nodes = zipWith (,) [0..] sorted_nodes + + key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes] + vertex_map = array bounds numbered_nodes + + --key_vertex :: key -> Maybe Vertex + -- returns Nothing for non-interesting vertices + key_vertex k = find 0 max_v + where + find a b | a > b = Nothing + | otherwise = let mid = (a + b) `div` 2 + in case compare k (key_map ! mid) of + LT -> find a (mid - 1) + EQ -> Just mid + GT -> find (mid + 1) b + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) deps) + | node@(_,_,deps) <- graph ]) + (root_payload,root_key,root_deps) = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((payload,key,deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +data SCC vertex = AcyclicSCC vertex + | CyclicSCC [vertex] + +instance Functor SCC where + fmap f (AcyclicSCC v) = AcyclicSCC (f v) + fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs) + +flattenSCCs :: [SCC a] -> [a] +flattenSCCs = concatMap flattenSCC + +flattenSCC :: SCC a -> [a] +flattenSCC (AcyclicSCC v) = [v] +flattenSCC (CyclicSCC vs) = vs + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) + +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ + +Note: the components are returned topologically sorted: later components +depend on earlier ones, but not vice versa i.e. later components only have +edges going from them to earlier ones. +-} + +stronglyConnCompG :: Graph node -> [SCC node] +stronglyConnCompG graph = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) + +decodeSccs :: Graph node -> Forest Vertex -> [SCC node] +decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest + = map decode forest + where + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + + +-- The following two versions are provided for backwards compatability: +stronglyConnCompFromEdgedVertices + :: Ord key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVertices + = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR + where get_node (n, _, _) = n + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you dont want to lose the dependency info +stronglyConnCompFromEdgedVerticesR + :: Ord key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices + +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} + +topologicalSortG :: Graph node -> [node] +topologicalSortG graph = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + +dfsTopSortG :: Graph node -> [[node]] +dfsTopSortG graph = + map (map (gr_vertex_to_node graph) . flattenTree) $ dfs g (topSort g) + where + g = gr_int_graph graph + +reachableG :: Graph node -> node -> [node] +reachableG graph from = map (gr_vertex_to_node graph) result + where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) + result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] + +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] + +hasVertexG :: Graph node -> node -> Bool +hasVertexG graph node = isJust $ gr_node_to_vertex graph node + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +transposeG :: Graph node -> Graph node +transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph) + +outdegreeG :: Graph node -> node -> Maybe Int +outdegreeG = degreeG outdegree + +indegreeG :: Graph node -> node -> Maybe Int +indegreeG = degreeG indegree + +degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int +degreeG degree graph node = let table = degree (gr_int_graph graph) + in fmap ((!) table) $ gr_node_to_vertex graph node + +vertexGroupsG :: Graph node -> [[node]] +vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result + where result = vertexGroups (gr_int_graph graph) + +emptyG :: Graph node -> Bool +emptyG g = graphEmpty (gr_int_graph g) + +componentsG :: Graph node -> [[node]] +componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph) + +{- +************************************************************************ +* * +* Showing Graphs +* * +************************************************************************ +-} + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type Vertex = Int +type Table a = Array Vertex a +type IntGraph = Table [Vertex] +type Bounds = (Vertex, Vertex) +type IntEdge = (Vertex, Vertex) + +vertices :: IntGraph -> [Vertex] +vertices = indices + +edges :: IntGraph -> [IntEdge] +edges g = [ (v, w) | v <- vertices g, w <- g!v ] + +mapT :: (Vertex -> a -> b) -> Table a -> Table b +mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ] + +buildG :: Bounds -> [IntEdge] -> IntGraph +buildG bounds edges = accumArray (flip (:)) [] bounds edges + +transpose :: IntGraph -> IntGraph +transpose g = buildG (bounds g) (reverseE g) + +reverseE :: IntGraph -> [IntEdge] +reverseE g = [ (w, v) | (v, w) <- edges g ] + +outdegree :: IntGraph -> Table Int +outdegree = mapT numEdges + where numEdges _ ws = length ws + +indegree :: IntGraph -> Table Int +indegree = outdegree . transpose + +graphEmpty :: IntGraph -> Bool +graphEmpty g = lo > hi + where (lo, hi) = bounds g + +{- +************************************************************************ +* * +* Trees and forests +* * +************************************************************************ +-} + +data Tree a = Node a (Forest a) +type Forest a = [Tree a] + +mapTree :: (a -> b) -> (Tree a -> Tree b) +mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) + +flattenTree :: Tree a -> [a] +flattenTree (Node x ts) = x : concatMap flattenTree ts + +instance Show a => Show (Tree a) where + showsPrec _ t s = showTree t ++ s + +showTree :: Show a => Tree a -> String +showTree = drawTree . mapTree show + +drawTree :: Tree String -> String +drawTree = unlines . draw + +draw :: Tree String -> [String] +draw (Node x ts) = grp this (space (length this)) (stLoop ts) + where this = s1 ++ x ++ " " + + space n = replicate n ' ' + + stLoop [] = [""] + stLoop [t] = grp s2 " " (draw t) + stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts + + rsLoop [] = [] + rsLoop [t] = grp s5 " " (draw t) + rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts + + grp fst rst = zipWith (++) (fst:repeat rst) + + [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"] + +{- +************************************************************************ +* * +* Depth first search +* * +************************************************************************ +-} + +type Set s = STArray s Vertex Bool + +mkEmpty :: Bounds -> ST s (Set s) +mkEmpty bnds = newArray bnds False + +contains :: Set s -> Vertex -> ST s Bool +contains m v = readArray m v + +include :: Set s -> Vertex -> ST s () +include m v = writeArray m v True + +dff :: IntGraph -> Forest Vertex +dff g = dfs g (vertices g) + +dfs :: IntGraph -> [Vertex] -> Forest Vertex +dfs g vs = prune (bounds g) (map (generate g) vs) + +generate :: IntGraph -> Vertex -> Tree Vertex +generate g v = Node v (map (generate g) (g!v)) + +prune :: Bounds -> Forest Vertex -> Forest Vertex +prune bnds ts = runST (mkEmpty bnds >>= \m -> + chop m ts) + +chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) +chop _ [] = return [] +chop m (Node v ts : us) + = contains m v >>= \visited -> + if visited then + chop m us + else + include m v >>= \_ -> + chop m ts >>= \as -> + chop m us >>= \bs -> + return (Node v as : bs) + +{- +************************************************************************ +* * +* Algorithms +* * +************************************************************************ + +------------------------------------------------------------ +-- Algorithm 1: depth first search numbering +------------------------------------------------------------ +-} + +preorder :: Tree a -> [a] +preorder (Node a ts) = a : preorderF ts + +preorderF :: Forest a -> [a] +preorderF ts = concat (map preorder ts) + +tabulate :: Bounds -> [Vertex] -> Table Int +tabulate bnds vs = array bnds (zip vs [1..]) + +preArr :: Bounds -> Forest Vertex -> Table Int +preArr bnds = tabulate bnds . preorderF + +{- +------------------------------------------------------------ +-- Algorithm 2: topological sorting +------------------------------------------------------------ +-} + +postorder :: Tree a -> [a] -> [a] +postorder (Node a ts) = postorderF ts . (a :) + +postorderF :: Forest a -> [a] -> [a] +postorderF ts = foldr (.) id $ map postorder ts + +postOrd :: IntGraph -> [Vertex] +postOrd g = postorderF (dff g) [] + +topSort :: IntGraph -> [Vertex] +topSort = reverse . postOrd + +{- +------------------------------------------------------------ +-- Algorithm 3: connected components +------------------------------------------------------------ +-} + +components :: IntGraph -> Forest Vertex +components = dff . undirected + +undirected :: IntGraph -> IntGraph +undirected g = buildG (bounds g) (edges g ++ reverseE g) + +{- +------------------------------------------------------------ +-- Algorithm 4: strongly connected components +------------------------------------------------------------ +-} + +scc :: IntGraph -> Forest Vertex +scc g = dfs g (reverse (postOrd (transpose g))) + +{- +------------------------------------------------------------ +-- Algorithm 5: Classifying edges +------------------------------------------------------------ +-} + +back :: IntGraph -> Table Int -> IntGraph +back g post = mapT select g + where select v ws = [ w | w <- ws, post!v < post!w ] + +cross :: IntGraph -> Table Int -> Table Int -> IntGraph +cross g pre post = mapT select g + where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ] + +forward :: IntGraph -> IntGraph -> Table Int -> IntGraph +forward g tree pre = mapT select g + where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v + +{- +------------------------------------------------------------ +-- Algorithm 6: Finding reachable vertices +------------------------------------------------------------ +-} + +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (dfs g vs) + +path :: IntGraph -> Vertex -> Vertex -> Bool +path g v w = w `elem` (reachable g [v]) + +{- +------------------------------------------------------------ +-- Algorithm 7: Biconnected components +------------------------------------------------------------ +-} + +bcc :: IntGraph -> Forest [Vertex] +bcc g = (concat . map bicomps . map (do_label g dnum)) forest + where forest = dff g + dnum = preArr (bounds g) forest + +do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) +do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us + where us = map (do_label g dnum) ts + lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] + ++ [lu | Node (_,_,lu) _ <- us]) + +bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex] +bicomps (Node (v,_,_) ts) + = [ Node (v:vs) us | (_,Node vs us) <- map collect ts] + +collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex]) +collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) + where collected = map collect ts + vs = concat [ ws | (lw, Node ws _) <- collected, lw [[Vertex]] +vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices) + where next_vertices = noOutEdges g + +noOutEdges :: IntGraph -> [Vertex] +noOutEdges g = [ v | v <- vertices g, null (g!v)] + +vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]] +vertexGroupsS provided g to_provide + = if null to_provide + then do { + all_provided <- allM (provided `contains`) (vertices g) + ; if all_provided + then return [] + else error "vertexGroup: cyclic graph" + } + else do { + mapM_ (include provided) to_provide + ; to_provide' <- filterM (vertexReady provided g) (vertices g) + ; rest <- vertexGroupsS provided g to_provide' + ; return $ to_provide : rest + } + +vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool +vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v)) diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs new file mode 100644 index 00000000..ae727d2f --- /dev/null +++ b/compiler/utils/Encoding.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module Encoding ( + -- * UTF-8 + utf8DecodeChar#, + utf8PrevChar, + utf8CharStart, + utf8DecodeChar, + utf8DecodeString, + utf8EncodeChar, + utf8EncodeString, + utf8EncodedLength, + countUTF8Chars, + + -- * Z-encoding + zEncodeString, + zDecodeString + ) where + +import Foreign +import Data.Char +import Numeric +import ExtsCompat46 + +-- ----------------------------------------------------------------------------- +-- UTF-8 + +-- We can't write the decoder as efficiently as we'd like without +-- resorting to unboxed extensions, unfortunately. I tried to write +-- an IO version of this function, but GHC can't eliminate boxed +-- results from an IO-returning function. +-- +-- We assume we can ignore overflow when parsing a multibyte character here. +-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences +-- before decoding them (see StringBuffer.hs). + +{-# INLINE utf8DecodeChar# #-} +utf8DecodeChar# :: Addr# -> (# Char#, Int# #) +utf8DecodeChar# a# = + let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in + case () of + _ | ch0 <=# 0x7F# -> (# chr# ch0, 1# #) + + | ch0 >=# 0xC0# && ch0 <=# 0xDF# -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else + (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ch1 -# 0x80#)), + 2# #) + + | ch0 >=# 0xE0# && ch0 <=# 0xEF# -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if ch2 <# 0x80# || ch2 >=# 0xC0# then fail 2# else + (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch2 -# 0x80#)), + 3# #) + + | ch0 >=# 0xF0# && ch0 <=# 0xF8# -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if ch2 <# 0x80# || ch2 >=# 0xC0# then fail 2# else + let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in + if ch3 <# 0x80# || ch3 >=# 0xC0# then fail 3# else + (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch3 -# 0x80#)), + 4# #) + + | otherwise -> fail 1# + where + -- all invalid sequences end up here: + fail :: Int# -> (# Char#, Int# #) + fail nBytes# = (# '\0'#, nBytes# #) + -- '\xFFFD' would be the usual replacement character, but + -- that's a valid symbol in Haskell, so will result in a + -- confusing parse error later on. Instead we use '\0' which + -- will signal a lexer error immediately. + +utf8DecodeChar :: Ptr Word8 -> (Char, Int) +utf8DecodeChar (Ptr a#) = + case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) + +-- UTF-8 is cleverly designed so that we can always figure out where +-- the start of the current character is, given any position in a +-- stream. This function finds the start of the previous character, +-- assuming there *is* a previous character. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +utf8DecodeString :: Ptr Word8 -> Int -> IO [Char] +utf8DecodeString ptr len + = unpack ptr + where + !end = ptr `plusPtr` len + + unpack p + | p >= end = return [] + | otherwise = + case utf8DecodeChar# (unPtr p) of + (# c#, nBytes# #) -> do + chs <- unpack (p `plusPtr#` nBytes#) + return (C# c# : chs) + +countUTF8Chars :: Ptr Word8 -> Int -> IO Int +countUTF8Chars ptr len = go ptr 0 + where + !end = ptr `plusPtr` len + + go p !n + | p >= end = return n + | otherwise = do + case utf8DecodeChar# (unPtr p) of + (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) + +unPtr :: Ptr a -> Addr# +unPtr (Ptr a) = a + +plusPtr# :: Ptr a -> Int# -> Ptr a +plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) + +utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) +utf8EncodeChar c ptr = + let x = ord c in + case () of + _ | x > 0 && x <= 0x007f -> do + poke ptr (fromIntegral x) + return (ptr `plusPtr` 1) + -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we + -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). + | x <= 0x07ff -> do + poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 2) + | x <= 0xffff -> do + poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 3) + | otherwise -> do + poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) + pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 4) + +utf8EncodeString :: Ptr Word8 -> String -> IO () +utf8EncodeString ptr str = go ptr str + where go !_ [] = return () + go ptr (c:cs) = do + ptr' <- utf8EncodeChar c ptr + go ptr' cs + +utf8EncodedLength :: String -> Int +utf8EncodedLength str = go 0 str + where go !n [] = n + go n (c:cs) + | ord c > 0 && ord c <= 0x007f = go (n+1) cs + | ord c <= 0x07ff = go (n+2) cs + | ord c <= 0xffff = go (n+3) cs + | otherwise = go (n+4) cs + +-- ----------------------------------------------------------------------------- +-- The Z-encoding + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString cs = case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_digit_ch c ++ go' cs + go' [] = [] + go' (c:cs) = encode_ch c ++ go' cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- If a digit is at the start of a symbol then we need to encode it. +-- Otherwise package names like 9pH-0.1 give linker errors. +encode_digit_ch :: Char -> EncodedString +encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c +encode_digit_ch c | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str + else '0':hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go 1 ('H':rest) = "(# #)" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. +-} + +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing +maybe_tuple _ = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs new file mode 100644 index 00000000..850393e3 --- /dev/null +++ b/compiler/utils/Exception.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Exception + ( + module Control.Exception, + module Exception + ) + where + +import Control.Exception +import Control.Monad.IO.Class + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = Control.Exception.catch + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +-- | A monad that can catch exceptions. A minimal definition +-- requires a definition of 'gcatch'. +-- +-- Implementations on top of 'IO' should implement 'gmask' to +-- eventually call the primitive 'Control.Exception.mask'. +-- These are used for +-- implementations that support asynchronous exceptions. The default +-- implementations of 'gbracket' and 'gfinally' use 'gmask' +-- thus rarely require overriding. +-- +class MonadIO m => ExceptionMonad m where + + -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gcatch :: Exception e => m a -> (e -> m a) -> m a + + -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gmask :: ((m a -> m a) -> m b) -> m b + + -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c + + -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gfinally :: m a -> m b -> m a + + gbracket before after thing = + gmask $ \restore -> do + a <- before + r <- restore (thing a) `gonException` after a + _ <- after a + return r + + a `gfinally` sequel = + gmask $ \restore -> do + r <- restore a `gonException` sequel + _ <- sequel + return r + +instance ExceptionMonad IO where + gcatch = Control.Exception.catch + gmask f = mask (\x -> f x) + +gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) +gtry act = gcatch (act >>= \a -> return (Right a)) + (\e -> return (Left e)) + +-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary +-- exception handling monad instead of just 'IO'. +ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a +ghandle = flip gcatch + +-- | Always executes the first argument. If this throws an exception the +-- second argument is executed and the exception is raised again. +gonException :: (ExceptionMonad m) => m a -> m b -> m a +gonException ioA cleanup = ioA `gcatch` \e -> + do _ <- cleanup + liftIO $ throwIO (e :: SomeException) + diff --git a/compiler/utils/ExtsCompat46.hs b/compiler/utils/ExtsCompat46.hs new file mode 100644 index 00000000..a33fef57 --- /dev/null +++ b/compiler/utils/ExtsCompat46.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : ExtsCompat46 +-- Copyright : (c) Lodz University of Technology 2013 +-- License : see LICENSE +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC internal) +-- +-- Compatibility module to encapsulate primops API change between GHC 7.6 +-- GHC 7.8. +-- +-- In GHC we use comparison primops in a couple of modules, but that primops +-- have different type signature in GHC 7.6 (where they return Bool) than +-- in GHC 7.8 (where they return Int#). As long as we allow bootstrapping +-- with GHC 7.6 or earlier we need to have this compatibility module, so that +-- we can compile stage1 compiler using the old API and then continue with +-- stage2 using the new API. When we set GHC 7.8 as the minimum version +-- required for bootstrapping, we should remove this module. +-- +----------------------------------------------------------------------------- + +module ExtsCompat46 ( + module GHC.Exts, + + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + + ) where + +import GHC.Exts hiding ( + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + ) + +import qualified GHC.Exts as E ( + gtChar#, geChar#, eqChar#, + neChar#, ltChar#, leChar#, + + (>#), (>=#), (==#), (/=#), (<#), (<=#), + + gtWord#, geWord#, eqWord#, + neWord#, ltWord#, leWord#, + + (>##), (>=##), (==##), (/=##), (<##), (<=##), + + gtFloat#, geFloat#, eqFloat#, + neFloat#, ltFloat#, leFloat#, + + gtAddr#, geAddr#, eqAddr#, + neAddr#, ltAddr#, leAddr#, + + sameMutableArray#, sameMutableByteArray#, sameMutableArrayArray#, + sameMutVar#, sameTVar#, sameMVar# + ) + +-- See #8330 +#if __GLASGOW_HASKELL__ > 710 +#error What is minimal version of GHC required for bootstraping? If it's GHC 7.8 we should remove this module and use GHC.Exts instead. +#endif + +#if __GLASGOW_HASKELL__ > 706 + +gtChar# :: Char# -> Char# -> Bool +gtChar# a b = isTrue# (a `E.gtChar#` b) +geChar# :: Char# -> Char# -> Bool +geChar# a b = isTrue# (a `E.geChar#` b) +eqChar# :: Char# -> Char# -> Bool +eqChar# a b = isTrue# (a `E.eqChar#` b) +neChar# :: Char# -> Char# -> Bool +neChar# a b = isTrue# (a `E.neChar#` b) +ltChar# :: Char# -> Char# -> Bool +ltChar# a b = isTrue# (a `E.ltChar#` b) +leChar# :: Char# -> Char# -> Bool +leChar# a b = isTrue# (a `E.leChar#` b) + +infix 4 >#, >=#, ==#, /=#, <#, <=# + +(>#) :: Int# -> Int# -> Bool +(>#) a b = isTrue# (a E.># b) +(>=#) :: Int# -> Int# -> Bool +(>=#) a b = isTrue# (a E.>=# b) +(==#) :: Int# -> Int# -> Bool +(==#) a b = isTrue# (a E.==# b) +(/=#) :: Int# -> Int# -> Bool +(/=#) a b = isTrue# (a E./=# b) +(<#) :: Int# -> Int# -> Bool +(<#) a b = isTrue# (a E.<# b) +(<=#) :: Int# -> Int# -> Bool +(<=#) a b = isTrue# (a E.<=# b) + +gtWord# :: Word# -> Word# -> Bool +gtWord# a b = isTrue# (a `E.gtWord#` b) +geWord# :: Word# -> Word# -> Bool +geWord# a b = isTrue# (a `E.geWord#` b) +eqWord# :: Word# -> Word# -> Bool +eqWord# a b = isTrue# (a `E.eqWord#` b) +neWord# :: Word# -> Word# -> Bool +neWord# a b = isTrue# (a `E.neWord#` b) +ltWord# :: Word# -> Word# -> Bool +ltWord# a b = isTrue# (a `E.ltWord#` b) +leWord# :: Word# -> Word# -> Bool +leWord# a b = isTrue# (a `E.leWord#` b) + +infix 4 >##, >=##, ==##, /=##, <##, <=## + +(>##) :: Double# -> Double# -> Bool +(>##) a b = isTrue# (a E.>## b) +(>=##) :: Double# -> Double# -> Bool +(>=##) a b = isTrue# (a E.>=## b) +(==##) :: Double# -> Double# -> Bool +(==##) a b = isTrue# (a E.==## b) +(/=##) :: Double# -> Double# -> Bool +(/=##) a b = isTrue# (a E./=## b) +(<##) :: Double# -> Double# -> Bool +(<##) a b = isTrue# (a E.<## b) +(<=##) :: Double# -> Double# -> Bool +(<=##) a b = isTrue# (a E.<=## b) + +gtFloat# :: Float# -> Float# -> Bool +gtFloat# a b = isTrue# (a `E.gtFloat#` b) +geFloat# :: Float# -> Float# -> Bool +geFloat# a b = isTrue# (a `E.geFloat#` b) +eqFloat# :: Float# -> Float# -> Bool +eqFloat# a b = isTrue# (a `E.eqFloat#` b) +neFloat# :: Float# -> Float# -> Bool +neFloat# a b = isTrue# (a `E.neFloat#` b) +ltFloat# :: Float# -> Float# -> Bool +ltFloat# a b = isTrue# (a `E.ltFloat#` b) +leFloat# :: Float# -> Float# -> Bool +leFloat# a b = isTrue# (a `E.leFloat#` b) + +gtAddr# :: Addr# -> Addr# -> Bool +gtAddr# a b = isTrue# (a `E.gtAddr#` b) +geAddr# :: Addr# -> Addr# -> Bool +geAddr# a b = isTrue# (a `E.geAddr#` b) +eqAddr# :: Addr# -> Addr# -> Bool +eqAddr# a b = isTrue# (a `E.eqAddr#` b) +neAddr# :: Addr# -> Addr# -> Bool +neAddr# a b = isTrue# (a `E.neAddr#` b) +ltAddr# :: Addr# -> Addr# -> Bool +ltAddr# a b = isTrue# (a `E.ltAddr#` b) +leAddr# :: Addr# -> Addr# -> Bool +leAddr# a b = isTrue# (a `E.leAddr#` b) + +sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool +sameMutableArray# a b = isTrue# (E.sameMutableArray# a b) +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool +sameMutableByteArray# a b = isTrue# (E.sameMutableByteArray# a b) +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool +sameMutableArrayArray# a b = isTrue# (E.sameMutableArrayArray# a b) + +sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool +sameMutVar# a b = isTrue# (E.sameMutVar# a b) +sameTVar# :: TVar# s a -> TVar# s a -> Bool +sameTVar# a b = isTrue# (E.sameTVar# a b) +sameMVar# :: MVar# s a -> MVar# s a -> Bool +sameMVar# a b = isTrue# (E.sameMVar# a b) + +#else + +gtChar# :: Char# -> Char# -> Bool +gtChar# a b = a `E.gtChar#` b +geChar# :: Char# -> Char# -> Bool +geChar# a b = a `E.geChar#` b +eqChar# :: Char# -> Char# -> Bool +eqChar# a b = a `E.eqChar#` b +neChar# :: Char# -> Char# -> Bool +neChar# a b = a `E.neChar#` b +ltChar# :: Char# -> Char# -> Bool +ltChar# a b = a `E.ltChar#` b +leChar# :: Char# -> Char# -> Bool +leChar# a b = a `E.leChar#` b + +infix 4 >#, >=#, ==#, /=#, <#, <=# + +(>#) :: Int# -> Int# -> Bool +(>#) a b = a E.># b +(>=#) :: Int# -> Int# -> Bool +(>=#) a b = a E.>=# b +(==#) :: Int# -> Int# -> Bool +(==#) a b = a E.==# b +(/=#) :: Int# -> Int# -> Bool +(/=#) a b = a E./=# b +(<#) :: Int# -> Int# -> Bool +(<#) a b = a E.<# b +(<=#) :: Int# -> Int# -> Bool +(<=#) a b = a E.<=# b + +gtWord# :: Word# -> Word# -> Bool +gtWord# a b = a `E.gtWord#` b +geWord# :: Word# -> Word# -> Bool +geWord# a b = a `E.geWord#` b +eqWord# :: Word# -> Word# -> Bool +eqWord# a b = a `E.eqWord#` b +neWord# :: Word# -> Word# -> Bool +neWord# a b = a `E.neWord#` b +ltWord# :: Word# -> Word# -> Bool +ltWord# a b = a `E.ltWord#` b +leWord# :: Word# -> Word# -> Bool +leWord# a b = a `E.leWord#` b + +infix 4 >##, >=##, ==##, /=##, <##, <=## + +(>##) :: Double# -> Double# -> Bool +(>##) a b = a E.>## b +(>=##) :: Double# -> Double# -> Bool +(>=##) a b = a E.>=## b +(==##) :: Double# -> Double# -> Bool +(==##) a b = a E.==## b +(/=##) :: Double# -> Double# -> Bool +(/=##) a b = a E./=## b +(<##) :: Double# -> Double# -> Bool +(<##) a b = a E.<## b +(<=##) :: Double# -> Double# -> Bool +(<=##) a b = a E.<=## b + +gtFloat# :: Float# -> Float# -> Bool +gtFloat# a b = a `E.gtFloat#` b +geFloat# :: Float# -> Float# -> Bool +geFloat# a b = a `E.geFloat#` b +eqFloat# :: Float# -> Float# -> Bool +eqFloat# a b = a `E.eqFloat#` b +neFloat# :: Float# -> Float# -> Bool +neFloat# a b = a `E.neFloat#` b +ltFloat# :: Float# -> Float# -> Bool +ltFloat# a b = a `E.ltFloat#` b +leFloat# :: Float# -> Float# -> Bool +leFloat# a b = a `E.leFloat#` b + +gtAddr# :: Addr# -> Addr# -> Bool +gtAddr# a b = a `E.gtAddr#` b +geAddr# :: Addr# -> Addr# -> Bool +geAddr# a b = a `E.geAddr#` b +eqAddr# :: Addr# -> Addr# -> Bool +eqAddr# a b = a `E.eqAddr#` b +neAddr# :: Addr# -> Addr# -> Bool +neAddr# a b = a `E.neAddr#` b +ltAddr# :: Addr# -> Addr# -> Bool +ltAddr# a b = a `E.ltAddr#` b +leAddr# :: Addr# -> Addr# -> Bool +leAddr# a b = a `E.leAddr#` b + +sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Bool +sameMutableArray# a b = E.sameMutableArray# a b +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool +sameMutableByteArray# a b = E.sameMutableByteArray# a b +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Bool +sameMutableArrayArray# a b = E.sameMutableArrayArray# a b + +sameMutVar# :: MutVar# s a -> MutVar# s a -> Bool +sameMutVar# a b = E.sameMutVar# a b +sameTVar# :: TVar# s a -> TVar# s a -> Bool +sameTVar# a b = E.sameTVar# a b +sameMVar# :: MVar# s a -> MVar# s a -> Bool +sameMVar# a b = E.sameMVar# a b + +#endif \ No newline at end of file diff --git a/compiler/utils/FastBool.hs b/compiler/utils/FastBool.hs new file mode 100644 index 00000000..9e88376f --- /dev/null +++ b/compiler/utils/FastBool.hs @@ -0,0 +1,70 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section{Fast booleans} +-} + +{-# LANGUAGE CPP, MagicHash #-} + +module FastBool ( + --fastBool could be called bBox; isFastTrue, bUnbox; but they're not + FastBool, fastBool, isFastTrue, fastOr, fastAnd + ) where + +-- Import the beggars +import GHC.Exts +#ifdef DEBUG +import Panic +#endif + +type FastBool = Int# +fastBool True = 1# +fastBool False = 0# + +#ifdef DEBUG +--then waste time deciding whether to panic. FastBool should normally +--be at least as fast as Bool, one would hope... + +isFastTrue 1# = True +isFastTrue 0# = False +isFastTrue _ = panic "FastTypes: isFastTrue" + +-- note that fastOr and fastAnd are strict in both arguments +-- since they are unboxed +fastOr 1# _ = 1# +fastOr 0# x = x +fastOr _ _ = panicFastInt "FastTypes: fastOr" + +fastAnd 0# _ = 0# +fastAnd 1# x = x +fastAnd _ _ = panicFastInt "FastTypes: fastAnd" + +--these "panicFastInt"s (formerly known as "panic#") rely on +--FastInt = FastBool ( = Int# presumably), +--haha, true enough when __GLASGOW_HASKELL__. Why can't we have functions +--that return _|_ be kind-polymorphic ( ?? to be precise ) ? + +#else /* ! DEBUG */ +--Isn't comparison to zero sometimes faster on CPUs than comparison to 1? +-- (since using Int# as _synonym_ fails to guarantee that it will +-- only take on values of 0 and 1) +isFastTrue 0# = False +isFastTrue _ = True + +-- note that fastOr and fastAnd are strict in both arguments +-- since they are unboxed +-- Also, to avoid incomplete-pattern warning +-- (and avoid wasting time with redundant runtime checks), +-- we don't pattern-match on both 0# and 1# . +fastOr 0# x = x +fastOr _ _ = 1# + +fastAnd 0# _ = 0# +fastAnd _ x = x + +#endif /* ! DEBUG */ + +fastBool :: Bool -> FastBool +isFastTrue :: FastBool -> Bool +fastOr :: FastBool -> FastBool -> FastBool +fastAnd :: FastBool -> FastBool -> FastBool diff --git a/compiler/utils/FastFunctions.hs b/compiler/utils/FastFunctions.hs new file mode 100644 index 00000000..140e4294 --- /dev/null +++ b/compiler/utils/FastFunctions.hs @@ -0,0 +1,46 @@ +{- +Z% +(c) The University of Glasgow, 2000-2006 + +\section{Fast functions} +-} + +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +module FastFunctions ( + unsafeChr, inlinePerformIO, unsafeDupableInterleaveIO, + indexWord8OffFastPtr, + indexWord8OffFastPtrAsFastChar, indexWord8OffFastPtrAsFastInt, + global, Global + ) where + +#include "HsVersions.h" + +import FastTypes +import Data.IORef +import System.IO.Unsafe + +import GHC.Exts +import GHC.Word +import GHC.Base (unsafeChr) + +import GHC.IO (IO(..), unsafeDupableInterleaveIO) + +-- Just like unsafePerformIO, but we inline it. +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r + +indexWord8OffFastPtr p i = W8# (indexWord8OffAddr# p i) +indexWord8OffFastPtrAsFastChar p i = indexCharOffAddr# p i +indexWord8OffFastPtrAsFastInt p i = word2Int# (indexWord8OffAddr# p i) +-- or ord# (indexCharOffAddr# p i) + +--just so we can refer to the type clearly in a macro +type Global a = IORef a +global :: a -> Global a +global a = unsafePerformIO (newIORef a) + +indexWord8OffFastPtr :: FastPtr Word8 -> FastInt -> Word8 +indexWord8OffFastPtrAsFastChar :: FastPtr Word8 -> FastInt -> FastChar +indexWord8OffFastPtrAsFastInt :: FastPtr Word8 -> FastInt -> FastInt diff --git a/compiler/utils/FastMutInt.hs b/compiler/utils/FastMutInt.hs new file mode 100644 index 00000000..4cde1216 --- /dev/null +++ b/compiler/utils/FastMutInt.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Unboxed mutable Ints + +module FastMutInt( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr + ) where + + +#include "../includes/MachDeps.h" +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +import GHC.Base +import GHC.Ptr + +newFastMutInt :: IO FastMutInt +readFastMutInt :: FastMutInt -> IO Int +writeFastMutInt :: FastMutInt -> Int -> IO () + +newFastMutPtr :: IO FastMutPtr +readFastMutPtr :: FastMutPtr -> IO (Ptr a) +writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where !(I# size) = SIZEOF_HSINT + +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) + +newFastMutPtr = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutPtr arr #) } + where !(I# size) = SIZEOF_VOID_P + +readFastMutPtr (FastMutPtr arr) = IO $ \s -> + case readAddrArray# arr 0# s of { (# s, i #) -> + (# s, Ptr i #) } + +writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> + case writeAddrArray# arr 0# i s of { s -> + (# s, () #) } diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs new file mode 100644 index 00000000..9607d248 --- /dev/null +++ b/compiler/utils/FastString.hs @@ -0,0 +1,640 @@ +-- (c) The University of Glasgow, 1997-2006 + +{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | +-- There are two principal string types used internally by GHC: +-- +-- ['FastString'] +-- +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- +-- ['LitString'] +-- +-- * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@). +-- * Practically no operations. +-- * Outputing them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' +-- +-- Use 'LitString' unless you want the facilities of 'FastString'. +module FastString + ( + -- * ByteString + fastStringToByteString, + mkFastStringByteString, + fastZStringToByteString, + unsafeMkByteString, + hashByteString, + + -- * FastZString + FastZString, + hPutFZS, + zString, + lengthFZS, + + -- * FastStrings + FastString(..), -- not abstract, for now. + + -- ** Construction + fsLit, + mkFastString, + mkFastStringBytes, + mkFastStringByteList, + mkFastStringForeignPtr, + mkFastString#, + + -- ** Deconstruction + unpackFS, -- :: FastString -> String + bytesFS, -- :: FastString -> [Word8] + + -- ** Encoding + zEncodeFS, + + -- ** Operations + uniqueOfFS, + lengthFS, + nullFS, + appendFS, + headFS, + tailFS, + concatFS, + consFS, + nilFS, + + -- ** Outputing + hPutFS, + + -- ** Internal + getFastStringTable, + hasZEncoding, + + -- * LitStrings + LitString, + + -- ** Construction + sLit, + mkLitString#, + mkLitString, + + -- ** Deconstruction + unpackLitString, + + -- ** Operations + lengthLS + ) where + +#include "HsVersions.h" + +import Encoding +import FastTypes +import FastFunctions +import Panic +import Util + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Foreign.C +import ExtsCompat46 +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import Data.Data +import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef ) +import Data.Maybe ( isJust ) +import Data.Char +import Data.List ( elemIndex ) + +import GHC.IO ( IO(..), unsafeDupablePerformIO ) + +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif + +#if STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + +import GHC.Base ( unpackCString# ) + +#define hASH_TBL_SIZE 4091 +#define hASH_TBL_SIZE_UNBOXED 4091# + + +fastStringToByteString :: FastString -> ByteString +fastStringToByteString f = fs_bs f + +fastZStringToByteString :: FastZString -> ByteString +fastZStringToByteString (FastZString bs) = bs + +-- This will drop information if any character > '\xFF' +unsafeMkByteString :: String -> ByteString +unsafeMkByteString = BSC.pack + +hashByteString :: ByteString -> Int +hashByteString bs + = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + return $ hashStr (castPtr ptr) len + +-- ----------------------------------------------------------------------------- + +newtype FastZString = FastZString ByteString + +hPutFZS :: Handle -> FastZString -> IO () +hPutFZS handle (FastZString bs) = BS.hPut handle bs + +zString :: FastZString -> String +zString (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen + +lengthFZS :: FastZString -> Int +lengthFZS (FastZString bs) = BS.length bs + +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (BSC.pack str) + +-- ----------------------------------------------------------------------------- + +{-| +A 'FastString' is an array of bytes, hashed to support fast O(1) +comparison. It is also associated with a character encoding, so that +we know how to convert a 'FastString' to the local encoding, or to the +Z-encoding used by the compiler internally. + +'FastString's support a memoized conversion to the Z-encoding via zEncodeFS. +-} + +data FastString = FastString { + uniq :: {-# UNPACK #-} !Int, -- unique id + n_chars :: {-# UNPACK #-} !Int, -- number of chars + fs_bs :: {-# UNPACK #-} !ByteString, + fs_ref :: {-# UNPACK #-} !(IORef (Maybe FastZString)) + } deriving Typeable + +instance Eq FastString where + f1 == f2 = uniq f1 == uniq f2 + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +instance Show FastString where + show fs = show (unpackFS fs) + +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + +cmpFS :: FastString -> FastString -> Ordering +cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = + if u1 == u2 then EQ else + compare (fastStringToByteString f1) (fastStringToByteString f2) + +foreign import ccall unsafe "ghc_memcmp" + memcmp :: Ptr a -> Ptr b -> Int -> IO Int + +-- ----------------------------------------------------------------------------- +-- Construction + +{- +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. + +See Note [Updating the FastString table] on how it's updated. +-} +data FastStringTable = + FastStringTable + {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets + (MutableArray# RealWorld (IORef [FastString])) -- the array of mutable buckets + +string_table :: FastStringTable +{-# NOINLINE string_table #-} +string_table = unsafePerformIO $ do + uid <- newIORef 603979776 -- ord '$' * 0x01000000 + tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of + (# s2#, arr# #) -> + (# s2#, FastStringTable uid arr# #) + forM_ [0.. hASH_TBL_SIZE-1] $ \i -> do + bucket <- newIORef [] + updTbl tab i bucket + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if STAGE < 2 + return tab +#else + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +The old `reinitializeGlobals` mechanism is enough to provide the plugin with +read-access to the table, but it insufficient in the general case where the +plugin may allocate FastStrings. This mutates the supply for the FastStrings' +unique, and that needs to be propagated back to the compiler's instance of the +global variable. Such propagation is beyond the `reinitializeGlobals` +mechanism. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +lookupTbl :: FastStringTable -> Int -> IO (IORef [FastString]) +lookupTbl (FastStringTable _ arr#) (I# i#) = + IO $ \ s# -> readArray# arr# i# s# + +updTbl :: FastStringTable -> Int -> IORef [FastString] -> IO () +updTbl (FastStringTable _uid arr#) (I# i#) ls = do + (IO $ \ s# -> case writeArray# arr# i# ls s# of { s2# -> (# s2#, () #) }) + +mkFastString# :: Addr# -> FastString +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) + where ptr = Ptr a# + +{- Note [Updating the FastString table] + +The procedure goes like this: + +1. Read the relevant bucket and perform a look up of the string. +2. If it exists, return it. +3. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant bucket with this FastString: + + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +{- Note [Double-checking the bucket] + +It is not necessary to check the entire bucket the second time. We only have to +check the strings that are new to the bucket since the last time we read it. +-} + +mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString +mkFastStringWith mk_fs !ptr !len = do + let hash = hashStr ptr len + bucket <- lookupTbl string_table hash + ls1 <- readIORef bucket + res <- bucket_match ls1 len ptr + case res of + Just v -> return v + Nothing -> do + n <- get_uid + new_fs <- mk_fs n + + atomicModifyIORef bucket $ \ls2 -> + -- Note [Double-checking the bucket] + let delta_ls = case ls1 of + [] -> ls2 + l:_ -> case l `elemIndex` ls2 of + Nothing -> panic "mkFastStringWith" + Just idx -> take idx ls2 + + -- NB: Might as well use inlinePerformIO, since the call to + -- bucket_match doesn't perform any IO that could be floated + -- out of this closure or erroneously duplicated. + in case inlinePerformIO (bucket_match delta_ls len ptr) of + Nothing -> (new_fs:ls2, new_fs) + Just fs -> (ls2,fs) + where + !(FastStringTable uid _arr) = string_table + + get_uid = atomicModifyIORef uid $ \n -> (n+1,n) + +mkFastStringBytes :: Ptr Word8 -> Int -> FastString +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ + mkFastStringWith (copyNewFastString ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString +mkFastStringForeignPtr ptr !fp len + = mkFastStringWith (mkNewFastString fp ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringByteString :: ByteString -> FastString +mkFastStringByteString bs = + inlinePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do + let ptr' = castPtr ptr + mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len + +-- | Creates a UTF-8 encoded 'FastString' from a 'String' +mkFastString :: String -> FastString +mkFastString str = + inlinePerformIO $ do + let l = utf8EncodedLength str + buf <- mallocForeignPtrBytes l + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + mkFastStringForeignPtr ptr buf l + +-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ +mkFastStringByteList :: [Word8] -> FastString +mkFastStringByteList str = + inlinePerformIO $ do + let l = Prelude.length str + buf <- mallocForeignPtrBytes l + withForeignPtr buf $ \ptr -> do + pokeArray (castPtr ptr) str + mkFastStringForeignPtr ptr buf l + +-- | Creates a Z-encoded 'FastString' from a 'String' +mkZFastString :: String -> FastZString +mkZFastString = mkFastZStringString + +bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) +bucket_match [] _ _ = return Nothing +bucket_match (v@(FastString _ _ bs _):ls) len ptr + | len == BS.length bs = do + b <- BS.unsafeUseAsCString bs $ \buf -> + cmpStringPrefix ptr (castPtr buf) len + if b then return (Just v) + else bucket_match ls len ptr + | otherwise = + bucket_match ls len ptr + +mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int + -> IO FastString +mkNewFastString fp ptr len uid = do + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) + +mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int + -> IO FastString +mkNewFastStringByteString bs ptr len uid = do + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars bs ref) + +copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString +copyNewFastString ptr len uid = do + fp <- copyBytesToForeignPtr ptr len + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) + +copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) +copyBytesToForeignPtr ptr len = do + fp <- mallocForeignPtrBytes len + withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len + return fp + +cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +cmpStringPrefix ptr1 ptr2 len = + do r <- memcmp ptr1 ptr2 len + return (r == 0) + + +hashStr :: Ptr Word8 -> Int -> Int + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | n ExtsCompat46.==# len# = I# h + | otherwise = loop h2 (n ExtsCompat46.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c ExtsCompat46.+# (h ExtsCompat46.*# 128#)) `remInt#` + hASH_TBL_SIZE# + +-- ----------------------------------------------------------------------------- +-- Operations + +-- | Returns the length of the 'FastString' in characters +lengthFS :: FastString -> Int +lengthFS f = n_chars f + +-- | Returns @True@ if this 'FastString' is not Z-encoded but already has +-- a Z-encoding cached (used in producing stats). +hasZEncoding :: FastString -> Bool +hasZEncoding (FastString _ _ _ ref) = + inlinePerformIO $ do + m <- readIORef ref + return (isJust m) + +-- | Returns @True@ if the 'FastString' is empty +nullFS :: FastString -> Bool +nullFS f = BS.null (fs_bs f) + +-- | Unpacks and decodes the FastString +unpackFS :: FastString -> String +unpackFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + utf8DecodeString (castPtr ptr) len + +-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' +bytesFS :: FastString -> [Word8] +bytesFS fs = BS.unpack $ fastStringToByteString fs + +-- | Returns a Z-encoded version of a 'FastString'. This might be the +-- original, if it was already Z-encoded. The first time this +-- function is applied to a particular 'FastString', the results are +-- memoized. +-- +zEncodeFS :: FastString -> FastZString +zEncodeFS fs@(FastString _ _ _ ref) = + inlinePerformIO $ do + m <- readIORef ref + case m of + Just zfs -> return zfs + Nothing -> do + atomicModifyIORef ref $ \m' -> case m' of + Nothing -> let zfs = mkZFastString (zEncodeString (unpackFS fs)) + in (Just zfs, zfs) + Just zfs -> (m', zfs) + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringByteString + $ BS.append (fastStringToByteString fs1) + (fastStringToByteString fs2) + +concatFS :: [FastString] -> FastString +concatFS ls = mkFastString (Prelude.concat (map unpackFS ls)) -- ToDo: do better + +headFS :: FastString -> Char +headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" +headFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + return (fst (utf8DecodeChar (castPtr ptr))) + +tailFS :: FastString -> FastString +tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" +tailFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + do let (_, n) = utf8DecodeChar (castPtr ptr) + return $! mkFastStringByteString (BS.drop n bs) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c : unpackFS fs) + +uniqueOfFS :: FastString -> FastInt +uniqueOfFS (FastString u _ _ _) = iUnbox u + +nilFS :: FastString +nilFS = mkFastString "" + +-- ----------------------------------------------------------------------------- +-- Stats + +getFastStringTable :: IO [[FastString]] +getFastStringTable = do + buckets <- forM [0.. hASH_TBL_SIZE-1] $ \idx -> do + bucket <- lookupTbl string_table idx + readIORef bucket + return buckets + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +-- |Outputs a 'FastString' with /no decoding at all/, that is, you +-- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () +hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs + +-- ToDo: we'll probably want an hPutFSLocal, or something, to output +-- in the current locale's encoding (for error messages and suchlike). + +-- ----------------------------------------------------------------------------- +-- LitStrings, here for convenience only. + +-- hmm, not unboxed (or rather FastPtr), interesting +--a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph. We don't +--really care about C types in naming, where we can help it. +type LitString = Ptr Word8 +--Why do we recalculate length every time it's requested? +--If it's commonly needed, we should perhaps have +--data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt + +mkLitString# :: Addr# -> LitString +mkLitString# a# = Ptr a# +--can/should we use FastTypes here? +--Is this likely to be memory-preserving if only used on constant strings? +--should we inline it? If lucky, that would make a CAF that wouldn't +--be computationally repeated... although admittedly we're not +--really intending to use mkLitString when __GLASGOW_HASKELL__... +--(I wonder, is unicode / multi-byte characters allowed in LitStrings +-- at all?) +{-# INLINE mkLitString #-} +mkLitString :: String -> LitString +mkLitString s = + unsafePerformIO (do + p <- mallocBytes (length s + 1) + let + loop :: Int -> String -> IO () + loop !n [] = pokeByteOff p n (0 :: Word8) + loop n (c:cs) = do + pokeByteOff p n (fromIntegral (ord c) :: Word8) + loop (1+n) cs + loop 0 s + return p + ) + +unpackLitString :: LitString -> String +unpackLitString p_ = case pUnbox p_ of + p -> unpack (_ILIT(0)) + where + unpack n = case indexWord8OffFastPtrAsFastChar p n of + ch -> if ch `eqFastChar` _CLIT('\0') + then [] else cBox ch : unpack (n +# _ILIT(1)) + +lengthLS :: LitString -> Int +lengthLS = ptrStrLength + +-- for now, use a simple String representation +--no, let's not do that right now - it's work in other places +#if 0 +type LitString = String + +mkLitString :: String -> LitString +mkLitString = id + +unpackLitString :: LitString -> String +unpackLitString = id + +lengthLS :: LitString -> Int +lengthLS = length + +#endif + +-- ----------------------------------------------------------------------------- +-- under the carpet + +foreign import ccall unsafe "ghc_strlen" + ptrStrLength :: Ptr Word8 -> Int + +{-# NOINLINE sLit #-} +sLit :: String -> LitString +sLit x = mkLitString x + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "slit" + forall x . sLit (unpackCString# x) = mkLitString# x #-} +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/utils/FastTypes.hs b/compiler/utils/FastTypes.hs new file mode 100644 index 00000000..a5c1aa96 --- /dev/null +++ b/compiler/utils/FastTypes.hs @@ -0,0 +1,138 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section{Fast integers, etc... booleans moved to FastBool for using panic} +-} + +{-# LANGUAGE CPP, MagicHash #-} + +--Even if the optimizer could handle boxed arithmetic equally well, +--this helps automatically check the sources to make sure that +--it's only used in an appropriate pattern of efficiency. +--(it also makes `let`s and `case`s stricter...) + +-- | Fast integers, characters and pointer types for use in many parts of GHC +module FastTypes ( + -- * FastInt + FastInt, + + -- ** Getting in and out of FastInt + _ILIT, iBox, iUnbox, + + -- ** Arithmetic on FastInt + (+#), (-#), (*#), quotFastInt, negateFastInt, + --quotRemFastInt is difficult because unboxed values can't + --be tupled, but unboxed tuples aren't portable. Just use + -- nuisance boxed quotRem and rely on optimization. + (==#), (/=#), (<#), (<=#), (>=#), (>#), + minFastInt, maxFastInt, + --prefer to distinguish operations, not types, between + --signed and unsigned. + --left-shift is the same for 'signed' and 'unsigned' numbers + shiftLFastInt, + --right-shift isn't the same for negative numbers (ones with + --the highest-order bit '1'). If you don't care because the + --number you're shifting is always nonnegative, use the '_' version + --which should just be the fastest one. + shiftR_FastInt, + --"L' = logical or unsigned shift; 'A' = arithmetic or signed shift + shiftRLFastInt, shiftRAFastInt, + bitAndFastInt, bitOrFastInt, + --add more operations to this file as you need them + + -- * FastChar + FastChar, + + -- ** Getting in and out of FastChar + _CLIT, cBox, cUnbox, + + -- ** Operations on FastChar + fastOrd, fastChr, eqFastChar, + --note, fastChr is "unsafe"Chr: it doesn't check for + --character values above the range of Unicode + + -- * FastPtr + FastPtr, + + -- ** Getting in and out of FastPtr + pBox, pUnbox, + + -- ** Casting FastPtrs + castFastPtr + ) where + +#include "HsVersions.h" + +-- Import the beggars +import ExtsCompat46 + +type FastInt = Int# + +--in case it's a macro, don't lexically feed an argument! +--e.g. #define _ILIT(x) (x#) , #define _ILIT(x) (x :: FastInt) +_ILIT = \(I# x) -> x +--perhaps for accomodating caseless-leading-underscore treatment, +--something like _iLIT or iLIT would be better? + +iBox x = I# x +iUnbox (I# x) = x +quotFastInt = quotInt# +negateFastInt = negateInt# + +--I think uncheckedIShiftL# and uncheckedIShiftRL# are the same +--as uncheckedShiftL# and uncheckedShiftRL# ... +--should they be used? How new are they? +--They existed as far back as GHC 6.0 at least... +shiftLFastInt x y = uncheckedIShiftL# x y +shiftR_FastInt x y = uncheckedIShiftRL# x y +shiftRLFastInt x y = uncheckedIShiftRL# x y +shiftRAFastInt x y = uncheckedIShiftRA# x y +--{-# INLINE shiftLNonnegativeFastInt #-} +--{-# INLINE shiftRNonnegativeFastInt #-} +--shiftLNonnegativeFastInt n p = word2Int#((int2Word# n) `uncheckedShiftL#` p) +--shiftRNonnegativeFastInt n p = word2Int#((int2Word# n) `uncheckedShiftRL#` p) +bitAndFastInt x y = word2Int# (and# (int2Word# x) (int2Word# y)) +bitOrFastInt x y = word2Int# (or# (int2Word# x) (int2Word# y)) + +type FastChar = Char# +_CLIT = \(C# c) -> c +cBox c = C# c +cUnbox (C# c) = c +fastOrd c = ord# c +fastChr x = chr# x +eqFastChar a b = eqChar# a b + +--note that the type-parameter doesn't provide any safety +--when it's a synonym, but as long as we keep it compiling +--with and without __GLASGOW_HASKELL__ defined, it's fine. +type FastPtr a = Addr# +pBox p = Ptr p +pUnbox (Ptr p) = p +castFastPtr p = p + +minFastInt, maxFastInt :: FastInt -> FastInt -> FastInt +minFastInt x y = if x <# y then x else y +maxFastInt x y = if x <# y then y else x + +-- type-signatures will improve the non-ghc-specific versions +-- and keep things accurate (and ABLE to compile!) +_ILIT :: Int -> FastInt +iBox :: FastInt -> Int +iUnbox :: Int -> FastInt + +quotFastInt :: FastInt -> FastInt -> FastInt +negateFastInt :: FastInt -> FastInt +shiftLFastInt, shiftR_FastInt, shiftRAFastInt, shiftRLFastInt + :: FastInt -> FastInt -> FastInt +bitAndFastInt, bitOrFastInt :: FastInt -> FastInt -> FastInt + +_CLIT :: Char -> FastChar +cBox :: FastChar -> Char +cUnbox :: Char -> FastChar +fastOrd :: FastChar -> FastInt +fastChr :: FastInt -> FastChar +eqFastChar :: FastChar -> FastChar -> Bool + +pBox :: FastPtr a -> Ptr a +pUnbox :: Ptr a -> FastPtr a +castFastPtr :: FastPtr a -> FastPtr b diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc new file mode 100644 index 00000000..464337b7 --- /dev/null +++ b/compiler/utils/Fingerprint.hsc @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning. +-- +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance +-- +-- ---------------------------------------------------------------------------- + +module Fingerprint ( + Fingerprint(..), fingerprint0, + readHexFingerprint, + fingerprintData, + fingerprintString, + -- Re-exported from GHC.Fingerprint for GHC >= 7.7, local otherwise + getFileHash + ) where + +#include "md5.h" +##include "HsVersions.h" + +import Numeric ( readHex ) +#if __GLASGOW_HASKELL__ < 707 +-- Only needed for getFileHash below. +import Foreign +import Panic +import System.IO +import Control.Monad ( when ) +#endif + +import GHC.Fingerprint + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + + +#if __GLASGOW_HASKELL__ < 707 +-- Only use this if we're smaller than GHC 7.7, otherwise +-- GHC.Fingerprint exports a better version of this function. + +-- | Computes the hash of a given file. +-- It loads the full file into memory an does not work with files bigger than +-- MAXINT. +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \h -> do + + fileSize <- toIntFileSize `fmap` hFileSize h + + allocaBytes fileSize $ \bufPtr -> do + n <- hGetBuf h bufPtr fileSize + when (n /= fileSize) readFailedError + fingerprintData bufPtr fileSize + + where + toIntFileSize :: Integer -> Int + toIntFileSize size + | size > fromIntegral (maxBound :: Int) = throwGhcException $ + Sorry $ "Fingerprint.getFileHash: Tried to calculate hash of file " + ++ path ++ " with size > maxBound :: Int. This is not supported." + | otherwise = fromIntegral size + + readFailedError = throwGhcException $ + Panic $ "Fingerprint.getFileHash: hGetBuf failed on interface file" +#endif diff --git a/compiler/utils/FiniteMap.hs b/compiler/utils/FiniteMap.hs new file mode 100644 index 00000000..dccfca10 --- /dev/null +++ b/compiler/utils/FiniteMap.hs @@ -0,0 +1,29 @@ +-- Some extra functions to extend Data.Map + +module FiniteMap ( + insertList, + insertListWith, + deleteList, + foldRight, foldRightWithKey + ) where + +import Data.Map (Map) +import qualified Data.Map as Map + +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs + +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs + +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl (flip Map.delete) m ks + +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.fold +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +foldRightWithKey = Map.foldrWithKey diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs new file mode 100644 index 00000000..c3850dfd --- /dev/null +++ b/compiler/utils/GraphBase.hs @@ -0,0 +1,105 @@ + +-- | Types for the general graph colorer. +module GraphBase ( + Triv, + Graph (..), + initGraph, + graphMapModify, + + Node (..), newNode, +) + + +where + +import UniqSet +import UniqFM + + +-- | A fn to check if a node is trivially colorable +-- For graphs who's color classes are disjoint then a node is 'trivially colorable' +-- when it has less neighbors and exclusions than available colors for that node. +-- +-- For graph's who's color classes overlap, ie some colors alias other colors, then +-- this can be a bit more tricky. There is a general way to calculate this, but +-- it's likely be too slow for use in the code. The coloring algorithm takes +-- a canned function which can be optimised by the user to be specific to the +-- specific graph being colored. +-- +-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" +-- Smith, Ramsey, Holloway - PLDI 2004. +-- +type Triv k cls color + = cls -- the class of the node we're trying to color. + -> UniqSet k -- the node's neighbors. + -> UniqSet color -- the node's exclusions. + -> Bool + + +-- | The Interference graph. +-- There used to be more fields, but they were turfed out in a previous revision. +-- maybe we'll want more later.. +-- +data Graph k cls color + = Graph { + -- | All active nodes in the graph. + graphMap :: UniqFM (Node k cls color) } + + +-- | An empty graph. +initGraph :: Graph k cls color +initGraph + = Graph + { graphMap = emptyUFM } + + +-- | Modify the finite map holding the nodes in the graph. +graphMapModify + :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) + -> Graph k cls color -> Graph k cls color + +graphMapModify f graph + = graph { graphMap = f (graphMap graph) } + + + +-- | Graph nodes. +-- Represents a thing that can conflict with another thing. +-- For the register allocater the nodes represent registers. +-- +data Node k cls color + = Node { + -- | A unique identifier for this node. + nodeId :: k + + -- | The class of this node, + -- determines the set of colors that can be used. + , nodeClass :: cls + + -- | The color of this node, if any. + , nodeColor :: Maybe color + + -- | Neighbors which must be colored differently to this node. + , nodeConflicts :: UniqSet k + + -- | Colors that cannot be used by this node. + , nodeExclusions :: UniqSet color + + -- | Colors that this node would prefer to be, in decending order. + , nodePreference :: [color] + + -- | Neighbors that this node would like to be colored the same as. + , nodeCoalesce :: UniqSet k } + + +-- | An empty node. +newNode :: k -> cls -> Node k cls color +newNode k cls + = Node + { nodeId = k + , nodeClass = cls + , nodeColor = Nothing + , nodeConflicts = emptyUniqSet + , nodeExclusions = emptyUniqSet + , nodePreference = [] + , nodeCoalesce = emptyUniqSet } diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs new file mode 100644 index 00000000..7ba8efbd --- /dev/null +++ b/compiler/utils/GraphColor.hs @@ -0,0 +1,369 @@ +-- | Graph Coloring. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. +-- + +module GraphColor ( + module GraphBase, + module GraphOps, + module GraphPpr, + colorGraph +) + +where + +import GraphBase +import GraphOps +import GraphPpr + +import Unique +import UniqFM +import UniqSet +import Outputable + +import Data.Maybe +import Data.List + + +-- | Try to color a graph with this set of colors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- +colorGraph + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced + -- r1 should be replaced by r2 in the source + +colorGraph iterative spinCount colors triv spill graph0 + = let + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. + -- + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a resonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan + + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are avaliable + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound @(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce + + +-- | Try to assign a color to all these nodes. + +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) + + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of + + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks + + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks + + + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + + | otherwise + = Nothing + + + +-- | Select a color for a certain node +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. +-- +selectColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ uniqSetToList + $ nodeConflicts node + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concat $ map nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- uniqSetToList colors_ok + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor + + + diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs new file mode 100644 index 00000000..7bf3ecdf --- /dev/null +++ b/compiler/utils/GraphOps.hs @@ -0,0 +1,665 @@ +-- | Basic operations on graphs. +-- + +module GraphOps ( + addNode, delNode, getNode, lookupNode, modNode, + size, + union, + addConflict, delConflict, addConflicts, + addCoalesce, delCoalesce, + addExclusion, addExclusions, + addPreference, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, + setColor, + validateGraph, + slurpNodeConflictCount +) +where + +import GraphBase + +import Outputable +import Unique +import UniqSet +import UniqFM + +import Data.List hiding (union) +import Data.Maybe + +-- | Lookup a node from the graph. +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) + +lookupNode graph k + = lookupUFM (graphMap graph) k + + +-- | Get a node from the graph, throwing an error if it's not there +getNode + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color + +getNode graph k + = case lookupUFM (graphMap graph) k of + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" + + +-- | Add a node to the graph, linking up its edges +addNode :: Uniquable k + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + +addNode k node graph + = let + -- add back conflict edges from other nodes to this one + map_conflict + = foldUniqSet + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce + = foldUniqSet + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + + +-- | Delete a node and all its edges from the graph. +delNode :: (Uniquable k, Outputable k) + => k -> Graph k cls color -> Maybe (Graph k cls color) + +delNode k graph + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ uniqSetToList (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ uniqSetToList (nodeCoalesce node) + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing + + +-- | Modify a node in the graph. +-- returns Nothing if the node isn't present. +-- +modNode :: Uniquable k + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) + +modNode f k graph + = case lookupNode graph k of + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph + + Nothing -> Nothing + + +-- | Get the size of the graph, O(n) +size :: Uniquable k + => Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + + +-- | Union two graphs together. +union :: Uniquable k + => Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } + + +-- | Add a conflict between nodes to the graph, creating the nodes required. +-- Conflicts are virtual regs which need to be colored differently. +addConflict + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addConflict (u1, c1) (u2, c2) + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + +-- | Delete a conflict edge. k1 -> k2 +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delConflict k1 k2 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 + + +-- | Add some conflicts to the graph, creating nodes if required. +-- All the nodes in the set are taken to conflict with each other. +addConflicts + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color + +addConflicts conflicts getClass + + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- uniqSetToList conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ uniqSetToList conflicts) + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set + = case delOneFromUniqSet set u of + set' -> adjustWithDefaultUFM + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u + + +-- | Add an exclusion to the graph, creating nodes if required. +-- These are extra colors that the node cannot use. +addExclusion + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u + +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + + +-- | Add a coalescence edge to the graph, creating nodes if requried. +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 + . addCoalesce u2 c2 u1) + + +-- | Delete a coalescence edge (k1 -> k2) from the graph. +delCoalesce + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delCoalesce k1 k2 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 + + +-- | Add a color preference to the graph, creating nodes if required. +-- The most recently added preference is the most prefered. +-- The algorithm tries to assign a node it's prefered color if possible. +-- +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u + + +-- | Do agressive coalescing on this graph. +-- returns the new graph and the list of pairs of nodes that got coaleced together. +-- for each pair, the resulting node will have the least key and be second in the pair. +-- +coalesceGraph + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. + +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) +coalesceGraph' aggressive triv graph kkPairsAcc + = let + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ eltsUFM $ graphMap graph + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- uniqSetToList $ nodeCoalesce node1 ] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + + +-- | Coalesce this pair of nodes unconditionally \/ agressively. +-- The resulting node is the one with the least key. +-- +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one +-- +-- Nothing if either of the nodes weren't in the graph + +coalesceNodes + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes aggressive triv graph (k1, k2) + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) + + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax + + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) + + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) + +coalesceNodes_merge + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_check aggressive triv graph kMin kMax node + + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) + + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 + + in (graph3, Just (kMax, kMin)) + + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. + + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k, Outputable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ eltsUFM $ graphMap graph + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ eltsUFM $ graphMap graph + + +-- | validate the internal structure of a graph +-- all its edges should point to valid nodes +-- If they don't then throw an error +-- +validateGraph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph + +validateGraph doc isColored graph + + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GraphOps.validateGraph" + ( text "Graph has edges that point to non-existant nodes" + $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph + + +-- | If this node is colored, check that all the nodes which +-- conflict with it have different colors. +checkNode + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False + + | otherwise + = True + + + +-- | Slurp out a map of how many nodes had a certain number of conflict neighbours + +slurpNodeConflictCount + :: Uniquable k + => Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + +slurpNodeConflictCount graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ eltsUFM + $ graphMap graph + + +-- | Set the color of a certain node +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + +setColor u color + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a + +adjustWithDefaultUFM f def k map + = addToUFM_C + (\old _ -> f old) + map + k def + +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a + +adjustUFM_C f k map + = case lookupUFM map k of + Nothing -> map + Just a -> addToUFM map k (f a) + diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs new file mode 100644 index 00000000..df85fddc --- /dev/null +++ b/compiler/utils/GraphPpr.hs @@ -0,0 +1,168 @@ + +-- | Pretty printing of graphs. + +module GraphPpr ( + dumpGraph, + dotGraph +) +where + +import GraphBase + +import Outputable +import Unique +import UniqSet +import UniqFM + +import Data.List +import Data.Maybe + + +-- | Pretty print a graph in a somewhat human readable format. +dumpGraph + :: (Outputable k, Outputable cls, Outputable color) + => Graph k cls color -> SDoc + +dumpGraph graph + = text "Graph" + $$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph) + +dumpNode + :: (Outputable k, Outputable cls, Outputable color) + => Node k cls color -> SDoc + +dumpNode node + = text "Node " <> ppr (nodeId node) + $$ text "conflicts " + <> parens (int (sizeUniqSet $ nodeConflicts node)) + <> text " = " + <> ppr (nodeConflicts node) + + $$ text "exclusions " + <> parens (int (sizeUniqSet $ nodeExclusions node)) + <> text " = " + <> ppr (nodeExclusions node) + + $$ text "coalesce " + <> parens (int (sizeUniqSet $ nodeCoalesce node)) + <> text " = " + <> ppr (nodeCoalesce node) + + $$ space + + + +-- | Pretty print a graph in graphviz .dot format. +-- Conflicts get solid edges. +-- Coalescences get dashed edges. +dotGraph + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) -- ^ What graphviz color to use for each node color + -- It's usually safe to return X11 style colors here, + -- ie "red", "green" etc or a hex triplet #aaff55 etc + -> Triv k cls color + -> Graph k cls color -> SDoc + +dotGraph colorMap triv graph + = let nodes = eltsUFM $ graphMap graph + in vcat + ( [ text "graph G {" ] + ++ map (dotNode colorMap triv) nodes + ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) + ++ [ text "}" + , space ]) + + +dotNode :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) + -> Triv k cls color + -> Node k cls color -> SDoc + +dotNode colorMap triv node + = let name = ppr $ nodeId node + cls = ppr $ nodeClass node + + excludes + = hcat $ punctuate space + $ map (\n -> text "-" <> ppr n) + $ uniqSetToList $ nodeExclusions node + + preferences + = hcat $ punctuate space + $ map (\n -> text "+" <> ppr n) + $ nodePreference node + + expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] + then empty + else text "\\n" <> (excludes <+> preferences) + + -- if the node has been colored then show that, + -- otherwise indicate whether it looks trivially colorable. + color + | Just c <- nodeColor node + = text "\\n(" <> ppr c <> text ")" + + | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = text "\\n(" <> text "triv" <> text ")" + + | otherwise + = text "\\n(" <> text "spill?" <> text ")" + + label = name <> text " :: " <> cls + <> expref + <> color + + pcolorC = case nodeColor node of + Nothing -> text "style=filled fillcolor=white" + Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) + + + pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" + <> space <> doubleQuotes name + <> text ";" + + in pout + + +-- | Nodes in the graph are doubly linked, but we only want one edge for each +-- conflict if the graphviz graph. Traverse over the graph, but make sure +-- to only print the edges for each node once. + +dotNodeEdges + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => UniqSet k + -> Node k cls color + -> (UniqSet k, Maybe SDoc) + +dotNodeEdges visited node + | elementOfUniqSet (nodeId node) visited + = ( visited + , Nothing) + + | otherwise + = let dconflicts + = map (dotEdgeConflict (nodeId node)) + $ uniqSetToList + $ minusUniqSet (nodeConflicts node) visited + + dcoalesces + = map (dotEdgeCoalesce (nodeId node)) + $ uniqSetToList + $ minusUniqSet (nodeCoalesce node) visited + + out = vcat dconflicts + $$ vcat dcoalesces + + in ( addOneToUniqSet visited (nodeId node) + , Just out) + + where dotEdgeConflict u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> text ";" + + dotEdgeCoalesce u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> space <> text "[ style = dashed ];" diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs new file mode 100644 index 00000000..46f6e467 --- /dev/null +++ b/compiler/utils/IOEnv.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-} +{-# LANGUAGE CPP #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- The IO Monad with an environment +-- +-- The environment is passed around as a Reader monad but +-- as its in the IO monad, mutable references can be used +-- for updating state. +-- + +module IOEnv ( + IOEnv, -- Instance of Monad + + -- Monad utilities + module MonadUtils, + + -- Errors + failM, failWithM, + IOEnvFailure(..), + + -- Getting at the environment + getEnv, setEnv, updEnv, + + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, + tryM, tryAllM, tryMostM, fixM, + + -- I/O operations + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, + atomicUpdMutVar, atomicUpdMutVar' + ) where + +import DynFlags +import Exception +import Module +import Panic + +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, + atomicModifyIORef ) +import Data.Typeable +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( fixIO ) +import Control.Monad +import MonadUtils +import Control.Applicative (Alternative(..)) + +---------------------------------------------------------------------- +-- Defining the monad type +---------------------------------------------------------------------- + + +newtype IOEnv env a = IOEnv (env -> IO a) + +unIOEnv :: IOEnv env a -> (env -> IO a) +unIOEnv (IOEnv m) = m + +instance Monad (IOEnv m) where + (>>=) = thenM + (>>) = thenM_ + return = returnM + fail _ = failM -- Ignore the string + +instance Applicative (IOEnv m) where + pure = returnM + IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) + +instance Functor (IOEnv m) where + fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env)) + +returnM :: a -> IOEnv env a +returnM a = IOEnv (\ _ -> return a) + +thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b +thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; + unIOEnv (f r) env }) + +thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) + +failM :: IOEnv env a +failM = IOEnv (\ _ -> throwIO IOEnvFailure) + +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ _ -> ioError (userError s)) + +data IOEnvFailure = IOEnvFailure + deriving Typeable + +instance Show IOEnvFailure where + show IOEnvFailure = "IOEnv failure" + +instance Exception IOEnvFailure + +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $ extractDynFlags env + +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + +---------------------------------------------------------------------- +-- Fundmantal combinators specific to the monad +---------------------------------------------------------------------- + + +--------------------------- +runIOEnv :: env -> IOEnv env a -> IO a +runIOEnv env (IOEnv m) = m env + + +--------------------------- +{-# NOINLINE fixM #-} + -- Aargh! Not inlining fixTc alleviates a space leak problem. + -- Normally fixTc is used with a lazy tuple match: if the optimiser is + -- shown the definition of fixTc, it occasionally transforms the code + -- in such a way that the code generator doesn't spot the selector + -- thunks. Sigh. + +fixM :: (a -> IOEnv env a) -> IOEnv env a +fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) + + +--------------------------- +tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) +-- Reflect UserError exceptions (only) into IOEnv monad +-- Other exceptions are not caught; they are simply propagated as exns +-- +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) + +tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) +tryIOEnvFailure = try + +-- XXX We shouldn't be catching everything, e.g. timeouts +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) +-- Catch *all* exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) + +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + +--------------------------- +unsafeInterleaveM :: IOEnv env a -> IOEnv env a +unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) + +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) + +---------------------------------------------------------------------- +-- Alternative/MonadPlus +---------------------------------------------------------------------- + +instance MonadPlus IO => Alternative (IOEnv env) where + empty = mzero + (<|>) = mplus + +-- For use if the user has imported Control.Monad.Error from MTL +-- Requires UndecidableInstances +instance MonadPlus IO => MonadPlus (IOEnv env) where + mzero = IOEnv (const mzero) + m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env) + +---------------------------------------------------------------------- +-- Accessing input/output +---------------------------------------------------------------------- + +instance MonadIO (IOEnv env) where + liftIO io = IOEnv (\ _ -> io) + +newMutVar :: a -> IOEnv env (IORef a) +newMutVar val = liftIO (newIORef val) + +writeMutVar :: IORef a -> a -> IOEnv env () +writeMutVar var val = liftIO (writeIORef var val) + +readMutVar :: IORef a -> IOEnv env a +readMutVar var = liftIO (readIORef var) + +updMutVar :: IORef a -> (a -> a) -> IOEnv env () +updMutVar var upd = liftIO (modifyIORef var upd) + +-- | Atomically update the reference. Does not force the evaluation of the +-- new variable contents. For strict update, use 'atomicUpdMutVar''. +atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) + +-- | Strict variant of 'atomicUpdMutVar'. +atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar' var upd = do + r <- atomicUpdMutVar var upd + _ <- liftIO . evaluate =<< readMutVar var + return r + +---------------------------------------------------------------------- +-- Accessing the environment +---------------------------------------------------------------------- + +getEnv :: IOEnv env env +{-# INLINE getEnv #-} +getEnv = IOEnv (\ env -> return env) + +-- | Perform a computation with a different environment +setEnv :: env' -> IOEnv env' a -> IOEnv env a +{-# INLINE setEnv #-} +setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) + +-- | Perform a computation with an altered environment +updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnv #-} +updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) + diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs new file mode 100644 index 00000000..54faa4f6 --- /dev/null +++ b/compiler/utils/ListSetOps.hs @@ -0,0 +1,187 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ListSetOps]{Set-like operations on lists} +-} + +{-# LANGUAGE CPP #-} + +module ListSetOps ( + unionLists, minusList, insertList, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + + -- Duplicate handling + hasNoDups, runs, removeDups, findDupsEq, + equivClasses, equivClassesByUniq, + + -- Indexing + getNth + ) where + +#include "HsVersions.h" + +import Outputable +import Unique +import UniqFM +import Util + +import Data.List + +{- +--------- +#ifndef DEBUG +getNth :: [a] -> Int -> a +getNth xs n = xs !! n +#else +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthAtLeast` n, ppr n $$ ppr xs ) + xs !! n +#endif +---------- +-} + +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) + xs !! n + +{- +************************************************************************ +* * + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered +* * +************************************************************************ +-} + +insertList :: Eq a => a -> [a] -> [a] +-- Assumes the arg list contains no dups; guarantees the result has no dups +insertList x xs | isIn "insert" x xs = xs + | otherwise = x : xs + +unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] +-- Assumes that the arguments contain no duplicates +unionLists xs ys + = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys) + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys + +minusList :: (Eq a) => [a] -> [a] -> [a] +-- Everything in the first list that is not in the second list: +minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys] + +{- +************************************************************************ +* * +\subsection[Utils-assoc]{Association lists} +* * +************************************************************************ + +Inefficient finite maps based on association lists and equality. +-} + +-- A finite mapping based on equality and association lists +type Assoc a b = [(a,b)] + +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b + +assocDefaultUsing _ deflt [] _ = deflt +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +{- +************************************************************************ +* * +\subsection[Utils-dups]{Duplicate-handling} +* * +************************************************************************ +-} + +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f _ [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far + then False + else f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" + +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [[a]] + +equivClasses _ [] = [] +equivClasses _ stuff@[_] = [stuff] +equivClasses cmp items = runs eq (sortBy cmp items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + +{- +The first cases in @equivClasses@ above are just to cut to the point +more quickly... + +@runs@ groups a list into a list of lists, each sublist being a run of +identical elements of the input list. It is passed a predicate @p@ which +tells when two elements are equal. +-} + +runs :: (a -> a -> Bool) -- Equality + -> [a] + -> [[a]] + +runs _ [] = [] +runs p (x:xs) = case (span (p x) xs) of + (first, rest) -> (x:first) : (runs p rest) + +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [[a]]) -- List of duplicate groups. One representative from + -- each group appears in the first result + +removeDups _ [] = ([], []) +removeDups _ [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups _ [] = panic "ListSetOps: removeDups" + collect_dups dups_so_far [x] = (dups_so_far, x) + collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x) + +findDupsEq :: (a->a->Bool) -> [a] -> [[a]] +findDupsEq _ [] = [] +findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs + | otherwise = (x:eq_xs) : findDupsEq eq neq_xs + where (eq_xs, neq_xs) = partition (eq x) xs + +equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]] + -- NB: it's *very* important that if we have the input list [a,b,c], + -- where a,b,c all have the same unique, then we get back the list + -- [a,b,c] + -- not + -- [c,b,a] + -- Hence the use of foldr, plus the reversed-args tack_on below +equivClassesByUniq get_uniq xs + = eltsUFM (foldr add emptyUFM xs) + where + add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a] + tack_on old new = new++old diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs new file mode 100644 index 00000000..4e64d6ed --- /dev/null +++ b/compiler/utils/Maybes.hs @@ -0,0 +1,124 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +module Maybes ( + module Data.Maybe, + + MaybeErr(..), -- Instance of Monad + failME, isSuccess, + + orElse, + firstJust, firstJusts, + whenIsJust, + expectJust, + + MaybeT(..), liftMaybeT + ) where + +import Control.Applicative +import Control.Monad +import Data.Maybe + +infixr 4 `orElse` + +{- +************************************************************************ +* * +\subsection[Maybe type]{The @Maybe@ type} +* * +************************************************************************ +-} + +firstJust :: Maybe a -> Maybe a -> Maybe a +firstJust a b = firstJusts [a, b] + +-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or +-- @Nothing@ otherwise. +firstJusts :: [Maybe a] -> Maybe a +firstJusts = msum + +expectJust :: String -> Maybe a -> a +{-# INLINE expectJust #-} +expectJust _ (Just x) = x +expectJust err Nothing = error ("expectJust " ++ err) + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +-- | Flipped version of @fromMaybe@, useful for chaining. +orElse :: Maybe a -> a -> a +orElse = flip fromMaybe + +{- +************************************************************************ +* * +\subsection[MaybeT type]{The @MaybeT@ monad transformer} +* * +************************************************************************ +-} + +newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)} + +instance Functor m => Functor (MaybeT m) where + fmap f x = MaybeT $ fmap (fmap f) $ runMaybeT x + +instance (Monad m, Functor m) => Applicative (MaybeT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (MaybeT m) where + return = MaybeT . return . Just + x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f) + fail _ = MaybeT $ return Nothing + +#if __GLASGOW_HASKELL__ < 710 +-- Pre-AMP change +instance (Monad m, Functor m) => Alternative (MaybeT m) where +#else +instance (Monad m) => Alternative (MaybeT m) where +#endif + empty = mzero + (<|>) = mplus + +instance Monad m => MonadPlus (MaybeT m) where + mzero = MaybeT $ return Nothing + p `mplus` q = MaybeT $ do ma <- runMaybeT p + case ma of + Just a -> return (Just a) + Nothing -> runMaybeT q + +liftMaybeT :: Monad m => m a -> MaybeT m a +liftMaybeT act = MaybeT $ Just `liftM` act + +{- +************************************************************************ +* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +* * +************************************************************************ +-} + +data MaybeErr err val = Succeeded val | Failed err + +instance Functor (MaybeErr err) where + fmap = liftM + +instance Applicative (MaybeErr err) where + pure = return + (<*>) = ap + +instance Monad (MaybeErr err) where + return v = Succeeded v + Succeeded v >>= k = k v + Failed e >>= _ = Failed e + +isSuccess :: MaybeErr err val -> Bool +isSuccess (Succeeded {}) = True +isSuccess (Failed {}) = False + +failME :: err -> MaybeErr err val +failME e = Failed e diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs new file mode 100644 index 00000000..e20178c4 --- /dev/null +++ b/compiler/utils/MonadUtils.hs @@ -0,0 +1,173 @@ + +-- | Utilities related to Monad and Applicative classes +-- Mostly for backwards compatability. + +module MonadUtils + ( Applicative(..) + , (<$>) + + , MonadFix(..) + , MonadIO(..) + + , liftIO1, liftIO2, liftIO3, liftIO4 + + , zipWith3M, zipWith3M_, zipWithAndUnzipM + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M + , mapAccumLM + , mapSndM + , concatMapM + , mapMaybeM + , fmapMaybeM, fmapEitherM + , anyM, allM + , foldlM, foldlM_, foldrM + , maybeMapM + , whenM + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Maybes + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Prelude -- avoid redundant import warning due to AMP + +------------------------------------------------------------------------------- +-- Lift combinators +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +-- | Lift an 'IO' operation with 1 argument into another monad +liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b +liftIO1 = (.) liftIO + +-- | Lift an 'IO' operation with 2 arguments into another monad +liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c +liftIO2 = ((.).(.)) liftIO + +-- | Lift an 'IO' operation with 3 arguments into another monad +liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d +liftIO3 = ((.).((.).(.))) liftIO + +-- | Lift an 'IO' operation with 4 arguments into another monad +liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e +liftIO4 = (((.).(.)).((.).(.))) liftIO + +------------------------------------------------------------------------------- +-- Common functions +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] +zipWith3M _ [] _ _ = return [] +zipWith3M _ _ [] _ = return [] +zipWith3M _ _ _ [] = return [] +zipWith3M f (x:xs) (y:ys) (z:zs) + = do { r <- f x y z + ; rs <- zipWith3M f xs ys zs + ; return $ r:rs + } + +zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () +zipWith3M_ f as bs cs = do { _ <- zipWith3M f as bs cs + ; return () } + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +{-# INLINE zipWithAndUnzipM #-} +-- See Note [flatten_many performance] in TcFlatten for why this +-- pragma is essential. +zipWithAndUnzipM f (x:xs) (y:ys) + = do { (c, d) <- f x y + ; (cs, ds) <- zipWithAndUnzipM f xs ys + ; return (c:cs, d:ds) } +zipWithAndUnzipM _ _ _ = return ([], []) + +-- | mapAndUnzipM for triples +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +mapAndUnzip3M _ [] = return ([],[],[]) +mapAndUnzip3M f (x:xs) = do + (r1, r2, r3) <- f x + (rs1, rs2, rs3) <- mapAndUnzip3M f xs + return (r1:rs1, r2:rs2, r3:rs3) + +mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) +mapAndUnzip4M _ [] = return ([],[],[],[]) +mapAndUnzip4M f (x:xs) = do + (r1, r2, r3, r4) <- f x + (rs1, rs2, rs3, rs4) <- mapAndUnzip4M f xs + return (r1:rs1, r2:rs2, r3:rs3, r4:rs4) + +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining funcction + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- mapAccumLM f s1 xs + return (s2, x' : xs') + +-- | Monadic version of mapSnd +mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapSndM _ [] = return [] +mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +-- | Monadic version of mapMaybe +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + +-- | Monadic version of fmap +fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) +fmapMaybeM _ Nothing = return Nothing +fmapMaybeM f (Just x) = f x >>= (return . Just) + +-- | Monadic version of fmap +fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) +fmapEitherM fl _ (Left a) = fl a >>= (return . Left) +fmapEitherM _ fr (Right b) = fr b >>= (return . Right) + +-- | Monadic version of 'any', aborts the computation at the first @True@ value +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM f (x:xs) = do b <- f x + if b then return True + else anyM f xs + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) + +-- | Monadic version of foldl +foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldlM = foldM + +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ = foldM_ + +-- | Monadic version of foldr +foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a +foldrM _ z [] = return z +foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } + +-- | Monadic version of fmap specialised for Maybe +maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) +maybeMapM _ Nothing = return Nothing +maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs new file mode 100644 index 00000000..4591b559 --- /dev/null +++ b/compiler/utils/OrdList.hs @@ -0,0 +1,116 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +This is useful, general stuff for the Native Code Generator. + +Provide trees (of instructions), so that lists of instructions +can be appended in linear time. +-} + +{-# LANGUAGE CPP #-} +module OrdList ( + OrdList, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, + mapOL, fromOL, toOL, foldrOL, foldlOL +) where + +import Outputable + +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid ( Monoid(..) ) +#endif + +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` + +data OrdList a + = None + | One a + | Many [a] -- Invariant: non-empty + | Cons a (OrdList a) + | Snoc (OrdList a) a + | Two (OrdList a) -- Invariant: non-empty + (OrdList a) -- Invariant: non-empty + +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that + +instance Monoid (OrdList a) where + mempty = nilOL + mappend = appOL + mconcat = concatOL + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a +lastOL :: OrdList a -> a + +nilOL = None +unitOL as = One as +snocOL as b = Snoc as b +consOL a bs = Cons a bs +concatOL aas = foldr appOL None aas + +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + +isNilOL None = True +isNilOL _ = False + +None `appOL` b = b +a `appOL` None = a +One a `appOL` b = Cons a b +a `appOL` One b = Snoc a b +a `appOL` b = Two a b + +fromOL :: OrdList a -> [a] +fromOL a = go a [] + where go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = a : go b acc + go (Snoc a b) acc = go a (b:acc) + go (Two a b) acc = go a (go b acc) + go (Many xs) acc = xs ++ acc + +mapOL :: (a -> b) -> OrdList a -> OrdList b +mapOL _ None = None +mapOL f (One x) = One (f x) +mapOL f (Cons x xs) = Cons (f x) (mapOL f xs) +mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x) +mapOL f (Two x y) = Two (mapOL f x) (mapOL f y) +mapOL f (Many xs) = Many (map f xs) + +instance Functor OrdList where + fmap = mapOL + +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL _ z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Cons x xs) = k x (foldrOL k z xs) +foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL _ z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Cons x xs) = foldlOL k (k z x) xs +foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x +foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2 +foldlOL k z (Many xs) = foldl k z xs + +toOL :: [a] -> OrdList a +toOL [] = None +toOL xs = Many xs diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs new file mode 100644 index 00000000..e350de93 --- /dev/null +++ b/compiler/utils/Outputable.hs @@ -0,0 +1,1029 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} + +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. +module Outputable ( + -- * Type classes + Outputable(..), OutputableBndr(..), + + -- * Pretty printing combinators + SDoc, runSDoc, initSDocContext, + docToSDoc, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, + empty, nest, + char, + text, ftext, ptext, ztext, + int, intWithCommas, integer, float, double, rational, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, paBrackets, + semi, comma, colon, dcolon, space, equals, dot, + arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, forAllLit, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, punctuate, ppWhen, ppUnless, + speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre, + + coloured, PprColour, colType, colCoerc, colDataCon, + colBinder, bold, keyword, + + -- * Converting 'SDoc' into strings and outputing it + printForC, printForAsm, printForUser, printForUserPartWay, + pprCode, mkCodeStyle, + showSDoc, showSDocUnsafe, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showSDocUnqual, showPpr, + renderWithStyle, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsBytes, + pprFastFilePath, + + -- * Controlling the style in which output is printed + BindingSite(..), + + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, + QualifyName(..), queryQual, + sdocWithDynFlags, sdocWithPlatform, + getPprStyle, withPprStyle, withPprStyleDoc, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + ifPprDebug, qualName, qualModule, qualPackage, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, + pprTrace, warnPprTrace, + trace, pgmError, panic, sorry, panicFastInt, assertPanic, + pprDebugAndThen, + ) where + +import {-# SOURCE #-} DynFlags( DynFlags, + targetPlatform, pprUserLength, pprCols, + useUnicode, useUnicodeSyntax, + unsafeGlobalDynFlags ) +import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName ) +import {-# SOURCE #-} OccName( OccName ) +import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) + +import FastString +import FastTypes +import qualified Pretty +import Util +import Platform +import Pretty ( Doc, Mode(..) ) +import Panic + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Map as M +import Data.Int +import qualified Data.IntMap as IM +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import System.IO ( Handle ) +import System.FilePath +import Text.Printf + +import GHC.Fingerprint +import GHC.Show ( showMultiLineString ) + +{- +************************************************************************ +* * +\subsection{The @PprStyle@ data type} +* * +************************************************************************ +-} + +data PprStyle + = PprUser PrintUnqualified Depth + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprDump PrintUnqualified + -- For -ddump-foo; less verbose than PprDebug, but more than PprUser + -- Does not assume tidied code: non-external names + -- are printed with uniques. + + | PprDebug -- Full debugging output + + | PprCode CodeStyle + -- Print code; either C or assembler + +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle + +data Depth = AllTheWay + | PartWay Int -- 0 => stop + + +-- ----------------------------------------------------------------------------- +-- Printing original names + +-- | When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the triple of functions that gets passed around +-- when rendering 'SDoc'. +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} + +-- | given an /original/ name, this function tells you which module +-- name it should be qualified with when printing for the user, if +-- any. For example, given @Control.Exception.catch@, which is in scope +-- as @Exception.catch@, this fuction will return @Just "Exception"@. +-- Note that the return value is a ModuleName, not a Module, because +-- in source code, names are qualified by ModuleNames. +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + +-- | For a given package, we need to know whether to print it with +-- the package key to disambiguate it. +type QueryQualifyPackage = PackageKey -> Bool + +-- See Note [Printing original names] in HscTypes +data QualifyName -- given P:M.T + = NameUnqual -- refer to it as "T" + | NameQual ModuleName -- refer to it as "X.T" for the supplied X + | NameNotInScope1 + -- it is not in scope at all, but M.T is not bound in the current + -- scope, so we can refer to it as "M.T" + | NameNotInScope2 + -- it is not in scope at all, and M.T is already bound in the + -- current scope, so we must refer to it as "P:M.T" + +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) + +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False + +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages + +defaultUserStyle, defaultDumpStyle :: PprStyle + +defaultUserStyle = mkUserStyle neverQualify AllTheWay + -- Print without qualifiers to reduce verbosity, unless -dppr-debug + +defaultDumpStyle | opt_PprStyle_Debug = PprDebug + | otherwise = PprDump neverQualify + +mkDumpStyle :: PrintUnqualified -> PprStyle +mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug + | otherwise = PprDump print_unqual + +defaultErrStyle :: DynFlags -> PprStyle +-- Default style for error messages, when we don't know PrintUnqualified +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +-- NB that -dppr-debug will still get into PprDebug style +defaultErrStyle dflags = mkErrStyle dflags neverQualify + +-- | Style for printing error messages +mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags)) + +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle :: PrintUnqualified -> Depth -> PprStyle +mkUserStyle unqual depth + | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth + +{- +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. + +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. + +************************************************************************ +* * +\subsection{The @SDoc@ data type} +* * +************************************************************************ +-} + +newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocLastColour :: !PprColour + -- ^ The most recently used colour. This allows nesting colours. + , sdocDynFlags :: !DynFlags + } + +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags sty = SDC + { sdocStyle = sty + , sdocLastColour = colReset + , sdocDynFlags = dflags + } + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} + +withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc +withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) + +pprDeeper :: SDoc -> SDoc +pprDeeper d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n)} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))} + _ -> runSDoc d ctx + +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +-- Truncate a list that list that is longer than the current depth +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n)} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx + +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprUser q _} -> + runSDoc doc ctx{sdocStyle = PprUser q depth} + _ -> + runSDoc doc ctx + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithPlatform :: (Platform -> SDoc) -> SDoc +sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) + +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser q _) mod occ = queryQualifyName q mod occ +qualName (PprDump q) mod occ = queryQualifyName q mod occ +qualName _other mod _ = NameQual (moduleName mod) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser q _) m = queryQualifyModule q m +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True + +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _) m = queryQualifyPackage q m +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + +codeStyle :: PprStyle -> Bool +codeStyle (PprCode _) = True +codeStyle _ = False + +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle _other = False + +dumpStyle :: PprStyle -> Bool +dumpStyle (PprDump {}) = True +dumpStyle _other = False + +debugStyle :: PprStyle -> Bool +debugStyle PprDebug = True +debugStyle _other = False + +userStyle :: PprStyle -> Bool +userStyle (PprUser _ _) = True +userStyle _other = False + +ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style +ifPprDebug d = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprDebug} -> runSDoc d ctx + _ -> Pretty.empty + +printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () +printForUser dflags handle unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay))) + +printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc + -> IO () +printForUserPartWay dflags handle d unqual doc + = Pretty.printDoc PageMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d)))) + +-- printForC, printForAsm do what they sound like +printForC :: DynFlags -> Handle -> SDoc -> IO () +printForC dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode CStyle))) + +printForAsm :: DynFlags -> Handle -> SDoc -> IO () +printForAsm dflags handle doc = + Pretty.printDoc LeftMode (pprCols dflags) handle + (runSDoc doc (initSDocContext dflags (PprCode AsmStyle))) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +mkCodeStyle :: CodeStyle -> PprStyle +mkCodeStyle = PprCode + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show +-- showSDoc just blasts it out as a string +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle + +-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be +-- initialised yet. +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +showSDocUnqual :: DynFlags -> SDoc -> String +-- Only used by Haddock +showSDocUnqual dflags sdoc = showSDoc dflags sdoc + +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- Allows caller to specify the PrintUnqualified to use +showSDocForUser dflags unqual doc + = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay) + +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle dflags d PprDebug + +renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String +renderWithStyle dflags sdoc sty + = Pretty.showDoc PageMode (pprCols dflags) $ + runSDoc sdoc (initSDocContext dflags sty) + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: DynFlags -> SDoc -> String +showSDocOneLine dflags d + = Pretty.showDoc OneLineMode (pprCols dflags) $ + runSDoc d (initSDocContext dflags defaultUserStyle) + +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = Pretty.showDoc OneLineMode irrelevantNCols $ + runSDoc d (initSDocContext dflags defaultDumpStyle) + +irrelevantNCols :: Int +-- Used for OneLineMode and LeftMode when number of cols isn't used +irrelevantNCols = 1 + +docToSDoc :: Doc -> SDoc +docToSDoc d = SDoc (\_ -> d) + +empty :: SDoc +char :: Char -> SDoc +text :: String -> SDoc +ftext :: FastString -> SDoc +ptext :: LitString -> SDoc +ztext :: FastZString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c + +text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +ztext s = docToSDoc $ Pretty.ztext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n + +parens, braces, brackets, quotes, quote, + paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc + +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' +paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]") + +cparen :: Bool -> SDoc -> SDoc + +cparen b d = SDoc $ Pretty.cparen b . runSDoc d + +-- 'quotes' encloses something in single quotes... +-- but it omits them if the thing begins or ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d = + sdocWithDynFlags $ \dflags -> + if useUnicode dflags + then char '‘' <> d <> char '’' + else SDoc $ \sty -> + let pp_d = runSDoc d sty + str = show pp_d + in case (str, snocView str) of + (_, Just (_, '\'')) -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d + +semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc +arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine = docToSDoc $ Pretty.ptext (sLit "") +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.ptext (sLit "::")) +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.ptext (sLit "->")) +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.ptext (sLit "<-")) +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.ptext (sLit "=>")) +arrowt = unicodeSyntax (char '↣') (docToSDoc $ Pretty.ptext (sLit ">-")) +larrowt = unicodeSyntax (char '↢') (docToSDoc $ Pretty.ptext (sLit "-<")) +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-")) +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<")) +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace + +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall")) + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> + if useUnicode dflags && useUnicodeSyntax dflags + then unicode + else plain + +nest :: Int -> SDoc -> SDoc +-- ^ Indent 'SDoc' some specified amount +(<>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally without a gap +(<+>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally with a gap between them +($$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically; if there is +-- no vertical overlap it "dovetails" the two onto one line +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) + +hcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally +hsep :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally with a space between each one +vcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' vertically with dovetailing +sep :: [SDoc] -> SDoc +-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits +cat :: [SDoc] -> SDoc +-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits +fsep :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' + + +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] + +hang :: SDoc -- ^ The header + -> Int -- ^ Amount to indent the hung body + -> SDoc -- ^ The hung body, indented and placed below the header + -> SDoc +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) + +punctuate :: SDoc -- ^ The punctuation + -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [SDoc] -- ^ Punctuated list +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +ppWhen False _ = empty + +ppUnless True _ = empty +ppUnless False doc = doc + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour String + +-- Colours + +colType :: PprColour +colType = PprColour "\27[34m" + +colBold :: PprColour +colBold = PprColour "\27[;1m" + +colCoerc :: PprColour +colCoerc = PprColour "\27[34m" + +colDataCon :: PprColour +colDataCon = PprColour "\27[31m" + +colBinder :: PprColour +colBinder = PprColour "\27[32m" + +colReset :: PprColour +colReset = PprColour "\27[0m" + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: PprColour -> SDoc -> SDoc +-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt +coloured col@(PprColour c) sdoc = + SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } -> + let ctx' = ctx{ sdocLastColour = col } in + Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc + +bold :: SDoc -> SDoc +bold = coloured colBold + +keyword :: SDoc -> SDoc +keyword = bold + +{- +************************************************************************ +* * +\subsection[Outputable-class]{The @Outputable@ class} +* * +************************************************************************ +-} + +-- | Class designating that some type has an 'SDoc' representation +class Outputable a where + ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + + ppr = pprPrec 0 + pprPrec _ = ppr + +instance Outputable Char where + ppr c = text [c] + +instance Outputable Bool where + ppr True = ptext (sLit "True") + ppr False = ptext (sLit "False") + +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + +instance Outputable Int where + ppr n = int n + +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + +instance Outputable () where + ppr _ = text "()" + +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + +instance (Outputable a) => Outputable (Set a) where + ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = ptext (sLit "Nothing") + ppr (Just x) = ptext (sLit "Just") <+> ppr x + +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = ptext (sLit "Left") <+> ppr x + ppr (Right y) = ptext (sLit "Right") <+> ppr y + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr (x,y,z) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z ]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + +instance Outputable FastString where + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) + +{- +************************************************************************ +* * +\subsection{The @OutputableBndr@ class} +* * +************************************************************************ +-} + +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +data BindingSite = LambdaBind | CaseBind | LetBind + +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) + +{- +************************************************************************ +* * +\subsection{Random printing helpers} +* * +************************************************************************ +-} + +-- We have 31-bit Chars and will simply use Show instances of Char and String. + +-- | Special combinator for showing character literals. +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) + +-- | Special combinator for showing string literals. +pprHsString :: FastString -> SDoc +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +-- | Special combinator for showing string literals. +pprHsBytes :: ByteString -> SDoc +pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs + in vcat (map text (showMultiLineString escaped)) <> char '#' + where escape :: Word8 -> String + escape w = let c = chr (fromIntegral w) + in if isAscii c + then [c] + else '\\' : show w + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path + +{- +************************************************************************ +* * +\subsection{Other helper functions} +* * +************************************************************************ +-} + +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + +-- | Returns the separated concatenation of the pretty printed things. +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = sep (map ppr xs) + +-- | Returns the comma-separated concatenation of the pretty printed things. +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = sep (punctuate comma (map ppr xs)) + +-- | Returns the comma-separated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' +pprQuotedList :: Outputable a => [a] -> SDoc +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = hsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs) +quotedListWithOr xs = quotedList xs + +{- +************************************************************************ +* * +\subsection{Printing numbers verbally} +* * +************************************************************************ +-} + +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + zeroes | r >= 100 = empty + | r >= 10 = char '0' + | otherwise = ptext (sLit "00") + +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" +speakNth :: Int -> SDoc +speakNth 1 = ptext (sLit "first") +speakNth 2 = ptext (sLit "second") +speakNth 3 = ptext (sLit "third") +speakNth 4 = ptext (sLit "fourth") +speakNth 5 = ptext (sLit "fifth") +speakNth 6 = ptext (sLit "sixth") +speakNth n = hcat [ int n, text suffix ] + where + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" + + last_dig = n `rem` 10 + +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" +speakN :: Int -> SDoc +speakN 0 = ptext (sLit "none") -- E.g. "he has none" +speakN 1 = ptext (sLit "one") -- E.g. "he has one" +speakN 2 = ptext (sLit "two") +speakN 3 = ptext (sLit "three") +speakN 4 = ptext (sLit "four") +speakN 5 = ptext (sLit "five") +speakN 6 = ptext (sLit "six") +speakN n = int n + +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = ptext (sLit "no") <+> d <> char 's' +speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" + +-- | Converts a strictly positive integer into a number of times: +-- +-- > speakNTimes 1 = text "once" +-- > speakNTimes 2 = text "twice" +-- > speakNTimes 4 = text "4 times" +speakNTimes :: Int {- >=1 -} -> SDoc +speakNTimes t | t == 1 = ptext (sLit "once") + | t == 2 = ptext (sLit "twice") + | otherwise = speakN t <+> ptext (sLit "times") + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = ptext (sLit "are") +-- > isOrAre ["Hello"] = ptext (sLit "is") +-- > isOrAre ["Hello", "World"] = ptext (sLit "are") +isOrAre :: [a] -> SDoc +isOrAre [_] = ptext (sLit "is") +isOrAre _ = ptext (sLit "are") + +{- +************************************************************************ +* * +\subsection{Error handling} +* * +************************************************************************ +-} + +pprPanic :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in GHC" +pprPanic = panicDoc + +pprSorry :: String -> SDoc -> a +-- ^ Throw an exception saying "this isn't finished yet" +pprSorry = sorryDoc + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pprPgmError = pgmErrorDoc + + +pprTrace :: String -> SDoc -> a -> a +-- ^ If debug output is on, show some 'SDoc' on the screen +pprTrace str doc x + | opt_NoDebugOutput = x + | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x + +pprPanicFastInt :: String -> SDoc -> FastInt +-- ^ Specialization of pprPanic that can be safely used with 'FastInt' +pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg + +warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a +-- ^ Just warn about an assertion failure, recording the given file and line number. +-- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x +warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x + = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x + where + heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] + +assertPprPanic :: String -> Int -> SDoc -> a +-- ^ Panic with an assertation failure, recording the given file and line number. +-- Should typically be accessed with the ASSERT family of macros +assertPprPanic file line msg + = pprPanic "ASSERT failed!" doc + where + doc = sep [ hsep [ text "file", text file + , text "line", int line ] + , msg ] + +pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (showSDocDump dflags doc) + where + doc = sep [heading, nest 2 pretty_msg] diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot new file mode 100644 index 00000000..1c15a698 --- /dev/null +++ b/compiler/utils/Outputable.hs-boot @@ -0,0 +1,3 @@ +module Outputable where + +data SDoc diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs new file mode 100644 index 00000000..b33ccbac --- /dev/null +++ b/compiler/utils/Pair.hs @@ -0,0 +1,50 @@ +{- +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. +-} + +{-# LANGUAGE CPP #-} + +module Pair ( Pair(..), unPair, toPair, swap ) where + +#include "HsVersions.h" + +import Outputable +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +import Data.Foldable +import Data.Monoid +import Data.Traversable +#endif + +data Pair a = Pair { pFst :: a, pSnd :: a } +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogenous* +-- Functor instance, so you can easily apply the same function +-- to both components +instance Functor Pair where + fmap f (Pair x y) = Pair (f x) (f y) + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Foldable Pair where + foldMap f (Pair x y) = f x `mappend` f y + +instance Traversable Pair where + traverse f (Pair x y) = Pair <$> f x <*> f y + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs new file mode 100644 index 00000000..bfb9df3a --- /dev/null +++ b/compiler/utils/Panic.hs @@ -0,0 +1,307 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + +Defines basic functions for printing error messages. + +It's hard to put these functions anywhere else without causing +some unnecessary loops in the module dependency graph. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} + +module Panic ( + GhcException(..), showGhcException, + throwGhcException, throwGhcExceptionIO, + handleGhcException, + progName, + pgmError, + + panic, sorry, panicFastInt, assertPanic, trace, + panicDoc, sorryDoc, panicDocFastInt, pgmErrorDoc, + + Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, + + installSignalHandlers, + pushInterruptTargetThread, popInterruptTargetThread +) where +#include "HsVersions.h" + +import {-# SOURCE #-} Outputable (SDoc) + +import Config +import FastTypes +import Exception + +import Control.Concurrent +import Data.Dynamic +import Debug.Trace ( trace ) +import System.IO.Unsafe +import System.Exit +import System.Environment + +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#endif + +#if defined(mingw32_HOST_OS) +import GHC.ConsoleHandler +#endif + +import GHC.Stack +import System.Mem.Weak ( Weak, deRefWeak ) + +-- | GHC's own exception type +-- error messages all take the form: +-- +-- @ +-- : +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- ="ghc". All of the error types below correspond to +-- a of "ghc", except for ProgramError (where the string is +-- assumed to contain a location already, so we don't print one). + +data GhcException + = PhaseFailed String -- name of phase + ExitCode -- an external phase (eg. cpp) failed + + -- | Some other fatal signal (SIGHUP,SIGTERM) + | Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + | PprPanic String SDoc + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + | PprSorry String SDoc + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String + | PprProgramError String SDoc + deriving (Typeable) + +instance Exception GhcException + +instance Show GhcException where + showsPrec _ e@(ProgramError _) = showGhcException e + showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e + showsPrec _ e = showString progName . showString ": " . showGhcException e + + +-- | The name of this GHC. +progName :: String +progName = unsafePerformIO (getProgName) +{-# NOINLINE progName #-} + + +-- | Short usage information to display when we are given the wrong cmd line arguments. +short_usage :: String +short_usage = "Usage: For basic information, try the `--help' option." + + +-- | Show an exception as a string. +showException :: Exception e => e -> String +showException = show + +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs + +-- | Append a description of the given exception to this string. +showGhcException :: GhcException -> String -> String +showGhcException exception + = case exception of + UsageError str + -> showString str . showChar '\n' . showString short_usage + + PhaseFailed phase code + -> showString "phase `" . showString phase . + showString "' failed (exitcode = " . shows (int_code code) . + showString ")" + + CmdLineError str -> showString str + PprProgramError str _ -> + showGhcException (ProgramError (str ++ "\n<
>")) + ProgramError str -> showString str + InstallationError str -> showString str + Signal n -> showString "signal: " . shows n + + PprPanic s _ -> + showGhcException (Panic (s ++ "\n<
>")) + Panic s + -> showString $ + "panic! (the 'impossible' happened)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n\n" + ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n" + + PprSorry s _ -> + showGhcException (Sorry (s ++ "\n<
>")) + Sorry s + -> showString $ + "sorry! (unimplemented feature or known bug)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n" + + where int_code code = + case code of + ExitSuccess -> (0::Int) + ExitFailure x -> x + + +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +throwGhcExceptionIO :: GhcException -> IO a +throwGhcExceptionIO = Exception.throwIO + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = ghandle + + +-- | Panics and asserts. +panic, sorry, pgmError :: String -> a +panic x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwGhcException (Panic x) + else throwGhcException (Panic (x ++ '\n' : renderStack stack)) + +sorry x = throwGhcException (Sorry x) +pgmError x = throwGhcException (ProgramError x) + +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + + +-- | Panic while pretending to return an unboxed int. +-- You can't use the regular panic functions in expressions +-- producing unboxed ints because they have the wrong kind. +panicFastInt :: String -> FastInt +panicFastInt s = case (panic s) of () -> _ILIT(0) + +panicDocFastInt :: String -> SDoc -> FastInt +panicDocFastInt s d = case (panicDoc s d) of () -> _ILIT(0) + + +-- | Throw an failed assertion exception for a given filename and line number. +assertPanic :: String -> Int -> a +assertPanic file line = + Exception.throw (Exception.AssertionFailed + ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) + + +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) + + +-- | Install standard signal handlers for catching ^C, which just throw an +-- exception in the target thread. The current target thread is the +-- thread at the head of the list in the MVar passed to +-- installSignalHandlers. +installSignalHandlers :: IO () +installSignalHandlers = do + main_thread <- myThreadId + pushInterruptTargetThread main_thread + + let + interrupt_exn = (toException UserInterrupt) + + interrupt = do + mt <- peekInterruptTargetThread + case mt of + Nothing -> return () + Just t -> throwTo t interrupt_exn + + -- +#if !defined(mingw32_HOST_OS) + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing + -- see #3656; in the future we should install these automatically for + -- all Haskell programs in the same way that we install a ^C handler. + let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing + _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + _ <- installHandler (Catch sig_handler) + return () +#endif + +{-# NOINLINE interruptTargetThread #-} +interruptTargetThread :: MVar [Weak ThreadId] +interruptTargetThread = unsafePerformIO (newMVar []) + +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + wtid <- mkWeakThreadId tid + modifyMVar_ interruptTargetThread $ return . (wtid :) + +peekInterruptTargetThread :: IO (Maybe ThreadId) +peekInterruptTargetThread = + withMVar interruptTargetThread $ loop + where + loop [] = return Nothing + loop (t:ts) = do + r <- deRefWeak t + case r of + Nothing -> loop ts + Just t -> return (Just t) + +popInterruptTargetThread :: IO () +popInterruptTargetThread = + modifyMVar_ interruptTargetThread $ + \tids -> return $! case tids of [] -> [] + (_:ts) -> ts diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs new file mode 100644 index 00000000..8f9a8deb --- /dev/null +++ b/compiler/utils/Platform.hs @@ -0,0 +1,155 @@ + +-- | A description of the platform we're compiling for. +-- +module Platform ( + Platform(..), + Arch(..), + OS(..), + ArmISA(..), + ArmISAExt(..), + ArmABI(..), + + target32Bit, + isARM, + osElfTarget, + osMachOTarget, + platformUsesFrameworks, + platformBinariesAreStaticLibs, +) + +where + +-- | Contains enough information for the native code generator to emit +-- code for this platform. +data Platform + = Platform { + platformArch :: Arch, + platformOS :: OS, + -- Word size in bytes (i.e. normally 4 or 8, + -- for 32bit and 64bit platforms respectively) + platformWordSize :: {-# UNPACK #-} !Int, + platformUnregisterised :: Bool, + platformHasGnuNonexecStack :: Bool, + platformHasIdentDirective :: Bool, + platformHasSubsectionsViaSymbols :: Bool, + platformIsCrossCompiling :: Bool + } + deriving (Read, Show, Eq) + + +-- | Architectures that the native code generator knows about. +-- TODO: It might be nice to extend these constructors with information +-- about what instruction set extensions an architecture might support. +-- +data Arch + = ArchUnknown + | ArchX86 + | ArchX86_64 + | ArchPPC + | ArchPPC_64 + | ArchSPARC + | ArchARM + { armISA :: ArmISA + , armISAExt :: [ArmISAExt] + , armABI :: ArmABI + } + | ArchARM64 + | ArchAlpha + | ArchMipseb + | ArchMipsel + | ArchJavaScript + deriving (Read, Show, Eq) + +isARM :: Arch -> Bool +isARM (ArchARM {}) = True +isARM ArchARM64 = True +isARM _ = False + +-- | Operating systems that the native code generator knows about. +-- Having OSUnknown should produce a sensible default, but no promises. +data OS + = OSUnknown + | OSLinux + | OSDarwin + | OSiOS + | OSSolaris2 + | OSMinGW32 + | OSFreeBSD + | OSDragonFly + | OSOpenBSD + | OSNetBSD + | OSKFreeBSD + | OSHaiku + | OSOsf3 + | OSQNXNTO + | OSAndroid + deriving (Read, Show, Eq) + +-- | ARM Instruction Set Architecture, Extensions and ABI +-- +data ArmISA + = ARMv5 + | ARMv6 + | ARMv7 + deriving (Read, Show, Eq) + +data ArmISAExt + = VFPv2 + | VFPv3 + | VFPv3D16 + | NEON + | IWMMX2 + deriving (Read, Show, Eq) + +data ArmABI + = SOFT + | SOFTFP + | HARD + deriving (Read, Show, Eq) + +target32Bit :: Platform -> Bool +target32Bit p = platformWordSize p == 4 + +-- | This predicates tells us whether the OS supports ELF-like shared libraries. +osElfTarget :: OS -> Bool +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSDragonFly = True +osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSiOS = False +osElfTarget OSMinGW32 = False +osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = True +osElfTarget OSOsf3 = False -- I don't know if this is right, but as + -- per comment below it's safe +osElfTarget OSQNXNTO = False +osElfTarget OSAndroid = True +osElfTarget OSUnknown = False + -- Defaulting to False is safe; it means don't rely on any + -- ELF-specific functionality. It is important to have a default for + -- portability, otherwise we have to answer this question for every + -- new platform we compile on (even unreg). + +-- | This predicate tells us whether the OS support Mach-O shared libraries. +osMachOTarget :: OS -> Bool +osMachOTarget OSDarwin = True +osMachOTarget _ = False + +osUsesFrameworks :: OS -> Bool +osUsesFrameworks OSDarwin = True +osUsesFrameworks OSiOS = True +osUsesFrameworks _ = False + +platformUsesFrameworks :: Platform -> Bool +platformUsesFrameworks = osUsesFrameworks . platformOS + +osBinariesAreStaticLibs :: OS -> Bool +osBinariesAreStaticLibs OSiOS = True +osBinariesAreStaticLibs _ = False + +platformBinariesAreStaticLibs :: Platform -> Bool +platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS + diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs new file mode 100644 index 00000000..5e441838 --- /dev/null +++ b/compiler/utils/Pretty.hs @@ -0,0 +1,1024 @@ +{- +********************************************************************************* +* * +* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * +* * +* based on "The Design of a Pretty-printing Library" * +* in Advanced Functional Programming, * +* Johan Jeuring and Erik Meijer (eds), LNCS 925 * +* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * +* * +* Heavily modified by Simon Peyton Jones, Dec 96 * +* * +********************************************************************************* + +Version 3.0 28 May 1997 + * Cured massive performance bug. If you write + + foldl <> empty (map (text.show) [1..10000]) + + you get quadratic behaviour with V2.0. Why? For just the same reason as you get + quadratic behaviour with left-associated (++) chains. + + This is really bad news. One thing a pretty-printer abstraction should + certainly guarantee is insensivity to associativity. It matters: suddenly + GHC's compilation times went up by a factor of 100 when I switched to the + new pretty printer. + + I fixed it with a bit of a hack (because I wanted to get GHC back on the + road). I added two new constructors to the Doc type, Above and Beside: + + <> = Beside + $$ = Above + + Then, where I need to get to a "TextBeside" or "NilAbove" form I "force" + the Doc to squeeze out these suspended calls to Beside and Above; but in so + doing I re-associate. It's quite simple, but I'm not satisfied that I've done + the best possible job. I'll send you the code if you are interested. + + * Added new exports: + punctuate, hang + int, integer, float, double, rational, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + * fullRender's type signature has changed. Rather than producing a string it + now takes an extra couple of arguments that tells it how to glue fragments + of output together: + + fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + + The "fragments" are encapsulated in the TextDetails data type: + data TextDetails = Chr Char + | Str String + | PStr FastString + + The Chr and Str constructors are obvious enough. The PStr constructor has a packed + string (FastString) inside it. It's generated by using the new "ptext" export. + + An advantage of this new setup is that you can get the renderer to do output + directly (by passing in a function of type (TextDetails -> IO () -> IO ()), + rather than producing a string that you then print. + + +Version 2.0 24 April 1997 + * Made empty into a left unit for <> as well as a right unit; + it is also now true that + nest k empty = empty + which wasn't true before. + + * Fixed an obscure bug in sep that occasionally gave very weird behaviour + + * Added $+$ + + * Corrected and tidied up the laws and invariants + +====================================================================== +Relative to John's original paper, there are the following new features: + +1. There's an empty document, "empty". It's a left and right unit for + both <> and $$, and anywhere in the argument list for + sep, hcat, hsep, vcat, fcat etc. + + It is Really Useful in practice. + +2. There is a paragraph-fill combinator, fsep, that's much like sep, + only it keeps fitting things on one line until it can't fit any more. + +3. Some random useful extra combinators are provided. + <+> puts its arguments beside each other with a space between them, + unless either argument is empty in which case it returns the other + + + hcat is a list version of <> + hsep is a list version of <+> + vcat is a list version of $$ + + sep (separate) is either like hsep or like vcat, depending on what fits + + cat is behaves like sep, but it uses <> for horizontal conposition + fcat is behaves like fsep, but it uses <> for horizontal conposition + + These new ones do the obvious things: + char, semi, comma, colon, space, + parens, brackets, braces, + quotes, quote, doubleQuotes + +4. The "above" combinator, $$, now overlaps its two arguments if the + last line of the top argument stops before the first line of the second begins. + For example: text "hi" $$ nest 5 "there" + lays out as + hi there + rather than + hi + there + + There are two places this is really useful + + a) When making labelled blocks, like this: + Left -> code for left + Right -> code for right + LongLongLongLabel -> + code for longlonglonglabel + The block is on the same line as the label if the label is + short, but on the next line otherwise. + + b) When laying out lists like this: + [ first + , second + , third + ] + which some people like. But if the list fits on one line + you want [first, second, third]. You can't do this with + John's original combinators, but it's quite easy with the + new $$. + + The combinator $+$ gives the original "never-overlap" behaviour. + +5. Several different renderers are provided: + * a standard one + * one that uses cut-marks to avoid deeply-nested documents + simply piling up in the right-hand margin + * one that ignores indentation (fewer chars output; good for machines) + * one that ignores indentation and newlines (ditto, only more so) + +6. Numerous implementation tidy-ups + Use of unboxed data types to speed up the implementation +-} + +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} + +module Pretty ( + Doc, -- Abstract + Mode(..), TextDetails(..), + + empty, isEmpty, nest, + + char, text, ftext, ptext, ztext, zeroWidthText, + int, integer, float, double, rational, + parens, brackets, braces, quotes, quote, doubleQuotes, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen, + + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + + hang, punctuate, + + fullRender, printDoc, printDoc_, showDoc, + bufLeftRender -- performance hack + ) where + +import BufWrite +import FastString +import FastTypes +import Panic +import Numeric (fromRat) +import System.IO + +--for a RULES +import GHC.Base ( unpackCString# ) +import GHC.Exts ( Int# ) +import GHC.Ptr ( Ptr(..) ) + +-- Don't import Util( assertPanic ) because it makes a loop in the module structure + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + +-- Disable ASSERT checks; they are expensive! +#define LOCAL_ASSERT(x) + +{- +********************************************************* +* * +\subsection{The interface} +* * +********************************************************* + +The primitive @Doc@ values +-} + +empty :: Doc +isEmpty :: Doc -> Bool +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc + +text :: String -> Doc +char :: Char -> Doc + +semi, comma, colon, space, equals :: Doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc + +parens, brackets, braces :: Doc -> Doc +quotes, quote, doubleQuotes :: Doc -> Doc + +int :: Int -> Doc +integer :: Integer -> Doc +float :: Float -> Doc +double :: Double -> Doc +rational :: Rational -> Doc + +-- Combining @Doc@ values + +(<>) :: Doc -> Doc -> Doc -- Beside +hcat :: [Doc] -> Doc -- List version of <> +(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space +hsep :: [Doc] -> Doc -- List version of <+> + +($$) :: Doc -> Doc -> Doc -- Above; if there is no + -- overlap it "dovetails" the two +vcat :: [Doc] -> Doc -- List version of $$ + +cat :: [Doc] -> Doc -- Either hcat or vcat +sep :: [Doc] -> Doc -- Either hsep or vcat +fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat +fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep + +nest :: Int -> Doc -> Doc -- Nested + +-- GHC-specific ones. + +hang :: Doc -> Int -> Doc -> Doc +punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] + +-- Displaying @Doc@ values. + +instance Show Doc where + showsPrec _ doc cont = showDocPlus PageMode 100 doc cont + +fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + +data Mode = PageMode -- Normal + | ZigZagMode -- With zig-zag cuts + | LeftMode -- No indentation, infinitely long lines + | OneLineMode -- All on one line + +{- +********************************************************* +* * +\subsection{The @Doc@ calculus} +* * +********************************************************* + +The @Doc@ combinators satisfy the following laws: +\begin{verbatim} +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k z <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + + - Note the side condition on ! It is this that + makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y +\end{verbatim} + + +You might think that the following verion of would +be neater: +\begin{verbatim} +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) +\end{verbatim} +But it doesn't work, for if x=empty, we would have +\begin{verbatim} + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +\end{verbatim} + + + +********************************************************* +* * +\subsection{Simple derived definitions} +* * +********************************************************* +-} + +semi = char ';' +colon = char ':' +comma = char ',' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show (fromRat n :: Double)) +--rational n = text (show (fromRationalX n)) -- _showRational 30 n) + +quotes p = char '`' <> p <> char '\'' +quote p = char '\'' <> p +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +cparen :: Bool -> Doc -> Doc +cparen True = parens +cparen False = id + +hcat = foldr (<>) empty +hsep = foldr (<+>) empty +vcat = foldr ($$) empty + +hang d1 n d2 = sep [d1, nest n d2] + +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +{- +********************************************************* +* * +\subsection{The @Doc@ data type} +* * +********************************************************* + +A @Doc@ represents a {\em set} of layouts. A @Doc@ with +no occurrences of @Union@ or @NoDoc@ represents just one layout. +-} + +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside !TextDetails FastInt Doc -- text s <> x + | Nest FastInt Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside + + +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = beside p g (reduceDoc q) +reduceDoc (Above p g q) = above p g (reduceDoc q) +reduceDoc p = p + + +data TextDetails = Chr {-#UNPACK#-}!Char + | Str String + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated + -- array of bytes + +space_text :: TextDetails +space_text = Chr ' ' +nl_text :: TextDetails +nl_text = Chr '\n' + +{- +Here are the invariants: +\begin{itemize} +\item +The argument of @NilAbove@ is never @Empty@. Therefore +a @NilAbove@ occupies at least two lines. + +\item +The arugment of @TextBeside@ is never @Nest@. + +\item +The layouts of the two arguments of @Union@ both flatten to the same string. + +\item +The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +\item +The right argument of a union cannot be equivalent to the empty set (@NoDoc@). +If the left argument of a union is equivalent to the empty set (@NoDoc@), +then the @NoDoc@ appears in the first line. + +\item +An empty document is always represented by @Empty@. +It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +\item +The first line of every layout in the left argument of @Union@ +is longer than the first line of any layout in the right argument. +(1) ensures that the left argument has a first line. In view of (3), +this invariant means that the right argument must have at least two +lines. +\end{itemize} +-} + +-- Arg of a NilAbove is always an RDoc +nilAbove_ :: Doc -> Doc +nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p + where + _ok Empty = False + _ok _ = True + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> FastInt -> Doc -> Doc +textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p) + where + _ok (Nest _ _) = False + _ok _ = True + +-- Arg of Nest is always an RDoc +nest_ :: FastInt -> Doc -> Doc +nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p) + where + _ok Empty = False + _ok _ = True + +-- Args of union are always RDocs +union_ :: Doc -> Doc -> Doc +union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q) + where + _ok (TextBeside _ _ _) = True + _ok (NilAbove _) = True + _ok (Union _ _) = True + _ok _ = False + +{- +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) + + + +********************************************************* +* * +\subsection{@empty@, @text@, @nest@, @union@} +* * +********************************************************* +-} + +empty = Empty + +isEmpty Empty = True +isEmpty _ = False + +char c = textBeside_ (Chr c) (_ILIT(1)) Empty + +text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty} +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +ftext :: FastString -> Doc +ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} +ptext :: LitString -> Doc +ptext s = case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} +ztext :: FastZString -> Doc +ztext s = case iUnbox (lengthFZS s) of {sl -> textBeside_ (ZStr s) sl Empty} +zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty + +-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the +-- intermediate packing/unpacking of the string. +{-# RULES + "text/str" forall a. text (unpackCString# a) = ptext (Ptr a) + #-} + +nest k p = mkNest (iUnbox k) (reduceDoc p) -- Externally callable version + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int# -> Doc -> Doc +mkNest k (Nest k1 p) = mkNest (k +# k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest k p | k ==# _ILIT(0) = p -- Worth a try! +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +{- +********************************************************* +* * +\subsection{Vertical composition @$$@} +* * +********************************************************* +-} + +p $$ q = Above p False q +($+$) :: Doc -> Doc -> Doc +p $+$ q = Above p True q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q) +above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q) + +aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc +-- Specfication: aboveNest p g k q = p $g$ (nest k q) + +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k -# sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest _ _ _ _ = panic "aboveNest: Unhandled case" + +nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) + +nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q + +nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap + = textBeside_ (Str (spaces k)) k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + +{- +********************************************************* +* * +\subsection{Horizontal composition @<>@} +* * +********************************************************* +-} + +p <> q = Beside p False q +p <+> q = Beside p True q + +beside :: Doc -> Bool -> RDoc -> RDoc +-- Specification: beside g p q = p q + +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty +beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 + [ && (op1 == <> || op1 == <+>) ] -} + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above _ _ _) g q = let d = reduceDoc p in d `seq` beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl $! rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +nilBeside :: Bool -> RDoc -> RDoc +-- Specification: text "" <> nilBeside g p +-- = text "" p + +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p + | otherwise = p + +{- +********************************************************* +* * +\subsection{Separate, @sep@, Hughes version} +* * +********************************************************* +-} + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +sep = sepX True -- Separate with spaces +cat = sepX False -- Don't + +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) + +sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys + `union_` + (aboveNest q False k (reduceDoc (vcat ys))) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k -# n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys) +sep1 _ _ _ _ = panic "sep1: Unhandled case" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests + +sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc +sepNB g (Nest _ p) k ys = sepNB g p k ys + +sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) + `mkUnion` + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys + +sepNB g p k ys = sep1 g p k ys + +{- +********************************************************* +* * +\subsection{@fill@} +* * +********************************************************* +-} + +fsep = fill True +fcat = fill False + +-- Specification: +-- fill [] = empty +-- fill [p] = p +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps)) +-- `union` +-- p1 $$ fill ps + +fill :: Bool -> [Doc] -> Doc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps + + +fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys + `union_` + (aboveNest q False k (fill g ys)) + +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k -# n) ys) + +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys) +fill1 _ _ _ _ = panic "fill1: Unhandled case" + +fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc +fillNB g (Nest _ p) k ys = fillNB g p k ys +fillNB _ Empty _ [] = Empty +fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) + `mkUnion` + nilAboveNest False k (fill g (y:ys)) + where + !k1 | g = k -# _ILIT(1) + | otherwise = k + +fillNB g p k ys = fill1 g p k ys + +{- +********************************************************* +* * +\subsection{Selecting the best layout} +* * +********************************************************* +-} + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! + +best w_ r_ p + = get (iUnbox w_) p + where + !r = iUnbox r_ + get :: FastInt -- (Remaining) width of line + -> Doc -> Doc + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w -# k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ _ = panic "best/get: Unhandled case" + + get1 :: FastInt -- (Remaining) width of line + -> FastInt -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w -# sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ _ = panic "best/get1: Unhandled case" + +nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc +nicest w r p q = nicest1 w r (_ILIT(0)) p q +nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc +nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p + | otherwise = q + +fits :: FastInt -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available + +fits n _ | n <# _ILIT(0) = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n -# sl) p +fits _ _ = panic "fits: Unhandled case" + +{- +@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. +@first@ returns its first argument if it is non-empty, otherwise its second. +-} + +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p + | otherwise = q + +nonEmptySet :: Doc -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True -- NoDoc always in first line +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet _ = panic "nonEmptySet: Unhandled case" + +-- @oneLiner@ returns the one-line members of the given set of @Doc@s. + +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner _ = panic "oneLiner: Unhandled case" + +{- +********************************************************* +* * +\subsection{Displaying the best layout} +* * +********************************************************* +-} + +showDocPlus :: Mode -> Int -> Doc -> String -> String +showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc + +showDoc :: Mode -> Int -> Doc -> String +showDoc mode cols doc = showDocPlus mode cols doc "" + +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (ZStr s1) s2 = zString s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + +fullRender OneLineMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union _ q) = lay q -- Second arg can't be NoDoc + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on + -- first line + lay (TextBeside s _ p) = s `txt` lay p + lay _ = panic "fullRender/OneLineMode/lay: Unhandled case" + +fullRender LeftMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = lay (first p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s _ p) = s `txt` lay p + lay _ = panic "fullRender/LeftMode/lay: Unhandled case" + +fullRender mode line_length ribbons_per_line txt end doc + = display mode line_length ribbon_length txt end best_doc + where + best_doc = best hacked_line_length ribbon_length (reduceDoc doc) + + hacked_line_length, ribbon_length :: Int + ribbon_length = round (fromIntegral line_length / ribbons_per_line) + hacked_line_length = case mode of + ZigZagMode -> maxBound + _ -> line_length + +display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t +display mode page_width ribbon_width txt end doc + = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width -> + case gap_width `quotFastInt` _ILIT(2) of { shift -> + let + lay k (Nest k1 p) = lay (k +# k1) p + lay _ Empty = end + + lay k (NilAbove p) = nl_text `txt` lay k p + + lay k (TextBeside s sl p) + = case mode of + ZigZagMode | k >=# gap_width + -> nl_text `txt` ( + Str (multi_ch shift '/') `txt` ( + nl_text `txt` ( + lay1 (k -# shift) s sl p))) + + | k <# _ILIT(0) + -> nl_text `txt` ( + Str (multi_ch shift '\\') `txt` ( + nl_text `txt` ( + lay1 (k +# shift) s sl p ))) + + _ -> lay1 k s sl p + lay _ _ = panic "display/lay: Unhandled case" + + lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p) + + lay2 k (NilAbove p) = nl_text `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p) + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ _ = panic "display/lay2: Unhandled case" + + -- optimise long indentations using LitString chunks of 8 spaces + indent n r | n >=# _ILIT(8) = LStr (sLit " ") (_ILIT(8)) `txt` + indent (n -# _ILIT(8)) r + | otherwise = Str (spaces n) `txt` r + in + lay (_ILIT(0)) doc + }} + +cant_fail :: a +cant_fail = error "easy_display: NoDoc" + +multi_ch :: Int# -> Char -> String +multi_ch n ch | n <=# _ILIT(0) = "" + | otherwise = ch : multi_ch (n -# _ILIT(1)) ch + +spaces :: Int# -> String +spaces n | n <=# _ILIT(0) = "" + | otherwise = ' ' : spaces (n -# _ILIT(1)) + +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc + = do { printLeftRender hdl doc; hFlush hdl } +printDoc_ mode pprCols hdl doc + = do { fullRender mode pprCols 1.5 put done doc ; + hFlush hdl } + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s l) next = hPutLitString hdl s l >> next + + done = return () -- hPutChar hdl '\n' + + -- some versions of hPutBuf will barf if the length is zero +hPutLitString :: Handle -> Ptr a -> Int# -> IO () +hPutLitString handle a l = if l ==# _ILIT(0) + then return () + else hPutBuf handle a (iBox l) + +-- Printing output in LeftMode is performance critical: it's used when +-- dumping C and assembly output, so we allow ourselves a few dirty +-- hacks: +-- +-- (1) we specialise fullRender for LeftMode with IO output. +-- +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. +-- +-- (3) a few hacks in layLeft below to convince GHC to generate the right +-- code. + +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = do + b <- newBufHandle hdl + bufLeftRender b doc + bFlush b + +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + +-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand +-- this function with the IO state lambda. Otherwise we end up with +-- closures in all the case branches. +layLeft :: BufHandle -> Doc -> IO () +layLeft b _ | b `seq` False = undefined -- make it strict in b +layLeft _ NoDoc = cant_fail +layLeft b (Union p q) = return () >> layLeft b (first p q) +layLeft b (Nest _ p) = return () >> layLeft b p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p + where + put b _ | b `seq` False = undefined + put b (Chr c) = bPutChar b c + put b (Str s) = bPutStr b s + put b (PStr s) = bPutFS b s + put b (ZStr s) = bPutFZS b s + put b (LStr s l) = bPutLitString b s l +layLeft _ _ = panic "layLeft: Unhandled case" diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs new file mode 100644 index 00000000..b1576a08 --- /dev/null +++ b/compiler/utils/Serialized.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Serialized values + +module Serialized ( + -- * Main Serialized data type + Serialized, + seqSerialized, + + -- * Going into and out of 'Serialized' + toSerialized, fromSerialized, + + -- * Handy serialization functions + serializeWithData, deserializeWithData, + ) where + +import Binary +import Outputable +import FastString +import Util + +import Data.Bits +import Data.Word ( Word8 ) + +import Data.Data + + +-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types +data Serialized = Serialized TypeRep [Word8] + +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type) + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) + +-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later +toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized +toSerialized serialize what = Serialized (typeOf what) (serialize what) + +-- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. +-- Otherwise return @Nothing@. +fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a +fromSerialized deserialize (Serialized the_type bytes) + | the_type == typeOf (undefined :: a) = Just (deserialize bytes) + | otherwise = Nothing + +-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms +seqSerialized :: Serialized -> () +seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () + + +-- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' +serializeWithData :: Data a => a -> [Word8] +serializeWithData what = serializeWithData' what [] + +serializeWithData' :: Data a => a -> [Word8] -> [Word8] +serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a)) + (\x -> (serializeConstr (constrRep (toConstr what)), x)) + what + +-- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData' +deserializeWithData :: Data a => [Word8] -> a +deserializeWithData = snd . deserializeWithData' + +deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a) +deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes -> + gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b)) + (\x -> (bytes, x)) + (repConstr (dataTypeOf (undefined :: a)) constr_rep) + + +serializeConstr :: ConstrRep -> [Word8] -> [Word8] +serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix +serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i +serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r +serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c + + +deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a +deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> + case constr_ix of + 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix) + 2 -> deserializeInteger bytes $ \i -> k (IntConstr i) + 3 -> deserializeRational bytes $ \r -> k (FloatConstr r) + 4 -> deserializeChar bytes $ \c -> k (CharConstr c) + x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes + + +#if __GLASGOW_HASKELL__ < 707 +serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8] +serializeFixedWidthNum what = go (bitSize what) what +#else +serializeFixedWidthNum :: forall a. (Num a, Integral a, FiniteBits a) => a -> [Word8] -> [Word8] +serializeFixedWidthNum what = go (finiteBitSize what) what +#endif + where + go :: Int -> a -> [Word8] -> [Word8] + go size current rest + | size <= 0 = rest + | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest + +#if __GLASGOW_HASKELL__ < 707 +deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b +deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k +#else +deserializeFixedWidthNum :: forall a b. (Num a, Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b +deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k +#endif + where + go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b + go size bytes k + | size <= 0 = k 0 bytes + | otherwise = case bytes of + (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte)) + [] -> error "deserializeFixedWidthNum: unexpected end of stream" + + +serializeEnum :: (Enum a) => a -> [Word8] -> [Word8] +serializeEnum = serializeInt . fromEnum + +deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b +deserializeEnum bytes k = deserializeInt bytes (k . toEnum) + + +serializeWord8 :: Word8 -> [Word8] -> [Word8] +serializeWord8 x = (x:) + +deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a +deserializeWord8 (byte:bytes) k = k byte bytes +deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream" + + +serializeInt :: Int -> [Word8] -> [Word8] +serializeInt = serializeFixedWidthNum + +deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a +deserializeInt = deserializeFixedWidthNum + + +serializeRational :: (Real a) => a -> [Word8] -> [Word8] +serializeRational = serializeString . show . toRational + +deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b +deserializeRational bytes k = deserializeString bytes (k . fromRational . read) + + +serializeInteger :: Integer -> [Word8] -> [Word8] +serializeInteger = serializeString . show + +deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a +deserializeInteger bytes k = deserializeString bytes (k . read) + + +serializeChar :: Char -> [Word8] -> [Word8] +serializeChar = serializeString . show + +deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a +deserializeChar bytes k = deserializeString bytes (k . read) + + +serializeString :: String -> [Word8] -> [Word8] +serializeString = serializeList serializeEnum + +deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a +deserializeString = deserializeList deserializeEnum + + +serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8] +serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs) + +deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c) + -> [Word8] -> ([a] -> [Word8] -> b) -> b +deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k + where + go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b + go len bytes k + | len <= 0 = k [] bytes + | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:))) + diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs new file mode 100644 index 00000000..73468416 --- /dev/null +++ b/compiler/utils/State.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE UnboxedTuples, CPP #-} + +module State where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +newtype State s a = State { runState' :: s -> (# a, s #) } + +instance Functor (State s) where + fmap f m = State $ \s -> case runState' m s of + (# r, s' #) -> (# f r, s' #) + +instance Applicative (State s) where + pure x = State $ \s -> (# x, s #) + m <*> n = State $ \s -> case runState' m s of + (# f, s' #) -> case runState' n s' of + (# x, s'' #) -> (# f x, s'' #) + +instance Monad (State s) where + return x = State $ \s -> (# x, s #) + m >>= n = State $ \s -> case runState' m s of + (# r, s' #) -> runState' (n r) s' + +get :: State s s +get = State $ \s -> (# s, s #) + +gets :: (s -> a) -> State s a +gets f = State $ \s -> (# f s, s #) + +put :: s -> State s () +put s' = State $ \_ -> (# (), s' #) + +modify :: (s -> s) -> State s () +modify f = State $ \s -> (# (), f s #) + + +evalState :: State s a -> s -> a +evalState s i = case runState' s i of + (# a, _ #) -> a + + +execState :: State s a -> s -> s +execState s i = case runState' s i of + (# _, s' #) -> s' + + +runState :: State s a -> s -> (a, s) +runState s i = case runState' s i of + (# a, s' #) -> (a, s') diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs new file mode 100644 index 00000000..edb0b0c5 --- /dev/null +++ b/compiler/utils/Stream.hs @@ -0,0 +1,109 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2012 +-- +-- Monadic streams +-- +-- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Stream ( + Stream(..), yield, liftIO, + collect, fromList, + Stream.map, Stream.mapM, Stream.mapAccumL + ) where +import Control.Monad +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + + +-- | +-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence +-- of elements of type @a@ followed by a result of type @b@. +-- +-- More concretely, a value of type @Stream m a b@ can be run using @runStream@ +-- in the Monad @m@, and it delivers either +-- +-- * the final result: @Left b@, or +-- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ +-- is a computation to get the rest of the stream. +-- +-- Stream is itself a Monad, and provides an operation 'yield' that +-- produces a new element of the stream. This makes it convenient to turn +-- existing monadic computations into streams. +-- +-- The idea is that Stream is useful for making a monadic computation +-- that produces values from time to time. This can be used for +-- knitting together two complex monadic operations, so that the +-- producer does not have to produce all its values before the +-- consumer starts consuming them. We make the producer into a +-- Stream, and the consumer pulls on the stream each time it wants a +-- new value. +-- +newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } + +instance Monad f => Functor (Stream f a) where + fmap = liftM + +instance Monad m => Applicative (Stream m a) where + pure = return + (<*>) = ap + +instance Monad m => Monad (Stream m a) where + return a = Stream (return (Left a)) + + Stream m >>= k = Stream $ do + r <- m + case r of + Left b -> runStream (k b) + Right (a,str) -> return (Right (a, str >>= k)) + +yield :: Monad m => a -> Stream m a () +yield a = Stream (return (Right (a, return ()))) + +liftIO :: IO a -> Stream IO b a +liftIO io = Stream $ io >>= return . Left + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect :: Monad m => Stream m a () -> m [a] +collect str = go str [] + where + go str acc = do + r <- runStream str + case r of + Left () -> return (reverse acc) + Right (a, str') -> go str' (a:acc) + +-- | Turn a list into a 'Stream', by yielding each element in turn. +fromList :: Monad m => [a] -> Stream m a () +fromList = mapM_ yield + +-- | Apply a function to each element of a 'Stream', lazily +map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x +map f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> return (Right (f a, Stream.map f str')) + +-- | Apply a monadic operation to each element of a 'Stream', lazily +mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x +mapM f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> do + b <- f a + return (Right (b, Stream.mapM f str')) + +-- | analog of the list-based 'mapAccumL' on Streams. This is a simple +-- way to map over a Stream while carrying some state around. +mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () + -> Stream m b c +mapAccumL f c str = Stream $ do + r <- runStream str + case r of + Left () -> return (Left c) + Right (a, str') -> do + (c',b) <- f c a + return (Right (b, mapAccumL f c' str')) diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs new file mode 100644 index 00000000..570282da --- /dev/null +++ b/compiler/utils/StringBuffer.hs @@ -0,0 +1,257 @@ +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + + +Buffers for scanning string input stored in external arrays. +-} + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +module StringBuffer + ( + StringBuffer(..), + -- non-abstract for vs\/HaskellService + + -- * Creation\/destruction + hGetStringBuffer, + hGetStringBufferBlock, + appendStringBuffers, + stringToStringBuffer, + + -- * Inspection + nextChar, + currentChar, + prevChar, + atEnd, + + -- * Moving and comparison + stepOn, + offsetBytes, + byteDiff, + + -- * Conversion + lexemeToString, + lexemeToFastString, + + -- * Parsing integers + parseUnsignedInteger, + ) where + +#include "HsVersions.h" + +import Encoding +import FastString +import FastTypes +import FastFunctions +import Outputable +import Util + +import Data.Maybe +import Control.Exception +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) + +import GHC.Exts + +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif + +-- ----------------------------------------------------------------------------- +-- The StringBuffer type + +-- |A StringBuffer is an internal pointer to a sized chunk of bytes. +-- The bytes are intended to be *immutable*. There are pure +-- operations to read the contents of a StringBuffer. +-- +-- A StringBuffer may have a finalizer, depending on how it was +-- obtained. +-- +data StringBuffer + = StringBuffer { + buf :: {-# UNPACK #-} !(ForeignPtr Word8), + len :: {-# UNPACK #-} !Int, -- length + cur :: {-# UNPACK #-} !Int -- current pos + } + -- The buffer is assumed to be UTF-8 encoded, and furthermore + -- we add three '\0' bytes to the end as sentinels so that the + -- decoder doesn't have to check for overflow at every single byte + -- of a multibyte sequence. + +instance Show StringBuffer where + showsPrec _ s = showString "" + +-- ----------------------------------------------------------------------------- +-- Creation / Destruction + +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + h <- openBinaryFile fname ReadMode + size_i <- hFileSize h + offset_i <- skipBOM h size_i 0 -- offset is 0 initially + let size = fromIntegral $ size_i - offset_i + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + r <- if size == 0 then return 0 else hGetBuf h ptr size + hClose h + if (r /= size) + then ioError (userError "short read of file") + else newUTF8StringBuffer buf ptr size + +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle >>= skipBOM handle size_i + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) + else newUTF8StringBuffer buf ptr size + +-- | Skip the byte-order mark if there is one (see #1744 and #6016), +-- and return the new position of the handle in bytes. +-- +-- This is better than treating #FEFF as whitespace, +-- because that would mess up layout. We don't have a concept +-- of zero-width whitespace in Haskell: all whitespace codepoints +-- have a width of one column. +skipBOM :: Handle -> Integer -> Integer -> IO Integer +skipBOM h size offset = + -- Only skip BOM at the beginning of a file. + if size > 0 && offset == 0 + then do + -- Validate assumption that handle is in binary mode. + ASSERTM( hGetEncoding h >>= return . isNothing ) + -- Temporarily select text mode to make `hLookAhead` and + -- `hGetChar` return full Unicode characters. + bracket_ (hSetBinaryMode h False) (hSetBinaryMode h True) $ do + c <- hLookAhead h + if c == '\xfeff' + then hGetChar h >> hTell h + else return offset + else return offset + +newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer +newUTF8StringBuffer buf ptr size = do + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return $ StringBuffer buf size 0 + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + withForeignPtr newBuf $ \ptr -> + withForeignPtr (buf sb1) $ \sb1Ptr -> + withForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len + copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where sb1_len = calcLen sb1 + sb2_len = calcLen sb2 + calcLen sb = len sb - cur sb + size = sb1_len + sb2_len + +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do + let size = utf8EncodedLength str + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return (StringBuffer buf size 0) + +-- ----------------------------------------------------------------------------- +-- Grab a character + +-- Getting our fingers dirty a little here, but this is performance-critical +{-# INLINE nextChar #-} +nextChar :: StringBuffer -> (Char,StringBuffer) +nextChar (StringBuffer buf len (I# cur#)) = + inlinePerformIO $ do + withForeignPtr buf $ \(Ptr a#) -> do + case utf8DecodeChar# (a# `plusAddr#` cur#) of + (# c#, nBytes# #) -> + let cur' = I# (cur# +# nBytes#) in + return (C# c#, StringBuffer buf len cur') + +currentChar :: StringBuffer -> Char +currentChar = fst . nextChar + +prevChar :: StringBuffer -> Char -> Char +prevChar (StringBuffer _ _ 0) deflt = deflt +prevChar (StringBuffer buf _ cur) _ = + inlinePerformIO $ do + withForeignPtr buf $ \p -> do + p' <- utf8PrevChar (p `plusPtr` cur) + return (fst (utf8DecodeChar p')) + +-- ----------------------------------------------------------------------------- +-- Moving + +stepOn :: StringBuffer -> StringBuffer +stepOn s = snd (nextChar s) + +offsetBytes :: Int -> StringBuffer -> StringBuffer +offsetBytes i s = s { cur = cur s + i } + +byteDiff :: StringBuffer -> StringBuffer -> Int +byteDiff s1 s2 = cur s2 - cur s1 + +atEnd :: StringBuffer -> Bool +atEnd (StringBuffer _ l c) = l == c + +-- ----------------------------------------------------------------------------- +-- Conversion + +lexemeToString :: StringBuffer -> Int {-bytes-} -> String +lexemeToString _ 0 = "" +lexemeToString (StringBuffer buf _ cur) bytes = + inlinePerformIO $ + withForeignPtr buf $ \ptr -> + utf8DecodeString (ptr `plusPtr` cur) bytes + +lexemeToFastString :: StringBuffer -> Int {-bytes-} -> FastString +lexemeToFastString _ 0 = nilFS +lexemeToFastString (StringBuffer buf _ cur) len = + inlinePerformIO $ + withForeignPtr buf $ \ptr -> + return $! mkFastStringBytes (ptr `plusPtr` cur) len + +-- ----------------------------------------------------------------------------- +-- Parsing integer strings in various bases +{- +byteOff :: StringBuffer -> Int -> Char +byteOff (StringBuffer buf _ cur) i = + inlinePerformIO $ withForeignPtr buf $ \ptr -> do +-- return $! cBox (indexWord8OffFastPtrAsFastChar +-- (pUnbox ptr) (iUnbox (cur+i))) +--or +-- w <- peek (ptr `plusPtr` (cur+i)) +-- return (unsafeChr (fromIntegral (w::Word8))) +-} +-- | XXX assumes ASCII digits only (by using byteOff) +parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer +parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int + = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let + --LOL, in implementations where the indexing needs slow unsafePerformIO, + --this is less (not more) efficient than using the IO monad explicitly + --here. + !ptr' = pUnbox ptr + byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i))) + go i x | i == len = x + | otherwise = case byteOff i of + char -> go (i + 1) (x * radix + toInteger (char_to_int char)) + in go 0 0 diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs new file mode 100644 index 00000000..228f3b52 --- /dev/null +++ b/compiler/utils/UnVarGraph.hs @@ -0,0 +1,136 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module UnVarGraph + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , delUnVarSet + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , delNode + ) where + +import Id +import VarEnv +import UniqFM +import Outputable +import Data.List +import Bag +import Unique + +import qualified Data.IntSet as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjancet nodes +newtype UnVarSet = UnVarSet (S.IntSet) + deriving Eq + +k :: Var -> Int +k v = getKey (getUnique v) + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +varEnvDom :: VarEnv a -> UnVarSet +varEnvDom ae = UnVarSet $ ufmToSet_Directly ae + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldr unionUnVarSet emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] + + +-- The graph type. A list of complete bipartite graphs +data Gen = CBPG UnVarSet UnVarSet -- complete bipartite + | CG UnVarSet -- complete +newtype UnVarGraph = UnVarGraph (Bag Gen) + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = UnVarGraph emptyBag + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) + = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ + UnVarGraph (g1 `unionBags` g2) + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ UnVarGraph $ unitBag $ CG s + +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g + where go (CG s) = (if v `elemUnVarSet` s then [s] else []) + go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ + (if v `elemUnVarSet` s2 then [s1] else []) + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g + where go (CG s) = CG (s `delUnVarSet` v) + go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) + +prune :: UnVarGraph -> UnVarGraph +prune (UnVarGraph g) = UnVarGraph $ filterBag go g + where go (CG s) = not (isEmptyUnVarSet s) + go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) + +instance Outputable Gen where + ppr (CG s) = ppr s <> char '²' + ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +instance Outputable UnVarGraph where + ppr (UnVarGraph g) = ppr g diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs new file mode 100644 index 00000000..e24c7173 --- /dev/null +++ b/compiler/utils/UniqFM.hs @@ -0,0 +1,315 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall #-} + +module UniqFM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + plusUFM, + plusUFM_C, + plusUFM_CD, + minusUFM, + intersectUFM, + intersectUFM_C, + foldUFM, foldUFM_Directly, + mapUFM, mapUFM_Directly, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + eltsUFM, keysUFM, splitUFM, + ufmToSet_Directly, + ufmToList, + joinUFM, pprUniqFM + ) where + +import FastString +import Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import Compiler.Hoopl hiding (Unique) + +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable +import Data.Typeable +import Data.Data +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid +#endif + +{- +************************************************************************ +* * +\subsection{The signature of the module} +* * +************************************************************************ +-} + +emptyUFM :: UniqFM elt +isNullUFM :: UniqFM elt -> Bool +unitUFM :: Uniquable key => key -> elt -> UniqFM elt +unitDirectlyUFM -- got the Unique already + :: Unique -> elt -> UniqFM elt +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt +listToUFM_Directly + :: [(Unique, elt)] -> UniqFM elt +listToUFM_C :: Uniquable key => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM elt + +addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt +addToUFM_Directly + :: UniqFM elt -> Unique -> elt -> UniqFM elt + +addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM elt -- old + -> key -> elt -- new + -> UniqFM elt -- result + +addToUFM_Acc :: Uniquable key => + (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result + +alterUFM :: Uniquable key => + (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM elt -- old + -> key -- new + -> UniqFM elt -- result + +addListToUFM_C :: Uniquable key => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt + +delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt +delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt +delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt + +plusUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD :: (elt -> elt -> elt) + -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt + +minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 + +intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +intersectUFM_C :: (elt1 -> elt2 -> elt3) + -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3 + +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) + +sizeUFM :: UniqFM elt -> Int +--hashUFM :: UniqFM elt -> Int +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool +elemUFM_Directly:: Unique -> UniqFM elt -> Bool + +splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt) + -- Splits a UFM into things less than, equal to, and greater than the key +lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt +lookupUFM_Directly -- when you've got the Unique already + :: UniqFM elt -> Unique -> Maybe elt +lookupWithDefaultUFM + :: Uniquable key => UniqFM elt -> elt -> key -> elt +lookupWithDefaultUFM_Directly + :: UniqFM elt -> elt -> Unique -> elt +keysUFM :: UniqFM elt -> [Unique] -- Get the keys +eltsUFM :: UniqFM elt -> [elt] +ufmToSet_Directly :: UniqFM elt -> S.IntSet +ufmToList :: UniqFM elt -> [(Unique, elt)] + +{- +************************************************************************ +* * +\subsection{Monoid interface} +* * +************************************************************************ +-} + +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = plusUFM + +{- +************************************************************************ +* * +\subsection{Implementation using ``Data.IntMap''} +* * +************************************************************************ +-} + +newtype UniqFM ele = UFM (M.IntMap ele) + deriving (Data, Eq, Functor, Traversable.Traversable, + Typeable) + +deriving instance Foldable.Foldable UniqFM + +emptyUFM = UFM M.empty +isNullUFM (UFM m) = M.null m +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) +listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM +listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM +listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM + +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) +addListToUFM = foldl (\m (k, v) -> addToUFM m k v) +addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v) +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) +addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) +delListFromUFM = foldl delFromUFM +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +foldUFM k z (UFM m) = M.fold k z m +foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m +mapUFM f (UFM m) = UFM (M.map f m) +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) +filterUFM p (UFM m) = UFM (M.filter p m) +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) +partitionUFM p (UFM m) = case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM (UFM m) = M.size m +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of + (less, equal, greater) -> (UFM less, equal, UFM greater) +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m +keysUFM (UFM m) = map getUnique $ M.keys m +eltsUFM (UFM m) = M.elems m +ufmToSet_Directly (UFM m) = M.keysSet m +ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +-- Hoopl +joinUFM :: JoinFun v -> JoinFun (UniqFM v) +joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new + where add k new_v (ch, joinmap) = + case lookupUFM_Directly joinmap k of + Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v') + (NoChange, _) -> (ch, joinmap) + +{- +************************************************************************ +* * +\subsection{Output-ery} +* * +************************************************************************ +-} + +instance Outputable a => Outputable (UniqFM a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt + | (uq, elt) <- ufmToList ufm ] diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs new file mode 100644 index 00000000..5a823031 --- /dev/null +++ b/compiler/utils/UniqSet.hs @@ -0,0 +1,115 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} + +module UniqSet ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addOneToUniqSet_C, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + unionUniqSets, unionManyUniqSets, + minusUniqSet, + intersectUniqSets, + foldUniqSet, + mapUniqSet, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + uniqSetToList, + partitionUniqSet + ) where + +import UniqFM +import Unique + +{- +************************************************************************ +* * +\subsection{The signature of the module} +* * +************************************************************************ +-} + +emptyUniqSet :: UniqSet a +unitUniqSet :: Uniquable a => a -> UniqSet a +mkUniqSet :: Uniquable a => [a] -> UniqSet a + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet_Directly :: Uniquable a => UniqSet a -> Unique -> UniqSet a +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionManyUniqSets :: [UniqSet a] -> UniqSet a +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a + +foldUniqSet :: (a -> b -> b) -> b -> UniqSet a -> b +mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) + +sizeUniqSet :: UniqSet a -> Int +isEmptyUniqSet :: UniqSet a -> Bool +lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a +uniqSetToList :: UniqSet a -> [a] + +{- +************************************************************************ +* * +\subsection{Implementation using ``UniqFM''} +* * +************************************************************************ +-} + +type UniqSet a = UniqFM a + +emptyUniqSet = emptyUFM +unitUniqSet x = unitUFM x x +mkUniqSet = foldl addOneToUniqSet emptyUniqSet + +addOneToUniqSet set x = addToUFM set x x +addOneToUniqSet_C f set x = addToUFM_C f set x x +addListToUniqSet = foldl addOneToUniqSet + +delOneFromUniqSet = delFromUFM +delOneFromUniqSet_Directly = delFromUFM_Directly +delListFromUniqSet = delListFromUFM + +unionUniqSets = plusUFM +unionManyUniqSets [] = emptyUniqSet +unionManyUniqSets sets = foldr1 unionUniqSets sets +minusUniqSet = minusUFM +intersectUniqSets = intersectUFM + +foldUniqSet = foldUFM +mapUniqSet = mapUFM +elementOfUniqSet = elemUFM +elemUniqSet_Directly = elemUFM_Directly +filterUniqSet = filterUFM +partitionUniqSet = partitionUFM + +sizeUniqSet = sizeUFM +isEmptyUniqSet = isNullUFM +lookupUniqSet = lookupUFM +uniqSetToList = eltsUFM diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs new file mode 100644 index 00000000..2e357c1f --- /dev/null +++ b/compiler/utils/Util.hs @@ -0,0 +1,1138 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +-- | Highly random utility functions +-- +module Util ( + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, ncgDebugIsOn, + ghciTablesNextToCode, + isWindowsHost, isDarwinHost, + + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipLazy, stretchZipWith, zipWithAndUnzip, + + filterByList, + + unzipWith, + + mapFst, mapSnd, chkAppend, + mapAndUnzip, mapAndUnzip3, mapAccumL2, + nOfThem, filterOut, partitionWith, splitEithers, + + dropWhileEndLE, + + foldl1', foldl2, count, all2, + + lengthExceeds, lengthIs, lengthAtLeast, + listLengthCmp, atLength, + equalLength, compareLength, leLength, + + isSingleton, only, singleton, + notNull, snocView, + + isIn, isn'tIn, + + -- * Tuples + fstOf3, sndOf3, thirdOf3, + firstM, first3M, + third3, + uncurry3, + + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, + + -- * For loop + nTimes, + + -- * Sorting + sortWith, minWith, nubSort, + + -- * Comparisons + isEqual, eqListBy, eqMaybeBy, + thenCmp, cmpList, + removeSpaces, + (<&&>), (<||>), + + -- * Edit distance + fuzzyMatch, fuzzyLookup, + + -- * Transitive closures + transitiveClosure, + + -- * Strictness + seqList, + + -- * Module names + looksLikeModuleName, + + -- * Argument processing + getCmd, toCmdArgs, toArgs, + + -- * Floating point + readRational, + + -- * read helpers + maybeRead, maybeReadFuzzy, + + -- * IO-ish utilities + doesDirNameExist, + getModificationUTCTime, + modificationTimeIfExists, + hSetTranslit, + + global, consIORef, globalM, + + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + Direction(..), reslash, + makeRelativeTo, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC, + + -- * Hashing + hashString, + ) where + +#include "HsVersions.h" + +import Exception +import Panic + +import Data.Data +import Data.IORef ( IORef, newIORef, atomicModifyIORef ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List hiding (group) + +#ifdef DEBUG +import FastTypes +#endif + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative) +#endif +import Control.Applicative ( liftA2 ) +import Control.Monad ( liftM ) +import GHC.IO.Encoding (mkTextEncoding, textEncodingName) +import System.IO (Handle, hGetEncoding, hSetEncoding) +import System.IO.Error as IO ( isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, getModificationTime ) +import System.FilePath + +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) +import Data.Int +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Bits +import Data.Word +import qualified Data.IntMap as IM +import qualified Data.Set as Set + +import Data.Time + +infixr 9 `thenCmp` + +{- +************************************************************************ +* * +\subsection{Is DEBUG on, are we on Windows, etc?} +* * +************************************************************************ + +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. +-} + +ghciSupported :: Bool +#ifdef GHCI +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#ifdef DEBUG +debugIsOn = True +#else +debugIsOn = False +#endif + +ncgDebugIsOn :: Bool +#ifdef NCG_DEBUG +ncgDebugIsOn = True +#else +ncgDebugIsOn = False +#endif + +ghciTablesNextToCode :: Bool +#ifdef GHCI_TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif + +isWindowsHost :: Bool +#ifdef mingw32_HOST_OS +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isDarwinHost :: Bool +#ifdef darwin_HOST_OS +isDarwinHost = True +#else +isDarwinHost = False +#endif + +{- +************************************************************************ +* * +\subsection{A for loop} +* * +************************************************************************ +-} + +-- | Compose a function with itself n times. (nth rather than twice) +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thirdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thirdOf3 (_,_,c) = c + +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) +firstM f (x, y) = liftM (\x' -> (x', y)) (f x) + +first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) +first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) + +{- +************************************************************************ +* * +\subsection[Utils-lists]{General list processing} +* * +************************************************************************ +-} + +filterOut :: (a->Bool) -> [a] -> [a] +-- ^ Like filter, only it reverses the sense of the test +filterOut _ [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +splitEithers :: [Either a b] -> ([a], [b]) +-- ^ Teases a list of 'Either's apart into two lists +splitEithers [] = ([],[]) +splitEithers (e : es) = case e of + Left x -> (x:xs, ys) + Right y -> (xs, y:ys) + where (xs,ys) = splitEithers es + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second arguemnt being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +{- +A paranoid @zip@ (and some @zipWith@ friends) that checks the lists +are of equal length. Alastair Reid thinks this should only happen if +DEBUGging on; hey, why not? +-} + +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] + +#ifndef DEBUG +zipEqual _ = zip +zipWithEqual _ = zipWith +zipWith3Equal _ = zipWith3 +zipWith4Equal _ = zipWith4 +#else +zipEqual _ [] [] = [] +zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs +zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) + +zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs +zipWithEqual _ _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) + +zipWith3Equal msg z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal _ _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) + +zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal _ _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) +#endif + +-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) +zipLazy :: [a] -> [b] -> [(a,b)] +zipLazy [] _ = [] +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ + +stretchZipWith _ _ _ [] _ = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys + +mapFst :: (a->c) -> [(a,b)] -> [(c,b)] +mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] + +mapFst f xys = [(f x, y) | (x,y) <- xys] +mapSnd f xys = [(x, f y) | (x,y) <- xys] + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) + +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) + +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs + +nOfThem :: Int -> a -> [a] +nOfThem n thing = replicate n thing + +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: +-- +-- @ +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred n +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- @ +atLength :: ([a] -> b) + -> (Int -> b) + -> [a] + -> Int + -> b +atLength atLenPred atEndPred ls n + | n < 0 = atEndPred n + | otherwise = go n ls + where + go n [] = atEndPred n + go 0 ls = atLenPred ls + go n (_:xs) = go (n-1) xs + +-- Some special cases of atLength: + +lengthExceeds :: [a] -> Int -> Bool +-- ^ > (lengthExceeds xs n) = (length xs > n) +lengthExceeds = atLength notNull (const False) + +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength notNull (== 0) + +lengthIs :: [a] -> Int -> Bool +lengthIs = atLength null (==0) + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd 0 = EQ + atEnd x + | x > 0 = LT -- not yet seen 'n' elts, so list length is < n. + | otherwise = GT + + atLen [] = EQ + atLen _ = GT + +equalLength :: [a] -> [b] -> Bool +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength _ _ = False + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ = LT +compareLength _ [] = GT + +leLength :: [a] -> [b] -> Bool +-- ^ True if length xs <= length ys +leLength xs ys = case compareLength xs ys of + LT -> True + EQ -> True + GT -> False + +---------------------------- +singleton :: a -> [a] +singleton x = [x] + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +notNull :: [a] -> Bool +notNull [] = False +notNull _ = True + +only :: [a] -> a +#ifdef DEBUG +only [a] = a +#else +only (a:_) = a +#endif +only _ = panic "Util: only" + +-- Debugging/specialising versions of \tr{elem} and \tr{notElem} + +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool + +# ifndef DEBUG +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys + +# else /* DEBUG */ +isIn msg x ys + = elem100 (_ILIT(0)) x ys + where + elem100 _ _ [] = False + elem100 i x (y:ys) + | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg) + (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys + +isn'tIn msg x ys + = notElem100 (_ILIT(0)) x ys + where + notElem100 _ _ [] = True + notElem100 i x (y:ys) + | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg) + (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys +# endif /* DEBUG */ + +{- +************************************************************************ +* * +\subsubsection{Sort utils} +* * +************************************************************************ +-} + +sortWith :: Ord b => (a->b) -> [a] -> [a] +sortWith get_key xs = sortBy (comparing get_key) xs + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList + +{- +************************************************************************ +* * +\subsection[Utils-transitive-closure]{Transitive closure} +* * +************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. +-} + +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = go [] xs + where + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) + + _ `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys + +{- +************************************************************************ +* * +\subsection[Utils-accum]{Accumulating} +* * +************************************************************************ + +A combination of foldl with zip. It works with equal length lists. +-} + +foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc +foldl2 _ z [] [] = z +foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" + +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if the lists are the same length, and +-- all corresponding elements satisfy the predicate +all2 _ [] [] = True +all2 p (x:xs) (y:ys) = p x y && all2 p xs ys +all2 _ _ _ = False + +-- Count the number of times a predicate is true + +count :: (a -> Bool) -> [a] -> Int +count _ [] = 0 +count p (x:xs) | p x = 1 + count p xs + | otherwise = count p xs + +{- +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: +-} + +takeList :: [b] -> [a] -> [a] +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +-- drop from the end of a list +dropTail :: Int -> [a] -> [a] +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does + +-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, +-- but is lazy in the elements and strict in the spine. For reasonably short lists, +-- such as path names and typical lines of text, dropWhileEndLE is generally +-- faster than dropWhileEnd. Its advantage is magnified when the predicate is +-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text +-- is generally much faster than using dropWhileEnd isSpace for that purpose. +-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse +-- Pay attention to the short-circuit (&&)! The order of its arguments is the only +-- difference between dropWhileEnd and dropWhileEndLE. +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +snocView :: [a] -> Maybe ([a],a) + -- Split off the last element +snocView [] = Nothing +snocView xs = go [] xs + where + -- Invariant: second arg is non-empty + go acc [x] = Just (reverse acc, x) + go acc (x:xs) = go (x:acc) xs + go _ [] = panic "Util: snocView" + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +{- +************************************************************************ +* * +\subsection[Utils-comparison]{Comparisons} +* * +************************************************************************ +-} + +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering + +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy _ [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy _ _ _ = False + +eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy _ _ _ = False + +cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering + -- `cmpList' uses a user-specified comparer + +cmpList _ [] [] = EQ +cmpList _ [] _ = LT +cmpList _ _ [] = GT +cmpList cmp (a:as) (b:bs) + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } + +removeSpaces :: String -> String +removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace + +-- Boolean operators lifted to Applicative +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> -- same as (&&) + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +{- +************************************************************************ +* * +\subsection{Edit distance} +* * +************************************************************************ +-} + +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ + foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv +matchVectors = snd . foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') + +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} + +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} + +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} + +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilites + = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss_val, distance) | (poss_str, poss_val) <- possibilites + , let distance = restrictedDamerauLevenshteinDistance + poss_str user_entered + , distance <= fuzzy_threshold ] + where + -- Work out an approriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshhold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 + +{- +************************************************************************ +* * +\subsection[Utils-pairs]{Pairs} +* * +************************************************************************ +-} + +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs + +seqList :: [a] -> b -> b +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + atomicModifyIORef var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Module names: + +looksLikeModuleName :: String -> Bool +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs + +{- +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. +-} + +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgs s' of + Left err -> Left err + Right args -> Right (cmd, args) + +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ "as [String]") + s -> toArgs' s + where + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + case toArgs' rest of + Left err -> Left err + Right args -> Right (arg : args) + _ -> + Left ("Couldn't read " ++ show s ++ "as String") + s' -> case break isSpace s' of + (arg, s'') -> case toArgs' s'' of + Left err -> Left err + Right args -> Right (arg : args) + +{- +-- ----------------------------------------------------------------------------- +-- Floats +-} + +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span p s) + return (cs,t) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +----------------------------------------------------------------------------- +-- read helpers + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] + | all isSpace s -> + Just x + _ -> + Nothing + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) + +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +getModificationUTCTime = getModificationTime + +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists f = do + (do t <- getModificationUTCTime f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- Change the character encoding of the given Handle to transliterate +-- on unsupported characters instead of throwing an exception + +hSetTranslit :: Handle -> IO () +hSetTranslit h = do + menc <- hGetEncoding h + case fmap textEncodingName menc of + Just name | '/' `notElem` name -> do + enc' <- mkTextEncoding $ name ++ "//TRANSLIT" + hSetEncoding h enc' + _ -> return () + +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred + | null r_pre = (str, []) + | otherwise = (reverse (tail r_pre), reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +type Suffix = String + +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +data Direction = Forwards | Backwards + +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' + +makeRelativeTo :: FilePath -> FilePath -> FilePath +this `makeRelativeTo` that = directory thisFilename + where (thisDirectory, thisFilename) = splitFileName this + thatDirectory = dropFileName that + directory = joinPath $ f (splitPath thisDirectory) + (splitPath thatDirectory) + + f (x : xs) (y : ys) + | x == y = f xs ys + f xs ys = replicate (length ys) ".." ++ xs + +{- +************************************************************************ +* * +\subsection[Utils-Data]{Utils for defining Data instances} +* * +************************************************************************ + +These functions helps us to define Data instances for abstract types. +-} + +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix + +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] + +{- +************************************************************************ +* * +\subsection[Utils-C]{Utils for printing C code} +* * +************************************************************************ +-} + +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + +{- +************************************************************************ +* * +\subsection[Utils-Hashing]{Utils for hashing} +* * +************************************************************************ +-} + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = fromIntegral (0xdeadbeef :: Word32) + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b diff --git a/compiler/utils/md5.h b/compiler/utils/md5.h new file mode 100644 index 00000000..10c8dabd --- /dev/null +++ b/compiler/utils/md5.h @@ -0,0 +1,24 @@ +/* MD5 message digest */ +#ifndef _MD5_H +#define _MD5_H + +#include "HsFFI.h" + +typedef HsWord32 word32; +typedef HsWord8 byte; + +struct MD5Context { + word32 buf[4]; + word32 bytes[2]; + word32 in[16]; +}; + +void MD5Init(struct MD5Context *context); +void MD5Update(struct MD5Context *context, byte const *buf, int len); +void MD5Final(byte digest[16], struct MD5Context *context); +void MD5Transform(word32 buf[4], word32 const in[16]); + +#endif /* _MD5_H */ + + + diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs new file mode 100644 index 00000000..38bd5548 --- /dev/null +++ b/compiler/vectorise/Vectorise.hs @@ -0,0 +1,356 @@ +-- Main entry point to the vectoriser. It is invoked iff the option '-fvectorise' is passed. +-- +-- This module provides the function 'vectorise', which vectorises an entire (desugared) module. +-- It vectorises all type declarations and value bindings. It also processes all VECTORISE pragmas +-- (aka vectorisation declarations), which can lead to the vectorisation of imported data types +-- and the enrichment of imported functions with vectorised versions. + +module Vectorise ( vectorise ) +where + +import Vectorise.Type.Env +import Vectorise.Type.Type +import Vectorise.Convert +import Vectorise.Utils.Hoisting +import Vectorise.Exp +import Vectorise.Env +import Vectorise.Monad + +import HscTypes hiding ( MonadThings(..) ) +import CoreUnfold ( mkInlineUnfolding ) +import PprCore +import CoreSyn +import CoreMonad ( CoreM, getHscEnv ) +import Type +import Id +import DynFlags +import Outputable +import Util ( zipLazy ) +import MonadUtils + +import Control.Monad + + +-- |Vectorise a single module. +-- +vectorise :: ModGuts -> CoreM ModGuts +vectorise guts + = do { hsc_env <- getHscEnv + ; liftIO $ vectoriseIO hsc_env guts + } + +-- Vectorise a single monad, given the dynamic compiler flags and HscEnv. +-- +vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts +vectoriseIO hsc_env guts + = do { -- Get information about currently loaded external packages. + ; eps <- hscEPS hsc_env + + -- Combine vectorisation info from the current module, and external ones. + ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps + + -- Run the main VM computation. + ; Just (info', guts') <- initV hsc_env guts info (vectModule guts) + ; return (guts' { mg_vect_info = info' }) + } + +-- Vectorise a single module, in the VM monad. +-- +vectModule :: ModGuts -> VM ModGuts +vectModule guts@(ModGuts { mg_tcs = tycons + , mg_binds = binds + , mg_fam_insts = fam_insts + , mg_vect_decls = vect_decls + }) + = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ + pprCoreBindings binds + + -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas + ; let ty_vect_decls = [vd | vd@(VectType _ _ _) <- vect_decls] + cls_vect_decls = [vd | vd@(VectClass _) <- vect_decls] + + -- Vectorise the type environment. This will add vectorised + -- type constructors, their representaions, and the + -- conrresponding data constructors. Moreover, we produce + -- bindings for dfuns and family instances of the classes + -- and type families used in the DPH library to represent + -- array types. + ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls + + -- Family instance environment for /all/ home-package modules including those instances + -- generated by 'vectTypeEnv'. + ; (_, fam_inst_env) <- readGEnv global_fam_inst_env + + -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers + -- NB: Need to vectorise the imported bindings first (local bindings may depend on them). + ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id] + ; binds_imp <- mapM vectImpBind impBinds + ; binds_top <- mapM vectTopBind binds + + ; return $ guts { mg_tcs = tycons ++ new_tycons + -- we produce no new classes or instances, only new class type constructors + -- and dfuns + , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) + , mg_fam_inst_env = fam_inst_env + , mg_fam_insts = fam_insts ++ new_fam_insts + } + } + +-- Try to vectorise a top-level binding. If it doesn't vectorise, or if it is entirely scalar, then +-- omit vectorisation of that binding. +-- +-- For example, for the binding +-- +-- @ +-- foo :: Int -> Int +-- foo = \x -> x + x +-- @ +-- +-- we get +-- @ +-- foo :: Int -> Int +-- foo = \x -> vfoo $: x +-- +-- v_foo :: Closure void vfoo lfoo +-- v_foo = closure vfoo lfoo void +-- +-- vfoo :: Void -> Int -> Int +-- vfoo = ... +-- +-- lfoo :: PData Void -> PData Int -> PData Int +-- lfoo = ... +-- @ +-- +-- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo, +-- but takes an explicit environment. +-- +-- @lfoo@ is the "lifted" version that works on arrays. +-- +-- @v_foo@ combines both of these into a `Closure` that also contains the environment. +-- +-- The original binding @foo@ is rewritten to call the vectorised version present in the closure. +-- +-- Vectorisation may be surpressed by annotating a binding with a 'NOVECTORISE' pragma. If this +-- pragma is used in a group of mutually recursive bindings, either all or no binding must have +-- the pragma. If only some bindings are annotated, a fatal error is being raised. (In the case of +-- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.) +-- +-- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or +-- we may emit a warning and refrain from vectorising the entire group. +-- +vectTopBind :: CoreBind -> VM CoreBind +vectTopBind b@(NonRec var expr) + = do + { traceVt "= Vectorise non-recursive top-level variable" (ppr var) + + ; (hasNoVect, vectDecl) <- lookupVectDecl var + ; if hasNoVect + then do + { -- 'NOVECTORISE' pragma => leave this binding as it is + ; traceVt "NOVECTORISE" $ ppr var + ; return b + } + else do + { vectRhs <- case vectDecl of + Just (_, expr') -> + -- 'VECTORISE' pragma => just use the provided vectorised rhs + do + { traceVt "VECTORISE" $ ppr var + ; addGlobalParallelVar var + ; return $ Just (False, inlineMe, expr') + } + Nothing -> + -- no pragma => standard vectorisation of rhs + do + { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr + ; vectTopExpr var expr + } + ; hs <- takeHoisted -- make sure we clean those out (even if we skip) + ; case vectRhs of + { Nothing -> + -- scalar binding => leave this binding as it is + do + { traceVt "scalar binding [skip]" $ ppr var + ; return b + } + ; Just (parBind, inline, expr') -> do + { + -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map + ; when parBind $ + addGlobalParallelVar var + ; var' <- vectTopBinder var inline expr' + + -- We replace the original top-level binding by a value projected from the vectorised + -- closure and add any newly created hoisted top-level bindings. + ; cexpr <- tryConvert var var' expr + ; return . Rec $ (var, cexpr) : (var', expr') : hs + } } } } + `orElseErrV` + do + { emitVt " Could NOT vectorise top-level binding" $ ppr var + ; return b + } +vectTopBind b@(Rec binds) + = do + { traceVt "= Vectorise recursive top-level variables" $ ppr vars + + ; vectDecls <- mapM lookupVectDecl vars + ; let hasNoVects = map fst vectDecls + ; if and hasNoVects + then do + { -- 'NOVECTORISE' pragmas => leave this entire binding group as it is + ; traceVt "NOVECTORISE" $ ppr vars + ; return b + } + else do + { if or hasNoVects + then do + { -- Inconsistent 'NOVECTORISE' pragmas => bail out + ; dflags <- getDynFlags + ; cantVectorise dflags noVectoriseErr (ppr b) + } + else do + { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds] + + -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression + ; newBindsWPragma <- concat <$> + sequence [ vectTopBindAndConvert bind inlineMe expr' + | (bind, (_, Just (_, expr'))) <- zip binds vectDecls] + + -- Standard vectorisation of all rhses that are *without* a pragma. + -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for + -- the bound variables in the recursive group to the vectorisation map, which in turn + -- are needed by 'vectPolyExprs' (unless it returns 'Nothing'). + ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls] + ; (newBinds, _) <- fixV $ + \ ~(_, exprs') -> + do + { -- Create appropriate top-level bindings, enter them into the vectorisation map, and + -- vectorise the right-hand sides + ; newBindsWOPragma <- concat <$> + sequence [vectTopBindAndConvert bind inline expr + | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs'] + -- irrefutable pattern and 'zipLazy' to tie the knot; + -- hence, can't use 'zipWithM' + ; vectRhses <- vectTopExprs bindsWOPragma + ; hs <- takeHoisted -- make sure we clean those out (even if we skip) + + ; case vectRhses of + Nothing -> + -- scalar bindings => skip all bindings except those with pragmas and retract the + -- entries into the vectorisation map for the scalar bindings + do + { traceVt "scalar bindings [skip]" $ ppr vars + ; mapM_ (undefGlobalVar . fst) bindsWOPragma + ; return (bindsWOPragma ++ newBindsWPragma, exprs') + } + Just (parBind, exprs') -> + -- vanilla case => record parallel variables and return the final bindings + do + { when parBind $ + mapM_ addGlobalParallelVar vars + ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') + } + } + ; return $ Rec newBinds + } } } + `orElseErrV` + do + { emitVt " Could NOT vectorise top-level bindings" $ ppr vars + ; return b + } + where + vars = map fst binds + noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" + + -- Replace the original top-level bindings by a values projected from the vectorised + -- closures and add any newly created hoisted top-level bindings to the group. + vectTopBindAndConvert (var, expr) inline expr' + = do + { var' <- vectTopBinder var inline expr' + ; cexpr <- tryConvert var var' expr + ; return [(var, cexpr), (var', expr')] + } + +-- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma +-- in this module. +-- +-- RESTIRCTION: Currently, we cannot use the pragma for mutually recursive definitions. +-- +vectImpBind :: (Id, CoreExpr) -> VM CoreBind +vectImpBind (var, expr) + = do + { traceVt "= Add vectorised binding to imported variable" (ppr var) + + ; var' <- vectTopBinder var inlineMe expr + ; return $ NonRec var' expr + } + +-- |Make the vectorised version of this top level binder, and add the mapping between it and the +-- original to the state. For some binder @foo@ the vectorised version is @$v_foo@ +-- +-- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of +-- 'fixV' in 'vectTopBind'. +-- +vectTopBinder :: Var -- ^ Name of the binding. + -> Inline -- ^ Whether it should be inlined, used to annotate it. + -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'. + -> VM Var -- ^ Name of the vectorised binding. +vectTopBinder var inline expr + = do { -- Vectorise the type attached to the var. + ; vty <- vectType (idType var) + + -- If there is a vectorisation declartion for this binding, make sure its type matches + ; (_, vectDecl) <- lookupVectDecl var + ; case vectDecl of + Nothing -> return () + Just (vdty, _) + | eqType vty vdty -> return () + | otherwise -> + do + { dflags <- getDynFlags + ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ + (text "Expected type" <+> ppr vty) + $$ + (text "Inferred type" <+> ppr vdty) + } + -- Make the vectorised version of binding's name, and set the unfolding used for inlining + ; var' <- liftM (`setIdUnfoldingLazily` unfolding) + $ mkVectId var vty + + -- Add the mapping between the plain and vectorised name to the state. + ; defGlobalVar var var' + + ; return var' + } + where + unfolding = case inline of + Inline arity -> mkInlineUnfolding (Just arity) expr + DontInline -> noUnfolding +{- +!!!TODO: dfuns and unfoldings: + -- Do not inline the dfun; instead give it a magic DFunFunfolding + -- See Note [ClassOp/DFun selection] + -- See also note [Single-method classes] + dfun_id_w_fun + | isNewTyCon class_tc + = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args + `setInlinePragma` dfunInlinePragma + -} + +-- |Project out the vectorised version of a binding from some closure, or return the original body +-- if that doesn't work. +-- +tryConvert :: Var -- ^Name of the original binding (eg @foo@) + -> Var -- ^Name of vectorised version of binding (eg @$vfoo@) + -> CoreExpr -- ^The original body of the binding. + -> VM CoreExpr +tryConvert var vect_var rhs + = fromVect (idType var) (Var vect_var) + `orElseErrV` + do + { emitVt " Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var) + ; return rhs + } diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs new file mode 100644 index 00000000..a897ad29 --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -0,0 +1,35 @@ +-- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser. +-- +-- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that +-- appear in code generated by the vectoriser. + +module Vectorise.Builtins ( + -- * Restrictions + mAX_DPH_SCALAR_ARGS, + + -- * Builtins + Builtins(..), + + -- * Wrapped selectors + selTy, selsTy, + selReplicate, + selTags, + selElements, + selsLength, + sumTyCon, + prodTyCon, + prodDataCon, + replicatePD_PrimVar, + emptyPD_PrimVar, + packByTagPD_PrimVar, + combinePDVar, + combinePD_PrimVar, + scalarZip, + closureCtrFun, + + -- * Initialisation + initBuiltins, initBuiltinVars, +) where + +import Vectorise.Builtins.Base +import Vectorise.Builtins.Initialise diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs new file mode 100644 index 00000000..bcd85cb1 --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -0,0 +1,217 @@ +-- |Builtin types and functions used by the vectoriser. These are all defined in +-- 'Data.Array.Parallel.Prim'. + +module Vectorise.Builtins.Base ( + -- * Hard config + mAX_DPH_PROD, + mAX_DPH_SUM, + mAX_DPH_COMBINE, + mAX_DPH_SCALAR_ARGS, + aLL_DPH_PRIM_TYCONS, + + -- * Builtins + Builtins(..), + + -- * Projections + selTy, selsTy, + selReplicate, + selTags, + selElements, + selsLength, + sumTyCon, + prodTyCon, + prodDataCon, + replicatePD_PrimVar, + emptyPD_PrimVar, + packByTagPD_PrimVar, + combinePDVar, + combinePD_PrimVar, + scalarZip, + closureCtrFun +) where + +import TysPrim +import BasicTypes +import Class +import CoreSyn +import TysWiredIn +import Type +import TyCon +import DataCon +import NameEnv +import Name +import Outputable + +import Data.Array + + +-- Cardinality of the various families of types and functions exported by the DPH library. + +mAX_DPH_PROD :: Int +mAX_DPH_PROD = 5 + +mAX_DPH_SUM :: Int +mAX_DPH_SUM = 2 + +mAX_DPH_COMBINE :: Int +mAX_DPH_COMBINE = 2 + +mAX_DPH_SCALAR_ARGS :: Int +mAX_DPH_SCALAR_ARGS = 8 + +-- Types from 'GHC.Prim' supported by DPH +-- +aLL_DPH_PRIM_TYCONS :: [Name] +aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon] + + +-- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the +-- vectoriser. +-- +data Builtins + = Builtins + { parrayTyCon :: TyCon -- ^ PArray + , pdataTyCon :: TyCon -- ^ PData + , pdatasTyCon :: TyCon -- ^ PDatas + , prClass :: Class -- ^ PR + , prTyCon :: TyCon -- ^ PR + , preprTyCon :: TyCon -- ^ PRepr + , paClass :: Class -- ^ PA + , paTyCon :: TyCon -- ^ PA + , paDataCon :: DataCon -- ^ PA + , paPRSel :: Var -- ^ PA + , replicatePDVar :: Var -- ^ replicatePD + , replicatePD_PrimVars :: NameEnv Var -- ^ replicatePD_Int# etc. + , emptyPDVar :: Var -- ^ emptyPD + , emptyPD_PrimVars :: NameEnv Var -- ^ emptyPD_Int# etc. + , packByTagPDVar :: Var -- ^ packByTagPD + , packByTagPD_PrimVars :: NameEnv Var -- ^ packByTagPD_Int# etc. + , combinePDVars :: Array Int Var -- ^ combinePD + , combinePD_PrimVarss :: Array Int (NameEnv Var) -- ^ combine2PD_Int# etc. + , scalarClass :: Class -- ^ Scalar + , scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3 + , voidTyCon :: TyCon -- ^ Void + , voidVar :: Var -- ^ void + , fromVoidVar :: Var -- ^ fromVoid + , sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3 + , wrapTyCon :: TyCon -- ^ Wrap + , pvoidVar :: Var -- ^ pvoid + , pvoidsVar :: Var -- ^ pvoids + , closureTyCon :: TyCon -- ^ :-> + , closureVar :: Var -- ^ closure + , liftedClosureVar :: Var -- ^ liftedClosure + , applyVar :: Var -- ^ $: + , liftedApplyVar :: Var -- ^ liftedApply + , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3 + , selTys :: Array Int Type -- ^ Sel2 + , selsTys :: Array Int Type -- ^ Sels2 + , selsLengths :: Array Int CoreExpr -- ^ lengthSels2 + , selReplicates :: Array Int CoreExpr -- ^ replicate2 + , selTagss :: Array Int CoreExpr -- ^ tagsSel2 + , selElementss :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1 + , liftingContext :: Var -- ^ lc + } + + +-- Projections ---------------------------------------------------------------- +-- We use these wrappers instead of indexing the `Builtin` structure directly +-- because they give nicer panic messages if the indexed thing cannot be found. + +selTy :: Int -> Builtins -> Type +selTy = indexBuiltin "selTy" selTys + +selsTy :: Int -> Builtins -> Type +selsTy = indexBuiltin "selsTy" selsTys + +selsLength :: Int -> Builtins -> CoreExpr +selsLength = indexBuiltin "selLength" selsLengths + +selReplicate :: Int -> Builtins -> CoreExpr +selReplicate = indexBuiltin "selReplicate" selReplicates + +selTags :: Int -> Builtins -> CoreExpr +selTags = indexBuiltin "selTags" selTagss + +selElements :: Int -> Int -> Builtins -> CoreExpr +selElements i j = indexBuiltin "selElements" selElementss (i, j) + +sumTyCon :: Int -> Builtins -> TyCon +sumTyCon = indexBuiltin "sumTyCon" sumTyCons + +prodTyCon :: Int -> Builtins -> TyCon +prodTyCon n _ + | n >= 2 && n <= mAX_DPH_PROD + = tupleTyCon BoxedTuple n + | otherwise + = pprPanic "prodTyCon" (ppr n) + +prodDataCon :: Int -> Builtins -> DataCon +prodDataCon n bi + = case tyConDataCons (prodTyCon n bi) of + [con] -> con + _ -> pprPanic "prodDataCon" (ppr n) + +replicatePD_PrimVar :: TyCon -> Builtins -> Var +replicatePD_PrimVar tc bi + = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc) + +emptyPD_PrimVar :: TyCon -> Builtins -> Var +emptyPD_PrimVar tc bi + = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc) + +packByTagPD_PrimVar :: TyCon -> Builtins -> Var +packByTagPD_PrimVar tc bi + = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc) + +combinePDVar :: Int -> Builtins -> Var +combinePDVar = indexBuiltin "combinePDVar" combinePDVars + +combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var +combinePD_PrimVar i tc bi + = lookupEnvBuiltin "combinePD_PrimVar" + (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc) + +scalarZip :: Int -> Builtins -> Var +scalarZip = indexBuiltin "scalarZip" scalarZips + +closureCtrFun :: Int -> Builtins -> Var +closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns + +-- | Get an element from one of the arrays of `Builtins`. +-- Panic if the indexed thing is not in the array. +indexBuiltin :: (Ix i, Outputable i) + => String -- ^ Name of the selector we've used, for panic messages. + -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`. + -> i -- ^ Index into the array. + -> Builtins + -> a +indexBuiltin fn f i bi + | inRange (bounds xs) i = xs ! i + | otherwise + = pprSorry "Vectorise.Builtins.indexBuiltin" + (vcat [ text "" + , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> + text "' is not yet implemented." + , text "This function does not appear in your source program, but it is needed" + , text "to compile your code in the backend. This is a known, current limitation" + , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" + , text "and ask what you can do to help (it might involve some GHC hacking)."]) + where xs = f bi + + +-- | Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array. +lookupEnvBuiltin :: String -- Function name for error messages + -> NameEnv a -- Name environment + -> Name -- Index into the name environment + -> a +lookupEnvBuiltin fn env n + | Just r <- lookupNameEnv env n = r + | otherwise + = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" + (vcat [ text "" + , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> + text "' is not yet implemented." + , text "This function does not appear in your source program, but it is needed" + , text "to compile your code in the backend. This is a known, current limitation" + , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" + , text "and ask what you can do to help (it might involve some GHC hacking)."]) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs new file mode 100644 index 00000000..6770103d --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -0,0 +1,232 @@ +-- Set up the data structures provided by 'Vectorise.Builtins'. + +module Vectorise.Builtins.Initialise ( + -- * Initialisation + initBuiltins, initBuiltinVars +) where + +import Vectorise.Builtins.Base + +import BasicTypes +import TysPrim +import DsMonad +import TysWiredIn +import DataCon +import TyCon +import Class +import CoreSyn +import Type +import NameEnv +import Name +import Id +import FastString +import Outputable + +import Control.Monad +import Data.Array + + +-- |Create the initial map of builtin types and functions. +-- +initBuiltins :: DsM Builtins +initBuiltins + = do { -- 'PArray: representation type for parallel arrays + ; parrayTyCon <- externalTyCon (fsLit "PArray") + + -- 'PData': type family mapping array element types to array representation types + -- Not all backends use `PDatas`. + ; pdataTyCon <- externalTyCon (fsLit "PData") + ; pdatasTyCon <- externalTyCon (fsLit "PDatas") + + -- 'PR': class of basic array operators operating on 'PData' types + ; prClass <- externalClass (fsLit "PR") + ; let prTyCon = classTyCon prClass + + -- 'PRepr': type family mapping element types to representation types + ; preprTyCon <- externalTyCon (fsLit "PRepr") + + -- 'PA': class of basic operations on arrays (parametrised by the element type) + ; paClass <- externalClass (fsLit "PA") + ; let paTyCon = classTyCon paClass + [paDataCon] = tyConDataCons paTyCon + paPRSel = classSCSelId paClass 0 + + -- Functions on array representations + ; replicatePDVar <- externalVar (fsLit "replicatePD") + ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS) + ; emptyPDVar <- externalVar (fsLit "emptyPD") + ; empty_vars <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS) + ; packByTagPDVar <- externalVar (fsLit "packByTagPD") + ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS) + ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]] + ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]] + ; combines <- mapM externalVar (map mkFastString combineNamesD) + ; combines_vars <- mapM (mapM externalVar) $ + map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA + ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars) + emptyPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars) + packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars) + combinePDVars = listArray (2, mAX_DPH_COMBINE) combines + combinePD_PrimVarss = listArray (2, mAX_DPH_COMBINE) + [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars) + | vars <- combines_vars] + + -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations + ; scalarClass <- externalClass (fsLit "Scalar") + + -- N-ary maps ('zipWith' family) + ; scalar_map <- externalVar (fsLit "scalar_map") + ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith") + ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) + ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + (scalar_map : scalar_zip2 : scalar_zips) + + -- Types and functions for generic type representations + ; voidTyCon <- externalTyCon (fsLit "Void") + ; voidVar <- externalVar (fsLit "void") + ; fromVoidVar <- externalVar (fsLit "fromVoid") + ; sum_tcs <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM) + ; let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs + ; wrapTyCon <- externalTyCon (fsLit "Wrap") + ; pvoidVar <- externalVar (fsLit "pvoid") + ; pvoidsVar <- externalVar (fsLit "pvoids#") + + -- Types and functions for closure conversion + ; closureTyCon <- externalTyCon (fsLit ":->") + ; closureVar <- externalVar (fsLit "closure") + ; liftedClosureVar <- externalVar (fsLit "liftedClosure") + ; applyVar <- externalVar (fsLit "$:") + ; liftedApplyVar <- externalVar (fsLit "liftedApply") + ; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) + ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures + + -- Types and functions for selectors + ; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM) + ; sels_tys <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM) + ; sels_length <- mapM externalFun (numbered_hash "lengthSels" 2 mAX_DPH_SUM) + ; sel_replicates <- mapM externalFun (numbered_hash "replicateSel" 2 mAX_DPH_SUM) + ; sel_tags <- mapM externalFun (numbered "tagsSel" 2 mAX_DPH_SUM) + ; sel_elements <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + ; let selTys = listArray (2, mAX_DPH_SUM) sel_tys + selsTys = listArray (2, mAX_DPH_SUM) sels_tys + selsLengths = listArray (2, mAX_DPH_SUM) sels_length + selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates + selTagss = listArray (2, mAX_DPH_SUM) sel_tags + selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements + + -- Distinct local variable + ; liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique + + ; return $ Builtins + { parrayTyCon = parrayTyCon + , pdataTyCon = pdataTyCon + , pdatasTyCon = pdatasTyCon + , preprTyCon = preprTyCon + , prClass = prClass + , prTyCon = prTyCon + , paClass = paClass + , paTyCon = paTyCon + , paDataCon = paDataCon + , paPRSel = paPRSel + , replicatePDVar = replicatePDVar + , replicatePD_PrimVars = replicatePD_PrimVars + , emptyPDVar = emptyPDVar + , emptyPD_PrimVars = emptyPD_PrimVars + , packByTagPDVar = packByTagPDVar + , packByTagPD_PrimVars = packByTagPD_PrimVars + , combinePDVars = combinePDVars + , combinePD_PrimVarss = combinePD_PrimVarss + , scalarClass = scalarClass + , scalarZips = scalarZips + , voidTyCon = voidTyCon + , voidVar = voidVar + , fromVoidVar = fromVoidVar + , sumTyCons = sumTyCons + , wrapTyCon = wrapTyCon + , pvoidVar = pvoidVar + , pvoidsVar = pvoidsVar + , closureTyCon = closureTyCon + , closureVar = closureVar + , liftedClosureVar = liftedClosureVar + , applyVar = applyVar + , liftedApplyVar = liftedApplyVar + , closureCtrFuns = closureCtrFuns + , selTys = selTys + , selsTys = selsTys + , selsLengths = selsLengths + , selReplicates = selReplicates + , selTagss = selTagss + , selElementss = selElementss + , liftingContext = liftingContext + } + } + where + suffixed :: String -> [Name] -> [FastString] + suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns] + + -- Make a list of numbered strings in some range, eg foo3, foo4, foo5 + numbered :: String -> Int -> Int -> [FastString] + numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]] + + numbered_hash :: String -> Int -> Int -> [FastString] + numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]] + + mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr) + mk_elements (i,j) + = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") + ; return ((i, j), Var v) + } + +-- |Get the mapping of names in the Prelude to names in the DPH library. +-- +initBuiltinVars :: Builtins -> DsM [(Var, Var)] +-- FIXME: must be replaced by VECTORISE pragmas!!! +initBuiltinVars (Builtins { }) + = do + cvars <- mapM externalVar cfs + return $ zip (map dataConWorkId cons) cvars + where + (cons, cfs) = unzip preludeDataCons + + preludeDataCons :: [(DataCon, FastString)] + preludeDataCons + = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]] + where + mk_tup n name = (tupleCon BoxedTuple n, name) + + +-- Auxilliary look up functions ----------------------------------------------- + +-- |Lookup a variable given its name and the module that contains it. +externalVar :: FastString -> DsM Var +externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId + + +-- |Like `externalVar` but wrap the `Var` in a `CoreExpr`. +externalFun :: FastString -> DsM CoreExpr +externalFun fs = Var <$> externalVar fs + + +-- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name. +-- Panic if there isn't one. +externalTyCon :: FastString -> DsM TyCon +externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon + + +-- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name. +externalType :: FastString -> DsM Type +externalType fs + = do tycon <- externalTyCon fs + return $ mkTyConApp tycon [] + + +-- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name. +externalClass :: FastString -> DsM Class +externalClass fs + = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon + ; case tyConClass_maybe tycon of + Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ + ptext (sLit "Data.Array.Parallel.Prim.") <> + ftext fs <+> ptext (sLit "is not a type class") + Just cls -> return cls + } diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs new file mode 100644 index 00000000..84797b13 --- /dev/null +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -0,0 +1,103 @@ +module Vectorise.Convert + ( fromVect + ) +where + +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Type.Type + +import CoreSyn +import TyCon +import Type +import TypeRep +import NameSet +import FastString +import Outputable + +import Control.Applicative +import Prelude -- avoid redundant import warning due to AMP + +-- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its +-- value. +-- +-- For functions, we eta expand the function and convert the arguments and result: + +-- For example +-- @ +-- \(x :: Double) -> +-- \(y :: Double) -> +-- ($v_foo $: x) $: y +-- @ +-- +-- We use the type of the original binding to work out how many outer lambdas to add. +-- +fromVect :: Type -- ^ The type of the original binding. + -> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@. + -> VM CoreExpr + +-- Convert the type to the core view if it isn't already. +-- +fromVect ty expr + | Just ty' <- coreView ty + = fromVect ty' expr + +-- For each function constructor in the original type we add an outer +-- lambda to bind the parameter variable, and an inner application of it. +fromVect (FunTy arg_ty res_ty) expr + = do + arg <- newLocalVar (fsLit "x") arg_ty + varg <- toVect arg_ty (Var arg) + varg_ty <- vectType arg_ty + vres_ty <- vectType res_ty + apply <- builtin applyVar + body <- fromVect res_ty + $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg] + return $ Lam arg body + +-- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e., +-- is identical to the non-vectorised version). +-- +fromVect ty expr + = identityConv ty >> return expr + +-- Convert an expression such that it evaluates to the vectorised equivalent of the value of the +-- original expression. +-- +-- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the +-- original one. +-- +toVect :: Type -> CoreExpr -> VM CoreExpr +toVect ty expr = identityConv ty >> return expr + +-- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor +-- are not altered by vectorisation as they contain no parallel arrays. +-- +identityConv :: Type -> VM () +identityConv ty + | Just ty' <- coreView ty + = identityConv ty' +identityConv (TyConApp tycon tys) + = do { mapM_ identityConv tys + ; identityConvTyCon tycon + } +identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" +identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" +identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" +identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" + +-- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any +-- parallel arrays. +-- +identityConvTyCon :: TyCon -> VM () +identityConvTyCon tc + = do + { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons + ; parray <- builtin parrayTyCon + ; if isParallel && not (tc == parray) + then noV idErr + else return () + } + where + idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs new file mode 100644 index 00000000..098e9c82 --- /dev/null +++ b/compiler/vectorise/Vectorise/Env.hs @@ -0,0 +1,234 @@ +module Vectorise.Env ( + Scope(..), + + -- * Local Environments + LocalEnv(..), + emptyLocalEnv, + + -- * Global Environments + GlobalEnv(..), + initGlobalEnv, + extendImportedVarsEnv, + extendFamEnv, + setPAFunsEnv, + setPRFunsEnv, + modVectInfo +) where + +import HscTypes +import InstEnv +import FamInstEnv +import CoreSyn +import Type +import Class +import TyCon +import DataCon +import VarEnv +import VarSet +import Var +import NameSet +import Name +import NameEnv +import FastString + + +import Data.Maybe + + +-- |Indicates what scope something (a variable) is in. +-- +data Scope a b + = Global a + | Local b + + +-- LocalEnv ------------------------------------------------------------------- + +-- |The local environment. +-- +data LocalEnv + = LocalEnv + { local_vars :: VarEnv (Var, Var) + -- ^Mapping from local variables to their vectorised and lifted versions. + + , local_tyvars :: [TyVar] + -- ^In-scope type variables. + + , local_tyvar_pa :: VarEnv CoreExpr + -- ^Mapping from tyvars to their PA dictionaries. + + , local_bind_name :: FastString + -- ^Local binding name. This is only used to generate better names for hoisted + -- expressions. + } + +-- |Create an empty local environment. +-- +emptyLocalEnv :: LocalEnv +emptyLocalEnv = LocalEnv + { local_vars = emptyVarEnv + , local_tyvars = [] + , local_tyvar_pa = emptyVarEnv + , local_bind_name = fsLit "fn" + } + + +-- GlobalEnv ------------------------------------------------------------------ + +-- |The global environment: entities that exist at top-level. +-- +data GlobalEnv + = GlobalEnv + { global_vect_avoid :: Bool + -- ^'True' implies to avoid vectorisation as far as possible. + + , global_vars :: VarEnv Var + -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation + -- map/. + + , global_parallel_vars :: VarSet + -- ^The domain of 'global_vars'. + -- + -- This information is not redundant as it is impossible to extract the domain from a + -- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that + -- do not involve parallelism — e.g., the workers of vectorised, but scalar data types. + -- In addition, workers of parallel data types that we could not vectorise also need to + -- be tracked. + + , global_vect_decls :: VarEnv (Maybe (Type, CoreExpr)) + -- ^Mapping from global variables that have a vectorisation declaration to the right-hand + -- side of that declaration and its type and mapping variables that have NOVECTORISE + -- declarations to 'Nothing'. + + , global_tycons :: NameEnv TyCon + -- ^Mapping from TyCons to their vectorised versions. The vectorised version will be + -- identical to the original version if it is not changed by vectorisation. In any case, + -- if a tycon appears in the domain of this mapping, it was successfully vectorised. + + , global_parallel_tycons :: NameSet + -- ^Type constructors whose definition directly or indirectly includes a parallel type, + -- such as '[::]'. + -- + -- NB: This information is not redundant as some types have got a mapping in + -- 'global_tycons' (to a type other than themselves) and are still not parallel. An + -- example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons' + -- (because they couldn't be vectorised), but still contain parallel types. + + , global_datacons :: NameEnv DataCon + -- ^Mapping from DataCons to their vectorised versions. + + , global_pa_funs :: NameEnv Var + -- ^Mapping from TyCons to their PA dfuns. + + , global_pr_funs :: NameEnv Var + -- ^Mapping from TyCons to their PR dfuns. + + , global_inst_env :: InstEnvs + -- ^External package inst-env & home-package inst-env for class instances. + + , global_fam_inst_env :: FamInstEnvs + -- ^External package inst-env & home-package inst-env for family instances. + + , global_bindings :: [(Var, CoreExpr)] + -- ^Hoisted bindings — temporary storage for toplevel bindings during code gen. + } + +-- |Create an initial global environment. +-- +-- We add scalar variables and type constructors identified by vectorisation pragmas already here +-- to the global table, so that we can query scalarness during vectorisation, and especially, when +-- vectorising the scalar entities' definitions themselves. +-- +initGlobalEnv :: Bool + -> VectInfo + -> [CoreVect] + -> InstEnvs + -> FamInstEnvs + -> GlobalEnv +initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs + = GlobalEnv + { global_vect_avoid = vectAvoid + , global_vars = mapVarEnv snd $ vectInfoVar info + , global_vect_decls = mkVarEnv vects + , global_parallel_vars = vectInfoParallelVars info + , global_parallel_tycons = vectInfoParallelTyCons info + , global_tycons = mapNameEnv snd $ vectInfoTyCon info + , global_datacons = mapNameEnv snd $ vectInfoDataCon info + , global_pa_funs = emptyNameEnv + , global_pr_funs = emptyNameEnv + , global_inst_env = instEnvs + , global_fam_inst_env = famInstEnvs + , global_bindings = [] + } + where + vects = [(var, Just (ty, exp)) | Vect var exp@(Var rhs_var) <- vectDecls + , let ty = varType rhs_var] ++ + -- FIXME: we currently only allow RHSes consisting of a + -- single variable to be able to obtain the type without + -- inference — see also 'TcBinds.tcVect' + [(var, Nothing) | NoVect var <- vectDecls] + + +-- Operators on Global Environments ------------------------------------------- + +-- |Extend the list of global variables in an environment. +-- +extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv +extendImportedVarsEnv ps genv + = genv { global_vars = extendVarEnvList (global_vars genv) ps } + +-- |Extend the list of type family instances. +-- +extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv +extendFamEnv new genv + = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } + where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv + +-- |Set the list of PA functions in an environment. +-- +setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv +setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps } + +-- |Set the list of PR functions in an environment. +-- +setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv +setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } + +-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files). +-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the +-- declarations for the currently compiled module; this includes variables, type constructors, and +-- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported +-- module. +-- +-- The variables explicitly include class selectors and dfuns. +-- +modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo +modVectInfo env mg_ids mg_tyCons vectDecls info + = info + { vectInfoVar = mk_env ids (global_vars env) + , vectInfoTyCon = mk_env tyCons (global_tycons env) + , vectInfoDataCon = mk_env dataCons (global_datacons env) + , vectInfoParallelVars = (global_parallel_vars env `minusVarSet` vectInfoParallelVars info) + `intersectVarSet` (mkVarSet ids) + , vectInfoParallelTyCons = global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info + } + where + vectIds = [id | Vect id _ <- vectDecls] ++ + [id | VectInst id <- vectDecls] + vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++ + [tycon | VectClass tycon <- vectDecls] + vectDataCons = concatMap tyConDataCons vectTypeTyCons + ids = mg_ids ++ vectIds ++ dataConIds ++ selIds + tyCons = mg_tyCons ++ vectTypeTyCons + dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons + dataConIds = map dataConWorkId dataCons + selIds = concat [ classAllSelIds cls + | tycon <- tyCons + , cls <- maybeToList . tyConClass_maybe $ tycon] + + -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv' + mk_env decls inspectedEnv + = mkNameEnv [(name, (decl, to)) + | decl <- decls + , let name = getName decl + , Just to <- [lookupNameEnv inspectedEnv name]] diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs new file mode 100644 index 00000000..ae7483a6 --- /dev/null +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -0,0 +1,1237 @@ +{-# LANGUAGE CPP, TupleSections #-} + +-- |Vectorisation of expressions. + +module Vectorise.Exp + ( -- * Vectorise right-hand sides of toplevel bindings + vectTopExpr + , vectTopExprs + , vectScalarFun + , vectScalarDFun + ) +where + +#include "HsVersions.h" + +import Vectorise.Type.Type +import Vectorise.Var +import Vectorise.Convert +import Vectorise.Vect +import Vectorise.Env +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Utils + +import CoreUtils +import MkCore +import CoreSyn +import CoreFVs +import Class +import DataCon +import TyCon +import TcType +import Type +import TypeRep +import Var +import VarEnv +import VarSet +import NameSet +import Id +import BasicTypes( isStrongLoopBreaker ) +import Literal +import TysPrim +import Outputable +import FastString +import DynFlags +import Util +#if __GLASGOW_HASKELL__ < 709 +import MonadUtils +#endif + +import Control.Monad +import Data.Maybe +import Data.List + + +-- Main entry point to vectorise expressions ----------------------------------- + +-- |Vectorise a polymorphic expression that forms a *non-recursive* binding. +-- +-- Return 'Nothing' if the expression is scalar; otherwise, the first component of the result +-- (which is of type 'Bool') indicates whether the expression is parallel (i.e., whether it is +-- tagged as 'VIParr'). +-- +-- We have got the non-recursive case as a special case as it doesn't require to compute +-- vectorisation information twice. +-- +vectTopExpr :: Var -> CoreExpr -> VM (Maybe (Bool, Inline, CoreExpr)) +vectTopExpr var expr + = do + { exprVI <- encapsulateScalars <=< vectAvoidInfo emptyVarSet . freeVars $ expr + ; if isVIEncaps exprVI + then + return Nothing + else do + { vExpr <- closedV $ + inBind var $ + vectAnnPolyExpr False exprVI + ; inline <- computeInline exprVI + ; return $ Just (isVIParr exprVI, inline, vectorised vExpr) + } + } + +-- Compute the inlining hint for the right-hand side of a top-level binding. +-- +computeInline :: CoreExprWithVectInfo -> VM Inline +computeInline ((_, VIDict), _) = return $ DontInline +computeInline (_, AnnTick _ expr) = computeInline expr +computeInline expr@(_, AnnLam _ _) = Inline <$> polyArity tvs + where + (tvs, _) = collectAnnTypeBinders expr +computeInline _expr = return $ DontInline + +-- |Vectorise a recursive group of top-level polymorphic expressions. +-- +-- Return 'Nothing' if the expression group is scalar; otherwise, the first component of the result +-- (which is of type 'Bool') indicates whether the expressions are parallel (i.e., whether they are +-- tagged as 'VIParr'). +-- +vectTopExprs :: [(Var, CoreExpr)] -> VM (Maybe (Bool, [(Inline, CoreExpr)])) +vectTopExprs binds + = do + { exprVIs <- mapM (vectAvoidAndEncapsulate emptyVarSet) exprs + ; if all isVIEncaps exprVIs + -- if all bindings are scalar => don't vectorise this group of bindings + then return Nothing + else do + { -- non-scalar bindings need to be vectorised + ; let areVIParr = any isVIParr exprVIs + ; revised_exprVIs <- if not areVIParr + -- if no binding is parallel => 'exprVIs' is ready for vectorisation + then return exprVIs + -- if any binding is parallel => recompute the vectorisation info + else mapM (vectAvoidAndEncapsulate (mkVarSet vars)) exprs + + ; vExprs <- zipWithM vect vars revised_exprVIs + ; return $ Just (areVIParr, vExprs) + } + } + where + (vars, exprs) = unzip binds + + vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars + + vect var exprVI + = do + { vExpr <- closedV $ + inBind var $ + vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo var) exprVI + ; inline <- computeInline exprVI + ; return (inline, vectorised vExpr) + } + +-- |Vectorise a polymorphic expression annotated with vectorisation information. +-- +-- The special case of dictionary functions is currently handled separately. (Would be neater to +-- integrate them, though!) +-- +vectAnnPolyExpr :: Bool -> CoreExprWithVectInfo -> VM VExpr +vectAnnPolyExpr loop_breaker (_, AnnTick tickish expr) + -- traverse through ticks + = vTick tickish <$> vectAnnPolyExpr loop_breaker expr +vectAnnPolyExpr loop_breaker expr + | isVIDict expr + -- special case the right-hand side of dictionary functions + = (, undefined) <$> vectDictExpr (deAnnotate expr) + | otherwise + -- collect and vectorise type abstractions; then, descent into the body + = polyAbstract tvs $ \args -> + mapVect (mkLams $ tvs ++ args) <$> vectFnExpr False loop_breaker mono + where + (tvs, mono) = collectAnnTypeBinders expr + +-- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a +-- lambda abstraction over all its free variables followed by the corresponding application to those +-- variables. We can, then, avoid the vectorisation of the ensapsulated subexpressions. +-- +-- Preconditions: +-- +-- * All free variables and the result type must be /simple/ types. +-- * The expression is sufficiently complex (to warrant special treatment). For now, that is +-- every expression that is not constant and contains at least one operation. +-- +-- +-- The user has an option to choose between aggressive and minimal vectorisation avoidance. With +-- minimal vectorisation avoidance, we only encapsulate individual scalar operations. With +-- aggressive vectorisation avoidance, we encapsulate subexpression that are as big as possible. +-- +encapsulateScalars :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo +encapsulateScalars ce@(_, AnnType _ty) + = return ce +encapsulateScalars ce@((_, VISimple), AnnVar _v) + -- NB: diverts from the paper: encapsulate scalar variables (including functions) + = liftSimpleAndCase ce +encapsulateScalars ce@(_, AnnVar _v) + = return ce +encapsulateScalars ce@(_, AnnLit _) + = return ce +encapsulateScalars ((fvs, vi), AnnTick tck expr) + = do + { encExpr <- encapsulateScalars expr + ; return ((fvs, vi), AnnTick tck encExpr) + } +encapsulateScalars ce@((fvs, vi), AnnLam bndr expr) + = do + { vectAvoid <- isVectAvoidanceAggressive + ; varsS <- allScalarVarTypeSet fvs + -- NB: diverts from the paper: we need to check the scalarness of bound variables as well, + -- as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs' + -- by encapsulation. + ; bndrsS <- allScalarVarType bndrs + ; case (vi, vectAvoid && varsS && bndrsS) of + (VISimple, True) -> liftSimpleAndCase ce + _ -> do + { encExpr <- encapsulateScalars expr + ; return ((fvs, vi), AnnLam bndr encExpr) + } + } + where + (bndrs, _) = collectAnnBndrs ce +encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2) + = do + { vectAvoid <- isVectAvoidanceAggressive + ; varsS <- allScalarVarTypeSet fvs + ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of + (VISimple, True) -> liftSimpleAndCase ce + _ -> do + { encCe1 <- encapsulateScalars ce1 + ; encCe2 <- encapsulateScalars ce2 + ; return ((fvs, vi), AnnApp encCe1 encCe2) + } + } + where + isSimpleApplication :: CoreExprWithVectInfo -> Bool + isSimpleApplication (_, AnnTick _ ce) = isSimpleApplication ce + isSimpleApplication (_, AnnCast ce _) = isSimpleApplication ce + isSimpleApplication ce | isSimple ce = True + isSimpleApplication (_, AnnApp ce1 ce2) = isSimple ce1 && isSimpleApplication ce2 + isSimpleApplication _ = False + -- + isSimple :: CoreExprWithVectInfo -> Bool + isSimple (_, AnnType {}) = True + isSimple (_, AnnVar {}) = True + isSimple (_, AnnLit {}) = True + isSimple (_, AnnTick _ ce) = isSimple ce + isSimple (_, AnnCast ce _) = isSimple ce + isSimple _ = False +encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts) + = do + { vectAvoid <- isVectAvoidanceAggressive + ; varsS <- allScalarVarTypeSet fvs + ; case (vi, vectAvoid && varsS) of + (VISimple, True) -> liftSimpleAndCase ce + _ -> do + { encScrut <- encapsulateScalars scrut + ; encAlts <- mapM encAlt alts + ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts) + } + } + where + encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr +encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2) + = do + { vectAvoid <- isVectAvoidanceAggressive + ; varsS <- allScalarVarTypeSet fvs + ; case (vi, vectAvoid && varsS) of + (VISimple, True) -> liftSimpleAndCase ce + _ -> do + { encExpr1 <- encapsulateScalars expr1 + ; encExpr2 <- encapsulateScalars expr2 + ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2) + } + } +encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr) + = do + { vectAvoid <- isVectAvoidanceAggressive + ; varsS <- allScalarVarTypeSet fvs + ; case (vi, vectAvoid && varsS) of + (VISimple, True) -> liftSimpleAndCase ce + _ -> do + { encBinds <- mapM encBind binds + ; encExpr <- encapsulateScalars expr + ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr) + } + } + where + encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr +encapsulateScalars ((fvs, vi), AnnCast expr coercion) + = do + { encExpr <- encapsulateScalars expr + ; return ((fvs, vi), AnnCast encExpr coercion) + } +encapsulateScalars _ + = panic "Vectorise.Exp.encapsulateScalars: unknown constructor" + +-- Lambda-lift the given simple expression and apply it to the abstracted free variables. +-- +-- If the expression is a case expression scrutinising anything, but a scalar type, then lift +-- each alternative individually. +-- +liftSimpleAndCase :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo +liftSimpleAndCase aexpr@((fvs, _vi), AnnCase expr bndr t alts) + = do + { vi <- vectAvoidInfoTypeOf expr + ; if (vi == VISimple) + then + liftSimple aexpr -- if the scrutinee is scalar, we need no special treatment + else do + { alts' <- mapM (\(ac, bndrs, aexpr) -> (ac, bndrs,) <$> liftSimpleAndCase aexpr) alts + ; return ((fvs, vi), AnnCase expr bndr t alts') + } + } +liftSimpleAndCase aexpr = liftSimple aexpr + +liftSimple :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo +liftSimple ((fvs, vi), AnnVar v) + | v `elemVarSet` fvs -- special case to avoid producing: (\v -> v) v + && not (isToplevel v) -- NB: if 'v' not free or is toplevel, we must get the 'VIEncaps' + = return $ ((fvs, vi), AnnVar v) +liftSimple aexpr@((fvs_orig, VISimple), expr) + = do + { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars + + ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr) + + ; return $ liftedExpr + } + where + vars = varSetElems fvs + fvs = filterVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel + + mkAnnLams :: [Var] -> VarSet -> AnnExpr' Var (VarSet, VectAvoidInfo) -> CoreExprWithVectInfo + mkAnnLams [] fvs expr = ASSERT(isEmptyVarSet fvs) + ((emptyVarSet, VIEncaps), expr) + mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delVarSet` v) (AnnLam v ((fvs, VIEncaps), expr)) + + mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo + mkAnnApps aexpr [] = aexpr + mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs + + mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo + mkAnnApp aexpr@((fvs, _vi), _expr) v + = ((fvs `extendVarSet` v, VISimple), AnnApp aexpr ((unitVarSet v, VISimple), AnnVar v)) +liftSimple aexpr + = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr) + +isToplevel :: Var -> Bool +isToplevel v | isId v = case realIdUnfolding v of + NoUnfolding -> False + OtherCon {} -> True + DFunUnfolding {} -> True + CoreUnfolding {uf_is_top = top} -> top + | otherwise = False + +-- |Vectorise an expression. +-- +vectExpr :: CoreExprWithVectInfo -> VM VExpr + +vectExpr aexpr + -- encapsulated expression of functional type => try to vectorise as a scalar subcomputation + | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr + = vectFnExpr True False aexpr + -- encapsulated constant => vectorise as a scalar constant + | isVIEncaps aexpr + = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >> + vectConst (deAnnotate aexpr) + +vectExpr (_, AnnVar v) + = vectVar v + +vectExpr (_, AnnLit lit) + = vectConst $ Lit lit + +vectExpr aexpr@(_, AnnLam _ _) + = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >> + vectFnExpr True False aexpr + + -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; + -- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint + -- happy. +-- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now? +vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) + | v == pAT_ERROR_ID + = do + { (vty, lty) <- vectAndLiftType ty + ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + } + where + err' = deAnnotate err + + -- type application (handle multiple consecutive type applications simultaneously to ensure the + -- PA dictionaries are put at the right places) +vectExpr e@(_, AnnApp _ arg) + | isAnnTypeArg arg + = vectPolyApp e + + -- Lifted literal +vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) + | Just _con <- isDataConId_maybe v + = do + { let vexpr = App (Var v) (Lit lit) + ; lexpr <- liftPD vexpr + ; return (vexpr, lexpr) + } + + -- value application (dictionary or user value) +vectExpr e@(_, AnnApp fn arg) + | isPredTy arg_ty -- dictionary application (whose result is not a dictionary) + = vectPolyApp e + | otherwise -- user value + = do + { -- vectorise the types + ; varg_ty <- vectType arg_ty + ; vres_ty <- vectType res_ty + + -- vectorise the function and argument expression + ; vfn <- vectExpr fn + ; varg <- vectExpr arg + + -- the vectorised function is a closure; apply it to the vectorised argument + ; mkClosureApp varg_ty vres_ty vfn varg + } + where + (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn + +vectExpr (_, AnnCase scrut bndr ty alts) + | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty + , isAlgTyCon tycon + = vectAlgCase tycon ty_args scrut bndr ty alts + | otherwise + = do + { dflags <- getDynFlags + ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $ + ppr scrut_ty + } + where + scrut_ty = exprType (deAnnotate scrut) + +vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) + = do + { traceVt "let binding (non-recursive)" Outputable.empty + ; vrhs <- localV $ + inBind bndr $ + vectAnnPolyExpr False rhs + ; traceVt "let body (non-recursive)" Outputable.empty + ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + ; return $ vLet (vNonRec vbndr vrhs) vbody + } + +vectExpr (_, AnnLet (AnnRec bs) body) + = do + { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do + { traceVt "let bindings (recursive)" Outputable.empty + ; vrhss <- zipWithM vect_rhs bndrs rhss + ; traceVt "let body (recursive)" Outputable.empty + ; vbody <- vectExpr body + ; return (vrhss, vbody) + } + ; return $ vLet (vRec vbndrs vrhss) vbody + } + where + (bndrs, rhss) = unzip bs + + vect_rhs bndr rhs = localV $ + inBind bndr $ + vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) rhs + +vectExpr (_, AnnTick tickish expr) + = vTick tickish <$> vectExpr expr + +vectExpr (_, AnnType ty) + = vType <$> vectType ty + +vectExpr e + = do + { dflags <- getDynFlags + ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e) + } + +-- |Vectorise an expression that *may* have an outer lambda abstraction. If the expression is marked +-- as encapsulated ('VIEncaps'), vectorise it as a scalar computation (using a generalised scalar +-- zip). +-- +-- We do not handle type variables at this point, as they will already have been stripped off by +-- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only +-- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere. +-- +vectFnExpr :: Bool -- ^If we process the RHS of a binding, whether that binding + -- should be inlined + -> Bool -- ^Whether the binding is a loop breaker + -> CoreExprWithVectInfo -- ^Expression to vectorise; must have an outer `AnnLam` + -> VM VExpr +vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body) + -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type + | isId bndr + && isPredTy (idType bndr) + = do + { vBndr <- vectBndr bndr + ; vbody <- vectFnExpr inline loop_breaker body + ; return $ mapVect (mkLams [vectorised vBndr]) vbody + } + -- encapsulated non-predicate abstraction: vectorise as a scalar computation + | isId bndr && isVIEncaps aexpr + = vectScalarFun . deAnnotate $ aexpr + -- non-predicate abstraction: vectorise as a non-scalar computation + | isId bndr + = vectLam inline loop_breaker aexpr + | otherwise + = do + { dflags <- getDynFlags + ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $ + ppr (deAnnotate aexpr) + } +vectFnExpr _ _ aexpr + -- encapsulated function: vectorise as a scalar computation + | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr + = vectScalarFun . deAnnotate $ aexpr + | otherwise + -- not an abstraction: vectorise as a non-scalar vanilla expression + -- NB: we can get here due to the recursion in the first case above and from 'vectAnnPolyExpr' + = vectExpr aexpr + +-- |Vectorise type and dictionary applications. +-- +-- These are always headed by a variable (as we don't support higher-rank polymorphism), but may +-- involve two sets of type variables and dictionaries. Consider, +-- +-- > class C a where +-- > m :: D b => b -> a +-- +-- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'. +-- +vectPolyApp :: CoreExprWithVectInfo -> VM VExpr +vectPolyApp e0 + = case e4 of + (_, AnnVar var) + -> do { -- get the vectorised form of the variable + ; vVar <- lookupVar var + ; traceVt "vectPolyApp of" (ppr var) + + -- vectorise type and dictionary arguments + ; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter) + ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner) + ; vTysOuter <- mapM vectType tysOuter + ; vTysInner <- mapM vectType tysInner + + ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter + + ; case vVar of + Local (vv, lv) + -> do { MASSERT( null dictsInner ) -- local vars cannot be class selectors + ; traceVt " LOCAL" (text "") + ; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv) + } + Global vv + | isDictComp var -- dictionary computation + -> do { -- in a dictionary computation, the innermost, non-empty set of + -- arguments are non-vectorised arguments, where no 'PA'dictionaries + -- are needed for the type variables + ; ve <- if null dictsInner + then + return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter + else + reconstructOuter + (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner) + ; traceVt " GLOBAL (dict):" (ppr ve) + ; vectConst ve + } + | otherwise -- non-dictionary computation + -> do { MASSERT( null dictsInner ) + ; ve <- reconstructOuter (Var vv) + ; traceVt " GLOBAL (non-dict):" (ppr ve) + ; vectConst ve + } + } + _ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0) + where + -- if there is only one set of variables or dictionaries, it will be the outer set + (e1, dictsOuter) = collectAnnDictArgs e0 + (e2, tysOuter) = collectAnnTypeArgs e1 + (e3, dictsInner) = collectAnnDictArgs e2 + (e4, tysInner) = collectAnnTypeArgs e3 + -- + isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var + +-- |Vectorise the body of a dfun. +-- +-- Dictionary computations are special for the following reasons. The application of dictionary +-- functions are always saturated, so there is no need to create closures. Dictionary computations +-- don't depend on array values, so they are always scalar computations whose result we can +-- replicate (instead of executing them in parallel). +-- +-- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary +-- computation. Consequently, the variable case needs to deal with cases where binders are +-- in the vectoriser environments and where that is not the case. +-- +vectDictExpr :: CoreExpr -> VM CoreExpr +vectDictExpr (Var var) + = do { mb_scope <- lookupVar_maybe var + ; case mb_scope of + Nothing -> return $ Var var -- binder from within the dict. computation + Just (Local (vVar, _)) -> return $ Var vVar -- local vectorised variable + Just (Global vVar) -> return $ Var vVar -- global vectorised variable + } +vectDictExpr (Lit lit) + = pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit) +vectDictExpr (Lam bndr e) + = Lam bndr <$> vectDictExpr e +vectDictExpr (App fn arg) + = App <$> vectDictExpr fn <*> vectDictExpr arg +vectDictExpr (Case e bndr ty alts) + = Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts + where + vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e + -- + vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon) + where + dataConErr = ptext (sLit "Cannot vectorise data constructor:") <+> ppr datacon + vectDictAltCon (LitAlt lit) = return $ LitAlt lit + vectDictAltCon DEFAULT = return DEFAULT +vectDictExpr (Let bnd body) + = Let <$> vectDictBind bnd <*> vectDictExpr body + where + vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e + vectDictBind (Rec bnds) = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds +vectDictExpr e@(Cast _e _coe) + = pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e) +vectDictExpr (Tick tickish e) + = Tick tickish <$> vectDictExpr e +vectDictExpr (Type ty) + = Type <$> vectType ty +vectDictExpr (Coercion coe) + = pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe) + +-- |Vectorise an expression of functional type, where all arguments and the result are of primitive +-- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and +-- which does not contain any subcomputations that involve parallel arrays. Such functionals do not +-- require the full blown vectorisation transformation; instead, they can be lifted by application +-- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.) +-- +-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised, +-- instead they become dictionaries of vectorised methods). We treat them differently, though see +-- "Note [Scalar dfuns]" in 'Vectorise'. +-- +vectScalarFun :: CoreExpr -> VM VExpr +vectScalarFun expr + = do + { traceVt "vectScalarFun:" (ppr expr) + ; let (arg_tys, res_ty) = splitFunTys (exprType expr) + ; mkScalarFun arg_tys res_ty expr + } + +-- Generate code for a scalar function by generating a scalar closure. If the function is a +-- dictionary function, vectorise it as dictionary code. +-- +mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr +mkScalarFun arg_tys res_ty expr + | isPredTy res_ty + = do { vExpr <- vectDictExpr expr + ; return (vExpr, unused) + } + | otherwise + = do { traceVt "mkScalarFun: " $ ppr expr $$ ptext (sLit " ::") <+> ppr (mkFunTys arg_tys res_ty) + + ; fn_var <- hoistExpr (fsLit "fn") expr DontInline + ; zipf <- zipScalars arg_tys res_ty + ; clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) + ; clo_var <- hoistExpr (fsLit "clo") clo DontInline + ; lclo <- liftPD (Var clo_var) + ; return (Var clo_var, lclo) + } + where + unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions" + +-- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma. +-- +-- In other words, all methods in that dictionary are scalar functions — to be vectorised with +-- 'vectScalarFun'. The dictionary "function" itself may be a constant, though. +-- +-- NB: You may think that we could implement this function guided by the struture of the Core +-- expression of the right-hand side of the dictionary function. We cannot proceed like this as +-- 'vectScalarDFun' must also work for *imported* dfuns, where we don't necessarily have access +-- to the Core code of the unvectorised dfun. +-- +-- Here an example — assume, +-- +-- > class Eq a where { (==) :: a -> a -> Bool } +-- > instance (Eq a, Eq b) => Eq (a, b) where { (==) = ... } +-- > {-# VECTORISE SCALAR instance Eq (a, b) } +-- +-- The unvectorised dfun for the above instance has the following signature: +-- +-- > $dEqPair :: forall a b. Eq a -> Eq b -> Eq (a, b) +-- +-- We generate the following (scalar) vectorised dfun (liberally using TH notation): +-- +-- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b) +-- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b -> +-- > D:V:Eq $(vectScalarFun True recFns +-- > [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |]) +-- +-- NB: +-- * '(,)' vectorises to '(,)' — hence, the type constructor in the result type remains the same. +-- * We share the '$(unVect di)' sub-expressions between the different selectors, but duplicate +-- the application of the unvectorised dfun, to enable the dictionary selection rules to fire. +-- +vectScalarDFun :: Var -- ^ Original dfun + -> VM CoreExpr +vectScalarDFun var + = do { -- bring the type variables into scope + ; mapM_ defLocalTyVar tvs + + -- vectorise dictionary argument types and generate variables for them + ; vTheta <- mapM vectType theta + ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta + ; let vThetaVars = varsToCoreExprs vThetaBndr + + -- vectorise superclass dictionaries and methods as scalar expressions + ; thetaVars <- mapM (newLocalVar (fsLit "d")) theta + ; thetaExprs <- zipWithM unVectDict theta vThetaVars + ; let thetaDictBinds = zipWith NonRec thetaVars thetaExprs + dict = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars + scsOps = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict]) + selIds + ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps + + -- vectorised applications of the class-dictionary data constructor + ; Just vDataCon <- lookupDataCon dataCon + ; vTys <- mapM vectType tys + ; let vBody = thetaDictBinds `mkLets` mkCoreConApps vDataCon (map Type vTys ++ vScsOps) + + ; return $ mkLams (tvs ++ vThetaBndr) vBody + } + where + ty = varType var + (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context + (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head + selIds = classAllSelIds cls + dataCon = classDataCon cls + +-- Build a value of the dictionary before vectorisation from original, unvectorised type and an +-- expression computing the vectorised dictionary. +-- +-- Given the vectorised version of a dictionary 'vd :: V:C vt1..vtn', generate code that computes +-- the unvectorised version, thus: +-- +-- > D:C op1 .. opm +-- > where +-- > opi = $(fromVect opTyi [| vSeli @vt1..vtk vd |]) +-- +-- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary. +-- +unVectDict :: Type -> CoreExpr -> VM CoreExpr +unVectDict ty e + = do { vTys <- mapM vectType tys + ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds + ; scOps <- zipWithM fromVect methTys meths + ; return $ mkCoreConApps dataCon (map Type tys ++ scOps) + } + where + (tycon, tys) = splitTyConApp ty + Just dataCon = isDataProductTyCon_maybe tycon + Just cls = tyConClass_maybe tycon + methTys = dataConInstArgTys dataCon tys + selIds = classAllSelIds cls + +-- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures. +-- +-- All non-dictionary free variables go into the closure's environment, whereas the dictionary +-- variables are passed explicit (as conventional arguments) into the body during closure +-- construction. +-- +vectLam :: Bool -- ^ Should the RHS of a binding be inlined? + -> Bool -- ^ Whether the binding is a loop breaker. + -> CoreExprWithVectInfo -- ^ Body of abstraction. + -> VM VExpr +vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _) + = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr) + + ; let (bndrs, body) = collectAnnValBinders expr + + -- grab the in-scope type variables + ; tyvars <- localTyVars + + -- collect and vectorise all /local/ free variables + ; vfvs <- readLEnv $ \env -> + [ (var, fromJust mb_vv) + | var <- varSetElems fvs + , let mb_vv = lookupVarEnv (local_vars env) var + , isJust mb_vv -- its local == is in local var env + ] + -- separate dictionary from non-dictionary variables in the free variable set + ; let (vvs_dict, vvs_nondict) = partition (isPredTy . varType . fst) vfvs + (_fvs_dict, vfvs_dict) = unzip vvs_dict + (fvs_nondict, vfvs_nondict) = unzip vvs_nondict + + -- compute the type of the vectorised closure + ; arg_tys <- mapM (vectType . idType) bndrs + ; res_ty <- vectType (exprType $ deAnnotate body) + + ; let arity = length fvs_nondict + length bndrs + vfvs_dict' = map vectorised vfvs_dict + ; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty + . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity) + $ do { -- generate the vectorised body of the lambda abstraction + ; lc <- builtin liftingContext + ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) $ vectExpr body + + ; vbody' <- break_loop lc res_ty vbody + ; return $ vLams lc vbndrs vbody' + } + } + where + maybe_inline n | inline = Inline n + | otherwise = DontInline + + -- If this is the body of a binding marked as a loop breaker, add a recursion termination test + -- to the /lifted/ version of the function body. The termination tests checks if the lifting + -- context is empty. If so, it returns an empty array of the (lifted) result type instead of + -- executing the function body. This is the test from the last line (defining \mathcal{L}') + -- in Figure 6 of HtM. + break_loop lc ty (ve, le) + | loop_breaker + = do { dflags <- getDynFlags + ; empty <- emptyPD ty + ; lty <- mkPDataType ty + ; return (ve, mkWildCase (Var lc) intPrimTy lty + [(DEFAULT, [], le), + (LitAlt (mkMachInt dflags 0), [], empty)]) + } + | otherwise = return (ve, le) +vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda" + +-- Vectorise an algebraic case expression. +-- +-- We convert +-- +-- case e :: t of v { ... } +-- +-- to +-- +-- V: let v' = e in case v' of _ { ... } +-- L: let v' = e in case v' `cast` ... of _ { ... } +-- +-- When lifting, we have to do it this way because v must have the type +-- [:V(T):] but the scrutinee must be cast to the representation type. We also +-- have to handle the case where v is a wild var correctly. +-- + +-- FIXME: this is too lazy...is it? +vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type + -> [(AltCon, [Var], CoreExprWithVectInfo)] + -> VM VExpr +vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)] + = do + { traceVt "scrutinee (DEFAULT only)" Outputable.empty + ; vscrut <- vectExpr scrut + ; (vty, lty) <- vectAndLiftType ty + ; traceVt "alternative body (DEFAULT only)" Outputable.empty + ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody + } +vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)] + = do + { traceVt "scrutinee (one shot w/o binders)" Outputable.empty + ; vscrut <- vectExpr scrut + ; (vty, lty) <- vectAndLiftType ty + ; traceVt "alternative body (one shot w/o binders)" Outputable.empty + ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) + ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody + } +vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] + = do + { traceVt "scrutinee (one shot w/ binders)" Outputable.empty + ; vexpr <- vectExpr scrut + ; (vty, lty) <- vectAndLiftType ty + ; traceVt "alternative body (one shot w/ binders)" Outputable.empty + ; (vbndr, (vbndrs, (vect_body, lift_body))) + <- vect_scrut_bndr + . vectBndrsIn bndrs + $ vectExpr body + ; let (vect_bndrs, lift_bndrs) = unzip vbndrs + ; (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) + ; vect_dc <- maybeV dataConErr (lookupDataCon dc) + + ; let vcase = mk_wild_case vscrut vty vect_dc vect_bndrs vect_body + lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body + + ; return $ vLet (vNonRec vbndr vexpr) (vcase, lcase) + } + where + vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") + | otherwise = vectBndrIn bndr + + mk_wild_case expr ty dc bndrs body + = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)] + + dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) + +vectAlgCase tycon _ty_args scrut bndr ty alts + = do + { traceVt "scrutinee (general case)" Outputable.empty + ; vexpr <- vectExpr scrut + + ; vect_tc <- vectTyCon tycon + ; (vty, lty) <- vectAndLiftType ty + + ; let arity = length (tyConDataCons vect_tc) + ; sel_ty <- builtin (selTy arity) + ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty + ; let sel = Var sel_bndr + + ; traceVt "alternatives' body (general case)" Outputable.empty + ; (vbndr, valts) <- vect_scrut_bndr + $ mapM (proc_alt arity sel vty lty) alts' + ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts + + ; (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) + + ; let (vect_bodies, lift_bodies) = unzip vbodies + + ; vdummy <- newDummyVar (exprType vect_scrut) + ; ldummy <- newDummyVar (exprType lift_scrut) + ; let vect_case = Case vect_scrut vdummy vty + (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies) + + ; lc <- builtin liftingContext + ; lbody <- combinePD vty (Var lc) sel lift_bodies + ; let lift_case = Case lift_scrut ldummy lty + [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss, + lbody)] + + ; return . vLet (vNonRec vbndr vexpr) + $ (vect_case, lift_case) + } + where + vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") + | otherwise = vectBndrIn bndr + + alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts + + cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2 + cmp DEFAULT DEFAULT = EQ + cmp DEFAULT _ = LT + cmp _ DEFAULT = GT + cmp _ _ = panic "vectAlgCase/cmp" + + proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _)) + = do + dflags <- getDynFlags + vect_dc <- maybeV dataConErr (lookupDataCon dc) + let ntag = dataConTagZ vect_dc + tag = mkDataConTag dflags vect_dc + fvs = fvs_body `delVarSetList` bndrs + + sel_tags <- liftM (`App` sel) (builtin (selTags arity)) + lc <- builtin liftingContext + elems <- builtin (selElements arity ntag) + + (vbndrs, vbody) + <- vectBndrsIn bndrs + . localV + $ do + { binds <- mapM (pack_var (Var lc) sel_tags tag) + . filter isLocalId + $ varSetElems fvs + ; traceVt "case alternative:" (ppr . deAnnotate $ body) + ; (ve, le) <- vectExpr body + ; return (ve, Case (elems `App` sel) lc lty + [(DEFAULT, [], (mkLets (concat binds) le))]) + } + -- empty <- emptyPD vty + -- return (ve, Case (elems `App` sel) lc lty + -- [(DEFAULT, [], Let (NonRec flags_var flags_expr) + -- $ mkLets (concat binds) le), + -- (LitAlt (mkMachInt 0), [], empty)]) + let (vect_bndrs, lift_bndrs) = unzip vbndrs + return (vect_dc, vect_bndrs, lift_bndrs, vbody) + where + dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) + + proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt" + + mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body) + + -- Pack a variable for a case alternative context *if* the variable is vectorised. If it + -- isn't, ignore it as scalar variables don't need to be packed. + pack_var len tags t v + = do + { r <- lookupVar_maybe v + ; case r of + Just (Local (vv, lv)) -> + do + { lv' <- cloneVar lv + ; expr <- packByTagPD (idType vv) (Var lv) len tags t + ; updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') }) + ; return [(NonRec lv' expr)] + } + _ -> return [] + } + + +-- Support to compute information for vectorisation avoidance ------------------ + +-- Annotation for Core AST nodes that describes how they should be handled during vectorisation +-- and especially if vectorisation of the corresponding computation can be avoided. +-- +data VectAvoidInfo = VIParr -- tree contains parallel computations + | VISimple -- result type is scalar & no parallel subcomputation + | VIComplex -- any result type, no parallel subcomputation + | VIEncaps -- tree encapsulated by 'liftSimple' + | VIDict -- dictionary computation (never parallel) + deriving (Eq, Show) + +-- Core expression annotated with free variables and vectorisation-specific information. +-- +type CoreExprWithVectInfo = AnnExpr Id (VarSet, VectAvoidInfo) + +-- Yield the type of an annotated core expression. +-- +annExprType :: AnnExpr Var ann -> Type +annExprType = exprType . deAnnotate + +-- Project the vectorisation information from an annotated Core expression. +-- +vectAvoidInfoOf :: CoreExprWithVectInfo -> VectAvoidInfo +vectAvoidInfoOf ((_, vi), _) = vi + +-- Is this a 'VIParr' node? +-- +isVIParr :: CoreExprWithVectInfo -> Bool +isVIParr = (== VIParr) . vectAvoidInfoOf + +-- Is this a 'VIEncaps' node? +-- +isVIEncaps :: CoreExprWithVectInfo -> Bool +isVIEncaps = (== VIEncaps) . vectAvoidInfoOf + +-- Is this a 'VIDict' node? +-- +isVIDict :: CoreExprWithVectInfo -> Bool +isVIDict = (== VIDict) . vectAvoidInfoOf + +-- 'VIParr' if either argument is 'VIParr'; otherwise, the first argument. +-- +unlessVIParr :: VectAvoidInfo -> VectAvoidInfo -> VectAvoidInfo +unlessVIParr _ VIParr = VIParr +unlessVIParr vi _ = vi + +-- 'VIParr' if either arguments vectorisation information is 'VIParr'; otherwise, the vectorisation +-- information of the first argument is produced. +-- +unlessVIParrExpr :: VectAvoidInfo -> CoreExprWithVectInfo -> VectAvoidInfo +infixl `unlessVIParrExpr` +unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2 + +-- Compute Core annotations to determine for which subexpressions we can avoid vectorisation. +-- +-- * The first argument is the set of free, local variables whose evaluation may entail parallelism. +-- +vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo +vectAvoidInfo pvs ce@(fvs, AnnVar v) + = do + { gpvs <- globalParallelVars + ; vi <- if v `elemVarSet` pvs || v `elemVarSet` gpvs + then return VIParr + else vectAvoidInfoTypeOf ce + ; viTrace ce vi [] + ; when (vi == VIParr) $ + traceVt " reason:" $ if v `elemVarSet` pvs then text "local" else + if v `elemVarSet` gpvs then text "global" else text "parallel type" + + ; return ((fvs, vi), AnnVar v) + } + +vectAvoidInfo _pvs ce@(fvs, AnnLit lit) + = do + { vi <- vectAvoidInfoTypeOf ce + ; viTrace ce vi [] + ; return ((fvs, vi), AnnLit lit) + } + +vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2) + = do + { ceVI <- vectAvoidInfoTypeOf ce + ; eVI1 <- vectAvoidInfo pvs e1 + ; eVI2 <- vectAvoidInfo pvs e2 + ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2 + -- ; viTrace ce vi [eVI1, eVI2] + ; return ((fvs, vi), AnnApp eVI1 eVI2) + } + +vectAvoidInfo pvs (fvs, AnnLam var body) + = do + { bodyVI <- vectAvoidInfo pvs body + ; varVI <- vectAvoidInfoType $ varType var + ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI + -- ; viTrace ce vi [bodyVI] + ; return ((fvs, vi), AnnLam var bodyVI) + } + +vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body) + = do + { ceVI <- vectAvoidInfoTypeOf ce + ; eVI <- vectAvoidInfo pvs e + ; isScalarTy <- isScalar $ varType var + ; (bodyVI, vi) <- if isVIParr eVI && not isScalarTy + then do -- binding is parallel + { bodyVI <- vectAvoidInfo (pvs `extendVarSet` var) body + ; return (bodyVI, VIParr) + } + else do -- binding doesn't affect parallelism + { bodyVI <- vectAvoidInfo pvs body + ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI) + } + -- ; viTrace ce vi [eVI, bodyVI] + ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI) + } + +vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) + = do + { ceVI <- vectAvoidInfoTypeOf ce + ; bndsVI <- mapM (vectAvoidInfoBnd pvs) bnds + ; parrBndrs <- map fst <$> filterM isVIParrBnd bndsVI + ; if not . null $ parrBndrs + then do -- body may trigger parallelism via at least one binding + { new_pvs <- filterM ((not <$>) . isScalar . varType) parrBndrs + ; let extendedPvs = pvs `extendVarSetList` new_pvs + ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds + ; bodyVI <- vectAvoidInfo extendedPvs body + -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI]) + ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI) + } + else do -- demanded bindings cannot trigger parallelism + { bodyVI <- vectAvoidInfo pvs body + ; let vi = ceVI `unlessVIParrExpr` bodyVI + -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI]) + ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI) + } + } + where + vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e + + isVIParrBnd (var, eVI) + = do + { isScalarTy <- isScalar (varType var) + ; return $ isVIParr eVI && not isScalarTy + } + +vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) + = do + { ceVI <- vectAvoidInfoTypeOf ce + ; eVI <- vectAvoidInfo pvs e + ; altsVI <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts + ; let alteVIs = [eVI | (_, _, eVI) <- altsVI] + vi = foldl unlessVIParrExpr ceVI (eVI:alteVIs) -- NB: same effect as in the paper + -- ; viTrace ce vi (eVI : alteVIs) + ; return ((fvs, vi), AnnCase eVI var ty altsVI) + } + where + vectAvoidInfoAlt scrutIsPar (con, bndrs, e) + = do + { allScalar <- allScalarVarType bndrs + ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs + | otherwise = pvs + ; (con, bndrs,) <$> vectAvoidInfo altPvs e + } + +vectAvoidInfo pvs (fvs, AnnCast e (fvs_ann, ann)) + = do + { eVI <- vectAvoidInfo pvs e + ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((fvs_ann, VISimple), ann)) + } + +vectAvoidInfo pvs (fvs, AnnTick tick e) + = do + { eVI <- vectAvoidInfo pvs e + ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI) + } + +vectAvoidInfo _pvs (fvs, AnnType ty) + = return ((fvs, VISimple), AnnType ty) + +vectAvoidInfo _pvs (fvs, AnnCoercion coe) + = return ((fvs, VISimple), AnnCoercion coe) + +-- Compute vectorisation avoidance information for a type. +-- +vectAvoidInfoType :: Type -> VM VectAvoidInfo +vectAvoidInfoType ty + | isPredTy ty + = return VIDict + | Just (arg, res) <- splitFunTy_maybe ty + = do + { argVI <- vectAvoidInfoType arg + ; resVI <- vectAvoidInfoType res + ; case (argVI, resVI) of + (VISimple, VISimple) -> return VISimple -- NB: diverts from the paper: scalar functions + (_ , VIDict) -> return VIDict + _ -> return $ VIComplex `unlessVIParr` argVI `unlessVIParr` resVI + } + | otherwise + = do + { parr <- maybeParrTy ty + ; if parr + then return VIParr + else do + { scalar <- isScalar ty + ; if scalar + then return VISimple + else return VIComplex + } } + +-- Compute vectorisation avoidance information for the type of a Core expression (with FVs). +-- +vectAvoidInfoTypeOf :: AnnExpr Var ann -> VM VectAvoidInfo +vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType + +-- Checks whether the type might be a parallel array type. +-- +maybeParrTy :: Type -> VM Bool +maybeParrTy ty + -- looking through newtypes + | Just ty' <- coreView ty + = (== VIParr) <$> vectAvoidInfoType ty' + -- decompose constructor applications + | Just (tc, ts) <- splitTyConApp_maybe ty + = do + { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons + ; if isParallel + then return True + else or <$> mapM maybeParrTy ts + } +maybeParrTy (ForAllTy _ ty) = maybeParrTy ty +maybeParrTy _ = return False + +-- Are the types of all variables in the 'Scalar' class or toplevel variables? +-- +-- NB: 'liftSimple' does not abstract over toplevel variables. +-- +allScalarVarType :: [Var] -> VM Bool +allScalarVarType vs = and <$> mapM isScalarOrToplevel vs + where + isScalarOrToplevel v | isToplevel v = return True + | otherwise = isScalar (varType v) + +-- Are the types of all variables in the set in the 'Scalar' class or toplevel variables? +-- +allScalarVarTypeSet :: VarSet -> VM Bool +allScalarVarTypeSet = allScalarVarType . varSetElems + +-- Debugging support +-- +viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM () +viTrace ce vi vTs + = traceVt ("vect info: " ++ show vi ++ "[" ++ + (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]") + (ppr $ deAnnotate ce) diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs new file mode 100644 index 00000000..e6a2ee17 --- /dev/null +++ b/compiler/vectorise/Vectorise/Generic/Description.hs @@ -0,0 +1,292 @@ +-- |Compute a description of the generic representation that we use for a user defined data type. +-- +-- During vectorisation, we generate a PRepr and PA instance for each user defined +-- data type. The PA dictionary contains methods to convert the user type to and +-- from our generic representation. This module computes a description of what +-- that generic representation is. +-- +module Vectorise.Generic.Description + ( CompRepr(..) + , ProdRepr(..) + , ConRepr(..) + , SumRepr(..) + , tyConRepr + , sumReprType + , compOrigType + ) +where + +import Vectorise.Utils +import Vectorise.Monad +import Vectorise.Builtins + +import CoreSyn +import DataCon +import TyCon +import Type +import Control.Monad +import Outputable + + +-- | Describes the generic representation of a data type. +-- If the data type has multiple constructors then we bundle them +-- together into a generic sum type. +data SumRepr + = -- | Data type has no data constructors. + EmptySum + + -- | Data type has a single constructor. + | UnarySum ConRepr + + -- | Data type has multiple constructors. + | Sum { -- | Representation tycon for the sum (eg Sum2) + repr_sum_tc :: TyCon + + -- | PData version of the sum tycon (eg PDataSum2) + -- This TyCon doesn't appear explicitly in the source program. + -- See Note [PData TyCons]. + , repr_psum_tc :: TyCon + + -- | PDatas version of the sum tycon (eg PDatasSum2) + , repr_psums_tc :: TyCon + + -- | Type of the selector (eg Sel2) + , repr_sel_ty :: Type + + -- | Type of multi-selector (eg Sel2s) + , repr_sels_ty :: Type + + -- | Function to get the length of a Sels of this type. + , repr_selsLength_v :: CoreExpr + + -- | Type of each data constructor. + , repr_con_tys :: [Type] + + -- | Generic representation types of each data constructor. + , repr_cons :: [ConRepr] + } + + +-- | Describes the representation type of a data constructor. +data ConRepr + = ConRepr + { repr_dc :: DataCon + , repr_prod :: ProdRepr + } + +-- | Describes the representation type of the fields \/ components of a constructor. +-- If the data constructor has multiple fields then we bundle them +-- together into a generic product type. +data ProdRepr + = -- | Data constructor has no fields. + EmptyProd + + -- | Data constructor has a single field. + | UnaryProd CompRepr + + -- | Data constructor has several fields. + | Prod { -- | Representation tycon for the product (eg Tuple2) + repr_tup_tc :: TyCon + + -- | PData version of the product tycon (eg PDataTuple2) + , repr_ptup_tc :: TyCon + + -- | PDatas version of the product tycon (eg PDatasTuple2s) + -- Not all lifted backends use `PDatas`. + , repr_ptups_tc :: TyCon + + -- | Types of each field. + , repr_comp_tys :: [Type] + + -- | Generic representation types for each field. + , repr_comps :: [CompRepr] + } + + +-- | Describes the representation type of a data constructor field. +data CompRepr + = Keep Type + CoreExpr -- PR dictionary for the type + | Wrap Type + + +------------------------------------------------------------------------------- + +-- |Determine the generic representation of a data type, given its tycon. +-- +tyConRepr :: TyCon -> VM SumRepr +tyConRepr tc + = sum_repr (tyConDataCons tc) + where + -- Build the representation type for a data type with the given constructors. + -- The representation types for each individual constructor are bundled + -- together into a generic sum type. + sum_repr :: [DataCon] -> VM SumRepr + sum_repr [] = return EmptySum + sum_repr [con] = liftM UnarySum (con_repr con) + sum_repr cons + = do let arity = length cons + rs <- mapM con_repr cons + tys <- mapM conReprType rs + + -- Get the 'Sum' tycon of this arity (eg Sum2). + sum_tc <- builtin (sumTyCon arity) + + -- Get the 'PData' and 'PDatas' tycons for the sum. + psum_tc <- pdataReprTyConExact sum_tc + psums_tc <- pdatasReprTyConExact sum_tc + + sel_ty <- builtin (selTy arity) + sels_ty <- builtin (selsTy arity) + selsLength_v <- builtin (selsLength arity) + return $ Sum + { repr_sum_tc = sum_tc + , repr_psum_tc = psum_tc + , repr_psums_tc = psums_tc + , repr_sel_ty = sel_ty + , repr_sels_ty = sels_ty + , repr_selsLength_v = selsLength_v + , repr_con_tys = tys + , repr_cons = rs + } + + -- Build the representation type for a single data constructor. + con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con)) + + -- Build the representation type for the fields of a data constructor. + -- The representation types for each individual field are bundled + -- together into a generic product type. + prod_repr :: [Type] -> VM ProdRepr + prod_repr [] = return EmptyProd + prod_repr [ty] = liftM UnaryProd (comp_repr ty) + prod_repr tys + = do let arity = length tys + rs <- mapM comp_repr tys + tys' <- mapM compReprType rs + + -- Get the Prod \/ Tuple tycon of this arity (eg Tuple2) + tup_tc <- builtin (prodTyCon arity) + + -- Get the 'PData' and 'PDatas' tycons for the product. + ptup_tc <- pdataReprTyConExact tup_tc + ptups_tc <- pdatasReprTyConExact tup_tc + + return $ Prod + { repr_tup_tc = tup_tc + , repr_ptup_tc = ptup_tc + , repr_ptups_tc = ptups_tc + , repr_comp_tys = tys' + , repr_comps = rs + } + + -- Build the representation type for a single data constructor field. + comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) + `orElseV` return (Wrap ty) + +-- |Yield the type of this sum representation. +-- +sumReprType :: SumRepr -> VM Type +sumReprType EmptySum = voidType +sumReprType (UnarySum r) = conReprType r +sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) + = return $ mkTyConApp sum_tc tys + +-- Yield the type of this constructor representation. +-- +conReprType :: ConRepr -> VM Type +conReprType (ConRepr _ r) = prodReprType r + +-- Yield the type of of this product representation. +-- +prodReprType :: ProdRepr -> VM Type +prodReprType EmptyProd = voidType +prodReprType (UnaryProd r) = compReprType r +prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) + = return $ mkTyConApp tup_tc tys + +-- Yield the type of this data constructor field \/ component representation. +-- +compReprType :: CompRepr -> VM Type +compReprType (Keep ty _) = return ty +compReprType (Wrap ty) = mkWrapType ty + +-- |Yield the original component type of a data constructor component representation. +-- +compOrigType :: CompRepr -> Type +compOrigType (Keep ty _) = ty +compOrigType (Wrap ty) = ty + + +-- Outputable instances ------------------------------------------------------- +instance Outputable SumRepr where + ppr ss + = case ss of + EmptySum + -> text "EmptySum" + + UnarySum con + -> sep [text "UnarySum", ppr con] + + Sum sumtc psumtc psumstc selty selsty selsLength contys cons + -> text "Sum" $+$ braces (nest 4 + $ sep [ text "repr_sum_tc = " <> ppr sumtc + , text "repr_psum_tc = " <> ppr psumtc + , text "repr_psums_tc = " <> ppr psumstc + , text "repr_sel_ty = " <> ppr selty + , text "repr_sels_ty = " <> ppr selsty + , text "repr_selsLength_v = " <> ppr selsLength + , text "repr_con_tys = " <> ppr contys + , text "repr_cons = " <> ppr cons]) + + +instance Outputable ConRepr where + ppr (ConRepr dc pr) + = text "ConRepr" $+$ braces (nest 4 + $ sep [ text "repr_dc = " <> ppr dc + , text "repr_prod = " <> ppr pr]) + + +instance Outputable ProdRepr where + ppr ss + = case ss of + EmptyProd + -> text "EmptyProd" + + UnaryProd cr + -> sep [text "UnaryProd", ppr cr] + + Prod tuptcs ptuptcs ptupstcs comptys comps + -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps] + + +instance Outputable CompRepr where + ppr ss + = case ss of + Keep t ce + -> text "Keep" $+$ sep [ppr t, ppr ce] + + Wrap t + -> sep [text "Wrap", ppr t] + + +-- Notes ---------------------------------------------------------------------- +{- +Note [PData TyCons] +~~~~~~~~~~~~~~~~~~~ +When PData is a type family, the compiler generates a type constructor for each +instance, which is named after the family and instance type. This type +constructor does not appear in the source program. Rather, it is implicitly +defined by the data instance. For example with: + + data family PData a + + data instance PData (Sum2 a b) + = PSum2 U.Sel2 + (PData a) + (PData b) + +The type constructor corresponding to the instance will be named 'PDataSum2', +and this is what we will get in the repr_psum_tc field of SumRepr.Sum. + +-} + diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs new file mode 100644 index 00000000..7e70f2dd --- /dev/null +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -0,0 +1,125 @@ + +module Vectorise.Generic.PADict + ( buildPADict + ) where + +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Generic.Description +import Vectorise.Generic.PAMethods ( buildPAScAndMethods ) +import Vectorise.Utils + +import BasicTypes +import CoreSyn +import CoreUtils +import CoreUnfold +import Module +import TyCon +import CoAxiom +import Type +import Id +import Var +import Name +import FastString + + +-- |Build the PA dictionary function for some type and hoist it to top level. +-- +-- The PA dictionary holds fns that convert values to and from their vectorised representations. +-- +-- @Recall the definition: +-- class PR (PRepr a) => PA a where +-- toPRepr :: a -> PRepr a +-- fromPRepr :: PRepr a -> a +-- toArrPRepr :: PData a -> PData (PRepr a) +-- fromArrPRepr :: PData (PRepr a) -> PData a +-- toArrPReprs :: PDatas a -> PDatas (PRepr a) +-- fromArrPReprs :: PDatas (PRepr a) -> PDatas a +-- +-- Example: +-- df :: forall a. PR (PRepr a) -> PA a -> PA (T a) +-- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... +-- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) +-- $dPR_df = .... +-- $toRepr :: forall a. PA a -> T a -> PRepr (T a) +-- $toPRepr = ... +-- The "..." stuff is filled in by buildPAScAndMethods +-- @ +-- +buildPADict + :: TyCon -- ^ tycon of the type being vectorised. + -> CoAxiom Unbranched + -- ^ Coercion between the type and + -- its vectorised representation. + -> TyCon -- ^ PData instance tycon + -> TyCon -- ^ PDatas instance tycon + -> SumRepr -- ^ representation used for the type being vectorised. + -> VM Var -- ^ name of the top-level dictionary function. + +buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr + = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they + -- are put in the envt, so when we need a (PA a) we can find it in + -- the envt; they don't include the silent superclass args yet + do { mod <- liftDs getModule + ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name + + -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... + ; let mk_super_ty = do { r <- mkPReprType inst_ty + ; pr_cls <- builtin prClass + ; return $ mkClassPred pr_cls [r] + } + ; super_tys <- sequence [mk_super_ty | not (null tvs)] + ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys + ; let val_args = super_args ++ args + all_args = tvs ++ val_args + + -- ...it is constant otherwise + ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] + + -- Get ids for each of the methods in the dictionary, including superclass + ; paMethodBuilders <- buildPAScAndMethods + ; method_ids <- mapM (method val_args dfun_name) paMethodBuilders + + -- Expression to build the dictionary. + ; pa_dc <- builtin paDataCon + ; let dict = mkLams all_args (mkConApp pa_dc con_args) + con_args = Type inst_ty + : map Var super_args -- the superclass dictionary is either + ++ super_consts -- lambda-bound or constant + ++ map (method_call val_args) method_ids + + -- Build the type of the dictionary function. + ; pa_cls <- builtin paClass + ; let dfun_ty = mkForAllTys tvs + $ mkFunTys (map varType val_args) + (mkClassPred pa_cls [inst_ty]) + + -- Set the unfolding for the inliner. + ; raw_dfun <- newExportedVar dfun_name dfun_ty + ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args + dfun = raw_dfun `setIdUnfolding` dfun_unf + `setInlinePragma` dfunInlinePragma + + -- Add the new binding to the top-level environment. + ; hoistBinding dfun dict + ; return dfun + } + where + tvs = tyConTyVars vect_tc + arg_tys = mkTyVarTys tvs + inst_ty = mkTyConApp vect_tc arg_tys + vect_tc_name = getName vect_tc + + method args dfun_name (name, build) + = localV + $ do expr <- build vect_tc prepr_ax pdata_tc pdatas_tc repr + let body = mkLams (tvs ++ args) expr + raw_var <- newExportedVar (method_name dfun_name name) (exprType body) + let var = raw_var + `setIdUnfolding` mkInlineUnfolding (Just (length args)) body + `setInlinePragma` alwaysInlinePragma + hoistBinding var body + return var + + method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) + method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs new file mode 100644 index 00000000..0d5d37c7 --- /dev/null +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -0,0 +1,584 @@ + +-- | Generate methods for the PA class. +-- +-- TODO: there is a large amount of redundancy here between the +-- a, PData a, and PDatas a forms. See if we can factor some of this out. +-- +module Vectorise.Generic.PAMethods + ( buildPReprTyCon + , buildPAScAndMethods + ) where + +import Vectorise.Utils +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Generic.Description +import CoreSyn +import CoreUtils +import FamInstEnv +import MkCore ( mkWildCase, mkCoreLet ) +import TyCon +import CoAxiom +import Type +import OccName +import Coercion +import MkId +import FamInst +import TysPrim( intPrimTy ) + +import DynFlags +import FastString +import MonadUtils +import Control.Monad +import Outputable + + +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst +buildPReprTyCon orig_tc vect_tc repr + = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) + rhs_ty <- sumReprType repr + prepr_tc <- builtin preprTyCon + let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty + liftDs $ newFamInst SynFamilyInst axiom + where + tyvars = tyConTyVars vect_tc + instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] + +-- buildPAScAndMethods -------------------------------------------------------- + +-- | This says how to build the PR superclass and methods of PA +-- Recall the definition of the PA class: +-- +-- @ +-- class class PR (PRepr a) => PA a where +-- toPRepr :: a -> PRepr a +-- fromPRepr :: PRepr a -> a +-- +-- toArrPRepr :: PData a -> PData (PRepr a) +-- fromArrPRepr :: PData (PRepr a) -> PData a +-- +-- toArrPReprs :: PDatas a -> PDatas (PRepr a) +-- fromArrPReprs :: PDatas (PRepr a) -> PDatas a +-- @ +-- +type PAInstanceBuilder + = TyCon -- ^ Vectorised TyCon + -> CoAxiom Unbranched + -- ^ Coercion to the representation TyCon + -> TyCon -- ^ 'PData' TyCon + -> TyCon -- ^ 'PDatas' TyCon + -> SumRepr -- ^ Description of generic representation. + -> VM CoreExpr -- ^ Instance function. + + +buildPAScAndMethods :: VM [(String, PAInstanceBuilder)] +buildPAScAndMethods + = return [ ("toPRepr", buildToPRepr) + , ("fromPRepr", buildFromPRepr) + , ("toArrPRepr", buildToArrPRepr) + , ("fromArrPRepr", buildFromArrPRepr) + , ("toArrPReprs", buildToArrPReprs) + , ("fromArrPReprs", buildFromArrPReprs)] + + +-- buildToPRepr --------------------------------------------------------------- +-- | Build the 'toRepr' method of the PA class. +buildToPRepr :: PAInstanceBuilder +buildToPRepr vect_tc repr_ax _ _ repr + = do let arg_ty = mkTyConApp vect_tc ty_args + + -- Get the representation type of the argument. + res_ty <- mkPReprType arg_ty + + -- Var to bind the argument + arg <- newLocalVar (fsLit "x") arg_ty + + -- Build the expression to convert the argument to the generic representation. + result <- to_sum (Var arg) arg_ty res_ty repr + + return $ Lam arg result + where + ty_args = mkTyVarTys (tyConTyVars vect_tc) + + wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args + + -- CoreExp to convert the given argument to the generic representation. + -- We start by doing a case branch on the possible data constructors. + to_sum :: CoreExpr -> Type -> Type -> SumRepr -> VM CoreExpr + to_sum _ _ _ EmptySum + = do void <- builtin voidVar + return $ wrap_repr_inst $ Var void + + to_sum arg arg_ty res_ty (UnarySum r) + = do (pat, vars, body) <- con_alt r + return $ mkWildCase arg arg_ty res_ty + [(pat, vars, wrap_repr_inst body)] + + to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) + = do alts <- mapM con_alt cons + let alts' = [(pat, vars, wrap_repr_inst + $ mkConApp sum_con (map Type tys ++ [body])) + | ((pat, vars, body), sum_con) + <- zip alts (tyConDataCons sum_tc)] + return $ mkWildCase arg arg_ty res_ty alts' + + con_alt (ConRepr con r) + = do (vars, body) <- to_prod r + return (DataAlt con, vars, body) + + -- CoreExp to convert data constructor fields to the generic representation. + to_prod :: ProdRepr -> VM ([Var], CoreExpr) + to_prod EmptyProd + = do void <- builtin voidVar + return ([], Var void) + + to_prod (UnaryProd comp) + = do var <- newLocalVar (fsLit "x") (compOrigType comp) + body <- to_comp (Var var) comp + return ([var], body) + + to_prod (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do vars <- newLocalVars (fsLit "x") (map compOrigType comps) + exprs <- zipWithM to_comp (map Var vars) comps + let [tup_con] = tyConDataCons tup_tc + return (vars, mkConApp tup_con (map Type tys ++ exprs)) + + -- CoreExp to convert a data constructor component to the generic representation. + to_comp :: CoreExpr -> CompRepr -> VM CoreExpr + to_comp expr (Keep _ _) = return expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfWrap expr ty + + +-- buildFromPRepr ------------------------------------------------------------- + +-- |Build the 'fromPRepr' method of the PA class. +-- +buildFromPRepr :: PAInstanceBuilder +buildFromPRepr vect_tc repr_ax _ _ repr + = do + arg_ty <- mkPReprType res_ty + arg <- newLocalVar (fsLit "x") arg_ty + + result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args (Var arg)) + repr + return $ Lam arg result + where + ty_args = mkTyVarTys (tyConTyVars vect_tc) + res_ty = mkTyConApp vect_tc ty_args + + from_sum _ EmptySum + = do dummy <- builtin fromVoidVar + return $ Var dummy `App` Type res_ty + + from_sum expr (UnarySum r) = from_con expr r + from_sum expr (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) + = do vars <- newLocalVars (fsLit "x") tys + es <- zipWithM from_con (map Var vars) cons + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt con, [var], e) + | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] + + from_con expr (ConRepr con r) + = from_prod expr (mkConApp con $ map Type ty_args) r + + from_prod _ con EmptyProd = return con + from_prod expr con (UnaryProd r) + = do e <- from_comp expr r + return $ con `App` e + + from_prod expr con (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps + }) + = do vars <- newLocalVars (fsLit "y") tys + es <- zipWithM from_comp (map Var vars) comps + let [tup_con] = tyConDataCons tup_tc + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt tup_con, vars, con `mkApps` es)] + + from_comp expr (Keep _ _) = return expr + from_comp expr (Wrap ty) = unwrapNewTypeBodyOfWrap expr ty + + +-- buildToArrRepr ------------------------------------------------------------- + +-- |Build the 'toArrRepr' method of the PA class. +-- +buildToArrPRepr :: PAInstanceBuilder +buildToArrPRepr vect_tc repr_co pdata_tc _ r + = do arg_ty <- mkPDataType el_ty + res_ty <- mkPDataType =<< mkPReprType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + + pdata_co <- mkBuiltinCo pdataTyCon + let co = mkAppCo pdata_co + . mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args + + scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) + + (vars, result) <- to_sum r + + return . Lam arg + $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty + [(DataAlt pdata_dc, vars, mkCast result co)] + where + ty_args = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc ty_args + [pdata_dc] = tyConDataCons pdata_tc + + to_sum ss + = case ss of + EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) + UnarySum r -> to_con r + Sum{} + -> do let psum_tc = repr_psum_tc ss + let [psum_con] = tyConDataCons psum_tc + (vars, exprs) <- mapAndUnzipM to_con (repr_cons ss) + sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) + return ( sel : concat vars + , wrapFamInstBody psum_tc (repr_con_tys ss) + $ mkConApp psum_con + $ map Type (repr_con_tys ss) ++ (Var sel : exprs)) + + to_prod ss + = case ss of + EmptyProd -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) + UnaryProd r + -> do pty <- mkPDataType (compOrigType r) + var <- newLocalVar (fsLit "x") pty + expr <- to_comp (Var var) r + return ([var], expr) + Prod{} + -> do let [ptup_con] = tyConDataCons (repr_ptup_tc ss) + ptys <- mapM (mkPDataType . compOrigType) (repr_comps ss) + vars <- newLocalVars (fsLit "x") ptys + exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) + return ( vars + , wrapFamInstBody (repr_ptup_tc ss) (repr_comp_tys ss) + $ mkConApp ptup_con + $ map Type (repr_comp_tys ss) ++ exprs) + + to_con (ConRepr _ r) = to_prod r + + to_comp expr (Keep _ _) = return expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDataWrap expr ty + + +-- buildFromArrPRepr ---------------------------------------------------------- + +-- |Build the 'fromArrPRepr' method for the PA class. +-- +buildFromArrPRepr :: PAInstanceBuilder +buildFromArrPRepr vect_tc repr_co pdata_tc _ r + = do arg_ty <- mkPDataType =<< mkPReprType el_ty + res_ty <- mkPDataType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + + pdata_co <- mkBuiltinCo pdataTyCon + let co = mkAppCo pdata_co + $ mkUnbranchedAxInstCo Nominal repr_co var_tys + + let scrut = mkCast (Var arg) co + + let mk_result args + = wrapFamInstBody pdata_tc var_tys + $ mkConApp pdata_con + $ map Type var_tys ++ args + + (expr, _) <- fixV $ \ ~(_, args) -> + from_sum res_ty (mk_result args) scrut r + + return $ Lam arg expr + where + var_tys = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc var_tys + [pdata_con] = tyConDataCons pdata_tc + + from_sum res_ty res expr ss + = case ss of + EmptySum -> return (res, []) + UnarySum r -> from_con res_ty res expr r + Sum {} + -> do let psum_tc = repr_psum_tc ss + let [psum_con] = tyConDataCons psum_tc + sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) + ptys <- mapM mkPDataType (repr_con_tys ss) + vars <- newLocalVars (fsLit "xs") ptys + (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) + let scrut = unwrapFamInstScrut psum_tc (repr_con_tys ss) expr + let body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt psum_con, sel : vars, res')] + return (body, Var sel : args) + + from_prod res_ty res expr ss + = case ss of + EmptyProd -> return (res, []) + UnaryProd r -> from_comp res_ty res expr r + Prod {} + -> do let ptup_tc = repr_ptup_tc ss + let [ptup_con] = tyConDataCons ptup_tc + ptys <- mapM mkPDataType (repr_comp_tys ss) + vars <- newLocalVars (fsLit "ys") ptys + (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) + let scrut = unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr + let body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt ptup_con, vars, res')] + return (body, args) + + from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r + + from_comp _ res expr (Keep _ _) = return (res, [expr]) + from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty + ; return (res, [expr']) + } + + fold f res_ty res exprs rs + = foldrM f' (res, []) (zip exprs rs) + where + f' (expr, r) (res, args) + = do (res', args') <- f res_ty res expr r + return (res', args' ++ args) + + +-- buildToArrPReprs ----------------------------------------------------------- +-- | Build the 'toArrPReprs' instance for the PA class. +-- This converts a PData of elements into the generic representation. +buildToArrPReprs :: PAInstanceBuilder +buildToArrPReprs vect_tc repr_co _ pdatas_tc r + = do + -- The argument type of the instance. + -- eg: 'PDatas (Tree a b)' + arg_ty <- mkPDatasType el_ty + + -- The result type. + -- eg: 'PDatas (PRepr (Tree a b))' + res_ty <- mkPDatasType =<< mkPReprType el_ty + + -- Variable to bind the argument to the instance + -- eg: (xss :: PDatas (Tree a b)) + varg <- newLocalVar (fsLit "xss") arg_ty + + -- Coersion to case between the (PRepr a) type and its instance. + pdatas_co <- mkBuiltinCo pdatasTyCon + let co = mkAppCo pdatas_co + . mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args + + let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) + (vars, result) <- to_sum r + + return $ Lam varg + $ mkWildCase scrut (mkTyConApp pdatas_tc ty_args) res_ty + [(DataAlt pdatas_dc, vars, mkCast result co)] + + where + -- The element type of the argument. + -- eg: 'Tree a b'. + ty_args = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc ty_args + + -- PDatas data constructor + [pdatas_dc] = tyConDataCons pdatas_tc + + to_sum ss + = case ss of + -- We can't convert data types with no data. + -- See Note: [Empty PDatas]. + EmptySum -> do dflags <- getDynFlags + return ([], errorEmptyPDatas dflags el_ty) + UnarySum r -> do dflags <- getDynFlags + to_con (errorEmptyPDatas dflags el_ty) r + + Sum{} + -> do let psums_tc = repr_psums_tc ss + let [psums_con] = tyConDataCons psums_tc + sels <- newLocalVar (fsLit "sels") (repr_sels_ty ss) + + -- Take the number of selectors to serve as the length of + -- and PDatas Void arrays in the product. See Note [Empty PDatas]. + let xSums = App (repr_selsLength_v ss) (Var sels) + + xSums_var <- newLocalVar (fsLit "xsum") intPrimTy + + (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) + return ( sels : concat vars + , wrapFamInstBody psums_tc (repr_con_tys ss) + $ mkCoreLet (NonRec xSums_var xSums) + -- mkCoreLet ensures that the let/app invariant holds + $ mkConApp psums_con + $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) + + to_prod xSums ss + = case ss of + EmptyProd + -> do pvoids <- builtin pvoidsVar + return ([], App (Var pvoids) (Var xSums) ) + + UnaryProd r + -> do pty <- mkPDatasType (compOrigType r) + var <- newLocalVar (fsLit "x") pty + expr <- to_comp (Var var) r + return ([var], expr) + + Prod{} + -> do let [ptups_con] = tyConDataCons (repr_ptups_tc ss) + ptys <- mapM (mkPDatasType . compOrigType) (repr_comps ss) + vars <- newLocalVars (fsLit "x") ptys + exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) + return ( vars + , wrapFamInstBody (repr_ptups_tc ss) (repr_comp_tys ss) + $ mkConApp ptups_con + $ map Type (repr_comp_tys ss) ++ exprs) + + to_con xSums (ConRepr _ r) + = to_prod xSums r + + to_comp expr (Keep _ _) = return expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDatasWrap expr ty + + +-- buildFromArrPReprs --------------------------------------------------------- +buildFromArrPReprs :: PAInstanceBuilder +buildFromArrPReprs vect_tc repr_co _ pdatas_tc r + = do + -- The argument type of the instance. + -- eg: 'PDatas (PRepr (Tree a b))' + arg_ty <- mkPDatasType =<< mkPReprType el_ty + + -- The result type. + -- eg: 'PDatas (Tree a b)' + res_ty <- mkPDatasType el_ty + + -- Variable to bind the argument to the instance + -- eg: (xss :: PDatas (PRepr (Tree a b))) + varg <- newLocalVar (fsLit "xss") arg_ty + + -- Build the coercion between PRepr and the instance type + pdatas_co <- mkBuiltinCo pdatasTyCon + let co = mkAppCo pdatas_co + $ mkUnbranchedAxInstCo Nominal repr_co var_tys + + let scrut = mkCast (Var varg) co + + let mk_result args + = wrapFamInstBody pdatas_tc var_tys + $ mkConApp pdatas_con + $ map Type var_tys ++ args + + (expr, _) <- fixV $ \ ~(_, args) -> + from_sum res_ty (mk_result args) scrut r + + return $ Lam varg expr + where + -- The element type of the argument. + -- eg: 'Tree a b'. + ty_args = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc ty_args + + var_tys = mkTyVarTys $ tyConTyVars vect_tc + [pdatas_con] = tyConDataCons pdatas_tc + + from_sum res_ty res expr ss + = case ss of + -- We can't convert data types with no data. + -- See Note: [Empty PDatas]. + EmptySum -> do dflags <- getDynFlags + return (res, errorEmptyPDatas dflags el_ty) + UnarySum r -> from_con res_ty res expr r + + Sum {} + -> do let psums_tc = repr_psums_tc ss + let [psums_con] = tyConDataCons psums_tc + sel <- newLocalVar (fsLit "sels") (repr_sels_ty ss) + ptys <- mapM mkPDatasType (repr_con_tys ss) + vars <- newLocalVars (fsLit "xs") ptys + (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) + let scrut = unwrapFamInstScrut psums_tc (repr_con_tys ss) expr + let body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt psums_con, sel : vars, res')] + return (body, Var sel : args) + + from_prod res_ty res expr ss + = case ss of + EmptyProd -> return (res, []) + UnaryProd r -> from_comp res_ty res expr r + Prod {} + -> do let ptups_tc = repr_ptups_tc ss + let [ptups_con] = tyConDataCons ptups_tc + ptys <- mapM mkPDatasType (repr_comp_tys ss) + vars <- newLocalVars (fsLit "ys") ptys + (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) + let scrut = unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr + let body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt ptups_con, vars, res')] + return (body, args) + + from_con res_ty res expr (ConRepr _ r) + = from_prod res_ty res expr r + + from_comp _ res expr (Keep _ _) = return (res, [expr]) + from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty + ; return (res, [expr']) + } + + fold f res_ty res exprs rs + = foldrM f' (res, []) (zip exprs rs) + where + f' (expr, r) (res, args) + = do (res', args') <- f res_ty res expr r + return (res', args' ++ args) + + +-- Notes ---------------------------------------------------------------------- +{- +Note [Empty PDatas] +~~~~~~~~~~~~~~~~~~~ +We don't support "empty" data types like the following: + + data Empty0 + data Empty1 = MkEmpty1 + data Empty2 = MkEmpty2 Empty0 + ... + +There is no parallel data associcated with these types, so there is no where +to store the length of the PDatas array with our standard representation. + +Enumerations like the following are ok: + data Bool = True | False + +The native and generic representations are: + type instance (PDatas Bool) = VPDs:Bool Sels2 + type instance (PDatas (Repr Bool)) = PSum2s Sels2 (PDatas Void) (PDatas Void) + +To take the length of a (PDatas Bool) we take the length of the contained Sels2. +When converting a (PDatas Bool) to a (PDatas (Repr Bool)) we use this length to +initialise the two (PDatas Void) arrays. + +However, with this: + data Empty1 = MkEmpty1 + +The native and generic representations would be: + type instance (PDatas Empty1) = VPDs:Empty1 + type instance (PDatas (Repr Empty1)) = PVoids Int + +The 'Int' argument of PVoids is supposed to store the length of the PDatas +array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we +need to come up with a value for it, but there isn't one. + +To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's +too much hassle and there's no point running a parallel computation on no +data anyway. +-} +errorEmptyPDatas :: DynFlags -> Type -> a +errorEmptyPDatas dflags tc + = cantVectorise dflags "Vectorise.PAMethods" + $ vcat [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc) + , text "Data types to be vectorised must contain at least one constructor" + , text "with at least one field." ] diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs new file mode 100644 index 00000000..387d49c3 --- /dev/null +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -0,0 +1,161 @@ + +-- | Build instance tycons for the PData and PDatas type families. +-- +-- TODO: the PData and PDatas cases are very similar. +-- We should be able to factor out the common parts. +module Vectorise.Generic.PData + ( buildPDataTyCon + , buildPDatasTyCon ) +where + +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Generic.Description +import Vectorise.Utils +import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) + +import BasicTypes +import BuildTyCl +import DataCon +import TyCon +import Type +import FamInst +import FamInstEnv +import TcMType +import Name +import Util +import MonadUtils +import Control.Monad + + +-- buildPDataTyCon ------------------------------------------------------------ +-- | Build the PData instance tycon for a given type constructor. +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst +buildPDataTyCon orig_tc vect_tc repr + = fixV $ \fam_inst -> + do let repr_tc = dataFamInstRepTyCon fam_inst + name' <- mkLocalisedName mkPDataTyConOcc orig_name + rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr + pdata <- builtin pdataTyCon + buildDataFamInst name' pdata vect_tc rhs + where + orig_name = tyConName orig_tc + +buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst +buildDataFamInst name' fam_tc vect_tc rhs + = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' + + ; (_, tyvars') <- liftDs $ tcInstSigTyVarsLoc (getSrcSpan name') tyvars + ; let ax = mkSingleCoAxiom axiom_name tyvars' fam_tc pat_tys rep_ty + tys' = mkTyVarTys tyvars' + rep_ty = mkTyConApp rep_tc tys' + pat_tys = [mkTyConApp vect_tc tys'] + rep_tc = buildAlgTyCon name' + tyvars' + (map (const Nominal) tyvars') + Nothing + [] -- no stupid theta + rhs + rec_flag -- FIXME: is this ok? + False -- Not promotable + False -- not GADT syntax + (FamInstTyCon ax fam_tc pat_tys) + ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } + where + tyvars = tyConTyVars vect_tc + rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) + +buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs +buildPDataTyConRhs orig_name vect_tc repr_tc repr + = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr + return $ DataTyCon { data_cons = [data_con], is_enum = False } + + +buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon +buildPDataDataCon orig_name vect_tc repr_tc repr + = do let tvs = tyConTyVars vect_tc + dc_name <- mkLocalisedName mkPDataDataConOcc orig_name + comp_tys <- mkSumTys repr_sel_ty mkPDataType repr + fam_envs <- readGEnv global_fam_inst_env + liftDs $ buildDataCon fam_envs dc_name + False -- not infix + (map (const HsNoBang) comp_tys) + [] -- no field labels + tvs + [] -- no existentials + [] -- no eq spec + [] -- no context + comp_tys + (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) + repr_tc + + +-- buildPDatasTyCon ----------------------------------------------------------- +-- | Build the PDatas instance tycon for a given type constructor. +buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst +buildPDatasTyCon orig_tc vect_tc repr + = fixV $ \fam_inst -> + do let repr_tc = dataFamInstRepTyCon fam_inst + name' <- mkLocalisedName mkPDatasTyConOcc orig_name + rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr + pdatas <- builtin pdatasTyCon + buildDataFamInst name' pdatas vect_tc rhs + where + orig_name = tyConName orig_tc + +buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs +buildPDatasTyConRhs orig_name vect_tc repr_tc repr + = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr + return $ DataTyCon { data_cons = [data_con], is_enum = False } + + +buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon +buildPDatasDataCon orig_name vect_tc repr_tc repr + = do let tvs = tyConTyVars vect_tc + dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name + + comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr + fam_envs <- readGEnv global_fam_inst_env + liftDs $ buildDataCon fam_envs dc_name + False -- not infix + (map (const HsNoBang) comp_tys) + [] -- no field labels + tvs + [] -- no existentials + [] -- no eq spec + [] -- no context + comp_tys + (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) + repr_tc + + +-- Utils ---------------------------------------------------------------------- +-- | Flatten a SumRepr into a list of data constructor types. +mkSumTys + :: (SumRepr -> Type) + -> (Type -> VM Type) + -> SumRepr + -> VM [Type] + +mkSumTys repr_selX_ty mkTc repr + = sum_tys repr + where + sum_tys EmptySum = return [] + sum_tys (UnarySum r) = con_tys r + sum_tys d@(Sum { repr_cons = cons }) + = liftM (repr_selX_ty d :) (concatMapM con_tys cons) + + con_tys (ConRepr _ r) = prod_tys r + + prod_tys EmptyProd = return [] + prod_tys (UnaryProd r) = liftM singleton (comp_ty r) + prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps + + comp_ty r = mkTc (compOrigType r) + +{- +mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) +mk_fam_inst fam_tc arg_tc + = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) +-} + diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs new file mode 100644 index 00000000..3e6c33ac --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -0,0 +1,198 @@ +module Vectorise.Monad ( + module Vectorise.Monad.Base, + module Vectorise.Monad.Naming, + module Vectorise.Monad.Local, + module Vectorise.Monad.Global, + module Vectorise.Monad.InstEnv, + initV, + + -- * Builtins + liftBuiltinDs, + builtin, + builtins, + + -- * Variables + lookupVar, + lookupVar_maybe, + addGlobalParallelVar, + addGlobalParallelTyCon, +) where + +import Vectorise.Monad.Base +import Vectorise.Monad.Naming +import Vectorise.Monad.Local +import Vectorise.Monad.Global +import Vectorise.Monad.InstEnv +import Vectorise.Builtins +import Vectorise.Env + +import CoreSyn +import DsMonad +import HscTypes hiding ( MonadThings(..) ) +import DynFlags +import MonadUtils (liftIO) +import InstEnv +import Class +import TyCon +import NameSet +import VarSet +import VarEnv +import Var +import Id +import Name +import ErrUtils +import Outputable +import Module + + +-- |Run a vectorisation computation. +-- +initV :: HscEnv + -> ModGuts + -> VectInfo + -> VM a + -> IO (Maybe (VectInfo, a)) +initV hsc_env guts info thing_inside + = do { dumpIfVtTrace "Incoming VectInfo" (ppr info) + + ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) + ; (_, Just res) <- initDs hsc_env (mg_module guts) + (mg_rdr_env guts) type_env + (mg_fam_inst_env guts) go + + ; case res of + Nothing + -> dumpIfVtTrace "Vectorisation FAILED!" empty + Just (info', _) + -> dumpIfVtTrace "Outgoing VectInfo" (ppr info') + + ; return res + } + where + dflags = hsc_dflags hsc_env + + dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace + + bindsToIds (NonRec v _) = [v] + bindsToIds (Rec binds) = map fst binds + + ids = concatMap bindsToIds (mg_binds guts) + + go + = do { -- set up tables of builtin entities + ; builtins <- initBuiltins + ; builtin_vars <- initBuiltinVars builtins + + -- set up class and type family envrionments + ; eps <- liftIO $ hscEPS hsc_env + ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) + instEnvs = InstEnvs (eps_inst_env eps) + (mg_inst_env guts) + (mkModuleSet (dep_orphs (mg_deps guts))) + builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all 'PA' and.. + builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances + + -- construct the initial global environment + ; let genv = extendImportedVarsEnv builtin_vars + . setPAFunsEnv builtin_pas + . setPRFunsEnv builtin_prs + $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) + info (mg_vect_decls guts) instEnvs famInstEnvs + + -- perform vectorisation + ; r <- runVM thing_inside builtins genv emptyLocalEnv + ; case r of + Yes genv _ x -> return $ Just (new_info genv, x) + No reason -> do { unqual <- mkPrintUnqualifiedDs + ; liftIO $ + printInfoForUser dflags unqual $ + mkDumpDoc "Warning: vectorisation failure:" reason + ; return Nothing + } + } + + new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info + + -- For a given DPH class, produce a mapping from type constructor (in head position) to the + -- instance dfun for that type constructor and class. (DPH class instances cannot overlap in + -- head constructors.) + -- + initClassDicts :: InstEnvs -> Class -> [(Name, Var)] + initClassDicts insts cls = map find $ classInstances insts cls + where + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic invalidInstance (ppr i) + + invalidInstance = "Invalid DPH instance (overlapping in head constructor)" + + +-- Builtins ------------------------------------------------------------------- + +-- |Lift a desugaring computation using the `Builtins` into the vectorisation monad. +-- +liftBuiltinDs :: (Builtins -> DsM a) -> VM a +liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)} + +-- |Project something from the set of builtins. +-- +builtin :: (Builtins -> a) -> VM a +builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi)) + +-- |Lift a function using the `Builtins` into the vectorisation monad. +-- +builtins :: (a -> Builtins -> b) -> VM (a -> b) +builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi)) + + +-- Var ------------------------------------------------------------------------ + +-- |Lookup the vectorised, and if local, also the lifted version of a variable. +-- +-- * If it's in the global environment we get the vectorised version. +-- * If it's in the local environment we get both the vectorised and lifted version. +-- +lookupVar :: Var -> VM (Scope Var (Var, Var)) +lookupVar v + = do { mb_res <- lookupVar_maybe v + ; case mb_res of + Just x -> return x + Nothing -> + do dflags <- getDynFlags + dumpVar dflags v + } + +lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var))) +lookupVar_maybe v + = do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v + ; case r of + Just e -> return $ Just (Local e) + Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v) + } + +dumpVar :: DynFlags -> Var -> a +dumpVar dflags var + | Just _ <- isClassOpId_maybe var + = cantVectorise dflags "ClassOpId not vectorised:" (ppr var) + | otherwise + = cantVectorise dflags "Variable not vectorised:" (ppr var) + + +-- Global parallel entities ---------------------------------------------------- + +-- |Mark the given variable as parallel — i.e., executing the associated code might involve +-- parallel array computations. +-- +addGlobalParallelVar :: Var -> VM () +addGlobalParallelVar var + = do { traceVt "addGlobalParallelVar" (ppr var) + ; updGEnv $ \env -> env{global_parallel_vars = extendVarSet (global_parallel_vars env) var} + } + +-- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays. +-- +addGlobalParallelTyCon :: TyCon -> VM () +addGlobalParallelTyCon tycon + = do { traceVt "addGlobalParallelTyCon" (ppr tycon) + ; updGEnv $ \env -> + env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)} + } diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs new file mode 100644 index 00000000..3cb6adb7 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -0,0 +1,246 @@ +-- |The Vectorisation monad. + +module Vectorise.Monad.Base ( + -- * The Vectorisation Monad + VResult(..), + VM(..), + + -- * Lifting + liftDs, + + -- * Error Handling + cantVectorise, + maybeCantVectorise, + maybeCantVectoriseM, + + -- * Debugging + emitVt, traceVt, dumpOptVt, dumpVt, + + -- * Control + noV, traceNoV, + ensureV, traceEnsureV, + onlyIfV, + tryV, tryErrV, + maybeV, traceMaybeV, + orElseV, orElseErrV, + fixV, +) where + +import Vectorise.Builtins +import Vectorise.Env + +import DsMonad +import TcRnMonad +import ErrUtils +import Outputable +import DynFlags + +import Control.Monad + + +-- The Vectorisation Monad ---------------------------------------------------- + +-- |Vectorisation can either succeed with new envionment and a value, or return with failure +-- (including a description of the reason for failure). +-- +data VResult a + = Yes GlobalEnv LocalEnv a + | No SDoc + +newtype VM a + = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) } + +instance Monad VM where + return x = VM $ \_ genv lenv -> return (Yes genv lenv x) + VM p >>= f = VM $ \bi genv lenv -> do + r <- p bi genv lenv + case r of + Yes genv' lenv' x -> runVM (f x) bi genv' lenv' + No reason -> return $ No reason + +instance Applicative VM where + pure = return + (<*>) = ap + +instance Functor VM where + fmap = liftM + +instance MonadIO VM where + liftIO = liftDs . liftIO + +instance HasDynFlags VM where + getDynFlags = liftDs getDynFlags + +-- Lifting -------------------------------------------------------------------- + +-- |Lift a desugaring computation into the vectorisation monad. +-- +liftDs :: DsM a -> VM a +liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) } + + +-- Error Handling ------------------------------------------------------------- + +-- |Throw a `pgmError` saying we can't vectorise something. +-- +cantVectorise :: DynFlags -> String -> SDoc -> a +cantVectorise dflags s d = pgmError + . showSDoc dflags + $ vcat [text "*** Vectorisation error ***", + nest 4 $ sep [text s, nest 4 d]] + +-- |Like `fromJust`, but `pgmError` on Nothing. +-- +maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a +maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d +maybeCantVectorise _ _ _ (Just x) = x + +-- |Like `maybeCantVectorise` but in a `Monad`. +-- +maybeCantVectoriseM :: (Monad m, HasDynFlags m) + => String -> SDoc -> m (Maybe a) -> m a +maybeCantVectoriseM s d p + = do + r <- p + case r of + Just x -> return x + Nothing -> + do dflags <- getDynFlags + cantVectorise dflags s d + + +-- Debugging ------------------------------------------------------------------ + +-- |Output a trace message if -ddump-vt-trace is active. +-- +emitVt :: String -> SDoc -> VM () +emitVt herald doc + = liftDs $ do + dflags <- getDynFlags + liftIO . printInfoForUser dflags alwaysQualify $ + hang (text herald) 2 doc + +-- |Output a trace message if -ddump-vt-trace is active. +-- +traceVt :: String -> SDoc -> VM () +traceVt herald doc + = do dflags <- getDynFlags + when (1 <= traceLevel dflags) $ + liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc + +-- |Dump the given program conditionally. +-- +dumpOptVt :: DumpFlag -> String -> SDoc -> VM () +dumpOptVt flag header doc + = do { b <- liftDs $ doptM flag + ; if b + then dumpVt header doc + else return () + } + +-- |Dump the given program unconditionally. +-- +dumpVt :: String -> SDoc -> VM () +dumpVt header doc + = do { unqual <- liftDs mkPrintUnqualifiedDs + ; dflags <- liftDs getDynFlags + ; liftIO $ printInfoForUser dflags unqual (mkDumpDoc header doc) + } + + +-- Control -------------------------------------------------------------------- + +-- |Return some result saying we've failed. +-- +noV :: SDoc -> VM a +noV reason = VM $ \_ _ _ -> return $ No reason + +-- |Like `traceNoV` but also emit some trace message to stderr. +-- +traceNoV :: String -> SDoc -> VM a +traceNoV s d = pprTrace s d $ noV d + +-- |If `True` then carry on, otherwise fail. +-- +ensureV :: SDoc -> Bool -> VM () +ensureV reason False = noV reason +ensureV _reason True = return () + +-- |Like `ensureV` but if we fail then emit some trace message to stderr. +-- +traceEnsureV :: String -> SDoc -> Bool -> VM () +traceEnsureV s d False = traceNoV s d +traceEnsureV _ _ True = return () + +-- |If `True` then return the first argument, otherwise fail. +-- +onlyIfV :: SDoc -> Bool -> VM a -> VM a +onlyIfV reason b p = ensureV reason b >> p + +-- |Try some vectorisation computaton. +-- +-- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a +-- failure message. +-- +tryErrV :: VM a -> VM (Maybe a) +tryErrV (VM p) = VM $ \bi genv lenv -> + do + r <- p bi genv lenv + case r of + Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) + No reason -> do { unqual <- mkPrintUnqualifiedDs + ; dflags <- getDynFlags + ; liftIO $ + printInfoForUser dflags unqual $ + text "Warning: vectorisation failure:" <+> reason + ; return (Yes genv lenv Nothing) + } + +-- |Try some vectorisation computaton. +-- +-- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a +-- failure message. +-- +tryV :: VM a -> VM (Maybe a) +tryV (VM p) = VM $ \bi genv lenv -> + do + r <- p bi genv lenv + case r of + Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) + No _reason -> return (Yes genv lenv Nothing) + +-- |If `Just` then return the value, otherwise fail. +-- +maybeV :: SDoc -> VM (Maybe a) -> VM a +maybeV reason p = maybe (noV reason) return =<< p + +-- |Like `maybeV` but emit a message to stderr if we fail. +-- +traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a +traceMaybeV s d p = maybe (traceNoV s d) return =<< p + +-- |Try the first computation, +-- +-- * if it succeeds then take the returned value, +-- * if it fails then run the second computation instead while emitting a failure message. +-- +orElseErrV :: VM a -> VM a -> VM a +orElseErrV p q = maybe q return =<< tryErrV p + +-- |Try the first computation, +-- +-- * if it succeeds then take the returned value, +-- * if it fails then run the second computation instead without emitting a failure message. +-- +orElseV :: VM a -> VM a -> VM a +orElseV p q = maybe q return =<< tryV p + +-- |Fixpoint in the vectorisation monad. +-- +fixV :: (a -> VM a) -> VM a +fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv ) + where + -- NOTE: It is essential that we are lazy in r above so do not replace + -- calls to this function by an explicit case. + unYes (Yes _ _ x) = x + unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs new file mode 100644 index 00000000..14333055 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -0,0 +1,238 @@ +-- Operations on the global state of the vectorisation monad. + +module Vectorise.Monad.Global ( + readGEnv, + setGEnv, + updGEnv, + + -- * Configuration + isVectAvoidanceAggressive, + + -- * Vars + defGlobalVar, undefGlobalVar, + + -- * Vectorisation declarations + lookupVectDecl, + + -- * Scalars + globalParallelVars, globalParallelTyCons, + + -- * TyCons + lookupTyCon, + defTyConName, defTyCon, globalVectTyCons, + + -- * Datacons + lookupDataCon, + defDataCon, + + -- * PA Dictionaries + lookupTyConPA, + defTyConPAs, + + -- * PR Dictionaries + lookupTyConPR +) where + +import Vectorise.Monad.Base +import Vectorise.Env + +import CoreSyn +import Type +import TyCon +import DataCon +import DynFlags +import NameEnv +import NameSet +import Name +import VarEnv +import VarSet +import Var as Var +import FastString +import Outputable + + +-- Global Environment --------------------------------------------------------- + +-- |Project something from the global environment. +-- +readGEnv :: (GlobalEnv -> a) -> VM a +readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv)) + +-- |Set the value of the global environment. +-- +setGEnv :: GlobalEnv -> VM () +setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ()) + +-- |Update the global environment using the provided function. +-- +updGEnv :: (GlobalEnv -> GlobalEnv) -> VM () +updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) + + +-- Configuration -------------------------------------------------------------- + +-- |Should we avoid as much vectorisation as possible? +-- +-- Set by '-f[no]-vectorisation-avoidance' +-- +isVectAvoidanceAggressive :: VM Bool +isVectAvoidanceAggressive = readGEnv global_vect_avoid + + +-- Vars ----------------------------------------------------------------------- + +-- |Add a mapping between a global var and its vectorised version to the state. +-- +defGlobalVar :: Var -> Var -> VM () +defGlobalVar v v' + = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') + + -- check for duplicate vectorisation + ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v + ; case currentDef of + Just old_v' -> + do dflags <- getDynFlags + cantVectorise dflags "Variable is already vectorised:" $ + ppr v <+> moduleOf v old_v' + Nothing -> return () + + ; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' } + } + where + moduleOf var var' | var == var' + = ptext (sLit "vectorises to itself") + | Just mod <- nameModule_maybe (Var.varName var') + = ptext (sLit "in module") <+> ppr mod + | otherwise + = ptext (sLit "in the current module") + +-- |Remove the mapping of a variable in the vectorisation map. +-- +undefGlobalVar :: Var -> VM () +undefGlobalVar v + = do + { traceVt "REMOVING global var mapping:" (ppr v) + ; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v } + } + + +-- Vectorisation declarations ------------------------------------------------- + +-- |Check whether a variable has a vectorisation declaration. +-- +-- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration. +-- The second component contains the given type and expression in case of a 'VECTORISE' declaration. +-- +lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr)) +lookupVectDecl var + = readGEnv $ \env -> + case lookupVarEnv (global_vect_decls env) var of + Nothing -> (False, Nothing) + Just Nothing -> (True, Nothing) + Just vectDecl -> (False, vectDecl) + + +-- Parallel entities ----------------------------------------------------------- + +-- |Get the set of global parallel variables. +-- +globalParallelVars :: VM VarSet +globalParallelVars = readGEnv global_parallel_vars + +-- |Get the set of all parallel type constructors (those that may embed parallelism) including both +-- both those parallel type constructors declared in an imported module and those declared in the +-- current module. +-- +globalParallelTyCons :: VM NameSet +globalParallelTyCons = readGEnv global_parallel_tycons + + +-- TyCons --------------------------------------------------------------------- + +-- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment +-- contains a vectorised version if the original `TyCon` embeds any parallel arrays. +-- +lookupTyCon :: TyCon -> VM (Maybe TyCon) +lookupTyCon tc + = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) + +-- |Add a mapping between plain and vectorised `TyCon`s to the global environment. +-- +-- The second argument is only to enable tracing for (mutually) recursively defined type +-- constructors, where we /must not/ pull at the vectorised type constructors (because that would +-- pull too early at the recursive knot). +-- +defTyConName :: TyCon -> Name -> TyCon -> VM () +defTyConName tc nameOfTc' tc' + = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') + + -- check for duplicate vectorisation + ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) + ; case currentDef of + Just old_tc' -> + do dflags <- getDynFlags + cantVectorise dflags "Type constructor or class is already vectorised:" $ + ppr tc <+> moduleOf tc old_tc' + Nothing -> return () + + ; updGEnv $ \env -> + env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' } + } + where + moduleOf tc tc' | tc == tc' + = ptext (sLit "vectorises to itself") + | Just mod <- nameModule_maybe (tyConName tc') + = ptext (sLit "in module") <+> ppr mod + | otherwise + = ptext (sLit "in the current module") + +-- |Add a mapping between plain and vectorised `TyCon`s to the global environment. +-- +defTyCon :: TyCon -> TyCon -> VM () +defTyCon tc tc' = defTyConName tc (tyConName tc') tc' + +-- |Get the set of all vectorised type constructors. +-- +globalVectTyCons :: VM (NameEnv TyCon) +globalVectTyCons = readGEnv global_tycons + + +-- DataCons ------------------------------------------------------------------- + +-- |Lookup the vectorised version of a `DataCon` from the global environment. +-- +lookupDataCon :: DataCon -> VM (Maybe DataCon) +lookupDataCon dc + | isTupleTyCon (dataConTyCon dc) + = return (Just dc) + | otherwise + = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc) + +-- |Add the mapping between plain and vectorised `DataCon`s to the global environment. +-- +defDataCon :: DataCon -> DataCon -> VM () +defDataCon dc dc' = updGEnv $ \env -> + env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' } + + +-- 'PA' dictionaries ------------------------------------------------------------ + +-- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment. +-- +lookupTyConPA :: TyCon -> VM (Maybe Var) +lookupTyConPA tc + = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc) + +-- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global +-- environment. +-- +defTyConPAs :: [(TyCon, Var)] -> VM () +defTyConPAs ps = updGEnv $ \env -> + env { global_pa_funs = extendNameEnvList (global_pa_funs env) + [(tyConName tc, pa) | (tc, pa) <- ps] } + + +-- PR Dictionaries ------------------------------------------------------------ + +lookupTyConPR :: TyCon -> VM (Maybe Var) +lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc) diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs new file mode 100644 index 00000000..a97f319b --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} + +module Vectorise.Monad.InstEnv + ( existsInst + , lookupInst + , lookupFamInst + ) +where + +import Vectorise.Monad.Global +import Vectorise.Monad.Base +import Vectorise.Env + +import DynFlags +import FamInstEnv +import InstEnv +import Class +import Type +import TyCon +import Outputable +import Util + + +#include "HsVersions.h" + + +-- Check whether a unique class instance for a given class and type arguments exists. +-- +existsInst :: Class -> [Type] -> VM Bool +existsInst cls tys + = do { instEnv <- readGEnv global_inst_env + ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv cls tys) + } + +-- Look up the dfun of a class instance. +-- +-- The match must be unique —i.e., match exactly one instance— but the +-- type arguments used for matching may be more specific than those of +-- the class instance declaration. The found class instances must not have +-- any type variables in the instance context that do not appear in the +-- instances head (i.e., no flexi vars); for details for what this means, +-- see the docs at InstEnv.lookupInstEnv. +-- +lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) +lookupInst cls tys + = do { instEnv <- readGEnv global_inst_env + ; case lookupUniqueInstEnv instEnv cls tys of + Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys) + Left err -> + do dflags <- getDynFlags + cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err + } + +-- Look up a family instance. +-- +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of +-- the family instance declaration. +-- +-- Return the family instance and its type instance. For example, if we have +-- +-- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int') +-- +-- then we have a coercion (ie, type instance of family instance coercion) +-- +-- :Co:R42T Int :: T [Int] ~ :R42T Int +-- +-- which implies that :R42T was declared as 'data instance T [a]'. +-- +lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch +lookupFamInst tycon tys + = ASSERT( isOpenFamilyTyCon tycon ) + do { instEnv <- readGEnv global_fam_inst_env + ; case lookupFamInstEnv instEnv tycon tys of + [match] -> return match + _other -> + do dflags <- getDynFlags + cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: " + (ppr $ mkTyConApp tycon tys) + } diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs new file mode 100644 index 00000000..6816627f --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Local.hs @@ -0,0 +1,104 @@ +module Vectorise.Monad.Local + ( readLEnv + , setLEnv + , updLEnv + , localV + , closedV + , getBindName + , inBind + , lookupTyVarPA + , defLocalTyVar + , defLocalTyVarWithPA + , localTyVars + ) +where + +import Vectorise.Monad.Base +import Vectorise.Env + +import CoreSyn +import Name +import VarEnv +import Var +import FastString + +-- Local Environment ---------------------------------------------------------- + +-- |Project something from the local environment. +-- +readLEnv :: (LocalEnv -> a) -> VM a +readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv)) + +-- |Set the local environment. +-- +setLEnv :: LocalEnv -> VM () +setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ()) + +-- |Update the environment using the provided function. +-- +updLEnv :: (LocalEnv -> LocalEnv) -> VM () +updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) + +-- |Perform a computation in its own local environment. +-- This does not alter the environment of the current state. +-- +localV :: VM a -> VM a +localV p + = do + { env <- readLEnv id + ; x <- p + ; setLEnv env + ; return x + } + +-- |Perform a computation in an empty local environment. +-- +closedV :: VM a -> VM a +closedV p + = do + { env <- readLEnv id + ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) + ; x <- p + ; setLEnv env + ; return x + } + +-- |Get the name of the local binding currently being vectorised. +-- +getBindName :: VM FastString +getBindName = readLEnv local_bind_name + +-- |Run a vectorisation computation in a local environment, +-- with this id set as the current binding. +-- +inBind :: Id -> VM a -> VM a +inBind id p + = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) } + p + +-- |Lookup a PA tyvars from the local environment. +-- +lookupTyVarPA :: Var -> VM (Maybe CoreExpr) +lookupTyVarPA tv + = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv + +-- |Add a tyvar to the local environment. +-- +defLocalTyVar :: TyVar -> VM () +defLocalTyVar tv = updLEnv $ \env -> + env { local_tyvars = tv : local_tyvars env + , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv + } + +-- |Add mapping between a tyvar and pa dictionary to the local environment. +-- +defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM () +defLocalTyVarWithPA tv pa = updLEnv $ \env -> + env { local_tyvars = tv : local_tyvars env + , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa + } + +-- |Get the set of tyvars from the local environment. +-- +localTyVars :: VM [TyVar] +localTyVars = readLEnv (reverse . local_tyvars) diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs new file mode 100644 index 00000000..b5332401 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -0,0 +1,123 @@ +-- |Computations in the vectorisation monad concerned with naming and fresh variable generation. + +module Vectorise.Monad.Naming + ( mkLocalisedName + , mkDerivedName + , mkVectId + , cloneVar + , newExportedVar + , newLocalVar + , newLocalVars + , newDummyVar + , newTyVar + ) +where + +import Vectorise.Monad.Base + +import DsMonad +import TcType +import Type +import Var +import Module +import Name +import SrcLoc +import MkId +import Id +import IdInfo( IdDetails(VanillaId) ) +import FastString + +import Control.Monad + + +-- Naming --------------------------------------------------------------------- + +-- |Create a localised variant of a name, using the provided function to transform its `OccName`. +-- +-- If the name external, encode the orignal name's module into the new 'OccName'. The result is +-- always an internal system name. +-- +mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name +mkLocalisedName mk_occ name + = do { mod <- liftDs getModule + ; u <- liftDs newUnique + ; let occ_name = mkLocalisedOccName mod mk_occ name + + new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name) + | otherwise = mkSystemName u occ_name + + ; return new_name } + +mkDerivedName :: (OccName -> OccName) -> Name -> VM Name +-- Similar to mkLocalisedName, but assumes the +-- incoming name is from this module. +-- Works on External names only +mkDerivedName mk_occ name + = do { u <- liftDs newUnique + ; return (mkExternalName u (nameModule name) + (mk_occ (nameOccName name)) + (nameSrcSpan name)) } + +-- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that +-- vectorised dfun ids must be dfuns again. +-- +-- Force the new name to be a system name and, if the original was an external name, disambiguate +-- the new name with the module name of the original. +-- +mkVectId :: Id -> Type -> VM Id +mkVectId id ty + = do { name <- mkLocalisedName mkVectOcc (getName id) + ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys + | isExportedId id = Id.mkExportedLocalId VanillaId name ty + | otherwise = Id.mkLocalId name ty + ; return id' + } + where + -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys + -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary + -- functions are always fully applied. + (tvs, theta, pty) = tcSplitSigmaTy ty + (cls, tys) = tcSplitDFunHead pty + +-- |Make a fresh instance of this var, with a new unique. +-- +cloneVar :: Var -> VM Var +cloneVar var = liftM (setIdUnique var) (liftDs newUnique) + +-- |Make a fresh exported variable with the given type. +-- +newExportedVar :: OccName -> Type -> VM Var +newExportedVar occ_name ty + = do mod <- liftDs getModule + u <- liftDs newUnique + + let name = mkExternalName u mod occ_name noSrcSpan + + return $ Id.mkExportedLocalId VanillaId name ty + +-- |Make a fresh local variable with the given type. +-- The variable's name is formed using the given string as the prefix. +-- +newLocalVar :: FastString -> Type -> VM Var +newLocalVar fs ty + = do u <- liftDs newUnique + return $ mkSysLocal fs u ty + +-- |Make several fresh local variables with the given types. +-- The variable's names are formed using the given string as the prefix. +-- +newLocalVars :: FastString -> [Type] -> VM [Var] +newLocalVars fs = mapM (newLocalVar fs) + +-- |Make a new local dummy variable. +-- +newDummyVar :: Type -> VM Var +newDummyVar = newLocalVar (fsLit "vv") + +-- |Make a fresh type variable with the given kind. +-- The variable's name is formed using the given string as the prefix. +-- +newTyVar :: FastString -> Kind -> VM Var +newTyVar fs k + = do u <- liftDs newUnique + return $ mkTyVar (mkSysTvName u fs) k diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs new file mode 100644 index 00000000..21a221d9 --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -0,0 +1,137 @@ +-- Extract from a list of type constructors those (1) which need to be vectorised and (2) those +-- that could be, but need not be vectorised (as a scalar representation is sufficient and more +-- efficient). The type constructors that cannot be vectorised will be dropped. +-- +-- A type constructor will only be vectorised if it is +-- +-- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by +-- Haskell 98) and +-- (2) at least one of the type constructors that appears in its definition is also vectorised. +-- +-- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no +-- need to vectorise that type constructor itself. This holds, for example, for all enumeration +-- types. As '([::])' is being vectorised, any type constructor whose definition involves +-- '([::])', either directly or indirectly, will be vectorised. + +module Vectorise.Type.Classify + ( classifyTyCons + ) +where + +import NameSet +import UniqSet +import UniqFM +import DataCon +import TyCon +import TypeRep +import Type hiding (tyConsOfType) +import PrelNames +import Digraph + + +-- |From a list of type constructors, extract those that can be vectorised, returning them in two +-- sets, where the first result list /must be/ vectorised and the second result list /need not be/ +-- vectorised. The third result list are those type constructors that we cannot convert (either +-- because they use language extensions or because they dependent on type constructors for which +-- no vectorised version is available). +-- +-- NB: In order to be able to vectorise a type constructor, we require members of the depending set +-- (i.e., those type constructors that the current one depends on) to be vectorised only if they +-- are also parallel (i.e., appear in the second argument to the function). +-- +-- The first argument determines the /conversion status/ of external type constructors as follows: +-- +-- * tycons which have converted versions are mapped to 'True' +-- * tycons which are not changed by vectorisation are mapped to 'False' +-- * tycons which haven't been converted (because they can't or weren't vectorised) are not +-- elements of the map +-- +classifyTyCons :: UniqFM Bool -- ^type constructor vectorisation status + -> NameSet -- ^tycons involving parallel arrays + -> [TyCon] -- ^type constructors that need to be classified + -> ( [TyCon] -- to be converted + , [TyCon] -- need not be converted (but could be) + , [TyCon] -- involve parallel arrays (whether converted or not) + , [TyCon] -- can't be converted + ) +classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyCons (tyConGroups tcs) + where + classify conv keep par novect _ _ [] = (conv, keep, par, novect) + classify conv keep par novect cs pts ((tcs, ds) : rs) + | can_convert && must_convert + = classify (tcs ++ conv) keep (par ++ tcs_par) novect (cs `addListToUFM` [(tc, True) | tc <- tcs]) pts' rs + | can_convert + = classify conv (tcs ++ keep) (par ++ tcs_par) novect (cs `addListToUFM` [(tc, False) | tc <- tcs]) pts' rs + | otherwise + = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs + where + refs = ds `delListFromUniqSet` tcs + + -- the tycons that directly or indirectly depend on parallel arrays + tcs_par | any ((`elemNameSet` parTyCons) . tyConName) . eltsUFM $ refs = tcs + | otherwise = [] + + pts' = pts `extendNameSetList` map tyConName tcs_par + + can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs)) + && all convertable tcs) + || isShowClass tcs + must_convert = foldUFM (||) False (intersectUFM_C const cs refs) + && (not . isShowClass $ tcs) + + -- We currently admit Haskell 2011-style data and newtype declarations as well as type + -- constructors representing classes. + convertable tc + = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) + || isClassTyCon tc + + -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a + -- vectorised definition (to be able to vectorise 'Num') + isShowClass [tc] = tyConName tc == showClassName + isShowClass _ = False + +-- Used to group type constructors into mutually dependent groups. +-- +type TyConGroup = ([TyCon], UniqSet TyCon) + +-- Compute mutually recursive groups of tycons in topological order. +-- +tyConGroups :: [TyCon] -> [TyConGroup] +tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges) + where + edges = [((tc, ds), tc, uniqSetToList ds) | tc <- tcs + , let ds = tyConsOfTyCon tc] + + mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) + mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) + where + (tcs, dss) = unzip els + +-- |Collect the set of TyCons used by the representation of some data type. +-- +tyConsOfTyCon :: TyCon -> UniqSet TyCon +tyConsOfTyCon = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons + +-- |Collect the set of TyCons that occur in these types. +-- +tyConsOfTypes :: [Type] -> UniqSet TyCon +tyConsOfTypes = unionManyUniqSets . map tyConsOfType + +-- |Collect the set of TyCons that occur in this type. +-- +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + | Just ty' <- coreView ty = tyConsOfType ty' +tyConsOfType (TyVarTy _) = emptyUniqSet +tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) + where + extend | isUnLiftedTyCon tc + || isTupleTyCon tc = id + + | otherwise = (`addOneToUniqSet` tc) + +tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b +tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) + `addOneToUniqSet` funTyCon +tyConsOfType (LitTy _) = emptyUniqSet +tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs new file mode 100644 index 00000000..47b1caa5 --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} + +-- Vectorise a modules type and class declarations. +-- +-- This produces new type constructors and family instances top be included in the module toplevel +-- as well as bindings for worker functions, dfuns, and the like. + +module Vectorise.Type.Env ( + vectTypeEnv, +) where + +#include "HsVersions.h" + +import Vectorise.Env +import Vectorise.Vect +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Type.TyConDecl +import Vectorise.Type.Classify +import Vectorise.Generic.PADict +import Vectorise.Generic.PAMethods +import Vectorise.Generic.PData +import Vectorise.Generic.Description +import Vectorise.Utils + +import CoreSyn +import CoreUtils +import CoreUnfold +import DataCon +import TyCon +import CoAxiom +import Type +import FamInstEnv +import Id +import MkId +import NameEnv +import NameSet +import UniqFM +import OccName +import Unique + +import Util +import Outputable +import DynFlags +import FastString +import MonadUtils + +import Control.Monad +import Data.Maybe +import Data.List + + +-- Note [Pragmas to vectorise tycons] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- All imported type constructors that are not mapped to a vectorised type in the vectorisation map +-- (possibly because the defining module was not compiled with vectorisation) may be used in scalar +-- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the +-- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code, +-- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised +-- code (i.e., it can only be used in scalar code). +-- +-- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged +-- by vectorisation. However, the representation of 'Int' by the 'I#' data constructor wrapping an +-- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need +-- to be confined to scalar code. +-- +-- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type +-- constructors: +-- +-- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised +-- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types +-- declared in a vectorised module. This includes the case where the vectoriser determines that +-- the original representation of 'T' may be used in vectorised code (as it does not embed any +-- parallel arrays.) This case is for type constructors that are *imported* from a non- +-- vectorised module, but that we want to use with full vectorisation support. +-- +-- An example is the treatment of 'Ordering' and '[]'. The former remains unchanged by +-- vectorisation, whereas the latter is fully vectorised. +-- +-- 'PData' and 'PRepr' instances are automatically generated by the vectoriser. +-- +-- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner. +-- +-- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an +-- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the +-- constructors of 'T' may not occur in vectorised code). +-- +-- An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is +-- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised +-- code. Instead, computations involving the representation need to be confined to scalar code. +-- +-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated +-- by the vectoriser). +-- +-- Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner +-- manner. (The vectoriser never treats a type constructor automatically in this manner.) +-- +-- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly +-- provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together +-- with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its +-- constructors 'Cn' are represented by themselves in vectorised code. +-- +-- An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed +-- any parallel arrays). However, we do not want any automatic generation of class and family +-- instances, which is why Case (1) does not apply. +-- +-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated +-- by the vectoriser). +-- +-- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner. +-- +-- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised +-- code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in +-- vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated +-- scalar subcomputations. +-- +-- An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are +-- vectorised to '(:->)'. However, the representation of '(->)' is not exposed in vectorised +-- code. Instead, computations involving the representation need to be confined to scalar code +-- and may be part of encapsulated scalar computations. +-- +-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated +-- by the vectoriser). +-- +-- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this +-- manner. (The vectoriser never treats a type constructor automatically in this manner.) +-- +-- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. +-- It implies that the class type constructor may be used in vectorised code together with its data +-- constructor. We generally produce a vectorised version of the data type and data constructor. +-- We do not generate 'PData' and 'PRepr' instances for class type constructors. This pragma is the +-- default for all type classes declared in a vectorised module, but the pragma can also be used +-- explitly on imported classes. + +-- Note [Vectorising classes] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We vectorise classes essentially by just vectorising their desugared Core representation, but we +-- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl'). +-- +-- Here is an example illustrating the mapping — assume +-- +-- class Num a where +-- (+) :: a -> a -> a +-- +-- It desugars to +-- +-- data Num a = D:Num { (+) :: a -> a -> a } +-- +-- which we vectorise to +-- +-- data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a } +-- +-- while adding the following entries to the vectorisation map: +-- +-- tycon : Num --> V:Num +-- datacon: D:Num --> D:V:Num +-- var : (+) --> ($v+) + +-- |Vectorise type constructor including class type constructors. +-- +vectTypeEnv :: [TyCon] -- Type constructors defined in this module + -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module + -> [CoreVect] -- All 'VECTORISE class' declarations in this module + -> VM ( [TyCon] -- old TyCons ++ new TyCons + , [FamInst] -- New type family instances. + , [(Var, CoreExpr)]) -- New top level bindings. +vectTypeEnv tycons vectTypeDecls vectClassDecls + = do { traceVt "** vectTypeEnv" $ ppr tycons + + ; let -- {-# VECTORISE type T -#} (ONLY the imported tycons) + impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls] + ++ [tycon | VectClass tycon <- vectClassDecls]) + \\ tycons + + -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/) + vectTyConsWithRHS = [ (tycon, rhs) + | VectType False tycon (Just rhs) <- vectTypeDecls] + + -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/) + scalarTyConsWithRHS = [ (tycon, rhs) + | VectType True tycon (Just rhs) <- vectTypeDecls] + + -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS) + scalarTyConsNoRHS = [tycon | VectType True tycon Nothing <- vectTypeDecls] + + -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs? + vectSpecialTyConNames = mkNameSet . map tyConName $ + scalarTyConsNoRHS ++ + map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS) + notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames + + -- Build a map containing all vectorised type constructor. If the vectorised type + -- constructor differs from the original one, then it is mapped to 'True'; if they are + -- both the same, then it maps to 'False'. + ; vectTyCons <- globalVectTyCons + ; let vectTyConBase = mapUFM_Directly isDistinct vectTyCons -- 'True' iff tc /= V[[tc]] + isDistinct u tc = u /= getUnique tc + vectTyConFlavour = vectTyConBase + `plusNameEnv` + mkNameEnv [ (tyConName tycon, True) + | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] + `plusNameEnv` + mkNameEnv [ (tyConName tycon, False) -- original representation + | tycon <- scalarTyConsNoRHS] + + + -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) + -- that we could, but don't need to vectorise. Type constructors that are not data + -- type constructors or use non-Haskell98 features are being dropped. They may not + -- appear in vectorised code. (We also drop the local type constructors appearing in a + -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as + -- these are being handled separately. NB: Some type constructors may be marked SCALAR + -- /and/ have an explicit right-hand side.) + -- + -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose + -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs' + -- are all type constructors that cannot be vectorised. + ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$> + globalParallelTyCons + ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons + (conv_tcs, keep_tcs, par_tcs, drop_tcs) + = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons + + ; traceVt " known parallel : " $ ppr parallelTyCons + ; traceVt " VECT SCALAR : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS) + ; traceVt " VECT [class] : " $ ppr impVectTyCons + ; traceVt " VECT with rhs : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)) + ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty + ; traceVt " reuse : " $ ppr keep_tcs + ; traceVt " convert : " $ ppr conv_tcs + + -- warn the user about unvectorised type constructors + ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ + ptext (sLit "or depend on type constructors that are not vectorised)") + drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . + filter (not . isTypeSynonymTyCon) $ drop_tcs + ; unless (null drop_tcs_nosyn) $ + emitVt "Warning: cannot vectorise these type constructors:" $ + pprQuotedList drop_tcs_nosyn $$ explanation + + ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS + + ; let mapping = + -- Type constructors that we found we don't need to vectorise and those + -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same + -- representation in both unvectorised and vectorised code; they are not + -- abstract. + [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS] + -- We do the same for type constructors declared VECTORISE SCALAR /without/ + -- an explicit right-hand side + ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] + ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping + + -- Vectorise all the data type declarations that we can and must vectorise (enter the + -- type and data constructors into the vectorisation map on-the-fly.) + ; new_tcs <- vectTyConDecls conv_tcs + + ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ + ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) + dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc + | otherwise = panic "dataConSig" + ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs) + + -- We don't need new representation types for dictionary constructors. The constructors + -- are always fully applied, and we don't need to lift them to arrays as a dictionary + -- of a particular type always has the same value. + ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs + vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs + + -- Build 'PRepr' and 'PData' instance type constructors and family instances for all + -- type constructors with vectorised representations. + ; reprs <- mapM tyConRepr vect_tcs + ; repr_fis <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs + ; pdata_fis <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs + ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs + + ; let fam_insts = repr_fis ++ pdata_fis ++ pdatas_fis + repr_axs = map famInstAxiom repr_fis + pdata_tcs = famInstsRepTyCons pdata_fis + pdatas_tcs = famInstsRepTyCons pdatas_fis + + ; updGEnv $ extendFamEnv fam_insts + + -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of + -- the vectorised type constructors, and associate the type constructors with their dfuns + -- in the global environment. We get back the dfun bindings (which we will subsequently + -- inject into the modules toplevel). + ; (_, binds) <- fixV $ \ ~(dfuns, _) -> + do { defTyConPAs (zipLazy vect_tcs dfuns) + + -- Query the 'PData' instance type constructors for type constructors that have a + -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item + -- (3) of "Note [Pragmas to vectorise tycons]" above). + ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS + + -- Build workers for all vectorised data constructors (except abstract ones) + ; sequence_ $ + zipWith3 vectDataConWorkers (orig_tcs ++ scalarTyConsNoRHS) + (vect_tcs ++ scalarTyConsNoRHS) + (pdata_tcs ++ pdata_scalar_tcs) + + -- Build a 'PA' dictionary for all type constructors (except abstract ones & those + -- defined with an explicit right-hand side where the dictionary is user-supplied) + ; dfuns <- sequence $ + zipWith4 buildTyConPADict + vect_tcs + repr_axs + pdata_tcs + pdatas_tcs + + ; binds <- takeHoisted + ; return (dfuns, binds) + } + + -- Return the vectorised variants of type constructors as well as the generated instance + -- type constructors, family instances, and dfun bindings. + ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs + , fam_insts, binds) + } + where + addParallelTyConAndCons tycon + = do + { addGlobalParallelTyCon tycon + ; mapM_ addGlobalParallelVar . concatMap dataConImplicitIds . tyConDataCons $ tycon + } + + -- Add a mapping from the original to vectorised type constructor to the vectorisation map. + -- Unless the type constructor is abstract, also mappings from the orignal's data constructors + -- to the vectorised type's data constructors. + -- + -- We have three cases: (1) original and vectorised type constructor are the same, (2) the + -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or + -- (3) the name is not canonical. In the third case, we additionally introduce a type synonym + -- with the canonical name that is set equal to the non-canonical name (so that we find the + -- right type constructor when reading vectorisation information from interface files). + -- + defTyConDataCons (origTyCon, vectTyCon, isAbstract) + = do + { canonName <- mkLocalisedName mkVectTyConOcc origName + ; if origName == vectName -- Case (1) + || vectName == canonName -- Case (2) + then do + { defTyCon origTyCon vectTyCon -- T --> vT + ; defDataCons -- Ci --> vCi + ; return Nothing + } + else do -- Case (3) + { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon) -- type S = vT + ; defTyCon origTyCon synTyCon -- T --> S + ; defDataCons -- Ci --> vCi + ; return $ Just synTyCon + } + } + where + origName = tyConName origTyCon + vectName = tyConName vectTyCon + + mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty + + defDataCons + | isAbstract = return () + | otherwise + = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) + ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) + } + + +-- Helpers -------------------------------------------------------------------- + +buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var +buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc + = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc + +-- Produce a custom-made worker for the data constructors of a vectorised data type. This includes +-- all data constructors that may be used in vectorised code — i.e., all data constructors of data +-- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side. Also adds a mapping +-- from the original to vectorised worker into the vectorisation map. +-- +-- FIXME: It's not nice that we need create a special worker after the data constructors has +-- already been constructed. Also, I don't think the worker is properly added to the data +-- constructor. Seems messy. +vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () +vectDataConWorkers orig_tc vect_tc arr_tc + = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc) + + ; bs <- sequence + . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys + $ zipWith4 mk_data_con (tyConDataCons vect_tc) + rep_tys + (inits rep_tys) + (tail $ tails rep_tys) + ; mapM_ (uncurry hoistBinding) bs + } + where + tyvars = tyConTyVars vect_tc + var_tys = mkTyVarTys tyvars + ty_args = map Type var_tys + res_ty = mkTyConApp vect_tc var_tys + + cons = tyConDataCons vect_tc + arity = length cons + [arr_dc] = tyConDataCons arr_tc + + rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc + + mk_data_con con tys pre post + = do dflags <- getDynFlags + liftM2 (,) (vect_data_con con) + (lift_data_con tys pre post (mkDataConTag dflags con)) + + sel_replicate len tag + | arity > 1 = do + rep <- builtin (selReplicate arity) + return [rep `mkApps` [len, tag]] + + | otherwise = return [] + + vect_data_con con = return $ mkConApp con ty_args + lift_data_con tys pre_tys post_tys tag + = do + len <- builtin liftingContext + args <- mapM (newLocalVar (fsLit "xs")) + =<< mapM mkPDataType tys + + sel <- sel_replicate (Var len) tag + + pre <- mapM emptyPD (concat pre_tys) + post <- mapM emptyPD (concat post_tys) + + return . mkLams (len : args) + . wrapFamInstBody arr_tc var_tys + . mkConApp arr_dc + $ ty_args ++ sel ++ pre ++ map Var args ++ post + + def_worker data_con arg_tys mk_body + = do + arity <- polyArity tyvars + body <- closedV + . inBind orig_worker + . polyAbstract tyvars $ \args -> + liftM (mkLams (tyvars ++ args) . vectorised) + $ buildClosures tyvars [] [] arg_tys res_ty mk_body + + raw_worker <- mkVectId orig_worker (exprType body) + let vect_worker = raw_worker `setIdUnfolding` + mkInlineUnfolding (Just arity) body + defGlobalVar orig_worker vect_worker + return (vect_worker, body) + where + orig_worker = dataConWorkId data_con diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs new file mode 100644 index 00000000..7b4d5aaa --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -0,0 +1,194 @@ + +module Vectorise.Type.TyConDecl ( + vectTyConDecls +) where + +import Vectorise.Type.Type +import Vectorise.Monad +import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) +import BuildTyCl( buildClass, buildDataCon ) +import Class +import Type +import TyCon +import DataCon +import BasicTypes +import DynFlags +import Var +import Name +import Outputable +import Util +import Control.Monad + + +-- |Vectorise some (possibly recursively defined) type constructors. +-- +vectTyConDecls :: [TyCon] -> VM [TyCon] +vectTyConDecls tcs = fixV $ \tcs' -> + do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs + ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs') + ; zipWithM vectTyConDecl tcs names' + } + +-- |Vectorise a single type constructor. +-- +vectTyConDecl :: TyCon -> Name -> VM TyCon +vectTyConDecl tycon name' + + -- Type constructor representing a type class + | Just cls <- tyConClass_maybe tycon + = do { unless (null $ classATs cls) $ + do dflags <- getDynFlags + cantVectorise dflags "Associated types are not yet supported" (ppr cls) + + -- vectorise superclass constraint (types) + ; theta' <- mapM vectType (classSCTheta cls) + + -- vectorise method selectors + ; let opItems = classOpItems cls + Just datacon = tyConSingleDataCon_maybe tycon + argTys = dataConRepArgTys datacon -- all selector types + opTys = drop (length argTys - length opItems) argTys -- only method types + ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys] + + -- keep the original recursiveness flag + ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon) + + -- construct the vectorised class (this also creates the class type constructors and its + -- data constructor) + -- + -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types + ; cls' <- liftDs $ + buildClass + name' -- new name: "V:Class" + (tyConTyVars tycon) -- keep original type vars + (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety + theta' -- superclasses + (snd . classTvsFds $ cls) -- keep the original functional dependencies + [] -- no associated types (for the moment) + methods' -- method info + (classMinimalDef cls) -- Inherit minimal complete definition from cls + rec_flag -- whether recursive + + -- the original dictionary constructor must map to the vectorised one + ; let tycon' = classTyCon cls' + Just datacon = tyConSingleDataCon_maybe tycon + Just datacon' = tyConSingleDataCon_maybe tycon' + ; defDataCon datacon datacon' + + -- the original superclass and methods selectors must map to the vectorised ones + ; let selIds = classAllSelIds cls + selIds' = classAllSelIds cls' + ; zipWithM_ defGlobalVar selIds selIds' + + -- return the type constructor of the vectorised class + ; return tycon' + } + + -- Regular algebraic type constructor — for now, Haskell 2011-style only + | isAlgTyCon tycon + = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ + do dflags <- getDynFlags + cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon) + + -- vectorise the data constructor of the class tycon + ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) + + -- keep the original recursiveness and GADT flags + ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon) + gadt_flag = isGadtSyntaxTyCon tycon + + -- build the vectorised type constructor + ; return $ buildAlgTyCon + name' -- new name + (tyConTyVars tycon) -- keep original type vars + (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety + Nothing + [] -- no stupid theta + rhs' -- new constructor defs + rec_flag -- whether recursive + False -- Not promotable + gadt_flag -- whether in GADT syntax + NoParentTyCon + } + + -- some other crazy thing that we don't handle + | otherwise + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon) + +-- |Vectorise a class method. (Don't enter it into the vectorisation map yet.) +-- +vectMethod :: Id -> DefMeth -> Type -> VM (Name, DefMethSpec, Type) +vectMethod id defMeth ty + = do { -- Vectorise the method type. + ; ty' <- vectType ty + + -- Create a name for the vectorised method. + ; id' <- mkVectId id ty' + + ; return (Var.varName id', defMethSpecOfDefMeth defMeth, ty') + } + +-- |Vectorise the RHS of an algebraic type. +-- +vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs +vectAlgTyConRhs tc (AbstractTyCon {}) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) +vectAlgTyConRhs _tc DataFamilyTyCon + = return DataFamilyTyCon +vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons + , is_enum = is_enum + }) + = do { data_cons' <- mapM vectDataCon data_cons + ; zipWithM_ defDataCon data_cons data_cons' + ; return $ DataTyCon { data_cons = data_cons' + , is_enum = is_enum + } + } +vectAlgTyConRhs tc (NewTyCon {}) + = do dflags <- getDynFlags + cantVectorise dflags noNewtypeErr (ppr tc) + where + noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" + +-- |Vectorise a data constructor by vectorising its argument and return types.. +-- +vectDataCon :: DataCon -> VM DataCon +vectDataCon dc + | not . null $ ex_tvs + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc) + | not . null $ eq_spec + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc) + | not . null $ dataConFieldLabels dc + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc) + | not . null $ theta + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc) + | otherwise + = do { name' <- mkLocalisedName mkVectDataConOcc name + ; tycon' <- vectTyCon tycon + ; arg_tys <- mapM vectType rep_arg_tys + ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs) + ; fam_envs <- readGEnv global_fam_inst_env + ; liftDs $ buildDataCon fam_envs + name' + (dataConIsInfix dc) -- infix if the original is + (dataConSrcBangs dc) -- strictness as original constructor + [] -- no labelled fields for now + univ_tvs -- universally quantified vars + [] -- no existential tvs for now + [] -- no equalities for now + [] -- no context for now + arg_tys -- argument types + ret_ty -- return type + tycon' -- representation tycon + } + where + name = dataConName dc + rep_arg_tys = dataConRepArgTys dc + tycon = dataConTyCon dc + (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs new file mode 100644 index 00000000..77b5b17e --- /dev/null +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -0,0 +1,82 @@ +-- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM. + +module Vectorise.Type.Type + ( vectTyCon + , vectAndLiftType + , vectType + ) +where + +import Vectorise.Utils +import Vectorise.Monad +import Vectorise.Builtins +import TcType +import Type +import TypeRep +import TyCon +import Control.Monad +import Control.Applicative +import Data.Maybe +import Prelude -- avoid redundant import warning due to AMP + +-- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded +-- parallel arrays), the vectorised version is the same as the original. +-- +vectTyCon :: TyCon -> VM TyCon +vectTyCon tc = maybe tc id <$> lookupTyCon tc + +-- |Produce the vectorised and lifted versions of a type. +-- +-- NB: Here we are limited to properly handle predicates at the toplevel only. Anything embedded +-- in what is called the 'body_ty' below will end up as an argument to the type family 'PData'. +-- +vectAndLiftType :: Type -> VM (Type, Type) +vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' +vectAndLiftType ty + = do { padicts <- liftM catMaybes $ mapM paDictArgType tyvars + ; vmono_ty <- vectType mono_ty + ; lmono_ty <- mkPDataType vmono_ty + ; return (abstractType tyvars (padicts ++ theta) vmono_ty, + abstractType tyvars (padicts ++ theta) lmono_ty) + } + where + (tyvars, phiTy) = splitForAllTys ty + (theta, mono_ty) = tcSplitPhiTy phiTy + +-- |Vectorise a type. +-- +-- For each quantified var we need to add a PA dictionary out the front of the type. +-- So forall a. C a => a -> a +-- turns into forall a. PA a => Cv a => a :-> a +-- +vectType :: Type -> VM Type +vectType ty + | Just ty' <- coreView ty + = vectType ty' +vectType (TyVarTy tv) = return $ TyVarTy tv +vectType (LitTy l) = return $ LitTy l +vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 +vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys +vectType (FunTy ty1 ty2) + | isPredTy ty1 + = FunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction + | otherwise + = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2] +vectType ty@(ForAllTy _ _) + = do { -- strip off consecutive foralls + ; let (tyvars, tyBody) = splitForAllTys ty + + -- vectorise the body + ; vtyBody <- vectType tyBody + + -- make a PA dictionary for each of the type variables + ; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars + + -- add the PA dictionaries after the foralls + ; return $ abstractType tyvars dictsPA vtyBody + } + +-- |Add quantified vars and dictionary parameters to the front of a type. +-- +abstractType :: [TyVar] -> [Type] -> Type -> Type +abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs new file mode 100644 index 00000000..fafce7a6 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils.hs @@ -0,0 +1,165 @@ +module Vectorise.Utils ( + module Vectorise.Utils.Base, + module Vectorise.Utils.Closure, + module Vectorise.Utils.Hoisting, + module Vectorise.Utils.PADict, + module Vectorise.Utils.Poly, + + -- * Annotated Exprs + collectAnnTypeArgs, + collectAnnDictArgs, + collectAnnTypeBinders, + collectAnnValBinders, + isAnnTypeArg, + + -- * PD Functions + replicatePD, emptyPD, packByTagPD, + combinePD, liftPD, + + -- * Scalars + isScalar, zipScalars, scalarClosure, + + -- * Naming + newLocalVar +) where + +import Vectorise.Utils.Base +import Vectorise.Utils.Closure +import Vectorise.Utils.Hoisting +import Vectorise.Utils.PADict +import Vectorise.Utils.Poly +import Vectorise.Monad +import Vectorise.Builtins +import CoreSyn +import CoreUtils +import Id +import Type +import Control.Monad + + +-- Annotated Exprs ------------------------------------------------------------ + +collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) +collectAnnTypeArgs expr = go expr [] + where + go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys) + go e tys = (e, tys) + +collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann]) +collectAnnDictArgs expr = go expr [] + where + go e@(_, AnnApp f arg) dicts + | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts) + | otherwise = (e, dicts) + go e dicts = (e, dicts) + +collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) +collectAnnTypeBinders expr = go [] expr + where + go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e + go bs e = (reverse bs, e) + +-- |Collect all consecutive value binders that are not dictionaries. +-- +collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) +collectAnnValBinders expr = go [] expr + where + go bs (_, AnnLam b e) | isId b + && (not . isPredTy . idType $ b) = go (b : bs) e + go bs e = (reverse bs, e) + +isAnnTypeArg :: AnnExpr b ann -> Bool +isAnnTypeArg (_, AnnType _) = True +isAnnTypeArg _ = False + + +-- PD "Parallel Data" Functions ----------------------------------------------- +-- +-- Given some data that has a PA dictionary, we can convert it to its +-- representation type, perform some operation on the data, then convert it back. +-- +-- In the DPH backend, the types of these functions are defined +-- in dph-common/D.A.P.Lifted/PArray.hs +-- + +-- |An empty array of the given type. +-- +emptyPD :: Type -> VM CoreExpr +emptyPD = paMethod emptyPDVar emptyPD_PrimVar + +-- |Produce an array containing copies of a given element. +-- +replicatePD :: CoreExpr -- ^ Number of copies in the resulting array. + -> CoreExpr -- ^ Value to replicate. + -> VM CoreExpr +replicatePD len x + = liftM (`mkApps` [len,x]) + $ paMethod replicatePDVar replicatePD_PrimVar (exprType x) + +-- |Select some elements from an array that correspond to a particular tag value and pack them into a new +-- array. +-- +-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 +-- > ==> [:42, 50, 49:] +-- +packByTagPD :: Type -- ^ Element type. + -> CoreExpr -- ^ Source array. + -> CoreExpr -- ^ Length of resulting array. + -> CoreExpr -- ^ Tag values of elements in source array. + -> CoreExpr -- ^ The tag value for the elements to select. + -> VM CoreExpr +packByTagPD ty xs len tags t + = liftM (`mkApps` [xs, len, tags, t]) + (paMethod packByTagPDVar packByTagPD_PrimVar ty) + +-- |Combine some arrays based on a selector. The selector says which source array to choose for each +-- element of the resulting array. +-- +combinePD :: Type -- ^ Element type + -> CoreExpr -- ^ Length of resulting array + -> CoreExpr -- ^ Selector. + -> [CoreExpr] -- ^ Arrays to combine. + -> VM CoreExpr +combinePD ty len sel xs + = liftM (`mkApps` (len : sel : xs)) + (paMethod (combinePDVar n) (combinePD_PrimVar n) ty) + where + n = length xs + +-- |Like `replicatePD` but use the lifting context in the vectoriser state. +-- +liftPD :: CoreExpr -> VM CoreExpr +liftPD x + = do + lc <- builtin liftingContext + replicatePD (Var lc) x + + +-- Scalars -------------------------------------------------------------------- + +isScalar :: Type -> VM Bool +isScalar ty + = do + { scalar <- builtin scalarClass + ; existsInst scalar [ty] + } + +zipScalars :: [Type] -> Type -> VM CoreExpr +zipScalars arg_tys res_ty + = do + { scalar <- builtin scalarClass + ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args + ; zipf <- builtin (scalarZip $ length arg_tys) + ; return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns + } + where + ty_args = arg_tys ++ [res_ty] + +scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr +scalarClosure arg_tys res_ty scalar_fun array_fun + = do + { ctr <- builtin (closureCtrFun $ length arg_tys) + ; pas <- mapM paDictOfType (init arg_tys) + ; return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty]) + `mkApps` (pas ++ [scalar_fun, array_fun]) + } diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs new file mode 100644 index 00000000..dc1f2103 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} + +module Vectorise.Utils.Base + ( voidType + , newLocalVVar + + , mkDataConTag, dataConTagZ + , mkWrapType + , mkClosureTypes + , mkPReprType + , mkPDataType, mkPDatasType + , splitPrimTyCon + , mkBuiltinCo + + , wrapNewTypeBodyOfWrap + , unwrapNewTypeBodyOfWrap + , wrapNewTypeBodyOfPDataWrap + , unwrapNewTypeBodyOfPDataWrap + , wrapNewTypeBodyOfPDatasWrap + , unwrapNewTypeBodyOfPDatasWrap + + , pdataReprTyCon + , pdataReprTyConExact + , pdatasReprTyConExact + , pdataUnwrapScrut + + , preprFamInst +) where + +import Vectorise.Monad +import Vectorise.Vect +import Vectorise.Builtins + +import CoreSyn +import CoreUtils +import FamInstEnv +import Coercion +import Type +import TyCon +import DataCon +import MkId +import DynFlags +import FastString + +#include "HsVersions.h" + +-- Simple Types --------------------------------------------------------------- + +voidType :: VM Type +voidType = mkBuiltinTyConApp voidTyCon [] + + +-- Name Generation ------------------------------------------------------------ + +newLocalVVar :: FastString -> Type -> VM VVar +newLocalVVar fs vty + = do + lty <- mkPDataType vty + vv <- newLocalVar fs vty + lv <- newLocalVar fs lty + return (vv,lv) + + +-- Constructors --------------------------------------------------------------- + +mkDataConTag :: DynFlags -> DataCon -> CoreExpr +mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ + +dataConTagZ :: DataCon -> Int +dataConTagZ con = dataConTag con - fIRST_TAG + + +-- Type Construction ---------------------------------------------------------- + +-- |Make an application of the 'Wrap' type constructor. +-- +mkWrapType :: Type -> VM Type +mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] + +-- |Make an application of the closure type constructor. +-- +mkClosureTypes :: [Type] -> Type -> VM Type +mkClosureTypes = mkBuiltinTyConApps closureTyCon + +-- |Make an application of the 'PRepr' type constructor. +-- +mkPReprType :: Type -> VM Type +mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty] + +-- | Make an appliction of the 'PData' tycon to some argument. +-- +mkPDataType :: Type -> VM Type +mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] + +-- | Make an application of the 'PDatas' tycon to some argument. +-- +mkPDatasType :: Type -> VM Type +mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty] + +-- Make an application of a builtin type constructor to some arguments. +-- +mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type +mkBuiltinTyConApp get_tc tys + = do { tc <- builtin get_tc + ; return $ mkTyConApp tc tys + } + +-- Make a cascading application of a builtin type constructor. +-- +mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type +mkBuiltinTyConApps get_tc tys ty + = do { tc <- builtin get_tc + ; return $ foldr (mk tc) ty tys + } + where + mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] + + +-- Type decomposition --------------------------------------------------------- + +-- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it. +-- +splitPrimTyCon :: Type -> Maybe TyCon +splitPrimTyCon ty + | Just (tycon, []) <- splitTyConApp_maybe ty + , isPrimTyCon tycon + = Just tycon + | otherwise = Nothing + + +-- Coercion Construction ----------------------------------------------------- + +-- |Make a representational coersion to some builtin type. +-- +mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion +mkBuiltinCo get_tc + = do { tc <- builtin get_tc + ; return $ mkTyConAppCo Representational tc [] + } + + +-- Wrapping and unwrapping the 'Wrap' newtype --------------------------------- + +-- |Apply the constructor wrapper of the 'Wrap' /newtype/. +-- +wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; return $ wrapNewTypeBody wrap_tc [ty] e + } + +-- |Strip the constructor wrapper of the 'Wrap' /newtype/. +-- +unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; return $ unwrapNewTypeBody wrap_tc [ty] e + } + +-- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. +-- +wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfPDataWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdataReprTyConExact wrap_tc + ; return $ wrapNewTypeBody pwrap_tc [ty] e + } + +-- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. +-- +unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfPDataWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdataReprTyConExact wrap_tc + ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) + } + +-- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. +-- +wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfPDatasWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdatasReprTyConExact wrap_tc + ; return $ wrapNewTypeBody pwrap_tc [ty] e + } + +-- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. +-- +unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfPDatasWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdatasReprTyConExact wrap_tc + ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) + } + + +-- 'PData' representation types ---------------------------------------------- + +-- |Get the representation tycon of the 'PData' data family for a given type. +-- +-- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in +-- 'Vectorise.Generic.Description': +-- +-- @pdataReprTyCon {Sum2} = {PDataSum2}@ +-- +-- The type for which we look up a 'PData' instance may be more specific than the type in the +-- instance declaration. In that case the second component of the result will be more specific than +-- a set of distinct type variables. +-- +pdataReprTyCon :: Type -> VM (TyCon, [Type]) +pdataReprTyCon ty + = do + { FamInstMatch { fim_instance = famInst + , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) + ; return (dataFamInstRepTyCon famInst, tys) + } + +-- |Get the representation tycon of the 'PData' data family for a given type constructor. +-- +-- For example, for a binary type constructor 'T', we determine the representation type constructor +-- for 'PData (T a b)'. +-- +pdataReprTyConExact :: TyCon -> VM TyCon +pdataReprTyConExact tycon + = do { -- look up the representation tycon; if there is a match at all, it will be be exact + ; -- (i.e.,' _tys' will be distinct type variables) + ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) + ; return ptycon + } + +-- |Get the representation tycon of the 'PDatas' data family for a given type constructor. +-- +-- For example, for a binary type constructor 'T', we determine the representation type constructor +-- for 'PDatas (T a b)'. +-- +pdatasReprTyConExact :: TyCon -> VM TyCon +pdatasReprTyConExact tycon + = do { -- look up the representation tycon; if there is a match at all, it will be be exact + ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) + ; return $ dataFamInstRepTyCon ptycon + } + where + pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) + +-- |Unwrap a 'PData' representation scrutinee. +-- +pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon) +pdataUnwrapScrut (ve, le) + = do { (tc, arg_tys) <- pdataReprTyCon ty + ; let [dc] = tyConDataCons tc + ; return (ve, unwrapFamInstScrut tc arg_tys le, dc) + } + where + ty = exprType ve + + +-- 'PRepr' representation types ---------------------------------------------- + +-- |Get the representation tycon of the 'PRepr' type family for a given type. +-- +preprFamInst :: Type -> VM FamInstMatch +preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs new file mode 100644 index 00000000..0a918f84 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -0,0 +1,161 @@ +-- |Utils concerning closure construction and application. + +module Vectorise.Utils.Closure + ( mkClosure + , mkClosureApp + , buildClosures + ) +where + +import Vectorise.Builtins +import Vectorise.Vect +import Vectorise.Monad +import Vectorise.Utils.Base +import Vectorise.Utils.PADict +import Vectorise.Utils.Hoisting + +import CoreSyn +import Type +import MkCore +import CoreUtils +import TyCon +import DataCon +import MkId +import TysWiredIn +import BasicTypes( TupleSort(..) ) +import FastString + + +-- |Make a closure. +-- +mkClosure :: Type -- ^ Type of the argument. + -> Type -- ^ Type of the result. + -> Type -- ^ Type of the environment. + -> VExpr -- ^ The function to apply. + -> VExpr -- ^ The environment to use. + -> VM VExpr +mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) + = do dict <- paDictOfType env_ty + mkv <- builtin closureVar + mkl <- builtin liftedClosureVar + return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], + Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) + +-- |Make a closure application. +-- +mkClosureApp :: Type -- ^ Type of the argument. + -> Type -- ^ Type of the result. + -> VExpr -- ^ Closure to apply. + -> VExpr -- ^ Argument to use. + -> VM VExpr +mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) + = do vapply <- builtin applyVar + lapply <- builtin liftedApplyVar + lc <- builtin liftingContext + return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], + Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg]) + +-- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function. The length of +-- the list of types of arguments determines the arity. +-- +-- In addition to a set of type variables, a set of value variables is passed during closure +-- /construction/. In contrast, the closure environment and the arguments are passed during closure +-- application. +-- +buildClosures :: [TyVar] -- ^ Type variables passed during closure construction. + -> [Var] -- ^ Variables passed during closure construction. + -> [VVar] -- ^ Variables in the environment. + -> [Type] -- ^ Type of the arguments. + -> Type -- ^ Type of result. + -> VM VExpr + -> VM VExpr +buildClosures _tvs _vars _env [] _res_ty mk_body + = mk_body +buildClosures tvs vars env [arg_ty] res_ty mk_body + = buildClosure tvs vars env arg_ty res_ty mk_body +buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body + = do { res_ty' <- mkClosureTypes arg_tys res_ty + ; arg <- newLocalVVar (fsLit "x") arg_ty + ; buildClosure tvs vars env arg_ty res_ty' + . hoistPolyVExpr tvs vars (Inline (length env + 1)) + $ do { lc <- builtin liftingContext + ; clo <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body + ; return $ vLams lc (env ++ [arg]) clo + } + } + +-- Build a closure taking one extra argument during closure application. +-- +-- (clo , aclo (Arr lc xs1 ... xsn) ) +-- where +-- f = \env v -> case env of -> e x1 ... xn v +-- f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v +-- +-- In addition to a set of type variables, a set of value variables is passed during closure +-- /construction/. In contrast, the closure environment and the closure argument are passed during +-- closure application. +-- +buildClosure :: [TyVar] -- ^Type variables passed during closure construction. + -> [Var] -- ^Variables passed during closure construction. + -> [VVar] -- ^Variables in the environment. + -> Type -- ^Type of the closure argument. + -> Type -- ^Type of the result. + -> VM VExpr + -> VM VExpr +buildClosure tvs vars vvars arg_ty res_ty mk_body + = do { (env_ty, env, bind) <- buildEnv vvars + ; env_bndr <- newLocalVVar (fsLit "env") env_ty + ; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty + + -- generate the closure function as a hoisted binding + ; fn <- hoistPolyVExpr tvs vars (Inline 2) $ + do { lc <- builtin liftingContext + ; body <- mk_body + ; return . vLams lc [env_bndr, arg_bndr] + $ bind (vVar env_bndr) + (vVarApps lc body (vvars ++ [arg_bndr])) + } + + ; mkClosure arg_ty res_ty env_ty fn env + } + +-- Build the environment for a single closure. +-- +buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) +buildEnv [] + = do + ty <- voidType + void <- builtin voidVar + pvoid <- builtin pvoidVar + return (ty, vVar (void, pvoid), \_ body -> body) +buildEnv [v] + = return (vVarType v, vVar v, + \env body -> vLet (vNonRec v env) body) +buildEnv vs + = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty + + let venv_con = tupleCon BoxedTuple (length vs) + [lenv_con] = tyConDataCons lenv_tc + + venv = mkCoreTup (map Var vvs) + lenv = Var (dataConWrapId lenv_con) + `mkTyApps` lenv_tyargs + `mkApps` map Var lvs + + vbind env body = mkWildCase env ty (exprType body) + [(DataAlt venv_con, vvs, body)] + + lbind env body = + let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env + in + mkWildCase scrut (exprType scrut) (exprType body) + [(DataAlt lenv_con, lvs, body)] + + bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, + lbind lenv lbody) + + return (ty, (venv, lenv), bind) + where + (vvs, lvs) = unzip vs + tys = map vVarType vs + ty = mkBoxedTupleTy tys diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs new file mode 100644 index 00000000..105c8210 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -0,0 +1,98 @@ +module Vectorise.Utils.Hoisting + ( Inline(..) + , addInlineArity + , inlineMe + + , hoistBinding + , hoistExpr + , hoistVExpr + , hoistPolyVExpr + , takeHoisted + ) +where + +import Vectorise.Monad +import Vectorise.Env +import Vectorise.Vect +import Vectorise.Utils.Poly + +import CoreSyn +import CoreUtils +import CoreUnfold +import Type +import Id +import BasicTypes (Arity) +import FastString +import Control.Monad +import Control.Applicative +import Prelude -- avoid redundant import warning due to AMP + +-- Inline --------------------------------------------------------------------- + +-- |Records whether we should inline a particular binding. +-- +data Inline + = Inline Arity + | DontInline + +-- |Add to the arity contained within an `Inline`, if any. +-- +addInlineArity :: Inline -> Int -> Inline +addInlineArity (Inline m) n = Inline (m+n) +addInlineArity DontInline _ = DontInline + +-- |Says to always inline a binding. +-- +inlineMe :: Inline +inlineMe = Inline 0 + + +-- Hoisting -------------------------------------------------------------------- + +hoistBinding :: Var -> CoreExpr -> VM () +hoistBinding v e = updGEnv $ \env -> + env { global_bindings = (v,e) : global_bindings env } + +hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var +hoistExpr fs expr inl + = do + var <- mk_inline `liftM` newLocalVar fs (exprType expr) + hoistBinding var expr + return var + where + mk_inline var = case inl of + Inline arity -> var `setIdUnfolding` + mkInlineUnfolding (Just arity) expr + DontInline -> var + +hoistVExpr :: VExpr -> Inline -> VM VVar +hoistVExpr (ve, le) inl + = do + fs <- getBindName + vv <- hoistExpr ('v' `consFS` fs) ve inl + lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) + return (vv, lv) + +-- |Hoist a polymorphic vectorised expression into a new top-level binding (representing a closure +-- function). +-- +-- The hoisted expression is parameterised by (1) a set of type variables and (2) a set of value +-- variables that are passed as conventional type and value arguments. The latter is implicitly +-- extended by the set of 'PA' dictionaries required for the type variables. +-- +hoistPolyVExpr :: [TyVar] -> [Var] -> Inline -> VM VExpr -> VM VExpr +hoistPolyVExpr tvs vars inline p + = do { inline' <- addInlineArity inline . (+ length vars) <$> polyArity tvs + ; expr <- closedV . polyAbstract tvs $ \args -> + mapVect (mkLams $ tvs ++ args ++ vars) <$> p + ; fn <- hoistVExpr expr inline' + ; let varArgs = varsToCoreExprs vars + ; mapVect (\e -> e `mkApps` varArgs) <$> polyVApply (vVar fn) (mkTyVarTys tvs) + } + +takeHoisted :: VM [(Var, CoreExpr)] +takeHoisted + = do + env <- readGEnv id + setGEnv $ env { global_bindings = [] } + return $ global_bindings env diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs new file mode 100644 index 00000000..c2ca20a6 --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -0,0 +1,228 @@ +module Vectorise.Utils.PADict ( + paDictArgType, + paDictOfType, + paMethod, + prDictOfReprType, + prDictOfPReprInstTyCon +) where + +import Vectorise.Monad +import Vectorise.Builtins +import Vectorise.Utils.Base + +import CoreSyn +import CoreUtils +import FamInstEnv +import Coercion +import Type +import TypeRep +import TyCon +import CoAxiom +import Var +import Outputable +import DynFlags +import FastString +import Control.Monad + + +-- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's +-- just PA v. For (v :: (* -> *) -> *) it's +-- +-- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) +-- +paDictArgType :: TyVar -> VM (Maybe Type) +paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) + where + go ty (FunTy k1 k2) + = do + tv <- newTyVar (fsLit "a") k1 + mty1 <- go (TyVarTy tv) k1 + case mty1 of + Just ty1 -> do + mty2 <- go (AppTy ty (TyVarTy tv)) k2 + return $ fmap (ForAllTy tv . FunTy ty1) mty2 + Nothing -> go ty k2 + + go ty k + | isLiftedTypeKind k + = do + pa_cls <- builtin paClass + return $ Just $ mkClassPred pa_cls [ty] + + go _ _ = return Nothing + + +-- |Get the PA dictionary for some type +-- +paDictOfType :: Type -> VM CoreExpr +paDictOfType ty + = paDictOfTyApp ty_fn ty_args + where + (ty_fn, ty_args) = splitAppTys ty + + paDictOfTyApp :: Type -> [Type] -> VM CoreExpr + paDictOfTyApp ty_fn ty_args + | Just ty_fn' <- coreView ty_fn + = paDictOfTyApp ty_fn' ty_args + + -- for type variables, look up the dfun and apply to the PA dictionaries + -- of the type arguments + paDictOfTyApp (TyVarTy tv) ty_args + = do + { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" + (ppr tv <+> text "in" <+> ppr ty) + $ lookupTyVarPA tv + ; dicts <- mapM paDictOfType ty_args + ; return $ dfun `mkTyApps` ty_args `mkApps` dicts + } + + -- for tycons, we also need to apply the dfun to the PR dictionary of + -- the representation type if the tycon is polymorphic + paDictOfTyApp (TyConApp tc []) ty_args + = do + { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) + $ lookupTyConPA tc + ; super <- super_dict tc ty_args + ; dicts <- mapM paDictOfType ty_args + ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts + } + where + noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" + + super_dict _ [] = return [] + super_dict tycon ty_args + = do + { pr <- prDictOfPReprInst (TyConApp tycon ty_args) + ; return [pr] + } + + paDictOfTyApp _ _ = getDynFlags >>= failure + + failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) + +-- |Produce code that refers to a method of the 'PA' class. +-- +paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr +paMethod _ query ty + | Just tycon <- splitPrimTyCon ty -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')? + = liftM Var $ builtin (query tycon) +paMethod method _ ty + = do + { fn <- builtin method + ; dict <- paDictOfType ty + ; return $ mkApps (Var fn) [Type ty, dict] + } + +-- |Given a type @ty@, return the PR dictionary for @PRepr ty@. +-- +prDictOfPReprInst :: Type -> VM CoreExpr +prDictOfPReprInst ty + = do + { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) + <- preprFamInst ty + ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args + } + +-- |Given a type @ty@, its PRepr synonym tycon and its type arguments, +-- return the PR @PRepr ty@. Suppose we have: +-- +-- > type instance PRepr (T a1 ... an) = t +-- +-- which is internally translated into +-- +-- > type :R:PRepr a1 ... an = t +-- +-- and the corresponding coercion. Then, +-- +-- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un) +-- +-- Note that @ty@ is only used for error messages +-- +prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr +prDictOfPReprInstTyCon _ty prepr_ax prepr_args + = do + let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args + dict <- prDictOfReprType' rhs + pr_co <- mkBuiltinCo prTyCon + let co = mkAppCo pr_co + $ mkSymCo + $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args + return $ mkCast dict co + +-- |Get the PR dictionary for a type. The argument must be a representation +-- type. +-- +prDictOfReprType :: Type -> VM CoreExpr +prDictOfReprType ty + | Just (tycon, tyargs) <- splitTyConApp_maybe ty + = do + prepr <- builtin preprTyCon + if tycon == prepr + then do + let [ty'] = tyargs + pa <- paDictOfType ty' + sel <- builtin paPRSel + return $ Var sel `App` Type ty' `App` pa + else do + -- a representation tycon must have a PR instance + dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ + lookupTyConPR tycon + prDFunApply dfun tyargs + + | otherwise + = do + -- it is a tyvar or an application of a tyvar + -- determine the PR dictionary from its PA dictionary + -- + -- NOTE: This assumes that PRepr t ~ t is for all representation types + -- t + -- + -- FIXME: This doesn't work for kinds other than * at the moment. We'd + -- have to simply abstract the term over the missing type arguments. + pa <- paDictOfType ty + prsel <- builtin paPRSel + return $ Var prsel `mkApps` [Type ty, pa] + +prDictOfReprType' :: Type -> VM CoreExpr +prDictOfReprType' ty = prDictOfReprType ty `orElseV` + do dflags <- getDynFlags + cantVectorise dflags "No PR dictionary for representation type" + (ppr ty) + +-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding +-- to the argument types. +prDFunApply :: Var -> [Type] -> VM CoreExpr +prDFunApply dfun tys + | Just [] <- ctxs -- PR (a :-> b) doesn't have a context + = return $ Var dfun `mkTyApps` tys + + | Just tycons <- ctxs + , length tycons == length tys + = do + pa <- builtin paTyCon + pr <- builtin prTyCon + dflags <- getDynFlags + args <- zipWithM (dictionary dflags pa pr) tys tycons + return $ Var dfun `mkTyApps` tys `mkApps` args + + | otherwise = do dflags <- getDynFlags + invalid dflags + where + -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then + -- ctxs is Just [PA, PR] + ctxs = fmap (map fst) + $ sequence + $ map splitTyConApp_maybe + $ fst + $ splitFunTys + $ snd + $ splitForAllTys + $ varType dfun + + dictionary dflags pa pr ty tycon + | tycon == pa = paDictOfType ty + | tycon == pr = prDictOfReprType ty + | otherwise = invalid dflags + + invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) + diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs new file mode 100644 index 00000000..e943313b --- /dev/null +++ b/compiler/vectorise/Vectorise/Utils/Poly.hs @@ -0,0 +1,72 @@ +-- |Auxiliary functions to vectorise type abstractions. + +module Vectorise.Utils.Poly + ( polyAbstract + , polyApply + , polyVApply + , polyArity + ) +where + +import Vectorise.Vect +import Vectorise.Monad +import Vectorise.Utils.PADict +import CoreSyn +import Type +import FastString +import Control.Monad + + +-- Vectorisation of type arguments ------------------------------------------------------------- + +-- |Vectorise under the 'PA' dictionary variables corresponding to a set of type arguments. +-- +-- The dictionary variables are new local variables that are entered into the local vectorisation +-- map. +-- +-- The purpose of this function is to introduce the additional 'PA' dictionary arguments that are +-- needed when vectorising type abstractions. +-- +polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a +polyAbstract tvs p + = localV + $ do { mdicts <- mapM mk_dict_var tvs + ; zipWithM_ (\tv -> maybe (defLocalTyVar tv) + (defLocalTyVarWithPA tv . Var)) tvs mdicts + ; p (mk_args mdicts) + } + where + mk_dict_var tv + = do { r <- paDictArgType tv + ; case r of + Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) + Nothing -> return Nothing + } + + mk_args mdicts = [dict | Just dict <- mdicts] + +-- |Determine the number of 'PA' dictionary arguments required for a set of type variables (depends +-- on their kinds). +-- +polyArity :: [TyVar] -> VM Int +polyArity tvs + = do { tys <- mapM paDictArgType tvs + ; return $ length [() | Just _ <- tys] + } + +-- |Apply a expression to its type arguments as well as 'PA' dictionaries for these type arguments. +-- +polyApply :: CoreExpr -> [Type] -> VM CoreExpr +polyApply expr tys + = do { dicts <- mapM paDictOfType tys + ; return $ expr `mkTyApps` tys `mkApps` dicts + } + +-- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for +-- these type arguments. +-- +polyVApply :: VExpr -> [Type] -> VM VExpr +polyVApply expr tys + = do { dicts <- mapM paDictOfType tys + ; return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr + } diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs new file mode 100644 index 00000000..09daf763 --- /dev/null +++ b/compiler/vectorise/Vectorise/Var.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE TupleSections #-} + +-- |Vectorise variables and literals. + +module Vectorise.Var + ( vectBndr + , vectBndrNew + , vectBndrIn + , vectBndrNewIn + , vectBndrsIn + , vectVar + , vectConst + ) +where + +import Vectorise.Utils +import Vectorise.Monad +import Vectorise.Env +import Vectorise.Vect +import Vectorise.Type.Type +import CoreSyn +import Type +import VarEnv +import Id +import FastString +import Control.Applicative +import Prelude -- avoid redundant import warning due to AMP + +-- Binders ---------------------------------------------------------------------------------------- + +-- |Vectorise a binder variable, along with its attached type. +-- +vectBndr :: Var -> VM VVar +vectBndr v + = do (vty, lty) <- vectAndLiftType (idType v) + let vv = v `Id.setIdType` vty + lv = v `Id.setIdType` lty + + updLEnv (mapTo vv lv) + + return (vv, lv) + where + mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) } + +-- |Vectorise a binder variable, along with its attached type, but give the result a new name. +-- +vectBndrNew :: Var -> FastString -> VM VVar +vectBndrNew v fs + = do vty <- vectType (idType v) + vv <- newLocalVVar fs vty + updLEnv (upd vv) + return vv + where + upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv } + +-- |Vectorise a binder then run a computation with that binder in scope. +-- +vectBndrIn :: Var -> VM a -> VM (VVar, a) +vectBndrIn v p + = localV + $ do vv <- vectBndr v + x <- p + return (vv, x) + +-- |Vectorise a binder, give it a new name, then run a computation with that binder in scope. +-- +vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a) +vectBndrNewIn v fs p + = localV + $ do vv <- vectBndrNew v fs + x <- p + return (vv, x) + +-- |Vectorise some binders, then run a computation with them in scope. +-- +vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a) +vectBndrsIn vs p + = localV + $ do vvs <- mapM vectBndr vs + x <- p + return (vvs, x) + + +-- Variables -------------------------------------------------------------------------------------- + +-- |Vectorise a variable, producing the vectorised and lifted versions. +-- +vectVar :: Var -> VM VExpr +vectVar var + = do { vVar <- lookupVar var + ; case vVar of + Local (vv, lv) -> return (Var vv, Var lv) -- local variables have a vect & lifted version + Global vv -> vectConst (Var vv) -- global variables get replicated + } + + +-- Constants -------------------------------------------------------------------------------------- + +-- |Constants are lifted by replication along the integer context in the `VM` state for the number +-- of elements in the result array. +-- +vectConst :: CoreExpr -> VM VExpr +vectConst c = (c,) <$> liftPD c diff --git a/compiler/vectorise/Vectorise/Vect.hs b/compiler/vectorise/Vectorise/Vect.hs new file mode 100644 index 00000000..b64f9561 --- /dev/null +++ b/compiler/vectorise/Vectorise/Vect.hs @@ -0,0 +1,126 @@ +-- |Simple vectorised constructors and projections. +-- +module Vectorise.Vect + ( Vect, VVar, VExpr, VBind + + , vectorised + , lifted + , mapVect + + , vVarType + , vNonRec + , vRec + , vVar + , vType + , vTick + , vLet + , vLams + , vVarApps + , vCaseDEFAULT + ) +where + +import CoreSyn +import Type ( Type ) +import Var + +-- |Contains the vectorised and lifted versions of some thing. +-- +type Vect a = (a,a) +type VVar = Vect Var +type VExpr = Vect CoreExpr +type VBind = Vect CoreBind + +-- |Get the vectorised version of a thing. +-- +vectorised :: Vect a -> a +vectorised = fst + +-- |Get the lifted version of a thing. +-- +lifted :: Vect a -> a +lifted = snd + +-- |Apply some function to both the vectorised and lifted versions of a thing. +-- +mapVect :: (a -> b) -> Vect a -> Vect b +mapVect f (x, y) = (f x, f y) + +-- |Combine vectorised and lifted versions of two things componentwise. +-- +zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c +zipWithVect f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2) + +-- |Get the type of a vectorised variable. +-- +vVarType :: VVar -> Type +vVarType = varType . vectorised + +-- |Wrap a vectorised variable as a vectorised expression. +-- +vVar :: VVar -> VExpr +vVar = mapVect Var + +-- |Wrap a vectorised type as a vectorised expression. +-- +vType :: Type -> VExpr +vType ty = (Type ty, Type ty) + +-- |Make a vectorised note. +-- +vTick :: Tickish Id -> VExpr -> VExpr +vTick = mapVect . Tick + +-- |Make a vectorised non-recursive binding. +-- +vNonRec :: VVar -> VExpr -> VBind +vNonRec = zipWithVect NonRec + +-- |Make a vectorised recursive binding. +-- +vRec :: [VVar] -> [VExpr] -> VBind +vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les)) + where + (vvs, lvs) = unzip vs + (ves, les) = unzip es + +-- |Make a vectorised let expresion. +-- +vLet :: VBind -> VExpr -> VExpr +vLet = zipWithVect Let + +-- |Make a vectorised lambda abstraction. +-- +-- The lifted version also binds the lifting context 'lc'. +-- +vLams :: Var -- ^ Var bound to the lifting context. + -> [VVar] -- ^ Parameter vars for the abstraction. + -> VExpr -- ^ Body of the abstraction. + -> VExpr +vLams lc vs (ve, le) + = (mkLams vvs ve, mkLams (lc:lvs) le) + where + (vvs, lvs) = unzip vs + +-- |Apply an expression to a set of argument variables. +-- +-- The lifted version is also applied to the variable of the lifting context. +-- +vVarApps :: Var -> VExpr -> [VVar] -> VExpr +vVarApps lc (ve, le) vvs + = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) + where + (vs, ls) = unzip vvs + + +vCaseDEFAULT :: VExpr -- scrutiniy + -> VVar -- bnder + -> Type -- type of vectorised version + -> Type -- type of lifted version + -> VExpr -- body of alternative. + -> VExpr +vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) + = (Case vscrut vbndr vty (mkDEFAULT vbody), + Case lscrut lbndr lty (mkDEFAULT lbody)) + where + mkDEFAULT e = [(DEFAULT, [], e)] diff --git a/config.guess b/config.guess new file mode 100644 index 00000000..1f5c50c0 --- /dev/null +++ b/config.guess @@ -0,0 +1,1420 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-03-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). +# +# Originally written by Per Bothner. +# +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +# +# Please send patches with a ChangeLog entry to config-patches@gnu.org. + + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +case "${UNAME_SYSTEM}" in +Linux|GNU|GNU/*) + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + LIBC=gnu + + eval $set_cc_for_build + cat <<-EOF > $dummy.c + #include + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #else + LIBC=gnu + #endif + EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` + ;; +esac + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH="i386" + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH="x86_64" + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + *:MINGW64*:*) + echo ${UNAME_MACHINE}-pc-mingw64 + exit ;; + *:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + *:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + aarch64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC="gnulibc1" ; fi + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arc:Linux:*:* | arceb:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi + else + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf + fi + fi + exit ;; + avr32*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + cris:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + crisv32:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + frv:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + hexagon:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:Linux:*:*) + echo ${UNAME_MACHINE}-pc-linux-${LIBC} + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=${UNAME_MACHINE}el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=${UNAME_MACHINE} + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } + ;; + openrisc*:Linux:*:*) + echo or1k-unknown-linux-${LIBC} + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-${LIBC} + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; + PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; + *) echo hppa-unknown-linux-${LIBC} ;; + esac + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-${LIBC} + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-${LIBC} + exit ;; + ppc64le:Linux:*:*) + echo powerpc64le-unknown-linux-${LIBC} + exit ;; + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-${LIBC} + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux-${LIBC} + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-${LIBC} + exit ;; + x86_64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configury will decide that + # this is a cross-build. + echo i586-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; + x86_64:Haiku:*:*) + echo x86_64-unknown-haiku + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + eval $set_cc_for_build + if test "$UNAME_PROCESSOR" = unknown ; then + UNAME_PROCESSOR=powerpc + fi + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 + fi + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-*:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; + x86_64:VMkernel:*:*) + echo ${UNAME_MACHINE}-unknown-esx + exit ;; +esac + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/config.sub b/config.sub new file mode 100644 index 00000000..d654d03c --- /dev/null +++ b/config.sub @@ -0,0 +1,1794 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-05-01' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches with a ChangeLog entry to config-patches@gnu.org. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | \ + kopensolaris*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + android-linux) + os=-linux-android + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray | -microblaze*) + os= + basic_machine=$1 + ;; + -bluegene*) + os=-cnk + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*178) + os=-lynxos178 + ;; + -lynx*5) + os=-lynxos5 + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arceb \ + | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ + | avr | avr32 \ + | be32 | be64 \ + | bfin \ + | c4x | c8051 | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | epiphany \ + | fido | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | k1om \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipsr5900 | mipsr5900el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 | nios2eb | nios2el \ + | ns16k | ns32k \ + | open8 | or1k | or1knd | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pyramid \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | we32k \ + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xgate) + basic_machine=$basic_machine-unknown + os=-none + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* | avr32-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | c8051-* | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | k1om-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ + | microblaze-* | microblazeel-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipsr5900-* | mipsr5900el-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* | nios2eb-* | nios2el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | or1k*-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pyramid-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aros) + basic_machine=i386-pc + os=-aros + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + microblaze*) + basic_machine=microblaze-xilinx + ;; + mingw64) + basic_machine=x86_64-pc + os=-mingw64 + ;; + mingw32) + basic_machine=i686-pc + os=-mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i686-pc + os=-msys + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + os=-rdos + ;; + rdos32) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* | -plan9* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* | -aros* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -bitrig* | -openbsd* | -solidbsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* | -cegcc* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-musl* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + c8051-*) + os=-elf + ;; + hexagon-*) + os=-elf + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + ;; + m68*-cisco) + os=-aout + ;; + mep-*) + os=-elf + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -cnk*|-aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/configure b/configure new file mode 100755 index 00000000..9d52db9d --- /dev/null +++ b/configure @@ -0,0 +1,14339 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69 for The Glorious Glasgow Haskell Compilation System 7.10.3. +# +# Report bugs to . +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org and +$0: glasgow-haskell-bugs@haskell.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME='The Glorious Glasgow Haskell Compilation System' +PACKAGE_TARNAME='ghc' +PACKAGE_VERSION='7.10.3' +PACKAGE_STRING='The Glorious Glasgow Haskell Compilation System 7.10.3' +PACKAGE_BUGREPORT='glasgow-haskell-bugs@haskell.org' +PACKAGE_URL='' + +ac_unique_file="mk/config.mk.in" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef STDC_HEADERS +# include +# include +#else +# ifdef HAVE_STDLIB_H +# include +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include +# endif +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='LTLIBOBJS +LIBOBJS +LIBRARY_ghc_VERSION +LIBRARY_ghc_prim_VERSION +LIBRARY_Cabal_VERSION +LIBRARY_base_VERSION +BUILD_DOCBOOK_PDF +BUILD_DOCBOOK_PS +BUILD_DOCBOOK_HTML +HavePapi +HavePapiHeader +HavePapiLib +LeadingUnderscore +ALLOCA +FFILibDir +FFIIncludeDir +UseSystemLibFFI +HaveLibMingwEx +WordSize +EGREP +GREP +Alex3 +AlexVersion +AlexCmd +HappyVersion +HappyCmd +GhcPkgCmd +DblatexCmd +HAVE_DOCBOOK_XSL +XsltprocCmd +XmllintCmd +HSCOLOUR +HaveDtrace +DtraceCmd +PatchCmd +TarCmd +TimeCmd +SedCmd +SettingsOptCommand +SettingsLlcCommand +SettingsTouchCommand +SettingsReadElfCommand +SettingsLibtoolCommand +SettingsWindresCommand +SettingsDllWrapCommand +SettingsPerlCommand +SettingsArCommand +SettingsLdFlags +SettingsLdCommand +SettingsCCompilerLinkFlags +SettingsCCompilerFlags +SettingsHaskellCPPFlags +SettingsHaskellCPPCommand +SettingsCCompilerCommand +LN_S +RANLIB_CMD +REAL_RANLIB_CMD +ArSupportsAtFile +ArArgs +ArIsGNUAr +fp_prog_ar +INSTALL_DATA +INSTALL_SCRIPT +INSTALL_PROGRAM +ContextDiffCmd +HaskellHaveGnuNonexecStack +HaskellHaveIdentDirective +HaskellHaveSubsectionsViaSymbols +HaskellTargetOs +HaskellTargetArch +CONF_CPP_OPTS_STAGE2 +CONF_CPP_OPTS_STAGE1 +CONF_CPP_OPTS_STAGE0 +CONF_LD_LINKER_OPTS_STAGE2 +CONF_LD_LINKER_OPTS_STAGE1 +CONF_LD_LINKER_OPTS_STAGE0 +CONF_GCC_LINKER_OPTS_STAGE2 +CONF_GCC_LINKER_OPTS_STAGE1 +CONF_GCC_LINKER_OPTS_STAGE0 +CONF_CC_OPTS_STAGE2 +CONF_CC_OPTS_STAGE1 +CONF_CC_OPTS_STAGE0 +CPP +GccExtraViaCOpts +LdHasFilelist +LdHasNoCompactUnwind +LdHasBuildId +LdIsGNULd +GccIsClang +CC_LLVM_BACKEND +CC_CLANG_BACKEND +GccLT46 +GccLT34 +GccVersion +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +PerlCmd +GhcLibsWithUnix +GHC_LLVM_AFFECTED_BY_9439 +BootstrapOptCmd +BootstrapLlcCmd +OptCmd +OPT +LlcCmd +LLC +LlvmVersion +ObjdumpCmd +OBJDUMP +ReadElfCmd +READELF +RANLIB +ArCmd +AR +NmCmd +NM +LdCmd +LD_GOLD +LD +WhatGccIsCalled +TargetPlatformFull +CrossCompilePrefix +CrossCompiling +SplitObjsBroken +CURSES_LIB_DIRS +CURSES_INCLUDE_DIRS +GMP_LIB_DIRS +GMP_INCLUDE_DIRS +ICONV_LIB_DIRS +ICONV_INCLUDE_DIRS +hardtop +WithHc +Unregisterised +SOLARIS_BROKEN_SHLD +soext_target +soext_host +exeext_target +exeext_host +TargetVendor_CPP +BuildVendor_CPP +HostVendor_CPP +TargetOS_CPP +BuildOS_CPP +HostOS_CPP +TargetArch_CPP +BuildArch_CPP +HostArch_CPP +TargetPlatform_CPP +BuildPlatform_CPP +HostPlatform_CPP +TargetPlatform +HostPlatform +BuildPlatform +target_os +target_vendor +target_cpu +target +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build +WithGhc +SUPPORTS_PACKAGE_KEY +CMM_SINK_BOOTSTRAP_IS_NEEDED +GHC_PACKAGE_DB_FLAG +ArSupportsAtFile_STAGE0 +AR_OPTS_STAGE0 +AR_STAGE0 +CC_STAGE0 +GhcPatchLevel +GhcMinVersion +GhcMajVersion +GhcVersion +OSTYPE +GHC +release +ProjectPatchLevel +ProjectPatchLevel2 +ProjectPatchLevel1 +ProjectVersionInt +ProjectGitCommitId +ProjectVersion +ProjectName +SortCmd +fp_prog_sort +FindCmd +fp_prog_find +CONFIGURE_ARGS +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +runstatedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +with_ghc +enable_bootstrap_with_devel_snapshot +enable_tarballs_autodownload +enable_unregisterised +with_hc +with_iconv_includes +with_iconv_libraries +with_gmp_includes +with_gmp_libraries +with_curses_includes +with_curses_libraries +with_gcc_4_2 +with_gcc +with_clang +with_hs_cpp +with_hs_cpp_flags +with_ld +with_ld_gold +with_nm +with_ar +with_ranlib +with_readelf +with_objdump +with_llc +with_opt +enable_largefile +enable_bfd_debug +with_system_libffi +with_ffi_includes +with_ffi_libraries +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir runstatedir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures The Glorious Glasgow Haskell Compilation System 7.10.3 to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/ghc] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] + --target=TARGET configure for building compilers for TARGET [HOST] +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of The Glorious Glasgow Haskell Compilation System 7.10.3:";; + esac + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-bootstrap-with-devel-snapshot + Allow bootstrapping using a development snapshot of + GHC. This is not guaranteed to work. + --enable-tarballs-autodownload + Automatically download Windows distribution binaries + if needed. + --enable-unregisterised Build an unregisterised compiler (enabled by default + on platforms without registerised support) + [default="$UnregisterisedDefault"] + --disable-largefile omit support for large files + --enable-bfd-debug Enable symbol resolution for -debug rts ('+RTS -Di') + via binutils' libbfd [default=no] + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-ghc=ARG Use ARG as the path to GHC [default=autodetect] + --with-hc=ARG Use ARG as the path to the compiler for compiling + ordinary Haskell code (default= value of --with-ghc) + --with-iconv-includes directory containing iconv.h + --with-iconv-libraries directory containing iconv library + --with-gmp-includes directory containing gmp.h + --with-gmp-libraries directory containing gmp library + --with-curses-includes directory containing curses headers + --with-curses-libraries directory containing curses libraries + --with-gcc-4.2=ARG Use ARG as the path to gcc-4.2 [default=autodetect] + --with-gcc=ARG Use ARG as the path to gcc [default=autodetect] + --with-clang=ARG Use ARG as the path to clang [default=autodetect] + --with-hs-cpp=ARG Use ARG as the path to cpp [default=autodetect] + --with-hs-cpp-flags=ARG Use ARG as the path to hs cpp [default=autodetect] + --with-ld=ARG Use ARG as the path to ld [default=autodetect] + --with-ld.gold=ARG Use ARG as the path to ld.gold [default=autodetect] + --with-nm=ARG Use ARG as the path to nm [default=autodetect] + --with-ar=ARG Use ARG as the path to ar [default=autodetect] + --with-ranlib=ARG Use ARG as the path to ranlib [default=autodetect] + --with-readelf=ARG Use ARG as the path to readelf [default=autodetect] + --with-objdump=ARG Use ARG as the path to objdump [default=autodetect] + --with-llc=ARG Use ARG as the path to llc [default=autodetect] + --with-opt=ARG Use ARG as the path to opt [default=autodetect] + --with-system-libffi Use system provided libffi for RTS [default=no] + + --with-ffi-includes=ARG Find includes for libffi in ARG [default=system + default] + + --with-ffi-libraries=ARG + Find libffi in ARG [default=system default] + + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +The Glorious Glasgow Haskell Compilation System configure 7.10.3 +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} +( $as_echo "## ----------------------------------------------- ## +## Report this to glasgow-haskell-bugs@haskell.org ## +## ----------------------------------------------- ##" + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_check_type LINENO TYPE VAR INCLUDES +# ------------------------------------------- +# Tests whether TYPE exists after having included INCLUDES, setting cache +# variable VAR accordingly. +ac_fn_c_check_type () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof ($2)) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof (($2))) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + eval "$3=yes" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_type + +# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES +# -------------------------------------------- +# Tries to find the compile-time value of EXPR in a program that includes +# INCLUDES, setting VAR accordingly. Returns whether the value could be +# computed +ac_fn_c_compute_int () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if test "$cross_compiling" = yes; then + # Depending upon the size, compute the lo and hi bounds. +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=0 ac_mid=0 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid; break +else + as_fn_arith $ac_mid + 1 && ac_lo=$as_val + if test $ac_lo -le $ac_mid; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) < 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=-1 ac_mid=-1 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=$ac_mid; break +else + as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val + if test $ac_mid -le $ac_hi; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + ac_lo= ac_hi= +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +# Binary search between lo and hi bounds. +while test "x$ac_lo" != "x$ac_hi"; do + as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid +else + as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +case $ac_lo in #(( +?*) eval "$3=\$ac_lo"; ac_retval=0 ;; +'') ac_retval=1 ;; +esac + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +static long int longval () { return $2; } +static unsigned long int ulongval () { return $2; } +#include +#include +int +main () +{ + + FILE *f = fopen ("conftest.val", "w"); + if (! f) + return 1; + if (($2) < 0) + { + long int i = longval (); + if (i != ($2)) + return 1; + fprintf (f, "%ld", i); + } + else + { + unsigned long int i = ulongval (); + if (i != ($2)) + return 1; + fprintf (f, "%lu", i); + } + /* Do not output a trailing newline, as this causes \r\n confusion + on some platforms. */ + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + echo >>conftest.val; read $3 &5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Define $2 to an innocuous variant, in case declares $2. + For example, HP-UX 11i declares gettimeofday. */ +#define $2 innocuous_$2 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $2 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main () +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func + +# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES +# --------------------------------------------- +# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR +# accordingly. +ac_fn_c_check_decl () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + as_decl_name=`echo $2|sed 's/ *(.*//'` + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 +$as_echo_n "checking whether $as_decl_name is declared... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +#ifndef $as_decl_name +#ifdef __cplusplus + (void) $as_decl_use; +#else + (void) $as_decl_name; +#endif +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_decl +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by The Glorious Glasgow Haskell Compilation System $as_me 7.10.3, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +# Set this to YES for a released version, otherwise NO +: ${RELEASE=YES} + +# The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line +# above. If this is not a released version, then we will append the +# date to the version number (e.g. 7.4.20111220). The date is +# constructed by finding the date of the most recent patch in the +# git repository. If this is a source distribution (not a git +# checkout), then we ship a file 'VERSION' containing the full version +# when the source distribution was created. + +if test ! -f mk/config.h.in; then + echo "mk/config.h.in doesn't exist: perhaps you haven't run 'perl boot'?" + exit 1 +fi + +CONFIGURE_ARGS=$ac_configure_args + + + +for ac_prog in gfind find +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_fp_prog_find+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $fp_prog_find in + [\\/]* | ?:[\\/]*) + ac_cv_path_fp_prog_find="$fp_prog_find" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_fp_prog_find="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +fp_prog_find=$ac_cv_path_fp_prog_find +if test -n "$fp_prog_find"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_prog_find" >&5 +$as_echo "$fp_prog_find" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$fp_prog_find" && break +done +test -n "$fp_prog_find" || fp_prog_find="find" + +echo foo > conftest.txt +$fp_prog_find conftest.txt -print > conftest.out 2>&1 +if grep '^conftest.txt$' conftest.out > /dev/null 2>&1 ; then + # OK, looks like a real "find". + case $HostPlatform in + *mingw32) + if test x${OSTYPE} != xmsys + then + fp_prog_find="`cygpath --mixed ${fp_prog_find}`" + { $as_echo "$as_me:${as_lineno-$LINENO}: normalized find command to $fp_prog_find" >&5 +$as_echo "$as_me: normalized find command to $fp_prog_find" >&6;} + fi ;; + *) ;; + esac + FindCmd="$fp_prog_find" +else + # Found a poor WinDoze version of "find", ignore it. + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $fp_prog_find looks like a non-*nix find, ignoring it" >&5 +$as_echo "$as_me: WARNING: $fp_prog_find looks like a non-*nix find, ignoring it" >&2;} + # Extract the first word of "find", so it can be a program name with args. +set dummy find; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_FindCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$FindCmd"; then + ac_cv_prog_FindCmd="$FindCmd" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "$fp_prog_find"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_FindCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_FindCmd + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set FindCmd to just the basename; use the full file name. + shift + ac_cv_prog_FindCmd="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +FindCmd=$ac_cv_prog_FindCmd +if test -n "$FindCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FindCmd" >&5 +$as_echo "$FindCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +rm -f conftest.txt conftest.out + +# Extract the first word of "sort", so it can be a program name with args. +set dummy sort; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_fp_prog_sort+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $fp_prog_sort in + [\\/]* | ?:[\\/]*) + ac_cv_path_fp_prog_sort="$fp_prog_sort" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_fp_prog_sort="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +fp_prog_sort=$ac_cv_path_fp_prog_sort +if test -n "$fp_prog_sort"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_prog_sort" >&5 +$as_echo "$fp_prog_sort" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +echo conwip > conftest.txt +$fp_prog_sort -f conftest.txt > conftest.out 2>&1 +if grep 'conwip' conftest.out > /dev/null 2>&1 ; then + # The goods + SortCmd="$fp_prog_sort" +else + # Summink else..pick next one. + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $fp_prog_sort looks like a non-*nix sort, ignoring it" >&5 +$as_echo "$as_me: WARNING: $fp_prog_sort looks like a non-*nix sort, ignoring it" >&2;} + # Extract the first word of "sort", so it can be a program name with args. +set dummy sort; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_SortCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$SortCmd"; then + ac_cv_prog_SortCmd="$SortCmd" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "$fp_prog_sort"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_SortCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_SortCmd + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set SortCmd to just the basename; use the full file name. + shift + ac_cv_prog_SortCmd="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +SortCmd=$ac_cv_prog_SortCmd +if test -n "$SortCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $SortCmd" >&5 +$as_echo "$SortCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +rm -f conftest.txt conftest.out + + + +if test "$RELEASE" = "NO"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GHC version date" >&5 +$as_echo_n "checking for GHC version date... " >&6; } + if test -f VERSION_DATE; then + PACKAGE_VERSION=${PACKAGE_VERSION}.`cat VERSION_DATE` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: given $PACKAGE_VERSION" >&5 +$as_echo "given $PACKAGE_VERSION" >&6; } + elif test -d .git; then + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` + if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else + as_fn_error $? "failed to detect version date: check that git is in your path" "$LINENO" 5 + fi + PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date + { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_VERSION" >&5 +$as_echo "inferred $PACKAGE_VERSION" >&6; } + elif test -f VERSION; then + PACKAGE_VERSION=`cat VERSION` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: given $PACKAGE_VERSION" >&5 +$as_echo "given $PACKAGE_VERSION" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine snapshot version: no .git directory and no VERSION file" >&5 +$as_echo "$as_me: WARNING: cannot determine snapshot version: no .git directory and no VERSION file" >&2;} + PACKAGE_VERSION=${PACKAGE_VERSION}.`date +%Y%m%d` + fi +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GHC Git commit id" >&5 +$as_echo_n "checking for GHC Git commit id... " >&6; } + if test -d .git; then + git_commit_id=`git rev-parse HEAD` + if test -n "$git_commit_id" 2>&1 >/dev/null; then true; else + as_fn_error $? "failed to detect revision: check that git is in your path" "$LINENO" 5 + fi + PACKAGE_GIT_COMMIT_ID=$git_commit_id + { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_GIT_COMMIT_ID" >&5 +$as_echo "inferred $PACKAGE_GIT_COMMIT_ID" >&6; } + elif test -f GIT_COMMIT_ID; then + PACKAGE_GIT_COMMIT_ID=`cat GIT_COMMIT_ID` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: given $PACKAGE_GIT_COMMIT_ID" >&5 +$as_echo "given $PACKAGE_GIT_COMMIT_ID" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine snapshot revision: no .git directory and no 'GIT_COMMIT_ID' file" >&5 +$as_echo "$as_me: WARNING: cannot determine snapshot revision: no .git directory and no 'GIT_COMMIT_ID' file" >&2;} + PACKAGE_GIT_COMMIT_ID="0000000000000000000000000000000000000000" + fi + + +# Some renamings +ProjectName=$PACKAGE_NAME + +ProjectVersion=$PACKAGE_VERSION + +ProjectGitCommitId=$PACKAGE_GIT_COMMIT_ID + + +# Split PACKAGE_VERSION into (possibly empty) parts +VERSION_MAJOR=`echo $PACKAGE_VERSION | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\1'/` +VERSION_TMP=`echo $PACKAGE_VERSION | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\3'/` +VERSION_MINOR=`echo $VERSION_TMP | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\1'/` +ProjectPatchLevel=`echo $VERSION_TMP | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\3'/` + +# Calculate project version as an integer, using 2 digits for minor version +case $VERSION_MINOR in + ?) ProjectVersionInt=${VERSION_MAJOR}0${VERSION_MINOR} ;; + ??) ProjectVersionInt=${VERSION_MAJOR}${VERSION_MINOR} ;; + *) as_fn_error $? "bad minor version in $PACKAGE_VERSION" "$LINENO" 5 ;; +esac + + +# The project patchlevel is zero unless stated otherwise +test -z "$ProjectPatchLevel" && ProjectPatchLevel=0 + +# Save split version of ProjectPatchLevel +ProjectPatchLevel1=`echo $ProjectPatchLevel | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\1/'` +ProjectPatchLevel2=`echo $ProjectPatchLevel | sed 's/^\([^.]*\)\(\.\{0,1\}\(.*\)\)$/\3/'` + + + + +# Remove dots from the patch level; this allows us to have versions like 6.4.1.20050508 +ProjectPatchLevel=`echo $ProjectPatchLevel | sed 's/\.//'` + + + + +# Hmmm, we fix the RPM release number to 1 here... Is this convenient? +release=1 + + +# First off, a distrib sanity check.. + + + + +# ------------------------------------------------------------------------- +# Prepare to generate the following header files +# +# +ac_config_headers="$ac_config_headers mk/config.h" + + +# No, semi-sadly, we don't do `--srcdir'... +if test x"$srcdir" != 'x.' ; then + echo "This configuration does not support the \`--srcdir' option.." + exit 1 +fi + + + + +# Check whether --with-ghc was given. +if test "${with_ghc+set}" = set; then : + withval=$with_ghc; WithGhc="$withval" +else + if test "$GHC" = ""; then + # Extract the first word of "ghc", so it can be a program name with args. +set dummy ghc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_GHC+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $GHC in + [\\/]* | ?:[\\/]*) + ac_cv_path_GHC="$GHC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_GHC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +GHC=$ac_cv_path_GHC +if test -n "$GHC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GHC" >&5 +$as_echo "$GHC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + WithGhc="$GHC" +fi + + + + +# Check whether --enable-bootstrap-with-devel-snapshot was given. +if test "${enable_bootstrap_with_devel_snapshot+set}" = set; then : + enableval=$enable_bootstrap_with_devel_snapshot; EnableBootstrapWithDevelSnaphost=YES +else + EnableBootstrapWithDevelSnaphost=NO + +fi + + +# Check whether --enable-tarballs-autodownload was given. +if test "${enable_tarballs_autodownload+set}" = set; then : + enableval=$enable_tarballs_autodownload; TarballsAutodownload=YES +else + TarballsAutodownload=NO + +fi + +if test "$WithGhc" != ""; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking version of ghc" >&5 +$as_echo_n "checking version of ghc... " >&6; } + "${WithGhc-ghc}" --version > conftestghc 2>&1 + cat conftestghc >&5 +#Useless Use Of cat award... + fptools_version_of_ghc=`cat conftestghc | sed -n -e 's/, patchlevel *\([0-9]\)/.\1/;s/.* version \([0-9][0-9.]*\).*/\1/p'` + rm -fr conftest* + if test "$fptools_version_of_ghc" = "" + then + fptools_version_of_ghc='unknown' + fi +fptools_version_of_ghc_major=`echo $fptools_version_of_ghc | sed -e 's/^\([0-9]\).*/\1/'` +fptools_version_of_ghc_minor=`echo $fptools_version_of_ghc | sed -e 's/^[0-9]\.\([0-9]*\).*/\1/'` +fptools_version_of_ghc_pl=`echo $fptools_version_of_ghc | sed -n -e 's/^[0-9]\.[0-9]*\.\([0-9]*\)/\1/p'` +# +if test "$fptools_version_of_ghc_pl" = "" +then + fptools_version_of_ghc_all="$fptools_version_of_ghc_major.$fptools_version_of_ghc_minor" + fptools_version_of_ghc_pl="0" +else + fptools_version_of_ghc_all="$fptools_version_of_ghc_major.$fptools_version_of_ghc_minor.$fptools_version_of_ghc_pl" +fi +# +GhcVersion="$fptools_version_of_ghc_all" +GhcMajVersion="$fptools_version_of_ghc_major" +GhcMinVersion="$fptools_version_of_ghc_minor" +GhcPatchLevel="$fptools_version_of_ghc_pl" + + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_version_of_ghc" >&5 +$as_echo "$fptools_version_of_ghc" >&6; } + + + if test "$GhcMajVersion" = "unknown" -o "$GhcMinVersion" = "unknown"; then + as_fn_error $? "Cannot determine the version of $WithGhc. Is it really GHC?" "$LINENO" 5 + fi + + GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` + GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" + + +CC_STAGE0=`"$WithGhc" --info | grep "^ ,(\"C compiler command\"," | sed -e 's/.*","//' -e 's/")$//'` +tmp=${CC_STAGE0#\$topdir/} +if test "${CC_STAGE0}" != "$tmp" +then + topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'` + CC_STAGE0="$topdir/$tmp" +fi + + + +AR_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar command\"," | sed -e 's/.*","//' -e 's/")$//'` +tmp=${AR_STAGE0#\$topdir/} +if test "${AR_STAGE0}" != "$tmp" +then + topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'` + AR_STAGE0="$topdir/$tmp" +fi + + + +AR_OPTS_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar flags\"," | sed -e 's/.*","//' -e 's/")$//'` +tmp=${AR_OPTS_STAGE0#\$topdir/} +if test "${AR_OPTS_STAGE0}" != "$tmp" +then + topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'` + AR_OPTS_STAGE0="$topdir/$tmp" +fi + + + +ArSupportsAtFile_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar supports at file\"," | sed -e 's/.*","//' -e 's/")$//'` +tmp=${ArSupportsAtFile_STAGE0#\$topdir/} +if test "${ArSupportsAtFile_STAGE0}" != "$tmp" +then + topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'` + ArSupportsAtFile_STAGE0="$topdir/$tmp" +fi + + +fi + +if test "$WithGhc" = "" +then + as_fn_error $? "GHC is required." "$LINENO" 5 +fi +fp_version1=$GhcVersion; fp_version2=7.6 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + as_fn_error $? "GHC version 7.6 or later is required to compile GHC." "$LINENO" 5 +fi + +if test `expr $GhcMinVersion % 2` = "1" +then + if test "$EnableBootstrapWithDevelSnaphost" = "NO" + then + as_fn_error $? " + $WithGhc is a development snapshot of GHC, version $GhcVersion. + Bootstrapping using this version of GHC is not supported, and may not + work. Use --enable-bootstrap-with-devel-snapshot to try it anyway, + or --with-ghc to specify a different GHC to use." "$LINENO" 5 + fi +fi + +GHC_PACKAGE_DB_FLAG=package-db + + +# GHC 7.7+ needs -fcmm-sink when compiling Parser.hs. See #8182 +fp_version1=$GhcVersion; fp_version2=7.7 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -gt "$fp_num2"; then : + CMM_SINK_BOOTSTRAP_IS_NEEDED=YES +else + CMM_SINK_BOOTSTRAP_IS_NEEDED=NO +fi + + +fp_version1=$GhcVersion; fp_version2=7.9 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + SUPPORTS_PACKAGE_KEY=NO +else + SUPPORTS_PACKAGE_KEY=YES +fi + + +# GHC is passed to Cabal, so we need a native path +if test "${WithGhc}" != "" +then + ghc_host_os=`"${WithGhc}" +RTS --info | grep 'Host OS' | sed -e 's/.*, "//' -e 's/")//'` + + if test "$ghc_host_os" = "mingw32" + then + if test "${OSTYPE}" = "msys" + then + WithGhc=`echo "${WithGhc}" | sed "s#^/\([a-zA-Z]\)/#\1:/#"` + else + # Canonicalise to :/path/to/ghc + WithGhc=`cygpath -m "${WithGhc}"` + fi + echo "GHC path canonicalised to: ${WithGhc}" + fi +fi + + +SRC_CC_OPTS="-O" + + +if test "${WithGhc}" != "" +then + bootstrap_host=`"${WithGhc}" +RTS --info | grep '^ ,("Host platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` + bootstrap_target=`"${WithGhc}" +RTS --info | grep '^ ,("Target platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` + if test "$bootstrap_host" != "$bootstrap_target" + then + echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work" + fi +fi + +# We have to run these unconditionally, but we may discard their +# results in the following code +ac_aux_dir= +for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +$as_echo_n "checking build system type... " >&6; } +if ${ac_cv_build+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +$as_echo "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +$as_echo_n "checking host system type... " >&6; } +if ${ac_cv_host+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +$as_echo "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 +$as_echo_n "checking target system type... " >&6; } +if ${ac_cv_target+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$target_alias" = x; then + ac_cv_target=$ac_cv_host +else + ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 +$as_echo "$ac_cv_target" >&6; } +case $ac_cv_target in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; +esac +target=$ac_cv_target +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_target +shift +target_cpu=$1 +target_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +target_os=$* +IFS=$ac_save_IFS +case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac + + +# The aliases save the names the user supplied, while $host etc. +# will get canonicalized. +test -n "$target_alias" && + test "$program_prefix$program_suffix$program_transform_name" = \ + NONENONEs,x,x, && + program_prefix=${target_alias}- + + + # If no argument was given for a configuration variable, then discard + # the guessed canonical system and use the configuration of the + # bootstrapping ghc. If an argument was given, map it from gnu format + # to ghc format. + # + # For why we do it this way, see: #3637, #1717, #2951 + # + # In bindists, we haven't called AC_CANONICAL_{BUILD,HOST,TARGET} + # so this justs uses $bootstrap_target. + + if test "$build_alias" = "" + then + if test "$bootstrap_target" != "" + then + build=$bootstrap_target + echo "Build platform inferred as: $build" + else + echo "Can't work out build platform" + exit 1 + fi + + BuildArch=`echo "$build" | sed 's/-.*//'` + BuildVendor=`echo "$build" | sed -e 's/.*-\(.*\)-.*/\1/'` + BuildOS=`echo "$build" | sed 's/.*-//'` + else + +case "$build_cpu" in + aarch64*) + BuildArch="aarch64" + ;; + alpha*) + BuildArch="alpha" + ;; + arm*) + BuildArch="arm" + ;; + hppa1.1*) + BuildArch="hppa1_1" + ;; + hppa*) + BuildArch="hppa" + ;; + i386|i486|i586|i686) + BuildArch="i386" + ;; + ia64) + BuildArch="ia64" + ;; + m68k*) + BuildArch="m68k" + ;; + mipseb*) + BuildArch="mipseb" + ;; + mipsel*) + BuildArch="mipsel" + ;; + mips*) + BuildArch="mips" + ;; + powerpc64le*) + BuildArch="powerpc64le" + ;; + powerpc64*) + BuildArch="powerpc64" + ;; + powerpc*) + BuildArch="powerpc" + ;; + rs6000) + BuildArch="rs6000" + ;; + s390x*) + BuildArch="s390x" + ;; + s390*) + BuildArch="s390" + ;; + sparc64*) + BuildArch="sparc64" + ;; + sparc*) + BuildArch="sparc" + ;; + vax) + BuildArch="vax" + ;; + x86_64|amd64) + BuildArch="x86_64" + ;; + *) + echo "Unknown CPU $build_cpu" + exit 1 + ;; + esac + + + case "$build_vendor" in + pc|gentoo|w64) # like i686-pc-linux-gnu, i686-gentoo-freebsd8, x86_64-w64-mingw32 + BuildVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + BuildVendor="unknown" + ;; + *) + #pass thru by default + BuildVendor="$build_vendor" + ;; + esac + + +case "$build_os-$BuildArch" in + darwin10-arm|darwin11-i386|darwin14-aarch64) + BuildOS="ios" + ;; + *) + case "$build_os" in + linux-android*) + BuildOS="linux-android" + ;; + linux-*|linux) + BuildOS="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + BuildOS="$build_os" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + BuildOS="freebsd" + ;; + nto-qnx*) + BuildOS="nto-qnx" + ;; + *) + echo "Unknown OS $build_os" + exit 1 + ;; + esac + ;; + esac + + fi + + if test "$host_alias" = "" + then + if test "$bootstrap_target" != "" + then + host=$bootstrap_target + echo "Host platform inferred as: $host" + else + echo "Can't work out host platform" + exit 1 + fi + + HostArch=`echo "$host" | sed 's/-.*//'` + HostVendor=`echo "$host" | sed -e 's/.*-\(.*\)-.*/\1/'` + HostOS=`echo "$host" | sed 's/.*-//'` + else + +case "$host_cpu" in + aarch64*) + HostArch="aarch64" + ;; + alpha*) + HostArch="alpha" + ;; + arm*) + HostArch="arm" + ;; + hppa1.1*) + HostArch="hppa1_1" + ;; + hppa*) + HostArch="hppa" + ;; + i386|i486|i586|i686) + HostArch="i386" + ;; + ia64) + HostArch="ia64" + ;; + m68k*) + HostArch="m68k" + ;; + mipseb*) + HostArch="mipseb" + ;; + mipsel*) + HostArch="mipsel" + ;; + mips*) + HostArch="mips" + ;; + powerpc64le*) + HostArch="powerpc64le" + ;; + powerpc64*) + HostArch="powerpc64" + ;; + powerpc*) + HostArch="powerpc" + ;; + rs6000) + HostArch="rs6000" + ;; + s390x*) + HostArch="s390x" + ;; + s390*) + HostArch="s390" + ;; + sparc64*) + HostArch="sparc64" + ;; + sparc*) + HostArch="sparc" + ;; + vax) + HostArch="vax" + ;; + x86_64|amd64) + HostArch="x86_64" + ;; + *) + echo "Unknown CPU $host_cpu" + exit 1 + ;; + esac + + + case "$host_vendor" in + pc|gentoo|w64) # like i686-pc-linux-gnu, i686-gentoo-freebsd8, x86_64-w64-mingw32 + HostVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + HostVendor="unknown" + ;; + *) + #pass thru by default + HostVendor="$host_vendor" + ;; + esac + + +case "$host_os-$HostArch" in + darwin10-arm|darwin11-i386|darwin14-aarch64) + HostOS="ios" + ;; + *) + case "$host_os" in + linux-android*) + HostOS="linux-android" + ;; + linux-*|linux) + HostOS="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + HostOS="$host_os" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + HostOS="freebsd" + ;; + nto-qnx*) + HostOS="nto-qnx" + ;; + *) + echo "Unknown OS $host_os" + exit 1 + ;; + esac + ;; + esac + + fi + + if test "$target_alias" = "" + then + if test "$host_alias" != "" + then + +case "$host_cpu" in + aarch64*) + TargetArch="aarch64" + ;; + alpha*) + TargetArch="alpha" + ;; + arm*) + TargetArch="arm" + ;; + hppa1.1*) + TargetArch="hppa1_1" + ;; + hppa*) + TargetArch="hppa" + ;; + i386|i486|i586|i686) + TargetArch="i386" + ;; + ia64) + TargetArch="ia64" + ;; + m68k*) + TargetArch="m68k" + ;; + mipseb*) + TargetArch="mipseb" + ;; + mipsel*) + TargetArch="mipsel" + ;; + mips*) + TargetArch="mips" + ;; + powerpc64le*) + TargetArch="powerpc64le" + ;; + powerpc64*) + TargetArch="powerpc64" + ;; + powerpc*) + TargetArch="powerpc" + ;; + rs6000) + TargetArch="rs6000" + ;; + s390x*) + TargetArch="s390x" + ;; + s390*) + TargetArch="s390" + ;; + sparc64*) + TargetArch="sparc64" + ;; + sparc*) + TargetArch="sparc" + ;; + vax) + TargetArch="vax" + ;; + x86_64|amd64) + TargetArch="x86_64" + ;; + *) + echo "Unknown CPU $host_cpu" + exit 1 + ;; + esac + + + case "$host_vendor" in + pc|gentoo|w64) # like i686-pc-linux-gnu, i686-gentoo-freebsd8, x86_64-w64-mingw32 + TargetVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + TargetVendor="unknown" + ;; + *) + #pass thru by default + TargetVendor="$host_vendor" + ;; + esac + + +case "$host_os-$TargetArch" in + darwin10-arm|darwin11-i386|darwin14-aarch64) + TargetOS="ios" + ;; + *) + case "$host_os" in + linux-android*) + TargetOS="linux-android" + ;; + linux-*|linux) + TargetOS="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + TargetOS="$host_os" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + TargetOS="freebsd" + ;; + nto-qnx*) + TargetOS="nto-qnx" + ;; + *) + echo "Unknown OS $host_os" + exit 1 + ;; + esac + ;; + esac + + else + if test "$bootstrap_target" != "" + then + target=$bootstrap_target + echo "Target platform inferred as: $target" + else + echo "Can't work out target platform" + exit 1 + fi + + TargetArch=`echo "$target" | sed 's/-.*//'` + TargetVendor=`echo "$target" | sed -e 's/.*-\(.*\)-.*/\1/'` + TargetOS=`echo "$target" | sed 's/.*-//'` + fi + else + +case "$target_cpu" in + aarch64*) + TargetArch="aarch64" + ;; + alpha*) + TargetArch="alpha" + ;; + arm*) + TargetArch="arm" + ;; + hppa1.1*) + TargetArch="hppa1_1" + ;; + hppa*) + TargetArch="hppa" + ;; + i386|i486|i586|i686) + TargetArch="i386" + ;; + ia64) + TargetArch="ia64" + ;; + m68k*) + TargetArch="m68k" + ;; + mipseb*) + TargetArch="mipseb" + ;; + mipsel*) + TargetArch="mipsel" + ;; + mips*) + TargetArch="mips" + ;; + powerpc64le*) + TargetArch="powerpc64le" + ;; + powerpc64*) + TargetArch="powerpc64" + ;; + powerpc*) + TargetArch="powerpc" + ;; + rs6000) + TargetArch="rs6000" + ;; + s390x*) + TargetArch="s390x" + ;; + s390*) + TargetArch="s390" + ;; + sparc64*) + TargetArch="sparc64" + ;; + sparc*) + TargetArch="sparc" + ;; + vax) + TargetArch="vax" + ;; + x86_64|amd64) + TargetArch="x86_64" + ;; + *) + echo "Unknown CPU $target_cpu" + exit 1 + ;; + esac + + + case "$target_vendor" in + pc|gentoo|w64) # like i686-pc-linux-gnu, i686-gentoo-freebsd8, x86_64-w64-mingw32 + TargetVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + TargetVendor="unknown" + ;; + *) + #pass thru by default + TargetVendor="$target_vendor" + ;; + esac + + +case "$target_os-$TargetArch" in + darwin10-arm|darwin11-i386|darwin14-aarch64) + TargetOS="ios" + ;; + *) + case "$target_os" in + linux-android*) + TargetOS="linux-android" + ;; + linux-*|linux) + TargetOS="linux" + ;; + # As far as I'm aware, none of these have relevant variants + freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + TargetOS="$target_os" + ;; + freebsd*) # like i686-gentoo-freebsd7 + # i686-gentoo-freebsd8 + # i686-gentoo-freebsd8.2 + TargetOS="freebsd" + ;; + nto-qnx*) + TargetOS="nto-qnx" + ;; + *) + echo "Unknown OS $target_os" + exit 1 + ;; + esac + ;; + esac + + fi + + + exeext_host='' + soext_host='.so' + case $host in + *-unknown-cygwin32) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: GHC does not support the Cygwin target at the moment" >&5 +$as_echo "$as_me: WARNING: GHC does not support the Cygwin target at the moment" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&5 +$as_echo "$as_me: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&2;} + exit 1 + ;; + *-unknown-mingw32) + windows=YES + exeext_host='.exe' + soext_host='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + soext_host='.dylib' + ;; + x86_64-apple-darwin) + soext_host='.dylib' + ;; + arm-apple-darwin10|i386-apple-darwin11|aarch64-apple-darwin14) + exeext_host='.a' + soext_host='.dylib' + ;; + esac + + + exeext_target='' + soext_target='.so' + case $target in + *-unknown-cygwin32) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: GHC does not support the Cygwin target at the moment" >&5 +$as_echo "$as_me: WARNING: GHC does not support the Cygwin target at the moment" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&5 +$as_echo "$as_me: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&2;} + exit 1 + ;; + *-unknown-mingw32) + windows=YES + exeext_target='.exe' + soext_target='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + soext_target='.dylib' + ;; + x86_64-apple-darwin) + soext_target='.dylib' + ;; + arm-apple-darwin10|i386-apple-darwin11|aarch64-apple-darwin14) + exeext_target='.a' + soext_target='.dylib' + ;; + esac + + windows=NO + case $host in + *-unknown-mingw32) + windows=YES + ;; + esac + + BuildPlatform="$BuildArch-$BuildVendor-$BuildOS" + BuildPlatform_CPP=`echo "$BuildPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildArch_CPP=` echo "$BuildArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildVendor_CPP=` echo "$BuildVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + BuildOS_CPP=` echo "$BuildOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + HostPlatform="$HostArch-$HostVendor-$HostOS" + HostPlatform_CPP=`echo "$HostPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostArch_CPP=` echo "$HostArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostVendor_CPP=` echo "$HostVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + HostOS_CPP=` echo "$HostOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + TargetPlatform="$TargetArch-$TargetVendor-$TargetOS" + TargetPlatform_CPP=`echo "$TargetPlatform" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetArch_CPP=` echo "$TargetArch" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetVendor_CPP=` echo "$TargetVendor" | sed -e 's/\./_/g' -e 's/-/_/g'` + TargetOS_CPP=` echo "$TargetOS" | sed -e 's/\./_/g' -e 's/-/_/g'` + + echo "GHC build : $BuildPlatform" + echo "GHC host : $HostPlatform" + echo "GHC target : $TargetPlatform" + + + + + + + + + + + + + + + + + + + + + + + + + + +# Verify that the installed (bootstrap) GHC is capable of generating +# code for the requested build platform. +if test "$BuildPlatform" != "$bootstrap_target" +then + echo "This GHC (${WithGhc}) does not generate code for the build platform" + echo " GHC target platform : $bootstrap_target" + echo " Desired build platform : $BuildPlatform" + exit 1 +fi + +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + +case $host in + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; +esac + + + +case "$HostArch" in + i386|x86_64|powerpc|arm) + UnregisterisedDefault=NO + ;; + *) + UnregisterisedDefault=YES + ;; +esac +# Check whether --enable-unregisterised was given. +if test "${enable_unregisterised+set}" = set; then : + enableval=$enable_unregisterised; if test x"$enableval" = x"yes"; then + Unregisterised=YES + else + Unregisterised=NO + fi + +else + Unregisterised="$UnregisterisedDefault" + +fi + + + + +# Check whether --with-hc was given. +if test "${with_hc+set}" = set; then : + withval=$with_hc; WithHc="$withval" +else + WithHc=$WithGhc + +fi + + + +# This uses GHC, so put it after the "GHC is required" check above: + +{ $as_echo "$as_me:${as_lineno-$LINENO}: Building in-tree ghc-pwd" >&5 +$as_echo "$as_me: Building in-tree ghc-pwd" >&6;} + rm -rf utils/ghc-pwd/dist-boot + mkdir utils/ghc-pwd/dist-boot + GHC_LDFLAGS=`perl -e 'foreach (@ARGV) { print "-optl$_ " }' -- $LDFLAGS` + if ! "$WithGhc" $GHC_LDFLAGS -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd + then + as_fn_error $? "Building ghc-pwd failed" "$LINENO" 5 + fi + + GHC_PWD=utils/ghc-pwd/dist-boot/ghc-pwd + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for path to top of build tree" >&5 +$as_echo_n "checking for path to top of build tree... " >&6; } + hardtop=`$GHC_PWD` + + hardtop=`echo $hardtop | sed 's|^/tmp_mnt.*\(/local/.*\)$|\1|' | sed 's|^/tmp_mnt/|/|'` + + if ! test -d "$hardtop"; then + as_fn_error $? "cannot determine current directory" "$LINENO" 5 + fi + + case "$hardtop" in + *' '*) + as_fn_error $? " + The build system does not support building in a directory + containing space characters. + Suggestion: move the build tree somewhere else." "$LINENO" 5 + ;; + esac + + + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hardtop" >&5 +$as_echo "$hardtop" >&6; } + + +fail() { + echo >&2 + echo "$1" >&2 + exit 1 +} + + +if test "$HostOS" = "mingw32" +then + # Find the mingw-w64 7z file to extract. + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if test "$HostArch" = "i386" + then + mingw_arch="i686" + tarball_dest_dir="mingw-w64/x86" + tarball_mingw_dir="mingw32" + else + mingw_arch="x86_64" + tarball_dest_dir="mingw-w64/x86_64" + tarball_mingw_dir="mingw64" + fi +fi + +set_up_tarballs() { + { $as_echo "$as_me:${as_lineno-$LINENO}: Checking for Windows toolchain tarballs..." >&5 +$as_echo "$as_me: Checking for Windows toolchain tarballs..." >&6;} + local action + if test "$TarballsAutodownload" = "NO" + then + action="verify" + else + action="download" + fi + mk/get-win32-tarballs.sh $action $HostArch > missing-win32-tarballs + case $? in + 0) + rm missing-win32-tarballs + ;; + 2) + echo + echo "Error:" + echo "Needed msys2 tarballs are missing. You have a few options to get them," + echo + echo " * run configure with the --enable-tarballs-autodownload option" + echo + echo " * run mk/get-win32-tarballs.sh download ${HostArch}" + echo + echo " * manually download the files listed in ./missing-win32-tarballs and place" + echo " them in the ghc-tarballs directory." + echo + exit 1 + ;; + *) + echo + echo "Error fetching msys2 tarballs; see errors above." + exit 1 + ;; + esac + + # Extract all the tarballs in one go + if ! test -d inplace/mingw + then + { $as_echo "$as_me:${as_lineno-$LINENO}: Extracting Windows toolchain from archives (may take a while)..." >&5 +$as_echo "$as_me: Extracting Windows toolchain from archives (may take a while)..." >&6;} + rm -rf inplace/mingw + local base_dir="../ghc-tarballs/${tarball_dest_dir}" + ( cd inplace && + find "${base_dir}" -name "*.tar.xz" -exec tar xfJ {} \; && + rm ".MTREE" && + rm ".PKGINFO" && + cd .. ) || fail "Error: Could not extract Windows toolchains." + + mv "inplace/${tarball_mingw_dir}" inplace/mingw && + touch inplace/mingw + + # NB. Now since the GCC is hardcoded to use /mingw32 we need to + # make a wrapper around it to give it the proper paths + mv inplace/mingw/bin/gcc.exe inplace/mingw/bin/realgcc.exe + PATH=`pwd`/inplace/mingw/bin:$PATH + inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe + + { $as_echo "$as_me:${as_lineno-$LINENO}: In-tree MingW-w64 tree created" >&5 +$as_echo "$as_me: In-tree MingW-w64 tree created" >&6;} + fi +} + +if test "$HostOS" = "mingw32" +then + test -d inplace || mkdir inplace + + # NB. Download and extract the MingW-w64 distribution if required + set_up_tarballs + + mingwbin="$hardtop/inplace/mingw/bin/" + CC="${mingwbin}gcc.exe" + LD="${mingwbin}ld.exe" + NM="${mingwbin}nm.exe" + RANLIB="${mingwbin}ranlib.exe" + OBJDUMP="${mingwbin}objdump.exe" + fp_prog_ar="${mingwbin}ar.exe" + + # NB. Download the perl binaries if required + if ! test -d inplace/perl || + test inplace/perl -ot ghc-tarballs/perl/ghc-perl*.tar.gz + then + { $as_echo "$as_me:${as_lineno-$LINENO}: Making in-tree perl tree" >&5 +$as_echo "$as_me: Making in-tree perl tree" >&6;} + rm -rf inplace/perl + mkdir inplace/perl + ( + cd inplace/perl && + tar -zxf ../../ghc-tarballs/perl/ghc-perl*.tar.gz + ) + { $as_echo "$as_me:${as_lineno-$LINENO}: In-tree perl tree created" >&5 +$as_echo "$as_me: In-tree perl tree created" >&6;} + fi +fi + + + + + +# Check whether --with-iconv-includes was given. +if test "${with_iconv_includes+set}" = set; then : + withval=$with_iconv_includes; ICONV_INCLUDE_DIRS=$withval +fi + + + +# Check whether --with-iconv-libraries was given. +if test "${with_iconv_libraries+set}" = set; then : + withval=$with_iconv_libraries; ICONV_LIB_DIRS=$withval +fi + + + + + + + + +# Check whether --with-gmp-includes was given. +if test "${with_gmp_includes+set}" = set; then : + withval=$with_gmp_includes; GMP_INCLUDE_DIRS=$withval +fi + + + +# Check whether --with-gmp-libraries was given. +if test "${with_gmp_libraries+set}" = set; then : + withval=$with_gmp_libraries; GMP_LIB_DIRS=$withval +fi + + + + + + + + +# Check whether --with-curses-includes was given. +if test "${with_curses_includes+set}" = set; then : + withval=$with_curses_includes; CURSES_INCLUDE_DIRS=$withval +fi + + + +# Check whether --with-curses-libraries was given. +if test "${with_curses_libraries+set}" = set; then : + withval=$with_curses_libraries; CURSES_LIB_DIRS=$withval +fi + + + + + + + + if test "$TargetOS_CPP" = "darwin" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking XCode version" >&5 +$as_echo_n "checking XCode version... " >&6; } + XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` + # Old XCode versions don't actually give the XCode version + if test "$XCodeVersion" = "" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found (too old?)" >&5 +$as_echo "not found (too old?)" >&6; } + XCodeVersion1=0 + XCodeVersion2=0 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XCodeVersion" >&5 +$as_echo "$XCodeVersion" >&6; } + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` + { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 1: $XCodeVersion1" >&5 +$as_echo "$as_me: XCode version component 1: $XCodeVersion1" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 2: $XCodeVersion2" >&5 +$as_echo "$as_me: XCode version component 2: $XCodeVersion2" >&6;} + fi + fi + + +SplitObjsBroken=NO +if test "$TargetOS_CPP" = "darwin" +then + # Split objects is broken (#4013) with XCode < 3.2 + if test "$XCodeVersion1" -lt 3 + then + SplitObjsBroken=YES + else + if test "$XCodeVersion1" -eq 3 + then + if test "$XCodeVersion2" -lt 2 + then + SplitObjsBroken=YES + fi + fi + fi +fi + + +CrossCompiling=NO +# If 'host' and 'target' differ, then this means we are building a cross-compiler. +if test "$target" != "$host" ; then + CrossCompiling=YES + cross_compiling=yes # This tells configure that it can accept just 'target', + # otherwise you get + # configure: error: cannot run C compiled programs. + # If you meant to cross compile, use `--host'. +fi +if test "$build" != "$host" ; then + as_fn_error $? " +You've selected: + + BUILD: $build (the architecture we're building on) + HOST: $host (the architecture the compiler we're building will execute on) + TARGET: $target (the architecture the compiler we're building will produce code for) + +BUILD must equal HOST; that is, we do not support building GHC itself +with a cross-compiler. To cross-compile GHC itself, set TARGET: stage +1 will be a cross-compiler, and stage 2 will be the cross-compiled +GHC. +" "$LINENO" 5 +fi +if test "$CrossCompiling" = "YES" +then + CrossCompilePrefix="${target}-" +else + CrossCompilePrefix="" +fi +TargetPlatformFull="${target}" + + + + + + if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -eq 4 && + test "$XCodeVersion2" -lt 2 + then + # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather + # than the LLVM backend). We prefer the legacy gcc, but in + # Xcode 4.2 'gcc-4.2' was removed. + + +# Check whether --with-gcc-4.2 was given. +if test "${with_gcc_4_2+set}" = set; then : + withval=$with_gcc_4_2; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + WhatGccIsCalled=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_gcc-4.2=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "gcc-4.2", so it can be a program name with args. +set dummy gcc-4.2; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-gcc-4.2", so it can be a program name with args. +set dummy $target_alias-gcc-4.2; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$WhatGccIsCalled" + then + as_fn_error $? "cannot find gcc-4.2 in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + elif test "$windows" = YES + then + WhatGccIsCalled="$CC" + else + + +# Check whether --with-gcc was given. +if test "${with_gcc+set}" = set; then : + withval=$with_gcc; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + WhatGccIsCalled=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_gcc=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-gcc", so it can be a program name with args. +set dummy $target_alias-gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$WhatGccIsCalled" + then + as_fn_error $? "cannot find gcc in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + # From Xcode 5 on/, OS X command line tools do not include gcc + # anymore. Use clang. + if test -z "$WhatGccIsCalled" + then + + +# Check whether --with-clang was given. +if test "${with_clang+set}" = set; then : + withval=$with_clang; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + WhatGccIsCalled=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_clang=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "clang", so it can be a program name with args. +set dummy clang; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-clang", so it can be a program name with args. +set dummy $target_alias-clang; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_WhatGccIsCalled+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $WhatGccIsCalled in + [\\/]* | ?:[\\/]*) + ac_cv_path_WhatGccIsCalled="$WhatGccIsCalled" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_WhatGccIsCalled="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +WhatGccIsCalled=$ac_cv_path_WhatGccIsCalled +if test -n "$WhatGccIsCalled"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WhatGccIsCalled" >&5 +$as_echo "$WhatGccIsCalled" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$WhatGccIsCalled" + then + as_fn_error $? "cannot find clang in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + fi + if test -z "$WhatGccIsCalled" + then + as_fn_error $? "cannot find gcc nor clang in your PATH" "$LINENO" 5 + fi + fi + + +CC="$WhatGccIsCalled" +export CC + +# If --with-gcc was used, and we're not cross-compiling, then it also +# applies to the stage0 compiler. + + if test ! -z "$With_gcc" -a "$CrossCompiling" != "YES"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: Not cross-compiling, so --with-gcc also sets CC_STAGE0" >&5 +$as_echo "$as_me: Not cross-compiling, so --with-gcc also sets CC_STAGE0" >&6;} + CC_STAGE0=$With_gcc + fi + + + if test ! -z "$With_ar" -a "$CrossCompiling" != "YES"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: Not cross-compiling, so --with-ar also sets AR_STAGE0" >&5 +$as_echo "$as_me: Not cross-compiling, so --with-ar also sets AR_STAGE0" >&6;} + AR_STAGE0=$With_ar + fi + + +# --with-hs-cpp/--with-hs-cpp-flags + + +# Check whether --with-hs-cpp was given. +if test "${with_hs_cpp+set}" = set; then : + withval=$with_hs_cpp; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + HS_CPP_CMD=$withval + fi + +else + + + HS_CPP_CMD=$WhatGccIsCalled + + SOLARIS_GCC_CPP_BROKEN=NO + SOLARIS_FOUND_GOOD_CPP=NO + case $host in + i386-*-solaris2) + GCC_MAJOR_MINOR=`$WhatGccIsCalled --version|grep "gcc (GCC)"|cut -d ' ' -f 3-3|cut -d '.' -f 1-2` + if test "$GCC_MAJOR_MINOR" != "3.4"; then + # this is not 3.4.x release so with broken CPP + SOLARIS_GCC_CPP_BROKEN=YES + fi + ;; + esac + + if test "$SOLARIS_GCC_CPP_BROKEN" = "YES"; then + # let's try to find if GNU C 3.4.x is installed + if test -x /usr/sfw/bin/gcc; then + # something executable is in expected path so let's + # see if it's really GNU C + NEW_GCC_MAJOR_MINOR=`/usr/sfw/bin/gcc --version|grep "gcc (GCC)"|cut -d ' ' -f 3-3|cut -d '.' -f 1-2` + if test "$NEW_GCC_MAJOR_MINOR" = "3.4"; then + # this is GNU C 3.4.x which provides non-broken CPP on Solaris + # let's use it as CPP then. + HS_CPP_CMD=/usr/sfw/bin/gcc + SOLARIS_FOUND_GOOD_CPP=YES + fi + fi + if test "$SOLARIS_FOUND_GOOD_CPP" = "NO"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Your GNU C provides broken CPP and you do not have GNU C 3.4.x installed." >&5 +$as_echo "$as_me: WARNING: Your GNU C provides broken CPP and you do not have GNU C 3.4.x installed." >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Please install GNU C 3.4.x to solve this issue. It will be used as CPP only." >&5 +$as_echo "$as_me: WARNING: Please install GNU C 3.4.x to solve this issue. It will be used as CPP only." >&2;} + fi + fi + + +fi + + + + + +# Check whether --with-hs-cpp-flags was given. +if test "${with_hs_cpp_flags+set}" = set; then : + withval=$with_hs_cpp_flags; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + HS_CPP_ARGS=$withval + fi + +else + + $HS_CPP_CMD -x c /dev/null -dM -E > conftest.txt 2>&1 + if grep "__clang__" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs " + else + $HS_CPP_CMD -v > conftest.txt 2>&1 + if grep "gcc" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="-E -undef -traditional " + else + $HS_CPP_CMD --version > conftest.txt 2>&1 + if grep "cpphs" conftest.txt >/dev/null 2>&1; then + HS_CPP_ARGS="--cpp -traditional" + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: configure can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly" >&5 +$as_echo "$as_me: WARNING: configure can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly" >&2;} + HS_CPP_ARGS="" + fi + fi + fi + + +fi + + +HaskellCPPCmd=$HS_CPP_CMD +HaskellCPPArgs=$HS_CPP_ARGS + + + + + + +# Check whether --with-ld was given. +if test "${with_ld+set}" = set; then : + withval=$with_ld; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + LD=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_ld=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "ld", so it can be a program name with args. +set dummy ld; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LD+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LD in + [\\/]* | ?:[\\/]*) + ac_cv_path_LD="$LD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LD="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LD=$ac_cv_path_LD +if test -n "$LD"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LD" >&5 +$as_echo "$LD" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-ld", so it can be a program name with args. +set dummy $target_alias-ld; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LD+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LD in + [\\/]* | ?:[\\/]*) + ac_cv_path_LD="$LD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LD="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LD=$ac_cv_path_LD +if test -n "$LD"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LD" >&5 +$as_echo "$LD" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$LD" + then + as_fn_error $? "cannot find ld in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + case $target in + arm*linux* | \ + aarch64*linux* ) + # Arm and Aarch64 requires use of the binutils ld.gold linker. + # This case should catch at least arm-unknown-linux-gnueabihf, + # arm-linux-androideabi, arm64-unknown-linux and + # aarch64-linux-android + + +# Check whether --with-ld.gold was given. +if test "${with_ld_gold+set}" = set; then : + withval=$with_ld_gold; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + LD_GOLD=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_ld.gold=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "ld.gold", so it can be a program name with args. +set dummy ld.gold; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LD_GOLD+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LD_GOLD in + [\\/]* | ?:[\\/]*) + ac_cv_path_LD_GOLD="$LD_GOLD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LD_GOLD="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LD_GOLD=$ac_cv_path_LD_GOLD +if test -n "$LD_GOLD"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LD_GOLD" >&5 +$as_echo "$LD_GOLD" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-ld.gold", so it can be a program name with args. +set dummy $target_alias-ld.gold; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LD_GOLD+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LD_GOLD in + [\\/]* | ?:[\\/]*) + ac_cv_path_LD_GOLD="$LD_GOLD" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LD_GOLD="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LD_GOLD=$ac_cv_path_LD_GOLD +if test -n "$LD_GOLD"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LD_GOLD" >&5 +$as_echo "$LD_GOLD" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$LD_GOLD" + then + as_fn_error $? "cannot find ld.gold in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + LdCmd="$LD_GOLD" + ;; + *) + LdCmd="$LD" + ;; + esac + + + + + +# Check whether --with-nm was given. +if test "${with_nm+set}" = set; then : + withval=$with_nm; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + NM=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_nm=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "nm", so it can be a program name with args. +set dummy nm; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_NM+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $NM in + [\\/]* | ?:[\\/]*) + ac_cv_path_NM="$NM" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_NM="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +NM=$ac_cv_path_NM +if test -n "$NM"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NM" >&5 +$as_echo "$NM" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-nm", so it can be a program name with args. +set dummy $target_alias-nm; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_NM+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $NM in + [\\/]* | ?:[\\/]*) + ac_cv_path_NM="$NM" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_NM="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +NM=$ac_cv_path_NM +if test -n "$NM"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NM" >&5 +$as_echo "$NM" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$NM" + then + as_fn_error $? "cannot find nm in your PATH" "$LINENO" 5 + fi + fi + + +fi + + +NmCmd="$NM" + + + + +# Check whether --with-ar was given. +if test "${with_ar+set}" = set; then : + withval=$with_ar; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + AR=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_ar=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_AR+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $AR in + [\\/]* | ?:[\\/]*) + ac_cv_path_AR="$AR" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_AR="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +AR=$ac_cv_path_AR +if test -n "$AR"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 +$as_echo "$AR" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-ar", so it can be a program name with args. +set dummy $target_alias-ar; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_AR+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $AR in + [\\/]* | ?:[\\/]*) + ac_cv_path_AR="$AR" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_AR="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +AR=$ac_cv_path_AR +if test -n "$AR"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 +$as_echo "$AR" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$AR" + then + as_fn_error $? "cannot find ar in your PATH" "$LINENO" 5 + fi + fi + + +fi + + +ArCmd="$AR" +fp_prog_ar="$AR" + + + + +# Check whether --with-ranlib was given. +if test "${with_ranlib+set}" = set; then : + withval=$with_ranlib; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + RANLIB=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_ranlib=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $RANLIB in + [\\/]* | ?:[\\/]*) + ac_cv_path_RANLIB="$RANLIB" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_RANLIB="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +RANLIB=$ac_cv_path_RANLIB +if test -n "$RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +$as_echo "$RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-ranlib", so it can be a program name with args. +set dummy $target_alias-ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $RANLIB in + [\\/]* | ?:[\\/]*) + ac_cv_path_RANLIB="$RANLIB" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_RANLIB="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +RANLIB=$ac_cv_path_RANLIB +if test -n "$RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +$as_echo "$RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$RANLIB" + then + as_fn_error $? "cannot find ranlib in your PATH" "$LINENO" 5 + fi + fi + + +fi + + +RanlibCmd="$RANLIB" +RANLIB="$RanlibCmd" + + + if test "$HostOS" != "mingw32" && + test "$HostOS" != "darwin" ; then + + +# Check whether --with-readelf was given. +if test "${with_readelf+set}" = set; then : + withval=$with_readelf; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + READELF=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_readelf=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "readelf", so it can be a program name with args. +set dummy readelf; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_READELF+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $READELF in + [\\/]* | ?:[\\/]*) + ac_cv_path_READELF="$READELF" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_READELF="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +READELF=$ac_cv_path_READELF +if test -n "$READELF"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $READELF" >&5 +$as_echo "$READELF" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-readelf", so it can be a program name with args. +set dummy $target_alias-readelf; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_READELF+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $READELF in + [\\/]* | ?:[\\/]*) + ac_cv_path_READELF="$READELF" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_READELF="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +READELF=$ac_cv_path_READELF +if test -n "$READELF"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $READELF" >&5 +$as_echo "$READELF" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$READELF" + then + as_fn_error $? "cannot find readelf in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + if test -z "$READELF"; then + as_fn_error $? "cannot identify readelf tool" "$LINENO" 5 + fi + ReadElfCmd="$READELF" + fi + + + + +# Note: we may not have objdump on OS X, and we only need it on Windows (for DLL checks) +case $HostOS_CPP in +cygwin32|mingw32) + + +# Check whether --with-objdump was given. +if test "${with_objdump+set}" = set; then : + withval=$with_objdump; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + OBJDUMP=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_objdump=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "yes" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "objdump", so it can be a program name with args. +set dummy objdump; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OBJDUMP+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OBJDUMP in + [\\/]* | ?:[\\/]*) + ac_cv_path_OBJDUMP="$OBJDUMP" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OBJDUMP="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OBJDUMP=$ac_cv_path_OBJDUMP +if test -n "$OBJDUMP"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 +$as_echo "$OBJDUMP" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-objdump", so it can be a program name with args. +set dummy $target_alias-objdump; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OBJDUMP+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OBJDUMP in + [\\/]* | ?:[\\/]*) + ac_cv_path_OBJDUMP="$OBJDUMP" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OBJDUMP="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OBJDUMP=$ac_cv_path_OBJDUMP +if test -n "$OBJDUMP"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OBJDUMP" >&5 +$as_echo "$OBJDUMP" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "no" = "no" -a -z "$OBJDUMP" + then + as_fn_error $? "cannot find objdump in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + ObjdumpCmd="$OBJDUMP" + + ;; +esac + +# Here is where we re-target which specific version of the LLVM +# tools we are looking for. In the past, GHC supported a number of +# versions of LLVM simultaneously, but that stopped working around +# 3.5/3.6 release of LLVM. +LlvmVersion=3.5 + + + + # Test for program with version name. + + +# Check whether --with-llc was given. +if test "${with_llc+set}" = set; then : + withval=$with_llc; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + LLC=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_llc=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "no" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "llc-$LlvmVersion", so it can be a program name with args. +set dummy llc-$LlvmVersion; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LLC in + [\\/]* | ?:[\\/]*) + ac_cv_path_LLC="$LLC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LLC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LLC=$ac_cv_path_LLC +if test -n "$LLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LLC" >&5 +$as_echo "$LLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-llc-$LlvmVersion", so it can be a program name with args. +set dummy $target_alias-llc-$LlvmVersion; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LLC in + [\\/]* | ?:[\\/]*) + ac_cv_path_LLC="$LLC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LLC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LLC=$ac_cv_path_LLC +if test -n "$LLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LLC" >&5 +$as_echo "$LLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$LLC" + then + as_fn_error $? "cannot find llc-$LlvmVersion in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + if test "$LLC" = ""; then + # Test for program without version name. + + +# Check whether --with-llc was given. +if test "${with_llc+set}" = set; then : + withval=$with_llc; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + LLC=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_llc=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "no" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "llc", so it can be a program name with args. +set dummy llc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LLC in + [\\/]* | ?:[\\/]*) + ac_cv_path_LLC="$LLC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LLC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LLC=$ac_cv_path_LLC +if test -n "$LLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LLC" >&5 +$as_echo "$LLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-llc", so it can be a program name with args. +set dummy $target_alias-llc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_LLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $LLC in + [\\/]* | ?:[\\/]*) + ac_cv_path_LLC="$LLC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_LLC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +LLC=$ac_cv_path_LLC +if test -n "$LLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LLC" >&5 +$as_echo "$LLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$LLC" + then + as_fn_error $? "cannot find llc in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking $LLC is version $LlvmVersion" >&5 +$as_echo_n "checking $LLC is version $LlvmVersion... " >&6; } + if test `$LLC --version | grep -c "version $LlvmVersion"` -gt 0 ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + LLC="" + fi + fi + +LlcCmd="$LLC" + + + + # Test for program with version name. + + +# Check whether --with-opt was given. +if test "${with_opt+set}" = set; then : + withval=$with_opt; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + OPT=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_opt=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "no" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "opt-$LlvmVersion", so it can be a program name with args. +set dummy opt-$LlvmVersion; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OPT in + [\\/]* | ?:[\\/]*) + ac_cv_path_OPT="$OPT" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OPT="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OPT=$ac_cv_path_OPT +if test -n "$OPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPT" >&5 +$as_echo "$OPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-opt-$LlvmVersion", so it can be a program name with args. +set dummy $target_alias-opt-$LlvmVersion; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OPT in + [\\/]* | ?:[\\/]*) + ac_cv_path_OPT="$OPT" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OPT="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OPT=$ac_cv_path_OPT +if test -n "$OPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPT" >&5 +$as_echo "$OPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$OPT" + then + as_fn_error $? "cannot find opt-$LlvmVersion in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + if test "$OPT" = ""; then + # Test for program without version name. + + +# Check whether --with-opt was given. +if test "${with_opt+set}" = set; then : + withval=$with_opt; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + OPT=$withval + fi + + # Remember that we set this manually. Used to override CC_STAGE0 + # and friends later, if we are not cross-compiling. + With_opt=$withval + +else + + if test "$HostOS" != "mingw32" + then + if test "no" = "no" -o "$target_alias" = "" ; then + # Extract the first word of "opt", so it can be a program name with args. +set dummy opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OPT in + [\\/]* | ?:[\\/]*) + ac_cv_path_OPT="$OPT" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OPT="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OPT=$ac_cv_path_OPT +if test -n "$OPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPT" >&5 +$as_echo "$OPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + # Extract the first word of "$target_alias-opt", so it can be a program name with args. +set dummy $target_alias-opt; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_OPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $OPT in + [\\/]* | ?:[\\/]*) + ac_cv_path_OPT="$OPT" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_OPT="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +OPT=$ac_cv_path_OPT +if test -n "$OPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPT" >&5 +$as_echo "$OPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test "yes" = "no" -a -z "$OPT" + then + as_fn_error $? "cannot find opt in your PATH" "$LINENO" 5 + fi + fi + + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking $OPT is version $LlvmVersion" >&5 +$as_echo_n "checking $OPT is version $LlvmVersion... " >&6; } + if test `$OPT --version | grep -c "version $LlvmVersion"` -gt 0 ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + OPT="" + fi + fi + +OptCmd="$OPT" + + + + + + + + + BootstrapTmpCmd=`grep "LLVM llc command" $(${WithGhc} --print-libdir)/settings 2>/dev/null | sed 's/.*", "//;s/".*//'` + if test -n "$BootstrapTmpCmd" && test `basename $BootstrapTmpCmd` = $BootstrapTmpCmd ; then + # Extract the first word of "$BootstrapTmpCmd", so it can be a program name with args. +set dummy $BootstrapTmpCmd; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_BootstrapLlcCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $BootstrapLlcCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_BootstrapLlcCmd="$BootstrapLlcCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_BootstrapLlcCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_BootstrapLlcCmd" && ac_cv_path_BootstrapLlcCmd="""" + ;; +esac +fi +BootstrapLlcCmd=$ac_cv_path_BootstrapLlcCmd +if test -n "$BootstrapLlcCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $BootstrapLlcCmd" >&5 +$as_echo "$BootstrapLlcCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + BootstrapLlcCmd=$BootstrapTmpCmd + fi + + + BootstrapTmpCmd=`grep "LLVM opt command" $(${WithGhc} --print-libdir)/settings 2>/dev/null | sed 's/.*", "//;s/".*//'` + if test -n "$BootstrapTmpCmd" && test `basename $BootstrapTmpCmd` = $BootstrapTmpCmd ; then + # Extract the first word of "$BootstrapTmpCmd", so it can be a program name with args. +set dummy $BootstrapTmpCmd; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_BootstrapOptCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $BootstrapOptCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_BootstrapOptCmd="$BootstrapOptCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_BootstrapOptCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_BootstrapOptCmd" && ac_cv_path_BootstrapOptCmd="""" + ;; +esac +fi +BootstrapOptCmd=$ac_cv_path_BootstrapOptCmd +if test -n "$BootstrapOptCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $BootstrapOptCmd" >&5 +$as_echo "$BootstrapOptCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + else + BootstrapOptCmd=$BootstrapTmpCmd + fi + + +if test -n "$BootstrapLlcCmd" && test -n "$BootstrapOptCmd" +then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether bootstrap compiler is affected by bug 9439" >&5 +$as_echo_n "checking whether bootstrap compiler is affected by bug 9439... " >&6; } + echo "main = putStrLn \"%function\"" > conftestghc.hs + + # Check whether LLVM backend is default for this platform + "${WithGhc}" -pgmlc="${BootstrapLlcCmd}" -pgmlo="${BootstrapOptCmd}" conftestghc.hs 2>&1 >/dev/null + res=`./conftestghc` + if test "x$res" = "x%object" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + echo "Buggy bootstrap compiler" + echo "" + echo "The stage 0 compiler $WithGhc is affected by GHC Bug \#9439" + echo "and therefore will miscompile the LLVM backend if -fllvm is" + echo "used." + echo + echo "Please use another bootstrap compiler" + exit 1 + fi + + # -fllvm is not the default, but set a flag so the Makefile can check + # -for it in the build flags later on + "${WithGhc}" -fforce-recomp -pgmlc="${BootstrapLlcCmd}" -pgmlo="${BootstrapOptCmd}" -fllvm conftestghc.hs 2>&1 >/dev/null + if test $? = 0 + then + res=`./conftestghc` + if test "x$res" = "x%object" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + GHC_LLVM_AFFECTED_BY_9439=1 + elif test "x$res" = "x%function" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + GHC_LLVM_AFFECTED_BY_9439=0 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unexpected output $res" >&5 +$as_echo "$as_me: WARNING: unexpected output $res" >&2;} + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: failed to compile" >&5 +$as_echo "failed to compile" >&6; } + fi +fi + + + +if test ${TargetArch} = arm ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking if llvm version is affected by bug 9920" >&5 +$as_echo_n "checking if llvm version is affected by bug 9920... " >&6; } + rm -f conftest.ll conftest.asm + cat << LLVM_IR_CODE > conftest.ll +declare cc10 void @target_function() +define cc10 void @test_direct_tail() { + tail call cc10 void @target_function() + ret void +} +LLVM_IR_CODE + + res=$(${LlcCmd} -mtriple=armv7-eabi conftest.ll -o conftest.asm) + if test $? -eq 0 ; then + if test $(grep -c target_function conftest.asm) -eq 1 ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + echo + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 1 "Cannot compile for ARM with ${LlcCmd}. See GHC trac ticket #9920. +See \`config.log' for more details" "$LINENO" 5; } + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unexpected output $res" >&5 +$as_echo "$as_me: WARNING: unexpected output $res" >&2;} + fi + rm -f conftest.ll conftest.asm +fi + + +if test "$TargetOS" = "mingw32" +then + GhcLibsWithUnix=NO +else + GhcLibsWithUnix=YES +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether #! works in shell scripts" >&5 +$as_echo_n "checking whether #! works in shell scripts... " >&6; } +if ${ac_cv_sys_interpreter+:} false; then : + $as_echo_n "(cached) " >&6 +else + echo '#! /bin/cat +exit 69 +' >conftest +chmod u+x conftest +(SHELL=/bin/sh; export SHELL; ./conftest >/dev/null 2>&1) +if test $? -ne 69; then + ac_cv_sys_interpreter=yes +else + ac_cv_sys_interpreter=no +fi +rm -f conftest +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_interpreter" >&5 +$as_echo "$ac_cv_sys_interpreter" >&6; } +interpval=$ac_cv_sys_interpreter + + +case $HostOS_CPP in +cygwin32|mingw32) + PerlCmd=$hardtop/inplace/perl/perl + ;; +*) + # Extract the first word of "perl", so it can be a program name with args. +set dummy perl; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_PerlCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $PerlCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_PerlCmd="$PerlCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_PerlCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PerlCmd=$ac_cv_path_PerlCmd +if test -n "$PerlCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PerlCmd" >&5 +$as_echo "$PerlCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test -z "$PerlCmd" + then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 + else + $PerlCmd -v >conftest.out 2>&1 + if grep "v5" conftest.out >/dev/null 2>&1; then + : + else + as_fn_error $? "your version of perl probably won't work, try upgrading it." "$LINENO" 5 + fi +rm -fr conftest* + + fi + ;; +esac + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +if test -z "$CC" +then + as_fn_error $? "gcc is required" "$LINENO" 5 +fi +GccLT34=NO +GccLT46=NO +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking version of gcc" >&5 +$as_echo_n "checking version of gcc... " >&6; } +if ${fp_cv_gcc_version+:} false; then : + $as_echo_n "(cached) " >&6 +else + + fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [^0-9]*\([0-9.]*\).*/\1/g'`" + fp_version1=$fp_cv_gcc_version; fp_version2=3.0 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + as_fn_error $? "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 +fi + # See #2770: gcc 2.95 doesn't work any more, apparently. There probably + # isn't a very good reason for that, but for now just make configure + # fail. + fp_version1=$fp_cv_gcc_version; fp_version2=3.4 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + GccLT34=YES +fi + fp_version1=$fp_cv_gcc_version; fp_version2=4.6 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + GccLT46=YES +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_gcc_version" >&5 +$as_echo "$fp_cv_gcc_version" >&6; } +GccVersion=$fp_cv_gcc_version + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether C compiler is clang" >&5 +$as_echo_n "checking whether C compiler is clang... " >&6; } +$CC -x c /dev/null -dM -E > conftest.txt 2>&1 +if grep "__clang__" conftest.txt >/dev/null 2>&1; then + CC_CLANG_BACKEND=1 + + CC_LLVM_BACKEND=1 + + GccIsClang=YES + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether C compiler has an LLVM back end" >&5 +$as_echo_n "checking whether C compiler has an LLVM back end... " >&6; } + if grep "__llvm__" conftest.txt >/dev/null 2>&1; then + CC_CLANG_BACKEND=0 + + CC_LLVM_BACKEND=1 + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + CC_CLANG_BACKEND=0 + + CC_LLVM_BACKEND=0 + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi +fi + + +rm -f conftest.txt + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld is GNU ld" >&5 +$as_echo_n "checking whether ld is GNU ld... " >&6; } +if ${fp_cv_gnu_ld+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ${LdCmd} --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then + fp_cv_gnu_ld=yes +else + fp_cv_gnu_ld=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_gnu_ld" >&5 +$as_echo "$fp_cv_gnu_ld" >&6; } +LdIsGNULd=`echo $fp_cv_gnu_ld | sed 'y/yesno/YESNO/'` + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands --build-id" >&5 +$as_echo_n "checking whether ld understands --build-id... " >&6; } +if ${fp_cv_ld_build_id+:} false; then : + $as_echo_n "(cached) " >&6 +else + echo 'int foo() { return 0; }' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest* +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_ld_build_id" >&5 +$as_echo "$fp_cv_ld_build_id" >&6; } +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands -no_compact_unwind" >&5 +$as_echo_n "checking whether ld understands -no_compact_unwind... " >&6; } +if ${fp_cv_ld_no_compact_unwind+:} false; then : + $as_echo_n "(cached) " >&6 +else + echo 'int foo() { return 0; }' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r -no_compact_unwind -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_no_compact_unwind=yes +else + fp_cv_ld_no_compact_unwind=no +fi +rm -rf conftest* +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_ld_no_compact_unwind" >&5 +$as_echo "$fp_cv_ld_no_compact_unwind" >&6; } +if test "$fp_cv_ld_no_compact_unwind" = yes; then + LdHasNoCompactUnwind=YES +else + LdHasNoCompactUnwind=NO +fi + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands -filelist" >&5 +$as_echo_n "checking whether ld understands -filelist... " >&6; } +if ${fp_cv_ld_has_filelist+:} false; then : + $as_echo_n "(cached) " >&6 +else + + echo 'int foo() { return 0; }' > conftest1.c + echo 'int bar() { return 0; }' > conftest2.c + ${CC-cc} -c conftest1.c + ${CC-cc} -c conftest2.c + echo conftest1.o > conftest.o-files + echo conftest2.o >> conftest.o-files + if ${LdCmd} -r -filelist conftest.o-files -o conftest.o > /dev/null 2>&1 + then + fp_cv_ld_has_filelist=yes + else + fp_cv_ld_has_filelist=no + fi + rm -rf conftest* + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_ld_has_filelist" >&5 +$as_echo "$fp_cv_ld_has_filelist" >&6; } +if test "$fp_cv_ld_has_filelist" = yes; then + LdHasFilelist=YES +else + LdHasFilelist=NO +fi + + + + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking Setting up CFLAGS, LDFLAGS, IGNORE_LINKER_LD_FLAGS and CPPFLAGS" >&5 +$as_echo_n "checking Setting up CFLAGS, LDFLAGS, IGNORE_LINKER_LD_FLAGS and CPPFLAGS... " >&6; } + case $target in + i386-*) + # Workaround for #7799 + CFLAGS="$CFLAGS -U__i686" + ;; + esac + + case $target in + i386-unknown-mingw32) + CFLAGS="$CFLAGS -march=i686" + ;; + i386-portbld-freebsd*) + CFLAGS="$CFLAGS -march=i686" + ;; + i386-apple-darwin) + CFLAGS="$CFLAGS -m32" + LDFLAGS="$LDFLAGS -m32" + IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -arch i386" + CPPFLAGS="$CPPFLAGS -m32" + ;; + x86_64-apple-darwin) + CFLAGS="$CFLAGS -m64" + LDFLAGS="$LDFLAGS -m64" + IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -arch x86_64" + CPPFLAGS="$CPPFLAGS -m64" + ;; + x86_64-unknown-solaris2) + CFLAGS="$CFLAGS -m64" + LDFLAGS="$LDFLAGS -m64" + IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -m64" + CPPFLAGS="$CPPFLAGS -m64" + ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CFLAGS="$CFLAGS -w -mieee -D_REENTRANT" + LDFLAGS="$LDFLAGS -w -mieee -D_REENTRANT" + CPPFLAGS="$CPPFLAGS -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CFLAGS="$CFLAGS -D_HPUX_SOURCE" + LDFLAGS="$LDFLAGS -D_HPUX_SOURCE" + CPPFLAGS="$CPPFLAGS -D_HPUX_SOURCE" + ;; + arm*linux*) + # On arm/linux and arm/android, tell gcc to generate Arm + # instructions (ie not Thumb) and to link using the gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CFLAGS="$CFLAGS -marm" + LDFLAGS="$LDFLAGS -fuse-ld=gold -Wl,-z,noexecstack" + IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -z noexecstack" + ;; + + aarch64*linux*) + # On aarch64/linux and aarch64/android, tell gcc to link using the + # gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + LDFLAGS="$LDFLAGS -fuse-ld=gold -Wl,-z,noexecstack" + IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -z noexecstack" + ;; + esac + + # If gcc knows about the stack protector, turn it off. + # Otherwise the stack-smash handler gets triggered. + echo 'int main(void) {return 0;}' > conftest.c + if $CC -c conftest.c -fno-stack-protector > /dev/null 2>&1 + then + CFLAGS="$CFLAGS -fno-stack-protector" + fi + + rm -f conftest.c conftest.o + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking Setting up CONF_CC_OPTS_STAGE0, CONF_GCC_LINKER_OPTS_STAGE0, CONF_LD_LINKER_OPTS_STAGE0 and CONF_CPP_OPTS_STAGE0" >&5 +$as_echo_n "checking Setting up CONF_CC_OPTS_STAGE0, CONF_GCC_LINKER_OPTS_STAGE0, CONF_LD_LINKER_OPTS_STAGE0 and CONF_CPP_OPTS_STAGE0... " >&6; } + case $build in + i386-*) + # Workaround for #7799 + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -U__i686" + ;; + esac + + case $build in + i386-unknown-mingw32) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -march=i686" + ;; + i386-portbld-freebsd*) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -march=i686" + ;; + i386-apple-darwin) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -m32" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -m32" + CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -arch i386" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -m32" + ;; + x86_64-apple-darwin) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -m64" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -m64" + CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -arch x86_64" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -m64" + ;; + x86_64-unknown-solaris2) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -m64" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -m64" + CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -m64" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -m64" + ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -D_HPUX_SOURCE" + ;; + arm*linux*) + # On arm/linux and arm/android, tell gcc to generate Arm + # instructions (ie not Thumb) and to link using the gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -marm" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -z noexecstack" + ;; + + aarch64*linux*) + # On aarch64/linux and aarch64/android, tell gcc to link using the + # gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -z noexecstack" + ;; + esac + + # If gcc knows about the stack protector, turn it off. + # Otherwise the stack-smash handler gets triggered. + echo 'int main(void) {return 0;}' > conftest.c + if $CC -c conftest.c -fno-stack-protector > /dev/null 2>&1 + then + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -fno-stack-protector" + fi + + rm -f conftest.c conftest.o + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking Setting up CONF_CC_OPTS_STAGE1, CONF_GCC_LINKER_OPTS_STAGE1, CONF_LD_LINKER_OPTS_STAGE1 and CONF_CPP_OPTS_STAGE1" >&5 +$as_echo_n "checking Setting up CONF_CC_OPTS_STAGE1, CONF_GCC_LINKER_OPTS_STAGE1, CONF_LD_LINKER_OPTS_STAGE1 and CONF_CPP_OPTS_STAGE1... " >&6; } + case $target in + i386-*) + # Workaround for #7799 + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -U__i686" + ;; + esac + + case $target in + i386-unknown-mingw32) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -march=i686" + ;; + i386-portbld-freebsd*) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -march=i686" + ;; + i386-apple-darwin) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -m32" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -m32" + CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -arch i386" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -m32" + ;; + x86_64-apple-darwin) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -m64" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -m64" + CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -arch x86_64" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -m64" + ;; + x86_64-unknown-solaris2) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -m64" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -m64" + CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -m64" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -m64" + ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -D_HPUX_SOURCE" + ;; + arm*linux*) + # On arm/linux and arm/android, tell gcc to generate Arm + # instructions (ie not Thumb) and to link using the gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -marm" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -z noexecstack" + ;; + + aarch64*linux*) + # On aarch64/linux and aarch64/android, tell gcc to link using the + # gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -z noexecstack" + ;; + esac + + # If gcc knows about the stack protector, turn it off. + # Otherwise the stack-smash handler gets triggered. + echo 'int main(void) {return 0;}' > conftest.c + if $CC -c conftest.c -fno-stack-protector > /dev/null 2>&1 + then + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -fno-stack-protector" + fi + + rm -f conftest.c conftest.o + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking Setting up CONF_CC_OPTS_STAGE2, CONF_GCC_LINKER_OPTS_STAGE2, CONF_LD_LINKER_OPTS_STAGE2 and CONF_CPP_OPTS_STAGE2" >&5 +$as_echo_n "checking Setting up CONF_CC_OPTS_STAGE2, CONF_GCC_LINKER_OPTS_STAGE2, CONF_LD_LINKER_OPTS_STAGE2 and CONF_CPP_OPTS_STAGE2... " >&6; } + case $target in + i386-*) + # Workaround for #7799 + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -U__i686" + ;; + esac + + case $target in + i386-unknown-mingw32) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -march=i686" + ;; + i386-portbld-freebsd*) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -march=i686" + ;; + i386-apple-darwin) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -m32" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -m32" + CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -arch i386" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -m32" + ;; + x86_64-apple-darwin) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -m64" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -m64" + CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -arch x86_64" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -m64" + ;; + x86_64-unknown-solaris2) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -m64" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -m64" + CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -m64" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -m64" + ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -D_HPUX_SOURCE" + ;; + arm*linux*) + # On arm/linux and arm/android, tell gcc to generate Arm + # instructions (ie not Thumb) and to link using the gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -marm" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -z noexecstack" + ;; + + aarch64*linux*) + # On aarch64/linux and aarch64/android, tell gcc to link using the + # gold linker. + # Forcing LD to be ld.gold is done in FIND_LD m4 macro. + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -fuse-ld=gold -Wl,-z,noexecstack" + CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -z noexecstack" + ;; + esac + + # If gcc knows about the stack protector, turn it off. + # Otherwise the stack-smash handler gets triggered. + echo 'int main(void) {return 0;}' > conftest.c + if $CC -c conftest.c -fno-stack-protector > /dev/null 2>&1 + then + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -fno-stack-protector" + fi + + rm -f conftest.c conftest.o + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } + +# Stage 3 won't be supported by cross-compilation + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for extra options to pass gcc when compiling via C" >&5 +$as_echo_n "checking for extra options to pass gcc when compiling via C... " >&6; } +if ${fp_cv_gcc_extra_opts+:} false; then : + $as_echo_n "(cached) " >&6 +else + fp_cv_gcc_extra_opts= + fp_version1=$fp_cv_gcc_version; fp_version2=3.4 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -ge "$fp_num2"; then : + fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv" +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_gcc_extra_opts" >&5 +$as_echo "$fp_cv_gcc_extra_opts" >&6; } +GccExtraViaCOpts=$fp_cv_gcc_extra_opts + + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +$as_echo_n "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +$as_echo "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + + + + + + + + + + + + checkArch() { + case $1 in + i386) + test -z "$2" || eval "$2=ArchX86" + ;; + x86_64|amd64) + test -z "$2" || eval "$2=ArchX86_64" + ;; + powerpc) + test -z "$2" || eval "$2=ArchPPC" + ;; + powerpc64) + test -z "$2" || eval "$2=ArchPPC_64" + ;; + sparc) + test -z "$2" || eval "$2=ArchSPARC" + ;; + arm) + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +#if defined(__ARM_ARCH_2__) || \ + defined(__ARM_ARCH_3__) || \ + defined(__ARM_ARCH_3M__) || \ + defined(__ARM_ARCH_4__) || \ + defined(__ARM_ARCH_4T__) || \ + defined(__ARM_ARCH_5__) || \ + defined(__ARM_ARCH_5T__) || \ + defined(__ARM_ARCH_5E__) || \ + defined(__ARM_ARCH_5TE__) + return 0; + #else + not pre arm v6 + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define arm_HOST_ARCH_PRE_ARMv6 1" >>confdefs.h + + +$as_echo "#define arm_HOST_ARCH_PRE_ARMv7 1" >>confdefs.h + + ARM_ISA=ARMv5 + ARM_ISA_EXT="[]" + +else + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +#if defined(__ARM_ARCH_6__) || \ + defined(__ARM_ARCH_6J__) || \ + defined(__ARM_ARCH_6T2__) || \ + defined(__ARM_ARCH_6Z__) || \ + defined(__ARM_ARCH_6ZK__) || \ + defined(__ARM_ARCH_6M__) + return 0; + #else + not pre arm v7 + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define arm_HOST_ARCH_PRE_ARMv7 1" >>confdefs.h + + ARM_ISA=ARMv6 + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +#if defined(__VFP_FP__) + return 0; + #else + no vfp + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ARM_ISA_EXT="[VFPv2]" + +else + ARM_ISA_EXT="[]" + + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +else + ARM_ISA=ARMv7 + ARM_ISA_EXT="[VFPv3,NEON]" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#if defined(__SOFTFP__) + return 0; + #else + not softfp + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ARM_ABI="SOFT" + +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#if defined(__ARM_PCS_VFP) + return 0; + #else + no hard float ABI + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ARM_ABI="HARD" +else + ARM_ABI="SOFTFP" + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + test -z "$2" || eval "$2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT, armABI = \$ARM_ABI}\"" + ;; + aarch64) + test -z "$2" || eval "$2=ArchARM64" + ;; + alpha) + test -z "$2" || eval "$2=ArchAlpha" + ;; + mips|mipseb) + test -z "$2" || eval "$2=ArchMipseb" + ;; + mipsel) + test -z "$2" || eval "$2=ArchMipsel" + ;; + hppa|hppa1_1|ia64|m68k|powerpc64le|rs6000|s390|s390x|sparc64|vax) + test -z "$2" || eval "$2=ArchUnknown" + ;; + *) + echo "Unknown arch $1" + exit 1 + ;; + esac + } + + checkVendor() { + case $1 in + dec|unknown|hp|apple|next|sun|sgi|ibm|montavista|portbld) + ;; + *) + echo "Unknown vendor $1" + exit 1 + ;; + esac + } + + checkOS() { + case $1 in + linux) + test -z "$2" || eval "$2=OSLinux" + ;; + ios) + test -z "$2" || eval "$2=OSiOS" + ;; + darwin) + test -z "$2" || eval "$2=OSDarwin" + ;; + solaris2) + test -z "$2" || eval "$2=OSSolaris2" + ;; + mingw32) + test -z "$2" || eval "$2=OSMinGW32" + ;; + freebsd) + test -z "$2" || eval "$2=OSFreeBSD" + ;; + dragonfly) + test -z "$2" || eval "$2=OSDragonFly" + ;; + kfreebsdgnu) + test -z "$2" || eval "$2=OSKFreeBSD" + ;; + openbsd) + test -z "$2" || eval "$2=OSOpenBSD" + ;; + netbsd) + test -z "$2" || eval "$2=OSNetBSD" + ;; + haiku) + test -z "$2" || eval "$2=OSHaiku" + ;; + osf3) + test -z "$2" || eval "$2=OSOsf3" + ;; + nto-qnx) + test -z "$2" || eval "$2=OSQNXNTO" + ;; + dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) + test -z "$2" || eval "$2=OSUnknown" + ;; + linux-android) + test -z "$2" || eval "$2=OSAndroid" + ;; + *) + echo "Unknown OS '$1'" + exit 1 + ;; + esac + } + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for .subsections_via_symbols" >&5 +$as_echo_n "checking for .subsections_via_symbols... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +__asm__ (".subsections_via_symbols"); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + HaskellHaveSubsectionsViaSymbols=True + +$as_echo "#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1" >>confdefs.h + + +else + HaskellHaveSubsectionsViaSymbols=False + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether your assembler supports .ident directive" >&5 +$as_echo_n "checking whether your assembler supports .ident directive... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +__asm__ (".ident \"GHC x.y.z\""); +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + HaskellHaveIdentDirective=True +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + HaskellHaveIdentDirective=False +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + + CFLAGS2="$CFLAGS" + CFLAGS= + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU non-executable stack support" >&5 +$as_echo_n "checking for GNU non-executable stack support... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +__asm__ (".section .note.GNU-stack,\"\",@progbits"); +int +main () +{ +0 + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + HaskellHaveGnuNonexecStack=True +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + HaskellHaveGnuNonexecStack=False +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + CFLAGS="$CFLAGS2" + + checkArch "$BuildArch" "HaskellBuildArch" + checkVendor "$BuildVendor" + checkOS "$BuildOS" "" + + checkArch "$HostArch" "HaskellHostArch" + checkVendor "$HostVendor" + checkOS "$HostOS" "" + + checkArch "$TargetArch" "HaskellTargetArch" + checkVendor "$TargetVendor" + checkOS "$TargetOS" "HaskellTargetOs" + + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working context diff" >&5 +$as_echo_n "checking for a working context diff... " >&6; } +if ${fp_cv_context_diff+:} false; then : + $as_echo_n "(cached) " >&6 +else + echo foo > conftest1 +echo foo > conftest2 +fp_cv_context_diff=no +for fp_var in '-U 1' '-u1' '-C 1' '-c1' +do + if diff $fp_var conftest1 conftest2 > /dev/null 2>&1; then + fp_cv_context_diff="diff $fp_var" + break + fi +done +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_context_diff" >&5 +$as_echo "$fp_cv_context_diff" >&6; } +if test x"$fp_cv_context_diff" = xno; then + as_fn_error $? "cannot figure out how to do context diffs" "$LINENO" 5 +fi +ContextDiffCmd=$fp_cv_context_diff + + + +chmod +x install-sh +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AmigaOS /C/install, which installs bootblocks on floppy discs +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# OS/2's system install, which has a completely different semantic +# ./install, which can be erroneously created by make from ./install.sh. +# Reject install programs that cannot install multiple files. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 +$as_echo_n "checking for a BSD-compatible install... " >&6; } +if test -z "$INSTALL"; then +if ${ac_cv_path_install+:} false; then : + $as_echo_n "(cached) " >&6 +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + # Account for people who put trailing slashes in PATH elements. +case $as_dir/ in #(( + ./ | .// | /[cC]/* | \ + /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ + ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ + /usr/ucb/* ) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then + if test $ac_prog = install && + grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + elif test $ac_prog = install && + grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # program-specific install script used by HP pwplus--don't use. + : + else + rm -rf conftest.one conftest.two conftest.dir + echo one > conftest.one + echo two > conftest.two + mkdir conftest.dir + if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && + test -s conftest.one && test -s conftest.two && + test -s conftest.dir/conftest.one && + test -s conftest.dir/conftest.two + then + ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" + break 3 + fi + fi + fi + done + done + ;; +esac + + done +IFS=$as_save_IFS + +rm -rf conftest.one conftest.two conftest.dir + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL=$ac_cv_path_install + else + # As a last resort, use the slow shell script. Don't cache a + # value for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the value is a relative name. + INSTALL=$ac_install_sh + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 +$as_echo "$INSTALL" >&6; } + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + + + # Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_fp_prog_ar+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $fp_prog_ar in + [\\/]* | ?:[\\/]*) + ac_cv_path_fp_prog_ar="$fp_prog_ar" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_fp_prog_ar="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +fp_prog_ar=$ac_cv_path_fp_prog_ar +if test -n "$fp_prog_ar"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_prog_ar" >&5 +$as_echo "$fp_prog_ar" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${fp_prog_ar}" != "" + then + # Canonicalise to :/path/to/gcc + fp_prog_ar=`cygpath -m "${fp_prog_ar}"` + fi + +if test -z "$fp_prog_ar"; then + as_fn_error $? "cannot find ar in your PATH, no idea how to make a library" "$LINENO" 5 +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $fp_prog_ar is GNU ar" >&5 +$as_echo_n "checking whether $fp_prog_ar is GNU ar... " >&6; } +if ${fp_cv_prog_ar_is_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + if "$fp_prog_ar" --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then + fp_cv_prog_ar_is_gnu=yes +else + fp_cv_prog_ar_is_gnu=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_prog_ar_is_gnu" >&5 +$as_echo "$fp_cv_prog_ar_is_gnu" >&6; } +fp_prog_ar_is_gnu=$fp_cv_prog_ar_is_gnu +ArIsGNUAr=`echo $fp_prog_ar_is_gnu | tr 'a-z' 'A-Z'` + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ar arguments" >&5 +$as_echo_n "checking for ar arguments... " >&6; } +if ${fp_cv_prog_ar_args+:} false; then : + $as_echo_n "(cached) " >&6 +else + +# GNU ar needs special treatment: it appears to have problems with +# object files with the same name if you use the 's' modifier, but +# simple 'ar q' works fine, and doesn't need a separate ranlib. +if test $fp_prog_ar_is_gnu = yes; then + fp_cv_prog_ar_args="q" +else + touch conftest.dummy + for fp_var in clqsZ clqs cqs clq cq ; do + rm -f conftest.a + if "$fp_prog_ar" $fp_var conftest.a conftest.dummy > /dev/null 2> /dev/null; then + fp_cv_prog_ar_args=$fp_var + break + fi + done + rm -f conftest* + if test -z "$fp_cv_prog_ar_args"; then + as_fn_error $? "cannot figure out how to use your $fp_prog_ar" "$LINENO" 5 + fi +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_prog_ar_args" >&5 +$as_echo "$fp_cv_prog_ar_args" >&6; } +fp_prog_ar_args=$fp_cv_prog_ar_args +ArCmd="$fp_prog_ar" + +ArArgs="$fp_prog_ar_args" + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $fp_prog_ar supports @file" >&5 +$as_echo_n "checking whether $fp_prog_ar supports @file... " >&6; } +if ${fp_cv_prog_ar_supports_atfile+:} false; then : + $as_echo_n "(cached) " >&6 +else + +rm -f conftest* +touch conftest.file +echo conftest.file > conftest.atfile +echo conftest.file >> conftest.atfile +"$fp_prog_ar" $fp_prog_ar_args conftest.a @conftest.atfile > /dev/null 2>&1 +fp_prog_ar_supports_atfile_tmp=`"$fp_prog_ar" t conftest.a 2> /dev/null | grep -c conftest.file` +rm -f conftest* +if test "$fp_prog_ar_supports_atfile_tmp" -eq 2 +then + fp_cv_prog_ar_supports_atfile=yes +else + fp_cv_prog_ar_supports_atfile=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_prog_ar_supports_atfile" >&5 +$as_echo "$fp_cv_prog_ar_supports_atfile" >&6; } +fp_prog_ar_supports_atfile=$fp_cv_prog_ar_supports_atfile +ArSupportsAtFile=`echo $fp_prog_ar_supports_atfile | tr 'a-z' 'A-Z'` + + + + + + + + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. +set dummy ${ac_tool_prefix}ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +RANLIB=$ac_cv_prog_RANLIB +if test -n "$RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +$as_echo "$RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RANLIB"; then + ac_ct_RANLIB=$RANLIB + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_RANLIB"; then + ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_RANLIB="ranlib" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB +if test -n "$ac_ct_RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 +$as_echo "$ac_ct_RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_RANLIB" = x; then + RANLIB=":" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + RANLIB=$ac_ct_RANLIB + fi +else + RANLIB="$ac_cv_prog_RANLIB" +fi + + + if test $fp_prog_ar_is_gnu = yes + then + fp_cv_prog_ar_needs_ranlib=no + elif test "$TargetOS_CPP" = "darwin" + then + # It's quite tedious to check for Apple's crazy timestamps in + # .a files, so we hardcode it. + fp_cv_prog_ar_needs_ranlib=yes + else + case $fp_prog_ar_args in + *s*) + fp_cv_prog_ar_needs_ranlib=no;; + *) + fp_cv_prog_ar_needs_ranlib=yes;; + esac + fi + + # workaround for AC_PROG_RANLIB which sets RANLIB to `:' when + # ranlib is missing on the target OS. The problem is that + # ghc-cabal cannot execute `:' which is a shell built-in but can + # execute `true' which is usually simple program supported by the + # OS. + # Fixes #8795 + if test "$RANLIB" = ":" + then + RANLIB="true" + fi + REAL_RANLIB_CMD="$RANLIB" + if test $fp_cv_prog_ar_needs_ranlib = yes + then + RANLIB_CMD="$RANLIB" + else + RANLIB_CMD="true" + fi + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 +$as_echo_n "checking whether ln -s works... " >&6; } +LN_S=$as_ln_s +if test "$LN_S" = "ln -s"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 +$as_echo "no, using $LN_S" >&6; } +fi + + + + if test "$windows" = YES + then + mingw_bin_prefix=mingw/bin/ + SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPFlags="$HaskellCPPArgs" + SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe" + SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe" + SettingsPerlCommand='$topdir/../perl/perl.exe' + SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe" + SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe" + SettingsTouchCommand='$topdir/touchy.exe' + else + SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsHaskellCPPCommand="$HaskellCPPCmd" + SettingsHaskellCPPFlags="$HaskellCPPArgs" + SettingsLdCommand="$LdCmd" + SettingsArCommand="$ArCmd" + SettingsPerlCommand="$PerlCmd" + SettingsDllWrapCommand="/bin/false" + SettingsWindresCommand="/bin/false" + SettingsLibtoolCommand="libtool" + SettingsReadElfCommand="$ReadElfCmd" + SettingsTouchCommand='touch' + fi + if test -z "$LlcCmd" + then + SettingsLlcCommand="llc" + else + SettingsLlcCommand="$LlcCmd" + fi + if test -z "$OptCmd" + then + SettingsOptCommand="opt" + else + SettingsOptCommand="$OptCmd" + fi + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" + SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2" + + + + + + + + + + + + + + + + + + +for ac_prog in gsed sed +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_SedCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $SedCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_SedCmd="$SedCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_SedCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +SedCmd=$ac_cv_path_SedCmd +if test -n "$SedCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $SedCmd" >&5 +$as_echo "$SedCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$SedCmd" && break +done +test -n "$SedCmd" || SedCmd="sed" + + + +# Extract the first word of "time", so it can be a program name with args. +set dummy time; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_TimeCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $TimeCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_TimeCmd="$TimeCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_TimeCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +TimeCmd=$ac_cv_path_TimeCmd +if test -n "$TimeCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TimeCmd" >&5 +$as_echo "$TimeCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + +for ac_prog in gnutar gtar tar +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_TarCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $TarCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_TarCmd="$TarCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_TarCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +TarCmd=$ac_cv_path_TarCmd +if test -n "$TarCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TarCmd" >&5 +$as_echo "$TarCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$TarCmd" && break +done +test -n "$TarCmd" || TarCmd="tar" + + +for ac_prog in gpatch patch +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_PatchCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $PatchCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_PatchCmd="$PatchCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_PatchCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +PatchCmd=$ac_cv_path_PatchCmd +if test -n "$PatchCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PatchCmd" >&5 +$as_echo "$PatchCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$PatchCmd" && break +done +test -n "$PatchCmd" || PatchCmd="patch" + + +HaveDtrace=NO +# Extract the first word of "dtrace", so it can be a program name with args. +set dummy dtrace; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_DtraceCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $DtraceCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_DtraceCmd="$DtraceCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_DtraceCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +DtraceCmd=$ac_cv_path_DtraceCmd +if test -n "$DtraceCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DtraceCmd" >&5 +$as_echo "$DtraceCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test -n "$DtraceCmd"; then + if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple" -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xsolaris2-unknown"; then + HaveDtrace=YES + fi +fi + + +# Extract the first word of "HsColour", so it can be a program name with args. +set dummy HsColour; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_HSCOLOUR+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $HSCOLOUR in + [\\/]* | ?:[\\/]*) + ac_cv_path_HSCOLOUR="$HSCOLOUR" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_HSCOLOUR="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +HSCOLOUR=$ac_cv_path_HSCOLOUR +if test -n "$HSCOLOUR"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HSCOLOUR" >&5 +$as_echo "$HSCOLOUR" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +# HsColour is passed to Cabal, so we need a native path +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HSCOLOUR}" != "" +then + # Canonicalise to :/path/to/gcc + HSCOLOUR=`cygpath -m ${HSCOLOUR}` +fi + + + # Extract the first word of "xmllint", so it can be a program name with args. +set dummy xmllint; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_XmllintCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $XmllintCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_XmllintCmd="$XmllintCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_XmllintCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +XmllintCmd=$ac_cv_path_XmllintCmd +if test -n "$XmllintCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XmllintCmd" >&5 +$as_echo "$XmllintCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${XmllintCmd}" != "" + then + # Canonicalise to :/path/to/gcc + XmllintCmd=`cygpath -m "${XmllintCmd}"` + fi + +if test -z "$XmllintCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find xmllint in your PATH, you will not be able to validate your documentation" >&5 +$as_echo "$as_me: WARNING: cannot find xmllint in your PATH, you will not be able to validate your documentation" >&2;} +fi + +if test -n "$XmllintCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DocBook DTD" >&5 +$as_echo_n "checking for DocBook DTD... " >&6; } + rm -f conftest.xml conftest-book.xml +cat > conftest.xml << EOF + + +]> + +&conftest-book; + +EOF +cat >conftest-book.xml << EOF + + A DocBook “Test Document” + + A Chapter Title + This is a paragraph, referencing . + + + Another Chapter Title + This is another paragraph, referencing . + +EOF + + if $XmllintCmd --nonet --valid --noout conftest.xml ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +$as_echo "ok" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: failed" >&5 +$as_echo "failed" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find a DTD for DocBook XML V4.5, you will not be able to validate your documentation" >&5 +$as_echo "$as_me: WARNING: cannot find a DTD for DocBook XML V4.5, you will not be able to validate your documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog" >&5 +$as_echo "$as_me: WARNING: check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog" >&2;} + fi + rm -rf conftest* +fi + + + # Extract the first word of "xsltproc", so it can be a program name with args. +set dummy xsltproc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_XsltprocCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $XsltprocCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_XsltprocCmd="$XsltprocCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_XsltprocCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +XsltprocCmd=$ac_cv_path_XsltprocCmd +if test -n "$XsltprocCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XsltprocCmd" >&5 +$as_echo "$XsltprocCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${XsltprocCmd}" != "" + then + # Canonicalise to :/path/to/gcc + XsltprocCmd=`cygpath -m "${XsltprocCmd}"` + fi + +if test -z "$XsltprocCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find xsltproc in your PATH, you will not be able to build the HTML documentation" >&5 +$as_echo "$as_me: WARNING: cannot find xsltproc in your PATH, you will not be able to build the HTML documentation" >&2;} +fi + +if test -n "$XsltprocCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DocBook XSL stylesheet" >&5 +$as_echo_n "checking for DocBook XSL stylesheet... " >&6; } +if ${fp_cv_dir_docbook_xsl+:} false; then : + $as_echo_n "(cached) " >&6 +else + rm -f conftest.xml conftest-book.xml +cat > conftest.xml << EOF + + +]> + +&conftest-book; + +EOF +cat >conftest-book.xml << EOF + + A DocBook “Test Document” + + A Chapter Title + This is a paragraph, referencing . + + + Another Chapter Title + This is another paragraph, referencing . + +EOF + + fp_cv_dir_docbook_xsl=no + if $XsltprocCmd --nonet http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl conftest.xml > /dev/null 2>&1; then + fp_cv_dir_docbook_xsl=yes + fi + rm -rf conftest* +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_dir_docbook_xsl" >&5 +$as_echo "$fp_cv_dir_docbook_xsl" >&6; } +fi +if test x"$fp_cv_dir_docbook_xsl" = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find DocBook XSL stylesheets, you will not be able to build the documentation" >&5 +$as_echo "$as_me: WARNING: cannot find DocBook XSL stylesheets, you will not be able to build the documentation" >&2;} + HAVE_DOCBOOK_XSL=NO +else + HAVE_DOCBOOK_XSL=YES +fi + + + + # Extract the first word of "dblatex", so it can be a program name with args. +set dummy dblatex; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_DblatexCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $DblatexCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_DblatexCmd="$DblatexCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_DblatexCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +DblatexCmd=$ac_cv_path_DblatexCmd +if test -n "$DblatexCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DblatexCmd" >&5 +$as_echo "$DblatexCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${DblatexCmd}" != "" + then + # Canonicalise to :/path/to/gcc + DblatexCmd=`cygpath -m "${DblatexCmd}"` + fi + +if test -z "$DblatexCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find dblatex in your PATH, you will not be able to build the PDF and PS documentation" >&5 +$as_echo "$as_me: WARNING: cannot find dblatex in your PATH, you will not be able to build the PDF and PS documentation" >&2;} +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ghc-pkg matching $WithGhc" >&5 +$as_echo_n "checking for ghc-pkg matching $WithGhc... " >&6; } +if ${fp_cv_matching_ghc_pkg+:} false; then : + $as_echo_n "(cached) " >&6 +else + +# If we are told to use ghc-stage2, then we're using an in-tree +# compiler. In this case, we just want ghc-pkg, not ghc-pkg-stage2, +# so we sed off -stage[0-9]$. However, if we are told to use +# ghc-6.12.1 then we want to use ghc-pkg-6.12.1, so we keep any +# other suffix. +fp_ghc_pkg_guess=`echo $WithGhc | sed -e 's/-stage[0-9]$//' -e 's,ghc\([^/\\]*\)$,ghc-pkg\1,'` +if "$fp_ghc_pkg_guess" list > /dev/null 2>&1; then + fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess +else + as_fn_error $? "Cannot find matching ghc-pkg" "$LINENO" 5 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_matching_ghc_pkg" >&5 +$as_echo "$fp_cv_matching_ghc_pkg" >&6; } +GhcPkgCmd=$fp_cv_matching_ghc_pkg + + + + + # Extract the first word of "happy", so it can be a program name with args. +set dummy happy; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_HappyCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $HappyCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_HappyCmd="$HappyCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_HappyCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +HappyCmd=$ac_cv_path_HappyCmd +if test -n "$HappyCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HappyCmd" >&5 +$as_echo "$HappyCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HappyCmd}" != "" + then + # Canonicalise to :/path/to/gcc + HappyCmd=`cygpath -m "${HappyCmd}"` + fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for version of happy" >&5 +$as_echo_n "checking for version of happy... " >&6; } +if ${fptools_cv_happy_version+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test x"$HappyCmd" != x; then + fptools_cv_happy_version=`"$HappyCmd" -v | + grep 'Happy Version' | sed -e 's/Happy Version \([^ ]*\).*/\1/g'` ; +else + fptools_cv_happy_version=""; +fi; + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_happy_version" >&5 +$as_echo "$fptools_cv_happy_version" >&6; } +if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs +then + fp_version1=$fptools_cv_happy_version; fp_version2=1.19.4 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + as_fn_error $? "Happy version 1.19.4 or later is required to compile GHC." "$LINENO" 5 +fi +fi +HappyVersion=$fptools_cv_happy_version; + + + + + + # Extract the first word of "alex", so it can be a program name with args. +set dummy alex; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_AlexCmd+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $AlexCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_AlexCmd="$AlexCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_AlexCmd="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +AlexCmd=$ac_cv_path_AlexCmd +if test -n "$AlexCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AlexCmd" >&5 +$as_echo "$AlexCmd" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + # If we have a cygwin path for something, and we try to run it + # from cabal or python, then it'll fail. So we convert to a + # native path. + if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${AlexCmd}" != "" + then + # Canonicalise to :/path/to/gcc + AlexCmd=`cygpath -m "${AlexCmd}"` + fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for version of alex" >&5 +$as_echo_n "checking for version of alex... " >&6; } +if ${fptools_cv_alex_version+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test x"$AlexCmd" != x; then + fptools_cv_alex_version=`"$AlexCmd" -v | + grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; +else + fptools_cv_alex_version=""; +fi; + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_alex_version" >&5 +$as_echo "$fptools_cv_alex_version" >&6; } +fp_version1=$fptools_cv_alex_version; fp_version2=3.0 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -ge "$fp_num2"; then : + Alex3=YES +else + Alex3=NO +fi +if test ! -f compiler/cmm/CmmLex.hs || test ! -f compiler/parser/Lexer.hs +then + fp_version1=$fptools_cv_alex_version; fp_version2=3.1.0 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + as_fn_error $? "Alex version 3.1.0 or later is required to compile GHC." "$LINENO" 5 +fi +fi +AlexVersion=$fptools_cv_alex_version; + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +$as_echo_n "checking for grep that handles long lines and -e... " >&6; } +if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +$as_echo "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +$as_echo_n "checking for egrep... " >&6; } +if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +$as_echo "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 +$as_echo_n "checking for ANSI C header files... " >&6; } +if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_stdc=yes +else + ac_cv_header_stdc=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then : + : +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +else + ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 +$as_echo "$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +$as_echo "#define STDC_HEADERS 1" >>confdefs.h + +fi + + +# Check whether --enable-largefile was given. +if test "${enable_largefile+set}" = set; then : + enableval=$enable_largefile; +fi + +if test "$enable_largefile" != no; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5 +$as_echo_n "checking for special C compiler options needed for large files... " >&6; } +if ${ac_cv_sys_largefile_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_sys_largefile_CC=no + if test "$GCC" != yes; then + ac_save_CC=$CC + while :; do + # IRIX 6.2 and later do not support large files by default, + # so use the C compiler's -n32 option if that helps. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int +main () +{ + + ; + return 0; +} +_ACEOF + if ac_fn_c_try_compile "$LINENO"; then : + break +fi +rm -f core conftest.err conftest.$ac_objext + CC="$CC -n32" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_sys_largefile_CC=' -n32'; break +fi +rm -f core conftest.err conftest.$ac_objext + break + done + CC=$ac_save_CC + rm -f conftest.$ac_ext + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_largefile_CC" >&5 +$as_echo "$ac_cv_sys_largefile_CC" >&6; } + if test "$ac_cv_sys_largefile_CC" != no; then + CC=$CC$ac_cv_sys_largefile_CC + fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5 +$as_echo_n "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; } +if ${ac_cv_sys_file_offset_bits+:} false; then : + $as_echo_n "(cached) " >&6 +else + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_sys_file_offset_bits=no; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _FILE_OFFSET_BITS 64 +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_sys_file_offset_bits=64; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cv_sys_file_offset_bits=unknown + break +done +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_file_offset_bits" >&5 +$as_echo "$ac_cv_sys_file_offset_bits" >&6; } +case $ac_cv_sys_file_offset_bits in #( + no | unknown) ;; + *) +cat >>confdefs.h <<_ACEOF +#define _FILE_OFFSET_BITS $ac_cv_sys_file_offset_bits +_ACEOF +;; +esac +rm -rf conftest* + if test $ac_cv_sys_file_offset_bits = unknown; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5 +$as_echo_n "checking for _LARGE_FILES value needed for large files... " >&6; } +if ${ac_cv_sys_large_files+:} false; then : + $as_echo_n "(cached) " >&6 +else + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_sys_large_files=no; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define _LARGE_FILES 1 +#include + /* Check that off_t can represent 2**63 - 1 correctly. + We can't simply define LARGE_OFF_T to be 9223372036854775807, + since some C++ compilers masquerading as C compilers + incorrectly reject 9223372036854775807. */ +#define LARGE_OFF_T ((((off_t) 1 << 31) << 31) - 1 + (((off_t) 1 << 31) << 31)) + int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721 + && LARGE_OFF_T % 2147483647 == 1) + ? 1 : -1]; +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_sys_large_files=1; break +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cv_sys_large_files=unknown + break +done +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_large_files" >&5 +$as_echo "$ac_cv_sys_large_files" >&6; } +case $ac_cv_sys_large_files in #( + no | unknown) ;; + *) +cat >>confdefs.h <<_ACEOF +#define _LARGE_FILES $ac_cv_sys_large_files +_ACEOF +;; +esac +rm -rf conftest* + fi + + +fi + + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_header in ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/param.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_header in sys/cpuset.h +do : + ac_fn_c_check_header_compile "$LINENO" "sys/cpuset.h" "ac_cv_header_sys_cpuset_h" "#if HAVE_SYS_PARAM_H +# include +#endif + +" +if test "x$ac_cv_header_sys_cpuset_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SYS_CPUSET_H 1 +_ACEOF + +fi + +done + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5 +$as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; } +if ${ac_cv_header_time+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include + +int +main () +{ +if ((struct tm *) 0) +return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_time=yes +else + ac_cv_header_time=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_time" >&5 +$as_echo "$ac_cv_header_time" >&6; } +if test $ac_cv_header_time = yes; then + +$as_echo "#define TIME_WITH_SYS_TIME 1" >>confdefs.h + +fi + + +ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" +if test "x$ac_cv_type_long_long" = xyes; then : + +cat >>confdefs.h <<_ACEOF +#define HAVE_LONG_LONG 1 +_ACEOF + + +fi + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of char" >&5 +$as_echo_n "checking size of char... " >&6; } +if ${ac_cv_sizeof_char+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (char))" "ac_cv_sizeof_char" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_char" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (char) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_char=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_char" >&5 +$as_echo "$ac_cv_sizeof_char" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_CHAR $ac_cv_sizeof_char +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of double" >&5 +$as_echo_n "checking size of double... " >&6; } +if ${ac_cv_sizeof_double+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (double))" "ac_cv_sizeof_double" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_double" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (double) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_double=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_double" >&5 +$as_echo "$ac_cv_sizeof_double" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_DOUBLE $ac_cv_sizeof_double +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of float" >&5 +$as_echo_n "checking size of float... " >&6; } +if ${ac_cv_sizeof_float+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (float))" "ac_cv_sizeof_float" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_float" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (float) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_float=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_float" >&5 +$as_echo "$ac_cv_sizeof_float" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_FLOAT $ac_cv_sizeof_float +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 +$as_echo_n "checking size of int... " >&6; } +if ${ac_cv_sizeof_int+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_int" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (int) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_int=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int" >&5 +$as_echo "$ac_cv_sizeof_int" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_INT $ac_cv_sizeof_int +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 +$as_echo_n "checking size of long... " >&6; } +if ${ac_cv_sizeof_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 +$as_echo "$ac_cv_sizeof_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_LONG $ac_cv_sizeof_long +_ACEOF + + +if test "$ac_cv_type_long_long" = yes; then +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long long" >&5 +$as_echo_n "checking size of long long... " >&6; } +if ${ac_cv_sizeof_long_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_long_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (long long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long_long" >&5 +$as_echo "$ac_cv_sizeof_long_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_LONG_LONG $ac_cv_sizeof_long_long +_ACEOF + + +fi +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of short" >&5 +$as_echo_n "checking size of short... " >&6; } +if ${ac_cv_sizeof_short+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_short" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (short) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_short=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_short" >&5 +$as_echo "$ac_cv_sizeof_short" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_SHORT $ac_cv_sizeof_short +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned char" >&5 +$as_echo_n "checking size of unsigned char... " >&6; } +if ${ac_cv_sizeof_unsigned_char+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned char))" "ac_cv_sizeof_unsigned_char" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_unsigned_char" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (unsigned char) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_char=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_unsigned_char" >&5 +$as_echo "$ac_cv_sizeof_unsigned_char" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UNSIGNED_CHAR $ac_cv_sizeof_unsigned_char +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned int" >&5 +$as_echo_n "checking size of unsigned int... " >&6; } +if ${ac_cv_sizeof_unsigned_int+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned int))" "ac_cv_sizeof_unsigned_int" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_unsigned_int" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (unsigned int) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_int=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_unsigned_int" >&5 +$as_echo "$ac_cv_sizeof_unsigned_int" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UNSIGNED_INT $ac_cv_sizeof_unsigned_int +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned long" >&5 +$as_echo_n "checking size of unsigned long... " >&6; } +if ${ac_cv_sizeof_unsigned_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned long))" "ac_cv_sizeof_unsigned_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_unsigned_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (unsigned long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_unsigned_long" >&5 +$as_echo "$ac_cv_sizeof_unsigned_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UNSIGNED_LONG $ac_cv_sizeof_unsigned_long +_ACEOF + + +if test "$ac_cv_type_long_long" = yes; then +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned long long" >&5 +$as_echo_n "checking size of unsigned long long... " >&6; } +if ${ac_cv_sizeof_unsigned_long_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned long long))" "ac_cv_sizeof_unsigned_long_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_unsigned_long_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (unsigned long long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_long_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_unsigned_long_long" >&5 +$as_echo "$ac_cv_sizeof_unsigned_long_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UNSIGNED_LONG_LONG $ac_cv_sizeof_unsigned_long_long +_ACEOF + + +fi +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned short" >&5 +$as_echo_n "checking size of unsigned short... " >&6; } +if ${ac_cv_sizeof_unsigned_short+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned short))" "ac_cv_sizeof_unsigned_short" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_unsigned_short" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (unsigned short) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_short=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_unsigned_short" >&5 +$as_echo "$ac_cv_sizeof_unsigned_short" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_UNSIGNED_SHORT $ac_cv_sizeof_unsigned_short +_ACEOF + + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void *" >&5 +$as_echo_n "checking size of void *... " >&6; } +if ${ac_cv_sizeof_void_p+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void *))" "ac_cv_sizeof_void_p" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_void_p" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (void *) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_void_p=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_void_p" >&5 +$as_echo "$ac_cv_sizeof_void_p" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_VOID_P $ac_cv_sizeof_void_p +_ACEOF + + + +WordSize=$ac_cv_sizeof_void_p + + +ac_fn_c_check_type "$LINENO" "char" "ac_cv_type_char" "$ac_includes_default" +if test "x$ac_cv_type_char" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of char" >&5 +$as_echo_n "checking alignment of char... " >&6; } +if ${fp_cv_alignment_char+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_char" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; char ty; },ty)" "fp_cv_alignment_char" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (char) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_char=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_char" >&5 +$as_echo "$fp_cv_alignment_char" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_CHAR $fp_cv_alignment_char +_ACEOF + +ac_fn_c_check_type "$LINENO" "double" "ac_cv_type_double" "$ac_includes_default" +if test "x$ac_cv_type_double" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of double" >&5 +$as_echo_n "checking alignment of double... " >&6; } +if ${fp_cv_alignment_double+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_double" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; double ty; },ty)" "fp_cv_alignment_double" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (double) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_double=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_double" >&5 +$as_echo "$fp_cv_alignment_double" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_DOUBLE $fp_cv_alignment_double +_ACEOF + +ac_fn_c_check_type "$LINENO" "float" "ac_cv_type_float" "$ac_includes_default" +if test "x$ac_cv_type_float" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of float" >&5 +$as_echo_n "checking alignment of float... " >&6; } +if ${fp_cv_alignment_float+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_float" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; float ty; },ty)" "fp_cv_alignment_float" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (float) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_float=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_float" >&5 +$as_echo "$fp_cv_alignment_float" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_FLOAT $fp_cv_alignment_float +_ACEOF + +ac_fn_c_check_type "$LINENO" "int" "ac_cv_type_int" "$ac_includes_default" +if test "x$ac_cv_type_int" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of int" >&5 +$as_echo_n "checking alignment of int... " >&6; } +if ${fp_cv_alignment_int+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_int" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; int ty; },ty)" "fp_cv_alignment_int" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (int) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_int=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_int" >&5 +$as_echo "$fp_cv_alignment_int" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_INT $fp_cv_alignment_int +_ACEOF + +ac_fn_c_check_type "$LINENO" "long" "ac_cv_type_long" "$ac_includes_default" +if test "x$ac_cv_type_long" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of long" >&5 +$as_echo_n "checking alignment of long... " >&6; } +if ${fp_cv_alignment_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; long ty; },ty)" "fp_cv_alignment_long" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (long) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_long=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_long" >&5 +$as_echo "$fp_cv_alignment_long" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_LONG $fp_cv_alignment_long +_ACEOF + +if test "$ac_cv_type_long_long" = yes; then +ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" +if test "x$ac_cv_type_long_long" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of long long" >&5 +$as_echo_n "checking alignment of long long... " >&6; } +if ${fp_cv_alignment_long_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_long_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; long long ty; },ty)" "fp_cv_alignment_long_long" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (long long) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_long_long=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_long_long" >&5 +$as_echo "$fp_cv_alignment_long_long" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_LONG_LONG $fp_cv_alignment_long_long +_ACEOF + +fi +ac_fn_c_check_type "$LINENO" "short" "ac_cv_type_short" "$ac_includes_default" +if test "x$ac_cv_type_short" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of short" >&5 +$as_echo_n "checking alignment of short... " >&6; } +if ${fp_cv_alignment_short+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_short" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; short ty; },ty)" "fp_cv_alignment_short" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (short) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_short=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_short" >&5 +$as_echo "$fp_cv_alignment_short" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_SHORT $fp_cv_alignment_short +_ACEOF + +ac_fn_c_check_type "$LINENO" "unsigned char" "ac_cv_type_unsigned_char" "$ac_includes_default" +if test "x$ac_cv_type_unsigned_char" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned char" >&5 +$as_echo_n "checking alignment of unsigned char... " >&6; } +if ${fp_cv_alignment_unsigned_char+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_unsigned_char" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; unsigned char ty; },ty)" "fp_cv_alignment_unsigned_char" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (unsigned char) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_unsigned_char=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_unsigned_char" >&5 +$as_echo "$fp_cv_alignment_unsigned_char" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_UNSIGNED_CHAR $fp_cv_alignment_unsigned_char +_ACEOF + +ac_fn_c_check_type "$LINENO" "unsigned int" "ac_cv_type_unsigned_int" "$ac_includes_default" +if test "x$ac_cv_type_unsigned_int" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned int" >&5 +$as_echo_n "checking alignment of unsigned int... " >&6; } +if ${fp_cv_alignment_unsigned_int+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_unsigned_int" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; unsigned int ty; },ty)" "fp_cv_alignment_unsigned_int" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (unsigned int) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_unsigned_int=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_unsigned_int" >&5 +$as_echo "$fp_cv_alignment_unsigned_int" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_UNSIGNED_INT $fp_cv_alignment_unsigned_int +_ACEOF + +ac_fn_c_check_type "$LINENO" "unsigned long" "ac_cv_type_unsigned_long" "$ac_includes_default" +if test "x$ac_cv_type_unsigned_long" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned long" >&5 +$as_echo_n "checking alignment of unsigned long... " >&6; } +if ${fp_cv_alignment_unsigned_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_unsigned_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; unsigned long ty; },ty)" "fp_cv_alignment_unsigned_long" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (unsigned long) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_unsigned_long=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_unsigned_long" >&5 +$as_echo "$fp_cv_alignment_unsigned_long" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_UNSIGNED_LONG $fp_cv_alignment_unsigned_long +_ACEOF + +if test "$ac_cv_type_long_long" = yes; then +ac_fn_c_check_type "$LINENO" "unsigned long long" "ac_cv_type_unsigned_long_long" "$ac_includes_default" +if test "x$ac_cv_type_unsigned_long_long" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned long long" >&5 +$as_echo_n "checking alignment of unsigned long long... " >&6; } +if ${fp_cv_alignment_unsigned_long_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_unsigned_long_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; unsigned long long ty; },ty)" "fp_cv_alignment_unsigned_long_long" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (unsigned long long) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_unsigned_long_long=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_unsigned_long_long" >&5 +$as_echo "$fp_cv_alignment_unsigned_long_long" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_UNSIGNED_LONG_LONG $fp_cv_alignment_unsigned_long_long +_ACEOF + +fi +ac_fn_c_check_type "$LINENO" "unsigned short" "ac_cv_type_unsigned_short" "$ac_includes_default" +if test "x$ac_cv_type_unsigned_short" = xyes; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned short" >&5 +$as_echo_n "checking alignment of unsigned short... " >&6; } +if ${fp_cv_alignment_unsigned_short+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_unsigned_short" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; unsigned short ty; },ty)" "fp_cv_alignment_unsigned_short" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (unsigned short) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_unsigned_short=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_unsigned_short" >&5 +$as_echo "$fp_cv_alignment_unsigned_short" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_UNSIGNED_SHORT $fp_cv_alignment_unsigned_short +_ACEOF + +as_ac_Type=`$as_echo "ac_cv_type_void *" | $as_tr_sh` +ac_fn_c_check_type "$LINENO" "void *" "$as_ac_Type" "$ac_includes_default" +if eval test \"x\$"$as_ac_Type"\" = x"yes"; then : + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of void *" >&5 +$as_echo_n "checking alignment of void *... " >&6; } +if ${fp_cv_alignment_void_p+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$ac_cv_type_void_p" = yes; then + if ac_fn_c_compute_int "$LINENO" "offsetof(struct { char c; void * ty; },ty)" "fp_cv_alignment_void_p" "$ac_includes_default"; then : + +else + as_fn_error 77 "cannot compute alignment (void *) +See \`config.log' for more details." "$LINENO" 5 +fi + + +else + fp_cv_alignment_void_p=0 +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_alignment_void_p" >&5 +$as_echo "$fp_cv_alignment_void_p" >&6; } +cat >>confdefs.h <<_ACEOF +#define ALIGNMENT_VOID_P $fp_cv_alignment_void_p +_ACEOF + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for WinExec" >&5 +$as_echo_n "checking for WinExec... " >&6; } +if ${fp_cv_func_WinExec+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +WinExec("",0) + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + fp_cv_func_WinExec=yes +else + fp_cv_func_WinExec=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_func_WinExec" >&5 +$as_echo "$fp_cv_func_WinExec" >&6; } +if test $fp_cv_func_WinExec = yes; then : + +$as_echo "#define HAVE_WINEXEC 1" >>confdefs.h + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for GetModuleFileName" >&5 +$as_echo_n "checking for GetModuleFileName... " >&6; } +if ${fp_cv_func_GetModuleFileName+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +GetModuleFileName((HMODULE)0,(LPTSTR)0,0) + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + fp_cv_func_GetModuleFileName=yes +else + fp_cv_func_GetModuleFileName=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_func_GetModuleFileName" >&5 +$as_echo "$fp_cv_func_GetModuleFileName" >&6; } +if test $fp_cv_func_GetModuleFileName = yes; then : + +$as_echo "#define HAVE_GETMODULEFILENAME 1" >>confdefs.h + +fi + +for ac_func in getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity setlocale +do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +ac_fn_c_check_decl "$LINENO" "ctime_r" "ac_cv_have_decl_ctime_r" "#define _POSIX_SOURCE 1 +#define _POSIX_C_SOURCE 199506L +#include +" +if test "x$ac_cv_have_decl_ctime_r" = xyes; then : + ac_have_decl=1 +else + ac_have_decl=0 +fi + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_CTIME_R $ac_have_decl +_ACEOF + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for closedir in -lmingwex" >&5 +$as_echo_n "checking for closedir in -lmingwex... " >&6; } +if ${ac_cv_lib_mingwex_closedir+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmingwex $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char closedir (); +int +main () +{ +return closedir (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_mingwex_closedir=yes +else + ac_cv_lib_mingwex_closedir=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_closedir" >&5 +$as_echo "$ac_cv_lib_mingwex_closedir" >&6; } +if test "x$ac_cv_lib_mingwex_closedir" = xyes; then : + HaveLibMingwEx=YES +else + HaveLibMingwEx=NO +fi + + + +if test $HaveLibMingwEx = YES ; then + +$as_echo "#define HAVE_MINGWEX 1" >>confdefs.h + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for atan in -lm" >&5 +$as_echo_n "checking for atan in -lm... " >&6; } +if ${ac_cv_lib_m_atan+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char atan (); +int +main () +{ +return atan (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_m_atan=yes +else + ac_cv_lib_m_atan=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_atan" >&5 +$as_echo "$ac_cv_lib_m_atan" >&6; } +if test "x$ac_cv_lib_m_atan" = xyes; then : + HaveLibM=YES +else + HaveLibM=NO +fi + +if test $HaveLibM = YES +then + +$as_echo "#define HAVE_LIBM 1" >>confdefs.h + +fi + + + # Check whether --enable-bfd-debug was given. +if test "${enable_bfd_debug+set}" = set; then : + enableval=$enable_bfd_debug; + # don't pollute general LIBS environment + save_LIBS="$LIBS" + for ac_header in bfd.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" +if test "x$ac_cv_header_bfd_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_BFD_H 1 +_ACEOF + +fi + +done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xmalloc in -liberty" >&5 +$as_echo_n "checking for xmalloc in -liberty... " >&6; } +if ${ac_cv_lib_iberty_xmalloc+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-liberty $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char xmalloc (); +int +main () +{ +return xmalloc (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_iberty_xmalloc=yes +else + ac_cv_lib_iberty_xmalloc=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_iberty_xmalloc" >&5 +$as_echo "$ac_cv_lib_iberty_xmalloc" >&6; } +if test "x$ac_cv_lib_iberty_xmalloc" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBIBERTY 1 +_ACEOF + + LIBS="-liberty $LIBS" + +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 +$as_echo_n "checking for bfd_init in -lbfd... " >&6; } +if ${ac_cv_lib_bfd_bfd_init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lbfd $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char bfd_init (); +int +main () +{ +return bfd_init (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_bfd_bfd_init=yes +else + ac_cv_lib_bfd_bfd_init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 +$as_echo "$ac_cv_lib_bfd_bfd_init" >&6; } +if test "x$ac_cv_lib_bfd_bfd_init" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBBFD 1 +_ACEOF + + LIBS="-lbfd $LIBS" + +fi + + + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ + + /* mimic our rts/Printer.c */ + bfd* abfd; + const char * name; + char **matching; + + name = "some.executable"; + bfd_init(); + abfd = bfd_openr(name, "default"); + bfd_check_format_matches (abfd, bfd_object, &matching); + { + long storage_needed; + storage_needed = bfd_get_symtab_upper_bound (abfd); + } + { + asymbol **symbol_table; + long number_of_symbols; + symbol_info info; + + number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table); + bfd_get_symbol_info(abfd,symbol_table[0],&info); + } + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + +else + as_fn_error $? "can't use 'bfd' library" "$LINENO" 5 +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LIBS="$save_LIBS" + + +fi + + + + +# system libffi + + +# Check whether --with-system-libffi was given. +if test "${with_system_libffi+set}" = set; then : + withval=$with_system_libffi; +fi + + +if test "x$with_system_libffi" = "xyes"; then : + UseSystemLibFFI="YES" +else + UseSystemLibFFI="NO" + +fi + + + + + +# Check whether --with-ffi-includes was given. +if test "${with_ffi_includes+set}" = set; then : + withval=$with_ffi_includes; + if test "x$UseSystemLibFFI" != "xYES"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: --with-ffi-includes will be ignored, --with-system-libffi not set" >&5 +$as_echo "$as_me: WARNING: --with-ffi-includes will be ignored, --with-system-libffi not set" >&2;} + else + FFIIncludeDir="$withval" + LIBFFI_CFLAGS="-I$withval" + fi + +fi + + + + + +# Check whether --with-ffi-libraries was given. +if test "${with_ffi_libraries+set}" = set; then : + withval=$with_ffi_libraries; + if test "x$UseSystemLibFFI" != "xYES"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: --with-ffi-libraries will be ignored, --with-system-libffi not set" >&5 +$as_echo "$as_me: WARNING: --with-ffi-libraries will be ignored, --with-system-libffi not set" >&2;} + else + FFILibDir="$withval" LIBFFI_LDFLAGS="-L$withval" + fi + +fi + + + + +if test "$UseSystemLibFFI" = "YES"; then : + + CFLAGS2="$CFLAGS" + CFLAGS="$LIBFFI_CFLAGS $CFLAGS" + LDFLAGS2="$LDFLAGS" + LDFLAGS="$LIBFFI_LDFLAGS $LDFLAGS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ffi_call in -lffi" >&5 +$as_echo_n "checking for ffi_call in -lffi... " >&6; } +if ${ac_cv_lib_ffi_ffi_call+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lffi $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char ffi_call (); +int +main () +{ +return ffi_call (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_ffi_ffi_call=yes +else + ac_cv_lib_ffi_ffi_call=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ffi_ffi_call" >&5 +$as_echo "$ac_cv_lib_ffi_ffi_call" >&6; } +if test "x$ac_cv_lib_ffi_ffi_call" = xyes; then : + for ac_header in ffi.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "ffi.h" "ac_cv_header_ffi_h" "$ac_includes_default" +if test "x$ac_cv_header_ffi_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_FFI_H 1 +_ACEOF + break +fi + +done + + +$as_echo "#define HAVE_LIBFFI 1" >>confdefs.h + +else + as_fn_error $? "Cannot find system libffi" "$LINENO" 5 +fi + + CFLAGS="$CFLAGS2" + LDFLAGS="$LDFLAGS2" + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +$as_echo_n "checking for dlopen in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int +main () +{ +return dlopen (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlopen=yes +else + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +$as_echo "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBDL 1 +_ACEOF + + LIBS="-ldl $LIBS" + +fi + + + +ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" +if test "x$ac_cv_type_size_t" = xyes; then : + +else + +cat >>confdefs.h <<_ACEOF +#define size_t unsigned int +_ACEOF + +fi + +# The Ultrix 4.2 mips builtin alloca declared by alloca.h only works +# for constant arguments. Useless! +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 +$as_echo_n "checking for working alloca.h... " >&6; } +if ${ac_cv_working_alloca_h+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +char *p = (char *) alloca (2 * sizeof (int)); + if (p) return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_working_alloca_h=yes +else + ac_cv_working_alloca_h=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 +$as_echo "$ac_cv_working_alloca_h" >&6; } +if test $ac_cv_working_alloca_h = yes; then + +$as_echo "#define HAVE_ALLOCA_H 1" >>confdefs.h + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 +$as_echo_n "checking for alloca... " >&6; } +if ${ac_cv_func_alloca_works+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __GNUC__ +# define alloca __builtin_alloca +#else +# ifdef _MSC_VER +# include +# define alloca _alloca +# else +# ifdef HAVE_ALLOCA_H +# include +# else +# ifdef _AIX + #pragma alloca +# else +# ifndef alloca /* predefined by HP cc +Olibcalls */ +void *alloca (size_t); +# endif +# endif +# endif +# endif +#endif + +int +main () +{ +char *p = (char *) alloca (1); + if (p) return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_func_alloca_works=yes +else + ac_cv_func_alloca_works=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 +$as_echo "$ac_cv_func_alloca_works" >&6; } + +if test $ac_cv_func_alloca_works = yes; then + +$as_echo "#define HAVE_ALLOCA 1" >>confdefs.h + +else + # The SVR3 libPW and SVR4 libucb both contain incompatible functions +# that cause trouble. Some versions do not even contain alloca or +# contain a buggy version. If you still want to use their alloca, +# use ar to extract alloca.o from them instead of compiling alloca.c. + +ALLOCA=\${LIBOBJDIR}alloca.$ac_objext + +$as_echo "#define C_ALLOCA 1" >>confdefs.h + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 +$as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } +if ${ac_cv_os_cray+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#if defined CRAY && ! defined CRAY2 +webecray +#else +wenotbecray +#endif + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "webecray" >/dev/null 2>&1; then : + ac_cv_os_cray=yes +else + ac_cv_os_cray=no +fi +rm -f conftest* + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_os_cray" >&5 +$as_echo "$ac_cv_os_cray" >&6; } +if test $ac_cv_os_cray = yes; then + for ac_func in _getb67 GETB67 getb67; do + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + +cat >>confdefs.h <<_ACEOF +#define CRAY_STACKSEG_END $ac_func +_ACEOF + + break +fi + + done +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 +$as_echo_n "checking stack direction for C alloca... " >&6; } +if ${ac_cv_c_stack_direction+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + ac_cv_c_stack_direction=0 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +find_stack_direction (int *addr, int depth) +{ + int dir, dummy = 0; + if (! addr) + addr = &dummy; + *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; + dir = depth ? find_stack_direction (addr, depth - 1) : 0; + return dir + dummy; +} + +int +main (int argc, char **argv) +{ + return find_stack_direction (0, argc + !argv + 20) < 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ac_cv_c_stack_direction=1 +else + ac_cv_c_stack_direction=-1 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 +$as_echo "$ac_cv_c_stack_direction" >&6; } +cat >>confdefs.h <<_ACEOF +#define STACK_DIRECTION $ac_cv_c_stack_direction +_ACEOF + + +fi + + +ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" +if test "x$ac_cv_type_pid_t" = xyes; then : + +else + +cat >>confdefs.h <<_ACEOF +#define pid_t int +_ACEOF + +fi + +for ac_header in vfork.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "vfork.h" "ac_cv_header_vfork_h" "$ac_includes_default" +if test "x$ac_cv_header_vfork_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_VFORK_H 1 +_ACEOF + +fi + +done + +for ac_func in fork vfork +do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + +if test "x$ac_cv_func_fork" = xyes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working fork" >&5 +$as_echo_n "checking for working fork... " >&6; } +if ${ac_cv_func_fork_works+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + ac_cv_func_fork_works=cross +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ + + /* By Ruediger Kuhlmann. */ + return fork () < 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ac_cv_func_fork_works=yes +else + ac_cv_func_fork_works=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_fork_works" >&5 +$as_echo "$ac_cv_func_fork_works" >&6; } + +else + ac_cv_func_fork_works=$ac_cv_func_fork +fi +if test "x$ac_cv_func_fork_works" = xcross; then + case $host in + *-*-amigaos* | *-*-msdosdjgpp*) + # Override, as these systems have only a dummy fork() stub + ac_cv_func_fork_works=no + ;; + *) + ac_cv_func_fork_works=yes + ;; + esac + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: result $ac_cv_func_fork_works guessed because of cross compilation" >&5 +$as_echo "$as_me: WARNING: result $ac_cv_func_fork_works guessed because of cross compilation" >&2;} +fi +ac_cv_func_vfork_works=$ac_cv_func_vfork +if test "x$ac_cv_func_vfork" = xyes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working vfork" >&5 +$as_echo_n "checking for working vfork... " >&6; } +if ${ac_cv_func_vfork_works+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + ac_cv_func_vfork_works=cross +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Thanks to Paul Eggert for this test. */ +$ac_includes_default +#include +#ifdef HAVE_VFORK_H +# include +#endif +/* On some sparc systems, changes by the child to local and incoming + argument registers are propagated back to the parent. The compiler + is told about this with #include , but some compilers + (e.g. gcc -O) don't grok . Test for this by using a + static variable whose address is put into a register that is + clobbered by the vfork. */ +static void +#ifdef __cplusplus +sparc_address_test (int arg) +# else +sparc_address_test (arg) int arg; +#endif +{ + static pid_t child; + if (!child) { + child = vfork (); + if (child < 0) { + perror ("vfork"); + _exit(2); + } + if (!child) { + arg = getpid(); + write(-1, "", 0); + _exit (arg); + } + } +} + +int +main () +{ + pid_t parent = getpid (); + pid_t child; + + sparc_address_test (0); + + child = vfork (); + + if (child == 0) { + /* Here is another test for sparc vfork register problems. This + test uses lots of local variables, at least as many local + variables as main has allocated so far including compiler + temporaries. 4 locals are enough for gcc 1.40.3 on a Solaris + 4.1.3 sparc, but we use 8 to be safe. A buggy compiler should + reuse the register of parent for one of the local variables, + since it will think that parent can't possibly be used any more + in this routine. Assigning to the local variable will thus + munge parent in the parent process. */ + pid_t + p = getpid(), p1 = getpid(), p2 = getpid(), p3 = getpid(), + p4 = getpid(), p5 = getpid(), p6 = getpid(), p7 = getpid(); + /* Convince the compiler that p..p7 are live; otherwise, it might + use the same hardware register for all 8 local variables. */ + if (p != p1 || p != p2 || p != p3 || p != p4 + || p != p5 || p != p6 || p != p7) + _exit(1); + + /* On some systems (e.g. IRIX 3.3), vfork doesn't separate parent + from child file descriptors. If the child closes a descriptor + before it execs or exits, this munges the parent's descriptor + as well. Test for this by closing stdout in the child. */ + _exit(close(fileno(stdout)) != 0); + } else { + int status; + struct stat st; + + while (wait(&status) != child) + ; + return ( + /* Was there some problem with vforking? */ + child < 0 + + /* Did the child fail? (This shouldn't happen.) */ + || status + + /* Did the vfork/compiler bug occur? */ + || parent != getpid() + + /* Did the file descriptor bug occur? */ + || fstat(fileno(stdout), &st) != 0 + ); + } +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ac_cv_func_vfork_works=yes +else + ac_cv_func_vfork_works=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_vfork_works" >&5 +$as_echo "$ac_cv_func_vfork_works" >&6; } + +fi; +if test "x$ac_cv_func_fork_works" = xcross; then + ac_cv_func_vfork_works=$ac_cv_func_vfork + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: result $ac_cv_func_vfork_works guessed because of cross compilation" >&5 +$as_echo "$as_me: WARNING: result $ac_cv_func_vfork_works guessed because of cross compilation" >&2;} +fi + +if test "x$ac_cv_func_vfork_works" = xyes; then + +$as_echo "#define HAVE_WORKING_VFORK 1" >>confdefs.h + +else + +$as_echo "#define vfork fork" >>confdefs.h + +fi +if test "x$ac_cv_func_fork_works" = xyes; then + +$as_echo "#define HAVE_WORKING_FORK 1" >>confdefs.h + +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 +$as_echo_n "checking for an ANSI C-conforming const... " >&6; } +if ${ac_cv_c_const+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + +#ifndef __cplusplus + /* Ultrix mips cc rejects this sort of thing. */ + typedef int charset[2]; + const charset cs = { 0, 0 }; + /* SunOS 4.1.1 cc rejects this. */ + char const *const *pcpcc; + char **ppc; + /* NEC SVR4.0.2 mips cc rejects this. */ + struct point {int x, y;}; + static struct point const zero = {0,0}; + /* AIX XL C 1.02.0.0 rejects this. + It does not let you subtract one const X* pointer from another in + an arm of an if-expression whose if-part is not a constant + expression */ + const char *g = "string"; + pcpcc = &g + (g ? g-g : 0); + /* HPUX 7.0 cc rejects these. */ + ++pcpcc; + ppc = (char**) pcpcc; + pcpcc = (char const *const *) ppc; + { /* SCO 3.2v4 cc rejects this sort of thing. */ + char tx; + char *t = &tx; + char const *s = 0 ? (char *) 0 : (char const *) 0; + + *t++ = 0; + if (s) return 0; + } + { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ + int x[] = {25, 17}; + const int *foo = &x[0]; + ++foo; + } + { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ + typedef const int *iptr; + iptr p = 0; + ++p; + } + { /* AIX XL C 1.02.0.0 rejects this sort of thing, saying + "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ + struct s { int j; const int *ap[3]; } bx; + struct s *b = &bx; b->j = 5; + } + { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; + if (!foo) return 0; + } + return !cs[0] && !zero.x; +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_c_const=yes +else + ac_cv_c_const=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_const" >&5 +$as_echo "$ac_cv_c_const" >&6; } +if test $ac_cv_c_const = no; then + +$as_echo "#define const /**/" >>confdefs.h + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 +$as_echo_n "checking whether byte ordering is bigendian... " >&6; } +if ${ac_cv_c_bigendian+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_c_bigendian=unknown + # See if we're dealing with a universal compiler. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifndef __APPLE_CC__ + not a universal capable compiler + #endif + typedef int dummy; + +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + + # Check for potential -arch flags. It is not universal unless + # there are at least two -arch flags with different values. + ac_arch= + ac_prev= + for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do + if test -n "$ac_prev"; then + case $ac_word in + i?86 | x86_64 | ppc | ppc64) + if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then + ac_arch=$ac_word + else + ac_cv_c_bigendian=universal + break + fi + ;; + esac + ac_prev= + elif test "x$ac_word" = "x-arch"; then + ac_prev=arch + fi + done +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + if test $ac_cv_c_bigendian = unknown; then + # See if sys/param.h defines the BYTE_ORDER macro. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + +int +main () +{ +#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \ + && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \ + && LITTLE_ENDIAN) + bogus endian macros + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + # It does; now see whether it defined to BIG_ENDIAN or not. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + +int +main () +{ +#if BYTE_ORDER != BIG_ENDIAN + not big endian + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_c_bigendian=yes +else + ac_cv_c_bigendian=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + fi + if test $ac_cv_c_bigendian = unknown; then + # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris). + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +int +main () +{ +#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN) + bogus endian macros + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + # It does; now see whether it defined to _BIG_ENDIAN or not. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +int +main () +{ +#ifndef _BIG_ENDIAN + not big endian + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_c_bigendian=yes +else + ac_cv_c_bigendian=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + fi + if test $ac_cv_c_bigendian = unknown; then + # Compile a test program. + if test "$cross_compiling" = yes; then : + # Try to guess by grepping values from an object file. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +short int ascii_mm[] = + { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; + short int ascii_ii[] = + { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; + int use_ascii (int i) { + return ascii_mm[i] + ascii_ii[i]; + } + short int ebcdic_ii[] = + { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; + short int ebcdic_mm[] = + { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; + int use_ebcdic (int i) { + return ebcdic_mm[i] + ebcdic_ii[i]; + } + extern int foo; + +int +main () +{ +return use_ascii (foo) == use_ebcdic (foo); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then + ac_cv_c_bigendian=yes + fi + if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then + if test "$ac_cv_c_bigendian" = unknown; then + ac_cv_c_bigendian=no + else + # finding both strings is unlikely to happen, but who knows? + ac_cv_c_bigendian=unknown + fi + fi +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ + + /* Are we little or big endian? From Harbison&Steele. */ + union + { + long int l; + char c[sizeof (long int)]; + } u; + u.l = 1; + return u.c[sizeof (long int) - 1] == 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ac_cv_c_bigendian=no +else + ac_cv_c_bigendian=yes +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 +$as_echo "$ac_cv_c_bigendian" >&6; } + case $ac_cv_c_bigendian in #( + yes) + $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h +;; #( + no) + ;; #( + universal) + +$as_echo "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h + + ;; #( + *) + as_fn_error $? "unknown endianness + presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; + esac + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether float word order is big endian" >&5 +$as_echo_n "checking whether float word order is big endian... " >&6; } +if ${fptools_cv_float_word_order_bigendian+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +#if defined(__FLOAT_WORD_ORDER) && __FLOAT_WORD_ORDER == BIG_ENDIAN + return 0; + #else + not float word order big endian + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + fptools_cv_float_word_order_bigendian=yes +else + fptools_cv_float_word_order_bigendian=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_float_word_order_bigendian" >&5 +$as_echo "$fptools_cv_float_word_order_bigendian" >&6; } + case $fptools_cv_float_word_order_bigendian in + yes) + +$as_echo "#define FLOAT_WORDS_BIGENDIAN 1" >>confdefs.h + ;; + esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for nlist in -lelf" >&5 +$as_echo_n "checking for nlist in -lelf... " >&6; } +if ${ac_cv_lib_elf_nlist+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lelf $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char nlist (); +int +main () +{ +return nlist (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_elf_nlist=yes +else + ac_cv_lib_elf_nlist=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_elf_nlist" >&5 +$as_echo "$ac_cv_lib_elf_nlist" >&6; } +if test "x$ac_cv_lib_elf_nlist" = xyes; then : + LIBS="-lelf $LIBS" +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking leading underscore in symbol names" >&5 +$as_echo_n "checking leading underscore in symbol names... " >&6; } +if ${fptools_cv_leading_underscore+:} false; then : + $as_echo_n "(cached) " >&6 +else + +# Hack!: nlist() under Digital UNIX insist on there being an _, +# but symbol table listings shows none. What is going on here?!? +# +# Another hack: cygwin doesn't come with nlist.h , so we hardwire +# the underscoredness of that "platform" +case $HostPlatform in +*openbsd*) # x86 openbsd is ELF from 3.4 >, meaning no leading uscore + case $build in + i386-*2\.[0-9] | i386-*3\.[0-3] ) fptools_cv_leading_underscore=yes ;; + *) fptools_cv_leading_underscore=no ;; + esac ;; +alpha-dec-osf*) fptools_cv_leading_underscore=no;; +*cygwin32) fptools_cv_leading_underscore=yes;; +i386-unknown-mingw32) fptools_cv_leading_underscore=yes;; +x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;; + + # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries +x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; +*-apple-ios) fptools_cv_leading_underscore=yes;; + +*) if test "$cross_compiling" = yes; then : + fptools_cv_leading_underscore=no +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef HAVE_NLIST_H +#include +struct nlist xYzzY1[] = {{"xYzzY1", 0},{0}}; +struct nlist xYzzY2[] = {{"_xYzzY2", 0},{0}}; +#endif + +int main(argc, argv) +int argc; +char **argv; +{ +#ifdef HAVE_NLIST_H + if(nlist(argv[0], xYzzY1) == 0 && xYzzY1[0].n_value != 0) + exit(1); + if(nlist(argv[0], xYzzY2) == 0 && xYzzY2[0].n_value != 0) + exit(0); +#endif + exit(1); +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + fptools_cv_leading_underscore=yes +else + fptools_cv_leading_underscore=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +;; +esac +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_leading_underscore" >&5 +$as_echo "$fptools_cv_leading_underscore" >&6; }; +LeadingUnderscore=`echo $fptools_cv_leading_underscore | sed 'y/yesno/YESNO/'` + +if test x"$fptools_cv_leading_underscore" = xyes; then + +$as_echo "#define LEADING_UNDERSCORE 1" >>confdefs.h + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether __attribute__((visibility(\"hidden\"))) is supported" >&5 +$as_echo_n "checking whether __attribute__((visibility(\"hidden\"))) is supported... " >&6; } + echo '__attribute__((visibility("hidden"))) void foo(void) {}' > conftest.c + if $CC -Wall -Werror -c conftest.c > /dev/null 2>&1 + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAS_VISIBILITY_HIDDEN 1" >>confdefs.h + + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi + rm -f conftest.c conftest.o + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5 +$as_echo_n "checking for clock_gettime in -lrt... " >&6; } +if ${ac_cv_lib_rt_clock_gettime+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lrt $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char clock_gettime (); +int +main () +{ +return clock_gettime (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_rt_clock_gettime=yes +else + ac_cv_lib_rt_clock_gettime=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5 +$as_echo "$ac_cv_lib_rt_clock_gettime" >&6; } +if test "x$ac_cv_lib_rt_clock_gettime" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBRT 1 +_ACEOF + + LIBS="-lrt $LIBS" + +fi + +for ac_func in clock_gettime timer_settime +do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +ac_fn_c_check_func "$LINENO" "timer_create" "ac_cv_func_timer_create" +if test "x$ac_cv_func_timer_create" = xyes; then : + HAVE_timer_create=yes +else + HAVE_timer_create=no +fi + + +if test "$HAVE_timer_create" = "yes" +then + if test "$cross_compiling" = "yes" + then + # We can't test timer_create when we're cross-compiling, so we + # optimistiaclly assume that it actually works properly. + +$as_echo "#define USE_TIMER_CREATE 1" >>confdefs.h + + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working timer_create(CLOCK_REALTIME)" >&5 +$as_echo_n "checking for a working timer_create(CLOCK_REALTIME)... " >&6; } +if ${fptools_cv_timer_create_works+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#include +#ifdef HAVE_STDLIB_H +#include +#endif +#ifdef HAVE_TIME_H +#include +#endif +#ifdef HAVE_SIGNAL_H +#include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif + +static volatile int tock = 0; +static void handler(int i) +{ + tock = 1; +} + +static void timeout(int i) +{ + // timer_settime() has been known to hang, so just in case + // we install a 1-second timeout (see #2257) + exit(99); +} + +int main(int argc, char *argv[]) +{ + + struct sigevent ev; + timer_t timer; + struct itimerspec it; + struct sigaction action; + int m,n,count = 0; + + ev.sigev_notify = SIGEV_SIGNAL; + ev.sigev_signo = SIGVTALRM; + + action.sa_handler = handler; + action.sa_flags = 0; + sigemptyset(&action.sa_mask); + if (sigaction(SIGVTALRM, &action, NULL) == -1) { + fprintf(stderr,"SIGVTALRM problem\n"); + exit(3); + } + + action.sa_handler = timeout; + action.sa_flags = 0; + sigemptyset(&action.sa_mask); + if (sigaction(SIGALRM, &action, NULL) == -1) { + fprintf(stderr,"SIGALRM problem\n"); + exit(3); + } + alarm(1); + + if (timer_create(CLOCK_PROCESS_CPUTIME_ID, &ev, &timer) != 0) { + fprintf(stderr,"No CLOCK_PROCESS_CPUTIME_ID timer\n"); + exit(1); + } + + it.it_value.tv_sec = 0; + it.it_value.tv_nsec = 1; + it.it_interval = it.it_value; + if (timer_settime(timer, 0, &it, NULL) != 0) { + fprintf(stderr,"settime problem\n"); + exit(4); + } + + tock = 0; + + for(n = 3; n < 20000; n++){ + for(m = 2; m <= n/2; m++){ + if (!(n%m)) count++; + if (tock) goto out; + } + } +out: + + if (!tock) { + fprintf(stderr,"no CLOCK_PROCESS_CPUTIME_ID signal\n"); + exit(5); + } + + timer_delete(timer); + + if (timer_create(CLOCK_REALTIME, &ev, &timer) != 0) { + fprintf(stderr,"No CLOCK_REALTIME timer\n"); + exit(2); + } + + it.it_value.tv_sec = 0; + it.it_value.tv_nsec = 1000000; + it.it_interval = it.it_value; + if (timer_settime(timer, 0, &it, NULL) != 0) { + fprintf(stderr,"settime problem\n"); + exit(4); + } + + tock = 0; + + usleep(3000); + + if (!tock) { + fprintf(stderr,"no CLOCK_REALTIME signal\n"); + exit(5); + } + + timer_delete(timer); + + exit(0); +} + +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + fptools_cv_timer_create_works=yes +else + fptools_cv_timer_create_works=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_timer_create_works" >&5 +$as_echo "$fptools_cv_timer_create_works" >&6; } +case $fptools_cv_timer_create_works in + yes) +$as_echo "#define USE_TIMER_CREATE 1" >>confdefs.h +;; +esac + fi +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for printf\$LDBLStub" >&5 +$as_echo_n "checking for printf\$LDBLStub... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char printf\$LDBLStub (); +int +main () +{ +return printf\$LDBLStub (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_PRINTF_LDBLSTUB 1" >>confdefs.h + + +else + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +$as_echo "#define HAVE_PRINTF_LDBLSTUB 0" >>confdefs.h + + +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_setname_np in -lpthread" >&5 +$as_echo_n "checking for pthread_setname_np in -lpthread... " >&6; } +if ${ac_cv_lib_pthread_pthread_setname_np+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpthread $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char pthread_setname_np (); +int +main () +{ +return pthread_setname_np (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_pthread_pthread_setname_np=yes +else + ac_cv_lib_pthread_pthread_setname_np=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_setname_np" >&5 +$as_echo "$ac_cv_lib_pthread_pthread_setname_np" >&6; } +if test "x$ac_cv_lib_pthread_pthread_setname_np" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBPTHREAD 1 +_ACEOF + + LIBS="-lpthread $LIBS" + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_setname_np" >&5 +$as_echo_n "checking for pthread_setname_np... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#define _GNU_SOURCE +#include + +int +main () +{ +pthread_setname_np(pthread_self(), "name"); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_PTHREAD_SETNAME_NP 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +for ac_header in sys/eventfd.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_eventfd_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SYS_EVENTFD_H 1 +_ACEOF + +fi + +done + +for ac_func in eventfd +do : + ac_fn_c_check_func "$LINENO" "eventfd" "ac_cv_func_eventfd" +if test "x$ac_cv_func_eventfd" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_EVENTFD 1 +_ACEOF + +fi +done + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for __thread support" >&5 +$as_echo_n "checking for __thread support... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + __thread int tester = 0; +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define CC_SUPPORTS_TLS 1" >>confdefs.h + + +else + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +$as_echo "#define CC_SUPPORTS_TLS 0" >>confdefs.h + + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for PAPI_library_init in -lpapi" >&5 +$as_echo_n "checking for PAPI_library_init in -lpapi... " >&6; } +if ${ac_cv_lib_papi_PAPI_library_init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lpapi $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char PAPI_library_init (); +int +main () +{ +return PAPI_library_init (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_papi_PAPI_library_init=yes +else + ac_cv_lib_papi_PAPI_library_init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_papi_PAPI_library_init" >&5 +$as_echo "$ac_cv_lib_papi_PAPI_library_init" >&6; } +if test "x$ac_cv_lib_papi_PAPI_library_init" = xyes; then : + HavePapiLib=YES +else + HavePapiLib=NO +fi + +ac_fn_c_check_header_mongrel "$LINENO" "papi.h" "ac_cv_header_papi_h" "$ac_includes_default" +if test "x$ac_cv_header_papi_h" = xyes; then : + HavePapiHeader=YES +else + HavePapiHeader=NO +fi + + + + + +for ac_func in __mingw_vfprintf +do : + ac_fn_c_check_func "$LINENO" "__mingw_vfprintf" "ac_cv_func___mingw_vfprintf" +if test "x$ac_cv_func___mingw_vfprintf" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE___MINGW_VFPRINTF 1 +_ACEOF + +fi +done + + +if test "$HavePapiLib" = "YES" -a "$HavePapiHeader" = "YES"; then + HavePapi=YES +else + HavePapi=NO +fi + + +if test "$HAVE_DOCBOOK_XSL" = "NO" || + test "$XsltprocCmd" = "" +then + BUILD_DOCBOOK_HTML=NO +else + BUILD_DOCBOOK_HTML=YES +fi + + +if test "$DblatexCmd" = "" +then + BUILD_DOCBOOK_PS=NO + BUILD_DOCBOOK_PDF=NO +else + BUILD_DOCBOOK_PS=YES + BUILD_DOCBOOK_PDF=YES +fi + + + + +dir=base +LIBRARY_base_VERSION=`grep -i "^version:" libraries/${dir}/base.cabal | sed "s/.* //"` + + + +dir=Cabal/Cabal +LIBRARY_Cabal_VERSION=`grep -i "^version:" libraries/${dir}/Cabal.cabal | sed "s/.* //"` + + + +dir=ghc-prim +LIBRARY_ghc_prim_VERSION=`grep -i "^version:" libraries/${dir}/ghc-prim.cabal | sed "s/.* //"` + + +LIBRARY_ghc_VERSION="$ProjectVersion" + + +if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then + as_fn_error $? "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 +fi + +ac_config_files="$ac_config_files mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/configure.ac" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 7.10.3, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to ." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +The Glorious Glasgow Haskell Compilation System config.status 7.10.3 +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +INSTALL='$INSTALL' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "mk/config.h") CONFIG_HEADERS="$CONFIG_HEADERS mk/config.h" ;; + "mk/config.mk") CONFIG_FILES="$CONFIG_FILES mk/config.mk" ;; + "mk/install.mk") CONFIG_FILES="$CONFIG_FILES mk/install.mk" ;; + "mk/project.mk") CONFIG_FILES="$CONFIG_FILES mk/project.mk" ;; + "compiler/ghc.cabal") CONFIG_FILES="$CONFIG_FILES compiler/ghc.cabal" ;; + "ghc/ghc-bin.cabal") CONFIG_FILES="$CONFIG_FILES ghc/ghc-bin.cabal" ;; + "utils/runghc/runghc.cabal") CONFIG_FILES="$CONFIG_FILES utils/runghc/runghc.cabal" ;; + "settings") CONFIG_FILES="$CONFIG_FILES settings" ;; + "docs/users_guide/ug-book.xml") CONFIG_FILES="$CONFIG_FILES docs/users_guide/ug-book.xml" ;; + "docs/users_guide/ug-ent.xml") CONFIG_FILES="$CONFIG_FILES docs/users_guide/ug-ent.xml" ;; + "docs/index.html") CONFIG_FILES="$CONFIG_FILES docs/index.html" ;; + "libraries/prologue.txt") CONFIG_FILES="$CONFIG_FILES libraries/prologue.txt" ;; + "distrib/configure.ac") CONFIG_FILES="$CONFIG_FILES distrib/configure.ac" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + + case $INSTALL in + [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; + *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; + esac +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +s&@INSTALL@&$ac_INSTALL&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +$as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + +# We got caught by +# http://savannah.gnu.org/bugs/index.php?1516 +# $(eval ...) inside conditionals causes errors +# with make 3.80, so warn the user if it looks like they're about to +# try to use it. +# We would use "grep -q" here, but Solaris's grep doesn't support it. +checkMake380() { + if $1 --version 2>&1 | head -1 | grep 'GNU Make 3\.80' > /dev/null + then + echo + echo "WARNING: It looks like \"$1\" is GNU make 3.80." + echo "This version cannot be used to build GHC." + echo "Please use GNU make >= 3.81." + fi +} + +checkMake380 make +checkMake380 gmake + +echo " +---------------------------------------------------------------------- +Configure completed successfully. + + Building GHC version : $ProjectVersion + Git commit id : $ProjectGitCommitId + + Build platform : $BuildPlatform + Host platform : $HostPlatform + Target platform : $TargetPlatform +" + +echo "\ + Bootstrapping using : $WithGhc + which is version : $GhcVersion +" + +if test "x$CC_LLVM_BACKEND" = "x1"; then + if test "x$CC_CLANG_BACKEND" = "x1"; then + CompilerName="clang " + else + CompilerName="llvm-gcc " + fi +else + CompilerName="gcc " +fi + +echo "\ + Using $CompilerName : $WhatGccIsCalled + which is version : $GccVersion + Building a cross compiler : $CrossCompiling + cpp : $HaskellCPPCmd + cpp-flags : $HaskellCPPArgs + ld : $LdCmd + Happy : $HappyCmd ($HappyVersion) + Alex : $AlexCmd ($AlexVersion) + Perl : $PerlCmd + dblatex : $DblatexCmd + xsltproc : $XsltprocCmd + + Using LLVM tools + llc : $LlcCmd + opt : $OptCmd" + +if test "$HSCOLOUR" = ""; then +echo " + HsColour was not found; documentation will not contain source links +" +else +echo "\ + HsColour : $HSCOLOUR +" +fi + +echo "\ + Building DocBook HTML documentation : $BUILD_DOCBOOK_HTML + Building DocBook PS documentation : $BUILD_DOCBOOK_PS + Building DocBook PDF documentation : $BUILD_DOCBOOK_PDF" + +echo "---------------------------------------------------------------------- +" + +echo "\ +For a standard build of GHC (fully optimised with profiling), type (g)make. + +To make changes to the default build configuration, copy the file +mk/build.mk.sample to mk/build.mk, and edit the settings in there. + +For more information on how to configure your GHC build, see + http://ghc.haskell.org/trac/ghc/wiki/Building +" diff --git a/configure.ac b/configure.ac new file mode 100644 index 00000000..37601ae7 --- /dev/null +++ b/configure.ac @@ -0,0 +1,1162 @@ +dnl == autoconf source for the Glasgow FP tools == +dnl (run "grep '^dnl \*' configure.ac | sed -e 's/dnl / /g; s/\*\*/ +/g;'" +dnl (or some such) to see the outline of this file) +dnl +# +# (c) The University of Glasgow 1994-2012 +# +# Configure script template for GHC +# +# Process with 'autoreconf' to get a working configure script. +# +# For the generated configure script, do "./configure --help" to +# see what flags are available. (Better yet, read the documentation!) +# + +AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.10.3], [glasgow-haskell-bugs@haskell.org], [ghc]) + +# Set this to YES for a released version, otherwise NO +: ${RELEASE=YES} + +# The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line +# above. If this is not a released version, then we will append the +# date to the version number (e.g. 7.4.20111220). The date is +# constructed by finding the date of the most recent patch in the +# git repository. If this is a source distribution (not a git +# checkout), then we ship a file 'VERSION' containing the full version +# when the source distribution was created. + +if test ! -f mk/config.h.in; then + echo "mk/config.h.in doesn't exist: perhaps you haven't run 'perl boot'?" + exit 1 +fi + +AC_SUBST([CONFIGURE_ARGS], [$ac_configure_args]) + +dnl ---------------------------------------------------------- +dnl ** Find unixy sort and find commands, +dnl ** which are needed by FP_SETUP_PROJECT_VERSION + +dnl ** Find find command (for Win32's benefit) +FP_PROG_FIND +FP_PROG_SORT + +dnl ---------------------------------------------------------- +FP_SETUP_PROJECT_VERSION + +# Hmmm, we fix the RPM release number to 1 here... Is this convenient? +AC_SUBST([release], [1]) + +# First off, a distrib sanity check.. +AC_CONFIG_SRCDIR([mk/config.mk.in]) + +dnl * We require autoconf version 2.60 +dnl We need 2.50 due to the use of AC_SYS_LARGEFILE and AC_MSG_NOTICE. +dnl We need 2.52 due to the use of AS_TR_CPP and AS_TR_SH. +dnl Using autoconf 2.59 started to give nonsense like this +dnl #define SIZEOF_CHAR 0 +dnl recently. +AC_PREREQ([2.60]) + +# ------------------------------------------------------------------------- +# Prepare to generate the following header files +# +# +AC_CONFIG_HEADER(mk/config.h) + +# No, semi-sadly, we don't do `--srcdir'... +if test x"$srcdir" != 'x.' ; then + echo "This configuration does not support the \`--srcdir' option.." + exit 1 +fi + +dnl -------------------------------------------------------------- +dnl * Project specific configuration options +dnl -------------------------------------------------------------- +dnl What follows is a bunch of options that can either be configured +dnl through command line options to the configure script or by +dnl supplying defns in the build tree's mk/build.mk. Having the option to +dnl use either is considered a Feature. + +dnl ** What command to use to compile compiler sources ? +dnl -------------------------------------------------------------- + +AC_ARG_WITH([ghc], +[AC_HELP_STRING([--with-ghc=ARG], + [Use ARG as the path to GHC [default=autodetect]])], + [WithGhc="$withval"], + [if test "$GHC" = ""; then + AC_PATH_PROG([GHC], [ghc]) + fi + WithGhc="$GHC"]) + +dnl ** Tell the make system which OS we are using +dnl $OSTYPE is set by the operating system to "msys" or "cygwin" or something +AC_SUBST(OSTYPE) + +AC_ARG_ENABLE(bootstrap-with-devel-snapshot, +[AC_HELP_STRING([--enable-bootstrap-with-devel-snapshot], + [Allow bootstrapping using a development snapshot of GHC. This is not guaranteed to work.])], + EnableBootstrapWithDevelSnaphost=YES, + EnableBootstrapWithDevelSnaphost=NO +) + +AC_ARG_ENABLE(tarballs-autodownload, +[AC_HELP_STRING([--enable-tarballs-autodownload], + [Automatically download Windows distribution binaries if needed.])], + TarballsAutodownload=YES, + TarballsAutodownload=NO +) +if test "$WithGhc" != ""; then + FPTOOLS_GHC_VERSION([GhcVersion], [GhcMajVersion], [GhcMinVersion], [GhcPatchLevel])dnl + + if test "$GhcMajVersion" = "unknown" -o "$GhcMinVersion" = "unknown"; then + AC_MSG_ERROR([Cannot determine the version of $WithGhc. Is it really GHC?]) + fi + + AC_SUBST(GhcVersion)dnl + AC_SUBST(GhcMajVersion)dnl + AC_SUBST(GhcMinVersion)dnl + AC_SUBST(GhcPatchLevel)dnl + GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` + GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" + + BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command]) + dnl ToDo, once "ld command" is reliably available. + dnl Then, we can remove the LD_STAGE0 hack in mk/build-package-date.mk + dnl BOOTSTRAPPING_GHC_INFO_FIELD([LD_STAGE0],[ld command]) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command]) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags]) + BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file]) +fi + +dnl ** Must have GHC to build GHC +if test "$WithGhc" = "" +then + AC_MSG_ERROR([GHC is required.]) +fi +FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.6], + [AC_MSG_ERROR([GHC version 7.6 or later is required to compile GHC.])]) + +if test `expr $GhcMinVersion % 2` = "1" +then + if test "$EnableBootstrapWithDevelSnaphost" = "NO" + then + AC_MSG_ERROR([ + $WithGhc is a development snapshot of GHC, version $GhcVersion. + Bootstrapping using this version of GHC is not supported, and may not + work. Use --enable-bootstrap-with-devel-snapshot to try it anyway, + or --with-ghc to specify a different GHC to use.]) + fi +fi + +GHC_PACKAGE_DB_FLAG=package-db +AC_SUBST(GHC_PACKAGE_DB_FLAG) + +# GHC 7.7+ needs -fcmm-sink when compiling Parser.hs. See #8182 +FP_COMPARE_VERSIONS([$GhcVersion],[-gt],[7.7], + CMM_SINK_BOOTSTRAP_IS_NEEDED=YES, + CMM_SINK_BOOTSTRAP_IS_NEEDED=NO) +AC_SUBST(CMM_SINK_BOOTSTRAP_IS_NEEDED) + +FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.9], + SUPPORTS_PACKAGE_KEY=NO, + SUPPORTS_PACKAGE_KEY=YES) +AC_SUBST(SUPPORTS_PACKAGE_KEY) + +# GHC is passed to Cabal, so we need a native path +if test "${WithGhc}" != "" +then + ghc_host_os=`"${WithGhc}" +RTS --info | grep 'Host OS' | sed -e 's/.*, "//' -e 's/")//'` + + if test "$ghc_host_os" = "mingw32" + then + if test "${OSTYPE}" = "msys" + then + WithGhc=`echo "${WithGhc}" | sed "s#^/\([a-zA-Z]\)/#\1:/#"` + else + # Canonicalise to :/path/to/ghc + WithGhc=`cygpath -m "${WithGhc}"` + fi + echo "GHC path canonicalised to: ${WithGhc}" + fi +fi +AC_SUBST([WithGhc]) + +dnl ** Without optimization some INLINE trickery fails for GHCi +SRC_CC_OPTS="-O" + +dnl-------------------------------------------------------------------- +dnl * Choose host(/target/build) platform +dnl-------------------------------------------------------------------- +dnl If we aren't explicitly told what values to use with configure flags, +dnl we ask the bootstrapping compiler what platform it is for + +if test "${WithGhc}" != "" +then + bootstrap_host=`"${WithGhc}" +RTS --info | grep '^ ,("Host platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` + bootstrap_target=`"${WithGhc}" +RTS --info | grep '^ ,("Target platform"' | sed -e 's/.*, "//' -e 's/")//' | tr -d '\r'` + if test "$bootstrap_host" != "$bootstrap_target" + then + echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work" + fi +fi + +# We have to run these unconditionally, but we may discard their +# results in the following code +AC_CANONICAL_BUILD +AC_CANONICAL_HOST +AC_CANONICAL_TARGET + +FPTOOLS_SET_PLATFORM_VARS + +# Verify that the installed (bootstrap) GHC is capable of generating +# code for the requested build platform. +if test "$BuildPlatform" != "$bootstrap_target" +then + echo "This GHC (${WithGhc}) does not generate code for the build platform" + echo " GHC target platform : $bootstrap_target" + echo " Desired build platform : $BuildPlatform" + exit 1 +fi + +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + +case $host in + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; +esac + +AC_SUBST(SOLARIS_BROKEN_SHLD) + +dnl ** Do an unregisterised build? +dnl -------------------------------------------------------------- +case "$HostArch" in + i386|x86_64|powerpc|arm) + UnregisterisedDefault=NO + ;; + *) + UnregisterisedDefault=YES + ;; +esac +AC_ARG_ENABLE(unregisterised, +[AC_HELP_STRING([--enable-unregisterised], +[Build an unregisterised compiler (enabled by default on platforms without registerised support) [default="$UnregisterisedDefault"]])], +[ if test x"$enableval" = x"yes"; then + Unregisterised=YES + else + Unregisterised=NO + fi +], +[Unregisterised="$UnregisterisedDefault"] +) +AC_SUBST(Unregisterised) + +AC_ARG_WITH(hc, +[AC_HELP_STRING([--with-hc=ARG], + [Use ARG as the path to the compiler for compiling ordinary + Haskell code (default= value of --with-ghc)])], +[WithHc="$withval"], +[WithHc=$WithGhc] +) +AC_SUBST(WithHc) + +# This uses GHC, so put it after the "GHC is required" check above: +FP_INTREE_GHC_PWD +FP_FIND_ROOT + +fail() { + echo >&2 + echo "$1" >&2 + exit 1 +} + + +if test "$HostOS" = "mingw32" +then + # Find the mingw-w64 7z file to extract. + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if test "$HostArch" = "i386" + then + mingw_arch="i686" + tarball_dest_dir="mingw-w64/x86" + tarball_mingw_dir="mingw32" + else + mingw_arch="x86_64" + tarball_dest_dir="mingw-w64/x86_64" + tarball_mingw_dir="mingw64" + fi +fi + +set_up_tarballs() { + AC_MSG_NOTICE([Checking for Windows toolchain tarballs...]) + local action + if test "$TarballsAutodownload" = "NO" + then + action="verify" + else + action="download" + fi + mk/get-win32-tarballs.sh $action $HostArch > missing-win32-tarballs + case $? in + 0) + rm missing-win32-tarballs + ;; + 2) + echo + echo "Error:" + echo "Needed msys2 tarballs are missing. You have a few options to get them," + echo + echo " * run configure with the --enable-tarballs-autodownload option" + echo + echo " * run mk/get-win32-tarballs.sh download ${HostArch}" + echo + echo " * manually download the files listed in ./missing-win32-tarballs and place" + echo " them in the ghc-tarballs directory." + echo + exit 1 + ;; + *) + echo + echo "Error fetching msys2 tarballs; see errors above." + exit 1 + ;; + esac + + # Extract all the tarballs in one go + if ! test -d inplace/mingw + then + AC_MSG_NOTICE([Extracting Windows toolchain from archives (may take a while)...]) + rm -rf inplace/mingw + local base_dir="../ghc-tarballs/${tarball_dest_dir}" + ( cd inplace && + find "${base_dir}" -name "*.tar.xz" -exec tar xfJ {} \; && + rm ".MTREE" && + rm ".PKGINFO" && + cd .. ) || fail "Error: Could not extract Windows toolchains." + + mv "inplace/${tarball_mingw_dir}" inplace/mingw && + touch inplace/mingw + + # NB. Now since the GCC is hardcoded to use /mingw32 we need to + # make a wrapper around it to give it the proper paths + mv inplace/mingw/bin/gcc.exe inplace/mingw/bin/realgcc.exe + PATH=`pwd`/inplace/mingw/bin:$PATH + inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe + + AC_MSG_NOTICE([In-tree MingW-w64 tree created]) + fi +} + +if test "$HostOS" = "mingw32" +then + test -d inplace || mkdir inplace + + # NB. Download and extract the MingW-w64 distribution if required + set_up_tarballs + + mingwbin="$hardtop/inplace/mingw/bin/" + CC="${mingwbin}gcc.exe" + LD="${mingwbin}ld.exe" + NM="${mingwbin}nm.exe" + RANLIB="${mingwbin}ranlib.exe" + OBJDUMP="${mingwbin}objdump.exe" + fp_prog_ar="${mingwbin}ar.exe" + + # NB. Download the perl binaries if required + if ! test -d inplace/perl || + test inplace/perl -ot ghc-tarballs/perl/ghc-perl*.tar.gz + then + AC_MSG_NOTICE([Making in-tree perl tree]) + rm -rf inplace/perl + mkdir inplace/perl + ( + cd inplace/perl && + tar -zxf ../../ghc-tarballs/perl/ghc-perl*.tar.gz + ) + AC_MSG_NOTICE([In-tree perl tree created]) + fi +fi + +FP_ICONV +FP_GMP +FP_CURSES + +XCODE_VERSION() + +SplitObjsBroken=NO +if test "$TargetOS_CPP" = "darwin" +then + # Split objects is broken (#4013) with XCode < 3.2 + if test "$XCodeVersion1" -lt 3 + then + SplitObjsBroken=YES + else + if test "$XCodeVersion1" -eq 3 + then + if test "$XCodeVersion2" -lt 2 + then + SplitObjsBroken=YES + fi + fi + fi +fi +AC_SUBST([SplitObjsBroken]) + +dnl ** Building a cross compiler? +dnl -------------------------------------------------------------- +CrossCompiling=NO +# If 'host' and 'target' differ, then this means we are building a cross-compiler. +if test "$target" != "$host" ; then + CrossCompiling=YES + cross_compiling=yes # This tells configure that it can accept just 'target', + # otherwise you get + # configure: error: cannot run C compiled programs. + # If you meant to cross compile, use `--host'. +fi +if test "$build" != "$host" ; then + AC_MSG_ERROR([ +You've selected: + + BUILD: $build (the architecture we're building on) + HOST: $host (the architecture the compiler we're building will execute on) + TARGET: $target (the architecture the compiler we're building will produce code for) + +BUILD must equal HOST; that is, we do not support building GHC itself +with a cross-compiler. To cross-compile GHC itself, set TARGET: stage +1 will be a cross-compiler, and stage 2 will be the cross-compiled +GHC. +]) +fi +if test "$CrossCompiling" = "YES" +then + CrossCompilePrefix="${target}-" +else + CrossCompilePrefix="" +fi +TargetPlatformFull="${target}" +AC_SUBST(CrossCompiling) +AC_SUBST(CrossCompilePrefix) +AC_SUBST(TargetPlatformFull) + +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +FIND_GCC([WhatGccIsCalled], [gcc], [gcc]) +CC="$WhatGccIsCalled" +export CC + +# If --with-gcc was used, and we're not cross-compiling, then it also +# applies to the stage0 compiler. +MAYBE_OVERRIDE_STAGE0([gcc],[CC_STAGE0]) +MAYBE_OVERRIDE_STAGE0([ar],[AR_STAGE0]) + +# --with-hs-cpp/--with-hs-cpp-flags +FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs) + +dnl ** Which ld to use? +dnl -------------------------------------------------------------- +FIND_LD([LdCmd]) +AC_SUBST([LdCmd]) + +dnl ** Which nm to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([NM], [nm], [nm]) +NmCmd="$NM" +AC_SUBST([NmCmd]) + +dnl ** Which ar to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([AR], [ar], [ar]) +ArCmd="$AR" +fp_prog_ar="$AR" +AC_SUBST([ArCmd]) + +dnl ** Which ranlib to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([RANLIB], [ranlib], [ranlib]) +RanlibCmd="$RANLIB" +RANLIB="$RanlibCmd" + +dnl ** Which readelf to use? +dnl -------------------------------------------------------------- +FIND_READELF([ReadElfCmd]) +AC_SUBST([ReadElfCmd]) + + +# Note: we may not have objdump on OS X, and we only need it on Windows (for DLL checks) +case $HostOS_CPP in +cygwin32|mingw32) + dnl ** Which objdump to use? + dnl -------------------------------------------------------------- + FP_ARG_WITH_PATH_GNU_PROG([OBJDUMP], [objdump], [objdump]) + ObjdumpCmd="$OBJDUMP" + AC_SUBST([ObjdumpCmd]) + ;; +esac + +# Here is where we re-target which specific version of the LLVM +# tools we are looking for. In the past, GHC supported a number of +# versions of LLVM simultaneously, but that stopped working around +# 3.5/3.6 release of LLVM. +LlvmVersion=3.5 +AC_SUBST([LlvmVersion]) + +dnl ** Which LLVM llc to use? +dnl -------------------------------------------------------------- +FIND_LLVM_PROG([LLC], [llc], [llc], [$LlvmVersion]) +LlcCmd="$LLC" +AC_SUBST([LlcCmd]) + +dnl ** Which LLVM opt to use? +dnl -------------------------------------------------------------- +FIND_LLVM_PROG([OPT], [opt], [opt], [$LlvmVersion]) +OptCmd="$OPT" +AC_SUBST([OptCmd]) + +dnl -------------------------------------------------------------- +dnl End of configure script option section +dnl -------------------------------------------------------------- + + +dnl -------------------------------------------------------------- +dnl * General configuration checks +dnl -------------------------------------------------------------- + +dnl ** Bug 9439: Some GHC 7.8 releases had broken LLVM code generator. +dnl Unfortunately we don't know whether the user is going to request a +dnl build with the LLVM backend as this is only given in build.mk. +dnl +dnl Instead, we try to do as much work as possible here, checking +dnl whether -fllvm is the stage 0 compiler's default. If so we +dnl fail. If not, we check whether -fllvm is affected explicitly and +dnl if so set a flag. The build system will later check this flag +dnl after the desired build flags are known. + +dnl This problem is further complicated by the fact that the llvm +dnl version used by the bootstrap compiler may be different from the +dnl version we arre trying to compile GHC against. Therefore, we need +dnl to find the boostrap compiler's `settings` file then check to see +dnl if the `opt` and `llc` command strings are non-empty and if these +dnl programs exist. Only if they exist to we test for bug #9439. + +FIND_GHC_BOOTSTRAP_PROG([BootstrapLlcCmd], [${WithGhc}], "LLVM llc command") +FIND_GHC_BOOTSTRAP_PROG([BootstrapOptCmd], [${WithGhc}], "LLVM opt command") + +if test -n "$BootstrapLlcCmd" && test -n "$BootstrapOptCmd" +then + AC_MSG_CHECKING(whether bootstrap compiler is affected by bug 9439) + echo "main = putStrLn \"%function\"" > conftestghc.hs + + # Check whether LLVM backend is default for this platform + "${WithGhc}" -pgmlc="${BootstrapLlcCmd}" -pgmlo="${BootstrapOptCmd}" conftestghc.hs 2>&1 >/dev/null + res=`./conftestghc` + if test "x$res" = "x%object" + then + AC_MSG_RESULT(yes) + echo "Buggy bootstrap compiler" + echo "" + echo "The stage 0 compiler $WithGhc is affected by GHC Bug \#9439" + echo "and therefore will miscompile the LLVM backend if -fllvm is" + echo "used." + echo + echo "Please use another bootstrap compiler" + exit 1 + fi + + # -fllvm is not the default, but set a flag so the Makefile can check + # -for it in the build flags later on + "${WithGhc}" -fforce-recomp -pgmlc="${BootstrapLlcCmd}" -pgmlo="${BootstrapOptCmd}" -fllvm conftestghc.hs 2>&1 >/dev/null + if test $? = 0 + then + res=`./conftestghc` + if test "x$res" = "x%object" + then + AC_MSG_RESULT(yes) + GHC_LLVM_AFFECTED_BY_9439=1 + elif test "x$res" = "x%function" + then + AC_MSG_RESULT(no) + GHC_LLVM_AFFECTED_BY_9439=0 + else + AC_MSG_WARN(unexpected output $res) + fi + else + AC_MSG_RESULT(failed to compile, assuming no) + fi +fi +AC_SUBST([GHC_LLVM_AFFECTED_BY_9439]) + +dnl ** Bug 9920: Llvm version 3.5.0 was released with a bug in the ARM version +dnl of the GHC calling convention implementation. This bug was fixed in the +dnl 3.5.1 release but some Linux distributions are likely to patch llvm +dnl 3.5.0 rather than release a new 3.5.1 version. +dnl +dnl Unfortunately we don't know whether the user is going to request a +dnl build with the LLVM backend as this is only given in build.mk. + +if test ${TargetArch} = arm ; then + AC_MSG_CHECKING(if llvm version is affected by bug 9920) + rm -f conftest.ll conftest.asm + cat << LLVM_IR_CODE > conftest.ll +declare cc10 void @target_function() +define cc10 void @test_direct_tail() { + tail call cc10 void @target_function() + ret void +} +LLVM_IR_CODE + + res=$(${LlcCmd} -mtriple=armv7-eabi conftest.ll -o conftest.asm) + if test $? -eq 0 ; then + if test $(grep -c target_function conftest.asm) -eq 1 ; then + AC_MSG_RESULT(no) + else + AC_MSG_RESULT(yes) + echo + AC_MSG_FAILURE([Cannot compile for ARM with ${LlcCmd}. See GHC trac ticket #9920.], 1) + fi + else + AC_MSG_WARN([unexpected output $res]) + fi + rm -f conftest.ll conftest.asm +fi + +dnl ** Can the unix package be built? +dnl -------------------------------------------------------------- + +if test "$TargetOS" = "mingw32" +then + GhcLibsWithUnix=NO +else + GhcLibsWithUnix=YES +fi +AC_SUBST([GhcLibsWithUnix]) + +dnl ** does #! work? +AC_SYS_INTERPRETER() + +dnl ** look for `perl' +case $HostOS_CPP in +cygwin32|mingw32) + PerlCmd=$hardtop/inplace/perl/perl + ;; +*) + AC_PATH_PROG(PerlCmd,perl) + if test -z "$PerlCmd" + then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 + else + FPTOOLS_CHECK_PERL_VERSION + fi + ;; +esac + +dnl ** look for GCC and find out which version +dnl Figure out which C compiler to use. Gcc is preferred. +dnl If gcc, make sure it's at least 3.0 +dnl +FP_GCC_VERSION + +dnl ** look to see if we have a C compiler using an llvm back end. +dnl +FP_CC_LLVM_BACKEND + +FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID +FP_PROG_LD_NO_COMPACT_UNWIND +FP_PROG_LD_FILELIST + + +FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) +FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) +FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) +FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) +# Stage 3 won't be supported by cross-compilation + +FP_GCC_EXTRA_FLAGS + +dnl ** figure out how to invoke cpp directly (gcc -E is no good) +AC_PROG_CPP + +AC_SUBST(CONF_CC_OPTS_STAGE0) +AC_SUBST(CONF_CC_OPTS_STAGE1) +AC_SUBST(CONF_CC_OPTS_STAGE2) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE0) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE1) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE2) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE0) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE1) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE2) +AC_SUBST(CONF_CPP_OPTS_STAGE0) +AC_SUBST(CONF_CPP_OPTS_STAGE1) +AC_SUBST(CONF_CPP_OPTS_STAGE2) + +dnl ** Set up the variables for the platform in the settings file. +dnl May need to use gcc to find platform details. +dnl -------------------------------------------------------------- +FPTOOLS_SET_HASKELL_PLATFORM_VARS + +dnl ** figure out how to do context diffs +FP_PROG_CONTEXT_DIFF + +dnl Let's make sure install-sh is executable here. If we got it from +dnl a darcs repo, it might not be (see bug #978). +chmod +x install-sh +dnl ** figure out how to do a BSD-ish install +AC_PROG_INSTALL + +dnl ** how to invoke `ar' and `ranlib' +FP_PROG_AR_SUPPORTS_ATFILE +FP_PROG_AR_NEEDS_RANLIB + +dnl ** Check to see whether ln -s works +AC_PROG_LN_S + +FP_SETTINGS + +dnl ** Find the path to sed +AC_PATH_PROGS(SedCmd,gsed sed,sed) + + +dnl ** check for time command +AC_PATH_PROG(TimeCmd,time) + +dnl ** check for tar +dnl if GNU tar is named gtar, look for it first. +AC_PATH_PROGS(TarCmd,gnutar gtar tar,tar) + +dnl ** check for patch +dnl if GNU patch is named gpatch, look for it first +AC_PATH_PROGS(PatchCmd,gpatch patch, patch) + +dnl ** check for dtrace (currently only implemented for Mac OS X) +HaveDtrace=NO +AC_PATH_PROG(DtraceCmd,dtrace) +if test -n "$DtraceCmd"; then + if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple" -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xsolaris2-unknown"; then + HaveDtrace=YES + fi +fi +AC_SUBST(HaveDtrace) + +AC_PATH_PROG(HSCOLOUR,HsColour) +# HsColour is passed to Cabal, so we need a native path +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HSCOLOUR}" != "" +then + # Canonicalise to :/path/to/gcc + HSCOLOUR=`cygpath -m ${HSCOLOUR}` +fi + +dnl ** check for DocBook toolchain +FP_CHECK_DOCBOOK_DTD +FP_DOCBOOK_XSL +FP_PROG_DBLATEX + +dnl ** check for ghc-pkg command +FP_PROG_GHC_PKG + +dnl ** check for installed happy binary + version +FPTOOLS_HAPPY + +dnl ** check for installed alex binary + version +FPTOOLS_ALEX + +dnl -------------------------------------------------- +dnl ### program checking section ends here ### +dnl -------------------------------------------------- + +dnl -------------------------------------------------- +dnl * Platform header file and syscall feature tests +dnl ### checking the state of the local header files and syscalls ### + +dnl ** check for full ANSI header (.h) files +AC_HEADER_STDC + +dnl ** Enable large file support. NB. do this before testing the type of +dnl off_t, because it will affect the result of that test. +AC_SYS_LARGEFILE + +dnl ** check for specific header (.h) files that we are interested in +AC_CHECK_HEADERS([ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/param.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h]) + +dnl sys/cpuset.h needs sys/param.h to be included first on FreeBSD 9.1; #7708 +AC_CHECK_HEADERS([sys/cpuset.h], [], [], +[[#if HAVE_SYS_PARAM_H +# include +#endif +]]) + +dnl ** check if it is safe to include both and +AC_HEADER_TIME + +dnl ** do we have long longs? +AC_CHECK_TYPES([long long]) + +dnl ** what are the sizes of various types +AC_CHECK_SIZEOF(char, 1) +AC_CHECK_SIZEOF(double, 8) +AC_CHECK_SIZEOF(float, 4) +AC_CHECK_SIZEOF(int, 4) +AC_CHECK_SIZEOF(long, 4) +if test "$ac_cv_type_long_long" = yes; then +AC_CHECK_SIZEOF(long long, 8) +fi +AC_CHECK_SIZEOF(short, 2) +AC_CHECK_SIZEOF(unsigned char, 1) +AC_CHECK_SIZEOF(unsigned int, 4) +AC_CHECK_SIZEOF(unsigned long, 4) +if test "$ac_cv_type_long_long" = yes; then +AC_CHECK_SIZEOF(unsigned long long, 8) +fi +AC_CHECK_SIZEOF(unsigned short, 2) +AC_CHECK_SIZEOF(void *, 4) + +dnl for use in settings.in +WordSize=$ac_cv_sizeof_void_p +AC_SUBST(WordSize) + +dnl ** what are alignment constraints on various types +FP_CHECK_ALIGNMENT(char) +FP_CHECK_ALIGNMENT(double) +FP_CHECK_ALIGNMENT(float) +FP_CHECK_ALIGNMENT(int) +FP_CHECK_ALIGNMENT(long) +if test "$ac_cv_type_long_long" = yes; then +FP_CHECK_ALIGNMENT(long long) +fi +FP_CHECK_ALIGNMENT(short) +FP_CHECK_ALIGNMENT(unsigned char) +FP_CHECK_ALIGNMENT(unsigned int) +FP_CHECK_ALIGNMENT(unsigned long) +if test "$ac_cv_type_long_long" = yes; then +FP_CHECK_ALIGNMENT(unsigned long long) +fi +FP_CHECK_ALIGNMENT(unsigned short) +FP_CHECK_ALIGNMENT(void *) + +FP_CHECK_FUNC([WinExec], + [@%:@include ], [WinExec("",0)]) + +FP_CHECK_FUNC([GetModuleFileName], + [@%:@include ], [GetModuleFileName((HMODULE)0,(LPTSTR)0,0)]) + +dnl ** check for more functions +dnl ** The following have been verified to be used in ghc/, but might be used somewhere else, too. +AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity setlocale]) + +dnl ** On OS X 10.4 (at least), time.h doesn't declare ctime_r if +dnl ** _POSIX_C_SOURCE is defined +AC_CHECK_DECLS([ctime_r], , , +[#define _POSIX_SOURCE 1 +#define _POSIX_C_SOURCE 199506L +#include ]) + +dnl ** check for mingwex library +AC_CHECK_LIB(mingwex, closedir, HaveLibMingwEx=YES, HaveLibMingwEx=NO) +AC_SUBST(HaveLibMingwEx) + +if test $HaveLibMingwEx = YES ; then + AC_DEFINE([HAVE_MINGWEX], [1], [Define to 1 if you have the mingwex library.]) +fi + +dnl ** check for math library +dnl Keep that check as early as possible. +dnl as we need to know whether we need libm +dnl for math functions or not +dnl (see http://ghc.haskell.org/trac/ghc/ticket/3730) +AC_CHECK_LIB(m, atan, HaveLibM=YES, HaveLibM=NO) +if test $HaveLibM = YES +then + AC_DEFINE([HAVE_LIBM], [1], [Define to 1 if you need to link with libm]) +fi + +FP_BFD_SUPPORT + +dnl ################################################################ +dnl Check for libraries +dnl ################################################################ + +# system libffi + +AC_ARG_WITH([system-libffi], +[AC_HELP_STRING([--with-system-libffi], + [Use system provided libffi for RTS [default=no]]) +]) + +AS_IF([test "x$with_system_libffi" = "xyes"], + [UseSystemLibFFI="YES"], [UseSystemLibFFI="NO"] +) + + +AC_SUBST(UseSystemLibFFI) + +AC_ARG_WITH([ffi-includes], +[AC_HELP_STRING([--with-ffi-includes=ARG], + [Find includes for libffi in ARG [default=system default]]) +], +[ + if test "x$UseSystemLibFFI" != "xYES"; then + AC_MSG_WARN([--with-ffi-includes will be ignored, --with-system-libffi not set]) + else + FFIIncludeDir="$withval" + LIBFFI_CFLAGS="-I$withval" + fi +]) + +AC_SUBST(FFIIncludeDir) + +AC_ARG_WITH([ffi-libraries], +[AC_HELP_STRING([--with-ffi-libraries=ARG], + [Find libffi in ARG [default=system default]]) +], +[ + if test "x$UseSystemLibFFI" != "xYES"; then + AC_MSG_WARN([--with-ffi-libraries will be ignored, --with-system-libffi not set]) + else + FFILibDir="$withval" LIBFFI_LDFLAGS="-L$withval" + fi +]) + +AC_SUBST(FFILibDir) + +AS_IF([test "$UseSystemLibFFI" = "YES"], [ + CFLAGS2="$CFLAGS" + CFLAGS="$LIBFFI_CFLAGS $CFLAGS" + LDFLAGS2="$LDFLAGS" + LDFLAGS="$LIBFFI_LDFLAGS $LDFLAGS" + AC_CHECK_LIB(ffi, ffi_call, + [AC_CHECK_HEADERS([ffi.h], [break], []) + AC_DEFINE([HAVE_LIBFFI], [1], [Define to 1 if you have libffi.])], + [AC_MSG_ERROR([Cannot find system libffi])]) + CFLAGS="$CFLAGS2" + LDFLAGS="$LDFLAGS2" +]) + +dnl ** check whether we need -ldl to get dlopen() +AC_CHECK_LIB(dl, dlopen) + +dnl -------------------------------------------------- +dnl * Miscellaneous feature tests +dnl -------------------------------------------------- + +dnl ** can we get alloca? +AC_FUNC_ALLOCA + +dnl ** working vfork? +AC_FUNC_FORK + +dnl ** determine whether or not const works +AC_C_CONST + +dnl ** are we big endian? +AC_C_BIGENDIAN +FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN + +dnl ** check for leading underscores in symbol names +FP_LEADING_UNDERSCORE + +FP_VISIBILITY_HIDDEN + +dnl ** check for librt +AC_CHECK_LIB(rt, clock_gettime) +AC_CHECK_FUNCS(clock_gettime timer_settime) +FP_CHECK_TIMER_CREATE + +dnl ** check for Apple's "interesting" long double compatibility scheme +AC_MSG_CHECKING(for printf\$LDBLStub) +AC_TRY_LINK_FUNC(printf\$LDBLStub, + [ + AC_MSG_RESULT(yes) + AC_DEFINE([HAVE_PRINTF_LDBLSTUB],[1], + [Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC).]) + ], + [ + AC_MSG_RESULT(no) + AC_DEFINE([HAVE_PRINTF_LDBLSTUB],[0], + [Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC).]) + ]) + +dnl ** pthread_setname_np is a recent addition to glibc, and OS X has +dnl a different single-argument version. +AC_CHECK_LIB(pthread, pthread_setname_np) +AC_MSG_CHECKING(for pthread_setname_np) +AC_TRY_LINK( +[ +#define _GNU_SOURCE +#include +], +[pthread_setname_np(pthread_self(), "name");], + AC_MSG_RESULT(yes) + AC_DEFINE([HAVE_PTHREAD_SETNAME_NP], [1], + [Define to 1 if you have the glibc version of pthread_setname_np]), + AC_MSG_RESULT(no) +) + +dnl ** check for eventfd which is needed by the I/O manager +AC_CHECK_HEADERS([sys/eventfd.h]) +AC_CHECK_FUNCS([eventfd]) + +dnl ** Check for __thread support in the compiler +AC_MSG_CHECKING(for __thread support) +AC_COMPILE_IFELSE( + [ AC_LANG_SOURCE([[__thread int tester = 0;]]) ], + [ + AC_MSG_RESULT(yes) + AC_DEFINE([CC_SUPPORTS_TLS],[1],[Define to 1 if __thread is supported]) + ], + [ + AC_MSG_RESULT(no) + AC_DEFINE([CC_SUPPORTS_TLS],[0],[Define to 1 if __thread is supported]) + ]) + + +dnl ** checking for PAPI +AC_CHECK_LIB(papi, PAPI_library_init, HavePapiLib=YES, HavePapiLib=NO) +AC_CHECK_HEADER([papi.h], [HavePapiHeader=YES], [HavePapiHeader=NO]) +AC_SUBST(HavePapiLib) +AC_SUBST(HavePapiHeader) + +AC_CHECK_FUNCS(__mingw_vfprintf) + +if test "$HavePapiLib" = "YES" -a "$HavePapiHeader" = "YES"; then + HavePapi=YES +else + HavePapi=NO +fi +AC_SUBST(HavePapi) + +if test "$HAVE_DOCBOOK_XSL" = "NO" || + test "$XsltprocCmd" = "" +then + BUILD_DOCBOOK_HTML=NO +else + BUILD_DOCBOOK_HTML=YES +fi +AC_SUBST(BUILD_DOCBOOK_HTML) + +if test "$DblatexCmd" = "" +then + BUILD_DOCBOOK_PS=NO + BUILD_DOCBOOK_PDF=NO +else + BUILD_DOCBOOK_PS=YES + BUILD_DOCBOOK_PDF=YES +fi +AC_SUBST(BUILD_DOCBOOK_PS) +AC_SUBST(BUILD_DOCBOOK_PDF) + +LIBRARY_VERSION(base) +LIBRARY_VERSION(Cabal, Cabal/Cabal) +LIBRARY_VERSION(ghc-prim) +LIBRARY_ghc_VERSION="$ProjectVersion" +AC_SUBST(LIBRARY_ghc_VERSION) + +if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then + AC_MSG_ERROR([compiler/ghc.cabal.in contains tab characters; please remove them]) +fi + +AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/configure.ac]) +AC_OUTPUT + +# We got caught by +# http://savannah.gnu.org/bugs/index.php?1516 +# $(eval ...) inside conditionals causes errors +# with make 3.80, so warn the user if it looks like they're about to +# try to use it. +# We would use "grep -q" here, but Solaris's grep doesn't support it. +checkMake380() { + if $1 --version 2>&1 | head -1 | grep 'GNU Make 3\.80' > /dev/null + then + echo + echo "WARNING: It looks like \"$1\" is GNU make 3.80." + echo "This version cannot be used to build GHC." + echo "Please use GNU make >= 3.81." + fi +} + +checkMake380 make +checkMake380 gmake + +echo [" +---------------------------------------------------------------------- +Configure completed successfully. + + Building GHC version : $ProjectVersion + Git commit id : $ProjectGitCommitId + + Build platform : $BuildPlatform + Host platform : $HostPlatform + Target platform : $TargetPlatform +"] + +echo ["\ + Bootstrapping using : $WithGhc + which is version : $GhcVersion +"] + +if test "x$CC_LLVM_BACKEND" = "x1"; then + if test "x$CC_CLANG_BACKEND" = "x1"; then + CompilerName="clang " + else + CompilerName="llvm-gcc " + fi +else + CompilerName="gcc " +fi + +echo ["\ + Using $CompilerName : $WhatGccIsCalled + which is version : $GccVersion + Building a cross compiler : $CrossCompiling + cpp : $HaskellCPPCmd + cpp-flags : $HaskellCPPArgs + ld : $LdCmd + Happy : $HappyCmd ($HappyVersion) + Alex : $AlexCmd ($AlexVersion) + Perl : $PerlCmd + dblatex : $DblatexCmd + xsltproc : $XsltprocCmd + + Using LLVM tools + llc : $LlcCmd + opt : $OptCmd"] + +if test "$HSCOLOUR" = ""; then +echo [" + HsColour was not found; documentation will not contain source links +"] +else +echo ["\ + HsColour : $HSCOLOUR +"] +fi + +echo ["\ + Building DocBook HTML documentation : $BUILD_DOCBOOK_HTML + Building DocBook PS documentation : $BUILD_DOCBOOK_PS + Building DocBook PDF documentation : $BUILD_DOCBOOK_PDF"] + +echo ["---------------------------------------------------------------------- +"] + +echo "\ +For a standard build of GHC (fully optimised with profiling), type (g)make. + +To make changes to the default build configuration, copy the file +mk/build.mk.sample to mk/build.mk, and edit the settings in there. + +For more information on how to configure your GHC build, see + http://ghc.haskell.org/trac/ghc/wiki/Building +" diff --git a/distrib/INSTALL b/distrib/INSTALL new file mode 100644 index 00000000..2e374be4 --- /dev/null +++ b/distrib/INSTALL @@ -0,0 +1,41 @@ +This is the INSTALL instructions for a binary distribution of GHC. For +more details on what on earth this package is up to, please consult +the README and ANNOUNCE. + +This distribution can be installed in a location of your choosing. + +To set the ball rolling, run the configure script (as usual, run the +script with --help to see what options it supports). eg. to set up +the package for installing in directory , use + + ./configure --prefix= + +The default installation directory is /usr/local. + +The configure script will figure out what platform you're running on, +and a couple of other interesting pieces of trivia, which it will then +fill in the Makefile.in template to give you a real Makefile. If +you're of a paranoid persuasion, you might want to take a look at this +Makefile to see if the information is correct. + +Now run: + + make install + +(`make show-install-setup' prints the details of where the different +pieces of the bundle are heading when -- possibly helpful). + +For more information, full GHC documentation is available from the +main GHC site: + + http://www.haskell.org/ghc + +Bug reports/suggestions for improvement to the installation +procedure/setup (as well as other GHC related troubles you're +experiencing, of course), gratefully received. Bug reporting +instructions are here: + + http://www.haskell.org/ghc/reportabug + +Enjoy, +-- The GHC Team. diff --git a/distrib/Makefile b/distrib/Makefile new file mode 100644 index 00000000..7f8add1f --- /dev/null +++ b/distrib/Makefile @@ -0,0 +1,73 @@ + +include Makefile-vars + +.PHONY: install-strip install postinstall denounce show-install-setup + +#.PHONY: in-place +# This has bitrotted: +#in-place :: +# @if test -x "./post-inplace-script" ; then \ +# echo "Running project-specific post-inplace script ..." ; \ +# ./post-inplace-script $(platform) `pwd` \ +# $(package)-$(version); \ +# echo "Done" ; \ +# fi +# @echo "Finished configuring..to use, add `pwd`/bin/$(platform) to your PATH." + +install-strip: + $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install + +install :: + $(INSTALL_DIR) $(bindir) + $(INSTALL_DIR) $(datadir) + echo "[]" > $(datadir)/package.conf + +install:: + $(MAKE) -C includes install DOING_BIN_DIST=YES + $(MAKE) -C utils install DOING_BIN_DIST=YES + $(MAKE) -C rts install DOING_BIN_DIST=YES + $(MAKE) -C libraries install DOING_BIN_DIST=YES + $(MAKE) -C libffi install DOING_BIN_DIST=YES + $(MAKE) -C compiler install DOING_BIN_DIST=YES + $(MAKE) -C ghc install DOING_BIN_DIST=YES + $(MAKE) -C driver install DOING_BIN_DIST=YES + $(MAKE) -C gmp install DOING_BIN_DIST=YES + $(MAKE) -C docs install-docs DOING_BIN_DIST=YES + $(MAKE) -C libraries/Cabal/doc install-docs DOING_BIN_DIST=YES + $(INSTALL_DATA) $(INSTALL_OPTS) settings $(libdir) + +install :: postinstall denounce + +# Look to see if $(bindir) is in $(PATH). Assumes there are no funky +# characters. +GREPPED_PATH=$(shell echo ":$(PATH):" | grep ":$(bindir):") + +denounce: + @echo + @echo ======================================================================= + @echo Installation of $(package)-$(version) was successful. + @echo +ifeq "$(GREPPED_PATH)" "" + @echo To use, add $(bindir) to your PATH. + @echo +endif + @if test -f $(htmldir)/index.html; then \ + echo For documentation, see $(htmldir)/index.html ; \ + else \ + echo "Warning: this binary distribution does NOT contain documentation!" ; \ + fi + @echo ======================================================================= + +postinstall: + @if test -x "./post-install-script" ; then \ + echo "Running project-specific post-install script ..." ; \ + ./post-install-script $(platform) $(libdir) ; \ + echo "Done" ; \ + fi + +show-install-setup: + @echo "Install setup..." + @echo "bindir = $(bindir)" + @echo "libdir = $(libdir) (libdir = $(libdir))" + @echo "datadir = $(datadir) (datadir = $(datadir))" + diff --git a/distrib/README b/distrib/README new file mode 100644 index 00000000..91842aed --- /dev/null +++ b/distrib/README @@ -0,0 +1,17 @@ +The Glasgow Haskell Compiler +============================ + +This is a binary distribution of GHC, a compiler and interactive +environment for the Haskell functional programming language. + +For more information, visit GHC's web site: + + http://www.haskell.org/ghc/ + +Information for developers of GHC can be found here: + + http://ghc.haskell.org/trac/ghc/ + + +For installation instructions, see the accompanying INSTALL file. + diff --git a/distrib/compare/BuildInfo.hs b/distrib/compare/BuildInfo.hs new file mode 100644 index 00000000..1101bf45 --- /dev/null +++ b/distrib/compare/BuildInfo.hs @@ -0,0 +1,59 @@ + +module BuildInfo where + +import Control.Monad.State + +type BIMonad = StateT BuildInfo Maybe + +data BuildInfo = BuildInfo { + biThingVersionMap :: ThingVersionMap, + biThingHashMap :: ThingHashMap, + biMaybeWays :: Maybe Ways + } + deriving Show + +type ThingMap = [(String, String)] +-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0") +type ThingVersionMap = ThingMap +-- Mapping from thing (e.g. "Cabal") to ABI hash +-- (e.g. "e1f7c380581d61d42b0360d440cc35ed") +type ThingHashMap = ThingMap +-- The list of ways in the order the build system uses them, e.g. +-- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files +type Ways = [String] + +emptyBuildInfo :: Maybe Ways -> BuildInfo +emptyBuildInfo mWays = BuildInfo { + biThingVersionMap = [], + biThingHashMap = [], + biMaybeWays = mWays + } + +addThingMap :: ThingMap -> String -> String -> Maybe ThingMap +addThingMap mapping thing str + = case lookup thing mapping of + Just str' -> + if str == str' + then Just mapping + else Nothing + Nothing -> + Just ((thing, str) : mapping) + +getMaybeWays :: BIMonad (Maybe Ways) +getMaybeWays = do st <- get + return $ biMaybeWays st + +haveThingVersion :: String -> String -> BIMonad () +haveThingVersion thing thingVersion + = do st <- get + case addThingMap (biThingVersionMap st) thing thingVersion of + Nothing -> fail "Inconsistent version" + Just tvm -> put $ st { biThingVersionMap = tvm } + +haveThingHash :: String -> String -> BIMonad () +haveThingHash thing thingHash + = do st <- get + case addThingMap (biThingHashMap st) thing thingHash of + Nothing -> fail "Inconsistent hash" + Just thm -> put $ st { biThingHashMap = thm } + diff --git a/distrib/compare/Change.hs b/distrib/compare/Change.hs new file mode 100644 index 00000000..a89517ce --- /dev/null +++ b/distrib/compare/Change.hs @@ -0,0 +1,43 @@ + +module Change where + +data FileChange = First Change + | Second Change + | Change Change + +data Change = DuplicateFile FilePath + | ExtraFile FilePath + | ExtraWay String + | ExtraThing String + | ThingVersionChanged String String String + | PermissionsChanged FilePath FilePath String String + | FileSizeChanged FilePath FilePath Integer Integer + +isSizeChange :: FileChange -> Bool +isSizeChange (Change (FileSizeChanged {})) = True +isSizeChange _ = False + +pprFileChange :: FileChange -> String +pprFileChange (First p) = "First " ++ pprChange p +pprFileChange (Second p) = "Second " ++ pprChange p +pprFileChange (Change p) = "Change " ++ pprChange p + +pprChange :: Change -> String +pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp +pprChange (ExtraFile fp) = "Extra file: " ++ show fp +pprChange (ExtraWay w) = "Extra way: " ++ show w +pprChange (ExtraThing t) = "Extra thing: " ++ show t +pprChange (ThingVersionChanged t v1 v2) + = "Version changed for " ++ show t ++ ":\n" + ++ " " ++ v1 ++ " -> " ++ v2 +pprChange (PermissionsChanged fp1 fp2 p1 p2) + = "Permissions changed:\n" + ++ " " ++ show fp1 + ++ " " ++ show fp2 + ++ " " ++ p1 ++ " -> " ++ p2 +pprChange (FileSizeChanged fp1 fp2 s1 s2) + = "Size changed:\n" + ++ " " ++ show fp1 ++ "\n" + ++ " " ++ show fp2 ++ "\n" + ++ " " ++ show s1 ++ " -> " ++ show s2 + diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs new file mode 100644 index 00000000..bf2a50ec --- /dev/null +++ b/distrib/compare/FilenameDescr.hs @@ -0,0 +1,61 @@ + +module FilenameDescr where + +import Data.Char +import Data.Either +import Data.List + +import BuildInfo +import Utils +import Tar + +-- We can't just compare plain filenames, because versions numbers of GHC +-- and the libraries will vary. So we use FilenameDescr instead, which +-- abstracts out the version numbers. +type FilenameDescr = [FilenameDescrBit] +data FilenameDescrBit = VersionOf String + | HashOf String + | FP String + | Ways + deriving (Show, Eq, Ord) + +normaliseDescr :: FilenameDescr -> FilenameDescr +normaliseDescr [] = [] +normaliseDescr [x] = [x] +normaliseDescr (FP x1 : FP x2 : xs) = normaliseDescr (FP (x1 ++ x2) : xs) +normaliseDescr (x : xs) = x : normaliseDescr xs + +-- Sanity check that the FilenameDescr matches the filename in the tar line +checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors +checkContent buildInfo (fd, tl) + = let fn = tlFileName tl + in case flattenFilenameDescr buildInfo fd of + Right fn' -> + if fn' == fn + then [] + else if all isAscii fn + then ["checkContent: Can't happen: filename mismatch: " + ++ show fn] + else [] -- Ugly kludge; don't worry too much if filepaths + -- containing non-ASCII chars have gone wrong + Left errs -> + errs + +flattenFilenameDescr :: BuildInfo -> FilenameDescr + -> Either Errors FilePath +flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of + ([], strs) -> Right (concat strs) + (errs, _) -> Left (concat errs) + where f (FP fp) = Right fp + f (VersionOf thing) + = case lookup thing (biThingVersionMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no version in mapping"] + f (HashOf thing) + = case lookup thing (biThingHashMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no hash in mapping"] + f Ways = case biMaybeWays buildInfo of + Just ways -> Right $ intercalate "-" ways + Nothing -> Left ["Can't happen: No ways, but Ways is used"] + diff --git a/distrib/compare/Makefile b/distrib/compare/Makefile new file mode 100644 index 00000000..49645783 --- /dev/null +++ b/distrib/compare/Makefile @@ -0,0 +1,12 @@ + +GHC = ghc + +compare: *.hs + "$(GHC)" -O -XHaskell2010 --make -Wall -Werror $@ + +.PHONY: clean +clean: + rm -f *.o + rm -f *.hi + rm -f compare compare.exe + diff --git a/distrib/compare/Tar.hs b/distrib/compare/Tar.hs new file mode 100644 index 00000000..50b238a9 --- /dev/null +++ b/distrib/compare/Tar.hs @@ -0,0 +1,58 @@ + +module Tar where + +import Data.Either +import Data.List +import System.Exit +import System.Process + +import Utils + +readTarLines :: FilePath -> IO [TarLine] +readTarLines fp + = do (ec, out, err) <- readProcessWithExitCode "tar" ["-jtvf", fp] "" + case (ec, err) of + (ExitSuccess, []) -> + case parseTarLines fp out of + Left errs -> die errs + Right tls -> return tls + _ -> + die ["Failed running tar -jtvf " ++ show fp, + "Exit code: " ++ show ec, + "Stderr: " ++ show err] + +parseTarLines :: FilePath -> String -> Either Errors [TarLine] +parseTarLines fp xs + = case partitionEithers (zipWith (parseTarLine fp) [1..] (lines xs)) of + ([], tls) -> Right tls + (errss, _) -> Left (intercalate [""] errss) + +data TarLine = TarLine { + tlPermissions :: String, + tlUser :: String, + tlGroup :: String, + tlSize :: Integer, + tlDateTime :: String, + tlFileName :: FilePath + } + +parseTarLine :: FilePath -> Int -> String -> Either Errors TarLine +parseTarLine fp line str + = case re "^([^ ]+) ([^ ]+)/([^ ]+) +([0-9]+) ([^ ]+ [^ ]+) ([^ ]+)$" + str of + Just [perms, user, grp, sizeStr, dateTime, filename] -> + case maybeRead sizeStr of + Just size -> + Right $ TarLine { + tlPermissions = perms, + tlUser = user, + tlGroup = grp, + tlSize = size, + tlDateTime = dateTime, + tlFileName = filename + } + _ -> error "Can't happen: Can't parse size" + _ -> + Left ["In " ++ show fp ++ ", at line " ++ show line, + "Tar line doesn't parse: " ++ show str] + diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs new file mode 100644 index 00000000..bc4fd204 --- /dev/null +++ b/distrib/compare/Utils.hs @@ -0,0 +1,44 @@ + +module Utils where + +import Data.Function +import Data.List +import System.Exit +import System.IO +import Text.Regex.PCRE + +die :: Errors -> IO a +die errs = do mapM_ (hPutStrLn stderr) errs + exitFailure + +warn :: Errors -> IO () +warn warnings = mapM_ (hPutStrLn stderr) warnings + +dieOnErrors :: Either Errors a -> IO a +dieOnErrors (Left errs) = die errs +dieOnErrors (Right x) = return x + +type Errors = [String] +type Warnings = [String] + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +re :: String -> String -> Maybe [String] +re r str = case matchM r' str :: Maybe (String, String, String, [String]) of + Just (_, _, _, ms) -> Just ms + Nothing -> Nothing + where r' = makeRegex r :: Regex + +unSepList :: Eq a => a -> [a] -> [[a]] +unSepList x xs = case break (x ==) xs of + (this, _ : xs') -> + this : unSepList x xs' + (this, []) -> + [this] + +sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst = sortBy (compare `on` fst) + diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs new file mode 100644 index 00000000..8653e3f6 --- /dev/null +++ b/distrib/compare/compare.hs @@ -0,0 +1,322 @@ +module Main (main) where + +import Control.Monad.State +import Data.Char +import Data.List +import System.Directory +import System.Environment +import System.FilePath + +import BuildInfo +import FilenameDescr +import Change +import Utils +import Tar + +-- TODO: +-- * Check installed trees too +-- * Check hashbangs + +sizeChangeThresholds :: [(Integer, -- Theshold only applies if one of + -- the files is at least this big + Integer)] -- Size changed if the larger file's + -- size is at least this %age of the + -- smaller file's size +sizeChangeThresholds = [( 1000, 150), + (50 * 1000, 110)] + +main :: IO () +main = do args <- getArgs + (ignoreSizeChanges, p1, p2) <- + case args of + [p1, p2] -> return (False, p1, p2) + ["--ignore-size-changes", p1, p2] -> return (True, p1, p2) + _ -> die ["Bad args. Need 2 filepaths."] + doFileOrDirectory ignoreSizeChanges p1 p2 + +doFileOrDirectory :: Bool -> FilePath -> FilePath -> IO () +doFileOrDirectory ignoreSizeChanges p1 p2 + = do b <- doesDirectoryExist p1 + let doit = if b then doDirectory else doFile + doit ignoreSizeChanges p1 p2 + +doDirectory :: Bool -> FilePath -> FilePath -> IO () +doDirectory ignoreSizeChanges p1 p2 + = do fs1 <- getDirectoryContents p1 + fs2 <- getDirectoryContents p2 + let isVersionChar c = isDigit c || c == '.' + mkFileInfo "." = return [] + mkFileInfo ".." = return [] + mkFileInfo fp@('g':'h':'c':'-':x:xs) + | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)] + | otherwise = die ["No version number in " ++ show fp] + mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp] + return [] + fss1' <- mapM mkFileInfo fs1 + fss2' <- mapM mkFileInfo fs2 + let fs1' = sort $ concat fss1' + fs2' = sort $ concat fss2' + + putBreak = putStrLn "==========" + extraFile d fp = do putBreak + putStrLn ("Extra file in " ++ show d + ++ ": " ++ show fp) + doFiles [] [] = do putBreak + putStrLn "Done." + doFiles ((_, fp) : xs) [] = do extraFile p1 fp + doFiles xs [] + doFiles [] ((_, fp) : ys) = do extraFile p2 fp + doFiles [] ys + doFiles xs@((fpc1, fp1) : xs') ys@((fpc2, fp2) : ys') + = do case fpc1 `compare` fpc2 of + EQ -> + do putBreak + putStrLn $ unwords ["Doing", show fp1, show fp2] + doFile ignoreSizeChanges (p1 fp1) + (p2 fp2) + doFiles xs' ys' + LT -> do extraFile p1 fp1 + doFiles xs' ys + GT -> do extraFile p2 fp2 + doFiles xs ys' + doFiles fs1' fs2' + +doFile :: Bool -> FilePath -> FilePath -> IO () +doFile ignoreSizeChanges bd1 bd2 + = do tls1 <- readTarLines bd1 + tls2 <- readTarLines bd2 + let mWays1 = findWays tls1 + mWays2 = findWays tls2 + wayDifferences <- case (mWays1, mWays2) of + (Nothing, Nothing) -> + return [] + (Just ways1, Just ways2) -> + return $ diffWays ways1 ways2 + _ -> + die ["One input has ways, but the other doesn't"] + (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1 + (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2 + let sortedContent1 = sortByFst content1 + sortedContent2 = sortByFst content2 + (nubProbs1, nubbedContent1) = nubContents sortedContent1 + (nubProbs2, nubbedContent2) = nubContents sortedContent2 + differences = compareContent mWays1 nubbedContent1 + mWays2 nubbedContent2 + allProbs = map First nubProbs1 ++ map Second nubProbs2 + ++ diffThingVersionMap tvm1 tvm2 + ++ wayDifferences + ++ differences + wantedProbs = if ignoreSizeChanges + then filter (not . isSizeChange) allProbs + else allProbs + mapM_ (putStrLn . pprFileChange) wantedProbs + +-- *nix bindists have ways. +-- Windows "bindists", install trees, and testsuites don't. +findWays :: [TarLine] -> Maybe Ways +findWays tls = msum $ map f tls + where f tl = case re regex (tlFileName tl) of + Just [dashedWays] -> Just (unSepList '-' dashedWays) + _ -> Nothing + regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" + +diffWays :: Ways -> Ways -> [FileChange] +diffWays ws1 ws2 = f (sort ws1) (sort ws2) + where f [] [] = [] + f xs [] = map (First . ExtraWay) xs + f [] ys = map (Second . ExtraWay) ys + f xs@(x : xs') ys@(y : ys') + = case x `compare` y of + LT -> First (ExtraWay x) : f xs' ys + GT -> Second (ExtraWay y) : f xs ys' + EQ -> f xs' ys' + +diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange] +diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) + where f [] [] = [] + f xs [] = map (First . ExtraThing . fst) xs + f [] ys = map (Second . ExtraThing . fst) ys + f xs@((xt, xv) : xs') ys@((yt, yv) : ys') + = case xt `compare` yt of + LT -> First (ExtraThing xt) : f xs' ys + GT -> Second (ExtraThing yt) : f xs ys' + EQ -> let this = if xv == yv + then [] + else [Change (ThingVersionChanged xt xv yv)] + in this ++ f xs' ys' + +mkContents :: Maybe Ways -> [TarLine] + -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) +mkContents mWays tls + = case runStateT (mapM f tls) (emptyBuildInfo mWays) of + Nothing -> Left ["Can't happen: mkContents: Nothing"] + Just (xs, finalBuildInfo) -> + case concat $ map (checkContent finalBuildInfo) xs of + [] -> Right (xs, biThingVersionMap finalBuildInfo) + errs -> Left errs + where f tl = do fnd <- mkFilePathDescr (tlFileName tl) + return (fnd, tl) + +nubContents :: [(FilenameDescr, TarLine)] + -> ([Change], [(FilenameDescr, TarLine)]) +nubContents [] = ([], []) +nubContents [x] = ([], [x]) +nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) + | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs') + | otherwise = (ps, x1 : xs') + where (ps, xs') = nubContents xs + +mkFilePathDescr :: FilePath -> BIMonad FilenameDescr +mkFilePathDescr fp + | Just [ghcVersion, _, middle, filename] + <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp + = do haveThingVersion "ghc" ghcVersion + middle' <- mkMiddleDescr middle + filename' <- mkFileNameDescr filename + let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename' + return $ normaliseDescr fd + | otherwise = return [FP fp] + +mkMiddleDescr :: FilePath -> BIMonad FilenameDescr +mkMiddleDescr middle + -- haddock docs in a Windows installed tree + | Just [thing, thingVersion, _, src] + <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/doc/html/libraries/", + FP thing, FP "-", VersionOf thing, FP src] + `mplus` unchanged + -- libraries in a Windows installed tree + | Just [thing, thingVersion, _, rest] + <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest] + `mplus` unchanged + -- Windows in-tree gcc + | Just [prefix, _, _, gccVersion, _, rest] + <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion "gcc" gccVersion + return [FP prefix, VersionOf "gcc", FP rest] + `mplus` unchanged + | otherwise = unchanged + where unchanged = return [FP middle] + +mkFileNameDescr :: FilePath -> BIMonad FilenameDescr +mkFileNameDescr filename + | Just [prog, ghcVersion, _, exe] + <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$") + filename + = do haveThingVersion "ghc" ghcVersion + return [FP prog, FP "-", VersionOf "ghc", FP exe] + `mplus` unchanged + | Just [thing, thingVersion, _, ghcVersion, _, soDll] + <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" ghcVersion + haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP "-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [way, thingVersion, _, soDll] + <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", + FP ".", FP soDll] + `mplus` unchanged + | Just [thingVersion, _, soDll] + <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [thing, thingVersion, _, way] + <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") + filename + = do haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP way, FP ".a"] + `mplus` unchanged + | Just [thing, thingVersion, _] + <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") + filename + = do haveThingVersion thing thingVersion + return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] + `mplus` unchanged + | Just [thing, thingVersion, _, thingHash] + <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$") + filename + = do haveThingVersion thing thingVersion + haveThingHash thing thingHash + return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing, + FP ".conf"] + `mplus` unchanged + | Just [thingVersion, _] + <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$") + filename + = do haveThingVersion "gcc" thingVersion + return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"] + `mplus` unchanged + | Just [dashedWays, depType] + <- re "^\\.depend-(.*)\\.(haskell|c_asm)" + filename + = do mWays <- getMaybeWays + if Just (unSepList '-' dashedWays) == mWays + then return [FP ".depend-", Ways, FP ".", FP depType] + else unchanged + | otherwise = unchanged + where unchanged = return [FP filename] + +compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] + -> Maybe Ways -> [(FilenameDescr, TarLine)] + -> [FileChange] +compareContent mWays1 xs1all mWays2 xs2all + = f xs1all xs2all + where f [] [] = [] + f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs + f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys + f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') + = case fd1 `compare` fd2 of + EQ -> map Change (compareTarLine tl1 tl2) + ++ f xs1' xs2' + LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1) + ++ f xs1' xs2 + GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2) + ++ f xs1 xs2' + mkExtraFile mWaysMe mWaysThem mkFileChange filename + = case (findFileWay filename, mWaysMe, mWaysThem) of + (Just way, Just waysMe, Just waysThem) + | (way `elem` waysMe) && not (way `elem` waysThem) -> [] + _ -> [mkFileChange (ExtraFile filename)] + +findFileWay :: FilePath -> Maybe String +findFileWay fp + | Just [way] <- re "\\.([a-z_]+)_hi$" fp + = Just way + | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp + = Just way + | otherwise = Nothing + +compareTarLine :: TarLine -> TarLine -> [Change] +compareTarLine tl1 tl2 + = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] + ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ] + where fn1 = tlFileName tl1 + fn2 = tlFileName tl2 + perms1 = tlPermissions tl1 + perms2 = tlPermissions tl2 + size1 = tlSize tl1 + size2 = tlSize tl2 + sizeMin = size1 `min` size2 + sizeMax = size1 `max` size2 + sizeChanged = any sizeChangeThresholdReached sizeChangeThresholds + sizeChangeThresholdReached (reqSize, percentage) + = (sizeMax >= reqSize) + && (((100 * sizeMax) `div` sizeMin) >= percentage) + +versionRE :: String +versionRE = "([0-9]+(\\.[0-9]+)*)" + diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in new file mode 100644 index 00000000..f1abd916 --- /dev/null +++ b/distrib/configure.ac.in @@ -0,0 +1,175 @@ +dnl +dnl Binary distribution configure script +dnl +#!/bin/sh +# + +AC_INIT([The Glorious Glasgow Haskell Compilation System], [@ProjectVersion@], [glasgow-haskell-bugs@haskell.org], [ghc]) + +FP_BINDIST_GHC_PWD +FP_FIND_ROOT + +dnl-------------------------------------------------------------------- +dnl * Deal with arguments telling us gmp is somewhere odd +dnl-------------------------------------------------------------------- + +FP_GMP + +bootstrap_target=@TargetPlatform@ +FPTOOLS_SET_PLATFORM_VARS + +# ToDo: if Stage1Only=YES, should be YES +CrossCompiling=NO +CrossCompilePrefix="" +TargetPlatformFull="${target}" + +AC_SUBST(CrossCompiling) +AC_SUBST(CrossCompilePrefix) +AC_SUBST(TargetPlatformFull) + +Unregisterised="@Unregisterised@" +AC_SUBST(Unregisterised) + +# +dnl ** Check Perl installation ** +# +AC_PATH_PROG(PerlCmd,perl) +if test -z "$PerlCmd"; then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 +fi + +# +dnl ** figure out how to do a BSD-ish install ** +# +AC_PROG_INSTALL + +# +dnl ** how to do symlinks ** +# +AC_PROG_LN_S() + +# +dnl ** Find the path to sed ** +# +AC_PATH_PROG(SedCmd,gsed sed,sed) + +XCODE_VERSION() + +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +FIND_GCC([WhatGccIsCalled], [gcc], [gcc]) +CC="$WhatGccIsCalled" +export CC + +# --with-hs-cpp/--with-hs-cpp-flags +FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs) +AC_SUBST([HaskellCPPCmd]) +AC_SUBST([HaskellCPPArgs]) + +# Here is where we re-target which specific version of the LLVM +# tools we are looking for. In the past, GHC supported a number of +# versions of LLVM simultaneously, but that stopped working around +# 3.5/3.6 release of LLVM. +LlvmVersion=@LlvmVersion@ + +dnl ** Which LLVM llc to use? +dnl -------------------------------------------------------------- +FIND_LLVM_PROG([LLC], [llc], [llc], [$LlvmVersion]) +LlcCmd="$LLC" +AC_SUBST([LlcCmd]) + +dnl ** Which LLVM opt to use? +dnl -------------------------------------------------------------- +FIND_LLVM_PROG([OPT], [opt], [opt], [$LlvmVersion]) +OptCmd="$OPT" +AC_SUBST([OptCmd]) + +dnl ** Which ld to use? +dnl -------------------------------------------------------------- +FIND_LD([LdCmd]) +AC_SUBST([LdCmd]) + +FP_GCC_VERSION +AC_PROG_CPP + +FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID +FP_PROG_LD_NO_COMPACT_UNWIND +FP_PROG_LD_FILELIST + +# +dnl ** Check gcc version and flags we need to pass it ** +# +FP_GCC_EXTRA_FLAGS + +FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) +FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) +FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) +# Stage 3 won't be supported by cross-compilation +FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) + +AC_SUBST(CONF_CC_OPTS_STAGE0) +AC_SUBST(CONF_CC_OPTS_STAGE1) +AC_SUBST(CONF_CC_OPTS_STAGE2) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE0) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE1) +AC_SUBST(CONF_GCC_LINKER_OPTS_STAGE2) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE0) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE1) +AC_SUBST(CONF_LD_LINKER_OPTS_STAGE2) +AC_SUBST(CONF_CPP_OPTS_STAGE0) +AC_SUBST(CONF_CPP_OPTS_STAGE1) +AC_SUBST(CONF_CPP_OPTS_STAGE2) + +dnl ** Set up the variables for the platform in the settings file. +dnl May need to use gcc to find platform details. +dnl -------------------------------------------------------------- +FPTOOLS_SET_HASKELL_PLATFORM_VARS + +dnl WordSize for settings.in +AC_CHECK_SIZEOF(void *, 4) +WordSize=$ac_cv_sizeof_void_p +AC_SUBST(WordSize) + +# +dnl ** how to invoke `ar' and `ranlib' +# +FP_PROG_AR_SUPPORTS_ATFILE +FP_PROG_AR_NEEDS_RANLIB + +dnl ** Which readelf to use? +dnl -------------------------------------------------------------- +FIND_READELF([ReadElfCmd]) +AC_SUBST([ReadElfCmd]) + +FP_SETTINGS + +# +AC_CONFIG_FILES(settings mk/config.mk mk/install.mk) +AC_OUTPUT + +# We get caught by +# http://savannah.gnu.org/bugs/index.php?1516 +# $(eval ...) inside conditionals causes errors +# with make 3.80, so warn the user if it looks like they're about to +# try to use it. +# We would use "grep -q" here, but Solaris's grep doesn't support it. +checkMake380() { + if $1 --version 2>&1 | head -1 | grep 'GNU Make 3\.80' > /dev/null + then + echo + echo "WARNING: It looks like \"$1\" is GNU make 3.80." + echo "This version cannot be used to build GHC." + echo "Please use GNU make >= 3.81." + fi +} + +checkMake380 make +checkMake380 gmake + +echo "****************************************************" +echo "Configuration done, ready to 'make install'" +echo "(see README and INSTALL files for more info.)" +echo "****************************************************" diff --git a/distrib/cross-port b/distrib/cross-port new file mode 100644 index 00000000..7c54604a --- /dev/null +++ b/distrib/cross-port @@ -0,0 +1,77 @@ +#!/usr/bin/env bash + +# This script can be used to generate some unregisterised .hc files +# for bootstrapping GHC on a new/unsupported platform. It involves a +# two-stage bootstrap: the first stage builds an unregisterised set of +# libraries & RTS, and the second stage builds an unregisterised +# compiler. + +# Take the .hc files from the libraries of stage 1, and the compiler +# of stage 2, to the target system and bootstrap from these to get a +# working (unregisterised) compiler. + +set -e + +base=`pwd` + +# set this to the location of your source tree +fptools_dir=$HOME/fptools + +if [ ! -f b1-stamp ]; then + mkdir b1 + cd b1 + lndir $fptools_dir + cd .. + + cd b1 + ./configure + + # For cross-compilation, at this stage you may want to set up a source + # tree on the target machine, run the configure script there, and bring + # the resulting mk/config.h file back into this tree before building + # the libraries. + + touch mk/build.mk + echo "GhcUnregisterised = YES" >> mk/build.mk + echo "GhcLibHcOpts = -O -H32m -fvia-C -keep-hc-files" >> mk/build.mk + echo "GhcLibWays =" >> mk/build.mk + echo "SplitObjs = NO" >> mk/build.mk + + # We could optimise slightly by not building hslibs here. Also, building + # the RTS is not necessary (and might not be desirable if we're using + # a config.h from the target system). + make stage1 + + cd .. + + touch b1-stamp +fi + +# exit 0 + +if [ ! -f b2-stamp ]; then + mkdir b2 + cd b2 + lndir $fptools_dir + cd .. + + cd b2 + ./configure --with-ghc=$base/b1/ghc/compiler/stage1/ghc-inplace + + touch mk/build.mk + # The bootstrapped compiler should probably generate unregisterised + # code too. If you don't want it to, then comment out this line: + echo "GhcUnregisterised = YES" >> mk/build.mk + echo "SRC_HC_OPTS += -keep-hc-file -fvia-C" >> mk/build.mk + echo "GhcWithNativeCodeGen = NO" >> mk/build.mk + echo "GhcWithInterpreter = NO" >> mk/build.mk + + # we just need to build the compiler and utils... + (cd glafp-utils && make boot && make) + (cd ghc && make boot) + (cd ghc/utils && make) + (cd ghc/compiler && make stage=1) + cd .. + + touch b2-stamp +fi diff --git a/distrib/hc-build b/distrib/hc-build new file mode 100644 index 00000000..43133f83 --- /dev/null +++ b/distrib/hc-build @@ -0,0 +1,114 @@ +#!/bin/sh -e + +# Manuel M. T. Chakravarty , June 2000 +# Updated for GHC 5.00, Simon Marlow, March 2001 +# Updated for GHC 5.04.3, Urban Boquist, March 2003 +# +# Script to build GHC from .hc files (must be run in the fptools/ root +# directory into which the source and .hc files must already have been +# unpacked). All options are passed through to ./configure (especially +# useful with --prefix). + +configopts="$*" # e.g., --enable-hc-boot-unregisterised +PWD=`pwd` + +# check for GNU make +# +MAKENAMES="gmake make no-make" +for make in $MAKENAMES; do + MAKE=$make + $make --version 2>&1 | grep "GNU Make" >/dev/null && break +done +if [ $MAKE = no-make ]; then + echo "Fatal error: Cannot find the GNU make utility" + exit 1 +fi + +# build configuration +# +case "$configopts" in +*--enable-hc-boot-unregisterised*) +cat >>mk/build.mk <>mk/build.mk <|EBp^BJbFZeN_AvSv6L(@skPhnF&loJb;9EvdPKiiuX!yqoLfAaD0cGD z%Sg?u8vfwh+*kdR7G{slEa8X=D}5v7V{<10qp=jjnb&;gvoDdF&AhVyR>PfYDD;GF=I_U9#l z+5P(f_>y+5AZ=om@s@b$;`u9l7Vdn~nU{)J9CmOv*if6;SzrXT?@#L}HJW`)Og}*n z4Q+V#dj|VmGuAg8j_IJ#eUHNd_rpwU*pf{jr<3k!L$Nh)xI5qts5n74+%p?Iiw^h9 z65Nt*`kt9>+a(SacE_pH&nR8FgEKQ;#73PyGn*MEsmD<=3xAEnK@ESQ4+phr3mlo< z#qDAsN9Pq+UJ+13_(5#x)QeUlQW~$E%4Xo*|^mBA&6_4VB7qqnVGrV?dZKtKR z@_PqoB&}PW9ovK+KKkRt>@OG*K7uXwj`%A^Y%1VqTR=(JLUM6`lf?UHAROG;nS+!FT;X|ARU_McrP4 VkHK*Xu%4UX55c#=_ragQe*jr#xo-df literal 0 HcmV?d00001 diff --git a/distrib/mkDocs/mkDocs b/distrib/mkDocs/mkDocs new file mode 100755 index 00000000..472bbe93 --- /dev/null +++ b/distrib/mkDocs/mkDocs @@ -0,0 +1,47 @@ +#!/bin/sh + +set -e + +die () { + echo "$1" >&2 + exit 1 +} + +NO_CLEAN=0 +if [ "$1" = "--no-clean" ] +then + NO_CLEAN=1 + shift +fi +[ "$#" -eq 2 ] || die "Bad args. Usage: $0 [--no-clean] " + +LINUX_BINDIST=`realpath "$1"` +WINDOWS_BINDIST=`realpath "$2"` + +mkdir docs +cd docs +INST=`pwd`/inst +tar -jxf "$LINUX_BINDIST" +mv ghc* linux +cd linux +./configure --prefix="$INST" +make install +cd .. +[ "$NO_CLEAN" -eq 0 ] && rm -r linux +tar -jxf "$WINDOWS_BINDIST" +mv ghc* windows +cd inst/share/doc/ghc/html/libraries +mv ../../../../../../windows/doc/html/libraries/Win32-* . +sh gen_contents_index +cd .. +for i in haddock libraries users_guide +do + tar -jcf ../../../../../$i.html.tar.bz2 $i +done +mv index.html ../../../../.. +cd .. +mv *.pdf *.ps ../../../.. +cd ../../../.. +[ "$NO_CLEAN" -eq 0 ] && rm -r inst +[ "$NO_CLEAN" -eq 0 ] && rm -r windows + diff --git a/distrib/remilestoning.pl b/distrib/remilestoning.pl new file mode 100644 index 00000000..60a23af5 --- /dev/null +++ b/distrib/remilestoning.pl @@ -0,0 +1,119 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use DBI; + +# ===== Config: + +my $dbfile = "trac.db"; +my $milestone = "7.4.1"; +my $test = 0; + +# ===== Code: + +my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","", {}); + +my %emailof; +my %ticketsfor; + +sub getUserAddress { + my $sth = $dbh->prepare("SELECT sid, value FROM session_attribute WHERE name = 'email'"); + $sth->execute(); + while (my $result = $sth->fetchrow_hashref("NAME_lc")) { + my $username = $result->{sid}; + my $email = $result->{value}; + if (defined($emailof{$username})) { + die "Two e-mail addresses found for $username"; + } + if ($email =~ /@/) { + $emailof{$username} = $email; + } + else { + # warn "The e-mail address $email for $username contains no @"; + } + } + $sth->finish; +} + +sub doTickets { + my $sth = $dbh->prepare("SELECT id, summary, reporter, cc FROM ticket WHERE milestone = ? AND status = 'new'"); + $sth->execute($milestone); + while (my $result = $sth->fetchrow_hashref("NAME_lc")) { + my $ticket = $result->{id}; + my $title = $result->{summary}; + my $reporter = $result->{reporter}; + my $cc = $result->{cc}; + my %addresses; + my $address_added; + for my $who ($reporter, split /[ ,]+/, $cc) { + $address_added = 0; + if ($who =~ /@/) { + $addresses{$who} = 1; + $address_added = 1; + } + if (defined($emailof{$who})) { + $addresses{$emailof{$who}} = 1; + $address_added = 1; + } + if ($who ne "nobody" && $address_added eq 0) { + # warn "No address found for $who"; + } + } + for my $address (keys(%addresses)) { + $ticketsfor{$address}{$ticket}{"title"} = $title; + } + } + $sth->finish; +} + +sub doEmails { + for my $email (sort (keys %ticketsfor)) { + if ($test ne 0) { + open FH, ">&STDOUT"; + } + else { + open(FH, '|-', 'mail', '-s', 'GHC bugs', '-a', 'From: glasgow-haskell-bugs@haskell.org', $email) or die "Running mail failed: $!"; + } + print FH <<'EOF'; + +Hello, + +You are receiving this mail because you are the reporter, or on the CC +list, for one or more GHC tickets that are automatically having their +priority reduced due to our post-release ticket handling policy: + http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/BugTracker#Remilestoningticketsafterarelease + +The list of tickets for which you are the reporter or on the CC list is +given below. If any of these are causing problems for you, please let us +know on glasgow-haskell-bugs@haskell.org and we'll look at raising the +priority. + +Better still, if you are able to make any progress on any of the tickets +yourself (whether that be actually fixing the bug, or just making it +easier for someone else to - for example, by making a small, +self-contained test-case), then that would be a great help. We at GHC HQ +have limited resources, so if anything is waiting for us to make +progress then it can be waiting a long time! +EOF + for my $ticket (sort {$a <=> $b} (keys %{$ticketsfor{$email}})) { + my $title = $ticketsfor{$email}{$ticket}{"title"}; + print FH "\n"; + print FH "#$ticket $title:\n"; + print FH " http://ghc.haskell.org/trac/ghc/ticket/$ticket\n"; + } + print FH <<'EOF'; + +-- +The GHC Team +http://www.haskell.org/ghc/ +EOF + close FH or die "Close failed: $!"; + } +} + +&getUserAddress(); +&doTickets(); +&doEmails(); + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 00000000..670fdd9f --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,4 @@ +dir = docs +TOP = .. +include $(TOP)/mk/sub-makefile.mk + diff --git a/docs/backpack/.gitignore b/docs/backpack/.gitignore new file mode 100644 index 00000000..c3eb46ec --- /dev/null +++ b/docs/backpack/.gitignore @@ -0,0 +1,10 @@ +*.aux +*.bak +*.bbl +*.blg +*.dvi +*.fdb_latexmk +*.fls +*.log +*.synctex.gz +backpack-impl.pdf diff --git a/docs/backpack/Makefile b/docs/backpack/Makefile new file mode 100644 index 00000000..641889bc --- /dev/null +++ b/docs/backpack/Makefile @@ -0,0 +1,7 @@ +all: backpack-impl.pdf backpack-manual.pdf + +backpack-impl.pdf: backpack-impl.tex + latexmk -pdf -latexoption=-halt-on-error -latexoption=-file-line-error -latexoption=-synctex=1 backpack-impl.tex && touch paper.dvi || ! rm -f $@ + +backpack-manual.pdf: backpack-manual.tex + latexmk -pdf -latexoption=-halt-on-error -latexoption=-file-line-error -latexoption=-synctex=1 backpack-manual.tex && touch paper.dvi || ! rm -f $@ diff --git a/docs/backpack/arch.png b/docs/backpack/arch.png new file mode 100644 index 0000000000000000000000000000000000000000..d8b8fd21f9ecb730060c08f05e47d72a18e1a458 GIT binary patch literal 107562 zcmX_o2RxSR|Nmp}viDYYRtVXlLWLAcw$eh#$SyK7ilU@EC0bSsS=k|36_F58*(3`6 z-*@Nx`@c?|(?QR3KlgQApU-=J?l_CRJ6Ra{8A&7(%kEu9RwNP?6^TTdO;3xjtUPWa zzCr6^w$q68m-y#)W!@Ehg~5B5oiB;B(V6&7k*}9`9ABjK+r7t_ZjhFpb1To9)InAf zNtCqP$iO=A`?#dwgL4QH@EtJ736BFLqO-e!wwXz&&~R+|I{YSh-%&CPw;*{LWe zC-=EuRarSQE{>t)n&L(?GqavYb{y~Dzt6XOBKf`N{so`07Rx#gM{2HlNu&Q>FZ`~R zjORdUWOv>^2~km!fq}s;Q`6t%CX4%4n>Dnw$a`+6dweJm!e8FOb5ZnvpMtF6lqiOu z?tkIcl(Qqo=&0^zN_BPhiSE3OzkkgnUspTXMI*6`@4rth&A54}IaR{8$caK&J22(s z5hf<4o`NF+?;af3@$AIA*-rtVa}1*y2S#`9-_Oz5*l1y66O)r8<~V~(+O=;VUCL>n zO{!bY{ax1)7Z+z`V~gZbbQtQqvvZfZx%D~b6DLmaYIuu&ZNHhouXdt?X4C(FTl$T{ z+BLn!u57HVqBi&L+_}KL<aVPyZ%SfrRgp24qIE^^A|3h`PQ{LOVgKj zU$(Zv-ZOi4?xZujD*sBcdXo|?T88SsC0%j$==9s-FXt~>Q~2KmX!?;y}ID%%M zSRPp3p~d%OzQ22Tt<-n-zI{7icz!B1w0L&nfOh!0;Pva*{c`?$GgB3-`_}DwL5B|U zTkYR(9JG7)?iABp#us9X4&oBZ%50gLnIW2Ta!d>i3}h`nKE7SMcfbC1X6*SEvAMZ9 zi={F)VVm~QO;S=j#8XHA2)ggu#9mrn?(%18%5MkTYIgqN7YYtlAq*s?ty}9py$qPc z7D(^)Wn^O7G4=7;%GQzb@fcy9a~%zmx=iu<=B(~1Jw4VF6BC>sl~13lM!SFe_HB9b z+m){5B9&X8a4F*3&KXi9D_>k*4$N)3l9F;;b>x`mc^^|#Mimtm&S{AkzVZqNnhFX@ zo-Hm;SR0StBC)WQF`g65l!u?68jg>+ex1LfveN9SIEnP`q0P=@VV$8LKbT0RAuB3a zd1CRUr6eS%9v^$cYJ$^4|YmXngTocWKaqWW;3lYEhBWi8S`as;Vlhfb-?$M?G1G zjf|-G$(<9XKc5y!S#su!N!u+wk#pzHNjp}p^7I$pyC=E0xLB3x-@NCxv_h4U#kH() zjlfwa)lb8G{V=lv$C>Cq^no2s#2PW zZr#d(4Np#Dwabf$k7xY7G?l<2pg#2aid4Q$p>V{crHWnDXD{X3A6^E`bUZn>Z=lR~ zXPO8*`}y*-Ke~*i=2w<3R@A@~*6%`dqVXJ}G`4$wvfBz1d?&-O|zu0$t@9OfG z$uM@~kw%SI%H_p%PfpGMeq(xGDJ8^qNa0Wm%A%jDpWX z`F!r{)?jnXCnrBB7@3$*Mp$iB$z>UyRc2vkzst<(9<6ouySKY&UYXnDL(iO!A7>B} z5?cQAr|#1yp_#!-DiSpvo$LJQ>kQpcE!?A_$;m|2iMpplwD+K&^Ol0~SRg;C_KXya}9yaNJaaE#QD{tm3QFbL3&2U+Na06i-Lc7S~4?-hlk^;sG8LcP7YRRUROPS zUiQF)n%Y`Q^ok3anRW##J4{Sy(I-x!30;zO6@{#@lc9K0A4>xt^YcrpqQQ zyur)MtL$fb(4ZBkc9AHrfPibqZG#MDS6W${g2cL*jSDJ$^b`i8JO@skAE2o(xkvx# z&@;vj8#c_&&85n{^ciEkXP$W;J;`}-qBD2;PfIk1>!@9;s+UnJL zrq#8zxuvPYkL;e%rpwvTrkwt|NkUb1@rLr+W>eZ8E>lYJ@sH0=4s83i_UBh;t{G2i z^%>{G_SIoG3)E2YES+ds_@nSPB+~lo!anm1r5xL|$VZRlcja2~uSggTw(D+NkHU%z z3JDEQOvI|4d@ri4Er?$8>gM)<*@;dGBO@bxW%bGUDxZKrU2`)%T6M>}cgE3-Tuw)i zUX16GBU|N~78Ms8{QUmT@{Y+R`y)&r@+~jqZDwZ>mylSDJhrdm!|p?_VAHPcG96H zM|q|){ZOjy>SD*i_xAPW7;9>3LWAXIkE4G5`nAuG;~pM0&CRiL6vp=_P|HNIqe!e= zT*fUVgBE>f)^F{4B#?ripQ@ms;KZ19{oUML=jnkm zdIpBbygaFaPoJur!wQeQl(aIsr5EmSH}W#43>7EU1y)*qd4&aKSJyB05@&d%jvhT~ z&&NtTC=pw6Ta$`0W!EP0E$hBXw9L1h+DXXcPJPx1X^!=Jg$OZed9L(%*5 z_U45DT`vuoaY(J&xrW`by5d__a$}oU{MG&Y_m>GYji9`cpSm7B+SsirwVeZZ-_b&U z;K{L#j~+czIx}J^#7`?8YW=yEQ(gHHX=PcQ!{tS)kCh_?z?q^Ft1uA2N@ zUETa#CurWyZ|Wl#S_l2cjXdcx-=DSF#iUV?^VtS@axMFKuG6Hd=%=X6rl&;$XT9p~ z-hbSy+*-B)_;PNffvHR-&ggvg`fnywx%1J{G$%e3ToT)HacFt&i=!&P&y%BXj9SrQ za!>AQsjVp_6Stjr%6z$1SH(Qe_z9IA|?M+ zPrjwnwrxB*zQ!^Y0OQhz8pm#{%2M6CcTZagn}sJ!)cv*+{hO$HIZ@M1?B>^1IG4G#4^Io4a|E0uNgrt`^@ z2}46e+R0)7S17PeIK4&Ab+nr#CBv4=UYvMm`ZQ!^eyq@6h`>+b;eW;FUO!4K(NM9t z+!ht}A#8PdF5kA;rFgpVc=tVW@^Q3-Yo3M%Z+A0NWs%~Bcq81}s&k9@X zOjcxmzBE8*q@v?Xe-@O8sFyFdHzx93K#NEe+RlyFyLu!4<+-2V?Hzr9rOw~EBQgEC zy6|Z`5WVxUV|2%k9g{y&>5iXz=E`+8L~zp$yf&Te@3PtSoJD6&EhD2#`;HC@6aJ zgySc@*(Ub33}vdZ)@wU&sGsIMcS^eXndH_SuZ=m5vjddWTwF;>N#X(J@spnt&I7&O z*%7m0q9ccDX|iwOK))?7?|o^m8QkgkC{5$$kh@evsWl0V@oE<5c(-{9HYN!rpjyG#hZ{=vp!fOKl}p}u@)Exqv7ecFmGnK2IFIV{ z@bD14A$Vyr5;uWoU}R(j-Sbh0xwyPMGYUQW+vWWh_D7DeadY2WEbZ>@F2?yY&s3oy zN_3K-rZ{6?JMWbr@8skYm6w12c4I&iJ%T3K1m;;h9_ z|18{nhT+YYLr;f}yMH}W8(U;NwHB2Y*>z!(?{!N{Ej|RJHrejuOx$_u0}@0_x8UpO z=%`5%+p#>_{S6|zi6A%e-$54{B}@{BT7j6C$8UvufA5ib zboj+y>laE@*IUV%7VUq=Pfq>16~6vTBz!dzTjmRnKI7@YJ?7?tT9T4q69fX2GMR z?Cfl5z0I3x5|y(w&QRjB*8p93|9HP8x4#VR_9ypJ*lCskgWHHt<`9c96=^whRiKMPSdJ(}Vd|xs3a& z!`6N$2s#381!;+klbc_JPkmI&_V@8&zf>Q}5_ONm_}e4>iIX~d5>#%IM$)b=X)@%v zX|#}w2??#oeueQ!Ql8nppVq@IVp&jn!j?^z3N^4aa8CSadsZA;#%xX-&UFrO|HMGq zR&~z-dT11y!{)sLnO9J;oKb{hFI_SQb4wD|iN_kUk!AtY5~!K%ynfe2QWd*2FrpFC zCn{stxvsCSkRk-OdB&1Mfi1|`@k&ZcHK`IiN6*c<=`e#gkyrEf-EzTImWHiqz3m5O zCXlz!=q}4ow{MI3{dm7;ky2evZA^k6XyD<&$Luo7pi#?HFFuzRDROeEsj3zc?Q(b1 zcr7mn%eI{+CSm^ead+=->Rh|*SW;4wl9FOE`pXlIyg-bs4`Bf%~(>yUdH{@vEvgq3) zOD2<*PJdJt-0she2ISFKviTx2-+3GxS?2GXRgZCA*W%_L{$tozkv)<%yQ@Y2n*pQ~ z(AMZHS2zGes7M+?^P6zGE&|%swYMuc_Om64^ECbWby7m`lG(0Z`sdD-dyFQF`f$X? z3Qm4}mO$Y|%BZXijeLIQ&(i6yXa+AN{(xl{SEJoOd9m$8k95@~hstxxjl98Yzt#3z zS`M#JP*9N1UR5~K(#pThvyInPUQRBd@8ie$RWz9rw62A-X!+s+ZK(O$Wz|sr@!K*MxM=rET84xtNBDJ9Zw_cC5Y9z4fZkAKR*spqxTq z6O)UzUlgaRfr%CtQLLGI{Lu$o2=X>{{l<+axUOO_iDKY?S$nUcn#hW(2M=UVLgo4K z@tItAM+fU^DP`qU=1j@RXf6+!Q7A7| zQ&Z~$OV6~HedD_}{`OYFpdNeN-JWO3MW=y)zugm?r;(vz1jZ5w&o~6mlz;k2nNPH) zhDLK}2Dr!{yZ*VKKe-ruRU*x=9y@+q=EdH<2C`~u>9{PjMU{#(UoLvw1h{(t^!WbH z;tjk?5!XIEIAE4@8|vA{gT*e!sY7CDefyriy&|=5z62u6Q5TomR#Yh20AYLxo~c#{ z3GPRaa{tx}|GjwMT$Uj_0u0`=Rr~DRu{(K zZr!qFi-UUjdWb^Q_ix|kR*60EN29x|%N7MD11D^kH*x;A16f%O52MmoRDpq|Ry$5k zPA)IKy}A9`cvEQW)h(ycNFD*Ro&x5Xoa%pJ`s4G<0L2d{OF(nW&Vt|sl|d=3om%?- z&TM$;&3mEj3xHE-k z06^{E)DMy?wN*`xODCUzI}dr-*j_#N{L}(jul3%(TkT-KalIA-B%>9SZ;2mP!6& zYG;QI78r(I5Lk8N#^I{uvw%`%4ljW!O6WEUH$RpNc@Juxu(~$#<40>-TbnI@v=<;V zGa-TLW$2&h_LYZUcoq{1nb3=*qzyL!fy1k!2C702_pImby~%#o1Z;PQr;vzUfW>jl8bVb;_RKiH?po%#l@4*lWE{y5luE0@pjRA{p-7*8ct*x~D$#qBhAZ zDW$9|FBj#ST`PfFRAO?8KQ1l2Z=bPobWmVm5pjPZPd|ZNN*vAC?+)1590LV9uzaeS zHOcdHnQvatvxfx*3VPM(1m&HvAqKv*@!swFo`L7i)xLhsa8v7SEuaX6+skIZvuC59 zKUcqe<;vWbWWABu;X1~t(rAubL@lUbRP!3N_Y}fSBt&g!&O_=SYKPpR6CMnF^zq|I z^6L;~W#v-;DSr7aTh0Kmqza8YhOb563i}NK)T2Wb)S3eNDjG%&nso=Dk9O#9Yt=$A zDWHI;Yu9*4LpULjUn@TSn*Nl4y^-+!&&rCJtn7mhihQ4sznkjoV=F$S9gO0b>pj-a zS9<0Pt)Zdea#j+-_^`x*kj@JntCJuf%xCaHFZJc~s~VH_$jaJF>dT1Ff= zDp%&W**ZHsJfuPShQ57^Lt&sKg@lBlk0t#6`Qr|%5Ydjx{ikGouE~B`U0KjRQedwM zsW%}cfsTge)vH$&D8wd^dbvIpOG!yd;EX_#G=9HcdG4oSp+lwj%%G0v4?$=cID8IL zz&4e^zZ$VzoFA79p^n%T*hk*FC4zkwn2AHn%*>pUmPQR;XLd~?$Ln)dNY$lN?d>R~ za~~YT#iXTosm6$@s&am5yhN2UCAG#i*i_@P3J`_6g?5W)b zU=79MR+=ET`?#n9Z@0nwLF1pyUjy1nt^{AM0b(Rdb!Vu>!-HEgZrr#7V}krTGrps{ zn`3JK^G6RK9(H;;1?8#!KMeum*$!)K&cCQpI;hxeA|lCP-?$sCZ}@?9NpbhC_%jN9OE`4%~b*-gLT*`!_y_3?p7t->lIvJqP-Oz2%t59jkMr;@B)T*PZ@ zYgzgEf7|&Q@w)a_hgT20(C^$H3X-o8wyLo=OCu7FNAtVlqN1UhB6N>CSnJ&HYXy0E zO}7@((m2^C=&x_Juy|i^q*d()^gNz#&v)$Dk%^uBnP_#qu8A!CsuNGn-HpDdM&ewO zS824x=Lx!LoWLE|rmF5W_{fh_Vtm~sS@_KcA+1f{S<-$AG9K?FM-MDT>vWbZym@0U zB`$s*jTI)!Rwybz{aU(k7o``UL675}+ICFQ|G07B##4PIV^7}SR6ot{_yT**XABbU z=-7^n%$B8>fC>E9SA(vmq=?!ab$4(0@ayMK_eA&pSK!6=-<~+Ry51>@arF2&^7U)u zCU%DHp}$pq&zwmW_{28Ydi?lt@;ua1m$D6pf8625SQaj$>KIqv#A`dF7pDoxU~@ae zk|0mDXDIJbjn@EQsnP~O=7uSBj!xze#Gj&!3|_o{jjVOPXvyDeyEaX})%(l&&c;uX zVW*hxBLi;kG6_p0L zH+p;a>^X=-aj&q@@%B%yOSnVWN{1ugoHe8T9QsR0ue$Y`;uZa!qf9Nr-O zJ6l>-_WGxT@OJ;ial1o@$d1)vgw1qrX;Nmqi-QDdz__*L+~X)V-8*EmkxqX6YPngi z6 zrv^&d0B!2Y#tDpqyH&=U_3aq64)VeVeARuV+%Hw`7Q_jH(9eBoYHhfX;taVCz)P;; z*blfF-6}Ru0Jmos7QW1B_{`4^?*QwuYgfw!0p90W>P-PLXrkvn2Z7)rbj%I50WS{< zY;gPYiKo1Q(}de5%1Hbb$fEbp?+2Ebmx0)*G(wh@3LGlqv5Vy{eLsB1gk_L6QMn>; z&Tz5f_43#?$D+_b{;P9MB7rOOxzY-+P?(hgkURaM=3D~Mofo!qbaY%@U3fb?KVOU9 z3{k;2caAzSF_9>!xVg@#Yf7+2;Vhz@1>VTW%rrQ1L*CydB`g``UU_A-Kg3DDnQcewCf?H3CPBHPJPy~{y(I3{ZS@!~({-?*OpwW|R zup5-mez#5)mEOumS#rVrK!H6UOc#y@c_2I;$Q{E|QaHDiEQv5I-*|DaorF zqH(a$frX^u`;{5CVtsmQeEdA8$Nyykxa53{Rr54=96ZQtvn!6Lgw>0etbAtZ=FP1 zUHkQ!SLd8+z>|lCg&VOwH8eC}7zyLU%`Po9=3Cw&jKu%RlhA&7Rov*&rrXmu?%THy zx}V9kAfV<2Tu&A>WKPnF;o4{o?;#Ql`)s}NB!HU)bM6I>llmTHviTX=z3xP7A^a40 z2Z2s6VG0nR1Lg=ld{tDi?67aX*K@cwqZ>og5{E<4_V-O&o0F$!5};{aZ?CP}hE1yq zkQxnT)5W2J17rpMnihg>m4I(Tr5X9Rc01M4Mv*WG4`?>OMaWHyi++RZ>~Ti-1?<4y zAfev|O31e_Qvrr>a&}G~54JHgW5PD5D{*h-ys8(x#4NQpD3CvUW{?<0H?1895!yUQs(m+F>4Y(Q7 zU(^@T4ixoayMHPWeC}PvUIL3k0WgxJ238&YYF1ECKn_jhS2OjqUw(VawA3EN&j0Uv zD6l3f0!QXN;dm%tol-WMxL5*Bd2)U2&m=a`srQfU#0y!WQ946!=M0KiLG@W#v9AcU zY)>#U_(Xd#CT9HG)LqrCf+O3*+QCR$ew{-{67P;aANU|}af0m+4(r&(ML4B)*A$M} z0{I3GLXF~cP24Oc^#q`&1T>{=3Sc|_!!~vGgA?xGaep5{2MxN;MgQp?qtvIbs>*Xq zOA1dJqS_Ktyj7NMsn65! zWvZ5auY#kxxVrYCO!uN&^`YSQ!Kt^?*C!F2dHb0W>g|EEqT2yPi2p9k%{haRx)Q%% zczr&K58*DN8{&j5v}k#-Hd`ln)O--eU)uGWmgytI3%SiV&+ayvn189dH$^g@&We^( z^l7kvK)~B4VbJ@ws;Z9uKyu~EO`YI_&Yz$*g9@oR1iU&=lURHzS;)}fV@pf?r>f8! zxCPJ8{y3-ghpKIUi&AS^BxL9L zQf`!F^6AE=rUcHkEJi{lO)IZ^vvQ?j#wjr_EoQUX)!64UehYGhO|}(A&e3DXn&3Rv znD5z>iA;cDgA_g&Ko&@SP!*7|tNA3mZDx2_BX57PD_x-taAkCS2eyXMOuA{h?CWQ# zMI260t4)7h%glUDkWyq23ZJsv%*sk*90gvnF8u`H$k}}Ml*8gwzm2M6ytIzn(W51V zMqBYWO4*Y$H9dXv_14SRfqNsd6vDF8((FBuVbZR+OAPnq2c*meaq0e zi9<7HA2|K-nVIT!l$5QOiP1?y+viIl!O9GLK-=S@{oA_oknk9EQ1?4W-Hi!7cCVN$ zV-&^o*EctIiafV61WEAq_rL0!pVO>q9HwPdh4yh~4kl~o%R5hL4j^l_Om2g0qGy2% zYyWjFfqM&k=8Msve;{j&J}-8A&7Rvo@wr-$iJ93Arsu7*x;U9Wl|LX%K7wv2E|#cAG?oBINx}+rUtt>m_5+9o=ab8qf&b@FwX3YAFoKhWifJ4hHiX zI(`Y585~BG+bqKv)g&s=l^hrMI)KwMC$9k5 zWR@*HtMU$3famo7UMj`Kp1ac0kk8!VBV7p=dH49R&0X7;G;Qad4Up@D`tI(&!kK+R z$z>jk8UN^X%m$&B7u$Wmn*T0Jr-U_P3(42$m;D7=7Tta~%ZW2)mZxr9j_-)F zIRQBpl3inq(A;A_tK0buPaAvH93-Uh$JR}1n zqo}L^4n8Pk1R7Xh`{jssERMhx5)B#faiO~ybJXLc$j#4M33BFr$nVmKw8g$rwOfUz zT=qUWIk^ely!hB#VN#z%u$!t!hrXXhJ|oT%{XJ+($W$EY@vL3PjrY4ybRb#kaK{#wl{A& zftLdV17me>Ykq_72z4M4%PFR%b)7CwW<%noOPxSth74EXBzpV#tv>qcBP*psLBI}B z_49_wlAq(dY!0SVWU?wU$@)XXd3y50Ugt{OI#;yW0iArnArzRP8XcfxB;DfQBa37L z`QICBOClVJq7(0A2^SNLTi@GT3Ca=SeA&Z41@zXQ=M|R0P&~Dn#zIaWsuFpLhqnJvna^f!MTbQHsgF6(!cAX@ zS+_%KVq;^Y5bb~X0VI#Jz}3@J!KYi6GYyVL%Ju8<2|S9mgM-45J9rq(2txwr!)T`I z)djkRBo>GSslmf&E@!7{`R+rBZgz)|2!}-?tyS6=EOy}0M;hT8(kY`_TP*5EC17%;T9~}!n z;!1P{^vzMl02cFO&=k)6DmO%?Gq}?SHQM^XfjO8)3l)$do#BWhC|VDk8WaXEI`B|$ z|6>AyYs1H+MiRA35SdK~u`DDD2tNv|d3kwqiOH6>QFBaBpFTC3_SezTnOpp}ADmg) z=2t{5TOz=%Gh&JZxrO4yTiTcV?cP+xG_!_tKoCI`{Fs|Jg}S=CjSZiPNAKc2TvJzf z;R8g7;nX`6XWBT#YEvUC1_CatSg6}QKb5(Q&HL=x2Ey04OW&+TANA{wMXbVoBEah=^=hTX-W5p2`x+#%^(gyCfy3Ywmv9}^o7} zE^cr=S1by-6V#4@M@B%foQV%1qFPv5Qn)gs6iomrLRMk|uXT`8QnJ|V4Wy$UaVmTr z@&TdVp-w?GI5_&jfcHrblv$dO7m8wq41xFRg!=r_(%0jM5BG-z zXt7h1;9_)cDI+&>v333;@1+~Y5I)zb9!H1f^EQ6-qyDAq_}vvSkg^9WH|*` zZM>{N{MIsb>9+Up4?3@bb+rhMBd|O6{Q#O|UteD_fyUCyN=suayf$sxRD@bDxA?}9 zv+cTC!c700H&YKkZA2z+fA2lqYd5R=Y3^=rMR3pJwO=F(>s&tzRb}-3GeowU2&O;Xwkz3;13(p5eOH}QFfY=MD(1+s?-$t{DBEPcc?B-@o{-TMv zR%+{f)^rMkxZ*B8iyGX~l^tr(PEMp)wcz}(oL!%OIn&Y>)VjJv8U=e`=o5hWl)2gqKO=+Izl_qx=VVYzc=~Z zxIdXkCf7n;xZxF0X&l{AIgCI}^~W`$5T^R%-M{}DrnA`mAq1V3Q-^LX*dS)kEhuPz zdkqI~tD>Ufb4aP;mwp1WT=p{T6R+BXHf>b!(%s;%skot{A+)7iQ{OI$Hq%OOTu3cB zVYc_HlY5R)s_g3zI3d~?KN{q9Y zS298gWSC)&t6KD@Kc;7PgfJitNA&aMm6cb$y}aO)T$%eR`Wz0gumABPvN0$<Q3ZUrbII+ z4gaf)ed6Tg6an!+wqh>iI9f~W=kUKmICmahcVF97N*#LYk@}FGmV^#&j4M1dJ7hrE z?F6QWqWAHImt%gAv?JEVJ;EXiC)$Q~b#)bCzdMw2&m0q=y)Ufn1bE5V9stIRuq9bv zgTe>8g)IU|<7yAe&lL#kq~*Y#y)OMz6Oveg{tu+bxtb*|!1%GEIOOP9t?$Wu_Uu{X zE9>(KM1oi^bZ_JV4Fjv#js?mFKIygbEJvCVGfS{$#Sz07(#lAXgH)T<7b7P*YK#hB z+V9fHd+?EMBv{7Pj4yuy!j)YcnX9y&Y9iS4+K}%IdBXWVJ?5 zPM*Ai@MkWPFR`l?Oj58%z%M9Cu%#}beP5*)SsNZ6_C9lFc(58}n8@Lj=Nm=d)}Ug9 zBJ^CkM9Q*7gz~@vW?}7&|HWQinfX;?f89Ig?w&)Wn%QmcN(ar4GJJe~y7j_u>;q@u zlU#9c{<*WaQz>YyA6PTMJkm#|@bcx$y1}7vJVr-H-#REFsEi^*qxE&bL>$pqrcH~R zB_-p{@6DTm6>MUEeXJ0BLuz`Pt`uIhf^O6o2+D@Pc^5Vl0!Yi>@@{dO7@>cNA`EF- z#(KA41CH6#)BW6N2527MNPwYhcS4Zxnhr!PP}zG(A7amZ1+ab1>(_A#lHh)4AS}o- z#_qt-2qH0Q3aH=FZ*FXJg+bfg(qee(lsw{zkr1<-fZZW4jo9clLIfaM3ejz5>Mai( zXh4CD!|zN5aRcP5SXW|9XxH~ySzT^^Xx*M%Sd#hx>3&U~8!A2meDZA*j)sPmz)74} z$JF_+^#_fr`&<>Uv$NZ^YnR2L?EYQuo)SqkLIAl=4KLn{zKDZZ1ilhZ-L z$xTY1)jb{|ftn8=cu2E#8}(|45??vc*6PDS-fv~a*u!xnH8nCVE$uBgna?#gIXREX zY_tVHx9Ws89odalP>>m*oSK$4ejXKacxWgBrMb4feFJ!#V98iOoGN$vHzyFH3*~Cyg}Ol+jjEd39MpZ7M;5NEL6`ByIB2doRi-=3dU|>Y z+yVrZ1EgH^?3r=hMHZ&XuL8}}yEG93A(G1oIJaD)K5_iG^GJOhIDA;-fHx8Dq&6Ut zP{m`Y=r&mF;5NOyY9dU}qh3IyHU=}Box{E0?0 z8CgF-c_*xI{{FlTpGxbGA(KsyodrQw7&c$a;oDZ02B^p#WMihMo}c(3M8^;j?jLZ+ zzJOy8>w@-wujAA{gjYaY8<8&~g5l*#|E`Ub$W|}Td=|kN#O>^~b~459^l?oNpg9 z@uV2RI>0G&^6;<~9p1VP|Hs5noh%yLWel+#g7pwu0AMPHq-^hJy0!m0h3_lQl_0IIU8(GwTIYGfyl51)tROKV7Qety0a z(iFW&t0Z^az{DQb3rPfFP?5VgE=nIz^%~5|iXa$= zJ<{f^M!UtJ{N+JhxNopthfy+A4I{V_f!X*3VavmGAPG_YvC?Y1e0+0$VQu!f)0d!B zxu66P4VPzo`{=0K8 zM#Mvy!tz`czd`*V)O+n8$K2dz7eQ&Nd(S|Nbb(h#muKsU7mB* zT{&{#02fAsdZab~m%<}B?D{DwNy*y2K0YjdF0Ht!c5Unzw5g!?h1U1k_l56%qM1nv z?>iZRug>WIMh2zjfjqu^!}vjL8x4Id=W5WxSLeU$YXd(YAnA=}uZ$?Vg`g>U6T;iI z-7A??qJlcCNwS>Vh)C@|L?dKEraeEE)1Vktocn27Fgg9{CD8_vXJGL1no;~c06Zfu zDjLz`N1Q8DF;#RlKX?5J*IO2eFfob4XkB2RIsVw8k{^-F=4(MT1|bQ}k}XsKjEAy+ zMjth-wWKlr+&~u81dAE_`~fz$=6)h;k%NmROrKMyPtPII;_wwd7?8OuQS7msu-AsZ ze`ky{x;!3+SQ(MHzI|*Jx4!7bi=C)KLlYD95TX(MOZ3$GH}+ShgA22ave*lQkr*%Q zT#ZMxq_(^JihVM>J7tbcDo~O=5qlV(oMgt_7&ZejPKkLO9!)uEdc=H`5O8d*9sCPt zZ5Y<}Xe+pA#@1sSNN|RUArhard4+|FlI9t={lej35aW~te?v9F8FGd%xuTLw8G(=| zAsJu~js^jb5Y8Y5C%>5h3QC{uXeL>90Z`ZAkS?oSVjjH(9y3DFD4G+fV7!o<)izju z-@R+s(6_96(R3RGBM=Ht647hl$)_8(8jJEzbVtO6TYUdOl*H~mZ+K<1vr|3xGzCe) zzBB^uO@_0PLR3Lv15k_hUoiafZy-+6EKk+_CM>Ycd7x>MB4Be8LpG3dP;Ao?LO7zPt&JJ@;ftXj30D8YA}TF0i&XmZ zrLV6D;sJ}_-!Wk&GB95iG08^b%$yFmMFyn~2|}6hS)hY#RTTa=EV?P^*YpvM?c2w- z*b$p`(e(k_js$UZ#hI>Hg)rhLfeDB-btG)1k7FJqE$^k@H$xUH5^^%$NECO{ze1p} z7;4iAL2|w5>d~=dR*${i^fkm_s3C|vi%iiFUJr2+J=ueg=tcY2!+MLH8NcvhWW>B@ zHwKWshiWJg5+-B>k_FWAR25?UEo60>jetsYFfx%-7nhY~gf})k{sLDGX{`p6snE7+ zz(JOS=xAw2K>Nt9Y)RaBr6II_-tGSKZ(m~U5k6F!tPbq5kyf0E9oQT>g@tby-0rX# zz2;t}H>?Nw;Um#Tgu-j>5v|{b{Kuuz1(_5oP=!&MG>{0Bjr ztJ&FmFYO9ZL&saGgx{)YlbxFS3jfy!^xg|(0l%NGurMd*6;fQV;Bs?wl{q*#9Q;An zsxE;oZUyOZcn*fwshh1GRNG2YqN1Ye^udlqPG)Vfd!P2(mKIa%V{o{FvVTCg?}OV< zcmuYm$jjxxP@L}slwGJ5kw+GM8{q5vWd#LOUQEouQv_-C3M9FOk-T*R-D!LEDsmkD z@-5E__6-;hq_!k$!b1}|2qqVUL0vUdG02XT5S^hVo|JkUgFSmL<)M}kee#mPHlq8Z`O4q~L)4TYHXh7?T3oR49mbMQYV@a5pUSyl zKSV~ZKl7$b}WM{u3un7p0zQY*K}Pj#Oaamb2#?i{8?Eo} z7XZ)!h-rWKkimdc3Tg>4Cx$9>5sZQ_{O{T}2#az)o3CF%YTVLo9fKI>5y+qHf3Xpo z0l6F%=Ib}CjrW2u2{Pn!4*>|TM5R`U`70Che^~(38NK!83;VRW%MH>kUw9s|WTrHR z-opw)eBis*Pb>m~NgNM;)jh!L&B7Y&c16tZ_z5?+D3P#b3b@*=mA)^}{xI1l{0~k! z#-QzqA*iSb%$LQV8w<*>yEj|=HO*C!qgM?L#yuBg?m`C84nrToJS&0t8T}J4?^F3J=L|-MW8Kn0=|MAMtBH94%s2 zYud`%(*6Q+uEaPXhBi�tx1>4&b=}iaspz#KcA(Ow6~4oKOzu(~}^W@5^x!b4BGN z`~LX!avS7iYZh-DOc*q9O`Ja;qwl8DXEt8S)jfIn!x9>Sq{|&!EuE3r-MdR9JFvW zHLj;2fhUNW0=i_jqV*x7k!$8kjo&?q+Fs@g`SKNT>hPB@R5%6Y-~M6hWvz;!1(Q)@ z57>k~(hd5+9)!*_sEp)YJQ~F7l|3-$xifW;>$m#C<|sJq5m8?L53pmb-vx`rtK}yR zH$tAh_RGjf;Gv06bj|+V-=?M>d+R}r6n}9ShMV?jC#RZjLoZ`OzQpA}Jam9ey+eY^XtxugS?iX9xI?a? zQ!`bD3+0rW&k#o#kt78b(< zO!BT}o+OiIPGLS&k&vpr2(6WIM4*t)pAP%I$bbyz4gkHfg#BW*nv^6AQpq23DD@V@ zJf(3EGJOWfQDDB7s&fE?yqGPHb&-&iG+E3+YVMIoY?kynBGn2KK0k(fz=O|=Mkf-O zZN5y3Kmc_A9ju=7%u@@^0~ftL6N(mo0Cx?9S0NQAtQ!)G*g8>Ck=kkiHL@u4ad!wu zce2-q)=RpaO?y9x*-40 zs(csQR7DHPcKrC(txvRnAkCFPeb{&fuv`3z2Iw8&1);xdLs_~aCypTCXgp?DB$4xJ z{qb#L!U?$;$nXghL2*e*Uys8Cwp^TnyO#qdOXQCrIT*DxViR?~4Dhmkc#sACWkiAw z<&?bPGVVU1LHdk;1`~$Q7o*sk?Jnlv;4ly(qp8UUtH}r}TztG+5}M`Q?UU${#M2-? zMWN8(m(kojnmISdDNg07**oK36n8#g^?Ds z+#g%yc4)k^(Rka?*m#j?5sdC9$~gg}vt1_tnO zB(4aX_E)RplcReaxH&i^tV{@h7u-Lgsug#Zn$(u9b7SB4WQ>>-!6J?&RKg_Ok2uM{ z7;b7QPwvo)Rml)j17YD;2N>nOq zU8Gkn>#b4I)Nz2TCWnU&0DR7%1lpl?^&y>M0=58vP}r4)M9f)KcYec1HULLG3&CiA1ZYGG}=SI^2Qa~zV$z_C); zVJ{ABiY?p&>;?s6C90gDbeP`iQEJc!Y-VF;7yqzh0wF#`mu};Ggf0dTp;f08X}UAp zPa;PSXnvLd^72=Fmj&2{tGpAbI9)u_<*w3EVt||=g+$Ej{*8`ROl6TIB<{R*n8Af< z_)qc@D%pR}vxzrPo^OREsuVD7Pl`bL(rTlr{!-KroVQmH`@k&l3=C~T6$8?`yxD-^ zVj6`Zp+xB>B22)MdX4)0@^$lUZNBi;Il72R=M`kQrZ-=Z)>7HJ6^={&=}0d8Ckn#P zE37`w{52*OlbH?Vr?X&#f|@?m5PUj1I}NZSF*Q#g9Q?;>xYP;35ZiJ;8Ilu{T)>oa zM;28sYN=5eux^e7vrMJSfw^>9+`=4B03j4r;`uSe(|icIR8fq02FuV+&DVQUMPn}; zK^Rwp7-bb4rlPo$5DVW#q6M)NF0?J;dj5bImSUC9W>@dqGbn9BF7K z1YsrAI~2}Vn;uJcS$eXYXkvDjNWdebZx>7;i7kI+U}mm|TD&q3NZow0fk$7u;{zTs z1QJybYMBUBLl{09XTNhIpPr+1F9I+@P1GQbM1bmU=wP|DG8a0sC=8R(;fP1)kRmV@ zISgXcBVBKki(^HkG)cE{l!)=EfX6#S1ZwNyvk;@61J&Uo7~u@5`$&LiAvi@% z`WJrwy(mK>nh(J2Jz5D!`XxE36eEX4G5>&g<(F3Y>N}xy<~!2|sa!6hIhm=yMM8(o z=`T$}OPU+gM}7aBZHs@Iz9mxFX}08ka}m=uW4tRRwlh3wCV9AWSr3TH=J#e@cZ=v>(XFK)Odm zJl7l?f2+EX^aL?hPhZ9sQVRF4TSGS}-Hygae}5V^nLS%U?VfX+g>?Dv^Ua(?-GBS9 zj#i%@(=O;TIZB(d%rAY+_?M`qx7fZTLdf+trpfFlkq7{Zjy<=&7VOXjzKtg|C6MN6;%1&4~}YY2C+pwXSkI6ps3;r%7~@2~6ONu+(~B_|@@hes~-sFL=C ziYi!J?Ct&?Tf4CER?ijm15ZW}CdG16K>H@1bb$Cvj|HI=5K`AGP(Ld(!>Uq|fk$h0+Jsw3B>Cuia;CdFPw< z@PWJH!yj&5W`Fb=4(u1Pc*iS6TCuM&A>^@jN>riq=X@#r5(f$GD&Rtz%Vdm z;;Aq_j}KqNa1()eymqn)A4C^v8dj z27_XZ&s3aQHJdqNT@=9il1zD?UqIHjsDW3l7*A9?Np9qJi7T$}T{GUTdSY^ui?{nJ4a*+SzR~CZWM+D*Jzy|1fSW?{9iu}e-QC9{Mhx_n zTcUYI-;ylbFmqiuIGD|BkiskK6I0H>=KcyhlMo%nX3$EIX1weiPxa+NL{h3Dv+4wu z^~s(7md2{jmU%ZsXhZByYj=$?Cv;mpF)9MgLtHa+qb)+*(I^3Nog+pA&m?u?CUYKm zc*t~(63;TLCs}f*9D~{gkwelv><*L}D5G^BKVE0vpXHHIug@Px@h(&@p`H{(JmO6m zuN`y@`>GeSW+|9C)q+}Ja#6;!dFyRSFL%qCPqlk(O(4p;L`XB@4NMb=S>@U&2E#!N zQ4x>*;Jdd;^lijB(P>E|7d$?Wow#Tlc(}6-JdUF3SKo@CJaHl(e3c3)$}NkXjfzaK zKgwq@{Gz0JtG?@h*N{d-yz~Xw19hK2J2rcP`=eV*)TMD=_B2#|QuMtl{q*l(&mhP&ICgvh$ z(ZG$~&TOn}_T|%Gb_`8>-k#ZTdu811&w2fY|E?HIk+u^#0ww=RTQ@g15(!bV;!}Mp zD(3ffrV={0vaaxIs0s##%8j3Plc_0Iq`1?fUn%VNchxW(cg2*CA2-P8KAu-XRP%Yd z0nU6B$J5%s^uY{we8 z7Y=6ybMo; z=@K<^C$6T=Zdh)8xZE!Bn{RefP;}nuD&MhjO1ZX(XKE1}H^z@={NE0JZ?R2`T$%|# zmUfq=WgO;<4WbYf%8m8DbF!AErlT&x`09$-gXfgxg;t|GHqIF| zHi%KHZ=(w-rx^cw?Xix#OwG@q+CqOAOP}7&7;O39TNtp8#X{yK9#3Q#1{?#Xhs7x8 zm3G;dbETV0nBoYB)2Q8`nzWQ)73G8Nvh!j4bt|a?ECjWwv6l*2_bt{ zQbHo7++=2NEm0vvRyN7VD20R&83~n;Y)Yx9$jV4jM%m+cUfs|0{J#G@$9)`6_{9H=bovWT~Z(k*mtL!(tH2?k$ zc^IG3h=Vox>Bz=u6H#I%3S%pX?Ep?ifrj%d6R)l=(P2t{ z#tdYB4s^PrrK(WK9ed}b?_Kf4S^nUfu>{H`*)<=b9)+K$P-Re1>eJ`DJ&6{|bS>-lNj^sj;`0pqkjIF@b zk{r2z>?S$JJqpLn3{G^`MYl(JNSj*Um8A_ciSkGhiBhH=seVq=_lbJdD{;JNDu{D? z;9jdoYUyUWT6>qZ-cHRf@19;IXI=`a{B5B`cE)RLw1tV&lVc(^MN9U2gJRr23)25S zXMHuotcdU+BSC{K2d=Gx&P}x``UxIyw!FhVlP9JJJa4^{?0DLwzGj_e63#Ft9pUx2{nC{vys8dF%1)9lplxbQ5V@)t0g{6!)D;Za*DsYr@#xoK)1$@%h;- zUnFDjVyIDoTC>>cJIpLK#nr!r(2C$_Vh@ErlhDun-CiapCXT6Pxh3gAEjyw-lANhF ztQd7OTW#~1NsA#?rlvJ?%n1m+n6$;uq_)mt`QXs>pb zf3C3l+=qvhY2aYnVXQ9ePF_5gK|vEv&J;WAS4Wpw#ASQph_Fs!P)MbU^oERnsD%f= z^da&!ucJL`>%4pRFdV-2^-J78x-?-+V*=FQk2D_a<2~I22JFA*ATEF>wJBKqRDywRtTIt49PWN$N+rzAZe+`lBWt ze_fE-!9X`YR$5c@?my9s+|-QHr}GSy8J9`?793030Tgam%hZz7Z@xEVF>E;S>VHQ= zN!BqsO`}u(OIq?T3&A@g>_`tC=kO?t2wF9nye1*p6*`fTkyO>wb@TG8Gh%M{+%}i< zKWI_w=#p@=e{h(qNm2hLPwEU^>L2P;Dsn65Ce^44DiYKvnURnr&wqP855`0x3w zv2_WYp$h=71=YZlQ;3qdo5Q3&GSOaq63%nZKXg>&aWlK_Cv>NC z@PntocHMX-&TCeOy-lkwe!D3iuAF4lwky#2CHqpzJ7u@C))w)xmrZuA;G7ePFbHd6 zVAgq)N|q((GEiex<%N@)3T7c@=hUiJ0;6ua&Oy*a3|_Dwc(r9dc(b-zDD zZGQDH|L6QF!sCr1byv5mvoal#oVdLG=n(k9}X_Ake|-&D4!cpVq}(C54_nL)_kpy7w+e-EL%&e^%S_JF=L z{J|G-WKZ%N<`rvD_ur51#9PImw8%`S*@wp`Wv=}BGTHn=?~iX=cGPw6Rv-4A*gY(E zh{U|2BS?Mh!I2c2HR{z-s%#OlWVL-veXCTb)HuG?82FTxr>3YF=r1No*=wbQAMm^_ zbH`h1SFE-SE0bgL_Vmy_w}@Af$Ms$}LO)oALi2z!)J8ZIlaw)%0Y~FTOjZ=T^Fy-s zW%bANQLAdb(f6gOO{#aTFIcx}2<#i-ry$8a$T?iQ!nH?1M}m@FPjRs6^5Ee8t|bQ6 ze)8I<64=*qIpj>&$)4?{sQD@|VLqx9s;$(vSBd<8g`3u)Ne;r&5K|)_Ee`QXsfMCM zl3iY2M|@~1g>m;U_+7awd~y%*&`q28i8*ylI6p3yZWrI{X7)l+R@cz2*} zCx!gqgOr2#=GNc@)c2UOOgZ6RaAY^mDS5=Kv|)Mt_&-NU57&%-muaewC7o5?Z!#yd z|8j2MS-DfSJ3~%o<@Lq|<#>$QkmQQUVrnTomSgq!cmL$nuS~OF`{TK~Pn?x@>0oK~ z1Em4C5i?s8O1a;(`p*yYGc`#S|MSQ^it|b`nWma-y@gqyuGpQQW`FOy9HvlC5xQVN zx~MB26hW19dEuw-q2tE5p5Dk)evZyMXk}wD?Y*2oQ}=jR-I%jqS83(|#}`{EUeZ*q zqxgfG^2W8=w5~r}$B$NSb=TVRLEFM+@5iNAYL>LsHAQ)jye8zgoueg|%mb|gY=3i1 z%rtVJAZPrN(_Ze8!*)$;zcfD22v4S~#@{Nc&71+-s3jV$672*`iw@}NU608sv(Kbu zi||aP<~DuB&Kg-4DZbPzJF)%z%syMIbN$latZ2`#Td2mT+%~b1sH~t+zZfHQ$J5sJ zrD~S@k=Hdxb(502R2OGh)T6$oihd}|Fg81w=*wUpV`Saqb75Xl$>KdnWRMVpQ1{>Z zmZ&Q9*)V51zg#Y~zMOgBYKvGwOm>?7#TWA*b`5bjDqr^t+GpY3zmBSOk$dp|mb#pr zu5aqe*HE#sFPYydQw#IfKi@rjtD97~MSQk$xA?DZEMn)ZlnNNQdm|*K?35W)UT0ra zJY8eHug=b3zSq3lFk3BzbExRpe~Wv0oRG8a;BZQNuqY@g5q`e-5XbDEZE8I|L#6*L zTIiQjl6HT5M4)!yFK=5zLxJf41E!Ez7ADEPt5xN!t{()#x3TXJFkrjkuvW=)|M0-- zP2a5{Q678G&z{w)(V_2`ZpnRY-}UIdH-Ey;2Pwk4`Sz%C?oqTj^US|i$Kq$B(dmbW zYoA(&R4Nc#M{LxT;wBEadN}y*$Of!P0YU;!G{cW%4N=`>b#q=&((XJJAH;&uY{gkQe=!v59Nt^Mr zJwGY=Q~6^r4R=*ar;MMg>U5XQ1*wz{dD7l6zrdNKB$aKyd9QCVdUrGB>p`*Up}W8N z7$nKAc+Ez3T+GUi7Ft{0%(Z3sX7b!Q2cn%qJ>JHRYi;Sd9%elvBc}&T_NvT8ztKG$ z8!0XKo4Mq^QXFghz41P^)U}G_KV;*|>T@hzGjxZH7c(u)Bsy#9TUCSgivFon+sA(Q zm?4`tm6_zD`ogp1Rc>VSm#5o&JB|(pY)!iU&Sj6S?5&loc2*ho`eJ8(rOnrbM|?x|Q2~mz!YS z24!7@VO@)R9aoBXjlP@Ht)Ns~TmBGnMHCWyj|mt$M;DOxK-hHfXnlAqPTd(;Ri?7O zdwS7raKh}TV96QE_g)kdpGKbttmH@W1imbumZw%WiSrChS0j^#Mdp?83H6+&x*U#hq7Pe#SXN;Ka)IG$hg)G3!&3GfE?( z5VH@|rvar~I2&pXP3q&(JN#KRqMgH&Wo(rK1L&gGnEQ8)|15suX8Mlm+hhK`&k_q$ z-=EFs*-1>BjWdcJMYZ^E=WDd}=CLp|HFQ2vLfNtQ0#7E}-+ArWCMgh0nVrvQN!2ORq`c+5g^?PK;;(s;gigm6er6B0*J+)>~UXF4<^)^zEBLmY~luG>+na3X10_ zM&+qFHvOl27N9k59RblLEQ_y{$s%F0MVb5Bq?DQrv;}p;@ohkKIt& z>HHTm&@@BGBBTT~o3NUsT>|AY;rM&1S%$n97B^9X5FNb$EeCvy_Gvr?6ie8^@n~5A zcliFlR)_eeeY6Y=>|KC{w_nX;!#BP9pB--{c8mD{b0{YTfM=nrc^}wpgsEB8$OCl6 zY8-ytbXI%k=0E@Ly+r@qd&R^)Lw^#H}reFaHJ`_JK#th6MsUR^3 z>RN@+%4527@DR0IelgzAmfbFSvrZ2!DjyCz8J z_7qn{iosu4sBriO{8>g|C#Zc$kP;m9&~h-q%x@@z@JMt+!qhF4nkLvxj?F-(L&`BJ z26?bWEJWSN=*H*BAW*Ve_v`*=sR_{#`tOIa;PPGBCY=wW@(*{yJJ$qPuOC-qa^rtabf@kvsttWr}{0S}h zKCklcH*O%|YvW%sVak0KbBaw%AfM&yerjY1!9F^~mH00fXCK%yk?y^=>{*c{mNlFJ z6cGb^d{i_EpHzp zH&=q30O%)~z)pCq91e;N-2`kez|6QVBlW+Jp9GYU4wGHQTMmICB$)GD1NK1M4oor( zoAAe-rn_{rP z9%NaVu_JH%mTmA{@p4PGT4lyKrom#5sOvfFx4PvCWKNA zG84g_%pm3ydLmG6?VkAUE<9064u7x5ad6BNhx+aUh!{`*UD!r^#2(S=vkI<{O5WJm zAY>QSKJJv1l(g-DvK8#Yt6)LUQ``eV=WT630CbG; zuB`w5ntQX_%okC>#-*prj7UpKwTO+zV9xOpW>>hK8lip)83k*RAg<2;{6Y^l0i9DK zcH|IPG%!P^soP-=bGInROtdV-1MiC_Fk-WVQeep@9B(7TyC9rmAb%jy(9jUmPq5$W zFJneVNC!q*;yJnxy?*@~vfXM&*J}iI9b;<`3Kq)au5U!yn4e%7GGFHcz9?+kO;3|4s<)xldik1YvnPezD=$cf=SF9;Ka-7-%E zu?01kuHxjghg(q1w|JA zZy2e-APq#^V6=s*YrhQ@aP?ui&(a&y(asFoZIR9VOvt7D{r!n4ri@KZ43yWFmBl7S zTL}8RY|SD$9;^t(m>@0j7jYL4V?s@Ez*B7eBY~oW5*EsUWEMQkRrPc-4M1oyamh@% z!bV>MmIq%@z#ac9l zNCZK=0PT(#%7Vb7NBtMWI=+r3Mv#+&Lpm#_ATBvM40b7hCF+|u9|9i&{ArO6y4!4c zlf;A+chB2W2W>D%UN$s@Fql&k=AxJqWf7eABS#K^q)F(1@SN&FZv6KfXsik1FC5}? z>wo|L27`eH;ad!HCo$F~{A+ObgD}qrnz8r%Bu^Kz22{dwb49^O3_>YBl&Gf~1R~9* zD%QFWA2{${2pb=WYFT)B>A{l(1r;WJk^kpeK_!3uFz=Qv2?wHrVEssm;{bL*_~0+G zo8i7Jx@qd>z{Y)W5g_{_7{Pe@T~)CL_E2z>Fx|nR{rBW2HYkQ(?#S@d`1dIR>%IzM zfuM9oe3IB6h%om6iog#NZbM_A8h1z%W;)=nV6zb-A5fp_@co-E+$a^ml>Y^&!f^=+ z!QdW)3H%jj#5WM@{#}M4moZ z!U@_vA=|*oaPa8S=$Ha~Xc|bwrwt^dfJ0sgJ|^5e2%1r|sm&Fwe?R}-e)JGRAfX;M zRJvQegwvJybq4`T&zdk8U~XfVviHd2&7?Te6_WKt^DsFJxm~b zVPXTmjR;Ti?Ke-{PZFwQtVnN^b0k~r`G}a92C%>~i*$=E{vJ(dXdjsEJpnFmJ#0=cPLe|`FM=m}4|afX^uKq3Ycv&)eh|+Fn2q+~!?dJ9oDiYFOL2*Q z^ZEDF?#HK%Pvp+*)+K@pu%a-R+kyK$`5uW|&Xz#mbD{3-+xY+Nlq;A}MKr2w6%N8x$N?;kMU14A#>fb!2nL6Q zIs|m7c#;4mLGy-mmXPn^We{;1hhq66Q6+qrIK&*HbN7g-K-u4g1tLyDo14}F(L_6p ze}n zv;&_Dd}0>R0u@?HhKm6C9b9<8+snVRYTC`r&IW^*O%f0iA_sxlk^S%DD_}zP5>*EtayZ7O z^h?-*L-;$yw38=XjFX7=z$Lh8No`{_F-GI>PS}N`?s)u1IN`t%Sz-jXIANGqW&Km z;4(?imca723Nhlu-Q^>K*e~4Y;m1TNNch*o_-S^T8)EVdjEo=)3ysKHR;mBzp zfz@+EFKHln7gANV&dXj}Ud{qF37<(5WZ>wy`GtiYSO3=K`sYxZ+)%;+ON@Pov0PUL z^YSAx-@XT`IDVkvf`! zVLYM4jT`bE^MfoEsLG>Jmu^}Dd5^H}c7%kAa0$bb4p{|t1HHw+!`~+77Om{L8s!M{Z z2xpH8a<-g*z%dK;fJr3}q-TFWPf>1&x4p0@2L;w+V#nh5sVPQS20g9Pyr~aAKfyJ? zEef>%u3g};A*moO3l>44o;(UKt%^7=SWq6@d5AgZ+LI?w;$kBs1^@FDt?(4{o^ccW zHGVaJ1`>jpnoyZ%<{!DPnl;J1aUJS|R)K%tCp~Hx6nu1kNaJZ4i=Zn zBRV=l2eE80tmnliYJu)1ZsddX@@p*P(BJSnfv@I4t|T${hA$xvU#3T-EGig8MMZIz zCTh;1JRk<yN0w8Em~PuF+|(_5H7grbGYH~O@IU6&1pi}($(y9yBpe>1t>&*1X_KW{QdSlW^x@xGl5gB-AYer)IDXi{*9#`z3NUrGdy`AHN;o3D7+whPn z>X0?k0B`?#QVCEId}rt_OQ7#7!x}3=*QfZ`(9GwjHh|9IXxSP8dHokiV$0NI2CX@a z@DT(&WOoy{V#yVdI0>`+?mK%fWOcNq!=tG+U~&3@7#C?C%Wl&Tz$Rw6XF@zN5|<*v z@JLw=Xe1J{6KZjK5aI$6`RPw5Gd8s&c&i>XqxUNfkkUMeY#_ zO@2#Db1{*fO2Q$_KqA1MllQnVT)!Af&1}j*RALbJ(Jn!cWD7o& z@};{=P^N}>qEfsHBi;NIGtoo>EdYM{0-IT|eext9D8w!fu)v=vkO#{LlAXAP`1kKa zaKe1n%|4XJ1vPyt9!#7K+>*dW6&gWpIs@-o0>?N3hZvPV0rRo^jK}WK@u_X@t6{A6 zrP0)e;+A}$7x~;c#q7iIYg@>M=N?zm{2ZWx$8oRwd5;lXOBNSvXNIZtYgOg^_NAZY)ryR9>qg??=Kh)#K<4ZP$gV8kau`BIhhj(n(^3eLZXTfaU?LPnhQrRGeK)(iuba}u;c1sX}w`CW?IU??c zCoFs6bO*`5jFdYfJ1RC{oGaW5B|wJEp5qe0JRYHVr(eJ>NeU^44KxH^sd0Ecs*p84 z;10_-j;^e(^}T;IQrbA-C#+PtN9XE^Z>SCZ^i?_8ke5WBe(;$ zW;Q~Px`_a?NOdUOLroSzkF$ro!^xl<(LsREHf#6;^C3bQAx)5!O7x{7G;V+e>DwWC z3uW!)TGztz z#ots&$K9f%q;jf#Ra}dzukYo>-+9Yc<4KaZQw82hT67Wc6lr#<)E_Sv-U~=9+93ts zKMi&Dz_wI?wo#niw@nnbLYUEK9p*fDj!x{vrLDUGHXF9gO`xm)?dV>4rhe>!$wuKNrUJf zUUVvJ=EkeJgZg?6J)kk)JV}WVAHUVornr1LupqWK zJ{pBfb*1h<)bqc94-Y#q_I;V#*f)DJ`BZ}TCQi;eE}Ohxp8j)T0V(xyuOP+Zn<=2zO`^l(1yeZ$82Lg!nfFCPh(7vkF}9pKz~*;?yV7ejxkvs98wr z9NO-`qupnHRhdZPLl1>InTSwJm~Oo2wt-Xl;yT%Pt3!@XU^Q!Oe1Jhv`~e9uG>!?X z^Kgca3z;;^nGpv1%HEa(HFNg(tF-2)9uq<%cvS7+u~}JWbpYG3g+3->wUSfx-hIPBzI6n*FkB&qhfOoSZSbX-y~6cE{XNEvo)Gayr!@ds)JA32}ndMns>;ni_H*4 zhtdZ$PukS^b?`Y*>7~gg8}&X|dzStAkT{%pW&+ucnq3S@7)h)OjLw=XS@(;l>y4nb6;GjC!4SgQq#4jj29+)W7yH!82J-!6S`q@^kzSvq~*T998pxKy^rR_Yn&=Y3w>io1-B zY-tz`jBXnmE`^*L)={mK{AeF@jidKt@7yn&0OLZNGEG6@gv6z?Wa*`{fDL08uLT*0 zu&^kHD{GJKzs!#MeVQFrQS*}N>?vx$o)LdHb#8F+f{enM_xgNie_5Ztsh959QKvrS zGxJ+2^}dkgb$)S)-?Jd%I_RZ~J+ye_+~ujZn)z{{J6ZO6RNML@56`M95@uQ|KL8!$ zCS6*bw#)Ivu`vnRnvVNBs1<|BY;hpj!w?n?A9dh|LNmh%os(G2IPu~A%kBI7TfAlm z1(GVAr4Vv}3O-{iXgcA!r6TdO=>Z^Ycn=%{7sW<-{*=Jpi!nDRipLbawn0y~O{;rE%kvZDp zcCpR4BAKs`crrZvPD*vZJ#M7_=MT@^f~iYlLj8%gWk0K8>loww`gbtq|MS3P#;?e{ zT4WzyD*O?h_U)5La9)NVgY9IyEJxA_pBxoAed~h`9iMN>CVK5pXk||tB`%x@mQT?^ z@R&RHYI!+kZSJ~#S`fw3?j8S}mlw)tU>sz76509ejB$;n|N1OXx_d#)_@QGA4#=c) zsCpv5+fzbsVd}w0Kw340TJ%lMon!p~FSJr5*w|`R@5|i!)j#vcxPX1BBB635JUsjn z1Xh>O?p+$|;JNhs+wlrm8xZ>g#X=K8#l$Dy0Z*hRlx=tLP=VYERVxvyb~M_da=k>P zmkI;K?Y01_olqt-1PW`GtSX{)tbm0Vbs*$*Mh4x07>;~5gVlnDX%5B^3M3a8opb=7 zn?MZo-H1d5syRsixJlhmJPxJK9w9ugWtNJt+tGyBl&Xu!tD^>>tB2e)6_zv>HGayz zcdQ1?IfekFVNsY)1X)5A$hV@yN_m``Z-1L)AXI@1Kch@8`OvSI*!g{07?7+;+pT-N z^^Tg&@dJ+^85-^JnldoD@$TKy`s@^sVfn00&23-hQG447gC>xeCrpYKpO(mJ z_iB%?%nX=~9Og#gtdnkiHd7@Uw^uVff#1)H{{T z79(M2!`x$bq>srRJY@)XY9_(v;memhSKv-OY2xga4^%>t)L|oK!s7t2$@ta)fl{JL zc=X7D6yi|sHefAgXq!8Yx>}r~4ggyla$rA!;hTzL=G})6PUzs1R!vZPa+BsYf4*uZ z*8)#hNDt?k@P%b#4s?A|HZ^?iWg!C=u)n45P%5DGU0=#0Jo~Kq&AgQTg2s4-w;N7>r-*<60q{fS@vn3Cu z&8OXbs^_12x<{9gx7@4rn56yqX{JoYyRJt|bK3LqS&D}bSG`7h+XA+cHuDV*7~Uth z@!wQ_w)v!4@^+>nsq6Fhwsq~zsfc>;@kqU|7sRVXI(ydkjlf_Bk8O|4;Hr!W zumFgVbfS(8Nl6aRjBStEV!VA$1=e?O@9S+N5vonaR~tsORF;tUlL8+-QpCB*0?iP> zT(|)nu|6lD6^PQ$U%JGZ+>Go1lxM&bSnD0;EP@8;e<_R;)>HDtj0~;}w7rC3FEPnF zHWna;z8up5k~d`w;q8E7R{Y09{;s04KT@cGfnH+C4cQ4Y;`?im@4bXn27`ZM07Z<# z;rbS5hZJ6DQ(!m(YXC;{mqgSD+(mJc15YO+c~Cgo+1f%Py8YYt@AU}W!ITS0%7Iu; z_=0vWE)2LtK@6b(5$Pwu)N|S~`-HO#L!lKt12@TU?pl@sJcRXgqU@h3o?P@w6kWA2 zWc&6$()7}=0h-U{WUl>2F3)_Gic2nEo~0|V9$p%zDmleca%GJ`KFdld(-u*^Gtt&zF6f$G6wGjvW(FeE3ZL1oy_Ji^H|=3U6j*q59du zN8z1nd^1KiO?7LP|5mh#rmLevamWG|vU@LP&9AL3L#-fLUtcP;J*ZRlYx4ukn<>Xt zix2uoUK%bMu&90a6V!KD5nW3&fNzO zqA`5Ki2v}Z2q0BkUHhve33VtsV7!%<)n0A~j4%kB2%v7}6)yQ6vA~xR#KJ7fgp-$9 z;vYC^SCod#A++L%_Z|*ME4%AvpPh~zJEo~a<}5MwvGm?_X1bD_b>v3+ZNOoJ;C>K; zI23FeO65_zy~`0R3gN!YyaP;U>ycCqFXJ~|T@oc#M8|~07+g^B6r{nW51+`BzABFo zsnS16O7ig8Sg%e%y5;oRg5RgQpr}8mPgghc=$HSbs4iogj#^n+pzD13`c8Giem8!% zqU7kuB1Z!gcLZ&$U9W6GVyMouYR~?@+opZB>s#b@8kI-1^S1BYS;bviK^=TGNZP`? zQDx<`=mw{n-s=n+#GVEZ|0rH6Q+5w5t{HacVBl*Rm;PA0?bMeoan0G4Wy5T7ty`>G_h**8;@nqq0p**~&xI~i*DGk5QY;C(E_LTzs1Gn*_iHgf zuGGd}gqHHu?bBa@XJ%m_vIvtLGWA7HLljgP;Si!!V9G%JG~t;OYSs*!lWPqPny}pC z!nRf>4L&HYsRuO#ejM97M!#Yr3lK63vtJ^-k}$skG)JmK(?n!aqQ@kxsz@Y+#zis{ z(K^J+xqlzPSj$GV!j8sc>~~PtEu|H&G|=e2w;PgCk2El-*k_C2^~?noSkR1Lv;4nw^RM~3?yj_@>w(U z(G?l<28)VDTnThbC3e*c+xQCeT=Z^crA{dQpuBKx%S_u@=V*E7*CQJDPU=~|C^EfH zAGNjuFTWtS+EMKvN26Dje1}-WR>IGF<5`{o4(f3 z)n{H^n_4C(12@(UM^^rP9ru_MeRGe7%ZPXPv}aftRc-6$ZPbTiDT9N(Ykb^)KA(6K zG`{ki%=-Coux3oDJeT3r=b1Tn-@u)_o=78_bKcX-)cYje5l!dHA}|w1eKUZ{4g#Ja zv44riF5CntO~ zrp)OmkwXJyEiWzShXu6jxvFPV?`?%9MN?cTv6b-Zq+KJAoW0hkbu5q5Y$E^|mpa}l zPyxbv8gm?BQBk`7yXb-;9N)fo?-qrd3@Bi5x*P=22F{RelN<2jh`|7!m4hE9fLI%y zCYBh0TfUn7bp_#dXyEP(6hsF6_$F3-wr4ZwKB>E+EB#C#7M|FV&a-=0Qe}(VC-Ukm z?ay-2{m2}?b*q~E``3HZ)Q&m2y!}PrmOcAJn@~}=>ynTV|Elv=Iu8<*Ag4{&^KZy{h_PC_v_ zd`;dus8i=s(yx5OCrSr@K5t#_y>+Y4T2Rok#c9gin0DmKw^wsM>G0S^|D&CoJF(pe zSITYBK14rtd1Nksz;ATGf0qoekpeT3OS!WEcvk_39f z#Bq_Q%aUg;;+)kW8l^(xGPxEDO8Tb{OPZyo)<&eWsB%hH)_w(Syd)-ifz@hfW-WR5 zUoOw~e3;qNh(M#An4QIg_<+%jMkKwD(o^shvU73-MMbIcP60DJ*-JL13hW+P@Vr#b zV%jx#)vx6AKN?K~839b&WUOR!=a$078k%c7n=Jsbp!lL9W^D|^M zvnB@T&ZWz)9=ua|@j4F$pW17xsB4VH-`XWx8MjQ!95KwDHd&Q04s1)kqQn0;RsF}*>nq;|GJIWbe1H!nYb~`FpR7PYE$7G+q^1}W_U$A{ zT!%wmUixMx)7nLQE(gTf};0bIWAfYv}51V>GV$nmUDPE>Bn1sMtbV(|Xe z$OOU|QqAeN+u8&-!}_bXY) zdaGcM`|${TSrS7z5XpQYMT1}+c&Z20Uua! z!0hZC`ixL}79tc9g&Sy5(@dVT3^zKqnZ}}BGuTkgTD7!cr6`Des@j7Q&{50tBs#rt zOYae38N$>DEDp|}+A%TNR|Xna|8TkO`uWN5NrIT`G#uqv+{^B{+3@$f4`~bz9n@+p z_w`csKJi#aD(Jh8Hdx8ebMCRR-gvR4Q+0&_BgsHm>SM%O0^1z# z*703=ft}^>ts!hJPzBZX%s#w`)lgr}4JCJyR`5gF12-g)F>|2qDve~Z`-P!kfxTN= zZvPh78yVUyxg|c{Z!;AmBR|XGq^c{t-fOp*ZpeuKszRC%L7hcygi~>EkE{IX9k`u2 zAU}b$*tc)%$lDAYvLR;#(r-jaMB~qO?Krz#+sv05z=XVO-yZBdV*BS6ocW?WYuAjg zT7G&paVs@-9g-NX7Z{&!58mhHz4$hgE$N^;LUOeXH`b#fUmJzm&(pQ!+tk)LX1ZzR zAj%Smzm5GFG<7{G%|D9G5`8Izw)-q(7FjH5o+@YvXR1@%m_DB~ z_4)0t4jRy=2`9qO$(jw~q+5>mLXtaEA3DBe(JeDfNNU8s^7io|ynr^%@+fZt<)F=z z?Tpm-ck7s8J}%$>T&XRhyU3?;xm|XtuthK9qTri{ThF78TpBMh9SbC>N?u5jQAuEp zmjtmd7#1pge0*;(h0boT*NKoK|5X=B-lC&=LP}umWj9+X5{C<98ab6VB2f+e5X-;ye8c3*JAV zv3x@Q`{$jFE5pNqHvU8Q_hY0O6Q)FZ1q}XZiLyNl$KUgz|*>tm>564%U_Fpi1Za*`yaQ z>JoSOJ-I8$ysdMkhK(cb%d;SH!>Tu%=-Yi`BUx=ReM6N~4}vt&(cpw6f~}`PED!Ql zs1_O=9StQ$_oz5r|ATNRVzO z!Vu%*;g7^BfZ_(@N{oGTEkBi^P|{e2TN%gqW!6yb4^0dtl|xT08DO(q;m7^?4fFJG z%JtPm?PsmEd&&8>2FW`dre(fu_cBo0A~0Zs>Y=st6P`5pLDX2_f2#rG3_~$SKA1iM zUu%L++}fId!hifxr|L^sB~9aNxb(n|iv^A=FHn!iqdxjkSWgv%Ii;p@krbf;Hs?Zl zZ}ro~%xdR^KALenc=x_;5HM~0mqcJ|)x#>yh5;|#)hBt6Rrc;RpVBmr4gOw7ruyVP z%G#N)h?A&O8kpu@jOLv2pQ5JryI2U6DkUpVjGt%6wwbq^b`5{k=ASQ@J7GrV>Z-Dp z&+@xg2K;Ea9SG}a7Z(>2itP$Y5-hW-Kl-0MJXYAN{CpqGrU*g?XjESTqc)n#-hGzX z^6O=~n7_RKM^_D`cGZDJJcA|`l`IpEyKr!Px-MZp#lFn1>N{W9_o)l6p9w?+RfXgY zoWd~h#hWNW{y1Fi>|xg=Vjy}!Ne=Rq&d00v=r6Ki%oXid4QnQ-XwggNP3paF3JWN^ zcYs1bJko3XnJ&#guE|rqPfQ&;`T2{&#rX6xWOW6B^`@CUj{S*al*lGlcPv@zcNGvMclt13u?43$h=Qf5Jft zHd=HMNb5(FF&4^UYQMgyX2E1-xM(3uqiXbVGd9$WuVtvmg|gh8+wf!U$TUL zNr>??rEn}+QlL7Ltr!3jFd{+SqNu;hp2ORU>mda2kYp&oW6TSfhhiD#jHC`H&w-VQ zLHO4+x0)b)M8x67OsklmAecKa79{NEK@>n3#wO?;P7Lp+qoq~H=mst7RSe$+z_&aX;qMI*`1ki^Bzs9gLT z>rg4oU}}^JbOQvMdbpR)-j*E!&z9(i;PHi}g=AA$3&=sE;O*<1l9wlOgK_kDBIY1p zO37xYZ#RAvIapsGTGy6Tpmg-SI;q5kCxa<-kDNT&q8xyioPpDLD|2&m4l(kaFlh%rW!94*{BdHC(PQ(D zu{ap-_2|PtI9;Rv5V1T2JIDzLBm?Oz63gjnXYkc)%k%rArI*ix?y{HADkq-ip~rabubbSJxTEI zMS6)D6qzk@c*HB(bwLOsLZa&_)?o@Me3f01FrS@7UeB7}6dM;;GoG)=q$xZNIr;fz zj9kEB&G|jN4Kz9nICecuq97Gw(kLa~-aZ3)X(3wj`rT-DHOxT;G2rQx1%m2=Hn0#t zJP{Bmg(JJH|J^&od>2f5UC;%(z=tkD0ihbIdh+m!Y9*MNg+JcsCuVD8psi%7`E-St zq``27heSj%Cc}q&+=sXc>eunsa(S&88|r||L`{9fv+tPS$h&{P8N=(iul}GIch1$) z1wO`<4iqQJDK)!#N;_U0ti&Ae(%hIX5qoO)1Q(<4%y8)Uh@gYv-lIPsbw-)QO`mU4 z^=o;ek$3k+fcE-LHMNy9-l;o+*HtXSXI>yDG%8<02CkslxU}u>GU2 z*m=Sm8RT=lZq*lIqs^A@(NwmR-EoWQldP37Mu*tgRqoH9tA{1}$68pL%F7p@GV*fo z^GR^~F?k#GKcvAe?Uj@~EutbCCRt(-|dtHal3#rgSj>+@DMmJ&A#3%Q@Uhs)d8q;K1!?~_4BvAFljm8SV$rcxVU znI=kQY@9L9dwOhDey5{Ld-CdlEDMWY?dQjhN@@=I`6Ba$NC?89Yg8(o_vW!Cm}cHY z+n(q&6Kq*^K4=2Y|BO1r3!|8|+(cp^F}ebd!k+9k(WT`*KyHiqzB8i5KP68<8^fa*CNDabtPdOOp`bA+@;~__ISmXkq>0Z~%K`)VM1+O`(7cJjMa4xm-|?-S zjeq{k{QBATAWtBIHrR@t>iCP;Eu|?9oE9-#EGC;yz0Y{d?GRbhlzb{iq_lz6wZ-@$0YYj)(w5$}xYO33C~Yha3Y@AGb8Dt14J zYd9IhN_X5aLcA_q7O+dc*Zo7xUlfRm^`!=)KW+Nb5Lw`~wmd^!wkKOwKK|?El(Op^ zfe#8f314sR`nphAVZw9At>4trUZ|FDP%Zoy+2AvcZUqAdgM(s6fQUEt?mg+*5W<=VzW3e7Xtagl7wuATfJ%6@zJ_eOCnEnQjh zwi8Ia(3gFr`uIco&6`*M^yJ@TWi>9CP7kh!U3!(^!96l^aT`qMF=tz?79H~VBT?H| zAG{&u;E?2fc^#6<7atKqSn~?wfhwo=MJE#zzJ-xZ0aIEcfngWh7E5#_sfe#delXTzDT_$?-kMkIvSlZiX zb)Q3=g^0W;7TAuPAaM8HQ*s?d33a%dLgUz@HwVcA&whEji*3{JiA9JdjlYf~!|Hw= zGYyIdSKKU?0Hi+G*k5NSJwzk5Wp62GDIn&`aSVEdhYli%s}JHcVe1%_h3DJ+?L9KBu{W01y_C2{LQTw^9fy-oSKScw0W@B~w{0kwYKTo4K`nfOkJ@s7mdl|-;a=Y->HpN3C zqG61NQ#%s#DG&Hn>u65)HeXm?UiDMGdqPasdOCow`NH*W?v_0dS1)YYHQX5cP%NoH zo=6L^7aMH zAT=>0$xzB-oq9p}beHfEzmjQt)^$t>cYLyTSp-WUB|0)Po;C#U=SWOEP-}O9)N#Lc zqVf@yeCsW!zOA0W`tPg&2Y7;Jt7trZAo^}=o-({)8`21|d#ft2lVL!n!ox=lJH~(n ze%#FwYOT!pytx(vtf0HPw+P?nUVrHSe%GZ?$O8zN>u&BVvAZhlto9H4OPS5@-p+sN zl%;l#V$8p0@cO@8fDt9XnMN*`HTC1a=F!)P+ztA^J3Rqqm2@RS3(0G*{<36%d81q5 z==ElPyg!k=hD7^&@4;OIC{-D@T;Yj4~30fLt_R9djoGm zZf-U6;GWpt+6*QO*8U6P;sz`j;cNt8z$*sY+Z<4?j33|II%TaS`cC-wH-&x8)%|+^ zf$2EouklXfbjG{dSKek-*2>?!S-poPX1Q9$ngojAb?wCwwy6xo3qrLS0`Db^6CP$@ z@u~_2eeHO)w3~tcYtO**2MVt#C>mw0{BK^@n<+j@%f`B%du-@ASx@nU44UQ(md&wl zyY{R=x+6uVe&CMkup0C-n@J1JX{F4;G|NyE@{wLcyxRWy^%&r$JtUl0e}tPKmz52Z z@)7$=*hu$S0J~;CE)mwQAoP5!MoCAoHhK|Taa3Ud z%%0s>Q0;)-Sz4ZhfZtOnFaEXho?NA0M!JQytAfBZ|7QH#sWyiV9lsNL?l#1j)(yO685&Gze|8VLoGqjN#UukLGl6m0|N*Zb;U21RiMJ@*YdbZxQoY!@Z? zxB3!GQ%(vs)-R$skgiaN)z%wOLftzI6(flV)6=lA$;i3$+Q#b} zC{|z_90bh{IRPIE7_^~yhQb9Z2h>3lrN0zFg7j`?fBY>KEovHk-Ie%NyakrXY9OK} zM9VO3I2_Z7;n8Ca2ZG$Y1i+$$KarVd<+F_aA@p5Itm4#`r(X%u9`d_qM+&-R`!!iF!1GrCP8+ zAA-151sj`wZb}4sV|cfCF68T#*~qqUs-8N=it6flZ9fMy*Z3NPVR)D6YSo{4n8Iq0Pi)bD&%u_eff0djzDWZ$vz2Ejh*5j6@*37ulxh*zMX5P(f(-itSbT%cD zyG>SEM>go2HzpO=;fdhKF>$gpFqD3&Q`sw)OLy2;dX0Qql2E=%YA8knRV*gReCqG@q=k z!{J>qOGwZ`(Hz*8YOQ>3(aQ?s~U5(<5wJXkP=c0K2FxudffWBpT;e zEuwnO#0I^yyY|~$S}vehaQj0jxe@?F5wEOB=VySegL+*!Y>CNKgki^eDL#F0VBi(O zE=7Y>dU|?w7{*Rk`Nt_(E_I*I)|R4r;U_nhQm(UfG1ssLul=G47iYttck4!^FV3B{(y-*6(c;w=;0<9mZq z9U)NU=kB{A%l;QOcwpYaz6#@1FQdB0CyFq|4}#zezP;H z^zD)Hl!Z4pSCRoE>U@5FRuwk2eObgoJ2XwmaUj1VO(1lTV5E+pk;Uz#%8dsd4u8Nn z2{3QuyIM9sD_zttrs8vIowJPYr@Tv1Na+Fl$-bKV^=b{*F}1Ighg1|3l#P4 z3-Vbpu{xQ_ukvWYb*003q2~{V4_fnp%w)~k-cn!DAQ`q{reyI6Oi_<2uu#&=z+jN- zc+OW7urPwdX4?2^cCy*m-QOgHKsh7h*LvKQh0)0P(cEY^A7#?sFJG2`St1Jd+|}A+ z2*$957f5_R0Y1>tYat*KRtf|mNN^Wm@F@zW&zlgs(&Vz{$nmgNHa7e67%Qq zFqwW7Bn^^!EjCVh1{7YrdGopbVHtU?E=DMHx5wWWJd%SF7>H?+o$kjVkguSiz{G57 zi5PZg!;Z6)0u7wINEEx=&f;+u>axydu&jEmDg=~b0A`QXIkO@vG5~x5-~kJC|6!rY zLXQX0W`O3`?RhP(8}l=iAC2N5_jxk?6l`c#VQ&j4-Z%p@kB1;y3${tEkXo}z@*~10 z;CR4x$#Q#VrwvvP23_0Bl0f*q+j6C5U6K|+Djp1=BsOt!D(|+3{tkPJwBK1>x3!{A z$yr@PL**JAQU`I=*F!>4V>R}4h=%|$c78&h?*XoW5VxIx1%?cBN`sEQVK^#fr?@v@ zw)YFmZEGO4w7EGTI{GO3Y8}q;%+Cm1DT{nBcPXBHS&Zhx^Og&kEqIj4su4hC1TZru z4?X4B`D+&w<2$DpC)dhtDP~izP;`a2hlCY1lE`VePS<-3WA$I?aUE@E6zSxSGKFwq zW1-1yxjYq_TfnHY&Ha^*b7ZoguW`(mTC5kCCGY;EqgCcyba`3k^gw21z$X=m6f443 z1Y5bHPh++usq{M4)i9yOmcKQP@uO@d+0zTX;TeYTlil?Y5mdm>j=)GV9TQ4H!Djod z87zaUx%h?U?pndOc-M*ylMm-Hv39Z))5UiVbr-*LzX(A63|Ai}#+|9_*PaQunIQ;J zw343tH7Smufg#-^^V}hUpeJhZT9)TqmAiB{|pu~j<7(%;=s!MS6 z$O4TC>7+wHh86hRKoSB&lj=7(PEhHfP{4;k__r`mwq8f10icbETn5A#6z_Pi;mWB% zYv+OEAT&$B=dB&t=3Y4NrFIQ4gBa-Ty;E9ikfrGaCS>!lBzu;ivXcg$h#_YVU}eGc zLuSD_lz|8ZRlx8^V3Cm**3zS%!K$itpmIiI4V7!Nw6bzRj1&7NZzT79ghi-|y%RP3 zw!W_JcHA@Iqz^#J?g9b#K)YBZH8HW>ex@;n4lDvkf%!84Q-M?{zH5PvfRqIkS1?+^ zZ=`u>9dT@#Z081Bf;f#{oD8v@H@p9Y6d4dYo~7 z;L7|7^?XqQ)akU9l#fryzTvlAM~v(V-rR7e6`J#Ys*#>}g9;myQKI|s2czWY{9W>V zf1?UHZ@<&Ct2C~z$KOAY$HyS@g@o4))UeTwuwKEx4=3p%qye+J+)dm%mK!j~=biXv;?&Jsp7>gjW(+3=w zG*#dG<(pvQHwDSTM^NK0wr7N@3`C7>ZoN8c;8})3c?$6V12fkTqYTE>abPUZhCRa% zkjO;FuVx7BtAshERcp+Mz z-k=Z&AxB)`#}8ofy~8doh+Tmn-2@S1m` zG?}iF680f9?JI+nC(hvzx_{8s+T_iRp<@@(?3F9Pb#YQWXAZS)`07YWuXDBSPT0}L zxKGCEJ59|`1MiKCHpJRZ4>ybUc})rgPI3KpikznYo^taKm5fhTf1hq>JUTuwJa=rz zH1V(ztP16kkUP>aW6A6mZfVPW)xEM?X7tg+9c{$F)nli^7hQ)_Eo#dg)HfQ?Tz6 zD5xvn4udZH z2_zsSvjr>dL;_?qLV*CT;3RqZ$(4nHfB*%s9D_>A!p5n{#Dt791fh+FhDHr9k1k?= zZ|y#0i0L>Y(Sp@%D}yCjXrDRuoXx<#6Txx;41Z3P2*x4Eku&iWl4TfQk>Qipd+l>0 z(jf#|M`1@Peet3tyv)pKFtg_=0nQpOw9XK(G(@kTUdo3W`YV9B3LzcDSFg_ICgGUxmv@x^dvcb!DJ@r&z|Op((s4@0!EyHS z+RK3FT6b>o`RMCA^9wI^6uWhO-6_?0kfk{Xgf>LE1me z$ig1N1R<3E~;7-JiaDm zz7aka{rfDI2|dK)ygej%rpKOp0{k{1o+DCKJmmgoO zH1`RB*G%cL0V)s=qY^IaaU*c9(*4?AxMMcAu-wPnq5zbta#%88lfc5uOAOjx2+rDQ zh9GEvZ_i>f9R3-SaUg26!-7W~nSeBs(>e&*%p)_IG`2b8`?f8_leK?7{`B=3@owyT z*Amcnp@8;6Vc;U3pzYd4+XTB?^rd%p(SeBkI$#S?M=S>ZVD6rk`N+|6urojtGq>b^ zT3YYCo!T*e$xHH`cR|AQG0M<;vWKT&?sLvyPYONqQ1E>FP+9prDJdAH)*!8eq(I_V z{Nas>f@KhJH^Y9tanE~kwStd1ZlUr7)tcJReVLyAs6-OZoDU}?Z^Ybik5(8Tc3|rm zqXGuszcAG&WfXp4@PcbQS3M)}kQcjiGCb;jBSnCyg_2Qjty)XWt|zt|DGsElfxw{! zngOhmxA(-#__RnOdugFK)wd~pyVjI0xr;brgDjjz1vd#@U%YXFQ3~Ur3`7Im`ROF-QU6E5YF(aP z!9hVzFv^pYmN$y5RVXHJW_7!gj0j*M3S40GSsEo!uBQAhJDWZ1O`R=Z?B?yANNGNp zwLO?=&PQiorg3t|3M0g*u^(nAo+&{3QIZOw%(&|Q{@(?%is}naZXq(d5zx_*!~og` z!s<9}16K>1tgbT18@luCKi@Gb1--^p5g{RMvbz&}LP9*%JK#5K_Yfl$V5n}tLfQE> zn`6cfL$kSt?^M+tjr6GJsx*=?neYE5#ZEtmeuHxSZc1SDMTY6Y@ydu4B0eQS&Y^u` zCNuTEo;n5~at}`-GivMU!Kn@X6?GgD8QBIM;xQl3ORNZyh3p2qiLn+wbOgWIMjW4> zngevs&JPsm#C;iW6TH}ZHq#)tam>w|<%1Pjboez)ff*=ddQ9r-%aT_!GFtzv_`IB# z@-6Vi{k}yBzFcN=)7hF_ud@oG+g1S@0Er+ef__HLfdV6(JFNhx;P*T8u-b+;0BDw0 z%-G@JguAd}L&1U=&jZQ^EEg+Aq#Yq5yarqNh6Nv~-wSW+kSB;X3wXsKrIp-&2fP-=2JXcIe1s?l81?IQ~MB zcRfr4XbcSJ%E1%Ti5@5SUL=ALfm{@ZRI<=vfwAq?NNEOPTkVgR-2hHM{5Zkk&h~7o zth-9?Wds`o9z;S8phyt{+JpE&?`Ff6(&X2?+%$nujQ~u5WWR4ggKJ4HfrJswMa;A~ zD_}zxQ}&Tu2<;+`$4xUCnKXtk8C)0Gmdv6mwl1@m1+m8yQu^)ow#&0n8Ufn+o+190g(G=NKrr3z5tY@v(Qi|4)*K zgt3^KOXYO}M|K|6c8qQ*d+~QyNtcqKwJ;B@1MD7WTtdPw7#;G1MPTV94kl*#8j$t1 zFfL>6%)I5tKwb)$?+k}p1nB!TUdi1tc>;U2`D|BJqy_X25qZvq8o-G63jz)W@M?-T z|H(JOW)q;kRA1Y9>bKHFhzR7s+CgnIv>Utzt{z$~wwKW0PX8sOpB}P( zzA6+@w{hQKOBg@}KpY4soYDZTK-h%kZfo}dc7%?C#4;R0Vx=#D=j3nxQ)hz9UB>7P z_i%)|=xU#enDu2{UzSB#Njk!NC~?r_12@9t0qM@FcW- zLHq(hDvu!l93fd+OxL3Yby3X|O)zKTAqSh2tw6w*+J?kqW^rHFdiqv9F40jL5MK(% zAhGt}`-L4gx3xu#0^WjNw4gsD8z<-R!_mu1HA|XSVTEFIR!D7Bn3GC z6AELLgePn^3@C&VCWRCQ>azQkz5V?PR#tgG_7!&?HmX952eJIZd zq=-NH(je0bueED4k}cw!8Pp&kZ>?Zqk@LeIm?FImI+(x_EPNw?L^fDWj1mA_Lbzb} z3Kd*j1Q0G83^wm~kXS|m^Pfpnv~DCW^ZE0v>Sxk$z5&cr0oE7T*Ot^s2?~+{2Ff5F z02NP4gWYGXW=l$VfO_&|`sUTEm*5s?M^oOsc?Yc|u>8vnk47$sxx;Vn;DESJBG6Y9 z(xQYdp&SlkA>DNsP!eW?iYTIH3yW(9(tlW_njoLGW5RqPnS~9yY_(b5hnsdMu%~2UJfpXhWG$&>_kOp<}yq2wx*y{~c}&&{CQ~ zEbqp~$I(#G1SevYQj3)%aaf&hX)6F|H;m29RSc=>#}xU;V%XRphTdP=3)DvKp^JMPXYH|+MvIOjshGSVz+HeKA&v?hu9eSH>Dyl zD^M!~8^(VwaGl{W%Dl8Zm^rviOfMP$sq4KC5=KJ$o=1>x>ch~~aCvPl66Wjo7XG~( zt_EonblB{T*G+x*U*>S{!256p;*l-&d@$#=YxqE}X@yz+xBw8#k>X5ANohpp-xEfb zYMZLkjUITl4=pXRP>41w^s|Bbq#P^nQx5Ac8;;7chG)EnV52684AzFkg8sKN$sqtE z7HeuoQm{MVHaTQvd=eTxcF;lFy&X=`u@4{|u>fUZfqn&x@PFF39}ubMZ%7uPU;Yp+ zm6(Vq3>fg>f2;}@r_)oRuMt-tt0$c!GrBeOe)Llnsx5%*^3 zliD)9GXhQw4d5RaK!?z793-A9put2ykUf($XP&I5A{})3vqA*=Px3>&>-5#|GqQ{I*gTD;Rb%f zIrb_yCkK%ug^8XbJckO9#R7>c)y}K3FW3Qsjr=*t>pcYRLTC}7j$YJ*rcoOpvJ0Mr z^~Il0q9?iRyI%{mSYcX#LLr8~Q1ruo%awy$0or;LGK>I<>VgPhFA$+p0Qh``v=8{w zFR&k7-bw=rSD1GFgopeO(u;vX3V_|IDWl$}AkK=sG?-Twe*L$o;9SBrhPT@W=MbXY zxi0i}the_P+`K%LSBN|(R5e+k{sJ;J>WK30f7aGO^brCEB-lpd!&!=;^Z|Tk=LrU= z0DVY!{#n1OP!%bJx0|O_fR;>S2vUG(>(DA!z=d z5Vo+kUa!i83EP{Sj>ySXWjB5qM7%`W8mP1;z~`!mBt64h}cu>?$&!14vK^T!@vOUGc+vP_aUeCB*Jn$9xtI+GwwDc?y8s zTS?6Tbh!{p7f6N#L9+$XYJKqml>Om@c5W2tl`-HKgV8W<{j)9gSUDdj$ZO0XhX3oL zp)6oYLJo=zwN!Q(H#>}BL4-0IM#jCnaQTNIF|`WVJrLC`%!043LL-KFIWw}tNcy#) zH4!L-#z4N#0BSvU({RiVL5pz@c2#U9vq~JC0dA{9vMiV&!WRUuxpi=m7@%trT_N{ zou^9lVoHUF5%E|+u!b@e16qj);@vRg<;zgyz7W1GP#uIv3|&BYWn;27{)<1TRO$o5 z1<8t>;VU6Yifp4PoJYvSbptf+0G(myX<@-8?zS3$dYd(KHH!F^Aa`85g-8!hg9-IQ6*@pA}ZDM2uX4X zIl#VPk!6F@q}@1d_#MEtX)TZk!hcsFCQ@36%<6xuU*WhFss!lXD#18*960yO0Cs&& ztBeCetwVUJ#eH1L^qS5hg4? z^KOF3|IAsD_dtNyqHv`_8CS7}94K%wjBptsZneKaOhOp|JpcFjz<1UZWE-#nj)4le zSJ(+4n*yyWn{P{D?= znXI{vWSsxffD1?inA|!*2m&(3>%%LrUnPZYOxdAi7?Q(t`q@e+n+JRdiPE~=dmr?E z`qKBk?uM`gg_x%p?P%^w4y$TPt{;!OJI~#fm+7goRcS)8J=)7xpC`V2=WL980MGBy z*RP)!ID6hmjxJc_8mTReZ#g-`!okP!YQ6L?vBTVH_DI}QF!SNCDvGI7v*ZwP5fIwc zGf-Mw?;pLKRr00oOYaw1+o!e_gqFR+-1v3f8|d%(B|;hAn$1(Kg=gOQ8?rzBnJqUY>gTkNuG$jJH<2VWD98S1QG|Gs%r{Y+(KxeV&X7^WaLZtSnf1h% z$LCtai(OaSzx(Jd-%#Cv!YpQ(SJ2Q1uZzE-EmOYSg(oL7g*zx z`F{EMYqpv+Ww!2n(t6v}kP)Z+xc)4)l9v+gC=EAWosuHjC|8n6_82wq2CcM}**){u z)Fjf+{=LVDcp}(=TdD7>>&@1`l%fKj-&HcZKX`Y9OQDd3(hkYfp&W+Fhr#ptZqVJH zoNmovlH9ng_Hs@Bgrwx)@Ev03n+G@Mzb$Ngb`16o|C8OG?*N(K&Qp%~KJ#H08VVIo zmCUn@!155jkj}8VnPP8T&)y4vk_#CYa!O;Pkd@(#VZnb=@W@il=?rJVey?n-Tq<0R zH_a(7OncMJp|xWmm^K00O8D;9Bo+~*mj7=0KEWch#`;r%Pi%uZM-Lz+;)+KWUc?8^ z+lo3))w%U-xD~Q~M{SQp^~K2>lBN7l?uV+O<>RT_JRC;tbC1gVuAdY*8Z)|I8x8&9 zLZ?fje(MJu8c4(E6p204N)JL>Y zkjMyDQehy#uC-nGvm?)Z*eu$epu(C-wXg}@IZxoefCijk5xYbHcfgWs`p|hA0IpDq zS-Ofk%Z$#r8d@arG+YI%`hNT*v{X^ny@O+ZkH;Uw85e`Ofjb^(b?}9+;k(`C>i;Ud z=gb^Uv$K0bY>_ zdwab(XJTp57=xF#S^j^|-Ln5Jg%{HNV1V(iF)DDo)5*x+`3j8~jm^pkkvc`%%;bJa z-3RnP1A`c-TX(#I-j)TeawId&4>8f*PpzfI_-J&)<)aao1zz>G>+k%# zKinV>svsdLR)!>Xwf6T3#ynHEZzP!~tTWlIR-ombue=z#qi* z+*(t}>Md7B;Oi0Us_6;cFLMJ6yXCAFI2--H%NvJXVoyzc{V2RQH)VAlKtQird8@uD zi<37+Z*eTood2TT2c$}#awk?MK6+%6<$gL;r&-eY;j)H_v~2OOQoh`-7wEMYuVc>X zzTSLj`w$N!6z#){2e$|B^i1nL8yC^bFm1~rOG?N{A__G^Bl9J5D;&qltn;}ySJ9P$ z7C=n#jSaiAec;=t%a>+3Y;I*tIy%(--4#L6TB!YBB1L}5`E|m3j0o3{Mtif9rYxAY zx+RxTxT?4qsEv;e%6ADCojqT>xZwT3es9TQ@wa+^yJ$J|FUCQ~kN$(wvYze{>}gx~ zjtb?Tq3#O8e!~802k*5tcDKo|gjdI}q5=d-t({nxv55#oH5Ui(!hH)|SmH(z$su2E z`iWQMrL?q0`VjVzEZr^x_NVZ@((7ugA*|&rsrA zQCGZ-@rJ}38;@I*gOX7DbqwrHg4~--xbwjzIqT@7KfevD+WDEJdU|Z{W0Y((CSLFR z)T=q^I8pdmpR7)4J{EPvu$^WsM*`M4F23|;G^yt2zxjX4jvC)v$qk2ib)?5%Ud1MQW>Y5_$X^k zBTA-t`j4Lx8E*cbBSh65%+s3WG|IsG)xT2yru13ye3&iecc+c7{58{`uU*@*?{jn) z--_0_VRqE^vp_2g#*VkRF8zMqwl1@0nFQasGHW3bSZZaFPAIG_O4`=Rt^tyxu%jfc*k zMBD_5WWBdh4=7@Gs4+gO#lZ=!kgt@jSWP*UysjGOe7a=sHaSiRQ5qGH{FwLavuCCu z8hE3$pQ~2qS&-+=cDO(ES6=_CCstm~YdjPjDPdbrO|29%aU}v@r5dt0xiQgSzw-4* z#dYkDL~=6PDA+pBQBUP-2|AJke8kOFTebp!K_rM7%8wv@Qda4C@k@&ZU~(EOAUA^zCZnH5M21Q_&dC@ z&oYm*zq}Ipw6Oay$GVe1TaQl9h~AkLewW(MN%XvNpA+?P&0m$j+nj)otNw7t#IB|3 z%EFttV8^?ry`DVHRn*VRSmEX_hcnW5Cn(8})i0J(%W1q1PtV-cmQXiP zr|qXqtvGf!9?dH9{LUin>XJh5 z|3lxC_iSc7^8U~KF`x4n$vbO1uRY9IM6m5UM|)bj=lrn+&3_E^t6%1RDSbNfqALL>2rFPBi3&S`z=`cu^7*Vwx>SSn|7` z@`mn>MDIhUbF{OJql({3LJVzr8ljnT54GR^IL(xH`}BFNXlyXO?s`=unsE>M?OVA2 zvuA|lD3|qiSyNrur_tyAw;4v==>3S#uaL!SSWJ41dGZCSS+vC-O*82Gq zo~g)j;+L(aS}N3R$F-289E<$9Uw?}2QsD{dMpB}F>AcV9!0ueUx!Tp^QsEL99Ey=@ zdNO-YWV%%MW@JwrB#6>akF*4y&iO2QMi#6Zmhq;>t3yK#M%kmvricdXg=Ez5O_fY2S>Kf zzHZT=U&+ZvLNc@6#J8c#aj)VM7b3mOEfdSQKYidG}$3dZqoHUQ*6vVu+yO`M?U3&D| z$3=jQ?5WjLQIVt9otp2>bQQm#HcT2CCY)2pZ<=F${@_|kN`Hj_1*u%NRzyg5=!Z3I z5yFuH32|Xat5OY$W2ta8G(&N}SL%9F5KZajlK-BYLW9IpvFYDA?(6(1qFxmzK_z7Mw?_3{)3&#qmPsV~Q5r>udaInyP}1GmSCw3M z#oMrw`V+SpKhtKLKi#0rc?B^vwqIB>wD`pg|I9CB{?|x&!OX9TIT$d88-FME(XcT0 zNWjHyf1z>*rg5p3pX)kbRPQP3%9y^7Kl!mgewKZt+|NW+cRnv3{kMhGSKe%HnNwVm z9b0I>J9^NVo`sEw@t1M!&D71scb`-IIS+{J)a*y%#`8@WMU3o|fe>@jPSs+FL4FyNUcT;>&_$6>wZl-Ksh`0%S>jGrd&{u3gga$qOoTcqNIm!8YVwhK6d_s z`BCjX4KmO=5gFd^EYu`2xb*Nz|4`pYFaBzSu6>WBn)+>?GKq_O&&I zF;)`9A{;?97ZkR)yD#ad>ch9>l}7cxHH7NQ&fq>Bq$IimyfY?K9lXuq$N06qmM&@z zQZzU?3?W7w;d1YXj?PK(V|yawg=ex8eU#S{@7~Vm%er?!fE;aw7xz5u_GEG`Uk>@) zcZGPYU#fp)XUAphyJWw(1U{syp9a3@sy=+XCgF2DZfRQ=PhKR5jBGzwQFCq3jOeYh z%J&{7ZvC#M%KUy&()t@K+eGI6RxJnX1G~9uSKIL5Lt^x~`|bxt!_kD)!aoFGg$&?E zNK%`17|Gn4)1KT;JkyGdU2 zixM)r=ktLBX7OmP#4!wW;xgRg3Jf^Twj*cef+0`V;1KT?xzg7SFeeV`Su=A(`ewF+ z5}O8PGg*pchH%UCKFy9I>~61^?`y`o_b?)$4hU7tdL{PDes(bP_b~w^AXa_o+32Ly z6cMxUFTyH222>QZWs#x-XN$2j!_Qj?Z)8^niWOax2az-G-o=*NCqtJYWq&1rPxOk2 zPmoU@e!BDE4z314&-ULA(qz(b{O45L5D=lf={ZL`6=ui}BxL;Iac!CM?-84+5eM?G9BV@aKjI9=|)nKFKtrlXC5XEL|pbvU&ohAGv-qkMk)0ZjJkk zp3U)X^lxnI&9)3pHH*E6z#i&{@65c5?zQnNFu|D_%Z~~(C_C60>Y)-M{V#Y^6r)Uz z$I7ahia1$TU2l+7{FmXVGPDfJMJklERmhF(jUGAJ3~UxY&(Nxf>R7Uda_eYwc5D0A zvDgoHW4#<-!IvpWPBS4^-7yyy{5-24`d|46G3)K2pYUJ%d5PETO|W<#bg^t6&dpYE zI1y&BO9tmRaYE66TV`v58%ZeZqAOq^UIj`#Cf3bL(RZ)2Z4utZRKSv9zJEK!-H&!c z$YQpsDy_=QSQ$eGLo%^Nhl}CGY{5OXx)itW^AvUkJ)V3I?*ZNvi;5Qyo4gzgP2yRzww}Zzgp*&X&f3>`Tm7DK7gu}{EJryv6(Q`K^f9mes}$sv(1W@$E4ISkZ`4;JpFigMEMAG9Z)t@5 z4rym4skQS?uOdCQ6AH8s+KQ|6Zl@;YRZ{grt}|P6MtMGXw!{6KLe|nd>3J-uE*zP7w!$nT)!F1~LiDDGDZ>1u3#%Qo^O5lUyh&+sZTF8ELw4!q z0o?)pN%!kD2NRzM`o=%gNSti8dJOJ}@@)sa`BcGQ@tofL;;4&&PVjGX|roX~^Cy6`HKlt3vAnmIHPgK>uu5N9? zK=(bTIVX-Y0!XUwd`tUfJGCkhP*-4%tui6Vw3mmklhw7dX}eIw@eWUpBm&CE+x=<^ zK1#P(F0+z6r)KW`rcKRp!r>vh!z{33#p0sE1|@xbwehH#%b#95zDB-nqoXHQvjlMz z^s`0R;T1XyE_3h@Tp#*TVgDRFv5udXey7->*{LIS#n4F1cnEzo1Xef_)+K+#(I9s1xfugqO zZ`l?rl&ceBH481S4CdR9n>6sr(NS9|WD4%*i|Cy_Xo#yjmn*qtzf75U6W`Xt!%!jmM#-F;-D3 zdd#_NfvV~|37E*iosyo)AA78#onkZHm_UQqY+CG-_r1VFOq=(?VzV^!ljaq2HgR-vgs?z3=C+fehFz}XkQN3{nleJePlf9 zKG(`DakF7)On*ma_Dr#zR{y4qb@G6%*q<)Rbu+J#wZQR<0i~x7HQjGe3z9t@Gwlqr zyg_^u=2i7S-&ynUpG9?iQ19E`-zkGBKx@2|vz&a5VCFL?M&D#?7Q=%*7SSaHFZKmO}w!OrB*+o+45=0h24bK_oI}E z+w9xQ@Jj9W5S1}O&G8%otD3Y(#vA7W3=-aR8|9TH3`*%L?m}LUoscdhUgC6?5YrdG z{eGP+Swm&f=YHk=xU z7BLuM{YZ(wke^32zOJ09RqsR!dBQHfIV*Xr_fxL+vQcJ|#_x~*=+Jx=u{Ja8en5}g zLvs1rYS0`FNjE1ch*HK+lVk(JD@`((&f6|zl+h${mkc-qlX-BRW%2AK9;BbL8ozo2=^O z>lIc%5j?fRrN5#--;=&9OgNaB!5pHMw)B5kfL-^T9BW3D_{eHNfEF6Hr$! z(?8D8A%$`+3i?~fpya4(Cf|0lX}~8IR;9D}nGh1H35#iwD&fmU>QAa!(}a}N$OFU4 z?DYE*X$%J96gHKvmG~42G@l8O#?uNzX7I;AF|QwMz1_DORs2KkZ`QVre|}(ZBm-H7 zpx?9U@lYIRV$JW3+|9d3cr7>=ai;IjgP`F8$F|{h_8V{UK3=}X2BqL1rMj>Qc9f~a zg5Q*{Q0avB-61GII&Kf*rhHaYXpXZmYu$=u{NuK)@z)FLFBBiEX&N=tt~*=(=IZD6 zW#}ar{;9)NWtHN&J^A+3=mu5aS@NS^f7ORYj#0z%8kKu3?PBmUaRoY|I@~&>;R&)v zX<8Pic-e9jO-pxrS*3G}KB}8^QrmxHU^7+1QS?B&BeIPXPiWgQrYTT)Cw}hn)`L}R zp$dDJ!lKhGIN>@^9M-GfKdW|DYz4n`C9HXvuPLxABh3(@UtNV zt==yqMtZ&GzUE`8lT^pzpM$Ms_!tg}$Ks)*4czoEM|OkO$SfjSg2&2T&?K)(A@#aF zo8o%VyWsMz87ZE%I?U@u)d?X{FR`JO2N@=HUu?AlSq62SgGBwETPn!2<%hHXWslzW z_;Lq!K-pFe12hIPTEiuNe{8@(ZU0%y9B+o$Wn)l%6VxPo-mGIS)7H1p2g=g=Ur9aMkn zAo9x8B+mHR)3)1#5t7g3B8DIU%r#6?4JKx`LFK-2edDL?0$vNJ-x2E(ah0=Ou-0Za zo{uBiuLTv%ytK5S>cA&x+Y2`+Pp(@G@*p@}WZtWrpbI-^I`g-Zm%2C%{Zx3sc?y^R zo5D|_O2;r55UKn=f=xV9qF*_7n*5rY%W^Qlsnmb(3Kwc{f`j14oD0)e)Pz z$&U-`R;F-5L?RC&>@8s(tvdyTAsgc+;Tw`oAx+N?1^9>DmGwmQn~EOjR6&0R>4>bn zNq+>o>$=|!fA(>hzJvDk-t;t;>bYSMv{F?XHGky!P`~99QDnZ~+TTh5*#!)=#zjNQ z;{9WxM#6@YP1I0qL4D&2bcnFbCCv$Dq^Y4Vt4uM>U2-GbG>1|3_cfvhPx1@g8^y-k zkf*^YfhoDSqQ1|zUsN(!@*1RjtId@X@9t-REmr5v-uqw*>KzRxJx*P(lP!K8&exBu{RNL z2FxxMdZmLE_Xr|L{mL)RH$?_Q(HlWC^bqAWvKa_NiAPH>Uy7b=bG^US5CqefPnIt9 z^d2NSYQ+!^&CP{(^@?v?580-+4>oI&Iu}On5h^iyYL5V#8koc(WyN~MMMXzEt_H5P zIV(!){(z%w3-c{zdjI{u_)@|?Y(34Q^DLP&3)N(BW|m`> zWM#8vXO&MubH#AoAQ+ECo+u2n)2MyWT?fA`5jv>i?2UcLAYNdU!=`~9*4ZcIw_Q5t z3j>P82`ZT3Lq;0_CBB|8FS6Z`%(O0h0om$5QVsdf$2_3Gf2%PqH8$;d6Gp0^K7VPC zkY`0E$$2`dEQ^-7&G4;I4}(@PtDjOR#5qZs{lI*WhC_ru$r}Qvq?}3E+sEJY`tKuu z(NMPOm%yMVCjtB(28Gt#*5_3gGAj6dAvOjh5h zN43Jse|PWQoK4l+4`U>tW#wB2kWbO9!)EX=Hd>Bag?&{2H- zcgqgt<2CUJCkzSpqWYq5i#&C1!HR(9RC(=%3BfbEfo^6=zrWO+9qQ--7DHv>={W72 zp{zeAF^w2JY3%7InT%87jN%6Ugik)%z(-Plv%w`pM`a2eKmK;#L&AgANt>zp@iCai z$WCFzj&7JOp`+}W+|+Cd7&@g}zr0Q@S)J#reMG$^g{L+AuKb!s@}g&+O6R}1K2YyG z@L>!PMk)mQGlQ$zF+HVDRUq9o*=GI0oFLqTco*wSRjS4v`- z;XmhlPxtb{%;YtiAp;|4_F#fFu{C6*oLPHrFqR@3Oy(wS!WP8q>R0{3{e0nb@T*+tqAuxldzAg|njVA$%1h5aPiSH@rdM-K5 zy?!RMssnAR4k(;G-t3XzwM%VnA42~b`Lp0b1&2D3SfurxLDV))pj7GMRS2Y!uyGCu zN-r5<$Ov=M%=L(f8H%ZPQ%3fX!tmK?uKe%8(-<*}=Y<70!6O6GKjfOp???GlSAou2|L1 zhYn6sX0d)|M3?{y<79}5_)I1Bkgl7Wp^j~@Nbc&tjTv{2D7jtHsXq8=ts=12l!S>M z!XW-lHcIF!dQ<_^e$;$*mI;L>2^!YRc^z#9@rYI|g(&hu<}5NfeCCinhHspLNmpkX z|9oMV7tA6%sHBWe8V3BK^?_r{^{4oK>bwh;1DRi$3ot-HfyJ0q`pU%}7xOjK+7|8f zXG)_qF^{E`RB}@c->AA-2^rhEF%PjPyl5xCjDIbEIAp{w%q!?0e;KL0=DK<h`*n%>vf7A+u8gEfJk zW}og@eiTv{N|H&XVdubuHh>0k10zB2jWXONs!85kuyBFR%*71%4`GLrLq~InZ@@=B zlZyBHwug@1K7IM#(o1D^EuycU_7{~K9PgFt`gUP{H!9|DT6a^=Nq=~}w!{-@(7x6` zZ0G42P5$g*%Fe9c;|3v{3yyiZyvbfLtBqnJ(g^V)@FE${K+{flLViAy&YjUGN8xfkW8C^{zU z#Qm3Cf_Ez?rzGSP|MR_q@4;R9lz(PSxA^mpsYSZ%%-~CWO3<2Z@XOt_U(YSQ$5*mP z7ew&#o}yrj)ySVB<+6z;DAlS6?NnVamf->S(izUwWwoYs>G}E3`?dSDN6?eqnf>lN z?(B)vl6DjtFX6*8ZR&APv@E2leXcrKEXD6KjllBZo58+V)9&G!q}6_#ZU=_GiYoIn zk2B@wje}gbblvX;JBKe@#4?_ybonpV}>Fwxk7Kd+pF+SjqEsHVf ztx=tFXxGIKm&N=hQ`!jR*w8@KCPZgB1g&n zSKr;ctErV;WIvGSKcqoX+2VWV{Sbs(r_9j*RPVZuY}vaH=?>zjG+?E~*oi0RYN_@P zFMgeB5u-Di3Xsd2>k8xDHS3^4t9+t)`t~5LPwLsQoWm3C-QzjE0M~~6yM=s~<#_KSz=-gNxpLBV%$#NK$3XZPMNu;zj@tL@7GAs-HDrq^F`SJst8-4{yo znPH6+i#o->246mId45+}_m`N7{qC>3wZ7kek_mYclHMVuSCvqz7W-bJ5NmE3D+pG>TNT6@^I7o|dSh zh$llU4SB2Nw)k3~$c6TwsO0}j=T5sRJtqA6v2otClV7Q9G(pODPiT}~36hxlE@*(+ zS!(-I=)j&pMt&=d;K{9iTf^`cfoH2RKnl8;?e)SljFek*Llc-x96kOU)0 z*^-IF$`Xq>W!FKD#cFP#x#M`^%+P^%h+H3PzOS@Z-_(|yax@Ji+HC6bS4QaeU#h2g z-dLZqKQ%t~2wd;#*#Et!aXJ+*ax2+4u1}9Q$>4>G$zz5ZJi|99!nx-Aad5tx^U-jP zP$n8D-i3g1>G+aSZ;Ra2cTor#w|P~19tzC;p1Ygyge2o2YV6D(mz_ey11RV8~F znYA+B*1?W#9Ua4Me;B)3JIVoBY<2NJatI#c=uEs86*>f^=6#j_Hw zmf+b;@65@)?;M^X)4_wesu{jPU@W#!>Q>&vri z7Ub5r{7jtzaHvlCe;yplqsYBeh=CP^)AfaiY03J`@>BWC*{S_S2#4)S?PAaUf(WTZ z^h=*)v#=IDiTuXAn*COZ>EWJIZ~T>3*nDU`vuT^1o+`rI8g-)sBnru9%SPdl6|~vZMY&K{zGvoNbY@I{$X~)RR>(kQZ9xA2A}VL zi|KxtX6o+gZuOi#rqMrbH_%lmlW`m&o2Qh!GAIta(x+$8t2ppuE>Y`rLRqh}aUO?q zx_kyle9Sz7K(t^lJRy@b_5a7zTgO$keP5u5R0I@7P(V@|=?(#rZc#u40hLy|yA(k> z1?fiV?iOi~5~Kxbq&wf-_xF9D_xQu>^g;O|T7T-w0A zhzB9rU>iaDp(M}9wD=n5p!~o7w+8iV7Go! zof5`G@%*&YU=&*^wB`I65wn{6-Hk%S6aWSQ&UT)ceTLAtaIheff1(9T|CK7>Z;OHL z&9XB|rYve$W(!j`(t1A;B?_;-%lV-CK?*SjF_HC$R!^#DA#Id)k-#%LOE}xI-FXZm z)t2wW?oT@z`@}P!4NMja8kh9JelpStv_2a?WY}J~4S_;%^&9blyesxFx$2+u#^583 z7aIh_f3lA2uzYGWX?U@jOOt0wl`E8awk*UkHnA%&@h-&t>w8qCVUq)n2W%s6M|XSW z(@zq+sAc(|%e)yxnW=0~BLT^W2(>e3wb1x4a0$Yi@neeIG3m7s!cO;o{gM-cBexSr z`va>>I)#k33@ocnoQ}}P{1#&PH@G3Vf!5|9X#B$b3GWiGLRgFr+@X|7mREW%GBfKu zJ+mzeaEP9Z?$!szW-`_peceLmwB4(KekWbu8;WmLJsBX;_J+e>+$`N*vh7YPPne#m z#ZTjEX0>C%mWdIqjMD1wp~>Xav3^Npt9mrYu;A#x+}== zvZ^;?u9#*55(aZZ@u~}~N1E95+;86{Y{FHNu3}Ge*NlyPSd1NXsr6oeE-f4P7T4kPWahoIoELFgd7Gcdu^a4QTEJJK|HXQD~SxcdL9TtVf++a1nVw8-S=rqAD?mla!{#mL z7G^u%bEBz!>GQ{g=+K}Q$G4XpOuj%cdDb0%xkf`MUE5RPn;ndORk?2^X=PN69?YL7 zZVm~T@t04&ohs`8omUDsgYWf}B->vxAj4ht^qSuN;roCkJ5<^|Yu<9I4%O37%vY2y zu9MO`Bsk5C>oRGk4ZQX547m9k$Ntd|kXME9&V;7pUhU1q4q@lim}^ zO|Yy{qOL5s)}ALo3Ok+iStLE-7+_!P#@^ z^qFnJk4atIZHKLbt>f!-lr)@T;U4y<>N#Eedl*Anq~*80?lZ~!jNcpU=sEw^qe{Qu zUE4fok;T0nOC%cj;hcE7sJ~>WJEI|k?I~gSy(dhZTaXg#4wl{~^oxcL7}U*oHKQJy z?azLEBW6W&{(j_ylF5}AnJ*EJVmm#0vW zd(Xa175x*RLrddITh^--#0(WN{`)l+<#I;Om1HAChqE}muIA2vnCDJ=)*TNVj>@Mr6Z1^WhLyzq@_etQMr z1xoz&BbqDH6k#5E2nuc?#C2}`cZ&B-tYcLt`Rp7A+AJ(_*25R~JpUb;=e}Lau|49O z(}phmqcmmOSG}il`sfi-O*GO_u45JHS^j9<>}t=;6Ds{w=<4SF_)m%b(l4~FSG6~e z-7c5zDGTaUqkYi{`0RV1_Y_#ea1Cy&vUP zc6y($uF8A5+%@oy-~XOiZ9AZU(el$GRtqwK1(kar?JM~&!|3nO6UGxNcqyRVB~E48 zsJMFEUuHi0qd!kYuIVwcU-i41I+eqKEWlG!>0Y()VTogNpKopZXq_r)hEyU< z301k)NVe#%C$61$gr_Nvdr1s95J%;jvEH0$&G2$dalE0eeTufqd`}>F&37jfSx&;=YY_laVpxF6#BtO$zm=RZyy8D!mMW0z$87@t>Myk zuHc7y4J&I)y`-iOw0JJ*Nus$YMJyhlkNHVShH4bwK*JZIdIT)Y0mB9ZP*HN^3{P6~ z{q`D)zoV4KxdW;{E}@4#i~XL&;<{zOw=lcx3wW?-wTGF0Gp?tvTR1>AB;~E_sPM)O z?(2O>GMoQqvk>>9zv$x3McSNHYI4Fl`uaCws3cBTq5XHdH+IscajguCzo%#F+3g;i z_V)q9Ezju7;;2e=uU_0#_>~HP5-t-UX4F8(tqyZJsV`a)rmWaW;@w_ttle`Fw#Tc6 zs2V@Jwwd3_IKuQr56nm)X0}gaMmfI(MX>Z%=h;H@(IPxC6aE0jUDKPQVnVs<39mzb zq7Zl9^A6g8Ba=fJod%buGU7c>4OCXl6y zJXAE&JY#!yjR;{Ambxgi*5f5c!wSl9&D#By?mu@oDj%_p>0iy@UOwVFQ!t`P2#`;G zJu<5ztuOzvqtDt_dxr$D3Y!WQZ%R#Oe_&}vlCoDp-I%|IKLG2 zvpJ3GMpxG|=*W8@p>mCQ&EL?=+`1QVyuNHJwOi3H22f-Y)S6)$Q9rnOlbf{`di-$7 zWZ9LMUiV1>nIgxgNDte~Q*7T7vK3&gCg{2EDLw28vwtkhDvvcQR(sKUyuN!RcoJUN zD?|PCXSKBPipMx+#hMoORn) zS^tuMAjzVt&Nr#t?DCedT^m*L* zF^u{R&=PnBVt2hD-IPAG5KfG-dkudCfWsRaSogKP{AUyIf_}?FhW)(D_7te1p&N=a zmc!iDLk8p66{FQ(fYOZLj@{yy)+y@c8qqcnzcN1; zrBpx@?>lMZTMz*G0~TtfcBhX_7m9 zIPDpdV5=XLo`&KO(qY?PLeDn!ZK`&7nWopG*4@zIlx)gvkKB_ljxO%5BDPP0k7`%6 zqKU9~Wo2XU--nUTS&Q87LMN1=QG6x(if7v#ohrZ^GG#PXyQaTXf^glzwPvsNSr zeMj&s0Y<18z(2Qt!Q9itqcJ<&OOSAAUJl@MFIC!x7vt@9-=WFvf*JtLyj8hvGZ$t1=417Txq2Nbe<5AS}UYF7BJdCEcguv);9_yx?II)4B zwI1AE*tBo`fIoQ5uQwS4*&bFFhohFUS47}xmoz34P*5eh$Hac@tR$)6IN%$>Gj!&^R(~}4E zD^e>E=KcVy`hPjc{QhV(zx0>;)}Br`2g>^5(ELj4e4i>Mdo2Hus$S)xq-kJm#CZ|Mrv%N zXIs76?KLZR3nNC$I{)I*SE9T36Il>8mutg9eSN-Y`|XU z_Nc_5Wz7DGEbMGoHf3<sW!AQo!zt1>}9jF!~_nqJ)v_Ih`0YGBKRSI zdd)9PC#(l1J+O6LJ|58X@oRh`A6@2kBizPE`L5ldr(yDed;l!7W!%>vTr1IPu`PA2 zyBx82(It4aM6_tnwWyFGLLr97LTP>SpLc6LHPmZ)@6+iVGD<#-0S%Pt7ztbsZqm!9 zvEDaYR`0xds`NzkIn6O9=1k^0J|y7U>5h}sKT(0~z-18hmQ&egs-)^~kO>!hux{&n za>D0!HaDS?prHBADEkUqNqtq96>UDIVqH6%olscWK(UmQe|>_!2){AuB>M2eB{VhI z??tBEe;}sge~;gH^tyEJsJwSNoW$#Q`kXAN*+B$@E6Z3x#}fM%=~uQ-?~rth&v4o5 z!WMSgfgJQ4$NYohBOrJ$wgtLpry^Fagq2{ZLnCtN-jJQD^0+~4=b=Jc4Dc3<&welg zahkKD8#&M`ZCk#_3}e3O;TuyxC<5!DcI|1br-A4U`Ef{D8V_Vog>J7HB9Dfoa@Uf7 zgB4^(Wiq_vZ8=%#7A`#s!MYMJvto3dn7iUt>g58xh}E|KEgPkqu200C2b^vf9qNlu zp+OQr6`5@@|2X6HgI7;yc%M%u*{%?df9!~oT`4W*C}LcYb*FD`+el?{3*u}%@LQI;ntrEB&upE9m3E_Bje%czaqyq9|^=C`GztK-+4&xZ7qYNJhR zCV3@nTtLA8UGp!59(Do7t5XBpl>aXLA==(#m)*Bfq=lrl>hvr8{n^?5-DCZwD{4kX z9LXF=H!x07ez`q~0Jn%7y1^N8U*Qt>u>)pq?)-tb5LmY}b>z4&jWmjHdbXWQJ#EZ7 z5a4@P%0WS!`#K!*Q zck>wuz}+@DO3PBVxnDX5T|<(y^~(vjg?f30>Db|I3h@=v?ZXW@mt#_$3jxX4>X zL?5z^M-quxSXs+mlCNSCrH+2nU9T$hJrUg(6uYQ1A@H6Ry?;lEiZS%3pAYlpU}WdY z?a6=(`_rL%BS(N@sUJLX&8kP!{Iv0b)!vLJK>g<$lj?r7^@n+)58hh#>6yK(3)EWaZE!XnlqxTFS0&mQVrg1OdEwQ*dvZUUA_*RepUmPu| z6vB@97r|ubFlHyl``fzc5IEtQ{?_O4zoD!8btZAOV1y+x@>18D>ztPC4IkJ1EZ+93 zNg2`OQ^H?~dLK*kxuJ`WyJB1-X5DBK`_b!a>YeA*aEaaoW9ZG1il0ee!YB^<){nWF znwcUOq3G}-gQ7VPMMFeG?aB05>${+jC{iE0CCC?nu7visKR+{0k9z=(5*=oARrz-b zFz$GZTQM+3k1l?(6G}7*W4N05sQs6MwiZBpYt4Cz+Ed3;+jJ>$To|*GvAuIL*m#SO zTj!$wF!a}<9>&XV$a>#dGdI{}SVM$=L^+>(B zb$EB6r&3-!C>q);OebkDDkJNc@omy4x4!CB4XzSI2{t?cq`>3`4 zLQjM7gPoD?LGc>54@;gj^bAPhgVyk@Lqq}cuYN_#f9pO6SyP;zG8TM%&~Nw2lUyBqo#89zn&n_r%Xb-?6BqkRQ0+L4+&7O$>&A0Jc-Z0AORvLb=xf?nhm z2g!45mp1%%(>+ocyvVUDU$(y;KK#Z$H4`(&N>r0=zck7T`-yE)H|kgR?W`?mT>;rG z#WWUbvzr_KUNO9M!Uwk7^w`X_E#DlPm-HwWxd*bCR4S1&o6+^i?0+aOo21H!YTJ2R zjSOFl|9#EO=z`ti3bf%sl{Q?vT#d1K9pl=`+&Kp|^vU6A&2X%yZw#*Xtwa*m2GtvP zZ;C&tVnwFGliFRU{S)Kk8o!t9Y-%*Bl+p)MM%VJ^u41Zxj7_*JI(^P5Umd~9ZrME5 zmzc!jqL#z@x16|84r5JOLFmZ~4f!8eNDvHv{wuUz^I+%A3?<3v>w9n?Z7}cxO$v0r zJ{pA!3q_xu1=kI8*I+oIWn+f(!j~9w{Peqh`o_d#e6QpBMQ)33fj)!8Vj&}ibzI71pB4$I$e)}?<> zxaOPi9PnlyJuGyw)1D3Pw(F*HR&tbNOW>MbR0yseP6kjB zX0F4;dd$$4-ylR7c8Y{1HcPr3Gw?-vah{l*915?(T}G*g5e={aBpSBLZ-&7JP)Z1? z4lxID8+ownu(c?8f^(qryS3oxB_x?EccO7&kY|Gb;^gudCHoayN?3XHp3+5_O@Ah> z#}s$d6#*Sm0RM~n=Cjt_xDv-}fW#K%FNo^M>zq^n;37L7s9d?x^V6;wyc2f2=cgz!2w)BdP$W;d zF$A#g&a?7t|K4D_CP9c&9^ynD+5m6hU`X~qI#+u;VxWL=G@`?n-_OL;;{Tf!gTr6@ z*1`$oJ&%|)cTBTY&|sdp1sFZZk~ayGG1`{R77fhHfV1y3e`{Adka0V!h|7ge(9HJB zJTOS8llKRI=C4y~*0BFI-ML$2lk_p?C8Leq1Ub1t*)Vt)r_ zNTy=l>nEqeGsen)??IahZ0Kt!(7^TUs23PS8-&B4v{C5%=p?QXEfzW|{Se&ciaIhq z8Mj{0B-!DtNC5ZX`SN1zMdQVtLr8WKNJr<(re8Fiw&wrG$4GEl|nELUPT&Kb! z1%1zeq3NC1wr@ZbbrrTP@+1?VrjHf@){7T)EiSl=fe{3i5x68C{_>> zA9PHJu!(1%k+dEg6c67U8PGX^DIq@Kz7Y|cNl_|v2z2-FTeVn_Zgfqy(4l1?tjO@8 z-Q_fGN3I-XN>bw$>w8>AlwW!sWeR#%g(rj*4&z@KP;8Cv3(F?3)qm(|j7;l3o8G)sUj6dGMtJp3|+4!6|4(Zo<9;CJZt}=(wjOD1rtZ99?ZaK~iy6+3$%&Eg}8{+k9uT;NZ7>v3kIvlVOW8JSaVo`h?`I$96+N<&BkbUxFj=hsn?IQ331 z-y+Sp@o>Kw*0G4(W+>rxddL#CSfs^KP(KP*N1_(9C3hXsyl+bfpUa& zs|HH|!xWT}U3|0W_~pkF-F;|?2Vp8&>$f?V-5|Ct;d`g&-+jV9CYZrd;Qj{!96yEj zm$%4*<80caZ;UaqUQd){wjl};82Kt0f)1KP=Ze14L8@BU-VKe@F{Xd0WzxZDh)kwo zA~iJ)ADFc}e-Q!6lRwawowf=&3%UxVJ-OY(4^|tm3TKkfP@X3hVZ8!H9)9fkC>kVR zMDKZiynp7rt+F2Fpa$OBtlpL`ZocxVX~mXrKpKRCj+!`A2T`)Ae*S9dRM7LfR9KNU z6kMM*TXd-b_8U(Nw1)XTM!{$Wo2r~K`u!Ou>dO%yT1wAzKk33|=~uqNlkWt3VD6sY zhX^hGrtt&1{9kYUsUGCLP8Vmq$LkUtU4$mfCd(JdB78{Z(XA9qJDLh3noqDC8i!g= zAm9V*MGZ{tl2z&6Y zJ%DD^sH27&_&6i`WV$wn4C2hRFecg=cdwcL^XpB}1g5>Ql7X=)t@o28Xeo#Iit?ii z8x`r(L6^4bJQDd!OUEJtH-Zk=pDw-6`#VMyN%z%VoJj0mM1n9b5TTpU2f1U=UP}|S zTp(BU!6P{(JWS_b&6NKh<1l%*G#tt!T3*S{^E_$@05t~&FJyFcr149tC+X`k-rC2! zc94z2om*V}(Lf$EJENz3(GunU6e$oOc2W&h-IjuR-&PgPaGki7B@-oss;I~RjsHO2 z2<=@n_XK!7Vml?vsSKyt3$QQ zz+Z7N*o6GWXoTVdxVj12T$uOmIILA>?j8d%!$CrO_yw8B*c#q|nv0hwrfSoC%ze;L zmUO;CszS&~-_n(QX=I1L@+moz65pK^LH!^ffpKjUkPlAo-D@ZftwxLG|_oN@{ z`FYBLMC4WQ$6`>$@f=zzgTN9LcPl#S+}GlKSc|otEP8G6F5HWrg*~7VLS1z6p;WgC$*4ql&%m z_o@6cUg2zrNpKT(C+6bD5Z73q)a8`&jN<720Dr-J|m1rjC& z-{)Q~y8F*Xtpowa4wY)CG>lzhH71|F{8C;B^oG)7eoh#WVG3ONnd`s~`WA>z^rq3y z&!Ae3KTS&{gAvtybdly((P2@|;RbJQDa=1EPj>a}fN_QH3w;aJyv3U1+$kF<`t{f* zN>0zBqRkfJlj(+^vsj&)6g^C;dQ(T={+SaIo_yf#5CmbNZs5-g=dJyEU>9S+2fOd2xJh(M`&uhQ{=Gd7SqbDwLppw+xsdqep!V*6_zRoUt1Gq(v*H~_u zu_uxWAl7ypvgZYm*4BGgd3$d!D&~V>$}0D_6-H1`G7rQJWDsXT_i92o<_Gc(iN%ky zzWM;FQ9x`w64H44Q@*XqW91Mx*qv;MDm5k7s7$N62G; zI-t9x>t16_ny_WVSi`3U*aiwoL<$DVJm`_06PE`qV0>!;Df!}xm`BD9P9#)$FDP=28Eajb$v@}*?<0;z03H^Erf@84}&delM5Lw zNjkc_3GsI@L3U)aII4J!s{ALcxXP&07c~1TlY3PlvF|j`kjbY|Ych8h!gj2C74sWH zJ91tbfhRDY1wjvpxZ8#EXTk>!mEB#KEiGIlL2k^I@rM9LTQo2df@0nU+}XD6&iv2V z$7gP5#?X6Dy>-Y2Sf9K0&fSm&>x+*o4d#Qgf?qF6be>^HOVEwnF8cY^g(0_5%;XTQ zxuCfW-wfC4aZyG6U{a&rc|4FcZui`C*0eN*Hhdi@CwD!p1vk0a3%GFuS1lG%i)*Yr zi0mpf2N~hPon}X|bHxC;Li!iSXdz|dG*KH}=g$j`)K3WEoh){K%v#wvy<-n;=kdRF zOGN0(aeDGuWrSpoxCOvg&4QrBqy$A_bE1y(A zxzh8C0%jyW?I`$W^yWl0(ej)eZmKHsm}^z2KISD?7mI4ezSZVjk{L6RrPBVPo<@>< z^cMlro?do%8y$}Ijc?{=2<2GiGhe!wUlcstPVaY`nlc@zED)#@c>2w^O=d1>UrOUotgP-yxE&uXEP zGMS7;xHhn^zbZE;7M-k{K@;VNsA&y)0upQ$ zIO+alC-qwq%Gr@I>fgRmiZ3lKF|cN5X9r&2!kh(>15tMg-a%ous`gc#z?+a< z_2Ix{kmU}*NPR#U)+Rx3%zpgE`{85#mFmpu zz0-V3fCAcy>|Asaa9|;bejeZV6x|#Rp?83#h^w(=Mg?AZkOeItu*M66BMNDcaW;fO zOAU%V3M#Ym7cU&_?DBT{$p{D#OC98;{5Q#Gahlr)WNu;e->>A+yoDA@I)8Cb#_Y)| z{@SJEA5Smmh&+fnkSrMYM?b`@!L+&P-F0(ce%m0hh4qF%bm1(1sW^N>pDS*;p-vdy zxCR4qpz9VddgFc>k|Kw0V2W#bztK=??;6aH0qVTbulMc|6QT5iq1Cb?5^^{0Ano}E z>w>Qd`MrDJ&UQ5lbzi6N-z4`zc>>_i+F<=AB7%S%1{5($nx70G z>GDw*eHUrm@O)d8Wc5GzBX__qB{gbv0v;xC57<~Q$?E7B7+@c~*XJPZ@x_Zv0H(p@ z?9Cg$0?MvW%S1ps1A3eTeO0CJp?Uw)JeI8fZ=&xn_@jUmnqb&n^IbS=-hMD1+-5CSYKZ05$oEoX-8OG!T zc9eMem2M)~`35ciV&S2i} z(6;${Bu-tYqnb)67D0%I^@vFem)nG zqqon7?Bx!HDrmC5;vxCEq`pb%`34xy=7Xw#YB7NM-MWhR-XM3HQvE3CU`_;oMME?2^^TYBBXNy|A$+4cC&=ShU$`a?XCGi4W3j?I#SLs|Q3VbKqwm8z z9|WyO9{?qgCHjyE(k0wH$WsQZ$z1qp(*=C52ljp#fXtt9*B3N(gKwm6_?h389`oT4 zojU!xY=CUQ!z=&C58ZXT^%@&q(Vw|cRV6Th_DulhnnOb|EwFZ(XS zPm#*Bqh89Gx1hULu{2ImnFxw+M0r2F_5_3pkHQQ5t>fFnpCowWk#wiUgoAb+V7(1= z5WVN|yCBp;8@pAzP>|ey3-z+$?hD{BpvNQP=pO@db0GV5w@34oWV;i;XF!C@QL-Xy zdbvkqJ6l(o{`(ptOoBcaj*>wi`uDv4ek&hd?)EIc#6`gY4rSgYv%wU>d`5gP zK#z!Q@I~R`=g3BwufF+*`*n=k(Y<&0F}AEfhH7zIVa*&I z5zi()7sW&;K>O~qM(|Y%%jZ-9sHHMD7XH-1LACYu^>5z~`-g@i!3%-O=?GjrG^{a+ z;q~6%;objVwMyw5FE50_TRE*%#7}WmAOIT3fO^vIZ_Db#cDVs+77vFz82Luyw;Z{y zv=gs=a(*?1s}^#hZmfau2a;Kmb8E}p{#o~r{*2uK@k#&`2|$UZEFO2veaCm&6+Dan z4&MU!0@5i?7)k?RfP~5MZ6&AHgChSCu9y6)L~H>WbGDSxN@YD#7yj>33lh0z`LG|< zzh&VWbw7gh2ta*-N?d-8JCHk^x)u0gopQmkngBgQM0I@6{yIqORM%=>d|&)=YmOM5 ziip=0s77RsU?~FsTWYII0KimLm1j?Tn!v+=gx}&Gm=hR-CkybQq6htx;KCw@mmp;S z35GqOxdb!RfZ$*{K0a`KuGre?W)JM!xx2HOeSzNuL>5|AgyVu=b9tNjkD1?;a6F-L z=A@YY6(yWogLyWbl+wCcFEO4CBL&diVKfC5aKnK)|A(3f9OjoieMX5=e#efhFneuU z_t>*-OokchQ9&|8sQ@8Lk3lbYpI9^LdNVmf16GQNin1rcX~k5E)Ul3UDeO14Z{PsR z6F4IW4Fm9xC_r?dHPG@=8S4@+>SL(!KW?=aQ^rCqTxnZz8=6NBgRu+6&n6)Rq{e@< zhz$Yo1p>DfDpApktO?7{O0ww#TLUtbsRJeg_N%x5{Q0Avrj+Ee%490Y#kG@lnjq@_ z;>E%C_D%8?&TM=AwZy$ zAhbO%Cw8O)Ntt|V$tQ)XSl63~HcklBQUA%M z)Y!z>?$CB}&ZWCM>@+C`!bxrruUl!uFH|`K;AUm_Z=9%Jw;#-Ne%IKusED1HjfjFr z!eB{!eEdiSI0%LZ;g#Zk0J}dhjQ)BHs84fkQ$a8h50>^#OiV0e6BA2bUw^l<37#PS zeS5J(ycsO8wXLCPBmZm{^-I&XfWG&yCj>S?{Vm5GV-V0`)?!0=Cmp-)T$V1R#|I;F z7&yc6U}5EoQ$zD^*$s<+5D~tbI<`mE0j8EyoMeTLEbn1u42Y@GjxLrD85iVB6iPA` zCA>x+P6gR&Eum;x+5+|nd&IaXL9YLnRX2S%qOU19=1QRcGQqpP2RzW(A;OQIMNXJa z4#7HA)YVB%7*-^ZSRp%4?24Ny~svld|J!e)tHUQ>7I0us%Hn z(-W}!YxBQ(|L2MwxVi1FWG8cZHdL#sd3ZF8TrA9^O}ihy>@=I5n`?pek*ipn^NhL1 z;a?ZHX5ch|PtMBk((JN&w{vfBr}sZpCTboX`0QN2I8}6^*L&FpB1UApOoiENNL7NS zS7M^60{Uf>xzYFP1G%yGCd4QR`P*jKNUBX~f#&4^ItIW_Fr0~Hdb%?aHzUg=+uYw7 z8d!ZtFw$ANOWdHa>@#TSKOM^~?r!L9qN{@D8~BGTV3mr9Kp+30=VPn+d~wIHjkOfPUWjw=n5J}_)+y^0yF4*~(iD+R@P`ihfHRbc^Afn-5*~Q2K43i0V#O zb0fy&l$4@h(<7dV;L3SbywT%)tj@V~SrQ#Z^OQy~%I+$hhfBhDCx$f!_AYGFzv&%y z?0`9T(sUDlju+ND&^fqs5#p_yH4Yu(3n(c(6j*n1$pcD-;( zHp`qp7A7B$Gq(g#=Jg9Q0`4j6 z_x?^5yIV+O=Bl8k7NOpzny(R!%oyA1}sRI$fS0qB$)@Ya-6?sLSJi&sg5KG0T!Z+BPezbPd8ge;FaxCr2X#*50qFZ$=`L(+!)w8r+;QjjcPsGdE4-eKGS@S}WY%a0$@U!0yddOXa`%>4fSyX+~S*|4k~ z1*l{ZUZ9A;j|OxkoaW;^NEPq_n;?15(~}b}(?QymP4KD#f7v7E?a9shLkchnM(n6v zT}x|y2TTmW*i9p*9SfJ3;O0$lK07JniFU+oA#k+b{zcYePedF|CP=OtJbYO&;VQ+11J!s?PR2B8=YRa4TkQUY_ z@F0+pmg0XOR_V6gc4v@kX6M|-%4&A5EihtMx6I^8^j9XUhY(};gdKta_e~b{n(&l( zoV%=SZcIs`(f!}8!UugL0I>6S;j>=F3*+Les33CTnCW^~%@sZ{k}?37*1Ci7xBTxE zAoL^$;OQ|41tAa`*s)k0OA>^3X`bS?T~uVs_Bh_u0=pdW^KqvcZ{-z9)l%I$t)2Rp=Gdz1?L5uaKH0fAT&ZlmY_ zoYQQW@j8WwEV$rh*z4-*rd1#(QblMb6TKM-B0D8zWv@bkM+K2^`$1Ho5l~WE?%y}( zxEt18X!;{6>Nc31%3NNY!!x`Y%tY{vAbp?%z_1qh4}u`Y_;_cb%wp;!z~csZ%SZkF zYXA!qR9RWMObe&jKyZ3l?3noE39a_gb&^Luj45e8J|L0JyIEQkYuk7C$sJq$m-An^ zace$lajvBm#5N}oU`a_zeHT}?Nvhubn7yX1bcknaHIToVAZnbITT@djG_@%mVu=QZ zn&4Fw78@)33%>U@1PCh)1{mW#zar{(gtA{9_C7jtGWlIX2L?=AoquQl@8>9_dFuUz z@6TVq{J^o2^SF*dB?)hPd)w@#A2?FofZw4|TZ_G9qT%=c_mhBUt|wy6%vRvahPZ$Gqk$LI|NSsv+?!$grdfC$_YNEFrMsKkEbN6e5AXp- zZ0TO}=IAwwB0EHd>i_>YxWQEy3w&wOy$aFX!K0SS+(%s>+?BW1e{-XbR$u=Go1*dY zakm|T|NS)BZlPYoe#d(cMompd$&ra+t;#mvGA*P`oa`Q!Lu_g zA>qOAn8ZYUa8*9G=C zrzNbsyy}@naUegOvyBQ*NWg<@IJP*Ykj)fgjFh*x{oag*0;A-%PSlkvuy3)vlpdZ2COs|L+0KrWCpCn;~^O*`MZO%$lnSOcGP6U-@ntMLlcXf6m=5N+qTNtz8!pvbcD_&*w$H&0c#YHHHjQ=`> zc#2B0s9Q?|8kqLsfxX)MY?WjmMS5T8!o;(c6H_EUTywK&;3S!iLAxH}8Hb0sVuJZ< z78k$Gs}wf9?NA?|Md!t(?SH9kSDY*)y&V3iI;ya1m0&`DpB26&r=So>=uL@&#Q75% zKBtpCCM{!dxmH$IR;_raHCAa!3Fe(>G%XO7DcY45A|tPF(mZ&82PUVOVD1=kTNSMT zu95LuyoXrd>13AJiiPWVErDI2Q;kk8WT&d-_TJZbo<-F2B7ucOR#p~u<3^|i;VhS7 zmpC|_zJfgW6EYj68O8kET+`TCmAF)EgACZjK88=fO9L$hx~QlqEzvwsHmOh2rNg45 zvB0_0>R?^Vf}D{CT69wE8x(mZURuh^*AW{)i^(c9FettPyHM0rimu0spZa>p+#_tT z4ekkmT|=R7V31ML_0qhoCq#egBRL(pR{UyFo!gKon4fkPBm@ z^aB5_&oojpKg&V=`t=KZG}((uvfgn_ihY@ z`o{WS%&+}obvl5T%YRc>Sa^8WPU%U&HM_ig70@~(pY7j;1uU@lL!qp;=cKA!4-0<$ zAkL#t7IpUl1H9(5<6X4bxBCCU?C%c*6gYa{fHcS!@u}aqF9Gf0!-vb0)w}$0-Azs6 z;3$0MSj?#B?(=G!OoJKNjJLS9b`}(ZDZBqoRQ~A~yL=Be%|4NlL!KM0abLb%yDuF? zC6Nurlh7~R(b3V7O$LX><}|55#4p#&e+%5L!L*(oOh={O%%u0m^SAD;45fnorq$_z zIpfnTMelZaQ_K}u9to(*f8a^OGM>BRaElmu`KHf`wqUP$P5JJ;DEVuo8SqN#Wql@Uya_B5{;BJf1Un zfSw!2iGsHDwxNjt_1TR$EJN+@D0( zzBxPFB*t~`-m#Z-V8}q0R9}yvz_Z7ZU!?$CcUWp`PrSBIdh;WQnp9fyJ=lZ>2ZQOo z<&H4atuv49Ijo`0CT|QY92SPT8u@B(qth_@c>nEe1E}&34Q1Fo zrkr~56@mlrhXe*{YoYs2^f|094!A|qURJ*Qopuvf%gTzwz|b)KP!3#PubD>^!DeaO z+^DhYhWKkvReyHlje`SU^2?Cd-mr;(^qeJs zCSW8G z){mW+%gZLg$&o+}-FJdrm?^sy=26LKIw)zb_dx=!J(QB+QoGC~b>Pj-vVpFQ zWloUbE~z`c!iq6bDNyv;8sGZz5SR=mB1(|EDQzhSkMigD>ARdjp^lOWsfvN{=i-=a^5v^+FcC((TSqr zl6YiIivb|^ucMlpTDXq3kP!;i)YbJVZXRl(>0UyO-AYTHtDJvKg`TO+*g zhtkhqo!~x7aHnFT((*BEr$3OJ35bcY;kUlv_OD6 z1X7jl5-=22D99%=@8^-k*5EFT5XTF(VGb*&&}KRA7c3#Q8ET@*QwNU+81Mj~q{4pTfQ9!D2>7EJklw_o{_R=#)ifS}9|D0WLw~Ik-O1Vc$Ns?NRglBWo8tf&Iy{vcW%Ba#Qw_UgdW7>BA0_KS zxRsd9VH-UXMXZcbUJ%?zP>VRs0mJp2-yc`jWHX-DV&Z45CXyUs=DaGanGZhBF1D%Z5>^&sV@4i=VEV?9z-sSYUH{*kay9LcQ zG+zO*+uN@ZF{i}D5NqUW;NQQ0e;Zg+0U-a@C#$*pVmUG3YSlwr0W)wFz$)j|!}G{E zhsYyM4uzr@zHM)3_i4`=s%}k}W5)1na4iRnWMXE!S39 z&-_KoUI|#3(@ns!r)z|_Zm9xJ%+qdg6BH5<2)jHvIXQy9R#Fl=tF*tz<*>Ir&-XR= z4i2RC^z`5#KVTye&eXepgoRfXWDmT>BP=W$L7PRfC>@B%J- zCdf5HbNfbFxzEx1Os~Q1)kZojp_v=yV?R9V`OCc_m9zr@sbL3@8mMUIEE~_If8kSz zR5hJ?9PiNCdR+TJGxMF7iVEmcdRP+UMo@d0!yh zsw}32zy(9R0ZUy884w9>z{<{pX}A@vnEw}rN6v7U9@NP-oVU!m&HMOEEWH7l2 zaF!>yX$|kBO|I%ebAyJ+L>CbL#u+=C7rI2R)#F>+i@5kC` zVWhdk`dB!-QUwq-_j{Pwp*GziZ!8&+A%Xmw;oj&(t_Vq5982mAZq7Qzud$xIOAxg6 zD^oAjO?;Oe7Ul&O>qIywrw9L9@yYnY?4_lpkJbtsxelX%HiB|DqvIPc%{y!*fY_u?Lr&htAy;~1YSOoD+m zWUrr@AhQXt1o#p3@eS)&m zW39ubY~BQ~C{DM<#hFWr ziXeB*R=)Xl3t2SR1fu3q8)jzaMgw^Tg<-2rr!ZT5NC$$0f_%qLrSbdhewmp*yVS9@D_?tP&R#3RmFRQd&*g>j5)S(-QcTt1%V>iMp_g z7>6T*S$PpJ4Q!2X!rsj)F%97(V(SKRt-dxiJf%LWq@=`|X^%YiZEGgY_gu5>uVj*Cs5%x$zf#ctV6TE(n{g>7 z`)Y||^)dZ|jQWT5(PCX6egi6r3<|2CZSYQ>eLadOgXu~j z3lUKokS>44dFap)-mRV;t9@J)%3Q2T5;Z+%$N+}38O2KOFPsNPdvob|OY((_YF0JD(dyvvXX zjW6;Q$70?aW>&T9#>N~<63-5v_4BR$#D}9!(Htk$+^DRl$6_M0g_Q3xW!GD3yt2Vf zBOxkUc1G~6U7zGE`zgRWof~;$g(^{kpJl%{@5D7Qx+c1@v0*9l&GY1t8yQYr<2mt@ zvUyy1%nJZzDiY*;25>r`0OG7dvKC~U1p1QN)7#LXJWG+0oE&ELhbq=M87-yCew&|` z0F600`Sc6?zn)^GCw{O{2{lw_uaeX@qD8C@Ka!`Qpx_evibYlEMp$7*eH<|%fNok( z{_(6IzzU&7`q;F?AX~)_4ohDV=ejxClE6ey|B3pNY=yAu5LBvVZkq>(9mEd#w+@|` zHZX{>kR+C94wi1TBWrJrW5duWPUox<1wF zK+kTDn+h;hDGv8mh_8y|juPYY1Jv?N?Lk>D!a4{ z$@jKDtDxEY?}Yl+29cSy{uvp0JsbH_%I)QwrwMyh)Jm3AVno%2wbAY=mE@k;;~L=D zpmF&U_v)YRl8fWh%X2rZe-?`f8OrjXu=%{Vm#%&vW0%%Hge=q8qN1X%^_SweFND&l zsHyGN&$s+c-B&+Vf%4}U;N7T^kJZ(W?dKkBtchKW7N!9V>PxY8hmq$?GWYppku`Lh z_tsZ#H#Rj@BW3S>dXQEB2t#0qK35@D%jKPL13|!~lC9fkT*i-sQivVO z;U_Awl>?~Br-8;b7T`40ze@?)bOSG0lF*GY{894-KVJ#M&!p zJ$?xs?D;=%?!H}zI60X(Jh?unH_ked91y*=4id--eyp}x1vhDr2fe`JWltx+D)iR; z0yN>_;hfh^%*+(VrCa1>{VJgBQCDOzws&&+wsbZou9zM`kMp*e2))_8zUh8Ds2#Z} zcOHKQ$ijc2vAg>P2Pes0HCnh573^bSL@_zxeXM`}jE>ftb_kq4edPsL0e7vt_z^F5 z)8j|4M@qR#a=e^B+XqFAe_-IbN3tCC*Ud~!gp4@gw=5^rxx zzF+pY*7lo9^EAlYBJXnsNI%`jJNrlQa74pQb-@06^P}peAi;uHlN*K|s@+%!ru~Hq zo8H6=!}ru?n17Op8oJ(85S?NrYTOqtqJC9tSD9L>u7IiX`(ppK>o10j3_F(q^me*? z_eQH>>+;($8Mi;)vdX>#M&)>pfM5^cBX1hLU+w5(t;P+_{l5F^@gzV8zDpt^zo0?$ zO_t`1cm;jJ`R>#UCaNXED1g!=B*in0ZEX+xS_dbfn(?cC#Y=|MWb)gj--I{!$)W*#05u(ADg-C?YPt>`L!)MOyZ;lZ=r1TOmt@_*7HXBdkSmwlXg~Odq{eX}(-3<2rxor5Zd6846P(q(m ztduG7Nk+ROvsm95$z@ICwJ>V#&f7)zW;ovkAes}|#bEbJNm^!R062gu0%BUef0Hvc znxNEoRx~%CRAZ4&W3+<4H;SqV9aYi8OX#^j74D(dOMp0p;pS%p@$H_M1fFlT;o;4A z9P{rLGTj~;m3nfWd-p{DP4%&rIE`^~9#hyUF68_4sd7$H-A#`3TF)$5&>&aQ&~csL z*RIZYO~Gql)u`u1=rw4)J-xi5Cc04ElE>}m?Y}$Ls$gTN*NxRW^228rDMKfRlXIiI z@Of4iAKf8Bn-P4+fJe>E+Bzdi`7^W+M4K}D_ivNVZpwsIv^Jc_$zs(<5n3(V(ot}Q zq|M)7nZH@*J}b4cMA6pPHiH9#n&=$rwnI?G=(Nf{4+-&tW&L4Nyv&xO+> zB4Hd8P%%V?h9>=s#7~Z5*GH$&SX*n9+e9LTAHT8-AWI;a!|PcQ#RK=Z9HAipH9tLF z0g&Z7R{h9!%klB?0pNYLA86_5KE|N5y%M$FBDp5Zp3hG;f5&sHq?lM#PDP9BDZ5^O zUqiYh+^>UepiiNDEpuEN>*0grV)jy1yea8&ng*0|8g)DLo$hdd$`-g-|A>nC%dzS- z?5FUgm;ZeJ{P{^WJ;>%-|2Hvyk)T@l2a|Q3?rLh{Gwl97G~}DN7ix@qkWtlbAYo{{ zxSfDtyM(@iGfG%oD=F0cG&{R=QeE9ilqEi3m7g~T$=xtcoD*|H!T0rI_xJBEn&owC z+VM@td&}Jd(P({+d$>XaRLmdrZUy4)0ICRZ+X9`FW5UrzQFEQyhS|Bf=C=EG>wP?$ zG)^bYxGd&8dw64}hKI_8cr9|0hc{eLHdz!*=EAU$eAKKd*jhc-N~ZCxkTcK%ddW zC^bCw1r=peC*2Q?R0|>gcYOxzz1>M0-e)KV10u z@#92kHM9J>{0o3VGlM`}ShW*-olc$7)YPmidH`H;?jjj!es;DhDe17efp`%a=YXNx z`XdB0oivRjb@QJH-XJm^-U3lkzsMaemH7-jm$_S*0Px%pzJlAr$g6i)kfHVD1zuiW zh#$m5L=;=TrM5MhnVK3&OOpU-h1Y33-#^NJe3&Q3*B4~G%7bfbtT#)Y=M-%cvJv<9 zgHfw@nP-!F=#QSBapA1}z^BtCQ5KW&DLvkh$H=qox}T<#lbBSpeP`EwCosuj>!DtK zN#sw+NJMj5boT0ucF{Bw>vSQ4t3>kjQ-A-<6H;+;!yp6>Kk#{bUdtsc-9jbA7wtr_ z#F}S#KrJl$ENcjd#A%on5>3f*)o%1G18SYd9sJZKe>{0KuQo4? ziq^grebKhSudN_?B`J`lB>r=uB;Yp2q$jV21n`klQk z`HNig;Tm^qS&OMc!X^Hy&!|>sZ*PFdXVg7!kr@p*8V@Q|76;+eKALAh`RebQ)mO2X z-{u+^9JB}YywqvvmiBF+MJ6$QpP9}600IZ`Y|PMo*V5d)dwqTVYhNE5FauxoNHsw1 zh1jluHHi_ru?t}MFXHa*IPu}ZVm0#R(*cpu2Wsczj=FPMqQj`yEdGMRCRphM`_ue< zk?NY7r|IO%U&JQOId!%|SjyyKci3CzUe+b17Cs*0BSRczh?$jZV?X;TKEvl%a%8L3UiW-0M0k) zoV`gdc=xXXctBG@Ug(g10kTtQ{zc@YoR&oyh&}BwN=~KJ{n4W>axCb{1w=#`5IpRE zRXyS)=he9m9gc69>@5!Mi#ylQ53NoA^5RZ4aK^WV`5y~y7*>%|E%dU7cIpy|pk2+f z7CcL>$H-+oA9#?&Z$1B4q|Ht5-<%X29DKgwwaET@Wq@s34}}w7y|TxDiC+Ii{dK#R zEULaeQ(P;$d&l|wGUt~23>au_vFdCk0^(KLam+%2A(L{ZQP@{yvIsU01fn4 z>aDG%M#@qNhXv}@vuC@;$Ho%iba|DGj9pScxSNJX#?H>JC*O(@7l)3h*Lspe^MBmA zbLTrY{eY194oGwk0N{IqqL2NrL!PuQ5lx+6NzKbXrZsyL`0cudMJ=VOGSM7y24p5A zaG(Ve41bFwe;vvs$e#}U{P{D=20i>iNf#zs-3X>*%1J!$KcfT$j!oCD%B`MAIoNw7 zqQQP)yj|y&;!ePQ=d7%(4xF;q$;vWUctk|jzyo5O>95(hAYLiWLbv@0m#hZGu`vqu zThLN*M>GiV@bGkQ>xE{s0&i>tZLssy`JW~A%mb7%SEIPk^P1I%a*RZThI%77M`Q%5 z101Nn4x(dDHG50!?bnE@k60#%!oJ6Q_KbR1V5yPVe$iX(fY=Gei9Jd({|C_yza)kg zmSZQTrcR3WRef*-_6$|3S?_HiVhBtmcQnjggOaW*q4pdh4a5E~*jT5rtXIP-{{quj zxo>QiT0dG{Svj+_t^!w=$?>5vEgM^Nq!2_d=i})IIysfVvnEO>;7$v9?v0(;#J%uO z(E+_UbOU7UvDRMe?{8&n9_gFyTth*qRd)FiBM65Lp1rjeZr@R&Jh9NaY^D?`;hcLR zWcmHp*i}8AlBe!itF#!#G^cP4T_ec82=K3H#q7<~a%##UosbO zy9G4rltqhs;g!@wr!*D^0n^xH^_Etr%3r;HJ#trlo?puM*|Tcs&Iz2Kp!To@uR1ia zgEL?Ws-X@t26U1G%^M^I4`M{D_Mt=)I{XQt5YhBxR1RWoJf=4#xh*cwjePCu(sQx_ zZvw@MxBYQiLV7>Zktw%(_ih6SG_RH3qjf~1llP)8dIvsP`v8O+AfE$*+N%1odZKO{ zE`M4QD2VbO2b_DXI>ONO#tjnyU-EM{H*cop1`VJxRajt0Tsdz|8rVF(N0}GsHyHan zifR9VBs``D0P4P6aQt{6xP~0yTk^DrL+Yl14{N_*VWDN-o^n}`0xD2D>8(kgyB+0h z)1>>#-I|xwwiQJs@4?_qkoKPe76=~WfX+~LrG<|Mm!}%=78pe%18!?;>qy2Z2N|X` zg?fKwD$U^|cH*3Z?ZU*C`5Jm{SoB#$OQV%|=G%ANPGh{`2@VEnjsfaMQWp9tg zBB%HRMk>@UJBS^)GyaW+V0Hb&Qjf6FqGhFlheuu?*p&&q^*&125WA zK55!@h@Kll9;4aE`Z_x2ACk~B*`t0>wB}AfvCWrTiQRj`4U#*9<}qA?B^;HyBZ7i^ z0k-hNTxeK&Pv-jWzkTI_5E&ijtHkL>jPoR@S1_>100e*Ha02OaP1W0QQ0@RLD|16E zLVOkq$O_#Ygk^tleGQuRD$k~<>KCqE)-4wG+XwiQpu;3^uCr!nQ8q9ZxoqoGRQ0&C z9g|c!%BBBXKkDtsL#H+zhm^&nKPIHF$Y5?V@F)UfuF8KNooL zdy*2}0bz@vr2K6DcoW81O(Q7n0SZ{rSo~7C8o!^l5n4;LI-_bpZcqGJzIM6DYlrM2 zLBFl5_%1awQ`Nf(c~;1kKpp(Sy|@W@N^!o(ul@MZi~3bPGd~VMq~%lJ4CWFvfuCG` z`1%uLZYw2RGD5?4x#ME|m%rs}v)czHkxqiz(%(HdIxrlDhpn5fKUnH=D#7p_?q04`(jIwVp{y4G<_%$15q zqs$M5>MdAtsx8q@F0(=u1`g*^mVsFAUuZR_r+>*YAvMA(;M;T?r9@+Kn&#{0eE=KW z_wnjg02()1TbeO-MI4PJQa>Rg#`u${g;??1o(LlzC`CvlLbi;uL#_*oJ3>l*coT>X zB?KQ{H``Jw-=j?R>{|T=Sa#?=H0(M$I{cG3n3Pc}TS+8rmJjxxj3lk7xV7}&jBK71 z%E0NlxkH;MhUHKr5Y|L_#uP61La_16WW2E&#kR z9GghgUyk}yklbC^9sv~aIuzJ)_}!&l>|ee(P5k*2GveNW?4*>U^NQlJH|H@L8X6To zdowFf9{jA7TR(uXMaf#GYyA4UZ&z_`lmXv4aP?u`;}a7mmo5bj<-pJ}fCayWba?Mq z)fPqN4NzK&6s>@CTC-xrWW}nb=^%n9FD@+X2QfVj2Bs3PXe=*JsX5dB?HfH-$NS~W zmjwBZ`juhWFPvvyu|y#gO8t!8c37o9m&d!S>gTt zm+sfJOg)8`p&z4A`1$yD5pSCm9h$D#Fw;jFYkfGo&lPTkoh3A%KYijqIo&hcb523Q z7+uS^ZQa04YT$%RKj77r%*w>%i;A$4ASFyvFC=hnDbCFfYFA9p&1U!ZdHh(=Rw++S zit{>Tn5lcB*>}8Yh{)K6id;o|D|itu$$l)9e@P3xA;R}RV(G%f;^#`7{`Tk!OI}^F z0(hV@xy_>o2tC7x(ozs|9x4WpLoZ!5fDZM&q2)m+6(**qr)w8jWk+&H`s0rq85TP| zQKP1+DVN!bgPmBgCxV`UY#{qJCO1}9QF)7diy|Y$YFu5sGY^d%_xnwRleyv3YF4q{ z^_31q2S9GNbak-=`1`jsHSI#3p_V~HlcTL0tXYBgZu$6;q9$O!4+0VIrCUj8?5=&d zFEH}neo#@p9AV`bs7`yd82-t!nyE-29yFw@+^K-P6LZFNo+F4FX={gb+sa$!0CW7z z&CVH8ApAa2r*E$lLnpeUnbWjXK9n8VhRvpCntXfG(g#G&%~YZSn1=YRFX&#@n;tU690 z_#GLHi`@@;WEZ@U9ykGnH(5qa?PRA7x|0OF3L)hOjp2@0-uFcL3TPZ*)NpIK*=Gn3 zk>SW|8kjLZf=TYjbwtzsz}L^u6W1ms5a4VmutAv4;_)VgVjkeW2a4&+KDW)C$VdEO zJ-_BR)z_0lCjs1t_XIi$%Z>~h!g_&Lun^Lvp&6LYi7KqQF@S{He+kkS5(&V16}WtZ z6FqY)|0cKNE*!~W0IJt>BY4o~oQB5U#o^!F4i-0WR-&ROUc*ID6h54Q=N_m%_=SZJ zZ$boKQC*!Ae-x^w3-T5^xzVD+4$DA*o2jvU!SBEcvj4da!G3D^K)fC2f^Ffm){{~cwNY#2RJC&2=T1C{CCvVAf|%VD5+}Rb5S@H#XR}#wlL0s$8imz zTgE#}xUSF>9xepzb>ovd5Y{0+Nk7`gu=MijHL|iIL}bH^ zzHpYweSDjj=k4xJN`<;8ZpW@?64K{Fylz@qd8u$6Vo|%DrtnmD^j&W5%CD1=&{iEK z?>j>gQCHE>upQ#DZ6rg@L)h8~wH-cP55PZ=THD&5F4$Y%yy*dM!_?IDe1TQh^;-4P zU`UyvVB_2bpG6I=vU8U<>aQUO=dz#mXe<&yGdnxX3`4q2E=ZadY0mD?n&X92$cNtI zW9R#4nU{RPB2}R9;^5)g2K|$6M$ZSr87NFvsi5hOLV)f{E!rcB=Y&RHaY+xS7b1#% zC?9>_%2D|vn#zH1sCAREGBq+H0pMW|Aq;@9H~I$z$XvM+L8b3Nf5rv20f>@z!Ia=0 z6to8$;Q>)sC8TH-U%sd&b7dg-4c$e9T3Avd2W42s)slSx(KP=wpMjbh@9~tOZUFBf zxrg41+>htwGcT`Kw^}S3D^k^889}?)_ox3$W1}=zhzB}eCMKq!g>-7FpK9!k!ZZmr z-&$KaWn)?*xI|>7ZYL=^pRIZCgF^IEbu~Gu0uGG?n3P#qH*vT5q3ZzI5MurQ-8%|5 zH@8%cWWO!~!=ixn3WiPGCgjG}+8GpYWFTyW|LWZtZQ)=Nv84ar-Te`%U+J?B;V~m4 zxWa+0Xmtu-Fj1Wo@K)rdKq1mM-wzEdeh@0q&oAuN_w53HG|+IKZdY_h%LKSX8sMWl zXw|v+@$XOb>DE`(^8x1RV%)8%-n03V8C4&4kfw*~=mHM( z5w8MaL{LZw1$ZuU$e{ybOCacn@a!W5E)}S0R~Dz5?Wpm9Tl37YTK1f9=oqq7SaoEO zNl8f|h>#>q$n?|<9EjX zYe&ac+^omGE&Fy=j?0FyME@Cz_(nYuwwT#umLb{?10=s`?H*Z5I0KBpezqV9@}EBK zgR5DA+)AS55EW&Dlwuo@e+{vNvCpq)dQ1})5nu_@l4WJfVdnUqezM}a&wB8I0~F}$ z9>I9V-x=dIc$RLp>2LkSn^3N+XbMkcC3HaJ+ zV`5_ovH7zDV&v%1ztt9^N%jGxAq)JeAF`$%pXfoubK2Vb?m0VGqH@Qc%AgD;miQ8Y zp@1O6v_)FrsJl_4m1%ojEpsWV-aY@IUOL|T7noIf?qnt3++jI(5yB}L6Vted_SnP) z=+Dq}3wnEteA-HtrwaaOmy5CuC z71mAO@~A4v0|ZJHp0sWg;6IcnhtU5R2-;Qw^i9{!+=fn%jFpv@Nzjx!&!$^@u=5^t zsnh+H6eJR1ij}xOfBw+mHmy84Sy^_dew9j6Z^Cy&UB?Z2xBa$uww;A#UNAGR?I#hVXA>C(_j8{?@gYm!8Iqs8qihcB>uMpN1_ z--96Dqvqz<#4S)tjEF@n;WGb1K{m9B4L~&?os(ff?zGm1dn$6u7KJ}e9T;m`LioM5 zwpQ`^^A^+sXD$J)JM2-nPvXf%fgYcMT#&Wp8VnnjYgY+uwa7 zTZKUR+{tZucFRMw@3_N{A#&b#&qZ(f(@*dJ?5o_05KSMgx@dpo1bI@%ap7O_QrG71 zR~8Ta{hMVkqto(_f&?$;MKjAUpr)%}S(_E+$`sMOSo503LVW!-aOvgD7-b15EHstG z!!;&OPENws859~yiQ0hh*$`C*;L!@`WiIPIMA7^7({0$$AHGH5MIr_4I|(76BnJgz zq$lz;8L0v+4Lf+fR}8sO*Q$u-hklC?Xu>0oeys6|ku$dMfW*B$z<%Q) zI_v-QX9s}0=bcepx1-6=#zE0L^jSV~?&& zojSD-U-mm8!pkc6HP=izQouyfqgprDlxA&XbxK}Z7lK@3*wZsMDL(N#dWBz(6CzG5 z6getn9+3e;w0c(d5Y9)ZE3gGv#&uslt7~n2UN}ai*X!4>Gwr>i(^KZUAM(E1MlC3b zmA(YP>qHo|*T9akd|=sUqx~u}otPFe$uyj{cRgt3tuIT7E)j6_`yE%=z zHE0uQjw5S4$(4FrhS6B*8}j1d!o=DY)*C z8Dy@*s|FwLGZ4tIl$J6Ye12pVT3Uu}TTqq-7ob3`%YotV30^NLuBb?iAQN!nImXWb z{%N%X-C^0>(A}*+Y~S_$JM6!Q+oa&L2Ua>pM@y@2+WDV^R0{1Pef|w7%@Ek^A>$}C zsw9UEgKh!jbyEGDe&MZzR04#K5`zctY;Vb3wPAs>do$#SLV+ZAC=SN`(@NOF6Ix%N+ zX>fNd+P`XourOZ(ukTlolbg#qiKdM&*GlL0Mb_Ln%xe*_0dDdgz{+o(1)%N_8>>M7 zyb}Bmu~e`dI)^Q^v`{Je!%qDXO__3&Jvh0`2M_T|&?rOWC4lHY#t1dV{FA3o<=_;{ zpA*FZkGjENPDNq3^XuoOoJNDHv+6)wMCCvLf3a&|VBiv};JlwubiZ1Zg9P@SUD}Q5 zbJgJD=GGp9&iagH+he?mRdVM12z3AGB=+U_bk0jj*JyuDyw8TrKtFd%%Rm9`Gq#>t zg@;z0z8z4#E%hDZgoH}v+l^1Yv_PXszkmNWva{Qbn#voiR*CZ97r>zw5J#}y@x(TvdW>=Bv74GaD`=cp4bA}9ZioHdhh$B_lD1wDDWu4qg z2pY`~VA2XY|1H=|=q)JFTV0+N9q-6|Gs~1bE{aJ*Uhm!srJds_{Mu612GZUe>ZYJg zbb^gcz{-fp40W!pd{^_VzN6GK#%?4ES4FFwgpyu=79VTFg62hO1JG{;X3EKLY$t1r z_RQU`VxKv)7u_^582|^l5>Qw_4Am^mod`7ca&I(}w-Js+1PggSFF+CePR@bJeF zutdhhV6MxZ!|PN#m@4Kckd1G`@#Y+SRqp<^we|J76@taix`3ocbj{Bq*!r zj$cl#&|x9QUTri-3HdOeK781_aIX?CR<`ZC2%(Uu&6PE&4dO_0g&-DDcP|}X)Er98 zkW@7!R4$AUngFrrkCBEI$lTX))n{NhRk+g(&4_Mm0P&$@EX?Hq5ltI$%7sQ;2dj4y zrWuqWf~)`L=OGG&po^dHRz06A4ysAPasPH=g-l~mtr!;nQ?~ z`03u-??;_$%84+Ka;Ic0=|Oqg(6d*2#=lx0{L{DCsGY&V9P%)HVs ztF==d?qUO?yX*@65?6V#IFaLFgrbc>0yV<*O^UtPcW(OubnhmO|LUWBh6OfXwJMtJIp$cj^YO#wdD&7zeRY6Lx6o);Nc5o1cYx@8( zG6k{8w1*0D#4vS{D_a_P7%@C%_Y-uVa(Fjpju-#7M^u3jk4Gl)H@}NQ)1OWJD(NqZ zlEw`nJ4aS&QZ--il5+=``e{!BjzbmbjY^>6DJoI2lGB);M~vMFc7MGsPcc&RSt6wI z`$DstRJQZxvCRXuq0XrXzCfg8@;bmk#K;k1m`aMqUle3d!q1eC+*zJABM?7gL<@)u zBQ%MPYi;b4Zmm)l(#wu@!YUVc&PyiN>)X2yoIA>SbggDt^q0 z`^^MHOZbFqG-J!{Q$ zCS9Y~y*w*+PPdDTz$tFtOIB9h(9#?z$ngUFXqU6toj*+e2hT?LP~kQcDP(E#eIHXL z3#lJNQ-+G`Oa(=u^`3`a0i&jr*u*;&>AcU!o_zQt*Nl1iGd79nbJrlI@Ilk~^tu-1 ze|_4HofxI`-+-XC*EvXkoc>7dJFw|odo@U9#Y>HGQfzt!)^&xGfXl+|8OfK@e=)uV z6VBc%b1#X^;vrFl{6pm&~5TNIfE6 zf))lN=>@(cirMFmNJ4%rl9Ixy&b+sB+Zmm*T<_b$n@NlV8Y<@rxQF{oOgQ?~`aCpL zp7Qca4~8vN6kcy3Fk`1b-)Xzv+wCS4G%QmDsVp-nY`=_hL-PUVN`-vO_4W4;?HNJ! z6_19oahay`9Z+k2h~a7*8@+M21iPX4v-l()f8Ye~Wg$jle>J9?zJHIT86w8|k>PTa zp|?`kha~V@*46z0xOPK>LV#afk+B8x=+k7k!UZRHLN_nJ0#yPGRXfptZiOg{I9#Zj zLniUW(tcgX4smdhp$li;%X8o(4q*ZkmOr~H)eq3#beLmMi4VNAHbgy!#_z&J>($qnny_^d$_1rz8WKp*0Jwdh52C2{quG~Cp$)llRR1OTb_i(@ zCnq7}nVg(ddVzR)5Dr$gG%6?-nkc#2?!gE__h%c4a0<6>5M9p#3XVt74KXnXdP?q| zwCyg~i7u27yNwPHKf>$R0P6@^znp!ImC(}Sp+Dk?ge(BVQejam&T@ykhx@#S7Jmx= zYs`{VIk=98MKAOT)Y~sqQiT6qmI(N4YOL9>rRn##Mls0e->bYq9J--m=~CQLoJ-%Ca!{PBR<;Cyl0 ze8`nKda``2Dk&V}E!ZustU_+1$3ZV8C-@I7bkw9reQX@OvA({LY_by=>Jwk?;y%dd z{M|O!Ph)i`hcR5u83T6&Yq)L)Ld^F#ZM#fo>7H=Z96=jkM~r6|+ossCDu|@tYD-=t zEbz2V^1MRYOqv21qHyybEiK$m#Oxa(At4x}_YqSDes2&$dPr=CRz)FHkgp!?%0Irz zZhwnj6FIQ5PMQqbGY^Q9YaN^HFa`>&Xkz^gaQv@euMl*e!aAGy4=uT`pf{=ye&*YR zETY(n1`Q>g;UsWi@;_`S$()HUSi$9DTw1}x_4Ho5h986 z%X50vuby}Uv!@+JoMATpO_(JRRMiFEqiyDD0O}fXet)bnx=J}%&!xFc+VEddgJY1~ zfQ~u{Hi94`328TyMhygu=5Zb#9;PpFMEYSkWs)73oDA@-HQl>{&zjXT7mAi}791NH zANPCk?~id)>_L41C(q-Ds1SDOu5Jfxn8I|B6c1ntu7W{`qWp-V29L(jgw~k4j$_J1 z(IyUEw=; zD&eOZY6WFEwwjza+4s({T&lO+G0yStYEQ$7CsCbqGm$=ye;s3oB^S?PP{)Mp)hn`| zAX<`Hgv|Y;FT7YQeQ}J8 zWBJCyH%+xPs5ajKH%&(gl6LN(v%G4oc)P=a`BH$-p*YU((l{@FxPLnzE<*#>DSUG} zf@FADF*YGWO*mio85)*|*Wn&W@^3ig9;c#WdIJw@8XA-|{FyWao-|acZ-DEi!N!qJ zkgXWt_4#rzdWoX@vvo(?(Q2sHzyxv$@WB-X5l!^Rwq8%C%2u25HlcB|)g6N={Zujs zl+h|zOYf=2irUM5Sp8eV!_8gmWc}u7de_=cq$(|3@+%;PPUZ7+4@W+uI6Ak*0Na+k zfXS~qtdcG|$CAInENV^mMk`(YBKGprm@Cx$8fa8@@$%~p3v+QPu46dKI1**bw*mx~ z=-;20n%y=A=hxt~zq2gX)hwAw%tKb;Rr)8jTXHEr%>`4KZ$5zErWldXMv`VQup^OJ zFU_YlDDc1G##z@G0N$D`K}r73z-=qea$aoB#)CJZNk4Zo@mDwnz<{BJ(w+Zx!d}}#5Xo&ALO1u*uY2g6__drc9pvw{_Zp(B zB|Op2Wf4ec_07%A^Pj-DPx1%~wqBlThn7DL5|OBtIQnB6pXh~w>-K(2&jFbMVP=HJ z@8MyyiPeN6r?KZ|T`$%jB3%@?+V+;-?Aic(e&+I9a}AahylaaGfM|*~9hX@z&(0a)!YOnj+BCwN3n;T?%kj69-Z?I3b*JWa0167j8km zOgr`nFvYv6!Oa^jXy!NmJ?9l_rPy%@lZkt76Mp?T^imKI<6y?NmudO}5fPQ9ka4{DsUBRL_R0yw!(NmjT z_-y}A2%UOcvFn~7M- z$;rtNWSKxKMKHw$>;A6$QM;R_H}3a}LebytDL6QD?f%#i5x7?gE0)j0tvK|}3+r}Y z6Cat~A}XXd5sFJd-!20byl^ZTjhIna$GaP9uSYOP%KO;lvD5GT%NIKI3)T(q{o1l| zRQ{8ZyKg1wr!yv}Czvpa4G8>F5=?8HS2GxZBo z@_z;gO&XHlL+U)l-}M}hK{*x%(gJKqFBF+k9mh?IqTms_J^L3+ofcOMbSq5b!us+^ zT#Db@?CflOxTLT6z3KRyL)owxbk+NKd+VfB-%NA0E1h|4Hmw0{lW0mbt%5Z!nBBNh zqN?=fYDqz+&~01hbJQ%Nx8n71OKy5|OdjRrl>J#~|FIy>bvz1>5iR9bCO6TJB0-h4 z3bmzU*k7VI?G`{UR%mS-5T|mK9nG(+9jKPBh+W#AQzd2&AvaKp?BdnSBW8#G8X57y_KO;50^9{>b_+{F64bXtGihU%r_@47LqW~I z;0m3CAC>s@0vtw?G*CsTeR9xXVp#e?jJK-NR6F|!C{f#LiT&VXn<8}jOBnC**7}E_ zb#Ey%GCBc5fD5rGepWi#{)Q3f)g6H*`r6{`tSlIR0@;$7uAtbpDsr=x5|>R9iwVS* zvb(Vs8b;wSD%NYZK=`O!SLW;Hl1ySeB7H-i(XJo&7t7Wj^ribM^-=V>|GPL`w;zv( zFW1|1N)4u-7Gw4kI(14L%XxWWvik}+E>(Q2)R|a{ipYVm5T(kFtgBYtfDDJi`}%N9 z(tyIHgLTqMzQ7;?%KtX>5rK>47$!U3lHk?0`V}Ch#G;hI#Xl)Kqm<>Xnc1&5kkmPd zmTwL2_$5$BvEjfRIWaicMn4X6b1dmw3_<|m#|i8TVTGu(U0hrwB=3Tin69K^i@c@} zN~rkm)H4*R(buvu+y@h8+_7z(?CceTj`tos=nlu&7`x?l8*C}~(+Gnpx6Z3~31$2D zayKcw!&3q(si~pDM#zG{oK0r%;-!$kyLBrpTA@>bU2}{-ZpGxxgG9@OqYa5xAo4na z3_^ZW^(MP){H-ClKpdjE_51h`CzxlHPQZMRgQI}v6u(2eZ(sN;X*m;>ugA1AzO$~1 ziCDB$aQx&c2UwiI;edP*L$&YZVoh;s1dGLr`*N$H+h5VS;vdAvy`e$oaIY{^R;Ocen zgKPo9mWFk_5o_yCEThUuJH|HEhuRvsT~iI_R8V1fhR{A6c>F7`15Ps5?iCbt1)b<9 zY#LBi45{WCSu-0&?;)xqeOug~^Qx*MnT)lD*9{FrPw2K5T*EN8ZnoaFU9!Sx1TSVE zMd|Tvn~9rilV=*7)cVDWfRWWp@7Xul{PXt+ZZGnkC3NEi2U_~!L(a`ME@;xpNRXe| z9e3<=U7S%YqS?AM?TOI)mG=rHg|c&0i-=JLw+9`JM{YI*V%#m}0SpW3*cW_ZV$#ju zb`wOqO3`q&d!yu%{hi5|lzJ?y(k<;D*hd~N{i1>%hJu8s=Y#QJSU6*3C`aw{`WsH zc_bxG0h3E8kVy(|C({FARb53)`Y7BhHXMlIMPQxvZI3s~gt$(dn8xjm=r;PSHEq)T zeKsT{RMg~nq}DC-+Y)%jp9>1|@&w~Ta%Xc}qXkhT4XNVf-C}GxF@)ajM~p-&|JE!b z6^(|kj=l=yx9gR_dKsgxzuS1bn`%Egg^S1Y|5Ykpzn(Z5c+1>8<=E2KPc=0!#IIN} z+?b?EeKXfZCG@W{@XdvSc4raDW(zo2CYu|Kj=2%(V=V@!TYGdWILGXBXJ_ZXGwl!s z`WPJ&7XHSuWY6HFoBUz;u&P=~N=yos-c?Q8RYhk{R^KOocU-IgVQ9{o*d6qyzvkte za5j_akO=%USse9|v9`{QZhsGTxKUtJ=($$nx}|sH+Me|ght@09ByeQbeapb+iDX{- zgxCS!QSG;O41!x3QCt)v91cJH=b>)v#c-uE@Iz0*wjWfU+Q;r?>9vn`&}`rSF;Hrw zcE60%{_7>IwCXZz%|AOk=MQ(bYyPaN<~hYHM;M0(WC!9hm#@hI7IQ?XvfU_3@vW-#VAMRaaNqY zp5WRc4$*#{{Pf~I#u(yPC5iYAS^*|@{4q{WB5L3lQ7;g`{_pqW#{Boy>-^IHeVKSq z;@AK0fB66Nxe~jpzr0x1fA+tp4c>pFnOs0%`9Wi*zQ-vWcNs5t{~e3NtMg=j3?Z&r z2045oQ8am$TSB?XO4kH~V!t#$``>#Eclk3*hw(_Cr{=%zJ?HTCt8~eoinqpp;~HNl zll?5AP*<<;+)@!E_O}7lYyCMzrC$rr{ZtU3z$rbejpY%{Zua_L39 zQKz^!E#tagOZ%|=e{b~jIzE$vSD(BsrRbv8kN3OpZ8-OP?FN8tz&6(GWjcp#dnvc>-uiGw>1BAf;Z&)0Fz3qb-=9tTRAo!#g%f=7 zvRmr%-#d)cx4b(#-M4w+Z)q6AarcitW~=Y}$g@BE-f+#Kacq9UoLg2NbuHxcLtj{rPGA@)q*=V&KF*W9hqo)X_{?tEUd?>(_Q_Q z`#HATCxk5N-&%&9c1iwU~mx-s3>*T2tHkGFXzx` z^^J7xUgh#eP2fbsU&Yj!S-~r^6yz}xUmCwrkX1M*uN95V55GE>+0f${SSDc;?Ua(= zS(rm9c|^G$+Ml;><*TcwZCF|ow@eQ_?eI8ntChJ;*otehkuHpat*%}?P7$g3)W14_qCPZuIFx=}sq8~*ahf zxLRWBeelLe`PHSB3&oea3)cS95s@HK_T&)-w(;3|2BQrZSN*~2->;XNJjqNfRh)$5 zLnj=|mbqHqpX9$4pY*i+xk~*B(k&FZUIwdWK#55EJoWUR{Y|);pX>{=b;(yG?lT``o{e z8qfA0RU7j1^0*O~-|N;dt#q=!k+S#xM4$8SgoIf+`Ov`9P>0SAB}{7cQNFmf`dOG$ z!eVd8(Z$QRT$d759%`3MPA_yewPpV=w5cZqMbVtlVRzl~c=z42F{816hLn^(w5Feq zbKN>W_OUsxmL`P;!P9wQT&sU|%B^SClt0eF(#rfC2$J)%q_?mixi`i** zZM_ioJf7<9!RulFyVuS`@B2)(`)be6#gL-w!#vca!s7eym}k(R)a7)f5}n|8eN9F2 zC7Nvi>H7Od?ByTj`EFULb8_-5CB9-kdcg7MSym=~X`XQX0v#%HcmH0xgM67=-@j7| znKzbiYjyuwV%KN&vyj%J^P&~{nd%feFV7SlP=|@mc9%ooBz8L_{M6lPtcxtV>#EW`!6os5qc=G zhn9m^;O5PWO0U-CGbdEc{r}1P?3%S}PnVwPSYu`XFIzn7Xo{V+ll2@i*_`U3$dhJ_A+Q~T4;LVzH7v0}-kz#a_{4!jp zSLZdGDFWNy9ASE!dt>)>+~&PIF}m+e&Bwf`#L`%T_x}+>TH2!jM*I11iu1!QbOHh^ zv+Ii#!+rd z2A_2c3c_~l(P`MZn5{0yv(OMuc3ivG%FuO-N)-9!jM0_*r5`*VOby?StEE8w&zb1? zMaO9p%=9O^=MTfe&37HP{1z1Y^4*Pv)xw7#lCHb{i`rl|H@~p5=YQFx-v0Bo zH`c{%S+Npz9Vc`-c`4gc>L|?>&)gYph&`jvc2Y=_=i~m<1rdjI3Y zqC`0-iW4DG$6P`#V{V0vqFjqIWk}>MXV|Rk6mrYGi`?b1WNw*_lrYzcrR0+9hOk*| z%)XzF^EZ6=KA*im@8@mr=d0R_2_|CD^yU5noNSwvx_Y}abPDO8sX50RtGcAf z+1gysMd00CeZqc@IC52`(QK*y@Z!VpLu+3uo&+Bophb|v&mtSkQ2T* zf3a-qn<;x3whCV9(SIAWWzb)ihO#~vtw|PB^9aB!F}+cuL8gyW@OTqg2~T(EwKB!> zamOYl{)0uHw{5c~5YGVwp?BGPt~ZLGNG+NfLn5=>)l{7YuY0j0ijE~(H|g7E3ThH3 zxbJ#jW@hZFl=2ejObv`B#0^K>ISXXBH?*{o_N8CeAg@H+FQLq8>6?%#zd{67T|MhB zh`s)?8=xX6vVJ?Ljl}-o@j%pUoW$ksH|-#|W8}Wob@BqK7KVZQrSpOoMlW*%8yv|b z=ts&n`oO=dQPraAO3Lw7Xm)tF4V~ID-N~FLBTS8Bjg>7`oax7ukcO|xY6&D-2)Rnu^GLz&*jzn2konbB2&oTuBIPzlB zLQ0XXAQ0h}|Gq*H>%=+ND(f7ee2$7Yi+(RJomGR9jS(*>srPI9?+H1b_*?mJqa@RP zu#G&}wZ3vuDdg=Rwf=V;il%ET)b>aaO1@(QHh&t?TVOYzdT=xxz#A)PF6%w{Fj#=& zz=~|Ljk-M=uaAut;MR0cI9j#Oi(sp+vX`17b19pfwzifSVWAhd=Z9`QZxk^8*qNq? zsCg@URz1}FhXowU7)Q*SDg66GIqfbgX0%-_E`lqMr9YLF;S`^f@mz4Bc{klo&yGXK zAbIl_!^+K0-%S7`yAhhsqQLS0SU2AKI9IPS3}4Okct>D)0wv)y|M>Z(dVGFYi_)%c zF!*HmetVnC?8!xu$zP*IM)$|QMj!dBaw_6_{w6OqO?hKLMIo%j88T7w68m6pPbGLq zJBX%WL7gKs>A78R-ufL_nM$IzM*Of?{}l99a{kLjM5G=jHe0(TS&=$o02`H!xskwG zcftF$WeZYGCtl%@yZZ`{(ItpzqZLMZluVH<~vRTmVLRRb-d&NWWXgI_*W2n_?|y)4fG@17nTcAfKXOra)|rXMW@xy zpMdP$m_C4Rj`07a{puB!e0uQBtHQ_!4{a#cH(!IDf4bd@>rmRk1iY0v?@G7TW4jg8R#fZ9W?RX7fibv1qM)z;^iBq#K4M0p(kMwu<$#RaZ~SBLApgHitFchQ2^VtJdDt< z>z0mSfSsz;C^iCGT0eydz=Ak`LjWVS;pYIAhGon)p?X7my{#ZD8tUhN%k@|teb z{q*PhD9?o2TV8pcotVVk0cICkn%lmD+ooO9HVRLM@vpTNzBNR~p*AjTc2YojF(@=t z!){x*x4&F`C_6;ciH7Tv8u9xqsdQ7&gW#|Xat7}={K0>gpGnk z3j(TUOA?||F!-gf&b=%ZDi3(mC{<%mEGomZ;IS0jj)0ATdY#NOp44+$(GN%_fpvUy zaARU(r%WHwP6d>%2c2-&TV5Z+gy$~?$PAp&c2J#kugf}a3qg1=d9}mXaZH+-6|j%O zIQ94q{FOb=Oe*oX`wb)wuf1)p_qMhVKwE!{ch!wQ4=BGRUDjcVHBgKH4Af=jxSf*O480MPF|Fd?nY`2IAMIyfqN9izZKe+qWXIZ5wt=g_PA#3>$ z_TKr86K3D)sE+}~38V^WXPZ*1~7O%rHB_*n4jxkhpCNzfV zG;jYb7zSju)V@~Ia*OHA7cKZwwR~+yX;g%a>KeVI(h>bcE^X2!(SBP19%f^onIU+7 z^#`+%eAAgmOMkHs$Poyq&gC3a`ty$+Xt@8jM%mS4;pFD_CU8&yYHD}-uG1wQZKPyg z^l}eJj0jE7PGaem zX&J&#A#*WK3XuT6%}6Xg(X11GA-Vh4)>t%E|6UwZ+~_w$ne>$P{xp)se;REWZ-bjB zGWyLi)Ip#(OPR+YZ60fm-;oJ3HZeq!?2+EhkmKM(5erNcAnpRpnl2H?;*R9J^|8HT zvK^b|7T{k1BLyg_s)>h6Eaa*iH$hUfH~KUZ_nT)}IGt?f>79(MQsZ;W!|ha#9R5*PD+9XB7^03rs6LShfc}W7Xn7p zuoVBjapZA`?ZXdS$B{@7B39kLxN?-Zr{a>L4r{i4EnGoo5Z!oK|F`!dAk-~axx{1c zy-=Cc9X(MoO3@SwYF5_KSRPyA5`k3?ugkS0+agDD%=)0n(d|$2+)$^d zEbQ5W9;H{S>xU6VS|E_n;oma?L{we%Vu$|&!tBWLbTiNQ;5=V@R$asb)|CIWWD32> zsF8G+(G`tLcxvN|EcBf-2{zmA=@J~qM~-5+gst+YV3`-wwWe&zl@VX&@`Js@-WeLZ zsyudG_qr1@bpsV8iRx~67i-~a_Wz*e{}sBl#q~Kit$DsX;F4CiV?21H+IPRb_@XFvFl*=ypcnh4*F$mN*Ne>+T!U-{qNX-rz98}gfG5&r< zE3(dhrVDVVsH?*^%~7f4KmfU>8SMH9Gb=MOXzy)W>D>B)OrBoUyebN)i3|DnSyMw5 zdjMxg?tW8v$PtML_klB)wr5B6ZdFjabCk`k*^CyYqy~P#L-DZY=3DNZkfMOg9L0Ru zsX{N{Wi<#G*N_W}W~cVPw*u;nkAKA-NgeRJ!r2P*X`Y zQ5ptX7AVrWrQtOw1~zsAdICE`O9F0gC^~5qTQg^K0tOZ)MuPwKpy)&`tes693Ft(v z4V+DcO^ob}O`v#rp`4r@O$=0*?!;$=nd^Z^hmwkJnii!CE#NKS z5k#c^+AFk^JonBH3QDRfE43t%wRi(T_`46iw!i}<>7$bLXPJ!)zdQb1U9lhmA~A?Y zgFQ|H7y-E;LXaGiB=mb@cEQt4$Rwm_pc>%0dNfCxlJxIOWoL%MV=G182|c}jok}DS z$bmr&M>1F+38V;2Mvtpgk=yjJE<2@at}ck+}L22sXI(fcQV27%a;UV?$;l=zYW3Y z5|L~@O@oyr7;Jx}ek>%T@RHi;Og6L-FYFLe49>80+G41G8fav(z7NDcJDpF!(-dMt zu^~bUz?NK)FX-rg5@N$zwKh+7I3R0%i`U{)d~2s%`aCXrT%}5>_yb@~(5N$&{gE{2 z#*n;O@q#mifa;t=t@cVF<>Ds=t56R(Ut^PJR!R@?t7+D#A=xht*YBj25ZX4bskf^6 z%aP%E&AHj}#vUyL5okd-{A&VXow&N2v z*kkq4G|49l=aX|sA8Sf2@zac54<+e8RumLWXC>svpC%;wPNfQDq?} zY-MTzTVdg>Ycgq0*5`avU-hfO;?^JM{zc0P zK7&F1(2F#**mI{aAOe0DxzpAg#}eaL&I~ayhcobqKp85|6CCCWuxm9aXGMHz3c(t< zh>s+~7(nz)(Zi}*rWL1gJ~b(Vrv4e#ioR;&fPb=0a8=b%#%3n84WjM-!c^51K?s0p zz}N7rD`rcl8pp6BYMqNzAGJni#sAc-F_=tCu~|i!{m!qDQPX3!s-b`(07wEaK8z8( z-d^P_-q!P+iF0uDWr;Al-$3V0JGZ z_}CATD3BspntYK@{Hl_7f-DaoaipV{+QHCA`q2NFh%aChmP|;NEbw~WGr`O8X-fmH zCuHk;4Z(z*^f;Wd2YqHru$^O zSwz7J$i$0f!D6uKZRxhWk!_Js45vG?9I^Sh{T#rLPtnd2QW&e*t#uhgs+Jes;_`J4 zt!bu#eaKK~tZx&J!~UCxGAvzwxx(M-Z0Sb4Z}hhjR<74giQC>*^Ef*$#>D1(k)FR- z;yu~zvg4JyCq!k910?}oHS9^Ww18NFvvyKOH#+`Why`z--4D2pU64HI82(_I?2at# z-gWcjJBh_#V@?dqEq3HbmVR-NeiJ4^$Wu2%5)^g&IflVZ@@<^ZOHK)$jgh#+MAWN9 zw^*c?Ih|=Fm+>(>FAe!*wsmf^ksT0l*mfF)v)yKiO*yE8MZoYA#KHsGwJ6p^%-UG2 z_KMP|$LUt6wM$g-{>VX$_7URywv%u(M-X>b;qk&W)f4NKFl=sQ9ApEy`Gcp@nM3>i z?Gx`7fDG)Rw9Ji_~yl2&#Z5zf%((~9~=$$MA(Vo49LS?%UV{MU=3{&2r#f=w?=w(b1nWnnxCjLkyx ztfiS8{Uk1Qf+^x=G9ayEs`~cWlvywUTPq?#vg=9Awi3*HUAq?87AW`aecogomF@x>P23hY>|9k_t_C9o(}EgH{ba!-^iG~ zkWCP+j0V1&YO~gx=U#j^{RM^B)d*zc07hBxKzL$5u6Mh>_GFe9xX`Zh15)Ns%<{I{rS*4VV& zVn^~>Ra-g)SyOrR1q=jCyqdB0$Fz=zam9z>8{2N65vF;*IEeoBl`CJ*8H&jAjR)Mc zmO9!m=TtFHuo0IhprJ@aCP5XEQalt(aDKZd;i3FNEvgz2TX4^ZvG@aRGA=Gb70+N! zgn0@fBqLlnPQ@HsHAocQUxMfjfQ>mW|5Rg7K$}dCKF0}a+@z2YMv64cQJNAaquxhl;g20)_C~rR5d~QcP{1M$9nTsrI6!a? z(hF3^w8hboM57d3`p)CE`-cox-|ihas?V7|3+4-)Y7788h@H1hUYvpuSSc8d@xiE! zkXWu?QS=1}K0Jy8L7qZ2!zJXJ9s-}+&p$fQsIP7XYAjwj1A@M+7{{oO%-D;gC_7L%wqbVOU9+95a zawWjYKigm2De@YKqf|pc{Zg8K_;R)BT{uhclh1SGE65k?@_Ok>hf;5TmJglp`?V$W zOiE^1evx^LZ5vjGC&tH1t@p$C%KMrA3*;_;!?(uP66>M_yR^b)6x2#BZjrvw4owW# z;YSIc7;jF6&#jYK)Q@Kw_u1{auD{Xq?XzVRMQGXinHIPrF7KAyQgnl5b#>a+wsg4Z z-To{r;^nQEqltyZ>uY;;Tlszsu~AWE@tbgT6Q}g87z=P^xBhg;+da4H*K~&jWfE?@mevTy&c|rqyMWmxp@&%d0obKy~^0EWXLYmA*FPW>&LE zF7n4gYjIlM#Yqbmqlx{<-aLy2$2m<*L9XEHLI@VO(*}-6tj{M4%xD`=kEdFR=OYDJl+bDpET_P^dMeVvi)D;9OgQS5Rb;oUUpF*dTI)I!gWB!HNa~&X7k()dk z$)BtE(_Y6WLGU&Gceb?ivlmBXvjt0Rh`ZKRI=!ZnCy?-v#BU)SwHwoYbo@!~;A_P$ z$xN2XY=o4-*XHw&ZnXJL=I`|LVoS(SWkxKk&a>KSDFnIFj`saZTXyW#-e6DXZmxqT zH{2(iDmPH^{b;*qze-A8T+@4T2Cc`?Ws(Q z%GVe^{q0dM-BKAr~~Ziq9df6wT-2YrH`eM z#9@AMZFdc*HMoNGBC4&QwG*@M`CAa5yUy z%<3s6g-a!c{G-9pmjaYA?2=F?;had_+(_r*zH=Ea6;9syz)X4%GE*KhN_`pTVm0r+ zpbvI1t$^u~;YPs96|;R6Oc1yfEEdMt7WToEn{tZx5)3^h)I(v+xr3uP5->`Qjx)!K zGxRYmU@*c5!p&qrXzJAD1?-H{2HzEo>xnX++Q;IMtJd+6wloeIw^qh=! z#xri@MqcD{sUB6uyBHHP^{oM?zlN*-aE9uAi&R&Tetc0KO*K1Ioin&$G}$=0t#n=w zdJ%4-TGq(X)x*4z{}i2$i%p+&*H!oNmv0LCsBYw>^37MeQjrSORGxw^#v=e{1?-Oy zze<6~Ig3(I{|Bb7246(;h;IeUE=#KSY$ zwP-}RpiR4fup9SoTIvI)^vbLusAy{KUxhZ#p3OM8;zHi6;mc1UkE#@Jub4KG;u0W1 zhS0x!SJ1}wj!2i`B2h!al-2U(7=@3@|Gt_Sp1b=rmx1z&6L|XMjD2uaF(p^Uzoiaf8(e^&B!~fN4QuDP|6M0kS65bSRYj7_ArX0#CDwv zqr`^xz6jL)-3|V}sMw>{#p~tizxpzf?dw5qsK3x7@GE|%z+%z!C-8Wa!dG6=JTB)x zy8Q*jG)}AjKiST}!T3Mu{=bDH6C*R*e@pLftjXBJw)-BveG#B&m?jpY=Nu!l3>h>) zRtQe6Fl)Fb>dlQ*(prj`LvNo85sijrrfex$vZ!LidUZQabzIf{i?Cau_wT_+w_Cp9 zeyZ0;Ve-n;Z>r@=Wl&#)lFHNVi(K8Fog>Z{U(Q;#{FezZ--fwQ8wwk}<`|vd%lAinZ>`G(rfI~1T#eE2f(MT={lRYJ!p+^pF! zA2*sT;FzsnR+}HthYPmrM+p6vg(qn3E6#??eeWPNSC_=0K7S1QnFceWMx;A<_ z?w-tO;0bOw8_lxabm5ve?)4Wo8n+(XKmx}uR>wZ&P*_R3WOXU>|u(t;r9N|heGJyic!X?cFTeUI~Vu-t}faesf zeKO&K=a0ZrPn7VC!(@!=vA>-U%IJkVT;I??2Qedw+-FyO!P4Qf1G#u>kZ&-7D&`~`OQoDT!dd5z@<{_NsxWL0ncYxcki^scHYb5PZ&FKT> zYFN@;vWw#7Vo0Lz!f|t`gc0wE&Mpd30x!~!H(aVO<*TXD6*0%`bh?L zCKdNgF!HY73MlahhpcC2h8;@SJ2KO$VbGZ)`rHT9=gf!N*V$cmbjRD0Y5ZxdtgPP$V}Z)ic&-U776I6Fya zjxhsQ`5p8uyi>E0Ki!S2IMOqke@^EQy02jNSd9PHMraF2d@ycKlg#)f$xMm;9*+>L z+$|;{fgTJ|i~(?7Sfo*D2$;h z|5x+ZW)q0NyIhz}b@f<-easDQItGU<%9U|B0L6 zseU}IoNJyPMv#y!)d)z)ili~DjiDN=h>BtvEa8%(uOp#DxO`6Pj4k0ytaZ`*GyzE? z(c)215|?34(gVmOlqN*t{zgj&f0zzw$Vpd?E^+y=Ev^m4uHl!va52 zci$#FO9?59sS1q2F2CEXKaE5QXk!YEIPST4RDzLf-|f1UpQc&7Qhq2|fZEUI-@ON3 zdsovKClU#Q#FP8^I#gmVnDaOt%E3+>>d_!&8KA(G2>h}wlbI6+V_{#Y1i_VDG;tE& zqGq8rUZk-v=IBw_Jx@G|vMsrRgb2fk2=O@SH)s?^zS+eD$nf!gV#F9R2^^$zpmC`p z(#ZI&U0cDl_coIpevAAa@4KwlYRl*ha}bFG5TIp=_>cJC>8D_C;beOne_)5;qY8bh z7ok*~1U03cXmVCO(!v>Le;E*#H9f*MXZL6dbjpFA^q|>v zJStcOyxH|X!L5`wFO0OvRlW+}DP9-!z9chdF|WuiTR zh+b3(g|91OE=+STyq;}s{X-Z_yr+tqtB64Bi)v#xWtM}$3nBjcKm~h=p-NXkBSZoU&u`wQ~Fsww)CQ6a`q(ZtxBR z2tgbM%FB$1k)?RWo0=J0AiYwz_2DIY|I+eEME&`^ecRnV;k&8#qrgGxbkycYbz>90 z^|Waau(X=vyjRr|WwZ|gwC-gwD5DnC#N=fpVw`JwMnjQp#YuqEl)8;c^42QvfD8=d zB(Yrt)FWa2&VZgjN1~%B<$Hf(DM8b6yrq(Ew-pmb6GI5^r9@ajqg(Rm>8eDGWMh#d z!e$kT0jHt^YjR^zrE4aj7ML$WsB)xHWRY>{rU(D~`TB^fxFy=5{i4Z1KAYw-k zrg5|Yp4EIoFii|H%^2EwucxM0 zZ+lT4vVjU;_5fefy4AM){J>}PsjbBM^wtk|g#BGo=zV^5kNHAX6Zusdr1Q}lgr9<- zMcg!6Pn7-c9-{qR+YcJ^tmO6adl7k9qxf2bJL7c_KW1TjjyHT4x2qq0HW|*MB3MY0l6BdZ**# z6R6Ye->L>fXVs4yk2r)FE%sa=B}u-l6{5JCzlG`XTPj1s9P-jv)YU>sEOHj2Q4ro9 z{i$2ZM>F)f)bEAcMs@Pu|5?%$Aj}}iuPhUS@|cvNcg(8!i^^&+!(k3Iva!}sA84}W zsFw3aDUBrxiI3__x0PBgCTxJCfR!J}w@_l)nU(-@T3B+*j#Y}_djt((0Y%shGh#bn8btWrU@-wb zdeDw6iF)Ku{ICR|AJ=hpJ)ksqlu&<3;22wLR10=7CM3d{E7lv57xDd0%cmG$Ozt!u z-7Yy2V3k-qWV^~v;GujPW8zC>VKb`k-~dnZ${S0UL!$gcaex3j8ERlW>E$sPGahe3 z=NJHiWa0d^EllH%X;d_q{6%vTO6tm2R>a;(f~a-|IPCXr0<=p$54p=43aJb&7Sxj| zNZU+r@s%!$Kg@8kWU&Cnim{Oadk^HQ?uU}fsgqcxWyXZuNr z?mMFYVd4!4f;4urQm4ChZ*hO;2r%4M(M(B6ppHgv%jir%7sTL3T1am34YcOvq-;qF@;AAzl!T4%<3xaDM`Sb}G64rOPlCzb93) z%cBiQ;|d&6pqm?*81& z&>#vuz2eMHe^GzKrP0K9uQr((em5|g@#)9+^Y&xppay1wW+HCw-l`^ofKIyj;qK6+ z6ZQjutxtXrGRUY<&on5a2kHnQ-ovDNRu#&s5<87)p zT6pfy$`HezvA>LZ3SPhj1&x1U9it-(Jl@uA5{34{gFi4s4(F)SVf4gbX6>Blw=5wb z8YA@r0nW^xv<3&IZ|Hmd#?h7rUapGY?c3 z*X@?#mGT^lU})%3U~0hYA4J9#nN86bHvkkVu&3U0sLSnvVQ-Y4=8$J+pwg_xj|hOc z3a;sA{k*eO%JUgD8>+N5Hn57n@qZ``Ok=ciY1@J~J&bU3O6k-$p_5`@qd{d@vDGj~ z9uUYWiVYOLbM}xiNd{W?yq-$&(0Mg--5QU*ER(dsj25CE->i-Jl zGayGc6*}}N)96MJVS-T+Nh%{URkN9@{kYj4n=T~V?pEVkFXO!j(4+(M=Y)Z|FgXK- z2e#Vh7SynjFof70_uSUnHbY7kKuYr~E0l;IjTpQLi%EHr&;*k_wvz23BruQ{)s3CE zFJUOxkEK$tQnsJ2@gAogSk_I{k4M211q(_uP{qMwwKXpCs);k@@#(o2XfgC!ibHQ_ zas+G`xB|Lrbw_D~jG1UF`O!IkF_W4xr1`6UA6*6z3R5D$xM&WZ8cNV&HywIDrV?K^ zQ2*!-kMd+Al{DrO2+M8(WY_jB2M3d0&qm_`{#YY zg-Q|e%3tYD++5N9fD2Qn%|##$aD_TYf{BDtP#!Q15Ng}pD&`xRU$VK=+B1_xYIt!^ zFq;F*%8I=S5dyktR{|JyEYkkk*%l&vGPzqDc9c5^I~~k%&7_43)@KqT6A+iG->N!P zodu%sV1$=nIOXPL_x_b8OW{ZW%|i}Qds~xdY|^^>ZTFIV5L)Z!>%CLO?Y6UayAa5* z(c3_c5yC}+{;tU0J+@Y=J_^9fe-;Kax`uhE9sa;BkzRZ`CK~pHPl+d9PhpA!6sj6L zx*b8VfV0^hx3ufDXSD9tRfq9AP;u?1#zWV+_A8R+4Xtq{zo*{j4 zu&n|_h}&JAmh=>qo=YbYj)_Z0J;fW2;Op+3j=R(_gr2efax~=%((Vbhpz6}! zQ`!_-yE;V)$7*}&7xlNZY2<$9)9$7qK2F#jCrNO`;ed!1x8E28xz&*c18Ihw(fNeSsdExYM((f}-*_~{auMVSSP|== z2Z@@#{IW=m4Z4mTm}FCAF5x(<^&3ZGw&%@k^E3oFC$9m9|M>#N$caq?5{2FGaE*N4 zQ{!H>ESF53+io=z#IgEK0*%*a!RsI&IJvm*3{DNUszq{)t>JjojLBT&;IsP~H!Jmn!DjwlqW9yZ1 z=w~ZIN9(S7MfX+Ai%VZo2?n!48In>HNstF_LEUVQ!<0Yq8}8DB(52c)wkqH7So!uThBs7yMl=k3ASEGV@j}tln=48uO}zjSQcZFkYt{pB=SCEK8}DIB8kX!QOI;im6^nHp&%R#`-Ep-QF35wLN9pOa+1>LkB^lBmMS+QKCj=j zjHF|302hllv^MRcJKL<|X+!UW$6 zmd`?4Yt67Bo?Mxqya!Icgl3&!04pR}3bE&a1{h>AreSHmP@EoR#gdAC@1&DgY{vA* zN-D~3Eh{y#`xmGA(2@c}P=`jGI`V`H#r?2zA7W~tXt>AFk|D&^)`!cJ>;%|F3@R=U z(s$fsjv-}ULa8`U_HfiUUc!kR7PrH41RG>Apd+VuDs1?IJlel5fD~vlNmPJ!V`Vz3 zu*QaR`9faH#4T*h1Da#kD;fT&*REoUDVH4je7N5+>CnxsFvAcQZ4A1#h&^acrw{Y| zb<59YG_8^NM$QRgv zN655x+MX4Vo}S?wRUDwg{S3*l&mhOzzHi(mHD0?BeBv$yph5Z1m6T6H=!mu`yG}8^ zFj5+6<&jH-8Sb8;>bPM;k2p$J+uHZUaUHcr2fi$Lp$liaKi@-$w|dLz7v()9IS8g= zZyQGoU1ot7Z{`MQ&6T%~=QjJeN#(v!h{;;}zFMQm32w?d(PM1ULZBX1Wj{KRBnMDT z?3W9ut5(vcwyZj7GqtI#s>c@*vUq)+z(pkNEkZf*(y}6?&?`jjk<+B%5KRT+<^hg;?PVWO-0(QK1oQW?Klk-K z@y-@Pd2wf`Z~~;rH-B3%)D(IH_m0oM!GpZR|B3-amNu@HmVIG^wKd%9D33OH4M+z8 zxcu%9w)I~Z6MqKNHi?Y#I_hT5uNesfa%tL$zLCl{8@VN=p@;=CZ2S3R_I6ITpzd#t zo0bN?u3>F3^#ctjA?S_Vn8Uz5P^Zvb5QoHe7`|BkEs=WS@moHAe<;LNWHOsPb_~c9 zOmM@;L7s1D1FY*|`-l&fSiJJQaFp6FL}IRo_efy55Dl~tXn?X#ACsD=BcMBnfvEif zN`lEC7!7`mZ-V~D$$|4~j6L!}pqIYlDeQe=7!AQ|Uk0&qbRcF!j8z-r`XdO83#Vz1 z)sY&QZp(RaD1;!I8NZvA7W6K}+n>6zc$hexP%NwFa=F@`r6XCxQ$@hi>+1B^j%PZx zsI>aGl9MCH3S_z6BfLJ2dPGbKyN6o}*ht1lKeThsA1eV`JS^-ywhmPKw$_AvYry<@ z#UU~k4v;)xApiCFzZ8*y=Dy0I>VFDO<&PLF*FqHp~3RNWl==IkVgyOSbM|SH__yb zzYC`Wh;_qV{D%TccT(@oao(;ZUE`n1x4|>O&l@ddDO3`Ep+%C}iPYeYA<_W0B+zWF zw|j8(4)NXk`akJG&=0}mKDZ4G%!#oz)bv&bEp?*zEx&K>x!S8Yw}&WXmHIjwp$1{f zC*C6gdQV4?5{AdIhl?oaf~fC7FLR&oAzy;}{Lj2dBR$ZHm|A=i4sO+U2E0Se$2-K& zMQvUjGC`q4LYu^dPn2dAMk9}t8R+|Fa(1&T&pwm% zB5DBOT);`;es$qCEK1g??zB1PVQZ2J`8(tYy%@_{=Sx)OM9`?h(@P^2)BnJSx>3am zm=i$6G!jGzyC0y=?Beyl<9~9OdH$c$my!N|27CVBj3_JPf4}-um-?3xMfjHyJwvk` z5$5N96DJ4nTzqo4YAYoH*9;_$rc^|f;QDyo9tL8jWOQH}e7sD8V6 zRon8jv(@YN$gPD^Eh5s{-l=7*pFo;vn^JAvTn;O1ue_?cvR0}!qBL1zc~hBp$QCX& zrD-^uw}q`v@r~ob`Qt>-QsYXzQ`)^@uL7K3QXN-l_>Z+EemLWQ+t~=QRh;X9Qjkl!)1S4oo3RL>>km2Dc9-;I}v)D^@@pKKBZPKuAbl?6L)-) zztzv7X)eF$lk);r1Js}z*eFO+$qopYjWo()r-6mV>S7#by9F z$Wj_Rvf4`>8Nu?WVQQECm2D)Y9NUS^8P2T3#SEopj?b3(?aiY!Ub<+wu6YN`S<;5f z>>MQclH`Fb12?IddRAG#2PigJZVRT=cA~?U6Kl8HNS%LNTQtk%ukiG~dA~zS|9C2z zXC#i+{89)iJzXfOTfcxMsZleEnMXoMrOxcFZXI)H(;T7@ryF7S@LeM3$Dl&a-6(g* z?jov(ped3!L5Xj1jB$8OCkKq?TycRx*yZV=KKRy2vR=!h^Tj8Ou;_}MgTXwHz+igvg z%O!d8wRx{U*bF)5TM;7-hk*HXTjq!VRm~H{mcFAiYd`=gFhP7d^Oz_*lQ1AaA1u68 z_JEJH)KbF^*o(}vkoVjb@v66#{5UmZGkK|kTyjb1Gl@1Bgc%lF-p06|6}t?4sf8aG ztlNc_-!CCUznw2S#|@Gum{oK1-x9icSs_dJD^K_Y3#+?83KUJSo`rlXDUxV1qSWSH zlmhWc1d+x$1Z~FZ$kROmK8|{3NAUcCn=GO$gcou|Do7(B0_{$Fa74D^G<&gBc*BiY zqMk;Ru%2|BmT+H6C2m-Bo;A99ojLG=8hfxDtV|-DNf>1!+~wnb%>D4lcue*kEMYq2LuxVx*A7oT32f&)eI{@QzM_5HWb#R%F}A$SY{ zdVkLXRg{A|>bxzB0RJYEB242{LWWd? z^F$^xA|kpDmJT&1O@NCDO0&`P;4~C)Di}@_$9Mn%6t~8vbJlZBvMGZA>0TYq4(Q*% zX_bGD=Y@qzl*9{19)@xWh#-`ASB59X_va3V?1ez)4UVvCHg?uQelL(h0423xl~mjk zWv70J2*Z6eNhEsq5AM0Rs(<+8^s+aH5CS6PHnZB-j;IHd7Z4Ek)Sy-PY5M* ziUk2}Vzi`iJHA&JKo6>xGsCxW%Lz*z`C#M!dnxaNxb5DAB|oVEU*en&EA+q6$tcqn&yfY*a4;(mV@}qVd@bWRc8h4H|J9YyoGi)nI%r&tj8b0A$PG>z#-isi}+m?r% z;27P!76~wB>oWC)hm*SODz)S_Ji1{_yKV4`Xg}&4)S)o$#4y_0xv>_+iJ$dYuiO!a zd*K6&S7R2neSTW<00U;yi1NTQ2Ie}$6dsCXYlQ~ z!LO68CS~TCec>d8U~*4@p(`6co=GHIVr3TAPnoBco<1_ zQ%SMAubCZS?ulG(G$hSnNlWjer2pxhyV95jso=mSt``esz6J77F5xPRDW>v~BWE`8o#a|Mpm z`+7&&l8ch_)$Dg@6g>{CbwhtglIWVV8p^&Wo#eZKw(gttY6V0EGwSI);oAE2@Ll}RMAA0Ug$ z0U+m|iy>pJ*oisD(=HqD4_PPyjve*gdzRUJ+Oy=+^)i1|sqHf;)ew$D!QWfU2;qvG zm{B$Jx)lxhm?KIQ1M9HyctAX*%E9Kmd%ycgO>0ph&=f;JYl_yd>le5-`>;bRaWB@X zaZK`;-ve=;QS?x`9g#(_p#Nhf@DAxUndIYB_G&_o^dXNI+xOBD1FWZd%d8bv-c$?46Cvc9NQu(0DaRw-BC~;5L1tidcmB!V$SYh%KS-=aBo!&ZyULca_Hvh&__05uv27v?RJ-V?9aG>Qh0_d@l9^@cl>061GZ6?z~+qcFv^LUM? z7m85INg!AfX;=1Wf_YDZ1t02Bemze-v=;OXW9?sQpwnJ z?KS;pNMT(>)_*Z=n2*i91+wLU{`x8ts2H@|{)h7z5J0(G9{VcLqsw=!Pa;iP1<4t} zL<>iQ4ne1qQ_W(fIjYlg-}Zy6fM=90&Aq6ADJAW~24?ehxl;tFV`l*Wj28}Egv$P3 zP{t{IS<&CQ*iRa%atm<0t%x`ya>UY!?2Ng9uC;13Q5jH*Maq*NK{oH$PYe{toN-%KVl@h)Th{i?#kkT>RrYxF6ZlY938^r}L{QBPg*NT`~XhOj_C zU^I#)-2ptThqYF|YhaY7(5e~-^2=j$|bu%VtYX}ikG*;J5(tg843 z%*=EgQZS|_WE)Bx;LFjrFyd?qnP(Bn`?{jRF6+UTZh#SvN_NZ;{T%7^BPN+8bt3E& z)ulcjP)>Wh#uKlv?A~}pOb)ranngKEvKuv)FGsRgf5h56)q$}s zEGH7bXc+-KR8TPfw>x{X&UfuZAu@V-HC2_)!`IISpnr|+sIP94hh=%!VF+Q-CXHM& zeg&SCg4x%-$$ZV9h-XC0d5s8Om6R)sxyh+ir-!-1Rof~o2|@MO9>>h~5Q7#&vr zT|IawFV9qXtHLsg1!nq@dhVv-GvEv`M~-{!JQk@%k0#5a>*n_;m5t{oEtO)st-UD~ z;RXoR>$ddF6~q@D%J{bQ;Rz`TD4NspY)8MFV^y<+%Yka04V9ZQ6t){->rI^tJY+bc zx0Hn&Ej=cuE~jw?;=9r(rU<0k9XrWH=H??*5r3Sj3+O->_F|3*bVeNXo(BZi8>^xH zpk2<2DWmrYgjXMiW5|MwgshfzDx^*6irDt9w9BN#=K$RF z*tYn#A3lAgM8XkCEz7Tn6XigJtVczbTCIlKgiVxa9!#rc8>l3vk7;9QmH&pyKa6-I zMW!7Io(Etmc)kpmE70d3>dc^qnuGRT0l5B1ct0f0|xQ3NGHs7jiP zE8HZR@v@n!->(jBsj$AM2 z-A?A&OZx(pJ$wQpERrqPc|zW6-mH^|TseJ~-wX8CW#w3x7Ry0>iKj2a3J{UiRc+&B6+PBy zNM3J2@sc76z#v!#UukZ6On&$(d4`@2VbxEhbP_;yN|9TY(WL-vZhN;E?y0lwc9%z0 z2QhVQlQN>{D{qI+3`c2ebi{KBc?@;doz6u9S3OKbaU8PGd7w6d|K189rtKE^Xjf6q zeIlFFQNa(b;Z)XRWV*Gg2xsEpOV0qp)lnRnQdM@^#q-fGjko$rL9(ql!4zt^^K6=l z00p`n)fo>UEEJC>-*_;jM5>8>vl-Sh&Bq&#w`5*UNv_4^l6`DZxxKY}h(gAHg|P&mZz4k!Kg0IxyvgFWE8`;5)mcHyAm=W&cerQVXO=w< zF<-Fi>f#*JQ{=rtqZKxjRZx8hS)ybDjj`)*x#T(CE?w0-k*#UE1A_nE2D;~CInLj? z`|RntB=G&jW_CdA_M^+PZyZ_OQqS?^UO3*_74H-Y*MzXsW8vc5D2nggFswOJJ#Fk5 zlfW!=a#Ul{yE-@Q2srWvSZNJ_bT=S7^Jkz(6L}g0W)n7x2&d(qb7}fh-GTyThF$b! z`<-d73rvuPgccQIjvg#8H^&wkBN>H!%ZsN#xp=nbfx25ab@)V#u89c~^#zn4vask< zoUT4miv6jD-Z2%^_}pRym%!ETY}C@n?{;zuYEI2Y|7R~hu=V^@^1}$-asAX)q+Y2g zJx{HS#V9OB&RJ!4rO4`}H6S<9R&85J4?G}gd45>@Een`5nzva)2t-)7Yl9QnQ5?A{ zDrH;_X9(lHLUvR(W;m&>-}s-FS1d9ud( zIe#Ns$fLD1E1X&9>hy*arcbK%bIxDd$l_u;vlUSPSNPXQJfkbE$CAeXPOWr!R+DT# zJ`YvhH;@nEXWMXA&#w24&S3w~f6$do|G@)gWTj{NZ*}Fg#g%%SYarB(-uXj+E@e?~f@v%Co`9OEE_tUB0x!;J)|Q37d3V zn^tg?Ul*iYblR%jj?cnAkx4m{rGroBTxKz+Mj5lILqnS`%@0hA#t%#9AKKLV@E|WN zyw%~Fwl~M`Sy1>4KLPsJ>cqhXjs36x`~eHoS*crmfju=gMDd)R|zV%P1Du+ z$FN)r?@Vf#xN#J^r17{h>dUT;+NzKi<}dPSA*=AJ=D>F?&$i4NJqPuvUa>lN(K>d7 zD)BqJ(rEkPYE%rP!X$j*xj?CzL}eOgGtL7uF&Mw$_z1()G9@%Gmc`$`l9`{{@%AV2 z&)j+g!<8!*nBPOsyX{ir;Ht@RXfma4^~mtz6`wLW(-$341(dJqu}bSS7Zat!V3>yM z7AmK7cZyEv1dv^E+BmVm_Bnl1SWWDN3;Rp)I_B%$!&J7x)L%>5R08+rTBuBRE2$@H zH=^VHRD=q~*b%Rj!5lSoL2!-OgH~}E^~{9_TqcnwB@pMJnw}|CJp{n;e@?=7>3eqTxYYUAH;El$OCPv_If zd->--wQu>ES2mSCo{Do2q27h~tt zoD0`<>)5t!+qP}nwr$%^R&3k0R&>XyGo21)08AWT4ZD_6_}{ivg|gT0RJ`{81bSHk=vq@)WLn%=HS)Ei;9PX95JpR>m;w z>L7+max+g10C`uL~**@~z+vIx(Dx3pvY7ljI0X){LlzybW3l)-S6f?}uq3rgXe?@@j%DXz@h`>d>TigP ziJW~fsm$42@3#IZ-z0N)q*Vkq?rg!NZ1I#EL}zj16$B$r!_e+AyPwk?P7W3xs9>Jr z!=xTo>@Y04T~7N`eZzoCUMt&!mIgZiU##O-+?q`Gk$7PaBpEZpSqLlY5-*#9>M0Gg z&=Rm4&-Tq`E+E#rIkO7ZQWsKfniI9P7jcv&@8a$2m}^>oozhXOH@_IFVt6Yoe2$@( zPUZ;cr4XLRR9D3bQA}2kwtZwECze4ltOl-Us-jY)`UO{-SF69a&DiPDqDV_f7)#Db z%B1pf=N1-dA!*zHTqe1OXeL**@&LyqlVZ;IzR@Do&P6S#2XxL-!CcTTzG7c1LillG zsu`Z>Jk$!2WA^RTi<~kD{leJV_IsXa*%A&rAm4ZAnW;=Xj8Lxym`-3=)^4NqLLQ@) zDDU02NC$E*cQxcbmCI>?65NJ{v&0{XT7e`nBEDBF$n??voCd}ZZb1S3!2wK^_VDPU z&|H3e=D`fyY-ExNhGaqn?MYupJt)-;II4gCK#GAKk&SZX=&-k;r@4ES5j!^P+irsk z($wgiL$Nz$RO@nn^|1H3Bh`H^gCc&l*WR5!EUVS>@`hp)K*7VCF7R1Y)wgWZ=> z`dta5-^VPvM1fRdWMun-Ks>q!h0kI#7b}dTAy+nx8K@1Cq4JskEX89k*_5ZC{QYdZ z&3v1fYr$|y4WU|LpGW{b&~GP zxQ#noqfEJQcD-!QIq9+?Zb7`qn)3AlP8_Y+d=}vnC5lq2iftroc=*IPSrE{%DqA4_ zcu!Gm30-jQJ%`11uk`XAMs!6%UQY;0TRoV2&l|e6d`+|L0=$xZ^}tXFSEVL;yiguw zyZ1_~W~rMv2>|ZHU`Gkx+{|)wqCXq}f6MKltEm2~U5rK5YNsIKN=>EJ(OwJVTG{tW z0{lR-+vE3Pb^L{{VnlgTfxMpC^@31QdCdhpJWf_G$~kr44$dUDO-x1m-K`S<9Isj4 z5Z2%lmuk*44(_16(KWjcRCeOd!*WU|Rrq}tGUH|5Ui|*c&g;G)u(K8X%S!z(v@p!A zkdQQ~swt52S0*wX%h(KNg6ADXT(QTBorGxSl`t_a@ zo6bltS=yVko)e1z<3-wi4Lkq%A9xNUdYmS^y@gMAhKVI>=$B5zNRaZx=lAzxlE3=& zSQQhML(A&Ut}~s?R`p=Ns#{KHKQvkgEcy5h4RHXKdtZoE`@i8~JM^*Nt-?pm^c4xyAO52ZU1CN`aXURTJ) zT5R`yGpHa6{|FbZnE1aNK9<_FIFC3?mrIHFH!_a)UatL3g;pQM#)7uxa^d$2YdS_X zSV?P&1D%DLCe1zub!B8>DUKzU*cq=W*QOHdFMsCFU=R6rFuD@Dd5Wfx{r|1p1M zy<<6EcSWmh1)^q;!Z{sP@=DxPxkuulyR`}!%+^}1LDWY8Jv<$%g>j|m`yhnC49$nL^kHquAq9zivN@X!c8U<+ZQz=-vy{!I#F8Y*xbj6y; zkq5Tyh%tK!jy-@P`)iX|uBfPF(x z9f0p}C-_jwWVUz#6CVuev?W=>NTt)6pZlC7hQ-wE8EuyqV10Z?1Lv!l)i%OsDPDOp z7VSV?X|{(eW|%I9v24e&sVZ3ZWW(!=)^0d<)Em2(|DXp$nF*;!s=A=MT@s!e9U9$Q zp>iXE7CX!r8D8Va->PobunH8}r$DM%XjmsUcoB=Ku}m_&XDwXo%vjrua4DQ^wdrve zsH1gctk|9urVER};K%uBlmuQDKk!&c>70+QIW`lSd7L>GIX7C%C_%2xx;i@AE2oZ>4j3-yTU~oCp8`C z7!L2FY#N;hncvchjp&T9ofd$N`Lqw#0*3Q6Sd4xv@Eq}06{)&@PclAsFxj`_ENayq zHEf1F{h(t7_4w!28I04FCXq5_niMfCwrfNjue+PoHlqj*(8zGGb123}e&mXyI>KI4 zh5wlzE5&MP2-OtLRm@UhZKSxyVon4AU-ouf#OPv;zF^aDu z;-Dj&&@e*ds>h)KF(acW?*wA<1Mg zp&@I>cm7nAqHwo-NnoTMSIpfse3n*nzM_nS2>+&i*RCBb-NYNv*mmQs>x1GS&>fLy zJF_iaz8ur|v(oQrKV-g^wp1|W$_xkqG|f3a!n zj<^OhAZK{m$mcv!U^MU!n1K@IeDTIXJCIy6wbDL%#x@*I5#^*BOknTbW5Wfv%YjZ- z%*F)`byf3#ux3wRe~5xj9c?-xCyRYQ@S_-|LwMcrLzy7Y8I-Ghh0E5^lz@_F>+k0f zKu%33)~Z6abw8TO;2b{sAiMrqlckx-gWYA0ZR&WvJ~!H>b;rAao5+>QY}x%=ww|Om zjwL0(5tpHfvel~GW@)VBhsoCGR~-}hPpDxr!^p_Ls=7kE_`?6hPI zgG!9|H<g9|x$S+Yf3U zvk1puPB}r;)g>6u49qnYv?Df)HaG@JnTO=eM7?79)2l{2=)X_|cA1#m!L zvSocQeGq&wGW?1c&Cac|$W6ybVsr(V`!<}muOn<8eE5y~^%G@|A7 zcZ)C$E;X<<|M2!`jK{W+!U?nOt3U=k;2M4qR@#pbnUg~@M+|=-qWUwTZ?z>Z)=4}` zvmg7+CZ+cSX#ZVAMB`FHf9tQp`X-KeIjbC*%nUs_62xMu@H^Uog`$dO6E$#2PxYgo z)G}#jvTSGRl^zKM%Y~rB0dTTKlah#5@rks8HxXr5fy`3S6E!m)$;jq=i~O3uNj{=d z-Z|a@rJpwT=C$+AZKIE zQ9_YtgPY!NoKRRYOt%uA6CyFK`?v0=ni7V>=bUMMNosdm5lKJKY|>2TlY3vN3Q{62 zE#a)|^*psBv@gRir1M02XPHr1)R;@-im#{ z8N={L)>KUbBnL`o604`!@@GvhoS7i?Su#!HEv4Q-=yNm_DOJdFWprL*O8L30beo{uHLKv}e%dz-L!ZJTxhnfAkroVR66+%f73o{TbWqWU z1h1!B6wMH{+M2z05?(F_GusL0;es4>l1o-tCna>6JyiW*p@8EvcQ)CHk+A6(swK3c zytGzq|6D6OD;-LZ+{p8~puR*3mwT$q5?F2aLf+z^YK|7LOFpATaP}vNpzjDIp203A zH)oMZSDSy+09~LoAI7Ld09qyv-aui-jZyOt{KR9}Co2@j8JDqH9O8++P~e)YKK_XC zk-CEY_?lhv{!4zugUpgjV$HEhS?j(RCaa$+_shm~I07YMqc>3NEhPfN^z^I=&KWoZ_e2HMPKjAq2pP(5kxbxvEl%VQVgEf8Aj3r~$hWKNhsZTS|L@!3 zd>RujIBMziY6-c(T#ubT0FheN$_VAl{YB`*wEUz-dHhcZT#L2vV}_;Cqr4^dZE}hU zsNn9ts89+plHh*+f?oP`S{O%mDhz?x5Q>ssIg~ux*2bz|sxG-ugaMW$_GfpMx&P#| zM)w40S^O?O);&kq0Rut;I&di~@t@N$Flp}*Rdy3#x=|CzL16m05v&ch{k8x;d;};x z>SMbmMD{@32J);DUD@J1w2N$`-TT)?~tPPy5sCOsuDH--Zi-l_ETrGJBJ_#=@21deWB-vglO(RR8Mwb2t3iGxbk=r1Hm6!8}MwA#P7I*G(AW z;jmca>=fyui!<{t9U5yByfV~679ROIFt)d4vL#p-th~@0{zH906r9gp9!)Eq3^Q$;#Cmuku28iMMn7TD#0ePN z0|qyFo-i5oZoY2@wyP`roUw9laQ#3PG5%SV8y*-}+G^#TQ|V;nj5zyfH}t&Mk`n)6 zoN0Jd{~ax=mW9k~xKlCwre^!AH&DieLqZN+S{xpgFa0k+c!pPmOIvj9l^{~R5f~|n zJj|NI(uRT3dMRZR7nrdgP9dKgJ%&`ygDEsmc72$Wy?YHNx^wBIyaCk3oSqQoTp&T$3qNHZieqzqiFHA@q7x6igE!LC9J0wTilH* zfR{7$lOdY$aXW$njmZW#mM-EK5o7Rci*af5L*p5IqrwupN9&LBJ!BKp-LBZZV>k3R zAs46}R)ME`LQIBhKkoYrXW~131UBsp@W`xM7Q^q`2HPyx$u#A^6zWkQ1U}AL7KF^Z ze)I{l=OuCK<_WwTWZo9mkoIqD2wop&K#aRK1}dzKzAowCD3&VcgYk3K4J>uAajyq% z*SdddqD}-6+9gaNzsCD8zg8exN`DYk)(Ie4@Wlg(gRU9r)P^T&1wVdI{_CcDg^5>sglc3SpchnpJ3+&RFU_sbD&F%5itgSipS9V^npUE{%_dL0GdbxTTFzRnZGRBzT zyRRA9aq!pV^Yd@ZAc+adWc(dJdi5R%#2iCLP6IS_y)}Hl+vwu?IPA9La|YeoViEP$ ztlqq8p?6Awl&z4=U%r1Xzk3i z)|BIWZMS#Q=bC&`^S+JvA`DI_K~B$98cIw9|B&dwHvUt#1IqHF0-RDuk^i!e7O;)B zEGdF`1rJRS?SY`7o-!KXO45fTu+{+!8Yy5|+)j8bgEIkoeg zVMo={ewwmt-Qx11)+1bdcIgL#!D?L z)x^{n?Z9tuVu}vrL5`+AgsoU{m@k!*(W3iVO4?=jl{oe{^1BC|(WxGFO9EMj#{YE6 ztpM&sXBO%^>ATG_VF}nQs8GXFcwJ|#Zb!--a@#{zz~RBHv1XA)=0y{Uu+E4>TV_e?L?e+io=hp;9a+)=x|1+p zj0)oP)etN~Gba;=12zq{KvRC_BBFpbXQ@L3UOodNamP~h!t?VID~_96c?h~0W7+5j zHwUZwg45~;l#EST#ESL_8e-pr>)&n0C^=_Qxa>A6SrPPy6{_vmyxJj#0HIG+I3jl8 z1oX?WMn)(8cfk4{XvoLsv*wIrVUfW;kLR@bG0g){dd?;2;MoIXZn<^)R$$%CBuxnd zx5_7UwRrxl7QHRKtVFhDOwQB6&Lhj@rw(B>{hZw;-LkoT&csrIVOhNDQO$-RpQevt zzCSIO^B<3~qh(BcAlB@1Qx6ZOO3@j@7mqqfflt4BCh^=G#)C~7kAFgXelwXOO($^n zR@^wnoN!YM=2gdkdMPy~|Hw`+`zQYG9F@IT$gpC{;By0^bQ6QH_cCK_(ET&gZc1?? zH{f13g)MEoiHs(@HY%+@pUjwMJ~@_=#Pdou3Mve7lxtoD9N~^RK1w*YMUvelPd3~_ z4kdp@r!!TlbU4yxw)cWa1IhN>tj*)o|1l}NN{-(Iz3_a7OoMmpU5izl!on8#T7t={ zjzq~@m)%?cHX%QLkgY62XTopr!fOyo;sH2Uxo(?%o&*oPg52au8aY8b!@V_RgJOA& zT^WHRL=hNfB6~!F$&GI1i@` ztBR8g6T{$l+GUQdDWXtMVmt-jK? zJ&RCdwT|9<{}}>Q^OH*lB^s~+Pe|{GU02B}I7_2gi>qJ=T~po}vbd>OtHUSgnu)zOsl|ef$D)=My!&gfZDx>r0lu zTr(MP=Ih!#V}3I9sL;x@z2@z7#6FVs;%sqUk48$w1D@?5cQYg!Qc#sw^iqf8KLu|| zu=i9qb75d@@(MHL4}k+N`pgEplGOH^-i02PfvR3FQLP3N*V_yXzDOM|r%--dcTP+t7zdDpU|K;|ZTj6>43* zNGMqbF4_<>XfmI?I1dISff`R4NKp1#xPi>@>ROrfXTYz1?tH0-RxHKA(DbrDm19G z<}zl}(T}fX`y^W7#;YX{rtCVWds$^d2sTQ@gjF6%`a`a`G~d-nzY(6*{ehj*f@#;B z+2P^ozTxV;rWbl7-9~!=3O?N5j-n&^-96{NIucP7a8vN>U`c|(toRIXIv``gC?tDU zNF&B|$R&AeWGCpv7-i12+9Sv*1esVP?bKsODoHm#sUUD1zgM*)w@57?;AJq&3+BrG zmVCD7eb$QPERuG{I^mFOh4PuXqQ<1N88T`VK7@)zBT6Zh^cI#eK4?0Q16*C`q78gk z-E};eW=yVXa}wC31#7(A$2U{t0@(x*^z|jlk1NfYA}}n%bfQKr10E{HTe*^f^tD2+b{B)q>CQB4-C;PJ>I z4(+C%3vA5M4z=kop<_fz&DT>LXkMKhv%3O8d^l><)R8$??*^DWXiWL>p;(xKj+bkW zHzR%;+|FS*Atb)yME`xCo*2XnpyNH@E}C3rGNn|SYSC#N3D$=pk|;lIC0J{{lm$7C zBee8Hj&JBLcs;E10C@m%xL`IR@vmnqLq+|(DU*>R$f3vthSdU2(#ObDCr0R$EnLu}@>b zIcQ*>gV=j|J!UdP1rwoS)~9QL+6@9DH5fjv2VQ3m3_VXC;n z%|S`y%^$K`FV#5jKx^>ebVQ!h`v_5v;+|ay+t+{;Lx-Mri=09($}@+H-7c;bo+-p$ z?-ZRsb}F`1Rp#k##7fg)6xnV(1KM8>MMGFs<_A}Ydol*S^V=WH*yUSL28KuMK`&{! zyuByc*NZ6?aEd1F_~e;W&t^wTTT!Sm_P<)^4k<#bauR< z;|IwTOs|R<+_tJ%o-#IpfGElq;*K+GD}J|*QX?n5%0v0y%7qee^1tX%N5fvvhafpi zs+`n6<&~M;mc~MwP1ueDLkK}-l3u!yLnl^pxrd?YJoW$bOn}Og1K`H#)TYd&FO-bx z{ks5~Y8sOv#wp&kHRAcYMjUjhPlB=>84-TzHB^hE@IK+)(K<$*_+}50B2{X_+4c>cmE0P`m|?Iu zE=_;{s;yX|`@G~9WEDDPdgtQ~CP28)UG0yBu2dmEk){*Fn6np>CC~3jDuID z>m+?iv2hnE22yV^l>95Ob#V)3R~vE^xRJ&@p^7diTo$^oS*--J&!+EVpB={SzTx^Q zDvOx%fZ8f^%ZdT8LpeL7uJ{PFqH`}J1NH5>At?w+{^#uxPMHgG=wLsg@!O$N;hd{! z2DL2Rs8Q-264w=u3NvNeUZiNu81^mX#};0ODDM)(mdbCTBpmZJda`7GTvs2!o1r;{ z&S921Klb)gZOt-eP6TCqr*mtz%1^kU_nro(5CB zDA&@wh^Y;?4fnG1wFBziTud>omMBxcxOw+jdE+$SYP?={TCxfm_XNH!-Mgnt=#r-{ zZ+2+pOXRN7(Vfv~dwhCye>wwt7#%oR=GIQ?xppVrcGC5=TURyqcD|oq7YzH_OirT|X{!-At8^rLfoG>{Wt{t^NmD6k z(aA}Q#sA||vNiMQ+DnA~b1SQJ@!>nx-9FukmtOneZ<#mUyt%M9)D({$GzWr#$A4J_ z?3tn-#XUxSH5AQBtY!U`h@uLu0JMv?t5spyTUm+PZKDS!h6{jHtVwDqC|&t4wLNF7 z93kAdRII-_1gM^Npf@BxZ7eI|Ko7>Z+76aV@YTq1cdwLHmtZErdC3GlNz}snct*a( zcC?Ysw$Jv2P@?9DM7p>knK~>=!>OE3{a8p>!6#-J!GoKZrh$xatj*PLh;!oB&3&r- z+Z}kxM|qoKXPX%rg!ptgM?yO{Cnrm#KvTZqSpNIIbm!Q$C2fUZ(7aC(muZFoG3)J7 zHW3;H6G#{5U{xIC+#JjL?_&>2{0eEEfU2B=$XykK5z9l$jzb%=8W&4bPfHN{xXP7J z*?38W^W`I`%I`l(9@w^vV{-@rLe?6ny`qUSK&KTvtC&fOrBZlF12+hOm=ye$Bnotg zc3DjLS>6NUDhdd3qC~C?#U39hp1A6@i6!6Il4$Bfv9m2%1=>&%<4I*Z0$dGIFc+eT zf#8JUUq3j8fUtvt4FcIW4UH_mhNwh7yx$PG!daIX|h=GT}C)61CL2otWe$oV8 zZ;JdrZy;>6W6_o6X>U&HSnc?9i_3K~4!}`^AqO|Vh#G>gt3+ehwTbmaqbOmc=vu8h zG9n=(SeLT37rC@hL5K=I=9cMw%Byf+1^MR_x@i{T`0ys_Z{*Y9&?#G&j)Af36I6k# zdp_~~7i&aiTkOLJ9E_G2Bbh-k@2EThl4zrm3*4Rv6kSSOd?N>jYtWQkVCR9mMVBCM z#L2rS{{x7C>Wdjf7CO@YxjVGANw$Rg;-?Z_EU;Vy!{iMo4Wu(z%!cNUL_NDxpXA1C z`gT37DQck+J~==BwF?>5z3uxT>Ayi_c$Z8 zT?7GKwjLptD8eTkp{Q$!OZda+8e!N8=@&z`vLxHtThG0;Ni359BAAB9p$yvwoW}Lu8;v?Kw1G7XID8ZZ0e=UPNgYiMMdc2<760 z8>brBBQ6AdQybhAq3X>@nO|Hk!SmOW*+p)(>iGX&JEq0w3?F5JNYXt7`~?NAuP}OX zaU6ikx4X7PjIpkEd7g9}P6H-^Ep?+uHGz@X#{ipWcgO_^@wCC~lr2ibiL5T-q4VljPB@f2>k&kGqau=HSwZ>e zpY%+_c8Z1thpFUqs^3q>(rj8ZsaP<3K1!FZqUtl_wgXEa8eg0}1cgqPS({iLJhSlk zEWwjG43m*Yq487sZ5QARlCZflC5p8$5z3laFT}HgIL30nyYNi=4nkLu*DlogG(xNp zaDVQz)aybNXdDv5d0Y2vsqZ>hwS9o4MpqM#t1;VQzfUIwOgF_7F=F2IhWdyk$E<4n zBs9XJxh?dlg5q+@mGHZeAeWoDv}Rq@B%YxkUo~6vDkx^yX62!j(+Kx}Rm<%R82a+0=6RYRVI;xfltT6K2P-cFb$+trz0AnwXRwTS40;y3hOQG4nj$d^%h%Mgv#`VNkG4}DP1z0qV?Lray8!*Ld)N%>CH(gI>V z&|>v6A@$#*-{lLJ&}E(79En8r%AQ8z;RfgPUCYWE2Ew7%ILBi%MDX_pck7G$98#dP zqn6T0KRP&*wpK)>rqAlq_!w-sQkOwLQDhZvqgkn1gqP*#PZO2gFwYkH+tKkIcIuC+SCLJG;Ck%s=tXZ3xbeZ>LIbks&`Xj@JK3la za!_JoK2BH-Np|oVVglK7OQCIDR+(yK>H|8Odzj}IrU8`7{z#Ao;&#Ha(Sz!(U<)?& zLc;#tZm}uGPq~{-F5ROcME#)@Oe$Mk2;G) zJ~CQd%{^_1WrzPU7rwj|Udw!mB~R62vyRNmKv?J>_*H8DScW=u05?=`G(E@#b=sT? zbRQ?qZy@Ay9a~()(KSUch>2%MSZNB}IFN@D#Vwn*iZbC0^G;t|zYqz1#5tUDZs~OY zdQjK9#)4jqA=&7Q4I~`z|7PIR%Rskrxap?{%P6n+Aj-wwiB##s7EfBuVvm@semwX+ zTg$DXI#hq&IjeHp2fv}IRE6h(AtiQvOtGKJlAGQpb6g$8f5?ksP!cY184sxD(hc$) z_AWfxa(5sHQ|*T48|{b5z@@G1CQy)YYboNr2Z@(xclt0_#9v)0EeV~pLPXk ztf4sj2-Tj3uw%f0oKxY@WclZLphb~>L78g%K$w12h4E0lrB|<-AE45uASlx~_FHB) z04L+|iOnjY1M8%`B*|lJUJD|8_oGJ6PJW@Q8AkK*39JKHp&xbHsk)j-wuBKK$JV>V z(I0&cc()-nZ7i9pZFKg?7gg`taN?atdwCNA0<=@}5HwRIDhOj?1bCgDT1#Y8`f<%Q&nLz1bnRV_#O-CI4qFHa+; zZqtd4N6a{34a5)0hsvUU`@Zs`^qF7AHpPWFh6Kf{{Ej$HlTG1 zCu|t|ED)PYXJxEw5MDzVm06QvK}oj?F=U&Q}tfY7btZi+$tdg z6Wa-K3+u*7xY&_VHqwvGM|@0Vs(uW068*IvA;ZdD@tA%H;K*zJ`7?e@1tZx2xD#~L zq~PLnzCf?a>6>`q8;A|KbW_XyO1P<_!~KT14*K9Lv}VvikNj(+xDP}4z`b}@C&fno z#+z|_*t%0^aZfcBi?zVoFIa+8#LPiCU-^C2UJh)VTDxIz{YIM`;Yn`ZxP1JV zljp9wr}7sjkRzV&0wSu1f^g2Ur^7q#?96l{OYD*NC01C`KWjIk4a5MaqF-U^LklIy{PYeZU$ETTHDb3|Hh+`=ubhQ`!EA3)ujJ1*5-x)YWhS ziEzEAW39q)grL{gr1p&KLLrMpaAet^LfegO-;R5E)herLZJ(Xs)bg(FrKNicSMH6Z z&!Bmsyx9FmV zw<)=Ct5xsZ>>P)%@HSDDvq7tpH<;KI=J_WWA%4W0?Y~t~q8>8q?F{5?^-t1rRsF*P zUFxMg)7-EPrtN61&Vx_BJN_8L_FMMq8|NkPqxsO5yvw9H%oxn>D^;qdFL~PTz|HAC}f1n8QUDGiE z=w`1Yx1gP@%OZVT7?~WTKPgw8%sDk|4ic58;oLb=`|Kce=K>vb?95BdoJ2mfIw%cN z^&LD#9B90M`z>nEorU$w2|;e{q!R{QdYeL(SSZ<=hO(6q?nd*9lvAIi#n@%pCAmL#OueaGE9c#^CXyR8k`yoKc5)@4J5!#vej@4TFSHQDl9ZI_U2b zpZX|UM<6g)fkxEW9`Qtt3Rk@D`POgk|VLi{#1@=YfWz4K^#dVSn#&!jE^7&$~dPodYXa^hkX^Nnh3 z%NeSLo7;5%U|m7%LI20>hwFdQaM+mt&$FNW|Dff7&i|n0i*ss!qbQ*6+qlcF-LLak z2{<;Zu7|E%oW-OL5eQibSqU@+1b#rsWm;3`#KCanisbV2N4(rSbjc5Bl!FP+&D=F>1-wKvIsLiQ60ewEu6RIp7X+xW>U(Wc{|4oyQeF3bm-1IyT=)LrvoQ?JvUWzA9 zNu>y0Dk_OFR>K*H{1cKn=d3 z19c1 zHyP(OwjI-o5*zd6Y`LQ1Evy)7*KUi2?rpLI(gAbz_WZh=4(0r!wKAWsC zzMLC<$Q|XWSkFBu-Pq9H60l^5ULG1~sG7kx5h-IpgPSBl_5WpQ=I?AGD6}+RW!D;0 zP`(w(winStx~ym2`MiF%5y>A@M*mB|;|y-7H_yg4%zoEfANt!%ntHP_ev{cNpz%81 zRj#rf=6l-fbbWp5c9FG-Fd@%8$j-lu^&w#q!0KNW8^)sAleUV$L`nXw`i5EPt+0CXBJA-Q zI*C+Zcz_-7{r<~j-ahg>Ud(GDha50Z223Xq_sxbH``cwlu*O5y2D`F) zRcM>HJHk-Bt^pe@W%JFJjnc4=7QZ@5gO`~#ZNDV$$wXwB?|Sdvg+XEK&fDyI$Zf70 zq{Km#%H#Qv;86g0=z0iqB`OUW z@^!`yx~UVIvdm~1~tP{Lei zYUwu}>-ld8H2P>|IiV11SdnoI@KE>{<^*WLhZHqN1~i-qK47#M?85?((u~ob<+mm* z16Q0M3r|qA&EwJ$6oabCby$*yyMIz_&_hLI7U{?()7z`Y#qa}U?3SyqDPjdg4cP6H zPpx||DSpaT(*J|f+)5aFriAnuplvIYJ!B|Qdvu=``_g{6b-I<56j{~4x_iax@<^;{ zRGi$S3lVH$fa?mkmLb>PD`+=!#Y%LuWzMD+US$z z6%pyt;BFjcf0W6c)?9}uld0p=OraPF1yHH2^z(i3Wi+DxB|wrLwGGD$et^bCG_SD4 zy|y>~gBYYVA7&)x^2gKTyElV2qt2wZxD1xQCPH=k1Hlp>J$|Y9e)Y2<-<-0`r_-{OmH&d zac=%f32BFt<_n*PnH)H&y^A&z$#|7fnd?$OcwPxV`@-iKE-Cfkaim1;I}iI9gc_c_ z0*IEM);(Fa<1qE5p-jpGk?lYNJ8!fU}EG&T{Gi%;NtM>eTx{+3>Ou3jDbJcSTSHRPP zr9%A>M1QNlmR3~#0;gwHVUFZ0D?V}9wShyU*jLKh-!(6U}VHfk9y=x6c1$F8~tn@eT0xewR=?5@}mWh z>JGb$92--;t@7srM`11mUnUkn-jKe~f9YVOdQ+sp&DCqId4@^!-j6mqeCtADb9p@b z9KUtRV1CTkz14w#U;oeJ?hE6t#&iNC-kNeuWlQ{E0s%BSe+5bmTzuQ(L=EbQH|tbc z6O)pTRLJdhP5>PUm7mZ4`LmUaCXdB6-5V43-MRvQB%Mhj#^s%O_Lw@BtHhUIf=oF&ctwWAW@R8Or--IN;@ER zQmlpdH@)}`fYTf2KNU`tB_mF#;gqRxIW`1Lw@Gb`@9Kh5F~a6lWP-|_CTV~&$L)X8 zv|1XI;l?vu0;ODV!a`N+sGt2aC6b#O+~KJI*4kBxuITyO@Kew0Lzx?bsb&ufsvy!g z|20G`d2noHxM$klgirJ+B=^Tbm~E4LP5R8EbS`CZc6+S}kM{ztf4SSC(FnJ_6=2e{q(X`6cqB(;;=vCk^b}OriCI5GY)aIq`h0lG5jL*nsB+ zUEHK4x%*P(PZbJ5h+l^h__bKnIWHM}?YP8=xAo3Cu@1}2w_Xrq8Z^djf%V7ED@zXT z)NtMjQ-YY$dVk`qI(zv(*?1xbx;%q_R=7=PSF8%@;XS3C?q{!zp<>FAp4}XFSKe}k^?&YAK=4b7NE)NQy9v2SV zU)R*ZI|M}pj|{qC?+Z_|#i?Kq!gwMD&Py0dJ_SaRBSr8Sos|p*_=@?wNBsC|qDQ-h zWydoN^y-;(AcxSkNb$5k%Z_&n1Fn99hrn}f4clmRzl;O3BcQUeMY9uja8-`R&~(0M z+|hZ8V6xkp1Q)y*DgxOmN7jmQ*xc55-+lYb{%EF91^!lwOd~vk^q}HkDf$a|wJ3Y? zA6ObE`~RMnVqxa|?^&9*bn<5V|KxisoEpj|5AHzud?amio@lYLahT@%r&=U%I; zA})CJQzdamG&?@FYW#G6(a4WyZu5T;!?yiu$b{=t0CPY5uEh^e4zBv>xYu&=M@vb}0%^dzqA>dE5i}`$T+r7UScLX7) zYKC&ls^YD<_D&WNQF`=APH&fiOC?nV=w(Z?Z{90)c1ix_y)t|oU5v$h&UI_-+Wlt{ z?flEJAHnMkp{8fMSQHUerDbcdu2nhVrAbyk^YF|uzsMjC#H>NVx6@A&)@8f7lM7b) z^vWaR{OlDia24PQi+<~nXKtv*V*2P| zieAKw+$O7qrU=Y{^qQQ-&j+m z6MBQFudh@|QOm>usiUvtxY?I*nC>$-g+vEy{l``SO5-6hDtm6q$`|K@+jkWz^#%_b zd~-e6u4B%vz8KSH*KyOAU*a}z)BodrCf3J5Bsgl^YK&Ak1hul?2?f3Q!nA*>f zjp-n5Ju(t4Wq;|D9F?2)fgESHJ!Rl<>=WmD;_*mwdb)+xU)#1qlt(2^oO4Es4 z3Z59e8H+Bm*&(+743388vB5+?fPEl2H=aBHQ+OuhWKf_ns)UmhW>YX7wLn!G3P6QV zox=`VM-<9Th`1Bl5cBGq>lyeB5(}Uxh3sE`7o&`ZOBLAy`uL-=;O%QkxOU53{BxpG z*WI>Q=q@dVFpfACESc>Wu|VOo9M}Gr>&F(OBUhC?+iCAQ3@WK684ohP6HEK~i*(gB z+O#$fPvM_16pe9W9fWoe@LmEAp!ow@J$z1Ji}YF&tUKt98BlXA1nb6F3ztDwR3BM~ zUyJVQs90#&>+bxp$=QcLF6oCo0)U9$(6UO0Y2fR*o3G`qno2Rf*7>|d2~*>H<+sC; z8?&*Un_l7kPaY@YcOrYRlFQ2WTWH-(m6}xZB}f)PU{3Y%X)<_;v2Kl^%{k4ffhMu1 zFU1D7iRpo)Z@hCia^fZFmphqL-#$izdWQgJJMJ3b^u7}+SxFS}$p&WZlFb47iyT#r z8}43h46=xoOc8h6&`kkaV*_XQpF<0+G|UFyZdmpvh9`|NizJ`P*dUyeyh`mE^t44+ zFfum!c*G_SAaB_?aMZ`WI{_ux-A`Jz{AB8?lR`lH ztrH6h(jkuWTziuVhEO}-`nroe{o(A^hu~wQTx(@fbw;SiA3OZq)V_1u4F5q)u-fDo zHSn?T%Mn;r=(0;zNfk{^X@eG@IiQ#zBb+RY0n|r=h+2gU)EN{Y2djrM3q)`^KyxcC^ledA`w`okwM2R{sG$5(<{AfqojYlz}O9V(W z#~U@8LX{9aSlU5yom=6T;}gL1Oq<0Ba+((#Ku7@U?4R6WGhiCl5=?07<(`mO7Qkvv zuZ>+>GBk$>m3iI8SbQpmxi+yFcYTt^I-gdAH{b_V&|hO9x}nv02n+(G;DW5U7VY2M zjTcJ-b&yXBL2B@toAJ-dfoZoU{U%xn*v)&Hhiif{da3Wmppa3*M%t2gJ0QDvMqu+G zWnu_^MF+dVdjg>+hz^9e!;wS2O(i!7ge~kt+k!pxgg}2S*_}oK6ka7b67-Nfhad*z z53OYDziEv@V^qD+eE<}$rcx4gvWjjQz|1&+zJ0932CDc8ni;bG?B?$Y#~Gi0-Hg;Q zbN3Rav$YKccL@H&5X6DJB{9c6sF&~#$+XEP_v?4oh~Nk7RWudXB8rBUC^{m$v~Q%T zB6Y-lG*r~jP$4x%oj=a?5SXauJ`ZipV+R}Ed!xF$PDdOLxuk$y;RxYEm?a@yL&L;t zN1zmmY8hs}xNPJdopF>7vG&6#R8&<5-bMkQ^Uj#&^3K(+FmcgCRuoCy06N==0~j4e z9kxcqlPxTq#CBlRBzvwt1Ey18BomY^qR|Xg0ZIns>b#ovZ6_Q_A18aQ!e{_pE;w9J zMCN0G!e2P*4aNAa1j98B?=*_AEs@-%RGUziPo0u!fENRQ9iES;fM0;cKI1&9##gHE zRs7V#ZsBO1BZPYGHj|Hr4VoN&fYV9ZKuIIeC<_9J%EfKy7u2=X1CrrvmKGq&!Sa>y`Smq(a zD9=8)wc)Rz#0A9wVAWYQ-0-`-e%G6Rh33)Fq?8^}1d2W6m706%k3*?js-zAe`H85{ z(bR$J7y`;mO@}wm{o$Ylp$U*mq%b3WDh`NllvFvMPYuxQh8sw43hpI-9e_RJEnqJP zE0~9L!SJEWZ{zN=ia80&IE2rTV?tCQhbwlQ{%(APTJhdC+EkG9XelsG_W*fRQ;l*Y zepNWQPz)hId*DGP55awfJptCjj1Vwfof3fw`Ao(sIj7Bjw$?VB&@W&AD8}8Am@ndy zk82bJ+I1Ykqu^A}%`aEMO{tCu%;v6VQgPvJi@E|HnY14w1f$!hD2^X4M#WR6ty$Gw zHxGUBERj9E%qO>x!&5O*$gepj(Mm{5Q_Y}fvp|{OOGCedH&E@m+%f#k7+L5RRR?oU za$8c;5I#*pYj-Y5Bp?9aUv9!hbY<8}laFz3kV}dR9eoV0-nh?!d)v;U{PQI4FuU_k z7SnArCfqDziygd1@!Yl!Z!27$*iM%-%B!*d2wjIYK)cS^EpcT1LK;Rd8-$9#25-I= zZxYqT@xw6JOHPf8HCX&)1gBxIifMl_Fh+-TuQLM7;&z5FL}q0Kc`A?dz7hLsc(YVpQDEZ{!fk0I)QN`^t5Ya9z0)oWbJP8r{qIO9}5 zy%TkSd>T|5d%W zgetnKq@4xbi)2|c0^1+D^-;p&BiM{c9Mn?aEQNT;y-6R2M#f0v@4&c0-=DNVaL@3j z*EyMl^JrGNCFCIC-7Zt2x?&%a1Sy9A*)W})`=-4=Gbde8tqB+)=7Mw_=fF{GazNIF z4NrXn^-swh`B8Z>=y1Fl-gmopd9EBo+9G1nw^@&Xi(~e{+gM-kRF!d` z2DljjYDhy`zoVX@-9y-x0T6E!!M{vj--Li!u4kmAZa$jr{eAPZqgA66D$8fAArS5*!Ym&~X_2ss#V;=7kv|l@dqtB918j ztFPTyPyzq9&kM_N{SC$@SHAqzO?`fDPr}@ZdkTv(vKQg8e{m<8C()Ol5wyxEB=AX!t~K)_K^7QCNaqJwLKlj%&PfmE zMNkktnd64vE);V@(}6g-!$C<`g6+@^lY7GMu@xwttZq{AUJ`ga9C}xUp}xc{F3m0_ z<%4yn2xx3Q=}WrPZ~q+msJ@OVxy(6)RB$b04#w1_!0Ev`hId4nz~x$BuCX+hxlF~PaRET=))YAkaB&1_S) zq*nhh^m*Xr)dL7+*Ze!c>=90Td%E&BKZjq%^20DD9><8AOSiR20M`^rGkE53`P|>< zB}JytUhA1J&SlpR2;gHux2O0&1^i+=4)oWJZ}BE+?@Di&>yA9Iqcdhw7>PYs^mS{T zu8u#4G@JU}b09LzzK3`6yht@RL&4H#*U7?3q(`^TqtGa5)3M-uMB%%MKkww4>O$*4 zO-A-Vmy!BlROKN+%9Om#2)RdzT>kX;hGB*ra3v^r-xBL*RSEs*12uMx8d#7Js(e`$ zWPi~sSEM(qdFF>ALix#=blV5q*>rZf%$(*89;}WYN2U8zemLQq>*%1J3uGi?W&|6Wc?E{$P55?&fGI5#Np~Cx&V7n#IQ`=*+lbkj*NR5ufzik5 zY~VVBRk7CRS>3nw-=A;Hr#yE`Y3aBmCb`iF6O&e;%EsnYcJ4!RvIFqU=_C?#X#D=o zCcjy-s^8YgECTG#1YiQL;q$}XS)(*Z$`KFnj(hw7-ENgPTouiQb<>@U18_e^i)eg5 zWLke%KF8UnhI13XO3T#wnr(W6Bm&O|)6-XBPqvc4jF0|F?X`#Kgk*-?sjaXl>fzj3N5&)}4ue zmX>!_Rnr3+3bYb!3IIVA0j(jv2`o{I*AJ?Wn-cx{&SK6|c@vwr;Mf8nZ8Iw~>*}T} zr|)PigQ812DPoH`D}fk0Qy%!i(v`+6=u~y<=Rl64>DonIURhPNtF0zYH(GZ1$*2G^V5r9raaD7kP(3Qm+ua z+c!x}zET>U6-6SGy)(5a4A8h&3d|BgwIcka>|Cb6iJdJnIwW8Y>;xH3Yv(>g4~p69 zX##RXl7Qlr14MSR@#u0?p3sRy0Z7Szhm;&KE%hw9XmpfSPG@ElPLeqnCht)A$V`So z6b9~4+QYP0zkr#XYjLaufR;+}aS~-xx2PqlP?B<(uT!F|HOU~7ZB(fcFu*F!oCR^0 zu3l3N02Fdl;w-crkg>jEt<1pa1#eNsO6mVg-A2~ZX@!s)aGliv7)WPTnZQWX^;aU( zFyvlp=#?r)-r%r>vQM31zzZm_O{0U1Oe(X#U#lpnK@r#URLWqp0U#`}9LyyG%Y zSD!wu>E`Pu-PHd(-F>xhuG1c!y>Hfj2gK`8^i}xP_;ouwBHDrRQg5a%?M9Y$7wMby z6QC*3-pd0uhv-v_X*{o^iFq}*>*jOhGW0U9tIqD$uVbX^7HzfH<9oyRaR$a;-n>)< z|11nhZ9EBePB7X2?~5~2y<)ks5otUH9)zI#Bdi5&* zE-o#6oUiZe&-X|$3xm|ZNT4j-$kOrObDh`igYScruc70Wt#jV@si|WpKj-VPw%;$u z_wV-yCrB!SNL6X?mxx!R~C!`XR{o7_|U8x+6>^`@@2{G zy4)x2yGFVOub`CcrbC;hG86nMevy#PtDZv&oc&oOT#*a4F5(B->Pvw1SH4a;AOvJn zjS0EwFlD;gUS=YjW!x@{fNq^4_wQLIsSL&4kV*HxDl!DmjR$J-{Gmc7CbOsEpb!73 zVT$3hq0ErQ5C>%zvFKyVTtM<|GRGN8CO(ouzt={-O}Fps=Jw2%zOLVyBCmY9Gr{pI zC|mad7-pY%)u;afm?VG@uvBD5&*DK9{Jav9367HdG)xuxoQcM{%N`{uJ~IjGvNcac zCZw}4id=7l8FmKcBJsO9!xEW_@?aH>Y@>(qg4KYv{_b9HDRMNJ-__?N$b`2UuTD=x zx8lj&_3$)BQsdyB$pLn^4(U74i2)}b>W#UxutWUedOz9BkBvb#S=*j+MX^g2B7$MD z3nRLIv0np4AEGPU;6gAW1Oy$?QYi6u>~Gar7;%Sr=AY!x2Dn3nG8P#uw**&c=#P_F z-4qnw(n>@z0yiW2NWi-hIj|y`*~}Rh{m&QC7c_Y|0sv*x;Mj%m*s4VyZrKV*->K{2 zy(*2KTRklBP!XulxQHb+dAKKsb0Y^K0UOj-NHqf09HdG-kaAcEuZpuRq0U~-50(-s?rRt}QFuWrNlWZX7l{qhW+tynLM^3H;?*t;6IZQ+mo~Oo|4?OtPrT~T7GMU z54>ar5D5YY6H|T0;e;u2BBzOY7))k4Tmov>Lnds24+>SueeW_E>;sZ99FJvU*NKOC za~zqyRMfRs1Mc;RC58D?f_n+!t%R!-z1db(J*?H`Xb~i@HxCadNgTT zw*5n{M zi}>GAhKWac`3SL*=Z<+;Ddqo+qm7pKv9A0zUWUDaXA!@oHP zMis&H+247NlQ*!y8nR03gMnAQ2`q>TFrArT|0bG^)0Pi0Y<_ zog>f%>^*R7lUGPX^m}30%Jtq**S{=edH&QM5@=;;LA{L360#vRxVCG7x4?#M2&n!9 z8G%}TDT-Hq?%5qW-0!>G8eSPQJ8^9Dq1{~Ea7xgQ4eGW?8p0OFhX-USVBEI}FYb+2 zjk#oBW@D{9UvVX>*DPpg%NUgp;x~9bV8q*THSW^Za)0^#JFL-P_;Pc)3F<9`M z3@0qJ-&P& z@c&rd&)w*|KWZ=TxFJgF)i${3+jA{WI^a2%z+!Pou;8!ufAldYKhphg#KiocwqRKp zSXuvDM3nlki+1b(cF|tVY*E3=2HC$SBpr>b#kDH&4Racpw{tg}jYCe{TUCD@K0X8Q z8B>gKB3g7~ecyl;ca?XY-Hh22efNI9&A8uAby3wgCGYzBbW>03B8nTPpt$41yZ=Is z7TeysOX7gS`WycZ(^<$y*fS(G&49dmbiW1g*z+*H1v^GyMNs=x!eqEK$PnBK2#ilJS0my6l0Fu_*s z!6Mvfb5mjPP$ciI{LRh3eXf#>`V*=miS*@X+F8u1Lyvw!xDf>K5IxO<{Zdv!l12*ZvaSoF^GjbBHZi;{(PeaqPI8 z;BaNiKH_E3`SSctH>X5M1iOup7|@>&(YRSO-oPoaEI5h+&Sq{XO@)DuXB-5v(tF*q zxwvhSDkUpxHG&j7Am+~F`ZC`v&*kW%ZTu76Pc|~vZ?A}kShm|ke~^jGh`KQ}k+n-~l>iq?%%l90cyJ{UG)LWCq7+;P}Q$tPa-kmvjr?k?Ls>~9p zdqfu**{AdDRSn^Q1bT_XJ?V}*SHdEdGW#+KrNSY>u$idU6m3ng?@vr3AB*=1Z#>-I z55%8j#W!YLOFYmAp3T=6l0td#;8wyzQzSCaeFZ-h%nLV13|lC#oX^X^d2H+(B?*O8 zHEFlmmss`}Rzo!tKm7szp^;c-&%!#1=3N^fINvL^3#!AUmZd)niY+?;TLe%EByIuyzfcD)g6n_v$icKL3B=b z@IjO2K;}%nL2R^K$ElUk#T-B_D%#GW-5YnznCEOYGeHxOI=ytjI_;ZbR1)5YlAnP% zHlMk`P@3LjS*t-7sV$%iWao0ki<5N|l}8uBOrC8fI1Pq)<1eh9bl#;s;YXM2+F&KY z5*V(ml)}hK)s&&;$f!N2kA~f<2?Y^P2fMtu*=d8EZVm5*!b0xLs>H-T4-^K7yiH|h zwir5DL;nfleAffL*P}Z~;ITM*;PEdzjDYF`3^M(<--%c9hDZT!m|X1OLgwQx zLFtf0oe^VRpN+R)r!;Vaw&+s&J7^3(CDxB4|uGxYwSYMm_YFA^smM#p42WPa0K&vb&sD~-^@uKE+ zzN9d?C&QVBd+@c|vNuJGjxz@LN@5&tz|vL4s0*GMT*@yg9yCeEZFAnM%m%3>aR{bS zd@@xV2Ln%9YniI25~h`O;81TUdJj`yCK^*7{PeEowL$Fy>O~d|g_{PZq;}6c3N;8XUi1KOVI>MhSf|y2D zc|(3xy>FN7mnaN2@W4JU*BpgN3!q?28MR8w9w}K{<&x6ggcTZE5)w#4`|`J39CeU$ zDhP5S)ah)3gI^!aJEBlsd}iD|b2bsIjM^juny?HhdK4ue&WsFi*Es zHB75j0&Vpe9vA{FYz2W04#1jW%^Q(B(Q!6tkEPPg>P09_Ccnn4HzbwP*0yrygpdN!mdKP7m#3*wh z8a2dcaZRzLJJSwv4AI#Y++nY!joXk|m{url@HH9=Z9M^9G)%XzsA%Wch37I(JWscV z3*MPDdCMwv46L@bj@t*jJQf|O zLma1iL26DgYuZtsAD~sT=r9n3gg;}H&`w&~iLJpb%50cL6{RHMOelRs>+KEl5xPC-3iZNagw^0|?Zp1AEgg5YauH5K z-QMmMX@bwd2WXn~l1#IklQ9h6bCNWP^ zP>jbDvY=}DQ`6oufx*4Dz}IismjpGsS~eSj8!3mZ@_=>%BM2Xb+{cfwZZR8N2G%{r z@kJ_ZF7@!VyVNS8`gbvqK0W$Pwl}jZ%0Z#}k2Mvmvh&rGHNRz?3~&2=58H~9JY5kP z=)R=(8;6nO2gr)wP_i>xv`{_^3UPTqN=h4vZgXDpPV7`yXX1sqip(+TpKy_pQEzpX z2;xGQRQkqng)_BSJC?T4y}CZY^aiA7Lq$GZj_Cfha< zUAyF948p=Wg66vywVq0pJ{i1GMZaVm$$n083@zvEQX{xzN=0ZvdxYc%iKGmmVVhdwL<2Osl3ZTr_A>&>zPFId@xTgywrs`U((vp8 zsHyxPL|Hr=n@<&GystiMu*m3`)(V0FI57;5Tu)x~<1Ta+uY5;TD$?!}*^o#xIOEg2 zK%DjWYm<(|Qlui=k3i_$pVNTbow0K&=YG=zCAwhN5vvcKqKaeP6>c#|rBu=AE27PM zClHhMGO*Kdh@kiVB!G`$N(CjN?XYAaA5!cIq8TxY_3B1e6}6_4X+MxXNHxB^mr(A8 zbWstetbjMyHd5S|J8Y|PwGgWp zRT7qoo$gjNA}3TO!kgt^JONh+laZ9qwOLhpDC=VlJ24^VnX}Z6P)(=*&LMedBMLzh zY(Zei$x0PVYgc6KV#54Ci#^F`s1fe%AGco$0tnRk;!&lQ_k-S>ehIbR;tH1?4qlxYIrjfhuu@ylwgu5+GjJZO7K*gcuuMwXw&YL&#=-@$R`NGMPEj&N=bzcGPe z|4qs*={$*lXSM?osqb%QLp&bccYic)No`t3kdc`~bpItsc-iQYJ()+QGcC=rkDZqj~bG1k{xBe^wdwm5jPghCSW*nC1uePmZ4&DAZS>~chug#u1#9VLiOoXLb62K${x zT55uIxA>-|ecvf7GC1>@R?Nd3=9SX2&iAN<;=-tHDuNk!0L0(0W52;*YRg|y>2Jfy zVx?fa-dkU@P2Fkz+s9k5*(Wis6;ANT76!Q*))IDjkI~U}8#oxDHk0TKyOf~&K1pLj zRV#VRdAno^j+&uM`g|fmxJ?1kO+#W#si%f$v{Ni`#C4Tq>K|>AlY6M54O0OX>5ll>j*{`k$F_jQZk>-kC8HL=YDnUo#A zEt}Wgk-k&Xd+KHA^{BA(b>Px9!#0g1zEAHOSG5L``Pdv8*j&e^z3a%nISic}9?Z5S z{=9rz5MG5b+Is+La~c0pjiBYc?5nzC*P3|BImzJ3p|Yje#xbREFK^MRJoZ~Io4}>& zn!@|{nY!!f-A#A5LeTxsb^z~2dbmH3cx&(NiR1JsoyoS|%12vONS@(Qiq+a%oY!#A zhuraEKP?kO_d3{)=hK`QhYPVC*K>|o3q$>-e!Eu>C&7c&+&`h>A5db>(6*VxEzYun zM&4^&+{95?-w#N(dzB%Y?bpA*RZJD4rzS<_wQC*!1N2%e#sQHZ^y&M1&rLznvE->GI6XrXr(pg;zrUf^^zd`+fD^KnKQ$ zD7TpfXqVyvzhd1Acpu(3r3ba*1PJe`C&|uXRm&+c?d##Ik^Rgbz%RSMsY8%L0F#pL3{W*!j1-Dp!Xi$2# z0VKEhV41+=@(Fcv)&b^3cGMfh=g}pkAogQjWETMLQN{q1TV~y*1>czglGl1XNa%y} z`68UM8=w-Rh(uu0uVT1YhB=2akmQHJoeu}4iWE{^3j=9(wFO)q@ZgfdKgSl1pFw@M zO>^hj=-qKwe9V|bkeXZ~$N17yVevg!(g=hYrF8=PR3pDub2ezIqW{eWbRr>pkGE*h z8rd(uwLE3WJdMo(88yCQHnbcYyynJD6?}mO8tKes5yrn>UIm@Ruc>UuQ=0kiR0^7y z_Nwb#cwW(i6Bt<&Cy3J_=usHoWE?IzT#+^m0uosj0CR4YVT@uDs>XyRY2rO1w;mhs+T#0H>>maFfRli2vnG5& z-Kt&)LZfcvI)sF_`LjvB_D#Er2k9*6z-l8ARmFzehPQtrY8KP%2)r-~hDl1W?#zt~ z!WDC^xKaV_rnwz}#Lkr2LRpw&C0udA9qSoxo&j^S3Gc^(ObA_T!U1BtN3|5q2z_s& zO|0}P8RCo`%DIjHgZjf%egjsUtTFJr{49Udg7fJICAQn9yiXi&=PYNKn? zHc#P0GRP1UiVf8dW^%%u5!Q-;Wef5{vkPdP7ekDjTPbWX0E6WSXT(gu5>2-j+gAmx z7-Nu+v?g8yf0vyL<3c#;b846zDmV5gxzz~O7g1J?L#UX{40PNEYPz2_fr^KYsobC$ znCKeMoTqAMoWV^#&3o_Mx!fqx{<=33d9O}IhQl`FSp#gdqX?tMO0fCpIIXb4h{Ti@ zo@mjD$M-1N^+N#XEF6&*x`1-oL0gb#06&(ByQAO*7LON#Hpi*yVArn1c#+EIDPZlA zo10F$4-?s>p;nY+thMTT^jmPY$xDa9I|Adp#f4x{wDM6=2XX6;*|DzARJg>_WOPhY za;M&lK$!8Jl7ZD2cgsb4up3yPl5U;BJqb~pI!5YIjSDD}aaQxSvfoz(&+^{fw@sP}Hl~G)*RS7G; z3lF=~O(Qsq!M%y2h50vNFi#7v6gqh}#JfQ^`BHqjk;!ZKz|<`BOvTGkE|EcbktMey zv|V8pNBjk1PPW7*hNf{2^j6gxSA6eBpxvqYhs7tI3M~p;oGc_Uu-ne1(_5)~?ft#r z4`X8ND@MKyGK2P@MOpA#>NRuLKhq$)BQ;8J>}ZV;h7yWh$N_vv#V)CKO9CjidEVE9 zIw0xfu$!|d(;k4PIWQb71TndTNNN579W1_H4J*Rz2A77L(5;v(NA8Rr6jfGH5Mr!^ zW%hOZmSDk+X)??g7HxxIsla;#u$r4rkhN{ z^OI+Qp<=)%+SlO8Zz~@dLr&7nx+f4;v_7XAn7phD!VBc>?czgnkd`BMey2kcestTY zoJG3S8rn82{QXH-crzw@N^+tw< zmj&G-f3l3Yd*5o=;CWg*f_^T2&Nt_x%mc9`PGNV2X9W5{(Q=}ZJSIb~b zOKVrXx05b}{+NnGqc`Bv7)5x#5=O+)Pj?B5IVMTKn8-LtGXRZD*jaY=V+i+`QMGtX zCl1xFvAqmt&Y|STdJ8v3vRT^fp9$AR57e3$!tqEoZ4D63nk-INWW8RJ%@iebIxyKg zVV)##I5Sc(Y9*IIn=Rme{t#)+Y_nvE1Wg~Lk{sEkfVNJl*8Frw3QBoTvm21u{$Lz` zk+^@;{N}&a5}Ij1hg92<008&1%B<2txhtJjl~$ZU9TYeZ{WHHIoLvK=`xV#w!>%(B zqk*h;0i={>10oudr`_x(Z-%K&Vl}52k>v?4turJpdhJWanOLj)(5ec_N#;mP zl5(vWxe2PHOnxLjB4bB^DT8bh43>zp|0PZT_necPmgFxo4eB6Ovj<}5q<7<#(};;_ zf1Iyq@i6e(>Oij+g&Wl!U8fg`LIIZ-pGWnROx6CKFL*$ z+yfXy1zNzz{J&C=)0#1xWO@8OaimMgX)Ut#TJSs|X|I&bKd^n7dmdUfP1$1D1KHWC6@+auxvMcV3uL^<*ObHJ<>VWN z6D#_X85J68D~SMM0O@xp&opWY9)H`4*2wO1@~v2<9GKF(oL^S%7ky6VL+ zfv<>1aV?{)HAs7n2SR2x@e>V`uPyv(@vUL@jJT7$cI_jn4EA zN@Y7toXCSkV%S>q=OpyX8FdyP!0{VYkmIdJi%s%y3-n6%IJ8&CyH{`Ny892_V;R{U z`IN@__1!o0pH=r+dwvo)yeS3AOU{m9Rf2pCw#c_#u9?F5gavO8t}R}Ept^jEGN|B; zp8D^`&LOv8Uts8%#@x5gx4D0Q2mLtE@OK{l+pg~W`>uCOK1^kSZaVJkm?+;oQ&>s> z&!&Ga&jpiECAh|=2zHd)xUX7=YE1bqI5!eJ+oHMkX;6X&1!Q@pJ}UT@J^3vt?>+ ziuK-}BL}NN4)~w?70&-*Mf_fKL5@*11Y4@#yuUjtOsnyY&QC1w)K}nxwH$6k#`QtQ zo_Rw_dfav$&c`&WfE*UNy);fs4DCpV^U?qhbV5)C+kJ_HBU}QW0@Qn@6tx<>mXlRp z=!|CvwEMihw`2#3Lh?O_zuQKzZVt#Os$c8R94LeA@=}Y+OslV+?B1%NQl`b&b5b>PI6&L8n!d%wMH#TleFJ;qziO?;>zmG2>_eSS@B5sfo3b$sM zJiA_pM9ckod>*+m$z9w26QAPv-x)!sf1_3ZEuZSq)UNxt0qVE=Z-0LLObe0nqBXk6 zBIsYCq-Ed>famy$V4A0mo9V=gsk~eQ{%(gN`ldNDNOmtyBG1tNv;*Dl{K83lB%8l4 z>cnexxVnDt6uYQK3D-6ckKF?cP0YFp6;v_DCJzqVE;xMopV{CB|DJ8kR1mwhn*$`GZPQAqA2aT*9i@lU z#g?&Jo_zAO@IORYs46!~hb4)*G&*2|3yR@se`vmbm|uY7!<0GqMoK1x@J|Aa=Vn$| zlf>r1~2A0GM_RPKrpHg*lZ*)B55Xr~@eOm5flZ`(G5kb3_ z@D8+HvndW3)(8%A0NQiuTY0z62-Ge-9%L>LFW^;%J{dSFt(cBQkDE(|qVp)f-mIkz zK}cgwqwhe~E^)~8uZq^YZ}Pxx+`zaMaf2R?HUL^D_KmTttz8|kK)L!IbDHtbu}E4xco+*6J1-IGKZE2)qVX#SPYaFCYCo@-=d1E;c%cD|oZ4VWm4JPc9~ZCg1P zWrf)352;pZTssaEy5Ek%l0(4hajrz?PX^dlnnWT)nJu#5AiiDUo_0fZWJN#K}Gc^XXJ-F$CfTE1l@_r741ezM-2WmV(D zT`$^^U8oyPBYvyqKTZ_)ki9OLvyw`PUyCr=@xDLU&}s?Uu!k*tJYx+6VJPC%iI5Pa zan6&D)GEw@f+ow~g)gJOPgy#Da+z*Vdl0O?kS4fkMLA@u8{4*wf+R1q&P*Vxq|&7KMxxnzcbU1r0lBYCO_)1OnNL5 zSi#BQxIQD^Aj31DWom$a>o(6$TpiKRjzTiAkEYN@_CbhujZ)RmURu4KcvZhiy6B-# zoly40sCa_`sX*O}p32tNC!OdabH?JprRhM3W>Of!lLP)`iTvgZ@CAk_yUtS8GifF3*}Q2&;?$n zK%u`1uEFs70_M#r?4n?qS4)^qPl2Qw8_{`^$eN($Pq_ ziwECA&6`1*_GbJO()0vbrh0*qe;Yjx&ntWovs?i6Vb&k>{FaoYS&HYqE zFmZ!|{|{sD(3lC=b=}5xQsEWbwr#Uw+qP}nwr$(CZB;7HS8wNZ&fR!=`zNfm*PLS{ zUYx1RXmlm>rff`CyR#+Z#QUQ}OZsS{%6)9o{p1`76LJ0M+iiVfa_wSbv*42L%3kAI zBZWu??y@NN#1UQmjWWs039VRI-^&uxK72fgJyDU8r-x;loTqq_3=X4~B9U{$^6u>* zE3X#Qoz74qg?64H~9W@H2?M&JmlW&&j zIuqyBwbj&pPA5eMOLSjOU=XmFe19jgEcVrfnV=*Vyt8@}6~Od}A(Jm~S~U@kJYU~$ zV(0fzMt{4bkj);LK2@tLcu zr6)i3yY<@gs4heeK<99`<}ECAa)|KDeU%Wq$$o~j>o+56p9`=kwG2-xdJ2yyjZdcI z8T4-8viVaR1?zPld%*Jx08QT`<~Gm#6{4t(Xrn(vtvdC%j(^9CDdvG`c0mtmgr_%B z7`b{aO)g+$)*MQpm6ZheMHCKTHBNrQ4aL?Cd*~H!809B_fJ>Jq6(D*Li5-_i=WLeY z!WBfH`jqCN@h+|p^xANW?@vrxG7S&Bu7K>8c>w=O6MyDO5B_%Im+bEX+VEZ-(kBRE<{}TiMHLD=Y zYla^2+1^mmiABb!8P=0tE|ws>7k;37{z=;=-$$FfJf<0#8AnS6%E=@5l*4UY=CEM!OAtxTNAwn8Gzh*g$i#X>ujA zjWt5zkU{GUyGHsW(EFB_b{5iSl)UcKkPI<{_o&}DD-cLKH3mI@Q&pvZL$?Xyqx`CP z^n}6ppRy)dkJhlaF|fDaE3WoNt4qL}sd|HC_^W(-A2u)Hj&H+!$3o8L=-Q3yl3xr|8nmNk!#~rz2Z%^0$HOACCHT?IW zGP<~T>t^5U$(ng<=*yiMvhf13Dgow|Y>Bt!wsB?`63sQH7ij;sW)#c4E>_QMI}tSARr$`+VP`9@c& z`WB2)vD98T0;fomXHdny{qJ-lf+NB{_woM9rA4_gP4|fQ#Qje9cpo3v`_~RyH`z0{ zw8IPK+btCja+q3$nshD%Qtww%OuMi0F z^9E`v;VI7VF5A?XHmlY_QM^Ql=KjPMg}{{&f-!W`Q$uuGC+LhWy_A`3b+opdHCBA15WM!-#5Dy)e4DG_s?WCX&KV3O=$6*Hz{RoN z3yD_qM8Qc5mA6$~BK!tKw;tZ8FV;+qMr32QG15cH`%N0KrOltbwl(A>XsDTb2bGBF zSC`qcBs8k1g4K;=NNmBz5x2spUUaJCvVxfBf-W4SiSVjLcDSWKEBwS|Q>Hhs-p1s;3*V+vviEC;! zq10qgj~$DP;>pM>BqpcnbZ>-5ByeflOFFGvg%=il$MV2lAre%v7l()jMu7DzW}Tm3 z^3F4*CL|eTe`^Wu$NadG;X&QbKJ@w!6d0xfAr7#qQL_GP=?}zpZ3Ud63MI!skeN|4 zwC-{P(lAc|9?%0)GzMVw14TY^2HluhVEbqmFR~J8O!*)2Rw5Mmbr!#j8t=p{NZ?VL z6310omBw^#9&uo`0`t{#FNDI?8ujm^uxh=G^Qj{V;L@{yugZQn$k$emaEl*NoC7>mj@C>JlgpF zu&F5VajXzF`^NbmK=dZW;y;li+;TnkXH{_Vh0+RsgT|$_M|K&wsMj^);R>p(KfOS? z!e&*%R3^FrO5^@O`EgTxPC&%Cl_{BkhE!xjeJG76k^zAao)hznHFlx~usy?2q_y^? zFi};3zyc#=Q%^c7Xgx`v#+8>Qp+P0H@A(oqiGc+fG93RBr5Tq z$yKGR8@`6vG*I4f+Z-43IQK@59&E@W*9j+d2HG6Lh@$hLRH%IxLg&#pg8xLeMJwI; zoAAf1lk#_ z813C!jIcS>modmQGVtUMCNLM>Q*7wxnt+0j5sHt$js-d@7;}xvqob9=Ez1>{O1N9p zDET}2uIhW3JQx^SU$V|t=H>U9kIoIKV=&8Kji0=o41nrwM3eu6t<}<@VA@XZUMKCx zuUD<`uenX@n8fE()(t2Bf#571mo!eg)!$h=9n0UHAcWjUN^x=Em)$p)OeCHRea_at z>SpuEGWw%RSICZ@)~+uc@)c;-a=V_{;%w!M898e0%o-yB633|(=|E${A+8S%6br(n zp1rdV3@bUsgWR|c4m^fQPxsIihM3;|u*-J}v>@I)K4J4nNg|n2s=H~xwfV#0>yWYJGF{&B#S+v8M1Ato@Ea+b` zH|rdH(jS`bw{}r6Ml88bkuJ(xUmgY|wDgKczwUCakBA#{Zt$+Px@xLyn_B3LTCg;6 zDhhwEj0DJe>lL(jZ==NH)YM&IKn*#4G!R2SI!$jMbjOAr1Uv?%Ff@N3-K?dGsMYon z(2|TDwS$Y*BhH!Lqi{EY+&@fn8=qf7$7QXz zKY82ajYolSBa(t=kImCH6bdh8A*QD>#R!n9*+_Wh;Udh|rFZN+4)fB2zYP}4^$YLM z>m~r9i#QsAm(4Lv5_37=!x1$>xRz1DToaH@kG}?v2e<>S44jDuwS@GPs~K3J=ZEkb ztZULP1+ZN`(|r;jhiN$R(t6@VP^6kuu($OoJo$l`ja%|8{eV`k$BSQl)gFQR0UC?n z(h4fYXYRX)953%hb2>(A1i|$sHPvDv$=ApEwr!XFT|`Lkhu6tt!1TZ|h+y;c9SCQM zwG!GA@cE(Kxf)u^|L`t@Bs_#v_}qS1j}SLVyvZ_Wdvwv6Zmix~Me;%dQBX5sh3LNZ zGY}J4Eyl5Eo@I;pym?t}>De-Eo*n(TXneDxLM2$?!DB%;;>~oo$+`K97b{Ka;crHQ zl-SJ(vqPwnG55gTw@)qxs^B$lIt^MM2eNHeIF7{IHqKm5r{|)eg~r1V}MELSpQj$piR1xOG})Vg^jLyZc3!gg11fvBw~<)ZU%9m4IbU%t6U% zHn>6L`Op`7YpX2BI?%)r?qNn>Rir|dD{}eA^LYHu8p)Glo1iL22ujU2!j5L?B&Dmo zFii&#;Ngd9KSbW|OwMq$&pI3XYMjI}W)Ois%PnnyKx;}qH53@c7E{P`{H(90`Ep0u z%|8`bMsT4DTAIRQI|w8y_FTF}yvgb*6o^N&h+hIM+U_{CsDP=itkBJrk}oC3O+Na? z?Y0hJM@BL4;uI29Z}cM(`65Syxfj6&V9=sA`>)K>BWiB^b5>OU=<9U_eTATzC?~5_ z_T%W-fUFe(yYUx2Kc#W6nK*&9$s1~#v2^i3ySPHS@(y8Z&mvE97HyjD2PE35Jbg*r z*R(lX$zTG@tcGF7tJ(I028`%?W=GDraZyX{T0$XQ&Z{v!pIU)hpCOg+TD0k{DQy+!wt3iB4t;#R`}R?S~lQ$IjL` zjW(_P!t5&SBvDgolIj!?YX0San4~GNVr`6}!qonh;bhJOyO0YASCv-X7@tsR*|EtL zTI4RBhRDier>vTNttT+CXwGU0$RK(=IhOZCPVO_Um#$Zjq@1@t*90A*i=M&YZ2C@D^Ata;pQ`)D9Zs{#ju4g5 zG4z8gk7Wt!Kwmw;TI#*`MC;_3U6m~Wi{E}@^h3ta(b+y6u$6ba8{q%V^5ELAz(7v! zw@7?V5}`2mN84?2g(m%L#(qH)5P;ma1qOjiJOG#G`w>(hPxeF>mhEDbM~Ny0Uqex% zLh@$?z#|a5sBa1SYN5FWHVPDA3@j_(8lVr<=c|>l??7V6Fd>9^(47;g&9K!H9~)qE zbc=~#;kEnXq1Gv0*}Yi&SDiA|40244fBbv2 zm%B!LiWMt4)BToOxG;smy|N`|yu%T5dxqE6OSqxE9!gpV4qOQ0X;-gZ-Wm=yhWmyp zPM3*4J@tJ7gBL6(dy2vQvEvh=OH2ZO;iz=+g(qWI3NmRki^1upWPIj}%EO9IZx}g$ z{!N&sqMAO-{ZbIPHc^2pKX&!6+O!1%?o=s&&}7ZU6xtT8g4c5wAjLG>&8Bg zPS>{lyx(m8ePnfMkAwuRSiING`RKLaB#9e6wNKbQ8#b}hMOhYph4SMnJesQ?KG!Et z$Sm(X4BJk0#KNYWcI0`$!u1J@)oJ{b3Kx&YQE&0eb1jc`QhNEmk*->J#Gl+wMPx)$ z9`&%iTXL`y*E%${tWv-`ZdukuvYcFytIZ^;)=Wf6^fSjB97uQ*E26(gy_d_SS16^$^J~40Fx#v3@n38-<@l zOZksUwU13VV7o-_6wVtn)PP!yZL$hgQHO)9$)|N(!3?+l8{*oU1&ji-shN@-`0Y8h zz^`i%r#fQ^%aW1FfaFBIo&ovIFdtBS#TMb30$MNJ?I(4+jnX<&+Ze@F-nk{S36|S5 zj+h7g2*Cq`$2S3^Jj5avE;5~cbo`MPGr19lGfi(^a9||)CHo>TVBc-ObDXA5#Pg(>2wO%>*X^!4sow&_ecwWAUg?LZGTwXu$>iOTiNS45ybNt$ z{n@~SW%P>13+8|O)vJTinF*8g;i^r+QLako%;C?Olz zRjzS+nDu!Azd&a+0ffwA1gc=zNSTY_5OxsPrcKFAc~fWXj zb4dcD1dR?zw?7HYiK7o`9~MD6o`B_Q0|~cTuocHvHq~6Ar2522UKyB)`>lU-pF1vL+6OK zIbT^1c#sQGxzVg9ruXC9%GUnHAF5d}-5hm*czvy<*I`TtX*SlHUL8mg?e8C7Jz^Dd z_aO~*r&iBT*!Qa8$gYWr9fCxR^;n(b$$e=1N)(t)yfzK(acWexb8KSFBhvE>C03aT zvA}Gy1aG(xa2~;{aSu8WGqP(l1d#l>LS`A$Wpx`R`1oJGl?D_aogQ%Q0Eu|BwPxzM zpuh7_$&s*4^vL;J;PdVwd=!5-Mk0>{DZmQw-$GWzN7-Da7J>5+p~yp?K2nk7=Dt?K z9-%U3qL6w+yA}N4!nHST{v8KK?$AICzB#R3ar=gB$tkDLOz;7$ujSr8`guMWR$&EB zUDF!XB~+4&YV@z7vso*V6#Ca)p5+W}{pxCfs}wv*R=jt`Y;j6(k}it-^Au&!GNt0V z$RCGnZ6Xurdia};Jbzd2QO0EEms*;~*y~W9vYc60Jcfypo8v^k1O)QL{*|pzQt-$5W zpHEeMz5n9>X~L%H`rfh}(R*vyd3>syOBVRy4*pSro1Bn zmI9Rd0d!etKm+V^{bqukVEhl!(VH6$+WdsY+FVNMbHlFUPLXPR53PrQfZaIzT)2-C zZ`wI6yO1RG{`|t@xFRbBj=l(7QFwy-nm@>a(yqd%_NCL2#CV=YN->nCvRb$gn+r!0 zeOkhsKe&mf-gX8oV>=vBFkU}cPz2os9H;#fY`_!~b^Csc87bh;mCYzmu`C4!g|H8| zTQ5KQcIWOHKcW!gN&}94|Hjn?maPj1zNQJn0ON1ZWWjx0fVh7JED}QfNV)E2omzsB zopFTC@{ixWOuK4n{g0sV^sB}t9Jau-8ftb!f82OAq}pihLse@ILbQ|U=)BeV8p9^3 zPV#2LKb~bQpMMGy1^w^>L*r{Pp>7Wo77`4*d-1sU_zFr`Q&TCT%Ae*1`^Hpdzbt?> zC2P+x=gdBo#NP{p;4=gbt4vBw(B*IC_7m8WX!Oyo_M|L0R6D=>Vvl!cBO0;ik*PGJ zv~&Str*O#DBPj<81tVi{_PwrB;<`Fjg{-Ix%}N>#&^=ZHeUtRVZZ#XPehcHni#g0H zb$SI=nIUMmP9|r3y2nVKbPv#Y_sRFpeumZolg2)`isWR+zR4V4Q{sYSpEA(*@q5AY z@%{XZDt_Y7y##k^{vurB6!f-a;pJC`HHcH&hR{B|G#+Ri)qC}DNf)6+~LhmdYVbcSGvlvYD99At?gGnbC)%xLn z(g6=HRyT5XaaObY05*;DUJm6z2;&bQBC&FrHBIvYG`C(8!E=dcyj1Z5I{|h@#CIQK zsS*`XVIx8G=MKT7{5Ki}*B9e7$AMtckvlw8UQ|6u1gtETd@{AHGXe>@P2VTqn@eq5PVJi#AWdQEh(|8;GvqfbzP2A1HidqRAZC?)?eJ z9zd#&J;`Eekua7$R|ZW}zh&y9IDuY6Ji;JTYHUQ@`to+0Yzk!{alw0r{F~HxRI(8+_B3kQ8oZA&3PS%^Pw54T?|pkVJmK=qDQe)GHL^IPn(b1^>Tmx%F2~8O7L^teD9P(^;K~NI3r3ZcXa8p-*+7!P+ zJ`=fahQXxfYQ7b%ZH}C*Yyn6H(xHRThpg3{I>f6gJuKU|9j)`9NVK=2A#Z4yS?=Ru z-@_e_G1BqKEpJd;` zLsaOGynY!-^R_22{%KKy6kp!G3&T6l{zR52cqs%^^QxInlO?BqCgjSLV3nlYD`B3P zqU|l?xjB$5-hZ-w?i~o-$own)J10vy91gKGbDsb9l9 zMK9w)9k#xUPmHyt zt%jFdAKqd&aS6i zeaa!Qr0r%lz+7l*B)$m)^fcB>OHI#>wi>?YBePrA}ob1JlLrcl`%x z_|U6uU2^LH`^}ruimFrhR@O3vkBjxT{mta}ZQBQa-zVGFi9zl;Sb|7b&!kY&N%Rpp zVkEVy0um9sip>zJYTO(JX6L0lP1j@pl6;vGQ0}cWI*r;?)RA}}$-PzaVJF<(%WCPs zSHwcq{`T&T3pPNi?;K9s`ID*nlcz=E@*?%RWN78LLUNBaM~oUb8R28B{MUDZO_eph{)~1r4 zN$cDu6zu5Y;F|vKL_5S%G#%Jy1)oP1%7GF}PtW7&UQ`_Vt4EB}QE1);dPVKH`bh3x zzVBHU7;93nEQ84GA>0m|Mr4ORij5oVb-wne=Si+-%?3UF5}vRS;_ z9+rAA8K=sh4+AuOph?FcivvF7rOw*_qDWHuI8R1YAKU?~1%^tcpiTd0$FT!lCdZ)A4XKOX|lZN5gTP zIh>c9ba!w6WsNr)@d!jAV-tvvhea+Kz+pzrqivN@-pzQ4RmlRaY{OG)I)$K$O=b#4 zS*t@nsTQRnA%bsiwoi)Zj~B6Hyuaq$sIqM3M6nP@QJ2nezVlmbhJ)xvHPxRDPA#Y| zMl4q@f3wXSR3^Fl6Y?^aC{6Gz98HWApKdK6qRTYMG&4-Bgm}VISb}yAw6XV%CaxIdAhM!vFo8(xNI)fL zj^*Qjk|wm|HqdBfUgF<;rOK3XHQktvR)UqU8LeM`%Hr;JL|?Y7NA& zCQX=zk6Q`+knS@mVgqqCeWo#fUDGj~C?N3eKuZDApG?9*mAZ7KQ4)ulwS#^So#RvE#^R);H0bjcN0a=oMq*kJqS6~(O;f+oteA^1) z;3c#fqDk}lUe28=;7Zeqs0tBC-_}?GDT@@&i8U4d29CbiWFaLRs`ct!36cq6llx4> zSD1@dw?Ykqt+SGA{(W+=H96MvuH0Ev4Q<47{3GwRONRg=uP^*;XQz5?x|Kie(W!LW zhE_!qH%ejRaxcclZJTN81?K~RG=paMO{fPU#y@tLzU|8{+7AzGSKIYUh#t{*N+S2^ zIv6Qr$VxVZBMWzbBsDVil@=7l&XLV^4-!JjG>4(3n|rW|8&lNfU7;WYz2f{{>B< zEE+fH&I%bPbpYZ?k^`zSV^H!ds1Yz_9(?^lZE{G495lEQzyk{ZMnWKKR}a;XH7#OZ zznaXF4u`#GIn5RqA0GhTR6W{_kIY`(?+Y7+Is$Ku612n!VT3f!ytw_bl+!H1bZ@5f z7VyF%>Yd*65`ElYHOCVej9t9m|F8hWP#&1p850pwjO15{cDnx88&$rhn^ z>G&#C-cULSkZk+Ekd+H!cFZg3O8qbA4jG^ki}n06j5ZxFL6sPnb5=aS9tGs z=FCsR^f$Bjs8JnpJx?2qR6JvE3Qxmn^ZG;g;bcJB4_ zyBe~aQ5!yqU_Xv-Ffd_1yBToYhFtFg1}M{*%L?ue-Ocf$`*fACP)G1TUI{% z>ItxY(RkR|CfS+!c4Mp{pu4B@x)8ap@cb1E!srn|;3{RpXTwEI!SwhIp|?_Q?&#VW z_ckRAY*3797R~J6DItqW-YpC0z&OyVd?9}VY=ot9c6R;rAhKb4Gyo?9sC=r&($*O+ zJQuiQIjX>7?HX3PKm=#hq=-P^T#qEx`H!ykn9|I z@N*bMTThdg#O~=b!i5}FGB41}{AhWCMszvUp_K%^Md{0OCRZ@cP5;q2`nb zt(4<|x}Q4AoGrq2=A9f=(ap|_`H@7}1sV{2_K+`a{6lwVR-5G?2&!&@NpUEogh-}l zEpV}DXlPBSy2yN#apfdQ4HZeaM98A1JnMepd8X@S zamx660>PMNs?rAOnML{V@pA^v;;JlM(DXfYxZ(x_aZvIth_J zepy;sxkLTMW<#Nf@BhLeESxxIf~yk>Qrg?iVc~kb@OcNi9@VrV5<&G>z7tA62j{w} z_g_g9F&7P95=Utff;0yU%oMSZhY&OR?>d97>MhR&{TEZm^VI7t9*F)*zN-R)U?~{1 zl&F^S+f4{nLYh|Qb{IyZ4e4g-Bkea#`Q()06H^5>zVv*tVKfl!hbFY9(F>9hIlOZ5 zaO_V(`gY5aXrj7=HSmcwDShUqqcoKfrazF9Qtc~)sF1Y)6u?av33*MQ2duV=GwkyR z1Qn3Gzyt#W$kOt?tQ6FoasHATscDcl=E)sKFicLp%;tp-W8a;f(@8TNFqyp4TD{iUDZ6XOo~!Bx@>kt}o@ zc^jec6YT<>23;x$xPKE-ILnz-q7=T`k*EKj@e^8Hi1j@CR^wuOts}t^^Sqepk0}Mh zpp*k|g0j{Q%V2_Y)iFLJiwGpCOsQ+-TOG2JTv9Y(zoz8WsKOU-K<$cl8UyolSzyDzx*%1DPIiD4ESZBfubLCF~5WUH>A|yw{j2+}-`W?Q}UO zRnQ<98XwrXa;cKdqz}p49?qtZPi>(#)*G3>w+1)Bly|8K80k3eQ=(>$PJ8t}Qgnr(5n|w4?27MB*9!71CQXvQL>!m&J zX-QQ!P9YmXMo=>mUG4IZrv3=}_)niFa07XqpQH$d*+lDn`E`0#|4+{%stG!>+C&*a zp^0w&F9i6qT2U7$5d_x!6vs4TZJ0tzHbR;4*c7AKfPV40r5q*j;@*@cGkF#Gm#;|@ z*6VXH_;m9T2rTX~ELQJ5)P(;GpG>OpMqk0V7b&as#soOSK0C2dKHwLO$B!|0SKWFq zcaA94cw$F}#T<*EliSId)$gNOpFbfLK?~b?)WjAjk9z6CHuw&cV4*TbWYdj_f5ZCnDscFvNWt`4-C3%?VLXB3;j6) zB{N@;$2_zsG|PljLJqbu@2t1}P{>E;!Zrn{V_HJ_-+HDx_)U5Nz=Oz%{s`0F%Gm;A zGCb5WC}A@QbyJ6dD}or9X07geCQPV+9F8B0Z^$%pI;ckw6dyb!xqqI3Xc`WaU@|g_ zPDj?^+`HJ@Z0r*$e@4`aPp$!DiiP~Ji$AkWwKYM#dU zUS%~~D6-o0RS5cA3XXUT__&s!v+3wM1`{QuSRs%{)u&N;(f9JDo)k`LgEQPzCh*_A zO`QL`YoknT)epMCLGDX@G@u#3)Ji>ujtNShz$M(W1;ydNm%>4z;255iJ&tIySCh^K zeEv77q+}+h#LmFP6|leGz@+$ctVlu?nJAl|s30d~&H76I8>$gxIJ!Ghui#z3K1pGK z5Z^jS-4PH_r_>Z44-F=eK0+7@kw`F2E8sUE0{t5kx}83U0VqfKDcfQ?j}1P&cB#UG z=A>D~>!aIgkqu~2EOboK8oPQJZ6T_AE+Hf<_LO7>*M7)7fheGn{3wO=v~(S4cI_pQ z615)go+Z%u9FPi((@($}R7Y~7~LX6?d zBb4sw>wh#0!n=13FYo!4nI~1zqH;6dg%#y)vJ|&he}VY<>av{)(N`yF|8pZvGBF(; zFizTKv^aRi8!!=LbVIO3KC#{1mwm2J_*Z|kyAx*G19hIXt5r|UNT^DJJc`J;lYEsx zI3chQ#!|KeGli@m>*+LA9L@nl#{HZ-b=rg*AYUKI*We`o2h%@r_cR?S*l4LXytE0f z&;#oIgB9H1xOYn~ds3t~vdP-llRqtwQjvUuM6pZ(3s7rg#(7FL$%%zt`pYhLrUCe# z6ALJ}>giF9N@8ymf011nr_n`~#YPaaS5vz*BT(g0+omFqk`8#V(OgYC(2hLg?rZzG zBq_`)WO)T8xa zvG$f8M3eHD++)PSsRk+8=g5G_&J*vBav+)K&JaBIAsn_;hyF8J%BW@#F(o2wA0&Cr z_cGw;5{?0PVO^^u47_0RK_SYZxWDkL09-56k=>ll zv#U!HMp@^0G&o|k__HjgPlCGzV`5lpAkx|`<&!n?7?StYrHAj{ssR_onT@l6g*#|B zvkI)rbs2HJGEx#Ym<5NigjP6uNWHDVP~24_d}5#O0gyX)rR$GOYOj%Edq#b|yH4r| z0VVGRQKrHk_*vrBESY}QaKqpS>XKR%bWSmq#I!n#tSS#k@eSCI5j@t?v`$0C0wKt_ z#(G?1eB#bk@m}yGL5%YV@DA;M1O=LLrakl?G~Y!~ko;-4zdQ-oYqFMs`MDaV=Nh_Q z`B|yxG;E{wWKyH)23|35>HZk_EQ((TIkS{07Sr6__)P>B5n`vPD!8zYmvdtRhI z&vz7d3B&6k3&Xv@L06)MfXe>`Yv1lBYs9nmVft)+VV4FS1bh8aDGZ zw)QV(C3-DdImo^P9(_f{LKjt|a;2X3ZpWHovzV5}t>sv6bc81msA%%Cn^D1)%Dj~z!DQ|IY3nNLoJe3zE z^@6uqBzqzgX-wL`zdqD=D1XdfKJt#Q$Zeb3DqN7ctt1~BL*py}T}V`z=jGqBa9;2T z!|$I$Hm}2P+$a%*3 zP$ilng0D(wgHO@IcjC~#G^p-BYRgUHZXx$6k{B*GXvQ4bC~#$l4xBpMEcczB00wDp zh$Na|G-DnEUHxy1gZF8~t4(1XA@;4$;;Sd=iz z^I-Qr8p2PxnOYSG4L}vq`=>OOA_?ABLJ-93V6Hs1joT?{kyDi6ErZpP$TF=k_y*i4 z<}@kOgLqZu4Sb+k^wrf2Xk2@3HY(Iw(vM~`P&&ROX;!%k3x$GyhC0h_nSi9Gh!kC% zYUWsF@47277Wt=4!Eb9!Q;KIUudVb*p8`+LHH4icl_7dm4f&UVmHM%9x5jsHShP*3 zT(147nam_gwN0MW>e1XHTgU?O9{Hd%5BlY4Jbzp;0Ke%+K?QKt-~+Bl{SEUfYE{lo zAe)dv$DiDO;SOD&&OT?d(}it^KF8qV%mnf)F#?%-kqV}fJPXh5b14mxGZwu1X!v8U zB}s8skLyF>>?`HcHD7LvUBKnr)A#sbt}-aNCyn#$8RWX zH+SRdUcQ-TzdYn^u`D+{#oa3xd}}!*+7rP2jnl)%JF~9j;#L?oMK{S_@9eFEgExaTmNRqv%32i6puZPU!<4ne@_^aWV4<- zeeDos5dl%H9jT<^$;=r)zQ7>Kq*@uJJJ*sV;3y_dbdT-{Q54aM-VL?recMF>Tkq9dUyBD`;B|D{QwVbWlrR49ZiQld#@K($UfSL2s3i&~K|-EuAN+Ox7; z*LBIMEgw4T2+EBPeCbBh-`<*u;DBE;Uf*%;Kv6_qzNZ9j(W*_Psc*}Qh+>G4=C821 zJd04uWat1`;GzFMFsoj_sG7VleS9co;;=q6IdjbkdmAatDm$T?4T?M|OfV2dM>heE zMKGZ(o0@0{8${FQM%m2TVh)ny1YpsLkQv__zw_p3EBa57z$`K4g{uAI?*%mg_o1Fw z|#LqDjSr1sh3r+0D6#TGrf}$)Z{2BXkC zGfEX<1(6ygOxd+yR0EGwHlf%*yHbjrdxyth9n%aE#nNM(xrP8@b3X@6gMZ@s@k|0X z5?MD?Yjs*)X+gId@d<0eztIGpsK1Q2Ly{0$G=XMi4DjYRaZBf`Gh6re?;aH zX@h;0m;Qv(jj*#+Z?IPKyKRSjczQW1q8a2Ce_NMv9z{4Z;0cduL~-U?`YeM%MAkt^ zt2=i!+vq-_eVrVKZq6dI+<1hs^Gks$AE4+n2K|+FOI>L;Mp8VD53SR;@v6l=^#6s5 zypW1QI0`xTpa>R=Dx?@H$)vrJffGzghE)Vfx7y50sp!5xH^l;*T(M#_)7hruMKbY| zO&j$%T6h)XGeXQLumii09V&!=loeo}c-$XjU8m|2W>qGfUy$1)H06sI7#G zML-AaID&L*_FCo$n2E0V2*~J>#ep9suvp@ZkO{+pL^n_(zn1AA*xU|KKQm&sbAv5O zQ3R|ukM{4-Tv}+8Q&S2N!r0oKYT+2>to>c*Y!Mv1;s5>{4IIC<_#I0YqIujUHgbv5 z*CWnzz3>T7Ow$Z4LMP9t88duk_Jd9+j}{t$Eyq^-cNmp9PQiI1l1E0At;bjxsv1S+ zo&7en`sNnm)4J{1MdV)@6ht4nL$8Kbnw`Xio%R4&Nu@`Fy*K za>iUKS5b$FqM=1&uwG77I~^scm#}oawz3*X`YY$|8Cv!RDH}K6N0S zNL{rx2{ zeT&~e?lSIAJ>B=Gq*XF{xV;s&WBo2072PD4L|OL&>!|3s zp<}TZu}j9EEcdRlGvvRyPNDMe5?%(vW>wiiB#b zc43K2_X0+2kc&oj;)nwmV_xj#GbjTpCD4_p9Xeok6h1*0X1@3 zekgUVC#nlUwnM``w3)k^W0~IQ7#&aW^&TU?5}qKdNG;*XfT-wB{xHWC-7u}UA=&e{ zOXZUktE7IzLE}%c02JiDfYCIm0JX7^Or>RdLyAcUC(v3;MTG<@7>iEK<~b^BSu-7K zxRRKBx(9LMhOvT!b{zin**333fJ&!&6k({?J*}>Oe4-1?3zDi zU>)$wK%b8p+cl}DB<7ricq{%(ydu)BA}*&u_R={4oaU`bP399F2HPu&SOh^IPtN|i zs%R9kE>6Aa(ODvyIWK|*8NIvaUzt8CZ~Jiq7LUZJo$OslZNF&rDp-Z%T_HI|ME_CP z^_THTpx!u^Q)>`nv~c|$+hW?>1wErGifzZ8et0%|hCiA7E@k&dbFo_lTEiS} zHwHpygC-PL-h7=6V`LvU1c`67;xiT}nx1Ox5c5)rMyNwDfhF>!NRgXuUN?? zf%-%3)yuImabN9vD#>Ua4Z!AAtawND?;VXI7DxOD)hml9h*Q={-C-SUE*6eV(^r%U zoqCl81*ZRQ2N1jV1qy_RNOlk&jmH<&t81%k++%QA@2;o%0;;fj&&vvX^%!1YuJ}n$ zp(n-|Tg}#&nSMvFuJyoA&KcLA0fZ2JKlu4kxqCinE_H*`-1lf*o^;vf=OW9mE1~n; zgfZ29B8bY+IHmn!1*uRiMY-VJ8oe)!>ML`u|CkEd{wsIF#`r&rUq&=168`~Rd#S>*+fwjHnGYH~g&?;eSpvuy;X%-VDtEr$Jvvl?2?(iASuhHzsI8_ZPfULG z%orTm^!lA#{LT7Mx9go^>&PM(Z0zvcHjc;=Um*L#y9T>7Z`LM2oAddT}k$v?-p#4#c zJL=gTy+RNyls@az!i^Dxk{9>K7pHhuv64LVjVXHYy?&>lB2mh3ffniiF?LQ{f-PO6 zEZeqi+qP}nwq0HBvTfV8ZQHg^|JP?&~?*E65Gvox}aS;@+fz>Z=Xg1xoLDkx-T{?3BM!W2+aUG$ykx$_aJsK`}vU z$fKr2QQ1h-PFv~rOElDj)p25^CUiiXk(%G)3yu5piT^`ZRB&Edu(U(EvOOLPzEjh> zWwDL)Jndf2z6iiTA_$>o#)di0v_dZPBTGud*GB z0dB`p-{~agd1dzQbX=7vdGIyG<(|U(BJ^3ZhWvb9rO#E#64nx57m;u0_(RUCPegMx z^j8vFkex)9` zaV`9fkom&2fS2qyIWqcUshtWHw?J2-WbK z#}aUaG?#M&$?z#OpbBD^;bF9yeve;eFeH3R|$`ONUtscL}kpJPus<`yNQ2z z@Kkm5>KyWVE&~hXs&+@3k`7d!TYu<;(w=<=CxS*yG;bn@zWO-}4bK+Sq}3~jMYR!=BK5KAGgJ}wqVJgHpNoArZ7+ zSmqd=AC1M*W7`~FOZ$Od{s2W3t?si81l7AntHHKQ`CLiu>0YTXnAPc*_D>Ypf)c-y zdZ4eV7{uesch%{Lk|9)7QuD`~5R5~7_iwb@p5fYeKAi)Jphvs%^}$L>J2EX(w1$Ug zTTuN;@T?HX2QEYSW4{y&JYhx!PSM!s@N4~IPH!3hQPHutQ(#ri6;1V1_L)Yt&q5 zh_n&XZhHN#%-1DquoA@XMMg+r)z}T7@-75knTub{UvE}+tY}=&3=Fa~(YHxa4Z>nl>PZ;3L=BmTN1(*qri5lyUQ2}dO4O(o(mPW%?qZ`uTT86xGm@x9bBxad zu~R{5w#2&HeiP_tr!j8;<0Qmn!K+$-H+}Rb3kxMqu?j1P|7}* z$GPWk59E%>TH=rWYCvHAQbwbtKi4}liwu7kREBc$BxPB|DOhgfRY0S!jxBO8Doz#f zxq9mYl*Bo!+?+0$dwS$ls;Dzc2{_+Xk(`!+`J@OQQr4u2qQDt)b@DwGh4+Fv-Pk-r z#IHdD`xf@Y{?rHejm*?hs;!}vy(*G0L9<#2DUH_v(E1LG322me2Wpo(D`$^A5ul7C z`-F!kbMlwDSim{PcMq`Li~nq?e;yR}rUkg35mV(7WKo(;jy3ng!j()-P83)g=cVX= zYKa(lGrP* zk|fOSVJOgp-7iO-u*CXeW`AcgwcZ1z5|xI#2%kg{Gml;ho;AWk7}lS0B&vMKbEZ}n zu}1K+PatK6;a#E*PHhuJz(#9uS`+aUlIWx073L;uvtwp2KzV`(|w1wwXVP%j`S31b~^5rCQf#SC84QD2tJ2xXRwA)-}%!yVtLH^ zikc;Y4t<}Wj|APFg_cB}CY>OzKacYT*^4NdP$9$S`39B?`Ym<`Npfo7ax_s7>G&S% z%xMp`&D2zi1^lw|y-9u?zx1l2Wv3f>;8V~;U0Ff9@-1Y;OMKR#ehv3ytv#4N{33|5 zn^R*(xTm)Md9hP_i@2wVr{ZHvX@#3U20EcVNwTja;G=DqXSG|q2Cl1lJL)pxQ{_;nD!>oLpP zedrz~<`-^Ft=||36cA9fRANH9or_u9t4Hf3ejUN-pN&}nrpATBIgzFa*jW$3&wS*u z$q5F@n~YacO6^ONA{~3eV3i>~tw@WVXhg)d9$hR#g^iSZ&EUG@h4H1`RW?nvbishy z8S#nX)Mo&J0NixqZ%qJav1gk)ZPMqvrpF-K6;e%14c9Qzu}ypy;+Mz7(nNLOw@Sa{v0maj%^Ox<&;p_`@gj0e1KUN|FC|M zBnL>FX39N#GCV)Ka>C+FyMjHsC0|5~Ql+jA_0wh9J%&us#a^jiG(vwbwW5DC8m44G z4|wZF!8xorYFaA36-lf4chVne33+|NmvN8b_S8T-9nLEXEv>ZDcqU1eVkhGrye<;^h-)Ja@;T_v z^ZpNdER9U+f6be0|3Bxz$jSOYZ?H^jNXKn*!1TPTAGN?SIDY%dDAFYMyR|}3*#_Wk z;Gt+sHXW{&o4RNC_ZCU4%VhvCHwx5~cT+?ajm7=#T6a5{{_#0A!GBghg(m?0E}Ebjac~7DDa&OuI8Qr`SgBV z#ST(ro>-+VZAXu3jjZ%Sc}LmDL)IHXM5LlUwf%`c{!b3=*Vvlz{{Ib}CUNA{mKYq~ zfx*PEL;DJjt;x-6i--(N8AhF%pKj!3zy{iX3$y}r2-J_=P78?{A+qSM&g&8p3179dm-#$dNg0NBRkAY?KiRt>@iE2z$=>K^*v&7s2Bwo)IGs$wtUCq}rdAO-Z=rEbHmvmQtj>dQeTYv; z$-gTFr>iPIaP+RH31lX1L?@kasd|R{3-{Att5IcVXI3Wgjo^ziAmV3fp%?|CYN;lL`X=6wupzYFnA-ffm!9nSX7`X9{c!JttCZTTbKMwN>H-%@M`_LU3@E7 zuVgK5d8@liM_jk1!D-|p)FhmuYNFSs7oV2E@ME-*Rut_;3PR!`%>EH)YtIH4r!#o; z&5Q&ZFUdvOuS+~DKJQZ+E=$@S(i=2?e*32;rv7mW1ov+*@WvEgv0p3E7w#%lSVh|r z1QDxmc`x}%HPd0j^GAnz5ui9oZd`9%NRgCSwisB z=@GyOq|BA+vln3}uEK}j9eFHiTM7u?b|=LSjbbdEalYWOw=lOjF_g_mbUS^BD%=E! z2wyJS>9=N*HlF+Elv^o~;=T$IQB|Os2qx8k=WGV22u-64?6tF)!9aA}kP+U8f{Yen z9gGdZ?8myH;BygJNCAxu=lJ_gUO4a(*SJW|#0Y0aWG8vIaRNa4kf)RzY**2E46<)s z`@96VsOHyo@;;w6H%JpLIRQ;V&scTs3}lbtOT65->p5T)SojaK{Xp0iC}ht8#5~|L zIzrm#5{~}J5SEp{as8nmXxm2#^_7uK*>{i|l!Wi#b`T;KYBfGU-DZ&Gs%SR&$@?+>(9@abB763J7x+ByDDlZxy>OZpA$c%-g$~M7^zhOr(^_9X z=-tH2vjrSkvpPC!FxDL$voY?&w0g6yboQ`E0%{m>PV2rOCHcPp4BenNe|~slC)YA#Q2LPeaLf&E)ZtWtQw-CY4ft-3)baWV<sLm z4aJpIO8BQrdVe5ngWGD1IluA1k$RTHaxI!(?Jf$n!zC^mf!5J6FfjutRqx$^z^^PO zj+fr`M&>@MlfnMEqZ6Urrs>`i6MRN3=A5?$Rn+IbICvNfC8?~ zONc27|13L8jY^lrIB+xL$ufci?_jPU=$+*uuy3nRrRUroj41`fxcLAhI2|^4x&1J3 zN)Rt|gLe!$+{Uv=61XCOV5B5p&?rmny3RKv>D!$JWQpOyFxLkJQ>i$@S<96doRsw%xYaAXd1B*@>YRY+Bz)EXS_rCs6EiKx$m{Xn4yUU&x^D zUcAp;XQ1#6r^lE*>_~zi`GF(+vLm0L`UE+Y{3k|OKe}2>mOMZbf7Fmo*gQF5^Ax#k0;_o+F`Oy)o z_QP#H@5Pprad&n)d){r6@HlUYj1bxv3f3KnIX24+{NpitFyl2poTul}nye4??=OhA zKV`q%;=y+3{pxY3r`N>E&-SJB>-MG7>(CB4-kE7ls=2|_)^wf-i#W*7cq~8O&KER- z^Jl?-ocru7|Nptq#QDGTjn$arPMcycH?@0NKx*lm9z&LHD%Nzz5AoNHEx~4ghOxXT;xPX zna1-i!@icat(_Eea`TX>5>K9=hQGDbGtiO~*{9_y)+rAbvY>x~^5$`6!Yd<=hefwh z;zUiQ#LA`=_ee;CIRm9??3ZBcE-AsbUxeN)q3uh~egLOJdx(E+Y&13A z*(d(g?dm;tmIvs}T<+?L^(H0VM3G%eF9y63d_B&Rv~i=qPqRS^G}M51YR*m5N$8eV zaL;9}P-=k#V&W(fcH;J~!oNLbC5^{FjaJ9vJX(N`amb5mGVRH)LeDEAXt}@uOUGAV zr0AaFkx+*Mbb#@}12B7BnDY!V0kVPLtN{OH$LDzcnLf^nVwe5#tYo!d0Or@57uN2B z%L4<<3Gjj#5CjQOO@TPDoA!=t!Jdx}O9fXxrnOI^1rYJej?gFG1N(C*S}zwu3Hf7Ghn1F^%sE`1+a?{rdb$w7!o4>dh zeQHuNe0fXGSB6XbAcAJt$C1y!JpCR~S|I#d;m!FFVg9TOzxv6gTK$*a%Zs~w42Z`K+>?qLZKyTij=Z22ZSDx(t5 zl-}846}`n)SX=Lkf6-8ta7?ZQceCCLqZeRZ!~yoY@A*vThHhR&1?S5Lg7Th#QWm(4 z%%1~?@F0oaQ>nC@={*ihtgHX{$jk4vh^cq|e!qBiJ-9L4nQaI~*fxQXV0^ zeqOdBe*c@P+>vZ+TEUPDQKw~!Alz&?n5O?(gN6zP&Kck|d?VccB5zwGC zLx*ymy^St;&E}EK^(_iFpYa^gBVrBh%XKGR)BO^51?3vv8<`#Ub`G5R9#wA z2fo&b^(S&=j~%UWS(%oiCqzFIN3yY8s!f2%9sD{!1{Z+~OwRgTK3VuNb1><}W)!^W za5QvZ)Uqnn#k!!8+0PZR1;&>=-2-NYLA)OMXxz-J0TUtutd0=pNSK5U>ihk}Lh$rN zB67>*F(gWjtt=)GL7b_tJS$n1G+h)kr9YyGXY|wIva&V@)hCni)+r_nQjohMg=PveOX z;?_^(V}GQ^>usy#+0vIBsqg*Wl>Ohu@|Q4l$p{Pnv1Xn6F9j(-_^)`mT+GoXTmL5N z3s@o4k9m>K{V2EQs341)?eAiRoUprs(vNS;=^Q#0r1{^$tOTee7q6@Vy^v%CP$_U| z+$+i+5J<`OCJbL7n{X`ZyN0s5eSxzM-EE2UrC%Wc*<`mvLw~fw_mFo|5`-P(6Jdvn z4$cEsK>~KAEBif6jKsotsf*@2xF6h@jBnFnft&>{90aPGhPOG!tjI61K3UlA6U0ne zT!jQKCsR+|6*6-jlmOhhXTlb+$ukCcN&>KO6dmv-OT8$R&pnSr-VWV_F;zbntPpy7 z1#FdwQipO{Dj0=OL7pwl{yja2pV4f18kk!Jb^CVTs3O6rfl$NrYfIP*U~Nk#vW0K0 zCHW@`bWlFNJpvk8EGLxFDm~pnx##dG(vv7qLLRVz7LQhCza1XRZAbKhHhZbX^x&`W{Bkyt?Xva}^E?$k)c^6c&ts1LO{d zN^YG)LT`T3Y^HKs@O~8x3K+R6zs{=1eQvRToERQA2s;p-92(=ltD(x^pXtAVcn zy#f*Rir^f5X;2b3@%pfASk#95$6`&TJ8Z0^KxhNEQYS^@cm0&vK#V~C&SX(T_$5{K zNP}`VSpTsCy#^Zb(emrY(VS7pL}`cqcq>!z2KAafe%X$K~G| zQ5KXqq`Sl+jj+CwzU?%GUE}QYDTKp)w7w{`ll8l@dvsKlChsBW89xEeq!hqq41vh+ z2+F)ng1Mho9#~@fCO3gw3Y$Piy7}vLNB^ig5>tfgWqn594Q}`?KBf|u*Ljz!B{*#t zUxVa&b>mmx*=8^P8HzfI#MH*3ct0ZqSRiO*4)oi*#7D_f<0wN?nk?^weDHLanEXp2 z_})OUMdbYO{yC$Aq%Z_HGK<@d&>@vo$y(O1EB_mPU$4-FrEQP7<6wSos(^q*T>b9f zJv*m>;FbRK#A#$hTy{MqYWm@Wrme603;r+1U3YdCg;Ptx3LyvOSyU7dj}QgT^`%%oc@T=`!q_K9R>;HLm)J(CX!6W-_oPLu*Z?{RQ$(np5wo^ zMwnR{{#OpISWDafs0H=^vQ^8*>6y)eR(Ed zx6S^+p0B3QA-c=z9JCKA+V@}bpLPg%gY|a!w#tz8E&9&TF&s~F*_aurvI!o1jX$px z+P9rA;@$WodYh!FQ%fh|pZs+Gs_I;x@9gmD)6l0vpSlqYQ(y?G+3LNHq2;SW@E;KI z67kq$k!!vC?0M8_50SY&VwogUcz(;n`LXrp?t*R-Ixq4rQZy3-B&^;mbC=KmU_}SR z`??!F#F7F#FXbMF&757Mvrwd!kFG$1&}-N67<9y408}kfJkNZ2a#=A@^9Z86nY!cy z-FhyZ=03i1|EO3gY$e{~uh>1^{Azr%#(lfiH}Pe6`o$0Xx0h@~PQQL*UKTIgY*X%Q zJvp#4n34k#q$r0w@=fX z9LmRM-4f3dWT@Kg)?1|D5JN++)l$pp9OYjQFC;+S+AE_wu6|kS^Pw94bYC5k-iVjAaYJQ73RvM|PLAl_bY!KO#$j}RB)9{TUnfhvj(0BDV zJfRr`(mk>Wr0djn$UP^OdH2<07)QP(?yMzw8FAaSST^>Uz^tq8^22)5jOU8;uToc_ z8N=m3fySWC7Z1Y4qdC*9FonQM?z$js7_y}8k=BnK3j)no-Mo#Ihk+2Pt)O2MP&umI z>}%Sr-4syku>(eqEA`@Na4=tnfA+Icnf-os$7fU~>Sfeg%PH~0)WPV}F%8aw#}-Jl zlo|ai&eD_x1M3yltsu?_^-*JA0-_qG1be(L^fhW-d1qMFD{y#lhMmxHL_K*RIfnugZm}UKJriEeU;t&KeutXy> zOFS|8z=;$f#>P!JTsQblb+;oq;uM*927VD>F~VkN%P6JsOuY^%;*S6vcW4VbPK0Zz zcMPJ0)uuxufJ#BlQ^7TNDa_%~GB)Ym42JKqt%+$0Lq{#lGHEhh{KmXtAb(q96p{dk z!~-Cs(?S8%fmacMu)fwZ1X*D}Cvk8bv@K26SAxx;jAl4M+>;EQOcHjtWEg}g0@@8; z;^2WqwE{7vQ!Kq;jUjI(PN3H$?<63Evy<=_zP0Ak>IGb9Z=*G1SwD3^~`{yS6aCA+#CuFeJiOYbTHj z*`RY9_8c>5O^Bj?ZGiW&J%Ei)t|TLQIMrLMqWr87X+og0^HKk<3dr zzb|@KNz>pfM}iNj8bSU+#b2kNWJX$vDR*D7W-L3mYRfbIKDrKP&`eog%LMB97Y3!7 zqF1%PT6G3uBZyzu#!LUZGO^it(ELL{#HD|`M$$X ze#4%}Tbs3lhceD}cKSVejYj-+WaM)t{}YTEB2#fDf&h8Pn{cp2wslI&Rpp~uS$uH~ zqHPYUeZ*wxu+M_gu63g?I3VQ}=@trt4JCrd@{JtqqRuP81#XApj5C8WZ7yTV07O?a ztefh2*txvmq&+eMgU?og`AT@ z{la0JlV~su1jMFF<1jZ845F~A9D^RRWLhEH;PT~)9)cSwM&BE&{Gu~rpkf}~j55bj z9r~g-UMJholr0;xkdN7B5ExI27Ta#80@ZXVyc#m zwlkAtQN{bgHm8f1yJZ5xUOGbrcY}pWiH!gw(MMq1_w&9XyYJ$re1<}BPL>xN%C*v! zQVQc%8~4k|l)w}qv|x*sRF#)D0zh^1?1^z6gYK*}JF`4%#lN;sZYY-Lay*5Ofai#!P5HA5>b<{CY5URVQ5cB_ag%qYc&^+e#3|ZS8vDO*~&oF zR93{-kGOC*r1#6R!u!ghFHDsUATGWxR*}?1xB^knip5v|&3gZU-p+FW2+6F<`kk|6 zujBxK?GRI+*axq3YygDc1-Orb;E)6DETm87hZxeEGo=UzkJ#?kOCw1d#x0(@Zk!>` zFwTjhG2A?*=NGaOJu6_)-0H>mSslsUEynw(K4(=2rhJY*6VhdeWaL;`?G_@_3H#-# zH+eO{@VK}J82D-%ehehj3RHW{Jqe^ntxh$01kV2^m&RLKft#3;k^-8VVrG()-ZMb3fWVED@uwqHmM zMt4dIVNKz_({KpX)&O4LGPE+Kx1bxFrRJ5LE|ijF67e5e)CwRvypCq#jQgvJ$V6GX zWd!6T=$N}wCaHr_NwY}`$0PE{HB~avzw(9ESVsox^t3C|V9#Azl#xOcZ0$-5dL&lv z2VB_fllYa2sRt+!aE&8BccYoU`Ye$ zfXB02r~YjHB2A%JxVHO-rTB?zJ-*rZiqBZ(gP!NIpLc2vR7OQV|=_U?FS!KAOk zP3e4*MT_x6NGS}?(L=vB1ySh9d_8|p{Gqsg|8vaxuVo2V=KmepMAx<7WV`F`9S{hV zr6W>JB;|IS2Z~%Q+MJ9c8^+tb#V(Ayf%&mAc*y-03L z^}`UU@7;`jvujLD#_?-^cSQ*AXNd*#Ljhf6F=eaJICDK&Ymz|Zzbeoh1230NpBw;N zjlk5gwdhUhC-*@144R!Z974ec+f1gqxiF)@0!&VEohE3b z!6;#(Y#Qvu{kR`uw%#P*?C{d19Ud50u!lyOjjHw0R4W1LP@Y|4GM>9eShMl`#Y+G+ z9*eR$6_;d?O{_tl9R^~&mDVBO`G!$+Uw?XFlF|~h!H7qcPwziv$iSIv`lsGR?1Owo z|76B6V!`r;PD<6%DsS}&gHY@<2LUrD#kAB+&vG|G8q%(+q?4n&o`_GuG_JDNY!|mG z{Sl(wW{yc2bh#3QEh9WiWO=ZgTaK{^C3I)%FJbD!^~N?;_q7CAli-Bx&Tjsm_qbTb zAV_>olPZb-qeeaFJNYRzF{P+|ShHH}Y-5UfZ~&ZBdbps{UdMV$yvKIe*2N`shVvbGqlVlSA2 zDLfQ0zL1$b2R1e|dsgsByl&(?E_}N=kV3J2hy~;9Iy^w_LD^ zTzeE|x(>yy2Xn|+NF^4>5J1|rk`^k&VXG`ps+$ znQbojOHy5NejcfUn2(0t*X=G6=!B#Jj{=H**q17x{y14lns>heU`}jUk>j)#*gbir z{RkH7;K;dPhmqGtO>+bk-LrPa4O#boC@V|)!nV}K>o{jC6S_K8&Z{kj`!mLk_kMy- zXFZ?2uC5}n7!CjTSx@Kh%~ANr)-L~>-@(jAzWj}&y{J)zK2l!_!M(&bd7&nW+_2Ax zpeXf9a4BWDgaf^fHmXo3#Xw$r`-TlrSXovc-`kN_a2kGIr5SJDbjZsAqn|Wz`VT+4 zoST66%0cu_82TQ>!w9rp^n-(CcNFh!PF)=Tf9-_kdt%I!v>e`-*~5yp+qLhyfH1<= z8V{~eN_9=}!wamiU6p^r`s$bF4tIYU2)YJvn!yy)MdWvT<0C=PV!oq{iWACn$!fwYTc}1kTi(Px za7vF(HLgcy%?YAP^G`5`2mO@`sh@har# zE5nXaeTCiS(Dj~_dIQOu<9)gG))w;wgo85MkA8*SW zF@po^Ss_o4TvIsT3FOCm)R>Um>XQc%*88*gkEtbkIpQg2{#&co?2yQ(rT#yk`u^{+ zqqW<=JItBIIr>E}Tg9rQjb6cEn ztA~-J6bycblnxme>RUCY=On=oK7y74l>e0d!lSR6r1v$t%9%B)$92R`EiQ8IZDQ_OALq^5SIcSO4|Fn zuBOV554N)YIe`J#rGbxr*@Y}!76MxpTggLBuHzIh{V`X^GRR%ETx_=gD2cARRkPI; z^de$$yKXLMaZG34O-3(vIJzj9r!F}qaa>lc{yN^&A~e^AiA4||M7@Dn;gR&yBfnrrnh_-U#FlvC=!~sCrnhdM({4%RAeb(KWAT{iMM3xI(t^ zWk!!*JSn-Bf6KD+O3DEdMiVDEHx#p^Gqwc7$8q?aG* z=%&WOyu|)Zj1Xej#28|{V!Ai9x!&`2u^k!&Y5>)EI?t2Ej9#}n*ikp28JrNg&pGaT z4y^%gH_&Y5fYUUtOpP9h; zu_wdi%~_uL`0($}<4uG`1@uD^ERRt{c-Ykt)$o2+-D`1RcnFPn8#j0U>0nmFy)Q@?r?$VRx!#a;;3&fKx?3@2vypi45h*@D_}4_{78|8!83-qw~HWlOWa6?2?s=( zV%pMM?Nq{cNnc9U`8zaIvm9^XS@qUPPq@N$AjpQR?aFx{4;U9l{)7iY;=MZFmI#;r z7`y8K5}fu(woq4U&FI_P*Gi(qm$;V_z+3n#-iaH$9(FpV&Ap7rIxI;-h%j)?Gm8BN zk80{jLQNWjrW1k&)CIUolcabx;r|v_&EmaUDxkq7Qzv1+gw@o0MQOFud`a zCnO3l{SqZPD$M zRXqycq5@&Np=WMbl?|8`oy8VgjGVjG5zJV1l5|8A?gVUz)<%F*xBmMQnX?8i634u` zi8|wBC5s96$2|0kyKNqvEVV0uG_xXPi~mPedrWbO;)E|k+0Eq5O3G7% z276qm!GvP#f<>%3dNQUg)%Pu_sROq(W^(D$pNT|2MYlxxN4QY%X6dj}-^UPSu=Fee zu(+GKTS}M(Jz}2xQ)nq9j>1+14tU#iu0znx2an<{CN2)^>vNo$w&4?e=v#1j?X7I4 zf5uCIt=t;)tL~wJh4U>jdXyxlQLT|Ry+3*^VWT1LNlIpAH{^l`@>2&LIAFVAJL5El zj1po!VVQV62XlMlc<{s$$BmbR@6Y4k&$%6Y=YZby$QbKQ>fhRSDXubC2{GSYf{w}vcskmZPC0es>3;(y;RfqC`Zi_1#q7he870Grf6>HZCT4c zw^hsL8TiygR@LakV_lj|LyJUHbd;_E+nl14Gc1%cx<~itrNx8LKlczX=uIu%ZvJ%x zgS)kNzuH^;!~YD4jO(c&$Sw8b7z+2|Tk2M}%9uaSSUr)^pEbaPwPa*j_8B4<<21WVoL!7p%`u$6ysLy_#@wkwhShoo+c%BS*Pxrc=T3cag#0F z_RoNH`?jRZ=g@XSEg6FO5@@v2Xu~Q+EhUY$_`-2`VWFqspdN5651w@JD&r=L?wSA6 zc)MV`z8!*xx78$0hLNCs9w&&=YBpD}XopkdLO_WrB}uPTa_PKLxRlRAyN+_z z%F$#=@6@Ly=~nGEyF|{M^%h;T*tw>afami$zgBPFP$T`s;qXu+vfPhniRJOz1DIs3*Fdkmqp3MMF?NG%^+q$v z1&cF>#X)5neg1^El^i)*!;@>rDK)(AfVc+6TGkgBfaEoR!)tv!MPI9WY>?kF0MB6I znqO~iW<*AkjX@XBp+OdjJo9bpB;=5qM0gPy4(4K`Fv{$+RAgJY&ifImdw7TleLE;f z(%vRTO2)(j5BECznNdiDTDefrQb3TqGE*JjfQt2(6V6z3b+(Nki|RNTKf1iE|~;s!k{K?nUVrG`>0O?7L=D07yA2xv%<-LBnPMY| zlSnMEpfi6x$%g0eXMcj!`+!E@KVsRTal7%#R(&BzsXTXd{Z<}Y5Tj$*8w~^qaEa&| zg;SOxNI6#R@)#0;2)sV7--NK8NW~AYtT@?ih6Yokx%sSuLxT6-ii3avu)qY(t3YBq9ZEY#ODpaAAGK!= ze>4K;!aV1Ea@~=xWum07)YxqReo<66+OsALb`O%Cpo5KU&=+Nqve1IIT2WB|E z&u{7sjZ%Rn269`?s$fW6@&@N_TCWdOE+`)MX1E{cIP~=Am)WUh+8N~90Txd`_>v^i z&jH$mBm5E9r;azl4`JoH2alQ-DAtCLo#r@KIR(twYCgsaD(fQO!N}ho{KF_+p=+u! zz7sgk*>~T`m$6dJA;TA9?Ei6gjy21D!42MBn^64!_Z_ zB>F8(A(tnr@*B76-s=rif;U2HW%gWqXjzSHXGj=7j}B0UC@DMiwXO(xYBXQVw>*?KgvX~&3V)u}Na^slgp zb(JA>Q&Umoc*WF<6|9taMsJm*41VhwaEM}pLp7Fzd*H`}7ifb0wiO6WEAOFEYFE65 zqILUD|Mt+Kd>Ps_4EVf?+$3r#EwTIP5)Koa#i04&UG`@&$R?tDuVHUGqH}d8WDVfI zK60nCNiz@!b1~c;Uu9<1_KsR9#fQyl@HcaT8+qNPEmvO{Lq!V+(I^ZYs0f% zeZ+i#Ch6vIrz6B&z&h6&(QMga$o4`&@7?cxpqF3GHbtXo)IVfdA}HEYiYS0bI_RM~ zzSfV$tYo=hVWgN=#+8iBp97a}i{Q{)e8{-JHyrQD zJ-+D}m~6ViWD<9a(;KB%l>J7XopdQemM!2l5wKh`%KIS~*_H&{D?$g|;q&`g<+ESj zbmQiAJFcgA*Yc#2MW8QX#5#}02JS|IfWZaKq?ou3N_w@_-5G2yvK$zicrs~Z8bzSI zN$tr*{sG}NBM&LqyX!1hJqjX9hoilKk@XQ&y}8shy( ziB)%{*ge?Sl0ZhGUE+yp2FtCmPSKySKbyDfO7-XVaJ(942{UiXK(IswSUQFK20L~+ z#vzpVciVRu?+oV*r7|l3BF3i1}R3Ma$PAQM_>Dzfp|9F=%J8RFk?t9yvMm*rrbt)D(g*7r4a>E8^Z!tTUr5~ zdFKl6iiMK5EH)@!hgO3J0R}Jh2B01Td#6lk86@sXMx(q_U4vic53O4Usa<%wD}Vh! z=3aNTI`uocT#6z2z@flBkEsA44$2mWW87YAeL;ZF=LP@w0LM(v_P>uhn3&nv{@Y9` zTJzrk*M{(KfHR*mS?W`#Qb-`7g9qjcTHl69ppLuNhg-*9L$#rzk;3IEX??tWTn=h5 z?gZmVFB&tfSASj(in)1lo8OkRBmDlpyF2N`i|mwX)5v_@9=xeh56fiko;>_lEctbl z-}R|>=UvwFS^^IHO4Xic22yJm2u?cOVig!I*o zvvs-EB=ha~dmGlfReg{I*A;PSpJ?K^S3yx(jdK<(fdCek(&Cpg6Uc+f7yxcILo9Oz zcdeef;Cs}_b)IB%*wd?LVgWqfAqsl!if#i_($;DdTUwDL4g;ps0Z$0Sy_{bjEZV6>Epajmo?fe!dgtLT_AraYVY~?gcFuZ@pD>Qpt!2Ss@%1su_bUL!>zmMH zQ`hHoSgt{`?Yi7!seE^aXH#xm^_9ih$!Do$=U_FOliaM|zn|FORI#pF>WPV`yILc` zkXH;QwdMWX`Zr!|o_Yn!S+2`$^L5#%nkh8J_i&xYsLn2S<6_J8>cdht@i@D&%L~J! z2GpKGywsrvIh<5?^>4E;30TUcCD^;KDkzdVPSDrb#RBu&o`q^>$UrrUL|VC9cEwCQ z%w^?G_T2c|Twmq&gf8f;^wETHh4dM4j}$Z_Aio=p#f?8`U0&&nSFKMn?OMz9ic2(Q zbqy%T_g4FcPxmaNIjj|9<(V5_36|m_u@2UN1U5B8n^yNCHr6mH6z&ZHtYDaM71^wR zWXo;(YLW6|*l_Vz5Zog{wgomal(t;Lu`^mDt=#u@iSG6!}2W z+SmXbEa+5UTx3==&)SECrt0xDTKEt2m!m>=0rW_l)}5nIsRcrb$iZrz6jvkYbLcgE$+*4E^Uqmghaj{Ue8Ie!pVbma zzoj;r86C)ww7~$gOiIa@SCWW#d8RUhQ6fmUm8T6Q&%9%wUsVsZ%wxKZ$Ym-P8h6teL@a2bmW>^e-;ic_9s&7b5T}Kz@r? zWukpUKF{_-s%CQFSJgVOm?j6TY90pAnzKGyoN$FNCKU@xl9E0xqAmRB+clNN|6U++r*kPt7x*@)+W=i2pU&u^=wbj}vS zjJ5^7szsf%u)iqSHhK*2JCa=Z5&#MVA;9we-@+d^$l@FkntKTGf_aR_Fa)}vtYJE% z0=={$R|2=g!lrJ{^${=+N+Rmd^V3*fav-YOP{8cX%0ewWVC{3aK*az$=>4_Zel=AN=X9=kZoe30xx^EILdIDv>_yA8-sZxF>{cj_P{b= zTuYs|_8T~!X;nam?cC#s=>H~64T!WxSKJz z2390@lXgn9X?*Q|7?sjPMKO)V%WEtl4P7% zSAWzASIZ)Fo6ZF|LQA5yC1nv_pl4=JWKxegDA@R!`Q(mhbmI9GYKX@=9DiW{>K6z( z?BWwbeH8o&Vm$rRjV73cLCp@ceG^D04aa^9x}cv2#AnRzmzi>c_#lrbLwZ$!Z9Y7-&EwJjx^h6?zJg*Pz@Go(9NLKVIR(zRu!DF3epL4 z;H4=jD|0T&jNV}-$yS%l5k1HHxXcrC>}$PC zF+>-kN3vU^MoaLV%c9i;I6jXnfD2-W1a~O2#M#3lb!2H`#qI) z)Y43{r(q~sqKygHP8kXn`}f^f#TdjkD~VKWY5wmzqP0RUGQo7TSYp-%5vJsCK2SE* zXf^0KMn2-`Fvsxl(>t-kgA$#NEOog91go%S7T4`14+)YEk?Z|TE7CGi2{P=48obM9 zy8)oNVOjOi^9+4=RhkQM5^y%s$DgBb7u$$jh}vo7n+!qb z?1;dH?P$eX5hbg`#p+VkVfM9C`^|AQX;{E)Zt*=0}o5Zj`jv|NRsc+w>-uF{p<*tNFjPaG4G-WEBH zi9x{69Lqmy776ps^F#HROZNG`aXhCf^-Fnw2dW&YZwn#Jgp*rJ01-AUX%XclE`<0r zLFXiRddoa&Xb~gLbAAv(a@ECCZzjQjTW4rFVnxNBADY_Y+dN;B@l}hqyF5yVe}(v^ z;+zPBmgE&7Q4uW7{m;88?FP@CDJ8{$9yNnII6t0A4z1`?My#@&DC39>?0P$DTF4Xv zlYe{o9bs*1vsDoYxzgULm5d8=3y$BFXBpaul%6JQC%@)bU5Z9`2BhuccE%osmHFgO z7+D{{B`%LduBa_BGs88Xmx}u7FcbEwoMNKj3&PZ9DOV1F6aUO%r@@03W7EtLg!M{u zKbb73XflaUiOdNRT|bE!<-C3vuboYvu1;JyohaL6t=>pm4|J`$kN*;)iKjk!D282b zMm*RfmHNg%!x=(Nj1eJpe{ket9oxTwZo{M;y>mPM*$r+ikR2zLPBf$-bC>jBUxe&H zDGg??$=u<52LiG1)AsCpR~ZW;n``FeE38EFwJaHJH?GJyhxRch$py(L*!5ZliPm@w zIEsS$dcg+Ejs37+g20_F6<52cCcVGnhkqy4){MTP-#4cvNgjyyTpiYwEx95L*(+#==WhYVV=caf@fW)~t2W6iRy_gncRX z`+nPnn#}X$7=lM53|)rwAnLXV3(JHPDaNUqiOc1C--#a2S%XU*LiXK1f1`O<0W=Gr zOOn$=<>F%k^)uRp>$tu;bCMA*f)~9%u}!WTG^{>ldp8^|4P*NS!eKjC{oh+26FuYq z*z%M;>`n0LON5a2kUxQ`ZI9k#AB5H4zJEzo2k?@Z@(_q1}}XdPQoNGZt) zzr?hpqytxvr(>L;ZI3-JanDeu2K?rqysjcfs-J}`{H2Rsp|e41&w#KL)4?QFDW~Y5 z!AGIf_nMOc+Iue<%rux4;)fQOvpvUamZ&>WJJ(AjVxqm=v3!B+0)Rdl}q> zs7M)xR_GAmJ3SiS3rWD38hKr00Ea2Zo)o@L0zZ(WJxwr+o(h}+7f>OpjMnrst1+@z z(21atwZmGKT-)Hwm^IvjPBe`O@`gAa5W0W3DGVY|FHnFwuH0T~1Pg^cKCfyc!8K84 zK3I{8UJ*XA2;hvOCn3E!c%GR>48Ivp!b^Y&!@Sabo6^Tj9aF%g!*uKU19MFh3 z?VQ-UM0g2$pa!FiI#Pkf#X;)W0fZ3JvaVWcK{`-+__TO6ElJ?Gz3+lCaC;JsBL@cz z03z>FpNAkp;21nKRnizZH^JG6eS_n0A|NE3whCLS{@fbs@GCKM!OhJU-mSs5(!!0QN%2Y zJL(>#5EFb{;V}5v_+1vj4@V_JoYFrPuE1ZOKMIv1HEoD_IQ?oN{t=0Z60bp>fAwK* zLN0%vZ-4o*^mV-b#ZK^QYxQJ$zFn#G#(4qlgolyx+Gj31ZqZgFkKe=2kEiah$$Dkg zD%Txv4z90bb5;4WYfCEA3xE2HxU{C!ZjOdr%;sRv9VXpWsrPTpiTxLNaN_LX=n6=7 zzhO9p4z6M7WsY@GADAz)dCgK@j$c4E-Fj)!QcoL`JN+y8vf6KsuNEhG(0?Ch;g}lt zr>y}uPb$~FU4o7-)zY2mOxYr1Cnwis^g=$wezUrJGJIR#j%cfrCOx!Z@=I`u34u9N8xh zN(RG6aCYv}2G>{LtYeUaielbi+00=uLp|*4)F$UDKQwf&WltYLgms>5mYvtt8~pgr zXZU`4E^dDvSp3+|d$g$aW>dP&J(s_?z88G_3~(W9rPHO<0}diD0tYgJ#GYF{Z>wRg z3}Rscdlq-1PisCc?j85xn`(W3jOx`5+SAECHnJLUXS>9voRA*N#-SvynTEgOz3Y2= zX^#B8r;cwxyV*l&p6f-TV3@S1%z)Z0kwAGMq#V={iSQywB*lgi6Jya;=G1&>zOVL- zns7C}4K^Z*&!01gA1t3=y7BlaZWL;bw8G}^eMF8%-iTH4T(aPtkUpF-k0Z~P(^f{_ z%RCoG*Kam`r+(UWdL@EOx~mSCLHpEOOowIr)QloG6G{bs>q~)71SsioHmcZT3aj@S zn&NAd#oo!$@Y;Oe)o*e(Tw6Pv`*1PQAO_o#grt_TQ^Y70)^G{`c*%Q;XvHvi!km;G zuq4;JqOn;auky$%vB@KedMJYLw8$8Fud%*2fMFFz^*6^p@GRjxbksi~^=}{tWb506 z)qKBT(L}96&3cydx^Bnsvy*w6Z^!e1l8zsOZ|o7&;BMbV20N&IuVJ@lyfM32^7P37 zX-2-}&r1%{#=l%4O0X3sznmeKSO0_~b5Is~2Ob3)sz9{7Q#3VI_@cXV&5H%NAVaubixU{%5vD~-qD0|U*S-80iaJ7qKYcHhiBzB zJqnN=DZGb<^Y~=(h9ya)9>f^X%IEVgD$z+U?=vfyFR8YM=zCR=f#RDM95Gx}Rd5%EM*DB-TO*N`-&U+h%W?gc z!R)2jx8EP>N4fuih%+<(C#;W=<-bS7(XH%?#_l`)K;Dr>8Er7labplIR@XOGkk6ep z#oQ`8KmEgA{HOZT!hCp-M@x05{KKNz!XH9zYHDgKYTORFxJKQ0b>A3!db`^`Xz#P7 zO&s94T3=-m*~4Fw@knQE_P?%FKZQ17ux5cry0^bPKiSw%Evgxffb-A8y4E#C-|yJ- z7w)t-W@@q@xJBC(OnN0SuYcs1 zTl!S4c-4f)|1rC|dM!YM7*u!_E$zmjP$K73y1Wh44ZJMZ zaGa(DQ${6%biQTjR1}EQwdn-83f0Lk#^R&}S`TeZfSvHhEh5q9l17ueF**#8f&zvS zg-9rMt52DukeZ&quG4db{STISmYL-4HV-4il`t%n`1RxFua`v{W+ zZreT8dG0(W0bhqYkatzh3#&OcuiuuBPXi#fBjoPyu)EAq{-V~5=07T_&jzd%+33c& zG`J$CTo~&Xj&kS3>BxQf36K{000b!V=TXGUwA4=}oUGcO{UM!LgY9P5qJJ!$E0f1d z?60xCWfcuF@Rvg-{2rZWMILFhy>);dBBEbw#X@Rp(SvI7_f{fzf+w?GUjgyBaOTN2 zoT#d_VW9_|;QunvJreRwOy~PB(O${r@284pKJBJAv%HGG3-)7dsA5My_39u9Gkt+2ittfw2t6Z)G znavdx(~prbZv5@Oy1BpAAW$-Jl_sk2gg>#C!On54qMc1G?gbP>QSy*OFsu9}>$R>7 zY?4d&G!UsXY?+D_NzG6E5k9nVCs>~5Iy^$L&c48~k=9MbNEx8rOD@VZ2x>toW#5T< z?cdn{5@bE$qMx#uHnsd`&XUlumE~wp5L}x0I@p!&5Z_oq{l!sR&@#lEfPCOqB|61v zNpSC~{GzhclaQ|+gIzUFU@1z^1(EKFfHKb7!opo2UWFMw76s-+S<3rqwkzIdoM)S- zDECpZlt?ci2DO=1qt+!-@s%vfZmeee?>nP2-72D1Uf|stEHoY1l+_AQvl1hekE{+& zSwUfv8Vk^%g~ewJZvC+4q;&8rg7pemcWLZP;(F| z?8F}rT;LqZ>B=r(6?=0o_Bf0c_9(^K#qRgpM2pMT?J{o)GLf!~k+aOf+;cnHwkDNA~id-{m&r zW3t>xmwnLAkE1!IEw7?yb?uZ92^UBjJn#}+TWpSvG ztItg7SCYr5m(DcH9U?1sXR1d!X{^lOPw*WZFJj%1<;(Z^Crh1!xdbV|^r*@g88t3^ zIjIhm`v{;EJxn}K$K@Sm&F;saox23|@%4;O4L$x@!bWIJk`TWCq`tI%1p{>-)J(qe z)aFb^*z`}9R)D|;axPeu+K!tWhW5&+2|7 zY!QD7%sf9U4LRWbsw17*Xs3&G^6T|^+)8Ef#p`|FO06AhUxK{V)uVgb{}!pT4r|?` zlH^iES*Z&p+l2gV_5CxAbA00GlJxd_NPfcSlw>sI*VgUcHAnx96WzPjB%zXkY1Y~M z_O7-|0RStV_bZoeHn73PDU&pFw=B<L z=S6+bLQt_Z>Ssi`Jn3iT3&;}k%lTgJl?t~B!)!@HhxR+zMSiy(tL{_B(jSz4yb3x~ zj(w1x$cx}@Nn%eIHW6tDGLRTF>Zckdkj;!>jiI>qhii)@(QxROoCQ+JhM*a(tM|$# zuOFPB0{15=l9+C?7^po%o7;bh)4s)F6}n2y*P#j&}M3h zWV39N?5jzIfr7;TGwfpS@t;>hzd=(rseG~eBjLGHM7P7f@pEt_2p6hA5ggWp#N6%h zMsw=+lj&1TAy3-XnsL&A{b}`qK9Oc2(fxIKxn_&<>lJ)CDZgH(roH$mD2ycnhG`y09N;kpXoKlGN{#p8G ziwD18xHM4~@s+)*l`>Kf8B>?aUdDZUK`D9&c44*rMo&vnP3eCJ7tD+t|0B5g{|F|! z(f{B192`&uKz#+BmZCq5c|!B{T>hv1JgNmAdU#9t#UN3!$H_aI!T!Cw zTi0zN_7rQQ{>z6(-{tegdZd~K{p7bd28~(eGj+771^Syn){N@$)eO~!Cs|Wh8eKui zYkZ1a)0g<<tAF+@NY;HPTVVPICrJ zCrb96!mQm~cUIHh-@OklL|anm%cAp<9G@YRNTrXU$(-1O-$8#r#BYn>l;@hw*d?Ry zi~e-kUcH_94-R$UJ2cr)qdh|!H%*qR*5;O~VEzTiwXohjZi(sPitJ#SHKLvH)b2a?`^F{kj|k{M&_qYkN%D;z^w+ z9XIXV9S5JbL(hvCB0j?NGtc2T!^EnGx({0?T4j*QmH5WUTM;CZksmR+;IpW^m z1J?`Z>dlX8$L#%^!{gG)SiQKr;mRxXkKpiJGKe-*^}#3?0Gz@ps=SmJG>wCRn}6%^ z`a%R+`l?RfxvyC`aejm(x=>z9N%e^+mLOlw}pI`FA8!C%vaam`v-sx;8QK9(j@Dw92 zeZ3|h6-0M9L&ZzLwIrKC`Q5*mwe4#EurU};h8OQT*6=Ph@YfGQVK0|$ODjl9u!J!X ze1jsA%Re=B^H@B%2lTItCgA;Ui%x_?>A9onLK{U!2k6*Mk>c}v* z0EK!T3`rzt42E{0h#;z=t7Rfdx#va(e)sswsp>ZcG#V0Ms64VT$&)Ti&YC%x!t4?> zTQgvsQYCwW7a7z)B;vA_oi^D>Tmlq29GyNuyio*Psm7>;@{mpCqCTMx|8i9D4 zudHv_08(3y<8=c=Y%5-Lm19%QcguRc*2Rt1-mPLt#s<+~l+pR;nBkM8n`|l<_$g@7 z@?S%PqDiI@`u;gq2{gI31ux6OUjh6>M)wgvi88Pxo4RCJTf>cIGnd2nF#y8Y+%0?&CQ4UF0SKC zuEUE|GpmpDuTSx%t;PSCa@rU-lR`6hd1VR!Y+45;>uQQyY(aE#Jz_(MhK?!1b&yf~ zYfucXX+hnUnTTOc8Ytq8|Zm#l0Za?Nggf%Hdc4w(_d!0uRq%gf|k%VCgB zB8g61dC9!SU#}ZFlt?aOWk+38;ei3^h*Y60-eSNjp`ki{$|~!TpyJA>?4paY&>w-A z1Q;TK4GO}$C8A@P_Lp#Ja_zQ72MPa!5&|OFhiL)Cn7w0a zY+CaPS z%#FW}f_L+nqHBZsF{pdnfe_YnN;TxdeWThmPdhf6sHGC@`8KCQrj8vl5Z8`_&U^nJ z!p;@9?R1H3Em`C$Axy@VSp(rmXL)k-svi`(6sP>pY zG*kj4TbA?dj59)BB9iL>odqVBP-W_wG5raRoFv79-ZZ>sHZ2EtbNEr_Yc_5DfH&nI z9@shG{)3hmJpHc_`N_*+_P@wA)^6Y9;x+PMshR50ye+q(($Ymd>;t*bls zHFQV}ypd<&@eU`g&#SYN5=(IjD8h<#dLFuqewIMS=Rs1m>Lg!Bnf+cXjOLoS+=E;y z`j|Vi8Zx75*}?{nx=nx4Kl~=0CXqQ_Wm1zlAzuFH_c})l}QzipI-H z{hDI@50L?}F}dQ2k*RVspYJC~M3VWaM1>;(t~GOy?GqF@YNtru+r9|?_4UVaW$Syv zT_m$K+U2K6&W8v#9V5z{KoZT$=CIt3U*!TX_23rMq)O7UZrJytLp!IOjpTMqi4R0! z*WC+?BKLfP*az#wX_%W`N^jNg^Mws+46BO7iI@oRU-Mp@Zs{a5%@XWFD4|~Y{K8HA z%kBWuM_hQZ6Bn;P%FD|U@?$^6ybrM-KTLwgJKel%3j;mE`cJSa*(n}J?~^KkOqbp8 z7m}&ZH8&9ZhQ$#>aEE}L6Lbl|{WzJPt7kyee+iTRzF3$A%L(DRbEa2xbfRh<`=+7B z93gVtk)gzqI^OQHFrv$@HP>0u8@5jX@kK8VQvy#>n$1+AfMb&GX!*?+fGDMREY8z| zlwS}pZJFEZ_MW`lIzexNvgNM#;l{WuasPicE{{mlZ>_kDci*;o=(!-Vo+FQ5 z>xBf7_THRr6X$7}6qb4JD%gJKQbWm`Qp1094;Cr>6blTQ+V_dwC%4X6;G5*(R z6?s+Ja#MNz{8Im*!uaN*#w3P@K3Lv<<1%CokOOTf8|_cYVtw^{s<@!{UIY)fdhe?9Rbn>tld zdsVulT!Ip={@`s~GGTS9J)l~33C!JI?+pn+1Z#BLV_TP~T>)1*6Tlb4)PRvCVl|+; z+w8LL1}X&NSTO|}cYZ?rWoa941S$rNh2uUF9_*vk|22X=g`sqi|A9|!7BS#x)Dw?W znc?OsXk*1%jL|v|gFy`zGxjaEDU1@By{9|`9^GqD*r!L$S! zB~LYnp5rL$atsen^h$ulxaj8pMN)|0hd8szbf;#Q=&&ZM@4!qP>G#W?NC?D7cMv}L zXS83q09_iG`rMiXasf-j6Z6v`N2c1ayRSv{xYef|tK?FijI17(6mwk*QgTy^7Vyoib2S=)IE)}} z4iD-ba;-s1O1?{cRW<`w5`ey%x$mi8H)tj)h)2QRUzP*}7KYRQ2v&p`k>Hy{-a$x! z5N&R&T0ltR;@gsSn?D^GxhL<};X70q3h?P>akvJ5s6J`Du|Yag;KWak7V|((CL)u` z`_Y^Fdc<{z45q7l8}lYVQLKF6PUQvNItnY-1;F@K8f|PJV4EWguo(#je2;wY{XENo z8ywOHfmyQNxNs|oYkYuaROpOHlO|K3>X4fGC6wL&E1_5j(~^Nz*GqWcte(?r$U)^F zppyg*ipcNU1%9suRKRRpQl^J@T?X&>7x@#QWlsn(joP>YNsiY6br|<&L2%P?;-biY z8?rQF^VeUdu0cP}UT9ydy+gIwUJ_Liu$@tQ*OJ0_ANffhY%sRal|jXS7aW*Id@gCK zE5Q8gSw+N{o`xD=00?RCE>UJ^7F^NGdT!P6u&M5;cf92{;jh%@pV?9rwVzzHf*uoF;V3J z%^og2i~O|IYBXpFon(;5y5xp>#4Y3T8cZ@bsfK;Yq8yWf8y{*k#^VMvdfS?q{YO8x zNE@)QQz0TtUrFS|?7i-NnuWcsT11H3{d^5!DEdZgJ;pM<9*jv+O9lGRO{9#EebWP; zQ_;=G2t7#KZPY{H7F@#t6aYbMh_5R`9KE+?g~kE6J$^;cu>wm)nSr}1attfx%|P0H zJ27oOm5D``h`xw@Z#CJadmaP)@ctRJ{mZ!PXUDC({T!Tj)Cj^Zs(+Siqdb;@bL^tQ zPv3HFR7~*>yEpvL2_$oQ@DxH&-Tp)fmEWCZgw5WD>14v5Tq=S9uXu#^;*`k;+~6=l z@Q~w7VIAycOq|kY+stse(>8)B!>CT1Wp0pd8nO}BD8V{M&G!1}d`z?mln@}bx4o&e z0sN1Wl`*Cpblbyx%gankOCn+z{6YBsYzL(rQ%H=mvzt&0ETf0O{BjH|5GlD02<@&u z*kl2@IL|~n#))(WS+|L@-<>dowkLR~`wbPa&$TAy~SVYK@YYF%z6(|z%Lx3nq zaco>H7zqa^e*5| zz~WB9;okn=HvYh$QHkvc<;zR747NcQB-O0OM*BocA1m0rm>G;Oa9D9~wTwZ$@rl0L zU3>8ZwP1&c{RD}JiO&ip+Cy*FAcjtY{jEWpK)v8LkDNNT+&Pn6Jzgb<}hAr6`=?JPcN1p=^ZZNV`>K8dhk zW2%7853p9Z2Uq9#Ax6IN0|nH`h%_trH524;dvRRwYu!mN$rJr^jK0eK4#WhnK%R#~ z{#Q8wW%An2>0z%ieC@@H=tqZJMCTy@_b$=RmBsgk6{&cL?m@ zz$|XN=PSji$H^qs=!I?sAYdf9^568IS8SeJj{PGGDn6J1s03R!fFO`j$+=+!bTNSt z^RJg^zhKlxBsu?SmiZ5diVRF_O#dzCUacl&x5*CQbE<~UGj3jdLBqk1TGwci2!iTW z7Qo{i31T$PYS3LEmi6^HV=vlrG`G&Wi6k=fN%Rh5BFBp4_3%Ex%S4-khQ}xJVr)7s z$d*ODnmCp%9AmSt%dA0~SUWO3s58&0#AFY2_>eGC%RE+KAyO}C;rhr=RJJ(Udfs}B z2S4nLZG{R9B0nSq=mD*L%^5D|JpE-rqu z0gYxiJ-6(EW$AFOl|E)DwEMdj;Dag(Z&~S!YchuJp1~L-kdDVU93*u3wleja?77EL z)Us8=LcISTA0JtcWrUrzB`1?sCwxTSo|-A!QiS9+0u~3t>RqTi*!WpPf;4_8iHsRm zZf-mhe^DMZ88e@>Ug((eggWZHVUsJF;NN3yGVVLc0;OJGHAPLrhe1cdw@mL##1>-C zRi?ea3dA&2O9Rn2-wYH&4r^fbhTr4QUZ-7)Mnv3Vb=B$^f?-V%kZv~?I-;V%%=qUH zDT9eu#!9tWy%{kUv(oLm^xe8d;;L6w=SNwP62%UMR# zNn4@uum!c@tWc=gQaTsCRAuslS-BuIsY7}xO5J!}*4^pUq@#)j98@3u zqZS`sOJMKGQ6r8HIAA6aY%DxfXiuad@y}!$J9gL=2i+wkgIc9Y{6TaB`E_5*z}Zp3 z)&dBCTN{fxQ3PVwN>dtdc-Mq_&0_mBlGo0fD{@%jBbmE36o&YH*VukG13-LI(2kd@~}cf6h^mY3wm z2(?lL*yC0Q2w;&(sQfm2wfnV3 zs7Bdp@Tq^yG02eTly+TjIyd}^Y7;U(U9!!BNqMN<7JkbYQNH#i_$UNy60Ev2Mi>BU z9yl3{aDA)cle2oT_9bR0j(Ys*%MIL`UNit6+0o#s^-3oGXm!ZchYsjYEH#_!XlAtj zTfUY525c|BMLN@CI)ih>CZdPb{`fXR{fpV3lWJ)R(Gi)6A7DpxD#H9lLW*OP97Zxb{#)vJ)fmH^$%8Z#@& z%sVHcNhsMnpcd8SBDt|+Tk|WD7uhdL$)qcb1{In&1r{|;3XeYs)50p{YPgV|u<~+5 zYCHy(Eeg@0+LiU8uW_EUcr{vOGOEuz`6l1C zTT2M!?z(F(9(bjk{(R%;q4fBj{pEENjs-Gg8w$&~`1@q3B)L`etF2q9X#nv-JQh~{ z5Cb|yXV_+LBD9)H$I!Z7&It*@p%qlwF=g?BSDpFARzKCu2`|;^VhLJ_= zaRnd7ysZB-@?eDYk-vly?4nksNsRIgwba}A!B_N7PN-k|69s!P>~X)m9@yB#W4u)j zS|$)ccCWivMy<=M$}A5%eUgHzN&bzz;nxfYrGy53f0XNx{kU48-Bmqt_e_aqSM7NJ zLfLt8Csf^XI~Ym$>^h1FMoe!_QiG%QLLFL^S3bm`;W0CIVCr#?Q&MhN@E=}lW~ToT z`*N`T*F4&`x>oHbE41%zE%=8bUXz1QWOkEzKu)s`R~~wusd_*QTts0aczyL$N@mXY zM?9gA!olJs?yI2&qDcHdXNMyF=5*kC?JJ;d?dmIT?@ZwOgkG@%r`GP&0R2m<1oz}X zAKZa;%gzk1r=G9_i=HslEfvdbnZ?V8upiym1HT^}Ue2t};nwN1U84u`TP1nM^x&Kx z4eF4lsurQwz~xem@67AfiA*&mX@7Iy+x_LSc) z!?2!@Q1$rJp?Sq=B(aZ+lG* zA%2S9^uN+X%cwHP^}B_PQI-Y2{@5xg2kyX}wqMFV6icevwXG%m~h$J=ZWjd8w4WJ89+%&}ghc-|@ zyLs{4JC>DH5>2^*B6H@P_@l!GCI?^|fUxGp&OR4Ek(ZyTVHv?I6doY2I z{R~u%5yC#3$Ks#tk5WWi5w$xn-Xt-tmCGR&KGhzHbv^8=z~ZopMQu!=?ua`{nxO8= zNMU(NfXW`sXN6by%vHtI8`Tr!tSY^0ob%l%NA3TjQQ1}Uf*3$|`Wr2bg>DUhz>Ww1 z@wb+=X}8mY&o+;4hOwD|4ZVpTGR7|=0P3HsU!m3`@@S|p*_cdV>z!wr=Ny^p3W~Kw zbhnfE)SuX2gm#UKCY}cIVvF*HJUpuHjt0SWci=|V2P`DNFu!|VMg#&ds?3jf8{k*p z9c>&#-I1bS2q2Xl$1R~Ey(SqGDW+njb3Rs6z=g^YI_r0(>OYY%xrhEVlq?m^AY5#2PshWi*xQ1?cE5U0KbHlDN@aDV{_JN{1^1sI=0UpC$W__&E}Gju zXSq)_@y^k)(I*R7Z6;)^CXdj%aF9IQ0bs_V@86TDmipLa0^NXp<8@+gk*)K?T%5E_ za*3l5NifEonpo>WnC`dLMIJO1rWH_!4Tzb`B;DD>I`F)h+m+Ou+)}5}7bSF6je~sr zBi!of#Rkr_W1w11PLx9yD#mSNz7cp8rwWyzg4b3FizEJrhVhrK4nPZUD2At)dn$A0 zc`TWhFmk)dN%CbP7HD6CqZLIIe%f>59!%V0L4kvz`Np>fL54O`l=b?QV#f#hJ1VKo zJa84AKgT<9K_JGW*t35G$PIO<#`ZkjcDAP!v&eUQ{Lw&CAFZ~8_1Bl@dxcwn6;-5g zoJa+PqZ9j7k(%2BF~Xoq-wG4Q5Svq5Qs;wDnGm~rs;ZvA-2HF_CWm%KwmHyP2WB&N zU>jltf%QusABG_&RQ!ie<0Zge@ksg2kElN9A6EwanQi=f^&Z!ajr0WM7W-?@dvb?a z+N;3XGuFzNO@ouWzvltOA2|l6A?Bd7gEHblP+l-Y?pSA>n&3O7OaE+93yFIL1)(kY zDoH6G!1`2n2f_#$#BFD_Q$|;dqFQ|1rtB&_={ZknGvlGKJ+XDu6C6_u3WG^C-jP6H zvYd~yWG#P%^NnWDfjQwerq;x7!ImN>nrCo}BEM0l&1j|NEFHREGl!-1xjEVN(V3ilMZ4Yd)hfQ!3#9IDR5cW7 zNW&UJoR!mXz8R^MnX4?MD5A3;PrK*&>jotvEhM&K?$tTK2dvn&Vh6n~f%=^dTiHmA z_MJ>hAQ$Y)Z-dYGj7AEtzL@5;z`V@EQgm1f`V`;}q2Va)Tl#x99B1qIMjxb`TBT?u zYOS)oT^KbKKYZpJQ9%S#obu79GY?O&8n@SL-YJshnYnTo!9$AhwP``fnt}E@OcSHX zqK>Q3AczRkW;Wi$6;LXTbH_!j*v_bg?~D<#^10wnE=hn(C82f#OK_$Ng?UxfK8wVo znD)aHV6m-V#NZhPU}=x)2{Wed^|fgU`&jj=cF}%{QKBO~sBD|~CalbFZQIw#uu$+5 z5WpGpqADWQ?*Q?;Cl1X6U`wpT?CXBU;lhi?L1(jO0ucU&K-0pT?^@AdIcQHJxsITY zmGI73!I}s3fqIcE%WYL$ZuYl68Ru8Txv|#MAw|B=XlqVaR=N1ie-4BJ-P1i!-TknX z1J=2$(;W}@3W^bPar@yIfoF5i zE8WUIMDl+c1pdQ$@;~R?f9;wr){u(b`o9shv$q3Vf-14((x55`&WY`V1X_e!LtL^T8Jx>O={{4inVMI~iRZ~NxkKV`4CMXjB#&#zLFO<><- zlWJz>AgMwo@f{DJG%MTj$sz0gz&0;<(vELg#%5PVj@u{w{APZO9%$pI_v7rXpCns) z>M-TV^N%TBk#3r4*O%F1#;v{xx^1p2rkQTd_qZp_|6%MLfsnIecRmB-_!5f)W77{#o;bW zA0Zk$@osCe@@?96pzjuo{!g1TLbRFQS?-jw0)m`$wZGRpOP$>l%#djXervYVsr@aC zXSd}@(VqD6bO5YpZd=%G&CaW*&iX-L2(=Gw9+q2X@MMe3?A3H-ZtDaJeT_}CMA2C>OLFr;Y$vp`>pyX>(z>h%Cc4{aS-n6O!4Cb_ z{NvczwttVwq`z{!3a89AB1Oj3{?2H&SG!I&vx~j!lmxt!zPMRzoCFA zt^|Edd|fWTAINbZuYR6Lq;awMEoi=PMC+bXdU!v7)YkR^cL3P~pe9*Z{zF zb*BPxaLiC=aoPn1g+y8f?pwO$H`TK;Ov9 z>=gBb@RcgTdCWnZh{)Ld$q58tFnQ*W)pJ8EcMBFKhUa)_Bsn^~VF^84cLEe-Vc4Np z&B--}U5OD|tqnOPj@Zuni#8C)BGg7vN(M12idYh!D(d0mjehXpV+Mn+i5-0A)2}*% z`>wZQ^*~GbplyntrQQs$#F>*W*-m$9N*z^YSIm!4!~PnXfg@HaHbI>J*=l(THuNtbpt;k#~{`Hogfs zr9Dhgnbs6jxISFQuBjDOL{BL(1A$hhnMa%O(20GWsgB(yQdNu-o$jmdhm)|^0+pH* zhbUR%N@)HR;QaubI8;*ofK(w3n#U-N^%bKYY@yCj*$yM5dc-6e+|TNZ9}7dm0}L66 z2QTd-#y|y4%O6vsFqct>84V0V_6feG7Q|+O?-~cP=$=8J`3XsD4?)`S?r*BG9@n%4 zolKt!jkL}z&2flS6W}eLmN?X)2i;$1Ln6f)r`#{n6GJ?)I-aV>&x_f{++DF#fMzbf zFpD7aBqE!9u-q~*#)+F)ozsUEJbLEDUaTExjUu3c60Ngv!>kGUl@zVsKTz6K`i0Q1 zG2Z885sP9%=`<1C-G^bxfh;xI5sI5hi(>}Mn#Eh3U+T=xHuCw^MWW_XKnsK|zSbX0 zP#!Kl4!Wb6?-*Cg{R!~_2(p|#u3PKa zGe|JmBJbDNO?2lubm3J2WX%I#?zS7G-4s=X00qUDNvh~y zrV{IB8hRE%W~hcoB4|d!CQ<>TRfKADAxTs54pFZ!r-7neaqKHaPOO~Da<#^?kYr2{ zrD{q!uyQ3zpsC^$COQ>EZ$7zFgNe4L$u`b%Gyk6>d+SFVv%dn;Q~HH8I27wWqoL#t5nVK+230jmF!&Rop|~Yrzaq04#Hg2>qYp- z2J!3Cp}rhw;XwY*-YF-HlvINdQmpE72gU^NveAi-?y?J#vvg8n%Tzo6TI?et-0=x2FC5{Si?mMGsRT3?#u0hcnj()`-K0`jNIH^d}`!%iSUy<~3wMj4yJJ`^!$w_M1J-*PG8 z(5DFRzo6-dm#7iouf@ZxV$|%!t)9c{M#bKstmOiNEgw^j`Va`9Ey}LljDrMCh5vBG z1Y5jBiFpp1Cbq^kvFj|3gOXOTi!AWq_Dwr248OtU7xe@AJ65lL>EkBEGp1o29>Gk4zv@)dCm+z&9FQJ#{SaWW|M~|at^I+Qd`#JrY!4!J8WT4$JV&s@j?C?~ z(@YJ^74e6kk6F700Sg$73-g5*m1iH3d^nRA06_Q@Ki2KHw3GM|iyOppvY`mIvFT*W zeEf|}iwV`i3>p}L3YuT00RsMA4-}!Tb1T72{M`kd^QjTwB*yDR`*ls~#qsS|1iyOR zO|rog)i1WHi8<3!LVm}9cv0(zp$gylD zR{yyKd(6i_d?)d&J})~OkduE&L)|Vv!hj7_uL#*(I9krgAbE#?V2lY%s;Bd%4?2Hg zZmRjG4o1c^;4m;b!rgQ08Bpfs^tWiwZ;Tg8OawFf1eyWeuqgvr&wiE9+)u~-5c1q6 z%iN@^(^+;{xy)A9d2#W=j{i=)2lZ_Vn?|Nim7s6LKs0)M`+hjir21Md)P7T~^5stL zeyiPB`WAlQ0eOxe^9lMqx;N|}K{vX(C%gLqyi0*33n13h>$Cs8|2bLq1vGV1k^V1T zJqyc!8Sk-h{GW{_*=ka;o2>sM#=NQ0z;k&_aw3Z$GFy8{%u~k+EdtZn(-1bC#VK!n zzhPTMEi_;|!myq)|ESGs=6bXs0^?QHQ`y*$^@Ov)q{cQ%=^ zzJ8y)9zARK$PH|>+GY|%k33#M5AxQV6fCB?ZW7WU5gEmgMHTW^#G}EjY=7JTPFA|g zba*gKPHL+*0f^yls=6n8%?@Ijs1r?HYO5Z{f05`~59VzTyM1FD^E<^xsla|88bLfA zhO^PO)jh63NgIRP!K{KulKj+UW@~K{Oy=pECD3(tT5BAQe?OG1ejFjZn`AC8)6!9< z8FjW)pg)=QY%$~z(j_!5`s+V@(=7HIk$c{a;?N1}Rrizd`mhrGfSxNu;YIx9A_sdbzl~&=+u|KlJJFf$22X_$_A5=tae|%Vih}62O*p zLWi)-Ecw}CzYqCekpf{P;Y~RmfpQCas0TbRcUEbE$x7r$FgCB}7=L7$Of%&)|FKgY znsbL+n_!mXy@>HYC;$nidQ37DJjAUyWe>C?{yS@=FYj+^DR>XE^~c+9MHr#$S+u@2 zJNXU%F_S)y)1JY6JMrs@`u1HQ+n7#nX2KJ^wPPYd?u`6{%XP81#sKn-^E!YKOtB$eVspE&lc zpaRi(2`Y{L&Z>c%6DGg2o1~nL0S{RNCLI)-g@9NZTO$*DOsO%V5Q`ku@{sh1G{2KN zRT*Hxb*8TLGUt^Wb2ld_-~lS?>W3cC+m{HVV9hNWP~*}DH;|wowTJWmF`a0-qi${y zDeRZMoPM{3YAa?yf22C{h>fQ_aY#yvrIcK0PGc`T<4EtJk!xL};K5HJ;uLYC%%2fS z2Jl_LN-!o*>((7BsGJ&CD=pK=-#dT@z{*~Un+fS{+C2Q1^&DUl#$I?d!0#JuUBr)k zp4+)lHKrDm`T!9gY(`B7Jpg5#%dS7oSq0vG{vS8Hc&XwUE3JngFE4vkoW_a_t9F!F z>>MtDLi9y49x4PYA>m|ANn6Y(iR3qJyCti#1tZG+`?mpWBe@Z=ad5Kk`D%*}$LO8H$++lu1qiZk6c#cJWQxE%nPK|ec7CXRChD$b3?LiCA< zY;ED}(j`JG6ED5%PwNYtvv=p&nnXoZyaDOX>0mFL@bfOreRzZQ&Xq<)323dq-#j;1 zs$zDQq3}NX!9K*i;SYOkN#u1u%6TnvAw%d&n$Yg+12hJXnFo!A=f(5Vzn(N^ms|@X zO}KpK&lhXdy%4p9#rVw(_Z(lbphEC7oz2xM1kOkSxbo*_5KOHm*R_03oc{ zp2omCxnUr2wLsoI*`enj)0UWE)iZ3^fVv9 zHIK!uDiH#`?8-Eb-Aw-|k6z;YeuaM`Twb(OhQ|8u9G3lGY@|{uwm#V!tHf2NCO=tP zJ_?A(;&$arQpTRc)5CabS#5$>#5m$0IiHNy!A9x@EN`?Mk9zzW0;*|j&bEObp_f?5 zU(JC!H~1QkKiw$*M%}M&u&g@{b`#^tk@lsxf?f?w-d|i=eBP5}MDQP}b`iPkwPULV zOsD?Y6?*=eBoYSyhEm@$IRkv$llzG(`=MEQ6cbbhc(=M=pifhx0RQD5V*lUaJPi1Z zOpNURfgmvAGjPz;GymuMPnG&liO)#S#Pa{$1OEe0uyQhXz^4k zg>-asFxIz*blZq}1y&~U`1}JsI-YTr&9L5L-RV-3Z7uC0!y?miO={R+Et^5VZhOj| z_W0FnTm7nCt@7FN-f5$POe|UPG+=^{lm{}l6P%Oo9}b33NmnpD1)^tQVEpg+m*&Yg zI@E*yh{4L`13Edh0IffM4GJznm|Z>4A~CtRvn7G80~={s15Q-|n84zi$l{Wc0ze@l zz4}56$Z`WP7_w0@`EdjD|1pAd3MqvL<#6NF&`|H_I(?rN18Amz@k`IlOuVsm^{c~~ z8=qKO!^O9~GJt6EoHetsf|3VK*96q&{v`up$t{kI1coCj?Cj(Utj}fw9vc_*3xVCU zIW~Zh2jm3K-tsf?>m>(9j=J{yEg1oj1C(!Ua`;IVL@~NKu(<*O>4LJVmiB*{xuvan zG2tic^K|j6Xu{^72Q>SoGi>+8m;?OL#s**le)Jvu-u$fPSAFs2!ph7DxWbOQ=Bd7- z0XR`@;rA;D!VZiKg~I7u+qt3>GW=^g*V$X2S)W{8Ki=8DE64Un9GnU`Y8T@tGq{1fmIZ7p4Tx0m79S0|uX`{#H1M_1uTcl7tS zM|@y;<;9lgxflA!_i4mMwI%1b#VyxVE%kLf4y@ZY?E9Bx8RW+@UxdHK0FDEGa$mEZHkq_i5s9;Lan(m%!~i@^56@4pZ5`5<~en?-km@caDqi zneU7z@C5G(SLw4i>{HwH3#{9e?LBaZM&>tiZHK7~kEfGw#n(Az{t7P+qYwOx&dV11 zus7r+wx0{|k?)Sq=y^2fneOa`4B$~0Xp`@wcS@i}_80usM(-Z(?T3GoZ`Pa6zqmB; z_|yN_@Se8u1I+8x<`M2qcIO4}F1vdh@6E>n{Ws_z3cRcXN$k+AHckIXa zGpz5@Z9n#oFU$HS(Dd(8X!QH8V(Bjh)}|)`&W`P$GrZ!TO4bZC7)Ala|((TT#_{an9&ZF%c->2=x#gh(cYA@Z>r~Mn; z&nFrK{23r~u&xe3`a_8NYOvGRD)?dN;;r1>tm2hr$^4ur9hbMOw{VC=e)$h-)43B> z7UNcAM+=p#H&K(|*MaxK1_07ZO3~KO(W6yb9%J_|Y%g;#3%iCLp%x!MxEOyesng!$ z!C4`K8Spyf4vA3w;n_rRRZ^(W?GD|!0-t;f=Zm|(?t5N_5bA!rRS2&rk0xE6TMXeU zu_JEiQy>%%0rmAL6kJk!=H`0rdZO(RBSh|=x16CmRJU`Bx&huv_X^dLdRC|XxV^I- zIDsv1jEs^;B(_g{zs?gaMa0gL?$kk4*k?WBLM}U9rN7igY0x3EqU3BY0{&{S>`wNz zO~$@ar9NjlKwc4HP3SXhF?l?*Tm>N(EyEOX-Gi?i0geJ&vyS2s+K4+tEsRdF~OQgO&&(W5S1u=ah*U`I3yI$K)5Qdvm$)_$iF zEp=^`giKZ{fztx@8sS*)1XH`uSdlg3wBZ^DQkjsMECpYNd3FN4G#ohLY>$!44<(Y8 z3h$@e#0yjzA_+=h9v{|t+|8aXJBuv-8;xD;C3Pg2)6im7%&8`RN>QO@s!iY9V4J0ryHzBz7(yN&U&{9Hc9Up-p70WF1dT%H{;1E}27JNA-3^iMinH zbG9Xpinwk`MX2C-&Y{2QcF;5h9Nipe!;hpQ8iXt&hL`IBqr0=5uKRs!2?p|)tRyhA zi6yrFu@NtZ?4af>>s4Q8mqq6|?J0sU*hTw5$)q+p*T{o8u_P2-&;bsg9hPe!x{bU7 zu2dL{qf~-<6B;jg`?@e}XA^xG(wked>-mv}@tq095+UUTB9jBpL4r=7Y+;HdM6I0* zEjVOcis`YbL1&f^hRbPj_6}UDvDlelTpT~*{FbK?tO^OCJB}Z@UcNQ=@Gm`^O%UGn za3RVr>f5GjH#S@ei7@A_ru=F*Hju696mpE>X{iFkjgz^{sVGcAV>+^Y0eLcHW$?=T z9=y2;rTlc1r|ghhB|anzxswQ+%M`o+SELAz<7XoWWYms6B=jNz_9-2qVX_1;^F{5f z!`h0OQ6aI*4Hosa(e+EA?B)@#g6*OOp6_@+G1jXN8Y`jM8iMg!mLvb~1~2{%FZ z#YOURnOVScuS$6xZp7<)QcYep2NWy|MmT|Mk1blyvKTQtFxM?}-Dp%Q_6WzykYWmB zpi&nbp<}d=XL3vbCU@3AQ5SYYthyMNKKw;%^1j%zQPGVOLe6EPE({$k?1<-{(1Yvg zwabZ+Ph2aaY+W=sGFEQGLEeIF#b=`Tg(LVH{;BqVokT_NWv~uhwCwoOHXe4S_uszi zEe6~PA!K-oac*)H(|cwK&d5|ijEy?Djd4tYHK{hx(6Xn=$a%;Feeqt9-w#k-7C!Jd zW-O9u2NshJdos?#k?YsaJUU$3sT?om#vw|HvUfX0`)%bKLYX9Z(mZad$MGlGw4H-h zy;|W?CC~!)L#K<7hRpZR09LfYKEQx&pm}Ija4a8SomKTb0&^7hn!YmDBcwdun+V{QLSb;)S({Z{dOUv}o z&v04h$w;efx&z)sa!W0dd;!iDW?3||nYufaa$bXF;=eZIiNj409{;>cTT6k>l4XW< zDT@?mOygS~8%VO}G4@8aLpvc|3RIoTnIC`EHKzq)zuP31)ygyi95;CZPm4J3kk+*i zQzU0E+JNlfK`rjfE$<2ko`CGOEHWeg&86Y!l7~@911mpFCHP=M;g!q=gp}ZxZ1T=z z!P;=$|F-p``yS>xID%-A>JMlT zr5e;||1O)Pd$a8kL+wJ+hHxfFkq`vkEd)g^ssN_+kj=rJky5+9Y9CEo#5*6nd2!64 zmvUA>BIu*?fx&+!_;IQ~5%x32iPL@Ex~GKX$lF9+YBxjWbW`q^N32I|+sNdk;O5hI zhFXnFTSaPVDhDlQQ4z4s_c;t8`~irEb@q|{%(slA7ZkvhTdz*bgc+#(rU|gVpP_{Z z)teO&B2RJeGB4n3$^v~HapkR%wXXMVe5w=B)+-uIz+C=N^lQ8@9)O%~ilp}tiY+Wr zINVl%akV9P#>F#+FWH0;ZbiY^SQn6tCh;y>jLYF>Hnece)2|jMPX@EII2{ zWN??Y{h=Hlk0I%d_g@B~@3*N5J#@U_3HEVn*Q?bWG>(=yA&a@rJnPf82ppglIM=?L zS9$Nyrs~5b#|gw$OgUfj3Ow_-&@euiXs|3~sQ4(1V3Nk%*O`6@t=C+D8R0xLV!xv$ zPU(PDSe(+({>b^&`n6}pQQ0v?{jdy3pX$zWNr!Z3FERy?WXi-~xhN6bq7{f_qe!_9 z)FI~IJrP4m{p0n)^Y$Km$HDh|)V&D9Z#dico8q!Na~Oi@rY3NgscUOj6mqoBQYu$O zF&RXqSK+J)Wlo^o({$n~FNcOZijKjzCa!O4X!2|8EXW;Js zBXeE_YsvxnCew6*!kJ4t=}k*{-Kos3*`8Gg2|}G9$QRtU0u%_kL-3;4m~!d}0laxt z-G_UMxncz+9{h4EFR?JKQHktr#Xf8Y9|-y^kEE8M1OsC7kE5$U(gXb|nrQz;? z;o)UJOX97<$94LaNmpvj++jnb71FTM5!8zS;tc@=y(4ZxOJfSdz-Gka_(Rgdg6PTj z4U~_oyNP}DeFC*00aOW%{wNeP^Y&$?fu7vj4u*AjS!W{p1-mg5dIbt#I6sjr=69vX zcqk354B``4YY4ldMS+u5V!6Y7x*28jS^3I^M{y%wHE3o|e44JF6}vA4qb7P>vIQs^ z&Zt_!tsQW=P5_ql7;E#60g?NnsI<463;UjSpUSKc`I@p$wLHcLN)Y>$Xu{YdXaQie z5+ou;%)J?smJAE&)QyP!V>=l-Mgx~*8+6b>I-xQc1Q17qx;IFFpOE+ zH+m;4SYv=h=qx1ln4u7^qF%10KBdbwrvn>G4CRjz?$X|WyiSY)Gpo189_=6rb0~u{ zEz3*6{W4)0+O@1JZbw8IcLw^xDNB{oLX(LIf!;Mb#lFLt^AC*I97^jahM)P51Kuj(6STny?BSG;I^UwzK`5TtD#bu z{Su~jeQPDgd|;K(c+z}6fB7=C49@xo>KJQ5Ztnv~q z#MScZbJD-9lYYa!<2ZiD>zTGQ;DVD|XFC9u$!C>GZEviz&Z7-+$z;gL3V%OeQ0D7X zuR}R)!0oA$QVd|=BnNp_%qxPYeN=U6BgVn^FMaS6J7mYkCBil2e){N`^c@y91bGah z%Blh%Gc};6klAh~onMbeIf$fW=ZEa@etyuZ%Pw^HB&Y_i(%Bk2DUiGQ<62v}>2Iy;~I`&J90!?B_xECqO}}@dcLTSe{#KNtNCA zF}ybCw#$V})a)ai^@wN9{7~oq7vzR9O@W&bmmZ=E<=&>ib(n=M@m3pCn*RuV&fM1! zKgmr~iWcBELk2L1dOdVIM1NaC48kR(Se7GSQ(+{?Au9$?JEugG!)Cs`b#vhpIo+p$ z7v_09A(8+((5S6VfPO!E8tr4TZ|%<6W}`j*Y)z2%_8KDI$k$ZHhrfT%4>sLSh)~wX z{QDi6a!#R31pu@_N~8vw_Kbz!MIvm=R71Lvk;mdCLqQ_{C$L``l8PqrYFcMc;dgRF zk16_=+9-J{z6!Yc*;O89e#SY}2*l6~{f0nq~{ z6NVdIS@oBcB@=52bA5_=$-;Jmt}qi5{xA5-o9kSTz&^kx)CoP*M`}W8s*! z>KaSG>m-n&%DX@BCqBF!^L`i}%gK8|AEA9lZFe&nj6No*hQyszxlWCT??O$bJ#S*l zU*8{^>_QIg(HY^wON(MOKn=C?N4`7{rg zj;{G))@|e^hiXua#e-*XUv8!_du@Y{x$D$*iW7EKTl1;Zk>uxS&wM%5JTQ~7?#36( z;r;PxEp;-M6>`3KnL_2z*dd}V+~>=m+%{GlgF^7RK#siv5kLgy#^F1*zN1g$fYMO{ zm&KCes}Qd{S)%47oh-|h_@akO>|$5s<6a^yAdtB3HEs^A?j+N$qL?CEa%ju!*B!K{ zQjhjA0t`Wwi78?w)bMyP~pt6|MN`*l$Q0d{UdhUnZuk4p~ndPQ+=L?%VSk<*J7s$hk{#=>qS(mr8-?4&$wCyLA!f`#GxDvqd-qmXq+<2gl;x}d*oNxI}wBGb9vMAF65BoZ5 zQ5>4Gf{zizOrFF9Nzn4?0%Pril`lNv6l(gGNU5M^_X%dfe~}+(e@}{hehz2qJ+XAL zjPq^Fs@ChFf^{^*BgY14_t>>}A4dKdW^mtBx z=qZ4HRiP+u)UZyz){ztziNX%HS^^x#(KgrX{?0h18Lp83alz{PCpfh{h8MvO!rg%`(Hi zrnX@+Z)jBxZ=)*vUj+RwQCUm#--?>amYd^~ z+&ghkHgp9bWgMN;Q~1li#|6ZSCN}B_0?;<8+maE$GE3RR6XJgE_sF!Hzb|7$R9)oN z6n;bm`(hexwE?L0-SUtSF}bly`D=X_ZSv+Hhf9#7`+ubSJNRl+i^|JdWG7;x9<$c! zj&=2`$_ISzwNH$XKN~!_7sgz(Amvrq{L;cAfH|}ZS-a8`8=xS>`j2t6GT05U122)b zTr6nkEXYR?#??BisOQRc)X@hpFW64#gGE(w7Nug$rvKry@q7}VB!Z?{*rc5n&{Cz< zx0zkEzELd^bgjVHYIn(PbAMAHFGaP9R7cnBx(Q7cV@`aLo6TArd#V)2J1Nr%$jzu1 zOY=h-zAwz}+BDx+tm17?Tc4N9WJ5_l>^v#A$RIr?Jmu6!m{l~6djRI=ccMIijh{13 zKWZcF_bFkT$k4~32Hu_@%gtez3OheGgf zx1pCv^e3S0!P5oBY}`9AHMf`pNJ3~ZM4IVc*hr;`!Lv-*jqfwf4v z3&K_DmTx@Yzd677+*w_I+hViHu zHdu1KlF5w~M|4!veiQ3*kgAK#wM-q<67YXKKfI&TZtir1l!b}wm2b_G#oC*g4lY1y zS@5L9YiD=M;)JZTxJmSPKI44#8RF}hI0afNA*~`HLSCi}rkc_+Gl+E*^~+9tIwNbV zx({7ipTd39LPeb=8uQRtgmv-FBIahu3%fHUJ`WFBXs53b=sh5uLM7!ozjp)ah(RVh zm>Y{M;~-f(^d$tkj*~Kg_--_<;N#Da4Ql^*BoNCJRA4M5i4u~k%%60TuXtJOW&&pN z=%80|gtN=-8h;QoEAZ8})a0=eyG7$@*Lk3tZP6;-?4Per1b+@L=QGTLmCM9^cl~*d z)=C|D7wM0pOQde`u(%ZO*7AwTu!IaJ-xltYdKbPp`~g!&3(;|m$#pA*YWKcCHJX&p z5;19hY|KGAwpAy2&ynp$Pa`*!x09b_{+6_#{BJo0x^h|IJi(`i8pU}TQI0z0a9i$$ zfmlKUS!ETgw-7q?fRVg)zUd9yG~D}8M@K6pSr`+xaG~=cH0p!{%C;X0?5tN%IE@OK zfqij&1~m>_=YhS$0mttQs|Px^noe{|H1pozwt$ev)`C- ziQK1=&5--ryY_g9Y3CsrZkhGOCL1_1A#hP_IP0Q&EjB4}JW#p-4FoH{HtZg+uU*d&M z*!Xmjd4?}VhQLZGH`^0z2grB0;pzR816(z9Wm(q-1ri}UUTqYoNCrrJ)}$xLcW(8= z|3v=|Vtw^97R5FKk#59f%ld!08xFGi~e@Vlsrk{Oouq zG;qa!VyLDNwrK$S=z)xT|0vpf!vt`D%M`3@Ar{e(lA2|b6(cz+XbHYZp!L!n04~Gi z)!@xNnV}a65vn0;O)9h6B&E#}jb2f}-YOlZs)64(!Y|MlY4|i3FaPi&*DY$dS8OfA z6VPaijy6W0MIMSKyjzJ;@u=;NdGP;L@Q0&#s%m4v#H-I=?c4#Wr8McOu2;|PZ!v*r8Q<$Xm|%n=7q1o_%mZtVIaPSHW7|a_GP70DLt_i_2QTQ1vhF z<`}S@N3^PFs;oJdYq)_8hm+}Tm6XI-ByFL)ZPQw=ED6vpCLXqfi-vSZi~+s$yC{t{NzdIoi;aU=~vM&0ZEvzF;_C zPNz`u{uE6}O=Mzp_JUvYNzg>#im|HWvy1}p-S}=Cb^2cSx4Su*;_dZT3&a+sT!jBXNBtN5YTs;d_q63eYZy$k=7g+kdOLiCLe-v zMAi&IIb42QJ}QUUv=@V)^UMm1Lb`@ME-VSUw_DY_@YW z-=XKewa`W6a}?oh{k4`lUW94|@iGFAyL;5M`bJ2TUYk)^$b&-*1Hs`+uptR)=$jo7NIi6K;>3tbk#PmUYFVhkFVjX7?Ig(**p(rQ|#L#I0bkUN2fV9XX&yv+# zFkj3g3|3IAWeoFX3?jSajy&KUKk!lv1 zjM@49#C?!~hUCD!1x?|tW`H0O|XGpEycJKKug-vBg^O-F#{W&s&ppMd!+wRij@?3Dy2fYnkH2sTV?##8tv^3Tp&!MV4B z5Qy6Wk~fCxg-CrR`qiEuio=pkq@`+XPcI^zR|%Ah?^$6)LQ75W)FbYCPX-b37YW!C z!j@UJ{2TwLnQ%TsQG64*+k? z6Z0+1fpcOP!xAUQXu&b}nFGZ3xt0Kye6_*d3g*orfNZcX+KqrJZ^;|B4JRdRJ80@a zkg|K;gcufJ-#*83fn&V#pV366PlKG2D(kf7FaMe{HLR%^u)NzScWV%R(3c<_j1uJW9Xk*gsod(+ z0{%EI+Iu0K@YrDjc6#g)bmS}`&_{!Zql{U^VVrQnEob3u?<~ZgIOC@tq zU$8bl3C3KBejQ37pFP96SD1-scU0{*)u_jtTFz}V%xdcnA~SVv<@b?^dz}KhU7M&##^@*$ITrcTbg_@evASPlSi4TfG_qbAc&xt{TA$~OJ^n| zCGy=Y$q~w{$1#YxQbfHh(N=l#X#3$cD1fsIQRAKSVyQf^+AWw*mO3wJx471$P;jq^ zmE3)uQJjM*>fIF_oO}{Q*>?$7{az(x+7e)RYvVn5V|ZP&sm1@vJaXQl$KBF(?4l{v zlsV(VMIr%$5CdlnbBVj79dX0{u?)aXa zn-Y_lxQ-iR(_T`0HY5nMl~aU-!q|XvQ94FKfnj=I_o0zAF+^zyyg}($NXx%6q>e@k z0ngM@4NULFkDg{-^NuUm?~FwL(?1Tv*lVyQ6%p)SHW8-D<*t6_iTR4AVqC5n4H0xz z!lXORoQM04sai}WR^yX4{Pf}s2#87`TP^M5{A=>(&<=u7d?U|Fl%f355~weHCb6*z zaLaSpf&!5S?L}-Brt8lC8UZ|+eCC+Ux5>lR>(v1P?72(%kAK()7&vFDQ=6g=a!sIk z%8rP0RHM}&k#8F2SL4npJoM{|h%ZkpGHNzItEzt1B$9^&g0v;g+KI*yEOWWwSe|lC zxy#xaQhSsmF36;dnE`;m=pmM1(ovu$#x9>Q7^+VG)|>^KRQwh!IJ0hWs>7|s2|Wna zZ%=kM=Fztgq;5ZoVzGQ+v=qUjOE^HBmWKG|YYZ1A%vIk~7#--tPuz0WfBQ3A1jQD6 z$k?dC7>(`!O79qhQ8$o==}ehk8_6)vM0hFn$KU;RDVk}c*REpKg0sfpnc^&B6JD$c z8x5+|>=({dhIxM(@B$#k%%)p;$KqsWitM2Sv^R%L>-3NqlN#i_?LPKAjU}}s|A)}+ zvkA$96}D!oOZLGfgXSZnP14VOR(yEm3yiXl(9DTNwk z4yJP2(|vZn88D>LY0bA^c>$kN9OHg?!|RkjNM`E-t#YR4l{Dk1ujKirfXaZz;6cAg zrrVYv`}4u3?%C7^%b-p?KkzP&>0Y%((@JJXYzTTk!|5bYCK;?=zXZ0i1$1vchFIvRzRpe&+fH?Px~9--VPr_)>Un5`feM_RWF(D!WF?!+CjRSbY{WXap0qr+uI+SGMn} z@|P~#ex}Jk{Or3rKko`wrr~=rc0{^5E;TIEmJ-(CZF21Bi&1R)C0lt% zRy@LOoE#XF?!b9aSuL;AJOF}7It~sinwet2SSE=}tkYjOXue#DeHgQEbf(nd<33;5 z&q+%%1;1bfzk>YX!1NxIK}$X#Z!(~e18L+=-Qu7=7gS-vmK+y|S~O$*QEN`t2Cxb1 z^%=Zu=0=J+QTerI&WdALo7h^gwauiHa0=^^$7rO`hgZhO)WqVS9&WQejBCS5f8L@I z9O!q`{bZkk$QMV`f>70s+mG_*AGZlgsUVwO7E7|c#8Qy`ci^jqG?;u@*KK}QUYDY%$uLx}(je;HneY<{1m z#nOX$Fb%`*6>)8}WmkEIVlF1VH=w_0Tfh$|gN|7a65=}~5H;un`JAjZcN*vXR4*B2 zfCJkg5h%7|=H&L~BbmA?26R#^e@2aDlRR`lDY}kgTR9wT6fW%uet^Rc;3k@oq1ia2 z(8jd~W>{7bBuNhx{yEg$3d;KLe} z$m3Vd*XPEi_)@1YZ`K?|%-Uh~%Tx>}Tz^9K$+m_9nQ9E)ja9=4>@HhntAyN_w~~B$ zV~m4m?Tpg7Qv&1zBygXYjgne6&WU*66sN3HInx#$5t2XKsrFRBq{=ZYv5yLX0zQks zo~I1LsUm?dD}*7jG8-X2v4Ql;3H1dR`OyLx_HGdOu~Ztr>9&8rvLJtB+8dus$p4gW zqLvYRjv#=}g!(%=G)pLHrz5_Qz*slB^%Kkom2}O@{Ar5egu~cT8o+n`BQ>%7Ya}r+(-~`) zO{&_LI>^@dPk9e(H05Z+AHO{)sO~H@4+F6H(zia!9&LG(lFer3K{Ovuw1O2y6|Dcj zr{@xo5Z^+!yO&Y~1|=cF4aGkqskUE7|+eMY8w)SwQ8 z@~W$lpEy0vAS6mr@Qrf&=uoM%q$73L_kx;(OvUu%n_WMT+VURi>>9>3OFl?)V=sKs zXlb@bPn3ZZqZG0erQz#GaC;$Tdi$AGrS$fcn>bvDT>&NV7a6gmn7)Tx~HNi*r&xd6-TS((aw^BPm+zLr`Nzl zdge^01>=@7tVeiHU(w)fG{+%4qy-RCru0^*#lv2G1u8$)%E~j8@>{|d)Q*4xF~{j( zVq^wz)Nxkd1?nkOl5+^<->Ol2v%PxY1Mk0xK?l2|N9=;-hG=Qd42X-B*73u>fko#o zz0r_Ms=P6qCtU}!1vsXAVc|wLTjhG54GhokW=xg0F!yFW$uEewasTp@uP&E#Ptj0k z*(UKL2_p*OT$r2=srYq2)5+(OIc|JJZjof>)Ktnht1XWUm5DL;)C<<6T4FXp|)V0Qixq1U35}*Un0$lG!Uw|%%Jo(w~p<~9o*L1 z&#slCko)}HKTl&u9Lj#uh${pSOVX0T2Q<4)%ksg2K9<`MuAgEg4>7?*5Co`gwLF|> zXn}d$VWz>s;eS?}R&=GFiaAG81$p^bh%=x{g`bm4-G3>j z8IcZ_)U=&%RMba>4OhvAbp2PoUSiF!rf&4VT@{qOSh`0Y$SlpV#`~QWsyQhP@JL>e zad}1BfGInE#QN^{stOzH@8ulh)*BVnLSJzrEWJ_W3sg1BSzmZs8Ao-e`d+PKc?Byi4$sr}K zvdi1JS7-?@q&}kR_1nMWfi~C{V`orfQ93_FBxooY2&&2<^!}H|#_cRNKh3mpe~(y$ zeyg9|;-{R+a^t8<2mc0XHE4OIda5qc-gYaY?HD!S4KL9RxxW@gB@C^>t((H+`+T? zc6U^1==|cvmz_#Wrb?!CCQEqN>ng5*(OLQ_BbspL?c8W@q)mFc3_vURqYG4!h*?kk zS)l1WcC8j~F~62WbUuE5ypJaII#S_S^F==(vWj*?9tQDM=6*Ux%t-oq5U;J)@OEwn z)|AEP+1hW}FCouODl_)HUWarBn`huk`U(L#@`?$XSVoFG(w-39%FkOV>>ykFFh+fR za(-gYk+=S^x*nH8ABaja8)wY&X)#kmU2?X!X_!vg1c$O{)y3(P+Ge^nN0>4DMhDOk z^t(QHYY@9;C-rhUAIXGY0xC1Y$=Ul*XRpN&m%iEt;z*6uE`)&wnr!tntP75Y1t8M* z&vu!WhtnM~i@b$>zTqcekIeIcgjXBaDiUeU4k(Cb8=W5ulle<>>6zzd5tcVjMHk^< zp7)vLR4=>mZYqC$cLk!h*C^aj%m2N|&o5-*h5Qp;t-j|JEa8{sN`##4u zazt9EgT`TJ^0K<%cX?J^DE75|`{aL7V2V&QzNyKzj7izU#9gC$B&uP=e1tAY_9&U|T zH0Yrtp{<(KNPj90?<#d1IZyP@*0U#zJEwIM^>*(#`mkUWU8KkwP+{YV@BMXeFyXwo zg&Qm!lMM^UtZov#yTzuVcni?P(w|(WHD|l$>`q(N%oVfjYH494r%huPn;+i$*2H}q z>zI(qO6OceY9~Lc%tzeGp@O-tez1#yiGHlpXlfD#B=0O*i+H3PEwbsB15*Y3?+C$C zy85cm3neZgzxC8^ii(ax_a$qm2*$VU5~bkYLVW=OhxY4L}KIqNS62-%W_pm%DBRpPa|yh5Mjp!)0T&pdhX-M zT{QK}N#h}$UFb8}s+_}nvNoID`^3RQXgWfjZz z{uB&LKZ8RKrY|zR{S}3YTXe^D`CA;9%u}VakpLLnyv}&FBx3%=My9^**_46-{N7`b zr-Wj3&VvM|q#EaRx6*lD&Npe6;#uK>E*9LuW#fJhC7ZaoH-Eo9&Ucd;CjN(=7z)+a zl@Uy7?`v4%yLLL{#A9jaZaV`Io8^L1ym_HHNxa4jue>PH`Zz~Qwx>MELs%|0HE6_9jU zUE1oB_b}>J9lpz;?O+P_S+pd3M`IQ(`Jjw2GA|7yXjGf8{K9RA=Ngw?SYy?rvKJw> zV-Uw|xdUP_R$e1FsYY7Cc*??qLMrf%+6Zzh3`4A!@Oz$|)bqN($^bH6ME+e@^5D$A zgqitc^mM^@0`ydAy;PvBq9uSwU-Ior25%VY`>=xp9(_p!)SH8@0M`M3{ ziIR5^!n?O+{gMT&L^vu3b6OvarvYLF(Vhyu;~Fh$yueqlfkU06&#^5$#hc5Ov9}oi zWN^k;w)C3aPVzU=avOzM=j^I5fJ<9chsSh)FO0^_mvkv(?v;;-&}8*Q^(Aw`~& zrO@7;Q7w8@Zd$e3IhaQ7Qc1~Y~TUDfs)I>o=EHzxGhVEm$+b8eo-cJ z%vCiAfCEX1BjLWGtk&EcMnwy!sIsew49u~}_@8d6$YklJ14UWlW^vFr7&nMV#{~XOg`Vb?+a0%|wx{Yf@QtWR{Xssb;1~<9)1!C|{QrSveo0h}< zM;3q9v-pHej9uMG(04g4%bRZSE4_-f4-V9Ha+TU;gnnG9w->aw^_9C+)>vh+tJ(T5 z-f1U24*MDpn{E)64r4KSa&xe@1@ogiR9o*Xjpp=X6_5C2NBURGmgoECJDT#c7Wj|h z39MbC+6@>0mmBM*#vPzh+h^6Lygrf!CrZ~F3F2LwPYKzF{IxDEnTb-9WK)r8>(ws9 zh+wVVu&27=1eV3u!+Ssf3UoZDvGuI+U?{Zko;Yhpna1v^micdct+Lz9N4au0%ysA% z@ev3A?PR1#O$JJabwsZ-YsMm^B`t=TniRa8kDs1A0P!~NH5Xv7M}4g7oC7X2n~v2$ zh2B^Tm3>0l&!Gmkf@4t(i3g3HM&J?~VQ+AqmYGZxTDA$&x2~tZ0Ia@lA+~%*_1uct zA#R|6(SXe@tEUFz1riNW?1i`9qyPv}kVW6-LMfU|=7AJ~E`6YS7XbNy2XYehxW>J0 zTSDH^7DJd!Ywa@i8q(`h3LzkCcqNcdE@`sn-eaQNzh;(G>dg7*IsX#G;c~HKx3lh& z!m0 zAdRW;XSwBYs*1>uQ9U$&ybC`XlGB^n3!QjYgzWeP#1Llts_%bzPw{a3Em*mjiBJrm(_p_}|Q#Y%r)nfawQd!=;T znBwJAwzLM4LW`lY2a%y&9EgaErlU)XAZ1sDy9_)c;z^`Jr;6nUQDCGN-QjkRQqSuC?!FbWkCNGEj|L?$UujyF$I6&`_@U)isfYsf z^R6)GlV3T2eOTOw%|lp~rRXp9m(h_cbE~o`@h{s`glPB~iK_IpoI@_gk98Lf(!bPG znEztE{of9t>11qg*3`EJQ)U9y>|;l|z~Q(hRlA0Ei+X7JOTn!PWZ!?`Hb;21ZPHs8 zcw6u35}I4P*cmtJaE5kzo!Ee^w|vLouJ;Hs_6S`-M6TM&cB^0r|1y>Z;QVPhExwd7ccxOO5oZG(8zhQaBr)^iXg;YTu>Pm);XyF3rxTOt3$IZQI2YVbo(~g2F@t3)SB+ zd>aWvf1uc7L>{N-c@LLWFn#GjXC%4E7kpSbLx)_n^XsWctWK%7Vn@ohBrGpG_L!{m zWN6vgBC_c^tp-&ly~|)YKv?*{K~7cx6l_4SdG1`rk>j&sUZ^|@INoF%>;5hMLo>xd z88`JV<&ksF`)O(CkfI6p%JB^OkTNpnET7IdpIm|*7snvf&7cLTVOcR|5sAyrao@WO z#R8%jPLJIHo9=6Qyx!VU0PlB*TI)?}*DHt*fbf2~8UZ5@&yKzPLfRj$wkMDvT(;XR(k$41J>uv$uqkpL&stQ6; z%PXL<=?Wx*K1e|p>!=)ia(^4s4is+q9d&IqDQs9UTm}#xk{Wzu{d=}$Q@qw0Wh3CA z?%oTnFWAHl{#%c5g+JcheG(R~I9&=GfKcJpb;aV-(*^pb`|V3vU?sm(;!5x!y}Ti!%hMZ&pvA z$)VjISlcjWW6Y!2LZ9Due6t8t)7>q5vM{0770$uhGge|nk{0jE>cUjOS(j0}8o{Wm zv~1O>Rsb^b>`(E{g4M9GiMjceo#cj5mgkGiswxsf#>jDj|5KvU%emyq+clFPSztLF z`x89C{(67a&+1HxGiM>|B4*uS&1)tFCS-`@>bjYjlP}ZjzA3h>yAWC6Lgf{{*3OXN zq)+h}P1ob~g@lr&B4biyu^L5tqn&{+6Y>K8F|Ob5;P2nt zpTc1IRVV6FN-4c==!lM)K~C`cuH!t_-6$XU^vqyP0?UsTSBcbxM|a{R_Q64~H_t zSj=ZlM~p;ZAFh*GwM5&V^SsO>lW>8fD3k`BwhTNPWbq{mg5^NaNOlXV781{@Y!=0-`JtIQvhA=0S z>RwW9*>TuUxZ9s9Yu&q_G6gWcH4#c#IY=D6GlpU{2&S*^e;(g3)$&w~10<;BiM-qr zi!7c`MYjysXkB*;O`AnQbV}!L3Aj1U7V2%&fS*9e${yuE4+y!u2~EDe@&73>AsXhL zY}ndzDdB>Jw~^OVORamLRo=~Meq@8)1zh>Cmg6t=66{^!yVYhP*7wG(Dot>XVt4Rb z+L0jGcqS-Lyv?Fl`dJM!6ZdZ3p>7S;i0J{-`Ymi>l{Mce* zsX6ZvgD&p`EJX}#JAC9!-oEp3chM|NL+LP7XurP$+Vj^3?KBg0ihpXn*RVDkHLW>4 zp-rGB8Yq1lF$J6TK{k)v^F~)XeMxjdvLV@IRB<9!=MjHOhxFTlY~jmXm9~Kq(cnuf ze#A%ibXpgj3JCbl>#pkRD(~69to?x_(?DbgF{;8@48EX5;b?L6@g4fV`F>59t&u)1 zkltx8exxn2fXhSJp_#+g0mB(8W@_oy3xU2hy`L@xxVJj5*sr}LD+F`mkw?P#ud&}A z_ao;pH*>w6hv3}%X+d}r5f7Ys5<=F-LsnDp3alpr<(*XKjiDV-GeJP=>;tuuTt^4E zq*aDrY_=YCh8C}lqvd?$sh?Uu3TvkcU~F=G3!9VI+rr6`xw$AMSb_@U#hob)M)ZUa zU9j~vys7;eFJOTgwHa|^cf7~aVBh9V@0{0uTyzOPZSoGI_8Z$;c{O@z8JUj7C6b#B?gyO~}Jycml*-D*>)^;kHr^D$RV^+5Dg> z2c6omyddK4CJMNbVlg27>?9{%x+0fk`9vKf6rI9`w&IY~Gg`$96OembS3wfG*WrPX zt*6kYAv=Z|B}e2-pK>Iz{aQAjIe=aD1Q}lg@(?fn{Oby27ns%iVIROJjfMtIF5&XQ z0X}*Z%K;FSPbMzIzu{Er*cj`ip53zRFuY2HFZl-=>y*^ZEs8Gzto)&46zh8lb8zKq z5DGk_Q&3Kj_`CwbLJbYa2cvM^_Xf%<*X9s6s+6Ipe_AD62^p%@v7 zk;#-^ktswTw+%STDLa}-N-8>HuA|Osiy>`4Q;j_cQB zV6X|52t&EW>q(aB7zUqjMWFOo2l_Exkqw98*X|F|B}2gKGoSf1;Ci-uHgt1uC7$)) z2qB>9dmgk^LE5BmZA(-k5F_mfv@!~_jX@`bf^MW{o><2*HzUC%ZJkud$b1+sKDsbd zm0>(~QehiN!Ps+(LtRF~l{Q`+gT`62gaUizTrShwDO0m6QY*kS zHiEav{K1w2IsdXl=GYa({ISn^>xIGbC$O7Ani>!7o1OF z9ewFul_OR|#TjN-spF$4ITbS%j6vy9R$=|D@~is8mNohEEw>-goeAledB0o>?jfHl z=?uQ#aZw_bXVI%25Yi>&p4~!?6vIi+`}4LZ3*|yoey960^Xv|#KS5va#sCas5p%T* zl>R64+o3h|85hr6?w3(l?@JbJiom!9HQTX|BHexkeW@7#FZu8PjsyHB|1mPK{tw^p zpZv$d%KksOzyDqSV_@a@?^Nyohy3>ptbAhg3I-E4(Rw-AYO^V`lJajD9iDhGUOk!^ zHQvmAa@~bL@%`CtTluVAsf>*=${XW-<@Gxn{tx|E`ZCH7>BWWSX$nS)>tEg-j>-h> z9}$rf5D@{Inyo#vI0E*D$3@)%Hb1exxD$Jdhgc}fPm~6qm7Xvqmfzij!#}zV);|rU zf3jzAa%5l#R8P;~@Jlwo^A8dp;IWF@UMq`KAWvUvy!WJsDA52}lTc2K5chfEyfs z#qApzKsf+-%Yc=OjsPOy`P+Sg$3H0i;BRhD0Mjtjza^h;FM7hMu6|@#8R=`AoapNw znj0Cw)6_Qp03whaU}*4Yoc;+p=XwF6tg|n8@1nM%sjQ--cz}L*+YtB!)iCrQ@^5xN zv!t@AaI~{9v#G3p7RFyuCq**{uBC-9t*!iAXl84Dvt*{{Ak6P)U1W!SbgLV)JKM9L zeB;xLvwyGXFiLCTqAy%iV{7>>8vMq*)AfJXrUPgJTuDhuW#McA<`Ds&=o|FEs{Av{ zfbZOqCT9lI2xP zzT1v|IYor8c>aU`RsRS7GyRAEQL*_a9Z z|B@UOdHo_DyxdOYf4pwU1OK!I27Zrm0|P4ijq0UEjy(Kw z{`|fQ|EXnV_4};&LAm=qWNU0`zW;I?9^>xn^u7x1{vHcm``(q8+3Q2q9Nrmy`u!-@ ziRNV$UYp%I>9c8ePOX0e$fVThOjrN13jc9}#yet7b>%1VGMnnd#RlMELR$L0_qocB zcpm%5|2e4nb@}5_J@=7}TuWcc{BH1|y2AMFweWLqv{bLC;KmG86OiWXJZ*;eKZw;k* z^VfL6e(%>hIX?rhh=xD#Zvy7`r`>pLX8Y&*_xHBH5pVV1Mfgi$?w5Z3@XxHj{&){I zzx*fg4SwZoe2Uk+q<45f@Xs%Pm43vVzj2?3PjG%)cry-fYqp<$&9{eGlV@-6Zv`iK zni+htH(zC6dJtzX@HSU?`?Gj-$9`1a*z@b7c zo4-W+K|{}YcSU@*{|^4M{p;X`w~qU7`jqQ8^t&#Gq()X2XScjdcQV%a1OEGM00PA0 zPg*|({X*JJpt>u>iE9;dzjgjf`eruq%Dhy5-jkNYspCf^SR%h_3~Ix^4P6%f#jm@K zSk{T8N#Oa+YhmLLWhbR*>-XZpATFP=V-=>8If$K2&5c-#hwnd7riQff>f!RV0MQI) z2YQ`KFz4cYET}vw=H+~w_Ee5X{>y^eT3^myZSM(#oR&N~3J;&~an+38M zk_(Ut_PhveadYE~%3}7ABTgECy7I~#+A^-?l|=Glv13)E7&FoV9tIvwr1m$39y9% z;R{i*C~q2dn4>#B)NGeI47^HVw+58|e$udXz_@1gg4MXQ2VwUUxi=>r1iJR@@tO~E zAjpQ6v+}wllsY5z5}?e8soLGx^O`qil2uPi?IfgLFOqVl{SwPK4sA@E?%s%HXS4}GD3&m zOs(FM6y-^nF>Q@vfv|e>^Tbkr^tO-9TwynGyunz*{P07mjoW*?gt- zqNi;f&!SjH$oF_ON$h*^zWBE+$zeYMd^h`XUn`zcLd{(+4!~O9s-wpT{921Ue(@3Ge6DPt)&7g z7alVcHETom>Pi(eT8-X8)b^Gj$ifm6c$btO=YEMS(@#`<%R~RIuUO?c4%M2KTn4zc zFGyt$goA-qHh~A`&~Q-=c2hs>rxgdSiYNkQ9;+Vmm?Bu$Rb5B4=e&ky9UAh)EH|nA z1+HJ&T#AGOcNEJR5$St=Iw6FKNA@D-V?Z4Ov{y&wZA}KHCq#_K);Ge&Mg~YLFRA(q z!M@9V0Fl6AXR84ezJagn`NWu)+1+c$zh5HuI#b8H4B5O?RNfM25XzUnPl3AXn7k2F z)o1*Gz{kK)`R`)wbuy^04J%c&=(|C6Gw@$mTD( z?TYq7?!)!cN!TFU&~r}ku>N?vgc`Z$dqBZfHz;! z4CHL-w@c_S zKRZ>Im`|JDjH5!@Nvy$SThT(qEC(zIa-7vSK`G?aZ8b=K>g%$C66O+tYk?*b7X*6` zz=6L77AEy`___Ag3if;NAZNv2mCsb60?VM5U-I&+-{pJ`MkSIb^F>&}^RlxcLcS&* zSK)0l^;>?K~#$rNekZHajk`lETWl1-u|fW-9k#&m%Pxj1%#-dljv{Nj%3S{F@HA0C7Ljymp}T!b@ib^geujduT;QXu=X&xKm+NyU zB2M@EUxuGHdK87caJg5|Tk_%%EDkk;r($A=3th31u4@vf0MFD?aQ*AKamHrKlFG+u zL=(=?zF&UCgOKH-n0)nJfRr0*UrL&9Tu!P%gPd+gExk`t1r9N`U>@KcCbH7z#fYAt zawdfzz(A5l4o2HD&l=T9)d(&d^^1$WM7xt`r<&4pTZ?c4qnou&NrqNerEWxMpU7y5 z>&W4mpqUxH2GmH{?@2CLZVAc3A50tYIO+d+AHoEuaUEcd&jL{d#MLKfU8-90fMjpp zvwuYuW!yj1t8;yv!4^^kLZsR7&n<{}a6r}l^0Xx768F*?k;Ya>QA#Yfd{t(zKNQ0} zwDT84Diyn{QCNLQL_d@;-D12fJ2cO%f#Gk()nCcL+LtK$0Es;F!n2^L7}&S{3lrHQ zV*1H59Rt5ErG+7ZOdD3tyL2Y^%c`x^Z>gXOf>nxXn-MkD2Qytok05<&*hh}1S~{&m}|-wowFd146B?0j^4yg zCF+4E$sp`m~CHK6Y9Ev>#0Ze9Mr?eH zOLsJUgk!^ilnK7~Ho)xfk-DQ)qiH0yxYcsNW)=WtNC(*S8|DYto>y6t-)x$dntMv5 z>KvWr3Trx$O>)+5$*k%AYDZbnSyDw_XP(ZbzL&Pef(@qht?N2woM!i=^ilRu514iPw$wcT@l(p-G=waA7~gqgxf1I{IkC7H!xoc{yoy0Hq;xTY0D2b}{1pHucAAKmzc!|vHP=3pKz5}2<`2YTt>QMGZ zizD^MZ}XmUh0!l9z(?Uaqd?wlV7Gv}-?~?NM>b0}#>~6>HvOC6h?e99DgI+?U!b7O!q0&}_vK)HlhsPm2?^%A9RFH`No5{U>iR z-C)V|Pf#Va7^(CRNKhG)vB>rM{hoBs0shFPFB@TR#6jE|0gkAbZwQtIh6BxDB@e^wAAk>dprgSr1e--d~el!rkcr1zGSDl`1>VF%6eP9Z&D zXaY|w#lAY`8BgHU@Uvq7GX2oP0SIzo@J+S9Xt~$PoJRLS+ORzcC#4uMQ)EV+`ib@$ zUXY|phwemMtxDOi4cRVCtPsPor%vJf8W|kBJPnljRb7-T0z9 zvs39K<3UU`7s9>&74Yf9 z$dw|Bhhv{K-xRo}lW+}qE%ec|6ZVcwC~NI|UiDU}Lk#B}F~j~1DRk+wEcIOq<5>~D zKkFDLzph%t>1C!9;_oTB?NXwiq5b#F*Wa#y---_PI@`rm`>tial@b7}IQmX-Qa6AF zMmzLj-l&!%`)a|IP;6lhl8Nc%b~Z#G--AdMHYwP@G2xz(TeT8Sx`a{*h#)$+9NSHk zejq+K{kNi<4Ug5)die9ZCH>|)N!G)bdG?cV&i9bfn59gXnre! zYzKj!f~I-%ZXPl4Mz0dE&CRNRr!HsJByH-HF4|C21o9iwHaqx_{liHHguL#{we_U@ z;Ihp`)IAjKudj)@7MmjxirUsA8qZSfLeA%K&-O>W`bu!hK8Ox5?OR_~v(MkUUg%6E zL0@Lf0Jk5Snm>}AEy7Q+!J_+^duUQe#b`y*iOQH_$Ex8jRD8^KW{n4X_DXYx3Qw|J zi&{~u>-8m9FTcAPkGpX~Tm+O&smIHUJi3vUO^#N$?`xj=p2^@z{xAoQ!XF?h&Xvo& z%S>1XK^uLk8U}_#2PP{FJ{A4BJKQNfqtbM{++Oh`3xEqfE4+bOHRS6*Yy(hBhh$Xb z*Zt5H#T|la=-C6C=(fBebw}tQRhYvdcggej5d3moD!2dKuuAEx85fn`i0Iui>3-=| zTf+ptNF;N(_UO^;b8{1M*!MZCtrn`nAxTQVT?3NZ>?8qkYcR4BYcn9RBeNxiwS!ix zB$SXZ`l+bgXEKCcjf)lwk*{71e6`j%BFE+K`4L1scmSjZ9RR?HE{_796fp?(y2Q2P zE!oG@1AQGwk9l+(mr=$98fv}b4Ch+_xz#p1awsZt5<#q?#P7f?H^DQbXB$9L$X?`7k`lz-JdSh8#3a^d9jNi!2FwZQrk#kTwA1g@I&W(>@k3hcz=8vmC(+9K#3*c#*jCAFJ3|iVg^9=uBi1P;Lk!7<(%X~Y@!mu)y}Y+ zE)I3kGly_{dJWQkVVi{ud0XPh8U0!PO=zpmEXf(5pM~@VWFsb4peZyhZtc8qw&BDn z43~|PXXTPTbjwLCWU>=SW90R@)AsMRqJTGKleAs1B;=CTN~zm{gqbI@fG;)Of8;2v zqk$Y}{V(H%&uu6J2*ZlWCXL{>w`?R0^pq)Z{yTluvEwFoMsVXNY0S*IGRTO>EJv^3x*b3iQ?LSMISj9Y_c(4ytN zEM+#YTpo&_T6pD*1z}&tC_@-n2kxlKYGFNk++Mhz;uUB6dk;q$$ADs4U*I=7eB>F4 zhSLjBz4CZYM!CDsGxH_0ybqZMs=FyYTlW~semu9o4-PM)1c5gO>oRAYop4{2&GMgD z(26NeXxMFV%fePH?31-M^0WenZb8kBv``RI$-CvT!^YW?KJ%cy8XKy3qgpDVi!M3+ zI#97!4>QGZHJ|;7wi9rC5!`(plf9_q6&9&a74>$z$J6{xeQuPnFhjgkx5Y$Y{9HQi>Z7s@FN-t(U43xnfFL^cC;`8dE2 zZ^jwtV){uN)gg61(4W8S5U-fR*!m#+soEfZzBCqcC0xuoaH~D%C-rd>TvZub7aZ0j zD8B=sgdBB2+(Dt{EAj^v$o&;1NzifFuuv|>k(Ck?3$#SqAJiUXL+*fLCuEWcQd{-c zSyA;!cM`g-xU%gUS*N^cWmRYd1Oq#0KGm9n9CkTmn$OUticN_jl*lK;KapCOR-v8& zCOqV7pf8gmz+t&RLJuWR>Uv@(iuF{A^>vRlWfG)Y6BAe*4BIZQ|PjlSMh zMYtB5wYj2D#cGqJ>e@=Ka>f;$U?T#2l^Z)-LxjsNp2srqv$Dxui@Pf`n1ltTnA;vJ zE8=2^6i;x+o9;{&nH+y^bX%W~{ifY{r7~N0Cic_p5&X!=l6BnHr1PiN8l28Xh?5_e zkc*xjek>{}CKSH6lQ1URfp8?FUASS` z3!@A>&IcMrr{?q)FPylkWq8%SvCar><)71bl9j9|Mxj1t4lso60As*Zc-4mFe<=j# z+Baq*+MJ?z9$Ia?W~gX!>#oHe*s2d~mR$Q~mFU=Xr~CrfcPd<3YcBqd)ta>+?mo@~mCaC4>p9 zdFwPc3*u;BWfkJBR+5z zgz}rK#)DCSq)fZ*vxn&qVj*DgnoiUi|k*druR1Cj` z?saB1fEY>|XbQiCc=L3I-z$BHXpLWSt(~{s#E8=)B(j#X6Aj z^|-L~M+&{V^Z7}F17x%|0tfR7$RoIfZ1Nu(%~+5~S#GN6*%+R8;2cTZF=cCxp1sq$ z&YU&ypO%L_Ht@}idX>z{S$rRDoGy!2 z@A>W&9)TCp`^3Q5>DTk|gbp4t^~Hj0IF(dv9w|nPfQT5oT8l6#+Q%_BKxfhRnxn@l z=HtHSb3aGb5^I0{aF*UO{p5@^< ztcu|8dt3fLd>SbpnZHqayVlJHeL58-t<%K!Vm9bx7AJzEso`K@f9uvJ+oBi=OG6hUTJez( zMU}!Uh!9GwHW(B=n6V9w7Q5)*&xq?YA;g1&>#(BD)@rrW;WNCZoZTG3-zWu#hzYXD zJZ2_QhRNx$tt7v2G!&}vD>ed72Duw`JG<0<+;TX5UZZp~#Rclr)IbHB+(_q6{@KEM zUB3HB1y}f2gSaT~KY#k>^j_*nLdJh7b)4E-TqKwt7_U(heqB-Jz*_YXL9YMUh>6Ns zgeTgLmVmm(M*)(|xdmhPE>m`RDNb!z%n{OmYYVyAX4ds(ItLY5qxr$yrF%NL{|w-| z`t}Q(6B4~6-DW1M%w{Gwvri6lRK0ehjPU3$^p^uFmX-@I)#oD@c;vh?Ibja5j@hw* zXXmmOW%*1_QBHdZ!Fsr_$Sv=`mAl(JTOPt4Bq@B4n@{mDAx8Cm-~dKUQcitW2ZWV? zH)b>4bnWvpLq=(o1$On7@bo?KOnn^q25o z4D8!LM?KN0Bj;#ThByG+b@C+iiSA+UT^eEg5D}OtDyH{(`(CtyB&tRv(4&T!Bq*Pe zeZmiYn}C+0!tQq4`C9HQ=`IG|k_g19lV&YsCm93%rnd7?=ohl1JK$B+6c*OV0mGYN zH*!&ya#ZA?auM)YSrh5Ir>u+Zaj=tFfDm$J-$~rNn2%9wsS}>@`c@u`Z{rxJy^|e7 zOg=PIA#N{p8{T-o)wZGzWoe1^r`NYrpC*6l?foMuFYLBaeo?@s%J?!Ly_SzER%Xz)KUb7;7*oRGy z;wW8{4S$I_#F9Hnm%ah_jH!gf>&BhZ;l52#Q^RA=Od~R8Ae#1K?h4Us?fl;e zJEtCDl(5UTZFj$I+qP}nwr$(CZQHhO+vc3_VkVhnlBv5VRX?CAwf9K%*iu}eEr?A1ByGP$#^HE@yl4gPX0+?achPGGM#VK(p8B&e zgps@q3h_`o=UD$89pw~CxP@T~Lu%y=+Nojk!t&)oOraxh_z_9mrO(N-Hn$%g;I1FF z=QTh?&!!;s*~T()phJg#%;te6{Y-NSL`nXAzr)*Z?(f|9YA?Jed`jdd)y39iLQuNc}T~gf;B-;CkQUBldAh^7D8z!B)e;TxiQ)- zmJhgCxOiAxp>?wEexo=$_?dIyrM z(J4((Bom@1yNw!|u148+z91y-aGIM#xF2=uDOL^dqI^a)bqD@{_yaweWtNK55I6?q z4376IjM+-Z-mex}>lzwi`xlMz@dIm-Y)h6Vb^sF3aq~nLqK*}jT>+5j0UufuwV#No zL_}pombrPqBkHM9W08Q!yk$7;xXQ3UXTFok zF`$vKkh9htPa9t}-eM^x%`Y;0Dr=`}YW+y3IB~MO8kf%0m31{vY{W95tI)&tu$>06 zbkh!*QHn$Oe_}uHA6m9FpckZ{T_`<@mI2-uwLm~k(9xT8A~R2VjpNK-lb7MfAdesK zf-;rvVT4!(=esiZ^I76Q6~)h2I$bz5*wMjI+yg!6!Q50Wbg>LKLi3{IEd|VVEw>~< z&@mF4JEtQsE_Wq#aY=X=W{9w_qs@kMN~vUMOeDk?i7cm%3f%v7au3l~-2ic7^bm1` zUEIYi<&i+Vj)ZT3ccO%)i@Sf$F*ahCy=VQntBdsziIS}G!u6NA!#Kd1*&zKV*LYZP z{j%g6QLTyOtMyx4(VNjMnS2rz`3|Dl1v<%`hA}tg%u{aRBU09Cv{!KRxkD$>)&fw) zGNOnV@M5tq7Bx|gmQu?pejLEJAQjgj(b56-og#mBRf&L<9#Biu-iGa%Dr%0GQG^29 zd=8wfQ#YqyNN7*6(Y)FT=9;vMXdB0|_IwJr1|GX{^G4Nwy?_gJGlcKi2<+jEQ}_6o zhb2KB3Cg&9%J@+p_qTPqb>%VP{1i*Y2=#)-8qAxRHGijIi_vyc8xezxEHnSHr5X{AEI_3Q zJEyL5?(COWRA5WK*FA0i6G(1`RUyUj^5(Z-zU}_tIiCXkzA^tWq0gLZzp~{v&RUR-h*HYX?j)D%<7es;}S! zf3Dm7Sma0a;SpNj81wgQI1@HAxH8y^?aGJK+|H0qz*2k!SmVU?tb~8Dh>wZC`FuPU z_wDuvjFP@tIK9HQIIEzmKmr;Rr%nqR?|RFkZapzD|f?gn$MofvgrzmK1enTJCgK6baTjk_ITxR>6R zeWPc1=dg`FnOnEZ>&SjgOE?yE8Q5TMXEW3!mgxPp59&{~(@KDPiE}doNMQ7zD>Z@G z@qf;5t(`)**Ka5NG;Mutnc}&$(CGu#^O&CrjU8dM5U(SrTDL}20JPpGyHsq@jX)f~ zZgWJx5e&zRO{@bNsKNb3haTQjeUTyA)_-?EHfk{pLRqWC%@PT959f@ya^QSpeu{&Y zN|~#yWJp>itqE5dcXMXe8%Y;(xcMk_Tf#k(>66u+!AH0tIah!D%KFIoSLIXZ+3+8u zVrx6V>~-ov3tA&JG{8-M_L6j6?|Bw4K|*$Y$;MYk-1CT1gvHxq|I%}tmFfu==m)p- zrm0>VIM+z_ImI3pj>;toTS&-%s8mGw_jvFy=@7mcmBbdWcbz$&I3|3G>5Wd}@*z7S zT#rtps8=BlEC-yfOP|8jrW^iYCEAhx2n>}`THM?|q5wEpe zUU-4o7LzD|d%O4GV3+cSZ%yKhGmBKZ{ZI#lrio>R*^AU56%Qe9hwH${n2Eano3Mfd z=8W8QVviOmMiXH09CGLrpn!O5to9ialjiI_{4YIq5nuT;V-`&jA=^!m#U~C}4o032 zVS@yOfttT;dl>GJhCp+TqKQXnU)LDQ?n} z;eWJ?w<^j(U@Rd8b>O*M`1q@N=9Zm|%9ShnrJfzaI*D7^^0|-V^dViNmG=R$f%OS# zUq*hGil~FuP`WnHL~EV*)fV3g(|zG_@9ZyA(TP2$(9Bd@Y(91lZS0M3jpB;7K)yd zuz^n!6agPeR>9C@$nXP8;#303j3GWrSLk}6SE$m&8WX$k66i$c8f6*PoooUMbQD-Y zFn&xBW6Zs%Z$XS_yg<|My)!Hu5>GJ%=%_rQzsYw%s0T0GvMQ1AX4`#uUYbAb`9BY~ zJe6uQ5X|O%kk3zo!!IZJU>a&h+{Ath!p%1b$~N8aB_2-1Vi?{&P>pBpJzTJuG+Zi2 zg1lV3Y?fC#teR953FPUr&0h~B@tW`ip~V-U!w>ODkO>ea=jLYmAa6o6GpSczUhaJE zfPNg}NBGH}0y_y=#CCf2aE`o6!jqd-6_;C`)iJh!pOUv^5*gr;mw20j;i;0g<-xt& z3QeA0-JPSe0e$Wa-ea{ni#C|DlD0y)ZOBmEjvTFq5SIh%UZF|Y*GTz%HBz=_1!_7p z3e<>r#3H$M4>EHk5yK+AdlEPWK^hY3^WgiN(|HQa^^|@o{4iYLB??eJn~69xrSa$v zu|L^&ME;S=9+wR3Or&atDKeo7PVfuPyuv&c9{3H)#r99IF*%Xy>_~x48yOOqIi4|o zFzvNOcu6wBDM%!jtMd7{gV>u;^;X5_a*5%yG+!4y3HYyp>{;pWwLr94cV$iU&yg@F z>K8{iH^~pCLJB8T)|c|0dq^gGx&@ojjtRxTqGq54y80`(Ky!QO(I8gOHOBy;;2!_z z`dExcM&}!#P(=V=D6d?vY?rAI=|d%Je}&1Zm@uoBq-TfV8*#vmLf(5&fDU6yx^ki4 zm|m%Za6&Tj>TPN1!kjk6|JsB5e@H=}4o$thZ#@((qaP&+HGxH3SggN!I7F5bb_CG} zB#A}Ym6fT&8)BfNlsH};r=w;LpP;P`OZCsashV`7g=E4lk3NYO4ciqOA@Gt8d&U;T zkvDbxmV@BFBUL+jSqVw3Q&Bx60K|{gsl$j;JV0hyaAO+24rOQ0bXK%gkJnWd-q~2a zk<~ui+#0td9D`1mc)#8*g1$^3E$F!1Zl7fvYd=2vMN4wu~Vf@4Xk+uf(YpcEzaU_DQ<@Yx`y;KMn?AnUeU7-9l zFh|=1{_2blG)X2sBe@HX5f%@<+O&ni5fK{k!0qHf?EE(&oT4Yx9 zDCok)Mf)+5qJG%?J(yK=jPQP{9@Ih|l-`uAS7>5TvD?iVgr*=qbbG;W{V-=6jP!iZ zua755#MCHrweC}qgv|rx&SU96=Rnb+taW#3J1ApjJb>6oQ?E`{%$`_<=U;qbg5eo4 z_2YPSKtb4wSby&u)$CI@v4idu$g-e_f4$gOY3?2tySi@=%M;I6TcGz11=C&L|vlizBtWeq*G@fUr6Xip=qgxm=^4+ z2>p4v+De8cPwVs6#izwqxhn((+C3v_JZ#9}kxQ?Jj9+BK3ujF8juIFo# zClCJ;@A=w;8d<=mbRq>`dAE!_imjG(0LFIUoDGBPIMeLS;SonBiwx8N%5wF)csFJq zs_qZn=tN9xaRZs zx!cZxD=Iohw8)zTW731QZ*4e2%|u8x%;fBxV`f44iacVr3_7G2^T9 zn@7ZPtv4~;J`baxrM;CR0j1{Wovt%1dXW6rz=C`tq6uykOYhq^Ze#@c?;}?qe@U1@ ztv7XhUm6FtZbv$FfRZ)561TZjDNB1bH`!r23*HX81BeESd-F(Z)|t}GDEN@teZ|G( z1kXurOrd2C;T9BWP_*O04nWy$)AUwj4sJ30W)|m{e0aLm5olh&c-m$Qe#^w-qluC3+k0tFbR9BDyf`k?<&F8^{h=5B7_IE^Qdjxp@qmO zyWB*oT>Gv*^3qISRW_q(fmn+*)KxQ)UWn_cMJ(Gbx)b<)cfi8}f72{~*7AtA<|uoy zZd3xPU|zkI`}Jz+z-KOApWOy3!|Hr6KFIQjMH*FCH&uqfzmA7qykF0|#d2H)^aI|{ zkq3+V?xKUK@=OgLNzeMJB!+z$tYlaBHjJr*x8#5!fn2w$(c~j0M&^J*`RFqjq{(yr$klm5Tj8hu3VRyqUgMix8Or6{-T10Be zrVdAFx0P)!o3IWu6GA<6)AMrJFg08k3Uc?TYxAprs8Jw45Z;GR_HGP>7EZUbFT{MM z$&o1E8jaG=Hh^1}+5SiJck7j_u+TP3ws$_>d*lJ8F}rNPY{0}o#n5EE&ec~*WBwM% zz(j-xlvP_Vugow$4eE~T9G#>xIc&xC#_kzkr2i`2K?9ls)7K8QpG23P9PIT$%Ie^>?=k2coHJ2d$`AL~&8$z`qL`(Q5BbF4m zCF_NA#aREf_V$|@k{OeoYt_^J5^kv2n7@d*H8@cpiAD1wVg{y6LKZVDa0`Yn0T=Xs z6*umVmXaH%fnI?+DqxVt`&>H(;LC77EQOs!SWmT)$3RSJRqhAbIc^6ARbN|mjEZ4A zqSj}NL?SNTDx$R5qk-N9!AD}$ztOa`n6<_9B9wMPYLsG?cNSCDmHQn}| zO~ISfKhm`{T3@rc`$NVYFX*xD%vx$0n^q~YxBWv91S`HGLzN-O<31E^TBYTM6q|`w zrnGXsU@rtJ>Imfpug-n&IHNR_3hb_S4N8Aj2k$Q-F`E^8iJQ;9^4M%9=j43YgmcbV zMe1PU%||`=iIv(i-bHYKt;NMC>$g==dz9xY#6Z@`(XK;`PNPIKOqX%*5>69TDC1$^ zvlZ4&Fw?5AE`lQL&#&ciBM_D9__Mz1-W{PGO+Yr)k{J~Y-j}xBfW8=dKDkIZXx7aT z6J>{w&6vnM!L>G|iiyA)-LKKmMP55@wT|vZZESUGSfN)iSE50X%io{;_u#LX5{SR=FPC~PbPh&UTXeWT(@sg3}Yu7{_EMjlLt|T_+sQT|UZRQ1B zm6V9GiHLJZK-C>Hm}qDSxe_Wn!ISE2%<>Q9&7nkNspxZ-Sze!%^9aXJDT62AYW~VE z`4Tfso}lhL0s4&yMb3u_Ger8y$}G8oCq~g>_WFy;(d#lq{Pa_^fY(l;!brnJ$Nmd~ z3nY`y#arysr)eY^f9l%djr@(ip~lRP;VA|t!0pV%ecj8j2;+FT?43ywKnyP4ihzU=4%xe zbG7Z@Xo3`zt`KM1+Q(Lb=~1j+6J9q=q#N18?{^Ht0jGW1jhW!iX$Gj+eci$+&`TM6 zYz&xB!8lFrL=baA+D}KbEr|@h__Nf#97`tM34{VCHJIw~e9vHT{=nLK?~1Q+Yi>0w zW>d9rD;{wna#kEsFsBa$W*uq2$o`+D;E!hb@_j)tfu4eWuj=p-hrX1$1c@u&2n>2#9rvBo=B+59eBxWH zu)=$}GB1inS!yH@)(Q;R@WA`nc(H&`>w@f2qBJ6eQ4mn*7XtcaoKwU@19Eow`PycG zL(6E;S^P+rQ7UWcl{zvJzd5M8k^rpW*o@2?VjguCz!{n2*#raT@)Lpf@8b(lGo=#8 zY{Oyfk%Mn$O7{Kas@t5-L+Y!B7`ClTvI_y^b0?2-X}Uhu%XL)NNjWwncl|6*MEyk< zqAunn5FAd4ts{Mxe!yY7;l20#%L&b}M4X<_BO)cJp7?(+Gl#r&KN&7fIUVQj?d+3N z1l3L)k!KO>A2_jp(8MOGQ0!4ddIf2^-y(bRw8Ng6^D=4TI>}l5wS)gG`uW3Q4Ce`# zVg6(_B21>%Q0A0FVt6y`8s6(A4=XR5lZDSce^~Y}SKzJ;x9zAA(_Fx=!LV=G;B(V2 z+s0Qr(wU~Cy1qG$wjoDC-DQcQsr^VGEGWx;#T?rb+2pmjOV>#f9#Zayz=E3m>qdl_ zp5)XtvmoP7Xv`O%6Y$Hw8oWc2tkY)abf-nSoQ=CPEgKNtruw30tPlRHJd{!kvW65s zzu6_#LtWPgNs**H?ShPne`OMH)f>yBLv9MBBW!kG{qBTh%`u3leZtG1w z$rAmx5Q`AnOZFq4O}S$7NwRwX){tE#Uzt4#@Zp@awY|IKi2!VY6hFP-vpVT+YqKl~ z7n3*7(+$Nk$r7YE;4E0zcEQG}r8fWLtrwMv?@WuDcG_6oWpD5y2EmH`CAURpA$ui_Bl4TV6h*`%S=N+X&=a4jY z+aL_}r=!}&cdqw1(LiMb`j^xT(#aw0L1}%nIj64Xx9q& zJQol&6!bvL-Xa9IDPi#sDOT^9+sfuAv?A6LilZKZW2Bsm9xcCG?>0vw-;x;I0Edb% ztS^CxurA4+fW98C>!G*Zes&3QKmoi8>d2jbeI;ilH zOuW9}*9z^&%cD~`BF>$-d=X4UgmtyyJVf}gLgQG+k%ih}>Uo1P!0Pu$yp`lCdh&C< z3_@R};m6aAiPO97x{;&e*E4kJDHQsgz#*_)bwW;MW}j_tD#Z!pI(xbPxEbaBgWPO9hpzbQR6XBB*&6uKNbGn!zXX9G*Z+bi*RZV=>2Uk;<8maY_b7qZ6g6U4 z&4(-tP?K>*Ad+C}K(yO}&ON$)b$=nT($>67@s$kVFXoDu_s1Mo)18;nJ{O~6QAcv; zC)`16?76Y~E~M7{ICYM70P+bny5@cJ z#DDOLZzMuJ2XAr1?;6bK`pZ6QR~ES0Bt?y>n2OWTmc z5Rku_T8-xj&uZC6m`|3IqSV`9v@Anu#xu|(zB=isHmkTW^$+&KA)DuqR>? zg~=@jja@7YUa~t#(o{Pl2Hw|JSDjoemNjPA2SKw+U2y#4b59f4mWOS$!oc=OkDA1m z?@-2kz-yW}V*@VI2iXsHf{j$&nMz^#N${}YYw5xtJsb!aErd%hTX9~(T|QhrPN}bWJZ>RJ5+NkAENPoL^T%R-4SgeTi-FRM zBxSEeIMD~tDcMEt)Fcu&*#HbfNLOqjRPERGTN4mUyICEBs#rp^-WY*)?(!on(M+e1 zfk(oA(4qaRz~I40=$Sw3@|lP!{cPzOzptA@D`Qs6;)cL$t?|;*f@rU#9H9P^6WG$s zNVgP36S{AhysE>4xbDvlkT}C?#4}LVTgUj2Q0dyINDa#tT_l@bIOwd=9sSQANKnK% zsk)<3{C?rkpGC*~n-BLE_#%ftpYF$}Rn=S1s44dxQe{D)19GbS1?6h>09>aAn(a#1 zW2*EQV=Z6BY`j%Ad2`9r7%KaTFYZSj))tkptqLLf0-blf|7t`(rE}Lnn6Jv_In+#A z?0~5bAFwzS56ihbBX-GI0!Q2Z2HcmHQ zu?JrDBG?GcoE8hhDmvKPsdv#nGir{GNLjwnHfzZ}^ zv(A#$u}#G&hBAzja+NI<0x2=8Y0Wc^1T;i02wvJqw&M>jovR$H1fTaygsAYvJPWF^Km;M%aUr}KZg_qOra!yP4QErdlB)iT1 z_B9kx#(qPar!uudp&ORd3I>g&x;U^^s#uSoRxr3N*+yS~F>&Cpd?>tR9ciZiVD7ZJ z%({xGwSEUpj)1EfpoJzQpOVbt*ebjB?U09Xh&D48qv){?$hs8)2C-q_~>&O(^G z!WTXzhmLFX!Jx==>)op)qWM|M{<~A0jQ?l&9mTqEX`7$#&q74v&9UuYBIy{hdO86L zZFF|_3eT|dwO#Yo|mjRh=A3&r0=~4>rLUCp`yf+a+jP`^@s2x z!Fr?kWKu%}jwnw*^Uv}bn| z{)$9yZW((EeO}}lkRpy&%ckv;x5%B9W3>fLK?tL$S8RXGOwbSMy~J2xOb3al9~yE6 z%=h1>D|$s-6d?h!&_PfWO;L+SN|i7^in&^%g1ditugmmkRPu?Dj$!_UR@G2&d3Wu! zB%gVV?0WsuzudS&9UD>lkMXwxK>4TKzcg-7R~TPJWLGVbX?^$&j8b9N374V7-{%C^ z;pH5SsyYi}OILMX9_n|=Qdlu12Alex3|wtQD`=GE^|*w>0-u;na{CR+M%5Yx{j!~} z19|B~CVA`h=R-k7Q_8#iO1yeT&)T2GxXT5Gqe8HXAjfnpL_IOyLgszOBY|KM71(BsqN+ZkHob94W1k_7`k z11mej|DG7}IoLV=&-8y`E$BH|Sn>a7{r|BRG0mXz+E++4(O!X4`2G90x3@^zKpLIZ7D#MWjVELnDy;$HxX|$H$}jMN0ww*ZqI&^ykn0va<-~LHB*+jI#Rp z*At}B!8{Br`EURx=v)Bk@cvPH=~DdZNyz;(6BN&Eh?m4L@t~c8`~WPj{*23j*U8OAtgZlDobErtH3hNxQ~Uk_cCb61bMo(Y`llHG5%Ofv{~9#`4FPy( z2Lg3xZv)(G0j%!~W*)sEa^lAB^JQ!I&B*DzyK@NQ0H(^t`1|0e?w9ew(3#~^VE{Ne z0)DywY(4Bj1Vupu1giG~oa$4B1CRPO@?{L9`W=>`+6T4+N3-X##zXgie7((OO)Mn_ zgf!Gh8MiUEygduOA` z!Powo5qu*){>+z`0p`YGh5Zi2oNBe0w&Nn`(} zRl@%&ty=0M43GT!^+?k1C&?FMS6~1B7pv01J%j_Z;MYf6^|M{vQ+r6>g*yaT_2(4w z^>YWX*3QoUJMv1*4Y^qw8~L~x{B;J*$#aJIIKdhbBL7BkuTk2jnLs z%LgA_;^ijjEqifaq=mTt9UBB@U&qO>FGJ{8>f!~EDn}l@(>g^5upj?s{fP($z;^t@ z2ebtUJM^1JR=U9>em`FN1c&7L@c$E#)1dwp=<7NL_;{0l@)O_%06*4~ zN9Z?rqkB)@_~pBoaK@hZ8z{@f{sYZZ#u7po-$FD7M|+0l*#WRwYLa&WdPKdUe8XNi>alK9<$ zOtk8OZaK50yX;^Brx{*Od!9vhZV8?gO_Ap<*io@I$?TNffL_pT+Q(N2Ka(~88KX@E zjM{ARJt+;{Wyzk9?6bFwklL>bcimH{_r$OKTO`$Q89RC+e+@g0x;xqRcBw!Lb=nj9 zJM8XkZuuY-Xl%1E=m%nI5yrLZzxHA2v~aSpa&PW>8yxDtO*^kGqLdcgKSHNkYM^6M z_2vuG>ip)w6dCMe3hVwU2tIygwlI`~dzDM_vk=b0aKf?{Wz=OqwlfdVU>xyL=M{?f zGO%kRz1>rv4U&n}K5cu~*00!#9Ecg@^G^gm%^Wr1&mqy@Ez6wlEs}(YdpZ>krR?`# znuOi!nu5dhO=oBY(LrgRIndry{D^=p6a_jPocV=$mKo_~D}2oj^9Gw06Jyaa%YU;z z@t^`H16TatL??|B3*u+tnZL75N(z^2`S^8eO4w;+LFIQhz}iH@Py&h*6RYixr3>({ z?!OBrxzqM3&(5hG6#>Nx*Nw6eAgu}PU9M`bc~*r7AxEG4$FTFvp~_jOFIpe27ww8E zJ&0jjUV92-jHqmj&*v=fU~145uCQ*e}V9xODs2f6u-qH}CnDBY!(%h7N#Osoj|p z2#5GnF^wuPwPE*?AxjX!7^Asc)~ZR+yV}C!5V_r6(n{Uyv=+v7ASa^uf~1q)=j~kjLawXy5|FARD9Vg1l=T}O^3+kEz-;@} zopYhrJKw$$y2B>zomoJ~+>5h7Vi6?eE=6E|(Eo)`&O^eO)*r9o^aj-Pt8<52eT0u=@x zgZh@`J@p)Vd2Z{p;@FX0CPiIRa3A-ubOKH@Eif+4fh;tKIQjsq3JU|GKq0r$EUDqe zo-FF#h@C3%v5a^`t4)|xtio~UqdO%IH*{73_9}%sDrzk|X{A~hNNQI-j^%g@khqv# z+=s16hkwHRfW48Go+3Pt;?>;5HMH9V%Tfte11l?0g^!7TWs^wvkQeg>|C`j48<0!n=__*5^50rl)h^NjN}l>B0h-%Wan6YQ~jG<2sz%2Ien^%NOzp!n`-pY*$kFf3&7-;Ewiy9 z$tzL}IS|xtdrkBvPeLoA*6a$I=5&+p2Fm;OhYU%)%^-X`|ETGlh%Fj)KH50r^umiI z%8adA$bHhNqgQ9Op;oOrWGd2-|0T`|KhFV1R-3=JF`aDsTJ;i@k)2a@~jc~Kug)J{$5cQ;V=!7gbT&6Vr zpr*?km@l!H@Vic2iPl3!1!hwdN-sEWf<@}q{MS1nR1%EZdo~#?L#S$S>b@kyd#FTW z$xfA#6NY`6*<&T0kA8@AeSxc2QQKb_R3M?2;;Ek6)tJ{& z|E--@)H_A;2qs?t4@SXki{TnJ(L}n3X~W-Z;NY0g11HheaPS~JCiQ#Ty7|<00CCP* zJ|krFjPRf`)r0eb#N#0K5L}mYnv0s}X(a__Q=~2HbQoxP;ewy$kRlp7BeO0-cDQr3 zq_gmhxC%#fxCJymde??Tc7i0E`s-~v&?KNHs5JErn@oY*5+utAV>-DKwFK>ZLWc&G z7fwl~dGi<&Fu}2*b1aQ=uR;2(0K|x3`RIz+N*o8HR7u?4UEIEpyj-+sNffr2Rz8v1 zQz}uAmbZj1^a~lXrvwEXsvb6Ch~qz1cuX>`sZVXUkwIBRicV|!KjlRIg>&j8Jx$uR zXzJ*GkOakH?ghc0Qw&+F%n!xT7-51Fnr}~+C23g(unFY*teOLoFid&T`9#U}ub1#9I?Kz6 zLasRD>(YW6tbNIw(eqUbmfWb&qujdrIl-yAvyOHX-G*)ii;Z1ds+gUW%)Az9afTFP zM)=2t3nnq5bW?I~jE?^xr>K1TE8Ke@-T?=uob<0fX=Ao6>RA)P{N6BpS%t;Ts)ZKY zsi;v#`ef1|Z$H{GQr!#0Xkxb|-oh5V+^^LEj;45biA(rWV?QK;G@qSo{S6%4J4mV> z7rE0xcho6aLo3v+b`URFVrT($uXH=8?JNZjQ5b{DcT_DjbjdVSusT`5t4fan(FV%{ z9;Tx>VlD(LlGS$}fu_x7bEeKkPn?`RF05e-nm$fo)^5#Pux~cgKM%l6D8mPuUjcTV z*bQXidim*V*RSwUk%)#ooWTfMA#ICmeY7bwVA^*gegn_=USe>Vo+2A6#r~baErC_< zu7Gna0ahe$L3vOt96vo0X1ftj!}H+(IaYLbLuFZpxjU{8z|T*gEyqIl8M>Bt&GC+Xf2?SKbMu zB)u1qjEpxSOll>;WE)s|x3eXrDN8#|%$f0}IiyW-2ptKcTEanwW!pB2y{C;>$RLJU zw&#gbNu=8;Dge}v#tHp3FQTwrPat* zLXzJ-+2qx<%>b&bPL^W63(j3}z{XWk#$)S<(HQ6xuzFkJpB0S3S3htRFn(jR_62Vf z8LdXhON=PJe#D!*c&bu8Ssuu`6hly~K6PVwTgbfeQVtIish^gO!gCzfER)oc)!T#5 zrQZ>bEt$`2_vRPkSl=L#B&>0e!gmF;R!MC&sx?FMu7*ZbyiK9Sox(tCln5xeAe&Cs z1l|Pf{LZ^-Cqw<$BAph)1Yd-|+DcJ%-`}kDtz_H^bLg6f6H(V8_*!kV1XYJ_Wt6f< z<*WJcbB>cwUT}v2CCDM{C)HdPX2Lfo+NC8<)0QTpoi2~dPiPiIYi`-Ewhh&;NVQYqtDt=# zH!-QF^Fj0?lSKX@D&-YIvp-qxZLVa0gZJ(6EYtzwyXvnEi+S!#x z9RytMUxP>T-QGAkO`~MIK_H_K(~ zsar2$*lkm7L`G&JgUZ*OX~%Pa%?8lF=ig@eqnp8*X7If3uR0d4b%?Eap*Q|Bt#>dT z6hx<-$4Ut5m#Z4}-j3n(d8gC>!#Z{c7CUynWhUrF=#Qi%L$nLWyPH?y;JEhVO}z{6 zGl68Yw)s{a>0V$-)62MxS*BW8lh?3Igx)kehU)@6KkAs`t#;B?;T;g_pTbws3q>B` z0;u6>!D-2DUBrGWpP88Xkb2bL7A2`OqvzV)0$La6W{91X;VlTm#;6FHXdPog`ES#i z%gEuB5!anjEs{WZt;NeAM_*S+d&Y#qi0^wi7r5-7HiGt_bk50z_M06Yk;iIYUz03O zMLV&sQ!u<@*|K=5v`Q8>g!e(zcN*#92eUduMQ&)$l0MUPXrIz!E(!b2N|xG5w6k_A zWg5)Ib}6B%&II55FV0#W&f+igoLiixuTTeX(BkYNg6Q`k?ME=iZTBKxi{ZL{g2mC8 zc3!3tp7OHsE<2Vl--SY<>;)6qD75Sdbac%|g6z+kyW9V8#_`;ve^eD!@V{kTr4X@F zWB#XzTHg)aWsz@V2Q=-4h#EQrdta^PHY!t`Iem4QJE4hk3gjn-$lgB$n2HyGyYPK= z6UZOy^16XQL*L&CIra#4F#WnLK&zkaQ$^yL{b>skMbF>Z9Q>YN4okwZIxWQr?&(1a zolyO`eR`YhNMD4fZr=@Nu2AEPA$QL+!&9IndAbmL=BM55F7hZ(-2Qv!wvzGy@@NI2 zG1$>qeiJmIHr|b@oWkaq?dN3r-F+y|02uf++iupyZmya5sx8N5?mRHvi#%ijO& zwbX006}b2m2{niy=w!0ctY1YYyX2Ioh!b!V%F10{jk7x)WO%0`qIb0S#ORgO44=!J z5K3%<7{X_d9|j#^n;)m*728c1cU~joZQTF;s6=SlD)zSyocYjI39VfZ2ZoVf)D|sj zQ!aI2q$5jeX(V!VxAe4HSq!~JmE2533#5N>{K1yVdR?WfSI1c(6=4|ba0gQS<3X!Z z6Hqss7v7>$|NVp>ZRVOpkL2;47(|HU8P2s0~_hvhE?(pDj@PQgO1V zltt$WIgrIsORGhxQZ*f)0baljiVX<)vjSR^JKypLRrrw&9=z3C;s3th%Kg5KZv`B;;E9v0tR_u{QJwvx&j8jBG5 zCsMvrcScWlZ&hlCLUK>>BGk`qqBm?3FSAVSIdtLqV*0d2fJ}C4t(}5&(73btjgI@i zGCMA9amf-W`j%6n%H3FZaQahR#}d}pA484hi$HJNE=7Pz4zHTlH$`hBBeQ(I_2vlq zgSLHaf*N%bnlig92fzZ|(Cs4qw1pyOAD1O1HX)JU(vdx11SM%X4>Dh%ERPG*2HvO7 zqJ>oT@!$%>^+xa`qE}~5MKmh|kKXZ)nz7@k8tSn8Wx7v9(l zv63lJ*SLOqWi~T}iPhh=#&su^-Yr5ThP1`OnS#sb^$?ecD@h`=dAqe09XCC0ZV9P` ziCc7b4CqeTjo0BmVFf$7soEM@H@#Wr4m{X4dRIz6w>@)Pen1B160d}wbfKcI!oo0i zA5?o>uHAd&8G5{5P;U=~VQONH>{4Zps<*movf;IO9@q&3_YiPwiY?0Q+W^j4U58qu zM;2{b?nCc+V*5TIwfX4T7JICe9Zhv0*a9~`e~ZoIR_T;Y7FfU*cQQUH35LgLY<$M4 z^W9EN=;$?RqIP&e?P)TuYTfa6AD~6+N?J+RhBkl?i}mB~2yBMG0A@o4Z=uS6*~QO+ zJjZb&b>rXqWT={Drd^3h7JScF2-{iBi-a2cBe(TO2gFVvW|$WDI2xWA;cps8Vg zOPFbF<~^1b!Z0&s`R|20q}un$-HwXzNDw)5iE{>*s*&9!sc!s?6rA`d4eEmI8?>cv z)ox>ik*?Kfjp%%oGB$OrY5yba-ISMt;}wo`n`s{Ei1wf;V@nCG#ZTzMJOhGn9h$~< z2-hc!LRvR|{mF$CPT1*n7H&Ze7mapvIY+43afK(t`(%md^mJ8U6HY?E6|VDkBBD*7 zlY-Us)<#Z2+@t%9JAqjwKN{D|3|nbufQ8U-ii5^*0>W@sl3&hAlFmuTde}7{s!{wp znj4sB>6Es7!p%J9PjxO;6J@4?N`k5e%0P&36;FDCnpj6X`!}&(JKZc{CwyzxMAD!0 zZTF|jhs1H?E%4KPRB~(k?YTio)+^FC)_S?6fn*2|Vp9)4-DztsaguDTrhoT=^YPrI zT@auxIyhBrw0ZD(wan0KpD8Vl)os!U+y3TusR zLHhA}owtX2+#@W5&7_l5ydgzco94(5-c1A{eASVccUo;*s;04ms%u`&UB;C@BMXJ( zN^>Btx-LvXZ80HOck3W?!8zcL!2y}tIqK_C=Xk_AC{-wYx&58)ZGf$TM`o~K?)rsf zskU4!2@%7nG*!6hHewxf_>|= zlxagDb=0T}PK)FpGYgu7)h8LpFXm%Rz8kSc#akqKGJ4~j0KFLFol~So-KAx$x9&s)aE zEnY(7>Moo6RF5*%cx0O>uG$_y7gKA>#SKxEN(GiQLeLdn{fEJ5JrD9uvR|vERIW>b zV}alGf9EHKzeX{k*8>S}P*=%9zI(_?4uJm3`W}J16auGeb-`o?*8EwYLede;qTJ2Y zBs<24pKwo8F0asuGo1>CVqS~4? zrAk5#VxVV)nf-SaGD?n#f;7dX1@lrq^WLVs$*|Ih>%43l51xFF^PiZ)SM<%~EU2=f zLng5$Q(Y%1_wF-=otY+BFzn0EM4tO$%MoqgU)!rD?A?24=7mFclRSW3C3=m@1vD^} z7Sjdi>!C%5Pp7?ra>Qn!G%m_;&mf={XQ~*6=6VkGp8TTq#7?ehhjd|A_Q3xOni8ME zl0N6T1!ZN=8BYZcQca z?JhLTr(q6mO?=(%{xdoRF9d+)^5@+(k9?NBXDWZJ>lrNgT4z@p5CwUUUF+F6Ng zHp0rPEYveLrIR#|9TFahwjw^Jx>`7TM;8xdBKnfGpjfod@dVP~?!6);BekLS2?J3G z_l(gV@`@nJJxhI)+E;Z&#)$j(xs&ZKXX_cD30EpIyI|AucDZkB6@>KO+V?_euN+ETfk&%vcD1) zbKl^6+cOZ_TBl zEk6DJthrq;eaM3^o>b4<1QuROzvy0qlS2<|?0+$K4$+}SUAm2J+qUiG# zQNOnYT?0yNxT|tlb(=f?SvYC3k2DiB)lYhD-Xa?!5xL_dd?g4N!Jo%sDmXKM;AS+g zSu%gd^e1Nd4t{#Fk(1HgFJ5aI;bM7KLTsvfx{9;CG|qlls}JKdGe*t*INn&AN)A1x z?P_oc%O!KUoHe{@Ii^)4?WkJrykI)S9eIo$CDvgcvn*4Ir+!cZd3~a8Y6I zMcshSNu(N1A%ezv#3(guZ&{(eQKiHt|KU0AXyfOy#$;FUK6!chOjEF+A zHUkpo9+QvCRoSJOB7`l|-gH31pe!{4C5MrwI|{hRo~(8n?~)!y&&?DAGO~Rl1un_> z#FLTXS{9Fg&$q_FjmfV1lpqanVIo&W9@y&-P5f*-s+N;@dCB68z#OM##X~`SYZe_A zB0k&G&EY*B-{f`Iu;_NKWt(Ox-HN(G#gar4hZ>Lcdvn*NnYI+)p`q82EwTqz(V@1; z9W{v5XDK&uHhMZ)k@V3u2ZG$%ppl}O;r6W1swY)5i4yXN<-Po2cBiq33w#t#P_ygx z7P&aPWGKh{a8b>mKl0;!;xOrZUwdqM)uQjDc5oTi0jFE#3od0@T-MGqO*ipAjwI;m z2y~t8ktNpdOarx)%XfGdbd*^1koz$`RH<|Y2zvE5uncI8IXLV*UGM_;@YVH{x`Q7^ z5((=E;vvS?-lc_T1U(m15+0eQ0jJ&TgKln{AhAiayELMg{t&kW#nHDfo70d5;R2H` z4P?(xp0EGF`lXH9Pr0Ba_qFGwhyEQV*v|RqJ^K=#_PNkH18k}1vjzyGn@XjiBw4AU zXTcUQ9gIKnSqL0`9I`oU?8aoaX{kj7pyGwS;Fe*M&Qkg{u71M76jSA@!6Ilsr+2+< z+3bP0Yt7p0&^yQdDE`rKpDNT~P%AvA{)BW{YN0}cjPmw3H3)q?Xk(rt%(6=dwJd?&WaYCBa7;e)+XxW$F|_1edBd?Mu)ugQLERc$ z<-)8DCM8iCgeq;A>iYv%mrH+v!%K~wNV;6Cq8AX7n8fZDJX<_B(#&=G9T)jh%?lC} z2fL76l#voW_DaggZJsbL>p+tEaI@LR81FJUnMBjS9K=PJjBlUG^dj8lsgsx;$TN({ z8;OT$Y(uNL>cLvKQ*oGjBJqioe^pf9xn5}BUIqT=J9_A9pD*WlHhxwB4Q}9FU zc^&rgA*^Va4GQ0UO}6hZ5U9aF`w_l0$ZYCXL}m#!_5y}h0+ zL?0vQ*=bHJflR|w3qHV!QwqT4B#VTuu;w8hc=q5Vr}i(HOFJ@T z({PLU6FACEh4^)uq|G&K_f%$Y?ikF+hX+leW=U8wY`hkb`UTpM9no$Byh=Dj?E_tfW-Qlap_u_ZDLyb|h1bRF*-m8_3thv(!mg4UIBmEM~Ka$_0z!A)GBpdP-Sm_P5NvoCn4b zz#Kk(Za)08Rd7mOW5Oin3wO}cKbkwDPUlQ5Cc;pE)yy^6SV111sZF&NJO;R-NK|o7 zQByDXc1RwI(y{^n~_QdOB@wg6QYrmqC&=5!O1e z7L2ccmwUx)jrYf20=K4(B7~%c35<@#B(FDDg=OMxz_i2WT=na+dB_$u(q|VuB$xZp_Ljv zum@n-4EbE&Q0M#2+Of{gwjwihR%DWI-LyT4?f$5aw$ea#u&3X&lUk6_6xc-N*R^}{P7bsS6tdA^T!x?<*e?TYm0p0t z{thG>+m*RU7O~V@^W4lZBx{u`Pd{d<76Zu54pw}Cysr;QE+<8c%*7cLe?uzV;R#Dh zexJyaTz#$oj0%>DO$iu;AHa^e7^X@UM|!Hbhf}cS}&;S^y{N2pJy#uNj(Cv+l=tvS4YTsfu$A zwFMq6u{VrY%lb699g-7`RAeco%v@>3zqclD{X7Mg{3#yG#=F2Z>CIYtT1Q0ye~A4T zR}#pniAw1B_2UU<6ou;^cYtT(K}{k6oJMd^wF#4CSiYN0Yzyw@FmT} zx#62#&#x}MSysenc#)$*=`2FYDu_64{6xzK;FC-dkQU?5#9Hr zR54urSrTk)yjHaxg@1UFqj#(zV;>`;S3NjKcxq&pot+5nw=V>RCeJd(>>6RzqXOUf zek}<=Cp#MWe61sN-9__wLxgvZcT?X}^C!3Wq-yNg=r$7>s!ZA5?^bbVm1inHuF~*c zdd-EbRmW>FT0c5-Y1D?dUy>-(Du%3m*+lmm93BgmCWH9G8OHpEp{dS~W>>}fs2t<} zj6ZIBU;N#<7QLC`J$C;6_}qm&dYSw9M(3Ch zI#N$dcVP~oD%a#3qf@Owdv4QM+Cn=#;uESZBTyqIedvEr_mKr6n+&v~M!H*COw;Jc zmZh1PE}`5pE>KVb0oK8FbPjXj=S`GjcDTCwUDy0M$1s-|l+K8caM7FH?MoL7c6MJ2 zdNRh0gy?o5y%F?O&|ciw7C0+mpGh1PN?Al#!<;ghiX5fPBIm}hH*kd6Dx$6oj2rD} zY^oL0akvG2O9-xiFXaia%_JS-**dteR1P64K_Y3p(iurCVn#0BUl7152E39;qWL!6 zD{z{5>Vzn0ygbqlfW zXLms8pqLs_c&gmevzm~ghfBquIDE7lA<}A6KlIP(oFNC?RMQ0wqbz$#u&Xh{z}qG} zj<@G%@G(y()xS1nCW=A3ry+z!2>=KI_xN208EOTMwxD+9!fN2^Jqfs+Wi7hrDykz3 zIT;~GgP+bT9Sg{Qd|EXbV$0RO4bcF#@+Q<@!>Gf>2JGj~b_tTEHOA zWVt!49uuTNBr2pNail=|l>5oOR$O{Wy!u zcy^0Vf~UoJYdQXpm!_W7=(>DL=C|~E{dGif$-$RPyBFSpI3ZzHjJ8r zY_&lbQ|wH^=*se;BlKJ9u{n2sIaeyhyMyw==3NZj#5#e715+Fp>0Kn=4OPvoPAR;0yE+Ueg zp0ofHdhh>DOMcwsPvoNy(RTSGR7O}pfFfD~CuHFN4#BZoQwt720R|vB0rc1Sj|e~^ z5fPIgFrv7IKi3#M7~m;1;5E^%JiehUYp@yt((!)ez|h+Vav$(9D1eD^F^KOkaE+%x z90LOc{4_|uMqW-@gkcO=KN4UtzpT%%eK*1FPeGS)NXXaMSBO9^pAbZG6j3ceAAYDK zXu5z;zBoSx$ZZr;AHX5x*Dod_9a;Yv>fuewAktp+Eht_dKy()nSa^>Q16hv)Boaiw z5Lnvf5g=4o{#8%EyB7e+pMMw-AjJQt?ZfD65)tNm0|Nw%n5SFdRsdrYbQk8q9|(r^ zDOetm0uTTK?hO>g@KY8SO8`IFw6^lxGVKmaYo zsaHTiqTXD;o=Zk#Fu^`vpda9$EkgrfE1Bs|%}+mypCVVQ+NueOVTZ{Z8Z`r?g6p0Zo-~ZftGmtG2eYKWAXSshoax!K!8C^ z2?zu7{ABoXBSIoF9D~39bc6QFeA^BFOiundegAM1%jm(!?Re()0{n#G9YQ`pdF|70l1zyqqXC3q^vmn7^d6ty z@ab=Q_3g?N2g6^kul53HPgb4$5Z8X+73>MYbk{T|Tgy!i$Y1x&wvnE~NW=j2*%7x0Emhd5EV!v45?K%% z-_Rhi!!;caME1O$Ty65zC@+MaA~EfWI<0AB6>xr1jq~gPtwXYq6l*pMr9z3n4Gvp> zNEPNvl14tA{2OQM{BKe+{MyA(r$yf_3i+KbxhU&0R z>_m|gl~xZ~oAf{d-2|~vnTCH^9mes~Mvd1_%{Edi>vqs%I~uA zQ?7S((m$R~t*L)7vvh%rOGBeL+o^ip8oqg#Xi?JgPU_!u-Y!ue1q0kNmI9h0SI`TgR_`{ZuMt6K zIC$2|PqE9@;>(Sfw<3?A(rBmsSXs`{A#Ux|I9CG>9YXWvjp$uMY0HszaxP#6y9=gRi_E92v@ z9o@%2m?{UJyq~@yJLhd%fR*dR2O7w@Y<*@!aE^48pQ=e^^L&qEs%HwPZ~t8EO;5oo zgXFrt0?UlH_q|ZDxOiTUm7Z+u=m5#Mbg$Am)7D(CowxAdG*^XAW|Igg7fb$Bc2@NU z@mD^f!|$g(sx>I@Wpmg56!X7ehpJ^*Y#;_Dqwp5Y)&T=RVI`(h(NXK4v zoF5n!?jOJVv!qleWM9!0_na5yZkYDV%I5AJ@jnKgV_9wTZz&6kA0=+S?Mn-}!EB`; zq;GZ-jaKUPC|oqO+SPWB8QKMvt0Kbu)2()nHy8w@89U3o&XN;u^seFhudjyQPa~>V zs5*E)FHu^=)ZCj}6ZO%3fa|FBqAYI#J=a1Lz+p+yVeKoL`Jjz-sM_S01+R#RSxhRA znht=N#-80l0*}`cqEDIopaK(zgE4IiTax8Ns9jYVVU+A6W@lbg6o=c3w%4k689h<-tat>m#hhsk&@E?&g)PJ#M-Vj`nfbIqnuiR(Cao z#R4h>*c66Fv(~N&EPu%)fm4*^zX_TleiVo$yz>}u+#^kN1%jApdhf(Ie&n&urrp3D zRT}10De-g@Pov5JGU@<#{rPaqyxSxco}WW$0dr0%09u11Q$0HEvSDbcQDEb(vZt1l z-DZ4ufluMzCaRaUB`4SOd7}m}>d|HhJTZQZFR#K%BqOQ2 zjkno;0Q&RQefb!jki^>sy;(D1F!<%UmJXd#yFjK1*APiAL+|6uc^&Go$3=FmeYTeB z>}%ytoXv`AjE@@;fW}ucOb<=A-G{Fz6`OrRH;6b%CLNxpgL2IA-1@^~% zaLHkEE5u>FlV9$fGwnhiq#qGGmnRdi)LD6~wj^K`PtS;?EZ{-`wfdu}hCb*bNT;hq z>~5>|Wkpr4i`Cm;OKuz@@`n|epZ z8A>>LuU(^7Xcfy(q(<{O-KPl{)YDXjx*4-W-l7B^noO=T-)v#-wXd+FLjX?!K`W~e z8Zj1&AZqY-n4fx<;00h8EkjW&%(ntSM`W5RyZ1=+thRaNb^78 zSlOY!%)}B3yMT?RsvKw*2CM=r+d_R^klMbIc_#u2=#d6Y0G_LHj8;~e5A0@ojlhFN zit2kB5Mj|lyHi^GxkO2z3$npfa0<2Oiw3CQ;JWqg+$gK-|}Ha!GZ zwk;_K!he*m1+V^GOOalY0Kc0)-tTUM)m&V40p?73z`?5zu1xo(#hsnlZnldm(vP#} zV>BKZsIKPse0IOEfE0S%^Xr)w3xV_V!ul~Fy~vxl(5Iy4!bc=lvvHF*W!IeTYr^2A#t0-Q^VO<1eriJ z>3D647!T`;Vp=>qg#W&6(iC5);9@uZ;b-?Ytu-whk%OO&KI9};@l3-#S`R`Q5iqE# ze!JN~+g^Z}B*4BsL5R?AnI<=NuBN4j#fq>sFHR+wOHg;`l~}`k`t&7f6K!J3&cjP` z_KMLZE-_%Lmn1WZteH_aX3YqpQWt28=dGS`^qm?k&uQX_n^+50;4%}>oFh_*SeD+A zo!Klf)1hZ>@=F_<#$!Z38qj{llBoOf4Xl0r)==xjo>NL=nP+I{!Qhw6e_(p*sf^)5 zqg)0gsUj^>IrR6jD~efcr2r?o9UDD0%3!XY>~WOlh)pf9{gooz1vST9qY*6(c!67t zB9{YIktxkkcFL$>b-S)Dt$;FIYP$BKA7>0YHeBf0#K6n&RZUJYwHpa?70rHiE`(k7 z_I;L@V)9Ed0>*IpE;|S`z!2bLhjpe<{T+z1RJk$JwKen3@y5R1soB5y5Jj|EuC=9K z^6Y+i254xA^7YnrF$#28Li+PTE3^~E#fAUO7#-HJo4h0IpF1@B`Wz58M|zxNHuWGUb%=<%MOh2@)>ep8TrN3)tR~d<)l9*ey>RAA zwoz0Wxc~c5L(rM?5Lnn20Lt9xAPjz;S(5TgOBq(=?D&jb$h@m%+aj2GYg5}xmRk7? zkE`sV%@dR6nux!9NwoJ_!lmLnyaGBFPtsfoVY`3_l&n{!!_mjSRoK{A_Rf6E3I@BOUj2=)jH;UHy_oWu_= zHj)JuCfB%mN-+vf&RB0|<;!x%<@JYGz(n6efsCVSA6y*ude`^z5k^z)T%)0!fD%SS z>M#!f_*4z8i&Xha%wxtM`&Wrjin~zodV`=a-Iki6=iDiIoCyKtTH$n(*JgbUs=9{*B(yU#|gX0jNwe43~oBTW>KSI zs-aO*Y+ctjiBA)!ZZyG0Lv)qzD^lEaL?edF1z+3Hq8H4rA@}ZLY;urjw|zVvRQ+4t zbMxLTI$~6%4Ze~fXx7^zCd|QEaQ%HM#)Q&rRd@j7h48aJFf!X|dfrQ1A-b&N zef@4P&dik7EX3}mhigdWsbfnDVH4w|B?NsC*aFrj(inE7hAd?&X<KLks z^n4rJrDHZtvE9+fq=oKQw5w5U>BuAvAchq(nc7npSIF=xY^5M!x0%{|CJyi!mD$13 zeMyD4)!^UH4^&qx8R&$3et)#`I zHEpqUhn>;-x1`)AcBx7ZqHZNgm(Se8Y_(CFj=FC-`+XssO!5kDM@&ttx=vTt`mR`J z@U%!4?t8y)6f^PCD3XjUFu4K8uKJOqv&zW=T4}ptRFJ9y#2Ouvj=Hkahy{AOPx1Ffks>>XiO9<&Bo{=>v_-!skb9%@D#*i016pV0`y&q zO9Q$aTHqUTytkH0szpKj8u=?cTIF<3NAB91Rr1>#!uE~Qypz}>Iytr~x}0u57;Do0 zKJdJld+|Y_KlMpde0UH3{CBX35N9h~HeMZn<(65D+jSZ%j^`Z^ zeX^FH_YQG$Qx!X-g#je-P;I5HjAgwL`@wR^8X%3k0nUzjcxv*RK+}8Goa_$Exd>dP zXM+P7#B_?~B>=VT@-RM^tD&q5Q6z5|Q(Qs^(KYr8Qk~1ao#ogTt z;+Cd5f~&C=4K}9KZ3B1vrgvmD2S-j6Q7+P%-9w2*DUD0WP6!=8u0>8d<3n{jN+zZm z+IL<}VW@ZYnOrKY?;N!&3@v)?m@;R4) ziqhC?>TF02t{&NZskW_@@lgytFo**pzO`@~OWpEz*Om8ni~G1JAOk6Cc&@?fu*0Qi z-czPll>KY2lc`7bFpk;}i;E2?w$Qa89=*3oKdx(YWW-j<_z)f+wizU1P>1e2uu`jz zf$e?dIs;24$CnIq!lQJq*|NVjc?__UQL9MtBMag!*vWaNUZHBtIZbQA8g!q+pZrz*4s^eucS@1i!87oB~Va*o)hpJW*M+uE3FSlcP zyWIr2d0>znJ<|OVUNRY|v`W^k8;e@9-3dNcNaVewg8lT)%D31rsU2h?QAvT|2U*a< zC9p(41qAJ3_Z?od)z^q|A@P34p61m)bUb52iv6yreyqEdZ@#VG&FCK=)9>!vb>%kvmJINnmTWT%jzJ9Xp(35f;$W7AIoEt04;kFaoy{ zvPA9L%^yrk*z2yImcDwTy6)5&oFLdu)7|X3%M`tPi?)Ycb??-M%4$d z-WohWO2;!hi43+`gQJCJ=FY-t;Fb_K_7rhpG=~aAWrg(4XZHD2tpSs7JD8feLo6hR z!-bE6rFerR>Z-d|{XT#37>c-2-y#zZlb+=*#Fj5!_T`OeW;WStXP}pH%tqJ2K4_DJ zrDNRS;WO2Z%IYWB<}F$K<&Ja;TW@52Y8vzfa(Qv`>fCt0+8Tm2?-`M}|8S&!cTs9I zQ9L7P*>`sZU0#w_ijQ8(PZcJ+cW$SAuS}VU666u-rFWN{q-emPbgN#tRrlR{vKN6Q7yXb zu0k|**vj#{V!JJBfP? z{~f4tdU}OXRQr%a7ER*#0TyJ(hT+iJfS@Wws2OE8IBk8jf$#I1_>`;A%BBcPhhCf& zk_yW0S@V*_>e|qme&>r2( zpjq`pi4w6sQ=HgtsGV@vb4k^`<1}`xP46DY?~$a?woL9MApzSj5VCxs_yMB;ExTyc zD)f;IWbAZ=U63I~{ngs5sBo`qa;Q(U+Qc`b=47R0l`?X8!;V)#N!W|Du$r!;FZb-9 zL(9uV4Fj04-Elb&x?FILG`0^hOYnH>aW|s+j4r(9wRk*C3%#630p3qM#~0)20` z=MJXN&L{^pR@VPM{m(3rk%5!_|IE{A{ZAH%&KB(~0YM}VOG(J!?8ZJX4#&_Z&&(hk<{aki z1|i8VE(s+r0g;HLIG=-`>$L4O^YQ(oxzlP&d))4-{jvSBz0wEwV53hKW1lNgua48S#1-5&?Af*=@nb+4chbPO*awAtSu5%1?uKZ#+G zKwmHi$L8kdsvw-bYguD6#)FhUHi!Z6Kaj!xnHqhmzME7)O9Jp)z3Sf&1!%G%xaG&y zl&22H9>aujXIK@c>5IJ$LqQjls$eEXD-Zeh?%(||< z+z~+-u{Ju1yC=e&%PhVgTxcM%g_<+XeN{ z0nm4Y#*W*I%`zV1P9K*KqL0wc`O>EqY>aereQ zI5`5*5TZf&bFO0ThkwC;1Yue~k^83iG7sVELwKw6%L3fKoZOHfguyljbFF)QB7cvD zb0#l7nV7I>{8+x(l_sP7hp00$4XS^z4+_K)zyk#E9R{BFbNu!J_Py|huL_HBSiA5Q zr7$-K1@)@4?}iS)@{;!-qz-IJuk#?x>kX3SzpxN6;PmfbFBt*-zx_SVi4-e(;%b@O^|&8;{`oCqVWTpD`f* z0B|wA2?YH9z>n;n>K<_Myi>>cQTYJ=gP-_6z)74Kcl50U{)78=Lm$|@V_$l~@M--9 zZ}hJM`cL$~^FrM>x;KUC&+qxAZ1tnn-U*JD?%OF8p{b;L=3-Zu= z1RI(8%TZJkj_kkxX2hniMQ9(omINVWX_4B?;4{fCRn_C{d$0C2JXucU4LDZH(x}Vf z45Qj+&2ujJTxK@Qb{Q+nht`D`vp6#3t{F=6(z~qq`^Ut;Wx?B=FGLpdqDan$5n7rr zmW;bzy=7nCpc) z)k5)Fy2_-;HRBD5#!Pk}>Y&Fja~o#Ud5oZP=MI=q#p_L$QK+-fV9l>*$c|3@t|7&$ zr@Ib|KbNBvOdJpQhwYR6wsvWT*-jPF&e6U|NA23&H#xfLZq2jfckMGo)m)P63)2Qi zQ=RiZ!|H!`05uPluGh}{KCC=K8OWfhK=Nnkwywh=BFRkbAWLa~de)I$B~?N{myyav zXkP}GBKXJC_{^!1*jub3{1%sDPp;q`xddRbRZk+Gbq~txu0_IF_56J4;Tl#iCqIPi zQ&C*_N%6oXc5kc6e)qhXq3`_FxUKjkCfAV#2U7IIC*R8~_cJ>{dSc+Q=iExtM*)Xw z!GK!#jfyl$)8sOph%$OrljOb!Y-kamMvc*FzB1aK25e-$KRJ|8;@0c7lHa#K@hsmT z1tNu7?awOc^&yJ(#N$%m(J}8eg;hsNP5#ZHJvQTL^Tu*g)W;j_Bwm!Q(Mnz!y{UoL zD`Dm>08ia$ICO(axL5a{S8&?ssex#w?H0J%XSTANQFViRWHoPy^fLPmZXTH;wAmSq zK{Uzml+B6lzqHkjkV!TZE?C0Mn2C5DJb<{4venzL+5iFQ$YmM6ByK#opWEWvaarQg zyUAyY29Z)(X~gq(Cmkd{5?sav4o)$CSzsy>YBEaMU(cL7<<3ta9HU?&>m=vZHB0v9=yO{3gLN!T1fNazBBt zh(0xR3(_jpYKENAChBP(76z(vi{uy|i>UJ4`C5Q^sJ)+D#;es}4j0X4T4yk;-IsU@ zrTZ{w;PA4z;*eoCS}bi5IO|k;BHkqJR*d~x#`Hb+1?;5b$=W8Ck<&ZBr{Id29*^HX zO)8$tz)Dxr`RAMrM>lWN%dOiv>7A}x_Ef1Ka^)fyFQ;yzljQ@-)658wmFhquh}K4ED*Cya@n(T?`{u zf*N20)v=G#C0uzDVALwSIzo2zQ z8mmxvOP9=4G@>r3(X_JzDyauaHgpdtL5z?{A7KIJkyh_ONj9tO zj*;!b4DLi+;#b?E-1Qw-+(F)(xETEI5wCmIP=TYxFKdoPfVZwoxqd(ksZE{~<3wmP ztI+zxbk7KN@WC+3-6OkGV85G?qwKA|lk=6EuJu{?-7*Fb8gyF0r|h;uZX?3yYvpMD zh}ndBJj5dXl#%g5)1{Z?OM@ofsioPqr*yp@qPf1bm}CTO#9%}=m8knzl;@G}{%RKy2@JB*;g z{-Xn`21S{VMk|F*mBmaZ;`KfPAkTvWOU6GSefY)=09jknnd?k^fa% zro&KJ>d6|af&a-}mIgAe&hC-N8rSVBKFeezRkoH}%2Z3AIr00n@!*7m(pqZqUk_Fi6MX{7j54mAr|!J8vP74Vhq5X zp8gkt7&(;&H@+Ai%HG;-Ih<^inGTRLrkA1WbB(RdBs~r|7~9V3w2-kw_%L@PHY!!L z8`o*3RRrv(UC&K#s9GS8JBgLrP>{UEcAdL#1D5*g)k0c3%B7aSXGbsh4_%^rR6+1K z-2FqTOd|5PCDY9@cuFpp%gZ=$HUQ2Nn)PNhnn&VM+DgKpl5~4W(`~fQ6<^VALfmBa zwVJ(^X06ub==i0OQ87U1C}=p>B!53VB7Jg^TAL%spf_(7SdT+y0;4cd#9d_2BMgoT zzQ=L;{s5WS3Ivy!+gQratU$Z56l}3F?=3MmdLXrKAXRNfDVH@?d=z!}iS%owsxb6S z?Fs>$!0_@0$w`ztN%}H1wYq8%!r>U3jn`cndEeSOLt(DdzDvON;kJ!mSC>eSLdM+G zT?sD?D_BkaaCx?AcOeecAS8{7j}-d*lC&1Xp5)J#Q@C9K{8}O?m1>xFA@EU@lF51CTp#RsR%QWRR5dxS_sJY{&GO) zJC~OZ1lcc4`HP3-%jGcF=BNUv{@MFt^&ssr|EupLbEmRqS2e-~G-M|l=ac4=qhP5D z+wS-7&7La%)nVK!JpDqfC#lAP>&6_qd5(NVfoA+DQ&Py)is@tbigNq*J=#o$VR?+z zJHK!J21C}v&84A`VZlnudymrH;oPACe+7fa6=b}Y=4EweoU4c2yKJR!{7R01~V3U z6U{WV9@eP-UJh8SmnjQiW0mjm!!VdHaD2>eFV#As9oTg|X@HB86Ejr{t$@MyLq+%5SC zQ_F6&YxKz!W56GDun@b!0V#zx;_^eAY;vagj}WJHGL)go?lfo2UdXz{-o%657qf>T zADm}~mUY-u1$82Eu03;G`|QSL+1iG!dlE>!1yENCFej;(3SAX3gdVT%^FkQPNB7tt zY+?`Q2Qf1Os(^t6av^3>$B00~-p7KfYc$9)W`xi|QBD4vN7f2FC?A;)$F46C zyMm)u;Tfq1KE6)Sbd)2 zFYe+;Oqv*Phf+0Qwwc#bmH_p|U8cQhLY`j8?%&Z#YRBn~JKy?z0s>8OuMp%!Q&^#i zyO>Jor5o9H(_ZN)Y{)UtVpZ-!s9DSwZ$xTAG~>aZjy$ZJ`_B5=?#~3Qn%RJEY3cej z4PWjP|91=}Y>&6w$i#lDW8|C^~y>Ti3PL3ns2A1tz|nG%hS9Jlr^Tt22V1~%{FWPc#8IQ zX~Lc^&1Z$jH^d)B-mr2akngpM%m9mTEH&?E~nQIWRgmI|}FJ4*{yhp$9vS?P?OI%ir9GhCv)+dnduzxd2JtNRj@kvB-M zu>q=|WasFJCgp3%LsQiH)4+!fhsHzVeQB>!M>4vDkXRO029MNxQ=+<5N43u_kZ9(& zPlQntt|y4NSIUBn(As6*=Cb>N?zYRLP$myiFeBOv2ls$RL|$~X?mcOgun(5#PF#zV zumD-z3?%|hUg!pm8s_{*ZKP5jL9zVWUi9}=P_WUzZQe9m&Zc%RGui`ps26v2b*9?M zMy}o*X`|-iq!RzEgW#7&Wsa)tCOXywobf?&Yeh`R`;9}^x4;@3MkS1Cb9YG&ozq;R zsB X>)ExnHx(W~sTg z#F}rq(IYtwmYiqTKPc#ucOxgKF|^NPM)N+{xbk@{aDcQ*j6W608f-skN$+sfYZ&$J zZ0^m!_MGmC?%#d@Nr$@+`H_yFi&s5RV6#-`SVu_v%f0BF%^_E~rCVR5HO3i{_HUy5 zUUk5rhhKp~h*XUH*&~BvuY#D4c;J#fxyw#F-9f7@?eUJF=W=vE^;4bSKn(~>(Wry% ztEBLJEmDj`u>$}SK8)(Gn~D**PHY+G&I2EdaTCXoQ6VB=ry!O1H(5vcn~9>S>;v)T z63#q>DwV<9C}!FH&dx8_o?v&yF_bZM@n6_RPK{53`fwG!Yz#>Gdx(#uuc$P;I`DIk zEH7j2r(jBGP?S6*Dn>0>2~4O*obQ&cTB)I~BbF9rSaP`)BwPmv3Xf1>~!mh(!v3sq8Mj1jrNcOx*0n+K2#|In& zGJ*MKT%{&A>{bpfWwNp78fPLQvO+iVbQR5Jz}NuidFA+rVE2RUkyht?$WbrMXPzAJ zycBkkwcAF9O>!k>Sf?H3O}b_7<@kbzq;NZ&;yw)x8M2SOTi|2ltD=M69&rney|}@5 zCSvH}*BEiG&iVf+J7+LafOX5ZZQHhOp0=&iwr$(CZQHhO+jjRm6WsY;aD$n!(n<<@ z{cAV$6{55x+}t*&2HEoDcliU0KH^)@PRc_V?UHE2Gr1sxdkNoqs=3{Z6{qXqsJHg9 zHFK33lSN0O^xcB2$kLOzlN;y;0S6LVV4;&&AZ&PCm=K~MgY#Tn+&taf-|$1i8`3>x zjyX(*RDmWPhs(VBHM9II&LPhlboT}B6Nbt2cj!`IB3eW^SX+)xH?dW0&MLMkmAPni z$^hg(ZoR}y0u{#P2#UyAYU2D|{_xiCjwn`FcB5!u5*slLx4fY&td_~pdy#=#8zj2O&gL^_$+Rf(JpNuN<*xsj!fDKtlg#0 zR-O4tyAyHMMWQg1utS+8T5f<`B9xvpE`WtD(Av^D5PDdK#V&)gqpV zteUNC3hdoF1l>?4*h7oeoo##-->TLihy8()`T9<$t4nR+Iv*;w8|`K^6>>w$qxdI8 zFoXTZnbxWyTH+eBm;QL%nI3}Gmq?y|tDqD+tgk2@kxDRvL@@3yrs{ z&?_sI$tx_+&YFlFMhO{MguihKi9Vj}mS1eg=1Pfr8Eh~L6gyfFuoX0@g%e1y!D-}U z(<#D1Jy|D;xzcyKC|zN`t9ZpGG6C-$crQ@%AW^Q1S%H)m38J=e@5&)BUTNOl&}3ec6aofTEv|5R!f?%3=yJYh%K7ZjUbUw#R`(Z$_<^gsyxJR`Z<@ zqvtFq-MXUekbL%>mQZhv;#7?S6Z!M8OeTH=IzjfLoi1=2AIqjA=pG1^tz zqpRkF&g{jZTQgB(O)|yAXx`teX}rgdO=;Q*%A^Nae1V3{lsS}X+{8*snSe#~>dv)^ zhu?I5{eh%2jh*N@AiDI+`3S5r{vzqLYc<6Qz1#lhUyEu`clv1lW2qaaqf#xq-(XUc z>v`J!m@5e#HtGlz;HvXz~~k9JEiB7Xd~_OxWwH?o-OQgXSzgx5To zjeYgumR-wmCE7{gAZjXNP&~r?*TTcVA8+>m@+W z&5Qpd^ArH0z*yv*cwO$iWh&o}-QWX*BUb8`p@iIe2p8qO;N|Tgr)7KoOPnSjwZ%kn zjBI$?YTq5z;)t9aTM#5Y7lb!hy2Aa$pB^0T;35hwX9_*>0(|I>&M2ESXwI=_v#|y= zcN>^vG{GUw8DoZ;DPbzi4fzoBs7bYbxTd!}Ja+9v@g3A!-KlZbzf%FRNrM>NGL^lg zh^zEq#`r?r`Y|^VeQ_O#S54*XQ>8-iDGDG=GUdf~UT|knkOXXyGIJEu9U(fJY_)SI zL1|o-+j>hqv9u-jzw=U(FX`BDq;s-h2MZB8JL=%OL^%) zu86yi7(q;Pu^!Y#v)~fw5(JQ`{#u5neiYFLe0R=Wtor(I`vkNW#--PE(zQ>kwh)JM z65wN2hoW}4ZP?0phKOuW0gOlss{U0bhud6lF2jO-JlMR1@4zyx3?*J%5z%U#K0p?+ z&~1;`FA)U!Ol^5HL%?_nYoI!K$XG}HW1?}cIA&w_jwij~8xKCcyhiKk-_RN@EpJr4 zhtpuG!(qnuT~O_JY+&=-sA;Ae5$G{{vTP1gc&3plN)%~LIwjHUYWu8@h4b$r8Rlqm{K-`XEKxY$zWrmr~R?68imBJ z?gJoXNO-2rIK(8KT!P&rB~;{@Rrq*Y_x9IJuN9L|D8t1fS}k~O%!u8|meINNsbp1e zjm{O*%jVbnLcB~Dt=;5~p$|c!L?;Rl$kH`Pv|cYcC+lrqbd7Tf1qp^1uYESvSBnO6 z3prXwxaae`GAB}b$HzVOCU3U+cg6E;zHfM%P3@k)>pR;Kpj>=Cy?_(BqOF>)eBlz=G;Lj7!?kFwZ_6@ z?_PFGBmi!_URM@?^l>Wc6#ow-8M$)5Ns z@@uN;$AB+F=|bn|XsK|2 zXl%sT08@o8P{L!9SS25fc2X=N3|6m`neKVwPE7rA4`NHBt@}DmnZI7UNTu(65DI2Z z)Y==sKDRv;x4n7q3TDSN+kA6|SsHcM16lKFAz_}&5|EiHg=DaC4UD}QW3uuk_Z$&IgU35(W+^?BrIcxRi>l9ZbDixF~c&lo)6)&6`iL=l00=&L+oXW{#pn~1P zVDD^`=me=)=@UCY>^Po`?RoCX4DzUOgdWsrhjEW2uQx@{*e0k?Fx2qB8fN=-dJ*Dt z0IDOB9L!NpxhB33I+hBw(8;fd%klb%*^Ld_rv4z?BE`CS88&!`rwF17#O3VN@!hG& z?{PJikxc&*#Ul-HLDh`ud`@7zf+?}R!-R;;I*VUXZXmfwp#B$M40+=??e#G&^gqLV z)6Sxfu)G-`4dpkI8v@b9Qvp?Fyj7SQjo+Sp)M*Bcc{PQ)$z>7t1}e5S13sfGl%@Yj zpqr@dqgVR`;G7IRRz$I9`*+1#<1(Qf0_&B9>c;ZGDpY@AR0P}U9iR-y43_stC8zKd zPiSb)tVqqWJH!C%}XFmJo0iqSQk2_^PGl37+=5|5!WS zox|Kd=_ZkJ-g-vKfkP$t*X&U~@MPP=Vf%ay^zJ0K5&+@mZWX#4Sce!aJf_O|&eHP< z^|iuc zR%WbP`uQM4!{JlPxF-&%Dy1RcUS6Y5QBG=<>BI(p5Yjhdyeyc1{z7%ol0u64)rPVM z=&V)XZTTb`-6O1hT8r6owa7AiyZq8)?ilIOrj3gi809-+BD$z&mjSDG=LYV|%)4!D z+x4j?fSzA_Lp^?0?D2@8M!qh@3W>t;dS6qQC`h;=s7ThL1-g(3M28+?@jWi(6)ZAFk#$qc{*Hje0S7?d&&1Mo8ZIdLXGP_58^LAm}$2t{vPWfi7h&l zqcl71)!3(XPY%t`K|MNh%qo+KCwyWL#-JlrpKW3r0d>{V!iE9r=G9u9uEgJP8lfN~ z(gOq^l*?j1Lm&ZbD)*gLPlgtn+w~))Ys*bE8HL-L0st-hCLp-M5} z{@g*P%_XVP#vaUh7SmJDrb`*mWd3B7tXtDW@jOM{@NSZQ~6VkwFKtLFrE~p!lE)vaVY+h&0OkpC-ME3&oC_ zR#tpdY|*;XMFW;gtYa+$m&q?Mnjq{}pf3Cq5*uzXKZ+wMb9Kze`Lg}G2QK;6j51Kx z0)S8Bto$w3hG!^EZ)v41lA{S+@ulLf+LMlWCOjJRTrb}pgqi5f1?{XeExvI+r5g@o zXO`jDNIN0vP=CJI`XF;YyCIWgkosFM{C1Su2?D666@?9pUQ}Ql8tvIIJ zB-0fbxW>igvCejR8IAHsQyJS%Dx2tAJnyXUmJZ@2jjV2%%Lq^Eu1|g;7zUPy@O7D~ zH-)76w>6&cUwldfR}((|pC2EJ2JWyD{L=)(2vqhGB$NI<;E!dXLm(R$%WTXDx51L~ zUO7uYY_f(b7HN(Ia!9XGBB?82>DDU4^5u&Y-UR?Jbb<%Sie`@)`SS?#8g)*DOFPIh zhYz$sejuw_F|VR`LHz6ZGu>Egvd^BBy=U{DL-m4J!FMSQ(HP+srIrR*Usvw#0?H-= zZjib8t2D9ZtINKro3xUo_0G$|jPRuoIz+z$u3c!(1qNn`2|Ip{^|E_Q#TAj5>UwBV z6Z34o0qGekr&UYKl2Un1jQ`$Q*q=%KtoKi*2vMj(A{U4PN~9eU{>LJgt4x=fK}4my zY;VhJ7N9@xVnkj-Nd5K~c60001aumkenN`ryn`gcMe(KC|; z;tdU>UO*uK=m9d(AuxRPlR<~@50!Hb07%-r03g5v4AH|NA%Fn^ZVBYg?fS>i4FG7= zaW5g|O+d;!1PN+0VjAIOcWLLXu-%1P|L6jx(W(Ow5E25u?4AQqf`>sb0l@&51?;mS zgofhM_PqdDi$ha@+&trxriohb*^%qh(ZR#R%hm-_mlj4gb3k+V0YkL{nh9zX(%m3P z_0bOiu+{+|!86NBgZah4ESLg%n8NxC+8he7bgaU$pJV3& zfMN1ZjbL?q@fHW~0xo>re*zEKD+dQQCS?xP2M_XFaB8s+?i~t8nz8a) zFO)lj{*Ps2NFSh=fFK~ApbfwfCcu4D-TsG)?&u`s!zSd1vCrSV%fq8HkU9?n!24iL zLA)OZZ|(jY1c0q!*n`W*Ufkbs20;Qp(j_1`hER23{j^_IUk2f-pS{qNP61v(dO!FL zU_ifKpWmt|{3GLYh{o3s_Agi8_9hkBV&mntABLY%a@y-N$h&<2K#sO|KLCV303Zl% z>Tf@$$-ZyD)8DNsz%bvJR(-zER0CBwfCPK^aPXM*Ux_V|4&Oj?k>5;IzU3 zQ@@hC5M$s?Zf|}+z2JMU6TdRAy%k@*MZde?39gN;zt<)|*T4K*f5FSTSM>nl6r0e_yBu`r!`=K^uMIIKabFk;gtq;hd90J%ngj^X#BA z`Gr0@(cwMUg!K_%#nsMg(N77XA-?E$2bVO~c)O@-;Bh|>fjar32)?r1X}=XU5_KxYz@F>hnPy0N(%GcX&ff$osEqR{(VKDa4;RAh*3M=sE|d{;y>d zA3lK8CHh7DA^5$7A8_8Vh|BffFzmkKJ9s1zpf;8t(JlbGY~Q#z06*w2dL$6L^xr@M zc!NEMH}n8JCLN!_-#p{}f2N+k&sHpaj^AkCUJisX@*yBcn~i_>_q7(fw&w=1h=D*u zM`@I2hVKQxOv9=<5a1nhcJmKb1#WIj-F9i88gvp{gUx)hYp?W19>c3W}~7aio+L?+utX`t%DAlSCd2 zNU0;xBq7b^4Q@-x2IVly;HQ_>roHJCV6IFr(<141OE`PM%Xu+GbBkK@WYNu924vof zd)3cSFtmHm@{R(aq%C0f*fZh%HwPl%q=v4uWsk^r4)%82?N?p?dq!U|g6h5pg9OrY z5+CM9IbZl;`YMkxeQJ}*YJsB7U6urHmV%r@vPF%U~;HxfeDMx9S0o08?55A7giV&ua}Q`nC4bGR~nh&DS6hDlRwP= zz5(X>_L8m_)=jQ!an83 zV6=jw?1H3@D=TJNP@oFZM-bQ?AtBB4Of0)geXM+~ROBb^P0Vq^9?K3~iWOyBV-H$Z zodS-Mmyw)b@GhILLG_PSfL=1g)J$lnTp()_cGDPjN3p58K2 zsFi!Y7;{R-lcwf$%#gm_x|$dR${)tb8XRNb<_js4@fRRr2wBhe=M23)3kKN`Ut)u) z3c9gM01hY_x5i4B^9$8D1qjX7CVLiab-;j@urz}Qq;owXU&2MyI*5^m6}jz>rep1U zRPRm-M~3uTNBjdH`6kOHDZUF6+8F8#G(q*jUV{cTw=$O=k6+4V9s&e8 z_d>|uxQLv@3)?Gg+{eeTspd%R3A1vNIqts;f&0a;i1}|>(!3_&F#-C8Yl7gouVOR> zqk6d_Jv4`$@uG+)I*Xqgi-&@}ds)@-mlpRuo~Gp7SJrfa+7j)o#UGQmJ6m*8${CB; zxy7C|HPwsc!wyKd<0PxmIYXM605_u)$8K_nIgs%-_Psgc+WGMxJia>s3eutobD~ds zjrlkxi>yjogufadIP@P&>!vP;hsnR=n`?f+HA{9AF709&@Yp|f)xICfw|8PbAlpHqREy%8(3L&zG2s9iNWcFRkwT#3~hfr z^%O!U4Kj1s%hx-Q9hJC_=ij(u!4_~3Nfl%HsA~nsYUN8K@DA^;+WWiXO1Kk>AGcfl zrXm%0{Ht)h4L7_VN#u=Ef;VJ}4rtMVM_+L!P=j(0IG(4|qXtiJHMJUaqsYERRNXzp zxBhZ)tw}8UR}QSl5Wk`tWY8xv?-|%v{Na`xJvG9Yj9u)QM-?meT@=P?arI>Tr?;&g zl@!P^9=O-;AL019VAF0Mb;zn88Ju7=E4+8_E;k+Fe*PMnO`XMgPUvA0Fa_zJc7PE5 z6xI@kY*Lf>i1kXd9_37KhAH%Q+CrFb5B8BWztNSWlMOVF_D+|DyH)Y;dfd8vYsmHt zMa&8Y;65O!-PW*vMuR>l@{PbewRVQg<+KfhaE+w@ zW+a6)XXhhpfQe^jj2|~;4x%sffXykviS(zSHkTFieiVIWtY0O}jj4JA?^$Eb-}6bS zjGq7H>J5Er0cAO9_XX<=FvcOqenMXp+ml*S|3k0r<(>Fbc#M$#6sGoX(!S}r5+Eye zkXb|Los`_YH9-h#&f^jb6w2&MSyg+gv?=Y#ujJ4;;VUf*qOX;PjK(;F(~>#V7- z!0$5gZXWXo#&wr@z(CjL+|C}Ss3&1OUg;Dn(W@RV^1XcIty5!K`wdQ2ZI=QU3;tJa8FbvA&r+Uc^%;I|sws$?-ih6#{nde?HNp5_GIQ`hY z0`joJ621mv>p?8^gj4KGU{jvT2!x*bD~ zH3y18)E8NQPHr=Zip*(L!aX*Ul1<|t&9ItEYNHB=xcbJ|7fnSdVvB%The9H9qowa90aNdZ-B5B(&yWaw+mqIOTg)U5Vt8h^ zB+U7akxuknxBnsuBTzc6gFq^8n?ja$YDHIiEp#(FH%zMD>~)Z8x1dIWcvV+Q1#GS0 z3yrU5VZ1vCP85NP;RK98LW-iu~KqDn%ma zY%zJE_Wy+x_?y5t$~y|3y*ot&unc~WpQEY+6>YZcl`^*RdvJ60l6F_T^qFpQo8r?< zyN)HqM+AjDkdS*?7%}btXLhG+Cnppp!QhFd3M{=?b+#xr(Zn}sM;r_aT_L-f*6op4 z{K1*TRy5ThD#hD_-Xp>&G@H9HnA?uT>yGdoTYX&h%6m-xr3$8J5G2_6BrE`IWQiL* zGS8qpQfvD8Pyms_0COp%dleKuXSt(}sDgN`fjL7nM&0{{>c@np{IcsP8Ps^`U$*)F zL$eM37*%Fjs)^2Ine%tE)WTdY9SA~{TSU>h;dIp_ks`o>gA68Oztv~)fn}cX8saex zDK_L$&rZqr$@p;2P5S$Bbf#w_Ant2rF?P&S)kCTtJ@~o{A6(825X=Yno|Wb~H)egV zno~aH^iSxig$6NB&j%Cv#lcWvb1e1?*;$4(T!dkRGa4mta;r2EuBlmVEKMoaIvN`G zn+a_xRvIk8@Pyv11@vcZF!9#ckQp4*CZ2kDP| z)&^xFLDB(Sc^=lg??_YQ3k$3I_275Q;O!-Ld$0 zGTa8?U}@W~0S4ybX|&Bbiydwf&Am4*VUb@NoHEYvX? zh8q8wpuAJIbj>$AzMBKUk5glZ?#4rcg3zgHDUs~5q#Bp^;9Z>9dF&vw0D4nW z2;M;Qg_R?$MC^MiJtu;fD$dcG6m6QC-y!Z7^=k$cH#sCLML<)Q3lTE$8UZ z9GEX!4X1ix4U&lkB}M5VnCqZNB-PJaMVJrmmi27^Fl-7kW<(i$xV18S&51RV?cNy^ z4OXbicbIQj&=tAf(=tN~c{~3b?3tnpd=DZq&t=vs2p{qEDVM{xSu*bKsif$~8kkK} zkhcyzK~+!o>Tfd9d{ioFkG9L|?@2L*Fip}J#_;5;pbl7SsB+f4O2vl3Id)Zf(_EZf z^eH)f$J+7EAa=>5rkF8Ps-W?(6BOtiXS=@vb;*wJcF?wgQ8Xsd_M34tr0=~7FV&1l z%Bc#W<&kbws33#WGnKW2@No$83r)@CHGCsxGJoCRa=MmMV8d`BFF;#Y$yxveGR z7r$V6D7RcsJhoHBM~TihgM`$0n0_mgcIVFKSU=gCq18LMP^re+tj^ss2o+R)O+%I@y3#Wi0s4c zKI0bc-H|_4Hwt9hDD2M_+P8mdbT)J)jHUSV7*@JA=-nD~DWX=Z7iBx=sqlO{liDC! z&p=+_!3CV`YXx%kv_mI5)znW-ywk^=co3;&e&4p&uU!Esk-R7u!pk@H+cppcqX=22 zQ6PVz)I0I3KQqO@gHOk3s?TMT=^Jg{HCOUFEEYw~ANM}ev|B`zp}96?s$B4<+adf) z{sF^fs0&TBadNQ!zO-G)Nf@kas&kV_9fJ!ZpCMZBTX`IR)j1k$#FUw>nd)^jq2;hD z-))?6S#n)@5~7KCin29S+J>QZ_lE5Z2IzfTwAci^sn)z5+OZNcQ{A5lzG+|oPZ3@Y zOD+CU7*wFD*OGrxO$>e@3N}$s6}r{reIT^_gt)FeASIqmbm?P;3DD@qEzQYi^`1c| zBB^Mu^(p<8+5pJBT3~Dgdp+@p5^D6>WWXL45MY(XL(+<`DQ$Ak`Rc~66PIQjZ%sPs zM&6SVrY=kzo7GXJzIQJ6l8;X^XYKynNCMpP9-NqJ!}3(;dxcww(JuT|XrJ8?3F@+R zU3dmrKYx?(uqtQN5H9nuYE|!RQ$10uv5L$7jsd5$&Ms84-Oi($^&#Z#gA;w79_@Sg z9hW{cx%h{6S7mi@kSBP+#y&$N{|~n+UAz_n7+-=mjCI`?2Z{K3CT1aG{&>Z(BtNsU zg8d>Ze`xe>H3nPcFye0JxvyOXBco6xROvNR_PC6K#f#+n&zN~ZMvS|0i@Y}*DQ4>w z7%P1hx$6&tvGFOWTKNXMD{I;CG;l~78WjRAeBCf#H2LrZg?sGgtUwV`^Vh>id1JS@ zg3Vbs#C|MPLs_rNpd#(i(I?RbY zqJcNCtgkP9Cyb_+655ThDRQSiUncA>EL&UOAf0X5u}1DOL%_rQ2Kwq#fN4ZQzVuGT zb~+L`hMJ4Fn1I?cIeqzGJO#%=B?ly=)aU>{`}8U)Lf&|=HRtu=AoFppqdb8Z)Z&}O z1-oa<>X3-Vv{%t;)PK!was%W^97W^<9M`r0Cc)fhEnyx!m+rSPxH0EjXBosQQ)s)D z#68JW$ozp2hKkXW>)VyE_X#*%)GFAdd_>mujqQ7=>mjdlH!InC_C1(dry+Y(7PkVJ=CzG_yn1?IKWIygznO-qVo0hEY|n zhZyRvP4ym5eD)D5v1!XM!lqGuxjsi^7)3z{eRmz=OWLZJ)6sr5@sGH4c2!#7KXzsg zSrDY(|F#{-zY=ygM+^VG*`T78BXS>|u5*OAf<7XVVsNZ_Re%=J=OhorY1csR`V_-S zC7Es#bFh|0o+8S?!Vx3p?4tr{qsuas8yq^`>qHZ+eSv&&IhS5%BZW0F!Ko8`dc^?E zkMLsOW|C=YOh80e64b@9r#KTMeLU%5O+=Kv2fTe1~KxNgrBZF^syX`wq9m9@={}dJY#% zh@~+Dmvth^*FN@vF2j9kpUgE+Z_=5WXxk)&D#Sf9zKdUf6y$2YpLr&y@r+30I4u8tFvEc=hs-p*{OB1VJFDyui~D1;>g5co!@;t z>*l0dOkyRQzH%p}e2d^rf4O--sUfB-|IV+sln!L!LLdJkAG)B^G_FSZ~4raeceElTn{qg3Y}C zbugm!G2!y8A*ILKMU0v`^(h!CQ>xT`PXMdeIZXOy`x?5YeKE9gp59|*(6~vj4tD7v z)sYxXK7>95-l!?$-5nb7%K=f|?~W5*0X7&AqbGRL4ZVGR>IQD=RMaqh37uMbUS>h& z+y_@V8kV7@0-zG z5iNV2CW-to-&uEgz;?)iZ!wzhZRN43_WVKzD?WQG?toj6wC)Cx;8v9Rl{1520&bE_ zqRhRd9`gYT#2mzLCh=)CkVM8f`0z;{?T+fv1!LW)6LRV#b)+u?hII?J1TNPS9riJl zUH`%UkwLE(L1q(MOdZisLF>Twm%n)mv!2S3 zy2fHKXU(s*Lgf2&+e)-Qn!-TI*zq==Rtp@o7`p282bKOa?ah#hj}PvT&;W{E49!VZ z{1HZ0Wn;m9f^KkpV!}2%cf(;&!Ad9EH_gN|HP^*}p+xryg20#J6G!=TeNMuVrVbQ1 zP%BPKlzJACtGwygL^vasK2&RT(R1U=1~Fk@Yt}~{O6~|m;1Zn zkz4pXCWWzYUFP?MuT;*+^R!ENMSHJgvw-DyL5g>Tbp|hZY?z(@x%h#OQ(TY>5r-@)w3!7 z1F0rwl*^uBC_ZI|NOXTGEYrYb`*IW*Wb;?UzmB~u>YgKc9`{Zw-N-IKt+^{6tnJy9 zQVkpyN>fbJ1V5T zL62zayipY`@fpL5?$;t#6oN9nt=7S|&txIDITP)yl2Di~P8BkfOlOzG6U{U0Egm}U zfm;-BYWG#uz_wsN?H^fT{S&<4b12P9ug{rC>bRjl^sk*0;!SoPM!u0e2XbyD(`g3Wu&n`X*a7e*EJcvAU*^ZHTyb~VRo-#Y z70s%0>?;N#<)yZf+J?{r2<2MC;$`NjCSRZfRzBJb73q~V85o?Hrq876yPT?7@}cun zFiQ&8l6Gv4$I9k`o$!(O0j{f0BLV}gD1d6PdLbDlc&nDxZq_(%C*5hMJL0}E>NUz< z1ylN^jnam*j!Z9s-KecVz`FoyU)I=7yWX4Tq$3z30&I>&`hBuJ^M0%U(lsQ#F>k-2 zORPGam#sF~Qtt!P-D_yCc3pA|cZ30U$lkdxv#J{H7zq^11hwK*`s9=uD=kO}WQ~-6 z(rvDan-Mnr*tCx7fPYeNha49&Qb+5Tqrn?Kd{szHXHlQB)r_h3Ca4zFz0?dA8@3uP zW!!x&_FzGTnbAc|oX%E=oUCE=PNLN!9{uepc7*5`Rnd$zwx>gU!$aRl_Rcb5O%W@Rt-#V{ZeiSX~$hr({5P?KThz?rLVc;-jkFItlrz~TI4xq4HmXPe}5>b*qwtS)hSvO$G41=>1i-S){iHyjtK6I2?2+*!d}_5{fpHmE|P zQu?B}j&c@2eH61cgO!LOs&F1Gv=>D!)lBm5dIo+2`P=Mo-j3G1XP(L>P)Z5YcrC+T zliBS!E9DD3Dv>GOJwyUB;;}JFUei_Yeq4vYd&*YHBhgoD43bs5dfl>BsCN1f(l(DY zFk~jme4)L(V&x<8?|&jHbsS^sU?fBuo{iD;=F`g*R2r6>!rmK+tva^IKF9K|;FyB^ zAlw1tsy`sq1pKP;u4Wg?zT>oZn7FYXJy(_ z6%=y*q~;FZ%xkyP6|`!ZI;AJE(K9NCPO*+6ncA9m7Q`se;Ctb)Q2CAx-qkC-1U7JJ zd61GVVxlky{@q+K$DS|r=X~>m({Y@2Bvq@>Yp|lA78PZKOf}F9t}ZkrM;U+c#LPpv z_%Kgj_)+$ZXjIxeGNo^6q*S8Tkpi&>xnqNJclV?xUU0|^q#}yALJWUdvQQ@AHYu0* z`~b1QB&QF0Z-{BZi4PT^A?;`a z!8oGL`bjI>Dk~?SE*!Sej@=W3m$I`D#PxSMuBR*sm9Gi^qjYfE_Kj>P31buqODJK| z3$%B>%rs6y6Ph?kjqTN>s5y>{Pvho>Jg-ZE;-;R5XTu0=7wM`GjXP$#jWB(Go_lTS z?09vGu2y=R*5!4m^R*Kk@1f?5H~%)|Y{Xrt*`sDr1zE84+i?H}eC@&}8S}9iKdve@ z{BSG-AliAiyrvZCIt(bXIH$o%bQ^F3`EfH%N5b-A9=n9+`hAOSu_7!x^xL^g(!`6F}}ewxsk*7 zU|ag}#r08lUP+ocJqp}w7&kq4uC68kwHf3|DtBb4;2{a;T;E^tL-iG267^_SgI`(u z@d!7#ed|ar@A$2hZ(|6V9DDOGyc>K#MrK*#Ut}b=g0Un`#J$`>&K?d`TdNP-Llf*= zsn(NtN#M>{GqGkI{~Q`=t5$mzYlCZ53-#A#b`xiuK35m-l#Q0p-9=ih?yvKLl0eF9 zWAVbKhRx2@MNtRu!i-;Ni9Lanr>U+>_mt4;3Dfsk>^AExLQJZgB^5ZHS5ti5Z_{Sz z;Q~%belDa>?W(IDqzFPk^L3R&{Yz6bqgY0}|=vpsy{FXz(aU3ro1EoiE~a+d~INvNrxPFUxl-D%Iki-gqU@ zo(DIlrLi_D##ZMsB=006j}^dyaIbGD{?{KR5VWcSbO@c(DmDUz>OF{-GC_A$r?9Cu zb2}NKQ%Cthv`{R`R9b^0kdjaUvhT+E#F9ON$HbH2Q206tj;MC4O5r%ZM(4b)i#t=g z4DC`N6OR(Lk~u>_Q?kU>5M&wVB)Rh%P8NNwllY4Ql5OdMNBhHHAL=$eecQa&HuVlT zuxCE}F9mY#lkJm{e?yu$ z{u|Q7!o>6+i0NN#7!$|;EfM?QNE15~3+Mk2()537!wUXLP!sM$3!lP}Zg0~Pu=W86 zPXRDDIY~nNkqiwYApPeNln8YS^J@z7^J^O8zu4LRd3Bx9Jgw5W{5OmF>2Y)EqmJSH z6?_?iF00bbc4&$f?0|VwRu)n~Un`nC&0JMyJ3vKQQbSVx3Bf?J< z@BHEruGLk*aN^4wWX+lbAgt`n`(}6FuL^n!*9KS=AVafENSmf6NV19RL`d z<04iU-#qjspkojqY5>y)SU8UX5f4HujoXhB?yS-RV55d%2;VfCA8xBp&lOm}jqq3E zRqd%(#BS*JZ&@_#!Z2#Yoj>svAa@%x%$(}No~UPGJ0QitODgdaX7JFE@V_1~(=yhP zeb-ZY0SQ%fKLdatPJ%o3k;{L4$q5)OB^8+B^JOz;64<*0OK`VyU zo55Gp23d$A^nqLYez=&r=1gRbK!6jl zzAkH=H=knmJNw}8e>{CTBgEIYc6^N=E*QuZz76=`7vfufUJe7m^$p*sEWuM`LZ z#9!!ELEsezPmX}S+$#*$shij+%pUG7Y&VDzJ9r>J-|rtsrqQ`cv~atZ_tEcHulFWp zRMw;BwjY9@SQ%NkbJ(~0J7^%DFQLBxK>mLIpJ{==y^CL`KtEu=T9v@Tzsoppxlt7m z+$4VE57;0lFF#-h@96YvzZ;lvd%L7faTrX405866wqR&Ln}7M@es5vla36e$e`;xd z>2H2rg(dN3W_qWudar*&F)x5zU*0DH2aVxbOz2tS)2;=+S}%dua&=aM)(3dCe>N*3 zLJVGn(ez{YIp9U&&}rVp;l(NYyY*YR?3$tn@yWhIeRl znj7s0c&I6+hJMoWD5l^FeBobHVFs<%dq3qx)(EV9tBHH#7yz7ILq8DyLiooA0q{eZ z*jnrF^g_bl-4n%`NkjPcU%{^tZbSM+YkUbnOwB&-w}aw!NZC(0oR|B! ztWFLPB5oaW#W4x>vM(Sr{ z9q$Z?q8Ei5%WGl=%#V?eZ`y(^`SWSUuNCf2+MSm&az6IMSdkdZ5&2y?6J$*+bET0d z4o5Eq4+IQm^lXT;_|K{3?uLKVUqbP~J^@;U9|{h^})!?S_P>39nM>%%m~9^}-R$@x4||=qA!rCrgQ&6E6(2ot->(YkUL~ zTdHa{q>fs;UShN^MI>q>^ z3gHk+OGbGxoV#Oq@+2z#(B-wuayTO#0e~uHE)!~M%OfUQe+|}nfDwtqHg6cO;QMpz{K*xl-vM3O|G_>nW=-fknzPav&)fL#q68w1%!hqu7$^ep&?T# zXgBJv}N&_vk5qd|`zr<&50k5Fh4{rY%TLYmL;iY#&8jzRJowh~`ql42Ne z3@=AavVtW=pDyepQA_uQHJ3(dL{mSf^RmDRnUybyjkOZaZzuiYqJMjSZHxnXwm1Tf zTR+tSZJCZ^g^qx>Nx3|+pS5kLBMpjd_53F+{t!S`=HJ~{hUPNU51siO=-VBUk&4OK z+xrrlakB7KaMw{xk3W;fu$^dPiOjg-dc-KMEkLwj6hk*y`5&P7Vo8iujyvZ*xK^P zpPt^@{~N2&FzYJ1^F4MXls7l5q<_q&4HtgO^^=0v>GJK*!ghSf^%aI}oqLyRKyp&E zEc)y|$4eE4v(7|&QAP_(@~=wzcj~+oj#}WeDkhH%UvH?)O6LVaH8^ML?V0&3ZOJ@} zAQb77_f#(2P%4*UdprFgb<4%Ev{Nw1g6&7^`HrpNIiL)1EXa9&b~Gb8jEX`6(IPzo zr8}7?p)g$Z*s=!9EUv=B0Yo0{OjHfXKDLA^f@%q zIWi9!jq@VALO!DU|4??0&6!1wwvCgH)v;~cwr$&X^2F-cwmPuUUSSbW0=~BZ1QVE$R6t*7cO?A*^!--2AR$6Ta>ewCBI@m6nIKj+urEx z?Dnp+%Ma-uQ0z1;_!KSdf|sw-GN0K>ypvF*;@y%Tp<}b8TUd}~rq_>f%R=1F#IH#9%2^e>S_uwbgbwK1E#JS_V7JWonCSR>dax> znmf?SHDTgFGnSkTL}}=0%2T(g%u$ZJj>wDRB4jaTReHIs9ud(o9R4 zx#f(;)OaqqPfO&#jR-Lra#Zp-Z9`lWg+4wclcmg7>4sD#&0Ud?5|jlXwMcbh>i_Hfbjq93Mn; zz~o(X=fH^<6Dw1v zQ`>hjd!$haj8Ks9>jw;6f1`AV-+bsS%Oy&B4L|GrdAzQvYBt8PEE=WrKQ5tSL+Y}8H`vr(gks;f+^5?PUv{EE$)-X`|YrYoYuLP3-7 zVVC4<0qiD(STlVWm?Ju3E1dJj@5djPnV-|Ptr1uyZ8|5~Wi@b2PsCdU8ufm=7_fzq zv7)6H*DX&QA^Y2wb2_ZSha>$yS|shn>|9#>Du#oB!vA)=r{jNin-*g(gg2h3b;bd^ zEM1J*He%lP%1K;(6vgdOR(yDG99^BqdbhA5i2Q<7tFG?lC0|ey`g|-4nXK~ZQ*R@7 zkX9Twgiy=vr%>r>xD)|o0GTf`HAl6ew7@4UBFpaMy}t(Wic7v zi6)CSvJVdt=g8!CgW|g2jL%K1ZDf&kf6IQ>j?(V?ym&k5pMDv9(z}%sL$8Hy~@g*P99^LQbGP)`qBeG)qR(! zn`^Zbr?q@D9sV@3RBzkn_b1l%FluhKAeMMusN5bc}#9)i=t}7XS5@U zV0c30fvNIu^Ju0&-TGMLk@wU-EDQ`%uxJ48{_&O3C~4j(S zU!8P(;?=-9u=qBP1;g6ONJLCmBDq6DPi%_)>FILf^?+o^%??7n+D>A>*8!$++|G#%Bdq3cjsA^)`d%u3u)8XCd@ z416>^r=tEr6m>NM;+Q?NAx8ymEONxF!3EM7xc#!+aAC*r#+0)`i%XBrnvf6jdtF7_ zVz?f7wxb})m#@A)_UoVoyiC#)WP@8gZgP59DvNL}lPErT>Rjx(Cx7=r? zk()ox=k-t%R4-sPJ6-OcB3k2|rW~F3dO-owL?{i8+m4F8oN@ZZ;$Jf{Lc8ZFt2NlF z?r=2d>IyQo{*Sfw^D3FEOJ^pYZ%Bqa@0qOepB}U|xOywy$)_;Nm7I42!wH*dNot)- zY;aVwg<67&&77MOXr=sj^qlC6lAN08QIF=wL52<{ITeMoe;x3d5hacD*W&zK+!4=` zlv>b1oP=D{EWuC;EU+a=XwBc<9$>y1dHTb$eI;|TY?>sxB#yV4)4%Y|EO~F`SP-6M z4wEE8F~>W`T!!lHsz)F6Y6JjV1ZohdM7(!)}_sj&)BIxIx=Dn?|TrM10&EG88V1sS9a{% z!LY})Oju#_gZv`buv-+5?}lwK49OET)iFwGu?dHNe;te3MYmm0FT-x__m>~~$->Lw zBKvA)mEZ1`&Qq6!OT1MOV!m#^4@9u|q+f6Y6ZMU`$9B!-{Ngn2oI`aBZJHDbM%&Kz zqs!E2QbUq2n7IjH3zX%razwb&KiB(Q^iEc1D*;Scyv#^pUKUH77FlDbh6{-4V7gnv~I`X%tc`I1J zwfTMSJ6p?!4W=c^Fv3VJO^!>cu_D%pMUab{Vta=KPOqOI&9f0%JnDeSY%4X++)K7F zPWQ7qw{|QLgPG>&RM4l5sY^>gF>V*C;<-0GE5uPBn_b%aE)cZXSF05!vxMvf7H0pZ zLQfpY2>|ze>^x5EqcloAWY)%YANC6j_3ddAcUGphhPB+?^W6K!n3z#$Nt?&=bW%0z z%I&XP#p=n=jFCA*_j>XjVqp028+{-DeI|f|(jW$+`^pFkVLa)~x0LR}q#lj(W+{0p?Km@ZAK4fD`B zL>(G1VRU^i%O-TUs$@UkW91JfOs!LCwndEWNb?5v?)~?VV@;Ttq?T$z_Tl{zgof^9 zCx+b8CAT?c+YGN`>angR0yR05yF+?=aKVtMU)``TP}8ADKIptnOXrD5qbw-C{?idN zWf@Gf9E32R!$i#uQk*H0yviI*hCaHF;ZY+z+p$acHn>hJ@7+E0)*_q|vzyn~SKS># zmrK*g^mbb~L>9^hM~tOq-6`yJdWmIQ$<^dOvk5GpytdNtn1p(-EVxjzzWqYeFkNJ$ zD~r<)voF0%^K4aanmzxTX;%#>kJ-~GBw_T6{6bU?&(a$0iTB$w{zB~v7u~a9O3>QF zI%-WrLr#@^XQbbHCv>_?4@^xbON65}b7<`EIqfX4;tT}FT1F%~FAhOVc%v+8@J4km z#ZxmU9EODU-WVd4)6pZ~bNe_UeJ6Iw)b~%zqCJ}2<)|(qm7-_O1>8GR7SvyHAiomN zFvj(anZ8?--^^}_tYYM+_bao%ynJjTVHpE4QF+CLno8%p8G7z`Fr!+OR!mm-j;48= zto{tuqPjD1jHsYAcbz<6CsE@*31=YQbtZl43fSDF_bb=CM6Z^E`s|e6;|D}mru{i8 zl{fO0I{FRicU|F2mxg&qhhH(SAe?Q&l!9aPX@H+EpDvNAmD41ip6i2{--0|t(!;4J zXclzGI8M+Q4zIUbq*DW9miOqJ_B-Z13W^ zbaN6$f3s6Km4zrl>OC?{HW_?w?YIV8tlpFWwo$tp>yaC_?pr8zXx`8#=VH7yVv>5>8^e3B2u%-F00^F6A)GXzCu%5yxrwg& z;F9#4tdETFjYSm33d5;Eh%Vp{>84rB?>%aea;w?+RffbliHe%>w4#igX;&uK-QV$g z+eAE^&`D?(>+Dp5G=;n=88*;w1FLt08nBYk7WnJDq!YGb3(^R$&DkDBk#Jgt9#a>z zkq~P(f9ie}Cg9s0m{7Lh@UF;h2y^BrEGNKRtKFc)qQnleEFkvd$wI-r7$-^tm2@(a}@Hx?m^N2NZa*OC|9vZx{Dpw_||X{vJgfs3mY2H2VR7CVbvJpB;qw)h63Gt19Cn1Fp9HSAHA--o%}<{gDse%ETrcLrt9ont zl(o#5*co&Q+$O1`tGdx$z%2V*mgU}BzcTz*H@UweWL@&U(haL68bZ(At82?NGhxX( zblQ%sJ1P~+3DASBhl~m!>Dah|Cr8F5?Yd!Oqdv>N*IfKkpl^I@n!KM+R+TS1sOw%& z0*|{hbS>!n@{V-8Xdhvbb?Hk4FQ_b~UIWMBJlqBf?a<(X_q|@B_1F zMVsi7q3V6p;z`(ESO$E1yJVa3cE*6^3@VTLB)f6ueM#&L^+@DI>f$&DHe3pffU``P zF?_DYKU%)uSpJssF5h!{l3i=NZ*#_4wP)Qu%k{lSXb(x z97Z#@M=k7mQBnAgh&y-vJ6Bi*9oEEb9&=C!Uyo*`JbWj%&Xi|&%Lja>?D%+B&`eqY zU(jO{(#NzbYW<~GtCL2U9+KLtANDp$R8_U{8_x}=yIgzbElL^&VR78U{?LqK_Le(t z&|oFy3x4k1*5Anj&t%8XWC6yp%mtD}oEMXtBu}%dLhJ5UTS~jmJPv#E69@KM8Y6@R z8kZ&MY*RAVQjgEoe5^)zOjWEX=83w5Du@27xl}iw!ul*O;^AU|biUwZmUQuGo^<%R zn|Rb#wg_{f2V;ZZMlL2q0Vjydx`KC3^(>52X~P86LjJmW z$eMh(NO0HGGULPc-hQ_!1>yI1H0hFXnI>9-1z*~ohDthPTJK>gO>x4=0P9` z7GKcz^ybI&+MQB>De~>&{sVZ+G-ZYW@DD$RSq+XtrU!ur|tl3dBf%D2Z5^KS^|rxsMDZEaYNUq zkpJA^jQTF_khygQ`)*t}&5$)o{Ijp^FBsMROQ;C$S~S2r5ldNp!54&1z0fPSfpKWBSX{C0&Bl*SEKai_};O2jA_B z+3M{}A{7CCuO#Gy<8<4_i@1@aj&z1o#W7MXx!u`Eva4RqnG}<}U5t*ODI%&t^4-8mYfI5y+x?~c)?Z4S5_g5w zAExK6fe+BYG*my&FvS9*Gqk^l{vZNJNN>qkb+%juwMus??FgtXUA_<<{y@r9!A<|q zAd{7W;XehLtW5vS&A`sg!ubDU&Ho-`axk;8{%?ZJMeUF3qG10b0#<(l2{=;1E!=rh z*nxjZCL%M-yu?esvfvr~ncOeSB4xxlrL)(6o!tlioi6LG4zsGA%NI}M8}pu-j&w|x zCeC7-Jv2m54%oi20dQ2{(Xzjkzd-#3_~;1Y&|}jzAtP(UJ_GL3o(QJt6gXrK0pOz? z!U9mJWH3T``-{5_{!H_Dy#tWDo>cwB6d+(A9svS-J)nEjL_nHx)c*tx!{7>`0|ay) zlS~fc2h&7G&G}k)VKskK#rk-f(-sxP==t60#{HFYoLvL1{7d> zcQweB1#D2kg;4A*nVHz=qkSPT*EY1%!@v$fL^eP(gmj4J>fxljnCN)S z0wWOT_t-0;+Ju_|(}+OOwPAsT4CpEl$p7>V5P58n7Sw-1Sa1kyclyeEKskT_*ATq} zLl3!5fO-JhKRp9!P_IF25HZv-aEK;oW!^KQe`qHadOvO-Fi;;203z^Gcel(ZjvC4e zpl#58GRVVM6pVH}vCaB$%Gp!hQvkw?VxOMl7Czoas z6GTk61M=l&dcAMgj-iG>^f#)R3qC4I)tl`P?E_{a2`P?fWaCHga8N?`4D9v zQXmTm(Y+S#W#*m>FD6c3E+>~EG9WgUcoWGWgb4U9Kub^o;GsuHpbiDJ7Zv>K@nt{K zL(7AQ=TC|n1*9QRna|J(C@(Y!U$Vzu@-Z*t?!^e7$3p;meR#=Drj*i4aY*YL;os|d zpQtJ=qb#);{LZ`s_{`5cxcj4%*D&}esslmo{+kE^0#k&^1*E>sfPczDRyYU?T>D+z)VMsk6YQsSW&b;|k_7l1!*6nsZ-G}VGMgyP|U zu2hBm6(0VX8N@8J62o#~UQgWe>FyQW!;8sKft%l|ih8^Q)(7yQgDm=W^Z0XdRL~G# z_4yW81FjTiB4NsndvpoV7h#F~SYJxv1ZCHHW(Xlc2WSB?#5KLjK%;AzhXG;8VB^R@ z9(Q@i%gFoR(zif%bQm}RQowl}A3&A6(;oaAG+Gye84iES1Ed^3W5>eQd*>kDW3{1rqZ4{_BY*Zm#JIQ%N52yY zB2RaoYuq6~9K-zY_+$tAW&&+00yAc)ipsV)*u_Qa;FYFfJvhbh^>zuo4u_}I4w{&m zk5wWM`CT7IdunZ!Q{A{Gv@+g~n-pdB5BdQ8lJq^cvi3;azTSas>AS8{101rC-*VM{ z2`t&8+$TBQ8I4FU8;+zjRo;#15uNzzu2W>Kb#cE(VW=S4D_WY>QBBH}W}z;ws(8g& zG#)Q(pnXbxvi=dYD6M#w$SIXM!(~M4UNPu5YJPxX`&vLiYi2WXzy2Dl!NaX0RG`MS zCVw=|&z4hH$V#yK+KrC;fr75aWao(Emt<<)QF)U_7`dfQ%9^T^quyb4b)zx1Enhz>zA z_;CS{X|u&zJuuq#*M^rcyG-rD*{g50cw@me%VaEVbaB9btYAYMC5EKSWi8=AViV4B;bHS?H1ZY9#1?w4xqX+qfY!)ho8=V!Cz>sKl#JRL8#} zF$z{qM|*V>X)JeEXSGLPOJE2uKs|@9u|LUg^reQ1|Ky0birbQiU@cC2qlT6z6)uGQ zG!dx^eTh1CT=*9)2A$q{W^)AulQd)~3Y%GxaX!t*QMxnt>7?&uf1{x37elJuA8m#v zW>}*1+dQvAo@rYlZ>Ve|4j{y)w(6l>i4SlK2hgg_m!fb-^;JE3nzdLArdl zp2Eba7Zu#aMYrz|n*o`YuOEav~y%f2L%LrcU8Zd4Z`K;p;wcFSJ80eLxGxq&pA$--jd#Nf?0cGkX)PPc}l zNsZ^>HG}NQYxwA^zNk8JDS4OObMS`JYfjok7P=KVZ6$XfrC|8$U6&dOO%o=_X0~W< z76Qd+y>;f6(oQ(1uc;Uhs`Cz4_t7|RQdxf*d5;;290S))6096=4;Ft?7_}|E{KfuB zOb|!ItOggxk_we1TK=`)hYG3d-o#hD!tN#GqO%jm8bS?)5SnbGh|O^13ou0{ju+Wc zSIa2z2`fQ4IW4|MIan&mvhbBpj9(I(K8FJ~Db+nAAt>+rvm1Ix&~&3_H)*K17FN5I z#s*rFB)OdKJqw80YQTt%qp^!8N)c1WR7~l6zx}qPaw^xB$M~L({@p7m^~#4oCC3DT}?E{_^Mw-hv^i4A;V5D8iHEk$vgtqPPbN+-%S8C$K8a(LxtWp+($y{^+mXd@>L5-#W50M>W z5^G=@d4CN}7B~cERWVcEuXA372t3?V6c7pxUiWVWoPnl3=1)gT_}KZ$1vgRdh0wa6 zKlQ536K%~+i1jNe({4LnhKhEhc9J~Q=#&vj;W5I@5fpd9HHFU26_4ACVn6<}$fXe!t-zw~VGvC=Hnk;AUJWd3>aRl_*MhjyUX(_(XiG_PiM2Ud3*`~q=*N`#)pfL9%Z--Mg2rO@KSWG-Mq$?ZM zoUVxzW;E?+5gZaYFoaB0#w6P30RI5QSx2^@tAunt|5+o68Ay?*N2`2?yRd+mF3IQS zomO5qe3|ED|B%e&y|{FUorLGN$F#c^S^v`SuSx}xGuqi)rx9&73BT#Uh0Tr9MsBw; zjf`SPo87UGBCh}}@bx7M&rB?DIYoYy&FvS1Z+0=is_(VF2I=Js)g=)WQTxXJ8;^V8 z>t&1+r%rt)hnf~Q>xw*2Pvc%~<{|IVFN$QLj6|p(&e9atp|fwF)C)elUTPDH5#Z%o zV|s{bOPpObUMnesXe=zXqT({(=4kC7Ke24q1*Pu;J7B%rza|HudWP!KO+rW4Jv%(X%SC#R zbS>(*SpdIe1lPzs7A#V|v|}=%8&=ne(-sBz4d@lBSZ(e~W^)Y<|G8+{q(3a@y{26k zksxnp@p9KcF?`f6M~jl2CGNz+ySp)l!L+gW(9yHy{==E&Ckac?;f_7hz3vG5H?}%e zaF`1@0udv`*VORB>Q&@B$@lo8Wf=dMYRx;?PpyE{%@bq-sP45q71U^8SjVULu%B@| z`+cYtn8Q@jGZIszc`&1PN*^tcdK;MTk=HDPf%t@^$BmQFZ02P6T6sFQz4EYNRqD2X za-tRN-gs`#t2}&jtH6fRFU$B(^$KL&x(DhO?DCCucpV#1s-M!@LQOVJT0Xi3a^wn` z<)b$KL)yngN_lea3Kz9JBR$9u_ZKnxHJj_x-(L|eHfMK438KO(hey(bCvsGZ=q3i` zpcO9t83!!o$;=KQFyg{j9AoNZ8XXB68h(|aPfeFq=9*?^tqO(gC#7uk{nH(3u5XJ6!TG>~+Vz<)QG5A-TwMOZa>liVQ*3o7AcOSu#>b}klITbpd%EG&S`#H_ zyd5F=&z2`Zl0l~gG}>Ep>QV=7lKE(rBTrA5b?YNjqFYYdT(?bd_b&R=@21%S_mSMlt7|(e<+5N|;+?0*Q@S{kd!vBgSZ+kr#i! z1GujTwdf{>iUD>o(IM0TFD zn~!`f17>DqJHA-%^!NStOVOh}^FE0Tk8GY_T`;9J!PqsJal4UkKFz4e+8YH1uFp*} z$@0%moTD=0ClPDo#J1PJ91Vw2NzEA5q zs@S(%lH}u2%)rm`N$cMVjuK)xAu8Pdb>H#i!TBqllZa_ulU&5j|D7*;q`Z0NjFIe2 z8yq=9>y#wPh*_a1K!t8d@dQ?Ss-VJJUwtB=ose`byQW==9WwAZtv=n$bqthkKnmlUB`iC=<8{${91Y zedJz{!05+iI@d_smQhe2bzP>;A`sdaQ>H4pl6}ND?xtvbF^BC#`dqX$>TB|-Rq?{b78L1ofUdl!qXaumQKlNXpU}TimJ0Sphl+$ zobwuTaJ>Lu!9W9W_%1PNV2@8^%+fgWN!*}){pOg#5kNT*eFj@DkSdQJt?|K(D9_i~{_?U)BXn-5oFBUo+PCYJr*gYv0S4 z-}8C}+rw7OxS#gSLSzCtu@!e;%Kdw}<@OvXOsLbwubC{f6sJBkDW!HtmiS zV66;|19K0`pLY<61Ec<9Cxyup0fi@*^qT*LO!aPdP>EfYpRTB!&YPouKS`wa5(wYb z>s`x|$KS=k5b?C|=nYi!6(6w976D-n!tiuWONyi#oIMSih+DLC2AAKODuGFT}C$Lit=(2SJ}1M9o72# z{vbZ}SPV-bW^wns2&CE4y*&QyyENXyr(T+Hl6b?XvRmDlyBnvlt}?_F)Y_?#Ms{CK zI`*v^GS`&M{fK#Y!g`UK7CG`})0?6C9HX8Mw4=mSIOF5u96xZ^=QGt~00UMXr2nJF zhHK{6@^aH{tx|g7;Eed@NU~>;i;6XR>;(009}M#ck>M#^h&{xRylEOecfEIX2d)-B zKdov>!Vim3`Rkm9-nu0;zFlxBz_r_v30HTHF{F-u@L)kI)w9OtORcdw?xh)3_-})d zCA!xinT;u zdY5o>WIE^T6QmT^i<%qaSoGE(f=K;Te6gzE6H#@>pCTg6&XHf{4%cF|0WfD4331S5 z!d!- z(+d7}$7}guLmQMx{G&e$fSPKsDrISqr-Qbdsa~Jw6M>-mKnE8^7#GXEMh46bhsZoy~gGeofzuzi9G4|X_y-%MGO zC88eR(DxfSQsZNG2Ez9@r?5*DY!%A}Fnx$4!NP572I*D13eyKkDp6xlLMI+p9zx5@ z?(|eqs&6A>Pq;Ys$)Sit|GkXv#%+gzUV%uP3Y_1bx&C#+8zTRM(s2F({C>2bkLmPrcSCUFxrf7|oYMSDO#-X0itfuVfGwx#lj<#)D{@Snma#QWyN4X35TSWD%Nq2K40#5c1aKTeU zKU;Ax3RVEv9`VvzbfnN{a_5aE>x`+8W6rAaA5MMolfpU%q=f)jWxNDXS8=-?q2+xZ zU%Yi~C?Xr}(Ih+3zfs4ed@7$?j%#y01+PSd%$L~_!(J$Y7Vn*Kx+ zRqq~tJY9!8Ho1h&g;g()GqxUqV+_6K&E@;!ykIj2Q2OqY=4_Yfuj}XwG4w@M2`K-C zRGRM;A#nL<*30+&<@pZ5{n#2~<6wj^8JR~K{v!Pn^sTt%7&NCyqszMo$Tq3qM$cgk z&R5@~^|CSz^w8L=7Hzzi6-GdJZ;3r&`_^mw)~9eDb(p}@LPy?A&^v~{$yTQo6Ss4Q z%2&zgcE^_H7~=7}4r$ej!94drYx7ut2Ub#qn6%D^6z_u-3AlBjGWXiM|r^ zhHy>aVj6c^W_sme7ZxHtrzbn}Rd)tm{D3jR zx?tI7mdE6}`jb2Yrf>K&JHMsUyNNT~XW8}j&GM4NA6n=(0IS1l?l9-h)A7OXx8RA> zI{E&V|0up$Zc1vM9G2=!Q*P<3ye#}7StP_FxM>*Dqpl+}2y&RlgQ#}G?}!PK?#-0i zS>m}r$&C-&9M~~xNqiS9fMdS{_9KdD;=!aiVFP+i;V8szfB4i>CZ@<{@FU$IN@CLZ zD~n~~X>5^1 zvhZrsVS0bSUhx?zJ2#R8!gPl$>asdqE6o?YcVC>mnLI?eko+~fMnG;#a^kH2EjGdt zm1{8i4<;jc&`70{+{H*KZER0>ZCmAJ1er3LamHxVz@5#X^OSLs^pIj-IIleaYEdS? zhs1b&dK6bxDYsva1{}W}xjv&sLF@SWzr41eM$-AHWq%r$eJi95toVrnl&d}-Dc#K? zU-&FI9XV7b#Q?-NyTx#<(h5~Hjj*SdS@wS>OdL9IP%uocao2Y!zX(kpzx{!4Hu;SB z8^T$996JEEKHjV=e*fq{XI)yE>_--rtR^d^ekvvYOKp}+n<5omX6vlRE8e02M_L4F zmiPRfC>6$jl7fv;zU2LWF2m`##HCRm-DZ%W#cx9uzlzMFXPhesM_Sa&cdT2@Z5A1R zw=|2L@&OL|_bx%UA9E#9>vc_-+mU#JrQScMDT!MT3s?sw=#y2L3+=jboH+N*fz5|K z(`7`Z01Vm?EfFxC^llmgIAp_z?dEb@A3|roO*SgZk9utU4j#8%kKUYF%1WTM(+O-) zBx4FmKuRE{p~_dd@22R{aGc~(G#x@mCVz9JFb2|SS$QkTLwPXBsB&I2`;w=KYe1oj z?nt*#bo#OnA9Z=*qQcsz4sllnsmXIIiv9#}(w{!_b$yo~Zj^Y}rXy#xH&|GS+g6)3?wd zWcEIh0X1j&Oq%)pP?vMtm$B%tmq$!Kh`F90sVd541#BO1jya&by_uVzTyKUsL3j?y zJ2gw`g)-vZ2`4c}>io6SbkH|CJaLS=mJ=G_LlkE&iXZNdP}wLk0X^ouvG+oLe}d8! zzInIhi5HYg`;nx4X56qOJjg#>2%{gQr_gq)&>z>QuWx8mdp`tGx{go4KN+N&aV6DF zdKe>3YCyl5ltyfC15R8rr%g+8g`4RiTu`o_@(_;1Gmd5ee3M{}r#3Q8Zhdy<&02s= zxyW+1^Y=9l1?!L!e{^V5ZUN~HweP_dA8NxPa^aj6NeMXcL{jrSWy>OVNmo;P9oF?NV|qE;*%FdTh%7U)eXE_Zm?-uf2XZ29yW2pVjrY? z=q_{ut;BJDK_fZTbLIL013Ocjj!%r;`@vK#W?R!njk`F$a;JZrJ*PNh-w9SNqDTsu z`WVr)Qm&bI-wr>>en8&r3guTe8se7d3GQyHu%udjUA-(_9ZZkRY~*^=zT!kNDUZ&z z9pgrUQdA9Ak@P!|$C$KgSY$8vGuoqEt8Vd~E&;kHYdq=;haG7O@mgOF#Y|0=);4Vn z)|G+7jBh|PZAi8*%Lb#C&-^$C!2N{a@q5~LIa%q&FVH60Pn_O%*AM(Wx)JNZmZ|rC zOFvsmAtVRKJbc}ZLd@S1uX<3z>|oE~odw1oGpZHAwI8PN4bo0Uv>i)y*xEX^pQzi% zjbWso@%0tn>^JN){i-tZfv0&s`TO@%*czM<+81(D3V_ofG~-vK=bw96>Ga&Eo%}bh z|9i9aIOYm5#!Y!6rg-nF0>XJG77H`oN7m28tPx>uIO6%FXm)!RNj5<$CC3xlMN~ap z)I5|1E>3W)nK!jZL3dVy-oe(~w(B{9f;S1%#n(1-|7uL5oZGn39awi-VyItBZNjpB zX!PI*D~>yIXt+?OE2eE*&1%uQLIjENDiQfC;U)*aNJ80fj2uHvHBR=bscPDv65X0@ zL+`dh3gN?kIs%90wX0tpjx7%w%T|5Tmggjw=?8Hvx_66Re z{^sYTXN%s!z4LEo7BRs%javXvafKM#e}W{K{sSbz#Ln{nCo7l;n3x$^+5ZzI!NkJG z$?<Im7rMufV)#@o~l>=?M3oMa#SyiwiKR$=XGo>)I&`4!NK9PM9M zMX0d2JRA`kkdlK!KvFm=fRI;eUQk?W9!yNA$mU)T@=Y8{tO(Ab}S}=+2>TQIG4i2K;GEf$1s4@%Q*{MvvpHoe159?TCg7h{#!{7-iNf03JN%lOACO!~ zJG#?5)Vn#}i)eDIegpxe2n_BIT-FCzcV=;7XmNHba%E|GUn1J7VaTKWvx)(;rlk#P zn}xIIw?uAp4a5Qxy_J1^Go`h@+P?1b4JtEf8zt+;{CQfFfY;j6!gVpH*5I z0E4)DxC{IE{Hc7W4>r;Z#K6Yx1cCt~J7v4;Ck`1AKn5_Ly~my00@8XUxMl=81$=#d z$U=(H8*5`zzw8_Xu2SVhrF2xKqR($)ewKbgueSs9Sf-r;vqaH60)^_67=!xWecPu2 zAa8q)e-g&A(|(jU@sUVvWNd(O053pT+duCPZ((SMKUuKgyFHjDwt_kkAfo_f{mh(@ zZK%h-+n+a}Z>P7Pkq>>v@13$A01UEgbN#!t?04$-kGQRYt=-XgEO7Yvv|L_8Tpc)W z*whcJD(JWGIFo>}v-!nOMY01EPA6sD5?eR?r z3i}I-?+ZiFJYd?(pHl%ybCX|Qc^rXmPpQyQ?WI2@sCA6>tlzF4Q8bnR%m9#}?i{n{ zg5lu1V?gZ+#(5k1ix9JO>#JM=IzV~Poxo(x@D4p}1+U^As3g5Nc93YHBX*GAh40t_k%}Ma0h^0I zqd-(*2l|7+^(?Q^0!tYG-q(l0g@K_7B1lhwQo7?*0yqNXPV_)4SQG+~U?|e!tA2-5 z{h;-KN*mdJaqrQ?&td+AM&&t0O$ERUh|e0o>Qk1n8*3}T#l#!~JOax>zvUq6fxk;J zAjA~d@|x-b3fJthKJV+?A+oQ2NM!Q#1biBpYQKq@EFj5x2uDW_5k@~@z79l51NVRa0o9Er%W{_Uy8=qk` zldwM$KhnR=6qelbPX1oq95Dw$7@8k_j%)*_roUhA{RqwT4)o=70hA-J(iRtBENqSM z@_J;)JCQ#nX8W(=5BiJ)HB;Yp=n%7MfR%m_Cnqqi%%9X*njRZ}I)F_WIO-tMW8h~C z<*W>D)%PL606o`_9E{hqD=3D*zJ;HF zqVoeEk%caHXDEQk6A1TP?kV@AF}?xR!c-2>B`Jt-_p{gIM++QaCqUd9qNz<>E%4{O zH>JZK1Yg(EZP>#v?y}4`KkrV*!NS$g12S7eG5xsb*nv2XWA(|;Q#$xF1Az3i_E1{~ z!PQEsm;W|*AxW?1=v0bn=Lb?~&vT=&>rGEb10T)wQ@zsAm0F&Av>|ruCYeCvZT{?j z&spYP&1+=0<1L*c#y4|Kaj8}>)yJPKGbd6mV)5}?F3|+LWX1qlh;weYU!fqYjZjv9 z=Tl$|2QZWxRUG)h7ilv7vZ!Mo)t-B&L8)x!a@k8XJU=+->mAL+BzaERnoII#INd-2 zXtUq0is#1XM~Ub1Oh4wm;xo1?ZZm3?^>t647!|@Ea8n~9h`Th#KX>y{{pYUF0nNwp zGHuY~C|CZSNQ&s*GbQ3sd?ePiFi3=H9&dd9L2ZDgIB+@JlE3g!H|%HXP!@aq?Ci9# zW$-ntR@$OPs85d{^OqX5I6Pf#^&Z)r%8tn-V&OCso;43_-TPcLRpgmmB8b3F{>Qlw z(k66@$IDCBZPe}-DGMcqrsjd-=6;=dt@+9Fkds;+HQRp$NNr7h;Q6qjfro~f4C$+J z=5XyVQFi`X#heMW&QkCCnLl!S!;=%N)}E2O&snQ%%G-nAzK_|jy6fz=$UX*Jfcqcs z7@c*LC8y+Lj1(R4z^g)sjJYqZ9^gLzJiHj}gRiN~c_l&JM^Nphj|Qg|#J;{VIMe3d z%UL$jok@7{HdMxdTXygkZRV}oP?3@GKsvDHr#T6$aUKNiLR@h9>P1rIeiD;67^W^I z$jv@I7_Nu@w=InwpEpLKnhRgd3hkro(LTia?HZBzqAR*C(s^s#N_Ad9AKGVGkx#1d zVIBN3FFR|yC<9NM=%uAppo}^z0IxWqq7j@g^AO@6_3(I>VJV)a#X~P#jWU*fo)3? zsm=@0J*vP+#so-mCHu#_dDjaL)vEO&z5SJQk$1tFo{XIFiRytZrN;9j=Q2N+q8Lv= zyz;6>6}nV?J2$WB^OoVPNWgOHJ zl*Bv$yl|lYn~*``p$3C>U+!ork-yV^lkv_>-zVx;qH*O?-nS_;!!7+NO&6+B>B){X z!>K#luf|8{W`h-aq(py!wks~aGj(h+j~+Y1?aoAZKqhUe`vRiVakLTtQ))DL$oYef zP}fsRIMPiM`r(8?l>7;@j*wD52$4`$ur5lCgGc9u^xoZ2$t1S}^XL>%My6gXHHw0w z&5OsA#5y|&&{#R|<;jAGfe+nzG9ECHjGl~VN=PHaQ1b%Yk%}=WR^Z-vA5CI>Ht?$C z8Ywmbmv2z=vn`8>SZYC#lh>@n&o4ja-kwWqTY_gx@q%j z3{c{8v5nrbC7fnTSwgdtn8Mah>PW{unNc@(8Q3vzA&+CrDPMiJ@IGyr%9BE8Bp4mg zcYSh@5x`&h8*h8zDDUIL@3?UzJ+HjY#~FUzUf14NW~@Em1yMHZeVoXEE#|a6gVxB0 z6!PAyIdKbb#y5sh;?bM^wA^Ft_}ia4QUf)d(srQ0Wlu^=#`*O?+cY$7L>Fm9UM2^) zzSZ_V{sb+8oOvxQLvzNK6ScR49@f5CH_EJXj&RBvhD!nx$~4AL>*aQ(V#{}n{?E$`HRPOF*>0JKd_4L|%k3n-fn}fI>-7nr@f71mlDS zwL~aGAb0IH-HNNibGQSZoTzDD9nwY=Dvl5)9PA5NAiJmHylotEXOHp+@@+k}vp0qU zFQ25mY-Ql}P-lN6t0Aww;Ka5fx^K(uzq0z4W>x97-WoV%;KT6CF&t*orGtr{<0sTH zx#JO~Y#AZR$jnWM^=dw^XuY*Adu{RgqT+qj8+rG@!nIV zh=EvE8dx&NqRu|`TP-|QM8Rml$Zu^HjqHD0(kh=$yWc7eG3o1e2T_2jr!}Uo8iM?x z|ME&9s}fOJ{`J}=AnP6uI7A(1_p*o`;PA;T{-Gh>8RI-AFhZZo$`c#r7N~GL8>7c> z@`05JTYOF4z-7_{OJx*Y?_1_5TAyYq10H3`c7G&FWwZ=czoDJ)XD-i`k`Y+Has?)g zeN|Pi`Rta_kRR_5Q7YtU{c&G@L4rTp?)KFPTZ28P?u-zBgc2VEFKD#0OByv1zZG-%vP`4~TQr zwLH#oG>%HOdFK(^2?Jf8yO+l~izA)kfu$3Ld{*KBAC{j}65t{$+!ih)#>PP`A#MIb z8ZR(!`f@FcV_Wm9Z0rC8qOeSzRciIcBEVstZ z6(WrFlj}*90mffKzeai7XHs(+o#=qZZfSSV@?qHg0S)BDM50Mi%i*vMKp zRrl-KMdZnJLLDLxAI#)JJC}=2#B|)xu_-t6y+yPRf*hg5=r#=+LghjX4?RvL#{5LL zMeJY`ma@Uq;Zongvwm>pcKn=LP@6}kd__mT*O zD%g<01Z{=Hu8*RWCClc@80V4uy0U;9W4&A%{eZmBN+inPWt*hfqAOvj6jNr8v>ftN zp9VCpdr^-y?1A1bRr5Fq`Qf+o8o}}pS8!vZ;3^_HN0%=VXFsF@I%bf>Bgm?2dBHUm z_{WeW7S^3ea<^ZT(mJ$?DA;;P+n%z_#%$6Ns;~|;$flPJy6Tj>&&kvsK25Ks(AntO zB)*lD&c=X;Ay49mtKQ2Rp7;t^UMq|1DJ5FFwsfXznQFM&W%JVq<5*w1GFJy?$skW9 z8@#dC^C<+yW%E>eZMkVThdKU=;S2F6R0nH;*AvG?w64C(3meU~x0ET(JjJ&|j@M_l zsc44$p0Vz;@Gt~ILipjHAB$%`=b#Q}R0(PvKJZre5rC>}`*98J-IG8)O9Z^^fes?7upYx#1H!0=!RW#!u;%kL_NFz=XdF3szp9W@V7c_9r`R8rWOC6Hl>s=k$Ecf?QzI4+VB3|>8B1@_c+ zF5_3mHo);F>|3=f*u{RvF3tJ$gQDYeUHW}({smnm7qk)<8G>%(HRrYygk+Tk|4%fx z((eHxOA7XHqKf+yES1R`&obU~WpKyXf3%t3cJ_0!k``i!SMLF^jAAFl z*~iZH*iYsA@ok4scrXYlQFY+t$}@EP-~k8UC^3%0GnGmv$t(^9CR&l7|EMK~!D|8z zD(ui%+sU#>v4N{S1H-&1x|ilx4Z_5e%GWg;e^fF%N2++Y_x9{{Ull>2sQ@MkhLbcB zkA8yP6HJ3kz)WlG6#dA=k|NnR$``3@IKq2O2F;GYkCMZSy8#P8MqWd#cxHkNj{_nSM+c&K@`DB#MtBfEi*MY@+9WwP++A8M zFMN7;K>eVwxJ7Wz`z=Rw2Xue8~YKFibbm)F4Ck*BJRD#uiq|! zF%%|~+oB$+`t|+wd^uYZMqvC(;-pF3uaGTqClEjv8!&cMzjRT59PKUDsuHH&OM`L& z0(bY8Eza{FRA?DS1i5Z!kV*cA<1#O^p&N82-b`yrsfWV_{ab`$#YxEJdt@duj+4;S z`08pZ&)!crwe<}eJ++a#@V?V?Bo?Fn1mbO{;d0`yFoUB}_X37PTvv7~SZDq%k3HXjdv>pbU=FUL%W{c2EF<4c2fl+=PvWr^S*!lb6*S7u*W{CNc@DtmjYbRRlXVPubT$ z@wd0hKD%ev89W-J}emNPU0)8yxCC4 z#DiI(ez?xpVvQylcZWgqgDLP9*L-VEoPRmS&tyE{*|I^A_AvGO*@euv-SSs{g?E*u=Ba#zc#5DZNdgRFF z8QeN^Xca@bO^Dv3Ft4{A6xFUti7AH}G44ZAFSri>sm#6pyzW$^nA8myODR;IYyV+0 z#I}Tk{i#3^lZk-;ng+7DbD3|~%69if>*VRt6pDt!`vY9z>l@DK$VFp3XvO@uD}Z}nvxi5G>Xk8gOa?#CbP|P4z1}z=T{h|JxmU%IIKYA9%ZRw19jqUSJT1xI=KL? z%{Ol0AMN`Ca@`>$$dg`MEZ(z77nVqL7}a`vnc;O1$9f2FqN`urd1H6w2*&e&*7t#iSA5gq4hQ93$@;~N=?RfWo zazolZRjY%9PT8>uc8vN$Z$tUc^IfGCpJuVgWq9HcN;q%B9{VxA9gXxP=|Jw|+fylh zUVwg05lNSRQqIXr`=Db9Uz5vlbDysEQz&H|`s}m9&_WL`?dI$F^CK1NLV>!-QDM^i0otD%1RWFIgp`s? zN^I{s7B%oHVQ}^#Pc4=ZaY?5Z1okBns7iN3+8di;P!>^mu9IZ5cZgYCs+F*nHIPGz zmM|-%lV6#~3QzX~utFjf_lo~5SR!*E0|6MM;9*QIMHwy)`i7`y>D zi|9ovyT8}OEAt2xE_UKaV7djOd`->Vmzn41wV>cuGt=LeX$j$doy!?~_1OTfAFB#W z&Uhs^HK`+cPZkO}gbjS?Qyvf)*oQa4e17vKH!eZmn+r0G@JEZ(%@3lnSmmtxccQls z+I!f~x4P5uZ*j5T!gHm-c6j|%1PE*Q_#=utPqV%%^gd5~Axl?a8ZhK?BWj4kXS&2! z8sRLlFho9HB581vjD@D-9m8FzqT?g-(eJ@#)d43H%N|WzJ*%dC}7kd$OuR%5eyz+VjiSQ!X3T?Q^SX7$~K6gPY8iuRo=pD zz(*=V0&6|Grf<%eTBfw&>gJt}UtTmeSoEVmi2CTIx^+edyj98Y3MW&KtL+aC6yrxy znSIYH0k4gp61cZ~!~4WJsH*q)W{`KLfP+$k-W%gbtu~?OJUYxNlggq;-}#{PwrHBk z+mVI5plkWHq9F>Am=Ja(|0k9Fvz9uCz)-8oy z0!*jTvu8^1j6FP9v9ns=jqB&*pCr??m%n4+mE&As7#%HQ`aazwc|i?3wOKGs_N5B! zIlP3SS9DBPykLz;x^z)X;d_C@UepAQC#tT-#H7J}c}i6XtkGItA%5O)G!_7GRuAoAs|%!& z=dd&>W^Bq)KPeilxfQj1r5*Y3(F%bQF|vRjjGpC(58o%IMnp~-=O@JF**ZT|;vH*j zs}0griw>fQ$i&X+d>s%B-OMCL0n<5WB;i(Q+}-rqeQTz>fwy%qa`f#}Za>jtzo&75 zo$F*EE|~d)`A>XX7!HT{Q58=ck6~|CC7nwidA+S;48PD?Wk8F9vYkS{tfE$7*sYvx z-m{t2Gnc- z;vs_Nn7AO3;SYK^d>^rUcoD9s61;&F2-)N*(H8WMt8HW3yL+=<;dys(p?Yy91)I$s zxDnrN>XCP5S{Op4h_H3NnPBFbUN0|~z=Im6wSZ6}W}0xKijWPw%8<>HS;0uXlQhZZ zct4?i+@uI%9C3@&oU@bKnUTpGq#ujjP)Q%dmACjU8uDoLtrQ~U+11){p#=I}BI>`q z(fm$1(%M>Ez?l5)1ht}XPe=pE0WtaWW4dPZ%N6m0S}mz7GP!@fAAdw_%M#c-$@**e zHh!rb8y4#J^eob4k7&#LMURQ@_2gtNK!4j zw)2k4h?BZ|cFl`&|Q*CJWyqevQ?kjQ;7t$Xsl6d($t?OnlC`Bw7Vk zdg#hMufJKe&PMUBtW>Xi0f9aXO=9BmbY3%{*~+BxOXUhn+v&RY{;|`Ek17x1Pz&ku z$LQP_w9RTJ)znw?S&cX0TP`BI97YFhZflRAU$&=v?s4ze5Nde6GkWTQtr4v~<$I*F z%Qj~ZwZK-UHYWs9?CE3T{nlreHzPM)*x&*|H^-O5SZv0_sg0tO1-7@BZeTRzTJaXVQkdE8B$r>J|gP87V%}l0^U?MJ0~qync$SF3hZH@Xo>)n z6^W0wRc?K=4R=KqQ*V>C^w}qwC;@=W`$8 zN$Oro#)0z#tm7r|nkXeCR*6_wcRC^&_>=XKShs$zO9xey624oR-QTMJBku-9SiT9qJ^ zk^6l1Xc@4IA;e`OIq~?t^BBG0tmp0}5bg))Lc>i&Y?{nya5K@Zc_357cOwQ^``eVy zNdrWc%K?vHG`L~DLMuI5MAgf2TSA58Si*$X&FimuFWd4`53EU#`yU7vTnhT4K)X^J zD4V^vJP;JSP?&uG?bh~_<18>b&c07+C*#9;x{?_{FG z>_5(YvgK_tuc%xgcwuRfM><`_M* z4Jltdv;o3q#+8uqjUC+6_i<6sO=cC+y72jn&oV=1^0YeM_BKIY2a1W`lan{-+_P0I z&Y5n%YEFfn$ncW47?X6vOwd*{ZKGB@gR|l+KC$MvJ@&-sRB&+ImoKH9ah7)pCLUr$ zErkY-BE%wX&_v7@^yO}6D@0L^o~0~NO5$QQ6y4_dmz#J`mdKEqXkCq4VuC5M##mZP z6mL$4umUotWecr7a8us9=kACsvlPIm#VaH+u{Iwi@rpSUUEMxd)l#LPakwds%bAp` z!)k=t@Ibs!Y~`|ZoFJGKBqSqqsFS_bG*+Zh6D2Ea3aaF(fYm-VC?Qhf<9A?jyZTDX z0&U@xB(@~H>(D;cqc@og<*X3*MO0Imz`|@WBYOJ01TOV>pk~QJx4rmvDidwdbgW&h zocb|798SAlNNPyl*V##ODlZ++jl&wwQC$aauX)=23n)Zp<66P^3cs$SPmYpDUU8rs7xZ&60agGGFQ&D ztnOW2xr(P|W1q61{6ck4yO&LGv9F}4;8y6ey9-5vK}^YpH9J>&{L|q@^*M$cTdwy- zv-!g`ZW||dgCHceW@u(czW+1H;vXL2{xB6+c;xpAAl{CKRQssITZ$loY7J9P3fBc!e z2=VBuF~3!tZ$Cf{D|1_GE$ED0>O}p$6_!th+kGyea*IHj7+5H$(xH2DtQ{Z z4q0$muq4exAp0)Tuo=Eox+gQO>s=O%5M+vgTlpUCJo9~X0hozFJ2-yX*DQJFPw^xHzi+LV+a-0gIt3!I6|xKmki-8*Qq{ zxIwAG21xagv6L_>4&56Iq(vfav?GB74=-l*#rAql;Iu1od`He1@>x&0wa1d)<^-2E zcwN55OA7nP8^+=osJYMpIfVkEzAlT7oS)gug9lR%Z8LAM02)M?_BkbZWK{GL$;1`gOyZUDt3w~#mnWi|`K!>` zC%dZ22M3qicNmE#Ox8J3>P8J)`#LSRa4n>HkonE_Q4Ru+00wJ~(7;BfT`BVxF*+6J zD%K-@+%IgFsDe0j`52L%K8D{Rj!7MI>-EaEQqcvi&`+W?&E#r?S$Bh5qg&+I6AA9qTF$Zv=(M&A3wmeW!@9< zWeNQn>ib|!NE5Ga%5*@%)u+^$(ycv>$#cRW`q@s;Lziq5vJ(g%7ttTK<}4Vro*%3H zzWp>uA)}c*Tt(mT5UTKN7wP_5zt*Kt7*cRS%-04DEOdw%*eHmRsE@ZL6EhtW^(0uZ z#vO2BU_Gc5UI=Ze=uES!v`x%Z+3xG?>~=m`U|Gz4!{#jlX{lm`lySS|P5dPwX^o5a z4AZAIVN8@oL-nHTt!Aoq0Yi=2`=Mzay83vekza)j{Dvk8kc(C#F>7exrla+#B@`{W0$fv3t zGw%{}c)2;J2SY9{w1kiOg7XrYh|WKHl*1!T_iGS)K*lsZ>Bl!w_(E8(NKN;FN*VwM|b zA4BBj2(72~=e4+{939%V?AHp__+;*D;u?l4l6>0>KX8S?lB_$5#NInc?#Q$u><_6T zEJRyV=D!lk1Wm-keCk;DXSa8?4G}m#ik7xEyUeOTSJVicSj7F>>OV+5=&9Au9Hut0 zMJnzK?MB+3bO>p}QX6!xHPzr#WkiPt!Lq0-FTw1)AA#EOVfx;@l-%rl>{3O^M|tNN zmQtoYs^{TACz#1G;&IoSH%fA3*vtd_qMs&FGFK*MGdb_i?U5dg)$xOo_-b~xOuJ%U zj_TUi9{b8^ZHIL;(U&@|f4EL{yLc_Uc6cYq20V}H2^nQ_`f4->e9QHupqoA%z`Wk| za#u$=JvR=L)F|ghIgNW4(rKPO)6q!W(x=sY9%@|;v3!m8?yi<8s%Qkf&M)F2U2WCx zX5O~bgFDM(^!pU956!AV)=yMX5kCo~%+PNknz(w*0^c}?t7Fm0(tYSC)2=0+$SY9X99^#W9x!0r^dH8odG7{a5dxDgwmN@Z6`!7Sdu8wI|UPDfSUlcDzQ?T~wf zp`P2r_riU0qNENbAZI{J#;rQfoy;@w8qA&=L^93m$UD1Hj)u$|qjh=6>Jxx)jgcr- zdCOA%6YUCGxQ1#ERgPnjxV+uZ-LRaBsD6uGY39SKty-o=k_;+aTV?5P=2c_0v#3%Z z;-qaLnE#~@CnAL?k4g`CZEUl$;iG4g?5YBx9Th1#i_~Bx_Ggr;8--|;Ptde!b14FO zSgzR<_z!?;nb9aQIjcM~!tDMns8o_OF?g&EN0z|C0p7{b?D}rNv7#b$$CKLSdS8)AVkH&7(YOo0|B9GoycmqB{9N5#K+vh z50qIz(IVXV#6c{5A$UdE?63%|pJF>c;aRqYmp|8)0|s#n%tm8Rv1`o1Ico0*+9&?b@Cnzl4Zaxxa+AS%Bkh^{C%$0fd%8iZK4L;Y zyBX{lAjS*93RPNv7f(9t`HK5q4!;q z;IH-S&F-u>W<0s|!ra6!S182M#c@U(8Sdz(o%NUt&_DP_tq13%Yg_9E43T1V%rXz^ z?>!lkb`x%*eFti}2>ZJtqdcNj2rWAG0fZC1AFADvYnZHSL+A~yc`4W;N0_gC*Fs&K zy|ebRYR|}#2>RnB3!h6{?!b{yv`}pk*ya~_a%SRPlG<&- zkOWm1i&8eKqcEA{zm4DJ%2WwG`y^^Q^X|GO4L99Qi%M1ulb7n^^eFbVzBA`W?1#Y# zPHR(Tp*(a*DM=B#`F>#GfPUD+t*A9|r`G!b?gCqtML~Y*ZWRZqhSM!hkkPi1eq3K; zBcU~588*JC-fB;YopI|W*h516fJ@gKAY!{_^rp=bU0GxZ_JiYB$T08S{+!kKN5dut zJk6}A=+JahPDoTOTNL=2vS%|HWt#!Lm%BpV38FfWOG#jn9PeA-l#DY_d0^N{5#>um z{O}{lV#N1~+7CKjYB&*DJ_jdW;awz;L6GvT$e2|V*AMxLgk~mRis--LZ+JFdUtlTY z$XhmG-=LEhYG{2c$EC9$Sxd+J#B+V$t(9eudI}+@Sp}X+uHhseEQe$)u9l~*Uf32t z6FFzoOI|0Xs0EY6n8x77*D7In8is$;BT+N4MX71&er)hQu;8bS`m4WvOu~AY_@KDV zoJ&;$fNzA?)yRXLu@jMa5vn|lMLqS1me{8hTYB*uX^#$9vR1~ERiz*fm%$o$jO<8D zrIx9w+%t#P*YUcbN9#{BHmQ|bOm9{VS?N}qjtyd{poha9nUj*rp4$$_EZd0zM2~f> z29>Ve*QD|cSy+Fz6|b)fDcB$t zsM%MI6Mm6}uC(W!1Y7e^d%(1)RXTs5L&MImmiRfEniW>2K3|V+0J2ZZp=d4ZiHHnAwv1Dk)8yx5Qu(b5; zGe>%5$7Q+`qP9iio9-&^TCVEYLTJ_mpd+iYxS(+ zRtY8zIF)#CX|Y_;Y=P}RKGJIy`Fkx$hZ(UG80Gr z-JJJU-rlbeo4(=G_?{)=bIMwySY$>Qk1XGWO1DL7G+!L$BDIa z_Uv6~|CKKC1wL-v7??Q!hBq_!LKZN3lyORhIGmK8mg2^-E+6RK3k&tTjJ(29ERegR zhV|B8tuFHB8;-%V0JjRcwUi%-mPGrwkr)HW*6jSYAqnryH%xZ(xgYB9NTrQ3MbG@1 z3zRksoiQz7Z!@Nc0TlFS8m&suZ3ZhS`AAp!HFyMf0#3a=HHlz7H`g_lb9gzHr*#-jEnVp8a>H;}*H z56EC4+V2-Z_`_);*&kb%ANv)XE1ou;pEmqwJ*^}&J6m=1miFWVTCg*y=Q$E#i z_^j1V1$>H-JU(-jECZnFE_4e9qN$J#4EGx^ZjxByVa(~Yg6#t_wQ8e%pusz!WO3sv{PUl5MPqR zygEFH z**v2ca)UOqc+i?lMtvJej@;nO8^9@muxg!TZ(5a=3WUIa17+tizTmvZy>{cgqT3~h ze$_aBn?PgW6ETVO*+>=6&#%+o56F+;$XVFjo<7&D!fbLULz+>?^seEF3OUfkoV^3y zsz$(>Oc-!NHYiOFe#B<o@A0u|L_al1bEfWyPx7R6&(BG|>o9l$c(Drm zE{+nL2^eqBD!rKRr%*V~Z@w;fh!4M2&DH8EFA4Fgok_>HU>%7UTK<%rj#qB)j?k{F z)Hu~$T1G^se68fRL9{)pOUWgq^_hV3Z2)run)&sr$^<#3VWDVnoqbN+rwr-A5Ty1R zTPvKc`bA1IC38KAz#Y_f`O&wwLGjySIbAaOX)U`*`u?2{*FuobZF03B|-J zzfAa?UER}&HDzv@W|CB4rEWTpgvnEIK|X5A)zTM0=mT=Ys$;{+@z>xL>gNWRsK(Qu z2Ug;hYJn|53r1H=Vw>oRMd8bA23V8Zt-z=ZO#-igrKqL4vJWquIN-|GFnfZoQTGJ) zd2++J)JJJa#GdLi30uZ>$XCyMQ~t9UVYIo>^PdbAwn;IIUko%wp~%0j?yk7F)1+aJ z>h=U6XMdr5Frb7g%&A2<++RayUhMq`;=P}gRUC$nEue9v6soL9~6kG;?^+Pr3a2Z&!0MicQ zXIQ6Iz7cHXi>x3#W(g1qwk4Bh8Ftc!ZWuDQ}(`z5F8pqRi zqx(bKI*P%Ec$foRttX9*n!~hcoJabefl_xE(366&L?XAVudIp3T3qkXskv^Hcfg}V zpWZYHyo;P`%fsz<^f{z;9fD=5OxpFVfNp19yPe$qJG{lAwj;}-=90`yF%)E7oYb_EPu8h(U zhF8DF=anS0eCmVE3(Hs-c+AtBw6Y&ulYQ$8HE3A@K<{C1Ia24D`Xed zjLSz?FL_v8{oSwq#y)$C*03UNnzi?qlFEW%z7uM+uWd=9mdt#P6#lgXrzsl&j8T0DuSkt1#|jm_T0&?14{o}abkT!W7n5(U%yqb84T|c^_F)!9MM#ah22+VL(753 zKhz+sY_{0nB3xS;yF^6PIE)H~EMvS#W$~Dq^(rF}j_it6?R|=i>_95L#3ahy#NCcz zE&!Bd4Pf!b8n94&XQ_cqB{>pvHQc1I3I8OfQ=e^6g~j((n#lWO-~Di+NMLZpkCcHY zx_(>ufR88bgO1RJh*_tvT=&Nvsnn4H78;#-ubuD`^ga48?h4Ky^;B^ZA4B*TH4kAq z?!p!+&5mSY9Zo}8nylg)WCM`_M?nQtTkCQ`#wwq(_{3^$74|{->HY< zIn^}y1@>zw>nscs9A8scEmq;NGd`_omu14#*a4mj1<1074772RG*9+nnxaZ!c;h4I zshy$pLwxaJtVNVh6Y=Wh;cQDVr1_PZ9YNw-OB;8?)W)tYf-q-L9(*f?t^8<`)bjoZ zo7^9cAvYX2EuX$3Ua!$nRyjsTNhYdWImVJVCsmqjbSyu%t>(tJaUL89z!>rcKM5hL zlvjJJ@0fNoBuc^gh$-7L1Bnapf6DMTQxT>~^0xHVUi1&c9q*s6Uu+miAk)g7G~cHC z&Anr;`W}~&t(kvgg2{>clj$70yKd>YRiLn8CxL{oDppJ_zLhG2B;gKD)Id^uOzO!_ zEvJBj4l-u;E-ec?PDp4jZ|Yor3Z}tyzCVvCbkO%T9D#|$f?aR6dZKt&Xi%^stt;l^ zXmxRR8>ID_sQlJUT6B@h9nD3-2qe@3ZZaH7m2OSMC=vxJuiw=drqqBc_wHvL`Gc0p z5FMR5&fuwwwJW^DiqB6YT%;GjeU-^O#u^&z;2FgVttst!FTiCwS;Wx$( ztHtEUYjm+qhSb;p#F^=@0Fvr%dOKJRQuyzZ);_iC00B(=;Ti)2MKne)32uU`mdukj@Y<~!#h&v#Gfa> z5Vj_@J?d$fJnIXk7u}M*M+y-y7bud|7~5_Q%=*j=F(ED@9})dEe9($3l{F$|$Z!j+ zv7r6qt|Nn8WN3nQylR`#gqH^fU(ZQhjI?KVHPsijOAt*BF z#oeOfUVF^-F{RrSq8$V`j)O)ZQJ$+-kq172&sOivN4)_P@r-VyA+|E7O6{idyEYFr z8GF25cgt#gS?cR-o+4c|Ptaf+GTW(YqRld4PLSDmi+#6Ez*k@mHFPMIRrR^U-QtBj zTUDAaW*}++v56*8S9yux^})vbfp;%m0k>;eRGrg!cWZ9-jfHC82zAQ1)2D64<417* zE&EXeOtBM!d4QgJ?oZZh?~Dpjy|$Y|@{d&L>f){vdNQi*Jv18mIR=8|%d&Gow%CY{ zd96C4tyLcUp2!HMq2rM-D9=5HDPVOyk_tn2@_W659f1NOIK zg^~FJA_>+o2Z_TG7jYTK-bh+qrlAca?Jsw}_dR^ShXKBYtm91|#!Xnn6j?UK(nG9w){e`{C>1jq3 z@$du_dZ=9bV16jZXm_Jjy{VeFtE^0;P+#krg;y&;TH^IgtcZ|rnBa?R_HsqFp zGtCRneAXy6eNB#ID&Wd$=-J&DhIEY))Fsi%q2LhLx@lkL5Wls@Z7&mUEGs8VDmrHP zB#lYjC&ai^V-LXnp#2Q78+2q^R;hYoTG_)ey<%>nlN#spTU_?1K+0#{Sf`r z0XvU^8vQ9mvpFr@RQU6jG|GB{$h`jCEZfh3Pq&uJ{Kv>V2%jA|o#Q_xe|F&y1Y&v7 zt$1i$u6m(L2`5^IT{($nd`U>@@+MhyW8W@bDcWW%Rv*^H#%uqcjLgMKjgWD~Z&xwsu=&ZUKNi5jdv=*Nm4S21|J2FQlsy1m7_)Y&s#7B(qBR*A+xZP% z93L;81J)|EGAsMXJb|tD`!o_1gEb|ex%2KF#5xJHJ*wg6kPb9QmrY(rzX(yaY1se? zmTubo$h>Y1+^WIV9wGN^J{s#4EPC90T(G!9o=uUGz58G()~R(iT4DZbVw6&bYT_z! zEIxEwxOn?#!DpOB#Dg&W6-O0-YyNz;tgWM8m1GqZ-<1SW)=1|(x(LEV>>+944_=Oiz07IX>5RfUb?hD%yc z$+q71`7hMT)B+k7#j*u={88UGL*I9z>b{w8UUr{^QLy0okgk=SIfEU&ZngvW9>P|WvTX^6N1|=(aGB`jBCPHQcCo3C!qDd#;`_K3gajO(id}{I1|iBW zdK3jt5U*Sn@mp58;!@c?ye(qUYhRJoe@lP?h!{jVy`bcKn*Af7gL12vAkHg*O9STv z2fXt-Xr|m&8_XITMu!hRo&aY#EuOkp>V7c0M%8TKh{u z7y#zq82cgt)VAC|0U87Ow2)WS977g`H9W4cHd7T|wF;5EK_iBUkU9el;wq>BFfIP*2HX3|DBs!l2bKS@$T(n+ zKMt*Zra#H&5Skg7`gPvCpMVZ;X3hsrR|EK)R5y}3Av;My+jMUUjJgqIc=fqo_*c^< zw&EGjw1b>NCxL6P$-qAb)6_&X!Z&PuXyK`A4vBrsDm{%DE#si^SU7YCfP8oJ5vZW0 zz_@c1j)+?#$zK4G&!A6&)8{PoQ5$P$5J3UPx|_}>)AzMG$kpR`y=u~B!aX`En%N;~ zVgE{@+LK{sS_aQ>2{o#3O&ovQ;qC_ociZDqv>b-3A~xjaV2XBd@5_(G0YcctVbK#6 zL8b*DQ&z;Dl!r7ve?d}>COIJ)fg=9y=4M?%ev!HzjR*?w5dRLatjIMOU4|-oM7WFT z_%YxnKjUBR)FldWHJbgRQ98KMYn-QdU9J`0*9-c!f<3?l5`H>!XkG~w+g`WC7lh?h zlWzxIU>gdAy5Hs5$pR0T_*`lsA_&dlW0y^-=hCFDh;@O$ms{%8M(yP~pZzY)z|x2F zd$IS^@l|n&`E>m=LYNU#T`HivfaZtfYpE~5<+Sr7jBpuky6Xt4^2>WShi=oiMz&`Z z!jSSxSKi4~4aIxMful?mfyk-fn$_UDeV{olH%tC+>)8*HsvJnUDQIO@n-IrteXmQJtRCRlYMCos(}YAJ_ViT3~LaWk899mYjj6x-L&? z?(k0c!!+?<3;mU714!{f z65fr*t-Bm^QD@@|tJDisXB-jhX=ov0~ zU^gjozg1pLs4=vbfM6G}+vo>W=heogDt8E4sqgJ1feJQSosJ>dHDz6bKhVz(3eBoi|f)Cn>iNPZR1J_5i2o{oe$dfSNX2aOy)aQ6I|Y-wfn&7u1+&LO7h` z+h_he%_#OQA#J};Hv9IJo!zq7P3@-DhM-LzNQueP99VtwXn(M7=f{C*-T+eK&5dH< z_s2wW)rw&!6}jwtyD=;ya~u(`=_W^ep3Y%HuGI|R&vHiF2P=VH)_xs5CZas! z2)>9~UvJv-M#wWVIm-nciYo|-touHIOx-Pv-f>{G^jatB`wr+nbGlW~xVM5q#4xv! zIkAKqONj{a`p6l*Ph%m-l|)m6^GlP==cKg#dOq`(afxV$-&2=oQX@@ZX>vp39_g1M ztX=xWc(g+LiOqmF=yiXZ3rHw#(^s#?j3Z34>Q($4{g*D446xtabr+|re=lC-FS!|Q70FhE0 zS$-W?g`&I+rg&!su>Aq{Nsjt!(2kD7!8NS$2K^z$0P=MxOlL@U&O6CjzYW$d=2oYl zaIDrKd2@*Im$!{u-o%^fr(ciorwP@A$`-yoT0%tAb4#6KhgMI<@%h4BO*w(CF9hFF zfOUrGgXM5SB(@!o&G5CQRaA!RJr$ah9k`92q1g~zu3pvR5;KWT0S|lSqo8wgq1B! zBM1p;c1)o=#8wgnFNm{Sb9-YJcG0OJ*=s{Gc{!XQ|}6>UiVegA?c7<=mHSW4cu&y+vt0U1{t>%$u1LQ!}~zN?ceGUHQ6s?M~j zV6bh^pCRK1jR5W@5nWeX-PJ)ZEz(CQKc%+UDp4A?XK|vfaW<^G8KjN)nI*~~v|~Bk zDN3JGNR4_GK#A6SJj3*0u6P>AR}}&6lhT4sa{6JcjQD=_(U|$1ila>~&=J5oX#&_u z{bkp2we%?-wJb2CKHZUb`3xiJ-tTFnM-8Z8{SMZ>S>i2R*!%`}Po~kEy8n-JUD9aT zQrjN`YCa{-cWCoLrYny@_IW&KDM(8sha|u|fh6tr*Goa%_BOgMk@GBoQQY(n?xQ=? zAEA|`Q7XqEC%4OJJDiwIHdKZ&LcKkNxzyTJV#Sj zdeMB0ol|orOw_Jp+qP{^jEQaAw)4ccZA@(2ww+9D8{h0*^;PYI_h6rO|A6kUUhBHo zl{AoHl!r5O)`+lHfOeKGtU_TEpL6oVpGyKw4~l56(f4B0eoJR&>N;BC;G`E$ ziukgeD&RxQ^2TJJL4D2?k8P|+53vZ}TJ%aMz1eK5<)D_)!>D9{*vHHAKqgEq(^l#= zZP+ii-RS40_vEnx*Up%842X}p=F{#y?%x{D%eGrjcVtyHdA8*doCYHSBmQ$N*r62W z5tIo)6-3jOkHx_Ty|SRIm|?^ev{pDF$=MSHKHG2+V>}spY{s;aZ=Q4U(YmAiQ<^_R`-5cH-+kY^MY!6;buV@9% zFgs?f@TEWaC^KI=Wkx5IQdclCH(slaEW)i3*^lpxw{d|o$z-SRyhQQJhxgI*4$n<| zwii>&`;=8JKI##+d##R7xM|u1Rd!Uk`BKtfd(Pnk|fVd}zjIx{Lo;awchh`%Kd zt*L>{knfKK&0owXfF-PPi8||0w~t@6LQd`B5;^7l&hga`f>U-Jcqc)7CY%%S!y8pC z#rSn6SUmiW2tD`?QxVEsy+2ow#vtK|Ty{8|)sU{rORNeyxae+GUyB`M7X?*qG$@JU zKVZ@guEdbbK6EHVx#&*;%=};)`3xIDovF2XlNma55ELuqi&XI;U^=+#e%03lDa9IN zwgt2Oq`NBr3xmeq1_bjYCVm@2Wf>fx7niU<+iNA=&uTW&9%{(I8tBgxcL3Z=W@D_k`=Q4nBWsL>#^V#8?L zR`Rmqg!>%dlWWfx=V%Rw!`&&Pe^y@GyT07?!x6Ri;$Y%XAk~MY5ymSWp)#`8Yo2@zpW!UU(S(~D*yELrm zhp-fXFzdGom85*irOopys5W!LKdTyF6u< z+~aD&U|pkA0pe3FKX1{0!#LzXr&Ga5qrFGR0C<3Uu{k~IN^=1X&4D8)+i`bOjisPX z-Y8jH23 z)7&oQ0VsMgs!|TIaK_9M1yf>L1S-Wz zhJ1hOjL94ebh;E9G_lZ;k!V-JW+p$k8781a+a@e_& zVp&&q?a^mWbSrIKE7GS5>9OsxhGka>s%&W!VbW!y6=nooESo?sj;H4TCF<`wZPPuJ zFbMMa7);{A7lA_~bDK##_h;+MYG70W`aZF##Ldb3;T zi`3}1Pyb+ki%LC}{9IMa5-^(0qsw3F7U+yZ&?~}%Ug#cGz8YGz85eE&xi)N8%Z~Y@ z&Lq-E(!nBubp*5mu)4c3uNPbcKRzp60k=vvgx$~RDtOoNDr;xj@t3@* z7=uFk$7r9J3ohD3RGy$ON#Z2>I$a4rBlkMH!Z@P8XL6Z%yN~_yqK1*5ueUp^mIo@~eU(Qrf7Qm&f; zHZT3LVaI`N4bGpB>ZA33iMNxWKfV{db>QhzSa%H(JXdb8Z6+H+?Q(v`T$! zB3kKZc{>&EXjs#zpi6iY#+v;?ZZ+wINLoS*dUabT62GY)An(sx;T^j)_qtaS&9mHm@~_%TpQv z2y;_n!qZy*P|==u^V6~GlD|e9O#(?Ye`}(a1{T=ZO#-@J>;e4HVPw*_*)^S?1(NCn(Tm+A= zf_xBnh#2XC;AQ+JncZAn*+_c*Wb11&#lM}$=?~pcd(kT{!QEUE@G-XEgPJIo$Gbs< zhKakGRJ0sUe|Yh)PN&$;%>E00JN8^+o5-K`;$87n)K#5NzH}n@x(!_|fwB4}4|I=p zIV?x$!5^|kVUHCmRx65EmeC2jVR3M5q|f#Qja21x`OA@YzBDZ;o!gUTYWZ`QWWhC= zYf@XTt3WHV#S|8?rxL2cBh_ZcP+Ol^r!mY2t~Ll<=UB_SWIaurSML%-;8+Xf+IR%Y zdv8=!DCAmh62|EfLe60W<>qfziTg>M50Nm*@p*kFiAuSxR%yWx-Dom;iPwXOSfGe+ zJgYtQ@j-VI72M}qMOF%rv)5fh9AWK?;uFr^Q8$h)KnCT&2fH}9*Ykz_)o8gXW1L74MT3!(?KKc`(}1! z*2#`<*`EHosGZxOsmzQMQ=WC_2Vo)k%#L6teKSd=W}Me`Mjo*3gv0!!CbNQ%=as5hnHhR8wQF=;S&w;=c1I5b zZ^&Wxf)5Dv)P8AaeSd*?PpC1n+GP(&uOA?V#-2-cAf>txc6q709HXZ&%scis!3?i%U?$l_kB&g zk7R14;roSvQ;`SZkCI{5r8RqbkOze?my`_d(Z95N%e=CNdlwV12f)ZK?d~x+)WfT1 z*%)ybLORy87YGFJ?ivlyw@PeMXU#QR1l8`=RM1l4Bkp};DGfQ}^TBm2e?Qso?9suT zuK(J^#dd(@ocknq2TknaBCemdVQmkUP-<=O>DlJ3d&$iymNEaHuX_)}KNeev=os1Q zHuaIR%JB?8RqS03_Zk2%iMsKUrLX=oklHeHByQ8#xYammPVTCfxpp~dod92m@VuFC-{g;whfvlq|2xL7;=9` z^=Ou_v(rq2k;4nwCh(=7`DZERCH?Vll~%E_7;w_UpS^9+F7X#<>eFdwIzdIdDS<2O zY~gS6!|W#}uH`x$oqpg_-?ePaxI?|D#zJT~6x1^!*#nKmxv03aMlu z^Qxz(?S&`>IucsLM4txP7w;jlbiG+uy9z}t*F8$w&A4e_BH;unaFeZxR!t{C`H*ky zadS#OP@y*SU?c7I1b++v&+6&lUwBCT@C`QK0?K-a6q9`=Q$KLHO|f3K@@;a%f$U~k zp_Yx5I1S|j#7G(#K0b1}XqQgF@N^U}X7V;=mwy^EAU?_s>`h$o-0X+`qCR0ssv&?f zmrSI8O)7RBu507JHZ)@9l(2`Y^jL^e{w~{Yg>`s1#jY?uvYB;p@{w^|`xkY3HcS)D z&=unviI&aHvo3!E@;L@HB_2p?fnZgXPivhPk;G z!J)>~Lqg;h(M%E3_xcFhxD4yHSgYcWOKLHBpbU*iAP#0pY;0LWB4O8^K-if}u(!^}>Tb1KV zv`Lo|A7Bun?={<5;}-f0)3B|Rn?r{9R<-~iQ3!L1FYp$LE%YXn;uybUJKvYHngJaa z_Xa{@OMEDJh89>|)hZVDusqQu7AyNg>_{#3dM zHIGe=^DOc31+J!*7d%C-I$~*ZePZ3dZ+Q+x<+jFWJ6u9$QQL`S*B5}xV8Xj2>Vj74 zmW($lU5(fiMWi&I83frbubU#NF2J~i*y34+aUDkO3?b;^N&gQiCVuGU25c>cO=urH zv10!qoeXP$s9|_jnw~VQ3-=~7zFR_#XH1PDXs|7dkMQSRRT=1PX^zwmc;AR@EO24K zhMW|RHr!0zccR_V_zr^kmI`bRx%dpLf~{8v1FOo{x=3vC494eZ zp?bD^i>HRv8nhWx-%m+SqnWF2&2u4r&vmG)D-?~*Mgf2Y=Z8oN>)Y-eHV0ylU~aIE zXCCVUx?p9C61}bmSTS6dTBM`prGv9xs(ur|z7vYSQhlq0NxwhrK z7j5;rsR99{EJ1-&amEH9u+~Nzr#i&S+fq)6iN@kOeU|+Jp660}f8_|^B&etJ{J4X(6)9z{biwL8Kz45Re7HQ zv@NgyRwrY=q(MM=%;~2X@x14~+2k!X>-CdCQ$YH#K}ehyZsdHqQHIJbbK0>?$*;3Z zxJ?t-s-|>hy~;5&#fGffoBX{1NHIM^Q5mxCnPabr*zqN&IoUorxr=Ee{oeK(bCs5A z<9;?xYovFy#RzKy6;}%C^{{y?%#%i6FG8JNAw1(8Dl9d|NqA9cnxnn#0-;sZ|ua38#^GZHjja-6I8#GM> zs)e!==#e`*CQm8JK^sUv_0T_|OUD_{v6~^N!C-0I-AI1HuEOjpV>Xavj^h=}!JFU{q24)q}ib#Yx1ew&zVjmvK$Uy2TEQy-qK^ zP>*y~ml!izVZ-CY9^}#+}+DuV5A!RP+;j`>9(n3T%@1^ z*(9XP*usNdid;ws!uV%DUb}97@*aH6XVEcyoVY&}B=h^}ST%h-p5~#U_0ON{$ zba4Opc-Z9N^w%YHO{$>|^p}tVF92Z<9_kKA3)Bx9!a{=!_(y3ZVg_ig5w!j5Xw|hP zz)MRI0Qen7ItByf<{j+-sSQdD7(D>eMP~<;!XkZQYF;sd@b2Ao0^d5^eYAq+kyox6{y{(SmAndK-}VzluwQYr7*OC)4$jW75x1a#8X%&n ziP#HuFFr=hJ^T2Rv=7CAytt@F*uG;$usK8%P@hks7stk1Adq|{_x!xs-hiK$IZqFu z6(U-yJ`@XBkfNXQe+}=APg4O7LXbdUJqLjq0z|;a>PenIMciN0D>%2ucafiMeFj|- zQhavqmR_`J}r2(^CJ!}uD2}k?Iy+$_|qL6{$x}U0wn!M=3Ckh*sgMvG56=>?Faw!GQMbaH+WRiEsWnTq~qbQ9pER;3hL83X*pnp$i3`G zOf?@PZj%_a#r5+9N60Rc2y0FY7Oc79!#enTF=X^HmWWAVavlEhq8ixY*1`D)@wv@j z4I%C(V$-uRLf?ComI$g2AV}9W*G@PZr7j4xH~7$&zaqGHGY;Y4 z7?@KKM-2Gw=?8>s4)tCe3ljm<#^&Gdr#J{DiK6>CE z?d=1S{axp8x!>@eHV(Q6@@))r3({tjy-oZxK*+lG)lWzpMELa6Ply>Y`6k~zdOq_5 zE)e=diyH?7n7q<2B?7>{Q@;Hj&(EFt2_&p+|6%qdl=l3hexlmMg?fwn)>pSbLJ0W9 zFWH;+x1RB*-oMvhkOv717eYcUWB3 z@XrK-UVzR-F`TQwS4Tmg4{^8P*W!t`GoO{Hbc5Rk;x2EaXwG=G+G9I(;rCskJ&UVv zvIQER*TQCxfUYlmARbcIKCcS)z3z5MeKX8$EuVLafvc}+6zP7W_Qs}a;4IViL@Afi zld&E|$`n&q{nVR`a1_W;S#EAHoJIk zbXCj-HcqOLdEA1jU6=L<0-&T`yLiMe#|G#(13EPhj?zHYqz9$J;AKhHj$x9guL3Sw z)|+#MyrsR^MDz`VXjmyLc9atcym6~y!A4KiG-tl>H;e368U;M zv1|@&!_S?lwi(4T#}mel&XgKhAF|$XnwTJ_WUN|y4C_o(uUeix3-y0LU)duipQZ7Q zsi+>pn*YTppe`C2-DV>Zt%~VDrIxLVm|*-XR`o}GWScb%GaFmYB`?PB7cUF-;lHdd zUE^}faQ~8nPmFzbWk$Xm+ZTl#U`wUACu~oz=};4vw&A9L#LM9{NM0VzfS9DtMlHZM zgzY8F8W*JAq?51J66aFes@iRrZ}B0wI|$HSSI&V%eH@SVC+#kN1-uE`vIrh`mey6L7jYbHozGYHioK!^jT|d>}`a=gEgCey?Od2t8;6{{Dp=qzoCi zH)k(QH71rEcm-noIf^)ArZM#9LMd4{P{lietm3_A7O`Beqp7d!!W1878}7|=ci0J@ zlVLUHjpi3V?wdLNXGyyj)-DK}5Fdja*;C&9Yj0}aH>Ju?ZW^VBihl{q`SecNdV?We zF8gi$%n^oh_qVa{#t zo2Tnyb9q||>vxtkEn-JBydrzWc$;f1Tt}^q6=pYiXWWW`tsbicE5OhNx27L9B2!rY z$#cfch2u2csk@5PX3Y3kZ$ptWl!PZ+Pu1}7 zkL%<+)GRIU631*sM!>p_-M{RB6VQpipj+ulJ=58jACD}JAJ!knmZbgeIu#SK^p%g7 z{6n}*dWX7xL6s`H7dUtHnc2&Hoq3U0a&kPnb!WX4Gn>Q_Ju(S+aa02rk;S zINmSjxRSmZfh58yp8@Y*uRtyhcq`!BYR{b-XSB8c{NaYu)Ao+t9g`b+;L$52QPNJp zBbE}fPJ*2jW0FsET%Ns-42eb8eQd(ly@2L<2L@KR=z;wLd&Q>;MeJm=aM^RWsyKt7 zLgK3svT}YRB~bUWKxs4s&}`CA-6N99m!6t8bz8K6-VJ%ioxbkeo<3_!V>*egBd@ZrL$yL@HIp?VZc54$y!2& zisbvl0`{Cfjmjnw30`+90+THoee4w)P22YoxF@eR8w-i-X=4<>Vm0?tXlt+{rg*u3 zKIYmu^cYUbgll6U`6O4$rzJVy#mE+GWtd7$)8B~VqBcjj%^jwuY;wBC zi0FcKq0?Z2I}V$uF)wh^IrpeQg%R}Q&-Q3zKR#uY)efgaOuD{g*rm*g?5HjB05ZZI z=kRh`WubA{gi#L;b}=Jo!>dlUOgKdnmcgWKap70yql}Lx9QjpPSnX>7(RuX3XDJ)o z%9E!@^x=j=R}_pRxClGz@`H0+^1dyxK&}_E$EZ_Ag*j|W!0l4taGSi6vTR~!ZiDGg z%?cMqZWc63E^|quU)J7-)pcJ**jqsReU79ZVr)KO25&Tq!7L>5hNXhd$F6WpP%R_y zt2Tr*eQe~#GziA-2`7nJ?nw>RlrlRziZd}Cc{^dTY&~%UA31vZ@DFI+M72HX^v<5k zW$c&(Wcz{@uDVFyEMiXGgPwkWfxNlS8!Z@TlR<4E|-qC(z_VE z@v#}YudrS5VBOX>f{?J{YRKO!2J&!-wLC<)(taFP-{Bv7jV02ZRocVLK@3dF6#V)0 za|7ucGBu5nkf{BKw=s8`kya2bS}~t(aMc(K;k$ZZc%6#0g&y;dgWykrAlPasGrmOh zWBjIdCXKNYDZ2YzdqQh*Rl-K0x})DC<-h-l^m-kNq`XH2W0y_Juc=q9*9XT^+tsYT zZ-uL)G%NKBJ(-vAX8Baj=-X!cDchfu@Py(_RcUeE z>|E9CX(AL5{a&4FY9Ye~*+#`|R0|WCY$Cj>fVX^OG0DXSPbXX1w=Ua^RyUGovaBMA zD$!RlzuMSIuIu!8ieyR7X&lg-L5yGEo-jFa`STA)unlgP8TnFp?#}~zEvCB>N(=7;0#LZ> z4!h(6VZG3EOK7O=<+^qXu)(*$*rkD;$LVd!qN%N}&O^Nk+j-Zs- zP?6ynD@CV-(-XFw%3%;ba2`~m82L=&fY`>~YFCH>cy+yQi~A#A9wp%kShbo2Uwem- zhR`y8=h+{y2a>|ZlWW~JCR%b|blRDr5xGt=pginU9&tUS5Z!%lqA%XnavAB zlAGEAMQ`WZP`(3g-Ix*d#0HQBSHp?vdX-ApGuQ5=?=6*AFqTW~T2I9bCY(y6h!{P&%(5S z!2=8XPGTPn(Jj#3cZ+hHl_Uta1nnZ%Mr?R!U$`;zeHulKX@a_mI(2VpoVEoPxazr} zx)zVb6R`U(l#q+Db|!5zMK~>v3aObB=}d3Apg`x`hD@6G1jR*3L#qV)QFd^r{4M;q zvPABu*GstOazdos3%t~;ZmL(G>r<4ui3(eKff@f9WxzjtI0)*AjfmzjN^)T3=}t8d_=`U-IscupQ*mF zb4Ek8e^*ZL(a%fkS0F;(FziT_)07t_yK(FMxRMPFT6#9drtcq=ma*5`MfM$b|AUnE zPq)=scWOad5d;{aZn1lxNDVF{fUT2*d&r0}D~t6;o1CpTT^yUq^a{m(@+ow=Cnmrb zPHR5yN62aA!iQ%l0MMXsqKwIxs3bKSpZH2FzmJzQO!QLd&Lt)ko2tsQ-nTP@wJXOv zIGMdm5uces_-X$%9Nldq)&J@LAu1+f`{p$A;XVi%#SQ)>xom{yPQE=;G>o3{)9J_5-L!+x%<$3?zJLb+IRldh!;BtU zy=KSK+5w+2tFwS8#xK=$xQ3)FZ(0|X=L7!&e16sHTpJ||n^hR!w_tYiFTY6x*&I3|JfR~$6rG3uje3!s!{^wUe1h_r35VBGh zcz;C$hv8c>_b!#|4oQBX4@b(``P&s!`rzKfxb4U1=3Iz?)6|IXI-)fpd3=xA^GB|j z6K1n)aav4aSV3+oeub(cs*T?v3+mg*7VpSOE;a4HR5-S)=vZn-@OOm9rvlzPxuhtm zbC0#ju%cK7i~l%%+3$lf_;6*u2L3=%A8du8A|AEpSoUXW*HPYPOzfEMdb=vM7R&|b zZ#e`Gf)b|z=|Rxff_)7Q5-*04g}c%=V$!d0@`5)a;4XYzp;bt+09E}*! zl?7fp9tvGVHzioc>;awP)1ER}LzqiZ{ zG{mt)9&{Wa(%-tCqG|hPuQsgNC?5cx^YX!z=lMCE&WpDEd<~dK6ZqU#AK4yd8@Blh z(37!ErTnP{7?~&gBDMkE`KPerIuDLoPjW zdL)W8dKy~8FZmG`lTMG|T5}S_@8)2mFkL4%5G`&;`$AXEL}z^UKZmCKQ3bf;nxx*z zag1()o{eP>h}zlr4Mo~=GFh;ck~a}#u$#P=7C1@gWOugHf1XdLr4{)*U%t3r*vcu4RDix>?uLWy>ZX3Tu=( zuD-$#>h#Q=7%QB9C^!xIQ02g-#*her9u5a5wKE)=qvdO-TgSe3*okVEk@jlp;r`tu z70JG~EYROP;d#hWT5Y#IWQrr!uO9HBq-d-5yVy)yHNNo2@h}B*VDwh}>oIY;#qk4R zK{b(1-7g0`Y_qo4|FPysre~t)JKFLpxNavE>iTqcw+al@A&)krk=AnsGXP&vL!-T& zOuImjpE+<&cW9il%LLKDWIQTC*vC!wsbvc}W6#d7vKxxNMsoVNo~d!F^<(&;S0Sd;V{V?&glY7F-+ zQ=PuFpUqdr-eKb+iwN4uH#to *TiiBCYSUw80%ct)|LzQZ?GZ_4=q$1~yYMM;*r6KT^~h>r@IAtHs@Kx;k5ql}kbF?<9A4Y&#vvPj(+)UOw)O zEQBPD4DSP|QBm+L^6xmYha=M~>1EP)G-hwwRC>7_yB{|>1BjaZ!iH=h^)l$j>BS?F z7B@em$yH!%HwY@V+Oei#hOR7?vJ(k7m&s6X}*x==6apPvS<(#o9*do}g z4pP{4I+~$^wxLkYNlE->srBj3Z>zT_ZW}CvHT;WoUjWMg(zR_8UXDW%4`wzS8X}|` zx!F!d-eDWD!AzxdX*f5p>#@asOSE#p$L7|p!HbDD<@>}opVfMKCDPDo3C;%;CIW;# zOoet<-o63Pxru|H2%Hq;=dK6i79_Hc&|x>7u=t>^;Y6A2d^Nt8s_o|F@pQE%B+r11 zfW_>Gdo$0zdylFL7}5gPf}q0;vyq(UgHd`FjtTZtKu3& zLqlaNUK~C?bxW%N@xD{gpjCw z#VnO$t67h=fLJ2cRJZm)TrO=%u`@^pCXbwHGh%wQ8Z<%H? zTff+DpY_}3Gkmvor&Nin${V9Rg9a6A3ZYCc>immVR=RkUl^Auq>0cZk9O=g z*WK8nJZBBrdo~en0kffrm^8P6nY=EQ8gKUCLi|A1RUSMPj}w(>Syt zB@3CpEeVN?O#2ow=7b3Zf%(ic1x~qZ*}r8#QU~VQwaUehR71k%VB&iU^k)Id^y$r8 zp^kGm*vL&(;j%6~0`tli?PMj9Hr<@1&v6*c3caNij)rf|2*K1dIEAZoWiL}TcRJ(q zM2Gti`B6q4RELC3Oj`>jf_ldFfj22jWAdS+RX zRbcQ!U>Qv~KWtc@EvES`F)Y1u5jj6|fc`gDa{`Li+Izj%(tr?#^pRi473VdezvJ;P z%pSBDJ3T7{GVLP~qSzzeMpm(b?oy5`fIiHv!g^KSPkQ=u{CQh!*Iy0!BEQoC%YLJF z>fkXE>IBbJJT($gv98*1iq}VdkX9nRB}7gJYp8A z-aoTC1Nr-Tc_%J*p0w*BwjVxAzSaJ22jysfEf|CQ1AmLOYyFS3zYW zKCtRALt&=*%76miZZH&h^JSeNVJ*?@kRl*ngt{@ET|wUb}E|Hq~X-Zm_zZXMjT!ruwyQz|D)%N)l3M4E!4xH=*dc z0=6`UNJ$<;Mnd^;qo{^3`wA~Dg&w=t>4&87o%q!6O=nASwSO}`_seP^6)AzVWR;(A zHa`HrsETy#v-s*&TuGfyTf$m4Ub26>*$Sx6HKEO+XWV|<69s0!SOxI^-U{eIya-<} z2IIIM-4eQv>@`$ z&*TzfrOrbzHc4eZZ~aP!ftk}!<8v}-^)~#&f{JdyvLP!V;=qE2f@CtJ9uq62FW&@A zTz#AOILFtX=hC+t#-w+%&|;1F>kx@s;vZsU=nPxni!x?ldcJV!?{50HxNxD{y93#i zbJ=J_m7JC-_PcBGm!OaI$@UPxx#!{UPVB7O-18^uCL5*qF`S-x2aPgjtE|@D<_4_B zTw_(}nqz%3f~$8V+x_y`=cQ#%{t|HLPL!3N3QmzV~-7X3NOD5Pv@hB(Xd#OG!RfltzPu-9CZH7dl+p zcHT7vqVw4k7U&cd+B=+|odn{y`6I}Tm4yrTtM0AiIttdp3fj68O0a+5p?lbdH~`HQQY35t_YOdPDV zFZ?(k#-}wK?A-Jf7-%D;@SylGKhrHto~g&r7O@<{4B*J?b=0oV_Q^4DnFkyYd?y#_ zZ-{unJUO8Mxr4Uj0Di#Sty7&Q&@;{g%o#_xgkibG`zd+?C@}?Hjd69Lzx&g{#v>w5 z2fOQ0a=n3%^Irs@Ix}cpDuOr}CcQ7TNj}^oc_UWbnznXj`+Z7ja`DX=9$N@(q29;M z`2<+0MArWdR;Ec>Uq&(>{5jPgJ>Vbop^l6o{B0{7K7gX8V4f`EL+(VRt?jLZjMI>v~~5_17|SEOtON&y=#dbkitdA z%S$+f)gB%ZNYFX;A|Z=6wlJf#QsPRS7NK0OK~EQJt^-UC%9wxB^>fSZ(3#VbE6E`~&RRILdT)J_A_NJG?n z=D>SL#`tnG*YBaoQ`+Zy&NJ3xlo!#LsKRB;oGLg7QU!2`W#Q?e!Zc=Nr5ESv9kEnc z*jLS`OFfWNyag3ZLTg=mcQA#5H&IS^N0w5M z^Pnwl554=zI9w7H=fAFds@>LQr}ISUooV@V1E2JTX&UdCwVK)&q9qJbJC}}G=Mjf# z$-qL`XpD*s%#^hl`KIWtU>yW_)|9En516Kxv)wSg{)N^hu!tsctDmKN<*apW-^2le zW=vqkci;|#!)lwq;zA%sjC)qOoV_9dtpFA#+~ae9KKDyWW)qxUA1afguc4LWhjoO{ z2*klLDjNCbg!$IDIgR{<9(pmGrEO%L)~oZZqbbpKw+yChWnNbu{l`wCo>rWW2$JB3 zmgKwNE53U0Nsybv;*z9NIviR_(E9?b<@h-mMhzD2q3c%RH^wh7y65N@*yQ`%XOENndBS z_7h7h$vmKUh5JIXvLyCzjeC5i#vpo&VTtH^s4I-2MI^L^mHRxLm^V&fG-K`KEw zv!hr2TwfYcm8|n!tn*x|5*iO)iYMPL?@zN(itbPX`ym+;R-Z#6EvWI$FX!udQZa0p zSCZ!mU!S5Dx!A}QZwt2hdg$k7?6bBu#_;?CspwXH)r$Tb)N~2gy%~B%UOkl1z20^z zTKALuK~g7AK%&|vmzIQt@1LwHBSbDR##q^se3Q+9Ps^F*6?eF6Vy7fqHix(Hw{l?& z?K(~Q)QfBNS^&YA7|8LFSOB;*GKB!40Tm9GMbNj>Rv?X`mX$?&J3owkUIn8oG^x`s z(HE%zZz(ta&DL<@?@8JAQIS1n2j2}MQezLHo?$xVok60@fg!gshRP*pPh!0NvqUsg zDWzsJI-S5e1f+l19`+*EjN)xD?e>i?ojcF3?e&8usKj!0RN__tcd=Q8s$Xyw=H!gUQ&Bj6`9le1PDdsOn~YZH4T zPovtTm)jw;rARwJKX~m_93KM)M>tP6lsG4*qOozF%SYXeDP|XGpv###XxIkYzsr3! zY{t6n6q)QqPmTq$jS;30592lI-JuJt-^7 z%BWFysQ9neF-urXH)eiY3UGmtcsc4BTKK1@vvvAF`i&CP*xYa|gcry}qvVu&96NiE zP#yE03#M&Cf@~4VO~Ib%?gE{SijVr&9n+mR(a_ncO{zk8W<1qHM?zrS9-Yr$qzCew z9<;Ea#z1pf`y)jp_WDL;{u&Ec?%JA=vu-CX7TR%~#6IOZRR7+$P6Dy?Ud`apeglk% zqsQ<;McQdNm2DWl0B}J*4y>ELQ{UO5{A1jtz!><{fA3m5MM$xWMI2~&`2oKAeu*7a zVZ$ac;6;wo%>2}cMpO-MKj4XNFBDYa@`8pG?@4DOhh5fLRIvX+I$_srF3t?MEs_1e zo_(Pu)hZUNQZLcF%VR=LI&V8}zc&|degg5YDeOsn7f|uBvHUM`kK@0{J$4Re7)BXW zJ98Hc79uVdR<8fuu@W);?~;g{g`NBVf_p?TjN+CyE~ZXIjN&$iE~cWU#`Y$rF#P;5 z&Mr=-hPE&s8!@fmD#^RJ^wBP@!6+h$93Sa|-2FOi`M`(?Sah;k2x{u z0FZ0T5cvpBz}%fdbiln(pvlvCg8od#LM6Z!8vxz!I%~md9loh-Apm6%-x>&*qvwP} zkVarOuzVCK+aVe-O)SwEVSl7Q7!&aKB|IP|3qp=Ra!<8x2)rVva zKwl#OQ%F!VaeQ(y1xXj8^9Rpd?-b0tpWd48dp0|k2kv#ZgNVma22JNf{!Ge^3SnKF zUk(`txA}=8xu|84*G&!7kP^hl6GT$ST+;tY0^<#$%iXvhejgp*5XvV&$`c4c$1<{f ziV7~tBCW&#yF7$QO!{O!91nhvo5neW*#iLy_~oMm6pspYXlXe3UfETeMta(sbd~lN z@ekS~T|zc^5(PPgYysi>%71T5Zw~^hnXw}h$n)p@j#5}(14=c3RR?g7;lK%fmAxln zn><1K@%Wh6QT7477V~ic-L9V8P!>^oY6=rS>-_}(@awC&lJhaE>W&Ct{am49hIxVb zq;qotOY9I|3P~+{trJwvzWJHF|xknKg^f8sf{UfujM$A8S8 z5)y3rQEj{N$pJ(KX9>v`*_YW-S+O0_GjlXQJsF^AMyi@CQ7PX8jBH z9z^5n|15bwLDvC5YGb`byny99{aeeyn%;f?cZ2=o%TE`9PqlO9r0;=VMpC3PRFi-X zCfH^qsODx zXYW`mqLrlOMSGV!8RR+g+HL9GF(|O%fVUycPYDIdOm^PB_f@WUL+~HjC(m_!@rb+Q z-l!7oK-cqW+=J~Y-5(b&Z(HqCZKx)|O`UHXrwr8^Lxo9J*&vr$SS0dnLMCb|!22kY z)z^X~5DmuCao_XIM^4&&1`(;PhF`FXk*>0UJ0glEni$4jQz^zv3+2ZWU&m?|WpD3{br%!3aaW^Re&K<>`#& zTe-{E#z)7o{a3~o59>*^H&=W$bje3iHva=#9hIA!ma^rco6M(eMH0;w*Ye6%NP4e~c;jD3nozTv z8?TL$yp|kf{Wu!BeR-Im5a+x~Z#BleG3xy)hv)il>#wC9^*>z9U8mWC+~_d5*lfx8 zYMjJb630ABxQt-Ppw6V8=J8J)&5-U}%>1${yOW6xTcO*6qv^yg7qKbD{A|qIH8*}% zi{~-0oMsC)8HDV=AvT?ZOy!oLZ%LnE;WH0mB62zKVk!x}J}nj7WZsQZ3G0#fuQ2$gO_vyTRWq z;$+Z@j(C!D1UkqEuXH9BE*OZ&I_E+u%*C8QG2y*q)<-8fL~CIAJr@H(qIu>HV_`~F z`mwnDN9EuuZ=rwe4ogl?7k0>;@ZN(T)dCCKc2|IaD{m}777tvlin(J3kF7>$KJ@jR z4`qg9Iz1F(NGFl@D;e%6VdaztS5Vud5C7(>zt%x7YNr+p#eC6_9~2FvW9tRra}jvr zj5m2SwgQbe)Y_34O%!1H&9)5!O+ZD)MCY{}e%zI2&c~=`Q7mQAI7ATsAw-dcGQqaR z8hsW;g4#swU9q}D<)Wqw$Qt(7a(jH?D;CJQB^cQnJD!C;gTVWFA4v&83IEOsxX3Yq z7GG&7udA}b7>t%oa#Sbw>B6I(-_pUOh7%Vi9S1giK}XB0k_Ed2?+4mqA4`Li zGC7fuV{q~yF_4q=A5OO_tOkO0ixH7pb z3Dd>in26wx&6Wa#Ml8pj5*N3Iy(&`7o+L#^*6K(V&O7Z6@8G1(b+PW*2q}1tR01kzdD8c0UWpZjQO7^r){aG`(M=y?Nm6;7--V zQ-(D=h{8ZxGi-=3T3S z`0_p;)KIeGRn@yUan1_e@YYt!$^knF%lvPHkX;v9A z$A}p)e7G<&#voFVi0aP>)Md3AD45Wi?2a*1HNZG~eUBdsx9SlI7WQP#G@}pkM&KoY z4#D-BPAY{wvh%8?^s!zAd`PcRtzFT7nm3!u_i8#5xZtGZD)KU`;(0VFP=o1Xh77$W z(<)R$JmPKZ+w}8-gthp~P}ZO(2%4BoL4}nq5z=!t^3n>1l3CNvKqt-q`;5`pb*_+J z8yKT@U)(Fih(_=z zR4Zic>f7~@VfLcXCujV2d>5IKZ{X&W8p?0F7!f0Mb|tS!NtSDfe zS_<Ck zlHtZPa2EQc8$8WR^D^{xVJ3P+jkOJFxr5+9C^XBZi6<9iTw*()fVj#erq#U6#OfE! zH`RSV{zLxXh2pfm9lT?lmUK63)UN$b&#}N4TXZiyB2McPVdxyGWB0e=o2ft1BdkvO zZOK#giF-j>3nC&|E%S$0)Fv<#&SE4Wv5^0Y5Y8gt_g*xfYfOkh~XY- z2@Nmpk7&D&urpy^%MuI=_#!y+oP;AOg=IwAdfBJgu9d1%ROus)!1+O@aeeMd?Si1(agbzuN(K9HuabIj-baICOXY2u-C zuZ6;o#@Od8(}katzFmAIPS`FziJ}uR_Ff4qoh$Y~f33$R{ML(q?zTZ??;s&s2kPyt z#Jq=r)2vo(wjeB!|jCCuy`6v9o^(lzX;D&&BXneDL%OeNTA1k+T z+|W|oz+mlzemHVvL=}&fpoV3$b+|e)5n^iTxP5CH{?Y`xC zVNfwK^Rn~8T>$R81djTCx4*_uK`YKinvrli9QAjebxHRr_?h zA*<*ke7)&B?bwxgLE7x~(m~v7a5AIIFDV5I*Fbv_{rthqS%|Np*1#|4O1{QkshRVZ zb&a)p;UA>8py{>57*VbnqAt-2mNlPi_mppKAc6!mo6;mrjzB7swNpp=Sp+^WnK;6t zDFqD$M?qSBoBio0a5(RR-ORK~8Qa>tM&o$}A4RwRi}j5x+>%P_>G08LrYT0$7vJAY zktu%7o6M^q$$bFFD&-mxg8=@=uJ)Yo8*KMDz$o(>^Fz!%BJ1FsA?P^!$XlRRqNIRo zP^s`#UBid=2qAPl1fW65g4!`MuSDl@Qn&kk8r(VqVRhnHNlwsOnlZ90<`7@+P3oG`iuHPYwL&kb- z+Vo6=*p1Lgs)xe$QSkfD-O7!_@C?u=%2NNPH?n8O8WFcM!JXe6XiL(KT}J88lt-_B z&Hgl3z3BCP9vP}SUTj@koFzRlbG^H2M&e1IA+k8;BX2{mbe9(4uz{Gg^j^14>K|Cs zM_)yjhR@fQ0kjztk_S0)DRxjUl89J&1c*-_d zClnd7zD#=np522;c!Fh8DjZ4eh%&ctnh<`5NVn-k2|GH&pF&=8vZ$KV>kt^u;l0u3 z76u>BuZ9lk(2IH@8Mj`OM@(Fw_$fXsP@#Jb#-+evdkh6*n2~+Pvz3+MlD+IX$kR><0DCxL>=FO!6ky z4sv|~`cq_@s<+Sz0bdif$<&G=uZpfYY39+GnrL}aB@5U+E&j?Q3i0Bchv5^)#h?4!V&n z!{Uw?PCE*^<(akhkhON(Ib-XKfmisX_;0|Lc^ow?o-&QN(0370AIwI>41E4{u*#uW z&BE*Ecm%6%c5TPa&m5=sh`CuK@dIZt`N@GbrQmJ_PV=S7M~aF=UdtLYoPf-t2zV^# zsy=#E5Ix0g;TS7&+Y#okH^a80k}Bc`&^MQQG9e2?HC(5bsuRVand~a`wc$G?Rd36P zVUMK>41$~1`0ufu;88{;lXRw$*gL9FkjYe;0f@3%wFoX-8J0*VhN&jJz>mUu7}(oX z=h+tT;x1boyn$f0kk`fUWj*-Xp>Y$dqxfnH{$;}YKwh_Lt6|s-Dm>Ce_ZdK}_lYB$ zPG%1zAkUe)f1*>2bo#}U6ULj3JR2s|EMw!pCO44LSAsd?p;P+0(MxxYn@?vhj1f=j;%A1HLeP`>`+r)$-sTP_VFP%z!4o z|3_PSz9gxF8t^E>qnk25VRx%jqLn)`1*r2&Q|8D1yiYT!?iIp0zU1wo$>5NmV@w^_!8E0eU*^L;NRv4vpH zE@YEktqV+Dc7PBkj&WQ1{`c$09b;!II8%=0{XfKP0rt(sn%jl9jf?hcz9z77T#p#@t+wfMIP|?P|4`nZOBs{W7WH z6K7kP-K<^EC~>c@=Q=2ko-dbYYMBC`FV0bQAm-%ys}`_l_4C(bV}fH2)o6sWY{JuI z!Cwy@(}F5%ZlztgAwMVTpSv5@!Cn@)U;7fg|^+w95tryN(pq?ECNkP5_rkICds)H5s5p6G<}XqpO+5+ zf%o-t&;c19u*th{UGtPvt-B;JlC8Ik>0@IH1vV@RPB-u-4iTZoEAx(|Z=XBlz-ACO zO*M8^U8{hzpGvY*G9^VpxwQ~!(U@L8dO_Zi2>Eg`BqJqllA^n#KM*WORcOGUFw(&r zA*vL({wdxnh#+H|Yrk4oH6DC4=0)7bHbC69Fham zT)-gDs8pCG$-XZ+BKg@n9}+V#)H$^Uj<-23^Kz;d1KaReo#T1bp9;m=`f#axn;O}e zS0MEj)_F@|Q~9t@m0?9K}Gz4r-+=J`Y0IF zy!a{GNF#(wCn5g3E-7e|=x~AVJNNn~Y#LTho*iX$njV#Tj1VvF-nzbPQ!>3#t{u!U zR@{|_D;q4~3j-FRoCvi;#6L#bIzp$KadFQDnaE&lPf)lnGk#Y}Wy8uAiUEbrgCHA$ zF1G3H2UEaCk=%dAR;~fdQ%dG|;qO}exIp)WirWO0zwr!CZBFH>Av@_fN`FZa=Pl*g z)tXZET`8Yu9zFK=cRW+%g#?kzu#4&?o8&;w4(x_QWdG(KP)SfdY|i^P=4VcV_n322 z6V~9vT~iAp8}q{K%d*ImBOg~35=q@6d<5+oaSKFA#{i}^gfjO-0Qd!1FSm5K0vMZg z&X2-F%{~SH>>=+L-71i_pNzCKGnuU7fjx|Mo+tfzXTteTN703@8$GXyx5C6Ho9aVh z4+u&E3wW;?I^t(zpZfrr>oOu|;YT(XujM^w|5^Ps2g;GBUhaw=PYrjF#&WG&#nC-Y zED=dhdrC$x2&Pnye8_WaTK$;=Zg~1Dk@*ebj~#s%+jUiiOEA(x9FRHy7BbjCI9y?L zi~*gILl4wuyzlHJvK16rWB1#E)v>pdu%8Bj17=Nn!-zM%EPphniqFbC2~664v5-HVw-O+4wZQ3KfM$Q~0(?H`V?E zd8rQbI4bpms=~T90Tp3;6*1EgO7!G9d2{1l!BpP3(D|OYDjI}{w4oost`GikoIh!( zpI2^cj8M+nK_M%_edi27AKR7ho=NyJxA4>#^$3eH2fN2bOeAsYMWeys;8h;@xBV;Z z>&J-L6szKcO=L!8p0GpexBZ=UP(_W<#(JyaDGlW(89*k=DHZnPjgWUg9m*i$W$4$)ymDw(LPF>xd3?TAMO|M0X&FCv;*vCdm; z64`#d@DgZEH63jCP8-d4<9BofdaEIwRP6wX-Tubl-#`|{nMY~Qdkd+!#b>@&=~2bM zud&^LB4>0&2(~lTc9iXQZi*a8AsDx0Z$LN++t{$4JO`!Qv1F!g^P59J}{jU%f1x?rMg2l`(e8k>p9Jr^)R6E+Z zCj@98bo~3E^YvuLzxnQP1;D9H5#8*MVhn)6x1XYQN6#PfJM5JUC4ByKV5G#CMI=3o zp8?-t$J<2S27p?y{l95(JsLXe4X+2DyUyh@|gOuQqt0N>3-kMr?4wDG3DBL61YWA&86kbm5} zI9F!PXSvGC^o*eZ1JR$R{`TTEb}!Bv8wGOw{u__N?@Nv}J^xv|^-<3kSjsRhSeYKU zt)*Y|h&YGjqlCK|+33ns-X#VXdhT-R=B3U*Tt_}vHNU_kbIscpQV&iOMrVLYi>`G_ zh~uG*`-8(yW2Mzc$T%PFrZtAyu7mBVJ7qqditZ`gjPsneq$SV zKF^`Q?nWV=F?1n@I4+#-vQKQ;E!Q(w^ADMS*d^Y47vn@^S?(okrB};X|A?LLx6@T~ zWIhC7>-&`oc3l`Ne-tQjILYtuj{g~CImljr<5F1V+dR^{wmOnmCgjV7J0oMb=TNj9 zFav#5I1c`#h=kr4F5+0hWC){kJ+XPnxk{g;riLskJ$E-l39-+0r?;iBd`~jXVFO?k zhL7pe+JejuAJW~Xk5AXN^lRd{Ccn#!YU*roor6~{!)xJ}kyzPjgPT{-Y~q7$QYG~F zfs*R+y*JDXggtfpFM*0cI0R*9Ngh@UPv=}izu?_po`J;s#O{Dai|g03b`+iBj$RWC z{AlDyV*Vc%gLwg`?mHTKhI22gDZIP|(YC2VBvmpdkDIgU$R{E76UihX;z85kXW@ad3$OX@8B_7==H1g}T~0rXf=Nngg= z443VyA9D_-Gl!WxBKhIFo%OW*ncJJ00_5Wf<=$R4T#d-q&8dLg_}gGfLgi;Zp0&^3 zn!^Qs##OW2w~CBV1p3P6T=cE&G+KyY^aje!$e7LR9w}0zW&o*i|+jy7Klq;)M0LATL#y z)ZQs@G|F4UNv7Xk#{Uhoc~kWO z>uc#>ye7y46}}p^QI}&o{AV#@3%13k=x}Z+{#eT91!XWOl){)Ji!H!=ICmcNKI<-T zZ8otq<%T^6V#Wkl-QEMvGMqU~?d5h5?R=1M}tCfFL9!^iLCR{Ml7pnM0)@FGARs(EydMJ0c)UZ4|JXG2T|glL051d5)dgHD=vNT5 z2TV|)Kky;B2{?v8{uuw#2LyKt_`mxUpw7-`GvGkN-2-a_?E;!>0sOGa0^w)zGNYKB#b@3Pbl>!OXw(j8zs(|$#I<5d&q7zDm~99@TlYHRrf9ax#x>_>oebp)=W{5cO)L;NXf z0xtp}5+G2J(ZK<50}SA`B>?J6!uH?{_QwYGubBV-eCHs}26VH4FyJr8#rPIJ3kK;3 z2Bc7Dug{zHXaCYBLO}sp6S7qRu&(Dtk$aPOYsRv94Ufs~rd~oefD%ELM*#SGe*ZLy zJ4vGjx;c7||GeFYI;+5{w5q!Q0{d!{6a?IdyxT_x0eTA&39zUI!Uq_h1Ml-Uf5-mS zU-P$i6`14q2L4G_gtZF?koW=w^mX?iaQIC|*72`}X5ZUI#Uq~M0RwLTDd@pe0I>-E zLHhDf{&gSw9eLN+{DI&2HRqqOlauSK(dnD|9fArH%<2AVF4DXT6S5CM1L{G)`*rdC z2j+@w>2FnFU-Q>mRv>sX8ymXL`RNs*P{O=`Y+Vj4v?1_EIIF|VU*s0tH^2o!`nb#l z%pV2&g2(n+wZWN}heYD7*d=4|O8wDQg0u^+|88*>A}Rz(sG=T=M&R{mCIPxb6rnGp zU3+A&0|feV0D-~<5*T^}UL(|j^q+nV1Q7uE*7#QXNt<^CQNWAXedvQ)Z|~?VOuuDE zoYVax{oQe4SVOiE=HL#kPlR$ThqC0WN-)3M)5cGHAMX7jN&PcxzS8pdItYb6vWth< zV*FWzuc9y6#!xo$Qp4_MCw10s$h&)P1Z2BZdN(i4(aZQ!HiQ|!!duL_?YOE76Y}N( zbIkX-$LXFG%4OKD-$vPd*2xi>e0jW-=kZMGzWRnP7vGDqrS`K$M9w*PI(1Y2_S)Mm8e9oR+ieq-vM3dsfXTiH+SO8*O zZdA-%XfncAhLL4tzoe$Nd%-(tZL6AM-bCuF9!=N7`dMT%OpRe9jq^$DNjsrDq9*akkEV@pLz~9@V0b$v@ol-&JIv4N%$v!Lg(ZY_E-2#%y%8NDSnGb>nWXN z>?K|%Qo1EBFD`rqm3`_*D1ZKtyBsjqax~0VM?XBh;lsaUMnNT)!he?3Qz=HwDpXRu z_oiZ)d$#f(UxM?;y>2@+ zuJSLHt|7imTi*s+7LUY<8D}y@ZLVURBn2nKwSkp@gdEV4-Jhh!)3`DL)#6l{#HI9p zk2SbaXR32odLGSywtM^;SyNRec8+S0TvC_06Sy_#EAdd`I#CTl860wK-m7ZFanOwR zuBYsr7?jHB3Fo4i-?(5LV9F7c(C*3rE|J<>FRo3yHmwt?{|Wkg6XJVsTgU!#yhiC!gcy%uG^JJ*96Cy5XAOt{NOL%S=U@ci zTAsi&*7q7k|I1a{Uelq>6NNFtT-CMXxA52zN>_Ggc3YLFa{9Dj9yMzPKbbxZ&z2U$ zt(QEd@z$`MDec32xEbsMv)t)Fy@|b6f`geIwFTm0y*XUxemL2Wq$y9&^1Noj(y)Xq zn8LMVhA7KVO7BrBai->)wD)w64$5D^*=sjMq%+i;c01;CNp>S(0gYY%!FL+{54gL( zahzi~uO1Z_KXV3*w4c^9`gWm)6!#vi+tpV%{B`Ih#yn|rN_^yL5=tp!>T1Xk>VpI3 z7RP>pIPh3Ep5LSE)t^MVA&=Cqh}+WP;X9a+2xmPo{+Bu7YIo-RIviIr^;nw%%z06= zmF<9as3&VM$Z%Na#A*{urpUc{%*J__zt@3g&u^WoZAGoczDysF^x*=NO!6&pZKreT zgoizF=G-J@&p|S}Ld)7I^^|#<8lD;Wg4-DcDbEpBgI`vE4rFe-hwQk;6_nK3c*V?P zXg!TvC9^haCfWvt^G;Mx4S#J>z$s}(bwe(B94_PYoWs5=TV(8(cf@JHI$41PBQThn z`_f)0@);+`+pH_h+&v~1#qKYSv`yhJ6zOB$=Bb-TMd?9bT#ePhCP_C$kC|35g=^>b zZUpXKH>WeXUd%Z`&jZUG`>e@sf$6f3?a0R<)5JaCJaR~ddBnY~Vt6qOlRI>&AfLq2 z+4|jy&w4gk81en&7hLh|-$1&XfXQhWdKpwZE4kpK6B90T&(Dy{$z^EfN3jVJ3v*$e zz)+UEO(*roOF5dNIQTyVEpPiK9~uLEZb;x$Q*V+9?mM7qEdbn6;?F_G>r;mIvKIYU zD+jI4!nz3P7Kt1DP}rwiPy_Dyo~`&LZt^eVdJMtlhl(SPkt4*b>hg`DUygcfl`QSG zaNr{?BLMKUk+DnJeOt~NSmmB~JL_3p< zA-8+3lklt_wZb1*O{s$a+U6v2_zJ7R)+Uf^w6qnb*Q$$7OTJWg~gl3^itMFy3%IjIsAL2c}Gs4J90$A9C{i zl$j&EY&idAggRm%Q+>1@k1tYf&>?m2Qe*v7^>B`l>tdw!X?8Msv6uxn)exG6Gg=n4 zs>WgI&gp#xktH&^3T z62$RlNlxnoFv3FBV6c(Yed;eG%7-tw3=UN$$*-9j%RJ4DMc4Q23|cA8-j zhC14i;wl9NMtVU9R(4#v*qY z9vytifHyz@_58`LyOkBr{O?Wi{yeUvc9gwjIH>DRMs8oRoeJZ*$GsLdn+ha4mSItIwjtcYaA9O%C#olt8%^=dyN5U-1;uPbqA?>IiA1dE;68E zu;HV&(nOU$=CA@F+?~~wO0)KbPN>rupS^!-jLs(4bF*u2bux->8I|h9BN2y8MwDyZ zh{b6GmeSyR8>@mXF*xz~D?&j)!7nu9OZFUf(Ip*ALL3t`=9#;DbN}F15i8@oV_bau zb9N*mtkx?%NkR*2_8>VKzC0`y?H9kCNE=(`>LM!z(73Ao5TD^mXUk^7y9rB@2L>8q z4*@4}dZs(|k$#m3mtry$^>2kt50f5)M5&$Zk_7=P8{{+bCu^nv`A&qnvDs?vBs3JpJIN&-FUFU_LrwPrfG z-Tn7dFL3%E)HJG+*f2~oQnvbnCskMAMGE)&LRb8Le$tc7AN6oTd&1GfW6YyX(uv01 z-d3G3R0n2z?w&_|D+DvRVH5z|xG-9i$@pfne#_KzdOF4L4^(}*yRic3dRL?_*$;Ut z>EJ6gbf{w47k??a@kHy4$~8rgKa2H;cR5H!4*E`vkR^x%_am&%+H7C{amQoM6Pa=S zWG#(aB}y>eWckGCCRiNEiEX$ks{-Oa`Y!5YVWo_Dz=x>et9U_~$g)%FH3 zGd(eu!pvwa8T^2c{pdprQC+s+S8N{lv-f({5bQKr7cK|1Nevz2wbTjgO9t@Ov&W-nB!AB#hi|69JVd0c z%+@QK?*0tX2z2-I6aqz!{^cu!b?tBNfT7?auh=KXNXQa4eEsweF&G;B7_IGWTMXYx zRw+`WVt3BR_B)gYH<_|&G0=s&&e}rHCilhi+rIor+n}?u^irNmZ*3>b=_}+RFg}7L!`3fV* zxe`4IDrQow0?v24CU3HaAoo9^kM6->g2KF$#PFP_V1@uI!aj zYDpX}KWeYe@9Mi?%miWdMQeszbhV15%mMhWvyU|_6Pe(F*C2pMQ z%jg!NlM9)~cb#8B1VpnxvloW(?T)KFISIQv!m`?xY-6O#~mVA z?an+yzw=r)&&G1O{=(DzdoXX%SWb!w7U+35339xWubWgDuj{T9&nKiQT5o0(BLEV}BEF7XQ2V=eM@gND2>oX_ECky{^&TBlTg zc}sxpW!V9+m}LrE9)Y);w(Wb2>ip)RSNqZ29EVxgtltehJM0y;nkb~;y-wEvd=RPP z+)*=C6U{PMT)>pfPjdxYx%{)~L2DHW%X)V^D-oS;Hu~v;N49izZ?&lFr&C#?c6sc= zH&sY^RxgnT++_;~R~Fl+8L~imw*VNgrEym0ox95MxB+HJPtkV)`*%av)QKI}e^Cfy zBAs$h+jqUyZD-~%R|ND*kJhTD$7sWWLM=BM7$W- zZ@BqpyGSeoXly(Zm7{@}u$!R7J* znbV*WFtdL9t*1X5tF9n@aVhtyNYtSPo zyFAi)WBqZ66)zD#(JFGj6Hao;%+E1Ngda;czNZ;BnGKbG+rr^&QVRN$oGU>S&w&OC zX?9Pc)9)A@!@oBb=R+AIui2~isfd@IkZTTF`U%1frX)Y@yA*kP^E_GzN5?BNVg*5+ zfp?o+t$s~qWo26P#Ly*h+AVGCnfAR|XgRg32iDZgXF-+oSx;*@V{ccFDuYb!^EAUf z?6?0RMWf$4afULqR;FxZUMdXr`l%B}CwZoTG(Fa@ScMfm^-UEDYHUJ?H~I~+PS8}G zdbhA$Txrh-+#~-^k8Qt?Svs!KyVn1w9I3Wa#~XJs1bLqk8xMfT=&EUIQIb<=ysi%< zYSFTjoFZ*W0$0R7p;jw>CJUnHzBkXK)5~^jr`H7|S$e&73DCJ&(z6D*^DO8xjL*TA zVW%&Of})zntTdjJmaE7%pIqG=N#%6Y)?4ma>m1VuCd%GU+D!fQmtk5x_%W?KTzImA zvg?7o1|^JCdkdQ)d6AA?lULTpaqOzcyO-^lswvcl#Os6wJNpHMDid>+R>V(|NOrd| zJnF>G9k<&${=IQ+w|QK+Or$3Pw>_DvaW)rSpP!n5IizAqFRlb=gkLKDM@NGme?wV& zbgftbj>Yu7zM-P{llhLShW*xsl6m*Z(479_Pt^Hg(aDhN>3}Pt8)kMoDIC2Uozltr zh&tnkku4^35-(&*uOCN=(r((l{F(3mPZZ0N-cOE}S10ZA_n#JTfu3jO90nesG4!rp zbR->Mj8Anqs|7!=Wj?JpB__ummVnc?Wt|iK8bFqu*RYAqn2SEK(BOOC^pKek?KU`Z zt%sa4`&0GRF|=vNz{8VWn|(blQ_W^)qFQG&q+FU3sS8Q*C!zDniSGR2xR#C#j?=}PaU_nM4+^W51#TT!r zo!k%%emFAGi1=o^P8v47nMl63Z?EHAHJ(~cZ^ zb`cCXy|lk1cG+ANuf;*v(;LMQL%i+TO$Wg>bsGi`!`GEdE1@reE_wA;^6jXA_acHV zFsE*Ve=x|z0dsWImGSs_@-3@Ljc6=I)cIQ@@f}$rBKiDHA2KVxW4Z^FUI#2Mbn`xa zL1EY=*L-r2`|TSIFS*^k8#NYth3%cP4s-2{Rr%pR?h`DKohPSZ*=O=(_=|LCYwaHz zlqJ#VJy(`Up$cI%AeMbE4EbPR_RIgs0g|!`O?i%?nAU=Fxii^vF%tOWH&8TMIHL#muSU2~3HMXZesQmK} zZr04R?HJ-yJ}*4X2SKyUpKr>Q1a_xukI!@INmm<EyB;(^=XL$8 zye=|af+mRv@b=yqQ;q`_pNLdxXv)sj!Z$^}D!8oYY6r(3*ka={NS=?y*-J>bsS-*O z`-32xxMlr;x(^;Lfs`hKVuQMjF6X&|Gpx_0q3+fi3Kr38lgD<5eDFS`S|X=U4+ry7 zV|!s-9l~i*3^S(8mOEq4QtlpMnSKTGb%V7jl3O2$#o(pkB==k z(*xp14mUG_pka?jRab^k;MZTUai|2~cW*NgkPerb`L+$@avGXox>B)a_imdMHk}|^ z8t-+G@lQn34uG==x`d}}v53W;_XvlI*~xuu(Y7gkiM~wyEBjJfw>>5Q1$S4HmH3-eu7Nem2+TFU)qB0+K^7*ls#mCGNL<}XJD0S zRaz5~CPxf<9#@WYHAE&mf4XREg4R6|6o<^Vry#En-CayQMDYU?p&!TCLF~ZJzR{Cu ziE2@6?S(5s_BtN2XT-++(9=HtP5&oEQ0WJ~{5Tpdxs1!cGp(K_UQ5RvSP72odSXAP0m1 zK&}N6;A8kH0Ojz4?E?D@iNE!e1Ox^oP|2Xgigs2G7y|3dfc?|ZduRyzXefYz06YW< zce`;8ArJy+S70qb<&Hop`wS7#fC^wYN09*=YefG>yB-h*?M8t1&`{8I|8U@9972e4 zQVcK!U}9UsxN>CL0XP8Mc2bm}r>{DcDWg`2;$#T)^sX*$^0oO;@AaBd+#g&e*zXRagEMe-ewsu8=r9-*@f$lgRG7x^dJ$KAfEPfF zAjQ5Tus|Q*Z?%l#Mq|(r4$rUa@3sz|Cn_i}u59aW$S&g%$q)82i12SG_StTX6oWN~z#BZM%Jom_{!2Pp#_zvUjpex^yjbUSD*0DFUv3Wi!NIpdSKc zEg4|hV<`@QZ#ouBjyhu0UKhBX!_a|*3M8QL6uLf)7{c!v8FlzM90}?t_@5%Ex`4v+ z7x*q8pq=_aUjU&WRCxOaKR_O%AM`h#_rit_Jp%iJ^c{R(n2;j&x9JqjfzTE);Wq-X z0KxsOk24fNM-O2bf3J^1yORi^+GuqB`KmEleDVY9Mypgm1q9v&H_5;$zmCF^Xd-w^m9AC7E;U3 z_frQ`^eUddzc>TC*gUsZJ+bQRKI0ED+;$l@-|7tCN8n4w^cn6%KaRONA<;C?g7YgL zXnZGpNi_bD*-8srC5Q?{ofJ8T(Nm!;P;^;92b$($$`gk~+^9$OD?D#RncOVdt$F;; z0@Y{};@i#09hw(*&Hb?6|1fq=-Iaywx=m8C?TT&Nb}DvKv2B|b+o;&KZQHgvqnVsK z?VPsSzE~IgM~sVay#482&YM2%@}bQ|nOPY}NnnJp``hs|vh~R<>LFO`mNT?6BCdQ9 z-F7e!KdJ2}M@IL`a`P;T&TgI{XlxXdijtFIBDJ`9Z3`6z7v>`Q-ks@B2I^WbDqk#{ z76-#ssem0TF6b4b6h+K=Tg`a>jZ%-E#tvqE!GU^uO5q`$Xmqu{7)%{3S1we~IDh@J zf+Qct+a$!wup{sNmF)TDH%04m%4I;~Y@y{Sq2pFp-=q(1P3Jw@2FaM!hRZWBKCMDEMg0r^_nwPI(?SU3Jyv2 zi|QDkny;@@PBIE+sRF%=<)c-aB;2Tm$)#_9H$t8)PR(X^_SJjbl3*$1!Oxp$%9o)r ze1^w#cgUfNjt4|WwA${%_@DhF#^kxF=d}B!mUxN=?isim2rGpRr7o&;ous#2W!C%_ zLv5Z;n#}u2Jx%jNkMo0u1f87>EFbK4*}ULBY~&Ottr2I zHV>&IQ7IKmYT3Fh`&-@SOlO8Gr7wE^nrn&<_$3%fgwYFy)Zl4h{(UGGnaX?!!xm^X zY2fJtSG><+!o$u{&sUoGQ{S|@T#P%%xo>EWhhcw!zCPF!2r;dwV#F~OJrpZt+YlSg zQ{x^Me!H4hBJ7~v*a!rcHU?)W4Yq$eT%|`Jx24?^BDQVT0V-9&$#RhUf0~mmgd0+mMl)0QSmk}IE)z)XcA zFH?dF^2r6-GrDcoFdI$wCDKnVdHB2#z@1GjB@Z6n#+wU_su@HmSzNwa^n_8V(7Bv_ z#D+xM6~TmP)~7kUC96&uguQt~F#VHdWREkPA(?b^O&L~i_xlwF)o!7eVy54_9oe>> z888TBE~CaObMb{qeRuC`r{Pk~J&*rD`h3_0YKF?2wlg zB55x-8*lWh635122Z^4Ee)nt*sO8Ze?oj|iS|F)vu z18%?XYC5lgL?igv)_QjX5cPVXWh7Iocr-yvyi>+z!Fl?#OjdVgE$aAu85S81$02iI z;Lc2dSj1L9P3AMmAm<)|yj8uz7oy&FU1HWZPg3p6mQDhg3MG5gSgmx><2YUjmNUyN z(1FDytXo=Dk5PHUGwvFKrIj1*u*5#O4>8c_*c&Ye|F7v|s!>r2>g-1fztmTx8 zoOWpyJ$9{vpsX>*iPM4o@|}f#&Q@+do@hr1xpLS1eXOo3QWAAd=GXj#VHSC!tT=D^ z`YsenPcK)rUQ`C2VW1tR(2HmVzn4QTr+N62Il-Wl3E0A{=m|LyPt;w~Yi!T%IW`)yd-0vJk z+BdIVZFGj*21A~hH)E;X-b1xn4`(1AvaFk@+REyTKCS}>@WG;s;4A`66@q_&hg<(){xiY*l}%ziz%8 zNp1KKkmmhh1zbLW!CNlVvrpbPmatrdb9z!)&ekJ0ZhG3D!$UN>T1&T;HWYoA7;S$^? z&dFH@%5@x4=9KE^OMCCQmc34u_+zIDcOY_!D4;RAps2^g1G96M{sqjOOjX)EG>ECG z^@*hKP6*s9(m8-~@JZ}dLBW(NSOW`dtqF{#bC+miv@e74Kv$>1(5m5PZ_|)(3lK%B zGj)G|OH55;)eK>(uk?;jiE_av#?>$76RTUHGM=;YkW|JP@iLzp<`s@}$H-OYB$XMo z91b@1ZZC<Ru#2RX3Z>9V&?vN`qV9`=7TX~f}0S8 zl>O^-)M)0ai%+S$r^qm&1ZYp>S&mdL5_e^<+0g=SW`@#4v_ZJVAeWrx8Y3*AraJ)YZ1ndQ)Y9DiFIe zpu~{n3CwsGS&+^@T);IGp;WK6{A~q6G`^67xEz&6BR-otX|KYP)HTpfvFhGNdds)O z{r#TT%Fhf%QM7J7Eo2|-+_EM6$Wm~us3^XxgLC{&s03L2&8O>mmf&mCC)Vy}K^jWX zI}&lea?S@iL?n-1>Y*(GJ@-V$>dZ*6Nn?j}7fWaFc7Zyk`*XLOSb2C%MYi27TE)1H zVvYiOo5knYU^i2XV}>iWQ3u5V*)8a~Znab@pL;vpji0~fyLdpBrFco=k-*yfH2n8& z=@^AgA*Ghw{q}*uy$76V30+-slr6z|_sJ++7`W;aKtD~YS*^f-`o4SCPwg}37%vn$ z8Mb!yVQxigsKB_=isURd-6w1h9TO{S&QUE~`bHs5z+CS{wk;Ca2&N0|Wj*sDL)Y^0 z);+icb`!dQ@GFCXGDahW9T0g8)v3J9Zz3PwIBY@S(zuU@8+gJeu|Np0H|}QQc*ug0 zq4~ny$h{%+^s||#BErX_0*Zbi@D__y5qW$IrwPRFPbm+~{yZw|+)m#&xB9Y6Mdd?> zgtzyY6y9}1wu;91{khpGgC1*FJJMrdWz)LYYe-3ifN3}bI&sxhg`Zp|jF(3MpOtNf zv$~g!OqVkvMwCRkGB(U<{InGNdt|}v2*^immd-4uXjo&JSb=tR)Bx#aLTLZDlrM9x zY)H>H2?rl95rRO`OKRKq>K(7#M@B@`jC0*@NL`J%{!QojNl~0)xJd@lQ=0y~kxJiIR#S*z($r zQ-m0#a2ftHJb`S@qWib|3<1(iyLBmx?|Ux!Hf2qXDq9-wyOaqIGd~Oe7N*epMEA^- zVlgIHCc%W3%44(>pmJ2B^qg|J4yN?Al0wT_0RZ#187lRbmzBtzH&vWth{!yzh%FB4 z?_oXd9|AJ5B!d^^o~)j?aqoM*Q}si$5=H`raNg)`p+~0hs)b7o2^p7?Gx#hwE*4e) z*Y$az8qBxcv+Hp#-Je}*b z|HOpzQy^jxs-fA?GrQH$wMEFN`CPX?v)ZYf-0L|Hw_@zTO}m?UT%%a(_J74RQcbzN-zQBhn#{w6uS;}l zg4iQC&2cVh)u2AUNbCzIwAB&JI^Bd${A4D7(iPn5OGpkPLcwjj^6b^ufhg8p5A{i+)J1P{ zK)ZYWdmjk8vXPE;WCnR_3$_X9A z;K&1VfWbS&pgLQZOyQ1Goi=3YtVT`|A>{1iFn5dcRVlS&)GR=~&{(dz{(4N7p!VDX zqkdRHc_g(6jY(qNRnMoWGYikm|HjixQ71Yf-sknw3FM11SBGgQDYB6w>Z*_XUL>PD zyD|7e@q*Mnlo}ilTgF=O1L37YJSW$T;e5qKW<}OJ!9Q=AfY5Gce37K`nT9rly<71D zRjs1a*@LD0O_h}_2U<`yu+SbNpT24ZrS3+p-VeWSW|TS-j&K4;6b98V`RDLp#i_3x z48f{Glah9Qz;qO?*6%7YgJ4l{`pB@^-W;~Ro5!GxtlrR*D&cYyt?h6nB0IaRdGCZP zcJ={5F9r9amGwy9$If!XLcMc>myMps{CYBL8tY30H8!*>|Hxd3i^0b%F)I|gA4ihq zAu1`2a;+=mx9&kAQ|CR;#OmP`Mq4Al=+qTDjyP^0-%W^)5m@^J(H`G)%dA+$ybeH3ynB6hlNNawKQ&fpz<`~jun#@ThtTdbKajU{ED z)8^%U#gcP^0+8HaKN;bp2wG8HRpPbBM~)WeF6*)>`_1o|V58`%B)sy(_H8woBA!zLH(jSFqNlt4_1FUG7XW89mbMK&epi6+I3m^SdF)vpY`IKA}1ZQ_w z0^Pz}@_N-#2eqt8ZHlvgh^b&i(1-_qo;K>_0pwet3a}1(wA5L~d8dB0wKIu!tJx|> z_*ayE?G?YQXhh9;Rl;cOfgbo4)=c9oop+Zx^pxwq+Y%<#q;+kYkI@!4^Q6RdkIFw% zBR4ED(H9y`G1wsvsqH-oB}+Bo{6aJa9ua00_?{J3=268vui>e;C~)OzcQ6grqhpxS z#Ij$Uk&$}>7ABTiC67nR$c%8*3bYZ-Muexvm)VNjVgvR`;QoXTs zuBaX8_yCv;oy^l~w97sJqOLu|4s3JY09rcxBVTiC=Y@38v&+MDWW=xqgF=AFnYRw3B$mzHn>jC32i$iQlW4XtS>1%-K==0a{ z@)4hnI&?KK6()+0g<-ztHM=eJ70w`I*Iy*>{bNg@9{z345qS`(Qcif75M~d@^IZz0 zbPqloLbm#s3zkG=Iee_`L4o>(^gC&`0*w{@d3bo`9)(=Gt-i6m8sE|0|I)=Nis?fc zqf-ZzC&UVJ3!ajaPzOBI33B+#1HIdNh_LY1_Wv=a8k2^)^ zmp1ZJ;~(KCbkV^5aZ-*KqyccOx+wx&*y1s^OMDzW3#V#{%2ln+NR1U;G2r>#)4xa2 zzrnhS(K8~P|3)rfD|MwheJSW9X_k6Ef;Oflh@*40(i z2vunj^1kLk63{P{dk2Gv<2sHM7MbUoMV6fI!z|Y0sSiy$9tiaVeiS}cvXmPTCt)!E z@?)jG{}K;oUP18lFFvb6*TL>h1=FhXgs?(@;mRY=<&8R)ok01-wN{|J3=t!$bS>K+ z%Qh&K#uX902|juZ^M*S`#7_85iR595GC8QmG+h0YHuto$`o{V)C7yl@-rGcwrwT)NpQrFlUsmQ2s2vUd|CVy}CYsPj$7m(n16lQLJ374hli z%8J@LAWOdB-d0Vp1iN#%akvYZrC+6i3ZcNW`UQBxLG9EPC)=o+mW(``E^6GXBja&@ zeo-AzQe?pS`cw)DJp$X1?aw1sd?a5Nd44M_v6OHpm{C*z*Qk;Vhi!t-z3xZYCFK49 z@YU`qvN(aUk*uW^p%L(X(*>1(3FG{!Y80rx!*rpeV#jUQj*iGEp$_`Oa-z{J{I6a&DPZi92pqWjDP60E`pXMF-o&rgZJ< zl*^P;KD{4)X#W-nx(ag~m)%LRVrh1m&UC~(gQcT&&{v3NJ;A^`R!Lf+CvpeltRY_7 zjHVSTsMNp(E%KrG1A(2TX1H*-Qxa#uax@8J(98o^Jt-_7-Jl; zGg;4>r0u!Pq=%)Ob2>n@(XqGV&w(EoJEOwo$wCSC0lxM15BV|gL?dgb+0N+=Hw?c_ zTgW0T05oy}X@>jwQ>XC7M)a3)>W@7bZG64cZw$9zCtfo;?9#H5$qD zVX3*q4&zD39M$_wUFj?z&E&d7Mr(nCW-zk6!OuOtFy^VxYSIwEOiDNY(Z?DfkvmjC#0t%;wmQr;?{* ziIGyi51^aoJpy!A4$ABcSA5iY)bzHRhH6_fTc0PT8W)~R^?#QbHT?M_I}te{OKlGQ z1-6;B_C3-UtY1{@f@SBmKDY4#BAVaH+fGG^B4&)m^_Qd1I+qWL9c|GL_JsI59-VP0 zk7ggv+*P+X*~OtK<{OlfUz}4wy(HjT(QUcoCvS(=CGvefUvhai+-4R4ylC@pbVpWW zA#t=(`(h%kk0=E;&16D937{pXA3)?!#YXogxO`|3&-v=|VJT|=j6GPMvr9a6x8hZq zk9rgAq^jCoS8SkvC+w7lxDWX-47A||w=4hl){=M6dWAzUYa*Va5I-tg5NapbE;f4Q z&jo<6_dh<5@_zy&^5DP*Ey{rdNmgsT?P_6+p3w1hHCR>X_8*}S974~1|4yWq2DHuM znJaw-%0amCGe^nJXwoL}R9Rkxp+zNzvpJ0*Ks*cCl)$luaXhdu0Err$^%b;I27Vzh zNm7DU@M#v! zV;O*E!3<`rky+s7r)R9lr&|)8b;HedPM5w-^XB$hNiwRyA}(s*)^wKarz$lX=i|kQ zXnlvZE!9O5_l}RVxb#27yaiWNy-G0au31eb`H)k+X%f!ruW@TzUrQnBgs_aFnAd+Nd|*xQ3`9_^u@2bhs3`Pz3Hn)<#dgN~RFiAz2+Ht*+Qk*h(P|k)rY)H(~7vh zOVRrXh#%kyb}xdub*|!B+*nV=747ywP>xa2jlU|Co^4NoJAy;yRf& z;TG=1V0S0pOL=yIQg6~yb*nvv+8Q@6hj2gSp2xh$pWY<#2y*&?m7YF0izDYll@b4; zje41J8=Z%OG+&@#)}{g}(feYDyE}ps-y=MC941Wc{beO-u)d@;OV}6jkA3iTKqPdF z9z%rOUig)?vZ$6Kn8XKA@4@#lX?Ad`{B7c{W`7RqpY~Y8DEdvR&ecn=tn6GMMic6g zGR!Mjbmm;^iae9dx0(D;_hX&pfjLdvdn7?d-%qFDc>Kc}Et~+np3`xjP3I_Za{UL1 z<$i}6i!9B!N8_CBDevWmbl&y@m|ngjyBFc@xO~mc4=>{8?Q3Ua)CkvghYhYpSs?0B^p|T+cjbxt0nRtN=bZC_ zcZzI}$S6$-tS&qcj5VKn%9C@Y=*!Z;!xLN7oif8(KvaYM+Uc~!PHDo7eeC={#Dl<1 z@H=P_0fe^Bv7Cm_zTF?i`SqrfT9au&2IGDTV)_l)l72on_ciJ+9G@=Dwf(qBh#k*2 z-uTAbvVsI_l-e?NARW+ur|*c88@XL0;YV>ikJzM-VL|SSJHtXzw(!6&)2@f!8QKQ` zt7Di#AaMIHLJ9h`PDl7+_1-;z2RTBC5uz%B8AI3_ZeQggo>MXP-yu}$foXS2z zwqOe*d0f1&vZR+SCE5L$IotgvoUn-U`fsoX%YTJ6*#8rbU?JjU=VJS>um%S+$Nw7E zX!$qSw!`C4kd8(yHbj-NFBCq%NlwIN`aJ}RxBc&rE-Gx|0xT5*Dk|6lDv4BU5wz5! zJaG7<=lh#`*WGRAg>Uuetn)U&RnR=U)fM6O_$r=*$&_p$n2-b{6`aQ6{10gVZ(>j; zP2|3DOK5;YAW#@ITY?E4H&#sQD_jp0BG~IUlXw}_h&)^*NQHL?2(gGzL>ZZw94b5{ zY*0U{KQD<=qL6qQ))rzJIf$wx$!`mgQm}<-EC_dpr@rh50P2|OBtnRkRKz_H5o)4+ z;Fp6A6<8U>vqMO`kwQ~w2M9uZi$i+&t$*=e$L-nvJ_QVzr?)qpkls9)RB|vIC*d64 z%|7%}c!41mWBSiKEWLb=C5)G>bdUfvi!*4+??8n37lNH%=w*&|49=P!v-_HOaRyB3;hY0iMmr;0&c>gxv9GFGhBx6{< zfhCi;y2u(ek)EC*G!on1DiD4D-@Uiwq9=dX)>VS28|BM?<;5W+2gnHPmTQ*}1>M$3 zDJOr=hy)M*isc;O2_oM2yDl9Z8`>Faz{lpN@V~|Odq=+?9&zvQDc}#_cD$XCH#~$U z(H2428|Z6cfj(0{)C3yl+4ujYH9(1w^M7uw{IK}p96$>4Z8qA+^daaicdFz-xF^aa z;ekx_x_X+I0wJN}CKdAMw)dtt3ocP(S&f6`1StPXnAF9$0ChIYNCkO>g%0|I7+F|2 zAKMJ&byw?a|Cz}*+M^pwpcS!K0pm<1O%Dw;-uU=bt^&ufBaQlax z7Zw*-$se&ne|}aWKWOYvL5``abspnfRJIb8UU{Y|Dj*<123n_RyEX$29R)%}iK>hd zWYJ?v0sIW9AHMYG)M;x?AQ33|!VfgCp*cA44N|251K<#N;McE#K7V9lqA`Nlgcrd8 zB1j>xzh4kT0Yu;@Zr>mSs6xmOf`D{%JBHjde^RjkBDN{G$EMFE?&j!?hBB2F9z}@Zp zbWQ@TWoX^B(D7O7zbt_oI!z++6*>_Z=(R!>{X)_&CC! zaZ1PV28|Vzk6>V}hoP{*X-sf51gx+s+QjabtHRJL|8GPhlez+O|$h%bzqOSW5O;JBG-Skg~>Iv-m`wj*nzl!e@_-KWbi? zYRB;c)dy~55y@(Csu^;X6lI$PM-u~MNl^Y%DbsFv`tJfz`6whJ^zsXO4#FmB1EqHV z%E`@Kp2-7ewK)RU6Z<%DP!dx%uC6s$$Kq-Rjb)*zS5&XrVoPHK)fr$CapEk`ZG1$G0#%Tjwn$*#l7&jQ3C@ox-2 zj3w*&GMnU&u;xsI27<)X>)-B2uB^c-?;Ljc>lf-1A8+ogN1Mjd(|Jql!bZK*6@0yy zyD)EC4Az`Q*hkhuR`P09bIh_dN*8F@3hy+{DFefnS_@#PY*zO9$95K`9{1NO?z6C~ zpI@<;`e@z0X#D*MG!#H^VWymCUAgXpl1pOf4-fG;9^uDv$r2`I!5C_KvsKQj;81(m z#uvtt2oHKrJc{n4ie1on8K4G@K$WS!+$Jx@vz34om#<*7wUa*TQ?9(!ha9a-a#`cx@pCd9z(F-Vu9paY?1$cKRVsB<_fnrYEdzfQ2WrElHTR;u;M z!R1M>d~5EVfc@FIL?NJiSST3`Zvz2EJ%ttG2sKpqw5QhgX+gqLG(XEj_N^CX3AZ8u3Dt#2VikYrSZ=@9+wmchh^I!?_CFif{f&YojQtX@kB#%H-z+?!xg zM-_Z5?Ha|tE$$TAm}9pxt*w@Zn**&Vu|%inll;E0z?8F@)Zd+QVDP6VdBcGn2@XNl z_OZyNUe$5w#x!Rjjel2r&qzj5Bt;YLzIK zt(NSJW^rfoD$RE*^gXX1rDnNz>j|63Gx?*jw{$3jd`{uI@8|*720jqYGPPBlTz38j zkRD~PRk}pBtH!D^EWrwvRi;>-d0ZnTY&$(4Hrr=9!(uXT*-7arORyWOUxyJfyLrCm zHsNm7=?Q{QR}_1iPC4Tel)fkX?sgM;%d5B0Bgb+MB`GbLd2V`G-#&Zs&b#d^-Pp28 zJ&oEuKDG~}af_Ap6f%+x(#>t1WcZxgrlsV15a1-jH|N==b__yq$jGGS?ZA_Y(hhoA zFSrbenTs#y(b9W;0n8dMMR6&&70AqDJ8j}f zhu15^{82?sw+{@4pEIvduH7e0WEPhSQ6)L+zxN7$7v0Cn$pq5xAA~prZkx%@2H?mYHJWEmkz zDG;?|@ijgDA`I%}$@%75enLQ`<5d!TkYf;fcZCfTH0WLg_GFa z+>VN8I*m%~1IC{-($IU-u2JkJrt&<`_76rm{$C(2ob`Ocnad$WQ~9;tNC)b?O{-R=^MS zxsv$6&!x)E;B%pKs~UEm4E%Jm`pQtWy5yf{P(p}5L1*HZRoOw!O<Q8m{G6B;DV;yBW_mZi%M4GMHp8FZ@QZfD7t$k)NT~hUms_eHx72`$wH|J z(b8b{y04^Z0G?~ErI_oftc07?phTq;dFRnfKXkE>hJuHZR&H%;qKy8Rc~qxG znC@z&_C8*F1;GlAR#6q*=-jpwYw6&bx9y6$-dc+2h()$MYoQCg1Q$FS){G4$+f;F$ zZObk%%zx(XiqN3)VvgqGpGU9AGZqaEi(Rx`Rh#C=uagfqI$o8$r>@e)Q2)rq@aT>e zkA7!hFoi;=p_iR@6E>UsFYr1ZnO$!TW76gjJ{ME@1E#31BKSM3Tp4Er2{wV`fdjCf}6@+Hgr64OhQt+VC(H^I^RD>+44r zDU-K>Q+dV1%9rKyc5dxjNmFD>H>uAs&=W$hRUph28*>}O{>E9>_Z&j36f?L^guJ8Z z?wH}840`ldfo3f|5SlEi#t7M+E4y=&c**%}{`EO|Oq}qB8dHWdljm&6_A$q81!YwI zYGknA;@4i{>64;VIcJ(wY*gY1p3(-)*5x9t`xPm0481?4HjAfgf~~M+Ww$)(DEM5c|+T9 z0L4wSA~+-O76`)cw_!Is>v)CbbwlREk7)EVf29O;%fq-~M=0BI;}nMuB?PZ4E@J_2 z>$u>R=h%!wH>!UApbMTCTy6{{&kUZG8v^8I_NfPs=^T=+KcYL>l?&JVE)9%M^lP_j ze|BzhA(IF}s5_D?tC0pWm1(yE7VVZy=0a1w5L`0eH; z^`pjOjF`#a=kL|;8AMX-5}!(hyd1G&0Ve22FSb_psBh_8p?#2IX|SRrWKV3Xk9KWB zt|`?RXmo#Jz#8otGJtY^lRz4!E&8f6L-Y)Q*&q>;2Di@RAn$SRTcR&t8{@B8e)l)1 zNTXsF8LRbQun*8pgW!kvg}^G|@cJafq0I#r^4{|g4*T$lf+0a4V2>C*^Mi8t@aJgz z3!Wddzz=0i1?i2om}Dz--%uZwhp3mmr(@sB`uy%Z}B!?_yHm>z98c?q|QgNAW@QH%);1R!_GpIQ{OvcQPKFv}JE!dhrsw!35 zv&uCJhFp9HWz@pfT+jef4v|ZXebLTu?vd5-lH-G~e5VxCDYT-=rkO*?cn&x5p7P(! z4v*0-QuK#N%o)sG!kAUmPDZ>(yOhHo(z1L-bGvY*FxaEo%`M-5{T<+jM93AU${b2gcW>&6s1h_z>I`^)UmYGz~1H*D3jVqSOWX(;&7heug6eX5NvdVH-5EV0ipY<09 z{6ABLxL$g~qat(Wht*7WNw@l}w$vp7J#bsWj9u5%0AyUPM^uE&g4^;#8V`$!>a5p8 zVlv_`dxu@ZBJ-PhH7?gU_^C32Po@{9xR3S^!y}<$J^rnoP(SZxSJ|8OKwv>Po2r;n zU{IlIljHa>arrY#bF8EXQu3&1PJh!>L35v`zRPik$*AzJ9OVIFh}gm4YWa=`;Q|9j zn!nQR*zVn-f2TR~GO|nqumku+6riXe(S#2LaB;Y2pt&>|ZdNu92=#qPm} zlC!cgR)pX*ego!C{>*Uu2=&5%~P6t!5j9zr@~`BO|i^3IS8e#_$8X2+uc8 zShXt?s@i5}S9w?7#z&!3U}Lj$R>E3)I!LnDbD8`wsoi)WVMZXjwOc&1J&IIOi0?@= zf!$7-mFIHjUcUlb{%&5nh*F3uvCiC{l2(Ydpkr+lD40U|iEwKzo^S^8DNk1TL3E0Jl;B_rsAdcrcWP=F$OS}4J;AlHM}O>XXOh1t;KQX)uqH=VauN;{_Z^N zLj+eI$sdr|PQ3@(*%XXHOPoFzKZHm+c0Y4&KF?c>ObU-L2_jDLP4*Hz!J#n4Q$#8o zrgxCA==p7WJwR7VzKXkin=@ppXzn4s855np7)9Z@vKQAwc?ygl!Xy;$EYxJpuqZmV90J0=2?u}IVD|Iovk>P>di9MsJvozQ@l<1 z7?|Wh_uNFDp@dUqu56`jKk$ywoRN5aU9&ueL9Y} zemJKL9r4?-Hl@nNnrZyQ~*JM))md8t>I%2p;HB!w;g^g zSr&EG$jL}Qo?W@*BuM9NOPmc-3-_{{{#czHH2SyZG7R>T>$1dFDm6|=jkVcdI*OX86Ei4 z#HCs#((17jbJavSK1Rp;Eqysd`J2fVBo~iBWoicu*b=QBd%S%+j~D6?Ip#=#(?7hX z-c}X7nhLl0rOlcZI@nvr1ab!u+FePP*F}Q5XTY6Gpm%*?dQ48rR@1nk<*>LWkT0yW z7I=r2`|+-~qCUBv*-(|Xk2XayzN0=}WU3L}%R@+&Q;T-9>|mc{YJ2EP zz#(Sz3jZ+wi%&9I(^j~VqkW8>Qp()C5=eIkbDo@FH0mT0DY2d#c;jhDarQ$G49cW- z)C~uUTYl`PrgIb6got9?NkV1HN%*S09zDVS(HmVF?WTr;QRk6n(OR+YCfCM4&*kf0 z@mMS{n_lVeKGxS1YB}UZv1P z*k?!lYo#u&Rnyn^@66Px1L>A%I21y}Y2`&_8-Lzpaa>rdB%8mtVV4~FvLj}R3R83R z3QQ#I&VJdyuRn9jrBS_*vYB%j_QI&tg=c7)P9nNpj~ zksA=;aguzV85={|a4z8K-B?;P`q&A=EPyr89hR!S8GoD+<#4u~j_BFAZ zhQn#5=JkeUkFGY6xxRY?OY+R5vnI#pmC@4$c2M$Ho6l5V(Ne$y=cMJHa?y ztTyXcX4OxdM{c60(Hs8lmeu2UZLF?aDQD@G>siNca!$>xfA%@tArQpPZj{p6n((@o zAg=pD1ZY!P#Mm56GF!hOGG3hea46qh-K%uUw4LjIl=%wn9=K2jjJfW4nT85TzUHJJCoNM^litH>nD?Q1T(gy+-_L z8S@T`ZM|H$9gHoH0nUuwoEkWP8m}X6KI|;%J5H(DhPi`+6EN13TeIy9?riQq2mAGK zK51bPx6RbeL`IQ&ewQJsAwJ4YvL&jYX9VZesq)mm`J?Nm_}L#_WQ8rQ=(+v51yAfs zmaj@T&oaKIZthC&voHevwuhZFn8d{*WItyJOOV1#4Wt|MH%7stdMA3zc8?tQoR1F9 zffg-$kk(Ay8Jot`qb_|*q~gIJG0NI?WL1l2DNH+4E{55ClV{#Le9;g;@VPkGymxxV z*UtHi*hbaO^-ejC4_3D&JjS{y+?{ zJB7^UdiR)hR$5bNbDK;Ueo5a9pUiddb8rBHDpU+xmmwE#8Yh|Wo z9~?7jylB#ng#=#<1?XQ#Ll~%g+mk%tREo)>*pYec_SPvrj4>liq>@E8njW-&Ww5RM zya`Rv?ylBd*!$rBz(|s#+w<);4`taFe?WH+@5~_FvV_!yz|87o3hot~^78e_!b`cQ z;CFd&Ca`J-^+`%shfti8TJugEYShY03|BIN1NS&vfnIkhQYF-aPvAO!&3t)5^lDv) zd?Fj*O%xsOZh6I{b(@mDvGw4-sTd-k*#oSqYUaHL?`9vQ$A@%cglSNk@Gmt@kktZ5 z@Hkft9wQ#tDR*V(E4*3l9eBMZz9 z$DmR-CO@9NZvOgGA?9Oi9x7RO9*a$O zOL^{?4L4Z!7dByX+-mC)_>a%3SJa=MY`Nj8(qfSC_2Fe;Aj!!Etos0Y7-{6Kj zO{n73nv4&(wI~NyH-;!bjpV6qLuT$J!TI>KGd@dEhBvLcz|&nPS1rzQ`(OPEJD3n_ zP}(VT*ixXfLVCHv?{yJJmvH&;q!%mFo2@>9-YX;jfWR0R_JDS}6Y)1RHj%c@`s%yi8JJ zK|zR}pbF)`@gZ#gg%4q2X8Vu8pM{8- zor&{5cK`or^I+y+W&eLV4_HPCOB)wcCn81(8$%aUF;ioE6H{0L0a#}jCsRXPSdWdE zmmewf!y(&;SIuHssI|@WQ2?-EZQqom__-p)j(7$0dm=qw~ zUI9%x^m8z&azisagYyGZTW_S3{sf@OBdQ=23=D`Hz1yH7972+C#-cg_*#(W!u1)}-?w^V`y+414|IjzkyMm$vPE%VO{0jfV1Izq|@R8n{@59cS zeyMYl0vzi3{rW6?uhAfJX<5bbo%q3}2}nwbND613*bV-wKtOGF0C%6MuK_wwSw{nq zio%KljEx1&{))cS{r=kjYE_z>-`{Sa{|YBJva|r(e@6|9-Tnv-J@0Y}yx%$%0Dakk zdUVC{fC7>KR`skf9MG<;_*qf>D*pbO!`M() z^ZeBOt{I}8#zn<9eYQhw{#sQ6eyt+>1(c!Iw*IM8om{^=WDK^RuKwK=h9Yx-a?6h> z3~6e3??XM~V|oL(voU~DZgy&XyJP{*H!?K-;_HmlVru#A`YKMtAVRAL=(J23o`y4%M&!r8oRiz|`9GV}9#LTwU!a zVQu~M_Pgu`n&j6HXWRcPm>O5fi)n6S{sbDoxSMki}%~!w9 zwX#| zuRm_^`ZxK(!0Pwj#J~!M+2x1Gg6zOsLPkA1c_{qA;mE%@`f=FnX&24>Pvt4yX>Tf-~~wAng)AbK?#d190) zIqOKqT+_(@lp9x8PW8i#aTOfx;}$RDFidIP3Pw<7R0**Ktdx&a0st?D{IKRy;k)z#&JGHqrk#i*71~1$**YlFiQ}6aP zvt}6Kp7N|ts$}GJ)=Mnd9v?N*Ffs=09yE zsrlM-cP|i;WgV3cj~W7qB}GPWm?ucrQ;I@A?iCpxCY>YslCCHgQv2%$YdzGT=vFSS(% z(8GMYr5?2wvBVKWzoM6TbrS|1+&L|DS!3QT@3}Wm1|f$e&2!pX4HVYtLDCkt8Ira8 zFot$F0C_5zgv|X*v$&Sqw|oxB(KV!0d3-CB;6X4JcB{8jPoCt$ooLpPRc21aO5o;V z#phW{2kLt#VcLuk8XG?<((+)Zh^|d5Ai-BCYVl0!LW}{GVcmbGmKCSUq}8-Nptgrj z@OP7t?TGQY)Dk#QUfJUPbE`t#m05qEw|9T6jn^+VPJBeiiTcT4VHUZ8;SEzdcpJea z+h4**FhW7!WKTP$!4Fh;=3GJy6yvrj!{K`R6*XF$jyC3SkOt+g3rzS4iiPfw9uCZ!`V@H`Ar?CU{4|ygP1)k;Ox9`^)VZbNWHSo4NlU zEE|ff{^I|Ia`uf`8b3&H<&3Hvg0pdd`F!hRyeyVLwMVF#2qGqo= z4okCuuff4@dujMAHYA2-_+P-HHeZ|<`9 zo|L;)!_+{M?c{I!!D=LcV{Q`Uzn?-&CYOs!fVxlt66Gql3GUw@y_A#eTjI~_F${Z2 zZoWe+pdyx8te`vioaEjz`vN~QoRsbC^4j<+#*jMVKi+5NXvKAQuAU_@a4rNFW`W3; zoWxe73>dQp8Vot5AduY*e%A~!SrCho4f)qDS<2abXEah1A9sBqXwx@Tty){r;!E>A#fr7u=OlZ5+biZnNd`^}|HshSeIuEpkizRJ@$iQ>dwBO-8RjUzZM&4D z^n0cMq3gb01*Zba4XM}>V?)tCIAqPP1+{qPy&Iw!dnc*&I@H6nhwg|^NlozX;A+L8 zBl`_%A5Y9ni|at^MZb!jhKswQ#8eGdL~;B|(@f8IxR`3q@j#a%E5Z8^!RC`SGK(i< z7+a1)28r48x`%lih9)6H-J9Mo(<8doVx&d82|m~r=4pIPz?a4V{h+X*gvrps>SQ6@ zYY*UYLX%q)5FbAe*K5WOh53-h#}6xyW<=r9U8TkE!tq}{W+X)4lAnaBDb2ghIPaly zBK!wd5V)f(0Wd$KX#=`Qr*2gfg|p4AIOgeSs&ZivyQLjYD%Q(L>O{%hj_{}T)6z!e zCsIPo!$j?6iXX96a<3P??+ZhObN~ zdpE8&6uaI4?LUo<=7aW%e7JbHg%>5p_JO34Sq-D#rfV=F``VwvroHJieLOp-@^GVV zsFjlpvwwsuIwTl3rf=(QJ8;~jU%%p^k~2m53*X^1ZOhB(mh(7hd)*nwn|US*^pXJ?Ks?UcD|I%iA@CN z@O+N%cUh~kP|9@P#`O+>&$x0E!*AAYKg{v`Ou8+1SSN1Y0btwU0Js zX!zxF=zvbh4;=Q|7&^&~b;*u(ePTqKVOIZ|(K&=5==>J*@@ei-N+MNY?gG}iQsWSg zWLjG7{#iSQF)SSb+_*#~d)@b>NC`v^kM5lULw`{`6q*?nmLQvlf_+%OJ%>UjVVENlw>+9Uf1&f4|)cNz!`XDhe zJ&Gd3YZkBshJl&9oF2O*p=byV%ov5H{~J|z!XYd@=r0%BPA zG)3WBj5sSn>NFu20kw$Wb2etd7PeNs@~ki^jy@-xOFBjY4o9I5+NxA(Y*;f{BTTm< zeUhx8)Sbh8e?VEm9}3nslb?G{^N`J>2l4My#LiJr?`zo*bvXQKr z7^P3^&B`gfwBX91(k0ck{u{0FmLN|Eq$1@~%~0el5#OZ>n8f&pZ{{n|fU8#TCW+Q^ z&#+kWj40e{!to(EWz%zX-2FCzy&4HjcBbHa1Rd5uUYF6D2Db7p8NWad>?QQ3AH+F} z4tMUYBNu31m?l*j%g3dso9&;(U>)Q;TvcjQg=E$6r$6)_Ih?QV&XI2nnLEB$Hp96) z&cXQR6n?cTwu4)g_Y-%b*r1HSnpn|zEvV~c;-8dRo3hgQ6pmjjtA|#f4j^)xn~xmm z@njz}3mSZLIG~H21;uuakBQaVp}{+}aWAzO~_= zgS5zX2a5Fv(7Sfh{@yANp=5gG78n`u&3Ba)m&5p$ zmmnG+Qi_e65p=3lrvZ6qhW?qWuK{Xm1CW6)+1QmOT9+0c>g=>@)#7Enj70f;5{uIF(U z2&=)dV<>OlAfBRf+!@vp?0p$gei>2zZmLT z!%aIo8M&i8!I|-#VkKRPbnrPx($bz&$pJ9R869s;CZiwtg4@|O`04Bi+MUQ8oe^$Q zjMHOK)8cf-?IOLwj8Y)=)*;?my}wW~ZU|flR`A{(eo~zITLzi?NQy+FgPc+QhFAQZ zc4SLsAj(UE+GXt*)xGK{e0a~&u$jST!DW{Ks}klj+jA^cHOmW9g$1(J*$GN`ZUA^; zD=BjDllrFH2CcRCZG}dKAX2-H=74yP%)~^~gG;1gB2W$DsM7YzukKl^5o=>+G%xRj z4Op>Xnh89Zwi$07MR&t_T5(pr2c+;1rY6#Jh)6V_#%_BM_=iz|BofbLR7saz-&6w9 zxSK8MmtOIFbAzKmTN@(Pd^tC1DZf*=PWp(qs*KYnfooTGG14as61;qfR~CQYWWZay z#n$mcSM$+QV#z|`7*swbSDum{nkt&j-qvDq0kuVOL>z5knAb#zx*79hJ-Ati@2s#! z_2qxo(U5~f;A={|v(#w1^Vcn!^pkYaS!y*xac;Y_G@d71ReX@6SsbwyzoQ+a^?6I1 z&E%FKB19r+UI&6^q4oENSzts|4qn?_^CT@jEGiC*s_6Z;31}0jeLI@9j&|sY5) zh9J=^FMe+vBVDK#ZRJ&YE*6j;Ej%y*X6)0>AC64PPq1^gLGc?%A6_B4V?P1go-?I01nV^f(12N03d&R=gW#sf@RR@u5U@2a=ZTHkV98{S68H))-*_ae@ry7KsYYF=m&Sil%Bg|O-dT5R16pASy7kqOw8 zfl$Hsd8tyJuRsZeN}_}`N^H_Ca1OHyv3r^2>PmaGYoaA-;1 zh2~$4w_V#K3Fw#uK{voA1!-KkHA^KE)h(*|L{zvlEcBYE?wnG~j&|spsq?1fC5^y8GMfmUZ=5W)n(Za5T4UTS8lLgi@lriWZR6FW;I>4;Gg2A_<}MVCUZc#FM>FC- zuUqoei? z%IuSn39g&gQa;c=xoVxNZ3!b*VQ-x?i2ZF3>73z#yce&TrM_qJz8(PtmP~%5eyQpI zLz9C(Gwz#3EQSychgstEL*4e7DFLUEkO_Cz%K9A2w=KJgNIDHvu<)H60pu{JQJ|wW z@7q5%+E>N&@NG5@UvB@yrTYfTbV+~T!7j1iDQy~Z)rH=2S0F>NQ;DVhlgV&x-@;)7 zOBZ2L#kGzFGZ0FRWo6qq_GnPX2=2@*AwAg=siY)LKaIQ;V}haa**~{3_;?^tS2Uy> z>+GV+Z>BAy&tmA-Pdhly^Mbq7b0i^Y;y*x1+!*QhKodg1i4gX(9f;b&*Hd2wtp;C} zcI%E3qK;Vle4{fzx=}>GYUbLM3$BGC?3lO6;IIzODn^Po9aOCfm@6?cPzmEL0%FOa z%J{wR5Dq{RXRqwZ4*;XYWj;3&KI_>}Gy4`CD_PkRov!~5jzMbdSAckry>#>OOp(!f z=3?RQVJs~L>N!5;+cZX@fDT6_+E4=MLt$X_fN)HtHhu9D1p%$#fJh`~eZ>Z9GuJzA z<%0!F^j_l>!v?q4zaIOc}yujb-Fzd^9@Pq>Fr)SF{koMrW1R_-zJ! z5a+cFGIgE2&fN=HUD9##!eY?_p}3SY@4W6_+;|O%XuoMToByhZEy&eeiQyhS#AqjY z+VgIh1QokF!S(n@&+nz}~CWxe`HzyyzXb@daJO0SS=UFzB^-M zo{Fp`RMwgl#K8|Yi%wSOvLNYOgaq=nV;mtvEcy3H+v zsf2M}S6OtBv)C|#p?3aI_D?J+H~5304wh_h-_C(4RD#Q39Xwi3G>OwZSodUt4?Fy7`^C;I z*j=}G%MXSf@_q#F>@#xu#AXG@yE{w;7X>|Z@98lq()W(ZgZHmElhDGh@Ak6 z^G24LlN;B$IJt}^Z0zFf0Vsj=3hCNf-|;0?WOAP&Qx6ALEiXR!$e|@`{pbBxDxB9p zs1Bg*i-*=AUp)ORh`GZ9wsNl|>gj%_%}M6omrrAt0&{{7+97wvNEiZCfIC)Ioc3Y2 z1*!@Vw0Bhx^6A5znp7e$t_-4`&Byejh09ipQoq9L!*($TZYKl0Lc(&KZv@bs$fhdt7a*iA{R-rBU$9i<)u@!TNh5+(IT{w%2#`$I0I`!oC#?wh}^&0*)naKLB z^9(o14i0(`$tGcJ)5B^}w^%ekj?1xUxC$NHM>mncxLdLD7Uf9a9hG&hQN+@3?T3hy zv+#^D*!T8M7)odB(WSpC;lslv&QK{JnS;E4f}z%8h}jopKesIe7GMxq2*Z-PwoU|E z5h)|nl~K3}*5AH+vm;zRWDiJiCd`)5(K8O{lTo{>c3rR!fuZ($pwVtDn$3owuoM*N zglXZk&SO-@0LNuOi!H}%P|fen#xWn?cN$8Y9%_(s{X=Qfd)F8Kw7%7Zwt7H`Gde(K z^G5f(=&={o9?7Gh{T|dqwB)1cjJBK`E`Cz%mL&5f%*U@m>hM zS7`EjT`t}=ZnyQ7urBh#hQquyoae!%0ncPk)e#l#qaa zDCyf@zExWhm1IPl%27fR$$ADIZilxbZ%rbjX)s8l&rKpEkmm)3DfrZSuVo9ZaCo>O z7w>aF=JZ(3m^C;R4(Tg*jRC{0V=?mOnh+yIUw)%rtrn%&oqHScE&Qjdv)fLlNYpzS zBlgxqPeQm(d>aIpAq~5k1$a&|R!t8>f$N}q5X+Oc1HB7(qMis}jWEvdy!#@}s^z3S zQ@KTfgDFKXzNuC3k9Ir4x}>5L5_z1NoVAm1Rw)-4rv!F9*9J8T6$cmO`u5in z=`AFd9dnQ45m8#~mn7LGTZS~9d|A%@gGx|HAW8sCZg}-+^B#X+g7`$3c`IHDSRits zO*h$8nOIgA+!s!3wSgQe%tg{e9MT{YJV+X84)(AXA^y=`<`TDyRg=)Yqk4v6UJh4m zpWINMAud3CLZroOh&CTtGCOj<*U*hgdg%cqTRMUv0^*W;@DzOM84-lug)v^_L?Zk$ zH4aQvDF2;AXn*Ts6R}j9jfv-;v`X&+^DYvNI;B)v2CXpA1TEKG0bQeSCCO}|s=0lb2z*~I)wMC=I* zKSRQ5$Jly^{cy9=X5Woc*zULcAR)?2io@T3oQ*26_;|L=i;VPo{CnH>WYF716U4G*X!Hoqd2PgKeWcY4)fZ{2tCz7n&pIm8xB4I8 zBuBtT2<-P~Fl$@jSDY!|rk+zX1Y}>^uLiCfT8wF{Y{l*VwcRr<4bLa#1%|s?pG$*$ zdo$b?4%`c6h5GX+>PAiN*;h0edq=Kp%l-v;UoZ9GaF&Jo=Q#K@cTLnSFwe8+YL>ll zg3GW=S4f$GZUfyTbEhwZb>S}P53e!{$-~bYT^PEov1Wz5P0W}pE07NN+~4)?7C9N* z}ARsyaa_yQpOV1$A08Br6m&;T2_>0jK06^jGI~!+Nu73+kO{#JVXjWv?Y$= zlH*|-&h$YZio8%x*A#8AtFG3~BkF9jh=b&$lsLTfuBO=)d(--4!?^f@GVO+a>d135 ztgbbGa)HjF>d)4a>427@{(JvK7}D2y_oAtEy+@jY*Z z$JG1>b<&{bs_W1_T9F53+)fbVx<0y2N2mZLzMC!hYFUnlPQK69<6+l6HrTuWPv?bY&wrSzV>5bBM#P_!#+R9zM9*5WhCtx|GC{jp}`=!Tm+_Ny*sx(`NT( zao2PC1^I0;DAPEoSC#Cxe0$${>pUN0gy%snml+xQHnC8DX|o6ZXiEuU`a!U|^R1KE z3#Ri_S(rka4NPwBf-)}IQE2OwAzKi3w!YQ&-L^E|RTnFq6z|bYMY3dG2k|ij^StLK zFp%v)kk5~6x)R$WNyrG%8Lm2!gb9w}bU;c|T7Sh^@m5uWARM^JZbt0A&>(agcH7ys zzo_*Q18jw{BP<~Ch6!c$ST}ay%^`Sg9hTejY>`dgkC@4x=wE{BI@3;~>04PO!!W&N zklpjfsFYqiXPRlj%0@1b0`p;q{eg*ddK6Gf}m^`prT1pbku3R&pgQ65l(%X44U70pF$1H#^MZr+H<9;d`UYy&?<2VB|t zkx2Z`XN5o)|KABnNZKA3$AN8IE=x>$f>V`qHmbSaX5HRHW2oab7{?q?x0mXwdo3V0 zf))*IJs&!wNu5Szd!XYg%*TZ4z9+EdU`P74w~G$C`7+s1QhYIYE{s+h)Cmv6P(o|x zeyHTlaYQdLr$SN!>j6S|jHS$o3gV?v3jK9A-B-EiUOz)_I(0t{i)7SyMU*>v~*m;WM|y4q$j2;;qaVr zhiV3&adW4C0Uz&H-re{FVB0Rqr$O8$kPCM#c5S{{gp#E}XHh(x*|Yvm8z#~%dJD$~ z&7!vEFir9|Rn&!AJXf}LggUDmAfGW4kzK-;iC=Mbw0#Qsq-NewLt>pkfLa^9@PzI zs@-X3ljIvoW>E&EP1dJXahS8!9YKj~8m^uWYzpEjwB4z(i_tzJL0)eE-As^|=bLn^`gxq~#~XLyxbZyLcUU3(XQH!e zkIbB+31S>2EWzc_Ma~|Mnc84yCieR{guwgW=)zx}WUl`gzUEQ}^?DeBMwEu84Yye1 zO4#gu(Q`cLwAQ2%xAL0v;BLV7V~uh>yvjA%2V&QGqa_j4)itrgX-{DPFvk*kYG+AM z{c$$B{JaEqrRCj*GS!r0QXvJqu9&Ka0O z0@i2kZE97}iYaJA%KI?QOZ~7X=&ysATdk~aG{r6>`Ul+rC|jFL=unayO{K`OTqwPZ zjW>MBx$atCbgc5;(~Qi5`p2O@_3Z%`fJc2jvv{w9*M2>0hA)6<LS^7Wmx-^s&Nkb{jY*7x~Rg`JrNfJ9sZ%u3kYYtbuZ0ZzMZt055aVE>#VTX zka5^r!ucFKU{phW)<0Tapa?|Wp{!v?)A$1{R+xD*_45Nqf=xvMF6MADq5dGsYPl5D zgCm^Iu$AK^dke!y5-iTq!Ehn|f2F@{!<6E-R-_{QwH1Q+4Su{38w!u^mHgOY@V;>T zyPPK9ryPo7)n)InQ+s*ozz{jk^T-6NHqUsMht*=ty%awQ>Js;slXDYL z`TR2qy=oCwH|imW5|Er9zK+qXC`YVN*juoT7}`;YBl#(D9IeJCF2Y6T)sI~XE%8;w zRi`VliT@-UC!#_oO^;#eYtgf0uS2Zf>^}c_YQn8O!NnbTM!iW4`e>`uh!=>}G3f?u6h z4RoPSG4mbiKHc*~JKCG75qgs-MpiH+AZ{~(B|4g@X8QLoje<+w;l!a%ul!J=!3dif z@K>&&LY0tL5|Uos!m$2U2WW8zIeRJQVyAJYC?L>10|hhU_z zp9*dw5`+B&=CPwzp1jmK%oEFVgOv8ttlq)E;gv^`DZ@0?6Sb0l9 zY7`7mx3H8k9<^nZqLBKWZq>KGB&zQ`4nLPcSmfxbBx|I?sm5rDaWUhycYavTKp3@_ z1SGmpzG>fyb{upYV?8Xfl*6WQ-W!&o*LD;(`7r2v(wQ*(yB|-`#hRcXEXRj0ZdZHZ z;x85fMcIMgh|P2$T20zHpVdl&N^}wUeUTW>Pj!QAIt9SPUZ;NXnWZi8AC8y3^vLGj z2{&e@DQa)sZqkZx+e@@wK3C)j8@&yr@)E2^F@ZY+nam&XXO2&yb4|6-Xv;7GI$t%TJ|B8xJ`McDYafdvKX(dMT9X=M=ZAaRPnM_7vw9B-HlPILp zx;Ay&Qw|^tuwLIfQH2%8jG>U75urFP*Szy(RD7$15cz5lk>Hz`WdG>V!vzpf9O+7p zmO0Awi-s*@pq@|K?Q9`z@Ab10)is5V(zBr31#8N-4wNie+0O9{n!zFI>3txqaxSgH z!VP<_JM_`yQPHvDu~t2uCr8^}e?sL{BRq2_*%G^GUmwtK<+kqooW=?*t4k)YE|_ZC z`PVtKggUq=Al2w%sC)}M-9PjLlAuJuRn&G)b@5Ny5p+ZZG)&A>I|QZxbHn zYA_ej5_WnNvq(m&tItCkfT-oBz8;!XgdokmVa{;#r4Uxx}}=spvt(%RVDh2hjM>QjjWI=9`+B2 zu9k0Vo;X1gseUDuu)F^2@yIh9B@R~WA(tx8yPNmLH*C4&ap)6jcbO- z6H=5u3N~>LGRi@0Lv=*SRA&8Q^7AHK0!$Qc2*?0p@Un)6v}d<(P~gyUqD>gp?xfjR7s zo71$3DZT27+ImXFp9GWko(dqsjNI#>rG0TL#Z`=35hx#j9r4Z^ynsLiB3|_9s#i@H zHTgMY>Ey3kYJ;oN+_wCbaSX_OMC>dzU()OZp6B#z)gB>3u2L@Ido(77A%aB}fkrTb z(*n->)YM^=*&bVZ@m*KfTRc^qtfPwf*^&=JWMvDA<}l3e$3x{Xm*p1~@8m2&R=B5V zH>2#J1JT-lw9%-N7}Ya)nS7AO zpb+}i?gT(Rl0JlntDbn{()8P3W8eXrvoCf z(IK8jO+AjGQV32M4Raa=S)zE0R3Q3}uBvBGCEhVK)y}Hmp0nGv+Qb#o zm_AO9=64bS&78dyhZ>{f%-`t}FXQHK@cW6>m)E3xE#=ja{`k%=KOOLTzmrTTEG8Pp zBC7&=MeT##gs1>k`isB(yF23a!x}%_0!cG?3$0LoZ1wn&1L5!kGihJ1pIaT!y>>fqXqo z^pS#K!7X$_9(kuCiC{p#J(KZ_ILDBLdU8a}_a&2I0g`2f_)Q3QnW-UuOyN8~9Zg*0 zQJ&AZB%ujuudleiPpsOO9v~aSDqQGGlY+daoNg8%`*hf^hf=4QGhNN;A_Uq?iF5h{ z>=~-Wp(}EV_pK2@fn+6P5a#Vw=e@G6=v^^MJu6s?&h|1&3Yxnc{vzSKR~+zRQ5eum zfqeRKhjC}u%Mzx|erwjgG+mVmQJMynjrM2@k!GJaJ#Y-791#<*S;NgT&2=n5_F_w= z4(zXa&CM%5K3}(<<0hscIK0N?r7jnJO4~oPv@#=xV^j!wbUd}_ozEU3!`QIY^!P#2 z@L#WJFfFv`0w^@Z&@Dt4_ZG99LN`=(1za#>T1MgMqrVTbKw*=`BY`n5qZ)$H)DezC z8HV%klBe60FEO(_%@%j4h9t-a`b|fk>_D6xzRqD@=6yvAr?9OY2U4!?;6E4+3-BZC zTZKdt;DE2y`WExDE+O)p4nFg~cZ#hHsE+V*?336U zuH`x5f6$0&a&u#yVe{Zx(`%E4cX{*f^tJ;vK! z;vruqxUCw)7j|z`T$o8XKufy0u5xqoq7^%RH3e{*q`U}Fc#j%o9;VmUlrOAo4#S{W zH-W1Brk7#^^Qh;?oCQw9^9o{RZ5SHMj0or-ox2-tQ>guDI+4c7&a4GCZe(LB9$%fK zD9=&U+O7e*=GXw;0DwH`?SZmnRb7AEB7Xor>NcUqURMDcjVv6xD)0qf1Vx#Kw$T!-JMo57u8HZ; zi20!#t?knXlhkkEexI{!!R-k`&K!%ff43+CMs5(NSQ%)7>y9Meq_?KBuQ<2t8`_#hTbsUfaofSyU{mJSi&E?r=dB3!)r)d&0A^&qUxnetT zwdG+RdyyUgB^BrqASbpiAY4N0!@`;B79k>plpjK#p_e1|6sAXt#|DFD$<(72KKjgF zxWzJmS?BB6iAjiNNM~2U9<|Bcqp=@6S8Zm`1CjnH=fNep#j}Yxst6Ya#2#d#2vhX2 zWLH@>_Whb0CZ^WFli5)=u^-uIRG0KsulWKj@DY<9sqsf(w=6B3?Fx)YP9DXxHimMIhCeeKXMbf z-`LEP1EN-nf$wG0ZGWk#TKBBWs_@aMmzwnI;)qPZ&~NEl;_KN;%4@svu`c`P#R`52 zPA3-{y=!hDl2XC5p<7H%u zdssg-4EUXn68@3~Cm|}eszbqmKMulA5wziRm*)Xm;Uvtd1ajZmU%A!RuTw_bst*KZO zvh)G{ZE$hEjbg3wH9|`scG!G+Yc$qNN28*d=u2i=I*9o@{o4=cQ8Gc*tj7mPP! z)5HR#L(r@sEqU+LI!#J*F9X8poG6Pi3SED`jP-Fnxp*^#tF8Lc`@&=vP;SO9&c;72 zm4k}umZ+O^)0TzA(O2Vwqa`-O9OfPzq_cQok=tNwx+oxkeMLEY$(@O6c?yq_q_PrC z<^@jiE3&K4N|~#bZ;7bor%&@8pyUd_%OmJ+RgH;oi|tn3CSR>S>AuQ7DyhzZDQ3|n zhCZ{zKDK6q3+BF0#}5WmfeY+!_yR=57+1b76NjXW{$3Y%{a_ma>kvhL5AN*|oawE1 zR)TBBz@1!BC{xK4o8N1>Pqln`the{1iFLKYH5!Qi1>5j;d|3Upi z5kjvtWbh)!1oKpUQPt^%F9*G=@<*IsDV)HyI+XUPL30wzXGz3(LPHv~Mfe-nOs~IP0ahCL9bB!*PF2J9pepSL15FMyfz&B~V-Lj|<@#eO0l`E{Bu8?Djc`no?uv{s_3XF?=6t&SbPsMk{?M$%%g(JQQt<`LAwiaw1 z1@S}`8BFsV#Gh6)g>2ZFS-S~LYo2X8Y7J?hm1xC?sjXj1?Mm z>OEg|$l;(l&7HMdrlw3X8kW=p-K6 zr!MD~ej?3s8=3Iet?oD9wLUY|<7BfP$^q&zhl7=XLgNhFptPEkrBUY~T);gb(yRT2 zO~FmyBFZe;>`SYE$+(1DrC>0yF$n8hSo&ny$bWj+TlQF0>5{)1*NF*LM*GAO6F}pQ z5zEV?j^+_iB7zs@IwEoU%)r4OwXtbhaUopz!?-ybzoK1R?)I!WJN?$R`l$`zsIa!1 zxnCHyCN-Ln@-X^xz5H=al#3thK4o?4bIUamZ1NBA9CkOFUk%43b1Usi9etvvtG0j= zD#GX-FZILMk$N!;^r&^?+5kmCmV1dF96>z1D5EZ-c}g40WL25Av3g6czKWL2i2GEH1a&TD23Hv$_d z$b-Z^tY;w?{gf6BJ7U~LoV`(=LtAYLT)&3QuCLK%#mw@iLpNcM*jH>a0~QMp)VBbE z&ZzaT^duEH?PLP4pJCl0TX)V~xk6B1Re$GY$8M9VKD71qV*un6E5^>m6HD=RHIam> z2=aqnTHW;*X1*fc8rsENIbKJiJrhbt)~Xq!lw2nNqnEBgdKgKWw%G!>mjrzwMh8sg zm{cL16p!$_LA$%a1`Af|fyQ?7$omMsE5VqpyK8oDG^ZT9%*KCepI#lKRYp&1s6_^^MO}S6HhLF z$wg_i-=1U=K(@74`(#NfYNw%%6dCCOT6ULIzE@@9v*ApsA^U5?9@~Ek}-#_5-=H;1tUX?szuXyU2nwT48E*Vn%Ti_2}WH=E7Cs;g5#jq_urTkq5IQz>S^w4x)5@%AHBIA2W1p zAcNKq`L)TG1ZF1YS^7aWtFdos#s%JS{zx0V;J?RVEqqV0S0z@j{h-D{NoBRGP3+{_y2GO zn3(D5|JywA|KJKdfyigCuYf`xqEfdnx*y)$+`tZ4MJ{;IsHs`d2bk<2FctdtTeDVQO%xY2`1{JQ{RY-DV>0~|(Kb_b-UzLKV< zwiZ`b#?)8Sn$uGxrlg5)f?6BMz18z{FpH14%#t1)ex8<|AHc;wHHFeQ0jqbsZ*Y8U zs0Ub6S9kxlI@_B9i>G%0%K}Eu0C0qT!AB#ebN~~hGpjF2xztMj#RcSN(gdKQqhlM& zy8%$(if3Az8ph2xKd=O8^olY!HH4CPqX!Ps?)eD=BG*5@xELRsy4v3#Fg83LJleCS z5dI5r2hgPnxWrG3Z{`-yu@~nEC`sy?&j)2BSO{dU9-#AsSjDB@?wQUW1YifGRgW>g zb38pTy@P!O?H&aqpQZvp&J}p|%c%PH*B|gMZv{X-L;bh(Gwu~nSpSnRM`mgY`wCm; zs;B=Y6#%N920Wj-r2pvRd=h}Zf$eu_Zg^#6e|mR#`;WDi;fLv+*#Rj4g@TIzgqF{5 z#mvYQ#?{%y;1N*kcah);pZQKEwS^t+jlLOJqnnGs2N54cJ=6GA&86;?pKeu5Pf%FT ztezQEeNV>-9!Yu^2cy+SP|g;ABjRs^I}*V+QPZCeAa)IP^>&YS0DLll@x`ggcQ{8F zIK#dd_W&AxJ3nz=TGAVQ|Eeae@&97%9J(}X0(DvFvTfV8 zZQHhO+pg-eZQJg$ZQI6szu_I6v)1_mImtl|_Kt{W?rbj_ASPK;1LV?>Ni%?I3e_g@ z8Sx_r+w>08zth9Aj#4o9$nIGKlrG>OkPo|SKD9l#yLv_NB*2iNB`zZ)BpvrV7YtC3 zisJGF@x|Qm0*+ZwzJ(E6`jxZLeMkezs7%JNxWHi-x!K*8v79cJl@@HIU2@-5Wm!wKdg~Tjr6Q zI-9>cq75;q>nNsmAnt6f4_J=>)a!v{71kSJrrcLkmKTknC zY32|N5B6i9$Nij}LI0Wo5P!lrfu|n2xY1{V5g0@EFC3@7i)mcjJ?#gBNdi10b^wMc7-Pt9xNZO;MSFYH$M`-S z(o}#DJW%sW|Gtjbe!yV+wCyk0-Vh-Bl8&Q0fbdF(93XvdSDT6V8;DL%vWsqd z@R^YMBCy!czE7~%UXud=+iP_>u1B+SLOvT89gMQ{6JR1nDh{9M zyK|s0s1?LHN1u@As=}qZAx31|KMBsv8Mm7>w%L)$;MVkT zNd_8Z4HaPYK(Us|Zivm9Olz#xi6dsxv)Ql{9Erd~H@2~B*WN*2{qN1`S$e4t!UY)-M$9lO2{_>vv4vnJ8`OM&!fF>&36izLe62{=!i*(wZ^G+S{298 zsk6M=DY4w67Wk^iPMl2ffq#Xk4Oigm&iyxoE)FFVN9U5uJ7IRn9VP-PgrOUab*i9M zun5`UHj+7ZGlo*BG30e*It0nozHWP+-Qs}YR-u}#WAOTCtp2dm{`10wR>iRVoac7@ z2CEROH$Q z&Q}|*wQ$C^D#?=<4^!A2BR^g;c3#$goHRJ)9@DFXQ`+!%F`E?)$slPC?k2rr_SO4l zw~HO$Gy0mK?e4^zhuA@$zsEwTEQ1S)c-nQFlTp!=-@Dl8jZWdZ{ibi)O?)=8q|Cn| zZ@Iin*<{6rLHp>1YJ0^;#s#r2)mFN&nfwTW3!pJ1IfpaF60hi$`y`#JnSWav82#BD z+CrMT?{`b`FC)Bns{S8ww1U~k5W%9veqboH<^khYDU%iCuIdJ(%b!PS=Q*e`zZ0+} z|EEpe881IB&mzbL>dG|DO*(^MmwN?0H1 z){k13rxoD%>j(K-5o?Yy(m|VxYS_3v;cAVGSh{VL;5o@;Md271UirQKENwEE7_%KO zX>%5HGN{2#8}WDerz)H?4F(IcOl7SH5l3r%cfvgM{Ro1SA?ZIlyA7tW)qAUdQFiFF zA~A`)aCW{AVT7FaOnVI}a4oR)D5FfK5h5WlQdKi4EIeucL^dgv#|5|-V`4#+Z$2=% zboenb4Tn6q){$Q6iYOwApx;@49g4?)e(>e>j5x(YcZoczW^aVF2gZflS+p?vkEH`| zENNd3MJuXIea=n+Nj)2zG?+OW|H?+T79b+o*a;TZ;N6jAKBVBg)tTS=*t+e&t{_3o zfAtP>kA%&Nn4(`06Aj#Lx*GMVluiBk4kRUiBc+OrvG7mn1^jZDo8dDx> z)p9^qrf=zx<;9#*gSB4C#pcucaRAwr8XJmB?e&8H{p)VpP5qO2L}7s(ETnO?P(gLe zPz`$g)y=Wxw==~_*IG;#gu5;sVejo7H}_(ZBgvds__x6;b=~CO=&VCpfU; zU_$inqZX;4cwT1nPDEY{`HWm_7Tuo#`%#&3vqRg;F0=Z0R|uxpbWsJ!u7j9gKBl+3u+} z!EW@d>@T;yH2p%pQDaYiC@LGvnpe;?t%Alt3uAJBx&tqd!8abs_#Z1Ayc>_*Be6bP zjTJF-(MH{CD{jBDiOLdyaQW#;a}B=l^{614H=iFYHMU9$~Z&dh*6NH5)e3BAZ|kNI)Qsc#2r=1_6PmhRH!gDLta+o`EMebT^QhI;jYZds?Kic+g zA2d8;wGB&UYHBHXM@w0$KOb8sw={R6m@8F~TO7r{M?8^RV`85A5IRo>9<>QIwfTp4 zYVQWRX$k8lQMQoA`<|Yb`>_a37E#)DQD*!#D+%#>gZj|--SP>OfaEiE9^@GlMY;b& z&}98lZLMBL91u?;~>qbdeTixQh4);!VvV*2Hrsu3RKoZ z*`X%Si$Fo4tRRUi;7Od*K$4u4&N`zC%%5<>c8k9k-N&v?!yE{LJ(9taEgKP zVRyj78xe-vfeO@*Os|CCFT|0Cn|wqp92lvvey)4+gcjKDV|B-WSvn%BxG5VoJ@%!g z6o;zAb~J(4;OK*M4GYbVy*gjW4+}PJlMZv3`NF-5kQ75qCC~nPlB1>iN~_?&y3{m{&y| z(wu_ygrh`)?==L}`v)0}>z!pjW%CR8hf(#@Sb9)fx~s%Z94HXlTdsiodpz(ITcc!TKS% zNp*_>AR11ljmy!0at+N#$Y#uLC>|7ISb*yqj#)2H2C*vhx1w8zT_9EN^|WpVt;)X zo=k^&9U9V@pQEnH!otXv+I2ofVR4xqvLOJR`2m9%N zNms<|5|<#`>7<@1U~CKB1C_YO`>B2Ik~o%b9PM)|dqLMyhN6%lNJCZQ;d`bI=N2-sU&IvDIz#m81IZK zirXoY88OcXo-zjH#;c?RspBfj^OsEYqjW z(lGAkai>P|>~r%s1j}Y5>s-Mdcq_Mz;isx5^HmK?Rrs9 z`=-J-H79IBYnBp`Xqn}7ly_u<6GT^n9L(hhVmZ}EV=O`+hyy>;L=zNPzbR)dT4p!Z z^MNWcvWeL;E5blKWNMNSr^`C|Oh5Hi`yiO+qaU{e<)R zzj5y5?DL^6ySILcFM@B~y)Oj~&tw;Yt(hD)f+BwVlL~Kz$2-(yyBWd;x_r~sh zE3LLzBFv(C^?hrhQw3>V^(6|dF=#!fyj<+Qg_eknWnWPdAPMk`OYtth3VR0)gRGKj zJi$1(kcORglBRhtfco`P?oPp zCm0qo6_;VJ!mFZPu$&!zkF9*sw0lgM#`d{drUiJ$A4!JFn?W++fA2ggq^s&k#A_qbQ zN~he@v>uJ|V!V;Rw-{S5$1aQ;-0+Q@q80I}1@ixO)jffW9QS(4Xvk>heao|$jQuW` z19z(q55r!aQ==_^S14Md{2z=$#J5p44TLJw+`9nftNgat-iLBO3dm;ZY>(wx+bvi3 zSiVXF5hcHiFfDef-Y7fyO~=QPp9iH`c=))Bd@%VbK}R|| zS}!pxo*cM}ry!d*jQijcBI}B?7Kv#~C{+~nCNU7sqn0mKlP{yKh&fNr=QQRU&QO(7 zpA21$stMz53Xpz%o{0B;Ar8hWaAa z1uNRuRl?A@I1r|5 zYv*O$gQZcQqx@d7Ko4HRn`{ONspOe|fu+6vh4=m>-;7x6Edha^o#z#>zkDS|LPo7d`XI z9;Bt^B{@&(2c=Vstv2EY7=Zb2Ad>QQp{y14$QM+JUEEV1K1C9HM+x2>t(}purkOuY z@>l!0b}AOVDl`J!<73xt?>9x(h2S2XC3^sU_mcg$kQ1|eLa0;^#X-k7IG$S>Tx;p8|BK!A~0K_;yK+z$ZVVnxvq%V~Pyz%-*ZTwK@5ob?g%g+Y_ z`{%Hmgj9SExjIrB)#-zX8#;YSbx1uxuN$kEZTM4C(thp+8MC@gyNN4v5zwjeaKRfQ zAgNMi{%Cuob74%Ak!eG4Uu6?oQjIUaayyZ*It$&1)_ef@{xuptTle`8kAiS2nt!xf9o%s?qkYY&<^Bs5k2zIqgAu+t`P1vzGkv>!o5tdz zhH?DEp3Qi;gh=A{NmwsA@t#$bC_|JlHUy&_B~0t(e(o<$>>!K%kjP+R1nX30Dq32> zjNS!Zr1IOJ8w`Kyq&2Jlmv+(kziP=eE+%m`?HXrwZUm)pwu4_n@J*E#=h}h9YZ=~g z9p0B|5&bAm7Vft1ZZ47uYEMPO=fN~d@IwWgqHWjH1ikIEpk49s>po<9M1lq{5xKiO za79d;6`g6)e+)Go27{C6&uG^Lrq$nkZN2>;Woy!6Csfj^Qi|mZOR-eXAug-YfEvb< zBd_i4fNc3AMBDrmVvT3_xJhPBq_ko-MahXk7x>7clvahhS#%CwMY0sTamuk#rIqNp zicZP6^_azKpE1T5L!G>@q9}ZA#&LmoLiDu7C~7lrDmIN=)NvQQK$!nnhaWnzbWVJ6 zRbWF*Hx!ArCn~=6pbN^6;o{GaRl31lWZ9a!nypHVym*;X##5eTrB&L)y4mVU%{~yT zb?T=}P>P9U8!~CGDdu$vAFvEP0w#(bBT$>~5(jjKF5{_L3MM3rL5}_bJWmph9JlyO zCC8JU!xuL$d0)x=0xvHTWUELvf+6Y{AeN6(S8DiCe~KE~)ENA! zJy<`bNNH_rMKT$h?bkY28O`$*8Y9GReGyN@*ao<3azP3d?%9x z@Ro_0HmwI}7g{Y6#6){rw5j zQ1dW7xX>lkHK)&Yyo<|9&!@vId}OUeZ@#@iOb=y=Sx!=#6%5jW(~fERxB{3lnhh_YsG)z8P#9BX@7+3Tg{Rf1W&u z4&fWyBv@Mek%W)#-xEhRqHO5dA2=$z`VenTFEzx@?NW_;+JBQ)_p4!Q{|Rw-Fwh6q zLS$+3j=Qbz_@qJ}!#!{ckqJ<@ckXBGTnGHsHP&xBcs!}epV9!Winc^&W4&CD#*Tog zf?@;Hd+dm@85enKRYZp>#u3+6XEhYKP^SZzkLz<8fp*U|1$vk-bL8H|@zHC2^^(6^ z!Ce(yZZcf^81xX9QEGB!`GqJCQTQI*oUWw3Vay(})62lP;W~Vjld`@x&KGj> z-z=Ht^WsrV38k-^jFslF8`!_1T5D-W!dkSkB?z83d4w~5D&$nLI(fYpg#TX6!aIhHF4IM@GAQha9?8% zj(EL0w-c)6{2r>p z5@g<4RDs7|2Yh!her<|;-f;9F2L?A}@uvv39R5SMCHl)xkV!t2;Jfr$P@E&Bu@}uC zYkbNRe>Z=D1{7X;6e%oR1=d#||9ArhT1uA-gf3*QIRm| z&9u2)QyxdC2ew^-tM-=UcRWlJJ5$T`Q3!Mq3E9`u=T?Y(KiwUSW{tHLrN}a5?TsqH z4?ZwMnJwsv_G=WTZS+t#*($tCRo+H-17kQR^CzLuum0Rj7OqhQ?8M}Q;4?AAhY|V* zWMPO=b&0X3JrGf|W`w-NyP!-mko7tQmb47rxFA7Af{d=Y3lL5NGfzlgHw|@v(F@zV zjHHaPnxnV6b@%9d^hO3HN-!S?Qtoo$VekHU1}k?sbcku5*dSG*-zv^TB=n5!>zU^q zuR1(;mbgs;fge@wjsJm$LC}2e=nU=-n8-*OmTd5E)6O71IBny)Q^qli!#4w^R|g$? zH-C!@!En2V+%~21ao;rWt7^)s*Mw)X8cW36{UXEpOkbVgmGVoyaau*CU^5zx2~xl- zZ(no>R4q>#b#_yK=IT{^P1$56{Y@)=`;ZH-@1ZEwP*ReV9oM^$*9t)H2(p#V2M$T5)mJq!Wv^+Z2hufgHJi>ifjdpeVszn4(zV%9* z)K)PhXT($9x;y_!{Nr~yROP?FI~PK;Aam$zaLUStr(sVhJ^MwVv7Uq*Cqq6-2oX>% zmrqj1wio+zEn>EIhoxl#RVNN@Z`t_38F`^#Cce{F!hDGBTl_EKU7U#&^-=`&ydK<{ zu;_cu+p=~7Mx&2h5{!@=vyfb0^Uj<8D{^+JlQF}Wme0yv;~^p{fnpN_G@p&^wYHy4 z-Xjq*_KAB6j@vYp8U+hhnl6~z_cjy(w_Ttv^ric0hTgWPPu?8#x_twYG*Y_Xei+9Z z;~7w|6-B|jzDROS$Mj|4}* zeq&P!;dSTQg0h;}&)bH;vh+F57tk42T=`9}PA-#glq}J$Q_zpxwkvD3z!T4avSfMk zTI^*0lVax&LCRWQJz8kS)Yc;%5W&x~AdkywGeTlDSg#k~Rcc4OI^{kV<7LgLkZp9q ztHxSKIvVISOwRV+@kFhVAmBLQWgAoR#RwSUhw$^o?Zfsul)jL1D#aKdW)@b$on=Vw z!P!ssoXEr)p=oSAmLb?=YznG^QR(hn;(Fg)N1XN6O>1_oC{8gGgG#BW700Y@m_(hR5g>yWfctOq1`#ZIb1#NmG5ltDDC?ivCDCv4ljP zqWr}mA}*8HLSS^!X?s!vx#3i2U`?-|hXnls!b37-mXDw!%}0xM;##<*|pw)N{sjTP(Do9_LmY^@ho{yx>B zV7Qs-r29AxPUHU0b6NVAQxM&?E$Y({2if0R9_j_I5MzcG$)3s%(eMc>KMi0<%GVAi zUkQLGFu`pqLWds})2e>d^)4Jlb&W0?{L^nu%}if@a$% z_2crGYR3NAhaF#im1&&_KSq`-rAyV}uiayR(0(Z!Q++7DjUd1A2qR##>iG-acH^%G zI|0UrY|ATx$D(zPm+sfi3ufjxt=J%{`)5m7)3kpWL;2R;MquwciC(I{xR_b^S5l&v zWz_sZ2BP%$@FipI0b3GTJS#)V(Si)-K}FZIyVyKR3PnX4*oUeGO-#ni$T;iU5=otw z2bH*x{$)*{-?|b^{aE~|I2L&Fye&!5EhE8zm6dPf%#5uqGnIjj5Z@@J*+1ccgwGZW zX#rOCaYVr9J@bks7*+sDB9mZUS*tLH@wQ(~=sPUl#Lus5V;#qXLG=b_ZJqKqJ zx;ByNV$vBC_rv5*2n=0-GmnwrD+d~qK+~cKh?HC4r_RA|1Fmz+a!ys?4U!AyoKuyA z;@-l?kw(X%H?FNoZ;f4%Po0T!oS>Qo9D0*ZaV?R_o+$GiS_RF2)Z4!Fcs;8u!*=#E zbA7fdes+nyB<#dp7DC9*9h!;{ZogPKo;wq?MppQ6FX&$f*35~{ttur{T@j_k?L~sl z)Vh)cCw3&i{h`Vso{hOw(7OY?Au>K8UBy}_ZL%wFW?we;C?lRj#+8_bKjr*0`wDOl zg5?O}qzARwY5qjdv9600X6Qca@%dcGn|gj2kBX*oe@ikkbbU1lP40D`EfiUMA}{WL zUOUVQx6;GRt#-zvt*Fm++ifcxzwnH!4w_uv7KlH_huA!_P>-x*oiI37F0yC0dZuL2 zjI&Ot#I@PEB3D`qT|x}uhR6JVitp$cpZqOF5n`SfR>!|v=3PC0<8$4}m;6aQnE!(u zfr5B{>KMv}#W++YPUa)3wdXdDjA-mfP7ZTntv5OsV z1S)Dz;3yYx=x!X=3&lX-5&Zl9+AEWviK#Th_C zWyXrGe_Ohyt*8FrbH(|#{m&EjeKX+QTY_ahDZ1-H5Sqt)gbvU)*df`)oC4eCYWxWf zNR2d`J?ZKESL0%U+_3@iyr4zE-?7}j;+A_b6ur+tjP+S!>-LSURg|Ew86HC4A9_~% z5vjnS2=#B!wn0v<9zOe-LYtfQmj3ARp=9=7gdzxBN8Z=8O za-SquNzcD0!mx=r?0_f>JIIQs{+^A|AAyE;DKQe7TTNwdjrL_j>EW!GGH-*SjZPkT zdxU)Z;P7>e**SHdfHM!!M6@OwSMn`iLjJ9M*B2^#rPES-mYIYp5uo z;&Otg$lRI<*navO3-gPsp$mQ)J3!sOR%68vhSo|BWS7smyaT7Lau&~|?LhUn1?!Va z+<^weXGGVJIBo0*X>A|TH}ZxC>}Hqv5_A4 z_Az2jFZgkW#DmdWQ-)iM5+kH&2!}9}`&_F41uqJRD)y~zWu~Sxt6~DYnzlAaaq=GY z7}uI`fjugF^}zZqpX8J1u_ z>ZU?!d}F?cPayoPmyvCl=0ZCvwsZI-ThS#vOZ?Xfj7`ZR1en6|6=VE(>qTpW!^lf5 zCtT&~ZihH^__1VTlSY#FS1BIarw_pAmEpP+4^k!Vx^ms8$n#$5y^x?4I+2^^2%f1t zZ&0kaIEWbK+*L|)`+3Je7!~6{zxXzn#6ssQderV=Q8Id%~LGF&qI0jKDS znkBZ4Y546UY$NjQDD1!`&7D0=>8=)SFKgKqC7Q*QS%OW$70sBx7$%H15A-ThmvYs( zvc^rg+FwY2U#KV~!AR{jld{M*an=u5t0TXo5u4dD_rgZgC*C_?L}7FObe+Ks(QV_5 zl~t=CUr&F&PI-ui)-QYAk~>MVBu{(I`^@v77x*K5!F?vvBD?*kDzA8O?W(-RZ;aGZ z*!C6-L+fiT3Ifl76`0x=D09GmA5peO4lxh8Mx^^XRO6ErMF_Yy*KlJ+ZT`_={7CDB zl4TW7rHsJ=k3to9^rEr{BG+wZB@_?T$5eC|;HhN$!p_K}#3i16Ws z7*&jI2c`TYY{HZ$JOOV(eff)Xtf()3h$tT}V)~yD$JQ$ar))Vxm|dk*dqt!4EY(=S z&+6|bblO8_kv@1+il6He<@{QZ9%iX$vaPAda=7-7=XZ)FKUC~u)2IohpVGVR_vLN% zxb=)SkE8SyiA|cWyLhKX5=G?e<}+PCJvZlL23EDG3=h(w?NU$h#A#HU(xl+TjXAMsD1!Wc#)++Hd_xPJB-3dq|z7;*ut zcHsb2TesFEbe~zq9e!iMm$bK#;J*Sh+(g3>wt7yaP8devOv_@wRn7+d0Vl~zpzWY< ziK%7z%C-4q$m@&2LH*00NmlNa4X_e>S9=k^iCRV*c`oyD#w6?e1u0hsA_&E_Ze|mz7ztG9-n$M5S7=k!T)BU_e@Hw$UhQwOZaWYn5i6lc zrrVMM{;r(no73SxS7;;W0S&dOTxm$?W9R_?O#%7rscHmD{H&m%P=zmgiP07bnwU*=%xT`aUEuhkHB)KL` zXQ3E4`Cc+)~=9k-a%EUVKPQo1_ER?alw>h&RjgkI=>Xg z>FRI3$<+S!ekC-2Y;dMy*H)Uq>{VU5Vgwr;&1rV@Xc58B*GmQ2{%3M!4ie@oZ5EW+ z)~p>GBB@Rc-u>2I=JE?Nb@)q?rk5tRQVHkn+nA-t)mxcg*8E%Ni;D7^xs}1mN_$uO zXjKg#icaXRLEd5@hP7msIQ@Tan5;hR$~_n<~A<)?`hGAzxsNDU<18<-0&;Xtr}5oEhNo zVgkP-3zAB5{U^V&d*=byPt8o6rT^V&CS{ry1|voHKCYlAY%4FyI{tGbo*9yJMB~ux z4oy-(xm|wRsm{yzM*?~}b|D+{VKiV*i>-$<5yD+hGXPZY1S}0AK8MV2l0yLf$&0l6 zH*{lS&=vU?%$P9PMdWYtCCaIx^uBfOxKUQq)mIFW)fU0zSN0d^EpSR2cD!}zl&09% zmLtN|R^hSU9&~W7X)>O@8>#?} z-GNEEPzl9V)*MRaDafqQB=JXvA*vdh{J#{Mr`ekacZBp;Gm4)#&!LU>-D+UQ~&FMk<9kO++ zpD+L3!_En{?WN$r2uDHJ_~>;~k1;e%V{AnE6`idJqABZvAjun%XcD<@?W(ic1u7GJ znM1_&oJ;|IUR{(wsee4&En5(7pW>mPhczSltDl2P(YL5i_ZuHYK2RAyV#0`HekyLJ zMG75{@neSj1+{_TJO2Wtr*S86c0dq~syuVs-!EU+G`yiP>%e4opc^eF*O`!L%Vc}3 z;cV5Y4W79g;0h6yp&+|_s9~my`B6m6u*i&`>7T=AzmWQOKJqWP&%gmyL?~d4E2Ej~PHZp}#`$m22ydST zDntWQ^unv){k~Z3`IwiG<-1?-R@KQgDzmP+7AzNdNMGQ&S!R&XLI2(8-Kxai1PZ>X zNHvJo!IlROd*S0U&<^8B z2sc}ld}7m8o4UT7Q}Q4NZ`Roh?a6whu}iYcrxknpUAg&jHA~o;M53VSKUF)YFH~T$N#|TkKBwt% zEF@c4)0Qce@>Hc^?@q-=jgnUTm@a>)2ctL`ytU@+=E_qq>Jj}~ zmUBz%l3(Hi`*gL|peAAq|K)+JL6iCr^4jnGbnvL_8eqo~Akr5~{?&UehN=Jhk|D4& zKIN)NrbP&M`5mdRA%E#hFfW^9e^)RziM9;UH@%l6rI7X_!L3PGLCHdl&JS&o(wNKL zPisfwjwx5yDDV;ukP*RsBwh}yCvNx9bDZsG4`A=|2QXJ$PTi}X>co@4wQNZK6NpPP zHk6L;CY7#*%adA>qipb)+G$iSNvuKFs_+oQ>?v{nk$t`870;D|y8r+$jejBhPeK#t z|0FbVv2*-?LK7p)|1y-y#Kz9?e-)bA!BkUiFxX>T0s~zkVHf#ap_3P>c9;efMPSK5 z7WEc)b_nBKB_kFWckq<`kGRhGKKlUut8cYhHm9AheeSzHdvn;>(q?SvN-U93lF-Hw zW=0lZ&_E+-%ggIQK!k}YXpqN(#f4rl;hTZKBof67KwR8GMD8E~j3anLV~T%ehcKZ@ zs0FWqnr7L7+~t9I5`cK>fe<10fj~Y0BB7knK%}vH1LiVdQ)@W-LzB=C(M9)EN+ zg^iqkpCAi3%zzr6o}QQiX7GruU|hj+aW_EFV~R3~bhJg4jc|f+#?atGJAf&$-b6A~ zYleZb)62_$*0xt8&`vFg=7!)M!G-BSYKbTl3t*<;?`q6~3+w353RX3itby(6hUNWe z)`%_@)r};OKq%{hazgI%j3^d7EQusQ=y(O>BnXO45F0;o>45A3*!OZSAb0iGfSn(c zpDCpETLu#o6_v=^-o{*>^;r-@_%>kR)RJSZLVHE?z{cDShN8welt1PU*T%4IOzc5O zztTIHgk)79jNxkU3V!ls@rFJXDAg$Iry6m#{o4bZv{n}6@Qtlt8$!AB{wEZ`?te0e zK5u7V=MJ>DgmiCse?z7R-OW$?|1r9>S*Wyw@^FTjlKvhHh+6iWp%YRD;z0g+1m*%J zgaDeDSx&yu2yDN7E$C0Z?jLEu=HX={^jrs~#oZPJ5)cpw%*ZC#|JbwtwHpYC2FO&|!v0cp z3gG@*&lCar4p;-S*$udK{IFm=2W()24+Kakh7OEj{V4$O{df!77f@Zt`~bWlewjZ2 zI6nsZzx7Liek>`jt@ZEHazOSyU;$?<*lrtOG%&V-1+4=I25BpF{hLt*_34w3CTMPG zu?1N9Cm3f$Lu_qf^yEM?D6eeDk(kMhX>I-ShWc}cYj|rn;7({3iSoV{2Wn^p0RoVK z(BW3GS+70(!&BR@O1Lin;~^=&I`oexEF~rK>myK0K886E7l_jl)daQ z0&nQ^gfn=J`YYzkSoY}f$E508JO_xqH2_IqdiI?oc$DQM?j6{+3{Yf{Ys~TmI@A;V z8`dD+@Z%@j4}}ZF{Zt6I0k9Z`i1E<#A|YGZx7W=?8jo<$bW4ZsRaZ! zOxyhiHZ0o(h^+r>`f(qHV`&Y^eJ1eMq)XgeFd9n)C=WZg18T$5tP!?ICJ1H%du!Hl z|2tug``_8++}}V(i2koX+05(}G{*>Rw0vg*pWst7KOT;nxp#u`0ZRZIYPnoIJR^-) z0}cpVQ$Ps7TOd%-o=~Nw(<-vEpkFO6;7TryvXW-%6!P)WT1T?Q-GPxK)t!85SQ($} zWTqtKZ;}?*f@0C5t<(O7NT(${f?Xu5~Dx*MWp5c^Je_tk4nT zSPmxBpO61c3#{}c`XYM0n$u@LAP0;y_fhp-k?f^5cmV$Zx}sy4T&5s&9O8`SRs_OQ zS&4oay!Dll#3AP;Iahz05`j-30;q(3Olvp_z|mkWP8MHR_d9uYEqlT%on%dKQUyO! zCiYD}o!R8vM1aX(Hp?~y1-BOSEzQ%3_UxhEzN4m4=y(zoRskjL7AEak6eASzPb#?z z-JfK?xX%s}=#Mc+Rb+nPNYs!k8kAKDT0;vMW2HS^7gM>RCnKS{TP^1<_SPO^l$^K1 zgT1;h&h*3**L@eKz|*~U6A&aUj!px0L*#8EFJCcng2bLEtx0`p-+pe{FZivHHE56G zUVldyoU}h$ybMCVBW)xZIb8#L91l%H4s`@N+qy0~LGBR-%?8XP3ON`JIt00&pyU80EihmOP zSkK-lUqMW-XJpD=IPQcy8KjKi7VS$R_(NSn|8^j$uE1TN^|9*)+CW0?#cPrj+IMBg!}0MX>f>Gb;4JGdDzw|X#MqpPjV>(+u;hJ0u{?g_wY?<*JK zOwv(}&xsktWUvP-A^_G8JKQrb^G$Fv6)%5HV9WwXt`e< zGmmbpyx-GdPA>gQvc?CEMNXcX4-0QpWemUev;G#L&tm8&20!7nWU)6z*76GgSgD zkd_g=4r4dRj<@ED=dXZ-?#cYcw?w(V>E^`=LeR4?vUbtS&fasX8@*#&Dt*>{P-;}+ z{6WI;LA;sXqlVN_gjhS&SVXiX(|NWU|7-|l+MAXLl$qHqo3&ydUdq0*5*oizQRdlu zip=jTp$~ykZt2F}YyFt0NpAey?TprKJG}+wOX%+DH<%ZMLg^#vi+g$VDv?5xZ8=j! zT1kEK*zY|Y{4!0mlILY0P6{8=9DSm%f>8}H%62|xh^5BVLHgSwl||t|)*MjkpuhX# zJ26o}DI{2Wk7LDrL)3O3R+J@RMN0JFSB(<=F&w)%($ko2T7DA&>m~&Dfji5`;xiP4 zPJBqK4?emAammJYJV zv9=La0VDxLV<;_Zo>X<@iyBV*+L4GV;w>3odZF7>SlQ6)n>W&#jUz?%*DeE+Z$g1~ z#{RvGqyMA<-UhWSkM-HT7xaeOf)sJ`^2Nn&Eugxq9XJ1FaMJm%>{;0g#8}Vhx~Vug zRLkjz(V#sT9q6_{)VV0eM_%Hr;dK1en6GB~#(4clP|L}ed3fx$=`&BSFW0E+bi+`K zWg{Zm+FGh~(%c$l@%J4N+ev(&(Hl&dxSBmnvR;%HMOU`3xBEVIJ< z@4AYTOTP;PybEAu8CZML}1Z4*(FhibkQ+NDO99e;*u;Dsepqvwo(CN z{tkKNcgPOXazQ+XXabON?R?JS#F>sLJE$g2j zWT?RvOieXf)#sAZ{gkqmT;(&>okof_(U95I~MZt~$#NFo78V&_~-+c(}zuAqDUYQZb!&7Wtg) zV`)$)mC-9`Aac<|ci=wkn=<^nm|?q}>j+F>`go5AO)|zNDNxiQkvRC4;a7%hJwQ0~ z#qVK|mf%BTh1U#k&coK->v%WiiBA$EFjaXH!$-R4l5pXvr0QQ?zk8ZZT4*&><?z)8xUj&Jf%6U2h~2s3 zpbaX8{m*aU`7uyWJ+C1x-kNDdU3yJSfq8abHRj`rpn2@~rMdRs!csZ7AC+Xi}pcyMJSW@)54o9x;5%!iery_ zH6oPqAmzbraw}Kw#P~d*%k{Lg<(eDiY2TCqxZwJ{K~;)1OYBYuLdF136?#~K5Bbh0nL- zAef>zb*&sN-X0)dC;~=N+622XGYL$O;~F$CJ;yz$Amw=9_chFTcX68n&N7O}Q(n54 zvNpXDf|I*o#hp+w3jB}H!Yy}KE``ym*w<5VxnxtLFj6fsuU6Na&unpUDx20gy|yy? z1WmDl7v_G?J5~rc+sca|bqnrkQnus@{>@mE-+uZCMc9+m#g+Xq=a^hVQ+q5W@t}?I z(-v6$3|_4H0a4EMm@0$iv|Zlr4{p+g@J8nLfSH^3kzeZb-C9(~!%Ckx3f6^^<*2nW zO5gY4$b_)E!cu#UemLw6K+qbprl3nJ$Q6fBB6{e<4z*DpAb5Qqsi)S! zjXB|(d1z^S^bxiFYMXBoKCbzHjGaS_DB+^5+qP{RyKQ&xwr$(CZQHhO+qP}{?e~(G za|dT|hyS1kl}ak9THpFs57gao|g>l8LgccwA|g z`sdBNd;O~cDz}bd&fCm%=w~*u@!bRJFwpa>6d_AV5bRtIaNSKc00rb&a6)CDsH$?w zYoX&;`n%z01M|}$kmGlEo4t%jwd+&4Vy@{$5Xpt#NlG!({+A%`hKdf2F6VKU}i-t0(mX z1G$7bNs;Y(SJYO0c)*(k3n=yM_vSvbFI&+hVa3>r&tsI(HEQo_Ncw9^lgIYz(j;2O zIBLkb9X6c0R)8T^=wrF?ZUvcJhA-LbSU<}%90aR9GMK(XG|54}I_YC=W0FnI191|$ zU6!`*_rXN@LzmHq`n|M(N6}FEhQu{#%da%HI=OVZ&pLam1!=Nd}moqtg&Sd0|;h(+n8iI zekRBlU0~C$i?0_)iO=GRw<=pJ zS+i~?Z(Lak7YZRf!e*m&Ow%|?#F{2*Zn;_hj_5#EPr9DwBm!I@q3hO83`cecna!B)>rt5{2dW4sQQ_hE=6t`-OUZD z8zTAJuu(e3W)uD&V!4=!2X%C`u_#4sZ+#JxD!!L=uXhu6uN5v~bjO%v1@;rEEi!F7 z0jb(#&A1F#8Pk_7e~2>m%;0ijrTuWzI=|?M@2i~$hRqCGfC#8i=zFpr%2}Cs3SuOJ zu$?YjX8JW?=ucsZ<%T$%f%mw#F4YWN77g_hjd|k*Hi4WCFFv|0`z}-rLTiNk^S8UyiV@-=!7jC{ ztHQ5bw1`0X^J>|X=vR;U`RgnmUQRWHcdme*j+=yKQ@lk&-=bRwOtN4C{_Z&)^lx^( z+d204tWE|(=1CmrDPLYIk3kCsyUhEWxn;c3R?u;`TN`+9$Q!AzwR>R-0lpAl=tJRk zM{sH0GYaT_h`Ax>1=f`>^;o=68T4KTx%vh>{kBtJRwYbGEJ-qZ4UbX!Eko8hX^p$Qs`>&@%}o2H7AJD6 z6B$}OXw7t08+Jp{E8{DAGHHJ&L^If74IJLQ21A%spTIo_Mkddm)=;nK%rPTOUfYuT z)|XxkSn|0xKyx@J*AMI0hyET7ZIcTtU`V3w*qmbsmo^9%$Ww}W4GeGIrkvRqY)yz?&;3fggoA zix-^x3vT0Xq39JjB7OE(R1a*F_uLSokSQo^inmR^?|6o8-Ztw~#R47jne4tPznu2q8f-N> zyrpMMuBqfFa7mOspK@uK$aAT}Xl19Lv(CpHEBu(bLp9w^q|HH6C8YnM#(J*L(`# z+g%Jwsy@To_4?4BX!eoT^$DXxjY1ZYcyB>%cs9`j}#Z29vT81%r-zMan9*Y-Ew4=u`;7uB4PC} ztfOqpHn)?AAEy`FCD}mO+^QtimJGZ&7ye1v5A)H&85@aGK1?pwNWPpcT$fORQXPrSq~J77C>zWe4|Q|`-Y3@ZN02ucDQqQLf80g#%9C9aZ)v2f5^_6ZsT!TuHDALdNA#h7&MpdTKxG7h4{ zl668*<>K3pS#l|tbf4BaNq7;7(99G&p2uV&1|-OuzoTyNnaHt~-@ks&El`XxBa);c zS~W;tDGNf$$JPzM!2!}`(WkC!f(-&gp?h@X3Pp9nXCu+G+F4PK5hChQvZ6G10hz6+ zp1{3xa&ChvT4~B;LCfFeI&ZUss^D1Ag#nrFDX=aqk-1S|lyq#Hl(Z}yASq9u=G^f6 zql!ArFf_4HF|~lu%>uKJg-M|5P1!A27M;%}kI!ALGWEz{ixBT<(L{dZ-Y2MRIcS5( zs1=l@KdsI}ewP&clJYVvZ4>j6&%Jwpz&n^t;;K?t(Xb{!wy?4ay~bztje^^-#sQ7p z>bhO9&*Df1UPk;J24Wi0#ENjYDyF!uMky{z=qAVTI zZ&U;jQJGc^CCoaQ#jEY`RytVlMKGV!L?J%s{+4U)`}}!|a1XOkhj?&majXt@=(g{y zN_^mc*e}NHUD+QF_v1Vb1d5)E#jYV_}}E`Vw-fG($dld4GDGgR7%GXzbb@LjNMGv4r_=$D$e7h_ z7NA90Q@@9>@6x3D-1E8jFi;#<&ib; z%qu`aQ8HqH4AV5M`MNBw4}5**h3+*%)sUS`-5M@zH@3L3ryFYMtHe~k>ertz%gmX# zaT`khi$>sI)%XErN<~JgMr;tc(A-GJ$z~9ra_3%LXG7+7vH?939n96CR4W{-r*3(B zdkzIeV~@X*NF}{mq`D(rD8p^M1Y0umUBOn!tp+GRe!T1zhA|x<^VBEu2lMKR7@Mz8 zEf4+=kT*ek-G_T-5{0$fPzX2_O)e2;LH53z+b8CV0s3{7=a03ee4#rXSr=;v=&wz@ zUmA_cwI>rS)W{^{6)LGMl`7uE84MVi!1VIvK@IUohFEQOiVSMAj|SZ~;3n>E#_19M z0+tigky@?_QuBlug zq&k*s-&1hl>eSu)D89LJ3i!Bk>dzn^yy?EVzVL@n#@OG;vXcI{`V=E;hpDkto@*1lT4TJT7|$<5f8LO~e+_}P zGXZCp(@R)+r}%@Blc1FjH`-ID6VM5A=6q^OcmJBeIQh=Nh$-Arx#YDmb2MeaD4dJbI43zt zy}IsN_*wt3_fE|W?gOGWD#tvE%?o3s^tMe0SJHyDj}j_I1Sn~8j8ZyGTi8#BW!E;T zQlBlgP*5vlb8Mg0>`Mz?_K%7`P#Qiafa3_+@yXtj=7B) zZ!j;7A8`p4h+CyeSY^aJHU0=>iITXJbDNYN!;hbGXwx zR*rNs35=q?BV63{UxX!+jq(7g?yU#w1i7lxpk=f^TQ`jvQNO245NAaX|5nRA+O5mM zOvHF&Z)d3FT0^7dvPW{1$M>d&gpZtkFqoShE{7`O2loz9!djQd@|uQ?Z$wslc9etRbw|2K zr#PC>k~j;R6zW`#nI%#$Ar62$8SMjJSK$jsgLK7<%o%>(=;rSsmUGdvV~AUy`$>bKKe>gnGr(fIqB%3&5zQN)1BTs^J^Yli}F zd96uP+8bSYy|urFZ;&@0PuVG({;KQLdrJy|wp;B4!HH+m*Mq61dBMv1duvBkP-kKS zZU%rbNy8RBc9pE}yW|A*@CsfC5#V3l@uJ!!;87y;LM4#on$quD%N>DJ$2WZPP^LtZ zT)ow4u30k}L9jWcyQbvk&`=dwpTm`oI6QKWJk~SxS%xzer0HX z7G-;SO+!%yXiYG|n@daRcJ(72T^^)8j32kO^YU%44$*G$a+W|n5>+B0m>vIt6c_5;V)XO@AfYZ?7y& z6w$*-S*M;^a}vztpB`8FhXG7JMnxY^qD!~F=YEb0SupQb?R7Y*_rL2V46OFqQe)lJ zQ^czii3H<9G7oRBeneMYqwwSlX3IAc6OfPo`&EmH&|!b-0f}kUz}b1qaV`-+2>(&I_F}u?;!CG;2@i1m+yNWvp%9 zXc$=d*ORFDr>h8*>u_gRQ-7HWoIu^Kun4piwP(&}1U3>87lKyLT^78mcwYE`lS5yC zF8~e&-=1NWnxW;t-S%4+V4q=Q#@kszV%iU*6_jyUtIi7G6NMm8L!Ih!ZA@ZuMOib{ zz2JL|ZpEh;7#$i}!PTg!kE*TBCON#VEGZPlT>JHcNU7eJyzyGcrkO6YvuUW~W02Gg z=5bas&i#NL4qRlQ&nk+Sds^vno@M%7+>@|%P3TkBLU8v)D#^&==$AAo66xLnDNAAP zqG8IRo=q)6oRC6C9kolrh-K+EFP$gp)=5_Vfv==&r%gSJkHp*ou5o|lhMKY{{toIR zpR$+no?8YOZi&H4Mg{~q>iH%&^91>U7J-sblmnODnbm`1oV@lCxs}@sRlHc_W*paC#Uy0)fLVmZpBStO-FZ|uRIsdz z$WL$Vd*gNTlErAd{Gto`mGsycs$yt%CBmJKTzAk&e!g7z1d01U3>>7fn zN8G8E?!gGzlX?{_$CJv3QKyaQOD>nC*kGam^+C z!x%oM!={G^(Qw*X2hR`Ne{{m(5c`p+xi|6FZQ8L)0PR!DB=ls-fBz45s2aFQRA7)o z?jIZD?(I1DKN?~#WinRpk)A031Yb#2egC2dP1MJoH&nqIt25!|_kJio^*5ZU>1n+jl;ODJbn<}064FCYY&9HmMZ+m^KJ;q*(=Mo5ON2z$D@>`TGi(i^ zY;|XRI9n}e!uTytNb^1njJRM=-<*5o!8^SVqLI{C3*YPG97_f&$vlnOI2p#pF>aZd zcaKf`9pfnlWEXi~XM{#*Q*SMS(4{J&C|wu$Wof&1%ON;z?Tjk1m6=$Pg^j#8ApAQ{ zRZ)nzne(E~g=#SdBo_YG@Pq|3FhLzixxc&7s>bFYU4I+k*V&Nnb|-cIk}O6ocyhk> zQIayW6kvO2;% zH14mj%)%j_YDAD)>7|3@aCF%Zv|UE~n=(f)hg7psJE?6^dx)x(svEP)c}7RCKADEK z;o+qdP7DZ~eXDK+K)9Th5$LRA6LLpocYE$8CxVevAmvYr>Tn|n73dv-d5LZ6!}kl6X2qy6paLO9*C9L>leyXS%x-Z`)~%YWKy^P8)mn7UP> zQG(lMi~&0)PW>m50yk%<&i~ni?fC15R{K|h^0|VRKATxn%C{cD9L$vcCE{b8j>sVb)+w}+{D@qlDsH$`{O`28RP4h^I$@ zq@3Nh(2@%KNB-S<-I$Ipj~yF7)E8Pol00Vio>mw+{;L$@UP?xYv%2mI7Q%iGAHhFU z;GTMZag05ExQb{xgUoIZ8EUt{U-4D@CqR10Nd0YnH^;w9Sb&%wvv?_)gOXSYv@x7L z05K8jcnS}4snK*83OT&^1?uEpqIW+8Gt@($0k}64cM9?Zptu$KXfi3rWA}0kAY;_b zNy=t&b#jOVN@xfz+*)=2*iV1s54PsGI2D%V8)tX%~(Q$ z>KRI@fIH{2&7J#!mMWnt39EXC=UhviJ0w(Uq<-5&V=P=60+nXv^Z7)&Omr;MDG0Fy z&$_{T%v-*ggpo`+U$;AhNSya?pRKt=q&)?bus?`Cex{kO#q~_dRSK4+p6FJuTAPK$ z9igKbT>ep|;*yxd)dQM`0mnneU4Jz{lG_Xa2kbJ1B~_*}$wk#d)83VlFMlSMJ($22 zU{5J=J%mLq@dtqr)3#~N_SPJMQOGii$GS8I!AGS0s*cf4(+GM9!ME-H=H9^vcE6{@Q~TK)15b5tQY<#_3opN%GXw-$9sYicS%!h=S9HO8g^hYaoZs3665Y%C%JnD z+kI9I=xsd{3e%z}S!7cK&mJWg8`&|#VoAx2c8?=~o0B&E_g+y&KN+mIv^^!W@S)&# z%ghGHt`$<8?`y{oCihCrvo)b$eI|8|ZmRQib2z@SY?^l;3njZk`C$}m9|19K6n2DQ zo@wff6YJg|Q!IvukkBS5_&9FVYm2;XuB8mymW`kGzt*Q|_uQm$LSV)f-A+CEMJtR2 zr&Pp{gn=v8G(U&vz85TD5o#qW9>n@P(O=+|KP#$_O@2cuvBE!2UWsbz%qB+pxf@7` zo!VRTOF0V=O~o_W;?-VOC8@cJ4>(luW=Fw$qa(*G;v7Ssuq5uqW(&|J-E%wAt!Q~T^0vm^8<<9ZpV(6&DPwyjn-#T;zg6McR7 zdZV$4{736cY;Nn#iS+aDYqbU~!SYNs1eTU1X2(X+q>}e;oa`2P(I1*f{bCGWzd6LT{Hx2BG%LqXy6UWF}EApmPN3JgEjRw6*Z*PC?(>(c;yPTTIoR68k&Vsws1V)aiC zVti6;0^3_4fk;c1P36d6_~Lv`nP7 z!}eE?wxL!>+Z1of{_hBB`pD3SekbY6S$3v3-eB`p0QsV{vd0D%8xd#|YOU)VC!P^w zqsZqSS;LUoUJG~b^iw>BLwDlWI~44RJhp}by%%pt;@M40+K*p=hw}>V|H5fAG5j}9 z`wtt_e>iPc*8iOT=k5d>D+}}gqqGVB7rPU#{}0pMz1Poj+xjn+z_I5V;xo=TtWfFI`&;zuSXJsotO zCA8!F^{Rkc;TEAdh26ECpSs{a-702{9W@0~8!yhByb9=_th~Ejz2#j1n>|@u03V&7 z-pTLrA9V<@-(;BjCSi6?fxR4tHdsAaM?WAesERHMcoa4Of6Z?YK^!fF)prCoh$%n= zd)PN;M~FOvLQwu1$e;XEgYY1Zd@VO^Jvctf0H2ihn+EPJs3<$9paFThHojYOa3Mk3 z+RYot4<2<-_5s|R@6o!D{^}~o=PX4Vt0H|}Q=jWfE$RFhxSU*7=)v9!Qb{J!QSZTVHp{E#*sxHn%R*t}j`V^9zyI3EVP^-tddUj=G|0G$D#=v)XkN4lIS04K` z*R{G7bgPXYr~x{+i@mW)q5synedu!h>L36FhzN7qRttMuf&guQE@7JkJih+*mkxr7 z6Ou&%F+Iwkzcm)8A9`R3DR(|jk zbpZf4zL|cVH6>L^9z3Fb&(AX^bYE&+|2dTbn}@#t_}3*tv{XXW@KL7b+n=gmj_Rmc zM1?V5L7~B&#dB5#^B`M7aDB$WZKi;O2A{tElLU&OuSW# z-##6`;r(7Q04{D7l-q=fAQP*KyBfBfM@+}o$EqjAkje@TYk{&!s_yMDb6R(!dBL;; z(ZNS#CY#SIFlNH$+YS3;WTYebjDdwb8b=hZ({@3139GXe7Bq}AxgsW??NNgv^cO(Z_t+0$gE-8)_(9v-ClGIyQ}$#6gEg zPDF?*6)ggT87*_&Tw@~6+?9piretxM_C**w7Ur08^i&}qm3OHIf^fxNVKNTgCN+af z!yhpg1o00e>&JR&JIZJaGWietf!pG!b-%Ljc)Z#0RRqTNWy4l1WjVBKR;UYOSE3bB zp=|}Bp40P*o&GE8w)xM?o554mse4#gq=?nusnu+k>2G1rC;J7lcdVvGZ7_AJ ztAzvOR;=JZjsf^&8ye?)ncZrGe;?Gvzx9|NEF9)FP6X^~97vph*b|H+kzJA6IO(=izL{tW zOI=OF+-GB*HY{7l-F4sGFIEeQI)#D~G{qHKRNvbmr%DbOx?B2Wq)iR?I6lWI3r!Kl z0`H+tXiF=e24BlX@0>bTJfk3ZL^d~RD8Yb|5VMd=;P9x9(`(uWyJ!jkxLl_QY-?+L zzAM%clQ##MYtK(RNKwFX;HfD?j*1^`5pGa(QWauxg1`?=Xi$8@JX=H?@(0WBp8JFKTKAYD+r2 z$<)e_0YXbg!a8g+<+D9k0|42GQEC)XblY%BvByGZq^50H480xne*14_c zoBA`R181$?r}(aR+By{s=^SEQN%2iM;tAkxG0hqKXvxg3aVN-itaI~-hJ?tW zo1FXZT@28D47wia$39wRZZkFNps{pP3cWWjZHq0#OQM55i*8 zOo1aZK&mI$Z{5ya*Hakla(9a{l0$3hn|@FVlQV=&*L-!1E%%Ll>1uf?n^TOYK3rp!h0r)B8I{|J77(we@>AL!w zi*9`6GrQf6GhIkxbE`Bf-eP52$8yJpNCA|(85@Rk=MCw3rNy5O*O!6+Jf2KUrlc2a z%gL6hhOcl0rX+tGP2i`zGZL=ss^^szI=Ns4P~^=L3A<4(A5T9}{6*{ujQYxz1eSwaj(WXBgYCVKyo>&+_!}FXUO1uY|xH)mpUV2y(tFg@usyelDqKfFML( zZTjM+M~|3Z0};h(1{>ATidd968}rm$*1FF@5ZlVfR>kYCt#-|y=e`a|M%^dw-sCo|Z z(+K(33MnK9i)tDSm< z>V8%m&$E*ijY{kmOAZueOQ+Ql--Q4Pv~@+$#Rc2hn)UW@Kw`n4>yQ+uQO8c^HjX#w zM$Qos3rsN@&F)g)!PAq$<6UtXpU-CVCx+2+M0<*f!dQU-T3$qt(C4jD3?fr7&20G_ z1ILp7DCUTE)xF=NwnMEF92OZKwf9ybH#c=y&G;BWzp~HrB;QlK!xoU%&K#7=d)=iE zg#>T=1ro`;qcN@J9O`Y7z+`%GW;xq*f!(;F#}#>mr|&3xcCYM``rHwFkyO1Saf?>3 zRhy3~!V-Vz#KPSxZtfcoMvt6Y2zo_VKr|^V-m5C59<}Qo*s<))+qxFJIK?w(sv7-b z#((F26sKb`&w9SS1eQCZNWBz4aS^|h3CrvlaT2e7&d^4DKO8;4tJ|zm3a6olEEYq}^Ltp-B=oPOuq_)KBn22Sn(zQV@I{B1qMI0sVTHXOEUIXUMlxWZJEy2%xo-QX`v{V zAfr5{ejvJQ3TmdNpEizAxNUuDpb+CwQ=Sc%rEc~tt1cO3><{Wz9TFj9r)xcx)bmP9 zhd?W*CXZSL%ZJ`81&xu?@DR5AV(jHe#*|Wjm%Jd;BHfeDYVfjA->0AkeHMD+01$W? zYs6u>3ghEHU!UZ98HZVcPA2CE%%giNi;t6odDuYswDe=)40=Z1Og~i{-1S4TPc_3w z%`-;F8`I!7ELfEZ4Fn@2dAHis z17twZyl9%~;#>HTbCMYqqyyeV>+4J~RoH8jp0kXHL#R=N=RsW+LX9Yvdw zJl_pn14+h%NlS6mRN)Ri9$qdOnjVk&u~DvmO>b$_O#CCnj13)L6o3rYP9q*MG=rwmN!nr7mmb0+TQ`j`T*m zk6kT2I16^RT}}mlq*TML!S_pWDzP%zSRJuRtT~iVB_o~Co?j1Ec*oeOskhpbbcttJ zNT%i9;jtPxClLHQK=UnMa|767Q3$gb&S()xV*aZz?x}=xTV_m*rpF2ZddTK= z0Va@-mIjm%2xt{#4V=ENpSrsUCq#>b0lCBnDbqWqme8aD#kHZ(Y)!dp*wjcyZ+nFT zch>~HGGkEMkiyTtsdg*t1~egVZ`ha;5d&zALow@V*VKh<#X1@Ir8FbxZ z2#w4EThi}d|405Fgqh}S=TN10yZO`79~&edG~p=9YT5k^r%-|!ETlGuY)zZ3i)Dl= zXe4UK$Eh$k#R`gu;$s29-B}}PyY{RSW!*2HO5i7rU0|7Qdc-Rc!cvqtTy4*C){s+P zlOcj|L)P`%7?BZOr_yNEuS$@lS*l%+r`fU_f5r%RImtzLY_x2#z~jVzC(c*tyON80%x>fw^;Qges}_fQ#4io z*p+*Oj(7!gU~eI<5opp8@TnG5z2q8YGgZ{@?bGaxIYryNfcveT4ci7c+$38$)T@f6 z8>%p;pK?4b*Y`mGtWI8o;E9Q2*9OxNSkkBbpzyQ{tB0|!3O-%%c> z<7H@DMYg;7b)SRpFTsK>#%t+U|Bj(8l$h&GH1I*WcPuGV;7;hnlvcdRb2U|o%}7WE zSeM~sM*W1>Gmeuy^Rn`cw&h2-a_~nT^}hsJqD%j<1`zV4pg#TTzSI$GZ=Wm)jIlf@W&@Og}HNVH5)O}=L0_Eql^Fdh}M_jrt0+~K< zErFUmO|X`2u9&&j+fLB^HR#;s0)!PtC>lGIwxYkwFl}ll^S=AbUH^y6uRS!RI)AV$mG{ljyLB)D6EKc5d(*k1Q9W#-c^~ZoS zhp5#JZLL%kL6EtRT)CRu`!VGvt@k=HbINIgq|Z`Z9gI75oVc?E>YLKC-WAxErvYX! zw(^m>^U=rBI6l%eXK)YJu5S)m&9k_#s7Z*?6>L-3L5xm#EI*hnLkn#i3vrS{oS4vN zLDASAX173JWP3%$MoEW#M*Ynulcv%ruSi`N%i*cyVuJxLbT>v@lhaf18m8+?V$ z-NBaljwbb_^u)$a)N`G+>75ArB{cX+YTk!vR%s&tKyawkhic@JcTC!>3$`9xWkFSD zhisF0)~mvM3EWG}jl8(Y%d3-J4vZ#9c8_xTChXu`AdQFV;` zOTH@b_9TL)QM1u#PL=1Rd2F+ImL zJ;2;GYD>|FR@sw3ICv~UXqUe6i?`ztGUHgDch}Hva<*k}1|G`q3n>jMk#p$jpFEGo zJQo77^=V(iA$pnyz|)5%Kh3>ctioHVoDRYrelp zdEOCP80m4IPM1?UDe+U`!ipiOm)isp0~WU*00*X^b%uL<{sFEUWJ zY~xn}URuLgd2}Pkw?n^_zt03zZ`N0t?*Km!Szxs&+;g^=i3i(X>wJzsuGo~zT}bw` zL#B==sF+`)dwZ?@Y_;zqVFzUXToo|y_$De!zD}2uj~u>b1Cd4Sz^Ob2FN>m+C#~xy zc9AytF)OXmn^88UNC(Woqf_!QVKtlPrye6liX_GkStoZ*C>RFX$^5s8L?Z`EC;g6` zri8Z#OU}+kCs`O*7O4(t!@gmS;Xw*)d@NJHBkCun^ysXyJeMSW2)U$@F{HO?e3Aqc z)Ly%l^=o9$R!iZRj6Ld=0Yebt8hWa~Wy*+UP(MB|Hk;805>{=EFtZAk8C#*7Q@Sp^ z7wo1h21R`^jOe-+sxWr@ZOHpn7^cgg%mys6p)#f4@BuAjcK!2KTT;CRTD@?uw%19fUm{i z*HP5foxvD_-a9@%-9J7aG%;cIYv&OBz1L&L7L2c90MWYA#c?M=xpFa81nAtBXF;^{ z%jhHq7=j0Y4EGNjc5?^x>gp=+MMM;5^aEN0Hi4Zx0xToklT)=aaSv)_Lo%^Ebx}R9 z6$8Ky!UaG=MLqezg^P0zAks%*z{!JjX$<7tRu1yR1^j@3fVnvN&PB08a9n{wt#(GX61*z0{QObz_T*(^T(ZfhEL@k7@02VQ8c613Q5LHKR7aYjbb62kf)E)D^BPq&}d-y8;a12&le+=!J&|qZq#c z>T~7!Sw10%Ucq=Kt1Xo$JK6(p9YkN7)N;3jKKh*}T^cf&~Js(nnzP zLtR1x8~q{w%*M2M1n=1dBAJ5L8}V!nA^^Cp{TDE!xq6yJ`*C^v3jKP|^DFZFGZH$_ z^k)8S(vpYX0lhgu2Lfz)1#|%*)Rs~3s|BI&z3xi+&hFLz_-Z=$)$z@~)<#v>VT15L z#j@U;`QCtU=050yf3*gn9oW?71GM-W>CI4&LAQSbefvi4yN>-z0{1q2`Ht=R z&K4croV{iCzn~xg8u(@F#q9Vx+^}wLU(1kYgmG2({ia%gd<$(kK!{!bK9_g+-!>6J zw>p1$CNZdzrlBusfS-WXe;OwLbcA;v#W1idf$u|oK0g531-iNaAI8q9Nf#bkw{6?* z)wX-JZJVoY+qP}nwr$&Q+qS*Gn{%p8)xJ2nNL7A7Dw#7Q|FLgR$MopGiTc%Vpo_)pC-fH^ZWuqJ+so%mcektJJH)TA zDqn$t63ojL2N)T#r4H8STaiTic%tWC5yXi9JB*3&b?ksb!?q_9HMJ_@gLA{_qAtbM zOF&BgYP01?+xLjxhwnwFuFUEVgX6GN8PHhL6q(n{EBu{&Qa~+rfXg7-mBf5THOoMTJ=+PeaZ%q)j-5q&nS*Dv&)z7rEv)?eMX#LD`u)a&Q|cK9tXMB&N^jGDmgPsLnNG09hRpX(9g z?f`0}<{I}rE6{IRhs5awhE?t-m2+TaUtyMbPse=cy&7aMx2?-PB)%i@FOcWf)5FdU zDJ@cHY3KG&tfo&8j`YjZ9b|*SY2MRGPol1jaYHmc;9t}%+g1&CY#r-4!8i6vdcLKj zrRe~5^~tS&Y4SFCnq8l$dfo1zYrzpqJgOpoLUmj3^epqe94FnLSGmo|j8aPXrOe-3 z)TEsj!^fp!A3$ansThyrpg_pOu$B& z_D2xPM0LLfV87A7+V>gq!#|3PnbgBH`Gqbzr%g~3ze)W~$kF7u{fu(qI`k)}jg4eK zyvCCb3I0*nzwotsju_cH_c}QQuhk$@AiOyT629tzSPPW(kdHV9`$G&t=)>z9UJBMf>y4Hd`avH)v?gKjT%Wr zASS#?M0UjpNjFu&X9dG5)I%`?T_Z{mX_JH)8;DCf9`=3>T9whVQ&kefi;6^yT^6|r zbwdBZI@hc)=VA`A;_!P<8@2EYlT;vmrg0|QyRgusv!h~Pti`VBqH7vr zlZ4BlrOORE1jV>2YF`?qd{A>>_;&|^E>FvyNU9H$afWZUY97*Gz0!~(h{+0xil8xk zz8CVx%=I49L%OF}-$jLm9`NctPv+h1HyxC0iRJSuUuaM>a(EEfhWTorF$Kx4%3;O- zR30?~7s{U9gJBbGyPe_QzvM?+3n_Zj6qt~0g*q(;WW?}092ij7dG#IE2HQ+jt#6Uf zY86Iu%1)gOl`3Nm-h$cD?l3XNAx(Bg@LW62J@$PR@8g2hevP7n*XE(me@&mLE22c` zaT}Sg+|^FE>2(B!PSRrW4!zn<+d%AnY#L&ysAR4J7Ni);?hC_HH8{49AFVFdN_O^z z3+AnaC)1ATjiM_czc|?AVq-TJ9a($$xS7we_Yw0lQST&gs2{4#1EE8Qq{D5Lb2@x) z;0vH~WF>#i_gdAJJrixvxYtpM88yDRBms}!UQLzvpPig_ZYma#D`WU_#@2|hAU}r= zqbifb`%(_gu;Aboe@1!H*u>svPe({>6{k?uia4@i<5FRg@0eS zjXM&akscnK9=Xb#b=_R0@_GqR5HK#Lo^>K#})LC=Syei~en`BWhGO zF70LBqaG_kFdhxk*6e-svY4EG4klH#!WIoELtJ)_*#;_qHj2{tvW5W~PRzDJ-8bRq z0O+`Q0gBw6z!P#co$Irt77q+e`r=6S#(tQB?)|OcXRsncs;Sx7<6b#;J^+VMb9BQf zLAmsL9uLx9uD6-Qc*RdDgO17g<$N!Kp&h9Y7felZJ!@KrDG6BjtoDO@5?VEMC0C)3 zrAlgc)$=dZ)#69q&0DpI_55lvya6-xPq0JrkSEHl%KW2T&O7;Xz|1%9?kn#!I89MN z%VB3E41~nX1QVW=C)WvMEP+1R?{)Qgl0gSvT%g@1@>TbHwDcY>;S^rhwAM?Nf~FyvxZG^6Zh?l95_rQ2$fBsqU;H}1r)%z4D4$}p0sAMod#)`^EnxiX#t4PE4r`<)j9L2bSoAnrQX*X#_4 zdL?fT#gJ+|6U!zHHSLSpXh_Jv7!*7i-YMw{g9VIL7H)4=jWyYbPkwN5^_YrRH2pe=y6 zd+o^Q!5LU0>ST?Y7K2pglKBJ=;Q8iy+U$`Ezzf-iac;{}WbjhaPVLb7brB+LWz`a{ zsv|hG-7!rko7C>Je{x)rUYsV)eNQ1|Bt~DBR{p6W_pnQoO)3RJJi6Te~<61Se{avPaJJ8iQSY5)Z#zYRI=i}6cuksZ0si+ANB1!+Z=3yA5 z^g9e3=kJn3jNhT1a@b9Y;K5Puxvx(@U^0Q}fT2TWOJm;q@}T)Ue*7Vex_dqyid5uY z;Sg!j)Q}Pw*5)DKT&gn#p=*YvMJwg7p)`En>S!E++1}1sHO(UE{w!5Apl^w_lry4k zF8UiGH>%h-7l^L_r*Q9r&Bw#2lZ~E5EuO~P(f8@|d{U*cIqjijdz~HL0;7^6K#WFMAfrm zvY;X~=t*m@nZR#3fa~zve}MC0)@yAod9CsSiUpn=T>V1UPfy)VI4I7}Dw9&GPrD{J zVq($Qr=^OEE6=YV7rI9MHp^Tey~@^{jDg6;>2EomN%Cc`Gr)7P@Q~G|i$;C%?qq`7Wy^Ed5o=C~x8{fH4gsxa`qjUAf^d5NQ~ zP#gMpe#B&+oMu~A7h;#}cIVuDqs=h*w9p(bZ6P)XgUWVYYQQWV@N>bb$kyxZ6*Mf= zfW=Zb_O_=Cd(t+zR;k;=dTE1E$dXYC=UdQ1(R(W5`j_kc5OfT&9kp7cg{xxDyH1R& zRnjiB%h$1pGD;u$Rg+p_ZX$_k=lY7L+-u;*uPM8BS|yT z`3wH{k`HePA*c4usgS3E5@Q)C^4&_`gAy;9m_JU*4?=4kA&zi)1l8w|?AJz-A2y-2A)8In?tvevvn$F0`@N^>Bg{ocnTCtJT#=Pr1#` zurilT7tEUW^u%6ggSW-wc5V2QZ{vUk=l+vnP1J^DT@z2i^)CMxnavl@xV*L92bn6D~;&+!o~#PzGXxS-_E6wK`) z8k?aXa1*t0>!UzU$V9NsA?9ga_$?qC+m~J0h_n7e!g~usiGTMV72_ir2sJf)w!}0XD}3Sjt?i0lOQSYkDq}Dr-dTR+%gHlCIa& z5wA{~y52l#KgLRX|I<5g*6PbWK5Wqp-S6UF@JR?OZqW9wEI{adhn#9T4YaGc!iY5& zRz>*`@&zkFZRfF!*c(70!jWxakMgI&NVgrNSKVti3^7n6FRLn;|0TLT=NPI-S}z`G+jSkaO6CcF*f69+5<0 zXXV~^;eGmo{Vfv5|Ad<$1&h;_cHsEv9GNl@%uskzM4M~-bk19u8Ex)(%vNd3r4r}_ zhD>H@W>Te`r}EhA@84~`rI5nP%5?I9tux2f~jOCW%QhqqfjPR zgcxXXz6>9x{~kCufX|4jsT@hOHA^lHqLg$(_>lK;Hab^kBYEXBW+>U~NxgYbC5&6g zLc)aOlkJi_#S1Z!C2UJ2dZfjECdKiy{7)zh+Ph)tZeR=I2vp94&z~RQ>d*jNI5jM# z%RG91E6QzIM>zwdUBsi-0M-JuVHUsBfN>Q`B@!QlzCgLGed%SRw}fP$SjxS-2#Y+M ze%nH^#ff%*+5XlOgIKE;KPmzbU3Doc(*pvLGfh*iK?;PAz8z z)|KzmR%UWB^5XYg*Ajls9&1eme4$0KIeJw?Q-b4`-W#aa`4wp!pHM?p2j=OG>D)HH^7F{97wB#w1K?qU%dO_X~Et}H{6>x3p2-pl&0aJ^VBI%XE#0Ze8NpNLl8#7gV)jfERgRHsGiu$+E9| zxCSm9o_{4?{FQipXn&d-Az0+UUeJX&bArVkN=BvK;k$_6xBH4ttzl>v)=4Q~Qe{2qs0OKi<{b9!TF7%@t6&Rr>-`#z`O?z#Ew3RQYOXj#+zgW0s z^Ie~kMQl~%Pz^qrsB$+&GZ@5kC7r3Q)v0#cT`zV=1^3c3aO-$ShTiLeH<~Yzq{JoW zBV@C8WdEoYf!spyb^WOl3g{qJwS@JuJFk6=IDenD=LM2&3c!mZg_9ROR)efWB%XSZ zCE29D+i}wQp(`uL2_1hZTD(9$xkJ7eg0hxYhd~um(aMJtf|_IY-5n4mOXJ#yF=+Bt zFW4M^Hv;8RwLc2|ZqbY4=Xw2O-8L?2r%x%Bo@MHZ@D(yf`f(k~gR@4ub*22JJrdP< zF2=VuvOQb9Xp@fWXgtqqfTxJ(fp?2&l^!46h<853c2h$DGlk}S z89CuB_J9KyP8<99)K<$qsWgudg^NsE4qjH~nYnK-%0NEtX=?Y_f$7p(Tr7u4Kau~( z>675b&E>VP2NObuV$1D*Uc9efdD4U{g*)3rtixj_2KWA_fK4YL+22+ZYZv@IjZ&aS?V8$noT&Kh!%+|9st`!BKig$9ep(U!xJsNev~6f4%;hmNGp1^_Yr0 z_Fka@ISj_HwDDj8jF9~G2U0%a(hWDG)0A?(Z(8cSH#mO zlADzYkd5>iOfA~42WJc43Y5J}hWXftqLQ#bZ>#&82X=0Y|CajsV0JDv-Pg-Yw_2a5xE^BV#7(diKYL)o_p*2#NC>H}> zuBw*ciIz%4&nqm%Vrn@-`#vi`h$tzQIQMFhOwP{?iI8xJF)98gV(u+A+myg_%^)Me zRK(Sn(6;&gVzXfgOCy`3BKX;g2f{4RnqLv;PmeZr>-{Eh7{6U>;T3o(?~+TKIC>Ka zXoyJl;3AL8xE2u(kFKN-MZ-wUk*$`RpscO@z9~@gEz9A>ahyg%1rX2`0!lbyZ$C8Q z0<&x|l8Ib-rm=Bc^%uNM*Ad2j)S@s^xK~Jz6%>N=?)hdGQH*nvznh*U{{sNmjc@KN zu!AxbwWiqTqU0U%;UnKPstXFG+Me*7^iT9nd zS1FD+M&FRW6bttlS@%>S<}vLXt}|1FhMNA1Z$_j-M)FgAsmu>S%%Wg1N4pDI_k74;c8FA?R zA}Hj{k-q_aK*OfdHhGx5E#B^O}@y^V9Y!sN7IG-+fF%*O7xJOJa)G4 zNBdFZNFe-Y_@@D%@$p-I4Qm%5xyt!;D*0q6D7swO-sBAqtUuq8v3=GnDM?qIh16FDJL22fbs z%9%IAC0Z!pwGP0B7u|W-^Cn=Wlm3X7tJ~#eXJALvdc4tE%urb#O(Obq>y~+TZi0Q` zT=)p;i|O+b@-wXMNDn@i(|!}e=d-RUope*TYjgboOTM;gy~Iwi0sSIBTM-UJ0aYCI zal$Cu@zNn#RMnh`LWn>MqAFo6v~%vo*}m;Pc{y629W0(!0e(lH>M(6O#H~m6X$AsT zlIt6(;5XFzaE;|#S3KOA#m$6AN#0=d87`_JwsOn26_`3rre#7ysy!DM3p^8*vvm30 z_K^R=g$=edQ~lp37-J-9r%6Y`fm&Ub{;+d@qZt|umKZX*m{^ z^fqB@*azrWcaCaHrpIzRR>Hpr6dN^g%#;^;%WAe$NuQhdzA+o$PUptB;p|S<{3eKm zB-&T7c^Yt@#|Kw}P)(4342v3WF%O8wev0kZg0^Z7-eKGvqfeCa5YrxrI{vi`nQ-1H z>xmeGmX0C;_cvWmJG>qSwp~R#tA)sL?uN?{mW~TWean_alN5N2hW|8TQT|TBYUAYVbK}Z70G*JsrqsUDW!yRA7Y<ywsC_X!S9y{*-zYd?I1*Fl2^}3G#em5i15?mau(T2 zZ?2`v#1Ffql&bxZwW4M&W;C+Ngrt(2|3-7`O@ifONtSh2(R`bJ`KCAMQ3qcHAVIb^1cL}unT?$9nw&4 zypC|~Pt?KSoK#W$*WhD;Usi_Pk8-t}+YuZwy3w{*SLV*1LxFmq`;dYnqKnn~1Yn(= z(wvL#(b}jP86WNSs6l#c<77Nv6;vA6a6)V)%D>ZtfKGeP{SWr3{qDU3rLt$ywpa30 z6X(&1dM9rF_Y`!*3vi=8yrldB_qU2xrPbv7@uITx0*#a3 zwobHmf!jQ<4U!-335quPzZ$h|!3#y)GZoOD+TP5~JoXxBM=D-k&x->q*wf_G#bs!( z*pr#`Tj(KUn6dOoHjxoLyH$3DK&i?0-!q2QVZkP;t3*1IJ1SdOv z|9nt3Jaoem=SgFzkQ>UbY;kh967p1s)t@|ofF*!x-DgGLxcl9tit%u)s}J(8i%W@e ztEBlk9^?l-xZGTCZCJUE`hyyGdo=!<%Z$bsnwj)!H3E}6rT4;Zb&^p}#JhL-#SZRd zGN27*p3Q1%Fv#`-5_7lDEaxylWwDWSQWfVfE=l-fcFT*E0vLao!NSayWt6gFNZM!t z2(d0hPQouCRDw_Z|HjO){%_38Uv|#_L&-4zVP|3fzpMX;nPK7h|7T|0{}VE3ZL*P( z{gHT`-v%N6FCdSM6ONH_8i<8eqRct%kA$0BnR7%i6iOm76qLj`yXUOO9OvzC-LsF? zYNp4F%UbV?&$gE-JZw-ZeOxsBG)^&45V1R$`+FYH(XvYn_#5!omr(cDS719Wt*1U1 z*b`>#lp&B~NRYui#qV9b6SyW({5lH_*rFmn1bBJ7AP|TU5O4woNTK}OJ8|T4VF1L zc)1qQm7v^sqyP<+044-j5R&e%)WFX&L4dvQ;MnQ@{(#jn*l9=yK+@43l&2r+zoc>~ z1V*#KG>X+m9W559ev!XA% zBj-Zd{>Pu3q!poqAqbCZb!Y_;sjW(c?P|4wP>!2}R>#Br9zjBO2Ie5!>vCW{M3L;) zv5p(1h5^P0vaK`$QHCNbbz8oot`MrShQ31M6v zK&kjYmms0{e_}QQkbn$)nUIkUfPu!rfgZpBkKfe!r^j#~Hec{0oNw*=8011>?^93g>`YHk1U=lS9M^bDdS0j>K7K>7b2M}Qmo=H^C$*!XD>d)Y<5f@VAx zpOgpc|Gj+9qhKi>wANP$U)#Ou)0!?Lwkx!(o_(e`{>3seF~|iXBoJf*ic5#$7x-_0 z{h_9YyZdy@{mt&zyYeggr?$uM_8J#Gsi1`=aD|96zVsOt{+Tza|LbJU0rXp&4=j9v z4W|FA^)vS#@*XhG9`O5!^o8*LYw@d|`m6f$+d~4*4t3O)^NkqxJ7#+f7V7?e9hE9hhYkzx>vBg>?EdjL4W83eK>TPMM7;H?4LUfx+HWl-48(w~PfS5U z15E$;!tyvIN(IP~4DJqDV73x|{IPBLKk!Qd3j`ZP!0`!meNfxM?=MCL3g3#}{A~)5 zfhY^7I#{l)G>^kn{#{>;U2%xQFK=2z19#6D7j^O_jN&x!iudn_G z>w=oeCS@eou{ps)1XP6jT5lar)-?-xpZ@xZCkF_c8VufQ({e12vHJ!7xUJOT1~ z?c;SD48$YQzg_y)K;RxJtTR4#3J2Q~F?S9%-Re>&;eIp-c@SzfWR35|QX?a>iM}zF zEd|ZU;$KvW0n4pV1!teGoG0Jy41%_->ZEA?IHK(&!Q)ZP7squA=)y*S`BkaN5;1#3 zEK0Klp+=@*dLtQjZyz-JH7cM2K;M2Hc$*%M50nigdKwH@u^f(-kzEVgoHhzKeHpHJ zcpBV*s3W_y{gnJ%X1kypXvAR5T}b8UZj(7`8twb_#^zT%4zsDxTr)Sc z(XQ$%3-Uxlvf~f$UQOc6K@dds>dmBlSKQhOYCjx!)Y?qDT)pNrjTUK>WPCuON*Fu7 zR{xfcWH|ujk_t33pK{L`zH_XpxO1gq)K9U-hF6Os75dMAl%>lZJ1PK%$t;W{Z*$SK^X@7 zf3bgF#}MypN^yh0c7;6@uWYjH+x{q3P8q*LmQFKh6^38bq25^H_$#rN*qf)I;>9%;wufBmz#sZ(ySQ9D6v6@5d{#w+|+%E^p7mG8~pXdth(<@3F^!PlF$+h_Hu3GJgs8IWJ*oWu7r zT%JEloi0jBjXjzCq-q(50$n1P(ltuX!kI+C@$T*NO`${oA+S(EL7emJx;IAl-s0)2BIwH*594m zN;7jRNP6=ra<_|?PDLXo?Z4_|HW0;L*($IlC@u!DrCVaEG3_2l-N6Iz&pjtK=jOk0;|21nO~yorIlW;O@MH_U_TBYx+>dlO)EN+IG6;> zGm99Lh4USC3G*AD*%+#u4zI|$Fow=*C!=KD8_3U*n$wDg47+{R=Z5*vhAlMQbOE0O_WcVw#zA zEj8nGSb(3aLGtiN^86*37}_lp`NjuhB%RCa@Y(Rb6UfQAMi|286gGRu{USbrKD8ltyb3M z_^O#IjO3d;RT^P!5Hi0(eR5C4%fJ?cn!X|A!~Lm-EY6u1<5w7TTFbJv>8b*7{-_je zJ0URuidzxaB36twd^IpSPymVs=3d?*bD#)AOzL5w7&v#^4 zc#Ip+aC?zDkGc|ufbm8>XEA|*6jgA>E|ouBPe#`f%Ig+W#~mF>?CUP7ch_fle3Jeb z=4c{*>{W!q>HTK8-mV2_+D|J=iMGN&9HIiCgq!GI*Lm^}PfDAH`J+DNzdDIU2@6~p2O_X6Cm9HXK9=8&GV&e`6j5>y)faF(cOH$txI9?WOhKBfrY%jZ=v79 zo!cg7vBZ5#&Ni8OpLO57p^Oeyb^25H)2s)oL)EVrcsQyxc;KntYlQLN>=0|i8PQsW z$8nkmW0>W)@QRb6d{{S|E}rdlgfzWXK<2BkGeQUnSjX?&E+)ry?z_J8@<`W}Tuv9@os32>Mu? zO{RBGw{UWy6E5(|miO4h!#!nK+<)iI`m%zr-2?LoHNeF)ZTzGiv`R_%niu0Xo)ade zb5*nmr1Fc8D7X>xS6~fSH=46_TyTlB6a=tmCi8F`h?0|2h0ZZ0-Mdy>+C|u5IlCbv zBwFwa8*aK_GZM&IRndpV`@Yjc!nu|39_(bO8ncRFLmb+yN1L!hy&#w!wHnr(!;cqc z15M(Smp#B#4^znmBRZ4tLEAiSTs!zWn{+(GzQ2_!IqxXqjXMMhz)W z;dL_CPu5l{Iwrp-uUFFy^}^&$qPc?D_b?+QX)^dlWR2vg&s{{=a$AUg=H|e1N#lT- z6Y<5nL{WWSwG!6>JBRkECWCp|_RJZ9nwB~>t4Z$P722gfxK^O8kS<|MD#3dB$)kIq zXzB9b{TRN0|CS(62>S1{#3h!WFSQVbR}URbOj^PyXt0^Q=!R@Q`W;U5^UlQkQI!-& zwP0tdE6Lxx*#mby(^b84ci}AOI<3^%y({p?hIDUVT+Qwvup4O>DuMSK8p1fQ6%54S z5PBH&UcijY8owu5Rzp|HvuJ7Y*S=?&^!D=oI_O7B?n;JujE17~{(sFUJ@CqAYpR`n zm2AhpHT-FG&dsZK@kc;Q{yOWvQC-(DMR)8d;1cVh$<}WUR`jGx`yzhun@YE@dv)UT zaAJn+h(=il1{HgvKNBz={0BO6QdbMYQN?q%VU}4}rWYS^IzS?4%;suQ`oA62b00vL zv-piuJt=3wNw_P4!_@5}1?+>Hk{cY4jJ3lwi!)Ajt=sGQHJjkgx4)xYH)Rda?p9% zyu_30$`No4K^gO)A9N7f;xYVs4mi>m1c+j8!>t(140U~%FxMLY5i}84TI$BswU*P{ zlV^E)1sTc4rtO@MY~fDrvui-NFs5R|tJ#%KBNf1<%{X&lv~q{yMQ2V_nRrb7=jn>| zr@#R_5?}#8QWkUXK-9)&nr5u+IoI zP($)xlf;+z)PDqs^CdVp*Z-D?@1Y!fLLf7+R1AE?@}d)eZfz!PEF^4PEeQUl8fBVq zCA+Q6tk*#pVpRPwzIyt1w&Ib=!Yk7C;ga~`Dn=Um>nW6fL`v+oDETT5Wfv=gHJyr>50N`zCq7+ zlv~!y>7=jXm~Hek-I_l~I(b^2V`kSgNp0O-SGyCssX-Wc%X~BoP~r6?YJ1U?04?x4p)liV$>>e=dSC_r}X9eDgVX;rGQWwP+k0>Lsn4=HY} zN3U~kS$Su!1~nhyfiQ*8*?Zwz=>AQ;FgL=i0(V;4SRNb-K|^RdzCNa(}Y@{ z7JA~p@F*%(ex}d+;drI&;PD(jzGTMl+=bA$9wf~Vk?e6pk^>Ii8W$6X3T=pGt8(C5?0FqbI1XYf0EUOP{W|jPVAy~4ys+^Q)Mhn&IdELc+pe@i<*Pyf0?I*K^lo!|idZmRG-Z5pI*6mR6S0osW~%TEkJRD)50?VhsMCyns% zm*^kPozq8^Axmwp@~j29LGeLShNHlE4}6~xV}mDwdU13AN@7BxU}ksu^Hz~U1rCbi!ZDyYA#->ey>j=Hk<0NiX}k$lvn*X z1I7%y+is&a-Ks0LOaioj9=5fW+(`ySk*kp!Sc=r>CM?Rgv11ztXHhHoL>>%zN^5&h zNbSS>1r=r|n(vf5O3RJ&i}q8D416sp0O^WmvLw*sR=EAeOrclcjwc` zA{R)Q5c`;5vU-{^=PIr?U?oyJb4s%3AQ;bJ$N4L~-Xe;J|8Yq6>t9ZlYJ8V789%5l zpx}#&zWZI0^y0^JfuV+ptrfl{GeCpqQvszcL?Z6W?>bt!!kQY2eGEnpLoXX^Z?Ekg zLnNiePL_%<9p(+Ah?19_7zTrdvBg&WN$DD24aq2ZMfU3Mav!+^Rr|SNAyS<3=qeFx zZG)J%vUmW@UAw=?8KqF74hOn94Qt0ttR7h6{(Kce1FPCjOw@{vEe8en@2WlM#aEJ~ zk0qsdnX78y;(a5|#XNp!K^K(@M^9Kq@244ruJrsPZ&o(PVe2C~*kr!301!;~COq{0 zut!HD$bc+Gj!gbud<{Ol5qeiSnO6%<8bu7EG-=hI6yejya*tz?K-FI6%Foyisn1MX zF}Z8nU)F+rFU)8ntp~|ORD)jGgH$X;i2JQNP5Se+s%II* zfLo@S*gyeu#ppJSPb^e8AYpW~jErv@Z46c30H5~us z-btTRCsVecHoJRcwHj?%HSg_1Azh|Aw{qWmcYOuQ;uG>h`kWSCwdFD>I#hdY<)w&n zD1b{e@$tT)+xeGOd-eBM+jn30cHOtQ$tt3VOSg%&)R{26<+MdXimTX<6{Wzdfwx}> z*L}QU>a?20yQ6bic~pXE{VX(#9#IOd_XtO$G5|9xyI#>CX}J}{PyV;r2){r_+{IP9 z2-YM0lF=O@ysY?P)Uiy2NE?3LePB?!`r=zVh?Ifa_|)_5@KDjwNDFVx)#UwupPdwpN49OZ}P6TNdazj=w#1o9+R0WeEL8 zjz+6lEh!@-R0r)0pD2)ph)FS2%s8_Qy9BpRQ&7U=FkPU#vfwpi&K1&;3{P(j-1ZuZ@)lh%8a&NQhO)P2a~wWZ8AEUP zCSA$p3=z_hty{%(zM^x-E+thT#@kltA1nRjyr=T;)oK=^Dub+4a9%Ee+cicdb!n1{5S^``%X&I4(U#Tx%a z@ve)5LmwER3ULVDCmhA1se;}``R#H*ajC!ehBR&CcHSe|-5yyNpX(YD=J#YYFJbwv zfH%)ab^r@I7A9OaD}A(O_zR0UGgB{>7-O~~@bIoK8MP0_b@*S?MOFUvRu%PhNV^nOjUm~LWaUL~OhjJMADJGqkJ1|wKZ0q(k1#i4pC2tvQ zW}Z||y2sgP3)DA8k>ycB3Aii5<;Wyv)ea6qPr4`KdUE8(6#zf-5=vaB6j8i+<7VY7c1>~mpNP27vv>pC$5m9!%5GaT6ZAqGCJfP66}KTh#b|(2~$2z%2d}vJ=UAX8l}#sPI7{eZ?Befl+$)8ZkQ;sYvYKm5j+^Q2*_nF zp{P^EFg18jv{T@4WToli7hAZ3#!{K=qgmwv8uId(KmOTyGGdiULrx=U6t*?wyp zIWJn$FfwfDUydTrP}<|W-Jp{cF(Bdyz>W{dAj zO`THzatm+EUo=2NS}=}{yp=%an~A5>n%pF*+aYP5didB`BHBd5MB%`mg zB7A1RRfOzw?#!U2=q56h{J)i-j8(`lLzoIQIj7g)WmhZOjcQR7d3@5EQ8Clq^#=?( zOOmWcFPF%o;k*|_WXWGr6gx)KlqT$+(Q`USpH_dG*?2(ZZI*}kmnG3Tbt>;y&K!i-sg)`<(AkL zS>zD6KYG<$536ZIDf2?m8sW8N!w``5-Nm*MolV|gU98|kD!!obal>cz|0m(ig-F56 zA*Y)04;P;xJ2BG1zl1P^B9qbFD(TB9!t(I(WT_yZqXHmLH`W$Ye1{5!9c1r?QFP^t z*(jyxC99oe&0ZPi{#=#QSj}`XV0cojUKI<+T9X7Uv>sH{tfjBYd^Fc8Zn-h28}rdK zy76V-eoM{C%2iYHEcmHQbU5-k6V>}hx5fk{#JX7)$;PzI_LVnrq%Ut{7vyt#ji`)P zjR{03m;JLFNo#D)n7Y|L$a@+jb?&deOy;V!_#ejJDM*vBL8B~o*|u%Fs>`-*er4NT zw#_cvwr$(Cz5UO|Y)r(?#a!n7dy$#vdC$?wGL8S0@p3L{(K2nC{dh_FBRTd1#Eq=> z_kUYWu>WtX309{6VH#oM;$r;o4aNUlO|WyZG5w!SBhLTHSZvU5QAYm_0zvL)Y?P32 zBhelBe=8PS(MiG1;Ym^wP{dnXkn>bqM1jyhrCxp?J3Cx}>;|(cx9yYmi?-{Jc71kq zI$eBAKrq^WB`o~i-v)u|&)da_f%y4>_4xUHiP_otFvpSJF=Pgd5k%Yj5$)@KjtC=z z0~P;OoTG$3%1CyB&^W|_B!GaB(Luw*?(TqJ-(K;*uEKst03Y^VGXng%8UCwbfm}C6 zoYfV_sLg}gKDko^1P@68^mrOSI`D5YVM#%W{0n#h_}m}~ZxKot3B(obl$h{e!{S1p zigWNvfzq6baCTrI2;=f_{9nUD%8?(;y;s2%2(Od|^$fo0*C#RTED(?2590xu5$Ne! zpU%&2J0wmL1SS-C9OblbNu;riC$FF#zeW<@s$)B+9_=mH|3@=|dnEOE;p@mqiW+F! zfpI%yg0~Ba&^n_JfrGiZevAPH;4t4+=A0aYE2n))g~29%hiLdy03_rc8~g`c6j%WR zXc5H-;xk!qW&-Pd1M(fb5bNJy;y;!V3uFa>G&s~R@xudX*H91z369d-nIHDg4-v5c zvW%eiLR-NEp?oFc!3o=ZXUz?W_wxdids|!u0D1TL{&=tmPfTC~yFI>-e7$%F46j>x zGGlN0Vg8JelLXy@z25o<1M$WN{{})7cqbwrNBB3F$oOI1wY%?8q+`6SnYjB(RK&6k z0^)ri0N(2C@o4=agNf-;3qiTPfyRbx{8zDv@%w8xPB91}DDeAd2j-UN@Td4gU-Mgk z{^tgUs+EiTo89TN`G>%)7G-kof&rp2X-na>NkKd>74&>WhL_O11zwvw~M%z8Gf``-N8@jLG0m%gJK7 zgm=>)j65dr+)FtQ8Pl^IWrfZ7t`m3bR;KKH_s))RELO4uC_=x0nN~nt_{TMH$Y=3b zMEg*3!n@?*@6cNuTgan`rAnviggVu#Pf8Ez-|W|W{#-_S_FZOP|BkR^l+mAS=AF*7 zCNBGL=SPu%fbV3j6akPhg736k;Cn@8rC>K>{o!&=ieDA;=64etzda_YjdaW9wll;V zIe}5XV0tyYV-YA|<0FjsA7211PX6R5XMwpm5m#NAow_L_X$13>2V@w_@L)5?3+^|a z4?1n+gN;%LZ`JvaS%K`~#XoT%I<%tn6RMc9&4~VY#^-FX6=u|Ldrv{x&@GLLlQ?BY zFRI!9F0)!>{w9u?~QbuQ@wQO_PV&etq>n zY-CCKEbUC|_Kv|?Dpjps#g;(b3=d(f`Sq52styys(`I*eT?2=5C?y~q$rIdxNsF0$ z{(CjnEHn`nfNnV~_3oY3H7Y0aLL5r|MO1oWLN0KvsoPg!+3jokVqZo}>oZ7`pLx~1 zR59Thn`~F87Wexbh}d$mPT@P%1*7C6!-)FX9VUDYDLc;TU~bQUeT_v;ut<#V#Tz7t z#0Lewovv15rXUWERn&&rwYolFr+>i}1=;pn>nic406aeo)})3CGO1Doa+Nq4C%|u&9v&6u#$W(4Rzdqw{v+O+j8D`fWTXYiq3! zHLPQ-*yGg!^Ja{%asmJu!*d9FvH$g$IaxL^f@R>S7En?AV6>wF-KR2h^iV{ekO>^s zA~KYJXvZ00w4mpo`}^7D*U4`Gv}-O))R}c>m;B!Xl@F}2GPBca4U%YjfGT1yWoqKL zV0{Wk=pH8%jxZPnL}v+M=0QqiZ2sT1aB3CiLlk@jFo8~lf5-8d!VN^m9Dxw(iY;YU zURIJ`3(vEIT#15!5dP_o?F}-}RR`Ep9h7aPQ5_?4JF`0)c0_tyzCsNd`7#S_bH5mD z@Lfe_>M!@eBG8}jPMI@vj~!fT7UwWkB2hH)vy4F8w!eHE@&ep@!z+IK?PNl`1<;q? zI3H=RkQAX=Bmtq+Ix4?ml{Iv5G1t?#ZJjwz?#&Z5(CFlzs&PMcfXQ45S_C>T6n)se z0Q6mxX&Si@Q1N=cK1qU`{5~AlnbO`KL`Y4hA4{+mcd5tS07k0JI-6z;TGPDnCp&2| zgqTBUi)->(N!jY{ax_ndmDp2!xRD>W%V3lflAT{T$zHl9NnwqRKB zfaAxpauM@_tol?f4-DDQL55`!--K!Q!SOwZGP;P@3yjv|V|ED;YJIiGq2bO47@f*t24>|%%{AZmJTN{!;NgZATL_wkl5fOf-pN4ikn6rq*^EZ!7|oF zxHHdL$a+ZFmCLKtYFHl=TFvP){9!EIGI$vIrJ5Z@$+!J`M$&7`bO-U%K*{3q5^@_= z?*24f`X-e*w+h20ls9MjS0frF&$1rq5f%9uZC)b_k64g}GFvVGv{)BE^&VCAW$G~DQJny~lEktyEtmEE{EonvIfsy21 zKf({ABc7O)&+dyWYgdr54;-xXppbsk`ykpwC@FIxu#HP*#B00GsOmi7nAq^gFlL(oEV3?unI z$P>B+<%Eut1O6J34rW8*W8aHhgz6}$$^VJ>)!gSZ^Ww&z`6Mh-^`LV8)XpSanw+=f>p)fIbVQ+;9&B}TRcw18nN7D5cBEcf&vlpOM(vOn6f*jpV(hZ2p7@F;M;h^QNk;! z&VGLF-pZ$~s>yRD@RWE8>CnelU*DQSokL4o1SZl{PffJoAh;Aw1NH6dsdD`eQ~w*z zCW{&zOfOK&dd@t)@*1&ixNjL8BPk}4yVtV@Td2h{546d3be{~y$(}*mj68ImG;Bd? z+cc3G{Oas?9NZWAgjr)~jYzk+Wbx6X0Sm=q^gXmc9N$EAy&P?dP(h*&5G{_8%pk9Q zxNWbY@1G6P*kD2lj^(KK+_$u?Ms}6U=@oDe6MW;Of1`Cs{WADd#&XZFNh`uBjqtsTs9#yURYup4zDgFCH>+|UlSYjQa?z`%SZ{2(k z_BE-XsFavF?GY1CyWM!U5*>Qd&p7Rwl zgo<-AYulY>g8=q@>GP@ljRZmSNKei@zvJ$jr8EkF51 z3rE5XqK6$8Lo0n}5mQ1Yt^4y&CmjppWY}_%-@jA=eKj(|*Mu(DOp+(b`gUpY^GO-s z{tT?Q!eg4N@}4b}#BPAxy6BAlLu}t)Ibs9|-cyh1zw2!Wb2jNSBd3v}Ba*Pw)(g~` zr2a@_7)T@Wo}k|wjnsr|_9-I&@-Z1Qe)L820e?hyDm{7gEJ;Wb)0iIy%Ilo2p-Dm^ z-yC#L6h5EDOsl1Ldl7kksDOpS{>v)?y|mKJGUaBQAM$e9Y`{*Af%U?c=o;Mk+y_qp zD$snRBc%g6u%X3bian6L+mPpXSiem`BWtac_XWF$%e5; zYMd%YD0`aalKlIjV{;(LIQYH#Mhb)nMvGy**`hH(S5M(2ZcO4D%Kz@)q?k6>VaxG0 zeYCy;R1b-*7@<_kg4&Tievr5itFVK7EJ>RF5zEXWIUN^9zIlZtr7fK zDH&&Y+{P$@j!k>mG@58C_nfErb18bwIk=*E5_EGv+&5bZ@Z2p57OURC+I7R+yqwlk zdvUI36D`LegNgjQ*-M>8j$O2CM`J2T_x?0~a=AHm-9WL?YS3S9X8^MS0G8QYD!HP%D0>wLDQS~*Rh=`_su0!i;{=gJyp%O!LV5(%V-^my2c^50GLUhN+Pk9s zA^Cdhqq=e-*^?-t{AJ!-z`T9BZu9j_te)Qt#|D#`=HGAL56s%&<9f{rHBfb4m9$X>%vSX-{LB zfVZzk`^Ab$-5$<8hl{FwSi@0QYx+sTewK3d?0!p zReTd#K5`*AMODSOH=zgZ$4CzjNc?`eIh-POse`0~;B zA!h-Ff-+@(Vwts)PR4%qgd#@%Cb|~W@7m=QGWjq+-k{g7Y*W0fzORsEs_5x&%uv5>E^kE7i}}Om5}&4qgAe*8T(m&L^cvikYssN~B*QejEkSC9-m&eIZvI z$)lT!D zv-H4WKb(h(Du@;Y$XbD9FJ0Y<9#!X{xJg%J0G@R88pbJ`{Wr3qw6o1a{Zbgf*gsZF28K0#r$#MDhSNVnU=)PnZH&5&HakQR zk@-$9xfwkr+f-cI>WB)VSYY;}BNUS!b1{tTlQ1W`RXy3`8Y}N%lZ1-3(<8!mE z7AEU9db*)ocZ+1VZ8`eKUUI1z{6+wEPl>)l>z(s5zr3#ojPi=RPp1c*N4lU3bFTqF zp-ZeRgL2wi)^+po-0Z~CJe@qj@&ZO4b*5!Now5K|f@9->5Y!rv3W?4pB5s%=P+(!_ zVpj~MTpt<&gLR5g-qSdE3#u%Kb!0EjO53MKumq&=5mMmuj@}mcRnP6f+j8p{N9L|c z#-$6_9Ddu6SpQp)4)xAay9r#rS5oLVX%~<$_xa!pg_Pjlq7F-{2f#re(x3FZ7pKBD z+|>Z7i%()c7g~PWHOhE*EjvK)K}h;EzJmse1&-!iL&%r+W9hAb$k^g^lhm%|3?aui zN@^(I7&%l8o!*+rt-fjj7o$jRVil>qE8isO?hq+NGmCDEgU%yWW#VfX#I*&_Jgr zZGdnF(P?t{oUj7gUT4Srvd+1i&qtQ5?v(oh(<`~NnKA(#DU>NTILZF&pR$xIyli5> z<8Kozwb>yt+!x`$hw2tBRyJsA#;!BjBI9?GzBuw zC8k|g3BRuvr#2li-D+{_-{d2m_~b(V&*L&VfT$FOZ{Cz1={K&Mu%nO@?5VV)G=h52 zh`r>k|4J26tYzj0=aA~aUKS0hujg&!J+2ztKofoy(4<)*=_T%52a&g&Ss||?qqUrt zMKHY|YyoG(_UN5zac1}p9Y3zu!m-C){ou`7{64vAE9RM(yab;dCyyvkU<{%r-NRu( za04A~)`wJ9GqSb~zx2-V_Q`UlT7UrkW0 z`a2Y!2CG7iaRMP^SwrMFq($37l z1Qxs$xyq+_dp2=dl0@3jGH+V-d$yg51=bx!ht_&6SMJ*Ty;HJwi7Iby#S3jBFU`}D zZ&JN+kv2C0GK*s_h@72^TJ`(};NAie9&y;tFSoycORk<12; zc%(#%n`?3@khZYvoxC}GB5@#4JBjwjA-HFU|oj854uvX=O zJ43WeUHqZ_x@n4SFuIZG0nj4xlj8tLiRr{80};lyJ4spDDc;W<495fcB2N8Rm*dGtpLe^jAZ<){sxN0DEL^DhsT6dW|N zD^p}JghqJLQ0?Z4U`5;-xEm`YoF5xZ5U7<7ls(1{X2fKhG`~&e7<1IK1MTmmHAqsbc^grugW6DXbS~erQXIvw_A6iP6EO zUNS^P*4ciV2d^-|+h!3k40^dGP^xdBp-Ws+wUn!%uprT8oqvv6O|3Hy79CZa=Jk!z zn@5tVpJvSiXM3a~?;%A^JVhAJRj;dw=Dw<6X1_v#?I=j-;XxA6TPGm8RTSe}Ze;T$ zp!!|6OHvz6vs2lg!j^b7CrzdFc?eaKUozjHV7B+d4|M zD$QE-A|7Z{r?|Xtp|&9>{cuMcHo|ouht1fdG5I$OSkwA}xR`|3L8}MY^!QV?l#N{7 zq8I}=io@_yaS%JU3N@S!cuEBF(NdMW4Vw5~t{#Q3m^#F;M|mjC%V(+0P~c%Hz5Xd~ zaS5TSiad5CRuD%0Eg;O{rQR=bX`(@odXFzPPZr6D&Q+jNFN)d&t>Ssx4I@;sjoWERLZrXcXCvQ&${U$6LC{D^amw|HCHo>utrrM5jUIJ@q0E+!9}(O3$h2I0_AyDTLA z0Zsb~@ciHK9OwUr=h&Fo{~O3L6S8x1{C`jX6VGvQa#fX_}wli4xv z$C_8}NtQW*t*Z}-uPI|cd_jzV;oBeZU=yJ7b}{sMAR;0~U?L(UVq05dO6*^6pePQR zLUELoAoLIVV5+2GVZ#P50T!_G7{Cw~Z39641we*SScZ~VL`42!adD43B4A3t>nE9@SDx(m(400~1v2R{1y0}FtI z;)CcC_9R0gI)Fyu<(KZXBK6~6L5Ta@^-abe` zp`wVuiyJ{ius`F-HQnonS@s^JeCti_A3jw0<{v7M%WG;2kkIxvVb+_Ud;`J)KSl^h zY(jccIwB%^F#lFyLOnw9zTBheE?uIYzGLWRCr2o&q$ovV= zH~J6E5`@r?wcKfLM25W=*zfn2Uz2-ZRRagHbnf3#unfC9c=*JOdLcmW-*w%|ajl4u z4`iP|yg)rl-#^|z4dXvk?>`+xE^e5Y>S-tHpFb$S+J75v`$1yTbQCff=STL!LVWs_ znZ@lCR>A-aZ|Qz>l!yN^8WzU7_OIjYsZH~bTeZWDPzv=F?0r{Y9ldLb|L%sCLBK?X zpA*l^6VS(%Nr{{N8Dvz3a2)QWrtHn_2s8*e-|<=6B?Nmtc?=Je2J)96oz0YhG-gI} zaPY5TG?VE=tkM7e1qt1YWFZ3$R5(Xq5c?bXt5Z$VA*#q%s7I}!07y^y@bV{<;vM4KjsM>+4)b`1=^J8z)fKqCU^YyDwnrpjGhPDr zCG~|d;z#etQ=br#0W!?uodksRW3lYo@ba!V=fY$475~WI3$E}OoyC_7g;$uh)E$jt z+Be-4hF@Dt99tx!RosCC$cWNA5D_$%SJf)Sn(j)aGiLeK?d|ciuWOfaYMA5d)+Azz zi3Zvfi|(~-U_<~a+YeJkj=F4vc4t>!M0JM?`-k4J<;32G?1Y};VY^H66vf5P-n|rC zq!NR1@l+2Xaxw|=R-E!^_Mw(-&sBDLXHJ4%`U&!i>#rsAT8#Qh&G%eQJEH*_Wl$%v zwj`^x`7S@^;rQ%W%-+#N>>SMJA{rs0L%l&P#~qzlnXewAyV@Dm!nu9Dd$+``f^`pl z9bHMO(Ya*oBxp*pgk*NXN^5u-t&*%C`X#VOA-#YC%Av`1E>S=YhPA?w#^g0Wk^&mCJ zdmM&5ga%z3Z#j8RCC-M6=v9`H`4=f`=~`QJkvke@Pxx6*Sa&?yX#fj>$6Ff&94@1I z(X3sp4Wp=R^51C!dnNPT7{G$~oen4(gj5a92IbCb0(Jei+p+CxyDr`h>Q_2^K$imjNqL`Fh+NR*t0Lnh+dHqbXD!QTja8vcJy7XtlE`h6Lm0%&# zA5VZrN+m+&XB8WHbMmK88@LS=rJagNe;PrJiQ}KT2Z5~O3!$2f*7v!!56Km+yL`f; zl#I7>j%2l~QNa@W3aZWdozI`~K9@2yZ*xY>6dux*%63EZ_RWV=DSNdxQ({TkgEgS= z4s89B<=^5#h&B;{@L&bMyMCZ?g)*E&!(umWc61$=k9GQWC)ubRyg{Y?K93Dso+RcD zhBlOYH3F7&rY3E=IG0v>Ej^j4`bodmdD$-_QuxwFN(c3iq9e2#iN=Sl#ifcAWyMyk z+xubCi}HYuR2AkA(*<4WF%<@?(7JNPB*}7AIH<;=V0BM$$JTP4vXU�L2VQ;L$Tf zOKIqd2^wmOG7eo{oj&YO>9e`&i=*4qOWH3ZkM(OGr8N78P&wXkNDIlw?H%@kK8egB zm8+yxeb*N6&sgOV@qo&c#o3R_B9zQn*y@g;suoUjxG07}6${A> zi&ZKI>^Ec{7oTm9m=a`J^;MJ z9H|{^(UDQ(iuuW|-POM{B@F}N+A_5LTx^1>L-aS*$x>?Tvj1 zYdz-Y8Ke9x-}h;6-n=|R=>aoB!5snk5}a+n0tEnq_E$D=4O^oy`q_Fe+7(ly;ncj6 z&Fca_Q`|GLV+z&%Nmj_G-60|aj*QPwL3`m+}{a8QUw|7uH zAKt$8Lo(@ZFzG${{-NpJE;rqL;QwfAYi6M5o5S@ZftCi!0u1ZIKf7PP3a=CrJY7CX)r#sUu?%3%+NJXsuI}Wkv82W zrX|8cl_{-aalzjb$xE*ZE^) z)XNg&=lJ<60#q^z$wtJ_r(Az25*Xu_$U46#o(NUX&qys55&2%gvb-~B9`07p8Z~`y zv+fq$RuQOJ;)V4|(Xc&6NwH(aN6c@yJ~#2S=rxxr`nIX+(s^tq#Q$vfYr`ZhY2tn( z3vlWKGS%_TlJsod^!{2WaY`imejo;yFxWYK0awq#TO5;w=af)Z$ zc$>U+wxWnkm9(DvfSVaDX4pnMgDBD zBP`y^CisHVfwxl}NN}_+58Q1e>k~i8QIPHt3cG2G^qia3@+%taGzO>cF4& z@WG;UtrB$jP7 z&-;KGD-@G=5*Vp zb_@jo6n=CKg!#>{_I|m`uO5Y++4_o1@MhEN_v0wqvxZ9$AtBkl2{E^NN_C&~GpO#| zRr9n;*v1b8T;r!e_E%!jL##-f=dfu@a+CSG;RKHL^C7E@PQppI^)o|cF9PTBWH##O z5Q}k%Rm|uOWzfGX^Yp|CX1N0f&9ZRdS@MC168v+CvWf==zMx_o>e6b!n}0|IUy zWXg`52E6AIqyAWQ61vuEufQBk6eXMabU2@=B5YTbcnq$d0vE+k-S?sa7VK<5k0(KB zesjY`S3$Sol0Gxl>E}3lg+(t()i8+^TDe-ev-mo9$rR3`unI~5u5o4Qzb$4&(7`DC1EVJT&Bx)%@WOtWYwt`4G#Y$a11@I5Ls zzs5UPogbRww4hfh7-0J3aBU227VI}F)6L&&@9{rI55ZHn9aQh@c{SvwrzET~J54+5 zc^KliiB+ESYXZZ`DaAtJH2m`F352NIB>z*h)uE2t{Kb9o_ZP3niH@Af&btd(7d#vw zCm3~=-y0hdacGR{+|b^NAj+kRLyaxj{^hXTh}C7VBeM4}8YClGz7d?MWCc+GF**qZuG!fjR(`$^TUfn_Lg zmT6qt(7Ufee^9P@D~0~7LuE-^-VI~|_S;B*Uz{iG@O(Vesdbw*o=X%qRp<6Kmb37_ za!;?exd!RcP6DPI5%XFWbLp9Lb_RdA5E+U5%&`HrAG?8;+tC%~%1Nn}C!kVXF}6-D zaIKzYzQW2@iiZc@<^Y$6*}m?tPS-s^kXNo?DKTv<(hz=EG`J2og6 zs@-YjPDDnvx;z?aT|KFzd#$x0o~HuI%buHgWo4M-IX*Z=<>|;jqZ9oxpy`4VIf_dz zhCJ;<>9n=BO;LYdTN|aeG@m)z{7EEW1y_#`3$4@HdiK0hnU$hP4@TJsbs3NR7}U50f_W#7NY)teE_pa)Rs!9-#V9ByQ!OK(8%sIZ(f!mNfB z(406&lCUEh`+}N^7jJUVx>NT%#QH|PXqbWO!y26*FavM;*nm@_9C9?78B00)xUjA zC|R=;rI=AGo)*dN{bgGbiA64zm#xdDSP8#6JIV2^)P!$H9@ zGp$c$k-)+4nVsgRe$RVGrLe<%c0A-JB%v*#o+cR;pL(*5OBfVlJAD{*&)M@}#*x{7 z-!edqEDQR*AB}->Lb%v%mGFp7tIzqpgzPqtCNBk;9Z(w&T`pFxDzAw~7~H;l?v>B~ z=!n@<(T93R-JK8E&VbsWJ~daF=R__xqgLm+KHiIpzW&&*ATlx{9xoomgC15w<$xs1 zJZcm;HVgM2!;R^mU#-=GWhpEP!&4c<`XMc#+prHS9c;s4lS`0pFW91m$m(|2+3Mjt zH*OTuCPIE|z6BQQ%g5S*kKI12^b2c369;W!G)uyh$<=&Y%RQ?-rq^~iwxbneG zq`iO)yl83QF{M^N#OZ-R)+4v;)|8DbYuZl%N>e&d{DspSziSa;M{SDQW~z{eF~Di2yYb-u|#BIZf!8W`qQkWXuu zj$9-YNLD($I^4{?b2NOczQc)ftXA`}|M09qs2TgsKL!r^bn$hkZe^n`!$B`C7J{F^# z(U%rhecD|i(vgw9(c{|DsR<|N^-w~E_RTPQh!zhGhi8raxf@wvj*X6dmthgv1JH8w ziVH165_Z8?w*g|0E<>FXjDr@q%VDz;Cvk;)?%O;40}6?sS<<9R1i_J#V#KU`IS%fF zroY~fgVDnncQ3bdtXw}@bH9nwY20e!h@4`~>j>NWmJ#s*3= z9mTGuHWUXLo>nxS*HLj0rZpP5^4xqi*1ySc+fj1xv5aieTX!CP$kXW!1*d^+6`W3C zSX)FAl5V!Ss9&zd-^ioL`Rr^XJqUrc_r0qyGd*@?!>b9EG<2cB#6;OJY zXZJ3E@O46LxPvA4HzRi#5^B&g%+>AlI(58mz@iC%K_gPL*cu^z-qYNfq?kD2D?5`- z?=#wWBrrLfJA)`fyX)1+8?Ub8u?2)ZhDBAgHlI^lTez`D`b7BDuXZ0`x7sLKX0f0t zNHKdOVxqTo(Ma$8(`wX@5jWZ%1Q!INaY_u9Jt^#=&Sagrn9K_JZCmmYs=Qjf8)_Gu zjf7|L3jZi}dKVBO%{>`Eu1zVsYRq_MR9N-KUQicPBDY$}E>-GeF(>Tso4aR521;1jqENrPY3(>cirX%W} z>=u7waVPQs+Q{DAYB(L#1M4Xtk}UWOj|$Wad&q*Q3srTt@wis zIUr1>ZQkMMsBgLYBTwu2fOrE07{5Xzft-f&WW>WslWVu(IF(KRupNwA5N#V$y_Uz=rylm%RHC=}?%WILh$9gmWpXO?^BE0tMYufW&_(Aej!f z{+{eqs{Ki4{zZsCCJC;Mxlg2_OT2bkIeuFr4YjxuGGhT+}N#ob8ZFhqdRUXs!{!AOSp|frhE0bA(fNVKuS4L#6 zsJ{Qj=Nz8%$hDj9{%b%*a1=ZSm+6Q@xv#eU$s`;RhtzIJG7bJ&!-S~*f&Empx2Z8H zd{T{MyW>Jzgq!P2jB#xittDYAWW8OOc}{D2Y@HMVk(!br$N%vZ|4cZPg`vZ|6-oEO zD%jr0r{KZt{XQiKe%`bBCc&D3HLQddl#gtv=;&t1!=MZIy_{TX6;zhAzS+jE2)pd# zy?BJZRKLiQd6-nDlKJnoCDH(_>+x+RBLO_wc&N0GE!lm9k9D z%khR%e}&aDY`-A)&a3BLIwjL5%>9k!*s&cY%&fVF9m}J8S@f>*dgzO7Aw!%0Uzm=f zua+bfH2vYVC!`NWCm(iE^yTZ|P`2$b%$>^4t(KIDIp zYapN_eJqYG>`p~(!jgH;F)xkY48+SuzZ<-X0i43J*41OD8qWSCAuraKE0>(HI&kzH zc4zE+*S&l!HNf=WC1DWDz@fZK7XYB?Bu4l_(JS@Z_E& zA&4(Jzm^j5w;}GuZ=ZkCu!r(2&(60vatSv@Cwa7LJQ^%Vcd`E}B_}>PV7mEOZC?x2 zCKT_C?+j?VD?^zpQkAmb%EaPt6G(}Uq!pv9m+Ze_*D6EbiIRhh zhO)Mux=+2h30hZhj3(<Jf0V;tJ?XAbb9L^2DP5NKquLA1-%piaN7?j^*&)?Id8 zlv1$%{xzi61DT5Nmr)V8@1TjV)(p)QEHM38KwBmn`$Lhkhv0^#rDVIP(Ei(Xnv)P*bqviJ}x&JO8<-;^GM0%uvdj{aa{%{$gJ%0Yi z^)x6=6MgV~^K@eEetJT4wJ{UUy^%+tO2$^!fxw|@_sCK2_y-znJ_U9O^UuVTm;mUF z+{s1y;KN567%#jp^g%;skM+o_U$dvkm=JinAK z%#5>V3vCDDuRS^Fj55z`XEr*&K{QrwYhkh1dns9QAL6XMm#rkNo1)tU2b{?3u@1XA zQhs+^Zdap=efX7?$2A#Tw5G$nO`dE{CIeh))H9u;!5sC^6ehL#j+s0XV0#wV}=&V&*S7LX_(MDD3qe)p1+mimd*o`pSL6F zO{LL9H}z$8hvHNbXGgJMJ@ue;<&9h?A{7=cZw^)t$g{$7WMQS6=e|#H)aZ*Bn9o%e zGS>wqN_VEYtm+<87l62E5!<7gD>Xi73H7fb-V0jcBXeE8R zCnSJVe|NfLTcoRr%>F|_RahP4|Ig4_nHc{ELs#*zHzj0{H?mT8wt;4lBV=Oyceho{ z($UG8kc)}szo|MQ8y5%H{}rBJ>1f*FjHLLk)SQlh1v#&D!$!eqG@J5lqmH?D_98TH zrf~iXAQTvVe7}25yG58ZkxCU*!IJla8P;j|SaE$Q(E+ltmpGGgGS4PB;=7$~qoN`R=hoNZN^}dW_S5s{=;xdZaqxJj*h09|#UaVH z@b4D)u3&*F1}@0Y!7^->jFTt~DzFQ6SMAl5DX=_IafE;7NTfqe474U%e@`rwI;2k< zmmSc#L2@4c#_OlNzh-A8pTnL;k~vP!22?sehVeVQ`l4c2c%(>2v$0AqKvfOV79_%@ z)LB<5Z|0v(&+Uc(UPf}UNZ#EF*<%PSuGz&tfug16ZY~KApT36V%LK)nUnn(W{^(sK z!oHo8-PcTs--C}y=D}j3U>YR(IeCD{94nM{QB(bRqocDddpJ+`SUgkM zpe#5Mp_bCjDI5kA6-WsvVoy`?0vkQmxhcQ95%fnd-+sYTxR=cO-~|#M>s;7uzUI0q zy3D%50wP|pK@&pEvjIPNkp=C-CJ^v6E6Ht6%yhZ1Nde+BX_&K)d~F6JSv?a8No12c zZBn|VBqkynqZkV^)MN<7A3|U86=EHZ>7s10ww zH=>GJQRcJ2xGUKC7PEu?STYidX+ zQFAt=vJ_s+32!~ugm=&ILTUvr<8{Z)8I!DS_mr$PfzllBg`YlG11>uqaZu4~s0b)ML_hlM_CSI74q-4?&v z75pfcjWOq*Oj&U+-qopLFTclz7<*^|zZZu>TQsBy9ixk}OiaMWpxN@T1gZzW zt46BE5EVH<0Uef$ur--s;X=vshx11X+wxAorRv{>p(9I4%4D||Kdt-CGH$vLlzSa% zzk;!%(@6f35Xtx$8SzIGZV6ahFn}sx0B(h?Tvj9kr!Rr2?l9DD?nO1m`V^9@dNK7) z@LrodDY}^xRw9xhg186MZ<6L1MsIGgsnbYQD6!i72`FT$fQav1pZG4~cHhg=d<%SC z^P#J;;n{N?&Hxsoo=!B%Pu+r@aK*ngDDR3LGMyfoc{40-x(p^bN*($B2C4dHXmbrF zjpwT?jpsqWpI2{i(~skL&-2J(pp!g7w+nvQY(;F`s3wRdrC*nzI#jvL<-~g(!O=7? zqUpI>DtG#fjf|PR6vx4FjaAmI{^!l4{in{Ohtt}v=LgWaa>Kj%Ijb|~al>H0z0t&} zPiCYyJ>7)x#@>={U@6YUT(l#oXgx03u~Jp?$gl8d{&nOrWf{9$=F*bB$O-+&6#0Zojkx5RY7LTK$1g>2eN1Y9 z>uH?FpGn7|z=ZDGCdaO*p^$fbHIuXBCF^AE_-Dh<{loCU=P#)gN4Rs$Wc-2+DHR!> z1u_=s3MsvheRc<2G(y1t!`3;)hytrycx>CYZQHhuJ+^Jz_RJpJwr$(C?>;xV$$dCY z+Q+^$ZJPD}Ykj$7=8$|O(pE>wXBB-UOk_1x1mDGLW0rw*UJy81)s~X{7)BLtIuf?+ z`GytABw$YN&c6*3PrPHs>Tk?X>gDHg@C2IH6-k>Ja zOk|Oo-VG~G58i4(QA-k*5qZKO!Vr5&OBY;m>j8WhN%EOQHJ6|koQtrGwQY!?u>nD( z^ay`UDVEoyUw^K0hduNt9qYo;pp=dSAGOC^NQxSu@oMnl3|6D@qHETfFwdy?)S--a z3K?v>?}{s+K`&{1$V#C?4Ts7!on%&lN>!7N|B>0ph_Sy;P_XCW9_KJg_vV~r-eoa8 zfuf{RmjDsrJP`)y3|FJk%y?#{m`mH@pPyo!4tE6e>B$L)y98fZ7!&wPzm=A;0>6&m zmqVNH3L*D#%tvDeR4MS!Wrb^H@IL9Aa}z7Va;xea2$D8@{XIGb-WAS{VjH5Oz6 zt$2`>38G--?_DF)XpE|6OK9%)Ce^4}5Q~%d2kq*RHA1$VLwjp@F@mQZ0sGW~E<6xV zpo=S-KmfIV>$pf82)@!#FoD!`QI!@X3__!VY3)3q)@PDV0H&BU41On`Nca~JQY}uy z(twwi;F%re?W}f%oZlpBbCEJ`dPhp8oWX?di{P~j8NopT7>8a7G1^SYD92G^DD}Cr4Fy0#!C~6?aeGg_tpZo@|e3VsdUqG6> z+LZY(9Erc+kmD>8tg!e!V!m9&Wcr`S(4qt&0tr+|zj$~9z(>V&$v*+?CQFqjIRRvz zmKl9+VT0laO+zqiQaLenEC5iOHPV)rlFsAlXb+|BmJ;ZWe}Tz{<_u$KR-6ww5E0Ih zN#CAX-4VbJLD4-u5u%aEOjyvJLI}-5{+>x+^mkETALUZjU1r30nfTa-Ch;|G|nS!nDJxiMY~ajbg+h5OT#kQ z1*g28&>-qEJP`-Ef3Ocda&kto-V(`=l7n-`WM9aejuA;28ByH`qQE+}F8&sY!!zj9 zTuXb*aGS2;fQ4jQpnVudqsjt>V%po4a`13uK%9CcmPBh$;*V1xTjRJvj57pemr*vZ zCHZCLiNhNK^#fMFw18LxKt}PT8N44Hc&1~4c41#oGZ$DSF47LXMF~1??J4o3Ow*MN z;2^yS#o+w%m-$|H8p`he7$RWplZV&&DzVXclytcmNGV?J=|o#Vr5xIypd!d41JlWo z2}?G?m5BX(V&PnbYH97zP<_TmBiK=(C4qkzG9!Ke(iCnuue3?C@i;Yg(M?Ir`=|nk zj4P-Pk2W<)%~cjm3<1wy2;NNep4s}WNOY}OQx>Tf7s21;1(y+XD58pHLjVj}_Fxad zyOb>;+x3PX#t3)F8gR709VXn0jba{)BJ{KouCA-N`s~Ep-;R5C1*Sgyw3xLCNQP*a z6|wnk&l(?@yE1WbY2GFY60 z@lC*B0SvfiG%-+=-wAlBk7TzNkO&hE&4`Vp9<5XJ5vR%40va?K6M3u_jrN0RtVW~6 zN}Id(-dhO@yf&hf9!B2Ojpj;%M~aQf`g2{e=`+zG6cb2&RoD>1vPs(-J_6;;bm~)K zTls}0A$?pw!sKle#|n~CF1IgvJjmR%X0tmHgakfq8tUKhGovT~V>}^USkFgS%nlts zuH9RmCpWyR*e!Zc)_L?X)N%5y;mMrK(AsJkb42#Qg&awE-l# zL?R}4%J+98wZJOmHHUrxOi=wu23j*Y0wJ-B{F2DARALF;gjzxbG4f&&6gkrMiPQ#v z(SpN{sZKIY$PfA^rwjFdvNB@2y)#COV)b%DkT?Ep5>gdb=2`-_IW3;$$)$56?Ewql z-K9_@kK!%4E&CiO6T=sDoqg=1Muwq?Rhp z<_2|GV&eINuD=Gtpys!VQO5L^1h!YapfhB1gAA|=sEpPmN;PUoH%7kef(LN+m`Ht&ws8J-J&aFMq@^(B}^04r_50TKR65he}NIZ;XEp9>{hlk1Gct z%4a3`XCkPiN^VtJk18lp7v>zTl#0T=L=~wS64P<)P|f@Jh?Q5Aiz-ZNVj@~2jfvL1 zBifxTq1NzN`e2TX%!m>;!ewNpM%iOhP=A|XaIzP61dQ+%DslBi6+kGz8ynG*1|TgH zz+Qg%U{v{j)VR+}9xEKkS{RL4O3W%~sAs~8SDg&ME1c31fDR6tb;hH0SLR36lEkN# zPT!}A;fQ7`Z9;SFM0>9SCsb?Jd3ZF^C8EndQsbD(vnt_~TiRG>;?v*E=gXgr1)}{X zRiPYGLs*82+F2&=lGIkKk^_UO3jIAsd!_43VJ>7DMP_B9i{Vo7g&7KdbWg@|0Sl#+ z3>hp!K_jY(WP$?5!FLikl+L>p#=6=|&I_3Yqzek|Pp)Y?u!MrO$jiiH74xo-ucz?t zxj+8Xc|sot*Op8BH&D99Uz0SZ&PuP z7gdknIq0m9`?o2MA7A14oSY8IiJ(9Oj3`|&i_6$Odl-w0OAnkSlt;QVQY3^{ohs>F ze7+{t{MW1fa5epXaONc_vZ4rL3)Wn{31-_`(G3 z&t9&tD7M3yVeF;MCyP+A5G&$D-} z{{kS8YDbdK8185VJn#$yOyyh{1-UM9@E;!>g`T zDCoDRKFJ2cRT)fcq6de^B%({Zc9O%afI_bkw232(aZeK_)9l`x7eBwxcbvVMvSf}~ zmrjd_Js%#){N;o-zT%VLnjWxFuHqu{6MzuY!ZP#iom^{2bNI!15B zl}~!+x3P10E=E7WpO`~pVq5pkdo6t5+}XHrZnt@N_^+_FeBD;?yH6loioBG`63X&f z;lz}EYoE(*Y+Kj2FK^u7J7~M$zN}uGyjFN`^_;o4ZC@L_mcMtpuf?`UZEH8PaByS( zVX$`%D{h=#J!F1=m)-K*pl-apn13{9OHVpUd7RoA_tR8ujqxIu~!6exp)(aQ&{$wyz8}Ubn9% zi@7gCLz)@W9T zTy9oZ>*FKUz^h%f8R|IgwGQ&AzfU1)mi^IDB~=ux7Froj8S~AKeWPdBJZ2mH{CwP< zqlK9o3CsJSKa~GQFm8k!>FsfU+~ae4T|ZRC&}KfZkzTb(=$4A|HPmcN9nKosvoX3o zyF2n%Ju&9TR`q<$SOUg!01HJ=z|V0JNkgIk`pYbx z&SNkp_)q*_teV^3Bz>zjZE?%(?(X~sd#h#GT#58G8Lh27#y-4N-@CPm>BaJ_AB9l# zOzbm7a9fxTg{VQl)F^g za~^+r8%Nd8Ib)CHko|+^=80Ho&iWHah6frGIEPZBhFy_C2#5xiVGb zNFRqqIw|O+sM%kLp1y3R*)LkH&9ilo>1`yUXo$)m3*98Vzlc9`cm*-+XG45>_OBwK z=z8N@Xp3}BQi_E4DA?@yqnF6C)3sL--o!s zL_A|BN_eqftu-z5^Qn8@3?e63g))WprIUPApYx5^q12PE@geFbu)H&) z{rt2&9lt3xXzoZxKjq9d;*_`uLtJcO6Xsh^pN_(m=H1gUl%n}!8glAh`swc^x65P9 zwNpo99z)1aEnrob{YH{*fZ9#NbwD%;p>$tR4AnCSn9M6YC^~n35beO9r5Gt~GT_*e)nf5!pQN;yk%H;?mcNc`;^+XC}Z z`#dPRXWaK-!o`0Uu3Bkukaxx3+TH+i-jGs>g_ut|wng73*FJo$J?rgzGz{ttL{(s6n69FSD6Vrb+#4)n5Ff;$J zsQ(|u-`d&Kk$_&z+R)il#MIc%#1x8;56a2e(bUie%6%i|6;uIdqXjhb;O2$}#O>c$ z-Mfjgn%ld%xj_r`vWK`qzzOW+f8lFzy7^VTMOB?M{?M?RS_b8eNTlkns|c#k2oB#k04JcTC7YfCF)%VR{Wk-M$<-TyHZs3Q;lyhUPp*uP4Q3z3gUcH;5bp-b%s{>% zlHKaS$J#c4(lr66aCoM&d1Pb&(8$PcenGf69s!1;x2j|SA7B75!M&K#IUE(i#pTVZ zp{4i4^M1WS6fzWm)7#rQ&wu2=AvQBOwKFi*fsbPRQ_WoQab=^e0sq30shJ7P{!$7K zn?r(dJuonJbapahthY08aA-p)ECOy-`=5w{)!GREhi{$?@Wv@%V=HgGUAi9`B|fx z2>@^-BO{|jqxVfg8k`s!jlca1FOwHUFdOV`Q(030zxQ+u)hRrzJe%J_x$+v;sh0T)O+7xtY3DDCzA z`IP(>HY|mEY03Q!{`DD-cFerEph|4|E&b9j3l9$h@5{PH=Pv1=s^`?d=Q1&8m+2CVQ+ z?8i&yN|qF-KlPiJws)KS>$mY+Iq_Th^?NIVRMXPp_gV3SdiQ(C-q6_a{N*+jma7|p z-${6TS5Nrz%dWC`r4LPOXZGj#&#Pbef`tQT?&ysbjm6uhFrI@3i@S;RZkI$GjzYqZz+Gcr-e{zBn^KFu!=mZ(!ee z$4_A2Ci~w*Z+;1nFTj7x&wrM0*kAD?vYMG0{MonNxbZOm-=N>083yJ@2Ic^5J$r_I z*cMxe8~1YL5x274EE7XvoQ}x0fcY)dQ5S9nIFw_rE;HI_9i*F#%{cEZA#OuTFT3XX z0iy=SwI|8Aqkb*h3x5{&or1>x|aHN=80zL6it3w|kZ|>a(0uhFRSiwu?tz8ssA%H1eVu>0eGE8V#2{=P zN#Mrxspcu2O-eaH(ZFd9cn7FoZwl?Sp^P6dZZx*8=M9$Z2YRbP>nNC4O_}R&xAKIKffMY1szKqLN@dimMl7@0qH z>!HLTEZW#sV4OR1l}=r9H(r*Ia$V2I09B6{%&x4j!l8EuYVd^^1aef>9G+0z*8phxHm_R~5D5~Z;Rx1XME?#^_!LsatqfdTRleg?+bO$F{zspx(n6uAtE*~R{J89m! zvtTLGDU?qp*h#&%GN5hVS@O7#!~}~8=WGu3YY6iA6r3#c!j*vScdN7^Cg0UcBY_4p zfagKBH5b6_o1WBETTSMX2Cny3gqSwVcVnRFfIACL(ZY*YwWar^c7Ff_YCCRqD}{#> zomM1D=9Q3rD@0Of`$nOuBp%C{;jayjP`$O84;|*n(XCk{z8hiI+p%OlO)(u0@&*^Q zUuCRrG~&Ho442s@FCi^5$`gMulu&Btk9zMSsnCu%XKWTBn7tO7XPSyQ6oC^S>|Jvd z&V9>_f;mi4pctegl<_4(F;7B&Ome^cD5Eq6&?xbZ9e(ah6G*M^+(+W;KDB?C7Wt%< z{YwDjs%}{&8<~e)8nRF)dXnja+b8wCBluH==;j81=g{^!)8wsXtle8$(xuQTvlm#(LKR@cgls+az#IqK(;zA~AArcBU`Txo z&ThF`W~9KFDc!Ii8B5copPTFX?$2Z^8c*baVkf`QW^HQtiaj!!fmF%E(-E?Ciy1;d zi-U8;!x;D%kYXlJL(5K3K-fUh*rN7Xz7tG*yY8N|VR1a*6?j+hs>ZfW*NQYZlb~G_ytED6I!OXJYROVABn+7M83XfZ`>hig z8dM7wPugg|(w&vOiYSKs5c7%&j6>Z0Sz+ZGF%Un#OpcqPSJPwnhei_F&>f6KM8!YI zBoFcgDD@xpJRK@QA>E-s2Y*&;kt>k71`v37Cwe)uVbBt+Vasar9_&G2sY>I8WIL*Z zRIA;v{=5i?4Pb$5Nt{_IpX!ayBI}%DiYO!yqCSmW+XST!LoBsm)G}-2AWbU3X3;#P zynF=b&HGU%9nWxFCTHGM0+S;yu~c?Cf2tG35k0SW#v;Lss)|qupy-)E+vw52PIB2;l6PnUqyv45=gnZz8DahqI#n-7muUulJ; zt3k3NGw9mLOj+=)3Kph<+7F#OP}O!SaM}ZQDR$Yk%v4!m0%_zNy$>Xc^abhnZN18v zuusP%zT(0Imzy4lEoB^BCK{FZYKcuxg!?>uA3-tTgPWQ=7}p)a~# zfwc~#ToKsKqZ>g$&KaO zHjjI$*ac+CnEy;=vDvQr4^+L*_e9`S1sJaI{W(wqk<`xxuR)a9@JfHR44OOBi&B*k=j&CHd9H{YJqjz8XV53WVw4(WVBu(o*~$b3yB`0y z#+$q2mjp}pcRdgv9=l`2I|oaSwq8(&Y3Y{}W|KyFLluX3Oi%%67sxl2w|h0DlZdYc zGJ<5!OiO9Aoj=~1&=21}*Ne7wlljememuou+{sAR0yK-X#asws#8kNN&fd&RYcuT1 z_%bLGD^6i&Oyj*SwO=|zZn&^`7QEBOk6)Yr6~Mfbo#3MZrEXX`y$d%*^jw(#66p*x zu)PoNPYW}dTBe9~=m!lRAM1QyM`EOkj*>w97ek*)U#_+MS2s^zwH85Y=n#rO1n9@X zn$RQ=+fAzr-|{t&&@}bnW-8;Oi*#to`&(HVAMhjb6dXi}rXULGVn1NG-a2EZH+g&* z!Aq3r?8)3*0Z6s(UcD32C6JmhCoC93Ice1GUm!a1Z18q}M@lUBx6e=Wg|ayO71q|!@D zb{-H;N}W{&GUkn;z6G}>>>vS67nO6>+Lnf`W8KHmYp^t6nt0oZ2WLoXH%X{e#X}<< zM!sr|qfN_-@lRX(*7o&2YIneDm6kbboUeY)NE@a69_=))%jIxoUv2&DjOkRlKt{yL zqF>RhoMab{#@aV4ng7u=*b9I&1_-Dzh#$GHwG{rm>BC1Rh~<@)hODOLNesO@o@dd20X^Na1P z5vl`RMNVz8AmV>KAl*K|w*k3+M-LAr|K<6=MVz89E3~y!MJ&sVJ4J3Q%;$QJt26G` zWG3G+eh)sA3UrzjO>aE|-TM2d?Bxdf5vMK};9yR(x#8&TS}K5!2vzLIHfbdS(r(#Rg-MqZ zA|^KpusGd$+#W+CikU5b%qn?3H9CPO(a!qfOMpC{h_c_~=AloEP}#2QK>YSKO)Q_M zvlUtSIWLM}OOd)m1L2NF=ZN`IfF4_Qa|r#oAQ17O?H<<~9g2YXbLwn@b?&Ft&MiGM^0a83D~3M^&P67Y7~xe~cj#A?|J z(xm&vJo5rj_>M%~;EWmNqFk*3g=2%(k&Z{999V$BPGO=;b#`&N>ouY=@$C z%jiTreEDAahtXN+k04>!P0F3!>#d3tzqA)4U)`TcPPDW zj4OT#->e_mpj^8#wt$aNXjbHwP?AKEN~-OYu`J{gdf7l+2az8R@HDKDg%3I#Io=KUG@j|?#U=bNhVKT z{Dq8xy|Zjt3{o1Wt!b9O!STL}%NU1&JZv!OzYnFyXTEleHoT%i5<@19i>(KVk;8eD zo}4ORLbrUNUl5mf_|YN}dU?j|*n-GGwx|zNa)HovAk!NA(HnATHinoo`9ma?Oc5s=!@AHX9hK7W4(k0!>t_zeZ7)SD*vYa7cNYgR3JpJQrtMgdd>!@xttZGV z@s$b9D~UV~Hsvc_7@6|}^yIa5qH&#rU}X<#Fvh!0PtPE}OLsP9wbVl%PH}zPUL-({ zn!uw=d354YavEn|iRWM67j!cIkM9^*jA66D4eD}Iyf)p_lRNJ2-BdF+J4cESk>P!Y z?C?v*ju%m^;fsWl3cF*+MnV&|>_Pbf3c+jtVgRYORY^0DLRZtYnIAm<(jtaml-7Y$ z1Gh8ulWMbGmQ=I}n$zSCee>sPL;B(g&f~aQbpxvd)fy#XP^D8xVdc`>cxr&=84&PB z->_SA^_kV5UH(Np&NGgueSrXpj|R_#XZh+O@fGv%N?scZ_wK`DY?&{F;H95Gf@F0k zFfm9J-VX#w2PGR&e_Xm!u?{@2K`Lq>Dw*TSDbsDh`IJf7y(ZhM24%=fV%MfnbpGaCHaP~O#Xnzw!Fyo#WD zR5jnIiAHp5TO-QF@>FQ?VL&^Ts94e>hvaru`kd)gnao`>jLkO6Zs<6nn0kUzAHtZ*3p;C z#C5Fig47&HrJLv~rWwBtZ>6T~?!_6H3z17tJ|c*>cyh7k=un?oKJh9lG*)n7^@PJ} zRw+JdvujyWj}?{}fKHNm(sm zP0}Xo>+MNV!NMpx{M{43V@k!YV=~2(%(N1Nl~HfVS>EVApN|wwsLTa}ke`uM<)0R= zJF^=&L=u!7}uEoGnNpkWD`qdm8rH@v`_;c zWT~z#V7v9qucyuEmve*N_No&rphs1+C$R}ZzM>Xbg>ve+fX%$`i}{>deM|r#dAmZW zo7=}!ytBzb0Hw>nwiw*DN^EobF`p6HSXzHyGg~81-*lGbsBl|LGE}R&{{r;R(%s`) zMqXe#%1wD0l;FKW$M(aF*~aq!1xQ@FsuxKc?~4q?C_Nh<0ZK=`Pmn&C8kVz{W|A9J zudC3)WuY^SEhf>#^^pET;lB5h6tB*1@9NCq5#Dj_(p49-7Rx6TW%m{rj@gkj_@mb% zu;PU-XLgX~5yIV5-{U`f`idSHeUAv420Z?WR-e*teXCo0&Qk@)H@fEGoeS;fdW8v& z49qiHE_cv8)~P?8z5)f&niu28iPR$uqbUxe+wkY+wcJ3M2YRb3;*=0GES)&!Owr5F z)=rIi6a-i2wf9rV6gmMIH<1|?4hE^82ickj5AFPCJWU_w+i3CU3FQ@1n6Eq8B4rko z;4G2v9eNCDxbl})GgH%Vzd8+0s)Tl8_T$=4&JNX`Cg1=y18`>XeD3W@)bL@r3xCo*eSSZpy=A&$4`!H#XCz ze4hR*>GWC^P7l$w@ggbjrW+qIO(;kH-t{9II{)Yu*!Q7y@v}41L(abVK&jIZ(meYl zLKz>?pWU?F-?m^TY8y5%;YiDaSRb|8oCXS4?(c(u(sMq#t2jmF2k-o7pFS|D<#Sio zzMx=^?2dGhX=K^o7e}>3v(51c=K6}3a|xHJ3r3;0hfc^PETi>9uS@6BH_}AQ5@Tqe zkGMBw>eRVvTBcY8Zyx;&i_cH2b|J zUh-_XJ!zm?7tWm|?l0Cwet((U2GxKWA?f2(EU;6ej|wiQ%l*)&hRs(qRBGnj~RORx`Umf zn!L*NNjVR^fo}7w-lPHSO|?Hgv*hPuSuWZ#1_uR>RqcfV5;jh6=>Dr6unNPj{t_xT zc2^PByPtfs{r88#q3P&1HksR_&2$P{#e+L?8+=lge~M#@1YpoL#0olvoeo>B&j42#XVgzaN(+Z$7EdvmLD`EC`~;SVUP03Zffn+ zPitv=>HzrA*n52q%$B!f=v-O3K0gh*fx6mF;!YuWpYEm>CRv|wnI#jxcN>s^^A}5MpkCoa za9$E|D9s{y?eiXn;L~A@(i`MwVkRpHMe7~%P}%CuzICf6?9RPIty_t^KjER$xv6-s zL~%lr93k+C$D=AfI# z9g0c?*r=){rpQhuB971K1|egs>a71!`Y)9$vP^-+pU?TFPf94(Fieu4rxr@DhQp5_ zZPXe>BeBY(5jI$3GAhTi_zlnTk;FV(Ec3xgVoLis`)>XOG;-S<;cKOy^CS~@-!e*A zt5+9#XqYiUJAayGGt)@CM!EtgLi$-T+$)$yfI`PR|EC*uLI zn?5IO*W=pt_Z|@IbS{yktJCbOeiBM&x8V1%`AhA_V%bc^!i4p^E zc-hpkxnmBeG05dyVTHkXj<;s1nZq#ATsN3BW{7gySe5cKa2uqFTw3BOVDFmiSR;a8*g|m0iZF&Pu$`<&GWa2 z;7$A16R^y!VHpa;?`C!UVCRU}ioPAMZ)T-7LHisKU4y0n>!B5-O}ItDobf`CZZ3Gs>}Aca=JD_-D-bM!5F#WKXUD8?#!Md2}k zKlI96^OA2R%lX6`$S7}M+7PVSS0vng)(k6ZazNydH73ZFy3@(RM%GsU;I|H8QhSfS za;DwN+Z6M3(4!bxJ#wP$fv2M*)yahRP5W+~)X0PnD1~5zo=zLHmdqWz{1#cv4uni% z0&o3MA=s3Z)-+c9v){fq2VS`}8)jN%keoZw-f3yy8OL|rnsTN*tzfF(d&t_7t#Qi2 zKXb1!v1l6@hOH&x%aJKyTxzwAIA8Z_cPakhr+AM|{%w=3ee*S>t%u)JCBi6p6wi;5 zZR4r+B0`r#Hsj3@%wlydB78mjP-#K^5V?;%;T4cJ+^px+Yv-FcHR^K}48lNOR%%4b z9W#Yz>lca13tSrnQZ(;xnuVuT$^}7Vfsh?}#2>IwqIN9eWooG2Sank<TvJW(`odzjjp zlwyaVo+ymQXCS`DBWY5>wT!geWOsMBo7*mr(77dw?)pqWGj>52+jLy_Cc1B-W6OX; z3LeU^cEhWJFb+YG111YW@fpPB->j9zx1>+$NS;i^_?6#_!kr zJTk^7U;+a;nYOo@(4x@PV^fFkpo2UA&g<2S=a=N7YzT7}=j=KHYjyZpE-P@!bV&cr z1>=24Df1tj9VF|)=SUod6%V!xO3$L9qsj}wy$8{_8nRM%Nx9ay!n@z{F)0Qi6RovX zfyt*!nyi?)B|MwGm<CaBR_=T={VU@8P1~IWm38XPH>QkD7~E z10O#<%XCVMSBE^tkn6)1*)hy397K>Z;5yQ&@0L<6qjxF-5?{$hxB#g}`Z8BY*v)dE z(tAXdxc+`_q#k{@a3rIU`h-)yh5TM-y=0+og(dKCn6W48y7fec3sbewGZRDCZmA7h zqty280c7gTc*LidK@KkDq*u~7&#Cbo@^xI`!W0;Em3oZTXk+ZTw(<=1D1~XY#oYmw z7Q++W3fD!ALYAXoq9#_Ju@*;Ch{owp18!S;8*bj;#<3O?BLbG7;@gnw%Xw2IP|76E zh^Kmh^C-c!L%Ld9*1SXFg!Pc|WhA}lThVd`c=hdI1B3G(kVZ>`bxOn%EEjimU%+a^ zA#00eS%9){k?ADlQ^^4YH}4&TE#)&{!&P|23r<_=%#6oM8O5Ob_d;>>_@4&Lg<`%4 zOAt9$^|=MZ&W3O9G#+?I4&|1X3xKzLWbtk_qN5A}TU!H0{RbLHX`;s|CS~+?BJOTU zXY0T2Zj^rrVHu|t2b%GfsOi1B*KmjANh1GtD}`OOboA|JOmWy0c!qSiu`z?bL)VBHZtL&Lk{cb z!M`)O*yqYHP&Hp(x{N~@Y2#e>7T4o z`{rH%H84u5xO7FESHo?zSHuCCbqUldn={yEcWz%@Vll{M@<{`mZfe3g0$a&3vQiFm5#((W zWoQYvT;Jk=4r{*-q|Kg-S6kY+5Ctn8Mjqup(}yhy1dKKb)Hai1?Y zS$lajeBe!0OGH^SUS_#Ji5M2gZj0Lxzds2Ao#2r|@{@2>T3gMa#hL+iyH2Db6I0OS zpc(?5o&}m^A|Tu9ifRqP(^tR})vC2Gjz;SPPV+@l)s5r;brM8&Wds%S9+xV8A~QJW zuxXUlLHkLf5>2MCaD)?GkZgS&Onx5GTMt)z!{5IRPnlLhays%#>B8t1ZF#OfH9iDu z5-8GuJ)MSfmrdrfx=tb%(_(#0@ePI$utC!3d<>*#b4B#zNu|tTKFIPSu6U(DMz#se zJ-aZD!5mi^PN|ss;|WT!DNGLBeYvuJ)buCiVhkY2F-!nqOFl@Q-hmQ1(;W{FMgQ^{ z+vNZQD1MuI&-)ORDK2eED(RAHJ9^{UL^RVSNgWL*sLG~-`jm{s$RTaVuo%Y6Db_;)BvIktw}+CiGsFt zdx*hn*a3tpbgO5I1Pf?Jtk$}SycMWqe9s1Hu9@yi0|ZJ4`XG>ALZtm=9EEa``!TT0 znHM#XT&x8BY>;RknSO_-s#shup<0kj1cNq?eTkBS3bnP10!gERu ztwNo6oXN2Bx4qpOkT1jSMni)9TO~S5l2N0dUDZ=rL(gj(p$I?qvv8>?5nPgNUf++1 zoMF42rMi9~d&YS4qpb*MaMGI zV;cDZMph#l<&U$YKg?^5D8ex-le;MNR=ZSd|^-m1D3P||H{n5T_C+2=LLMZJD%UiK%+6DY~$pPB_-$~C2)b> zu-A*?L#VslTC=oy^cmh;hy__ zkbG{W;3|HC88pGVIDKxrnGHrKcg`pRy|ha0H4hpAD>!adyfoU2=R2XHL6|?LPGS76 zC>LdfEAyTi`kwK~wFd4@0?lm&3)wovLKxNvUYz7Qeb*PskL#3uSllB0q9Yh1v6_ES z;JhR3DV(qz6K1y9F~Pc|E0<`JawZBTi~FiK;Hw#7vJi_tYH|~3U$|tF&#)cI@3Q29 zYpD>$`@SJgi^seWbHpFjBW^=F)~Ac$MR;K@HO=f~Md%RPCn&F!QQr$k00odC)=)Tc zNs`yX)Z$;%Di*!VcjFEksRyMZWaeAr9Rf)Dn+?74jIzhh-cl|(B+4=Q%NJ(Mn^HoCj)+Xx7^sI zM?&{|4bVlxX5Sy}H2Pp85u8k$)nVavQemU}jX%FWnomu_vOFKpiC{eiMJh<#+PQf) z!nD{gAJqUgf}I2zxPWr`u-Y&{h}bGAl`R&kJ`@V^d+Myy$~MKRK2NPIC8k*Bt8^3y zWf6mTbS++_5O&1o|8QgH^35X=(DLz@B>UiU>7yelkI`uqTZUc*O&_D%X0+@d*P9fT zpN*Nnm<``qLe*T~fNK~RCuK7Ex%t>83F#Fcc!u#W?;KAmxzG+KH;Ke8N#h_37~eyn zb5#KWk=7-6Jlnj<-8)mjytAQRCaIf~IqDz7;Di=r0g~Oq2bCtXdySR2J;0QvkN^kV z;_lLR-hsIM4`b&P97-4_*x02vfeVxg&myvdbdZ~+(i2lOe8B4Lgd-Bh67??h%>kFrPZZgj=OGurTi92aIqrt!`X{YhAzG9|gM$^BE&6E$%G6}K`rT{kZC7a;g@AFt7fIPc_!p7e@s zGT6Tq=DR&1_&;A$(?a6~n!rTi!CJLrVPlFUmL?yi2&$AQrd`n;!nnZm&vRQJnj2m& zBtt8<43nsrVs|ibcx5h91?hftal?LFm@$zArNjMbAKfq=NANeMz zb~`a$atvjR50w%tps7l%Nu)C?n77nJ*e>|!2`@g*7Nn%j$%|G76lS25E~@1QNzy)>IyFMzvTa?iV zbcCWcU8#tob$|lQNp5qR#7y)xviMCaYP#HrzzW4B8s? zW2CvbuBEYOC+T20Zp=;};+bGZqJ%?tA9oIRo+!V3Zj?xLIJIeu=mAA~^}{44d`4(| zWMCopF3e8PC#?ij^_O9r+*xunGo)lrI{x4XNPG5Wt0gEr3<8sfk7?Uq<8Ys%B`-xs~`%I1nKl%^$z+b#!$wtS7~{?ViBr zegB1aLiNw6MsO#zJpm17tl}CoFd&CWQNK@Ztp1kHwh=G%B>;ujoC>Sdt;StJzYXN* z<`FLTAeOuZEm789EL~5lm8wYI6m$J2sfv5$d6#jU4d%6+>3Rtnn{yUZQDF3hjuTG$ z%rE+G!gWd*1d)cAf%`!eq0|O?F~y+0z>LO z@_@{Uu*v%5sj>D%p9TJ=J1g~x+2%>NccJsGzn+{DguF$IJHu7tA4#=dEJ&HDNRhY2 zEWF6`n%o+(7bn-^6aKeXj%gHbo3qCpEMGuIIciFMmnPPt4QhrA~& z%@&*I|1KZa>E^W|)bcp%*w!=STOxI9=nd3J)Y1)f#9A{e-OQ$-#dg!rL- z>H^T?edV{>!JT(T$!KpV(Z$gjX9_H~9c^{c%S+k4P@^h_L4hp>26N@%<=*&Jy<0Y;hjS&1YxBE^>AI?JNj$`1sAy(igO-D0wNv zIE7@=qV$)v&J1%H1GTfiP8QdQ5y=#fTPCUkbNdJ#5GPe%#U4R-&9A1&LkT{lt7CWM z1XjWj2d0YoXGL>q&Z9Ec7MO36+RZM$;8X$ri}*s%s={;IPwp+&s!joA{&k*1C)V3m zL1LKlR-Px$xh>w{o$0&c! z+PSy8#UmEC8z}9r>o6)tv$kI<{Z)n+U9-mG)oa67%B%#epc=I2aB@kEje?9z=yY{a zyXM>}lbp4QSrz%f^hlcx zn`#?cchc?D$4z>*)+CZmVu!odCc{8y+J8Sso_Z*^C=|CBb7E~o{cm3 z$~)Z`X^?`YhfsVJ>>h+&C6AO&%HKOeT2gf+iJCtn{yvk@Gew5PyKCBsa!8E&D_KC4I zDw~M|3s;W`#L^zk9|`8^`%#7E?!!|>ceu)U0JYJpw-znywsAB>%{&$F)r@+>cyhZ~ z9EZL1Jw?s{UMWx5RuTb+sIge;+O}(zyecJTt+J&|&BYAEx$eN~-FC_Cj3u%IlMlWLMc&5@cn>Es3gI!C_EeCSbpqsL7F*B`&iRD@+uoUu^jq=ZpNBe0FO;uM; zIW-r1(Kspy5>Ks|eWrKZPn9V;-4qYwe4+XxPdQb)tvP}&tcK<~oN zL9h?2(gnZXeU^?(aXX`(?6hlmw)8crOp8{M5xjFvYWAwoEF_kJ7oT+nbM7G7_+RQ% zdShz$O+&X&L4lO9?S6πp)h2jxPuqUi$<7D4vH_E0(67{zK~brzMTij5Ww;ybNw`*VR?&GtZHk%0e6-<3&Fq0NO5AQc_4d-K=cokE$U@1l?LWzdXVB(s3nX6ilXjuDCg%0M029KUG03aCNdZZ&i4oO@7Ey10>gIKFlu9(ty)OgqKO0_VB4` zWmV&Mr6*_u;f0CHE4H;@&_3#ANCtP`4tXb2=JgA$d{KH9{_s<0M~am-aQ(f#$6Lt> zJt3MV#=ebtrj<^UlW#MtxJA>z*9f#k9Jmh?Pm>CXhNbo(APHnsrL95Cr z$*Rb5cZJHsCs9I+LT+`r^2{E-ZXRn{Sj@y^BBB2G_9{tDVWv|vZ)#1Bs2z(-VXQmG zCR@z*s5rQPNLApNC}w{rz6e7cD`gt#gMLI6;_4NtijvE;25|VSMfMfvvShG4o2Rj5 z$Rr3=-#g(XiSSXKPBu2j6jar0o(Q!77>t=*8;=|f(qqXDYOPPd=yA>wfVH4bqL?I9 z5Bm3z=Kpj=OFQ##-&mHWeYu{U<{ZjeDJ$fK=Cb?p3py;^vU1Zm=(&r4g9yAo&Mu6| zl*|5L%0;fUL_r`Of~vEe2Zd`_UV@v5PFBB@SuyCh3_}AN8J9pRFSupp-HZ}+4hczU z-Fk=@E+Hb&lH(}Rh8q;i;}y>+oH-@Ho)Lqjilk*-aubSFQzxORwp{INsw1!d>bZG} zryhu^)hm5o(W>{JXx7fl^A#*s%TM||$_Ge>YvB2M2H$?&3d>NXy9L8fvo)f@M@iB) za2ti)$N%6+C1ABcX>AgA&ZTdOG!_XW7es6BK|$r?dPTZWG2rAUT!%lre**MOMGgYN z)G7BPR{dci)k7PL!59)S33U;8kE-SX;I;M9oD`=3efCza7A!YdUApLxN&l*QqqHL` zc|ZfL_~%`rGRsfiInORVZuDoFb}ioQ_X843FI7rxU}}h2jIZO{hA$K0*2Z+6$ka@ZA4x#ldHYxp_ zg4UXsmqnWBV?-;ZFo|Wd%j@Q3{tZZ~b-RJ|JJ$N3Xj~`VQU^oT9WHh&NR;Hu;94r4 zv+Z{UkU_v@xrFY0w>Qnq4+DQxD6Xg7vDDJ=S-n{q>V`1xGUEG3b5nHYZL|9RDC4m; z1&H0bnv7cuDB;Xpq+ou=45&tIqJ*Ngv6RKR>Z=7VCM_W=0zuNnmBjty`+vPrj1?%p z7S3g=I-1Wc7d62MK?*ZRq|m~ZdMrxgsM$`9hV?p+;=YgfZyc=7(5a#dmNEoKP$U+f zl*7GFrJ2{hO@FPA{&Ds6^^HIC@U%uw*$K7RY-W0RHd1aIgdpRgoH;-vk*)+4nJP0o z@!%jO57pg7PESngDgH|qQ`_X-tQ(~p*&2ExDk5o}f&G&hmI(3*hokhhpe3HdVF&cM z7)X_K=`=luFU_A|zj`Uttkarno-*(En!p=c_n{`S`u!p5B`kXapm3EsAQ*K^X|=d%Pl{2t$Op}N@RP*(m^{QGjI+L7)3Qxw5I(i26wPdFqtC3>0N%(vw=nn z1&yLn8Z%jJ?IA>W**Y>zgve{epLhX__hWX z_}tw8;U@Ss6|gY>>W2THw}26!ou29c8;AdExtD{U`F|}Rj{Yt8CS9SjQWM~B;RuB; z&Qah9xk|te0tij@(K|_?oM%u4Q=ZVXr z1JORg1CtOVM|C7p1j@U*tV6K#4^E;0AcFx67y0cg1OxyO2ndY(Vi3kD02tS?P2uKE z!_V>e<>$0rNm{3dViWP-(Z9A)2eqjUvU3a^ zkk4uBy-*Ax$dBu^d_j7xY^1ddg6H0~-318T;QA!hzd54Sg9&wa6A+m2&D;#P`yp}+ zDgY=52nhHiXaG^h@@Ui(zq(&TGYscna-S?bhbm51@ai*EhH7 zdSnt8(Dmsf_AU1t3O&QpBHfbrGxDz2IU)i=mmeUvj@(aHTnPaHL=p;U=mt*U2j_SP z?UwG|x5z_pb!Qmzn~V_R+7CeddwB2q{(E@v z3Bln7@SBgW4=?qnxBUm_=!fDP>wekXwWd-l+M-0{_u>JkZ+Kz2Pr>wJiPIQyz zH{UBQo$p)Sz`BTgeDvI_fdJ*ziVI~o+KG4q9B~UB@ktWuUNPX6|Lj4JJakqo@UBXA z?a(%`E5{Q=cKH(NctS${%Gc3Z9oV+nO_}2g`%xIMO|#^CqU*IY$lwruzLDQ~J17vVKfpkM zKy$wQ`hI=~e0k*j0MGE`fCzS9;7K45ZC~I(H-v*ffH#Ch-+&?jKx4jrofTc*eLsZI zcY=gBIRSi3?yg8b1HRih$a`%moaY18WpiF;=54}}wF0GW;Esd#wa+{YxW z%|Su*ydJ`(f+{Ci!y3Wq@Y?vSvxaYX-KsDZnyF`BH^IUy;3*UC^LmzNP8%B_*BPbi zzXW~HOZdFSx(txXYVUKo+)vaA6xUT4#8JZoHcOH@1AW-RiU*3pPR|ummq0Um>_#V9 zE$ld)qzw~(S^mF$Do}3y;hP;9U6T~I*;I@oV?}YFzVSRdVQ~SXdLBkzv)QxdbZ6_` zwinK;;O41%4jGb!9`fFsr=nW1b9W(qDHwZi783;6{H?aZ6}S6m1x!q-kNmqxC z{X9cVa!t}V#5JZg&ABHSntvCt{%Q1*{YI%ob{6O8EZHn;gJnqAi?m-58>COy@Jd0# zbt#89Ir+9Qmi%jub=8WnNp^ve>JY`=UU#W33Yen0f)knCNz0DK9n@W2e|h!$69EUI zHU)J@(f&C&@187Y4<}=2x~LW#oUCZ$j6x+19~zui(jNU(SKbP6x>Bc%g0xW{#aU@%FM#|x#WmDzb z7Y#{1ZpBk%ILM)QN=oa%Of?0psAF5JX`Nyf(t_Tb7Ey*lsdNqH-V?@31Zgu-h#@Bu zF!Hl&SOo;7;Yb6pU?PBH9XT*XFPP^+BdTC&;@qh*MG+pVfG^KP0u7M=>cow47Tz5d3f z>y%7H)N>^CngzI}2Z=eO%4erSvKa)?rC){f5{5uIIO`Z=v_Il(me^EGEPEkgREA zuuU28d?{ktZYH5>itz(D-Bpzxop>I9Vp1DP6;KdEd=?5mpz0{*61nE;}=>&Y!j4C z2B*y7hU$R&vg|p1%Z^V3KD!;h{pWz)6b!FFXnV3=x50vs6GYdAJRC8vDLhWnmCd&f z{QSO;@bC-ei9vxI70F}WZG;xKz4E3u+9gdo#bI-IH}~^H|K=fy&e%?#1;FJc5f8Yn zO@HOy2;=e4f??5OCmSWBWgY{stRCZJtVX6ty3gibSvzIvW0Cm?v+#0k@OI>a)kjyS zx_NuM-5qkKEfl^7uzz)YDg=0kkjzJmmWfYr+lw#3845esxP>d-MT5v>)p!CS7g$M@ zvv8mlly!qjRt%jJs^Hn?nD7tZT977;B^J)1uTa%5e)Vq2MrTxeNFq96yT%J1NPSm7 ziGvcP<%$;#SI?j55e@Jvm)^N6!26I5VJ|D@WoB;DjO z^@1B~jgXJ{pubI;AOqQ$tO=W?iL|W2RI|i}(v6i_mENz;#1XZgrRgv%(MAc^`Cj3X znmF5_ch&*Z;yqKI6+SHl-|UC+rMt=Z4nBcb(;H{b_&1M79x{qHvrWvZEmvtrEcSL zYs7WGjz$JK9*HtBSlkBg&F7)A4K)slk$@?4(Jh zx!zPBE@*vbI|Fs(pNYi;b_lG$tg^c3?8D8gCRV1Q7%p8S=239bf7qII56``S-%2V% zkAso$j~hzCwyK}^cRDU@soi0(35H8u+(s>$5JE89)4!EkuU`e2G|Ir%(bE9e(}6_z zuuQnUSj&QwQhXMYDl<;TL2MpD3~)3Iu&Hpl1$m9;4D+>XooS>LO~+4$g*Pi-9I4YY!K5TAHfAY*6e0QbBS4EiboA7n z?7d~Me!}!8|4@e;3&hnn9)jD+CI*Ir!vt-0kKj^uRbM{MXh-)H1K{8w)4!m?G29yT zGOT)~1(=cgZdmO4#mKWk%&8kYsdxIVN&eO~LR;iW6C!LA+O$hxpTfRK`Qke$StoE_ z9!#6=Bo4^M`gFI4$eM=|v<`jc__AHA^Px4v_TNXcKk?>#Mdh>~mgEzz{fcX!o2=5W z6|i_1^X{t#6dpbEcAkiyXXHIvkemw|IdCU3s$#K73{T2kEMeFl)2wqPN(II#+Ry&z%vZtaVkWPh*XqUO zXG8~7c*|xl}Sn18`(K=Gm*^Ynnz@GBAJi%O-uvfv;XH8al$PQ+duo_A&o zS!E>a+Z;zmD2~fpfpd4pU*jAdbyPTf{22c zEHcd6JvpD&JrdA_U``$bL*$+xsn|qeu1G>GqN|X?ZO}Yfvo1%KlLpE4ka0k~i%cUo zz>nIF)TQ7p&xhYDu3a4on~(Ey<{a#|Oh3!444GdBFIV2)M&zLCszt+17(}7@u=C?G zaSeTN&ol2nCskL-vZL3Rv@-4p1A_k)YUbbnadLe#oH2^~3eFg2`7q-?8DvTg4AJQr#c~gE zV30p>H}}#X&M6wPOtVmO2ghV`O5p~+EYOnY>8VZvsP#C72dh3G5IrJ+!@i{S)~5WFb!>F3$EK1zCJ-P zHhFd?ZF#De;wQtSyzj&I#Co-=DLoMOmHjG_^?W{=KR3iB5@v)qWY=LoyLnfoT$UR6FmhFyQg%a+{9Ti(xitmJ~JHOypa;DyI3-y`R#ba9}r}<%m z)4^4^^0;%sBqv)*U1-#-8EQkCHb9n;M5odcG!)NENt(@ViOU;1?@S*rpt>7!l*{mG zB5_M6Z16<1^Vf0S^rWRUNlOB;qNbuP64XiLj<;^4LCPxvo#sJ?Wz2v=`_q>gFU%%+ zBhHkl{ok|~iZa4FC~|-RZv;T9^Q#Kf|CH5!OG-lk=v^R90#cg{Lm{9HM&Q|Qh#dQ&HPw#3P!Fo3o zQHtHJKK0Co+D7lmR*pB1WH`U;aewV7z>-U~-5?^xD0(XeEN=m~#Gd{W0}bLJF@z-Xeno zf0ofl*$@utX$Yh=G4Wm5pdS8%95L4_JyTfvY0-xr%^hT$BczS{h8i6CwC&0MTzSGMtSug$x+nr7V7_9{JARYQ)L9gpC z5PBO6jA)qs`PCu1t{7JPt3lt{S%ewe8>o0vFK97D(R5V3mVJV zyse0G;B7W5W3`D8zc*JXw>QJz5XVN#o4*FWBT<-yO6@Uf6x(2dz167@s&uX&OqSxS z)f=lC`v-*gp7{?2+45TeE7v6bvZTYNhEteOKI|giEzH=@S%+DwAcDH4Y+=p#-bLv~ z*qvLQ-$oBQibY_-IvdQE%9=7P%m;&k`wOMS;%5+t@b}#hgmG)d-B(x8nfEVJX*qO0 zG1_7t-8+Obo|THcrW1@UvU-A)QV$N9BxVdMX!8M+V`AnpxXL7G5eI-qsKW__o@ZUFBHWL)I|;}Hu-pb2*)iv59v*M5n)vZ*`+u< zPgHv}gxAnysUtM)qM5$c>LmDUnK|Ucw*&w~u#gE2FWu-?R~C;XRYvO#raX$bZn7f- zI8gD1oY4;TfCk+0}ee z+#L|}CASnzj;{<(0#-cI<~E3yH)NkoBDJl^auK7B=#}G3`$Czoz;jj|scLnwEUUEc zC6Ftd+Ff_Mr`!(N`^5C#8DZ3HUX73IhpGDL!>fG&b$PVQ^GhMJ9F~An30#=dLL$Q8 zln|ii1=U-J$Xxf8_4mBF*`yps3dh;5diBRp$lb863SD?2*_wn2^rGI4esi%kz6<_2 zk=x%?d-*LNbck^QI$CnpGm-UG_yBZV)Uhs>WA;Af8He$O6!F7yeU&*nJ*QP@;KGx} zA~Tdur0T>0tya~sXCQFSlS)XBN@>GfYjNyMO5qkq{j#tjo0eS6{=G$3whAC9BrFc3 zzTDM2t;z`HcT*WB*Q4dLsgN^$C04bas=^sI)jvzq(jbnk9LMFxqcInG z(~Jc0%?<-$mv<3sP?2R6AIDbF!CnZ)B-`$U z1Rzj{es(boxzN_F1C1%?;z~Tqt7y;>E6z`5Mr}7Hj|pvGsj~j*)d+lqC_&mE z&uy5{YD2*88YXMg>%CrURx}Mu69wLRbQF{PxBWsxi3x#M!{a5~p{wiK3{jg)9{ppU z%O>^JT$OjmgIF0Y*KRkhi8HrR8)}}vlXY+ZiRT-2Fcq|8`wCNPObaQXgAS_D)x%#j z<_5Nkjbt|yJ$x6O_d(+9>G?>aRTIwsCr=w0^h8DncVj2eP}=wQdO{RMdd#z?kKW9I z8pUgG72bUW6i64r)>an1>P~d?ptxdc3@84OzwDaVHbAd=lnb?EYn!k$l5ZcBF}411 zw`X!m8&~eSQHf=}sosBS+P3Zf9Ev@T!J250S=s~pB9EfHE%P~KxfcTOH~%YjAwEeZ zo$Ch&ddnoSF1liOfasI1*r)fiwBP4+4?o?d*rGJst?NXx<*^L&uaF*|aV~Q8b*Y+1 zrH+sOBbvSYhB%7GF}2l1`vpi4kaW0V=rAI$$G0&6t5LsHW5(x(Xr=OJm2R_(FOWP&~OBOY*5Sg@ua^`l7Y zPHUFyOYQ(agWT6}=V8e_CeStOI;xqXkA4{qd`M~U<>7Ez!P zOZ-Zf7Nzxpj)ZNVHavr`L!_`rQV$}F^m{{fTw$%8%QZvWeY^7!J2~>~NNQ!FA;y{F zRp9h1Vm!xYJg((Fd^JYy2%X+@L^#$(qO5b9YDh1iAJSh%4t6Wt$&C399r_AJBs0{< zVV6lI3KQ@Tt=5OqG{-Dr#daRQ8A@KnRk1PU?H-$F7 zRb26@WMugKPiQOLbZiC^4G*tK2`QO+SZR;Dq|lia>U7{x_lYcc9VV@W(H0@@E#@qR z4u2Uq&Ks4D3=vi$3DY`ZAjlDy4hnpB7TK!B-cGD&vTJ3Yh55vh?PMNSfcdcJ>q&y% zto%Jva)|!K?dGRQkb-)ns#jBSC)D#Ak=(j^Emv-F_!@_EUnRbJ99X_bOF8eT$Z4^& zvDrBWbS{!A{f4^R!)GJ;3mQ%(2PU?-($X)Thl3TX$RRrAN;@J_(qbX-q(rERE{O9Y zLR?~|#9;%5BWCT#`3A8_jYo{L;WhnM`D9Ywc0~Uo$l8;vmfmrX(U$82Eb}sx`UfZU zg+;R=jTSR;NmZM~?6Ge+PXM&(k(}P$o{|3Am1B7+_D93R7tWLzl#L5+WEfeNn64Gy z`H5y2?fE7ybubiljf0~CB+ZyW>YmGi)@^N?WQfOZs^5(33NL`~Eg}x%u%hNxZsar- z;i2>fvAqD4dVNm?I;(g zDABmn3Ws6G2`)&%+xK(a+c@`D%$`-(WCC?p`Vcooi;9$?TZ(ck@buC-=*m9AY2e~M z{O&;{6k@Tr#_8rt9 zWdhQXvJ@cF3(|dW^eXDbog2(i`G`5q7V?)QSk|lRj_fFv9q5ug2OS11Y4n6WbB*tx zts-W!%4xxdV6gnICy8bnE!&^MUxOS&d%~r*)ebiO3Tz=PPu|6wPzc zp-*`0H=?s$g*cx4PRg3V9Mq65@ElAv5jAr&t& zlAQW?7mdU$3b zCDs;_iE6{$+Z|VqH(qP25yjFz41yCC!v`V2!NLnDZOS+c*t6W|1&VT}S| zowr-(VQS~dk8bj#Wp)sePm;h9Pc|y)yuE}eGAf1fN!IE41x#O_-*h3`MSa9)AckIO zij_o$ysvfpktH6}KWYlv8WaZAEiK%eiJ6SNeXPXXiOSRQ2MY6mJsiUzH_;tY;Zjz& zUq8~!Bl;UH?|gP^H=GrK%~goAaAf6KnwGct>o`RjThrYGz_qno49#X=UL`7q+cdf& zX~95{dTA6Tt4BYAOdIs+DyfYTkd*c7fCdoeXZChE15a4pc77OoiI3>ePjs|?+o}g; zz-DR_b(mgbjM2$*3|sQQlnCA}CS}4OBB)}Zc+r*TOoz-Zp~(TS5pvDDVomCCEz|X> zK{c5JY4&^fIV!x(h*$yjD1ufUH0{7wVP#xa1GGyRJM9FXVt{3oewg~D*iSxphh%p% zdW+R|vmW2+!zX>X3=$;wdE&nn6(yyF3cVb3%{yl0sq_-=z~GZc2l5XmFHTEsb@9yD zY-^?BN@FD8GI=+b*saN)GrsdQ-&Gm`1yJqBWY0425hjh`bYhV>yb*0B+7G%w=aufX zY2&)eTq`Ek$U5B@9txIsoZ83XGzdwMSb_X81t& z-(pTB|5hg!e){gh_LIC%1nJ1@*RmmD_-etNn)}M_S(TaUqQ`uGu1nvT*ywpWj#I_P zMQ8ijgPKXa7245J{+*6PVMdel7b-Emu~asVm>yxL^dCYc`%{;Qh+FZ|^J-MuEj#C4 zx2n7UMjZU4XprvFspH?)UV(hpVC`F;m&;Hz$r3Ygxw^7NnJ$kWqU6nR3>{8k@JAhf z>>-XC*nOl>6T|ogTtUK1M`XCTBKkFhk4h@0&$bF!fq)Oafrz~QcDd8`VP_F*&E1Q# ztTrX3CZmZv)V!f!^ZAq z8sRdaKazDu!Kj_FAbL-u^J4yxNm>GCg({@v@~vfs8TOlk*%31|Bp|hvZ=(=Rn2_46 zf|pWQZk%p&?wLy$C+UT`f@qe7A>C#kL>tM*O^xHLhFB&IMK^mLV)9k6wyb@M?4|di zeU>TqWm%X*_a59~!#HnhwxKkSw|eF3@;<%oHz3o;%YkVyUX#?w$ITojJ#zUzBU{2B zt;SZ*EIV)K>VNFiQZMPnbNjP6n_7EwPw!9-c|5q?s1-Z=-P9t^lV98%JGe5}9Huw@ znxiK2;AUvD0P_+Zo`Y?D=`R2M?R_y5uWpQ54#>7g6vJca64+fV(*213aY>3AP`%X-?^)iQ=E=~e9~X&- zniAQhf7HXk45t{h{?xs_V_@96tmj4OpVP$0b zPoRf`g^A%m&i*UV!$8l%&iubEk2HfSA+KYy{*|H(aDs(R5Gr+o*&={|q3@fc7jhL3 zT`0#FcV$ahfL)*wFI~9Z<2cE2y#D%W?y;TLVES-(lZFID+xlt}MNA3VmnI=JR{ znI#B7VN4T;@0XaEnVpyjotUEo4b>X_NitHj;?F*q2lp)a!x-lf;kEUE6%4STr&`9rpN^Bas|W9|zaYiI?!hiZQ@tB& z{_O}tpUwd67ZC7S<=X~Ke2G6J$5h9|j{(yfu*ze?47>rvj5C#o&^GEDtoNrrU=Sym zoqcn2bG6@v-UZxrQgx~dfQ@_;Di6?KAWNIz*l#BYkW!CpEO%;^;S5kiMQ%0MK^h#o z4Qmwx$PIZ_a2o%)P7EH+(=m)`mw|&HsR%^QIcW9Ayy~$OkZQMf9l-Ch@0aH}`sH~R zzu`^m($fR8iB`9PEo>p{{MH2lDjFm&?OfTZ0IY1kHxR6#9o-(mI|K4t^!|wj^4Y+F zjY*aP_r-$z6o4~1hHwt(U(%Od*+yXZ4sxrgk8EpA^v}Qq5a+=Q}dVTx!xbkw}y9i@b@eFVRT2<|0Ze->I3Y`%E|)L`UD6=0@$}P z8NTD{N(m)8geSReeU0~zO)U&0>f4V883MNebpPys4Di<`0BCE39vZ#aiTDvscg|oQ0OYJ`(@9e`{5nS7|=eYb?Q9`>vp`;R;%BOYt zsRZrskG&w!w|!&Zx8lcjk;&mZl1rmr#4)G=3(i#k;t>BaA2x*3EaMTL1_b;1+UNGL zcleIIw!fIN!qr7tH5~kw6TnS9?|qn9&E!b?+2*Cy;RRS-!?^T+Tm2Cmg1!afttsai z`igx6v#Zci6ph{g5>K!ux0>)n``h1~`CLj4MV1;n2C!3P8go!AlgL+Z;zM{vU;Ea*WoQ`u zzgJIu1#|$wFLiJ4CT{t5eU;~?hS%Qiyx$Dx@FqX-K1U6~{M&@4=ub?rr-A~jD+4rX zsffomS9@aZ?sgw@M6(JnY$oE`Y%0Me!?m*QPlRVAz0%hsx-^D24k+EqTIY!ln;10i zWTKG?vntI6n(4Rno^S_|y0-%<+U=|a*aq0oH^fkv+Ie- z2Ik~kZgX(Q^aj?vZIqxCs{Q%fl73?a7MJ>~fiiZxBu)^S6D0v+aWC=PQlh>KX zhC8>pbcZ4!w53QkwubGMxMx?rlkW=?W0mHOVCW@!*C>R%9%3kNyGYpm#*tZzC`75U zAlI?ElKHlxz|7MOUqC~V=yO;*?tpFVS2Qvj`ZkOJa)S!ZD$r<>gqKIlMHqTLQtb>x z_{_}@ruIEUv#MPX^iuyG%iE^+;PVkPuWPQ|Nhc`qBO$@fm1t3{{xkjJ+8wtKf<#18@RxIosWIQ_8)}tbg=z)tg5APK9j$w)8tGt7 zK9M&~mA!2k_)+D$yo%~miATyrX@9%1G%TU1XqM%7RJOVP;&*t#kaFOZ6pw35{0yeb zSXmbymI0NV<^J`bCJlDWdE~e|$U&VFWJS@mw>7&5Oi9(o>FtWQLw}u2p7ZAnU#t)v zwa+TCFgByqQH9(nsneQYs|YEOZkxKcRa{3P+21H&yJS)&CDULVb?mGY0zsE9ltuNt zCuv_X`&^`+DtfU}vAvAgSru3@+Koql`AB6w;WG1OQqVJJTO9JF@1$9iFJ^dS9F@_eoHVa)}Jj4!OCUK@+Vv z-11bh-W7>Cq`t|aq}+TU!G^qM-S#ADo;dDm^Ol1mQ1o8nLqy9Ar;>?y2=!kN%6Vgp zh&o3x{3w>2)T3l!cg8k8JL3^8#TB|_jMqax#SC3gG%wZkFD&)F=C8U3&V{fwSQd11 z-?EsY{n;Nghr0plL8q*?_+{eF-nGnQq|KouG!lqHDi-Ucg*c@5IF63rH>DK7!_N=1 z!MURLiyb-dwl2^fs-eva#1)u9M_8O}F+bS>hVldbsJgSj^w+Y;9Ztqil-HK2D!v=N zFjNu%Nf>za6+&PW%g}iXLq`F4 z8qZkx9s=Ds`6jt(+0`Rcb{d#R1DUtw1QXp4V)*>3q^;ZIdP*8lQQm4w9ch%R#|+Zs zPsg#o3kYkC#fd`~GMw8n>Lae z_dQPgIN@#r3F`?pv8d3r1fYn@WO>Dh;J_Zr!({TpunzP$=UlL7*wmvD7wgPqWfv{Y zC0inD!9_5I-HL0hvuI>DNn98xQ~uFRGMU`O1WiSHOh)Vul|19+&!f-z;zNkq57E|8 zmEuP6wbb?hAj+t*$!urlrCyh$am3??a2dBJZgO=M<)*1#rQ+j};ysjGrI9fyj~^=@ zh$GTNd#80#z0$uwqq8;ZwKV?qtc>k^#gKF&UAL+2Q=yqtf2Mld2d^j$DZPO9F<@@! zw}^S;?NEx<4 zs^Xd)-S*brjzelQM=7_Y?hheP6{?R=t%TI_x<=u?L|zJ-DiNBw>hw0}uyYCNAW}i` zys<3oWrzsP97`w`Yp7V7cusdjcj;vK(%rooId7CKOeD4tue=+!xI%UONsnDf^x9n1WZ;~l2dqaGd zN~TK1*1_a_BF4w)*KF#D1@`H%8h=%(|CmwtUS8*tw}n&SPUg|OM<66XRajjfU+e>$Q(_QpoU)emwz zaMvpO)`3x=C|sTEBLCPaO=UwKtkAlLQU$rH^0Xg*Pvj!Qr!}{DA;;jCWR%gU-s3S{skbA7@Jj9A>$51S zEg-z%;s~RS9*l|FFg8rqk9hv=JzyFv=9o)@71>mS( zZEh(s&ku}l=N52Ef*;kFg=|N#c`BynMCzoqNFN^f1twrj7VZWL*+%0}Kc_#HnrbA2 zxPYQ32AWAH=(ln9c%U(wB|_u-*GEzM3<)povj1h zA$1c?4Ls=Y((W>SW<(m_&+| ztvt5&Srk!b!<#9K?`~{C14~FK1UZ=(&0f4&4*1k>?aB{bk@}F`)?P&|uq?&V4+9-n zMFY{#leYetwfgS!nmJaS+{fD?wUaB+v|h{!Fe{3S%85i&GF!(=yrldD+R-DbkU!s5 zT!u(DdM4ds+^r>RvmRRWys=jJU(PFv~sA{*ZCjvqP_O}Lb4*j-<+?l!u=G9iMTf_^rej(Z=hW_6IGCauclj7)UxtX4Rc{KOvyw%ty?#PqCW zL;K9E%9<2sI4r^4%c#_CO9f=!!-u50ZHY~~?sK@N_^oqdl_TWu{389OaDMo0Xcwf{ zw>{EI1-qp?FvJg3iT?F(a@msD879!4N0Ht9Q8Ig?zHS=5w#_uQ-u8K#l|LwRBI>B~ z8RzV<4c+1+__9ujxjS?uIkZ0Kp4c6o#HIUjUiq(&UCD>U-PVh?QJI!29LZRl#OJ{*j&64Z7XG!rpF=@EAd zDQh2NqzJjBX<|s@mGSrhg6FzM>f@1$dVGc$UbZnB`Y%tk^kZ`#oU>Pfi9Y5kOHCn8 zW;9h60C$Wu%Hav?ylhZmr~Qi}So77)#7QIb6VB6~^mgr$VDLN|oL#6nSz7K3C?1@3 zj&dCxpVOjcBb0Nea#Mz1tG>E!iX>P}XYevIgL&A=aUVKa=1eq)eL~AVxx*WZ zca(?du)pnPyG)}DEnWEA!qY`_1_pD_+=|1@^we=>vI5ql0PnpyB*@kii$74&*4Xu* zy9ni5&3=7u{ny9(9h$|v%%NTNFZVGZVOy(NeNju`h<}4Z3pfQd0fZ1NPor8#oz~Lu zKnIFMw=h81Qbv_|CPMaAU}e3fvN6hiXo*YQ$Ga8JpO@+?%&;6_RouGt#Urb#ur|0l zvcz*Pc`gnY5PGW8_tTjzg$5@U+nfm!{GK9MIjD~~kn5Pe!u~a8wBrcFBH%u%Ktqh4 z0%>%ETT^7W3g14iDW|GK64-FKz*6EOt?QigS}cbrKSGw4X)GwLDpUWdGhZ5D?>()s zgqJ!lO|V)Ko;p#5XhdS|&UYW-x$b2OJu30(XDUbAnyh9YOU%q&d5T=z7ugl>6CA#` zXc)<^Rj8y|2ZzB*nxe?|x>2ocF-e4q%sw;+T23k>B`~{rUfr%WyuO2(C#vI0Dd*z~ zplGP&-AE!)2?IE`l66^7wrM#8IoTHsU;HQ~=$KRKaj#i;w2S@C9U7!#3M?e(jU&a# zKCc*m+0z6kAZPQU=#`J^3y0qr^_h# z+-QzfQLBDZ&50H~mMwnvePgOnesbSpU3s}Yl;3nT9u=F2DT5M*GXn+WvX}E&{}~x1 z+1|vNN(yFO3bBuTm3w&l61I`sfls!(P$&xzEqPw>iVB!BFDi5vj-9P2VQrj0Wd!ST zyr=$$-X^NVoBpF2Y*1pn{1h2hUfkiVUt%t0Ywki9QE_Di{TGZ3_Ggr3l2;u{Lp^oq zguiAwSQR%RV)_SQG6ZczLl^WZsRJkLn1sCb;VH5o`B;dVAV{o^qVnuI_!+Tc=y*{~ zZA&p3p*3&ghn1i-_VR0$s&-ZfCR8t0V?)5ltrCr2Ds1dj`)*saL!0^s>j2MUQpG9l&NxCItPo!1o zfEexGI zr>4q-36HEMSktQeIekQn1Ewb}0!vce57yz!zTrD4$T-8CtB|oNMeHn{SVC5o3=gjf z%{}?}!jQURD-nbWJjGJ9#uT9UijKs*5M|A#+Tq$@@KEDGtPGukeGrK{Kp7;Po)U)$ zyR;+6VUKyRfI2aF!B)G3%}s60o<`Bnd~4~_gqSWTItw;13YN=rjjW5LLsY$pWp_G3 z^L-4-YR~aXGrc~QyTWiLZJRMjHfKR~BKr`8)t=EUT-sS{vdCA@pBBKlCwN1GP zYvA$oBwOL-hU}35xtvf09Qml_)#p&vhV2R8q}I(^ua2HQX5KG3!60If@)+vs3(Gp` zw-i01DoxS%a4Z6x-XWKc4zdGwKr7=ZeKx55{!wH3#MmFJ$}UGY&0!7=;i4H$PaCs$ zII!0DuywN8u2b-^uNfTr1FXm8g>7PdOnf%jbDNiUKtBh9ee5-!H929*eCpyLqle90 zYf(MNn;w@-E2?1p33_qTi47GY_!3phAn(frdI;cdWCX@E84fm;Z=h3_NC^AWqbRU% znm4(2-N?eXxP;YzPhdD|V7S5E1h!mH5`tJ-#fdxdplVGb{~`S>SnWxfeTZ$g*AcTb zAx8uaKJmKJGdW1tvu?_A2|wWGQn zI5&PpZsEFon0KS6s)^cL0auqCJ-I(WKA$bj;Lq$Hd!R%niYJ0v__@Nvbl~5tpyKbL z`WMU6E5{cUUd71%XWwyiB1e#dt7bAuUP{ob^8uLU?P#P(UcxZ)wo5Ja9#}Q-*S{@b z^Ju{otHCdusQyg3H3B(L?ZymVlMabueBiWE>@Xl7ZRw>= zTFa+w%Dxen(KI)w^h&-lbXDUgJ@Dh;i^Y)OhDTBsgE+y`j1>lnSEfKx8_>~_$SdtW zT9*R-kUl5KVZb)-5rNgyMtL(aMKz;}f*e(w{??ltA~;5FWiN)OK!X-3baGUk)K_#?;cG3PT; zmBQU-Jw|0T|`aDHLG z#O3wLLT23GT%WXvir3*In)H_dih^|l?U&6M+}3J3(C{G}CSK@4MZ#hKrR#Iy8?5tU z^(DyN(Gnwlf{oj1-IwE+tQaaQ@nlz1tAD>Xlt!U&4xAM*^#LL|-Z8+UDjmo!%Gi(XtdmrezI73B$k)9G1MC`n=zLOO$2UHPM*LV_9SJT8mFI3IkQzl0E5h6QQ z*I+9lxbxQ{@R)Dw%Fzv#$I6mxjS0y=?DWbi>h#DE&?7Qz4eYFdL2I^?hr=^^Oxo7q z`Dv9%t=@M}kywZ)_b&A}8%+5Gc}mq>Ved3aX@aP>M?S9iD}#!Sn=8R@U8uYCY^lIi@A2xMc9QxwcEVv{ zSu0hhm?Nw+vZ;VILB0h#iFTL<7F~53d*f)nJ?X+_+YgghQN4z@Cp6b&rf^lB23vi? z70EwDv8|CVWsH4u7k+-T5^;?HTFR%X$BVoHd%ItAJ0af3=*`yXzAdD2rT3 z=;B(D4P2sRSPsF6I>+(Q*F^wmG@ir&)POwF$k783w7(F(iHhLCL6WtoiWW1YbNRZVW z9DR3;wI4DAcz4Z)%w*mpMk6pw+mjIGD4^nALh>Z2G*|l}_2(Xc>p8co`%dDjl1MCCw3tov=A_Y+>W? zWthT1#qBh#I<&L*-MpA|u&z`_TuC7?eAh{6@kQM}6sj$D%?^70tihid^`Kn^v>H%~ z@=geAAhaDCnR?2@aCy~k37bGJih{W2AGF-` zS0)c2ajxAOzOn7LN3M+TYKGov#lY3!l2-`KXNu@a2%OlA-;vok@18-RxD*Zf?hdqY zxs@^m6@0$2dwGm}=Z0jc+hn$l?s}=@A#A7mCc1>-!naDUh~gcy~sz#XSMfa+DBci)h+^7zit zD{OhPU=2Oi!k)J9E)WzWJF*9UE*RcyW0n$Pn7F=vdpG_b{*gyaH#k2VVaDfOHjc{S zj8$p03Hlqv;W!2Q1qc1CjusP`o3IGh0zFGTW(uVcCdN57Tss^%N;WjP)`*-rYS&je zk14q@bTA1mC9Zv291Fv>A0n2z7H>6L+lg5lwl*#?WTve~MFcA3Vdu;+*_?DKs_YCj z8+QWh9Oij=s0qhsPuZl|#@bhHgqi`efY86C)79be>=*S8==6EY+68oq8y$Uy8BLt! z7Lm~EtUx1a6JaPCnYOt6BWk_R>|{7iCm5U3&B^A-xu|6i)bo#!zL?7&q-TOKy`+Fz zxtmc>@zVMDM7vePMm(9}fn(WLUh4-#x&q?dUd7-oG1sbDkr@ z{gtD$pq#rJ*RQY6KV8Swl2LU&w(o?k%A8?bM6F%bTP%Usj%rp(e3~V`06Pse)DssA zfr@?SF(a11L}P5IQ8%y->3G7PjM3v6Fd;P^r{-6HwlFGv7{I5Kkq|N7vftOg#9rge zZ@@XVQ;GJS`kjA3U8&E5Ut^~@#>k7)VA=50n1P(k>Za5y8wtOXpCeNru=4Igs-qqX zVnj0_G`cuPX=nAoE3wfU5onbTw-pq)^vvYEX2wL8X{`ECjY^&WoqI`#p9vX@+&7cN zX5)5toXnEyXjIo((mfcPct0PrhI3qD{7@6^?=>eTSvy{1Q_~5hnk{-@PK>&-N zc_-_JXr7UAVO}XllS<#S;jj@hY91sumAgWdLiwOv?<_7mZgm?FAF)n6i&^>jLqu30 zrPE5g^H8^FX9=S&lzrV(6CG>=LUu@huf->QZ5uKlpU-Jr-4lRz_^)kbEo>~0z=DX* zg(>&O0Y@R5^w5G(`c8Qg^I^p)e{`L_*ADETajBKCH11?AIG_79O>`Q2D$QB)1Yg!O zbENWb1HVK#3@I90YOaBbtQbN1i<$hQh&mj~s^LB5PiBiVV}yxK0v3CeHixfXTZ~IbRGvQk5JTZaGN@jOk^&pveEOPV^wIveQ zniD2`wqeEV1$=NyjNGqGQv%(3WJd$il-0K6Sy?SMK4ZW)To=)p?%7ciF#)C%fOk&v z8jweC_mAi~2{*-=?n3wZC~7{}mLh3*p>_uPMyo%<`yk_4nKu|w!kT2=mj8^2n0i7NA^juUZo2ZPj z-oU9sjD;n_nWsO2N2v>ARLJc_t&gz3Aa)|!?eG%m!fh}cM|Qx|R~9o!{M}}cP(@d0 zU+1~F*U3!{+r_D^b?s+_CfD&h zFlGMCvfiKO@Xal3DFlA0+tY8r5Ie~Px#``~+pKu*S&gQx&vDV{(PoRqg2~TyEsk>5 zexQ|E;JpR60{T?EkqdlO0F}?~#$j%-Ecsl#LT^adyT1Yc3bo4-x8cR^oKDPDaA2Q!)g=ywM{GZO8o+e#zF?BBi4_W$$eg5stU~e)mVv>GY3qaM7o&$@j-x0#>>k6IyD8C^j_?=z zwYsBQ#PZr;Mz33&#ER*R6}pCfA$`0%|1p$!?QqZPT0M@NLA0RwrLE za~7*fDnTi#QR*le!crZF_=NKZ{WPAg&^C1uO0Q=!Nuc9Rgov^|rf=uI?nn*8%XXaLZ* zWy56KCg3dmtEaZ#UGL3SZZr_P%J=UwKe=PtRye>jyi~4Xpq)IBq&>3IsOxWI5?AI= zaM?lE^2>8aN4TW)z#^y=N17E=_DpARt$#V!d!!k+9FTEZnc5+{`gt;OCB)j< z(<_SkTRVazz<|#AU!$qb@hL)#jZQ16OAU6qMLU~*NT5eiKc8c=ZR-!9r4)_pODd~Z z;#yQb`RFkv?vizY3lRl94J1^LI{!bCwSUa{MPL=FthR4!dJh*nyQv7_NW`XotGL)Mc2g-xmvw z<+eyn*xH=g^LYeB@8hDj%8cH~7+LESC>Aqlydi$UA(ef%$v!iZLWZD&j><|IvzL9A@+Ed6-iwqstSBvRbb~yhqznTfM4w+eI@XFmgL0V z;7B2eymp5+tSYP4J2cA6hsE^?5jWl^x?|JiK)NM0;NfK=Psl05Wf6+UO~Jn+y}Yq$XjnYC{W&*uc_ z0jMx`_(o;uZq}Ohe(i_|U#f$}o%8R6dO~=*_SG(ChB{r@RCjn`S85*ub+V%rUKFM} z^SnqJWfZ+lk`-BwWq!iw0%B0rxV5iv?5G2s>#^&d^-AW0J~y|RA}qbIs0#UO}xUlkTLMI>~$n$NAKZmDW&Yvvx+VQzmbUL&w>3H6v? zl61{=5$={ag!&5v+qP&(^jp(Col0x&eh~i*F+Q3Lp*&ahMEr)zpL6r>c+5ox)_T;6 z+29(Y+Uf^-TP#`8-(8W#m53ucsdQrkBCO|kYi}w5#Tz*xo&S}{zC;u;=lkNZD zIT_g)+5Ss#GU79EFtITH_w|1Ros9Gx42=IzpfmafR33YM9u(>TftueQ2jcoa4{Pr( zoIs#g-7ak(3qtnpHC({%HNvKc(=^Wu@yo|gsW>9!r5QY4F z-*!qsNJ0i0erbNqbU%!~si~2%si{bDzC3u_I?xZ5Sn(_fXNN!brN>Vlf)iL~YoN(K zX^p-RD7cq@bry|(2yAcv*hK%(#3YQqiRtlMZ9xzd9slMajxn6PKFBXE3ao=bF^G-L z#~wueSG&*Q`vZ~RMif|oZ*Q;g=YySp5bhL)k*OY>JiS#D@TwPaO4|B&5yuoi|03+i zL14=6==^+iV(@Tpug~1@r2ll+nnGL%{uZE36HqyTmfy@RpJSJ996$t_YnN{k9gzay zTopge>1;-Vlj77RT&je@8I?)oe;7X8u+aT zvKw;z-w2A;-J3-jfJ8z{0A%_Bzt^^Ojv#Cu9dsT3W!{(OC0XYuAeAs{^w&-Wlfj>Qz$gU23F?3v z060@qQ(IP5fLTa@N9IPucPjsPaIxJT$<&@feYo!JSh!dKXnNRux=|pA@1WBw!+kiA zR?ZGUpROO}PdY(k1Hkm4No~MVeyMn#eY+cdhS~k!`kbFxJQ;r+2DdLYz;Tc7_m?q1 zF1-`D*9Lsg)Q>GgQf6~QWGLYlU-FMiWF)8i@BQd1AWXHjH2@qdEdUujS?`Nq*XP7f z&*o1mWtRW<*cH4VqYo3cLKxWY9<#(;>@DfNT0pW9M^A9T0AtB^FNG4T~_EhzEZu(C%;N=#oF}$*? zJ>Zwi4gk7(dd5#2T&JTc>n_(2=w@|~3jeL>mz^-A7ZdnHk7`^>5VHRMrS&~v0tUBU zH8wVY9qMgtCNR$rt_=WkQCASvD+IvgG@Ab2ZuF~~6bA=@G@)O_cMv`gUC zUrODV)r;>%-_d6f(CfL$`&Ab3=63?{tAf7cYYxe3*#KUd zx_a*%hwNccFqyr*-vv8&L;G&dLZ_9x}^OQw$0WzKHxX$z~Lj8g#B3d zCbo9KajD;9)Cu0+PrI1`Al8q9Eh>HAPAo@nn6|%b{!b2lY>&17wcn#Z@Z})r=l)j~ zL8~ooGbydAA3NB?D-P1Q6y_X#hnlM`6W(9;bWvbV+$+Rs-P z1jHjqCIRg6`LPRi|+Ro)j4-VJq)>c=FtmQKqTP z0g@mm6MVt^A@&z@z9n+Xjd?!tc1=HvA5n{1rQBoj2 zF$|m{XEg13)KQJQI*N}LGWrBr8KH=VHvi%V&5DB_gVp48!GOcomOT>0ER#1|p0Jes zUE%MuCUIDd#MU)Oh!#P$Iica>}tSk%-BQmhExXTa~*P zbx~?N!tLVbhPdEcC6)a%W}j}zoT#2Ply_>V!e3A-GEZiI^k))2Wo+qoy9+J#%R-lg zdx_EmhNBdr*=@r_IrYUn_Io?A=6O#%-$Cz|9LZFbjcRhRwt_(=(UTlE6o**U?aBQd-t7J( zFAi`GZ?G`wr7KllrheB1b&IqiB-_#kg*PYt* zctpdwA}2)Z@qFm&KJgLnxPBO_BcxH4Qv@{?Hzh@pDC7N5^`K88ZYgkx<%;pc+p=%> z#PDX*^}<|ts=7TD+1q!BQU21MS$6s4OJPi>I19kDk_ByAk)#$gS0hHT^ZF(BM_bnR zFY+j>CFkh*EQ@;K#gJGEI<4OBnWEqNy*?^YT@7mW`ABgK7GQ11|OG zoSa+HhxKoF58Ls=7L^k~8};&wY?@0y(0R zl1JL`^ipiTXL3*ZRV5%(dFzm#UyL-OwXabQ`pxDONq0*1BU%oXLwba51fPc)1oC2v zW2IIyaG3MISILw=Y8a7F6^A?|8JKfM4G9G-=(p}{eIxaW8u`{_j9lVrRc-W_O^lyM zPN5jA66iGySp}SwhOrG?ge2c9wOTr1D0g5jm6aGKh9QRZp-aC4>`kq(EbD17m~hXdr8j9fuZg)djDlE>GKUbTS=uvyFtON^s;v`Ph$KBYkCLH|MnbNd z!48*Vj7+2oib}c?pP5ehp7%6@7FXu@&&hXF9x>~0P2Up!@-Ljg^iYvazJx}^$Z4Tr zO6Y-ly@Scol4(1T9PDN@Vrli!zY6d(Q>gn>x3q14gQqj$aLGGa^MzglT^ce)U_N=j zTrsP_y9-|d3Ybr_${gDR7b>AvTVt0e^$bU^Gl*ZcQ;64dWA!8|eIr-fC^{wU?XSP` zPgV#DfC^;2(JLlp6M%FZoYcd$jE8WI=!miifPs1ZD5kJM= z1+UxAFqVkOht`&E1+=<5SqsDda6qOpCPek4B=Dg@=8R!V;B%upZ zLyK`z)Hv51Q1R<>e8SZS;w%QVLDuXba32&*&iAnbgHgC?1w_2;B&`|+*M>_9rB=ghvXtm#+0l9QY(af8A!i+jGXNto(aA@$zh?SHIpFy4UF>Vq* zx}TIX=2gR!FU;}#`nwkBIwlZ*v-i<-`y(te3Y>CezqBkrt3Y1@QR=~%w;$`Dl3<2w zoVu=_P81w%W{n;qcu(w2L%XeAFMsatUxToGX(XspW+k+{Yp=YbU+yCuXiWR_+r$V1 zW(4UYlP{~#l#GtMnN>PyJ?sYwh1cOj?trdO1E11YeRclL-J*{If%w+2+*o>ys66Is z$zVphp<{ip4op}J^o>}Y!-2{fK6hUR#^g+-9$jqys^-^5W)u+LDe`hP)bU-o{faL%3M}7&>G9dHNU6nBs2uIJ@r!BjJ>P z;~k_#PHAUEq;>;4V-%oo@g@v!;kBzI`pt& z2;5Vj3-;;=Q7KA3N&i7Q)RJUzK%F=L68TT{V?u9N3RRCKEkQ~NWo!4;T{msJ!KpyZ zC*D(vXX&eQEH?`AR1zQbl^5;LaY* zybojbZH>0Zq0jH=K@VpJ=pGp(I>D~Zc$6!{k=fF-ZbSePaS)QK$Irm5E`%)lp`M^B z^Ja39x^y9_IjR8L7-TU!&E($GNsW07)TfWa?D}N9t_`)-VfLYVOm`fh=BL%~&`7=v z?R1yfz3Ve3{^3fyoqw0&8;ZqL$?VkP&exkn!U8EAyukzELs2@GtVqIQ5c~!TT*^#gU4gw@ za|C>_45bvOHJ!QVLpr-5F@wBU;(~1a?Mg%R>B-3ziY<5CGj+|(Q>n7_V*16$BA4sj zR5QfJpUjXcf(pB*iwdqJ;a6$|=I*;k5_5B1;UT9ZUv= zB#LUOq@%G?VXrVMgL}=S_)@=0vwQ|VPAuq{PGRF*xXsR^tz-X3MJU1U)k_C>u=UD{ zh2Bxwf$)lM^{1i6jGe?LbP!WzFdrMb!(&%i%$BO|Q(Zr#_<2+S!IlNvWDeZi&6A6_KrDZ~QpYA^@4Y%Tdduo4auI88etN`y$NOdGpj+vDT z&Bw15lju5@_a=<}&dk3t$98MDu8q$;Lz(>OsAd9b9%Tz`E&FX8=P z14gse7Pg$!n2$y3NSKr)Fry1`7yp!Kit-BSiDRofP9}HIK`GdGV(?QWK#goY(b()t z?8Sr)+Z;1^jmMSfzE8TyE2PKXX)@8=hW(#A_$ zhmZ`=7G;<5a_#a93zIp6$4dvzT@+mPecveHtey?jt&+3$P$1`C;D3Zi(dO?gD?mbOPULB4{AU(MY0 zXVj`_K20TwJSc3-vkUqfCMXne-GkQTD0p*H5YVjn)>O<+t8q{_^TI87`W<5Gj7kmz zE^?`Cw&%6HG}+Rng7K$&?6x@pDfDI~Q;r`oap&#ENX^rAqh~ZfAWv&0J3?q-%4CZ4 z@mRm;hVdpsg#X}aj0aSXO&ezh8$Ac+Kr##3gJ9O(|S9ULBRX&SUDf7&7 zXKkbs*%uRLwIEumVOcsQ;8FSw&hH?g@$S(h(9K8x*@l^|h~kWLikQT1iVgo~i{^Pe z7bK_y`Gwfma~GOEpLJCI+vY<;^%!K74_?O?Y<2tfC4q6UvpD?9BHM^m zDBuy2$nWKp#l0=Mg=Uu9fZp|jB z|87~>x;qD@GE_~9nMG^_Tt>1}jb~KvKu*M}&wk~kIz?&nI99fzZbNfz!DANfX2Bx3 z4qQO<(k~Xi6g{<_P3juf2Sh)Gu}+2HF}tlln4TxbI?q%wU=HlZgO;AV&I; z=JOnWjZMi(ik^%L(PrDz7|Ug06K$vmis!k3Y?p$|ZzTbKDeaqz<8>V^*Bc|2a!0`I zLVj&iOB&qSH7+^eIS6+NAPpU*!j94eQKGc_$t900dXL95>qHxHAA4Tbav925&gTUD zcr_Ps9Jy}XiC1|id!fhx66v<#MP?Nd`7|I@5W=`3YR=q+GX&fLe{Jy_b<*l>H2mO& znRN0(X{FU2>jks`CL^5FBP#E7@09EHNZM4`XKFbf{-D=$SI zo&l#u)TARP4VAj!oJk6D^?bb5IVy1ttfqjGQn2-cM;n@4y+7ZMD~;LZiVBdL3d$d+ zh+dAaYqh;K`1U-i!e`xgCve;Qt!hW~16DVAD-7!dD$Lj&2D9D~{J1?|C;fWgSI0uk zDEG0D;*&!4$ZL732HRdngGE72CZ!k|KB{0VYl>*QgIht7F3?(z$S}n3ttj4$R}?@G z;JX#WL^9Y11es0q(hSt-k{0yZSP$dH+eE@P46O;m(9;qMuxld7>Ml+;`?nB}FoTwY zhtpl&Cc?Y*$k9!?#QAL|^GFJBt-`Xh0FLBg_~5G9-WR$EL~QgLE63XNWwC)-4ZgrLL7A+j&e~9l7m< zl<$Jm9bH!wedQs4Qjf2ntmum9PO;IuU!!=ITaESqs9SnwtrIHONT}HCd&G)FZ_0Eq zgnpUg!#6w`CHKdsud4V8tL(EpFlRV%21pIJW~wjICiA~Mh8Y}+b*+tP2>B|85~AMM zV&6wpL7kp5!UWQ-Iz=#+Ay69}-!L&4d&p8O7#kJ{ZLa{3zEc}5V@{fDiOdn4NmACQ zk~CdT388qCDZ6aWOQ#fI0aI-)yi5j1Q=?e3JL7obsM5DUN;!6e%4i*i3i=Ida3!3h zX8XJ=_%Wl(<^`o{CA6DZFc|}o^nKMRKyb30gw;#55+>CXY2R&h-Aw_jsvREncsE~kwAi2thNI8PYIZWa;+#p)GbTOzp z)F|5nx9vcbbPvm*D-DC-Jp1fAO0}s9lYM29?n;bGF}hch?w-XtYBGAcE@uJ4#f<1a zsez<|H0Ki;p%Ylya*X&=ZmYuUT zj->k25lKQ(etWQF!p6a0L3U8?9FW=%vcXY<2L030jD|+Vo*0lMLOJVhNSs6T13TBz z7M6pr-qWbYMny)YG?(}!d>^{*nlE|g3&!R`erQ$Up_!*nYePc^Z%OlkYvWJf)u0{WV0REs(*bGT znO!(fBVKOu=zpTDoAU4DH|rfHC~teH4L_4}ikMw4t%3_R2XZe0{{MjXc0w>X)2 z>1T{to|Vtrv?nJs_I%wswweRDPnkVX2Y&pRL9Z#?>~AKZfo6*swkR#U{?rT1vrPmx z>?xlEea36vxyKB>{8Sh%UcR2Hw-e*2OwO$DO?VNG0jDRTG@67u^#$M2;w6_tO#nY^ zVv{>?pC{6W4w^tCCtO;)u8VKvqp=W zNhCP@=52l-`SiAyd%1Jk_HyD9d}x%gdMKE`KE|z%B;73GVKG`1V}WwpLSsd&A{a0m z&(%{oJ}NQ)mn$)e+fEdl{0v&WtnVv6J3Nz#d|C^c(S`1lz?`|`8j#Ep+XU9nu>Wkx#B2R47~}Bm^i3_QzddtAwAs4MV2hr^pHMp>k2Z*^ z+P`;KjEV&b6XF*Yk@}qUYneO@UXZU(*??smNAzWgZSG>v4pgDPDR!Ywj!+7yZ60nU zNS~N=rC|A@O(m*At(s3M&6~Jxi?&bif#uJ`DC@?C1{AkX8!Ktc*4~*5o+Pg%fbbAQXAdkMDe`|K$-u*{H`QO+ky zW%q4%r{-L4CnpdnVoJww!_a*0HKo!T_d#;jHL~P0$i_14K8x?;@MAx(xOjv-N!@yv zQa25OGujgah4Yd}`L3^w)~a6qdYb~N$~*Av!$&50>0Yd4K|^1aVSnjiqXkcWHDN}t zL|&@A+b(@-Q|jW8pPB}T{{EGTT@n3hb%UfcK)G>Z7V{W@hz!Vvh4Jqa zIhMch=%`GNAm$7G7kV#-YTjhL9VSN>V~6$9RHdaRq-@38Fn6Jz(3}sN_VrIGmIQiP zkhZ~W!COO0X1IG?1Y9zeHq%v!kV_&mxIwPINJaBFjjz zzQiIRrAAJZE){fOnm7TYxPh^x+2AkMaTanGN199iu!=u zaY0-SA0DeV(;T4pmc zSEFM+7g?k#)sKYV3qMOM3YurTP84IlyEf})dR>J3Ezm-m7QF6pe|HX1$No# z{V}I5af8!Rkl>aR8lu&Q1a<2u>0LK3MkO<2G_hP(EjI73X$D5-tsR0I=lld&cB`v@ zh?l`F)1CT%q)&1yxpDaZiQ|D7zkTZ-8N7v8{|pD|t4jvj)AL@ipfHcW0`;J^(##mY6ClOt={lSD}>zMC{2jTeM)%!J42Kq_7m>~Rf0M{oT81??LZIK%|QJZ?LO zQ?cWukz>C1TJ=cT*@al zI{F9B;c_u-?c~`{a4>1m@?rI30AwnK{$?8HzpRVd zdIb#Y)yvG@NF2!{5iN9&0J+w+@|&jK5tDNR)7saHuH5IvvYaS|0X?&CD>tVkTE#ip z+hCnJ6XIXbUDDVJ7Yux}8S;;nBZavU5#dU%@#tAjK|SAtPi56z6ScekMV6+yvFJJz zoI;n3Z?87?7w1Txm(di|ZJvJCkI!xnDm~01IRt%#fmOj{)9%w#S`Z&^Z3s(he0U2S z+o`OC57<+n-B?W84#C}_>C79INqUFD2N!$7htOuJEWno_-9To&afx5gs3B_ra($K> za7L@xX(`1AGrrx_RGZ8%s4o?BYJ#zmK;ml&=4c)Yuds2sPF$v}MB&*WW9erOiBXZ@ zMbv`LrGegY*KS8B6?Bx7vZpO8;liS?U7&>Ef|4eXT<%&ec#Q0GLh&S4h}$l@#L+c{ zN=H@Igx%LVTbPz<#tS@B-CI-o)lI;1DJbTvppf|fkmolrAJa{?YqML5MQ`5+vhQ}Y zyMmAvlgqi{Z0Rw>lXTTR$}<-{|G@@bIBy{&zm$_tS8^j?T&Mg*bWjfZxUg)DBn^yo z_5UBX?jcsNU|R$5Q6Jm3ZQHih$F^hKOJYFVYC|Rj8u|2(u59@`ivSGY zq$HdtOJK?7-3C}(6@wIjP9fT@OY&6Uay%POru{-5<-TfdVJeO)JQX~ZjC5yRgHJYz z32u$3AWt=XocqMPN1D|ZWJ~RFqu}n2Ae3Tme0NEcTskmrOO{PSsf1d5P;6D4Gn-^| za9)PW3kvlmkOg~9?|P_*BlpdTn$@UH%QXB1oh3N}^ zkv3G*Ihrma6dhovvP6M(vTcb*qQCz z)pIO}1D$m71&q2<_+(IIL%u98PfFyiY+Ux;k1;FQR|Ia_1>qkeZE?>m!A8%<_s5S^ zxIyA=(pGWfM%Fz`c!p(1s>*TQxbM?~9KNOByg0^46s(&eqRULGG!#~sS83k8%R8jm zz#k+jDrCE_+piG-fl^^=(xY*nI|N@qCF=&k!B97(Gfz-)t!bEsp$oxMn_kM>mxR5K z6XqDB1Fjoh5o44$J67_6y1hXB<$%hn3Nz*mI#PgtjuJ z?{mr~7t|pHP@-(%{Waao9I=keaq}^uz-G78p{p0SH_H$_G@dpua*4I#hV@`+y=dv=*er%C44@_3ehA_`@cg|Xo zR656Z@h5dE-ntlQ9$zERjNQ+CzQ$})XH-dswJtoN7?B3=+|&!+W&*#FRB!z&+MnIL z!u0v^ae0W%>y2{6I2VJU(>pe+gncq%oMfN^fRBdUMf!TyOqE3=GeU}gOhtshXCIB& zN+Q?YhtJ#K__08}l&BO=BUwr0+J(`4e`LX_q@|=^!wie;5M%c}LUO0b;$!-P=x-Bq z<|1LwfnHBxbH3J=ml6Oap(iJ6oA0&PFQ+Sg_U}|2x}Upd^?I-uG{3u#CcLB+#8t3! zJ)J7Y`?$U)EQaaOjA_}zXr$FkGaKu96vbip2+Fk7HWsi@0=&sGGCGJ3x;Jq9acr3} zOc-U5)I8gGcg-07CCAo2JDETES7$Y*L_Ts^c+e~s-exPQ8{b2){P>wXzbmf}j4xA> z&msNLiVi&1L6}NlhN;ts;TQ#`t36%S;zG|Gnxz8BX*v|pnc7>kw)Sv5O7Kn%Go3B& zUstba-%)-#^LPD<4_N0*HqtAR7be2fTWvD3CAm%N4hM)W4)M*pdsaA&j!`o}Fxbvtm6^d~~!3Ie=gk`dGdfQ15Dd`k1Gr2dI z4ViUC)_=N9qXyE+Hg}ixig7PAN&LBAWGp+yrnHiuxHQ-9w>0m-fmMCew=q;)kQb2~pRC2rAe@bA+D*};Lz zQWNH3;V;w4AlX`4Ugzq*USe^~$5IMm(d^$N;+4>>@`|F&)F_JrYwRz$ni(6H5pi*> zuRev(&WAPNaZm8#izBe68+OHrI1MdPQdznk4DoKd@1JJBVUh6t?bs|A@x3K>ElxBQ z0UO0Re#=MIRfzbye>WM$EnDb0A#{*I9kiRKOSZm)`H+@FmA05Ox>U$G;Nn%$_ung+ zXH(`)%Qw2GQwhn(2J9d`X*%EE4io8VKCDM1G(LQ=IyP3K`*pmK%SmXFJtP9TPG)A+ zjYnQ<#8yt^v5qQ*v$D{&cTFmdPCQ85yg9$~Wrg za~Tj*s6O+jc*e^ylk%L`WtDX%wjHTNuPNuq5{Ju+i0-iI)~!SypQ8?l`SQ$L=)1eK zimq`AR=X3IVhw#oNhyj(-{D94CJi0nQ2h#D05#l8o>lf_>&kY$tt zs4$n{MN4S&p~C2vGl+lBUWHb)*C~O%g?=BQitmu4g7nYnh>-`i$VWMo3S#knBf&U1 z3%!EacqieNONMbAzVgd_1SBftPFtKNp7|p6kGFVQ9ANG2(U>oMwvxl?(}K(JT*}OQ z^N)wS-b%usVQ0R;Iq1sjLU4L{-lZ5zfsDhy&s1K9Z>!dqB(tcC$<)xg5%4|}w18yr}1Q6EG5d$F2Xg2p0>p9}-s~W&-8YqC5nr1kqIvc?Tb(4;JHt;`6C^y@bLQ zw?wgzmcxvB#Qvs9TPcpPKBN*|XEOEB%G{U_QR$G6R4IXP+mW8mz z#&YOjtF+2I3sZ;1qny@2ifNijQ4w0DO;>daSp(}cvSTmoq{t-_*9G6l8L%c0m)D-% z$n?7|PNOM2(QnmOjCl0e(-BA^R)h0NV8hr)nu5yp3V461SBlj63M$PrGl4*&D@d#3 zT65jzOUEVuOU3BY#1}d5r`t?9KgG80kV+&&_6tBpMiUT<|9^<=_k&0>-X*fk>#-f4E6GFO=F6iQx=WH-<@ zg0a3z!_;9kvJRmvGkq^#YjnckLVAzm-YloLy*-n@pdtt1Wt>(scwuo9@m(+%x zTOY~ds0@>kCkd3&x&HY0exb=@FEO31UwJ3|N`-V`RJ$&S0X3o<3MKDbhobNvbZqXq zlgk(kG%bk${qEizG;y(_C2YB-FiSf+U-bs7#IQS0N%_})~)&v~cOi%Fge7=AqTGn872H~jiT9kkR!YhZYpwUigH zaT)s{aFCnm^NC$K~qKWJ^+H8x+{NVH|cJlK_d5Y1URj^%2Q)569r9#pRzai7k4}5uvr2MS14Be5aXrY zWEq72N#;$CuB!{R;jBU9*T5>$tU2V8CW2jfJW6f<3muOt_|S@mMT5Gyw8NTwC}OET z&q?ep;?smj+=~g!WA2QcGXRV1+5`<fKW1apCydn!%EN5$zj7tLQCONQ7Nmq)?|vlD zBVO9zf;MFj-LkO6bnLpyI?X=6s` z{o~CZTyYdTzM_drnBt)Dz#YPMOue94#P9*?XL0)$ex|*BS1iJZ`GUGS3)ONx z$K5<#r<6VP{XbE<&fRhZZ`uYB#J>_I0ukp-#AN~~QLS@(!1!Hi>=O^gSM+Oe=#hMz zbN2Op!*qIfLa$l%0-CLEzAmLF0M?{EAvm=zvs8++&Fjxj9X%1rUDYR-U`wHy6I(y_ z;nLXA&B1*AA=;~O<;AuM!EEQa3{b#;od24oh5eN1v`aQGy!Zpub1>-v<{1+o;YTLv z3yh86d`|hml%B*s|B1YSY#>LJ6g2$~wQlL^K+^Rr$7Q485tRde5Aw zO!8MkTdSBG=mEP4ULbIk+qNaLJ4G_R@PIP;MSnOf=WNvh6e%1W@k4N&Wf!dyrmzuo ze@A(>UZThE7@QLwH%#@VIFlqbfs{X5!Npr7Qi%{S(IY};xc_EzL+Ab5)5^0KGg)Y$ z8LA)3zarEE1?N8<6xHZ<#UT?LGL$YsP71%WW^5OY6)pm45>$bqukBqmNH|iFxxo{z zP;+YKvb!=c+Lu4<55y!57_O1CqB%LhX6f{@RACWrpWNO1q)!uiwSzzSyLM8&dv{@oD87f3UMF#?GXQxKFKV3qBuBT>*G5;>NdaP*S~)s-u-MG4Gu6N^B8623WVinjUk&R^usM8C-~{F1Vw+}))#uH zf4hNoWF03|otPBbYm3qQ23m z5uddvnB3*`0!=qlrw%(IA|-8##Jrn4GkbA8Tx_|EM&bIGQZ^ICQWx{xfK#p0rYO55 z)t}|)`3z+lpb`%5+EEuf~bVq_)UOcuHJ)(<16;MDdcf`a#!d4xa@%y zu+ny!AXE!Bw`NBO>$S6YZ?gFgGBS9#^V&IM1I4y3SH-)VrZ@D<$Pjz$L6unwkal>L z1w=H3(n24LcsuL$zNe`C;`%#6`)sX6-di!w3{5CsU}9Vn(T;5MEpSC(8>K5g^03ia zKjY1mG5qArv$M5&qatBw{QFk4VfNLACuxJQYKYUk5*kOkE;HL;y6XDS8tI&MOW*RF z`7U9lgo?PZLb{M72#SSc7T_Clag&I-j~zsqvC!j{CU^pCP)%V<4_1FCdgd#vRm+}` z8pqI{S1K^q7rSZBL(8uNZ>DEhu>g6p{GhOgtH%fr(z-AbiUscrv7@V~ zKG}6~{+QYscXMHJ4#hoAB*yCWj?bMh`w4?xu4u~JuuF%+K%-aiSuu^0GWkM7n<+uP zb3==XCJ;PY75RdpTH&MI2yXz~8#=f6=Dx-mg;a9C`y0C6-L^Fnb)M0-+klx=0uwr{ zMc}Q5T)tNg-{-Q;3#(LHG5NV!JbrH&ju&t~Al4bNdN zP{5t9ZP2>(wdpp{*R!zkQR8J)dI&8AOQL$Vy>*S-tX2g&CQevc`q;YOUQz?d$qViy ziwl-L-JeC2vQ*`MrVnoBB%8f;L(E{*yUuBx^wAA%pM=x6lr=P>iQT>?ey6s=s%-vR zOK6fZ=YGD3j|6L^MQG>ccuS@-9LsxQBXRZxuEJtt?=9-u!sR!Fw+V~)S#_~CqlPi2 zn6y9W#j0+!tpA9Vgvfo^&#X|F#yzsp4*k8Wflxyy2XmhcgoP_%k#32clHmd79*$W% zsfC>@eY>wbAWG*?*VZQ0zOH3)coLwnj(?EmFS`PPd4%Fve;75;^Kq~-ToV}*Y@gOB zF?V^|NIY8cSNNu|qHE@uFxTk2crO;qEJ+~MVx(RaEKWV(3e5`)qCOkYjq=phNX+O9BKDTnSI}t;!HmP+L zLsYL-%BOE|)pyaq@xq2fpd+fS{E*Y(7MAP{AbAZPd%frC-u=s(^VSFNbaug%ZDX=3 z9g+iv^YCV$wumD5v#vEuB?n&x95WxaaRLrC+ z9c$1Sv@AgcW6^HDD`RGW3^8%4s|sA2_URzwK2`+rdWHY{rmjiYIKr%Y>j^AqTwsU*P9oT(%ZEIdf$M=-sHX&>a?s9Y}LlZc1$vRUBy zbyP|xZ<~#4-G9n})MeVDEd#z$8tNeZZRcyzu|kgbtkt2GHKCI^_?Nj4UoW*=W_^9< z>+xl4fM6rUg=k-wXVZg_5%(GAtojJ>(w5=64-3LwkLv24eB=|oVMA`5GMgSepU3?@*FLJH&`|fMvTeWhBu_{ zb({pTrbhD*+NmY|!mH&#`DyBA{_#~TTDe$~7qq=}kZxyiF-n_W8B~k9&({iv{D-NN6 zqnd$jeIcUz)KKD95;pb3d#NMlRno#ftaxQ?+fsJ+I*&M4L525V=7k`bYVQ3ih$&GQ zk5fXiuU4KT-4|kjDXd2@$uSx8`44P^%FYzROvY64dW#krsD{Ny!i?|4FBIgjx6;Z{JjlVLf8o?XqDNG0Oi zvq4Juq{|nMcfaGV5jgls89n88!W~-(HjdXx6#WV@Ga-non6r!{rPSL3YC2LXePATY zPZ(p@8%ktZDjLOI33rHLYCjgF8ZRm|>R+(M>Cl+a)MdQ?$vvp1U+ihZ8Tf{89Pd#@ z#DW3VbX&TD z;5KdB@h&!PMI^$D1$wI(sy?5ih(Nrfe5EmeVOAw-%(n}yb^$zJG`hp*98vK6SB0e)0p0sa&dW{_=2%&8Jneu(XCCMB`H zY8|Mst-#aXYlQ-?`mbA=tD;86>zDLh|JNqq;o{4s^uJfKic0}A2_aRi*km|U>)Rz{ z2XQ>+2i3Ep&T`N*GMRqD*3Ew4Iew(q0oG&#*9 z0Xd_PSD{@d?CcClOEH5}Zw+(GA;@QVLRI|7#o5QWK59nVjz?bnIjMosj8-w%44Bnj zhpQ8&td`6FY$pHdf+IV9=R_`(UD{@OTXd+Hyt_aX=weU^Rt-H&zt+v01>ilFIMyh)+Kd#Y0E-2l|(vE9c|p0*6gkir+>Y5cOJ(mbymeVAb3m_TP8@{ zkmm~z7YW*cldS!>dj%fUbMqU#SZ6h*=;Cn)yHETVryzyK!G=71_EXl&34jlBrRUMP?f?3z!p zNKj-Y3MTu2d7P(9S-|^?QVk(y$wPNQ=4()euJkHtM>XpE6Oq{P%b{|NR+ zh}@lR&mls_r4y_fzxl@FW_ZRTjqvsSy(bs;nL&cRfD75ZH4>apycJj6e1zdV>gQoi zTzTNq(f;nZE^8D_5|#kYPbJ(sqwAd^LPQk$_y#KqZbdvtk4@I$T*6lPlq@1`^Mr*ymUa$JM&+M)%Fhy$OKK;LfAel)J1l{lg1fjs%<@UrI7HFsrq zflQ%w>>!bd384iWVEF}`7Q91a#4D(NmyrSNm~U&!Wfc^%;YtX#tO(az4SBvt7d}ro zxncbCj{wcX3?#PLC&mjmtLiBJ*{P|M}o=IB~eJHRsyK$^9oF7ACnZK>lIkf@zHp4O z<7^o-k4X2rhG}w-P#uxuoE_}!`QmUndwyCE{-~)Ba zw(Zk~NHP?B&Y%w9!3QGug@t)-zF1;H$vb94*(4gzY<1O^jp*&u`cE#vI2`NUzl$-0 zC!1(HHYsnx21jg$fWRV5C_3^9#)YuqlPhb<5FUS|&}433!aOw~aq-L}X?QiFrIILP zqRc{@S<#A&D0B2S|)y-z$`J&_(U+U!x*Uwm9;C1&(86oZNjM7M+X zahqBa2)qn6FR9qeA63skF=S)!MEFR@A6_tcy--xx_^qYiy;KD%$g>hCm0Zo_AH_9| z3#|Prvq`-s4d-g2TpHrzyKx_Hyf%`K#6uS=nrYm-j^enL@+_r?74lcd0@(iwfWM@& zf3I)Hz;SIJYMK(c4Cv z_B=>cqSg7lz%xu}nf7<+zd$vja9yM#ayIHQawoz$Nw|(t6`GF`B(5t-VW2gT78U*A z(=A3AjM5E~QzBc0VlN@zOcZFLycMIeV%4{)tpsM%NsiRHL2@ENZk~{@S)vHU%VK4W z7ICDEggtxoc9r=~S7JB*KnLH6b$Q*@vv zkw==#RW0K&0Qp?=IO-X?`e}?(R_5!s9XT5LToQ^KT2E&H5n&Oa^HA9tBElm_88^f<|S5BXYQOcbOuu{66eQnUXQ5i_|ybXvN$wjJksbOx{dEPzwsTzi%u2AWgwli3~*ZEi7$y9U9_}x9A5UuCW>*RgHB^!xD$f zXQPCVcJfKe@|%U6KE~<`O|sjH;bDYPlKp<`MZl(F`GKd{af#5bso}YHuWk-vWzvA%QAlZyp9NgKJfs%0C>Utv5}RI0#Bn+$ z`{!dX_hN5^byXWQmy7v>pVp}LLH{^Y)O{!72goc?s66y9C8sa#stVl^Hc6UvvjScR zf0yBXx@zQ}Vp`}>6w?m^383xgmwB!8g5Szh*N^!iXd5SON+qi?p5~F#&OvPv>MjS3 zEV!x#bOcot$@`$%6ekaTIAmCwY`iO5EXqVQwtAC$kYU(ZQ4WCMU~T7t$ss3A5>Y*F zXFVJBa@)&%u44h!67^3m5w@o7c#U#*wyEmg-jhD!Pe!u46L_B|uK%?{Ip6~jG3e+F zE-wUZQBk{MCW}~}sMP|Tq;&&rU4wvh0BcrZ=ni%r2Ftz-1$QD0$M*=b@tZ1>MEj+% z?Fsc(ER8%B2+)ZCINk_@)FK(M{?98jQl*?wD&4!9C`9T=S|%kQ4py=QYB`NWNkd%# z6SpX`^sccplv3oSmLSo{MVgHivb+?t{K4x(lSYpA*8r8sTH9{K#fFD)9FbXZ#+WFL z&_}1khBi}Q>iMJ-Zj>9g(CG1#mjkW`NGAyA920QpI6h%VPfP{}jDHOC8qyLnB!Sv5 z0MQsWuZfHLAWW_HBiJ=3Atjpbjsq@$Kqt=@L!O9Z=Lt`?lc^ zP2sQ=KkdS<$NZ%xBjRfl0BU}jJZmUcYXD7QZ?&_UQ80xA9%O_#G$}C=S;LC!yKThP zgfRYLPxDDvX{BG{!L$0+-PZMi`8ZjRv1r3rQoX_DTzk`Q7!_&HGl3!5)xOm@o<*TA zI(4ZSp`E!JIoySF4cOjGp0UGnW2gZ8=$=FpkOK+`+8Sn&y%B2+r^i%(ZW?xhxXrGpT*o3t@6%KM=$NlWYpcYP41t{dwX;hN6@Q`?mYIO%JpQ(3BQaivU)_ zL`NT+rbU<>hLEwIqU2qSGM}^n-uP59nsu2ZG)G$kDsfsVYic{gaoKwH4GZMd!F3N( ziUSLcwo2^I4Y+f*P+P-Tx0lCUW^Kg{`Ux2xnA19a`=p)-RnBQJ+DL|{8lbK5MmjJd zq&+39PT63n@&)>^e5?T+S|reffOzeZ&eJ#fsUQxxm%M=m^hHu_iH-l^vX?L)YKQar zEkr>Gm${-*wFB1C7{Smj1ZDw33wS4k7|g5DlCf#+lrt+;o>rIc(%x?Sq}!+A0rLLh zb~co1qeQ-bH~zuEMh+Z7(2jg~ces>u!2LF)&I7ywO&YcNcB3heh{)Sqy>jJJ4wsS@ zmwNObkuL>c3Yi{7E|#%gqAbj23HgUJCQsrb=l5(!E zP{w5;OSUJ?7 zty^gxTjTr^IAQfIoF!C_A|nU+f!qu3ZFWhI#D3(ZRCZ~jdaV}6e3v8cyDd8S?kz_B9 zC=OSB0?P^2ndmt4Y(-v%9$d<0fq6qWdccy(oP4oYwAh>+Ul-;z@{FewuH&*msT{{4 z5uz#d9=|7^BE_Q;R82(c4!`}6gi*awl=E~Pt;mRji?n^Odbc3u?nIMrp*#ftRG4eklJ#=@ZY3zBx@XPZDNBQvMN zG^mtW6@9s+eXge9?ZI-?h+{jHVK}`;oc5ikD`9?pS-=5t;op!4y{BmOC+>mQgpvp! zVsJ})2m3RnP>dV}wd#Kzg~6%3+37i4Wu-qVnj1I}9}%=8*7b2h&+Ecx)WU9YWqgVKp@w{)^&Akpsj@_xb^DTpb8Z}v9 zXEj9`*&Ww<3}M}~oBGD9jV24j*9RCgMow_Z@k?B(+ycU{V%Oq+i?T*4?_<|nF$WM~ zW~)vUpzLKr$J@#8HIMD+bZlPWvTtaV5W{R~=dwFER9#!n6d-_h=dWTGU0<*rdhV&tG$bXzb((>AH6xe!(|C_Qn^E>)m3VfE+(ZJXsl}9fh}tpi82UNc59V z_$T~an-FJFaQq=qJ4;zsINV)|bfjJm^uV!AhEhz|asm|2*U<0=Qrd$fm|x$L-2-l| zb@qz8kqH<;FCyfICMy>`+0|>zKX3spPV0~5pwWy~o98n}{NN?W)LRu#kgKEe->3+|VCy^JB_1r+uR`=N!W{Es3n<^{mHWk=L zWC<0Ltd3prybv^Y=5j0mW6FrRd}Hz>2qU{=;D`))c`-z#UT~cDw)~6jMY!)_j>dQI zX!T)G-q0>m_iKC6v>disX?r8XHa97q{OgMbZ(j||D|m6nV6fa9>{0LBLBAjJ+VnCn zXT2UX4gn4o8F^7v4CswG50I*1w~)AWCmCL7?p14tV3)-g<7x&yW2d=~LMBDJzzWPz z(1|q?1xtBys_Ncd@5{A?07hfWV%MU@X9Wv-GANm=1j|?t4c4R!2UWswocGtIK^Gg* z&wVMhD}?1S^4-Pd)rw0#YLI5VO9LCmSpap~T=}kwd;h2({l+4xtY4t8c=!YDeRI5` z>dH%>RL{6gk+hs~L;w2z;fM+NxUyBVpFsv!Gj?Ort4k8VaCfO3dbuc?38B(ef*j!r zID1%})B5hV9Tu1+cIZgVbA=wLWZ#T!%{5-C;8Fh7s)##UmhYqL(NYM)42p1o0jz$} z#PkbH{CUCaQ4}A^*g)NyJm=1P?_LOGz$@xe=bFH&$Cq4?f2p=NZN=-qLGUlhsV`&D zyM&OGn#P9o-lk>%AOq{4H|_M4oqng?M~0P(Uxqcw#aKS|oCwc05dulPm>vA*N+w^9 z2SoAJI51ZWtPONnQtY?3$w~IlSAo3;_NFDR1Ze?XB8?5wQ+ zl_44NSvcsK{`>d;ok%u%CieehBJm;VM9r<7j2-alM6L9ljD?L2ZHq1Jth~#opTD_}pV^)>-LLoBwWo*g9^8Muv_C=!DP7F8fo1@MItX-VtAIYcR~9YiAMHmwK>Py$ zVM$m*8Zb~`1HHPdUVpPFY=B^Q!fOB>csrPAK|PAMr8yg3^rAo_Sl_8$UqHY%e1Q1m zWYnK{*s?Z4dU1B>KW77WG2m)n;dW_IdSM|%2<*APN$~P^L;G7t!Xn*WUHtTF)Zo$f z@`%WwU2*JUd!Rs(eQtzTez!sXm-K2wawhnYynSN`;os(L!kdR(dgvg2Y;E}a;K-=C z`~D3=dH`She)%b|d8Z-#-_R@X82Hd%8885V0zRpq$=}`Zh|feAprM62+j``9#1nvZ zVjcJZJTN%$GgxHMeey25!1}c6%)EFf5JDY&R`-B>oS}f2l%N36a(8Gv)YySegZcvM zMU$=(1-p}brByKvN2`9=v~Q~0Xqz_;@wMu$#800Rbh1=xpiMgG>^85@PUAB1?f8DRpya}??X zd~rhz11RDF`W4y_{kO^h*dxFQd#|mBywcGsETr?XCX-crk+>euYX-01;N{$@C#K=U2XFOF#e? zw*3-qaKpQTOZX$a-y2^9jhnA?NBq<5bxLUQiWUS=5XN_}==Nk7(@S&USH`n|bgu@w zb8v^21R#v_8}QZ>?~7@BlH8Y*e^vcH9D0iUh9JHfJ^60E z)wg}yAC|Z68%O;_QiJSLozR8dqI{lmcOgaoeckXeZ}_ORnHzOu~zUE|x}8b$Jp+GKsGqtm6qaOv|* zNtE8HR^!iky+hQZoaW5hCN20U+#&^TwV^ZjP)hUW#+3Dtf(vX^CJdWLmrL>}NP5tA zYwAcNuNmbXoAOmEmrYK$@+*R{1hX623w2{u6g!E6TcxC`W$=Yza=n^dvs*paL||^h z8VfIWiR){)#0;OW4yAOMSME$li|BDlcV=@*Qp*N`v%;ncI{Km3mAomhEIjzOH3S?& z-SEpL86r*tMB)}~bXhuE__7VhtoabkN=Q#xkwy)6H(sI!yyuF><;geO@JoRp>8i+J z2t#=6U#Tm!)`WK3=uCR5R<@1hq}Sc~$?nbX9`VJ$C?=O@jg%6Uq{0rS9e<-J8m9-V zaaC!k8!DHly+5s{SJVUxMx8i1ETCGcPWlqVb5g?7ZBJ2IkZiS7AL8YP)3hLm8z+1d zMvO;#f~Gr0bOtkSz(#rILy>T((o_)fMp1d9f}KJ%bs+)@4#ugTc{1g0Ly7nl1Tu0| z;>}a~C6MjP8X^a_6H?WcItjH0PAd{-Z)FxkCzz2vWlA-`t71Bj`Kn@dR3h0; zx1kKB&6%yGjtN_YcjaFM5I0j1`I1)4QM*P}Ps6lO-O@7?oeE_<`CP4yYQ1adRa{oHn%=jKr!p^AdyaE9MorpU-C_avy)uIN8+m36~0*WR=Q*w6^`k zQt*<8TZu?{_bc#p!b`sfAR69}(Bg|ha@ucpN+0F;rkV9u#d;#<+_nNFkZsB<72S9& zABJDr)dk+&H*=m(x_NxEL!$jIHISC4xH1aGch)U9BFP{H)h9tHTo-tzBPqmgRFZ1N zaUaXUD0jo1bKC~%o#&)D1=!sXdu;ug7kzGQ?Aa_3=U%zp%p&tKyiwTi3<$p8v4>u5 zB9+fl5F_!Y6&>G{CJ!Z@ve`CV{-Q{rO2;-3pIFqbA;;P7gR*hcBwwzlzC@sxJlU^` zbfOB{J`QAVfz4X((htjk5TYb%5ET>Z!Z`NLFf}g`pd2@7iot#>Y<2FWS+bTQ~_LAJ2)o(IPYG zhF!PkD$4Qb&)ro_SA)2!I@SVTVBHNUu2Z|={<_-_cMJ*E`|&wJ7qR6yI?5RAN25Zz zkyD$v28!0^&^fQMpp-qI8;t`GQl`eSQh(6_#?YTE5T4oIVp1~Nn|`(I=rZid{SX7$Tfr#9&0EAGy zEMLa1Xj5lmrbHNYUA^L8Tckn{+Y z<|)SJRY3hX(@?a7gW3$lte=?o3U{7Xx{VgyY;j589VwTOIJJsiM3HH`zNi<%1gd+` z{Y~u;)U%OgU!-{*bQF$SoX;ehUD?&WZeUtbX020RL*BE6`*g}XMxZU($HJl(vg!HF zfuqsbg(I9@=P&ywA6a988+Ib$46TmSO`HYu?~TaN-w*g?fW%jUs*zkp$+G9BxKc5) zE%35&#IQs4qGTn*7CD`UgqyqLMU5*%4uS9lz1umhd~)I^bMh_3U1~$vpGa_VuT`=l z?OC+T9~9PRS98mHAPTfHJXGX;H)sO?(aF0`=BctKKH)XVEhRra2C}Fl*Nl za)k1S&HpN#QH}pYxawi)+-Ab3%gydBSHu!-aX+PB11Ex&&2tgK`9P)jRzV;qLs(6L z+fr@lJ;`D?7@_Q#Mw_aiKO1^cxw6W{1vJkVZ3Yo#^aSsMXp5(gI306w6y@SSt=0=LXH!g&wDTQU1{8rA|~CL}WU84=we zO%aI;c}abJfBPl0x5nNTgVtp|DPww4Hy%Q$IA7u?fRV)eLZiE9MSfaN@oeGAs9hVInf zxW(MhU7%w?xkjhhteB3oh%lw=n9zyP2oyoJvXbBxkh0Hq_^cgex9PKv(|4-;CXzGj z8@a(3irZcf#@7`&R20> z%p@@d`Ruc)^G7o(TDUmg>hu!kWHkPu+kExxC4HACUxOK{g71X2=6m8;iGoxj=@`|< zfxBHqza75d4@No}lZaZUlIfaKQ);a`k2~8i-d}$Gr0(%%hDN{Ez2rbAKOjSfPSAA|M&FOu{4xolO3f9dKy_XCz*+%ccdnmo2mjZ z=6{7f4TrLdT~`{FX=Tl8Hvyg}&z}4+0|61b(yussu6e?Qga?Bu4GioZE;Pnjr71_* zEb-kv39mUhqjeZ~Oa260Sdk^Ri&(9=(&)q{4my&RB_m%IYYT9g&S?>56LRzXzsodd zO%>}3XXp~$w8$&yebKaJxu4u7SPZ$ZC7zKjti%bidmg`@$8bVQp}-^LNN%UA`@^j3 zllWA;lOpPABQ*XEiWY1aEzy@Pfx2LyRv0HkCUdQ1KO~DkB-i`d5#mIsta!P>O1_^= z{UpFW7B?IPg|oO>+9o8`h3Xe+&s8cq;`=tt&)x3;nwknzO4H(u14ot(@%(E44otc% zuYSvM^lH*Vxoz-*-hHSd^bWus+y#4Hy>FxhN|0ci&eETyNyb*Ee>z{UZsx67fk{S$ z?AgXhz@e@tA6r(-gIJfar8^B!Z?wAXgk@wjCLS}SU_m12SDkprH(xQP*XrFv+&|R|**GQmy0jhkaL-XW`o`>>`W=8A*o| zNWL0Tya-gb^(j$ZiQ(?2`~RRS7O70d1!lue;Y2WuGqS|+2y#|DYzy&($O$W*nPm6g zIVMrZ)#lnCt?SPZPtKAE*dGr|t9udH)`!+1@?v&z+g>OcPxDa=M+HqXq`i9BH>)Bh zDdV_rrh7e&oSyjUo9Pf;%`FKiif1Eo{qmkBVM(q&)9YV999OntP5lhf1(D zM-2$^EJzQt<9TqG5>g4{V{T1im3mh?3pg2SiNW8a5r+Pm)ZmTyMOhl` z?E8*tXGc~?Kk~PIF!y7V8w0>I!M~c1nbyoam~I9{LDkIGs=IUhLSg}l3tTM;wry!l zeqpn@pjZBX>>1_9vdQ5e99HxUt;X6(4!@;QQCHs1VuJl*P-+Zv50b|3%St4Riiv1Q z9mM9gHiJnvD0yOG%hT(eQbs*|LGVeUq*6aCryj{Kz@wR5D?0hzNOf-9yIcQR$zMvA zj8v?D7aN6No${1*oSjG=`{pH5!dUu-qs?w6a4J(+F-VyL zGRK-nt-9TTb=3^_rNGJr@pEMA=Og>A-ubFwE?F$o7{s7lPZ39xY{m{4Ej6}&ynu-VjD10&on7K6jor#%^iZGr(>MxQ1j$cq#1imR^W z0QBOBkodH9TJ*;Nldzw~G`>fLwu^}kbrQ%8!rvlvqv>kJxlZHsG01n8{K2l#d+psn z{_f73d1M_s(_{jynA9OY9#4(SLU}%;B&9PS?R^AIgIO&$dz>8m&cCFQKHlKIS5s+X zVpB{)UZ8;Ppe@8SHGI_=)-Zw=Ir+xWItGnChJ@KvSqsa-p8mLf6u*N=pg+v@xm&~) zf!+yq6uoK6dAg|@$>`sTHpLU^frtnZSET*ez9%|!Sl7n>XfL_>UUA)*wsJnmLT66s z5tGLSc&ORWzo~fc^1QTQUlx^ogpb?=+B-)Xnl4$@8Cdp3gXHESNTk5h;Y?jQoH7

fz+cQ!8*O8CR0C1}z=u&peC+!=^X{UF({c{)&Rm3- zVqd7xpUAD55Z~fq2f2DL?LW25=!rv)!jGgHJKy-jR&M5*)SPYqK~JX?xW;9v?U+O# zjf?+AV%dPp*p~i&{6>xhVt{l+3UjC|;lqSFE zN@G7bqSapfgA>(dp2Xuc3gGl(~RQToukNV}fXnH&$|Yh~D% z{(+Fbns;jG_6vDuHOMzdAtRub?S;1vjHCZ0S#{%YV1ghee%Hs?_yUsAs0p<=wkkt! zd$rYN%2R+b-hiT{dT{v+vkslsX#+|F*1N$ zgWS^;%qkUZ&33bJe*UAS>s*?}*2UBvwG@05h;vGFpN^yI*K}#Rg9#3Y9`VqK0&&tm zrWOAX=!{)~g0`wGSq2pIS4ft|9|5U?kc1WkMT1+RZp+Bv#PF(7Kn2{3K0FP*Rc$^4 z{|G@ty95qL$%j=05u1-+cB;p$fkfPVluTzWe~AVeBx&}>v8Gz$sAt~0FEx*(y>f#^ zenKg^;7C9J*0&lCk{ga6w)17FlDEn$t#h`fT!H1LeB`)?zK0DfqS6`i3{UMG$UT7p zm!?@~F0}kO?8-6MQ?iNwMNpp7gNaI=&(JZP;&gj=5&KG`c22q{rJeWCAqVC`V~|2? zYZ(LmSX=FOF%YRZb_71%HuR*gB+U~>!i z6e93yxm>iJCGeYEt;(=wVU8SV1$hCa&MITK7B>}@8=U-VBQI7QeJ#Krgq(@SiWa9n9EL zh{ff|eDTk>ScDcpZAm0aY7IzU(LHaG(`EbSb@md_dUY>fX?YhPrhtMrm*D<>*xpEeKV8&;~ zs@uReOU`{}12qfX)$wH5l8j~KW1^j~z4WD=`)i>ct%HKQT4c*ER!wD>MVYJ{!%AR$ zfv5CUlrcgIr&k;$&LKftrOe1gy6S146g=@bk6I14|EuzWAMpe!lwn%9H=1K7xnAi*=i?>3 z`N*Zozt0sSrt;v@%frDk8+`P>{vlrm!dJ>GqH4OcXFvORJGBFf+$eDS&IZ#JU3;^i zoa6O`AP+VR7sX){k=&vVz6hJR3iWqqF^N+1EvmgAXRI4%wgi z)ZVWouPvJ;NkI`Enc2x^@W=VnBkx8F%)(Nr4sS0eSW0mj>%4d;i6f0UxlT}F@o+qIloAidWbeafz5yC=J@<3C0q86Uw z7{1=C5eXk$g(h5JvN@WT^8(&V*+|CI~o^i!^8bBf)LNKSu56S!!673p-@XIO|5#M4bj5>@PEC%WZjo;*>HFn=y_8 zN-SWMAEus@)ucvCW^Z1fz`YvF#XV;8ftiT8;$!oBA7-U4d{IS#lmD@$k^b2$(9_&Z z)uCb3m5V&8hUV%Cy-nAqo4Wo^A?7&+9qjR)qo2iP>1K4J&_OW%cJo>pcIg(wi$lSd z>tH;*l1QyIw%zq?+#wxF`efn0&i9R7U2ZoXc1|YAQhfxFi$+C-G_j45R~QM?=}rQT zIj?^9sb5_)LdZ;x)3tZ#YWj-jSU5Se)A_W)<|xT$CCKD#?;quS<;S__BgjJ|7-6s9g>(Us`_ zktBCoZVw(}QnE-_n4|_a3?Y;^n<8#zrHhD4H!4TDcW*9m?ex0P98;)c7gFl)X=P+d zWSYwsn!KTT@B`Rv9c}n8sUHjDe@p#XIsQWr$HBc9ISgol7B?}_xlBFPuR}i4@AFrt#1OWm80BGbFD!5Am07XE& zoK_$RJs&D8VB2B+XrFG!Rz95fz&4|g4-npl1K{i6pm3{i5wLMqpS>Iw0_-mU;nl#b z8}){NHh`x+HU-B1cODXa$rU05IwT*ToSd9)d=oeQ7VJZK5cVFV$QrQoz>PjT$r{>S z6oUZr5zJ2zCOsXtz%Jg!PnZt8ZP*=1M*yH37)?;j9X`ShA?dZbo7I&V1xc{TX@$iX~9 zH?l21YXk-$0vHgW5s-I4eKml!snOh9H4h&<^gFv#yGLALeth(H=>D5nkTrNq@LsR| zkM^K=eSpCk;H%R|yD>jRI)46sG|M0W^&modj2r&t+iCqS{=4n{F2Npv(tj* z+`hi)+anX`FiwwO?}0bFylk8;=)ECgpglwc6c7k#NC4sC5dhy` z+6VUUzVhEz%bokoH~z2Rxrg7Jhu^XfJ(VB3!QWk2N)HasZ&&`W>)+pY!C86oTYli1;H!XkY$({b zZS(#g_9cX`F#;=pn*zMq-%Axi|C`W1XkZQ>T`}@*q~+*qs@ReB4ZpN$eQ^7=oyaI) zE1_L~{I*#D@O%mG{Jh;3O%L7Ovf6iXm+jEsY}0?b3W=t{Y(K3oK!Qa82-w-<+3D_N zwSfi)0q}pi?wdiqzE@cN$?OuBF0M5%ACFh;uO2X)rlzMnXpc|Mr3df97x!31N^X3BFatvhP*41+h` zjnQ*`CUxyTr%uEM%h;XSszjFVYNyED4Rd=Lps6wprO)qi#fKUoqCH%1My5UYyXgstQ=Al+5u*wU&#`-wNl)en^{y@+wYGO z3(k~Q!5d+0u(BP1%XR$IOj!j69Hn2h>x^Id6Z!!3smOi=aaXTup$(BS33!C8igce6al6T6g$sM z)L?;4Qm;c}o86Qd39~@Xh)jpZrOlHIZ7MvAmD5!6mBbEv$}>EK_Z;?2k;O7!yOpVE zg0d_snYrD~d%N0}q{vor$m>F$-03wmC`S>EfxMWTs3T>o88gAJ9x>cf zuSxD)X-JcNvuvc_p6$DC3!&A0N(U#C9M8!qv@1_<_$ZT<8#!IQ28k67WjPruRq)2^ z^<#`@{X5azo20m@Q?#g3HWpz}@iXtWZ4NQGK08cAUSaID`>B`>P%*rDusmejjv&t2 z$!dUHV#;;jQuMH}uSIG*KFBEe4>^by*Yihd14UE~sCC%+dN#a8=GV9v{Tlw45h92f z6^wyksIZ@8+vf4M!gWEI~SI{swbZ`tbpoyL_T^Oq>lJ_qk=%x9y|c zit%`cqK-KDdK(L~i$$P4VD~O}J8XmaMjX5_m|IjQ*tv3fmfPC%o6N7c3)&5$dzrlE z>iQ_+(j=C~nlPeQt>1TD0tmg$Dm&<+xnt@1i9W{5i1SjqL$HAoM;DH|U@pt&%rjDi zD(pZZlz9KgC5o?*iTA0e?d-;rPgP61^(F}R+qJrUrJk{w5kHHdji#6Qvggdq6_0qw zOh)RqzTBN=+4k!6OAm01a`q6KDwB*FKLD?kPfFIq_BA@4uc4>AUo2J{7!vBI=ohC$vOejLwcQ%GWXS3^ z3nV{Lk-hcWomHmk;%QHn%5jMv|In7iMj1&4g9t$U`MJcOI($%U>lf%$uCm{1q_QhG zzR6TJXUfX^`r=u_^LEy_N^2yPTa0zOxKzZxJI@8DG z3k^7Hc2`sl{P~_8zwO1Yv5)wd;hOhPg8B2 zQ#UEQL(RUF3KA`Gm;|eLSI;|5Z_HJa^#_iUiHGLa4QzBfL|?R;MWJigFKcsQf<@E~Wr zXVQ&uvnQHaeJ_PmZ4}o_`#y7y=MjMonX#VvcizSyd?zHnw2@amTY{~qbfEBoqomsd{>;`1A+bJE7_rJxEi+y$VMM_uU z+Lagb`6AWUyjf^ruwJJVA&gJ2fK00h+8mcc^hAudVdD|)PCBOQk0#w~cHWq9pOPWD zZ_o*N-SVikDbTtT@so2nmy~_gfL_xxVWNw>A zxX&zcADfXDb%U)LBm$FX)&rACrbrlL2(0CXc6<>pqKjKzF{pdg41F8!--{vMDLIm{ zcx^)=oCKZb0mn&=l{0Wqv5GI8LHE?|(fF=q)|&TXja3uNNYw_h+wIul2mPQGF|{^S zASEW3PhxOwB}fjYfLm$PM%&E?Q{Ru2xTtv8j;gO0$*3^fL+Mqk!x2OH?tMgVa+xzF zjm)zuqQFnO$e4G<_v2!lmwm5_M8h(rf9h|*(9sfOZ2xUX&+*K=3o{0Qpdf5b!Du;0 zx*I6$s}=i_De6cDmCU?3*hi{&xI=!E2-UehKB;-x!>A9AjJmP$ogq*2_&Ce+(kS;g zMyud7ga;G=%yBq7LhAqQT}C#n1Usiu!arr-wRj^c78+~MQAE$u(`4$ANhhNA5RLtP z^m>oCG@WWIn`p`j-oB*d6*!??=;(!G9mlHTEMSC9`SV8^SBnn>UE8N=<(Dim&sWj) z>AKi1(P|NeR}^hICYa&S!LJL+vgcD`8Z;wwWZt#Ezpdm6QS+Fg)S%WUw7Nuwa@&y0-XPuSSUkk6MlXNVc;nmKS1Y1?}&V4g>BMn{FwC-aVc$vS? z4xp&nguj7<($t4YkNkD{hiWAYoTCWPNyBKe<1796N?oATHJ7;lGdFG+8E+`RpY|uS zDb-5yF456w>cZ)Xa+)b=u9p`PC-UH+nyBPcgfuNP4zPes$C8X2G-TZAZfWrA{LW~& zzjf2wOrTa^ufy~38#QEo2!>j1Nz~Xl!+?JgrE`ZGed#vk)iE;|KoVpZD9z2CAI44W zBo(o{XYcn(qrSTFQ{%wJhLXkSxfEmdX37$(a00!?X|DLCfc|vCG+qISx~h=qVpBwu zzQLv36|zgH3_CxR5h!^ZL2oVer7B*=dY)oq7e-|I*wkkGM_N zrrQUecBn^b|L~*@s6%) z?eFxQ?4CSE2La23PWN47oe;5Z{Z4)|wXTi4Xf8;s%=COmzSsPI_{{Gz_xwV^?^#3^SO9Z!F)Zd8bHfzxNR8*GTT*4Xj& z)k4ov;&Lw$l%DsF`J*5UOG|H}&*6>yp22IkUG_$$2JhiA(n ztw0td?6HB3!NGDyYiZByCSCq4qy|o97mwYAOkZ&btt{<2 z2c*S#i|`o6`McY)r{vNl%@|PLXx2^)^y5)jMC1LS*Oytvr^ct!$zc8-#{*B{H^Nrf zlG2F?@nX+Iixh{c{Y&ta5`LOToi&DfxRPD%EG=;kD1eWOYHmhQa?1ofbJI3L2ZxGS zY0P~Ut@^7e=75A#LMAT3`)rD2<8g;R%6+rIS?VTCa_`$&$*Nt|Bl%SgB$1pCH(y+( zR&JpJ+`w)2asjUvjUH1}Tv=a*}uAJL6T(Og@cae2q+;*OEPqyqO zAAyS`g5O*)U-Ue=fW*rmYiBOt3FQpo#@%wL57Q0Zc`y3b+kR|NY}SaOsLP~eO-q`l z-aBs<=le7=DXafhdST(O(O06Qd8}<_QRPNe22oteUStF;_hBE zLdP^%np8Smif$R}RJ*+DQ*nt`&xg*o+&Qrlb1r5d6T!P_tSB+@#4ePvVxgge4NQ2P zsdP3;^W%1KUSSt98%`7?*Rj}7WeTbmW>!=Q6+rBfvGF3@ejoxgn z2AX@WJU(|WAhp26vKx^qKS-CylZ&Ec?cV=Q9p`;7F{{Wx50H=z#PGx&P_t`#g4qUR z+4wq+=qXYlPe#n34DElPu3rq9$^GC`jb6AYf~T1Sx9}2x$MPu+)DzlGe6Ql8Hct4nLUq1tw~nxngL(2Onkn#p&@)>`>zldYFK{1{79`NfN>mmVg= zVkks|mC4Y#`0ig`l5X4uS)LF1R`j`je3sHb(=V7gjbQI`n1~A(Qo!mR84@AdD6JuCJkjwun0!{{^0Zl4TAKL z(vMAFh^@jT7sB~eDIU$oOvGAr*-xkuVF1kGh^&$`yThyCllrwN6n^=0_`P+jBwHac zmz>ugXj$9-q325zJsPhX`;@7YFWbt?9W7&DNFBvs)J` zzfgb=-20+msaq)$NY`gHD4i087Bg?R_I{fL%a7}T=>*>97sgP_BB-MCin9Jcpcdv;3hfy)s!K65OMbe5)P~$J&5s?(A$?-&u-Z$~p{{ z0Lw#<`r5^&wHT-1Ed4aioJH3HWuv8~mbxz-bnACROtl3Uy#d+6oL~Yw=$7k8YAZ6D zmn_KrXJn$UREkm7*LuAT`n0-$g*xVt^=1oIU`@-FO$(azPsG%*T9= zH}VzHKr3(J{>ZGhEa8OQYk zS&+Pgi_yF^4NI-LwCZ}W>(M!dTwjzFq;D62_$nF6l7VH(ojxoYjy_~B-=TO>o_YfI z6AM=r&sakb_iEJ$WFymW*-I#!Tn|^4H?KU|p{2^$%-#_qrhoILs%;Y@7bQgz#>Zk! zT#x?tBTJ<`7{<2UqA$BtsB#)vnPW4$coGDOE>qxPf^8W=PMcV#((5huDgR<&+ZCXD3L_;FG9WIU!EH^exhj=Q);hXagngOxBz6rVq3)IlUx_x_k zoronewv7V|e?4pt+)AAC*hoSfq>L2LhrAM{WS8GBIdm8Oz232*;$2yTYo3PJJpyq_ zD(=?Lx5*W`yevihS!(24&)s?qtY{&s>~9Sg@V|TC7?Tz{GpQiQe=IMq%Grl>vaSSm zUB-$}0Re*Ntp>x)Jt1_<_Ne1OnwoLDUmx#&NH}XYflKbOE*6T_O}F}-Fv4|cG~)Dx zmGGT%f9(Pr!5~Z`9tc zbGYF~IGc08JqH`5Q%tNgvrWRl1~5}X@w|Y9RAzq;OOh!wC?F`xt&Y}3E&Fh^e;PTG z$v^FKjdXY#BU8zo9e9uf9=xP8gRDI)J4__a0qU}5AfYXmn(S@6FMy#0Yq+Wn?r6N| z@GcxFSiT+PDg@bkyzi`>pz`fET0@bDAm*y2!P_}+`N%I4pybwM6aCf4Ql$wDC{gh& z;%OM|jI6mM+{Z4ekiASz?@BHW6vq-S)MV~hqL-z)`O_s(Y=KdUDt*76_( zNb#!b4wjF2nMQBw^Jy@Y6WgP$p5&8z^*pzcO#}SwX!bQXJhSBqmaf!$ycjo~!7Q~w z8h2nTucr7M2--Z}6)NNecp@PNnvRc$hOJZ{^?~c=li`z;AM0GTxN~pKdT6BUfNYZs4a_qt&fsBnz0 zHHsEXm$unqZ`iXzk~C^8Ldm)!8c|m4GCAm?C^dxO+Q2CXy7375ghvdr$mx11W}h2X^^wp@r>(69iZLEA z2@+ux9m)NCFZ>NX1M@EP;=RF4)j5`iO`vq{+&RuLP>1U%X|^D9?jO691kM7ci19Sd z=;UJ;raS3*M~IU<;o=yNSD=AV70%ZM_m*6p08>@LnnUO%6a%ZQIy1T(I3&WxAh#R7U;L zxa#9JS*|l4t^m_zF4d0A7`F4MlO9P^M4T%&qgUFnUNy)$Ul={A{sPz}(jb4sVx2=G z7qEPZ`W=OVI-idG0#&X|Zp?}jqDPU^w(LKNqExYnnYAetUYy{ls#k0qz+kr&HO8Xy z>aF19_BoXU!*lhiw2WvDo@X={D~57rR7?deO41<>I)2HWakNJGjLUfaUJVnAMw+T7 zr(n##8cjp%&%5mulrF8NXeDGN*N!PA#8wzvi6gP94eK8fMXt80ndmA+3(uy;?}X%p zY~3@PgKF_{nj?xBc6FrVs&0B2C-@X=$@y!u~2Tfkv0gbUdYHTgJn}~t=%kT z-9sS7!1Nr$yd|3|6&OvmI@Hjs12@kQX3y6j*S$bjv3aZh0e5kCJ*D(G?{Kud9Og~Z6=AUP?<#3 zFoh7r7L%m@aHQj!j8c|mQ=PXrFV=4k=Wssk+nIJ#6L5tL-UZTe`XPtzB<2$Euv9Gn z5;DZDpiWw)Tt~aw3+#ilu@nOu_Kk67aUj~BPxXYO+d;JrMo-M^BN%Hz^^9tD+#{Dl z3(0?45IydIQk!DR-hy)Kg@qd4V61guXJh^xZXTPZ>28SPd%LdozVaUFuoUAbq!IX; zY;Frwj_TlI%&Ne&yHAK@9?9-xT{Z1@Igni*%EvXwy6&OuA#l2-VD*9AkNRiNt5U8r zro~#GQtgQjWAk2q?wHR^q3EwUCVJXg9N;3Gb;1mnb!q8kqR?%bxib3|jxzTa(?}Ka zbn;39&4QP|9HpX>s)sLE=@nJ2TqZUuRR+rJ_rzfaWD!2|O62*cducb{yh%jZ>Nq7- zLw~)}m1=I9*8zw3*B9|;R%$1BkckV{b6Q!R#L3gr>`v;9^QA*DgPik4vx4u+PAOGx zCDaT$b4EoR#rh5bnz)UlV4kv-sT9wuqs+Y|-_9f{Ec@dMizPk3s9Dl9-!2GaluKVf z>8rW;VH<5RF07nk-)+J>P-w$0iAn@1$BtF z#)lCJGJO+jY)sh;<+C`C2rHis8#8VUWH`vwFUz#jkt&KcITBVr>`7d4%3kM z5sSCW9jLJUn>wb9f^nq%=rgUS&jI1))IU_m554t77I|!WbDMVh@g!%Db`WQ^g=JJG z5a?MTz@G>umLHtAKBq9>Zcnj3&8W7^ z*<6ch(U`dD?OkV2Lc;fa-~rpXo#MjIjywIderj+T@kj*$2 z;M_IS_Vz2T)P)8T6LI@8EvAIk6D9t>ovDYidCK$zrtv({o2d!%1gqfN@F+W?a3@N29p=5e>EB}0^%YvW^g<>bUV!Jx+b{!%c zT6f^Pb8L*nInEmqNXPgduZG$JcjKIJVmVpElwK9GKk$)y>o1dOa4|H}nnB4A`>XZfGE|D*&kaswph=OPus1QV<1)Wt`l@^tgm6lK|_`QdOx1K|j$ zC=OxK;ejVEMl1#=Vkg5+opa}2eV@Ib+n+tFWRJi>)jA4_!5;A-Rx_s$+5X(J!Vw6m zfIN879zwAZ5!f+=G_puH5K)`~`kY`u!!&!`gK1fBeZs^;w930~`}z(1G=| zqY+_D0ZB+;jSm44l0YJ0dHxwh%nJp$`IG2*@YKQvyUvaIpQ5Kz9K>?(S2)9%g(X(tJ~d`l4|Ere`3-zSny` z{$85M9^J=J8UKjWG{1cN4f>@JG_*_KZx%+d7Ob_Ws;DPxhyF!2utN(7>O@koU+1B- z7NgP$9ap5 z_$`Wx4EZH|`J;{%2fS~uh^NPT+jSduRt3p21<4peb&U>j4Is1_9yk<~3{-$H{J6g@ z(!g>29S6py9ca9dDDV#`b=K96ki zkNIE5jv9Fhyrg~`8R8?e?8(&h*s+%66B;p!#`;;d%T&|Yb|uvi!NFqlI`p^ZUT)LJ ztF*e|&}ZGP%jCE+Jg6uSqeYdrkTnlZiv+uFH;?Br3O(61(S3EorfJq&l~1DWs=xow z;?>VSy6N)_Iu`aU|7!Vpj#Y=-W*OP+_*HRsz&p2w2+6n7cJ^TK{4-BXiWCd=Oxu+? z2L@p$a-|*nGrkH~9G^pSncU`f5@I>y5;?y5eEH=<^9E;Sm6iPmkK1Duc&}17sy&QZ zG{F4A)CjI?uhhYz&Pr#FP9fj7xyWdA)J(6OgV9d(x25 zvz$w4^od&wyCo`~jrw&PWof~RN*=W?UlGIn0%VNDz4q;~eQO#VRKDfEt8omK7)eyp z^}((`fp*AO&)v7j(-p}E%-4GPS!GbPW<2kL%(Hba9BnOjbIYd#Xc@cKo)*ig$4lQc zITA`IOt2}YC)VQPk?%A)Fcl)R^1+lXHfbCAe$P9J3o+R@-kqSB>XfA2o~nG}RgCZ4 zT!TFu%{~`#n9y|G+H?HA$9gF~;iFR*!`rhNL0OiEGCAPfjyB9u3!pKN)nWW8qavJj zRL+ikI?07ycY^0HxlS#(w68A3c$k`@Ur7}Pv-{sWmxhyLP@cnH7tLku&u;Y_SjzEs zNImz1EyeK#;=2v75s@X96^Q?+KR?W>fs(E>x5Y3`U#xlx&CRijP`dEZ_Caamk%wT3mv>aQWyKt-KEHeRJ+$#~{{m z7kNy~Iab*Tk4s7Mt1-KFC``$0x!u2&P}kNxYk?KTah~P;Qd$-BnVTKcRweFri}30c zKEWI{{~A8eOlx|T{qw{p6dv7mNW;<`Lr7Jyn zkvO(gIsyr4NAj`rh1z9!TKutYqUp2j`{_9m@I?xFTB4yz=M|axjV%-%Q%rtyK6lyF z!!%`Wlp67RG#}t)I(L_~OpqeMSJO+k+t}D;Kboark)gZ2`J84$SLS*aN+Lt|{+a+w zjAd>RYkJc1_ZHo}2exl<%~4Bg@nc8owd=DqG;MwLRjc=<~g5kC#E14OLycTiKa*$jW}c)FVAk){e>Jg=9~~dL9lPYI94& zZq`nVnWUTyuu^+nb-wDqxIQ{>z}i%=90Fg0hFb2?4#Fp{0_u4HUgB0V4y$ z|0e}GIyngSF|C zyD6gjlC#3laoF2q(Ww)HgxO`I2}y2IK^4H@+rzds>j9%p&G%3RzaA=pU3R*vD^22w}@-1b%NWaqP#SX?2epFbvBMs4eiH?hi4TMwuNbGXjlg(4GRK zivd6w&qa(!0AP=t9PH;RdGGJ%qP1s60a#D7kIWGhx7*G8#W}|3nU~RCl@vZ%=b6JgZt*H7N-Cn zYsaHFhax9n0`1B!OoxP!(>fZ42G`vK!cm$;)fVhf48;UN%8vw4)5Ra>(iVJIjCqCy z9Vjm`%qI{M#U)X*C>|o<05uuI2n9qMNU=kd2eCWg>i3uIckv&n*bRU@1QQPkjFvJ6 zAO%BIXM8(O1LXX?S4K0oW7FxSMsIt(Uvy-{f4jvOi?csHd-(c#`u1~+orA*&!A_e0 zE{r!Ad3m|=y5Ge9`vNO=-Oq1&{|e~Q)lOR`MFFPX!R)y~KlTcLhsppsxYxrDV~0m0 zmUMr;dH!7t0*w(m^>7cQ3OBCOA_WB|izoVM(DBdE%zebWPCjNVE_xKYmAJWnco@Ew zkmyaScR!cDmj~HF4u7;iw)lsW)aU^`BVLS&l=(q8ckKv#-f_urdcp}S&t1klk6&9C59jl3OX^;5_e<)2e&-D?pN20H*>PU@10bS~IHbF@ zp;GPm;o|7=T`c;!x(=RX7z&6Af7~&f__$MP<$Sga-$x)(qoE3u6GuTrvy420Mxt~by3(&@iIWsBi{j4=RSubs$ zDw$vRM}ZETSvw4S%^cZ0rE~knGzpS}GJ;%ul0Q!jS<$yICmOE-acnmq-)zoleBiqq z2hhF?oBY^t--#JlPKwFLw;M3?&}(`b2Ig;Rkq76q@Rv%y!t>4Ik;gtZ#>dNz>4NQ^ z$U6s|Gx{;RfOd3W(ui@hyZ?$V-}F=>&2Oe)62IInz>_N*z1p|z58Y`~v;4Fb)bZ8g z^2mG(eR6K;SS|t&PT%bJAs3^kOwN@6Z*=C-HtYKX$bb6AG0Rig8>tcZDIcynLB|_h(&qK(39RJgN0o5y?HSU=6CjB9}jG)*;-KBX;#T^ zq-eaQS2M*u97Zf0{al~GMr+*{hO}Xr*xFwzV>=!_8bsV&7O*4pC2v5pw8O4r;Bx)* z%Y8Yy-CG|#F!$U5w>p2by0G83^N){j%KlpzH^+VMmC;qQfih}u_XRKBpXZ$&aBqyw znaW#XY~68;T+#hY*u>xc#pN4rnBO-7=sK>8CXCz;h@BohUw7}G@0+49cFZT)bBmPx zDTo}q{O^IAd0BzBf1i#uGV>oHbb9c<4S$W@extScx?}&c zi+`T~y#J8%kjklmbt^e7i0n~ev3Uk*bh*9#c)JI#bwE7gzVhATdA>zIWcM)a9zu2vtp6N8*|+2VZJJ|?beo*b z*g2fBM*2w`vhvQt(>2@YPBBYr(h)hZW3cG;=HuG@Ih$vu9pg?xN5^aReN=B681UuT z^6_fCZeUiK<2E4|M)F`WngNTj`yE^kM5oWL;o;L_7x%gpD`e~RE;u_dXcL@j^BuG( zx@7A_^cl-q-wU_+Enf(2yJVg_%-qet(X6|mb(Y{>RDF%%ZV^1tviql;-$~GYhTDXN z%e?8b$Py@fQ0BQ-dE&5PBLA8=>jkOfZZh*W!S8?N?Cm&+!`r#uf3sEi8WlJ8(2^FfBe)7^lst&~%GZ%wf~Jx33;jU^m>lqVcS)PcZb2;N&RgU(y9 zjxC_lt9(G+A%;R+fX_?e z9F(WOh^uQ-*JQs z&>+l}Dz3H&v#=Z|nBrUr+cAlzlUDPg*62U39LlR>5>Tp9&JO;-g3hHw8qoMNLni?^ zQ{vA?X>S@+M1svJSt}8WZ1pvqVNZ8hin!KUomJ0FTyFE!Y$;=^OeFD;xLFTfBCx0^ zPuorg%qAlMyEiXQCcH^uJDr)+aKJ{~ZUMq>7?Y)bhl9NcQLEF3jay~Mba5%_Q?t^J z*pM~Nu@qCuRad!N!5mVJt+L!%Kx@dGxZ8;B$oH9Y;PT)CRf=`3Qt5Nem#j%9uslwy z^DB!vRm0>sC2Cu-(jIX<+mH~mmH6C+*zm$s^nEdGjhkMP)m~^)TBs&gHePk%7AcKb z2RGkhMj>Y`Bm4IVK*dt$L2Zm&kKNp`dTXMOOH6Cboavi+Ks2oMd>11shnKhLG})Ja zV&L47+@1N^Np`SztKRm4uI^v#yb#1Si6FPBw6b$=cf7ZLU*^`d$v$*!-n&Jmp58X{ z{~EgzXsFsgZui>vH8d?4G0bWSF^o|e*=30gGh@aw_H9tMC~G2#l(mrE5K>W5k}NS8 z$`(Q@*@}97x6}K5-+R9IJ?H(-x#!&HdH%oWdH(m_=YQ_~J?H#?*JAgqXXAWuv)Xx* zGpA6NQvDDl+}KSXQPsU?TIIXoCfIi^moqnH^F1!TJ7bQRV$t?>TXX$=4aaHx3+4P_ zNxjmrZ)9XxJe>S-h)(|abpf2}m1Uu#*gHBP^}d%ba@fgbg7?50H4o{e8!JmsZXPMN z+d@b=FD;{<%C`hcbaXaEJq;8|H|4@bH?U=WJhEz&r8$70abP9WmnN>KP0Oe~Wsia=47~Y!z*!ivRfN;8>i#xa<5J zOIuXly!^)*E-%LiarTnpS(nD*(mF(s@s^o~vStgzo27j$8Kkj7&AYUVj*~ZI;!YWL z2~S^W%~g3OQtar{d9Zu}A+J0F7m>g|4?%YRkbEHY6=?Yb(l z7+f%QRbsPdari~@VB*WL+~V-H$AS|h=2hiKuc@lqOQ3vJHC(u6It!olP+S{P<-p&+mola*SCI5R)|f#rn}TWti4aDbD=o<#|r7w zAuS!A3d^)hhw=%Vva{NPCP@d=G2`k^1_n&K3`D8ThPGz7EZ4M|GHrmB%A;=-%Udy1+THlki9EI-@dH@22~Rpx$2 z!1a2M!0`P6dallQ?|(SGec^n0T9| z$xhpfb(VB8Lq<2j9k3KhU#~X?cauH{C(nBuWv*Jj<0}GBPPYwcsuk^TSecgA zpI8|>B$(_M2v*Usr3CvBfwN7ByBEfHU_a{1e1B5by6#Bmmm7c%L95uZE?qiGw;e#K*@S zPo)ByvtU~?B?tr@zx+`H*%JeUfT=+Uz$+L^2d)W$tE2wyCIAO64Mzzjf&iZo8W^HG z1y5B0dHdso$w5RsDD;osn(8ohmDbPq{( z^X_b%MC*yC(IHiA=CADgwsuh2xA20E&6B&f%x_AL>iw%qiPPDJ!*%_!fw91bORH`0cPVg*RtaL@e(3moGnzGoG*4 z>n@p39NQcC&>p_>eGKPOUF)~Q0cw&Pjb<<1C~p3{^{oAuC*fdCB=KsTpc07TAZI8D zrKRJ-t6@W-5q}nWHBN(^VITwu1~gjx`2_=wn!pg&KYNh;fZERh`B}q&ob`0DNFyC6 z8mogwW6{P?3=|GW>R{2py2T>3OpwT9pnrw{^Wcb7PauF`2(AA+Us^H8%*W17JaPNz z_TW%X&M`0qVtJCUtfS15citMDkz>sp{b)+)YV7+CvNR0NB_=8wKS)qMY$%rtzJyLI zktkT|c;E4SIJO&e=n{Ww2Dxsk|6Q-s-rMcT=&j#JnaT;mHyfd{)Hnw zp1gY^r0^)k(eUkM$~&cT-0xYic?ZV`Vg6V=lnvV{EzK?FCW?!tK-o#1a=F}mZX#;2 z#5y+nPT3r5c`N;zWh)s1Bmpj9X>@ZT%~rNjMusONGO=7(JVuG{6Lq-1oL8gHl35YV zULs(a_#`WR@WHUrn?@Cy0_V(;i`9ipBk%jz3YOEH(~-5@v=^Zj&bfFu0@={9%M&)$d+i<(x3;3Sr$Y}>a#H+q4TbK+=q?B!4FVx0VUE6-K7rA1;EGVWQJtEgGmGJUuq$(_w;KFc z>u<*G$?fSdf~po(#fzhw2s3FDc}bg5X|XIXea@Y-VmLDGbO5d z2hUc>*u|I^K8-tn+iEqhEli#Qv3#a>@3UR?ZCke0cU;9@mh7Q1A&YuDChNnt_gI^T z3Je8mJ0EA9B`4GFEY30XHZdr4NX?B4=l7xfh2`8KJJ)GrJOlWg z)!}T97;H{S(0m*En&Zf>tUeFft`!kO%GTvpk9ken3`5m&KL^n=4h;A)zBFJp;>@Pu z(wt97@>AZy9JqK`V@<(OcPB?KhmD?Nej`8WCGFT?yCal)p_9#l!;IdSK<@JSj52pM zLG-3>W@29o^RcF1G+}YZ$cY4;QsY)>Y~p%yPjSXLoUxKD_*5cB4f7h>u8!{!Dzi8P9%< z;IXZ^^+KWPv@s#=ui7lyKf=d9yi#>y7LL!|O-@v!tXLs^dM5Lev1+YbfFhUK$GzL+ zmsd0lP9v#37X1t64oB7v2TRLbFN@7(mr?tU +String} to \texttt{StringLike s => s -> s}. The result is less readable, +required a large number of trivial edits to type signatures, and might +even be less efficient, if GHC does not appropriately specialize your code +written in this style. + +Our solution to this problem is to introduce a new mechanism of +pluggability: module holes, which let us use types and functions from a +module \texttt{Data.String} as before, but defer choosing \emph{what} +module should be used in the implementation to some later point (or +instantiate the code multiple times with different choices.) + +\subsection{Fast moving APIs are difficult to develop/develop against} + +Most packages that are uploaded to Hackage have package authors which pay +some amount of attention to backwards compatibility and avoid making egregious +breaking changes. However, a package like the \verb|ghc-api| follows a +very different model: the library is a treated by its developers as an +internal component of an application (GHC), and is frequently refactored +in a way that changes its outwards facing interface. + +Arguably, an application like GHC should design a stable API and +maintain backwards compatibility against it. However, this is a lot of +work (including refactoring) which is only being done slowly, and in the +meantime, the dump of all the modules gives users the functionality they +want (even if it keeps breaking every version.) + +One could say that the core problem is there is no way for users to +easily communicate to GHC authors what parts of the API they rely on. A +developer of GHC who is refactoring an interface will often rely on the +typechecker to let them know which parts of the codebase they need to +follow and update, and often could say precisely how to update code to +use the new interface. User applications, which live out of tree, don't +receive this level of attention. + +Our solution is to make it possible to typecheck the GHC API against a +signature. Important consumers can publish what subsets of the GHC API +they rely against, and developers of GHC, as part of their normal build +process, type-check against these signatures. If the signature breaks, +a developer can either do the refactoring differently to avoid the +compatibility-break, or document how to update code to use the new API\@. + +\section{Backpack in a nutshell} + +For a more in-depth tutorial about Backpack's features, check out Section 2 +of the original Backpack paper. In this section, we briefly review the +most important points of Backpack's design. + +\paragraph{Thinning and renaming at the module level} +A user can specify a build dependency which only exposes a subset of +modules (possibly under different names.) By itself, it's a way for the +user to resolve ambiguous module imports at the package level, without +having to use the \texttt{PackageImports} syntax extension. + +\paragraph{Holes (abstract module definitions)} The core +component of Backpack's support for \emph{separate modular development} +is the ability to specify abstract module bindings, or holes, which give +users of the module an obligation to provide an implementation which +fulfills the signature of the hole. In this example: + +\begin{verbatim} +package p where + A :: [ ... ] + B = [ import A; ... ] +\end{verbatim} + +\verb|p| is an \emph{indefinite package}, which cannot be compiled until +an implementation of \m{A} is provided. However, we can still type check +\m{B} without any implementation of \m{A}, by type checking it against +the signature. Holes can be put into signature packages and included +(depended upon) by other packages to reuse definitions of signatures. + +\paragraph{Filling in holes with an implementation} +A hole in an indefinite package can be instantiated in a \emph{mix-in} +style: namely, if a signature and an implementation have the same name, +they are linked together: + +\begin{verbatim} +package q where + A = [ ... ] + include p -- has signature A +\end{verbatim} + +Renaming is often useful to rename a module (or a hole) so that a signature +and implementation have the same name and are linked together. +An indefinite package can be instantiated multiple times with different +implementations: the \emph{applicativity} of Backpack means that if +a package is instantiated separately with the same module, the results +are type equal: + +\begin{verbatim} +package q' where + A = [ ... ] + include p (A, B as B1) + include p (A, B as B2) + -- B1 and B2 are equivalent +\end{verbatim} + +\paragraph{Combining signatures together} +Unlike implementations, it's valid for a multiple signatures with the +same name to be in scope. + +\begin{verbatim} +package a-sig where + A :: [ ... ] +package a-sig2 where + A :: [ ... ] +package q where + include a-sig + include a-sig2 + B = [ import A; ... ] +\end{verbatim} + +These signatures \emph{merge} together, providing the union of the +functionality (assuming the types of individual entities are +compatible.) Backpack has a very simple merging algorithm: types must +match exactly to be compatible (\emph{width} subtyping). + +\clearpage + +\section{Module and package identity} + +\begin{figure}[H] +\begin{tabular}{p{0.45\textwidth} p{0.45\textwidth}} +\begin{verbatim} +package p where + A :: [ data X ] + P = [ import A; data Y = Y X ] +package q where + A1 = [ data X = X1 ] + A2 = [ data X = X2 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) +\end{verbatim} +& +\begin{verbatim} +package p where + A :: [ data X ] + P = [ data T = T ] -- no A import! +package q where + A1 = [ data X = X1 ] + A2 = [ data X = X2 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) +\end{verbatim} +\\ +(a) Type equality must consider holes\ldots & +(b) \ldots but how do we track dependencies? \\ +\end{tabular} +\caption{Two similar examples}\label{fig:simple-ex} +\end{figure} + +One of the central questions one encounters when type checking Haskell +code is: \emph{when are two types equal}? In ordinary Haskell, the +answer is simple: ``They are equal if their \emph{original names} (i.e., +where they were originally defined) are the same.'' However, in +Backpack, the situation is murkier due to the presence of \emph{holes}. +Consider the pair of examples in Figure~\ref{fig:simple-ex}. +In Figure~\ref{fig:simple-ex}a, the types \m{B1}.\verb|Y| and \m{B2}.\verb|Y| should not be +considered equal, even though na\"\i vely their original names are +\pname{p}:\m{B}.\verb|Y|, since their arguments are different \verb|X|'s! +On the other hand, if we instantiated \pname{p} twice with the same \m{A} +(e.g., change the second include to \texttt{include p (A as A1, P as P2)}), +we might consider the two resulting \verb|Y|'s +equal, an \emph{applicative} semantics of identity instantiation. In +Figure~\ref{fig:simple-ex}b, we see that even though \m{A} was instantiated differently, +we might reasonably wonder if \texttt{T} should still be considered the same, +since it has no dependence on the actual choice of \m{A}. + +In fact, there are quite a few different choices that can be made here. +Figures~\ref{fig:applicativity}~and~\ref{fig:granularity} summarize the various +choices on two axes: the granularity of applicativity (under what circumstances +do we consider two types equal) and the granularity of dependency (what circumstances +do we consider two types not equal)? A \ding{52} means the design we have chosen +answers the question affirmatively---\ding{54}, negatively---but all of these choices +are valid points on the design space. + +\subsection{The granularity of applicativity} + +An applicative semantics of package instantiation states that if a package is +instantiated with the ``same arguments'', then the resulting entities it defines +should also be considered equal. Because Backpack uses \emph{mix-in modules}, +it is very natural to consider the arguments of a package instantiation as the +modules, as shown in Figure~\ref{fig:applicativity}b: the same module \m{A} is +linked for both instantiations, so \m{P1} and \m{P2} are considered equal. + +However, we consider the situation at a finer granularity, we might say, ``Well, +for a declaration \texttt{data Y = Y X}, only the definition of type \verb|X| matters. +If they are the same, then \verb|Y| is the same.'' In that case, we might accept +that in Figure~\ref{fig:applicativity}a, even though \pname{p} is instantiated +with different modules, at the end of the day, the important component \verb|X| is +the same in both cases, so \verb|Y| should also be the same. This is a sort of +``extreme'' view of modular development, where every declaration is desugared +into a separate module. In our design, we will be a bit more conservative, and +continue with module level applicativity, in the same manner as Paper Backpack. + +\paragraph{Implementation considerations} +Compiling Figure~\ref{fig:applicativity}b to dynamic libraries poses an +interesting challenge, if every package compiles to a dynamic library. +When we compile package \pname{q}, the libraries we end up producing are \pname{q} +and an instance of \pname{p} (instantiated with \pname{q}:\m{A}). Furthermore, +\pname{q} refers to code in \pname{p} (the import in \m{Q}), and vice versa (the usage +of the instantiated hole \m{A}). When building static libraries, this circular +dependency doesn't matter: when we link the executable, we can resolve all +of the symbols in one go. However, when the libraries in question are +dynamic libraries \verb|libHSq.so| and \verb|libHSp(q:A).so|, we now have +a \emph{circular dependency} between the two dynamic libraries, and most dynamic +linkers will not be able to load either of these libraries. + +To break the circularity in Figure~\ref{fig:applicativity}b, we have to \emph{inline} +the entire module \m{A} into the instance of \pname{p}. Since the code is exactly +the same, we can still consider the instance of \m{A} in \pname{q} and in \pname{p} +type equal. However, in Figure~\ref{fig:applicativity}c, applicativity has been +done at a coarser level: although we are using Backpack's module mixin syntax, +morally, this example is filling in the holes with the \emph{package} \pname{a} +(rather than a module). In this case, we can achieve code sharing, since +\pname{p} can refer directly to \pname{a}, breaking the circularity. + +\newcolumntype{C}{>{\centering\arraybackslash}p{0.3\textwidth}} + \begin{savenotes} +\begin{figure} + \begin{tabular}{C C C} +\begin{verbatim} +package q where + A = [ data X = X ] + A1 = [ import A; x = 0 ] + A2 = [ import A; x = 1 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) + Q = [ import P1; ... ] +\end{verbatim} +& +\begin{verbatim} +package q where + A = [ data X = X ] + + + include p (A, P as P1) + include p (A, P as P2) + Q = [ import P1; ... ] +\end{verbatim} +& +\begin{verbatim} +package a where + A = [ data X = X ] +package q where + include a + include p (A, P as P1) + include p (A, P as P2) + Q = [ import P1; ... ] +\end{verbatim} + \\ + (a) Declaration applicativity \ding{54} & + (b) Module applicativity \ding{52} & + (c) Package applicativity \ding{52} \\ +\end{tabular} +\caption{Choices of granularity of applicativity on \pname{p}: given \texttt{data Y = Y X}, is \m{P1}.\texttt{Y} equal to \m{P2}.\texttt{Y}?}\label{fig:applicativity} +\end{figure} +\end{savenotes} + +\subsection{The granularity of dependency} + +\begin{savenotes} +\newcolumntype{C}{>{\centering\arraybackslash}p{0.3\textwidth}} +\begin{figure} + \begin{tabular}{C C C} +\begin{verbatim} +package p(A,P) where + A :: [ data X ] + P = [ + import A + data T = T + data Y = Y X + ] +\end{verbatim} +& +\begin{verbatim} +package p(A,P) where + A :: [ data X ] + B = [ data T = T ] + C = [ + import A + data Y = Y X + ] + P = [ + import B + import C + ] +\end{verbatim} +& +\begin{verbatim} +package b where + B = [ data T = T ] +package c where + A :: [ data X ] + C = [ + import A + data Y = Y X + ] +package p(A,P) where + include b; include c + P = [ import B; import C ] +\end{verbatim} + \\ + (a) Declaration granularity \ding{54} & + (b) Module granularity \ding{54} & + (c) Package granularity \ding{52} \\ +\end{tabular} +\caption{Choices of granularity for dependency: is the identity of \texttt{T} independent of how \m{A} is instantiated?}\label{fig:granularity} +\end{figure} + +\end{savenotes} + +In the previous section, we considered \emph{what} entities may be considered for +computing dependency; in this section we consider \emph{which} entities are actually +considered as part of the dependencies for the declaration/module/package we're writing. +Figure~\ref{fig:granularity} contains a series of examples which exemplify the choice +of whether or not to collect dependencies on a per-declaration, per-module or per-package basis: + +\begin{itemize} + \item Package-level granularity states that the modules in a package are +considered to depend on \emph{all} of the holes in the package, even if +the hole is never imported. Figure~\ref{fig:granularity}c is factored so that +\verb|T| is defined in a distinct package \pname{b} with no holes, so no matter +the choice of \m{A}, \m{B}.\verb|T| will be the same. On the other hand, in +Figure~\ref{fig:granularity}b, there is a hole in the package defining \m{B}, +so the identity of \verb|T| will depend on the choice of \m{A}. + +\item Module-level granularity states that each module has its own dependency, +computed by looking at its import statements. In this setting, \verb|T| in Figure~\ref{fig:granularity}b +is independent of \m{A}, since the hole is never imported in \m{B}. But once again, in +Figure~\ref{fig:granularity}a, there is an import in the module defining \verb|T|, +so the identity of \verb|T| once again depends on the choice of \m{A}. + +\item Finally, at the finest level of granularity, one could chop up \pname{p} in +Figure~\ref{fig:granularity}a, looking at the type declaration-level dependency +to suss out whether or not \verb|T| depends on \m{A}. It doesn't refer to +anything in \m{A}, so it is always considered the same. +\end{itemize} + +It is well worth noting that the system described by Paper Backpack tracks dependencies per module; +however, we have decided that we will implement tracking per package instead: +a coarser grained granularity which accepts less programs. + +Is a finer form of granularity \emph{better?} Not necessarily! For +one, we can always split packages into further subpackages (as was done +in Figure~\ref{fig:granularity}c) which better reflect the internal hole +dependencies, so it is always possible to rewrite a program to make it +typecheck---just with more packages. Additionally, the finer the +granularity of dependency, the more work I have to do to understand what +the identities of entities in a module are. In Paper Backpack, I have +to understand the imports of all modules in a package; with +declaration-granularity, I have to understand the entire code. This is +a lot of work for the developer to think about; a more granular model is +easier to remember and reason about. Finally, package-level granularity +is much easier to implement, as it preserves the previous compilation +model, \emph{one library per package}. At a fine level of granularity, we +may end up repeatedly compiling a module which actually should be considered +``the same'' as any other instance of it. + +Nevertheless, finer granularity can be desirable from an end-user perspective. +Usually, these circumstances arise when library-writers are forced to split their +components into many separate packages, when they would much rather have written +a single package. For example, if I define a data type in my library, and would +like to define a \verb|Lens| instance for it, I would create a new package just +for the instance, in order to avoid saddling users who aren't interested in lenses +with an extra dependency. Another example is test suites, which have dependencies +on various test frameworks that a user won't care about if they are not planning +on testing the code. (Cabal has a special case for this, allowing the user +to write effectively multiple packages in a single Cabal file.) + +\subsection{Summary} + +We can summarize all of the various schemes by describing the internal data +types that would be defined by GHC under each regime. First, we have +the shared data structures, which correspond closely to what users are +used to seeing: + +\begin{verbatim} + ::= containers, ... + ::= - + ::= Data.Set, ... + ::= empty, ... +\end{verbatim} + +Changing the \textbf{granularity of applicativity} modifies how we represent the +list of dependencies associated with an entity. With module applicativity, +we list module identities (not yet defined); with declaration applicativity +we actually list the original names (i.e., ids). + +\begin{verbatim} + ::= , ... # Declaration applicativity + ::= , ... # Module applicativity +\end{verbatim} + +Changing the \textbf{granularity of dependency} affects how we compute +the lists of dependencies, and what entities are well defined: + +\begin{verbatim} +# Package-level granularity + ::= hash( + ) + ::= : + ::= . + +# Module-level granularity + not defined + ::= hash( : + ) + ::= . + +# Declaration-level granularity + not defined + not defined + ::= hash( : . + ) +\end{verbatim} + +Notice that as we increase the granularity, the notion of a ``package'' and a ``module'' +become undefined. This is because, for example, with module-level granularity, a single +``package'' may result in several modules, each of which have different sets of +dependencies. It doesn't make much sense to refer to the package as a monolithic entity, +because the point of splitting up the dependencies was so that if a user relies only +on a single module, it has a correspondingly restricted set of dependencies. +\subsection{The new scheme, formally} + +\begin{wrapfigure}{R}{0.5\textwidth} +\begin{myfig} +\[ +\begin{array}{@{}lr@{\;}c@{\;}l@{}} + \text{Package Names (\texttt{PkgName})} & P &\in& \mathit{PkgNames} \\ + \text{Module Path Names (\texttt{ModName})} & p &\in& \mathit{ModPaths} \\ + \text{Module Identity Vars} & \alpha,\beta &\in& \mathit{IdentVars} \\ + \text{Package Key (\texttt{PackageKey})} & \K &::=& P(\vec{p\mapsto\nu}) \\ + \text{Module Identities (\texttt{Module})} & \nu &::=& + \alpha ~|~ + \K\colon\! p \\ + \text{Module Identity Substs} & \phi,\theta &::=& + \{\vec{\alpha \coloneqq \nu}\} \\ +\end{array} +\] +\caption{Module Identities} +\label{fig:mod-idents} +\end{myfig} +\end{wrapfigure} + +In this section, we give a formal treatment of our choice in the design space, in the +same style as the Backpack paper, but omitting mutual recursion, as it follows straightforwardly. +Physical module +identities $\nu$, the \texttt{Module} component of \emph{original names} in GHC, are either (1) \emph{variables} $\alpha$, which are +used to represent holes\footnote{In practice, these will just be fresh paths in a special package key for variables.} or (2) a concrete module $p$ defined in package +$P$, with holes instantiated with other module identities (might be +empty)\footnote{In Paper Backpack, we would refer to just $P$:$p$ as the identity +constructor. However, we've written the subterms specifically next to $P$ to highlight the semantic difference of these terms.}. + +As in traditional Haskell, every package contains a number of module +files at some module path $p$; within a package these paths are +guaranteed to be unique.\footnote{In Paper Backpack, the module expressions themselves are used to refer to globally unique identifiers for each literal. This makes the metatheory simpler, but for implementation purposes it is convenient to conflate the \emph{original} module path that a module is defined at with its physical identity.} When we write inline module definitions, we assume +that they are immediately assigned to a module path $p$ which is incorporated +into their identity. A module identity $\nu$ simply augments this +with subterms $\vec{p\mapsto\nu}$ representing how \emph{all} holes in the package $P$ +were instantiated.\footnote{In Paper Backpack, we do not distinguish between holes/non-holes, and we consider all imports of the \emph{module}, not the package.} This naming is stable because the current Backpack surface syntax does not allow a logical path in a package +to be undefined. A package key is $P(\vec{p\mapsto\nu})$. + +Here is the very first example from +Section 2 of the original Backpack paper, \pname{ab-1}: + +\begin{example} +\Pdef{ab-1}{ + \Pmod{A}{x = True} + \Pmod{B}{\Mimp{A}; y = not x} + % \Pmodd{C}{\mname{A}} +} +\end{example} + +The identities of \m{A} and \m{B} are +\pname{ab-1}:\mname{A} and \pname{ab-1}:\mname{B}, respectively.\footnote{In Paper Backpack, the identity for \mname{B} records its import of \mname{A}, but since it is definite, this is strictly redundant.} In a package with holes, each +hole (within the package definition) gets a fresh variable as its +identity, and all of the holes associated with package $P$ are recorded. Consider \pname{abcd-holes-1}: + +\begin{example} +\Pdef{abcd-holes-1}{ + \Psig{A}{x :: Bool} % chktex 26 + \Psig{B}{y :: Bool} % chktex 26 + \Pmod{C}{x = False} + \Pmodbig{D}{ + \Mimpq{A}\\ + \Mimpq{C}\\ + % \Mexp{\m{A}.x, z}\\ + z = \m{A}.x \&\& \m{C}.x + } +} +\end{example} + +The identities of the four modules +are, in order, $\alpha_a$, $\alpha_b$, $\pname{abcd-holes-1}(\alpha_a,\alpha_b)$:\mname{C}, and +$\pname{abcd-holes-1}(\alpha_a,\alpha_b)$:\mname{D}.\footnote{In Paper Backpack, the granularity is at the module level, so the subterms of \mname{C} and \mname{D} can differ.} We include both $\alpha_a$ and $\alpha_b$ in both \mname{C} and \mname{D}, regardless of the imports. When we link the package against an implementation of the hole, these variables are replaced with the identities of the modules we linked against. + +Shaping proceeds in the same way as in Paper Backpack, except that the +shaping judgment must also accept the package key +$P(\vec{p\mapsto\alpha})$ so we can create identifiers with +\textsf{mkident}. This implies we must know ahead of time what the holes +of a package are. + +\paragraph{A full Backpack comparison} +If you're curious about how the rest of the Backpack examples translate, +look no further than this section. + +First, consider the module identities in the \m{Graph} instantiations in +\pname{multinst}, shown in Figure 2 of the original Backpack paper. +In the definition of \pname{structures}, assume that the variables for +\m{Prelude} and \m{Array} are $\alpha_P$ and $\alpha_A$ respectively. +The identity of \m{Graph} is $\pname{structures}(\alpha_P, \alpha_A)$:\m{Graph}. Similarly, the identities of the two array implementations +are $\nu_{AA} = \pname{arrays-a}(\alpha_P)$:\m{Array} and +$\nu_{AB} = \pname{arrays-b}(\alpha_P)$:\m{Array}.\footnote{Notice that the subterms coincide with Paper Backpack! A sign that module level granularity is not necessary for many use-cases.} + +The package \pname{graph-a} is more interesting because it +\emph{links} the packages \pname{arrays-a} and \pname{structures} +together, with the implementation of \m{Array} from \pname{arrays-a} +\emph{instantiating} the hole \m{Array} from \pname{structures}. This +linking is reflected in the identity of the \m{Graph} module in +\pname{graph-a}: whereas in \pname{structures} it was $\nu_G = +\pname{structures}(\alpha_P, \alpha_A)$:\m{Graph}, in \pname{graph-a} it is +$\nu_{GA} = \nu_G[\nu_{AA}/\alpha_A] = \pname{structures}(\alpha_P, \nu_{AA})$:\m{Graph}. Similarly, the identity of \m{Graph} in +\pname{graph-b} is $\nu_{GB} = \nu_G[\nu_{AB}/\alpha_A] = +\pname{structures}(\alpha_P, \nu_{AB})$:\m{Graph}. Thus, linking consists +of substituting the variable identity of a hole by the concrete +identity of the module filling that hole. + +Lastly, \pname{multinst} makes use of both of these \m{Graph} +modules, under the aliases \m{GA} and \m{GB}, respectively. +Consequently, in the \m{Client} module, \code{\m{GA}.G} and +\code{\m{GB}.G} will be correctly viewed as distinct types since they +originate in modules with distinct identities. + +As \pname{multinst} illustrates, module identities effectively encode +dependency graphs at the package level.\footnote{In Paper Backpack, module identities +encode dependency graphs at the module level. In both cases, however, what is being +depended on is always a module.} Like in Paper Backpack, we have an \emph{applicative} +semantics of instantiation, and the applicativity example in Figure 3 of the +Backpack paper still type checks. However, because we are operating at a coarser +granularity, modules may have spurious dependencies on holes that they don't +actually depend on, which means less type equalities may hold. + + +\subsection{Cabal dependency resolution} + +Currently, when we compile a Cabal +package, Cabal goes ahead and resolves \verb|build-depends| entries with actual +implementations, which we compile against. The package key, +independently of Backpack, records the transitive dependency tree selected +during this dependency resolution process, so that we can install \pname{libfoo-1.0} +twice compiled against different versions of its dependencies. +What is the relationship to this transitive dependency tree of \emph{packages}, +with the subterms of our package identities which are \emph{modules}? Does one +subsume the other? In fact, these are separate mechanisms---two levels of indirections, +so to speak. + +To illustrate, suppose I write a Cabal file with \verb|build-depends: foobar|. A reasonable assumption is that this translates into a +Backpack package which has \verb|include foobar|. However, this is not +actually a Paper Backpack package: Cabal's dependency solver has to +rewrite all of these package references into versioned references +\verb|include foobar-0.1|. For example, this is a pre-package: + +\begin{verbatim} +package foo where + include bar +\end{verbatim} + +and this is a Paper Backpack package: + +\begin{verbatim} +package foo-0.3[bar-0.1[baz-0.2]] where + include bar-0.1[baz-0.2] +\end{verbatim} + +This tree is very similar to the one tracking dependencies for holes, +but we must record this tree \emph{even} when our package has no holes. +% As a final example, the full module +% identity of \m{B1} in Figure~\ref{fig:granularity} may actually be $\pname{p-0.9(q-1.0[p-0.9]:A1)}$:\m{B}. + +\paragraph{Linker symbols} As we increase the amount of information in +PackageId, it's important to be careful about the length of these IDs, +as they are used for exported linker symbols (e.g. +\verb|base_TextziReadziLex_zdwvalDig_info|). Very long symbol names +hurt compile and link time, object file sizes, GHCi startup time, +dynamic linking, and make gdb hard to use. +As such, we've done away with full package names and versions; instead, +there is simply a base-62 encoded hash, with the first five characters of the package +name for user-friendliness. + +\subsection{Package selection} + +When I fire up \texttt{ghci} with no arguments, GHC somehow creates +out of thin air some consistent set of packages, whose modules I can +load using \texttt{:m}. This functionality is extremely handy for +exploratory work, but actually GHC has to work quite hard in order +to generate this set of packages, the contents of which are all +dumped into a global namespace. For example, GHC doesn't have access +to Cabal's dependency solver, nor does it know \emph{which} packages +the user is going to ask for, so it can't just run a constraint solver, +get a set of consistent packages to offer and provide them to the user.\footnote{Some might +argue that depending on a global environment in this fashion is wrong, because +when you perform a build in this way, you have absolutely no ideas what +dependencies you actually ended up using. But the fact remains that for +end users, this functionality is very useful.} + +To make matters worse, while in the current design of the package database, +a package is uniquely identified by its package name and version, in +the Backpack design, it is \emph{mandatory} that we support multiple +packages installed in the database with the same package name and version, +and this can result in complications in the user model. This further +complicates GHC's default package selection algorithm. + +In this section, we describe how the current algorithm operates (including +what invariants it tries to uphold and where it goes wrong), and how +to replace the algorithm to handle generalization to +multiple instances in the package database. We'll also try to tease +apart the relationship between package keys and installed package IDs in +the database. + +\paragraph{The current algorithm} Abstractly, GHC's current package +selection algorithm operates as follows. For every package name, select +the package with the latest version (recall that this is unique) which +is also \emph{valid}. A package is valid if: + +\begin{itemize} + \item It exists in the package database, + \item All of its dependencies are valid, + \item It is not shadowed by a package with the same package ID\footnote{Recall that currently, a package ID uniquely identifies a package in the package database} in + another package database (unless it is in the transitive closure + of a package named by \texttt{-package-id}), and + \item It is not ignored with \texttt{-ignore-package}. +\end{itemize} + +Package validity is probably the minimal criterion for to GHC to ensure +that it can actually \emph{use} a package. If the package is missing, +GHC can't find the interface files or object code associated with the +package. Ignoring packages is a way of pretending that a package is +missing from the database. + +Package validity is also a very weak criterion. Another criterion we +might hope holds is \emph{consistency}: when we consider the transitive +closure of all selected packages, for any given package name, there +should only be one instance providing that package. It is trivially +easy to break this property: suppose that I have packages \pname{a-1.0}, +\pname{b-1.0} compiled against \pname{a-1.0}, and \pname{a-1.1}. GHC +will happily load \pname{b-1.0} and \pname{a-1.1} together in the same +interactive session (they are both valid and the latest versions), even +though \pname{b-1.0}'s dependency is inconsistent with another package +that was loaded. The user will notice if they attempt to treat entities +from \pname{a} reexported by \pname{b-1.0} and entities from +\pname{a-1.1} as type equal. Here is one user who had this problem: +\url{http://stackoverflow.com/questions/12576817/}. In some cases, the +problem is easy to work around (there is only one offending package +which just needs to be hidden), but if the divergence is deep in two +separate dependency hierarchies, it is often easier to just blow away +the package database and try again. + +Perversely, destructive reinstallation helps prevent these sorts of +inconsistent databases. While inconsistencies can arise when multiple +versions of a package are installed, multiple versions will frequently +lead to the necessity of reinstalls. In the previous example, if a user +attempts to Cabal install a package which depends on \pname{a-1.1} and +\pname{b-1.0}, Cabal's dependency solver will propose reinstalling +\pname{b-1.0} compiled against \pname{a-1.1}, in order to get a +consistent set of dependencies. If this reinstall is accepted, we +invalidate all packages in the database which were previously installed +against \pname{b-1.0} and \pname{a-1.0}, excluding them from GHC's +selection process and making it more likely that the user will see a +consistent view of the database. + +\paragraph{Enforcing consistent dependencies} From the user's +perspective, it would be desirable if GHC never loaded a set of packages +whose dependencies were inconsistent. +There are two ways we can go +about doing this. First, we can improve GHC's logic so that it doesn't +pick an inconsistent set. However, as a point of design, we'd like to +keep whatever resolution GHC does as simple as possible (in an ideal +world, we'd skip the validity checks entirely, but they ended up being +necessary to prevent broken database from stopping GHC from starting up +at all). In particular, GHC should \emph{not} learn how to do +backtracking constraint solving: that's in the domain of Cabal. Second, +we can modify the logic of Cabal to enforce that the package database is +always kept in a consistent state, similar to the consistency check +Cabal applies to sandboxes, where it refuses to install a package to a +sandbox if the resulting dependencies would not be consistent. + +The second alternative is a appealing, but Cabal sandboxes are currently +designed for small, self-contained single projects, as opposed to the +global ``universe'' that a default environment is intended to provide. +For example, with a Cabal sandbox environment, it's impossible to +upgrade a dependency to a new version without blowing away the sandbox +and starting again. To support upgrades, Cabal needs to do some work: +when a new version is put in the default set, all of the +reverse-dependencies of the old version are now inconsistent. Cabal +should offer to hide these packages or reinstall them compiled against +the latest version. Furthermore, because we in general may not have write +access to all visible package databases, this visibility information +must be independent of the package databases themselves. + +As a nice bonus, Cabal should also be able to snapshot the older +environment which captures the state of the universe prior to the +installation, in case the user wants to revert back. + +\paragraph{Modifying the default environment} Currently, after GHC +calculates the default package environment, a user may further modify +the environment by passing package flags to GHC, which can be used to +explicitly hide or expose packages. How do these flags interact with +our Cabal-managed environments? Hiding packages is simple enough, +but exposing packages is a bit dicier. If a user asks for a different +version of a package than in the default set, it will probably be +inconsistent with the rest of the dependencies. Cabal would have to +be consulted to figure out a maximal set of consistent packages with +the constraints given. Alternatively, we could just supply the package +with no claims of consistency. + +However, this use-case is rare. Usually, it's not because they want a +specific version: the package is hidden simply because we're not +interested in loading it by default (\pname{ghc-api} is the canonical +example, since it dumps a lot of modules in the top level namespace). +If we distinguish packages which are consistent but hidden, their +loads can be handled appropriately. + +\paragraph{Consistency in Backpack} We have stated as an implicit +assumption that if we have both \pname{foo-1.0} and \pname{foo-1.1} +available, only one should be loaded at a time. What are the +consequences if both of these packages are loaded at the same time? An +import of \m{Data.Foo} provided by both packages would be ambiguous and +the user might find some type equalities they expect to hold would not. +However, the result is not \emph{unsound}: indeed, we might imagine a +user purposely wanting two different versions of a library in the same +program, renaming the modules they provided so that they could be +referred to unambiguously. As another example, suppose that we have an +indefinite package with a hole that is instantiated multiple times. In +this case, a user absolutely may want to refer to both instantiations, +once again renaming modules so that they have unique names. + +There are two consequences of this. First, while the default package +set may enforce consistency, a user should still be able to explicitly +ask for a package instance, renamed so that its modules don't conflict, +and then use it in their program. Second, instantiated indefinite packages +should \emph{never} be placed in the default set, since it's impossible +to know which instantiation is the one the user prefers. A definite package +can reexport an instantiated module under an unambiguous name if the user +so pleases. + +\paragraph{Shadowing, installed package IDs, ABI hashes and package +keys} Shadowing plays an important role for maintaining the soundness of +compilation; call this the \emph{compatibility} of the package set. The +problem it addresses is when there are two distinct implementations of a +module, but because their package ID (or package key, in the new world +order) are the same, they are considered type equal. It is absolutely +wrong for a single program to include both implementations +simultaneously (the symbols would conflict and GHC would incorrectly +conclude things were type equal when they're not), so \emph{shadowing}'s +job is to ensure that only one instance is picked, and all the other +instances considered invalid (and their reverse-dependencies, etc.) +Recall that in current GHC, within a package database, a package +instance is uniquely identified by its package ID\@; thus, shadowing +only needs to take place between package databases. An interesting +corner case is when the same package ID occurs in both databases, but +the installed package IDs are the \emph{same}. Because the installed +package ID is currently simply an ABI hash, we skip shadowing, because +the packages are---in principle---interchangeable. + +There are currently a number of proposed changes to this state of affairs: + +\begin{itemize} + \item Change installed package IDs to not be based on ABI hashes. + ABI hashes have a number of disadvantages as identifiers for + packages in the database. First, they cannot be computed until + after compilation, which gave the multi-instance GSoC project a + few years some headaches. Second, it's not really true that + programs with identical ABI hashes are interchangeable: a new + package may be ABI compatible but have different semantics. + Thus, installed package IDs are a poor unique identifier for + packages in the package database. However, because GHC does not + give ABI stability guarantees, it would not be possible to + assume from here that packages with the same installed package + ID are ABI compatible. + + \item Relaxing the uniqueness constraint on package IDs. There are + actually two things that could be done here. First, since we + have augmented package IDs with dependency resolution + information to form package keys, we could simply state that + package keys uniquely identify a package in a database. + Shadowing rules can be implemented in the same way as before, by + preferring the instance topmost on the stack. Second, we could + also allow \emph{same-database} shadowing: that is, not even + package keys are guaranteed to be unique in a database: instead, + installed package IDs are the sole unique identifier of a + package. This architecture is Nix inspired, as the intent is + to keep all package information in a centralized database. +\end{itemize} + +Without mandatory package environments, same-database shadowing is a bad +idea, because GHC now has no idea how to resolve shadowing. Conflicting +installed package IDs can be simulated by placing them in multiple +package databases (in principle, the databases can be concatenated together +and treated as a single monolitic database.) + +\section{Shapeless Backpack}\label{sec:simplifying-backpack} + +Backpack as currently defined always requires a \emph{shaping} pass, +which calculates the shapes of all modules defined in a package. +The shaping pass is critical to the solution of the double-vision problem +in recursive module linking, but it also presents a number of unpalatable +implementation problems: + +\begin{itemize} + + \item \emph{Shaping is a lot of work.} A module shape specifies the + providence of all data types and identifiers defined by a + module. To calculate this, we must preprocess and parse all + modules, even before we do the type-checking pass. (Fortunately, + shaping doesn't require a full parse of a module, only enough + to get identifiers. However, it does have to understand import + statements at the same level of detail as GHC's renamer.) + + \item \emph{Shaping must be done upfront.} In the current Backpack + design, all shapes must be computed before any typechecking can + occur. While performing the shaping pass upfront is necessary + in order to solve the double vision problem (where a module + identity may be influenced by later definitions), it means + that GHC must first do a shaping pass, and then revisit every module and + compile them proper. Nor is it (easily) possible to skip the + shaping pass when it is unnecessary, as one might expect to be + the case in the absence of mutual recursion. Shaping is not + a ``pay as you go'' language feature. + + \item \emph{GHC can't compile all programs shaping accepts.} Shaping + accepts programs that GHC, with its current hs-boot mechanism, cannot + compile. In particular, GHC requires that any data type or function + in a signature actually be \emph{defined} in the module corresponding + to that file (i.e., an original name can be assigned to these entities + immediately.) Shaping permits unrestricted exports to implement + modules; this shows up in the formalism as $\beta$ module variables. + + \item \emph{Shaping encourages inefficient program organization.} + Shaping is designed to enable mutually recursive modules, but as + currently implemented, mutual recursion is less efficient than + code without recursive dependencies. Programmers should avoid + this code organization, except when it is absolutely necessary. + + \item \emph{GHC is architecturally ill-suited for directly + implementing shaping.} Shaping implies that GHC's internal + concept of an ``original name'' be extended to accommodate + module variables. This is an extremely invasive change to all + aspects of GHC, since the original names assumption is baked + quite deeply into the compiler. Plausible implementations of + shaping requires all these variables to be skolemized outside + of GHC\@. + +\end{itemize} + +To be clear, the shaping pass is fundamentally necessary for some +Backpack packages. Here is the example which convinced Simon: + +\begin{verbatim} +package p where + A :: [data T; f :: T -> T] + B = [export T(MkT), h; import A(f); data T = MkT; h x = f MkT] + A = [export T(MkT), f, h; import B; f MkT = MkT] +\end{verbatim} + +The key to this example is that B \emph{may or may not typecheck} depending +on the definition of A. Because A reexports B's definition T, B will +typecheck; but if A defined T on its own, B would not typecheck. Thus, +we \emph{cannot} typecheck B until we have done some analysis of A (the +shaping analysis!) + +Thus, it is beneficial (from an optimization point of view) to +consider a subset of Backpack for which shaping is not necessary. +Here is a programming discipline which does just that, which we will call the \textbf{linking restriction}: \emph{Module implementations must be declared before +signatures.} Formally, this restriction modifies the rule for merging +polarized module shapes ($\widetilde{\tau}_1^{m_1} \oplus \widetilde{\tau}_2^{m_2}$) so that +$\widetilde{\tau}_1^- \oplus \widetilde{\tau}_2^+$ is always undefined.\footnote{This seemed to be the crispest way of defining the restriction, although this means an error happens a bit later than I'd like it to: I'd prefer if we errored while merging logical contexts, but we don't know what is a hole at that point.} + +Here is an example of the linking restriction. Consider these two packages: + +\begin{verbatim} +package random where + System.Random = [ ... ].hs + +package monte-carlo where + System.Random :: ... + System.MonteCarlo = [ ... ].hs +\end{verbatim} + +Here, random is a definite package which may have been compiled ahead +of time; monte-carlo is an indefinite package with a dependency +on any package which provides \verb|System.Random|. + +Now, to link these two applications together, only one ordering +is permissible: + +\begin{verbatim} +package myapp where + include random + include monte-carlo +\end{verbatim} + +If myapp wants to provide its own random implementation, it can do so: + +\begin{verbatim} +package myapp2 where + System.Random = [ ... ].hs + include monte-carlo +\end{verbatim} + +In both cases, all of \verb|monte-carlo|'s holes have been filled in by the time +it is included. The alternate ordering is not allowed. + +Why does this discipline prevent mutually recursive modules? Intuitively, +a hole is the mechanism by which we can refer to an implementation +before it is defined; otherwise, we can only refer to definitions which +preceed our definition. If there are never any holes \emph{which get filled}, +implementation links can only go backwards, ruling out circularity. + +It's easy to see how mutual recursion can occur if we break this discipline: + +\begin{verbatim} +package myapp2 where + include monte-carlo + System.Random = [ import System.MonteCarlo ].hs +\end{verbatim} + +\subsection{Typechecking of definite modules without shaping} + +If we are not carrying out a shaping pass, we need to be able to calculate +$\widetilde{\Xi}_{\mathsf{pkg}}$ on the fly. In the case that we are +compiling a package---there will be no holes in the final package---we +can show that shaping is unnecessary quite easily, since with the +linking restriction, everything is definite from the get-go. + +Observe the following invariant: at any given step of the module +bindings, the physical context $\widetilde{\Phi}$ contains no +holes. We can thus conclude that there are no module variables in any +type shapes. As the only time a previously calculated package shape can +change is due to unification, the incrementally computed shape is in +fact the true one. + +As far as the implementation is concerned, we never have to worry +about handling module variables; we only need to do extra typechecks +against (renamed) interface files. + +\subsection{Compiling definite packages}\label{sec:compiling} + +% New definitions +\algnewcommand\algorithmicswitch{\textbf{switch}} +\algnewcommand\algorithmiccase{\textbf{case}} +\algnewcommand\algorithmicassert{\texttt{assert}} +% New "environments" +\algdef{SE}[SWITCH]{Switch}{EndSwitch}[1]{\algorithmicswitch\ #1\ \algorithmicdo}{\algorithmicend\ \algorithmicswitch}% +\algdef{SE}[CASE]{Case}{EndCase}[1]{\algorithmiccase\ ``#1''}{\algorithmicend\ \algorithmiccase}% +\algtext*{EndSwitch}% +\algtext*{EndCase}% + +\begin{algorithm} + \caption{Compilation of definite packages (assume \texttt{-hide-all-packages} on all \texttt{ghc} invocations)}\label{alg:compile} +\begin{algorithmic} + \Procedure{Compile}{\textbf{package} $P$ \textbf{where} $\vec{B}$, $H$, $db$}\Comment{}$H$ maps hole module names to identities + \State$flags\gets \nil$ + \State$\mathcal{K}$ $\gets$ \Call{Hash}{$P + H$} + \State% + In-place register the package $\mathcal{K}$ in $db$ + \For{$B$ \textbf{in} $\vec{B}$} + \Case{$p = p\texttt{.hs}$} + \State\Call{Exec}{\texttt{ghc -c} $p$\texttt{.hs} \texttt{-package-db} $db$ \texttt{-this-package-key} $\mathcal{K}$ $flags$} + \EndCase% + \Case{$p$ $\cc$ $p$\texttt{.hsig}} + \State\Call{Exec}{\texttt{ghc -c} $p$\texttt{.hsig} \texttt{-package-db} $db$ \texttt{-sig-of} $H(p)$ $flags$} + \EndCase% + \Case{$p = p'$} + \State$flags\gets flags$ \texttt{-alias} $p$ $p'$ + \EndCase% + \Case{\Cinc{$P'$} $\langle\vec{p_H\mapsto p_H'}, \vec{p\mapsto p'} \rangle$} + \State\textbf{let} $H'(p_H) = $ \Call{ResolveModule}{$p_H'$} + \State$\mathcal{K}'\gets$ \Call{Compile}{$P'$, $H'$, $db$}\Comment{}Nota bene: not $flags$ + \State$flags\gets flags$ \texttt{-package} $\mathcal{K}'$ $\langle\vec{p\mapsto p'}\rangle$ + \EndCase% + \EndFor% + \State% + Remove $\mathcal{K}$ from $db$ + \State% + Install the complete package $\mathcal{K}$ to the global database + \State\Return$\mathcal{K}$ + \EndProcedure% +\end{algorithmic} +\end{algorithm} + +The full recursive procedure for compiling a Backpack package using +one-shot compilation is given in Figure~\ref{alg:compile}. We +recursively walk through Backpack descriptions, processing each line by +invoking GHC and/or modifying our package state. Here is a more +in-depth description of the algorithm, line-by-line: + +\paragraph{The parameters} To compile a package description for package +$P$, we need to know $H$, the mapping of holes $p_H$ in package $P$ to +physical module identities $\nu$ which are implementing them; this +mapping is used to calculate the package key $\mathcal{K}$ for the +package in question. Furthermore, we have an inplace package database +$db$ in which we will register intermediate build results, including +partially compiled parent packages which may provide implementations +of holes for packages they include. + +\subsection{Compiling implementations} + +We compile modules in the same way we do today, but with some extra +package visibility $flags$, which let GHC know how to resolve imports +and look up original names. We'll describe what the new flags are +and also discuss some subtleties with module lookup. + +\paragraph{In-place registration} Perhaps surprisingly, we start +compilation by registering the (uncompiled) package in the in-place +package database. This registration does not expose packages, and is +purely intended to inform the compilation of subpackages where to +find modules that are provided by the parent (in-progress) package, +as well as provide auxiliary information, e.g., such as the package name +and version for error reporting. The pre-registration trick is an old +one used by the GHC build system; the key invariant to look out for +is that we shouldn't reference original names in modules that haven't +been built yet. This is enforced by our manual tracking of holes in +$H$: a module can't occur in $H$ unless it's already been compiled! + +\paragraph{New package resolution algorithm} Currently, invocations +of \texttt{-package} and similar flags have the result of \emph{hiding} +other exposed packages with the same name. However, this is not going +to work for Backpack: an indefinite package may get loaded multiple times +with different instantiations, and it might even make sense to load multiple +versions of the same package simultaneously, as long as their modules +are renamed to not conflict. + +Thus, we impose the following behavior change: when +\texttt{-hide-all-packages} is specified, we do \emph{not} automatically +hide packages with the same name as a package specified by +\texttt{-package} (or a similar flag): they are all included, even if +there are conflicts. To deal with conflicts, we augment the syntax of +\texttt{-package} to also accept a list of thinnings and renamings, e.g. +\texttt{-package} \pname{containers} $\langle\m{Data.Set}, +\m{Data.Map}\mapsto \m{Map}\rangle$ says to make visible for import +\m{Data.Set} and \m{Map} (which is \m{Data.Map} renamed.) This means +that +\texttt{-package} \pname{containers-0.9} $\langle\m{Data.Set}\mapsto +\m{Set09}\rangle$ \texttt{-package} \pname{containers-0.8} +$\langle\m{Data.Set}\mapsto \m{Set08}\rangle$ now uses both packages +concurrently (previously, GHC would hide one of them.) + +Additionally, it's important to note that two packages exporting the +same module do not \emph{necessarily} cause a conflict; the modules +may be linkable. For example, \texttt{-package} \pname{containers} $\langle\m{Data.Set}\rangle$ +\texttt{-package} \pname{containers} $\langle\m{Data.Set}\rangle$ is fine, because +precisely the same implementation of \m{Data.Set} is loaded in both cases. +A similar situation can occur with signatures: + +\begin{verbatim} +package p where + A :: [ x :: Int ] +package q + include p + A :: [ y :: Int ] + B = [ import A; z = x + y ] -- * +package r where + A = [ x = 0; y = 0 ] + include q +\end{verbatim} + +Here, both \pname{p} and \pname{q} are visible when compiling the starred +module, which compiles with the flags \texttt{-package} \pname{p}, but there +are two interface files available: one available locally, and one from \pname{p}. +Both of these interface files are \emph{forwarding} to the original implementation +\pname{r} (more on this in the ``Compiling signatures'' file), so rather than +reporting an ambiguous import, we instead have to merge the two interface files +together. This is done by simulating multiple imports: one to each interface +file. This works because GHC does not consider symbols with equal original names +as conflicting. + +Note that we do not need to merge signatures with an implementation, in such +cases, we should just use the implementation interface. E.g. + +\begin{verbatim} +package p where + A :: ... +package q where + A = ... + include p + B = [ import A ] -- * +\end{verbatim} + +Here, \m{A} is available both from \pname{p} and \pname{q}, but the use in the +starred module should be done with respect to the full implementation. + +\paragraph{The \texttt{-alias} flag} We introduce a new flag +\texttt{-alias} for aliasing modules. Aliasing is analogous to +the merging that can occur when we include packages, but it also applies +to modules which are locally defined. When we alias a module $p$ with +$p'$, we require that $p'$ exists in the current module mapping, and then +we attempt to add an entry for it at entry $p$. If there is no mapping for +$p$, this succeeds; otherwise, we apply the same conflict resolution algorithm. + +\subsection{Compiling signatures} + +Signature compilation is triggered when we compile a signature file. +This mode similar to how we process \verb|hs-boot| files, except +we pass an extra flag \verb|-sig-of| which specifies what the +identity of the actual implementation of the signature is (according to our $H$ +mapping). This is guaranteed to exist, due to the linking +restriction, although it may be in a partially registered package +in $db$. If the module is \emph{not} currently available under the same name of the +\texttt{hsig} file, we output an \texttt{hi} file which, for all declarations the +signature exposes, forwards their definitions to the original +implementation file. The intent is that any code in the current package +which compiles against this signature will use this signature \texttt{hi} file, +not the original one \texttt{hi} file. +For example, the \texttt{hi} file produced when compiling the starred interface +points to the implementation in package \pname{q}. + +\begin{verbatim} +package p where + A :: ... -- * + B = [ import A; ... ] +package q where + A = [ ... ] + include p +\end{verbatim} + +\paragraph{Sometimes \texttt{hi} is unnecessary} +In the following package: + +\begin{verbatim} +package p where + P = ... + P :: ... +\end{verbatim} + +Paper Backpack specifies that we check the signature \m{P} against implementation +\m{P}, but otherwise no changes are made (i.e., the signature does not narrow +the implementation.) In this case, it is not necessary to generate an \texttt{hi} file; +the original interface file suffices. + +\paragraph{Multiple signatures} As a simplification, we assume that there +is only one signature per logical name in a package. (This prevents +us from expressing mutual recursion in signatures, but let's not worry +about it for now.) + +\paragraph{Restricted recursive modules ala hs-boot}\label{sec:hs-boot-restrict} +When we compile an \texttt{hsig} file without any \texttt{-sig-of} flag (because +no implementation is known), we fall back to old-style GHC mutual recursion. +Na\"\i vely, a shaping pass would be necessary; +so we adopt an existing constraint that +already applies to hs-boot files: \emph{at the time we define a signature, +we must know what the original name for all data types is}. In practice, +GHC enforces this by stating that: (1) an hs-boot file must be +accompanied with an implementation, and (2) the implementation must +in fact define (and not reexport) all of the declarations in the signature. +We can discover if a signature is intended to break a recursive module loop +when we discover that $p\notin flags_H$; in this case, we fallback to the +old hs-boot behavior. (Alternatively, the user can explicitly ask for it.) + +Why does this not require a shaping pass? The reason is that the +signature is not really polymorphic: we require that the $\alpha$ module +variable be resolved to a concrete module later in the same package, and +that all the $\beta$ module variables be unified with $\alpha$. Thus, we +know ahead of time the original names and don't need to deal with any +renaming.\footnote{This strategy doesn't completely resolve the problem +of cross-package mutual recursion, because we need to first compile a +bit of the first package (signatures), then the second package, and then +the rest of the first package.} + +Compiling packages in this way gives the tantalizing possibility +of true separate compilation: the only thing we don't know is what the actual +package name of an indefinite package will be, and what the correct references +to have are. This is a very minor change to the assembly, so one could conceive +of dynamically rewriting these references at the linking stage. But +separate compilation achieved in this fashion would not be able to take +advantage of cross-module optimizations. + +\subsection{Compiling includes} + +Includes are the most interesting part of the compilation process, as we have +calculate how the holes of the subpackage we are filling in are compiled $H'$ +and modify our flags to make the exports of the include visible to subsequently +compiled modules. We consider the case with renaming, since includes with +no renaming are straightforward. + +First, we assume that we know \emph{a priori} what the holes of a +package $p_H$ are (either by some sort of pre-pass, or explicit +declaration.) For each of their \emph{renamed targets} $p'_H$, we determine +what the original module associated with the $p'_H$ is, based off of +the package database that we have been manipulating. +For example: + +\begin{verbatim} +package p where + A :: ... + ... +package q where + A = [ ... ] + B = [ ... ] + include p (A as B) +\end{verbatim} + +When computing the entry $H(\pname{A})$, we determine what the original +module for \pname{B} is. + +Next, we recursively call \textsc{Compile} with the computed $H'$. +Note that the entries in $H$ may refer to modules which would not be +picked up by $flags$, but they will be registered in the inplace +package database $db$. +For example, in this situation: + +\begin{verbatim} +package p where + B :: ... + C = [ import B; ... ] +package q where + A = [ ... ] + B = [ import A; ... ] + include p + D = [ import C; ... ] +\end{verbatim} + +When we recursively process package \pname{p}, $H$ will refer to +\pname{q}:\m{B}, and we need to know where to find it (\pname{q} is only +partially processed and so is in the inplace package database.) +Furthermore, the interface file for \m{B} may refer to \pname{q}:\m{A}, +and thus we likewise need to know how to find its interface file. + +Note that the inplace package database is not expected to expose intermediate +packages. Otherwise, this example would improperly compile: + +\begin{verbatim} +package p where + B = [ import A; ... ] +package q where + A = ... + include p +\end{verbatim} + +\pname{p} does not compile on its own, so it should not compile if it is +recursively invoked from \pname{q}. However, if we exposed the modules +of the partially registered package \pname{q}, \m{A} is now suddenly +resolvable. + +Finally, once the subpackage is compiled, we can add it to our $flags$ so later +modules we compile see its (appropriately thinned and renamed) modules, and like +aliasing. + +\paragraph{Absence of an \texttt{hi} file} +It is important that when we resolve a module, we look up the \emph{implementor} +of a module, and not just a signature which is providing it at some name. +Sometimes, it can be a bit indirect, for example: + +\begin{verbatim} +package p where + A :: [ y :: Int ] +package q where + A :: [ x :: Int ] + include p -- * +package r where + A = [ x = 0; y = 1 ] + include q +\end{verbatim} + +When computing $H'$ for the starred include, our $flags$ only include +\texttt{-package-dir} \pname{r} $cwd_r$ $\langle\rangle$: with a thinning +that excludes all modules! The only interface file we can pick up with these +$flags$ is the local definition of \m{A}. However, we \emph{absolutely} +should set $H'(\m{A})=\pname{q}:\m{A}$; if we do so, then we will incorrectly +conclude when compiling the signature in \pname{p} that the implementation +doesn't export enough identifiers to fulfill the signature (\texttt{y} is not +available from just the signature in \pname{q}). Instead, we have to look +up the original implementor of \m{A} in \pname{r}, and use that in $H'$. +If you maintain the invariant that you always know what the original implementor +is of all modules in scope, it's easy enough to figure this out. + +\subsection{Commentary} + +\paragraph{Just because it compiled, doesn't mean the individual packages type check} +The compilation mechanism described is slightly more permissive than vanilla Backpack. +Here is a simple example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B :: [ data T = T ] + C = [ + import A + import B + x = A.T :: B.T + ] +package q where + A = [ data T = T ] + B = A + include p +\end{verbatim} + +Here, we incorrectly decide \m{A}\verb|.T| and \m{B}\verb|.T| are type +equal when typechecking \m{C}, because the \verb|hisig| files we +generate for them all point to the same original implementation. However, +\pname{p} should not typecheck. + +The problem here is that type checking asks ``does it compile with respect +to all possible instantiations of the holes'', whereas compilation asks +``does it compile with respect to this particular instantiation of holes.'' +In the absence of a shaping pass, this problem is unavoidable. + +\section{Shaped Backpack} + +Despite the simplicity of shapeless Backpack with the linking +restriction in the absence of holes, we will find that when we have +holes, it will be very difficult to do type-checking without +some form of shaping. This section is very much a work in progress, +but the ability to typecheck against holes, even with the linking restriction, +is a very important part of modular separate development, so we will need +to support it at some point. + +\subsection{Efficient shaping} + +(These are Edward's opinion, he hasn't convinced other folks that this is +the right way to do it.) + +In this section, I want to argue that, although shaping constitutes +a pre-pass which must be run before compilation in earnest, it is only +about as bad as the dependency resolution analysis that GHC already does +in \verb|ghc -M| or \verb|ghc --make|. + +In Paper Backpack, what information does shaping compute? It looks at +exports, imports, data declarations and value declarations (but not the +actual expressions associated with these values.) As a matter of fact, +GHC already must look at the imports associated with a package in order +to determine the dependency graph, so that it can have some order to compile +modules in. There is a specialized parser which just parses these statements, +and then ignores the rest of the file. + +A bit of background: the \emph{renamer} is responsible for resolving +imports and figuring out where all of these entities actually come from. +SPJ would really like to avoid having to run the renamer in order to perform +a shaping pass. + +\paragraph{Is it necessary to run the Renamer to do shaping?} +Edward and Scott believe the answer is no, well, partially. +Shaping needs to know the original names of all entities exposed by a +module/signature. Then it needs to know (a) which entities a module/signature +defines/declares locally and (b) which entities that module/signature exports. +The former, (a), can be determined by a straightforward inspection of a parse +tree of the source file.\footnote{Note that no expression or type parsing +is necessary. We only need names of local values, data types, and data +constructors.} The latter, (b), is a bit trickier. Right now it's the Renamer +that interprets imports and exports into original names, so we would still +rely on that implementation. However, the Renamer does other, harder things +that we don't need, so ideally we could factor out the import/export +resolution from the Renamer for use in shaping. + +Unfortunately the Renamer's import resolution analyzes \verb|.hi| files, but for +local modules, which haven't yet been typechecked, we don't have those. +Instead, we could use a new file format, \verb|.hsi| files, to store the shape of +a locally defined module. (Defined packages are bundled with their shapes, +so included modules have \verb|.hsi| files as well.) (What about the logical +vs.~physical distinction in file names?) If we refactor the import/export +resolution code, could we rewrite it to generically operate on both +\verb|.hi| files and \verb|.hsi| files? + +Alternatively, rather than storing shapes on a per-source basis, we could +store (in memory) the entire package shape. Similarly, included packages +could have a single shape file for the entire package. Although this approach +would make shaping non-incremental, since an entire package's shape would +be recomputed any time a constituent module's shape changes, we do not expect +shaping to be all that expensive. + +\subsection{Typechecking of indefinite modules}\label{sec:typechecking-indefinite} + +Recall in our argument in the definite case, where we showed there are +no holes in the physical context. With indefinite modules, this is no +longer true. While (with the linking restriction) these holes will never +be linked against a physical implementation, they may be linked against +other signatures. (Note: while disallowing signature linking would +solve our problem, it would disallow a wide array of useful instances of +signature reuse, for example, a package mylib that implements both +mylib-1x-sig and mylib-2x-sig.) + +With holes, we must handle module variables, and we sometimes must unify them: + +\begin{verbatim} +package p where + A :: [ data A ] +package q where + A :: [ data A ] +package r where + include p + include q +\end{verbatim} + +In this package, it is not possible to a priori assign original names to +module A in p and q, because in package r, they should have the same +original name. When signature linking occurs, unification may occur, +which means we have to rename all relevant original names. (A similar +situation occurs when a module is typechecked against a signature.) + +An invariant which would be nice to have is this: when typechecking a +signature or including a package, we may apply renaming to the entities +being brought into context. But once we've picked an original name for +our entities, no further renaming should be necessary. (Formally, in the +unification for semantic object shapes, apply the unifier to the second +shape, but not the first one.) + +However, there are plenty of counterexamples here: + +\begin{verbatim} +package p where + A :: [ data A ] + B :: [ data A ] + M = ... + A = B +\end{verbatim} + +In this package, does module M know that A.A and B.A are type equal? In +fact, the shaping pass will have assigned equal module identities to A +and B, so M \emph{equates these types}, despite the aliasing occurring +after the fact. + +We can make this example more sophisticated, by having a later +subpackage which causes the aliasing; now, the decision is not even a +local one (on the other hand, the equality should be evident by inspection +of the package interface associated with q): + +\begin{verbatim} +package p where + A :: [ data A ] + B :: [ data A ] +package q where + A :: [ data A ] + B = A +package r where + include p + include q +\end{verbatim} + +Another possibility is that it might be acceptable to do a mini-shaping +pass, without parsing modules or signatures, \emph{simply} looking at +names and aliases. But logical names are not the only mechanism by +which unification may occur: + +\begin{verbatim} +package p where + C :: [ data A ] + A = [ data A = A ] + B :: [ import A(A) ] + C = B +\end{verbatim} + +It is easy to conclude that the original names of C and B are the same. But +more importantly, C.A must be given the original name of p:A.A. This can only +be discovered by looking at the signature definition for B. In any case, it +is worth noting that this situation parallels the situation with hs-boot +files (although there is no mutual recursion here). + +The conclusion is that you will probably, in fact, have to do real +shaping in order to typecheck all of these examples. + +\paragraph{Hey, these signature imports are kind of tricky\ldots} + +When signatures and modules are interleaved, the interaction can be +complex. Here is an example: + +\begin{verbatim} +package p where + C :: [ data A ] + M = [ import C; ... ] + A = [ import M; data A = A ] + C :: [ import A(A) ] +\end{verbatim} + +Here, the second signature for C refers to a module implementation A +(this is permissible: it simply means that the original name for p:C.A +is p:A.A). But wait! A relies on M, and M relies on C. Circularity? +Fortunately not: a client of package p will find it impossible to have +the hole C implemented in advance, since they will need to get their hands on module +A\ldots but it will not be defined prior to package p. + +In any case, however, it would be good to emit a warning if a package +cannot be compiled without mutual recursion. + +\subsection{Rename on entry} + +Consider the following example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B = [ import A; x = T ] +package q where + C :: ... + A = [ data T = T ] + include p + D = [ + import qualified A + import qualified B + import C + x = B.T :: A.T + ] +\end{verbatim} + +We are interested in type-checking \pname{q}, which is an indefinite package +on account of the uninstantiated hole \m{C}. Furthermore, let's suppose that +\pname{p} has already been independently typechecked, and its interface files +installed in some global location with $\alpha_A$ used as the module identity +of \m{A}. (To simplify this example, we'll assume $\beta_{AT}=\alpha_A$.) + +The first three lines of \pname{q} type check in the normal way, but \m{D} +now poses a problem: if we load the interface file for \m{B} the normal way, +we will get a reference to type \texttt{T} with the original name $\alpha_A$.\texttt{T}, +whereas from \m{A} we have an original name \pname{q}:\m{A}.\texttt{T}. + +Let's suppose that we already have the result of a shaping pass, which +maps our identity variables to their true identities. +Let's consider the possible options here: + +\begin{itemize} + \item We could re-typecheck \pname{p}, feeding it the correct instantiations + for its variables. However, this seems wasteful: we typechecked the + package already, and up-to-renaming, the interface files are exactly + what we need to type check our application. + \item We could make copies of all the interface files, renamed to have the + right original names. This also seems wasteful: why should we have to + create a new copy of every interface file in a library we depend on? + \item When \emph{reading in} the interface file to GHC, we could apply the + renaming according to the shaping pass and store that in memory. +\end{itemize} + +That last solution is pretty appealing, however, there are still circumstances +we need to create new interface files; these exactly mirror the cases described +in Section~\ref{sec:compiling}. + +\subsection{Incremental typechecking} +We want to typecheck modules incrementally, i.e., when something changes in +a package, we only want to re-typecheck the modules that care about that +change. GHC already does this today.% +\footnote{\url{https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance}} +Is the same mechanism sufficient for Backpack? Edward and Scott think that it +is, mostly. Our conjecture is that a module should be re-typechecked if the +existing mechanism says it should \emph{or} if the logical shape +context (which maps logical names to physical names) has changed. The latter +condition is due to aliases that affect typechecking of modules. + +Let's look again at an example from before: +\begin{verbatim} +package p where + A :: [ data A ] + B :: [ data A ] + M = [ import A; import B; ... ] +\end{verbatim} +Let's say that \verb|M| is typechecked successfully. Now we add an alias binding +at the end of the package, \verb|A = B|. Does \verb|M| need to be +re-typechecked? Yes! (Well, it seems so, but let's just assert ``yes'' for now. +Certainly in the reverse case---if we remove the alias and then ask---this +is true, since \verb|M| might have depended on the two \verb|A| types +being the same.) +The logical shape context changed to say that \verb|A| and +\verb|B| now map to the same physical module identity. But does the existing +recompilation avoidance mechanism say that \verb|M| should be re-typechecked? +It's unclear. The \verb|.hi| file for \verb|M| records that it imported \verb|A| and +\verb|B| with particular ABIs, but does it also know about the physical module +identities (or rather, original module names) of these modules? + +Scott thinks this highlights the need for us to get our story straight about +the connection between logical names, physical module identities, and file +names! + + +\subsection{Installing indefinite packages}\label{sec:installing-indefinite} + +If an indefinite package contains no code at all, we only need +to install the interface file for the signatures. However, if +they include code, we must provide all of the +ingredients necessary to compile them when the holes are linked against +actual implementations. (Figure~\ref{fig:pkgdb}) + +\paragraph{Source tarball or preprocessed source?} What is the representation of the source that is saved is. There +are a number of possible choices: + +\begin{itemize} + \item The original tarballs downloaded from Hackage, + \item Preprocessed source files, + \item Some sort of internal, type-checked representation of Haskell code (maybe the output of the desugarer). +\end{itemize} + +Storing the tarballs is the simplest and most straightforward mechanism, +but we will have to be very certain that we can recompile the module +later in precisely the same we compiled it originally, to ensure the hi +files match up (fortunately, it should be simple to perform an optional +sanity check before proceeding.) The appeal of saving preprocessed +source, or even the IRs, is that this is conceptually this is exactly +what an indefinite package is: we have paused the compilation process +partway, intending to finish it later. However, our compilation strategy +for definite packages requires us to run this step using a \emph{different} +choice of original names, so it's unclear how much work could actually be reused. + +\paragraph{Sources in sandboxes} Another nice way to implement indefinite +packages is to register them as source packages in a Cabal sandbox, and then +teach Cabal how to build them multiple times in the compile process. Perhaps +the global package database should be extended with a directory of source +packages in order to support indefinite packages. + +\section{Surface syntax} + +In the Backpack paper, a brand new module language is presented, with +syntax for inline modules and signatures. This syntax is probably worth implementing, +because it makes it easy to specify compatibility packages, whose module +definitions in general may be very short: + +\begin{verbatim} +package ishake-0.12-shake-0.13 where + include shake-0.13 + Development.Shake.Sys = Development.Shake.Cmd + Development.Shake = [ (**>) = (&>) ; (*>>) = (|*>)] + Development.Shake.Rule = [ defaultPriority = rule . priority 0.5 ] + include ishake-0.12 +\end{verbatim} + +However, there are a few things that are less than ideal about the +surface syntax proposed by Paper Backpack: + +\begin{itemize} + \item It's completely different from the current method users + specify packages. There's nothing wrong with this per se + (one simply needs to support both formats) but the smaller + the delta, the easier the new packaging format is to explain + and implement. + + \item Sometimes order matters (relative ordering of signatures and + module implementations), and other times it does not (aliases). + This can be confusing for users. + + \item Users have to order module definitions topologically, + whereas in current Cabal modules can be listed in any order, and + GHC figures out an appropriate order to compile them. +\end{itemize} + +Here is an alternative proposal, closely based on Cabal syntax. Given +the following Backpack definition: + +\begin{verbatim} +package libfoo(A, B, C, Foo) where + include base + -- renaming and thinning + include libfoo (Foo, Bar as Baz) + -- holes + A :: [ a :: Bool ].hsig + A2 :: [ b :: Bool ].hsig + -- normal module + B = [ + import {-# SOURCE #-} A + import Foo + import Baz + ... + ].hs + -- recursively linked pair of modules, one is private + C :: [ data C ].hsig + D = [ import {-# SOURCE #-} C; data D = D C ].hs + C = [ import D; data C = C D ].hs + -- alias + A = A2 +\end{verbatim} + +We can write the following Cabal-like syntax instead (where +all of the signatures and modules are placed in appropriately +named files): + +\begin{verbatim} +package: libfoo +... +build-depends: base, libfoo (Foo, Bar as Baz) +required-signatures: A A2 -- deferred for now +exposed-modules: Foo B C +aliases: A = A2 +other-modules: D +\end{verbatim} + +Notably, all of these lists are \emph{insensitive} to ordering! +The key idea is use of the \verb|{-# SOURCE #-}| pragma, which +is enough to solve the important ordering constraint between +signatures and modules. + +Here is how the elaboration works. For simplicity, in this algorithm +description, we assume all packages being compiled have no holes +(including \verb|build-depends| packages). Later, we'll discuss how to +extend the algorithm to handle holes in both subpackages and the main +package itself. + +\begin{enumerate} + + \item At the top-level with \verb|package| $p$ and + \verb|exposed-modules| $ms$, record \verb|package p (ms) where| + + \item For each package $p$ with thinning/renaming $ms$ in + \verb|build-depends|, record a \verb|include p (ms)| in the + Backpack package. The ordering of these includes does not + matter, since none of these packages have holes. + + \item Take all modules $m$ in \verb|other-modules| and + \verb|exposed-modules| which were not exported by build + dependencies, and create a directed graph where hs and hs-boot + files are nodes and imports are edges (the target of an edge is + an hs file if it is a normal import, and an hs-boot file if it + is a SOURCE import). Topologically sort this graph, erroring if + this graph contains cycles (even with recursive modules, the + cycle should have been broken by an hs-boot file). For each + node, in this order, record \verb|M = [ ... ]| or \verb|M :: [ ... ]| + depending on whether or not it is an hs or hs-boot. If possible, + sort signatures before implementations when there is no constraint + otherwise. + +\end{enumerate} + +Here is a simple example which shows how SOURCE can be used to disambiguate +between two important cases. Suppose we have these modules: + +\begin{verbatim} +-- A1.hs +import {-# SOURCE #-} B + +-- A2.hs +import B + +-- B.hs +x = True + +-- B.hs-boot +x :: Bool +\end{verbatim} + +Then we translate the following packages as follows: + +\begin{verbatim} +exposed-modules: A1 B +-- translates to +B :: [ x :: Bool ] +A1 = [ import B ] +B = [ x = True ] +\end{verbatim} + +but + +\begin{verbatim} +exposed-modules: A2 B +-- translates to +B = [ x = True ] +B :: [ x :: Bool ] +A2 = [ import B ] +\end{verbatim} + +The import controls placement between signature and module, and in A1 it +forces B's signature to be sorted before B's implementation (whereas in +the second section, there is no constraint so we preferentially place +the B's implementation first) + +\paragraph{Holes in the database} In the presence of holes, +\verb|build-depends| resolution becomes more complicated. First, +let's consider the case where the package we are building is +definite, but the package database contains indefinite packages with holes. +In order to maintain the linking restriction, we now have to order packages +from step (2) of the previous elaboration. We can do this by creating +a directed graph, where nodes are packages and edges are from holes to the +package which implements them. If there is a cycle, this indicates a mutually +recursive package. In the absence of cycles, a topological sorting of this +graph preserves the linking invariant. + +One subtlety to consider is the fact that an entry in \verb|build-depends| +can affect how a hole is instantiated by another entry. This might be a +bit weird to users, who might like to explicitly say how holes are +filled when instantiating a package. Food for thought, surface syntax wise. + +\paragraph{Holes in the package} Actually, this is quite simple: the +ordering of includes goes as before, but some indefinite packages in the +database are less constrained as they're ``dependencies'' are fulfilled +by the holes at the top-level of this package. It's also worth noting +that some dependencies will go unresolved, since the following package +is valid: + +\begin{verbatim} +package a where + A :: ... +package b where + include a +\end{verbatim} + +\paragraph{Multiple signatures} In Backpack syntax, it's possible to +define a signature multiple times, which is necessary for mutually +recursive signatures: + +\begin{verbatim} +package a where + A :: [ data A ] + B :: [ import A; data B = B A ] + A :: [ import B; data A = A B ] +\end{verbatim} + +Critically, notice that we can see the constructors for both module B and A +after the signatures are linked together. This is not possible in GHC +today, but could be possible by permitting multiple hs-boot files. Now +the SOURCE pragma indicating an import must \emph{disambiguate} which +hs-boot file it intends to include. This might be one way of doing it: + +\begin{verbatim} +-- A.hs-boot2 +data A + +-- B.hs-boot +import {-# SOURCE hs-boot2 #-} A + +-- A.hs-boot +import {-# SOURCE hs-boot #-} B +\end{verbatim} + +\paragraph{Explicit or implicit reexports} One annoying property of +this proposal is that, looking at the \verb|exposed-modules| list, it is +not immediately clear what source files one would expect to find in the +current package. It's not obvious what the proper way to go about doing +this is. + +\paragraph{Better syntax for SOURCE} If we enshrine the SOURCE import +as a way of solving Backpack ordering problems, it would be nice to have +some better syntax for it. One possibility is: + +\begin{verbatim} +abstract import Data.Foo +\end{verbatim} + +which makes it clear that this module is pluggable, typechecking against +a signature. Note that this only indicates how type checking should be +done: when actually compiling the module we will compile against the +interface file for the true implementation of the module. + +It's worth noting that the SOURCE annotation was originally made a +pragma because, in principle, it should have been possible to compile +some recursive modules without needing the hs-boot file at all. But if +we're moving towards boot files as signatures, this concern is less +relevant. + +\section{Type classes and type families} + +\subsection{Background} + +Before we talk about how to support type classes in Backpack, it's first +worth talking about what we are trying to achieve in the design. Most +would agree that \emph{type safety} is the cardinal law that should be +preserved (in the sense that segfaults should not be possible), but +there are many instances of ``bad behavior'' (top level mutable state, +weakening of abstraction guarantees, ambiguous instance resolution, etc) +which various Haskellers may disagree on the necessity of ruling out. + +With this in mind, it is worth summarizing what kind of guarantees are +presently given by GHC with regards to type classes and type families, +as well as characterizing the \emph{cultural} expectations of the +Haskell community. + +\paragraph{Type classes} When discussing type class systems, there are +several properties that one may talk about. +A set of instances is \emph{confluent} if, no matter what order +constraint solving is performed, GHC will terminate with a canonical set +of constraints that must be satisfied for any given use of a type class. +In other words, confluence says that we won't conclude that a program +doesn't type check just because we swapped in a different constraint +solving algorithm. + +Confluence's closely related twin is \emph{coherence} (defined in ``Type +classes: exploring the design space''). This property states that +``every different valid typing derivation of a program leads to a +resulting program that has the same dynamic semantics.'' Why could +differing typing derivations result in different dynamic semantics? The +answer is that context reduction, which picks out type class instances, +elaborates into concrete choices of dictionaries in the generated code. +Confluence is a prerequisite for coherence, since one +can hardly talk about the dynamic semantics of a program that doesn't +type check. + +In the vernacular, confluence and coherence are often incorrectly used +to refer to another related property: \emph{global uniqueness of instances}, +which states that in a fully compiled program, for any type, there is at most one +instance resolution for a given type class. Languages with local type +class instances such as Scala generally do not have this property, and +this assumption is frequently used for abstraction. + +So, what properties does GHC enforce, in practice? +In the absence of any type system extensions, GHC's employs a set of +rules (described in ``Exploring the design space'') to ensure that type +class resolution is confluent and coherent. Intuitively, it achieves +this by having a very simple constraint solving algorithm (generate +wanted constraints and solve wanted constraints) and then requiring the +set of instances to be \emph{nonoverlapping}, ensuring there is only +ever one way to solve a wanted constraint. Overlap is a +more stringent restriction than either confluence or coherence, and +via the \verb|OverlappingInstances| and \verb|IncoherentInstances|, GHC +allows a user to relax this restriction ``if they know what they're doing.'' + +Surprisingly, however, GHC does \emph{not} enforce global uniqueness of +instances. Imported instances are not checked for overlap until we +attempt to use them for instance resolution. Consider the following program: + +\begin{verbatim} +-- T.hs +data T = T +-- A.hs +import T +instance Eq T where +-- B.hs +import T +instance Eq T where +-- C.hs +import A +import B +\end{verbatim} + +When compiled with one-shot compilation, \verb|C| will not report +overlapping instances unless we actually attempt to use the \verb|Eq| +instance in C.\footnote{When using batch compilation, GHC reuses the + instance database and is actually able to detect the duplicated + instance when compiling B. But if you run it again, recompilation +avoidance skips A, and it finishes compiling! See this bug: +\url{https://ghc.haskell.org/trac/ghc/ticket/5316}} This is by +design\footnote{\url{https://ghc.haskell.org/trac/ghc/ticket/2356}}: +ensuring that there are no overlapping instances eagerly requires +eagerly reading all the interface files a module may depend on. + +We might summarize these three properties in the following manner. +Culturally, the Haskell community expects \emph{global uniqueness of instances} +to hold: the implicit global database of instances should be +confluent and coherent. GHC, however, does not enforce uniqueness of +instances: instead, it merely guarantees that the \emph{subset} of the +instance database it uses when it compiles any given module is confluent and coherent. GHC does do some +tests when an instance is declared to see if it would result in overlap +with visible instances, but the check is by no means +perfect\footnote{\url{https://ghc.haskell.org/trac/ghc/ticket/9288}}; +truly, \emph{type-class constraint resolution} has the final word. One +mitigating factor is that in the absence of \emph{orphan instances}, GHC is +guaranteed to eagerly notice when the instance database has overlap.\footnote{Assuming that the instance declaration checks actually worked\ldots} + +Clearly, the fact that GHC's lazy behavior is surprising to most +Haskellers means that the lazy check is mostly good enough: a user +is likely to discover overlapping instances one way or another. +However, it is relatively simple to construct example programs which +violate global uniqueness of instances in an observable way: + +\begin{verbatim} +-- A.hs +module A where +data U = X | Y deriving (Eq, Show) + +-- B.hs +module B where +import Data.Set +import A + +instance Ord U where +compare X X = EQ +compare X Y = LT +compare Y X = GT +compare Y Y = EQ + +ins :: U -> Set U -> Set U +ins = insert + +-- C.hs +module C where +import Data.Set +import A + +instance Ord U where +compare X X = EQ +compare X Y = GT +compare Y X = LT +compare Y Y = EQ + +ins' :: U -> Set U -> Set U +ins' = insert + +-- D.hs +module Main where +import Data.Set +import A +import B +import C + +test :: Set U +test = ins' X $ ins X $ ins Y $ empty + +main :: IO () +main = print test + +-- OUTPUT +$ ghc -Wall -XSafe -fforce-recomp --make D.hs +[1 of 4] Compiling A ( A.hs, A.o ) +[2 of 4] Compiling B ( B.hs, B.o ) + +B.hs:5:10: Warning: Orphan instance: instance [safe] Ord U +[3 of 4] Compiling C ( C.hs, C.o ) + +C.hs:5:10: Warning: Orphan instance: instance [safe] Ord U +[4 of 4] Compiling Main ( D.hs, D.o ) +Linking D ... +$ ./D +fromList [X,Y,X] +\end{verbatim} + +Locally, all type class resolution was coherent: in the subset of +instances each module had visible, type class resolution could be done +unambiguously. Furthermore, the types of \verb|ins| and \verb|ins'| +discharge type class resolution, so that in \verb|D| when the database +is now overlapping, no resolution occurs, so the error is never found. + +It is easy to dismiss this example as an implementation wart in GHC, and +continue pretending that global uniqueness of instances holds. However, +the problem with \emph{global uniqueness of instances} is that they are +inherently nonmodular: you might find yourself unable to compose two +components because they accidentally defined the same type class +instance, even though these instances are plumbed deep in the +implementation details of the components. + +As it turns out, there is already another feature in Haskell which +must enforce global uniqueness, to prevent segfaults. +We now turn to type classes' close cousin: type families. + +\paragraph{Type families} With type families, confluence is the primary +property of interest. (Coherence is not of much interest because type +families are elaborated into coercions, which don't have any +computational content.) Rather than considering what the set of +constraints we reduce to, confluence for type families considers the +reduction of type families. The overlap checks for type families +can be quite sophisticated, especially in the case of closed type +families. + +Unlike type classes, however, GHC \emph{does} check the non-overlap +of type families eagerly. The analogous program does \emph{not} type check: + +\begin{verbatim} +-- F.hs +type family F a :: * +-- A.hs +import F +type instance F Bool = Int +-- B.hs +import F +type instance F Bool = Bool +-- C.hs +import A +import B +\end{verbatim} + +The reason is that it is \emph{unsound} to ever allow any overlap +(unlike in the case of type classes where it just leads to incoherence.) +Thus, whereas one might imagine dropping the global uniqueness of instances +invariant for type classes, it is absolutely necessary to perform global +enforcement here. There's no way around it! + +\subsection{Local type classes} + +Here, we say \textbf{NO} to global uniqueness. + +This design is perhaps best discussed in relation to modular type +classes, which shares many similar properties. Instances are now +treated as first class objects (in MTCs, they are simply modules)---we +may explicitly hide or include instances for type class resolution (in +MTCs, this is done via the \verb|using| top-level declaration). This is +essentially what was sketched in Section 5 of the original Backpack +paper. As a simple example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B = [ import A; instance Eq T where ... ] + +package q where + A = [ data T = T; instance Eq T where ... ] + include p +\end{verbatim} + +Here, \verb|B| does not see the extra instance declared by \verb|A|, +because it was thinned from its signature of \verb|A| (and thus never +declared canonical.) To declare an instance without making it +canonical, it must placed in a separate (unimported) module. + +Like modular type classes, Backpack does not give rise to incoherence, +because instance visibility can only be changed at the top level module +language, where it is already considered best practice to provide +explicit signatures. Here is the example used in the Modular Type +Classes paper to demonstrate the problem: + +\begin{verbatim} +structure A = using EqInt1 in + struct ...fun f x = eq(x,x)... end +structure B = using EqInt2 in + struct ...val y = A.f(3)... end +\end{verbatim} + +Is the type of f \verb|int -> bool|, or does it have a type-class +constraint? Because type checking proceeds over the entire program, ML +could hypothetically pick either. However, ported to Haskell, the +example looks like this: + +\begin{verbatim} +EqInt1 :: [ instance Eq Int ] +EqInt2 :: [ instance Eq Int ] +A = [ + import EqInt1 + f x = x == x +] +B = [ + import EqInt2 + import A hiding (instance Eq Int) + y = f 3 +] +\end{verbatim} + +There may be ambiguity, yes, but it can be easily resolved by the +addition of a top-level type signature to \verb|f|, which is considered +best-practice anyway. Additionally, Haskell users are trained to expect +a particular inference for \verb|f| in any case (the polymorphic one). + +Here is another example which might be considered surprising: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B :: [ data T = T ] + C = [ + import qualified A + import qualified B + instance Show A.T where show T = "A" + instance Show B.T where show T = "B" + x :: String + x = show A.T ++ show B.T + ] +\end{verbatim} + +In the original Backpack paper, it was implied that module \verb|C| +should not type check if \verb|A.T = B.T| (failing at link time). +However, if we set aside, for a moment, the issue that anyone who +imports \verb|C| in such a context will now have overlapping instances, +there is no reason in principle why the module itself should be +problematic. Here is the example in MTCs, which I have good word from +Derek does type check. + +\begin{verbatim} +signature SIG = sig + type t + val mk : t +end +signature SHOW = sig + type t + val show : t -> string +end +functor Example (A : SIG) (B : SIG) = + let structure ShowA : SHOW = struct + type t = A.t + fun show _ = "A" + end in + let structure ShowB : SHOW = struct + type t = B.t + fun show _ = "B" + end in + using ShowA, ShowB in + struct + val x = show A.mk ++ show B.mk + end : sig val x : string end +\end{verbatim} + +The moral of the story is, even though in a later context the instances +are overlapping, inside the functor, the type-class resolution is unambiguous +and should be done (so \verb|x = "AB"|). + +Up until this point, we've argued why MTCs and this Backpack design are similar. +However, there is an important sociological difference between modular type-classes +and this proposed scheme for Backpack. In the presentation ``Why Applicative +Functors Matter'', Derek mentions the canonical example of defining a set: + +\begin{verbatim} +signature ORD = sig type t; val cmp : t -> t -> bool end +signature SET = sig type t; type elem; + val empty : t; + val insert : elem -> t -> t ... +end +functor MkSet (X : ORD) :> SET where type elem = X.t + = struct ... end +\end{verbatim} + +This is actually very different from how sets tend to be defined in +Haskell today. If we directly encoded this in Backpack, it would +look like this: + +\begin{verbatim} +package mk-set where + X :: [ + data T + cmp :: T -> T-> Bool + ] + Set :: [ + data Set + empty :: Set + insert :: T -> Set -> Set + ] + Set = [ + import X + ... + ] +\end{verbatim} + +It's also informative to consider how MTCs would encode set as it is written +today in Haskell: + +\begin{verbatim} +signature ORD = sig type t; val cmp : t -> t -> bool end +signature SET = sig type 'a t; + val empty : 'a t; + val insert : (X : ORD) => X.t -> X.t t -> X.t t +end +struct MkSet :> SET = struct ... end +\end{verbatim} + +Here, it is clear to see that while functor instantiation occurs for +implementation, it is not occuring for types. This is a big limitation +with the Haskell approach, and it explains why Haskellers, in practice, +find global uniqueness of instances so desirable. + +Implementation-wise, this requires some subtle modifications to how we +do type class resolution. Type checking of indefinite modules works as +before, but when go to actually compile them against explicit +implementations, we need to ``forget'' that two types are equal when +doing instance resolution. This could probably be implemented by +associating type class instances with the original name that was +utilized when typechecking, so that we can resolve ambiguous matches +against types which have the same original name now that we are +compiling. + +As we've mentioned previously, this strategy is unsound for type families. + +\subsection{Globally unique} + +Here, we say \textbf{YES} to global uniqueness. + +When we require the global uniqueness of instances (either because +that's the type class design we chose, or because we're considering +the problem of type families), we will need to reject declarations like the +one cited above when \verb|A.T = B.T|: + +\begin{verbatim} +A :: [ data T ] +B :: [ data T ] +C :: [ + import qualified A + import qualified B + instance Show A.T where show T = "A" + instance Show B.T where show T = "B" +] +\end{verbatim} + +The paper mentions that a link-time check is sufficient to prevent this +case from arising. While in the previous section, we've argued why this +is actually unnecessary when local instances are allowed, the link-time +check is a good match in the case of global instances, because any +instance \emph{must} be declared in the signature. The scheme proceeds +as follows: when some instances are typechecked initially, we type check +them as if all of variable module identities were distinct. Then, when +we perform linking (we \verb|include| or we unify some module +identities), we check again if to see if we've discovered some instance +overlap. This linking check is akin to the eager check that is +performed today for type families; it would need to be implemented for +type classes as well: however, there is a twist: we are \emph{redoing} +the overlap check now that some identities have been unified. + +As an implementation trick, one could deferring the check until \verb|C| +is compiled, keeping in line with GHC's lazy ``don't check for overlap +until the use site.'' (Once again, unsound for type families.) + +\paragraph{What about module inequalities?} An older proposal was for +signatures to contain ``module inequalities'', i.e., assertions that two +modules are not equal. (Technically: we need to be able to apply this +assertion to $\beta$ module variables, since \verb|A != B| while +\verb|A.T = B.T|). Currently, Edward thinks that module inequalities +are only marginal utility with local instances (i.e., not enough to +justify the implementation cost) and not useful at all in the world of +global instances! + +With local instances, module inequalities could be useful to statically +rule out examples like \verb|show A.T ++ show B.T|. Because such uses +are not necessarily reflected in the signature, it would be a violation +of separate module development to try to divine the constraint from the +implementation itself. I claim this is of limited utility, however, because, +as we mentioned earlier, we can compile these ``incoherent'' modules perfectly +coherently. With global instances, all instances must be in the signature, so +while it might be aesthetically displeasing to have the signature impose +extra restrictions on linking identities, we can carry this out without +violating the linking restriction. + +\section{Bits and bobs} + +\subsection{Abstract type synonyms} + +In Paper Backpack, abstract type synonyms are not permitted, because GHC doesn't +understand how to deal with them. The purpose of this section is to describe +one particularly nastiness of abstract type synonyms, by way of the occurs check: + +\begin{verbatim} +A :: [ type T ] +B :: [ import qualified A; type T = [A.T] ] +\end{verbatim} + +At this point, it is illegal for \verb|A = B|, otherwise this type synonym would +fail the occurs check. This seems like pretty bad news, since every instance +of the occurs check in the type-checker could constitute a module inequality. + +\section{Open questions}\label{sec:open-questions} + +Here are open problems about the implementation which still require +hashing out. + +\begin{itemize} + + \item In Section~\ref{sec:simplifying-backpack}, we argued that we + could implement Backpack without needing a shaping pass. We're + pretty certain that this will work for typechecking and + compiling fully definite packages with no recursive linking, but + in Section~\ref{sec:typechecking-indefinite}, we described some + of the prevailing difficulties of supporting signature linking. + Renaming is not an insurmountable problem, but backwards flow of + shaping information can be, and it is unclear how best to + accommodate this. This is probably the most important problem + to overcome. + + \item In Section~\ref{sec:installing-indefinite}, a few choices for how to + store source code were pitched, however, there is not consensus on which + one is best. + + \item What is the impact of the multiplicity of PackageIds on + dependency solving in Cabal? Old questions of what to prefer + when multiple package-versions are available (Cabal originally + only needed to solve this between different versions of the same + package, preferring the oldest version), but with signatures, + there are more choices. Should there be a complex solver that + does all signature solving, or a preprocessing step that puts + things back into the original Cabal version. Authors may want + to suggest policy for what packages should actually link against + signatures (so a crypto library doesn't accidentally link + against a null cipher package). + +\end{itemize} + +\end{document} diff --git a/docs/backpack/backpack-manual.pdf b/docs/backpack/backpack-manual.pdf new file mode 100644 index 0000000000000000000000000000000000000000..5d686d6d45dc75d97d9c7a2e6abe9aed05e7a4f1 GIT binary patch literal 199748 zcma(2LwGJ+(?*NNwr$(CZCg*cV%xTD+qSJ0+qRPx?f0B(_x9KL=T(i_t=<@QSCK1; zNzgMhu)~lqERU|ka5E7x5!stq!|?IJFvyhy|BL_+pFIqm=E%163zWq>t&ApAsEBb$O%k)ses-=wV zj$0^J@9=yHzHBzGf8O623o^Wv z(a@xeB20isVD0lOgsx(sf0oovW4sZ%`M|Fo1wH)x*7Ht;3r#wDwqX}t6F+WYIS)Kx z@vhxJC+dxj92^1%Jq}M6)h50xTY+jE&~FiFD+TrTB|7bCKCu~;Qj2dw%--lE*=A7^ zK$M3AR(l=`F6ZRRY~Uj}-XzC&nOs_wHk{blK@I5}z&T%Dox1sD^Y5e-)25RFKd>@f zAbt-Q+lj`P`I&aUws4?fTTDZ^$g9q4toNeaJw)tFY`_!Rh_3oc(GUpd32zVC1qS59OP5_tJ7T)q(sYc{dbF4f<4~Dtf+XP zc$X823ubz4i5B8yMr_paab~n&w%(m_PL^x=(~beKWuC{sBwGyp+|W&aE}-dS3(7*l zb=Y;TS3C*nOA`aF$l^G%9F&XoIBX0rAB$s;RQq?8n4ZFcr3XPb)j+3s;ol2_~pveSH84S%!jNsoAPJxkb`hPduL0TVR@P#7=&bt2p({t?Un4DdgK*2g1coEe?4 zxD3!iI9gS=_;GrfAhevS6gBQ)8InnADu={mJ?KU?E;cR}t0f^!E^doF;sm8JNy7X= z6bV(dg4Bg&poUv)9+LJ9{I21kG-zJR#NtLiL!U>32$=MHn#1SIfygNdSb$%)<4fCW zrWowGNLat>WA+&g8@vZpN<_h_BUdQ zEb_c(*{7F@Ax3p`WMnFB@Uoky_{a`5liV>Y@p(oC^e$Y*6CnC|{~r5-w4;9ZCpLv= zC8uwSJPr!0FrLJ&X-(jkojeLmUqxHAO)P4oAoGAC6gSvNm`|Q0BV9Q$MuFm&%LL(f zc%@1;L<@}|hd`-;#>ITFD32^u1oQn3!sq(hyJpdOwvK}$A4Mu4(~jr@wN#Dv8R6^msUM3 z6;8a!A)u5Gf|^3ZFHyc!yI_Wm3L+csG8!u?2%?1JMBd@dD-IvA?<{5HwlsLAyaa)} zcsI~LeTT>mxFlaSfXWzqOa z+VrCxOmI&^o6)wRhQ8A|!?Gysh*-*otw^=}P2spFZZsqyVq~D5q@6nv{~KBw)u;av zyF_qXB|&pji?dyoPGvIShzzkKTXX8Ln&N-NInS*GcD%HN(g; z*i$uy)mij7m|vrJu>gvBd}^(gXz|D?NY1cI2wx{MnoEBe`B|4 z@77bC#Ip+I+qI;|8EBS<5Sq;EInHSs1Pe~Dy_N!wJJZX4MS&|Dq8d|TuJ3hxp8b}n zDZyS{H`c2%ow>x?TPcQB&q3Gf;7j!=u21QOQ!(O_rYpwUrFXq9F)BRSV2T*>lD3|b zJ!u%y-^pYSvDZ4>-!i%+X%Oks}f<)#{4}i5T0%?_LAtja6Q2;54Clv!HjR zfHn(s_SB^R{bBI2n&>A_Fxn6RM=?kg5OO2*bBMkC-a2hlm=N7YJ;w27#o>dTuJ7zk z?W)yBP1w*d1ib{AP%8@w+&yNN5z4GClWJW@_;XbEe;eZ3-zM#u1>N_Vl;Sm2k!4(RdyUz@H@9-PwM-R9Trc{ z5XGB>AR48n$7RC`zFVJDMyTtyW38NRQ9Cu=2y;#94EFXQ9ZdT;^1dk=$AvfTid4Fj z=@qz%^Dc;;7?CYkW1IogFDreml1bm9_*^rEw4o7BqeqE!PIS|SM-oyGqzA>26GZwljZ$5HZqEJesYGWP#5F7w-J83|3 zOJ=%VGv)`vS&5bCcC`iupfKy*T>?Gr;R1Z!%gIj8n}-G)gqF zZ=Xy3CwDE|vIS1F9VyF1Mg`#3DVOReFrA_hmhXZ}CsluTP1oo^QA|$O)##|{?Jh#P{{ZDjm&R*X> z=$sWqiDO)jN#-vvZdZAJrlt-rJo=Jcu{WRa+aTD=$Z&Duk++>Lk+>Y^*YPgzn=2Bg zgCM5_zIn{cF1Dm!;O2x2N*I8h+5Zd8|NZ`dz|G9e`u|05RyH=K|0{ae>gdKFwW0gv z8yc7RHUy$;rikgcA&N6}Tj?AZ&H{-if&ohw*&3ToCm!d%^xt(Vr~Q$4Q+_sDbbj!vV~v z7s=@D$G0}VbGkO(-~XMU7=A`GLzF&_0N*` z;~(eN(~Lap$pgNf16rDY-#1ctGCgF|8PVUW1(G&Fdl1yj7dt~I(uA}4*OFHv#6r7x zTcx(tr+P+x{*D3xgu1QGzdO^KlvPqF+O+AUn`<51`ZbFBvL=-d#`zx#@25MvXN^`Vr{*31~xL4Q27-Da7(}r6uEA_d`JA=3!)hbueFSuEzRW=WK#WBiHtK-oH)R z-gIJz1RCFse}Gn+b!7)L5fhF`)SsY39FB=@I8Ev9uJn|W27~Q8ic6cNKugkZyWxT+ zzkGUgiATb)?$zI1;-8BJAI7apE|lhFZ?zqTNi}v4*eS_LiIR^{MiSr_pDPm(6(MHh zt;n0dn<>{2r9g>+TL{t3K2uM%uxMX*R$Uuu^Ap^C#G{tN-gK`H*`Fu{Nv7P#h??cW ziFyxHgVJ(Hj5_j2V$h2Bk62W=*h#34TlbC_BbW811CaJ+N?_OT*Uz%o%>UB#WoZPV z0}~vWj~uq1l^w2`@-p4mg`rmfysxjOTot@#m)RZq^KD5{Nz2*#da_wF=dis=fsT=< z8sKOl3jr1RS<@7X0TvqjOzOreGbh)4S(9H$PDP~qH^Mgd)rlj%J&lmff-YxC$lOu>nuTX51`F_yy=gSI#Imt|bVdz|hSI?tx%MG#w#oSM=_Osn)>CNH%Q;WAQ z+Y;4K^%r%&HzYY0bjjj5@bBF`y#>2FWlIrs%*Z>aP2+33)2Zah=m1Qy@ovqylRT#@ zooG40zKX@|Ev)`k2e{WaOrH~MESLarad7P*+FSqk(YODuFQmD|0owf=`rEtsICLaB zTW`d(UX|ftmu8@{xZCg#;iN`26@A$%T_hWm7njx_5W1bosH*`+`5nY<>vXuvIFi(m z&iwd99&})m%nJ9M20zaW>hqNZ8cOMdh47AAj6OCWk-A!}r8t+1B5*LicCnQb4wo)IB}kKh_-72PGYT z3S2)fL%Rqx8vioOG-!W6-zy>%Op<3EM_;jK z`@__VosR!P+{=0S9uO&;UJ^Uvw1Cqs=MNtAu5bZcB8zsL((nXpY^D+Fx`3e=_jCO5 zW-aT-bAZF$Z8JWc?z;(Poq;t%acq3m`nTcj*JK(##ws?o13eT8oZugC{Jl>l5>SWg@10w?f3#7+ zZI$70VoIu;$c(RZBF(3sv78_lk{qNAgcmsvUJ#13HO48FEH-#nYU%=P-@!yU zoMa*S?11*9|A_$aeCRB!5QkiEY5-i4-j(QSc(1#~|AY&MJ*;89x##%o|;i7z!y7b#3Xk zdzSa%%^wx5js{qxs@tU>!`@Gb;>sI$Fx0r57?dgh)#V!NabTkOIc%?1{C6oUiyw^x z+ccFtZ-@KL9uvK_fZl43l)d#-{h}Bnjndq!LWccoAgg*#xWRxO(m_Rx-24$YJ z@NTS0Xf^?fyx5H!P&Y%~JKbg#pXXBJLBaJ~e1B^zn-=Kb!%U9~VGlQ@lJ?9h@5@f? zUW_<#lv&_~d!}nIqmwA~X3lJ(pq3R271{#pqlS(L1qw?HedvjiWJDhCLic)MiTByc z3;7heh*Mj6998646XR8DZV4GviVQ`c4;z0IOXZ*BJQA)r9UqBvRE?HCVYDniKcYPw z2&Kh+u|h#LqUo@Np&i%I=3(wiZ>05*pW7m#4J{nf&DLv{fgjXduU z8D23M%%p};1Gm9$@yMyV!s9-~yiGSP2m4By7rJF76yHGASo_v5N=O<_<&~{_E3rv^ z<+N9Zc8vEqhjPdDLTpo@&fzL*L@7)`4YE!Pbx~>b|hut~R zSeXKlQpK+aMR64IOAgTq%^B;EadeZUg2x`CvDT=8WvhjQxBLNb4K`2n3aVj(38pgE zBYtE`n|);;!b))O<$Am(oP+(Vn}83`lu#&OpM*G5P**&b ztPgflzYH-ge$`hEoI~;j?;{)O!3a@N^pid&1;T4bjsQcR_F<|ZnC}r~!2`KHb>VZ| zon*7kHMZOO)I$>WgAy0Xzo4^1@*}hqXryB7lz$9qMXCqlvn_h5G%q{Jw#d}1xXP$< z-swV;E2HW&c}j=|FFfC(M6oDE)lL`x*>ugxjvtFC&PN>sY4* zu;O?~UtrV)EHEyU8J5OE09WC$S^aAc4k|7+IV_BxwC96S&`jV63zRzcW}L%4NF`Ez zS3`wDlN})*MY-oOw}WdNfkf9@gDGS3w#|6ds*=KMEl%Nx%~Z){eOni_1=^+ZB4<5 z>Gwb0BlMJ3BkYmp?B`?uQNzz{m z!>L^GY9w=yGwySyCw>RSygP6s1saIY9a)lwl~!3M-2=RYH0EZNo^sh{$V5W?(sfte zUd9s(vs~8BD>vf>oifkoKeT@RUIRw=iYqj$Qkp+UwP;Z>fY$UvcZ0>+)1LcN6;Rmz zhrqFL{ttoU;AZ*13!Jp`(HMH)e7zBQcwrR;R>5MdgrY+8dfZ`&UfhWcc^e`TbYz57 z0EE!&`QDjrY-oVlMrv@>PW@ZE-<|N{r5$>0pC|g{U3j*peZPkJiAZ{ti>q^YlQrOo zDh8#yYopdr2h&hNQ@Ci=Rrfl`RQ_h?L#aixfBWm^W^Kc=a;Y#HWj!6EFTB#KYj<_r zl%Qpl+WxU_o%unj4Zm%ss}BHkTf?%M30d_8WwEe+=G)mDG|2DX?Mn?>o^$@DNuht{ z9(tX!N4m&3*ZAZBnBieW{5U0Qwz~?Or;Z2iGee)a3Fbn`W&R37)vvPa`Y%A}+iN>H zy@#^Rt`SV%A<(tnIgrk;PtjkKqv~^!SD-z}Ew8Jo{u&@HZ(2VDcLY5K`a1=4>oVhr zgLsT9aI-!6^BDvgp{d~!8q#!#-JchYvDV)W<5Cl7?>Ua@KphDS#y%lS$Hj>yG>M>aTPQxa@Dez1(rs3l~0QLuuX;|AD7JJ+`?KQXY$}@k{A9e8akj3G!;@{s1=$v|MQMyPz4PKjh<~|U8?;!$ z=`-IWA}-Gdo7gflgl1RdgE;b&f-yL|N0!jr}DHGm31PNR5oy92pCcVXOKHjvGBoRGJ7SA6|9&h66!-YFEH z75{~IYP#bn*0jrXiq}u4=b${)SzwZzCN8h%<5Br^qj*`>LOy;oS25fP)p-0+vbj%AK_^8ISID&+tp)E#*R-p2yjphHnbz zC~`%ePdt%3Fv8tMCO}mHT3AhDwP1J+ZxK43hF#v!D?iC0Zm;qncw~wH?iuJ*7@67; zR&^7Aid5N+5^N{*mN{;NYOTc+wT3fHIp%FEZk5ndf1xilTrks8XFk=W8$;|tCe0U3 zCu~xzjHC^P>sUd0wH6C1m_t4<(w7=Ueox`unbU7B!@@93B4&@kp{U?Q>L)DtDi;7Oyx zO{D~}-8=C^5UR~LXJ0A=U^%mQZKi_1uP;#hIYcSOVzg@SGu&J~XKMY%0kMJ^BKbL& zT@TgMSg7()@tpz=zn^i^jOg);Gtp<`GcDK^U~x9Go--ZZl_0`L8utQH-74}tCnhkc z2JqN`AaQu=!oWKcWZRYuNo`d&KsWK{^)ySVv@-~^bc1|HZ6}`X8&Pxsnd47IDVq;} zzdl6h3;zk{&}*=?9a@ir-(<)jd&huoW4SQ=EIMRO2zBTLCDk3zL&mMqjHzWkg-{X} z^I3&?vfPpCnt+5@l^TQ;e5CWb%~b9wcGnFH954b!jNM6Ds%7$= z&T4paBN<~J(nQ6bO;UQZBNH;j&(ZP>7VmYXQIqBg$Xh>lmu;F5NmU3?Y(ttf0cvCr zPh~D_3=W0=)0DhDOdS1ZzUVJ(QRUr$cEFDP)37kaT~yUQH1hk1e7%|7H}f77RQ|5E z6+D3euHj}cTrKz*)k1O7HYwigtfAneG_OKeRGSxl5Z;IjZ96g;9Q`Vi*1RVStZpf^ zM>Xud1PtZ}dZKQ_jDWQ@q0!8;VQ7T=v?b{aQWL~LW z9BCw;VE2QqFV}L)LSvZ3AOBI~v-U~`4J8+z0&E7OzK>oej$?ejwp4;_))465B6rk` z?^l}$wPGk*st}{Jo0T1dnoKOzwtqkpg+2rdE)^{}o?KMi#A&sJyXN;p^0vGi+l-mo6}}(D21NW9<%Eg;~FLj{ozeJ&kim^8U1hd zb#_zfbT=nJ2hH0|`i>qCN5Of{!=47hTN)*0-q+sRI1fq=!$|fq_Jh#e%kj5O^`m zl;aP4wvT6ST>RUwfmo#W^x`SoxrsK?6v6h!;6Wq}1N8fFG$wK-*!i@N9H0No;E4WF zd}AvbkWWthNIssWfN|dPsY2At?o3z6G1CAen$>2FQQi4S&jl*LSt0$vWNaL2m!RUf z92WlJ?j6QHvko7K$GC}B$r4Q~?nQY3TES^lCJ3*=9BKl8_HBmpP6G2W=R@7$+bjp7 zo<+O8S1zG)p&(y>2Wg5ZOM#PV+5lsUn`4;rQC!Y%&?#YLL{I7d=p~|Vt?C!t1q_Z# z6o9+6?U2;S3I|l?y>ALtTkhm3@=InuvX;9B|oDB0}{s518xK{3sBPJOQ~rW z4<1b6RV^NhOv<3liJ#TaTV`UkUIA;@w#PP8g216HIf^AS_^o z#)tysTp4rh9569xKy6u-hv5wTp_PF-3g>GIDx?;wopWDfU;U3J5^TuIkal2fLWAAk zC%}`}2zmtA3@Wv~a5|MeFJuoLk34ssp7%$bgV(ru#>_h$0@#**1?6ie72Xmg3e-EC z=S+yL69N3PK z5nl_PIiR-CSHR^Yk|cEzs8*3aKJgJdUl~^dmI+^NMp_NL$i1+L2DLEor+6U(h)1hmWrvjf5# z1G}PR^96ew-xr~e4kM@FKfDs&CV+u|K`2IDn7R{SE|(<_UwKmG5Sp*I)ibD75sTKK zI@xwN2k1TvgdYtm!kwd3UowwjM|E1x7+P@G!z1UmtjaWYXMiM<0by0Eo$b1jz3l6_ zO$H;1eV+pxq7X{f7kKLU!&C+Ouek&*@cO<36V?G*(no{x`54@rTZ$>#TK9GFSNbN7 zQoVU^!LBY7fXUaHG-Z-jx1lfiNS1{8HOH9s!Kl4HMc%Kte147Pbl~#Lp9&WC!ss9# z5w~zR1{I4$EzJ`Wa-|512z+hwS3ur#c$|gHg)CqZ;QaGY7mx3%4(1MT{i{H6cT6wJ z&X;^`)G{9GSi~#4^uk^T&Vr6y`kW>P6!AB@g1MqX9y0|gVl7|C&gjc0#oWJ@-oH#b zJrq!jiIHhgwuo%mFx-?JG^&Lo zFd;G9c?f}>NpAKMru(O8n_(gL-!SjTrE}pgtkl@Ey@`#{Q!$iHQB_@#TmGGd=AI+S zkfYIl`#=eGf8fN|m~Zw_{h_JNi~v=v(B1lqu>NFdo9mK;Fv)2a9T8H~Y)~^Y@JF@(w`qVE@=D$i3m)6n&>05W{^d6{q<)uKwao%iKD4@~vc56~1ePgKZ(kP7 zz~bF7!%E+EilErVGWOfQVVnw=#-jZC zSmw?fwU`O6U*1s`!BI>E;5AkgR$$zNni>O`Q%}W0^8csS>SayNwF0;2$=LI-{qNqe z{+!TxERi`bjYK9x{2vLMiU2TXKfO;~WTqCwva==u)D;q*rx^)p3Qi%I8@8I|T?b#} z6Vka4((OmN(a9uD+*FHovjYSHO5W$+-8WJy536Dic!jS^NFGKrtid9T`ZV0%9eKKd-=LIL76hJ`U7L=Isd$e7}7g zsgGD>n`eiY$|er~X2{niaV>tF9yEM#dvU4DtFn*ZC}3J0XMu9KEPssUj^Fm$bbLB? z%SKO3A5WLoeFYlUeY=$xSyz+%NJ$P$pL*hbuz3{JzKi!=_}jM$**WC5^$UD`U){N~ zm~znD*0@6R5(~Ivw*T(O-FM2{KChe%BV(ns8=_>p$Ri@YpsQxx>6CJ`Ss_F9hPBG# z^5^@UX{PO9+a8Hj&MH)Pw4@1wT)u^Ya&ibQGe=7M;id9swPK5_^&{v@MW`Cq+$zVyoB=;q!rlX4NqBh;Q8!z>BuauZ z@z(`7@I-mb+t`Auk%4THRl)uJi5Ia|p1!uX`_-V071eWIMc$PF6VRAKQ|0Mz47;t_ zPd2q5Wo0)(_cRfV$LC&fvm;wVWy()oqpNHs6ei8Ske7jX-B|a!5-@YbTg6ykTU?cy zRx(!7vAxIO0oI-1Nm$+IRdaH(iRZ(KQdP3?Zebwig7m3TDkMTH%e1X4?}HOzr_n=% z3eQ44EtnFS1xr3=y0rMVH6&K6^p?N zXyA<5`?I8>b1eFsDTOMq&}I@o5GQG)miHM-#|5EEmtmkkTG7GeRXHn#2FDUFkc6z+ zN{T*WCx&c^?CRmQ4N)I*(g;m7q!3sjsH0V zD4YLPBK69lGE6h264bwu57>&pRKq*dc+LnOxm7#u>O2 z8p0HV_$~3SUKdxk4c?V59WcRSOELl>629RqEdeI{p5y4`L}*$?lk^!r)T>|64jbTO z7%aZmS{jy;c%*H^(sCI?LQK`c{!VLN`v$LBp&s(r+FZhy!Yd<`4e}PaT9mkU2!k1s zTzHsx3&H`zJxC~)>LaUhZja#WWC6>MCTK^ux?|w|K`<22^cCzyK~fT>NFo(dR?I;r z!%ni=8Q|;iKu}Wb9BnCzCZJbTVn0>xXSEs)y+>iJLcIj%t= z@@Y}XTX-08?;t+v4$AL%G>*1*1d>6uwJ?diC^4AfetfY1Ee3}@jAHI%BLrpQiMf`{ z;WpUKAY)E{uN=id^vfnss?q`B8}V?GDj@ElTi`|)h2$oX-Jzl5b*eObv|t+5aVZat z=4pGYOOJ!$lUN&|7YfMs=oQhgL zV1|7Q3(V&lcRU>t$K+j?Edc+K6EB#*hh0sj{KpZm3(;H2WO#k+nS~13jsk{PHFuY&QXQqcUdQIQIvNfk_f+6jvvYc~6b7pSI!$=V^8m;CWE>@{N9;QsjjB9q z5gS9-&ns+|O7pvmg(N4CNHAJx6@{^M&no!(aB2n0Z@^zv>*&=bXSU#_j%WF)SDgkS zE`zXcGcX)(SRyFq5t5xH(VcykO35^^FZ3j?R8yBvg9Qzv%(C2}0bI=UJkBynftxf4)pOhky{`)5C|hIk)uFQ0V^NkGckct!)-A#~dt!MRtbe zFP%nimRLv>>HDCF9KN$Wa+Nliv2JJIcEqdx=QK-R=tEJHddkBAyca} z`Y`eVpcY)I?h|9^FAdU~td3y?u|RrUkaeQECD3(C>-V|(ZND!5^J2-5+skGG(bnq>ezGR$*W ziwa$RZvx+ar|EmVZLN1a`hGoErvk-z;e;?WxL4OF$w}}OdelvMdwR&uhUMPq8t$;Z z5i{JZgg5JKXo!dxbr#Y15z@HMs%9b5)RK|~4Q*orvLO(-^i}QDBrpJ%h)cgYV=k@-QGtz2>LXmR{!_i=U_UG&J%rJQt_@8jT z2|V{Q>nu;OnDa-zc(3R0rQp{ZG1R{bsFB|?D&Pv)g4CemrDF_6hHXT%mRUM=L$_x1bhmO%KO3u!v5a)YCF(w;_ z{9_UG!8e8X$-^4CaoWuJCVq|Xigjp=Fzn1{I0kWYTwevGe(b)`n)QHKOfAGvo`T8h~Z(3tCjZcD0 z`#A8o((C6JijWih@nudV*yH#2yWR~-8|VN*Xc|XqnH;M)E0Iv{?JA3l;~tkJAY7!9 z011E_u!Y8D$Vm=`3&+tt5zKN@jzig9*CmpKqMu4tTr0#Who3yFlZvGZTxU9Bx{H6o zyr3;CkDDn=&$3vJ$OO32j^Srs62Pb2-whiKvnmXyhQfg9FlZk{Id8mY#_da}I1Kvn zj`n=N*0egwp1?}NyVPIsfRZX|af?Xx*xmDfN=9Ra?=i++z(Ev-_bL%zNeM2QI!0n= zfR5TMm_uRk>&#-jLLJ3Authwy{SVH%Dl_8#ly~P)i-cRF+Iu=3UXe4!L+H3=-#Hec z#6MNy+L*8anr1z817?UbT4fQ+Ot#&o9`m$d4{}%9gOtnQ3J2QFb&s#3z$==lj~X-5 z_Z@-rD>ad9*1wGOLSR&E_kWK=1G+mtj*O!GC8ei3s9-QcI$sEWAy1TUF8+tnvUC5B zIF^}-`TuIPvDh0)M{N(j{URHbGyr30lpc;$$a>mcF7-&-hmywzw^Ak)a$?a$miXM< zenrE5V#jOW#DM>9+0MHM9h^5qvg7SVKGyDW?KYRfAbQ?F<@rj!$O(=IQxv{yg5dyYHPn-E_h{K}9T`{^m@3 zbw{h(2X$LGh(KX#l!#Dtmx4N~|PX=JsANNKjDkV{%E%fdkX)xm)Z z&FDZOlR{k^$9qQFhRC?naTqey74pz%Fq27zLL25*>6UgY>HfgW(LAVG+&ce+1!{vc zoz{p?gDrm1q-h@16soV45Wq2X!<>N?S zoGz&3h!25aRO@CTl`fkr2Ub#2ro1zK4xz?m4No%!tBOm3Z?n0YCQ%iok}M`Y2u1kz z5DUzqZNlx(x(*VXj={L|bO+~9FnE)x1U52*4{HE?>!&M{oD=q4ScK;tBi;Mwz9TC4 z&@6+DS{-cPRDXBVPA872IHH8r+ez=AN2Lq17>qp-P-%jNNzje9ih|KlI-m;_5mF3h zY&4()G7%GP-~jX~@27#=x06;2wCMua?q6e~LSVdJMDi4z`y5cxkK#Dp=M`Ac?o*ZB zh9=X}sn9g#U{i%03@qoc=nOq6n6am(oI?;2rniQ$9;OQ1SId_1!YTs~_~kvdYo6S_ zy(g4ROj~D2Na{5Cn1Ownv9dvyHxOe|N!NLM?#%z@AJK_Mt~UdSW@E z8#lU?V@J})dLF0JjFOwfzf@i**L2x{Y%r=dC`L0M7r)5^BQ&8YkoO*W6$hy`IDB3e zQs7L+k`08ew|bsr4%Ybv3G}f5Nh<&u>M!2q^~!AYLP#<5pZqy*CEFCR?p$A&?&h00 zzTeL%L30|;VnKr1>U{-lEI{z}k5A9gbK3A7E@ zqWiE`C59SUKCs0m$r2*SbOMT@CS=?GNVgHPRMGuuy!Y39e^tz!l|U6jn9rhtpq+-g z#W1FqY-lgaFTTXN><58rA{}k~9V2Z3zO;~RmBaFmC+HlU#4!UD%qW45Y~n`Al*QUd zQ}SRE38^9h`!a7QtqB3q02$N_m~15(}*8D~l3$q!}6Ga*_V|JWwzGV!61H7&b! zq;dn(_I;65NTm_rXxDl-uhe`?5_sq4Fps&u-`DOO_GzQz3N?Q8eeu2IDkQ!4A*&|rxvHknC6bg%5430ml~sHSLpEC=)o@-)3tc)VMZB3t-^wD9 z54}%Vpv6i^k98!7c!$M_wf%te6FB*66r4)O*CL-A)NQ8VW2rIKg{bN24++(UeA(E)F-`TZU>lJNn)!()PbY0*l6u zOo1wzsBwr3wij{qHV{fDQpl^J?eSgDpohiNK{80Y5Xtj2ZhwRm8h+7V+s*6VMG+TK zs^gPk!*o}JZ?}`>lk`yn&$87?2`b-LBY)K%a|z)T(;2DR`3%z@I`ZxTL6lb=tb>_) zZG*|wa}Z`LcC$rM>k%cR2=IEY1O>+jvx!a=_UJyw=mRPc_;PjpjZaswVCWrByzVBc zzQV|PCV$=!r)|fX8yPj(i9P)aFE&tjv?4@-`OL!r8@`|ZrU?g!-22GUVl+sNnf|{& z^Lz<--+KwSIp$SVc2(@9%e43;wl&&XeimreB8*IS2w%@`&qwY3Oy{*meduX<3eP#A zF3uC*AG25Yi-FBB!<=$Ek6Cl>P~~~YIjY=_lNa5B3}Pdwp3lR^l?qXkO1#gjD`>Qi zam)y$xN(Bc?T?TMf1o~&xNx~^KPdgv0{w^rr>KwaXhK;Wfm;e}!`hbD6wne~+JFIoLJG0e@CuI9 zD-RmABc+^M!iRNC zfk10CpD9+;-XNoYMoFe7BL1K*bej`<$TEn05pI?V%g*}juLFD0K6otH|jm-SF< zB~@R2x(UDKI>mf7tD&B%o3#X45_3K3FyWawa3!u^Cmlx>}ht_C3@=E;c&xsOdX1WA0VQ zD9hI91;BrflK1FKlJp1Nr-_2;R}>~7yr4iFVZ&7rmt=1%U_VkV5TfDBzwy#Xk?>mN z1U4IXI8ER8n}onOUNt9dI&&f*Y!QSO`jRH$?SlR5CiB-rCWF4Wkvgq1+Gdnt55@ryPj^@cPVAoApHFxP>Y^rH z*8A8YZ!twFM%RmD5`$KT?bXD%AzzRqjh=RxR?9oun2(lr)eTShIsnj<`EAzs@6Cs- z*+TO~`ifm!#Z?A(Qx471)kVFm4qd-j;2V39nH^uc#E!9S@PatR|~5hM4T# zD*IP!tY4HM2Z>zen)=eR8}lY4f1h@W0?j4c2HEaq<&YiQYRilX_R*0RUZ%Ez5d z`S|DYCskzv!6GnwtmzEGH;H&fOcYTo@PFKX;zl}KdmJn1fC7dtc{|;-=BG1zG-Lp+ z^QRLbTS>;QAvuwaBz>WcpYdmnsdF=?n^PH$8F%e>4HwGSy@gn}2+muC!8)S#vODS` z$98}?6Wua#kmc$e!+^f5l>&rAqwo)#Kw;9u2H5efy%Vr?=QrhJ2_(4O(j!D*8Qp=Rz4hYDasVu!iy z$xP{kTpE*onb{$+8-~nby2F<w%zVbZ(RYK`AYvv9!9c;oeh5jt|mZjH#ChziZ;QB@}SxjnA<)5ppU?h5Q`|Y6H^crjSop&=8bS0pqpIw`bNs3 z)a@Y@HQV&o{=2Yvz~j?uQ4`j3i{dB8_oMFf`WWW6%QtFWi>J?Y=j64yJm|V@4dvcA z_f2je>sM=st+^uPqhgl?WnjrsETq1_at#c-OPN-K_f?!4%FJtq(Ry`s~d z@%-k8QgWCivI9i1hpv&nzGLIoz3~Tng_Y_0wCYhCb7~&Ng_<^KGQo-nQYZWVfa^v(cpU&)&CnAf@WehDn6TUtDL3uCo#w zRS`x9s279oZnP+QKOvUs9N-ugr?uH6kDY+s3lUyd*N1nC#VqW@ej#qW+?*`mW*fE1 zMiZwv;Z2lS>4tyD>T90us*BBqfN?YY%zQND9x6X_L*#NRg%~OS*>8p{) z?YWgeZ_#5QT-imtCU(0pDZ={`ndY~LQy-xyId&b|ooC#Og*rkMWq`_IyXikPYzxaH zdc3TYExwz6#n1sDPi=pvO+bMtn1MAF*Y1_;-*v^e z{qP0oG-cc(86)=k`sDjf8K)@FaNbRWYn~P zEJ;c394>Y7i=h!-qv7r5D;-8>PW+x*hgOMp{j8@-TDS~U z5oJjbA!|k!r5(XS&8HGYKOSvI&xT1VVJVwtMJrh0j@|GhgPc-AdWvYHjmN1G|!$O0BlpuN~g~@2+ zAxepE4iR@LmBQ3kOdbw#LK+k)MbdW9!ufG_+%qgLatWRIzkSu7)=3JvjrX@ft-tM6DcRliMhL!LPPhCB&* z=m{J2(FRotbx>qDBAV$4R;Q@Trs|APR6B4`52wtPh#lA{TRT0hn~RDIa-5+0I2=0m zN1-204`ATXy8ST?^V(X1lXHLYxVLNOLP(;Mg!fq*LvQn2g4li(J=5KWn6`yTl~d_l zmaXKn7?g6Y!tVz~9c>yGLG}d6oezjSpDd*z@$E7JjgHC!f{IYv(SjPGnyMj{n4;{g z#qIo|fhggjq!WWOlw;>8oYr_RiiyBXqlL6*A5UOg2#cC=_-tOrRnXejWtf6QXVV+f zaG%9i8`?)IOJt)vJh9wY2yf(ryKG>5XQ$9Cr7h<*LIifz+p+__oWuAre&Ti3@X@}G ztx%|?mEz^2mg4Pcp?S~NzZ#U_s~-wpiJr84ko;LQocHhBlzd7F#q`B+{{=d2_Q(Iv zZI*%cf4J0Rr2m&%^}m#<6sya{UA4gW-j>q8Aj#DgCeW-mpq~*^CKm8Cp8;`naf9sC zn~AE&@yz-)+@gNp6$?)od2MaWcr^$oBn$tDC!F*%?Dgy2u>1IVcWi#sc*NJ!L?rH= zBb-r)HzeOPL*+#7DY?^|s93i+poGQ6`3>}Um%lE{CvP8qn`Vm72+6H^`+jKUfk>sm zvv1ug6*rBPCDwPr;Z;0jqZ{ z9O571W0lk2iM6T%u_H7h)zg|qm&p$INQ~%rEZEL#tU7R#{T8`Za#c&1t;U9v9N&&?nHg-!0p zji8BP1RZ%=wR$HO1%13n3eAz_-SLZRFFdhpXsF7e{KOisZx* zw69a;5Bey%l?3sJXdtnI7oD(gvz#JaEVH#qjsiK6rw2x1 zXy)P$B6B&hs_YOUGOKUeE{2P+!j+5+mnl(wIsIg*QMV{SBHx>5p7tvbw@}cT=u}~d zLzfUW)6WHM0}Om!_H;e9Y4}ZSQ?zLGEBLmu(QVE!vmjl-7KQFxkF(0OiD-{&aWWdy zPf)T(q3B~4ySyQ5-UolwvdU1T1KcOO6@uaLXSigpnE}L*f*3=)ADbe&+2W*0EwEYy z=3W4SuWrdf-y};Q@wQIebFT|MwE>M!%3>vMvbC|)!~cs16Inli*)q~Jw$^lFcG2CR z3Mp%@O5K+qbl^k+aJW=NY@sL09?6B|0~kb_wWs2Gq#M-%cpcOn+tF96fB=!v!S-4p zMw)|>)DOm%yE(J;GODke^>VC*(33m4D52Oo6*{E>my*%(dE87E&$y(ts10GeV$ekT zi{*2yh>YI1Ij;enhdr`7Rx%y%rH^0xkOH=I(`N)HeyNre8P0@8YD9lTy-!54c>Y&T zR~y3Ht2wuX)*RmRzK=U(dM$bmvsC)d+_$nL zDjsCYNYYmyE>>Nv-A9XBg|kfU5KYk)!O}?4`g85CgE1uv;E!sHxu#Qy1%@bPqw{UK z&4J~5^zZTZPBb>CmPyVegS~j-AbhRuV|WdZVJ_#{DD7Qr%H4pCRe)`5c%cOAv-u0H zq#{((+9g55S$VP!(n!yudpy~zil;0v3VS@v*QmR(zd%<)T&9vFtYKCmswx;C^vyFj zs+SBsRYL`@)b%2IbtSC8BAkyv@K&7vZ14$2D}Smemk`Q0edP?AxDSp9)fK2f%rq?spB^(e+6vBp$urvoEAbHQn^B}t{;RqAFM=EVmRAAjQM3Z;Fa zsB4j)6MYJZ%;99_4-!rCSX^kb0YE}?iEXn1hkC3FVx8##1=uFw-PVVTn4+&jT`t+m zW^i}4@z*t2HHPVYqI2XYS?Eo@1838fP+5EmZDy$@ZC5cZ83BFABH^+2EvW}qzxpit zZWd8}sedHgmga7vef!x$*3y1^qCd^QoWKVYgl#9a);93BgC&o$`NT$_C8QH9%9IcU zmpe5dUq|c_LJWd}&;k)xfM=2EEhLd-t?e+I+_62XxpOv}p zpzr+ozWE(GVu_l)>qcR9BE-{>uv;TG}dtRx)jUZAW zx3H~7qC7hqJq5avAjNhaV1J>dEgEdyNM<(R#)NnAY?TuDoTd^E=`UtzvuzbeDp?A@ zz_)c1Pap2>g>^C6X)`MCc(5Z1Y>XQYVOhQbZ*c|vs1}a4Mw8{^+4gBiraua(>um+q zXFBFw%f03GIS~MKc26KETG(55$OcZZ^sn_fsNBnS`|aC3B7!v(hv&@SP!K?X3WrFb zc?g=5cQwv{rr}q#^^<8(7RRSwLo&C7P1MkxsB4!P8AXytl6fjlkP`2SFO%L`Pxk1n z&q|qGqq5ljCRyx-<^Mr66nwZF9u@_w-*>O*;)O#X0`MDlfxvDj0QP+y10ZRb>t+^r zCKw-a<#`+igt-W{eeOJ;auQMIRz83SeIB3FB<_>&%>5#a6UVi-F)8w%8EmvYm>Qw` zq-%FVla0?X$_cITnMq=DMG%24U*Cbo08K-h%sxBc@oEH~!9 zG+q6eEJ(&&aWO_|yXB?LE|yp}SI%Bf9sia}uel*T+ zA8g?V+ewS^7?Fz`{AGtpZ4xaLm-mYx3MX!hXEluOx$t=AT5s2ButJREaL!F>+u0T4 zwVvuVm+$){9o+Y=?}4KG@=RI9qGOZ1FY-@%N@o&k|2w*zp$f`}OnY@JZPUczfXt6u zmC`2ACmGwkd(S$#h%r2Df>_B0UxtHa$LMPp`qjZb#^8MU=9PWYd6^$4TlMhD{l}eh zrQ+1rce8L1H_Q%DQO>HE?2)!`937(C|l)U_o~v59z5FcEfj|*M@xN0#BA~0 zPm*e7jU%h(*wUW^TVHr|I%1AnMoq%rtSWk^63B0M*4OIM)M^V;tml7ml2-vB01q2m zM13vkw;!Lwfzh9E*F#0~*FxqF0a1^w=+G`O>-O6rO=ilv9=F%#3b#5;>;5N-DI?3+ z89_-dpe@P6bkoiUJLPuQ5F{~F5=dQ>1jxCT+FujdB2Vmrz-g|QGd5#$E+%_2B)b;p z9{Cl=o&zKK_+VU-oSnp%kg_?RKMfz2$){r|^0b%<0cL2Wp0sK!@sJh};Y6@=XNbAU zfRN7agArj0!rU+wONd#eh2`g>{TcktDD%OqB;APK$@3ANVI4*++f2NUV){TM`j!8buK@wWA>zb-l5r%7MEj6e+9*SiRG}&g;{gKQa__tYsq(;nHzzF@P z0P|eno;O)mu)|kM!^J-j@1=bEn`0BpCJj{fm;|0-eUbN$siSPt4HDCjV>fic0D+Le zamXzP=!C(iGgS-zwSO?Gz&R=#!MS2tEKtvkyTrqw?SoLjiC@!7ctZ7^u5!g8J-wRm zd6MQ^m5>49obiRL+0}~EzZ<`eurBS)Zt!QqCVX1h99j6<$AV2&B5*@AGpo zw*6Uq0&6`FRIa_5VXLim#9X*uxNn6izP*XhV2lX?=;#5N!3~Tuag?=iIHqxv zdB2+==|z15ePaz7#NulfL6*g_Lt#L#t&Zj`DsnQ&=IVT-`19M-suZBBxpYg_7{adt z=c5j-TKs%#dDqtl@KB*%u6F}Hh1D8GHbdXcX$2$^y16x5q?8T01CoP4TDhCp0AA(a zc2Dtp+%~}ye;Fe3l+L&KgNsCPofDAUFi6uo5RIvG7}J1Y`elbs8g#$_d4bT~Rlh$L z0+0fl3ZiKq8QWI-AY*P5w(9HuW2L?Y6y(UwBrX7Cdtm2I0G=eU0YqCcQnLo`Y;?*Q1l{}??L2})<|WL zN`K)+g^7{X41 z<0W;EjBLlQgI7Tbj5i0m%rK;bQMLjf;noUX{T*uogyka&yzi6Mr`jtwt*v5UmW2(~ zcJw!s=o-hVJ3NDVVrN`)(!zhM6Fks4U_iky0dX33@fKg%7i|rM0FQ~6xG>z29I(85 zD$c)5MwK$f#Vy*qTu-#;&rxb`w-cR1BK`;wQ*e4S@h}KB8a@t$bqfn!#B66nD#Z`VIQF( za|E=mQuBJv{`8$y?7r_%A3R#<@-GR<0Jop>VvRdnE8wZ4IBY1DF1LohxnMFuoW#5HC0i++Y_O;<1jzB@m`v~xmlN)y`$QM101jjTvjVx`W6IVcejJI?Du3&`o^C|)ZsI24}i(u zX>8;3#RHB?N*jp0$FcKzT=#OR`)#rw?=T=1jv^QhE3I&oY>(OAgM1KUVkVQf zJ}@qAWjgaiEXo5?jT7jGHAcnv+NQs-Z(Na)%@wolps zQ2skQ+iEMoj0e;zw?m#Y6IuI@6G);qunbd_UlTY31aVdY`Kx6|lz_Nnu5piU1CSyX zY#f1-2@CMeZJMcnu)8%Lp=gk_6U^~tJLCG)D7kO|lp}aJ?MorgD)1-*WIMr-CyprC zedilt1qUK5HFV+Tun7TttuaAc6tvzPFkE&QVMe#TgwJ>fkucw!v=Bg8bf9V{$hMB6YDVIL@-e( zqqPFQsN2%CU3T&ubtZw_Nx(r6_QQI0b3+3FE-Gl`V-Qs)N0`<0H;&=+9PyE~)@`#q zB7hi=R0&y+Stg~J4JeJToX3G2Z92il+)wI4YUzgdfdIi+>WsU}km^qBGw+sbC8d89EX@D-Q@=(fsXVbHEYZe})Vn zSX&bZn=I?OYKzvQhdDgEP{$8t6Gv|Rz<5RaD66Tc`KV0WyL3XS-OdPl^t5w&Jtsw|wND@?Rn^$4mTMGq zD(B0nsbwzX3%IPc@d@GLRuppmUS8nW`c8;;9|{*Mz$hu~PChm>khM`yI3I2Bkg+Re90Yb>`+w^dui4%S#|cuYjYG>6;q71^Q|E9hsv(O-{iY;)6@*Li%>uZrHA|MjebFAW#!@MQQju1WkZxyJ zvCNkHTW(@~DWd2}5mm#q(mh&}if!LKwkAk6Jx@2@I}h60syOvV+u?SgGu>odC@MR% z54Xb>ZSY%BXRMU|7E`|5oXNwnLQ8It&DCnae3jC;nzRyEE7e-n!+5_MIp|#dsmlgm zZBimoeX!Pf#C*LpZVtrH%rK?v>^6$3$OO-Mud$K`v;g2Voq#P5XV1m~OTYKkN@*K# z{fn6!_R-dKYZIX4&6`$TY+C2|#neFg;kOm|gJbEq+kp#j7C&4> z4wcA}z8{S-@{Daz#M!4AWI<{CD?JD{pyJedFygn9UHzjzDuJP$Itq7nvd7|a?Q*syaO<#IWvxegW3R=GjkdS>6}H0v6o zG#M3|+imz>TL+>OP>d!g`xoTagb@j2P5tnu4`GP^JA*{T-IKD0rx)2^L16dVJbq>k zVWB=~&ZCYp*4}Y!A|IMlrwHxKtphP{S8cTV$#@{2w`%+6=ByfB+(l_S5fzn-EZWp# zS!(b3oih-4Kyo=fniCUf@vWI-?+I+Nvbp+L+@uO{^j+KebWCLILR zTEotzH$YleW-*wG%`=?plA`tS5Qns*wJMn=%Az}}pAUJOD1ar3_SUA(2cWbI0SZ<< zb9}+3d2YWlh#-!s(v< z&1}#qf-=h%fLo|aG5%mEwWiauRU?SFxX!B~9|Xv42N-QnqOx?UcZ46`C=Wa%qF43z za&4%|$opq;n@+z)d3YrjX5eUljX*kMS{ruZEdH=Ef|4Lx22d}dA^s^G_l!ny-@gg3 z9=I|QkS!l~FM4O9PRCV-7%mo)_7Z=lNmHGLZNl^(8toc3c@IR^`?|Vf*AMQ@luj1q zpd2WT%cVdG-yAVMQVHR0Z)30(sQ|8qDIL|yevSCVi=M+u7h@yWb@JFgA7x-^v( ziTikhY;Ii|1=2$Zs9c3+p5##N7SLXp6YizWx0Q=%PE>N>K@xNuK?J14$f1AET)}aP zQ=EEVKb*vIZLORys*D*LIfC?1Y9%M>`;mPgvYt&g+*d>WOds>gLucF7Wz~`I>6#pe z6p)LKkI4upqSOe}m9`L@C)md((2egm{N|m@Hwb4RS=D0?P0ZW;t$Qy|V#*k)RCuly zuVimz3~%!mq`z1R)kU~ja`phU29f~Map zeoo?}-alewZHHvhXt=1npTH#1sn730K{PsqGv2b!&K`wXAJGJ`PEdQ)sGD8du{p9Eh3a*vhH z_AFZHjsV0~F~!7@znT#Np1E%K(^lE2?yAp$ExmywuG>&byg`8|3;8n5(}u>H(Dk>yJ`p>?vM;5Bw4sS17f?ig*#H3*s2PZ~`VfSzKljwG z{Hi82jsz0w2ve9^-jb#Otag&W^WB=K7P#LM@#1pg=+}DwBNIdE(Hn_9h}>)O+Tx3J zG@9gJ9B869^n!jx5ts#lY#&r^k8XOsf`zKu{_Q1}!H8a;S-Ck-HuEs`!zaTtnk%&{gnA?hc>aB?1X)Mb0|N(Q)Yb zAlYciP%I*-<0e%=&9g-$PJ~w#2?dINDtU>h;wvOsHF4sUwVe?OaVcMV$!CClGg9@9 zNux!xi6S8Z4}lT=qCrd{@H&DJ?Pnr)Cr+V~1!nw-Zj9XE@&cWQFICvHi)kdW{JQFK1EnJ zL4DQOzp7LmbE4q8@+@$ibzhPmpxbE=tJ=j5A5Z5K%Be7`C{kc4mDaqY>zkF0a*Axr z2;xX7{eyw24dyC0vp;Xt+BSQ*Afga&>lZnmH){GBXt)=)&-+)q-kD4q6QOfp^%|Mw zI3)!vejcBlx=kha6l!%P&2cvb32`XO_@4LDyDc?U-|^)n=pz2URM@i11t|YaT~gP- zLNE-v_vSuCV2|SMQ(bTLV)>?vT-!#*OVBtbHIE7PbKb*>cg%ePZ*MLOfoVb27ZPC8 zADr$b=%~np_3%mPp=T&X39k(WASE}hx>P#EQYttbmc4aWxNQ4h!^72A8FLaSimWf5 z9F#5gAEpxbnhgifV$3oyGrRr_-{m$>dW?^?f&ds>z59G}vv#^GmlA(qYFkiFW&75` z9CXs@6e$)5qX1+h&ntrWT_*k3rIi*Bt>o;Aez$8VvY!G9rP^{h$1VqmXR8ZUj;~?2 zdqf=Bh;_`=BE_GcQ;&nSi6T*_cA8MPg^t}lfNYB>sdO`e0wV(9ZS_)~V;N|lHk7Xu zY~gJ?E4CS@_1f-+f{Qf;`tNeJ)$k%Nfd*hy_9Y-21L}M5#Z!c`d)G81l||Ed$RN)f zN{`8mQ3!aBpne_7ld-C*)rg-7aM!b(aYEFp0QuqWxGZ~b-dI*?^7}OyT5d9bh$Pxirk zaxO57ylt6dGY8Ji*^fQ>q%WGIcuy=RG4+hsMf8IjL6YUCgGa8TPK>DSAUzE#QA_H0 zmSzGred_O>7_)o+~B+x!wsOk-N$Izb#&rp@7cv$d;VQ?q-(Ies|_nZ(wcMDLQ1|pAw;#CXkTJy>!&RZJKOuqA26megvQ9 z?l=8AZ`#-!)@~u5FY??j5MDaD^Urm!E5lR0AXl>*+3uY%eGkUX+7krXB44@?3?Zg5 zoeBsnW_t5D3`P7i@f3vJ@zEU+yVgSTJQbGmGxq^DDZkJ$5OGtL z>MrLvw>D=0%4|pNGFPR_v$~b%AJh?+Y#7yNE=Pcl#TLT7=_eTs|v~Q%ja3(-3 zcUKInp+x7AE*AGY3c<)p7K7fIDhlgjim!fLE*gkZ2l#A!YACb!q0CK^W1$=p1gu~J z&~;_9Lsn5OMfJpwS&>RuSRn`-?5c2k&`{7D;8e)Jv)~w-#1R{ldjc7GzO4Q3n z_XitAG`b;Gf}Y<`Bq7A3{_hcin^^;$;Ut~=)#!11cK@*w$*OngDr?`vON}k!S8q@P zuRUr2+ZFEjB~J%K!QR$|7#mh82(GB|K)h)hNW4FXU#(JF_m<>(#O{?pOYNz|DCzL` z8&J_WKEf8@`1B6pVDbLVh4A{t{%)RZ*%j_>qxkhs41-+Dtf*pXG9O*toS*p7-CpSb1Np|z{-5L6)BZR(wMPg_7 z*UXxc-$NBZkhEC$=^M7jgexwoAKW63LKZ_Wj+c5p`Kk{fl5nFrX1m$cZ&rdKgs_MT zc=>Az#3+haA>Xpz1}CcCo4cNEGH(|k(7I=rf(U#N@Ubp)I2rkuU8Pw6I5sQrFdicxF?m3@`n0J zj-f5`u3ya>A-#VmZfc_B(=PzAi9$(nN^M{tbzy8_Z4MsK;@t8tvU6>IZ4NBY+RobI;_6kQT=;ORy7M6b*o&^C1j4S-ZBuRN);9C9x%5zsNTrNl2q6kZBWzP=9R zXENW~?&Qk!%oys8eoY-Ka|4hswQVi^FDD?cD>#MJ1i%rl^z{!a&0{TqW}jXduzrEr zhg`=$9G5V*a5Fm`Ix_Oo0vGCvm+E=~z$AsOs2;J9CQWT6*e-VsL0UKwx=hVSZRy@u>DMJo42ptCNx$ z05&l(F*p}_-x8w!g{^h}-6$9p9$bkZXZjDl-_qXUvHmRp{U^oX(&)m}(;<8n`rOFZ(E5AFJMEneQ26@MAPZ?@FTPoa|xV6q=u$3KTl;r%FG z$?vJ_uhaOiUfOTM@$bgjZ>9Lu@W_cA-*GR{51+4)mK1heFA*>2>hQY}l<_s6Y5$F% z(6Y=gONZbKE7|X5k~8bqUr+%qr_5iRLQ?suh3zHb{)P3m1HJ19y3PyyAX6g?vkHCq zrmsT_z&Qp6#-F%bqmJlmz8v^HF}a^}#&3+A-yOxJnYEpxI7*|RHUlAYav}J&IH?~3 zR)6%xQTB|#9lz_t0AQY6UZ-)S{&5H10H!apb$(kET;To!Z}5w`L;W!N@o(@Bj6fJD zKV+%^K@+<}VEXdknY;~UzhP~>V|R83K=c^DVLxRF{YUs?Ao}#*;Jy&_pV+?ylYZ_R z05B)Neefb^zXB`&Mm#t)e7cogMEn-NnqLIdZ}=k+`n4}$zTl0Y7<{IoyEtWhrAhr? z_^2(`i9UMK~3;u9)|MO$|UBK zmn$xK)O7gRe+Y(15mw2*x0yVbrMD z!*%t*a z2skic>15uLTBp%Twk(=iJ@9zYE}R0jPL!K*2ANwb>)lE?vAaEyZ!F!3C^|6L_n9eF zhw5%>NiW1l=Vqf){u{8(Zp^N^2C~;$cF2UHD>yo?s4k^TDw3e(Ev12Dz%W=D@O=-x zV98F>1GOd_Q0(k|{==waZoIv2J8~||YB{3h2oO0d{5+>Ca721w3aL^=O!|@jmg*Z< zTLdz3kCjKp%;yQwIZLP9S=N1MRM(zf5KCqQdHXi!%Ejcfu7}6Rkc>SOKFLp(9$=kV zGcj&7BTI4m5l$5YP>2Q9)dardbRKncUe#AE*cFv!bGsgxNtGbU~8Q2$JxJX7>RdU-k0)R@_ueJB+IjtoX;$i6wT9QIYwBX-?JYUyHzuT}I6UwTCdDw2OA$qOmU} zr|4tFuoToEu>BlfM@(1#b35M>c2s1G6C`pKD>`o!`(`+N2itt~;nx?M+l7fn>C^GV z%8;})GQ&OZ0m64so*->1!nTR|_OaiPB5rCvWsn&DCAjisLqU+JHn4wyzD_WBs>`azBeq>0c`hw)yzqCtzgGRyY=e1O1+K+;vo1lneyMe0Bg`=>CV~Nw3e>e1| z;`5wilkza+^x1upu&89t^W}a068aki32}*ATsDnu$!%J(oi+#`W8HHV1imSOQ~u_0 zU8~e6Sl|5&aq`pU9EGkZ*Y}=O-}TWrTlVbix!M?S)2b$cg1@TN6s%1}l5Yg(GOvUN zhkkcu<*nje(T`l-qlJ7pJRX=q&A{MbRW}^)5;-Y&?KpuBpCWZi;@}2x>I{eX0o)i3 zZO5$Wx?nz{us(?{G#lLz)1+DJ3nr3?B>B~8DGZa+hWj+XCS$d z@N$lDqORv-&9Cpt-U^r9Qi6E7<*SMvRNj`8W&G%zt9uV(gFP{2FnF*f(vfoBQ&lBj zA|W7-le>gZI?P|&dv03Mh4ElCTOzTi`x9aR1$*Sr7hgTSyFPQm5OL3-5y2G$mZX+! zXk1xg3XVk%$Ys+?w03~TmiT77n6WJS6Zp8Sw39J5PLgmo=DFdTZpB2MG1T@rKZCDh zl;>u)PMl716W#raRCaGps{Sq^`g~@hxV4U(CefL?n0M~C zGx$q)9hnLdh|&}-@tN5)8@-km4w43^4Osrq!hFsz-d8q-eD?m9Yu0JeRkNr#8r2}w zlK`vt5@`J5KGCuTA%bvGh}PRWW1$Zk->*aI8@e4-k*G=n-!H1Kf@@yheO;4P>MQXL z@e0Fr(Kv6T_q?7VdlL_S+&(&+I?lwD&A6_I$k&^HosvxJsA^%#2?X+Y#1E4N!p(jn zv+IwCCg&N|xU1|+8^}6i-vTpCqUEfP+!*G=vw*?8Z^UNQaO~!(fa|bvI8Ap&oN-ZP77v(DOIUB8`Yx8`~n{5oGQLG0B}! zKv!;jA%-o!?+e3b89Gx1f9YjjznKb0r&eYaudd7&v?$G80EnMfL@DsXW}FZz9_d;t zTyRp$gn0|jddA_hj#(k9kcxIh>}-l}xtjIXdL%{jK~qgQS#}3HiM5n9+!1ayDq|?& z)f|Gw2YAZVVX!MmwhHXla$~%^;iF5c0@c_6D2KwCwuweOm#4 ztz%a)V@GZ8_hbJpB0hBbBsdw?$0 zK0jA5(^3Y|QzzgVGu^S#;|=JV1+8o}9c+0+(2y`Yvx)KOv8Cb-6L-`cR4WoY z{$j?cYfu1&yISEch9pe#Eu{s!TV?%RS;ejR?7U!}Q+Dt|`i{qm>HZ}mWYL@e&nwD+ zT3PULzt@=)RCT&HM_5+keiKL-7gr4l*p6M}8O==8Euq6yxFPcnR#qqD9^>1u*B{AP_dWFCu&cDp@qvmrgHt(cvB7f-+ z@bf3Jc7Ph%=0A4C=d;dFd~$!h5i_ID37`JEa-Rgg3xZ4BT4*CP1*!EIH3d*V5w=0lo|7;EU!eE-zLOEE`Z9hD8opo z+J2-8H^)OSoxWq)FwuA}Er6Q)aN_-7R~`tRCjg83&GpqrA;}`473#X|w4z?;Q%bC# zl$xXOe7zP(WFY&o$kkyy8Gj1JK)O5ct|s(Zhg<(FCz9l%;*JAv$&(jM&6g_BP&#qH zP2J$$46-2lT5l~V@N=V>eAsCx<9!@C0ku%TlDY$jHkaa)>dI?_sbp3GAVC{Rz5ST_i@;A)NldNo&F?G~UA^CW2$P)?T zEu{Gu`$RiB|DCLr|0F?r7oa7c*Bh(UN;67N^A~pL5ZDEp;$)O=^ci<{4#=z;KwFzx zcY;vP+u?Lw7$<=C1$LU=bS!~AhpLn?8jl>kfybiY@Nekol;Y2f_dAxf4+}vCyYa2~ z*dl7j9PhAwIMVirZ-ovJT~L>Mfc5S|&}tRXuNQ6yvleX>Eyp!&;Sf zQV;}`qG$o;XPB@V`gJJBaKyct!ZM+u_f-G`Zo#xVK}P1;=d+N=^8|;NR{Mt{iZ*=) z5jo7jtf#KKqZ@W)t^06Y6kEy|dXFGlr}w5ItcMoK6lZlu)2FXfGmvaaGHE!gq1Y1e zeg+O5wL;}280f$A;KbJvZR(B@V%*FQ!N%O{U(v2Ocbo?AILt;I^}Ym)PSGv9#W5Ks z6Wgh(%rPl}Z88{9bfTUO<>ff}ld9o%n$cS90~7)nI7h(lBXJ23YVH)=8OSh*Jj$)S zgf+O)(!0{LxNctChFu1E4E`>Cs8Xu0N6hmWNu`&n@aC5SP z-oz!q72j>i(*l`mP-nZcjg8q79sXK+bbpMX;y3wsvm0CwGHa*9yMm=1y`37+NFJpA zqqWx`EC~KT(;IwfX#x)zDjLUc)6^ZV?Vl^x7$rBDIrJc1Sd*(AB13JOOKuo`!&Duhx!p!uPyYtj?9Pno#l3(khV>$B~Sp zMT^W`V-L#56OfOx+1;r-r*}<_F_;io(6S#0&IbtxU_Whcs`%m=0rv@+TT4>N`}f1z zIh{;`_dhck-oJtUfV7JJq3%~(3m=mj#!6!ID|F)eI+Bbg^t(G>#c7~pU24Kh)QdzX zwiqZ!7kuY3A7+(p2VD!d%yj5rjL>Y3bCPDJ z#I(luLUJu~vI@sIWFZZ<1AK%vObLN68?7nit*k}{;z$-4W>i~rpP?*Ffd7ZEbBYm$ ziNf>Rwr$(CcfYl5+qP}nwr$(CZT4@PHfhqNlbpGj+cQ^l=6T*n`FvPEzpXWD9DSb= z3EcGBczR9NVSs0BqVo-}Zn2A#%==O6DS4v#L-S3@sFjm*ayP55+X z;ob!D07r*$*`l&(MsnrZC6a*qJ>SaSb!Tbsqo^u;|TB?)?1;I_NE(9ccCuf?hw<4btS$% zDSpNNbumOt+;F!)kr7B$xep@!&gD&&b*|YSAB21mizHXsl zb*maDK}`@liG$E=tenl9p|SmXLVS1IEyu5pny4?xLse?n*#erq_Ka-6XS6med};cqx( z@r!{%=OFSH3i#L6qjM0p$N*l>cmx}fh`c}?Sh^XUQtz>l2P&Y|8AkVA$HSv%mReZB-?m?kATfMVVjl0V?`5H#xb~mT691XW!mAq4fR4>qM>Z_u z$+nc~W69!E_qdRFDxD6*`A_d)3+Bq1(;E8feZ?c*KT6go#hFBytBPku|yl=Y{<1 zsMF6{dHs5(u-A~n71|(=-b7{C#bFvOwIo}9g#!U&lskBZo?9=)9CBIYi-+52aF_G^ zD9|QQB`?09`f;L|d=I;&{U=v)G!oIgB||y#3^@P1W{VatI7EZK58DC?g^{1qL}V7N&piT-uj7f46iWk<4`wdBsRbS zi1h9uYGUzcB?X=DF1Z&`OV$qzp$)0C6;aI-z0=S6&(0XmXu$)OGUvl0ENJ-Lmob*Z z-G})O)6WOF&cZ_nE3MF2E6jz{hLKhV=+2l%*N;2O`PyVwA{Q7~_9`Z^6AE8)L}{|F zG-|079;?HP@9$7WA4@6;ZaX~BF{_ljnbVKf-mN{@%jR_AIJZ*a9%6#Bo>$P4XeE>s zJg9x#8yO1rgjFV0oy%%-TJe8AOWi<(^Y|QX=}C(3nnm zQwZqhK2fr9E}2KmF%d?&hqUfYxCeiWitOFtd5{z;i!%-Wba)w5@tz_hkZFBVEFmzL zgk(;l%M~oz-^z<^P0Y}OU9X2B4{onQNzpmcD;lLmh#i`f5Y33K!jD37NLucULk$b@x?Hd!uJuU2QGNE^;MKB7EMsRh zT1_Avkzil{N&|8fZ}Wwx+BWhPlY!9#xj?pZVU;>4{pPP(7y!xe{Nv}JI7dU`&`fT5 z&~kyWq}k8Wo9cbcgBr25+RWhZPa->S=ypKxF~!Wqzi=x`@`U}Hvr?vPa8`d{Sq%sa z>Pncz=WdZ@1b!BwaHMcg7kF!a&i;oGZJ9wWM#9-AtY$F;3nv^ zDTrd5A%k*I;ISn(X&Ud@x%=gRW}{%tl}vbPsqT5i(I4hyB?fsgB07nPTIiy&^%Xwu zp+O_*H@$Oz?TSL6I+hm)D`Ov4ISC>Fy^592zr|N;SnVN{8yVF2^F|(0Agn@{NfE;( zl36%?QLFk|>gEEcbLik!vqN-BZx|OLWLD|Rt;Z{19`^J_(W-U4S*_Ek+}`eOPKGgE z9n7bn#LSP(x~c~}$d^iidM7jPO%uh`SK?9OZ}+N--l`DRU+B@w|mxOYc~X z_y>9Qrf-x)@%2LSCrkOpUG|=`CR5wABU#N|4d)qK^PrSY@yJ6EK0N2h34F-i`?F&< zwVU%?fb=5F>4XUksQVH%byJOk$3bflvX&yCR~}`I_qdZ;fU{T{u{dbsY&+N}G#2MF zN{TDB4+AE=JH?IAMYH1tbX}T0xP|;E$Z`z9MT6EHV#mo(UsgOs1j`RNh-#=^$Mpk> z?%|s4{cpL|(=)UYdE-?*YyIEfBexbpp5}9F2|bLxjVP_@7K6d9;4uwMn0qk4q<*0` z{-LNnI))|;%bq~ip#wKW*`oJI%!Q_5h4b)HtlYz%nThL)m0{ijwKNbHcEj&F z#@p#3SJKHg6*LEelGjv4KuDsxYQAENQ%S80wAmaIrh}AD0*V`>WYW8ho1Hwc-fE9@ z1BJfy1i+|pld`Gg;jCz5pE4m~wm(7;GpcFn-1|3p5s}S|ZmRf9m!}nDZWr%)$fT9f z4a7&E=LXKhu~Wp2%vVS3SX9iZw|EowVckurO>2U?ky!Hp3UZQ~bUWm)ljIR~1zJ`q&T1yMIVBvfBML77COz8GkZZq5$5hy-z-21mnU z*El<@13ho3x%7E1DrXBcQdd};OQ?j!%nr<+_yr>CuAiPrO5#Vz_JQ3kI6zmwC+_q=J;b^&h4fHY> z=_9}MG{~MzuB0>ZFEa1Odc->)*McmWpF?p%qr&U*`d6YWVGsUiyLRWLE> z7w${R(>0S{utc_vSX@LlR~;|^9WV>YbHb-c+E#EtHigFW!6mN?+Q&qn-PWCzz?|__ ztptB)t855cS9ywg`J_N`rB8vv~@eGSP+T=F`l2s;rV;I8IW z>vAo}GTihMV~F1g%<}!`Vb51uRp%4%FZwCI!wq-#9E#|*);*8jOU{q6P<{=ZT6Dc@ zJ?q7AvsEvMS*q}S8 zw<0>gc)Dt4*b&X8E=-;lDyO@ZOfu=@g+L)ne+wt-UbJSNQwfHQANLK6ZBa9tz8P!t z^C5DUa;~O^pV|wi^mH2yh->N5$I+IH0vuc%SvVpeaq-)4lpmq~FIC?>&ky9B6l0g{h zE>`C2qR8x$1#*j?!kXm*ArHh~1LmcEe|T|)fnE+{AfjIAWZUrgO|4@o~>}PZ}i|LXbnqpwb2Kv0X8zn!+P7YrD zc{nuK^aHZiYOFYM`0B*qvDW#JE98jJNfE+{gXO>8`~FSbs=46q!+yPdf|nVV?^V*g z525D-gE(|C`a}6?h0j`=MxhzM*M^R{*t{HXZc5$J8sIe1EXL}FrIcj8XR$WzoAxiP z$_BgjQr$v(oY;kupF^kU6hpKCw<>o#cIihJC0VIKU4Xt!QmqBIa0kjeD831<$^E7W zH2GK?uJUM+r-MbX>fNiKj2i9{*F5gp63noGy4JM3Fa;}n`U;0)uJX&Djv2$F|icu20Gh zJXfAF)^6 zyDwJ#NKuCKzG?`-)@)KegO|LTnhIj`Y!T&Xv|%fn+o{Vf&1419wa?+3mIjEye2D z5MPC2v^SithHiiD;263#>QIA54$a-0^49G%B}pQ8E}pGeSy`*LAq2p#V;&sZm-6bq zavg4LMrZe$=2-;119Lpfi+mD9nh-Y^lRS3aoFaT-N?u=^bvfI$=Tjm4RBaSW72kL5 zncY^wkxRviB97hyh^s^PVGw?GpuhDukK#l{M93PF{Fh8)4YW(PSxmt&CF`qsy(ezd zc9ZLrQr}2OPYqn4Io{Ng)bV9cq#c?-Z&A;fLCc^98Vvc^me}3&H zIdu3KFfzcpiplSfZC1ssgQl>AxiAq`RhV&>>N*~0isYmo9JRbqNJb~z4>JYhwh1E( zRq}U}uH@-{Chnn%Anv9oxOzgLy(0OQ6@m}c5WrK^M}N0j{zC4l8Mp2HA)e#)xR9Od zLT3)$*T*QN4N>ZSD|Qope{Dbs%4f-_uh@1{KJ&SFU3vvQsUCvXm(OZ<5sqso1zIyp z!ozr}1N965!p?1}XL!7I2Oh6e?5-@z;nm0R;|_C(%{9K)PL`;vMkL8ZAz7Q(A9P?T zTxH#t+1)aW@z!C{bw5t>G58U&0lJY$FsX`2$1Gp#0=PgKoQKy2Mr;g{yo5V^?)DOD z+9Q@#3AX!Ml|OOM$PW{rz8V4KxE5NpHk{>hQDUSkP9!#BxGNq}Wl4T0^=!|aVh7k@ z6Qu4at`2jg&YB0A^_*6bVi+E~h3hl$0s-D(b3aa@+2F&&ZPENvX;sX+{o~}2%#!JJ zK;_0Id?jYlZV~hvtYRe)j!G>_0^DuTh%Rxj-ahz=O(difCgHV27x!ZoHg~I&q0PLD z;2V{)K{Eo6J5rBRK-IA@5=(HG7r&nxK)sb>Oq5n3J;de+70gH(Lzt7sk8j|#{VISE z6Nq5!^`%kbBxuHj{uv#qNB&}WZ9Wg_>xS$q0bR-#&FsjtN7WZZjw%8Or za_!{b!8f;_QCLFG$I|1C4rF>{Ucf&N4DIBy)E|Y?C3YBvh60R*T~7140Y(14h9UP^ z@>cA)=BTTIg8GxWq3gO?E#G2Bk{&a1t~>jS1C{g=qdhtTR0r9M<-ih5tc%>fAm$b^ z0+*^Mo}X5Oa@*NcDMY8{kc{Aj`(Lr1x&_-9!W79v#?VK(IS8&>Ohf}F;E2DRy>i1{FhG{-sNnKfryY^6DEv70K8P^Wr!eC3|S?E!0e~gX+K9) zbslQsvZ6FbrmY#8m|b=P0H}OAKJz6HBN}12viNUHIkdB5q+?Xy=mf}t)zd4}BxS*A z`y`oo!bsFg4gRCI7n~IiiY5R?506BaXN?=k4x@t;aph5a6h}_U+CMLyZR?sABaV@? z;<=O{*LX`yglcE%?a=$)S31LuAlcHGV!Qivx<*DDZXIWlrq=_D`klvkmv10F_izT% zMJa;XS4iB{HQW+R%8ClVNV_>F);RxD?#2R`gQ@Uc0wn|OarAG13v-({Fn92`f0r=` z9j@<@SLHRWGus{5Y7&e*CeWs_Se{g!!cADV4X?4{Y@>R`WkX`S&DJbKba1gbnNwEH zI!=E$@M?#|t9l2TJROMej{(qC0)Xkpk0Uq+A{>xx(7zl;*_egb*Vp*y;fHdLywJEy z^=^agr{nL0y_kO$DS+1ih@HCY>RPGcSGW4%B!3CIkjuLQ8j)$`G&rUXtf5a6r4~143=P)Z*j_AzUD1DbH_+5c^6~ z4onRTn8r;%WHhLZ_nBje%p*+lrle#^FAZ5D)2gzI0%Zypi;R}ms;N$w#bY5G0Yocf zQB;w4f|9a{aXWp;Z-4j}OLv2r8xr2&%m_1WCWQd&h&vRixC0)0eyin^dcfWc!utv1 zTs2bnAzD5JLifL_*dDgQ+Z96#94UwYWw$XL;$FaB&iiw}x{NzhieX6GF*4e$X6|LC zKnu!_Dc=*rD00K2;g*c=Kl6CASokC>M#rx!%h2s9OVNO?{DbZW%Y@6cFlLWf7!~9V z?KY;3pAMo*@XW2d6?cndMJ2My&yA}`uwPGx*nJ`|oz-^(mK)@)thXEz?UO(|g75bY z{GK^x=o6A#L06{d`n9+rITcx@a(T3`rjSWSNY{0dTrCuDOtaF;^cqnndX%CO|B7Pw z_$#wU-bVN<)#QT+a<_Jra1Ft=*z;zyK5XSRqkh++M)lt1_zRC7Bwf+z8B7MXN^T)W zQf0WX-8|b_;+fTR#kWbLccK4RK9X$4 z)3v<@q)Dg>2NJ^8N@b&kE6NTB7pdo{ScC4mUg3>^`MVVf%*wWu>z?xC-lmV{!SMl3 zMCn?bgD9sk76QmlVt_oLbQUzU?3tr<#kn*P-L()Ztb4+*igMLcgF218j|y#-xBXQD zwc)z(EyYb78u@HGj&0Q=rY?uP$7hq@Wn-U$I85`LK`@AdCYEv_r{_zADJWT6SuPS& zwwo5=6g72+#5OaXHFD=2w`-Z*E9cz~IH|}WSfIMmY1<5ml z-fFe+2~&v0988Lr`?8K^wr#jgs*lH_>5B8ashjc5BI1yYz`_mK=pTEzLz)T|a3do$ zXY(W5JjS3`9pJpmzUoL>Rm9Va7M{`SKRmGY7N1 zQy{H&n<`AkDaS3)1nIgZx+!l{Aa6HdgHlV+b0_`&lv8VL>CqxTQt8Os+ZUOJ8G)_b zCS792#2zOpUP`Zog#-%DSY@vKirg9NEYIxzEUUJb92OaIeS5STJSzVRCF91ky|JRU zu)j{J1|1;qJZ*AZi?HU=S11EWc+3VrFne7K2G`JI6I7(bPxCU8C#sHow7-?Q@Bt1| z@F1ni&Zc%@(4mU*BRk%MKIY5b?AtX2`O3YKJPjk2FDRcfThaxJ=JrZmL@!-VU3U~j zp12furr_)4@je#z5AQ>QWt|t6gt1c|atyR%(n|{~n_6r2OvQm;t#_9*!_t5?X*s6) z!3_9khLu@qBp!nthK6cyoaG5V4752FalJ!`QPZ;fxi=+m#dR~QzZ#=RYYub)bsg4a z;;NBVuygE>;*u3j54}zYg@nh1OYg`8n4jFDrMb*?j+Oc@KW{y=@xajkf}j=MvqH_d zaOY(CAMjGH$|`-q3ptRN-RW|O|1z$rDb=5(9>VfJoPy#4&M#Ng0Ta}fjt-0uX+Oo1 zJ0-H5qR|#78_}??fq-23k1W)??JXwAMbq$zmb9_W0TVhk^qy~qbXQ^V?Ta9ZIpC6) zYxg@Oa=_|#DRbMojouzb4EkZ~%w<4|C+e<5?Fk{>k;|ij1xA|RHz_H(^u^*eo_h8i z^$cJ7R%FZU&6UQeWVjS(mEUW=J<0(~?x2%W);|mPXGxq!kAww_e%(BVmNCpCosvji z{6c}Yhmi5FAX`vvIW`;*Sd(j099)r7{dM5ox4eKeG(pGB)+(1zxDjt-TPr<@R?dpC zl@Mhx!B6I|rgQOIUIVAa?b!U!sUyQQVJ$PkW7(J&qPBJ6g$z`-3{p%e`<5~x!mv}( z-GAyW;$?CsL>s69WYgmY)ddj?+4;3MY@Ii>_uW5pws~s%GZ|z3=(pSidkk`WiH3D! zLF)#A@P(0$?}|l&pnb56S2;Yf^o5Gg&tnR})Qz>C&tf8+iRMcYj$E5j#Z3rb$QJUJ zj@=pLjx;iduWHrlB{W#+V6M(N>5LndYE<=l(#L(IR6 zS%%B)2AI10F<1)HOTD1G3Fd-<%Fe$*+o1>yRI2-Xs(2DAJt1DuX?E((%oD=MnPC^I z51N2?{Qwh??_HYh=SFoA*McsXK^FSET+|Yc*shBZFW{1+k5zgOdFpYSCT`XDGgn*q z`CnX$e5dH7;tcXWCOw<5>5t(*j#lG`R$K4IL7_!A`jc<0kXG3F_uTy=$+q4hT7?U! z)aI}W{v||p5RX#~?np&%V)#Dpc1N#0saE1g<$Pfv(cH2n3w&CLP93JvqElgz+f4!f zts;qc-Z4q*Ao- zrvxIEaGKPX{0_D{TKfixEWK6$vLDF1vab>ce!`@Sb@8iu9*J(xBc0pKd(fUZg@`yW z!va~~$d{80WNXYZG-&m(t(!j2_s(}x8Bq|`Rse`p3T$h_a&ZRXFIgv&mVZ$}(u?UX z3BZE!&SFDHKr`NR9y9wjptOSW$J3j3y3G;G9snZWAs7fNfULn*fdxKKl8JERv2H<; zcfE2! z^DL5EB9u44Dqbiv;ya_zyzq?QfG3&+2VU1LN5GM~zRSJ7AXNkLeBpWAeFaE)5$j-fxwPLm#i@*~;G+E;E8mX~^Vg&uxz=?C&4HjXgL zg10e7fHJ;vG$42UQb52(wQI;akv;Brf0N_Y?ABiTj$Hgn;I#Ivyfd;APG!!`|RHleD*v+ zTWNq|;?{M8b|aIr5{r}<&BcwpQROh$ zCh+~7Pg*Gmsf+aDIAhB5&RxkhN1yC&`#5ob*P?%Xx;Q|QH$3X-Hoty-gbX!M!Gu(T zB-*_}4t(~^ApV8ofbgeq1V#(WsrNbxkp7k2vJao&YU=|-??*UPR9r?WAiTI-wZ<08 zz|Jxj@6(BvLPZRwt{D3RHaE?= zIvvalP+}&=n5yp~@~H!QYPLUA;Ofhq-~p;M_6??~L&CkpB{WF_6OKjm{6J3~6sctl zCcs$pSTAu~;(k&fa7ArD-6g$>EKZ>nP@G8L8yzb(3ey$i6Z7X&>k@THJ;eZn`a*R@ zff5^sU$8ArXgN_gEu;H9er9#tG1N0cJnYvM&0Hr49-&~{!rRfskFb5b@5(2*SVJF| zw%kVM+3z648uYFuO+A z1eQ-CP?D>rd*Uz+0yj=s82a8>iFFjT}dyBE%GSO?(T`+eMf> z(hVh{wXN>@&pWc?Rok#a?G>2*eq}Y7SGsJjGhM!+F{7ZmyudV#swx!@JXXBI)1C>$ z&JE!r)jpM=o+S7{frzn^3RI+A(C|?KBDHqphA_09oOgORRW_fbCuP+Z7G=)On1O5T zdoQpgRuLoJr9NTdEi5h*mX(n8po1ek2c7ePFL%dDwE@nyRffVwHv)wp#Pk#%2kA+w z9Xz4v)~>63|3MS+rgex}F8y^QeTKgNegLcWj4UHTq)$Ew%bO;d)qd*6%juA0h1`DU znHo)6sV2VTW7gQiLlF8f9z#j|_sk19vk39mPx^48BONc@zu!2~e@5HFH2wp@2q$?j z6C5rqyW?nmfeV@jLTUdkNNim!DF$u%rLjuG)70q5;mxVTd9>%uJAB#c z#MOxY`p*MAB-~R=2ZvO6|JsZk+>WU$+(|GA<|clj);f%6H+cA!Nj^^aOibH>d1h(o zIsC>qi37Yhp#@BUAopjdR9x?Q+k60F)E&9_*<)3RPl5Wz0IqO2BT6@zeWe>}$`i#T z+7x#Tv7A|cd#szhg+~BDGE z=(hRlsZ6$O-fCgv_?)PUQYo)WLo$7IImhbLVQV4!p((jjaS+-^&MT(XXIGRq(-4I| zL76PWotOywnnvTVE%Iu^r`$=`e-m?77{gDuF!#s*k%hSL*Nx%kq>E!gSTbnU!~g`s|%~nM!WO_K$6xZ9?&m-%o8utf#~gvp4_6<$m325f#b0ZO>f2MX$`Gn0XI3%9ojOA7R9CW~Kj=40JMb{+GV2PH8i3 z|1v(gFB6rm*YS)P^*8uRdM(1E8uWGk@-Gk#B9m;u=%?s}LqFic4fE7!aKG^b06tUA zeM%5dfTAlcYvxJQ!2(8;5({R`crxz}pLmlqQt2OXGVNp6|BFs#`+w1?oSgp$NBy64 zDkCTR|3*^(Z#tEQ>3>(_7PZAE#8r^?Ia?zTtmt}HZDTQ*5!dvF1U z3?N=Pb>8RY8@Ut4=177pmoP@>b{-?om8GJlKu-^K!9 z{=O}^{uxO96GZ(JRDA;=$NKvFpRlttB7g)SZ$BD<37UUk5%4%_gy!PH#1^Qv$<1r$ ztREhr^XW5ytFNzaY2P5=;VS`pJ?A`NK8$k{*hXKiIb1WaIag+opzZEoQlQ-U=FE(w zf6B_zQWB{7-Q?l9;eS5>LGD4iG=NzIY6;Nc<3ab`rT|d$dC&7!)#J+nHCOf5`fxL2 zQ*Cnv&=K}m^ugJ{Ioo?f+qu>KwE^m?fLTsb04n7O!ulqp{E*WD{;c8rb3%UlE`B3^ zb0Dto)fnctw-w(k*Zv+5TFiFwa>DkEu<_8Yh5zWso-?8AI0RnIQP3waD zq`-lUhgSgm*Wmsx=2o^rua8eB520GWc8IU;Sn9TDZuAK+%PAu+eVisyE^E&D`R23-9_WZbi z(Fq%xfNAHP_}s=n6&t^YIf`7n8^q=ys*<-Fm4 z>WNQNk=7L!P))tdPyM+_NpN@qdS`TS0#4&>Ujw+h%J~A&vt#%F`8|~b4*V?-yppT# z4lE+}|G9P4eLd$T^8PLW?C=8%!N2cmQ^nRzf&!lZLj2HTvuAx=p@03Eb^M_|{>h*8 zHGTI%{rstt9NC(^rRCk)4gSU9o5Qz0{f0eMYP+?qQ7X84=YWR&Nw0wZ@OC1_x}yE9 zk>7#+cjf?2-SuZnysiRv4ce#x+?ApAN1N7nv)Kne19uIe=;RFg*Q*IIeQj<1H}=M* zbJ|+B7Isxd_U9O&8+PWGmh8&l*8I+Eg0sy7kRJs-j~#KNB89WP4WReB_Fo)>$4`kN z0CiMQ(Uuj&eha6ce@PMa;vMqI0bsqUzBAP#_P2Y)znKh+<2Pi_9U-tgPy(l`B~-wWVh{@TjS@BiHXqT1Va7p}hl4E}bx zRipd{)*=P|0_#XMegpat-}~-eSab`<`p)}cUH!iME@E%#{-oZd>OaxFX~#b09k%Pn zw~J z->x3GdgL;W`dUMOS~mS&27fg(ukv*Lh~vllEYEyPx_WiR{D5?wI)5DcQjbh;fIgK5 ztCTf%cyRwv?>B3{`q=(f{@gnM{xx=VMNM7#{I2OdQ9b?b_vzvh#G{YnSa=L9XfsTo zI;oG{kUJ2`pWa9wXk6Otz<8SOnWV|Rd9l1Je{N>S-_fldRuJnksJ0bf)DEkT=X%3y zVeb=fC9Z7Yf8)vSTFBV75!1>Z!1>bhq153M2$GntB5gf*IleAIwuab-T&w2Ky1AYS zD^U-3zFeohRN|L^v*9(=*Yqk)6@`DRa}MFu;l8o8TgP_x)41W~0nPqrHwyrKnuhkd zz4Sz5zPp0X7~~cs`73gtMbZnx$ANTv;tL1vUH7S^EsKYjT{~{YmOgYzDLX0@Q%vwew{&LOq(0Nb) zc5^~fYrsEq)D{v2x7mqZ;UHrE+TBVB)mexbbh#0|Eunp+K}3Or zy9b}1XY2NZMDc1HHc;I+UB7~U7UI1PJnZ>7`Fp9V1|9?-lBWGJLad>LI7F1%r|4q! z$R)_WcmUry7{HoF*FuyijC{AC5Y2k%yo1`|GpF~V!iSp?7FCN5alIW@$oHk;va;z4 zqt#Hx3M@r#v<5-(#MK`~!8fGfWP#?#EX9F4mP$8>j8&r+4&?~-Ijx}u2Z~xMgtmax zBC4UAvR#${A;T`EHZ6>QqqQWZ+5M88Qj^OGp2GAJqbyoe_5uATC7IKBrs{A>hW;Yb z6fLjgOkKbKNV7Vf0AXT|ND+tgk0mm=V}A)zxhfduz*|Ci1Eype&4R7|qNkM($HI7e z-uJcI=c6U$d0imoxyjD*=_a%mD#{o#XLfo^DJ2K@@Oze?HrsAq|7=)v?nZ_|+lxAx zcsbLKDxnLho0hd_iXE+U#xzw8EmGSAa9>YSLLF6z()a)cm^nqXw!^lLYR_>EvAi+%#vD-V_-Eb#y3dsf zMxdycb>h>I_;#dnRM756uBQR{dg!f>PWqY+EV1$!&hMXkFt81hSKm|jSc3!?$pK=* zN4pzhWdb4~93~~W*0_JQPmt@oNIV);1;$wXe4>Jlo&$RLWq=5$tQ>E3;~KI|hCI)JAxBsJ*ru^WNP`>fOm2+cdzT*rDv`1+ z*@eU={n}ZpT1lK`U4`kV%j!{%itCHY2>B9RvpDmb0c z*lm4WOS}McB-^7LsujdRX1zn4{T~+5`r&h~02`ms+wYX+#+kk`@+zeJ-jKv?C zC1wyVwOaet`O^$ZmPB(x`cT%fP4N~_Bp>>%D{mh)4#B(B+J^SfR^k6|n9>9e4upLvd+jS!2;QNTcsAbVzhLN3FyYe9+xa z>={#V2a0K$4$hneh6*lBy>y?f27z`;GXRUe^pLTOcqApRoH;6ZBTHh>bSJTW%fjoL zons<#w)5PSLMLp%xv_cm*64GAUV`QJI&oDBZfYxx z={IN@*CWV4)dOz;)Q)7=gvGNefA2snFOs9o?!I!kdID;dp4~fx1=g}gOJr2^ARPpl zD8+5eN278p^vjqbq00gf!s;BuxN+Fns%aG;DcK6ZNUSiPweqRZ(Uo$ZWdCdd0d84_ zL|}ob2(P>+T;`(X8uj3{Ef3Wxb5~7w0vz44^)3GDwv;I66Dx z?>%F}{9ZXav4V{!+=4MfG5FOUMxKeKM+8Tw;;xSe@Qob$=f~EYNLBJEj z-~+o58I^qKu%!UQo>f~t+QD=a-%3^DCJmYfAOn)eky$~7%O?^(77A_mN$DrFD0pj6 zVa5LJq{u8Krv*}VQMmI{xXus>=WSoN=KV#hA3dpp4u9t6k)wW{c%?5U`5Gid5|EwJ zsP9Uu6iboz(`^b*Ujr~Wfcef!WobCwOr;E3{V`TOAmwO3ibA(gns0Z*^+q0@>rlAd z7qu;GorJPyemhE=T|VGGb!XfD^a$k^4h};z4WooA6*|({VvlmlG#Go zo6mfg%ap(M4~r`eLyO=x=X=WONsF?%8m)}L=sx~#;;!$+>4n<=n^`HWJ(upI;Q>Uf zrCu>0T)dTl;8JHCch!_51qovenjcx-rS3^5{Z!FY;u=uAccvaKqD-i`i1B%26sDeG z4rj>gc<_VdD=iyU(o}3#J`vEXg53QE%vZ{=nwP6Iu?6UH?gTj<$>}OGS8nkfv)I@? zh-_Z?eW!8biE5nX#~sWT@>~1a*9}`fnhm#E(|34Ds&eQXDI3(DU}eI5QvVMLFs@nt5X|k1?4)$q zH+4Qier!di$8PoH6%Art3aNUxze7;_=;eWR!z1$gH_B}PjxsEprSFWlu0LPICV0sL zlTqKku6(IT%~hQW0)s7>rz}-!5=w?8@M#(QRLbP~5~{S?CjyUs*#$~w&TFo6+B&7Ap+a4uI;lcvB$HEKbI{AajE?s}*sf&NQ}vNpBo?-> z6BBv$mJuB0^xRKp88MG~)&69sJRBv1jZWmjoe+#3`xSXXjpEp$XSHxT{{%>@f|G=V zak7cr-3;a8EL(O%BD}G5hCj2ha=ezvW~+YvxN=5dBW7G~^EkPJ6~8XO=`+nCW_jrx zw3>o>gPJv@2_8n1L7}R_2^{%p1&Uw0 z=#mJ7k}J19C6#=AS}*PdkzHO<+8-wj2pXR>y6?UO@oBS9=I4qkqW!y`8UGtoFl6t! zG&WV>QXVV}a=n4CgAHBa4X*sQlZ-+TOldIfp@n3esF!+`Y5-~x;oxC3&YF%&2uop^ zE3z2#ZK9@Ep}aYy8Vr>;saHs0{j9(BqFs=etOJn-S8RnH>v)!eNBKG)he7jz*)&1e zGE%hXgBv1bfOIl^z43S``!ymgx%>k}(ie^xyIF`c>gg_oCyDDoKM=)AZEYa?OSh%d zCj}X=)a9Y|u)1t*WR-ilDcT<8E5s7fl6)V^FG#V4C@qA2v~Qo$7D}4eWeBZTXdx|( z7q6i=2w&X4MmV-vNciA6WZR)1U8(`-2z%gNEgd?!#>*l4jo-NK)?ucWh3LmNTlU z^8!1!x0^Vl_3lsbs-a)sU;F9XkJ>)e*0xQ$#a4uDwBcKEUs|N!a#e4vji)%?{6Z3- z@q9cf5&vjlev9I zKUcr&PfqxuGOWcSyZOfp%!p{sL4HNu4ooYN^78 z--Xr(gIR9!O?`{S_ZAPj8+5{5ABbIl&7laH4*3FyL@X28QpRbk8r6nVLz^*NX~-L1 z6vxvujz+~E)81ckA&=NeN7kzkpQwBF=1#SRC-sp-iBGX~;5M$YTcF4dsFnE&Lzn}O z?GUm;AY}wkSd-MlZ%;!_&heR&-E*so<)InVC#7W=*^WmBj*2RTwMn$hU0eY1x>FY* zI@oN^7%H`~{>R|Ge&r(11Y?agSl#?2U{ToQ4$G%BlRX|uF?O1uYbM-qcEXRVbNwvM za2M)I*ztaTW)++#HN?FW^&%%Lb8_ITes94EIW6xlrz+Z@{gcG@x;}_aIz=hA)vglX ziBN4F_;5I%*Ef*X(F-=)+$$ZP+Jxfq^NC`gye{<2%5O4zj`IqhS%vEHx;M^p z4bPOh%v5rK>!8u#r|jCAr-k9Mb1zkF+AUDLZ3L=2`C)u%cjKB_Ee39FqU_7VIKrSP337GV-tgye-;b16_M3T*y} z!|lqtKC+9Z(##L13w`7_f;2PJm6viy%F!lL{s79Gg zZXSJAT@0gXpskT&P{x49<0Q~LvhPiCDthjg&AfHWl*Q=yK$4}iv+yA%NMFHV6ORjJ zu#|&6>-B`Y*1Uvfx|r{up~G)FwMh-Z2SqqfF|Z44m;`Lka_ImSH8cvqo4`rat*SC(g5#JX8*5-Nl z*rz$($8@OcI662qI!~@?!<5xO_vYOk3;pz5GH8PFb`>DfRXgD=ES}{JDIcCCu|Qg- z$&cDEK1C&16dmz)!X@4TsCG6W|9N<&7-+K{ zr|U0($>&xT19+$;kp6c}!z%`}Mp+Dv6P5 zruO87-d$l2>AD1`F`2vNDa1MMOI*Iw21;vomHUp9d{YGEYovtBa|Ifu?dX;#b!x5S z3pySqC_$dQt~dKL`S^~ZV>S9b!Z20EMB;9QAP5y4Ss zZ0L_yG$ALJ23B${?~vomUW8HM0=--d<~R)6nlBrw|8`fu=S?@`d*}l-@h;-5ep1Nq zqy4Etda9(0{4&B4fC@DH!BEhO7xN;5BEOhuxpq796UVtD8OwEq`n^RW!GgcBc_a>? zPU>gcczH3g)wm?`6k@1x956EZoT(5f?uve4@vcCW^6aoKbVpKw_(fHqBEN}WNO#7; z;|*RMwPD+sW@c8V8!++&0`5u!5A91&teht@&YAXM4)D|6S|JqERSRc!%^A^$hP8E; zB}@FnD3?F4is6sfBmYbtrC!)wtFc>0f=WrR?@QXXs@MQzeWd~S+jD;E5Ix6Ho1=BPVMUt!I|xq5 zZ5PfM6k@uea7v3dTxFIX7l;TA*=H9}Aw9KJOQ8Ep;8oJ^87YHGAektzTYr%k*NF;J zRIMIIvujOYpCdoN67_kTQ^f!39uw_3&?!)Dieu~8l-WYYb9+1+DSoAt>WbKomskho zchVd%HvUd_BIDa#SH#7+jLVx%C@oz6_VrGw{cO;0d`b&6GZq$pB1Sum0zpcI z`s=v?U?8?{OkVH*;>%c=Qww+jT7m89{5lfSx7c}dbq_aTnjm}z!`f)*KYy97Hd@-n zt`PE=*2#&tmpp{4l35^WF`gD@Gnb3Fuo>DjiPkk1cBzvwca;jeaIX}T3uI-LY-G+N z<~3;(xB)ZsKNve_08zAH%eHOXwr$(CZQFg@wr$(CZQHiz{a~W`!6X%(^dz-wuf=m$ zi^m?5(l_nFKd#lRM~RsB5bs|~rmExq`4CHKJvC5)o~A-6pdPs}=ejJUo?3R=#LnHV ziOSZEhhAN1GhsgYi@bZGJL_qNt^*V8u7d(so^)slg+7%o;!uHY!VyFR7$2b&`4n$l z6-x+Kq8uceYo>>e8`fTM9A~KSqIsj-7wra*R3iO%Zs5*6GLky{#2|DSt(wbk%yQbH z`RQf+W0)V+Ey%3!8&@OR6 zf~%xY*N1T~fLSw|8iEq9cyXd!MmeS>)@?d7=>L~cphrx|kiEXsNQdBI{x8HL!4;*8FPBc753Wvtz>fl&5SRoYZiVL_;3Ts0*$lxaw#7KviB8Oy>chp zooBsRfyv4cj>B0OT1$Js1^B-9dts3zSu&(Z8wvA|NsDtF7FY zDzu641ahcM#UZb26c5^r-V8AHWb)G2WWZO#1v)jCV=H>bmr7m*v8^yiywzXg+LjZ56KN^J6Hg<3Sh7ZG41U4 zLDE%KM9OLP?8{RBx)!*W9BZ6>X{6NDj%~*jGe9_sowDm?@@hdXe`24cC8?RMPsvY4 zR)*lu8UOpxU3>T~s!A%wdmiQh>s;VWWsr1O{D?*cZJ1MlRbY&wb>F|ms_I2<`RK8+ z?@Taw!9zytj_wVP=l(~LP-HHAk#!){c5Zy8X=s*C+|q~)edQZ=6Or}oP>flv2Z?>+ z@NjA1O(JMr800Vx-jN>Q`=^yD@{Dneo0LUZ+C^0@NMokW&Q#VpcPMTqXUt)N(vX7C zTYfuea-;NX$bK^vK(YL`wlXd32)E#PmFiLeSn>310v(o(B_GPQgyU8)aopIvt3YTp zIQm5sY>?%9KVPOAZBy>Vfn_qOpP#m=xN!O0lJUXE#Y=LN+z&HH_PLeqkgW>j>7X{t zz7b9L*f{_S_ROfeui9Fi!eFZFZ-{Gmmb1eg> z>~W>0uPzfy!!jzZ`7U`{wELjzQHA+XIlLAn|G8Ta@)Bl9Br$HP39{)UYfcSjG@i)q#P{OVI zBGJ5Kbo(P+zicWY6b?`H>@E&L+OX~*=+-cVnYkS( zRZdlf7>^Pp$CV=2^JL9DN%A%>^qWT#4?GW$0))!)FIN*Qa_UnFiDV9syp}*`+H?8Eh?0sR3vKE5M>ToG5}Uhx^A*)%#NAHfbwm_XdWyf$ zE6h~7NysvxY$-A{r)er!;C9mwr8_SrQx%qb=eW9xmMDUIH6!X@35b8D@6GM%&ZoL= z58+uvI1lv{f6$DoA14(UHS$)m2x~7$QY+UvqrQ{pOuIl>0GZO`Tg?OiM3!+*oM&il zm=a4)W;igun4#>N%4(nHAxZ>$VK zrZlw290%`od2Q{xeOK%%dXjrVUJChiAvZv>l%UN=FpHarS7PG*r(3gyQbGseF(3A| zXtUTVhn42DrLfo<)7V61vGS9`>xrmgrhdgs$xP9U^*|n~9Xdu%DsD6&{qn7e#}|Wu zv^J%o<~QQ*hYXJNWKA60rfgAI>JnMCgPpzHO!Rs#iBH>4ZeP7J|ffHZcBd$s+Vt@;Y5*fW2 zd(v0=k{d_l-zAPBgeDeM%3PERM*JbWVPgE3P+Uhe-A_|oL>-L?&3k;aVnT@dOtFBP zD0~tB$1#P%o&iWs;icS1^TUsahOd-SFi_yT`r-(*33`f zNVVDo`0*jnjB#+9n(rBUZ#6P-8u%?gXJar(s*VI4YrqhdntOLe52AAWJ@cFJ=wmsPf}an zT9u0LI3ZP)&4xdkA1!x7jOiR~x0Ga5aL^zzL^$#t*CZZk@#D61j#iQ_?DNWwA}0#1 z;c*?Oh`}lORk}LdnhifRgJ3F3;g>b=+6xQoydk~PWa+FIFU_0EIpglnxuJ`dKpgm{ zFdkjZ$+@-(YN!&T(Ah~}`9>{j&ETR|5^++d3-c+^+#N?P%ube_*3W6^=M#50(*L=4 z`AuTjLUBJo&c>>{`B|aT=>n`fOKBi7(Za#|pIQu4D}Cl9B&&*B&{-Q(RsAd5x9ZAo z|G6U$$s0`gzM;0U$a;;}qke0CFD-?UQ;CF__Qts;Ks)w!W$?n_O-~IaMK^~go?#6lKK}(HO6nQFZ%?g{q$fGdYUC-g?n%_-QcYf*v0Xqz!I0(vjra6I7 z@7bk=-)0`WBM`?N6Y#_RfWy@_Ax>Qcmre9TN67h%*n3ewWvFY$-vCwJEM>p?##Y&B z@diF@-L|hyKewV*U(>=^#60E^>V6^Ip6RLHyyiZ=B4EEl+mJL)Lr;ohxZPKS@U2qa zJ)qeO%PRn_wt$iB_x`#x(@3*0$`B#5Sb=4-1e!4YY9)R+?*Zh8Rj&9ii|+RxeY?qS>%mB!7OfaURj$N423<)>F_3Flp4-G}HuXdLpwh>&3qYyQQ3L3k0 zTsXDJuFNo6W;<>qycH5h;d)tIiOx^jaIh_Dm_Vu4dpmMkg1ID$vk#TlIYg-#k*F5( zRWjZUADY)9=-Gt+P>=~VvInb=IQaZP9{h01soVs{IS}>_0+N#RI0H|Y#C)%q-Prq~ zCJ$B9D)R%5#cvpn6o*&{?UhmEyFX8pAkltzU*aN8VsldO_+8U3)Hv2Z*7;_^$3-b@jH}rGaX;r$P zG&H;8rxxZmi#H2}e-KVhu?IjM)OWUnJ=D1`e#!-+he;n#1e^tI*F*|L7DK7TexDer z1oXdufeoZ?XF=biJQJ6fFIT{=Xz2w+gZDBk)yaa62Xw_S<@UVUR%qzeDd_D>N)Tln8Xw z3}^0g_7Tr>3vR`+NFvi0A11Ls>oX1>JptxBZ!$=b=8E!cFn-#2*ha7{!Et#0N$I;F zeCtW^k+N}6U_Ot_DC_0_YGHKR@i#y3n;>sRVLvpAPcWLXsS{Z7x*`d2AX1PyNPUjE zMqIC7CJ#x>sKyXsOrGX}d8;8OH7Af-1}7#SEq0e?D#$=C+<$?fD4tbN+KdmAHB@q;4GeAemz&hXtp_D)Gqiiya4jc#W}u(4i{3Hn9{ulp z#5eVyRCH6&v{bRjSX7!WDNLKQm?jgdjt3TdXF<_qwkQ(B#QuC;Q1CQhL^;<-?otxU zsJh)|{vwdv?!q`bR+Zs@T*@@$9h^WIS9Bm$K0g3VP34eQ2;Nz9tOie5w@Ttpl2&mq z!@<8T27Q+7qefTuM!JC|151hxc#Lo3-jT&d!i9cK#*=@G6rIAiz&^8lg@%d3 zK5n8x_8vUM_N`Qv&fg27Xx%VhAYH}|nw1nj- z$-IOeMuq?@Ykuveo9jX@5q#iio|ZVIt<;d#S6bX39Vt59UQ!ho=#2k<`8t+cANQr2 zWDn_sbWqK)0>QIIyU?S@H(+`|?-2k!CiYOGPAyPdcQ*@jzVAQhnK4Sny(Q-K)V~qV zCmDXAop?gy5LzD>TU1nvoWC%U9^7nF%3RZ^H2U%?_4-2XAHoLFp!^-|jO36O%Q47lf;TR& zE&6I9p6wQ1-(&uiQJoZg$6rdH;9cC2%4o%0z$j-poR}4n`l#U!hrtDQcL9fyiV0_b z23Nr6rC|25654a}kz(PM6mhd=d^hq{j(cvwUgK=Yy0gHhjjV_%WlzaO?jBweGjX~Si1no*Ta9Gt-vnZ(-6ThKL-0lF2@G(LA z8I3l%8$1naTtTG1|HAGyoh1WtTq70&eyvh1Bc)$V{;y{99C{Z|FZ6w>D#1OV+C27f ziyU|S{U1z~&{oTmFP;}tdw3-)M%KpN^!1!d#SXc^bxx@oTQFxxLpL{Kd$KgQN?qOt z<9sqr7af#k)lJ+gzbFf^R-0K0&UohyRxu#fH_% z60=^?>jK9jS$;H!us;y3j!*B%{k#bn|-!~CjpjK z(}^qp)9ge8;SXqEm&BRepOYyB(R|A|7OfmBRbya6JO0GCn!0AFE|xKW3CMVL+qWo6vs-lvt%QCZ#5z=WL8RakLp)5fPg|Cxpf1m+qM@NA zzH^0Zg!C$uBbM!c`c0>L=bG%D6DY{#{L|wHh8x4{v+v~tXeqk(i+TAToRIXM(se6GT)8M?H z48axg>i#r<6N%L)%G>w%avcyJpYc(Y;W(O&NKr)9MDFwSIdA%ZkwZ%7(P+&$)hn(&k~2x4t`f5<~cqT0JWzK`#);j6rkz;ZVh%zyd4`3QUT ziK4QBZ@KWmg@ABMziPFaU@ z5eX+Vz^Rkm1yu_ePi&sClVi)xQ$(?N7ooM}ExK{u(WLN9dCjso47m2?=XXSi#Pm3t zZLY4DLP4SYrfTk%J7W+F2S16G2wS2CNL1)(aGMK*=c1;4xe19Af3+q6>)JMxtIE-!|F5|u!#b4(-q#22HgwSTu?~)_CP(vmG73Hc^A1wDm*%E-fl9_a7hg^Y-Iys z`;r)q#vI=gGdea|cZ1CA`ktF2_?Qiy_ZJA0fVGiy2U?^CGD!E+5q9DZ_`#$8*yqGvK_re2-)6lA$K~ndf5m2zOA=xMb zADA!F!~^*x5OnpftFI(Om+Hj_pH{GJ6&D*?A{_J;S6V7G|x6U42UrQ{Es7nJ7!IXL=U`xFQ=4{#)E# zFN97YaFlV0+`Tzyu6z|KRcrnW{Lt`i=5Ed*5EjO%9T9v}$kS`$=h6v`;yj-0Wy9}T zD&1#rp42=iF&yC+G%(2jLAIRL!c`A%UifQCoom(IgqQBK7y9WiOeaAT;C*FRVa%F@ zFzxk@ZD+Y;)u%*T(s-cBDr0=a4X=zcn)|}ioTPN6$Z~s~obiTyg+=5MybUj+z{ri` zXh>W9b_EC)rY*)Q*oT%TK}$T;|7^9jxM%|cL3^i7t!Z(<9ceJI83m$B^rD7aq{(Fw zh&Uf&#rnI`O#N+3YV@dvsCz_@{k(He!T89LQ!Jjf*Nb<)fE$@#er&IdTXKXtM43{1 z_N{TpR3L&@u^c&BjqJ7l-MfsqC@_WrusN=0zE5h>I=e}`T+PMsKElUQ#oerQ0=e9g z^{nz9*~k9us`7;o3AQ8Mgk|cCMCavQNMP@ZQr1rL$Z0w^Fz(0eqm6@rO^LI}Xdw!{ zP^(l5=W$o3$xpe)3L>*lN>kZGW<|_Qob57!T`k?Uywj?C$y7f3rV%2N>VM^jDuX4t z-@(s}zZ55Te!xnY1gilV3&4jJL>(zy>kGolq95jJsH)0WYuw*l#5kn{=N~bMxgVc4 zUnU_@g7aQCkV#$qHt*UI&RlZoo;=T?&nlQBQC6}dpyf&ifPzJ<57Sfo(gDqj71M_1 zZ!v%PsCh{*3?YA;?y~>KbcWpJ?!!#Ow?6E|O73|fr_%QEFn@^~Sb-*E!iClQ+GM7~ z)9cm2QlJ003)u%|>xH2RrJ=PRH)=@qksdBp;%C|=msF7+Z9u=lVb=m$>v24xN-cGZ z48SM=dcS!0mGzoq_EOp?{|2TOcnH0#vR3B=C)1LL$31QH{#XE@E2o#WN_8;j7SJ@p zV52yPO3Hbf!vwE_hy-Emd`LE{nZ*-xBMU+$hVzmy=1H4AQiT1z*u*x^oWg|7(>AgZOef<(j2zYEtT%I@E-Zh`t5cMXkf<^%q`U)!4@`Uf^T~F)RW@fKPC+ zoR@*=NffGmWv_o&T`d*2>DTo(XhoF_5u>%OEyC4o(|vj8V_twT>Ptms&2P%{9^&>d zp7*#t>ILm{CRCTpl{{@%5_SGu{3ci&bH3|BrMo$B)o3!o^lXzttHLvxDZ9WFJm{wU z>2q1am6Bs^CTm+%Oemc*Zw^%S6F2?h50H)cI`e<)GycB{Q$_+N78cI`TVP}&U}E6- z-));rOiZlo|DU$a=vQC|UHdOEs4<)Ec1bsztyWue@fcfj*vwH$W9^uo(boU;o09(Y zn{R)<%x5xYZmX_GUUq!e2}o2FOHi5XSb!row%Hb#7Z~jTgN;(rFaTg+W?W!kWE@IL zsLs-Gl#>Ck_zGNE(okl$3Ld?;eoP zIzKS@pIwu{`rHJr*^mD}(ecMi=+43 z0~=!?7l3YjIEBW*!| zzeOhBw0?8_TT8R6a0Z{bAoE-QS*3sBXO|Y{K_MKR9KgK1e{0_LLB_@*7#bMdfG_}O zXl(X>>-(YtOaBJ%X58x?fGwE2=kSOF4&L_s^IZ1EriNEXCx7BT_qJAvZb!c`P+C0Geg0VE{(=ghzjW_ka3Wp#Gu#!5z`-OJXZ)1Dy30`qD4?6S;l7 z0VsTXb5a2QO_7>^@wEs5jN}on85)=}`287v|M6V@wSWI*-S5%-*$e;r10y-NHhzlB zKE(b0iQ8J(8lL>x2fr1#x_RjXXl}i+)_?SsUiSOb*3irk4{m(^S&`Og^^=ggg?bX4Jy(N5$ zgZk`c|M4m}Gw(Y5?X&-*s64xqO+213tU3waVSm1-w0X z1D3YJIrMQ)jzZ<5f75=V8v)Nl{|H_KcpdPE0}IeUf;$48i~dEeV*)%I`6Cbq=zYT* z0nJN)3r+)gP4J)p@MQcqKsx@2V%_CJ`OkAiFW|k*6@P;@0G_G*=e?IN{~Otvf1=rU zTtol!yompNXYsu+{6*K?#`M@jO<@fUkaN4c80%j8oy6;AE=uDbKi_@4(_j!KRd%0bnlq;FZt&iUsl&v2C(gK zqeq(NH|QR4>o;`o+U1k}eGh?}|G=A-=3mOBH|Z}!Q*YO1cif#n==2@=28TBGPcQrQ zZ{)r^q|M*(`>f?x8v4;);`)zbU!LLHZ)0NvQ06Zs74%VG3EZEub?TeR^==*dR^R7S zSJ10J**m)v7}sx;_a81$>7I}_d45E~${)_q^rQGgA33A*ul7@)k=UqvTwmwVyB^RO zKdP6z6Nr}f_g#3yZ!2Ku_X_c5p8kE15k!Gaj``m2{k~ z2Fd!C`ul!+g)s7Qp3qn15{5ILsK+$#vz<(jM@S|_i^NpRgp1bRCs*L_%hc|yLs9Kgis#gpxGM~-koSIKy z>0wYa_A!zqzzAex6P zK&!QI$=~5JP3MXI4=|P((?^&NgwNqa?f*f&@<#wSK)Jpzl3Ay&4zt`ncRIG`UM!P2 zsnu0>`r8E9I@pW!CC|=0*H5Pl!7K?;HYy5n4L7P3k0ZBN`a3WBkv^YZoM5;TjNE}T z)@4^eqWBVh&?Fyfb2=ge9dZENr@&`*I+a_TR#GiibwmemjvzJ@ez^Yp3i|i$X0?-k zX0{fU2zj4@wOhiToYoWy0`0M>t_3#?`BT1`ws239MnH-Cp>A8vIt^mNTp>uUDrAS02CZ5nuyo=#IdOc{*XQPhY4gc@P(}#;}%=nIhjN`SQteOFIDQ4#g}v;_RoB>Vs2CY zi*~S^qCc^UNjtQDud?(w`p=eaaC2BzxqP9wzv=kL5Q4zyg3UZ6-n(E7DWJ#bxmhX0 z_cGSD(GD{u8|M-z9#k&23niX&xe~|DGf>jab(5J-Vomg2P#IQ#)HP=VnUQ37xDmu)c+sQrz@_8RCrWz$8PEuDXdyNwKE=(VHBiFB{AXWDxzPNMs<;>R~p{|Eexd zsz*^k$q;3R47T8;S`c4U-4_c@Bt@vYC`jj`4lNxMB*B>y5bx^QC@k8fI)M0972_V$ zhCeecHN8KoD>{!3PZT+m(Sa1vFe=`mM-i6jq1yYgMfDhc8$&iQB#-gF{8W6z%!J}S zK+^ZnjH8ja!p1XQRs)xwS7!!VlY;*~u)Ol~o-oNDVB7CMlIsxySjV3YT9I@A6geat z7#8XXb{Dy3d94Rzf(RLyMcYxauqC*e@euGqDXNMAvPcA4q&8U5?PWCiwTcVv|GF}U zk*8ul^E)kH*5R2ZnmZDzz^(cx*T{J`rYU>E>~&Y`2m&{RrFT(My&P;)N+!JFkQ_z6 zg{AggJ?o1OFip7RM-Up0ne_(8!>4Piq?~D|iFM@=&=?G+?4z)`#Gs-fEx}U+3x_}F z8v(?qlgU#YC7Ej|MOzUhs}vYAe0j0oP@TXA=d9a>du4&e!Gz$r7X}rcoiVzxD&87hfjwos!pX*YHN}FhDg~_yC?roVbTN#5R<}^d`g^N$;Q?bT zRb9}~1)JmCBvavRYRgl=EOA^Q{h<@_1M;A4D@j+V+Znu z^BTfLmV~O^-YU+w6>asb{}t*1T3L%P4}odK&C+Dcizgw6H+uK^EzvdQFAJ03Wmj#- zaIu-{QUgf!tp83r6BeKS))ZPTKa$VTafyLwc#14*5c##UaSODGt`6v71R*M@!NgWQ znO18u(k!mbPsKdUdmF_8-{A2zVcbUfPhX2PZ{`Hg+MKuTL=iB24|Bj&C)&JvfspnR zYIEWDiEk*(ptyfry7poXY(EY#F|Hwktu1kq_O9E9mld1DT z6{Hds^u+w#W3oYZV_^z}ImBu0PKmaox(8g#kTL@MoVCDaxZnuVfJlH3IOO5IN@iP( z=*79(K=JyjIzKowlFv)ZYhz02ns`=@l#;ln_Yca_zx`g?uD{V!^-R^0H8=C~WI+I8 zf;o?5**rKRH$epbx$9W@>~7O&5^8RCy4|9e#zI&--PhG?##hy8bSSiy%Hx9Ma^=W6 zAPB~~|1Rd~o+rHJW0T=Nog z^dZ{Lq$U`u{X2-5M|(4|-hAAyB+gNYfUH7!a(qTRL1n4I#V=_5_8rwF>NUyg;O;sB z64pP9n%8@zS{Ihy((|l-_o^wXr>VFW(PPM_h}9vm-=xiu%>TKt>EXd>qF^%m!+Zfq zakAg6JYqwKJpnevdgaMG;mG!uY!Y}4yYvgBo!y=|&iExx-1o2k{BzPf1i;VDQ${)` zB7bBSQp?Us5>XmGOreo;*oAQ)8jYO6eU3u0Nly3KA&q0Xo=q5($o*y)6s#6Zi|5!| zk*vaL?CJEL$?4E~3{^yU8F|PNXne&1^SA7$X7hsT0j(YxEM~4&1d}Ucz!BGP3(FVz zl_6uM$mZTDaZA-+I*mjw%6ImZ`~>G7VC1q*)j9DbBVO~cG7eC7+^xVt0H69!8h3bs z@_|=mBJ7=Wqhx38%8|>h!e*;HE#=7Gg{ra`8GrP{;kqo7`8g>SdFbqlc>?B#@)>|v zgS9{|iw2v*nRQX0T`tpx7Ku~$**;_G#RG0ZE_P_8O|jOr+y8;t!v$6_`)W{J!5rBh zl`DHoS_LqxTV+gewX?cqca5Szz7Xjg#^ckF40WSR!-cr;AY`0qd*T&!ffLF$Bsph` z$s9ZxjE>upBP9bGb{EAVILbTel@XWt1DMG?oVDf8j%|8G_bv_y%KM{oN7VzE?CDLg zf7Dw2Z~?;7j{WWyTfv%L(vHumUkOGFQ3JYN*Xy59CdUgUp!pAI?G|s`yUR8&8(E9N zPL*n3HNV=!8HjW)t%S5A#xgLy?N!##Ip$f7dNKY1n!IgLg@b>vZm9SZC{4%r*S_a? zSxVm@c?;zm80bBrK0>uVALxNQ5+bL=Sea-FjT#*_?#s*BUlZY1TP$clq^?IEc1B67*4FA$`^LFq(Xw

7;X2kOK>d9d22aN3@DfJw&|WBWN;7!F*kjb!R4}7>t)RRy$dFt?fy#4ZNMxR zYEM?eg51T9TD(ko!o=g+PcWa2NVCBA-s(}Z=49Q!82enVx{M9?=E;HH36f-ez7FlN z9OF9?(`jb-j%f!97}U*U#f$l^L>hRRAuS%*n`{n?&hY{|HRB41kOgO&_bV2ox-_7x zv35?>flR~cBRHjI{#sBIhept-6Pj>n$WORk!>2zirDbf%XyL!RvUz|dZ%}qL{)l}V zmpWmKmou$fQpfL&xbaL2k!hi|YH0Pjt~YEXE)nIDO@+7Uh@uJd(Q2o+Y*IHLnQJ9l zA$oP!*ysJSgBLTDwGq4XNS1IppH0*(9Ad}ASl*al9S|v!>`oi}2_gKN9cl{N%laW* zFgO}+`;{mnlg^Zo=lkRkm>NIaj+Jxs8Ou^<)uu@_HKFR8TsmJK=rFObRi#*!uq*9n z5&I1E?%k$%+4CMN1b;7*|6ITmb$uq@YKlb>AW}v(4)B)il1z2osH<)M|Lg>xmO}fx zVZADZi5h=j8fF^({}YSKf1J^h3vxR_)%_-gzP7uzRM}LhAo%zFQ4cyiaQBY8z=eC zTX!C8x&_5oHllERpQ~vhQ%DUE@Qw3sM)ww5z`xeC)BiR>c`kW^F}Z`uH}lrce783B zC8b0&7-x&I2e^WeL(cM<)o%GQ?dAD%8*K+GYGic&DAxiRr@`|%0LWxmg5-9nP${}O zGEfXe9vW4~f`Ij5a^$xQ+uM?lQO&?r{sO_g6<%v)>a)V6Nzmx8S!Gt5IL4~H{H`qZ zthwrfyeOhF2y!HsXE^vkJPL5YQb97;bSSf=M9|81+Go>iZFofgB~MZ}Gtg8-U6sL% zcz_f1W?G3cisP)R!6Y!!FBI=U-YdF!xU!poj#F7gqR&M;A2|z&_$`J~%vujCih1@fCqFJg!YXa>GPY;{31ZwUB;&WwQ>}Q^EeEWpufqAh?H? z;NeIl^?}z>QGEpR%o6yo^D^q~$yQgm$jn{07_WQp8K>ez0>5B*t_i|3f;~Mj!5-uj z{snRSOTSW_-q)C|1WUIOvFgV)E#g1|Enhl5bv$(D<3}^eGbp)1?_NvppP!2k#Bhpn z$xtaq>dNPWpA6bFD;zv$eWNOPO-f07bdVE(B?XBdQ#y9r!gI3@lfi2vkn=zlg9TYy z^Q6~&ujEtAX3e@-zc}0d3zoB9lyOF$sgu6LC*n;>(uS|gUBpy%-s8ZI zGz#jcfaf1D4`WMS-RqG8hL7p&*VRt*p-urd`VL+o=0F9K7FV%iB{|*G4Z%Ca5uUb} z#+9&8!fmmi6IE8s%XGH}Dwg=wcg-q(iP0USMOk|A?LAHFDG5kw(U0sHkUk$f)dFtG zZg+e9*Nf&-L1G+*y=!DM482ANKe9o?nBlR{e0K(FE#+MUU-?p19g4fz3c7q~Z=JRQ zjfap^;U5?5Und@Cwjs;n8&5>#MSxELxs&r0 zDr$#C5PVHCd@oQqvWw7%gNQbg>{EhM(?&gseg1}zbF{K|=lln(m?wOcG8Y;*M2WU& z=ek0$$<~SuL9HI2f;aLsEznvoJ;NHVP$JPo%?eV6YH7Vl<4*hR))Y=(4#}vn39_tf zHS=bRD05=xO^HmD^|MW#H%%RR%)^>#PRbonJ#HKPa{q@O0L&P4;dMHIuN$XJA6tpK zeFE%TGT)Hz;Y9yE4|YpFKA}#R6AR9U!Q)xIg_vC#wH)|y10mmSm`$8+lr-iLfsBg% z)BwIWFpzx50rxI%ubo7f`Q=Oe`~)|fK2D#nd3}MrAqob*t1)EX(5A9}$8jUqkMj5p1(SmPDL$M9cbwVX-_1^Vs zOsIaaWE*p4i3E`;3AyVnlW3jswjP*;cFwEr%kkvdkglK2H3#<|qpAI_YGa733z&wp zVg~{DLSUIhI1)T>(o&R-{N79OkzC;3lDV8@%$3H{_F*&R{Y+a!8o5<-C=l$z(V)n& zU*{0);Ohe&5mg1LsoU_YsO+~?y8KtXd8#yohe;B2(3cW^xwN~mKWj^WK3(DCF3F_n zU3`6q3iVOBMPUdcy`kzjNl!yGTJG&bSx|Js9^RfS?|YK!^6DnH z?1yf|cHd(CKBD9l`tng7o6TQBz_Zc4w3AS+YioStZ! zisaVjsD1#mS6;~*U-e$wG1!@6a5ND)GesTS^G*F|P$={vxjf?8yLfGhPkS@~@iQJao*U~0W1bpEicbw-dn`YE3< zd6jcE`{MifX;l@`0@)@B&}6f;b9gVKDR!hCzN6RgB#z+*td@iosXGL?+qF&0)G%pz z@TKKhPDHy}8ZUNRV^%7I_%{sqXt{Gq^WzV zaI>`Y34+kjJzy*ECDy7BHlaVuL%zp27$uC=+sM6G)3 z7ob&CQBDBp?G#Gcxl=9-^N-nrTK%FBKUdf-xk#8x!Wa5?5kE|8K|~pCEr5S{2P-eaK!ZpQe?5Ax=Qmu9nTLbMYn+Ln zreJW_Up>sfu&sulUxS7%fSMAMu_Swe4z)E+A_%(BV?cDGXtTNVyaCF-w$;DKg~9iG zkhLY=y?$n?WN^lX7y@qeVBsiX06lbpz+QN1dBk`;Q(EmkQkCE58gziKRt99Ds?wl5 zou<4<2h*3-Hsh_BW=>tee6d3@hDflTCB2EhJXF!Yo%F9x1I=!q%vB377uK#IY+JR| zPUTKu-cDo+i~z^?orj80#D--AKzyJ07l3~9rv{{tA5)0VQmGoX=f`Vn`1N<7Tij$9 zSEXGrNOQr=8QgB&KFbVaK?hqn9R{$qmmGPRXzA+Z1MKY+49gPzSLyP#?2X zlZhIo!atL21?h~wJ1*@#>F{BUiwRf=Q~mv4pYj1_B# zD86P8HAyM&YPK-Nm@AvDu2=5j0_=1zf{3Ojz)dKI%nucXCnfay~BZA4S6MBuFaCw^iU06&V zH2fjl9SdJ#vwGaXJ3~;`nuKUqNJ{cSG0nHnpshFytSJoiTsFT#ghuP?hJ5Z?CH!`D zlC2dmR4^7|>he%qaVWG#!@EjuQicZ^eT-N*%9PNZ#cJN9)`B{oI@#2E4lIdYw%I9> zF^8rYjMhVrqu9a=Zh;2S^pvGCtefoVURt(2Gf=5eW?tDqDzdD2d8-7I(PRTB8tCv^ zPmk8%fWh$)tE>>bP;4`UBq1qBi0?_w(^1j&h$ceu<5JVf0Lv7~#p`dMWbPw5qdIdg zynKn)UYtb)-I=9>`yGO7^l=WqavQVx{Tc+$P%)H}w8F&bGqjZ074=ok;|`pA(0j>x ze7l}Or2<0cK#ja_oJ`Lr?4x>|3_34O6*kdgKZfSRsESY{6nRGN3sWqBnhW0<4Y`Eq z8aO!?gb57V%X5h2lMn*F;}Un(P{Q8Fd_vF-$B#X^xLY)(y)LLbOPPj=5x&7cpQT8( zo2Cvv#R4YFKbD9hAWLvpf0M!?0=4^`hX>->)lX}aVQA`PCcBF(2XJ_%3LN%E_$-cl zBi9+3kY1I;?YhBpy&F|L(TrpR=r_0oILnxh4qf27KV~m*5eXCGl+0?OqnJ`*bS0O~ z*e$*Z0U~@<4Sg{p%XRX|_K;A?Kb0o(bT=XfYHcRN;L|D?m1 z9Bp&+&I?77YpXe@LH1zr1!D=W+m85bddg7jE8&7F5VWJcsfEUefXy3m+X0WFJ#pCA zC2|vM-aqPP1WUE~(KK1B+0G(r_!Q!AZ%c{^H?SIG4^0@)s`4Z1C65)GZYu`pD(R7! zt2PK^NJgx!J*4t*4IG(KFJ#(-BEx)S3J}Ib^(w9yuGo<9+hWg!;y#Ewaq?xctYb<8 zF*1ggb4n5dvs#&~m&PPKEyY;jE}W5mfwPimY2!Cn z_B6E+=VAt{{wvP=KF$~=nyduo^JHXOsWYv=AFPtiF2Mkz%25s>Z`|ZhQryR9Jp2^c zCaAxx;*j4;psR!IXymW+CNv5)d#k4ts(VpO z1{H7wfq~}m^^m-6$#AY7Bm_@>T&^0S`lKD@e?x${|H##)8bn zU*Gf_%JTSBbWkYA3G)x&M_5~K?beBfuW39sF}P!~GZ;Sik~^lpku+Ui@H)p1gAMO( zB+aYfIW+BoiE?&l-jAr%EP?3A>UYs2y-=uTC3WY1Y>~jg)IJF?fAtRai(Y37Y*U6TONoM&SOhsL zfuEa*02C{iV`%}Ql`ODe#Eg#r!0(PC8<2r{NhePVk2A^Q=O>!O!V*{t*XeQb1dmjX zaT@gLiT|tDz?>!8gS^>3nGPH!_sAyGi+O54qT8JIL=2C+N?k7^Ygu(?!iyNz2gPIz z$yI7f_aZAc{trgJ=&`u5AXO_M-KIYwEbR5?+rlzq6c)T1+tOhCD)qBiTvAYMN}BZL ze?V}$>OSf5%;yY64V+Ev%Xxlu@Px4?w>|I$Q5io5DIf9{CRq?Ojw!48&kN6xUp}$S zhRVH7TbB8B0dfB2+hw2@Oew@cdvW-yb}8QN!c`MPs!^qci>0S>RmML4Z$#F#5-w4ta%`Pj_eMBmRyyFWZ8XzxgUNS>Nx`~|FFXF@5&VA`j zRvWXzo~RDS2I{sdRuhtQbhy%cjKkDzF|fC=>0XLr_sj4zHe{9eIf$to>FVq^x?X9e zd(aI;#w{cdN05w&c7qBOQ8gFz@AX|x&>zSP=L0t0-FY*)L zm0*pRv1D0S=tZ<-ioybftJ^xF);&cUQe&M^NY#kMq#kNlx|kFlYutKGF4ZMfbQ3ZwtYS)iC>#{DUy*7VzcfrOi?hU;X)>W z^r1X3DLIF30tJ|eZmFtvuU8bSUfZKIU(dpe#9>DM_B49Q zm=jGNMe9UmPRQ;mL<*dN9KTS(SO2Lv&4m|BB}c(yXNEd#WI-Z9|Pnax4a0PLj&=4%u($c+H7ZR>5=+A&ddm@;d9m9 zltMLO^BaEFArKL{Uv+nw+{4;zGoMiYh9u&FAEO+`aSbf+;x_Rg^96yr9TvN;Rf!%Y zI*X2O@#6}k&QoW!uPSma;C9@&b+*fZ*$fn;UBZ|R01UmJYDb1)uTPi~#F*}q>~}z_ z94M6ryoDd98?8T#8SZ64^6bR%;)tbif+uz5^wLr~6aH!thP1EunMCppB18*~y$**) zZ>6;aw&*(IJv3GU8Tn_LoSA+$X_4oMIG`)1LXQ=F^;^!^d>t4Sh}*mt_xbv_qq_c%E;r1)7_*74OJB>q{7XvG|c;d`T!YaGS3+3)! z?6RfaK%175cxgMz18@!&YnTy?Pm_Ls) z(xkDOZPsfvcouod-ad%BDz@EZ3qs2q0;S5|I&mD`DpwH*;0*_=#(wgsvlTzO)|{Fa zVMTgprDB$W>Yf)}cSKvVcsbWPQD1tC1*d0~+<`EBk&Y}zn|*5IjA9}!AFX!2&nHF9 z2p+kI#cP@Dg{nv=Y7na??LV8fv+ynW!0*3R&ILKT_|5z^ETd7L) ztLl8gJzy-7!uuq^?K<-~zx%{_8HuEBUjCJA+55&rhr*)HmWr-BnMgZQCVjZNdM!5eP&I7KgZ#;1WTUz%|P=}Z% z5=*q-JZ^LczJ%FvQFbULdQ%0{ei2^GB;LrccbP+Ej$=8zhvD8yRM*!I<0LsN)bG)A z`rtO5-4l6*bV9`_T09!OzId1K5W@;M4a?aCflY<(!q6YIFgD8ZwZ2$OWqXZ#|2Ubu zjP)EgxgDsJmDqjiGKmZ$&E)BK$m6IdR-pM}|F*BQn&P^{1@Jtj=|x@1W^C2t+n+^z z1RI8(N=JdG=2$MPBl-Dt(C2a_lUo6BuP(FRFB$yOCwH#OYiw|yh~?EJjOxFbwt4l^ z0*3khbUWh>xt0c%IG163V82e(grv1Wxa@YNNYSdGtJJ^XRq{awgKx)F~ z`=Ku}&BFJ<)efuW+v0l|&hx$}&&WW+DZMG|vV&9JlGThV_}kWR-4fLej>eyLdL77i z#6x=1FMwAt+MyATa8o<7(k1S^kfGG81_`l&=NPDoyj) zsKheSH}>L__si&zU2Ya8(w~CUwk#S@6TRu5i)*sN8sKcTvrCvq$g($^W~}#= z$Fan}^(ESB%%$I6D6a?#NKX?T-dH1X^BW*r?)_!iVuz2M*oDIix8c$!l zp7ruKw9`2K+|!&VU3*Ray2-TYdBe}*3?R%*4=A)X;Z5wYf*258iLy~Q8#`kzp;snZWV~Q#hd*yh1TumfN4O{FU~W*|Sh@sDE75hja6OUAXxCiHM`b!gaUuxHWBDv}RD z21-Z>*8CYyCI{SGdW4L{56k)1snR)mQg_?uVa1rnIf4ZVw%hGC#&`~EO>b1uD1Iwi zp`28|6b4H`NS1@Q>g|u}rEk2!`xh7GM`e?|)Umt{UfO9tI3Aigb79_ieqUz_Cj<4R z$xLyUHBrP5EDS!`)64$kyS&b}HTN`r*sI{$_X&<74*|7@liF#shGfZFANsiH$@i)| z{#&Hu_Ad?}E(6%@PD&-hTp3w|7p>NEz*Mv`oy66xrY*931E*GLZSoPdMq6ifm)n5~ zPP3MCLwf0552sGLPvXa2v3@u<@Cq4P?QSZ?yL=~;;H@F~+GZM6AO+OqR3xFDx&^%;3YicDi`%7DQ^7^YWebH;d~}EtS#OGdZh8Jhw8n6A z*eZb7wm^M@8q&*YjqvCRb&*bid#`=+x(eNOE>#Xh29mZNHqEV0M>;sjN9_UA>`%Y0 z^%l?NaK+#jPTd5{hQ3d?+IYIZda`fbgKkM9;MHf<2OGxlE7tEVN#4lx^HUi&k9z4e zeMQ24g%X<-6ZVn}r-=2W26Ju+>Q)v`;MCz~1^U>EcT5+So!0EWgdT;@s9zRIM$wYJ zKre|^Iq4GRIz%`;(KrR}b2~SXTMr~S?W0vphpJ3!X+=JKgh$F4aL8RR`aV+>*?FTW zeiv(ADdZb~GaU)dpzCJ&jMBuuh#SX9L8Io>$5~gH45Am`_IPw9DgQCav02B;@g>O< zr%h7unV?NWQ7j@JH=jEo1R5fSasyWI_!N54u;-(n2_l=s`FLEK4Lja+GK{kUPfYQW z8y`QW@~-9@Il?J4l`E!yH8 z70{FDGtF%EQ*$NnnVc}tCOy(4BW#PS##GiloHt|avGM1!F{GhC&ZY!%FELN7Gz{TY z5ogRiE3OEa zr9qV{7|5pv`ky{!SYIlqbbDw{i7k+gw5n@iVZaFLGWe4AIr)QluP#wz{HWzD81Tbc zIsJ99W}2^}h8TG)E_YLZ%-y;ici z8+0Sg1xda?f_03mI&OO#C9FMYo6ZH)Q)A3Vw1~o41u3rcr$NjcQU`xWYUQFLIfo9B zEw^M8>{*svm~AYE@;8?N))kRrPT;~LyNE#c5|#0`A@buHFt~_n)FCK2G^-EF?L;ojgUVcMqyT0D z0edL!o3WuOoDCE;{KncNAkr_EQ;a1AZ+(3~{1NjkuPI~%@J7>AjamgqyvAg{TWy0i zxp-PbLD;O074DzfSqy+ZjiUx`RNxmPJB1<5?nzyd1m4993vzsM;H`J5v#mDMz+x^W zoapS3!?$hr*k4Ykl}dVf9;ayvmjQ*Cu0k=UA7^Strbrh9a_l$|(OhcoRj zVD$kUHI7b>gGLmKYblv6b(PZz=HAdMrSlbmBj#*5Sh*2AVY^gYQ_6)Aj@SGg zA+{Z0N-L1}uaqOlgS0EBP99;?FgA$>KmrLABi>$-gIc}S&-ss)l?7@ukoF*Xlu`N< zUz&%%WOvA_J1TKWO^k@Xdj-Ud@c4GmEc= ztph@Lk65sSD5Zu|<%*~4iH3K|&CTgi$Z?U(0h!>4=pm?tMyZohs2WK3TWR+9`xB z!yjyp?u3;8`p($o55W7{6B;JT6|siFp?b;r`HS=uc_od^(PyaC?Lw#lx#%a7u$%jZ zok@sHyYt3iby&;b_AX4)@fv$2gkJMSb{@G|TJvHkiWydJagB{SX+4lQQG>jxo+z;@Hl z3Rs-SGf8UBPgZj=mrr`r=FB-iLWr@49@@w2Ms?SvWLLPvIsz{e;M)4ZKD~|dW3#fi&D&3ohToj#L;n_3g<xq{Fq~?w^nT7IR0R=WN&JM7Gr;#AqUa# z17R(sOB0!PJ~@TPmm3y90b>S)up@D^yn@5}8v83}yPA~g&=iCgml$SVspjyc#r)~E z{2XaAdd1t6NVc3Mg}t?_^2L`UDQEPdheQc7eJ{c%Kj!#6Jd4R6*?y%!`bTL0`s9jX zA%<|eQsorT+2L_ucD+W?foyIC0<~$V3|65$+Tf;yK=pOegkqYBjDgWIMSw1DeEAM* zHzz?|AW0NBxC`IIKpA7sW)5*edoU8+nx^jC`ijklv9!%(C-VVepjZ3eW+JIF2D|T6 zXENvc{8OI7BR#e#)imqUuAlw5TIwY@vCFWqRC!p(VUmQ<*~KfkT7m=KV%W(1Wlmn$ zmx;8rfY7Qeg`IHvo%MdE6Y@-$@X@*9`}UUSEzs4?(`*#YFPO`fX|W3Oo9mnn&wXZf z!Q?7uJ)tYj01jEePGV^4{42%ecRjB;#Rhd_oNizDx!Px~>DcwO$F?|fadWXbU834s zu@T_dfr{2#Z%Ix@Y$<09Qha8>Mmsp3nXP!(O1lElcm3M&f^ynveBwz>A?1c74l+(V z&+$_`k}AyWOYe4K;$IqdA)h*tQ7a21C1JZogkGy?WjF*ebc8o1MJSyH4RxU!02>dB#kB)rWTXM}y)`$aQe5v)n*A@?KV1y=AHQTHmd3jvlM3S&D=v%R!4Y=myqC*fPsxI2)l@DPTc@N0gZ7jx=h;KL8a zOM7;{1<^Rj467lWs69O^hPpM?syG4*JbGUB8l$Z>#H6PU>hLdL%07;G#@vwHF3|0~ z4yHto1oQaJdJtHs*=29(^s*A!<7H0>&$icg)$D6OrziiqyR#MA>}+PAg0UaNu6?EV zUBDV7D%9YJG%%QlRqm!ETe#@V0CH8I?az&(N)q91FJ^aQpa;MxriYEHi8wA9%O%jo zX-HWwboF!1a!AV?|Kc^vP|uo{G`!5w$2XeZBT&Z0{|L3`A6}K!%tj@`cgQH&uRx<0 zz$k**XlR#MdWm-q;e><4tvVLD5zoJ&Gd1vM7xdnH4nU@d)SGR5e%DswWd>su>P$fL-Oaf`OGj zD7SEZ6v-896iYf4=@wP9ml#D}vR(?YHNvWlxLGRnY%o2wCRjc z<8)~`aat*pvCY%FqaS5O#KT?RRp<`4Q)q}T3^mPrwHKOtQws$AKTiAh+}`frhs0Ax z-RD;x1SBS8%^*1-N$xgmI;C3^idZSKn`(3wiN{A0-Qg&Q{s4V(bOfAUeEKCjMT-ItPY z4DI6CF#xw8u@|P6jl?E#D!_i&iyG?+ZyhE&N+u`lc28_c291L2)2A9{uWtn)>eSQ7 z9@gQ+)0VJuRE+7AfSP9dzKhYOS;`k`pU~j7mPbC&ewtz4>a1OBgh>M72&Dt)^z-Cd z|ImKVVYz=~+GemKp1`egk3}kMmjCoU_HJw+_11Gp*Vs#=bq?(?_ zTQeH9gl2#-vbdSQ>zb)IM(XokQ&~ebwA`0Tn`Bq3*Q?T={lSkX1y9QTTnd{RGok$8 zw(%5UqZ{MFj7Q-&+!yzOiGJ{Fi#}eUtQ}v_H6kF+;f`QL?EC8bQWrAIYaoj-10SX+4v?4`b-*6$ z&%VklC*px;u3$3@S$q>Dfz-)68^a4o?;^Y(MM4=RQ8 zlkPQ!cU?1Ug4hg0g67MgJ*v}8a@D~S2Ha?jKZ5LrQSgGjk+A+st;m*|57#!2D5K7% zV<79zS`kH#{1}1n7*Eyho_#XF@jcr?Ua!r)E}m&1i4nS2p<0yqh}k4*Dz!raeY%1_ zi#P{d1f()1voN0la{iRem~myYK8ut=rH9B+X4`sdc2}CrEvRb&O?38A)&xieGpm&M zO~5jg$G2TeU)~`Sa6JI0AAK!ZK?{B{bf`Gs7l^w_yd|luSEVJ=5>B<}0~eq5zOVIN z*@C4nWEpRwFSuHn0s$Pl*@ZfkKk$rVx+pCY%dHDN+na*>>Ka;#^)I@AzJCjI3>buq zcN(jkDe13T(ugqO;eA!H&0yVt%l?rl#ipL64Gh98N zhg)!t<{FFbcPUbUdwjJ+qq*PCyh#UTk{=%(+ZgP+?bRunPQR@QMRYT_f#y~Xe0AiH z%a^)xK3#lt@9AIK5HRiW--e{$wq;;p3^)(dC& zEI&|xoFR7_WT!P zNsYROB2hpO(_s-0mFcn;2ZG)Z-b7$ceQbZX;%}r)V@5Fkl-&+q!6`c)w(4i)$`rRc zN03j1ndXuyTSZd25f#sW}tC_=Z6yicO@>V zNZFRy+q zfbZvmS{>0~lk$UIS65W`k&ZCu;Oo=d#`G&~6M5her}EOEA2x66Adrre+h$wgRGimOu+}Jy%G|vVMxyt$ul6mGy7G9Mv z=Cz-WHq*4RetLOk)&Wop#AT3ksu7k86*h~(3;QKSj|K-CxdSVW8l88}4+Kz{H!*D4 z$!Ud#_DKaI#W!KQ)`2Nd#kXWGC~R>~%B#cDx@w|+igtRrirk8WcLA}y+9e8-;oXLcwbF^j=haaHGZa@GXe)=Ih3`erOPy!&&=zH3;sN50#v`&^|;I7uc{J#VE9t)VThXh5+TeTO8Cp zWhOT5J4P3b-f7P_nn0LVSotoV(UkY8r07NUsY8@!7!{Y49E=4Wj{bIvfP#x9W(osY zNy{AGj<=-Tc&S|lMJhs@IkRs998!Ydp<_%PL)U(!2G)wshWPtWWd)FR$hKNO?b_sE zdMkWPFzT6=5OXBYB7~XzW6wIa6%e$7UBc`s`~_0U1JwsTCEOC7GjFZqg4|lceG#eZ zFcnqAZFsQ{FzmLs`%f&?LX-j<;0-Ia-kVJKnzB*YQow+N}CU{V|t z6SHX5xr@nH>%d3&0`q*zdVV4`|DY4qcRp!S%bI62caH#mwo z{2PIxlY5R%RgA}4rZh`Uz>SQb^9y7I1pR{_qUE!Xe76IgiUi%!eY;Ep>AF2rYwb3z zZi?soOF)unZ;t$xcPv~#kOK)GAvy!cd+9k?-9Pppvf6KbG0yI&- z`Jj(9=!Npb8Mih7K*3zQ zssR%tnH0#;`D0dQALKNe%S?Yo^gIwBQFL;RyA!M~;c=M4PT@Cw7Z8=-7u4$%5F)PC z?06_8*Kw}hChzWl#%1|Fml^ELAP?RVn~Sd5tUC{0ivp%X2##78Get{Y47qgTt-xSe z!k+;N_C6CoDVe_*P=&0&>`H{V&)L(%=k~CRoVTl~CY0aLAPMde3$6dxv;zjr9BffcK9q!cWkOHCs@q%|gvZ4dSRiA0o%iDBHU z?=mNESyNn$Dw*hIFU_Zh{j(pn5pD-|-rp^;Eq_K#+s(8xTRd_{4XFpXC=Qth9r?1` zRiG6nVnkuHBH3;bifA0?X1*I|Q9Ei@(1-ZT(+e&BhS8!VI3)!^G;IX0__qq;6~i~c z(YFk36TT1x?v@w!!U3$aF)wcY?ZTMfF2``my;d-seQq~-{EZGR>9WZ2dV((xuwF^` zEgF{4s4OsN^556GL+IOTZf8oUIck#Xx>S?`AOOk#PhF;*VU{i)q6|*$i%2#E^8-hk zU7JFYbkMKEL0W0a52ptgO^|TW*agW{k-aV*1U5~4^|Fd`%9gb{n(7l7ocIv~Kn1Xf z2T^$=0(qXg`^2igp;hCQnZ>D2x^iQN-M*$|tzNa6zgk;pr7+NJ8}+*Q1(5?UB42*^ zFKs-cWfzGpIm?JR5YyD7)3BX%EzdL@pX&1p&<8CxFbdf|%8R(NgFudkzm-k0^5RkI z_U)+CrU~ILMrS1#n$Yhqw!tTm%;*9UPFgnc#aSOvJ;&9yxu=sPlbfhk4Fk|p^2k7y zaOptmTN?3>L@V}8a~*3N-Re4Qf$kH!vTL@G&@@uQ;?hv<&%fi4HOBdB?*WxJSKM9i z5V-jFoxvd&37jiCZ|K0l_@iSS#9k6Ka1i7QP96SC#6zGnutEY90; zNs94v7h zUsaEor)B@#s@PyA0!xcW6*(}vwRENJHnzc~f=&<+uE#lRfo?4m;8rIwh%Q8MNqSbs z7hH^uL?asu;8ex=%;(eR)$!?$P=KD9#iPh z&5Caot{$G)MPD^#hj`?BPl+)jgWz%&`{N8}_>#Ynhi=e7$ySWQ??`H04di(wq$B(H zLKsz7dp%hwH7@;1Pcr#~vWkYFP&mN%QwUfjn&&uDs=V=3A!COh+`=Cv74?B0R0!u` z*+U5i3z1jFI`u}mBut3H&ILz-VD1HUG$MmO9-2c^#aN2dxrXMNv;puG5*ik#{sJC+ z$_y6$`UFF=en>> zfkhO>H#2q0^L?6S53Y_D}>6SA|wh4u67a#76g!uTF2tgMb^%zlS-n=kBlyU7D(~Jcv zTL%1xsqj$o^NhdV0on5OMCPb^1c6p-BN}+`;5s90b8DqaF~1zoBij56(yf@%%I3M% z+9^vdIk3)}>N){~DJZR7slGY^nE5y?>!DL(vN7&@P6_6a(>{C6%a!#t;VCCKM_~Xc z218OVw1A?-yZmTPRKHQROFG%q_Dav9{}XX5P5sWie?p%U5fdg}l-UDNJmf5k09Dv< z=6mjY6uxq}vDK%KT9`_^?j5W|m#oKDeP+a^QG&w#bOX9k(1nA+)Csi&Q9}wM{ql-d zIb53?6XYc2{(g$vJV%@R`l9!9X4_vtVD(-o!teWMzOj8Yz>vPJDs?W^Bg4iJcJQk; z+k>C^uNNoNdv!@pQYEeZ5aoiqaiN3F>Xr|GAE6(t<~wQ1ojsufdW4j2X#fKO15#Rd zLi^pDnQtK{(^eC2R0CV0jdI_~t5dJ+StcZ4s-{`@Ym%{B!m{vpDa_@W#|#P8!BS)^V5|sz z;Xs0ugvo47RPjQ(ChvBfyqUdHwWGG?%B0PpHy!1P!Yjzf$24YSo9{n0CKi@!<$A_f zdn7?SrLvFqOke%CexzHw@(mSIdD!P8mgHf%-fbB!>BR0w7HB?g*U+T3DTA2T!a}sul zr6P*-r|@_)ULpN@7kQ6K4m+|fz*s{_$nU(uwu~sX#M0n%TMg-B6#W{(47cUtF>)T- z#&MfbXirS;^5=`&3A9&dL!o^5!;#>;+NOjM&uYVAvZm(G?xv1FicmVL32JP}QML3}ih;45-_v(5*raf2gOzCk zU=cc8ue@1U>Kh$dE?0tVda`<7!N@dr_*RhsL5+;cs>pIYKNPy$re$RW#Os~2u;e6v z(<;*)tMUs0vha+LFN}*qjg&>rHdj;{8n|%hGun4Znq@O*h{TC5iCzCBPeauCg|nLd zoCp79KqyAbkw~V$y9Gu=ek+!`6v5AvRvX~*bb2!%}HK34RSn0zv>(cy5hQg&obH7Kg1_EneB$Q0BI*DrCk&x z{bw}vOsE!nR)vOvU&h8PIl;>1}JmsE=FI;*yowrfi-qU-=2!u2&e* z^#Uj{@XukzUB!}`tp!!NKj>dZ4<6Asws7HcS3+zz>e|+T=d^f*Lz{k7bJXDfTxUdd zs{*RONzyFMpd@$1Ymu5i&^3wFARp7g{%x#eWj5f0vRm9$4s&O#=hpo}O5Ka*afosa z#0X{`IKEpYTIPhP`A9Y)6rxcs)0NOLLZ|QecDt%Uv;4z*0+V! z-PTjoB`LqBMz2IVr^HiGZ(@HIR2w|;;Ot#4!wb%_F364JS5?gm;4VYR4^Zsu{3rvR z>GAug)`+haOSjIn?ui73aa|!YM}FP=C44?XmWHvp=?%^RZdUkP$iSs$;a3@49efiH zG4%Q6i4g2a+FuI3qgu!1rmm-rx^S&8Gm3x;UCJ&axBBM$$jJBqYrGGeGM}f#SlW+l zL^XgKEtk}AwOHOI2%qz%F=)^ADNmFUtkv`Gj~$cmsWyF$IR(Rn)G3mhlKbm>UDeAZ zB#jr$|3RhOBmO*+Z$GLdAJf8t2=t2I7@{hQtu=u1cfxz)B_ZSTE>JSwVmmrSfF(F! zp7OQ6?wDk13sZg5Gn>U3JQa3Ak^?Xxr4D|innVU1O(~oevS_BsObG@I$=HI5RZBtTS=`c8Jib(zTa<3q z=LWGC`Ve2xBM>ht2_oVfX~j`oEOruK3}Q^Els!hrvAWxQ5ti5z)fz0gXL3nVD$67- zW0<@dlwQ|Q-r^M4tiDXgKh`hZhhTkgN?yzC~K6OSw9{D7J9Yn9mIG zgrrF&=yB~~)zacYkc z`Cr)jM7O>>hgU~i1~P^%Un;A=c+*|+{@E4$S0WZM%hSCs`77!N{ z(jC1q3#+$|O-8T;25i=Kq-6?aZe(+Ga%Ev{3T19&Z(?c+GBGe9Fd%PYY6?6&3NK7$ zZfA68F(5HDGd2n@Ol59obZ9alH#Rvk3NK7$ZfA68GaxVuFHB`_XLM*FI5#peARr(h zARr1aMrmwxWpW@dMr>hpWkh9TZ)9Z(K0XR_baG{3Z3=kWjkX0;lxr6@Od}!PAw!qI z&>_-DNVgy{%nUHZ3=RVf-6`FjA_&r50@551>5>)%Md?)JL(h57dC&X*Ykl9EwPv1u z?YQ@~?`uD6I9c@!1r#9&Tj(PM93>zu2$TURYa0lQ0DwSIK_F0skdxC0hH{4f1ru_b zK#^`R1YG970+f+Z5b73F0ikZ=v=MNCrn@shSQH>EAtNj)0|Wv@fI#X01R{_!02Po2 z3qZnqika0nC$xIG+TsG$YWb%nzJ z4A%NH;6C85*#LwEh5s)1SN5+$F!=9e5EzVbaRtG>U~qeY9n2XD(0!yOh(e?813+-d zuRxHq8{#$}N6JW|vLfNlx?Mb8b4gt?;J1l?fHzbFd*Dsww!RX9W$ z;o<^?qudC8^``=Q2=ou5GW}v27o>TK+#|apwZ!aGSLjx>;x7rg10Dpb{ zezLrk7X$%!_WCFM_x%d#nCqFVKjQzB@!virB?KDaBOodU5D*a;21rXu0VKtN0Kb1% z(F4K$>H_#rss`K+0g(Q)+1n}or(uu3?w{wc-QWfMyOs{(R!Xgj9Y(zb)xo%l02j8XyGz+Y%GIwQlzf z^fw}Wt4AT|-=??-K*$c^j{GnGZ2^~m{E`46_${e_D&D#g|78mc-yZQ#`YmN4lqce! z@Z09Rp~ydhe+>cbjzr$R27b%*c0&KLf4_5}P&5=wxG;+VKL~ZK3+=e5QDpQK*n0PH zigU{}gIB<30omz(MS`EoTb&cUiab+H9ezvpVN;doRAG_j+UHAa1AatXvVQw_-yhbA z1`}KDg!Aud2F71}QLOK0CSVdUQrPyre&%ZuUd*`>)@@XTF`M6ZbQ!n02eUEg26 zG#Wm;rN3P*@tEjG`J_Osam>@8(rL~@+uRvCHawI7^Bq2l12pOM>Dd%T{`d`xW+FeK z-(IX}iI4f3NZjR&_ws8a5w~u74tjGsX6#dn(FraerJXcQ+Bu)Hl2znr`V39y*t$!K zu=5U&_m+;q1#kxhKHU`2%AdddCY2?dXh^iYZ9JV?!gDmRkX&DWUH;)ecdG3 zjjpp~y|@99^j6PRe!ce&J`Z)B8DE5f19fUW3%pl6f*CWvo{J>1c*}n9M=b5i(?Rg^ z$TC%9i!_OiDsyXR;D&upooCSQvJva>2lSA}^r5ErWTeOLCZ99a!3j7UG0?R=<_2-0 zx57;2Y-|jExKq=Xny*5{&-k3CK9|}3OuCg3mm!utH7Bc}RkTr$XwcfSZtDvXZ+7)g zd%q{)MP&cyO{#L^@*BnK$^xkz@)rc^`0;U<%~%oZW9~F+@7HBiRwyFYH6!DG@`M*1 zn^wL(9(!}VZ&@q=loc$uH&h}e)^SduG|$sb(Au9Wj1y>it#vyzkFCuxRBv9f4Nq=r3t?`u#t-&3bpg2JD7Kb-?I}hab>; znGfroqFQh^i?C?qZffU0xPH1P9As!xgXtGPDD$#=r5tn&0Xp=}`2+;Wy5P--czzwt zPrC}I4zm{@@W&2L8`{SpybNJtlvWFN2#oO`|9U*lD=TU^L3cL{(p7<_*^4ntt99=g z-}BQhPR6iJSx;`^0=J-JD;*V&;-;89vK&FRz6L{h2iko9+lwR`@2TwXg1LszleJG+ zc*B=uhnr)*d0gvFIRvuH3Tv?IT5q{6zi96pdUS5@UemkzmBx0>afu&=7k+V*oK$%5 z{cgUCUIj0j`)V_uOGLuQ#?@}tfi#NteEbI)ek=^<+WwGPyJGxlyAJ;AW0J#rwelue zWs|h%$!s&|H!!0s?B&Q~;+{;>-E_$hZ{_tfxM;G)u=>pVrg_tUzTjtwa?$VOrj(Xg zpVyGYD*{PvajWEDO|Y?;0gDeuTCy(rKaWF}EtPiDs3z~q4<^}{g1nmc6<^j(Sbc0R zx50})m8QuO7uHU7pX5W%a^0VdiXtr%3fgt!JQ10k@r)9PX6u@4W;4x)|MGta~QcyRxa77gMj8 z&ztuyqawnhj{vXzHB}a~aa8ZaYh17WSUT}jYS)y57K41_^Ohq@u0dc&TN!0SFn5~3 zTK20tDazCdl*WxBns2n2W1aPbJ&OT0oqC`l22;fYgB}x%uf}VEd-AN#FJrYAUQdYF zQ|j(42~vd_^+_hvT{U@*CkOD#w_=wl-&rk4GqI(TwAygW&U3$3g7YF zg;+JF?w2pt7JRdlrhD&28o#&!k5#P}?T`$YIZp?yCreB^WJ%y!5Qr?SHonhKxW{6? z=3#u2wc*^M=gY}!GT1`ma?mzck;_a$@sO(nMEL17&534QuUkf_HFNQ3T~a2lS6sjX zgRhT4a8ay8UqjwVx>9<)q@%_;1AY)~MBq?{NIJuHJ%}pmM=2-qO@@M`7?Hva2K8q# zo+PFY!H1aN0AnmRd6N#@uCFII`O&E!V`hHgb@I$yJzT(u1v<;u{O6@)P*D zTEz}s=aC!e*dOcSQ0#jJ@m3C`*-i?FhSsBTTP(`XR#teUev3^4&!iRFCRU+0D+CI) z?LS}Q7c~1udum4`lfhKdt9sNtAM<3Lq}uVTAEcH`4yp?!7dMNg8!W2RwTr*0oC?I7 z-7;>Zp1c2u$#;zJLr6?0Hs$MR5X+Wp6bW63jv?`T3s#JsQ*$U`mqufr*tTukwsT_J zwr$(CofF%(Z9AFV%+yTPcQF^;Rr?2Yb@zVP^Q;<4?QxKjYM&T@opeVuS!#~LY5UTQ zC$3KMm%0oxsP)@ZlNZ+#)~x$KMemA}WH}ZE&y)Uqcuw#FlDC???6LR|!|0kKHQ|ZT zE3tB0og}P`Nv64ujE{T_oJXwe;TT4CS%afulTb{SsRLh4KEn@&*u)d3-&V+&%^YeF zZ_LSjD6JyV0zA~qh`){065@yz!k@p1q{4kjvl7wl41NZNf4Jg>`MH9=)SdSLbYGpJ zwU=s;pXSZMu~22JrY3s~4i^J=HJDAwSuETyld{~3Vl5x)_I5W}kZ#eSM4|c{P z$HS8HP+`%!+R*Wg8$8BycnsIb-ZU4!#pOLC21Box-UF#c@IS{{%O$r9WADSKxqPM` z{iiI(eIRRqV!AJHARB~rkaO4mO3aK{*6sZvAd6uM5XDmprDhkLaQrgF*|Wl0HZVzT5qs*$WH?s+Ij;&#Wd?`YYUr&&^AgwJ{T zan?6Pp{W$Lfe-8?KxerM2Vq$Xh+rb=!f&KXw4)EGBflbcb_Jw4P~n3DQM}+qCzL=V zHkCZKr{~s=LMbyjBY>UJR#1Z!eyLQuNZww%5k=S6tt!~dD|@Z2JcF1cgYJR!>-0;v ziN}HI$48%I8SgY~Aeo(Bn55`2lvl?)tnxg4o@Vo%I11gs^uYSz9ZV>d2nUKzne=@JSj_;o!2|g=WI|A(xAE!S0hD zDcE*RJdx0N*eUNw}uNUDO}mjhN9-F*r`{3v^iXd%EMO1ES2(9 zrMV5ZfuBos;5d)$CnS4rrj&cbUDN2ne1n#7)8R9%CIc2^N&!HyKG?z znn*h=#ZlYNn zWd%`gm2$Oqf3fJ&A9ClI4I&P$ICDxrYoin`4&TG*)L7@OlN;~C~pPLoS6y{F6UKFBLQK|aGePs2_eiUVJPeHewK(@FXG?T`7uLqJNgp{%(IM8RJA z!F~vrF{{mwBK3ij!NO4V>!`S>lE2%=^|qdY zv5{w1pTK(x4mjB}aym05GiP6Qv4xZ9zzcs{(lwR(`DwnaiuMM~fsb^Cy#4vdLPAUD*20?gLXB9@n-UO5F zZPd12?B5uLjf#(lv{tDbV=CsfY(YoLjm*leFwum9b(3x)x(q6Fr(q2&0y zc5GK!ly}clteDoT%yYBbRV@cvG_c8TQqg=+-^$HqB$+ve_`JsiyBb5S#WI|Dc<%05 zq}W!9j|u3g1V8oU>Plm@ReroL(2adk)Lv;bV$RQC4B&)0^pilMA3i^@g5_*LjrNYY z1Dqpe$h2;s&kbij!qyAuN4ppZ=A|b==PJu!8<(B3VyNqGBd?!_)6?O?NMct?52hpt z-vU%0GN>%6#MOz-vrHZ5Rr%A}b(bj{A9g!1lA25%3=u+}sJDXZ4}agNdRE&rYSc7Q z)2F=aZM^h8l!D!T(a5-B8I8-2;swTMZ#!L!qqV0{_NzyQM8WH%grM~jYNk*KWy<^B zHBp`toawYXZ&(-jk$LYh)t@)nN9i=%g4)L$Z}KA-{9o+3TaOU7pTyRt@UG3Q+Ahe; z6CG~!m+=PYo-@-@lt$_@B&3BJC)Z7E(f?= zN21qx^S_i2Sk8I@~<`J{{dYeS41G^m2;c4~dASfTQ>x;bBXKwRC}co?-J0t!0V zYGXamvEfY4xo3;4I0`d!99qrR@XA6VtQpI;V!gfF!^v8_|E@e7IpOnWLt95mW%A7B zOF%PX7cj~?$@!41SknqV-2;B1U*(I+`JBDT+Gc@T7p|{eN$T^&Z=m%t-pbdzvi(DT`w984 zd$VBqEew3F-Y$?0$7m+*tV*)uBz<#po(XFl4;^XO14yHa&9Njxjlt10pK@G@$fDbn zsvsJ)x~mgq2s}HpQ#}}iIz7Kw6UB92WiJG|Tn?rT`VOjVUZr$dBCuh{z_bTO-wFFi zpO{9vwKi2dqRK{-y`K60D$@?!#G^LdLJZ5tLp?Dr%KMM$ptcD_y3=^i8v zzl;%Ib}r4EA-*B>l7Wo#TzE~Yw!1ucvoYKjY|$_M+Y0s^=~y`Wl||t3)!Wqd8Bv{lLz3%S zrwolpjB-U|8R`>cS}IgV>Y*%;s2BOqWlgyljYA3kr|-!H5WTVxhtL}#;KM|aKuZh6 zk=_FH{jN&KoSc1>QInareD&YXc5 zf*4OwHa44{#p$-Fa_X9#in5S8Owg;J_^}evk`mn5QbsfsD7W6u7J3EIN%($taa_YW zYHq3m821~LhQ0T8Q0ovmI9nplWJv3?IIy6?$5&Y_g9E{>*Z@U#H{m2@0@s@OT%Yqt zL`xAiFv~N+cAPVvgl@ZPBzEU5_e9qkCsoZGes7{A-YkCk+`VcT$~xu zX=A(;PzZk*C;JcZ3RHFpucCen_u2H! zGzJ-$I@=nkpIEprLxjEL*uFphBz5Q#ZVX$WE78umNRDHt+ilJNuxyaHrG_S!aKx2a z)iUko$ct3fUrwO1KEEWfB6iN{_?gJoFF_gwqZ+xN+TUj@oAiaQUMRJNI@-Gf@g>BN zbUwqv2#?{CpNmRC3WuJF%@nB$R?ycBYwY#`f>=w_d=x&H8|-@FXiCLc0m|SZlRRrF z1=+7eFI0ZZxgff0FpX5orCB)9q~=&YqI-CaPo%eIZTENN>_LIez#Amxy!b54E;h?< z&woB*py8&js|ey&T^ZChBzLr^(VprL$Kew$-R4J!oauz9XlaI#%w3!TQwbPP+)f zvT?}HpB)$}-+>q`X`@E%Q8O}ggjmG&4%fmX+I_d_lz7~q-nat?B72nC8v@om+0sN} zR<*gCNQv>OmsX>2S#}+56vDsGF!_KRX5`|IC32mP84+YoPgv zMl!!oPCqY=fbB;Jpk#>5udG<&s$lmpnSO>{@|2a_AS}gFp-Q= zXp?Nh93tCNMmTYcqp>_d7V3GJJd`Eo*r|VjtPji?QXD+eo5}pF;(7#i4@bA^XzkQ2|M_Y z&oGbu1H(Owr?})L1y&!smf6@($@&-&FLu8^4_DjrT#k+O2pvmfF5iKlIKjsLeb3*V zA%u&Sb9*lafJ`u3Fm~r{`g5it?g#C+COk4_m*CW2Vy&o{*oXW ztx-I%d)u%INr(yWqKTr*UFR1}aAfg(1m#|87wFCKk=Dfa%1)!moi0m`*YjhoTkr4gmS_qAIB2f5*~3~1zLPT~=ZM}P}r1p1A5 ztY?A|Ih4-19%Uns42#R&r4Jx{z7ZWbQN-lx45->=&k1H|GQJ?@gq(D=ZXKYl^DT^& ztfh~0t)0R1=*`DtK3~?Q!E-(bwb^sHkrI>f(4sL6rZGYkFfbEi4#~V`=mL?9zefpG zPA6^$mxn|#hUZDk4Q$>?! zjPP)AV2?Ah8d+8iPSO@M1Lcg5mcWed%<_$ls%D};)#Yp!m5`PZJ8{f3Y?le4)fHbq zAG)iMBjU?9oNV2A_ z@SGuUQ`U#JO6dq=u;{^2xCFgK$Q>V~dG$Z+CZTgSb0gX$-ZW(O)nwoLCmu5OXI{Ac{4>6xW1VF? zimL~Wjk5F{L8}w|gstIv$3~WrQr7Qo4@Uds4D9MDN$#XjlePw|rO&;ZfG=)*)>~&a zgwWXA`Ub6Gj91~tHNxd(Ky*H-i9q7t49KT*RAQ)9w=;WMdMB6j{faQo3-Y~4 zq$^zp75V{=uBfkzO$+1pha~}btHm;-n8qi^d1vQ#e3Uhcpa(iJcBh$x6~G~(ltT^Q zk`MJyZjDLaWaVs4O6>v0@HQFYz!+59o}MA};^JjcHRgi}>>wyrUWFfbW_V*9cPVK;E40 zW;t)<`&Apmqq-h6JX{=_I|HU8wRuE&T1Bf~-O?mA$N11jcQH*l=ej2q;}OhJsp;lR zg+UxE%OSs%yG$6fm?Yi*&MY0{FF$tO%Xd2D1bQxVfn7W~KEHUTAU^(0>9^82=-P!pQXByvZ+!!p`wO^vVALQP?>+{@);q%P)vx z-O4&o5FNA#5#S^# zzSy?E@`Ra!MsYS#a7@DxhXQjpFfr9X01u<8sDA)hU1it!y=KkLnE%Pb&*mC9Vba6} z5}|_~{e=3r0go=8DUj-)Kbn<71Ogpq5dgTz0&ubYu1EN=u>1m}qi^^^=)rybg36&+ zvGYcO;sON(VosU&>A76N>xz>X4j6vkKxP5Y0583~xTSly01I01!Rcp_q2!sJ8-Uh$ zb0C<50T%W7=|{)DbO}zk)j2rU?iw39IyxHC);SygVN(a6rUTUIkx}_!jv^fH0x^Pr zQljVml34GBjHphSejzBUcW~{Tll@~$i+~_*$o&8K;TP}b1~4pO9RRp-VdYa*0LVA| z^L){%KK1{Byf(4{xS&4w_J5syQNg3XZ>%9h1g)*73vTtvOZkDK0|AjsQPi=wb1(o( z=O6d}ks*kw6Z2I@`loCj&sk!oq^XLjy2^184`VR`(5Fv1G_$muGz0{Ay>e0;G!dE-iqo41HVgS!C{gn5Sc>rdm zZS`*i@A-#m!MF4C2jZJ*{Ac*?M^=0s1L&=~cd?{JFYF^1EH>*`_I%h&cxexv z_hVfF^KNL0B5~dwO+SiCoB~FU&SlhzBi2C z(kt{G&$;xEs270hu5Q>@e0o)$?>{lQ%HNw>rZ2w^0M()G=rovK@Hemnfcn)pAf9)& z?||ENf;2fHXKEFTyMMhprC8dI*+VPb_A4P`smFweV z4m9l5G@ClP?HLslkSY$X@Q%-QpT>Gp5f_?9QP<1ooOUSUdP3Q{$Az;gb}eiDRs=7f z>?)t?tx!`-EOvC1hR|W6igX0j}!n58JjE1Jy0VTSQEyb=KyLt-K0E>63?T&}M4o^dRX{P+-4!SCU+W6#T? z)&w=1;sOsMvU2XV;enUX}ED1(Txu6f*l>Ux6UH5Pf1_vuA(E*s-{e5i7!8;-@H+Lhj4^H!TaR4o-o^?6fm zRDAB3ZIRNIrKpFVO<@I0g4Ibl$Fyq0Vh+ONbRj4}PMqEp9aZxzw#3HFcP|0gk$B@A zBi%M3I@|6v+8WyB>x%KDTdlL9E^O=~I?8fxoYjf5EnTG`X~Jj)xphs6+XB!!E8uNy zkts=Ya+}Q<^KLrTB!At~?Tk#jl|&mkAY8HT*|K>Jx%S7FruvhKq&}kc0pcjWm#Q{X zl&3$Ph#gQ0(A&MF;@A0Gi#cmNzE?k20e#j377f-<&SpIARhA7n$9nyl)R5b2M1N&z z3T$c3fsyd8jVaWx18(#VCiF8{LLwBqVWeFvJArA|aTNSVq%oVBl1zZhNU5j;F;Pd0 zHrd*oj@gVFEWGRpZBM04Z|;2=LF1jvf5p4+OAIDj88NgKIPxSt91Y3O6Gbm1nVPjj zK04cm)KH-TJ143XkfdyS@lBgt=~Y~-5_o^q>^Bkk>zb=-tR_zR)SVKQV`XGGFYc#3 z%`wOf=BhxlMxcv_& zCsrIuk{F(B$!<{o`i=5VUfMGof8Fvi>%d*@b`CrEkI9@nCV0N0YuQF3oB<6L*ngDVCN4_E3veTwrG zMpo-BQu|lO@rjnb*aInvYNukw7QJwb#bs6OV+NKhp~K?b(~x??ABG%8;N1OPViYgu znn-k?#kbHNX9ADN0;970);D3RwpD{G$J?1-(Uj>tbx%|?zhY7%Q+kB{yUBEjRkH6z--r^_f!E z$RDQxw;C=+A5qPwuYCY$F5aK7ljYW-8jn13ge9S4YQ-o-VAL}?$bExnZe@{LV4_Eov7t z38AXugb5*r=rhJUYD@>2%BB@p!*5%;OK!E;eN6rNAB#Bd19LTKL_=p%w{wr;fj!@| zLY^`d4Hz>>=8mQWfSa5}XV(Bmau$$?r{1GRSNTb+h;f(E-VrrpzM2jZZAf~{B~CH) z46w>-yycgl$1yz2ZNad8&paQI2rKzT^@QN&FnzWTEnK>hA(h{_^_l-aq!U{T8YKi) zQrQ!{MtbK?b+pO;EUE{SXb|Th5U#9N6+s(gff=iwWi^lWXz}!xCjbKcSI1nNpORfn zo1d+$Q`!6}o6icSbxv3DPjn21qhNa_=lYy|<9)w3oEgz;&~WAN&W^phJIo&82AcjmM^YNM^*hV6I~ z0TU=+$n6ksPj9aJwS~S0c9uy6e!7Cc@jsFhjaE!)qI&fEP7DNT@iOuWJxTsLB*p@K zJBsj%BlML$e_TCycGpw#Gx^g16qa&aOxwWcfamwv|FvG8K|%16jzBrIf?d($*;~3- zei`R3rbLakv1k!?3j8LJn2?IU+kz<-1|590hk0E1=DeytN_h*uX#MS~ybU8LWc-v3 zgosq>36oikzvG|G5jd$O9PPhhj{ewL*5-X{hIVCVKTWB0Y7MZqOb5DYx+Lxkl*ROu zs-((~bslMhs8ZbCmVzORsL>j3g#&y96uFFB;zyYkGp(*yiC7mnPZEeD2$;ICw5urw`}D#`){@x^wxs~SEm>mEzwj*~o8 zYqOcvID(>hdwHIZbL7W2*0fI(M8~opaXm`7getCmYqQ;62@WMl&<`gAEDK{Ex{FfI zc-k1kiU?Q}YP#>F>Kr)MrfG?xO2P&0GA>r=%XYPyiS42-yNE|=MQ2lo(b!fra^_Ti z^XHmga6l^|T_)q4P%hanH*FoPQua878+6C4tVo1IyyZ|{6lA1DjAWTA_YTa9?4*#J z>6Ira$mcA&UCQ>V#R>&2|GQbq!pF*(5wa|5LBRV~{5&*S>3CSe z@=WLi^5fS9n&BK_b>-Gc&n?Hw<@AuAN@%Xk@cGAkyxwZ(h(B^DJQ|Q^OESHph}F`# zlYn!r%qK1d`mgKWWb=N0FznDg7Z4)a@svoRq{i%rgoz?D$j>mc{vKy_>0BJ6xp&1R zg1vw0-=6lN(PCL~Pp7Af#GAWcgHAi9pepmYY$x?_P3H8x-vDC1S3`A}L79?!>U-7x zUFx#ict4$P(ZKBmRVVxvPr47SslYwMW+f!a@ZWw-H{C9)tMSI&w5Uy=mNL_0+S>q_ z>Ax=go{(DA6qud98PH_+jI*x>CM|}62i3E;-n(;zxUSYF@5}BC+%+e509v>1mL&w% zG!hO8s&R5}r$(tYZ;0Uu(u#$68PLaEXapVgP%=On+T5ZIMb}rjUp>&e-xo6+z7<)NpBJ`4Mzb;K(FFg?}Xp@;n z)Cl`$UkT+Q^>FQ&TR8>sCJXc2n4r>CR4_}7zaJU_cE|*xJja?>J;Kh5_ zJQ5OC*-Gi6(wcR13rb_)EhLzbNFYw|%6xa+-qdhxY55S*qUpFjgJ`q?MtQM&Js8TOW%|_>-Se^?#@sU>#iOay!KGO2hU9joi%bsSeVzyt?Dewrqr+;u}o z(`)TVM3Q8LIIVs@ts1^~lJ6L6gr_fM(*VN*;7T6dK$$JgDcrE6>CNU00d*8~Mbf!L z)Aw_y!jE!J6Lf@)bVboSkcKup?}vbwn*IfPojwDUg1mq3g&uZ7+GCaTB*nrFXEs>vb!=?CV^GtX2F};0hJK)FgyFx zVgw7WncUBvrIRh!2InKqV@GS9ka+is^TsrV?`X#Cl~BLU(A zPd{zrQZjdIbrB^In-XPbi|_b&WqgI@6m~il{Zlb5Ygu>#`wfk(tFN4p!3_g3;~F`z zpcY4GaQz%|18j*?OdOLarSHUtsjcqGG)d`EVjUa>KK7d9PZeo)kK{13N@D5hCCS6> zAl_`oN-Pdh7Um8nSL!bG7R@4(g?Uxy$f1%2C6V@b*U(Kpu<_K5dQ<6>h#E)D{+bDd z&b-kxU{5bS;>xdh<6<9xZw4gY9y3}7^HE^a9ghsss(r`?k#}fy12Q>b{7^6v``uRZNj(Keleg7!T|D6vK^ zsq5y2-+?6F6GEuh{wnnCOQVZ@h57$LsM7ayxJskAa;z{ZeO~RGBWK&l%5&qZRBsil zzj23B%4j@cN{^ZSc?@8c6>Odf?8dpcAlE5T5UDQQepJkM+Pg4sg#r5zIg5BI31!== z4jVEw0PG!n35VsX9*I>4!4iOI-i`dIZg5-@xO~Ua4_!3eAw_KO=x?Xjqo$OWcPhBz zF|)GGmrHKkw{AsO=~50i9C9biY{Lj80!$#0;&QC1q8K{m_BDK8&oLxyGG-c^#}^aX zzIWqiHf#_{ou4aeP={Q`t`v)PGis#D&khSjbO_vHUm$S96uRi!xk`3sZtC1_)l7od zP&1}I5C0$l0mf6AQt`eShdnt zE0KReBxJ4>TWP@}h#4&UmVhMlPV8wo4CtJni4MG6;>+exrf!!4h2dz4io@JBYElZ# z*8KYk7SDv~2vY_@;wxu-o^7eo5w~W7@8Jj~9t3UAi7yjbeeicEjt^30E3e1W_o7O? z>F33BD}2{2t?hpc0O!2jbr!!PzWDty^&nDL(qJVJX{z;m(tba+#VRVJ0Lf_F|zZ z_Mszw=62INFeuhTej6bFey|M9#6?oxZwt&D>vKiDhs0RTowKtY6pEq=1B=O)<_FU? zXKT}Lk{um4tFP97l_CziUbDWT66c~~06lv*P+sYl@p3seoWRJNUpep&v!`mg;H_0l zzk=vVZe{+_qu^)*&U{Xh4Hpf9{!SY3)Dlr8RhX?POb`tk;g|iD;Z6^KBm2o zMSKs@a(qEe(J4mErcjHHjf7M{FNMbWe-O^Y-(GV)`fw>h3X03Z2-Y^fLSUQ$dT{ee>pHsYh*0}!mjX?vVu4Mr zutm>FC9Dpmw7xhZ%!nS-i6JfM2ClR-?u`lWP+Lp&q|CMk*XI*8ft3zd=Mb z8zowhjKi>}tb*UwxZX;kc@UTh+D0GFO)v9Sn2we1cMAaKC(-GEr6AjoPsP8G`ykK9 zC^tLznNwxV_vFL=8BGj{DLR1Bs9eL9P1Kn4`K};024MSCbXv{ zo2_W!n1?=tm{gDf^INRU%fs^#)NamZsOl)On#|qfLk3+i-Nt0+YllRK`|>!lIq-C2 zu@lUs(dG2Myvd6}`E8|-;yhPhcq=s)D6~MCM);8QrI^njQs*Y=tF**&sC5bCm4yE0 zSzhXRa}9|)IYMg82_GoXGK;XSPY($bZ%QobC@b4b3YDizyVIb8=>-8%xHnm?LiOes z_-p6G3c@j*m~sJFo(=C%e~Bdg_9(k#4BLBLbaX+to(gUYaS3AWLQ5_ppA)M8l1XaI z55mNRVvV_1E{t`{vx7HLNn1pHz8fR%>yMU8H6tG~nZ}cCmR7&T3B7E;I;O6jnp(O}FM8+g%w41HGNv4N`kev6*?7lEGF1v-o# zDIm*9!tfXqe^XPW;Tp~1S`J1_s?N_!D>==goa3l9dLGzc6Sd6Ch!K?=fYv*>`$H4YV*s0 znKT?1(kxT!lG3!Ypv;Z(cz~BxLNO!zNJ*xtFGP-KOT-Bx2TZDY&pZ+)Jn2n>ESXF0 zoubr)CN!q;9Jg2;mziDOWmNGG!o@wT9uRB+bJ@q*Dv6M@z{qyrK3@G5Na3ey1DiT_ z2Rcrb)wn^yW>OH5F_!Gg4gf2ZCI6wjUF~ooC3oWfu~kPq?Vb*9uXVj)I9!|l1g^uS z#@Xj3t&bS7@_^o;SW~OdEn-+!s<_u?CRzex8X;d>s)w1v>aWo`K>!| zDM^>+lO=Vc4{mUr{g|hn_4=fl0xWa$it`rJ3E9O1^NnA{dkvFVw+cnX5z?}u=w9tY z-|5s+Jnh%htlk;a0B9?t2`?l3FF8(M7nfaE`}37~a5#}GWB={M&;#Yk$UiNfrc#=% zz6i%yF~+EK+Yka)Ooqx2~#~>63?uz($q% zUPZGwwPzCj8NQz+9duw#wJ#|OoTi#>pF;3O%8ZVve*!2avf{eYMtblw@sY$eEPD8F zy;wnSS|G)N!`&4VMYnvAJ%=e--*<8VDr&o#`zGbeyDFRdaJ2BL?5S4l{;q5Rwho z^y67x*qZit>kx!Iau0j=Qk3EbRMKD1<&xQj5N&K{Pugf-q(j;-c^@F{Cy6JaHv?|N zH@%Gxy&}*dyh+O{*A1>1!Sjk<%_`dBO~Xz@k7*4QI)A%TJ8up*GeZzhRLQ z3>1}62twgqO=CMF7?5E5#*9nyt9tL-bwj&Oh^aw7ZcHY1#&ji-YF=K^1$qIEdo!Lc zY=l=`?UG@b4y95{Rg<8}WrNAp6n>qQYRmygrkOxm1mL6+PWbu(HpF$>w<()J&KnCV zP_wa@C(M0$JxV)q_x@B z+i*_wu9nqUQz~1@txa$skA_E{q8wH?I!Ph(uNd@=2;7PtuEUp!XK0&%dUza* zks zL=?)NiM{U!8095OH+mKXbWFqOoR|>GC*ts6?e34RJu(Yb)Dya^$S>J)r0jL?RmKSA zY!A&vzho_H>^sCxWCxV~7D=;*8N%a(&iOo}h%GSXR(OfrM`4hC^ZI9X?Ih^|V$xi{eGu9EG;HFlE_$i8;TNXIlQn>&1jEGEkLrdbdKRV%uNE3h z%OuBBd!8A8uXr_%$a`VNTZlEF{j+|l2;EbPIC!d9$HQaGDfMJXhlK6Ikki#ROe%>>qz#;wP|UX)Jbm`PNyyhOWnZFgZfRl8W@EM3#3(|4ETwt64bJ^h)IVg$S$ZA{k_?$? zzjc&e4r^-HT9w~#CL8;CHs_di*4k%zANc-=1haK))HO)G`Op1^f{kXpIK5ZFo`jT^ zoSJ%*l${$Mx~^0imrNfiNb_x*L&>txp$(;9pxy<#%_=T+st!;%3ypTJ=tG1kZ#4?D zP2Ii3J-*<%G3y*-A0hJ2is*r34%=i53G1~{SV4GBa#AJ~84Nm;u|=xSMkSscJX|qpo5iDN3+*rhbx;F<(|2%)PWzc}{21Iv7)o>jP?epi{ z_Tou^t70RSJUl)s2dZK9mlm(VY{G(slovm-WsrPZ<8vr7zZ$-#rFql=-?4wggl;HV zuYkdik4-Cg4*ky3*&Bh13+voc`DC={(DehT#|!eUMX%0P75-fX0_UpM-iWZ$maR9y zZBSw!K&_YDdL!`NN@ZE(zquNWd{`_r$UX@G&{Lkc*eG5SfEj>5o8TV(+|T?3 zA-*0lR3b2ug2}lZI{(lV!oLCVT?FJK1Vm7OfG+&FQQtp%5DI?St2h=g@+UxL|McP2 zfbys}*PsELn}rH&-ewT~84N+~A|N2_zh1${xdh(vC_ z-P?cT+SJ|d1rpHj&F)iGwIeg7pM-{L1YPCFApnp8WuYx1O8^E4(fDBm;p*sD_||i! zUqrA9XMD|ON6*8rh5;x%|ET0tqXJpPI2%8La{g2yc&Vi?Bb^wiGTxJwg-4%H-c|E) zkOvurT5_hl-Z6Cc`!&+?`cAXTr!`O2B35l>wLj_0qp|(UF?CVN!*=l|Q3F6A{P^(+ z^br6CK>_ZX8VT39X->HPG z{R1TQO%QQDMi)x zh4}7$BX8s2{9bPORQ&O6(jzM?T+#JF*4>IDzpflmzykQtRT3J_byf*g7uw4DR;!Ex zDRkk-G`VMnyI^ehH=YwfoYAK86SuXxgor)rEudO9Tgb$HTFxtiqO$ z4WWvN?Nxzaod5igbWcOsd|z?7gMtA12LZAg3BY2IL=14dCs3WwGWft22)L&uR#2bwJQQ>$2Q34_uI}FGJb9Arwj5A=7$c$ znXQ#-5a-F{Gy1j=9y#+T#T{T%oD1Zz*NdNg5cpe8S|6a54df2|Rc%bw1_H!l&sPa? zDfVZyR~HRp5XnGDOy^;U*x@l)I;ETIu!t+LMkJ>RL=fQ<7a3cRDMx9AaKScb5!y%1OZy z30R5J9GoW2Dim|&LA(f|d>?ue#!E_Xq4JT%RG}t>kE#m_Ww4b74QW0D372!YLycEU z(RU%SSz7lA!d@ie3?iH8cg_qWLUXRKCn6ag6fgIDXAS0(-ALvWIDfN$no?Y}9r;eU zLu@_~PNp0$bBozeZ~^GFB=wnD)QAqH8@(9wBNd~W%H$nhITU_4`$$74)|U;Gr5Nj_ zykyuhe1eg}>$B2l<^PMaa|+HRej99TCllMYZF8cDjfrjBwr$(CoxHJaJ3If~+O4hK z?_#&AZ~C_Dx#)iS{LZnAECDSocxyN_+cH?dW*DwQZB`#${kJl^!(JLlZDDYAYqtLs z?d_%MYTfgsn)J@h%v`+ne?M8$4>-uaE86}82sF`+tm)%q7$|b0Da{TMH{S z`H%rO-xy_C(J38S7Je+prOZy6xS?#LJqN&Hu~_31sK~#X(ps}V_}n^amo0c*vtIz> z%`4l+uOeeeIv)OjqTBTqF;mud*WWllS(63*Jex~5ECC|lXz27j#;W<8(k<^S5;}Tc zsaER3e3w#VNm2-fTcfRHn1Y!N(CNTQ;C3{axpedkQitT)=%RFa#yFqe{=8RaFw31@ zgxxMiPpsZaSB38Pb#*W(w>BT{c)Pa(PC6v@ia$E(}pMbpY#cf^g|S%(E`M#H+%IS_pvyt_KuKjcel;%ew}mGH0^();=;^R!tJc zWfO2RC1VuK7VxXebFOWDZoO&#^i{V0bi*q4;~8Fa!D)9)GNsjbesKU}4Uwb5k$m;$ z1WKWyHH$?g2Xyft?{n-&BTgwaimlun4=)V9wX#)YSP3=L86{J)`b+@%l2tsmLOguP z)@FA|r$-W*wZ#Qwy(t^CggU%mA-{|O=u4-J$Mf(r0u6X;`e4ZM*L(nT!B^SynN2E4 zfpdJiNCZGh_?IiW$_8aHu^W$71C5E^w2)B5p**k6?|vf0k~b29(hO@~Ey>yz{B~6+ zZ3mZi;$iERUOhRh)hr&3)J3`BLnUL)YQt!nsqNxS8V03>C)RuP6;`V_pe*gAjIx|@ zC0yn`#Bg^Cj){&oo;whVep?z*-e>p=gt<3%U4+vBJIv4@DDR1TOp5%%-gy|B2wvS! zfJ&ulSXuzHsex`{jMWIovWz@jChA8^Vs{hSO>CQO=KaX1c`A^`29LUno}o5ibuFRn zk*l%dOf6i_vsMG&S!OK#Pa}W3Ca@t9sKRdzEWKF@@rv0}DH&}jbH?tH!+CkfGSU{B zozw1{k23DO>}9t;3*T_B7COxV27VKjx(lok$XH?1u#F`6mfuf0W*!PP2lUzy>hF|RQw@&AGz&6Ax7h=nI7C8! zgKHKJyt*C#TRQS_kSgEEmU5Vz>LtXjI?eMJbG)JO3ZzEp5)tVmPGcz1L;FlL<+6IG6Zak|B=e-3%{bfR~T|ClRgNN92X$yjt{TSyok=xkWQ zho3{r?fBzmV&%b*TS-u_=RvXhW7%tI1~G^;Sq*8*t&4?)6^jh&kmu=Qk>0UbrS)q& z;2Z}fcTv(7Gfj(?jYHY?UGZ!5WzR&xpo7ExQk{gq^O^l_G%kPm@7C}V&!Jpel0wyNyE7fD(4j`q<+@|r{2 zCbcdv!IlBJk`^EHnjut&>H603_{kmwOgtz2E7lT5i?;d&)wwdobb^tv5L%~EG%~XP zpe1Jo_R>t2Vjb2gdcH&rOTKb83Tq5=T6aX2aZYXTPZ8gXjytNR`(4L?kqrx)*4XSY z(3g*izorlqwd$1va?UT$m`Mi}cI=zsAP(Ah_9!}0S&eq$%~LkuUbal$$QiKlr~apE zYC9%^hZ6M_5Iv3U8+)H-G=v&;-47@G)~iAWXFb!cfWJFoJyBNO?b9p+yC<9Jn`)MS zeq2g@iaK6^K&9JyyGr#HFF-FJhP)_at$j+FBc}~zvNP*F4;D?uM3F24MMYKaX5zCLC8a19@}K0v_n;CW2E1 z_>eu#tg|reB>4m*@9d89&1T|>SdP~Ht64n;uu)4qQztQz0$HU3_NBOp1Scb>HVcg} zJ*6b_6ja0_9b5HR&R=KXQeR)D$83ooHpCrxkEjB23U=-`(#aL&5_*wimjz|nn00hA9{}e zrUC9klGHyE+;J{<@??8o)$aYkRVNep)2kFFTz>mrg>V@qhR4&Zt^l@!tUiX8F|con z!C!IBI=yktzFRTt0nFj-rWpn+WIO4t9z5*Rn`axOIaerIf=s<}RrQuo_sm~Epy-+r zQkn&jjN!Zr#CP!`F`COd8HLO6r>i<4ANgkKA1BirR*tuB4su)jMg?}QPcZEG9@;W z=kLq3h{2M11UpWlFJ|u-qBkp3c-|v7ooK|0mL8a92%axz5{olkP=2S6K4G!4KFGZk zWd6k1h_~WL6fZ2vL;}Ji^Fn1Oscll5<8JCj0c#oR@hKxy;XY+sL_WKezfde_y){r% z2*rEVg|fbZiLJ2-=WlTFUpVd(^2gM#Y-k`pYVLQsC%e>^ zflbVs|Ez0|r2=hl>#<-B0_`Mjn87u^lmZulizkbH~43bV;wIB z9+Fhk`x_*-U-O3!FjRc;ovDdL)u~GNn&IT2IYZ`0iJSG#`R-kE{Z*<5mzMBySVLT* z2O`aZIR*r;2bnX{;rrmp$yS!T_bgMh4=4K0DL9Cpa(FZXWn}9b23C3+4yeiH?_5?` z#@kh6d!0up(98`CKBZ{>2ZrjGPf>ywRM(Ab9?+cU;spG*-)D>Su`=eH-|_N1_cpSq zlpoPg;f_uDbfubICQ30600nA>MKN1kbggU@p)R&DpP$hhnB_GNjtImEGSNr(R2g>u zV8x}@u@!BMMf_m}8f2gA5S~$@GzRoKG^bWbz|DCpA_4Matc^m;diU}irqR-=w|*`R)SG;t@k5G1G^ZD?M-J@L4t zUnT@}edis}c;BSsBGRO(gK9BNN5Ov&Mn`cmc7scLbUEJPZenUFofw^jRAbaz(+6|6{Nq_Ji8lh6NjnwVHc z*1b+&4uNHRPteGHKtk94wr=daeN^0N`XZ%MIQiIu7(>yVV;*dZv=>U{@LUVzB)Y@{ zy4wBkpa{sS##`6{%gfS+ynSR6wcefw|7AOy{)imyzG1pkbvv3C&a)2N=={=Tx=-+j zlc(@dfEqH-BrNOgP_l-!zoQtDVp9x7v&@Q$Hn5{u*Q$Afe_sg6zWY<7-He- zknnO0#G420*9LCj(y(z9wvSJ1--3-yi47RW-B%A@8pq9&wRggV0_!P8zmqt4xLFJp zh+3k-UZ<@!w+(A8Fsy%@F0%9;z{Q%hdoc1o*n`eDP8G)QUg|fPNAIHs&QGros|Ob@ zfHJ${{adR&@?sg|<0&AzUO_|K!gF9)4o{bv6Gu95889()+svSESs!Fzm~6q8F9b%3QEs|~?LDuk_{iBi%dpz`L zB1Hzgd-qD1xPdR^r&N7jniwQ{Iz=aYc3y62xdCAfRkRGSLL|g=EyvLZ7->>r$@B)= zgz1P`JJjiBg{sOgiY4*en%Ec$cAX1TNahJEoi_h8tk!wzM}*}uS2Bb0qk0S9u)bVGatz>6 z+=`-Cdog5JUqd7yd2fNh5*ylgz%qLfRFqi_@7LQ%;&|GPK}1^Fb^m)dv9RdNX$K`a z$(d5rd+rfmQA4nAvRQ*?xYXN@8a}(XN+N<{@LUX?Y{H(k&H==^QCd|zL>xXudjks3 zFS&CRz&)+8)xtZj*Q58JD)@bFMQ5uK^tXR+?zZ$j?1MVoe^2KZUcP=#+79_I1+E=7 zVh=?Pf8E(XeTt4JT;pDz(}ePB?Q~>ilT7!jj9#e(AmnNKbC6I`eK7S~{|cQw$h3~+ zj&di~4TA`IvlY}p!80o8k>qSs@vo#oXzOqb>ouLOW{ixepQ%c_Tg0=og5|e+XnHSU zXV8H~NcR=j^QaOJQo~3ei@OlNi?}{A3+Siy4KGjvF!d-VA^>5;-m<+Xbl(pb=NxA} z>wsLvX*qPLkL$|NirpVt=?IYV(4?v7)`mcdZWcFp;viWdrL|b~*Sqh>>@F6DFJ?Y! zbX%X0tX}@<+MZ>%jfzIy`Nrg?Y8{NxbBOFQl;{!0(-@VI;YO3C{{D+M(d@jNFG{D$ z@)lnXAFCciR(96$r=ZKB)+<5nmu~!3UlN~PZ&9Kg?QbJ1Qs_SOGQn5O(5Q~bDEoc0 zFLG!ya$nkby&jH%KNh$Bga^ol%X?DSUxV|hPN4r3_qXrjhEWgczD>%<^{xY%c&aJf z((YqSjGLyqu3Lle16v$&#UwnZ@>GZJC}+v!+AS1zKM|ls(NUoVOvA6!U@Wi9YtI%v zDmBErHQw|&N))xKBjOyL?{0$|Hidp|RLV7SWQOTkG~Z5?LlF_0H9N1jEJEg!)l84u zqt)w;%SA6P=>m>&Lw}#%37vcV=7Rt5t;E6!tu1I>Ip(^-0nk>x;)5VMOPWl%z^MSI zcw)b88H{YkE~cjt0Ct9|F3U@K9=i!{f+-oHLn-(oZ6_U`D|e2@Qp3@;9Uc4zWe zr6vT=bgTluz+onKY>AR>SksD!V@{bg?9~~2AV$Zq4k$6$X!r*x1r;xWti$H#66B&u z)`wz2i7G6{*a&1*R!ot^g+rrS;c;&T<8<>lL7#f7QN>wZ!kG)((TjGwSS9%;xf((&@Cf3md2uIEJ>ficRw@?`2#M49BCxCl5N-< zohEba2`&++8JslaBRKX@369iL=V?e?AvmguSl8vKg$ydyGyID_OCp0YGne<6Z+ngr z^_YKAL+N#m2u}9s^2W*Hn)<|A>VQ93ElNh31#M3{Gp6dg12}aEeka~cP_DG>GTCt_ z_{GdDHkcwlP`FK&m2@N53&UyX8Tsr?Os%Ep-G`#rl|IQT9q5Tb9I$NVLNDw z_{Gln>xgIk&@XvAcEhkZM@Sm4c2H`N5p0I2X8~eT;;G!mGq3oo&o~>>xIdcNgc%)% z;ul?@WhfG_eEg`?Tc+>o=f|n5Y1QHSo}ccDpJa-YCI?AiuZSU8Zpz!&ifVud$&?Ye zK%Yb&7-(sb?ZaNIYj2XTEnR4Jup{N91K2Ni#^jVsqL zJv&Eh(Kjw#**z$W#pIhq!I@m|PZIc5$46$n{*}8b&UA5NzK#7kc7AJU{`Cv3Mo2*= z7$fpB*}}bgjE29u56Czjj6(18JN0dTZGJGQC-svt)AvSrs&9hf@8hvw{j>^ zDqj@a&kjVW`nb<%zLKx=bRPB%yu_gISZ2a6f1AjAb^d5s@JP{WI}lSk)gy8p!FaDp zyD1*nSb~mI=+%L;=sBRL9%5UH58p45(HZ}2C|h8WpTn%WuvZkFUqIZ%6v#!7jY;%k zb@WhnWf}7UsL=N=c2X}|JzoE-^@o$X;o0ht=_+(%8D33lc7B;@-ZzIa{DstkcD9!B zAxqZ-pYAnVQl@NWQdTt*M(b$}rs5P>bsyd)JeRX00qi{c=#6`=Cr##cyfvRkD<*~? zH-DZiQp1M_ADwz^EsH?bs!3stlKd!Zt=?U%tRJa3dbU>7>!8+`dCcI)0(9Ca`Y3)X zlVev@W0*{%_e|w0GhLqq^?d}rJytNZaddvrMs~$$i6_2Ly&Ta8>KKAM1KWOu@gwa zT@j9dGK|4J_dfVH#qmT-j)xC{c-Q=9U!>!0-9zD~;w>E=+h0&`=V9e?M}p+Zeu)*> z(bkBOXLWeBoZHrR+Yc6aetj{hHKO7sbm?McXmt&57~x2P7Xa9SELEKXbTCCXvz-2N z$GyT|;RWQW{UjB>Iwt2!F{BS9424FCtIiyL!UW`UJ+j7v1ZhUZ4Ttu|n#4~4pTO9! zchSaJQ}z4@lMiNSKJ6}Vq2oS`pBOam{qm!an-Gm82D6?_BqfELn!RUn6hl3RBIh<= z8)=AoIvlx7V|PpK0PVTn8b_zqZE5~rX~c*=;$F2D;|i~m%d+vAN*wmls~r&rHqLAQ znxg*xYS6kP@Hi@}cd$QQfT0)CiK8dv_xSgz!5lL^J2xPGF&7)QVYBKN21CScA2v`} zG0jS%oQ{HaTtaJ79_9pHl$`Ow`?VA;1(;=rxlqm%pQK_cd&itOQ<|8!%h<~lw1f2Z z8*_AHC43tZoF%`N1q$RUBjJi_fdW_t0+mo@ zSBS5$motzY{;`Je%(LJv0mOt1t8}S*j`pJKM!=>UG-$)Ad#@<{q$E04x0W^Y1D4Jl z7q%;EKx{2~mZ|L~GWg5lsU1`+9F7=2Cz1tb=wg7R(Al+oITHlj8pOsJFfnDc zUlSn}T^J!9JP0uvQ8vl~gye&q_x6c^HTWH*EDvy#CE^7W@MM~7bApO zNu(%HQ`aUiArp|~ZwOMd|Acn@|AlriiIx6^cIr5$kn?EZ=7fp!%$e~`ib4rsjxPiH zx9)RE{4fR}fuv+)pub%pDF^Z?F~OpMP6L?e6*;fPq1N#9qk{VKFnfK2ce_sl`rXFD z!d_orp#t~J4M-<6Vib^eK?mD_qVmisCveW8{sU?t!i9d*%cey^>hFVy{P;)5%VQES z!oc(aUo%3X`Hyh95#i=j0$tnq)t4X$?tn(T8dW`v3L@RATLKXp%@@B&`h++^&0utx^W(MmljOX;NUEHmkDh+V5ML zloZzkR25f-CMc-_0tMtRDhB+!O=P#X5Yx}V*97=;R2_9M2u$)v3VpTshxGDm_0j!D z6OO;H*XWGMJ}MZ*?T4t1O%VjD-`oHHf;7t9+dF?&?!W&#q`^70b;H0HQ>%-K`{Eqm z1~2$oTh8@3+i@<8XP|rgvut75*M_Gk%Gvp|C5ovDe+=u)>SsVm?^|{c$??^!f6WNC z1QZ_f<)H{9Oh|a^>(o{q(6)yU&l>ZO(NNs{52K+926pyp*(pj!3apO?b14ym!z7;o zq%YLQ<`ne)ZOSMpis?VJs}0n44+1PNi3X^3-_H{LP6`VAAv6R+rofCD@&zs61Ud_T zhl~RWBeVm2!H3C!ipKqr9bBUeiFDiBj_ibSBJ|h4*wE28We1CNa=JzN<0hYi}9A4rrmkV1Zk|V14g)0La3VAD! z|9T0pQK>YpLjSU7-l?3517FHFbkKvGzKo#0@gHCv<#MUqgSU4xDll05+n25rFh6F2 z3OKxdaus1{L96TpNCARm(N;ia_&}%dJCIqm|1R&3-#vDSn8Zo=9xfJNYi;RpKM+|N zF56ut7qP!-oJr*WS;V{u6*J;(N0=Q==L}~Qz9jv0`si6Qf($Km0*IvIYC?k;`)|}6 zg8!)$o2M8(_;zHF6P>r7+MH68y##}FA`rJRNM`@tgehPU348o7TGb6hGHkkWYqb8uC(+y%vdNB?LxSnR>nemf|+$t>|Nq|Dr;lG90UJU2Ov1t4Xa*VKd@ZIhq@x_+AE zLC?(C_-$-f`n_75aA3OF7;Q&&$E?tO#StghY3C|Me?KGJ%kDiivIlAmenvFt(_nA6 z&0UmOPt9<`jTO=xXOfUdi0E&Xmf3`+O2e0Ym8!eW@6xeYP9tvVd$e!hw?pg#$T*<= zS*gn7t(mcupsk<>`;?bost8wgJoJi>N;1VnY?p^hdWD?1nl=MW-L79BgJ%5@Xr`T& z!>ber8@&29&`-}bo(CVfR~yV0>#CEoZ*ioZnQX@&hc(h3^7B_L)=&8m-sDV)qS3(w z{VtoHdgc>UA6+WAwZU=`d`zTVvZ{tH%r5s2D5Yy-)X!IcXsxt0G3R-DT;uUTGmO95 zvMlQlQ)q`dE7Io)M+ZGxkU8J|tnQzuDx}`Y^rVnLTghj4i%<5ILFH;Jh;%xJ^5I$Z zT7@bQcCM|1-&&1W(jV1eH52IjJ&z_A8|WhzlVJl1!i>!|+xO!UP`9HWR{iGCFC1eC zmfCsLxg9zI{^8y@>WG98wMn1#TeR--ZVj*!%`tgp(_Bwxt@YV?3f3?&fz(1i=w&I! z$uQoPuZGL~d-<;#fND`){EdB6WTnOy5AmLN^pulKf=*BV2l~sKz8CEDZ0z*#+J$;7 zK4fraz^ued`e~nUm^Rm^mE@1;$(d&hlC25%aEA2U}_piH;p3L5HAE8Z8X8IGJ>P@Bf4l*WT%#25)n-YcVva3|l zhy%++9q`0$sV*=9@geZwdyzamy`32Lqr|aDOtBiP(g^{j^5-CrmQtrV{#ZIAl5+Hk zX)5wN)hz(H9l=z|ux{+^0ftDAPK6|FJuWJcA^2mE!i;4==TQhTvCZT$Z`H;861T|( zsbj+%Qq5HOvtW?Qaaf3-WW6CpLxtI5%`dIjeMloUj~lV^TU|VJ$h!|-tEAqx`-At$ zXq}oQ4laYBg<@J)-?(lfm9B}GslM0l@^HW;fj__E&z!KN^<67!vY5sJwV85 zc1mp{+s|ljhj!-1Y#3I4Ie=&BoK>RTax1s2D(t<}VxPg`-x^`KvzHH*b4T``w{DaL)maNr1AMVvf}v6_38AbT zE#Sq+n608F7j_MjIb*9FsRo^)s6|4Y$gN!;;rzpDcG!OztR?Bgi~d8B_F0o9-2GO` zrOqQI@D<<$tYMY2Zf-Bd+!*1KAixYO8SqltZ(d_>avF(C`%VrG@$>y@4h9pyKMbaL z4LI5EgAp8IX4;_jIflnA(r#p}xwCgUi!2)GyH6d2eyGPf;yCsrGWTw}PNQy%I%p@a z8|7+SxXI1q$o6$$Lz&5UFAd7mPm5f9f4#KA*RUUH0PtX)_c$-dTlwJj)fZo*f(sv1n*H0u1tB?Omb90md{h`3C+~HXpU?V zmkyvm(;!ms{-bX*K&GR%F-a!C?ILupvM%6SPQWcP-l}F^Yb(0aE_!6$vYaLuECo`T zBSqZnU7p3cybH$$Rmv~p9RSl|H$y;IWfImJ!shDpm!C4!WHU?0V4K1p4b@g_fL@PO6xITz2D4`?4GQ-Wj8-8clMwT-S-KH`lu4 zg)mz_mSbkXhehN-6P)%RPT3)rC!x&&OhlgzpGkn z;c*3|0u0Tvb5WZ;lYXyaJFdRZ8BH@T7YDEuo@2*(jvADR4?pK zl}BKLALRR84dz?DM)_HplxtvgL&Uqs^xqb&wfZT4;v%|n$2FGc4KFEKbU!P@I^KA* zL{@bh?+MF3&@{i$`Ip^k_CieNWqoqU$}h4_4<7Ksb>~Zb<3h$RJ7d5Hju_`+KHikW zwI6tY=ZjeG&l|nXh*%!Q1#k@@Fx$Rro4NwevfWKe-vvzlvuD)N(oiIr7Vc;Yi?0tj zf$d@k+a}fTPMI`@+FolUwwtNyWz{X9eO7f7FmY!T%HDbz&Bn6OBp6ptB+KNPwU@4P zdxKDa-ju;BZBJjXIfObn5iM&!Zh4_6~lEQ4Z(w~%)u?xvW- zDck;AcA!^5WuLT6@czNbwqbZ;0(=H{mFYvGlo!`KqL2EjNJZS>gza&Q2p5`|$wpGl zk?X@wizBw!oLWLN&&Crp#B$E}BbpjK5Mdla$Zt8)n}I{R0$l#E(3vl&q0b=GW*sEP zy;wQDl`}a1fEF9Fb52coux})ImY*CUnl3WkM^Y8H*6|cGzh3>c?st#g36;K_WUr?g zl5z=!DWMPb3945r)oZLOzjqz$7!r)}uV&5D*aXMpF!tPudf)Dnfdo2Reb@F-Eb(Im zuhkgonAPwOc&cdbGNVzRG>U8!EvVV>5EdO4@`TP6`bS>V1RBCU=;1BMz{!_rL9oh2 z_xbT>fiVj-w7BNLFcOTGuhs#hEmKrS3y?2jZCU%;1#Ij?5$xRez8)Ph zS7jS+O1U?bQ=JA<7h|)2w*zk%nR>zo){UV9T;T``BYddUXhBu3YzeYZ=KzmMzMn+( zSJgOhvC9_6=}S8L{sqHkh}+~c{ho1HGS8=mnN^CL;b_*tjGK_&P*gIx-Zrk}7rS3h z??Z};zMTnu6f+rCikiTam{>*rO~-`BqW!RI&9XWqi?!skvJU7jBB!Ex29Q@N4Hb~vw((xrGwk-V|Ns9!)9VZ#>i&I`##^` zs%nhYEaj)LxOgCV*GrlwBpkiEngzE9L`oD`x1N-kawYd}uv0CYrj&M~30K_36sJ6y z{LW3zSeHxE?C{*7p{!ZapKdyebv6Yw=>h@z8~N!ou2~trf`)Pebf4WL7ePWBj4`Ig z#9>uoe|7!ZRcw2ZB^nZh{J#y#y53yHPPQ5?Q|>ZaxiF*-AT~Yijx1iZ@vFL(y`QL! zO?GavN3rHpR;d%bQYfC7rS8MpGMPv!jzI3g% z9I3J=X}Z`5w6<8;uk$(x7;R`GhqP~q8c5u=pG}O9$oa$`3K`=ZOB?y}t_ufOE1Pwx zikeF&O=BbzAv&2=uj>jJ`=GL8lJ8eULggyNGWy%x$a{$CYhlg5M>dJ?Abz@eu{o7o z32Ek!qWi{9JrS$6m;Pmzzd5B_;w$8Igsgb^6?83&6N=-bcsB#UwsspBC`8ZKS1sv% zd@5>ihvCk2m!jCtcbyBm??XUD>3Xw1#pM0gerKks0?yZsau!G*+4y5)MFdW~Ul1AC z92R1#C&j>rCc(L6bx_dBDGO?h02(?78{&=jc)GxYn)-xL`M5GJDHo}qV z0ZVBl7R;(H_h12rRzLy8TFiGBLHu!51%LX!!U1%C^kK zHj&kkJx5|0p*hjcVM@w;PQxnQf+KSBpBicNNqs}XpTE2C)r%5(DH6ePv+2yAPmpwS zzmu$2^o{t4DQ?&mfY+y5*n;;$M0a(MaO$+J;O4hzWEiAR!w3Kv!8e;^%4O{8ITt@? z=u{Tv^^%EbwKLttY|GA!DQOjYB&Bq>aS3vQ*2kTUT(QrW^4mug4}UEx&KMq!)zqmH zx(Tg9Slvqx#1(3Ojnrm#0hug!0Zolx<+BSTvix=_FubmS-%-q^eE0b13f3v9=p@~V zH~8ofdqpA^e7N$T7PRlFEgj=V4I}-mLWZYVI&is_g#JENa-Ch;0~%XSRV>JFY4+9j z?lgOjAT!#m+&1Vh_}=`ixwsMGmW8q1`Fs8#>9YqfNP!W)%a?SWK=zxLB8eQUlP~{L zpG=rm#|=5WZTMJ=3chGqP^p;q-SSwwIW}sV3aez;e(#wmZMfrhb|>Llq+TUnp5$NMTJh0DS4J(l-=?>K%X zGS%zfT9QT%!I1jvfjQ^mRZe)~NZKIjRQDt~UKz~a%(m;xX2F-2A&ggNOMXMxZ;(^J z@xAmtHoAScCYvw=+R>M(NEfzhN&U&qP*G*Eys8n>wQ-EZdaj1F%@BA}6>U_s6GehF zWun#kk}cc!#Bv=aDZ2IHOrA}B2lm-!o+)df`N|{A20c}YFChy zjAVXdzcMKCkq$ajC?OJ7k?>pf=gbp9HPA%={>JB9d2g}`#7VX7hcoqCWOme4bZH3n zfWu|b7>87kSP!Gu_|xUnFsmY9>#tQGJ=3;BC7yY{(g2ArRUS{Fkl!7^00eHdNg_7! z76QK$()T9A2NvP?gh1<4FliW39mwz+YiRz>c;C#v*{|I?PC1V`v(IRWA9tg={I-dlQXy4>Z>g%PMyO6L(k)7RzoB z2y_NlyO&nFgairGfqGQQ@=*a^uIG+WZn*Tlg7q2NGN$7;l0|dq5w?l;w;=$*rDDOu z#5Xml++p>b^c7K=h8~sxTV)XIa98B@bl8O_Zp4i=uZ~$chxGrjwugvtC zQH9+V{x@Uc-Bl;o2>0>Hb?2V#xwU4#{PomEC7o8p*-n-Z=eR$aO48pp8B&~-t?UD> znMBLC;TKVdx3k4HwKiuAjY$}W-N~5Eq2=)5O{YFg;nVe?PBctjPc>wr@yU)05_E$v zvaNMuOR@S^wgZ2+kT1wgbsj3<@NEN{{KbMiwI0s{TMRd8zj_~;Fe(8?wtH+An*%Q`~cS>14WZg>vnk$ zo5(;Oq+;8r*6cboa6p*VAdc$44`0P1@n!q4%K^c{W4Afp`UHWa^;9SE&b_HLh1nIJ zmEbZ7DU}DrP3_f?7SlZ_j+xS`T+#?_L@`mL0Nol+(NVlIHQtnO{Ql*d6p+>|Dh))K zIpsS_1vUeg_@@0g5AG@lOi}dOjakIE)_ zMvxbBZU*I+RNrEbfTxMpm!Fr^ltHXSxR`&Z%4)q!<_E$JIyck$ZZ}ua+`WUIIIFwp z%?gKt=77J(T~najwRVFci_Fb=j4O7tD16k2ACjpvTDzZ@wnn(|j#;}2tILm?j#xNI zaj*d0@W~=|&1{boHZ}+~FVnV~(D8fyy(y{TmLZtOp+&3&fvGg29?=X@=d4seKqWAs zH^@}H$fo$oh+>p}$cgh$(f&#{OYVzGY0nljaTCW<&qK!GySc9`H`f~UsYBcYHj-EE z{{2kz=4g^ne&Wqo5y^Y?4mK^WZDkPKTFQ%`)3Fc%zJ|c@NMX5(jgsTq$90XR+pvII zT4B8}m#d!R@h{z@Y!3?C2CJ^MW5E|?QU z+9%2zx2jY>YlrvvLTudp-J;aSQ`uyiDVv)yfDWqksLCgbSWlNU&v<}1TZ9bbC?>3P zhVDh7LDPeGNUz)9AED?-3xj4he4a22*IB2YwI(2V@4i{4D6i@*E@tJi3sXHTulo)J zd{IRz$0ih*%bxQdKktMlRzh+rH2E7{cJkR*J74N0a`aroPwAJ;o7Mti!5th3*5GL8 z#p);2yxJGcy~D90i%_2$97opsR^RQlpIW_&*GFq3p7q`-jzz<{Crr!q%s>p1>6!y~{| zOMk>(?cQ?Ucypq#r50X6#C$B1;{~fg3C+{R2(y7!{b?4)zWF*#YmyMqA56Qb8y zqmrl_plj~v$h`4oKgE>_FtU%S?b1#wt=WLRuWQxbrq*`N-?gnT;4v_`V?7$~&T1fP z1jpA>STO8SUgRw<#hg}F@fFBCat(}Q7HkLJys`qQ=he^3vr%vj%6^(^5LM>{Fg*S% zeJ7}Ar+oLf_*>|JLK*I4yT@KF#0T->$GXjsSGOW9%0xwd%7i27GF8f2Ci1S2f34@e zXW_zE{oqh|+1U1eOx1?MvrqQYXLGfUHKlUik%8Qylsy)+#i< zY~dU=1X99nwwyL>PoS&fDX`yQ*%9R^e7 zPmydeb~MJd*is1)8b)$#3njz^-;U~8-Pa@7x5zB0DqW0nJ31rx{VGj1lOszPKPpnk zn(zl`qjqSTCoWJLZM5+yK<`A)T42pu1 eHaHaBYJ;M?)pvKNgmJhSN(nxwOn?X1 zImXpxoN(RjXe~p@w`3@4@OMRDLsf-w)}1QQy=NVmWtpSpC9W@^KsD^NV_lIOqowsY z-pH`UXS>RjRK)IDylRY3t`A?ga~`>}s(aES&kh#)m@m_fE<^E-a>m*fhRbN{?~s2a#`-7l;;2_4HbBulGtq>Dg~qC5tySLrrz0WL7ot*E zN!R`$B0X@B8eefdq};icT!1DHg?tf<(@1bfHwJYd0FyCIpHml~4trB%9I#>}MXOv)(sn4Bw52P5&g z|EW|H$h+23avO8c2^b%whkXp6EexC{*;B7tQo0Gb`7EQ+91HHgAOLV@qSL=EF%K3u zE2?)iCbfL4mRY=z*3H0~Sd_T(D@0o-)Cwx~;3u#kEy(m>lNqr*mT*C4*?WGilyza} zoXi@ISSEIDxJJc9C|iTb8y+i&Ab{>rt&ai>qSZTZulJzw82mhQQe%^7Vzuju%fN0C z^vYJiSlH=kyVGY(fS46xxj304>2&yt{x-V5;Io1i%_b0w^?KhdRjw%?M7$BN<8yir zrM^BHI!uV)^+dJ*wR#-mf8e3=w;!AdJwRNk0J#>dQ#2Y#uBe`Stx(f((R>ocTvf4r zF^LlKULdx27av{49x*2_9y$4DAe5+}kr&XTzNdiz;m8Kq=$brV1*V$B_#ifRpK9m! zi7Hz&x?o<1)iAU7lT4%W_JW2(?ZjADIZwcepq$dbGZZup+H&!g#i=6yf;X{XdNx+4 zp@=9&+ou;`3x9T-4uRS+4qqbHW2y3W8hrI*9UmTJw^FLN^P!&e9eoaLbHUsuV&9Ui zNZJT%D$%Z9n5Ia}9Q^jU+k$B3$(3Qecsa<6a#@qY3}QXn9nQEbz+ixh)}a+qsWA!z(R!4@vKR* zbvrFkRleav^e|m~xZNsVi1{UDnRM29b<<{BWMjC~r4D@$9zo z>a!cK!R`4A@ih8k|8HhvEn3R&k&k9Fcg%m{K~&VeeeL1mRMFJs*((+dLt*HJf@F@V zs~n5zdaOhF0^i?WwSQO(a7Q~Vpr$rKEt_22;TO$kuA47~t;k$8dmKaMOuXS$a0CF-qACvqZg+cRT#S=L zR36Wl_)xel2)3_0c|VmX5ywxA`lM4@OYs8G$xmJSKjs-&tGg{tU7yn3%IaF)TQX%s zx0m7mZ;cv-YFw1=;q@nk;J~aowIo&pOJw%S8wHH-HuO{yAy$A$((ZU{eCQY8vS3d| zn;bEsS~3}-qklh-fn~Xzf&ME*gY&;YG?+SH-p;kT&&aMZdiTBT5q)c z=VG&}8ezv~WyjvIy3DF-e(6+y`S4~rku^=&asKGI3rbQHN>`g3+8$Gx+MWqciI4Gz zC8Vt!0@l~pFEP^B4xRZj8@>=S*M!nVEqG^#p$27QQy= zP(68YW__oA@ael7@~R5bD4%wMehN`g8eV|h7MUA?&C~y20Y$-G!T~+cBJTXe6zH43 z-B4qG-z7J(G(y^aSFX*{e<}3a{N(Tt_aX+O-0svLUJ7umpb6g123#=KF=P6E8-Dug zKJ@B*|FnG6QvRfZ|Li=4wXd&zRu{j@eErO0uWPQmeQW)+*VfSIb~0H0xC6WVY^ZEK z>YY$qS{R;LeDpRa(1+x55Sp9WJmivVaz|=-q-9Y4>A=+bv{d~jQ~$c?v!cC{{dJj5 z_wx_hXo`Y^`;mEZR~=c&jSYD?;s35?{^HH}k*BgSv-)q0okOfJO0=bq?f=-eZQHhO z+qP}nwr$(C?bA1%yrc(j&^4>1QmIj8XRp1!W%sz|!qCtN2$Pcy!(+fJ_8p-PxEq~k zW^Q=-@CF8aesO)R!>a?3_v{U5`YKEBHl=`7BmEbU?;`yNm@mcDufH!j z^{-zJ%9Pdb-PiDmZ{N%|%8&BnIwYhlD5PQs4>hlmZ;-(|w*M0TePZhq{$1jB&Ny${ z=8yb2X$3Fgk8=AL{#~Peh_A$ZlheER)0MT?ld8SPxbKJ^3Q|)?__-ZePZw8zx!4{@)UeHIkGl2f9o846kS^xoLk?AZkYb^1o&vQ z|NQf09KL{kMP2@kwDW{{e*N=cc>Y5FT*O9eW%H_aetpk)8CWq71x3{uf< zVmgGXFNHYqtUw*ME#AmH&cxqV`V<#E>9|}vc!~H+6<3YHZ8-lk-Nb(LYi^;GwEt5l zaDU>pu?mKyUcqmi$@C+JV8)37BESg0GRrg=}U##rNiidHLf)=Wp?m6E)ae*Q021%l|Bv=B0 znnTS>F$*_w?b=3kmibX474MPt`UT<>nC+AaRgk8bYO^r;sinV!5PPoD_L7lOL zEIRreF!41+&|-}#rF1PLQPYqq(`ya&92|x8k04Lj6;0uty+Yd>oDIBVVFoIh9mKL) z)z8wdaX~JL#+_%1DY0_3>U9f5%36qc=?nR+J2fEYMxQ|vi&pPD4)c@;HeJ}>om-<# zY@Sikp`+@yL_j)oBazmVFX&<%ys(-{p2EHu#Dml{HU&fqf*+=)w%9%XK{pNKYuB59 z;+|OYd46YfWwkHq+hyT0=s_vb@==uIlY~L3INqP_2!RC*D81U!|`>lCHWxuohVr_$a;yOK0QJ zXo^Y}w`;bqAs=D~|FI6rc?G{T8!zp(oB)-Ehj1672r4zIU`5bPNAu*8^8!mQ#WBHO z;zhRHrrDfRP);71#?Jrpq}w51vDmX`y+!WjjDB!-B5uCuS+G@ibk!4`s>TK{ieGV@ z>h_KpPj1-lYg48pmfA%)mqzU!%M#L&D2mI2#%#S)%|7#oo06pBP-mOu7Fw%0)GpD2 z7Hp+?pz9O%CeOn-DlE)n(s#DlSN`E{2zWcC%BliFjGvY1LT`oGwAYN>{c}25ugtZh zgq!Q3m7=S0Na%afQ_4`EgoE8M&6!FZglB*tI6Y|s7(PmsVj#wX<LUG>=yW|cJavRwmQpl0~QEg;Vk`+O%}N3h&XqeGZL z(zNS3SrMbrVY9rJ~|Zw`UxV(InW=)9-oUYA16fc%jR@U*+savFRAm2`#**JH+S z{+h)Gjz#+@wL5{BJI@UuckWzO5W!Vf0}~|6#{!eF=e}|%MKW~dcP0FgWu;|V{^c5A zgU@)qJs;QLTSN5T*@yed$Vd@#*Jqx!=uChL=s^9J&OXn3evRuF>PRGJ-vqVFWJWSj zARpNYN~H3Z&X}@KF7v3nIax{P8How<)m^}4u;wB8ZJj7UkH>s7v{ayY8!UXpRWz8R zS2b)UAwW%5$0X9p|7eF^I#|G-8Q^;;REu5ecGDsFIw%r~fv$M%m>QM-P>X(L^8?x_ zSLyxYmL`NohMk@#MBCTQfy%tGXLYIS!Q44z<1e!JFYm6-T-Ne2AmCQLvi|Ed)ATz- zE;(VX6EUh(WyAs-odYNWZS<|>CD#RcIDT!gTnfK*^JZwqR;Ze}B>s1M1ySO7VroUw z-Tt>D?g|hx#qIXhUB~y0>&Y+ki#+4_xKHm<0)*HXxo$SP^cs+A5}0cGp8=#=qkO$5 z?2}2*dhM;YR2}?G6?RaaRc!MeK|}Zvdb#a;;5|i#a5PVdneAp4mq;dYGUP&E19&5j z+!9aN^Gx;nYkH%w$kq}80|Qwfl+qJz@vRwj^_!tjjF#yv@w~M|rket-6(>KKn!cc1 zgEH<=N2S1^;<67fz}kstixkc2X+MDzd&VXfa>dJ+2 z6{U*3eIzpYvV<%j7KR^b*tm9Z&okcJhO>;dsbl9!Tyl7lPyep!U}wNk+4N|r!%@&L zbp-MasNUL!@!Yq+3{BSDI2bC;I=TiiKlfRH$>1XhzU7L`uf8)<`I0B;>CRTLPa}iV zkQ-Ovm1i#{aA?IxaoKs;5p*@@n>N7g z*U1CmTq*(BOV?2VMJ;E$u@Ju#(*De2eK64U@~&S>#0m=U`2z0~{&zCudB_MJJ9NTQ zZm9V9mC9DQQraOn#jIr29kn|0`+@BPB^g|y;?!92gBT5@#C#m^$%t8tPpu}|Wnn@T zV{RC`Y^)+wu3S}&nX%&VkcP^7ur6ihSW$kd2dBlpz-n9o)Ymq{pJ#Jpzs0i;Q35`E z8x_D0##E55vAw#|e3Z!0(bU)cy-_`#a&Y7Mq6xYf-|CiDPUU)Y#T$x96pt8oz>9hAg2@8~n2D6_3Z zuxR`-486;f%kRZ8_Jb4iPmnrSINv7|VqgI=F#B3N#G~bKDWO*Vg#@g*HA63(`e`l! z4!PY8I}=dJ)Z@msbTu9^GOyJQwfB%e`;uG24*}GAUeqBVIQO}@F-VdZ|)ncGL!;yx`bAbX7P@ealB6ra9ql(T|)CCmwO>MIS#BO!j~XqDA4i*SE&9g2(1Y27xCtw&VpH=0=CdlG&cr2B}~J=u$fG3&xy|n#bLo+S#ZRwJfY8s$vKE zb~TCJ`iyTdE7RO5nvdO zp>;6kb0Er`v-3ejE&9YZ^iOmn@Ft%x{DE|Zg{TMYWXq>8!&F~il_pI}WIg!Ydmx=M z0uI+9by{|HDSxEcw;zu-&)aLj{Zq9rH(1e+OkEG`YHRE@$I12!lXZltducGR6XHeZ zR#iudCFaabq~w)ig*RKq-%C-bTY?eiG+qKh_q;4=&WGO;#*RC$OPzV?km=bTphU^< z#$SLJJmyIA!;1PEl1m$x%cHydmh?quvcRXKyu)tI;Sc<8v<6uBPeGBBo!bs#q7A$v zP28gOH3PBd%Cb4jQ~v_+ax}s~@TtC#gAm(iJQ*_D3*GgXVC{-)T#)Te6?GGix;)?O zHDZn{U|;0%)oAV|{Y6V7-sy+pWux;3K+!VEA)*X4Yd+fSG}{N9m`)2wf95N*ou0dR zKiZrum2@aS$jG80SHBkBGjv1>D_Uwi(Z$aYTU7rIWrh+)4^!T==y@@~Cs z?8q;Zu(ti^rqaH|Fl zwr=>Duai8=bRVwx5{NT{3Z$CarBk@AuQ``=X32C= zsT18)vrz=cE~(I~U9SiqhX?>7C3B)wz%`l>_w|b6(@7qF!diDG@VTnXhlxEPeR6iQl5^lqyJXLQkURQTm$A9+^tD# z9GrJG?dI(sowa-B?l+JsBT;eT_+hs>koAQabvvzfSS7ONy&8m+6lT44dKm>IYH&0F z#ZA)*f@$H2H=0KfxN{pkd}hnzo)YoB<%X$uXW=R!hm37kxeanJ6O!QMMN~cRphL=Y zgEj0FoOle$h|$_2j2pz3|5R1%D95bDE8U-ysKDsh{wO3ZX0cZhO%wOs%@{>KZkXFw zuR+N5WoPmORmlg%$-rbOA~lh4ahR(RJ`?%`t7E%WbOe25x^GB>_i&igOC@Q#=z62r zsF<@5*3-0No~L-Fs{a&atuUL7$^qTo7^7!HW!U~o;U+2HkgQ07B3wtpR){s*7w2QeO3a8uKl$|PxRU~vU51m`|3W%)hEma0w;iUy&-puF} z*snLKfkrqHShxZ@HwMUcS*c`4e#K>YYO<}2NmCn*6^2^*J^-s@Vwh3TnL<>%nIK1p zadMM~Q2h&d}G=+q2<>{nd3=)Dem7VrSbfbfX zHrW&NakVnA*~;AA>%rurd~d?xFH6}*R$orgN1nz|Zy$H?9C(%YIA~bI(bifRmu>^`{V310W|pi`k4ms%=jgw!<8%bY|CQ;`B2KfebtABaWQQM3`~!$$=q* zT9r&xFQzCP&i9rgB9A4@9qLiJkh=KO>7RZ;WNt#avp>J(DDD1!mBL<3Ki6%91kOnv z>tZ2LN>On-LXb$L@Kd}O7TZ~|B_Z2MLdt@}jmEh_6Sz(8Suo-@40?$wnDYq;O$8aU zT=t6_QQk4^JYKr0-N`6>?;?kLnp_hcMn3hZgcV;UoTtMK2K_T)z$uLrjXUvuMbB@-u`FfRH>$|Cgc01AAv5-vdtRO zpOB_2H{+QK?i~r~((|he4mX=VE&W5YUd-O0Zo~>xupiG5ja|OVm5zV+Lty9H>J!yf zE&y+u&@J`n{t82~QCMZb83@c0s`76a9%@Fva8Wk2o4xez7ZKgLG0nBg_hinGgi~nCzEt*WN3?JDOe50s(4}1Hac>`W99k6jt3Mc)? zL5%Hkh%F{r`Au2vp!8gR;)(}^8G`SgZNp3uQ)0FUUIaPzD+-s?-BWlnvR9l`3JwMj z;h2;;TpY%XC}HzRP^SyeI0UI;!cR?~kBu3M4-HY6*GuHTCKk zas6k!`AErcNrqs(pvTkH8^XP)n7I@?9-Vtos;H4Y+^b5tgCV2h|#rYh8o`YlC;)>is zhQW~NO*W!fJ>KiFpIdxVfG^8S8>;%W$=+Dqr%oa!{w#vqZDR zh!F(63RxTI@{w)V7mfg)|8gX3+mlUWEtRFCiFQt30X&W{Y{qtR)>-yXreSSLqT8yG z-t}#ulcunGE@UKj@;T#`o4ar9Md(F{zBajxkPEqR!eY{U2X2j!;py{0M4QhLs8INp z)tDiV`E8A!qwt3^YF*UkQ=4tGS5)Peke=>|&$D|L1s!2plkW(LMI9@+zE(Sg=2Gyl zgtxKjK9a>zvf({c@xiPKs~s2I(_^@wKP}#wwkL<6l8u3Ve5~%{8CbE#`A(GU3C-B3 zzdZ9Ms3CgXpLWoecCOJ1Gu@mb}R6TPQSg+dT@R4gTdAe z9FfN1_dNWed3HnNh^L~R0+aQ@GA?qponuG<_Xlhr0Bsv7?i6TWmssWdUY0tN11)Il zYYv$37-@Sy2T?pi4ip&vZDFB<>IVwlcbbnWJr!Fyc|1r5tq7QW!&x%w?73jtN3`{0NpwiaXNZY@k`}keC&torM71Kib(OH?Da@m%Y|Ki|K z)y+>Zfkid*czCm+g>0#~j~I#A>)Kpu&6VLr9W4PX$DO4rtAx>DgPD$EJMc_&&;%bv z?%=p;NSBS%w%|2KfnP2L*c1mhXiue6+5F}wz!nLh^(^1AWJZ3W1m&y+yz|YP=seHr z9lvdRV*?rYDN%RL&H4IV%qkJ2JEqU8#}uBZAX!*GtQS>N2TiVqd1uSXa@N}k?4sEP}X&*TgeKnEd*|B`O%IQZ$A5ex=yltc9V*paXx@>rx5 zZ9_>wh9$wnV>~3wf`0K!LbL`BRFYXMnZ9C!Faa=6tXJGjrFJ4{|I3r*{c79D7shGo zlBo2itbvEl9&c=uXe?B}#$N6}*rtn1(Wj0ShFYNZnq~sk%|8>J5-`FRhyZsg3r{_X zO}W=IG;lrkG*yF^(lT+>8t7kPWq@SZ5T5JPwHGZ}uDfF=>xOhYnJW@PJ!1XY_@F1~ zh2R@*Tdd|RH*<=~(c?WFDTgFGa0dy_>bOx2Pf&h;a&jQ-qV&V=h1FIX{tqkWTT**R zz;2Ks-xC0Wy$LcwT+&o*T_1UnQt?Rr7wX*XY^7Z-NDZc%%`P^?#28dVKU>n}@Rp{u z8frhD?b2FhUi%Xg=>tLif&oJ6EKhBhJ3>!|bjt4=(JYiDxPj>{rhclyQ?%X)ka1#D z)C}!W!QqL;dBn-d;8RjPQJ|cC8VY9yF4F8gXUpGwfv{$oWS^8{UG3jq7>;Q0C*`5} zOM;xsnh3d@rFcx=0WRTqD?z5rj<>stN4}`^1!)r|OI9Ec$}WYLC1KV8ySn{gA-YE* zo~F(y?=#(mesX-iObExZCVd`(PA+J=#S23S`BlU-H}MUo@!`I& zduNqrG)PLy<2MxMOWR?!&hy)KPKk$4TGrE+d)wy!WRw>wAS8_n|cn9OVSJ^PJ(7QGvlopD%3#5a56qpMi59w79 z_xxrCgb;qH6PRT~I^5~oQsmX0Y$mE(soaJ$1vg6hHQaeia^W*J%Th9q1o}cLJ7HV6 zeM^IQYIKKn=zvtuwimO~hMHmwjjOn5=cu9?y_hxP3)FKKnvgA&Wzm&>zQn1PVK9Bv zX6jKD*_h#C&&KKirJ~tbzRz3qK*h4i0C)RWf&M3`LxC76h2h11ezE1rso1qeG7s4; zZ`P}kOJP*7gI72rtKu-^w<|Fp*)!iqcS$^A+P&pA_`Yns`3HF(kda^vb4p(?4)Ygz zkd@EREgHyn6FxUdTp$Qe=F~eHo5^TVxSgu86zNFAt^{m|E1S@eQd!DhVG*nKE-4F1 zjSKO1Y%L!9=5C0Z&ti*2U8@~OH{4i>_EJKW4qrmV$qb1eac}hJ@l=>!YwG>qw;Eh1 zSclxx3M4*u_y$%QPT(<4!0fp;P4B%jk3Qlfr9G|R+6<9nms9i2;nN$oTO+7 zY>vw1aV#}4oz6riYspu*SUlR&-F3g5Q<3|=wd#?DX*{prcH4T*T}_G!1)mEC2p4`bpNB?W{nKZ zyky~p1g0(yI@%9haVNje7$Fp9F#U(sBro_UV{hbOY{yi-8SRYkEWvKUsP5R)KmWbX zK~S&82#z9Ad^NFP62v{e6MTwH+m7}GhckxcLWuq-FZ>^q&6Lb%j$BRBudv%w=MRTqsK5Z#emYyv z;h+J@*)^YMCG{6>LY2zmYERiP$2n>`1ldvWcxsN_-^HQ6=hT3qlGiG%;?^yyIx@xSYU-Hh};ox<0#0#&MQH4~qXDn5;@Qf{74YLz$GAt5@E_l~X9_K4dRfsmv zcT{K0*vVSPZ?@w|Eu`F>g#qxhs}9g(Csv${0$!Ef{NsR^h6A$tfMz4HxodK>Ez8fu z^XoQ|R#M|bMX!5kaCt(e1>k`*g%9(rT+Kt@xrh5Sp3z;z{jo-lK8z=Jx{5LWl+5T6 zL2BLDS9ZZ%+bgdZbi$}MWbKI>y-(_k=@EQiItkX{<*O?$>zl=$n-CqD- z{fzZ@s3X%CdB*s(F`OAHE>5{TUWtSBj9Ud|v+l^Mgxjiar!2LVs{PtzZqbXnpsCqNfXCra-!=&H9f%|3sq%YC8X(Y> znn>f-M*zp}jT|$IB>0Xf>>J9voODnT;U(D96Sw62;2Bmdi*jZ}Jh{$yJYAsS(6)*- zJWe}7Wyo_=Of_0P$9W!IikB>n+S%(RF>F!pm>NSTqL*jt%zZb8ZA7P4l0nlZg7?L7 zU`hTL-Xx-OsO8-FTyN(&<%bFYf}_uOpCoRKRLTH|Hy33no?>**yK1=VaWKky=4E)s zJ0QgLk>F{v@HI|8Tpe9PT{=%Azi7&WM!;`l=9mk;nsm}IrC{-qaQ(M9|IT;D300?~ z@7k6pp4ZZIj&1)*KaBntvk>h$k$|!k6Fuh8t4CqGgM*f02!8wC-zvEp&vUtmhx{rr z&^~v%Rd`FT-Z#~JXO5M~V1lp&@qmZ6Gjd^QR6y|J4tr8L` zo8sPiSgK#qexc|!ezT*Qa($4Z9e$c4OAe^qtqwzrSH|D@+ z!83y~;pVpO(~#g=SDkm_eD(#+Bf`xuP6m12hwaGx+df;%5$jH3!?Rtmt0=USi*c?1 zo1`>$fnYOn1Tt|!))Z=(Fr|=L*o#s6U!lnWX0%jvbp;$4G=pFA^_VM!gcVIA&-sA0aw8 zGnSdcb6*^KF9aVmIbu=<`+QOIP_Z4O6-}Q&l@mmJ6%Vj^1lw z`6ElhM8EXzZV5BVup#nF))4!8zK%6^%`%W#I2tpz6Mq!W1h@dW9Nv^L9K*=&pW@T< zKuyO~a0BhiN>Tc6Z>7fekH9hL?QWpmj86knWs4zoZp={gX+*)#VNN0L1wVFt=|u4B zjz0bu4EP0szrVNbU6|ApqnLBE=;q4CD{_*r#2-!W9V=j?do7w9ZAT@ssC$1fgb^$4fWeKe2Arp=dvx z>_L|lwpU%wOqnRXvGb01<~6qw_YuuP_zzKtIxS)kWRMFI-zs7$)r`ExmGG6cQqNun zSHml$S3pVgbT(PIwJT*{uryIxBZrqOf)Hwo1jTh?A!n%#?q!Zl2MOP^dJ0c}Q=*C| z#;DqZi=e|UIoxu z-oaI(44R=_U1U-jWV%HTn~KdS!8h$?4xqm(%tG3bF7dI6e7R4_C@kQroD{Ad|8x*F zE9-od^#=VS_w5rw`ZA{xt0X@AGeFswRQ=gH8e^cmJJKhM-JmpFnt%?BR?hD6-h7(t zmDM`Dk^KuT%i!33d$(gVG*TDYxe^RB9)vVkzzeY?T+xhP7aMm7!lD?N9`qK6)ME6kxxD^b)hY5!Mo3eiAI%91~J&+&bDvmS|_n3?5YXKN1GKZUnTvjK!7xLOgc@z}KKC7W@3@ z9BWH!zIabKmEB>SgExLnSF?k;5-O7YP^I`5Z8-TJPhP;z>!yDp$|Tikn{ADE7Go>z zEa(4;OTix&BVeJHzPthVLWS@c`G~d9brzd5Na9lCyvg&N5ZWK%9T;*tuL4Wi(aTI) zT`YEIaX?OizTZapIw~nE-ETA@%tvO5t>)Rw1e4jT2vgW2)U)f&2h3-78C_n&kRT13 z2BGR8y=bMAH-{Qh)m=`L8A`EF4y#ttp<{HD{KZgc{o=$g4*A#bu~J_;pstL?q!{ag z-risf;#O_Ts_|q50u{;tmEDPSPMzR0^7;*Qc61N(&K=VXO30FKNv`AD}37&!Sr|Mow zNi#4+4jMm?j`XgbB{BBcvXqSN0Q3>;zDBXUPFQq$d1mK`h1k~gNgs5K?%t6#;qiUu zJ4X2$Yk$)HZ67^W1ls9Kch-#}nkR>t=y`vC!1WA z-QMv_!l8Wb=hu=-?R`#a4k!oL7=8Be2BKV?Nc*IYGadFcnXS|8k`^k?mIezQ%6E)J zlb`>|iM%u)T0DZtzP8wt=das&>*q{Jfm7Hecm}z4e6(JC&I+vSdtF=?N0(c-7St*_ z-OT0{kaIi|ElqUsct6UxMacXUy>@G_>a4LLrXwTVl$hS!u47^W&1M@(snWvALjpgX z;Lerk1Y5BWBKf3fa=2jnbda6<@n;?ww6V-P>cZ==FNUOlp1^aqhvL^94U+!67 z9Q;`oGa2~3xm~R1Edo5an}==fWDy=F87KkrD0tW(Mm!=SyzdaBrIwtCN(F2_E?2JK zp0qvSucgeE02Z3#D~Jc#O*p1A%Ph;j{P)x3J{DG0T!I(7eSQA{b|nMeYV7hsiRw;o z*D!77SKmu7!((SoezJ5bG>dsyl25uxYYa$6jZz_1fBDEE5p-Lf9+Ah9T?e0RDZeX!)(e>Mh{w|yuIJ69v z9H@=kkSxF>t&vxtJ#>7Lo)X9O{^B4Y2NIzwxF6Nlh!4@K>_dg%jhJr?)%RMkxu4hA zt+^Jrvuz~$MQpxMP_1AN4Yt_qTh@1O^Q7I-*n3HQS`v*V>|qP6OSlx<_HYJMVr%2g zek@^*Ab!nAB(~O*l6;!nzds*G=U3c&8}c_4HSK{n!lSv@vJuLKE;)N7^zM{VWf4N} z<-1$QG89T$voB9Vh-W52C)A)*q{v?v)5XFLD&%PkS+n%Aho8jS2fWc4^8U+kO(hB; zGoI_jX@vsBF7fK0oAs0s3$et{x~&5A;q!wfwps5VX=5PfU)mbzsLubuHPS?8#B0-> z-WiI3inK=y(~lTmw;S6`F2$g*qy>l0NTj5h6UX1^7fec6_1PwE)h(8X=m5`~L*r-q zvVoYpsWEp1hU!3T(9;y`)GH;7w!U{LiTqSShc=oiKh+Uu|uIFnf&71peJp>CMCVFrHjACz+3!$FGgsadsDP=Zp zFtH|skptXtz@t-DGY@v+(V)r8Jf*zK?-fT8Act5tF#55Hek7iKA(kt8=qWW?*7Ymcmvv zuzvE`f&mjq?~Ir6`zUwR)3sj4b2&N-!);^Bj4-nr)QkW%@K!9x_CPL^x1i49jKxDE zB3CKhE%e+e?-L?5QX%mqyXLs=$&DRo+mAMbcUSqMgHn+R#td$l2~`F$bf6Xtg5iG2 zKg@u!&Z;R$5oywtD2Sj0yb^uGP(Jhqgk$5qKFt$%!$d}P0zvJU{-@FqS)(F8sAr5C zh*V@7J)z}mPIIVf!PG>?Ts@FNt2>^2p18nz{u6gCq+mW0bPhsIC${#_s8m-iIf!-% zYYFV#x2aj_Y8dA)+_ff#TGK5XR$_7xmhy_BcV?Nl=8q_VDx%Q@6=Q8g{~X$(AQo@3 znEz-^;+QgUi5ns}j&i(n5w~6l`FLJ&ky=K?|IdXqWj6eq92OTlKw95Vk2!NQ2QXC% zxVPR#*+}i81J;U5XekHEb~QrKei#(X!n2{o(7enckZ{j+Lgl21WarotBQ3NXzAOgd zyqhH{2kBYoV-)(w(T{Urcm;;PO+1l5xlIBhaeh|j61oL8tjuO~Lj z=yfw-1s^hQ*`JDS1^{b8&Ve0$OJ;o@(^x0yFcM%e{qP7z0aGUg3}(hA&Tj_i9GMzb zSOuq{%VPxRiK`}YVh7_KKZ|m#mN1-DfN11$EhPUZ+PtqgLB5sjE6jcZrp>lNut&Z6 zvj;fC6nQP`U~p&E_R#W)6SS8ep=Z(OwW~{zto|0+%=(hBi`!yD(T_#3woF?d&4L>q zOh7d$fI3-W4%=#E!5}0qE4RrubJR;f9~?-vA7`v$P${cQE;8d}PqT~5ga{|h(r0LZ zbYzi}w*UV>5Y~H0XqMoYF`~>!Dx#)8@`pvJ{OmpCBytv2Y6b7`z zXIB1KB6EGw1aqBI#`P^z#`ZC-H|3}$7G`iIS0+MpKGBDm1`YjmAT(0NkaRPf4Z*$s>HFi- zb1s0qKbDo@@Gwx$HC6UkK@51MI928&P2@~l}A(V>$%)CGtX1wgdale}K4#M4{}O4Ne(;mb*}{YM8CEY2+Jn z4R5Dm7OhkA);vs5z(R2SM8fR5rG^HzZ1;#eRx_^N3_e{Pro_3<4jSNlK-{ly%U zuznS>#St#%YtxIWN%)(j5Rhz@gr3Zp{j!J12Bc=hb=o9<1FIDzV>{c8%cLGpPO~*o z00Alj(Z27N(^A_`QT%hZS`M2(<-TLSM45?y5|{268;me}gmQS>JIcvCQ$>=uB`5-j zfgRRRDdv?Zo+5@wT7BU2QpN&S+Am%NV>Cb_{>;rcs|!GdOC9c!>BO$cXT$! zsWkj}?0pU68o}?xq=YoLb4_r-_Wl&l_`%D=EYoOp5N4*jXlZvZ)YV=?*&tMZ+7urW zTD&}dlot|E5i(m2t_qe6Vt719Q`c{TQ;9Y6HWI8s7sy+3!|m&p9DbkR?BQODH%@9J zBpz^Yp!BUmW=nw2XBxy2OTbkQ=`raZoEXnKc)`y(xqmGt3l0v`qLAv>dHz-C2_e^@ z)O_RNpbplF%S2cNzk*O7Nr=&nM^5PA ztE~x+E7Kb@(t#`heQJC1nvR@#VrZoVx?@=RqR1IhFrh}-Z(jdqO8pMwD>v1+p1`UA zd0O#zm{(s_y9rGs*sw3w)Ps&U7rBHdKFo0g_Md#mY3VA=<1B{+chgNm9Mri@HxK0m zaHj_S8L8^@NgD{T@M`_(<7};)ol3;fcN;rlH>LQ|UQV4&XK-Hx|2LDe+Ik?`5{iI* zj=ghrT>I%BqmW7b6_&#Z3y%fZ7sBr!dvJc*^(WVi2T4R%cz78HEF8Mawc$?j)G86* z-a(bt3nrwftw<=WR*Z-lWRYXQ!6ueFP*P!$zOd}nckJPKRxFXQKy+}2zg_eF@)aY{ ziHEWHB{I*^YXHjsY{n3r5`__@Ro;gX?vdVvtE~xmo9!{^5Yl29Y0$RGxdny!xOK5> zjP*gN)q`*bHR>APpcn9Y>X*c8u8&AsV z&?b`)Kzv7*8Ez>Ex`ZAUUh{^ota#x0CF;>MGwGP8F>`=SujSt;Zi%*ZUYzB@E)N0BHcBStKiOnLP_-n%IdLT_$UL{B+@-LNGXnwjVNN}?b zd09?}*D2t3pPIg}K}QT@E-{91oV0Krps|;J3t5S^i*=+%r#wx3Th#XutxN-ey7ScC z7R&cNq0N54)m9N8oj_5&n52)5`_>3;U*^8)b*H_BqrSj^Yb~VtT8zAmXd3OR2v%SH&{4&7&Wzm7&UwuU56nrAM0RFH z-!+F|o=i}^ey(;o<j4zqlTAE;#r4j?76|5R>X{^M_Y4pDc2NQ?jwqAse1vho7Cf2f@T8(!ix+Q; zxrkZcwnV@{)ISBtzR9&FZnP65`54TdrBDsDCw}bpjqRn?{%s6P2@2iK-@=LN)1IYj zQd~+0{^frK@Y;%eIOE9k)_Ch^I+1U7D-}$&w~&FvLlk5_pnjzPTEa? z$ssl3LekfuOyGpiqgI|FN$pJJzi&Z`=(oP zn-9&J>|Q^ky8HXVrSWY_NgXUcG3s6cCWf#sC?Dclrh|7vW*#XPFpxSp%IC!|T?i)v ziCCf)k2*X1xd!k26>%?2w#N(vJm1I~Io)xwZY45A_M1LU zT`lAq2x}r`d?57NpAHnOKD*StdH7+qehZE9i43>3p>v09Qe%iuR=Wtq3x{E#jq^+)+z zI!nLvi{r}1wszVa{Q;|ZVHBOl8Rn7L@rr6m&PIagZ>dUke~N<`fXbm6w6W`Z+1zT& z*ed0hv9=8&tRG5|#Sa65!z^h=#jSs@c~P-dtn`51q|`lt1Nbwv7)#FAm)a>@T&6@B zY3^H_#<3+B&C+zo#h(a;=LNZB+K!^vK$5WoO?z6wO z&t4X*n~gaiJvXo1t4$^=r}|3_DDrgzn}SMl5KRDLh-4sg3#`l_e*k=WVFU*N0Zi)2rs48wAl&_h`4xn*CB@b7+|q-HFqO{kv;f$G!2uGJk`4_fPYJ`#w>{d8uXW`aIS_q z&02+jog7a~D-VJx@?6DdlFo%3xZ#FZz!!EE&F@L@{j0k%gy8zxH(LK>kHRS0zs;SG zIq64_{%@hr22P%tADNtjloSexe+NL`F1%>I4oH-@c7AVm&vY6F(6?4x&7a2<#vEW8 z_dm?Yqfh`(0YGyXICK9UAI_gPVgNq?7di-ReF$eig7DvLEQ8R^pQh359?mIjJ%Hgk zI1qrJ&##MFgh4tE65!hh+xHtHbVUVaI%fI955|X{tcXZ4TfZE?IubrU1sI4wKR$zh zdpkM)exAp3e?6biw^%jUATDJ5ca_dG@6S%-86KSdA0h<&eqM)jJo>31;PxNsCs95* zLSTpg@0{}=&f}laM;-Ma)xuvFkqSKfcU#^UUH{(^cvt^EuO9;Xsb@X|<-Dk2v;VtY zImI*Gg{9DqJ}&Lw%?f`IgQYw_yFNM%KqnbQ_gflHsA7nR(9N^HdH9iD^~aR$x0Ibd zI#6Yp@PIFm0lfnMzTXEuVGz4fE+IJ#i(gkhI_ytVEfi2-^A`!LfdT`-`VP*uP%wwp zv?TIA_+a@W+~rT!Gys7B2vQ6rpuQ;#z&g=Rgf9-YI5NI*)CLjE0E26x-*KpWdzVr0 zYZgfQpkJL|6(-b6s9^Z1SvB^c5QClsN#i|8aFaI`nT`)4S-3j&>~lK zgqd)i5;pM#Q^JP&zNURi`mA(1_G8kb1#z7ZC_Ahcf)EFHI}tN(znUrUa1ejE(Gx z(biElOPMS9<{rx1V;ii3(LjtZ)6?90gL@IlE!6O*UyutU({wqm>%*9|OibYMkt+zI zCLFz8*#ULUXeuE#rCoC!NAJiQ2k|53oJ^7kXcO%O#;*K z%*6RO3ATlaAc{Jd8AJYbqj_R~-x#zJI2*Ey8Ye$UH}3_Cx#cfe(bQgXhMtGK z0;w|C6`;p1LDd86{UcJLhp}COyR;+Ep`2mA8n_^kCCwSbf zbta5f>#t87g^_`8*Wt;P1CK5oO|y;da~QOe){w+z0dsjEOTD4n@nPUO<)R|*b5nx| z?^@*#F$O=68IF(PgquP92!=BctiEdH985=8O&`Tpata{p1iPsqiSWvvS=jx=#{rUP zdI-h8Z-4DFfH}9}2{{Ac2kjeeh}V55%xGqjuhnaL%%by3J7gWWIIoN}^DV24klp|7 zLa_~y!^$PS?v;_=?-j(RRj+E`ff%Y>rHpiJBo|vlj}xp@yUHEED2vAsrISNWAr-z=1u>V?#bWi>rmr|&^QLyAL+wR_AeCcp0Zv4weYQmkq;p@F zArg4I9JxL;zqxK$1j+0>LMP~)kh9d$Rt3RSv{F-U6|{`)2}uezQ$B^29&Rw-4EJJs zIv;t?vH?ZrshU$Lo>$Yl={AOS9d+2L;(h3*EXr&*`lMQ!@%h?d`2wgNEjGu%Caro< z?Z;{f2kbFL%&N35mtB6)muio8>N9lvBn^|lfLAJosHZWQYhbdWRjV$cNfKgbYEd?R z4WRN-{c$%lIw5KvzlkziYeWM5VBvyEoIeh?b9hR^2|E=nIjnkn05uJE7-P@0Sr}Yf zA80{goPMgTr97|iJZ>PDxMT!f^2%x>Fd@v_=0Qv|01bG74vBnXJiq*66qyi_ecT(= z5uU8rfO-yk=IlTkrh-)Wo}^>3uscN^y)iBe5iZ>9?x`F>`PqHD)z3AVXY}Fm;L0el zD{I~q+p69)52w75Ol>7SqpF(B#|1~Jtrkuu)G17$GIt`2N408HBh}l%1k8PzqYZ<$ znmdB1AT9e7E@LHS9~+DmT!w(AMU3^zUBb!T{Bw!MW-XL=`TAS#Eu5#LyqvDTemgDM zJ9P2=#+g{ll`>y9bFUut)H_j@a-R%u9G0jK+|`PuLbkOGGgUg_G2Kqz_`ySYWD*HD zW`wukVjCNJ8% zfXJLKOP#5wx5Xc3VWG^qRwvRa{}b3AgPZ064a{mZ39;x5v1SJlH1Mj{Wz zH3}mim!(2=Cq!+CT!zp#Bw37ZY6z0aOj1yX+=~JS27MKhdW0K4kturM(whv9+is-@ z@fFcR2#C0NQot+uq7Zc)7pR5BW|Q5aVVY+R@5B-oKYWCs@*OG!Uk#TO{yrmKPEGf$uS+79GHK=qQ9B-om}&Bg64 zu?fCsi}Y!iWtz^2^z8hv8kW-U#ima zq@%GOT1;pNmVdLp{&5n^iwz_ywDI`nth$8aiec&J6N zl3`He*2bup(&Y~1?L*Q-f_vB;mg%hi`E=E=yZj{R^J=}DoU{*Vf1(6Reaj}0*DW9Y1fpE)^e<>iMa;jP5-Ev7&jhlEU zl+Oc%`TUsUlB#w1xG0|vkt0pfxYJ;t$m68r(AAVE{;VmSOfYAps{+`K;f|qwesWHL z%KH7W+P_#;zBypBRmIIE$gGdEJQy@QwX09ByaF?#X5@JhooxAfLTc?l+(Yy>3P z)N*lOFeidN^$g-(WSahvHhr6 z+}coTZ!->xT1>u%W$gSFX}`*Q|4fjrVlkC#jUrd0O=Ewam;l5_tMVv5nOmP)hty&R&>Oh$8tJSCFYfez#-v>&F#4%VuWT?P^O^6Mnh{-7#7tH2UhuBT)pY_MF379@q_Ac_7z06IZ3G zz>=lE4R!hnzKutY>*mK9FM7K0IPanw?l5%(q9zv~3_d+5$c1yYRzn7fW-NLeRlN!j9EwgYScUASZG<+YAB!xkA0@SX3qJG1fS~kGhpu3q`}S^fS4K#q4y_ zSCP!tK=|H|i_jPhcPn+`z_(e}G3SL!?h=v8pLA2+2`A?4RHb}WMfIWFk$L8}Tg_p_ z5)Lo2Ns*sASeF8QRAs!%knq0TM$IvsO+Ca>UpZtL!-XiaMVU4UA?+N0Y;a#-4J3?s zA4y9_%<;HvdVdX^VfL&`o6czeHqFE7UDDgwD-il>&+c4dyZyKle2IPdhEOI zn=_#_Qe8_D8p}gI|6YKb>gTG|DNBwbqWyHJoxj=lLSus1Xv+B)y=J!n1hlh)$UOV3p4L zhTqjrU=SV0DSO)xYmNalpgZxe_8*Q_Y{xog0QKnbDF}&kVaWyI5|lgWR;ryH*ZVy_ zq8hD^LPs*Lr%R<^8jH$VNrofF6Bv(#izV3+AmsDp3UDNRO}f`Pz<~ zjH=TlkHKmRt#kdhcfwtohg_M^ynIW^l*s;b@H(DdBdM0(wu$-W${V!a5Ql+3AP99q z%XSfS(wsN?g(A+Fc+ldaF=^1~rrVs=jJQWYkV|U;KfH|T2GosIqn{vU%jf53f~5|k zs6&Wn4QxrUgz)yfgBrtf3ys-qjlg|@EvEc}MY9+Z$&<{949Paff;8z?=Z!;l#R17gBRnu}8;sxzKm;fqDIo-lu?9zq*u<=NWE!@MPKQYcGCs?Bz0nH&+u*^t4#JtGoH zhvYl;AqE&?J1zdhy3yrpO?zgT_Z=OKE6Q=!3&ZT(otieUE(V>x6i5Oughkh$-8#6G z3EXq<#@+mcCc+yA?7W$Xi~VJBC2eahZR>v9nu+O} zV6eMwH$S~o3Sxy(>)Z78HDq*Q0a^vM)%&Rd`KzkZRC8mA-kf0N01IYh20coClU<3F z*tW_?no^e7g}|BoY3D!(t=)9^!|q*tC+B*60Lqz7y~Q`I2dkiLXUgk4DI(=~e2QxH z6m%clD@Tug`AsyGw_0;GD4Nv9b@IEg$eqW^sp@v~gyzM)31-A!2L#BC+@gcqp&C9G zscC=9UcaYGbxein>idw_=&1J(SKV%I#Ta_YPv)2ZR}wVJ*GTM|W*ZKN+wXU^tw`DCBdjHKhFB8>%XON-;woL5m=<*gj~@lZ=H))pCw-AX6w z!cyu?&b@*X?iwmvp);p#nQ9F=h_h*7lNya}2&Sd6Nh1vNykB(lor?{tB4j#InOVrO z7PARA|GYEuk@GX&RQ9UMfa%2DP39FiyPJ&mpLe`m#rxE&W=xfo10$h-O}*EAClZA; zIauYPGzW?A8r?rbizNvT)&mLWonz(|c+tq9jn2^YQcMl1@OkS<>@1q7K2dBRp zvf=~k8SlP24JxO;eo1eF%sAvca}3T)^)F}V;}0T#AML9}Ub&Gls1@BOu*>PK2)Ka0 z!sA>^9!fyW(;eKSonoBMsnhM4f-7C}{S(1qqf9+hNUtDTAZ}!eN`|#TcWT>0-jtL9 zr#N@bd(^e`TOj`74-!H3>41AGq6*d(6J1*BfO8AGbHby!VTyJu_#C#iFE}BVwwa!% zRB$y>5wc{!t5ka#zG;moN~eeSCy>x(ay}HVr9V#n6G}GhKb2<~2j=Tif-!6JR4< z^WClbi#&xpT~>EAJTYsS2GNk3(^4HTbfGf>+y-V=VB}?3PUN~0V3lOcj;9glnEQc_ zylDZos~L6TMPimR!h)NXIdud_Zw_K`6O4LVWE);EXSiB|Yu-Jd4*P-{O}d|2l)>q` z%Dp0{$N7LS0YrI?&ZTP zT1X%$YF6VxnrPOCv`Y)Pw|$Uhj~Q53ZYGfzHBK+TGy1nE$1S;Gu!cEox-6v&CT^Yd z+rJCk2IE8lVr#dZlKkv@D|+#_Rn3BO#a>3V*Tkp-orN7?9fnr`xfnOf-MT;)45vR;hblx5_e6neN^%K*oMX#- zPy9*K)UX2D#+=7I7u`s7FM|xv*VulLV-e?D=1_Xkz3@$0YdQA)^ePr97yVdM0h%S- z7A$!}jr!av=~mlx%kogbccYuk zVEov(`_NxvUfy_hol~j1VrLviG8yY?4_#Z6`rZy`_`pEb$AR zy$_@lqO&j0)(hq{9)8-{!QK@}PAz#*L@u5%y%a$&a{w2G50 zm8C+}ozTnUrDzxt-2oV9mg^(5`Q9EJ0%{}vSHmrE^jo00xhPOso z=$hDYW1bZht+@^Ghw~=f7-hiWT63BR!5Fv(H7jXP7uyeVh{`6Fvy)_Jql7m$L%1}Q zNjqhMD;Y|d8_=2&_;c@{b_)lO(A-5PwuKtEB1wTrWpb?taR`yoisLdU6z`)Df`OMy z+9#iXGGu01$hf3T3$7;a2;P@edXOqs+S6@gV)v=kmI5R~&cyvaa_gWel`*RiU?Xf3 z{7rE~+=iet_xQl!I0MDWdXhKDE%IS#$4CyL&yU&3_q7W$`FF0T22xMsqtVnw`)$-a z&Mnq~N7$X~A4DmsD|79sYm_ASG)7X!TAuCKq954SU~aS$ABYK+d$PSV1-bJ$&G+Y3853(xzOUew2I-%bc2n*y{Cz)|Lt@k!?bd3 zehLmCcg;CTh^^@BeY^j>fNbXIhrtz0qnI_EbLeJyU@Dyt5z%}ER&1g!+M(yM-Vi?P z$>(9Kqzl}cb~)z&A)cT6*!P&%i=zdr;yQ*eTzvE@6i|XkYW8aL7A~j{nCXFKLdY(R zohufSzn6so=JAD2^`weVFJ#F^%Qj8M0T!C-meM1-m}jx_LM``rvLZagt*O3=QRWkU z_;vO+&1XK?9}R47q8s&ZM^9G2UMW6ss6CaO*uc5Gq6i`gU{aRTnen&Tr`+h*D~nO} zk@dObzp~fO@q#tVn@E&ZAJ|D7*#p5rBg<{*FHVwC6`#r z_;HlHW|ghfa2t9O4b2gI!J=jo-5}%_42P@Tw&C~_EfT0paR;aNI76vFVA@)Ed;o;z zsNWl{*6UhZu9vIDvVN*Dnrz1xjE<#aqW~JZD_zVXg`bAhv^dz*(VJgdkuLVQmzB4@ zQ18znlKtlWV8<}17$|oyP{`t*@8Az5T zj#aq48wYKTE?ze9_I8;ipC~>c)BPQZgYc|A;HEX1dUq6PX1!Q}oS4`WoNQ-m%FJ8Y z8JDmiV){Vi(3i=nS>1OT8W&OPa%jJSBtpuw!tXMpBK1LLsMYYD1I$Sg$ z7L)oZg>g7A-l{&nG0~lj-Yimo( ze*hq0V7D6L8grAn6%2-^Z;K#S7Xr4=?J(2fW~%E)rAtMDX~9CHW~<9t1%|0D{cl5S zQ39Ln@Yq~bT2_!00Df5|$;>pUuEBw!p1}cce)003wl$z1Ba!@Nz;=H=>F7T`f}-tz zrZ%;$_O12zJGT4Utu9|L@r zFrgBg`zFJHf3^rLjEzq%Orn6hGOY$s`9|-qAiIc2$V~}?xwwI8?9B4>VO#Ub(DAr^adNf?Rqbj9d<0Vi)bWY+ z>@&vY_06c@nB94i8Sx<^c6Rn98SRJBg>3|7Bm63PufQ;UV)5?sQHe#{rQWFcTm`i3 z;rY?V=%SdMADi3$;Mw!hqO0i6&n|9eKj5MM*&rv_I|R8kIz9yb=V03axVpyH3eZ^t z_489*U<~>mGJ@B3AFV76@ZEFPoxRXQ=J8no*zN-wh$G=L)|TdKAjE4Aj1%_DzGyXQRny zCWC7fq4XFS^vhdMyJ28P*!tH?89L zlQw^$)kA3QOZ#!5sQ#zx8`!1$9HLe=afZ7d4dO@!x!Zh>=2+<{R`|{IG3k06F~Wb2OrIM=@@PlM)!;1 zH7Q{W?=~s%>vu^S@Y${SR>S%6t*OlX_O0Q}{DEoH)^PDg$zQ;;s_l`t`vU5g2mB%3 zOM+P4hW-Rod0xS^_UT;#f8p7sREgn{-b;#l(YfuZp6%aSdV1peuvpf;eWz7dGSZv4FgK5R(jhi!e^tr+RoL31ir7=}wo}u8no{UFDCYw+%Ge4t@6x8{C;GG9dn};Yqj}WbV=i0S4{Xc^oXy5>Kp>lJgzmd(AODhoKrq}3 z$9aUR3eA&VZS5D7pOuux^r0s33E`-S#wS0)Ep*2Q6dx7J@v_9|m;aO;PZ}lvi!#w` zDK*o6r>UD!#g7&VX&?4WC2kjW24dnTus7JVO1YF`<}cnnZ;Igfm^+Fs8=EVb#uJSp z7jO&@`*JOo?jF4lfV5rc;jDF@uWydgC8@&|Sj>TkebLxH;h?V9frUAZ7ReYDhNdEX z5;|Va$a5u=W6j{R*e;<I!6nmVUGb?CkL0hu&!MmlV`|ogMEgiR z$C_iEUO=;LC&4VrU0aZ4n?1FYN}6{CF)z$zw~>wFqxj@aE@{ZmCUb|bv-9l*w3B;^ zODLJ|La+DqoL|JN=;O*Q%|qI!G<&j^!~AiYY58^^hcMc+ccnyisElZfE7!{Jg;i9W zXG>f@2*>m219?CWHx#m|Rla$kU;s3}PYb4qg5Cl%Ie)X@!N|1(1~Y66-Th}<3%&+@ zTKX3b?U6GS-O-@8Zp8fG3}rM^D6{*_y1yU^Re-T!r~5#|rffIh?RXmZhrPfkmpaF3 z*-CR!Sw7z@5F9ZF-fmNkHZm$d-B^VNAO-W1+@fVkam7thd5;xCcZ>rYn~swpf}|l=&z!|H z?Tm8pE3n_bnXVexKIhd!*z~7#pQzACm+$dNeE!`9@wB7bvlUA9$|8LoJx^+}QEEzW z5T+lWYuQma`x`kNP9JHRsGovx=DR9Y9}SOnvgL>Uay%1w`8e6iyFET@puwkctK#S_ zLA*QVnw@wG4RXka7OqW%vGYQ`C~n=VcuVy{)i~MLGgp~tgXV+}YeO6j>)iLRJzR>nAKIs=D!g2#F6l7Wc`B?E!99Pzim zNZJAoDnvXa zhOpo}%RF}OvF9{4HUJn-ttZ3v`syYlrNu@0qCJ|2k$F^q!z}2b%r}P>d*7qlpF;M% z7+hJBt{M@%!=1+wMahF5%J;^nEh}rbw}U}^?Y)&k_06DlY{CPvo$O{PmmkvPWw{X+ z^xsS1gy5+;IXC~<<)`zZS0`dut-#0bg{Im?rU>(NfQ@k8a(7#VuCZ(5zJ68`SqA1u z1<#<}8rj>BqJq^r+f6)W|6vaG(1|@ntSQl&b#_xBcuc!FF(rVKCwk zAN`GDU+WdjbCmHn);nL}YJ%LsQlSX%Dh~*aOF`F&dU|mDoa)QTs}?K7&$(aruyN)# zGtw*EzThs+z^UrWD+BS4B7caB`*ie)>2fn8|7dR z%Yl?q7fW`B2)J$B8Giz`rc9Q>gCOiL1SD<@4dkt56N=3m>bCp-KnkPrRNRNhEzQ8P zcA1$y@%C^7sQr#6ceCDQDco@=M;P#UkzQ^GTB5^=ln)-+Byb>*16zy> zQimY9qpa-7E$^<`JX-ml7SgLMr0FW(i*Fm3A2(SIl0yCjI}tFSy1kQE*J~Y?U2Ow= zzk{rJV~Iv&2K;R>w#XSzrzY($gQlnhC*nTrk8#8Npq^JTSCKktXO;qjpFq;$7N$pU zy`KQ#;>gnpF^#ulg0a)RspWUmpRbAa_ceK1#u^R{k@PcciTml4|0B9KWD= zB^Q@rXIG=HY839sPlnKeb!f`mnGZch*(8}*APb;`ym`7u6huXb5z8AIVR?5DZ>XyU znP5dHBa-9zMmAd3#y3OKXi2TsaUo^}<+X+_Zp5P)RS}NUPYfb94V2 z*uiLTfY#l7lkwzBRfhDn&bPq(>tt>T?f7T|VB7qYk0|nDH;icIoF4OOk)*k0OO0WF zT)0gc%6&&jqcc*pfbXg$ZD$6%N$6T80BWUdWIg-T*u6;*2||E@RMl2?YBfn$HJwwV z+jnw1$Yxwgg$wUHKQYpXxe4`ee@IQ;dalU4xOHr@7uxGBE?z3h4NVl%IWfhYz9NGfH`4xZ$flE2jT1hy5jCq_Z zsJ#RL1@>Wq0~8V1Vv6t8LK*IgoI4*#-!mKo!UiPvlt{z2Fx90Ccn5rAZ$G+v^OqO+ zz&#Pw5e*CA{;TfAc2!;;5QcC_EYS+`v`}X-Bq%lu3)c|KHRi0i;ahD4`Ut_n5lH~z zgJ$fG?tXVEo9-d>s^Fiimu!!1<&1}zCadi-Q^nR`Cw$okazv{f*oI5z;je!uShEz9 ziH}kG@&iskV=>SIQhtkEi9^v$bhV!l596$Ya##x9Qzc!THbyh&)+K-+$_mB>qkv{?1|n}n#!Pt!U(q^1o3gNIN;>2d4!&N{ zc|v<2p?n4gql7vqsqRM8WjuW_BJ9+d+MAgBTq>r%nzsyLufX3PpuhG|;H6jfEKj_t z1b2_hqP)0K2Rcz8mC6%;Aa;B-hab5f^<|hgXd}LsxkmV-o@TY*GQdy%+Qb&0qTyMi z>Dm_*7flR7-9jQi`Il!G9;_=xnmOIODM?t& znM|CZet!UpQG=2Rotc^v146;DYp7?{WUi>J{I?{q-~W$0qrYDkpAC1HERUA0PPnV! zDRN6h_|Ps^b z#qaYG(Rop7TX!oEQ_y0G_I& zSLV@ChKlO*WnSIf`F>G9bni2{eb}WPdHPx*#uqt+k^x5L`MyePWn_fil5Xt9adeoi zs??gAgBEkxvgjtC6nU#w+6&Enwu%H3j|{bW+&fELZ7bf!2I51ARH>AffbRy9Gn;hb z3BNn)9F8nyC=$dYb{*6>nq)(%j6ehFral{i5psY!UuT;*72QlA_PE7U`iYHDLU@kd zD1W{zb#J6Gi&c$b)x100rw`u^V(|ETy=zJR7`6Fd_4R$x@rn3xWo6dT;nZ}PjU8;h zPTFt@M=2?ZDD)xFCjk*QoS0n(P&t7k`}H3iZ-j0GJ8te0BFE>u4gJRU@wm~^KT~u| z2*`GDa&xDTiJw)`Af;Q+f;b$twOt`^$BGEV$UCJv1EM{8DG*IJYnE;W;4o2eb)1~m zzj)8|>n`b(V=hq*&S%AvP&*)fnlN+0aUO`G2leOoJA5!Q%c8>&ZeZO{v0rQ~LY4uQ zmHUGFFDHcNCN8k)RV6Y!^Cd`0eb^>6x{`p=T`I5udYQ=!oIhfDv*joR0B28qNYYkk1+h|`_>7}wB( zPiGw#M$wWyD&j&W1VlvDS-rwR17W2(8bTF&YbET@pVwlLK7_*2_0EQ!f>nc1ih3bL zi6rhGdd#NA&jxKV1(2i;8DZB1Zu`(o`!G1fQhDz~Fbi^GV}G9IMmdMz#sZ|jrI|f!V^;^y&_$QF>C4cV?$`36s=s~T z?9ae#p4`7iWm?MCwK_5->#VUBB(eB}8c^O8zc4BD3n|>_#~FOp2)pH@>C&TO_)5Zr zs6SG*vSj@(_-JiN=x;?OCUvZhpu0VdQJyK5>=6o9J|ER~fE~uys89N+{qNGRU9)Mc z&O{-IE3tNPjxYRaM2U7(JIt^qt~Y8*!z&r`1UJex1`{?h>Qy&Tr=8iqLu{0dW`T*U zR*iKSs8*7m7pPPBHi@h>BoW@F83_Wjt^R!aj*UaLiB3_>84~zmz>SxgThc5zUMDA# z?E{6&q-ZDz-v>-Vzd1(;cl~+&mnzMlm=IpO^8q|7O=~($)YKfIr$PbebIwd}!{-f# z$s-xqAzTYq9Krbet)XS^aRc9L*7SGfnHJ3c6GFE?hLiD)&tp(~gFGE%k^PI+*K};( z?noRK_5wlnCE@}K z$+Wc<09Dn*q`Ex|B?(X~6TLFUks;Ec(q6!}@b%xB+=^cc6=8Evc!f>ZEJ~i*;Pg?X z!h(8FM3rTN%UXMM{DUzzB>i5D8U%bI7iW9hD|xl+<)NTJZ}s_Xu(J$!Nx?GO&neS; zmrK~@0dyL>(km2ML)dAZKp&xPsCR#RjbaV{1ZY#JO|iX(HcKZNu+*!Mh}WFK<{jLt6gar& z)`9Tb?SN2}Cax`T7;T|h4%@Q$TFU`92^W_2-z_#h$|40Bygp@gHj>p7)`T-K^)6or zXK{%vMCAHy&QoVK=LbbT;#cwtqlq@)+7yW?wh(CCUAnerOS~d8d75Jqi)0fAi|Rt3 zy~NVXvP`sEbbKs&_!7Ee1OidY5a55241C&-NskwObEcs&a@iXSJEGG-9$k47vKjiU z0hbhx9Ku1dyASMC${!djLdzXxFu^dbeinK<0hxH~oOjZZ;)_UF{W4B1zMARL!ZCBQ zk}f|KXtr9SHf#y+E9`0Na#7Z5U=5b5*&9x?%yTW8ayG~}BL)w$HD;7no<)JKT9QvX zzl6D)#+5WTb6<-P%BvjoqdUwH`K{?urz&u+5NUOsL8Wd-Q1UCyt7ZWn464%^vZ}J| z6x5%4<=4_|Ntw+GP>3l&K9WL~O)~+?uu^e#Fb1j6WH0{b`B2j9S5)icEM6OZPTJkZ zRhlKtjk}Hls53iuOF@+QDBu~hf;y{@J&HP&$;{9;Q_+CW5#l9V8q&n6ikfoBBa@zR z8_b*+1FeOVlfqmgkZqWUxb-F;htO`)+3`R&y>=Dar5%w(8y{9^i^N#&K&8`SyDP?j zB7;~J3QO3CnQ*podo90^f9k6GT2a!^#?&>dGDc0yY34-c?Es7~y#?c0-LpzQB4m*~ zOLYAHf3zB5R7gGitrwJJVo;4KEwc^)y7Wf0JtyRvlZ9{UWLL4?XQJRp6Zr%kAM^y@ zu&c5dpmdz7o}+PP68j;AWU1P4I&?s#e82gAaZ`8vo&oAeEMYz&%Y!G{b zhsEZ&VX9`o(HDtSr=z`d0&q@x23M}%<|MC$ePt2~we?bCk^mj&2R&@Ntf5O2%q-%! zd(^_jw-XECeOfi!c@%9y%H~C$4dX{2*yk*Yb8eD49m65(;w!Y;^NqGJr;~2yMTzG<%I!`~^s_ms*8?Q75PDeLYqU9h=q4hZgw3xX_O?W~e^aM%|Dthox=_qhEB<*AY`im7%{Ngl%?19Rt3LSV z_Cpk5Ylw7|0*8hNF_HFmItWEzG?z#+VM(XMfLQGlpd~a6HZMK|>Q`eamV8hgT@AzCe7I@n|ATBU@ z_M|$6o-EKd*>av-71nrwmVPwIoz40Uc-ZSZD{34)pTmXX^wVDJe%itrs=ZvL&7rGk`A*l-xlLAz2*S`E6DmqR1 zdK|MJO0cL23+xyhii)a4q}2ZliZ6@Vu~$(zW-lG9zddtKC4=^TV%_5h;Tlwjx!VlO zxqvPXG?K?SI*52Hqpp`m(F;x1G`mgb?BT4SfZmGH>KVxN>Mtk+n+U6AsPb-}X(^AV zUEgF3nov zzKA$4%wgv{`ePuJOdFq%x%su)&y(aZ)Dd9d zg%y?Ac#0RDFpflZ$&bB&hx7m?6|Ar$KCWc*W~JBo_+3eBcX3;+T@D|jI5@kMx}F&9 zr-x2*$IKr>Vrkt~y{iorWS9^NKpr2D zL|`VA+1qdWLg~qGbIKMhK4R>T2;hErPq-R9E4_2uGpEj@_U~Q#ue=D72mVLA#}gD@ zF_^K3mJ5D6_XMStPNr_GG&}-wgRy8s;?V~(KkN-sQ{v$^YB6V3F+E3YSB~GGu zUPzsYGZ1jUZPfWmFQyyYqnW}oWK~VZNKR-!%4IBZq)(>MGacmYE=^YXvcdbJIF;`% zbH2lqVx|>WC$OQurPvABzv;Mg1$(FO$Q)e_A4`td(X@y*1))Um6w9_;QMATJcKR^N zhmaNet~d_0b8|hnw%OP4cxku=Ql|gC`+626R(8p zuRHe<$x5w-Dr&B^)L21>FyY4I)%%U=H16>xItY8V zlSXjEEE9e01;RtAoWbo^HLE`g?f-ag+Y&bQ1p8NaT>lYSHDjeEesDDi!>51`gf}l-TAJ( zVtJf(4FU2Z;J~PCfa<+cqEWhg!#S%|DAxBi$4G+gX*|srHITH$kXX95AeT&~-r?7x zMP>!~dAB7r@(IYO!fo?>JRG}*crN+!fpNMfM6t21N1v;5T24>-RO#~D)kQc0i0-`e z_nql{N61YFJv|v6xaV|aHxjuPIoloD!B7`~h;yM`^QEtUh%J)l1(vj=ucM8;shvp_ zKr1mRTw$fZ3k+j(leTHgS0bR)NG1Hc!1=FRUFkr|#6=DxE2ay2k&9-qAnAlc~13JT_&M?I*t5wg_LBqR>!94t`I+`?{b$930 zRSMy0k%Lu&Ae7#h??=A(!+Wp%TYm(4AQrIGuZw$6Fg`D$Py(LEQO9YAWb%21Q))nW zP^h&6jkcg>tDUmL(Dm(Z0u^b0hVHBGj8<5ul+c8rTl`v&XYnmvoD)XeT)b@gv^%Nb1^@v&8hYlpd65r*4Gc|Dug`Y zO5}N}UqP~q*=0_vkAObYU8iZPNR7Ux%Y`#_rGoH4 zH-ZiYC%E(pq>*0>mKvWuiWQ1mYvmv&VR|d1T6>YV<%Ke}i6mpK{Oo}M{RAPZgQUAu z-tcc&bRO^bzSfS<4`2GI93vD!=u+gS2{lzt_tr(mmRYb+eim}+p5Slycw~U7CiPhif5v%d}aJ4z6<+><-m4!xKVe`4whsuEAM_EPb|8E z=Ky@K)3rb>j(Mvbh}L@GdSl|l+~sP;gt4L(U{!WsE2xIM69$J==HJ^DI{hPQe!Hh9 zTy|GSTggf9TW~`%BfgKsPWR<2zcw9@2t%HW1n_`@1SfqgoS~!wcsuT4dyuDO_oU`? z09{5?(4xNv?=b9p5?erH$9mC-i#5#RTrzJ?@|AYD)bZ9()Z2>mi!z2m?2)MI2>LeK zj-vbd65i+&XI0%-qm?5vq@>VwLcX@P-TEcr(m zoaX+E@#;+=9DkRMTcHx=`(pU~8}U>;MsJ`Kjd1ZCC3-64Ak$}DRQqaY%&!Gyd@>U5 ztuB}^`xqbhr)HN;FaoTyK&?XLQH$8?rPthzTrMvtNSn-cryEuFK$+apXrj?c-=rhq zy1FTmkm*1zw!Hf{ivadUe8~$grEQ|$AmHKu_&LZVJQ#!3CL#2vyj%dj;uj^k^zS2KP_qJvg< zEwPas#W17MKW4$`?ER{ZN)DPfhFz>4L zm(niFgT6N+&oa-O9`_nh)n#v79bbIC;6fs*W3bNP{+TVgEMYunrj5I6jW#lBctxh)q=3q;BYBjc!rz8^YyJJ&1Kp3GBoVxt%;0ByC@K%=6ZgKhbJOd3^)AQb9LlR9Ldpt<=QMJLzo8p- z33wO$R<|J#?7cMYnj3Y=HrMiSn|vH6%AGT4j6iYO#vhf{oGw|8IE!CZR_6z5s-#Lu z3H_&6A@kdeuC9+uLQlaJk^t7v2% z?ShG#E0)6w@`WZ;1suKX&M4IEij+z`4}+5+TY!^K*^JrudGAl@1aj}SM=vdfR9Ma8*48<|7+T|(bJU#{BfoQgT&W=48T@J0lQ?Q;mVuKe}yCig9sLS zQp^IDYh6mDEE6r4F9D**)#93s7&U?0G#zS$ogj4B=_4@7g?_RAz)7&h^8o+c+s&SD zzX&;Z=n*P}LQTbH!3*jN7p)DxSe(IY-;SMu!}pz#=71W3P#cIR@7KEg5r2=`B$_(g zi#ExD2yHdo-9D_Y)oF{bk$aN1r46wyMvY73HatbDTPAd-wNi4c2%!ViK`~t1r!*DH zpI;aF{YJ$7ec=oBL{5fgbxB?d=l3)q?$_CZCH1oGSEvCu-N9XvMA7FZFOdD%!@54w z!%Ul=OD>IsZM<%HNj{%7H!(Mq25VnR&GM0@6)Uo{`BBric)DRtQqg;+m)MO$j+9|8 zc56R!8h0e7Yl(SA>bkO(qrE(}gMs35R^nuhLW>C)>}pYO?u)lD^oh8DI#YIKt;}a1 zVZS{4(aP$I2N*DN-~o@~K$n#?_fLD>l*oA(Q&{%M*_Cs<#oFl{KxwsoC#SbHBSOy3 z8Z&1wlFbHJeKgkGLR`Mq7rmZHI_$OU7nh|ePFA?YLDGJ(a(I59C#_3+ z+iN=yia$;n{Og`$2AE1EO55Nr>ns~(5~9NiSb-jgpkbe1C$4DH(j*?MM>W=PQ!QNa zq7SgyT-RPs%jI4RZ9k6@8FBzIAM)=wOst|vCLt7CBaXuCaOc*&$_HrKIQ{SI(m(hcU6Uq~SBlegH~|Vslnz>r>cYxcRcX9xT84}I{jFAt zlk5Qx6k;vnom-I|d$f{0^BSy_mTAH?=&=LmqJym;{{9s*Jx}ky>86Mr%IqU%Sl5mQ zb>~gtMy|nCgO~xyrhQwX9hmMSrPJxlJj!CPAl?CCKicbY2Upt{M1duwYS=~Dw@S~j zhw$lZldcLis!Yq}l;^5o*1>r{T>Iq=Nw*WY16(c~)`Q`^KM(x&ttab=@U_7WI84eG zRE`qbEkkVUmqa`?! z`#{z&?v7%M)j^XN9P+1%T6{BK02_(=K=6Q{q`T82jfIr9NCYaLC6`rVpRbP_3SF-7 z>HXdr5_E_70H*9_O7J6F8GLuNf0m8 zw5rrT-fbo}uX4ER!54UcbDYk5-4(%Hs=of-YSD`0mZap($Ql;IXz*@M-v(kTz{bS< zj1maDm9%#>K_zzWKUS8sdqUoS)FlX?2!{6?{YEopaE3;z5PBD!^taXY-r~&^p`cW_g$yR;DHRCzOpv)px_rXceKf~RUNYf< zknpBb^{eb~TAQ5QS;ZXt_R%u`@U6eLWpnJXH*%h%L%Xn;6>}IWak(%5;8iq?*7XAq zy7$3=je?VYCRc}qNy;De`XHu{+-6Zk6^2Q*cLkGWIQ@sQbBNBY3$SQXv6G5z+qNpU zZQK09if!ArZQHhOcTIY&9{huz-q9W1wca~t?;~`%XkN|SsO4k^~@l^XdPO>odfhAO(#Z^LA1FJBv8LSMhX2_Zb1!f0xKZbDT>V z3R;u;2-FgqnG(xBG6CGq9&#)zwV8T`mi{?)mtwJ&k}yHc;qC?DPXESAF3wOV+ZCN%KBRflT>VWbQ*{Bo5b!9D}An0u+ zq3xZgcQ_M4F#WLPO8?2=0jBI*Vka?Y_+4=Cwv#St>iG7TJ8=Z>o+qRYN1zTPYBE+y ze!#P4Ds)V2Dz}$-^L6eiSY%YSW|}SKBNeA-Y5&X^G4u_m+3Z`{AhV`^!k^OeEye** z6Y8Q4OGHais+li7k1OgnB#^Tir6ecn$}4CC55lqCun}6I+le9IDxav>&@ zhJWLO3N7wl(3eiFZ9iG;HjRSp9tjrY^9Ra%(Zu}E-w%oFNWBOZ8xJX=ULLHafSq00-=E$Dt6|ShF2Up$nT|$i-}R< zTvuDFA3bEO8o+l4ZHul#O(SO-T%aIBwRfKmK+4rTUw9O0Gky&KsdnTu_-hWdsBmI} zGv2Kw!-wY>!}&3C{nlNwRCHLeHA1TDKR$ohF_3)yZOmQG8;Ts&jx#?iLEf**$Yv^{ zJuF(r5#RY>HPN~~kG^DLmFl_kbOFQ+%-IvlbbU2v+2zhs?9px#y2q_wd!5<4+es(Y z!rrnB8vZAc&3@}8ThUWa<+A|i-0ychFZNY=>zNj$+}WfTC6^Uu?3r11jVIP0i87L0 zw=&-c$s$C-9mpmbmio_D1%Nu}Z%?5;nU8p4H|CGppazUGwCLTe%H_{~4)rI@@#v`I zT;OXVwCyb^_@RVTwZd`v>6JLNa)U@=fF5h~F;==JM8pyB0PeaY9HMp|-kTR3qfQ@n zKpu#LRWTNX-8tB>irI$k>PfX2tmfNn;AMR&HH?1l0WSoOl1ZUaPNKJbilVx2Y?}iU z(TrG!ad!V(|GS{0iY;f0MNiz7w12oLD>E}H;!mEKt*=H~xwX3RFa_Ul?9fMAB-u%r zHf3ZQ^wYLhQOj_LnHHi>1W1`(;PP>?eRT^xe?z!7KxQFFRa9s3Ww8a8Vp`(`IGdj;@}NlN)Xg55s%3I|dh2II>AZ<(4C!0{H#B0J^!1(k=poPl6Prc&@>smcM%vXpT8 zsB+VpVZZ-}i$soiE${~MwR7$Y+V1LGOm~ZmI$I*^)Ab$2Tk&Kw=fwuT$U&|F=q14I z%^-HCY^|zhB5}HIHdk7`SviJ&dC?hDp}_)vjZ)uJuk(l+VQ&B4jN%V6`WeX>eMe=N z=eLjJGM%x4-u=z_WP4AK*}p|-Dk&mXv5-Th2T{IcMU_;JUUcz)u5CvdE3*YCl?L19 z1Yu{UMs=B*M5~z-K7ZJlGRjuzWbUEV#IY#9ndE!9mAtzf8^g}(B#;%NNB)QdYEh_y zZ;|G#{H@{>JF?tNPg_l(L|zYBqdmJW=Y42OHCGYG=UX+i+3_?(Q7+r~;SN*daLrDg zq+6hvlfUW+7Q{*8k;1f(P)X+auD)iLDBkYbGB2uc;81yhxPmc;$Psj$bgWj)bk${u zZK#F-PjbHnuSCo4XEB5DXomn6@bw9Ivn{bX8C3tKScy*5+}v1AiIvBw^e_|~dy>VK zKdAi<(V4{50~49%L+4ZoXaky*qSGcVC7h%)jZ-PU3!r}+uSu?YPhb7h52SzgF}m54 z=`_`e+aSrly|6=1zs6v)Z%txnl$d`Tn`FK)XZw^w8rps?m1?tOP5h2yVB;%pK z)g=3R;{@k9n_mBoKQ8d5YO34Flv-7rSM5*^in0cAWLB6`qVfJ*Twg`7n_ch^uEb8x z-0dx@b+>e-@^}4y#&%GKM%hE`a2-@xtjkkPW@psvJ=4;-K%z?)S+Z*@^E+BZCzJ)< zLhvEel``O!uYzh=mk?dHhw_rjwhjS)y5&V^giAA>z}QwLYyB1y=_Fw)<8Ho1os;d z{XoV#_^Y?_t{c;C;vFdOG33T~fW&5?kJ1wK(^B*gfgSGc|Nd4Z*c1h&u-XG|`c>`- zl(fqbO3l>;yE(Q2W@&Ws+&bBV=P#{qO3+eUOR$mSoSR5I2nOBk2dqN7X-ya%Lmfbi zP*$gAHD; z!6Ed09to0#S84>~@-~}7UxT@Dj z1puoB{@KPRV260=Is2aemH`d^l4u4B+>4e)W3Z!`1UH9s@dH{qQsLO_++6iTW2o5i zM}x1v9r1=ifGG_OJ~Haf8K?ETS4KgcWFO4+X&d+OPd`mJ(N}4_ z8y$_9nnC@3^KP6+hj@F??B(?BQvb}*NFgbwcF8scaC1Mk6- z_cLM&;sA2*T}|&?9d}o_()_3gutKx_=G4 zzOdW_25xU_75?=3IeWDWnx2Ad3<%irOGd<|fc@gXj4=&;(tEwT)ydTrFsc^6asX-b z1$=)!-Ye*;+NTD-0Q!G2=}V$3GozEiFZ6JKHppq=UVgpTKiq??dAzpyZEp5!3-paZ z{QMNp)%tzwfUf`?1sSY3wn@mtRHP`y5Bfr@)V0x@5Av@LJNmxTPJe~{Xs(D~6{ z?;<{aG|mBv-#;kd8Am^4_dm3MwzvBBVlvKRetr&`?Sr`7e{gRpG~HT8faQbvqk%60 z!cT+%xGJha==1B>9^KfCp#y?HegA%(O-@gZ^bP$p!~J{do&wY@1h#sc0TRdb9oIJs zPJaCaSoUhCHyuZe5fK*v@0bU$W&X2AdJosO&e?cdnFK}*fL_{$A z`+)>Mk#8>j%YlHVVCOdl=I9u3U4Bhx#bMu_aT^Lz;{#- zn13ePk6^!m?7yt$Mw7GZ8@SCsGZxS*PLu%<@FgIB#J`PO{l>qo0}uHTxE42EJ*uW7cG68vg4=UwSdKkuJA`FM`qzuR zYOCZ0WBhxJpmt*uqkxHxz`=ktVx(8_8wTpmkm#?=9}^ev*y_0Sv@6iLwrt60{O-Ki zoeqf`{Jp&$9Ca!)VL#i#gsU5n%*2_7XVUrZC+JwJ47p!sr!AgGp#U<5;LMf~FlLSR zXv+vzD~lng(oU#G%Z(SO~>q%d~GQ z(_qk%NR)IQ^%;qvXZ|PzO-3$P<1LFdoNlQI7F2FlkqT!*`tchd_OqkU=lbqiPPCG0 z=(QZs3CB%OYX97-#Gt`JOY=|9-~va=@#s}rL8#$1ney`Ek-vo z4Kba-+BRFyDG$@*-KFe{Ds$W3w>3D;uMl;e3GnxoHJmEh$ErX2k*RO}j1VL}i$?Dl zGX*IDT@*YObb49Ds7J3#K)kSp#;c{pRM7GMzT`%K3&@@Hm)_#0Wi>T>qTN;4EUus9@-z$(O6HaR0dIl0hSf6b55DZI(naVCW zEc9?%=~nm9k7=F?SX%fkzC(ulCuLwIO|l@Gywv>?6Kk>CL>M<8-*tt72UD0^yt4Lp z9{R3CT&pRGxFO?g?7uMIhGLS@M;@6TeA6kuuDcBYM}Yw_5+=Em&r!TiTs?~IInVeh zmwV_ZsrhMzrYn$1sIF=u8wk)b)jIK2lH}{uJWhiT7l%GUcM*%ODGfU?wKX5*9aI`3 z<+GU+UFaJ<*-+s%n=jjyED?k5vmXMcKE{EMLyR4K$c6CB_kYb21Uchfx9o#T>h=^u z$~ORWmE)o0!$a{+eq6ayb{UZ5_$NZe-KmrJ{ruB5$%yg1%u)}!f)Fje9NG@ zlzsT;RXN4>4c>FlC11}e_qiuM({EJhnVE$?CvoWVQSgYU>KKwv8>Jh1>|?MJKs{yH z`s~vND18^f+C#}vioeG9NGC4H`?DSD|M1$8mHzG5a?y)tck{V@a^G0j!62_>2ntcU z;rY45b}+9XsW_|{-+(nK;`I0KWkdB(mRuNf^mt6Oa^02UOfp^<{@Y3)jIebv%_K8W zTCg{&@7FTME$RBa{@ySy*2R-W_z{#>K&?<}U1tt7tz-hgquOpZ_Y8s?K(Q`j7- zcn>>Di)UE$D@%dty0XwoBTzA+?)RWujPLWE6b8DMIpA9%UPZSuXQoTAMSts$UZe83 z>)W|~$JZ|vc8j$t!c)Vakp-4o5ACekj*f(j+zue2lX9!f$Buh!!gtJc67k>JL`VaL zgdS3ba`z8IQttEkL9_cyS-%POHIRjp#@+-hmU!hINhQgn_uUs*g0*Ne9Di4n_+$S% zG9?YqpP620nRB`s$oa?_)+>p3N4jkMj16=;A~%?Tm2rk?trVRQ*4Hb;&;mODE=jMM zquq&O2UWEQ#i+K)wEQh#w6fu@qfIo`e9FbzY6skE_r(9q2BDxX9-SEL!USbQgmouj z$@FMHXNKfa1UR|!lkx&Xw41BCB3dMj;lR%53miZb;&}|RK|Y~+Imdh)u24#SS?@BDw!|`2*_%H7Id8l?Aor+0 zX3$`OBGN__8XJH{5yWpsxG?ffM`N+%{E7-T?c2RgA2NZ#HiJuBVv?CikKAOccaY3p ziyDnGyH6U{{>)_r_bEA7nwGo@0yeO1*~dA--b^Q6go+j2j**NUe~=eCdx?5I!1c+I zo(#smvO0^Xj+Z0G;%s7oU_6e$JJ-7)hqaB+e0w#1*2UO}!P3>NVE}=e(z~b2W20Pe zl6=ep8^SXQngmHD0F(4Qq|a=x4L+9@;NU7&)YimxT> zf(~qAOd(UP;_F(D>nrl~wM#_b?*!&%8}0fNbTn~iR79To_m}y(1mSia{)$IXtZK+9 zj^@dhZ_udCiYiui9#cwUh$IEy8H;4A?ueGUIvD=Zk?EB8PjN0* z8DN^~PD?)5g^r5Qr28wMlCVnsd#o_wuA(0(6v2bgMuCAEE2Wt>C&eS5MkE%3`*ly| z+Wt*PG zq;g@TP12meM~Zc!22I^nMiVteb4Ev!D<4Bm3&Y)IHv{PB))tatS}4TeZ+V%ZGe20R z^%SN(>8Tl3OB7Pf!Yl(uE{6^47rJe|jIv%9?4pm4?I20?v*4l`aq;yb>Q!Q>_Kuj0 zwkMZr=M*YhD~!GpNQ?2{1lYkL#-^9`QbV)NwuCZo`oa^IWw<|6?CTKBBii&)6`WB5 zRb#-wntlQ#@XRceIV9>V&1J}6Ut6YGpO@?nXJD!9YqpgxIue1k=0<&R3dfvA1o5<5 z+T^KLC&M|4Vr8&7k4!o3ANJ?t^fV+1k&Xd@W#oV;u)T(yZh1CH#KLezkKQ6B%3)Dm zV~1<5v7o8G67nd}6-=bgB=~YN1Y_cwRq=3@-@ZWkeMACpJhkW4V2FBVFBNR=Sy+y@{ElbN?;e-Bx^dS) zSoax^e{0igW4U4yuAO45y&_B(28qpEU!c5LY+wVcHcmR1nSFmg%b3d#;07u?PN}Zh zvv5D1E{Qj83R})8+(_-CnmJM>ArZMnAj`I0)@=w5_X(%*99Yo=T=>Lf+!YzAb&@t2 zG!KuRkLPhW&^?YY1aP!!sZ@IsJh%BXOJdjZ%#ARU zE=o(;s%*)s7P=jdo~oUA7;%xS_^Y8Y%O-BIox5Hvn-0L+Xs<6U;BOWe+R7tNQ~Ar| zds~5aCgGDr0HbUW*=K_qtA^PSRk}--AkV!XxrOgj4p^0_Lv!$g?-j1^*Q*fJ3>hH- z5CG&_qlO_rj+ztSA3)!Cp)yRk#Fr2ss^gPgtS`N zc6b3Y{ggEzvEZaZvTcm(TR;0bTCk1r>zEc;jH;9oV9c-;LH(Cdk?lET1)wo7Egxa0pQ}k?ymYBy? zc|UgD9$lQOxY7yK#=l`)sv(806wZ|Sd!(dbr>kI+0e{`&k<)X!Ws7%4%c_TX;D1jA zIAzy+)CWa4~;m4BJvdqsyfhdr0DO?j@tS zL{30icT5HzCUvd9vjBykqlPL7>}k*b8WXW@(``%A8x$EAPY*&~5qDl$xbJQNh(5f>yl zr#2#vPMTkso9b!&BI!vnG=v>u-#8r+j`(W>5+9|id^K{+uAuH=%Im(PVSnBCL59odgRsx& zb@%Of)@RnY{pE%04f$QMj(B|~2GPj2_ab}3()?C~U-x@b%3`{4>CW(KjUZ;%(vOs6 ztS^VBl9_8vs@~O7A^u=;Cz`r;*{HVq4{i5kV;)jtSEb@*hTg$EZkFgUsPIu0*;^6J z@aaZ#s*zgZKAhI?l44rN6JyOG5Q~cMx_!?nrm-pMk+|SGq@DCN^$7W}0jMyzW|O6o zBqOn?8VC1=ntwe$H8ZJ+0uoMJC8oOBa92xWHFKaLdW482O)5DGbxXcBP1Kw<6uVvd z(8hnBzqhKtgsrAAeuHO}_L)3!2Mfh(PR$U70~dHXK}y$Ou+!97b!tHD;>U$CsKuEx z5>Qw*G)Z#d2GRbp4qzGtZ9jAVA_Qd=y;UuvPfHsZj-C0HVZrneK@q}la53Y>Bho6W zt{tL)g&S$A1(xG~Jii6@YciCUM#&Uw4lWB6I~t%ZX2Zw-AeA#bJOj5y+qLjfgnRF8 zt?$>7%QijS7pcQ`(EuiMZ4L{A#D-Z)fKeD(>yV>lJ&-3bfyT%l;736POJR8QuQjlxS8Z)Z1d zs8tT8HYkX(VLALL?g-%}qrS)RDykfnjh3c|NxAT^9!iaT5b2WUQxJ~UtPPw7v-wLQ zk;g-zZ8cg}tdsVU68h#tmC{(NIDM$%z7^MoqSs`_)+E_ZgdJ7XD5S!#sne}408V9~ zb(KKW>8vzGD=yA=*p|3zpYVJGA81OgPBT~^X5_EMFWv*Nu%Z?e?aq636>YIY)u&1q8JTR8!u{B)FWksk4VFGF?N_kG}H?C%r$!R2pMJ(3vMi zNgS}^`*;bx^>`Xq+J)}rYB-)GpH~dnfQ3x^+M#{*bzv)Lij{igM+!3aAS7`Mi7lPd zaNQlVN9{_ntlFy{M&$RU{Tkp@S!n{u64Z`n2pqs5sP@8+3%)v)Vvr26`sNF>cvw8& z6BQK}ByKflTrYQdMVC&{l1w7mXXAJV@irB;IZj_O>jC9S)psfQd#g)4TBlJ)%&}1? z&P*zlmu3$%le5L~alwl!ov18oSl-Ar6XU8on8?N#H-`3nE^T2Jfr^w45O2#F z=|sH*I~9mPXsizSs*1Q@8C`d0sFw2RfO-1KE6Yk$el>p56}8C0ESVS|pLI!WY@kC5 zUnz`kr9&P}WsAKr89i`-V&Lx4k}`-oyLUtd{>k@o?ozew7Nn?)o$QbhTIs@UalrN9 z5Y^69{b!TM=C+)Rh>(>io8Gt66WF1TP1Hdf4b~=cWklEe_k}x?Rq?nV+XXd)m9Y5+gPHvR5fYtXj&of*rII1Lg(P?UwW-LF=)EXN)6e` zavey7+>kD^h$tWo$~6g)eDaFZYj^7sczFR>d=pPFB< z=M+J7wp^u@W~|2eXSuITU>6kBBd^=bHzEwn+) z;%*U5TfM!U8Xza+_kq-pftg(UX~xx>Q7*nZP$+Xot#lPWGJcA6abevhmsW`sNeI4p z@3L%9Wj-_`X!tm1Wa}!dLyPSUg!DzhaW$Gmth*Z@nXXAZ`jmp4LYk`LfXO9A1G<L5*=1)zwqY6TKs8|CJ6hU7Ty-|dF*wb znbLq?thvPN5K*$MKaGteWGTlULcAZX5yS86_qdR+`#S1eVWafE0I%?kghT!Esmwd3 zyeSoCl0(+;Lb1&&KhbtJHO}K9ebOsk(bWsKSE_@eeYKp^L}sEuu9&9Pt}I>3LwCI3 z0Tt!or6)skt+baZ7kSM4NF5g@7I)V)`jRX92b>m;c=LFi$u5Opve|H=TfHI{AH|cYi-=w zH)~-vAWtBM`=X;rQ#(0o5Aj;AuHLA*3!##U#yaqFkz>Gl^fyRD$(2kMO3~Csu%FC< zIO2qL*m(}jdeM<7^>6A(>Z&2*dyhzMFu&Q~FL_crj8f0A92OO;cg;UXu3C3_y!7}8 z(g48-u*u5M20#@-$(a0)>+|6$$B2}UL-LgHy0XAY;9U1zKi6ck?`l+w{Svn?N;fMz z==n46cq7ZRYL1kx`BootvDndsv3c1C>FhCvY)LdVF+pASHAmtbJZq70X;T6j1LeFl z$^**e%+o^kTPdhu;LX_Z40#*{qfea$>lXYS;1s7W(zU=f=$ zik|Pf!OOtQvtF}-9l?_@?{N8;o7g)UZoKbQVx_eu=|;nHM1N1To>kjae7BvhrWru5 z8xURBy>sfefwH;Ja#70JSuNC$6`ms}b_kKYrh`?$S68Fh$R?r3$ot94$zaD`{{>qt zOI}M%r#(BLKC9vwd6`r&$&>yXnb2A>NTBlJf<@W>@Y)fK+3msq4XJTb+k)Zgu7eEM z{G0#lJ|y2_EPzD`d0ucO810gIgGvoLO_q{!>lu~!4TiYp z7+aba3zU#34(=zi*ziq%q%7-8Dm15owP7&9Lf`jurD*>K#>=}J0)szqCn`-Dl_&g6 z;ewNB%=xWq94M9x3K5@>rH8sH?h?qyVyC|U$|?W^2t-{=@_0j! zXz9=N!kgILp`?S)3G!FJS&1>U#HU#yN~aySK7-CwJ$yi*W)WRS$5R0A<9W^ba#IG#9xw7S>Io;*2O5dsXs@oQFe z5QDu%SNY`1s@PD2=xupPW1KhVFTAYaw{+HLnZzCHduNHQV{EIcnp9US>9=D!IdKae ztBnckD_w%$BcvMq+($C<(v6k7uQM>83ZbBr4_J|o0w$X6YqF5>C4OC~U2wRX=3>D3$DqXk=B*O>NrbLs%6zGx0cZ$?B>B2oQex#zcbkP_WEQ_l|j>0fSx zb^B1g96HIc;ym|b02n45%}V=tT6f26O`w$dGRXu5eo8vU-of2Huv13yXEtwP4Oi?( z25Vl^+bzNXr2lTvV8;3urRH4A|s`T3Q4$-k=b=ptxWSowO3-V8K|$zT>C z5O@;sz9}xK0R@Eb0&ckode{LO#tDZtC88TOqV_KRYeVU&!!<&|lTX;r!UL(UFROZ8 zCZUyW9=0^wug8^yBTut?$Yp4&-Bg9YQqA0bl)j9y13@kVa<)ghe4$EdM2My<^fb_7 zE6iI@2{_dai|;%y_jtBO-Yn%Ch{Jx;ot$yZ79DxpP&;XR+Y|5b4DsD~TD2BFUYOo)el=O`HB-@y7$Fqs`GXr3AALq`!k8lNn zqV%3U-cBSSn#RSN6>9SoD>^M#4zy_22^s85E)VwuF<37yf70HsN1)oTjhTn%z~YRDPSh#IrW@q{Nw^+^#B5gy+sC{2TD}_Gtg`&HF#J=B`3|o_Y@|L~NB2WLAoXI zD-zAw#1wI4vRNe%pgj-V^ssYWqMt<3!K@g}R5Q_C`w~;63PI+24VAUGCexQM#1>8- zF?nQ#q=-wXO;j(}c?)Rcap-WpTu9ct@DEZen9!;!%gIhMaj23zL_4U0g7n!T1iUH^ zA;;o!R{Y`|U>ID<56B5p?)Gd~W#Qi7EL#T)?IYoBSCV&t)`yZdo(&&{x$Wdp9Ttd} z(KF$sb|h@q%=jx>67mOKmbl!Pzb|vJhbNqfyMaM?>-Q|y=H#jSeHg3922tw71A}nl zaj)XwB@jSYv?g>y3-1oA)`;YLcO>o1$9k$sB|?RH?NE3xNa>Vk;!-;4tm{F@OmU^# zH|>Z>+T7}ux=b!p(@>C`qYIiw%gqP3t))f9bxtW}DfG}w?um=cq7#HVvDi8J`WPJ1 zf;(SV@n+%(`Me|(u=9|YfLV2Xfz4gfmB)LoMzLe;B&~wWjLLZFXgK$Wt~_h@OWx;8 zW=&mOkDs@&fy^@Lr`}Bbk;Y_=RyE;B}Sk?cF5uEv2 zRU_25W1ieAn&uY#*HvY}8}N7sOeW+bli=FgF?-e*3UJ}s^CWg!Zt@Ob7x9CCCZLM@ zzba^K|4~6>VqyQkPGdGsrvG*tb1<{B{y&|@kuPA%IGQuy(8NQOs@f&39UUE3{`;^D zt=yvFQVu2R4sLF4A!yXs*YIxB)Fmfh-+(GFbgMod3DKMbh>dFddP=c@Nko-_#CBnS5^@s4h)1{A!seiiztp0o0d2r38vV=4lhecC<`^vBa~W+HMHNKibtvRaqHTD}Xr6(dEU<8Ww4t%QO~iL3la=%)6geKhaQt@v(pz z5Ck(bGdngl&?yj5dxkp07plP40NyJ->4cu4Jv^W8v+FYuvptpoek>;9C&b*u*eEKb zy{j|uyZe{YT@PejFql3xlLI&g$dq7nD4;WNNT2~=bo<2}unF8gx%+Gc%<%K{@IuaO zACk7drs?&`__Kn_JVqHIF($F_MSj$il%MZ<4MY#_3IsxpjqMj01=Bk=0CoGOM?Wr> z`&0WmB7v#J%ndZtGZs+ssMlZpa|U$&6A1yg3-F;__y0hH%>7sVX9J7NjQC1SZ}l`#*k4ex5UUt81+)T{6i)Np*wjqduiY3Q4x8#f3Ow$mj|aGYY2^wc0n;Xxv)G4m;$-Ok^(_? zhkj*?Ddm3jq+|3Bnp>T~^8ErbI{{&6a1!~vkmTe9k|qL#eMfNsOXmX+(fuSY5%$3u z!hQsKfXKpnkkFa^B<>Lmff*#e1S^5a&iF&&dPyE2{0k<&1b0vG0f-#!{rI5K)vy1K zsK26G`{t5<2<$|4*%-8wB!gj8ZMwEg-=0yU5KR7-4ru zxA(I*%E-p}0fBxuaq1hmkL(zr?U!^6=<@9a41*()u<3)B;Ti{P^u! z)xJZ3me_qEKvqxjzxu8G6E~&rFMu?+*N$R7YAKsQ=s9sD@GbiMTV{EPbA&wxe! zl;>UXxn}@fMAi}i{7)B^t3B>jAFrX=JA&J8KF8-C==4tC&@`sG+A8NavzNWU z&JS>3-`4lsq<+cuzq>NIe}V*1pS*<-t|pMr-tEACn@Oa#as)`7eAc*ucJ_To{5&-Q zK{`XE6VTDErrm;RE`v62sf8i7GG0nUPAXoS7tJ!b({eR;@Z|TB&MTXOR&s8Klfb{^ zR#{8P??BSWb-LrSuJi>r4pubsdGKQomdoBW5`Cxl2B!N^PqLs7SwBvQHDHfGYudXA-%2j*hdqMyngV| zQC2d8Ao0)+w{f3uPF>N6EgxcsS<~R=&p4oHb*D^oU9^OF%q%gvsFu+2IP&0X6P;p5 z)>%l>&wY_-Waj9Kg2h?=;%82?z#v>6ewXMJ=jPA8Js+RY-(}F^rn~_RbXx`sjA}_dJB^>J3c0(OsZH^o-OJ5H>_-re*VX-d>0F@#bg&OX2{`%IGo@pKdxohiwR62<#qoaCciCq}r^+W+ zd4CZM42h1O5f$}HSXUDSeaQY&<_Y3?1~Q4KY8VkRr^CWIDc@XHpYsvu3T6l#$R6 zc@txqKTo+mXhp5ImzTgIT%=-OvJ*V`ln4e^vGp^7a^jboW;cyZ zJ8zHhX;j=ao#Z7LH!v!q+h2Iq@fm^5W3}B&dU=bQcLQPSxQ|4(le~bsxXS@OUTV^J z-IPs?O&_x3 zYLlMl66~-Xx*`%AehzT0s}v&HgF9O}16Ym%{v-C}+R9gAu>^?@{rDG}a*;qHr zu_YM?(BHmN!`q(>L9&4moVZ-&)1Zt;h~YJLOr#$2KIjXR@w+sPm<$W8>C~UTTq_76 zU^Oq|QH9;*^1laO25(Y$!QfZ@?cXu+bBOZHH72*NpVd1YSJR;D8`4*~f~DB`)f_zN zus!f(8xZkkgIJlWOS1Le#Q(HHm@75GCT-$621%yBLa%DN*4j4D4A738%ju@z!b-%SImiZtVVy%eB)z`Sc&D<#Efl2>9ihBLQl>|V_Kb& zt>Y23h1q;uPzGsC)I=md%gd{-2kOG#)3;H?4~so4l|N!L+fjlt%`^K`NliWfKy~RA zTu~=cSDp{)8u<@g`;xoE@c3{TzsGKUB0f_jJ0q1LX!mM-Xr>aft6=c(!6O2@` zZr|GQ*Sz9tlPt-`?6n8;StHc9dp1g!RXJnKdUg<^clq#K-*4#HH4_e>U-c&g!gsD_ zRDe{F>U>VIpqqL-6m61^w>IW$t)r&T>WPYtio`KoM4*Mojf83hEVbKwb;at8W?OOO zY)d+v`3E3YWWr83UEM(7_h++CFNcy(ZX5aDFD8W+WUSz+4ipYlAl^yNw8Z=ry_fjh ze!v6r^RKdGa~4TqGXp0$91irK0)&1kkGQnFE%aqlBD0_nXKsz5uXjI_L`EgUFUH9d z6n}l0^Ab&1M8)8i=im%7y3D7gKz=7C^rOY)Ap+rYHux?=AWUH&FoA&lD)<91EsK4( z2rF7(l>)wBc%Vm`NR3IqsqWTvfW(29FSa_t2@FNwstyqEatOEYf#?WV5u*U%Z6VoF z`HALYNc?Q4geiHft9V>;A~36c2>~UBdqIeUH4|<>gz6X=8UTF_zkl)7<7I?%9LMUD=iwxXAYvX=VK&aeqEp>$0L zub+$*9B$@L9OJr7?~TIxELrp4UOb(lvu|qVt3u}mwt54+HrQ*DkO#0PUkR03K!4rj z_}>&6@9?ByF+UfTaXF8I44@Gz0w|>q9mJ2S01L#hr5?Xp*L1~50qUxI?Wih@Ll`Fve-xRsA^QjGi~9r*zv;RD}y=9!r@ZXU9(C1 zT!guKLZTgt{W_!QAtkd*F!Aok_JU5P6R0{~=Dd zxHmR_)WNxyLH)3GHi{xyl3Ds;(i_yX@4WKw&}xmZ#ccuFnfa%`q(&Z^gT|+W@%9LV zC3&|V+MA!dM}K_e)Hp2KPDaVXvlRc?T-?&arm6Ev%(t)A_QY`ck>Z!4LtG3B@C9B9 zaeo=*rSb~SLsg25wis|+Rp&M=M1p13f;|0ln&Y}~!$&J{XVE1=Frg0q!{~hV5>Wm30>&N(F9yaE|>Q1-~)e!Va_*XnM7qK;8e_=jOj%HqJ|tH8pnp( zUWB&$bm4+3%PYVxQ73L@J7f<_J4!D%SRbl&p|xKTm!uY>&=l;-q9UW2nTOp}eU08^ z0*&8;aPN{XEk(dxGi#RQG!P&Pd|JQrF||*O@OL z4$eNv+1@0Xl#Na9RG8(wX%@yI{R@}%Wz>aNsJ0~dWO@xv8@y5Wbw<_&>}1yk2VBXB zuXRSy^3AimrC1PP)h@k7)K)*Fy`Oor=-Jy&h35eG?e0&r}b+K?_QfH z@LfrZtO&QO4b5i6Czi>#IP%N2u&_@jMzaT-6&{OTZu3x2 z5g12i21pim1YI)^rm+ zGrb|lmJYHX)t=RiddR#xOiWv;6`)s5_in zTckwi)`3-=TPVz9t-7W36F#44y{XAAmL}MZWeqT&ZcIc3Ve*!mSshC#cM5egoBtzK zSWTi5i<<&}2UhMkU?L-stp0Uh$D_-I0u$fy$EyHoqxo!Lv2ewSHIUzO_>Mwj?6U4>n{dLAgrQ}7B3#FX_`-rS6!HgC=e zt_?^4s)@uof*vs$y^>x%=|t7IWvrzE9d{xPcf$X$bq-C!Ffg`m+qUhuZQHhO+qP}n zwr$(C?VhjhV(w;k`2nd)>LlkmTMyK$sje57`_2CEPfD^QP*0f?h|HvKloDz?SN5ch z=$o17MHkyHV>&cD^!262jgK_zg7_$xp~1ZI|7~9Au@%lm2)QoISsBc-Go~D?Eowv$ zSz3M(oKmqT^R>xYDEDex9rIj_A}DY(PfY$t>1nQ-@a~-&16b_Fo!izC7)^^L+AbR` zd#^I?6A|j{B2NW|ZL-;t>xjPP*Ua*X8dj%+QhCOYkqdrj7X$j2?6FtByU_&yVP20B zgQQ$-JP!_e@6W8)baFP|4rwcCyn*ECyHAOaKEE}PsZEUD>4AR{`VcalD!n}KphtNi zTa8Vp_`rJA{x(qxGzEF3^5k&jou`v~=%Etax-aA?6M&|6bh0?#tNr&&9nu`8bHA-B z;&_d4l@SVU+E=Baze~zw&`<1Z5VFL!-hZT^1=7wWq5tgQ{bF<)C=d3HZ}0~|G!8v! zi>z4b_JYXS^SqPc?ny9KVy;}~&$9Z83$W`$tWH;R4o!wu5$mh);zf}S&Q_#X@N@0* z^SkL=p;KjkOIKtzB37eBrl>_`>QrSn2_RmU5;|izE(vtyWDWX19ltbqp4&b*Qhew^%cb-#DC0muZ z)raPUNKa7l9qvg_11sLcb%WIF0SUDRFo}DW-PJ@nfdQ^~1`9VDwQ9i^vmuT6UN8?x z6j1{~*uEgAoU7kGqU31YTD+CnM3fj@K0)Eizmt~D)c(8d;3(>d2k_f62VoRJ`j7x2 z0fQ_Vb6zRBDAF4un56_%6_qYBy4o^u8%JYWFY2oDM~tkoIF%~Dt!7h=TqFf(z^WEV zIW;Irqy8yMGkOW*+hDSD?D&WM%74aga3v%&shs>nVmF~i_{&MnIDzRcllm`>&;YgwL zi##Fol*!6!Y>2p*(mG9|s7vO%UYd%3rBjQ#tEhyt0Eyp$aT#<$%iW7ZT0ye_m$$v41N#Y?Zx5cfYPbFX%VF&SnwS2v>ZL+o zYoRk;%jyV6S7wBWymQoI3kl_8S5MV0UL=V1=90{+DVVYzM;yS&Cd+i3-m#`VEl$pr zL^#r@cL;vCJ#nlaXixOa--qo;cJa2^|C7H3-HX+49fl;M0K$Y)!dNuzo5!kdU~ z2VGBa=O-$KK3vz31Tu%-1p-PCTfoGPqo4~X&tCyGZoFddrM)@}H7`8cnU8@KqGK)Q zl7WHxgXI2;WES!Se^74P{nsBhcS?(NMcGj><68y#CKV&^Nh0D}#PH;QI)zOpB3jU3 zOWv6%e<#9+ubNt^HLm%TFU&CpPq-*ugKNjv`vHYHyF^hQEGMs=Co}YRf>)d4txo*V ztt@Q5eQyGvbHH2UHw4tsAzW!#FHlj&Wj~DNh3v=S8GXd3?{j%L$b|L)`8X#zGMDzp zTsHjQ3vsY0sL8k#BZu1poXVO8x|Z-ZP=w2X4IU-1gfFp3-aBil{`mp1i+X$j6OphH zQXA0I7Zv4AjFk}F1##QC_!pbixWOo@F+~^lp~Us4N1D8vaK|V=OM!za?k`eds}$&u zG#6xfOh{Ak+jpLzOpL$d-Af-#E!*b;p||jb`dM3orEAP1gV`w}O*Jv8DF+4nhc;X` zMUn--s*@l-T8e^QbatLo&#*ek?b=y9L3yiYhh~yjTF`B52JZFT7NW{FVJYrSYcalx zpp}vi5B=-nS6?o$5IX&O5o{FLnE%MA8zrq^Nv3j&=GKC4BT9X|n!`Bxw<^C_ngN3M zNUmHwM~FV;KhmlG_!Ev2>6D02IHD>r>DMejEh~ls8&r|7Vrr@}&4lGf7FgB$4CNJ9 z2^Q5*TNnyAnJp$nMh3O|!}*4*CasZeGMdTCA5NoGT$mqFvm4<`G5gyOwVwrd3Li90 zSB=Tkj+J`6WRSNoQNr`&>i-1zf=KDm*ZPohFXSxn>S}`XLa{Ri5KFQh-UC`Y-iAOH z2p(dw*_sbIwmaaK%=3cHVWL4og5-L;A?4ViX4t4#7!z1w>a_@3s52ZoI9_{Vzhi9E z?ra>A^WvMUWVLo`Z0;>7wp(cm`S>9z)}1W7ObqRcXuX zW;jQL;=7@>23*2RT1m65n+Oou7=<&nEcow6FRFe^V2F79DqiMZla;>OWS&7~Qw0IL z$;V9f)Ou8q^adiT(Uqshh=`GU%7U2o#K$i~_?1YA2MFic5R8$TLpTouUS6u`)=;)> z#n17(%}#In`;i$lz1hWOT&*&rX%+}ZUK%2|UfLJ~4rA+kOkIrZ8`ccp+UHHWlQTIt zo?a~r%^|!e?RK~WKVht}c5$rC&jzRgrc;P7?6%!J<{|d}4nh}_knJP=N@GH?Cye~E zl;Eu<1}5@%BbO*lPUN4_G+_=o=30fQRBT?(u+QhmdM zDo|H3+WJf*qKDXlFlrhAUt0jLgaWP{v@!|NYNE|3lX4Dq5^fWjvOZVrTA(=v%2Z7# zJjgv(&>*KMkS1ErH1Ot;2GeM|-$HjaAwlUAvc0EYo?|#3(HK&TL%`rvtD3OE;D!t< zPp4gALed}adS-2rd$s0^P*%zvfTsK;UYf~w!xOr^pQmZdj=?ZpPS6m3f!TjMG^qdDZ(XQ^bgSd*K{15G&C&g6XG=k+eP1GWiVDXjpHmxc1>_T}bX9E^7ynrQoBxp-ru6%E}crD;FLirb%nXh$05 zikAusx(TXlf7C6QkEkIi1HCkcyo<_gIin9_ry^7l7#X$Ad7R2mO__aZoSUfE22L@q zbwOq*#P(`_%Y>v~nUmk~v0`8S?+y`rBhF0m4*H`OF)1H_B6y2`>OFQnad5h8)&^Ac zhzt_7(jm*{^>LXj5)@;!_%L?m^>3D37rT~)ff2APTKOWR-O=12I)M!P04{y8G|(m; zKPQ3IKSYwzJ|<|(V96gWA_>o20r;y*E=EeNvm&;e+tiQ@rlXI*#|QigP=6PM0{~lm zR4oUV$UbxTz3BKyNPN@o)Bizxf|>8LZ8MMAB5mQe`Gco<6wxPc_Yo*6KAK#iPp@Sk z4ZD_St!ZPmK%XK^>Of8p&A=<>AQK%YjLkBGf(Ozwq?DXgcYIe!W4)wWsIX|D5;xgr zxGl7L1|EhLY2>VM=06>IkKtwyg|d1AJ6L+z+riR? z9GranG^9AiVeI|*vF|7DFA+ZCB1&eEO|h+qUAxyzM?K@z%>>xw(uW6n?t{T91Y3D= zbswT!;2QOi$n=^37(2BZQs*u`F@etrC1ymyKNb-FSeZu_BG_1C1BoX?M7NTRh-iXDo; zT~0Z7T|F4uL3f1$cRC0XSHw--*yI}Q(t}t2>lzXbBTF_`itF|lGWMBSRSaccQogmR z)t<-#o5DPqpg3aHHkZlKr;^lr(*)IFht)Nh$%7A;oV}DoKigOrDt(WHxQ@U-{lIS% zyO19-V;mWj>y3-Hq75;tQhvV>{>-Z*E=GcetfE^d$}_7pce<7*XQZc99uhY1pA$IL zH2#uie(|MR4#~dO9!SU2k{@_EBuZw~LE=KV5AmqC^YI}?w3lszciV})UdCI>&s4(y zkd*grUj350YrNuJx6`V=odL#dUMCbE!lcK1=eHqCV+CArPM5RmTy%4MS#P_SE-SIZ zwR9jnkieIk@v`%#St5rQ{U^w9gxED70iHA(wPg>sn_VS??aO4=O9nXXu6WIY$T zS9u5`lxK0vcdJ`YO?go)Gb#a*zoiMG5rz>Y%Jwqmi{FcL4q@>tczxTA!I>yx@bC29 zX4%5mrnxM6Y0%rY<~E!-tyx?p33aAMy{Wvo9)6B_a{A-i{!ra&<8fa*Qt<V;nyn@i>^necLg$1Il4Xhd zu~1V@e8z=$)FT<)ryMUtqIAc$a!-+`ZyY{LBJkbj+2{c{+rEWw&t? z_r?UQIf)tzG&v-JPPmKa&)j2c_Bf}TN_BvTQtd27U}9OHE;CV8p^XmgTu!Vu#Nv`0 z?>4P3N$Ae#=@_9R7)g z)G!SvrS%Za4x1}J>2zGnF10tQ$;xYw+~YoE`@3$5D`u(ps*oydt2?#1u5?!4iiHvp z+o4GJ346c0Oz?Gc7G?3|SZ!~|&DDzo(tJ619LcCIehSHIt8yJ7C$f zF!>!N4y&;lB)-qVX$Y&SjLk9lxM-;2jT{%N2kvc@ZPh9f95~vV&;8fLR{a0TTT3sI zo_-?6&p~0gLUPcwE_6}nJSt>#0_IlNtlQxYpoLEy_3)y zIhx-n)-oifMsTo#mmrEZ-`TCz#+&SIJZ}=P@F2A>chnZy^`u=b-42wv^pA#l=Ser{ zq;;s6djFU})@&fKdZBEq+hx$oixMBK+K1;7{z-N0+m!KyRLbhRtRz+M zB8*}B{gl#?-pNHZ_o{R|=M{vpZVH_eJLEi-ICw46x_v-Y73`PYUhL4yNO#Is29CQ~ z(f=1aJXkv1*?FPQK2@pBrdE<(PkT;1hq!oZ9odk!o|_yV1YTv74Ot=4=;Mbh5Tc*r z;F*bCLywJkz36=-_c&|xub^(_>W=HH9wEC{oDS&1!b2%KbP*tVka2t7X;-3S7R#4> zNYkXSK{lMQL1KDt&CU)2$O-t9iE~Sug#ZDWw~c<0T&|=BB<1 zvmMM5jxce}^%%Kr5f&lNwF}qQ_dDlCpD9a)Z+y;{`S*~3WA+nSXtjCZgkIS{_}j=+dAJV# z6|$gGFB0c~xi9gY(e_QX2TyME&w8tJ%xekz0+^R^n|bU-CLaxP&tRjeA+#HwEDhp3 zxoD)ji!_FB&)d(1mK{4MOy~g!vD)Ps*%9>U)$_p;1uN@{2}l*9SCgb{ljx~qkApNw z_9PYG?qaSc0X2rhH{O)Kd*;goNj+kyuty`kF`|4-&s`V`kBV;@A~y>|t_)+LSO zM0Qv;*5y=0iQaT88sg9#_*FC1Cy~c-TX35K>aL`M0- z@Yr|oKEV%ZOo?C^w3RF?ID^T~$Xz%KK?9|HZ-+}tYzjhJwTHCcQ}11nNy|I}tIC%q zHP)0+{8gad*qaj5mC@#+3j?6W>GewbU$&g`DVPbL{I+i+V~u*1ps$lfRzoXB_$G>!j2W*u$DH2g zxWVQ9lN+!=w(sic`cT%pLmX|(Vw2=25uo#5A8?xG-xX~ZMSq>VEXmHKy(dWnQMn> z4MVwgTa*MebEY+De*#v+raDQ$I8H~5Y`Cl?lKR$6ejP@d>jkl!mBk5wf|5y zEI5nO{Yo2jGu|myUQ6L1vlTOw=7@tkPg3YUeL>4VzD#;=KLbJn2TdBDZ4$2&uecRh zxG&A$lVV@pOO;y%G4TQSqw)x!skC6-hgz9hm2)prOG=!fnl{vM=$rs?9dfyo+PUduKJVZ6khUmbaI!O1%UyNMfkF|BnW8L!@;o)trH8!Wa$%UzAp z#6#$%w$Cf(9r|8&T#MZl$dOIh)oatbK;U=^4w4pCvvdW-x|mv3ms*LqaOxP2;~oze z?3z549cwx_7>tIQ{OSJ^K0meU+Sc4laq`#7@wkwC2cOHKBlI;nSUZ@*6qXpn;&E0O z_+xd@Q6Vg;vPDFt{tPPu63{t5gw>m~Mg>Gw&mC_~*>z$v)KIkMdn=G9DeM-abR}`` zTN;Gy-1ltqQVB-ILVvPWjOxwA?n%gPR2BTl1g}nBNbneKj$X6H79aPE&oiIvR0zAe z{mWjhbPcezNg#m}QDhu;=1P`0SW2c5U=Yi*&azFB4{HO&4bCuce26P4!iM9p>@dWI zu?7UjHL|z!wZh#Pm@P}e6)vmTq78UX%OVY;5EKhPJbv6E6+V)AL;4)+PZmgs(h2;Y zf*mLzUt{wXH)!gM{~{@Zw^+6?Sjn@E&n3&sg)$&5*#;3ntXbKL)d$l#ql+ll`1pF- zO?f0*72XV$o8eV=XlOgoWXWYnliqAIJh^8nPAi5yn9i#qRwk^#GE8kbYe^aZ80y__ z3RFy5vTKj9S~~IJv?kkxKIz0eGa87zT}(#D*h(+jVGYG@d;&!B zva!X@6X84%skdm5OnlSUcG6PHP}Vb(UL}IenM~E?k#2+CXDsJ9=3ft}ZE~q>d=Mn! zojz6@NtFllDf@Pv8S;TeKcfT^+@mV%8@S8{!`#g-Up-j(f8gD2W5U882?uZ71Dgg0 ztb7QtXPB5`lzh#7jjSg_tjc942v}eVe31$#sl!-CyBTK7OLO#w)d+T@d?0){_x0IO zqjnQXaoy||DZ7Z{1G*k0z27+Yj@*%@#;A>zGBY9P3(=e_ye8&88RG0XE{3~`zoNu; ziprK!wa+;@aFcXruH#WzI;@N{bRhVXONOJyz{Q`Q+jzSNbS`61Ph2G|xla`ORO-{l zJ5>`&agJB#N#9=~#mLi?dA;sA5+mw|EB~^l4mvneD*|O4LpFBH%v%L~#?I;cdXGU5 zHM-%N?dp3Z1ENXgap$Q+CJy|dvpVa_$a76kT|rLcxZhcSUuQo&P>jT-^^o6~;~KOy zhfOIXWfId~k$^8|nmuoRebcQ+y*7~#qyjJ=F-bWrCqXyv}awm73eHFob znThuZ=lkO~7f*9Cno`#}!sB63fOy7}JjcywUQIceV5TR<6EarclFvmi0MoBgtIa;8 zTL4We{5WE(wN;ZOV8_L+@5luQ82rQ&ZHc3yTLjkXB&U$_5)697&5-7#(Ejtg(_+Nc zm?;aerQ? zTa!FK7i_8gnd%-q+#c7yi0a^zJc3sILv<|jJ%NOrJV?`Jb#fL5pEP}qY?uc#YP>aR zR5E>5!O&~kTS?W^9#$qMboZO-^bGvA@w!HBw@U-nE%G-AWDZERW2z3vu_F)f$WH?; zusD#PhR8Mn{Bto-W*aiQ2Bhc=&3zds7~}9=F^!2;J8H}84cmZYQ=grld6pjjsYpOl zNrp#F^Vq#p=CT%WCtB(_PgIQ5GI`!IgtOt*Fi(|f63K_$ALQo$HKrYg1Ya&H+b}<1 z*PZ__O;Co{s$=y~Ix#h(^Ad*pVS|5)rQCiz^C~JHhJm$ults-3DW}%={Wl~*!%Iv} zl%Cq@MbNqYLzTL)^W?(V70EM*j$?e)oEFxIJ>tHnC=zlwhSg^vgdjtp1S{g_a_vJNl6HvDN{FNaV{s#xzBWzy_K2{9jRxTXJoq1 z2d?~sP$7%XFQ+?*FHGJB402kFIqGDZ+ebg0 zI9tO-=v{h((|2Tk4yUvFoOdY^9o|a16`ieOu$(B$!1xSR$YS073m_Zv0~qhQwG9z= zt072SXS~MJ$U)mKzjz}2cEnrb2GND^8ZoUEN}&x#86ec2zX2vt*S)nJDzQt~kMyGp zBk@E2DKTlzlPM*|V-kOlCg0t>IuT10r=D=9x0TS=1LeUWH!nnPEG!cdKaNewjQYUt1z^pBhw5t_#+qL z84D%`#T>M@G}#Hx6WS;ZE^^}H`~)rzCUCZq9{}T^cTeqXQhmr&nu(QnABaZ`xMlR# znQw1YWDiqvNnogiW%C8K@*h_Csr4%bLH^UO>7e)BJ<7#X?BBuq3`rR9+J*_MWU-so z3Z~>n968Q7jBz3I_7zC{mSry`M>G!MBwZk_aQj)x+wuS$H#8OO0P1KHlg1bq7$GJx zDj6wc93XjnC5aK?wH{>oo@TJgk{x^|vi{`w;SimLC+^X;6oR#R(z0xzxgv5=^E<O^n8nxImNPfxu*?=4oLBn*%3b@o@ogQhny=D6Px#>LgVCR% zM4e2Jvg|rO0QW)_ivGWEM)c1gj(r8iu{qFo5F?9}Lt#s0P?C9uT;xNTDA?OJXn(OI z1NZkAq1E6OLsucOX-e6T8bQ*2EnZI&yEi3iSC|&=X*8k&F9#Xg=%sVDy~-XaqOnp% zEmdXIP#T&f|1i}XU+ai~z03>w9OZUIdk}44NP~#JV%2OD@l5EJRnk7XHuhl86>8TB zhP6)=h3=@c3Z2%E-&|c^mFZHp@t2gzobNHi9^S3mlFo%Yz{)Zf2NtUJEze5Y*EzBQ z?qVUL`(;#@8V8wgvo1XgHbSuX!1qx;_c$gxJW=?<6CaudOWrbDcpl!1%;bIFbToXU zc1X>A{nhK-sJx#DrCvUuE3F(F`T<)@$0}Fe-Qv>sS5x5stVO(zbA1k7RKaadrJ*Z? z`TeNhT&)|N6!S~`l=zIaxbVpcSn)Ojk(_Rb>d9@T^4Zb{#*j2OF&Qys8`mQigVl&*aNn~Hbs zE-6fGD(7!@>yE-2-Z6f1`gDGNU=k<`xga7CLN$XZ)f+be1=L(5!I|aw_lp8UZ3t^Ms}pSF?;0PzKt%D z;R<Ex!Id#4uqkRX4_8V_pNOp8bsqnc8mhh6-LC|FoDAm zgesKpRYWTEbCm#S523G|mm4=t2S2yHgWGFUcL|IgoHm0RG;H{f8UheZmkWk<(^@y; zW4#TT!10hj>v9O1*e4W9<|QT*8J%$93U957Fg1bZI07sTVIg-zukh`z+Z}GG(Sjf) zdnIoC34H`EM+=iFR$$ze>1I~!p}+fCf{pc0qDi1WXmwc5OoZBf)+m&ZjD+38YI|ta zazg@5!Hg0vp zb(1;_r#>^nQ$efBxqRnOHMzHINJ75jr_okW*fZ#x@YP#&X?*EW3k3DzOP=!X6JA|+ z7vCZ0LcQQ$K*8O0v$J;eDh}naDt*>sNf^^`F*jh?xK_W$2!e(^LL|X3G<_A4pP|BX zC->5~?VwDjCVg&xto>GjUHReH4#Iou%g^Z+^4 z1zBHsxIhMi&Vc$4Cn~>K$f@sZC{QT9=Q?v3$!yY6G9&>#51yeQlRcVzkQyx^lbSv( zl2qiB(@zO5A~Lx0%ZBz`i$F%Z!pVGApb8ZZ_HRFVtFu{j1nHJ@ z&uX&pTTql=PeTT!5ID9lL0W6GORcJ*x^H@uy<=za1Ce5 z>`^iTV6>(UL7gCr9l4F{PEDn8NEUXxLoat#^Ixcoc;hdVMGs?MT!X4Ef-r}d9$n55 zl;u6VA=dnNkZ!k^2j8o@=HP?e0C&^PLBy)nyvoHeSKhQaxO0>w+cM$fS?Keya0uZN zl;Zhl7I-CiFkQk(ilj+MGX82QX>^e$ZHJYtdbE&nrw0v{{@X#A(84XIuK`hC!KIq% zo6xE2B_r<9ngNrqykrLcr$8m&AI^ z;$Tez8db4lGM)ST8MOPAUWlI`xGv=;dtH9XkMU>Jm3mTmAm~Ecur3Trh0nKktznhdp_98-!J6P-Gqb;ft)5-_C~JxQld zY`JW;gSDZ|AC&ZM(f#2x^Xu6gB#ipzGZ0L1p*9ufy4ttgRw~j}G;mB#uaSkrx@CJe z(DJwugF}ey`_?Se{(T1&YNfjo&ASV{Vn^QKn7f7BX)_QlFGMBP)Wz>HtgQEJ8hV=_ z#c$JT=odQ}xUv&^mTExss~ya}jhF|OO2rPk%9D&$(NIkQP_DoaYDo&z@cDSl1G3sR zKjwS0=G-L)4d<&>^)n zqUYF^C9YzPM%Ef)n64xVVC$QkNB81f(PS7tN|uQ&8RR~+?(MjLJN6+-jydO}f};(} zTUJ6ceY|K}RlA3_e~Bg6q8`mve89hW$NH#x3mTaw1!AtlV&LzE?H$)sriQm(`?+}bSB2iLB`%gEyHR|}^{ z2Dx3Ew?};Q*^@BaT$QSF?xMa9ET!Rp_Foz?RHQhcZdTz;tz#avG;&Y;Xq&QFz#e(r z-M)(Z5_{uk{SbfCZB0v z_>xptFCyxe4K|nOYyZHKBmm>vLz<%DN_zj0Y}GV{Byg-ZT9w|D6yqi6g6G$Oq-ON% zn7)Sj*RDRS3krM6>ok!tWygNX)kpfBCg@wLBP`0e=WuMb7iyiXHS6X`Zqka==6GnU z(JeNCI4NaIvkNRB4EW|@SA^oB0gzYr;^Ko&Gd3EF;yLZC1WjN%=GJ8h0pt8bn)8I- zRpn{I)_{F-xTl;};q5U;hRoF-uNhP=SbawUYQfMu9))@^I&kTeGFCvwYHsh-wXOb?;TZ|skyRB4P5v! zb*4qcPNQe*4SD4KGy_uB`CLmvGsbvg7#z)qDX4IfM#P6GqSCu*pv6p&_wrnAWX@HD zA{w~42la3ulkPI^6f?8*CgybSOem$+t^?0YtuA+nkvWx8`#Le(M}s9@H+s=bUU!iQY0xjOX513i#A{kQv)<3P$CQ0n zh}bDLB%VyhqI5N=+*Uj#`M)}rE%GlDVIO=|9agozYAC?hm(~OO0$xA?KL$}nWaAtd zV%7wOAHk6pCoiz?VvRa9@FD3-ZZcUp$lxrm$pt|@jWWHGGQde|nZ8%BTnd`hRy+iU zxfTXkId9|RW+W4A@s&M0EhX?HuY_u@i>;!&3z%u$uoW%%;n>hM($F<*hDAH7mdQCB z8;k*wAA{T_>q=id4AYmryP&OJgLqO-rfcz-Ih-A5iZ&Rve}xs3Ggj^b3;HceAv@I;-FvP?TO6w>$bZ-BgY^zjYNvS0o|GwOKB}jE^T(Bs?K};*XdBi>|}p?3SJqQI&~#DQM6-xLT=URVqKs zt~Xp>zQep&T8UmDzh_5>ba9ufnVcg+#NSokv3AfSGpyO;+ly~lyMySLCa||#VjnH zlQ8P)B>*6uZz%hD#xz2$@)|DU9()fSNSMQyX6_yIgWrOUH3d3}cQCuDD9}WwJc$t6WZEpjdvE$1CgunsMn{>NmF5FX!v)^UNlnTslVj$Q}kUV-CLjr!qlxdP9oibUAq{(S%WgMJk$4DX2M6b-35#Qll2PGbH~PpZ=L`#q4vUYs_2Pr097xjb*7joR4mR-H)3 zt?`V|d0XmMm8J?(L2d~=dWqqBTTdOTrHqAL?k>ua8={E}t&QUKTF*f-93NG#P>g)lF^U1>M0A>sf z;AKkQGnyI4A5cCDd*Vmom+K|Q8q=LXI79K&HkfKwtS=^MY{3GEZO8>tPJ?9>!VO*_ zoOj~x>)xx%p7yIXZV73VT+J-PJ0ch~MxNZR_1S|#$w$nhL7k@%y}nN2dShQ+D$hZ<%XnxU&+Q;d`FN4jisUQ+w6vN2DNq~{qh@y^_2uW=gD-IuS zPGjJXGP4(bCBq3_&<59Slugb;tA-10k8U)@&ng$Cnthe`Kz^8m%j0)I)j@i3%Y z`o_`vAo+Cn20#0L5u*`6OBGW>?hcKDXvEOGvF~s^BwyH~ICAWTz+@LT2em6>JmKlD zb)UI>c9#RrCC%R0Vb!wooH`Td$7?xqRfbvBATpmx6CfwE8ajRM zPN7NObM?A!K~vg2e96YoP}4(Z)UzX*&puMPfcMU3@CFEu+EW970zSa#8^Xx=K_&lk z?oL@VBTb@BRClmz&^fc=Ccl|vnj}m{lEBLC2r%2gsjx|Fc!0i`(!HlSrUI_{7!cW) zVpnp*&2=FfL@!^WQty+5Fgb&FIb^7W%9TmMP@d(J!|R^oVYiqu*DJVA>AFZDL0|oC}fkW+A<5F26}bKyw&%O8XJU&Ztj>B|C#JCSf5i?dK|SU7OgHyA6v@0z+6 zTSW{~Ggy|r1fcC#v?E^+_19WLX3~N^lLmf_S0-6?{-?okPqlvzN4{Bvi^Pd-7GOVe z>)30ZIo%g%JOTc}hM1#J%LOX=`t`mhil zObk>Qb&}5{H{^WNJ+?zs1kCORt@Rxm*F*>Fa*Q-&%$;E3b8SKVrK|Tf5$1E{u;q~G zAR0^M9g_-Z)qDqMEVc69(UC$b7vOX{1uMP-O@B{w^)BE5rYz2N6Kgi&|Jan>Z5Ci&`5vn+Tiy$Febj;^l>Ma&|N^ zuz_;ljB$ZvPqtd`t4W5C2${6nn;Bd;*?TjAf;2*7O3nDk^hz2@0ZzL*sX3_tVM5tO zlR)~FOH9(p3bDXe>Et;3=clvh*0aWP_tkZ`*Tehv6CLhf5)+LUxgWVozE8=BpivK% zZ)9o(9RQ?XpG|`SV}gj-FrvV{;5VfqJX<7Tj00HL7*`-9NKC<;K^G`UoQZhv-w;O* zkN`{oMTH=O%7Eb?I56pl3`v5@kA4s(1Zdjm{|_*ZtSS5)Asmn-8#`4n>OW)+L2NPr z!Q^D*BHuJ1Ej=@2nD9Oz69{P3YoUlR5jP+<5K>qv$oEu8J65V7VWmI6udi<-1brh- zz_F{WAlChmLcKprW;EGHp+djzgg?h1^iLJD1{z{NS`_i0@;U+o3Lgk0>^w*=I|-It zX~z4$f;kd@6x=#S1`wJs^Dp_vGr0iP`w9*K5%kB{4*eC682dN85eSmRJrU78AbU5q z|A0p!AheH?MkJpI7XQA2mvAt727i;-`+p>T2sNw&u}cVky(uXEd8%&}d`yW!L`q`~ z##yI2(fM3#&8(Mu3f#anbSyc-rt6ckDB^;I=3a1rU));o-2E{4PizBwcNEh)m}GcF zkg=m~pLx;FK6YlrDZ32pOrZXL{rbdg9RF9a`CoAwb9#Rp0K^|5$PMHrO9)6Jq;P;x zRWMGFFo7jq8Uf>AdaV3-?|DLjFVsI#8UzUcK|)G@>P^@%vyYn`GEpO6!_AK*``>;M z2AgjJ0Qb9(vnwQ}el&403zgFf!BMAS;Ib#c*PcDN!J!FDkD;^Smzb{7e`BOC5@IO2!F$S3E z;vfFsxuM^o<3F||FWuj@e}8tOpS-!be9wn`kbiM_2O&=|?<4s$HSi&=z@{LZWcz$1sG60${1p#0Jh8x|ACnEtM8puB*k^vDO@tf1&AzI)C0T4X#lY#kd zzw)^O27iH1446^)hZk$(_Fyt$+Tf`G3Fds_(YCJGg69qIno4e9!t3D$0TCSVi%SlB z;1?AMZ-ScJkA36;0Tf;ZG{L=ng(zri|KQ*2c!_<)Nj6QMj8M(P?%94FnhF+v%}J)@ z`2Z`h4s>x8K3+1=^75vg!Ig7sEMCA~=0hlX@b=kRo_X0>L{I)R8BYRZtidl1=!`A5olcbU&SNHJVu7P`a8KS0D|Wa<;j1)> z9TqpgO*-%W$bnfFo`7P1tdp8HEY3An!{9djn=VUEK32yhs%*YhLp4XYczIUEhD=gp z;X=F3UifRy*jxt-kzs{BlUO?Xl|0GHG9u2DznjaE%BWG>XK}ay@)Rz;e37-;L+KN& ziH1OTBkgPH&LEzPYS5w0ntNzKh=w3fp+}L!bmjGc`kAj0XlePa#vr_KeOPU#`KqsY zEeK3YA~C-x$Vxp-v3zCpT+k`lv<1Dn;=mGoHJ*_!BIwFQZD_*%0luemfb2jJXGfnl z8t8o2=_X_Du|GDOW#`mkSg$1)SL1bBqhLx1$Yi{%_p#8estdzI8(#zO7I^6k9 z0@uD#>Q5*A{f~})eZ4>vA9UO_7k8b@^=d6z>9BjxSF-2u*+fD0ujVhZjZQ+Iab!^L z2i~j&J7jf?ur3aR?rTNPoV-*WGR+S&X`9UZ!hmV~s8iRAZAR{QbzD+!9GR+O#-sW> zb7=`L;nBM_vVTFC$_TQgmBsXxf!B72N?Eg~^`RS}MKskVy{&xEJ$6z7w`Z6_e^R3} zh4te)SBFqf`K%&gXjegEo!<`p4W|}n3<)<62rSBN1OJfMAdZbg)*h)pKUJoZDpY3i zAtS%aG;)2~(DCoK%V{pSIar1u^*LFrm_7k9y$f+yY!EDdVT1K(vgw)%?#l3u3hxca zC(PUL`+m%_X(a=lYkBNU!m4PAH|*0xhAEjo^egzD2bGToONgZ@8{ZhI7k$)th`c|J1X)f`!4a4=9+;nCX* zk{UyqatSP#f6twlp>U`P2dnt4u@8ILMpRi{0&3YxX=bD26;N2&XN|gIsB6*z>PS+B zsSgg%N9(Pe2Bpt5qp$A;;D-MmXv=`_yl2hbT^!T{&XAWtL#;wGA!mbbYX&Htl$K6o z9865$4KN_?GQPI&56QU=a_vD+_H8_`aubx%Gd8dOyAH~zG9d-kPE1E4C%YsIL*ET9 zspodIUp<8vtI!qO24$}Gfy*Yj_dut+c-DVg*Z_9)#NCDUbhK&(!X|KaKY!5VRo`f4 z-=QX|2M(0it^7ki08v4a&eG41ACx7zf=7f|ns4p^KO{Qw>cnSj;eFY3XJrdHN-Ie+@b|F8k-kL~Jpd67Vz}@{UNHi&&fUYlSv@CPqEicGkNm@U%^w zLd8@*W%>X)=!M2+R-S=+J7x`o5Y@m?Ye5O-b<{NyASxb1i*E{q$`Vp(x~8YMx(~gQ z)n>-$`87-#>;ZjTd~vHhfsrbq?z(%=Z0$}&o9rcE)2ObH868CSb~VLPYc*feiW%V1 z&K;q9DOA^dhFvGjwxm~m#U$lv#p`+*AB@b)`%2Iax5-4~EMhx6q1aKZ>t#Cv)(?+UWw{>Lo6KN--fHL1hcHlCH39<#($EADA z)7iFOXTdwR=2rwp3+p~R4z98#g!UFcjf372`izr!rP8%CL*Vr|pJsH#l3WnNzx9B{ zhJoIt#RVd?7jsc29JuBs^v=~bzE845VG~n1A_SYejMbQo>8SH@<)U80^67DY{K1=% zvLRLu#`y=aQZTo4DXxzlP_%}&%N*!fpLz>rE!84As^Tv;sb)kx5I?U zKU@emBjp@N%<%J^e;TJByJ%$GWMC)X|3Yt}tGJq(oLh9Ldg)}Kuwh5TX9D{a@>|a6 z{P@)R9k$sww5aB?vPO^dRq$0u{b{_sgFh{eU&;HNg@B(zM`BED>ZQNaG=cLr zg`584R?UZ!`rypRJp5wbLv}eo`sGGg#jX;;LG($gCDn5Py`b|J*82WSS=-*znWpU+ z%d$BBEUw00O&n8VQ*4Grv4^Qnad5A zJGmQzU`s8wNH&enp3tVH|!eHgUVOwhB~YW3Gq@Z|I_xJxjDD|=m?(&Q)^TsU^8 zp!l>vi;c&A@uQRR@`jy&=v45A_cUV<>2wKkTR`Lvak|gzG4h9K!G%-@yPJ4C;M)gL zKn62;7COs;b!*38DMIC$;=;1Wor3_o&?mMov0Ie{X>>i@3G&a>)ybT(PWbokC!GM9 zuHuEy3vQRk453me+2_B7llh*yT&Ae#mmsF{OpJbBT&TdDHfIT?3jxfFB#Ysh771J+VuWJ?1&33A)Z@T1zbZwm%)>U;lGOd5S)EnMziH%66U*>2lFb&a4$Xd`l z8hUHOKlXDlo2kWgso~M2CFxVh)4MqndgRw&s`scApegCZ?#Uk@h?~Z8AiSSkj}yZZ z3pLWbkLjPBV~eu1=TL1!=AVrE=rX<+@>|%JO!RcIy1L!qvjy3 zb@TiO)-JctYVO^Pf+q%bb!z?4J(@G74>S!Q1q`8d*?)bdr7uAjbIC;L;_20H9JzJ1 zhLgEI9ZLbdt6P2XpO-!7d9>xT#27zbSQ?ILuv(RAgf;Kb?{%OqH_4Xg9B#<|68WaM zepciIsnWW^#$KHzNph0)8GuruZ@MLJw4IzuX#A}~IjTUJ3Y5z2u*pcp{3hu(WV^gr zF7X(bP)ISv@)+_OM!7{O*Elh_h(NcPp3tyu+h7SmwD5~=ueHTowP5QF99{b&I$A%# zf8Gv`J^+@EBm#H6`Xb%TlRI}yIuT=yG}QAdkrI${+i7o+9Krn@&nl z3vrY@FMm&McbmM=7=2W%jZJAIxXPMau3+?4f*2;^&ParfKKAlm)S4tn9+0!l%nVOX{L;v#1qIg&f|LK* zMg5|G1$$T~SZ`n@DY_gBq?TQx_s%Y#Q%#;ePWaGUk!)d9u3>D$A1rPO8FPz&pd@MR zv%Z#D)ODQ;kv*H(nz0o4JdZnm2f{P_g&nRIb=il6lN#CDSjU=VV=@!<+B~2V4iTB} zi5;pFp}1f?(h|Ez6LyOMV7y3Be7fwZr1~SaJFY6m6@=C@7u+TY&zCNB2Z^uF<$}sw zhd{BD!=QFKDwpUW{|=$*%E5dXdmr0|b6$d$K~IW*jL^p{?o?VEe6C(Md}sb}H-c4V zGi+~kpP^bT%Lm-Z6o$Od9Cyz=UCgy{dcmexDHiUeDQhKMx}$i_BKTp2#i17r=74-u zM|V8C*h6o|(rPfY4yol2ea7|BDwBrn9frTS%oiMjK}AH!Ol|T%xy+0DRE|cHPcz*F z)QAQ;FfIsQZ@~;=Z5Pz)OgQTtvI!LD)m~ePbmc`wic_#*CMN$QgUyx2B+j&wq`YXKb=|G9?ep4A zQnNu7N_b*U^}H>2oWy)%{!ANFfvTh3J4Q+ogL$r|D`2A; zk(`-w2WxB`hbuacGFdD1_|xc^ll*#7YAgPw>SGo>j*7)$KonTg;Wiqgd);?75v3&M zx^T@hWi!D$)psV{hRX)4uH!cQcF%H@Ab9ZLoAY+n_F;JUX@cjk>pOC6PEv$2(%mg* zJz^9h{WwuZBL%m9D)kymT==!L0_R22!9FNPwrMLK77V`D*v42)H^7HAj3?D)s$*j;?f~1TvxV8Uy_*~XYS5O9PR+ba1aXDV-yL<#q6@2dfR2JiX z#x`K>Z;V9|jSiXFR56*eAgwkfwCBZdDAhYKOc~Dd!lktJdYmETnBYq}b#w_>A?BEM zg_LPTjstiXuYcVXfs4wLv z%~EPUFKMqP3s&o`WC>wfxCSNIp$xPG-`FSh1bKXsQ-(^ro8{?bNr3LKMA>9T6DcQ3 zMuHVj=hDa5vY==#{146Ev+2>U>7f)|Ow{~xaRYYWc) zpRNCj>#@^wF#V5ly(VyFq)o(X89PFmaOOV{5Q_1$8IOcAo?^s7Ac7M3L9hYHfM+7H z#pIMa<&U&Fg>JF1;m+`}z6HJ~3r_!G60WvP=wUiD>1%eA27}g7{ntN$W*n?IT+k4t zHvpf)KfXCH4+H=N5f$Wb&}eHbGy*!=DxWDMtr7Y<%wIvtucO?c5CMAi3`UT^rv*_0 zK+J1dfLeM0YEn?t6rjHVg7~qAe%K1;6#k5Zzy?sWs37LKvGi<=v?PfUY?uaSF@3fV zIXM8hJ-!;hGjL+zi5y;t}Pq~gP%^o?SzU(Hy#yXbNd zm|(q_neg)H^DtO@(T%}*fU8r0VCR|uIB4kiEe*?d;J&?lX21YY0Y5S?a*s2@5QjDT z5Xj+g}1mj~bi z1kl{(+;8TZ2SE+X%);zFHVE&|Fs~}93anG+Wo8+OM`EqX`HVv_Lx=OY+U?$CxCrNS z$94YzVE=6l{-N$)-U2lb5^ilDSWNnH=u02{UcJ;u_a}z{iH8RR)UO6eMO(yuW$Man zfx28Fd@aGy`rA_jH4X|ef(rN`)@!gz$Ee5l4;&>g`Sar_DUk| zebz1r=%rsZ!>=~1?;M7*5X91GMPTWdp1ObK}lY6L!qdi+!o2*@u$3>gRms9*5_-m737-lFGw@US6g+qn% zgl1UO{)rISMS*ttnEPE06PXn84OO?k`7LM-a!faPee(Sq;rS^*P{~@;15Y*dF|)0% zhll>&()@ESTFQkP|n+8|XH~yP5epO+M+=CPi_K>L!92%FOEKxQL`-nBR^*SAeUKFT(VEzYk)&&Kx@}XB;PaM=WfL zBqs%#C3=r0sBT={hBB|_M}r6r4SyicX+O_}asU?LTM* zqp9Id({ZX%84L~pbYk$bfuR+SfK*jb_6CIxTPkqmkUx6u;LYJe^x#Znt;sn97?708U4XgvM0 zTMZi9)|+#3aHEJ1JxYG{?=n4H|L7c0 z;9-~))!z(Vcyg!p3)`Oq)fe)HRu-=8h8XooIVkq+28X~Oo-Mlb99vwGzQE2=b=T7| z9mwyOUxIWzFbs+Sy5n$#4~MEV_0TX$*O%69T?iI!Ubrn|Muo`ie;!mG5VO1NYN*}M z7N9BSINsjlNF=n=SEbe(YmyG3F7Fp&S#++qdIPxoxX9$}ci&4|}B1_n8pGZe>>hs2WuswqN@u8Qf zO@r7UEVwj)q{72!aA=C;dE>m(?I&6v-ETbY+$~(~eJ(r}Zz;EUh3U76*Cu>>jYajJ zHBTM#Q%!dsxmqYyK(>&MDU!6sMkkv?bMxY0P3WTN*Ys~z!fTmIF(74 z8XjCsy5AFGn692a_Ks@;a9S709CKb@6xNvK%b{N(Ob|7ZDrC4_qpHF&&8=ZamClgN zHeBM(gonAA5Q<5p`FiKRVf~N_S`pt=ektOI%L}*NWHCK)jrFw!>5^}KdV!!ST2^I+ zd_Lj4)8BR4fdlnK?$dYcEdjqwoorn_+4b_))~mEP2yTxM5IZ6hJ=zwOWlz#%OeXI4 zdf##P4^V1{LR0V)M~ot-j;`Ssd(ejh-*Ae*eIe7446;s%T7K`hm|yUJJ-ZGEmc|%N zA++*?V9_f0_W@N9=@%>gs$B$;ANC5=U`}nm?n@J2ny1F*fCe{N52KpKuj>74@#7MX zRstI&7ZwZ;>|@?mDcAT-QG|8w{DWDEHGZdPT24gamK9Wbakl1F+k8}+tB5j

  • >IyM$`dPKZpkGkM=ITnN#ifPyOmffI+Ji||JtkX z8_8Z}t5|pgVs?0@rLr|4by7JvkulD@lhu-CwKqd3Fn^-0R+s8NO`*4KXvl zHE~(RbUzMT9{D^l@-?q!G3>gkWLgkS|GR-%x8*($hfq)o&re+Qzq)8YjO`AkY%DlE z1=*s-C7k3~oT~VMG=r}@V;epm<-h`=3nyu6ZFpI9 za7DzJjv9V+g#MB%ySyN_BVQI{oCnL4HSjjAXJIQ#f&4Sc{@g^CKx;nK{vG{>ALE4% zS;sS(XAj5Ng02QL30(j}nGUVA{u2P&TTo%%y{fCuOvO&*nXZdnhA?e0x^({0Uh&-8 zNZJl+L~U8`yB~*TSr<6x}(KG+P2*ym~#z)K^; z5nVd@n2a;0;pTRuEGe`vkz)xYb{m7>6LO8QyKIM@>LSl?yFJwQMjmeW#}i3qEzEBs zwvR+l&WsG*0O6ux{U5M(XUR5XcFB+q{+goY9Xr8Yw#BKzrQQ#RSpyb7^tPm-^9=Cb zWlTT)KEI>KgYPkC@*{Um4Ry53Z zEEH~X(!}{8f9(Uz7<}~yzIZKg)EX z|De&{SxFdQ~n835wC)(xjQj4NXH0J1u z4Fo`cU1D2E==yb~c7?mJ`L4eF)_t1&ToCx2Ghj=w?wakLSg9uqE5zm`1VT|IM`(Ls z%Zs{*#OKJ8m0xJ!el7K|tU6v`_sUp1StDriLspea;cJLNaRX>xNg61^D=X!Tp2Ft^ zXPBrzNFaX4#6@CX-G=a_(O3Y**~A;um-*M2RcAck(!|hoIBn*)a#%?Q_e{xJ9fJ2f zyn+o>vzazCDTSMikyQ4i%vsY#epPmO+u`ml@|2A+1?F~kyc7%_j&pLf_zZoQp4H`I z%P?}vuE1J#wJ^oVO*G;0Fxa%Aco{=m?7_vcw-|J&BW{b*dbU?tE)f3-6Rdb$j3Of# zwMJ-xrPLy!S86H`aGN1G|NJQ~tYEm05(Dfuv35w?fdSXajV;lO#FtlFrn`LKF+5S~ ziL&y~zw|9{d6(?atRvgIo3r!ri(}7Q=gDT)Rx|*}a-Bxj2d|ziS$sluP{$=*;^R_$ z1i!u-`#B)mV>iF{%q*)k)iC4+GSqs*^-ZrD2~+cr0AhS8)F;Z-@SA0He#5GW;$0A% z_@veHHtHslBFXG}1LD8a$#lDOVNA1-C5G8dpNZ))_kGGnvAw5rbN{(yC9(XI<{|wg z2&YtoGgtjp-AK!UzO}KISt#G4?qbT!$qlM|wi)Sav0|QN?WBioPaoFpW|x+F{BXju z<0~vZSJl>FeLn;SgO=^Li$ab~82$4*s%`Ghv5{+7hvt>2L5{A=VOu1Url`&n(&iVt8nRZWfd7^z23z?y=Z=t7+ISd3Nh z8~O1)DaFtO)GmlrHBR#O;inL%$-rz5cph{(OD+xncDn7F{pBor`LK7})3fe#X8PlPWd@7FnsN^~ zMQ{{5)z~qyyI*CQ56mZl{k?vI4rdOG83mhmVPB)EJVYEG@AeMAghxaw001Ejj^Rr{ zN}^voW6llRrUhuCe}0%_yt?Zr6@~bcw0|vY6#1sr%LI?4oyL*}Hwmvrx3Xz@SemXQ zt97*OMB>U#Ov`$Ac?UXsXgP~P_$NO+;>`b<) zE}2+cGKi0b!8D3o&1z)HbHjIo# zwQxk%9C^|0jGKFRh{WF{+&dDlKkV91_t6fBGqvs7-f~M1@yC`sOrTi%(-MGv%O4LC z=?;?qNa!9F8svH2)_FOlBmvJ< z#c>B;k3#LUd==F=^*z0Gj>)NHh?;NO#s~h)XU{)}VJom6Hwtg1Uk3d>*&gzotnT!T zGbWL=;q|ewuxUt1Dz7Lc5?q+b#AgvOl-2LL+dOt@*TVDOd^BTH!e*haYTg$RQAT#^KEMSea1^lh!_B$q^;=Q%so)T;S^gX zIm}zj#(&WlQ(6f-&GLwQ+3qcW`9IZ$_?2``;%OR)vZ!0qXUBiXVTjS6KKLFa43FPG zf;^#aEF7#IJ2+ud0?b)DKd{KBm+O5*Km%_OMvEWV;L~MbI>i0@E*5qi2mtDK+>kD4 ziD}&nZAEl1Qa8{*P6w#enW5#NETp9g!DVrqsNkVD)3qDu(vJ9fIc&-lZt?kJ9Q435 zZw;bVow56Q*KnnAFT}dW0ogI7EIS9Q3kM`h0X=SRw}eI&Ki~!%NU0@dtpY#G#H50f zPF@ID%t-KC`O9zn^X;F4^>?$VfW9wy_BFi)f0y_Q3q;&S0e%&d=fHe9l$ z`A+_>)&Wp5D{-|n+*Sv&88%o@2idqec8g#!8n&OfF!nwu!enMHq$CaYl;yV2ETORL zLgTU}%w@fqUKuNxO0B!7`AWB!5f?faPWPD4EKyL)vWR96vEXf}_ZZH{c5rG;*_IBi znYtkDx$aGS@@%3>QQ8km`zR*NI6=N=@)_hfooh~C-AsKyhfJ!_ctZ)>^o3>dNGa|f zOBaj55d9Yryq!6xhQCm(Q*UQ8RwG?=vA66QAH0=8U%d&V9az$`(_nQgr$L9$Vr~A_ zmosLj3Q*HpAsN?F`F5#Ia9XD3^yWpp2L8k_mdxk_xqW$hAhjt6es^{O&U4ag89hZi zI&?IG-Q~halUFb2Gd**-opfq_Pn~QwwV$D&fmj+2w`eVRsEe>D>TR3XncLW)!S<)U zBTQZ%-HhK^J!yMI$yTH(h%jqr^98L0_mQpiHAcCoRcl%T9_4FG0ca=lkiFI-MQ!hE zD0_TJP#{nr21+cfZDChRJGm;bw}dSSO>y8l%(Cf@1OCA~_&z z2MdHMmR-YBCsws5e;i_P~O|JM!JnsTjU8?uNMxnP&?SA8J>zoztV;Hj&hMO zm^!RwY3xv}8IEj^+pkLO(G-nYvs+NN_UYQm+4kUVQ)pR3(eltEz4(Pbfcc+vV`h_~lL3%Ti5qzr)VkN~!A zE%-ryP}*e6r~~zarIktEXDr`-4^V~Nt$0O zEK?c0=1!87O?(MvXAQ*w_EPXeISV`v?BzuD9qbsKD+y4j;^O4WpQUW$2Rp^%sTm1S zl(39j-iHMD{17Fmh>}MJ^Vn6l=D#?}D4yz(Jl8(SFN}D6t@ozrRR4&=pB6DoM$&)U z$4j_X_KCD>+*-T~aL^s))1_;HKP24?c{F%7Vmd?VhTdGGMzhjYr-_kOT%6(9J~%8S z?}?Mu<$xM|nN0wZ{KG#1gFDv{AqvN%=YG*IzuWQufBQ^y(9hkV_@r>xmY&2H*JTlWW zNMf0CB~w^TK|7)CM`gpDrcB&1Z0mbry?#!e(C-_`mS65yCYB=iL+>iIETfJQzWFf1 zZEn-S$Cqd^Gp)6NHHtYJg&OddT$6!*fHUQ&Om~_NQgeV?jBgb>FJYUC@~}}q!6Klj z=}hHJsy;-_NqC)TPiIt8AL@1hQVLUgbluaU@xXgd9+_V&`>A{!A=~~d#pSK!T6c+b znvUPOA7lP-1NnI?BOrAr8mk~=T?{L19gI1lIublMW$va!ngcie*zFZ-z0Ng0`zQ%w18j2DYn)K4^lwt0ad~Dh(%^(AHFjO&?zFA&4{zDHRtaajw~EHT9=0*z z*`2?0Rk*Hc1SSq)CkM5^)#ZCLb|E;D+;`X?N32kI@v*7ZG*pnt%jE#IL}z2~MJ41N zLFUD;%TkJnoqL_uBWt>iqw`Y>2>kAzxR3g!tHJM-9A@}B$WPl2tJ@Y#SQ6D_ z;5VnwxUa=E+Q~XI76nKss+L-v&eaUV7FUK}CulIEoU(I!>29V^I+ZB6x9T|>k8OkX zzW{=cESaizpmT?-;;gpgy3%_DYSo_+lx)@#nPgj@j1*FIE_DRGl#k*M7X=5_Z#VD) zr|lCi3SFE*+6gTy64va|`qwy{W|k$7;c*bsbKQ>#Pbqi>F_vgEX5ygoEk{2B>K#)Q zl9v&!vhy<0@6e-Zk(k7H`nKHYNb+=jpiQ`MTr%`9*_&`SC_9}Tu0ux^pf{*R1rmOt zJ_`Z{=!9fg!}*4_TX!GjsiNEpM&i9N=5ui_fY_ru zyXA%`WbqRUbV8*3ds|q)=9<6pf~5^S#M!2i3&&MVC#hn`;*M@OwDn4cg=)HLNzhPT z*VCS?i~O6YbTuX+?I1#??eoeCI2WZk(J=WJQ?EX8E7ie;7Q@3$);CJH%5t6j^x%bV zO7#I$l$x*c)Dl%3wS-f)=R}3eEX|ZtXLzE(gDO!Yej0WWWeCX85oR!i46C|Me#5qv z)tj=jSH}}&pdlM*rERzcNX_ccY3R$zUFP4mpoK&*_wlLfV;ZVt4M)f=cBcK9Wax9&Ho+W=ld3NVDWX}}a+u0m7$@U^qPn_1k{yIx zn(2-6<3}5)`0(K=n}=zS9G)~QL9T?Z?t21u6@n;jh%=g9`8hwfTozn6Fxid~j5^h{ z4^;qPUK{s{0dDrR5pMZ^q_gttWhEK1q>WbJVjb4^ndDBS*?)C!ydHubtyA2#y9mI_sbs7C~DT< z&T*iAs}p0rp)LVap4)%u_8WNGH3jbKg_c`oO_in4JU&Qbdv33+GUMC{ck*O_`i^6N z>DLbL4%e#JB^!Aa;k9wFrlsystwDKL(eZv&*nTh@)#bmXBAtE|%*T4GIj)a<-&tFu ziQ8ZZb-2v(oHkzUH(ie#qs$mS3A}6)GY?HAOcuKnqE6tm3f8rco{ZZ%O;beZCuB8xCzfx!YJYA2L zNbf1G9^%u%9jDFh8C{}WXqZm2|2deKI^ztOuYc~hOd<}6F~JH911oLC&f%!dei0*a zoPe7deQ))kjkslh)|b)-u0~l-awT8u!|Xuu1S_|)7+qpov#6s#{{i-5If?o2qyPq1 zmj6NuQ1-Al!Kafmv{Z7ofuxhgXQ2O;_J~?IIyvLBv$OsuF#w;5gZ+Q3^10HovBP3R z{Jz$!!@IHnmwZFVuh1KIK%7GAU{oT3c^GJDhpl5mm2}A3rRO&TUB=>8)I?3jvkMDK z9WDiH#y$fbD&$F0RUu4*!@GWOWX@GcLdHY^7wrdc+!a9Jx}nE7dxrLG zR7n!afQ>bvvOw-8>Lx&1h*O>Yb?8z+!ovEL1Xl*S3zWuq4U_=;_lKCuUnj9R|BtX0 zC7fcmCVbL<+24c!5M{%n#5$Bl1xRY1?54+A#GU28WkMu|+XzNcX463!L82-aMY%Na zi?r}CyH0VM5U>HbL{SEq_?G4&49cYH4Zkw&D0@Pn^cppCILonf7f+S)uBw)}Qv>+02t3NWUB8+Aj zKn4{MstOP&QK3unEj>6Wv;l|9s9m>i7a7b;!R)MvJ263%n5E6Jp z{t?;F3S$@Sd|Y>Qy&uNR$f(@t=}sqmJ>4yZlJNb|w|$z_bn|88uspa0Bp-jgJA4)T z-pcL^bnaB>v6f7nXTkas)6?NxlJ|o0tBn`wgMKKFE{%kIFLLzx6d#n3eZZ;q$q>eoac(RV)A>E8n(|ahpPC@ zduym(F(=UBM9pM$y#p3+YSW_0XNM+?P@AefESUE7C1+%_m?hkOt)+zfOiH9OQMymf zxkuM^x~E2OIRTa-Z&=Xs#JRcXnQV?aDl6IRSu@_6@|P51h_p<3`RsUY(R8jnbxsKo zs-CiPf~3cZ&2Ed9>{?`GcK%w=8Wb*}wr_A4k8DWBQ2WS~?7r%`a@(z7&s=P9WXtht z;RjZERyc4mBc~6lVqz_dZwH|5KaJ|&*%d4dN5Vh1ER32y$s?<;ob^>8JMn0J@rEHxs3`CR?yY4(MD0BG0AW?ZOyzL-j(u@9Y`>xw`+_ z?!ez49WeWZ2;~tlQwBT{B~-*Hlh-T}1w0|;M5K(2kc~DjhJXx{#Lc)^c+0bHc7GQH>HiE}RIG@)SQWE)zXzQcU65#9~g@<|CsqO_QX7 zLGTBbR!K^6+h}eyX+6FmFyG{`wvb-ciCSM02bqq2qAt+cSyoB<4x1~L)X5aK4VO5| zkcfmrgEl3eF}%JnZIx1ivawoQH66nY3iT=asjce(C7Mtpge;BrO;I4n92$rQgTC36 z+ABe@Y?|bQ^sjqK{O5)U?1me;MPt5JMi1{#5u64V%e(NEScT%laz&J>oR-Z%#<>2f z=W1&e86OmPyltuy-+ddu-u&ri_x_X=0*7IIYN^s!`uJ@F1vwF*x z6x@~hVqYT*++q7`N0}j?KLpiI%Db z^FZm!rs4c$hR})c2*LG>Da7*a5*vXhsc36TN?AutQ3#1{MT`#AUT5Ey@cju%ngcS{H!vRQ6G6xMH#%0Bl zsN;x;Bq)-da>;&iW*+#?K~t3|%rvSns7x8pPEUP2wh&1WTRzX5y9%*02NT9sj<60@<~^$Xy_5AU;hqLOwpXjlIuE18 zwL0g*c|;ybvT+m`g{Lx*g`Siej8}QyhEgVnNG6nLx(Jz-g>CcE^B*81RCI5yhe_ps zI+3x$1R;f#1TV?Pv6-0Ea)+~1j1gSQlaz!w4Y4Lj zHi|E0)QdP%Zs|o@7SBdS*s}jVMAVRnO`IR#;Mhn0;-h8KG`d*4!c~q~cJ3ZVGr4cY zgCa~x&ED0!ejZBA!W9@)Q9SAINIlGq52^t%hBS8h`F=N0d+Xp>LSlQiSMOn~=r(WZ zrYcHtHM;A*xP3ONoUmZ(){HSWWr{hlZ}`R(X-=c7r#O&el%@RVe|R1GvC{$bp@{Pt zbQJ?qbs(>0r4m1Q@Lm>9wL_sL2SG5>NQlRkMa7%5P%q34C9i2dh+Yr1 z7n4q)0s}~6WUe}W6(e543wUB^JQ!iJ-Ygi1PuQr&Uxq;0bY5|pBNpBc9~@cb(0XS^ z&=#E>Zx;^4e%x;_zp*H08E|swC=apZ|E)fpUR-{Wv&CwrtS`-1ogc z9GE(O|B30lS|Sd4zm_=nuE&-mEBQz{StthjI52U#L&6bwK4U0we#iIZ4*QBx*hP z2^K$e2vw`)o6aWF_2~nK+~bVk+=2hPkU=I^1JRcvq-!GlOi9oTSZW8FOLezUKWOI% z(}#C{V&9O`dj}Hz+$`b*N!LD{n1)cV)%&Feb#nxAs;jHxZGIdv<^jm|F^tzEpH ziD8C?4EuSpWWAQ@lgfB>PJr;BR8Cr;BR%h2Gu4tBjh5pn`bk3*^1h>E6rvOP_IXl} zgNIko0Imw`3ZVtv z{C*XbhrGz4(L-w`-HO9^aIT+nOFOFA}&X#Kc~9=yi8}2%lrLw=?;v@}+H*G3BkXRTP^&qaI$!Z(`oeXKrjpOg=k^nYf>&SlNG+V|Ne21lZbs3& z#N4~{=W=8qw9p;>_GAf_uJe^OyrZg*9dy6sDFQo)Ep(UlRW?-c`Vw`|h1~hre=TH; zc9;uvOf2-HMsGga?bFqKLaDAD?QBWhSaJ01l4acA8$9tw;XBcu)e!y!PVILs3@2() z*5LMPfo-J5H%OFBE`)i$`PX*S>a%!uG*}?&+6?dPFlfuTR@w^kz!j##6*7ek98OLb zmjT)U3sS+G2)VP{0N8upbofNWXC0CK?drTu$=TcUad%E>{Yh39%!&21?2JzfH@!_z zhJwp--l&3f_Zt;sL+Q|ZCbp@If7^8u9Atcb7)o<3LT?uhZ@8p~IKvNp<^s-%n^h|M zPg^!2Ki^>HRI$=*O?=n!O2u8HZFi>Z2%3HU!@Ku(B!Q6hdTWwM7 zuN*TRxZ?K|NYAS)dm3GGp^^yh<3OtqK*LHx!%+$7 z&!eH)-B*LFUgr*>ZsWcQbVtMuj`GL+LAvu=Ts7p;jla*0@lpb^J z4J;Ydo~hg37j+YvZk0!7W0AX-cu(Ni2Zo7Wd$&tz-j2@|b$80xQ&CM@CKQgJTks6y5Td=zy_@x&Gzuss10R|Vk*$w=e=ZAw_d$LwxO7af;*(vBXXjh+) z2$uT?YxDfu*Lz7qgUAzY4<^lm%b%})TAz&1EWf8jKkNH%Fa%HW!SfgJ3bgHqi&eI} z@GJGWleleynrCb##f92%cqRLgR_mmWTSo+v0t7&nqTYqay-scssE0` zS3_YLj=s)3wm(ICZaSLLzC>$NBPdQB-XYlt-oVE?NUR%)B=G zZ9430RvV~01O$G!hi=7{rsr+_HyZ7++<-F>uVoq-Xf{Q+dW#3Qt$Vi{S1;%%MLXi7 zG|URLl%HTqtAT_J7pj|n0OBilCjR^6pOJ;(zfArGT%67A9LXu@lr5aCO@2R>TnsHu zjGTYBgnlhMoPUo=8z`Hozgd>Y=wV4LGa0iIT`60m>C!uI2eE5n3!nj zS;*+=$$sNx?2P|!Aa?OR*4Bmwwzj{gAvuGh))S9Yfc6b%q$8}B`{Y7AcqD&PQC|12~R$&0VtWkp+P}ZIY%Y0 z>Rx4W6_hv%$Nk1p_%A8;-(f&J5YPz#fsV+qcwJY5vydwzdMLcLbXk)#mA)L&S}M2A z(OHP^^1P%H=Ec|fr+3qLw^fd194l=ii=xIhESJXTYGJ1*-x{ww7RyoaP}^^ z9KF&E!SPkzx6o2gFoRDxT*p9MfMCmeXI}8Nkv2;W^8O@g+hZyeX&e1Ghzg)0Z1nsT zrz8>s(6K@xPQk7>^1lLP^}|(5jVaNv4q7N3ybN1O0#3Hkt>N#ndsUZN+HG94E7_ey z1Gh)`Ptyl&yrG$di{rgZtqzXHlK#-k{lkNsVv83Ut)7$;WqMOf5yo+8Q>(0rUPoNb zI&8~Uvc;{3Y8m_D;TH<`M`RA==rRdb$^@8+wkDD_(^Tl4Dfvo9FSaCxk3@6BZvL5D z$^v88Bmu_u`LglD-|9pa(JCqB*)7%SWH|vJ*q2?X;%uvl9{t;Cn2~8H(w#hDK<2X*K<(sT2j7sV`%c!EtCA~rRpObduqPuq$kOyYh75i1On9-$Q=;kv6e4`%Sd0^sN6&dG$ZY6gY`vvWWu7!8cWS*6=7pfC__v z;P$wuVCi)hC^ljs4nPXpZF5ChExdmntQ>XF513La_Y;sr3epE?sMZEBcA7$yURP zFr`*$YoRK};OaUA*plfC5jwyh^_zNuTHN0)f?)?Geh*um^F0UTRC7(Wy3v zZ~=YPl{fpI0}FP470FJM0=N&lQ_o*FVhBV?6 zVSNMpX?|t6GEDqN5Bw{IA4&%&o9~kALNArYrCOE+?-j#T2*Q-9*x^_8T1OSsY0&+c zh3pWXiQHdb1?BhBhy_bkcM3*9oa~z9b;jhJo2DNsB>4i%f*KjXk`gT&^WZWB26;ho z74op2TiIPoDt83X0_XwsAO;YG@ZtWLHL?$xfiGC+Hvr^;;TsPsRcxov-%*RP8!;un z?1v?kvht7pfW?0w6Dx`Z*LEXC!<&45DVQ(HiAAK`PoK%@kIYI5= 0.8 (ASig as A1, B as B1; ASig as A2, ...)|. This statement includes the +package \texttt{foo} twice, once with \texttt{ASig} instantiated with +\texttt{A1} and \texttt{B} renamed as \texttt{B1}, and once with +\texttt{ASig} instantiated with \texttt{A2}, and all other modules +imported with their original names. Assuming that the key of the first +instance of \texttt{foo} is \texttt{foo\_KEY1} and the key of the second instance +is \texttt{foo\_KEY2}, and that \texttt{ASig} is an \texttt{exposed-signature}, then this \texttt{build-depends} would turn into +these flags for GHC\@: \verb|-package-key "foo\_KEY1 (ASig as A1, B as B1)" -package-key "foo\_KEY2" -package-key "foo\_KEY2 (ASig as A2)"| + +Syntactically, the thinnings and renamings are placed inside a +parenthetical after the package name and version constraints. +Semicolons distinguish separate inclusions of the package, and the inner +comma-separated lists indicate the thinning/renamings of the module. +You can also write \verb|...|, which simply +includes all of the default bindings from the package. +\Red{This is not implemented. Should this only refer to modules which were not referred to already? Should it refer only to holes?} + +There are two remarks that should be made about separate instantiations of +the package. First, Cabal will automatically ``de-duplicate'' instances of +the package which are equivalent: thus, \verb|foo (A; B)| is equivalent to +\texttt{foo (A, B)} when \texttt{foo} is a definite package, or when the +holes instantiation for each instance is equivalent. Second, when merging +two \texttt{build-depends} statements together (for example, due to +a conditional section in a Cabal file), they are considered \emph{separate +inclusions of a package.} + +\subsection{Setup flags} + +There is one new flag for the \texttt{Setup} script, which can be +used to manually provide instantiations for holes in a package: +\verb|--instantiate-with NAME=PKG:MOD|, which binds a module \verb|NAME| +to the implementation \verb|MOD| provided by installed package ID \verb|PKG|. +The flag can be specified multiply times to provide bindings for all +signatures. The module in question must be the \emph{original} module, +not a re-export. + + + +\subsection{Metadata in the installed package database} + +Cabal records + +\texttt{instantiated-with} + +\section{cabal-install} + +\subsection{Indefinite package instantiation} + +\end{document} diff --git a/docs/backpack/commands-new-new.tex b/docs/backpack/commands-new-new.tex new file mode 100644 index 00000000..1f2466e1 --- /dev/null +++ b/docs/backpack/commands-new-new.tex @@ -0,0 +1,891 @@ +%!TEX root = paper/paper.tex +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{amsthm} +\usepackage{xspace} +\usepackage{color} +\usepackage{xifthen} +\usepackage{graphicx} +\usepackage{amsbsy} +\usepackage{mathtools} +\usepackage{stmaryrd} +\usepackage{url} +\usepackage{alltt} +\usepackage{varwidth} +% \usepackage{hyperref} +\usepackage{datetime} +\usepackage{subfig} +\usepackage{array} +\usepackage{multirow} +\usepackage{xargs} +\usepackage{marvosym} % for MVAt +\usepackage{bm} % for blackboard bold semicolon + + +%% HYPERREF COLORS +\definecolor{darkred}{rgb}{.7,0,0} +\definecolor{darkgreen}{rgb}{0,.5,0} +\definecolor{darkblue}{rgb}{0,0,.5} +% \hypersetup{ +% linktoc=page, +% colorlinks=true, +% linkcolor=darkred, +% citecolor=darkgreen, +% urlcolor=darkblue, +% } + +% Coloring +\definecolor{hilite}{rgb}{0.7,0,0} +\newcommand{\hilite}[1]{\color{hilite}#1\color{black}} +\definecolor{shade}{rgb}{0.85,0.85,0.85} +\newcommand{\shade}[1]{\colorbox{shade}{\!\ensuremath{#1}\!}} + +% Misc +\newcommand\evalto{\hookrightarrow} +\newcommand\elabto{\rightsquigarrow} +\newcommand\elabtox[1]{\stackrel{#1}\rightsquigarrow} +\newcommand{\yields}{\uparrow} +\newcommand\too{\Rightarrow} +\newcommand{\nil}{\cdot} +\newcommand{\eps}{\epsilon} +\newcommand{\Ups}{\Upsilon} +\newcommand{\avoids}{\mathrel{\#}} + +\renewcommand{\vec}[1]{\overline{#1}} +\newcommand{\rname}[1]{\textsc{#1}} +\newcommand{\infrule}[3][]{% + \vspace{0.5ex} + \frac{\begin{array}{@{}c@{}}#2\end{array}}% + {\mbox{\ensuremath{#3}}}% + \ifthenelse{\isempty{#1}}% + {}% + % {\hspace{1ex}\rlap{(\rname{#1})}}% + {\hspace{1ex}(\rname{#1})}% + \vspace{0.5ex} +} +\newcommand{\infax}[2][]{\infrule[#1]{}{#2}} +\newcommand{\andalso}{\hspace{.5cm}} +\newcommand{\suchthat}{~\mathrm{s.t.}~} +\newenvironment{notes}% + {\vspace{-1.5em}\begin{itemize}\setlength\itemsep{0pt}\small}% + {\end{itemize}} +\newcommand{\macrodef}{\mathbin{\overset{\mathrm{def}}{=}}} +\newcommand{\macroiff}{\mathbin{\overset{\mathrm{def}}{\Leftrightarrow}}} + + +\newcommand{\ttt}[1]{\text{\tt #1}} +\newcommand{\ttul}{\texttt{\char 95}} +\newcommand{\ttcc}{\texttt{:\!:}} +\newcommand{\ttlb}{{\tt {\char '173}}} +\newcommand{\ttrb}{{\tt {\char '175}}} +\newcommand{\tsf}[1]{\textsf{#1}} + +% \newcommand{\secref}[1]{\S\ref{sec:#1}} +% \newcommand{\figref}[1]{Figure~\ref{fig:#1}} +\newcommand{\marginnote}[1]{\marginpar[$\ast$ {\small #1} $\ast$]% + {$\ast$ {\small #1} $\ast$}} +\newcommand{\hschange}{\marginnote{!Haskell}} +\newcommand{\TODO}{\emph{TODO}\marginnote{TODO}} +\newcommand{\parheader}[1]{\textbf{#1}\quad} + +\newcommand{\file}{\ensuremath{\mathit{file}}} +\newcommand{\mapnil}{~\mathord{\not\mapsto}} + +\newcommand{\Ckey}[1]{\textbf{\textsf{#1}}} +\newcommand{\Cent}[1]{\texttt{#1}} +% \newcommand{\Cmod}[1]{\texttt{[#1]}} +% \newcommand{\Csig}[1]{\texttt{[\ttcc{}#1]}} +\newcommand{\Cmod}[1]{=\texttt{[#1]}} +\newcommand{\Csig}[1]{~\ttcc{}~\texttt{[#1]}} +\newcommand{\Cpath}[1]{\ensuremath{\mathsf{#1}}} +\newcommand{\Cvar}[1]{\ensuremath{\mathsf{#1}}} +\newcommand{\Ccb}[1]{\text{\ttlb} {#1} \text{\ttrb}} +\newcommand{\Cpkg}[1]{\texttt{#1}} +\newcommand{\Cmv}[1]{\ensuremath{\langle #1 \rangle}} +\newcommand{\Cto}[2]{#1 \mapsto #2} +\newcommand{\Ctoo}[2]{\Cpath{#1} \mapsto \Cpath{#2}} +\newcommand{\Crm}[1]{#1 \mapnil} +\newcommand{\Crmm}[1]{\Cpath{#1} \mapnil} +\newcommand{\Cthin}[1]{\ensuremath{\langle \Ckey{only}~#1 \rangle}} +\newcommand{\Cthinn}[1]{\ensuremath{\langle \Ckey{only}~\Cpath{#1} \rangle}} +\newcommand{\Cinc}[1]{\Ckey{include}~{#1}} +\newcommand{\Cincc}[1]{\Ckey{include}~\Cpkg{#1}} +\newcommand{\Cshar}[2]{~\Ckey{where}~{#1} \equiv {#2}} +\newcommand{\Csharr}[2]{~\Ckey{where}~\Cpath{#1} \equiv \Cpath{#2}} +\newcommand{\Ctshar}[2]{~\Ckey{where}~{#1} \equiv {#2}} +\newcommand{\Ctsharr}[3]{~\Ckey{where}~\Cpath{#1}.\Cent{#3} \equiv \Cpath{#2}.\Cent{#3}} +\newcommand{\Cbinds}[1]{\left\{\!\begin{array}{l} #1 \end{array}\!\right\}} +\newcommand{\Cbindsp}[1]{\left(\!\begin{array}{l} #1 \end{array}\!\right)} +\newcommand{\Cpkgs}[1]{\[\begin{array}{l} #1\end{array}\]} +\newcommand{\Cpkgsl}[1]{\noindent\ensuremath{\begin{array}{@{}l} #1\end{array}}} +\newcommand{\Ccomment}[1]{\ttt{\emph{--~#1}}} +\newcommand{\Cimp}[1]{\Ckey{import}~\Cpkg{#1}} +\newcommand{\Cimpas}[2]{\Ckey{import}~\Cpkg{#1}~\Ckey{as}~\Cvar{#2}} + +\newcommand{\Ctbinds}[1]{\left\{\!\vrule width 0.6pt \begin{array}{l} #1 \end{array} \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsx}{\left\{\!\vrule width 0.6pt \; \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsxx}{\left\{\!\vrule width 0.6pt \begin{array}{l}\!\!\!\!\\\!\!\!\!\end{array} \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsxxx}{\left\{\!\vrule width 0.6pt \begin{array}{l}\!\!\!\!\\\!\!\!\!\\\!\!\!\!\end{array} \vrule width 0.6pt \!\right\}} + + +\newcommand{\Cpkgdef}[2]{% + \ensuremath{ + \begin{array}{l} + \Ckey{package}~\Cpkg{#1}~\Ckey{where}\\ + \hspace{1em}\begin{array}{l} + #2 + \end{array} + \end{array}}} +\newcommand{\Cpkgdefonly}[3]{% + \ensuremath{ + \begin{array}{l} + \Ckey{package}~\Cpkg{#1}\Cvar{(#2)}~\Ckey{where}\\ + \hspace{1em}\begin{array}{l} + #3 + \end{array} + \end{array}}} +\newcommand{\Ccc}{\mathbin{\ttcc{}}} +\newcommand{\Cbinmod}[2]{\Cvar{#1} = \texttt{[#2]}} +\newcommand{\Cbinsig}[2]{\Cvar{#1} \Ccc \texttt{[#2]}} +\newcommand{\Cinconly}[2]{\Ckey{include}~\Cpkg{#1}\Cvar{(#2)}} +\newcommand{\Cimponly}[2]{\Ckey{import}~\Cpkg{#1}\Cvar{(#2)}} +\newcommand{\Cimpmv}[3]{\Ckey{import}~\Cpkg{#1}\langle\Cvar{#2}\mapsto\Cvar{#3}\rangle} + + + + + +\newcommand{\oxb}[1]{\llbracket #1 \rrbracket} +\newcommand{\coxb}[1]{\{\hspace{-.5ex}| #1 |\hspace{-.5ex}\}} +\newcommand{\coxbv}[1]{\coxb{\vec{#1}}} +\newcommand{\angb}[1]{\ensuremath{\boldsymbol\langle #1 \boldsymbol\rangle}\xspace} +\newcommand{\angbv}[1]{\angb{\vec{#1}}} +\newcommand{\aoxbl}{\ensuremath{\boldsymbol\langle\hspace{-.5ex}|}} +\newcommand{\aoxbr}{\ensuremath{|\hspace{-.5ex}\boldsymbol\rangle}\xspace} +\newcommand{\aoxb}[1]{\ensuremath{\aoxbl{#1}\aoxbr}} +\newcommand{\aoxbv}[1]{\aoxb{\vec{#1}}} +\newcommand{\poxb}[1]{\ensuremath{% + (\hspace{-.5ex}|% + #1% + |\hspace{-.5ex})}\xspace} +\newcommand{\stof}[1]{{#1}^{\star}} +% \newcommand{\stof}[1]{\ensuremath{\underline{#1}}} +\newcommand{\sh}[1]{\ensuremath{\tilde{#1}}} + + +% \newenvironment{code}[1][t]% +% {\ignorespaces\begin{varwidth}[#1]{\textwidth}\begin{alltt}}% +% {\end{alltt}\end{varwidth}\ignorespacesafterend} +% \newenvironment{codel}[1][t]% +% {\noindent\begin{varwidth}[#1]{\textwidth}\noindent\begin{alltt}}% +% {\end{alltt}\end{varwidth}\ignorespacesafterend} + + +%% hack for subfloats in subfig ------------- +\makeatletter +\newbox\sf@box +\newenvironment{SubFloat}[2][]% + {\def\sf@one{#1}% + \def\sf@two{#2}% + \setbox\sf@box\hbox + \bgroup}% + {\egroup + \ifx\@empty\sf@two\@empty\relax + \def\sf@two{\@empty} + \fi + \ifx\@empty\sf@one\@empty\relax + \subfloat[\sf@two]{\box\sf@box}% + \else + \subfloat[\sf@one][\sf@two]{\box\sf@box}% + \fi} +\makeatother +%% ------------------------------------------ + +%% hack for top-aligned tabular cells ------------- +\newsavebox\topalignbox +\newcolumntype{L}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + l + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +\newcolumntype{C}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + c + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +\newcolumntype{R}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + r + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +%% ------------------------------------------------ + +\newcommand\syn[1]{\textsf{#1}} +\newcommand\bsyn[1]{\textsf{\bfseries #1}} +\newcommand\msyn[1]{\textsf{#1}} +\newcommand{\cc}{\mathop{::}} + +% \newcommand{\Eimp}[1]{\bsyn{import}~{#1}} +% \newcommand{\Eonly}[2]{#1~\bsyn{only}~{#2}} +% \newcommand{\Ehide}[1]{~\bsyn{hide}~{#1}} +% \newcommand{\Enew}[1]{\bsyn{new}~{#1}} +% \newcommand{\Elocal}[2]{\bsyn{local}~{#1}~\bsyn{in}~{#2}} +% \newcommand{\Smv}[3]{\Emv[]{#1}{#2}{#3}} +\newcommand{\Srm}[2]{#1 \mathord{\setminus} #2} + +\newcommand{\cpath}{\varrho} +\newcommand{\fpath}{\rho} + +\newcommand{\ie}{\emph{i.e.},\xspace} +\newcommand{\eg}{\emph{e.g.},~} +\newcommand{\etal}{\emph{et al.}} + +\renewcommand{\P}[1]{\Cpkg{#1}} +\newcommand{\X}[1]{\Cvar{#1}} +\newcommand{\E}{\mathcal{E}} +\newcommand{\C}{\mathcal{C}} +\newcommand{\M}{\mathcal{M}} +\newcommand{\B}{\mathcal{B}} +\newcommand{\R}{\mathcal{R}} +\newcommand{\K}{\mathcal{K}} +\renewcommand{\L}{\mathcal{L}} +\newcommand{\D}{\mathcal{D}} + +%%%% NEW + +\newdateformat{numericdate}{% +\THEYEAR.\twodigit{\THEMONTH}.\twodigit{\THEDAY} +} + +% EL DEFNS +\newcommand{\shal}[1]{\syn{shallow}(#1)} +\newcommand{\exports}[1]{\syn{exports}(#1)} +\newcommand{\Slocals}[1]{\syn{locals}(#1)} +\newcommand{\Slocalsi}[2]{\syn{locals}(#1; #2)} +\newcommand{\specs}[1]{\syn{specs}(#1)} +\newcommand{\ELmkespc}[2]{\syn{mkespc}(#1;#2)} +\newcommand{\Smkeenv}[1]{\syn{mkeenv}(#1)} +\newcommand{\Smklocaleenv}[2]{\syn{mklocaleenv}(#1;#2)} +\newcommand{\Smklocaleenvespcs}[1]{\syn{mklocaleenv}(#1)} +\newcommand{\Smkphnms}[1]{\syn{mkphnms}(#1)} +\newcommand{\Smkphnm}[1]{\syn{mkphnm}(#1)} +\newcommand{\Sfilterespc}[2]{\syn{filterespc}(#1;#2)} +\newcommand{\Sfilterespcs}[2]{\syn{filterespcs}(#1;#2)} +\newcommand{\Simps}[1]{\syn{imps}(#1)} + + + +% IL DEFNS +\newcommand{\dexp}{\mathit{dexp}} +\newcommand{\fexp}{\mathit{fexp}} +\newcommand{\tfexp}{\mathit{tfexp}} +\newcommand{\pexp}{\mathit{pexp}} +\newcommand{\dtyp}{\mathit{dtyp}} +\newcommand{\ftyp}{\mathit{ftyp}} +\newcommand{\hsmod}{\mathit{hsmod}} +\newcommand{\fenv}{\mathit{fenv}} +\newcommand{\ILmkmod}[6]{\syn{mkmod}(#1; #2; #3; #4; #5; #6)} +\newcommand{\ILmkstubs}[3]{\syn{mkstubs}(#1; #2; #3)} +\newcommand{\Smkstubs}[1]{\syn{mkstubs}(#1)} +\newcommand{\ILentnames}[1]{\syn{entnames}(#1)} +\newcommand{\ILmkfenv}[1]{\syn{mkfenv}(#1)} +\newcommand{\ILmkdtyp}[1]{\syn{mkdtyp}(#1)} +\newcommand{\ILmkknd}[1]{\syn{mkknd}(#1)} +\newcommand{\ILmkimpdecl}[2]{\syn{mkimpdecl}(#1;#2)} +\newcommand{\ILmkimpdecls}[2]{\syn{mkimpdecls}(#1;#2)} +\newcommand{\ILmkimpspec}[3]{\syn{mkimpspec}(#1;#2;#3)} +\newcommand{\ILmkentimp}[3]{\syn{mkentimp}(#1;#2;#3)} +\newcommand{\ILmkentimpp}[1]{\syn{mkentimp}(#1)} +\newcommand{\ILmkexp}[2]{\syn{mkexp}(#1;#2)} +\newcommand{\ILmkexpdecl}[2]{\syn{mkexpdecl}(#1;#2)} +\newcommand{\ILmkespc}[2]{\syn{mkespc}(#1;#2)} +\newcommand{\ILshal}[1]{\syn{shallow}(#1)} +\newcommand{\ILexports}[1]{\syn{exports}(#1)} +\newcommand{\ILdefns}[1]{\syn{defns}(#1)} +\newcommand{\ILdefnsi}[2]{\syn{defns}(#1;#2)} + +% CORE DEFNS +\newcommand{\Hentref}{\mathit{eref}} +\newcommand{\Hentimp}{\mathit{import}} +\newcommand{\Hentexp}{\mathit{export}} +\newcommand{\Himp}{\mathit{impdecl}} +\newcommand{\Himpspec}{\mathit{impspec}} +\newcommand{\Himps}{\mathit{impdecls}} +\newcommand{\Hexps}{\mathit{expdecl}} +\newcommand{\Hdef}{\mathit{def}} +\newcommand{\Hdefs}{\mathit{defs}} +\newcommand{\Hdecl}{\mathit{decl}} +\newcommand{\Hdecls}{\mathit{decls}} +\newcommand{\Heenv}{\mathit{eenv}} +\newcommand{\Haenv}{\mathit{aenv}} +% \newcommand{\HIL}[1]{{\scriptstyle\downarrow}#1} +\newcommand{\HIL}[1]{\check{#1}} + +\newcommand{\Hcmp}{\sqsubseteq} + +\newcommand{\uexp}{\mathit{uexp}} +\newcommand{\utyp}{\mathit{utyp}} +\newcommand{\typ}{\mathit{typ}} +\newcommand{\knd}{\mathit{knd}} +\newcommand{\kndstar}{\ttt{*}} +\newcommand{\kndarr}[2]{#1\ensuremath{\mathbin{\ttt{->}}}#2} +\newcommand{\kenv}{\mathit{kenv}} +\newcommand{\phnm}{\mathit{phnm}} +\newcommand{\spc}{\mathit{dspc}} +\newcommand{\spcs}{\mathit{dspcs}} +\newcommand{\espc}{\mathit{espc}} +\newcommand{\espcs}{\mathit{espcs}} +\newcommand{\ds}{\mathit{ds}} + +\newcommand{\shctx}{\sh{\Xi}_{\syn{ctx}}} +\newcommand{\shctxsigma}{\sh{\Sigma}_{\syn{ctx}}} + +\newcommand{\vdashsh}{\Vdash} + +% \newcommand{\vdashghc}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle EL}}} +% \newcommand{\vdashghcil}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle IL}}} +% \newcommand{\vdashshghc}{\vdashsh_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle EL}}} +\newcommand{\vdashghc}{\vdash_{\!\!\mathrm{c}}} +\newcommand{\vdashghcil}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle IL}}} +\newcommand{\vdashshghc}{\vdashsh_{\!\!\mathrm{c}}} + +% CORE STUFF +\newcommandx*{\JCModImp}[5][1=\sh\B, 2=\nu_0, usedefault=@]% + {#1;#2 \vdashshghc #3;#4 \elabto #5} +\newcommandx*{\JIlCModImp}[5][1=\fenv, 2=f_0, usedefault=@]% + {#1;#2 \vdashghcil #3;#4 \elabto #5} +\newcommandx*{\JCSigImp}[5][1=\sh\B, 2=\sh\tau, usedefault=@]% + {#1;#2 \vdashshghc #3;#4 \elabto #5} + +\newcommandx*{\JCImpDecl}[3][1=\sh\B, usedefault=@]% + {#1 \vdashshghc #2 \elabto #3} +\newcommandx*{\JCImp}[4][1=\sh\B, 2=p, usedefault=@]% + {#1;#2 \vdashshghc #3 \elabto #4} +\newcommandx*{\JIlCImpDecl}[3][1=\fenv, usedefault=@]% + {#1 \vdashghcil #2 \elabto #3} +\newcommandx*{\JIlCImp}[4][1=\fenv, 2=f, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCModExp}[4][1=\nu_0, 2=\Heenv, usedefault=@]% + {#1;#2 \vdashshghc #3 \elabto #4} +\newcommandx*{\JIlCModExp}[4][1=f_0, 2=\HIL\Heenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCModDef}[5][1=\Psi, 2=\nu_0, 3=\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} +\newcommandx*{\JIlCModDef}[5][1=\fenv, 2=f_0, 3=\HIL\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} +\newcommandx*{\JCSigDecl}[5][1=\Psi, 2=\sh\tau, 3=\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} + +\newcommandx*{\JCExp}[6][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, 4=\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashshghc #5 \elabto #6} +\newcommandx*{\JIlCExp}[4][1=f_0, 2=\HIL\Heenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCRefExp}[7][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, 4=\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashshghc #5 \elabto #6:#7} +\newcommandx*{\JIlCRefExp}[7][1=\fenv, 2=f_0, 3=\HIL\Hdefs, 4=\HIL\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashghcil #5 \elabto #6:#7} + +\newcommandx*{\JCMod}[4][1=\Gamma, 2=\nu_0, usedefault=@]% + {#1; #2 \vdashghc #3 : #4} +\newcommandx*{\JIlCMod}[3][1=\fenv, usedefault=@]% + {#1 \vdashghcil #2 : #3} +\newcommandx*{\JCSig}[5][1=\Gamma, 2=\sh\tau, usedefault=@]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JCShSig}[5][1=\Gamma, 2=\sh\tau, usedefault=@]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JCModElab}[5][1=\Gamma, 2=\nu_0, usedefault=@]% + % {#1; #2 \vdashghc #3 : #4 \elabto #5} + {#1; #2 \vdashghc #3 : #4 \;\shade{\elabto #5}} + +\newcommandx*{\JCWfEenv}[2][1=\Haenv, usedefault=@]% + {#1 \vdashshghc #2~\syn{wf}} +\newcommandx*{\JCWfEenvMap}[2][1=\Haenv, usedefault=@]% + {#1 \vdashshghc #2~\syn{wf}} +\newcommandx*{\JIlCWfEenv}[2][1=\HIL\Haenv, usedefault=@]% + {#1 \vdashghcil #2~\syn{wf}} +\newcommandx*{\JIlCWfEenvMap}[2][1=\HIL\Haenv, usedefault=@]% + {#1 \vdashghcil #2~\syn{wf}} + +\newcommandx*{\JIlTfexp}[3][1=\fenv, 2=f_0, usedefault=@]% + {#1; #2 \vdash #3} + + + + % IL STUFF + +\newcommandx*{\JIlWf}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlKnd}[4][1=\fenv, 2=\kenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \mathrel{\cc} #4} +% \newcommandx*{\JIlSub}[4][1=\fenv, 2=f, usedefault=@]% +% {#1;#2 \vdash #3 \le #4} +\newcommandx*{\JIlSub}[2][usedefault=@]% + {\vdash #1 \le #2} +\newcommandx*{\JIlMerge}[3][usedefault=@]% + {\vdash #1 \oplus #2 \Rightarrow #3} + +\newcommandx*{\JIlDexp}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2} +\newcommandx*{\JIlDexpTyp}[3][1=\fenv, usedefault=@]% + {#1 \vdash #2 : #3} + +\newcommandx*{\JIlWfFenv}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfFtyp}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfSpc}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfESpc}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfSig}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfFtypSpecs}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{specs-wf}} +\newcommandx*{\JIlWfFtypExps}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{exports-wf}} +\newcommandx*{\JIlWfFenvDeps}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{deps-wf}} + +% WF TYPE STUFF IN EL +\newcommandx*{\JPkgValid}[1]% + {\vdash #1 ~\syn{pkg-valid}} +\newcommandx*{\JWfPkgCtx}[1][1=\Delta, usedefault=@]% + {\vdash #1 ~\syn{wf}} +\newcommandx*{\JWfPhCtx}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTyp}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTypPol}[3][1=\Psi, usedefault=@]% + {#1 \vdash #2^{#3} ~\syn{wf}} +\newcommandx*{\JWfLogSig}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfSpc}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfESpc}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfSig}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTypSpecs}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{specs-wf}} +\newcommandx*{\JWfModTypPolSpecs}[3][1=\Psi, usedefault=@]% + {#1 \vdash #2^{#3} ~\syn{specs-wf}} +\newcommandx*{\JWfModTypExps}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{exports-wf}} +\newcommandx*{\JWfPhCtxDeps}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{deps-wf}} +\newcommandx*{\JWfPhCtxDepsOne}[4][1=\Psi, usedefault=@]% + {#1 \vdash \styp{#2}{#3}{#4} ~\syn{deps-wf}} + +% WF SHAPE STUFF IN EL +\newcommandx*{\JWfShPhCtx}[2][1=\nil, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModSh}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModShPol}[3][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2^{#3} ~\syn{wf}} +\newcommandx*{\JWfShLogSig}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShSpc}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShESpc}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShSig}[2][1=\nil, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModShSpecs}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{specs-wf}} +\newcommandx*{\JWfModShPolSpecs}[3][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2^{#3} ~\syn{specs-wf}} +\newcommandx*{\JWfModShExps}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{exports-wf}} +\newcommandx*{\JWfEenv}[4][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, usedefault=@]% + {#1;#2;#3 \vdashshghc #4 ~\syn{wf}} + +\newcommandx*{\JCoreKnd}[4][1=\Psi, 2=\kenv, usedefault=@]% + {#1;#2 \vdashghc #3 \mathrel{\cc} #4} + +\newcommandx*{\JStampEq}[2]% + {\vdash #1 \equiv #2} +\newcommandx*{\JStampNeq}[2]% + {\vdash #1 \not\equiv #2} +\newcommandx*{\JUnif}[3]% + {\syn{unify}(#1 \doteq #2) \elabto #3} +\newcommandx*{\JUnifM}[2]% + {\syn{unify}(#1) \elabto #2} + +\newcommandx*{\JModTypWf}[1]% + {\vdash #1 ~\syn{wf}} + +\newcommandx*{\JModSub}[2]% + {\vdash #1 \le #2} +\newcommandx*{\JModSup}[2]% + {\vdash #1 \ge #2} +\newcommandx*{\JShModSub}[2]% + {\vdashsh #1 \le #2} + +\newcommandx*{\JModEq}[2]% + {\vdash #1 \equiv #2} +% \newcommandx*{\JCShModEq}[3][3=\C]% +% {\vdashsh #1 \equiv #2 \mathbin{|} #3} + +\newcommandx*{\JETyp}[4][1=\Gamma, 2=\shctxsigma, usedefault=@]% + {#1;#2 \vdash #3 : #4} +\newcommandx*{\JETypElab}[5][1=\Gamma, 2=\shctxsigma, usedefault=@]% + {\JETyp[#1][#2]{#3}{#4} \elabto #5} +\newcommandx*{\JESh}[3][1=\sh\Gamma, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3} + +\newcommandx*{\JBTyp}[5][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + {#1;#2;#3 \vdash #4 : #5} +\newcommandx*{\JBTypElab}[6][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + % {\JBTyp[#1][#2][#3]{#4}{#5} \elabto #6} + {\JBTyp[#1][#2][#3]{#4}{#5} \;\shade{\elabto #6}} +\newcommandx*{\JBSh}[4][1=\Delta, 2=\sh\Gamma, usedefault=@]% + {#1;#2 \vdashsh #3 \Rightarrow #4} + +\newcommandx*{\JBVTyp}[4][1=\Delta, 2=\shctx, usedefault=@]% + {#1;#2 \vdash #3 : #4} +\newcommandx*{\JBVTypElab}[5][1=\Delta, 2=\shctx, usedefault=@]% + % {\JBVTyp[#1][#2]{#3}{#4} \elabto #5} + {\JBVTyp[#1][#2]{#3}{#4} \;\shade{\elabto #5}} +\newcommandx*{\JBVSh}[4][1=\Delta, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3;\, #4} + +\newcommandx*{\JImp}[3][1=\Gamma, usedefault=@]% + {#1 \vdashimp #2 \elabto #3} +\newcommandx*{\JShImp}[3][1=\sh\Gamma, usedefault=@]% + {#1 \vdashshimp #2 \elabto #3} + +\newcommandx*{\JGhcMod}[4]% + {#1; #2 \vdashghc #3 : #4} +\newcommandx*{\JShGhcMod}[4]% + {#1; #2 \vdashshghc #3 : #4} + +\newcommandx*{\JGhcSig}[5]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JShGhcSig}[5]% + {#1; #2 \vdashshghc #3 \elabto #4;#5} + +\newcommandx*{\JThin}[3][1=t, usedefault=@]% + {\vdash #2 \xrightarrow{~#1~} #3} +\newcommandx*{\JShThin}[3][1=t, usedefault=@]% + {\vdashsh #2 \xrightarrow{~#1~} #3} + +\newcommandx*{\JShMatch}[3][1=\nu, usedefault=@]% + {#1 \vdash #2 \sqsubseteq #3} + +\newcommandx*{\JShTrans}[4]% + {\vdash #1 \le_{#2} #3 \elabto #4} + +\newcommandx*{\JMerge}[3]% + {\vdash #1 + #2 \Rightarrow #3} +\newcommandx*{\JShMerge}[5]% + {\vdashsh #1 + #2 \Rightarrow #3;\, #4;\, #5} +\newcommandx*{\JShMergeNew}[4]% + {\vdashsh #1 + #2 \Rightarrow #3;\, #4} +\newcommandx*{\JShMergeSimple}[3]% + {\vdashsh #1 + #2 \Rightarrow #3} + +\newcommandx*{\JDTyp}[3][1=\Delta, usedefault=@]% + {#1 \vdash #2 : #3} +\newcommandx*{\JDTypElab}[4][1=\Delta, usedefault=@]% + % {#1 \vdash #2 : #3 \elabto #4} + {#1 \vdash #2 : #3 \;\shade{\elabto #4}} + +\newcommandx*{\JTTyp}[2][1=\Delta, usedefault=@]% + {#1 \vdash #2} + +\newcommandx*{\JSound}[3][1=\Psi_\syn{ctx}, usedefault=@]% + {#1 \vdash #2 \sim #3} + +\newcommandx*{\JSoundOne}[4][1=\Psi, 2=\fenv, usedefault=@]% + {\vdash #3 \sim #4} +% \newcommand{\Smodi}[4]{\ensuremath{\oxb{=#2 \cc #3 \imps #4}^{#1}}} +\newcommand{\Smodi}[3]{\ensuremath{\oxb{=#2 \cc #3}^{#1}}} +\newcommand{\Smod}[2]{\Smodi{+}{#1}{#2}} +\newcommand{\Ssig}[2]{\Smodi{-}{#1}{#2}} +\newcommand{\Sreq}[2]{\Smodi{?}{#1}{#2}} +\newcommand{\Shole}[2]{\Smodi{\circ}{#1}{#2}} + +\newcommand{\SSmodi}[2]{\ensuremath{\oxb{=#2}^{#1}}} +\newcommand{\SSmod}[1]{\SSmodi{+}{#1}} +\newcommand{\SSsig}[1]{\SSmodi{-}{#1}} +\newcommand{\SSreq}[1]{\SSmodi{?}{#1}} +\newcommand{\SShole}[1]{\SSmodi{\circ}{#1}} + +% \newcommand{\styp}[3]{\oxb{{#1}\cc{#2}}^{#3}} +\newcommand{\styp}[3]{{#1}{:}{#2}^{#3}} +\newcommand{\stm}[2]{\styp{#1}{#2}{\scriptscriptstyle+}} +\newcommand{\sts}[2]{\styp{#1}{#2}{\scriptscriptstyle-}} + +% \newcommand{\mtypsep}{[\!]} +\newcommand{\mtypsep}{\mbox{$\bm{;}$}} +\newcommand{\mtypsepsp}{\hspace{.3em}} +\newcommand{\msh}[3]{\aoxb{#1 ~\mtypsep~ #2 ~\mtypsep~ #3}} +\newcommand{\mtyp}[3]{ + \aoxb{\mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp + #2 \mtypsepsp\mtypsep\mtypsepsp + #3 \mtypsepsp}} +\newcommand{\bigmtyp}[3]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] + #2 ~\mtypsep \\ + #3 + \end{array} \vrule\!\right\rangle +}} + + +\newcommand{\mtypm}[2]{\mtyp{#1}{#2}^{\scriptstyle+}} +\newcommand{\mtyps}[2]{\mtyp{#1}{#2}^{\scriptstyle-}} +\newcommand{\bigmtypm}[2]{\bigmtyp{#1}{#2}^{\scriptstyle+}} +\newcommand{\bigmtyps}[2]{\bigmtyp{#1}{#2}^{\scriptstyle-}} + +\newcommand{\mref}{\ensuremath{\mathit{mref}}} +\newcommand{\selfpath}{\msyn{Local}} + +% \newcommand{\Ltyp}[3]{\oxb{#1 \mathbin{\scriptstyle\MVAt} #2}^{#3}} +% \newcommand{\Ltyp}[2]{\poxb{#1 \mathbin{\scriptstyle\MVAt} #2}} +\newcommand{\Ltyp}[2]{#1 {\scriptstyle\MVAt} #2} + +\newcommand{\Sshape}[1]{\ensuremath{\syn{shape}(#1)}} +\newcommand{\Srename}[2]{\ensuremath{\syn{rename}(#1;#2)}} +\newcommand{\Scons}[2]{\ensuremath{\syn{cons}(#1;#2)}} +\newcommand{\Smkreq}[1]{\ensuremath{\syn{hide}(#1)}} +\newcommand{\Sfv}[1]{\ensuremath{\syn{fv}(#1)}} +\newcommand{\Sdom}[1]{\ensuremath{\syn{dom}(#1)}} +\newcommand{\Srng}[1]{\ensuremath{\syn{rng}(#1)}} +\newcommand{\Sdomp}[2]{\ensuremath{\syn{dom}_{#1}(#2)}} +\newcommand{\Sclos}[1]{\ensuremath{\syn{clos}(#1)}} +\newcommand{\Scloss}[2]{\ensuremath{\syn{clos}_{#1}(#2)}} +\newcommand{\Snorm}[1]{\ensuremath{\syn{norm}(#1)}} +\newcommand{\Sident}[1]{\ensuremath{\syn{ident}(#1)}} +\newcommand{\Snec}[2]{\ensuremath{\syn{nec}(#1; #2)}} +\newcommand{\Sprovs}[1]{\ensuremath{\syn{provs}(#1)}} +\newcommand{\Smkstamp}[2]{\ensuremath{\syn{mkident}(#1; #2)}} +\newcommand{\Sname}[1]{\ensuremath{\syn{name}(#1)}} +\newcommand{\Snames}[1]{\ensuremath{\syn{names}(#1)}} +\newcommand{\Sallnames}[1]{\ensuremath{\syn{allnames}(#1)}} +\newcommand{\Shassubs}[1]{\ensuremath{\syn{hasSubs}(#1)}} +\newcommand{\Snooverlap}[1]{\ensuremath{\syn{nooverlap}(#1)}} +\newcommand{\Sreduce}[2]{\ensuremath{\syn{apply}(#1; #2)}} +\newcommand{\Smkfenv}[1]{\ensuremath{\syn{mkfenv}(#1)}} +\newcommand{\Svalidspc}[2]{\ensuremath{\syn{validspc}(#1; #2)}} +\newcommand{\Srepath}[2]{\ensuremath{\syn{repath}(#1; #2)}} +\newcommand{\Smksigenv}[2]{\ensuremath{\syn{mksigenv}(#1; #2)}} +\newcommand{\Smksigshenv}[2]{\ensuremath{\syn{mksigshenv}(#1; #2)}} +\newcommand{\Squalify}[2]{\ensuremath{\syn{qualify}(#1; #2)}} +\newcommandx*{\Sdepends}[2][1=\Psi, usedefault=@]% + {\ensuremath{\syn{depends}_{#1}(#2)}} +\newcommandx*{\Sdependss}[3][1=\Psi, 2=N, usedefault=@]% + {\ensuremath{\syn{depends}_{#1;#2}(#3)}} +\newcommandx*{\Sdependsss}[4][1=\Psi, 2=V, 3=\theta, usedefault=@]% + {\ensuremath{\syn{depends}_{#1;#2;#3}(#4)}} +\newcommand{\Snormsubst}[2]{\ensuremath{\syn{norm}(#1; #2)}} + +% \newcommand{\Smergeable}[2]{\ensuremath{\syn{mergeable}(#1; #2)}} +\newcommand{\mdef}{\mathrel{\bot}} +\newcommand{\Smergeable}[2]{\ensuremath{#1 \mdef #2}} + +\newcommand{\Sstamp}[1]{\ensuremath{\syn{stamp}(#1)}} +\newcommand{\Stype}[1]{\ensuremath{\syn{type}(#1)}} + +\newcommand{\Strue}{\ensuremath{\syn{true}}} +\newcommand{\Sfalse}{\ensuremath{\syn{false}}} + +\newcommandx*{\refsstar}[2][1=\nu_0, usedefault=@]% + {\ensuremath{\syn{refs}^{\star}}_{#1}(#2)} + +\renewcommand{\merge}{\boxplus} +\newcommand{\meet}{\sqcap} + +\newcommand{\Shaslocaleenv}[3]{\ensuremath{\syn{haslocaleenv}(#1;#2;#3)}} +\newcommand{\MTvalidnewmod}[3]{\ensuremath{\syn{validnewmod}(#1;#2;#3)}} +\newcommand{\Sdisjoint}[1]{\ensuremath{\syn{disjoint}(#1)}} +\newcommand{\Sconsistent}[1]{\ensuremath{\syn{consistent}(#1)}} +\newcommand{\Slocmatch}[2]{\ensuremath{\syn{locmatch}(#1;#2)}} +\newcommand{\Sctxmatch}[2]{\ensuremath{\syn{ctxmatch}(#1;#2)}} +\newcommand{\Snolocmatch}[2]{\ensuremath{\syn{nolocmatch}(#1;#2)}} +\newcommand{\Snoctxmatch}[2]{\ensuremath{\syn{noctxmatch}(#1;#2)}} +\newcommand{\Sislocal}[2]{\ensuremath{\syn{islocal}(#1;#2)}} +\newcommand{\Slocalespcs}[2]{\ensuremath{\syn{localespcs}(#1;#2)}} + +\newcommand{\Cprod}[1]{\syn{productive}(#1)} +\newcommand{\Cnil}{\nil} +\newcommand{\id}{\syn{id}} + +\newcommand{\nui}{\nu_{\syn{i}}} +\newcommand{\taui}{\tau_{\syn{i}}} +\newcommand{\Psii}{\Psi_{\syn{i}}} + +\newcommand{\vis}{\ensuremath{\mathsf{\scriptstyle V}}} +\newcommand{\hid}{\ensuremath{\mathsf{\scriptstyle H}}} + +\newcommand{\taum}[1]{\ensuremath{\tau_{#1}^{m_{#1}}}} + +\newcommand{\sigmamod}{\sigma_{\syn{m}}} +\newcommand{\sigmaprov}{\sigma_{\syn{p}}} + +\newcommand{\Svalidsubst}[2]{\ensuremath{\syn{validsubst}(#1;#2)}} +\newcommand{\Salias}[1]{\ensuremath{\syn{alias}(#1)}} +\newcommand{\Saliases}[1]{\ensuremath{\syn{aliases}(#1)}} +\newcommand{\Simp}[1]{\ensuremath{\syn{imp}(#1)}} +\newcommand{\Styp}[1]{\ensuremath{\syn{typ}(#1)}} +\newcommand{\Spol}[1]{\ensuremath{\syn{pol}(#1)}} + +\newcommand{\stoff}{\stof{(-)}} +\newcommand{\stheta}{\stof\theta} + + +%%%%%%% FOR THE PAPER! +\newcommand{\secref}[1]{Section~\ref{sec:#1}} +\newcommand{\figref}[1]{Figure~\ref{fig:#1}} + +% typesetting for module/path names +\newcommand{\mname}[1]{\textsf{#1}} +\newcommand{\m}[1]{\mname{#1}} + +% typesetting for package names +\newcommand{\pname}[1]{\textsf{#1}} + +\newcommand{\kpm}[2]{\angb{\pname{#1}.#2}} + +% for core entities +\newcommand{\code}[1]{\texttt{#1}} +\newcommand{\core}[1]{\texttt{#1}} + +\newcommand{\req}{\bsyn{req}} +\newcommand{\hiding}[1]{\req~\m{#1}} + +\newcommand{\Emod}[1]{\ensuremath{[#1]}} +\newcommand{\Esig}[1]{\ensuremath{[\cc#1]}} +\newcommand{\Epkg}[2]{\bsyn{package}~\pname{#1}~\bsyn{where}~{#2}} +% \newcommand{\Epkgt}[3]{\bsyn{package}~{#1}~\bsyn{only}~{#2}~\bsyn{where}~{#3}} +\newcommand{\Epkgt}[3]{\bsyn{package}~\pname{#1}~{#2}~\bsyn{where}~{#3}} +\newcommand{\Einc}[1]{\bsyn{include}~\pname{#1}} +% \newcommand{\Einct}[2]{\bsyn{include}~{#1}~\bsyn{only}~{#2}} +% \newcommand{\Einctr}[3]{\bsyn{include}~{#1}~\bsyn{only}~{#2}~{#3}} +\newcommand{\Einct}[2]{\bsyn{include}~\pname{#1}~(#2)} +\newcommand{\Eincr}[2]{\bsyn{include}~\pname{#1}~\angb{#2}} +\newcommand{\Einctr}[3]{\bsyn{include}~\pname{#1}~(#2)~\angb{#3}} +\newcommand{\Emv}[2]{#1 \mapsto #2} +\newcommand{\Emvp}[2]{\m{#1} \mapsto \m{#2}} +\newcommand{\Etr}[3][~]{{#2}{#1}\langle #3 \rangle} +\newcommand{\Erm}[3][~]{{#2}{#1}\langle #3 \mapnil \rangle} +\newcommand{\Ethin}[1]{(#1)} +\newcommand{\Ethinn}[2]{(#1; #2)} + + +% \newcommand{\Pdef}[2]{\ensuremath{\begin{array}{l} \Phead{#1} #2\end{array}}} +% \newcommand{\Phead}[1]{\bsyn{package}~\pname{#1}~\bsyn{where} \\} +% \newcommand{\Pbndd}[2]{\hspace{1em}{#1} = {#2} \\} +% \newcommand{\Pbnd}[2]{\hspace{1em}\mname{#1} = {#2} \\} +% \newcommand{\Pref}[2]{\hspace{1em}\mname{#1} = \mname{#2} \\} +% \newcommand{\Pmod}[2]{\hspace{1em}\mname{#1} = [\code{#2}] \\} +% \newcommand{\Psig}[2]{\hspace{1em}\mname{#1} \cc [\code{#2}] \\} +\newcommand{\Pdef}[2]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L@{\;\;}c@{\;\;}l} + \multicolumn{3}{@{}l}{\Phead{#1}} \\ + #2 + \end{array} +}} +\newcommand{\Pdeft}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L@{\;\;}c@{\;\;}l} + \multicolumn{3}{@{}l}{\Pheadt{#1}{#2}} \\ + #3 + \end{array} +}} +\newcommand{\Phead}[1]{\bsyn{package}~\pname{#1}~\bsyn{where}} +\newcommand{\Pheadt}[2]{\bsyn{package}~\pname{#1}~(#2)~\bsyn{where}} +\newcommand{\Pbnd}[2]{#1 &=& #2 \\} +\newcommand{\Pref}[2]{\mname{#1} &=& \mname{#2} \\} +\newcommand{\Pmod}[2]{\mname{#1} &=& [\code{#2}] \\} +\newcommand{\Pmodd}[2]{\mname{#1} &=& #2 \\} +\newcommand{\Psig}[2]{\mname{#1} &\cc& [\code{#2}] \\} +\newcommand{\Psigg}[2]{\mname{#1} &\cc& #2 \\} +\newcommand{\Pmulti}[1]{\multicolumn{3}{@{\hspace{1em}}l} {#1} \\} +\newcommand{\Pinc}[1]{\Pmulti{\Einc{#1}}} +\newcommand{\Pinct}[2]{\Pmulti{\Einct{#1}{#2}}} +\newcommand{\Pincr}[2]{\Pmulti{\Eincr{#1}{#2}}} +\newcommand{\Pinctr}[3]{\Pmulti{\Einctr{#1}{#2}{#3}}} +\newcommand{\Pmodbig}[2]{\mname{#1} &=& \left[ + \begin{codeblock} + #2 + \end{codeblock} +\right] \\} +\newcommand{\Psigbig}[2]{\mname{#1} &\cc& \left[ + \begin{codeblock} + #2 + \end{codeblock} +\right] \\} + +\newcommand{\Mimp}[1]{\msyn{import}~\mname{#1}} +\newcommand{\Mimpq}[1]{\msyn{import}~\msyn{qualified}~\mname{#1}} +\newcommand{\Mimpas}[2]{\msyn{import}~\mname{#1}~\msyn{as}~\mname{#2}} +\newcommand{\Mimpqas}[2]{\msyn{import}~\msyn{qualified}~\mname{#1}~\msyn{as}~\mname{#2}} +\newcommand{\Mexp}[1]{\msyn{export}~(#1)} + +\newcommand{\illtyped}{\hfill ($\times$) \; ill-typed} + +\newenvironment{example}[1][LL]% + {\ignorespaces \begin{flushleft}\begin{tabular}{@{\hspace{1em}}#1} }% + {\end{tabular}\end{flushleft} \ignorespacesafterend} + +\newenvironment{counterexample}[1][LL]% + {\ignorespaces \begin{flushleft}\begin{tabular}{@{\hspace{1em}}#1} }% + {& \text{\illtyped} \end{tabular}\end{flushleft} \ignorespacesafterend} + +\newenvironment{codeblock}% + {\begin{varwidth}{\textwidth}\begin{alltt}}% + {\end{alltt}\end{varwidth}} + +\newcommand{\fighead}{\hrule\vspace{1.5ex}} +\newcommand{\figfoot}{\vspace{1ex}\hrule} +\newenvironment{myfig}{\fighead\small}{\figfoot} + +\newcommand{\Mhead}[2]{\syn{module}~{#1}~\syn{(}{#2}\syn{)}~\syn{where}} +\newcommand{\Mdef}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L} + \multicolumn{1}{@{}L}{\Mhead{#1}{\core{#2}}} \\ + #3 + \end{array} +}} + +\newcommand{\HMstof}[1]{\ensuremath{#1}} +% \newcommand{\HMstof}[1]{\ensuremath{\lfloor #1 \rfloor}} +% \newcommand{\HMstof}[1]{\ensuremath{\underline{#1}}} +% \newcommand{\HMstof}[1]{{#1}^{\star}} +\newcommand{\HMhead}[2]{\syn{module}~\(\HMstof{#1}\)~\syn{(}{#2}\syn{)}~\syn{where}} +\newcommand{\HMdef}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L} + \multicolumn{1}{@{}L}{\HMhead{#1}{\core{#2}}} \\ + #3 + \end{array} +}} +\newcommand{\HMimpas}[3]{% + \msyn{import}~\ensuremath{\HMstof{#1}}~% + \msyn{as}~\mname{#2}~\msyn{(}\core{#3}\msyn{)}} +\newcommand{\HMimpqas}[3]{% + \msyn{import}~\msyn{qualified}~\ensuremath{\HMstof{#1}}~% + \msyn{as}~\mname{#2}~\msyn{(}\core{#3}\msyn{)}} + +\newcommand{\stackedenv}[2][c]{\ensuremath{ + \begin{array}{#1} + #2 + \end{array} +}} + +% \renewcommand{\nil}{\mathsf{nil}} +\renewcommand{\nil}{\mathrel\emptyset} + +% \newcommand{\ee}{\mathit{ee}} +\newcommand{\ee}{\mathit{dent}} + +\renewcommand{\gets}{\mathbin{\coloneqq}} \ No newline at end of file diff --git a/docs/backpack/commands-rebindings.tex b/docs/backpack/commands-rebindings.tex new file mode 100644 index 00000000..96ad2bb2 --- /dev/null +++ b/docs/backpack/commands-rebindings.tex @@ -0,0 +1,57 @@ + + +%% hide the full syntax of shapes/types for the paper +\newcommand{\fullmsh}[3]{\aoxb{#1 ~\mtypsep~ #2 ~\mtypsep~ #3}} +\newcommand{\fullmtyp}[3]{ + \aoxb{\mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp + #2 \mtypsepsp\mtypsep\mtypsepsp + #3 \mtypsepsp}} +\newcommand{\fullbigmtyp}[3]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] + #2 ~\mtypsep \\ + #3 + \end{array} \vrule\!\right\rangle +}} +\renewcommand{\msh}[2]{\aoxb{#1 \mtypsepsp\mtypsep\mtypsepsp #2}} +\renewcommand{\mtyp}[2]{ + \aoxb{#1 ~\mtypsep~ #2}} +\newcommand{\mtypstretch}[2]{ + \left\langle\!\vrule + \mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp #2 \mtypsepsp + \vrule\!\right\rangle +} +\renewcommand{\bigmtyp}[2]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] #2 + \end{array} \vrule\!\right\rangle +}} + + + +%% change syntax of signatures +\renewcommand{\Esig}[1]{\ensuremath{\,[#1]}} + +\renewcommandx*{\JBVSh}[3][1=\Delta, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3} + + +% JUDGMENTS +\renewcommandx*{\JBTypElab}[6][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + % {\JBTyp[#1][#2][#3]{#4}{#5} \elabto #6} + {\JBTyp[#1][#2][#3]{#4}{#5} \;\shade{\elabto #6}} +\renewcommandx*{\JBVTypElab}[5][1=\Delta, 2=\shctx, usedefault=@]% + % {\JBVTyp[#1][#2]{#3}{#4} \elabto #5} + {\JBVTyp[#1][#2]{#3}{#4} \;\shade{\elabto #5}} +\renewcommandx*{\JDTypElab}[4][1=\Delta, usedefault=@]% + % {#1 \vdash #2 : #3 \elabto #4} + {#1 \vdash #2 : #3 \;\shade{\elabto #4}} +\renewcommandx*{\JCModElab}[5][1=\Gamma, 2=\nu_0, usedefault=@]% + % {#1; #2 \vdashghc #3 : #4 \elabto #5} + {#1; #2 \vdashghc #3 : #4 \;\shade{\elabto #5}} + + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: "paper" +%%% End: diff --git a/docs/backpack/diagrams.pdf b/docs/backpack/diagrams.pdf new file mode 100644 index 0000000000000000000000000000000000000000..a50916b23469e84fb51ec53bb13596930de8dd49 GIT binary patch literal 145951 zcmY(pRa6{Iur-=MaCi6M9v}=Jf`t$)cyO2Cu7kUU;O_1g++8w*1&0}QurNqquz~xX zb6?K?QoVZhuDxn?)kE#>V%3mW(^2?cf znmfAKGV*Jf+gf`tzWWdGl~G!n(c0PSe}Mn9|9>6+e;mJxy_E-}q4590MgG^m|6eQm zzt;FaVizxGPe$SY!zJ|J(f`Y(;OnWRt{2w^r|G>XkJKK8NF^UL^ z0E8L&74028t=<1y9shHcx3+Y#vi>h(4^MY%b0=)yJjXue2DY9Ck>!EXNvyjMXgZ05 zA-Vl>0*dhglduL4r>TuaJjVQJn#kfaxb%YV6Z3E|NQa<4}MOT8GG@1fdwNAU)qA#pRQk?k8P2yh{ELu znbMd0dni)Y&jz`!jjz=MgU$LO*Rrb@PteC(umNQ-;jbGY9cclbclFZxV%zd2F(%@h&a_A4;=RWgadiskA+5R3-gaVQbU7~Rz$i%1^NU4;ks zKi@poLpl`imJp8^u#{_w)#SXF%TSLX-RXg4FpTX9@H~isZ`|7UR@~#(KiC!HgH|3@DC`1RLV`(sB;W&pG+wV= z5~Ry$yCodrhbyia4UOYT^vW`vabM5~U}jzqbK5n%^bUl;0A4R51|WOmI#TQeV|aJ{6ma!=pD}-0)HnPWbv?jM0U*C0 zwX+dR6yJFzgM82qHWd>DBXPiW?Er-((cJM6XDBN&9KPvF*26V#j!l_!>5?T`t*Qg){la%UoiBYH7JpxvFePG}iF-USC>*BSiu%Hs>XSd~l-MKIy~P1Q%g zlMo7i$&G3nBl^C+e zSi%eaQ4lt{yn0;^8+sHSfVgVWIY*rO74F%r;C*Az>owUvr?5dy$~_X`)R{n_b2y>t zN}Nfo`npV7g|(;;%T9Fz)lHnf5fpA*2V6Lu6~654Y&|J`2D=Rv<0U-TO_={xavCtd z67N?xslD_c^7||rRxR)bIn?(05$HK>gFg|NyDd7KyskJ{)K&R&7s@ZP z6jykcb{+W{DNxb!F^7E&YsnL|N^NfXTAp~Yj8R`R+L6hC1A1>kY8^XHvl{Kpqn;pe zvl8L8_wSK4;ft>WaBm)c8}eP!fnb%1mKAFX0ucY)GkOsV`5rC9r@fJmOUs6Kh__zi z+Uq7!?jiBu{nn#PecaW8_m+|8^^$4#{k!Zl8_DN`!kaNUxY7?PqZD@cwQ zp&mDlW%9OiyJx#HkD)V2aE*3S`G$_ylE@#U80b1%L|7{A`_-Q>q8hB7xH6dPTFFR^ zhORTbL@^}ic<|_3uplt8hjk+FXePbXNr#W4vX}$~0e){r;0cpaUJfNb*s>Zm?}-#@ zz06;mO71_>-xMxD?qe#b{6GtV6lM0Gd%8?j_81JRUL}WJ8*DaemJ#d)qPG_+Bs@by zNhW{^5Xvj_LB`B8>1F~{#S@Id=GO)-UIlkqtMec_DiR5<8kx?L3M!YgqRu5o3bJ(i zUY5i?^%K-Y2|zp#I-ps(;d2mZCyIo@Xnr3zUMt^4!Q%w4?r2!abs{0egW(G|i;bk8 zjUw0k$|_vv%eQKL4R-EIZ*7Ux`dPE6tALP=pmXl?zd#wN87$)R`3?<+PsF$1N)mWz zsV)|5!1UNduQ@MPz6S&TaJUjXx7sf5`jB3G*vdNLF7s<&qhDPtjoQVqC{6?SwTsE1KG-ui($ zgeH?k?Yin*A%W!-~I;+%is{zU6apU?Ym>5ibtNyUt<*DL&R;Z@GU8@H2?Xw;H zfnzzKPO&u$YZMh24}Zq!u7I;jdtUy|W7u(mKO&QqRQ8tOUD9*+azQRX(d~ez*)qLy z2a>19Khf?V_iHgkTSWhgI$ME}gNbLx5SO`*vV7XrUp;3y7z@7OYs^vatVdLME;nl| zMCUWng=GQ4@5f>-!#OLm6~{DL3bLW~@EyA06K?;=i}ULuM6_4z63v#dNZC9RXDsOf z#I`BB;=|;~+plpG(2*VFkf1uG^s&tb>hWvNJecu~<52LPfSw-|?&=+|-DbQEhx3T)oA{25yPNBul6WV(1?|vzs}1$N znn=w1H}GRf1&|66Vv*p9e z%Ok_MNdo&T%Q55AvB@nxN89K}!hnl;^k`1m$gl$e)(VXa|6+*nelF3GAeswK*53xkS1`X1XsNUo$ArO@LiI`hNHXh~?Q z1^p8>e8ld>1Sq5XMcrGY9qVcXE1BeU4?eOCJB8te*Tc6NeQ!X^z|mzHQB2?t3*GUc zgvV_<+ud`+7qJ01djc5rp2)`#2cA#&i z)y7BRba2*{xlvRAJAwUqN}z8W^YjSDKqei^yn6Glny-1F{9alZ9ox7#?Lc7yNLDxn z9E^#dBfnO}^1!h?fJGwLLv)B2!9YE)(hPYBI&1}NAd(}>gjq1TXb{=SGs$$P74iDiVN zLsTg0o;14}u9RufOvR-o7-4L_SyF!=neg|bqF0wj5%=KQkce6LC%)L`hYp^dicltuP#lzB7Ti}eUE5IIUCI2 z2^Xq2+{^#m`3mkf?zK~(2f{e7Nz3=o??kj!iqrNQ0(2_@E1x<|yGh{TKiva&6VCmN z0kX>bUONFQryE6~xLV^RLSl}L4^8BrtC$K5u7JV6@uLNH9|5auRqWIMxfSRoKhH^Uz zAc%Mj`F!|HuW1Z?flAulpY(mo7<|4R)!6)$WyZ&Tc0j@I-5EY@G2lN0EEj3_S8isH=&dPd&_EZ(tLhkx$eQ_C@PM;k4>;XF>iX8%2nWKrc=XPEvv z{G-3z{$W5!_gB1Tdj z?PO$|6V{XJB;N}MgM2U9&ys(qi4g2yb4EgP2a{C`Y|8*j?~|k_$M)2MMIE*0 zB)^e7+LgFbnhU!r%%#b8g*TG~dAf?skIqL9trpAXY={)>$ae!>7Qn8k@*MsR=Og4=BJgC6W@#ZuF?vt5acinkDF8QxqFM^gTLBp{gd z=+kA#ZUmNVJ~InW&ox(iR8D{<&LvVShkNwCt`582OZ>4ZT4TqD$aJqPYmyDp{JL=j z4egR)OJJ6~LMr!jFj7&6=tQF2MVS(xp5-Ddj+i98Iy{8voE&^*y=S z+%yT5zcWBEX~k8ptd{pAN+snO@7lVzU}U3#bdTK;P^@a~jIW%rNo3VTr|jVIv1Jyf z;<^EkJ1?nSFX`S`z2652USL3zqXXx&x*< zdR+whX5nUhwXOodpbs=hhf5F26t&BcI9GItlGT&LHyLNvAXfYd-wV|@33csHDpj)o zqlDk3Ln-P*JiZJsbqvp}Y#Gj*BOD@DQk2PEp+CyY9a+51X+)OM7}7?%@6SayQSY&U zE;eYrQ#k!2-kot0-I>k=m-Kfszv@2lF_2R>TY|+cSZFhVO_x&8i0_U%iim+Z{f>m~ z;832s?H}otdjX3vazFwZU$WgSh+K4Ns)YA!;^9@g%d87GxupfLl4Jto&<7tL;(<<3 ztudPp^XQy6?pQb;F7QjH;0aHpE)3A1o!J0Qj-ut46X6WATfZJ*?q`WEvlYI;0#}Wo zy52?6y=knAY#RZ%gOg3{Tp%LdT|nKW3A z#U1H+y5ID8 z+8PnW>Q|P^I@(YIo`GZm2w>8Nh zeCwqcHk;!NusZOC@`?Cx6q&8IhRI)*V)SF4e&o-&i6z=1O7xOLTw;E4RhXpvbTOpt zG?=CmW-BJirM~`Z?^n{NefPUG3@!gu?`{DT5(O8^#!yr-Hfm^BY&G76$>=_1BT1@c z8nJ8YmLyg@F@X0cE+wMS zHkJZ!p-oyBwE-%J{t+c2H(sMxQl-Rp9g^88nWg5`~434mG?>nUGxVP zLaZwiF(J3{Y&lZdX(<*}ac0(q#%*&nfRd^HYKnU>gM>+XWP1~e!ZiXJpmfuVb4sCG zCNz%N?HZ?fc?cR5dmhGL2~Mn>Or%H89Gp^Eh0m@{uSbBgQ~2q;>F)?t*G<8e7Bv%k-YrWTk`rFC9o0B1e28t}6AZ@O_#*f$f4tt@I z^Zo-e0~2)22hOFasPfi|i@dhum~ERvX-p^tr$lr#DK|^jIx%^fbOIh`*xsL-4N$*5 zPGx;u%}KV$kh{dJNTP$rW_y#mp(!<=p!Y0Li7L9ih&Pv$)K6cE0aB_jEv2$qM&b3g z(n@2&uO@sA#UzOs{|X2>a2={6IT1?DAHyj>&Qy-{Y8EN8%!*cYh5-ueEqFp=Uw1Y) zB|OAZj9LAR+DD+<$piVv!3iZzlDRxXL@yW#L%`%PxX(cZU7w5)`)@u)1yGt4q%~dG z07f*>C|WstGG;gN>F5b_5*bTd4sA1(h?`95a{>Ld9MpB3dj*r}7DA2;q_#$fxAUz zGkyZk+Vb3i!&H}D&^;*?qMRRi1T0Rp-cAp+3bW*&-j{p~Q}E&o1ojmY<)QslAGl`P z{41JwJ%8;FyFNu&N&~vW2y!imX`SU*%iWQJka1-3+0=CrPj!rThe&E;MLw}R=qFu^ zNIG=bFC~tB^A*f5HIBlX?)KpfhAS_0KSE0n+h&Tcm(~u%*PJg$Bx-vTB_XwL(DdU} zpFh|rD~6VFJxOrX3SvzJmIck$U*4vY*@+H!hp<&qhk;CuEEGuNr$!hI{E^dF&N3za zqcz<4J-1Ei+&yMWTZWXcl6OIrmcuQJ4NQNnj}S~0Z=*g2OBx$^$7rZ_Sr1_ZmPsAo z1Gj_k|55Mu3<^jF3%G}<|B|4;x3SqFqEA>gg3>?@Wr(~an@~3wU2P}uIk=1i)iu|P zFS(+;MxwjO1iNr_HAqQtgD$M1$n8IlL&@jMX59>n#Gp@;yEr)|Fbs*bJ%)huO}<@j zs&bPeu=P@4=-Z!~r=x<86q40&rxS^TbtZHx*6}Tx{wnNOxgBh!G0`@GX^SKPMo^#m z%`D&+Z{u#N)A{a`)-q~~_q`=;5`v6c>Gpi-<^i6>@>(2%&XVM)%4T5!U zUyrYe=9^J`5o2y8R#wPtp-q+|&q$>lx+j&BbN&)bEei3A9n&Yt7IN1Yj_8)>+>(pr-EW`o%V`8( zO}xXeBGo)gC}Bqn@gaV#P*H`Kj0vW*kO%Cly`_)@C-0`%4oDDQPR*hBY%|QEAA=Q) zW;6qxjm77UO?|n-0%9u`5fhiU*Uw$MN#`(3b>R-YR%w<(&8t&MQSZ`8D z#6L$wT18UP8!TKZr16|yJ>MwywDe};HES6*+i`q>UTE~XLW?*}$S?a1n>9Ip&v)#8 zp>|Jg=t#@BNT^cuUNMPdC>VAdfBe`nO=2V2_;w&E>?3jshon;Va;(_UOJNd`hAZ)3 zYdn3of!$EknXTBR45nfNl1fBl-UCVLzWKp&)$+c6RO}tma?AM#Gn)SZEcM=>W7*yy z#m83=z@V6l`M&wE$Y9E0Hs0hS1;cmJkg6}Ds|T?BQ1AO`R>{6&C26l*^NN7nVim0Y z#A8tpDv7Sw+rk=eWxhJ(xT?^zH%-W_Ur<~Dn%fMp)@9w{2+?;;gJi%+pnGf{`r6@m3+Cw;=QO7nW@Y{_lTu*-sj#p`Fu?dGDl>{?> z^kA=CPg~O+eB>=v-^hSfV#*v>uEiE6C$^f(;PgYP6Lk*`1LP+F3&udg9b9P;N8Y}r z0udM|(3$h2KkbxXh`kFFx{;U}VMFIUiKtmQSszKoTQ%Ql@E{_3UtY0JtLHb3jhM_( z+N_w&zN^)~9=yfWwcl9O8U85gC2I3(HPKEq-&K)!Ua=FA50@H}_A2R3!4dr`MjbTs ztOeeJNEDQ-Y8!#YpGuixpXI;!hNfo;?*DM?IDb_*(~~XmJ-JKoc~y?2en-vbi$ytlUKmOe|)6ni-m`0TXESi?{7KV{Y4g!dI7&P@(r_ zL0$^QqU%+p?fnS30}UjP6b=#5wJ%GLlfB;N5c2U$;`-NbfG7TcXiWW=58j=X#~V9w zM3>C9_L*?SZ24bSXb1G_$CawwWw&43SeBe!YiHX^RR!uxgs!nc9x4r@4ey?mE0T_@Ti+W8&ndM&uBEFyA6DkUlPkzPw&sgaMN zxb@a>yz|G%#+WlFSY3y+b?5ovwrO1ls6K+L?%24k^h_|1-TP%2dc-VK!%o^H7-ly6 z%)47D23#wJ8b?lW)cpuDp$fH!PYijD6M$4~RmFtgO!3M(XKXHnYOXl|2E{x!&?Kdu zN^oOItKHtavC9EXF1qc;i+_x2jbTaZeWuo>|Gf=y%)uzVOh^SoNOBZfzG>BQ@?sxs z!t9S>@I{-^-iTVr@3u7c1GFV?r*HTk(f7atMu9+TK(m@}MdTaG_t6&eoeXk$8GCqB z{(;g5!P0TEu!ougt&D?bqHP4?pQIDAU|VaPUEP527tmC8ME089tFZcd8shQ7cKZ?= z%W%;lgu}%7VYuzXWp4)a*LP6`qJzL8Zx{)wjS&E}m+i8tZ~b5?uWx8_1O+uyI9f1cE~gjo z6iD<^{zzO4*pXP$%af_EP4_^r?+*>E3Z@*oL$lds{}aC^Kc0x?$lbTTk}K*CAGpQ4 zlh*I!&qS@8W~GC#5Z)6)pQ2WW{#eUUPX7cnVYtdrGO;`kTSO!{U)1P>Q5T;F?@8AP z-hCf2ner6GSCcel z(yNBP_q}!i$z76{ZZ2ioirA+b!XzG8eE1f9&+g2AigiNR;--;8ztyGK2_NQDPA*A4 ze~5GrAtJE+(XyyMyeilqydGrYI^0PVE&74HMT^urnhefj{F;(izso6v_u3SVJIt5i z7@R;RQ>}UlI%oM?K{_Tm!iGt^L(#EM_|~v9F_HU2dRTs6T#bdweJ`hfW?zk&(8k^^ ze(hhyl?CmaUIL_-`pxH$tc3ihB(~_8`o7_pfivS1+crw?rO%4aW>508;?7qcA|^;i zXk&niYth9xj>ceX^iGX}q z^WUHWF7)WWfzLp7%8jCdTH`#lb3$|%QQT0VQT3hx~kgeG~=&n zaFp+Mq62MzZQeV1qa9V!KwQvidFCV{LLZ>>`$>Ac(q`e$qdhCx#C2O|li^whEdIKb zJ)E4FTgfP4PYBzwc4a9=HF+=JG$o55udm>Q$}3^A+h6M?-_C%)yh?OV zsph2CHXLTq?ZT*RC$~*igl+8xC=I5!bybYsBh*s{@*n9aTiOaZX{4ZIWos(5VXD7Q9UUfPWt-&*nN#ZU<=O8DIT za%gecnKfMWsH-YR#v^ySONQSORet{*v>A;vQeikF)VE0&~0jpEFtaYAq#&sO2Yn6cc zEeMkRuff?whI@Q_%^ez4vNn=+<%7s_!)GqPZ86~e3L^eCo-)TRqwMwU4pDjomCuxf zPuhUsAx_5zI9V8)q#m#!R2U<@5=fN@T+w^BGAb)3imbk>Ej9~KY?Y|%Txvj8h*)DY zBxm7WUP=nrthsPOzKWWUmlan@X>lW?copv5(6Fu*LtO^I9b1?L-z8XIlsj*uYed)Q z6ol57@ec4-yJeqD#*3V!*b5KwEB13CT4iU9vou5SN?Q3i*HPF-FFU%qwA5ewPIIYJ zY`0R0tF7xtDVCpij~VW{X49%gucTaXZ&8DOEvz^mg?kB-mlq15jG5;ju|4@$lo&#| zF*qhvNLy@|SOmH$47B~|du5GD4?ck=k>yB!aIK76Mbvx3<7}3GqXssJLkj%MT%p zu1h}#cHf=LM%d^eO8^!EaTL*2h_MZKA6Q{fUeKW9DK)EyB_2Lfoq}jOpS>*KVZR5b z&SL}yJG?X%NPCv%KriJz2n)YvdS#J2T=1l=4!E1zE>-$|U}y<}`3{8}^u=FK0W5ZN z$$C!B9VG__1p9pzA(Z?sXUc`+cPsZ)=2rsB=fA9sKNQ+p{)&EUYuMtdJ2Y+ZJbKNeY?>X1K4rEj_=c$nOM$~RD|&Zm zqzNxI?#hKKe>>u^-1qTT@2*M>#D`{3W?si$ddS#IQTsdx7M$k8L}^JKHj!_mJb?dp z5AJh(i7#2rb<;(bxluEb0^X!sZnHmb7D;oV7yM#wWt&ro4St!HViQBVN5Sy-z4{LEmMZFW*~>nSQ>>+JXS1Dsd=1p&|5V5=%bCeVr| zyE0F}{+;ta<@9%FasF?nfPpqp$j8Kc?(wbBBm922Y768Aj=#0pAS;~X7FB29 z37-V?X_t6W-ivcCB&61E6pOO`I4{a^@TB;IFYf~53f+o@C~HJ9AmLo4z(o8t_g=z< zM$#Tt$e+jg``fSR(3&t+zx_&7=dz)QN9IInyrvpuLK`U}ZG^|_Br5)Lp-$8rf~y~i z$f_D&xh$RZFm#MOquHHmnq6c`@8>GK)mCbNn~-%sfoJ}E>uG|2KJTo1jkAyyn6=51 zm{~YZE3QXFt9h{-Kav=KhPk6?k_NYZLZT|fn z%!%}moGinzCfuVCT!lb9_oe({ovU=^V0SBOL~0buE&Xv~IV~;1xSo9AG9TD`_v#Ut z;8&|UdRL=2jNflr`}OsMR6_k{loWf2qD@OF+mUv9MJy<@^(g4yPVSmIdC;k?O-(8I zQCsa0msQwg{{FX_HAe6vF@4Exw$BPaV*kiwI($nFu3np7fxN%fuo2B3u2CwGJX zN#)gCgbUYjSk~li__aBHR#kQS{=x<8P_=&JyrgWRFhCIRXE+QF2bHPl{Q7Z39)Tgi zW!=b*x_Id%6~v5`=Ci&kt%@4S4n1xc%mm?Z#f%6E39v8RpiKluiL;|A#AcXGhj>02 zo+v~OOU$=?M@}V70?4f$AMSbopnX_1pw+Swrhg0O4sS*Q;r_1j*FS&k@8^AzsmrhK zuM+qy|1QwRSBSVftbC8Yg$tC%?a9`|sxzcf`D&uh z;d*~sel=zNsX3yzLSO1mt0oklHMe0N&0ea(6j>c{2y*ZM+U^R}woc?D(P$uGf241r zABrrkL;f@$Rt^*betr!Z|5FnqkK?0JA7`%65Yx!-At$~(1AIkxt%F-LmhVCN_}xwH zyB4V^Pn3@F!kYR{0XxrlyY)bIyy`#t-M}5mK zb6NLd8v0tn)hxo@S;^7MX_|vBrSRY)w^B2=W-Ix_&HB5>w;Bh2FHl5Wbv_fHj+c%t zX^_r@i!KClZ@Uy^_OBlto04FUC$=p}$S#>H;JQMg8yrWqtEYp2hVZJzXzpU!`n%s`pheksf3-*=6Jt1B8|;DxHE=wvu3diqMB z^fvxB+K;{L)wDmu;2n+&RPT0UHOsWiPZHHt&ji2Fwm?ba&7aB0C8M5}W5!6xO>!vB z(pYoUt&n-;T@Z&lmn1&WlBAGMruzcTPomwn;P)E^jRf&-ouvXl$x!|FTKGEP4!CRh zTH&XOI5)@Y*Ck0XcL0;{*~{YAj#$)C{`O~J%e+vtRx1udR<`b?anuiP*O7+}MH6=1UtrMYl#S931#U*phzQHcW2_<`eaGDDyP$ z-Iz~;I&-#VYQRqV>NaF=6giawvz-MX(Fs2&`@}htwjdM!X_;-}%cUGoe|}Eb_wUu@KP-mLJ>9b0o}cBB;9k;cqT)Hy$C*uOb3zH(KNaJcLM;8=a(zo zpS z^4Moqtj&ZmkK1k&aQ^5{caSdmF*?A)hxb6GVFnw1}? z7h{?FnEw%5(*f|DOG2alD~*%iaK34!rS?^`(G)(bDkFVMuvB1x$0=%?p)3YYVys*8 zNjNXTH< zN{BT+gT>7dyr*h?2p+JD3xxb>+<_wK=%Y?5c0z>k=?84f(d8KS;))^*WoFMVq;j*5 z=PlKhl3szN{z-a9hYH1hLH+c#Viv_zlWuxH#9JRn*UV1%+n?%L+c);am&7vIu===; zm=C#B7aF&-qG=;jSp6fezVSloWEYx>Ip8^VK7(;vZO^EtSn*BPMDYXuweN4g@dG5a zm5Vb&D7b{OdQ?vSno=E|3Oww5xU4(b20cjYNIAbKA*t--EHppqzB}SVxu?iJyjkzd zilz4!loDP2og+>hl@H%UV4OJ{XP-O6(%5T9XpUTiJdfDau_U08#uxL|bf8)PLhxt2 zjv4%Hcn_VS_w=ME+>U}3aF$czG#N(cE?$FrL# zSA5g6qrJ^vqo~BRzEs40Hn?CH6y#x=m?dy<&6hPG`UEsaG8XVpZ3z8c@RjL|9ib)g zUf{eZAyJX=$)q!Zh1P-F;)QB6BW+(kK9|#N`6}H7xWit{eEghxG4f^2aXHL5$mCqL z=OxASzX6KMwqc|eT7j{-4_IQe>1Fp>Vl?U>iRV%duKt3->Vb})nfg#!t_l$S(05o( zQpeBI12{Y(HxT--Rcjx1wA*(Xpjd<95?L5Q6^(a2L%WoO{7QaV3@MEj&3O{uFF#5V z7aIBTSV$F#`j|qMaHJ+7|1t6IagIVC7YS#`7&L3X9l++rMvxsA0&A*qRZQVO z5{Y9?JS&kpcTO}~_xge<@1w3(pfF0g`ye!kmOMqALA$w+K9RoN_thxoBw-W1 zXIgWGAZD|?gPRwwJAri;JK#=7txrE0Q0_2zo?j3C2rN`Q3}^jf@Yn1`}`-q5y= zL1|H|>~tksHj1&)P-IEetz5e6cdp;^zVh~LN9wbHFS&7M%Bd0cPe8~Km2&46JRq&A zdZePDwk8jH--u9Xep4vXKO*-K1HF}GFvCR}z$tzD=}!gao97sF6Tf2l5SUp4YLr(2JaLlAj(+fquRIZt52-B1`XZfkC?VsG3?e>%mBTfx%4SwJG`ZqfKfjvr zu>XMOHh4AGV(#@O9g2(*@zo76iG}0tb=Bpd1^vo&2qITBT?+X4{9NOsBxz#zC*UK| zUybv`3p$e)!Qv{#^G|IXV@W8eL{;)y(~y|=mq*#020hF^*3&3oQ)-zZK1xw<6JtZ9 zYCLQ9zAKP*C}+PR`z47e=C@*uvMt?Bnn~5W$oopi#ZtC)J^W9I5agU1a-Bq=t=ROB zmbqhi0Y8DR2^b8Q$nweC`dY?cP0;%H)c&7@g?)#jQvy@NnDjKuDUr_BF)ug~lCu9U zMy1b(ax_%I_xbbmU!hY~kxk__Qbh~bVK*3kwMV~?cahCTTAB2mAG4rE*7*eyt>{Oe zpEu=){Wn=CmY^FPv_vrYJZE0zn#&p_|TXJ zs?BULUGe6B4m@A;RE{#m4Q z7_=K`(;%9pUe_6#@Co5SD9fh8B24&tJ|fB}yqd6=D1E-dAEl@Rl((K&wC`a>dXHBi!w3I z`a(2)q+yCmm|6UTVf5RUSagNpuWyC_b%z>(+X*oS#sr}!d}#AK=(%GRYKvEvRoSX) zD6h+hH2>tUyxh5Q`#b|YY za#as*Rff(WIzGsu(F_9se+bOS|75QTvuUUGL_o)c49U^Z$ZW4uf=;g{nZ-V=2Zzf@ zhHu+&l*U5uMveT%BqguhZAx>lz<5FpfAnXOCF2zS+7v3lsD=_9W+<^RWw2pDLtW7 zSCFVqfVBA6@Vk`P*&L$plYkq_P|AM0K(U^MyZhRDqLQDsx?OZJIWcf!9U*(^ok@omW=nyU!CCAK^jqKxM4?D`rD(F$>!IzWDP z6#42@b-%$XY|X`xIXD|JD=`|uz(BVQTxwzK@WzOPiJf6a(y71X`SG1@GWoNeZWaqC z;O^B)x_a|rwFmRy{h1tI%`8i`_NXFsi+Xq{vOd$8!Sd{-Q&-QS;-1bB?jJncAqjiY zevGFxlx`gX?c%}m!pjdMm4=XF&PDckpkctuRQ!a%;@ro|hm^l&>V7HIuP zIL!}zj-^?x4UFq^aBy1ss67e#B<1VbVaw6nVI2Ex3|-HpJ}=tR+NpP4P`f!(n8?Q& ze^b$&QnZ;P@AQkmJ7toox?;4YW1ng|y$VZ|IxiYu99wU!>mz8oX}Ri^>l#Y%W!}ViQ0tC-oK$)^z{L4+1c)Feb8x-X=yvmef58Xs= zn=fi|AKx`${PsTy|1w$mGc+x9Tqu)rxtx?$(>kE0l4UwVRfHp?`JGekr$2>U=oqb2 zLF;08&&!|M>_=L>DRbomBE9Yo8$H|2hC~zpf9XwNW|ca<9QI(!Pd573>g8#35nL`$2P=6XAu$8*pCNt)D3WdOU-=S=hd~Q4tu| zTBSH&cd&SA%XJqfr>s)1NSAD{;&vn_67}5<)BamycwVer#lV?WDRql<27d*@-kA#Zh?2-5!` z(8%C9sz1dnv1=9m5M5O9`-f(2$IC`M)CCOevSDeY>A~Wz;jzd|GI_hM(w;r-qgf zg6wiPGy2SSNsixt)VjI%^v~8q>o;3*VUn>jO!faNTaqb8X9gg}!ab8s9si5oWxeSX zot8-xU+nHNXwo`FC`@w8jiNq#E3b%^GVph_M=fW?Je%X+Pev=BN!9qH8m6z|{S?QZ z$0^DD40t_`364U^Mz9tEeM=@VABEsh+I&~Re;u(mIhvMYX>83e3)f=xkRwJcNfVz$ydiOeu%-Rb{* zfEZ*ghSAH$UP@7JY6$bxh$~~Bf0Ck~mXVFgPmpew5+t>CqP_pcb&ROEX{(@9BUyMa z#A30GvSsw`Q>^VM36qB@NByY0e`sx&k@~o3iLXc@(Go5`os9mwhWZ z=`ZU*Y;^DbV(l5qM45 zza2K)LlK2V`St!-?f1X&9Nna?$}I*E70>{ zkTBXpCU-;E>945S95@6-aJ zP%^F&eja$oe&E9nHud^Q>|7U#7oONRa>?sRWU3L$XQc-a{Ry6@Ctg1CmUvB#bDb$p zEi(ozoI;~s*NZbiNggANMI)1@ffl2ui*mMq) zROxLIGu6v3!F1O^W#n%Kp2r!abLenUT-TSL9-w&ZsOjA3sd4Z-7OCewiare4ru!ym zf!^DrL_`{A92|e-wF+?kSyM@)4Jmh?aE*oN1^aS&FMU{l`AIxP@AKqLoO4^(szivRRqxs6iA6)dKa-uoGo z1ZApmyO+eL8kGwigoGG{Cp^$n(&b0Rmt?>m=4b~Y^DJNKG8TQXupT(5Y{9i0T)^7q zvA!!alY)ynh%mbDYw_%6^-}0DjhRUw#X)tvg7FsC(H{iCeHaqqoPW{zpkIa2Q&QlZ zGlDayTDDCXA2Lm@cr{dmNqGvTB&@I>+GPEq8$LK!fXeq9@$ykZu*J&Q z(ceF+7iK|?h!FcqfRM#vOiN`X@WWC^EFNiX*6Mx^(Z<5aO+T}q~NY@EXa&YGY{uKq^Wa0W8U#S`dZGrj;`}H z1y=+J*Npo^7x+5FQDB9wDa*r1Tc`Tlz#dvtGup@rki)N|r+7^Xb%)kfXJ)-1t7m5K zj8Hjia%uE@uc=$XpkC8Zv60mzj}zPK){NoV$ZDC{$pRS!Gdo!zK7VE$B(i9x){ElX zbt!I|IS(s4IUs9kDR&=nn{{OzCvw@BWKy)CtV?3&K_1_d_=BR0HK{I2VOOyd7G12W z0K=k-HRG}or&%+O8)ZK0R&`Ny;;37d;1HKt_Y)`S^Vv^l4&R?WRJR}av8U?vqZYwl ziqk}9=HB{V(4o4sFGC8t|;Z4J0J|oT9AmG ztyyE77;!s4gw3=8(Ex9IcK{VlN>OKu@MyHGsg5FqRo!se@}Xv}L$r9P>YK^Jug{4E zsi^8##j={YUW0|cs)HTNa@MTQ%6ydDn+EwWr|ZNgFhUiaVYPP*W~UXNPraQ|oFbij zq6m?#D3kGnkl7M&cJd@oV!ejAT+Va4;Kr~zwtWH&~ z_^?sU;7MI}N1uOMUXdbL)7FX<$(k{I=wDrDc6dj<3wiIuaytTElBNfESdn#>JT5z^ z2al%DvZG5wO`}5N_oYN4X}x9)9TF7lRIYj5n4ipODEv}01`txC!*qBU_B-7p$n;%` zN=01l<*5}i$jZoYP@v4!fji21?DdnKfa&T&rtOjpg;LXX>HG?LxOgzyK{yYF;~B); zVY(7gO+!4nq1j|ru2Ms{Ea%Z#bIB>tl7IPh@N_wt!OR?{gBA6E)>6$P&PM?UXcpiw z-R1}LIjT_w8DM8kDP+!WQWypu)U6t4XcOiv$&qX-Vl+~Q!3xk=(kOoD6bRrJ7&S|Y3fu?yq81S@nw`$tb=V=n(uc-;oYQxD6= zS^>gHKhbDHjY6S6IP&vnWk?yGo{KxvAz&Cvgba=1G&E?(P52o-*%lW~4Q zfsTSRR+ynqyTNMTB#%OSR?J88Y(xLZlLY}oyi>Q)hHjK&@%cNv~oOU7KH#z2w54C$Vc8El089+nJ_grrs!?#!w!C95~$9@nDSS#auF zZ|G%IYSVmR6|FVr14>&n1{R#8=6q1|p^EacZcg0_gJ#W+qEK$Er&Yy8V?C`YY8;Yi zV;%Gc5zTYG8FW2W$11CZvJMubzgb7?s2V6Zi|Q1G?FLn7SWUF6P7{CMR1<>pVO^)C z@1qV?SMV`nMXO~sP;eS+H%Qz$pXGYMY3wz`!urz{avtx?>T8gU2D?Q&9M+U}Bi0Kf zVc3CT)UO#yZK$G?(ebe3r*);Fb3v5{qoK1wojLx7^+I89h8ivz_Gz?+WWCu1>x*J0 z(McgCtp+ofOGZWGQ4#{aP*Yh$>se`i=r645t%Q?w39kQo-hcmoQobOlgtsI|xE9Y0v)s-7Gxu&j`QC}FkH1`|TNo8&L_!3gVLc0w~!)jU= zFoP=V0w|U>t+)!N>_rSg?M3y{ZSdDtb$)1YU)QrWKC1Aj^F%}8i>BTn4sXDTfwYJ8 z#OVFVVld3MlJ;KI2UX{QFb6}D0EL60ww1(ylHMpO`xIt@&QWH>!I53nJYXmBx`pr)m^xc;tT?~OrOOY5Y z{DVtb;3zq{RkW-Hp6(}Z>D!B4ZzPtBA#&TbSn^hYTnlYvOQ%BNE~yl*(thjPiY-7< zoGp`7j}XQ!{l7=R(9VdMpk{ktZQCcA5ggeU$q#ZrU-qRn+fz&Dio z?$FVsrW|foa3MvOV~Z=ImK>22`MsPG9^nT&>$=as38c*o(GuB`9ibH`?KQD*8L%Au zPEfsCSRGZ3V>{YHoO6GRm(x^J;;H-@JxI$r3fqb6A^H-Dq%kk773%6YbuOk z#BaB(Cg0++#WEsobdNh6J$Kekv(AW@{YNH3-%BSdB@I$gKufv%6$N0FG>GaqRYakq z+PK3z4Ol1OqcZi**0bff#qF#`1_TzYRjbfWHk$32Eihj;+zvyW43K>LJk~eIv32L- zI3`CqjCyC@F9YQmRucSGjh#B!ox0Ajj&3%t$EuEMHiEaQaUhL?>Mcr};CW1V=L+Ee z{f{kl*DyAfTS4|sJ+@XDFJI7GbErQOT+a6?8m_5Q1JZO%EkP&Raj8=dlEF>JRY)eL zzB@Be(bV1%ncAi)s`C)K>NgpC+CLh_a9_TAkkxA(jmk_80+dEEb=W-U`@;lcgI;QsfbF15vKrW;EQ~E3N_ZR9 z48eAY{})7`GbW|l4lZG|su3CTL%Va5@UpP`jOM%p&rSWbAb^`1ye%|8m&XH@{M6#X zQPdmFF!IS@rZl-jV8t|bwn9Dryv~S9(f##~Ea-39*q|7-AWR*Nkr`uZ)HXvZG<9p` z{g$JJ_xm9RzO`!mhk~T)VH%r$@HImqm{oN2Fvfg|+98z+ z`wa4?(0_yBT`e7KDR+wKpvbqPmpx35k>EiZZ@#B7-%nVHQXR@9BpaDD899jDDJ&li zs-}9*AwWiscc-!*1f`yVXn?TPG7w3LOC1AO@Ps8|ze2y1Pu{_Awo45wSI`D^R4`PA zU2-_DU~8*u&S42$YAcV>sil6#E4F2+tsGJ`m*_W)U`uTpSCGb)7YmU~$r(1|smNnv zAC}k%%4IFmGr#V>8&k9)>?cdz|}O8G?z_H^-UViIF)} zD2Yq`IZq5CcZ)%uT~jX~ZXJ0}+#v1qC<>4(lbm7nj4pG&f%q`;y2b;Ik)6o^Rg#PP zoRfXUg<3RnI=}LrY~qtasTKt?2YrF`h&ZqF11)+QWL~xE$a3XwbI?P=NxlZ^5>1My z14VL_usBLslypM}lEx-03=9}9RXoJOb>o^Hd@}Aw3GyXdl!HjG;>d?-E>lmDt(U(Y zkt4=g0W5c@(KDYaz>>kHF_dMIgn_g#rLqk;5693FLNFQ6Bx?k9=66eEO&-k|ak`Wm z&{;P3c{B8OYBy#u^8}rX&ik@U9ODkv1H7kjQlK74&a-}Bb^(MTP;r9wkEOTB5VMXJ zCC+0z6?3wY5SX^w7lX`aJP$#ZbaL>++0BSqfokJP@QAquojX+=IG!H$L7tK3a?}_b zAIc7xaF%D#1?GH`KgWvHa2HF&U?cjvAxisneRHDi>mXq z9o85ylYB~!7kp!Httl?YPKFP6)0XTIR@*Hp3^uE+ma=dHXB-)P#xnFe=p$ zeKuuAIqHmK%UNODxgvFpMmwTA=g>NiI%*^6JDc6Y`FhbIoKZ&&>*0Gm>Ylwq%Dzuw z3CZ6Ee?F4IaopK;7szlP&B3Rky1xk~Zj{)%{H#Gmb|-zo9=TZExeo{Ugjb;N9GBqO;mcNpHjUdT@R{7p-qOO@d$jU z3zc-FyoF)!JmU_v;tX>dt)+2`b3Q5ox)1lVX|HhLco{VavWGhNS?GUcsg+)dK4&OC z@dI(OItc6mM(!cmG9q`jYLfy%H-jk*aU@%M2V5Pe+@WUBjvQ*m<>9)C@pTm=wu>KUYuU8#y%t!J>QJu|H(nDb|NI zESVf)m$xoGx{>eHE`p702JsjIqqmfHgl?R2HH4*W%e@RP&#lEyi|IoukyFqY5u*Fv zh{kcSTkcka{lR>#-Xs0qU^3Isf8H4 z{+xEDVtm(R4qPF(q_Gh4R2uvsZE=!8NDfmDN711TZ7hl0<|&-`Zt7xlX240DZ``!^ zK*iNAxc5EZdp&UFQ{4zfLk?ffDvvu%jA!XCEwZ8_@Yr*gHeCf*%~?qxKdeLpXfTxz zD{I^nv6F%Bd|P(dIw^W#5p`1Z3Q26#keCyrQLsXi*r>6@7lb5+c~v7;V&f|aGpVVA zX36s$?7^8h$<7nb-_nI45VA*t-~qS|H3Vk~W)3nesBsAua++y@BZZBD02%SEf#&Xa zD0our?&J)P$e|Wh5pL|J?!lc5PAuAS!Jc5q(j012ddS~8m9CmbsEmhZDhHv)KsT+p zSVB@Xb38I*)Ceg|G(-!Lvo+@kH22mDm1Gl3c%M%4n5E?-P!HF)4QfuH1TD~fAH8g38(fiby|}*3 zi0m*-G^1E?><)Eg4?-CbMTY1UBsg%}X~K(rh8SM88ZKx=5y9TXaAhLc52G-o)HkRYL9j(qU5QQ9= zsn%IEiHUf|B7>Rt#)>jV5M|_wvf#{EjN@-4y`cyMJ7?|R;L*#-2t#?Z1X0Q-!B9Ih zoevWC1;a`(<)?=NCNo_}*ul(1pTgfV6RYuQR~pZ@=jmYSqNb!7RJmYQ)~2%qB6=-v zxgD#O#dx4sp$xZ*B3agEf}B_5__s;>mFC91@4o2r~Zy>I#u)QYCUB~U9s zgmj?RCP&7c+h*wzf`@1Z5REhQw_Oz{F>+UlNf>{!U<#I>6;d!Ogv(rT34!tQ;Z9;G zLzy^z2*F?%Y}^fkiO(^V2gJ0z3x=4Dp*%R#G@x=INJ17}GbPi*(}()uV^h@`D&>gp zj?i2OBd!b)RI1Em2#`|s6hnpY3kE%V!M>m08jJBxJ>9odvkhHIAR+4h4k;W%>jiqF zV{3Zr(1!j6_v6b$k?PzH6o$DYZ=xCQ0vv)WJYcAQsTwwh$~Yb358gPX)nX+lx|YAx6NK4 zBP3f@BQ_M`l!4zceO2|+66K*nBC?u77#i7*t*4D8erTgsDOY-W8#jOs*#2?`gZosZ z(ZN!(l&hiS;Z#~DYWhuObIb7vV89VS`ia`UW{{8BxfgAFR)F>t+KSGJ+C=@msB9ta(+IN^i!ML{r(mm!`F#8^$>vNv(K2OVj28NL#tupwlL2-^9ZlqaJiAC9iCAfpjx+a?DcUpZ$9d^20mAplo*OWz2g4sCL zMT|TMxT6}^kKZ@tKY}4xQ#K$hXr}J;4JI^exj&(+SsVI3*4K2tWnz4FZzv%yIJ~r< z5f{3({*C!6-;?K~PQg0QrWk&nf1{Kb_=DeLy|rS#DkffWBh-nw!G4iksG*ds&)>u& zoMt!W2ZNnC419pG%J&C34?tXN%0I3X^HX7PShHe(kDfm_F5g%7WSv-#Dr*C=f>drpyi4HI3!jWF?r^9zgK^E?X7JIwuPdVT~GzqsBC{K@$s ze6uO%1Nq|)w_oS^z_VX`b&8WWd_`&L3a(n!52GFg59bLbObj7RCrSQ(YR5VL`WLJl zSHY#58lSYH9m5W{f*VMSS3{e5#{guFw4xh>teaL4SE)7(tpFp`|DmCfQ&Zkn3w_g{ zvwL`JsQiSYxZjR6RH19i1G>*SBf`q?#Z(;Tj0V1-JQh^yy)*(-4IDg#cYScMEzDSF z*p_||8ql_I7I&;2y$>8i6XQ_X58;6w#rJyE9jk(ahA79s6X#R~U9h^X=>2)$j}uc* z1@slZG^6tbS#!bXJMesIJqI*~`@_)Kgcs(&?|$)pU|=H+P^MW+8p`o6jg9rRq)C$Y z5tL3Y`t#?3xuankvZ^K$7oLKhN>=Jx2`kCD^NX~8Yy6}l9bBp@H?Swyz=@+?@1>e( zI~^yY_k&A_YjkocWeRt4C1qx5{CU53K$Tg;k5oD_0+G*o1Ny{#l&ji#BBIKj!R>UE zwa&h9ejg2#RwjvxCkF4dV$A+CzV zs=(kyxB{bjV<45ZrS3!w~8t!Dhx>r!?s_aeDJQcA+iQLPV?9#MOc;dv1 zvN6wkFvPgSnJtXmiOjA>Hf-!rX2$}fGn;hagfjbdyfo;-`8~=h`CMG#*L;LAHg$sB zzlrfAr=cz2dxj}NCnSRgpb=|nE)%Qy-LZ;8fc$DpPnEPLG{+WH7G@9$H zx)ED2F`n7ARr`_Sk!BM=n&d!c(>A=Xng`bLT-64IU+3aatVh}JNOOzd_jkXxa&0H( zyYG1xSU38=&VN#lK^ei&6oO_8&U}2Nh16`$h8?Jqj0ZI-)yWuDH-x>;DEX>G75Xs- z#xB7)QRd$_VNkx`AgMFozF|ki1(8M(Tn>VttFpf!3*+ie2*S3iGh5U(#m5(LvdVsfuul3J{zkou z0$q!BGrCTIWi>juYCeZ7t>@^d#T9S0)C$@2s8&mXc6e@&tvFNhU1smKdV4fcy1p8wSnH0S$!@m&-bxKsv3ajos_WHZA-X=obpgZ^@OW9ZB%`(zaj>R)UVM$Veg z5nO$L4?AOf&MdH2HZ<;7+p70dC0o5!LqfJXggHOSN^3%c*+{~6D;nQmot2>xSxRMy z(sGZ6G+LG|8JMAXw_s7$HSoQxi87=C9=#v3l=Ou~%B;EuYw8~J49QtkS7L39FHW_# zr1z-`N(~xn7OV-J%C=wBXH+_d`DaOacj_Nm(a8WGJ=Y1aA`+6rIl~`RE~d_hFAT{7 zORbj3>)GOp(ua8aP8~IydQszI4XQ5QKU5)zI&XFiqyCXKuYT>Qp7&c}sNqCz4Xt-a zx8(^g&Y${7wvJl+xpjM{eunoK-j}qxQ&u>F7o=m;`+GkahZz4W8|;<5ZxikhWoCb| z%ggo@Z{vEXZ)C+K@Vc(L4(N>az{xAO_NM~QicahKo_B+)qNHdgi158j=@HT&lw8HF zNr_pNtx6wZ*Q<&zs1^@`9w=@8&GDNW4C=Z49xpY*)5NX$ev?&+eY8?~=z7i-vUL`$ zB3)I;5Z&T1FcQ(6)@3s|(096;2_lQ!I-TaMN_S5PaT;l-ZD&ZjS+eApb1}g0;H3h% zgIhX3&uB}Y<()gyv0M5I?4c?siFs`RhjcdkkagK@V#mDiRPrLUa4NKWWCwHFNmMPl z6womhjf^MPB= zp7b3!rnVZT1IJV;)1O14W{2}G4I#&;j$1T8@?x&9N`mM2EA~&7CAGhj_|K7L6}J?1 zBtinkiEYvCY`S*V!&%SLt>*8kf#_DBh*5GJ<(*;Tld7#8B=vUHS3)5#huHwE=zT=Z zAbZbYb`!&$?M3Tvn6JD;g_g&Y{k6-2#Jo_btuqI`svC=J^=e*IxFXfNE(^CXP*|TeR_(0t@R--YeK}%k%l< zj%>o4mLlxXk!`Z;{kTP{rK9&%#injhfp*^~mEw*qod|o^QO_3@t4p#I_h*W#7QwVk z@q0t_zy0i>ck={OujhQpIaHrkuo}MU{p^4@BwG-JhNy%IKDf0UFJ%qx@6@elSG*<8 z`qW6GZ4G>*@r$PBXC_-)!m@4;!qjtF`>0F0!WUsy4*49vZ<4lf2f%>R-rif2?QH8g zH6T{_ZIZ57p_kI5IxM#SitC`K zb3IGmfD423UzpbUO}N8DlyC)&>hkJ4#@D0$o0844qA|7frS}JP+ALf}IG>XSX4gPT z>r?9)S90lXNq^zkUDCuWC#!w zt#xSo>V&D2v;I?)^_W$x2+#ZctcQm1dnqYteUjwNp#NnLDU-C$_j$u}y|5Y7r)ETg)VK6SKHu_bvW(M_WXbW4Y_&YkBMQKJOGpk+zHZ6aIX`}X-;z|6wuj(}%B%9f*xYqHH#7Z+v=Et7|ezemL$X`p=!-7(OhF=Q)bqz*ldq8W%VOt~OoohWLN zI?QHRkP^CR0^4r&>_Y{cOmCVG^raW}{k-qPUvbBS<+4jo8n9gUs>Ws= zbU-fbYDP+1bI%51&^>xKScCUQ#jaxgGhlY>f`z7=tZaSOv{8hdH>r(@CeF0yV}&T2 zn%YZ8nC0`l=zX3TtyZe(hla-K59s5hMyy^_wAZs48EQOSjD&2TG!%iW*42AyKyK?z z7`lZ)b3Wh86F{i-J%Py+RqvQtfw9s)Cox2Q3J{ZOUF{%e@_jXRD4M`I;O_pVq{$t@N>9ZXz5ke9@gejS_dlYQpi2*F6 z*Q>faRonsDC(y#+(i{{ix_5Nti85}Z%T_&6Ridx-$gnM0{S|AaFQ(+Ps$_Z2pvdQj zTfRziiKP{S&)4(pKvQpyN!^99Rh|BncSl>hvc0chXhv+p_Wzaj9anb5N|yU?1ud8Z zEi9Pzbi2V?xBF9wD}ZEgcq*9rkPv~;!rBJ+pi7@*2d!=|sh)Rm=B?+Okt>SOr0u#3 z9`%K%^jGfjlwX=Vv}B8C8@MHHlk-`kGCbq0NDp@eqyGcii)`o8zfqj^;{1ZQ!gPKm z<9H^V0fR~{(&h5JkKg-yb3J@%ZsDXmlBNB855=6rrm_jk&Zzw%-{tzIBt_imIV71H zmL<48=Ow$P&exJCT3^Nd^gQNQ)X}VKy?#IVM!oOH9jf>HF<*6*L>aCJCRLUsitY`U z>aHZJ%}gzD9r68>U^XTDp|{_)y@P73DcRmV%ow@BR4{5svY4RUwc`b&2O2Pr30_@( zZ}vRvvdXdNnk~7^9&7SWv8P)Tm0S6FUfsj33&Yq$jXRu`$<{@s-t4pwyyyG={9+t^ z5teLF^W|FY(BI^0zsr1=<1OnRl`#2uR{|WZmfVjmE(992OtX@nlkYb@m#nVmPbp zsn{*?&wFZkM?v31tJ*!DQo-8e4+Hcn(7WkzcTKL zs(Srh+7zj@*?4kd=ko7#pYkm3K7}riBoBDcP}m z++X_wRrRje10V6JG+*1Q%}`@oY-nD$Cnl5>+IS0L%AJ^DVU)Ux<`!Gvkd~+Cv|cZqu9YxgfUDJF2b1m{P7R#{i6KT!YGyb>_@#)1D%wPHl#bk z7PlswvXT^w<8}G_E>9Q|Aj?qX6W50bZbep+od%5GBgRCLR8$ch=|tnT{ZdU4(n-nK zkYg3yNdfa>pq{HpVA-Dt^(GsxYBwS5&OCzxyS+Me$yx5F8Nued|;$2@=Ww8QJYgNK9GXSa*TbV&nRsV`U4O8U8Ov`fb)5=%R z`S1UnHby5?Izy2>;7QnK7RqUQ^we?AupD<*AkE0Y=rkVY9QlQvc7%-bDxGfV=%-Yk zm)B>gJo%xZGa23~HP<}g$?m3=E+f2N6-YB8H#_|(87W`A+?Nkn^`Y3o&JE0P>vifq z8D7n<!?mwsEBkd5`ivDN9<%5VoLsXD`3GJHmON=25x9p%1!%3e@S%U}S>v&w+Fteya)8>@!vI!adU*#Gy z1XLA~$RO(XY1mp+>LEj;Rmp`6FJ-41oZ(AS?T!pHwo0Z1SX_W0!{d3c&gAk(C3tR9 zx!*;tW?rmd$-`(C63$?BK!%!be23je#pH=9gJF&t(u{85FGiy=MrU8d3>{dNFmhF~ zmMIYBXZ*CrvGDu{*OUxKMf|!xPkDxe6=nJZn(ov=G&Fc-HT80kwmyVe5yaHHZo?vB z1)*Vul`4FXwWuscMgx)yW)gH@77`j%79+F%3RR?xbcjy=pOJmgDQ;!dhwkL=89kD{ zUbue;Wl@0?#xpt}iIV=F637HD?N9W#JM53~Fd10@o#v|y4%;a=W#kxiDjug-9y%g` zEce9S;))|O%UlWl^VB$+9k0!#&^)J8pvq{C;aQ;zb)R}U{FZln28+4imI74yp$zZw z5X(kejX{fQM#GLFE{rC8qiXX4mq*oyHh&A6)#Jd2h%z?ER0%#-qcG^NuXK-3m{@e2 z@YKkGL?*1D&YjhEGt1)8Id?`r>|Qs#NBl__HH5s;saa%5BW+*s2)guCXXcD7jSMl9 zKC);c9^m$G>lq649X`ySFCvw7*$ihz0X>!B$w(=eMd(A05vF z-~BQw+jHY55u8gz)u5@Zovfk6p%$Bo5S2o`?^DMDA~m(snS7(5OOEw&#)vBaU z#{DycV|AXY??!!z!Ss19(CiO5HL7+p#DHO(joUejh~HwHgSGCVj4UJ#Rlq#D2M1RX zFk+oB`WFq6TZA};AM`&D@`qU?i^Y_5rjL9-LR&N?MfVt0Sjz58!@Wd_sjio&&QKsu z7;73K;F>v(LHVA$rAk++en5|mvPcj^;C?mB9%xk|t~3_85OKLLruZzDFi|9mVLKVU!OV5wukBO6)os9q zp5~*OlLQ|H8lrj5Jzvx*qz~a>$6&!N5Gkbis2o>@SJTSigc2$t1+ATp4k*muX?e)V z{^>NvXLPMLp+T?jPG>=ed(tP2%$~udg#)555$iK$@;hMG$~^xj5Iv0yu61cR`dvt% zJEfdZ%&Vc*RDhxW;sUUcBjfEdx>|MybaI-OS?1=7n>JuaO|hZvK@qvF%>zP!(xUH- zYI|k4H-{9f*{B`zP#e*dxD`&w;bW=PN(UlfPRZ2p1E5UB0atKSkfKuurCo6`4XO(m z`&5yM<}KL16yniLu7riEGw6W*6FsNX3J`khJaw)P2z4T?Z0A-%LkJ2!Sw!e4NUa12 z(R-dcU^6N;{SCSGbP39j6c@dkvLur^{>*$?;EE5GOiI0@lT&FV2?=d-bW?vnaV|>Y zIpr9+qIg(6uN^QZd8%Z_$T%4Ef0#rz>_^33ckV|Nx;~EX|G7Hc}iMs(0c4mpY-`yenH%b-#9(cf5cF_HRwQIkJcVW1e=@G}C z|E?+E&LjE7j0X-%5bz*^>wA;uJ<0?3sQVVM#Qe(nY$8+MFI@FK(Bm428gS;#o#TN^ zpn1SH=3zcG3{HKIa5;w*aIE(b6|6tXnVlNb`rd(2>pZ}-+>>I*ubtIl7cLkVIl!~l zIsB=!G)O}R|NB44LuT;7&mZ)yt7`3i;+kqWI)nbrsF!w15yrk8)I3>0G(0j)E4vgT z`p&Up*UxDe*4Hf;v|{Y2Cw3Nj!ZT1VENI0JqItl$hMOUGgQS!xXXjgubh_br0pa=G zBNRKUGV8J|3r{S^y;L!@Fbbj=n$2;iK;E$iPhvnt!c!7;4mS-iP>^R7V=Ge1CW^6D zX(5q*K8axiv<~zU7+ezkhZ2w~o`axGkUNz|I#hZv;Xjc~&vg^>VT?HC=vjX*zI%w!c?mlaprqJ5ZP|G~HkN6b2TnzzcezzV}N=4;w6+?`fYtd>ZB8+>s=k=KH&w zd0Mjz0rbd5UGx1t-FzaFG~eH2%lkD9pq=@&MPf($^riXs6&2UE=KFhBPere!`TlNX zIT=#=-tWaPrCx6TODLkck>>k*g~~CsxBa#in7HC=g4%;nr}zeQ3Cnu0a^F1{2gb8TAztp3u zp>V(nZO}E}U&J}t0bBDe3$fj{{7l5&>wCXs=R_K3&G&a9C+;?DzQ1JQM1>a3w^YRN z`FkZ|<|J03y=_FY9@3dngr=$yVuo4ez%*P2YBAE49Bl-Q8Mn|1>$C}V;rBX07-H&d zGIgTUvpPIxguNe_7#~)zs&1JFK0TP{y!NdlA*kmi?Ok=+{1e6lMu7reSy7;XV?8p= zqGZZ}jj?CP=Drvi^JU5^DM-98qhQAGZ5E6DT*BZGBqOR3aKrvj&9D8lzK-Y8_It;E z$`y!G&2<{XLd!UClE8lYKhOGDxNsgU_pvY_8bAH~K_Q2#PJkDT<65CTRW+Pifp>ND z<13PYs`{m`rl+yhtAgWGl17`is&*m^H%V>Z&_J%LZw=JLcsYTiH@qC1Hqm)|Gh}pz zG39`RV8)ySqvzI&LJyl^YN_fGhiF>{WCeJzS-s2H9(>bhzY;#g#K;w@a7&DnTu4Sw zRIbr|;DFkzDBjF;l?88lq9TfYKH#S0#mdZqbPVWBEaU`f@6_nWp}=vU*z}3ff{80a zd)by4>c_epiIIXV`;cfaK?8+T?>RPhAy_>zSbT-T&=L*N40KM!eB2-p#jxwd5X6Z{ z{Y12%NTE$sA|^6)(@>=W^zh*J{QNe zm;(lOY}nQlT@C1c6JY$dYADFZRo{&h-rP%iX{n$kmRLliz38)$0S+8#;QK~=T4Dz4 zMhLH3xG>%^5oZMsj~u%(Jk-F`pwJt6T8VjOEGyxssQHzsFrY`_9STuliNr_Cr>PmT zdsE+-UGyO-4;xPd(a^Gm^^)(l(_Mf@SS>9dN+1heD`>%Uz(FvieOh=}_#@M7i>6Ws zT%1*uA)%9+H7qit+0ixY{uWVjnI0arV2kh8=g79y)4g@I!ogrMcbB=yWv7)iFLgo2n!d^8~)Fv*~pxch7|ce?S!+(}QPTM*s{pGiFFruUI9 zmn2CfuAM>g?EVvL6@2uPM9P>Gu}+d(>LMNBI~QiiYG_WFL9}tpndGx6_yWZvl0#w; zmYtZqlvxHk$^D3q#?Ou->^u$45CLsTev^a%voy70KA&0vf^L&IHOQU`TEA#QZ#)w&FPo(1`RNIQBz+EQVYr*?Ad~nfis}d-5S<1UM$9pJg=jii+h$ zea%{uCo>}rLfnVZI4vh@qKNw1py1xZVN|I*tiQ`>c&s~HzVJLHzu<&Xq5JcG z?0~E_`aMHBGin`0w00&OcP!n=q`)9~GEj@ve2bAwac33QmiBGPaNu~KA)*Y5iyNaL zxlx}RRQ|b9g(TT<(RdE;;`f$9wt{Bsh86NV?FZuTgAY~085qkz70NjBuOQabL_ag+ zH#ztWN$6=QBoO6ck}Uhh@&|5o$+|&|DNCY3U2$RwB1l%)+yD>aes4)iZy2H3T}I8m zv)=L9|1Q}%*H@_f32RQwAm7-lxWk4?^At~5$p&SAK(tPXE(-K&fUBZ;(j#JI#G{8G z)Ch|U2u}Oq8Z2WhsUsujC{|S8=UTCTKW?m1#T}(#9jQ2`p_Ou)oZvM{u4`H^pI7e( zFeE9Ii{E1~6RcmR;gvLmviyP9yB=hL1r5~iXMbo8V&P)H2VqKoP0s^kMI(_3df-mC zOhsBe8mFEUCsmTuxFYrDj?i`DoFR(8-xD61agqhNLoOtYLeok5aWz-t?^$NydNs8Fyc%DiTTPt`qdghq@Y*#%*} z)poT}bZ<&|VR@DZ?=7|8jMh$UG=vo;+=8WOl3X7;aN#{)ShCxotn;0pvHqOt65c~r z=u24QGsus;nmeUU7CAa$C)6A`BbF~zY%C(oT24B%CS8Ivwr;_Ai7wtYbS9h+cW7$9 z%~2oeN}K1*NSilXCygy7sw-ZDU*H)bAt1>zHkRa52cb+z{8gRppOSGy5~)S9ce$jX`*0Bay*80RYqVmX_&ZG6KS+*DdfUC&S(#$ z;XWD(n**i7xJnsx6ymayxNTD~1-UVHXz~OU)-;!}oI5~D<~SFmZYM=9PNe;rn@`G* z^^Vutb4w;q#5=e@HU&meTn%AmofvNALeikQ{o*YddS1nSfg!8nxw!YTd}m(~H74*v zSp2RAw5skDPHdHrBF_MmmcP*{Ehh!!z_8=zuR|2b09l zRAoyCXcXI$IM2>9907w_;?s9_Qzw-~&!Vi>p*Q7M1ygSn4A-4JJKDu580OQ(i?|~l zyle=^26&}Bc<3%~`|I&92Jci57Lvse44mFUP!IgBkQvN?$=h%O=xu&^CmO2Otzasc zxGt~V4dZtetIJ4sK4%!k>N2|EGDr7sz}x{)@;!wE*nz#iyb}uZ2c{MY9N8P(*yC+T z3o4|GqNUD*MDd5I zUV&(9d9Hw5235t5o*52kMZtSHKsC4!AH|HWkU(3?rh1se;y(>v875YTED(qofBo10{S!*% z|0p)3LOA{T!}bqVN^(Q}%qn5Fp+8uaV8dMQD#45GB&yhS#JQws<+%0yY?TzGlk0s5 zLUJyDWD?iZ^?kS`MmhJ{aZ&knfhJIlOMy4$K z1y-4f0^Ta!3pnP#?tEf>Y7?6aey?W6=uclIsz zHbL-~nzPWIy$0dqgVAhK%_fI(#S-pxS{YOdO^5bbMj8ZTTm2j+PJA9B03 z4Pt&>?;}Vq`+P!z4tPH2`@%8abH4FC*CHtYd=KZD+dbcNep#8?Fx($lt%zY*J1Y!w z#`4THyPCnq7prow6HdUj01`%YZgTLZnyYgCgVNVbv5YN-YOcx^hY*mRJI@ul76HQM zvZ_I#ly8(WPK1d8%$?@*eBVDeI%j1#1 zTd(~~cmHx#spr3cSco++xDf8ZXjZFO!pJN*_Se-T7S>Z$9V3#7;`|!nm~VULlT}Fg znXfPm<+oX=80+WzQ?(K@Fxcl280Osmiv8{iCTH>Hni!?PCPkM9qJLVIACpavs@zo% z44Q&+WmRS|Ki}Wq`$Poif8Zhv#dz7-@m+U>7}a&BhpIJj#aY?*87n4+44j~=4-CD} zY6%b+va18!Q7|@iH$oe1L!5^P# zQrmRYyQs=!=0f~!X?>=nEziA>IDV+8DJ;~6f^pnUgSFkOBPDX>*> zx`tI%N3g2Sv?5NrKJV8%-U60^&g!{pr0Dlef^;;R1|Ekxsx!$nN=4BvjL0uWT)^dR z&Ae^sjPiK!{?4H5%<6i0b*rY7iDyov0FA~F$gDat2wAOJb$J+Ymy5f`t%<+%+`ySvok7}cZijX-D4 zYa3e#X0h~%>e81p)8Us?*>!bjouUEE2{Da8r^!ntm$g{#Z~mJ0%(ZVlP)a2t@k%>EcbiJ*2wRTufDW~G(ONQB(PfFIv5G-7gqd>k#tcijIqIK zTjd51ct3mq^`)=1P_QHozMmOJpz&;L;`gj2Z|l6g0bBBUG7Jpk4sCH}?$DO)DeHaO zejrIK+lKr;=R=Iyx)D6#{naQJt(Vg9G+w&nH6-B?!?*1J-XGdYFrS^o)o=qh`L66R z$V9kyn_a&Chi$tHFkqWYf=1FMY>eLjSgLl@4e9g*5D%3OGeyDUds5$;f8O)39=-}fbJr{{gs zT#lE^9giLY?r@g}f;-wRtLgU{vfT9ZvqMv12W=1W=?HdedwzA=O=+%b1Y1$SCHBIe zi?8kd(P$cyH?Dnl`wj(;_LQ`O*r84*yrkWplB7*0TE_q2mWKnhBVyEaw9~C`uhll^ zFPb6s9nNq`S|nAN)<-5`@+nf0A8a@bz~c^ox;bl4SzZ`Fr{64AaA4A*w7>8W%rgkA>M2Y12)c2;Pfoc# zzekJi$((mju8(ItJ7IEOub;L6$I)6aNdYLvac z@6*oH5!YWci#zsY&d>erlGXAcT-Uo^YK%kcMP_K8`W`W4>3nH7+WI~@?bi1}B}&qH zz)x9{&I|J``OZH9E=&7e12#UL{VrMaht;A`R_^fKS9LM$iC#kYvgxVI(;l7ewPJaV zda|dT7(4Ww7zCYBcB78ml;`;pry&&}=VHQ0&q?C}19H}Uuwob!suC(XQ*z`<@7MFr zFxC!oK;QlkzJOQ&>T+7IH0_lq7C(4o8(ZNL*+ICI2ZSjax9-SH>l zf&BiS4;9n==G~9>Sbch?{$PBf^;&$tkY=zF{edZ~;rk`&27@Y=r1RW@$;WXc%ayHY zsYBUbwh@Nc@BBiw{qe>*Q+3FBVEX~jm}Sc=#^+mJGr;N{81U~IsGFs}sP2x2Wf!6^ zxR(39fThD-n0`g*H0pW<-|e|osPF$1p2ox7?-vc{4=j83g_Gbjp1L>%Jh3D4HXpjD zobO5g1Fuz21|*MnPESSaN9ISVkxe$bFkydH#t7xmBR z;H2*F&~Xb2YbiAJ>%167SiKMp%m2`EYt%0_;1&2Foe0HsIN}dHrxhoTFGA0(Nq)1U z9lV~?d`FaL)EyoK*T-|(ZgHE2VokNmQq^HetK)idmC@WvRrG{b7(Z`WOm?%J77=hp>*!*gL;&;DE@(-UiA)aoj9(Z z9^E*errn$t=Bz3&?C31qiI9APQ&o5@)nIv&uYR7nmn5uJI)>1x>fdko)b|gtA+~T z@f^2kiE8mg!OQOW3k8;BA4ghOoH$m1lx=rOVd|Z_k{p3d>mgbxRCU#DC?9b>EQq_Gh{Kic!?*Ydh9@lRg-y8M|4#-dF zOm$XFP9b~gfDfbCn-0s3dw-3s5yyU?&-;FQIqz6l0Tb8S@SWh9F3TdD@W36Qr*#R( zxuZ)sELTObjr80Wr=PZ!MOhKgiqyPX^3z zsLu&3*x=0>SJQg!_1g2H>#J*jnqbN{+>aqTNt-!2tNpk`e1kp|*q68r@IzHsNU@-+Wlyh3wm7eVb{=bFS>NLd{C-fuB8{u3rY~>>O%gxtqvRw@_Ua~1 z1-lFsa!Z$C&wMnD15N!~!!HHVBHT+Vsj_mzs z##?-YD}p2;Y4^aC|GVtVl)iXklzy{pmrFY1(sNQd?g-KX?};s)=+^fs|8vJF3Dj#F z&HHlZSReI;*E(DOvF=J*?g(qK9y`$QGMU{0~b}Ct)Ytf$5Zd0@)Q&g{#rW>HHJXow*_<DNy%*yFSHuS!c6JQ@AFpRUem&?9quK`cIf>g zC#6N1(zZO?#nQC*j~dp}b6LvtoH}py^Y-9y$;R16Se#bRNmp&*<}C#V6-sBc)5Q6V z2iE%azV@d+9*Pg$-O{*tLrmvc0H}k+RwP~hVk89POV=)p9n$;5p2fa_7~#}>zz@;9(lZ2BehPC@9r(VHrswM!)Du1oMLU_E=@2g zA+WY~tpMD+VN<-##Jmxn>^{vgw+7W@F;DnW{t%Wys=??f8Cwjf}IXm3z9q(Xqw^s?$kb1-h+yYMfh0Fb3y#IXv;7qsQ4fAR8tlsr; ze6%oVvIU_B`o%#s>5LO^gyV#rpI3D2m;7`=6`bD(i+PjJ0NprhQ@n1kqRLz!ykM-n7G z6H%12p^;;(0Kb^xGh8t^uWx;aPI6ZSPTiC{)Zv?ML*pT1QFKXuH`6UW7hR;^ug%Ag z2aK@aZUe)4qL2i9C+Wp%_A4&kN$v>wfPC+L>-$aFcieHV2YUNGAy^ZevM~DA4IP4G zd_}`Do6mfNUcA=s^VsjI-!D<^Dlgdt4di?fvC?dNYbeKE7uE@!I_u5OysOXUa1&QoOTp(TK=A#t6V==U`&yhC~JP#Plh|W^9xJT(fiJx zgC(OWCLb+OYf~PL=4T%g?B{JgW1$((NFqXe>;@sCu28?3%V$&UT zc3|wsy5A#4`+Egk#o2zbzJ2E(7%6)+ntcYW{T}t>5&`8mYiXq79}Nn70I=|zS3WqG)H+tC^&lWH1l1X^GAocd{aIu zB`xj`@@$&2#K+M7I6sp#mE#X#Xw`TXTyrb`wgW@D@^xeX<$*yT+}addF{Zh)&hP9; zf4r!{)st=nWZj;0-q4|&@}9;PMhoL+f3%sCdx*G5^Xb_nxjCDWC%BaDSh3^4`B}y1 znN3+mbvYhP= zF5JLVxc|gp`YR3`=PL}FD0NxoRi22Suj|e?^lL>bOj=GAgLr>`*Yg>lH_Ex5#CT`Z zPH|o5V)j>#n}}60#hJ@ejdMrmbK~ZccII5ux!&_$lFR9*Uy@Q(6@Xq`HEnH+TuGAV zh3y5Fq?-woM$#*dob;yr-vy6aQx&8IkC(NzMX5kEcU4QS`hKGvSikdeZYU+=tXxIX z)G4p?*w2nH-gs#m%%yD3gzKWISzhSRiLLRa;cJKoI5$!D6Tpacwq~$Mll%2bf7eIt zR5xHzJN0^(wdF#%k3UyaSWEMF<{mW*XZkfrN!yu)e6CDB>blJPO0rMf%tw6RnUZxq zJa8wir^@TxvED7OG`01n%(wxb;@=POaC@ndy9b*4gIvE?H`-Mz;1{a68fREFV`j=# zaYbffQMVD-+eLS9e_+qJN*Da(3i?j&syjOLeM&X_-j&lT;h3-Fw%v3`lQR20avpk} zT&ajzVb&b>kp071Wt3An-ysZSZt9Q)a47SSJS~rReCO$bCR*yye2g(&7CoL|Per<3 zLS9|@$R)}OYRtc|yq=aD|RcAx9P?l99%}^8qr3yzGaL2o% z8pstL#Xy_r*83H3(Q|UKp{Rtw@TB$e1~@B>H|EJQOyJ6Oz4NmVy6XIg<~JS-US#Rz zyWf$e2Mn)@+MwpM6a}FhLq9>X#Vu+|D8oopSaA&ETFM#|M)Wkywe|~-8}~pAan>0% zkEGwz>dF;QSsVC0YA%kHnYNF}%TGCr&zJ7_lvkhj7kl+7_hm&X49ssTs)0L7k8S$U z07XT}zNZ{9W0+v)v)HQN6jed4w&x4?n?;x3{bP=sG%w|xNw@7eNfY$&L$1@6Y?3T*SZ6`(nshp{>ST;gD|NoGaq!^_f4CR^*uBjJCY^ucQ@TdpysA7bF?y zV3Dde!;hrc*}6-7!q4sTr02qsBvba9DWCrW-1WS_RE0Tnt=yP_49^h1KQx|W0>*gX zA39-?59dj1iek^i+zg?ewdSrk3c@zvvRuR4M76ZKkkV)SQM-3hF)R%t`Pq52Q!M>xfm9PpJ9?9brIOJZpUN?WXyQuWEg?U@<Fn=|5}i!X1%T5r|!@$hB+Ub)t_$*c1Hz9TG}&d2kY1+jB| zJa2Is`p@A;{>6aCm<(mcHb(Lb2OHz{RB?d*{R=ab!0$6oMpTLZ=t`?|L@11axkHSb zQ4DdVja89b6>&83=XX~8l^3DcEw6(kCd%V^JMimCGb}1DShBfbpZFFPP2+toDqLw} z-gmwUHcv*VAl{-o<_3PEuGl?nT#pbvPfwTk8ZM*SrQz#&zcD89yx-^HZI)eIu>1@Sv3uSAcf!t#<@@`_RGjfg zy5pTQ9m=0#jKxs(Al|XzdcLsg4rP*XhlVmEpjsc;F&Srvhce2TM||JMtsjn|X_%kt zV6tlUa3(Zr`;6iYvI>2oD{r+yCIfX;SD zsWhF4@`oC#*!2oJrCj1JJEfkhq87xgbH6#r50usC z3<;O}JoZ?2IL3qw`DS1YsKeRhu=@>JQNYCOkoT0i&O_NV4Zft2Zv;i+{1g#!Zt+l7 zAR`!t^Hw1%4drfk;Ph}FEAGt5_xS>jWkozJ;ONx&fz$OyJOqw9FBP1ARM%wd;8i2@ zR(J5Wp_*#U+`TL8no*L+K4FDhnYgiIs?o*>fuZV5^yvGRGIO`9V%CLSGnu#kMjQY~ zojDwL;E5O@&fXfyJz!`0w){RvoYeh2_MT(HT+(6#~hQc6dENf&B*Pw=MGvu4mdHFf?o#8n4hRYOGVzB}-VaGgF z?67MrpBeY1C>Qcdd7D5!0#+t6e?Jt1kv=Diy6krc>0dNPz<+%2%+iiJbD4D9F&KHj z7z=rNI6{GU(h&-Wu-tfGF%iL49Al9+ zzGEUNDRjk56s*s=-sz>f%oQI`?sx2;awJ(bd??OsWZk*pn2a4KbYnIEJ7%ThM4gG9 zfFbnIS7D6zx2${OQK1^onMd74^k|xPpGT}Qg%<8{-AN7nAq{(QN7cfW2oKdV$ zRkSB=QCHm0oZ=Jq5eJS5=UAWDRE_n4yM548oZj_;Kb(9{NeV+dL}~Hkla}OiR)j3c z(Nv)sw`|BK%$m`r^o#;9r=Zt-C|-6BVX42EK*#8%pOSCsWxukIyxydfO=rei!5puX z+ngaE4(DnwNbt(d9(cY4FWl4O-01w!4dzOBMW(DGSp)Z6u=R&qQXM#)KD}X z#~+HeyD;C+;=T2quQ>yA!!6MZc5XG_SG+6NXIY39kh^LrF&F&q2jWQjyw8cVjsnQQ zc~@}mxYb#3+)~%0h3wEBHGqibZZCJ&t#U=;(0W~Ax$72k{gkylpCRdf$xBaJtLk~s zb@i57z(~t-%r&>H$CjvFaWQO}YJFyP?O%Iy-K`I;CdtD46W@REX%nV2yte5aFnEiO zIeUBoqqE?h9}S5WWvyY+uW!!DHoB$?YfJh|&SoDkhHc&Hr8tDZP{|exve4BRUARf&z;%Caj$^zy6=DP!0ytoQhLU-thcSd-3rDy zA-_)y^!Q~x((vm{!y9tfD) z5%-spkZWQu$rq?E*-P5gXZ@Fg z!4f-^;jo9E8|L$>I2vkK$@srsiq|DWIBrPVqvD1-D7d2{nsz9X1ByV`KERHbUuq9A%sDT8q= zRlP(uv!0qT%+;maymEHL!St)|tGe}&_lMP(#}gNn$JO3c{d>5sE~1NvJo+h{$LDvy zJRY*1hP-zv%RZnyGggbptjE$a>*7n!R3%=~kj$P@vKwdC+1DLsOX;k>4C)gs9+cT} zNERg3wUz#@KD?qynVlqLVan{4A{v#a-e+H7)})tQn32zWpR-TG;vG~MSj9(Y*7S({oGznXO(m_IYjv*Md;(R@JT zE9^-ZzWagf*sk?3+ji)C%%)|p9pMYTZ9d<+gilM^xjZkNH@%NpJdA!6pI=KpPx(!V zPxef`_1h!6x#@oWg(nF2!xdwBzp^|(wLSNzv97bKq#@|_-Zy5Z`aU-H0n~kMQ{TH4 zTT8(7k}Qo!&m8M8Z`qKMkDi~3s+`Y~7lGrslVs%UJ5RH!o_v-~I;v(UBZPe&OS(P- zzE7Jr>w?(AJ5>L^$tMu?h+Mmp`To-TX+gd)Ylhj2!u)=B(%hOq?P;v}^}tc(BVGGl zT`yc*k6-pYy)Szm=f{kqrtzn8#unDMWWVElm+W;3`{fKE?%!5MQNj1zL676nzPdDD z!`#1{@l>DRPp{wbT+jE|Z_V?W;K-iuEE<0)|Azepmh)5U3;X@U9VBDlS=^u8~QRWIqvtelTy$%zk)y@%Jeq^t8}-e>73yiZ9oIq~~b zQ7-Qr8P0wYw?7H#ha}1l`C~~!d;3cqc!55-zFM0v+(qA}`eBR@JS49S#R+pf!mR86 zz`I@g7uCW3fk|(N;&{2^1xQi zBKh@lOk%$LEn-I7<$pb!-!n#%>oL4P{MB{k*R5(a`;|{3qODwh9aVYi)<*|IkDoyOzR`*+7hPyXk>{%`Q` z-_6T=(3*~Dl)T5~>Az!q;6YeC{&zBYJ8~fu&b;N3KnU`I9eI!ecSRc195ACjVl(qr z{s+<{^LFNV5}f4e=liZv&hNXz_wQlk-LL2W_p;=zXdBcV&)b>m5$F^1z4bOyiWNrR zCHBuga96Cx#tu>{BCLLMNZQX^QXT>t^WHbM;`anf5*L8fQj#hzqn<}e_3qg3Ktkimm-NWNj)RWWoH_jKg>Tmomr6gBHk9%Cy4}yDMlDiLwrdpD# zC4^b?%*a*Oe-Zw`ejY0lj-YP*nX&5rzEbdT=PG|m@X zr+w`BLQ=Fr%xGT8Eu9&!JLA~{_6%di`&Op^ok+>)_WTY%+cV>(J#*dhvapA)z>s6c zuIpW~hpt=BJ+n9bbE<+}^MbH+1;I}=!5J@$xAFV8t2*YFpJ;-!BkpF53K9pVY&x-{ zuDd>QLaJzty60y;<@3ILHgI;7G%g%Cr(9$0pM1M8yq*1X#fUgDSAf_!A=ju*c&;e5 zk#K8NuNS`Sl3ZmxW54AUMBqW(j@%6`>rJ-28CvX|uk#2qv83B+QaO)cY zL$mVX2Ts8KsR!v)5{x^`=!K~h^7ysACp2|~xPwD<(DUQ_j92Mczn^!F&lBvRLO$V! z_2~wVCOTU6oHs5%(FH+Q6|GU<8#qXVT>qhAzU$5}?SMTW-iZ11mp-tg6G(IReD`Nv z?Pj<4_Y3&2+{FgnnYknA&KxsT9e3pWADH>^1tTg3YZk0PHfZGc2b>582H97iapGCM zg)?@@`R=}B?3J8!qRbahIx)^K;rI5$Ct$Qa_k``~PokmU@kB#s(j8?L_Us!{2*-RJ zjZv^a?j>Bng&Z4EaRbJUG~kVL{RQ&1q5S={FHJiqG#+W>Cp5g-A#Er_KV$`YQ4ou8 zWC_QQ(!sc-$N5pyr zto^1O;ED>QDT<}ol#bQ!WEW5+_f;ho(u(i%B;S2d)u+2}f2r`!qT2KVay5j-I9D5M(e8z_?>DUG0bfu2Fht3qy z?t5a-?G2_5DgA0sow>c^eBa*Zit(1b`@{*?Fi4P1Io>uMeQF$7`-z$f<&v={UKK6O=}M-S>&oUqLPJfzWNgrrhTu7 zmR^rH;4Kequ9ue510AQhH3M+FE|{m{-&fo;RlA4!M!fiu#j_;$PNm+i99t+G-evlz zO)J>}*gC|4d6V4nm=Z4ECpXI1f=Vp89VzS5d%ULozd$nd!W9Ct3afAHS7O)l+wFs~x*E--1xxX&ocWs7Q-W}vUadnQZo9@~T z)s%tH+g*Ww?>^=mJLpOSzPYaLK>j-gOOM`MU&i}I9Td2uOZzb&y8vy<7iV+P3DG89 zWOrd+d@%-P!rX7>p%>W+n#LRZa>oNxi_Cg|1D>k9kkX};Jy&bp<$eBiXxeOH&kwq@DPMb zcGnxwG4*RcdHD08Iwuc*O6#PReLhs`z(W{JtM<_Qw1Rg@sI-x z_rSCiG0(h8Lgsv`v_?M{#@83_s?}eG@wD<+Vephyo>X#ce#3SfTjf9Scy9<=G?moV z?bdc0?-y?X^Yn)#Ue0HlhU$IZ5a!`qBk=b~fttqS{&BrNkEQWQLpi@Los6-a9c|M% zzhb*cuPq9!pZM^*evmA-Gf@aUPd%qABmCnfLip-aqZ(&Wi5vDJ*0V z95}o->Qq!aWCiuNsN`enUm;k1ZfZAGYkFQDDq1aZvQof5I9h4TQpKT4t##h_2^V%K zsjp=KdELZX)()_}Hw)&TvX%kmwRSVtbt{$UO$pQQ)1G`Y`TMhimT;@+w?b`!Y%FqZ zflEi4ISuw4(Jyz#EsHbWS_9+Rqh`HkD-%7i*k=gaL{>Z?Y6l!j?o4)4T0cK@BtP91 z5-7Ky2c@pgoI%O0f`&Uk$a6lt!oItT5g*^)xu;or29od(>^$g!_iwyT4%qQI6>yWM z>fEynFTW2@RXC3CcqkKazt^*V|N8n$R(2HPaZ2v;VSqR1?tCwl`z?6z9^zi{gj|)aEb6{T_hTrCj*%hT^qRa_;vP!+axI-C=^psxkduLTv&EV$oHq1!yIiun|2X`$u z1FeI0l)^nn+Ds`=kKuy_#ok6(O^dyY4I?(4GJJi-wbfz4Dat+33>Bq^uG7VR%Ha_% zw*xRFMt6clu6R-J9#)56*rUzr@aK)vt}l$RePMgPdju<|dtG*(>U?}%C1zaK3o9;8 z@4M$QwC%Tt@wxfxR;2mXCr<3}liL#+GTj}Y&!1}Xhc@3G4Po@zaomE^?tBJM4C{e* zU;gpUl_#_KP^Kaa7JYL?eg)*6mh$A8cEH~`!hNO<-UZwQql_A|ed{Z@M01Fa*SH5+qZGCYbk#5fl zATyh83~c6<+{%khR)?!}P^9P%Yu~Y~LNA zugNDyUth8B4qD0!C!FY1tm6EP$2(CT-(Grlc*bQs^KFWKtnInulXpTiaPrRDQv|E6 zdsGFUnMEh$TIHWRIP3QgYX3xIC+zmVle6o&Ph^VM*WgQtt}Kqm zrtiwp&-7g>8ZI)Y=W_?<(g`*Dw!nE^9Xq{u7@61?XXg|Zy1ugf?f`7A?)uI7sbd;5 zwGV7x-XhNX`{Ny-cUtunCM0gtq`9y@V*upOVs9;cYnC)t5(aho(h4w)o}wh0W#3t> zr{3qJiO!0S@l+#c8Kd}q#vPY;_QI;+f;`vaKI_X=!tt!6%JkJBLZG;sb=Uj$Wp&_q zQQqx`imxFmZC_diRqlFDs%76BX#hPZ(7f-C4(*_ON~f0(BJcQ0oAgbY2COcObl&d( zOy63QY)D@g@09bxtLB>pYkin+(fXZ7K5@rudtu4z^vxNASH<_|9lwL>y1IH`;JoM4 z0Q>wlB)#jK%kTRN`a;**RCC+9B@48Gh{|GXJP2!kp+kFn;5%5F*)^NvS&t`}Cs24d7d z&p(m|*H<22UVe24Ai3VG9w_iWld+UQgW%z%zY)BJ#~UxGo)m6Ggkp`Wlr->I@5aP zhiYw7$)|$+E6KQCH^2B3Ht*O&_er0kvqLsiP9 z&+{e=3cYle_M4uM`e0aY!f02=ezg&H*bdoO)v{~5G$1lf^5wJ4JTaeT$L@<^xtl8L zd!G}|)NhsPkx8|cD~?Ry;!e96G^*wc9}K>I>>;UEdm+JEkb5&OmG4NJJupXDqM3xZ^wq4~oHj34 z=t!C>CEse?9G_k+OIAfNwG*tcm?mcB_AGFTF}}}T4V+d-dLh$CF7WqN>ljH~&kfqb zAa@+6LSQ>(G-vybH>Xg9uiXo!1L#ifRRyA{$iI`?MRgo_Ud7 zc`Lh$HZ#_Hw`JSoi6&IS+#zRUWyq@R@s7wt*?8plRge3#!l5%m1q%p0mc=?Y&vr(6 zS}zV6PWydd9-K0S!}jD-o8XM6eMIf_oP+J z^{2BmX8s(CwY4wKVz$H*!2T_MN!jL6AdQ=Zz4tMoIMtRtGVqs3qCqzFkKy55A`>U-;?Z$xTT%?nrhhhEV~|l-?Kfi zff2pPG7XIAh%uAz;lR7Szpu9ZPQv5yJ{_2{6Q~NaFJ&j~=;v)qb4QV}yWVbZ%@j;o z1ytw4oS(fpjBMzA$}itSWABVKpzXeQQytJrlrt?^y+@ws`;KUw;fRl=ulFh2Xw?_U z8E~e3S_AtB<{nx{?Vs_+9iMcf>HT-j2d3?m@hdm2Te;nR!qc4_?HH3;tCBG%B{J#V z6V|yb?lbczzT?0Z@gja65hm&qHDQNv{`!Q>=zRY{Jf@fM!17@w!j$2Gcf;0Cd~f_C zQ;#iqYia!T?$J!zBj7#fS6I8Y%SR>NH0k$M$C`=w62ZS%F&*&|u?zukP%`W&t&uu4 zdZDtogS&xUxEeV+&SP;a~03MT~wWPVd!;LT{ zP|%c>^gZ0sl@uQY3|Y1y8dRrwju7eP8@tB>(`mJT6Uz4P?G>ay%4O9-eCGvZXIt1sHmjd5FkS?<8LrK1U^yr}o7W!Cn- zFKaC`@_gsz)e{v(wcZa*t|zS?(uXZe`${hehU#(H-C+T#T`Wp8!)A?YJJu;P)h zVtY`CQ%ezJNh_wFPpYtG7r-6h2`K*PzzdQH__SuMzFnJou(VL-VA@u-Az7)C)b9#5 zWa6y8Rl6#0f-_+3tZq5|f?1qZeoWa`=#|Q{*dwPfWH z5v6$GWeNLaVTvxIeExx(o|h7^CG3RCKv;2SuDv){AIRF&4ABDN#MooUQH?KeRlj1~ zYEsYE-j#(wEvG9>f$ulPhc9V8jG0e*&I%yeFzP{2i-RnvdJny`e#Pb;(D!tr9X^eu z>SDbsbI9{$1s8sQIFpF>OzIfO*2f9-@#HylX73wzjT^(t_J>xror{$S^EpmzIMW!n zZlq6@pFUiN2)Axz*M}&C`M$F0#!|fmWS)$O!E$XTKUXj33-b%C?Ig-RSj$P2e@xYD z@cXJpRS8$%npWL4whjF>MdPBECjmxRO2 z{b8hQXC!J8CmF0CV3@bm?>jfV3T8cpB8>BO>~zdkkZTcx0>q000$X+YC5^9IMI++oxzEy#TMZxwd^9gPYu9T zQ>ZmNdyiUWHs{KOS?`VG`Id6Lto*{N=liKZalV&d9M*jLoey(9x2ys+KRCFYMa)>$ zzNUCD{5%)t3=Gp!GF9Os3uc}!-ygy%YKcQQ0<2?nvT@*68p?W}SmEN;+f@ffdV7*} zmU_N3GWC1!&`>=!+W|<|s0A~xSrG_ps!j}U*_x_)!V^Zsgev(Qn6d`vzf}{`S~O3f z31+1x>yU4a6KUbjk-czxwQN@wSguG|rFFBmm7lZnk>}6z;f-+ZE9$tejg|C1>i|i9 z-&MC7((h*NBYCs8>$_10E6&W{gvkk)v|v)1EWN*j4_L2PEd^=Otk*_6NS6HX=Wj*9 zjxI{B9Ml<2tqO&m(bmqB-oAsLKk4|iR^GnP-x`e_U6F1rhV9IM+HtBXAW{czs)w?q z!|FzC!pxNK(&;-+1a_9~T31}Z;VhlMLw57`SVyRP{0Zq@&l~Fwr7ujYM1w{=uZ^MQ zTbJm8cYep;|7*V1;VCH%%|~^LH2$)__}4Z7S3iLob2VVbF5mO*;`FXc8P}a{iPd4E0(L&(n_^dsfxeflH`a{Tap}am}`Zt#{D2oj~hM`wY#D7 zNs<&}{E@P1i^cj!B1Li~g`uiS4G~BKYEj;d>^v|vc%D#^#y)VO74@*mB?inrd3VjA z$)b=e;g0Ij#K@-V&|Fc6)oKYty6z+~vWv@eye?V1>V3(cdQL93^!t{t95NE`BsJ=x z3Q1GnyH=+{I8JEmdkrVPbwbd{Gv&AghtD}_Kf!}?lCAfD*C7ApLgUZ>{HZ(Aa@jHT zC*a?sV2#PY0ssENnwNlom)a(g=Ygx>mLv0T>G!`|ec(8%ie#Vz$JSOP`<%?dm}-St zJ2DGbz#-eVNn&&0c+Mc(3Nt)26Av6hH@iRpj`h)4QqdlPnVkm?ERW33PB?8<6+LiR zQQ9QCtSGI>E)oZhiL<{c;J#x&u)YiT`o2FjUc-J&jn^^1sqx|#wYfCjzs^~Qd%1ohdUj_3H^j+&5drF$N~8{HNKoWO_ihuu*DpYc}_K7`|}EgCKkeD-(I z*<2z1Fsl#0Kl5EQJP5y*@g>BIw#J>`*^g!X3nl2lJl{~F4$Sjk7;oaLpZ$pSu*Le> zuU=IV68k%sDsBRf@&7rmC45Et;$06MkCDYU1ZQQ@ovT(sm6*qOZdBJBTv5o%tg#7r zPv!X?cwz=cJF+l?q8kzbtw2)0rj|GnoZ!ZaSxBdXoJYUcNWB4Hi@qa?@WJRs;&$Kx zj6gCM*kxNPI)34#_v6N^aVhv{U|c4gQozKJEsP|Fg@O8F>|XyoU$}u=>zTNL`|e-d z@GT7Eev%k^zmuMKV0_kog*N%@R|iIUzxllC1_ZHZ9~OKsZU9YZ2af%tqp!ja&YH1U z4>4?LeH+h#!FywWRqPbvNj#r~13#252#XPG#743g3iz?}%g^r{Rd)!3Y-sWq9eJ1Fs?5+2j3i-H;$z3)XM81PgMB?1)_{R(0h34rl}-rl)hB-7 z4GiP>VLA#7sf6dc7}Q{y4wy;FsO)yACUUYq3b3)a58$(csj}Z`3FmkRHmI^^ zxb?*?IPP4!&x1;3&Cu`=9A~cbvncq-p2~n@$JF{ZZQ!)Zv%nu^96WHG;JD+@eyM6p zq!CLexN&Ee)3_18c4iobnHrK`m>>Q(;Gm-_Nqk|f;KDc~BnQQm}&?nU&9LW)QPZ7;1mwIjo$)Q;QPFlDz1V4FwrHv5sn=$_x&-Hef?K$ z|AI=?7jF0Wg!czlaSV;86GJ~7W}AOtwn<#T02R~FeEXeG#(1FedE(A1DH&}H+ft(e z#7R8!9k{c?uxu{H^X+)9r08ra*?qovpKTADo^$ zQ9~mN7$H?AYJ|j&A;X0I0{%wh#tcaqGe&&jku2Fbu|hIb`)}kwu)+jjN`h1G$Bc#1 zg*&3OcSN$V4?E#?C7)KR_zrfYG@pRr*dg()!X3VRsZP-4#T`HxKWljWMXSVqW!nSS zteO~rTUHGW!tD?1#RHZk^MT8Kzk^S;`NB=D9trpRy^cHA4Ua23w#qvx9IL$3&-@p0 z49~Z4h~trJtMz81Y^&CjE#bu6w1}KuINFMEn5`SDPJnHnUO52pYL6t*x@k&aKpPlO z>u=zrl66n%xENpMXBuVes?v2+T#Ie0rnnkQ*MSc&wSsFyG`;!z1?N4U`Ayxq)^J0f z^-x!JYs_m%tmVl9x3_Xf3^RD;#eM*{M|G;^P=Ajcjs}?=5n$4mU`_+ZIbrBYM>(;iD z=0n|VYrg5ZQAh&06s;FYA-9ZPedNZTrLFUO85C1e3SJuOo`;c6l_j7)0 zX+9lt^1k>H?@MY#^Vp~WqxA;`loZ-&y-;)CZVFv>Kd8&S&24Sn`0xKz1jCvIz`y24tHW6+F&5756beg;dsro zagD72f9d3ijyJ#z>VSM4j_kGMzh072x7c~Skb?jJ^Ctyg;=;7b@clE#utzv#R9d_E3L7>F4t640Jr0LS4(cL z(FJnji)tNtVU`GnoI7qwU((sZ!0SVY^H2py&}Gi38^&`NYvr!^eXfbAfTxZ1e!qal zw4v6G_~Wh#jpFW_1a}qZgg)wXxzAaQldxL}8m2y1k(R~UO^0%aYI#%(nDuMv1yyZ7zeJH0cbx=x~$Fgfk6df@{BL8_xDQ$ zMC2`i3G)Zu1FVVOiC_}!*-Y=sRQ)Mf<6})ryaO7~cJf|D=ai;Kt`AIWEbJD0$l3~P zx7W0TSVTQ4JwLd;mr^igy>zQs#Qd@E^xuGEMCr}wV!?9++{fM324|elvB8rb-FWc4 zWBloIX=pFe5Z!<1V$m+qc3_yc2gAd*4V;^4eJJt9gobX`{KDUW&+TxFI%Hw{oEi$H z821jP1rG&dJCt^6*Z2$AFZ>0;;wH%7WF@i#uYc!UVe#AIkhN(<>|=$jxJ~(>-EG+@ zYu7G9wyRxhqIT7_Cd{yQ+>VP04cY_R8l$c9x%0bU{f{v9VZtu04&UP*SO4byV^iO( z8KnA!A^o*1+|{l(*ol!>@)O0@;|&#pLy~-RE5f#Q!%2y^XV||mX9zp79Nj4Vown+& z{rq|0C5?n@x*AZs_c02C&u7g@z%VW!%A7T46bBrk9IzkP-+*U%zBsbzCMj_iZnJE0 z7R}MFf#{x|VBpCp%*-BPf5qNe_-Qqw?bV~pUXI%^t|qzO8K{-8W|(ecT3QOS zb~QwpQ{xwOa?tDYv~mp#dbwW+Ye~6ZAnY%MZmq(q5FesOvN$g7n_C<$QFr?vv zUru@_<^P|&OSGZt`A%0#35g(GDJ3XOmL~N7{`3CWN%_> z3N#=vAa7!73Oqa@FI0JOWgst5VP|C^FHm7}Wo~pJG9WM@QXnr)Wn^h#LT`8=TQDFn zAT}{FE-)}4H#sscFfd&pFGFu`bY*UIb09b%Fd$MOFH&W5Z*_8GWpf}rJRmPna&Kc( zWpp50FHl5AT_8R_AU-}IWo~3|VrmLGATS_rVrmLJJRmPjWo~D5XdpE?GBGzGFGgu> zbY*fNFGg%(bY(dCXfB%#JNxy&or~SuRHC>;L@wLCydCKfh=H)B8WAxBv9@&!2z# z?zaN_VZV!N~9 zUK!wd*`9Se;2K!d@6Yo4BPPH(4|v`!aB_)b&!GI4R>vLPOXI_P1NLm=0Sos79~yB- zH(33u^Kjc6e&77t>3P39I!1p>EclDDPvDQvcxX*=4t0Y(@>L(O?it*Nf1m7lRRVav zeBOL8psfe|ZBu@J3k>j^=fTS#2>e**9DX2HyfzkXFe)%0;o%$rV;=BKDFD!AM=^7k7#l&-1IHkmi zOue~gfD_+62q7@zL%-ji{m5L?0$yfN`R}_2rwbVa~mr?K#uX0t2s_aTwJI zE+H^yZr-f>;5T?q=?8A^vNtaP5{c8|=sIBMXn^nz)=rYv;BP~tSVF;fC$Li6KKa{& zaA$O3foBN=wDjAJ4zdJ-bFT(=<9EUx+_vwH|DA9b^F6W${$9gQL^6OPB(49VMISL15Gin z2EIiqo()Hyx#Es_oeB6@MuI5%fm;?!e*89oREo`8_)sE#fbc|zzcm$5=|Q#s{;%J> zJE-ZmBY*ZXCgyd1{ZlIrmrq#LI$Y*31dc9nfP*e8H0v|3AK1aS4wA2`c^#r&6-S;y zi9e7uemKBt*jy6z4-8Oo5Inyv9zC=c9wmr5HymmO_t0qdhbmY;X2nygJn{;8S@%i~ z*f4rQE|nSzLtdQsF=oZ%0Qd6~(|lH=IPj7gF#e;|ci<-s95iS0Q_wo#dhz{ws%nJ>L!l{yc_3) z`=Qex-hn@ex2(e%3p9fR9_@1(qymM9Cy+(hLH-b67i$7{$XhlzA1ai2}HxErPbc;HdE;wC)iio2v@!3?{}EeKP8<%$NL z56y6hTKW5-6>x?V9H>B$Zdh8_BwV3AAO7~hZN1NDy?=_MP0fe6)Vk&qmz!>wY%9mR zK59K1&g*J2-XAi-4U=VZJ4-KkyL2!k}EW-`p?!9%dBY ze|QY_#|`&*c+L-we3iZp=f`Z`Fzt2hS1x#8f7Ul19;e@ryS@tRm(PccjHvJYv!1WO zk01xh4H!sWal=6)M&rG|``M+ZC1LD@(nGU%!vUB(2sYm-BM;o)9h|@b@q{1T%T-nm z{PHNl;(2*WGnj(=dS`3{m^;Gv_xtJA}KWFGXjz#;71OM*tVPQ|n{(z$le!4>;wTSP=u|H~&g@rd% zND{g2a}7NYuJePBn^G27rK8s4&F?!qUSZ$d_g@!TCES-BY8#$<9xJF*k{2glfkE=P z?G<&!G)`D%!vk-?o(mp4v)Zx3sV{UH$5}Hb7XwXI^N6AMwf^w++C_tYf7A!3D!kM1 zS!2c_4eK|tKW9%X9CS^4PKO<5;Lrgybu)=$CG0C9$N zfl2$ROYTL^Z%H;*IKgtO;;a2=h^@*EhBIiFFDAlrlo!IZ3c)v8wSJQclMe$+nss2T zxP`6GLb#OY44XY|SaB=%+Ev1|!Iqvc^U)q!kt7QJo~|pdhmx?~=gX^OH`;tn>vP}) zIMqO9KA{Hv@xqi7e*Wt`&y6}h<5(MR>CqKhv*g77b<9t4r7_+lKKX;GKSB~Wdr&za zdY|YOJ#akwYNKC#TzJy2QwbmaSQy(tL%mT>whsNe-sg|6yx#dyy95olE}N@qoLt23 zt3!S!zyta8fVEX$$u&h!&Klw#4T)X@>%xF{B^Yrs{y)WjYdv%MsS2sI+yAOGq_=X{$KF$Qj(a{xxaIKH-fI!NIf#aRBn(@XA z=5akmBT4rFO%M7Z43kGlHyh+Rl%;tz>1v>%(Zw@xLfg-a_hCK5^TQ6$Bu^gJGZB5a zA7&Q8`2GyhENFgGO30#_RVN0?yd!Gm(RF6k^T63@PZ{4=ZGUK-exdYve^KaT&zP~1 zcDVk`3cP{~Pk65S;*QOtm?mdjBzb{DTWxv$1Y50n?TJ|x)$oiy+V!l;1mKDt_5g;= zCi{XbYz}T>2RgWD(eH`FKA{E-V7T+V4;Ek7`{^C_{A8bKhv{qNd_r;*7@`yIcfTg0 zZK=N)G4wr39eUgM{x3u$nlNf2@~IPB(EmYdzY|+cX&B%li+omA`0Dcf0A~d23k$lA z!t@8GH#iZdT*Zu67fmj`udipvR+kl?^!$7^m(>+gZ2cYY)&^Jm@=?Z798q8(#gbtC z#YY!|w9GWfYYK-sgDD(?VgBm zukx;*6L{ckxL;lEz|d4?ePMbP{5)}d!{m~N8HP1X&5Y}Ol++l>UUzmv&M-G(iObfh!`_J3u zN+oASFgTuNbK-mQ$LISz<;cPL1B1`Ue8=NH&xp_A^BZo|CG|aqI;Y0zkN14?y1Lz- z{{mm1THotUJ?pJkP87uhLKwEh)$n{;;(|Vp{?0#5e;+44qzfG`yJ60s=Lg;KVx(!D z=hr`3H3yzo(}L$egUJm3M#1rF}m3 zmzP{+&z%_GhI4;^;mj~%V2CI1ghTdL7-sByy)Y&D`8~ZxdcMCjtnV3PDaq-r-7vk! z*pb}i*Tarvd%ZY+%E_efS(ls|r>Bz`N9!RjOpE~r<{^vuNR16w><{N}U#sEyM4(EZ zUmlmIVyb+83ZuEcDY;LITv%_`2`}jtMdM29INvKtJQ4d-k~{?1pX+T01r~A)MwK^A z4giWRSutKdU$j5qp{3ZPun4~qxDC^~T=^Xrg_I)vYvj4b_TPzrZ1_7PpBQ$m4DDdj zICWuuaY`5NL72KQcCg$i^C0|sf;UVa>gW55VR~K|tM}1Auwh~}=Qm}aaz}@FI!?F@ z#nk${-o7*++NX;cTDoF{2`AVT{{RM+CQWq;Ry;+|XXriL-zH6y``09udw-v=_x-{E zjniYp=N+Zanm;{8{Ql6m*WVeX*8UPh43pvrJEs&BUL5lUMMru(T7b)w`USmgV_0qU z%rDrBRWZGV6;$d)M^nuQrk(~}yEbW(NSCSdAS~z^Renb1M^#0U7xbJe`S|X{b@_Ru(uaHt4(qEHL*fvGA#JUo4k$-c>#?$ zx8bv5u5fF7^qQ8Wr$G;@i!_j+N7X4k1-Uvp!2^#2 z^Zf-FG9}l+6)TgGHheI0>H9dL9}FB%f%Ve*+%PeqOY_ZGk2UkH7d7implP@|0iXR4 z%_h)rlU9(B0^Ww^4=LM*#$k;%$LGA`je15xrbTOa$MRqB#0;pJ9e37-OVf(;fwNY4 zXrNu&g74=H!KE6L@Sw|YKG_m-TaNCBGvyv2Z?#DiNdq&;(gmTrwIb_bh^jb4@bMP1 zmLP}Pqgzg_ApHf${K8%D*N)5=uEJr%HNU^NuFUV3XFd%$zFs(MNBMlZy7A#!OE?KR zTBmSu3Wtf~&}1%-BYswgz7IcRouavAE(c8u+5dG)^F#W7ow7xML6wyj$94d0UHF`j zeFKERs3Jb^r^XulxWThV?&(`!ZNamQ_&toQi^e0*S@ zm*>yl1K%>z-J3PnjNeNy${AcXw0~JVkeae#+kOocWZRAu>HQ|pwe5N4V;;cy4%xa~ z&kzrSEz`!e%?e@R7k_WtDCXt)8{QtPCR>NLRg>OuVP?*hOrCM9;ceSc&e?WA7D2P^ z09&Tonub54(w}l{r3$V)39s>R;Y_)|u5FRl7w#Cpwg#jIb$NL5t2Dig9jVgv^3?m7 zL$Ke-6`sr$SvNnJE9k;uT2qF3hFv(7{(`&UO`|QYHI<1&8W&gfiovCutg}Ni{aS02 zI3)PsAkTEKh`P)~bnd_lx`ph;vx2EJ2%M?MtH!wkWS2K4L7y35+$%U-LR^XVoUxMG zL~ZDd5S4F3_8>eq_jy?4O+KW8%$PQ14<%5UxLir15?T*Ql2bmX0y?jQa;ju$hea0K z!I~lcyL`0A4O17PJ|5C7XfIS@A?=BZGqL?b$(gUdU%?0Ydw8mwEPTQBu`i&Dd7Qc$ z-$!jxbY75pes=^O2cKa1V#M{M&c>X-1+1Ei|14%AwCgF}Gnn#a(=$A+JtD$5t&hW# zJC%L3pgGKW;k|;n1cURhbm6^YOPMqaIJ6XfS+MDsqA3eFwNvt~y_N%8n?1h|aXwfy zE2R4XrRe07~YgO#r?G;t!9 z&F2KH3qW^Sj3FQ0r5?CTSJ*hX(xWTn0~h%z4+cq6P`8=(3&SRz^6MsKlg)W`qri^e z?_u2Y-6uHbo$omj>rz7)>-ATh*!4@|{aO0^$qkxc{e4=uL(S4$I>9CkS%M2Ns!7{U zpZ$cSych_3V@bD3$PHTMzVBdc-0^e1wpT#0t4eo8uH1V3xO+XT{&l|f`r#*@_x@MF z)@2sH-(THxDN>S2K}9};ty`q7UqII&P1^Ii>O-SBV+Q4V&iTfxodIL%XM}~h($)3| zf1aP~es6$B`FWl=wQKn8j3F5rm-AX|8JRV}kw5lC&POsHoEg`%x%YTV4pDnCm&nlP z=HQuS=xbB@BXyZ~eB;y{nlZWfkiHL_bXpPvXUwITJ8qo5u%AEkU-}-rK6eKxC9Iu+ zM$9GYDPFRVsJ)p-WY|Y5>-i}zT(y6De@qj3i6*#TlnO=rYnUg-=R=-f{KT{TH6YhxLF#^Z@QHsA3g?W_5e{eECg2qx#G_SmJ%*gGvw-nd?3DR&%P!+t42kecm`3h`D-4B1?M&PF@&v87S*rnI{zRJucaRk+ov1 zAc|&;6-N1DU=-;F;KNZQ2f!C2BuT)B0{MW_o(uEFXV-iXg`bLf26O?-iD+NB5>1i| zd^);xBYwYs`F0Fx-_Si`7~?Bp@(5s13}X;r@@=07D0+pyKg9?6J!<#Dc;<0SSAl)< zTS26B;|aeRZn!Hm<@f1G%0PuZ5~1NTpN1 zM}3Ll<1J1HranpujE8+hKi zPDA6~|AhHSUrk*z9FyMf^M!FOq~Fvxe7(=}z|L$bfUQygUTvJ(8gvGZ*}K{RQyWUy z5k=*4!u$I5Zk`?KSK}s5)6-Q7Xp=@k?OU;&U}^00t+q>DEU|3>PYok zSQX>;?k~Vq-uFYJwqXa>=lI0&{XH1d@x8A1_f0{EM)f?;!6BK`n zitkAdNBeTgFjoW4N0(;SY~AEXDh4sIU+bsEqgO-+4G7~<6&y)knIOg&!431z!iWYv zDBbxT9+2+&9k11T)) z)b#tR6Z7+=Ae>;WpfGW9RINsm-cl>(t9-{=fw9taD!HI?eQMxDMts_EUKwm3pcCx|I|xy`)xQlz1Yla;ba&LE;{Can67=DGx~PUoKot!;m_9-WX-u zz~f^+Jh#%85Ra{vGThN23;|E7)WpP7ky7)FQ?v8$Coo>NOkL94Ilm=6h8VMeF_Jn6 z9iR1P!jvlD(RE1=!wI(}o+}zfk_xT6KT29Un$tO>23^}b)QID<_L`*xaG=GP##(?T zMPsc<(*ajSQqJ8GBt%?I3rRpn>SV&)LF`D&Um9;2J1*TCNmXZkf=L4&5A2YCPnu}{ zetEc_<|nDtin!v?`sU+5*z1q_(2(|1UgdVBSSC!{h5Ow!&gYxG0eJtFT9q(8PSVvI zJrbGLU>n#0`DGie14UdLH7iCC@rJV}hcEq6qR{1wNWr)kd$WbkH%?jPkYsJ*i^?+= zERP3LHm+o8Q`#qSi0@P0HQ}skqjvI}4$SyRFOp@**6Bss8L+4qtXV#l&Qp^;(?h$8 zUG7zq33Syfu#z1iPD%23IB##lQmhzlo(^4We6)wEdXo=?-!t6x{Cs^Pow{J$=PT?H zuCGbZ&7v<~oK_bpi)pnzfB2ATm%6R#I_WN8w3KT0z%pG5(;{kSaDi^Q&!r@)zh z-$Zyp4lIoioOsszWHDAFm?M^Bv#&f8pZ_ zxbNeBi--O&bfSj}ih2K>u+ND%D%WT-8lx=G$>@zv1nB`A#tPYfc!_7S(eaWLm|fp9 ze4=miaZJWDADG{R=D|Acr7Q+^`(4t7kaV`;{u!V5`T0af4m^+j70>sM{nZIGc9aAk zj8vBL?53!t^~9su%>LzxvrE$g2G1@ZnD>ji8!&o0Zs7f;6y@)S?BA^OV5GypAFm&K zl42EY#CZpjh5tn$ynkW6@4zc5(t_VFQlQ?yY+ZnY7JXa~Oo~&49|;U6R&?ygMcq;H z)kUcz3;V+3154_yt9vHFI1%iyVCDH=7*b8JtceTH&-;aeg8v@>`}aEW3+MHnA9u8f z=X#v$1;(u+j{+!y)k#bC7OR)myf7((`-#3`rkI8PJBytK%0g|*3$Oe>PYP9@IqUS7 zJTUA=yySOY^plIC7CjE4sMVoIDwl9|+0&fA{qQ`mCW>2{KlRYi`Y2Pup;kzX;`xVU zuwiL2)FYKox~NODT58DxUX+T;X;@PjON^V4%8Gt2#_p6su&$KV@2U4iec^Ut`D~it z@?zkWo;%t*Kk^ z9kYa<`AT?V{K&z*H32Rdnef>$M$`{`h3367VcBzw@Jo~b{a=2fpf=$swa|n@Z%FXU zRDJQBS=enMcZwB@FJsn=?RUu^*11^J5E4&e&dwlfA`It-T67 z{)07xuyjMLfSynC4Q@6U{;wF$^ZRN)QzlH$b18&*=6$_zyW`4&5G=o*zEA6kJJ!TU zxt=D;#~q?)m6DzVwjb$ak3>y`?vCesL!N2=enPi3&Q19Ycw$o#Y0hsdIz*hB+Am_n z^nTa(dvTvnAyj;R@BN(e#QOWx42aXqI9>^pO8NYfA1-ym)a{6&M*wWt@9VH$cz*CI z<)Zn6#&gm0m`^r7VL!6hgZ<9lkD+*O51!YaUk*_e_;&XGG<~1HZ;JnB@LdMS1L^jE z6#BJqoQ9mUU}(6JIsJ>!G$apBe1EE3-EL1MNP;O}{6PC?8lj zePPguV0K%Gn=|0~k%oaYIppzRr`u2-2=5;788WXTvLj&J)2uIm>*Va*so=|1`Ao^~CYafB-0>xgfjCR=H!YC8K8^ze z6cwL$e;JeZ{=QiYp(wcKhn#2Y|51wM9N%B$`vy%F>L%io8ZQ^7HVB$gRs=hyY`Bz% zYq8_UVuUl;uN#+Z0G0*Yzc6T4&oftVzdtd;81MJ9eor4q(R#vis}rVN92)PA9RTM3 z5q4e?_p{ofoP_D?X2o4Zl2@u9-Aqw)=0Is%VWyyC9nk|rYiivJGU{P>J zjK6rCnKu4CC3_*)E5vAhzYJL4CIJ&1@;m};Kr%N z+UQUYIlV5yZsv=TgkVnh(ifS-y_oqF?3TX7bC6X*(-*L8ZoriLqNzZYt-M|vrdJL$ z$==@bvITRzmvrf9njgQ1E>254H_)BXJVnn>VMvo6@;*;9?}76J_m_g3Fr53-6jAm2 z7%2gUE6YK8Ml@km()y@Xz;+NUjJoj5@9&rPzbVGu);phd_bd17C*}GhC(Q>uEGNys z%Ja|ts`A77{LcHbI2e2oIcvV~L1gbAV(K|x{9@#y3qJ49!Uyp9oYifEJzlo(?aF~a zu?pROv|v4E-70ZmcW*q;tMfH;=1WqIFEYJ~y8a4QM^-(rj;4HHQHN2%>e>s3a};8L zVcoTJ;r18&eg9DWl3j()3OlQmH`mI{JYu)Ut>E1qnFn@Nz=`&#PcL)2vpQXa_-OjiJURfhh$)lJeL4n2nQDHfhb}3{_xza@; z$T}(RE(y!6jQjopp2V5~aOt8f4$WWr2yh)m8FxQA#_M?Z%QXtfSQigG_=fqps+{L} zJGfxIO&wbh9~O^f&z{ROP;L;}IrXruvU9`}{kz+9=}EuB>mu30Brq7kcUh5@6Q}Y-^$@3j$qwF4xOdE10S)IbU=g zbQRZfod&tqQe8;L8ISV9qJj&%PMuW5_dypd$}-8&jLhXwXMVUC#$lZmzP(7DLB>^hR^NtgCh3u&mQcW~}U(_d>?=P+ZuGkg5Fmv7R8adB*kYq;lTe)+6+tlSeEcpqzsi}*56D5NR5 zDnK;Nm}r=9<-;XVwR^A}YnsA($g)5^V^McDR0T&-2bmbsg_54M|aeZd2dqMRmAs>9`g&zw*l7=*EG@^<==D&yZ|S z%A-H?cNI5J*mVgDTtj&wu_XJQC0;onWqp&YGV7f*CEc)+1{L+L)Mdo=YS#Gz11cq{ z_OB-Gr@zPZ7;hGOQRjzPc-|Pt_4quI1AWhX>bwn~=WXGhMugN}PYyHMv|a5MZRMgU z+Y*fxKQOhyrYvb{w>Y7ebi&x-#ufMbJmm^=pp&S2DJ#48XB^E+udYxjCzMH5m)_5u z=OnIB^nIQ%^I_pNz2oMBO*zdezVrKVEvev2gRrUmPuB+`UXMxv;W?L1;RA+@_obPLvGs+UD z=EDqZ?uRs^)~zXFenThhjP3qvN^Rno903EPJoPBT}3( zKEL*DqX!}GICWdDe@K&rp1_Rsd!Cdb${f;qr3+vDQl&``oxq7!D&yNLW=8Z2OTSmf zH0=-OqgL&ZGrm7G$c*r!>Z;yEL)97F81K&D?k{Xzm-)BI;5Lo+Y70{t&-1TwVn|g+ zxV}HW@8kUaJo9mBp)1#`hv(A?i>G)z9-h;~Qti#CH&5(U7&kRO+QUA5Cpw<1dQ_GN#tfPxSQB4BhAL*X&UVo^npYsiA z!o-)5$BO$O`JV5_zfg4__dBw!wPD>D7(DF50L>5kIFd4;`|AV2MFdyR8AUwJ8O?m& z8PO9w%o)-0DPTOr6P#haUY;?ED1;f>MHJ)=X;GM-r_ZIuJKqN;#(2H8N-OwR*9csx zuiv-(J^FY&A9@`4zR>=1JU)JEUWs+qTM3hgIs<&ZS_Cu9i}ItHfo`5VvYwx+2>56j ztO&4F9a$9gsUUc430wtvA^}ILjxKACZ-f`nKAsD62ccc)CQceI&->x= z_x0h^MQ()D@02g}TsPFSbG~ld#&IeqU zS@*Vn(c1P}ry5tUze&wZbwG2-)9oq?;(XHgNE03>SMvMgwJk2(^n2<-Q{&^cM$yRh z%Go(3clmv4ihh26<@{V-m8i-SzRIzF*U_(a2;Q4Bekhq5nG+4GK<&+kE%Sve62ayJiUb7pZ_WC$?U zkd^hrjOo0z9(&r?n@?PlvN4k|uqXq&0pnMG$IJ6P{2!rl#%7pJniOl|{?Zy&gg(KC zSo+QACRgbFS&uL#6k8cLMG5;DP<-t(?^Yu`~6YuNH;C_7~54`FN$6w>lDK|`<;`^1E z#vWGkY%AkdRQ15^Gd}M76R7w;|7g$3IG267R|r{{7y3lA06OxzImqdW7cl{2j}uFm zV$MTwMKq$;7gnA`ve$@bus*(Ysuh_6%p7i(-Pz*e$Z@vBF$LH_X^|#EAK;AwT0(#xKv*8NTG~SsB3XiLr*FAypZ= zRW|k-U$`j)xI-Jt>wRCj-;exIh2~R~jTwr8^ZAgUj`N{DobUR_eE3o>`X2Lni~P7l zF#V39obUB$b4-Cb>z^;|{mLKv!|xLfWNSyOzVlITTQ0H~o$*Y*bk2^BuDQ5S63QQ@XZhw6LpRA<@2jhLzno8+6f->Z!A_c32%|jaqwc`CKTRTwPD|LaPVN< z?2UtW>LY{Jd3z5+&z}{h2gZ)vE}>YlyQ*%=t?KweeW$7e2eU=0@6Uz)^Q-_VsDUP0 zfBxZ(!v{w81niiq4i6dLg6b~!$V{#7@`;R?>Mr@nfbkizUZ+ZHXBW__xFEZXR#kgb zAE~~V0rfq`JHhS>%IDL4{=82;IrzPJ?wmT5?rfF-r|>NVq336Q*Q*W1Lin8MbH~BiVP$o)OKMeju)-5mtu^a)>T~07kc%lFX!F(TE~r^2e!GbF z_k@v2P@NwIUrp_Ie-Fm`hH6CNs_z&Z=9(Hm6zvQKjgo~k<-qC9d1@WJ8oz&JrapZX&=1S z`o3Zq%&w`53bH3=buNc#lIw>J=o3LT$dyCvfmxkmf#bud)RNKAhgL0ry zZUu4|OcRl$;rWh(c(s8rm-7h?&}`F+4vtHXX$7}ibxi3a$Z(1&Nmq0W0I9euKPEjo zr}Bv`H<(XTo$)k8WjDX5KDt2+ykC7;0yS9Xvl>_2jQL4bai4(4SA4KQ#2>2geB zF~wKiH>=Y z(~dHK1Nkbl!g#r`t*rfpChZGZgv~a=QbrGDfA25sJwz^VRVL|$-4~JCYmXO}tZndk zR%O8n_8u7)=VXoyn#BHb7sIOC*xALfy0hh!KHLNc^k?VXRLq#CG-bEBOX3=jHq&V5 zN&9KA^FrNLdpeP-(EUdpbQkJC){!L^x>dMmjWYv-`o4PE^di2@jEf@4z>I_s`F{(}&Pj zU`J(IRb-@F_Hjj&m5O+Gs=}2x~b`k5kf$yQqd|)@`M!E(3NM z8ms)+XY zr`e}Aj}NVde01n;(`c8gI-s#; zeAaVE(+}=Xb>ha5p5!5fSG_0gC-l>v?u|ejgL{?_6;^A{x&a7Y|8D;n^qsEEFP?u- z)>jy9Yph8xXrOU+K-GL45BUuD3Yuc_?5A|^2S=`1^Nm2T3hw>h;B(E@W{B))hgJR9 zlnci@owUQJTC!t@1#cSczSS0-y!*~pWQO&0f4}F~WtE}fM0DMijaFJ4_MK6Uu-2FG zJim`>%We-P_OH8|6JBYZFz+{i=8GGc+LAAAfWnsEH?$wV@kjfU3Agp`AME0LA3H3H zHtzF>;)W$1eM7(@_~Q02yrK-9-Z+KEvj?YCZMSuc{@f8%fa9*-I~Zlp3v7ty8)1@Y z$klfZ7!hxEUGt4W@O(5^US-iN=Zkt=V3Y6%!^Ut$3dxxU5(p5sb2%zwEOu0JQt8+6*ZzOzx@ z^+OxI`voc0m@$0$$6CmzjXaSiyf4TTX{ux>sNHGpfh)9|DtNwFgBu!} zZ=p4omiat?SG06$@fSSx`~qDvFGU`=*3th%KEu|pN3QoTyguX9_nw-?$}`lsc-dQT z*IXmoMF;esA(qzEyFJL;bXysm0vq-{HKROq!1}+Q@AHJ|f9t|q-@|i$FB>T+{mXs6 zflgenx7XKQe~8$kwTWVp<;> zgsBfP&N3xCi33ZrHMzzWJZZi@ee)2yQJTwEctmCO9=JX`2OFQ&qf2SMe=5NmM*EPO5YjFW>K*ks7|=1@i=xq7VuCo}&cf zN{(8@BS-bTxL6|>k(J!C^ihAGa%$@NLsPz$CyPr8L*O!^Zh|NRIXivy)f%g-WXof7 zv?@t;t7c&Z->TVoXN*49P2JgBlb<3~1L+`b9D}KM{J0IFu^gb`?o~+uX zHt&0smUs#)%92jl-g5E)zkh&d_*R#|iOYN4sU0Q7NV;gkb*j`BIfJ1UWknDuH+(OQ ze0kczIv%dhdu5FCIw4tTBgxy^b;7iItEw_dQ?4pakHxofnEu^HfBc}8={nOU`-V8% zBuF$&5q{Si&nINml)L^$i$ryqlv|SCF`ySc=bhVCND@o=?izDv1+j`{eIft zt13!jd{&iYe>I6YOp$p0`eR*H3X1NkYo&j`s0y{dHu$uS+w{H$47hhk%@?B?!7#=T z>7HIsN{8O-fV;zrsbeuWszOj<2=u%@5`sr z3G=+VVET+apZeiQwiRl9es8HYm(GXx@Hi&t`EmcN)<>TQ@7+nFAl_|-%8{;IT)~PN zFZx=Qsi61C!?2JE+kNj&l6RX`#MCQf8xfzo@sBY{<2Rz@T@ftYwRYh2;^VsbcgE#s z#a(F8b#v3CjJkE!iV6?*23+<65(ALGV+)==cbj*>UPPSeqLfxfk)q1JD+{?5O_`7@ z^)RfWhz*}dHj5)n7j7D7#Km`QeXQ3Njw(08il+qUFAmiR z_wv{(t7)7ythV1-J35wLwu z9zz_sDX(FlzzF35z(X>s@&F9?c%OF{XRLU*_6m2pj(+nb4$KZZ{{Fn*KjTZ4NqFCM zUv0zf{r*hK^C0YddNXMVMjckX_jnX_?&gfktrk1a=bH&}R+v?d1*tZ&W{gbMku@WD z?M7B+#?tQ@hev+A#??hvzc0KwYpC}ED~EM2f?>@qt>PCN8u;~OUCeCc& zR6pI!XTIIiHy@h$X7}tBO`jojx%)gM`-Ru%{W>GP?^J)S1K$P(mq114~$_UkulNAyag?yEF9hp@>+5Uueub ze(+q<85f(ykf)9JqfO`2z&9*Tp!}XGS%3?N_KdUW=={Fie4TAy%;Id^j9B+jg&u2- zhAVTB6Yd!ZmM>ATEFShAp7K;_T+&11>inZ|*CugX8BQ1Os+HPwI(7FcYuTo{m*KjF znB&fGORp)q%<#2N*G>_BYOT)map!m5=U&UmcbU$=x%;JF%LymwTC9Cy!}%P@oiz1sZ58D(FfWszxW!xLO&xmIl+jB-BB!8pT^ zJX87^vsLDktuaB0T*_9N;0dlh%UBO<)gWu9>T;OP;`O7+z}+9TzNl{+S zhM5`G3z(TPl%b~QMPs}x$TY?3LRlaiCI-8^Ii(D%3!&Q?qXSa*K2QB!IeY=Xv1vNe zU-N?(V>sgtne1LKdzBB@10%z1s#>!wNhRktwe{$t%#E7PTtQyOlpmJ2kr^W*8{-z? z35;^JXVgc^bN?@8;1_#iO11LJW1aCZ(u)b}}<%=!OMmq6}3#F!N;0n+cN0 zH8GgXFBoxnNyKP!Ol$L`7$TO)+6_` zh{E~%qWxztc|>w#?QRO1vL2CBP^YEzo7FLtSvlqK%7JJQmhg*_f>nsw=Al5lT zZ?xXVUh&qmS~kadvpj5Bw2Tv$7Q-wOV?ZnVeh7~FSQ-tPSKcqyu1>`U8}8XLhO{EB zgjq5ny_`89A&Sg`+j?YdgP(Xzy}xRG&Ka4n3~bFFq&Fu-UcH_3K@Sku(d0kZwyS2-Ex21ygJIjN5YI@2Bd?IxUZUzgNLCtHx>BRAm8i zJe1W#+de7lr}yW3%u7%{-nWJw|?h?WLw@1YPqGcY`rlS3ZFjEO4CgF9L!h1eS&w!VGD z13qa>apnx&86(GMs&mk2`aQ?Hco;FL|Fr|%Qc%xR>J?>lr2be+Al+w&hoqXvsmF(Y zPd$wpB;ymC^0=b67cS-dJl8*Dr}%vzo(A!Ec|J2v%p;kxVoQ2VM-hTB^>9+ul$7Iq z=hyOMhLock5dY8fOTG%`dnA2dS!R=#*og-IaZc25A8u;4&WIols4^Z3+10F>Lp5~c z3v+~qGSYGMN3*Vk>Ct5di1jeTk}}Gv>921BOTRpgIZKv;>;-Szcox~p>bW(y_cJ6NSX?Nua(8pXg&gaY9t9>}9rptTb&g}GmxidTEraPh2!|R+J+9K{$ zE}yxcr)A*h4^6mRz2V#W99-C)(RqTN--2y+=ZA6U{2U(BZqClpbK1?JAQyEn`*Whs zqGFs&w^nI?{eAlQ)njE+@9_Mqq`c3I7)6XQPyCKM>yN+p`B<+R`rd~p%_e*qg6r!q zoVMkibCO@%Zg$yvT(3RsUFSvboX?Yy%TUhN$0N_2EzM`=sKjG!|3Qwy8@*j245-Qx zVf40WJdtLRV}hKK(QeKGt>>5~V0}V6wbX%$acv;FA+$+eP~$TWf`+EOS8O%Q2QUY0d|A z{nn(JBQu?qRi($J^gb^P;Q87TU=EO_E^~mUsy~^tGnJRQXnQK}a+R;gdS!W!4AXn$ zEHTAk#&ohd0Zn{mWpF@FuB_e^eqU3@#-7n~ zv>!Zf73D*Kr>%1P1Md@B<@WyAJGRQriPmGI2X+q3=5dRf=II5}4$SNX@RU{c zeZ>A(RmKP~V!0nMD0KPm_c)s9a*mB*t{0st)=;kvzRx)~{NB91N6!4G)(4O5TI!X{ z_4%gr!^3MzH)H1a;tjjI@Naz^uF4J0id<${0i@WSc<_UVE9sIHs-%! z?#B{7F^6dhU)`H#&KEzCcl*M`=Oz3lKFhn2;E!3VZ%C+9TjC+i23hhrv(xWNH#?-_ zjm{n+1-er(DS$hIsNqtKfHxy7*5$b2s{u&yv|J;;QOgEUsI4bHb9I#B7$ko+2*pPS0n) z>IRsRE4!S113hdxy9fD5>&b?hFV|zYmb+eJ*t*~QO~hRJf#-Z-XHK$z%HhN4w{vWZ zn%vuYh%fUE#4+D?KegkZ&cbWm?2hxiZVzN<-6eZDFP%_PuZ;n@Uoe4kEki%?3~~GYmz?zH)+)5-r`f^ z-Vctun+?bB{$kwOIvreiDm#aIL|67qi;JP?j6y!od%lquYB^A-S*hZI*&@q*L#j0c zWlIo4maJQE0`sX9p^!qbEb*^>*d1d6`5DA(}4A-S{^i$6P7@A!aj#_vz~mjDY&!)uV+3rfGQV!;m?UqPtYLyA{$PQW`pJ!jkf0G9uL&5i=yYmd3T-;eDBk#+Ij(_ z`PL&^mS&g~?WZ2n;tTWMaYU}nW7#vpav7bk5071hTY9XKc4+WoSPMNLiuTjmadiKK zp}a@knqWi5)l%e*(fy_Trq(P4)u%f5M^9;#y0Se4`yO}uJA5zvS+6@X@O$pz44>`t zJ>>AAFZnpph#{6T#4dcFf287h-+XwezAqlG`TBgDWTv}fcgQr(w@Ht6b^|G%`*A6L z5T+ib&Of~Q9a7`ZKf3ANG$q*i71Si1e}S$omZ~Vhy_z0MY_Fz`65gwsqm99n0V9@?+e zUsycl|L^(NR_q~)b{B1GDO_&|1D3M|UcC}co~{Q94S%ktifo6P)JF&ff3}@?Z@Fc{ z&NgVK33Z^52L&sj)Kay2@6vnRp}9j(akPKF{(|1c^W5W_Tz#mcMIuIZ!qnrMI!5Q$ zLvrC&UszJ=!ip;lWaTa1NV{R}F`|)4*2~aM=fLhuB+y{EEx7upd_{;->azJj>Se`FwnCIzQ<_qsSU&G~Jr2?pPVN4d9a- zQ#fSeql=P5d(+){K_w&b?AHmdccUGUA7E+uyol9TrqjVbMt$CHDAH< zFCYkdJxIfvvGXlRL0R)9mt;oCkl(y%Tok7De{4I1$gUp24js$+Cidslw?oV20K_17 zxiQQhGE26r^B3rU%Idg5uH2L#G1}wN8q-`^^G`1iLqd2>&W9NCSFC#Xt0rZk4$6IH z3n1vdVSfLZEE{IUAOb%Xy+r@~vraxt4fZ|*XW8KSJdW{z6W|sh28SL#XO9rs9X&hi zS7kV|{iTcuMh)_!jN1th9E1mckBCh=2_7GK&-q>cUs-vt@9U1NA8s`KMTfZL>FaJqaOGNg8P6Jc`vv>^ z@KI}OrKcHoNY(XMxGBM4MzqR57H;U>8ypQ`Qy$+(BI`mRsJLTXJq3;3;L>Gy}B z9bCW);OC4X+(CR&w^C-@I$2|A#}>xP*E0IX@Ao6#mk$zE-4V0l9UraqlWzFzV7b5F z+PCf>F?_lBA z+al13{=Bac=KB$m$1Tzu2F?)HEs*>9y+gWhWWxu6=?UK7FW4c@7yPEG#{w#Ot8dih zdUY#M&ZM5A`FHG?cNCuPN{eyBn?LC`uT0OkZZpfclekvuei?W8Ro(KKGwHGG_g&*$ zPs8^aSVC3Zi1R@V!7b5yhy8o)@Yw;}DqVH|+J?`L zaD^GSR9D@qm~o+c)vb#g=8l2?;(G4tJCaL$PppK#4-CPD@8|oNU&Z^CV^Qjtt7-gp zQbDb9MX}PRL2wb>JhkD&2h9a0a3To@ko6GMZhT^k5)ZY^S3;F68t0C}ixl))ce4nS+`%J%NVBhc65q3-GBBUkZ4hLVOI>v^5yN+3?vR+Gshbc~9*C zJW(}i#tnQjYsRoibT4Q|AO5Pl&J0)WSd*R#9KA5_zsO)fq>8=bCE1Hp2YacyFD`@q zT&l&jv{yRAs&_5PZ2Br$AMe zI4C|`llkzwKI>XR+f2F>_s3i_rnoG3+;Rk56gQ>b^#r+6(fbCtI4l0o^Wbt*?~g}& z+%R<;&zF*p<4eW`P8_In?E|h~H@oir;&>+&Lv12o|6xESUy+;v@?1HCsa!b$hVYD6 z?I2bNM=6QCk6RzAbjo19}{aSz_vTkb;-{Oe}v@!2c$im8+ ze}VP}u2ZY{BKT-+;xb%MmvzVac731o>5@ZS-;lP;?+?jI@DRbmpgOeQ+%L-Isre!= zB&40i-U*h>aa1uDuy0{`&+@uZj`3jmy zI*|$-kbT0KskwYBUz*U4rn{qMKH7PMl(7_O^dBwT;5|P+w%-nS$_?3&h@oAq*YomN zp_O*kou9eWqc#76*L^;vX9b-eCE=9dLS3jQ$zkk3w^sox?)EBx3!jt(mX>+na1g zJ`XR6t@2L4QMV1(yCe@RqTVEVcm}qJK*wmTc_dXQOf2J>2k0>AOai)%{2GXh{(pB! zUPZJ9uDY2vck=~d-GH55GvbIFre_6T97$NhJzBzZXd``r?nFn3`dnGtr)BRXOxerl z$Jeuis^-h-`sLMv&-|o;BMy1BH^vbwt4+@D^P|n68Su5Cx@|JgufD!QH0!;*A9oK_ z-8X&qXFdAuNV4fbH6v>r^F^D^>scD)%sR1=MRk0Ck#-6kM3nNJR~MY$^UBiC!N-Or z$@+X>`uoV*@1f`E8SDK!AC4F7FMFY6+;wrOd=yzYkTipyxp~)fzNcD{aSp1sbbr5j zLd)OzH_`k6&uG%-2Q0cK-G%ts%7c&T9S8pT_Z>EPlkD&C#I>xu=`z~39Bt*;AEU{_ z;tVKBWR)VyRzv=7v~{@_*r2!A<5TYgUq#gFzJFfNTP8fFJarq+dLAp7S&|ngj^b2% z^7e|BqAw?mlu|S)#}XFjjcZ`vg|^M`t_7d+WoRxXO;$t zGeq;LTBZHWB5x(;H;ZIrrSA-Nm89F>isq2-3}-NhtUBz;9MWO=#UZN@d;`7cZ_Hp0 z@nK?#bzrP`c3GW}B(uX`t23PT&2hy|zCL21Z7}Xw10Rs~FqX`Ecd?`vItCcqOhEY{d1*?jDvoFqqBBluUmb7k4ctO?ADsBry7=f(ZIaz*2< zivu8+e~J&Ho~TT5HTSv8@sDHHhSe*8-a_%^1LFkPsdCARW$yh{jEmz_8a#V*PD$c9 zUs&BL_5!pRaWiq$^THP48q+}nzB+2YfiK|{o%v)!T5xCWr+AH!d>HUm#cYs*{+#$wE zg(JAt)pmUedaBeNAeyXLRyQDsAIgz}ad*ZmVMdbON$^nd(@AguX6L!7NODs3LR;7B zEO6`Anr?MM>Q{1~Y6ehosG1?c^Tqj3`3n6#+80T1hooP~@rgQ?ur<+D-SYZbSRLayGCL=l%biY( zf5Gx4i$dmn--kSxs?K}##>>Jzx4w>d{vkh47sYUY-J7&C0;O?EMRtY^@tmPvndOO~ z@RnldW)v_>d*j(@(p;F;IrjCQ{fn!2o&D}tuk!gm_gPl$81h)FV~Wi7ufkB@(8;_S zRzoz!_>!tIU@Yb>>5dqeg|FFN%-IKia# zznXD@li0a61q#&j`}WuSo8F&T^;xGf1yFN$;i-BMdT*;>`LR?Fl3$)$r%sqN81fQj z)x*f5Hp~cAeqmQQIakB)W3GhcZe60XYJ&Gzd(%X4=O%({-2JZutv!FH+uz)B_~*X8|Dn|t)ltro2TZ2d_Wx~ z6}fedMS1u_>)HXs)aF=oGVH%q$H=~}eRggQg}ug#iYZRd`AkU`o;h<3T(e@y$eJDJ z68IKU(otz&*x!3&`RDzh!>;eso(hdqzvli-**AQiRHF_IxDxqF+U6LM_mkQ!Yk-(w zC|!^>Eme1`wI)B3Ykqn>k_;U|&-*iB`pw)yR5bO}=sf#XMb*B=mauQJr8n9&Ir12& zW{Hw;%y)j$9T~4sM5HjDpr|Epr9F~T_(BhbZrAG}PL4W8T*ZEOM7~{BDfMFSw`yFN zty0xtlb%~YPmcooGdd#Snj7X18P1SQteHvr9{W);1IyntjW5CZ$zWAYkTF{0I-#B< z``Irt$--yH&#WC}y+GCud%cuQtWPM4J9l*yE%SXobmFd|p~t`-MoB^LF#39ecZE%k zhpTt$Lc-V!XTvz3QQqIX!sU+Z{q&H8#_0uPKg=dC+0^qr-uXA_YJOj1G-AH*8_#<7 zxbEs;O;Po&yRgQZYq(&IHRH=6z3myz+W+Heb;nrv!0tFbx9Ohm8TXyIj34>?#E0p= z?IS5J3ww7sA~jX9L!RUgp7b#=-#=UXcZJQX{mWM^9z9HP%;$Hsg%u>B*vQnlVuGRZ zS2rES)>VJMCmA)0WSlF0pzgif5)q`p?s(C!28|L z;e>xHZmRx++c(OAeS5}UK~n`xImKNYrjG?)R^MmHjJ>8RH)aU7`S^5x80H&C3%q9C z9V+0Z>#Fd;T^QAO+{PiU>N{}*nqv>ygYZ~%^^gr$gJsDPKRx!(hFNm{=a@**q`#do}GyvhT_aeF8@za$I& zV7O=wVWYji+}{(L!l?Gw{xx8jx(L&Q(er)(-rw%K8}NPK;flK}s_(2tIzsJn*LTj- zw|&4P<$Jzk{Y4@0JL~t`8Vg`h)m;RTOS+w%w-?+uAkU*#Si;L32HwMxo z_71_UI~b+g5`;nWFy!@|06iRSxSAUx_;8sRPSH9=2B*1TLoI;s32u->zC{(cF;w3h+@N`O*+#hCp?3Q`AUC@- z&pI_ujNtq|4i7<>SF0XoPW`ktO(Gjr>rpO4jrH@U>d@GXu@Hi*r5~ zi{V-8_3p>Pss|?4`Ob?J@B5$&`8IPXIknr1HKc3U!$4gl8D0<7Hb~z7+@Z06VZK9y zTw-WGJ>K)QB=`3V`0BDno$h&~3r4My73hM|fpb}1DzpMwpamzu3Uyc*{jq2{V^*9a z!>*^lEEvrg#Bni-7I~Z3;-s$OJ0i{s75$+_YTX0GaWR(pX})j06GP;K!nMrLd?CBL zq6xSd{qRj&lsIu#@Hg?vCX1EYrh7gdnzn@wInWia>m9#W2ZD~OxLz&U7-1aplm@a! z$8*;g;jD<{K9ON<0og#q@eOd1;k(A5&kmg^>nnz}5#%)b?&E-@7>-|oj}Fl+?nHh^@#G$**F3k6%;$_H7S3qOF zgMt-I!!d2n&-M){WVCBvoZq_}8EPMfdRwu6WvG*p_E-J#X)pK=5}mJlT?Ht>-QqR= z*ca#bzR3(y#NFx{u^sE4*ZID?$05tW{rGV=-2+2X`yQq;zwaxE|M>=oGBEDjAE8}) zzPLT{uBUXbw|rrF^=N;LrrQp|^?Zv6_4y$`Z9wYz)(=K>hjbC7ADs6&!nh6`iV%0e z-THk!C+3Lqp#a+(@PqnhB?RBAZ>2#3_FbW1-*yNockiZy6uc)2KdtYe2xQ0I+ZUTo z$o>2(Vc9S114Bw(j2Oa*+n=vLC&&o0?=Ohc{-xf#`;aAaF&I^o?oQ7L_@xN=NZd{S z!a8vT$4O(jO>pLi#*hGV-^hBO;SPE5b9zRM(0RtJ7xIcKG`As(4Z-K?dwlApDcLs} zCz2JBJUg+A9sfc!n;r4Pjy2gcXFj$*;FU4YU^U8JFEP;ZJxC?rsBqz_h#}w4 zSP?8%-!fC1Fmh?U#e-1@Mpxfkguh43HV)Uas z<5%}?;1VI-n{vR>E^?huw8vD@pa~2|PoR67OEq&XcSxh0atAg3-W}7TUMf@c$9Ft5 zb$^XIUn81PDo}hOpMhad(vKpZAkTrTO$NiXxA|k7TLSm)1+`g6F`z z*3N>IrS$|Kg{5w%X6OhyasqsA4a*Qm#}0-177jSjJ}@FM$Sb_VG@njZ{Li}7!Wx{@*>i9m%!;(6aa$K4WNaMBg!Pk1srn!=Mj3;yVyFe;kw$iyX5&G$Ov5~+JmfYj~|a6b2TESy^_DcaDr zgR?yNxa07G-QS~9MYr&tyPlBy1H}KuZBy-$TDYC6`6irYxel7Zr>|y#>pa`N8_C+e z`&o?-1#C%m-|s~pSb`}-NCEJj`>rQeCfxhYmd-KXFGdVA-nB);jK^)!@YeheMR*5r zo$3Q;?LZQKsOj+TsiJe4cRdyDIPXF#;$h;8GD#igR<#Unf~gyNyg&F^^~+&;pZBMT z!j&(|EOVc$3)M#V7gOgPchKi7XFQ|{B;DrJ$0Nm<_3pch){xZa?Mz*#h;PH9JwptW zXO$m{+rzFdxscy?F>LMKw{uZvco??P^ zO0g~4l$TWRYxjNhz%0#|9xT3}nw~r~o0{MQ^LgVV?MKf+^TsyiL)+CmEVz{CRNRy? zUT>8>PkdH!yl+#>;OM09(OUHFVEsb@RUQ#=z;5=iX#RaXG8v8FFUO*-`n9&ucDwnO zR>qTHbEdSlp!$9KIxqr;P1c`}TNZ)J|rhosxK!UvcF zc1%6vdB^Y%#kqSlWBR%+Np%=IUmsKZXZ-AtZci%gO0<=;U8cTApCCLwo)YdV#1Wn#|YOrd>->W#~x3muCD7afXa}?BXA9q;93@39%D>0x` zkUlft%7GI4gQ2Y$_c;~soec1cyK}GJ?>in~?QZ+@U>(1AO2m#jO9GJ-cjm3=AK_a) zm@}|tuQSKs-dKS6rTfz(;i%m^7l={cxd1)UeN&Od+I%k#(t_K)vx5|FuPbs{-5Ixf z$L+J^4%>&q{QYn3|^_c}t%in>NvgTgR%o*5E)_m}IyEzDa{*y(2@2J2j z;cnYVLTvl-sd4^UKDhDFynJr=Rt>}|FFxQiGY_>cd?rVv>%$@Jn6ig_Y>2g*BXGw; z^W9U7@ZUQ)kfZ;?u^)bZiR1XaB@T6jeYb}~7=d@MZ;kK!{vRp#lx{Q`_BVErKD>=D z%4bFyk>4DEdj|tFC-)9+LF`?35C)uo@RQNL&Um>#z#oQts#;+f?me~p`wnbjL&*&yM#j3U+?Lo{!8! z0e#y~%>u{yK3L~lk*W^se)q2j&iB~R3e=mRIC{lQ1tEI#0HuFK+2_+=cCvH0$~N$PK-JK3+M_SYA8Ig`p~n;DVWrZn)obfoF|WOdI-8vZrA9NQ#UKT z1Y8y4FOalLG5x@Zb8@>+9*rl!Ls{<&7;efb=%68Iz32VtA_MlG`I>&;`+j7{nda!H zwDw8A?!7mHC;8*I?!Z^mcms_&>!0w>_xZD<#CO&XU%x4K*nZ}ai}}t!Rlwdq!q5K2 z?}eWqSN5bzCM0>C?@8NSdm7qZoKd#k))wl8q?chhad zW%8ub4B1V?a%GaoG-G=CeD^8>eUwXpgTk`Be#kD|!q9}zW~;_`QvWYszp?ExxW^8K z_?7|ME4){sOZT~c3$N>k9n@C+`yD%yG){_e*Zh?O_WMIuAij<#y^3cM z!JSnWNLHTzM_--DgMj<_die1hu{S^%R3f=qa8rO`)5;Z;D_) z5?dVfocc~I(V+C(<lYsSeQ=d%XwmA|NwubIqNVxJh60VTe~E8DS+>IM>7`BAG|u#15_v+sMp>!C#?ufQs@`oYB*zg)X2)>k#yy@+Nigw=^mRJvEpa+mD($? zZDH6KODnd>SIzg^*Uabb>!#EoMXj$@yq0+O;~TeCzm}xb(C?`W*;h=BmhYqPWncRi z20?*4P}O~h*G{lFWC88iitgJ|aG+eT!1l@AHBJqhp2IASnV!=kuS6D1o7Cf^V9o~_ z#I{j)5d~w%*)hfxy^DMT^pqA+06mpOeyFMU_x;E`T)*CZ+slP_yT3mc*wA>$%zD39 zUkh$iQ;~&-4me=}3SS{(6|2}G<9m{Yv=jF0p}%;)dc*C^ z;q~dMUHS`pxOc_!<`39-hhw&MN&14R{o8kr`m?R<&rLs*vOi&XTu&(P9odSGY-%RT zU&U58-vGYprBEFJgmqXKgD^d*NpPH!_QiMUvgsd~~gk{783)x1ukc zk8kLX9p))?q7%?`@>JKZiXC^wVZ{!M%hB`afg4uj=NrbKo>4JFX`*PXa^R}yL%0j`7+6Q(9a?D5PkjC5neSELo-^UIpUR6n<^+s0?hI761O?aQz!}nKZCPsNXd=ba&3w4=^hkKapEMOU<-2<^`x#i&Qp*}o#a z2tB|aIPBYAZXQs@$(uWUOz5(8r3|`i_3Ro?!tzxMcKif9Dk;J)T+a;P9WVLDcMcC0 zc_dIH+so6H>rg~_;#ILi$D?pA6z8Z%7$U|C;lPl8PguTiblp1NAI|A+F+b1etgonY z2p4IE)YLdB`n^;A;A^M`momgPyFmf2&XXH*A;>*h=}1UT?e^d~sP^?uL{y|Udpya!AbF*c;9nJ`vOL*-bWeZ zo=tq-6|5RpMP=4?#TngrV&5^ic{@LLP3f>pLJav@qiHKM5z+govY0B}V&~)4ti|3xJ2trps zFfq1;q4ngL#}2w?7Bb4?6FcVkPukC^(6e}iv4adL>V7#q=N(Tf+5uK;7ExSR{b+`a zyY-@2uj5M`U-=!U{{+#I(xo{dIucKaM!RX~jjuc_<~ikC-@D%DTgyX=j~juaRN{C8 z1|+2sv5FllFYKOM4c~XfsYwdBqZKuk+wrP>;l*=D^{^ir?L+5UQ~hTeF9ylup6`_A z;#djSTa_`LfiKs8R_Fmu<3W-2#%3xsL3gw&&|Hb%h5gAlR+FLYSJjJBvvh~0jrXys4M{G{7!{^CHvTep5NM?5sMeCt!=jjm6fj}%6W zflEQC0q9vCjbYt4D`%Wi*s%}tuygu(E;Z-mr-!0ZFn^`ysFJd8>?bg$8i19bbMeBi z0hq9!l431E;q|^>6fxfUh(Z{v$;x~hlnL%fLz&`ORmP4u7DasN+#i%-UVk$Fo{m&k zMhcb(P0#Q9e21RpaZ2g^?oWB@g+HglDAE+OY9i)(G|N$~2QY>_a8AIQz^(3eJyLOu zFO3e$IPvTl(u^2=vu@8B4QWcg#l2w1i{JrWp3z3~h%0`VcEoppr~Oh0vKlT0Su?%pdGFFp7F^;5=LzJa4lknkjo`U{;hRk!Ur|X#_Jr%lXYtMR%{P?rWdSZ02i-#OLqh6y3{Jb=^ zd24$6V94jpR@DKeSXGrmgA}+`3!pJqHLRB>rmZW^aNB-X)x>~ivUSV&28}TilB9{$ zHx_0O0OG+1mKSRkt#Cw*@Zz30HdUm}cGWSEO9*GpXet_*_9LedK|VP53PLmRJ>&7< zvB!oY#9^WOUU-~*#rM8X_)MOA-NT-9ymP`nalCXw4pJ9Ao?_x8GoHCAIaOD`6SzjX zFPj#cV&a=CRLmK{?w-|sguZc~JUhz=K~H0ruEMPD?6bbT@3W^hOE>EKou56YNnEou z|M^PxjgzN5v6H$UuM+a^&1J+8{C4Xf43+g_MDeaoT|j)eX~XI)LHhCW(=A6I;Ma3> zBJ$S^S44N@=i1DJa5RTr8T)oA=M-;4a_aTOZt}UbxeYH!R%e7wxvCyMn{w2#0cgAS z3hf46MEPX9X@~iHcx7xM?kXQkeb;Z@W>a_axG5xS$0@hBDkJJEg>YYk<@nh_ds@-C zded|0_|e3S6cgVQG;Ivg=2dSCq$VDWaE4P~EE=ai>v8GlfcgD-z47!+CPg!-TMR`{ zXpeZj<0O#W+CzQ~WV+}Lu0`M%#5D^ z>ABvB3bg}Ae5i3JVSrRPgfU{YD56B0^hN-2K#sqdfDzgpH5KXXae5w@I&sYKz_iO_ zmk&&hF98Qxo*CjWOCRc$aK-zAFKWv2Cbvn9(5B)084sBE_lf$5VCvkh5vGP0dwO7c zVgiF_zI>j0SmZ5V8t3Ue@ct?*jq9gPGWEVHPZ_`8M6(=kvZZmbUjZSW{7@@bqDQV=#P{E+W%tup{~+z%rbn}{qlInd>j*v_cz^CUsG31 zF#7);xZ>m_h8cm$qBzG0NuiXR4;&nnG(+TwUYMS@BnqHDC^#pb#K3S)Iw`ROnH=PP z6Xy+_LG+9{UtE}B-<(0Lpa_QxQl@AIOHzk>zI1lo--AZmd|{pxhNt$B8u+~L>yL&T zFk)Uq@23^U{&lej@Mnha?ZEOqHSR$gSJEDs<6PmCCCoje|9IUM?~jzAj!u2;;G8iv ztQcz3T|v%zAHJ8f?8YRxk1Hj9E5Z?AyRqi_m5aH`dx*0n+qc3uR`ET@i{vciO150a zigJ)WE@rWljq28|drkefZ^ z7&irgrgE26)CIp$&6*uaCqC@C;QNR4H?Gfc*6(RoL+)gHMwkmy^N>YBis<68;rZ={ z%X1eO6MtP&fcw#<4@2&1eff?rWFDmbe!o8Rg|Cdy58zYhNVaa(_56Cz(L5D*CcdZk zFKfKQLgD(RY{HOoKZ-6{QXzUw9+sHQG?M6i_fd9|x9(E|@FCjuoEVy!GP1 z^!^pWe4gXfzSxiOz>E`P$4k-&XrO=zPkfca{+~xA{k};GA1>b;8!MUd<&oS1Tl)J z@5$!W{>Ubc`2*(q;Y}^fn+|;BFWeqaPt99VW=f##xcDIae*b4bBvirS604v6ka)kB zA}Y{*T9y5fnx2O?op_&^azPUBkX95j@wP10K_=euERTLd4zBL4Jn+J8TChiOuKC8~ zl6Xg+DrJ-JyaNo=?gQ`n{5~TC((li_iBp}kVC`OEXFPuJ34P;lHbB;PW?T_}iYU9s>`|8OPaC)n&rtl6+}m1(IZX z|Gw`Vm;p6tU}Q0u`@la*Qx_{v0{&rem8%W@805g#N6!wgs`rNyao{HX^z6v0qLMiM zxWcfCGiS^UjtU`O)kU!)T`Qi~X&QSvblMZP_QmI|Phv%;DUPd)f??SleBa8_uEN<| zR}oEc#YMTd74GGVJ{EuDiCAIN3__r+WgGuy4hI#|I97;|Gov z*L&Ip6?(jQ9B}BDA2{Y)l^0hLf~e?d_7^i80aN4M!a2`3^2q~lP$~6+3_kbyT!4WG zp8Vd>3_IXNc;Ndy@2lQV{iA^|S=EC*IbU1_{;>)tMO{TYUPKlyU6%wp)p$wZ3&Tj}^yhP*+jc@LC3Nws0rWfl0^IS*BzWb%uX9yF`%V z&^d7$cG{t9&H#J5m@{9|f446B^$$G2x%ghq=IlxM$lg_TLRRFLR&)sZ>t9%!@{Ln= z4LZnH^((2!XMJY8ffIQTN;s10%F-guiQL1fJtq}T&6q15S`oG40UBub*dgDr;)?0B zf@0YKoN$+!(_GQ-qAuR@df+1omMonbF7&!22`V^k_4_`;;9UJ)9xmLnTGzPau}91@ zsK|#rFjkCw)&ukV1$!=!7Otl~^SQrIz`%Il$3Ey4`LK1B3&(u3XrgMzxW1pDQUqvK`$q>Po`T6wUkjiqj3J zDb&Hb*g2p=owcm5$fvEVYQABqUJ9#SQp0u*sUBRZZjlui%T@KJtLQjV)#tk6 z&e5uVo)sCMSC01r8c<}Xwa-G zQ7QHe7a>&jx~sT?sH!(!MSfgW@4JfoA7WfEsT@>&^7Y;o53iWNzm{JoOuh%r;L4)2 zLmp4{If(}4n&j$*A&2z5#^%c4t)C*RjFn z(k+KiUVZ^5wR)k~NehKp9(5+kbx_!}W`G$?YYx~!T$FL`U|f_@)oZ@u;*P6(;ReLZ zF&A!n|AyxQ^Pd?zKJ+{}f*!((8zHOuf1df$j>nF0J?g+)XA*^wW2m_>V>Iy9pL2)! z^*J?`G$~S42&1bTj;WKK5&-to<-jRTp=g|%1|`Y@he;Pa`IqH6x5tKzW=5^nvzU+Y zqX>vs^2lGQ!Bu_6DZIkUU4-fDfy@IlU7iA}pB;hfNNGt4sQp(8Us&EU zEWV<#%isU#hN|j1%tx>HZ1EhE#Rny&PR8`Z_@#F(Rs`d>s_XHATYlv7YT{DNaCKmW ze)0p8COu9r_4vxqIl8(nIE)Y3C&17e@)`JjlxpCK)#afz%yS4dxw_s5o>@)yQPz5R zj^o@~Rr6cIUjs~hSTC5uH+h8fFOssLK@j8BJy(|3hWn8v)wzGv6~!}x*)xg6%-8&p zntyo!4yhmueZTMLoJTK^2d+MslIUUUHJ2Xl_sqjBKls$ScPMme2FRFL*JF$sS+0^I z=GTj}rtB5&(EQpf7fyyrAzAMm&q=+ec9h>=&?MzcTuc6Ea?CP?1I9UgIRHE>4*RWm zXUS#wdv}o>#-8jV-4ioF_lYZ~(GIsxM=-cFoEn{rvY%BI{F&u#Lo zZnR4ES_z| z4|&#bes_Fl`7pTttobjECr}LWpCDBgUEN7uEAX&j>Ee1m-}lq!vGx9s?-<=vLKG~{ zmpsPr74dA>{>mq@p8dV=qn9Xu_w&vNGEaWdLy_Aa{qQ1f>PAf%AWgHsN!>ihx-h(< zT`MyTtr@T8AXxUDU`c7hOYv#Jp0T~{#0b4k@{6HcNeCnTo)$MTzF~3GQ`^w!Cg4Q4 z!*3b7Tub&E4LomObx73%%L_FFF0!`blss^Gy#EK*jz|V9@hp7ZdzweVV@viWF}4&j z`C`z|Z~wk<1(F$?Gp4SVv?A&OTmiLtX3;m~W?CCRaBcrt8;=!13Nm8S61k8aEDu}| zwc;BpxRRCU2j2M|r*=r+c0;yhRrmDsg(iJ8ETEQ}Y^;{~i}x&T$gi{K?^Y3#%SZ4hch2j(vJL|8UU zAxxW#IP=-nCgI^25MX(S6X6OQhE!s|&=~J{7FE$d&iKWF=i~ow$nCRs(UPNRb#cAv z(Z~->4IMjxgnRQzLsmw}flc_0LA7iz37^mMMu!|}NV}}+a4*;tk+ZDws^8OMfgH%> z8sQU(o)_Oa*>_n8)3fO3$>qeymKURvYceH8MjlPeMHtUmL6JoOzRX4XA9gU?zlN;eq>p#`*ha5v{>DS{9Or7;b@bw!4mgmzj@CORLu%9P|u@`Vd?iTY0emkb< zI3?kM=eqh{E4Hxk#zGH2d!DpXB=<1mlJ&gd2AdNYELqQE2TPJo3LY;>7zRxj`$d4E z^3TbDq_9h~NH@1te_&!57+3ZH>ogBc{dui-J)*c$zA{Jn+j@T$hQXtyisJcvmG%V+ zDNTMaK988;%9_7n$kbA$T@}HM$@%?^tb2bLFY*3$WT=4W3nN7J?hm8FwFy5s1^E7? z7@qg5AjXUN<*jG{DNIpfkoI3kbydxN;IqT36j2mab)pYE*9*&ruE40X4Qn_>t2$a7 z`0!-OikbrBMZVx4d}3~;-KgzZagk2|U34ORuBhd~a9N5G5|;i=xJvsItOyj}SM&XT zz~#RGe80-(tdLRFQCiHmCg-Oht&oYjej>(6#4am^%VbRgr~ZoZ#Mp0Y!Q>E-M%JP+qR=&@PK|C(y$rQh~SN z6*Ti5Z_hYrDAo6UT`@dZ=|%o?&Zi9LsWEO@7P{ca9*v;Fr9C@bQRa;T#`DHu(KvC2 zY?LCo)ghOPva))lr$6I}>D=*w89wl#iQ>5K1XoPOQK#kus}Ws5E*GJLe8BWgjVKAI zsDSz#QMN-xMZTT^JF+Od5?w%QQ8f;(cdtd>)d3%V>G${CBS-b({p`0E-`}yPj?$(2 z>@lNw#W4j$70VOFtDkXjO_AMWG{EtDW#wtU@(&MKa6UVSX?7|q#rZkv zR{>{51qUdOF%(i{yHO=lz*H14c2M~-j5=A$3}`DwXY)XW!j%UDehF7D44wn>6^;ct zE`K@q-!-6&!nyWnAnQnKVR<%Uh`D9R=h2^8J0n4lvFN?{Sf~#i-qV-r6MJS2drD zkAnGa;j2ML2|g!#slr#0jPmouH=}$-J4$@<_ma`Lpz(4HZU_jD)_(95y6b7rDTb~v z_f(pe0E~+daUi>qN6cs`t@|(Bj$4W0f8eH^kFEjJpsE)XO^NFIF~;Oni_c`X>N;k| za9n@L7?10c8B==U_W6C5_RIIfB2y% zPCZ9O7kHL2E94}We!ou+B)%}eqG~XhlC{WwT0GUK{oin~1x-ej6z+!L3G6vCg^S~^ z)UTg7?00;NhZyBc(%q(35T~GcXd&03D7PAEG_|OLaq%2i79pdElDdfV(xQM=V%)Ac z3RcCn$?$k*P-TInf8bHy-z!HA$!MWn)-PEVa;{l=O3C*&^~3OA<4NG)p;;- zT$Jm)tiN)XssBo{FJ%0bcE=@0^?Pa>jPxR-r>GJew=mS=$moz~2QRyhij6 zx)ua_{e%T#7}}R3TV0ktGV*ba-IZPFT~l4Vj5}hhYi}7Vb7drBpGEcjjBUCHgJ7N3 zn^s)AaJ;W;MWjku6r1|vxbNH8RnBKf|09NnZKOkV;`jr7^mk! z7R;unL9%s|>bfFx;c~DnJ{WJ(7f_MLXl_x>1Eak~@q0!mEr~YyR#`vXL2I0Q=>3fS zkq`4-VcK7~pSv)Oed0Vn#WwAzi^w38oY!E~(iY)CL-J4hAYPdGSvh%ro&Y$0>8;e`eiMz%-Jq7*08>>^bZbT=+*IUuc_dHf~Q~dy1A{RO; zl&s@7!hAp9m!y+BI=dk$lcK*||5WU9KQ`U@JvH8}=&Y<_#WFi=GRHO-c<4rFAt|@! zPmM3_XZ`A168i<3_x_RRm~Gt9l&7LT{%=GX!YXNs3k_*pz(}^gu&ftW+=o#K^)@st zj6)omMiq6CPOPYe{DCc#i`#|AxLny-lV}X&B@8eMvxEW8XMJ?!mbat;<5*i#gFfyg zIb9r6Xjg74CQ%#%$?|(F!Q3&-moW~V17`;in=QN@qGfucl6C-93Fe7Bq%kqBHAJ(< z2x*opLY=8;S{O)o#cf_5J8_>Toi1|bTd`boT!EIc;|jEk7mT7L;6!IMRu*{OG(c?v+sxRYhRix*2lOW z>QhZ|n}PW^jStX_ax7S{Sd>!%N92Q_p>qMzd6?vvXG&KT15yAcy>;eRe3FBw;PRn% zg!NFW^8H+&@0M$IX@@}p^opA%D}2DF!Ma4Fz;LB6i@HRsOEe9+RHxpT1P8?^GFGQ( z7AvkpGv@n;tb(a=p0qdzE(|G9hgRt4V||RP`1^|9*J%pX`l$PCt&hGJu5Zg%$LF`C z7B~RC{V&Bfp9A24mP9dlf8#mR@B2xy*ulC*kz3>RMiRf4a`>L+Pv2f+6vtAJQJ@P` z*BZhHb+MuS=<*eD|GIoh-~il>ZI1a-RIAceBJb+J(v@OG&6)sqs1?~9*wI$x|HY2B zBJUk|wB?U4rQz=F%X6$ARE(gttQ`VRYn~G@PVnBaX$8q5g%QeoS!ELWR25m z-kKjzsipPsj2PPCC8-q=gadbKr&z&~_KK62aWr`nT3gbc$RkTUx(#E8Nda4SI(J}; zhxq#~E14KX29B)G19OKlzwU?yFx;;$)(KM=1BMv4lXvsL4X4u3_}I@W(5+kZd7o-n zPcO2U`VNkqaN%;$Neb$YKpND3~_k)9U7r}wUH@B@9DDGCMD>Bk3i}1jM z*2N&auw&pc+{|o?v2~tnjKQ?-a}(znZhpQz*&VUqj-dYX?m!pDp_d4j-k|4Y&Gat4 zq-j2{{dQoUtDu-ZJ|6nkr>qHLe9EKG_2U#&|F;7(0sx-v$VF9z;D_N+o^$nw;bHp+ zD;`B(z>09s^W9V2V_emj`oQvg#Eb^)1>M$gVCsHJ;~Banq{2w@qfEh*nqVO;DX0DEkPP*Vg&2UlP;26@(NC6W& zrgL;m`D?4jsVQ+qj3P>N8&kTZpBIJs`Sns1G$Uoy9Jm8c`hM_)XnfEAYG4}j+e zI!h>Hr!i`1`*C#hOn>mH4t)(biC5hZa$rg|&cBIg`9Aw#a(&11eLwdDQjyh`mddP_ zEbRCk^JC1Wz5Chje(@Zy8h@j*2WFI*<5Luugm2lyq_|0+M?=r;1M}PghG#L)RKld` zp>gVxkgDjVe|cikuL_y0 zsOG%$4SciO^}z9aap@P&f7e}quU|O9bIoozZEjHn@=RCK4uJv{SDS9Y#Vd*|0LzWBbP`M$Qz596#|MAyuNad-gKMYG|a@|ry(W^8!| zl)8*FHb$Tn=WWZe1c$yd;(qs7jp=c2CGaXZ`gxiw|&=e7qp2SK!TT_Z?6@7ondgJ$(vYm)u z!RBfhshWZbW%GXSU5TC&%r*RZxvIeiCaB%D0J>=#C34$Q2_q%W>~ zqfZA`z{Y<02@2gso za~G0+Pkos*+of%m^@TmZ_iQ{XTFR%6v+cm-iitNMB6PV38RB^ehwGCM?eQfpTe3h% zWt81XGqfL!T)kuw`h5kSI>XZM@(XuSx#6byG5Wx)D>m)t`Ttj!2-xc7WrWrT4oqne zzRZrFfX`T&C5xixqP#uqS++%iJ^|Mu^4~GPxGFE-)6Xz%+Iar4 z+5CHYC3qE|BV26GZ9fg$mtU@7uUXxA7wy#_8`$^|jpwZB0d^#3=Lrf{<|y8u=GAU*pb8KTOw{Q+YWgglqi15+3#aUPqU7bt}P55zl-F)}!1VJkPD zXjOd@5EeKvdp&QwPr2TiUFVgn431}@@Q;LVtIE8E#Bf)9iVg;X|A>_j?0XLg<9mYD zcR{~bpFT*eR&}$7zNhSaNGJws|LCwdf!Lz?p8aU)zVA1&6DB17Li9u!QTSL*Vabc1 zrd)L5uc-qsMBND+X1(vsr>V~a9IO#W9Ne#XzwWi*eztzchq4*xOIfqAou;oIB1Mi7eq z&_UhjI&db?@~U|6=^F8{>$R4oGs_JK+N3-9+$IN*=o z?|vWt=&CWpiN+AtrH8JXGtyW0y&brfp)0o@$_+zIf291h?!Mo+W1zc_cnF5pm6;B+ zxb^2Ak66FDHsYviU3Uke&??|c_{gWOPB|!>`M|%4w{Cu`Sg(4@A;fcF;2VWm2X^Om zKF=Q9A-GORERT2o?%B=tsdEj~>j)?bKKLBz^6!y9BVT;?5dj`|EkFD})M=FaGwPLJ zXFo=}^6&8f=$F0@eUEYBv;V{V0(m^v<)4G^u`hh^JAMAdM$_30_~37<-x;d=kF(YE z92-e0arra8KkoBqKU5p9`Tlb^Kyx=Rlt8qp>L;$(Jr{8)RdfGn z$`|(tggMpLbN-z5FXJElxzvY;@@)0{`vG{HUwb&_eD}cF|26Oa9{IV%Kjhyfen3Dg z9B+aTzLvU{QeH3B86)U>+*E$w!Pn0B`Gc>mx(c3$yIgsGy8U3dL~k9FsN@U{1S{@`=( z`~I{4+c$TCzqY!DV*idq#Pa*x?3H|8;BK{KeJTVKT|}l|x_nIUJ$?DBr$?VU_Y5WP z7j6Yj$a=hs)se3oBwhkAWZr(cgGNp3$#dFV4Qs-j0)(_0@hZBx2w*%v* z+N9dH9E{zQ|p$z0(jZ^HE!Z9T39Ft^aQ_EZS5m>M zP^h4wu9^zML$y$XB@wD6Fe~#p-u{8#?*nFjN=24joY}D=C~s#)?Dw5;hG>N?V_bDG z=#YM3cQ`*fS(gsoB8@)A2jMuw+@T#eL3PRK7U6}~)!U#&o&41?8g7E>x@`~2TBND; z7gj}X>pJuOeCQB5a~keV>gvVNn$BR3M+d{RBgyL-NJClgdfgE}Lq~AG^Q`Bq@Y!)j zv%@=d;;xEbbg&PdKppf0AM5r~7&uiE>+IXm8#&_vnsU$h2@HD%Q!@ljG@L4Th0v0% zWuTjPjHB|OGu8^wo8e-hXN|k=pIQg&{BbwdP(QqmyRe4p`!4L?i^ezMvtvW`e&`+^ zT8G}(w~`Y6sP6!i9spPHK+^jTenz|RCw%*_L+jb|S>K&csNa$HqTUspulvo9p|m67 zs|L(Y58${Vsn~D|4M|Oy10Oi{UorsQ*O|t2_j8!zCh+Au4I(>&X*z&I>yiv~yXmv$hbOBSH$RlSIr|9ceoJ5JOeyofwnd24QsdaC8?5 zj@9oeBRJ#kQ$U?9$l;{mE{^7kD8tNw?JE&_gWj%=l|4xLz`hY6Fsd3VbW1rfDV}io z=lOcSPmWmne#I%2^?h<^UC;c7x~C)O@Zq?D`HJF%Uv+)xkZAY&QyhRZ2?m=v;`EiE zRBq~yo*}hWO^KzqF3$^uQ|qcG6+CXIjo1NI8jdVW(7#Ww%pH^&vb>O!cQ9;tfk)Zr zA&F;KeqpT`IfYEE(+ca-8?i#tF#C~b?fF)(kNRpB$f9Jj;2+#ru*Cy_LyEo~`&+>5 zL=l^Lr4raFq~6nUzYX^mf$wiT9rh_j-4Q>5Cfpe#Y{h2p=D1uGRoMen)1TfM8P@Xh z8*!4d1AEsw=iVLdwa#%sJmU?Tkbe&<_c=+7Sa*X!<^2Aro6406*xaCrMmR7m>j>Rh z+MqWS-BB7(=FILWbv^!qvB3Af#e)79-;x0Pp}QLiP8Rz&&<(@7Ms&l#_ulRoR}+{% z={Zgsl>ISDgT7;cl3101==tA;Iq z{<_}pi-u>G9BhJHdw6J?i}}8!9UHP|!di|-8J{5{T- z-M2tw;G^YtTyj{yR}Hz|uajEeZ@RUE^OOIE^x=~n-Co*|zvMV#%JX|<4PNU*_;at4 zEIIFPDIF9SC)eNTjzPJ}-VWqx@vz2aL8Cj#)t1qXgdFlmZ4xg}&aU^b_P|4TKTlX2 z!yWZIF#2>mk(BGt_lLWa3{Ze{JzPI=rQjSoNr|CpU9J#ruT({+iJ-_#cz-BzY5t_h zrIWsEysYQknM*Pyz2kjl+i`S4V7 zXN}-!aRfSPT-yLmysrlmjZLk~u{X%k^$f=;C=aq=--*HJO;6+i**a((dOeb8dfw)X z&k}HL&-$nChC-v%Hq)i=uvLtIo_hNq`g-U+_H+77SUy#7^U_yVIR7Cqty0Tzi5Mgb!A)}a5-jKuS)90QULq;0uFC_zQdYIdOvk# zc3LUYZQY$G@U57X_D?bx-GDyu!npBI>x=Ux1-XyO`081>+|fS#(~*HZJJqEFGR7F* zOCAdM8s`qN|NgQyBA67y9u<~BUGJ;yk+BzE>M7A)9~XL^v&`ptzTEHe_wG^AsOjqa zeLobvm;57D{RVP*^g48l_xhv%0HQkG-QW>bazBVPu7{~1|16?V>h}=uSI6AsC{9y% zc*@kOeh;tAZpoUr`$N#$VgH6}oo&I;0~@Qzc=eaER)6!itC zKjH0bZkZi@&&TDUgFouk?wii_up`NmWxw3E8`k+)2xM^ z{t;bzR37Xf(I4xV{Ue?o=(2411=@3ie|jt_8<>P<3j zUH3(Y53Y~f&mvB_sTE@f%z@|-V#|&lL2SD=MkX)EEOAU#{|m|_a@-Prw)$o4{Nf9l z7#CmmA@lcJdSTY{J3shBZk5lR#!MB< zFWys_{WGk2H zJJ_dw03WKbD)i2%H$WjrsPI$Li z-rC-<+DvE}cMJ9I?Fs4Cm5F!YATD|`4}1_H+RLbF>OJ4}#QRK6v2O?F_H|%v>wR5Z z!u7|(dZPw@;Mw2xO>gHUyz;w!3*$@pi(@A6f%k2Y6Hm8{n~r)hhTpSPT^& zy|Wi(M#V|*5&;=3+nFz)kuBakv!xDvFw&X*b}$g{pBFyaMSWfj9gNBIa^P4Yv%_M% z1%E>l?SFsr;WGU$5i`l3~fOJfIMUrypdCDQsoM3v-GIESx$yuhT9$bmm=E0SCgJFJQ>NEyUQ4$rZ0A@t0 zXQkDFgA0d#KX7(1ww}=h`l=RaS`p7z!c;w=iog=+Z3+W8OD#2u!0mq53;7{&aA(ToC~d$yy^<_8X~Q&dd+U#^@QCxtAXG~l{IuFJX$ zKG&=rikj*JQ!awaQ7{ubQV7SmFkY#wF%SR1AxCMeWfaUDI0>HMDxA)>9*<{?55gTg z3OP`#v?=UpZKjw(xINn6fk)9<4w%}De@`Xf;~Qr;ZUX$fHd2yrHIqA6KrIVHvx1ifq%@6u^cXmvM zcnv8Y7EyzgY4oAzBQB|-7s53^Jk+Li7sv!CN!Ox)sn9zk%?IWlLPj*Mh*6o01F-j^ z_b=!cqLH>lL*SuC-GQ}v9v8;i`s&+IljB?z%=v-l8Z`m0XX{kp`?l}{p6JQCU(C1D zV3iE&8K)Sv*^EwsS2yf5(DnXaBttk}!DC79tH1|y@(#@PCBgmG?RwR@4hlrV_T?F* zpx^cP=KT~*8Or$~m%g#5*nwp~#s0xjcXeYp_F^3Cp)M`$zt1mz;YhnOtS`+E^wCKV zl1aF2%g&br4{!)HF_;y>A&W3|MS5WKpo?PR&bb3~g?J;E>~Q+RI5iLsx>6HKAJ=~4_d4Tz8LqA?{V@om?=k!=#Jp;FwUCnb)X0k(b9+rV!@Pv#7PmHZogcQ871CpUL z$pe7z&txyuCO)VqK!%`e+?6@AXva8CiqekFsvY3-RUCx%pzGO#-zq&6J2)#itl#e~ zSYw6(_rUt7P8N zI4KzWGaF8IIdx}~eO@*GvE3&1)T};+d5*7bHtAuI-*FC{I`U#o+FJ5BOj^|9xjFO& zP|Tc=%JN!G+agKhlu3NQPjSPvE+LbUFZEE=mgWZxt^_?u6t%3mV#ij}{DEO~nd^<& zMF-|728voq)-`riy+bqvOE}kU$*89{FJZET}AjFf*FMH^RIRPqnK6Y36DO385a{D8VAqfV&VgXW*2QW zc|4Fmb~WEs<@v38e!u>V#Xy5G(zL_e0iH6FVS?q8TGU%eQD+51Ua;sNb>P8s1T&nH znp}Z3RnB0^7tR@4QzXvpRU^%9X-a(mwzU=*K$o@aOW&p$d~YXdhTw^9n%jc=erOQ) zCWZf^5-zZwm%dNy8{c0y{-yczc}VreIMf3-SnH(81uv@nFT_`y+5!9eN%K>hEopRo zJ?Cp!vmJuhW384a$;c$`u+55bsmYlJCP{5)-^(A*A8TVm?{uPsp+oa@X7DhxJi2MaRT%+m!0yXJs` zf?LaglBzf&Fnr*hF9(!l{|>*`^!tS0cgQ5#A_pcuH`Y5q!St^jm>xUMcgSPM_2X33 zxq9IK_%{N6qH70!ZH<7RXxyO)TaO`C1GcsOC*Wl-@DI*O))T&vznW#q);zHzIRoPl zOn*aYE+rR*Pl0hppBgJW3c67_+Ep0)k*!h~8`8O2a+S4=`Da^`z(8&~$N2rGNCS36 zFs-!*?s`9cn4q9srI~vCwe}B8p3Pd{cr@Jum&b!ta+U{+_|DRljeluUnJ_6J3ICKi zpZ(Lhd*ClcAiF`fQoxW&Dmw%|ByIa_Xf;rCjHQ}E=`213Y9x_0YA%Aawe2yh=$wbI3 zWT;&kie5;LwG~_kV4rIFCl*%}YojJyN>T*h&j-gOz283J)d$!!l_TrVMBrm%jz$Q>Q91I%REh2iHFoutd?E z&yt?X?=S5rF}m&VsD$g|lTNZjA#&jnQoSCrZnr7|0yl-}JymS`Fc< z$SL9W&+nU`$NRhHW0>>j^IbBCah$WFZB6ZOtbm&CXGQXel$Jhmlmk<@2aj-tmO{;u zEYJ}01r6IFIbv+1QR z=mp?Z$q+w}Q8Is5#0(Mq4ndMO&Gy$L=? zS;{?$`qVi>AIjMy>OOIM_SqA1K6be`S*TnAPokn34p9ZDma&p|25$yHLE8EQZ`mi@ zgQVOs!_-zkd-THn@e=)3#8?Pq*Kb9G*=gQ&p6*&9nupvOGj?J+A60ya84qg%;KNbn z*MlrX$+kV;1{n+9%(B#;f58gMNH$4TD%Zk3o90y=zrcYkdf!7lcE;HL}mkDobN8?$) zwWnERp@D)JJFo>et8x|~>1UOvGwFHq0N+=|L;n4!50^6*;nR5*@i?F7{Fo6?CVe7J z_@GaQz2*Y{J7CD|nUu@cgl}4eyl1-5yWbjo`31G+5q$v0x;(L*K}Qx$(~fs&_^i%9 za8OJa2DvHHj7vPn$z)2%zsIyaYvWrI%L$OR5b-`%~$%?Y?4yZL*>Bqi}4p-Jh0Zg zLt8T#&T`fYso^%QKsm-*!CWuw_#mVhqbV154g;UR76MnWimb%Q`YQ)#SMYM%Gv3E4YK^u5fi_PGOIiX|M@a!3N$p zbnZa6SVJ-LZ1_D1FAN&J&vU#>ihw6pm%h0*UY`i*S>IbRa$s8dkRmtQLAWX=zJy=; zvAjS0e%5{{7f|E*i3gRHbq+&jtSp}3@3S-$;?MBV@7K$73t23k9YaJf%GfQ6FUgOk z`OELLD&F6;pVXAt$w~BJ8L(`_^Lt%3`4s$?;2a94mE0*c7h~{U7}?4-B!xIy!Z+^k zxw?D~as`g|kRt5&>3SdYZb)%k+NHnGbA}wWKbcyFo1+Wc*^{t&wxi(KlU)_x0Zw;S z_9b{|*RNf_t2{wnFunB`e&S(C87bYalMwjG`H z`}#zc51e05$X<#%gT^@j7yd*8_P3g*?5Q108dq*s(9m`+A1P$$oZ$N%A%zs!;}a1z zY{U&nx^6#k^gyM=3b$PM4Iwcpo>Nt+F^7-VFXC$R%HZ9*?kA5CxdVoMezMy-e~l= zV7-?-9~HMwxiaLy`N*ml zA+Y$H`T*l@klxhGixDJMNFI39?>McGBzPfriZiO;9m-7+%&y+d)KvLCS7rEl=EwSZ zdfSPSCZ9{HUzokG4YLOXZ#N0ep>o9`RYfDYsrHB6tDCaVd|L@=ggEVxA>uLIUgDf{ zb;rK9S1`j`eQokmrp~=>gzp0ewsO|l9iE!c)BT)P)9x@{~w&!|<}>IVMS)$sNc z=d|-S37<;p_APs{X6K$2t$#ndf6cUx)Dtsz#VbgYuG^vg#rp_4?(_Kj-vjeLge;nT z?{~N>EEyOa_kIIOiNFYBYL?1{8Mf++iu)tN3$zGRs`>td{*-+4{t0WZyr1In0##Me zg)`u(>+o z90v{5Z)E$x9EV)1 z&SM{f-<-_@_s51mFliP$cwzRWccj|Szdngt9oc42{H(lw&xh4xQ{QKlE9ra8Mq)?x zEZ=k1@84SeT8nIU{=T?+sS;MCIuq`Xr!U42&*_#M{eIl>z~6lERRadkR_3axD{Dp6 zuIm;d(&N3AhLsVtMyleNQ#?NPJ>F77Kis%?05}H}Jp^l2OouC|iV=ZAYx`7B9eBJa zAuh1GCsk#>mfy#dP(A7D#E$rRsdZ#8AYg2_MSvTEriHslG>oJ4$?PRX_M%0I@($zX|0W z>Rtre?Cc8fEL-2RpcXP8n04i~GYeO@`5<*FcvNtP#ga82Mz)EMt(G}cFr|veGxT%+ zUNxub9oKC$&HDM&y$uub8_!>H@uB&{Q_1nHd>f8u*CGh!{_~cABK)#zeo?&@pD&8Q z`Q8J1*+4J7eyWRVuODCb=|Ao|+{nN>Fs)YX;H~I#2lbCtJM4!dJQXA4^R5YGk9cS1 zvtRbsNzLxRNt%TFPrshd)8G3;QM0K32D|Y(E0*1n?I|r9=ktZy@7SsXj+>vWD!^pt zGs>r^Y`~A_(Btw$3Dyeue(QQ;fA?hUFHepwi^Cn<>8W!^czVv*F?=bCsgsV``{4S& z>JRHUYF$$qF6>`Bon_^5a=pi&`i=u<vdExwc!vls@>-iLL zy}wT`T>3q&^rqia7vX%IFT?)4@LgIrSQ*sZsHI)znS_I9m@ z-Cg%Bm|2&GnPN?f9zOE|Sr1!H2&Cu_^(GT_q=8XPEzhLe7S;2wnXJLQktxOK? zpc~q`AF*oE^t^nbn6WdN-LF|bgh9AInHuche0>Dlx*|C0!tTfX=JvDS^40wIQZ7F@ zLeUswYzu?zN1T*f#D2-n*+XZ;#7vT+Zo^rcBfAM_#i!V$pShnGxTt2x!>`?rCv1$hHFs=F*br^ngiw;ctpB;a@o@dA3 z{;6ncw;qEXk4?kuuzYj1)Pee~!wxuI>oI;$>rU@~{l<;43HfcCA`Rf|Q)c4fl zd_^Jb80{!ld;+4DHnxTcRT3&3#Sj9pWpMGE)Q%eSAD8LDhX!xV!%&KTJx3H zw$XF1F2GHF@zk@NebI0QEns#L_WRjXd3?SM!%oU;Shb9G03SqUyEO zQ(azs_it&jEoiMVcRWOchvIzxk9VducSghxHFvz>_o_UAX@B9KzAz}3zqic1u)oL5!mM%D zaV-5_St9yAdxL5~L;7t#EzrSHt~CvJ6O(_F$4j zU1dy;*`9wTOphoze9OBA8C|zxy+gk*PoL~~e|kB3%eHQ!H%VBp=dtbEt(Uv_A;)LJ z>h~jjOGjwm{o{T&Nd)>ITN^qhqqeFw=Z^A??pOpF&c2408R~PmMbWMs=Z+8cnC1+| zr!zxqQ~3v^;Hh4yT;WvyFvpj&bGgDLjs?b>yRVR9x4PSMe1EcPT65n)?08SI{qcK7 zL2PR?>R}4$=~HFgy6eUvL3)-Z4~kS2Vc&6PG6KKdJ<}jzdQp!w;II3P0=`iK<-D%e zi@Mc-!n*y5{9cuZ930cDyj|dkUO#o}tv6M6@%>Gf3iiJ@`R}0RA;ry6tk#|P1&Z$0 zdgX0lwO!*Kl)Tvd*?}!f05YL(M+E|-BWZ?Mkt!%96Gsw;K{3M~U-0a({|FQ}vU}-Q z!s?cyamFEm;S2kDX5>I7>i61#;qJfuUebB`gxV2 zBj3Cd<=S2B19@TB6m!3e>@u98xcu|l%D9%waa3OK>WIq!{!jQz@1Otsf1+;X_wq6r zy)P^BQHyTAJ@AjX9yoCNfqx%=;5g9Aa2-a7hoYNy%T9VfGtdJkWw-_)a8h(*_krX0 zstZAsBFZ=c2YVLX(OwX>U>PUinD0sULk}^Q1adtY1!uxXJm2*`;A8fS-+2Fn&v_G_wF#LoEMREas(O|RGKlsl1r zfuBXaJn+9&zIO4uRHd{-1{^kS?S+jGKCjLS+>f;{Kb`OGboue%YbRBRghEz!((mI8 zh-Fp6EsL!#ez)+mLWVx$5p#;)Z^@e!aFRS~^Z6d4$_Hj0T4-%$tD`7m7YiF6t#?bec-XE^s z0}sJx#-hlI7)P0|Xb8RKz)dhIxT>P0;(5M56wWAORRu;_mm^q#5gg@;7jT#>VCuuc z2afeA8$3;{uj_q;pNfgVpDGCS`zHK_-h5#HzBQE0rtkY*Au=J6x+*?6-=>O*z~52@ z$r8S|DkRPca`Cq@A6L|DJg;1l)8VV!@ss}#o|+4HgB*APW_~_*T#@ul8LBvIri@iC z2W}m`JA(Ui%ACs2hfMH};C`Lh5xu`<6%hlD--}|=BdttD#&gpd;(CQq0_Oa?&XleE z`<3sRa`N}fdUhlaaLiCW!;lPTJp*{w9FR$2%5z4?FqT~t9xA&A#wS+P&>5s=?zt-% z7FPJcamu&?V~NN4g(VDeh8r_f7A7hl;#Av&W5vqWK?OyeO8R}!kXN)p0iwBVn)3U} z(@XUN=le^U(1r7IV@J$j2_QOJe;y!LMi?vK0lA2u4Qcfi2yOc9o!h;*fwVprtl%8?HX7%QC(LvDQ-p9x=Zy4w%ryrYd3}6P7ZgQ5|7TD5@u* z8M(S4zA%K*1x;?;?D){+`mJuD=EW6)$5&VOJa~LHy+5)vS-Ahe^`CK7-l1BgEY}2W zU`Tams1_;9HAI}R^5xK#Ei}!n^$!*D1B3BBW#b6r4;=6J^W4$r_ta#GPgsU4-yP)h z#&1wq7QU9g*EGM0_m%bHJ70WNXx98b@uPgJva#RF8Li-UNd-HGV8+2^&<_MmSD;-j|YV*D;4!BwiQ^v5i3?bNCgJDq9P2jI-&}r z{9e^K>tC8q3CLvJW>l6c9V^a^r7T!v=3kjoJM;>#&oYR$2Lm!&G9FQ#s|nVjGiA3g z?CK3_ZtQ-`Y6wc%zmeNdO^DSITe_)Xo}*mR){L21ovMW@Z zifCE7FEg{VtXF1o!kNjg>3a;`f%LkOJf3q401iPa0(p#{MKSE)k`-TL*uR<2rg8`(U{PERgW>2eR9g3Z@?g{0}^&b<1<5w>GzXTMHrv- zacMr29sp(|)JYEjeMWUs*HwMZg;jSqVIRy&duZ}3R9)TJk`v&Av0;%ZmwJ#dazMk{Qe@Z73%?vG1pJfVqLDM zs8^;({lvN!2rr zHBJkDs$PL!v#ELvdhz)CDZQksK7thCdI|daT^~XFW2k;(&wB>3o+0!Y)i3arE~@7s z1+zkEi{o6sz%z^4|4AI1RsSISRxr@$!2VgMzTwp@o2(aVDGm3- zSjI;^#eTn66@PB3-`I$@amC~a)yU<`F{8oIL?IlnqG0S`cJyuN`;4xEB68Cy zSTuiXNyJyzxM5NVpC9_(7Jf;QUG)xcJh~}%VhWk^VQtkv)F)mZaJyQ@1AAQYe7~>W z{X5kINi&LW2dsApnpS;6f{by!17X)QFrK*#kB28q(h4xck|b5L>nAW{W}_!jL=sGj zdg~t?-D-tAA(}5)TEWosw0&5garLH6m|6p~>5G0(+a&5C&Mz|jj1Bj`vvKtw)eDrV zTvOcpZu{-Pvi}4x*q^r^0oEO7)Eu!M?|8rCYw1+s`+?En?|}#Wd&Wkb|IgTqzu(8Z z<4t};zwh@&M}%=I7jQ z#is!4Q8O__OsOgU_^8c3^wt_!fVS@PqcN8MT9wSb3^7v~a zSR=`|Rf0V-WV;@oND$owf3NC4kyHTo9LaCH6a2kuFs<`|zgJD_oCo~9>Zrha`1h(~ zIxK+W_o@@b$^?I}+N@(b;O|wNhv@<5fBmFe=;8eXf3(p6&ir3L$IT>Ie;^eV-XwSm zYxMB%RVCgC@b{|vQ>OmEuC65AniSW~YZbW!M9(tbSKG*cT-$%gmIRSGySl-NpfT>S zjV33;LgPjfP0m&|b~WA#0(E2NzBD(EkiZ{lX(l70Z+72hv{~+Ps=Ux)-o}()=dg&w z59Yg}bl8V~WXa|=Mg=7&KFpx;sbo2j(S0z}I|D~&(U?dSxF`NSKOY?R_S8NvWQ@qz z@xcnY4LlPwVD@500Vd|P#wXVO;oyjBzyIPTv7>)*_+&X-_57s^Fv|xY7G{k5pn0L@ zNfMb3t_yXyeDO)Dm^rM!^YXJbzxX5}Of6-E@o)q%tG&z6EPQa3jnVkd*6F4iT&(=Iv{g}*o)7HmIg z;QqAU@^B>dAC7<6ygKuP0dM!4EUW$gR3WwRPb?&M+8OE>|Ktb9uOtn4zYnKSXul5z zSi}2Wn2CRZ9WdVT#Vm$w_SJQ@$75$*mt)M%>o61J@xQ=J?6DX#ggd!*Vit&_IkI>m zY15Hr;+m{^4&k7PkiXlQj6HX7VkF;(zaME#VRd)}!I8qwY{tLuhn?>4|0uj4Cp`qF zNNVnHJt?u^@Bd~r1X^)_f2_EN`tJVz8uleonz-l04)^!R(R1S6-?F$c{{D|b`b~?9 zxa8mWBMD_04`z$OxH7+Q2>*mAOh{PYL)dPq#D2H_e5adn&P$0Ddcwm_hid zwI*f|f9~0QBNK;mPxopQw&$Kt%tWP;x<cH)$wD}|YI&i~Fx z{HFH2Fe-(0+B_-4e)Ct^e(_4JR8A64$<*IgkxfRK3$<^O$>_GBD6^sVkW4SjHWFoi zVf(qI6BM?ezCiV;JuiGsH8F9HH%g+Yed=5%6~x4;qn#ELk(ifk?-+R6Y}9#L3^Xxy zq|{_((*rIR2ubhb~9geXzM_Nn9GH-A;_<9jEaU_A;nx!Pk^Co!)sAL$B5Yo7It4hV&tqh?+!+VJ<%X@Vv<8JIVUCN~(EY?umq z&T>za8C?gm;9XB}NpY|mJ6v)wR`tg<;M6d%b|LzGU!Hry>7-!b30!s~s37KN_-cA4 zc&Eaj{blG8rjE#CVDbGaE*29J@0%V^D0SW2q^?N&IDMGFHvf@9%gzI_}F zmSPTrA>}?;dO2>SSNrrVx>XB{?}Xx967N9|1_`I%*jQ;k{5Yj z`w08Ho1rbNB^3_b)n$UCMP5mtk{m%iw>EtG@rmR{tkaX>9_VfAE{tg zC-{qgstXm1an$~?oFn|$B}HXP*M8@Z!KN+{0lA#+ep9e%zvH0`%E`9Lh9=uYvI`uJdIFMX|B^lY~^WoU80p@sqfF1;WYbqAYiYRX8d*R1xmNK@mf8m!Axdo9(;DlQD+X*SjW1UbzGG zyv#K4Cv{iA4Y;)fD_9gv;Ks@?{7D)4n{ha7EAS@f9%E%iER`?- zYjVN16L`Nj)|J8O*biLJN5(EC#DhznGG+?v`IWhY&$$P=xv=Cm2dl+?a5@pOie+Z< zBrF}Sf`N5`*?*EYmSrj{3BakMA)|AA-eEo6`tU&rSk*0L;FaN>GO$@wi|0PP1eqDO z=Z{w!heA31Jl?;(BYPgjVgKv>ds#=w2uSSxaLQO6BY;~O=YBt(+;A!%cn<+}6d@HiZKm0;_+ds0n|c{hP^yV@0{bGlS6J zfDcTqn0L%fbqNl^3EZg#T^w58Hbp(m6*acj`7rmq@p`|{8UH;0bqr3?051a$tnXK9 zT{;{Noc&WsRN$mAQ{)84E893QT8>Bk<&JgeE?9u!Js;Yz|P-<+Rg`q-vu(!)5MkMqV8JLX|nBWz+tdpU@shm z7Zab)%|kiyaQFe}Z_WA0_cNv$4sgNJjxGE%av2DpwhH&n9 z+f{4OuJR6}uzEXub?yk;O{;T$m-~M?3dg@H+uM#=qVVnaYX|5kI)ydgN3DsW-Eg{m z%zwy`z217~c&6z^J9K!xwBr?$_}c*_JuqnPkD2|G3Cy;6Jf5fMa8RF^d0>uUrzQ`F zIDy$j@L@I>as1xLXukJ7GJ80{1Y0seAz;{&3GnwCM{K=qH_niXK?WYp{}%r480Ndd zX>nlQL*UcDc)0(~6mp+y2a?Ba$pATUz>96Mo7<-gMcv}~wWBzn8`N@aSu&>PmV{h{zh8LNOOFt!hSddDowMA64Gj~(s%y-UH{ zGDE)?1zV@sk^w4%1V*4^@3;Qq>CNj`xFbX_%{-kHzdPs09F`aDX8-9j)2G4kl|L32 zaC(EpUFxw-SbDft^gdS)?(ess#}}QvAn^o;EP-LVaJWY*c-ss6x5X#6eIrx|KNOTs zj~E!=#}X?s1MTATnb9L2Vqc)}v7S$b7A`^Yo1s{t|6K*S93FPbRSH-*(Y6Xaj6-+= zHW-BMG^A}E9?^2XxWD#^$5Z%2eSl3q<7IRjqRu39}|J& zOrHCn^d|hdzbNPRAVyd|JqYnqZV%H@i(>Z7Le(hqnM5JJ%5{ULriOAyO!cH#0c9yE z6uYhHUqMj}JXktE`(tOf`l}fw>EoI(+bdRV!o>T4_rBPixNg?P8E$?bnZtG4^~v`; zpg|@RY?N!fF!Q1J1n^ejx7%T$5^$V(jP|sfoQ68Of(a zal|nmSOMf^W`JVYKUhZo#ZuAfC`a}0QxnMcJ_yJaHS-(8-y?HT|6w8BGN!Jy|h$s(BJqrDZG5w|6wYWul?lso9hIG5fkEsrTG8Qh$KaC z8^yt8%X&so@{IM2#zP(a&-E8Yk#=vyj)ilF}Vko`-ayUlNrhGYoIHC~{@x1H5|8no zWY}v;9Z8WzrL!!p_@d*gEGx;yd+_!!Xs9fY@Nf@UrQ;z#%5_AL=F9n*-IU8RyCqkP z&Gh9Nx^4tf;hKJ`arkYN}wkQ_}>(MBL&6W6k za)j5Aoqiv#*+8z)ubII9$PA&GP>#(4(o8w;dG7LS*k2mDX2to^6zxX<&ukUfkYRuE z@b8l*s^>%Bv#u($7(Vb@+bi-9v+8P2Oriqp{AIQ$P~P~9xF9rN^DFn)v|PN7h<|WR zrpTnOZAZf<-uSF9eEh?tzR&#d0N)fN4^`>`riV_sxs0u89erPNtK-{0%Sq7#njIa~ zRMG4hS^wIz+nS>Sv(iT)ib_YsmZoIGl3vrNd2La!HM8CMd_Kc}jgK6ZqoCMTv!7-M zVex=sLwxs-W=9{=)9mPzL-7&44EbVbr5qcu>x%iQxyNnTipv)}9!mLeQ8_NIrn9eR zB}YcTQsM|7YL4m;U0Wy)F3yv(wC0YmG*RxTJvd+cwO`{q{^9wgu1^oa(<>f^-!HvH zhCV|IE)U()JW}gP+oAZlW0RxY9Yl}A+mZW9DVgERT)p^vIUnQUq*%M|^nKj^Ni)9d zKe(eT19nEtrS<9c$oH+c9+lQ9OmF#pTM}|KVP5Ami&W+wPtA`fM^6f{R^_9Z!yuZ= zW6q^8J+HP_*~3%KW12&;3V9597H_Gr+dZ7lTNqwx!itGhHwQ> zx28EAzAilo#%UX=E?<6sC+_ZV?l8OF4&`@wZKw<)lLhKlx+(jyD}@5fnqxKBay7%c|M`1X4=!|`dc?I{>+e4QTFZf@1+dy~ zss25KBj5A0{xv>7m%oD5U`w&Tg4JtZe_36(6jQ`#|9mcMMHlp#M+!!)2y6| zYn@dZ@>j}LzUtZ$HZ1ZSA+^X`$ry}vzFX?Tb2!VyFM6Ww|lIHjnv6EnqR6HnnL z+lMnsy{!z-h&)mXB&t*(lP5Ic!TyT^*0nyDFr>#0Vd;^akFq#^IaBlZ`{|L2NV|Gl zrNVlpY^6BAwn?R%xzwMGdD9AU zhA_N>oIy;l0QVd-a&v{M@ZMj%=r3@9GI+>a6aZd9cXmYqO##G&JTXeYD3bzHFIj$Nh`qm;rsIM5VhrbJvXZJ?${*L9Sp8>K(6t!t7{>{Qddy>1O}Q1J%D}3U7XX`iDodR_*0cIluM$zT@wUevU1b zbJw>$J@iNMl^&a-+qDz##C$`g+$^rCT`84{JVb#9{W1JPr9YtPzVpD^LCw!a!Q{G? za@d+};7Xq@DU6|jfjPoj?}{E_=}E%!;F%(-^eWeEuR0aD@4tE!oOUPg0V%c)d-yJ1 z_1k`$2a=~TSoPZ0wNCes6jOC-;2lw~E!r>Uj??pL9@hLmtvGoqYp*_@Sf?q9JDyRt zPpVdF&ek$2!!m4pR@TCOQoG)BB+Y*_&lP=C_pf+8r3b6tSY_?flyb>aAEs2Shf+yN zAQ9(VNI|3sg-*fcsegZYZ0oipNOAuDaewIbE;>02 ztR14nP}$nYzpwTYtAEuyK=T88uQWb*2WdT|xhrTO*Q0%(U(J2`d6^%XQ_uCk9pU-0 z)hmN#uV$Zket53h`_!V=V@+uPdv`I{k_XbTM>8Xn%AYv)nEhqar0KZ*Fl8I) zm>aG{3f3OVC{)i_d~f<32YJMo$5VVied^O5Ic(FcM!;Y^-xUOD*3&+CPzug-&p~*z z0$5x1PxdI&m>fz1o@7m@$*|f|yrH^>LB-Q2S*+%x10MFU%ijx+K zL(Y}-Aey~tF7ziXpB7gIm)WN(P0^KYAWd;OEu<P{3g_>=hZuU2TeYmwc}~QwEd}kT5>gbvC3J#x7;$ z!9l8HsnLur33Gr&V&TM?mA;mMNu-AUvKlK7$xp|9nx7i?X-Fa87QdLo*cE)jGK&i7 zNjM1kTb_?~aSt7TbO|J~Wpw$4Sc(+Rt_l`conMeJh`ftYu~=Mma_VU=i;NYWD|JQu z_^HGa3(MW9{qKKR)HC{(^s~Vs>Qsx>V&Q9C6>8X}*RzUV!b%9jl&Gw>l&>m;ISA?e ztTB%+$Kay8ztclu+2tlh|L!LiFZJ&X@)(pm(&Tnmhuj1^AW z+RIDI_2;X+Jy?trzOdI&vd6zw)bFMj&v$KZQSG_)mU6*8TMRn$wT7Eq%{S>XZ1FZe zVl_ImIHFkvxbYe;_=d_umBtsR|K^gu6%yiaF5fOr+8QQtP5>P>UCw8nA9Y!+o`6^Q zDJf505+)HnNFP_fp7=wPmifzn{(3MM^)T?VOC3Kv$@ES<%v0)eIqH<<^Ym~PlL8I{ z*u62&@Yc(@KGQspubS+Ja_0|Y&wS_dp<~OJfa`R@w`)F_yXjC9=#qqfmE6`x{8DGH zhc2zIqqxKP7vIx)20JN-QzdYSflV5u3Ryc2!6;$CnZCOB7$>d2cN*Yf_ z#H$7s<48Ci0+}#LNpZ=n6|0=Ngo`B3@iy~^+#X&*ZI9FaDzA|?kEbqqspR3Ao-0lr z_rLEj4Z9$f8>QC&Nh2>=g5$*sPqC~ffCWR)oQhk-o}5}tHyv&wq|Ri#Y5e|v3mi}f z@`41Ol-N9#EX5-1zCQ_8G1D)H#2l81h(h4Gt3hW@U2sd_b!IU1`YDrNA`Uy6Sj ziU(qP2!`Z?l1wh7OMmREOr)J9ZxE~3%Iu?~P@DPJaU)=;8d!n9w+ zXIV28^P{HF{-WkdgL*1VPD60*I^|8c)*7q7!=>CLW z^4+<=UUL{j7fA2vWuuhmn1{$-@^Uj`aMqARoOk%< zhd`+B9>L&$-Y?3In9{|R{4kXyePp1?pwtP!cat(BrrdC>C!WM4nA7u~sf^A<7x?cbUzieA$GPo!lQ);{!E>qj^@Zs6I`9h`plFp7PcEsWt%Xg=C1ax>4BJ z8erqoZ7r@lKAA%x?JU809Bs=rIv>j78cl0U+~M=aFCOagIouCZfl%jqS*GE66L7R2#2`OU=Lf#uqP|6AF`oD?HJ)a^uN1gpJ%N5ROHW2GSqEYd7@rAr1DEk^G=ecHDst99`=}9p5;zbX_H%1Ax1wqIlv}m zVsSTYy=s3J?JRRkZY-XodM5w-pa1*M{{tuTdLm_RWOH3NbJsFd%PYY6?6&ATLa1ZfA68ATu*KFgPGDMrmwxWpW@d zMr>hpWkh9TZ)9aYJ|J^+a%Ev{3V57seM_!oyN+D{jUp%Dgd~dkjGzEF>kh%N4H$VE zuFjjjw-^zWcETvseHmx1t)&k|QT+bjU-eh{{NH~&|1)>{UCOWj@$>oPfB*dd|M^u9 zzW@2J{~a%n8t?J-|N5W5{@1T^{&oNJpa1cz{chvezkk`Dzt{R@ef;+E>*s^l?`na2 z{q+ZU2mbu|&wcK{S0^sOeFmQA!NFw{kMY6%_Yk%f*eY?s^Mdxr@7X@sey>XWdGX-S zpAUBQ_k$O4$McQv_w$d_UR%U{zTfZoo}XbIZ1|q5Jwtmre*0a|^QrOJnZScN{)X?Z z-=5D;`&;9)-_3uSm-A=f&x;3hJTY+ddixvCtNQEb!NDBg!23<@jhOHIeE#+OrQd(L z0le$`{T=IZ`?oP4+5i1}_dC8`%3tH>^LeHTcwzp$yzROAw|@`N%h3By`qB3s^!DAK zar?{f`Cxy}{C@fu?HwGy-=Lp^H|D3}{fhNy8c&Vydq@8dp69vadk4q-POMMjh4IJx zpZ<+$79OeelqJ>v%r>S>N+q>wo$?az8oR zGrjL<&qTl251;-deV+Yv`df$(J$%MP`T>3WKCc1C{A{exKmY2*VusDn2!4JAo`KzB z#Gr6<%~%f(V&i;>_|rq1Xz}2)<857hX4LlY)`){*ie?l$rgKCGk9|4H!S4=FJi)ON z@3T<%_g=6fYF|6(!8xAKQXh({`^B8me7}ey*}ouU;Mg&-F@b}lOw4#Meg=Ma0Key_ z;pD&v2S;@EpB%HRzXR=?D4HDjv(TM5c9g0A3-g-m|# z56<7mdKu{DL(z>r3<~~G^u-v_!7WCN75HGz0C-9(c?LD&^_)=$bB6Q%I-VJ?`*iJ4 zG-nt*y5|TM+Hc%JAACme!A-dA7fmR&>%i`4g;9i2uLn@j)6*gw<^a#6n#&P%Q(X!~#!NIrJ`aM5An4irkxuY)NJeN!0 zTFF&P1$OT0Zor#scIN1VoA$s*pbU&T{VYDdXR*fCVhsaXYB|e#1`v;E-MpuKRtCo&CYV>kp1K<=NgE&oc7vgUP83*zvrB_aA&_ zuyfzE#w;h^ZEQ9XEo;UwEvvl@%?qB=hHvOZNSGno(;|z<8R-X zXC2??S*!NWdenP1p7kttrQd@GaO~2?UH9q#5blsI@;RmJd>->N^xW`!*ZP}of9y|U z_J{9x(ObiObk48gtkvx-FisXPZ~r>!N7%tPcBV;?D+CKv)c z)joGDSB#kV*TmX!{Jj@ZWMZz6OSZ`V^7q-^ge;Tq^L{!&Ap_$ZqVOTviSseR0lFw= ziUV^8t>kc(n9@4uYhyl)6!@7)wuc?uQyRw#_msv#ksr)c6XWj{?Jdq_wK8fJT3L9GawVQR1rZoGe?KiD(fxko!SP?Uxn zt_3L#A6&kK&`8dqbZ{v=O>DlauW4IfHrSM#M6YFOHfv9$5NFz>@y zAII(Itau@ItT^VwzbWKH0nSr0n9+vt*>R($T8POPe10%Y43tPQ6 zq=TttM2`pMgh?(ohPVuN@c>PF;fMxi#3g45>)aCN4K#o6_j#TGTGpInpAxhJ)UK6rquu|G?4EaziM4(0olLwVzE zlU%Wp>&^nXq;ZdYt|7q_j1)4PZuHpGvx!15zDX^xbN(l_#Dm|TIQRSH_-E58!S6SW zPv`!u+T*7FF35Q}1wXhzj_Deo;fBohT)I&YVakQzv15w9M8Ok#&f<*^1yAS=O_IdK zo!=xmeQ=CW=j0qIx%-Q?BEn8CF$YcoaXq%*H_!3u($iu@?4RcfLb7+$47n&?cb`eF z5F^no82hl4dn#Xn`3LhP;0%JV!I&VEqo z8rY{gsV=_nKQk2Vy)?I=>B{@u2hT5>TjCQ{}?cx3hzNYUbJ($kT>>n}L-@Ykw zn>39h`-|~`&u`rKj&-O%{qy?tAJ!qPAIIa81^N3tS2uQ~`<>)=)wapSaaeFA6&_k7P0O-mDs@7ml5|CU#R;1(V30U#BAYXubRo%&o5^Dr3V*m zA3nQ;|HK`4mIr_C)T_PtGe&#xxuH0)2F!U_AK^z?4qlLr@`1(Kps_?z=#{px-9pEUD%ZSrGWaMMKSem2HS#|K( z-#E{r4^ugq@&^AUNvyle8u{k)~l<1d*{39 zPP4-NcyQBtO^2~c>wVVagOj(P^=v6`4!kc-&Efr^KNG!uUJQEN53c*RAM3L(JuS?4 z9Z&mJXYHlOp5JfZ&sTqcKee7qvR8~pnz%JFU-e?HSH7?L&9kqB(Z4q~}R#$$Hx8=sDLYxh3F{&M{*+I#L73p=d9bK~Gx(ZZ8*#nK$SgoC40 z&FIF8>Wh$0dR32i0mtzx&BX7=eNKunVN%$V^dBpx9lOB+TD#JdVTb1P&(g#W)v0s7 z*ZRF}aL48C!q6V2NB+L5f8ao^Tzpm_Ir46ppLL}>-!f0*Bqs+gk`7~sr1Tt0-!OMW zx^uKQs5{<{9U>08Ly3Gj{zV$p5hSv{=^P%l2$`HJoCZ!6H_`~;7HPH zZSE-Q#m>3UGh#zJJeYepR>VpNMe+V}uz18GcDp>n;2T5-2FN;V-4P%B&hWvly}0H3 zDcQ_>hJ@r|@As?D3|L%C=rZY$0UQ)p>77_ekqu|u!G}k*rtig#Iw(%hc}C>(!!z0= ziIFG48>}=upZdPx`;Y7wD>(0bIo^k#K>-hG13cv5v%}iZ?|DYJq-!g2wII!$6%6e= zT_(;iwzx27aO+e>ixqpkQOj{Ke-Hn(T5-zC->^1}sL(&H8fc7r?BKCq-2ZyN=W}4! z@A*B)smuO+Mp#1|99$@THR=Y9x<)`QCl5sk6tN38F?St&HEIaCL9_ZjbcLtLcldCU)WKnFX{>8bXD%MAU#<9kETA!oL! z--qrs_Kb0SUYcYkdhFs=m$4E2gQILMEisI?1}2~WHI<%bddg!9F>Ak;|sZ~ z;jbi|YmWEt8gGobsYhF~Drs!zNl}HtXE+0F&qc!oY*Bin+=`} zm+Gyd1xmjM8>rs&oK%fDgXh8BmDav)S7tm(HmS%AXD{u#=kojBM(EypFlNxWrqt9N z19=P$GA z^#2K!O|fT4_$J}<=NgB;PoStd_- zIN{K_@{ddhL8HQ)u|h3`H?3h<0Kx!kK$O3D@Z4w)9+-2`jJLc&b>dyGJQU_M$~#5a z9?l`G(^&6o&DoyOZ&BZ~a-W|S(TyTpR4tx^Gdm@EoyATX-WO9^*!q2}7`;)le}2b9 z8X9^&{n=AcYsQQZV%`{Wa=>nzH^5MHLi%HW2Kdm{_om)w`%BUx_#V`hA!`Wp1_~PX zEsDX(;~RTi(wA@T5x!5^#q|Dy>|mOosXf8@Mt__5vhyUPB|prae_?Vt(hH@tuK6H6 z^}F8hed9x+16;0lc*`6d@~KXOfwQUVi-S53osFY{!s!bhD!y@bItLf50QT^JjwEMr z6meBh*r2qg85sq4XhuII*4ZhnXqZtjLy|xBJ;|@^U!L6~&)%l~Q66@UclT#S5T=ki zlL({04Tb$NoC>D)46>1S@aVeHus@WSP2)FVCTOpKBz;X|C_;1eK06+ zOnjf`8r9grF@hq-(vH-*H2a8}P&H?KJd(g&5%9!8p34MR7Z+~<$pZ-_S1ZJ4yYc5~%j&nPoyH0+N7kb^Mh@d(2J^p@*3v#?udmx|3 z`#GMe`wH8iI;Y!uv2J{Pziy3ZN-qcsy|~Gjy^Qzy(hZOEy|9NQi_WF{1;3B`+a1r= z{9y-7o*Lp&ld>j#BjWcXPF1$IpjT7G+>DFe(W7BUaJHs}p?-<%EKAD6yD3Q$Digk)z!X9Ofi^R&9JVE-M;nV-+rnoB%8(@>1dv|FwJH`or{)wpzQ`&{O?OF4 z0kl44UQK8GJ}ni{yOpK!V8@n4z1a!{=E3OSjB8IXvYL~kO8TCFD;Ig#O=xnKe*K|tDk}-IbX!6(V(%aJ8i)WU+K1SE6ZC}sR`>o@Q zmCx|N3Dd^&{c`2{HfV`i@=nA0HhEFft`w5I(-%>6cnU4BEv^d*apc`*4)!SgB08TJDLe!vgTdfUS=N+8IXL+vG5ZI8YmXNWvCFOy?WJBG5=s}p*f{aK zJa#uUU_JHr;Gez9ZV`;Kr=Qne!n6b6MC^(YFGZL-T}U+Y3!^4BgEhy#9J0{Oq>Bzt?k= zoPXWwNngBkR?$Ci;Z5!F)^1u4-h#R#>*FZv^!)vRc*NFpacD7wKkJ*R|jdd?e$>3P+S z_B^+(8wPAzwsnJprqpCnnmnKKMhnj#TZ#t8d0^|_$U+{Ft{R@tao*{M6Y_|xs=OiD zB>hcTxNLHNEZFr;R>%ciw9#At;DPfN{iA1&(bM8!$_GQw<9w7=ay8wMa6?>q0|LF! zbI7CxThRI(dBli&eQsdO(0|%P4yHT<{=T|ya9eS;af6fYe1V^s^m+^Oohhfxa{a#O zx!d*BI5_$%Ez=s94{4$3sbkuIYshm1^hD1cm^gq3WjyUax1A@qV4QrbRuv_AA#nEz?XBc{xEPK=6q74CrcIe z0adoYh4Z%7%a2Bj`#9gPn2+2K75x=|Ua*wuzHhvLl;qDiKgyQI2j^wkkA`X}aSHe? z^$$fFFX}IrG)nQk)KE?7GpGT@elJVs0oJoL+@o?jV1LndEQm%V|d=h!OX-m_xvnV=TFgdYA}m_Pn~fD;~sqw`a59PDU6zk z^Bnr4@#@4&S|y;-EYx3w4jjKXY3<#vKI-5@&qX=S2JSN@HELb@uGEQBA2wxWIP_I? z{tRfKi_V{c`&~&Z0jwBB=g+9p&z09oQpC>&JUoiBeIWS~6BYeQyH}CM*CBrwX_y`N z)gpfAI3Eh5ERK8_`ahj#?)rU`{K?;^9gx3IJ7QZ(?DQw?l0`Y#5SAFY5?4H@ya_+R zqVuwE=;Q2>w=M9OJYMX|>(SrD)X#~(BQ;WB$p5(S7klmx`^C8L7V#%sY#&^)9*K*- z2mWDO<4w%|6R&I^827!4!LN&K`vx1$#kijpSr`ob^dN# zCQK87qkVd4T?~(~7sq(?d+HA^9^dU($M_QWzuJR_zev8Trv9W49N!<(cQmw*`Kw$n z=~pVOwnh2~IP4xwFH7q86T_nM;)4ECA4C22qrYMQ=v4^$wdlTAT=N6|3&s)SORr3O z#$THDb5T4A>9xqKlJr@npW=G6zeV)bq|YKfrXT8j=({0DWzuikQ}pNZdoAVilcP@~ zz0ptCwI7x+`$v6U7ypHRlYYBJp8PxcV@9d@xcoHyfXC&x4LS6f*bdnG<=>3bOMV}I z%Ke@XN58n9^F)5uI)9Ena=<>bq@Seyg`Vn5=N;`OQ}&i3&-%9R`7Y0W*e=uh0oS8Kgd3I)Ii9`;BDI3^EUY0r4evpdIrL3Wd zW1RBq-N?!~C2?=W=PY?!!IPbW;2+&sY-xwUSN{m6ywRY4OFoQ<({DT;;ld~L%m8IJtoW8rgBc9A zR&0ba<6!Enf~PQDDRA&0>3jyyMCp_U&-{8lM?!|F_xB6W*Sa$vSSuJjw%!>HnI?5! zThB>RMg1AVafZm_6FRL(LAFS7K{4rdfy_>O>wQGV?!3dqR*(5e9o7Ja$V(ySXDL>o zR%rd|g8yNyUANj;k-)gc23I_o@nf+E4=#v~h%Z)LFY{J=u*0u=cj7{?*cG_R_iA7CZ-#9gE;jLWX zE3}&O6si#C(~G#`_)6cfS{QA@TU0Gg9;=u?#Xf9(zsj#WD5e(r!B7gR$c&qQ&-KPG zG-rGC)9(2_XnFX1NY#xVu@%Q-crTj9x31Onj9*%*!ueYDdOvD@t%x3=b(a>aQfg9m zy;yH(wa_2ZN27P*p(nc40(JHmIFHfgRJCq_1syyR0gRLtzgYEUWXDhy`BAZ>>(Q9*g zbz=tzQ}2^l6erBwRu5+XTzWsOSfibMs(-}1*VjhBfT8!(^9l3U(r({0-d*4RnWAmj zpY+FMd-NgaJ+>-RB5}$0{aGJ*ZdFEt$n&aJ`m6e-2OrnluhQ-)f82_&ri@g0Fvbss zUq&PzJV2pC-;ef~4X!FuWNSW(^tN5}!yQ0+YuW+$zUFJ)`KPB;MV6Rq)RcwX@!0{! zm|NZ~szGwEwER{hkEA87!UZBdS1K)+mA+I5Gcp1zDD3xn+0Pk(%^oq$McAGl*0wxL z@O$C<7Z%TE`;9jZ^;iC-8egN-QE6#yMjmQaF~aN*XP7tLY9`-1&QHepc44*;9%L?G zKF*her%@AhF#U5uQMA;yq4r%K;YGh^{20dz%Z7N|!F4`Z8h9Ate~kl!Ma)IWc{gz(YEG zX=Lk2Ob_kEgDZM*KJWC{&hOd#yvsuwE6}@skNHKao#%U`XutC_#={dkqs^$B)O`+nz(-mkUOH*MYZp_D}W7}`OkSNLAYR`%Hu4r>JDz|W4j z7(4|Dr>>mnjIyTpUqvFoj6$wn6)Ogc^ZG3(`i;U~!q}0RQO}rH&-WoGem~c#CroSf zgTZ5jwF566xJm3T^>c*zoJ%jPE%UUmpz05SY(R$$6!f+un{;oSi~|=er2}x%wYC8+ z_zg7NN;fuFFG#OkPcaAJ2@y8Zf&_*DSWbSC-ir?KA;*HD1KNN=+%1yf1g<(>fIEnP zoctx}XmE(F0vk44q__?o&pop0gd;*c_Zh=IIGzuLOZTEs#`BkO4cJIIcCf8$+CDfA zFuFok1#nQcc`%cDU^_D)q|#Nb4zOF9Ud|V(%pClpdpZ+ul52soYl%Uv9e6l5=$ue~ znT}K#S1`u5WlY%;azdHdxn_s6Zz$h%?W{Af;o7uMx}Z?*=~}bxDhoGtt<)`U`!Wrj z^rt~R^!oqF1gw)HQiE4XXnZR1QN2tlKjB44ACfanX2J_eB3Bgkw|NqAIa& zq-0)Ve@vkUAI}e7NWi;vjbsYAO@>kz6;ljDtjnO9tNJ}ug`3LtinJWIB@!>BPTIO= zBMl8TqQEC5+m;$*BIVoW4yqIBaW|c94vzj%l~*UmznSu@PNV{rBB#QcJydn^J%*P^ zQFL&DY7QbO2rU&^2OAVu;1IJzaU}t5QaMgzew`*`21L$@KwB9P4yLh*<1-oiOwXz8 zCsVH2N`~BT9}Y5+bbL!lpG`9k5lYHci6l(cxv9*}_jQ0FpeU53`u%KIHF&U(t17Du z@F_(jMk1iXK-hz6jsZo^D)S`!lj{GX=ZofnqW8hUxFT@hE&cYF=G^S>Yfd=hB?tUo zk^Eklxsxm8Ipd-Tny>i%A#)Y`KV_a`d#T#QjzF=CUaH1J^I{c+(pP60S8Z2lJA-34Di?q<@Qu6A~-yWW$$k)ttu_${mGk^s})mBkrPNaogO4&S- z@OV|F8bT8Am8q>Nc(5rT2lKI%=mh~dm#4yE{_s#5kdVxEDP1q@9JVr5*TnlzDy2~7 zD@8S!>EV%?I4G3ORFx|2;Z~Z?UBAp5Ow^M*wt?A3Z8#VNk%W9_Vx0yatALhGWw!zd zkhmv#W*F#N;Cz39hgLlg4x-d*yGi*?174GIoT@~I7#KYJk?gI4=iHE~qH0}#lw8ZU zYel9;?Bki?9PwKCy%PB^6m7~GK&mEI*ZY%+LU*PnDp;X;XEfHUlAM=^1piqQtr->O-%%wn@Gcu&2cl2xF#6-;e(#*) zp2})C9geE^aZw#z%0xKjjQQMcKJ8E4O`vh;vq?1vCyOb?LPO~Fe13oWKljC_zpLK% z0=L_rz%<$?rqh+$TP|fc@wn}sQ*6-$eO3%%Q!Cc=C)LF(Z*RCruc|L1xL;hjG7-;` z0f_3@B{>EDsD0_2hQDfGkNP{FkE_0q=c#Oiq_!mKK}U0Ns`t-|tTZ3M4emZ4dY|fK z7^v2iatNYmv*9=4dp^i0_*;9MQgvf;Db0UdDYMSSzOY zrEsosyE!Yy{%oyS_UH4Wr~Uv&L9cX$3M1+Y%-@G>>eon%`KfgEuJG9jJUGAcJ%+|; zJ*xB>xTbhbqi93>E%g^QWKoCp@F&cU@de#3P@eE$njJ$-b~#5^*pCkeP1e{hE@x?) zxgXs1d#*^_KfO{Pad5OpSDXsxHBS=@qI$i$z89`3UWd%&6C67E zX?|*3YL7jfYR?{7kl*LYjNhm167TC2x!5K9EbQ@J-}dH}?P7*xh;B=JgtF2CSJa+> zE;GE4aLzYmiRPl{hubqBB->={dPNXLO@|ae3i!-;egkHH%R) z%J!qbG7BO$@lvcUNKT?~^8ud@|LicxG3o4tGHXx&$n{0hC^P5j z{A3;9+Zt~d4=Tbug_hb6im5VmJ5Hr0Gv&Z3CRrY_j+ep^OX*6BM6=_AHz-=~_vGrj zZJ=gH?Ac@GdN3&HV)RH@w}qZO279(Itgv`cr)1S-_+FrxG|VoXYmzHaQ}N0vojgOX z4X7!3Fb(BArzMH@0iKZWV@9ha*G@@IauU)9KK<*EJ9PhrVcP4EAwMzu+wr}54c%Yo zxW1Q$S(jV^3Pp9YE9;|7oGX!S%*S}nZO*sS5mr-`uZqfmt(zZ5LiKGwlY48E~A z&K{ghg)^=#*o-Ga3)iAriO=RKSre}^H{q6{mANDL<{Wm!1nz~36vx!tJun&I3^V2N zx787O%%UIMb>xp4IEAFo;14bk1EUObKPpa%mB);_wO!5)bO(l6w7_%gDCB4SBWm5-qjwx6%Z@lHExvpiSOh6rtxs)Vch9bnm7#NUDpqX7qLIv_!v`E z^^4p3sNGh5vCLtPSXH;{opI*Rb)Dq*U7{xG#{KsH^jDSq&Um9e3CE6DN0-kg9)y|? z^NZMz`+LMTyQ{zOw{dxFIs9duYBd=2IbvLh2mEwhjBdbR#Tn}m&uh#e7#)AF+II)X z3P`wQw4`d^9nANM;g_r$S(On8R*=ID-;SnM2a6+JpN^t{|gBRjIBr zdz4EBaWM{VX0vh`e3^YpHKi)EW4IK-1KCXS7vi zbgE1E9q`*$?Z$(Txz8p14wxHV!ttp39^0$=z5c9EDw3IV)aBvDoS~|9Uzvl{B`WH< z1Q-3@uZu~vFE3l>P<45HK_lILh+g24m5S`q^10UEfXmnV>vA;^hoD-Rhr;2h4jytS zJb4zsIK)HPB6*mEYv$za5>}PpL_BXKkEGMg6psPVV%AYre65TvQRTqOcxcyo%Gi>- zqTJIG)du{IU0$q+4*J3y6ayZ}d@7d$5MP-Tg=nPvy@`AwP8W~L{B`g9{C!*Bm=5x>#`?IFvIC|N?bzdz z0MB%dR}J7} zvJaZBdX5YuUgbhSV~;MlH0dV~m{UB=Wbz;2G3j)|737L@2JQYn+RNuKhPnKpCyYgI za+yHJl;mls{`q|0#e=TXN_jCd_+1L?qTntk7Vd~4r<1iF9!;l|<0=sA|wd zT>A;PqY60*BV5cmCOK{~hg-TuagQ^HDI&*t!gji2%UN>xjdgE$5f7J!K+jw z{`7dmoaS__t8fB17+i_fdy=ME?I+Le%`eD2w|Va9%D*YcND0L#TbCQpLKYC!I6m09 zhdOZs*TWjDtv!YBGmD@rRsgjxDpt@oO z;B;|m3Nfx9L>C9uO9f+&q`1 zD2K<~l?yi{-!9|arldY^e;gEy`Ph`)6>Y@+cd3xzv=Q$YJ@3!WU{j7<7mxkOt#AtI zF7xjlZ`Js|cEC2tVW5{yp5N6U%9&lYdMdm>&KIK2V`6djjXXZd^|wosWsipB2+j~r zfi7S5%{-3U(|br#CT1SFe1A$ZXM4zNqYB6e2N%lzEcJ)3ncNYQTlSVqLO$mV=JWQ- z5x6{GIYjT$UU^8bS=$OjP1dt zA>}G~>)cak!?Diot|xgU$LHE%cYWK#)!_|vc_`OA>k%8E5;H>(Uw8^R9^R4aq^QH_%Y2m0as5+@-b0(IQU4 zPPJ%5fO+1o58mJbMKkQ>#i$SP;xXRecgYPjptmx0zl3XCLG~h76~2OOqmoq{obo#x^*%77Vf@1Z1!;W2gpSQvM zJt=bO_q=_8r?iwDv7;HM?aF`CC^>cY*Zz9m^&Aw9aM8=98*jtP$3sWB+#$`eLZ&Fw z#+raVg8fdF^Cig!=SXFSTsbt?B`$~&)h)>=F}W!AU}J{heOI(Tl2~h1-@~41?Mo-w z80qgtD?*)L=1XY^&}0vOVvOuThV4-H;}>|N7MG+urWeuJkj8>EGIdfG;lYy=bGk$$ zq`CE_<7sW{BuXqAVxW{2$=6}98@Y_N9s` zEl}c+2E_;D5UZ*HC@9!{=E-H;*%daNh6JrKX9(3I-K$4%bGUP4Ewv6?n0lo~T&a6k zs21fjtf8JOR0{^V?%L;SPiL>bC#qC`RL9_ATQ62caQ%L0MVj<(`My1x-p1(hTyvx5 zSrxa<#CHwdz}I%>_7XW#sr zq70#lveh(3(^hvK zjEd2oUok;7n%}7@1MLLu!JRdF3!3($w@A~jfq|{DnuQB>tn(b&G zCzI*>4c0cSP)FwJo)o@i{hROj`qYZ-e7`^Q)7PD^-mlIe=C?i4D(Ane!m~}uemL1| zO0QcLY{@%6PC8qn5bnUGlZW%abTUo_cTyIs>OW;8QtXyy+4s9XItjHNI!Sw#W}55q zeG;E=RAiKpeYPoAzVbwtV1-j|` zY~Q4V$lrgRyuIrjLtqNrI_|mFyQF>2fJ=+S8FESM{9bCp`Tj_0U3k4auzzdD9}EiU zR|n9DWlI^v)EV&muxCr_*O(9Dt{~<+rS+b&4}BM!lLlDVvoW4OrL}8e#*E5BEgnJ( zw$que;UD)-%qo<5YI#dtdLx##M(s&!vGqPiFoX?vX8yiPca0fw%FhZ=cHU2B2B|x8 zWS}h14H+NOzQY)OaFfr#S)-9Qa$>noT?{>zexE)B$Wt`degCY{*!O#fi;Q&D!L5BN z?4SLe3UJhO>A8g4^SlN2w|}!`Rup+ne==4;f&lvQ~jHmVH4&I7xmAv2d~wAJrn^_ zfBFN9+ej-v=SO>*ULGT@{K$qk9xnin$K^$EPWqv|I81CYWDTH~!AP4uxav^wmGHXn z$NaDReyrEhcp4~NVF~oY82fr5RN(8C;xERzci$%uTX%i>m$T zWaZE7;e;k{Jc0Zj&$r$W8kQ3^4vaXrmVW=9TeE5p_J1aYLkXsUI~Uhu=M-d9-3AA`=)Y;-|uI>@jS;96!|%q7Vq zlXFB56nr&tpBrhXCyl2c!O}T8_BS@Q7hKJ5`!NG{-*4@uQ0~d3U{n?yj~_?^gH36WdA%VT$rcM?k~>y<@>VXPTW?K>rT{=Psxma5ksC+ z^ovL?$=bJ<0?E^oqE=F1Qf<0K6bBrdL7JIb9RK6t4EfgDx)loRXiu z_eF7wdsyCuh|lgrHeEyq9}GEQ@myC(?V=nYuZ=}HhBxk$eur`s`vV*5P@u+wFWyKm z4EXL1-rvp&xnxoBfR#J}=h7PAlENC2RrC46iqZ3BiVKrQP`zi!JCN0uhWrW^&qdKN zv#}@FVs)UTLBwMp%oRkS{*;xU)qkdZ#}<-~&61gzk!2xdK@UFyp2Rwbm`{Jm(*$`e zE{$&94kU}wj-DeFmhU<8V%%LvyYVc~@5ggL;_qjAPC#ojB?}{~M4y&7!o9(l9Qo)g z(pu;Jqam?)O24vljxHNf)qQFSPw?rQcH?n(Z9^%B+!d`f(L~yXIYYEbaaRoW2R^k! zNw-Q$muw$4LP^sNxrDBCt?}t3XN82JkVtwyh)WzRD{LM}BmNVXVgoL+Bsa8(TRgK* ztA)g>*{b(tlPcVYnTE?Hd(m<|bU)(z+=ppt=gBHvF|B^O9~~P_k@OSsE)6l_!6`%c zNjseGl#NwIb?a|6*A#k%nw*SwJ807f{h3;Aq6yl3nrH|;6qeqDRXijuHUxghhz7sE z!3i_b*}w>=`X4Kjm?woaOSR~%PCF#q=L~P%@T%<8ls1>_)RZP&c24rOmUdfEz_oMt zdy+Ji!%pd`pZD?Vkv;0)15 zwbcWr9Fe8Il2a=w3+uRysvZrUEnCm)b4L%186-uG)HCfDkJ}#a!1Qe6#K@s6{kFwmf9~)Oj!*L?OXS9UrsY#N<3+q5{c!6wIbS2@X-&IN6X$ecN|?06@wAkWP;X!Q+1B&k z$M(nvr|eW!@?2VasZr0gv()D2<*fldnocXqkY%k) z<633OTNp8Cpi6s}mPK&^Skhc)hslyg`H7ZAN}yH0M-IOVt{~YiMxSHH75n-LrK{LR`c zqv)0B`cCbYo>K?U8Q;2vq@}Gq+LZ=Zn>^c&t+7c0g7>H=m8Pwbw}2vBAoV|Nv8A2J ziDgyM?_WDpgR6D$*-h-6!9`4&8Z^Ub-$6@SlV$J0ZtwdetuURKyA&(z@Q}`3%4p`i zNBYcr;S>gqgJSet(gQ1T<_h@GJx_jIw4_0%Ju^(cBd;gcW*N>+9A@#S!k* zQJ439(UjU(qDfDhscMgW5i>rLMzDg6=2e=%#suGaYZx`H1eKUFabms?8XZ+Lf*BpD zucAh+`O-c|LTy&Fmqsa`f6V|ny^^1@dg@RDZr_p^v8DqxL6XKs$(!iXh@M-*r$^To z7twx=5yL6JFrxRxV?SrZfR9D4(Qw)NK!w9)cK}t5q+0N9#-EO+_J&3TJ}@#>Bj2Cm zgy58e_YV0$3{tUZY>?{ZML)PJ%56W+CP^oQUg%7A*=UP;aeP1DhmXT38gCaL<_ef} ze&C~wcuqb$XvdIWmT=Ce=_Z`Nr!~50{(07u0^nCBJ4+j`dmhK18bf|>NH;RHJ`0Lm8Z-H4lch)6l9{>-^l(;jdW=Ap56P3WrrjXl$B27<+molEuxNUwbvl2~ zlPnV`lOn(+CO!M)g~O!WuA8gkUzfhecvam@C%lk+y^$cFPe)$Wm=VMo98CRCVrnBo z-f5Wt78<&iDSk`XSDW%#Py-jGLlb+H7G0^)>rr|%e}5A07U>2M=U_^t*pNEXvZknT zzi|z5oni6MA4EcIWVVF{tfPn0_n@5fgX8+b+{3`1HEBCFWU=d7rm#i%?54Em4LKKE zro2U*MN@@D#yzy{YA>|9ZKof7NIM6!zrk1A&RCYE72u4<5x`=rf27fCN)ghKin47< zkceG5xC^(1;;n`AF^LB;f1lWQ;GCbJfF(cv*v?H!nDhJcjzu~0gEOum=5LGQ*2$c4 z@K)TzN%33C)t`Ny9|}o*+er~zByS>4!c^6_A;+Z^$uiKdSxNmJYIK%<*W;uN&Z@D9 zYq6{vTZZ0u(ZflJd@(9w7U^mbTlBQo^?pX`oD|Vn1sCO-O;x!Mu6WM&k&;=7`j7S~ z9+4t`qO?O$sO~7$L@}v>U7)Dcp!&OqQ97}yCg;JVfU#e^t_D{tOs-P9b}ghSWO}u% z3|xE8Q71lWn^l?p;FD-xmERi*mst_lL2^#ZO1hPEI8tIp`b4fObeMs~H;|LhvbOQj zVK(rY!~;|$jaqzB9=*_snv&}`l+QFJ(?2+f1t7VkKikh~)!~B+8bxl9310RLedwxzf=VA(=b&*-z+~%6>RC(mmcD zx8&sfB9gn8jBY_{@gl7-ioe|%K(V)jshjDb`+7BS(L>z=QJO1O02({gI=(aFT2b~V z_})E9kcQb*;G!Yf;N=S!ul~L-JwGBpEUQf;y5;M6Z4X~Tv`n-o4I)=)Xne)q?;HAW zcYdsXKQHe|h;ovbk7)k;)rj_&Z$W=(S>0OLuf{aiGqrOK{mnQHB;Qxc;ap!yUk$0^ zbB{v9`rwZKOS;qgW_w8We!oY)>UX^tFzJDO*p;cEA)Th7a?OuoV-C&|J8Y3XBInN; zSmM;{FI@G0TMrLG$<=%EG?a)bx+Au&9YYG=qIl}o3QpoD@+SE7R+K@7q#(-<(s{PM z(kE^iK+ zZFjuv-yQ!;F-D#yy@VMkK(dx`56O~*RD4$CRgXv}Q(EqbeEQ5+tiZf8gfsBWBI7uh z61jPcjBd>3TV%#G=9t$-!3=p76|#a7o?bG@3YkR9(p0)~()WIs(u>4UW-cu<@Gz5T zk%32;j*+`GyD^|X;o4(a0|=>64{egW9F<9Tk#g5Pw6 zF`slx<3huT{BFmc;~~2%&v?v`-&o^8V4SNkGHbjgJ~TA3hBBpFW>x1J&#&yH2lpof z^TEup%r8vLh~3}EjLYzgz$jPQ(g>`2XH?IJsD5HZT4Q~0-1hvh-v`e2k&U+XzuL2F zE@Bq*G-olRG|fd@S=o!sJu`G`BQmg{L{FWmb5FIaz(a z*9{b<{veDh`a6h~v0BEHNYUEw`-b^n>&2pIy+5AcV-KlLp|kFQxQsXL@||Ho9I;gU zt=$aE5mw}pZ+9zI0p=L|BVwXXY!Sc`nVGQKEBxr{HR z+>F=_5oyngWkziVW=-Y)9crKXearj3R-XPm`Fva7s{Mf#b>#VPI--@&x5*U1toORe zIrqHOIo`CRsF*kWK20O24AOLcM^+hcX^JrPU+zqvJS4xT9i{I@``U4cT0WSDgn}IG zQv5sX5XglMk>##J!ZdazMKxqhz2ECoJUQ1VelHii&K&GL#b#f~=^a}QivEcl#+=cG z6_y&CNp`C$OZryE>5>>3uhW$BX4OwTWxU#=@O(}lna>RrkfxN5tn)+PixHYAVq=A+ zJ&KUrfUVWYMJAi*0@5?2n%Jw?EJCeLOTdaSk`hrjuFKb+P04 zRbKqe4`olT2W81Lt!?ZnIr5B^l^-f`!~6`bAGvtq2Au0nE?#6RBbVoTp*~TQa}@kb zat}55-&`&ZyX?VB?|1C+G!@4D$)F7HS8wy00v*q}XIaff;ob262rPPId+Z+)ows?{ zH+X`S`dWXT5|foV#x+z?(v_3N#C-|gtv_KJiuycKNTS|saDADIV#i2%A*=xG>AJnR ze&5!ubI=e%lC@A83d~)(1*t>5>h{Fvtv>I+=d_-S!t~s4du`njCr%1a%t{ZZS|@8z z)i~!SYHn2}z?w*BUvtmyJoh$n@FXQ6Sg0^mWe{IQl^j^Dv#8dF={c+0fTmXwPhu^~ zqFN(3`4Q3*6`b^Zqk2HLzx%W2R?)cv8eJ8#t&|ZcnCFcF6Ah_94~_M|uo5UO-gjhh zUma8?w-MAU^(K|-;;xYaeYtwfFAh~OV!hO%`Z4UmR1GGM00j(E)>})}LbBdzLv07P zzwmvjq*1N&%9?AbM%2)Adu7#yS`&FHt(nzdCb6xDrq|FZ^;Q@C!mM$X^Woz;hnMS| z=J&cz8IG^#?Zt>$!;14^l8wQo5Y%&TkIS+;$|feokizvi zW5uR^=bJhwKA+<1uJxJN;q2d1g(wLRQAKQoim+VS4}v=z5aT|;l4I+BfORB=G1-gZ?qN~4{JX*NXjHvc<2KYV65f9#9&l&2Q zzo!%XgQ>AGTrxP~GXuOkRP}%ro~Y9^D4)F0p}`vTx`ly-2Ty3O@q5S&oTaAR8a3h6i5b|lSGtv18=`SbT%Q$gto+D5Y)}qH zHCJKMbnogPs^XQc{!=m>93S^6Xc)(NR?V|Uxk=B#JRKH$%r`4gStn+DTyaPVs?cS) z)OmH?pL0YD3FUG|m{h{r5Dnsss_Qp3W8C#aD+W2G(*4v_XHYcV7AQy~Xj>!Z3_!Cl zNzi0Tpi`B>Fqm?Ku`Zvg*cl9kS<~uZ?upunSp^L%Vl}Izm2bT2i)lJe%yap{SaBri zON~l?pQl9h59j#O`_!@Jc*?s+tw^g33Z$h)w>_gJCApj|AC$y3zmk*M{45=}d5NKPHv0sKA2#~moS%fMXnHmn`fOut8sG-=fXL#xjn=#Ucn zv%`5iU+?!d|BZ4sP3dPmuUr=N3XNCJ4=q2{IDfR$?4-{}$7$Ejg72$NWLEMt%c^W~ zb1>E6qwUHp&oNRI>mY7X;8vBmE=+w3DIn#5xrkYZaG<@JT6AGb;>1IC2EOm9#a_g1 zy*sR{e^Z!}Is0drp{gBd(qFK@CVj`Q?{icCX@{Vka4=Vx^X1YJ^7k$sB>OkCqTG?Z zISuu1N&mwg$@NitJ$0fw^*Z$8xE+61u$#2L;2E8gt@ePP+h3UO8P;3YRouehX`mru zS!xpNTo=|J64p5`?Bub+LzUA`k62qWf-0=%nqUrlt|8V$wi{|F4(4r?n71S90}kfx z3v=GdCFr2}2#T;FTjd0XPCaz?mi3o?u_Z9AOPwC!-j z3(_UErY74BwNwXF3(7ejc|X+%d3!0E5#DaFt9sXr@_SucQI5E$wNNumYa9~}7_#Z{ z{`MJ>H|=xmGp8)UFo=U$vl#opn@(=NZ+UWe;xV3+7&QRCF!jRdp}W4v_8qdw((@q= z0cZkc`m(yDAy6eX76((Wi4}5a7^Fctm^5{@~<5h_*?Mlp$KiThV&u?>T=1^IJs^1M^1> ziH*wvgsFkzdQEwx;M^WlJAms;Ja2!3!>o&AJ)Zs^`m>_nV>~7ff?P2Nb3S1=Fv;%7 zMdKz(3_(zC;s6L@I=G6S*Vp^7_L?{dt;1F?{VjaIiJp7C{XIK0ePRZ7=#~zLE4;sX zB4VwB=WSx%?yzEr)eZ{i#MGJL)SgW{3^OpBb|89)d_Q5C!S5;gX~w7FHY!@`&LM+tTrJ2Q6_t@ND9gitc*5+VAge6ZviL?QxbolU(bK z+h7ycZC&$Wkc|0$(`|BTecc|pb9S|d{>(0!gY(_RQ8|BI{iElkZCb-wsM=8S%qv~- z14Dy^5ed^(KHvBIykLc~BX&`ZajfVr^0LE-*VbJD6fMk9)5Q9oFzp-%^ZpD9Tsv=5 z+_P)zc2i=6iy9nBu57VN4%wusq7lHS1hGrN^eyG{ChuMJ2u0bvER7g;26@*WOz&I1 zkNaSuE4d*yC<vq?fc^#_to; zRlS#@n?YjAW%)hIjqJ~o#tJmNr!-VJMfSjR-KBQg_xZew#=!%3()`kVlcsY$R)62G z^1;EWw^OP}ify>RyKq5&EPdqj^f^9p#MDZ!a-<#)Er*e{Z75ElX6<_jOaL>JPY9oGQI6QBc!(9Cy#Ph^YhQ z4p{OtEQ9kwo->S?o~6x+dCKPeQLY+;^Bw&w8qbhM%!IAJ*ma6@VcJ31p3648C+Wc- zTlvA9|J6xf^fcyk)BJNiQs2V)YO?Ir#O-4J5dG;|`5maCe8MX=Hf6xpU`!_x_qSwQAL=wU6vNyY^YDWbfzk zZn|!h9Ui$qo0X-0nWc<+k$pq2R(^_h@fGK{T=G^4(QNGIUkDwAW%j%42oe6?nCyZnlWcqsh9rUI zSWpnOA(%@W4OdT5=m+3coq73|PlN_~JTN+%1*ng?ujxMjv?^v?TX6GbTddwyBMwx$ z-A^|&8-l{{o(|~0VSF><(ml6G_ZA#~o_CGaHS@M%|K=sP_vnSHVZ32chg{_8^OW&a z{2kaDck83+gXOI9w;mXB@WtFMkElxKP#@f|(eiS$1dcg~!Oiwh--C_a#?GkLyCzz5 ziSh$352mmq9W^U=^l1lV2LEoM5FY;CeZ%lV@m)XZ{lU#wRj*zmp;0_BU!i+07jrza zpk(;vs(caH_Rci^L7m}2Dj+x<0YB=mRAT0L)WZj;Z?8O-PkUABGmleK#9yA1=|PUw zS&V%QomJ6i!>7U|v5cwXKbyej)gEZ+bm`aL%Q9k#_*!#@K^J*cu>i(<>t*9~!?5KU zt-6pqKly}juid3<)Mp7(uRjNk2-vDf3JHFBU7WmxsYktZC3{i%GpVnywh$K*usF%c z*GQ{04&|Koe&rlcZQhH`H9C27?mD~XICtDu9M3(XQs!FGQf!{KXC`gB(mjJduJl3iL|DUNH=a$bNS6% z33Y8YL!oIH@4(mO*=uNdF$+H5PS06>ip7I-6WDz*bpN=)c8r*FDtj41J^|_XBsk6{ z?$IYvmVazACRRY_nqqYEG7k=xP4Gg>l!wnhAB?y7Q+o!Q$3W<6@*3{v2-!S*bh99M z_PU5)ueaWUdibT+?kUM#_yM%{WgAJ{PKGG?z;x)Acz{WGBeMyOo1=Vx;E^%t2wQFX z`34jfUAw!&=I1-O<@O_(1+d^44QFuf6l!oSxJGV3q+O|Ud81U`hsf_2Unajh{&i(; zTqBbk;i09hrSE5eD?Wa{@}1PB_$uaEPyP(S*_%eAj2`G&wquqMXIcMyuE(#uqDFZJ zKox_9>6S!vm$Ar_pdzbSn$5h)wv+ zdP7+{`~uFN40bmYG=^xW|M@>**8(-aW8s3zC+FS0CTR_;Fu7)Jfk%c27`^3dTKCYK zeTG>L=YFaLjMy8! zcoKwqP(qNePd)rucmJ|S;dz=>#4_;_7*;b0^kM>xoNx{lU9nl#Y=7Vj89i5uV81q6 z`lo0VVGcQm$N85bQ+B{G=0zPhd9v;Oc}L^Qi!mk?e2ly6B4A65LiPo-AZg1fbW9Cq zvZb)_$;}H8aHM9|A>g}6nRzis;?*k2yM1tXW6RwjMT;{x(RU_ABkc&;c0t&em!v?fmd$*VlA2dBVcR2@pVA`R2kiE z?g>Y^3MfxHeD7f$()!A5(C4}7pni&Jt9W{u=u);w+R9S}JjLC6>hL69D)6*<>D@J3 zxmYEyjB>KwOv)i+_uE-xNC6VeCw*tz4Gj^aLid)`V+4yr+XTwGHHRef_@>R_V z!{4eWsN?YmGBf{ZP>c%(Ma(#|_LS-t=JAQUZm+rfE-?;Em1tGZ5Z527tJHYSR+l(R zhACwHS(xj@yg!Uvazqs2Oi&3K#Vsi!0iTkQf96vIQbf!okKW2y<50j|kK(IH-%SKV zW&%J^i`9P_QJLRm2Ot;?p;hdhBFOG6c55V?QUz)({)rcvE zW;;0U+A^Jdr``&iuccEoCqmwAaV;EBu=~;}F0oe>;lFF$-B~g)kv+#v4UK=BppjhF z`XQu&A&9gaD3*g0?U`^>YojX2wZ!Ld z04-e_E}P0$Vfi#F#VO|01RTx2gQ~=u#7d$9+K0=ue7emjnpdmq`j_2 zC^SW*gLalAbdh6!Rl>NdxZJ`Mbf+L5xk?~7N1}vlHqsb^L)9EjakbSoE59m1fat?) zEMqdP=3;<|_IdV)M=66r_3TkByQJy?qY_ZXto2tIR@lD|6EXZT?E9+nji7Jil1>XU z{duKh_|eMV9lT@Y=JU5>CfCvQ@g);ua!oq6h97*k8K(W{!m%pW3_dvVq-bR@3`?%w z#(pp-Cy>;<1nh{$7IESM&7c6z)mXxF-E2pk27T;*r?el`aBscGZCG~ZHY+4@zF5ze z-DKO9$QF#@)u}SuSWHkR--4W+I)z!{AC?AH>m}N_xls?QolRvxPfV)MQc+2zxf)-n zRJDdm!Y`GK#u6KnGW{#|R;Aj)2VZkDM;qWXo;!5D*}EWf4FB4^F*jCiTenx(hrFaa z$cS2(R4rrf#hmGNQ;%49Ud`T$C*+)3GbXoqHSo2%Xc6Aya}ix zO(i{kUX{n~#CNRch!5Ttsb>R0<(r;H0{IN>X+uuG=XaVr#Mt0h*%*JfXv&~W)H^^- z@oAY&;i^Li!{yC3Z>M^6ud8Tb_Z-gjgvLjnzVMb1KMLJd>7)h^Jm|5NU!{3= zN9<(fv{)Z_p6dw>j#zpPA-{3#`N!jV>^vIIq5dAZ1H8sT*fAwV#~5fw>tp;eyMK(xQ+F%%P(+cC)&~d^CwsFzap&%WV=ddB zTl##4(wWMNM!NCZSM@6tsXnj+qP#4 z90xf=`n;rQqn>)n-A4Wru3Y)ZCMc%1YMCsD?1EpOc!uZ-NOEa&RT?R|$J+3`793Jz znOA4N3<^d22J)05NDkP`Vc&cL@@^))GMaOJFCkJ3;c$*D#ctO!E9R9^W-&IA9Ghre zEW=Gcr%Sgn0lD8tN_IfoL7>UGhYh*}; zDTBu)euPF5-p^xHZ3UY6%ZupHKExdva!tdb>+YR1OI6k30lYzxPYt|sY1*9fI!nX9 z_+v)HGB{#3$HueNP`gT6^&-Js1(E%{o^%)66HBgx*oCbd6TH|mr7pA>@M>ohtw^};dHkj-E0CWS9}0BKHywCN45LxpO0Nznwuu<^C*7YLSHY7;#4d?a)g z^hy?@Hb0_6c%kOUXratUGKz{$I8I24RXioBX{X2)7IxO`DyZgm_Ys!fNf`pA)LyK= zKkfGtYP*)KGR1S#QqlsxI1$p#5ffXsmawOju152bN~#e-6J|s7NQU6eb$O}=4)oNB zD1j=|@5Ejc>HtD-{{wljk|}J(dy4vI@=kkx1RD3nr8t0K?9t6+(mf;f3a8E-T@Bv! zUd7(h@{E|)UV9L!-NKRnbAp=T(18;Y$3sn((v5;U9yMESb-pF7ysw=kIvIZBF&Wh}I(>lcHTljG~(9VOz^oOWTya)Uu9r-XIo zZ_6-%yiN*-*3G@`B8kVA|XCQ$uT%NBWYKq2&*g8ubKCN#0*Wk*}e`_axXt)pzXzCtoz*07q3qx`l zv=&Gbz8mWHFk5uI#O%t#l7tPHs`-;izUYb?26+kq>SzD7aeY_}v*e=` znz+_zoGNVx{32MA0oI=u!ORPs>hcEJ5~%^xnf|04WJ%phXHJNE+Ow_9x|OGbZX#q! zbG=z3Q4~b~B1W?G%aW1YqC(#kBR!?ou3r@NC8~!xS(kU!DPTJpF7m}5md7P^vAyN? zMBI}O`6Qm8KEyIDFR1yYJ<^X>8?U|4t%m}xhO%metCiU6@9)_oRdNb=O+k{zktk@f z58n@r1TYN$RV;Jt;kQ#bQG&DzX$4-ZW!6XbITYi531tlpaS0n(I}^F9Q2#-#gx9$| zjizEW)gS+=n<^8djkW+2FEWrac5IsOOGmgG@ZOA`?N%L>^c4(792p@*jtJHSP+*;sBL7Z+Hq`LO|&s*q{>=}=+$hNYT5$f z(_TmfAKpF&Z8e<3Pk?&_1=p`1d<>`%15&j{&(CU+2hg{~}7_a^L#LC3bQGiNy|^3SB%F zmg@;HXVZ_nB+0E#xljxw}?f%{}pZZ+?Vn|0cR&&A%e;~H%y8`ZyX`&_=l zAn6o0NW!NLj$wAkeyHnn`D6YVfN@b=W=+6nL=Io4fZy@ePCh zE$r%?%CA~e{1%XX`C`)`6K=a{myW1@ZByg&H-Zj~)^YIgUHtxhxq?vLd6xcYxIDk| zN6-N^c4WeyZocf!Ut@gQE_<%L7hhBG=;x9ZaE5@mER&rjx?AO5WVljyi)7C^LuYvV z2LEUd&EY?_ZTA8FBBcrYx*nEiiML#{48xaF!H{kH<$b^WRpY82-+SmArdsGP8#*zP zukBOd4n23PSE~fa?)LUsXOP=zOFMAD#o2HbbU1o^Z?&Z>oNyR;xw*AH?aAQzK>fSu zHx0!2$iLd?=*7c-BgI3v-rCBjE2Yus+(tT>%8wMrA8GM zr_k9{IeWfD1``y2`LAL}0VmsIrv;3k0Wp5FUr|&+(BWHOnXH4mW;YK$J)&<_&=u`g zhORg;&&<5vnwT-Lea?P19r8*&De?fn>R zCfWly1}}e&jrV=wzgUih(KIVqw_o@9iAR-@h`XGt)n298>J#n8ZEP7IB(y=! zTp>qPLesxAin!OFC^XDBb_`GIarT=jClG4#_JFym=Uy@QN()iMmvN_Vvpf4J>`)=@ ztFHFN4&!2u$_RIkcFEz*q47^EcYi5gH`Uj!==9Q>LuHxfoCB0RpiSqhrIO1)w{`pL zDgrv+#RiXtUZAate`DX@**r$MHL6@>jF@`cd`m(`%h5*D=9;4RyCQs^x79HYz^QPifJt?=#Hhbsw&6ubY@++k|cxCt@vJ2eH)^*txF6uZxKN|oL|Y* zS5mEV);^71->MOt=R|Jpd533tloFgD{rTU9QLf60XFPD$l&FyLO7l7F)TYt!Z03uc z9$3%oN5)>ZXv#M)Jx@J=mlFwF383gLS0Rfqt&6i z`3A#VU6Bf&9>obw<#X-DcUCO3h;+$?e4VVKR83z(Ffqh#bFhCx)Qs=t-vHK0h281S zbx0jc*#>X_Ia1lskgK|^;HLvN+T;Xo(^G&Iud48pjt&-+5H|+@z+ngKbG0PWC;l~8 z6-PSK#38PzIjuyd-rq;L^Rf%hy}7NyrB&nzO~K84RmAFx5K=`664Hc;;KGX`<+mI$ zLU73Xm!4M55%+YqNdhGpH22By))1~{`;d=rR=Lp1Oj;t>yc%I&qaU`Pv zXNU&{d3p$PM;y-`KvQyQd$q3HknB_9T=$Ecb@19HRo5!)M^q&ZPLhfHA{jg@We$T%6AcjhAd2c zo)i^(s$DF=fK6~7xZ{}PWQ+-1uYke1$OiMJy z8N`u~XQz`in%*8r*KUO3djuGQjhG^wW3~~{H3PqgcqxK!M%EXp_8&Xnc60+UfgPlFL} zT#nXu?Vm9)KJ^ShULj+l>1l`{sGpixG}n;@*!$0nV%&5ii9O;9mUZ{8b@D2u|8dnD zDIFcFb9@E?IBHBH~ZOyQyh zVduK6p}WE=O(S4A^LmGb5Or0dA0`qtW@-^%&Vu=syq!@h*C;NH|4sYtG1=0(GT!8J zp1|6qf6xI?W96Xglrb!PKf?@KCHCIpr!2c-SR1+#0Q&~ayu=RTuO|>*TupsG6w)|P zEIP$0!!W(pJQOmssM+bMc&oWNi!|&_lHAm;qnN1ScXf8{+6CchrPh}9Ir7zt-*$il zwrB-0Sv3=4|0O#aDj%nBW#Xboe2!rK2UExp!2VB!9klWdc5<6?-Eb1^+_3s!=nUyJ zS+G)9VRrU;=1yV}l!sGP zSXf)c`-6>Oc8;ozZ}c+j_W^JDGW*W=tN|n*^Ecm`*v04L)V=3FRLS*{Ya7k|{PnT> z-nv6>xnuU#qqc;-{E%1or4})OlW)3gw-LMSW(M)P{lh2oZ$Qf*77Lay^VC&v%@rRI z%HZA;A5Z+Y(VVAB>nY`sMZ)TJ5xyD0{+*BRRGL_mf2~$= zY+VyvsuUy_|32`#t`yGu99=d6f{h9R)2f9n3j1t1qRy zv*-^s*3Ns2-X#iN?C@}9&U2pp0*n(HR=f*)n)BZLw?)RCH|$7v>BVaQtm-+RyZAPD zyAzr*Af@94KY5Xy?^F(8%r(>ju*wFOBr4QemRhNQwMpVjHMD$pXN&YPW~UHk z8PC0@j%G=Cy2j<_7Kt!>#JuhZ8s}s%rKq}Uhx6K0mP}74D1OakeGvX`qos=x+n{}p zHMHPmP?q{yQ{I?gV_PDNnZQ9Mv@VR;GcC*FxA|N;43@urDalY$oI|{O$_ls)r2Dnj z#`7X5X)0GkG&Nbl5}{yy(+xb6PD!BCtEL5qHg8~cJ$3YFaJpU4J{jfOHMxyBA*-_d z!50a6#Rt(S6T<7CEq%&L6)BLDXZTYHBB|8OBD-JdA3?B|guxy`Xe*mNOa8D&J1d^` zwZ!d2LGPc#!AL*0cy=QPTRDVJ{rBXrbNUAHLmLbGJLw?`;}@HHjz%%SZ=vi%+39fV zv5Dl0Hymd(8v*$xy|%@-tQmj{UiOh~vYc;ml}mi<%J_*Me(R0vqaC!^-wbaRHsSh)_zfTa6^}29xu()-B_TEiD6m@@DqOd7#s6%^#=Nm z6nh;K@!~hTp7v3krP{@O?5|gqvXJN@(*4q^*~R!ehh8%rcpx3rVD&<~Fv6y{tJhv2 z1p0I6w`pp3+N zfrkUr_nx~bzs6tPNy2!eA9!6%vHU2o)Rf!lGo-SUECRDJ%n{B(PC#D6_rLI%85=ih zIq|J`qo}m$K1M_HNo^|m@7`OqhCOyoaa8Qtl^Gb-sutPywVA{{&7M7V{JN_h&BnSW z!-Yqd?a+IAcyHo^cRTVbvu5FezAP}JyT=P-e&Z4G>l+Vm(mA|i)CO(Myv2ayCicS8 z2F$^f;1>_BB|0!Ai82@xoVX`#55|!7x0IUx)!!LP_c2j9_l;|KaWk`ueV_0C4f>af ztm^e?!_A;=(KnxJ5+JmcI?PHH#Y;Jll)Y61=tOxHzHf=lNZ(sqq{%Yqzg!1iHVAc< zxqVy*K}<;oyxrG9GRiFBb{E$f%gEY@eV>GetzmMdsfSdeO8J%t#mRl9W>}PY{YKP6Y z0s-{P6WhuGPT$R51Z^l4S+}ER))P+DM-{zYW9gs2=1(b_KTqUt>Vpj@LCH zjk`l)E~5WhZ)x}O??FbEpeFk`Xjk?GYE%%laR?YMFemyo`BjfRqK`%u-2ss_GUtW7 zskTj)t?_+vKr($r@6f@Ua|6YPLf{w}FkAa6<3>o%*AB>>ybvq|P9otO9S z&9gEj{J=Bb{@`&*kmHkLVHdmEI87ko(z6xv=U@NCt&n!F>4^FBb*98I1uySWZ3N8> z%zHIkv-hi(1)(#fu1MJEKZ!&s z?_;@jzfV{xQIv9#St-m6mBARO{!@Ca2(k${aYk1mLQ>_d;vOqTS2pKgWjP18ypq}K zXJ6?MgS76Yazg!VVQd{zU}PF;SJ8|^9VH~Dr>n!!*UMHn;HEl1jx(PHXj%p80K|N_&HG3 z63_RMrW0x6$k|OeXUbn}gshNY%NhXN!QE|i#fw80rJm?MXN64sh8w{+Su>55e$XL! zgp%#hD>b#ZEflfXk3!tpU2FI%yyXT^dXG+y5-x&}!+bu(WCa|^crr3eSJU4io~9mto-cOG=_vFA)0oc_Ov0^!XRfz5 z_Onqt)>}6vKVBxPZN0d5o65g7p_*~mU<-(0yFhAIAAj7t*R|Bv2jy z9SC@ajRe`69rMU5AYa|m*R=@X!}QcG8YGU1$c~-L+Zcisfc&|CKdYi=fYw96vQylc z{;pM+GX%?;bf{LI+iPoDl6i+CK%9Abr0R>*TAW!E2Z<^3q3^|MeHA4zf%yUR)*2rQ z{{Gg(7++n8&Klj1((ed4cn>u?R^S7jzLf62lW*<)*t!je`|JC5w6veQNpnbAduKA@ z_kr;9Zg1+;se7A?|K3(uj8OQv*Bm0L>8A5k&>Q}Y(fHx!eKhoScdBx03)7E|p=7lP zB8kWGhrL{vEkr6#DZsRCSSWzm#-J^k|e(QtA(m!Kwu|KsN0;Fzq%xpgOA->KW2 zb-$OF?zl_8wGc>`)Und9hiScw-o5gJ+EuwWU#WT2JjuTT0{+(c?E5I1QVs7PI8g=# zMI($)#@eJc2-18+?87CqiaF;NI72#tV$|oSfkL~4sB$otw3dZJZ(!7#2L^SO5j=5% z!59X5G!y?zEa~dI1bxCrHJu^aB|@zpRaCJvOaUMY1C0K~(dlQg(s_JL7|(M#170A8 zqO{~fEMZH>?wk5l^^3Sq!tzSfn7k>{Q|D9_QyV5elM3S_;+x?QB|8mpE*EPT`H}%e zA79fc*?#WCx71}~KJJ~a>Tl97MuX0@ZL)2jFQFQ~Wv6ho?Ux~Pa7(h)*JODDWD?@7 z{A$sW2l<7ohP59{`+W6_{F54P+b4v6Y7wvUPVw!Y6K(Jnyb6Q1hp!GvTzXMJcKwU{ zkLd?IDIae1=kC|w;k=-}%>NP(NFb{m8^#>vCf!1AuGUA{etWKAr&L#x!2(a^Q5uBV zsXpv_Dr(MFMA;R6xrE!%3RjiJ+klcGuH0JWaO)9+FKX~cXJA#FtC!Rm&QuzAw~n_m zeatg#bThb9XZgW|lcw5&b!qt2=NJ zfJ59g#cFvL3h7k6wPBC_&Pm5dB)9ZZboy~AYd!<$I(bF<*55iX!k552FTWQljbCkL zy`|drMIJsO2S80`Nl3JRaQoTv+e2D1`aa6&ZFcV(PG4Kt>DG-eqy&2XmI}M?Z%lL= zL>(5eM-wZ=T&dTs8jiPfFtcwcUajs*C>K~Y&T>{V+MwSsjeiB126V>AA63#c{yh4~ z+dn^q#>7i5sY$KXi7az#_QZU)hJg8LD1I>#&1jGGAo|cVi6yg4gna#}0XZoyeKEXR z-3I$1PEF%tattrU7?owjMKF!?*XQGwznBrdn3=1bub6ZT<|E{meBftkez#KUWnRM! zm)JK_v6JwEt6cg_7EimWiiYvqF4JFKDfblLT;8D`D?uyj+Ysf3v+1>zEMmu_go~k` zwt9TE+(=DgXfMAI$G1XM6PyU|5zcReVM)K>A9`bKbC%5c6Bs>sIkjAWBBMlqOLB7( z)%zV~Rg@JFS>1<_!UbfA*fJpbft_tYd27dFqb}jn0A&j`ucddxe z9gkM6oHoV{!>fpIV)CcVdlt*f1C_IqT=sfeYLzJnjC}kItgC0ZcndAjyB0d1en%)q zNoT36@i3&(a_xu4apmni5n@`)+O4ycPsxz3;BrO}Q+hDg)*o6{p2fONDj&VU7!+)N z{^XR+c8jA0U2fexZDD(*Iy(-7;=vF?is?9CBSO9?$Bk6PF^tK;N1<&s0ggW^fPP-Q@GQ>7P=&z?>}-`TC+>n{;#d08 zfd~t`7mU@{bqrZcz&rIOxyMM?(qq|1vp;5PL;gs{Ar`2IC}Tk0QwhkOC^$u0JIkoD`Sw>xc*2c+ z^YRt?RWCkxDZq8*7e>q|Y(tJbp75iS!W`I`JnZzwDf2O(2a!U}*gz>HjUrK47*wDf z$8;5x%GND(EdVd4AfOCFCYi*|oTURCqPhbd@O~*74Bid5uP7k$-u1jN`wD@MK;I82QzrBuUeXdw~7@0{@Mbq&b0nKryOe}B(z7MGj|J3 zjr@B}>sL`skXi^8@Mc_`{Rfom4*(>W!-4e}0GWx_sYI!{S4rC~)G{X7Q zp@{m&Jay-(&!%f|>AMos8JpQ+sReSjnxg-)+`18!$igB{4UeqmXDE-Z595%-^jf2( zP5&Fq5s4f>^>qCkZ9e}(&gr!D1-R(Zl!QQCsN!t&NAklx$1u-p`*i@U6j?qmwEK=Q z=@}sVX3)P)!C~mYBjmvuQ6xz0B{FHut1Xj;4StCj4&QCzjTq|O70yn0-iaK}!@iS@ zWH-~z#m2-FAYQkU!7yCCt}9tbL;V2JoD1i1*FZ1Ifju2q!$J_s(y37z&cv5GCEyKV!8lH<(E9N!2M{z} z7IaTk>>`NpQ$T%?pLi6KwZ&@$it>Lgn403#P>3fXaw%8%B*=}ygdyQQK***B#Mdgk z{BrqSAYj+$n248iZd(*HtvlNN$!`vS@m|28(MM2v?ef+IlU~t7^a8W=y1H6$&^ZVr zewMF^Y$<~5cCqILDPSM1t?=7=7U(`okp3ONCkCUJx%lIiSAi(pt^cs8x<^6(m2H80 zt}%{_G>XO7nc)s`a2ce{Af&EOVK)q9TQ2jFEYw9{|3l7c8yATT?i3AYL3MB@B1Xsc znk%P*^nkJA#@E_bQ(UGnH@>_S*q_tl9+SczCA)JaEn~vY()KRja#iKm%XpMKaP*M*$^28V-7 zM29>Z=lAgm#i%P+QIfHb45(87XGbLX!@~_=Z9YB!R=U-RLRz!dyLl)fuVUG z-QQpb3lO2bP`bl{x*eATTZtb?+iGU(1}1 z$%+pNLG;5~rLyQs5(?KvmJ4q;e*}tCA-%k*`NqG>)A+-)EgKQ{S!UG1EX@KA21j9# zZLYDVS2oO(psQ*S@%uvmZi7uL^mYpp|ITnSp~FSYdnbpVqW;(Mny)^23e8UlPkUBg zSN2e&5-wT~2c*4n6^vGS17h@SJn3W@A-qM)!>feakRQGtup5kIK8WBH2(FIpU;Vah zcJ`Qtua_OkqAh8@FE5sm}i zQWV>NTtKo6lujR$U?YTH!&R21qdRL=^h^3^zNlxpRvBlIW4~PDMQIga(b$kISc$?A1@l!MBlOwYJa*7SKx}QfTIko`ASrmnqFGTra3(aM_J6ZK;+Bq zGB!TX|7;PHxLBorLklW1jg?0i^zqkc99-gmPM4p-3snC)TI#7)l;Z36ea~P=hm+%kd&F#OczEM?UeFfcf6wq@@INLC$wMw0`2#B_?rSBR-3&9#fZ1*AD?j_CFv+kEp561nXY|VkKd)H6XrLN( z+@Yy|Mlm`%VflDrye8;ZF+?C(i30rV!=KVp83pf@cXnOZJP^<1HP$Rtz{zAtoHf@{ zvdkFU#ahfZheRazfG!iyBL4(`W9R2chz2JdQTOuY%eK>|XM zj-<@(&0Jia&5i9)-_IOOY*4w$SjqlV3J8#~Xm~lAld-56TmIM4+1%chjQzb@jf_Rn z+|1fo%)ygPkM&)^&Bo5m%1Xw=_n*Rmj78kR-u1n)3mMygYTuiynY%c+Ih&fhko{*^ z6=w%ib#qrTJr)%SDFZSgq5tgvLp>YY|Ds>P+}_gFij0esj77@Y*45nky|guUHJ30q zbucr3@AN+|-7}X#gH?kSM$7=q+}^sx@@HXU?nm4^xE)4BaV%0%+|m%d9KzrQ(KP&0 z`Vu+>XIL0gbBu}qW9mHri|YUXQ~%FI{y$CK)7jhtm6eQ*9hLQeZe-kCTpV0v7G(cZ z#>PeVU$tcR|F4Xj^Z$^salV`WKimIo$Hm6W$?@N1Y;0`oT)h9AjFXF<`+w8H#>vIS z_U;(}Z9G<1Hr{uO{WlpG8y`2{f0w=M;Nbn=uJ3(34!(C!`hWVmIvZQtnmhlOB` po4?!O-DeyeT*>}#BMJ$jy0{uUyZ)Dj-aB)1a-dRCNh(XB{$Hs?J<$LF literal 0 HcmV?d00001 diff --git a/docs/backpack/diagrams.xoj b/docs/backpack/diagrams.xoj new file mode 100644 index 0000000000000000000000000000000000000000..acec8d02de7f56a77b86d5b381d4d0ca08289387 GIT binary patch literal 118800 zcmV)BK*PTuiwFP!000001Ejsn&UDL>o;TN3{NUW1E60v=6C1Dr!&6GV-A#y1 zHrQ-Sn)upX@jh>4)iy|ATQ&L+-&&O`50P;`{M~=}umAjqAOH8yfBx6s|LKo^|C{pD z^P3<4`j_AR@gIKohd=%C=fD5WAOG~5|M2hs-QWG!KmFUE|M3{p*|L6bp zfBDVp*FnHPj#f;m2S8 z+rPYK`>%ic!|(s$H$VQwl8{x3hra{k*NUeEsJ55N2UAAj@Xx3Ay* z;dlS-=Rd#x{_9`<{HOo?^N+v$=}&)nJ^%TS_m}_i53iAblM|>v)%p5dJL{*tf7IH3 z8tq3r`=`DYQwJoS_K@ZQK=LOB5R((Ow zPiqTmMbM1z4QBRwHUxE^o%mk==`6+^g8F)Yuk(faQwgZ?g~}+6QM|tPQ;BDtS+|%{ zKw4kr3*)EZXEEkv4J|%f>xwN1XdFSBb!T68&P>lXGaK>qfV76mn}<;*JLqTY7r)#2 zyIKXE^8VgocRiQGYCX>rgLw`8d491zKkJ!toHwRGT3&R-l z@%5H7^A}z}h_7qUM*JWk{cgs&2Xt8b>p1#Tc=IspqVKg5^9<;9jJ4JHLO`)+t;Y{8 zG-4@w^EH>Y@>!2(o4E-2YCEyJn#=18{o$mKcDEPy`sfC{pur93JX`gi(F>ZKU(Bo< z%Lk)8yg3-<0nfnJ*Vm0pf#t86Y3GHQF>9SWIM{?50cq_*n}7FrzvZI;|Gx44Y1-`< z0jjavP2YGy<9R_~Z>j8I*Nrc)Np+ytDvDkSDDG+*3B~@F8LtEsJ6aa|%N;0MZ$R_p z{SWAUJ1?ZcE;M3-_jij~-+T2-$g>_(_*3Q^(*E8z7kK9}XB<{Qx&tCR0qOqt*!%vB z_)uWBzA$35ObG+p&^OJ~G^{YQ$(RrLYD)OTD**}XALhBaSB4I>_6dXwNc8m4T*?Dg z7D@-C6;*B2MD<$2$|0BUlAoL2o{J60c1U$h++~%e;I4 zLev*>1ioswp|8a&+}xI<8}Wi-g@M^a&~x6<64i{~6+wk(aU;s*dJmAfUQostq!R>x zUf0Wv!Cp!ZY)-!0gu-^yXwmOS6uX2U>8GTpzbZU$~qm z?oKrpit%f&%Nr{2W4{SqPN=fi!ma;)tY~Y;6zl7Py)KHN7giLgc0g0q=(Vwez=LjR zYrU_nOsGNM13IFx6R1B>`wbKnea0SsGjDEvU$J3rH_bbsm$b0=Pip}oNtD;z`cB?D zAD}Io^AthBF<&&GH=wE0j{SZ?)%Rrry>RBW?74tmC;DQearQ5$z3%dh=?uQmzFA?6 z(^z59`+yo8bX_QT^aQG+5M=D{c@v^XSxEWmR#%hTnhCF5_dp1Zar(NU!q@#~0Yhp^HnC^T8wmq$=Jk;J zoQp+pLsbiF_38-cbDoDctt0sB1zuE`X9pQHN@FK>u3@ot59^EFeQj3bO-a;Du(kYw z)QE;2&~wZOYNYQm>jvv=AkhobJfD=rpLuUUGpj~NXanroY>(M75?|~0_>UlCmWFOA z=H`^9AkD1uX3y(85#W3c&o|UBrlFf_bwq-0KyjfO2VxPUfqpN38p75KiWORTl752XPnKdMyebD;X7px&Y?fvzYBI4kgX10#eM5v!f9G zVJ-+|9=#%@F|7e=6TVpQ^eP_Fqd9ZbSnnG;K#h6FF~1<& z5Mxbqrg-5|Oo3wA(-@0jJ!dkA*h)j@Uo#Xv2E1C+O+Dik-=zr=t{4{PPI*$R-6UoQ{a(nrfj|Hg?ugv zA?z#`WBTVYW4)d4VU>+nJQoZ23%R>J?Al0N{!Uw2rX614N_(8nekY}le=e&H2rcU* z-PTM&B#*MM-T46RYx}6Xq~IQhw<{R5^v@UMJE7kh*Os?zHQtezdLbV8q%89F{xwlNKXk&`J6m6k(mD@G*(C)7}|$W$kN;UEi$m z)RZ3rqfP;%_~$99yTzwYNlTaC?AGg!AniVfcdqR&e(=(wt+(pbPD&a&`<*+Z)81+2 z3j(uON^3z&_DT+;9W`}iWA{vHBBu0$p0_shhVsq3YZ~Q^mD_fwZpwq<7{Bo z>GunJrl$J(=NC87_T&c{B%qCdr@=g+IAx&TStr^UPoe&s-}S256n+=>ub0BpQ41|f ze@FcbM7j4wq_N-7OD1_P^g7sG-_UE{+J!<78gFQ!esvjk2PTh%7WQ4BS+%Bwu-+RA z`JtmaJn*G?p$#G>1o1W$e&X_mwyd2%?E&w*IPVwsRwU)eZyxCo2W#s_gE_nz7yhMPod;-1f7`a;KGN0Was-4;Ve{r0h&U4n z!W)x#-L2knh1m2HU;aaiJu52#c0=EjBcn7i`IL08|XaR*UsBVHa% zz8lVTEZLZ~pdaV&FrIER8kprSi7JO@1!yrdF&dPWkn(^m4~m?xlm|t!(askt&q3#2 z=q#S+LZ3O7aThy*rFrQ?u@jb*J6FT!;N5-8+p+VT6APEr0~ubJ{-2f5tbz`*_=$7C zkb*4S9+ZyPJasYArdUHOu$?7-BdBR7BB0|rd49qWRP9aR!gKN*!Ugsqd?0VO=gPY} zccIi5*t-X-$H%Y-7>XRX#rCwLOHhYM1v&(@w4;)@2Q%&YOpv+eV4r3}xxeTA1&H|` zoYKm#8xp<_$mbm;f}x&~-_u?YD6uD4Q5jRjEY_gk$#NL$(`~_Wm^T9d;n}R#VvBDC z$9fPB4%h4KltTRG?pI1aI1o-v3>8XOW^D=V5`A6L3T_b^MKn{auY5rBLvBnAeM6SO z9x$f;0zEee-#Na!mgE+=HS(E$$5|iW zENp2+TE&{Y=@Am-8+lAMG54R7>(yZq%=4gr5F@3%Xb?!o6iO2W1WpE|-^l>eh(wBc z4j@sS&g2Q0ds=RYu~2AR@+NtEbR#b5)<2(obAUhRSMu_|dP*@x(P=T&n7*j5FA8$x znTb|Dx{nJ+*k8jDYHI(@Y!;t-F6y55W*QO)yKk19>4EbZA@)ul+3di5IwxaX8~MyX z7(820@y?h!wVkWihcxJ4we->mw9>_W1U+2wxNGGk&5gmzxhssF*(n1BCX}6{1Su+}EE>9%1+o-< z9p{;)tX2r{dt{~zNKyfKSZ4CRVW=e~)0-ff#+-Q>CtuJBBGDI+<5{d>gQ_c6WD2M^ z&nHq>OB2MC5-!zRSr3uO2(5h({48wuIQ1MouW}Y;0>6hbz1|PN%1u6nM_D$hG2cf!x}+f zaqAAyhCRk*x8d__X1!BR*37UR=1n?zE`h!EBuml`9w?>v>?FO__YS)&YgubglFwLX zyI2^ECg$+kTG;acTXNR^-=5u4to2 zYRqvZjUuRVBRi03e=McVly^1Hw-6IwFok?nx!lv z%G*h)&XD<+zIRf<&>A4!ref_}w%r76p2gSullL)x*G+La;$HIW@k%eulN^U$Q|5@Z z_nP9Ip0yMaW6!#ci-+&wV@4}z_9_!bAJE>HWAu@`6iC#q*&x>Uk@M8dMq-cOG#`ky z_j%>bBd8!b=nIgYM@%dr(T4M##i9*!U2gJ#ct0TOs7bfti=!rQi|G$b5?qtf;89Sx z(Go*rONOZ?#CpIQpT_TcYHKlxF_KEhKgal#num2$c<{Kp-S+!;PkzBXqTTOVhSprH zku}Y8T?;}$wO(0a)cXu5e|Oj=?nm7JQ4+VbFK;f`1eJ4XNWYjnI%D_pJ81QvOXF-$!qV4KZ3@6a|#+*CBCD?W2cB8QyhyG z%61gcdds?F@kMU=SSh*0EguVv=?P8nC&z+ScZdpj-8ZW=ehGdb%H0)Q*$9_ z#xmo?AYiPRIG~PVq}sevY3%4Msq8hLnP0}3vtGK~1=-3JI618YjC^M5SN9u2^_ey0 z!kBeJO6|I%ps7yl2m4ps_5b>rP45g8eG>C>P$?W2a8N1cNvD%$b5QKL<@u~9)cVyi zbIg@vT6&M|nj5(S&NCr()@0^RS`kN{5QHG#ghb9OBWr(8Qc=&dW4H4fd?#XN%hps_ z)q2t{5TmSXn^Tl}NehA^*nI~*N=-{kV9dJbGI-WGGmS!$78b>}tf_Go7Gl=}V_p@S zCaL0^)9suR-=8DpMC}t9ZU<>>PUJ*CTM5U{{HeOJ6O(s%3}3vdW2i6i@P+|g-0w+ae4I>3rw@knM>6%n zh~H-FFEY(nw7zmp`k~eCYhn+yvPmDCP~!{pZD@T#3nB5rP`|kT2b2EBr@xuYCeC9r z7roNL-6`nkPGk@VF=Le=4&P-v-oK+43yUMyA-p1OGupn@uFGAtLD!kpiv$|K}o^?W>m6g4%8(^MVdb3_m8*j>jgD- zbr$mG8)nNc=z);L!JnQ+q3?VMWa^7iaaIi|5PjQ7^N3|-T;Xgsol0#ZmBR**fiV1d3q zZt(U2Y6`0ID9T#F7y`FcuFVE=mJGkEH#Mojog)g$Uw_&g>fdGAIvXwbkO1F+23dh2 z8SY6wk1x*3Y{Cu!^zZ7vB(EVSW(Xa2iBmK0P-Q_{1{=q2pOK;Kanl_sV(W1h!#Jek zKlyCA=mU_F?{DJztb!Cec_@3(@|hCz<)`=#4^?cSW}u@A3e=A@pN@6jc-XP71|Is^ zAPie266!BXWz?G%!kQMjlq$4PGbA!0LLz75cT-q7fCgEDT5rt&$@89dYwS$DId%Qc zx^>Dt5UYWe+t4?-wr)unvao~~&N5q+Qz2%kVYYHCMO#^zM6+30QpCU0-WS3yN%Vaj z*ttLVH=j8rkVJOl1z*rJMj5~Oogk07*zNL*QHacGnAZ;Ol6FhGxD-h_w>VD2j)%`Y z;?d0Zl)r@0{6HVF6bbR99s7;hbw|TLIN&?xe1D<4M9a<$DeXL>1UXS1Ted77`JhrU=R|a!DGJ4hJSX7h4&Hfq0@!8SEwT^&7myLgRq#f#Y*i0&8H1+dK2v;^a4G&f#)S+@67*88$X=lzT|jgwT=nTVz;vG)_V%OMNEwsg~jshl%WjxNX)N27Gkv;XP{%DvIiQA6?KzT)F5c{>uuG7Obv{TPm{Yt4{)!M1c zx|CzRu@r1Fsu#BFP2%Rl>9ZXNZU}q$8mX@gekZPPEJSm3D%8ULW(j2Bu|McX`E1`e z-#mGZSai8Z**PERG|767X2+{4sNY++pX4^q9C*;{ zoVV~GkvNaQc-Vgd&98L6ZJp>zi-wCHDpP`zYXti`V!daS_{cRK4AU;FI59b?kv$c$WW3=&pEFyJ4jB>#))S+711Yo&0e<*Cz)$) zUrgUKIggwUGmVCZ9*lin?UNm#M;jh#UM+YK26 z`D?et5n)sRkTdkX`No)$^6i)z^DjxJXD(h!Ipm6VqJjdN?P@*bm?nkYJ8ca*zmw9K z4Ys|fr1njQ?aC8$D78=UnHgAp&9^gU9;N2YdlCd>Tau6)cBDLHDD|o)U*Sh7)6+jC zkmDk<^D}qgP%*>V3D)ONMPI?EN+xhSjtiaLZXrcCyh&*-?^>?$=jx;lW;K!LOc9=hUdrPJ6{iR)H~_ z)T6uu$G5X*`jmJ^%in2Cr(ID%?l_DYscrk~;KaUR5e=Gs$b~SKu6T!Jr93%`zUKfH zJV2+U8(sQs&0L6HuI_S(oJd?csj-iDfRne!0doF^R~=degS=#RZ1PmyBBBy+aV0du$u@XyYx36FAByrCrP=ivwgjl z7`II%AO$D_8bn$PM+u*G#PseNO}#0Qw{hn6mG<#gZ3CYf>nvTGK^Q@ou{cKNKeHHoqq$DU8+jBKO;^AG2yY2U$VF;pP zpe%Yo{R3Jl7dj-sxroYXoRWy0-u5_D324rsya7E$Npq%5Y`^_kL;qTH`6mJ#qr#q3&oFrbrdrNk^~ zruAQMj+EgP({EjLW)y$U<(;K)oC`qiiX-Y;OG|^D$G$sz=QC?n&V1+@@89!u9mQpf z-rhO0Ji#{eJaw-Y_lo?Kw$lPrPVQNb(yxv3JO0%PAw`D`=)sn&SbgNu&9V9!-pC6P zaM@h|9}3qiH`4J>HNBC~$1}J$P~N44AXo|Ex=5(~>X@Uyxn39U-#6nRDM`O)uf6DL zOID0{Pc71!18y)7*wshsRgLU`Y6}#31bbhKM~yps3KZpY{fMpa)Sa}W`x6toHKH%= z7cq{#JIdO)J{z6P_1S1I-fbBgQ5T%(17v%q&S|DLT3NmIm4|(@E)#dM_uStKWb5X1 zw#T_Q?d@kPzcM=KudjF19SKn}Zx6+czH~`J27ARgm#XQHTpZRmdP& z>02M?4RNLOcP-=k{pR-X%H{N9CI9xA<{QfIn4g-*m|!f%tugbS4WK;T`Q8Z#{TPV{ zieq)i6T;o-*+9Y>B)*XkaX}uX5F=+VpYk+rBbLKynu2n?Zg5{Rs8adzPJO^)Cu8rj;RVUx#9evX9bjc616nlKIv*^u|7Pf~Rjt9L? z`2bJ)`Qw%Oq#Rd?wzUP}Ir+?XeE-h&A!muCmN&0`e3G?MYTBv-@^0(RdxC+ev%|4D z-FfXEhsb@$bZE6Bxw1wXDgWu&OrP-~#@}lwJhKd|eVN%t$iK4}X!ARJI2Fr1(`K;w zU4iz-6`IyoFfzV>r+wi7-Wdi1FSxQh?#(r1Tak8tW$cG@5scaW1M2y8mvuL!-Mur@ zog*A&y7>t=eh%Iw1a#V_k5oQ8&yct#mSgI-2nQz+ShqjkwC|N0pI+LX__Fz4`M@R3 z?3-J5qf`dDEw7%V_jf%<>BxJrqpPLnKgcvW=<`~wBTri9=Lkc& zfs2L_Z^#w{ef>$z-+3J;`kS7nuQAeqbw|UStEfPXS z1nSNZPKbEleNr>tJI$}AKVPhVpVVa>km5EIh8&XaWy|BY(k)krh83eM8Re;GHDhYM zC9~hNtc=LnF;&2@iVEg zo@>UiE}SNMKKsFLeP%Y4SVBKLtx6Wq=G!K6X0{8n8fYu5h2g~enIt3c#Hoqt-re2b zZMBI-x~rB^ z#T~x1_cg-=9P?yoa?d1?&KyO{p7(q7%Btf%vvsL9EY|YfxSg{kiyGMUcawRj) z0yR7^W831!Ovu#m19JbZa$~GIC9ZlpD0XTKX7{FJLV%s;X~AHC;Cf}J)vg0Meoq8* zB~=;hgkv=|rF9!F?)NU)328s9Rh^lZss@zyAi_1wCHn1Wc1IcMYd!snL1$+VIPd2! zZ+tl!`04#Lp*!Wh6ZLw|4AtZyR?uw2v(fLqa#7JDnQeyINzS$ecWB!w>GtQwPM@Bb zWe=abuv!0!olhRs5|=*Dw&xA};+B<`v^TJ~w2Yxpr>-VO{eCu{^xOqx1{AwS8$OYY zDaf=i7E@Z1XLnx9NU#G`F8M0&_ML|MJ;8F%Or7Og#yBdCo+FsV_qA8x}vR&w~9Z-C-{8l4OF*0du2ME^dRMd zR_|vIUH0Zl3C|tz8U^?6NqF^_YHGc>u<$I!UYJhSovUwlVi(7H)a)ha-+i~j`XsZ8 z%i#)2cyoGvvH_(#;_Z?WP_K9Om40q+rK*l%HLXa29`81*>eY8GOzO_pGO}8~>nT;K zV_Z+WQJ_xk*-}$u_N3^AXKs+HK7J$Fw$?CGga~A*H|i$NEPWVs*`vpkd3ndfXup1^ z?vir`G&4t#Fi&#=uP-I&Bgook+(B9|-ML&_P43xFQOEu9EP?b|GFBia@0w-i3)vVK zc9bXPF`r+2@5!AI7T);8hyI4MUdmi~4p9wK!xeDnFtZh~sH8v_{l+McvfYIjcxFuMOI zWe4w>Eok2PcH=KQ%`of%^GPR`ra_{bEzTp~ zw9Q^`-e_>`y_K>~hsJr8IXW%+nV_95ivyS2P71D3ZvKMy-gz@n@Mir43ho+P6lD#l zUJG|X?fSC)EOD|w8TIo3ITmX(rcb{2{9cNZ?PTtVNAa6+f^TU2;+Zh*q%A{xcJg$! zO9$cj$uG1k8TNKk0`Z>tKI+XI@Nv>z6r%*o=-{id(|Mz_W)`ptn5#;lKcm4JLBV)}i4 zWRmqh(+?@g{vgDOK5`VTzGtS2u)e4DGES-Y^y(L&2V1yi-P2mCd)03gB~V)1A3^Ek zZ~A&-A<()x37t-ADfRc8X`p%D_USsom6X`K>nKXy&Yh~AzP>YNBQ8|miFf+KPM&{y zod7&5(ii%*b!Y!NPP)39 zIplcqUdJk2+YR4*Kp!&PxRRjWtREiIPW3ox-mjUCmV7n{LHcgl^wBeOHuiAz)a_$` zhcyr`v}@iS!kfoPi6i!DjGH~x1SM}d?`QCqF*3KvqdYg7zq=aWK@xO@II_F%JfS~t z|8r3Hac%FKr~LpPvwoV~M#-BLxa?|!whWDOb4S^0TW&SxlUhX}PG*E|e)oJtKIl!y z>-+rP7J^YyE1rCB-W<1{d5}2dM$I_!a`OC~d(){JXb)*0H*?ldn&uw%`b|;CNV|sS za%~>*p)o(Ap#yT}&#$eL@i%+4$ms9J=Ti+r2&)(57~}(FjgHzSJssHn{%_`?xu8YzoCiBU9v%5f4|w>2py=SpCmLT8I&_zQWTN|uA%`whuOmQb;g#*kaP1JM*y(7sW4hG;l= zp_RstfI8Tm5Tcx+fpNE}$G2iD>V>9F7=~7wQ^vZUq=Z(UpFAry&ri_G^Rtnpzu&}l zXy}@jO5k1C`h0!^yO_^!U{&$?4RrGPev`JFg3x1peuK{BKEHr^&GQ>QC60tf&GQqq z?)kkwWX~?p7re$fw*_axRFN1rAs1wea~0%F))!6&)Sct@2x`P;mkm^O%YSVZvcEYu zm0v^cj3}D{RG^NXVmb>>Z>VZdRrqg5g{Ro>gwPEO6lfovQ$k&5SeSPZo2aq=2(nEy zAspi>5vWpO>6BZWgomY4Xp3Tg;Sw}Nc@veO+EG(4>$)vsJJ!0;gI{|Hieg+5Q(%b5 zk|?URs30}gh3c)48;xm}?%BioVhf_?Fwo=s$!g>0ad!N*hJ1?j}500Ry zO&7Fc15rHHkjhvU-1jQ?RULp4O>*dmrebm{YPBf?3}}#j7oQD?Zj^`ZQRZVwsFS69 z8c-DtHPn{qtI92@R$0(qL#k%skbtEcMV*pLYh@*zga*CBSZ$%EilJv_BT+%-N&(I9 zus%9XsUb2Mv2g5)I3AFiHIt(~=n>V)$a+KSP-SRl|6LVDAfGxR_y48OH7bmteVZ)1 zZ!bZR>VZX}1=VmMRl8GWbu zmcl(04X#w=t;01q+ydFPJ9aM2J%lIIowuSwwi$L0VYeBc^lccl<(|szt}ewp-CCCl zLDMaAAKoNEZ+Y5Wn5YXUDf5kjcN0k2XipM_POqaz zOWs3KV5KA9d_E;{-yV`m;%=FR*eK`dd_E;ryWPm$x_Po-uoAq1oQ&;OV%e~3XP%tP zH&z#9Su|`sD_f>I%W~7A%UN@7uKLm7X`L*RTY%Q>HROg}HB)z=EMePACQ3UiP^r;7 z^9P;ctOgBLkbkFS=#ph|T`V&54ry%rYwNrJ>CeCW<3IlV*9yG9zE!G&ZY5V1dpL%^ z9FRgybnZ6K@iL*Jb!G&THw?c}sJX1HDpg*X}ZM1f;NjMZy=`Q@f&o1KONetf;v; zf6%cmZHxIuf++<4BC~jUu40Un48mi*QJRNNG)%=~1 z%XR3v)=pxa1r(*{z$|%{mZN;Tpo}I5Qk3?SYgZnDuP$MK17uEUgA?vxv6;)0*%kw+ z?abN8uVe8ju62sUSa88L`+c;_RD@xm$ zTcV4+GlOIBOt>UuD0Wbd!}p9K4}@c9)o_s*%>TLbD?1)^Aa_bQ%xn-zuTkc&t{VO~ zE-OWNihEm4Hlq@hN)Ucf^hFv&hoY;^fHD9JP0$01iPw_B`+>}kIhY)bui2b@VdgVk zGbbm^M3M(+LZ@B4-$>aA$v^#4ZAwO6^j&OQ&Cq($Ms#BeNEI?`12O`=i~g796-iDH zNWsFFgE+Wc)E-1%B~jF&*gBXe!?gY8SsBn>@C&O{Z_&((gOgc<-h?9?VON7V^!%M> zjh%ZnW<9dSLUJBvW?tj4cZ~_pUr!>Jn?@`+&mk1Mz?DScHaufwKzD%;X+Iag>$%s1 zS&RH2so-b-21OBUMSW4#HwaWwz{Mp-s__TNX5j}eF)+0RbFH|Z*5*xk1~rCCmf?N4 z5-?CS5d1VJY$=;Ap}qew`8EkU@kig=zh?~JrFZW7SNq<)ZSdW z*0PxIIG4UB1nu{j@AADC2|S9#jF#mP3ZtkfZUwvKElXalX1XiyNs^KVE8=4ANS}V!H1p3%Bl%y2t zmWczwU&{zfm&s*h9@pf>#hUH?^_eC_{SHBU`zkr8yd($F4%QUu1{l(Kv$DGuAs44v z>izm2oWm^>-H{F&q40+l*#@Xx`t|Wef8&}_O(dwj1H30tq0-1fwlBoLOJ6uyr$R!N zvquUP-NtY!S0U*u{=(W=PqVqNwd+k(u7qQ-N4vrUQQjqMEL^G8{<`PfjUpy6HnC9k zL`N}h82lsX*Oqbn8yi)%L&ag=)Hf~>g8EQHfsJ~owqOZUmD6D&anEbkoe&vc*^#7l zup0rV;0pg{suaa8&KHi2VAz6&wh9pX;c7tEDEM7{3sZe&`>4(DsyRQut8kU=--YcG zBo654njC(YIUD@08Nc{lBktkwyGH!WEQGHJ!e|C0+H%cCS5|&ID*W zo8eEw;0Mp73ye5ZMXn=0b=?24;Nqf9sCwmzC3aeD76QY+nm9tK!wHBWErcN`eq;(7 z+~L=k1Ijw>kDv{cdzPR>`co_;)`lb$6L(d9jEn)bb_MyzO*2%7KcGPZeR~8&Cxx&o zEI}#`p&JoUSmseVi~SyixD^_}ev^n^vPz%R%gei-A7zJav~ohS3|cc&kOQhCQ#)I4p?!iKoqz;9;7Qm3WcR4PRYW1f46QQB8ELt7?sR`(^F zh5EZY6d7^d63(ntTM!Loh@L47*eHGwOd3XUi8r_IsTh8_^-FQd zX+IGncEk2h>Nf@d1R=1^lNC~f#Tyc>TxoXCx>wXv&9u6n#(U>x$goesq0Rix)X?vG zR&=sIVUf3?xwNbjRc5*s0@BxOMxogqk(Ddv57%VQ3VpL=a#Pe!x`dw znyw`Mt~`)6u5Df(H*V4H7DpA!SF|#9&iuWc>#*D0tw^;xieC=K7;K^!%(+DY6ZF9U#(eLr#a``(Yj78vuPxu+p|zL zQl8H@d&&NSt)vlFV{RE*v!gOBW`2w^fAOZfY8pB@rVXa(}mX{sp5;lcRTfHsU#{R&A^z){;sdb71JptK7vdNxlC+Ac4uVxkQ)fQc8wcA56Z6)C(z762$9UYYeL{2xa0P@wKO?7 ziFaWdiN-(;Rmk$(eBaj5vQEgx{UNNkLAmGMJtbWuc_UqvXYMR-v#((;8$cV=#_d6C zCyGsYmJ!u!_4%&-g#D9J_O^~dYhp+H$zH4WYkt&I8BbPT5&o1k8oIIb+G#?}=G$}M zR@FAiKJPtr^JX^P^(h=Qyq=VT$NOFn*WYm2Aq#eJOqYgQPnz~WYF>NyNuZmSS(or8pOZqgIRCOk^f!Gn;nsZh%dqXMX@TE>yJ>>u*l-q~542AJ*! zArwQWvRXNNb~SnZnO1Fd+Vkp-aeh|ggcP)nu@*Po%0lBzhfc{dIozVGQqm@p_v1ym_A$xbIZ|8lREjzEoYq~4n zw78J#e7duO@W7kAh44O$t+>l^n}W=f%x+6)G_%_h_lIK(i;p>*8;e+KfNCbBMhwkN zRRc&Y8IEd`8E3c|t^|*9n`lhU+C4O432s9o0i2?00mL4;VaW1r*4)GZeYL4Ajt@V8 zB2F=Bg29!Oom0Bv?AbmdxEKeslcH^2E25l@7S&KE_s$M3=FSnalsF)jWh1(%FNW5m zeS_BdiS#^^H(HgOTyHR_W~3m?t~L9lATimD>-g3Ecn|!9J*f0usbbzX1UKq_i** zPL;|_lrd}=3~k9I=Xz3T0K-K-Y5u5w(@mOXQ$PlwILRYX+*LYpClUS?K-<1c0r4`T};Wbl^8w--8MzqIwj37HgXbY0j-*pK*cgBB6^Z(zTH^<}Z>=UB!&m`yI{ zY*d{jMm~VjOe+(hJYx|Hux8ExF0x9YN^7PMay_=5N5P{+#W(6;y1CpVt$OY+i{F)Q z5~ZFTijT3ay>#>GIRDZu+*LmrKU}`m1E8&zZe30pGeWIF4aOoZ!p8D4%+WM}6QiP$oa%`8`fR5N9~uwX+0vBw z?H;}~HgIx0fkcD&H==j#K=5nx_Oh>eXInRsn=`-T^TSDQD>y;u-XlLD9GUnpo4}dd zTsebYlE}4gfqu4Zmhc8_mFNOO-^I$+P;oJUwP}q`_F)CcBG?F!X!V_gfFAYp$yO*x z(E6I#sQaQ))CY08kqbL8wi6eJ=|>x;0ko>_(XvxS%Ujm2mF#FCNa~7~(W(HxF`Yi9 z)^lba1OdTLOBgpt;b~ST-+*7cnn|PkwhfIP1qK^rPg_~<|)J$~P;&K{5RB}3XVwfoh@wvbnnWSQ0wnu}i z^kIQtR%JfgGnJ+5UidrEHGc<5z|ACfw+f}jO`H4N1_6~L_JAcUnp0Sz9=UJ%n`*0) z_O00PlJ3gXZR1F0yVF54@kAdRpC=h#v)M-wdISQxkmM7Vy>oXk{VZ~Wc1a50?VWk_T>9^5Zr5GF|84KnKs5Ff;-k9~ zGE8P|)kT~pD|9&U11k^VmjQ@G*fj{thQQ zo(tf=@oOVzFr??~p6)C{-aP|{rSv@J_Ep;fd_VSujbSGB_KWnBZjp!}*clrX#S5H| zLkz@qcCY>MqBro#_Nxn9O@t9I0kr&Vnoc3pzw4v+ z+)qvCp_a(fM}rI(rPc>fsVeY#(p52lq(Gt?Lq>Sr!T<y+ts3N6}p5#CA8qxR3%`$ZsO8R0$1J(ByX!DL-yf zMg*!4c;XUADWhcKOe7T&2zw!FXAvb?Y+&*{-L1)APnW!yd$HS{#@)qYEg`za@qe_{ zE;bfnEiRV+F(enNE;Q`8#d_5yO8{3|qeXME47;VLmFXlG5_P6qAxL#C=K8e5F4o8} z-WQuUHi=01xZInx%-iKNvJ&RXTnc?*Wm$dw&e4vf%49DS5;)hbj2z!vF2_%@(JHqF z=4+Q$&7NU#4(nFhj)3)rfO^QPTkn2+@#gsGe_Yo5=+aSKM~2FMW!+A~dUmpEe4O8Y zGM+Nh9Ppty*0Ssy2^nACw@E^*eUID0=XHL2W{tlHy2mLZD1NuI?sg<$?UR*}17EUR z0qI)j_6QMFe*raWpBd^|V>r&}jO@f^$Q3vR&D&$)HS6>4($xjc+c}|Rfqzng&d!+y zwz~W*T}aBgYl!nZx8i5eC`yQbK-p&($Zv)Zg$?`A-Tl2Ykk!Y1 ztMG`p{55s%%DI(wANJQhKXqn1Yeok($TQRBF0SH5T}H2{W799k-PpNhF3aikj%@!y z0?BEd^#l)Uwm#5VQ)%t-UYBe^5p?5xd!7Wp7S{@eIRxZ}h~^loai9wpT%iFeDTbP{ zlvN9^P=I1*tOQVaw4h@NYJyy`A}9{gJ6WT`T>?9KyzUl9Tf>3?tZE34IEIu``Ll~d z-!Lu|*LtKzQSy&I_})zYRnKTOiism2H`^44+Sx)=U-$apA65hrL5i*4=-$PVfv!Vg z{y~;^ahxEbl7*^0wjmXq^0GBeag2uLFy?8CD!F~dR#b8qizDo4=v(H@gtJ%?9(-A1 zhoFVrJK!zP$#%QN(T3!@7W|xz^7q9?gX-_0`jOOK9Pvg%U?DwP4WZ#s4Ie|?GDqei zl?5bcL}v%>v>;WM#0|&1CTA<~_~ocih+1%V75N(X5!i-I}+ zI)MVzUJqzffJk3IlsJOtZWkvaA(hYs2MZL$oJv2W;H!)BM=>)em{^7(d$(G?*$xsA zDw@j%6m)7+U5IRzLQ^JH=4s-xh5A0COwV=AAJHk-3=*ZkNmb&3ErTo`c!@$kNROmj zQMI%RUv*WYLMy#$snb=0EOo*ms`GE4`%cZOG;{fY6c=QOP^>qk%1VZun&mNDeovgG zeV37@U>jtGiC!$qPh1I6IVEc{QN-jBnzCkcL>JRCFVoJfi{y{{^8Sanftw+%j542QEwcAP97K_JwL+PGmoXwryw;7q~h(9=!YJ zJk=|g`i=r#iu%baTJhv0qJ^2mfnBoKpw(3B4s23~IFViQ$r9j{!q=*uJw_?7?W94S zDXHTDytZRI^-pRZu_%ESuPJVVOPBJ;Hn>4u({0Ss3p8UBnvEY$8e5_-&@mxr`*CUp zkiDh@^;4kQ{BfL$DEs^w8PE2b2+a~Jjri#DQ=!QenGPUMl+yJPG^T7;^zud4`Qut^ z=oOD697(|^<-BVF6^oXTH4nTn?hT@TTwa7dU_#fVtwLR7IY zmeMnHGe#*R!zdT^y7YAl92Dr7%e@pTp$!+BcrwLJ`S4WS!yz2G@=j{&RK?m(YNL3C zf|6$zLvo=;7g16yw2Lnt(#oLyH7Z-o*$QYz?1SAVU%}DJBsW7ac7_o~ZhdUKq z90!i&+V+4-(f5KazfussOpm$I!3ihplnt4;a-}qKm-bxP3b^u=oVTP>F|&k>@i2;| zia2RY;A=4Jb#>|XhA4w+$OIyx@{4Ef^LLvx;Dl_!rOX8to2zB~?R}vV%cc;eC4PGL zRgR+&`Q;j(!PgJ7jvb_xR6wGyEvtPBlJW0$1>u z<_ez6b5hra_|Bzp|7Pc0=iw0KzAL-a^<7(x}3F$`1t9MyWwclm-wS`o`eAc8Czw z0D{HioT}OiO5iBcMvVMW*5mb4g!EAAUMt`D#Hr;%P-&=w@f+9dP&mwXbcZMuaiooc zg4>Y`B3kFkRNL3&4^fGDmk$Y+UCfYa<1Y0%qLhXsTe@Q35Oei zTE)n2Oj&6nc;M3Mt9!CdhuaDD|Ri44!k_X8@gk%%Xl_}&zDnMk3Eubk+Tf9bzJHkkv z1b>JKbT3+lb}L%)irkDrfoJaMPzfBQorL(+pzaNlZ~*b7^P1ZNDTsv(_C9!mXJRl> zJhu{bV{t+hZKC@oVU(s^24>ZMXgWfR4YV?ZqfT#lw=kjmJ?)i)# zZo0Jbg-9s#F?#52R3%=7Mj6a)8wZ7{2)J&PwA^q=2um?H7)T(J8qMfA=CqE99ZQ?L zB2jMKmx+i3?$0+3B50>q^G>QsAuFJl5zRd2reUG5+jkN}zwhL|y6Qb8cLb#-DZ89E zob^(3q0hX>akn`bl-j=Y?(2Z>69QEkjnJr8E@0Hznc>zi&~t7idYCFaieVm?F5!F) zfIwAE^f=hsge}6He57L2(Pa8oRh-Wgi=*?+q=gkB4Uoj3auMc23o>fFQz5gH?go7f z;B`Kf$nQ&986MaGUbCY1Pyi8E0&S*x=fVZK#3cA-084;g6Ng;1EL~bKzw9LTEodf2 z8j=O$uJqzik&gXmnF4Re$%sE`jSE6exguYmt*yemqpMqf@U^(qug_rx>S&w`|K}cl zBIIOlCIsTg%k)BYiE3B@yxv~4s@al>spA>cr|XF*mNu4d0i7fvN;`^twI5Vy?DXL> zp&+b-MjXK^jz-e}Qj-?FkB)w75`sLp9MpEaA)@EPX!dP98M+kNFtp?*A}DAxF*@QK z)kmV}yXFHn7mB%=Aqc&fjA+3FVt2@Ve?$pZA>f=PNWmPmNnhk>(LtTMU1nCeS^|gw zU2ZGYVy1+&LBSFT+n}vGw`7q1GbaIr+c}+@P6qdD3HzNHJsuGUtR?}F)S}Uj6Ava& z$iDJ#hVpha1Ar$77|nSs0v?9}YJl#P^g%)n2}lFy5Is#agApXnqZNhH`8$s?;SO^n zE>biTm$Ub6JK%A$Qr*x5L=E#bb*sw(nt zkdj1869M&y8@OYzbl*c1o-=X)jP`!594r3cECekLVFl8R?J;=SmIXs1XFd^^6A#(6 zi(a~t+bkTH2bXZkqPe+**l#wH8cs;Z3*oKA{24%u#z)aj;6WWXln;AXn@#jY+QdPS z!Wet{ebRFGh%!44oNnIA#%}_T%s@2`RSBDOeOA>58!7AY2i1$(p(1+!Qn;hf05_^1< za;O*ZnLgSO|0XaMt%cKegHXDV5oOeIyScrrXAPC50yCxvD;>C8J5Fqr#sGpwp~~*G zagA>(BUxmjT5$*fv}M`tpq$*e8z#sABT>l?X6! z>Fj;Kri1f5UMRe+1jzbimPn+k8+OvXcw6%jLm^VP6Z*PQuL&D+$}eyVNdtT>=ZCT59~Z5lgX3EPfCZg})$x*&GEhs5`)A9|R%pmEviz z-i?^7|Lv*zfTTMD2TGo(RBGJ@1bnHI!kZ<-dwB4fQs>NciQk^re}6fOP@AeE_RNjKKT_7_OE z?q>kKn?DB7#L+aJ=9Ber>=*z*RxtoS3G6Nsp%KvnaEMCPL<{m-X9>gN$sm*iUN`6n zode*F=(#&noKpiVD=6BkZJk8BBMuF1cmvIVWMd7mEj{=*L5(TLR-}MZLL~r{n$T?v z*8>!!?cBk5Q53>vM5A#7k&XhYy-+bg#Ju1Z3P?^OE>)og23Bb!Nx@(pn%E z|4c@qQxLUHV$0>e(w6GfiQCci8?6)u7(tBagIT3ie%HS9^o`2R#!gX_WyZGF;cKpJ z(rKTQYU506k;?5)auSC`D`wQgQ8_+ww?XX%7)1bMTKF6EdD%{TO~AhyC+|SjDVx1j zq&ktcK~V*yF;9oY2u<|;WSaIb7Dv!mT)aB00m(Ql=? zUpRr$5@~7BXbnJVwn!$T55->myO#u z_h{eZ51(Y?j?LG)WyFBkgC+?e0GrmswW6II=TLVWe z)Tf^)4RG0zC?MkHHQu*pk{f9Py!$k97(U!qs83ncEJV#$4C(X z9sc~Amev1c^UH#NVUoFJC}MH9@K{`%GihvRIgOP#kbc0 z5wcN@qn%g+FuwQvXs1^^sn>E;W-79L)W_vwLzx&^G%vn0q)iSySVZ&;`?i{kR>WRY z5jg?Tm^aY&{Y`g?(#eyZ1#A1rixKET-PBzopOhm<2#EZ9X}V3$A`pA zO5}GsW)2*pR6Zkxv(GG!DNkngw#ePs-W0gwG=xY6@H{S#*(p3XiNK(a+9Wq_7MF6+ zYf!90=)~hU|^> zUi~5tv0#irPpnbkYzk@-4%wr>lb}MnKoL|M$$b2-^i1mL#8UtF&qm`^QGKO#8ak1D zEhq^3$Z*qus&f7XMJ6=KHin{ECkZEU%58sVEr@Ve1z-^O6ru~Hb&+=Y6riPj(-$f6 z8T#u=B3!A-CTPE)qg{-6vGJqAHUf%dhF}QHyFNc^^x<1TuP;P*;vq|IUDT}bST)V7=^7hghgw@R|XBqyP!hC z{H#FqQ&^9n=TrTKmCG1q3bh^wvj1p@Id6ZGc zK*nK|*dE-if?hv==_!p-)|4#L86`d&!TgMJK=;WgI@B8VB!Y`SAlN#B;tF-hQU9_A ze5Ztw#%UTgrsyE8_{NePBNt|kjSaC#(Q7RlfyH71`5k^%%6FPrEh;x1qegUaA-JxP zdzR0rvs?&JDl^|yfd>U61QfRw39uH)BSB>X?+bjO(0ZsKt)h-ria`dXP-;tyila3AM-;84G#Nb$N~Anu?LkxwpfrzT@XHI7*;?FwFsL8YSpYPYMXk?K^C zCHBB^=pkQGjXUamKyi?T^c_>N>I5y=R&^2gwTrR$`WzKbk(cZ zj+=`J>0AR1x?_DBlY01%#D{lPM!Yp6%$abJ>u#?uuciWfGV1T#)MK;;?*&Q z`R?2|$$~4y)>P^ngA5`IP0-{V8go%VC)p&RTb!TngJ(@TR>9d&NvSLMq&1g@dgEs* z+#QfsTl3igGEQhkw4BPX6U$Y}8z4V7p!#tt7n&_G>l@l|Z|8!~Ze$1TleIyg(uIT- zhU9{{zas@C$6UXFxH|>TT4@bYpWMUP?TVaPWqGPJypEHPOojU79f%B$if&seb6-(= zEA{j%0%|2Wr9Nny^H+C6{_Fch&-+e6Q9(se+`;!V&D#)JoJ=?%%^N3NCBuS>rb!Q2 zjBxY_+U4SC#gXc>uPc8ScfRh#=D26|FeFRwrk1w>6_pAVkR*-+)jFnWR zPKX{9`R2?wb!Jqrr|)S}hvpL`9k!zUk~kl;KF|@Z-JzX^7W3S>6Mi!=t@_TB$5byZ z)R=ENxg;f;;(RChJDl2F@C|8yWyI-N>p!3g6qK^iHZUO)Rh#EVyE>0)D%0RRmE5y- z`9hpEwM~<5(tKCv!kgj*@P%g1Lmp@|uOTBS$DH|v11;A2Oqq=bgew}e8v#s}%teQ$ zn-(_*WXqpWnYVD|?Bnbu7`y21fm2^!iB5$W}aYa&uf-2r3;jLWgw(=Rt`zT@Og<}M*8r`r7MB)8uL*eTnAFF8_^@? zQvFS-nxM&9KQprc6Du6HZmEV`lkRL<@+h@yJ+nB4p-*Ob>OAKs)cYqiZ~o=Sv!wkW zUk69}%oEhU5EEpXidJXIUAn0>l^ePx0%Wn?^LJW9%e&(`V;@qD^F@ry6dVgk`&rV; z>8!@_#wKdUbqZkzWL#D@X35oh6jNKBZB02%`InV9$v5xB9Z-z=;>5{w*Q`(GKl)8! zop)lBVM$an-j_(b zwvuE>2BhYVC1()TNnPxKj4^(*B28;9gq53{In=-I@0tcwA}V`v(_J!e@KvgvEINpC z--$v@2_&(H!29Fy)?9mi&MVpG8)LT*87IfOWOoRM`|--BN-Ft%XXAQaLz z|4OmMUR>Lt}O^4jlb$jm(Zt|O86!mWZNeIDv<*gSBuLy<7y$rd=4#N8dovUftr zO5=G$w=y**MwK`933F zGk=HmvEI|xJ=ocZY4fIPyOfl`-nAkmft@TPVd$GPoajidG;>$z7Tx~-L$M1}_1UuY zMe>G4bd;rngrMVV@P&RGFd?rTH+LF8QrB3f|86WklU@u;dJJ^3Nx6_xFSlDe<@q_Y zwu>lB&ni2~4VLvD%7i#4%QSvpjm4FFI?&-+p2SxbaY$>~*=VyGC95@2*eDL-$OMs##k{ zag`nTD~g$W8(rw~<;~g)kSq7B`-N|M_mrgEje1%0TrT3U{Iau5uqpm7?`N!uc&(0d zU0qVolB&n7Gs-6#Le9eh&@YL3}Xp!3}+H|y42XL+^f zpkJEfl7+S!9MfiZm1=1tdJX+eZ=lNy)q2Uc7x#>|m4@20&jUTA1oHFbY#PtZUu(@; zaHau`YMy$NPEV`mD%xWyj9lWUraqiKs)1BruBEoxcs8I2iyl$)%I&IBhlJm$SvQgJ z)la&mUg9yWIX}$Byk2W4sYB>{q@+}LZTFs`ZJd*q*tpr$JCLkQFDz4dx5+x|@?po% zTW&wrb)W%qFuNTk^>$f4p9*2h*utbY*5wcgtt)1uwh7?Hb>SC3A-@>+$W` zY1{TQTcI|PrJk=M;G=e8N|`4+UUdwZf{=jM$fjAHhEFP?jUDL0(!w=1*@4|Y&xnsR9mSDuSHiP;(fRVyo{EUkSeO?`lDA=4K|&NF+9VJmp3?pdy-BA~|> z&;5pIv6XMS57|fwMHn-Zl60WMJ=Z8#UOChjHGNQLvXy-J>ncFD0jk55=hkUt)zczq zD6Q!un@`zV*tq<*7Bkx~@;4!I10)Xtk!DZ}ZH$l`6T`l-*R3)$%8u@M`;z z5gNzStE(6FEAvq^zoUh@=azLV&C@5ps3S|%4keD?Qgt*-PdB!omXV7 zZVc_PJAGk^#*C94)ueL+**36twl|Y+rhP(wW}4={Y$?IhV9Zkbqzscao#IAs*FV|n z&T}|4KzpD@U*$G7mwGT~=q>$ZDqhl3UQmtVmextvA+}}j@iS&x=KIZCzj$76Y3s(j zlaS>|)oCIhr0Nu-{rv!f}b)^0Dim)$~TZ!la4_sqNx9p)D%uZcV&vtrCH?4y# zCu)?Fmf+If&jy8PNSrnI?w5PF^8Vh=VoH|8$IQxA;^h>=T39K(BGbZ6ZEADDNyn|X zRpgs4K+l!&j^bvXEB`gu1;M7<(jJKvIciFng_bAwr}^1_OPHf2-&6aYmfTZKj(U2+ z^g9w!(N)_RdC!8zjFFbhLm#36-VNTIExG=MO7=1uKx#h(C#MZuwl-?+1%yq8u5dAz zQ$8WZ)A~)kBRLAz&xVXMuzt2e8!58g8)dX;?w7Z0wA7;2JgWZUS^359(3Wyc%89f> zo1rIH^w4$cVGSx7=9psNop(_2Z6Xzrds1oEEgM-$o~Es%E!NG=n9v@Y+gIVyp+J+? zHwCGf5_Xo>zq7HmS*``6DSAuz1BIK{v+(e&z#&z?iI}r|_T-y7Gh4E#MMuk6dnB5p zb`$S*dJj~uifRstcS!7}g#@>DIuQocd@he5W6YfQ3qFaA)#fCo&y$WDvw)N6jnh~` zeR!f*JLUh{yfk}%#g!-&pLEkUdAhj@g8J(FGihV2V%j#>@=eD*1UBcJ(8e5-;%{jc zrXwvy>tjc?UhJF3drGW&g^jlH0d?lt;9s8gL|4>YR(gXDP@Z5Dw2>NvQl+Jtf^{yT zgx=aHS}%$62(o;sUO8CLeey2v)(U-XCBCO|fg2n3L<>lO+p^jyn);e@;nmsk|{jD`6_HR}= za^7llbu|s`=}0|N{fEZ&*79t?zYouj<6nsNwB36E&Gv>?YN|S?m7a3#+D>b|8f)#; z6!rC;6i9e+GLpnylk8(TJ$o-{XL!^0zfMmhRfB;S?C0Wrq2CcuP_At%UhkXy&R( z^Nns#me}11%JCse>9P)l6@-G!jyF^XDR4{aS|h#h>KQfC8mAsr*Ve22uby5h^}Xsz z@pie-nmb*M#3pr~@@^M0&qh+NcTU*{bk_UL^@&^dMp&+Kg%w-s=va|@>b{&-qwK3a z&=br2dXTDSOQcqNlDh=`*_RqUJTqtSJWDy8XXZQ)owZ6!yJS1Y3b@O;GFIFqTe2+y zxm-qr79HO}sh0T#V)dKt;SKKMS@)ZXr=%*1sFF>8A#~J z4L$BMW|~cs;domR&yCY@HsZvNuDYC-T>R|DI%*BJfk53)&-fR8y``N)Uue0aI0=`N zvQ75b8c(ra|IQTr^pwri_p0Y@+3et|m);#`D%4D(td{9EJ8|y4Iz*t6JgA;nzSUpV zTPig@tTJf7{W8u~!15?VxMN2g8d1~cGtL`=O_!@1&h~~NiRH$l?EQY`Y)(djatLDA z`~}NO3N^u+fOH*+p9K!0QLu=#MsP__jqeb8|Fo3G9Bgk%t<#;zG|l0V0hO8IIzHVH zmD`mQ9lT?&TYty#W~d~#;=Mm1i`eZ(Vck(~$bLrIpL9Ct97ut%-*S-xVViF!>A|+! zIx;1}(blmO-O+IDS$aPoLAJ}u1a~9zv}e~l_gy`@dcEmJBS*TY+3Q+eY~1c?Hf`6k ziaXDe;M)-GSW-LOeOvFdoo>j1PB5;Ux4%P+ee3+Dd7|g?a6cVtVH~mf+&EI-2hyH2 zwA=UVu=#`h{5JBLuiHiFXhWO%ZT;$LyDcB#t@gXvbzlprg^Qk!1mduXr7|-V1oX?`atIbP-%l!>pd# z``AkoYio@nALmlE_9XV0n3!rgV4`0=F^NfQd48f(Ekk=Hx3nZCmTfIm4rrfM8`C$l z&^ppmlz4`&@I~HarP_fQRsgC~qWsSKyekbCY_x+mo#aor`$JKt-=K}-|I6B&=2+4+ z*O^;+!3DH@9)Q+jDDeYHh-eWMg$8%u>GquC5hYatsl5Fw%PQiAPv++4HXH+nq*Fa3 zFK}0QZM{B_r#^j3{NU@MeBdDh6DG=G5bh4HXC@kxI`Wyss$TrsAt)n}g&z?}BRIc$ z+&415J*vf@c4`o3q&b3~dfaL9o07@$@ocGMTK?`tFbYfR-Si*kuZEvEzht8z_M z`R|QS*CvSWLwubVBjn-fC|DjD0u+fDLKc`oW7wq&vLJKHVgk*mdVn)z1hAg~BDSek zwUo~vb3OIs)PTXm0>VYcxC=~35Jk!T8DF0_!PMXerLWG8C~gNN;@BQ>2o5ntXbL0d zD06)k4`am`^|inwraz+>u!}z6REi`3B9Xagf;*6_flMX@@GE*!V_{;=hsK*k1m1dG zuP3p7L%1sa5|Sr%h|xrx9#EpHhLGyildOOTQMQnD_1>rj1`Y|ua%=P#NQq2w2@_eO z_izyD1wcwl;lqNN9wg|Jh(JRrhIMHG9QMfUJX+4gH=Kh zXq$G>-zcF6-NS4R!SQUL78 zlvhv>sEymHf~BGm%LL#kXJcCB@J{)i}fo*`BL=Jqjgs zW0?nHlwnKK;71g5A~Ustdwf*lptG_R8HZgw*Hx(AhoJ=>)2J_8K%DZDj5z(HR$KuA zFE|yApluU@g-hXh;!GD`L(QWwTt~}W3;`7XO$lHjwR!2wvhY_A8g+_+cmnzitQAT1 zZiuI7r)eJ_hK2)%J{>CapcXEpABB$gXR$tE=#ZZ(2G@lV9sJl;;e&n%H#62;=s1Z{ zL1@OOW@6sofW02ImV<}&8hGt7{Znikg9mGeioT$$;Bd=$;rfDUfJ37u5s*84CUanP zicJHJ)u{-Kh|pf4Of$uy57FNQI@%Fc$O|cKg081F-mpN5cB=XoRRLk!O{2!qI&3?t zHe2G!Ik?c#M%?^>o5}1S9Z$lm0rqYL0s^gR2s*gnok1Nm4(B0$jGZ+K3%mrozm}(W zWLPj1YMrAU1kla&P60}N6l}*e zBRexsb9WS_yysVr?r?q`Mx$7Y*9X+Qu!?`e4MTuaF#w&=)MRo>372Z>cCLbW9Ols*2pq_I@Y9)vj>T-`_ zEjfiwd+OTctI0*Bpo|tX$6q+-qgZWxy5u+kcGM6mEd))X^b6A9>!W9TQYtpb*D6)s zOO%VLJ&L;4_*zxX_2_8(Bo{Ob-v}N480|+8m}v%2X3SBTw0v*dQSW4OLk&zLE?0`F z`M(yGfg@ZZkiJg6UY?*c4W9Hk%EGR8Fs9C7x@!;<`O6bnI9zoHGVAP)8m00!HFA4A z*&vY(o&bbKEtb!$Wby#PwHwf`9YZ`sT%mFfVxl5YEO!J_+@N-B-{QT``T^)(p~`Iz zL(@SZ1JU{%@C%rhcrEZ;06Crq3a)_2h8|D|6Ffu;NR5fMC6tAD?IXarfUg_)o`GcA z<)PYPtDs6iv<)!28Z+GXrEn0-gMHSz$e-PV4N`w7;sp*hVuQJb8GJR$rF!761;r&q z2w`mpqvrik)h(RUr3T{%m9eIbOO@CzLCFkA>tRToZXu|0mMN$fmCF<3>pifU-GUMI zg9xNve}DeP7)^wz2qLOp`Qss$1|pPOn;=IgMv! zL|ym+C|SjLEC7~H4fiELFAP!%-2lDP%n`iJ#B?&2UW(dJH7Y+>o(n|BG5ikS8 z3VqN@Zu0DF&#&8 zsf7{~p6J*4`7yE3vB`gCUGjCqrG+u$pf0LOKjMB+>DlO^T{n6*P`^4KJKa6yd6o?a zry%>FXJ^^=W7eQ(_LTi(M_KMg&pHTdo1XO3g|Ry0c4Iw&)SaK;GLcYCM71*UO=kAhS)QXT*6J%?&Mi#S49vn@xLo-s9IgQm>5i{G(=n1%Zf3?n%s$OA;vJ{>Z??Nlr64KnV`b>p=irPt?X#a+;8+_ld*9J zC7x7VruZ&;7G_KB_)3xYFe~yqnd@Sf791KXXv7$f9XQ96LQ&8^2 z>5-4VnxEubq@FBx%AZw=Yb^E?R}G4(Rcf_xagEo~Un@C?>Xh9iqmL~3NvPnC_%D{D zQXYJ6_xe=8Bwvu4X+*awmyd7ePb|u8*5p#W%juiPUXmAJLKE<&YF!)22sLqj1qA_Jt8~CBZub{A` z;1*I?bSNTlFqBV0BSO7XsJjc;SSso$OqimV>;-*5AHrk|0v9o5)nkm=%PzPvA&RQJ1hHIsD}{QX zFuhb%cP{3&s61VKpsLDCWo1`(5i=F@A>@RLteZFz%9<$RkczA(##1vUX0N$KUm7Zm zRe3VDE2rrRfpx&bsw$s8K;#z1UOhM}6%jO)T+U0MM)lu3q4LrR65-zNNeqJ;1)5rN zxyxXUtqL^aAPSp>79BPtL1loYOA(|)tmYb8PI2cAA>Ln37^VZcmU zgYZ6Ps>~nioQtXY&9HH4g&S{@Zbo&koHQpPxK;foMgw(j1k{hsNxX$#mAZw4s^*CL zC}1@1HS~0F%Zc7J!ZrYDND7M~P#RR=EI{Ri>yiqPJ>YpSC#P9Bm&0LWG?h< zGD1RP6DKi(Pl7EoP|3X0mj+e1Dx~o|%U7bVxLXIOFXD;d;e;Pdfsqs^$qJfG-Bh%I zhawZJ1-3_~5LMuU7rv6>sM)uLN`a-EbzY)118z{k+Bp4OV2x|$7w1~zS)6}pFAC#L zik8wCihCC0(;5-Yi(t=G+-j62K2+?Rm{vvMH1K>s;UDsZIH_}1j5)jwg4{XMJLbbp z{CS3w_HkAhyzAGSia$Tx`0|d8?dUr(mWq%ZjVNu0jQ3#h>SOjN3ZzX6CL`7sMD48jVK!9QC)h1#KbGtr5s_laGNuy)mQW@#;ckPIC1!A2 zyLm$UbZli%@6L$EYd-sD8g8y{Rqa?(qNmyMRsvo zB=U|d$wT#zTr-u_aSD4LYU`^zVy0AhDq8Gb>v$8ub+7L5m=f06j;0sXa$Twz(>SQ&~REKDps1tIrY1L%M&8Eqy5M z3H43#PgJV+O)7AluLM7BYdH}`M(jA~{}Bb&W1b?|Ygz)O`pkCN49`k*RLa;(f(9k{ zr#7E21L{#EKe077PKHMO0vVjU`*t3=NV2^QpFMG_2dQRv2gAgf#SZOQJ9g*BzkN!b z7D(TY^K1|^!nu?Q4e4b3oc2cJ_6a|Y{>z))x7i4AP%hH=u>8&-i;}FVOwd*Zohv+x zWMVb^j4^B2(nj%)E#;x`i4RGLILb05nOxv!NLwPnjrJ^O9%|2rnvR-D_qwaTX#ae| z3ClaL6G9|T)Eefi8)p?}OL0Fv;WWCdM85?nNYw36R#9TLo9`|$rhAi#*pKcLb+Dpp zJ!WmXXH9V`$(rgXtF4oRFp#l*nd`);s5h~`BpW2GX=7O%R&dSawo$V~ZLBShZT(j* zEOeU)3ec&ksDNxvIP*k+%cY8CNh6RY?Rzp#phJ=(QSL1`qEDJ{v1dEe@Mf;GUlW-eM(*LAg zOlhvwUuo^`w5fH`jP94cLNOt}m#pkHJ9~MN879qRX{QaIRqF+ZD^}$h`oy|gro2SD zg`J&+EzozXRlT#$nyvCO94LgQ<#*goqk2dd@T{I;_lvs+KC0K=op)b<7L>NIQ*Xj9 z9%|r04x1?JNwMQ&tkj#cJL5B`*Pl4BotyBa8=+%Iv-`uH{_ch<8#ZH=g~idZptvdSxi*oqeL7m7pfLPiYFAR*ZQW z^P11|4I&O!zfS@$$YbAe;mp*sRetZGG&755;+Zoud%aI-F8eP^_uRuzdpjpOz5=cU zxzr`8UMukFi7a!B;D?Iwsz{V(ZS#!G#*`@2gxQaBu7`STtc5FA0}-{PY#DdpK=~v2 zS5UmAR~7_j$kdNOY7>CzbV_3i9c2Zz(O5LX%$tcfrOia~E}$&^rmW^f#P7R9kNm}H zpcW35(VS!dEVq7S^9F28TD9O$bx+#Ucc|b|(jOB6cN9PNO>3S(8U0aRKH zG^D*Lj70`B=3^Jz!YX$t&4o&D&1)enw#pS3C=>PFJ@SwL_P0Z6^yd~Hss6&5ovwN% z?Aitu*ucVI6mIYhS_wqs;Tm{>pgdeHFK}&fgaGVWWopjhHLOXX0HBE_Re->Uicc)k z&tDXC?>B|f%+)aql^L8USwu0}H!RbYLh_9gWrvEZMyhN)dn%y?F7XRRSLpJ3_6v%*D;2_bIo;ZQLQ}5J|9>GZ z2d1v@)xkW=Ad(5iEn|Z6yxiI%xn4|WVX5Zq+ASS^RsBfuU4|+kEl=L8%vt3tXLn|< z0MuEDwN~p7_OE*;B$j0CU!g_oO<_`GIMg_xUgfga`JRbZrMsFleM6mJP zAFOJ^INfz3H1|(U%)1iHE8(hlFJx!5ZR0fyjk_6>IY!isYS!R`@1|J(VU@sN z@{Ga>X&VScIOQ)yYB>^xNG%y&x+S`hAmW?Lc(jWZd?8Lg`0DzK5L*2vU=f)&zYE>> z`w>>*yK~Z3d}H`>8aCG#)!IGJTJo73m4Ahb&*@DmE^}-n!VI556z2t%K1%gAW7Hq{ z*R&^8uUJ(Es7*%kv==qIsSidEm~gaD8RIRDWJ1y6S(#Rhd>=h6?^QDeS_!$rm9XJU zWfw7?!i*Qi$-7=}R)1x|!ACax8IcP9UHi5!{)e^SK8c0>75lKc=CpRu0tsxld!n{` zq7K$KkGu1po_1EduB!*MdZlxU)vm8GHOrZ^(_436K0Bq`a!-RVmwS37Mgu)kwQ3c4 zsFR~fLV;L9k+v!|n51W)KaJb6&SesJ4;8xt^4Y#f-93Z`Tl~#M6^>4!y{(dF; z)j-c`cbzfRV<5LLDz<;kT5r}MV!YxD;;yo{@H>w5RI=*!h{&+3xL=v@GAfcF`xfz~JbaD9RW6H2Lr7HN!`1vKP>fZJA#>$4ZniMfUCc%!Yb%^Y$K$Io#fZ`}qp;u=Q<@RnIiuGc!X{4V1Ex zJlls0NtkqniIH80uc6H zVMg*TQ2kEzN||wMq8xcNir@ThX3ZZs0mM^Dq|tmEIGjK3?mfIdx?8MJeP8`_s49v2 zHmt3lT?n|cb=RRC1328c_tmqP$Mj8M@l1O;W@h@{5MQ~^j!YlAy~0mpcxQ`}c6_)J zKx*%LkKs~jKW{e6fZ&97@5dwfLeF9*>ODbgtjlWmlp4inbb<3ayw>-d^P)XT>QKrX zx%d^6%b{E=W=3E1Ow?vi#0-MkENL;M;SaBawDH&l(^XeA^V);oO%VJ&H%;(Qm47?A zt*a6e8L3h2=tbd{njl?D<0ehKDg;m8#Fu|4ojr>;N4@7ax#qsd&uks6@jIQ1(L(X9 z<-7S{e;99d&8D;3_#0z{18QBJmm;8tioP|EK2S26$9vXk-aU9YZ#HWonPG zgY+H+_A4N9rT3Y#l63^Vsb^=NR2DTLgfL;_~Q zk>)h#oz~~Irp0srMo zl;*IALc#}+6ranDZ`zUorCLuF%6v~>Wbsfx`(yv`Xwd_fv@UK;t68R>*#`95d`{s| z+wvAMLDE|R#P<0u4`w2qe1V#;J+DL=$%EA`E6#3R_g)=y)@-wmZ?cmmVb#wBOsIdi z+)vp%0+gtGe~9u4&6}G&7c)3)@r)M6`!2PHZ;MA7k)5kM*e864rB8DqudG}@c&{tb z0YUA1P5`BCo2MzX4!tS#V0}dvGqs?*`o8z*;OuQ}KZ$~yV%E0L@0hi1`&s5q*|Uyj zv97I4Z>sg+k!?PY)!pwK=#s^i`=P&*{FO#dVgOk{roV9SwhuyMmzCzUzHeQ@z+KWw zi{*#J4%>)!dHX!}we_5p-}j_D@=ktjuhB2|vfa$tdQ(>8XuaAly`Z#4htu|B>mKxs zofK=EUGq;PlDvt2-j(jm{A&K@2VA(jtzc)*?`yX`y2S3bX2p2>yT+n_xBaH|>2%+e z)YMmU@mJ*8h}rJ;mc;z_tH<%XjE*<;j9P);jj#B_c!$sA;Gp@wD{pCsgj4NnhdC#~ zUaT6Y+upAmQzJjd_U3)}(n0J>$s;^)eu^nTGwvx_Q~hqP>Tkys-$5c|zN$KvoA%Sb zzPNpLg2E_tCyG%lYn&lF=Doj6=7}>aq|C5R5Z@eE%B)x?S#Z7!cl3ubRqG@N(lFh# zHs(|}5l|6Rab?T{cSnerbeW!t-#ma$1Q+NW?kU>?rDyUQ9?+naE!PgR(nAd>t>J-> zO4-`WL5WJmr|VWbAfNHryCg%JURR?WpxYp&V2^l zZN9ge!?F3Eewp^fzlpC%zg7#{6Y7~X++5#OU|}bpMS~WkAAQIPR0YJ-(9^KRAt>F0 z8k{h%zhuU0_w?+v?Y?O)bQWn8(m;<~QCx;3LN30KE~w319K1lq;Gos^T)odf^3U`< zy)tLtJKiG0rPKF>==Xfx6XMym!F5M;2mpQfoDwB1K2~kmS{SJ1SEoOcI$zBrT9>5@ ze99~fQsG(iIh91otEJ!7XGW#JG`P9j=MwxotOuOc&DWkj7_In8Ga(<(k!yK5+9FnI zdCe-6{B5yH``*TPP}U?{Q15x!*2seIw|(xSq{)fO`^qD=K*Vd$s-4|fBY9dIdr(!q z#Xsl^2;Qy;ha{dvTT0E}oWwNg%{{MFb6=)M+pdMEXWcx+1+tiPvKL7Q5JpR~9(UR+ z$vg1K#*(}$8%pPOAlpA0*hlt2(3)NOxX}iM7C!sx;RMPJy(sxQqmJ+Xs7Zn{M^_aDamJVZV9zNytx&s2Nl(p^(KBS6-jBF=So3rs`ZR_s1Yw% zxd}BiWsd>BnM(CEJZwtzYuNo&B}0B*$~K0-cC()C`fDkPcc=v)oV!Qk?hFKf6Q+!N zt;)}&QglvU73b*erb6;5MNiF5qLkoi3ZF-3-zjmjbDq}kBP{>HkA!W@?Q>hFv|a-N zD&`kTGirZvcKh}TtE`8qdi}-C7)1?atXi>`b!>Ma#ozXZe|PqIogcH%Rb!@$?wAD*$QXaL@<@)F`hqs&)RcA*MZsdbg8qR?^3 zqo>!DJoJcE?1fUpl~S<{1Xxj@`I5B@!}o`-s!~^-JHKkx$hWIXIn;Wnlpt$B%Ez;_ z3zy|stS4uvze$xjRl^}KFV^~ukW7A+$Wh)UMQRQuDPEzvW^_N#s=pGu2VWx?^07m5 zv=?*O;0pB&3n-N}D&>qDRRw}-*K=N*z3PQs7k=J*YJ>+dd0pa7?qTXD(7IJ+%zzKB zN=66R*)nwyvFug3RQMCKW$}0O<^Qnq#9!$o9Cr`O^C>BFcx^}mVKsTEnxEehF+%pH zd1O>`MYMpmgF@(s8vE|Zfo(uFpeQ6$Dfk#(?emQIwgJYLimCyfre~kb1)7}-iw&JV zSc3=tnWBgTtV=56Hn!Uz`*}9~W_r%(LCr=AAGdLLNN~csy37u0uqVQ^yv+AwJkP4X zB2J&LZ^GLH{a5@;w&tPKv%$0QCnmpno=tpj`W& zTr62B$$|>LlP}r;Llno>ag`Pd5s;fmdY!yVqOnx)Gu2uhgfzp8*xJG~e>!WuG_told6k+Nq}`60U5WI`M2V zrtnd)GU8ZrTw`zX&CR~6d?n6Ptl09}m0|y0oRUO9kx5!9wtoC{(%mZ5sCOk6eh8hX zt9eB7;q7^)|LPulgOWxRqaBv9;X%+jEWhXQi4y)G?BY7H*Yvp*^D?b%hnH|!vj~3> znRj4&A8Io8@Y5~NOL*8M4~QsJ=BVdPnktcD@=d8+A?0W*g^$7~((j5@w(Ldsi$F^M-rBQ$v@fX%N=2O1-O-j%@Z3H0q31uJKg$v(mj(( zL9+DMgthRFFsw=UW|wI}Bh;HA4a;Y@x1O4Nldu%)wh{JUolFbsdh=;_>_8Y0q??B2 z_TFa>C9Nkc??kUxEF7s?=i2=4e3N}06r-0ty_9G4(u|A0;?<^~@w;;E>C+l#CrSTO z-7+RtqTdDwcS?`Gi!E5Il=$6X1;fI7wdM?^ThOt@q^oV)qI~s*jxqPH z1GZ-Z@jtQaWzV*3tkP*G_DIUW|Zsn&sVxMSKrQDVGk7HGzY z(hZ_x7nfcaYbHIJno()_e!6%ji5K%kKBm`fc|AAn=>`#VFAbsE7Mr)v?-+yb8jsbu z{$g!LqwWOaNC)Ydu7jIKP~yqSGwCkvowV4H+AE!`rW-*^?bEoeWf-_?Pz^J z>zBPB-Op@|>l2Ov{}qj|EAOw!3sCP_u!GXcSFuZP^xd={N;bf1ty$j`SHyU$&#d*L zka5b&LubFw>bDDB{9%O6ckG5md0e|p&pL+_9vSY@*eQCJv_Nvng01R*vTkGbvgI2X zu0w6Oq+&6bRO{H6#X$r6xqkQIuAe?{VuaIrU2x*GOpg_vwg#N)284Lap49WT1|+QH z;=PJJ{VhrQ%evDs%j*7SJG`VLj+wX*e-fqKL3FEB*ge#^caKBWX6>R=1KKBX$((jr zs&O<{)m+3SSxJlvt8zzI#5OIRNYC=Vzsu4QuJwEHm9?$~AG?h0sJ>RKzJ&AQ4wcFD1q0X%N&GDg+wu+loSCTerqLyS~7V(K=ev|dNV?dQ1^+l;~ zvG&#dPRzHy67v=};``0-7diUFDB87Wofg}*b!DiB_v)3vXCKt=5gyH>cI&E9R&&_; z9cwYHamQE2wTGUnT9Sa&NUPH))sYXB^7JmO%Xi86-Q9(U^Xs+^{m6j2ZO>{v(>?5P zo3hvee1r+CNo>Q{{lGU)FH+fIE zbGMt#7$d@C(U2@n-Y_f-?fS;%>vzdtITm!S1RcCH0UAMF?sa6K!W9k6Q^ndsX{09p zY2;8;thf!YVI}Sw=aMsC8@WmqZMb3Q6UUJL7yaZ}WJF?lqWtKgqCI)BIP04HU1UAt zcxrU8whv`aWXDcMUv7qE!@}H%9-@TRp`zc)UhL+k;0o*(t=n&Qc5(yfy5VJSWS=$S z%yF$9sxe+Yi?t?Cq2Y6H^TTWa>U&nEuQjb`wck#hK54(Q+R+;hdA--N-?(Jv`#+iyz-%QXYzPC%_-U(8LvI4 zo^Ez3QqJB+NkBhCs>-`bahFCx+%rOXDL333>xqV-9VyRTlgD&Sp>12e|3-Ou1VEa+6w4T>2Y^`0lx zZM7^M$$MZzNluQBBmju7-jT}Wr1(-~zt%VPl2yv-zB(>E7u2vsn9EP!*okvp9M1Eza`R(kD1; zZTg!!cf&u6cSO42ly=WKMwVopRGzEn7U6Zhg0{1 zo!p+XMC-a|(oXJmUDp@hsIaw@Z_tgr!hz)1?*?b*hu&|pBPBI=^9n{A)gz2&)n`0C&0hJJ+L60@e-7G{ju9<9I#mrSdWMFzoA+lT z|M8`ZQDDcqiE`ki%kNvVlGe*ybIW01Dhiz|z+(?}?%FJB(@-o2L)(6~rbrz*8 zY9Fm&PsR7I@Whvwmf;+#rYyAV8|@}WK{t!7IE4CqCD|fUm7DnNp1rMGD~oc}D@V3; zv2mZVx_YKlN%0cW{mQ!06KILivwME^lwY=@$PHZP7-x*ZO&vJl(DT=gLTKF)3Oe%@ zg`m0b^~N1w7rf6hvqYQ&2FRYOPo*(#ECYr;=dv~Bz-bTMOvuDpTG!JT`KhbdZ_t-< zZD^5Um_37$VF>rub#nvZ?4F)I@R1ciUF(-3B&0FFVj?()oF4}t^fc}{v>$3XdO}>$ zpG+%u-ED6&7t=TWXhC-eMcB-1y&x(;x=}n^-q({j09iy72O!NX6TL9#%OuW0^BaEK z^xE@|kHAXiyf$%@DP`YWD|%};(g0a_sqSpR{LG8;@3`YQJB}M=&&f9|wV->Oo=H22 z-^otDKEvSZ!jC3_r02`q^5AEz@rnb`p4g(W0_b$>^_Tci;(^rmyTV@vlATSF4JAIM#RL`G2&k@b&X7LoGBJ z<&sIJHc?mm>#7^a8FHV=A1d#IqEn`AClgQqg6cf$kIYdPUn`Cf$arj`z2UDY3Sf-q z&EeIJujm|9EJL@>lNCFG<}{$jy|+0V&tvbFaj~8{F_i^-*Fo_KwzANAYj>9`0;4VW zb7NtT`6MpVJ7n7WuFOa8p8d?{_0Y=#qq)}a(vwxk4dIixhHOi+yz5#edEPbK6OVnm zH?ZR+x5oy5`evUg%WhxG*nP9vW1p@zZ?Ak)mR&Z#9u8GZK|`<8;+0Sf@||^}9CR+kvupiQPT^|L zSCY?@tjxr8+fxoBr|BnN@amNae{%Jjh3C0?hg6>F))W5nUvvTjDy*pyDiwPPU%u>~ z^7HFl%Jus4C4c1S$8zLo1+7xOE2xM7>DrlZ>V$6e)2At8kc}z)^Y!Jq>jdgsi>uA& zZp1OPdtXUG*}AvG=P%7W;t{$};SJ>xRi2G|3j25Dh1X`U#JfF3JT%X>`e~b8|Le74 zpPeA`ZQ}wyRKAvu-jpu@k2b~sfwCY!yD8--=uO4RAgkm-CS)NZ2}V#cYl@mt42dkA z#Aj7vXz;9eAunU6?{(XvuQ-Nsyu3YMUC4jd-l#j-rsJ=4VLXDogHm&k}aX zhy)>up)2wQFAR>p&V*DPnTI;R!y$R1JwQsll{DTZxj6^L^Ucj9#3re>*2~S zbY=W79gi_?oZ6csL*iL?EJ!@-eipvoald&etpAP3ye^-(C}rpB&F$!j^Gy=b9Bnel z&r+;}O4n(h4Phi>g&pLVXx0F>Y+SStrKpNC+oQbml>H|1VJM!Z(HAg5g(^Oji4FD< z4yMnddCr*n%?qzk%Hh^C&31Utw_|29Giv1U7L?Gk8&pI!Ae+0QPny@|v;3t7LSV-N zuiWU~9AgpBz$!z9JA4rlJm{Yt3^`nCmoJD=?fYhC@8E>Vv(s;{y{O`6u}+Hj;9iLf zuVFl>Ls{|I28Uu_mRCDsGqC>+vUD0=p^+WckkprQV;lf0c9g+TCM|l^AiKQ7=|g$7 z>>g4e1A!Yp%nu$nuD^&!$hV&z4Qy0rRG-zwS^J4EpL23#XYwY-8<8QzMtk(#{Z8ZN z7!RQ<%H;P?ReH$Pd-{rdUE%|@^8L1_#vKhKDB z^6wZeDZ3GI(b+vcna|E07q@w1o0uns zK0d0^#~16lUo)>~+=<4AQSpr}6_SK}U{Q)>sLZxdug{oNR!N(;QQxTExb35b5tLi6LA_>aD0&E=(ZG-B5w&+#_)xqD_jJImKk>rr?8|R7 z=aDZ~c)D_P)VDlRT*FAli(Wj7$O3RjNe>T-z1zo)dFaac#RgA+%6)S=P9*lydgDd2 z~AW{LE1yFH|Aj^=b@)Z-YS26+^qDNm*S|A%>EQ+ zyLR2EHxgyE8*u@ph?35FD)T$R6&@rdTEEU$H7dh;yuu)F2Ekio^1pY3w_&vnwu z<<#%^tTvoBZa%71qB?uI}EwF+S;IYJFJO zUwHSWk5!(9^q)p-uIuV}%6pgorz*Og$QV`F)xBqR&r5sq>~&vS&3cB$9_?K&*rGng zgtn}F^5FZ;gJ1A#9ycyP_b#CU>%OK40-d$0(Ja}qw)M!QEd23s)AmkY?dI!CLs{r* z<03uB`PTiFkU*D`zM@zIol~>i+&nl}Du?*~EK#dxOu+6VK`y5mZ zhEBfv;1T%E3e{fhLzeQ$Ec zi)NMdrZ}xWeUaAudbXb5W%tatLt5zQn`%M#I^j&OM~@Q@v1~${yQ1e;);gk@gk~(+ zv~})MPh#t27fSlF9U`JbmaSEpXA7%DCng~w3uEl;kA9;UGF&0l<%E0{uJmg6OxpJj z6mupGNO~V?dmr1=_vFNz^SPUPw8B$gZ@qXg-Yrjxbhi>`7gIJFNi+i`LM+l2s8pmF~ExpEP34_gc zkVCMCpNZ15ns0o~(7NAyatDcAXSJe&eE%aVs3So?jE`uZwf!JDbHjCf2KqO7x3(MEKgea|r=NR#~BZNEh;)U8}4St~uw7TY~+o zr)F*vPIjBtZ6g+@`_67$Zo=@5I6ZFUPaeLH8Iybn*_ZfU;JMCdeXizbCiE4uh`8MK zlzqGZEQ3qP6C{ndtQrI8ent;QR%BJ%+P8Xf4JxWZt4bI(DO}Z=Ga{>26E+_s?XF)c zDKFR4jux;7WmSnm{^aR5qyDq-_tDxi*|mPAiV-1@Z~a~(n6oM)s8*?PqgCTn^>kJL zRM_8_T2HSFTCjgt{gtR{+HS8$P;=dWx-KnJ)3s-@SCrv5qmHs_4`4@kwb@H;#t=1R zm%kFvmPZ?3S^j3!O5XmaD$(j$WUvY)8*5w5p54<=Wpz{DxYgp;k6fu5Y5CH$Ms=ABlx3`$Ut|(jt>5~~9t^EROLtZ9S%?edA$m~dBO|z7 zo^O|Tg%>NH&*NrIim#iHptrM9^%Z$#0(X16x@+`hI}cPX7{9dy6~2b$uY?Co7|t7O zEm_?8Vy&w6g`HksQKihtU{9_NDNOr}%{TBTlB*|1CVH}cU2lf1Sm+zcId4MSZ~5l6 zm2~s(M9ph+H6@%c`5~0+u1cWW{R}&m@VYJ)$Qa3%u(}?qT&(|b^Sp|19jp5iSv1Yx zoa9I?#;~x2sb>q@S7IiV|Dt)>s=`MLs?evegw=7mXQDJO&giN4ck_-<)Lgd(RdiG9 zlXFcyo5kN;WR<8U!D_eqnW?*e%B;{V#W#iXmt1A5@24+9C!p7JyIMlnai8iBXYFFDJ#pjW zWW{QiWNl8ZE3R6rnW^$pM4|I$?JD$dad|=`6%W3U*z$JFv+72;vWWI=yE;o2l2v_G zm^joz76^T;&4=oiA(Pq{<3$ah%!4>seI+O%>0fF$%a_2)`h}7N8^o+?L`Jeg5~(sn zmpq#h3tFz0&~x@zB6_Y|X}T}!6LPob=F@N!k*AYuDe5l!42THF=JTQFd*Y38@oh}) z*O_yX-m%Qy0?HJ^=#k_Hi&GWYBcgdkN-SdKK?_bl$J zr=ArRcE^6S%+mbLpt?`r?^Xu?x4-?v@8T@JrY`Ss<0W=bI{&^}cu_+Xr{Pxz^Ony% zE>4-tv{29wCEs_3>ce;j854kT$TNu$jr6>{yR+{_CA`miQwZK_Px#hf3y>)UCA8~| zK|r|Nc`MU7f>fes-?Re%cFy9)d&Zve*zXxsPsVaMROl0;s4_<)c&12FBb+bqZNLB5 zI+TQj=Ik%27=z;Lm6EDw@ayL#-D=)n>{fv96Lv*O!}Ys^QYHDY_!p{b{&?&lIh>wt zkQ}~-S(1>&V~3YiUCle%tBx#KEqdLPbN^4Tg;xHxNe-oFF zbf+)*K_IU|2}ykMEcD39>4eC^k$5&Gd?}* z{${LSM=oh?8)K-h@GZGpd8VC{uO~gEF!2WU*+)b2MVJGPo-Ow!?V!}UxP0D<)Q6G> zUJ_-`XY9-Oj@_Q$Emm`VyB^K&c!Fxpo~2nC11Ra_s2?h_y$h`qaWo6#%g$e~dX|C; zev!{Pv(lN`!kIZ!4)@(-Q4u+LH6u4VdBvhHiQiS@iwC#Lk1R?a=VUqf{t9w%ChyJg zROid{1$6atcgHM@UDbpO=Zd`c6}}$!aBFu60YInPs74Nul=}G^jkn%2gG2IGuLrsY z{sO$_M-NeqMBbr?hzdOA+?MjAucmIIW zuFBV+@7+J=J+--uzIOQ38JF$r51!9AC!S}zr{?jdT6^Bymj{b)w5NrtsE~WKXZ+*y#O43`+~g(pLt1&dFaeF79Ni_+3%lN zBOwKhab?e{mKqK8f%l3PkA1C&BFb&m*ZvdUfOY6q8PTx+zN{yvU1$K38sGKp|Bef`v}Sp*3R0>#cRgBQCZ1<$*uPxTtqOU_n5Ho zC3odtZrY7x{A)iHeEGTu%w_MrWx?8fr8#zBB3o69S@JW1MGz8Ge(+?SXbWKgoiFS! znf05F0SI0aRo>bYUjLG=-+eu+iTA#wacx2Sp5eQ~Fa6tj48L8mj-;KgR9st7z1l0C z_p*mPZoAva05RI+XF5~m>DH=@*RyJG{a_4gPbZhZ0uRbV9@MBnUSho|&urx@3vaf#M>+fnZ8W~JuiU-){kqu%O2F_A4+Mec z^Zn=J6PIgMHatkA)ZWM?)j{6YdpaYM#N6!}pZ3_gcZ(ZUP?8WDrgz)~^-mLww?V&D7H~__5px;$w!FS^We>;ZCijhlAS=#odfwYW_jjQd$YPmgk+B}7wVN# zJ#AalRB56!+Rn2H_Xzbs5=D3n(jX?3Z~FT$)oh4wYP9om2%dAhC+Ffd>eO78 zO($~J%jK6Glx8rp#*3{LjjxRDQ~OZ5(PrM+Vo@cij^uA}Ruo=#M zQ_rIHZR+SDScX)EqEHkhRvJq6p3jQq;u;uXCsM2h(ll3B;5aRqiddcEy5pgkm8=>y z$ie*mT9Uux)-vCcs7&8|!*ej-GOG;pXV~tC-wZ2%x7Hkfgl?@Xu<6^?ud(vCt9u_x zR;o-M`nVRX@FOHk{X?0P>qB)i`KviOJQdaaIq@+_MsE5tt}RGDh8Hy+o~O`K!Nqha zS${MW;_JwlAJ)C2^?BtWZ;Iz5C;r|$)Pm$h<13n%7}1^G#aAQ;qc7d}zwbsu{&wBB zWnGMD`<@yj+MfBC>usqYNCnahz?!JZqdm{6?uJAZ0p%_$N2eUBWnIm_rv^rSW~U*w(C|q~QC>^F=b3N=WRd@5SJjSZWI4+| zyin94svTW}IJT;Dj4BeQsAN<7m2TwYTNj?svrbn3FT7i2X#@4A>drj*K?YNzt7KIiv6ij zEjuImQtQ6C!Y|t9{R-d#ZlP!Y?(vHjz;6`oQ}V449JAZMox}A9-)EfR)BTL`fnbL> zw zzxA@k5pw#XJnFNyK*}_r-wUOH?BnA|w*QaAJ7#_cCA@U?)7iU?UPGO=Em|>7`||y~ zv)_&Z$ycxpks?#dt&V*7tjK?hRl3xhkIY=}n~z+|Fv@$3Z@PwbjDZ+Is$>^cQpY!6 zT#p!?R#hj-AurVV`T6+pA{JrVhhRCBe2SvvQ{3~JYwXFYxY@-$^ZE@-jHs-K+Qws# zH&vM#YsFJ<`A8xv9=T`r#=@O*(^Z?%Tm4NvyZGuTA6hZ+-(y6- zcr?q+I6hL55=r)G63(KW)KYF1YKPj&Y=!3=)rf-&l#^P_J>lmn?pY@iPy0_5mSY{{ zMN|tQF_KCh>p;(rd_mc3q-+#bK9%niW$)+SPHxFXIn@1f4<5~sL^tbIvpd1hj&+bX zkn_DLOIv(ajZz)_a;pf(7>Y5gHM@&?!$;Qu>Pjf%MNxC(%E&>T;=@^ros?fx@t9-M z9ub)G6qaOcZ9R+CL_;e0ANdR^_qj5m>BqzIqYZ0-6!y_(oAig4*W zy`G-yp*@DbIQZp3X5UcRk(Azzo|pOU81~g=F(Wgam;_?P6Qd{0Y z;tnHUdfxpom)EGtQ^?6IEba8{Te7ar$#YsR+25F-dBG~JYUAn)S6O9bA4oqKs z<%_IH;a(j*d?wcmGh-tV2=;rUb*>-3y|h?9Jzd*Fq3g?|DgIoQ_NKqtk+eck4?dfo>jtHD*ywKd zXy)fl&GlyygF9RM4ev+x_%gBClk;}rih3O*opq z`D~2%d1(UWQk=dGjP&;62`rwN7lrz6*}A1&On*hxTn|MY3(@_IKvInA5fSzXTdJd`p5I?^qAHoQ|~e9{%+kWEaDTbMq5l}RA(sbmgI*Z;tB z8Tr8Zo`(DCn96&V#!{8L`)D(Jdi^$IkQU^;SEx;%w05I1s#m@eY)eL7%=t%u`MF<> z2$Z5~=-A+k>a8>25sRk|F7#x_wz|SxZnYbXhCx=fcFTdf=gvHKTMF%y=0{FP|i+O zd%B0ay?d&~YVu6I)(+2%R+2%UJDqr+*l=^R^`Mi7BEFV?Os86H#tVN@8LB-#H-DvA zn+dO1vE-8{O_Hen@@$eJBgw8eHJ@&QxfaT~WQeiLntvs)%H7eKs;b@QrQEMn9LD7K+GgEamur6q_mD46 zW^hqe+>Gq0+0^0Bip@BqV^;Y-Ic0E(L~VDdeR10h;JcpdD#UYHu&T3|&U{vRSIKy& z*LQtZv*u4?JOf32T0-}%y{W42ScwZc?|E7B1+{$_&Ez|^X{p~yDk~HtSB2}4gUgl1 zr3-hA54vdxv0BzbRn0!s81HAo1DEZv=I5L3m-awLCZ+A}hi!gQZE|b9uD{rPcB!?pksBy0fV}uudx}|FzEehf%iolTSa-bOkZrr^Zr6M4UT^pP(j?6Dfn|du@ z!hN@nS)UfDJ|Mq#xxQ-^b+he&$RF>av3c3jA}5%F8WIuJ>%zH+_>T zPwN+vUY4Q7oaw$2p6u*z2EuptS2E9}S;bexnjjCl+P7V%5}RAYS>C;ikW{?@=p)@R~GFhWMr(v^einX>2*ooaim7n30T(T z64>gG-OZj}!b|KO$4V7d@1)l7+t)TFSn1y_AOM&Sx+b>ZAx>q$K5q7(B zw+`UjA(NeiRW5R|*e$t()8VW>2;&o;}@lR|5;bXWRMC?|Qzz)-NvT#dhe! z1)az^d<=)$?fG53w%-}lxW1)BNwYfAMj5GCLpznYWnJ!oig`r+dTAz5ER8!v%fb zo7*qcp3j@z-_%Viy;>L^?K6Xik}dYT(Kr9)U;h5T{g zhacPe+Txq*nWvdNPiMENFTfUc`?fgAraZ<}&Y48HKz%a5H##T2O1wkn#F(;kvcB?s zWlktloVl|R5wra)&MWHf&1P?}T979=#@j4aD$fd*=}mizbE*2uFO+0cwAcNWGrzN2 zXFBULhrijOq~QlO9qVzVE%?6$P^u1Yu&o*PgCS$=2g7nSpB=J;dSY%)d-A4bTDK=L zM?b{}(L(oL(oEQ!R-ZXTXPV8HhqEJRecPsH^_??DRIUAg_ulmf9@(~@#;k3h@&hVg zdugBY7-)6n=_`KLu4k&xWs6D7%<_FW`n}#Vd`dg$epavl=eEGDbFTNTZ07S8@$$q`3qeCygF&y240id*XT7jh=9e4`=sY~0cMcg5e-yy%;@x~`z)GaK}* zUAx2wYqqqr)JC(u6>Vr|ao@3LOns}q6`mDb)iQ4JruI_IVYN>=W~NvtK9XaV>p2=w z+?~(PTGf_`#y4Ll^tzThz4>0V=KIItiq(9p5cS$G_MNf^SNHxLJd+pe>|HR7y{}jI zTE{mB{X{w_bJJt*UeB19Za!~N?X}kZm$`1%iQ}8i`|7(I`5)GLJ5Dot!})?~vCH?D z;q6T}ct(?C;{OZ7;9-Vv9VuSl25O9ep~TPwQpy`{b41R*Ee?0 z6WNr5k`*O5Z#nubF&DBOgzVV1GMqi3l^~YsPz#OZoXH*&b;P#r-P~uD|0w^()^zw`Z+|`*U(No3!A`#@7%$&panPTseM=awVAn!A@y7M~_H8MITpiFV+8bL`{ z3mzTz!^X_qn6ER3$_6ZvCeZhdiU>})yZ*?=-7Wn$eMyhadZwK4gzOiA7t4w3d$>-tb;T6;235A zg}WkSDe!zKWopDdt2>J$-fWI`U);KsOOSXbw3aLi43D@gq8s9P>|N+0aqYb=u$~>C zN&@|@cjr{8XF|=1_QuVy`lgNb4=XV*W>8}8$ITn*!eJ0~v4%t$vEkh1_RU#KLFw69 zvvD)V&wd^0g~8Ov#gRJub>xfbQG(K&-_1Gv{Rqc021eXxB1TL&UH2KatRE_RBYZE; zjUhxY&Xh5YxuG|WSXP6oaO~t+V4{f{V3bj#nMlas=F>uVd*`$r-QPSX+UR83a=MRZ zb>;c3U+^3`E+x$$HRGvnMq_iY4q9XC&35Vm~7E+ z<53}r+ncw3oOp}=-U%O*~yAd>`0pE@D z`NPb-@m;!cnaFfhgfnO_{XuDpJvp6e6>B(e7AresuA6tINM2>pJzv6sXK~AY zV`Owi-D;MmGM{v(&&~l$JX4-m+~uqVjaE0UMA?9Z$n${b(o+Ax&IDr*N= z23=9Vo{Q!j*RX_C=T?RV=b}Uv?%c1rpEvg~Y#-H#Krw5V@|*3M3+;L=Mv6yH*EaCV zC6jG{;F3EcJ?oY-4GV*i`(j2fZrQ?4p&Yvy-!KYD!fGL8ioV~JEE?JovbFRl&vRbH zu^69rGIyjoZcaP>TyWZFn$)~IGVBJ^d9)i_gfdIlW0_D!_(W@WPq(x0kFF@&2e@~K zQkHU?*NOm$!l9gt|B)85nsYrDH%3Y7Xi=vK_Q=(Y7<714@wJk%tNKJ6_1?0&^G<%Rvd}FTQejc6=o}OSAH9U#yYSLVkGLt#`MsoZF4{ zq2|k@>t<|!Hxl;`^E-XIpA~(m=;@`xzB7$rlA)Ae9d8cvY}{ps`RVYpqOQd=58_nj zSrUTDV`Bg%$To(A)mYXDWxD!znzdncJy|Lw9pgT(OmpHg)-;09*`aG1|0Y(Kh!Iep z4kdjh`niqzse8OuqCp9XOSjbrxyJW@?W|QWkB2>g_MQAeqVIIxCNGrg|LIt3A(tCO9EwV6P`zdQcdp~k)FbaFjBfQe0@>*-swkB!obNpC`qxec^WBS{8!!- zFK1E0R^!cjPnVJMJ$Yz-bAHVglr;aZpN}McGwuPyXjKU=l#G!rYu{T)3o2EAv+rdz z!}#5@4y$K*Tph$XQ{>O@d2wLYLut<~%ffhbd4Ggm>*586?P?iqEPl7GsSQ>|np*6Z zi~6=&j8>BPYjH->U2QPe$=cu7H%H3Ghx;1eNRk`h$D#Nw{|qBrHP)qIONy;{DBa;> zm5OieBKB?MgZaS zf9%2kIz-0TI@DcU`t(5T@8X2O1FFAO#FKIxTZw%XrG2Oh70GlVRq7U4C`ALvL^{+d zx3L97ODV1`Kv0T2kx|reHy$dUQ8;)h0g+NsOUa28-$1K4)M=fH6-pqjAZ12!X%EU} zP`_GON*0X8sY^hq6z!nyrHi8CH#ws{V|b`upEoJNvIK2A`3i|CDjvITdE89TVzd-% zTR=;zU@DrCU{lZ7JI_uFI~o2|vs)>2dWwr|O0cOU>MkyE8LKIfQHmmLzz0+s6MaJo zftAx)pr+=DrIl7n-f&+colX2gVU9&HV6w0d73)W;>58PyGuldVky8+20X+#^XC?Pf z5T}RAH|5YXufn5CP^|PCuVSPC4yf#uyr1t5)=wovvEpA!P^FafQRxBF3hP!1Af;k} z=!-WioBc&Ny$LBhrK!18W+MBm3T9DD)mkc zF-)D*lnl=sJh9Dn!Aqo`i6i&=<=J8%QOp^I$lSVz3q7y=%o4>!J%bcmS8<9(v7LR> zE#sTrg?M*+o>4Ln?~RMts8GhDFvlKFW<5N(Z;9EEV9UHT7=w~h4}Wfzg9T$2%^;r5 zpj6WKYzs^>0^R*7XEksMRbHp1>V0&k+%Uq3E<@>(A8k-!rj8ndQKWZ4RVSXlsIyc_ zsmY)T`r~al&Ku~(T39y~kTjGz$u-&r_RY>60GZk)*FR0-4!MtwhlxvMH+H^g_;8XQ-mKt^$=#|$7&4?jRP*md?H2{J`zx%N3g(fn{-UBHBSrW)t8UM_ zTUVLt^Gcou3eUHCV#5sA2#2^m8!pNnYjn??SR+2o8RwbD40qQSO#a;bEXG%Fp>L>8 z>kF!sXYA4oG}>y&?Py&Z#B`0x)_nH2TwN~AH6}^Yj`o^4IXFv@)NE#P2u77dX+OmH zrZtEJLAmM{YJB+%HyfUfw{erxJl3q7? zGe!ir8bE=D3`IayTP5d9fh^T0(3z#u?m9rloN;m)u;H`QsZIlDoOvNrK;R#(Ub%ZF zqzXbrbtKmdR3j*0`{OI?>Mt*<_|48))#gK??3wCrK`;|t)Uf8*s&*rtuggFI>gN&< zQkznI7GIHs=3^}xZXgiNRO(LEqq0k?2NGH_U*~OnI%&93o9j8>n*cXdpQ>M}0V16s zHlkY919=ZVoq#2_(CXOlDY?#6$hztZUopGGH7!*JA--AeiPwfpIULELz5vj2`YE6l z^;&mB)!vM?1zW!r-+|5~H^KB=D)B6^e)|_ z;my}Q-Pjg%~t5=ij*>~n>0R>t51h|CO0DHDB)tNKRe0)>zH+m*{4MJ7d z`Nvhg_sc!c*jIH`tyJ&X-{<9m0+QWxP7}iwn#XqCF5PTemp;KM+K08uyze?JM5T(} z1IeQ5Z4Ebx>eL2!OEa3{p)&ZFl@on2gOZUoKRkbToB)J=f)D9iIg#rJpzPctXE)&6 zxhZ0TI;CFEeRIMuD*QTCTq|G-OwIHo?0NS^S8l=~4%N58=c-g`^>a~-ZEWllDtfy= zk!MwlN};cyD9RPqkxPZ`Nq}#$-|w>kOF*>0E=YFo;Tpr) z;SUvdn+sN`+x!Dv_@aJNndsi*l8e8^-6EL_qK3PQGNTiz=--eIeW}p(FUVomGXW>& z=PT<+C{(wf2zbo|HRDxKuI1_Sa%10H4*`OQ5`TWMH=7{dfR}6nXB&?Woy>!+s3;!Q zM5RL$F4zPDI52CKTTD;C(`tS)OO>OC5`c$_bpVyEUSPYlZsKuq0B-FQ`plet^Q^7C;k@!hX%@%mT%1Hu2!ot<6=uOSiPjWEbmr>0j zsv}t_v|jrAPi!ZymYO9~-MYQAdv7=|}`Q7>v z4$bWuH(HF^6$HGt-He_YE*6luA5jl#Nhsj!M&YRJ+CXMLn4V02=Q8YS*;U${@JHYKnD;-yxS z_unTrBv4zL6f?sp>MX`cqQ00yV<8n;fPGC6nIFzXuhi~Y3X4SdES)h_MEZw(-Lm2P!oH+JX5Cg5QE}diQpJOO!4a`iNrFW^^6Y-5 z`lc!^Xs3R%(hZLaDOL?ci2!)aK~(@A<7D2Jrg1XwJBI$IVhormh~D`5IgM{(UmJv| zg)Kp|WNSscd!-9dQZ=~+OZk0df#06f*)tL9WPX(+Jk%_=XCwP;O!avtr1tDH;FA^O z@IK`hb@hs!dhyqHGt8$i6}#Pf&%lE|*zB?H^-cNu!H9lRMd9|d+pf`2M?^`XQ<2Y% z+Pm=%=mIBy>PMQ@^<@oOcw#c#x;#{)+atE~(-&RRx{KHL`ivpD&bKUy`IFUDQQu<4 zGd#Ap(zXjI(_UC+i~Axo?1|x$IjOh zrT7q;L06?`;{{i34Oek2bJzy>iSFiahWF!822IXEHSBy1N;bfwtxZK!5P2l?K1FE# zjBun%UPdEX*x%gwf3?Q^r+@kT|M=U#oqzo6-~Z$JkMqa99j9ho`n$jW>2Lr1kN@=V z|M~A`6qWtz|Ns48{{FxIw}1S%|NcM!pMUu4-~Z!Z|Ms8%?tlFEfBENsxI_Mb|LLFq z{cnHw*Z=tU|M-`$XaD*yfB(;4)A66ae&^Qy4}%lQGayZD5XMXmhXGa^oA~SEl}ivO z{4cBvCYoP6L44%2>Iq3H`T%&v`t));C$y0KkP!#ZAc%d$QK1~EORR?=GLzpZB?|c> z92dHyLI-5M3GZcmzqZHkCk((0vgM9B3F1Wf639A2;l}7yu$>Ix`$uSdCgQq-b*g}N zqbD=mF}z&J@G?PsFrOwD%0$x#;`%Q$YWgHplssd7jWi1p2?Gs4lqbajG6>EbDy5%4$be^D*Nr= zC&iqRd^pba%}I#=4CBT_e7!IM;o|t1R1fDnN>H2Od{LI$3}sdjG&3UNgv>MIBt8pU zf^~Kfu~j0jS3o=?ZpOml!QL(yo*5oLq42OT1i~}JHKckIv+6e|D4Ogy6R~oB?fYh& z-%h3K49sv7;Eg)OSJTR7V(^$53X7>q6M#l70Mj6ZJ~P8CM^w!rPIs5T_SM29(Pf6G z!bHS75tmaCB$GOfGvX4DKfka_Efw2(qtm^SB%ua6SYrq>$#pAn4 z0wH@-RTt=vpY+dCtZ}iQY58JnqO4+$(jn^dZpZf?BBuUDIL4XRwY)GhhOo%;xB)} z(u}LfZtnZn;8Yp{oH_s!V(Wi3O0jFUK9~B#VKs>OP0^FspH)vpoW7AkK@zc_G<~{p z5S$)pl_G{8c!??U(-<(BT<4GSaTZ;0Yr=nd7%Gqvb<5wl^{3c zZmj$`j^2kjJ;>&9zSa>WB~~GrCcM9bzadz4S3jxI(HKvNC66ceq!PYBblcqr`51Q+ z<4D7N5}V|k{+r+P7U`w9<1j-?-fTb!&?`3F4;10P>ezV=L;!JvWJkobVfL21QSl4y zb`Zo7B%2ZlV6i;}Phz~^H=qA@h*>FKU@TlJBP^hfJADA8v)zIB{ds7E($Zux8 zxh&Zht&8LOp!I6$n?WoIy{0~62+b&iIv}0rjy*Bb%u)| zW+}z*VjIRQnM(800<)6HIMhyGbi~E8VdX#8dcHLIJHEl#ua^H^XXWo#US%v0=!deb z-$9k`b0p{DbMNqWCdJ;*q%_4Dkuynx;G7<+W}gxn%%lR6YF1enf^0K+ZlMYCtY%C7 zOc;I4;RwnyuSW}M-&xDaH={y7b%Xk1qeDrGRz_QOp-MsN7Iu23G93ugL+Q{tW5^Az zsI=F7@EuuU3XaLmGZ-_$@3@AYZ-yKRtuupDW~q_^8xRgrCJCBL`k`bEI5Uv}DIgFf z<0`V;^6#d{(6~Fto7Go}+Ma%rd8tw(+}U!bs2bYhp{lMoJR9SgrD5IeBa=Y}QLPA} ziD3CckW40!z7YPA3F^Ny3dEfxzzM)F4`=JtK>nCQim6ZsIHy@#}e6ZWC4BWP)U0AU_|9g^t^xBAYe8|g$LN>meu%0zN*yX;K!{nB!D_!L?en63Gs2>N!+EB{ zf|02;SFl>-a!m&@zt?tfq+!uTW4MK}|9_DFWm)gg2rGR%5~5I!3mraF7dcMz8PqKI zcNI`b$?ckK4LS2mwH?cC6{65?s>OH8v(Ibsr83@>$s?vKSDAvo?{feBcx&|;cI1C8 zKEuu$)_ZF@@}g$nhYlyy?0e$jlA74}nH8n96*iAU_3^*WT7?sU!Uw-8=C^q5KN%Ai z0Gv8mMIO{Qm4ndks>6FN-UMbz`?rpJx}O#8o|$vP;lRFcwwEdBP%r(V-g9I@C3q%U z2Pj|qU~M+;ozu1g&?fDv>c-jp%x5ossn=Y1sMYRiREN)O&jdPHv^RZIJo~OLKZ~9% zo1-?=c-E{g@7KidthGah&R5`yYa$!`PTKyFhxMLJ`_&#dfx0|{lQ(5$9Q)mRJOjdE zc4kSIJ0wEgzC4{%tI8<1={4XsI2{jlb~#Zu~19&)^sTjypOC%~|DNumFC*^{rS^pA~Gy_qEev<7C3kkX!YeM;c6YtajzWEDL;puSn#a2zI#aIjA=}473l#Gwj z)9VyDa=Yn1H9RJ3o%@bgr)Ha$2!~7C^8Q&+)?Lrq%Up+^)wYeI(U%9?|ph~%G->)U`%tbHP zme_*QEpYQ@SyzAQ#V1G?df{uYoaKvHVbi;#Bgo7nQ6sTWV#)$!OEQ}r2r zc}=Jswn}!h=6JaRkWF;&{SV!nb`G58JHs)TD})K+)!iclv-dj%zPhS@2XC`VYG0#3 zZ9GNR;?y(oQu8ggW;EM)Jmc-n=jY`LukQ3rY{dwl`SQWi8#qtGL@&U9uI<^~irN0Q zWvPT`xgBafakPtGAN%bB$^ zZQF1sLDDhbYx75~5;#EQFOei-AcT@QVa`9~?;!*o`2qzn-2rG?R;#cz>yU{ z8TVP90;9a@ya8_#4mv^s#NPp$GrA#IpLl4W7-9OMVocj7e~cH; zDOi8fcm1Wuo;@(-diheMj#TwEKvvyn(imN`s+Qs?OI$0qYoh}K5rX17IbWiuS8@7G zbV4hZ&D=@6DSB-vhUU&-#o^kmYeWcmdpXwlD$U(N$EJZh2N@0Hb%s<&Bor`yj%8fn z93D$UW_P~d`Rsh3)&boquxXdS(|Gyw<-6S1pe4Q;LiI@raD>l)q-8ZB1Y-3}J<}N! ze2e^J@h$rkE3S^CaP4^S9H9qVkE`#Tg=EgT{?VIHUls4&!p`CynfXR{mXR9grLe&o z6jA&0QbK?&B-1H?Q<^>f(Yd8r8U;^s(knz%x;@x;p31QQj~+#Mz~VbOBQ-%Kb;_-4 z_(_*K7KL`yOu-}38)n&x9(4TE*yB6XqYJe&+C^WxP#bTp>Fr8Mw6gB9)9;r;TLeXQxd$kJLeI%rgs!EQ2MTU&(-R&(`C~hgyW809$!t{ zFgoE>&r5VDs^*tJ1-JTlF05$*(!J^X-MMCTKV(K9T|@VcZ`;;=qj%J{?i;-(-zfG9 z>h%#{3R%dV^W`SrDW3FG=y1Btuk=^M8jbl~mc-F>YB{<$-x1MKfmYiyyUx{2|D)3o zkqi0;5^;%cSi~_N_n^bFptp0*%kWuB7cIO3Jku+$Yj|Dg4g4l}(KncE5c&;UHdV4O zB|M4RycByUsLXPWUW6GbzRTF2kH_g!H51Q%)1vMt_VK}(tzFSX)ezllflVvTyDLVg z9x|5-%}@tIm(Ku5=T5gIdBpoN7H&L~eoWGh)JOPIcg^I^DkK*T`Gbx`lse=VL4ej# zrQJe-nk%h*Fa{|_W4brgT~GClE#z5^t!GNQkFDP+jy#Ta>$~-atRu!gj>e}0Pfmtk zRw7cW?zhcjr0zP@|7g2YY_hUTj%YgKECKsqDdi;G+&mIxM72Dk%?k?}!X!XH&$H?dR2mJ^YU8>c1 z-0_K(pNY&}N45TZwHjQ9DsHXrsHMF-hP$Cm%^7IMcY1J&3H75E4HrzNHTQ%Aoq9-xRXb3)9i zrf7hct;SxXxX)6|FnuVN_hgJh@_sbqMaPP!hPgGu=O0wtUux=^o~Qj%UA&zXUmd?g zFXnwU-#*0m=cS5qt(Q0tO*rHj{S|b6c6umm^LFsPG#T@~VryOQ%15S1-|op~i8s_~ zZE8;l^SbHI10ME?w}Xy7MWOq~T<7B1T1*OoDJ&<+ts#pGnHJh@Qdna{ zI|7S~eZ>qSHL?EU?d*BJY#F6I-o8Ev=GC3*w9Ub$bRa3+f-MaVMYdv$P{KygqG{TT1l2zDs@H!by!ek5kOxNfY+RJ;V*lNh3QI=TqR;~4;e_je*CiMGe4P~jLHr)O8+Kqj8(n=V`Hba*j zUFwn>JevK)gX(FONLS+;dK}%wXG>Y4j_f&45`?T^{qn)@9@MRLX-P_b1p?VS*L9JAk))o@z)#;}QOuimPW(3(@h3$W- zyU6Mq8~Sby3hg(3N3R`OOh-jp>Uk2+6m_NJDem=kS^PZiYIjF_9```HU*>p672WX7R6iMtc!nP`p9c__F)Cd;7~`UC_Cfd6MyUt(pCldS;O&5ZOliYYDh(ma3{g9lXR9 z^jWLoA9}DopIOo(o71GMdsU>?pX}BaJlT9L*68h7cxP83f=9V=Cq1_JtKBJzHR|@9 zZ{5j!c2Vd+NAH`j_Ia9n0LPA~zxfxghVsn!9o0J$FYW2MKZ{(Fr`lW2`>pedC&T-w zL;XC~9HBmUQp<<0esAB&T8Hi}MHj9p5)1oRtFI^*2Y$k*x$`^??ppSY-gOeRhxH{S zNzp&I!sYQZ zDOx$dtG)NEC-cdv6;ENO$-J(|`cb@(JJair77(+$eVR|b0lCswMj*T@G8Xpv4Yi^+ znSabL8T_2Ktym)p54sK$IJQZZXP#QI{&|P?QuhZC)19EEg`{+wymWzJUnZ+s@3n*pj;T%Xoz<`aGG{a{2yfyt3nEI2Ed!)u^-3Xi@zg3r!!@2dmH?@@#jY zj~$X-V`B|Z_Hdm+xl8xHB+~@ha9QpYs}}P zxBsRaKhvYYw;o@!Y?p&2v&u&{TzKjm=A?OryA4=3hyuc zgZDRPZTni&w>{5G2~UeVOZ|UP=)Xb9&A}TeJ?2|*NEb-}T-WkT-#6HcsksQPU7asU zYvN8;si?!FIlD_b48JdUxtluTAMBpsCL#+{Pm$xVu<~46nzQb#mQ_BDoHg-f>Um07P2Ov-wX&2NZXD$vd4JTV(I&+; zJjQU^Z!)G%jZo%vo#v4kg}PA!{7_RCciB~;^T=qbsYlgen=98$xZj)vvej}W*mW&4 zXS5PwX&kRhQyvWx;D|cnn9w&L%fhNW8usp1j?HYzz3s6UH}$(E&i*Z?(}wk$c>l0m zL4%K(QF5OuSsO{aZTO^pq|X;-riUG{CDkHRs9VNeS=BfRxYqo>uqK+%-8*ZoX?|7C z)v9<++}zmL;^rpwPxh`VldX-lCO+7H!w@%jy&;|{S4~3#$Yd0Jwa?u)zLK(~jJvy_ zP3vC+Tc+gM*5I^hJ7=`i7Mgmoz+0*zZc;2S6}+sJl{WO9QhD2u9`pEHV$VNbhwx;b z{A%=ISzs|f`2pI{w-m2!aFb5KHmwH-7hsVLk9KM1mg_go#TSI;&S5-%vYNvZf9d88A%V-qN^qj#;R+#g*!2Px;hd(F6$9dTE% zckLEQZPmjz0xiAk%VbJ-^~sivci(QmlyL-ByC8G z^S7vrwR+B83hgAm`mtsfDNm2>n(yxf zq=q~}Vt$voBEAKUOOjDZIC%}djo)qYa(5C1y7i+JhxVQ)N)PgRqHuAHs5nu=no>X3 zn+PR8sTuw-+e(tLtu~PFa@r5+)6Cj{?`64-JPEdv0zdm~H0{XlWFEAf=Q!=h^Q4pt zYgI}tiu0s6`Jy>Zt$g?OD4Kgh=S5P5l#1d#!L_DY<9FIs&4BuH(2+jNR8Cw6ex)^5@{HMaHE z;5DA2d~YZ~vWB|6mFJJ!ZU6fSXZ0BxrHj=%UqBzIGdsSO37^RBnayh&#navATa-$6 z@j6ApUHZc`+!dS;mNx#Ap=)d8o}9y85x`WT42SgkNG7^r^POGx3-AqS6BKJNolK9u zlRG2HzT5td?`-yc#^n!O#?F6Ysjj+*Y13p3KxK%!VF3l{=kLmk5DNBRzK*fHbHe0r^z&! zi0EX(K}5f&!%<=PNcs_SIs}rY-vAYnHF-Wrj(REH5J^>Hjw7EFD8?YTD)p?MWc$B;20Xs*cj&@M_IWgEPPG z^yxcugpz1efy0Yv=MRY5y+9wdk zioNq&gkH%I5&6k5bE9D7aGuECeyR1LnuE92KA*qxnerByQu@kEMG&^ye(3+8_UD=6 zG*kb)_Rrsu7E-_dg!fzC#6nBdcSIz!;6WfgF@{30jbUz6@Hq)ywdNjBf1(P&@lneA zOP%uG$u1*#Pn+!!?q81FHQiE9?vI0afdt4Y{f;!PX*)SSFg@on^TT`R=sVF18%b(C z&xq5k#Y`n4^!}x+Rs5viIhRy<2GmtKHI%dM@ub6(j{==>mMT(th^tixL488%cW7p< zztk{gf6ef+CZ}!dnusrUYs~$&y}}zl(&23TR)2~aM?m9Pl22FKPll#M27h-i&DoT;QpM?S^do0&m%h5GL!%%|2=W%;O7dN0*=OMF!R z!58qfcTCL!jJb%Pmy9Z`n3*?20Jg$&M>srm`(M271P#!+2-xDafX#w0F*xQswRlaN z7agx~-4;n)zN%2X;1wE}lEWeQ11`#7i~_Pnoh;rj*dIbE+K~5s9vLR)qD^{Guv~4Hi#n z4nPr^#c6fFr8EcT!uD=-W_KS65p*6t5@LdsQlP`5Q8V-Zq3!Me7;n!*VZ{53 zMiHa$9&d~ysR)mE@wUQK1%M)<$koADE3 zZ*#7Q8Vi@#vJ;czDUFpW{+g}i0B2f>>5vw^zw9~9#o1 z%$S+cR4tb2cS>q{4elJ) z;?wRfp5G@4QJ;^Guc=Kg9)(tp59{EkfxJuS z*t?wg?QtBg=-O+yw|eaNzARRCN-D~FsU{01zMGg1*T~G_cbxl5C9LqP-dC3`pIDdW zw@+Ow`rZAAx;($Z2merQ>+U{3Bv1h6zHQyaL%)K%8;TS7VA--|B*I5tJ9ojJeJQ@RM{uQ34#6K^!%lo^d`5caY zkMq9$cqYoUmz41}!K5`cL2o3twr;O}%tW{6m31g69y3-9#Us8nV zj+Nc>DN2z`sv8k9HgqgqQZo@KMU8(@-)FAhVwIp5#pppOl8V-gF(9w{wh{reso0;I zWt2eYa~C0Iv)N@1+^q1JL-i>+TPp#DeFjpC&M3<46rybu&vD35JjY>N|5+BXDi2)|zY7 zVWS|H=9=DkpQ>@EzQx(((~4Kce?hSv`QsGn8R|-HTF$k9s5c<2_OZfH#DH%E>%OSG*Q9XpiD|!11D#t zPjMNQ{)A%pyx*w|0GvI5w&5143U_%XmJw4!C7YhXsc)fnoK-Ovj7BtmLw`|xw@||? zD-P+Pa)L$!Drz<;K$d3(d0?tOuIGTWsYV#b292viYV%XZlN`g_t3q+Ua~iEEo{~tN zD;4Kkh5gK&dj;cBv8e%1s#-bjRA}pWRBxk3NAA2L2X(rppykN}!X`ZOi=>h(s5V!u za4LeGgcRH0Dq$3Yb|6_nolX3%x_ai6ly|5URk=Q;TK+t$oJTVMSdTxhgn6Zm2w?(Kc@I%)t6eXr-q_-on07Dk#1P0 z5p2#%iKiO$kZMA(c_ia%&8m(1)`ahr%tdZDk0Doy{CrGl@N7bo2ymx9e&!Z+B>#*& zb8_rDNZ9osDxS%m(-jrZW8>$S-15hoBGstj_|h(H#m<+ade`6s?X;#{2qeKvQT^Jw z&wc+6U{#(8Txw&4nkU}Q%rr(gTwlw0c^`8@T`n@V=nd?8erMxZ^|h_1Bx%*MgDiBe zHBnrPXLjqNJ?miO4JNjOYvBxX6=Xy0Pp0VqO2_?Al1Kx9aA#*ysFBx$?UGx^~LNo*B9^iOP9wK z`Rvp4L>~OmwWf^u${Z@QpWjhMfjnZ>ru4DBGkf1$`D#S{y;J+O4RZqDQs2|P&E%Pp zIr)_;>}8GNQ5JrDC)L}mF0~2@UsPp|v}0|8eDcoQl_ic$jVyR}mNdoA9#jmyqXS9) z_2M-OFg8wJ%}akgOT2;EU2l$h6}Ce=x)a{wt67!T1*!3|Vo~Ls5)}(-& zgtNI5o%T139Ca;10s(5<0OualI#AIy{1Skm^1IOt!)K{BhNWm^3J=SJ$eQlv%7EzW z)@hsayIap4GP=DRu`c~-kgx)x6vdG;uu9G$1kceFaa z$4u==fO+L}=khh+0n2-Wjs4Zc$2J#6ru(tv0NfaDrOcO-%{S!fs0oVvv0?{4gXU{! zw18%!83MFCUpsj$2R2TBMFPiFH+G8#^GYaLLw5|jyz#S%HF-Lpo< z_Gb^0&0T3DGQ5{MdDyx($-|y6mHKUD)pk3^hbY^l%4pvIxCU2rWpn#|>-&`W&b%{n zY_Zdo12$W}eP*UNP%%^Cf27K6c}Bfi?nt=V&0Aa7)=0@n&b#5;M|$|$cV3#Zvgc>C z!{51-mHjB_5x?WqRSMU{rrvIY7$==PUQ^ZnRdoYAvprs;aOSHPpD&Yo>Xnv~>-lWO zYjpXgsbY^AY~@D_Y^5grwl=e`W2NVVR!Q^qil~W!b(K{usmNO9PO_c1WE0uW_C3tM zXcBWNa;DEK9ac5hziqKB#a7MTqC4@sjP`z6Qt${P>OIeHwG{CA?B9*duGScMJKhC1 z-g@3^?c;T(Emn-Es}X|UPX6|OPkC~}X(>RyI8t*J-|5`^^`+4LXf()<_~h;XY!j>u zjngUs>x@=Oy`*R7rD%o{UT2ybE7=O0-4qRLplUu--i*&1IO$gU7v0QazbiODcovxyV7U_HNP!*4F(D3LbexwG3v`FxH&5tHZ&OOWquC zHuY+k8_#vNtL2%$Rg`U^N0eo-QmB}V;?}nofKUO0sf`e_b$43ir z?mqmxr#%nj&CkbIwo`im+OyOz)%ttq@}3}DpSM3xX5C|_3c}VlrLQ%EYLN&5;1+&v z>Ll0&&oR7Xa>=r+;+gHW5MBy6UGx|OgS}Rypi6zW?(LHnu+q`qJNNf2-{*Ul@3dV2 z%*1y230sf?v4(Sv&kNK zQ#>=T)z9y=mkWSCI%y5aQY>Lfq$zmP`(Mt47X0<4@T;FU7g#Wjzy)Md*5kyTQ{HPe z@05q4=^C*YiaUuIQ9y8tPrjgZN|BX~>>!C9U66$S*OUIC=1+U~Z2SAF$_q$$IwdpR z4GVcP8L27x;Cx4q{Xk;AeMJIb@SR#u-ayhD&ul%pLUP1>_ky*|Ot$(h58F{cr4_zD zk`F~bWF+?=Xdhm&=%SL*mu<8y8KnU8k8?@ayLsgbfOe;K{b-f|L# zKzaw6%1=g{oU~DnIR7{@y+m~q5c^9};+>u)(mP(SyYroE0v3#B4aI38hMYO+e>;CU zhuT0gNAhsH%r54B|2Q+HdiEdXCfBrzoG>j*G7_|jW30$lMFJP4UE_V+%J_v7$noXe zD9ZmG8LMrMn*i0-ZK)WzQ4x0Aq<$)<5;V8!A^hQzMLA5l}Sc35|E5> zc%=PQr@=8$GmjQ+VvGGh62BbJMa*`_3!S_pDZ|m}c;T=?V3}8z_e<9iNOT}F zqON-VS19r#Mi#zBB)toJM=c4zdW>7pco-&*fcHhw7JgXVhPq8LC54SemmH24%@s8!W zfC|sgbl?sbZJW*yiP@gc2zjR8PDd`*%=sa0 zxPJf%ia%9R6lwu`(fVqH3iK2~wI(Hhy+T5ChT~clMAe77+M4d9|3zMt2j``ho=L}x zN57-PTPyxD&sr}(c03aBRcmwtmPl#m*G|OKbJI#9hxU@a7A{ruS`Ug$o-5}%h_z7N zcV5oWzNi$abosho>U(V(jWl-2_)#B!Nbz0HNeS*-?)(sZx}1{|J7H({s~vONcH*@5 zCn?R7QB5@$;JaSg(uF#LPA0%EXT9{{j?KXfzmAZE+zys!u^fsV5m|IyI2A>QVh8_U z$6#;H2r80o?%ez2`cgsEWvPH%+N&`~n|1<7sqwqw-T-6fPA~m{T@ zcIgT!bezW&(u-aT&3Eqdj!1YD)I{~inNqPUpHKJd`(;xZR*aVJ)o?Ri*PxEFkwUU` z|8BnPsg!2cGv6-XR}l(a&%Ve_RNL?D3Vs}&(|1Z&RS(g~OcKZZ)Z>VrzcEiI5jq>F z{j#l@(JGIj=a=Mi`lTJu@1s1T!wSB5uYzu)??kM;dQ!Zy+UT#n7&UfCcD~)U?z%kc zb72Xjju__2nb}C4E&+-Ucl!UzUhcwi!BFjj6u?mJ*@YoyTbZb!whA<_R#s4T;ZzXy z?0(#kYEL4;c92<%*V>4u^IctKH*_+%FUu{JY`*bH1%S~O2{YV#T=>h6p z`%5N^+yqT|l)~w6O5=zeBk5LKc{RZ!iP|5Uz&2iH*U1$5IMsa6g!cbAZJP2LIbV2t zZ@%-Hd7_w7T!(ssKK#D&&adC6_zd|!UGYoMIy-qLxg%qIvN~B8)u#Ad0-v)_cOF0j z#M@Ow+7(GAYpRc5JCkrukPW2F3wB6*te?__p}ks3ONqxSE$!B!@dn@PJo5;DMcZ!M z`V&~2Ej2CY{B*UHXxrKp*+H?>$fZ$yypz$jyhEKC)l<`Ga_w~C(KOYPA)9?oQA0AS zx}sxEP9VwAs^dTQ){78|Y;N1qm=UpiV+_Z4lBv}D_Zl*Nym*#9vzVrSS9Fb2gKQ+e zx{2bn36x6Y82Fir8gkBe*@&FwJzhi*Yj&*8A zTiSOu_kQo()|-FBljA3nJ&X-~>l<6$c z-46xAB>FB{RL_&=`H(-jcef#ZKJ%T_Z?c-Kqu$+`(&yGrgvSm>=(fH+L^WyVMg=wUtkj+c)-27AWz8ySvd$+Weog(JrgnN0YTHykT|34qg;vX*{U11rz4~|kT{GT*UOBO6#CcPBandAz8zCoSWd10h4~>ZotX_?T8E2YK z)H!_ud@vrdSEt;HT`{Sdr|l!e$E`7eRtU#}fXImx^DDn6Ht0O&^eV)~a?A<8jGjW* zWsE?)UxB?T-B~I?ASr6KL0}xZ7I$u+0Fj$U(X9}0Ctfq12XlEJ#5MeT>HtsHRaepU zoM~JBR!t*2bY$h${q8}1q)vFcab)S(O`pKAI(I!}D=prOTlcf2AzxS=32MF_Kx_q4$nqDl?Du zo6nEB717Wk3l0d9v0SUkwI&bk9pPB6{|qj~o2IP6vE0-3j@NzPB`e3uo>n>At~b>& z=gwG~?Wjzhn(dXflk;&6>(Pt`*DGspKK|YPmWl6Dxtu!K=p}q9x@`?8jp5Oq@jg|w z&f;3sn0u;Z&H_PUzd38QuiHDa#7XaBYwrJStTp%@q8pzsQS})o|1KitS%jj#`<)Z&GAW#^-SpGQ4%?Q zZ=2M|ORe#~eR{XV`mN7y`GtRE0}u88e5vpuZ_g7RLGzEg+lHi61|y!mNe@{?9Ov+z z!G(CfWMxn72~#_%`@UoU85F+C*z?lrOl^0?jW;ZN;o{n_*{XOXkq9++0e-(&QSrT! zGlTC%Az{bsOGIuGDEFP}A~WP^tIa3a+S#pXC|*$osN-+ZwJB_H5+4LK9?z8A#2@Na z(zo3GGOPWXckfR55d<)}90%oylhHGH?Bkv%<-ccM9tV1CaWb|%H6J=)o%emporOCCTWE z6sLiz4muhVRjr&N^ox=oc_>#IPcAwW2lMdwo|BDM$@0dK6-&zBxI%6$G@GDw zZbXctr&fKkx*EG^bf0#vpq4%E3hMTbN$BK52>xT(YtmHr&6pyZfd6W{rns~(hm^utm+5Up9}wGir*DeVkps?nho?x)gD~;N3<`U;Di#e}_zA%Mm>0Xkff=7QY=! zFFfDJ+UGp^)o}JamK;%u_;_{k$+PEq=8|-vr%%&b|K>5D=wRZ?IlV)uen#VrFI^sQ zQPhJIg)Tz&GHOQqN*PY~A$EaRNp{|P>~EskDs&_f8lNX)KoEJ15?F3 zYy|~34|~F+dNsXGmlIZcyW?7F^ufQ11LF}iCHZSgn(~qaQW(t76fA(>KB;0>{8%OD zmkRERul{8&@b^d_u44%p`|end#~Y7z3uNl%T?5M6(HY3*CZax_%)ax6d?iD>}V->ZmiS4-y zck0cvz3=09Lg=2#W7ySxn)BB6BDWds6s{7r!U_%FS;8KzqWEgh_0F?kowVM%>Xv)T zm9=e?1^4dM=yy=amDqL5d{=xz>eY2_l7yTqEG}Hc#_DG74at@lJ=|)mqV^xOU zXJ5w*ikY7?Yl_G5+xtguq~70q{*H5KAJ27wZ)a4HZ(%;W#(*CrK(rt4h^R+ZO_1O| zl2U~E;L%magr6dR!ciXZr1R2aZ+g^=qb(fQTE}<7FGM}hr(0fAAfNttK|L?`9P>+D zlXq3U?3z*zE;SSb_^ry`@n=OAPWt;|<&}+u4G)I$U}n-!7|l>PS(QcQxHWy!lm#-B zM|zq7aX^m0eamsDq=TO#={{%@*z9ejhuV50K1UfiM6_ON%KEvAS{%lA7(k6AW(6#iB}1<%a?rNouK{j`wZ9FRmTciRmdD zZ1kkY`@a1s9|Y>hF3W|zBqQxocb(K=G{;n3`4@KmE(My;YTDW6vWJgx;> zML8hHzl+$vY6x`An93`0wl~*K)^rJqsH*v2QqAxCvARzZXf5N6U(R34^^5y+O<4n` zlx4VP=9zR+%J4BK^ce5e)Rrs+YW-H?L^n}Gm48#e18w^5*Y$J#qW0*n=F%k|`e5Pj zVtoB8*LHEf(H-w*?WN=SPM!Ov&gYq4Up*!2`A$$Cq3#4l{z~dib)UQhJ8{(GDbJ5J zIG{1CWt8A7MX(_cO$H`FHR3$Et zH#lEe{GKPB;Jbb?op=2)PxethnRwRkSXAXHhjuOJ(ga^B*7nHnw6?FsUX#v1J3K)i zRa#nYa)sn;mV|Pql3FA~B>> zb?sso-~EOoN@k7B+X^0mjO$BvT?>xkWRxUP>y%3^VT2FutjNgWM1^}*Z)Wb*9^8+w z#mdWLU6ix7sj@@@RoAfH-Kw2+sVymUs2AM9Kjp0~G^I0aOIsw%W@i@4)=ma@98NpR zve}XVQ~?%!b<_*$JQqBgGjJFmkQ0nukj$310?aZufxaMcwyI_t!FT%3(Nfx1S#N8( zj&hBZaA0DX>s3uGdG{N-_Nx_CU|804)=9i$IzOf8tdFb@Szb#POhs3fRv-vQYZHP< zMMJ58V=QI2skMhsHvmmI&#LwdJSmXbm{DD0^zqg5H!k@l$oLW5T@}#br6yT5>}2KU zY@Gy=iKVQ{Egvz!8JkQUMJ}Y(Uh3$SD7uDbad!)7<$}Vi0v6FHPX-M?PnCr2V zl^qEhz1)DV8%4giYNOO+I0Ea(n*qE%J-3ZJhd$4#!zhp}A03t(-Wyo8#Jt z@8qA_nLo9WVkO>CB_|^{=J5#<8A~O3>jbsMKUC1Ro+mQ%Vyao%e!2o6Ut70)C2s~U zq!N}>@HgyNa$MN+WVI~SXOPFTwzEtg{ zpR8m$v3`*qQM?1mQDTiEizDs7n5F978NaKZ&*%`KSc@#vUv|W{{TKZTcAl(n9>-EP zIC&gMF|t7v1Tjwi+Qz=OM16Bgki`Airv2o2pu_cJdt~T$@G`j}>(%JM_E#v(xgprs zAn$XU&^>_J9*?z4GDSEeqGnSX9U2y00MLy_N!jpbb)e^uqSf85tu61$kLvfelC`{O z{X=GOHB zIM#ID2ELp4>gn@}I#=&iF!En67^%re&df5`mp7+F;jTK+&x^A-7<<&tuH=H>>KU7@ zG1rKmwBlx--EC*x=~~~KROV?G%k%hMv8Ek$iODgMgYcxjeu842R??H^7 zGgvdDfJ|8EdM45#sv;lnme1Qac@*hmitLD#D%9NWSG!c`#!?#0dbp6fR=y1Ec{E+n z^wEhyqDOo7HR({Z`(&#lt5uPcpxbkH@^;U)s$`H%O0{k4$BvaZtD?VBY#u+AypiWg zyJBv0I#kQ|M`fp0zNxbF;}am?!(72GQ05^Ou;z-HR)#W4@Y_uCOHS^Wnf|r${%)%p zZDIoyzoAR|bzQ@*=qs~L*k@#$AbY2B^?3u?L-NO8${wYXi200Rp^K%*d$4rNZymoh!9pb;;22n3P+yg^IL>e;3!LWmA0F{Kw49Jk54u&u`Ui zEcSq`6K%bm?d3CyYv{{OzeA^rtc~@FE#);uR9~vr@0~HeWu2d=d?b~QF-vLkJCJwe zgduMi8Qg4Ft38L(l`C9gx5=$yFf;i1U z`o|L8)pqG`2!y+PhGR_KR&ub9EDgppYJu!?w>S}i1PnEPbXvGcMeaS`bNJ!MHm>;n8hl_$vs5~75S8Lvd{S; zb}qSfsxl5FsZKT0@?E7C<}cMU_v8tRyp$`qv@rtXV+0jZeMyef^*+VJ zPgkCX_~3x8tX-xwtV>;u@{sG2RE$VC6K4rmgQt-B!W*_xMB+QQ#vsq8n!@K8=o=rh zw?B{bQ2u_{rNCMKdkmNA%b5vXkR3&jPAWVu{Q*lNRQfKck4hg5!GKiyS)5}O;=5PR zb|%KvqRuiV%oO!JFE!mmKJH9}n5OxR7`OBYtwW`^#%V?$iB+k_i@7J_sT%Du7d%3a zhOwfbkJo1m6$9WMkYmYIAuQWQ3k%ePSkFzAY-cJSvI|(FX zIJ>Lg{ME1|$Sd6?l;RgX<#)_)+liSX&~bN|Kj3%_b6VA%_uM{vfX=l^nKAy6Sz4C~==&SxbFL#}kBs&pY z&hgu0ez%_zoUp&W>5u%0G%zQzZO~iq4s{MAM+JKSP8kU9EQTl&@zMKkWB&~D%t=7 z@;P73<8!{qD2MzF*`_+gFU2ZV;c6_MVB`(N=$CPui)L+-B{5P0f$4l?iG$q1so~$z zi(Y*vZrV=1)m!=y{PJoBkY!45OK2*okIywsDQ8GrO8uRrL|+PcaG&*BC9=dgf?c%5$b`Zu6Ms1#ZnwzkbX|%;| zRpab9-SoTo79q;{?Wzx^8PAcwqNet@buIWn9z;-4q?}i^$-LBWo)z#f&NALcFL~Ay zT|L{8*O-~($ZM4(>2IX>5ZetFN8>XF1m~i_X=Cm`ze^+#_Sx2*L$eKL2pU4w8xE)2 z^Otdqk7|k{gS5Oke&;1#UTQ?}pG6ge+i-Sx&=*}E-wc~`u6w&aS= zS)=L(P>qoQ;6a?>Ug>M+`vjjEXY!Ni#GJyQ8Xwi?_TuvzoCBYNioBv9fE+P&);u$j zBa|o{_z0T$q4+HlHKLTtBjltbev5Vu;>6EdPFJ*nlkcTsyz+ITyYywfrs^8=6rIHt z$Ac>bGkvM8Yw{`jVVhhEWgh4N0j;Hd<>@lzX0(cf`EUPRs-8I5C6A+6l-BaZSDq z|BgI`?L9a2zRzjaw`cItmpv`_M_=Y;M%1=f<)j|s$J%uf2TolH zd;~P;st7f^06goaH++zug0jFVEd1<{lgBvN zwn9eiL37h+zOxm_$7AI++7B1fQ63F%DF5gv%0;vsSwBXeW+U+s&^ZR@rK|^2-M#1W zNo>6#Mg%?qZvcl`{?b#7;xJ{!PTe_V3xoFnK_Ag?=9x=OeWteHo`0IM-7r zO?=s~K1ntJdo@P;?$s3(`p<9JI4UahxggjQ?<`Z~Eua~a(;&PO&O{ZQT8mRrskLGi zs#<>*+*H`D!_j$jjDQ$F*Y-}ER&XHZA3=UvH=5Wd^8J%VfGi}#0Nsdq{K@PCR*A0h zSUGX6c_yCuQj#41?>k?+Z8q;m5V6r5Vnod=e~7ui+MWQA>?;zqjkQhX26RFGf=`W= zLr-@k_%E^gkvpU%vb3DIMnzUhUEoYha{)1VO6MSUzF%8^PD?Q`sFC4IxD5~dGc&G! zz%5_a%v$+Ur@vG&&NI|+{{E$WHni*YTQMC-@QolOk>WVD|1 znttp^gowmepHlRs`zg!5so=tC8zitqruF`q3nYN5kk<6MyUR;W zXCr)kJ}dQEvKZJAMPG)bjPWh|yoauNw`hDHi%Wqi>j$7s9I`ahuhL(%5bs<#2IQ8c z0`uh9Y9vhvZjW2A^$nPu3Xtkj5} z#WSOSqIgR5vd&zO=+V40ANf%~k`^sauR|4kGbo$b9QfQ@H4BQIuYIp2w=kk=O-)tB?m?j%1eW97P& zI;vQQ<#=Xvncl9-i)YHl*-|y|_V4z`___Z!6XhNI$u{!LOIaDYp4qc^O*gTBD~gj^ z?!-$TI?voCxsGe3<(N|Op)1P74223;mGGDCOqM_OHvQ{p$v*7vSKO7`9^WaMth}Au zU$>Cy-qrP3`Em3Ce#ooqLCp^(UG}9m8S*6?9Q#_$YhBIf>z9fzYkyp^{I8=uu2;Sv zPZb`A27Y3w`eqQ&*|V2=^E0E}aaNc8={fp8 zR&!*fZF9{b{ics&_;gZ!vYz!)YrIs+`sk{b)W!J((P+ATDRSp&E$ur;P-GB9d*!!I z{s+m9hgI3Y(OSBs9HbpMsc-ck(xz_b8`D0TOhlSOlNBCKRiDg|m_bcRlxV+IQrfJb zs7CrzMDTwbQ7e}0(T=LPek_{#WGzdy5X;Qj7%f!`jOaMK=x)QhojrR0)RYr6Mu$U! zua`$eV|zv$?Xl%|-r->X@8heP{d;GyrgXcr+gz&`4WF{EIGS9)^<1L5Dzl634E`K` z3RJZI;&(L8riNkqT2VcDw1*~-R%%*nt_zR%Q4u3xf>vD@?%zF{m-#+Lhj44op?N;v zS;RffD;8tuKDFaJyZJiWmJZi%#kUM+_tD~-YtcG6_XEwaPgYIS9@yFi-2ypfT2_p% z;TA(w71Le{tb}MeOt!J!P9;BWx?{z(aIO&36tv-ML3P)NM%yACHkz~l%vt!{m1RX6 zW9q(W$7x;at&(zUyz`~r3S8PGQBM`Es9zaE@4%hSWZ&GoMkhfMR$J!3-^nsXv%iyE zUflXRGER@%0mtm>TO!MTxqe@0BNi$3E)glOY%lRI|?0-$Fun&w3^rb5aQuGqGG9@~7yL|27j; zped93QboFHz~_OBL#rdQBPHF&2;^Aw2|A0*r7ueOUA2`(l6tlU)_fP%9|H@g*qmA_wx(u?Q zZ(DpJQPQf5opX#xu{AHQ{+}@->T;rqPBD&0*NDjCj``FU1vGL{Ikx{eyW`(RB#68i z!x3oYE9>aBhb}dTE9?LuqrMNQGI-u#oDhu~P*tj#4Syy+d!f<1JFchtor#$< zLDMkXzG^1%*4qQc82Q(__GE1%ZGkL>Un(FuOV%ihdif=QOMA*l0YICRXLa=(&~M03 zH?P>qgY!N6r=cIo;s*NBrv;r9IafTNfS|uPNzIU)wzcOl{zbfDc!$SmhpUVGGR&uK zCjr<}=agIkWE@ma=upX!rfcD6n7-x;#TfvL)M~|3616B`6Q@s-fVNxK@`7Jh;ynCt z_RnpbIo^IUD}D-mQKu6Sj#Rq^V`lA3Y_-QyKQ?S?2{GlVLBzlk;U^ZLcyGqRP`$%r zIjZYFV;Pg`dM5S!FYH^x5$S3-iuJSdrR%HlEX1NdMmmWKeKR(3a1u4^E+DaWdl--?-l%-}$HU=YQh@ zgz8ENAS~#aB`(whw3S{eiYuSbpJ^|Eiy3Cl;7Xi9-~gV_qr2<9nl@0&dL+9{(1}*= z{&Mn~%croJi=RTZ2c;B9lp@!hs{l(bzo|qeV!^rdc|UL$mj&%S!+)81s&#n7*5|@f zAnFuN0d=^*Epg_Q*L{jt6V)B)WsY4Jgk=TW(WZ25LjO{~c>UgKg}vEh^*svk0dCGQ zluN3Ihe6HkA8a^Y8u}H*a{VSh68FZRlQeUP!FGYJJG0M zQ+zsX1f=&{p6;Dvs(1q#%c!K1&wjv>wX+lk{1?>8^PcFq8(4lEA^v&yIkx2%;k7tP zsKjf9}Vpat8dU$rC8~}9pv1MNBfr2N>Ux4TN4ByME8Si`X3!k9y ziN_Au$-9@L(jC4&uEqY-2>rj!#3`2EU8yU`>j<`0Yn%~8uih&Zbr@4rDVxY1D7>}= z4AEw4rXpImp{p)C?sQ|I5q>T&UmM*uQxUP92qrfC`l8A!-A@1d{7+UGp5kD%cfe`h z4+K3OF)Dvip5&c#s&^_>c~_cBFGQ?s-ZHJ9inN%|$Mua}r6>5TB2nk@rlb(%6SGm_ zfF<-vk3|7&1rMtTFvnu;r5`_QrzjNKmh(mFBotl3F z+&=UV=h$#q6+}4_nu#2Isr^aKwM;&Vm__P*|IBB4>q(jJ61XI8-~r)V5M3mJp7h!h z)D7x!*;a_{?bIrs(x3EZx8g7^!tsV1UE#|puv@J^l*RFz8gr`@6dbwnqz(C+(EKc<#CSReUn%wIXg^#;cmTbEOZygC#6&rau|uYZ~8^ zcEF{u3hp|T=VN(ys-uLeaj7>3)=PR-;?81E_bvM{((a>Yrq}(>3w^j1z3L^=POf|@ ziCT1LsU!y0qc5{>v<77qL*0oih|!)8g3^EHiIO-)H|2?5+ltFv3cF+L8XD(azmk6M zyM9HwqD+(i=3U(M8LGeJ^}AF{k6EYsO8_CgBoQeRs=-R7ib>GvByj&i9Dei=q_75vo>nEF{ zJ2N2U?xiq~FSpjT&hFc5HFCt=)3sV+-VxQ}JE1@*xbsUTG%r21?u!n zqiC9Wn6{~6pL7q9Nvr$?^!KguL^YkhRS7z#q`^ZqqUznr19j(9TJigWs(xk!C}mzX zK7zQfzO4OuPk?`&YdIpzbVPb=r+WrMGG);2ShBZ zdsTu`os49(c zNI$E~vBnZBiZuC}>hxafau4w2AahnJ67*25N`$6s zD*JD2f6FiaGjJ<`Cs*qyr!h@g!X%K5;{>u++(4>P+6#te9sV6_yFSnCZo?UgQq6J0 zrzKAiQ>;WriW3}(DYnlw?YNpP4$I6`LA3^VVja;{AnVl@F3yfA>bzs`9xW}SJlDU( zl4W^wa?S0pK8pN|&sVE*o|H|ZLRH7^B%v}XQXyjomuHX`Zn2tjn@=s3$3FitcKO6> z#wq7at|OvZm!sTqO`kipDeK8+o=l~iGZX9D`(+Zpb2+h&c5=+_QY4LUaRWI~WoC5F zp#N}PcSMYJUy4P>`pG#)v<%rZbu6Jkg06`g3I-|780d}*{KAyezHGD!(K#pXF1u*VyM)4=v^>1SPqB;UQUuqhRudOu zP{pu$ac2UWHtCV$P3)Yv{gYsN*+htRsF z!(B~!7T5gMZzR+WawK2MNvg#z-XAK1ZJb<0Ubl8C#^j@w=6&p=7pyiU?Xsa6Y1o+m z%`5ibcQL8*^#k7=yF;dPd|9SngqEH$;qSHMeMFcAO>U)Q!uts1(3;?PkEAI7%h-#v^X1S~1p=-npYOCQE+0*k9W0;o0 zRoA$)D%x4JA7Xa3?KyAvvTidJ34J67!)d{3uSVhY>#d|dZ)=>vOYkSjP+a?MchHl! z0?>ZUOA$rXzAf6?^Z>?6KFAOX|D-Ia{N=yLY_u)VX^93_2}k<%QsM&QCMOB;Mowl^ z({Ot5OB81o+ZMzyu~3Lw7HM)nMf`^S6A^(MwstA_j6$x2(O}L>%XnjbTX|e5A0_6ErcCsedE+?jlx2Y)J7<1MPT)~}P<*j%R96?>y6{Ga^Sh8PgOWTe+ zo6oqtzf?q;k}99yJ&s{+>GMO^240Sl@y!Z&XSLKgiUPm-gd@b|C~C>RO-Kt{ApoT4 znWq>M#okb2wAeD|cziEtBX%Q&=}mB7z+}WZR$ZPP`h5K>*I{HNTQd3djAT~;PwVGA zika6AU>(?TKV)1-eC5iJuDFc0uL3z8WH_~G>?OUSb-$FNUPNM4&X<&C9`RI*@5C=P z-nfiBo*k4r72=Dn$I;h%%-GMtA06Z}H>f>30lVh|x z3gB|j%j22o%X{piB)<;nqq#}_R?0zCK*nbg)YU!O+jOZ+DI+vm_m6#12;wa6` z9fxwM7j=|w*}i#AnFyHwbtsyYwjoc!4(H1_J7T5NXBAKBUyiJ)55`xc*C|H=2TJX_ zCP$B^prf#A&>h#R$3A^p+)M;H7`$_E$*Q!sxQQ-^pH!z9KQXjG<}_DVJ`9xMguPV?aYX8UsG07{jr*Fz!5-V3)7yiv~yb zJRdG!)1ytARZ!wHo(V_Z^=rpmcXSO;Y0O#5y88xyXRuo*CWYi9mSqYZY-+UVX9But z!``h}hhfjx`mScL_Br0Y*~`Z> zbSZpY@k}YYigyHsA9KFfV#~zubTZ$0>72fb)KiOCLxsB(mT9bCvqZUT)L*GFg5vDI zGvB*^7vD1MbG+Qshdo&LJfa$~DzexyR-Q9$X%XF- znAP8MM?0(GK<sWBgWYL+NqMDD!IC*{Nm z3NGLp(U!}}rkcL`u@f?Y$IQSFF1N z)0~@hyOU|s9r1fK+60A((Jt$e+-Y9o&i!(av>@dSU22GW^uE{~;(5CHm95`R?}xkN zrW`~v(mGK~EX6r;=Zu`Ca>S83xn!tZ3h5T#*}YTaDd}-3?Y&m~OlJ2=MQTuy!qk%1 zDEp0XA)3_RRq392&grIWZ=|==gV5KOIqT63+P?jPvp^DLKdkB#=+5=3xpP`jaQW0V z^vEksm!t-}gN}Uy3-2K2$ z7e`d?ybyha2Y2$s<zh zEXA4o&NxDRXL=oCmc}P)+21(V-S56r`(cl-CQjcu_OzpA!%xA=nx8kY(y8-Jy#cu! zt1`WdV|J(Yka*v8Y01c9Z8dJLro#}kt1SN@7uP(;(gosQZZ-1eM$S> z$0ter?l?LZGkEN!ikaV**Z0iX+qU*ES_##T$}PMUvH92!WZy(2=2GNiKKim<99z1S zvkm^f^JK2(ead-!qTk;g`87&R)_?x$Q*1@v89c=vv&*g21~T(hUNZBi*dxz1)*-G{ zufyH_FLl@bq#hY#cr$bU`xpkbLM1{|AL{QHT?+5{-<%v&=Dv=n8@lnCL6O<9dr%SM z3$tZV;iPQkOOfXhZy;MF&eZX=-2E%4(6eG!4eGf{e8hOFBLJra6+999_EOwg?wy)z zIj0Am&&t$Oioa})pa7MO(H7fB^8`iC*Dj*)-aUCu+OK~nt1hTv`7)mJ(U8VdKHAKO z+8=8E5{K<)+akL1NlBlgP47~csBALqI2ka4G&rN_AyL-T?L-!$|1O=BjM zrlsaXcm1&V;wjDg{1o>vyFd8rl3S0sXQW+xg6jIRN1Tkecbu0h;JxYgR)jxUTSEsB-QmT#3p{oKO5z-#c+3cN!|PJ&mD9mlm0U3 zNGAC?O2%I9o~C+D_R6JZYI&oiy>eH&H1F{ET{BPIu@|K+O1rq!%B;Xq5}ftQrjkD*sDD!BLv@DHfko>5)#UM2bIaoO# zg7rsztY2?kTQ$$W`q=usGvU~E=r(!h@C>3+-_iOFp=RgXhemWV6XD6(m1R0e!&aDc zlSkz)Z6&+GrM{XN6QTLjz4Nvr(%anOVioa&A7Nl$jRQux3xz+rK({FeWa_t zY`V+yQLByHKf%vb@1+w~Y@O<-a%jV$zCq`4+XlXq_6zr#H2P?!(Suss4HrDxMF;w9 zqY$0PlZuYz+}YGYoTsRpf%5yR92I{1QjZJTzzQ&m9@>>Y>+0)V-IrUVrF**c^ty7E z;?C)Q*F((^=ql~@2iaq~x+{2Io4PjjJ9=nGy9ISYVCIE~R%M4&VPaNg^i_J(AGK7c zKl^#qxIkU(;TNG4RAoWZKqBW%-N3e*^3a!ihq$V8pc1H4@)) zTfbL#FAs)p>aVR9VM-sbvXH7=1s?lW|G2{v=Um@mZn~_823lo2C&g&FbBjOq5&M|S z`CN7fpG!Y)H}Zy)^?{|ipSPKvIiuU_R$C)q+h(HRNR~rgVwE-PH|%W0J~d3H^)B(A zzO!l2J-_RV!bYQYE& z%Cp?mC_2bO z8K0$o8_|?vi4(?4QF9bkWE4pN)}`na0##03JSs?8(gV$tMGd)u7%bhg9_PWVLB)3t zOMcu1yIAs*Oz3q{E?WgRvP{cfoFg>Fp_9dU^j;LAtvbu&>8-h`6qA8E?$t<6yE|^eD_$g{(pMgE(uNRoomet&_Ih0B|19 zWG9nQ8;ADuQE{s7W6}ZM?hA4JQnoB*k%Y84tpkwGABv<(s8P2GXK}zkDxC=B zblY$Zb#%K(I}YmY^6{Yq{--{Bbm2fXh|-Py7X}5T8`Z&tZPg&gyHjl-xYmP;Z<8gl zNvk{7v10Vv*DgCk?Ni-}I%ZVL{!F!hTx;&F5%Wv1QVq^QVpDl=b#D~DECYS9W+e;q zrBQA<2I37R3n15*if0z5WXF2u@6be-3OS~p$qI5Oa~9l0$^Z5n0Jd0qN^tM-moXDf zdN9S%@dgsO)J6{c%|_$6^ILywAVw<1eN9FZ5WS7&Vmg-uY2tm|q@W^=UMkQ%icXO1 zqk?SWT5uESENW3kV6$O{f$mW?7sa3{%o=Dg%x}D*`5GN9I0*t3q}#HHE-sSplvS!r zh9yTEZtE7`nKCB&g{a{sa=A_Gth2fAhh_asbtvg(e_F@zKUPW2Dv_}5SOW_DnPbfq zit{tZdpst3Z?v8|bAPP=(YFFkF*+m^%jxLWP^|4nkBPUD+>SmHj~dBE&xh((d~~tE z+MWNPqSuE!1hSdqDWU>PrRWrtcG6|lk%Z9ULY0QA_r|4$Muf%AwRoQ@sN1o965MpG zc`s44zoVN7t?}F=L>4r6Vi(8i=FA6f&9PlfzY;g}`+N%>QRG$O)MZ5IG3r+ydQ5kZ zkV-kP@`tNCe>Cr;pyZSx*si?XOGR&y;dA{@wZ{MJ|NcKO_5ZZ-)Orw5V#Tbk48JQ# zv%xI@eHscP-yiAIU}P%JS1EXX)S#NqR1as3q@g^%)<;VJS}$c=zr^9#q|b5+Z<>_u zSN=Tig>yM(<{k*Yky4<#^q(2IEUhm$*$vLtdeU@Ys7W(WBI<@wX^t>xWLw-x;*O6d z2Lu1spJSu``%0)ML_Nu$S%TfHbGUB+qJ*cpXT)b`#cHv;>v($ z8oQ$cgMhP;grZ5a)ov_}Eol*``^R?OZ0|J{x0qVS{MfHGI#UMlzO8eKH>{nflzP}! zQh_GEvGU`7y$CBcHI%8=y{4pJyOV(0q@uk{bW`!O`Vm-{5gy6+OJ|F`dctaD<9PV6sQsD5#u3OVKpIa@+k^^3r za|%F2yf6T@TE_0bXrNHv4gvg*HZRX><>}b5KWzU)mk{INSq6E-n$)g-ia}Lt+Jgc; zw1nT)UNzv4TYA;=ciGmkoYX8f`bqblPqwyADxZlZem=ij|DdvoBR1yqe)Z0#Hteex zUBA9)_fQ~O#QOa?3f;f+GR|Q|j~+ZtHhNo!=#FP8UQ%)P=6ZnClLO9@~RL_tRX_9K`{SAT1&>gmhi$b$2AH&pr6mSQ;_A3Z3eVxM%<#|-q7spJhu&d{^ zJiior+MjkS`ggu7(^g)5>9p)`!fYlI8)H(i7W`qQ1QNmR_WvtGT6ON|iQV>!GXG1r zgbP&frg@siq$buIbHPrY#=u_MkuewV9vHe-a}Shiu83>R910>fs|4ybQLoDfLcKO; zmu^iZW@7jn6kGw8HE%eYGx!dyg*Wos9p88n6gXMCv8?gzQsZBZz?~G=91%|(2G-#R zK2V{xN1@!Es$L+yqT{Ig?4|CmGX+ZY{Hc)0wjiNEbYg9@HFEx5QXYW zAR-C{E`xVLEk3)a?!;OdLIAMF1I9r2IooUX?|!l@x_~FEj6JXsF4cr25MQc_B_(!Y z$#tdeV5xScv|b7Xf+JgP=$Yp;rk+_8=lz||jM}|JKm=e<@H=7{b-dql{Jt^YweI!> z8do5_H(lvP`Aqiw7QVyq*&28Y!~63Q8Uk_z!~@5Lr?3&umtxNc+C%P%z)e`66S~)w z_JQlM9XpFJ+y3hKvST?NW0&WgGqGk|?N6g+|AP;X&LyGlRD5NsQ?JAdRe^>-et~DP z)8DsZg!oM3Da(BSB1%|NDz&-Ffa-NPt`^T6))xL0{o$X!*1r{z`S+O0h}eFqq1axk zt)PaeznP^7jk>5Zx3rLsMHR$F4)ro(ixuH{U+VAWDnkA)qg}iFQh!fS8KM7`7K!VZ z`g_$%i!6XL!muuF=nWw|N()h2dZ>t{#aU4L*0ng)i@K+l9^Qr09xsQ&ggn3@%>?-o0=1?Nl;!a2mb7`1-Quxlx46o1q`1`&YR!0#Ydr{eD zQ8(|hBEnJR|1Ya)BEua}6?g8%ohgJXF}TXk zsw7s_@Du(F_oPp_Qa+-dl*~cZpEn#H4Ft87RPlp~y$d+KDn?xLk5%#Gl3H9Pxu=!G z`|#5NQt-8!JE8(MZZwamKp0znOvT=<$G;1?h0w3Spc}PnD^SGNG!}M?K3eielcgwT zPxY-*oVfMMQ_w`UIErFYI=@m9G^q0=6??8v#zI_;QY1meSZH=$6=CdoLRQ7c`eEjg z4HOEg6a;Rg^1kG=HuSX_oN1#myZI@N0u|b@ZNQ%)i&|3o4d}W<^Fo}G7SUCbQ9D3! z%ArvsC&y;p(Ss@O5FD9r5YJ;jQ|djanBB?j_5}Y1^&lWZYE8bc<5Qo7{Xk5HcFteO zuz>2eoSFQ3tg6wOH82K4e1{b|vnXB`N(2J&TG4h=pZ5|((?N1lSgKY8co znVe?hAUd(Nai>?smMKwD6$_=* zQziE<W@oo~qHXhRYdOH_NHYaKLBw4b4ag1Eq_e>2{A&%kuqRMM*Byb4w!PEe^w zUvc5)Sr&ID)GDYDHRy$vzTiRS?^5@yq&fSXds5}CT4V}SS24g-eCkcE#U9iKqj_)~ zR3T1GrN&VSPXtx;%)*JtoiR?aEvNSZls%YL!wi zt@Ns>*szruCzbg8-jX>E#}j zl&;iwQW2WE}{9tLX@&>OToV5nuu$i;LoISpl-~Rk|_0>P$5mXULSs0^1eUhA9DA*Kv2rAx4 zJhf7fqf)w|61A%!94b{(D!znDZ}3V_8@}7jOnUb!9U`n*6Z;E3Pp%L(*e#-_ zeDkX8lD4Bd8KLG zELK{(Y%=rOtMj)r-T$1k#bQJ=ES@F70a{ru<7%mo#5y9F4u!cq4GKnGJf(5KwsxOF z2*+=bc*ZALw!7B?MP#3YpUV;VJz}cfUa#x-H%Fcj8c3Lz|Q^Vg(RT_xAcp5_i_2 zz~{M)-I6$`Zt(3$JF0c$IR6%Y*1W7CK2ni55T52wtB9KQu@%wD-)lL<`@7AxsjYwR zk%LdW5?Q?qa`>H=RcA1s1gUH07~BM#r;w=@Gb0sH!(Awg75#3$6v zvqd^9Qmry5nLbq-I@%_nuS>!HGF@r&d8y$$lbY7TQ`_%L3hmNQIoB%| zrt%$U=g!45;|Ek9{BCCQIr7o*j&eNGcvZP0jfE}xiuA7sm19GM5K636#0)Augs5Rf zbAgso&>;suFLD&JQ45E_fPV`NPu0s9Sv(u80RZuyD-7~m(Lw-A^7Gbb2RtZ;(XGR`alC#p1I!UEw z$|PuhO*zEo=7_>C(E6167tPJG|Fp2$DyWyTxgj~ZuX3gihV#2b|E ztXwN_Opc|Sw+?=Wy54WVSxyi+sN9j9-c$#zG)}ff>#yaXTJ2}ZdBOQG6YX%nukuVz z%!#5$XtvUqF{sJ=@|oS7<-`Bs(>j--#rjk+{Y5&2m8!84| z9@{x79UfbJ2YHaT3{D!!igkH8Ed<;$MVcaKNWn~*$9te)Ym1l1xV9llh_=!2#L?GM;=$H@mF3hesbpP?v;Us% zd)EbXhlUS9#T$#P7dQbB%cWrdg(+PIqnVc4jXNcOHdIVPLBAEHS);pNrJ;7E{$qUa z;tkKfGId>fn|#2FD!M40_sr=F(EwjSpubk-=YWlBvxTYMQ_8hIX;5x^ld>wd_$VJz z>2_yXL65#%>ygyvnW@HO)#*Hu)gz5SikD>n(|j#HnwpZi&j#w-ygQP>Wu7Nroe~e4 zYLS_ZSE)QU>$L~<74Z)Vy%iL2Pzwt;{#fK|U>B5gZD>y67SmJ*@ZQLDL-9dcgIlgUWR@TCx#FEz_`Io4)J;%Zku$hoDJU+a1TYPEr0%9WyW2uRD>SC5i2%_jk-{6QCd_H{?pVpBerpvZu{8fC$W zn=`R}=QH2$o1P^(jWjRg`K0RW>XLo3iK>@hTnFVk3n%+n&h1_Aj*weH`)c2lM@GM7 zc;OBCwbNAcB!kfVs>ULH_OVMY_Xje2XU0^m*PoD2c|5xfn^G>7d>@*<{6T;Vzu;xc zhUC89H;f}`PxTP<$l(~3966Vp@>;Wn84o+nawH)T_)jXX{nJ1B;B=on@u6o}zl=Z9 zD=f9mk(BJlhdU>-K34DyYmNELVLhfor6mI!9V|Br+Fiyua%|*U% ze_nen+Msk=CrGFHcL6GSubtdG(C31NRRB84BrSqVq1YA5L&%v`01C?urJ^@FrYR8Fbii^dYkgb4Gw2Ep zt4Vd_glsx|u`HULCKVuulqr>q(Q%6}!!syII-5o(azM8v9iFdtWR-0QT&qs6(mWRs zrWvivD-pX6%yq6(OKR_zLI`6;HpXBrA7`6DICDl2xVwY3T zrYgaKQqHoYnhtSsQ~iavK&|T}XmTN!? zwzfQ$;E^WJJbd1+EjUE6ckgWc@WN z0{NV6H$s#1*)275ZJWnZSQY7^znj1P7u*D}qX4UasW{sj03u3?2avVEF~J8y3zvi} zwJz-sP+dp9s}Nil-(`5e34tsb+M6X~0$@?fG?v~!{Bn&7B(jGRDl6ObBqiTP-iiNP zE8mAbc!S?fxbS(eVHx^&l9PQ{vk%_#`+!JxoOMd!>fKzQuwB`+0QISvrl*@6Pg z-;>`^y(4mVrCS5u?3g9Kc6IB;wX*K1(9ZQ}v6_xwjHLAKN7TAfQ+E;xXzf@FAFR7h z`3)t`F6XYaxVK+zR;%eVAE>iD&XYOo;$pS6EalHVn&eK$yV)#o-g*( zPOpB$1MPL4bt6ILAQzxV;U2l_zVl&8W46-vDa0li=BH)vpEew~+ zij`K(m3BXsMhumvPj_Sr;&28(#YXmFt-sR3?I06)RF2Yl%q0nkeFGAcuvoXzTh}!o z6?hwrJKgni3lVo&d`wl~O)BAIcYS{0Ha82RkWfHUe55}w6m=R=$Jc)s!Jw{XT{4=0 zDJ^g!G}Z~~;6BR`k5u(#0G`}u{UdNAfSUFl`a4BJY8505L$eiQwKFR~+^h_cV$fUW z4^+eW;s??i$u+Ff8Xs~gn$Wz;aKYNu$fTt%1R+ zD!D0-5JV}sOfW*-mPtXrGIb>fHFYIHDybnpB=Uhnp;(5XJLIPa5x-ILK*}agG>D&xr$9iZO)fdciJ<9!D5ga6pReSBNErc5^536Vinqkr ze_pUFAD@vgDgZ^s;Lr9FE|EsXR8vTz{o&+@d=7cI`GE3=AfjZvP&qKOCRPwmlgQsB zDk$A@&joA!{7oQHrk@UE$*(!k*t8=L7D47lMtnCW;Yi=KFqt$C-dfo-IfX79X+&*I zqLI?uL|UH;1&poVJz-1YxBiFj@6qZ<39N zh*sJ{9ruj03M|+&OegFx{kH|^M7b0(a%&5EITB#AA1`LCIS*iyPkrek@EQx1F0T^usPk{Fu5d#nW?@P7s6j``wZP ze?G6Mgs|v-cl+~)AeovLTu5ZxI{7EnPftslEfj&RGz51Z5QLzDU&aFtW<1HkFY&_$ zhX}<;)8h~qW#=AZZFCe@oabIqzSGaB57>9M@tNMNVd^Z)%6I^Im?K5zSr_)#f|y9& zowwzdOvlDc{EX_LgN!_*{ebkM9Ld*ou$<{^=%0Bzpk+p$5lYUI91u32FH0N-|_jJpS zpH1Rb$W3yFAHZB|`!FGG`}{l0a}X24J|F9EX3Sr!MaipjM=MJmmt`TIhH8=&>PVWZ z5^?1H;xeqtYg8;q$#Ht-AO%fPBNip7#VMYyl;UGg&rEjAZ~x{CIl=pKpfVFimxGb@ zKVEz8wUys%3hAjk%d*6*MOpc1E(QJD->bD%U;xA~QZpT1C^T}0CGTzr1|-maw?@;S zYg0H6CmPx%LgBasx=dM44--sfHt~NX8hHk_{o0Be|u%q$Qa*P*F){q!Xzuz@ONt~ z{`v9O_{4NkDTQXHQLN0AIiv--ghu~E(3Y84HDz`%<0eu&-1uWwZg^*fp;vaNWsZD6 z*BqgTmHeu&?BmVk;11Z!i+z$1)-^`RIXo;(+nIQ!F zH07h~AIeqKOGyJ^uPMcYEKOx`0NFha_Vl2;q0r}TtWjqId2+4D00h>juEVzy82$pt)K!Q3k3@Md|Bf( z6dLVu7#F>_`Q%Ar9bFyyCbo ztVK=TOnxR5H4V3Wh%;J0Gy` zlAXs=GPcJyp%YQfBK*Cpa1cX{~Ujaf4pidk<9<_$A9~$fBEPC_V54s zAD#po{jB5v@n3!x_n-ggzy06;{lEV4@BjOM{L_E_hyV3&|N1Zg^)CMZ^WXmE-~Z_! z{`g=2{=fhA=i2}H*MIz%AIA7kKfm+a{{N+&^+VN03QF`tJ$jVjq)t-tM_;3C=Alk2 zr6)Sm6I2w{Jyi53o2H`%cJhjXD$Di6`&q6v9>r9T>SR+g8GX8=#0NFF7R61m1L7%J z{*t=fexK^PQ?B*!FkCG`F)e4>Uz%NvYBzq zq)__d!)Eo!@|ucvCg*mtJ>qNgP6~k@I%W9U^ULqHe;2Pk^se#y=q=^3(0I_}q*^cE zFiQF5`*bb+KtXNhB?=GwDKwQjhwAWI?K!Bab>|He4*7ih^2qdtC?1CT9b;K7sr=oc zG$oaasmn3co|qykqp0fnh;a@eRee(Qu&6#dh0IKCie}P9V-;V^deSt-2Hw?I+N1+@ zzoR7PsH3(vh5QMibwWuo^Mh+yu#`1g^ol=J@L%F`>ffQK4eicLQS8nX<>vIesluvvU;RpH)FH}dqqwN3>N2a^ ztNUXtDp;ys5u4($k}wn(E$S+h4v;F(zsv--9|SVY77okF+l-(X&+k?YZ#xzzKKU?0VY8 z_OK-<6y?pIhmIF$5_LoA6sG@0trUn>4}?jPWIAOe|DvG%P>ns&7SzrHmy0*_AHL}7 zlu={4Mt|I4?YN}DIYRAJE5o098tWj1u87X~P)Uj4e!sz#^L$29?+Qbte_zTX}|1(=n( z1qJl47tSUD`lRzw5m28ts-aYcj!p@5M4AlhZ8zB#x`y0Q@24hC0D#(-dpJG75G5@W zKsdQZCBc>ffli1mz=iom0G%n-8`4t1!+EUz-fPeO9eRM^i~VW^t?8^k9@)eyNN}h| zowY;r``Ra^^EL0(dCpU)k*Skd;5X^X2`Yn192fhQQh-4XG!$Kv?yYP2?NlM}D4sZY zgOVNB>nD|O*PR!jxMjHk;G4@fm%xjisLCD7Fw}1_^8@hPyjJALIM3r6pwdZlEa+o( z83Ng-U}SW6BKux|$kZ+PzC3+~L5MNxNxj~V{Wq7PcLR$-&n!qILH6?0q8D1HQxG}k z-W~W4yaOhXZ`uU*DG(z4qwv=?TKdKNj$pZmx5G{)$Z>mb@|M(w(wK6F9o~234tD*0Kf_Woxs( z5R@cg?udP*Pfbc1e9nZruXXCn7C$9+;J8|PIj%jMJAz8II`OrO2yT4{Vb|eYk5F4u>;`=N*(1Ul}u&#G}Ue8 z#86GwgLKc|J+>9I>gaRtq=K$iqBU37^|~P1{N&Textzx1%2>ePsQN3?cg-3`&|lV|D_L^4n9 z7vT0wRxO=R>WsI4ANAnZvJdg0x8FpL z=_!&xvFjHcOZnlX@Z#=yc%UOHn#M;&;^J};D!n{*@p*jUgHmVyBJ?e(KjnE@* zbh=tJTl9rag5nBwawzh`&^@ZkLsQ)`Af-KB26Yms%V2|2k3;S2&d4^pSoS?AXhWn= zP(Gsr=85l^QHRjbih7S zkJ+-W{L?eX?N=(VY&q_o)2CJty?fqH_TuI5tQB>-8~Vb>{y25Vkfc@@8uidrA3Dix z^(@Y7+x_b-#h=?D3*U!35K4;gG+}bLLTOJNx~S#pTIt`?@qvA5DQCx0I?!g{w(f4Y zRsE@1!|bBe+?`h4sz2ClT)GM+98X=}`+)~hQXS*q#vZ%6tP-L%g2-DMZcW4m>#7dmsHe&?E* zThjGsL z)Y!-NVDK7Yb=yQoHaj}WsYp(qN$~>PiszMpP&qHGt|C@C=^Y`1E8cin%pmbuTZgBA z#Pu456gueE`v$FMzny{4Czb2hKlzSuuqE~B{)RXU4mO{9<7zB4HfR6_I|cha>WOZs z-{~}^_(YtM`u58CnNML~P5M)uh7E>Ia`1^yyaER;eQI_K(t#5NghWv0LGH{hoJcBP z+vtswO^+?k4riTl-vI8T&);u=_vbrM{^X7h64WNXLlSV6#39|=HWA6g9qGUM-Do)) zB`b&jE5Hl~imtBTNq^GKvpZ}hVRygO&jOW8MZ1LdQa|(7FBNvsghKm{JuhmeYyMIX z{#~dD=GT|PdoL>V2RaxJIsol;DRtX4MGQbx#EI)m?eun1N4wMAMbsDm1nI~uzXVZ4Yuwi)%RKU^=1lohYIfwHcL<>?JwQ=o0&2H_CNpezyI?;{YNE%_H=3i zw`u4_ubu`*X;d|IzLXBJYz%mQ`Q7$Gm9ay$LtjLRBzUG9=cyUHn(F19lZJx0D)!)+ z4+q>J`apZFO~g~J`M}TJI~5<)QyR_x$gtnlZ&#D%h|f`eLCsDFiC&E?ko&d8-+rLh za+EKXpygQM2jx5aZCt0Pw5v*G!!TS7`?jAe$4Zx*(e362aH2BOMRftnV8>H(=7*oz z-x*ZPoUNFqTKrDhx>c`ORhvGJirF3EY+DWBa0G3&Dv?(wQ@)G9S4TwEK(14U`(b*JY{$7H!J*QjtEv8&|B?e=f= zyc8x2;&-S$66Nd%J<{@hCu3fz!si)3@Nj!3NX+(*>ryb&)ET{dKg9cJGZyQYu__u~ z?(RF)csWMhyN!#8w&FE6mv^$RY0W+Q@0$~UB`N^=RCSr$h6`lpReBAoGzd+W1qo>M zw@~1YC4D;(A4!A`P{;^~BAg1IUCPcHSx`FcB&yvzrII|B_NjLC z_kGp!Jv8(J7Dc#?BId$NSj2ev!%L;TDOy?qVb+GPNuul8qUocQCCQx7py&-fXjPZr zK;uj)a)&09nu*Dsp*@qkF({-GR5nRPvoDh9^S9OJzgj|iKf_<05?O|4P=6*5gPN3% z#TWo(xANFnN$Gc?wos`eche6eP$Mm=AGNG@cax2Uq2}+U#xHk{do8Hx-{l*CpYir@ zKEDdpLX4^&BW3avCG?2pqblSEK1pfI2Ip6`F5do~bf-|N$-Gvh-HwWpSR;OS#>Kd> z20Fn%sF+}KyOZik&3^CXAWxknbkr-@@^{tOQeSRf!qjcM8v@5pL*ei~AZRF!p|{DM zcns)lnqxUhoWa;-# zbH-sF@tEtGt;31u9zjB?Aiqj^pEBWYaG=cIHy_m{lmRJp)F#gV4jRH+s5b)w!>LHI zp#e7~#WqQIdb4cP?_LwCcO6f_FDZ2tQ<|pS_%KEcn5~5S`!YN*7`1DK0rB*WfkU{f z)5)H`;6W{xBAsA`NfflASW8NG;AQ@FV#=^n*xyeod`(l2L>YVAEe zm(_^N=SFg**$Xw4@{72G6rTB_R$DcSyy;qT%y6{o_}XM@nmm^*Z#|AzBnMwSOj5t; zp!kc=pUtbEZaLHuOsAmM?V;Xj7jdDD4KW3HhPITcn-#-fEznHK@uxfC6FsHNnaCUH z-`eRtDpMxmwmq+%=Yns$0GZjRjZ8<F-dhRX95y!_ zp~t?j0!f>YQIDOh3qWlF_M$r*z#6HVtJ^)AT1z+RX2_v3kC`MLlIk!nxWn;|k&|^} zNpu{kjW0SlQng3MxFa*LM#rH*H>kZYRc^=jbTF&8dw;oLc*R~@D|lY)EVCxi}dcv7oBkzh8zibQZioygJ|Atib0vc%--mC3$9_) zDc>%gTpm}jT6lP8_X#K8cW&}nvF(lZ<>|M!B~a|w z#W^B*M6})KmIi=Mn@;8D8cXZCWb!G?*23rKV;`)^v=yho^m^6M)$OWsD$BZR!n-gb zeO~i@JBN6Tv%*6$-TDR!fX4Sd z?Y%aw7~~h>%N3%PE*C-N?;Z=p{G!LZLf3@O&rv_Naq^ju&*ipX3Z~SZm_hlJecAA( z8gTlu-fP>2VgbHCU(4m$wodYWSacrs@w^0UKROzaK##OeB5pL@jbkyNvhmH4Q1_&n z7v8vFbbS#%y`U1ejs$wpLON-V;=#^7f7mXhM|HYf1eG&Lj!(zdq_y?EhWDa_Bcgvx zKC@?j!Qy?t8*KS2Utmi5p_0ths~IY7x|OCi9Tz{OF)duLLrG2bx=>46fsKkhL#3Q| zT62-&RJxlJhNAb4^<}5wxJalYN$JUQIae95;y2lX|wbv*yE zje1jf6yzdJ$Kef9cv5PhaP`MQuHYAH&^Ee}2PMgnB9xc`IGCU$dqm|}kYN4dU_{Mx z{rg=$b&m1DPCXo!*s_h!n@X=e2My)tdMT#TtIB~7{z~!j zq;Lnvkwk`IxPxOpO(9WC2|JDUOfPa6rN#8YksJlj_&wYHHmt z3hMEwliD72!8Pjly^c%09Shvwj;CN?|A(7T?~5ZI!z-zC-H`(Y11&nKg(r=ttaJTi zrjk)Ebw{S)dh9V%cU6+YJ7nsPOkSSDI%ERGfL}ySuR~JHqgJYfMxE65I^;9Y9Vh-7 z&CsaR z+dGg*TC)$zM)plC8i#67of9bLj7IH)dIVi?5Xz(lrL%EyEzb@DZ?rtuNg0$>^H^y? zQ#uZnjfCW6=y0;nV)#?g4a8`dcHfEX87_e- zPBG3w_5Dr_rlCa8{h%FUL~l&MhVdt||Ii-fx%pb6-PQ zGylSCx@;~*9kzU^>>RC;LYM;n&^WGdY5us}#1kMHx~wz$!}NV4Ub$DM9gMlhrsG&S zyGU<2CO6tW%}u*Bz)B^bEgVJnUKz4_*hdw#NsbJ!w+cysx*xO$$h}$raH$GegR~=w zJ$<;Q-JeAeh%{3zcvNv~Wn{=YYTwD?>(X~sVB=9C5d8lSCkbup>`qW&j%VB6EI2b{ zr*0ew`3AWm9$T&HnqtRMhrdfpr%{|`EA5Q!;8KwgS)VjE?X=e%^rH${o|gV&$3qqn zdF)h@t*sNGVqFi42dsXJlIUEaQ&yZgx|S}c;@_oz?@+>r@GX_$UFd`w=YzI*_EDA# z5Y9QfFyF%OIehErNY?S1yGC56&%3N#n zMpw#ktVO?5jHc~dq(_k+74RXgEU9|6wbGp$m@~*pG7jF6el@_J)Q5Ihx;4if*-aNn zUrBe`Ue2cg`&fMCrUaDpQr(4y##=h2++>&8U#j>GDkh{a5~XntQlk9KapSF~kbH%> zX~)BD3SFNDC!NMNmm>CS>K$iI+hTpZz5FsV?GC2q1EibJoL2*2mcqC%I~>6*r>)QK5OSOzf5q1rFa)NYE)~#w=>PH8%kqI&&jYn3m=m3j%tf`uIy0` z&s>&Ljq;9?V2#RTDgqW%zh$_Tqa=yhXlg3i8a|zUrLd8v$m{U_EPTxyUy%ICLbmEe zNKf!%4{`xk+_uj+LzVF-e-n$Mo_CzQS?G=v=27{BLKXX&?j10(%lYho$&LzH|2C;`|j4M<9L$8*=Wv_Bq=8@>bE?_kzL z-%Djq)rmNOX$a7%f!d!>oxIZ$sBamBs+uRW5;<_dY&_V@M^PQDSqhH#N7V}zg-x%s zCz9qP{YW)XJ;p_>8a?VLTZd4$s#Yo;`2gOboO9IUDZfzpzDr4I5v9DILxsXlwoWo- z`8vcuKFd+A=>n8F090?4v0RsPCc2PHV@fkROq5c9V(pIfE0ws!R#v_@km8`Spdh#t z;=?ZGxFp|;Q>8kezi+ZqluuMZJhg**)4#a3_pA9;YlSH(t0y>hh3bM@x|R%7{Pwk6 zB+I2E@pW|Cm?@;@a+HKigUUNqc2U~7cIme6oKKNsA{g*3CYac;8;Mx?H0p=6siT?P@Aw?G1F+&SA_%VZseWj zq}pC9L_n9z!kqa4RjrDJqakrIo2AmLU7J-6Dy>2#O8x zuxfZPQ`$aDGzPUmo8?o`BGpf|O#@Q1dDgtxto>3jmnqsdyi|^5+Pf5s))XhCM6@X? ztv5wJX%NsZ@FE+4-6&<_i%xyV(w$n6Z@)OPe2Q?Z!!5?fc&T#loOiC98U&sXphvC3 z$W5>2Tm~RjMRS^3la7K-$Ku*0@n{u5{8s_^ssK`@1#d5g zcgGT%n!Z-fmD+6Zq1M*)hV^!7$HDUWovHc@g}l`>8`aS@GSF@Q2CTcP&{m^wWUtOr z%(rX0J580kF+Tb2H`{PP>6syA`ZQ7~XJR6&D74GFGp8Y?h2JR`Ccg;h zHj*o-y6)2V%LuV`4Z;>x&3O8Dh4DY;x>4z0=CwES{$+b^!#Ibou_2$YU}&`;Bj0km zwF?`ce++!iiPANWDPy|}JyVKt-`SO=IE^&5xm*er#P{zo_FR^hiFG@DcZN6nJo>sA)b?- zhO1w8>iBrYYJHpSlhL;$8RL21aLf~md8mDv@Yva>39;2~YdTT$yfbm=&Ln)y_FPL@ zQFAzL3H6wIfYa`;(ErieEM+RX+Dm1-20r7x_B6whs;d5yG+AeL9!hpxsGoY=e3L>q z6dNlhc;4K+sXNi*KCf|vncDPBxl~9JQ*5P|T3@O6XV~!?J+4NU%MAosHpv>y(#f6` z6Fr8W6-znHC5cTmZ3XcN@z>N?Yrx#!43WJ#(4nHHJ=8;EY5G7dwbLb@yg11_ zRP2?Obv}}+96L~h?o_8Zx||K!pgKLr+JTC$9a$zMBhQQO9viBa{ z8HYlr>S7|0ST)|fxd&3e^|{qyCW1=pDzgM>{7zX}#l_$|J&BB)JoFR92e#FM^CY!q zN|NWnBi1>-iBiPOwd1(NL9ZGVt$(Ds9XxOtoRxC=o!;z4@db>a)9o8Pa+!AZhIxJQ z-vCjEV8ax9Q|U|MQtibp1P~6;Os55E1L-BCf=g{axF(Gw7!>mq{1-Q3Co%+7S6%Kq zov4~3nr`YzC}y=Ott2n`2CiEaGp4!qc^t!yEsFT)cs=WBj%|nRRp}^Db#*I( zjQyz+SL)!j<$$8G>LzM*D!;=s$fGNj3p!Pl>Q+Y*Y;S65$jKR0x-Rio&`T`6c+o+{6~7p=3cS zV)nXI9?`yUSxm`PIYu93&O-!|D2Cv~N+)UXdPXX0f{PWK2ub@2GCR0nun`s6L}sV6Jy~RF4Jt87;)Jip+c` ziX37Zm^C`wc0k;&J9((&eAH@5b!rHv(NrrZ@kT~+@_Ap@q9L^FW$L$47gS@^t}$5o z_I~RR(zULs!_!ek8*&+s;=L#qW;Mkogg^&$Md_Tz0tCZmH5fHFE5w4ScTE6Q5#CN= z%x{jOCKz$LacUD-9&t=!=NNK#ipq#x#jiSOA9k;;Unm@ozEhqvu1&fao9Z}zdHY;` zL!8-DPH2E{i|+9xnT|DZI09NBZ=(umPHU2icVci>R`7&_Jc^*g;(PAzVw`G|t}+m0 zM_j7;?MbEM?NYSj)l<~K+tl(?;$YhAx4WbM)uNGGvI$7YpS)$yVVYCdtP%(q$l9th zBbxw^e7JyID?rEr{I3F%9Q%5~^V+hvKCj7Hhf20l<#6!?B~N}V%vN*&#Fwuv-Cc8)Xy{J4n+T%WTjRt zirMJ+`BLjUvsK31lTerJBtE=gKLNu)W3=0SxH2k;A1K&gi|Vb zdH7x9DJkryG`*7H>`6_6r@5OjjB0Yny))0INqS_(4LU*81r?0v_f2*-p)mk*la$NKN6)I@TkeIa z2ot!~j1{#ohFP0mLI5^c=k=y2rD)UFN#5QUH>v#_@9r$|H8Q~K2q{l2#RJLx`o zCkMq#O?0Ns&OY^h%45ARr;Xrs+ukv$U2Vi8djyw%?k%FXxns_a7WcbD$$s(jc6L)M zL|T*OrvrMaA9z>vHG4I(Y!RoKhd)( zzcuPpGBbdNDQ5l-#zf$EDqPbSLKd~RFJB9O?vJk}13kVLpV9BaJk2q-No}l3{i}&o z&iLt*3%aZ0c0no9n$JY2n_9jzpSc`=lTxH-=E#UIlB#B=>>Gs%_VqXcQS}EFRS2A= zsCcGGkG|UlokTDuI!oQLNW{aibk3RrHTA(84qr4ZWy*5sJgChxlSwK8@yT)1h;A+p zrsg%;`?3>BbdyRfidkOjz_8pot{DH);Gh>l?$-!lTq;=RrDEWwFdW8}B(Yz|W_gh^ zL(0@3JicKPg?cw992x_iXv(_8S!Hoz@tF4e7XKEuI!wlR}*NwdGIz8CDO^FJ?u87A_ZQ>Z zCi#^i&SRiK^@O~{j$@=k9whZRzMs^&i`TIiCW>KDJ;RWV_kC9(vQ9)O)v<$G!4orD z90WCAuA2v*m^sua!1kn}6T3K)o-m$jO)BFG?0v!Uls*HE?U9kzm7axu9 zSH_yhOe&@ClhMt<^KvLh{4^T1qe`rrl=QKm=?tnoDCY5$C&JjF)JCNBuvx=oJxN9U zv;YzdFJQ**BMfn#zkAZgZp-ggWdYRoNdfYK@-p#w$VoPpQ;wQ5@r}@LEU2sy@BqtD zRfPv22HC_UaaC2dqjF+US&0HGcMd-#p%-K}GwGFi}ESx-jfW% z2^N$;rYmtL9-)2wj-1^&85!sxexBQ4CsqEQ)5J@!ltMr>K?Q8nx%usyQgmU})B~7PRlY|{ zs5DHPgH@I2p}yn?6&isG1Wh8wD(ypk$*M976A$yENXO*V_gFxcFKUWU!hcHioP;75 zsPdUMRaM$2yb@H-JSxy46gkna7h%eY?!BttkWZ=i4dc$WJkzS4IDww23L*`~t7<7u z)Jjd}Yph>~Dj(~I&9%ropjF^k>XOHt^|>@>`x19XcReSu5a`$|}0RwPAL_QkBGYuH>~mHEpvvDF^( znb0;WXn>SCj5EJ|`5Qj3-J`bjcV1xFhx9SDl&TtxQy`J;li+WnY0Q+HvhV}s%O>iB zl~}i`N1=0V)z}g|N;^A^UG z74K6yH!4e4nj8))8dRn5PGQAFO(s#oS<|+C!i7Xo8ylU4o3fAS#1-6zd5^qUpQvg; zBk`#6aT9kA@PI+(g$n+{!kIRT-o2+=TEsp--QquXg()Q7(MgPV9k`q|w}aw3h}s>g z)Q{gjVbS>7BL$meB#m?6Xaet%cNVUVtF#~Kc-z!ESBnHgGJt7+d{N~aK3My7>rS!K zM{;`bcIkiP?{+V_%skCbIZ>hzj*h*2z<=wpjN+o`7EorNvV>U z?tH97=ToTTLObweLhh&GUKf z42!u|j&1&2@56fYzIye50=2ref}o^@1Te5x3%x|aSNj9v8`Mk+J)kKo8Zpq!tU=WRhd!F6a7qETSYxH7|N*&db$M0!vyX zcG8(~XMT89H0r~uj4O76@{TF*YEIt1Ev`0{c5kk`4g-q&s&N-0u&L~g_Hva1s%zEa zQIy7Vm`@4WznKkXW>#A!b&Mwd5OBZ1Op<;WR4_@?eq{ir5HzkN`}isKdNS`*=%H+i zuI-|5nE7`Tlq6lUk}3IJXVY!&lyRruiShP!N{6)g)~-Sr8&cWZlX^By3e#X@{g-RQ z*MecmJhgCcGG3{sBP^WQzD<^?|J_toFO0gM4a%7VdGQ%jRVEeubKMq*@xk?2DH0_? z+G%S$hMh4VOQFTq8)E;o_TfEjO8B3Jg^|bZZ&yyayoZLNp|KZP^iZ-CwXc1`}J`hF>z zA^UfWg=zNN>CS$g!cEEU;*&0yG!2M*w=@&=y1#AzuDaO zGSGJXAt!3vtSaOKPFP0Sfe%|YPHrW9<05YTZciCBIT0gE&?CHe2LY+CIo~KDQ6mhYU_>Y?X0J zpGu}Yc014W&NauVXP4u5RJ*Hlc0Z5pZ`f&2@WM+my_;emsItKzmqfKKwG?CA=;%&L zZkL$+F>K-`J9Wo2;s6}7D_Dxr{l0u=x4%Na`#7k_@R=4lFThBA!i`}AAg5;9<&@Jl zt;pvau0uTUTvw5Y+V55xpYHJwDwck{{)3j3V<;;rc^dM4M51x_HC3PR5;B8QHuRvoWInUqE_0%%{I5MeZU45(c+26n(%p0`E~$^ z6K!tcAe+eig`;aCJ=da+23=a$W6;6_l@o>Kzfz!QxdoOfiw&ULEvnQ_;$rIpODdUC zT8a<~>+#Z0Wl{aTu2dh;haBn+oo}Wzx6VOnTilM5a z!~$%qfcR4Qzk9JWB8=9erC($eFT9%SB(z9_SikI;MYb`GA1c)v2f^(R>hl^!qx?JY zIP31Fhp{|NcZbq+mvsRYYuzyZzKj4D-?tOcTLKE`+m~S<2L{TqP;75q5P?QL0Uv}a zu$F-dN}&4yCM?D95vz-AFH_rh=6r77nKQo`b%T9Ld=MyO9fKAslp!edr8xb3r=-*N zTg8(*l_9lnrT+63`{EO#f@M%`zaK?;Ub-|^^?+OtgG0OW^5U>xf<;hIkm{ZH zPEhlLFf4%q(6!)>ssK{RUy`+yDK3+GpJlQ|W)|Yt9?D@uL zC|uqAyFPA>fz@wSfpsNR03CH&h7Hz$N28mUL#~1aONS04-t2bB<#H6ZL{~{4Vr6wacVP4}Ixy=MP|x>Lnls%=MEJo_k;r}M zm@OqtXbS{`(H0Vx>h@_?ldKX0?aPK#YRNSME%+P@ZUHF7_VZlG#P?!#OAjE8NEiwl z_9bcp-8GBRR5MTmQ8D{vHFf#XMD1z?Cea1`mGb3q}{Ev9{9$VPLdxMC3~dx2Hw9jux*p!LigZ8a{%&0>O22yq;=t)cjhIT&i$VLZuRi!7>8NEu z6>eEBje_V>mmP>jr){O$-r7(Pa=rE&_hzd%x;kikwbIN(ie_utGLEM0wRk(o-9=Te za#hrPCQ(Y1?nYfBtKj~I$M6d&vpM<4V&FRsDgxmH5uKrZJgn$-O=YI3D&JH%n^#_n zo}IpvI9k!(S9!2$9W8_M%T`q0sl6|_fDYsCAhc|%?;t!GeU%aN5SeAA!uzUtBvx!w z>q?vrtzKRT-$%XTG$WU|@7Z3hHuF%%u9~?mKEo7#7&Q+;@oZ$Q54x4d`wn7Q)z}uF z|I8a}Hl-s7w^uFJ1{81AGjqC+4aK@{ba_$ur5r1zlNhcfWK-msrFRT|_;_mcCYGAk z=v$SB&Au^s)cu@Y&hZNMpg?A{zF7_3%*1)jhF>i<^*6{R3QDn)oHj+(4ntMx6<`Kc zM*$EwY^_*T(In3Ine9r?oWyIyA3j*t)0fAE zdRyV>X)2L~aTSz4V-e4nBB8)^o0r|&V+Idlt~x+V0qv`QC4K{74K9^No#3D{ynWc; z^IKG)qV!9_(&96zP-nEgCzR@$YY#WcdJXQ_WhbzKT@C;dWS5n5Klmx8;_VMXWYx-g zh+I-nAzkcW!V+XY6PD}ybN*F1TZ){jYU6~<0POow3RmK+PKsTW&ph`1sQ|3i_;Q1Z zPr2n_pZq9=GUE+6JDMtWzt`q3zZ=7*fhoW5YTtd|P$u?cP%>c@ysW6L`UcMgq1wYN zDHv?`z$P?&{oQTUD|lN{QY12B)-13mloaEPN9te)Z#CM7|GAB8=jKx+OX=7?s`X2S zw-q!{>0NoMH|wzF`C5D*Gts#wRYj{J)$hywGp0@XO#rsY1EK&dlV1seZYCqAX4qk< z0IUTDLEUn_I8DXt@iu3Ga{VDgyQ!f10-Q4B(<$GgRfpt|U;?rO(Rqe=59Gy=qpHFg z0Jm_&H_9f+nr}mfNrP*S{S0w-j$n_5hC&JwT()XD&UN5%O_7P5 z{9{u~;mUHIQ4LIz&eg9Xxy?%6CI&0!S438(Pw6*4OPI6Gc4KSv#%EXeQ{I?d10A38 z`6M+pr8_BE3Bg}VlqTu2IUste+21?Y4N8rqw7Fw>C-8P{ZY6umTAt6ffgdP1Kcm>X zh8m+LqFRc%Y}tN^s8dK%TKkkV17N0Z>ICY763=GH`}oMq&p+3zU*0?6JwKB=q4V-r z^-3yY30;>1<1fxh|RYZiSo@HYw?!c}SA(zuj@{Zi}P z^J;;E(F(8W$Z9b7nvU=U+pfD6;%rfd@M=6|`GZ5&tXsM>?|dwVLqspxWnfm8HU^xy zw1r5RSlV92&&=}?)o3XZA&=#zDB(-x`*bI`lvVhmVcDHa(d~N;8Laek$>*gw5vrdl z%~H2RK)+Lfzc8QDB68`$^AWRZYud8S@4JrIe8aM5Xff9h!Nh#ubDa#|arYx-0l$XB zYq*%6>&1!Bc&d+*_(TVz&}W}|BQ?5{$r$y03cyZN@cMJZ{ra7bLsh~SBZM${1g!)f zr7G<6xW08_%rN``4Rd6s=*moTMY$#_D%bbGhI-QOjJ4K{mIr?M^XDYJ8o^qTaOKnM8|v%js?$ zd(`L6FxgtqKQc+|&i>r!qqY`IR`Q)Oq*aM&1W@;!^O~=A^lxu-a zapW?^YCp<&+FpvB;OC=})KG2BxHyDWB{qT z?bi14ekXS7@K#T+9o=Eo47!dx<0Gjk4lbsv^p!7&BpTm!7OYXHwX3ai)oQG7)p^Q! znvF~$m8kOAB~!v<+>l?Q7L0oAv+WX%_?!ja zw{;8MW*be_{5yItcG3tNm0o+1S2CSFy(q6p6zF&AZ+CUgrh06bBs7)c>MIu-y#=(t z=|$%wfkLDHsCJKw92}hnic+W4xg3`~Z3sOzG#(5pJyC<*SMA=+&%ku0Z(J?~2|2yK z6E(e{`Sz5aKAtG~-RYmwsBUS=^HO`fccP1s0MylpoYbk0YqecgBLOR)^7il%K8M#~yi%~K*F0H)rluXsxhir(Hb$oW8@f7Bj{2?< z>RnUMcy=f*=u6Qrx}Y+8jn+**>+c)p?R2jcDyUpd$?o}Ok%~rf)=pm|o>r7DlnTc9|+n@4Z{`DXK z&;RQ`v`=ZB!t;mV12sVj_bNej5(;j#6P~n?mgKw?)qab-{fol-$AJ)2NeqCVG* z+RfC$Z>sWKwo~cy?U)t4Qtsw^f|eXjmp+b+r9==_@%Uy0YKs%w5lp{6Xp zXnOW$eRTxOsjib5lq#?uQ8ml$>ROiKRT43!jmi5>swI^tAr-didZ8FlP``^%`b$2{ zqQRJ=;zPe5K5Wz7?H)#xBb~mc=uuX{mZ)CTk=4oZ_?t4wx+yO_ugG2ZTBoT3MXQ@C zk+3Tz{d(R}_s+~P>fWiN&8SI-oV4FopFdIG@Y=)LV{G?Z*+2Q>`KYNI)VS5a zgHpxs9L>W#b^k8sp6EN-bQ85Hv+&;e^|i(RdH7!V!f#l9%KYVbN$HtXK}I3CPw5Va zskXjCbE;vU;jrV50EMuYN_zM0K-R2ESgY=-FbOlM3rU8VnmZ6=$gABB1SGokdfzZQ z{KMNxp39Lf(!x|1{W#5TqO>K&eD3{H@T>1!_jl~2-z{$U=Ug$>&*C^oOcLP?M;+9I zrIA>wg5Q~GHnRrwA=fJ<5QZV;KUM6!Q73f*#!x_JRt4@O`|CR?->gbmpF9h2G%(!5i|K>>cvVgUY}~p^iTx zhpFxsU^~Y<~o0e6KJT8|M+b!`Y-ryQ%s)vD^rE^vHIp_ zb#a!f4l{taq|`=66xGxf(s}zbTneYxJmy|qlf2Wl&dQG)3d-{Fydl57!v}}e#p$)w zOJv@V&U=Ea0*@f?!ok~;YQ#GRvTzX6kt|G#PBdCwkj=BnbxtRmhTm^p9!Y0;N1ji+ zh$ve&F7@mo%)IuMsc|PfO4pB|7M1kV|6kmDC&mc?T%A3Fnrg7XovDvuNd0V*oSksp_x9a>W?L-??ai3ZAk9h9 zTrGF&xhEfYro^E-#ipwj9UFpDuaN8qD|?V&>@Mzy6r8?`B~CUrEpAy8IsxfP*$Iqm zhsG3o<{5X_?c&oW_;*({TKp1pU7QruX_STyJ{-SLzgwB>&*yN9o#gK_8BroSo2w%jNyJM%7gFUpZV?gf@#NGlBKe|x)WjXLZ$dXD5XH}As_O*>fY zn|r%2+2UG%_0&zr6P-2txvhkrr24*`zL!s)w^8i}rT%I9+PUtzyQk0Oe8cbwlHV|{ zz0#9XkF@;SZcR8O7l~W8|8~D^curE{k>sZFp=ad#*2^)|`faWs&6paHW;$M4%h`{) zDZgD7pW5qgmY`gjEkLC?4UUOUS=kK%4xi3}-U zO`;M}e}18)nP#Wu;qG{yVDN_qa=JU%6e#ujQjg@x3aTxz`ryR;QWJPm(kv)x1a39F z?oRSG^l7^F+8RC0E2vh((ho97-YrGb<1DUFApG({j&oW|&Nry@*YFI=uhiO|Ywh?W zzXK?Wv)z+S;b!?Oay~a-1ZNX&_8vIfEv#~lwmU8AcWPC4SZTGgROowgVr{5FyGjMg zJ2LwW2iNo3ByQUNP{C8}-^QM;)ZZOUD*_&WpTnh2YKY zZnz1Jy_QTy4A{A&+D)yUD>rq_e7)}NpuX}K_j+e7o?6wxicr#fEgjXjyH$h;D*m9F z@9(J5*-fiLsY@)+)OzmmQYl|ewNyI&6wQp@fPU~nosVlNF7NNAzd_VjUYCxcaOXl+ zKxL%r5SC7qj(cee+R*Ud3KG%eFQ)mtnmJM|wG*+Ml;!L=Zq@p=w+!k96=4>(_XK{@ ziJ-|p-kW^jIf#x(o;1zuZJF=8sCvJssW&KLJY0F%=NC$x9^p+`P7UrlN4R>dbz+HX zjMq7Q)jhE{X*^s*2u?-W>vp%Y2u0Sr%X6(c$?4SAF|{TsMPIC^zjyyKPr0RgTjtRi zn|nY$%%S81Ad`m9K@wAU2TC}-Z8(N6Y{zqvGlS<|_yflV@?o7IpfrN6UXHXj?1Ti> zEiEYRkO(xp2P6UbUT?d-@=5LbQouG$5#oBOSZfL;%0qJBmnT7vh4XrIr#xjEb$Rz^ zFZTKdrztLi<<=GZki>J;f-t1!4DGg4LsA~SPQdk2kM+VBS$o{BEx5^X0>Yj+bng46 ze;41NorI>;5g@W!y$1wEz)d5sc2aoJb0kZ07yGkNIrUZBrqPQNLPLau(hw zeY>JEwdcGjDsse2*Ynul=tjKHoj`xTVe6momVW#BwBv4q z14=%ST={#>2k5JBH>Zpcsp1Rxt%8!qoYb=SKkuB^ue_6L``sAsvSFQuc(e^8KhngIipE-uyY@L3!@lG=TgR{!nUrjxRI7uMT@|Y~BuR2&`%vpsB;I%| z8)Ki3=Od2T$F}X1GrB)HVaOuNGvk}DKaTDMU%oM$T$vlQ$+_6*rl}@%$7Ryc4NCsZ zT&H!dQNCXGN@1R4%fy}>!}FVO81`=FT#Os@W40A%``v;NfBwA`Q%Xy3FR*pcJ98|LJ)uKy-=ELaxe;7Rc8@I& z@`n^p4odrML3wr0oe8q2`<&*3kQP&?WM!Op*M&TqcSq(7c0VO_rP&?ji?enrh5~qI zHcRom*6ejI;sWL~xKKRd?`xLgx^rEhcc)IW{ATy<>D}yec( zUM>Jt@#`9Wu?LoX6zQz&YuXDE<6gJ*bF3fQR;tP))%Cspo)k_RDVs;{LV|Nah}WXXexmA9^c zJl2eoe)3iI)jZpI=Uu_zUWyQSb=UQK1UIc|Oh-NW;#9li)UQya!%`cnxwRU-lk$tnvE=na=@Ys8kt9w2r9C_U-#ZFSP)nd)a z2hWusNy+~e=j_wGTViIO=A9H@K^>)xpv3Q_(=qo?$BIPvefssH?W7h|%oDx#e9D_j z_s;#@Kc?SXuh_i&*q)Y z*5GE1X1|)?GyIfz`!js1=L`_>6ubT4&;Bl`l-rD|{j74<##|YLsVQYsS>(jN<=NdXl{V;9r9hHa73X9xNFQ?_~L8AM>Bp zKF`J0#I1$$ymwaPVB-8b_skbhHZ1W8 zRd~BslTm-=7aT+MPetN%H;naMP5+~YnFj5CNH_jTA+$rnZ`Vc zTI{pP6E4e7i5%Oq{Jy+X)|f{2SZYTiX}R8$NL8hKQ|`!;)V_X?0c=}qJpg!1e;#z8 z5=!n;G;4dQG2Y*iy$vv2t2EdO@-+_nSmm0nq{K0eQBSPDD3k$+TiW}e$Cctmqdb-> zktkapV>KhcxI8`~H80YJBH6b{SE2GrS@u+Qs9s-c`ji+@ibUj7rem#|P&8&O~$Mtcq$rL4w-XXE@5miRHC!PhhUfu+LC@ChShW{bC_< zt}k{vzhT+0JDFYimfKAHTbnOUy-W)(>KrkxVH)Eva!=u--Kbo~+#%r_MNa>YwM1 zy6Nr1)=BVB9kxzl1?#-mPEx{7hlHui*YazZ{p~UL_3_*Dnb!vpdjK$=EcBs>2~zr- zRT4%RegYUYRm<+Z7PSGWUnmW4RH3e^t>u-_*I%ib-%BKm$kN~zOHF-!o&G|hjB;ik z|L(glWb^yP#Pm`$X8<{tE;^c`GL++K@66Pso@q^Zv}P|-a0v&ePmp#!OffU98(E#d z8`i2el>A1q3o$f(dbeSTUb%M0l}?URP|ng6rD@tl-Nc&tcl3K9T%ogkD8fiwe;^8! zGccM^?cL+lNuckOw69RIK4TB!%DQ8@z8cRNR&u_fdJpERRL8_)7c}YNoC~ekuUpSu zF+a2X^1kAkNG`ni#N6}BfI%|X-QFXEna5%lBwus?7!{Xa zc&XeUoY3#J4Vo@?a@$uYKS|YoWq6Y}8tKrscUf}w_KwImT%1;N;r5wa`P~}{P3pW{ zxXtJJzN^RNK0c02#PUxd0n7DEV>YH0jfL#NbeI zk7RbA_6_SPxgQhoaoRGAL%Mg6E#7m-zW!{lcjtOTSrhz9w;um* zYv-1$%TgTScaP$T2~hWoWIPuv5Fi}^!XTU3dsTiB)j!tR(vsRwYv=C%ySr{#S(%ZM z^Wq9A20q5Mb=$Q6P}Ob~2bkQs9{t)bx;5A5DHNJgMv=~*ZF)sS0m1Q+N!Ao2wWP=x zT;CM7v%LeaqAm2+?7fUSb`eB-5CFfxBIM%G;dBq zYr}qqD1CY}4dOeevmVO2{ethJDUYo{7}<1!?JlfXlwCwsKFvE7SJj^H+J5WKw07r~ z-X70XFUkM1{GGa{7LENW#kyMVrT9*YoH*jGF>2m1Vx+J1T?(&Xo|8R!-%AvX)w(Xl z1!EPPSD|^^aQ#|>g56lyuSj@jl^1lM7HPyW8Js=JF^0Or1md-c>+!uIHII z!rfJrl$E3cqW$p<^?Y+j>1%mz_jGkeMd_L{LPg1J=@wO%mGAL;JOtF#^@`{hO{PMp zS`iCr+_`nf4{r2c9ZPiy_WUVHqjq|}J{q-m|1PPBaJss_j}J8Tk(BxKUDl>wMw@5! zUCJf~nxHldghEq@*@C1K9fb6Yb47t(Xq|8S8i|DT^_1GbP0aMeZ#!+QBK!f3d88iM z^AQh25|+;r){vye`NR?t#Unkrtd_{klQcl4TS8Y!QvAdceOSR&Q#$8L^qM5$;w`D4 zh{7hY@3lc%5(>-`Q12_@6_mum@=9RMj&zV&;7Tl!Js=5MeN zchfINzGCFSVv zkiI50XTyvJ+9k$G(qasAMyfHsIfXRwbXsaLFM{LcOG+_kBn_fIX(8p9Ym!bB_~iaf zq!M%VtQX4OocU|164&k_8DSs^WJziv6%a9&Kx`#iTUcj__MN!dp%|A`Sf8{uP1dd? zp=(cTzbwOb*F5xUp$~RQYojX`Qb&(Sf>bCXdg&BQr;B_Vqr_-YAzvFI1Mbp6MppF2?#>3zGJ;fNM5HU5AU8tM$|(i_yI`?`$h$5wkKorolfOfdd)h}jo3f7; zP%g0aM+mt<9GqeaiDEbcnJ~mrtMr6Xl@}cWP%#GplHSAl)Cn~o8O;y}Ze_Ux|Jn;; zYRJYmTp%-|0rlf6*{D>9mE zD3d3@xlugpND6f+vpj-@#lKT9t&my12!rX)O{hyb?-5#S{%Qs2HaXJ~27ehNP)_DK zUPTtB%CQe;Me5MI$=*~s_Q-?mK2{IqPc9CH+c}^OZv7+0VRDm6inF&Ta(Z#dsaX1= zW+moDQBAt8EZTMJ)|0s!$09h7mJT$q$`UzmU4*p+IlJ;D#kHJlZv{QK@(_!+)X1AF zuJ{ufebqHGl>v zr_4ro)?VB>K63cloF93CZ7xeux??-n@VtE`XDps^Sj^>3(TxRj(Z>0>l=m38lE&1C z{JyXDF^oZp`_;ZRp|)iu0ZUP~Uju3*R?x-(DBG{?;{3kzI}%8P2egGWmstkeZYHcd zb7D8s?4H@PMXZPGV|Un>aYFCTQyAMl{D$+@Tziv?i!*W;vRVmwZusRl?#Eqh%V(|) zc2@mPS*CGkH5qcH^~&!(>uOhzQuGXKKy~xB$eyWg!)s6f##2C=CCYt6np-){wLRT4 zXRJv!6$N19MPi2yX_^|b?aK@q-$JG%$bkC>N^9-`6(erTeJKt%ZJ3viIL5l0VDa>e z2o@VXn1)Fd&-|%SDn`E~euoa*$%L9`tpb3mDg(IoyS!_uax2!V7^Bl1XX8uE0c0syKbB>+%iN@*vb zM(V{gK_fqs?u@sucU)IzGRD5%nW(V!<0KA~6ZdtXStSim;=XMi+^3LtGg+-TbgRmA zC;oW2m1LMFR2!pp`4}jziR~qM^iNm@Vqi!dzG#SxVPDPp2xGm#OMuN12%68jG z`jBCMtb+^+Htr-tdnOl7l$0qwAxVWcGWc9orp_0;tKw;ax>bQ%P`9!i0kz((} z7E)cBU2irCwn2O+weB{E)Isgi9kI;Xw=JW{>!I)ur7~*2mcroL=?P9^Ri%YCc=f(* zH8rk<4Kw_^*ty3$&Zd)dwAM7Af%!v#xdmNKk@QPWeq+q3R4lu5qMzA8ZD205&R6R8&jTUZw(2 z80HoBz6R{LsvwhWsBta0i8S{87SE>cxfS1nMTP&hX$#dFVDs}zVuSMv+{zB%q_VTK zgQ7n(*$AC6k~a%2vNO7m^W45!J_G5yQQlvs@fIukQE?0Q_QX-C=1)lm-g9uONe8ax z(g3IVFmqMPhFHY`TRuuH)#uu@AsP}EQj$_zHd*7D+h(bbSno=Mg?+oD8LAz#(dknb z?Q&g76_jW*o1p%THwic@A)%s+73}cYLpsFVD!v;wx(Y|C8QZ%}{7&^w$*#-Eg?Sqk z-i6A?XS{Rr+jUKYmU)VHsTe}E$1MJq*k44luiZ^WF$mR871PjurYOkW&s07`r{pM! z0%-V=Dnl=-{^+xA!t#O?X9>cZvzxv=_DE5wFYk&mx#*=inNEc0CpJ!I_0HvfsqBND zYiAr5xo@iBy~u~Ml>L<0-SW4yC4VrTgjF4+4Cn63yGP9lxjHbRv+9XyK)cJE>Q0q6 zjcXW+_MKhBxA=+YNE3^whqEyz2q zNCi2W*c#AE+-um^{vErKpGlx*k_{(dpuR=nc73M`Ku_#)!2~BK22wiD1j=v+MVVQq z6DedN<=`qwT+1+*sL#$+gAm4ct3vpbyg-4>WbX>}KE+4U-Aln$(%tq3|4CsY_SP$+h0n zTj^8Mo$@7?W%_d${(vsSg+E%g=SyX6Gi5+Tajx=CQRTINmab_}$qtI#st{KJI3T}N z5QnRtl4#S14VCB@f+R^rb+5DtbFJo`?2aa``8K@Y>sz7?IDwmXG6uCZKV>)fyexy$ z_BFj9-hLVX(x0KjUrod9%3~^BTb>$aJ-I?kRBO$yA{1QO`ML-*{O&jt2b|+_G*)qy zKeg0)b-k2`q=__6^+B6mnTZ;+styzE39!CjFxM#PorvZrgzM(_w;P0sQP z!-#|2#gO2FD2`+%tMOo9PY#PD-msqfMwHR6)U6B&brpAJ*8uC=6>eQki*lb;r4#X7 z=me&6zjC9$s)gHbR47M?xn6$As0Yguii)$%ds75?yK6{E@}1Pe6|ZD8ad^Cgq+8L4 zr*7@Ki+fDRfkbKjuuL9FJ4ff*6L%_OUS%?#-xY_#H+xJ6=+O67Nsw50j~P#Sr)gSl ztFqBu0xjCmT&6LmQ@dpvRW-LfLs)NFNGjv{*eogEb?0mBG4fez2M`P(4O;tP&7d9E zooYk$?)adhcX7jkzbJKA&Gj+8KE3;WD$gHR&CT0^wGU}jvx|!k_g;h1-_mj|T!lE# zN}Jh}Qk8KlW)QoymTg)?Fu0P7GOWE4e~sr?s*vGOX`uUkhU; zyJbGFfhq9shI_E#q{%!p278)UKGe>1pVj;+bzESTHt2VW9^8)+yo$f&yBvf+nk1Yv zW%kbPqLc+%{U^eGo7mhaxh~K0Tg1LpO4CD8zfJl7gO5}ABxN}G+n=x24DP-b@4NMs2mR8ozqu&D4)j30^WFfL>Hv!| z{z`hLHeB^?Wj^aE+ADPDW_FLuULV)?^VL*zS>1QWI1InfZGSfEbxrV>lZ)t0U|wcG zt~MO=1$y_CjA1HJ&jb(odL-2d#~hRD^tEkC>PiIiF)*TAzbYwc)02yC#(VNa;i3P8Eu6&9E`~qJxIM+zzHzyN7;P8`kl@YNO%h31ls= zyR}@!;p*=7S^t#!1Yz3NK+UPraMV%Qt`C~%8dWG>bel^#GlWeimW)`2$0Ql54<`_H7C zb!@j^6pfYcAxf)B+ELm}=As<8(!V+?*EBxXmW)SD5*@d6V2}|QkN%K`BZHD&+JZP{ zs|szfR*!V%SHk-MXWrljf+tU{b>3bhri znfoma6TCo0(-Y>QBTa&N8!58OFn=^jptdR0imnjG6it~7P+Z_hVp|1k?MP=26sR(D z{7!f@O8WdVYDyH$=nA3ktASzCWzG{y!h!vuXzKbJCnR{KkMtzh6-_#l9!siDv^gpe z1F^!FQvm2!sy!4efeIDSoh0ASiT_cf6uiY5lD0oJ`jN<(N|q(!{TW9I{|-g9x1v_4OV~_dptLH#yLU2({(#T z$)dQgbMyNWcP_%wX98sa6$G^l#C~4f8I?*(?~yd|&Qt?*;AsfWpH+lNR`d5+p?}bA zl-oEKnc~x8UCsnPi|V^zwG?S^#UaHTrdQgeClujVLH5wdc)uyZULhfH&ufKJ5~V^@_-a4_KB`t}z2%tV zCDmQCsZk!C$U>~ztT^Y^<~t>|e6@9LR(kQ2f0@rPt*EF|fg?plc}|{T28eOi-C<0b zxAUupp4D52p%=ckT_DKUp!V|bR2Qw@VLD2vVsW~IIXl3jbEH_=swU2qfdS&QZ$3Jp zs%(qicemK1*edp$uK{I&3eLT&nu3*Zy5C-{s{8nqHopr12j+!;S3E`?0EeC;a7XlY zbHSyfNi<@vt1f5>2LL#3LZa>Qozybza3ZTbdn=yyoolKP7AS<`-TmmlRy@^Qsy^R|-U<^B z*JM-0uJF+wDZ^r*@0{c}$1^!2XsR^~JKvd%KZ=F5y_D30(p(x9+nHyQEY~%AIV}Xj za9#Ne1v5|v&{zypw}G~Rm4xoVKoiVEmSr2)*qA_0^5->KowHxaiR$&WX#+;})0<#v zs;0j0bZXPa`lzmIf2Wg7Kn?x$wCLQqG4u3Hl|;+c_1dfIANpGeBnkc^E2POD-fo|? zXa%B_9u4b$VY5@80cSH9M)gk{M?yVMuC0cOuBbgk5NHa#kX9YqdTp0 zw&7A0-buGX)hyLom}NW;)bLS_dx7E#3`*XH+qyuzmtY0pA-Ne4Qjn5>IkH~r1*f=> zJ$QVb{h-9L_0qFpqyag}Y>VTt z^DmzE5#`slWvGOFLoGkg1Ryo#s97dr(4DiJq@k+pF;ov9Qcs_f-WSsH)+Z?=t&jd( zrn1msS-79}Y=mRlBI?2fm1kN^o7=imRZ<7YB4eq+#po2)kyd+_=dwv13q+m~fxNai ztymJiTxZ4W;O!+yNRVghMvTk3?mF6idQetlM1o8peNpLl(Ye1 z_LVw-5=m?+^B#yFkjkA1-R7^LATsRg154q6YCs7)YJf)C)szOuV~)<@VUje;H6#yQ z9J4Y2EYrUWMAG!z7uRa`ar{*WSMR7tUCnBB6(4Yq&e5oP-Ip~a8<{O6oiBt5k~6c> z-Ais8x<*Im3}R=0=zw7r|8~~w>kR@bAqzM@Tn8g5p{tu1~gk2SLGk<5&P)SSRA`j*9= z@<lvu91dgw#fiF(8*xbS&ex}Nz8z(A@q2Ida-0z{yFq>l?J zkhgz56~n=0cmlmUXA7gFK-9u7mW9LV*C-kn_d`xwG@r~kb;fuMCLt;;ZM%^rjbZ5( zq#$4InJ%azU-XHj0lq~#KSNsNI`Bwx&hH0{qGQA^wr@J{tu2=o8J%$UJ1@_kaT5%3S z%UAX7dGq4{TuCiPN69#;z_zAc7W$nm$}t`Zg}tvm8!#BPXn(#z_WGXJPT@}Vi}0@> zOICP}eDNF~k(hm#o=_+i&AR7Bp(y^9q))Iv!6wO^6mCf;C1WUZ_qBD$?_L|eHma>F z(OJoDri3)>;4Kd=p@DtR97E}F&lU@~+8g!0xt)?UCk)Zv{@p9A$5jLK=DF#yg7MyK z)t@8ChtxnLv!GrNMNQ2L<4JMEtsq(ugQhtBe4N=TYnJ2Bk z=I&gA=Ll;Q3I}1KXsg1MVrF8CHE={>$|U1id3?o2uoKJ5GZC&8C~TAZY>Y?Reu}nV z-T8P@{07ziO;=Y5kE0EDt&7en#kios@lViHd3=PcsXS9q7@buF_1QOK*#N8Nm}nsg!1u1r-VTR|f=*0NNrt@oJLB zH948|J5P)HlL!aybh_69jwC;TP)5eZJlcP{JqAU~*&w%GP2#A}m1 z4Wa{RS8qlyT`$Cu#*Nv0NS&uVjzITrQ2;#I1wQmXCSFXEZAW0HcNJ}^T+pv<{4bOvHKCf=Ge}Q~Y;}GYLl-3?;J2~-4g#P@LPN-Dx>&;&0XhS!l z@fppI7ZPPM`XzIYYx1hA?Kp4ozmKkr;P9~zII@*nd!&q%YCO|DKm5KIvzJ|FH0A+H z=}6JuLjRIHH48l|s^{>!jz%yG|LkbMJ!kc-Z}?~1d`9rjyMiZoRAw4?#w;XV3i`y+ z<>QY|9|TP0em_#VZu9{QfHErYcm~kqygi(4gBH<;bMj@1(JWd-w#AG?jn@wQz+{qmFIlL0&-+JG`c$-HI5|yvL}^!A zA>lv_Q#RHMNm#KaIMFX@j_H&-^=RB#&^X&}fE0*hLSegU-=^% z8Tkf6S2pL5gnm+vo~{jN(!}qk*&jlyE~i?@8>Vx3@2L_74n*_hHm z%CU^y?UEXV=DJBI(W2$Uv34SVS=ZU7&;iH|H}VtdU6GYaIq9R*ABw#rJz2_wnk6FO zIZ~XFrhlgl%(H(tky}q@b2G`E^oq|l4J)#(epK^B7UlvZuzjfM`W{++a{ z=>7^CcX4`qw2aQNvSfnf4(-%*T11mP^mOj+oS31>+-*Hss|l5Hq(Q37D7Jad;XU)! zLV83SE@C6TMPbf{izOq=Z5CGfN1r8(|Iwp2SnO4whwX>H@0~q49Nk&V6SHsRe1Ya17Se9OKdR@Puoj!=#+ub{3qLt$ec3}dzi*7huR&Yb;ZUufOv z+sMgt=SYsNoIV@3ug}UF=>vp(Bqds$^*N&JUd+3}ZnKw(l+R4xmvZ^^8Z;RqOCA(} zsleZc=yV6Ci-&4Au5oVek-KoDGoGE94GT(8`*LTH4oC2BC@j&Z-yUSXoYoYGpu)(J zf&w{?no|j)J(l-`456~6Pi2(xz6q6#zGW(nu}5Hik_THMkeW)cq|+y5WJLQrRVM&& z;gLl2n+NY3rnjC-B^`x3aV?I*8(3u{{AWW6z9UXAQ-KfI&1VvYbtvfjc1h@I-`Py& z{nZ5%4wn0Ne5O!s&m^kt2rEt4U@J`PQ%*>V9!i$hgA`I8Hr@doe67sm#-G|Y?!}REtc^*C5n6K*l2x?3h5bLzC(7)Zit!vST zq*9JJXdfvk!aJ=8(K&|aWZXGC4}$&~>jWeBNJooloq?>jKBTXCkzpJklz_>wehjK)W;n(NaEQD(tL?BikEA=}S{zXasG9oL4BmlOc5(U=#9+W)2VzA?26{U!#=eC7?7;mInb=lkiuHEI$SYwG(Lf}ZzrchEx zid7JZ&LhP-3$r>yfN>?PKi?TC`|*_YC52mTP_iIzjae+IOy}LVZ}xInT&VVPq{v~$ zHiJK-=!6SMqrgQl0BKxl-a8qy##3ZTM7Hy_GNMPfEs(FDXZS7#gcTW{ufd;;$ugk5 z$XmK;GnYBJ0cpq>DFYh140(yPLx#NMNNvV5!&*o@Ga_^o(v}RTh4e_?TJy@MjxAj? zO=<74Tnc0zVbzf6o@w8HvTboRPtg(S_2Oon=8uLNt{dJQ1<6B7UA@zKUVhNwf6d98xJde5AMn8U6fEQC7K3NuJ z@wYVQLDF}QPf4>W-agq+ihCl?3#`B_TRVT7Bl?$TMUjSulf)8{HA`Shb@rzCSOHXU z?mQz=q_t^%xfY17HTI#i&H%85-F77DIQ+~-);x(l<(`k?TD4A%9Q*2%Tjax6Y%^9* zsr>HyOnpCyo3igWajAyUJzIC~&e<6nfJ$n2OngpJC^d(qYiFDsQ{DUyLI)y=vu#V~ zyYZQZ^fmTfX=1uo9j`mK1gzQdl&?9{#VU)=>BH|k^RO!x%f8g7zw_8U__g0f=+2im z&~m^cPMdmlCd6q|M4PUp_*qCQ;u;HJ_Tng9NXI8v^T0mkq6vgju;z{CJ2Ma&cfjBnxE+36Jtn$@Eek-f&ZsI`re-#4))M=!;f z1>|x%0*MY##C(QXG@Dpsr{_;21{iY^-U(`)+@5Ew9hVM&@%a`d8>p|FApJAiAfnVk z&v&HgT^N#Qm{VuoMcXHHOV^_7?(f0@Ir~jGQol^3n0Ie=6^Mw_CPn?CpSGiZXB9Zk z7Y>0V1sWcS#M&zfZ(rT|vhGuQ^|feI^D|=&3gFJp&{eLtd1Ym&C1d`uXDzgUUyg8Qn&Vu`_=LIRnv#n`^K&Dx0^n{u{K1XQnk0Sr)U&k=bw#OvSo64SHrTt$}3{ z(W*Nk%RFuSH8cQ~6o(Cj2ESA>hR>Fu3s!!)DOXWd1WW30)M1ra}qO-6BKuI-CLKTi?U@<1~RuRhUt;w{wf zDN4$|pHbm-*7FDNe`q7#UeMqbx<}1(l>pAqF0{2et7#(JyxMPT9p56u9j#d|{c7k} zvJax?v-1XG_F%`T?Y?s{D&l3tj_AdVm$m?iJ6FC;?1wQ!Zk&5#9X#BA(ptjR&nJ2v z+I@UPy}ftt$5s$N9*w44gwPw)*%fnLU9>yeZn`I|nV3tN*{WF{{TW^UW>?t6MY@?~ zk3~6#(GcgnFouy56-n&4$9FQ=S>?qV7e#T-3u8M+>e#_kbBj3BR00cj@Vr{{e9P?C zy$35Wr?uuet(bcpix~jmy*8|+<0O1DwB-F7`+k|qTu7gb_<1MJsVYmII9X^Hie8#I zd5<_V#@TRz37SsI#AB)a5$SXBK~Ug*78Qoa;t=5mIcKxn^sKXv%kZvn=5i5Uhe!*A zUO|8RH7m;U+s_ItB2|~9*OKeVoUeYaoq14`Er(-?RrY*bOXq!0UflVzSY=@l zp06IHd&O6i7O0)nnNjRz@CLnzJrq2MMTG2{xm~v^vtOIa{GJ8_K1x0Sp+*rH2CTNS$jZ`U(L1 zNb%iqTB;R)&7ALiP_^N6TOiGwbRc-1M*Ed(-J-(=FzX{74ZMiHz&>?!=ezRTPzwz) z*0)%tLutbpE=M{sL8`3{O0>Ug|M69#evfoKa+dHw5`i8y4wmn0<;pX z;wdGDMHRKdQa+M)l8|VVCD2s<-M}+T9y$ishqUtZK1Bqs)Y_*sdHac80xlU!KW<Jiy}!v1CZ1OypW{ z@qt%W?G~sjk5rNLlpv1;5e93+;m$mfiv@RcmCg}YUG_62>FwX;|NiCKR9VSWG>MG$ z6oX+5&meg!zI!k(v?4}=vt0#yL_Ov6ZA+sxLyF&FCwNy`W)3}8Cyt{dX_VqA3H_^a zA@T-$NAS7Uki_S@v$eRmNkfZ^`4zoAcxL6!XoKE|Z>eV906~Av>=Po4q_wh@AtoKv zQ3>)&?u?m6JQRHp1eM%5swpW4E}ozby?`R_me>F>Y))ldKR_kaHUb?vV||MpK`ljzr9zq@byzpwrE Z|NP}2fBW-qfBuhu`(LcsJ3-3{1_0oz`Y8Ya literal 0 HcmV?d00001 diff --git a/docs/backpack/pkgdb.png b/docs/backpack/pkgdb.png new file mode 100644 index 0000000000000000000000000000000000000000..9779444b42e642c1f38ac058dfc992cc62a4b2ee GIT binary patch literal 61693 zcmZ^LcRZKt|Nm_yJCc>kY6yiwC?gpyLNd#&C|mYc$f#&&*{LW=B&Dp3kO~p9XJ%w% zkMHxYbI#}Y&+nYaIh|8)_xrxD@p?Vib%$wbsx#5ArzZ%4>CizH9fF`tA_$6HS{nRL zLG@25{6b@KL|uhgA^%RyPq~TTp>sTFc!40+n3Mldq$;MI!*8y3Ii#Vwx}An|^_E?i zRyD^E1RrroWxuXR^GKV!f!;T&)xX9TimSAut_JWNWToEx>R_h$4yl<6-3{l?e35h? zjoz){bSrH`*T;L_T}Ag&1KAuehVD8YULjYgIGexid8b9+tY3Uef9`_GmwX4`y)*F_ zbd_l-1n}2`wGYp-vasT>1487#C4$!eKfnC_z5o4D?QqZh?_skHI~A2umcuGr&JH)E zJG!_8Wn_pkTnY{4QVtt1^`03Gj*MJ$f1BoA>U8MR1CB*Cwl1x8*qZeIx=}UOT*e5f&QCf2)0;oSYm%=y>~C4 z-T#7~9>?-*&l;D(ud5D(Fz&auwk~KXD=)V!4x+oe>&)T!7w7Ek(rL%5**0vr@-bSZ z6nrcI}GiaZY~lU^WU9a6l;Eb82de=)4y=Q24@iSkGswRviOf8bCo6 z6(4W1xm-g-Lp4n=z2=pT{_NbG`IlH(M|bz~Ya92jYk8ECQqt1G!?sPcv?>IAE@( zM)M#!c`|5I^x;*+7CE_UUjN0w1DBcQU6-Qx57a!?;MpMWwXQM4wEW^K265|}MCAm1 z+Q8|bEtdUX;!+JV1#XL(Uh`X;=ijk|Y2#kE(!Q!YeL3&k$J87h#be{*Y72b5_j&vx z(v4q#2xHqu5NFSxt*NUkSz4G$SikwgLVtokL15Ns85vdPCi=!3P5sTAUYO6>XE5br zTKd*pBp2Hgk1d-wC!VW&{31JBW$^2x+H~VRrRC)!Ifpbf%I->7cK-Z%wISWua=g3D zWA<0q?#SWcVFn%^o?APNIo#ab?#g>lGnm%(lt*5Vi#yd>xLrVi(syB6HP^Y%?CjZ) z+dGUO*fc)3u6xY1X`e@w)k25=%Ek*nJ_TOC&Z_tPWLQy=5*HVj8E!AwetW^$&+A9p z^LcPt8MhHGuj!HPRHG%A*GQbMV98C-d0+dw!!JT{Wsxme?W(eum)u*I!HZX}FsAAX z-x4$3#LdkuRQK)$3>Q$`yKulUmMFs7J{x4y&Ao7H6F(lq9j0stYFjt2x!w)E*eUI^T`a3U{rntnB`DZ+G|5w=@9} z5s{7y>S}8AM~+nOYfM|R!bQS=@+$ZUJ$v?yn#itjEwGwUcDO4|GOxV%A)G_jtBcM(NG3xJ<+w89{C<_xpnJS`U@8> zP$)e!eyvH%Uy7{~WR%Xa{;Jx^w=Rcb6?}~dmiG4caNiYd;3SyW^aiiV7`J{N;=0>9c2l7@*+`&QYK;JRNrH3++X=!N$-^ELp`m)L+d8>ZnFZLE}(NhGAi2n0iRbLVm#dL+E zu|wAl4i2u`*@3I!&Q&8g=AN%%WL($bI};Zg8F{BF>*dQb+>y%4@>1Cv#YMhro8*Ow zP>iUE^2_w}bjFeS`FYBKn%Y{{)yx~B%IRroSx_{>?|0%hbnBm=GA39G3JN@*KSA+T zPS@ic8r%A(5m|2H!(nSj9e(>TyLL@0?OS+fUuP#DQK8?8EjHRJtIG1ud*=Dc#;h|(FykGCrnLMjCr`$bS0u>V z%y6Q>e|av2;PdhEG4V)1HxqgOt+n+e%0g0dvS3zL7Wr{;Ny%G*K9x7N2<+Z{{OEnj zLk*#4&zuPx8L{PV=yR!NH+L7tYxYNsLt=9BB{bt?l&d#xKi5-I zQ91Q|U}}BiL^VAWxvq_HNn3Vb{XrPHT3`}3)&=-P5AcUWxS zzTIPSHd8=Gfm?+_NbZE9-=fU@Jr2yrj~~A!qR;%Z<+b`H8m7}xpFVxM6(}t$I~V+1 zaPwxB92VZ)XBiLQ*%>$H*7*F?rFZZ4`uO@fbrr7)x_r5c<@Zd7e@}N=1QD?F)LViG zS;Kn`MclF^gvsEA83mr^zLX6O5pI7yHa3>%oq8f`Rz$QG`0_CENS7A)E|{5_X{GLR zb9cXd?;bbyO+t#47XU?$T}z0Z>rf&d*dWK2`@w?;d_e&b5ezhpTmheB_LNjrF%X^I z-2yZD7y6lXbad9OTuRhS)6OuF_pEktb?x)aW@KVwpE2TTN?=?d_CDJt@WA53$IjRK zWJSr$WF<;V!`LRDt&F}KLqWH$6+nGXIhMddLql`S&Xrk-nuaDEtq&VIPR`Y9D0i$q zU!<`5*@?8@n6n+<2m`*y5ZTq);;c2Pq5tja&sgs zKZI^MavK}pe`VRZ1x={Jt~vXh;Phx)jDz8pZQJ?{{T8O}oB$rIZck!IZze*&J~|Q+ zNVPf~r6SBE-zyA#?Bk@ItZdjztLkv|$W3&XmX@f~rDKIFJMq}PR`ioUKHn^FePwfJ zkx@WgTnn4c$0yIx&5eTyDl9DQcFoJk$e6|6R(a?4lbXZ{}28=a%q9zumwRxDAmX_H09Z~cJwr*8ZQBw=YBHn&+5WTT1-+LxVEtwT{ zX&2wQxw*M8l&^3!t)#Rx5rDVef-hgb6jxLnBv?*7)n&z_9Unol6v3RZzaRV(w|8O@ zE8}KWU0q#SYwm@z%e;O<>m{xE^wN#Cpd8`zlmXTq1^L}gm}O2v1$}0cx)be)VcWKC z<~BAW?=;schXVan+W613xvT2x>K2>yCBu z)SW9=Z^SdcZ>BjR9DP_f!{pT6yLZu=zI{89Q)>Fo%`V>ZUQA4cW%)Jv-}h>yiI`ny z=*dk3tY2nXpQ?=;!n|6{0q31zu(kX3)bQnFBGEc?XAsN6%-EeSCjfh8TK*8`jp!5d z^76Gnr{haA9aU;tMCoIV7!^RP-aKH?(D3lJ0FQT0sc>^~g`yT!g=ja^?50}Hyw0jR zo~*kT02*1+?jNpjS1)-}QBt06`m{qpK-nZRIy#z5>in&{3cha#zQ0VdrPc-5C{s8# zjnz3+Zxz2#9L!+RT^eRl8p>MS*r;FYwQ`6ovSiT>2?+tTI1&^T)cbuais==eJ(@Xw z`f1-DpvHx(={H+?dV5FUI-&drLV68X9&SJWn3m`+=k@Ph6Z98xGV(|tEfAibnc=Lh zt+hat&SL+4W6P1=9Duu*jC-%Hms*?e_5061@?KLcC(`uT$MR?58Ly!GS^VmJAAVnR zv9R!{UCMB?emS9nS?=@viWTsyt0Wk3gi!hR^h8-k;j(a!L&r|Z^%?~U6jwIx)zdyQ zC)upG!n9tp;^j_^gQR_{Om(Kz`m0=$)>`rRD_YxlbKkxVuc)Y4>D@&3MdR1@VNFd< z0aoZAU&7f%YLe9>eHw9DS|D5PE0YQ+wnq~b zHljd!=Bx}PM>@{_GB3-*)w*zp2ag@QjG70ub-HR6M6d@nnFu(ZqFEWDWdwAf+)?1` zw7lp^6rn=zUlC*dB+IuuqGFJ#-baGd`=+43E%fbsWmWBIlOpNl}n#+t7P{R415r7R~?=69Hg-@~$zcze(7eVlMko zc({0YCier`f|cI!B9=R@Mxr9$7B!quUO=x(I&^buu)@q6r=FTOPL@8u-mk7^ti&!B z`z5RQ%z)ym8Wk@uFA*j63Y)X{^R_>iSqabK7*k!C5k%muRe&hJ~xOL<6jb}gIeSeYv@0WiC_UIT{eKI`+R331Xm76>4D$kw= zx=(cS##K~QRwVq`<~fdFz)`Bs7+S+P>Qu0SPz%LG43$Ee81q4F0$bVbVl04zxU;h5y|L2dq z4v;IPx_S*M41gI3c^__wl_BqtV=mo^8S5b@Butuby?&1)YsAW{D`xk z?^hB}Ypq}SEqT$94~sR^ef{p;&}xMR#yt-0)CAz(Gox4ZfB~nwNGS$zJ|8?O`&=Cj zII#0~{6`H)0|)b;xzwp;Q%(d`lyMn|IysH%YKclGx`7;sbGCO?#7=|maLKu(#*Q^* z3N9`#ChASDSmJ&|`Lhp_6cyFs*VL4*Xrb3{;Z5>h)N9s6zJ9t7;y@7k?z(&T?hygl z+LplKHI0q^CCcPvxzm#1Vzi?$61#wXNQP6)1c+z#$j_gwYu7$7u)+?+Cf&SstMaj9 zW9c4BqiydlW5IS~RS^N89X;Taz#3f{CqaduqBu~R8CJ_RKN_e4?~ zde>OMNWtB^*#Hon=nqlNBb+ngOnaSInTSz=kw z!4ZN@XO1RS=CuhNA5^P*pf)*J?hEQ3L7*<{i0VJlo%sDyE!h(n0y8rlS6qWBEB7AD zFE?ev*yhjk>ps$^Oh|bre>!aCMKrIXGe}5TOF`x*}Dd_ z>N4EG6v?Xyx#|0Nb2K>z)madg2RD+8Teqbey%Gk0r?#@{w~#-k{VL;QMFkPHA~G{I zj!?*B@s1%ipoC|Zruv1udla~4)v@x z`dC`30+nLlD{p@AHlm_#RtNF@5gV)oxceqFDN zX>bIJB~6a)cS<%kwrrb5W~@>o00NRZ6h`sgyDzCFzXwDXw`mYXdpb3`fJ$x#RJKcI zqpUNv`n3%dQFU)pv5bfSND5Ryb0JAd{M|i0wb(ctWE=@l`?(M;yMcPI2AlakWoUgY zEG&He{hwnl?>h7Gmp-}7GaP8IUcE|EWLu?&QeIQmpJHW?U;D7zZ_#6iZY6U?s zaPEX;vH8QbjS*xOmXR^2?fd|FM@jSZIs0ZcIfo&k{h*$+U6*-#eO{jZJTVo0m>e73 z!@aI~ER?vXRPaxWIiO;a5Dg3rBtkEkovJ(Lgd*!QP(uL`iA%vpMpu~q$Co$;F)=Z6 zv-|n^L2|iOPX39)TrV5>L81nPkr6Hb(&{xKnVFfb&!I6LgrtJ5@e5i`qSx=CHy+~x zZe#7~Z?-}KBBC~C_cNc%Eg6Y93sGUhL0VF>6uRH+FdtTKiF_k1 zua7mHRTy^7o&J_}?HV%}w=q%l)^&JYi-ECm)$nJH7XN`5F6ENq;&n+EDx&yPPv-9O z--yAQ^17@Ay%LmupV!pEf*%Sl11xLV*lIz)=bBF@*H-8kL(p4AczAh1=Vhl|v!)!x z<|^)x)Q;_1a!%CiDWtjj;9=&c2C3B5)pgU2*r7?P1J_aztJiGOwN3jOE+j3jmw9q; zg6X#DjCbZGA(d(;`#wgOR9qLFtNJq_ib0es1wXEZg;9_qGaGT5tNwh$Gj7ZbzUp>A z7jWwP=2tegNe5PM-n_X8AoY3G$B&dz$E)rc>*%Zz zf4W`|M(ssbRx#G!8Coh*hZeb(Y!|)qIGBVo7A-k;&VCKg46~d#P|Rw1IF(;X-8m*b z1rW;!9*vfBHzj6s`dGmNGht#KI}6q=ASt;H{7K>Y$=r)kQ7luVZ9F7&aC6Ja|pKey9`cJoWEbr!Y50&T>3IYO);0ASFcmE4B{ho2>A*_qWB zOq+nqZ`HUT1U~xXdk(}0$XDgDvKM+~em3vC3uXO`)o%z0cNTQvU;HsQ2-y<*W$e^h zsB;8C>hfURebZ3>4RW2g+?PCeqkoaCDKn#O>{ZWA^63dQf*~HK9!^mMzQRl2tR=&< zNU$PoFU%h#6vig+x5x#Ct_GqpA-T!xJ|@@Zi|K-yKwE!QzqOk^Dq?>6X9U*GM57W0#leJjM=IcvWpBmxH?G6CPfkPnG{;_f@$%(y z+l9IQ1d$Ix8OE=7q6}WfFi&ds@3JVRMO9@ZNQIqek9{w9WjNWs(wUQ#G%b^%siV2A zhSUVi?lI(s@^$dwK_x&-?KHg|?Ooec)YSp8C_qn$01W;3iG6=D(fE2<=gk1L6nrVw zb+~TD^@rrjJRE*s_1AQ0SeUlYf~?Dc)<5{mHy+Imd;3H~Z*A2*X}kMAOr|-uhTjJj zaW&Qh1G@ok1Vu#|L3{e*ybsNcb(E7FZxQ-Vq|T$mnP%j*`KLTFJ~SIQZan$Mkz(=I z?>>N>)oXYasH1iVod{dW|Nh2jZWj!; zgxnRNEUlMkH6VcUptkw;I5;{x@8Z~Dw7Gu)B@E?QVeZdeJY{ENqatLSduhqF3r(d9 z3PiYF_9^-;Teei5!5sjA1!2j6CS8W8(6{h8wXjg}t=rG=#6-SW;NZBu?jIm-bqw(2 zxeV&a?n}wclt9lfO^L@~a4BC{t%Cda@br8S?+FU4dZFKvR=Sats#d*URjS=-Dgw*3 z7^Of9BTWtkoRDIeG!wCwaCR!beE9&h@xr<9aO$`7WOIVP<}K)850Pp^JX-~~po#I# zqko=+z7z5T5dhmF`RKh}cg4*qPkGb60Dzd2%ir`(-+%s0 z!dhBJ#vpiBM8$P~Y{JXvb4i$gu3e{T$<_jsh#beJLVra_i@(Opd8>X6jgIb&{Mp$V z0JPr)8aj(Q&EUEOrAr1vDTMEcH2n-xGXW}JsQ!2X<4TS+q4Y?{97dZ@Gh{UEk3;ZW zh$x5QX#gWi0-bnL^5|DKq4h9`cbMl~odC6$$7$M*i&MGA*ZO?io5 zv*VU!6TQ8s;Vj{%lF%psBB`Q|TR!a@9*zKum>R5Ged?{t{h|s12CwZmK0bO+r~8a&-$(Wh`#iM1Od9`XbH4QQ z^7;Gtb!h`ZcLaeXAVdVm#chN`MiAQC+Rl3q95_G}q4&RVA2XrlPtEsc>-u0P~A{xpx^GXZ)HIb;v|BeJb6Ouu`J4=P$nsqprh;`^@icz)!Vz7 zfb>^Va$w~9OLeEk7ca!ShKEIfCoC?ainAQb(kfg<<;J zcNFYUbOp{5@H&yVE2AeaF0Ri7Mg!z^jM`AP(`RNLRPFZ~E}z zL&j15!J(mU+({Y9G2-K|x&3Ueti5Xz1Qh}bAu~!Y3AEv&Z6p%W5QzZbAilkO-_<4}|=|G1N?o8Bpyi<{S##<<;#y5;L0YzLdO@-NDh+hGG88R94=O@zDShxJnU?@rr>q#fcG$RzQt)>XJpmp6T{lH<;c&vlZ z81(%4&IJ3v;~GCOU`?zrcgzXz78ftVxL^YWp-m-&_|DN(JbbwMyY?bHFS40FLy?D? zT)a3pc^#?}%!@>{0PrZlwr%t-@_~VY;ZEI{W|PzYHU|&V>SdTPDJm+SEb!sZI2dX2 z=Mjt~;lM+gjB#i@lJTImiQ-*^ z!laG1=`%l=0+N4#p}4yGn5I7@L^%9HQys5u8h4Ty55bwXx2^~7>^ueU=i>QqPtDQi zJVW$%q@pwn@bLu{s{H8+DQHL|N{BN>Q3aVXE0#{|(up!pU z7bp|Le>l{0zRjB-YW2(cFYg2G34F5|~9)_@;c%obU>C@4Nj~-R_p|7)JtFS{@boS679-xwo`Hltz5V>fKnn{;8 zLGaD)zF&X-6)Et8qHBqkuUtMZ53mF=@r%thM+;~c0#s(uckq2re#cKxQ zx)N|-BJY=+`{)%+E1dF;P@Jwyg)%cUBUG>n+Ce79I@cHAGt;q48Qu?um4L*cigt%J zapjJJ`>6gnlqF%^{$;F&56CL?pbS+2tk{M)yOt&w15)uywg-625kmOG|?VNh|h?c0o` zvxmMuVhD)cc`N>5t#xN#UofxVECtE3trC2vb^1S5R0w71k7IZTzNOu<_2|VKhd>Ub zwca^~)W319_mGISV0{rvFr5Pn&%oD-vS$JG8tg1Jay%|>}%~`n0t4LUs1kYoYLIeC)$Nn!H z30dD)_SpK5A3vV6Z$X4&>SxPL$K`{kewC+!J8#*fi~`Pn$^eqoco#Halt5qnw>kE9 zs!6^a?89Jm)e=Bq)PRE;8oo~?`b|rL0NKsIeERfEsoe8dCk0H{zQvlP16@Ny^PhY_ zMDj+m3aWLYhN+!*NFXnz#dej+1Z}R+LucrIUjSlp!jD+zX2=(9UgD>1y~dJ zop-siUh1h9|8snU5cIEr*xPgZ874cfd*4~ueW|8KOW_l$17lJ~B$+A09nV6)t$lKQ zn}MMrX&L~kmF9U)VzcRt_4ZN|G9JIouDeeA%}tyk9d0Gf)xUQbWee3fVcBG!u3Rg- z0-5rCQ`4K$k6Mp(y5ij1w~s5`eJAz}TwvV%PXNN#m(+Y9*p?!6Q3ELifRt3TNbm!K zjSjgAdb$||4-}XpG;l}Ewt(ymN>X1o7Bf&Ky-O^>gy61SYn8s(47DBzyM3#be+u2! zVMO*%W67>~^X3hy>^0@s@sQdtslnk!0}eleu0~CmRmaQk8bH%kRCR8LJXSGSoEKg# z|HB939>ce?!Mr}w!pU??jGi{0KH!^nvpyQ8Y* za#TZu>>uz@$U6tqYIx3C*TCDP#8lWI$k}^;w`g)D8*d$@l)d>PI0>_nQ zUr4x=rurTpGJw_5DLMK;swgAxfo0FA&*Y-|&|#QYM;(8;xGO;vB5O%W2^GkmX9IdV zBRq4Tp#mW4EU9HQ+wpeqvGFdHcwv5@jVtS$3;hdY?Lis>7X~4IrN-KSeRwE|${JK- za;dd*yr-ND8NwL5J5~Ti*V(A$u%e(Ksgr(ykoUr8&iOm-@FBF0+Z6TS#29S8Bwr2Z<9CqW$!@!6EaaFg&_t)GD(BLGf2uB#H_;iJR%mh!;IS9?b-IP(2;r@Vb zGVY_Xwzpn^;*%yYSTtEyow`fu%9eADyR3k?fqgs+5?;M}b%wM9=ObTioswFM{99p4 zePg3K8Zm>yUp^rA!wD?o+rv}8e@Cx*WR#vN`z_=nL`{<~ zh$(VG--dAR7f(EuSGS+LdMM$Y<#KCMES7ROuZ^;)VD39zs5rN~jX&Orj*nliXE9iZ zFdNzM$$%@|Fg$>cPoWnS-jvbdzP@OOpChYzefUyt-ndco+QAgELgg7WU+$BqP9Y7M zvoC2kKY!Ofeo0wbZg8();p2btr{G3KzmuAf(Kv?;atljP!ghQeUi{r?Dgg&fwdV5@ zlW^iQPoFG~iF5ujWd6aAlykkHtlgEiTThrFL2Ui)DLWe9w#NP$jnwq?9l$&zR+77R z=}0^#g$Q=uf@}U7h%S?^ytBzd{^|XFqkIKI3l*&pMNr?9X%pu>rv|Rawr8D*u!xI^ zF)mo>UEZXJ_;P#+oExmyTf>ZujHFSSw=nw7`8!F8;1!VR!JTzbA(P}_Dp#$(`lk>$ zzk`7Ylyt%VzEQe|)G3zSOYI0jT*}VQRyMUfd^p@fck|x8dqs_N7$M_@Gxt*b*$s+* z`)=I0u`Z)5Fm^OKenZG^2?_1m-^X8_|JIw0c#Orv&358#`QCdVRjh`#hSEzzRw>v+ zz*L)GSNYo8t)yXzA(OJ={^Jw3Dj{OMl4yk7>BR480DAU}9EPE4#g$uvTwrSS%gf8N z$Z^(SfkF!?djEbut0cmXL1csskx9f7!cXpj)q@6R2Cin1b(&5saud^@J$qC=KDFsv zYiVi4`zau!<1|piPxfGB8Ju&2gM+)h>sqg7Sy)=mC1UU;f^_U5h`)}Vo|+P!8V58Y zGt#n(-qW_K2Hvd5QyS!ZNm*D}5X81)@w!2!t*@d{%kRowI9t$YZfzY}xIBNP)}bFo zOv0{N(r4l4>$`HUPc5h)q1al$=n|KZfW>vN^80sgGEWUgcohY>xVd>f`M-0M{p?*! zv*SHT3TOrC?6A|={pY5>uJk>p``pIrZ9X;Jc+6=LjkVvCDION#Ix-iJ1RuHWjk2vN zi103%3$J$-LdN;=>E0zewyi?fEX~dNO*0$8V8M81(Y}-P`d18whK4NAT#%lYhOl`R z!Eo*8M-Cq@1|G;nA0Y`}SXh{I9C|-AJSTFB#A$AIeE2b%LrT5joW|vaG>{osH*7fB z%MV!l_Sg7$Ae4CmP6#LTelA2f^78YOYOQ;7lxbu4d9Fn%B(>;ur#7`AE~ljVS{uOO zW;yPg6|7>CDF^hgjKqW;r<tPow9~$kBPij}p0|(b z2K^A$UsImvZnQ3HUteEjM&6f|tpdb_IO6f6VE5TiMevg-2vn3Z%=2s!rZbvo2r8g) zE)0jvFP25n_ht(yLeB+^e{rE-Gk2eY!Y0TnUPFFJa}Tt<7K4~CTJjJ8b$YBL5>{## z)`xSw030$riKIjO22$Gq!;i@JK|&CS>Ug3rlD6y=_b^RpF)Lr<r91TDlziG>LD<&p}2W=+m?p+~M2V+CSzP$>I zX^HsrrtEWUsDP7@@wYy6 zS+Q=8j-A7Q6_!Wcci#EewD#mfHzT)gX0FTNjo2S)9)Fwq+UpChK3FS;|72ClL;#b> zsM;h1H_>%}Kh*7t$SKe%Q86gA4A5=a#%V@@2PIsD$;~zOwwHh{pKe7JbwC5zsC=Cn4z0^ z{OSyh&Cp7sWC;FyB@b0q)g|wn_2-+Ko3sA=J~)0|t~wj|2bl@6 z7otpm93<_L|2}g5yzrkBL>T7EkBHLN;i$r&co5<~e=|NIHG8z&+@=fn9QxdXhbNz& z(z(&^$8&Zv5A?r}Y5ntYt-nDbk|n|duNVY|`tOOV+V(F&srol%RF(ml1$e>||IdX5 z_$9Y&3I6X9VaxZr`1tJm?-8-I{+@n1AhhJpFUijz_`lC;X#6`NhxJAslp$&Uw?L|k zi=;NS~Y#fv$XiopFLt)TCaKv68UEOv6&dTif=H`!sfMWj*83}%3 ze+>V-7}q2LCRzPE!is38vKzU%D=Gg*m;M_Is_!i=RfDj-{x>`5eZ5maod4aXn7f8G z%w;sJe|)LKWiXu&*P6@Q9QeD`4hO-ch-IduGym@k0m@{3k$3rTjIp;uVxf@yH|vV% zl(I|cw|~BR;A-MpWm=Asv|&JbFrny42*BZ*BjgvDs6V6gE&JZoB&6JrsNa8gkpXkt zc^+EZKP%%=_Y8RkVGwZSe~*JAioo>o6oe{1{~O#gLG1`Mio1}8#p(o6{(nP#{PC3s zb@PQQ%Q3Qe zMV~|csFw!P@$bKW)%nr^XA&^*xa|c%0iTJ=Z51CsUIY#k5EMiX*}wxAoBC+3FSH8%uGzdNJPi3V4w{X$@@NRsWBk(0PHt> z4$_Gk9y9z5B;nh25KwN^`7e&I&i+~TR6m0m1c}3%l~tJpOR2`Mp9{>Ab@adhk2w-C zq_r%3;_2p+V^9_xAu{`18iGIE$2CFr>niW*k;-CG<^Jk~KNcLKB>NJSP(8HYXGT2M zKMD#3`vr}ZfxxjQRV5|je0^#lq_4a8?|-zzd_>*2aS{Gcf9ugdrvimc3-&Q&(IRTq z1r?nJ18m#wzv8dZPF4FtVrE@o)tfO z=+JvitON)z^{Q3u1NX1-DqaIHB6%77Tr$cz4o9n96sE_Hao0r=TR0ctw?`otsQ+w! zMILh`iqH%%L&EJM!&U(R9^E~Wif7-m>)3E4k3MWoKhi(S4KN{whays3&QX0AXLPxaF1B2yNBwZT*9VY$ZdJ|_U*?& zN@Q#!K_NvNkhCfJ@PP(~2Pu}K9;~{mb_o==sJ-1J^CxOLzLjO~htoQdD zkV2@*K6f0ltOXV~fb>>}4OsqqvvSMqGf#`lv3!y}#MR*`0&#e>@O5#kj zq5z8OwrRL8WXy>?XG!4biO0msFb=^`@lzuZ41JezYUmpSq)5{F!}$Vn=;3)Y?cNB^ zspG7nxxGCz0u_+rli`-nHI$;YSpe^nayd8)!evD~>VNu~3#pTysp8O0(_>Q7?70O| zc3;ak9BT_cL5&kWB%dA_8Y11)>b7MhzbOgw_$W}<0VwL%HpmJzqPg@Sj6x7HGBRY` zHw_CEpv$iao)C$zk<3U&P#1T0IWUldH1H83G(*^YF1`g8@Xc+<)Nqc3bf{1Y#%cbX zFJ<2ddDFJ-Ej!d8!ui8p|F7@H3aTy&Q$ns(J$#rRxX|3fVxslu9^?@T#D(KVl3l-N zopH_wHnZKQ`}ipLNb@U(#M%!Amm^szv@aC|W55Pp zoU7Z4T1-KZXmxaynV7|)hMH%FyU9%r(b>8^PnJ|LPQG(vf-auKnExkT3!hbCW<7vv z@1E4crD+}qzCXCHb^(HKrpLGi^w2VAKuwvwdtU~GD=8~e5*1_i31^UFL0l2u1Ey3R zPhR`h)drRXDFr$2U9)Blp>*`RBb^ThALfLaogEYMfw_4Q;>hx1Z7qaDQxuEFX+!Y*(YY-lbdj1W zA@sK6YdCo}8pp!&e!1GHe|+mbv(rHU8;wJTW!mN`G~a=`lr;NP3WyPR6@7kL|I+nG~xyX~KqTJfcQA zH7h6QhX$Znh}MHf4LpcBq&Gz61YxmvX!ZB^U&iiv|M4R|i5?IXN8$ikBpNvVkS58K ze;-hiYEzE!lFJ(!pfbQZMeh|sMRZaks!i@3N@5pm9h}PZ>AGJN8cKUI&w~}E3nSV6 z@AqCuZVdM9HPUY=Ey?y%4lx;4D`@Yz+s%} zUVd`QgM=F*#J|M{*IXGhrMHYlb=|l*Gt=yc>xtwRq{9=AV~D9 zhfpWTBPis--tR1j(`>(IdGyD*sbr+#j^7s*5fHIT5FA)Hj8@w@I2Z<9p?5Ij#CVBL+BkZ032bhNL!{FK5NCe= zd^i*e^27+cu&xps7n$rqTs9GUEhx7d3L<&B4_J?uUkeoo)nGquAbB{=FGCJe3n`nx zNi@jwkPy~?{)xPq45sLsf-ymXbHFR4l18>XbgUjsGGsFKqt-^+gjfhxFZpc+ixWrMCI7D5Hk`jt zMni0R?Epyw$^)v9Ptx^UCJg{(jyN5o`&5^X3?p8@Ud!Vn`__uK&ZOcI6$gd}yy>Cu z0Bs-;OefAv;bd(f00pTF@H9g`R z?-_6PR8Q()`W8<`d-=j(SB2qDrz$FKI&Ffua8=eQ+BUdhi*e7w*N&3rdLy@6Diewq zefn-4+9ipZt=Isul730kWWKsrPW)T zO;Y3Dpu}$&fh-V{=mHPYd?K(r|5^y|vty~;4Heea7 z0`e>=Bd-E!HUi8hkEAm4(Pi+7J)1F%Y;$)Pl#pU2v?|`R%k1NuIC#en5pv1m zxfHM<@=%EDY{!Ah=|j1aTW(ax0r@;Yrh!Zz;CFYOdi&e|decJ#+qb!NBF~=(_y;Kx zMF-CW>1{DKSBj>v?y6T-D?GCK#xYJZ3a1LaeE(X|hKok&Ay5MXvLCkM>*1l6!RKMT z_W6z&FET^nl&k1ZSE&L;n+&;ja$S|v+ImsH@?74 z)d~KfEn5SF~o28I*ko62NMj#R3iyqvNApc=6;m;gr$H; zwZdC@f;Irgutbw0BypUJod75lB=F?Xa&ej?V*uwAj^GYn<%R|ZFq|Q3`Z*`W?en|= zd;dY4gFmKT7Ji2P_pD$@-eb=)9J`9Ci!g|OT6+=mIzr}AJtu+^1hKNW68B?bcJuLd z=10Cm>+9+1**+(S)3r<#FMvT;E;Me6Sy%Pw&YiF4p0IV%6f9fH$aI3ZAjx;pk->vE;tb%qcA^pm zLMA0pK90s+4hiXo35wNS|8`P=7aXFaeh!U_xvd~)N<$kQey zzlAukBL`|&7lIKUiH767m25cj%8bJ)7c(-()Z?m}<#xP2X=^*;&3immi=PB-sDr_G?r;)j zAXPX;CKQnUWGYhCuzIhwGzaLM*8=Fpw#QSDh8bXHU2>zSnPl^wn|RdjdUo|H`gKZV zxCtwOaf1wbT%3&D5vK>s@83&Z6#&InIi)Ut#wq;RdAIWN?E)*uwghZj;nlt=oQlGEC(WEt);+vq zBjU~tAS&hLIk}gu*GoHQmeoo$n6&L&rEDkLXs#MvqBucQ zbKx}@Qli4y^*U(;pg@phNzQE~6j=sxNuUG5yW2hS<1>dla z;5>CIUh0FFGim2}IFXjjX7Uv>q|E{N#!Y`^s+fEk3Bt`G2y?y9CG`soc@a`-=tAUq z$dJb0U~5BkKc|FT;lNwX3Z`tXKrZcF(eaB?T(pYFXvm7C^g#v(Cf@4yz>2rg$47&?G zGY9isBY)wGYOBm$W4;OXXsIz%hpF7KbI4oaLbnkh;_=puk|j*#HUh85h?00ewJaBft(C19cHpgFL6{$g6#5Lia@UcT$ppV^yALB>}?r+tcVKH-vF zWPQsoKL}by7l3d6EQPl{3c4=|mBHy}f@^-vNRtcUt|--8&=vgkvZ zk}8o#eC-}#ZDUgfHj#<7O%MZZ~%1#`SD3ji@ zD-Ug*x(F3qTv#|9)=euAM8vx7#W-MaV{`wfdxCy%qWzILsYK=3B`bSx^IY9A#V}s- zomsWb&G!iz$W1p+L$JSk<%;#Wb5CZ1kC%Rc0M1BV2clPjd6e6`myKv^Yx6`H85sNc zvBcXV`kJ(dgK>yvJvTQifuBUZJAnjAFnr2x8Qk8biXk*gHiDeE8{{p0{`{FP0Jqu) z=;nb7HGls;`09N_!)&oML1h})<`XP6q$hCxNqIGZ&$*?SQ~2| z9=bWRN$_yXTlcXqI8AGHq_>b16hO)k5!s;PAasgPH<_B6Qj!uXV9gPH)op@&n-W07 zSs~r8g`!cX@uH6QBV|E!Y_tL3%UcfN^+_=#4zD-%kgOai$vy z@KYJ~>3UTdYBmA~fy>;fh?JxE1QMLTmm>|&qEM%?wrK;9#QiElIs-Z9>Ouko&#ie3 zLS0*08U!fH$jrQTZfm~QysipP{O}Xc4PUC!t|vZ4i*O=Fa_|OnYn~7ZF+QsQ+~hE6P-uy?YmV+&{`x)mQYgp2pkK#Wt4s!W$qz(#<4iLEnh5cZ4nx+ zm{~6f#$98Rj4FvZ=_iEYUO>lwc07eSM#=`%Yi|}RD$ddJAv>W0|9Q0KbtJjv9Ua9@ z^Sz?Ymtgth;AX}^4`g`%Uow6`QWP&#!q#rCge|xW1(>?Xyd-2W`h?DmQ1`CgIG0Wv zfa5p)=xwwC01kL%O&=m>Q(sp=)DIZMQix-bG1Ad_PL>S!93VtbJY9E4C#5bE^?s5`v>c|AL|}F z{_@krF5AL%`E45$N@e?h4ETQ7z+Iviv%c2jtwa~ivgg7v**6^z+ULE3cnrKe&wb~< zk#Ri8%hQvUfCV1i75NfDYF-A9H}(U-hELWuQ27?wQ!;}xpLdqy0bY~Uksi7Es=2UOV{elySGanVjg|%F+Iec zZe@I2UL(E#8mQl!z8@UY&Gn)Em#V9--SFA9Vr`wWHtLr4+gNNO!h`KZdg3#db)e*s zH+q1yNEU}PJd_|lE~Bm7d)-EgV7^5Gmu23-du7-IW{%WOkuOw$Um=6^IuYvHT(>$# zXumY_t5mFbb3x1S;8saWqMq|QU4OSaEyn?e*wE$?@)-P7X zlJ(Ml3v|9zK2&>4p=Pshz1zH>-dCAuynm2%oxseH;XV_!OGxn6Fp7bG$U<~$2Jj9+ z!081Dv%q2@0`P7VGlcL}_qws5k7a$uIdS$gk{}%+m0>Jsn!va7rqzDzf$78Zi|lXlKtcM4Nn zj6N(5iHuMJx-f&L2TygCagObKw2&7FEh9S{mWj}NB)U+jO*NKefn|P{phuZo zLi~4cP;6Kpzj>$rN@%DOXg`@D#*ebWzP#-5c)4YU>+b z(_|jXG;lsgw^oNuJn0K{w&VH0r*lt>KbC$>yjBr(uvfBrPP@O5*OfOyY=@eeE+4%C zXVI)&kG8PY6EXW|{VzXW_R*VTVc`x)4HCM3arn;hLbDI|xQT$AN6io1lA0&p^Ue8C z-2_}yBTl}yk9%JLro$Ex=+ATL{@uH%>jQRm=U*XMmVB3HhxUV@yB6CjVP5dp4XVd! zmZLLg0ug{gJp48D%q0J9d-gK;5|ikwaK(N|LZ!N?7M_?fc7WobZ$ozeYJKw^(+npb zn?i-3Z}-hLdrwJOGr92<8ZlY}qi8iw6g<*QK|GHh1ziJCrAub_KF#9PA6)>tP_<)W zceyuS!jq|yc~LJ-?<&r#78lPvkG}09xAEI~sn4H2Wu3`WRadWTX^BDU?M7nrJ6`f+ zp03IJYf|FNbh!T*00xt2xo~tiK*!X?M0WrM6>R{fpY;rMfUVCSJNQGm##T8>pm?Xt zoJGXZtB-tn!1Q(s|Btc_&rgXw9-H|;nyx#X%eU>{Rv9HL(lR1@wWk%C$rchRkrAoL z7AYgyA~HkD-jrFSlwDHU6d`41zn}YeJnwTnf4s-@roQg)b)VOHe%3kB{hCx!8?dU( zO9AMoG{ayiotc2cfC2qWjnYx{OaRQD#>N^(zpy*$wHA+=?gzNf*w9ef@beH@ZxeZc zr2SXX_o3?h2fIGAeU^E7)G7Yg!Ki`11KsTcXvtul%I`g=N4ZtzFoWdxn)lTP%?0t_ zgbrJ$+uWXvO>U}x@zh}F%7WPi+VaqW{EbswPZ!m1oV2k?=$n?D)f=sL&1Mi6?SJ+< zReCh$tpwMNH_6N^V{gv7uj~`^E^dFXdUwY*rmzz2@9&fZt{(X4-_Q|U-eI4y$tc`? zt>bTCS(EZMVV$>}iv~hkBb+pu@SO$TPk=)n|4|7C`6WPz8<(i(y5p-_pGjQ5EJ&cm z(wP3J{RG|!*0(4PY6@}@SDPe---3H_01&6Hq45JxfB%D=vuDn1)%ge=Sf|wi`AA?A zv+MMrWc_=bE4OLa@$6Ky`9B z=YO2I+m=&am4ORwFzbWk_DvaSA)#n}{o0prk@S;#0d9Ed2!eo|B$N;-(C`rxIGt>Z zsa}9nOJlHntfv9*Xk}$3oj1y9w9KY;Zs=kUpw$lx(@N)*>AjEsVaMf<+#TnQBi(+F zkH;nV?|`Wdp;&?jfO!&*-nfUk*Q|)n*;NbzsAMUss|4*OSZRGRCae%ocij){DnaaJWBopc3;cX1lfl5V!mG z1BemE|ZyG`ViK?bMg^X#0{Wp_L!Rz|r7&f;|5-Em}U<;0?7s5>XGF7qDn zR3o^kkAisGE#n!_XNaDIvfrP1&!&g_4<1Yl2vA9%LvuMDXJ6Geb29$0{cZ{e4C*Q0 z;X69zCWFMvnXl~Wr#@$!WNrVo2Aiy~APrW-DJD_-qvU;uzzae7un>&l%6gBEQ z48-G|nU`AUXW8GOvO7TXQP+OH()HF~UrKL$1b!93I9jxr7nLr4RFgO^YT?NN_RhvULrNA6b@)FIp-4#Ocw<|d!_ZEYsj>ZEq95qE`AKHFOJn- z3Wv^Thd(p$^U74_KC1)EeV5Q`&V9;u!`b=K*w5K4w<<8u$(=)XkYNrc?S+d&$q)(j;gxCIk4f!npkOVRj-@tj?VQHzmI;je5|wIsMY`__S;KZk|J_wJ07ExU8((BXk$)(FKU{rae_bcg>;3>DryKcQT9 zC+Fq)k)WL68J1)izfM5q-<4%}3cS_s<4)@C;K9@hG}h_LYMm(5;cTB16FrySB{g&I zzv6(_%rL=#E>!DoD$A2>_56s-Fzw$}R^>Wa?KElh{F61Vs6Uv-<c*Vo6g~b zR`w^7Qyb9CUnc`*t@ZQk@FyO*Ob;{b_XE@l5JG;5Y0%g|%ny~$G9uCY`Hd3Qo5V7y zhhOaqUc>xXDRh#5n}|n^rn>qjx4B;yp`V3T-y%1Qd>L`4-Q8xOZ7=lsyoKqK6oO{Y zMyV=#d9ADGzU%8-uS}hn*)URd?8p)K>Di)v7dp9@Z~g?(FhBPJ1{n!?H!RX>N8xrR>h}Rj2I}-%!6CsIspZj(IKUuvjg= z;1AB&u|vJmxv%Gm1J%iEF76I-uZLcDU$qoSpm$xb5-oYUZD7L%PsiAi?@i3tlK$Sj z^usjNwB?N1O8(!$7b!n9{$@*K2IjcXaBeQj@D{bZ!duduJ&^7N z%l$c|7yENfA|l9QNk0mgD|p}%o33W=?c}4D?B6qbgeq6_xty64csOW z0quU8kdUyU;}Ti6_w9o$+dlmQwEqfg+9MHYy3q(3biy~KC}r|vaF91=3Yd5u{bEV= z*fJ@$q3j>)SQ66xT4E=%LQz;SE9A1rYi-do-wtZ1!DEn~e?(A&1H!9T5UX+B5XiLKE0JuvisWZ_qJ0IZTyg)`mO)YOy|ayI^m94==J!}@*Ng`SnY zDU4$>V{h|^I}D4g!fsz5?aJ-jxa$RN>1^hhvLi0aLC;E)pXi}CU-)YJrn*0d>e92v zD-F|zx2-RxlzBF6sJHxrV~=X)nmN$Bb`1bWAViNJT3OV>$rK2RKX9?^&73-x7B7JD zj5oOFr_WE5vvr#%N|cw`B>rCu@WMEHWNBjTRM{P4d;3q{NY;e;{%NLbW{X=#=H{Qc z-^ABDo_%=MugBF*WMD&u>Gkz~!4)033>>rmIv@46Ul{_po+1qrF0{EFy8GrXeza++!;GzlyTThry;`>CTlvVncL0FjPe|;LSY*!INLS1`HON-eugc*vhYFEln zs!Rh;<0j_EI+SeH&YS_?WDspWa|xi@!OB;!3fLOnhvXDE$T|(;c(+?xY=qy9)KYM= zvPM{xV~E@F@2Kgk+hG`a(w{upwQJ|j(ZRv+tI}W2@}D>nPhM0=IpYvBBGWe=Nf)H1 zP#k!li-6ba_ostxo>I@9KlJ{FV5RBRn>ULZgR-b))46QkOQB&N==hSc^Ty>(Xd>MA zu$-4$Sp8kMB!kT0>$VV}&84qPTzDmzpl2WQ38N$ZLfY(a#k%(S^&Dxmc;@HN@3gbC zs}HK?z1HV+axq+Cv}TnGx5m#1nHx)EW42}aJm_APqrUA(UU%B{A~$>Q_Zm#v<93P8 zp1Xt7IRl2KKeoJ0y`v=atf#s9IP0}mwfjZ2mcC38lO-jrgHA7}oa#2Ow9K#Pt=(I? zyW{qBn~LwD+RgC}wv;NZDgecx$!Nv;n1l?dO;0T|Ac{ z?IEo22<O-rSKGe7N+aiZ`@$H)*niBRs005e0-PAQ+?gHb%r)kWkvGM zdiALlUKUwPnvodIrDTs{;?MC2H2C`5CUr{)zS{FMj()Q_Rlw1j=6451dA3_gP!GeZMb{VVAq5CzYYF`a@q7>%}-?N;VX3@l)h z!ynyO#8O2XsOxSuLZ|tm7a5xOS`uYAg3e>YzYeJ6#E%;fMm&X;)X%WeobGt=#m?Yx zuV(^#a*n#MJ-{pS&w38x?FF>OLm(J64B4HM=M*Qwth(B{!Rv4?dcn@?TK$|VUDC|_ z{1sFW1rycN{-vAg04lEKZY+G2OKS&6Z(svvwj*YJ#G1#HeU-nLT=)rxDcO6>^UGB8 z=*XAtCJVES|2Az3VsM*s5~0w$)zxJYct}wpYu$a?ve(r!h`riKb0mGR%G-mt+IcJZY91ou2Jbk;ZVEpEdF>g(g9pnAMs!Ufjo2Us=0Dbc>1FXH)r%;X-K z02Efejo7m57~lM4Z)F_%V&Lhn4fMeM!JJg3<`!GKAcYG4&&9G_7rS-=&8~1m*w4~ zyZeGq!W3=$0wa#z@G%VuC!_UlBmc8avC;AF<^_3;l??UfFE00yMHEyInY+{+Bjt;B zuP&P#*$J5I;}6=f>j`g#u1jI>LtqZm@Y&-k5Cncf;Q(bjXTl8##lcN9OA6+oUo+g> zx1JGjCUC_5rxz=)oo~yAoaqbvS>F3KGJ0AB^3UF#o6;y7XwM3~mDjHN+IDx~mLK15 z+%q(}CR6<=c`a0oZIDotiTAilT8({NfbYV6cQgHGFa+{I z`q1m#1EseIZ>Yod>$Uy0zV$54>jwfd0~~rL1DC@VnExK59LRkg_FU~_(W}^oO-dD9 za;v;^*M&#fwqLWR-5<<(;fyOyu#uPEct&nQ3i=I)0_VEQfrZ(5my^@-9b#vaeduq* zH7l0V_k?DhX*kqp7vpke?_l^)YnnU9O83B7Uw*y5`+8maBw#%2_}gzgjrF$gQ^%Q| zH9JcLMT5oW=F>*C9i;!A7}Ocm+GnY9r2F_giGtxm`M}m(e;`EMkl4Ty?E~pkZxvq0 zL1-??$SE8i3riI~E`N=TQ|LVgAPgn-@nAN)wWt2xf1BSwNV(I+ftvcF&6S{weVblC zdz>omx_QPq*}rublE8i#r3DRgc0%?+CNaPVT>C$^JKwxsdf9FE#M;q7aq+-6oeG4v zUp|d`uzIq7CUY!Pfbin;r1LqBc?S#qD$7qEiyZR~bP=W`C{wAltPO>9KbmfRv}}6l z*>RqO6sSuzwRIE&Lv@?yC0-V6+Os8?`r^NcV+9S$qE=PJY2iJKis8ynX;+U4!CnO0 z9byUu$ShT#=zax)`M_faazG!>_4g=uDJp-HQrpk@*Q2FC2trJ1%{yXa2%jAdjD z$v4svvKL;w+P3!5VbkgrL0fgZwYG6hg;6wSaP#@&f*69`1a4|+Xkb6YAs7bh84U(DY3 z%df9?+#E=I27wPSet;0BL39$nMiLG09aeuf>&E}D>W^aUGj6s5alYdUyr@gz3AiH3 za6>X24FD*??X|XoHA{~uXIYnua8Yg$XXIo?bQ_pKGBp4a{-`GlTOAR|N@_fbegw2Z z0#w;`ohP4Xo7+uMr+k6__|V=^zsu z{usxBv1xj*WgQsj+bqk}deeGgPk6#EQ*H02G3CH}U5i;6$vY1~_r}DZm$#FPw1)2(QL6ct@R8SD4eR#&E*B*u<6+`BK>swdXx>69UBNZX=x_o5d}zSmOEOw_!e@PT3j10 z`5<;&{=dhy6-3tQfjU16rOUqk;M6x_y+aV0(+7$&HhLE+;*ggIcuxf_w21LHQsD}| zi*$Zq)c!EvX#4IynTrQc#U-@LFqldOvI&J-xUd$};VmI_f`vTS<}LC3W=!p>dF6pK zk}=vqB&Y}@BtO~bDDWu7lfR>xy?qG8Q=ZcdH9-AH zNB0RVp(058ELmy6_|}H)QIgL54Q%`(Y52iSLgtOxPb=X^x4{v=7m_n#z(l=j<7$NHkj#34yLvn7_j<}#RDYL$i;Kxn znn0AO2q-Hb#O0Br?@ok6EY)|)NS;63nS4HA=XsGj4>bMI7r4P4Pq<7|Ln<%Dlmw~8 zJ?Ob?ZEeXv2Q30GqPYoxNJq&~4;*w}UKb>gd?~PCaQyKh0BjFwPsg?%G9#)LySY~2 zxZo0#rAUH06-hS=0DQVxHc=6q>#wC^6Ek9i@J!oV zm5)UTAF?G3<`4?+JWXL7M|09|)XvVJ+=9x~2D=07Q)In>q=s|^A+3~wBeVHy;6@!6bJDwJx*G$_i9GD35SHK;Bn@dl48*QlQ&KnjO%R$})cHZ9_xgK2Vt4L^HDSrsCoEXg4nW*3fVdPs@BAFF&34rH0X5 z){~eRDaiz$kzfraL{RH!Ywzn>hrNKA*tmK7Y`w`hG=}v@I1w5DsvBpa+NbEQD&N!{ zNCc3JLl1rt3UU8QK*4`^9E3z8p&G-yfu*#ce^aMoAN&E;YCsB&M_j>JBLbnw0hw{OM_FBcAl_KxEE(s^$Wz6XU%hDHYKG9d6w{TH!&lo)^AJhqpQuN6QJ z5Ja2{bMQ5IR?7Gj&vk`QD=9_rz0l2+CuV16_8-Xr`0*c$K7Bgk!NZ5?`0XiL+uOr2 zLH6T`lv#fg#@+e^qHSIRTIdV7w9)zTY2ypwl7%6O&KpF<5PDi#?_I}kN-~ALXY(*O z=f&w1Ntec{ZG;#Ol5=JPQlszz7ueR0z{my^mx;(Y6PI3E4H|&D2ILz8GKcKxZxWUWn@SK8BjnnesX=eFAn0_HE(!+AyXt$J)Wemf2^^w)J^>Xn5Z`5bG}l|_ zsWS6{tL@YTQYCJYjw18{cYvB8Zz%xZ{4oI|E$=#NC zBqU3ZSoh7?p~v!-%HAge$mc^?YEvQcrlqHshqOrxk})LN_Cxvo8e9`WkWeH+1|Y^> zFb1hk8u6gm2YY7HYa4*$xsuvAb~|903a6qLVCQwH$e4Ln4`C6Ze8k=}_=2~D#5Ra z4m%2J>Rd91FJ8uLHxCaFvMM;R*KUH1d<49@_%j8GsNUq-B3ed9IF(`=WgS4&ZrZ;Q zqXC&U)(Gb|NLs2rds1^#xNw>Hk{vZ_9&(-U!Y>9R+Ax7{pM2R_RGcEv9f7wBj0#7L z13oMzx(_&0zSpq0VkHkG8QjSGkTsJ03W1&CpD&Nz;BWg2`x-W1k?Xq}@HA%U-EQBm z!Ez@?Jd<#-#u`3+O>~Id2McHhR~%CBUgI}%dT-$5#md5>nW8`!FYU1%P*!a35ELY& z4;9W8a`MApejUM4(47&$^w-brfNl+~Y5=50sgR80Z9RRDTs}ocZ-7_-TlovxN-?B* zajyXmIRGv2T?EXM8wt?WI(p-blXtmS9NtaRn~sW*_2mk_1t8wLAs9Uk)%;}v4;t*q zpdfI0hsk)Yi8hIwR_(;iPI^>;EeD{jiWD_ufsCpaH>g&{&8z4nuBg3)QW%mHG6=N> z0c!Aa0pf$9{G;YwRAVw69S&A9=Ld~UuggP-E##iAK8FJhMTCODKMuDe_6$&vU+I=u zVLje=kMS%jssG@FUV)|^a{OEW=_`RJKv|+>UHnzz*H=J^>Nw&q5q)s~`+#`|8Q)xR z9wsA510_t^zhV81ECDIy9^ew>YT1x$N+?6s>uYZLd2&l3C^BxdqqWbTJ=+xW$-20x zpn#WHgDfMllM6Hd9wG-@D;XJa*vNXj&W?MRtdL|sjkg<#Z?u3zUjqkb!XgyBMdT(9 zGC~(G?BBF9!wlr)q46dK{a{@daubYSe1fEWu5fY(=vb>_BiPv_JNDsRm%-l&6?hPe zLeONN=du_xN;!uh;44q%$a<l{5uawy%oAeNXloIiu^fP%D; z$3~Ys3{VnDkixruoBCc(MF?X2@GeTz+s`scdID^f(927Kr5J90Vr*N8rI@S##L2~j z+#eGSRrW_E;7qH>A7Mt-zK3K9tb_B$)xsI6qfnxr{=Yi3rbveQ6Qp7~npA2FME9Y$ zSmw>ihM-+u)8b0h1Gx3U(cUA`9+~yUkPBv?-(uGH#k@f}&d|<%D6qx#jJT40-!nSK z$Vj-I((XsTi9J`9ZN?k0PmGmJVQ{5nCQ1;X*&n=h8n=tx3JL_ozzblBmrMxsJ^b?q-p7m037! zask~J;SUc<%r!aky_;m`3h)!Ob7sDzq?^)-y7@f}&jqjW`d<~ z(PX^6W91||?;-rVq<|a_p9s#~%NU!O?`-h~2y_Aj?mY{LC*DD}+Sc2ffE#lVO+n@- zYy9^pRC?ezBTzSfAZKjT!%D(6)tMVV z1C|#e9svT|(!%i%?3-OxdQXyj<|taBphp4WOmId}88sR6KW+y} zR2tSBkW%W=V15F9*P{!INM?CRlzFbYB54+(FSraV3!t3iC9r+gNSX=va0w4-9^DQ9 zJN#~y`)PE*K5y0@6us~&2It?^hfF=)@YZRxRnEU0XekSkot1SPxwj|7uv%{m6$Kr+ zb8J|mdL^awOt$_Epy?1#%OS0_fY7Dta~g<8U(#cJ6XYd;|1G?ta0iZjQmid zC#P(|tha6FPIa)W7~?OGpOip3qJVS#fEu$kMofr=NUsUG=~*!r$N;3yknLkg{m=PP ze*{@BY!t98FXB2%K_?8mJOvt-`*^U>er#9>;v;4E7ovd~?ER%B&955SDgp(GD`gTe zHj?Cpv|N3eTuc-D(D;9i(&EN<=*uZa>CzuOLy{FmE0lzMD4X(O9r<{cE7*U0H)(oy zmhCO+E5uBNj49r!q5o8bAb?m#*wmiFr;GyJjB6Q@J>EDC$Q&et&M?T~H>|;NVJ3F% z+T~|4jsr|Bi;{&AEf4Rx{8MtJQ~XcVE9x4wKMZQX6Zu5+o+}W*wGP4EC6pD5gG>4( zkwS@i7ROnYAQ^?GC=sRqb`e}K{q#)Bmmu8|`F22#scSGD1(AD7$X(!c-nfV_VGgAA zMq|SKcB`PKH^$&tBQcqKsL9btZm9DUReUy`iI{CL%(L%bJ?ZOcZ1l&EuqA5BCpwBOL(Hs+N@~3@gN}*yKqm!2sP_-;b~0B0c^<_HWYxO(0SwXkBvsV z#~dw~t*-{d#{cxG{G#h{>H|!8`*7Bg{QOCT%#vQdF6%(=c}U-8nj5aj8=Q7?c>DCIl=f^8fe zZxN(2W+;OoS0$p(8fF&p@XM&zwBES4_NqW*e;t^;{F_xMvZ~SE`*j%DAjr>1IDy&O-XGl>FflnBdM%x3zD4lL->$oMphx*wvl!?4Z z5g(oML{g&aL;4F+NR{at{*|5BGn&^5z=q1^ANDKGHhaNGTe*tP`jFKS#)fW$N?zRR zeCyUhrWx2jc!@(+t+LXa{;L{P5q#kbN;f~-3v?k8(BeS?3{=*1^W<)&N6u?avYF#vkn3VVJ~smRrF zNW>((X|GwMp(gtA!$dFNk#+JK#6!Xb!%j#7JAzc+FzZy#Q(=09Q{&>*Dzef#VDots z4y-(h?7&_I=63^X&V6izA(tLQ!cAU)h-9h9k>7xZ%GUIdo=W~~&Rjbb#QW5@C1PJ3 zsB`q$!urrm_vx(r-R3C{CLnfPYyQZn2Gv$&)1iV+&EBKv!7dx zOFT3>TNZ7|WwUUFX$frvMNziKsh(*;Br>fxsdR%RdhX#>-*=4qvDO80b$>J6Qw<#cO9y)D@VRf_*FU8!1{gY3{ZkLL|?*4L79YdkDpQ_ zplaT#GL2%LvIPvX_}5OTYN)*Gaatd4lafD2g_1Y+`*+Sy=cUXQBzsZU;3-&K73#q; zy|;{ZLW2<1&x+|KjZDmc4r0|Byg^#$cxHy*y#|IHl*GfYsgm0E2hiXM;MDFCJ7Z4- zYLIZ_E#b8%U^hn48^*-Pe}IBe<=hW|B5)`w0#hS(lK{sMB?L*g7%m-!lkhn)>#UAp z+HCq`ghDf{6N)L>Wh3%<<@xYs8MNG&fQzW;dkCkAhjl(4_ew6U8Vr%SSSzg2dBaBuD11hob=aa9sDJU{;lNg z3K!=&fHbIH5AlMM!SdzE7^-|gj9u-iD5f2BjYCWy>7zl=E*tL@PXAz)$l5F1BbPuN zD3*V~Qd@S3liPz&`=1B;6BaD@R|152a~i!kKZMd;8{% z|6hs!K?m!+K!RDATM6tOmtz;wR#*v*!#?q+N3=z+;tL`NJrF1RvrPk1^rZnJ_Tw*8 zFl)jg9{u@K391Ct1^9B~5X8D7Gv9n%G;k<*s4rERTbY^7HtEY|-g$BJ*W%CeSIwvR zH>;Vei{>|6ND1SczenT7@#bFOu1H?R3U1{oXZSm?ned3LW=;6wiI$VjAU?2`#BI69 zx!3szxYOa05k&PfJZb1$-|>@g}BN1%)C! zM=5_HEZ<`rMtRJ@CuU)8gO$1dmIAp)nT+#o1Ej3r)rbNV#B0nO=6{NzysV6g0PMob zoZt8lZXXuHsNizIdr3J(a&7yso|mPgHw?f0InB=_CKimI*5KLPqRA0;m`>P((t)?yFW-nrLapP;>{E@Ok~2XE6KSgdbX}RsA2fZL*D0#f69S z8d)FR$#_3VlQARyU2}6f_MZ#VorW9(U`V7@urA->!v+&qN{frrz~H47u%(95TqlS5 zedv~1HlY0Ju)JQZ53Q>540t#Mfa3rn8J=TAxP_PY!5Y@Y3*er0#4_=5LH|5-YOPqb zA&a4d+8YUJbIq%yM&Lm>$K98MWobSZ*DxiRKkj!VSs`o{70mmNf~|w@#tIYZP3&HW zxnMUQ>)9gz&v;CoDZ>`~I1w7EiME`XxxT($3upz+#*G|{+H!BQBJjPrSyuU=zvI4j zYfd}lU-iu~7CdV~LwjsYAHzs?6N%IE->@qB{LW(U*8>h^v?C7EEc;>~ATBZJK_mzI zC8pJ-&QG7NqTUyQK_?*?fOE0VF5CH=-6?D8`DxXOv_X9{5{ar{c{w*2+7e z)A+Zv1SI|3&c&p7U;Tl}$^Vk;k?*#B`*sr4#*th+^KrmIl}23tXuKmYkZp3}#`i~# zsnE*ero$?Nj~|&?S$%PnlIthd7fS+zgXdRQ-|QB6%g4d_6V@pr)t z?<07~6v7oi3W(HA1tTzWAs3l!JU}@~B=>NiyDw^JDv~Q#>V_SToWJXM#B@7?nXsvu zNi22eX~57(;*OJ;|3@x*!R$GNmmI5zYth7_cf145huq$Xi&&xD+Sw_(;A+=bwF~sC z5}@mU2j2}iyx$~!iRJzbT`R;0#I)hPBkP+nY>+Yc*aW``8(YsIgqmEbhi6@fb`KrH zy5Jn}S{AG&dQUU@=(N)zd#YvungzNM2h|#IsOSgP;6i_mx4u4P%7c!co?L_X2f1)q z0Tgz4)+-bzh}5Bz+tzXQV{o6Vr#8GUO<``1SDO$JF#D;|yL;r_kQ*Wd?b&uF}%z^p+fV&FvGcI8zknjy_$nm)}G&KJEQb%4i4meEz?Z>dmrdcfP z*1Ch!*!NzgKTLU}vNPwB+topb9?0!JDV2r%6z_u@NZ*d5t)lB(Jr(VbL+{9bswN|MybO zYbwE?&sIYkDsI(mks<1a3QlkC|8Zu1wTkxJBg-A1Uu>kNp}2TaHrr^$Rea0zwD-X4 zJA0I{>CwA-UA$-db)9#`t=P1=ms8$IDEL4nrII2kS%)#l^iVPcku6s3)wfS!|%8*ma!pQbXiaK5fcT z;lRG(5x;vI@@@((dn}jyT2c)14&E^$afE-Qjz(74LVjVP?~dKKa~Mh}3=Qi}5u@!i zqn%?N#~0jRc`{~Lq3SCTqmXg={os@`r>0=~sVET$oE^7<*r%~=LEr*H$;BJn$(ZPj zW)lQ$<7E>%!(p@&NA~G~T#u`N(ZPl)@G@K8Zf|c-!JFmrIN150B(qyQvmG$&JBme@ z>C_7IUDh4>SzNk_upIHQWFD9g5Jq9%>@X0nl?npKmnRVTkK1a7rGDi!uj zb!+sG@nuho-#tww>wW9*7tU2UTP{~#_g&9_B;ewrU}U85`0+%kcSy*}?tcq?3nFfH z)FrDj>x~^o#pYL)LJCG2l@~pm6IP!-zGsYT#tV8_4%w;%xk7;EN7%c|plLSLRE+c~ zqI;HvVFOzN&s+3>p8X3;qV~yqWOfd$KcVj~-$tyJ*RPdI*kJ+dy~VAqR@8%yPXqz+ ziNvQ0G6}hAA8{gp0W&MfL zsD%1!5ruWvhS}Mew7HKvxFtguKhh;Wk}#~Ol5Q=N!qZ4f)tUC#u(8_I#I%a~S`X!e z;5$>*mRIlH`yjwZG{?JCJNlKpFfMg($xPV2tf97CV83FJOW50&^XEyryMHN%`r7iICNWb+4Enhhw(XVrDlkJd-j*^ zb-ey;a(E-jod<-h6UFN|Ph*A|fI1k5ymQNo04bF6=eX zIkj5qrHSC2^~{+rEDS1bSqZ00$M|KATVPw#sLtFSGO7q^#-ywQ*x{asS(=*ED;OSu z`#%X;Zs!go($gnO2VcK3S7h%Gk6-aLPuCOaZ{GF!Am?`ar|J8u%e!*BsSY05h6!k- z($Vi$tpGnoRh9Z|)Xg{EhJ`U-Zrl=cF==^nY0Ko=DntLu>a@B8i5?V~+$<#*W>oDR*r%+lX%^^N^s-}>=% zdO_}_iC^N>IrI`Yi5nrU?dEdkQ!F3+n7MM#dulMg%<1eT>f4NqiiQ`amT7yaHpUol z;z-`9u?Vi}4*Glw0&NVr3x|J%3S-rD(WoI9xW^(XcyTr)PJ+^~U5zoc4b z`9jG98vQ70xyT~h*!8_vqDzWx7E*Ry@w5vDS? z(wnBD-r=RM@B26GQHqIqq$>03)#~z{nV)y`Ug&l)OI0^|ty_GazScwVXx{vG$jKu% zhLF!~oE=jyYJN-u^yY3k)5Qzyx;Y=JwypCmNvja`*S_TF{>I9H? z%4q_a3-QTk0so|+yOM7rr)i2LVAR^SwxVLDRq-jQsbiQTsJ-uP;?(~2mdu=@Bn{## zEl*_7V^eAl9~H8}rg1sq85)!N_tob0^pvt#Sog0i*m;#;DEs)y{;Xc zQZikUkv`(=yti&ycy+%G>0AG|e}4euPVS|7_XpEXQ9bsg&k|L|JVt4o6SJ0O!B80bfSKQG@n&f6*e{1I(2IPNzA!CKm69& z2c!<^7jLhWIPj`FaamS(z)7i?s z5{okw>MG96%?@8W_TxvvGq=o0!{vtHOY9X}I6r52d0pW&uD;+|)!q@S*!1?kq1{ZE z$2*oEtP{T(A8>79>n~l=(9gYMQorl?zM%QJaRhvfRJWbmRZ#GyG^N_yTDY}P;6=4r zdA31_$Ip?>&n|7e^KKn`ubkm%H#vW<+=l@xVZXBgd%IEi=Z{%aos-2KvpXLe&ECeX zOE)(Xj9lWqS^94Cd54}z-nmsxm6cs$cPWD9wu_X({`tRghSnm2S?Dkw1ZEq7536#=@uism=&uRK%9X!TcTDx3}X>eZPWUD3+N3 zy_ukW`55sFf{i<=Y~&&up+1rxe#TgLbRBK4(18Pyp!U_F$x8zy+zy6e43tMQEK`At zfXHcyxruI_+N2wiNL5zm4QoZye@Z)3_dLgr9cnl*$y-JATQLl(=KkF+6Kxz4X-^+r zb@5bp`~jXpy!%@uu!gieYV<|!@YufCf+#lbr8$EXfwM9E?^-pl@v}%He_!lW-K~hY zCedIH@y4d+cNf_kRz5GBx*yp@6;rSJtm|EbXttekiTfCf@$YX7t07(=x2LSFb}u~B z%6b(g5|EPOZ+=NH8|x+WPyG6&u)35#^r>C@+bN;IhzvCNu$MbA$n6&eS?6z&n(ZT&~N?X6sWbJ zpzz~|=<3HEC8FojbhOWX>&ko`y}o9AO)=q^UipKOrjgVm{}!2xZIo^iGO=n*m3~elY$t)rxDrt%0Ydw#_#MEC*mDcUwYH*j5`^=d$MhJ;~ za`eXO6EZnDIjW0*$>@mKn3&e}wFMbU+0+?lB@SN{D)PX`K7JftQQ?|wmj#7Q;LK=g z&qa`-JVYm^^3s;x+xSpmRpnh>U8%kGt0&pN!7-x;?_uT#OqGwCnarTUzGk7QpB)}l zQef7wN#C>TMk=2fD8gTz0aicM57}y893Ia5Z7Fxo!m@C7Zrt#37&GwbY4M@_OL~6h zGe2x;pA;RycG2j)Q3Yq$*QVV&GMW~ae{CHvG1$rS^BpViu3avrf5*EN#>S?Pt*-1h zK5V;<)k9p|*5zwa`_-=cAVZg?M=x?B-uZ9XWHv4)I_zWH${p>ra{Jx$jsYhG8Prl!-J5t9(t^!1s!V#)7@ z%_TWndz^aLS0cn(Vv=3g85Wu+x}Pui^G3cFaznI~0%7GRsbMCK&;cPVzTodc(gV4L zed`>&m29*=f=gIP5IGG*p+$8pgi9tJCr2b82)&fHwY7EFTuTA?0sK z7?y{)Y;COyM3fnPps~^ z!PR>^*R;vwCmZu_BbgP=Ljsfcxy~&bm$1EB`(_`-HR|N#$RptJldoJ@ynOt&rubJe z(HOnQ{>AwvhmK3jO`KLLy!7c)l<^$9n05(c)$QaZZN3M_3`{~Rr9vhGKK^<|e;7Pd zN=g*2U3a6C6qZ@z?Mkiqo|X= zwvV&$f{j&PpNfj3nl$swIJG}6swUr!FCHEgcK98?vh(wE#hX*R$+p_10K*ogEVB5G zlU)EA2nq`NLnNjEgfbNY=DfVmu~Lg737&vZ$OKIgFNO>03}J=4N!5au>gm+i;vis7 z?@&O<&C-*j5Z84=xIvlJX=l6*qzZy~5904l!G#ln;TMSc^I^o8MGGRYwJ_6beGPD9 zcxi*rMkvTnZ$JxetH-MF4}o22k-fNd%(qOhS6NwGvk-`qPk-fZq7U>{fVf#4O6O_UsU&oiaD%W#_jg_ zXkJZb`WeICL{IIBKr{WsmCxedhTAG%4G&gaJT>q3$LvbC=(F8kYeL^gZ4FHm#TZPo zb{u9|{kw6wr&`9CgY8Xp+yO1|{oLMZhi%ebZ5h}b$J3H)6%0Mcd+$4}lznf1oai+9 zrQ-Gd8PoVFj?OfzGpwQ?jf}DweH2kP_?ptJTA=Sn&)7}(;UQW|D z#)l&Me7K$Im_$d%yY_3XkLTK&tS(J#Z|~4yWK+|)@|!kL?##o7>arXSm2T?&>ubjg z?~3fZ7XN)!o|dto!2GI&X~78Nt}oM*-|Fp62bR44$|po8G`Bz34P$Vx_s)sk-#u;W zmH&w0;K99XG+o{+)HLtLuUttN^(hCK{5~4bkd-ikLzt(*?@UT!+8-?)om8;C5s(5< zB#~h*i~k8$tn8(|N|B<)L>zPICl1Kc+qMy#fTXa^ws{0zWA!mqZ=t#MAtDxWpNYDn9K}ddp2ReA+1lBIf3Ma3{ z5e^(`_V#Sie^eY-Xe7j;rxxD#wFhB}L@OZ00DnO~zPp6xP$@eXDZG%y5;d$C5ovF0 z5pKe)n$rKrQ8wn^xW5Z~7?aB{fd?F?3fL7LI0{ zTe2VAwM+kP{7x6XsVqasK81mZP!4JnD0aCC6$Lq6*`k}7jz;63X`Bzzd%F6JNbd0! zgR1MtwZ%;eAR}EfGv7_8r3wAqO3SFfH3RQ&d`0;?4~K||*cibxyQL$IAI?b_|B zEJPm`B{Cu%$F;BGuC6eLN0dmD<+Wp87ZQ{l{#t!fO_(31Q`>*oa_wn!w5`ie4VQ$w z)Qc|e%ame{bHZx5CUJB!$!g!bV-B(W99xf69ijkeqeFWC;jluGWZI}fAjKa3%g_d?+GS^Es$}#r`m%6wNu+b|HB&Qx z2R2OE1gRr8adU*~KK=CEoY?dco6cu)grK;1P7TLKfC-ecPF+>uvP6?XzCEma@7$vgLec zWWZ*gRu$SR&7GgqO{?o(%J|hpKioC)S*kWM!vB^OmE#M842}1v48}$!MIr{vZ_lZI z%GJsfl{m-E;oB6QS+UJsaBM6~8henltAvEqx#>KkPP$5liL0+Z%W0-`QLV!~eCnPc zgF)?_wPoWv%+rk(%MkzxBJQ%K~nzbDhHgx044KQ#SFxS#a==X| zCw(D%45|mPFBe_unXnW${G@PIE;)tqvhSq!78Mg?_Z(Q3MfVotXT+d(Uh4ek(03dKVG9C7oND zW`LjecrA;-3H6zc<_d~JFLzzOEIFPY&CY5Q*w#%)r+x%Wwhd(hBedvwpK zZsBLyA4Ss*4b`nmuD+h0>}#P;l+>`Q56t?#_|i#+I(gaYv*_L z$!esTdnZLEqo1C4<>%Wsd5<1^&hDNbcs+fCnY|&$PLb-4?)&qH=nJT;Z62Ke?^LiR z`=O$K(WYC=ydbCj<;`_t}s6$H1cUDnhTBEK&-324Z0mu(oXDe*qn{yU9S{q|f5>nr)?- zkxN>gP*zg9kEBL9kgX{Y-ULQBy$m!_QHV@P$YDFLN6KhCc82Uao?c{n>eMOM6(dzK6MVC>Y!!*Y*LXoI>)$c_*DA=n+6|? zhr6SUKd_57+A~^?ZDh>bSgcUzF3-vmqpULK^@ClbX(K~g;eCKv;*(LnzPVI%e(_5mPernW4uWlI`R=HB_ zIsSg;b9jyDTHqazuH2@VU4?}s66Wj6TyD(oxS}K?@|V7T-Is5DQEs+LBJJ9fpBP?T zHUgC8phyChX=3pN@#XLT9P!Cpf@+81!4gJ=Qq?salYr<}5RzMs9)aMCSa7@P2Tx8; z%`tfIf?zOvL+nx%dHnLFTflsn*E4~7<(s@eOk-uN`@VdMVdNNG=kq@_aLK|#FG=yh zo;|*R(oX>?L9y3OqA3^j1SU)=OCA~_FK9qiPYKzH2x_Lsz*WgYK#{JUOnKqD3AB&2 z1dM5_McYIeYjxQ;IXP3@-hw%lp4h;o5W~GYro!N1iHB);c#LUgiiC+);{0T+Bp&in ze?F-&Ls6Qb6z+#T-_Lb#6_ylnI$G(Iv}hU`gEazl&K8tH;V;zSME$k)wo~qZ87y_RpX9Vu~V}eVSpf zQNhr-I5n7clTla6e%=cHDy)%J1EHM?fc#NoUtt+MG;MJ0WI`=FJUXfjeEjJ-n(;vO zy?Y>voc{Y)OI3mn_h%=xZ`SZh!hDil{Tft5DYrBbACXuqSenjIj%J5Dy+m zp)Zi^d*u=VJp#k|DQI7y`{ddgUyR7i_Rh|yxU-*U#Q_pIdhD3+;)i+Y(A*bE9S2H# z8y>qAlxZm;*C7#|M2=Mv%g>RKFeE0Nfl#TaVSTl#L!5ro&c@xkfjU*HX%n@2{%&&l zv4_w8&ggo1c!#=2J0E-HaU1p>Y+eKMhXmI$brd)Lx_fUQh0wW^Jv}4R&Wop0xOuOb z#7p@GOjLQq(&Xh`i)!Rfym z6&V6SS?jGwJC1T~97sF;PdBsfyw;Jldm9ot<6jTB2U=NKB|&ye5Hd2=r5zFmE4Cp@ zykR6{{ACeJDF8T;kl|B^n5Drtk3zZaHVYLN4bXo(v2gDhb)!e+8jo8a7C_%>T-JA7r zXY+DO_T~?9Z@(pP(i%EbGvFYt=;-K(jV3hYrWZ(*PQeW%3B!7?zL3j|SY2lJb9WaHLEDxPpw0S8L1T^fPyUw%j>(E3#wr=I;ON>%GIV{`>dwmkUu! zXi$`qkDxs{1kfbOpTe6ZF-}C8xfByO% z$L~Jw<8$=6D_z&?^&F4K`8daA%)2uM&x^799kCEr^Oc=-*v-e@qokwF9&)?H+hb*< z!kWo}Ee}uZY8yS>qRq#iRI>0<+8vhcKX~vcomNy5Q1r80d8j4-CZ5gJx0~X?R02t7 zck~6n{pA;T548b+eTyC^^h6bP1M__N?s5@ogHCQUpg+R-bd2-|xKp}iBl(L|+Z|o@ zo*3e)j6IIPJU`@tq4Y7gv%85Yyz+O zqN>V>yX}2Ng$mArVdRz&JsSKGhNL!N9EO#o4w4Q@R`(FRfNxA-OV1#1Qh&k&Q{34D z&y_4DqANzRMJa<&Q&$I+v#|_f^nytlHYoF;$qPk}D0l(UyB%rZb}>>U`yG^&A*o^n zkb@ASjspluPBbvqfxDd|v7aPD8^pbbg10_)<0;j!ufJE)o)4YTT8dN-0Wg9Tgvu3k zXk_iI2@4Mw4Amf36`)eRgH19f(W^E+qPe=dy8P+oB-&F#S|N-|4?a9Fo~>p??i&nN z&Yivjpsv@5Q3?7DjROZ%;G@}&M2n1q>C~@`AHibgLHHWPn%+oo4XZWIG-H7FYAO9t zUjtcMlZ}4?g@3Zv&C0-ymQ@&(92Gj>>c`@clE3kx+h?LZsGpq+w1dl9&Ss`#L%* z6My);?b^O=TS+#!2P7>D-Zc7^ys)swXS0M&0qgSR-1U-gV%8qs_!E@edt1$E{;a@# zNhZkW&y%e@|M#7}5TdSPVzLe^WbXmvWCTF?;LraA&xfMwb1gR^btK3&7OHVnY$Tlv zAoYG_WxA#;^zwv?4Mp<9jEq~r4>kx3KPo8~oYdD$JWNPVP&}S)vWG!FMInqY@GSm+ zSX9RyE;4X&*-hR)1b1zaUS0L+VdIF^MflW0QL;H!JwjeAz1KmEHn*Fixx>7@AiPSkT@KG;X-xZQ8B+451ubd z0wD>BC5VrOe?kcnKEZh6*>^lTb6iIPLeNzr7P}2)BK*tqd3ui+W35pX$GK6;yy<*933h8vgRFblMaZGB6)mhg~>!4ADtL`M`|siKt$S)r#k%W z+jbHgk2z5fwWq{U?8TSB}I!V{Y{Xon_@SV(YvVdK&{?xWLh!1+2 zZHibO*l{h#VnYI(I*ywQVTYXX*?Q?@1J_$u*Rw*p+V$B<1T`D zo%z(Z$llg_o|Ey!C<(i0cz9SD^W&}HSc6uadF;|1&BXUrRRpkb0KE?uxr~%9?pfN{ z7I+t6ACL;7z9uM(*JcLNf{h%y)xOQ9V*vfuwR1PcTI zfxc1(;|4zntVE=rXn^;K!G<0r0^}2rIA^F*Na{97j6thEg+bX$Q|&XRgg^ zmbk0OdEyTsc9JWA30Gpg0QlmB(?*p3P~rrvZk)BS$6=1+u^c3Db6eXRKrV>j1Tea! zvpZAJBYf#fIXp7TmPhPu>tRzIs=yWCL$aCTEs02o;UP{t=vmM*Vgh;?&L{Bf55IF~bxK-VJ=8kA zFkmP2aZIpS*xiPlF@jxh*OGtSSX)OY2@_yFoRXo<2>u`~P2n&pF4?XVCOZ!<*-(T` zSDbooaefS3$^K7?Z2$1nER4W*I(_C07iXxJXac^*5gc)gDbS(<0F@jBFB`)&L}xtD z$ywzqMgcB)gwnna$KFA=rPv9Yr!V!^dcnc0WE_3phGol^B`V;vfvG9%!9c3pq|c!o z5dz=u7Ej$8#gv62rb3nOtze1c$nimvP+YO(s=N4kBtDifm4WQ*cbiNgff2{Jidru| zDDumuDthqKv?GiDE0)L){@z|U^1t$z4{*`{eo5M<|IaVU2Ke9qy70>jID-8UHsbcI z{BBfK5NOj6aWG!6R{K`)(eWpu`=!< zQw(FWe{Zk7_hiKpP>c$!4$_v-Pfr-0jR_8B$JG=P6SL`~lBqG|@5s*%MlY>$;>1k2 zyb{z!#ptxi$HG@I1G)V@>KE{3QNEUKF(W&xr2WSTpEkq$Q`?AB7IB4eb}qw0L^Atz z2z4xR-I1@dZTog&>OrbTkS*t}Fa7)5e17D|<<>ZSSBU}CSST>rR((=`25Vmsi@4zJ zLTE&wa}o0jcqh>CI7`YsJWYVdQD!)?cy`*X1oeP9ML!VyE{d9)>fy)5ea*BAuV*aa z9eNjS2AskP*tNvz%+1{$yuG+EF(7hepc56vi)#8hx);yeucjv_+h9@x%Z(B+tRueU zSl1C&s2{ZakQ6-1-VA~gkXXV6&-@NM88bW@_&W20xUdKxfJCtXVWx;AF&=0vf7d<8 z9qKa8RZ-qCf={k{LqW;L=GS?|shuT`4WLz+ zTU-0%6$=RpGT?waZE!0)dj|xvD?k$UhSnFRTx06ft^ez^v}MiB%ygv$A%F45TvPJ6 z0FdfBR8&wh#N&=Yx2nf^1td^!%=}?yLRh&dn@}+mJ{b`MLaHSYUa{nR4+f}?e|q(h z+wOmsSaspV!kL+RI~ONAb0F%3T=L{VuIG`xAPm$33-=~8XNz&55lc zp1gl?dol+r2MbAP~wi{;ZMFS_T0euZeajat~4OVFo0=XWO>0SOwR;klSpa zPFY&2V&$*;AhT_o5TPq7qv+LaZo#sqbb%}=HBC*SQeY)fpXs#l|0QwkKaq1L;8jS=X9@Ijm9KY%>p6a8tw1Y^9TzA&SCJgs3WXIwD z{{JDp&@6%P1Zx8>s;)y*trJ=&suwC!%}dMJ*b?w}>rptV5A=hnUOJBMhKY`#_T&rE zSRzbx;&pP{19lfQWh_~M(3??YJ~%A@tF_QnK^s&i5aL{iE|O4XnlhrKcATl=Nky1P z*s5&{(`S_9`Y#4yeh`@W3QP#*-#tKiI(9z9I0Q_H+tJZlYHEa#Mg0NSS#q5iDfF+>faYOxmeOCI7Oa&qp3g#@Jw%cOhdP{2?jNl8ifR)gCI z-Mr?HX$n3wjuz`7TBRui|2{1H<<~FUFb&~HNO!#50+H%7EmR9MWwNn^;<1{x5yy%h zNKK(B11S-X&KJ{Pp016b#8m^A5G4iyh)EN-flz{K1yPB6RaHS> z^1)5TN|AYx_z?DB$xpqKqqw*3tLb`gc(o=U^A}ri6`LKg6vGANG>S_pR?5z+jGvc9{t`@-PAM=kxNyKeD*6psqDUA6RuZ z@ECW!?^#`(O2OFBq$GfXsT|(JdN}!Td!-!v%}Xk?*FR;!S|pG>YNHTzJDP^+U}to7 zcZXp(4-UQ_v?0kT9hm4K8}>GudLHdh$5E7;H;C?0Tv9R!`UO=8_qoR4>F7_@Lac6( zto{koW2zSPMSuVIA3p{!a5qX7z(x|L2(d`|Da2_^boj|@;?fgAb3s$a3RykI`r`-6 zd#TJlz&#gJkWO-N*5RPRc0uq#ety2ce=<5>COTYqtP#`0L`M*-hMF2i8N$>K#HUz1 zxJHPqB#;~J=K?dNp@IB-%>xJYDkPbXqbCYIDIgS&?ZH6-eONKZTGxXC+NMko-057t zQkFYYeg59KDVopNxHkA67>CnmgiHOQu5Qvt)^0on)LHScg@27T8- z-%Ic$bjS>5*RpnjRV1#1o%am*53xs}0RJ*6%i5UuFEzXooPoV{ve4t^@UR0K&UfYI zEL4=$N#)*n!(U~E&Vy@l+z?}2{ijB&D59%_Jj!&_?KhE0 z8GGQ*!-Gh2ybuGxv7AX?8rS6}xfj4#=|SA;A-%S6E}jH087 zF~@QO2q3S46fOv-Lyf)6VXi+?Xx=F}x87S1AG|KV4kYM4~=K8|D2m*QSI1rTQCoETKJih7R@i-X{Uw*0D9 z3$&W|r7ahsQwcnaYnWWSmDSa&>e0)Ax1imz^&oH*eengm89ET|_m!1_xC$d)HRA*= zjZ5?Q$4G!|QVD}68W3J5;S;Z*UP08t$%zvw5Ea#0zSD$qBU_ zjM_dYqfG3Ofdhg8mn|l=;`MSZh>9Rhiy22PF1S)h;-xAsEsa|n6Q3C5=ny6+0Kj+* z@N~&VBnN7P0U6)i!t{+qnI>Rp0)vq;Fn87eq-^?SiOPDL>MHW-^g}ticzb+-EFZ?u zLJ$gOEPud%n;PBG9Sg$p3Dt&Pza|SE&yZLb{<;rar&9bd4jvwV_*=HawQ_~K#D^&G zNXcFT(nO{=UouQ@0XTWr+4foeU(D&|uV32$(BFe^2!4Wy^OPaH zyKyQ3pj@G)r8VjM;s1`!o)zUt%EX2P=(Zo+W0z|ySAcA03&}8ETV`(Vem6G-gLLD? zFwX%dg%8Mt`glJ!qWXg`9kqFmmc*_ZK0CPjI+tOQ{U=uz#r5TbN(4od`RUW8yqz0_ zj``xThQ`KjUbLUorb(T{y)NXnx#(!===9vwV+THChI*#smu4Wre9^t(pYNezdiWnm zXUp^~VfQ+*q+fY(^a|#ar9t(IK+wHfo|r$uX>~aTIq>T9WOz5FJZUzL0qNZ1V@1)! z(a#f57Ir94k~tW0OA8HU0EUQ0&h6iLBWZ>I`%ASwyyt1`J@xxo@3#wO&#KL1pe2ot zud}7aS>86ZSKAt5YsPN+lk+ZXU0@kI;g z8&it@5~RZ-nUELmO)9XQ2iQ4`5dgZIzy~O7`f(c{4TQ$=sC{))nzAZTtnM&LwJPhwb|oOYl#z!c`BSphB-#IB}R{Zsuwv-Qj)m~_JU~{b5tn96BD+j{OnG@ShKC;X4fe2 zXdIY&e!j_bp4lje_QGyvw%=o3v8|0#xLP*vCcA)R`TtZqiHWMx#VQOjeSnDUyTQZ2 z&;LN@ZR0`#IJ-^zdu}UDX_n$sVEvx=R_$g-&u8(r zhBTd|g7RC8mSxoO_@K0o~Y!o?4U*`|4v@ymBj>QM2}Pk;C-+qJM5=j3sI zGg5O0N3LQ3O5MwGK>hH*$z&YHuB{#(9=Pc@eQ^fP4YfE$>uazd*oH?KysvrDslW0LS_a?&l+EZs08c5((hQi%ixH%(;A9;sj^bK26D zFF1`>-ljn|P6oEp@aiDr5BRvfh5hX97g4wyVcQspQ;5{QWZsA}=wJ{1ONP~tiom^( zb}wC9B4yo}!MI^R&90f|>`aeXrJJ#S#w4dd>C&i8X&&g>=ULo*C@xWj$s@^PG))W#Y8sVnAlj>B1mSl_lqQk7hrSGHcrL&|FnO zo|kp0+XE$O=cT?T3G3G@CutYO$ioX?`GKM>?}ArJ&(E-tFH6FrqnF}j%X|5fH0(qe zg!|g;+&MPTb_mj?;=5;3EulgW zHT9t?Q(t0+=`TDR%>XOmcyO_b1d8a(UWF56AFD)!Hfn6{KABHB4=vJ;l`>ws#Ngkg zOWP+Av!DAwx+wY)b3FI1l==AP#a17;K09w&d{Se{lIZB|ekQ7gv$X8qE8x?BqD9X)qU;7{dzTEEJm-kr*c6l_iC3L6d}FCKcf60>Bn9T8slYAkl@t$p&Nt z3JKWPNL!Zqcfp@Fz33l5?D$}h(F=DjizXo4i>d0^JyHJtI7NHs2V-2_4mGxvJ-8Sa zt|xjx!)Q$5?p=wUKbUUbS(|!AyzBZ2)h$=fxg0#SD*O6PchwNSAS^3eGgJP2LROwJ-biuipS#k7e+T|HoqPJGu}NOG#`Vkjr-R^fWqqr{ z;4ZAwbZ(TJR+|xru7;@y*mj68jE>7V z2+7XCRjG=0uP>B3x^<{UbpO`ABc9;FzvI25g3KM;+9JI#4H0f#tHx(S1cTkcB5gzV^6&h}QlsWtaKOmNH#pYhZU@A@a|tkWO@n z=iIvo-u}8OdCM_(7hQ4m!XTJi;zwqD4HraC<_4^0?;#wmQRB0Rd(1%|P{& zUcZ(%F*cs8-qp&}{{Wq{N)>L32cRBK~$!S>jpZ(u4SB1Bns;W2bZf!{GEawl;wU_<$#NfHTN%_uSEl=IqbZ27ZLfKYtWZ+(tQc_zS7W1^^ zQP9CTnChmE&h{v2o`M*m&bf^)*OHwgH#b)E=+-Sw$rE?r@YL1Nf3~60vEYeR&RMm6 zaz6dQ2lKDEgd8{!tYG9G8rnHOd#jS4E8a)sz{xyigD1Uti!NVosQHJ4u`elOIp>m^ zT>d^uXbIx3uqYkPz4~q2rF(diXC?}q`t+Zse!43a>N!bPhs*ui@6SEw z#vUw>P!bgM0vT15!c^%3jwV|Y+w5SyzFZ7tKF}!0DY|e29w%;jZJAf?%Yarc>!`DM zR%F5rmQqlqkPvQx z5^CA+4*X31ufI{agM9G`+CjXl`VWg(SjI4@K}+?h;*8*FKAJ z04p6EyAvJznzd^y3Bo|%oDZKRRytP4qXwHU5J~c2tw(!^x+m-Ta~H((+}9GtB&fHs zF-eDiAsb^n8(lINbt2mu*>RVD^D$(iXZoIVjvN1qHZ@zWG-tl?Cn%&8gn&EYjjM81 z&*WfOzN6|(gZXLhHT**yb~!fUDk1l*t2{^IFSMMg-uB9RZSnP#3rCW|=4T2uYnSmT z2d`1pj*R!I2;IQ$H$Lk+I^=0c+f-;b$e|&;hWl=7%D|82W1`{#-?Ibwc4@D>>|A42 zrF(YgISIWSyC|+xBAT7tx-Bi0JKcF~WkiOvFTh%N;Qo#SS$z$2B>^_`AGS1j^n6Tx znsZLR4;9=uyHF=gFQY5>^y_wKOI>csbjKlKL=`UVqCc;&xo0piLG+l%$Pqo3&2p|Gb(U6D zUM}snmhXw0kEn3;*v_+Ig#{|tK1+*DOfW2eQGBU6yCSsUYVO(#GEog7PqH)y8V&|v zl91zBbE!M^s12(jZ`q>vXR7%w*>qk0CD3|B((|>XzHa0ER8Qym!aZ*M+Obb6?{19y zUL|_y#`r$95WnT}(fiXPV3#X((m2uX>q91KWrNgHPP=!84s^ut75?RnjPTJ`ww|Y| zEaPJ*lNZ4o)lMYu$Bzc-UAsnK_V8KMO$Gh@r`G%Ac>le>r@z`8*04S->AKt+dUuOF zQ~K&yy^PprvBM4#bA!2Me-4E6+41hqw6@O{@Mm4+qjVjNGdEi5*7iO=tFyVy-{4fX zXU_5F7)$*guU>2!T*ZKa`}%73Oz<%{V7AOu1SmEJz2&x&Kzs21DI^9RG+7B_O+#*V zAi!4WlMo2XLTh8&l3xVnTo!s!CXj{=F?6UCcn*Wua;c={=4lO;z-8QBXp6|7*HU568I#lpdt`lZA!W9@RE1F8313kg?N}mX=4Hps!UmE`|hoJyC<>Hdp zB5Kw60!2Af5g2x4u2C2a)UnA{=8XsBo_OEVVq$&(92(WF0eD(f-Fq8-mA|YpCPpO; z*G;sv<@L?^?rv^NX>(qutimsLhv0r$#+zzB`mW?=#+KvheBWN}ly%wq($jNp`a1hj zSEc#c_Ky$3e{QsVmK-+_A-S%&cG=pEj&c@0O&NNsCfidi_;!j(Z~iE#5Yyb&9yi+h zGJ)x7Mn>Qv=G&REiZRh!RR)*ypZud#b@1-(;hj+t4%&w<8NaT0^yy9hZQiBH$39m_ zt$R24G*^F5!hT+p`h4r(7y;WHTQ6W$WAJhOoo|1E^+d9xvfPVnTkR}IDUW2+P`HC|HKLk zwyL+wT_R6AFaa6+S7hD;CQ08E0PJ&ny0POCDgIvG>LcHtKSgJ*gy@H7BFjjV zTDol6X-qnC;iSF(1QM48a2_X?WAcU=_iBUzi4&sizh;5brVUV_ZYI=ZO@8XCM=(b!ZsK}6q*S#4c zUN|Ojofgwcy>h0;pnTtrjaQV;ZtjgbpXzQGcElxbiF7TKx!J?%KECZuPos**`F3h1 zs;hS??blp#JSkXiJ$I7mC5B*KUmZogkteW(#6)T89b12%jF8^XXVuy6(L}Y_nzv;Y@Lt*T0l{*rrmzr`g zamINMpCXob44L{VhnKRkS>h>v1qO^6Z781KC+6U8lJ#=|O)xQ={cUZt{Rxq#Q8O6h9&?%r)ZBj zqvo?pIh@E!H{Bg@1JxPv45uc)Sv{yjk3&slMF6Rj8Lu;Lz-m)M*@q2Y=Uv*M5$%(pLbzkoP=I%En} z$E7453g6=c&{-a}yy`Rc>uiCEo7~2rbQHJER8ur0Tp3G4CQk0*vMiUgkPq?}eOz|S zP-vuTO-|yYjqM3`;^LK@PA7c@rK$vL%WhtLbh*D%lE6_HCa_1eB{kd4{l> zyr`;sym}MgyU~)x<5z)%xvf{!lCkMz9iTpYoP2R!?BE?IV@nl2xkpW_c{cJ>3;R3F zy7<*ZGlrv6zh4i*8*deKOo#cXUpVdK9yj1TmM;^N|OSoGKZ{07`j z9&4>B4rIDjmG4^iwa`yJYUNmF)QgU{x5aHtPwY)Tb)c(1G&rvgxdf~8&ljY4Oi!h> z_sd`YtR`tUxkqgOvI8^IsoD7-Zap>byVrU9ekxO5VIkL@<$G6L@cbt^_30pcUE<5} zs}pifO*v_SYc|=sytJx$H*+A!>ff*JJ2?+rJe-qv%&PoKr^bHcU!_5sPi%_k1qE%q zZ;Nv5QQ(u#@eQc`@j8MhzvuVB2c_z$q^1Mo4gna^8GO|~ zNR)ld9`T9f&0^FQ&lYX!52H~B07-nH zS%5`!Dej4E&c|l?p?pgY7lX72NcX$&DV7YTVfX{(RYDO5rg_1^-DutZ`~wpx0K+F&X;epTu9>cYb|gan7*@U$%y(l!*c@p7+&9rBfp$ zU?n$Cz1I22=}(X=m%)-(AEt_qqZQqv>DHb{ej4y_v5k z-ovn&7=yc8Xk!4v6VszQi;2^8$%B0F#xq&cd-lWt7a$(z-w+@fU-QQ!5GoUTuE|Npr0^zmmkQt|M^ou@#JFq^mvfLW)byeGwCP)IZRFb((|sgHTcM# z68*u@^b)Jirr)2wi8owN&(RGD;y%h};gESh5iRrmOZILd>rO9Uw=IzW&}Uj@os{*b zqvj=L5);xAnuqi&4;~J?|EEhTc&x-sDI{uF1nXx5+sP@bhAmOMxCedV!LOO!v-qI& z!$UF>2376$HXk%XZH{kRzId&%8*F@k*!$(?UN%3!PZdoo)I-a&zTLn; zJpopp7dFJoJbzCA^3-eJO?t|a`Mk0Gne;20I`{K4Y}haNDJ#n>PSwkYX?#g}^2Ug{ zfsFn)1L^6?gH6GPT8dI1?lSg#Ofgh@^-}f|4)>Yg|7NMA#!^L@=UHB>ByydLC@II_Iu9dmTfQukuTga2-f!5|8*O-93?u00??_bwr!Ezj-meufAajpJO7O z%~Ptc51E?EIX3+k9Q*-&wvp`bwE2mTz^Cx}3`7*kV@7C_B$Hwo0pf z=;g~#R-TI#6@j;V#?u^DF-R!rRefUi9u}Lgi>#i`oWj^FQPn3YJWQlPCw%cny}i?_ z|J5GzUZBM==srUkqCfimV!zc>qmDa^y#<8yIpzv$aU@gpnVwsx{LnZ;~-llazggfIX+9B&u~br(#5Fhj_hknaC91rk6JVjLz*JiF|p zogR@NDWp$+TrlpyIFzYm%1DGSfU;MNsN*?#8zHDUZH@^bv(Q@#u(kQ$1u5R64ABAdiC#|w-BflZs97G1!^grc{# znNf6ncI0&|4@0_Qv*%HM5G30mk~xOi@PFx&k<7^VhS+co-ihk}S-zy31i=U>0X&B53W&NXLjAx%nYxc3Es#U^$wCo^B^aS3 zxtGjji+)};vC`IN2j2%|qD52@FpEDSUhxjNkKkO%lJVy6TARtkA*K78bMCI9lxKIY#14#hMbPWI$CCMiUst5;B<##RG@ynq?#!n;slCQDxdE3>w~J{+XpODL0`zFt*~avB3}h}@nDz$K=N(biH-dr^uz`S4p|@wHV<9wn%4NZ)UKRWD z*IAC6!Y{8**kjrs3AWai0-Te)qaddRfO2ph_KRf;fiuZTH%U&{ZpRKaqo)S{))QY- z7|@U`RfesiqWiX>SYAsr17D)^Ee;}=%8+&!mG`P(?>;e*MAZ$Mrh98X+Gtj&f3TLI zpOXf$5rCMWloUeK-mz^Vo71xFh6;8sY(yB94+)Vt7m}G69)1m)u7To-wa}^V#d0Ci zG(uJYDog18OI@?`>Osa(xNvnj-)?Z^^vTk~6Rh`Z0daN&K`<7W{*m}cQg@l#h7qDR z^^k<9{{2f}-)8{i-n4)t5{JjL`%?c(xalV*UA=OpzfeqAn2@1C7&OAc{lR~I9<8dE+sP~k2aW+AEd`fQW%`j)89?XabB z`t`L=U=f2EM0OM%eNY@Kkm(b5@uS+{i`FBFbk2qBpIhHsuwy7n!Y~~R3-1>PA^D0V zBZ$JK%dC9Jj7CS(wV=E)+ZG81?-7dK3aL`70gmm*RrU;Vbc7}HiuX!e5yQXl;0sQb zbc6GGN$(11fO|kH>Y#4dr^tQ=m4WE%uKelsLf5`>@5x&m^l9yg3}DzHtSZ5>OO0C(GC^^=eyMZciA+z=xmKc5Lg(iz{+= z>gKrHnS0n>pF6na4HFg{SRVs+msdAq3bhr-UD#3ZKi(o~cXaWoBI)8e+&Q3jt_3j# zF%X=$H=C@*hTe-{B57po{NQXL-vjuF7vx~zW--Hyz6>`)Cpn%MIxc>2?Tc}9VA*+r z3vz>BsfDAFmBLdkM|j~7(f3#NJmt^`M# z(I9OV@wrEX^ZPyYL3}vQiZKdy+NDdBMueh^FvUNDWAV^aJbfK}Kh22a{)W`j6R+~} zDEj&huUyB@P(?vo3RsIqUL@mMB0@~8DaMD_TXCQ!ZmB=@>=+?h{rTgBpk^j0(j}0S z7YKB*7_wc^-#?e8VY5On0MYXz5VrG?cnA({8Rl{3GEtl>SNdSs4DL;Qk?#zEa$oF+ zHEPfCa)+5hUmo|?-HNkuw(Z*T-i{6gW@9phqTn0IoiD8Gyw7AsQeVOFb32Xa^5DFy zC|F7MIB)TKJHR(tIt3s~lTv`d>Zw86$z7E5@9&YQNAfXI2UWEO{XOrQn;FNmu7iwY z2^Ks;PlG;}VSfJV_3L`{^O@OtC$S>daB;oEOfyvY?xqv_D7S&9x%XmYKXQp^a!||H zD`hQh8w2!b3hp813z1I;gvd zQL;dE(9+WwdF;me+1u<0&tn?NjO$_`7xg=G$FXqm@_xWO>$lKvM$;_oF*`|XEXQ4B ziK})E2S*Vm`i>CrXdO5p{)b4|#VCZIgb4E@4~4S*oXm+(z^Rt2LztK7D@|aPtv@jX zdU+MBp3^l>!EX@>~>x@wjBBLngyfP=S^-d~N+<2OKl*7mk?YpeISdSUuBACuVMZA|gB_ z1`zWMqJe`Lx*eVe&x?ik<82iWXkm3}go>{_8PR z(0<^!Dn%>6fjxuE*8&~E#v_k!INkW~B;@c>3I;SX3&t!?p8Mu@M^Rd + + + + Style Guidelines for fptools + + + +

    Style Guidelines for fptools

    + +

    Comments

    + +

    These coding style guidelines are mainly intended for use in +ghc/rts and ghc/includes. + +

    References

    + +If you haven't read them already, you might like to check the following. +Where they conflict with our suggestions, they're probably right. + + + + +

    Portability issues

    + +
      +
    • We try to stick to C99 where possible. We use the following +C99 features relative to C89, some of which were previously GCC +extensions (possibly with different syntax): + +
        +
      • Variable length arrays as the last field of a struct. GCC has +a similar extension, but the syntax is slightly different: in GCC you +would declare the array as arr[0], whereas in C99 it is +declared as arr[]. + +

      • Inline annotations on functions (see later) + +

      • Labeled elements in initialisers. Again, GCC has a slightly +different syntax from C99 here, and we stick with the GCC syntax until +GCC implements the C99 proposal. + +

      • C++-style comments. These are part of the C99 standard, and we +prefer to use them whenever possible. +
      + +

      In addition we use ANSI-C-style function declarations and +prototypes exclusively. Every function should have a prototype; +static function prototypes may be placed near the top of the file in +which they are declared, and external prototypes are usually placed in +a header file with the same basename as the source file (although there +are exceptions to this rule, particularly when several source files +together implement a subsystem which is described by a single external +header file). + +

    • We use the following GCC extensions, but surround them with +#ifdef __GNUC__: + +
        +
      • Function attributes (mostly just no_return and +unused) +
      • Inline assembly. +
      + +

    • +char can be signed or unsigned - always say which you mean + +

    • Our POSIX policy: try to write code that only uses POSIX (IEEE +Std 1003.1) interfaces and APIs. We used to define +POSIX_SOURCE by default, but found that this caused more +problems than it solved, so now we require any code that is +POSIX-compliant to explicitly say so by having #include +"PosixSource.h" at the top. Try to do this whenever possible. + +

    • Some architectures have memory alignment constraints. Others +don't have any constraints but go faster if you align things. These +macros (from config.h) tell you which alignment to use + +
      +  /* minimum alignment of unsigned int */
+  #define ALIGNMENT_UNSIGNED_INT 4
+
+  /* minimum alignment of long */
+  #define ALIGNMENT_LONG 4
+
+  /* minimum alignment of float */
+  #define ALIGNMENT_FLOAT 4
+
+  /* minimum alignment of double */
+  #define ALIGNMENT_DOUBLE 4
+
      + +

    • Use StgInt, StgWord and StgPtr when +reading/writing ints and ptrs to the stack or heap. Note that, by +definition, StgInt, StgWord and StgPtr are +the same size and have the same alignment constraints even if +sizeof(int) != sizeof(ptr) on that platform. + +

    • Use StgInt8, StgInt16, etc when you need a +certain minimum number of bits in a type. Use int and +nat when there's no particular constraint. ANSI C only +guarantees that ints are at least 16 bits but within GHC we assume +they are 32 bits. + +

    • Use StgFloat and StgDouble for floating +point values which will go on/have come from the stack or heap. Note +that StgDouble may occupy more than one StgWord, but +it will always be a whole number multiple. + +

      +Use PK_FLT(addr), PK_DBL(addr) to read +StgFloat and StgDouble values from the stack/heap, +and ASSIGN_FLT(val,addr) / +ASSIGN_DBL(val,addr) to assign StgFloat/StgDouble values +to heap/stack locations. These macros take care of alignment +restrictions. + +

      +Heap/Stack locations are always StgWord aligned; the +alignment requirements of an StgDouble may be more than that +of StgWord, but we don't pad misaligned StgDoubles +because doing so would be too much hassle (see PK_DBL & +co above). + +

    • +Avoid conditional code like this: + +
      +  #ifdef solaris_HOST_OS
+  // do something solaris specific
+  #endif
+
      + +Instead, add an appropriate test to the configure.ac script and use +the result of that test instead. + +
      +  #ifdef HAVE_BSD_H
+  // use a BSD library
+  #endif
+
      + +

      The problem is that things change from one version of an OS to another +- things get added, things get deleted, things get broken, some things +are optional extras. Using "feature tests" instead of "system tests" +makes things a lot less brittle. Things also tend to get documented +better. + +

    + +

    Debugging/robustness tricks

    + + +Anyone who has tried to debug a garbage collector or code generator +will tell you: "If a program is going to crash, it should crash as +soon, as noisily and as often as possible." There's nothing worse +than trying to find a bug which only shows up when running GHC on +itself and doesn't manifest itself until 10 seconds after the actual +cause of the problem. + +

    We put all our debugging code inside #ifdef DEBUG. The +general policy is we don't ship code with debugging checks and +assertions in it, but we do run with those checks in place when +developing and testing. Anything inside #ifdef DEBUG should +not slow down the code by more than a factor of 2. + +

    We also have more expensive "sanity checking" code for hardcore +debugging - this can slow down the code by a large factor, but is only +enabled on demand by a command-line flag. General sanity checking in +the RTS is currently enabled with the -DS RTS flag. + +

    There are a number of RTS flags which control debugging output and +sanity checking in various parts of the system when DEBUG is +defined. For example, to get the scheduler to be verbose about what +it is doing, you would say +RTS -Ds -RTS. See +includes/RtsFlags.h and rts/RtsFlags.c for the full +set of debugging flags. To check one of these flags in the code, +write: + +

    +  IF_DEBUG(gc, fprintf(stderr, "..."));
+
    + +would check the gc flag before generating the output (and the +code is removed altogether if DEBUG is not defined). + +

    All debugging output should go to stderr. + +

    +Particular guidelines for writing robust code: + +

      +
    • +Use assertions. Use lots of assertions. If you write a comment +that says "takes a +ve number" add an assertion. If you're casting +an int to a nat, add an assertion. If you're casting an int to a char, +add an assertion. We use the ASSERT macro for writing +assertions; it goes away when DEBUG is not defined. + +
    • +Write special debugging code to check the integrity of your data structures. +(Most of the runtime checking code is in rts/Sanity.c) +Add extra assertions which call this code at the start and end of any +code that operates on your data structures. + +
    • +When you find a hard-to-spot bug, try to think of some assertions, +sanity checks or whatever that would have made the bug easier to find. + +
    • +When defining an enumeration, it's a good idea not to use 0 for normal +values. Instead, make 0 raise an internal error. The idea here is to +make it easier to detect pointer-related errors on the assumption that +random pointers are more likely to point to a 0 than to anything else. + +
      +typedef enum
+    { i_INTERNAL_ERROR  /* Instruction 0 raises an internal error */
+    , i_PANIC           /* irrefutable pattern match failed! */
+    , i_ERROR           /* user level error */
+
+    ...
+
      + +

    • Use #warning or #error whenever you write a +piece of incomplete/broken code. + +

    • When testing, try to make infrequent things happen often. + For example, make a context switch/gc/etc happen every time a + context switch/gc/etc can happen. The system will run like a + pig but it'll catch a lot of bugs. + +
    + +

    Syntactic details

    + +
      +
    • Important: Put "redundant" braces or parens in your code. +Omitting braces and parens leads to very hard to spot bugs - +especially if you use macros (and you might have noticed that GHC does +this a lot!) + +

      +In particular: +

        +
      • +Put braces round the body of for loops, while loops, if statements, etc. +even if they "aren't needed" because it's really hard to find the resulting +bug if you mess up. Indent them any way you like but put them in there! +
      + +
    • +When defining a macro, always put parens round args - just in case. +For example, write: +
      +  #define add(x,y) ((x)+(y))
+
      +instead of +
      +  #define add(x,y) x+y
+
      + +
    • Don't declare and initialize variables at the same time. +Separating the declaration and initialization takes more lines, but +make the code clearer. + +
    • +Use inline functions instead of macros if possible - they're a lot +less tricky to get right and don't suffer from the usual problems +of side effects, evaluation order, multiple evaluation, etc. + +
        +
      • Inline functions get the naming issue right. E.g. they + can have local variables which (in an expression context) + macros can't. + +
      • Inline functions have call-by-value semantics whereas macros + are call-by-name. You can be bitten by duplicated computation + if you aren't careful. + +
      • You can use inline functions from inside gdb if you compile with + -O0 or -fkeep-inline-functions. If you use macros, you'd better + know what they expand to. +
      + +However, note that macros can serve as both l-values and r-values and +can be "polymorphic" as these examples show: +
      +  // you can use this as an l-value or an l-value
+  #define PROF_INFO(cl) (((StgClosure*)(cl))->header.profInfo)
+
+  // polymorphic case
+  // but note that min(min(1,2),3) does 3 comparisons instead of 2!!
+  #define min(x,y) (((x)<=(y)) ? (x) : (y))
+
      + +
    • +Inline functions should be "static inline" because: +
        +
      • +gcc will delete static inlines if not used or theyre always inlined. + +
      • + if they're externed, we could get conflicts between 2 copies of the + same function if, for some reason, gcc is unable to delete them. + If they're static, we still get multiple copies but at least they don't conflict. +
      + +OTOH, the gcc manual says this +so maybe we should use extern inline? + +
      +   When a function is both inline and `static', if all calls to the
+function are integrated into the caller, and the function's address is
+never used, then the function's own assembler code is never referenced.
+In this case, GNU CC does not actually output assembler code for the
+function, unless you specify the option `-fkeep-inline-functions'.
+Some calls cannot be integrated for various reasons (in particular,
+calls that precede the function's definition cannot be integrated, and
+neither can recursive calls within the definition).  If there is a
+nonintegrated call, then the function is compiled to assembler code as
+usual.  The function must also be compiled as usual if the program
+refers to its address, because that can't be inlined.
+
+   When an inline function is not `static', then the compiler must
+assume that there may be calls from other source files; since a global
+symbol can be defined only once in any program, the function must not
+be defined in the other source files, so the calls therein cannot be
+integrated.  Therefore, a non-`static' inline function is always
+compiled on its own in the usual fashion.
+
+   If you specify both `inline' and `extern' in the function
+definition, then the definition is used only for inlining.  In no case
+is the function compiled on its own, not even if you refer to its
+address explicitly.  Such an address becomes an external reference, as
+if you had only declared the function, and had not defined it.
+
+   This combination of `inline' and `extern' has almost the effect of a
+macro.  The way to use it is to put a function definition in a header
+file with these keywords, and put another copy of the definition
+(lacking `inline' and `extern') in a library file.  The definition in
+the header file will cause most calls to the function to be inlined.
+If any uses of the function remain, they will refer to the single copy
+in the library.
+
      + +

    • +Don't define macros that expand to a list of statements. +You could just use braces as in: + +
      +  #define ASSIGN_CC_ID(ccID)              \
+        {                                 \
+        ccID = CC_ID;                     \
+        CC_ID++;                          \
+        }
+
      + +(but it's usually better to use an inline function instead - see above). + +

    • +Don't even write macros that expand to 0 statements - they can mess you +up as well. Use the doNothing macro instead. +
      +  #define doNothing() do { } while (0)
+
      + +
    • +This code +
      +int* p, q;
+
      +looks like it declares two pointers but, in fact, only p is a pointer. +It's safer to write this: +
      +int* p;
+int* q;
+
      +You could also write this: +
      +int *p, *q;
+
      +but it is preferrable to split the declarations. + +
    • +Try to use ANSI C's enum feature when defining lists of constants of +the same type. Among other benefits, you'll notice that gdb uses the +name instead of its (usually inscrutable) number when printing values +with enum types and gdb will let you use the name in expressions you +type. + +

      +Examples: +

      +    typedef enum { /* N.B. Used as indexes into arrays */
+     NO_HEAP_PROFILING,
+     HEAP_BY_CC,
+     HEAP_BY_MOD,
+     HEAP_BY_GRP,
+     HEAP_BY_DESCR,
+     HEAP_BY_TYPE,
+     HEAP_BY_TIME
+    } ProfilingFlags;
+
      +instead of +
      +    # define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
+    # define HEAP_BY_CC        1
+    # define HEAP_BY_MOD       2
+    # define HEAP_BY_GRP       3
+    # define HEAP_BY_DESCR     4
+    # define HEAP_BY_TYPE      5
+    # define HEAP_BY_TIME      6
+
      +and +
      +    typedef enum {
+     CCchar    = 'C',
+     MODchar   = 'M',
+     GRPchar   = 'G',
+     DESCRchar = 'D',
+     TYPEchar  = 'Y',
+     TIMEchar  = 'T'
+    } ProfilingTag;
+
      +instead of +
      +    # define CCchar    'C'
+    # define MODchar   'M'
+    # define GRPchar   'G'
+    # define DESCRchar 'D'
+    # define TYPEchar  'Y'
+    # define TIMEchar  'T'
+
      + +
    • Please keep to 80 columns: the line has to be drawn somewhere, +and by keeping it to 80 columns we can ensure that code looks OK on +everyone's screen. Long lines are hard to read, and a sign that the +code needs to be restructured anyway. + +
    • When commenting out large chunks of code, use #ifdef 0 +... #endif rather than /* ... */ because C doesn't +have nested comments. + +
    • When declaring a typedef for a struct, give the struct a name +as well, so that other headers can forward-reference the struct name +and it becomes possible to have opaque pointers to the struct. Our +convention is to name the struct the same as the typedef, but add a +leading underscore. For example: + +
      +  typedef struct _Foo {
+    ...
+  } Foo;
+
      + +
    • Do not use ! instead of explicit comparison against +NULL or '\0'; the latter is much clearer. + +
    • We don't care too much about your indentation style but, if +you're modifying a function, please try to use the same style as the +rest of the function (or file). If you're writing new code, a +tab width of 4 is preferred. + +
    + +

    CVS issues

    + +
      +
    • +Don't be tempted to reindent or reorganise large chunks of code - it +generates large diffs in which it's hard to see whether anything else +was changed. +

      +If you must reindent or reorganise, don't include any functional +changes that commit and give advance warning that you're about to do +it in case anyone else is changing that file. +

    + + +

    Commandline arguments

    + +A program in fptools should try follow the following rules for +commandline arguments: + +
      +
    • The -v and --verbose options should be +used to generate verbose output (intended for the user). + +
    • The -d and --debug options should be +used to generate debugging output (intended for the developer). + +
    • The -? and --help options should be used +to display usage information on stdout. The program should exit +successfully afterwards. + +
    • The -V and --version options should be +used to output version information on stdout, which includes one line +of the form 'Program version +Major.Minor[.Patchlevel] ... '. The program +should exit successfully afterwards. +
    + +When an unknown commandline argument is encountered, the program +should display usage information on stderr and exit unsuccessfully. + + + diff --git a/docs/core-spec/.gitignore b/docs/core-spec/.gitignore new file mode 100644 index 00000000..a1958037 --- /dev/null +++ b/docs/core-spec/.gitignore @@ -0,0 +1,5 @@ +*.aux +*.log +*.fdb_latexmk +CoreOtt.tex +core-spec.tex diff --git a/docs/core-spec/CoreLint.ott b/docs/core-spec/CoreLint.ott new file mode 100644 index 00000000..56b4b991 --- /dev/null +++ b/docs/core-spec/CoreLint.ott @@ -0,0 +1,539 @@ +%% +%% CoreLint.ott +%% +%% defines formal version of core typing rules +%% +%% See accompanying README file + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Static semantics %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +defns +CoreLint :: '' ::= + +defn |- prog program :: :: lintCoreBindings :: 'Prog_' {{ com Program typing, \coderef{coreSyn/CoreLint.lhs}{lintCoreBindings} }} + {{ tex \labeledjudge{prog} [[program]] }} +by + +G = +no_duplicates + +--------------------- :: CoreBindings +|-prog + +defn G |- bind binding :: :: lint_bind :: 'Binding_' {{ com Binding typing, \coderef{coreSyn/CoreLint.lhs}{lint\_bind} }} + {{ tex [[G]] \labeledjudge{bind} [[binding]] }} +by + +G |-sbind n <- e +---------------------- :: NonRec +G |-bind n = e + + +---------------------- :: Rec +G |-bind rec + +defn G |- sbind n <- e :: :: lintSingleBinding :: 'SBinding_' {{ com Single binding typing, \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding} }} + {{ tex [[G]] \labeledjudge{sbind} [[n]] [[<-]] [[e]] }} +by + +G |-tm e : t +G |-name z_t ok + = fv(t) + +----------------- :: SingleBinding +G |-sbind z_t <- e + +defn G |- tm e : t :: :: lintCoreExpr :: 'Tm_' + {{ com Expression typing, \coderef{coreSyn/CoreLint.lhs}{lintCoreExpr} }} + {{ tex [[G]] \labeledjudge{tm} [[e]] : [[t]] }} +by + +x_t elt G +not (t is_a_coercion) +------------------ :: Var +G |-tm x_t : t + +t = literalType lit +------------------- :: Lit +G |-tm lit : t + +G |-tm e : s +G |-co g : s ~Rep k t +------------------- :: Cast +G |-tm e |> g : t + +G |-tm e : t +------------------- :: Tick +G |-tm e {tick} : t + +G' = G, alpha_k +G |-ki k ok +G' |-subst alpha_k |-> s ok +G' |-tm e[alpha_k |-> s] : t +--------------------------- :: LetTyKi +G |-tm let alpha_k = s in e : t + +G |-sbind x_s <- u +G |-ty s : k +G, x_s |-tm e : t +------------------------- :: LetNonRec +G |-tm let x_s = u in e : t + + = inits() + +no_duplicates +G' = G, + +G' |-tm e : t +------------------------ :: LetRec +G |-tm let rec in e : t + +% lintCoreArg is incorporated in these next two rules + +G |-tm e1 : forall alpha_k.t +G |-subst alpha_k |-> s ok +---------------- :: AppType +G |-tm e1 s : t[alpha_k |-> s] + +not (e2 is_a_type) +G |-tm e1 : t1 -> t2 +G |-tm e2 : t1 +---------------- :: AppExpr +G |-tm e1 e2 : t2 + +G |-ty t : k +G, x_t |-tm e : s +----------------- :: LamId +G |-tm \x_t.e : t -> s + +G' = G, alpha_k +G |-ki k ok +G' |-tm e : t +--------------------------- :: LamTy +G |-tm \alpha_k.e : forall alpha_k. t + +G |-tm e : s +G |-ty s : k1 +G |-ty t : k2 + +---------------------------------------------------- :: Case +G |-tm case e as z_s return t of : t + +G |-co g : t1 ~Nom k t2 +-------------------- :: CoercionNom +G |-tm g : t1 ~#k t2 + +G |-co g : t1 ~Rep k t2 +----------------------- :: CoercionRep +G |-tm g : (~R#) k t1 t2 + +defn G |- name n ok :: :: lintSingleBinding_lintBinder :: 'Name_' + {{ com Name consistency check, \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding\#lintBinder} }} + {{ tex [[G]] \labeledjudge{n} [[n]] [[ok]] }} +by + +G |-ty t : k +----------------- :: Id +G |-name x_t ok + +----------------- :: TyVar +G |-name alpha_k ok + +defn G |- bnd n ok :: :: lintBinder :: 'Binding_' + {{ com Binding consistency, \coderef{coreSyn/CoreLint.lhs}{lintBinder} }} + {{ tex [[G]] \labeledjudge{bnd} [[n]] [[ok]] }} +by + +G |-ty t : k +--------------------------------- :: Id +G |-bnd x_t ok + +G |-ki k ok +---------------------------------------- :: TyVar +G |-bnd alpha_k ok + +defn G |- co g : t1 ~ R k t2 :: :: lintCoercion :: 'Co_' + {{ com Coercion typing, \coderef{coreSyn/CoreLint.lhs}{lintCoercion} }} + {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{[[R]]}^{[[k]]} } [[t2]] }} +by + +G |-ty t : k +---------------------- :: Refl +G |-co _R : t ~R k t + +G |-co g1 : s1 ~R k1 t1 +G |-co g2 : s2 ~R k2 t2 +G |-arrow k1 -> k2 : k +------------------------- :: TyConAppCoFunTy +G |-co (->)_R g1 g2 : (s1 -> s2) ~R k (t1 -> t2) + +T /= (->) + = take(length , tyConRolesX R T) + +G |-app : tyConKind T ~> k +--------------------------------- :: TyConAppCo +G |-co T_R : T ~R k T + +G |-co g1 : s1 ~R k1 t1 +G |-co g2 : s2 ~Nom k2 t2 +G |-app (s2 : k2) : k1 ~> k +--------------------- :: AppCo +G |-co g1 g2 : (s1 s2) ~R k (t1 t2) + +G |-co g1 : s1 ~Ph k1 t1 +G |-co g2 : s2 ~Ph k2 t2 +G |-app (s2 : k2) : k1 ~> k +--------------------- :: AppCoPhantom +G |-co g1 g2 : (s1 s2) ~Ph k (t1 t2) + +G |-ki k1 ok +G, z_k1 |-co g : s ~R k2 t +--------------------------- :: ForAllCo +G |-co forall z_k1. g : (forall z_k1.s) ~R k2 (forall z_k1.t) + +z_(t ~#BOX t) elt G +----------------------- :: CoVarCoBox +G |-co z_(t ~#BOX t) : t ~Nom BOX t + +z_(s ~#k t) elt G +k /= BOX +----------------------- :: CoVarCoNom +G |-co z_(s ~#k t) : s ~Nom k t + +z_(s ~R#k t) elt G +k /= BOX +----------------------- :: CoVarCoRepr +G |-co z_(s ~R#k t) : s ~Rep k t + +G |-ty t1 : k +----------------------------- :: UnivCo +G |-co t1 ==>!_R t2 : t1 ~R k t2 + +G |-co g : t1 ~R k t2 +------------------------- :: SymCo +G |-co sym g : t2 ~R k t1 + +G |-co g1 : t1 ~R k t2 +G |-co g2 : t2 ~R k t3 +----------------------- :: TransCo +G |-co g1 ; g2 : t1 ~R k t3 + +G |-co g : (T ) ~R k (T ) +length = length +i < length +G |-ty si : k +R' = (tyConRolesX R T)[i] +---------------------- :: NthCo +G |-co nth i g : si ~R' k ti + +G |-co g : (s1 s2) ~Nom k' (t1 t2) +G |-ty s1 : k +----------------------- :: LRCoLeft +G |-co Left g : s1 ~Nom k t1 + +G |-co g : (s1 s2) ~Nom k' (t1 t2) +G |-ty s2 : k +----------------------- :: LRCoRight +G |-co Right g : s2 ~Nom k t2 + +G |-co g : forall m.s ~R k forall n.t +G |-ty t0 : k0 +m = z_k1 +k0 <: k1 +--------------------- :: InstCo +G |-co g t0 : s[m |-> t0] ~R k t[n |-> t0] + +C = T_R0 +0 <= ind < length +forall . ( ~> t1) = ()[ind] + + = inits( s'i ] // i />) + + +no_conflict(C, , ind, ind-1) + s'i] // i/> // j /> +t2 = t1 t'i] // i /> +G |-ty t2 : k +------------------------------------------------------ :: AxiomInstCo +G |-co C ind : T ~R0 k t2 + +G |-co g : s ~Nom k t +------------------------- :: SubCo +G |-co sub g : s ~Rep k t + +mu = M(i, , R') + + +Just (t'1, t'2) = coaxrProves mu +G |-ty t'1 : k0 +G |-ty t'2 : k0 +--------------------------------------------------------------------- :: AxiomRuleCo +G |-co mu : t'1 ~R' k0 t'2 + +defn validRoles T :: :: checkValidRoles :: 'Cvr_' + {{ com Type constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{checkValidRoles} }} +by + + = tyConDataCons T + = tyConRoles T + Ki // i /> +------------------------------------ :: DataCons +validRoles T + +defn validDcRoles K :: :: check_dc_roles :: 'Cdr_' + {{ com Data constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_dc\_roles} }} +by + +forall . forall . @ -> T = dataConRepType K +, |- tcc : Rep // cc /> +--------------------------------- :: Args +validDcRoles K + +defn O |- t : R :: :: check_ty_roles :: 'Ctr_' + {{ com Type role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_ty\_roles} }} + {{ tex [[O]] \labeledjudge{ctr} [[t]] : [[R]] }} +by + +O(n) = R' +R' <= R +---------- :: TyVarTy +O |- n : R + + = tyConRoles T + O |- ti : Ri // i /> +-------------------------- :: TyConAppRep +O |- T : Rep + + +--------------------------- :: TyConAppNom +O |- T : Nom + +O |- t1 : R +O |- t2 : Nom +-------------------------- :: AppTy +O |- t1 t2 : R + +O |- t1 : R +O |- t2 : R +------------------- :: FunTy +O |- t1 -> t2 : R + +O, n : Nom |- t : R +--------------------- :: ForAllTy +O |- forall n. t : R + +------------------ :: LitTy +O |- lit : R + +defn R1 <= R2 :: :: ltRole :: 'Rlt_' + {{ com Sub-role relation, \coderef{types/Coercion.lhs}{ltRole} }} + {{ tex [[R1]] \leq [[R2]] }} +by + +-------- :: Nominal +Nom <= R + +-------- :: Phantom +R <= Ph + +------- :: Refl +R <= R + +defn G |- ki k ok :: :: lintKind :: 'K_' + {{ com Kind validity, \coderef{coreSyn/CoreLint.lhs}{lintKind} }} + {{ tex [[G]] \labeledjudge{k} [[k]] [[ok]] }} +by + +G |-ty k : BOX +-------------- :: Box +G |-ki k ok + +defn G |- ty t : k :: :: lintType :: 'Ty_' + {{ com Kinding, \coderef{coreSyn/CoreLint.lhs}{lintType} }} + {{ tex [[G]] \labeledjudge{ty} [[t]] : [[k]] }} +by + +z_k elt G +------------ :: TyVarTy +G |-ty z_k : k + +G |-ty t1 : k1 +G |-ty t2 : k2 +G |-app (t2 : k2) : k1 ~> k +--------------- :: AppTy +G |-ty t1 t2 : k + +G |-ty t1 : k1 +G |-ty t2 : k2 +G |-arrow k1 -> k2 : k +------------------- :: FunTy +G |-ty t1 -> t2 : k + +not (isUnLiftedTyCon T) \/ length = tyConArity T + +G |-app : tyConKind T ~> k +--------------------------- :: TyConApp +G |-ty T : k + +G |-ki k1 ok +G, z_k1 |-ty t : k2 +------------------------ :: ForAllTy +G |-ty forall z_k1. t : k2 + +G |-tylit lit : k +-------------- :: LitTy +G |-ty lit : k + +defn G |- subst n |-> t ok :: :: checkTyKind :: 'Subst_' + {{ com Substitution consistency, \coderef{coreSyn/CoreLint.lhs}{checkTyKind} }} + {{ tex [[G]] \labeledjudge{subst} [[n]] [[|->]] [[t]] [[ok]] }} +by + +G |-ki k ok +------------------------ :: Kind +G |-subst z_BOX |-> k ok + +k1 /= BOX +G |-ty t : k2 +k2 <: k1 +---------------------- :: Type +G |-subst z_k1 |-> t ok + +defn G ; s |- altern alt : t :: :: lintCoreAlt :: 'Alt_' + {{ com Case alternative consistency, \coderef{coreSyn/CoreLint.lhs}{lintCoreAlt} }} + {{ tex [[G]];[[s]] \labeledjudge{alt} [[alt]] : [[t]] }} +by + +G |-tm e : t +--------------------- :: DEFAULT +G; s |-altern _ -> e : t + +s = literalType lit +G |-tm e : t +---------------------------------------- :: LitAlt +G; s |-altern lit -> e : t + +T = dataConTyCon K +not (isNewTyCon T) +t1 = dataConRepType K +t2 = t1 {} + +G' = G, +G' |-altbnd : t2 ~> T +G' |-tm e : t +--------------------------------------- :: DataAlt +G; T |-altern K -> e : t + +defn t' = t { } :: :: applyTys :: 'ApplyTys_' + {{ com Telescope substitution, \coderef{types/Type.lhs}{applyTys} }} +by + +--------------------- :: Empty +t = t { } + +t' = t{} +t'' = t'[n |-> s] +-------------------------- :: Ty +t'' = (forall n. t) { s, } + +defn G |- altbnd vars : t1 ~> t2 :: :: lintAltBinders :: 'AltBinders_' + {{ com Case alternative binding consistency, \coderef{coreSyn/CoreLint.lhs}{lintAltBinders} }} + {{ tex [[G]] \labeledjudge{altbnd} [[vars]] : [[t1]] [[~>]] [[t2]] }} +by + +------------------------- :: Empty +G |-altbnd empty : t ~> t + +G |-subst beta_k' |-> alpha_k ok +G |-altbnd : t[beta_k' |-> alpha_k] ~> s +------------------------------------------------------ :: TyVar +G |-altbnd alpha_k, : (forall beta_k'.t) ~> s + +G |-altbnd : t2 ~> s +----------------------------------------------- :: Id +G |-altbnd x_t1, : (t1 -> t2) ~> s + +defn G |- arrow k1 -> k2 : k :: :: lintArrow :: 'Arrow_' + {{ com Arrow kinding, \coderef{coreSyn/CoreLint.lhs}{lintArrow} }} + {{ tex [[G]] \labeledjudge{\rightarrow} [[k1]] [[->]] [[k2]] : [[k]] }} +by + +------------------------- :: Box +G |-arrow BOX -> k2 : BOX + +k1 elt { *, #, Constraint } +k2 elt { *, #, Constraint } +------------------------- :: Kind +G |-arrow k1 -> k2 : * + +defn G |- app kinded_types : k1 ~> k2 :: :: lint_app :: 'App_' + {{ com Type application kinding, \coderef{coreSyn/CoreLint.lhs}{lint\_app} }} + {{ tex [[G]] \labeledjudge{app} [[kinded_types]] : [[k1]] [[~>]] [[k2]] }} +by + +--------------------- :: Empty +G |-app empty : k ~> k + +k <: k1 +G |-app : k2 ~> k' +---------------------------------------------------- :: FunTy +G |-app (t : k), : (k1 -> k2) ~> k' + +k <: k1 +G |-app : k2[z_k1 |-> t] ~> k' +-------------------------------------------------------- :: ForAllTy +G |-app (t : k), : (forall z_k1. k2) ~> k' + +defn k1 <: k2 :: :: isSubKind :: 'SubKind_' + {{ com Sub-kinding, \coderef{types/Kind.lhs}{isSubKind} }} +by + +------ :: Refl +k <: k + +-------------------- :: UnliftedTypeKind +# <: OpenKind + +------------------- :: LiftedTypeKind +* <: OpenKind + +---------------------- :: Constraint +Constraint <: OpenKind + +------------------- :: ConstraintLifted +Constraint <: * + +------------------ :: LiftedConstraint +* <: Constraint + +defn no_conflict ( C , , ind1 , ind2 ) :: :: check_no_conflict :: 'NoConflict_' + {{ com \parbox{5in}{Branched axiom conflict checking, \coderef{types/OptCoercion.lhs}{checkAxInstCo} \\ and \coderef{types/FamInstEnv.lhs}{compatibleBranches} } }} +by + +------------------------------------------------ :: NoBranch +no_conflict(C, , ind, -1) + +C = T_R +forall . ( ~> t') = ()[ind2] +apart(, ) +no_conflict(C, , ind1, ind2-1) +------------------------------------------------ :: Incompat +no_conflict(C, , ind1, ind2) + +C = T_R +forall . ( ~> s) = ()[ind1] +forall . ( ~> s') = ()[ind2] +apart(, ) +no_conflict(C, , ind1, ind2-1) +------------------------------------------- :: CompatApart +no_conflict(C, , ind1, ind2) + +C = T_R +forall . ( ~> s) = ()[ind1] +forall . ( ~> s') = ()[ind2] +unify(, ) = subst +subst(s) = subst(s') +----------------------------------------- :: CompatCoincident +no_conflict(C, , ind1, ind2) diff --git a/docs/core-spec/CoreSyn.ott b/docs/core-spec/CoreSyn.ott new file mode 100644 index 00000000..0c5b3048 --- /dev/null +++ b/docs/core-spec/CoreSyn.ott @@ -0,0 +1,406 @@ +%% +%% CoreSyn.ott +%% +%% defines formal version of core syntax +%% +%% See accompanying README file + +embed {{ tex-preamble + \newcommand{\coderef}[2]{\ghcfile{#1}:\texttt{#2}% +} + \newcommand{\keyword}[1]{\textbf{#1} } + \newcommand{\labeledjudge}[1]{\vdash_{\!\!\mathsf{#1} } } +}} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Metavariables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +metavar x ::= {{ com Term-level variable names }} +metavar alpha {{ tex \alpha }}, beta {{ tex \beta }} ::= + {{ com Type-level variable names }} +metavar N ::= {{ com Type-level constructor names }} +metavar K ::= {{ com Term-level data constructor names }} +metavar M ::= {{ com Axiom rule names }} + +indexvar i, j, kk {{ tex k }}, aa {{ tex a }}, bb {{ tex b }}, cc {{ tex c }} ::= {{ com Indices to be used in lists }} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Syntax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +grammar + +lit {{ tex \textsf{lit} }} :: 'Literal_' ::= + {{ com Literals, \coderef{basicTypes/Literal.lhs}{Literal} }} + +z :: 'Name_' ::= {{ com Term or type name }} + | alpha :: :: Type {{ com Type-level name }} + | x :: :: Term {{ com Term-level name }} + +n, m :: 'Var_' ::= {{ com Variable names, \coderef{basicTypes/Var.lhs}{Var} }} + | z _ t :: :: IdOrTyVar {{ com Name, labeled with type/kind }} + {{ tex {[[z]]}^{[[t]]} }} + | K :: M :: DataCon {{ com Data constructor }} + +vars :: 'Vars_' ::= {{ com List of variables }} + | :: :: List + | fv ( t ) :: M :: fv_t + {{ tex \textit{fv}([[t]]) }} + | fv ( e ) :: M :: fv_e + {{ tex \textit{fv}([[e]]) }} + | empty :: M :: empty + | vars1 \inter vars2 :: M :: intersection + {{ tex [[vars1]] \cap [[vars2]] }} + +e, u :: 'Expr_' ::= {{ com Expressions, \coderef{coreSyn/CoreSyn.lhs}{Expr} }} + | n :: :: Var {{ com Variable }} + | lit :: :: Lit {{ com Literal }} + | e1 e2 :: :: App {{ com Application }} + | \ n . e :: :: Lam {{ com Abstraction }} + | let binding in e :: :: Let {{ com Variable binding }} + | case e as n return t of :: :: Case {{ com Pattern match }} + | e |> g :: :: Cast {{ com Cast }} + | e { tick } :: :: Tick {{ com Internal note }} + {{ tex {[[e]]}_{\{[[tick]]\} } }} + | t :: :: Type {{ com Type }} + | g :: :: Coercion {{ com Coercion }} + | e subst :: M :: Subst {{ com Substitution }} + | ( e ) :: M :: Parens {{ com Parenthesized expression }} + | e :: M :: Apps {{ com Nested application }} + | S ( n ) :: M :: Lookup {{ com Lookup in the runtime store }} + +binding :: 'Bind_' ::= {{ com Let-bindings, \coderef{coreSyn/CoreSyn.lhs}{Bind} }} + | n = e :: :: NonRec {{ com Non-recursive binding }} + | rec :: :: Rec {{ com Recursive binding }} + +alt :: 'Alt_' ::= {{ com Case alternative, \coderef{coreSyn/CoreSyn.lhs}{Alt} }} + | Kp -> e :: :: Alt {{ com Constructor applied to fresh names }} + +tick :: 'Tickish_' ::= {{ com Internal notes, \coderef{coreSyn/CoreSyn.lhs}{Tickish} }} + +Kp {{ tex \mathbb{K} }} :: 'AltCon_' ::= {{ com Constructors used in patterns, \coderef{coreSyn/CoreSyn.lhs}{AltCon} }} + | K :: :: DataAlt {{ com Data constructor }} + | lit :: :: LitAlt {{ com Literal (such as an integer or character) }} + | _ :: :: DEFAULT {{ com Wildcard }} + +program :: 'CoreProgram_' ::= {{ com A System FC program, \coderef{coreSyn/CoreSyn.lhs}{CoreProgram} }} + | :: :: CoreProgram {{ com List of bindings }} + +%% TYPES %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }} + :: 'Type_' ::= {{ com Types/kinds, \coderef{types/TypeRep.lhs}{Type} }} + | n :: :: TyVarTy {{ com Variable }} + | t1 t2 :: :: AppTy {{ com Application }} + | T :: :: TyConApp {{ com Application of type constructor }} + | t1 -> t2 :: :: FunTy {{ com Function }} + | forall n . t :: :: ForAllTy {{ com Polymorphism }} + | lit :: :: LitTy {{ com Type-level literal }} + | tyConKind T :: M :: tyConKind {{ com \coderef{types/TyCon.lhs}{tyConKind} }} + | t1 ~# k t2 :: M :: unliftedEq {{ com Metanotation for coercion types }} + {{ tex [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }} + | t1 ~R# k t2 :: M :: unliftedREq {{ com Metanotation for coercion types }} + {{ tex [[t1]] \mathop{\sim_{\mathsf{R}\#}^{[[k]]} } [[t2]] }} + | literalType t :: M :: literalType {{ com \coderef{basicTypes/Literal.lhs}{literalType} }} + | ( t ) :: M :: parens {{ com Parentheses }} + | t [ n |-> s ] :: M :: TySubst {{ com Type substitution }} + | subst ( k ) :: M :: TySubstList {{ com Type substitution list }} + | t subst :: M :: TySubstListPost {{ com Type substitution list }} + | dataConRepType K :: M :: dataConRepType {{ com Type of DataCon }} + | forall . t + :: M :: ForAllTys {{ com Nested polymorphism }} + | @ -> t' :: M :: FunTys {{ com Nested arrows }} + +%% COERCIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +g {{ tex \gamma }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/Coercion.lhs}{Coercion} }} + | < t > _ R :: :: Refl {{ com Reflexivity }} + {{ tex {\langle [[t]] \rangle}_{[[R]]} }} + | T RA :: :: TyConAppCo {{ com Type constructor application }} + | g1 g2 :: :: AppCo {{ com Application }} + | forall n . g :: :: ForAllCo {{ com Polymorphism }} + | n :: :: CoVarCo {{ com Variable }} + | C ind :: :: AxiomInstCo {{ com Axiom application }} + | t1 ==>! RA t2 :: :: UnivCo {{ com Universal coercion }} + | sym g :: :: SymCo {{ com Symmetry }} + | g1 ; g2 :: :: TransCo {{ com Transitivity }} + | mu + :: :: AxiomRuleCo {{ com Axiom-rule application (for type-nats) }} + | nth I g :: :: NthCo {{ com Projection (0-indexed) }} + {{ tex \textsf{nth}_{[[I]]}\,[[g]] }} + | LorR g :: :: LRCo {{ com Left/right projection }} + | g t :: :: InstCo {{ com Type application }} + | sub g :: :: SubCo {{ com Sub-role --- convert nominal to representational }} + | ( g ) :: M :: Parens {{ com Parentheses }} + | t @ liftingsubst :: M :: Lifted {{ com Type lifted to coercion }} + +LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/Coercion.lhs}{LeftOrRight} }} + | Left :: :: CLeft {{ com Left projection }} + | Right :: :: CRight {{ com Right projection }} + +C :: 'CoAxiom_' ::= {{ com Axioms, \coderef{types/TyCon.lhs}{CoAxiom} }} + | T RA :: :: CoAxiom {{ com Axiom }} + | ( C ) :: M :: Parens {{ com Parentheses }} + +R {{ tex \rho }} :: 'Role_' ::= {{ com Roles, \coderef{types/CoAxiom.lhs}{Role} }} + | Nom :: :: Nominal {{ com Nominal }} + {{ tex \mathsf{N} }} + | Rep :: :: Representational {{ com Representational }} + {{ tex \mathsf{R} }} + | Ph :: :: Phantom {{ com Phantom }} + {{ tex \mathsf{P} }} + | role_list [ i ] :: M :: RoleListIndex {{ com Look up in list }} + +axBranch, b :: 'CoAxBranch_' ::= {{ com Axiom branches, \coderef{types/TyCon.lhs}{CoAxBranch} }} + | forall . ( ~> s ) :: :: CoAxBranch {{ com Axiom branch }} + | ( ) [ ind ] :: M :: lookup {{ com List lookup }} + +mu {{ tex \mu }} :: 'CoAxiomRule_' ::= {{ com CoAxiomRules, \coderef{types/CoAxiom.lhs}{CoAxiomRule} }} + | M ( I , role_list , R' ) :: :: CoAxiomRule {{ com Named rule, with parameter info }} + {{ tex {[[M]]}_{([[I]], [[ role_list ]], [[R']])} }} + +%% TYCONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +T :: 'TyCon_' ::= {{ com Type constructors, \coderef{types/TyCon.lhs}{TyCon} }} + | ( -> ) :: :: FunTyCon {{ com Arrow }} + + % the following also includes TupleTyCon, SynTyCon + | N _ k :: :: AlgTyCon {{ com Named tycon: algebraic, tuples, and synonyms }} + {{ tex {[[N]]}^{[[k]]} }} + | H :: :: PrimTyCon {{ com Primitive tycon }} + | ' K :: :: PromotedDataCon {{ com Promoted data constructor }} + | ' T :: :: PromotedTyCon {{ com Promoted type constructor }} + | dataConTyCon K :: M :: dataConTyCon {{ com TyCon extracted from DataCon }} + +H :: 'PrimTyCon_' ::= {{ com Primitive type constructors, \coderef{prelude/TysPrim.lhs}{} }} + | Int# :: :: intPrimTyCon {{ com Unboxed Int (\texttt{intPrimTyCon}) }} + | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality (\texttt{eqPrimTyCon}) }} + | ( ~R# ) :: :: eqReprPrimTyCon {{ com Unboxed representational equality (\texttt{eqReprPrimTyCon}) }} + | BOX :: :: superKindTyCon {{ com Sort of kinds (\texttt{superKindTyCon}) }} + | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types (\texttt{liftedTypeKindTyCon}) }} + | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types (\texttt{unliftedTypeKindTyCon}) }} + | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ (\texttt{openTypeKindTyCon}) }} + | Constraint :: :: constraintTyCon {{ com Constraint (\texttt{constraintTyCon}) }} + +%% CONTEXTS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +G {{ tex \Gamma }} :: 'LintM_Bindings_' ::= {{ com List of bindings, \coderef{coreSyn/CoreLint.lhs}{LintM} }} + | n :: :: Binding {{ com Single binding }} + | :: :: Concat {{ com Context concatenation }} + | vars_of binding :: M :: VarsOf {{ com \coderef{coreSyn/CoreSyn.lhs}{bindersOf} }} + +O {{ tex \Omega }} :: 'VarEnv_Role_' ::= {{ com Mapping from type variables to roles }} + | :: :: List {{ com List of bindings }} + | O1 , O2 :: M :: Concat {{ com Concatenate two lists }} + +S {{ tex \Sigma }} :: 'St_' ::= {{ com Runtime store }} + | [ n |-> e ] :: :: Binding {{ com Single binding }} + | :: :: Concat {{ com Store concatentation }} + +%% UTILITY %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +B {{ tex \mathbb{B} }} :: 'Bool_' ::= {{ com Booleans in metatheory }} + | false :: :: False + | true :: :: True + +kinded_types {{ tex \overline{(\sigma_i : \kappa_i)}^i }} :: 'Kinded_Types_' ::= {{ com List of types with kinds }} + | :: :: List + | empty :: M :: empty + +subst :: 'Subst_' ::= {{ com List of substitutions }} + | [ n |-> t ] :: :: TyMapping + | [ n |-> e ] :: :: TmMapping + | :: :: List + +liftingsubst :: 'LiftSubst_' ::= {{ com List of lifting substitutions }} + | [ n |-> g ] :: :: Mapping + | :: :: List + +ind, I {{ tex i }} :: 'Ind_' ::= {{ com Indices, numbers }} + | i :: :: index + | length :: M :: length_t + | length :: M :: length_g + | length :: M :: length_axBranch + | tyConArity T :: M :: tyConArity + | ind - 1 :: M :: decrement + | -1 :: M :: minusOne + | 0 :: M :: zero + | 1 :: M :: one + | 2 :: M :: two + +type_list :: 'TypeList_' ::= {{ com List of types }} + | :: :: List + +RA {{ tex {\!\!\!{}_{\rho} } }} :: 'RoleAnnot_' ::= {{ com Role annotation }} + | _ R :: M :: annotation + {{ tex {\!\!\!{}_{[[R]]} } }} + | _ ^^ R :: M :: spaced_annotation + {{ tex {}_{[[R]]} }} + +role_list {{ tex {\overline{\rho_j} }^j }} :: 'RoleList_' ::= {{ com List of roles }} + | :: :: List + | tyConRolesX R T :: M :: tyConRolesX + | tyConRoles T :: M :: tyConRoles + | ( role_list ) :: M :: Parens + | { role_list } :: M :: Braces + | take ( ind , role_list ) :: M :: Take + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Terminals %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +terminals :: 'terminals_' ::= + | \ :: :: lambda {{ tex \lambda }} + | let :: :: let {{ tex \keyword{let} }} + | in :: :: key_in {{ tex \keyword{in} }} + | rec :: :: rec {{ tex \keyword{rec} }} + | and :: :: key_and {{ tex \keyword{and} }} + | case :: :: case {{ tex \keyword{case} }} + | of :: :: of {{ tex \keyword{of} }} + | -> :: :: arrow {{ tex \to }} + | |> :: :: cast {{ tex \triangleright }} + | forall :: :: forall {{ tex {\forall}\! }} + | ==>! :: :: unsafe + {{ tex \twoheadrightarrow\!\!\!\!\!\! \raisebox{-.3ex}{!} \,\,\,\,\, }} + | sym :: :: sym {{ tex \textsf{sym} }} + | ; :: :: trans {{ tex \fatsemi }} + | Left :: :: Left {{ tex \textsf{left} }} + | Right :: :: Right {{ tex \textsf{right} }} + | _ :: :: wildcard {{ tex \text{\textvisiblespace} }} + | BOX :: :: BOX {{ tex \Box }} + | Int# :: :: int_hash {{ tex {\textsf{Int} }_{\#} }} + | ~# :: :: eq_hash {{ tex \mathop{ {\sim}_{\#} } }} + | ~R# :: :: eq_repr_hash {{ tex \mathop{ {\sim}_{\mathsf{R}\#} } }} + | OpenKind :: :: OpenKind {{ tex \textsf{OpenKind} }} + | ok :: :: ok {{ tex \textsf{ ok} }} + | no_duplicates :: :: no_duplicates {{ tex \textsf{no\_duplicates } }} + | vars_of :: :: vars_of {{ tex \textsf{vars\_of } }} + | not :: :: not {{ tex \neg }} + | isUnLiftedTyCon :: :: isUnLiftenTyCon {{ tex \textsf{isUnLiftedTyCon} }} + | false :: :: false {{ tex \textsf{false} }} + | true :: :: true {{ tex \textsf{true} }} + | \/ :: :: or {{ tex \vee }} + | /\ :: :: and {{ tex \mathop{\wedge} }} + | elt :: :: elt {{ tex \in }} + | /= :: :: neq {{ tex \neq }} + | literalType :: :: literalType {{ tex \textsf{literalType} }} + | |-> :: :: mapsto {{ tex \mapsto }} + | <- :: :: assignment {{ tex \leftarrow }} + | @ :: :: marker {{ tex }} + | inits :: :: inits {{ tex \textsf{inits} }} + | ~> :: :: squigarrow {{ tex \rightsquigarrow }} + | tyConKind :: :: tyConKind {{ tex \mathop{\textsf{tyConKind} } }} + | empty :: :: empty {{ tex \cdot }} + | length :: :: length {{ tex \mathsf{length} }} + | <: :: :: subkind {{ tex \mathop{ {<} {:}\, } }} + | ~ :: :: eq {{ tex \sim }} + | tyConArity :: :: tyConArity {{ tex \textsf{tyConArity} }} + | dataConTyCon :: :: dataConTyCon {{ tex \textsf{dataConTyCon} }} + | dataConRepType :: :: dataConRepType {{ tex \textsf{dataConRepType} }} + | isNewTyCon :: :: isNewTyCon {{ tex \textsf{isNewTyCon} }} + | Constraint :: :: Constraint {{ tex \textsf{Constraint} }} + | no_conflict :: :: no_conflict {{ tex \textsf{no\_conflict} }} + | apart :: :: apart {{ tex \textsf{apart} }} + | unify :: :: unify {{ tex \textsf{unify} }} + | tyConRolesX :: :: tyConRolesX {{ tex \textsf{tyConRolesX} }} + | tyConRoles :: :: tyConRoles {{ tex \textsf{tyConRoles} }} + | tyConDataCons :: :: tyConDataCons {{ tex \textsf{tyConDataCons} }} + | validRoles :: :: validRoles {{ tex \textsf{validRoles} }} + | validDcRoles :: :: validDcRoles {{ tex \textsf{validDcRoles} }} + | --> :: :: steps {{ tex \longrightarrow }} + | coercionKind :: :: coercionKind {{ tex \textsf{coercionKind} }} + | take :: :: take {{ tex \textsf{take}\! }} + | coaxrProves :: :: coaxrProves {{ tex \textsf{coaxrProves} }} + | Just :: :: Just {{ tex \textsf{Just} }} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Formulae %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +formula :: 'formula_' ::= + | judgement :: :: judgement + | formula1 ... formulai :: :: dots + | G1 = G2 :: :: context_rewrite + | t1 = t2 :: :: type_rewrite + | t1 /= t2 :: :: type_inequality + | e1 /=e e2 :: :: expr_inequality + {{ tex [[e1]] \neq [[e2]] }} + | 0 <= ind1 < ind2 :: :: in_bounds + {{ tex 0 \leq [[ind1]] < [[ind2]] }} + | g1 = g2 :: :: co_rewrite + | no_duplicates :: :: no_duplicates_name + | no_duplicates :: :: no_duplicates_binding + | not formula :: :: not + | isUnLiftedTyCon T :: :: isUnLiftedTyCon + | formula1 /\ formula2 :: :: and + | formula1 \/ formula2 :: :: or + | ( formula ) :: :: parens + | n elt G :: :: context_inclusion + | vars1 = vars2 :: :: vars_rewrite + | = inits ( ) :: :: context_folding + | = inits ( tj ] // j /> ) :: :: subst_folding + | ind1 = ind2 :: :: eq_ind + | ind1 < ind2 :: :: lt + | G |- tylit lit : k :: :: lintTyLit + {{ tex [[G]] \labeledjudge{tylit} [[lit]] : [[k]] }} + | isNewTyCon T :: :: isNewTyCon + | k1 elt { } :: :: kind_elt + | e is_a_type :: :: is_a_type + {{ tex \exists \tau \text{ s.t.~} [[e]] = \tau }} + | e is_a_coercion :: :: is_a_coercion + {{ tex \exists \gamma \text{ s.t.~} [[e]] = \gamma }} + | t is_a_prop :: :: is_a_prop + {{ tex \exists \tau_1, \tau_2, \kappa \text{ s.t.~} [[t]] = + \tau_1 \mathop{ {\sim}_{\#}^{\kappa} } \tau_2 }} + | axBranch1 = axBranch2 :: :: branch_rewrite + | C1 = C2 :: :: axiom_rewrite + | apart ( , ) :: :: apart + | unify ( , ) = subst :: :: unify + | role_list1 = role_list2 :: :: eq_role_list + | R1 /= R2 :: :: role_neq + | R1 = R2 :: :: eq_role + | = tyConDataCons T :: :: tyConDataCons + | O ( n ) = R :: :: role_lookup + | R elt role_list :: :: role_elt + | formula1 => formula2 :: :: implication + {{ tex [[formula1]] \implies [[formula2]] }} + | alt1 = alt2 :: :: alt_rewrite + | e1 = e2 :: :: e_rewrite + | no other case matches :: :: no_other_case + {{ tex \text{no other case matches} }} + | t = coercionKind g :: :: coercionKind + | Just ( t1 , t2 ) = coaxrProves mu + :: :: coaxrProves + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Subrules and Parsing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +parsing + +TyCon_FunTyCon right Type_AppTy +TyCon_PrimTyCon right Type_AppTy +TyCon_AlgTyCon right Type_AppTy +TyCon_PromotedDataCon right Type_AppTy +TyCon_PromotedTyCon right Type_AppTy + +TyCon_FunTyCon right Coercion_AppCo +TyCon_PrimTyCon right Coercion_AppCo +TyCon_AlgTyCon right Coercion_AppCo +TyCon_PromotedDataCon right Coercion_AppCo +TyCon_PromotedTyCon right Coercion_AppCo + +Subst_TyMapping <= Type_TySubstList +Subst_TmMapping <= Type_TySubstList +Subst_List <= Type_TySubstList + +Subst_TyMapping <= Type_TySubstListPost +Subst_TmMapping <= Type_TySubstListPost + +Expr_Type <= formula_e_rewrite + +Coercion_TyConAppCo <= Coercion_AppCo + +Expr_Coercion <= Subst_TmMapping diff --git a/docs/core-spec/Makefile b/docs/core-spec/Makefile new file mode 100644 index 00000000..402f9dbe --- /dev/null +++ b/docs/core-spec/Makefile @@ -0,0 +1,18 @@ +OTT_FILES = CoreSyn.ott CoreLint.ott OpSem.ott +OTT_TEX = CoreOtt.tex +OTT_OPTS = -tex_show_meta false +TARGET = core-spec + +$(TARGET).pdf: $(TARGET).tex $(OTT_TEX) + latex -output-format=pdf $< + latex -output-format=pdf $< + +$(TARGET).tex: $(TARGET).mng $(OTT_FILES) + ott $(OTT_OPTS) -tex_filter $< $@ $(OTT_FILES) + +$(OTT_TEX): $(OTT_FILES) + ott -tex_wrap false $(OTT_OPTS) -o $@ $^ + +.PHONY: clean +clean: + rm -f $(TARGET).pdf $(TARGET).tex $(OTT_TEX) *.aux *.fdb_latexmk *.log diff --git a/docs/core-spec/OpSem.ott b/docs/core-spec/OpSem.ott new file mode 100644 index 00000000..1c21ada0 --- /dev/null +++ b/docs/core-spec/OpSem.ott @@ -0,0 +1,97 @@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Dynamic semantics %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% The definitions in this file do *not* strictly correspond to any specific +% code in GHC. They are here to provide a reasonable operational semantic +% interpretation to the typing rules presented in the other ott files. Thus, +% your mileage may vary. In particular, there has been *no* attempt to +% write any formal proofs over these semantics. +% +% With that disclaimer disclaimed, these rules are a reasonable jumping-off +% point for an analysis of FC's operational semantics. If you don't want to +% worry about mutual recursion (and who does?), you can even drop the +% environment S. + +grammar + +defns +OpSem :: '' ::= + +defn S |- e --> e' :: :: step :: 'S_' {{ com Single step semantics }} +{{ tex [[S]] \labeledjudge{op} [[e]] [[-->]] [[e']] }} +by + +S(n) = e +----------------- :: Var +S |- n --> e + +S |- e1 --> e1' +------------------- :: App +S |- e1 e2 --> e1' e2 + +----------------------------- :: Beta +S |- (\n.e1) e2 --> e1[n |-> e2] + +g0 = sym (nth 0 g) +g1 = nth 1 g +not e2 is_a_type +not e2 is_a_coercion +----------------------------------------------- :: Push +S |- ((\n.e1) |> g) e2 --> (\n.e1 |> g1) (e2 |> g0) + +---------------------------------------- :: TPush +S |- ((\n.e) |> g) t --> (\n.(e |> g n)) t + +g0 = nth 1 (nth 0 g) +g1 = sym (nth 2 (nth 0 g)) +g2 = nth 1 g +------------------------------- :: CPush +S |- ((\n.e) |> g) g' --> (\n.e |> g2) (g0 ; g' ; g1) + +----------------- :: LetNonRec +S |- let n = e1 in e2 --> e2[n |-> e1] + + +S, ei] // i /> |- u --> u' +------------------------------------ :: LetRec +S |- let rec in u --> let rec in u' + +fv(u) \inter = empty +------------------------------------------ :: LetRecReturn +S |- let rec in u --> u + + +S |- e --> e' +--------------------------------------- :: Case +S |- case e as n return t of --> case e' as n return t of + +altj = K -> u +u' = u[n |-> e] sbb] // bb /> ecc] // cc /> +-------------------------------------------------------------- :: MatchData +S |- case K as n return t of --> u' + +altj = lit -> u +---------------------------------------------------------------- :: MatchLit +S |- case lit as n return t of --> u[n |-> lit] + +altj = _ -> u +no other case matches +------------------------------------------------------------ :: MatchDefault +S |- case e as n return t of --> u[n |-> e] + +T ~#k T = coercionKind g +forall . forall . @-> T = dataConRepType K + (t1cc @ nth aa g] // aa /> _Nom] // bb />) // cc /> +--------------------------- :: CasePush +S |- case (K ) |> g as n return t2 of --> case K as n return t2 of + +S |- e --> e' +------------------------ :: Cast +S |- e |> g --> e' |> g + +S |- e --> e' +------------------------------ :: Tick +S |- e { tick } --> e' { tick } + diff --git a/docs/core-spec/README b/docs/core-spec/README new file mode 100644 index 00000000..1fb304d2 --- /dev/null +++ b/docs/core-spec/README @@ -0,0 +1,83 @@ +GHC FORMALISM +============= + +This directory contains the source code (and built pdf, for convenience) for a +formalism of the core language in GHC, properly called System FC. Though a +good handful of papers have been published about the language, these papers +paraphrase a slice of the language, useful for exposition. The document here +contains the official description of the language, as it is implemented in +GHC. + +Building +-------- + +The built pdf is tracked in the git repository, so you should not need to build +unless you are editing the source code. If you do need to build, you will need +Ott [1] and LaTeX (with latexmk) in your path. Just run 'make'. 'make clean' +gets rid of all generated files, including the pdf. + +Details +------- + +The source files here are written in Ott [1], a language and toolset designed +to help in writing language formalisms. While the syntax of the language is a +little finnicky to write out at first, it is remarkably easy to make +incremental edits. Ott can be used to generate both LaTeX code and definitions +for proof assistants. Here, we use it only to produce LaTeX. Ott also has a +filter mode, where it processes a .mng file, looking for snippets enclosed +like [[ ... ]]. Ott will process the contents of these brackets and translate +into LaTeX math-mode code. Thus, the file core-spec.mng is the source for +core-spec.tex, which gets processed into core-spec.pdf. + +The file CoreSyn.ott contains the grammar of System FC, mostly extracted from +compiler/coreSyn/CoreSyn.lhs. Here are a few pointers to help those of you +unfamiliar with Ott: + +- The {{ ... }} snippets are called "homs", and they assist ott in translating +your notation to LaTeX. Three different homs are used: + * tex-preamble contains literal LaTeX code to be pasted into the output + * com marks a comment, which is rendered to the right of the structure being + defined + * tex marks a LaTeX typesetting of the structure being defined. It can use + [[ ... ]] to refer to metavariables used the structure definition. + +- The notation is used for lists. Please see the Ott manual + [2] for more info. + +- Ott requires that all lexemes are separated by whitespace in their initial + definition. + +- The M that appears between the :: on some lines means "meta". It is used for + a production that is not a proper constructor of the form being defined. For + example, the production ( t ) should be considered to be a type, but it is + not a separate constructor. Meta productions are not included when + typsetting the form with its productions. + +- There are two special forms: + * The 'terminal' form contains productions for all terminal symbols that + require special typesetting through their tex homs. + * The 'formula' form contains productions for all valid formulae that can be + used in the premises of an inductive rule. (The 'judgement' production + refers to defined judgements in the rules.) + +- See the Ott manual [2] for the 'parsing' section at the bottom. These rules + help disambiguate otherwise-ambiguous parses. Getting these right is hard, + so if you have trouble, you're not alone. + +- In a few places, it is necessary to use an @ symbol to disambiguate parses. The + @ symbol is not typeset and is used solely for disambiguation. Feel free to use + it if necessary to disambiguate other parses. + +The file CoreLint.ott contains inductively defined judgements for many of the +functions in compiler/coreSyn/CoreLint.lhs. Each judgement is labeled with an +abbreviation to distinguish it from the others. These abbreviations appear in +the source code right after a turnstile |-. The declaration for each judgment +contains a reference to the function it represents. Each rule is labeled with +the constructor in question, if applicable. Note that these labels are +mandatory in Ott. + +If you need help with these files or do not know how to edit them, please +contact Richard Eisenberg (eir@cis.upenn.edu). + +[1] http://www.cl.cam.ac.uk/~pes20/ott/ +[2] http://www.cl.cam.ac.uk/~pes20/ott/ott_manual_0.21.2.pdf \ No newline at end of file diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng new file mode 100644 index 00000000..28540ac8 --- /dev/null +++ b/docs/core-spec/core-spec.mng @@ -0,0 +1,466 @@ +\documentclass{article} + +\usepackage{supertabular} +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{stmaryrd} +\usepackage{xcolor} +\usepackage{fullpage} +\usepackage{multirow} +\usepackage{url} + +\newcommand{\ghcfile}[1]{\textsl{#1}} +\newcommand{\arraylabel}[1]{\multicolumn{2}{l}{\!\!\!\!\!\!\!\!\!\text{\underline{#1}:}}} + +\input{CoreOtt} + +% increase spacing between rules for ease of reading: +\renewcommand{\ottusedrule}[1]{\[#1\]\\[1ex]} + +\setlength{\parindent}{0in} +\setlength{\parskip}{1ex} + +\newcommand{\gram}[1]{\ottgrammartabular{#1\ottafterlastrule}} + +\begin{document} + +\begin{center} +\LARGE +System FC, as implemented in GHC\footnote{This +document was originally prepared by Richard Eisenberg (\texttt{eir@cis.upenn.edu}), +but it should be maintained by anyone who edits the functions or data structures +mentioned in this file. Please feel free to contact Richard for more information.}\\ +\Large 21 November, 2013 +\end{center} + +\section{Introduction} + +This document presents the typing system of System FC, very closely to how it is +implemented in GHC. Care is taken to include only those checks that are actually +written in the GHC code. It should be maintained along with any changes to this +type system. + +Who will use this? Any implementer of GHC who wants to understand more about the +type system can look here to see the relationships among constructors and the +different types used in the implementation of the type system. Note that the +type system here is quite different from that of Haskell---these are the details +of the internal language, only. + +At the end of this document is a \emph{hypothetical} operational semantics for GHC. +It is hypothetical because GHC does not strictly implement a concrete operational +semantics anywhere in its code. While all the typing rules can be traced back to +lines of real code, the operational semantics do not, in general, have as clear +a provenance. + +There are a number of details elided from this presentation. The goal of the +formalism is to aid in reasoning about type safety, and checks that do not +work toward this goal were omitted. For example, various scoping checks (other +than basic context inclusion) appear in the GHC code but not here. + +\section{Grammar} + +\subsection{Metavariables} + +We will use the following metavariables: + +\ottmetavars{}\\ + +\subsection{Literals} + +Literals do not play a major role, so we leave them abstract: + +\gram{\ottlit} + +We also leave abstract the function \coderef{basicTypes/Literal.lhs}{literalType} +and the judgment \coderef{coreSyn/CoreLint.lhs}{lintTyLit} (written $[[G |-tylit lit : k]]$). + +\subsection{Variables} +\enlargethispage{10pt} % without this first line of "z" definition is placed on + % second page and it becomes the only line of text on that + % page, resulting in whole page being empty. +GHC uses the same datatype to represent term-level variables and type-level +variables: + +\gram{ +\ottz +} + +\gram{ +\ottn +} + +\subsection{Expressions} + +The datatype that represents expressions: + +\gram{\otte} + +There are a few key invariants about expressions: +\begin{itemize} +\item The right-hand sides of all top-level and recursive $[[let]]$s +must be of lifted type. +\item The right-hand side of a non-recursive $[[let]]$ and the argument +of an application may be of unlifted type, but only if the expression +is ok-for-speculation. See \verb|#let_app_invariant#| in \ghcfile{coreSyn/CoreSyn.lhs}. +\item We allow a non-recursive $[[let]]$ for bind a type variable. +\item The $[[_]]$ case for a $[[case]]$ must come first. +\item The list of case alternatives must be exhaustive. +\item Types and coercions can only appear on the right-hand-side of an application. +\end{itemize} + +Bindings for $[[let]]$ statements: + +\gram{\ottbinding} + +Case alternatives: + +\gram{\ottalt} + +Constructors as used in patterns: + +\gram{\ottKp} + +Notes that can be inserted into the AST. We leave these abstract: + +\gram{\otttick} + +A program is just a list of bindings: + +\gram{\ottprogram} + +\subsection{Types} + +\gram{\ottt} + +There are some invariants on types: +\begin{itemize} +\item The type $[[t1]]$ in the form $[[t1 t2]]$ must not be a type constructor +$[[T]]$. It should be another application or a type variable. +\item The form $[[T ]]$ (\texttt{TyConApp}) +does \emph{not} need to be saturated. +\item A saturated application of $[[(->) t1 t2]]$ should be represented as +$[[t1 -> t2]]$. This is a different point in the grammar, not just pretty-printing. +The constructor for a saturated $[[(->)]]$ is \texttt{FunTy}. +\item A type-level literal is represented in GHC with a different datatype than +a term-level literal, but we are ignoring this distinction here. +\end{itemize} + +\subsection{Coercions} + +\gram{\ottg} + +Invariants on coercions: +\begin{itemize} +\item $[[_R]]$ is used; never $[[_R _Nom]]$. +\item If $[[_R]]$ is applied to some coercions, at least one of which is not +reflexive, use $[[T_R ]]$, never $[[_R g1 g2]] \ldots$. +\item The $[[T]]$ in $[[T_R ]]$ is never a type synonym, though it could +be a type function. +\end{itemize} + +Roles label what equality relation a coercion is a witness of. Nominal equality +means that two types are identical (have the same name); representational equality +means that two types have the same representation (introduced by newtypes); and +phantom equality includes all types. See \url{http://ghc.haskell.org/trac/ghc/wiki/Roles} +for more background. + +\gram{\ottR} + +Is it a left projection or a right projection? + +\gram{\ottLorR} + +Axioms: + +\gram{ +\ottC\ottinterrule +\ottaxBranch +} + +The definition for $[[axBranch]]$ above does not include the list of +incompatible branches (field \texttt{cab\_incomps} of \texttt{CoAxBranch}), +as that would unduly clutter this presentation. Instead, as the list +of incompatible branches can be computed at any time, it is checked for +in the judgment $[[no_conflict]]$. See Section~\ref{sec:no_conflict}. + +Axiom rules, produced by the type-nats solver: + +\gram{\ottmu} + +\label{sec:axiom_rules} +An axiom rule $[[mu]] = [[M(I, role_list, R')]]$ is an axiom name $[[M]]$, with a +type arity $[[I]]$, a list of roles $[[role_list]]$ for its coercion parameters, +and an output role $[[R']]$. The definition within GHC also includes a field named +$[[coaxrProves]]$ which computes the output coercion from a list of types and +a list of coercions. This is elided in this presentation, as we simply identify +axiom rules by their names $[[M]]$. See also \coderef{typecheck/TcTypeNats.lhs}{mkBinAxiom} +and \coderef{typecheck/TcTypeNats.lhs}{mkAxiom1}. + +\subsection{Type constructors} + +Type constructors in GHC contain \emph{lots} of information. We leave most of it out +for this formalism: + +\gram{\ottT} + +We include some representative primitive type constructors. There are many more in \ghcfile{prelude/TysPrim.lhs}. + +\gram{\ottH} + +\section{Contexts} + +The functions in \ghcfile{coreSyn/CoreLint.lhs} use the \texttt{LintM} monad. +This monad contains a context with a set of bound variables $[[G]]$. The +formalism treats $[[G]]$ as an ordered list, but GHC uses a set as its +representation. + +\gram{ +\ottG +} + +We assume the Barendregt variable convention that all new variables are +fresh in the context. In the implementation, of course, some work is done +to guarantee this freshness. In particular, adding a new type variable to +the context sometimes requires creating a new, fresh variable name and then +applying a substitution. We elide these details in this formalism, but +see \coderef{types/Type.lhs}{substTyVarBndr} for details. + +\section{Typing judgments} + +The following functions are used from GHC. Their names are descriptive, and they +are not formalized here: \coderef{types/TyCon.lhs}{tyConKind}, +\coderef{types/TyCon.lhs}{tyConArity}, \coderef{basicTypes/DataCon.lhs}{dataConTyCon}, \coderef{types/TyCon.lhs}{isNewTyCon}, \coderef{basicTypes/DataCon.lhs}{dataConRepType}. + +\subsection{Program consistency} + +Check the entire bindings list in a context including the whole list. We extract +the actual variables (with their types/kinds) from the bindings, check for duplicates, +and then check each binding. + +\ottdefnlintCoreBindings{} + +Here is the definition of $[[vars_of]]$, taken from \coderef{coreSyn/CoreSyn.lhs}{bindersOf}: + +\[ +\begin{array}{ll} +[[vars_of n = e]] &= [[n]] \\ +[[vars_of rec ]] &= [[]] +\end{array} +\] + +\subsection{Binding consistency} + +\ottdefnlintXXbind{} + +\ottdefnlintSingleBinding{} + +In the GHC source, this function contains a number of other checks, such +as for strictness and exportability. See the source code for further information. + +\subsection{Expression typing} + +\ottdefnlintCoreExpr{} + +\begin{itemize} +\item Some explication of \ottdrulename{Tm\_LetRec} is helpful: The idea behind the +second premise ($[[]]$) is that we wish +to check each substituted type $[[s'i]]$ in a context containing all the types +that come before it in the list of bindings. The $[[G'i]]$ are contexts +containing the names and kinds of all type variables (and term variables, +for that matter) up to the $i$th binding. This logic is extracted from +\coderef{coreSyn/CoreLint.lhs}{lintAndScopeIds}. + +\item There is one more case for $[[G |-tm e : t]]$, for type expressions. +This is included in the GHC code but is elided +here because the case is never used in practice. Type expressions +can only appear in arguments to functions, and these are handled +in \ottdrulename{Tm\_AppType}. + +\item The GHC source code checks all arguments in an application expression +all at once using \coderef{coreSyn/CoreSyn.lhs}{collectArgs} +and \coderef{coreSyn/CoreLint.lhs}{lintCoreArgs}. The operation +has been unfolded for presentation here. + +\item If a $[[tick]]$ contains breakpoints, the GHC source performs additional +(scoping) checks. + +\item The rule for $[[case]]$ statements also checks to make sure that +the alternatives in the $[[case]]$ are well-formed with respect to the +invariants listed above. These invariants do not affect the type or +evaluation of the expression, so the check is omitted here. + +\item The GHC source code for \ottdrulename{Tm\_Var} contains checks for +a dead id and for one-tuples. These checks are omitted here. +\end{itemize} + +\subsection{Kinding} + +\ottdefnlintType{} + +\subsection{Kind validity} + +\ottdefnlintKind{} + +\subsection{Coercion typing} + +In the coercion typing judgment, the $\#$ marks are left off the equality +operators to reduce clutter. This is not actually inconsistent, because +the GHC function that implements this check, \texttt{lintCoercion}, actually +returns four separate values (the kind, the two types, and the role), not +a type with head $[[(~#)]]$ or $[[(~R#)]]$. Note that the difference between +these two forms of equality is interpreted in the rules \ottdrulename{Co\_CoVarCoNom} +and \ottdrulename{Co\_CoVarCoRepr}. + +\ottdefnlintCoercion{} + +In \ottdrulename{Co\_AxiomInstCo}, the use of $[[inits]]$ creates substitutions from +the first $i$ mappings in $[[ si] // i /> ]]$. This has the effect of +folding the substitution over the kinds for kind-checking. + +See Section~\ref{sec:tyconroles} for more information about $[[tyConRolesX]]$, and +see Section~\ref{sec:axiom_rules} for more information about $[[coaxrProves]]$. + +\subsection{Name consistency} + +There are two very similar checks for names, one declared as a local function: + +\ottdefnlintSingleBindingXXlintBinder{} + +\ottdefnlintBinder{} + +\subsection{Substitution consistency} + +\ottdefncheckTyKind{} + +\subsection{Case alternative consistency} + +\ottdefnlintCoreAlt{} + +\subsection{Telescope substitution} + +\ottdefnapplyTys{} + +\subsection{Case alternative binding consistency} + +\ottdefnlintAltBinders{} + +\subsection{Arrow kinding} + +\ottdefnlintArrow{} + +\subsection{Type application kinding} + +\ottdefnlintXXapp{} + +\subsection{Sub-kinding} + +\ottdefnisSubKind{} + +\subsection{Roles} +\label{sec:tyconroles} + +During type-checking, role inference is carried out, assigning roles to the +arguments of every type constructor. The function $[[tyConRoles]]$ extracts these +roles. Also used in other judgments is $[[tyConRolesX]]$, which is the same as +$[[tyConRoles]]$, but with an arbitrary number of $[[Nom]]$ at the end, to account +for potential oversaturation. + +The checks encoded in the following +judgments are run from \coderef{typecheck/TcTyClsDecls.lhs}{checkValidTyCon} +when \texttt{-dcore-lint} is set. + +\ottdefncheckValidRoles{} + +\ottdefncheckXXdcXXroles{} + +In the following judgment, the role $[[R]]$ is an \emph{input}, not an output. +The metavariable $[[O]]$ denotes a \emph{role context}, as shown here: + +\gram{\ottO} + +\ottdefncheckXXtyXXroles{} + +These judgments depend on a sub-role relation: + +\ottdefnltRole{} + +\subsection{Branched axiom conflict checking} +\label{sec:no_conflict} + +The following judgment is used within \ottdrulename{Co\_AxiomInstCo} to make +sure that a type family application cannot unify with any previous branch +in the axiom. The actual code scans through only those branches that are +flagged as incompatible. These branches are stored directly in the +$[[axBranch]]$. However, it is cleaner in this presentation to simply +check for compatibility here. + +\ottdefncheckXXnoXXconflict{} + +The judgment $[[apart]]$ checks to see whether two lists of types are surely +apart. $[[apart( , )]]$, where $[[ +]]$ is a list of types and $[[ ]]$ is a list of type +\emph{patterns} (as in a type family equation), first flattens the $[[ ]]$ using \coderef{types/FamInstEnv.lhs}{flattenTys} and then checks to +see if \coderef{types/Unify.lhs}{tcUnifyTysFG} returns \texttt{SurelyApart}. +Flattening takes all type family applications and replaces them with fresh variables, +taking care to map identical type family applications to the same fresh variable. + +The algorithm $[[unify]]$ is implemented in \coderef{types/Unify.lhs}{tcUnifyTys}. +It performs a standard unification, returning a substitution upon success. + +\section{Operational semantics} + +\subsection{Disclaimer} +GHC does not implement an operational semantics in any concrete form. Most +of the rules below are implied by algorithms in, for example, the simplifier +and optimizer. Yet, there is no one place in GHC that states these rules, +analogously to \texttt{CoreLint.lhs}. +Nevertheless, these rules are included in this document to help the reader +understand System FC. + +\subsection{The context $[[S]]$} +We use a context $[[S]]$ to keep track of the values of variables in a (mutually) +recursive group. Its definition is as follows: +\[ +[[S]] \quad ::= \quad [[ empty ]] \ |\ [[S]], [[ [n |-> e] ]] +\] +The presence of the context $[[S]]$ is solely to deal with recursion. If your +use of FC does not require modeling recursion, you will not need to track $[[S]]$. + +\subsection{Operational semantics rules} + +\ottdefnstep{} + +\subsection{Notes} + +\begin{itemize} +\item The \ottdrulename{S\_LetRec} and \ottdrulename{S\_LetRecReturn} rules +implement recursion. \ottdrulename{S\_LetRec} adds to the context $[[S]]$ bindings +for all of the mutually recursive equations. Then, after perhaps many steps, +when the body of the $[[let]]\ [[rec]]$ contains no variables that are bound +in the $[[let]]\ [[rec]]$, the context is popped. +\item In the $[[case]]$ rules, a constructor $[[K]]$ is written taking three +lists of arguments: two lists of types and a list of terms. The types passed +in are the universally and, respectively, existentially quantified type variables +to the constructor. The terms are the regular term arguments stored in an +algebraic datatype. Coercions (say, in a GADT) are considered term arguments. +\item The rule \ottdrulename{S\_CasePush} is the most complex rule. +\begin{itemize} +\item The logic in this rule is implemented in \coderef{coreSyn/CoreSubst.lhs}{exprIsConApp\_maybe}. +\item The $[[coercionKind]]$ function (\coderef{types/Coercion.lhs}{coercionKind}) +extracts the two types (and their kind) from +a coercion. It does not require a typing context, as it does not \emph{check} the +coercion, just extracts its types. +\item The $[[dataConRepType]]$ function (\coderef{basicTypes/DataCon.lhs}{dataConRepType}) extracts the full type of a data constructor. Following the notation for +constructor expressions, the parameters to the constructor are broken into three +groups: universally quantified types, existentially quantified types, and terms. +\item The substitutions in the last premise to the rule are unusual: they replace +\emph{type} variables with \emph{coercions}. This substitution is called lifting +and is implemented in \coderef{types/Coercion.lhs}{liftCoSubst}. The notation is +essentially a pun on the fact that types and coercions have such similar structure. +\item Note that the types $[[ ]]$---the existentially quantified +types---do not change during this step. +\end{itemize} +\end{itemize} + +\end{document} diff --git a/docs/core-spec/core-spec.pdf b/docs/core-spec/core-spec.pdf new file mode 100644 index 0000000000000000000000000000000000000000..52f2e39f8320fbf1f00142f6d38062a50e20dcc4 GIT binary patch literal 339243 zcma&sLzpfwqJZhLZQJ_Gwr$(CZQHi(Q?_mUlx^eG^vpB6+l$UB*=CbBUqY@ZDo)SD zzy?FUurj&WC!E9)r)PDu-)H7FBVOeq0OEC(W^yR}nfn{Ep+19U2_ z)rQ>ros0_?^XDNC)67fbV(*Vwzvi(cCrd8Jg`-P5G{?Svn1XLWfZxk^TpMm)wdA&^ ziy!Q;=%`hz)UarnQ(GqkhXBN#!jbBq?L6p`gIRXz;PrXWL-Fs+!o6G91$#F~OGnkg z$~x|m-0EbdtN8wX|2OZivq&;~H9HgUJ zhG_IyY_=sqypEp*hZ5HJSOFry_nxf>Cqe#$H=6aZYS0z<>dH{lthohB+U5vs<1%;i z;I_SuDB)3!u^q`X? zRy8uP79;dwYlCUv!gA5=EtVT^T;;k|Oc%KtYDd4Bs{>(ZuMmPIVXm(@_o}0DYw^W+ zb<*St%T&Iq`+SP`p;$WJ=}l2p&x)lKh%bDaKP|H=w2t)Vo$ zM0O20K?PHc%4j+&TF&^euy$eJowxCF(_CEPq`bNsE%JAChLda%-Q^PKIHo~Az8fbr z$aq_SV@ASxH;>hcno>N?%n3is&{}!OS5tAE$pdTiC?!(5-!@8z=^&%!!UZEoQ9TkU ztAFm@F+mHo0I(szEH7hXE^J>Z1(}P0ia4*wt8VEIY)yS_xRbNqv$B? z=DHK@SJyfq_}p`E-blYA9ui)s`nR?G+D~lGkY$b7cYF%;l^Lsg%;-7(>ywdr;*Tw9 zO#DLJGSI^=qCYaCvrtj3fFKI6y05>MUbbXg@R}LGYcF{$tWSy{ykv^+a0-~va_ZdI zJyZ`bBJqa;SSD~`BBZY^YrMFJ>bMYmVt#xp#mCniXb-{fD-jnTsBgbBiIgC2gY|br zb7$EUEg7#v26!4~s0!Oc*an737b+?noH!bE;Z}DzXi<<1e^>7%_TdwOS=c;yRnm(* zB8qgfhqH3wz-gp2O+%5GlVG=&P(;KV+k`S-bq*K^%Xb{Y{ zm{B>39YdWUG;!M)Ef_w3n^Ry_V}U1}kt!x?xrr$67mp1*5?+Jg2)amExTv83B^P6j zNX3JMcrs$V&6%wC{G3cK_lJCN^URGFmWX#P?%&hw@T6bA4kcuEDIB=*aAO`RPGaI~ z^SLR;EC>z7nWNyN=+XDoM4+t|{1izpRYR-F2@hap#~j7vr}D#;&@M;d6(&qJX9Dej zLTs=!K9##qsmfK72fbC`BJn~WGEzR3(|KUM-DvLUa%a$pv?D_vK?$&KPn)x@V(qvV zn@Rejw90Yd0Le>}nEpdwP(Y&lfsZ_lVRvs4GcyskV%q2!~RQY z6Zpp@V7FL5VvX&E$_*0Rd&rbOwF~2RXGWWKZ^Pr9*k&|9=^=4z7!D5y!NlXr2Wo7? z+$r#Mu_%>r!{;_w`JNg-Qk?8*C=w1~zaDdd@Af=GAy_i~aELE;W`~v`ADy&&L>DQ6 zzEw$$+S@lItCi4`W%6rO$k6BSg>+&Fhi0qGE@9Za=5s`Y<@urN(v2^aU8I-Qy&X~* zPOSY76jur!Vl%|qFCe7>azQHI(0QY-Y?@n=*{I^AEsa_l`R~8^k+XrLi&>@0W(K1` zgxa-R_##~_<<9Vlu)o`bf9UV?JaX^2Jf$X55#p{D|0O^0d2;Ks@H?P}e7bOC+NlGu z6;+mWyZBnAPIzX@|01*buE>72?7hkjGbnzAx0a!R$Wn*eF|+tJDNhuVm0@Ge)8tJ5 zoKBnkT~fs6)2O#ewzKq*8>JR5eIf{+5nZf*u?X8<&f1fQ(&vP4BRNPMl(_?N`)enQ z9qUD-8sz>Yabik$ph+-934CkJVB()O{H3pcKMJr8UXr^FARc&AfWE(!k@LcVGWjsg z?~fMiJ;ZE+Im^F1fhiIV(>g`wuSbb|0tZhnoUkNNcV^N(Rt;5Tcr0X!KnHO1%tYF{CRxkdM2ykf z7atI=Aq-T8$%^a}Rsxb_(4;7UubnRiWmgd1ek&aM=&q{FqQ2rCB6)lc@t;-QpP^0Q;{ zbc7nYY@eh+Ca3-t8S!_3lNjYF4#D^QV88^WPSMOs=7+%T!}1 z3os@~>$<#CBFR#~fE8W2KdXjvX;v-1U*Xzw4q%-Dtdk!PR6!`l!vEfYD1H?8SMz%I zhVX1X19OZgTX03w()tJBfg-Oz5I_SRtXtWMb`H!yT_a}e+R)04^Bsw;Ooh{OeIlv} z{54iexCyEe>|+)XGRD)M$_^g2THzo+c?S2<0`=&}vkhXU?2{uYpN-*Ee3|$O;fC{| zJK`w=mpmTdja{pmkxVmcIFT)iIW$fFGUzU$LL!`KB>|dL@fut19<*$a!5_(RzuFS^ zEeg+g5YiSbwPIrGzCEcm^bVC_8Qgc^`zl7P(7vHz*3UmQ&?p0)dG4ocM9b4?aWe}p zu|XD62b5%^e0oy9&1ZU$D?h3a4I2{`^xpe_`6F2*W!Yzl34k#+!yo~mX9imjrw%Y? z_NM>8-2OBBkNRMkng0v_n3?}){{7LGaXDf~>HE@POpDQF8#;h@ROXuD+*BoC`_p|i zMUbo-oopGygLaa*!uz`J5CS9_989%|T|kv$ShD!z_O>o}bj&|EiKwxmx4)y``wjV5 zDq2~}%-JUcNj7nfTPc)iQqs9w%3tUE?K5G!z>pXla4e|=q1=VuZ!&aE!lykpboZF{0^U4yb}LEZZio z^eQ26tB@rPtYejJR}>?iEz)R=(W5f2IX);zq=-jV`VBp5DM}<&E-`z&Uv6HKLkKbY zal%@Q0SQ7+Q3&I_KDOVDZD2_s@pa`ZxQG>{g+)Gi5LSHcT?X7=w&#zA7`ox(qlN)+_ zBcx0L7;#1fCkLoP86l;;AX0xet4+cpfmo*bCxY)|ZDrBu&PZ_JlXG`E=(bvPewACj z^3oD^-A+4h!K~3j@Sx>{5Dt-mc1ci>Ns%|)TTerYFrbQ)P=)Davf{;h{XMB-+}1!U z34D~DxBB``Xo`_bCs#fstn}p; zb=1A@OH0nl1w%RzhT0jYiHsQ~74K8y?G-M?U?xH`$PXPa)PI&!|I~(oscVT|7lseS z{psxgd8DRy35@3{J9eC5q{xqb{ajpvzn4Dsdgz<&x7>?k>X0&m<-Ee&<-I&|e9GzFZP)KE zg#$x?LcHlA8Bi^?aQ-uGu647aWB%JWEwDv+2R}G1uq_Zh*G5<$M46?_N#ag4=)CeX znAA_bc=gq0wLCV6ASeqj^wNnUUqx{TR)y{V0$pBF;^x$UgQjiYGWBp=zHuxsAStRo zzvO0j^Ur8Y=;dzp<5Q6%%nwV-=~?s-OfJZ7;_XrW0~g4Qmt}4oUL7JjT}=1d(|6!* z2^UN7kD-A1IrL7c0vnm!Y7+4*pNZtxbfr~&RWD?3N71XN8)|ma9H5)Kmf*S z1Ov);11ZJm!k;p0>5w7+93rk*0tOq4LJfT8H(n~Pz+_O6nCB%TZPC>sxXvYC~cL63o?dCu$Ov$05%9GPB;>+fCx3sFRZGTdi z;EiWpW5lyH@o(o%Ib~P1%VG?im(5$J)qpR?2uQgl)6C7k;asZuJNBMi#-Ndr!HmQR zxp?DZtCYc>_XK{~DS$|Yj%5)6Y)hpMDSHHJFt}WbSd)jQfP^AH=I@nU@q(+92ncWd z$t4)wY{e`R7`|s&Z?O9MP2Ke?av=@|kSB2bbU_r>~&!SkNS4=1G;scU!KeIIAWVMx$>Z7BA=zjo!pr$mtpgB;$Hl(MWI3>$K^$d zFa|X0aZ2~)crJNRW#s#6|GCMBE9R{&m8c@BawRAgKbRo_2_Rc>Xx5vFN~Q_8P~fBN zdEyRC@R`_B%pgwYRxSv2M^{6!1sRV4XB}U35e}@RSyN>BK;G)2&id>&{#u=RJHF6;GMxnFQtiqi?6vq zbRDew9(3~hElCmh*J}h>IVfj%tF+|?i!%S)kt5&g>1*eS%Ht2f%v`o$ohX9$5-EiY zXj4(xi!zwBZX(4SK1GoS8EN!Vst#fWj*hTl*r}#SxwPorQ>yKPZfcghhJ(Sf=`tNm z=*xZIyX~sqBfip(ahZ>}#BggBZX#cRvq0kNneK=)Gub@rfexK+b7N%_yCP zTR6F30hbsU3Mb(&Ob6Z2e@OW!=O-=vj<>JVsNN`GlLu3Cx zJFln5IC4DKu2 z$jTi#-ty)^7y^89P;|-ztD2FLis4PBgN#dCF-4Lyn4yYHI&;`r_yj^2Stt4+#N(DF zXikS}Kato4fYAIOr~syLiz%Uy+o&d}cQO)H@PicUKwGYgtvSRD-?vAB#%w(_YrL5` zQ`$o401Qd541uvCi$>v>(FGj>f+wm|DiPTrvAitEOk5Fgdp4`lv~ie8G^3@Dq5d-* ztRjZyZ8=x{I;HHf3V3(A+%@}j{8ETUuzql4jPyM#Nl}z*Y#9g>hBPtKuX$wPcs#hz ziw7r_9Wyzlv@`XZlQMDrFnhDhS z`2zrH1%AOWs}&4G4C~_f8Vre;N#&NX!K||cw1--!&E=1t%BqDESwCicxC)JE7S8QY z%!cdOU_%~#Fe`%3)QDpn$5_+r$u7C#6}}Cy=PC<+5MJ1X%<)8nMEr1|hIa7*@>X6g!3I{mkjH;TA(2Qu!&9}l=M0m z-x1L`f7DVu$8}=ZRJK9+Fcutl|-`m7K>H6V}l@Oln?xPwj+u24tTu*0z7V-Q_68V8kAxSGR44v2cZ$|ocP;a*Gg`t*+JZ(z zkrxJ=SGTp}8mm?$Nlqxo@015)8{SQYGXjwfmcJ=5T#U98y(3 z!BH_*a=L;xhum69+RI3bkS5%hKsL`Sz!cR_w z(h)TI(#7=?#qzkJAzOpC;o9KfhfaEMTs93^-L)_Sq#>dMTBE(L$C~KF9_-(PtDyoi z^>87>#wf`()bH(DKOs+fOAzSy8GUXb-3y!$`n+rYAXI~K*}Bi)oNxeoBZ%IN0rCy% zl=!*817?rRH7Vk!_HsV+V57C=UXNf6ory(Qsh`FoI5H0#m)5hUBxaImQ2OB4|= zRQuQcQupux`a#*QamT;!g!S7~nZ?>&y;FaC9SjJ@v4rr#AmWL_7^LR(*7YAxs+z55Ctc+(2z>l0p(v}iK+03G z<#?EIcr>~#OjzT_t4`@%dr!S?O<5nPl*$hVmAYHOUNjW{jCx9AUPVVMOJ-UZc5yG7 zWVN!G{IhcKet~7_fc0c2fAp=6r@VS=2FT))>QagE%BucVq!-c6I>}H)kY-TFE$_Gm z3K(Lyb0RSixN>C*H*O0QtTelm(uS!Zg|ade&s6qE2FBv| z$TNvXjtJ%ba6bwh<>}8^djBlI$!n&j>iYx5XX^ zV-yru()voAR9^E7Phcme-|Pkk?ekHlx4IwyB7e;3ci>drTw(xKz?b{k_IIC`7AE3V z{gq+AvE$X$UG^3B8(srFRawhBlR{>bDD%!WHFZ8{JTE@vYdh0y(e3aBwo3M^nZ@nf z*S476pSk<~Ti-?ei;cv!R{Cr^rMAV{7jCT${6?8;gycd9HcG`)A}R0vuaj#jWEZEF z8vB9(I>sHAEW$rLDWi)dYKh%)U`n z9=QzncQJ{%XvHLlWdOg=ZqXt8K5i^e8Bc&Qz^%4Bx{~2S(v6_|T~s6UWCeX)6@hN4jYjY2HYhEc2|;mCpT*gEQL zKax*|=aI^%h-I@m-AXC8LRDaS{v zAPh^E&r1|=M)3Pbi%+1%<<{}kN26p+M$?L04x~2#Ehu-!*!r{$HjxV@H&4gob_^hC zH=Ly%ymKGIVtFbnOmZdz~xV@!s)O3w#-m8!+B)-YRxo-!{HjILvl!3Do`oOD&rR{&P%) zN0f+g9^WtB{km%qHWZ2WQ1Tp`GpfNqWUjrW&giuWnpGv`Crl6`=4^R z&H4Y9J4+h|XEjk&hk>f9Iw@;{tgKmce1{t&W=QQ~dWz(8#TCwvw{7@9GC|>Hy_OcP z5j1F!pZA4bgOHDF`}BE#-szuxjdcr5f%B}%*ivVAKOPm=a>@J?+1YxHmi<$Wm-3wg zfaly<&f%%A&}t8_LE;C*UDL;Km*wvA<5SUw>J8WGQ^T#iihXojwTHdwUwa0dOp*C% z^G$)O?{EJRk=5I&-hPdJ^D|iLk#D=+I``4j4ejmbjhkIpJ3uo2ecyAN8BRv`w1*nkFWVSw&0^o?DZKK4w_gGY5#?J%MzE5_ej1z3Z}qnAAnW zl)Am_k!~9|-Sp~5Fg0`kAbMZdmEH$Z%;6vN@R^uAzo5Chd1$Ei;q@)=EB#pXaivxJ zPOe%->~A$&c6&o!z5^jBmH-3ocD-*Ru|R!sDF~cn`3Se|Jp+B+ow|(8u8ja1j+|Qi zTZXN2O?}NgOn=`}F1UWrN`5s=girS*%ZLeC$IUt?9S$OLlP5cP!C+ece(H3phl=iU z{%iHDoS;O*=&&gkVzydZX83^KQS7{Wak+Gvr8;-75BkFNldYR+%snt(PoWrDroCRI z?b}1QpWTe=J@XtlVWwG@@=p!`>Shf7=2K7=v5G z)^?R(u6g*9e_#So6gfHEjMnwoxJHk+?P$$P`A-4;?`_k`{w99OO?;CjIoEV0cpURc zoL7s-d5E8BlSW5D&SRUK##@I^SZ)Aa1_Q>?EJ90|PgT|JntRbPZGeX}3g7g`U@*KO8U1NI6x!?@Zx z5yFt5Zovd7ElYZk1D#;ky*cRozeli4O$u<25Ch7g`Z>-xK~bpLssfHEgvsVXFH%R{ z?Sh5`V3DTSlkdridndLim@yW6By_wX-PPpO_+S4?D@>a7Dygvo+F~1Rbv*PfLDM9e0=Dm ziqd`M1DnyqiCRc^?*{$4J~C?LwLvii9ic(5jWk&~5X}jH=w&(mdG+V%8PY3c{4xk?*2dEiDj1R2Zw(FpGkMxsTu6 zhpxDSy%cN!p2#;Cp7<0QBZm>Cs(^--_@{}gY2=^M)1P_D>~}1hK}h{in^N}J>5t1?PWew_ zO1yfHvOaBb|%ARH5^u^`~JIv)tu z=$VXo))X!zJdbX-$C!`ut*@k)x^7U>%Dp|2QLmPVkm1O~TcS3_zs@bvVL((Ml6x_| zboS+($J!!=;Xjma=0K#Bj!=UIaZ94DcpOOlJF*yd?yy?qD8O)!BK#wU3tlw;f??l_ z#Aj^rriy!nh-sRU)B#8u-ui{TWDlx14Z0Esjar=r1B(bb4YxS&7Tf7^Z{jEW_{%`Y zg$Fkrin-~d*3F6+3_S*ar#{jD#ec(iko0TU`iPN?W`qHD@IR&BKy|21`+5a{s5k1;)BS3$NER#3O68g8D0DG3ofj&60^hqcI+^pwqP zF(-XYH57oMAOe9VjADeIizz{gkx1>tf#5Vuk}Y6fIU{bWt0agTAvcJNwJ9#O(<3~A zBZhL?stnb937g3gtcb5Z!4(lUx3q<;07IW6$eAH#Cw-jmOhs2Yh8BfyQV#Orn+BcN zhz}+~;-j8Qt$RXW-bWyEE?F~Ds3fn%70g;~SVP6lVuStl&b{1tR+LEhNd#~&*Zv?r z_V97ZWVGn842l(59p`04fw+EI4zdtZGSU&vl-MUkdy2v(^x-lgL);DOgibZWyp=XYn8N*+ zNHL$;fT0IZotRYyJgJ7$~VOSsU?r+ihkU1O|A(V1DQNKc1ZmZD9hBFC>N>V9~$!z`=9q*vX>SC7H61 z{MLRsLzqDmBl+QgN6Lq?#JE6(qMj1*UuxeM6=cm9CQm0wKw2m!PaMM|o$F#nVNAX- z=DX^-mZ4qF780V0uAv6M8sgCQOspZ0|?Aym@11Ea>(f2ENXo2`3oj#S8Su|4I3Kt?Z$5J@vrs+4X8LFP@6 zaNpbcTi+tq3Kmx;3x%*q=mzP8BAUi*Egz1h>@91}e~4;%DxFjz#5B`1mps5A?uaI6 z0)CDZ8XiCt14WG!%7kz7;V3E9x!x*FAYaGl#CJrqAiz_S{m``6Ml(+JRDP4VKLVFj zqyHTr8R>N%E^Zg7+-KsT*DKxyYzpVUr9IyHfcr{`F!eO^@SQTo5R&Oqvy$}e#9-!CkRcI;_v zf5qFtQO36algF$)Si(q7$3l#-bA-pJ<>e8IxJ7M>75)(c3!uxKEPNJYIFdF%Gj3@> zbt8%h)+pssM-J=gXp?>8#=FOe-gJ$UBuZ#0!o9bQ>-c%D-U9y_P^!?*@h1y5ss_K8 zzDEk}tmN_+#RU(IoB`BwPg_uv73}0~`!{cqE#X9Tt z-GvW*w~g+fXf3MmADn^-D+)u;cUi79Bs_93dQBd=0Lq_D%;lOHL+jFiGg@M8a;YZ= zfN;4d`=6CQ(N+6+Y3!aIm%iIok?qN3UZ8Ty-3f)sj!iU~&(Bas+M^!9c`&(UPX*CE zo7t!eZQ)S81#R&fAm{bFPKBE~X&thQwLj%$eL4uU!5KUTcYoIPZnQbJ{T>|?%!GM$ zCJRvhqEION;d!sC>Qr(M-7HW4$}$x$d0CYKmVh zHV5UsRqa2>I!{uL(8ub%CKAT#N&@{(i^eTG}$OS<%0w+f{GwRR8%P;7jGZ>; zT|ce_9w+3?ZzL(wjB#~NFHpczqMA@oz)gCL#d*xYQCdn-@5#>2-WJReSf6S$=R{B; zB+#4Y`(#8d;NOLW=vZ8sq!u{xFrmZ?GH8Z+$RrK4Feg(87!w(VRyeLA)qp^GHQ8I2 zQ$=%;ajo8+%6J}kr-KdN{O4%E-ao)Io;t$+3}*M^F`nM6czp~*MU$qHAYszi&;JFG zLEd)$zZV|X|5oWanE&SsOc%Jvv?-(7=Y8o)Ho-F=TmF%2Qfc(VyrfJEK7Q5T&q zYBx+Qm=(yn_v7W`6c~v}DDiP>&I}sP=aX&MzymQu{+819aTPtTpy5n|!yzk|jBHU? z;nV|F9J^^v9?nD*mOTqVDIgb+rN<(F@yu6d{QC5rlhfYTLXJGb4DO%*y4|BWS09G7 zJe&8Gy1W`I_ted;6Ta>}cJpk-(>*4k4!-oJx;UU&!(buLX@k|koA9yB?m}{^;J`i_ z$N-Hj&Y?4q4xXJKmslHFYU>P7idu$4n$W={1&0aW4lrL2SMoD0%DjzMvnj-4{LlH7 zsDVF4LR(dx6#Vs4&v}O;-*dWQEUS(85DPZBC}7HMO4Y zN{LVdSW=WNJA*bdB^+zIWLZ4C>JBw+>FJzZF8LCxr7>L*Gf80F_mb13$;O0gb zWZX_cXFT{#9P$~haOXZ+JXfUeIa^}ib)^YfhKDg@0ZX>TpbRa5KVDk zua5>nwgSCH;Y7B=HEyi?b(%?_6m5rF&mqxE-uzPxw|1-)(2qm#_X(S08Am_Cpga#y z`<9}Ev@8)CkWf5zc@Jb6h;g4ANUi%ydbMV;VZMGaF`l)w+&Z(oy-L7H6&9~Nb?#KV z3oOZT!mW3*%57|wRpu5`lp4OuT3;#_TIHOT2LD~}>5d8dSktgC%Im`L zrkXGJ4pr{9aTa&Xyq&IG{mhf$H}oUOPWbJV?w4# zO#z`6ZGwP3xN&1_l}^M1MOxLzeW@Z=o*xSH_Bd z=+9Q&QA-HY?>#qti?NpZo15pIxuIrM=f6d8H;ffWX3`wiTN#a-dqvZP@!V=jRq=ce z$&`ruOiV}|w?=TU1k|j5vniPnZ+HkEqzncQ8k^kJr}&RUM%fYhHdXlJdRk^qOxgtIUxd7DHlsdGD%?>-l%;&`(Mz-pic2LegVF1V1R(Ftf@#l9o5)--SH3rhzzt@vR}6rh z_At=7LX^Fwd*HOf=8+%{Nc7SgBK&4`CC#Mz5}K-E$A)DQ^^vk0_m|Kov*j-%=gzWJjmJr(@V35KBEO`v4w;RT}B zI`Mvo-YgG;2xK){Q&xe9N_thFlrx22>FM=}-XL{xP~a_QzjfEpMN8(5b;(6O>uRG?k7w!x;?j`PqdUae#(1e>J?M=G?Jf#^Yu3fg1 zRdn6{-ksWE)Js}u(Sy7Uqs6c#;si5w`YB(XGs0c$ceGQwaGY}_Bn3#GXt`agE0Kf# z&1Otj?u}4=J|8Z$|71hSSO}0tPfjSfDbO@bNTC}}_ymk4Bx`N@aO?hC_NRc*?6!(i zgQ*^WoXYJUo{rqrC-%C>(Vm8DgJo{MDw>k;${$~kwX*4f>yf}h{5qUv49{99Ok=Pp z0S~m}RgcXh=&)X&lMbJ%KLKq%zgc#>wOp3mXLTVwj3;^6hSH28$s=(Fn#WBX$)RF} zpG7-685i7zskk2t$QGlAR#+vRixg4#OCoKK88z1;=OwY?{a;{;uN+uoLpfzRrt|pk812@Ea zWi*VO3~Yyq{_|Qz{>5ZdsRhO8?R(+;1l*?XkA;wug4(au{_^ZNb>9FR@qix?9*kqN zVBbBZcZD5k24n)*SpPx&YFX*$3*}QH!0uuo9_kv~BxyE5{!)mQ*}G^ED*yU3mCw>?-*SeAAkU@uC_#3y+}r-D`k_*R>5j97zHu;ls%7 ztyn>vav2Fetl2Q|&BdFGe%4N?>BRd_GNTitmhmM^Q{wFdM|fVgz!9u|5i6LMR0-jj zkgYNM2i!`Dr@SGDSHL*(nCVvhB^x$WbqRMeF0YR}9&8TV`cc#n^fj&%xi_c1>1b?k zR%;k~Hb?Hz_l?PIEn_uM_is_IOz zCRV*MMs*Q2$Kd{L>bA<+7S3_k2=)LWHws1$Fs5PS2@tptHMj079p*p`UP-sfD6a3O z$X1{&JSw(wrgpL6ailHqn)GwnTTj>7Dzbl)%Soe)m&J#mUG%K?P!i{4$2hAsfN=6N zJVi~^#>Mk&F~t7h_+Qs6^Fp89_P$7~dL};tl)$dsV{DElh>&D}J@ukHYbVxl5!1GZ z>b!5pI*Ajp3ADrEhl=(3*u3hv1vPdm3zl+T^Qjl{#{K1`=UDsoAy$u!@t7Cgf*&c9AF7y9ZBwHq@4T_fPE!*A!);3WMym-TV=ficFnHgk&M};OuGhfA z>^kA`vd~D|{Ej+BjKF^AFzjX^flL*(Xluv~=cI_z5&CS1=>z%!FVZB6M?3RQT#NXN z$^lVG|E?lNacCLwAs^7{XKyM{eJ5I2adny^V3bMh#yCU_E?#xBw2lyr){p?XUYL(RE5Zb8t&*Lf*But_$7hJ3f z$`-RfSB&vOn(C*GrGUMrTNNNnE)wsK1MpI2GAg$8Mh^0w3Xp*#822VeF$_Hxgyi-g z848=D3Kv(``x6a(FM6)zzJrIqBZc&Qg`XUQ*hLAmVKo}XFM9~!?n}X86k>Jl!1za* z*^2`C4rf^UOaeJXuO9#2VD`d;@3~YRk^^C{_Y-8q$uONA13>`5F=pyGC?=LK#q%oU z*ZD1BxCvNMisR2##I~ly1>jJ-L2cyNqCQmlX-jXZgB(#|;uG#+{i ztKHUi6l75+%wGO0e9IuM7*h#sGY^>Z0|)=De5n zbtROzB$Q4Znh?ieS~UCre8t|=z|x@M3aO*BOA`0ejB!{v>`fkm`hV9Y28RIt(MRl| zsl!@;?CE1R%>U!`VdnOE-@z0DtFdM3+R1z*%Y7L=7kMzhSC{tsXaBrCd{(Ms(hDUt ztjcxTU@hpY3O3GH&pj%c5BFC`o~}S_9#%1tlaRzUG!fD;^~;roOTDXVy<9ExA)?6j z>8Ato-15~yA#-Hj7iAKl6RW(X*P~#N1E2`%=jQ6zQFngZEFyQRe(tGop7RHJG#y@H zDrdo_I^(~3dGG6jM=!^|6EozfqK@f=>St5%xBLngXRPnrEW?{;6jq=Ajho*!8kig4prax343IbPNTomUGL)NK+1J1`hi#rGBFhJFJxH0V=FQwL^3AN#Mt5)K{XL% z9THVuLeMKK?!Hu=t~u{G$CN2tu2#?TgV*k`%+NWNnM{Vt=-yeX#G?Bp6F4f|P=FVY zw28~cv?!?DyCDjv8E8zSTsU4$iV9{(SQ7PNmz%Y#-T%CJrRRzxA3A!Z&KQAjUdyOB z5&zlRyp=Dir6ZIEn{Qxg<*kCOQAoL*jWNhqcSwKQ9`$?#B9uHlyJ-IWd~|2mmpgkg zIr3V)Whig?e2cj(`~G~T_~#dZP{)=@S50`D@j`1}+mAD@R6w+};MTCxpm%cRzfRmIujqbP>TXz@5R zR)dkLso1<ibzQDj7Y{B-!9~#wyo0^Ly5^*pA(L}Q_>7eQL6feB;|{QSz43YxR5IhntN{0)1s%IAKj6(x1?3FzSw6+kR}>;2q~5xl@QkG)Wj>! z^|;Be1N-){h*PAx6LWs{lxs!D;I!k|iVTpvie|dJ6I{emtkONkpd?x))U3#`wG6LA zTU&hOJ#`xj8J$wj4W(h2FCmq->{ZQIL+>J?b0VW8zJwOAE?eCsg_qS)OLAi4Bd2H? zG7iAJTvFp1Gm#y*h^!3&Ap-MJI|s%|(8iJ|Qc+v#BD6MpkfR7FH}+)3A_^Fo>m?gS zchzfg_A+au2F~v)C!c0FVQszDd$dO03y?}98zPM3q?jJoT-$|!INz3lwX5?MUhy2X zJrmfxbSyuZyH}&B0ZO32KVkeuM~r3*5u~#4C@Oc!`lldZ*(8!3;whi%lly<3UoKYQ z?znmwE8^jkS!HfvXo$Fe=8<{VVz+(ROWKF8Zi}|`g3ZE(NZG<$8));Q5Qnh7D$PH7 zr#wTOs7N{8U6gZD5}N?vM=&Sw$pe0z^@uqhETER`1EJ2EC>8y%U4)z|x`yKo>j$U@ z(q-;w*|ClCgfhe%)|zLp?Pb;ERP(}RXx*}`u$xlB!>-@pNo!>3vM$uwKh)sv?4OV&SuX9e3@Z}R8Jpdeo_}<{TC?LDnA4#| zkJhPwGF7bMRR5TNZlNQWb(Htgf@BMie_7ee{y3fSCGsG!DZ_a`v0=uoX-VeL$%@4snIF&&oipSKIEz9T8y;%${i-im(Nx?fowos=(;yv-C>^t zE*pam>ZGfhSc9IHwQQY$CZGd{gt#4|tH61=EkT_FrzAz!y_%yF0m|8R{x~}%*+yO@ z&^%!+_U-2iYu^+l4X@*xHf~cRo3-OhmBLNCp6gLh43dlC25;2V2hZ#8p|nT{bJ5#z z0$I`e+fTcsNsJ%#g~Ok$mYD=;Wmaw7xmkLOBy8cmVxCA8PV7Yw&%oZTONy?nM`(=}pT&%#DC zEbcvC^AyN~hhK_=#_a!M3C{mw2^Plx*%GTdG7fkgD1BEN&&GgPBP{-yQV>FRq2>)D z#>86t_#mp}W+Y=ilF1FuettrqE}!gNYx#C_aVdG0Mw@8URSg3^$;s1zINN`IB;E6X zIeGpsZdN7HrIp;D9ZS+M*1iX2n8$LiZri=yPa)}#&!0_>0>8RzN%lxA`ju8@fqHOB z4zgknVrVR*2@YCvTUVQ^@q&5>zI=_Znm$7_xO+MSoTcPYLA#Kw|+_`C( znx&0gja+)O9V?mkrZOu#ugBHR$p%W8Upm}X%UaPk;)YPf>dp=>uQz@6jQ4&A9B87j z)8D#dxsp;8@$!8?%YQzP_^1(iG)qGSz@B+o2XEO~{JMNjr>#Sq9oy5|V1$?VYGbT5 zNjtdqT-11iiI7%pPJkYb-hmhT1R#3IJ9$q5hDfqyv1Gz&s^ID5zabZJp6)I1C?=@G zG#%_PxW@40j=8N|;?3Z3VPJw;suvylkJ~jB?H=v>26~M5toL<~@MQ{BHnb-2*tF-@ zY*t8AhPp$`u>*}1@T7DgU1?WQobjQiEhI(07HwB#z$r30x#!-lx-Ce-IqH+gsX~#e z@=sIC5X9>W3ES0Zhg7k;*JLJx2gvxGd1H4y4dNZ3STJX1nLFn=oA(}L?CO$O=6HSU zvNJ(6A>p+TU9nu2Eu6SLOV*^E_T)l1saCXWWF6B`6%}@OVD}Md&}4AzD(EZ3ytcE( zreJ6@KzYx>#=5yxL#oBqKpFYKJHh!*){qR(>V(~_6YLQ0z`AhO!kz6&6Tvvenlqqa zIx%jwdrX4OP$r?NF_oGJRWPZn2l@*dZRKtC^o+?g z4PEpG{yo2reop^fUnXktlNyAGQy=C4zp zV2aZfW7tF%V!FqI5#q}JAI8ohOps_fA3Ij8faGc>2wyt|qI2@y5Vtv>lX|QkKgQum{LpSzl6U}{nBYwQ4Xpe!D6Xen zml+YMn*i zY^gM{=W&VAozkdBe4x|;H7;0oQNyQpYn3F6%9(xR8>)robX$IT>6t4B7h@{p5wu&Q zxN<9El8ILsRAO_uf<6{XAxcWPKLgAG!wO)k9AXys4?xD&nl*PCHV54u6 z3)nHsr_aS{)R-yA8D|F}P&0O4$8%)E$ zr(9he#g8K}53pm5t*sl`8rdzGCtgI9%~BHxDSQ=ujmA$=+@;e&`LrsdXsu-$IaMIZ z$t|@LAp5LP{vEAr`utc-suDpb3Ohwb9`ei;;@V*8M_6+eviAhbeih;wgwU2*Mp?xw>&tBX@qcFNhi%!m{7+%NpzZ2h@^?6EkBMgo} z8${3>!|?0y`uen+^2CTOV46{Ao+-OAoNoV>nO)XEl8u6bDs<&9Ll;Qd{19ATo0+=X z+4fq+Pc3G!$eVkMb__w9cW{nfm!H#V&(19Yub9VNv+!B zIoM$VqxFLe3K^zS7%iGvtye?%Q(V&%w#ej~C#CJ!9krEXTtvwbk_Hs484$YP!>rHb zs&LjB?9YS^Pk{xCB6;p+o9iYwJP!;A*#&msKtF&qS?slaHNwipTNhbFb=w)^>*@Y{ zr*)~0zUtm)f4hQx_8U^0ZMvpnSFN-4wPF6S_J*%Dty1xyd5ZPFOinX1vi{HQ$YX8k zq{G(#KQu&*E}H^+2s>AS!=~L}JeGDP=XBqR6g!+@SVKZpc=UX1y+!MeJ>EIZmk5Ir%iAk~bxzRdLL_!6k( z^}e|Ls_z@jF0Lv4pd%EM_HK?a$FoSnKF9?q7{a!mjhInI&{AH6x3V}yv9D#q+W?^!a1Bo{js zf@{IHDguQZvO_8cr%B2rM{_EV&Fe0N?%&z@whAiD&ti;e?qTm*>MZIq+c@%ZFqUW0 zIy`mDEG1&sB(LX^a~yP}a_E@S)Awc#1Y1K@)kCe13H#{^1q-95ATKtQjSVfCf~6%# zGUMHzA2AQA|04cMXX>Bi4)D2so(@ys1cEa%3!sVz4l*~L!DgNf7mQJoly171?#mNI zz;Xu|KSV1-Uw@5aB53ile?9!nvJN zbv$lV@B2KSLJghIA7j-gLU~b01I($+6 zvL3)^Is$Lu*PMcFMUr&UY+Rs!AA?=C+8JStnKPvU(n)wGp=l-FYze4Ul&{B!%fxkc z^j}qH^xf5c_x+unl%G>$3#zC&j2|nw)tTN6{Fh@UzjM7Edqgt1>k3g0j3n)qDMnSCeyQA#F0^Y0cret3=}y&75(=An(W|GG3ahWv z^y1)F3ot`jcA^<)P_Ng#!E6Q<RX8rPY4{D+$}3Fc>6Fm%ZYK&`b< z6op`CJ|0UJFw|9b>U_|7k~u@oP5Fnnxp)MXTod&RW$)Kv!IWUAY$Y|>WK^A{QS|AMbU?b!2ET$RUMhCK3cUx##$l8c2T1c zeBK_-)W?Jr;hTC-C>)OGbfEihzrRna+TOkkpy-IJx=vh@DcCG##V#RhKA1_x+&xWI zZC~u!re34GwEfy-&X~(3RMl}4CxSvXkHilnxyJ6~>(mhl;3|Ybiy%W4HirMW;_3l5 ziXv~?;ehEZW*p=Y=EqS!B}h_pfkIZ+g*z0-=4xa>agQuL3DK!vxe%Iz6D_!%0IY?o zUDJ#;9A_!4UQd<^YMx4nIbsp6u^YB%R>MhybMJOS)&MYMiAMQ-p0@3iqBY9BGqvjD zzvNUROllcn8i%dXsH@J+PSbE9$Tz%cwR_OOomDx?|CGSN92OVS-yexb?aID8Pdm}Y z_B<6>E`JUjx?ciSXeFmJE1h0hnP5mf!7RR@^wqFeecq|qv>C>a*p>ILZR4$&hBq=e zb7eOcArTH=oz!c#XKvglA~YIHzD9F?bO=sA)>%8V(Qi$6Z&gMYp0PJ*36`9_P?c6X zP6cqLQZAK<9nn*bA$FqOxmKzSzhzy&T=-=PbW#V$RjEAm6a7Ih1tJ~)(#!@RHyk+< zyui!+sMmfILjU1O*b?4g8otD1-{vZKjEFudy_&aBa3|&{3NegP{6tt6Ilef};o& z8aT#6^gF=_T@*_$e@FF}9N7b#Fz*_o;^XWC>p%B1O3~1ENj_ejjo|IL)8w0E5fEM{ zhrVntt`MdtmkDn5^=W(Iyfv0Ft}WrbI#4cG8&bBRQloHV573kFX`ucqt$5|awUwV9 z|3LXjxj`7BdSu1w?nj$O*u<@-Gzz1+uY5eIBY1A3?xhs|_^uGz4EL3Ng#&vnO_x)FHqmF5bWan3lS~Sa4GK80p*{u|_}4T|8dUvT=i=w;z(OO1VF_GKUX64MVZxLQlo&1E zOH!4Hf|2L7vN<9P$iL5|S4YT9V0 zNiV-m1IaUH1otP~{Gjkpl$0CZd_km|Mjtaf%l(-U zQrqI}+?4*H6-$d7YP_31^z+3jF1-C?MFne|>-6v2V_iKxdr0;^MODadMy^1XNUvF8 zu=cO>-~$gbRDViRKxp$zmWnYdjH9K&MB14{lgHcRJdK=NdImyz%tQ#)u)=5VO|z$33|Pwm)!J?(nW>l@mh?uC}WOSUU0h({OHm zFrU^6QdZZs4D|ui;{~511h@pm8+--g!GY+QLpBgphkD6l?O(Pioo(_J3C>iD@KMf{ z+Q`jaAVa>3X8$t=xZ!6LJlUF|*{z5%VP8VP58_46A`z<>s~4|X&V}ZlBTX@m4e8#* zp4r#ujO*i<7CB6KT`XpnR4H6;sNuK6x~%RX!Q&~|ixaj?ENFLfr5vVW@1ndl>kwXb zW#umcQdxJ8t#N5}2At>ML8LfhYiH&RTLms8+9Q=tKyBqS6`-i$ujirrbbGnM1b#Xk z*U8qyD13@9f8d7gG(o&mA)fSZh22BwH>8pjU(JVw8?=m<%4pOc-*u2G1{4J>mhTPA z%cgmTPgKjdUtU|@Ak+2JS?%D(8|7f%gkJWs3S6v9${)Pw^I;8rp495R+{E15bVVZs zJKZeCtRcN5&jF*JGZO_H;i=AyldZ6d$=q%+h};EYJHpc?t(v;UGqJOhXczEUQ6axW0milCt(+6`gC=4 zHR;>`{>l-il?8s(RojX(I}xfq6pH6vGfQsXu)h*8(@0gFnf9u7cCYRc22;Y8BP4v& z|Inmb1E{J{hY=?e+&)+VW|zt+{CqHdB{)HO-q6Gav3UUiHZYw9MmbP+S-~44b)aM~YopO)&V4pQJ4yS7?d8A`?unS4| zWKa_ldnn>WREISAK%eAgh~KBIaHE;o0qXM)d@6`34**eNipm?7qUh)(p@8SMstP-= z7f9Q#-41L}q%mG^ah(OqzbD~_8FzjGP{NZ+|4V`L-?$gATczsMtWP5oP18g* zhf8&&)bfR}XdT|X`RD8B;ObdB>mMqzx<2AM8cL!vC8I4#(zZUL`l9`ltHkyBeK59a zpK%r4GRz6dXgJ+h37Bb~$w6F=PY^ywmc>lONEiK~5oL(Wn5j|KG@JjLJY|)A4xv0e zE`e61el^K7++JJWs8?TgpyOZ^y^BsPR}mO_zr(>E6S=DboO}jTUabQErcWCvws|r; zh?H5;>xR{oV_KM4WcbV(D(PCRXW}TFK1cy)X_vTu$?DE5`1l#(7wa(6G&}yPGF~u2 z^QS>qj+;JQNv-D1ZB$p!u2;K;?gp90kTM~By#qx=^2g>ag2<_5i&P?- z62^SH+-B^#d!*gVLFI)=4oe7-b%rH@U<8raI&v+U7_kh+P(xl>UirY3CY528@IX#W znh$Jqn-QnsRFy<+9B~WCPR-jk;KCZ~)3d{x;BuY2m=RB4ss(1~ zR13MlN-kbxCjP2@(qF5#&dk|R<>yr9(TCBPVFh)XR3kSW&<0L=wxC%-za8n!Gy8%K zSCx{_Enq(b$?w%|`lZpy%=qh{<~4Q-MMG-eSp-B(+Nc^k+#sABxQbWw&+5U`Q!ZL? zy-5%foSM20f}QnERUiRKK)y;?4m9AZ^N!s_Wj6xV7wUcB#&<*=}Oi zSO2y@^=+Z-A0AeLxIz*D!iuGJ&rWS91B+YByVw>lYc*GTdGA41GRzt`*+g#pHNmAe zy}NeozS)!QqPatR6qe_%vh>ooF4x^w6t++|xFcBght6)A4>aVN-I;67ti9j9wnVk< zxIQO~N}&2lv92CvIjI@|qJgDP+W)*4{?iIIdiHFTk-}j2Zlgq14WS|XkWey#@iUa< z58(mZ_PQv#zCF+FP}r1&duxwW$|h&c(-J5b=3!kC7>(?s?ZCc9bo=eCRA`g1qOm;S z)Tj0x1`mOTG4n)&dXzXpzHrkQfVOw5@H+nhf z+S#=&*FSW6EfIq#jzs*H&;dlw;MQyDw7?%;+rCs8W$k$f%3a1I_2&XNru}dLObA$@ zLzR%n_pl^;oO&ouvP%CLk7Dd~ank!!+AEWb&Hni(6GW3uL2_?}D`Y1yWORm8W9;-KnIF1c4khc zswGJ>c5Yi6Um@_ct>7+Qame}>+O=beA)7s`(vZio_=qWs?8VWH$fHYD;B}{mQ1((S zmy-@?CG<{Mq+7}u(v=`54&g6GBIiPBacNj9SVpY4U>GK!u;0SL+fz1Dzj)6Z$(Rvu zFw53@cmav~x4=v4nG?){>80t3b4)t4Ly&Xg$@!H_|B0pD{|1EY+0NX;boA2QV|cy6 ztPD|9m7-oRvg?S#eVgQpAeH?R2g5sT0Dj%G@U{I9E5~JEQ?U0Q?uE1 z;FS`tNQN5e|E@$n3_qK3Psjtk?h}7&H0)5&)mTa(R*beNCnH&FWMr4~)+*EqS zb7`1s{6;}!s1XdFl-S5;y2eQn#ko5=Z;)xu=f@ce!-oOsGBXCdUs;y>9}23zd{nQ@rD&7DQWvStX!*7i|O>-U*(B) z3s4qaMs~7mpJF6Gk0`#oTNG}2`&w`}HcRHLolh@}Qq|pK)#_B_z#KJH>+6On74M-T-Gq%GuIGiqpX*IQ4^bzB z6JceakR*}3B(J9!y>!a{?ZP3!NxX(ESiJBnw8KKwk?>YvgTu6RTMdx-x$J$;6r^7$ zvZ7pCu5)svHK3C$ZLQr>JI?@XP4CHWZJ+8{^RTbmeIqWmLP$eJpPI<$ux;7O(@_xr z9iEBA#2AeS0;)z6;Z0!a4dPT3Na>ew;UeCfjfbp|k9pee3m@=-yILL8P5;tJFv;i( zBoKKK=)sJZxgH5TX(~>{&hn2C%o?6(ICjxkbi5df8sW&F1=>U*mcik*6)T&rl)TxA8A*5rOAid6qFV%|V?lnB7V)ar@{tQvJa}#Dxk}9Z* zu`eceu!;VVwz;c!`!Bki8zdQ#o`dn4%s-c?#vKYlkz3>E`ovNV4m0;Es1Ft%ykJui z)D1l&Ubb^gu8>pA|B%d5sPl<~a9m-EV{#;A^XV**3^BpA#PfY6IiFw5ijYS_n3?NPi8D{+iS6|w?Q)kE8CLb;e0$62Jva6=*FnKkJKOOpyYeDcFd>fSeO z4??oqC0R@V9!xcZ#3E#GEjoLVkx>tbMR%u;bUoA_PA6t9QHP83nt^2%`T5Ph@MU8! z_Cli`{6Q%3XSt)o+LOO4QP0$=Zz{Zo{J)7Im~61@Dr<RMp#G@R@#0$HN6$dDw30=Y^1KPrrcI z${Ef7CGK+m7rudoo$Y^RC9id)<8a#k-+0hjf71(F9W4TJ^_8Rh+0&=Uc_xi2kh0_hp;9xjx^$ zsKP)YZS9XL0oL&vs+_fH4rQ$$jb3)&l9qmV=f}+yxj;>WUZ{XkDbC|xtALTg%Dw0~ z;Ao~5RBQ#5cC6>2)>dFz?tD}&Dy<kMPiD`aN{SS$K|N|sjJ%c|+<>NSVQ zWBL}xjtLuvjtL}m4N$UgheZ#mwrI}d@hEPZt5L#bIBE${dNmUaO6!g_i~B0sQyc8f zr6CQ=xGqb^TMcsmfXFMl#6KU_q^4_foNkB1zksIcbh^$oCUZO{b227NhYm29E;J^^ zNyiC-%<+PebM(SsX5AYELsU$)ST8OZXkwN#%!Z6t%WO2`gAI^}&t2}{oPuA+I+^a( z%+#!t+*+BZz;lk!lAx6A89uYaI*n}DT-L!+uv~dLs0x8ii;F^ZeF*NGc>gf!?~- zc!JiV69;ig*vd#onu?^L+W95#yB2s#7JObbQpjeMGhIYVI?8+NR5DqFEf;J`&e7z! z=~ygl=0XSrQWi!9lVg1bljmHBg`DlBsR152LQ6SuLwOl;Ea8G*_l1}x6ebMfcs31J zIi+M+$s;2|5d4cWm09#noZ;jE*HtrV;T%^*-;7xUWU+i4m3jA8 zWg;OOhbr;NNiTsje1nZ>vsE5GNoJ4SNZ3@|nMHdaj}`Byjgv5I3$sx!+k!21x!bi> z1T6)5vf9J2YbvUzG{vo~Y@vdSGkDkG;>3oonLXr;I73e3FKJ=GCSaTD@2coQYhPO& zzNz8_B~?kfzzy5Z78K@jwTR_Uuc}!e46SXPNM@Mf{ql%{MKjDw=Bs0FzF3Gx24Y=f zjO0WvKsW35SX2h&adSK&TzbwF=(xte_nxS`DXF_LFR40|EE^jp9W_+ zA>`>8vh8>Mot+n1(vV*50`i~k$R>mTVENCWZk?GWl0LV2a24dWQ=dsPF+|YHW4@3t zMyk`a)Fuab^Rax_Uxbe!T#Wc7yc6i($_l4*Y!_A7JT|@|oNm4YG%XctZ}vqFar^q? zhIn@n(4!5NmqRay@3;CJOSyf|=2lV+TSvbcnZ0%&%}jqQkR*qBDZD8lwm!q#_vD(fSI9|O_hP2ZWvQkf;J=-G5lGvMDWDP` zlSUpgStjntWY4FR+6+OZZT9H{v_G!i(zor}(Ifo*O*7@ZPD$7mPc`P?o63N(Atv$V zw*=+iLcX@QzH^(v^6o;v4+J<`d zoir^Cs=v65R;(>1iD9<0gd7$n=Z-!{wsR_NNOZ6SbJ}Kc;`ZSV-%{+2887)e)@IFC z)_bI#zIf3%EfT%*EkPTb`BLpBO__Ag zlUtZX$v@J+2AO;wL(hkpEli`CX;=?1kLt^f=L?^2`^4ZtgsBB(b^swmo|os)4x69m zLQ>He;aP-`R>BB$r@HH#Kmj>i!iCi78L0QygUIpKRa+dc&+Gm{r8U1lhjTdaLxV1t!H$8^>!#oOzIvX(_C}#Rn z!wUJStG>)-iZNf$`*oyUQ{h7dCLo=al8t&QAC*0th;pgs!1Cv+JO0B6yy)hc0xG}X zTxFN@HM!*?>8f8X6O3Y|vc7=N%%S+LF355ZLXOYZP9lP66}1XDKi}jO?{_8mkIrDc zDL2YdUulQpxATpWr4Lmz<8e>^;TDwE;PN)RVY)wZDhT1u&3*#Gu$*)^COa_%(nq5* z7fNVP1q)Pigiv3|RneZh2;sU^@}|1&A*hYY8ceUJ^XuYR8zzTT;%HQFzg#xF^PMm0P4gmQzBGOF~Rsh^a1$<80MiWvdC1_@GX}+=5I*n4DhMg7ECT zxh?Hq?M+v><6-cYR8nT4^{J~Z|20UMMMbqaGvl1Yt#V+t8bN(`Xagu}!Pi=V$fmFN zvZ?Fs$LpCa_}_6_qR5aJMHDjzd+Uns(?>nulOwI8sA@#%HJHv>rmI*6y<@$ZD1$h8 zHKU!g2=&LHeg-$caG-7vZiQf=zhw(AZeNUxx+%A~9zhJ&rx|aqXg>E|s%~ZVm6$CQ z##|3YucA|W(5gto49`wrNzgq8GN0+X=C_X@5LU~5Xsjv_3!x=KT4YJ|xk@)|Kbr!L z`b)hupH;aL(wxa5k)diQ=9u}dG#lyE9kg+i9f-~*USC@W2RfbIYp;lHVH z7H6~A;`4b6ADgw}2awR?)TOk#zMGZ)t~T6TKmWm3|DU_7qaWj4P_*ji?IwLLN{+=H zw-xHrj?3Jho7`RR0ZxA3_p6ETF(GnmUT8sKnZA>{As}k*sUT%OIt3Zc)oYMNjnz7? zuB|D=2pk*AnwvyZ`gVpPp}gxdU5wYy8yE7NF{vTQ1i-Mo)ZRTQSZf_8jv*U`^?eY+ zaVA1xzh*W=CqKWK$J4@Sf+eeTMJ~=y5B}V%)AU8akCwsM%i^87q%{hUf++WWXFt0zNUgazoWU-_aixQ^Fn!AYDVr^1aOzl$>x4AiA-y(Z? zp5$B;4dGd{TF~mK+v{UVr}Un$So}TMN~w3Q4S0_m z1!m=L(jN-IL7UJtQ@MJk26dSb^Jz)H>(Azow;GZYdXNFk(gFUc<3N|5aJg6c@EfPI z0TrSs*sVQ`l`&4@>HctNadMb=o7n@aHZc>6)>wKaxzLCOH%rHD(3??iZ8w6L)`lY0@fRls&fHmN%1u&b1KM zg|>8;whcz}(A9<3<*Z7KrXOQsV)&TR)}5c-An z;JW*LxNa==sEiYBRE}Qi#8(JvCh3VIlfCBdgU>(7c=&&|*LpD5vWKFTIc~S?b<#QZ zh!B=l^f1-jvNRUQK_adoX3&?I3uQKgyZcH&1OWgGtku1-?~DAI*t7gFGQTnf?}u>9 zAipB2W1Hv7#4OuJuL6LO{EtBj45?9)a-WV^7ME=yx7WA$4vy2dwsD#M-i_AQcGT z*f`#Y#d#rh#G^^M>OTgDTAdYm^};x!1Pbj@|t$ z@fDl8ek>`c1VE<(x0g-DrC^hPw*-eBUODQ}0uh`s>6C|Ms`>W{!l|zJ>+XCh+`Eo$ zcIUbdTL~U8=BXpd=N^lBv>t+zfk-2A6KV|AkHAohZlIclOHy zBx`P(sDsOZ9Z11?`*B9gNz}1O_;@yn<~W0$XsG$BupGQ&+~+zwn!ZF?Cn>2|%O*!T zQgjwQf&MYxKFxeG9D;l4oXF&TiGJXD?URxib1W*%X09AiII%2zX8m@QS56EQIApN=h@wM{X3JET*dY;?7{Z**1l2UWPtljRr(dQ=eDMzb_pj4|HEh#@(` zh?O=dq(UYdy1F34;S6lLK5QWR6tjBsDwM8cnVRHDzMBFPdlnfAgqquaYItdg3^N=c z)m-6MfCy@j_Nwtd6MweJNHxtC%#-T6l{TQPTqzObV=W0PD;pT}U?K}x8__h6>)`c{4|El=6`8z>tY|$4jZ{@Bc*sqo-LX&@@!>6Yh>5P24h6}gp4=0_;cjU* zxf)W~y`zLeLo)pIE9n=N-?_xhv#v&^46UA0hbWDER4i@V;~|P3{Q=01a7uzuL=nXj z1(oV?3}y0LCyLZow?ZLj^44U*%a>M@BaPh1Bixf15VZRO)A`{1Um0`cY%+Tr`-)^| zmVTn~mWxkJtI)fQd~4(89*PM6$JQI0-uZQz;HHdg=lIYCMH_ltX>;fYHHgnyNwbd( zW{rS`wr{GU{cF|BNA$(LiIeg+_53bgc9jOc)#Xej5a5YrO?#PcioXXOM=#G_Zjx!F zBi3o+W!$7k>50&9t56=mbfXRaEl2{x7g~f4@yXk+HPB{KAWOU@nv^r)c<)!ok+Wpx zrb%p#!Ug#OTPHIcsnxOU}V8t<-y;_YUaYK_r1h>D}q8aT9JE$s$@x|ZM zOA+~3IC-!;GuZ1H5!$xdDlM>Veo{gr3{>B9)PdpMLdI%Q%ddD6{9u;aTD>cD`Z0bn zJql+ciVN59uZyR7_==3}$g{Avy*zg%q*@z^_rZj#-jV*_eLG@FEk&Vqzw zR8noYq3kVg5VJsw2Y>rv?g3%q-LS@=X;|eGcrJ@#3gdNyG;$V?&P^o(JK<4_*X~J& zydUIna)GYL9dBL*U9T_RDOLdRBQ=*Sk~;Zk?34imFXz>tikS@EqM<=99zxr zk`H*jah_0p^u{TD=yykt%dEUADTX_e_U|~ES4J`_as7XVk%QxIe=6J$hl=Fa+_U|8 zIkq7$Q{6`Cp&EQoOX4<@d>6s_hUc(A>(j9$&C}|7eLfz`ru@4*3Vne8Ww<}<0$`C} zSn>MBmm$El)hrE)t8ZG6T#=1%@AGv;?Ybh%CYb{Hl?M{~_kp!hunfilfLo`>f6JKE-Q4Q^ zdpFu**L%#n>?x${U8^SJDdb);Fy>DijZ%9&>Y5}&ncj12ZavR;3&Y>_HhfV3Sk&k4 zCE83zGPzf8HxF>FqRvjTUahNT4mS<-zQc&$-vF#=uPb*RMO3QRHP?mZYksYtul<=H zfJ1*)Rk#Twf0{}iTtD6LD|UycUjR<-puPW6T(JLValy#J_CJH(%UZf|8)7KFyZZZ; z^aLYG??2%iVPsa7#j4A0{}u;Er~vKIXw@qlB+cpXGQVKh@L*`IiTG-E?__W@zvg<+ z_6#i?=?W#`*IK;!aCLfpZIQ)t%(yajO2Wv)w1_aJMVC%g4Mh38nLRz+I}c$6rxPq0 z_;DU+?u+aA@^^k*M(&f!GAtopnpjFQXUU+c*X_)iME3Q_P$15d;ZG$*i697)=AKME zFV`)*ZAdE$VvM%2J#Uw3Hh3h|tt@X`BU^|@r#|1{!75Lz8Te+wD(^4t`Jv)PW?5C* z)s~VZ=qx*%zuWX&(Dh^PXRZd5P1$tMs-?^?e{U{(wf5@&jpXU>)I@{+Eq3?zkj>Dk zT}d%r;i_Q@iLANSbaxaUUU`hV|9oxw($%m?bw4C%AsYn`!W^u*fDIwuxOXGTgtnJu z1-`G`$VZZW?f>4S1$&}Mvp9&ZFG-3hrIEx;kZYNpFky}ssVrt3^+A0^M?-$rs;fY_ zKh6%PUFFFk*oZuFvL{L z8ln&ph=>n{VL)6r(d_}#nfjY$#3wpkMQB)UvHvdhMmJ`^w&|{_2l%FW#ab5o6s~Qp4_+5 zV6UoI=*_HI(d1iqK^NNMkh2o1jJ0br1?cy{BvA8uE&5gbw>a(X)TRTnJd@V!(NSQ0 z*ti00tPfj?o z%_~qzyVO=LY^g(p^N;+tIZ#m`_$3!vx_ico`FcO4Tzap2WUL;;07S|UOXM2XFkmO1 z9AIZZi_Z)IJ&#SR!sh*45kk1x9A=S-t*3v`QP0j%T;Bd8c{zbu&BPa5qW5ePXw@k% zWa={EedgbXXI2k~TwYM#gMI7YQT||M?onl9h+#y{F$j{c!F*l#0>Z3t5U#-#3nFwT zimt9E6ZKV|h;&7V@(oJLG+h^G6>+f*5zDhQM&CV!0C>}|fq@iKsE%Tmk>0n{Nr#oE z#j<)d+hwTK!+h@ko9uNXAnE-37(-OdtCU(DBxrX_qfndvzC(3F#yO(%r+cDni58mT zf70Z0Sw(EADD*`Mnvz{KX%uu3p^Z-@-Bi%GeT|jU^tw1YG^u4MQ|PKLg-S0@GNO4A z$PRQFJowV)hY*LLziW{5D9H*qQieRhKz}1j?|uYQ9U?afs<}44_&}zFhlx>!=lMA( z{3%8p3PtVv!oB2~oHckzH~68~-{lV`Q1>m=|2FK) zJNkU=P!b(j7LcCpMx%Ekj1dUgem|Aup$4Z*2@TbJ&=7fQAaVZVFcZt=QbnHU62ql( zfL!(@=w^{bFpN;v5ED5n`Hc@+aa<*k-z7806a2~NDNbeaY8Pg zg!3azy4zwHIr!SbqF`fp)SgzU|2-TV`{%-DAB3EHmz|+uV_k$!>ME$z60X;AqeqgX z;J|pKTn$LUb+P(n$=--%;hTFV4`vW%PJmww;inG_Y-wa*3&LEg@*FDcb@4&Lm-;xQ zygNz$xMP%PlY)*ZYN5!9nix+j>vb*ig(Ath{s59X{9#QbP)l_ZY47 zQSnyJ4kNyC*ybX!LWUhxC}7+FEMuhwCx(!nFh#t@0vKj_RvV*B2p;RL`59H^=7~Jd z*}cSQ)mCceI)0^(fqwY)gm)NT6DvFgqy zTi#NZE6e84EU$&L2KvjX?I*aF1ZQ!Z!QfkrDx+DS)xn}Bw@0&lP~F2e-o}34$Sk;M zh8X|AEd(noqe#fLnC2yu65Eoho4l=(%ePhpMLPA1C6Q4leJL5;R%$Tx3()Kn0QR59GCRY69?Sn0mvj8DcYY(gIEG4KJ#c#K-h8)ZwX8joj6zk~H z1^r-i_;vd3#NBT?cL#Oq-5>9VUl$)SXrPFXSp27XP}ES;*^ZV`@3!}Lh3R>-;UT%* zS~h8m8O>ge8n>zNStEAOV=4>9A9p8qO}e)3Q!_JuABI1V|Ad|%Cov3yl_m@8Mr0^S z9|W(wr(Yw6go@2b-q%xiJ!4;S@N=6uzQ zOgk~@487wuQE~E-n98@Wz9&nWmYDcjp{(lvoRz;_L_X8dP?4;9%uz9Ry*fRg{ZZOJ zKh6UgPqlANI?p8xf6nU{JKwG^>?hhVJ@qlh?%n6f0jpS%m0U#PUFM*4Nr-if-Y(Bc zrO2h5Dh{nxKXBPjJk{l$Z#4baFAC z*4lkmGI)IsXv}wfCq5g8?B^RzUk&D9w=DXTRQt%G4fjSv=kXM6KX3-9EM)RtLd1{& zz;oYe0}EV5g<0BJ{&NQ)D`T0d)JG$`DTmYBYo5xGKL6zDb7uQRpz3N_ci0 z@e0-H)c6aWeSKTj1iXUS9N2dh04fMxGXqEYIT0WV4;V#PXd34l9f(3{U^5_E&|~_q z5oXLC(9*y=PBe7vQjlW|)%M<+P2A!i=FE~xwhSe@ntibzqzVs8O*i}8ZlGF;Qa<3U z;%|llqh{JrKrb4RN!+b_UD%^NDKM!@YDUh;^*5e#AUi1-apSIMbHwic!Y&v>HHp`6 z;>wn!m*9f_E0OVJdO$J%lf4*vxejbxVB#*tJ8?A_>kQWi+aQ?_#qBDCU#Of6Z-*wSp z@Qil`&M&_qDxdn%T^$Lg?^Y)&6){cbz~6tS^b6+`Ef8}xsIdL%;Mpe~Y0o8sr6d9? zMIDCgXJzK6xU5YagJ5{$zZTnMb>ean&8lQP{b3$N7dL&FnuO~L9F;6 zjb{B`q^9ENOh^_AD;hd$3MI@tDP>bYj%c(Wgd$Z@rmb)Js<0P5<7>F<{e_dtc$@GY zO%64~iRpV3P?C8cF$73<&6U|1hvfqq%a*=WB((8yn3ZSo++*j9Bp)`Q;zbJ1WPlYo z4Y2Sb)@wqX0&wo==S^s)xXcGWb#$neMlRzNC^uEeHXLOS7{I4Oulw)bwQmUDndWB* z?$Hiaidr|I`(jGfN902L&7FH-q~_=CE0yAaf@6-RK_F>t98aqj4j`_FTU0K9I(7RJ z4l7xv9L^i4QuvvG*Gwcm`bvMMADS&ZRs7$i;9nQ+F2rNyMt zo@S$$7695=3yD~BpzWA|?P$FO3z))Pp4N>1>grsD-UI;x{h>0+Ut5f|+%LfP8Piw0 z3RS}lVhShHNA>0pjh#NI=lszO2~ID4kTyeO-uIz2FjD|pAy<#~VC_to@5!WDow}aE zy#S-U$QXHfjoaL|di}IhO_QU%Qd5RDag?;}AvM6b(B%w5oj{|;(kE{=P{pNQgZU=E z!3=AYc&ig~x`73>l!aGfDU1fTPc$bQ!Bh<34+e)p0Z>C(xMvW#z~)E5Ns@zCB$;%* zSrXt!rRh(fMgWxqtn`V1;l8-6(RL}Lm`pxmVwBOuW{;)Q;bo7&<>hAC|93lC^k7+T1(0FY##)we!~x8`ihsf7m8p}OY+ zLy6K0YTF7@7bn#e{nZ)FRP^jhaX~4V4`}k(6-a^(`vl1qboHQ-jKdF{C`2u%>a(z} zZ|nA@Lk!aKh+l`hc}WQK9R-1+7Y-y60nJ4Ef+n;V1SqZ$WLn@abYLTNplua}zTC1F zaX^CDe#cMB5H6l=igOOY?5%6#b{EXHUDtMZoQ`eV9ox3;bZpzU zZQHhOn`dlWU*2!`xi;?l4K+s1RdcRmqL%g}*j~7_A&o>*@K*9S6=cL+hisN2wT5oe zVgDiAJ{P8y67*nqp_w?VN8u_I{f)zR?tU3O8;Q!Sjha<41fguIh|#81!bTd(&SS{8 z5Ho`x?DymBR49I)%cgk=c&HEuBXMn@-i0y>`TnHFZ)n4AHIydUN`6=zb7Sae`H<#E`iGrj5eu;W0I6m4eDy(<~1C#|kNS=-PugRX_4QwcNb zD|)L(dsfGi&xc+4G7MZOmD!=FeB2Qk3Gxs8b3XDx@?QC~-l1FxSjmN6T8X7;x0cxu zBPfJnVT3xzt*stXyqgs=j__CV$;_61^0{EgI*$cvz8|%t#-}_z8arsy16_RiwQzSB zsU9g{50pZig^o8ge2L{R9p2Ildgyewz%t{|Mv$d0{xgWa&dwIT(A2&WX5eYAufU2Z zKPGoRhm64S?3stqNn=JN$Z`_aVP>J{{KSB7lAttN9E6R0ce1^uHt$!1r*VfXc}vyz zcY+G-eQ|nV*_%g*nA!4v>o+(ExZLr7sK5Vkd>Q_-{m+%1ml|XCn=J5M=TxcVMoK9C zzuN1D+E!^flMdt6ST~gII*lmzE3+jiWOK5-JdWc4*_CJne;1V) zc$a`w&{RM~dH%%WpNA_z!WJjHcelN{y)%Sob8&ILUJC8msh0|1Q6(}5!6=B;M4;Ko zW^*MBNq*dK2&hoK%7t|Yd0iGPN#DL4gt!9-zj2x>Kf2UbshSAbIEkp0#V=JAAa|!s zzKDmr>y}v8`%BBm-;~qe813UNAu;sFntk3YA+9h~w}4U4r5eJtqs|wXj6zB`pFnaa zQ8R)ip+>udnO&Ho)N=PDYQa}tWEP-E=CKu4UvcIw7zNa(ThplqBMh^wJ$~NS)sZLM zxJL~lZole-P=DZhLfbT2;Gh)^zG=~vFk}m7dNy%fE7Lf!rVQGq3LLQ$$2f+N*cFst zuX`n=KFItM`I(UU0Xsi@B_JSHZf zEF=tTIZx|ESktz@b+wYPL_bi3PIu}xqkQAu-=Gm-vSq>o`PhGH8^8)OzC@eBfj zQvj-SU#wP;rvelR&^!bhh-nhdjm>xeNG8L#8~?*R#;kwhTKsp#B{^80Kx=z>=gxcC`@WDyA;(DjhgBG7%6PO zJOQGl$ff>KTZqU6$fVoSaLjhQp89wC{Wb-9Y61Q+V(5jw+>;6ig5M4CX{t3IeaaL# z4SAfL*Tyq?mmA+c*+!^+^L&2FikP^WHgq+#*#(6R5hhA;*9@1^%esg(u)^62I3cWk zk3LO3U@w8=iF)~9I`^Z)ZNdB)uC$Z<$mLwf*al&%-)sHSt3a}>sp|MdaJGNl@C&G8 z*=zYq4}T#80&JlplPQ$aHTHL^T97=I(j{7t3X1m&7H{Sn#6)atqgfYBn*)su-z>}e#CC-b0#fd+2WgWs2-vGA#R+52*Hg73{Ees6 z>>?OUBZ)p9Tw*U_NL-hsSIIvP z3WMxW)jb9wJ%uvyF?WS7AZHO4<>JmE^R+#uRBW0kMk9gw_G#pqQRNJeZ&l-Dw-VI; z)%Oo2p1zYssHBtd{a(HPK?tm|5I0kJ(~?(Fh8%*nlhoooq2Y5``{FA^5hW&m;)W(K za=|K{K4YOcJ!X&YO2L{%#6`dmgrnYwnFcpCgX4?_?lhGviEj}P4zyfX^BB3+tAys7 zz5UtRkSwdz^kR0V`y)El&g$Q=(=ag+Shpy@El4e66T|B|odRJG%*Ia~bjO4R_9A)O zhG?eL*LSesyq!< zp+#3}-*rPN5u7pi+*4W5(;Wu*w<9FIFMIu_ctj2nnn%#uC&4Sq50v^V5$O-lb`+if zKhOvK8nl#$b?)ul`=xraziHS(*mFi{QEj51EgKN1eA{N)5&lOBGz!x+WSAhICQ0Q{ zz-*baQLMx;4rtaz-E0_IZh{7o?Az1sDH~%D3EM64^B)k*G1>^9nP_dMdV+a4PA$3b zOK{ZXqaANCeFXw#2^gy>_M@lP2H6xP2unr6d>W6bH-jVLiigmlG7svaWel}#S zR1cKmCE;7t>ztqZSD1AGRxBN(X!j^T3mAxB!xg@(h4SP6Z4OvV7e^(*Gl1gika0CJ z@rH?o#Ku@!KcTE{Y`Q1S=$y4d!*cqc4faMW=T+DUg z(p2mdjVR}mzLU3|O@mq4`VA1c&tQqfd7a&s_O7ji-~G$yjFCM*Bl*BvFqlas6f5A7 zVoXuoo=nJFuCHDD2-cr zcVXZuVV=vNRV)?No;2g`7MC%M1&5@Kqy1R&p5g+qGVn&Vkq$E9G``jLTuD(A@nB{5 ztU!vtf%<71nl9rCFXA8GrndSWP`a5#}oBXf~pQ*P=fKo!kQhRtBo#GW11 z#3@Isq#WSwcJC^yY_`dPb#APg@E?NXKU^RNCPvo(^}A_G zV94Jl4q4XV=__N$r+2D#udg3hCt-Rul3hCSkWr9AUSu*EPIc#7%!I1* z!&xNE*7=D5+AGyew3O+kJV3rSC_N!ar!+_#D>Jf077f&6Eb@aaAk6|H#p4_s zCC#GVouGW$sTT*NhDk@mrjZ9>7|=zlq1vka$x-2%;Ro^K@h7)hQbU_lC7tZE{Y$~K zgdJw?uI`(p|Kx+-Fw7#0Gms+TuFlsdQgpZ2}bye{4eA zNGjlzoETX4>Q7%C-m)Rx#JPk%Bqh^mXV-u3)lhv6&wxy`&JHv(LhDVP>|h=KZhnf_ zJ&>xq*Ty0YTxa*v-d&Ymt`nS7sdf$6H(Fz|&?Em?z1pzWY1^o}KC`Al9dtxmxAI)v zo>8BJq{`^{6jXk1+R*lF?1~zwc>Xe5^1LvHVcojKC%5jgY=OD`b7K;n9%0hm{R|94 zWBvSCuWfS^Y9?H#<9tiPjH*j3}aF-@97Gcslyc=Ls9->t!A(gG_X$ph_jCbDX>R)QX zH2MqbuXr*tm=~|~_k6%kF7Q4utUr>WYJ_=_{*GHp%L9aJ8hCT8L;9+u@x;bisu3Ud zic}uUH}XXtR%h(nwnTr85VUNNc895LHRE)y9Fp?vyiGapZYN!KQ*g5o`J-VIj1U}9 z!~3>L`Cj zH?Q$HhD*JW&o})eWVS!f9Fa~3Y(<cpglyjtzp zM!ehk{3+w;d)C3h_8^CMb-IB~0z3|QDIW`YY%dfT)M;2}nAe>G-^o=M=c0bfUDItB zc9fG~w9-`K&(|-eUVm1DPv;KKV&$r=yiY%xNdO(Ah=FWMkr3f6zQlFGnuI73^2Kg4 zt@WGov-z^2_Wi6enasrR!P$AgogkNxlnYS`&!dcTX-k6OFR?WdKqxyz`}K^=R-k}nH?d$sKoMt+h$2F6(H$OZ`*LN;78r?f-hIsNMLF%sE zQc^aZ;R|@>uX(@MTZ0{_XvRTHwC$P5L-OI`Abm_ba2EzIz3vBx^y>#-(31aUFL-jxMi(5P8vA&czbBrI|v&-|( z3?>N$5XvLSCeMTvxOhMlZ$c7cRJq(f^wh%`?SANiUWy5Wr`7-sVh`&UexOI4#JH?8otZYO@wTVI z;T586%bs=r{YAf+<9R00>|$&Z)DwLhe>2};rqKAL{l&!bQ)5K*>TF+AIw-9dct*Nl z(>3J<$G;N5M&=N!3}}@6(lWR1{VZ(t6$c5@1QvVx0JHYKq8hy!c~F${V5Iin{Y6}7 zIRpbafRBec3YpVjeqtuly7(EP91(^}G7JD@Jb}K7SFqtK9|Kn+9U11`Lg+9BY#~@! zGef3!9b=Xz=>_>+Y2h|-u-l)fC5DE=-xEeTM#B5Ou9o!%4w3faGv)-PezreVG+sBj z8FoJZ^r-yU&Yt_HTYC!J{cRrW*%(kR-HV-;Uzsm6b)`9bV5fP*;Vs8s9lEAKFrLER zVFI@#6L&f56(vrLV3KZP<$)M7n8FaP>m_o#*?pAyr9~iTOO8r3&~f6i`YXE*Vo@>T zrRC!SO7}1jPK=IH86Mt(N3@KiPsJ?_&W(m6N8^@>M?Qo}ae4(rq!0wGAO}5Rd+~&{ z{aw5fww1xI&ED0blx(vFYYdWZo83E~5IBVl6qPWR2&Qm6W^C;H`djezTy{33D$BJ}Idt`RH=-|%SJb`W#r*rl% z3IY3esvf@0lJMM3UHH=^CTw1B82z&;$A#26-}G7~naQiQ zy<=!o6ZymnH6s6gu?zr~&)wtLdaSp)`~IUR{|kCJ3(neX6SM4h=g+wIQ0tx{AMm?O zak~L-uZXp;ZHZRb$K4zrC2}WQ9wo+d@(d@p zhSTj2K8%wI!mI6*Zu9aK?S>%?Ecd&M*@PI;-S~OH;Y7_}{{4-d@sSZzeJQwS{96E- zV>p~8{-S$be+0)GOijo^-R#M?Hk1l{pafgCDAr|Wc$pzQHejb&t2OceiaNIc@DSrA5%u-?)7XXN zvRZ^_t^WKdJ_&`E-P4OWBz{PkAYupB@bkmX_2vTQlrU5;i6;0MR2*^py+01QP>G(4 zYWtbznHN?U?}LNu<=poso4ORgz8}$V8iLNs&fV$etAKj?CZ`69g6##66aP>yr(zl; zn*iAAyG{}tkdBj7fr(onM-0rXC1iVwn}wh%Lyw*9Q&QRwA7^dlPo=;lo}og#(Vaur zU)>cV=>s35q==ksr}m_28t#Fvu;Ks$*Kec)qvi?X@553;>LO| zW9>>!iUcR_`YW<02!HSauvNmVJ}i0(L;Lfgj-a;0#tqe6?ewwmYSoVjVxzg!h&GwG zqI@Sn1Jm3fyn(Qe_${qhES*rCV6kg|NHBX<}*$KiTp z{d%hRMsALV=-;-X8|HUwB;3mTou#YB7-#0BH%69>v4K6irVA&ennrPkkL2hBA4(anP%&J;laR>D50e_- zDll0K8W~chg7^zRs#3l<%1dCq_U{f8sEOqzWgT>1+Vrzdq5azL`VWpu1Q-1%zZR$V z36O%{qF#Bx@x8587vw{-Eq%XtnM~!pVkJtLVsEOZ215JyR#W>iNh)2|n3Vd()-!`8 z8e(%>IQmI=F#*op+x(k>EAqcnTlT7ST$(KA$suc_L?5)kFZG@BW%BVy*zwt;sB_kY z^vgD$EX55I-BlU#t_=!-FHlhhN;^P@#5bvi^n2;%m>9j=@N%4VE zc;QJp#TRgR2Z%j_Yn*SpjWeOjw=F)BBW%EeNN#*4>gCPJ(%N0I+2OvJCgGrk)i2x6 zL=c0Y3PL%rr2RSx(44z~!EzrFk#@mqN*-|xi-wFL$uRtsleQ;};p%RVs_7trAzSTt zC9~}2N?7hc)ZJu>=ySMHHPzaR zn#Xdyn)9FYL_bCn{kwmXz>Dc;kAx=;kPc(ylg{fWVvq5XihV)JW$@rJxa>!P5Fi2V z4~o7804Wh*iU-QHQF9ncxRz8|>3liJ+ukh^X(~gwN56H#mUsp}vFwpzlQMKAbi5}K zb*Q65lqe%;;Nof+sxu-&=sSj48l!xQEYsr)@N2>3fAK8MmZvLB- z$IGHs(Xy#kz4y+`wTv6!xIrw54*7S~Cd&{5MG%t>v9@ALr?wwne3w|#m(mDGt{kKJ zr>kl!T8VQXlGh4#?n=EeBIl_O>C5`Yu!E#MMG2LtnTkmUt&a>TEL2%FIxYj>s851& zQRPjhzrv}Kx#BApv25@R@FuRc3W^ia2+Qd!1HaAqffOiUwF>Si$36NUuRK_za8gmT zKzt^5k#}*#QtVYA(C28aw2me>g_Q*J99P}}y1IIP56i z|8_AxA}RN#g~`anIoWBO;x(uvX<~JVG;Q;0oo)$<$r*ZV<}e}**2Y-_(V@Cr+CIs7 zfGvUe|KzDf~Nmu$~9X^-pELt zYc|&A3<;J_w80(t{q=lpXvq}QrTAX`acQkor&MOT`nFr$dVNdtQ-ev!%2LUOVrQn# zg2%%~qm_71<#mGFreIM`1p&4YMrJL;Jr36df4h9$fvsoildNt-fc-p#AC1eQ?U3#0+@uEn2^)Azt3c)mJ z0VH%Iat2HUZB|9I;e|8HK1k(up(#-aW2AyU>wP`BSz zYXcpm+O}gR(}FIMOyY+o(-N|kFF=b=tqm|a@Go9=W?U+W3H)LgX#l4QV_<>gTjlR> zSAq(+bC;np-mZQ3*Q}~^I$ezR#2`>$JF2WiWTG;*!%0}$+A-c37Ni%3lz~k9tQ%|Y zJn{yfEv?y7NsRkz*Ar7-9GN!D*KL0%+>*bu$;15YK1vSXobUF|N>r~u$ZPeAiqc+8 zDM=cpOTwzJP!q})^*tNZt5}duM|4jZGVk_vpI2I*BOZm??UJXdUCeI0MJ@6Q=q4_# z*%9`g(#OKamHIJ_3wsmo%3H87?*Z=>XgyuI37*6v^J2w~80y!l^xjN8KDQI#Jnh3d zyish5eKFmGdCx>c$SZ6bQQqFS*Te(smh{>#N~J^9n{h~XhDxsXZCJu zq;`(H??MKnL-iXrXkpJ6*2zT<4G&3kwKZ@rd*O4e4ey6%7CdKr`c0WL^@qk;5R)e7 zkE8`ge4rwK@kAC(fmmqtdUUpTH7dC!m~p0-?UEn%^*dfVH!oaHS4K?HUs&4?pNzZSG~{+J?B7B_ zshx*%hzr~ElO+7Dvf)3YWM={tMuQgW0JD%FUN znNl+REk=t3bL3#nV$kU&p3r{FFtIkV!l_GRd_Kg&i_t}@i!CD5At%9j?4)ff_il}F zi9ay~IiTk)C&#f#bB#wh@W+7|a%#+iw@8sS!|F?y_TbPw4aGQU;u>`WRPtlJT(ob$ zGoZ@8H%LlSo%N-*MGAtuUg9t92A5j>uZ$WuTPq&C)ZIUUZ1=uVZ2F+PGRXdRfA-z< zHG)}7)#$G!KzpQtg{)MJGiks+E)%))u%Xgl8YXQQhV}HO7hfx;9CMZQZ@5({by;d7 zKufryK$Ag18TB|0RBkL9;RhOTUX%osW$>g8QwMS>)X=*7SKP1JD>Q%N_VH0ZL}Isud&)oy>(0p!^b=<(2N-NWb4= z52C9?qUNI2&1A&Hu2N&I;b9C4-tYdgB)h*g=h>{7h1*4o&IxQLC5p=aGK_8YmjJrPzmr3F_beyy~8je{e5^G z+NmMrBxlG8ieHl&Os9^kH=DnN7&x_G?Ahm(2Hg zJrnJ>Gb6}qQ8P3kusszzA7>@0fu=WGvHW%=>YQVwAA6-uMOjOi1<>A~8+yK1C#D%A z)QfyFpi?D8fKqv*RS0# zLtls~H{GW`YKHG2Kbe_X$#1OaKgzcTt5jB1t*)G8)*Cu+#B=)$ra-W@j5TqlO zZ~>4SG~H|=NhBpOiv_(Ut%>Ahq}ZYQmdTeuCt|7hTL63X(_dR!}b;0 zGY!dI!ZExQ{RYJDo33%DtZcP;@*D^XB5_Pr7Yc%;fBHd~3|77C!O9U_&g zvmcl$>CLwjFl&p8)9)|!rpr8+pZ32d2762zzuzn!o`Wkm4Rd&Y2G-5?rrI2y$BHk) z^l^x_*8*?Ew-IXnktl{YAFT*6td{vTYea11??FowmRiXMnEm~C@Yg-JT>0NsPA4x7 zNkXl1lDzju;)fy)L?`qL64qWpS1}_whkhy1Gh%%n1|6a_6^Oe2VYS8NZ&y>@(PaZT zTwlNfKID@^Gm1wlidjAX_EZtN%7uJqmFz3FIkz5i^1s->dS-%L#kopGH)|e|*ZcI< zF$1k5?IsSJH6F)lfH)zTm{WBwbC6(iResEQ!E#Y)PM@OsttxO-L{J(K!^`1c6y>MNBJB}Lapca_ks??J z?3ZD3E*R?b0!ea)0>|TGZgmU_kCa4*L*rsAaSWW}$Xa+|&dG5kW#N1|aw5SzMulz? z7-i|@1%jH-r7RD}=7NTMuNoVE`CPd5_y{S`-l-Z>V`|2*$j4Ru6U!f9mCM=xch}99f-zbhA zrRR?5aCL<9%SWDITeL;7C?2CpxLZ(yT%;vR|8BlZHxB6%a2_t5)vY{SI>cJS9Wwy~ zvDRp+^m&8|^`p-_%kJ7W3%AKU8CbeEJd&)0|Mn+5D~407tvuBW{V_xJT0+JFa zc03iLWVDO-@nTlMg!#psvjf@c9JA%47d6?c*V(F9y?=23O$yiYVUi0xpSp&5~3=!lnx)sV4tY^E8jBB5uRIWxZ)3!cFdGa8LGZTM^+)=17fP>&bssLl0L zee={4-P8=41*Vv-JNG*4+7mNq%vNu6J<1_qvs0&QeAw%o z_k0^g2mA=n!(BKlmjd#8n%mkZTKuj}Y*$a8Y~xLuyRx25n);5HW=3zrLy!5_+9msx z%lW;dVuoVRL)t9K8ds#XPiKT3yJ01@V-^edf9jYst(QZxF&!3|%$B}h;s-vkN}2-< zs@+2|aD{C9w2ntuPyIEaIP@Y__A3!})v7zNg=dl4fGt*^!4w`hsgFa$@-_lV$qksr zHKzFO&-TzS*uuBd8LqggvgTH;)>MX$J3n}~fMOV&d9*ee4#Jtd>whz00Z0b8JAXxb ziFuHT*S_o>Q;sAR#0beTz6+RQkcXDBG-8lM1r77+2NQpP5TKf=H?LM>>6`@h2hAzx zrXDUVEF&fvEs{l*gkSQVxZZB?SZ~XvTE#YE1aG5S#Bl!8LpaZL@75o}h`3VGwTa+S z*lDRd`K;c|EPjG*7NWe|YViVpH%2-1er)nX-qPeno;*-cEc{o9t}7Wen7L;QP4 zOpGjdu~KL%5kP zD^J9}9Ocn4hK2l9-djY} z<6^d~zYNeifXg|QbbjtwtIbtueD9Bs?3@#QSLGB6Z)Jz{Y_Yag^vxq1DLh=4>7_;E z+!zuOLp33df}vti)NC=sWkfDf1R{2N`*}f-l^aPzs-p%dUu`U!hLcJ9*bOK0rW9Hz z=3%SL*g``yc-1tJ8^rOw(RKQ)-1Ht{Pwg?m>pH1-b2fc|?I$j|!w;YS?&38z+k16y zX3eS5M|&fEt3R&mOaCtwFpS`}Q^Q9| zXPCsE_AX4pJt%Rpnq*-{RhC#-E~h0n0YYpF)Y$p@mf02y5(*`LIUb+$3l?mPd#hx| z5l*b(8DpxuEARB}@p8(hTb}D*JVcqB^E)jg7h@zMrIfQrN>_U6X(W9$sn3>_iNEyS zWv5Q^xtpJ^h;+Fpv#usl8egoUO1_7p=`%xJxOP(8RLb4U55mEzQ?UdPe(K z>MdeE;xpFK^1fhi;$zyQmyY8_dPKNK+8E-J^d8{VroH@JG5+0L`$%=|eO?tt^eXFc z9l(TraWk-Fe;BnRwN|LsT`YC9L2T!RX7khVphfeYVpB(6baJ4pNJZ*~1A;+knlTbK zQRtyvjJ9&xSDZ?B*QISo4l)V1_5=lhRS{ z8VYyL03=)irhq=sg&2!r*hSv*nv;B+VZ} zG*biBM({?6Z!&*%tFP%d{&r5V2pR}E^}+|p`p^}`Y-6Tv(6Y4cM5Oxah|~yYD%qf6 z#>}Yt^C*w@%lpO`$4%d1cp(N=qsT+_FpU_NcjSt(Z!v`;nkfd+FcoF zL%`k*FNPU(&Ku@Gl(ikN9vT-cS+IE7?uvw7V0_Q^J@2lE!Gy#|(%#PSI1g3SY?8?X z!AI&zDBsz3ZqB!0yTaE7lNrTC!+~!F1Trlm5$f=7SyrXVf9J+^C%Wg9JfSHSR*aat^6+E>?0vp}^ETgN}fkZ0K!9Td{Q? z!g++6Db%(uokHE;_^r$DBfsOF;l!bd#Q?Mi%+<>32YwkJ9!8zphx-2px4>teIwgB4 zR&XiwLa*bi!E16it@dkDkzf=JaLMXMyk@?k-*u2b2dvwq>8d}7fsw)w-@NdqVS_zU ze#b$FCf@0*Bipe_JhQraqu~V~>KCTDpg-}nMVbzx2n(Tydv1g^;P?CEw-HA-z?yHQ z+Q0dx`jlh^{6C_-C1Mfx3gT(J&$u++9XUNLv1?}XvuQ(MyYcuO#e(sCgrOvL1DTw0 zzJBTmLx@{CNzkHf`|H5v6dWt=KGVN$v4nNR-$bYt8LBp>&LMU}nGhxoaQe%X3wl7O z&mDvwZuig2=c8ue#d<>QjHEyf%q%2Z2z`MBBITlEHx+E(Z)21KW9x+Up}U)Wi3A#j zXQw3gxni7TPs7q6mK_&R$P=|tn4n_xKs9*qhtGc9C-fJVSAi26Bw%tyF?=@}Atqg$joql$^T^r-K=)iwNRUN-pfKrGH>$H!csAa z5R-)JN%ktZOhACz=@$r#%cKXiGPwksrKl*3b2z3?%i4o41~Hhpo=5*~7($ZNAcH>o z^iQmbq+%$c?=|q=iZ}gG|GR)2CJ2AIl<3@H3CRLft8O9N55}r-X4(m7UoMVjGV6im zC#NH6&~-$aSFOO3=uupCxh`>chC*28Y7r!elj-#ad$p*xeVmtI+xT%`OxFhL4(wD7 zI}2-s7mwAH1Zs+xut{E=l*FIt9G2caeNNHOa{ZfD!^Ictii-j?^^8L}=ue%vN#l7U zk@ zxEJ)m2EBjJAl%#miw`}O{FDZA71#rl4h5Si2$mTvTzw$fuUEs%JPt+5RF*Ro9C9=% zQ{d?os1L2S-038!C(6v2WGM5*dV@TV57<6-yk62~=^d7NQB}N;{PCSga9&Ji%t!4rKQ|1$Ry=N>}pkLA_fN3XnYX z1H^_jH>q2aGU8$MP=SmAh1CR@tC8}vAvy)E(dkaoA|V7Tc=~iQl*fr) z=K$2It+Sj4FFa3hi*G2Y>hQq+t3dg zXC>!MF$?EY;aT{}AmIDy<@FEL61NE3>*8Jm(EH*SuWTckIeehK?Q-hlVKTl+fW5F6 z{i1y&?$c9dS5BjB$r9N4uxX}IJoelUUy*o^w}DV-Gk!Q`Sy(95qIMTdwCCK3vpqmc z`G}J}SSG-ZAJ--P3X2_5%2k~7b~{3lsO7uE{x~N1t0RBXI2=dEp!pGO@{_mufY)^QnMuKR_@Xj3 zJ@D#H`5ACmqtITFva;iO+r%(5|A9n)$n3L0-Ak7lnk}Hg=bw3vDv@f+QnCG6uYEL5 zQ*<-uG*r*ZdOpP=dB{OjdHLM2Lk+RyhAjX6OvercA7lR+o-y@D7aJW5q#U*~^`0Zo zkvhi1WyT8Z_qgq%aXLahTDoT&Mj}B?;(baFfCYxI6x<5a9IR~f4zwWw6}P=AiM~Es z04tlD+H_X1Q9gSKVxQ8ea}!bFP==V$+n#XNc`3$hX$Y?xii}Vc9`}M3EHA*^4FOs+ zeLbZ7Q}0QDB1L>GmsQi-rQz#q>l2Q(!iyAjTrJP@0(BS?jtH+KtDIV3s1L@wVKEj>8TAQ;I*Hi(zGdIAK!OTe8I|-lJ?cJ)ZQ{ z<#aE#R+^#ONKPXFcm;x%o5J4L-s^AsY=Ll!aQxbP6kYVDs6}f&Xb0x(hG7cvuOM@0 zi;)wvqz@VPP!7Y!f8VJ%fTxdurg);~KBmYho(B@x|QZ7l9sK6(UlA-%3s z%faCKv^0u4!t~X0o90G;6qVqHAbd_bkTrDzh^yVYIAMh1d>$H*$3_Y7nAr!A$Th~k z)j;{QV_5!oHzn-3@;O)|%yD?Q`@&P8fkH4F_WmBU)gyhloxOZ4Xl;8hMrTJQV(#T7{>4lrq zNi-D#^#GF#%#!87z2>ib!Bpc+2j!yuKS?Wqb>AKEwa|8;ypigh@7=@h`8Cu=g@lU# zRNUIBE7F!oq1;OPZ>yayW4*b)z=k8awSFf}{a%O_p`mQ0vbMtvW?&U~*Ffmv_-bTp z*yNBGjfZ*IgZ6;V7*&z^xQt955USSuS@6%W*eF?m0JPA=NK_CH-`GB z)s{=!YCj{;+L7_Mf}KT95F6#dx!Il&glBaNuP}6sOl-}0MNV@ub;ZNbL}<-H2y8G5 zFf);Xn7EzBv7Tx!X;n_Ku>;4SYlu2ECK-r0_Fs?3qrjM^C108vNnBq8#%3}rQH>~6 z(8!}re?yVL4C+Jv8a7{vn`ig~_0Q(%D3L*vwp#nm+hx3BUmzVN!c>k9a&+(OisNjc zRKVb@HBOkF)SlE9`5cT(UWd%zK)zovQ&DJ*<|A-4cT2;V0L9WWRn6q9~vxfo@<1w=U& zB7I@xdo}6etw2#Rr7Bua*$D#vlZp|t>;9Q>>$Xk4{xfO@QZ(V(ye&|N>Ld*4L`wFD zW@d>pn8vOg1y$1D6vWcB3K0g9)?+6ddur8^mlB%Pn6d=5RB`;W^840~vS!~`W&;He{dtT^~F zmJumdTz0-1JAqQpmoBes96=!1T-s!M)a!wvPWlXDg2X`sI2G_jmCR+Nk7{hLmbJj~ z;uxSUjt&9)kPd(_jslds`=>yR#!-2T!OkKQMW2*x?pAhYj7>1R=&-S@ARn;Yf`Z^K zf=EhgD^?}A=0kUdqB|b>S@!mDC{a~A>-s`;DKaGqvhxa#=pL{j-B{~fT>D>YLGlO~ zW!z>`2*AxizNEh;SOvPSua-XymyZ>vLEGhE;?wz5QP1`bL3O~V<>dNFHMssc;bK|3 zR#OxC1>xhEBa;<hGmV0)sJs|S8*ws6yHnoD4ie9rU5wL97$vi>Fmod zesH=lHCsVlKE6pgnO=Ji4dpPtWmFC&aaDm~(9`)dzpm3lExDz@sM&h`iPC2(lm({7 zVMah!5+%qb+dHnl&442>V_p$Z^ftJaSof?UG$E|7r+bHyd zeAKurz%UGGcs~(FOD;M3$9}BNFu%n%X+3$5CDN)K!EU=HFq*0G&dD8R2TmHM!2E8i zsqrrjvpYt_`G|P#2+M*f4Jd6SL5N1mr$dav9~>XuH-eqXTuK({j5$gCAC<4&S!BAv z#XcDrez<9|JQcPjV_b2voQFb_+?ee(|FBx6+8EkGW!Y2CzjYrEMiJe-$G*_1JSrf= zasBDNIpC@^Tq|R@MmNhCV?Ed7xe!g6n&k6C)zhU(x)oJF+V6KLzBOHYvldY{$f!1c zbLh5MM<6Is?-m`<%X!6 zZs8_k9T9U*ufK=W&i?h6UDC^N6*UsRkko1bY)?jJ=W!Ax0U4HgEnpd`IWVIm)ue9ORSNO@r)8` zv=B*4t#o8N(yTQf5H?hdkgV!8qX7+_uf}M_EZp3`ohO#?$WTPFt+yCmnkSazpPCbh zDQo*T#U>VWA?X+3O`wyYlbaVEX-45L8=Y_9HQvJmQ%m<&&Qr zNtqx@hm~qnv!{9O!CMlgiAG3_k1a?KkusxgX3i~ zdwg9L!T73TzC?rJsS>p<4HKpCJ9MEvl&|S>-<9*PPcqc?<)r969t&SlNByU|A@^K9 zldW7u7}=wVheA<#P7$xi*^nz(%&0=QX#7E9H3biLESLlrKKJ<&!Cl$X-pp@JP6b&= zO=N*-Ad|8(7%gB5u(qc^%#Sw$QGG1};!*Fy!jgCDVEmU~5=gO9`)MKq2sch(e3)WW zAccQlt8MXOqkW3~0318-%e2~g4<*pDmRBhye}wj2^q-~nXYhD884A?0G+>uk9B%J_ zS}CD%Z_L71>8EHDZQIwBq39peG4X8ci-?`NT^~9bs(25EFgeqf7oTe^vuQIGzuwu{ z&Jaq##9tjPuLG0HEDRk+o8de^qWKwO-)I^B%-=R1*PVhfS<$}C@2XpTDO=`#DOY;8 ztJZl(D{>z=-8tG?_>4!8Dy@?zpx|#bahggfd^r{bYg(D9H$mCV9H|VVkn>nigs)g) z5Dny>K5m`iL6ao$2$+U;@HRxTF^EqMsKfx$%LIc=Tlml)zo4nt5G0)<8{5oK;p?$x zHZPAb1>Q>86-u=68&3CU7)X}D1J5t_LSp)`+!}=?KpQncTHf(cD!zN|zQL<7!aD!& zG{pWN5vQM}`2TrFtw~KXp+E$&`?+RUOjK>@vGD(6>>XosVZwji+Fk9cZQHiF+EuRF zw%w<;ZQHhO+qUiJyvfPl$;tmDdw-id^JOw0CNsHzb6tI$cAJM-UPeZ45}dI}F!{E8 zC}Vtl)&GER(^C~9L(J&m14r9CEw0L2(p6>Wit{-?Nv5BZo+KK`|^T~I>vJUd}Lqb^7nhguCT{!8_4%}lfUOyR%zCfEYczGHw=(&bg1(WF6_5bLmPTh zIc~Pqv@k?BRpqBso*=}z6>O<0+VwRn8S~3dGBj-Tj*G8XtkyW+mK>0XC2_^UH%c6k zYDs+WWdI<>ab`_QJSO1@^Ajc!My=%+HmZWevW15_iw6Tk@4mMf(=$E}seL1$wOAjZ zRDWzoGoLxX6nQQlR*7%>=kPoAuyYL5mh}2dgGS$L7_}r_y7czrU$_Nbb3FdwWNp3H zFveyJzQA(*XCX*H#A|gBm206~h@VX+-A^tcHC`c0r!bj7ASCtDdx>e&dGKGD%JM-* z$W~{Et8v!myt%V`r3im)nc!qVM%QF`&3bHcjzk>aLWr|}(p_#nLc=bD=zs7CfTOsk zI#W06A)CY^X3UX14(8+0BIuTFxl)VP9;fryQext;KG@N#PO$rHU;`Xu#+F^2XBOW{ zUiB2|ms@mBc`d8*2XU%`mjhE&AHuKsz)%yN7xhDBETouPNV<1syNg|Ig&mhO1OvrJ zta)2f^U;G+eTa>d6s~Te+ji7*>830-4>H>kKvYTV`@OyTN^3)|LgoJHe0#8-jZ5Ck z^{0sPmI_E;Dm4%+>teu`B+fqzg$7y1a{kW*8Pmk84^6(PXhfW__6>ZW`L@IHvPZej zlsMyFh>Lsa9|WDT^Jyixb%6OE)-?T))oD9McP)lcQpFm8QBO$7E|rE!kvR#a7y5Te zAQ~%msw0pDmAuQKzlahp3SKI-#*Uh%4^Fe_9*6!1q2v|Kn7Eb9$82=-!D8+7I-Ldi z&(~!OPa7!tDEo$jVR$wF`%n2+lZR^Cs?E+R>+xEGYix9FHl&(H>Lg*?zRt}>Y2!tE zi@6NE`}a?#-Kr3kDS9}ZsJe|TN&*d(#i3Le2eQZZb;F+07CPi3&)E?iuJNNtXox^r za$B%iQwbkO+$_r6(ylPc23R+l8flbwkj&F#-0$Z~s zgxX-nr=ET{_aao%`&VX-+2`rahNcG8ny2&UYEEssnwx22eOoHy=!?zk+S0C&SBHcN zg%PYXUt$qaMBBA<{zChrS?h&Zg9*tkVf|RGs00#GI*N^*@!5~EPyAIBM`49h107)@VGv-DaLb5(KmEWDXL0Dj zJW0*J9CVKt`rYKzDgPB1T#S_FeiE~Jez@3g68q+OJ~+BIlmdTztmC0=bjZie)D`!v zHrPag*&vmvr9n1Aw0oqZT6J3fRNd*r9S#xNrTWs?XkIXJ-d5yqsHA%m|EI)v!C)xh zdRxee$W~{+IyoVr_$Ylcev+#V6e(%6`sCjv$c|Uwi0#W~NW!xJ>0?nit7>j24SP%p ztAy`b(2t@k*J`MNgR#TZ=9eN^+WjMa^wdubqzb!HHEcy{o7AEFrZ?G;W~ZCjDFY*} z-?rVI`bN2^e*)0mpA=nuGrK|*B+bB${pq3g4VdHbLu|)h zxs<3ap(tOcF*SY{s=si{ha4;U59L2(RqI%N$P-Vf7e5Lvljv2=8`hqSkl5+?Ns+Pi?gVAgDPqFg9Y#m?WkL53O@C*xxalYC zu;U({O5rH+0M1b07EVymk~WxFnRhPl2FwCQ;<^CVFvbjl_{C;tbOZM>=k?m;iFZXc z+!(mtq|dBW^h_@^3AWZtids+=piRF{Kl*H;huN%;yGc8Sh=w8&2#|-2^9H-ka89M@=YWOsq0MoZd1o+jt6yT`wNbjkEx4mGqNV}Rk@+DlEthtE>h6MI1 z9inv)Lpwmr9_EIC%$TreEezQFYu+sUXGTA)d#{&-EL%t@6*CiU?wDK=+Ym|7 zz8TWq9+b-+lKTx}eH}FG>Iw`1Es_NRswBi&$1RkOo(ED7&0RPrBZ9}5-It=qzk1df?pWOrqdLI56qh%FU6No%*-DB=A#IWE< z-Z@wZcjmQ#X`z=HM(UcE6C%pK$#W1y5Ar@O=(z9Pei;B16ZntiFTcR#L&4*pi60#p zYoH{{+!TW0DM-^R#HJP)U0(}PpB6T`8YU8^DahQ;mmAUC3id++k~4UKjeiLvC_oz@ zChoU7IEWtB&+zQ}6ztXB!PEsp%lCBrwOe{BhwNsitjN`s&1It;w;AQ);4(;C$CJ@nuj!5JJ>J4;)*X9wu|#VNAC z2a*;ztqoE_BwNQnA-JqJMHDG`Klzp2M*!mUg8A+MvIYQtpHAM18=N3}Y0Ux#fLP3# zAtfadF-w=dRKQVcV$gdK_r|+Buzy@0YoK^|U0WbMsYtuPn*TQWYx)PNk_P!}_4-Hk z@6HYw81h@g8pg=;wxnI_o@9IO5IXXJJuA@ikxr#x(`h%Wq1xpTSfO5OH=(-G$Z)xf!TJJhQip^vf?eF#8+e&B$wJ z`uI@B)jM^8gn4FC{PQVg;l&#Ee!G3>oz6Qq4to~XbE+wKk=rIHnhhP6;Ppx%uw|uoo{~XLTu>P2axJpt+#}9kW zpGRKuLm9#uxvYG$m*UF|4*U6=nB)k^FUBfv01G&K`sqTxg47R29DxeYD@zZcTKi7`myltr~ zzBJlkk%Coi9@uwa*YsYp-YBL5!$4;&CC7D2khWW6XKL?A>HC+8tV`maKW6{qsJe9q z+l%wESu=n9d`nzTv`SJ8$}5_cNBoq&9w_W@ztdSn<#|2r{Yy`5YqfZx5zR$D%AvJV9dH|!Jzb)J zq3QjSar;PTv{W-&P9WStEC7$$>(KRx)6Slgx8d8J@D_P(!e6;T=8hUeako5GWd}tr z*5c?>rV@#JbP3b*@)bB?M*lHxh-ig>qI_g%cBfN^v>ceL=2O`!2whcZeoAY;Nvw@qQ}aXZuWB8 zHj-H=_x&4{UV0Ui$TDxztejWIqFGpt85!icwgjH^?w#Naqh#@)>s*}D< zw#rvY$m!AP_`RvFKR7i}1H^NqQ3||9e_b8Y2*AfAHxT53%Z`eJb0g35Bafj`YAsw2 z(G(hSClF3;)>=k08cWZAG?R3xC>_7(N4^+!pR>T!P@dRE?aC?Wt=RGiNR%tNQ?LjQ z*a$@+PI#tPL+>qI0J%=bkt8DzUL8@ET48<8q+*!8-9p2Jr|R)T(2ie7o>|5-3T{R{ z9zGS(#ovJi+58>dySRuyA;k_mrexLX(}C*L7>?&?VVX?wd{1+`LqK5$`qM^_WJy^Oh0qZ+^TIC~2E~2s zBq&ErsXWLGJJ8CEnqclLy#2P)N7$lyT#K9;cnn`7_Pjl5plcJ8LA-c=osNd8kbL6m zT`TOwkqSPJR=j}9#>#zrQ>dT-Wtjo*od{BcDPho!q_Gf-4@oiST~~E%?$y*M#paB5v>+eqlJk#`^d!CoBhR1lPwWz2Q1Q=?`5 zaGBGYtI9Eq-&$|zwJ!ObqI@vtSiJMSuv8*jLII7=u2@{KHlRthqMgLElXAg+>%grM zOFm_r^}5Z@vAF%Zn5c3T((El?-Mn>oI;?h zW$5Lq?61f>`0@yULfTTCpa6Ai?yh&<`)es7rij2iMr{V*HRUJpcarA0EnlTuL&Dg8 zx{28Ja#&nXTZ}V(Knu-#CcPs7d0iSFm_d9@Gf2@_lpgO%1} z5eOFJbkmu5xufOLmCvPmICChyHqn1R*6M6Y*Zu4E^^Ek4WHI^N^8KP-t4^@(teU?M zn=AhP^R9>rlk-t=x!dfbY~+fJSCwUFXttZBGeGO38l`NHWy9mMG)-8IswMO}U3Fs2Q=1AyB> z_l}_1?^l;@bKbWuM%tblQly>8ePvdhhN9bcg;dD!t%C-|L>rRW;h|?k-`oESP%q8q zJ<0`r+T@Nns{mM`X=s_DOwC+11>44qT)R=&T^$R%4qE6~=fc-YrR8N)M|>;?QJZB{ zc4R~+mx)CGrNblBU=v7-x#KniXAI1*byvpW%nx{AP<;5iYveptIME}y5Z~diiMllr z;R4ySoNm?$a?1o6PLn~0czpC~Krayg^}t_;hI1=dHe4lzLi>e6&qAq=uQ>1XWbdZd zVQt39G!gGRi}K<`c?;UBLP+}?s^g%Dup856b~pnGJ-kxSW7%o3lFB{RLsaFqOWOKB zMvHF3x23uq1ZyxtpK84LKAi=e)AfI6-@%DuW2frq1g= z1U(5!ww+M>u(qXiA|3YARgSV1WwBU${n9F&6c31NQS-7ria=l}GG3}vP6fJQP1+GB zT7CE7^$>iueGqvXzmven1vYN3xI5Ufk$vD~Lv}{ZJYQW^MHL@)t96qkTaVg(@Oa^l zrKS(0C56smwMa||7yxRNMJ4|{jn`^?w}+dxD_43{=_TENR*Ffzjon?nB<3%}CAQ!C zkj;!=a|ueT_{NpIxW1PeGAvWmyXJ6hbb>Fuk1K=k%gOXm^&-2F*X9^7#A0;jFaz|d zG2m$wH_(3{XQK18OE-K3Px;4hJcU~4sonW_A%pRGKA8)CIFm~sEp+XH5&8|b43SX>Yvd?2$E zQsgetb=5mnhe{V(&_nFjL1r$$Q{J~aW@d#Uho}6aKc1f$?ZTfZ2T@0(5ygyLv?YRi zL+W6ghw|7JuPYMOHmYA#j!jwAwv!G_WJYnge3tixE_2dlg2(_FL%|PQ8Ik{tldz)s zIM0x^8W8xxauku9!KHY47$~6i?wxR_O|I13T#ym`$*}%)+HA6YJPGo3d5IgD2>!+3$(fU&evyn+d6uL{>{K7rbEkoeE z(Rjjqf$B%E{CBlRxo@lT2z1C# z!EVWiP=Pcr>v$r&>fGgUEqVk8^O+@I&~J^w2Vs*H(%6N3%#w_#(zN9?4;AKo7ZSu9 z=t^587hD0hpsKAva`-dGD{(auoRg*!OWtoIc z8|uSa*|C&&gM&MPxE&9PdQYi8jK7W+x^I_gr0;du;&wgIZ^YvHy#?jU^rZt*wwsCD zI_bz|o+_NN;=;z_-Vf1TIWI$vSaPs*T-Z=sjz1a6cf!CZRKG6Y(j5L~`pB|yDLKpB zO8P{Zqo7cfGH?Xru(AOGRkZmXX|T5G%| zh{izq_eTW-+k0`$`>$EzKSosNzT>yPfph%?&bb@m;ew*$+AoR5C;fI>kkV2_Gn#)! zBm^S6%pr;q-vf7r=sd|%B8lLQ2lEV? zZBnec)*ESgAU(^@CDon$sVAD=CX>%F7gURrc{CwOuoB;CGSZ>D%jJ|<7&<-5xD}iK z+o&ujY@4W~{d{S*G$KJ*)C@%}9sVJSK-DwKd)Ofh?C7d4)8#v{p}~@2nW&c}}d`@NQ&K)~k~kwwN;<>$(&mB=PrYIo--_oqlZ&%=_I=@5G{ohkwoRb zA}qi^*nWQNpf%ewY83V$1!R=Lyp7FRYG!np$d|XG(^BB6wnhH@oUBhe&Ai|q)>2kz z_C35e8w%VEsVS~jq~II#e4|;!HzH3UP%Ni16M0$9(pu=m{lofvoNc^3)=%e!JK~d? z^#CBNSn&MP)@#}v>a%-F)a#bqnOV}Td5?~8xfQw zilvrXsKjWvVp+4l@`;rYR{!bmZaFYR94y46slk+g8@`4Ib^x5uXaujPv>lxp^v+Jg zv|DNmPmF~2g?b5^-F-;@`dVzSvtf+=?GT4REm77fM|l5s@;eB?ik>Y<`eWj`G=-j7 zA%h<QT4Yt^BI7h3!uR*WdvNDa%R%R28;+o6 z>y^D}Xm_c+KgOOiwqWV~LnPHx718HSuj# zEo?EXEUzl}tM$bppQ!xESnu(sF`sb>=BG+tt_RBq!M(yC67&>>Ung`dyIiI|76Zy> zw6$>sOIkN+s!1f+861~C9%FT++Ig~USPDZK-3rXqZgT-MvC3wS#ruw;2FfB@dfvPHRs2?(_4BXFGd?B&?*f98VuP;xkhQ9RadC@ zA}2n-raN4Rl4N{G2O6ul*=k8k{k_Y8o|ev+a7+JA9f(!iu;L=?k;swIHG}Q+{A**t zZZ@Hy_0DIq47)KCn~>)>w(qchx4;Iiq~p0s=_JLZ_{}wDGIhzRQ>tos)sLt*IA6sW zT9a)yIQ1?C#JpGb4{WU;chrGu?K<>1cH4sb7E{@g7#}pbiLSi8dkO6vW^H?*tWTe| z7@=#)grpB&A(>qu?G~ACIw5Eb_daWO=I% zY=wPpJ&tr43LegQZDrYAy4wj;J0$ogVj#JgXZ33`g<$^(x}lPb_FkJ&B$|+n>aTW( zM8lBClFYN&QB{$+36cs#{>MZIB2-JuLr z2o>t^Tnix2ap|?-p!^ji_vO;QAgb=>ha*9NGJqM3v+2?pz~AYwS)kuS&Gn=i*u`3g z=nop#aSKAH8(7Hmb73u&s@dITk!IrLu~7K8*7?NaYx`~e!<9_lr|0jRHT<1XlL^Ln zcy)PKCetEHz1MJ}^=0RQr0Lfi0SrNG2p&(fAp=Fe0RDzIV3vB$EG zVa`8d3Arxfj5eErN)pZAE>ryKsUB!dhnFQUHfk|zu_d;D*)=z-*woOqT8ywV@AtvS zz)x-`b;XO=);Kb4xpEVi_`F03VJEy+Gv`3r@N&$0^Or?1i^x^FKW#M-Xh{@5oE#DS znh)4ag|W%r90+!Owh00arC}P$A?=AMd~3t9h%K=%1Z?#4ns56O2TpcbHa#fcgAktRb25eGucK@jOl)9%Z-!UoaR zz8T?Z2$=7wjsmvfl_k4G%|#b7e`Rx1T(>$LO(ZkOI!)o6ri@69gdloc5yz{B(lrcr zG`8xxeAb%ypu|7WN19KJ;Eai znny5U!w@b=tDb}zJgqz5bd?y{+|#lwt`rL1Kh`hK9uC9j(g^oc(Al^ryN9=KYwBW& z(mIx$3awjGb4OjE;^^YoVivzZRartRpFt(LzAK}9kc_v}jY1Js8uD;F3Xx|>`56~b zM%cii5cSEA0mTEN%7$w z=6+l-9|1_o{th2s1Yp#Mtx2#@cQ!Zy?t*m6%5-ko>=7 zTh*J%$;rTElV1qFWXdz%j>p$#Z-BqjU@ zUFv}geEV(FqImrm7_Hv-ct^SHO(8B#KPr~VS9X*~e*w!k&!3rsqv9-Kauk^et)b-d zkRgok;S5Lf?B;zs%rk34yQs(->IBX%`P=MV>#BBmqP(x^*ObamD%N3(k;7q1{NY(c8tY(cM1cS;qGpEIUjdK!AI0rEulH#ZMCH} z?hP=YDJ{_p=hTq#71n@<{WmRE9ALQD(%IKHgsIuH_4{w2R*ElSK_erCoBcL0Bbslt zfMrzj-`n6cDmE(DkS)A}aV`aT?W$Izo&`f^!nhv`OeA==$<$1303i(A6bZqSvpW;3 zc>!f)-PQngT6Gs}>6;<*xa4|AmcrMDxZF3CoFX1KT5^8@Ju(|0Jba#%e!DNDLR7-ix%bu8AA&O$YpvCEhDjUZRKhr1gXTi78h$ z&WcvIap{9 zH9_d7NsXYsM)*X*DjIgGS+4SkEg;PuV6esM1kpT`InV{D3=>Ro5C`Rh{b;9`25nqD z5fC>al{ztL4lrWmkbUFSzi%jzWS|WV(EH>%Iu97sfvZu%!NHdU+1i~^KkrG5kq2$*Ua~u{&jLrsZ_KY>`(~#=MVfQ?pRsJ^)2;;4ZdLw9_cjp` zRSe}NHg8xg|5_!Fca5f>seKL^`p??!Ud6!Jqho=G!oKzWDbIU=YhW7jJp}s%l5iL=hZf8CnCBl{W?~b(JzIK@tUdnk#R&eu z8NZCVA(CYSobO;QYs9T)cO3my@jjEA7>zP9CzgEB7k2j_4x19X@$Zon@d{ly;Y3}I_)EJ=y;IGQTzjp^H4FZ08*pB?FAvcV5< zS9#JGb2I*u-)NHtI;|ADPZ~Wa>+QK!Q<%gxl$EnSxXlYV31eOUkJW*wdI5F6Jv)?3 zH0pV8HF{r`yc*2#xLS)PoB3(SH5iYQ3Jd4oAl`{RF}R3MbY!sy)e`ut*|GNtC8WQt z4J_o&_bb!6D$7By=7bm}!*P>Zqw(;JI8AZ$7%b@fSdbb%<(r z-?sO;w5%E#(7msuOO{#lO`9Cn95*U{B%CERzIQ?)%0hdf~%jf>Rp<-lZpLQ5-A zQnh!=QmpdbJ+g^Vuz1qYM>Kt-3g;$)R$C{`a9aA?=1XgW3;|M(Ky%Hjn9Mi;1`Sx} z--fPGpDo{z0@3HbP0v+K83z@&P|tB4ExnD8cj)bWsFV5TP6t(F2KJ6oj#paO?!P9S zj~hCHrbll;d$a%Csg--*vHv*OLc1DnO(LmQ{2nsU4*LL8v|Oowy_UE$&M3+Bvlh`8 zpT%M?Xpjf~frIfMK^;mgw0BtOs5Myxo{JjKdYv|~SylG&3(USJ-W9#3V=+)N!}+Pc zy>BO2yBfL006p~7wxXV3;ZmEXsemel$au$Sz56^=!!N?(%r$2Z-I{nj4y$AT zc@*_?w0=FNX80@Nw%bzVy-Ioie!Y?WKM^TJ?L1bsCE01NzSbIAp%{Vyt&Ly&@m5Y| zVRN|WRI2g$ej%H(nIO8=O8EbDr|W$M3JEG(Qhy6Gn?D>}Y*dw#5Uk_r6}2*FwRH04 zNu2;WL>bD^FKnGm_YpGvex)nDa7&Mdr|hl$(N8Sr?b0;*hZ{Z$31OYMz770Wt;eGp zx(~)Tn-;YPC9rHID5M!G6ClJdRyaC(%+`AnBik4C zCLJgushH@DkLGLkb`fN~&X3iT_8)T1f3Qa(_19!=wg_E-PdJm%knx~38Ds7r$g}lG zX-g*efzlpg{=crgD{!)|zS_YQ+vm9pg6*5`HI~P!gXh`lk&NYc9VP313w4_SI6+oqEw;8Td?Oce*9gw>7%5CFX%H2A|}h}5IDZK0k- zCD2k!n+8446PN{b&tkW9jlhQHrSlsMy4afi=66;O1A9D6cr&n(>rZ3unx~U9WMlzq zg%r@wEaB^hVH|gEJg=#<2Gin36m9|SvE%qC#eySJnkSpj4XFSo!40&Wp@7O2t3fdA zNUjI-+4d)G)#W!bmRegcN0{~vJN1s4`+}kg5NgcJO!xP0ER;2r0W5Off<72X-?9?W zd`x~q2iNx=^~59j9Vd}AJ%ByE)g&}CI;6SMgn0(9xP!F7SJNWuvOi+&IPu!8r&bNz zP8?Cnr2X~l4JxVjT+41blIcXfVTFFxrK=u$ktFS^Y7O%+lp@n$g-mZEJcy}q=eE9B zt-y-^Q94=bIkx~2HV~{1>4Cq8;ChoJGO#NcGRZ%9M2U1ZR{QqV zWA7e+5`k*1*uW3-wQgjw4C7 z;mXuuxoyB@9t@Av@s`$q&jnFL;|(bjgpyg>pQPuzGX8O_9AS!$-zDs4f7P-*DIHoK zOLSe`Y88yNLJeSaXwu+xo4%Mz}BD?`%8e3Boe)R{pD>zG=y4faxr zMIhX_mxns(k#U5e31SC-OlNi^T&a}L6|PkVZIrM|2TL7M@gF;;ys(3iOP%POj!b{{c( zPIa}=MnrRF@MH(&Xws`+xUu^=y_2z`Y}NQN#w=H1$#LQMS9H0J&(^46vknd$MREO0 z4Tt04PHn;OqHW){&vQB6tkido@bI&>GuT9ptzXOX)}yxiJZ$WMF)d9RH%RJh-IBl-E+Cx6=d#Ca2Z5PK6Nb%?Bjb%1 z$vLK%`PD>Dm!fpp-Y_FlDW0uD5BdpO>@V{DYGjZL`_3 z{7-%X3$bVGHE?J46KLhLo6&4qWAwRpx^v2IECx5>95BKWLSe|U65}l7DZ$`ZR~5$- z2irF`CO11a1|ca?0_NDn_8yBDa}^oh4L&xKaY=|V@InCf1Xw z=gF$On8mlsC* zcf;=K=)4v9vQ(k`+76MK^DM)xHr2y07x(m z;I*~Bv9XbfmHstU!w(!2q(%nF(XjCuz7D>s$t9n-&7Mh3XFw5V2+&~3dJsG#eaSlzGN z(fhlhRt7eQhS&Fm#&G{F?mIH1K9N4Kf_-deTukX`m*bYCO|YSsA_hcFLPElo>6%C%*&O^vfStk7M7;J-anTT?FjEKDI))gEe98jv~S6e_cNAQf9xxvbNN>IDZ=b zy#8hln~0DKr=9=G{4e?`BEnGvg2ba{3WASHiwpw6;smy)feoq)#69iBe?$80Erx^2 z1E`O_Q5F<6mm~T;>XGeqz7mqm0CNx~0JVtddjQt4^{&}QSigtaH!Ic#7MyMXC{U2G zf0qFWGzHdD0c#I|09q8MhNdqqg?Gk4AYr#Z`q;wtF2?QS)zMoIZUe_HuHiR8ep&9P zc}|2QWdx{Bd2W8!LmaT8M-SYThzrCTTORrc`d=^hrIz?(mbweN6+$DEYK_b9r^6n^ zSx908Sm?FOO&a+sJG}p0^`n;FRl5W%L2Kq{VE(asP5ZYF0`>9&WosXG3qCS50e1(| z!&qJ)e!1I-sGrx`;^6HD+LibSmbS4r`0Y|)T?GQw-zx?bu?B(47YxJiBl?1N0KpRb zA)0w*{$ezQ2E!Tx5}ASo9uYp}2!9}X&JsOBcbmn12kx+reGA`W9|0q|{_D2G0gzGs zgwOw*Fa3h92f9}zI{gk{#Q!?#R1unf%k%YyrPM~fmb!wFDrx} zT94X(w4<+4h_}?fhuEKPLuFjbPk@*==i3L;n{LZGfOyhtacawYdWZ2?5aX6*PH@i) z@dW61yF~W`y4$Yt1KyL^_yO*Jd-Nk_>f_ezo7)07+g;!IqCVMPKLIS=8e0R)cH!%N zc8xOuP4I6sCxqJmx5d0)N{sY>(^!5wsZKm%S$=LJtN0O!F_0AS>*45dOxdxF-ue6n z1_FK0)6?2Au==a%Hn1F^GghHm1XbV<+UKqn9%kaND~lE9J*w8+xcG^MDV0=B-t5+Q zVJTvs3aV}+ly=~%PxIi1t#Bv}@<=*{zK z)EJzAaWE&5;)5cvUofg4y>E7MFI|;$ij>>2+3N}xror>E0hq)E8QScUDw(*Q591EZ z4N--*3SwsCykPLjr48sk&@e}&ASKZSqNRx_eIC#W zLhmR&h`JC2+7wUbh@MRyW1a4$e!p?-fM6uPZ^hU&frc}iG3brKHuFZlbi5Z)`TquPZtR(`#L;s z*!$t|Z@y9;hJxBn9C)Cz&lK(1LEEN9wwGU-O_~ZBAjDON#UAyTkxKcK3oU)t5i~)f zo+6(f7Z#=s!aA9@eDK&gcs5#E+gWtRyq-dH3hS<(yendz`vR}a`P;IYi?ILJ`azn=$pRW6UWQdH+z0& zWBL;W!Ob`ZFewi`m{TUft(tSzgWJWvHm$f)>*`)Jc{^Mb%M~a^^|yK2%O04qw{Ff# z{3c08s7=(6ehL6y)r}p=*jmL7cn8_WW4bD{5*xd{@@*05+!uAyJP&P{oji!%cIt$K zVOD{>`iR#c!IRF}1W841qCUa0VoB6g7pJ|?tc@49C0YEG@n!JsTTfb4Em%ETxa>Kx z-OT0=@j7Dnmv{JFu}>Thwx?9gNk%>NF$W{dI`I#;D%u2S>wcxJ-B9iV zPY@eBm>n>(b?2iIe)S^~NO8;5dkUSUZW(E!`n^pl>KCQp5hbuZ1t?E}5-@!fu}PIj zYvZl)gr~gL158?IuhW-aFg5w+*_iu3*v)i`Q2bJL9w#cvjQG_;PnNdHU_RlS)Gny# z7?M=Mbts=#Y+sR5M4T6rgBVFNoK>aylgl41D;K0&5LIDLJ*K1EcWC~+LiS=DD_r_v z?M{RfeBX5=E{v~h^g!c@ND$P{x*`fKKC~=ECHwv!WZ}^#(61pF#6GCQ^5gt0hxULn zSr2ibGDk%1G>L23-P?7hT;&hq+8utTZIz-;b|%?Ov%)bBs!y~0A^Fluu}}bHE%zu< zoMg}vdez>1-Yv#P%)s6f)=F@f$u@k{4GRv;g~@S0zoGr9=+YnRN!?Pt6J{VR$|L6} z5xO0$8)`+hZ_D&n49<@q5D4@hs(%X#>>HG%-PbAC;y|dGP(S{Lby>{3Af;4GaOc49 z&?TB)@`h1iSrqlEQpGvjb6`P*G1W`__wZ=yr_gxi?VSjq@eDAM6h_^;pu&h4nh+D) zH>IfNN~%V`)fyl*%V(`kH*d}1InL9vuG-T1C{@5!guyEo{Lq1?yF?XMW=c?LnC@Kwtwa{ziK zrxMkm&4*rVZN4RJ3{84K@da{YD%t3x=o-#NtD1X8>JA4B>9yx=H={4uU6=7YPx?Q> z`mmBshZLz@Wew)V8KS=YLd4$%vSa4S-#gCI=R{p!(*;CfDSL*dYsaMbV+bhEa8Gt~ zA`EpO=f1gRLH9y3Os@#}af)_Ih$9&^ZcCK!5_hMwZ{ zJ6B$1CaF6r5Td#5R8wa`wHa;-ca4Ev&VXn&d#IJ*n6!}M80SVmyOv`wI7aE>a6h)@ zjZoM5I-1c~Pf}+kd|1)D5QxNg;`h~z5$0Z*DUk$2D^kOcckSaDnFkIVHzPbEI99D8 z6L0k+_^G#=##8G8+mk;||D_W<`_+ou0Mhg3TK)1U2eSKLrh^36&3(d=x=jy^V0h{E?d~unxc7IqYCK-Wv81$qu$b2UQ%a#;JTMI8K(=IpqV{qSly_Az z^kG^pL0`hPXNvHL`A;$YD$%&*Jj4(2pnEEI&@R5nH&6GmTud9^L#}B6` zW7bM_MoU1*5BOM1=_FP%Xfdsuzv^Di+{H%6PMK{h>^6s{@M%U>c z*9z@ca6L*!4N%gE)GCSyCa2J&9gfuuZ{!Y=pTP!nKvay@?EYc5-~PjPmhwE(>P3e* zI(#$95$SgW)>3uYvSVCcq!ad{m2$mD2#N2T zcilY%Zqm2|e;{l@mdg-+KB{E4mK)&uSC#Ys!`L|l39?0twz_QF=(26wwr$(CZQHhO z+qUhh*LUy+KjIDkWXDNNa&qG2##&jG z$nzYkJkJ^1kVv`Kq5XxaDVR{#m2aUa1~7o4aiqov58h$v)9OWI`I5FjXPxJrG%s`Kgp{?2n#2eA$qXf7s~W#cNPB-^ zJ~wLxjT;-!L&_hZW?CiKL#x-%c2&oCvW*1(RGP%AS{A)YHf^qYt%DJ?t+I?Rj8_gJ zrYkCoJ&v*aoiLP$6C@cdL%2YeV@`}jvIOKmrB^}{%8M_C|cZY9o5$0(r`U+@`^7=Od=u zzV*Xh{`Dfy7xDUY33SKG!as7T(`e&FOh0pBl`IS#t2V*)kfd9r$zRW-^{>{V-S%qR zO5b36vK=}%ybeC;#yf5>%%kTG;iUrwWVgy*z`{Dfeh+>BYOH`05A%1u80Ov4>83=dl3NghpWH%yu@73 zMnTHx1>K9-BHWidAOI@I49Il;8o69cbB{uHNAg~itiGMYD6<1-D6)$C<{{in`FnN> zB;E9Ys33Q#WR2-uXs;qbf44-07k}=7vC!qVqk&YrA%4%f8v|ZD^fBZn0lM(p#~)7| z+n%B?f^N#vBy1P)wnCHij~LmOWvbaFmd!0q+|K%=i-PpsCd0TlBMg*c$XB_tb6SbZ;i{&fOUn-8E5HyHBFhB(+9a0{5I za*07BU@=2SD4FQy$G+a8<7IkIi`H=@mk3(<2q zw`=!flb#l0mT2!WS4Pb5mr7{n%?C1)#Fk|GQ=>oWz;_GGfI?v~(r~aO$AqMELndC@ znz+PXiM1~GqUlr0n-8t{#k2<%!9F<;>kpHAH-g=mON!BwX-)PJrr`Ww7A=Q=-^e;` zFD{HZP?%tm^$>bAj3JDjrtd*lw5e@IL)c|Zs^*Zq2lk7!UG-pp5lffN#ay}=Gd0!$ zNesq2^_}685pQf}^cLq_p3KR65HHLHGh2}<48^K}F)qR!CL3y}f1f3d>BzON=GaB; zP?~*CZvnCqnw3c0>9_}VEeaf?X`~u-=DDc3=_V(}qqVlfZlDJ6{S(LRAl;tT(36Qm zG?mTq!YL6hc=hvRPF5-%YFXL>;;O>oi!^5uSP>O~6_=NETSk1hN{ z_$hE+^yS$6rdN|IH0%avuNB{l)ixmRS|6#uz04p>az}BL-4+j7JK$=>{cTcP2YuoJWO};i;@? z*BR?ut>a4|-&v$hd$b!InL3c0$i+^rJfJNta7`wWh|q|j^%>1c4^Kj!Cv+NXO%(`k z?igYF_o1Ra_ctR?)ar&aop)}|8E{jyAz89LU7U8q^a1fX%Q*y=)Zy;k zrtyzVzG05!QY?1q&?%H1}J8HCzC`VP6rmxe`$o2IQ)o5Zz+QjeC);Q z|BCtk+no9f>9#VbdSxf{(pn||eflk0m-V*HQ#^;>D+P5b5>7TzmYp{2y0|Ry<6oGy zFg`IK85r{iZJE@rG4X}R7y7sp>-hR2fAkzET&@*#NsJFwVRc%~;)=;?uKKeDTfBgC zUDeVq1A1?+z##T9MvWoIvMO$WWuCKxm8y1Ljpn8NEwviArOlJK{Pm(9- zu^vn!kJk4g%o|+s%IVbXijy`lUH{!<;iw5?(9`XC3BVHR8UDIZJgRrhTsX>>XqU&p zP6Bgus$d6`u6cs3z?*Yehds_?e8wfZxuvL$E5nlcn81NL!gp_v-Z{+A0Lw%Nv=q*R zN;2of{7HwWu&*ccoRo2wxjS&Aa#DSNUvT()I5{axI8t+Zd z^72Q3`eTeVNnswR>_gS{k1#zAlMR|vhV4nHhct(Ien_y<0V%Y756HZ_i!(BL8hDJ* zSlVm_A6cm3Fs93o5-6u-Dv{=8Lx=h9UcY^ZBDJu*U*2uhjGN6JN?VUr5tO(D;bKemn9sjpI=S7SZb)bHH8V=UqcLX3e1-roTt* z;3_wGi!pDTrgRKXs_Il|x;Q%HuRK6cDWTVv>1rxC+Si51G_M-GPWPV|W8Is@OE9;U zuR_)A{<_{*G@1g4(U`h4TpbTjHwntVN4o{zvVN<6b7~Q=+zYm)?knaG&CU*vT%6X! zoVCtVUli!*F=LqW^MjFClv#U-uBW6#5Sv-i%Hd}o@b$9M=X9uPoxCrZN{6jRRya(eD^z_Q=^wCl;CV6Kb`*4p?|3mpeg>4KxG5 zJKpRVF3&;xAKdh3l(Q6 zPt&^MHSa~dIQWIrn&nRw5Tvi5wL`o$R9YV6=Lz`<;$an5$k#QCL!kbm_9h#&`H?=O zl7x{|?A}lCZ#{pLQEG$Ht`&_trv@&r2fkfrMx%YW6{i{8kf;VZ{5A1P3`l2SIyvgE zaGaFPu;3|!%_@ZUd@jh57JcQ}Pd#$e^>p|0Lvnz3&Onr%U0IePx(7ky9x8t|x&VT9 zAHLm721Qu|ro-T3pW(2#)xiuLhYi#UDJ|Y(neb?1ZKDaBZ)f$KQD{6V-vybvn`m9-#_58j#kO^pv!kKA(WZAeTGPh(E^;l*Vw^|PcH`$wB(ufx zU&r*j`iQ1<(8!|xlA3f@b;Ak_xV2gcZ1oHvIkk?Q*u0FRSel-A20%&fVd;=Z3OL$uK zCsEG1dq5;@^htHF7&4Qkb(bWj2VkkYVb*y6a!FRD z(sPcp-a%~mL_#%1o&X}nadeH3;_(X$bpxhPnIVv8j4OQ?pT9v9x330lYKo%)xc2T% zTgLdPkd;pXL8Ve=N-i#3VqKVX--Kq$9!7PtD(?A;%L1aML}*M=J#O>pk!2(1pUtwP z5+tEt#a%zpReB?@LcF@HncB&OifmIXLR+(+Kl4+e7;X$L+^>;Z<4ED?0iCDUeU2e_ z4P)VTyRh8w8jS%;ax=AND>$P%z(g-eS0=~OkCR~8&tZVSS^^5s*bRTz!58(cLzu4G zATKzI&2sU*NEcOjrNpfo?Q;2|8za$alc@@B`$Q7}OnE>a)@`yevQ*N3Sz6@Nu{p$vbywc! zL5PZ(zcjk@osTH#mV{*pNB(RCFCRPn~4IZ z$ep#)+Ogh>RWnN!oa8Q5ndpQ&pztI7Ut$3SqB`~-IGq8Z%)pN!W|hn7}b7lrrx=K^? zzZ%(Q>hB){do7gR5-*OR;L$xjr_8yM48~lKoVkRCTXLX`uKY=W|0Od>{kHelHKZ+} zpS!-YM+&W4vRF@NR$Gu$aKlvm%3#^FndxiOhpj7&oQ$EDCGsPD&&p1xE-SEc1J}f> z)TH?op%Y060O@MRl|r$fVUd&W^Yu|9#1eu!g8jH;sJ!*zwC1NvrjdNpY(YT;2sjF-1 zJ0*b;<`N=YW-}#IVP`1#s`{I7e6B^7RQbJOA667N9TS5|At=hq2_c@vkIw>h3Zs+? z9Mu@x9J!JuGvq}KEd*;PlhA((4C-V_Fv(C`=ZHaN1}fdHsR*Es+=kHv-X{y{a)%z@ zG#&;1FrQr3-ZC5_v@q$xlE4E5oUWjxYCB1rc{u1&;6P!%`h7<3;Qh_d3pJol{#DZt zi|Q?e(0U!7P=DqNjkUpGDA8gdfy?Kb;t}%q^bs;R9v4$T72hjP>Xd&ASIHaZi&=|1 zn!z~>N<4KjS`x)?_wMZ^4Z zE8@^7pGl0H${#N{_=yf%eumPjG$94&_s`DHoU$JVpgfvR@{u9>C^qY$p~Y1rzcG_#EwLjY{T1{+P?SWM;%jjkNsi(A#3 z&bgO%mYQWd03lw;3RbeueQU-C9g0Mhn%ht5&@};T(vWmrO`@jhT8)hU6Ig+Ai7Pkw zsh?8SV82yFKDY{`H02nDHN)6Ln8s)TcKD;~d z3|xc11tr&>_F1`lJWx|Dss!S}8b{jejf`UxpqEZ_vPjVe!JnX52`TwpFnZU;cK2&v z=P4D7(|f5gZh;w5no$)<0cN|c_*ifGoXTKf2dSZp+%}*MEaZ?VINPo-Y~kfzr{TG% z{g?Z*un}+by<{(|PV1%g0sby=;jD*%Xq{6+z1JM6hu#<>5{ixJ^(}GT9t_wkU!TJQ zb8(%mS}ptdjitHHf9V6p34-s0Yerp(0T-jAxQ}EE1p)f zR_n8q9wPGK!|qqC6pyUjLZEv&GMIRn6*81@w>q{d{r#z;&D{bSosy^MOGjb-wZ8vO zevngfd<4fN#D)wkK$m@CfqAQ!=^O}q1y03_C0|TUo00p*%p%!Tul5EvXv7}sU#{*6 zp!HNH1Ak1EWw~N?!5%l%(Qg7~n|INv?e?@~8D?@^BwWCg1&JE$P^k3g1O$c6O!y}! z2La7A$b_CPT;>(cB|PqPyJl~5BJi;$_R(NI88>kX>wUgo&|*q;gef(!fVozd8gwAQ zht`JYuR*9i@NhtQdHB!mE1LyT6BgWM93B>wf}kv^>4@Fx(hXa_d(3FM_yPqn-@6b3 z*Z2J}GD>7eH&$c3t8mfksE&o%xG-KNj9SPO6})f9dk>NPiCy`Uc<>3CQb>HXot7Yt z5Zd;0R|}`IEVcZ;%+*8l?fh{NTi2H_d+0pAIflj02hp_(Dqt4{^d zeO@}xgNSIlY{v&V0wMuCiJnymBdv)$D5aO?i5`bn@*6T`*$V^$FJGG$q*}N;!L-rzd+B?Xq4ssS=+A z`=LO3{AYSv@iX^^L;N?8xQe_UN>2=kD-~$+(WD#2`$MtT6#T16_leNlYt{~QT8ERv z<$MzW^$m*!Fq;7Kgo7&Fi>I-iDZ2DIIa%w#)ZZdg3QIw(dGZ{Y7JUq5i8_;%;A}Va zQ_1)PouZ0;pBo8<9=M6)QbB){#_AATcA=-Bo+fW{mA>=w=yR(gaQGampoN*TC&phNH zjb{dr>Chp#{D|QlO+gg!d@!P1+Z3kGNL#S!{+-U-M)BT&|4I#&m3>?}aBarih(E>+ z0VDZvr=QydnLja)!C8vL!R97PRo&MhnX|@=MMlOm?OgJIX4Rtgz;x#0cVaN?&9~ff z#*CVTJ6n>Q^M%WrF2Es=Nnfa2dfCp7zwFaTK5uNHofOb_aqydD!Tx33AL%3dfe>U5 zO=e!kT;r5NH=+*5WsOkbN>Jo%KDfb0h6A~wD$p?EXNAtB9wpfl{Y{=zSG8jV49ntp z{+AqI4u>VsyjAI?(Q~$ji10HDU~;m1mse2pxjC2$W5Iaz`s6T&kwl?M6e|diQ;GKyycDz3wR2u!cZ* zEWWQ@Hjn1eLz-m?Bt2@5R=_eM*NRr`thD{%a&raUNXIox4q&WvW`?Myr`*UOw0iw)3mk?n}&>RTHaj>={{> zHQ~yA|7Q(ro%ngI`)SfZB9_CAIgjomblWS@HH5^Ho~K@$QLEY^Uz$=6UqUE<(-|vd zt>)>8x!Kz?23L|5slXpIygjml+mgioL=oG)8a+htSLCVoz`e(ZF-s9d7UWcPp4M}d z2$QXvSQW+J`O!ktN>iP=f}2b{k680!XKT*VS>RzpZ3kY@S9IIx!rf?KfJ@m584tE3 zq&kmDa}3r)=4&Q}<%BfzsLPh-Q0I>rwg;qvnmK;Q?31ETu6LZo`g(;XCAy7sq zvzMlg-$tWSKcN=z?_t43X&48Ja3&n(REdW zH4QIre&MBrjW*JvK;#ccpuVn9vNz%Ad6GutxsUBrnU%|huLHh;fuN~Oh|LG~pKU7k zmgjSzOPXbB;`4uPPMi@?3FH!{@+P8t)&WOexG5+~Te=x8LYO ze0Fa;sSBEr|F{o2nMdMlcaiPy3a|yn4yjw$?@=0RtjJtM*|(j(^lU-`IS2Jmb$KQd z0bA>q87p=07eMo=DHfy`TZMX({dHZ5(08)3b4^N|iVC-_g>}C1*UMIdJZ~|s`bNxo zA?Aq)y->Rnr91Q#!;9A_`r2Q!HrTcP}w9wH|bKn+JGaj~Xn$^#EeP0{C8)x@R6$I~Zw zfz)$g(Ro0*usm}pvYy1 zIYwf+Jfaj4Ro6>nJDE$+l-j?fnL#&pg(Irl&b!#Ew&BdaZeE7ASO}4YXn;mp z(F}PNII0Kr5vmJ|L`{WWo4~_k5OG)vYL^Cw^{n#bGyrAS9(6kv!RBiiRiMYj8;B3y zZAk07Q#a3haW3ZqULjw6$8bz(E)u6aeHS?DspUt&ORFe0}Y;2rM zuGDdTphvM%YEYO1K^W62j$sq#dDo52?akk8vhK0GcH8o89k?yjg?YFV@kAW=w_Tsv zhQYQpi@7cyqAnW;{8pUO)4SN#Ei2~jH;K(w4kB2m{WB*XiO zeGSe8a8gJQDw8P!73$9I@3Zlw&!@lOtC)afca=Q=HrUjbxtR}5#?VrU-**ae479#5 z-d&Sk>X1nwq`wZY`byx9W2~l<6lspiQ@xl|J#TI~G|s~rWRKDxs3Zh2LRR}mv~F@h zm|9tf27lmApHFS4Ttdp z9v%Pi7dyor)$ZvD8l*^mB>`|x!S1>Kxo=?6uY(g?s}Is)?!)AjS_`7Gl|lR6VO;c* zdX;-xT`W8S8Uq4Ib{UN_@W{6@%&MIZh9w&q2*M+)l3Kb_p1+;|gDoWvk}MCDxWWaN z_^vwoBm8qJ95ck+PZ6>V|4t^3-p!szBi1?}E&Sck6n}6!7^xA_-Pd zSipCeP+)kUxk(O2zm&#zSiRC~W$;Kk)V}v8dl+}3vq^HmR(Q!G99a)j36IVkQh+>x zHu(j~@kMiV@|!_(*s)5x@#3htUgo{qohqhwKv3t)4t9pS=6LM!i*+``=!SeZ=?GdI<-_bWZvP;a4-aYmCbrCTZNFJP{?|a%)@=%2 z)Y6dY%%dO+iQ1rUeIv2XnGmRmxx*+x>I9+x9ZQG4zFuyaNrN7r(U*1zJ1{S^BS&9w zifi5D;ThU(a*CW>NN`?!Wf$1^R5q>)IIA;;NY4pz5HQTR$8xcr*>w@v~;R!DiB@-&@l__|4+WIabc5Fs8wK zOvWdeRjc~%jFUe9jXp@m78Pa&uLUE6^Xpm z^;!}KdXR_VO}K0eZZiygB7bPgmop#zEdUV~$z~OO^AiPL_HCu!Nf0E_X=f;7d;SeI z6^2*Hkc_$8C zeYOp>1BaS~pnpUi&HSg;>|RyB<>c1Lj8PaJr+AvcMFq35a>!MMnW-7DT~LHM+kBhx zWz-;oq+WZa!wrBH4CumIV4Y^poNDTg{!@0|XzVt2mc}vGav}f10D~j-b};Az6#O5vBex4#(S-t=JcpM#F$1xwNaR{NQ2F^LMh(Jjk=h`!u7_O zBl@Htap?s2Oi>Q#C(XLkd09JcEPF2VUM}>Ot1r#G%Oi2j`oskwUZ0Kp#)&LAyOxi- zz?ML1;>d+f;s^V8Rjwxz%2@20jh|qko)8h%ZZ)PR^zP#Y#oW9P{|tEN&MO88HYC10qBS1PSF>CpoE z7HEmrLNxC0+pP?3 zLaWbO#b3us-Bi^X?OiQWkU_IN0zILw&!H*=l2koLG3Z3tl{eu04J1ckTn$3mLE-rI{q#rF_(| zuEIufe<&{+mWadb%~#m!{j-ZnFNgZ3r6imo)2|8mH|J?a`wC=MgA#B0CzAC29V@LG z4n7HmB8Tut)wYFe5<8TbY^)Oul)yPA@ywRM+C^ncKvJ86b%Y7gwZ=6nRyI z(`y65$PmtPmNihzD(wIsoR+2}e`DUOxHLb?Eaf!%5Uk_YPGfb|=WJ~nF^&sZzn!k< z%yy;{QT9=I5^;V6Oqy+w@CcA7d_H2g|FdlxWS;z_U7_i%tcCZ0?Ngwxa;-yF|FC2< z)#Q}9=r)Mso0!dyf#}v*_Kk}&j%e~x6m+d(l(Evni`#t6ArMW-{4^9@)OG$&bhh4{ z^3v{mP(w$0HU4#l%(?>YUU$@3wX!l|Br+$w(9Yb1@(V|JjVqD)mFIY6D|8Wgz8Kcg zZu7Q9^BrbqF(l7;wmbALOXaX%*1=1>Bx_+NhrgQuE~oF+o#AoEnnXA+=TCD>cCg0C zW#9P{Up#3<(rYry1`7H6#SGFK=1mD-x4=h)F2x2luOh3|;HDiOmD(eui*yM1T6l3P z7#h}P9Xt@Jo+0l8|8JTe<{0sW4>4zbJ~aCnw?~#i4#gq0G^JN*B)JExvG`O$J<~Y| zRF>~p%C{FtUn?%mM?i+T0{HJ=BGx%EPW?@U4+g^|6Zr8Q)L5~0HxnXP{{Y`x!a+8f zL~K3Xkl!Ujto*v+#B8iQ4PHEjHbqGGWcX~df zoxgCUShNmV6P=~#9IblOPUM^S(k++`vF5sR?yy}SEP&FP#43kdXKWAaZG;Y;_C+p zwe5Q!0fbdC3p&oQX3Yoi&`;NAdG=uai=9BsU6Y8>3-muNJ6%5U4=GWV0-w{MSRv<>Qc0H!*_N9Ux9=l@Oid}J|v=wXXDK&dMS)o3*g4~ng^A%!L| znVcJA@*+{{MX9LSk$n%YO%sOModg_<`J$g4 z5Hpn=3H$a<0{#{)aYHOO#V+fC~o1n zv;6v9HG5`w&7)xNX4$F~Oo#D9r?|iO=C9K#u;~fkuI^yV{cS2%(y@5btJkG)Cio;PinKDkXsQGtJ9xEeVl0nE4S^GLd0=B;1osF1L z!t#nW`TLAUVydto>CcL==a2)C8HnW) zC;&;qm(ZwYf!FcJY7v4aE=eH?J#j)DAqTAUWq8NLy5*>9eZXqWbw?~46bE<$nXdQ{ zgt%JgXBH2rAiePiSJtWgNXClb;>a3R32@V8-|k?e9ozWBq~_jG-jEf7bjg7QXs$o~ zW_X8;6L&x_Yzx9LS+Hu> zpX)J=xOgB=l&vs{;vEn1nP=ySW5$YPla40r-b@`vhY>RKN52}=LS&1>{d^CT0r{nU zNpQOUn%yO!UeBUy!uI;LTIdq`GYTh^=c~qQ4rlFK0432+dqxHW$U0@NK^b|{smqe+ z$l?I#o++=}k!ZZpQe*Oq74WE|`|4DS&@*ER_pzQBJuOr|vz+=N(s0K=Wi-I-kYmMB zkh;$D6eeidbi{};!?aWbZW;%<>i{@|95aHeP7IiYrT|}ukm*#HBN85aSbl^H3|$-{ z+iR-%nU8bo*5%c#KKuS{-ki>dlu=GS;g$XipUDjL%MrFE9DP;hQbAKOoekl!8kd?x zml9dV+&<9W|4g6%GRa?Ajn&6(0)WWV$3hj0FDvoF|As+|Wh5cd^pI)#g%s?I(Bynq zM8QecWDB#v<~t5AcE~gig}mj>y&6a$$8ndL{V>>o>Jy*;1_o`D&4YnC5UheEZsK`b3=KF*B|8UKcxzr&mYM?$nPuJz}HPRby-T@|vs*qJKe67m@}x#s;^(|m0> z7a7LpE?r6e8V>gm4@%M_w!fvD4m1Vq`Am9T5?A(-ZBNX40u~ho5jWwv0 z8eE}3c)_seAl|-!cZT_TF<02q)Z#xH7d_HE*^&`(9Gaq_Uw1b`IF0Iu3!r?xP(uS` z28%bpQQkw~zj7-fR_aPBkg()MdH+EXpy&VF2MuMN_DR&ILtJ>?VamL;3^)|(h|a?B zX;A*AnQ*arDt84uPIM4m$KEY^%|xe-4)1YFb18}qujQbU+75*tQRTklm44ai2UrrB zsZ33@0P!w0@=ZANN-d23i(5~A=Y^phWo{bwE{aG(M$*UM63aQNCbJ>-i2$+?a@Gv*d7fQ-5M55#HdR? zOjSD}k@Z$t*^8yFYp+QTU(=?M%Y%qRt40j|^;KmbMb#OY@pI;n+DpI&Ey%@mY@%kx z@1xz~;1O}Jk2wZxBebit_pI2|?K$tAnfAPAD8~oX@WHtsJW98pik`M&QNV1IVCbLVI6bDV9{8`10 zY#Ly&1@mB*GzLyvR~@RR(nq&{g>N4WpnF?@&=GXmC*#fanNsDy2CuvNM{lm&oTM(~ z8-HgX19)*U*&*i>>j~=#T+djqxL7lRi59Q|W=E!K@gv#cG6pTn!Xij+0WmT$tE=8( zfYqXzbnvP;F7}0xgB#>>xAH(mHtnU8rFEzi;iSWf&m=Y}i;qJDjrFI4G!E0JUA+Ss zL`FvNx@UjU)u%FYP8ufBO5LMP$Xasmg3yO#K>EaLP|l&xMWqSQ zU{64A1NoJePVuDfjV}ooCQqn1Xsd%6#`{Q5HWl|q&_RFs@B8|g1~D$$cnMO=)q)cc zg@Zi?;z&=R1{9GN_<7pz!#S!zn9^%IL;FOu8SjYJUZYx%@#~Xlcp-db`^{+#jmw=i z1cXD&cO>xROi$#OWb@DB`vY=fPRc*K@LPw|(px=MRWY!%q=1X~FP@k0l~U z8QkR=J{q8S9kCwj9z!FJM3Sr5h!87o1j+YB z7J-H$M+$1;q?X#Hnle8Qk&SK3XYa3mH`c3LxH@}k?_&n`IGjSO_{N8JZ={6c^I@UU zYDf`lD#9|>o47$rHARrJL8J=711f(3Z2(o8J*TgJtD!Zt#q%s zMMh#~K{7OS;;yNlnk(~hV8BN-tP3#JL~qt8-gP*CY;IJeXx-0STxg+HOw|Ur*h!WR zB6vvP-I1^nP_9dyEMH>Wng%SB-3+9U1~%3YH^=s0b`XellLd3Skbc@q)y%5MT!wM^m)CK<-&yEurk`X#QIkdc(QS(yl;mzL90rz9~q(lRf>DBYgwFIy!p$ z-_iO0bTE9AD^Mn&F-8C*?5k;Q_%UG|Z0>CT6qUSJq5tp;=?Xw;?d|O6KRdASEsU<9 z8JL?uN74K$CoZ=b($Us`Dqu_a9OF*^;TH}X0sXPv(J{8Sw=trwwa~G%s6ook0dDx> zQ22(ohPT$Ix1jG-=K(+rIUj$QM*R3-3)Sl0lhr?0hlUfVV@ z(>Z~57J-zCj{zcLPF{W;Qa)3GaQ1dff%HuDer(%(Z+|G^=YDRdM@mXyU1COFa`-$Y z{Xphcu=B_WMgblG=Kn-pPyaYDwK&_m?b=?MKsPb7xVye-cGB|+sA1@R=^XSzIng_V zas+6hYx%YKqKv<(roB3%wz48Q*EKT!!yVv%70W`OS=oH}+~q|5w(DYfg1LI${uY4D z?Mxli3QTF?U@Twz%ha4K82q|;uo8ULt7ilPTuEtVSxHd=IFkCchnAxp>XI*U;Y|PP z82wCs=>*rd76uaa9dyGx>gEN%f5HW{M%HJt0~}ph++2Ro2LBQRo0#}v%pn8Q(YFF` z5PgOJ*s!#|q4l=^%I|{{BWh{PF<) zswML&@|MkN?F_GYlD_`#AIOkQp$K63Sv#mMW1N^!i2Ff!vG5FxMye%}f zc>Hm&ckiw9rN-#&nk6{9?fj0M-X*>EB@WxnHJ8d3|xq z)n;^z?Zv|F8`HZ5@Yn@(qg_SQ+uw`2Tcvia140k}W%!O{1BfE@4MXZ9`v`3Vh%)dE z!|EgZ(LFE%q?7m}Pyr}>!utnd_zeAzzmWe5{os4X9XQ|{e#u?3fM@WBuHx(8%?jVJ zYj2sKIZvKv-lrVd!``9qoY^)|Ak|`Hy`9Y-@Q)g z)&D~4f8mvP?15(R@V^%yZNG9&n4Fzmd~R2IbqQ{>Kk$A&X9u>n2Dgy)jpzH5Scf`j ziVk~J(08+c^b+7cxW08FgMAvt0AQK$c`Vx!%Q6zXDKu&77iOvS^|p)g51ev4|5-@7 zb!E5q#$6<3sqC%9tq^HtJQ)<&G1cnq3xByCo(1SN%Xw6L6^CV&p z1l3ntvyNo^)hYVPkv8)0x;tB#G+{ISG!LCrL6$5Ss$BYfzT+PzYqYiQbeeR8G6YD< zsdit%f`nc%m#*{Y_nn)326D>yFk15hp&IDmGuUqF{L!(jqDMUbJUpf%w&tdv?T{p( z3-C^ZPMp)hdQFuBFkxz94$5+Qd)>FcPW$dOD?hi5V! zm7g8NF`yNSs^lYb{1Fw+Nq3?~XVq1qD4g1Amw?-H|6AM||6niB<<_)T)+bt@shU@C zl^HY(Wru?AUYu4Hbcqcp3mI4G4?Xg>r8pjuthYu7x*u6KCl)IAZ2RY)3_{Rn4*H;XLNc8dPEaNwh0zj1cLJgN&|GT8U8wsoU%uXqkmzq zb_Xfpy1Tl1dRO5bsf_#vA+_(c=jOH-nm(@N>}ENNa-%Syu6p7?ZM78$)?&>}2a6|b zwpm`iZh6bz_{3wshSOt$^mj_U$Hlo?`WccR2dXh*aRqCq_0Ci5y{**UG0&=8g2J5I zokxw|xjx3@eo}OP;$CoIe(s;s>5Jv@>->mZq;b|W;L9RD)=LMa{F&K1oR z>{}fqO_ID)etB8JQ?b51-}_|0Q5zaXxkg|Qk=SJ1OWv%BE(<*!LG@)?3)#T&q{czW ziQL6fh*R{JF;_~7N~Of5y|^e1Of4kh7#nzplb6Ab&|=uM(Wkxd<>6H0{-qaMiNYs0 zTcP}6-RwF22=lylv*rfl8kQzh7JDX#KPW=HGEXXG@vK4byC7RSn+_90?y}krjiQRx z6Fz<*z$y{596a~#yf&_Dc&C1~$^K(3zFyi}(wJNZB^D$J1pVy1KDLvu#K%Z2{2-Id zo9OecJ}=769i8jDu|r%^1;V*H4fW(&K&&0BmP!C@ZnuG;Z=XWW?({$Ae&g~KX*ZI#gnc~SdQsZH>{;H@OeC6QxXZ3kpjqP2m1u@@`H@Ge zBDT>3_b{IdZ+rMAk73tplOQio{ae1;#;p3}b1#?8TV09X3DvQ4=v1Qas3^5+#59eSgv4gQxx8Xx z!T_yG8dUsiit;l%#QXM1Z2-U^_N9*o5}cKY(AweElL5Ek(Z&{nz7YUY(K2`-rK7&( zY=G=~Y_HjdI{n>IxjhL#)GiX300bPADJ8=J*ExVyvre=D2f}HMz?1DOvfosK83C8k zkxQ58hK}%x)JkgcP@ZCOh|xA{EHbaX!e@A&cckHTXgz&Fj}wXUnF)K{sZT>6OwR;9 zv~C|9v$Pkbp&(jwggnB5Vhtfm2eR*9tEgLwnPL0ba#%QpvccN_wN2h_R=1s* zziGMx){cng<`;l9KCoEE2QLk~Fsg6U_(Z}94<~KZ5NBpEwmOMmJJf-j1xs)x9XGGY z?LBOxf6y`qq@e3;IN$IuZsH04^Fe>#I^`otWC*^r zIy1zU7;96h-P85cHG+>3PT0sc675k#YiJ(<f~(?pWf}(l+?19DWlFe=LugKf_k?-4L4BwO`g3 z4?1<8-R_5nN>n#@9sz{rJ8<4e~6R9!eHS5Y~K1iIOR{b0ws6&t)uUcL&@5uyqbWnlRC}E!(zj+qP}n zwr$(CZ5v(eE?ZyOuDXA`h#T<+cbJo$o;;CztsQR|+$}1(EGLp%gk??5b;*NY@Z`{=>8LHGD|#!TH=9 zQth=uHch)g#Sol?fU>uEsnKU0JU+_N`Msq<+f+KlU$Y%=vWXGh=&BeKr!;f=Y{pT$ z+y&FN{>4rtjyvDoQcQ~d<6J5A2thH!uT1If>)Q?QG~5>;Xih^}Ac zSNJ8=y+kCgVySII8tC5Wws?w@wuGCEkv@GaTq0Q+sr$M;O}7gcPUKkYY^Ra+O-e*< zvI4>PL#L*$mEOg6^15=ymuvUJaj@kfnxy!s09pB{@7bL!b0B z&vF3Ra#>j!WmX$jFxg72gq86y)gFAh2vqAymLe&tqmnW@xXIkKRrMzX9536Tm+>4~ zyDi^}yiakCd|Va+a%C-TQ_VTrSgj9Kv$;YDZ6E;4@K{7~Pwr*= zJ?r2|l-7pZFj=R0256nnj7qwBRsOwDktiaL9J>H9#bIp~zroe6ay)sDx9KmGbou;j zoxN8hT2*)0!JThESrw{y1V>v!sN7S9XOh_Sx` z@;M{g?Hm?XL6^EmkLB`Rw}YR))7^<{^aotrdfoTp0v8WhF>?Dh|GOCa>w+2^h*{?C zAH%u&44wZ%tzbRU<%BKkWiQw)Fb|$D@MX8wq2&YGH44Mv^lu1Xn{fIBFI6Jz3Nf3Z zArmF_AJvx>ySLo@-6Rt74qMS--aeg$N@94{L^S=vzFN>P>n<0T>(l4_pZ>0@-=bjy z7XK72PN>W6XqNg)echZ?{*j(Izo>i$*Zy>uM?7G2_v)02z#NU9G_K!~Y9IJWl0#}U z4u~(x!%tEnNe;0l8f8k}X}Dt*Z(J|SMp2+60*280b z&o5F%L-?8B1|ETC%g}xh9$o0z&%aQ997tuexGIhs$?^)ahsm;HGo*p+@^9r|nKH%N zgeu9A!_!$53akeEuN?FwIHzgF?RVy1?AKXTkj?;BiWqd$p! zH^p}Q*i|O=f@i#s`#VUSqP@!rs*IwxlRF{_b<2VUJdQ8P zHcSL@Xu1P3+*=<(T4L7$W2(O#JcAjYx}z{-HW{~~A4IKzmd5PV@K5TpTftXv#z4*y}&50lmP`Y6En{GlR0nj(zka6P1VWtoIyX+ zJ^r590MhxqfzHVpgr@XZxk%JF)lvIR`H8`kmZFI+gcF48Ilv(z4@BbLCV;1-yxX-J zK`$gs9ZnEUKfRgAik26gKVx-Pjk7@^9hTiGI5x>V9LFE^1^ZNWNwGZ0jQ(0@AdlRB zEB&p`Heq>*C9Zo_ui>+%gP_zVo(V$nI@-3`w&S}(er|=k(9|_jT+kb=QR~Ja3&X8U z{c~mOVUAw#`BFAc>epMGIQl?_ZwkAjmt`Jodq!cczQp~@;?YXL6Ykh~{(h)zeT99r zaNjmdVjOWBHL7GGQc(yeeL*K7DkxVpj|rz-R!13nN;>ulvJ zlnUFcmUAM?>dU=F^lUA0;(3~@6GJ{uF%W-nIz!uwxft*NM4l9rh_TR5B|K!>S*+-9x6!aYrZL1f;yun&VK0F!_w*Q zJ1z&>p1WEB$9C4k^BI@+O~LR96M0#GjwA6XoWbp@0xA`m5C3G^(MT0{vpLVFUJ;v6 zvQ`A0tl)vRheb6#BG9KdA`sF3wL?zGS#ri0YuJqmrq#=B4u%UU=uS#!I+$9DxOE_Z zg$P>ORvjW~R1LLI;U(;F8QcDWvyOYd2yNha9|7^+UAb5Qjs+EF`(VrA&F*yjF-zGIE`*dTY__4|i8yVmTh%oR^t;d&I4KYerbALX~sikUKFn*$16_2fdd6s9-(mQpA zmvEz5f1;FMRfR^Xaq<(=(iLXh8vN=SN+Lb#I-|zFr5`7+$dozjo_*L^?YC^-M#2ZQ z*QsWTNj6<&WtHLf!y4+hOg1hl7;ldpEw)@3F$Z|3v=N*e zGZBq+LUs^#)Q#~|ltww3G(o@zH;BLfiv!h2^`{V2-Ja&ll%~@dk@%qHwjU?hdmp?L zi(Iellv~a(JA}3r%6QU_!gB71eWdupuUn=$Ue=?>kUdH~rTEh|Kg&D`emiIow2djI zEIEb@tP6f~`O;>)PT#jHJKrV;|IW@Uj~Jl6%RRrZ+YxY0f_pA)`er4^M%<); z$cx5zwqEqi+Fj_5S|L0zzoA+Qh~f(~RE5mVNSPDRf8P-KkPRYv+k}K^>b!+GUAgsx zwAkL!g|7{wX44>k4F#XBSj{x|VH4%YPQh+ml*<%}KpJyq4e+^t?w?cbaHMB}F_oE)x zRn-5=Xi--&%h`)qAGM2u?nSv+GSdXr=l*FYPpFxwU`in|9)6Eh3nJyWHWhg{qq9I{ z2!oE@Vfk+T*5-Jz-|DjFIp?&qM=F zF{f`U%G(&PO_zK^^k=)n6R6VAOtw(|u6+ox*=pD+GxnSbzS4m04*Lp$6|3RV$0McR zE=ui1NZ-!C>zLrzZGeehVy-?1R7VxGxVw)NexUg;edjmCsOt@J+9z`S5aWkMxB9q% zoR`M_yy+Z~aZ^6!S7?5P(mMWy8xNTJ*GRYS=I0nyrg$O)BG48lr<9tbCZA@Gy@@Ndw#n*@=;T=QJ{rb^H!_P7ZdO==!W|BD;e>W( zt3LBl4_4F-{ckpt5lpudFA|R|rpEnI1flN-W;%>?-D96Vgdi2yi5)ub$U_5Wn&^c8 zg@YwJ&{?isYG^I9UG#_B(uQx2uj(UY*4$iG+Bps>_2) zj5E8(T#Hk=3pjWf^`>~<%8s%`toK$~Py6vw55SVpr9cZ_H1YEK$xB_<5EPJ@-oV}l zN!6aLafb7n4mvrgyAqR>%VWO>xm*pwjR`@V2MO8<9}w^`GxiDVhm3*_KGa3pihCYs z@1vm1@M-Mi6`yU@gTE#6glT83;*MJL#O!{?)%g!bOLuv^emYT(14FLAN zs=qBNeX)IBa*%OG45)dDTDe)}iBuB-g-{9P;}ZbcYuh<^L-Gv`xtRjHM9Vn^Ti88=GQ+B4pj}wOLyO2s*_-VGoh|9 zsiqdb)P6oC+FveJl==A z06_+E1}!^Lbp#h)RqI0>3)v`U=sibaBjfBVzEwt^u8zI@XP}ab^GDQd1M4W6v|h8n z@d+stgEB&$kG*LVleRTl4XLuiqxr2%r%m32Wz+a1ZX*Qqvw>-Bs;cb^**@tIoo|w$ zYvt=L$Oi`7P3tyJsfI$53SsY{3rDYp;tM2j2j%UXvbde(5qSQMKJ5eJP&w9@gQBro zH-y}v2sf~~1jmtWxW4FzA#OL4s}^R9p&Pc&PwOOR?2FmNYHohT;K8)LFHITFdI`kk zu+|#$>*4SLz*btmCxSaCzMFn2ET=xCGy5lmC)XcJ?~kHRDayM zpdlBhY)9~<4%q@S;{bCrQz#HF{}e-%B{mkjXsb!xn$$-JL3@lFit7RYoNsmqgC|?_w6^wY#Cpq#u|@R< zf5{0K>_l?7(G;gue}~e8s3lrp@}DuGTG8(Sje2ZLU+1nTUh_P+G~s;?S_u&+r-Li)G+a^K_MK`ff<^l3E%J$?%~Fp;cane5;7-*p&O}VXgH`ZmxheRTc@Fn=*w0-gsn5&rDgl)Igl|mWE za=nzJD3DaakjP910(ASV_C+MX)@g(*BF$|CoKmK>K-V-5<8yXJ^g#JXWONC%UCAAf zmmcb+OBHm={42=&kNy|{~@T98*dWuaKl9E@$LZQ@#W1^ zw(6WtMb0m`VU&V4*D--8bnyP}bykC@T)*9@nTg7QG&yvR->RoHfmUb#gO1d2-U~Hw zzxCxoz>YJP`)ef!?~Jb-JJb2wN>6}cGV#&g!fs*HHeH&poj>T67vQOcgwYA5d4!{p z{xiZN@9_XI>M}o`@#{1cGU6p84-q1f`>x=XC!itt^U4jsZS9k%f(DPkAlx=uEc2gS zqFVxIae6n%+Am-%zkqUjw5!z1U8PdNDVvr_2wC>uAKz+A_J9s?Xx2{sDP=k^vL*T%MXkOz ze(T+5fK8ryW*c1LpA%=e8z4SnF)z8;-&DLo_W=-)Tlk-DNF zB1(fkpRNSQ?O>)HIxtwHgl<+7L58b*Sw;yYtizm;{Oi$Oy?QrB!BfgxGpAVRu(}^6 zKUt%A?hIS@M$csY+ZN7AT;e1z5dYR4rIt7mNtN3_t<29vkJr;rB31*u%xv%W-7TqB zll$o|BH{HxKB70l(v=lkFT5YLjSK>1qcWrhq^Etn#^gZg-8wK&ShG+>0A`TbHMi4uhZe}t6j*d)E3yJ31qr61=qj3W z)oai7e@ANTMEDdzj6p$jWKmY+G^J(sFv(#xCTI}Sm_jR(6%e$3ll5w1cSaPVC-2fa z)AW>X(Y)_Ai-1ZgSbJjE*e4lpr7rNtjQNL{EtrOD&dN-s-~KC(0EctRMAR49DL%Pq zldlxqUX3_+d+ESiTKnOW`MmKWRFV@$5`wqi!CYbLKMPx^b`rLk z&21Er44x4!B+R}iJC`b9ftY>??1GEWMEC!o+H@d5I5fo1XKoejnxr>`$M|Dw-@Fkr zjELoubp^u*OR3sX^@srFvmix1_R~B+&=mS`^xp9Wkj#Z!MS@K*1)LcDI3jFhF}x1?`S@R zull@1sKp}?sW`>iUD*Q0#GWOD6n!ehaPvW5t!N)~s0x(m!iz;A4Z|5BlVLlR2$QAk zO|gYP7Xnzj2$SJ3$-I@VJNSh3J?kp<-(jS=gt9ZZp@=ar9|3G*DfDZ@^#?;+3M;p~g0)+g~|K3?-tqci+ zQM^R-P_k949W5}4U%4Y}3vlxM*!MJJ@lb&%4lMqJpF1R$`BPqZZ1A|ni;NQKq z4=+d426fS2StvNWhXd;3hr!Jw=}@hhG1r!8$=}ws)LhF z$1*cYIy(0?Tq(*L*-*I+w5P3G|NJ_Uf0+i5>Moj*U|_T+b{E*7&4;+suq^9{iPSN`DjD&SX^! zXD|IpOGsA&EON6>`hTeLDC0uW6Q`$}scdAz7zuo=_P<+)$G>$iU>JIWK{Z-AN!~&i zZIkO;OJH+d$-k>>eLsZ@^I0YRD2AZ4`Ifoas5_v#`!BXIas}@!2dsTv*BxOe-6!S7 zrcp2dI5z?eP;XDwk?lI`4TP;CjjlDim)A%qYoQGUx(f!$eF;QU4-XA(3$kErU!Lc% z>z?SL%tC74&^@lMiH9dV;69#hEyHF;YsvJG!Tzf^PZI>`V`c+=aWPTkt=dH>t&Kf; zX=JcMp^=#gs8X3>_gVlR`~)+1B^~xwwlVW0D#W>_+Ptd3dfip;bqgYexg|VvDijTD zX?P6Xgsl?L)TNG`-;8cGjt-3#8YL*!8Y>_!fb9;egcm@|%EpZBczkX_K3;_Bt}dFrp#1y-NHFQC z#;ywcRq4B1S`xq}hHmG21y~hIjeVIQUN7Ct&jB;i7SBX2Zz8faedo9PgnnxZJh-Alys1f(6_X#e^OxR*%o%`vN78SLRUs8q zj2@gcq9-i~PtphmHvWyVv{8N@gr&n4aC$Z?5ptoR zuHEY`#JVf`nvd}@ZKPUkg$1{p2x&%pvbN~#aI$0|RxcZCHR&z5J2We84ygKYoA7Fj zox}3>bM_x!n}Rh?$3R4r5D?L;_VIafOTXW`8fDx|bP2PuR!b-bqlF75MOarDIi?GG zYq;sdO3ZhCroF9Q*%`t%yj8*&?3!NikC+6%*I3_}%p4Wv_-CoZHN8p`Qq=|%ay%BL z5InFRvn=s5qwW7?B)@fHR5!+@u#G8T2GFGJYC(*N zoIt<7Vd$yJ$(qmUV>UU1F*2FaTP5|`05+=n>iz-Xa;F^D4^oRtfpR&d_d@fuY!c;u zxwXd~HjF@%5Q090fPBIW9~GJ5lB#)T%g_XFjJ*aeSf)a0w*3VB5Jj(F-iu7H4S*yVyS})c{HqF zTXR5671=Dil}$Jh8?rN+S0)K0VWxcYJBt3?xlIs()U0@Opn-x`(8NsQxK1X9uwAiv zPj`DbZtq_ToeHd72W8@@+6uqbhO{8Ek^$>7KQLXUNcp|jrc8-U;6`g%U)nxM4caxW z@lR0f-APLY-YO|WhiYyR48e2;Z{jQB3m`Cu2DX?4bcC0kzyYkEMO#G?F%u55MlB%} zVL!*`M^&!$bt|(c+#Pr3>;nR;$Y&pBS@9*GM@xE9}CmSbHmLy$?WlqE}QWP1bk|8o8m&=ae_(DpQ z2&_fgj=J?|z<}ONB!+0AT{)0fEW}rVxaD$AR{5m;NRrv0RDCP_J##2ZD}R=a&ywI) z6DXzLPqRl;j&8tnHVl%MXpZYj7NiU)t!E6$kyhddIWPEISJyJs`JY*-)KiyNWs)w3 zWdEu)2RA5Da8ce_3E*e(wMqCr%QtA@Sv<4mfa$N-xP%RfX%m?RGM^p(=(1&GYxKh{ zAoFdGbo;KC-WBg9%q-h)bZXv{ zEKFqo&NA^;TJ>S=@Jf5IO7FkJVtz7s%^FW7z@zH;!>%n(UqFMt;PZDwN$imWiN<{B^?xV$vx9^sT-pjZjI@F z-T~zEHo+euUea`m_ysZ%#+wfFF}%#2p5MbTL7De>mhQuaHe zoicp0I>bou`U}Du^GV-uwE~lKmFQt9>9{g? zTyVk%EPY}p_`?e{t3sHO7pnr#g{R$IGdbzC?k7$UKc&G_!cx{RKu68|NUujbfF(kh zoZt5!Ia1yG-_%jC>pI#@0Ko`>X=zYZgmrs4#u%-ndWy5H#Mq^E2799dsG=vzDiS|{ z$D@FOJ`;M<}g zhOr5JRF0BmJNBGW(t@4LlBp9$CBI8;BBOKVP>GK`T(&_4_{ePyrt`yL!Rx)dBCB(Es7484XbKDX@SI-sP*jzQ%D9sBf4ek0` zsauPvv|9ZpjlI(w{{7)a>!L{xlQNn3;n=poi$Byia`GR3Z>|PFsuX-inKdX4n1f|Z zq$;T*uZQOcNac*+AcWEk?3muIO!IWrrqwNU;*_yUd5X8@5|`G;-S2{jV6I1_m7csV==1*! zafAekKpoZ%a7BEPW%?P6J9FG4i)|kp#i^Qzm-Rd>(RA$mTfpsAf&_O9ERLEeC(vXv zen_b^YNffj85P!0=EweK8^g8glflw_vxfHnA|PV19OmgjX(GOwt#Ycwut8wz>FwZ$z|QQ3 z=LU-^XyX%_!#UWA^Naen@+`lq+8*E6iDr{FA{9N{V4w{whVXyMV!%eA_sMNSD2>`R z9wK&#qSPdjiA_MIhF zg)_GaC9yE^3LNQ>xv!^2?Spatw`X=@TU<%({Q<^+-W-N&%HiIk=fKS5jU51!A*@GN+*%~DGsJB-V*?j4)!Fl2bz6vy zpQ3v2-UGaWzb53>@0G1>g^Z&JqSSF}Ft*HviQ2&M#&aa@&5l9p`{Pk7JxkO=zg8xg zDsyJN-QymnV=g1r4dcXmfj1}_o#7OdJWYnQ=%}yM`2nw`!JE*0*7URhTFsva-dKX8 z84=(LS`AjSODNH5cj;FtCjU?e?A3EGF1P|xBVv(TF;$R2+8YWd4qrq5>yoT2OpD(w zw%W_1k=4SHMc*0UNU)X1^TMa-XjY7*v~A3-l!X?EF07aolmRC#Y^ifZ>`*Y%m0%Z& zwiOqQa4sz;cqLH&6LZ#J`*B(-bqetRcUn}8SaWM(J7ZD*G%U~?pw#lO1M%#4TfsHT zCwlSVb*Z@<`${=PnSs1`DBAYmD07J(UVDatbPpgbjYgI@U7MRdmq1E_EVwkoe1*^l-=Xes)m*&ByYyWJc3saJaDfPI3Tr;dRe8F3Yglz18V8DKH zZSkmlP%^O3@55J;-}R;|Q-_a}xNWFQBOv?+%&Mfia`xZaaifs$=4h}e7-r0!q(CY} zD^)U`%S@f%N7K^S(d(92g)I!g4AWdfZ=6ZlMz`%g-Wyj?sSG+^_y)RAsGA>-sVk)J z|6-&0zG`2{z61DYOD%od=`_}0QQqM1axBPWkkXJJSW@=)%1!=_s|%o-5X{WlNFm>e zyXD2dP_vy23!u!#XdKSp6fT{~GInCa+KZc07FeC2(s6DghQ|mnqEZMZ>-pMq3+F(OC#)c&^R_7qcD*Oq3mO8(FnG~+n3xfDiBt|~JUvAV1E zYt&aO>*|hg;9pbe!c3a$mw4xV3odP2*dCx(~UVO zQ(9`=$%U9TOfX4w*d!FRu}i&0Sh@LvADby;6qoTUA-3pkc-_KV+?3fO$SLy`Ehi=@ z_<1E6EvBKbGs!A$J8kGf0u^Lg2al}7hHv@&Z6mtOYwpR z%BUGdex3z8k%3Y|?7;xmkiV=5m4&=yCtnohX6)QTQx+iOSe6p7j=X*(ua9FVCTpeJ zJ~5ZNt73>(K^A^L+s-+atSk}3R~ z&Oc9;a={`jjBiZGvKQ_&G-S+z2?W>T#X!KG&L!krq{Gv!;bB*tca}ydrKg&S2hMmO{kg7idko5@9oONX zGT-ZshB?U~eoKFzWD!Ykb-uo|5aQNOve(8bAC=tP+@T zm7fRogA$)0`~A*xREyr%3s6=-r2pyXCdn`p@N{0wah5~;X_GctDd|lUq_waksnXDG zkUa;>wUTIMxVG~+;2qk%s1J$I>a#e7$IPvEmK>hm@HK`0kXD#y$1Mr&1ZCl(g!BTytPR9!6G zqO3rvt2b=|&MSS{U1PF>MAN*q0%w5ioArJ&--IfaKz^v&lN`TyvyU9 zPVSXJE$6z3Z4_eiepwQ4UeHxvSnm%k!0MlOD01TCE0~qv%b1|kv6~8#@Q!7@Owt!z z4JxO1=;n;@YIlm9g_ztWq@XP^{LY8%M_XKb%6Ua7nWVL{%blStqU{mm!?0GSC9kKW z`#=I;`=*OK^$8N9A3xigFHPy_%YwGNWitR_aDR@V_BaTb6P&yD-TyKZ<}#1X69nrin~3;gp2gVqe)+9MV*KAV<`sN^leD2X)TAx> z=Sf}2p`!Ku(VA@4eX!0aAqyNEzGv^9lpjm|Jel6$+)H&qgUP+kspGg%J?6Z15rgy) z?uaQI)*l0<@FPX!a_AbFi@vrA6cPnJU2J-Hy|gSf{T!nhk<1Tba-L6&qd8~4b^WS` zUxH46^Mf3*0;iy}h*ZT_nyDdn@X$-BIiVxC^3WZo%x}>pS{0d~1zujY-0>*4FwmQQ z?&y@OooWN02@Drxy1xuBM*;c(3LH&L=&TOSV;b|Yi`}SrG-mD6?2#9dnoa@onLkykV~~Z!UWyG*`^g?#DdpAvd6~gMZw;n&l^?B_3b^fpiAi7 zk* zVSm9*z`zZG8x{jj@XeE~EGxNZmN!F?_2AOp9&~6+bx}nPxSFe<&9FnwMP}?C-2IA! zB@_qp+dD(DWcfAWN3{jpnpFAW-;L>zpn&10As!3Oa*viPnxUFoTj>t~n%X1Dw^P4g zfyEALTgerf!iTs<104W#RiQ_~0w(K`j3b!5#l^|~zo-8n80O~Y#0+ z)YmCz;o1A|;`{f)!p83F?%(=X|D8n+j?>AAKA0CJ-6on<{At=D$TTpji*qX|AYh>) zBtj%Asi6rAFyWq%-*wcc?4ScEs8#(3K_r>~##8h%b!ZY*5yC2d(ZvM}5)uehlnhLi zG{}Ee8zQAcMiI=5(-FTg%F}upv$;mkf2I1no;=w@Pl3M z-8vyhfvc{7MB(j&2;i=MD78Knfe`l_XMv&apubRW7;pE2iEaY9La(lh9GH@N8OL^z z_koML*lsGw?cu|D!dIij(@a!UcJPm&aBQ6gSo;_ZFbzOqGws^lB zMt4ys9Ip`W@4#%Se#3>Up?=o5Lz01zi@LIsx}borfPp^$ao_(c7#+ic{u-mb)k{1h zog;>h03lRy3iC!fE={Av$&o21*EgcZ5a*-Ynh)`zh?)N6h>ceE3ax2t4`y)hGj806rq~j}(V~ zClOpiyFPxxg^)KJr_fKI8YM*Vh8#Z|^^wSflYfmffbO=wNu$3q zlw`jMfy05m5{iD8fy9Bnl75kt!MnalVL+5opddam8KY>X(T^=`e;Z}cz+JxmrGJf- z%)7mRbRlXiuwtB*J_C_UfC9QupA50n(Se=65_`au6{P+Q3Wq5ZRHcJ|6WkT9{@A}a z_I5sojVh16n_4S{zU%%R9sGBB&^6S+oXB+-gO0^XOsDodL?bb%vtl^qYW7Wu4xUeQ8@ z2f<3qY;tSiSx$L%voyNk*J6H)DDvx(%vR4URx?s)FSWmq+|#-FEo$m=tS$PTrL`4o zvbiw^Bgdbbpk}q#MN1V^(9fmYjSh^Xe~;)2D=!8tmQrrI$fTYcDD?5MaP-J7&Ce6y z*PdXu_{`!(QmUokmuX>-G;-+%x?gEK$82xey9euW!oLdq4c}ob0pj^L$tx2}1?a4j zE}2=W@-3oyL!N`O5G?;l%1wCq8jWZt0*KGBQ7s;W?3TGl$|ylgevG>xXhUO9Tczmt z-Y*KG*9;4EtZ^_*zmf6yc%oT4(Q)@caW{4+eYwSq+xTmw$+wgaDrOG1;oYDDR~7*| z{azEu-1an9#05924rIE0RLDyhCK426VprhOjVuF`dvEqYol{?Pdx~!_^UjiyB%ghf z|J5AxdFSofe47kij(pXE0{q?7czE4e*N;jp$+LMxm+dQufxj;2+2N^l`577WL=jG_`E5MfB`;Y)C-=#Qg)6_2 zO{gLKUpp0L4OG8o9`ba!9pp=hWc{vl&n->ms<~o1s3PJ$MvLKdcICG1o?{idQ-BKk zjg}8$rRq>eDZ6Yd9GcO}0h*x+?%c+;Jwbqx8kp7|$>eEs;%xCr$o?|aAUZV$#)@0~O?PWL97l?{sd6vjq4!H!E zA)J{RjRf|9mM~O&zu!g5JD@~-cR zo1>g@_0&(~ULXQAfMUJZ>vRa;hrKu__#u0Pj%2&k2I@75aU0oH)L8`+@{A!m<|yuV3SG34p%A z`lZig56HZ##!v6`pT%~{*MFtGJx~#IE#&KwF`A7Ffou&^GvO+8j%-*b{sdt^Om_kN z?G(~?am=XOK0-r*VZVL$xxoXuIWw<5gC_wO!!cN`eaNu-EoV>P4dMwsvG zVl0;OXsOf=)`Eb(edIXrAE!aNhLo$!I#|x;1nrBx{GBwE_ye6S!r&8=kvOV35Ke4JFhb>| z#TqAhAv{j(PP{?#5uzAIR^6I=0Z~4`M)3vCaC0TcW@W=9&RuuFLx;JTocuyed?0Jy z*)s^Q4b=GXfPDZKe6=&UHUI z*2Ki^xBe1Q`*zH{RsW(9aC*=FttDV^d`k@?%Aw}1&8p2}Po2$;^R1Wm3~!gL@(lXw zkq4{m)2a`}>1MqUMqB9=#>lFm0l>V?L+@g-$D=H~$Xr`La77DD#X+cFqU5lMQ3}~` z2u#WBIad}*1-fmj)o~g_>3c`_&UVtK(muKw7~k8mel=2_;p%$Z_c2}Iq-LfQLGGP-9!V9O(n{j zZ72p>$v(ZgS^VrTPEVQcc!5Z69fv6$(H_?LBx5i!J5zD+0B;2#b53U)+2kwR5EgXB zeL;A2(v&?BcrUYPfwzf6PCtLJAokj3m}8v0`Xkf3o^jQ(Z@L>GnWHG2fAHxhC%Y%1 z@CxZ-&rPvqoFmT`m&vs)7wX1PG{px?GdPYM`Lv1j(8di3-#`uviGvM???O{dt16uR=--0!7nb#kExGL-{;`=A@yOkB+j6_on2iYQ35;e;7peT zudvBhm=%B8fd)L|%gyt8(|*msL%z(5R@h_3{ZJyi^vmD{y`i?`*c4=n_JC%n9A zqD{zf4(q4%#C;okmfA@HaZ1lKG|DDVOnp&oL}EM^-JJ$R)sd z#emc!aTJ3^Q&IyrZl!S9REN20%5ZrgpkF$8P3vv$wVys!_Mp}0>kY1$)Vaj!rx%$#+jSTYr z8_mK*TlQFc!Q(OM03vYrUb(Tx=h_c6KoxaLRh)yUF(P~Rb00kr{xh4Jp^HTu^i4@! z6;>9kUQVa1&c6#E?|L%qQjFvQ{$Ju7HRWOk#_ZAActCk32`>5Hy9NKuC&M3dDPNJF zt$=aJLu2;r-O3Y%LQih}8dhE6x5EzAMuuZ#MMAx|s-64(m=V&A(skZMpKr34NZ02c zn(`%+PcCLe+H<13b)(`_n1iHkC8f8GW%{uNaUh-9e)PCkJ2P8w+A>}9*X(Oyx zyQ8J9eDk7_^2#Iwm*a>eB>F>^6!(DEh25XI&MSKKS~)tR>lMcYPe(*YsjR zYJUJ_2@0mn(WDP9hh66&9G(YrTyVc%qf^v@8i*v4#6V)l@cLJp+a=1@E>B6tA=~@_ zy{8}_ijq*Xj<{uNNmU%v^rheGv2tcZZeHaMWDJ4DCCh z!)yR_xU%-{gJfC{0m6L)=I-U|D7pN@x*G7f2%NXA@r}d*wKWu$ z*Tu-mABEv9b4ez~D=49}&|~9f2^MWoG86g0_Ls1ERw2WNqvPC?NaB9v?|dEJtYoNS zd^lANzX7LQAweA>t#NDGp11o%M;^~!O7Zw?`I!Md0xgpqyJPfSItdwX9mILrDtIl) z-rxTsB^;|8$|;W9CHxFLg2oU>=yX>PB;W>qrTw@;<(s8!at4z_H ztP%~*58I6U(~i?KE2<@{Zl?58S}ImOU{Iu}(~hs3de+04PNp+_ZomHLx>@h}e8pZV z0TY5gg04ZTDG)dssS_w-)7Ly$=hh60ZeE3#gw8WG#i4W4EI=<)dz>$cM`eN_DAOc7_un$m&6+@&(}HbfiGkFkYJFT470kJn=@sSmbPO` z=Ed{o@D$WuT20VfEvlWvH%~KN0eoXe-RbZPD$f4u-xwu}hhy)$9mv2WvEKbx0G}lQ zI+UQWmqd+{%gKeZKE-YIln*a~$sP4HH|b4#&W)xblj=ZPnc%R~raEUc0qYHihWv&^|K(#ZO6G2w zJB4q^N?EORefk>+XQ<8!=EAmkfrdyc&XN;?Hu0&i@B-iYVOh(vO*JKvt#=YP?hADZ z*6sg_2Mm<3hm?|EZ2@(q!CH%J zBT?DoZL!bifhWYoZTfg$=|-}!%V0;nd9tv;4wtX_P%p3jYQ z`;DYGc2y%A4|)MI;wS#Y|6yMNmt&9Xd#L4u+6asgQRy?|O@x-ghJs7q+OkzRF2QNo z$U8}e6*MBRA}vah;80n8X(bGoTmGwk&9hSegf8MKl)KtfN#2lIiqJmz-(9kwex-zr zi;i>Ac57#R=}gn1elPTNpUp-+T^&9qIwtC|p)%@?6893dyFVCG=X{qYugS8ge;yRs z)R@z;^k*l}2%V;qG=T>JfdY6Y-g$hmFvafI2nItvT5t6}-n~`!$$>f??T;8blL~pr z>lTrlL;64{!O3%sQ*el2#Vw1|)H{>TQ-F3Sd=k#FTbF-9K6<% zF)+-+>jC>0Oo+DP3uYqk($t;T=>5l?fvu+g_`R*0$mFTS-8%{~_;zGW)!3_;_sZ$8 zyF~j$`9kCWdlX1|Zj7$L3Z+v2u}+uVt7JGPHe0iJfUT!rqmmwN=heQWgfkmcyXT`< z>A&~I>)-RBisl;-c?K3#N%@t*5_@+YG84~QoucS0Huu-L)-u$J(?<{Jbb0JPd!YGf z&vxJmU#L(|Q9L%m7Sa8WeHa!bA=)Cu*_Qr(ct%|z?2 zZB1M#W@utKC@_zdM~ zT|2!1$qJ-wXWpS5VaylI(%zywB8|=zdAPN@A?`*#JM+IH!DwVBfNY*R5~@Tte?%aH z2ro0!$gSeVN<7&VpOV4`ygm7<_#*gr$9#L*7_17$D=}PAR+auX{Qy>(!R3VHzM*D? z;>W@WlYraHY_`YMEi_$ha{EnV8F=`4McuiZs?6`BkU{0`@-E03rm?Wbo!iX1gKD_Z zP+Kpxq{Vpszz9RLCu#g>nU6e#71R{D`vNW#i&y3Rn|~R#o6N*m0RL%;xb!gBc9QsL zv5uy=_q-KAFyrdcB@%q!1Z1{LkpH3?v;w5VEXL8tQuDnqnSOv{9Y|d!83|at!ST$W zp?oSpwjMAKt9~^{&RHdh6K)B&dV=z6c>2uGmuOP{d=dQP50)2h)*AD382Gr(AeWVA zxA^o7p6SZryPpe99-&aW#7_&U7Yp%sNwYjujCn7j%wc`Zhe=_Xl2rE^vONdWLEEn$ z`qD97uit*OOY{=q9G#%PmcrVnxpuiz+_pe=Z}T8vH-Bw;XoL7SoXk_gIc(k8E=8YZ zU+UObxmWBm;0$!OIaHDTvhi(Gad(P-)|aH9vUGr;`i~o#s~o4=Qq2`K^?L=cbYeBW z#50te20q-#9wW7MYT9dan58ZVmNY2oSM1Cqg*Ak3yzUQb!;!b%(vp1lr>#dYbF1N-D;;Jf>2fr&DG zt6hqDg}FqX(&MMFc9;bG2RTiUIZWGaqvx}La!M4_3GQFDJ6j)Ndbh_GK@@1fn|8_U z2B7kH)@VCu`)YdN>@LF;(F=_melb38XO!mk`HyUPo$Hthcpl+t#>M^Q1STyVL(nR6 zJ@UPTG`-afexcVtWj*K(N1<8UWpXcfx;PFe2K9Wby{&5403MJG?whs#q>kjmC8uql zlH<4}H>0YA9AG`DwAw?>nQ%r^fw-HzOifDwAWQdCvK}%!ZmT0ia6RGGhRU<-56Gp+ zapzyp)-M6&;)e)Cv@!dzV7vCOY|fv2SBt;{@bcR!U%ok_8YAa>B$II=4${o`4m4UZ zdG29J9-`ja@_YK-PEz-(+I4SA@fsf#haHEZxYt3_@q7Z-1qA8U6aLa@7WM3+BIqSOBf~%i%>HBt0@msLu$(IE*Yzj~dP%jv_P|0D|HE z*{CRbU4DmJt)eV-{6Ba{%%!#AGwn$Ce1yVU@e@eds$crcid`$imAw!oJDR-YN2#M< z0p~!g2EC!bytF=wq87i8Ik;53JTK#D~;Er49H} zZTnT1qB|tyfFK#5<-Z+ju}{s^@(2u;znhY$a633f27O{r{*Jx=OWwxWVZF z#uS6NP&*zncenjx2b<--qs)G!WN^&st>$j%Z=g$eG#!r|l0IK9P2yEb*1cS&H^IQ* z9+Eui$;RRfSWt#4q&KZ4f6F&xv+OW&>XG_>gRlO&Z=%=_z!2Ri8XsSkm0{%b$+|X@)pb4n_>(CgG)iy)i1hBPr4d?6$E`HGRhiBl6}B9`x9&3+kj- zc{EugYt&lrR)jhqIwzMCb{1!~e^oZTkuN$aR*}Z$5Utw=x`&49uR3pN0R!XJ-+@-@ zQ3c3fEvN5ZD4f+h2t{6YF5j9ttY_JuH(wm>u<>DcmP9{!81D$E;aVS|xS5%geia(X znFBdaJsj82@+`rop|+QnpQ{YulIwe2wdFy)IgHp}P~^QSt5AKeibp|eMTuB>Kx?$i z7m+BaK|L%Hk=fTj9d~|%L_RsOHz`y;{2i6)yj=rIwWvecBsBF&iO+D?g0KI5rz=)JF5h$-5}aV5Xu zkf}xjhl*SFo@v;${#CipZi*n+`z)8AwB}mL!Zi72<2|wQ>p*5~bwoZl0y~c7AIOXw zTVA@ScN6wm-v$ks#bPAS7)<8dW?R@rl;ATZqOpE8H#l~%6q`?V0h1g?8!CG6x z_`JNG#b;t3fggD{Ze~qgXPHsFf7IsSle5x|9#;r$^TPAn1^}T%#Z^*!{jKv}N{NXz zfmx-Op^Vpt?-O#eiK=m%@~_n^mKIn%Z5}JHDlD;2ghoRll zl{Q|)Bhl0GE1cFq?cq}%^YP(G3*fB5v@|#8V#r)DAg7|2@#4P#636P^sDVY_92V2k z7CoXgnMTi%0Y8WTd|Auy4z8mm65jy_QOi*v9W-EeDGj_BD;5%_%C0Dz7ltxE16Oj+ z5-S8liz9YX9*plOT9p_lJ}Vw=^FI#a->m#Yy54tlAk*&p$Jm>J-G(|xt+9ox|a+~cm7ch zq%8}_h{#Jr-yNm*)O)FDv(nHWiopVxg^5U-hTBx}-DGn+KOWv{HaZk}1u_afTp zI5~D8o{!L(sEqS_6)j}I3o1kX<9O#a7yJvCw3ww@0=PE*R|4BQd0L{E+);_Kz|pzqb2^f`79XhbyIuu{w zmB=JKAg_|Y#E99eMezV7t1&aAA?EMW0B;D_G-%Z^M>2>Wnh>{3 zPu_gvxW~K>{WD;O$1ziUq%Og?4eVIx=JUP}V2cEa7P-XMQQ90C!GAhh?PO>`!H zf%)7Uk$3O(M6ia$_Vn`Z9g8GnErZ zHN3Iw&dx`9`+=^!5=j6s`l(J{I_NOFl*ytWuU#)G>gGcF`4>h00(qOxa)@z9!V1^k zbu>=kV$A?Q7DCQ(Lkyq%zX#E9S)4>$)BU^XCeO<|8`zA_Os2<+pL~}k)+zsLT`1HQ zK*J_@W^>H|0K>9ccQ71JSak{X3#{{+H*sdF>5R_!6Ro&0H~J_(&eTao81e`dmAH~e ztl2QH8Gk1V8LtOF`JBJH;z;y%5@FX8JE@hE0>qvCXioaaZv0CsWn9Z`&`l>(UVP$G z8XawyLD;+VG^h2H zU;AIu`fX|F-`+%y&sLy&4}R1Ua(y@0WpmPMY{cGOpraQQ(c$_1MeAZptZsA|z9aFV#S=3vdPa$=LY;4!hnG4(kB(KXBZGHJ@8pY0gq%XNRC zl0!H54bTq*Vdf6`S|j04u16vqeNTMms-G2sP}BA(_>uTd)PBM3unI};o>d6WFLxIs zI?CXl(_l=hs_-=$Ot}U6nbSlo>zBWHG=phA+p}2$=KAFnjcn^*dv8#r zQE6^hazY&8rIbxP8Fm?Ck6SB+lQ|5#)@q*3ioPN=Mm)fgEJ7+2&cu2jWe>|&)@xW{ z(d^NV#EZn$JVa$p+9qL4S8Qbrf$cm2E&l01^=J*LN?uj-`#i9bBRgJt6xF;C18xd_ zqzmg;(+K8EF!r}T-2SnQ2@)|mt9g6q@hld%1#xWtJUT@3xq;8!uaqrca;*Qf&NmRW ztyMERU;mtd#9qc)0V`evo5ifx_=p}?k<9p8P}vKUYtl)t#Fvh@^>7;m&*LCHGI@@3 zKD`i5xOFlo zeqc$Hwrb(is?kr>qXTAbM?NQS6vVP_RhH}-Ghw)aZ;|R?#%LaOwaV+c*X_trzwU|9 z`a~sdO4n|Mp|MDQw&&0%>qI~P!yvO*Kz7BVaSz7+dm&>G^&0Sfjs0+qZNCASw#DFi z3ii0ZcQ6nCscM&b3F&W2xv|ze&~5V1{#EK| z@w>NZagi5-*F`eTLR*-@&${(*MNUzE)7orchbDVbv*1GYS^ZIO1dj`B$70k~A<+p* zs7H*6^qb)duexG((FokN0#N{HpdDB%r9$#T?&kytLSlO3?zk#!^tVUDkct7#Z z)Lzn~`dJ&|$a*u{1t$`}t-qe7ix=6#EFCJ`PoTC~2rk5uX+fu%lr>#7ne0xAO;!F; ztR2^=k|7_g#$uS>eJtVTgC6|Q7D1ZE^rCRhRKlG44j23v3II^xw-fvi;f|T%zl1v$ zrvFjwm69tb)ce^cFRt?PPuQpt+qQ&tABYqUvJlYzv~#zF(1ab`>y(^7$~yC z^3W*&6_!@i(7^x#0=oqA0q~%s5J7H$exzeY4S`{F;K1|MhhXF9v}TVI0q9< ze)xdat~mj|4h{;pdItd?YV_g5c_E9ifd%&RU3%Y?f;@dMV^*(+pUmsz z3hD4Hd-VN?KrZ%QpacDrF|!y@4zEC!)ZfQ}D*NAmoqz@b2Lu=u1sMqduHXPZH@F|a zrRJvO#2Fso>HCn6V8Qx$yZQtHe>d;!Amj4z_W@`;fwq@c04VE?@JKSQB;O7|Nn{`EPnpCrfL~j0?*9 zp26?^tf8P7^aT9#Dg4C+Fv5!}<2eLSJRm;YQh)b;u|Msq@gN@5?fU$XDui(j0DSlG zVa6suvBO^Vn)H9IOgI33=?Z{_9Wi0_f5Sf11PtF9bhbEtUt1s*k9C?ol zVohZN9GzUR}Krj1w2zzyLj8PEY^w^G8*7*f{ zsB*_5z8M2}5~v}5dAIbKFxriOZ-g-|;ho-^V}J&T0OG^I$Kc^5A&N*~Aoj#-s)5&D z*>?fGyA&{RFo6UN;ea>>cW-yZJ=SRbFd?;?rgD4=`wve*t~&@H1kx$&z^*%oH&pT$oQKT&4GdMRP+3pvku>> z&UBspNol9^Ma>$`b4J-htW7iR0kvLYT=|65xnrof;$Yn1&FkqD$dQ3O5o|;f{f!3y}^uzb=)E##tNr=b%rk<6gCiW-%sii*Qe3M*?LF9MSr5tMIj z+c)fxQID_v#?g?f+xDaF4_C3k8OV^QgB^W8oksqVs3QD;M;FMD60d^Mjd?ae_`KlBU3Vv>+%K*+^&+nKpUaqJ$YWYy)nz!k@S z>P{cE(|hZ|g_`(T|2ZZ5Y&pI`A+ugI3xD?jEr;};$uRwG6&SvPnQN3w;_fKj+s>5^ zh*B?OG^LqyD#U}RxRq|r{$D~%k1vC-MKQ5)g{=(IotjMP9CVBPiV{D7=Z^B1uKt4PTCk?0QrNHl)i=I(=UM7{bgxufPY;-n9w87FWz zMEkO>Q=85&#&aF}XMgS#Ty|n}$%=dRs%^wo+I51y9N{wSFPXzq$6tI9bIQMz_@(I~ zm325iy~oQ?|6X!Ev(t8flkK+|^gl-pHneBY1ZN#e$028oeIy}O@ZjIrUK1!U2s?*T zt6N5(GBsJ`C^b-X1MRGnIY*SlD+9n>S5K$#sMMA>A04+a&R-k3i=8=>KsrqK_}dS= zbaJ^gX-5TTw98GCb2ONEYfsc@6T$a{p|kpW^iJ(3zf}Rc;V6U6hw@LoGpYTJ8UMCE zjBOIAr6QSa*?06}Una{IP{e(Xw72Ooa%VBm!Xo)fMGVS1ZL%nrZa5BoF_?E6e!rQ? z!xaZ@)Gb-L>B1r`lN+WXORc1kk(n>^VWp|1h^fK_R}^r^AuS-eY!y9x`%=hGglDGO z6_9FKRzlf7%6m7TU;C7!I#EGr%G_DA2sDa(OK3D`eW^#3O|A{1^23v||I4-VMT6b} zIqfTer%5HIz#3&MyzlP65X;-Cs9<-I@$!*jJ8>8Ab6Ion(QQjG;gMtlA5|D)JT&}5{(j5RRhRQ6gbL#YxoFy`u*J+k0#^n{t#_g3owtI1+B_|5s)?Iy z5(8`C(_X>zJUsHJ8dXPSb!Ome9O+r0x-Y+}=Ustl@~XT5yA{qs@l`4|ZdX!&y_jR1 z_(pvuK~ULa3f(T_QwClX5xw<~%TDPku{AYqRPG`y9B!&yJAJX-qq!p!|@r!a;hlFE7^Q|P}om_N~Z)1nE+#CX}Sh)m- zdbf8=kU=fEff?^a31=QvDRot=S+ROBT9}TUM9vUKE`3afhPX8nXw<&-gmEJDWn8^V zj7&eHIHw*s6@Qx5?())Q@n)+Kjf+Y(f=x?;wK!bg#;*ocf)Y0C|dTcV>0d?`oA! z4^!s%3h;ozs0>l~y#((hAzS(JAgtlw#+CX$2b34@`19#F#Hb0I5xBb#2=0{qyfCkF z3Q1N2x;jtSTentxP5NeGPu|1bBW?4`iiX)-$<}im=A?`)?^Y6lCtv`C6N6KL7bluq zpB~5gTga}0HJeH*L;90qn(@EX7_Q{Hs)7{D42f0W!z@N?2#?yAEmiT-9|&e;LUnCD zb1lC@@D|b!+_HWwie!|ViZ`dBC*NxpQ)g1EN}li9Ntq+f7!{PB?VhK&(Vnq8;PAKI2LDspyZ?Ytm_ujOdMJd zSmm72kN}m_TfhKB@x|H&Tn&7P&}VZ(Vy0;C+)&alrQE+vb$R zef4=iNZdC_?vyy_N!KY z%WPF8JLO>c_(wW&VX+*x<*v&(iPn|G*v(%Jirt_5=P>dnyq61Ge5iQm^Wnqvd5m9E zmJk#rMjf_FIsYtquWSm-FC2c1=!41{{Zh#H@=O8}>lp^#7qDYcOuN)Fo#$dW?bPYV zEJrH*PHkk8re(I{W8-mA+%g%iW)q>%U=*1Vo?gJGbEdcxP0g{v%%0D!q>sh$ zr)S&{Pck@+EDF&_A_vDkrOW1Ts8y_^7mbX}u^oAfSgDp2(^lDRMcNeY#=RL3Kl52k1e$Ra+aK@+n*|_f<(Iz5G~}MJylg@0bz`4ql0wFqP{6OW1F*Q!Ss&jaR+y0HB|KfJ6Moxv_^#yl}Fq7hiM4#-YQB!I7TvNe)QfvfO zVbqk--@1FhCfiKJ_`U|XO{xe1@pTRh^1P{#u3@6A0^n<^4-hDr=mSO7^CL2?Zp&eE z^-F(3>R6kl3}`SnFJzeXx{Oc>b9@4(9dNjG?Jf9ZY_bBnROBw{HUMfAk{h?E9D)H< zls&HjZJv@0HL7f|k{k((Qg!J6agJGJIPxX(=_gY3JrJIX|EyT zkXvHw#y#nva>Y~`h>}RxlPKd(&Pta{lE5&)laGzPMi1jpF6c{zB{>%-FPDPTX*F!YN6hB1V zec6QWsXRSJ2nM73kX}uCp@bJ4rAvU#Cc&&Z`Phrbkdb>;q<%iVhkkl|Wvw+FGg~nu zGvlBPFTFJlV5()C{Mz0yg&L0IcirEpH?2+9^s^!K5ufA3$ z6D>D#Ci!EEVfkQwIxs0i>U|dC2>cQ4MyIznuiK?ujEm$s;p7X*aoeYpHuo{4U|Ek| zoUC+EUPs{$E!X?#myC)k}zG)Rgw@0Ial6~{G8`S|IZ+wjS5ZX+deMq=BnmcEks zDTBj(Y59!-4;$XAZMQJ*4o#Gsdukewha%Q!o!jmYN=fp3!%f85`^E1^NV_b@sU$=%)QH*j107pC#A463 zrC91q8#DpA-wOuw$Rts#7M1TBg^Pu8X$me`5^Bc#tV->gwM-I1c7*E0oy99j){OP|K6Mtq=~qNAO*V1TH(loOXOZH`>l_TU zGTF`+CN=u=)OY~SSv6%TzQii@yKFom;}$f3nnQtq+QlOP^#gwQgc^8JPHK^um6z6_ zGH2-zr4gWe+}A1{ijLJ}S@z9f1oOz4{wnfcFIze3gr)Yk6OZYkNBq<{0Vtxj#(8n} z-A9ov&V>vK&!^L+Gq~Q7KlSeDCb(Qze4Zbo1r3R}=Z#Q6?IKR+asvT!1%unfEt~-- zBrpRZ^-UH~$XBBN8eodb6v`Q?f?0Hmpl?r^#!fvlk&&omGLV>S!IUf`orN_w1?pH< zn{n>5ghmYLO)M~rOB}J>7CSeb8WkMjzF5y) zbNtT(?J%n+ig@RTURxrmcg^5*`Zhmhx%2A?{1pl?CmtCu#jWNd;$~MMQXXJ!;@%C{ zd^5UzZ`~0Puh;VP?N{l=HM!eoyoEqRyN4D{l>LrWQXgFLT)dq!^OWmi|1 zy0pjWJg#Y<^LJ07ij;)MJhN7n797P~Z0L_t(A|&#&@XqT?!$D zDdXLy;FTMxZv-54YjI-Lg)d_nXKJW*pf9T~E{Hs7UsB z=_EbeOPQIzisWc^P^lO4#>6@_BU9x?qdbJO^z^-uz^N>BnaL`9YA@=WvfJ{ls0D^; zHlONsBDV<{E5mp0lJ9*yHEhL>4V&h|h{`QlGId7Qb+C1Zve4U*PRXWU+CA$XQJ|J* zWZY`iq?7F$JHSJ2kR)M}#!+i1!C*kU&H1XI6=X?{X(1f9eOK3lY1S5t@i1f?m4Z=A zbI^-KKC*Jn1~F?!(QUyyt1%;I-ntb()7;=kUsSFnZYCI{5mS{NGUzQ{r&32l;j0@Q zv{6G_Ku%7_zmJlD3loRcDJs!l2UWEcf<9wuf>S_Cb1DY$H2;FS$b>ZULzaIUF3-jQ z;%VI9j}8AV%ju2%r()I$&lxGbU^L$RNwC%!5}Q)MgVZxwF5Ceb>Du&8GZZ9+&j8mB zaMj^?L`hq01~9FiWeFE=y}?$>`6lts|M75@?smG_#?2tG`w{!C8>>o`*@gT=yzL+* z?|?jOEINsB3?{DG|E>u~+6$2YP}r?!cn27G)J+XuBodD`$|d5`;G^>3USdJMiT}@dJ#0Iq4BYd{vak+0+gPc#h2h-E z{C*P1SKUwQ=vzwIw23G_D{9P270{En|BYc z#16uqN^6MjZ5;hXh}xkayH$rBXtmH)Gma%IX%a^J(Wo0? zMEm_+TXd})vE^lWJoF+4Vr>N$gm>4IpzWP+hVU3&d<-xpsd_5NlZS}u zXMQPh_B7~ZxuucinXoZci8w0ea8X@f0yPmWPd}i9`E77faRP!Cw?Vp*drmYuo-Ds@ zku#(wP-PJ#(0ChVi#3Vl!5cGWDZX34mlW$}p))Q`aiuB-Hi>SSC!O7OMDoc(ml}rp*Q+h@+z^ADWhb55LmUMCQ+|yAd0Ww3 z!%6QYJ%hdp+=xb_;sAM>wcO6cBrMjjO^fJ9xlw1(>oK3~H+oqe@PZ0@l{H((( z-fMJ8`7c#&oUQ@Zzth&C4-S^d5F51CfeTV&CUNSz3=;)PE>ZrUGkFVt-FTTpIiC2h zih~<=O1s0>f(;NK_GFkaA`?>NE;Ya&6&apvY9Xay2ED1J7(;~@DEX;Zf*k{f7F(=!zryHio^ejrO|D4xl>04GD zQIAF$trgw;O&}%F4ioJvq?*~3p9Hj<<7?0MvDBV|pC`ebO#=a)g1y~piBmOo@5fMIlc@LfQyEHLzKG!B#Yh3Z`5 z(ynfL47Iuf11W1;9e>ej6Uj1y4n0YBwvLzY4wf7dd%(V+UB@b+K)n-l(nd0RWYJv( zD`F-j`B=%Ak(P$_=-n3Z0T8w|>b|^pt9=EB3K)=QMe?=L1eyvNpoX}Z6+}508db#u zy^yaHnO(||NHM)QmK0d%p01^89h6Pp3?@L-oA`3Wrw*pEeGfvQ1^wgtm;19IEVFF9 z{0>&CGAwvUYnmO-QPR}rfaXL?2Z=D|C)hph0D>YTk%Ya4H!a3vgeIGL=AA_9`TEU@ ztId^&P!H}Wlpl<-pDhZL8EqyFy~FgHj@`uWrrY-Rk=&&QhM#1CzpMfG6OHPX-}L*d z^}paG(|^H9R<{2IC)qienEne+a&WNy-{E8{r~-;EI-8tSkVINlG7F8)KMGmA)Id`= zq$C~WOubDhK@9s3P5y(FNdMk~Ot)Up@4SBhn)TSZn!fU#@|kB!p;#Ve|+qJY>tJvur%J?b+vT?p*E#`jLGMSCKcp_c*69PvXi%^)D) z7$kxABl4(%V+f2d!vP$D0)UG62NG><0pQu%?)OH(%@6@-#$zu5!US>4&sWowQX&0a|*uDWy8&=9nf3>xKV6j<%2o|aC8dN0Q7O>S*ZVV7Gu61r8{X7K>)c&MPa6k%a>ifZ7ed~Y(>BICyV>82mi13cUg4Y5k z5CgYKK>!a*nE(hvdwLJreKQK;ZP2CAOE+mEHF_2Ztu)|`@eXyZVSRgaYrQk%&@Q3= zh^sf_&!r754B&3*uX=q*P>pq8qyq!X3DW3bE{-7-6F;JY>2<%&nu2=(zP5ydx`cQD zLy!RX0DqjmrD_k)A>OY+ewc_+-aNUvIDlvni3oZWq#+K#H#b3#zySMlbO?KPe$U_R zf?+{`X!7+r`fv(chUj5g&L0|UL++p6Fs@Wcet_hom9?eORngs9i|dkXl5`|!K^ z+S~B8tM%&#PjYK%_PRO!wfXz&5Oh`Gn(K#%P<;g@9vxBvY{;SiE4>`{g=wN14!X4b zl;si01tuTWxD}LgJrG!Z)>keDtbIq&qo&Oo9=1Q zH^`W37YKQql*OPEu{tx6txlJccL_R?wdPzV$*p7Tm&N(4TUlKFc*K30pR(If$QqZ^ z!!MpIbN3@D%PuQFuRzUyAI+;c3|isSRAj` z{4!H`|E4m4{g|q>FD+crH%2MvS7t zW4yucZkX`a@T95|r#i4&5iuD!hElnW?#6{?jO5Z&b%eOU-l7)?jxqerKM4~gEXFZV z{Gg(0mh~8dm)=8Ydw_(tA~3sPnLk|5-Qul2?Oo6jHL7bb)uO;p>u|n9Nsq#*UJBpzcf(XaE(n`!}jcoFpUQ4u6X#ho# z<1L2p-p1to#FX_11M6f_y8L z@_Q$8RYKo?M|z1lJmNke zI1%#L)@Uo{;~;dBB>;T*Gc(g|r`Oo;%}Q8=g79<^uhAX6piZ$X|2x);7_I&=MLdD8 zxQo2OoXESFZAa6x~i@aN38vTiQ3X7511bBw3a1v(Mqq#t5036 z9C^0k@RpLK7n?V-g$ZygPI2-+hlmm)$?mRbmYAM5;e*Lf7hF+B3~5Q!^|ZAF&vcPh z`A=aN9cL`6*VPek=ga-VZ_&S5R~|KI_6H)QmNkPz;=}WGjY93|+zie3m-zM;H%&|Q zPmxE$LyLZISK1Jg1bc7>U(idTp>&1zpSQwEe=bsVw6W`U;v8_ETuYV~ZCPjuJBBTe2as z6ha3gQpR_~P?nGy^;3h1dW`UvtbX+N3-%A{$4&~- z=|0A|Zss*onrn>Z{NEf|kOC1@4bT1We{36nI;`wS+}rYI{-~Nd(4G%2PQ=9oUv9#- z_>?mGuLV#x8^3U_@Vt~=oa69y6N>e#pF@%wg&SLu(HSb^2-QV7YDkr)IjxS$5wG)xHT<}w$KHJcp}c`n0TiLBFJq}) zux{EKxqek?2~w8bPMmjtG{W-q6(9E=jD?$te>#kBq%<+U@WO1EIw-gbuT)1Vf83Dy zy3kx3mKZzqKUCI|K3ecW2f5@TubE(~mWAE|TW8Rl24$0Bi-3*@J>L^!dMemowhTL2 zxGw-q#y%E_%-ijj2#b+mYePL7JX=_5fhAW)aebUhz1V!c<7z2#JBpm>4wQzZFS034 z@Ue)C@-)g4pPDGCXY)_^$`>)bFBV_k>P%vr+%#|ry3?sM< z;7g6=a}bO965*EI*;L9Hn8wM6zhf8z)$c_!=@2iLLWXh&3PCflFL<2Do8OC^(*34Y zbH=d?CHAAlB=Rrtq&dE~9cAAC-ZYOV;kGb&rNJgF#OR~kIP2&zEw%h0Sk9EZN#uc2 zCYfSbKrr!FvDvn*lD=`8kKY;5w1B_1U~IHG{)kBI;w3R5MVqfR8Jx9L81s2nr_jWg zbndVF*78>PO8n*P(3mZfAPEQ`ROPt~P&jI`yx6olQ$EMx$BTNAG^C>gJ8*Rv6BiA>K6o(OJx z`|wt&r~KF5v-vpTF^C3ZM;fjluk zF9oYtM)}i~jY%6AK%DTM8cZ9XINcZ;Utgt(DfBt3f`&;v%gR8`zZMh(_3XQ2>B|p? z5<-+FRK4z%gFnFh2R(JjIas4bJZUnXdRAv>H89$ zwWRIz}G0MD7g$+#9<_mAWB6YK@_WV?O9~H0ZQk zh4@0bw1iUk_UUOAyGL-OSriJm1~kOSv{J8tw0d5zIwQJBTwQ@qFrT)!Xie%AXmB>WNW~ zG+je7B=ht3?V*h9oI+exeZsuBx2IHl60R9fimP3`!c@er@qxP}_sDuoljVI@X-jqG zYy?+_rokWA9LuWIo_dCE$%~+9Zx5}80w33K$eG+DE4jh}&9w8AHDL#;N%E1UMrNsC zJMx|}9+kFgM^d|;+y#=D+`Hrmi|RSI4C3$DRpsUh6h-9xGGS2){)^hCT{uiW(lyV) zAw^(=IWKP8NeQ)}m={I;0Jv_4$-*Cs?Yw1_4 z2*BC`LO&h?Ey;1l1w|Q>s2(OjzkB6!u?r|{f4>1>(oaIKqjoKQaa9~>*T6dx;AFel zE-*zG#cVn)F_JRUmX=(L;_-|*^DZsBif$L7tQ_O=N{r{(Fd0UJ*ifhEF3){4SfES;qgOk?JZvPm?`4AMWutQ&Jn^SB81Akxj$do|nBs znk`W<;>KTSy*Ewm0w;)^rcBdvOgqABSr+FQZhaYDA%$maMEepSrz>{b8vCgdHRBN| zai0w{LmgS1w#52|!P$|pzivHUtu}3>&{dU%cN~##+XZ#g>T}+6t#lbFws{y}rE*T~jRm7!%N7$vR7fihkDNl_X^mVj2_Jhc zP`_f-4L>9<*D6Pc=28Uv0i8zb@Q2$ zqZ~S=iowr?RHS>H>U>5SfJe@MoSDl_a~$d->UY?>4OoySvXfQwYr^BYW104=tiln? z<1Lb%Q}ubrp)#uE=-l#9AM2v+05hb2H-$>b*(gr%de~+2ur1)K^L=+f7$@!Fr_Mes z?JBC|O7-@!Uva!T3nPreP8wSCIMUs9N zZ9JQuCM7ivToj^J-$k}zJ3lz7M?^>z+WY62jrKgH?B~7tfh%@SS)Y6{p6SyD)H}Xg zs1kD&sxA$=!uzeH6sEOSrVymmw`k<$%jLL1DuxkXZ=yCG)?20cCSz0Rc?KCMo0rNd z{~V8F`D>m-7i0MMJb&36(896(@2_hz1Aj2bBaLfC!L&^boar}lCPOTU`69B7^0q-u*6^Y*dkkA@( zy|Xzy%kFsh@TdJQHe&6cR#&9Koe9%&NW{ar^xzHSqcBq=X*fri1D4IwdrSR8P$oNk z>}#a_RH)*p!$Vy|9QMXjSxtfK5hUAg=1Wd$Zy6@*BT*U+Ame7PXC!mLWWrG@sG--# zOUO5plll{|Dw}b7lx&Uf}Ds&aj7s;tvn zqKzW?W(7Tg5_plyQ&rie-{-L0J<;@hEvic^Qn$Z*|F%+S@xu0W+g?cerfJMPUZT?I z@w6}o^o#K79VbTCDI0Volaj?q9bKw+o_Y5{+k!Of=sWNR2>`2@EbQED@w*Ykh}T21 z=o{5myS$EltHh%PyR5m##KatO0T%6y(^Sn7x!nN;LCIN`Y7P_=KEr+Q1dZ<@Y;F$+ zUtrGMRosIlNluT|mj@hY?-xf6_ngSa*f4bs15 zsA85VoR^_){mgZPma9%W<~Lo=7V3!Du1Ai0kJhj+z7B01RviGt?Udwc3GMk>z13xr z8NO(7gaO$ir83-FR7sCFxMwnMtSvJKhlvEO&LjA7Fp64?TEDYo?>=(sfV=|#oQ4~8 z4dT~!5PrVY<7UY{&Rn{f8nbdKN~vZ`rW10hsw&qqtl-oBgZ{AYt`(jDTT_)7Rnyz@ zUDBcj-Lb>%!VGRu7C%oZM!_BC6U@h57o+iE-f?9${`LY51ihNvna5yzuqg#yk4>xz zzEZ=L?4%{j&->B(jl6e&M_(Ud;odS?@H!D4?X!!;kvU47k~@f2iztUquFAw5V?p3` zb#yULrVWDKrb0Q0yRckuK$QBLy6o2vhDg-Zf|c4lp*b}4m!}V%8TaS=`V!2+|HOKj8Tgiq z_nB)X;619l;)@N#i>C!uE%h*~rC*I)(S+82#N z2$t&=Sy)&eF_Q<4&UE&kV`~c3VBebf5`mpyOy9nH%;7|dBX%7{S9w?vtUWc;2l@Af z3}47e*YTMJ(k4#yda27`iZaZ-){3ZajXWsCG@L<~Dy@c2oCF!q3j`6)mvEQC3poVmC96OCMp-}H(oMf0#n>N&THaHPA#jU`oM&POsXWI~*mS6gVGD2M3| zC5I2@%OEwtf!95puBkV`^1Rg#vC#E|_vG@Ya4C+5XJtXvBz&iIt{Uhfm(*|d=X%>8{YjzfadO~8Hu1Q-EEw+3}mXo!lcv{ zrk1 zLlr@o5c&G@o0`$By0o&vb)8f2y^a^4{U07yL?GPIJ##}c(v#Cq(Vb|B~zgI zG_7Qg{zRgy8ymg7OPAu)@O;8!4E?i-&%1nWE>%NY?v%R7>*0z^+AJ*y>L@#%h;3It z1wq0^i5<6Z4M>gH#)HT`vmLk-ek`QWU$$ZEda22DZ zh^g=}01zW{jJ4vJ+RT15rd@j;64dNFe_bUP!{vwND4+qqnf>p2AHCg3;=(V3u*baA zc?>bjNn~`v+H-td9#J1W(1<6LMai*6v_#P#WHbPEeNX>Za1R$(+9m02Y3m#-%3?O$ z@Gr}k>^dKTeaERoSAMhisXPG$(*+3IV9gw^@DQaw!kwrGU{&a&VJ3lOb3xWjo&5de zJF-OaBX2^mv?FJM zas}#n>y53ECjjakAq$?gzM3nY9>}-A^ZqRCux@Ey%tR9IWMA)TvuPj;r(BL3*h(gZ zX&|Et*T;uZKqZe|E(RMI>Me+n9H%IlTU%EUoBot7Iq8yp1my77{o?C1XOmphzb$vf zPQV=n&PCGD1sMcpQ5(OOTc`Wny}_3j%WkzgP27xiW!BNJ)8hiYabC~bD8Mz5Qb(%H zuiNjR76B;{Ox-$cbhsXre*p1THP#4v_kg}7vSD0%m#a-KPHR~dD{Cuz;w$J_{smxU z%cD?mNN92G@70pZ^K5lbe5?541aFlrWggqw}bUW3SE&*SnhQiv=NA%B9xY1Xgx{3Z{XO@(Z(^!#Vd?jcL<8KEf;if z$IaC5)S2Z|vOoaJ_|o9A(5C+x`QJ9==6;9y&XSxcdhsD8@*9I_g(XHhP-yT53J9} z0+w#8StmUy%?lZI*wkkDi z7&5|X1}6CJfsRIT!v6`aqvo5}mmHlGlX5yCt|Zmt?Ppoeksq4(GcNioeDw{F>$} zA;@VR`ySL@#?MfJQc|PrI{yHUhdDe%EPCwOp8<@eV8h$!^xVB-3BtiIhdL?Hf!iCU zR;uuQTP4URl&ws+j&WSv=x&pjez&46O?)E$(=K33s+N-;^rqxUdQnzfUb|AqzjuI7 z5>9slIL0W?G%L4MVyVRr0r7w?d0uOJ|0N5`y@zf9rM;5F@DV?*9nK0w3f2>FT$ zHg?zmEFp^}Z(MyMpoxV^GZ@iWlGAT~`b#M$zCCO=3!TV9wl83kqPkdt*TLezOD(ZpBo`5#JzPWUu7`m z<(ZXmwh#U|{jM&`F`u2tVFb1EFrcn^Wa>ePbN{ZnvyE+1jc0L^B?dIBzKcUu zH+v|bA6YT-^?tgQiF02NhYoGj`kbQg!VG8xfm-un)vBMbjp(=z4Om~G7ZF*fZPwfq zsLg3Zf>&`G*l^?}ERQF|iEvSr_a^k@7YwHN2ikTCA6)55zSZLqo*P?1GY7l;LSYdm zs-t4U{M^s|0IAiZ{3pDTB<$Q}T*Kl09JS(8Q#o~L4sHd-yI`rwpdh$T*+VGD4=;>E z*@~Ekbv6HOr(NNi=0p-F^b5B24KgTc(?9Hz(2801ApNT3LV6L~x~_p&yzf|I4UOnQ z`pD)qQIxvwy`?s@c- z0h1egOk%U#Zg}_-{8-_d&@%}5!uJutCL@pzP_pcU7EHk(`uX?f%+s zi>)<5E4yT?{n1k7GX9UuB?z_(Kx%vI^^YTN-X0H7krrK98zzmJP#q zl+BM~>4faPQtSvRE|Sc)!HtM}B0CriD2+ot2@?c}xE&DB$MN7bQ3?tqzkHlp7&I^H zXBX}Qo#D#(UL=ze7-Gd-*}pIqsl_otRnOtk_vQayU3yBW-zM8836YKab70oyIeBdi{D!7>2JY)8`+9c{LvZpN0^2x zhTT?km+=dFf*5O!kN}s+e(LAR_e@?vov!p&KB9dy&}H*!ERax^-b+thhPI1eBF#8Y zB(H(FNOm9nXYMqfGcf6P$tnb>)~JkY7(-g)H$cciP*B9+ev;HXh`B2WBlp(Vy&75= zU~q;oXvCa3_9{QW7i29Q)syH^6jYRPJ3kn;2X7-gPMdkA&JCYN)C7$x!h}E8+jR!q#NvJ4tLEX$> zBS+;3pX5I?Njz0U2KK~^*_k2A@~b+D=Br@lMpP)YEyyoP_7SM3ch$dzN69YY?JJEB zLf8f%{rY+-0PG2d8B)@nu z#nvb=1pH@%(bU2MfrsZuhlj@pqb%)8i$T2GHG_~-EKF%m>ml4VhB{CZF~?3+__qdW zQEuW4o#@#L+Ry~9)A^>;3DnU6abREo{IIroAArl?bn9k;Vq}6ey?BXOL&&-MLn~9$ z!^>lp9&W`23)tB%yI>v~x4KNBefxP#$0*$>2*CN1$>@BHh8blRuLopm(=BAUat( zKlnGhJAL4~>tBZs4t93VmnIIUwwBhQEbUF8V5tV zT3jPkB;moC_}~;W6z0U2OUmEh{(@)Dzf~m(|fz%Q!bPjJwY* z3`llnnIt@l=N16P8=qHB*7?-9dUm0&!PC6)~oFCpm*3*j!&jgmH0o zgM9b-erxkCAtfQ|}1`T18k=-u=Ha@H7Pm4Mm*@bS1?j$C-p z*4*BF|7rd`3uL3Ol&iF@n*XUj__-Jwx)KE0i6vkFk>XOq0=c{;J%kc``*zO!;o1`( z{vp@oYJ2DI>?504%i09@`OyTg@cpSAyxuhzeY{O8g8X!blJuWr00-p=mNG8*l`@R+ z6#4w~2=;mS@Z)?FEDa3C|N4=aSy&!9A?BPGe*YnEZLCd;JMBXhDZaV@(}RcfpL1LL zGFE5Y>(kN&wXr(3`v`7jV;U)ZMrmzs06OE>=2F%Qgjh{zF_oqNWEcJ9g3$ot(g;=7 zch)anEx}D72-kk*L$PL_$j`)Fq4Ji6=}2q}zPXS6`PKcKcVk9J#vxg}+}K_uKnMk4 zT)_akqWE@DPjA*Opi>H7FH9uZAQb|}A)P(w|8CKb4yS~>U#w?sG z`;p8oG%0)GD$D{VM1&u3Y#t))gJf`&oh{J40w`ecz2b_;dvK z_^58qEhL#K)LsrA4|(5rczgvkG=;r=nZkEnXBjf&g#^bDR_I`RfAkTEup0b?6&|{L zz=vga{&32XI4AsfDZuG}zt^f4J`za+ged*UJqvS}RaT={)HD467DZOigYSg<^g~3D z3u*r?0D5SH8$1_zi(iw~yD!P%90VLK_4a-**4li!Aa7jE z_-ErMSteuO9-i>6HKg;Ttxy+O4?0(=``5z6q^yCX`;Pu?{gSwgh`k{D5MquO$_6DS z%^Bdgq-`cJ^i@f9XSv<}C=syxkk^tDKYi7Bq3=9GDUdJ2E#~MwgT|Oqv&t!%-A^9q zU_l$0H#P7noY~o$F|kkrB#i|XOWz4bna#egY+J+xWj^ZBt6RI@{44HX9HtBd4B+Jb zeZbc=+f&yzzh?z2lE@vKCX58Y`x9y!#n(N{Iu>9B))envZ%ADL9{bf zUKBRAuTT2bZQO#GZIk-0ckql+LXp;fJ?P3TR2qx1L%KP;EQWvb*r<~`(>Gqp*lA+Y z#kPJ0PW&A5Q%lg^v?bpn!>Y~KL{_y}mp|G#kCzHD3k4R&!l=K!S3{t_9-UQ)r%gT3 zMfHY=iHo48bcQhZt5bYgxOq~SR#%P#?eCtGbshFj#HWVgRNPVP4(V- zUXg@USTbL*Y?1Me3dxl9`QTrPAZDYqKA4x&9I4>8Y_C#(JeCrUmR6gImM=^hx51Zv zscGZ-H!}#ki~kyaMmZ)u@QddBCFJV-7&~0Y@4pBF6+wb#n8y>jb}MACy*}0JxFBqM zB>>sd9JTfxF)NJdTIDlHAlyp7rHY2eOgGnccVOcRWWXPyD;HOeAJ2DtrbjJxoc&8< z1d@k1V6}KIS8MvZQDJB?mu?q8%hwW7kXCuZ3bukzqGxko5+}48@fj#(qWU*mt4eZz z@@Z4RLof%*+M@b<-qIgtk$7QSu_3otB?P9Ws<; z!~PLTGH7t2PC5D{I{cPr%>7sXz}RmjY4UmMLq>Lxnq(XLSz#N^d-T3TH)kS z562oC9h4$psZyuZ$O*pT-7J1+4rP$kAYNq?o>H=EU((m7goqa*_ zlR}Ybk@%HHRr`4g@=D9Tj>qgP{k^snLX%Lc=cQp+;bLV-^6NISIozvIH?O{5A4VV% z>Sc#6aJc;WdxS@?9?!Ofyk(laTg9duPEZ7u#BMty`v+ZSYPi=hLlXJ)95kqIOGP~n zat!R*QJ4m76Brm=%8?0{im|RdIevy6qs{$|`(q!X0Xzbo^N@60axu45X-1~rO~pRr z2zCDfJ1rdoJB%*t8pm}_n+-f@Yds*xz68fg)tv!(hm!dJ0z2Jy8x?I`rKxV(o|qZf z3@0ihV!Z!Szt>$3YzodC9A)0qO*E%-_HZY%WgZxKa zgqhTdFYF?+h*{5<{kM0w-2Atnkt%Zl6WP~o8`6uh9{dkQQcRfZ@iosf({^PvZi00c z9eWAjCdMbh1v0Y2+}l>lc*7!}5tI1xq{lmr1%yVnCh@_k%)L!#PU{)cP($1Tj#|1c zkStEmz38~Z_qeT^DwRQAcFrR~igvUiaNQN(b?St>=bY<0b>eot3HXOo(sp_1DC-qc zu3?skRep$F!kznO!SRhAAl-#xJEo7-T69feYBs({HjvyO<_plozBZrl{#bIg@j`56 zB2kbq79Iz#(Uahr&CF8R6*&XYg6ySVwlsNs4j-7OtGI0X*uBO{LeW*t1ZS+2pi@32 zA9_N!Q!)j7M=>--O-n6iPLNOAgrH)Uj90*!dX*X176oAtA;01UQe7WKwm$osDBf^sz7%9_B-6j z-aq3B*IuR5O&hzIaOQRr)kTKsCq`&Qs-JulRVrXOB+5B3XbcWS{5F$tK8!>5hSuoJ z`LUxhiys`0XYMI-xZ*ngRnGd`QYVe~#Yv<+H7&Ew!kY!Im`y4)Xl`ggICa;*)&fJQ z(BK#0hlqMgFl)CXLjV*cZn0RDEUo!sbWvPnxkokNF$NW+)<+yoB3H?so0zG6TGW&ra188)TTA53x%t0;JA}8y4uxu!H;+`lYWh~! z^(%^v@Sqp<^0(msUQC$6CV~SFOiNkx2lN>gyZ_}_?7jXWze9NOjgmW^wQLF}_hB=< zu=M3{uJ3G!?n=)nA?N+0#B%O>RK?ho)e&6I4cUQlnnw$E@5%^EDP_Nc@-dz)8};QS z4?OQAe0tmxykqfbD@8$A;n~%WttA>VHAS()tK*`US>AOtBzRv$i6L9(FjLBF#H)Si zU^DDoD7a=w5;TInH)aWVz^lvoE79OwyEXO@LSQEAh9pry{BLm1EbS?iCr40b3q%L7 z5foGPI`;&qG?prmqy7-NIgZTHIotDEkIPlUcxME9HTL}(myLa8hfFt2iTCN`xil}3 zkII4p8lobv9Z3&2tjl!L-PPcJZ`BpA^W=bxOXJ}T4Kqh;qeAX|=I8^h>MaG8%l8_O zZD#R398tl*A=mHuzcL3hDHCT5Apu~|YOG@iw{c<|$nFf>n~@(hjT#3dl#kbGn;&iE zbKyd&sR54EIcC<*-RdWXdxGYw?+Y)1m_>~B3u5)dN- zFtpPlGWLuS(Q$)>#cLz*t_5c4ikAe}lbjx@9gS*d~2mUY==W<%LOO3&jgg7){PSXhPn6Y6GV#_qk_L%xd9p-fVXPPOe z%1^lu>IIP=PVcPBo&=%2j>|C-GQcG77(Ua9gjJZs6&;(vZMyCvg79;SXf z9=|!zr2#_3sWGI`s}QM@m79(22xkY#7hR0Sz0+`*vAY;E_4{v|sk_GLXjqJ@AGt`_&y9 zCz0g`N0x=ljxc#mcX~Vng8L|ImATZbpxtM)S@HwyCMtbq^$$pfMi@8gUfeWqrx1Lx z=1oN14X;8=|Aicom1s9kvtv;oZ|!3AOaGM{_z1lu)O;(hwT7(K6f}z1yesmYt<_R3 z2`H$_1Wl^SY*ajLl&&>h2~*-TMl2UIrCb{MUZ3cGgwdHgTX9?R3saUZb*@KF4Oj~+diD{jSROstuJXB%tIXbFScG_v{0z*PQvGbO^I4LCn&uAZW>RTd zUilAjDIjMbzO&dM^R-9pJfNrQ8u5pT=<{1OuM0>99w#imS4|$eeNbl~5)%jDvCs7) z4sk~iMjg1{6e~FN2nxA#Ix4}g?!XJgHmzf`uP0`8!4ZpdL`dq<;1V?jO1l6Mr|Yx) z;CK$O_8KOLnrp+!$_cnTR^VCwMYefcx^DA`@f8KAxBHeQ4|2*4wm0|PTHku2PVpo5 zW1P!`DSeKku7RI3bRcZi%oxopP~{UGhuVIBOq8J?lxv7Kma1kULwwt@)OdqDRA*s% z$fv3brm6T&q7jbthzN6*Yb%>8g@iT5Yus;92(vP4VC+Lz9MBRFvRsX!pep^WwZ_rn z1w?$bIE(!`?-7j~L|a%f<+b6T(NWR~C8~yn`A`rPn@o93OIt@LMyF4Ae1EG%qZ@|| zVk*}#1nXPKR=$?=E5+kP;(|N98p{les*qKugaL@Q59f=5ZeR8Luz)X6g2O(0b5zT( zebmQJO3DffZhE~1P0#gBvQSPxcZ4XxaAc|YMWo3;BsEr_ z4~y-N>s0Lyso5dO)kiQG@(q*~^h*cn|3Guc!3OL)m?dh<$u+n8Bn~EA7x&d;Coev6 zcPV3n*y3OWTN+ov>eUN7V?$lR>=`JGS@kko7Vq1PSj}D=LtV(LSnP_@8^`^CExL+b z+ON5R?8RG;heIF!NK+pZCGG>R(1+mQLm`rr=A{XVQs;5jmHbGr2{Ok5b@|m8N*S>B z+V^!ZC%t9yJx{sY`9USj_QWR(#IQHrN-7*U69fDPO*XH!Zzasle5qpZS~heDp>m*+ z63N+w_3Xe+6j2 zFqhkN@YWz*>01)Ge{DMKj*sk^v(Gd@@1p8nGswi$1R=5%!1w{zN+vvV{T>gbu7zzT zBSZzu+7`*@`MN9)feK-hgpqmSCGPCZM*2I>{yNTcDzwKFwlryQ{>FVndUp{Q|2{3T z?mgM%kGedVQlH>nS1U%~gfppp)ExK^IGgpIgy(>IcoJ zWeU6w9BNe<;!=;g&y#t%&-Wt|deE=3{p7c9?@Yc_KBm|r5K^~@lSSp|_hwdDvYY8F z2aIuw7{^c`eO-$V!aHUFw}cCiz7^*uJb51ap3I*yKOrS;lo z{C$X*8urviDnJHH03GfoSY%;?wzE+)&vOhfZ_%Z285qbA)lJjuE9+oxr|=Zu>AW2E z*EyJW@fctDXPrA~wP0k!SJ(N`7IsaN1;**fj~OiV7F^RyER3@cFGwYW&7@&U(q$xf zpZD3qA|NSFl_i3pNSl`^)QV%9^<9X(eUz{d|9vPk6NGlte)mFchX)6GaP?h!dDb+k zeCv^pJa7kboLoM{YmF_m9uohuq@T(I{tt5B>Kt{)?$HPbIe zr}WZE9uqoB7ym4yMPEyb1?GCG7-bKiCXmmWgt@$u_0J-_NN(wLH*V~qB;-{)X}H&m z+9fKgK-hC8W5j;;p2HuFLVp&ejc~6obso14T4=|v+oLk5{iaI6u3xEt!Pyp+7?3$rmgkv-?RAwUXtL|zNnNXB#k;Mk}ZnQ@K@ki#BMl% zHap@gTEa24erN;Y%i~wmxa12yL-SmMLuq?62O0JBa|n?@0qS;ikBM{6inNW62XA2D^7;Ws^gz-RyTbEXJY3k)*j-e~N_;Ib z0(?4}=yIm?VY28FwJg$iryu>(6nBm78w4u@hjza__25B_pnARXNzWfh@0q&BE6zLn zHBW7}X#zJ7TIM4u-{Ldq>yP?etgSnM=eBaB<3+7>In#jy}wiYdwmWr9D*wmh?SL88d+mJqO$k8|ozfKc#b zGVf;FKO)ta$4nqRr$n2OD8TvAuhl9p#&x#I_Px4wZRj{6W37yOvg3Oexk8AAoQZIy zMjgEJuW+6bc>`Tn8J*F+l;yS`&XG(&|334j7}WviYG06|xQw5YCT!iJz9IJ9*~$rd z1e}2pDpzS==~m5eVNC}^O!dPf#2(~}I>-dNagxitTlwnN|7bf7`kS0Av?~{p;kreY zMa3Wiu939e!iB@pZ)ol4W_Lz%;Z(R$+9cy81*zQrKfD6{*rERka%PT8 zh0WZf_}XAtjE=6v)zyDF^=M{Ya&UJKE)643{ zFHe5cu-3NEY?N}tIqdn@{tKB_+^nFTotC9v=+mqiL&bLIKVnv73&$GS4ljXV<$Ef> zOs~M1qt@P@5T*iz)w7MKgcdzbNPJu+I%+Z5QO9t#+v?>NIsFSQCV%fB zZsCf~YttX5_`4gSm?qtC?LcGf4)H6?L@P_EzFxb3kS`;yaQ28GHt7g+UwT4gwqgOj#)MpjYK!R?;3((!a>n2L*1;@N`^jCHcjxdi7wTcj@#{^Z}L zE2Ig-+@DIv*t#EEB*TA%dE0M%S*qp!sszQ?J(^;0%eXG4+M1$+R|zF ze?RpWU~CT?LEPv%Y5*60!9&O4zC_dcHKHv#;N;K(D8hMB&Q&=*APL)%!cn>&fA3)9 z`(p*)OFkbke_A!JKjJNnT5AP~r53Ng=T=lrhe>zq>6OT(*Dh7sokJUF|Ja3F|%`mW)) z>>{+LFCMy#_AGBFNd-Nh0USTGx6fEMjMO#^YcVSqEqyXQQ!M-*PK~fH*2TI`>I5V7 zoA>7$jy7}F7CFWKMcT&t5Vov=g=9zE*#s|;H(9|Gspe{nq!K#m$cM)RSDOVWHa!%%LWr0;rn_X?V?MJY=FkCGt^kGP)sg;Yw|l!sUy8T`j$pjGWH3(6aJc>+lR zcoto9Jw8NLD-81wwO*Ld4r05Wc)X2rPeF(z85^edvnf1$Bg13JQ>nH{#o90zSXtsOw5<4Cd`Y%yHninns zgOAn0viZ*Rc>A)wUw z?KK=!OGL{y(7X6ZBvT)qMFkPK^0lN5op~myxt*#IOf5K>`QI|9BPI$m9YB<#i{zw? zLWr|>J_pghM7v6C2l0e%{Wkmi2SyzM2iKT@@?}J!2By@z?z(F`Eh*uZ&l6BfTwGT+ z>!jj})J0*tMwqQ+@FDf{^%+G*=0EO@qf?v~veYub!;Vd1aMvXbR9M~k_ z_V|ODz(qnbd)8|I-xifX(z&M0GLJ9ARqy;>R`i%qe%)s0pb?MI(I2(o~?<#_6 z4=uDtgpR6X7M4<0aS=ODRaRp83=Qx5saciI_nH$%bV0p`oRH;)RSFbQd-W~nP#LoL zqqixX``0)O(Aii+Fn1K~Qf&%}9k-p#*UtD50&kV;7mOvHki@}>o>22odtwTUf@Y5v z|I8z%b*6t?9f|xsGT#Zw_dquPm{pe8Zt924-ZniUBgI9z)x+Y&U z{h-9J!oU8Pb6YAc*GYXiRm0yGJggbBV$Ba*%pojc4pb`hp*^*v+`^k|*g`WwIsIc) z@C64WXEM#EQduPw#`#Eb5G~m=*k;Z1Fs8nmeB^0?H8IE}n*l`GrZ8oA$PJWkG^>w6 zT4Eho%LVMuquoY;R@L3$qE+z!z8`x+t)7oK8m1<<;Iq$^uKg9=170n^+GNjyw{8ot zyOs$aCNIc_#)Davv_tl}oJc*ytN6RU;g*BrwLjn~j!;~F@kKDu^zAG2hDw5PjY44$ za4+1u7WxrY5cwi?c_bVkC$evJ!xl`LV$NO{&lO@^Q0plxYgDh{m42X>MkQrXWz1V$ zx9UUQ-M7V3^E&QrH_$*aw3!`?4)CJiq6sv2A;Z%!C|D(;d7e_6OqtHr9Y^chR^$cY zDhFZ@l{aK*=Cn6oOlv&tsac1X8<5g;+PP@IxqlRkV|P`4{__;mQQ!V(@FbT75@6Ix z>QG|K;ey1Lp88mO$erqWVNm6z66#45e}GgIOe7soQu`KZ1*+(V6i?M4sGjhs;3&w- z_lcVrLi@iMw2?Ti8`(mQ|Iy(Jk<`$thAhuT_zZdn;2J~gKjLV7%fJ;P>GdVNEVmJM z)6IE*tjKWFuhhv;e4@6obbs%NJ$4xM+;H2Y(zdX}%!DArJ2kW@|1)@F~gxTsM1 z1vcGmS-WiHdHM_?;n|CRNMM~l-^ZG!Ir}DMCdCs?yIEI1+M+?18oH(J+4Wt%eBRJgcY;`>@YTTlZfO^Qz^>(4-=H+o$I&n}X)CqL;I`pc|~j z1y~!Dq~oo43!+wuVm*im@0yWXkL- zgp5bfsMaE~g=$)U2n|x`9oYPPiNMh$f|gj~?wXg&EC2``@>Z{*VEJ7VH!puvoX;H| zCee!g4&xQ8iHG|jw7Q?xm)&gs?;5GdqrA}oB~mG=u4;JpF7=hgXfLX0;AGgxfnpZm z>DO=56rY{MLk|rEAAHt}K}YQkF@l!5$^o!kG7FANl3Q4|C+5OoZ{g1@43$pg{#peL z@20qTpAG=6vutqlrL&+uKh!*ldCyJRwD{fftvLgd#@o#EG0LZoNZ&Bzz3BplmpO5G zsc&2OBAq9ZPt-^THZ9cwN6jgA`yBPn(i@I;6&pKg!*Y2;@whHQKXxX9*>&)&%@vUn zH*I;+%xTY%wRz6f|9RJci%a-a1O=9|2Q{n>0lCf83&C(KNK$jB2iU&Kj0+tV$P>)O&AYOZhn@y_{9mz zNrr#;{-a8OrRc+|?(2%)WyXv2Cw4burBU>LHzGXck-ef1`a3Z6*x48LQ(B~NmM^7# zDs+=@(|F9$Yfbg2sGp5Rek*(G4)%Pp`D6`=D{+enC(DL9ZsI;tE@nhHCB!w+z?ZrF zZc*OORlA~vYYGJxm~T9T$x~%i5W$^jVy%Kdvdg z$Iy0}%!aVyDO(_e{@ zXSAH)PGadS_?Rds`CEmTFqak@)tJtkMw$n**0;k*(ud50kzuxf@GPy1!}Bh;9gyKEW{ zX2IQ4`SKt*MRiRq-1X?a7K)0qZy4IY2C-r{dN$&L7x-P14E>kj&x=-g(Ryg3X`Xk_ zlAmtpUfIX{X<5QZA3#Y#)~`*pX^WY>fk4^RIofc<*qUt@n~lN4gWatT~(kaa=wT@A^%4vz*kSia--Dq#^fo?gy|%{HI# z?EuFaZ>-;>SZUFLcgJCKqv1e-p})O=p+cMca${Oygne zz}@w^xD;N=Yet!@&9d^}$A1z*gZ!r6Op$prEo)|W7!pj7T}7e)-QeqkjhiPe1M62H z1<|Oi?w4z4p_kq5-9x}fVU+TQW;eVpOBNU52(~fWnpl z7QUPwi;MQkvF3Z-#eIy4eZfqTwTQY-_3(!Wgd0kni&2V1fnyg(s#tKJ)8&*tJTyyY z*@2Z2#BtPO+_<~(H(D9s6d;Ns;#8#omNE90SN@l6`*EWOl$5px;CcA`e+avWW?{6T zJHW@b?f2NWZQHhO+qP}nwr$(?$xQ~S48E%Tg+1Ec)$3VYWX#f#(4q;>f>0W%`v&KS z(^s@IRGAp=mbdcnK&*UfA$T8KwXE)ONdXnZul78!>IhLu1MjYnoVR1qbTD|TgHt0* zVk>!)^RqX3RIhVP{XCrb!n_1R-|bT3oV+q3cH{v!c$f^&y79<~-s8?t{neX&0UnDZ zucvgLA$9(f)p48`oY?F!&MAB|hu@``iMhINSj^Kdce~AI*-uX1punVpD%VXuQFT78 z^NYaNXd87}zZaXZ@L*fcvS5ruK;5`RTu{i)#-Aaa(+CZ~{2 z*Opp!6`FjXuE%U?YoH}ZgJ8a^9X{p%b#fb%av2{K*H&2VZ;Mk)(V*=FSCa2gxZ4c) zGx7|6bzh|1jL45lX5>;Lo~0&0>^T)L2D%Nm_aODnMDpx6%jM5_qDhM21U(lXe=;HJ zeQico@~*Ix{X6^*yaTuJF&o3k?e^(g0HLxpVeSE4y-gXmU-LfH-o*O7Lz9}X(Lo4}Nt7`YbGpwYu9`ChKF z51LpE*4*{-qQKgk1o-XiIXvLVHEx`(bEr|uK=<-!2%PN z86-D2J4`AKuKTmS;`eKl=9ga1jXR{Oru$ckemiKZaH6{@t5Bd`{3b_6Hw){9!`B?? zX^dnVF5BW3BD~LRZE+bcsI+`tozPq}HEo}E7cpD(I(}hQb53;}c$=vD`Mi0_2PG_3AhC2z_@PT+KpM6~L8!z}G{+)|*?&bMXHLzPad0)&^_wsZ>oC7gw zok`v(I~srvQlY(vcQpP{(`cHFU`YQ05#46p24s@9D=Y%k$V=1_9kh-92JzawiTT#T zNYn~WIjmR!-<*-xz-oc(Qur_<=;WTm%Xu5Hml9}(cEewJN>*hWV(_2N$bZ zo(??zrVb_eFO`O>O%&pKs^i)DkwyW$lNuZxrjjQ^3PNGz`5XKkwduYNeZ0PPjBwOP zS8iy4yg7k56e=A}L~@HI-`TR{!KT$zle?n&e)8r=AGDo(U;&8Nyjcb0I_+EKjS7+Jkm3T zpPp5c5qcOt5c8GJt^(?W!CLOa83f+e(H{$-zG&lkLpkWL*lx!%{=`t6zA36(pNe>D z5i}|9s6{TzGy=*Sn)n)ED0`$@3;+C=hRW$+-k}GtnSU7yVQ0fL%mqOyT!T-^d;+4~yggJzc6Q4ELb`wG}n{}$qQDaTAkic_$=Mu1n?m<|z-7BMzMUMSho?Sd@WA?Y_;P~ixiMo4^O6)k zD*&CSJe&_=jqGRqseD7Jf`ouN&SCu}q$=tBK30#_D~g=kFrD zUm=PoVulj^-fPWF!a}gwpr1ryNYv)6Bm!B`7h~rPyziw~&Mgi*r|f4jTFY%*u{IuSGl#IS+G6%*t~Z-0fUVuSj3* z@ZKcvCPC~NcZ1pQZ ziD3mJm&&K!n1N@{IE{|rLw8U48Qck=IqP)63OjhZ>h>P#ZJ7^QsH?YskdwM`;xaOV zB06GjovG67DWnfB`?3O~C~v5tuesYKN}GR+n0qjMZqZ~D<4qI@R~vAeJPtg}nrqPFqls6S|gB*uS9Ue@{{OkQOVdXx)Rw;R|F`l#;coTbI4S+!UclUXHH)I|2+!`C7A z`BssE)!L0poy4r~DC$w==r%`XjirW;C~}lkI5JbNLgv7A1<`j(r0cw;{fnG5FgwR? z4d#?xQ+tkH+wbp?o^*=q3FPc0lHQ$Onr#LI8y1&TV?0)z?b4knY9y-4Fwv@Jw>EMb zr_|SUCodvvpARP8HZ^=x4ym^=dxPtUK3cT)527qjJKj!zuX3B}4N#83R?Ae)!1!(a zh5`&3z0UXdc5X(T1_azfv+xA%iVt7Z9a!gKNs>3~&EPxhnPdEzjxQuXmjBTIppR&JiN+L%7n9ZRPS zpdS8w*v;^&W8Hmdh-;3XGC}DT3ahaZ0`|Vg93LHd(t#)MTvU)99(E1OfTjc?y*JWY zYix4lUKlbSx-b%N)2IK*91*K@A$RnV6~#8G^yyZ8TMcmnMFnEq#<&yYe4@$cxne0g z09&h1q^^-@#P2HOx@c&Wt~dAX%+q`6Bl+7^NRQ>z2jkm5Jw&vwsH+5jI~8UJFoVWq zEMQK@iD<4nIpk5v+^E*dAmjk;N<2r2MpOEqFP^x5GV#Yq`Z05)Aixpu*Ata=!uvr@ z1D%1B7JcRls3D;GF_xs2r6I0Y-F((ixWQF(U3m9Usd4-d*4p$Xmg;GQ;rdCEB9d+~ zvZaP|2N(%z609ToE5Exk=%I2?JHU~mEv?o$IU53868T^09h%b@lLPiHh^g3!HFx6J?xqf&J0t1MeGsCI!ClkEwEuKy6#PKYQvx z%KYc9$dgYS5Moy{{T~)K%7L;W{Qkj%Q@tGP66k*$j5DLNrR<5~hC1s0e+5_od8O|G zvhl%mnTOkd(_f>fQIIY0qBuaSF6t8~DIu>M+;G1dP|*$4XhvgBf^`DJZn}F=;Id;x z**Ah;YY;Y^3N0uu)(5bIg#U$Y&tSz%!;^tH;w$Jjlh+$BJHv>hl4jE^2GH+kKA zq|7AU%fZ^z0qgbpe8%3zMUv2Mc-^)mI_A%u*-?0X-@?6})9#;^;u9@!GPt5gT>BgV_c41=TKHI%Ha`jK|{WMT!2?a&^HOLAExvX?8epC7YNs1De+u@UA0S|q}a!@rmx zVs75*gKF8My$YW=Mt~I94PL-;7Q~8VdUc+nDOE&_IDRQ}DWY7^%MA$?3?N}ILZ>el3aB&7=wL5VxDkPl?PzNsn}8ahCTr`#>=Vlbdtt= zaNa)xj6F$?YP@HI4{$1%S6AV?pT==35`v}EY3b!vMm6Xn?IFN1GPLxi<#kkuG-9y5 zhMl%cH;;OH;0{=-)*aqz^EU)IZ4J5B%Akc8GfeqfJf(Hnj z8CirTG(M0H_Oaf&vAnp4vPbGCc~XY&7uSjNS|5oHX*Y|8)Xq6F6Y|Fi_e!s#5!8)6 z8_GVF@pmRT6{~MM?Qm*Rx((aaA(ZH~!s*_JSyx)Cz7{t>i`pLwL40)xs@mm%CCIdd zI-}@*VbvyCiC#_8g8-G5}6mr|~rNBA_;E~`j1e{b=IaR_t~O?VE{cY{Qv zv34XA_9?Pz1q)Z;a&T(tOY^{?Q{p z!RarBJoW)1;_bzOL}^Ffj#$+0lvj`i(NN78a3Vs*;C8;WSH$ic+jnGxQ3rRmNw8Xc z`#okGHhd+*i33+?Y;Gdteou(cbQv+SxoLuIP9LcwqJ(*$->s-?6)csu@z)D*t}7fR zL(vM(jEi7@($70fhB7kyP4uj=Qv)idOp9(8MoOV@?T&rJ1qPGh#bS~wZ^4^Qbml)}eW51${o9|) z73;GKYfEjvlYqnb^ZJM!)<)z4>>s5)-o_u7J6Z1?q&%;Ee6`Tu`MReK+YR ztY`|)QNMEfgJ8`MiQ~B1eq1T@n9nM<))mtIbrf0)0k1TSSBW#zBR@n1zOX zzO-!w3CNF6Cd!)760;A4hcsJ*Wx$K4Z&+Cno7Ja{=0b$9}iz7Yk)A6VdB?yD7aJfv~p>vTe1dqOH2yU*2dfV6Eu0Clf*)(9f>I~d%@Hq_WuH?Ioh z)I&yQ%4*lmqqa;KC=z2PgVqk8A@Ki^;U2tb=D1sDkmQHnD#<>it#44ePx7BtG0Q&^ zlRXzefl?$#Gfu@OZl?N4C_?a`fL47>^$r9!eW9YvYAHd~Zcb+B*oYW#oK~|p`?~)} z&ciu5kkwI|G8tO)c;?E~DVBnx>!?L3vHG(4SmM}z0y;orfKpx1`ARe>^F+{s3Gy|! z_=;&xZ4BK+Z_&eZupPvm4&KBXF15EyU<{c(ua5UUra%tT%1&Z7p7Pq~UhtI%BZh~p zLUpwy^^kmTv(WGqV(&IuilU~(qSXCa#$dJQnay9Kc^ zWX>@0m|xae;jMh|=4mLz6!>^7FJ1a1k5I4Zi+HlXpE=A^HFs>hp>tjhe+_p}!KBGh zu)%UnoW0z__c5|EV$2R8jm|zCAnVNk=wgdgQ$mn6A-8YFFKBeY9H&t~fd24NyG*NV z>9`E43yzGik+I5YGQU-Q3wl#Lpgs+ZOMr5759V?I6xH$pcH#BL6Kv3wN><_WW1UY~ zHrB|!8K$MQ-u&&~^Z~!xq;k4P`nZJ1co=fa=#6t)hNU|73CP^pZ4-0mlCWr3NX2oZJ2RnXOBM<)kCT|i=aNEskLz(9Ol+P(f@2n=|(~G*c;#>5afS#gOZcyvVmC-Ar4Pg1Y^M%$> zn6XAU<3#!x4v)oRRxQk)KwYTMwqNtHMJS&@1!AAtHhA}0bXmxn-O|ao2kJMfeDhe4 z|LP|CUYm<}jiy?!^Aq*d?a$B~!!vBl$x;%V61FkftNo6*x#4iiPkx~7oDI;?Sd;Nb zke{xq;@&D0zd}738aTA3_JrzxR-&>kR51;;rGlsapM5fwP;~kad-nkw`7b=ieF1HJ5?`bL7 zHD%>7*JGCd%s9)8SV~~&f)i5=RWwC0jVWNGt7juC1qV8Ywgoi$cSY-6%LM}w+6%2 zhe4ZHR_Fqycp~~KyNe{vgm9X9lE(dCE-}8?)EJ-R;+V<=w>M6Qe+p0R88g?))PzUl z_?XTmJO>_EK%@_MzNH;;)Eh#w2q3r}A7?o3U2|A=c|du?O`t1!PEE=EHiZmOk*r(z z=5_+^?7Fb%bo<=y4qWI2P&MYZ#3s%7U_M3fpC8ZzHrz4j4z`x5wf`gW*z_Di$>#n* zG*@E`Y5P0+&qht}Bs(^#EH@6EoEQqc&dq3~CIPpgH`4^z+=@#i_IQ6-S+XFT^E$(% zbXIwjz|ro|3CY}SOI=DOK0M$L#v;r8hTEuXC-stApQkgCnC5Gve==mG zLXPYG0D6b9bT0q#(Qn3<%sGadTDY)%Yvy4!%wn|E@Hvs)M-X33T1(^(50oM#iC`_b zU*!#ywQV|8JcL|8X_(JhjDiXMI*8D`O+_KFHemz^F@Lad1MbL-brCSjF}Bx(YWMdS zl1+sD#AB5_AFMTMHXP^fYh80}TC{1j((96%yq7LG(ansi_hpGt?LqdxmVC1`3C%(| zfiek6nOeZ;l1n6~RT*}|d53}BkK7407MeMEkh4kmeQ_*v`xE>In)j@6KvynDnd9>i z^i6JVcZ88F|Ng6!JxIjt3=l2vn3};Kra$|wo!)zcKnWNjyC8zT(moGk_uhP2wz#l) z9B#natC#!w9z-1Pr9g5JvT3f%fqosD#I|ZPB65;!5a=}PP~d{16~mM5U~8apC;HtG zaK}mHIIWx_U#0M}`1_3Q1DMTFcD(i;rnF8s60U)K+Z34kSS~ea1T6CKz1E_5Mka%e ztx~1;P@4AQ&fk>e6iA({jsaCfH-~CoviRlrYoP^GM;PgYadx@#B-(KHF`@S^``ucs zT*ax!k0}ZB$Y}w+cV9=w<+qRF-*d6Ga2I0G51X!$Bw|wI41}pw;;YjEPnS+wqnT!b z{!T_rXbjz2SmpN(@{C#rxg5qLySQ?P>@?Q?^ZXnIQuneYBwOT?a&NIa7sL9eqCuRK zY;vq+dyxwRCqNCp!$h91%JB~!a&RM4CMqnu^Uinfz@XAGWuyei4lR^vqz1{CJ%4KyprzyIn$WGxLX2#rMh&n;}#}SPF zyU03Hzjy*MGL%nFF^%IUrsSt~GwEDj3-1U`zs(Sn z^cTGq02X7)0@g5hW{UDopOn(qt$gmLQyAoTVADHgBK#!dqYzP%*(&Y1COYlh1~jcc z{n5Of1kh##HQ5QqPd5q064?=vz}bC-3S8Nnf|N15=>_0KOK5fJlc4c9*0`fsrz-14r72+wi$PH=syA535DACF*} zI(^hvih}*bm$Oz7tX&pghN%2aZ5X&`w0F^RjHs3hraue*i7kqwa8PWqzE?Mrb05lM zuOqIJi0UJm!kSxTX2}zg`q&hZ@Kc38F(gqa8@nDNK+T)-8q2e?y3 ze$e#uH^=_o`ku_iQ%?(Tt*N(QmANaYPfw6@E{Se;fT{m6K~(TM3nDO6)whp6fHz}+ zvBK`c`eTG7{@Fps)R!ZE!p5aoYe`ZKib)UszR3tyb3eqfK+IKcbHzy_qV|3@Tt3{X zRjv^$dBMm9NjdE|$CSILc#K)=;YH+%RnucpgNWiF*I|vFyL}5R0q_BUjIZW?y7OE> zc{i$hj%&bb&Z&`tmXzgup|O>gJ=eTNoO?f`LzlUeG>bWt!w`n==t(j7%3f+;LQnN+ z;$I)gK%3_N!tEhJMgdC%KCFRuj~_36mlkUWH+^;R8Ig~h_F2NkXH>gIit9QPA$yf> z;=EIE7uAYdzzkHpaTqmf#PV|RQ*gHPGu48B!an`og2DL-u+8>q755`fBQ1i3B7x;Y z?YP*N<;hf4aY;KvuZ~2pVc0(ROOrldD6uI3^D|q(-}wUYP|lQba!%@HE#}BaY|9eS zBUrWi{7B)jJz0M~)RL}LoJCXdf^A2iYx$5KKaB|fFBr`#!EoBl!D`@4UMr0y<^cheS{c?B9c-cPY%)cT+`oJ{-wqGgI0W|6NId79iRf^-nw;=2t)et$2j4JMTxc z&xowpT>@3wZaV9%?k~^Zl4N0Py&j^Ra6#pMO0G6I3T+s=-^r5@2<4#1JX% z`+QgbqW>8WoTCjyHsFnVz*dw}jh?uB{gI{uD`A$Hq{bmUueB+q|3lXFt1ZeC#YE|L z26GhCxjw^T`y?#ghoQ*b`kESwr~}V^Iaun$+UHP3%BsZpLBr7{e!<3_IuMTlrk<>1 zW{qVx^azuhr@Yjubs&#JwfZwLLpU%pV61u|pJc=&9;P?M()A5NU1WIKqtCD!F`9Xk zrsm9jzTcLS4k1m~SA>n9pt4lB7CCAtninHQ|05_ZKHQ=&iHn|)+5o|<<-$0-$ERzS4!=!Z>WHzuh07^5J4Y|C*Dr)mckeIzRCM(;8e}^4}nQT4Oy9!RC35eGtoV`!*#p&M@ zS(6O~5I>t) zx8m{_9=-_@15r_Bu3PRq85mxCY0jW$Q3TJD?XAz}O_R6=3&-68%6CU=5kjaNiv7;* zv-r$3Wvxm`m#h2~SElwr6r@P5lPpN1W>bjM8^;CY2g_HYkwUTC;vSBE=lIgZ+!k3j z3U%7Q{B)8@z;D7xX~Dk%UVDL3*`i&m%>=0KBGaOC0H9voKhe`(;LC~_vLuh*P3pa2 ztV2J5^CEp1#juzODd<4@MU+K#M5%rSPxIjCZ<;xJ`6-y{#ntJ5=aDWrB_7k{sq3Vq zKyOCDy6mf4X&(bttr%}Qy~Zx=3~=WX3h4?ct4pAK+Y*D5dr;heyBZ^Ixx^m-3BDN_ zQMN+w8Ioh(OknbTbm$H3%=}=R{!9a^;5qY=!G{%C9YY*s01cpM=(9Q+w^Ug^G$rlQ z^%&nFeFTlD2AMk9=Ws$YT*zu%Rf{|fo_59+`tg-ByunDSRVI_$h$I!73TqaTGFCIr z_tIism&=1Nj`v-z4s!WIsE;VyQO10rW!xngLjdg zR+hL&Df5f$CYN`>)AZvXrh5qs?Oy9aJ@J+NEtDbawl0Ke!>ugS~tH9*jX7nTqd zu?gnn^FIwgmpl0ogrok8k@5H6E6`eut5^562uu7FmRah`t3<+M@(8$^ib2R`ELocb3@2x zaP~4!$TC6HodQLXXP(0th;fOg%YM8h^Ziw7PKinwXMPiLw%qE{Xz+a@qRXf~rxt%x zrS^k?3RgZQ9pWOUGWA?(4 zcKcK^s^nk@Ocpzjd?#fCa}psz-4yZ_OyPUq>v3iv8p-uud?KM}I7A#`u0rzaOwf=f zCC$ULuLxPu$(eo}iA#or{p2TctN0^_HH|QgMgd2F`JdR6ukT$fOYCj+sKF zlDeF5>6sxHGI3#o=be$qO@cRig?{Ba9c`i+o5d?q#*+RnI;ZMW_qik&(IWt54L-#1 z&f;7tirLtE|JgmgdZvemnly7mv3*3 zNYilr$+>P`qC+*HkD^y7sEy`$tS_~(Xo@2?7&KIaM0nmiwS-TC)o2cou-a!Go&G3z z+|d0xejca;!3PLGCZS&bt&6n`ZCwCC*>Jzu@=a?MuL$d;dQA8}v+4SGe+jJ`4l`1V z_#|akEuAq^7PC31q!LDfP%i#TiqIssf_~B#j33 zT8y9MJnSZPedn~J3~lw7mT3yu1Vpu|NQf{CurG0#0=<=(CzX0#eeGdi1a52=-*s;P zP1(C9v!AMnc3Q*bDDY7+*4gS#UL_-iSjYv_)&5xI_HTXAZ~Bm4-n3$6+Oa zT~^Fk2GMB&CA5)wdboSu$*(WcW>z@c2iQ8cQ!+&-y6*B^HR}F_$7g7Y9$cvz@I-Ri zA(trhbnXe8F<7NBebEj4s zj2wAKXjvym03}D66ay=y%*xeZJQ5wq_N{3bzgT5RB1PE`Ymq-o-g|<`YI{;#?rQL? z7dkYfL&P_G0syVUN7rudHb-xxY~3ID$I5+w_vX;72nlaYIX>7WmS04cn`mTZIz*YH zzzR$?{IRb0HYU~Kg%LXowLmXBF|eBy_{RON=U7E71!sslGLnPz*geIGnb53*I8#K@ zJUa>$VFY@~+YXOt$6&-qYAz1OW7>v_MTs4WDTvw6ZX5TVIIGwtmj~>#&H*FCmUHvY zkWjiM0+i-<7o`zpTF7U+?_z1fZ5DQBnO()IPU24~fY%sX#6A6638nYe8aT>~^!Slz zXM)eu2Z~J$+wa=nY5%d@n$KaK6pQqpjP_6#N3b_U^a=d_of-~0)X>B`Z_-+z zi4@$Dld%CmhWrt@7ttclPF{ZP$oU<|?QJDuf(MZ6W<_#8jHB0%IP_HH8oRJdJSppD zYvYzWUuUp2XGbYP+xn?kg_=4d3V6qujy6kG*6P3&x`+Mfx z)`(Tu(?<9yxMQ9lQ*D`&PcXH)AVW)qC&p@wR6#UGCii44H03AH@zqLeRict@03Mym zfIk&p6==QPvFY@CvN&jIXD`>i+P_;lxO?8j!YNrGr=F#GkK3go6xV$UYWWdu;n9(N zE#a<9K1f$g^UC?LzmU7RJFLiyM%;o9$rdh@rMr}zUiGkxBe}uAUXZP;7wVhV#R6&g z!4FBE{S|%`*59r&>ky5dLLgv!AvmS~X%8Qg51Am4KSfHJ6;8V!u+w3N7++`&r9MpE zXap4hY;8NW_LKtE+?6J9`hMPqFfR{O>k_*B1P3+Z=AL8cO+e7}B8M7-CY`K)cW1>o zb6`*+>$!%b4=)v0TCM_E)^!IIA;$9^J)mlI)wtmQIUBE{I@|k7N)EgS5S$Z(t{_zq z;2-#u!PZn($t1F1a058pWuGA+bwe|NL~12Hfo4VT0-_r}jduN6ntsQn2`cCSN9R!f3Ze#=(KS8IETQcanc39VrIAWVhsY5YM zvKy=OC`)YPiQ=Ei_BDW?p-Lr^Rq5n3BVOZjFWh6K<}uITv+5^zVD~^rme|I8_0@*f3R8hT9sF%=3jx+T&MQ*#&4#P`l7@z36bQ22@4wY~0+T3X*s zh&cC9?78R_J{A&aUx*i!?51=wsRnf}s4%3RAkWPHVk%kmcFydufLa|Y^}}#}Jb3w< zT;+AuCcr^U^7VBm=*wRb25!%pCZhm*3j%Ys{1+PJQHwxORPa#2)d4&fke00~vj}SB zy4wBvaPQ(5500DJp{D2r3~@D4nw1vyj2-J3)i57)3dQRubX#GddwiAoUn(?j!?Kw7 zo*|VvW26|I6O1a4AjZ07RuFV_Em)SDJb^SZu;_t(5g%@ksIJ!mC@uEFE`Ab{Ay~Ud zq}vYbp=O#Bc;Epc&L3Q(6lR2xl*LUT(_`0bd!EsCTKPbmSXePaHk9ea;5EzuyF|5% zkz>+`v2JVp_84|D<{?w!g!kyMsN>OJ3wl0O3zuxRIWCc1gF1 z!XIahaa_DwqeTlk8(H!(AJ_f_ZKv?;H+EJV+W)f0vp~LQJt>{Gl{Ln@Pg4W2Ssaea zn(etH22KxQ2q2E>8H-T4Z%qT@;8Je8?K~#NPH}ny$g7ub5b_kM2I8NNvo=~3}9qw<7{5Wlh6iPfL}4A z&=O(#p8fg$9os-Vrm28>z^1zCv-4JLZ-?FES`*wpjcbG7C*cR_=j`eh$t;n-;;A!4 zv}5xpuyy6f?N<@ToW}+1zkiBj14X2o6z;QbIcO9BGp@M0o}N)_LfiQrWDY4M(HP=B zDq{R6ua~x1*nS-<(A706Yl}HtqwslqYHPsRYC2pDNCdcKHm>7p9R~;1!oQo)7SP8Eb4!i5?~=P(FDikppr;UlTVnpX#p8aKf+~zB9#F zEgDo4?GR-}7Ltg`bk5%n{AY8;xeFe|)OFmk6$9Zsv@G*n#~s&vCZc?prgET@3V`4e zXwF%C^9P(E@x!@W*FxLHi|J=l+;5S+oLz3TeyEB#VZpKnUo5(h0^ZXD_7x%GCA^v- z7))CUDUSMQTf`Vm@Y@UJI*(@kI@6p7#MHM|$|pK8O*!6v;?QuNhEKCd!w#=}7&NPX zfKqn_w43S4XeVgmbPGY>Gg5ohC0?uJ5$Ckw(F3#jablC0DJHH<8n6mi)yd-$uJrBV zNvK|;R6Nri{$FD>T&a%qBWfg+Gri64c$nuk5T!UaPkEHG=uUxUK+npi5nXL7rzX#q zQo!7_yD3xm@AY20x$pzn(F%5>GIPCvSU$a}SkAkqqX6MMl`B-jtm$9IeZt%ef~11^ zCYghP2JzmnTM=cz{DCo$FG2MQWv5pf=aY9}me<_gEU5cRo0kocOmiVJto0K->56LW ziTWnXjv}i3d5rQ+^?z|pnad{mv}uF~(8DLo^Y7W*;QIDs(v@ssUJ(Bv1k4ItFG_UP zVq_&*BD+zDxE7&2tyA0%)Eun0FPYMd*QT+{(RkVE_2_^8UAEnssjUIDWoFw~*rIdd zZYuI3dfezR_}ef*x#ODlW}^8vaIKGA>-#0SlXPOf2(EgWYWnMI1G5{6-fq_xC+q4NRQ{0{Mw0BA zl6o+yu}S3>1DA2`sOY_P#^$b>vh5P!9&s$?w-<*!;It0GqA9+K+#E?*qS+;GZL_Iu>D_C{{Kbf zIp`TU{*NI~@c&2TW12ygQEri0q#?xJf~Xe>rWSRGkQPgbTI!*x8=$8a33gx?324OK zh!+XNi=D-(#EA(W3j2Qj_BigmUbA;{I+&ig-A-qRMypGvsNe9-q^|-b0t5j7P{bccPE5YG8G0S=r-rI zKAL>{l1(TR4v+|tEj;*nWjP=-ZvH)A;L0zAJHUGr8-Opt-`>gZ^sfp8*k2AzYd!xu zm;b>neLHGDk|{W-Ij<^k;kG&K)8QWJ|kE7uOzsQcDQ2_Cc;6 zRw_OF@FO~8coT3QFV5*XjEcvz*?0}~9ey4v3Mc|t0Ds}3AV4`Wz@@3d%v)7=ZWr(~ z+xXv<&s6``65s(qefK}WmrxBsJHLDGoPJt)0H_O?m)CE$dp+p5JbZuvjeLMpc`6K? zyS&Rb+wv3q*PHtUdbWP(`I^^vz$O7_2P4BCD_xq1F=Nld8yZ?O+i0)zOG8}z@wreD9Z@4ty(wUocC$Gqbr#Ag9(pJ!MeP-W@oP_LQAH zn_v!}&<+7YP5R`J7ks2oE2y@U8-4q7v_Z(%s~W)j#~}W{pq<;SkeeH?Luan4J%nf1 zoL{eEqHQ3+j}|weK_UQpBuLjW;GIb+eszrf3BRsvwl>{yytz=4gh&Se5W;|%ag;%%||73bg z!w}N~)Z}c3t|k|z`sdJ^AbWIDXtowKqQ$AwzNcHXCTdE{+-=F-Ep@z#1dkzqO&&1p zl6{L4^bSC@Vm(etW_+ws=#F%38-3UgBa)UJ8mkkqNmtnMxbJev2Y}>;OajiIB;rC8 zc>v4anyZ^bnWNLmjD?D>bK%<(l`HtX&`_xf!xG6VHbd2}^&Ylt96YP7&a(;I;APe~ zL`m2!EZ*rUl!=JaGE^nk?5N1fN!GK52`}(PKWT(ZJBjFR?}&{+SLu2a z>d2?irU+)nR7N8rcmU$ z*CpQw83ICgs2qpZG8-(tjyM(upGgl}bWqliLgX?#8oGP=MxWrjAFiQ*r$gV-5YOJ~506R%%sDm1&!GLJOYUTf!E<<+U8Q}y{1S9k3BuRvDZ%~;TbBu`5% zJ$DVB@cQy<1^#uqN#_k`y+w`e6GM!5el?ZF#U=B+7W-e_%BwDl(3`}k*xyM>{}uo8 zFn2!zfO$In^RwC;Pb2OUL)KOd>?~pq7KndEf?1($rm$@Birq#eyRm*2s8X!O`QDKA z6(hxp(|)`p)=M%5Na?h4IjFG>_1b$ns^A`7@&jUWAx2t`%V-ZgD+a?N>g&?Bh|&6L z6o06yH_xo)qB(AJe&hQ!IMLo{>69|*wPqR%8ieERk_eyM_>)LCsZ$v|8FgsD8lojQ zv^dr0Fp0%MMp6fdpKEbSeevhd2 zD){_hLmN7g>d+Df7I8)9rGg|fTD2fjr?Uq&O}*qb8QC>r)OKCqll?MWt2`MQHJM)% zH}2c}?jT7@h?dUmL5*(HkaVfW+Br!^GM`LmQ^w7UJi)tR5;{AnILgERx2W^wN&jKs z7+oGS3D1eccZsm~ixObmS%pO}vTj0%Js=aAU5?PZ4U2W6MmXyps+!OI>DEu5v~k5? z1sAs1pn}&XoOWQgJFwD-C{!$|6j&UG@h|a5=F;fWakR;>VW9FD2&7P_E``O~KdqK7GI{-HVri z5h1CY8E3lr7C}@PIln;a{sNTA3lq(QddL&LDsJr<-is9mv!@ktYci#4OZ+T<^33t_ z{vPZsPHtx1_#(Vz1S3u-1*8VUr|zHD10m>o%#&*n#I`{vX#iCq$WKZU^4S}ao+3&q z(fYY(?p2QcIgZ%t!bWs~31R6w=1SDTuH_m7xA_+&Qs$bAw~#5{F%aum(`eBe#R55a zFjkS3l=4G35I&MH%u7=$H@KWCrPAT#*oS&RxpK4K0-gkoq#@a#^F!h$>Oh8krbd#G z2*-a6ak2(xxPyEFtx?r+_uKXQKL>lE<*YtcoSjxalniJWTT^CIHcU> zs1wSrb|WRkN#aT{9+(38}; zAI>~BVSf{Mo$b1F%E+=hL;XgQSog z+tB<+qA9OJh`3UvRiJRsTlXU#sMF@_U=p@W)fhm@jzM=ruFii;GEE(Vi4Nf|FMIi{ z>F2bCGzDn1)DGO|d^P>sZY453f{L4aa?A^O>9w1qfDCpUniq99Lc*(9fyyE>OI~Z6 z!m0U&rh306WP|>ZXsr&VYFCJrsy$Q^b>T-wfp+Nuq0J%Y^3KI0xykiqZ$|al?eKFsjSk14DesgyRVE zA%_NSI-R(t%YQz=fU9+>JWsUKdoy415c@up zwc|-bsUlhQoe>)3t&xb(+MCqSQLKvd(LVQ$yG$4kS={Ajfz@x!g`ry*rTjidea#Em~u~@ zqArWjrR;Vj9_W~0HnpurV?QP_76qcd&?3OkVMbs~#)ZikVDO=6j@A4KMJUir)iS3P z9fhbhJSV;;80|nmB+IK-vJFyq-F^j1eUz}HK1iA96xcwQbrWjx3zD8jX0NQcwXB0) zv|e#a7%P4?p`ztS>!h3Mzsx80vqTyqfjIuKRnHj<$`n#@ZcleZiOZi5_w`Ns*0fas z{KNHxRzTpMy^A~oCkv`a1^eDcy>PIk_III6UUn-qjH6-e%d*SPRG<1|tLiFUG(s`S z-O3nOzCwf_3&tBY4{1d&QLTSz<_cY!*}ozD*lTwUyXS{d)NA&$9aEIoF~HXgHy!0B zORkt89ct;dChR@;IPI;MwmQ{*8|I}fIT!3n+5C9Tsgylu|{O>>VPrtR6N~of<063@WP=?)!^bvRxL>Ymu>G49R@nPK5pA!ASq6N2ajp z*3+Wtmx}o3<_|hpkRE{YTGF=#0c0%V=;PMn&e0*j|sh&F5OKEptdI4DunJjCcv|CXQF>K)JC=fq=SzI%7!sn8yPNi1}-vICp(U6#x zut;z=dG>ET#q+6D?x+p%(AULnToNoPE^^~WOW&}6Go&)V2z$zQsM!O; znvS~Z6TU=Q8=7T-3aY}QWN$7FZhn*lqrP@E;b~XLo#jMTW-&t@s+y8LTz5`8 zDu!KlLoXL0!I_^LbYMSiB&`yX4^F%)0n&4tM%ZGT^?_9!w@B=tqzG3F`ft``&DW?j z0q4Jm@`;Md4fay{f)U81S!?n5I`lTki=n1VoJYh^r_RPG7@28HvfcF2LI3`7IoO=K z${${9fJsu7TSH#Rx6VZZdMMgZwmso5KB&iJH<|D|xVGpMnmNmp`PQWv#&e3J;ob4 zNUL4?jA^0}edwnLiE_z$M9%AaH;G^{y!d0r}AmDj8(7;gt2pmv9PA(fOgQsunu zJ@YigxP=d!5(#0*^PSJd#j;f$>w}uj?%F9G{HV-@JTyWdg=-!cTknD3>zsQEHdKL8 zpO>MeZ%Voa66B<^38SVTG?6QgU~u;h(e+jxZ(Ljs&eP`}i%5L^g0|Q}>Jipkbo`dX zQU%wWGj=gtb`19Vc~+A(EkmmBIfLe!&TBmNS`Q+64s#-ZzF5m`(uHoK7yp%zPMEBN zr09XQ;q`eri504My^21rs&Rj$tfI;=h6zem&*9wzbf&gb{)liYOVdMUWi%>xF;eu|6YjLew6go zlt?E8uKhK@_b^}}ENIUSD$t3BwCGo$H#Ib1lUXV#5XtA8*VnEo7Hj6(-RCs~MisG5 zk{)e89MN)p3Gs;!qM3}<)?+#wz+Hva3>Kd@^c?)sO`)H`f=`Lybe*$$DXQ>-$wgBZ zW8z27@Gs@H;yie~cja=zpOM)-&VEEYh2OLR?$LM3l!Uw<`Pq*~ZFP|8(L7&DD-$`x zvrLw+u`iEIojxAzecI9EjgI-5v3ybBmdl*SeSe9S7Y-|ggDP3~unaK zKj)&KeY~<0AptI&wAXF!wNIc{)v2wuny*Jx*T!lZHZT10Hp*O4x45FwKDKe_J>P zkud?SSz`29oeas0Wl^cyG3ep-lp5&O910nB{JC$kGtoL)lF!AlTnW$!fK9i!*bK|S zqjP(i!ua>OpV74Lt=`{a#96>r4eh{SvzHUA%jbf!H3R&PeAuwB`hSQ$GfrX)N8H_(+({$NIlsS6M^75Sa4 zt527CFJPpeHGC`aYP%?PF|+(VK+44R^Pw@CWclU$Zely3bHY9AQI~l=Mo9A5pE;a1 zT2p7Y&Wv5EHbhPKM@Im}fcZ>g+182H70Et|DkJK|`E6#i6CGn+hMc;-<>mDTtfkp zE<$LvaN`s$q!;S1Notv?vEM^L;Mx!#!?X}8BA0=Z8qUBEr-pPn>5?vA7T+qT98|ZI zj#a%omodI`FcvO^4|ZlT^ry}tYIVk-@6162dbfWM0$(&h)bB}thVkM#P7m7)LPLLv zJx7*jWXY_sCdPQ^$r``OvzY$=K@>2YA*V)9K4jwI7y#rEqP`dLt1sD&{cENT%se# zo`d-Z`NKW){LRFi=5CQcJTIHsz-IbvVF^OLqGtqMn9_VS_fB7|P@*zZFjkodSZZ@> zGiSE2e9S~z&27>4Gb-4@Jdkk@N+xn*jZ%Ps--(L@!8`Eb;rTyhO7Ty@0KT0U>peay zj@SO(b%)WN;xW5snf$sFhBM0=H1_EQAZ|Y3!`dUw8^bjH+9UTU_@anQTzl4(1f+0O zaTt=TTlN*{(MzT5 zH7l2#rL73czoCIBC4|n#AKa`)Hs1#cx4de(Pj7`RP##wsqt`Xc?xN(&w?rBI>JD^= zNLM1&o-aC4ycF@4C+-)TGz;EBQy5rY%WF+pwzqxL<6_HuQTok`Cr)v7BvSepvWGsY z{|3B7oBKEZU~B~?ipCLG#s$BUf44=%@>xzMI93Ku&sMwB?!^nQxxu*tNfIA2_l>&u z1;Oqwl+5`_=qc6#v+!wpC)h_g;c?Ph=53){J#QLQq}fuu4s%DF<2&}etQ>Yt4V7OfHo#ng;Yo_U<9*qu3RIF_gE|IK z02joph2Pp=dfXBmayOO5qWSHlWTPzcIE|;77BJDrBO^Q( zh_7o`S2+#xzl7n!Xs5mBcKs=X%906u_}9w~h3HL%%AD@{HGoi)c>{YFxJfRm^H)PI z1+r#gXeL8jV-TlXHB4NN2QQ?;S70T^mYL6a8Lz$7y#e z6vyhFjs6HR>Y2d$sf;t4k@fU3z5x$V{wNr2$B%E$ZK+%G-7o^BQUYgx0kOV6y`M*) zvUJoIVI3WI*{NuMF3vOn8ZPQppF&T=Q;&8Zf(#aB{ zezM^cVP&sVB@h#bmSVn*&*Q(lUKkb;*^u*~>m3(zGkZAF zyntYLUR1jlKkinb>FjSnC76eO#om{&&z%C3ifQc zNXFNIsJh*(xaeR1jy-Du#qlxe64i1|63q}GyK&a_k+XI|iBzyYso6dH2dm~%cw(W} zY&fx+&S$VHtSn<{|XxX!q}9!=lq5P5%e zv4hfJ6mS-sht`;9@}qgAH2qPAo}-ArR@P@nao8*RMD{DX@h;%6p8G#(=ym(p@QYYICZ1pqtQ;qqMt`=XL@TYeImdb4>xS?i|0bc^P7%2bHT8No4EG~1F} zEqeRqY{BP7|HX;2|DqrRj*>Vcpu}LxTKJ>2x~F^&l6p-NMMq|}oRm$PR)-usPN`pL zk{44&7krgZL{`bqU}{%^%mcZRzw1kXw|ISVBqzh*n3rTsUL`>eRRtscp<|XhWN~J+ z{DwUzM@V1cKWLR@QoCiNe*FX}gVMOp;eqQ@Oe1e^@?pF3kk3<=TjhDBlZb{9t7#8D zg@g4XDr?THTHp-0z#!bek8r_gsbdy*k3z(Sy)VM%;FqBtS1|iSPCYM&Z$*1>n$p`z zf%E&IDL@OXS99h?+#I_mdd@&VUr^?>LEZ>Q^DVFQBXvrI%FboCOu_u2)skQ;8EI0` z|Mtq+E0Vc8%65e8QA`}FL~fYh+YDedi}=EDC1f{4F3ybuvlSW8Wm??jO&lj*Id$8K z;c$uV%NduS?$?1B{j-lP8^zs1?QhE?==iNcMfQLl_}88UWmfyKz{!_@fBU19JPSz~ zCCT3A^D=@QD?`0~+wPHmy)k~slwpFaOmnzWy3R8(oT*WrZm63~n%!J2!)`1NrWSsO z5jAwAA}L9?W@R;D_q|;}TEDaB9CN#=mY->QRjlwDh()`jYmdj{L#bv=q)fL9p_U^5~ zUvLw_0qs)H`k|Kfly5gHxI&d}V&7^Dap=!c$oHO6tIy3JGEQ@TW8au%jXm;x+A;`USJ6&K%zEmD8g1sGIpEnO=T7Q!ntZI?5Z^=Z;s_9lw5FG4Eczllbo1a;rm8t|LwZT5E~~^H)XcL*3HQGDT1PRS@h+JUF{-{- zH?6$88VF7XLF43}MZx(sqz+iR0fWE?D~zenhM-y4w0=@5JU}@w*a2P)W6!epP4Az^ zS57Kru&+BR9$lr{$1-A4J`bM5azeaCLdG$G(U+@#EWnTHidXYEW}-tjA$zmV7xZc+ zyt%=D8)DXa7&4RcD`^5AEppwl=RsoPZAcT%Ys|x-HhucdG;oKljpji+gZVPMs3*eo zE9}QTJu(ceE}iVtc+H#w{Cc^6YrK;*u9c_N`NxtUt;+JOcBSvRPYbRK{B)-WG zSAYov58refaNFT9`S1(xBrwgwtw6nbP&Xy@tCz>+n6nY}kVXgQ=I4sB#99)W_$_;K z_$+JJOGII7S7?WQe~3hl--3yMDu+-JsD6Ef0I<3Motz2Pkv67~wB(VAER=`gPy3ZG zy-lF__1h*-FYsUE#v=ZND?N6HTG2Ezb2MzMda{OW$zjo>PVQP1CA~^NA=IT;E{hIR>?HNX zL0i&2hm^S1w>N!6n7Q$p>(ax*`RncNTbwtwmNOfkIt9Ks{vwLaO{5P`0@!!Y}8xzz2Cp-UW4*UN- z{U_OBWME+9_&;Xne?fLyK^1gl(P<;C>;pltbpm0~wzjuj`~kr*w{(MsA#SjE+Pk{A z2S^bh5CT6*-@p9oE_S$7on|%~J6CUdxQ|WOvClhKpOZB z&&~|Og8*^(3-tB@;by-BCK9-Xg9=2T65IlScID4Yad3EY3RhR_=B2)0BKI52Kp31J z9vc4Sz#%k&a|=%iD)=LfEn`{#HWzY^!R7B8zyWr7euo7L&TT9&C*;LU4-N*Q8sGlC z*s~^`8iTp>Z`T4|8lW>UbE^m4OEd6i8pHbvV^U+$@-Jl_I)?8G4JxSuAH#%kXIc}S z8c;|pgJCZRUBkR<<`58;L(D&b2>n51EU}Ob2libUD z(3#31jIE`srbFn`M_Tut=TX&!vLxI$u!9fn?9Bh($RioTwEj_XrElezTS2?n1AKl* z))2}^OYIZUXy~ztIc*F$32Sn9>C_HK2w- zxyFAXXI}f~L!94c5aj&c4clE{OuTAy=S{^^hzh2)PBO)X#&!v06gztCx z92~&q{o$d>$^Aouup#yi55Vs1?*YGlCLh{<`kH@RD+3AqZeZWw3viYe0Q+CVg3C6( zNe91YYYpC3d2~M zyt-i$(k&p!*N0FIEpL6qp?zGUwV;+Tod0W!M+1mQUe=hoK`Sbd@vH8cKUhI7&1Gy)j zg4a9Si+#Ej*0}>%BlXGjA;Kf{lYPS*f!B|J1#tjaH~JCl$pK`I?1tY)fIhJw901kx z>O#EyYWPzAX?jEVHUj&Fb_8A{_zmm^VC(V|)ZE>G`~5y`f~30vVAOr`VH~hH8!XxU&FC+m>JL^SSqDzKCTps9ttus zlQGY96(^5K7&e>lSiS~B=FDy2p>>~r7ozd4hxYQ2j{H}vi8$Cf&2IpEcUcr~Inmzb zPJ+Kk;+{5#Mh5XY^Z++n?lCSerpYYS_qomSZV9s9$2QzNwrI-Ua%WU^x~t{!H0G)D zit39Fp1m&jq4g{A_f_W^eh{M`VJJ5UW!t3jNezb@PYHnufqV@kUzvIzX0bhaBM$ir zOEdS~-L*gYJgal+?#X@Dqg+0+KPM<9Tp=e4;vdD$D1JoTm5wLRex>|EiP`Swno4k@ z&$E5vMY0jhO&oA1uiqRsl_@~heE1ypM9CrN=yrL#G|9(Dnt-=EM~lEpKC9z0^kmA- z5t4neEQWIk;;25cU;9A6?p1HH4SPrer367}5{O1L*tGn!w0Sxc@n#P5wef*DeEXfg z&BKcJz_sbCaV+sH#^v_75_!3QW_VLqAs00?Npoy$NbIX9dtx!DC3*doNnwp;6Zp_n zl7aCW15oNyzo$Bt-CVkGa^3FgTaZYz1@=$J6{q#eSY^LU!jzbX+=v~Nvz)7 z?YqGQ!k_Y)yjmOaA*%mX-@h;nTYZDnb=Kx;`aIPU^g@@(&00~WwbH4x8b9Je!eIw)faO4o>(t7KA2ys7=utG#(^w_p(k$!WM!om;|i zDbA>Cg1gWxLge8RG-%);OjR}mPE0kX!Q+X1FtVOcEW*BDlbJxbYKwA?Eao9R^94v+-4*Ba3RE#JADu(YW+`ip9?+i^ed=e z*!{z!lZ72JXIymw=%m2>X5D1~pov>^V8pHSM2U9H-(#wgSx?DY{e2m+xDI!P*wJyM z{Yr*=N?2LNe_g(=sKeoGzng6Y(`Fh8f2?;+ncgTA{Yqaz5AzUH$C2s%@ePQf;r7mi zNXjtFH{M-1Xo?9!rkNm{k>`C`konlOObV5B8pp^2e*`B|(1qyM=-np~1gOoE?&ZoC zRIbTMR|b#OzJrr%ADM{mIjQK5jDbANIV_%s?;c7@Ot?{Uz-8`n&zU7;MSb;kh9Pw2 zV&qz}x7Hl3LQG7a)a=+$sYG##^g|^Su(;L%jo}oUk3TQqNR3y8Bnwo3&(6v+pTtt0 z#g+Sm_e)B&_?|ht&9cZIbLR0)O@_4SV;LIwj!xj&M$tV{&dw}cYhFUELGe12ex7nL zoABHtriOSt`uf94tgeT3kql-ev*P~bI7&25{28o1;Qa3V@#d6Vq%Ab8kS)-brQM19 zQBjwp#y`m^;x{A|Gq}?6Hk6*D*MWdAiVGXBY zW-O5o&eE{eEBLM`0UX2+1Iid5G=e&&8jGFiDz*X5)vZi&n57+0y}|tG<#!fn7wg?B zySRbhGMqSvo|gosf{_ljB1_9xrw^Hsfytw@nhC`rx82kuyq|KLtvB}bJoEP}S8b3% zHLDI@%}lOOJ}{{niC+Z#sJ4BXobu*^irN&e8Ah(_j>dvT9#tlHEpD~d6Z|`{Ww)!s zpy}naQ|s*7a8^Z%*^;TlggwpTIkwdGR^%kLyx2=y^f$x%_g#$TmLuyXp6uQ!SM6EB zfsOsk3{SliM=}NJ}#?>Axq*S0_K#$G~`~504T_;P3FBj`m za+vn7WxZz83+LAzjEK)+d+Y50zni-;Hecv%LS`<=czu2^1+Ww3wu5!wQxFfkn-jNw$LSqkK3csCx+e_Z1Eob#>m3UWP(tKcmawaJG;6BBPeAnaW(pA8+T$J zhJT0%wN7EDP(V`l34a#8x_ecqm8*hvMQ3ew@o8h`^!+_gx3(r0-XZMyzEcKY^`JTO zKzW;;{)CoF0Pa&@1)S_@A`kVe-_&ZgbzHv`fBDj0BMv|g1&-F@c~ zgRY85hF@ewfk$#TK8%v)qUP7aU=bFpR%E!I0QK&``C4wCEeNEtz$3{E+kLZ_9 z@BxOGxav~Y03^tmm`#ER<<1n2erwri`J6)*w6qXPQ<-*tvsFDSq*f+o$laFD)tdtg zKFJc})(TvnHC64R%Y-_~&55wHWU!c+<-%$Ydu;PrFs>6(RweChZUj0u@J)a}veUWylG1(QmoXm*e;27+Vqu2l;R?m+;y&J!F7g#;j*i zxI8T+`{6mcGx_kW|P%4OPTpn8nXE0w=G1~O-gwv*kV^Cor8U|?t_SZ zKjC^Pbe%4)!D)+rbrQ>Z+_Ve^K%)6F=gkZ8?wKQDt)t)nLYt)brX92066F=&4O*b*@d@#bpJCTSE1(ALU^e{&#~Esst5QN8N43V zmj?dUaz%Enm{FHrBYtgG1d{oxbHOQTVy_-Y_gblncbNRuOk<0&4juSRo)Mv7D14DJ-2Yph6*2@))k7I?pvklxJB6Uo6DeP!bh(q#uwlpwX1biA>I~5U2as`}w%P}s59N!c?HKuFFnO+J=BJvHQYFEX==Rt`0jj%7xes86m{5Btb z@ZdcrBv@z;dl~k;Dl++yMc7ALtgOqKCJi$6iR3)5Bhpn9Hqm zrZXG-lbBTR*+$@HqqK@i6%qajEPRSYyCi&bz%f~P~FgZeCvOe6T+RBpD_RqhqK zG_u+BQeOgn8g2xkbd|LYbA(ae7}_ABd&*}SKUvO+Hi4W=50kI$Xan%>GHu1PVK>xRjLvIwhF4TL<&%6v&LlRevr8+`nukKdx2K{lJ>-SM-LrOE9Y`Pk$eg6 zJL42T;uG)_zSszbof)Avn}}F)*(~Z;2VIk`+n_Ez=CN#b1}-_Af@e)!B+Tw8j9CBj zHbt0U%sL4veSyDe?S@F3vrxOJu;tu7gwPq@5E4yH9*`fv%Ru$UE6yJ@Hc(hqwC>?1 zlWa4pZ2LQ}q}kg(kXNpd!cmw#lIZ<)&`3dfO|4LOP~YGr?KUqwUb+9gA3%oI)7rGKL|f{V+D zw_ZCFnPh*L(decD`BV_58u~-4aRyBkGksXOg2+2}NocQ))WE%Y1DhCQ(Ta!(SXx_V zin}54ShB544s=!2%WxEE5H6@0Ziuo%JPl43>hl5fBzdbGo<&u>l;_2-ch4JRcglKt zZ5o(1x3Mm8*>$zf?e-m~M0F=2n-HXiUGFHeTTk<+H|Ijm(c0J4>7c5qMzih%j?A$B zuG|<&kr|#o!5RW&KF`*bZ?Qj|03?^P3{{RuGJJ`xmim()+9;kVsHC? zNJ}m(vrUR&7Rhh{9s_{9cf&}f1)?0>vA%3-$*f5+^5W7u4@$3S-P=I7f)}nQL)h&~ z&gZnF^<1;?eq;yOYU-rkK8nuY18uXjb%n52e66Z?MB*0;s4jf4J62cy3C3!PO+=;w zy2X*O9DQGI8jbu)6Cls%U~gN!p)KRNa1j0B=5)%Rdp!1n5-Uk_cBBn!$J%F;1+OPU z$u6?!?wO6@+SuR&uGTRT`J26F_usy{5w#X8KQ#!(^yLL44th18;n>dQbZpV9-Y!0s zS=2C@`4frb(tdxKmKR8%KY3+)8RN(4cxKWHun^!U*19H8W#oH_)-jek*=SCS=t$Au z5`fOj3dLpSW%hK!Nu@T_V)6>rGPBk?Qn4e|ZIb4ws!KY%MF>@w1^OgD0V^v6@ujCV zT?tx*6^@vdqm+uL3m zGMxt>|Lh&KZsqC@@g{PsaqS=VoRLQH>7YreX}&O-Pm>YBtdhaq@s2G&R6b|w8jyaf zzuJOfE+;Ca5NgTWs|$};Iz0x%?-9v{yAc~3q(abOFb*hRM82l<*}X8&-86l{g{&Uf zA12m4lZuRMweOU?EbN=*gKNX8&y>aH{dIuRUdRpIN|i0!!dOik(!9{NWc zm=3OyzmLxkM|pvQ@$&mn;Eg74)0yG##d*J-g67ke@s!ezukBubN`3_Y%eq7)x2 z<&5N)iomQ-Z+{%W3Bf%Y*$y}CJja_bD}8s4)+GB%-PcQOCjHna{w6ITtY(nrr|rOx zlKC1^DWE23`I%VuDW1`Z06EI+^q$ej3)O|HKv4wgciT-MmCf@;``-4&NyL;Ihn68y zxjJLg$_`C>wjc?Q+R`D(g zeJstIw#f$K5rl7 zy@W2RsJw(^uUm;zy;lyrlj3#lwXL37$9@H%(bxY>T&}##atU!F>gR4f%VF{sEY^?+ftc-ol&}p;znFzhbfj`Az!!P z&BS%hTzlwrk@X(0F@8w+iD1_`KqQv~7Nt+>wsxY808dR1g#Tuq$e~!y#qZ*}2diRp zYtPBgo2+w>xk(#^14vKmlLu`=!`&7X*dAUqQcMs6XU3pk3^Hpf=(eoS^XO4Q33&HNNgJkv@n+)*TqW4LEV=4ceF8W*eqlIuk95CMI^bN}lPelxNG<;r}1Bc1{l zDj%=tv^7FeOSvnMvxXT`NFfQydZ}^dhBD`?ESJe?0%*-G^a5{i&tp?aehVJ>MB+HQ z*rh>QIq2mM>%l`_nD^qqg(_)LxReBqkM}g#t$IHksfh5G+3h3x!Vlx=QFz^>(M@quPr41t z4TScGJ|1u9$==jV2kx{i68&^-Pq_kwAAeUIUk)_wK)f9p2Aqu)@cof+US%AIZ>Hf= zAqK^wFzCnhhm^r8g(zqf(Eh5ti>1k#-%mRe9#SFD0L?jdXa==hz|7>w+GbV`zq+zQ zl~h}OEk{BqAKrmxr3@qF(C6(U5pkrghY(+mO8f2xpo?|SII&P6rdk3fj1K2>rsA{3 z(gz;RG^MzDx#r9sZdd7n<{4NQ3Hw+WXBJeqHL>j<_t2$G+qIxscM zXGWeHhL5<|ACR=e(Q+`nGnvSD0IOmj@UP{F=_gwm73I;)Rlb*%8Wn2ffgYL&XQE!n zS5SzgmW?%y*2(JvrjnY_fQNcQ@Eofg^mC*(^WHRn8V5loEJH|}tAu$6+R-kcct+*% zu;o8~$*&HQ7cQccJmVoUC?n};$O4&sEKmP%c30;&Z5AHH7!$;62SGIB_sSgX3z_@D z^C~s{rvG8pPo8rI)G#x-;0#teqYkeftHKEO47gfwG_@+Hc+Nynv1Dl4&OQ~iuI^^y zdn?w9lE#CdnRbb{41 zxXe;{QP=NY(>ad?Q%u&&udqA(Otp4(B3~G7@@#(NU4A| zAw~{n3dtyC7js4&@D@L>NY?X37v=?GpUQ3W%Gc5`6iFuzsz_MWrNw1}!Bg}=`orsV za9UY-7cJqY}4Fem!yVfb^X z3li3Hm!Ht2KOA66a_8@H)^sv?&BKWdwphMqRwV>JCy6g>!;mhkK1`?|E{;39c=C8& zffVTs0-En=ef&N9j`=7h-}Iuc`GCXzxYmR62FMAZPcS#W%t@wg1n2@)bih@QI|w=` zF`a7exh=}4S-ud-dfq4F!D^?6Ro-sxAlY;k_*+jrHkwdwFsrrzU+!>W-S8eN?RS5Gy^-DB3)Kp2);M#&$d!wM;3{uZR$Izn@*VW=xV6lFO0iI@?8u+&T zlUqquq{z8-;u>*ob*SeC+f->^`8^t=LVwsan;=4fYiIYb_vh$q2Qv!MZ7-nP^_pfK zCh@kxGJOg{C>~NG*P-FRK=F=+ur-@A(dF614v*w93*>fTz6-RmaZ+VFvnp!yut=b>RU3Hmh`P6zygY|T8eg%CVu_sR|*KjUAf6`XSFAB3fz0Uhc z4JP7ti3D*EvAXrCMasjf2l}L6V$q7%$}M3URcp`rvAUupIUcu=TgQ{;nsv-i{HpAN zUS|$DN62HGx-kLvfLRjhFRD_636y5+`_}!Gb(8%d=w|{&b;==@hFAKlKM^ z&aK!f!%j;bi_WflQ?SRdNKtl=nRWVWY1Q#4u|=`KyL1m7Ha$g0X9z_}<*b+Sx&+St0tBjg=4n=KJsY6DW7Z3S$knSidAk205Pmd`?Dl&Cf9igc1`cYY3aL$~$ zQM3mz38^0N+)NjLxx_>#wV%>|yXT$SJG)Z#HLGK6cLD+pDzfDf_<_^7pkV(@O0FMA zEPNU7F&Cj{^n?W&VLbSckPe<}AIp+;>jeo(;$+uPWph^xn^hk80Dn+z^CV?RHZxI1 z#Fb|PUP&OQ*jH)-LMWQp0wpPHmqfD{Dc{C935N0+34Ebcdo3z&csIrC)GAMh^y=RK zXaO34E-+5tyUXWW!S-Y{5bb=1Cv~e2b-G~a^KBqKn#N|+sR<_sD625WFJq22&Apx50UM1qsL{K zAE?jnaNb{=uo7&F2}0A7-MM0*1d{6QECoeI$`yfx921|3g^9(Rhd=7Jenq&?N2}LH zpye0aT?Sbt)kX)-^V4&c(VAp|8ssf2a^w=v34!3fQ!Mo4q*vo067W6QJ@K=N6c&tE zj)=4&=ebAevSS6}bO2_!8A&6{=$)OO;lFFmdU4R>c!sFU${n|>cJ6y3q@SGgp`KTF z_zB52m!`I5_@2w*XtrxmsrB$M%Wx6lGO}$azKpGuC10ek3G7D4qOKCNGddAda7-Ry zq)oeE+{6BH6>^xO{zD0kzZ8b|@P>-n$I&w#H>O}L!Ky$%jTTtQ;05VY@^uk|LYRwQ zLD*uC+@3%rSML#0K}N{{ktVu<_1f*xGUmjI^RkT@92^&cR<(DL!R8~~YReN?nds~# zXJ4|g5%ancVB1;lDXc$|O2WB1>F^esCp z6n9^M6=vOd?-V^8UX~Aop_7y}pl;vI?F+1(RUd%APHc%RzwmuWBR{Ie;N3DHf*5UevK8`wn{AQB<&b!8OX+$!UtCc&?O_A4wDUG?%Tq@7<I7_c}5HXfa99(%SqIUQVQr^Kan zOba_#jx-qpB5NxpAlaWSJ!#~5X-{5V-N-;Lz6;H+alE!1WTi1Q_>S0_*30?Mlu&!e z9GGK~CCKj}*6m;3d@s>tas_V-Pj0T~?=DdgGga{SaR+~8!6=a7Sma`Fw{)eX(H zy}dC8cE_tZeg*fczG02i*$)S&VgDXRF?Ad%L66-Eo2yWM>(FJJoc^Ulxj6IRLqxR_msp~}W1>SHHMr5rvYK4|Rq z77fEIeaEsZp{oPW?!ZdjuBAsaErf}$?38?u<9yg{-%N~tRV5|sR=lXuJJ;^h->?+F z^%c^f!VpR3qlg^#$k)I4aq}*l$Zlw{p@&?D&hUh; z-bJI6;hjl?Z5xbIa5OhI*7F8AwNyd2adTsN04VMAL{*;;{%jFE_9^^?uL70xW?7c1 zS;)SZr{?{^oE6mim{~XdT6o-D;KHM2A`^C>6BnE`uHkDzMyraW`e3P*hEk0Fr*zns zh!&bN!hM441{&6=YPyxL?bGA8;HdO&V*bqKX8>^g-%@+jbN?TcdOPJ8%21X*c56!< zKHYt~#mwYO#}fZ)L6I!aLHLzVe^EJY6Vb=WbajvvXP|&CeTIjiHjSOuIp|mHC5#w; zgg!hh(V>t}5*Ro4(%E}4NryazYRMf>$8qK>Z4txQ-1FfEEW1na$ij}FA8Q;|T4SGe zqRr=54}pcDlm{_$x925iz1Wi|jUBb=GxNgQ#h9;~<%i+{?~>$i9O8wg2;_^b4>FAV z_L<{(^pqjkE3){~>U|SU+Wsaa*)E5bFiqi@!So36e?{z*a9znw5|#KLJWBFzND|mt zV-!eT*B?t)XiW)qVpX#k^8$)%=2DVcxPqm_irG;zDvbLv+UJUCc&?Bxo^3m)M~%)= zs3LHg5qB%SX-y}bd_9O#*g%~iYl&_H#ddv>R?s`c_o9c4l)XfsPSd{3am@7$daR=S zk7_)gnrM4Y-n*Su?;(GciEvf@GnQTN^=(W(pLG0bu>{^H8BQYo4K0Vn!W=OH@oa}~ z@F0ZK7OePB-CAtiWG{#Y-za0p2UhtPnf9{dY~9=t-+6(oDoj_`*c|Il!vi>YqG%18 z_rZrWcB+=@j*{%b=etOf+7wCB@f@nLeerJ!a-}$zH6$x=z%)Dl<8^aCK^f%rfgG31 z9l3E$vYcPb<71}iPP$Dx$!Tlx!^N9yepIHavrDUvKaEI2?!YwdD^YteDg*X4@pAU) zErr^3a0?ugwoJ4SlO@!!SIu<38a<-ev9;-(PoH8j9*yHQA&)mkj>OC|t{;qvL{9gM zFYuZIS!{xb^(zZ7uXx#ZhjjH-tgO6N44jzH+3OS&lKCW*Ndu$+V18!uL|2X90$_dA z%52FmojJ22Hs_aZub_Hv#d>)b7{T@?lch|+5`~1PBGV<5@d54j7YRVy*yHZTK_pY( zr(1<94x(No=1VO0bITeoQsC4Tb-^paIrth%T@oQ})?Kg>_8#!^b5gn-n2e|SQ5iKi zBgxZ=EA7(Au?hULEi=&UOzUk3QDTdclaoAUY`y!f)ikZ;Ohu@;LK0!qEI zWpFE_Mcp_pqPD#Q#onJeytZxK$S~4U-M0K1x*-*|?Hhp3)hJp=se!z=2fx61wCR2S z#qzN*{5Q+T!u%ikEjAX;|0nzY)AF&iurvOz^IK~F@>@GiVCTtl0V!gZ=LjUl!dMA< z1_2=^=&2=wASlJyB%+-pC4xeof}O(gNF~yHH9r^MKesuLJL^uaw>fsEH{Nc&9cJq{ zR+sk^>-{zTQuY{$>i+N)knYtL)Ib10A#eTyg5GRwJ`hMyKZB98rVwK7LVFD3zoGnM z{(=(8vVg%N9TtBL0a)271Oy-m2&gCt$RI(0Kmr6J`f&CkB>jQLaE*ZHj)2Pt3=P!1 zTSx89=s|{N@FKX5>qz|uYc1A(6QRuC8# zF7+unO0E(l%p`q%;o;%=;*+THaSUI>qrmq71vh}52Wkz1|K*bJqUiP@#~{D5F!1@X z1$OZcKEgENZKIw52>St&0ihbe26YqxZ5gl`fc&|z^UEp$=N!QXf9zM@1_QwFPL}~d z-avljUd^8BL=e_)4dPo^x5hC+9s~QY09p|!F!D=^2g0629smRwvh-sK%BgWs;T^#R z^9iVv2XFrh0+4dz0zeGk%DdLCK!h_dq|BlMeGkX~s$(sYQvbEa8_db>XDFursrx`7 zfT(A^Sm}B5Yg0EtaoraVfPo*+3K%^^7G7>dHY?v>X-0`K!89& zMhExT1u&4e^7_#qf9}a1=o1XkH&yxe<(siL^QVmjT7x%&7W>}&Y!BQT03i7bdv*G_ z8{l_)2MPkfhG0d~|1WL+uL7NfYXY|U(;)7G2Y3&X4xsoK834e~=SMH2pxFdCOt9z2 z;dfidm)8T9R@dZaH~2U7=y*RD0ACM~z+YVfBz%EN0fQh^>+PF+a`)@^;AgWEHtw~32KEiq`|}ilf(`HwcxWc8 zmH3kKLFC1f9Yi!%i64FiL{sSIS0<+*q9Oo90D#AS5mwwr1b{b)!k`84%U6vR06#uV ztVjre!qXQ(t3Ak1oi9`bz?-41oLb+91^8#kHygAxz?-7o+OF5q{g(v%8-F{8|1Ng) z+u&VYVD&Zv#8UhZ8cgLz-%Fo92*Vn(bqqf@Xq)fbLcxW}qelo%5BTj!{gYX1OqpG~ zyN@X%t!>&6M}*GtdB9}2a>r0FTw;ie=nV2YXQ@@*b|^dtVaz?3ta>j$t&z(pTjrga zSVgC}quX(17slPq{l%p1hhEnk78r*SOMY8rgGonw1hSP`Ql6JHm6w_u>MT5%yv><) zYE&ii7Y*KN3`;lzEJgbNF!m1ZnQ(2mbc~K|+qP}nwmRk=+qToOZQHhO+xwY(7`%i1 z7uM`rbyS^(-WDlLQiIVkM`nEh!I#0uo1yV@i-uN`R$1%%tv6rq1YuA95t=|HjHI2Y z;*Y=@yZ;JWBdoBP6sAEYSNsn;Qr1h0{2`t&+bp?o%AT?g5gv&c9#U^DV2cw(9s6}1 z3Mn^1jRfF5req-cPIK-_ei5~_6-9M|j5bQC99qFiBs3wo{jfR&cE_h>vaY2!kHa~p zC)cS@0Mb#z!MOSB$cVkThfn;&A%ZV<9eaFaHCk3Kg~mf2^}XcNjQt$zJ8kz1P&rzU zn&3L;Wqb2+)EQIIwSkYW8+{e*Vmb0s7pI+ZH?44uwWwe3$t3sX#ADI!s{ z!A;q&A3j0iv%>h9mS!Ju1`Py}l>4Z8tn%(U^eJU44oYvir8IRLCbvu>Rn_nsl=qH` zHLh&Fih(Q3jk-^ooODh{Oc){I%SIxeYl-U4r3is}Cdkx4&Kj|t3ly&Z9`@X6IqX>E z>t-0(VRRtWyFR$_llfMyZRavw<4F~|Re^3_)pQU*{gQLl?w?a%Dk1&TIms!&rPcRh zw%-KsZt{q2z47^=fw^{d)%s^R7krW&(8}eLv*}|H(-t;&Uk}u zZz#OwiEunQ?NsUUtxMwE1z=24SFoRDyGR9P!*8G8H>LxF7mY#EoSLMmv0T3YQ!Mo@ z_Sc<_JR4ryP<4NC5m+2z$}A_QTE}q5+veP`FrHJzsa6iO(e34=j z%_}R$8Iji*ea6Sa?uS7@pX!xcL)(4!veAf5h-N{4N$1~ispginq`j&cnS*})GXu*3 zIU*RvobZ=l1>50A&c)HjIn0B!0Ohr6MtsxiRT;)ke*gNXWOp$3{FtnPY+2%X@*qrS zQv4cAl;y;?%GDg%K+f~^dK1!So8$52vo`?&K~~Hbw4#iq1c=VFD<=AhPqS%KM z8bHHy;UEI#ikH)A!4qcw8V!5QRHQ-LqU4v6_(p%_v`MG7vu8e}+Pr6bXb`%^ShGpv z*2cFMdH&kP=T4y;ZBNnjvb4%FX}VctG(W~@2Hg_wf=cf3hvVMI%0**|h$&}iJKNEJ zmEY;e$I`pURvvFUfswa&d-?Q15wdgl*sWt!3f$aS{CZ-z-=qKQhUzr!(om&Q`~gf- zLc}(p9rf-~+QM0U6mRfFVUuvVt$?%xGeDo681iYVO)B1f=NOO1mz}hAg6uQ0eDJ5k zu$SuOpvGB5kC4JLVL|{I^l|`s#=FeX7qNVT^wC8ie5diA^ZTFbHxu!-RZG5rdR>eY zsIeU-;fo3D-B{q9;_^F8(%?fIqM!CjTcCD|dK}A{7{ra>`=Bn{GQC?uq{Ks@!=)@2 zD+Z0=5O)FMY4%a2=uR6h2V9463mrE|`znJLe!@y>(Y7G^vHQNZ_MfPl?j|OvjmHYM z5ssRKnC0i4%>Lx%TKO`u$F;a9=58i^X-F~L2(pKz&LlL>P48f(Q5hp2&-0j8K`GDF zKPjvwW*c^fAjUhDxhlsJ-u=8e)H+-X0<(uEfrrl{xP}2{Iln zU6mAYM2RK;e9PTnFcZhiV+32jRvI9PP34HnMwnT$IP_W(NWcob$N_c*WsP&}1z)bl zap89xoxNK&U_zLfSBYFAPdXEeNYt3Ji(k1{Su-mi&hZJ{@^#+LPbSai)1PMRLoxG) zx{+$DE&I~bk>PY&Ena{TV`YY&dYcPlchP!IK2A!CZUTS51`6Ze-*kiMGLxOlA;e2+ zR8mS{1-`6k$ef_WIcS?r=d8b?r}S5?Eov!Yc6?k9yX?QXOcNW})7MCsaJQTK&if8P z@ML>0I8(cXi=D}un3A*d(oa*D>|T=(RYJaKucN&R#Jdtn zXc%@orti;1J64%OXm0v<+8fgi5->ql*ovQPc zHHGr%5ghcLVZaj0`PMFv7C1Ad%xNcU6}&8^CWM}~%aWX&kX4>@k7SH?1JreAOv7oe z*7F-FDvPv(I+BDP2-A2P$0yA1N74&0DAFvpmmM*;Noh_MM#otP|(Yy0AzRwB#l!2-1RT z=ZU6!K0V_Y8yriS?IEWDiEL_>Y*-vuwO9cX6Cc;P1EVDQ%(^XshnDYcG{ znB9aGt>R?n8D#xj8>T{w4z7*%**2Q)A72wChFsdj>l9jc(h@M<_a&irKbga>TCB7b zN85NTqiKO3xu#o47lUu|4YS+RsWR(VXuvRWwF>7gPI+VX_J6B!EAKQ{bI@p&<9!@t zU_z*dnLg;LkJM@5im4b7oNT9+TJnzuVD(bsT*3?^^wkA?H@gltC!-kUQE1M*;qnI* z1NsGxnB2C#lqTOhCJoYV-xOH8UG5z6}au*n^G06c24WryNZ6QVq2t;1QY8?Uf=j%Q=U_!EwXx! z8v8H`bU?n9xjNDse~LeczKhr8#l-Ft(;y~8p^peqnzQbnW7^%_r{7Xe?dPX2*f_O2 zy8bTNE_4Iz@)sOKx;s)0pgCfhox6jcGg9xa#QZ=)Y)l##iIY%k(%XgT2esV4+(maK z;o7g-vYI_u&@}UO|C_7eJSfFU(;h9GQd#R6)2}Yl>O7_7cVe48tF={)C`XM7I>bI@ zm+~6j)`20S%!?{PVa^Tfi_M!S@CNzINZgi9#&po(mD5RFTA#CJp$ClqY!6#SNR{z6 zGWOckpn4``RDk#peLMPO>asr59!b~!8fOmYhj1*o95t|s1jQ!cCehOavpI~Bj;q11 z>duT^bhY8rEKPJ*5nbrh)%=_8w_`3Tj)#Tr^{z+6AU#)HG%B<|<6|$wBi?%S+L;H{ zEJM_CvK;kCQ$OX}>qPClq!~Yf*A9{)!Z}mp@hV&!0c+GD^{$#{)#XM<0&bSg#98^M zbZN$?{o2m5rYJd8YG3_x<+*Ch=jW9<6JBA>@b2r8g41@~yuAW=Uk!Mv|LqHaV!7_XL+EgY>ht+1hKuQ+m)q-7g`-Gb>}~K#50x4~y2lT3?_CUQ z2v>tt#U~w@q7h)$NL}V||1f5sh&)Q0dUNTrttW*ECfmmo+kV>GUEm2s96eoGxiet>p%0>Q61lP3i^ZfW5R$gKaVBmQd`d3y5^if4~<19^=EH}r#-p0zrNV9yuLZ8QLd%1eTSr~WO#mdPq zlWGQEw7T#L|IBVyHJi=kJAT9bxrOQki{>1IdfLfzKvL+Qe$lGIbXxPHD@mGTgbrDb z*KD@aR;5lN++@!`+h&KlQeb^P-H9RHyOLGYf5`PlrA~ICKA&#nsd>>~;zqGhAJ@^E z_coKp&ui${5Z3{!)(Ty1b_C^d?j+Msa5p#}9^-T1%OT=Ic;G<=EObhW>7$lcqWPZw zcNA*Jwwh&_B|xkleMgfjE>i!H>9(HfU9oW2hHd)q+r`eRN zdUIySHI%_@OedN4+i!x3P#rp85H&sUHuW8%n|Ea0Xt2%jvIk(oNL%p{x%X5vb!0{N z+V%TQ-?K0^&rEz#7YjFsw-&w=G3=jbEblXS`h|CGSY3j$-;c#l1k|msyLP9B@07wmwH_KE>Rf$F%(7c^XpSxr@0?2Dv zH8{U#pth|gNNs}QwEuJbmx5;Dd&8V$Iy>_-b0^W3PQq#M!`M0v`V#rl%}uxJDq;FM za_B=s_SXr9ParCCyKQ?)&2cBp#&3n`q}l%ged~khU7C{w0;8luqZyCgIiO?Srw>cM zZzrm}>|;#G9TYIV4@Uqith+h?t(O7?+umBrHjejPbcH;;TWGM-QXKNa-!xM2EBbj& zw(`{1@2{#om=-v=B2x*#`&xs<0^%c(U6nFfImqCl@0JqzMxe+*FdOO&$wZ&qt>gx4 zh_VnKc6B})lZLmJ_o1$5 zzS2acj31`+gC2xu{Rn2``6_0l_dFJVmhe>cvCbt+e`#EVj<>e9SLKPV9Q}n?oBJeL z#dIa|OiBVRjHz(=gPo~Wx&5j~=)7}l*QW8MQ&cv+qX*99hidO7@M@*85IrmFM-k4g ze%3bhS-d?k-K^Q8o3f9UnV=9hv?Kc|a&_x`&Mit56tOh;JxZXKQB0sZ&VbpDeo!X> zl?2Tyrwa%8rK`WFRPdW+>8TW##SKEWirS;gj-W26n0SspBd=nNTc5+|GYQp?;=MjH z`L`v`shF)k$fsY>bh2->gnpm7{HbNq-@1cweSrJ`r{p>%8NcG2S>@FDV;! z>q@%Y;fW;iQq2XwFRru{&dmB>Cg*lF9#8osN#OB~)lQHr#Ad~##xh{(MRODXC!oItxshITH;1(S8^sCFBuk&SLMvcB~r}fx* zbv(6fBir@-u=jP1k)6k-;B@=BhJQh0o$QJM^-W?y`E_}Z`B$T=i4a^6h^pXR5UIk&t!j(d{~gnOjwE$UIyq~_~W^s7|* zad4=~49$}(BD5CO(4VSik^4$v1SD;rf%>_wf{R`zAaht!C(vLYb7K>q_T!J4+G3_S z0j0yIrQq(dZBfIiomF#^JB~rhD}$pl28}i{ZJ%y7nE?%MsTa zhr%+_p#~6}?fML;1z5A@3!UWQUD@>gGx()HXLqzhV?ASn+YOwmJ=Ir<*`D^Xx~{d2 zT}yAIyFmd5I?vzNDnad&#=uqbtufH6L~`qRf4OOPqE-nS@f7~7kTGI3^}cl~UF##m+@-CH2yA&usv-7u14lkYR0o(q!}nXO z=yn(1W+;OfBHq738jdD%)ZAsw>!y0m!!u!8CUF9Vt(=-t>qtl>Wq8uiW`f8!5$cGf zZ2pS3rY9gXxju9GK~XfedLiz25L9>dW+8o(nol^_uClE(3^A|F{1L;@It=99SB?u> ze}_Y0jl~vtbrnWRghg*5L}mCL2`)G#&o;*tV&`JV#8ykI9HF> zkqSSpd(u$;Y2mcYEJ+R=o&v}7I$|Sj>1Z!jOB2SU40PvpQM>5C|8}ODuVx%jE2tE z&cr)9lMzQS83W)({A28egaw7;Q{&+ikfDPR&r?~?&=my_+A&wZ?QPdrUxd&Jipqdyp!AKz$Sr}75`~?q)3F9%r5iQ{*ItPE^m4WDtC>=PF ziC%Y~tSK?UVv@>5<~UhENkQ^258;8LK>L)P46V5S8%cry8UHa07aa#)BI@}|;U54c zh!NrMsRFbdpR0+wHH;QB`LK%A2YC$XZ)R2;;@b(T%4fBVF0xUDbWccYqZ0d%rFIg2SeY7cmVtf zCmRd`#poX5{Y%6y!d>)DNco>s^fyez2+AQl2w?y^6lBi{bjsxkSUi_;h+yQy4-*Rb z#}*EV7UYL#D{rS4q#vm_he(lfVGt#-ZvcrN$fAu0*6?3BL*Ph$2oPfMB7;bHCkOH= z!hJ~JHc>2R&~AtbP$o4w5ET4w-dR@xWgEqY&JfPc4@|*XEn^$G4Po|DJU%`n*hbcY z2H@f^Ds1E>xBAno<~E|FfM_3qg$3up_&Wv|1%ZMR4A|BrWJ%FaDY(4oecTjyD1>C7 zAfXkO7SI$7(4e56m>)RDsMmlmO@HrD+eZ)xZ$d7R1umE-;ucouX93h*=-U90WikRS zG1rKg(c082( zmB2}F7>#wYNkvTw!yC@sF14B(DFh-REd&TulvE&)VO|^Ro9oo%P;;e`gHChwd>U_CCX2S_q{OQD4D-{E~iK zCx1uY4U~QmHhwMmGWl-)iMMo6VgtCa2Im!51)!c*VgK%L??a_CE#UlIW&lG43FZIJ z?YqHUgnCPNIVOEn2kxt%?^3ZLD*jun%|S^@1`$-Ggh~bB@Ys?=Mg$t6D@B2Q%vuFf zLIOjMaR%Po0|(Adpo}zlOpXT+Kftdv5RUW%5BUodL}6@pL>V zeDfMM76&}}UXmoG34qRCCCN#o8Ys&mu(%b!8SV*ZP)MW&`mwMA2$*dQl!bLTmO5aoSl#eL7_dc8 zr3f+rYMsv|K)d`WggCqUtJiv3QASQuKl-R>GdFupl##IbN*UQ zCvHEW{qoq7H~n#LU9Y_^@zEZ3TCO!O6L(UR@4e@?fqyBpHmR=!G8ey$ST8twG0_C4rWQd#3sFx~Ceroo1t&egi`U+eDhr+(wCXBM@DZ&=JmjukOa)IMqy5vgIc zdb8B1p&^P-M=w0SjTcjc`f=#N*9^rE*U=M!pMlw%ePlz$DXYwY{jEQ(A6Nphcvd>L zsLQ+^Hn08!FR+iw%az6OkNQ3F26(>_vU!fL-MH#Z=f&`s!iF+V^<0`uU|B?DbqB ztb$OUfS)7{!3_7%T*ll7+PwJ`%z?9>c%!q>!8F$?3lk--j&Gm7gKd@v?Xv4WqymFt zhx33?yG&!)NI_jo{$KN4J}^x7g{AnGAK78qk_(?^cl%F7C)K3fn$>rV{Q$JhX{@=7 zsNQs`+LX!6gjX%9f&wU_kZD3Y13TLujE+mjL>I$^SFXSn+)uVJ8cEOt}EpB{; z&OF&&ZN$f8j~Ct_VFQ-WtdFXi#zp8RrH_&1V%(OO8nlo!PqbmlleJYq1uvy5Ir5@=Fb^tYN@+bjEzSx?ugr?%QpMs zP128$4wY6*H+?UiylH0Tj*I5iv=*n<Exuwo(tFP8Up+^j@WHWusM%UYxyL0E&s*%4>z&} z)bmz{2d*`2b&4)UsY%wXQfmt|H#~V>kmr{iGGKAD)bOh_rWU;%NRW_z#R1`dZr)Es zQciQ?!NLPDKXm!0W{KQ$FvskHU+A7$abcwG-K9v#BsgSO88SJTxjs|@!$fifU*nzX@F&hk#%O#m_0Mi_ z2UT^ljTMzQ;#E)e0ug-0x)}2uEsU?RsTJU($BZbbN;yWy|E;sko_iUH@HXtgR>^AL zxf`nAe3u!Cdwtr)Il5-#o?tF{+3h;7athE8eAY0aDA(Fy;;5kFP$AQKU)gV!TcWE# zv?!@I_iXO@5ms1aZXhE=scdE75zN zGCZ~nlbxj}6*tG-vIb9N-lkmml?n%?@)!~xTl?}AN=l`Ukh2}5N&CN=Ncmwm|C9LH z+UTg6H|-AfHOC!BP8(t`0xD`GyN_~d>GdLHDwy3=d^!995#7-V;nu|}gg^Yfb*p&? z#bqVKaBC*g4n4=Li)s>Es6KP0AnXay8c6WE(XL=TZyL+ngP^RW#j~l|TATWGsOLi0 zse0oGKO2YJ3FGerjzQxys96~q<3Sf{kb17mv&>n0yJb&l%$iDH*+TC9Z8b{kQ6X==Q?sVRdbOY6&`%@*E zjpAmy6CYJ2TnBpcjHmt8w_wGT?4;#ufm;ujfA zC(n*9;Dr8ble9*!%{oaJjV1;LPAziyGEV*eOPX#k;Gg*KodRm;t8N~ucw$Hl6hg#)~*v1X=FwQF44vtSWtS!K_y!mXv7Mg_-LW}Gy9nn}8` zFVr&VCV%SJf0ZR~^a?H4UksFE^YPrJrPL#09}#j932!(;x72P|)%(Rtr$wtWyMdrW zrdq=F#if=MM`oAEmiZOKvq#G|n`0+b;~F5(?xO|zjCCb={jR?_Ue~zf*`kSOXVcO+ zSe~RQ*Ki<%mv|~CpLpOp%93R|wsxb;e3!_GX!gW}E`Un#M^6Ks377Ot3qt? z62yNSbKnwt=tZNV0US5yXrN zntZ_Vj92#|OKC8alllWf(@mH_f`er2=8|pGCTN4*3;uqR*;sTd-A( z8j}b3Dvyk`7hTo6q_j3@08e*l0GLZ0DwczqB1m-o(~EEM;AQc30Wbo!4sYkb1`LT7 z`m$%}KX41Pe2K7aGgPuvg)6tb&{md{HJJPOGrJXkwqy87J9h9iiI)?x#(J_dmOd3P ziMr**lLmDxIBGBB^L5V5jcsyqcaByg4aSF}NJjA@T%`5vHIJkd#rlLRy*g(nRrQzm z{H75)$X(PwV*FB+;Aeza;I^HcQ=M-$Yq8*Z3-dF`_~c2cDV-G;jdbeP&8QxDKZzDr zuHBHRV0-C)<=7JTnoGAqtCW3*D`NgO(<>BFB)hI!vhKQ@VHz)8Lp-3arR&2a?$$%d znLw~Oyx1ddx7New!Ya^xV=w2Pm;3nat&x&tp_Y7zJZ2y^su!}FhLuky9?cx-PRzJFPP(!_wrN9@3-6rijl#1hAXU_&xo)I6tJp@>1 zRl{_eLEM$-bb_`>aIw3RhM_u3K-Zr&&67b4H-o_h0fJ*H_(W%KQMp(a#(j}u&}(paV2cG zCCpC`A>^?AqgDox^n|43VJ8Ek*of)fHC%Zd(v&-ui_o%^LbvWBmB9e%Lpc0{DDzOCc8NmHqNppzd5&c|40Cd4!a#_Ks} zA4e6?tFEgAp!1@v%2C&mZCfqs8kHILheOa+A_}WQ)_l$8zVi$!sB|P&ShD zI^%OA{!0MIiDsH-0RmOgYd=0t+v0G%A#~0)DRp#@EyluJ?_dI@1|b%s29DR_FGjo3 zYb(;(sO4F+>LoqrMx*AkyeD89iyHAq2BoXAzjgVnwo98;pCV2YJ8(g&Mu{e6Da>VC zrQy{7wVQg7w+72dD?HR2g)g=?D4@eD;KxX_FI$VPWH87^zlv#x#^dW3y(uNs(^-aS zSeOr5H|-P6#M@r&qju7Z>JX({qjOJfx$1W~^r#_TyG8SLSXcDPjWgc4@+W^Kt&s&s zTReHQnCP!H8P{)k{Jd^&D1-*7HbgJP=pH}k1?{@y4B_FK&1S5+Qgf7ju=r##<6&8j zGq4uazSdG^HFS!f;%V6Tw7YYf`%H2&CuQBHzl5UN6Sh*<)!S_+n!Q$zHe=0FB|_=Z?n*FqMcLWd{%vdv4chW2-Zr3 zIljMVsU1O$#vbQOSJTX77oa|42trg-72m?~oXO@H&=BK(Zpl*!XQ~{cl%0xm(i5r> zL;;?Lbf&FrdNXLnW$*T#xKpQiJRWiB&TrSDNR(>%xUa&UHqJ}AmWp;r98&|aEsG=- zxsZOfNptX+ahrJk_r}o4q%cw6h#QJP26LzzJaRPTbkJbz#)`6G8BocOf(_5Jyy;<5 zVUv#7OJM5r$Of3#;)PpsZ-j>!a2_~6gq4Y<4O_V|ca92G^-?R}0`r8@-@Q1*!}i3z z{^lm`VB65|Nnveli1-OuMal!LdpgH%xn+$-!n0$+e6B+D<~OHn6j1T2fg zQ=lm`mrqmk(B#WdxUBR3>bwZ+n`EHO7bgluYidmD4SEytEa|a_qO>kNfL9s#^tKbv z9$#>mQgly{ksB1T?`mTHG|ER$C|qw0W)7LoFumAkK~#B#*w-Si`kRbhYF>_E$^csd zg}U9>?`XVlwGHj7+V(nFW>zJ`_rg^l{vY&^)Ck2$gLHE-hU70q5_(lw%_hrCcZzVrs;>TSN77woC=isY5w-0zP>>k zpl)|n5V56r6XzIa)~+wYbU8hICBe8MUwI2>Da-O>o>lxrOXHCmpU_LJ7x1&`18o0T z^dOkfei>y$n|0IRWK)h_JUf~+lLj(z) zDip^`?+kxNAtf@Y+SaHNC8QQ$J;DpyNc2!TK4wLnm;gtm)ed1rZ&=K_J73|TAfvHE zl8i33f{n{C++*lsp=+944zHi>ge_9}Xop7GUcFm2PAtd5IkhH4ls|^B<)l%nt6r-{ z*Pj#7IB&H%d)216L5+=K!z1v5{ME8jeu$rIO#R-&{(kp~NzG6s4&W}EBQUGp8eJN7 z?E~KynCNX0cna>usFQ`&(wB;O{X)V$O>jNS`!be^tIgE{b%Tm_%VpAeapt~XbUROfWH=P{neV_= zB7lkd$}*l39Kn*PuY0h4L)((&H=~A^G;Ot*HBNeGrUvcmSA8*$?u{Umo?IY7Z`RK~ zK$7H@S+8rR#=RS?uFg{T=v9qJ+nzx_l5b^w^Xs%Z&&xfDmX9r7@g7x>trpP}a20FJ zz>6$pzf^EZic*K=8F@n-BdV*)J)9#>D7};Hh@9sIwdPX8h-*oY{HNjA>F3qdQ0FVg z#3fn-egQb1r_((eW1F37iRCM~{^ZGX+17s+w`ZM#LvLLo&UkR}F$@CX|EY!I)20?C zQb-4}l0JNXsa33?msR5z^80{u%UaKRXt(~{sb0a1iG+3`ox^G#AJ7SS-Ixe=rdsN^ zK3&Ug@DOMHO#{vG=aB!P4yD>AIueQv<}lQmFU*`!rJi<+<>yN30q7Z_iRnMaCE5<5 zg_6RmPDf$#63NL>4r;Kg<(Cb!6e)5;Z>|#uHfLI@nYurQF=%C`BqQV@?Hy;&-cS`k zJ@$~eR)`yJz_KK^?P)x2U#X$zvdZ(umC-$&BszSat$qRsu?P&RJTS996T+n=;HnnR zUHQ?eN{-X1$};LZo8GD59D6?^v@BS5;AU^D;c7-nP)g;HxgO6tVHw*GpDt%ka!Leq zbt?CwCs-m`W*#7tozI9a)sz2_AY4NzmgN zvP__VosepXX-=2YTaZk`5zhAy)E8cQ4wiAs?OxF=xDE#y%LvDileK*BDm=Gf^owVZ z^{LA$)MT=+DKokmxBF(Kf4yeX|39$C&h@{y3^=%$S^uy7M>j}S6zxSiIq5SoZe%KH1!2fyj&kK< zNf<;zL1gK&f}$sCIWS|-8BxRRY(2}LFGm9mPX-Fn&@SPHk9CCLBpbbhDtyTwM@9z5T8LH9=H9x-FuY( zu6_^Hc#RZU;Z;Hk9nCu^NfjqI;h>N}g-Okblp72g6;WYR-!~DDsbEw?KKk(dJBS78 zP?1l-_tb>iKfMQXvgg}We)K`!uigU?v9PELc5ej9z@|{_5yU`T3oI=#LEH=Zmf$Rd z8^Q+Xet!S-yKiE}xTS#y_y7Q6`A`f<$)!oWy@+!dv2GC916_u>{EU!$4DEt^lprrU z=}`U{mRGQ^AD}n|xbr=V3YdtHZT;6qk__2F91FlF&_g+JtP4xPJFa0wznGU_Oo$*q zu55zgP)7p$KMy}>P_bXvu+6O!L|X-tew+)?XHf1zz_%5b;rZWl!h)0w`)Nc=(=Z{A zVIP9~_KG~&{kKB}g05tsgs7#r46gbwxqsc8(!w#euG56){v&KM>LT1_`G`=M$k*U+ zDS6aeDCTjUu6}d34IRWvJ(5#-%_O+zdv7v93p;i??W&uG!zlQRRtcoD8 z5HjQb0gMQQQ?ol*Pc&`yy*yVO(C^@f4+sNoMOy)}oX~ZIZ6vU-pnV=f07Jp1QVv?E z$KD9PTOdTJIbi!Zh>ia2J;^?Sc}K>n`&oPqPlYyuJATYn4@APZ)l&f)8eIpj{CNAH z-}GO4`Z3W-NfkA@yVkv5#fb?@0YY)j|I%)>)W8tJgoTBIR9nPnyGlPrzYf>EN&w2Q z+O57{(IrvtLVspI(!HA-2P}TSXRuv^!vTb^S7pWmi#GEETMxX-{ZKaO9A zv|pXs-^hnw%g^5#iS5nlYmUj+s2>4MN|2kAUyQg*V+U4yVi%>hcEO+4a;mFY#LEHP zy`Au1bGCWKEmKOOoUI?{h`$W3Z3I(71hFmdKZ}BXt3Vh#aIwMXMO}Nnxmfv(V6Z<7 z@EkTTHEpFsFdF5%sIVN;zx>K@R&h>mY|e$qiGpRN6iWpDG`#i{z(az62hV{XKetx} zKF>_BAUS$r|QddgL!jtNaL*wuAmcweEq zFixc3(0kRQICckhGNpU{f5u+BLk;L!d`bkIjF%0orIoY3s=kW;21<3AX^vywvUHXn zPU#L=8o?_Ackl^Z)CUbJb#xWT$XBBZ3C^hpY9fso3$fmN@EX2^)R$@Cz#v3{vq0_x z>-~58Ynk_$Np zpOT+e+J~N-!1eEsm6pa5pQ#BE@&-=BpH_Mxuqqa&dS6sSl23gK%-9oHh<-F?u|@8(1f< zOUibFZ~~rli+oKwCO>{qHbwq-F;~c+89Zl{f%HU>iFf!AU`F1McVH1*!BOv~TWlYeb zi^u-#9H8Q~7yIJD497%0l6Z}_GCUj*CD{_BNBKf4R z1B&7&0&}@oOHi*zXQ{1O^n&6zRYG zodCL)(t{tOnF%P=5aaT;NHPsvF~BDGNw(evR2Eoz7nF87sF;LN6Iyz`w_n%Gp3_t#O+v?C#gh1~e1bno4ul6n_UmFDZpE|y zNTCUaGEM4a{E4V&#%GLsiH6@Og+{yj*E}%$AS3m?)Z*^X3z=(*B}ts&w4(FrzbY!N@s@Y?sgfWg z1_@}X5%Fj&zde$5i^v_~m+@A*#)yu;BJ2UoYH!BGJ2UR-C;rY(oa$POEi7TPO3bd* z(cJEKIVi=tS(Rw}VQgAGt+B5!WM)1;jF%fGsL>;!+PJA043pVu2Z=(HL&Y(6MU9OlwT#|`X^4N+0 z=ul#O(N%H8j+nY{w0~Z`(`3JbJ>#{Voir3#ng#P;@oZc_*;iDKB2h!7bj<*1J?Bh3 zWcwe=o3yrHQe77&O?yRMLq~+I+Js-!_;~fq0jl*xpr}d1GJH|1C^_smqSpa!OwFT> z53EPe)4Idv3?kCyPx~swBwXO?<3BCPo6}9uGrM0c<`vH+_U11p zAOaO9;O6lvFB6xw6@B=&+DtW~#QGro`G0_^D)x=8pj`=k6SUO5a6YZx*JdZ)X5$&L z3;ZRBjm4Kke;LfdZoZD`CiMYwTsJ4Qzm%Ob_U;_cCqEp%8#z1-y9v=$8A!5~cI?I7 zy|nLE2g&Z6%`-({3Sq^K>g~pMg&KXw!>UvhtPY3L#s8=#O9B;zH>9ojo_ z6uD4`#I4TX%$9W~f3(e6Qrvbfc2G{6zz76rz=SfvhF>~>(oScTMzU7kbW#^Ok$3ue zDqqdGz}ZxV&0cMmz}ufJfd-4Jh_aN>?`#^RN^|a^`b%-l8;N~ zD6Rox^YcDv1En~fKf3Kq|FYQVw*vKK^tMyAP|}wInh<}Vo*!H)_suUlC5Ee5daUat zZvMT>`(;CbRD#U1R@37Cx0ULDd7(&W1OM9Ofl34FeptgM!91J<<3nd=H~#XvZNghx z@PF7kXF$=J01IE+Hr~6oZQHhO+qP}nwr$(CjeWb#Hh+q#l46QvCUfu=&&?F#b^LVe zWkG4R*OR*lo$U)Ikr(Kg59*gB-Ai$w(a8)bt?y>|k&x{u`B*72?b&pUV#$k(hlx51 z>2qPL(%kI_mzv1h&6>*OAi38vC$wJ&3LH@GSvU?a9FE*5geNw@X0T#RpA3luxqtZl zQeN&em+2?3HfkbfNfbC(PmDrw2H$S9!xWlV0$$6oa0~Q5m-2E8Edlw9DgDZo)E`l| z1*lhP_qq*T`5=6dQng+O#HH(5eLO_ZAP~7did4h|4)e|Rm=&GJT4}^f-zN+~#AlOO z?g081=*MV`@GO`2X+sBZT!SmXBS{l_zR{9{kSW_<(h7cPRmB*hjR7}loW(9YnuhoC zB%HpD2n#EH6FiKi|AR!0VZ7`NRdwj))?$2H>6}3I z=3_FmiVEJ_`%A^E`n|C>V$@*SbP`+W3gAlBaO)I#l;=kq3oX^torKRt5d50?(@$4kGm>DO^bOpU*=AYm>=IhzGD zXP4cTMqw~WAkL+~m+6Z=iTDbh%b(Ewvbax+#74yIe1+?juCq_}1BivrLnxaiEj&lB zrN0%rw<03AZk>1t5t|_PGfu}2sq%ZM>le);xqin2t<=M5FxP%lp5wYV4A!pTlkyMk*BBk z25o)u7<^fToOPQZi7#s)x>i48iq^X?m+ACs=}#Jl8z}6`yJrUsIyO zz7HmnQg@&QES@S#w8O+nzj{fg7%@*+dBP#EWuZ&!_2+|R2D=DVpd2;S z);GUfh%D*ag~zR7Y2J=!!=fi~e2IkF#u_N*;-kcJlfjsTY1uLC4+NQyfCzn|DXO~1 z{d-cH#IRXy-?mMGZBz5-LW3s+vUij*8fw54I@azS!CAnPYa7PW>gdfI6wFB%A46>{jwC}w; zChj=!WD{tp}0wAX%<%Z-$Sh&I^Q?d4LuU>)V(2>NX8nEZ zQfRHYRFYSx`_2HNW*{}CQ(MQd85(mC%#xR@9qzLHV^#PJFj<;5DjyA9rM!wK&sbYccl|pnE}* z&rP4<_BbqgCfrDD)JCRkP2Eq-D1z1?j@3=89u?t(y*57Rd1*|T_h;O)=?3O`?*1}m z(>iN#hWgF+6`UcO3lqY$wt#GWtc%*jNi)n#$-)YXhHoVPpS?+6k$x(0GHSTNgWc*g z=r(`Mt_!_o&`zE$@b3ox0*e+m>!n*~tnOCnP<|4ldrh-;Hk%KHqvh?-%fAj|6g_^c ztg^hRPu86o{ZM4@@V|cLWyCD} z9avkwS(ASGrG|_I&i6}4(b;0{tqHVpwGz5?-n>3MGRouoY%F?-8CE^(a4emQBa}MS zWt@(o2-ls{FgP)`vDl=?&>Sw%-}gQrxJ+v8cUv2?Ji;*Hh*ZN|E!ZFNa5q%m3XsuK z3q_$-Z78&w3=4CJ9KFPhnD&H}9f7;AJyieX1JW(M1FHRW#$S=JojtvCm_vv57B2QS zIBly&DRMo})*vO716=p08>(<6%(pdGN< z{578hU|`2^gH*RB!l$tsKHl`Kk+W<2^wUV9U3$6iBaTi=sSPOtQH>!8`bGpc@%<_J zk!}>iY$_^DK0}7J=_{eT2GtI|&`;AFuV4L$mZ;zMNBy@>kxZ4KLhQ*Ei^&p&71vR3 zQTMW-3Mg3F^rKB;*3zSt$0rZKd+j+!z>m?ZNv;lPE7W21Fk*1LgpDNyJPtc9L@Vn7 zX(*^~FBMGb@zIt;N;KiUnSM~BvW=}6S+b;o*fAMI z3vl?_Ux*{eP1s0(789Riob@l{6`BWtRa2Yur)MFGC|Ccs$RZKbgc8iZ?V(S)*o%W( zB*Po~2syS^ni5QzPOJn1KPzqPnqW0zOKRNtaN_m|n#eka2zMs=!Xr#hrnhuKp@kw) zK1oC`-ZD4Svh;2xqDte>ciwLYrkL$Dz8wY{<(T>{c%JYy?H0EIM~xg|hT z5Gf~#zf_IUy6eB#bd^&n7BNBR6|1pV@9W$bb~=j6CA02~{#kpn2^ip3ps&Kn$7}x> zoUg-4*Y`^B>hq?7swv@+9fDSqaXL9US0tyEg*P@Gw;*_d+83=wJp+gPY& zqmF%XDOnW6?VkaEul37srKBy!%;7G2icR|hhzq}I^eW}`?JCB4U->Xb7czxg`0aZj zgvXO^mWb@wzJX`e2LAE`L7W-sDK_=YU{rQnUVx3^K|vi*41@;hT5K0~9TZ89zUBU7 z(4oj;I775{QiEy)l6G6p-_~kYA10jglE%vwismLib>fV$42gl6cF9C>xw!@3Yba49 z^}5qHZVzkLxjKM1C8C+p=Db_$8$t&uB(!(i10!}n9-7EHW(r>S_PikNQtbi%+OFAa zD?fGc@`Bq#-D4&C*9nvmLFwkF;V@qZs$|@rSC^VeV_u%tw?F(M9U`!-CKn04wLPDd0$apRwSkmBxs@%&0ENGw z0S^A>$7uAL*;s5VaK;~z4)qjQMZH>=bcCa_CXJQkYuKAxd{damMFE+KE#aHmtF*2I z7s!(m6@c`|aU>1ts9DLoEU%dTn@#i32Qj>L##U4hNM5{k4ldmG@4WK#=dONm9MH7Y z%osRuYj{NGCftfWMnNt85f|K!3m944nvoR|7+B>#k%>uVG4SX?RgdEp8tEWT1ZagAdZ~F_lP@zi|Y0OB6W+Y=<;&> zr~jyOL6a^-UleliY>JU_brLhBfp_rB&&z3ka8n*gugP}?Php26CT-+1ORfmgXVBoT zjXn{Dd9Im={3d?x3JVAqScMj12S&37}C%HieK!%8Vlfi ze=IN+`TXhR@${}G?OE&bniHLBGts9srGaiI^AWQUOwWML=>PDtv^&$r=sO^8v7U*1=FJ0->q0Z&J~)bsf1OQp zub$3H;~pdZ9uu55fn;w>dW0v(Q&GfxgJ&eCCF zl*tpRjKr?_?bAcW^fylVco_qgKh-nae;CVeNB z7-LC{-tukg?Tj(wqCvm?LR3<;20>V4|66>po~fL_%i#}Xum(tfouETX=gtL@TV(zvku+dkrFSaAw_}N;g%r z*>4>VQ)ohg=G0OqbKPY!Mr;+ak`b$xGWl90eWndnn+t}mp~Go`PdZRu_W$4zju$bd{WcY z2N^sTjcIbFc$$ep95%7gp_cagrQ1C0n$pRoSAzJtiBCEn?#eV{ zcVu(O@8ip(XJCkccBJsY!Z;4ulXXAAp00us zmUdocW_4oW9=->;Y98jBI*B!y4~wF`0|;41AOMaQ0Gtj#91p*X3jir+XP+-jwiYPh zf(c$r3IM8#UqRyEIoNcOiShN#<&_PvudHLwXph={)SY zWneSNH(~TVixYq^=_u56usmzS%a>HO$#JMF^Aji#E@-|MG(OQ*Q*c*N$vnzEc2+(~ ze$2cR7^kmEwRc)zlfGS9;61(LH`1-$e-YMojvp76#yUF(I~K>M7Uw1~wez?rfB;0tA2ODp4D>qF~XyN|D~DXFR7 zG9zeSZ#C-OJAOlLW;!?mfQvKu$LCM^n{CikKVV%`GXU_E|4K{D*sq8$8gTW`z-+c_ z^D_`e11~%txZn5cF0XEFuIc2$IO5TF?fdOX!}!G5_(U1wH_2D5gu=o&^xovaFtpzO zkv_Ox-D5rQTMqBnFXzO+Veq?EX?yDBc4O@~x@^zv7zE)ha^P|EJ2Yf;my!SXwSx}e zhcmEZ@ev0Y@aZ?E8<7*fbNCT{^!M@Z*X8{;^MCWKw1&UE&tn~de7((2|MIN()#-uM zW1qI)k0_mixvT=i=kByPzpGEEceTVSfEpVeoL{vnfL1SEm`E`zdA@k_E7B_~&}QW} z&@FZEmVQ5rfv0x_nxc6fiJ8~6jKF&PdZxel+mAKsYrMHgt*0{IDuB7F=e>#(Y#MCp zKO5{acshRRm6hqN4~~bqi12->hwkju{yM#n!-rT<3e7;1b4w&i~3$OaDfuJpP! zsQ&=616cL(?m22y`tH*jeTJq$_nCZyd&Ss1f*%3aeVc!2p`XFOX{8PJ#vQi9jQ+b5 zQ^vRNbZF+c!L7yFhbKFRAP@CTmwa@0q1WUKpZ>P-&AlP}hhY3(tLzg0u3fH`cdrrr z4gT$`LPrl^-3OTQ}l+W%iz<(XS<$o)Z4V*O^7yesZ_Hor7%-wg~tt6pg#upNcBd z_Vv63jkz;FsZhlPO`OZ>dVv4_yplfTqsOb+OK76XykiH^%*8Fu?W9pViWm zG3>_n{i7;nB=Eu;c1-cY{5FH>%6QqRRXlyZA}uCu#>WTc>Cem{eo5J$SrW#3tEtj; z!I8idxys&g5;p+2QT)2Du-xUc&B}seY+2E}Je7{_n&NovSB3Cb4@m`5~$xf3;Nir%$M{7xZ<>JNKE8l3YMVtzgHDy5PH9-7t z-s;w!jPZ?&pW<)K*+p%N7b_OO~Fe@i{K zn0F&*xs(^i(eyYF-G$S=0V*Lvfb4i@yf%G*Y~pr1U$kS;tD z>@A^*qI^lZwA1*DJ2;t0tOPL-NA#bCt4{DB{tIiQ&tdc15JM zj{F&fL|wTjuJ{NAt&W-1@Q7Tn3wilWrN3YK4iVkU%Aqw~bLJQcG6)|P3`|tXlBaeb zB=u5FjaTB=3FVOM)aAh4IN+d_x{ja*yT&fx2G!hSrnEy7D6}$maoV8UFx`#S??UD| zQ?t!5W?m_+o>YVRD{iMjh-QaOEzphmv#^uA))K5WXuEnWSVq^~Mw%>hxWwbFix*u9|lqt6_9j%VeO1t#n`n&uX4;Cz)4Cy(5JiS^SJD4W9SHrA<7 z(eB9n(B-xpk8&pCXrz!!9BC1?07j|M2ASLznaGjIi9mvCvYgI8$k4m?RnD*2WXLT6 zjAjCZOXb6}1&?S0o9bZQMf&D*q}bM-PQ{Ix!5`}l`BeK(DCS4T2uDnUjI!aZAN{HT z@>q4cNmKq#%xQckR2|uZ^<-)6R+vX)gcBZrbvaJ)Mjkd{_7E(gWl^R`{LV>x+){Hk zRu1sW->^z}O_G?n>mrwL4?>~_PB~PXIo=Rf__>}{lmGdEQWg#io${1^JXlZ{(dmKO z6YgL_-DR{k+iOet>-SsUR?pf;xqkVusVO62m1q;d&_-|2KaJ-f?FpnpGTwo9$CvWaM?cy;d5WNZa=Nvl-|!({@K z=HEfAs82hz77weJ0u!eXOn_h)EECzJu`E4PZYFz;0b*_F3XZ?n^fXZ zkh6!n1}B{mUi)oI>H{5gV?8`ESp3z69R4l%v0(&cd5 zIZh7alG0Uw1;iFNAu>2f+<jvbdF+^^JzbzlNP6!p?S^^xNHOjKTby$` zhCa?)e;Zp_>M#bnttKE8?{b5Jbid52Gd%%+MSdXa?XS)I!3Ltx#=$3FIY>MYt)I`u zv_Qro7_G(SXyGBW5%>AK<0b&JPJoBh+mIq1te6wQv9{GP5}I`s@|xT+61T`!kwC>_ zPxRfJwF%+}T52fz$CvrvPR3cKiWqXV?1DM38aOVi)STAT-hy z7RaPP<{NnBc>@9tA{ezEm(e&$L{`;kJQO`vmu0MX=RzWWFySc*aF;+zcxI|eN*)hD zRIc&V))$+Qug!F-&VcjNtZu`c00L?NND9dKqovX4-^}neGpTgkI|^*8M>x8c=APP4 zd%ohzuz(qn)K+9DTi6xT-Ti+2G(S{FN_*`OMo$Ek*~gvIwN7|3k5xr_<)swIF?_Pj z>r8m^Q9y;3Ka7ns0yHfjaysdWt34)jVZ&LijSfO#_%1DwBWpmarclwC#8kst570k) zFVSVS=n*HJ3Tj?P z&8-nf(SLUdyoa){}BX;EW@f;KS2{%JD zv(x<3%Gt~&U8vJ`A|aafDoTed?>eF>I#OGsb0&87;C;6M0dSyzJ5Cm(R)5cD>5$UX zG^ukgYMEt^5*ja@JFbv7-27xIY3#vcb~2(LXkB6a)UM%Y`;vyPzNu>;bP8Fx6OyL_ z+H4G1p+&O3N0)J*pwc#Ua`@Q*#6#FOt#62q*h#!}B5=?Q^zH2UmX>fcXEPhXJ%aeo zI+%LBnld3v2F8Qfh0XEw3KVvSne`E>_k7B9bKKn`M!8;^)(Bk|hWc1K+)uYkIbmj> z-kKbKG7viaBH`qQ5!u_$xR*^G&wfg27Pn!5q$H8`j+n01>e7fqVEHbv+z|jQZ&PKR zd4j|OY2n1vMsxI!KXw zIQ+Wva;5}WxRlE~#OrEw8#m~+S#TRoV9pRT{wJQ$n|}U|Z&5+?cR^yF)WK*l4TiWg zo~Ah;5Amc8QyF<~j2#Q#W-9Oa`#lg)eC(;nx$GF72-n}d1-AF~ zbg|C0TUY3Q1ad6G48YGe@jr6;sbd?YP0=M0r4xK7`gz)u!PKjY3R``%}! zM8MG#XMi$36#gIE86*n%6}$(He8U^T>zlU>+L-lbhyNMtJ>pkU& z?2jH5^`)W0Slt(o?SG%LO&4S#_kyOqowAsww%Sr3;clWuo(?`K1oA+eLuRlulYc>P z`PIQu9P9)lbz-X++!@@W?Fj6S>2*O+9s5nn7W~LY?>U7^4A&)9rUEAnf(?#``(w9V z08yOGhkHaC(?~=#8i9MAb2Gy6TTpLRf5X&Llou^%JwMMlw2_&jO2rx|$KYlW-kOh{ zt-Cg5`^;XZA{Hw> z2QDnyZt~?nq?~r^EsXHRyZ6WLC{E~3s;7v=DB%yv)EY{=xU~EL>h`+G;|-_$p3`|^ z5f#HjBpOj&h(xzxldy8%@ua_r+(oG8dK%=|&H?8;)zi`8KX4i)9L|1$ zwIR2sn=NwT?$c(Yh4=R_ReiB|NeylnU%cOT32A!XKuUp~Xz4;kz<-tR=xVvDXAo7lX8^ruB%B_QZIOLQqo8s={G&LHK+a2kZ<7UOxK~%Lc zqza`)X5Z|+5`wzWHbiVSCPkNH2r8{JpKc>`;BMaRPbS@R?rOq;_@~|COyQNwiZWfB zZNUoYvM>_Q`xZ`#eZUyI*-&m-jNihMEB+#pizE~2SoCvI2bRydaMp2m`kB+6bUbAK zE$RGy-EyVJk1>q7;=^SlCttu929wr%MEL%Tu91qtUeGqQ0y+V%?OqaNnGoFE#fz1G z34=9&w^rf$jOkSQ_%Xz6c`Q4A3v#<5QtN_NpX=#;Cpp&>gdn3B4NEmbWd;+!6qXLK zg(}HXBqOQeh8rU->)w~x_oiu8=w=X6BHOHr8+(c?hD9jb7G#lE5f(-r<{lrg!3X;? z#4xDpnU~Go34)J!MhccoySb&A1evg81TvaM?7ZJj%bgc+@n|Mdy)9`tqeeVy7n_a^ zNf?}54jNz5svD-~=V1Kv7$;m57Yy7;e%xfQK~+B#r;m0gnLHheqw;nU1;htGHUa-^ z$L%Pcz=0mI&#VQv61gqA90I%iuaBRrAX7we*jXQVE&)`QD84dlD=>-IxI987$)O@S z*9e376=y;`g-aePg*pw~(mHJyQc=CxbDoPKzMA6E?zGfn_u6|QNFb^>LXvmU!7?1$ zID?O^wKDJg3R^9+GjsR*;G*GKrk;iMO;O-GQ{yRTPr50ea)3IB@;&egzQ08BE=|Ly z9No#J4aF-Y)e)?TzbXMw0*G*{2e6RYiGlnrZ+bFe`50T=KecNmw-Bd!&ior*)F`>p zU5owe*~M{lIB4Yf(^5rzc^SjF&0MNPR2Rh3P1K+fC?K7UBVRBk^h-5>Hb`VNs)>P5 zg5f|}km>ENTNo>e5h9b)G?b}h!Spy@dEVZ7y-iiB57ocGKY zs$2DMcjP!w&MxiXF{m^+>5cC^YNP$a(Y+64OV)Wj{J+L2lu}DBgA13tnZ0!s zQe>x@%zjCrL(?lM{ zV1-=+7dx+{t5hAkGWekCb9BwXFHV34*Pcz zIOO^}>xXq%QFKY3i_aU8DPBydjB`KQBG|E0-k95yp1Ex5p--DrtIP4Dl5iWkUZcBf zMh+kXFa=1AXP;vhb$DD3eHPn7Mgh0iq)-qLjqSkM5V4+1xj-gRIx06S-N2C5qPoKv?LMtEmW+~+q65I4VOx4vWnoKP5!)TNcHnDw>FeX%$({nU#lfhs z=rblOJZX=<&xf0zNNt~kAe^YsK-BgdzwwLGN?&u&mEJhi&4(*fYHam}&jX~3oLOi0 zaFWF4%9V3o4;j;ZIxjs0HWe-!J4caVHvY@-e-~rX3wP^To{o6R&biE&&q5%QPUns1 zCr0FOFQaP1FGsRmU)p-w04o@({3IJgo+v~_>1G~z_}>#UYKL{KI9cLOWL~{xG0k;| zUjJ$(7AP|M(&4Fc4Z4)nnE9xoN9{$8Jh?gyQVuz9Lt}&Rb3by%xh&CN7n4{?~ zt9qf#3abr%{)v7^YFkq7S6FCpko(jR2$oP|>p$De0rl@~ZTAAErdPO2&h*VDU2uXd zksn&$>Cz21=-1D61@)Mt*eD=qOkLhncJHUsHl<}YujKQ+r5Kif90n!LU?k<(y>IZ8B4aoq)y+BgvPV;75l+&-`FFNS8}$WN z*>Rji|F~PmsG)R4dFzzE!)+tB@r->w`x~|~aY27w^Hz?9WRzfh#~cL>G&)!3StKUh zYPGhtDH+^SCU)w52QHp7DPuC<0^7QkN=|c@$cKCOdVv}(SkJ`vp^vMl|1sR@876{g2lmo+sw> za1M3vtIzlH{W$g3Md~CuL<0UTfChmsa#jo+C}$C z)`&Fn$en{*ZjamYIM(Y$0)AHsscNLT-2>lc^kh|+)JulTY5uJ%_)P;VJmSq}D{zaR z=ru>bUy8!?QdCk|O%y3mfNLoig`6{&DHJ-XePiQb4$m4y=dB}Y=i4g$^?ObF?7r;B zT3rpF11W698N(>;;k_agb~z%_M_y{5iNOw&^vg;=5zAM`}F|P^%Y#--8zsLK!XSD)1@I({!-I>659`4i$zI zswzB#5U;w@rXj~ohnc_+AFgFe|9}B)khb}4BpbG>aQ&Q=TS!362s1Iq215Ry9sRkA zA(V)*nUo#pa|O+ZmNLQ2kYu~Vi}H4!Q&4()E@n>$qy`sA6lHZqRi2)UcRHwV9rSgD zVs;NpzBjWILL>ZeSV8Wq5Z1EM6iF~TZKY#L%d_c?s0iD#Gk?9$i!d=SH0B5%N=Epj zG8D;78Hg!sOz#DSvzmSK07r+rRog@6|W zsQ!tYwfO4{3h+(GFHF~*Jb@o2%SJR6AYUPJMZlr5QI5RmtI;c&RBD6ltk337;cr?g zH{lxlD-2b9`40)aa1tny2c#AKJ$MyQ&c9s7mtX>mHZ=VOo9uN=c-TGl@abA%@UT}X zF0}`~EW$f-dZ>U$7j^TqLDgFy=Kl`J&w+6OZp8Ie=<3*$;_?U6%aKA?qv_zLbGRBL zCEETK2bV5Z?GxvfqSIQ~Fr(g?#o^=Ubg~2AGbxVpurkl5q~|hX;~&|kl(j}3?~c$X zNUU)5J|L69c=C8bAT8=gNGP7tc@51()@bJeLa}ssvzi~js9QM*KDm)0FoTu5rVKqF z9;oUzu)kJ+U=mM`HmFDE_$w)Zvf;wk``l*V^;lRQxWT`?2`BH~UuX;F_g+MqRRH}xpLmtFn+C&;xW z`476F{_|Y{v5;K?hG?yK)|7F~Du#K`Zp^QnI;=;NsH-|3{nlcDHgd2p^K4&ud|CKV z0E}V>eLrH5F!OT<(7W`j3l{U6MZX>YcVZZ-@mClr@P5?ZRGB0=OzMry=YU^KfyB#n zxMbyHmYjN?hYv`?r$mOnf^D#p&tAlR5;lW%*R+lVP+>!n{<~P;mL%s4HhXhVk<1_a zt_LTD-q9`9-FbHmsdAuzK@NwNVUVvmD=jYFe;x-uW9^>t=3OKsw>js`fvTqfXzuce zQLZeu;Tcfxks>VnUd}mY7(pcf!&IG3gUt+B5+7DqG-r?b2Q*%zHYY3G*@#pxH zFUz;gx)t~|Vx6^X=yr2s4T`cPZ8!N`C{2j37p<^+rtDzXC+~=6Fw||HjMdm!zk@Z@ z?`K%17t4v>K-|Mgko;3wL=ma3HgdtZ8GY9@p9JG2j}GQr@=oq+*>q26TK974chijirSc zk06Xw2%-6M8PIy3EIt#Ul8O~9*y5Ip4XiQ_;d8ifxxF4I3~}^bvYy+zKE~A~i}8Hk z@>cq@`6Y++IUZoEAJwrxqKsULU0#PTe!}byUu$fjc)M{fw;m72HySxHhjo4P4L+L} zab+a%&828IVYg|>;kKjvzfLq6ty*cf z#DYvreV*HR0eIucF`?^AMBx7(bE zn?srC*`tOfY|1A-K`{GChSMw=T38O6?moUgV}Kpo5VKc}OPAW(bSfab=WgRC*}y>2 zr?Mt9=SdKxfU{ks;c~hjIMW%sPJMo+h$;OrAF}CcvKBkpf}+Nl~UG>>#hcrNTwfew>K?1WrsoT3xsIgTs?Tm$6+#^+I|B*tgqbX}Y$fMI)Uy`sBypR&H zqh@s&tJ`Zr7KyjZ#qj&25dyA0V>gpB$)cCj1D^F9^(=3pfDECxwb_UEb15w4*}iD_OxvDxs6`Tp2o-V){hjUoe`U z?9~%vLG`gwenL6WVfCe4ra|aR2S+yLthlT+^+C~1CK9?LKJan725?6)!vRgwk1Hw( zR}WzN6oLTNsHDyL2&D1&c8uD3&Us83YRC*85V#^a*|=X~i12*rytU8#=jApLE(O2p z-?gQ$gkpYEs24v|5^Z@YSe@_Vv;Y`OnTiuSks1x}yd1{q0s z77XLnn6W{yU>J_B5K`I&A;|^C$1Cgn$~})7h6oBmKgHAqHsZHRZSAIMXlW-4PVg`C z@u*ftwDz%4lReGm;Fc2}_*K50ZTvxnWT;qX8u>m^LST|CMu_}W_r{&PWbrc_DA&wj=O`xCmXpoC|9uq=RPM8Bz{IM z??idD6z)oj*oui@8ijD(=Luu9bIEcI;yq`L0roL0Chgrzgw?cQU^&;+=E2M+2XX%A zswpigW&xjSJmzpQ=ZrU_Hxo;F910p;a0bsBrYn?!MLcM8|C%!Q$${h$lFTBeNA@UG%?L4#-p=UJ|QyV&W& zE3p#sQ+g-`b8zH@>(m z5!(Ipw@1o_TCl+CuDUEC+cUz#%lU~@wM-?5yt{tnbie!zjB37dA0HoVByK{-VV zrzqSoTcAwr*5X<^pEK(K%TPg;wL@&rE^dXUjri zRVhDaUbmvz%`PFs3+FQmu-rxJ!&NbF_<0&2|K2;)H`p3DHx!YH40?)_j=)De7TAF* zO#N=#bnk2UXo$@nLoM~O5Q9?~z4=k75DIg8aFJu6*-+aC5qcI$IHBNMC2gWB4jU>5 zOady7;D z5XY8w;c2O4aLkjuMuF}feo~0;Zs;-iztut}%?Y($9$(F*&oAUqRJWL;kwTP38h{dc*&m^j2o3kKwAuEh2XR}t@x zvfzqaY6aON7oI1Q6$0;O%6{8DNXUrh;5P3TE{DNb^iANHemJs1sx8RaCDWjsmW8-d zmo4uHNusRI0>W@1AA_OHv(O|V?${=92DF577O#0y{>NpOakQ%H-$Eo^{3zoypjbE? ztiGbp=CSj4d)`AXaICZW41QLt|xW1F!mt4P_eiH9{r)Mdh4GcGE}=xNZudnz@r!)IpCi5#1-OJSIg zxkwe>;Y5?r)i2t50H)RP&9N@Pi3aI;u*SllIqT()Sw9C1sN1`u4M|^6&1zmTAra=yc^&dT*N9L;x`swdU$u)M|w`L9E#G2;rW-m_pFfOcQMst`pygSxtse=3;W>$z1 zOa@nUM`tIV01J~N9h~sWVbFPM{0YgMWaTE6j${}e4w`0 zt!`M;T2-D@>r;<$YS-$(SA-F2Ix^g|QY6_Nz3H;-POZyfzp-m;V4hbWGf8nRbOk^7 z>dccg@ZsEj^{o?e?>rVwt@n=3TrZvtDQm0c?bjAM?r=+*A}AY$H7QGG{DzpO)z6*_ zrir+(Q(US63Sf`m9uzMes`Yww8aa>U7TTFhR$5-IUAeLAYM3M?3~1ghY=Um9X0c*O zhl@aW+t2YXFQy6C8lB*Lc%5rm(kU+Ua^`C}Y=0ekr{)6yFo*bU0(qT4yF^2y{sBUa zrB<++jcS0DtJ+&5D4nTW*K?J=^_7U~#p1>xp%5cP+L0y0?drgZLtc%}8H2=B(q25z z)b1;3MPIRE_7H>^rLX#A>=k%!itsp6l7LEcUB~L$#3&dSQ9R!|Vt^K$)6U|k&o?4( zyA279wuSd!0L!zJn*Rg?u>B_(fSrZ)zrg^^^sN8ihwr~fS~0LNvM~K`VSr~)xvb3v zKj=f5fKC{MfX;u76Byza)=zb^u1t#Kh3Z#6-BDNC~`s1L&7Xv|tH@qtg%j z%Kg`v-~@)*-a9cov#ke%l5GvxXxj>q+6n+wMhBHv$HWAHiiv5~7X~NG9q@qk2H(*S zh=^~cANMRkh~i}L>>Q?{$-#T_F;^C#83WcYI5af!N7mIZ3}+6*$ix6%j^4f*XrtSh znW-MMj6KcYuO{c819ryl#PV`{YWVozVBq}FOz?dFx@7-t8b@9eu;s-+x4aF9^{3@41zM$%)>nnZYe&Lo0}ypOrrViMYFnY8@4K z-_Xt%ydbhBTIgS2WLM<4>hSZ-{@mhB0AgV!08(3=pY7bpbf&TS<=}ZxqfgOTDc>M> zP7_E^M+R_C&b;nQ=mosz@W3p86Wi09@u%10jWtfUHP7ErYQC2fRNp53o0G93eRu~4 z;EAwb>qk<74^b0HCr~?jCML&wJ77N<0Q|M7i1S#Gi=3D~-ehXuuw9S4XBQ_s5Vfvm zz$Z|3fZZQ__s+C7V8EIg8$R7zU#g$fI5jnZ6MQCBKZ-ddqu3|er@sty2XsE2zNQH1 zd81#fKGXmwygoml#&@jxCvYz5?|4MC31C&bmMZoeCKf&{eq~D*i=!)s#B+4g1qq^a0;(EcY3@1}Js$Z;B_{_lzd@#5er3nkeyKxAUC$ zDP{Yr_i6N;Dg75(9YCtjcVCko^>?5Zs_G}$mc;L0QMdkA%&mWeZQZYb`dfuf8h+7w zj-B8BZ~3C@k^Yl-xOv0&RVkO!s*v?>RdL(b;hjo&WOevtuZ6LD&u z4}3$O87Gwf;i!D_0ZO*`KR z1W$Tv7^cRe*S%j}(Rs}@{$)zQZYa?f47qjacrzG4?|r*UkMRSfT49cd4=( z#B?(T)>Ku&=cwJYAR&E&@sV9vmo-|Vp*0Md-R&eZ>V+41qs@2Bu(aKa!!uSV{wTkr zBN3Ypl}v6GABG|*W%p-dZd^7ttSDu1tnpJVQ1g`W=jkr#@U*D|hh*VH3E;2h-b7W{ znctGdPjPwC%maghN}}zTQ-b|;pW9g=4kO5Z<`dU8kX@r}7kQT}aeNkvsq!oYP(9S? z*Wr@qlZ({X8cnO?YjvLP9?VA?xRipQ?Wooy>{T)?*1s1X|kBdlIOW)p;M~$F~!QiidK%iSK!zOlr~&|*2;Kov*FP&VY;1GL`idqU-JCVAfQ8K=ED)s zv=qB!s0KwnsZ{I3C_`Mm6w2~r{G+dmM|Q0=sw441%PDFk`|fb`(uOsW$4}C zJ~aFyu!%E{;x=$HEmGfv-FX&^c++w2my;_MwcEGwz1Gjb&1X;UmfTKTUmdo0%KtKg z8EjljshEj|HHlO+m{Q32;`eMBp$4E4z@C|dY?I3ynYT6zrQkD4A<72n6AAb|hi@a)N{=QkGHc4W=%R~rZ^b>TUsJuV_L*g= zJ&!d&7Rm9WjgkvhD})RchO^yNUg}2S}A9A>X(1}JASPA`C-Kcd>@p4MvMICJaA=N9wdn+2F(KUVepQ5;U*-e zI=yUJTtXdvfjj|@0uOqx}7!5n~Y`s#jE( z#wEW4#`P;5OM!{GDTWuxSaD({+M6^(mX>EGlVT zva?OSe}Va!ENtwp>+HCC?#3(#L7&8^5;C0X%G(%9=0$^&oCI(jO{weL=B}jGxv%)y z^s^C)4Du2=<1d6D6tml`-J4$5?mc}#B=(7t-fCfDfUONiB3Eix`@&to82<^LYgIB2 z;BtHVS*UiC%dLtd8X03AO-a4T#I7I z8_~fRYQZ_?6m%ohR88rvpB^oc#mpZ5@|~?)nuBs#wsX@inn=-Cb@{ysD+!tYHh9Le zw-Ky`re#wJJ3Z26U!j(BhvpvU8X@igsf2Daj}w{ukm!*kXgN6| zeKYVDMwj&?+H*!bYnk`*!v}!WH0X!U`Kr)Q3=BHjr}L82A1lR?$VgMp6m;}#bVKb0 zDomNI8)47F&+^=i>sc73#GmDG9WG?ntMk~zkJ!XFD-L%u<1r)TvW7VzjoTb;?H6o> z?0a6%8k)tCX3T_L&3&kxRd24)6>jxE>C7tG2huz2#;91In6 zOnnM180q-tYWu#yFO>uSl#!$?dAGdIkCOf!iklYW$s2)%-HFdQwRv z8r!O!Kj6H_1A<1$zE3IR(h;CP@5aD2Y!R!&n&%6p4}~dH6O+EJ7IwZra+23_0zba+ z+2ru<3;6&F7jEm@tx~#tW0E1lbY|rqaH@R!=`+qbF=i(U2F;lT7eCoj@%FpVcFWRs zB|M1WUr2M!b;Ic4(RO0XOq4L;|8-Xip%Ivz!Iz#wgQ^NUa6!+tF}XuLA0TfSv;e(U zTco?-@xm8T;;Gh(Va)YnaV^<;@-ke3vwp^Jba3rIu$m9y+<{vxW^4eY^tX$w(lb`BbFTp+}Z@8yTJ8_M+V@9Bo zs1FT|V*HbshbK zRU?3G6F;c^j{Lvxuc*ywlFeDQy$h)vqo=eB)0h{t9m*H2pL=yv{>bb9e%vydnc!~T z%QFRoyxkHW$b7vaOSJ?YZoJ@=xaVwC`|wB+Tk-Z7GBXA%*7|KNgqO~XS$K3l*XPqd z_HFC}z>6K`Ej(Jn8^Xf|x+?-Jb+J#6-bg>yD1s7aI+{KFt#rDK-q?+=ZU$;Kj2r^V zMM`&l$(B58m~5 zCdv~h<^rE&N_9&HO=Jn)o`rYoS)W?F+Rly;RiS}kGt37kIdc%tg0$T^ywvZ%F*c^PfX9o5NYaorQPZg*)q@5NRFq#``)iN6B|IAUT+ zqD=-;7Ev#KGe{Urims#oG|atJ`4bF@;O6%<8z7lwa&%CNHj7gC5#>S(HSAY z6HKe<$}0Xm*LN_L5elN)Upe!SZkeO+&!zYk=>}Nd$b+nvO0ZM5g(mx_@jRy2%jGpF z6^S=eVki|Haja_fPRB6?uPb4JY`Y=VJ0K&Nd@ob(WiuDy=*q1xCJw;#MIroq(>v*A z#R;@5PZs7pQKrI?7w~(5;XyWl6u$AOOa6SUk+rwKN)-Ycxu~Uz>juC7+-c!hNw(n| z%C{h8$l(L;VchFytK4LX2~WWe2;y!A`weqfhFa$+Hch5Wgt3IVdG^6eFFRZpYj-*e zjHz0cUjSovM+={0MBT;33Wr859V^&G<0or)6!2y2S;dv~N^!!6m3qu@HNxyO&$|Cp0Y19`VpcOgi(O z@5_NM7odZ~B0Tq7yUNON+qR`oBRI4z9Jp>qnChmbH2o)z%*YH|MkmcA%%-5X<_H1K zpqybN+0xDX(_ge)e3#=Kr|=N+{i9=1(XcB<#WC?znU%3L^@I-6&&uWYgg_HzA-9I*!^%{pwb=o@8W!%Cjzty?910`pXYqaEDjJY ziD548NcTaNkT`y*=&^^?NFiTbuG=m0FVx{-tH#5mVWfVvZ}l6b*t+P{XC_GrUZ#_| zBv<1v$&u&a3n6K(B0Vk`Xu#;GT#;BNyO!sWRn|RO=Jc{NNi-viS7RERs8nk5S9~yd zgjJ(YiNcVoVd-{{#~xQ6|Gc|r3L|CuTE41_-z;gy{@v*{EEy`jWZn*)*&|QO)tgsaMopyXIILFM?|6ni{OD`Nz-GS*h3DZ#+N}59KsPjO4jymy z6i*rU-y3#Aw#DX_IA`Aq^1V^a07K`WH?@82q3Pl#kkRQEIw>f|Y^n(#R&KQ7VSMTc zwm1001sy4`r7q2lJs4ura3#vE1)5$CQWVdX@w?AjZUK!y^}&(#D<#V^MXUvh2&h%K zk7Cj_&jhme1n%UJxw*4}A_;czqatr0U$CUJ5S}VmLB>uwBaG@wy&q1-i8#yrEa5?E zp+@7mJWNJB=vp)VN0W;yBi7kjV{&`AeUMVxqSX*uBC51Nnn!TBQ_Dh5hUQ+}%=tW=^^5TjhLWo{V%h9lItI7=mDY zMWE-UzC(aV7G!Hs)Ci*#Eqv0a7;rw4YJ^MC_kG|q0z6USWlp)O%T9L26Q zvIi*D9Ob`^#wbxSv^qY`=|?I@?iM;lHD8fTj}5$_VAYKDmi9WNs?4C%&Pu%5yK}Wx z2jqfJtp;>#sArPEpGt3Hktl0~ys_>0(H%>db^zQI#AIo4;qbyd#H=xnbnO7lfq_UnzW^|oOuys^>-F(;jLrIR3^Z;uaY$n2%92PR$8!(P)-u5N6NB`i-|r)jV)%P2HY#v5y7 z681mbLnC?)yZ8E6YxDxyKQKo+1$FDo>>Zc z55;WXx+UZnk{wNJuIU6Lpz#|G7O;1cBgi3l{o;PC#UOLeICu15FpmEzj}|fTDi#^y z)VnFTg*t&h)lle9<`Cp$MIvEA5BtQ-N)+$!OI-IQ z_ZY&AGp2_LaUXD;#FACteBWNROm*+S``Lt-TO3R~TC0sH?>@kp##kn0477be^)f;x zLb^$#McvnidaP1zAcl-HMbiLZ6vkDZVi|HZau0{spj@Pg`)ZwyJ&rAqP4|&tm z*lzMS59%;edSjE>St!XMwx0qE7I+$DhbA}bVs%sQc6LFK9yvQk?ht`sqJ(6^H5er0)n2(_y|{< zFt@P8l}G{MWsc%EW0J{{2=Z z)7tFs0d*uWPJKu|=L>p!F$@7MZzw)b4p#oh!V8gO0py?#$2zJ0}*l!0bs608u^zg^^ zgRHXdq;15zPsZFg)XKyqZF0cSg}xsxo1tw5J;CIEf!5W(IjhRW{BNn# z?xQ+J4iT#v5(YnRKXT@nI|vzL*eLOoQJys}Z2N$%XF4ljD7$hY-%3tZ{}V{!2hV zfsvRwdcEgRT7B!H^d643$uD)Lt$SXS?#E;f&a?tZhHce@>l$2MuBubWFcpFQZFzFT z^O_hK`K@Z$>W667Cflw+F`E3Y|J#KudLQ~vs0p4m;t>-omRPXQ#8Lg~0aGtKnqa>{ zSdN7}!N4BoK0=exb;(}{Od%ZuA)#x_R2N)9mNAZ`GckWgeEYCgXUhol4S=i_PJT}8 z?pVybL3YxRl);eXBL%tdAE2eKT<)?VCglp=$^@Z*cb*O8&e|iyE%2wmuf2?H(``Hi z#gE;tbSldQJuEg#eS^F7LS7_ft+>~hy-Fo-yv0=U!G~5T2Pe(aNhwBonSA7TXMBTb zJ@We6JJVKw0at56t``b@$XnHw&Vjm(*~jqpk+RPwN)GWTj`wRguQ~6#@<)AG1^ z7XTAN_l}FCJa*c%;<(b|U`xHPU3)Ol#9wesE%Bw&3*f);Xl=3w1d^+v=wQa?{29F3 zL0nEF7nU=_l;Z(KOm>{UWNrzGN8`k#Hf$c`w3QO&o%iVQ)g-V8$w4Z(pdx`X%7w`PV> z`4<-_gde6_W2{lXR2u! z$Ox?dEp50&I#o^(6_`e42vEEXKWi1?<>n!+Oel^rtCr3t z013rWVXak0pjFN~ftfv9Y%a=YW7EmzsYW|WxYW6SQF%SzQYJ6uy^+KhoAb`N))N>o zx3=#Q9yjg*l<~9d&CqUbMNS?hXxI5%-DeSoEDFdX0XH%B}L}jUr8!lERJzcLkux=2{vw zrTDyj6~>!Kg*UZ~*@ZNo^@31hN^b4rYjASSwiU;mCGHD2!tN~o#O)A=S)^%yd#uq0 zmescP)-nYCA2VHju|x{*k7`Ab0_uN!T1* z4MX}}2jJ{o?k@|Q@S`ZuI7T5=NLq8wy&Adg_!^ramBkVW=@VTYusFNIy+Iql&D zl2~(UD~KL=cbh|!9M%U*Sm24l(a@IaoX-07QR(ECjxh&vCD|?S6eV_eGdo#B7!_IX zDizT4UaM-evWZM{4xmBxZSj*x)G!t>cgWKEXj)Sl^r8rA+*lh|zn#Phd@(h<`&$RV zGxGd;exM(%hjp?y2*-C-H<4vEw)|;jFb$r2)m(jOMNX?r<4+e}xW_l0l42jxA^Wx= z+;Hg>i&=NTnjB4YPxx32^G#_%@*KS);VE6@k+>CRAe7v?K&vpBTOHNCKK{=UGdJQh z3MZ#frndMt3b-r>qlXcl3V$&Ko$Zeae9U$GS=`PTs=J;c#yBTT(K?xgNeg9oEun7L zq>H0K8x2d05oP=kXO0|aV}ef#uX2hZ3W*7hR+W0QYI+Z{TX&oXx=xI#tz8$sx^#(n zU$oongZQtR@?8|&9oP4IZB97z*vl|kOW!7(N6eIbWna6yReXCgObj&&Yy&PMaikrZ zVqK@y0b|fHG+UcgiGd^wT-U+%!N~qDO;+}wYw;L*NTeB*bAsQVhhRhh(MdXUmoD08 z+%K(&JE0I>-RQ!f#7YHEDh<=FNzin{yLiPW@$&(K@HSE#Zg7n~jUh@E3HPUg+zALE%U1{mnxFO-6c z?5+hrE^0kK3v6;ItvJR3Rgt z5V3NCki8@`Gi-@fEB59yX7MW%52YURsrG+3*1AR3H^@VBcG;#u&xNwDs*cQEeuux; ztp?>_Ece;M3{wTPe;tYw`EWg>XVrw?%Xf%)rLH?uUi|qV=Ev*o%CbG+T_Xka{#}~{plD@fyB|126z4av zx5ZW&K21IvJOBJn9YNOG2Dnq*?U;Ts+6|=P5-7;O_3mTW(7Q=3$EN+}KX|kO59YU) zXa|7?BD|i^)eX_PtQ9vwd#sVf`sls(MYeS`i@impG=@BT>cl4mbYe8YO3gM4uZtTG zot8wr#gy}p+H00$RP`+~{hQ+jMW28xgvdS_CTX#2@|se6fArTc?C|lmc%akg zsA4CPC++4QBK)YLw(Ab_21Q!ghJ|#bTdSkIj<04pMc9eYmY*WWmyfWz*aIdurE!lm z>Klkx39NOfwa{_xt_n}y1G0eLzBc;OiCvtn`SXh0uvZaEd-tAyvJ>WB<0y6yk?e;a z)3`M0qDJ;vS)MO+;vRwxV7eMZ<Kax-%6DUXG5Jp`kt6REr^lm zsFq~molIFb$->Pt|ATxHdh~!*GB1w~z;3R>XS_mK;pUAt(?v!%0Sd)Wr@ireRd zGT_$^fjC0egJQb+s_1&wd14i3MeNE6zrXm+!7C=gEfk~)%Q;9F?wUN%>l8QGYX zsGD?rNO&n{0%3dQD-dI!NvkOVW)oHxD0>KIfB#MgHb{4ycjAqAz|>6!m!bMAhVHxe zh`M!pqzw8zW3dqAv~vErnP64toq)&6+}}{mFT!Pm>%w+g0r=L5_(&zc5$PV;(QNd)Zm@&uA%}-Gqz5~Vv`MR`^>PhOVf#CJfsBWdst8B{q z0h!-9_}P{UKil45i(8MskC{GZC9t4u(&i<{3Z&fEok_6bF#%?AMG%NLQ|3c>|vo znKBu{XdR%JmD91wyGkV@?=@hvnK;+oYxEusxObtG+5#S+(4O;4S*(ohnjmty6NEUo z$lVZL_*_FFGnHI=D3_Lc2;T+Dobi~ON+&!SQGoi`5bB7jZh+M%nnl%=uI_@B+rT4B ztyx50v<2C)c0u~*9W#q%8pg0nB&Wwq)D;ijsj2lHqU)y!QV+^sD4I}UYBA*njjFk> z5EiNtT1Hp#DcU37l!78$WH*E|?ADqVZ25qD!9(gIj3fs^nUNHJ8H#PhKjUJyI|sFd zX+Wu7hg=obYWq%(#8!3XVq+{x4uucL=kfOOA=KaH3?xoy%E7I7Y_UMvp8W-T3l!Um zS+l~nXJA2Dw~Sw97m@N4##ZkWfbiL_)AXQ)DAbMH6SWC+ZuCCb8>a!*taDRMMHU21B`SyFqLz%G93J(Q6YUjHAS$WifQldOo@qoK$P(3iE%=*jKl@2!xs3Ce z52k%yi#~6_NtGw{hM|@d()Y+)o?enJ)6`8WJkvk-i&g|k$`6kG!$cZ7?7(jydFD}} z@2B}dVO~F>PEUEA4|QMzAZ@O|er*Ta#gU#qsI`s6PO;7Gln`y*kV^C6iAnd&|v~ ztX9KBbicr?VeapQ_nB`lbjh5V)KtY#+Q7Yc&CQrP_3o?9-0I)O@01-^T_US*E5S*p zi18puBI%fg$7GrV@HN^PeWZC_dn6OJoMyHhSScwNW`qzNL59OFcgtBE(S`lyIMrgT z$2*}F@G@Zd&s1Ovda)FFq=?0?tSxvO(q!F^gO8T|yrL!G7*>`Nws$ktyb@4o0LymL^caUjVsQhk>g_lqqvbTxo|H?r@dl#uq$^pI9q|D**l4p0 zu4vHE?e|wNyLRy?z~|=_+NZv(NVtEvItR3^mUg&-C6O%8q;5)ED8s<^sji{-X4cVo z+jFGR0iJ+iIka*v;383t55qKPJJUQ5w{sdF$l<0uQLw`fM6SCjc-_i=@tOFGSiF^I zJ+UU5j7MJOuvi;Zin1gzA{LCFx zy*O7#)zo<@(W+MFb~KLwwLXDVwhqFwvc(o~l;=6P&qdDGl}}l;8b=Qc2&9nqo?yRS z#M^fw5TUDa4zUEar-jWrDS*)njyPtJPa^%`FDh5hqjC0Ov3G!H7E-bSb*eue1+oHe%Qx;%jTaSdRvgXRwZ> znze}t#yixWo>EUYMPm-J`{Tk+Tq@fElK`9GqSa>+pB|uk(;Zd;NBUd z8FJw`+!{q42FC{>*DQy|i5-H)U!N^Cs=5Z(0fWVML2=r{IYu(bd3zfy$^R1A9-G}L zK*?b-5Kopp8Pt$!Cv8&buKDM_9e69SH#!)iGSD@8(*_eT{5%h=QkU?TgVAlsfllM* zf#k#jD(M;X*8#z|;f{@+Ll+=)c!0shmh|(kkv|&VEK+|&`vgqT#=(Z=H?o88#~AiL zX}=&vKDDk9#ISPOLl57>Ly8$3BN^dBTdV*}^z;K1MWeI*cPQM?)DTuqu(~LM^79cr zGTlB`26!Bf3EKDK^D{UNYG!$2?^@{vnsd8+Zwkc+E@czT8dFVxhc}nt0S6)iR|D## zQ^v-o!@USP{~_Ihs{##HrhFNFUoK}X=VOyDlHwLlyYAD zG`u*-EoNqq6t{?d6JBFqHb1JcV(Ww?xgOlNiwywT- z3;FsG*A2P=4>nf5Ks2)R&%wL;41M+)uy;P4RSFvG&ZZ)K^_`B{)tz$R-VW^u7Ro5t zxyNxq^H=9$XHM2lzN>U!mJYOG|=s$+J`)=@d*3SFgvNUle(*xof8AWebC}n+HGnQ zlLQhp3$0FyZ;je}DvR2ZqLq+(uI~D7u|z>^(fw>9i&8zazUaVd(IDpks7o(`-r)AG zW}W0m!l>Y29<`0*O1eDLi2Usb5DcAsR6XHs`51s^{Jxl{#_^>s{*X)*)i<~kN_{F+ zM744<71!WIJFn1&iSqKV81!1X>wjJ|gRENWJzhT-!lpjRN&}+1;;o;>ZMW52Nf|4s$59H0Zj$B=8WpgqJ^C!vD5WZ zy}B4^H&HDTz~i|iXu^|6&Fx~q!3&)nQIr}sF+H7wFEge`46kcQa1I3m9hN>LH!v$l z+^oBki+Xp2$Q8m@+vx%&Y4f*j(XA!KO1K1!8`)SM?UiR7X`d0S!}jD1*FV@2H|1JV!At0f6tN{63bKSffUBjKFwf;Lx+tB&qOS9mk! zRzhl4sSNE7%mul8Ut8)YFi*EiRV7v@*-zDHd&WL1Abh_qCu$c|uspkrSP0q5;7>&7 z+;A68Bi;nI%hqHq;ldI=Ca1H^c#Mk}6griSl|Z=qP%~p<+mB+jxHb`$o@R0M?^6Tj ztGvOGUx-PN3q3-Ni)0Fp*1Hzm3W~JA#_fk+Oe{`M_>$8OuJQ<>c4~&&Tdt1pbWrL8 zxM!h8WyW-?M$=MZX}u_Qbc(S(nSzvKE`=Az>H7Z6h}u*a-8`LVcH@_jTl-iXTWW$) z6Gxw_`Z)SJxA%oyuuD6QT(Pj{#Q$gPz(v#U`gY7S>&k z$w9F7{lt#9yCr^E7F&!sM~CEaIKr00&u(={znYzlYVy7$VBW_kBf2Kjfpnqs^tjW$MI+zIZ`N_{rg>1XD44&Bfo>0+3o7y@B9Ri{<*d1i9=Yr>Gx3? zu>%}<(OtT@$86UIUB#lYpn_T#_M`F}K$(yu;3~trWPml`u`{r@{6Rd-VFZXJ_KL#+W^o%^8CU6x{E^9|CO_fc1CO%1f>yM_R zhbmslwi;#!2oqRqjZsLh*ie7W$~^ifoT5lExmF=)_GAEy1;yKRw0mOTO;OOjBc)CuImSG#W?xQcSrq2$aoDgT6g)7rS ziVO1c>rOW(LM>jZ=l#m?r;Tk~$+H;{c27#}mRRbQ%Uyj@aeF7e&iC}1U2XEUFKjG# zXtF&SEE~EYCmfV)!Gdkgp%Ty5z7L^Wk_vY-M@3Pwd^6t&)u_qUieOIdnkr-hMS4*o z@X(du&sSedYB+W^oPFottm%G7Q{R`Hqg?Inn z{0{q8c_v$?{Tum}E!rz7*R5{*O;MJ7g-B@K4|7KyPk)q4g@W6)G)(|Vyw!W1 zTiN{PUYC&^q%uhR6XLzaFL&>8P8{+}q@*Qm_>Q0z)s2z_VH`S-X@@{q9?Q#hX0(AY z%hD!}k$g{FE<`j|*t@;lbAf3gt0w0V8wG@Nqog{iw_~Io!#{puTbdUjfT&XQbXPlz z<6P}|8P#hG?Z{EjAVWRZ=6+cff~9)A%B*({a_=8tZOtf68c5po=cJV z>+V{xL8{HB#Kap8q<$JILat~O3kuo=M@~0f<&_3;gm_gSOdzxQMb||Yv9-(%`Y~|E z@Va!iD|Ckpt7zL}_;`gneScB9r0#Q!D`QdbsPaM}@jBbp*AgqL>C?>rJo>dJmr*D6 zcOO<^$3kY$a4edlQ=i|(E1m3ZD$SsMs-uK5qf3oV{CL`7Zk$IZZLMsyh^8o$X*tJn zKf$ZlomPM3O~RdVs%G7^F5kV&^KPeq7elC}W?Om^96~!Xbl*c>9|O0bYNe|NKsU)B z!6=JqEHHyEFs2TLK`bCs6K$vz(GIA|=IslS!P|EbKdAhWf(tB6LfM64AmP%ja~#%m zWKZf!bs=+5u(l5zB(g!xa=!*Om7)fBZ~#vRKt%c?E}6Vxz|{);HQ5~>&KY4_^e#ZDm=$A1lNL1FkK+$=aOfB8opCZEQ>NB zgI7%fR|Krni6VAvelHx7+|O4qLC!s$>qf@JM(xrOd<*raSjY6-0`6a4w=WOMWW3+WtEwy97$Yq5)*hGV*t?f=YTb8wPu1vG6EA zBwQB=WW)wXg%$}0 zYPG*`8wS3R?tVw|14N+JXN$SRnzjHmI#2c)(>Qlh^gf(r-(eJDjoCd^?{qLtuayd# zkZf4y_M7*^34rQ9(7-J8|B(h}`1@ZpFgq(7^Zy(D4;Yx9jhW$p3j?=;%Ar`G-Nib& z2G%(ZE<`6RY&N(k=w=n%ZR(!XQ-eTUR*HUYkih=6kZamL2KhH(j13)BLzz)#~| z!@!-#JOY{X*AVQZ-~Dyyr__fJY>&9VbMy3c49wzg%fE3^u*w3kg_y$4gM9($^z^p| z=#>B~3(V^OO&WzM@0*xXf4`(3+rYfIf^xVIZd(JiB9PJZ3kjh7I|V)h z3DCaw#R$Ug&bNQcuY(_kJO*WRr+R_!7tn+X08)FG`@vPUO;AG*Zv!8;Sc~cI)9&A@ zzB4R>dT|Bg;_t5aGa(Ci0M`=ox}AEOJL&A?@6q}88)`*B%i7XAQFrfjJn!h=<{prI z^i%I2N$)#()kp7#j{t!J_yF8z15g*+%spER(9u(~*PGPUJ9LK$^sSv=1EA@KvBwui zgZ>kIehc^j1gv+Hv&Z+#`{!3Wt*Z+FD~tt3540t)P4DLg4lU67*W~THQ_u^5l<)2B z9>}kk=l6#(P&N&AX?Xm#^<7tW%CL&Mu(YE8UUvMK(%9%<)PXN8ferv#EHpu16g-`r{?fDlZSeomgPb8w zzW-Rj$JrAGUkx=Vd_i3P*VF*~_dctEZ6Kb`|EpDkf#545?PBNjZzCZd3J@Q#jV1(U zZU6Ta{pTLw?wuemU`?n8;Nk@W|3?R3I%`MxtKtE_t-n-Y_)h(INO>1)sLikC z;}aADfZW|dzL-Gxgz*Uq0{nU5TWSOL`D?fVJlrl&82ktTUS1%;7V3`q>rRCP0X)*b zM1PYofJgQ>i2!)y{v~040FTmd5&-Zh|0cK>mER-;;8Fcea4+h=Nff}N@h^!00X&+& zi4VY|{hQzsbbk{(g5Ga}`!xKQMB!P3eiJ-`^}qD1r#v=)ATNLi{0G8A+Wtm(iMCFE zXyI)42f{P5{{!JELHwLw$Jrb)7VoH`nH8)Rnc4=p>{5C_xzWOo6|>Dq7aF2{#!_n`-jm zbj{g{i1FzFD)z(cQ6JOpoRH--#e5ioeE+)4F<0TxkF#z&FpUkA(r!#RJ$jwsC|T<< zo}~%02}_E>^xX^L9{%q&TgCSs9^Z{c_W;g-(o1~0G%8rUbY90EVyqDz;~MOfktu!x zp}R?jr>>IT*gaw_B;iV?J&xjs@487s=BK5l!JL8qbpF%VD!sKr)e%G##D2>~2FYADC-Rs81sp5f|v4rD5sNDK57n42X%Fyc*zJMo}xkNC2-2H(|~w?z#;%14LE3IleUld>NP-f2DZz-pF81fCh} z8^!@Z0#~+Z)B~3hrTjt}kLzDyQ9`m*? zTQ^_(#Ry(drkLm4C=NZ32m0t+430*keL&E-0IO{ zyLQbYeHLK#1E@W?|LVqso};siZKu4hp6PN8z#JvgMihV%xgemy^0}z840kqzatWbn zJhHZl?U3q0l<`~khTU#qbW6x(+*<_FQhX#ez=b4&$1si zbX$JVc_9@bXT5Jky1VCv^BFN_or|Nx``g_7wr2xLzl{l9;A)7Li`vPLl$8A>PtkU9 zgwiI2wy?^UC8#%;%gO7;?)5HSHAN2ex_iM+sI0gTeF8w@I!(6jiTp;TU<78ICw z^cRgp9y?^>4fuIKxo9ui1qL4V1TUU5!N}4Uk#$qTLmrs2#M52*w4@DG!rg=~g@_v+ z@@*;RpUCB)vDXRtCH8=u&z-Xl!==#0Q)(hIHmQnL9hCMi&1|cC2!<`q%hSZP$|k8Y znGf)#&ee6osS?N#V;Uw*^PU;$XKalrPaGKkE_Ufb&0-+`0`JIAD8f*ocXq_0Rk=7gG_YH2r;0Grh>jR#`RHzP^=DOt z?bQXRPI)p@6H;5(gXrM-E2uF=_mYZEOG-&}lWQq9Wf;$;h=_*9E3qe~P3(K7dQrHU z`Yj=`JYJE*zQ81nMZ1C4REIQ7i4>dCm!jJP?ppHYq(Gx@ICN!F^E=Y=+IMd@@K8Rw zQomS!vx4BLJhW>~hCdN>^h$?h{q-x-(NWUM2I*9bGU9A*I=9qHM=?IlJB%*7lHr>U zDi%yjaBJ;Ep7()csoRW$tkIK1^QJ8bWnYY;bSgW_l1CmJg`>47b#mE!NNT=#fr=YV zO2)aU-QiEc8g!{AeP7c;M`7l67jK36d@|i}o~*m@NeHsG>{t|Gn0a$6Hy50HV5B{z z0e7+dSfp&8g4ljYk+2Y61fEGlvao2$_pF8p7aB4$OPXCM#>^JFM5Q!ekZ0uCbkRmqJBh~EP#(R(g|@l6lMPoVkbpg@C{eYGCSmZkSon{gVZ^3 zsat2StnVWfr$*tdVN1WfhJJOT^SR5TAhYuy!4aR&$O4^;zv(7F?y93}QaUnCkiXn> z!`$2m`-n!h09>S#VM9!jd9hMM4E3SwiRGx`tYsQS#oFC*9!R5CH^K*J*$ZU{lSY^? za-WWrr^E*B;`Ll5NMl8kBn#Nj3vqN!yq_8E@KU7$(wtYEKAc@G7l=-{FjTctRTd&r z8jlOH6+R~FBbk(om8j;P|FKQzd8dsZrhYrg0WGF;xm z6kwQNU3-NTx{p0h+Am}jNjM}o@l6u+(9wLVzcTFJzjUHfo#J1ld>#+2sKw}YN1 zhVdvz-{Yf_JgAK2j4E*&ze?Bb3^VrEe=0tljh)8nT5b^mNV4~?UvovgVN0=4-~Kqb zs=?wQpVVoKr=GKmnptZ4`ddmM|42>A;AB~^Zg+Bxci5bz&Ef@xXT3i{m3ys0`d4#a z4rzAQFZeucs|Hvu{f6UKv#L^On_9ko_&+#m&6JJh%X>#e#`HU&Mh6j;y$QSssE*x+ z)j?PXH!QLZDb+&fem)Hs;b(-dzT*l@HV?x2FXHWn?1%j@nHRrqslGWa3THSWxb1ty z&MBmV-|uRd^yI7hh*&}{VM_tN40u`LD<-pV%B81al3<&rH46#(P6?h%^yqS%f3>+& zx?Kw{vZ5Cz{ks>2PPU|*wbFBBqw<1~{j;GRiVttw_AxD9yP&)uInGXK*so`LGmQWa zR2vd{{56%|D5KWvag6wFUu*UiLpNDsfmK|2b4|X!paJmuf@YJt~>vqeIvO za>wLC+bX%I-Wnj3xF-DaaWkwGtC6!~aG1>S)fcT-ua)L=Epr^2$w-Se^BepK&MJbJ z>JW+F70Yg4Kfl{P)P$^D(k?JA=1b^sq-}tA-GEKHV&Dv*09uh64@+H@>5uL&IJOU+ zE1t0D3!Ke&vY^+w4Z%q#9s_~d?AVYWp>$CmBu3}t*aH=x1C)cyahsxA>}5YZB5u+>$AZb_hUq@JpOdGvlrXbz zT|w>IL_==W&cZA9ojiCH?t^kM%#hIj(KheEXf^DqMgE;VvuW=Y>(9)36@>TwL*nlR$s%zXKBp67I%JBjbG_L-5k;y_<2$|jI_S-> zMNm17Q*m9In;>_hbKHPKIZ~G2n`LEZOI|rlzV8_?WzG*C*!5ogafojL$lPZ=2@6DeN`m4yEgu z49BYiWOkif6P)tN<9F9&XKLCQzoXzzUyt*A%d<46C&D(S5i(^CQFvfnPy%IKl<8Q{7JJp>{3-?`V&2ho9l5v=|lrD zO=ZJ}cvO=w&0^9|l)9m2smc={Q`M|80$|_OG!5zR-?7d1zZHib#;*^tBKm>?RtBTuNaE4P4&9{*(w^`+gbgA?Whj}6+5ESOb&&T) zk-~Yw8wH5zeFvuyMG??8gFGNB)4m48FPaWYM10a!T7Y#pNcTv4X=gVrh$1a4xxfnK z)Vbe^L^rA|;#gLy^o7xKkQC0UsS7=g$71(2?f_3>|?88ccCrU6>_TMJ`5~w0YNITe=I8 z3Q1IG;G#T02%!uK(3l;yTwP&UHQ_L`LY>+S_#)MHv=tGrXjQdG3k_(_QOa5p$SU3b z9zi6|Ym!{!A*X6qN|*A$ztP$A?eW6#xQXs2P^Xj~S&?mYg7d&PA`cQG zEI9XEF&bZ1A1|8jC1vU)4tMhn$m5&$4|yNKC*i>9S8?>(pwAQ%!g##AqoR!q6;TJQ zj>q$$-F{Ro7f=6}Zg%A1?%=Q9JCB?5k62J&vi5k5P(hJkL6}d=f9&&i=^uY6S{PTF z@U z?*%UN`X}>KPh8n?o%`d0e7NO_dJC@1)JAV}y|tv-H_(->4kBC8*iy&Rw6H_Ra&nfh z)7wNRo}?5};C1*v5yoN?z|X#+Uw>Odpu1bP@vQBQ*r7uzg3Ihfdx~sV0)^^qaD*x( zqoFaD>!NHqSG>Q9+m-HZ!6si;^3i#e6v>n%$2G8hNJ+!*3*rFGD35X`MR5w5+pIv3 zkdk(-_+773n`fFz$XoGcpu^d+REKbz-mGpXljEzIrqIw*;&Wps3x8H}gSwM2NTI<9 z_LH@D)W$}e8AI|?GICR9PlonHvqSloRqYzmEfNTcaMqk6ScgO?^y3etXk%3i|4KbDm9?{#Ssmn8r)q|S~QNHr!&*Oc+JCRzAeUq^lFqgI4+ zEU|a`N}}9-D9?mwW%HBwGmTub^NZni1MJ;b3w^`&?t$uaGmsU$_Kb~y7 zz!s!j)ibaYKkAGbJH6#xFj?mAnQD{TORvhY%T?lh6{pa`!>%8~Hv@j46?ZU3See?C z-C**OxKt9GCH8tiS4&H6iUV}@J61pK(Z05Q4$f8f)abCm**EIjJ3;<-YVUaJR3(qd zUc>qJXVH026go0cD;7giG$_BL=7RgA@Zni^>UJ{j@TC9~A`K;!eHd1?2H8HS0%_iimNpWaivGC3PXT#o$kc>(4`UPz%$vfne&7gB(38Wv&+Pit!_Ddi~RPmyk-mCRxEWPByIkEi99WYT3x15BRa(R6n>9 z0e8zCGI$)P`W@WT^M{L`yUGKE5)Weo9hb>6q&hz7l#Y*YC~bvOg`GY6io~@G(e6^yaVj-4wP?vWbCbAdplV{IrW^-<2jlS~Wq-%PKyHGn{ zMJK0#si$z5n!kNjc(=7Rd&_}iYhE4ZR!hsXmmSYd{Z1&63MzDiaE!d;J7nTLvD=Pd zmQF#R@Ln#sYeKFn#V2MHjTIzE>hRHCW92jrIFy+_C2BaoE*;JE^L)EOovHkF8+}u? zaO@+NGmI@REw-uKh1HeW3SLn8!mCy(Irnnj2^jxm1QAOri zd=*=wTKw1L>>98e4~-!EjKt{WGMwDV)#17C*k2?;EUJf+_UA(NYnd)8x9!|Fu@;STpn8+iB=*X!3B8Prvy#O5yJKVIweH57&ka3# z3PH0MMN|U`vW~Wi#Vi(_C;%vb65?u6sAixpI-;u?1{U3C15~*s)CN53dadYkEYPL& z_5o1xJ-!-O$570RvK3K5&)Blwqn0%6&6}p$FVOhGnk@~3uBcg^HI;p#o-S{(?D|fd zcjZ`j9>!k$;yUiE=R=XRlFS{9jF~-JHaTv$#W@`exRmv?1&15Z*1Ga!wiIP%tyv~= zU5jXe&qFlY^opxwM%X6f%~8`j6+-v(=JBsjEO%uC_qiAvoOtcxN6Jz29Qo_!#4tpd zZCaYs&2BqilUWhyRCdmSy}nWzNpY$FEm9u71vHe~q%K zVpsk=cN7XBH{c5vvv~*E0_~?vzc+Z!KDNT5nd}$4P~Tr`q1Jyt_cnPNb!NBf1Z|gW zpv27GmQzZWCxC9}8C`Y-r!VHRTo|^jTY}Wgmm_@gZ>-tj>BkvwyY3;{FQQfiDz3?y zFBeBp#+*E#r<#`$Cz4IEJZGaB*CBeMv17WR-Ru!Z>PyzayD4rcTE0~WL)Oe&O`)0P zGo-Y?!Kw4;JWRFfE=!gUpZ}>@<9j$P$vMohA_2vi?f%wAxBl*XRX5#P!aco>sNuo+ zv6vqJy&99mk87EXNUqLr>jO7fpCgRJyL8P=t=wfduh-VbefXL7q%NIZZn?;$pOaJn zjG?+8RCcOB^e8V1Q{a8C{v-oH)~n(ZfP!wfB}rp+B*`Y4)3* zpu!FBsn?D6S6>LK1G|EHMyhW6EvWa7+jJhxYK5tdyC-M2Z_J04m~o#i2m?sI;_pN` zI=&M)i&Bg%Ygq?&+ z6*Y=OI@Vk|LY4?vUxG8Vjw>a5nA6=rq#c?VB+}C`D zY7VWFjLc2KrDM(z3M5iWPjAV^d$bVWo=4ZtxI(gRi^bNA8zF?vf{ccg<#t;)VYz)9 zs671sOOGeW%ku?AsQnDbylxxX39g;QHLI&H`uw%LK=7$x@A~H^`@+pd0;|DQd}609 zQTe4#M|wXHZ)-m1i@arvUVIh8mxb3&B~kIR-JEU&;icPpx3e#RmwS(AnGHHU#P6Xz zT_dr^edS;0))u((L}a?HX@}yh1D%WbwFB{Y>9_bRzDmg>0m441+Mh1R&Z7<3$FY71 zw7To{GNKObMo{evu0JkdH=e40xhy@mHS#H=y2s%9`>Bq^AnJI2bTq7>6XkuPZ)aQ~ zZlrx|lm_Gr5^f!4Y5kn&@{n;hAhY>tMBB(@7-C|wNS>N?rBFmI7DwZc{>QJ9WQ6sz z+OM98-IZ|Zd645Sdpk;;Ndt1EreuP587uX8R7!QGdYtH$lR!low+wO0Q)y<#g`KOL z5MRIdy2B7W%Lt=W$Iy^x%A`tVriVo9{usXWdP^9VEpuxKD76l~ap?GX2`yTLu9G>~ z()D`u{Y(Z@{f&G=5cVysYYBOMsO#s++T>;Zs&4i$J5!_Qbs4-*V~ChwTc1a&`31Rb zKd-$NcvyWlNS1X$>8?{-V|V;BB>B8s&s2dwh&H=O&WTQs&|drtQ~A41jj`ccQ4;wnO6Gk>U;(B^+L3Q2jB@_iN_zcgp=9b)kER z$z6Q?KX1teZZwj$O|rp*sRa1elh4=wCha;KHcDIZVr?{#+};vhQ8J z4$g|(kh`*gZE$sqlPG|&{<`1F1?q?(Rwg<&8fezZ{nA;_aS zkuRfOf`w*QExh31)&TaUh89Bq_OVXTXBjVPd3EJ>5FjzmhNi-s`)+soJp-@j{fjb8 zoBe3PRR}*N+qAD!Of*1^5S76_rZ2#9@AbYrG>Hi%YiskuFMsYsy!TC$B+qqGwsvaH z!zqg&PDjt?u7hu7MH{z4^vhQnbwu~*%>#Xa_StN6qF9J`>FGhlW5$NG6;E7FIWE1; z((@8Vk6>VIW~y%Ad7M^J*_JpCik83C7bL(~ema~uEI+S=TiD%8&$=`Nb4MX^=~CgO=hu}^_7HjJA#ypZ z4y$D0cqFs`1FX)i?~39spiqAo5>>+Y~e^x5A4`?q&)L+ zSVUzRUMv-i94?Slg``$g1A-E83m!f8F3QFocqSbtIMX>otq;yGWt2Rl$8H#P7H#H+ zjfalvN!^yWV)g3TVT_iI`kk!1KZ|jQc@o}@C839=CEnYSn2=_KdE~W_Vt5azSs(z6 z5>(iABU@He<3jaCOZeT55BOvw_U93QxDqm@e|2Zb>3yq}L0!Q7*oZJuwJ&e<0-M3f z@|lvLQ>B8W3yJ&p+~$I?$f%t2yWP*o$4oq2d6HKR2U;&_Hy_wkiqziV(Y_n4gDvIr z5we`2sXpBnZhFb#L;smg6VtR=8!ZG=1d*hJ8tJy~)u5T#jsX>I`?JpsNgt-EC&C=E zL|Ab0@EQ}Te93rEL{^W6o*xjs0^~d}FpZ3>VR;Y*#)uQ6eUg(X(%_!qdR2gt_q0SQ zCVRY`DHp@*RwO`n%5?jNWdY^ho?o!!ma^SqYa-~*LJ@g$-X@1;YQH(1YR|t z=9#2sk=ntI3uXD{I)#hI#Brqd1d(sXqJC%P*yZ*Wi-oS>*-|oeP-pZqJCSg+~%UqImyT6}zvQ*s08P%|Y z=Iqc}IOum}NmVmtLUr`=$P1y`MpKrP`nX%_FirQ2bNLVx69>eU0E;63h=j^}-KP`P z{?-1}r1)(~_{sVaxgt$1jqz;D!3@O1@a?W~)iLToc%_{D;UJTQb7c|dwYWNwcRu6s zKvL*g;NYS6g%5Sb!MFF(Dk=hMp+YsewYNwxtA3VE zYEN_1BS5T<(8s6etAVS-w=(82{PQ)gI%v-i3u5;7_)eYyN6F0GXbBr;yK$)~)Bz25 z1+UFg24~5M7?ETV{C4s!Z#KTTzHdo)W&>@!tQu0!=wB(y2#?fDC}DAmqxxRhQ`0X zj|O!(&%A zG#hA$;G}hayBn`4$qWf*V#NS_DH|25iP01}X9#*Jh0nr3tlqnX`Pl^LqN(jgBT6h9 zEB)os+?< zaZ`dvPl>W&Awa7sFcXI1jC_{up-vxN}!FPZYaNZO9=x08kfAu z^S%ZI_qz`yl(0wDnk<;OJ7cswG?G%rT7P+AQhR5q1iIh|^R|#rVNwTi z;&fTwv&Cy|Fj)O)^l1|~d@RMvXK-WLU+dqbbAWnEQ=p0lzN)QS^rN7Er0=N83%&L5 zyhGW|DT|O=_}07cS>}+#t)U&Cjod!IqP0ig={_0o!Lpb46 zA#XtIbXSCI5Ef3JXr8k~Ztb91vC7z0x4snz%_Ck|dOh}rH(^V_683b%yKWAxpU9os zaW6w6iP7n?*IU&uHVQX0aFo=QJ-wx@e1}Ak@W4fqF($HxDHuy$GSb)M^<%dDeJyE9 z))bQteB1O^LZtb=VrXjUJyN(05?X3c!w+S^8=f_@m;1EsvO=oMT{|;U_{z@_e`GEc zx+su2XH!e=2@0~s6)IQMX$yF9Yu<6;<@J!!_CZ^peg|phK50&l_?mnwNPFE=9m11v&&dib|+{FMd-h==#Bb~*TNPI*GdTn z?B!SNV_4pdNnhPz9Ut7@x`!->rSKOAHN`7Ad)MKis7*(8D~f|Bg8g5l91#fUUS89+ znzi8VqdN2VyHrz3e;)s8c##>QrL@sJ-|9{I@dM)ih+N6?6TnMCJp2`29P4{S?6tAg zm9bAf+MM;*`*qm~2`(@!AGSdGPoD-PCSJviHesCB+U?sxgy!UesY9>aJqrABd$Lc5g^mtX$Q3i%H_YbR%86E>x1O`c6z9r>xrk9^<5tbB0KRf%f^QW?sB* z%*2sujie8L80wZ;l~#RDIdKbs*z(#%(0R&TvDzgTVau@ju-?Z|RHFe~$=Um>aMXO= zvstVB;Pc5a>PayG{r>^QlrLxsWo~41baG{3Z3<;>WN%_>3NbY@ATS_rVrn2fJPI#N zWo~D5XfYr$Ha0a1FHB`_XLM*XAUHBGHwrIIWo~D5Xfq%%3NK7$ZfA68AUQHNHy|J& zARr(LFGgu>bY*fNFGg%(bY(|7(5Unzd%0eZ{`- zeZ{lZFwm%LaY$Og%^-4cm@@}ACzmiFt)iv%1mNQ0<>cbx!D3+0hC16p{x)MV=t7(j zP&iEZj{s>W2-x|~CIfc9i&KHa03{bYfSVWK77*qZ6z1Xrc(}NP{u2my5(Z?zu22g= zg%ePM!ypJO25Gp1hZEGw+WGF7|2zWB<}3iWkdPqz?{q-Y9^wQw2g3jru(LJ9{_aF` zupOWUH-|!;J^qV=S=8Fu*+Ccta&vRz1luDx;Z9cKEbM?A)Y%%)gdiYJt`H00mta5@ zY!CTM87CG4pluCB{AJgITROXeogl!S!47H;fg$cPTwoRuC*baIKub{>P;-F5{t8z9 zD}WvNyEXtfC-*;ee`o(9g2H|$gU!w1_6}f}2NY%nSVHX}fSQ~#r?a~=I{=1R{0aoy zA>eoUU{^5I4s3Q8@cZUqKu%Hv0N)AxTOPvP3F_dC;6y;}en|xVqPeTGEX+b0Zf_5P zIU}%s-A@MU1TnuWy9em6&f3D@ZZNOEfh81XVfjmhg^L472L^R?fhfxS9dc*F`qyR! zaR&IgxVWBhaRU%X0OD?L4f;i|?co6V?fh-NQ{dy}0CxZ^??ga+pq7xkA1p5f*cAde zJGnr7y#93jH^SoP1}vcF&VU)j3JSyem;KHRvHT0)HQx#94j6FV%^o+v_3QJ`lhNIH zS-@d-9{+~_?k`A5S6@d{lkG3X|M;Y&;O>AIhX6mo!Nbo5aB~Up0D=PCfX{!^{8NDc zi2rR>2Sfk99M`{$iZDw!AoQ1pyW;&vhwI;C!Tk5iumJykf-3xOmLUN1zoT!+#m{Aa z_r?AHya2yb{{QCw7t8-`^#AulaxQjuzunBg{r?{~*dA)<@pr)8D7!e{t%VBwZaHB8 z8>$ESYn4?X7El-a|Me<5gYVWu5@u!hPZ^;IIjB3tLLKUCZvEE`{ih3e^mb4fL>-QR z{(9K}9Nb)7|Kqz`ICI;(7YgF8SHE45yM6laBV}RcaEo7y$HOlGfSsJc9$0s+zeD_h z7x&$UT0q=?k2V0}gu$KfQh+;oK7b|M3F}u!1)l&Q)nBIH=m{49QvVn603gkOkdPn% z0{@Hd^3484LIBA8AM{HH$l?#k3xKTtfcyXm`Ukw@wfzI$5!?L%@0jiXh1_?{usFaM2Ys3JCTHC{A96QrOY!@fppfp2B-^zrb-q3PNQ8C$kzBeD`Mc z;eNCRXl}q0opksm3tU3y)QUh{V2yg`SkpUGI30vYvI63KR!DA|>=x zqDkwI=_VzLPEo2wATdhupGxOPg%q?-g`yQrIT>lbVATP}MVn2Y-$;zS$a(G3q54t^*L=r9P8~f0`avRR8nR6JH@99R-yQ#0k|zR&AztDh{DKD{J5W| zETseNW^9c&EO8d}F7UDa9`l2UqE8|AUm-ozb)qeVR4p~QG%j8&2xcF_-PRv3uE#Dp z;sa$7mJ2rsv&h7VquoyRgE(8{34-UjY810Qdg)5c62c|-oB7nUUO$Vow$P24zg|O6 z@Lo)6FdF?ZwPdMvm_?M(&oncZbH#X~e<6WPn@)I{D-< z?&M@balUIhB(b@ory&?}zs6g?P?}=1HJqzeH8R0A&Id)O48fO=1=0w)o0W4#~ z;R>#S37MW{6Gl+0isO{pJR23QjiGqv^9ve}0+uGjRkZsKRVl~yNd~YK%JwHTa2ls zy$}(rFMFn;@6DjNY4u$C!jd4M-z2|=3ldbYKwLq=(+sEQY#J{9RzUR?38cN(*Nmu} z=VI)rG10ujE;;tdGbFTwaoXR1*;Ds}QV`#B0+pHe zXIa*Bh@ERHvgFU3**UA{A_`*fmcOO7&W;lz!BzPg2A{ehm<50Oj6UmgobRw%q1Q<# zV>YHPi%HshUj3|iiC2eU*34>W3BBb5g0fDAe9MCWQ1;RGg}#wWHNpB@5y--`!G{jw zeY^_jA__qxG{$^*-r0rTlW&{H?yoow`&~rh-+dsZW??`7GQJia=qG$c`0G$ zyqA;gjh`%hB;Im9ygW`>ok-q$j&#^)smfizHc@RtMXLTP?wAZkE7;&bv`dOd#yE=r zDrbyciX#!?$Px7%Lk~pG6ZH-%oIx3?rcdBTr(H(-M}tO6g8;fj zJUHR#ND-R+SW2R`PTb=OLK9;W+_s_^vP@BH?*X4R%z($HZ$35U+o)5%*6>yp`uV=M z+a7HL=$ei-CiFg_aGndISQ{}W=6iD=b0EQasmYZzTz1|8Pj}AE9hWJutXU_j?H=vC zE9EwzoK?~=n<%1R1QPMt-}lOaPJj66P*n577?an|{Saqyy(zxnmQ$6@e;mSz&c39Ih%Sjte$LvcP`Ijvw)C!3}q4++jTCnj*a~iCjNuMr?{D;>w&0YZwxt1!OX|gos(fc>+g?W zflcad4W*F;eWfMH(s+0qRwm0q98uK#OkVUKFf7Tv;_-9$9$(R~M&S;$3iUqbD?=PB zeNKSW=1P#c4?Enn;`X)m-gF#2ZK)+ABy?0DE3K|vyBU9S2)=x%FmLkI)Vn3Y2Fnsz zDXF(xA4D96G!@uivG(;!*H9^Loa!R4Yh72?nt1)om9_YHLr3{Y8QUq-NTH|TFUz`u zL^O2|f~RX4^I&Ts$Kq+CEE9zkMVEC1{AVU=3fhgteOdtvsEOB$F^p+0bZpEFJVgE` z{^!)YJsA?6_)?@D{c$Q5y;%+-rs3r3xQ|G)$Na+fx8GLSW){vn4yNvwsUw-Dg>PfG z$G}9g&~{W!_ihg=*UO;QY*-WzVNBPHDdxwkLnB)3FFlM^zG(8*?WmWy-lIuR(!6rt z0VhK`&Moz+i9Xb9y#;r3DLojOI`OWpH1oq3II#UbIvYt0fD1)%2 z7SPdK>_dVOks{yb#Rb)cxQWHIGD}gCPu?=VlM!X$jKyMLrctixnnlHGewT?WKH`@; z)oZ=&Z_?44#E|K1YqOZ3i-Nko68oatWrH`W%0AO%*385y7b(Uz zPilwf86vsx#!?E((D0r)AHF3U-dX!%L?R6@`~C|Bz5IPiAy(!-WfpSncTCZIx&|O9 zY`Y8p_Spa4LH678^RTae?R$9mqP1b~rp*#9cSBMs$&nIl*xzlIb^4hSg^YLHu=M6k zV)9F`Ir4gizWJgS0BWSl7eagSNgfhMmTBBBIyTZ`${o&{w_nPBy|Q1Z3>Fp=7{&Ba zA}0Tey++R|yz~jXX@I1h?7#qQ;zk`({I(m#7$h9hJOhm~-1?UG%?Fp=e7%Nz%(;aKv!^NkIch61p; z4ht<2AULU*Hk+U;b-v$owXigZ*~&gNU{j6se26zbbVMhqV4Hw0smZ(f0$qk#ylIHx z60^DkKvsz>39wa&x2QLhn2J+d{_GmL`$W!97?7m~2abG7Rqw&IX zC7tS&ZkU)7w~o$B1jFp{ug@h{DQhL44^>6vULwADUp&hu^QWgGNp9CF$qt>R7V7*` zvX^9b5y$J2a0sVb3wxL=%oZ(9O<|fU=etW=6V>XN33tM~-H{OtigQrgQ&dpx+q(f5{3MH*de^$LpQT$|nbesY~4y2Pv~ z1uWmFumrP%(Etm1Azi{VWt*IlkrBIMQKJFeaN18a6|O`j7BFTtcAiu|yv>$24*3Y5 zichm)LkBdDv0DlLw9~JfR^N!s?_Yo8CoQ+GZqlyKRDCVp9)7rY8XP#LWaI^}8N_mB zd`DYBzftsXu9L4`8^LHas7Fvm8ejUZED-ptk$bk)Z-)l2&h$#FKob zwu<`}Opy4DwKmAFL%tGAVBTHkg-TKHB>4~JM?+GIpBjZLA}xI&BgomWBS)*M43%`8 zKnbm)m@rqU> zo8xV#H;*`SDg5ES_)NTG(5W`$%pc>zs6^B9Kt)^H%C4f|M$i-B*ST)(Lh8s;llh)T z!jD>IX}0vGve@Asu!Uo{ea(kld|;Y}NU;@qyR))Nn{G8wD)$3bRseR<@yt^p34hn= zVe(11`m1ipnQK+2nbKpvd$PwOGo$`C6}pkz7jxBSI)k?k?}sttu69qdr7P0%(8Ja0 zdCL(Tb;g+A6_J04H)F~_OIPlWwANyvqz}yfp714fQHwAYbEH#A+}PL-SCaxwyQq8X zQkx71hsyar^X<)51t_|ao$?#KjJ~V5&)%tvx}O2hd~gL1ftM1ws>Tf`_VxB2fJolp zwq7s3d0Oj))LBb)*7Hu2w#jd{a#e)wi(zvA{iImi&kqVEI&dQR?35R~t+-s$96 zS4Hg;E@6@uCM8IssI5VXy-n!yY&w^--6E`1_$x2I(RnHeW3X<3jh)*K8xFSuH*7T% z)^Ci}&g@X)c-J9&O$L#hjeLvSiS?aN6RR zC27wMoi`pP9NZ{)jR|9)wrxZL^m?GzI88IXAPB?^jYo9Yj|s11C@nMi<|O$z$jpug zS9OMW_I>KIsKs*d>6Wr}TbT}xjU`c8b2q=Ahs|rvbY@aZ5xAq3<-w!}py(uQXwp{E zHKd6N;i$J{DzyIwu_C7LT5tzibh_Sl`=&PG2NHFqyleAxt%y-~`uPww*4)hX=YyA0 z7!M{tF=1xn@2aJnG;$Dh)%!aQHz{a+TVGYA7Gx~VK#h8*F)NN>HKGQ-Z&~u_&p`9H zg$*zRX*6u@6sNL!@KW3?*Yw*mRC!Uut#e|$^W+#_)EQ84TLv0D#>0}&9gkZP`;?O@ zU&^#b1HIzW+{-!ZLzYYlP2E%@__X~#cDv)u%t%I!cKEAMvY>FR2|8r|MZ53bn%J8E z25xAcC=m@)bq+GiSi+p1{)f{^W|s{wwebqRaf9;Du2i$4EdjU%J58at7X_Jv@;(Zo zO{hsCL@)4Tm3@+}OgA5(Kg^BncPpcJ&0cBT&Z)n3miz-Pm57ws96k_#o1EaPn? zb7}O&occsMtvL|*IqagKS98V5hE;Xqqt))XlUuqHGB5TBX$L`-{O#0{;V}faAZGm= zExfsbU}T7j&G?`nyS6IAaIVob!+4-CypR8r?O>;IstqIvrvn`@MTRK?R;(xVOAb7l+;&u=03p$(prl@plp3 zBmKwdJ&B(S+sNkR&LWZNs1!M*(9`(NkR=(p?N7H$@U=!z+0+&+q-EIvs*k)3vo`Xb z%cDTF7!vZFc~7z+2Tu0Aru(OY>6g`kpKFb8gURMFi&CS%zH-<1)hX-Sve6}|Z4_Ip z>fB7#k98c!i1QMNcGGm6*^VqJVEmkz6!AD0FiLDx0YJ!R~*#xsmcWXC<> z@YQbo4J$V_@M}+UE7?JQlCmmE1p_@F>?_7h8E;f;Ynml`UJr~zg%4%l@X{XVf(e$n z`-3s`2o7W9cX$NGwE>-GsR5kBdp zT8y1TcV=CnZezP*+qRPmDzih$+qP}nHs9b>=ZeQTjclqJx(5JhdE^6Z<|QK`qOBq_WujOCU5suH%D3CffMv!eOO( z;%0GOxrcS!B-+h}haO~RaikF)g===*B{i`mF1IxlQdI-{tUkj!ZQrMYOqV-tG}@D_ z@?yunog}KtXH23~#z?`AGzAZB*h%$bcoGNT$is#rVX<5oK2HCq;PzR=HhF!Surne||n~=2YjY zOg+t>V-Dv6EbLF~gy$h8W9>LvmhLG?Y=u&4D+0s6F6!dgZUJO%LNHs-<&4A(A1*^M zDw4no)x(Lzv3Ilq-F6PP$iQTNiG`|i9)@u7>8o#kMMcZ;BG|k8Ey+0D0?RFk`Amkv z=R;MJ{Hmb4|QA z9bT!S0ft^1d9q}5;asF&$9xLY0$2UB2*+K$9Sa3z=c0>H+pbAHHwNBzV!6PU)+63L z;6u8dQYBeL#Hn9HT5dd2_XKfmK>+n+-w12XHHR$G^Ke1UjN;Z;1j%YuOlO9=0K`Ko z>hyGhK5Gj!~~8417NdYm?ZE z4sZz~^f12_+_xnc_!`VJmh!zGvRrQ=&|di^pW004ZCA%)7Ba=`B58d`4Tb2?h&aDRqAt9a+x}&+R(cNa~?+)Gd-QE zY~2=FkNs^4vkxxko;7MfFl^{O_Zw@g;yDRRP*qgtlSS2H)rh**A+lIp<9tZO$wNGw zxRp5z#x^IQiM z#D&Km?}~&-0QRh_ybB$pt9PgP9xs=YJo0_wbfr-7e5H+;opP7VD^O+Y-hMVzrQ*VU z4RF!S7LaYcG7{4m#u6lJ~j+r;qT zVp${^L{3r(Cu*J_(wj?$J&yO5jBZ>=c9Pdx3=?~2QhVk(cdXNVhjzbE$;M$7=H=I{-__Dhwb-(E-$tPz2 z`hEq4ZLFP!0b5#YVse9-rdDD+`rVY%%5vzX zL)d$uwqfA%HD=uu6$<|++4!r;^CPxbbhu||uw}M?h!NVD7fnJI!F){g!ZzXeq(S_W z{hfNXd(}9#**4#Xd@$;ix)V4^g<|RBHM7?a9CrJyIc)@YO=)9$guembzaga=C~w2ZBb32X$trEJ z7;vsaS*cnl%@1U(2CW)WsKjC}0ae|xY6fz8+h@ON=SXl21t~B@G~?M{ej&q-SUNlj zNYe4+?@b)?RwHu=!&28(0$dG-`1A`z4rVDkiH1+iJ-2?IDJr-FD~cZ=?pEkV|t;w#4H1qct$dXo=JIeXnOVagGTT-*nIKb!r&B9%$muWoj&Emq{@?F!tEt zOF9*0!fV!x()x9;`LB-t18#=q#-301m}bN?bEi9tA~qZbFTW69@XlB>my{K^0#l*(9FgL6j{S6F0)bdO-eoL3Bl?M+3+l4O z=E8$X&w8nR<`l4xOky1^6lfhuuNV-=6NK~pfTgx^KHMoo=j=trc^}E^kMkfFL^X> z{1Cnh?deXb!b{rV%>;VTn;gj@=*rF3mbT{@#(g2HqB+ae$g zh^&^Xr_l08CkxVUiPykKOfEeHKq7F?19j_CY8R9XBP3F;r&>(C%OCxgEfs5#aV?ZS3AJ z3^0nW7KgfQ2Chb-=1Ov5o#0-$H&-9{R8$mP-p$RFK5RYQn zL-cw-mZM-4S@}SFF;aM%1xZ+pIz7+qOmH+Byq~NGv(q>+`Vwq=s=Wp7%zMe-me-h0Mn^IPH>7?N|_@{LJOhhft>HJL?i@vXou z+AGp_?5!fTsxtNJA3GZu)X)je6#WZkBzD&JonoMRiI1QaD7`0otY|vsPxTY#sKR7q z4Z)#{@(1ICF#-#)haN-A^RCblcM4mc(%`m%E9c7{LZ6NA0fhLjF~Ba`un%nvzEGOa zTbXpbzFUW1cQs8yI=Rc_21;oaDo^K{o062m& z{ANm?Uj*4S#>F8J@0te%ZUF?_rFcwb@1IPn&Zfc$dirg#zxNf5UWs==2TbEm+FmBs zTJX(`n|k;OAFfGPOHWld?3^Y0oGkx|DlsuKvags!L0M=!1bhVZ;m@LpcTp8q87rEW|m1t`o+kb-{y_mjMTY zC~p%1@dE?p-u>c_r}!s(^VQX@??pARl>>TU$Jgiahu{!Ig8=WZPdn1D*|F7!6a!

    {FMIVh537vNf74kzh7r0Ks zYqKQ?L<$59`dglJVF=F>(h-!f5cElT30Sj+@GN)Y!jIY>#FqoIZ*=;#wR3l+7dIf^ z4|5YJfDuCtr;G#h0;mpBSP+O#)WtRk9ad7WtAn0~q4HPE_F5J5c$t(lM7(0#N^^rb3Js~AX%rlLEM;#7S*i|RT?Cn0c zutAReZm;Z%ep&WcE%Viujt5-cp4kl{+WRi|zb_=g6mSp_)W1b4EbKk7;4Ba!LmtUL z@!rQyO`brIU*8z^r;m<74Um^H7NK7qAJlumF>LES5HOPM4WZwzAMCf+z`-HtT0j7l zKiwEG-0;UJ4+_NkkH?>xUHB_-#zWDCSj0ZS$Y^)q6Au%!7-A`?9FVCIYvtQl@``+&Q*JL5g5uNRrsK%74isOo2KH%l!HBh32{;HUdnK>GWq?PqfGC;9s) zGroWa>>)JkSuXe|c54J2?*6+v;HZ%Yq#XyF@hC*_M{ODE=~T$d|ElkX{)a~8_Zp#_ z2*ic|5!XKzAV=+9E+=LU)Cz8OQ?#>hVkye^b zchrjl{Jop-!}$y8E&4l_86}v+3n7Gu#AENRc5MI%Ukj(z4_Lglml^m=E(WA`|L5aa zxWqOxi|>p8YF!Aw=)M-`m_QmV+#?_!OAuL~6!K?aIIcg=DxiqxVdkAJs~7B3oC4`c zP;hqZr_?w7KnRc&xoxSRjdx-Wk8GN5VJ^s4zAjc+iMY&Td$X&a#yJhocYvsFtQJ zWGuUdf9pW~?}v?51w1|_i-Yv4W*xG3`HUB7i?z2V0yMzRa9HYl=vCja^078pgwSop z6|mY)-|QhG0-+`kX7ON|xaJY{zVBZI_@3rygPWMdK-V( zyt62O{$v1&0C^~m19 z!01)a4r@T6ck>PP{siMckb*$vBP)N%7bYRddif70Ok>qty0(QRFQ{m~6z1cBk5&9| z<@jgMN{}z`t0$yPyP$RTX)gAbm4VP=0+&vt*pjN1#)p81{dgt{2_9GFBBn`t#g+UF z#Nulu7-9Q1qPPXHc{ARl8+KydL4wmSm!E$s6HVu6DWIr@xcY=LvZf0vY@*@UFoGeVDK2 z;^ZKQ(VHx-UM(otDnT>+zpxu}qRespw zUFAQaesMl5@)cNBFJT`*MM>Y{LawuXKKUinX`x5!@&TyNzHv=Sf@e7Xm~4cE6ln>R zl>5LEf+0GFcMzg;g!LhfhcNYFzp$Z@!L-%My~2_8J-AEHj)biN@6h}%TitT&ruHJI zL39tAW&TA?UZ+`p|5sz`6<9XNz@PV~{ES39v;Kqd+k%oKqR6G!2R#jUbc_`6P2l#%F?KMU_*&cVDmhz;2|*nm(AS^v&=--a|$n3DLUVxusp{ zt$DznVTL}M_1xT<1uY>q!j&cCkX%8oCM{8Ik;pm1t>^^!BB-n*#@o&U&B+=ul3MJG zYk;WD5d+=7VBnozH44cR5kRHR82Ux&(K7NvuT%ZQB@%%>)`Qt!r)Ghbr&VvOaDvkE z=MGC7w?MUojS*R@_AlO-?Zfsm#CtjYel?omf;eyCJAu|}D)UZIpI&gKp z$G5Vyl>3_Bm}poD^qu+vhBwCY4#~jZjN$2RRbN zPH`iGr8L)>5~p|j9oZtPn$KAH&#}-ZN^=$apc8vy*_f<};QDAfnmawxl?&RxWiwJ+ zA%}ThwW8H+CA%UwTq)e}Iu3ie<>cn^`u!Uchh@sDH=FQg(M(Y?MR#^SE^f+`xS>KO znd7@A{A>iR+dn#{?RHb66PU4hHkMhYf$*PX&r^f^&drLELeG zpk&eatEK`Vg%PN@RaU{>z7btZ9M2ZKcI@Z_?3XU3X&8!Zzez#OEKb3p5kO}5j!8<$ zW3-k6#p=BW3yY?KN?2?0JM|V|>a_RyLhCrX6G^kI`ejG4E2#x!A)08Jmqa|P{+DXy zwp>&jmfK1q;d&=UN)87IMXE=L6Qjuhh5=)IC0jwjtnM&epSRPFT`ac6$#jQ8f51vm+N@iP)yfcN1@(@7bYciZbm#F*WH4BTgWwdl0(Y;>3VY1NY z$``_W-$p>SdXqxw8L!SPB!)H6kP!6vjz9Mf_oWgw5!IG4&mJ;&|ENd|i{JF`_rY&B z?7j#1d}~}eCUq%YzsrlGSTGY=?X2(9a{H*2YL{7idVw&>M~wV!wqZID7fA9k)npoE zA+PxsEyT%+0mXGE%a!(#bR;?!cbDLSxm?0FxF?dM;BGvbYWgwDDuiq3kI4LV@KR5N#%T#c)Z{=)O|W5xl+ z<*p$JMxHHD6)`EN!SJ)9TTytpNy@D82P4j|ZiHy$LOR{F7w&FeU#4+Pz1D{mz=d5r5@U z`#W!;jTlgXfGT&|Ztu7OYr@Zt9F@SyC_JV9>Wf6eFg<0XujA30kJ|P)Unrh?2tVJW z+dDH*>gp!D^O4RJu>BlD|8;3Gi8>o0z%>T1NQz5wHQQx3-bHcpSohrN8?J-khO{NX& z`sj%{_X+5Ggs`Efyehgb%N8}9D)NDbA8H;Pbqc`9ra{4+t|5HloTmS*147Tdup&}> zNxFaOAufpp{Za=5;Hbk+90`|}&1z?;1#}Ju4<^@<%(v;X$>D_tW3F1e@=FnS5#F4a zg{hI~Y_f4)gv8Iv@$cy9we6t@TmP}AOAB*r!-}Xn)RL;+xnTWU4obPIy_@?yvVc%f zIQUB;xT`%n@bE@S4zAaPN4s=pb#_yfio5YpX>!_)p5X`exCu!!FpIIikroxa{-IVtrA9sc95quZU zkRmPG_;vDmiLAhp)S_e#+(a8|S@QY(PR(c^nmP4qSeKo;fMK(hr?*77Xzu$`W&?PU7nsS9g zh&EpiAr!P`n?S#2YbicSZwpxBd(Aq6nm(I4=Y9KFh7lqyjJ{TTDC&*o?K#^fy7sD0 zJ_*lHm1h`4C^?Ww6I{516Wek%RdU&dWsv&1#|zbkMA_zehca^`=B9OR!-bAb^IpLA zITaP14=j4!;WaZ|9r!ks;6s-s)K;sCAa*qHtjDFnpipbi;;daK7O-=8&3KWN#_Wiq z-4cd8Er`G=f9@w%9}SYxdgA&#@(*$bjm@g}Xx5_$tTcF-$&O=FHgmgi_%H`bwLE({ z>D6QLMR9bI1X@O4RX1}!SxkqSPMdV?YVO7@H-#@&ZNZ04p4DxR({CMAgUb>%u8T8SFNWOQcx(@I7kvGi1VgTK#_p{R1^@dktPvmRn2 z)e3U6$4gM~CEfLmtvU`jNDJ-IQkq^JF`lmriCHgUyod=uZ=o`>Oq6K{*2h@s??ADi z9#(Iq70vRWlYTRqn`1dBO_5!t)U$p;)2<3ypnjq~Se=Xj3xpTP@BD3gMA&ec*uD^R z(`q!q9T)7Hz<@{bnC;fkcHKk4g2)Uota(z!D;wsvaVoW<70u9)bOB5vF6JKOzofwR zx;2z}f$^a;`c`C|lCaVA0)!MFiJx>k=}=S2M_#egtD!HILNpX!2pD)ELb9d0!0GjA z6fh|DfEi*)lGQrx50CiNG8kxKboZK+h7+wfyI)kqNwH|Je9y5srRuYOk4=jkwsq}` zhmY|;I+!}Unl>SA)ew8w12x%AbXF0YCwu89QTwnudz0N=&`u{K6evA&OPKMIJOo@j zLPP(Ppm%>9t}cB@%yOfSiV~=A%Z?+Fy9%|2JM$Or9(R@ve=q~Wq@-O=^1wTAt1|*b z`J)q7Y|MJOj14HdJxo7^e(;~5h<>x7U3(7&5~)nw3iYS3uv+>pXg6mzbS3!hf2FxJ zPh?okv_?hbrS-^!vS)^-V)Yy?dmHu=Y0W4w9ltp08CdMXG4Y?~75~92duee2Z0S>o>1Qmcm^?>>+|u5ps(25} zwsk~BGI*tqF|F1l+;nZJO&&Pv7AuBDcGgwriqrp&?C zHfL$7hz<&NNNSZybM_YrD{`OIP?}-vb5&MOzi>G~m^m{fz^~6JvmX`{uG-DH3D=T~ zx2~FuGN2SF_X2pXi=>aFFqHcitF-U7jlI48*ogOf}vAHKQ?r>P9b(JZS-|?!zu%&BGnBys> z8eCrsu`#iI>uwvq8FN;g;7~apSjVdUgkG#ou*)LAl{=1?r-~@DjWDw)Yl!}v@J?ZN zE7^N!85is{X4J@h7-xGOlig~Vq4%P=$kn3>5l=gJg0D9DLK)unSVGwtiG8o;#HS-5 z#B<9CU`oBb1&d<%DPJwq2_VN}RkdSH7*vB&(-P7QPt^lt95 z+^8|(W>XYO679RT!rdWNeEo|Im$>NSK~}OX{92=}1~8karh65X>Ah}@*U~`&D7IB7 zcknDzA7;>q%6M*Acr7yKX`~{RNP8$h`3*o}UZpc=t~fWhRxdFYx4Nq$Y0eMRV`L`20@F?A`N0ajmL#GEp_soAMJVcwzq|q%i^$bbn+D(< zb7>z;Nz~ymTp5GdgB)LGR?rG;E%bDV;nYy|ty){^$Re+CzSzmY*MjFF&H+v8u9Gi= zc){8`fgU>Wz)g?!RCL+ERrc|Y!5su_U(SIUUr7PKB!)yiO6f{`h!a)B5`lGfj*yL+?IFN&giO<*3OwoQ$fe@F~yT;xBfHX@aM#)G4$R8Ta~B-mLuDyf0Y+ zB{&JewZp;)h89+94XE-wP%r=su#nHi1vyig={6O#GV;NCvA(MO&w3uGr!Sc zf+WGticU>3I`-Mh2Mf9m_aT7nlF*Ny2?Z}FXW$mQIS+$Nk%iy`vW2|j@^&8OinC_B zHH^A}?`)`R-Fln4b>kovvlmnL`p{jlE->$gx{@7dx+XkNe!7!xIe}h(L0leMb8AQx zb$Ql34?I*RU5Wj1ttQ5ezygyx0qy~2JKCPJ()*MH#mh4HLT>|#5VP~lf)iOVh$CsY z`G_ky7|jL1gt}Utdo?U)bo_#t7B5{P#&uFKlEF({Zju=Q9nP6ZyG_n#3L~f{%PO{C zb%%Y=6QI`L?FyUhM2fl$rM5a?hL3Q|jc&w|2@@M1TF_=sAH#FufR)Z4G1w_kAUU(3 z?!!;1(eSdY^a!Zb#1UUl6d!@5%O|^TMw+#)tQQC0q4aDP4H&B@f|$HL6u`^bj<{c0 zqj{>2=wue(LD&H8wKwCU>31tV3TXjVD`af;#kbWGz#gJ>m63k6(WF*DCQp=7>5T83 zJ=FM`2*&LGyv*A%8)@ZMYdUnipm-mJmMPLb&q>?mjxZNO%S3O)XFlXNgVInE_vFSs zStYdn0_w#WJ&ZX2Yg;3^YmLDfZCXzNCKPQbFUgYU9HBui274dFE$Hqp!{^YtC_(7L z@!Ue}TWU8Nr~ERKVssd&nl=nqG;xU&S$8^LQFqV7^;gz|O_Rs`)YoGdI*Z7H{A7@B%hI8GZn*TWmnc@*L5UpS6G@2iEJgu@T-Eot9aGxHUmC| zf$95ADql;Zi{LENlW?ETibfG8-|QvAip!l+2m9MY06cJ#{UNTJ#8@+3CP+xM|@?QL;-MUoT;9^TugD$f#^CVR(mjmg=~;>*oJn8_A2D zJ0Iq}PjbPOQn%=w@3fd6H+)ls7;oU?d_=aZkx;wOVOD#4xEq{PEvnQCZ-kI7WX*8K z2z&ps3P^Gmf7K@yy7lf34JWrxy@rgfwEY=AxB@UkIDUJ&RXKyp7tDc+&04c{tv!VW zqXf2696un6*k7bA8+g2VJ5L?)j~Z;4p)pJWVqC=lVS zR-P8YXq{zM5(+zE_?YUiGHg_Sc zba3IxAsMeev|H{&u;cLnCr-+w)u#5$Ohus#Ut3GqM)FFs6U~Mt-&3A z-K^YKYd5EM13-@-2j$PI(Y6 z#9Lm#Ea?%XJ~L`hw~f2Z5}=roCHbPcz2+}}kqp0u@$`$7bE{MPW_N39IH(w0H9O5s z?dCE%*<6OUK{7x^@#?R*rF4ZG8sOMbl?6uULy~Lh1*5UvmpRifhYojhWUhN6K84b& z#!IRQ_mJjbI6(fMXK=5!HLESaZ{BNsWJ9t4`Hbr1+kUiZhs%yqOs4zi9mRJbgpNZ^ zV1p!bbf&o84KB?B?jStR!A!8&_uXDSBJ=q^?3BX|xGTJ)6u%>)G(WyH+RbSx`hi?F z_=aCYu&Uu)IE4~8LuFvpA{=qbCdGVanTyJoeXb#7>bq+6L=5g4hQAST;&V5}OF`MQ zx1Em^KQA2Nic!xP*ln;#(*XOy6v}gT@R{vx?HwU3BN| z@W^P*)u~mWb9rWGI!IMlAy-z88muCBs>wRm)|KSWbcsUw*=l5CwShJbRh-`RU-me2p?*-Tj@H~Ys@m>n;Ac*Fk6G0;s)xC`1<3jAX~^aw|^+flxYBY$^1xe z#o|%Y`)Erg$bA=x248<)^IMw?Sa05BbB{B{+qbZ8S6in)8=qQWuyLHV-@-b9b+!Wb zoY8W<npjiU$|Cn8KfhAx^_9nC@uL1pu=`}QZJfL51MdUQ5_t4x zO0LSpH!MZs3yh|v_$k||@x<0O%;-*-q{e_PO)R6;j-dLD+x-?!;n*=XJ+ znqdB$FJp})a%wg^vkHNFdd4jR+b?5S*CB*3pb9qaA`a z@LfHM9QQhtObwT~-@!X?62aZM$iDNQMkpnjM~`@7gJzT#sfe4mPS01#+Ki#u5sz5Sbg7#&@$*|K2jF}~8@Psky2Gy3)rC@b4vFi6vRdjVD zj}VX}A285p$RaQ;d|BOcwG{k3KFJlP=r^{2WhU6wh$1MAU}!H;_;a%uK1QZ6b)vZ7j_Eh7~Y2kdx}b@nbu7d zOwW5(@t&l1!?H-h^m8s~qVH8n+0W`b`S$;&BCIEHp8Vte%R^7$cgdmJsz%ywd@ zhkDGeO6#+|k#O?jT`6pXAtPKE$Lwp^?DJU0IeaYKZ=mJ9#jT564r@D~$z_LX?%5x= z`_BFzVzyc!l7q0e!c-n|?eqJk&{{X3EO2vN3gCTzUK@R3wnoSeg!DV6+v#~t-X*@B zEa3MP&2bjtVzlVG9h?{BG8J4kr+D#lPM(JvC53f5)hF$fu0|w;;j<(5$DA7xt0c}= zI#PR*LamW-(l^d)#+RIh`nxFa`)umZNLuZ_#k|J2A_KQXorMjj}~CT z(h3@e!0F`Gk2HLhiu@!!>Q{5qNn8NW_9cw>AkZG>sMy&GoQHf%IlZ$Y>8oR2-v6rP ze;33`-Nh0s*0E*c{t#Pg-8hw)ONO&y%zR~iEQ7K&FB{?!+hH?YXCaR{uLNob-dvd( zFKMDQYnn!#$RgC#>Z#laqzsy6uMXOghIJ#652Z)pTxu&Ww!146yQi0WQ?(rS{ceoF z$Dyp>NY46&#GRP`i>+gSCt#i2i^-2idObJJU`au$UTPx-O+P~w8rqoP#Mnl5yNF4bsAq!Eg?SjG`bS|%$3aCClyZ<%2vMhqm97Rf~Q z;<1}vk6*=W6%OLV_7JRWJi~xD%*6T=L(xcHM!io*a zaLVWD&OV6SssAe-UO+hmiltCk0`Fz!=ymtckxYH)6@1AS!VKt+!YjSW8MK6+RjM>J z9GBJ`8_^wCY6pWoMITUAp<8(^!ktE*dBN)S0kAoS#LxW`4_fXQ`r^QGa+w$HIcaJ9i$%(| ze{OhtWa7anAw}QnPqvq52y%^K2e^yQX?!s1It5KOwuJNMJghONY^zjG&fa5ymw{;T zg$PRtw=bWLK@`swBB`^_jTzk%`M`ZHdfjI@yH1hC!n-sEKz>uslIAcB~i+NY?x*#51f-H7bH;hy}+8hVAJ zUyARnMDefM8eFKPws$(uJZV~#De{}&!MlS+;S)pKT*V1a`=x4EQW)i&Y_x1*QKaA$ zi^999mKAVZe{jV7UlWwtO{T12j(k6M?18^l-m>M-`-!>((O}jM!yC2L(P$SB&ZjU# zRkg(+q`nD1v!X9R!EI4}`5ZnTS;x*Gq0f&`DrOTu8SIGlaQ3Dsd<+}*bTji#Su6`< z_{!UdqUQCB0KRw4Yb-&u_Of$1xvw$LF3*vNuS84tC+F;l^(gDOt2+ce8xE*ia?S2r zDZFQTdev5yj(a7xHkkH=8P?&L0|@ylGmHLN_S`q}tSmkFWqsUk1VZu6A6&`6$fK>< zhne`Y^vbu#qq-Eq_zu_Ir)3MJo8ls1(mE2ejAHnrFp5eitwqeIhFOSv`u8IuGnlCSn*Q>h5G!FyIGI^`9R2QT&{^S z6#6PqDrnm})phdj2krN=mq)mb+{^Pipb(N(xAwj_@Ig;mG|)pmG7C0ZwAe+XfFK{9 zyys}P%yY>q#fq3<-D>-cilYgp9B%8_m%!YX@k?_P)=TWUuZ@=r)2$KHPTJUW%}R57 z*1*)e*Ex?93-4kIQQ(I=YdSifEJKckp367$Npc`9t#)C|EKoY{+Y!7-|2q~ z#@IPIxc<+AF;_@sC96exaYRDAA`x~)uqdJ@Vo6Bg^55rVK|uMWNpoIG8Or6vgizvk z1y9tXMdE64^rC{`MS%}ue5X7=?>9P^JIT$iFFcP^Q-H3=sh!MJDGXnoeh8~*#bHDH z)!=+aEI|oaTUvxZ{Q`MRX|SP5EB_I${C{~>_uKrft$FpRsUHx^_IxDHE*Y$V!NaCH zOu@lHXe4y-ATr}1G8279K`@BKZ=5ifMBpUk9CI8&SQvACCQ3J?T9lRHQFt4(*um6y z0Q#O74A8*BLPFf`zW-mA3HWFceIPop8T{j@+AtALV0&7W=z;f78t~pKK7>e++Ch#IwRJ1=}1-oIMN!L7e@lk3l$?18}&j`5V70`zpE_*!>WY zI|vF^lwgNZF?W4yd0U_!P9U{j(6hEYM!!C{Zy>@xJu^@!;ozUdo7ywI@VT_zekf9u z%d5YAZ+T3v{&XAA;Adq!0S8?UNI(Jg@8BYw?MCNxnTwMPc*x%&o0hIo9=EuDmy&``sYKXzDz#hK- zllVo~*MEr)j0}pN(L-Ec1SqO~!~W$6_^w~ixA*6i))W$w1`%urp|mUNo~wO=;HNL! zmEG4fV)$r9g!m$f~4WBk}xA6-?zt{Jton>@#5+c&!;T`h3vsZ}vPsarW_Ubp|cdVQO z@+JIRI27n=@$e9k0TUCIprR%w)SFw%&)rWZz^;-WTmbdX?3Dw4 zwpY3TXLSe)=%*$xdRPhz{O+gFnZZ7Z5Bq`rattP2 zsyjQ7ME+b?b*tz5Y5M*ZfoI7Chc*g*Nmg%fbc=$wp z#VFTgu`TL*eZ8kD=Z1BDn|HcKGW-DmR~6NRt-WrS=&6y8(#WdY{_Bn^f`AgOlvLY* z&c0`sL(G_r%Z)o_bunp;=0d@&v>H{Y{1@ll!XY>gbhqz#Y8uK6l&Ljj7d052_~H!4 zh@3k%iG{>`SL$AccdV;cQmTp&RqGD?fiMkGl@EG}yrSTomP8@3qM>(EmYOVp4qfvi zGnGi&gn-G-Lc~*Mmb@#<=lg-;zq;|uFPgO@0OYBjyLQq&t7@g1$@SvrV(aW(G3JyNOcKJj3TN#M446xLPFZQ+z`4xjOO;F* zO=-m{9IREc+Zpt3l5?ls=MA4}JrWP-!&9Q9R5EC@5cT8zgI(Q8?VH=Yr!g-gNAcvT z2{`MAN$cai&6i+v6OK7OBK4L#MLpnl@Jt-o!1w)Hw4SfC1jdun&i`RJ?vy#0~?+ z=@iI{C;^j2CH(*@fFZvMEiIE9K5u#iB9|e=;bb3 z_+w9-F}Wf=PH@B9Dw>fjg0g&3E2vg=Y-k`C-`_l<0{Wovkz#I*NVx?U=2Rulx0`m$ ze*FNn97M|kNw){(TG*bTn&{6ojBx9sa&3Yxx5WuP$>PPU`{8(9t2UdO0r8}p#7ET_ zeyVC>8p#t!8smI>grL&ur8)K^;NV`JWDAnRm|D)$*QJS+KiCS98j>&q*Vosd90GKo z_;8HnXFDfVgomEnK3$k8Km4E#yBc!O%#k;9NI+WQlAs=lE+^HfI4VpXiOzB;g%!`Y zQa(|Vrl6axqOR{Yb2&iAhagsTzx4J(2~EN_HW5LOhmNDXNh1S>{ylb@gM2nkF{Jb= zb4lqT?R@UA&dQMi1FIAGd#>UhV*Sq5ZY@80+>z9-;3!Hz)h60HWVBAcCL&1jH3u<( z8`1qL%DR6W<5zPkGXF|ec5B!7uW9Z6v>lE?$;#_*`oxZutL(Wm6 zL!h%tg3_)wbq3nu7E9^b;{Xu9VBYG-xjb!tz zTmb!X-^qXK*NnecgJdWB?(B8*ayySv9%4>p8Ckp9QgpJ-d1PepY&HLZd9&7V__}WH zYFJH4-Brz>R|lYJO@R^N8s*Hb8f9cG=C!f)A^!pxzcZx*n{$3-3S$5u< zG5btj4}X~tkXZ>GKAR7^^D5#_p`=_AU|#Ni11P{;#)!9b%I%@yBnjm?SKy_Wsdw-rsj0UF96tEEDrD z*o^xPyjrPZvAH@zq@V9b0&DA6sMRf-mv>qz@j4N)rg9vWd~~EyzYXKN?$6hEmZ~Ex zU^U3uI1f_VDU^fsVOCV8%2K&;D(M(Sx(IR9cME~=kJP9sK2 z7KyjLKwo`j|EEoh;pz}PXVCLpu?cmH*z==t{X!;>`C@)DX(j^qYZ~`?`xXwTU(e1( zh4RLcNgB^lS4oaPkC=c@lEj^rr&j;1T&6fXB&0>z?+3ITSZGLD&VJb-8TYd~8Zvm@ z^nEMs_1XEReH6=YvI4HKu}NH=yf}I8QFh`kvQV44^Fvj-FGRb3G*W3U9G4|qCURN1 zF57m`-i!OT=2$M8xA!}26ZG_YS$@E0n1kNhNw0g*{`2B$-sLu%8=zXo{4^G*)D|<_ zepHlm+AuNVWC)co;x!EBHS!8IHzf`6-2%LDRur0hDqFBdhA-Hb3RloU$dri77Qebn zrUiapAuzsz80l06jgcDzAHTTUX@*>Ye~sgtkP$qog#m+6e?IH!Hq*oOYJ56J9N>yF zL&U=Om=Cl~{*w`TQRkWVK1lNy@nDW8A3qO8kt}BJqv4eivj{8{_r~B7GQSZ)JDI2nP-~_Nj!o^Qdmw>7;Xt) zIs~3_oVd1vi=CijQ>yB7GxCc}tK=i}lmLUy=udBh68Wp6vK^Dct&nk+Lbsh6f_0b7jD0MWHXrR$$#NI*jdWaUAr7e+8sD;0jZA{>qxt?qX{nPDv1+gW&=(^%6>X-tRpq=Q{kbE$@-yM`aI^j z{5KHm*GyhUDmS&Jr1-Z{`Azjcz!Jk!ZOwONCczOdGjJ>M$HhCOov{_=2KZ(*y zqmWb({Y?JsOHkPVAmQG(SSVE$n zTQOWfqA5eenoJ=ucIF;MKi;IwFAMTqk{pN^-psw0bYBvej^I9G83x*H~lc z>i36I)DZ|b`51zZ6?gd zT?n4cJ@n72+8gAxCedXXN0)GCaWkd7HoP?rt3`yrL4gy_hoLeEFS5id-q#H_*p>%4 zA*ZgW{TLNXCz%odUS!P{unzQ_OwN0D26v@D*vhE*;9tdsKj8S+t|ecEhUbZ?@Lu?2 zlv{WHDHmm6cK{xbHiv3;T^0Vt4&BU)xNT3{wWv~Dg=GR2k?BenKIX?ew8uJIZa(~%hYqU-%f|;29_CA0Y)g@qaZZ`jmqpZU z%KK^;f|%il1P|8TYX4rWFmHA-sdVI1>pJCgIU*-$$umeCvkb_j_C_A7Gt{`h&qdeK z-e8m}koDGA&h0nB3xBuMy+M-sN@|8FY7qMvq_jkeVn1UCDa6Jiky(NDItZp`1oot} z7kI+@jq`?m>Z3yrpZ*TQJZ{&Ges7CrqrkDq?h52?dzFbu)N#pUE{c?(*eKnopckqz zTQV9k2aV4fo(mat?lcv6oc*aEQLkNkXWQF&&%7*r9zM%_h)4y1{soT*kp3M^F_tTukFQ?c4CM-|OF)cHrlu;#bHu zCc__=7Cj$4vFNlYhTNuw*}2_8;87SUOR=Y2?-8Ka@c3OdWj@$7OPc-xs{SS6CUZV! z6E$4kC`-x5L^o14+IjQ$itV^c27I)Xq-d&-={LXyszxQ(L4Qa#SN4q%<^~Bw{HU6GF1=`)>RM+>Rg#gfB4i8>C zM=SW(-R+nDca`hi5#b!qe6wjV-(t1l6ZkaUsc#-X+ z`TkyxMx*{M+Th}cdZ=DLv+NuuWha!TQF9@~e&Wq8PFE$!rOFq}!E%RhuPtIQTZ1$0 z(G3&qoGW@%u_Z$m?0}Z8G(HguzY#(b2cGwC5ctq^dakVEPEi~FR*;wHGQ zt1^68xARd{i@a4oIaId}8Wq0qnU<-T1e_?ldx!My{iT)BklCFsL%nEqFD$I-E9##_ zbI)h;w#DKKrgE05V$7Tc^%v@B5Ozg=6BaX+ZvoFTL|eb++PfIfU<9U0zNYNbLY_SM zdgWK@g{}#;1WEc0cjA(?kgqeg;H&CsjT^@gc6o*>p7W8FF&ww6uYUi`w zC+W*;DNmT4J}@3sP|H?4H?Cx48xw+RS|erb_hO#kw=n zdJintGgc`*$}%Zg#8n%G&splm?w=MAn*Enn!YYVt5vWHx=_& zx{Ml^BD41{kY(?N(%5%D2#0wWC$?fHP>yr9JdTT{m2`6I$=IXiPi5Vl$z50h6~{i{ z<_v()jy2odLQ&|;wQ^j0@hUpm)WHiupGA8PTQ!ney#(L(lic1R5z{dRl5G5eZ(j{3 zbo+*$uZ5z(m6j2J$a;(~BRzHa?v_&&V0V|-5Vyo>{ye8b(OE~s5pAK?Y0z?RU8c3R z$-;=nqrC%Js!4~CRr#OM`5q*#s})-iUx)dlqRE3$-5HI|wFG9;S2n}yTcV0K?0sBj z7Tm?JHEaP}hH)%&o(eeq$6B)VTLF7gZX5?hd`3ef&%LPJuSD2<;kn#a`*uD zFuvINGpiRy9(I&#)viWn2;e;m$}h5xw47!ibuvILvoB3aGKhta>?YcuiD-VrNe=^4r z9~QMThlA2^lRGcQ)rm9^zQGRS#FJ2I_U}un^;c>Ob~c>+#8XbhxOGG3evr-&Bc)7I{r=5@bo~rJj3NY`*5fke29O-th z-HB+$upM4?0VVHgOw>51c}gUcRkRYsslU z6S+281I?^x*kQaH4z~$2Zmat$f}9;)I7*sN-|s$#-c!$>xTU8CuVe}6*qZ^m=6PCo z>n=RlS!f5qj?hmBVX7`iUtBj)w8U z<<9NTQ@inO!(Ce>37Q8z`5>tgWAfO;Kp;SQQ_O{`sXg#lOZ_OcpY`g8M!h&TO{5-o zPxk_CaP#+VCz98LEQxF!;r(RJO8#&=%&|;FZo7?Q4?v@?=Ki14|Bux; zIhdIK*I3QP~|EhcPysm9l{jU73!c(K`;_^J^aYp$W3u83paSC+ z1JmQ<0THR{n7cvNvVh*HR12+d&Is~U8-BY3@(ZCK3;r*vwi52FIg(KPz-W6{nIx za`vJBZh){9&CQp>EC>Gw)B<_d2;Rf78Ifs)R&h=qAyMfCjgX9BBi| zrx0M~5;Tv++Y8!&4cmqpCF^ogLGTgXfd~KgomhtNazcV0l{5hvvi0|#aSJCfL8hSA zqE207itp93oiR-I)0-kaKPz!fM4qjFnHot^fo;2c>;c9%29RqUXL}LSnA*aQ8Bs81 z5c(_}Gm2Q%q@Niv*~A_lreLB#pziolFfh=-h46uuI3w6^HNEvbAkQ2~&oE=m_pZ(Z z9f7n8rG>hU(v%(v6U$K7z+r@la|?FzeymQBp?Nz zCL%!r9Y_j_iM;{u{K!4jLVU`9b5=nA{&M5)39wKL)*%6k|8^AOym2642pA9ks!iPo z`fLp50jV~l3jEq#;M_+&2+1eR|9JrUM0oo-|JF?Vk$?a3Blfc3?c6ng-hKWVg=-04 zZ~r+COlx3;>Bg{zdUWpl*;FTdw@6*i$6&Jf_-Uaj=sSB#2-Ybep8-WVI!65r8O%8{ zvR8tY$AU5bl9URF2hkfufC#rH$uaEh;X0!d==o_VXhkrN{;uFEfPCHr6K7l&yqxGK zhKe@W9Q{{?0YsW;=s_aTH1--63Y16mnDt9&+y4?5=qQX-=?n=dtBA7?C5Y^uT>}^x z2nj#T@r#wN>53EX;1CjMI?)hn3BmdeP}gU0E4V!`1HwaObVl(VdkYH^sKDgv&_A}j zCddHqBtbGy`=z5}DG>k&2oTIy;-m_-^acU;`dlczFk5_qq4w6ys}1pto}@Qo{;gLa zLe(cZh?_b=H{8wN&y`_Ue0sgx;LRbBWxhy@>iFOZMWH>b+U zKWvqvWO=a!1|H_dwis6^FDY1>YRATJCbn96S+oFh>RcP^eUE?y zchH34L)O1%W&3G@LkXKq`WmdAYHGX)S2suu2f<2o*|S`x3^uacbpr+6URJ?Hu4UxxNBvWo15qYbaoh zwAfLhw^k8bX>*d}7wz-V>TZtOl2wORG#TUcfVA=4Ls)V;P7($SUR+HXkZhmSOtwSN z7bL#qw&y+fWhdk-AHBUSJh;$&DtiIk!Ki1+fF`3>!921qO#EaA)p+%%mK1F^y0EJ5 zYvN8wl_bPtQOtWZ*Dl;H^dtJL^AK3i0BREJDYBsw8A#9teR`!(ds2XcI<|ccQ^o#~>yyCb%YBIO zG<0{W+x0;MQ2CkC&dQnq<;1+h1TO${z~2+^<^IWEU$4H4>>yNXE5u$`7nf(3}_GDV>B|CPyvLaq_NI_uc)I z3@F}d80|yjFgQr(mq78Bj)Z=r4Y|<}zc}(8F38g#ArzX6lNFkc0*pkgOo)8@BzqL} zd)B%nRicN1@mhd!wo?Hq=b@u6N+U3-3*{j)noL+ddvqqLUFpyyd`1nT!3#grB`NC6 z3alNDu=(zH(TnVrgZ%Zye0p6WR-nN4p+hvQD-Xmft!v}DHM5ZE-0z->222~PvvDo+ zHr%p$rL2K&_3YJ1!eiUoX}d0v8h6(WiFI(p@4wIcxNf(JW4=0zkW|QW(Ed3oa**rR zFjAzGY|%Q*lod9y*~Nq>B$zl+*^MsoW9f13)Hv(5B`o}K`8UylOX(Rfa^XaR8L^&>Jl0rvNb`cyAuV168 zp;1JZe=jfYpk~_Mx+`M9Gu=wP&TG`|qrJ=FsC@d!Y4Z)(xtc-&vvX@f_{*Y*#fOsS zL)9~!Qnzid*f&y7SiL2}Q+_BzKSsx-*4U}p!1o$d;7Q%+4P{~2#zVy=U2CMneOF29 zVffgnQWTf|Fk&@fkkzba2~En%t)474sTo``>TC(P7gr~HR{Cno`-c!-F8(Cc`WAG4 zEq9;`pW$!NNcHx(e%81uI%*i< z`rTANP&hx$2|S)1j%70M-|?`7R-&NI6<>uM2Zvqz)Q70yA4qLfoD9%1u0ge|(~iuK zvqR**3d@yGY$Cp3&^2`9|ky6ydDg{tFu+PJV zTQM;Ht>?|vT<&|B29f4sxuDC*^7yJ;)+j3YrwgBf@HLZfEWauvSp%c=@AwW#Dc zfFi!crL+@5%EnlVE1W%-V`!!oT99I;8Le}3#I}psQ#o)k7tOwJO)YhDKl8})+SVyZ zs335M*v-}I*<2Cej{e;>@S&O@GkDpkD4j5uJ_r5FH38t-@S@gqBSI( zYA8IaqT6VwP36(=k?0S^PLUg4T`AM;s6s708^;$zf7Y~EX}b0Py2!dO^GeuM9Jc*+ zK~D(+`H<61S+~_pISH0*}>T)+91t3 zh)uiEXA5c0PaChnb)To|+_)$Hqk>~(m@r^!7?Eh9XwvOBq_p-& zK{x9y%h)Tlc+g#!!Yl8O*xT;{=Sz&c(hBs!r1$(0#b!Iy?~78nUjyj0rTz?eTsJe6 zl^ptSVDXv@?0nbEP0JZ0Iv#GdP2$Bz!w4{P>mnr=-KtmO!TE9p3D7p}ZfTbGj)p1*@jY z8V}4M=(lT{w6FGBDF(G*y>XZwZ|qlUo;&>yY#thtxmHO3aKeLidL4g)sHS0oRKVf^89TE3%rCa9z@_+_`3WZ_yZx`#HR_dA{3 zz?U;LPekvM1UpZci6gg6-o|rTlVAVALE82Mt?P(Eu(K1M$5+z193iJzuw{m`4tlM= z(cMqJtWu*>Wz}A0I3sbv;{E(+jUcMzwUi#)1{D>L?P=+H{maO_=nuhWTzV4U63XMN zLy9+b%BojW2^TwHg_*bYH~z}C)8n+eT-zRBc+ZU2&jV%jC}Ly&(Mm?c=)0!ZSkmKV zg7w{v+L!ZCsGe~J%FNP7L+GVUw1qD{bn3UJ4$Di&;wqoHK(jrDVgwxFhs2EQZF`mV zB6hE3xlvRX58(VD;=mg1p~F`l%;Hv23|VcSSG*I^Bm~AcC$h_xrE&0|UCxlPrIbJ6 z9zTx*#<}!83i(FtbKRx7%VbHSZ1m5QXT=0}uYneq3W7S0L%2r-Dh5%mF@A$Zt*p+)R>%#dcd2F7UjHt!9@lr0g4G7W>#ux7Ca8$7xOLrGb1 zTq@WLd#uv#&e@Skq%q60w`pW-+eKXg64nQx@fDd?=T4%t5E^62KcPL+8uVXiQk5sx z1FDLl?T!%1FA>UbZKf~~q6)nsu>jseHFglvA_CQ5ET|UM39=ziY3$kcC4@b#^1GFE zqvYE@k;L2bvG-VO9b3Umx@932d;eqT(>MQH4Dl4`b92Ar z+W6`(F)`I>zPj_uz1ftPjW*;^Ys>-Q_UT2rLjo*e575d{d8ajiudY|ELM2?0BfLNx zO*{d3&#Jbdj&9@7G!a)G89g282Kj?_Jikwd_<6HhdOm|I;Gi$O4YE&B7X9U0YhExT z%H^HJhy9%vIAIOa(`1K!9$~7i5m@?N>0ta30GuB;@64v1^YCK0@*gHoG26|NsYv=Gkq)mUX`wfxj#LqTPR+*2a+%@hi6!(8 zTrfk`TX7dhFaqrR%rFqt?mZ%{GU%|<3 zrBCgek18q zu2oT1P2v>h5q?C)yf5)G3HRk_c}Md|!c&J%Bxi?jNN*Z(@&pqf=AWwRjRZRdvN)i~ z1GG@TMP3@*%-R|MFrE5C8pSWE{;DenAVklMu*_aGZj~Zv6y`EvJ^b1Lz`u)l`^x(dB_W-=Q=P&QPjf(j_u! zE#V?^dF>`F!c|r~@i%@Z2Ps*x#ik40$AWA!#=RY4nI}P=@#u;6@U%E&{6ny5O+CvR=?Y#@Ac}_HAb0rBoD-ONL%nM^1Hr6clpG&akjd0r!iSsGr0vl4k zBTnXD{TJl-zpVTXESVQ04qi|Zi@1#Fb5V5Mw1Qmj3p;bv*HdJxP^?QHpSAk!M!-YX zXY0i-&_F?gbWHd?hvDX4RSZS&$)20HXiz4_kjN>yrAvl(sdx;kWsSMnolpwBFLh6z zLXa=jNHot;gL(CaF{sD(scUc8^RTh_I}E}anvotp>3!&Vu@%{1IsO(D01V7$?(ZKF z(|!HyHJ7(Hd~|8D{75sRgvGt+1&U*u2aA-L7T%UZ@}J7B%6pG)rZ)Jq@DNx|M` zCQ6)p0y|V-#7`8+Tne#`zKfMfW>+28jnI-*t(rOK5{~4+_*i*Dp4rhj65y6)oA{8* ziIhTqK|#tA3_aEVx9>fk?fDwXc3m#@u_&VieH`w?As)JOQ{E_g$|2dc_UY zZk4>vl+m^S_g-N^L4B7!URZUT`LJ?8B!%^ddf)ByJ9hB!4J%&3xWxLhOE*%lgyZ-^ zCr0dnazpdn?)(y>jZL@taS03CtV-GRJ{NT(Uo{?ugfCcmoq(Ax3%#-;!eka^(8M7q z5Z8Hp(r-WH4gNr9n?^eP*NTPv5V)!yXYE5KOAIUyZ-~_(N28~_Jn@biT$cj)uvd(1 zDe5^)5~tz}ZSBj)Q!1p!EL?tBs|1Rq6A3?eyvN?Qy;>2$M;L=$BwMQJr31LnmPNGk zufCE)+*Ztw>XzVIj=EA-A3Z$vDGinlh9R#s84J5he$bUKXM&HrzploonA$U@O1@ts z=8`oI8yVr3cQO`liEzMo3W!6A*((~XF~kC`7yO_twY&bW#LGEnR4Y0(r9C|Ne@+mQ zh=>OfuP-Q~(ke%-XMe$}jJm_`kN+yjnZ+faUWbFVyEA4ZE~`Xd$-A@ee-N&rc<6R< zo?jP`D+5xs0;ivu? zC|czS=<@UU2+syw36sHWg(04}+Kfjscc`BDh>iy!{kc2Yp~a=8_!iN%cq~eP{zI&- z64qJ!;!5vm90l3{r@CkafNc(E-n;9%cA+6E^m z4f~;q@u#-(`VQ3-k+0&aDfiU=J%`kg<*Z|T7jz8~n~0zOO3xtFr6X+Wq<3@;RTAdl z^^}+SXkvrhX01WM?kCC7-ubJ?-nn(^MLXsqQA1H-4|1pLX4u#|M*q=c`A!!%G~=z< zZ+~V`Ilr>JYY{ICKKgS|s@vLzWOHzz1d?LJ=z9Ao1%?)Rv*KEeRP18+ZU^E` zr7N?_PgQ3J&9b4%e}iT(r(0|2q=oB2in;o1l%m zBAKkL(d0-;;OrJ-Q$}Kh1{70ioIH{PZ1WQo}{F5ZzhdPOV=##u$zL0)4xqo z`}uUXS43OC2hnr$U-0vF94=xB_rhluv4VwXmk)aBONuPJYop^_!1OS)*%+2fd1w)8 zm$yq$Fqp=`I3zy|?r#4z78`3u#C_O0tWyv72K31jVx02Ob*+~1jre7)&!bPI8zW3U zH^p+2aa@tGTfGx%;Z3Fe2PfuW`Y%q*#r6LdE?J0}*;rZr6BIMEvvITiZ>;7U20 z3xTkQ*Eqh89?;he(Dp(3pl}Q!HjdCpbe@ig*VhK5AMpjbq=G^VW8kJR zO2)uro9iIC3FYK}|8C<8pJ42@^8LJl&1KGkuD!kPuzsB*AT1k1(P0?SAk!sbuw zNT8D11ZL$zLqWO!0FYdRF%0YY1!*fQD`}$>V^O1Xi`tp^QTx!rT7b$yas%TSgjD+o z=|Kgs)`5QPW5FYF^6i10-(?HTEg;<4oxwnMz*dM*^Q#xLqZ_NK=a6sH@bf9kpk6Hz zo4zKs?ifKS`gX%X4K0j*9NK!jf1tn`z82TVhK6QFcE(olO>GdEK(#@E2}{tm`|J%V z0u!sx34cqhD7ZU(OE5?f*^nM`h6u`Xf=EUG0gBn-`Ro*=M3qe7UyB@uHvN)}uL=nD z;x(t%QHAEk#m%Q*gFcUcClihnN^W)Wu=x6LuC~3>wd4O0H7C+hZ4}&Ka%-_zt^?=h z0zD@CY4JiO{vu_C3jKIL1v)b~?thmAar5xm1IRoJ4mt39`fO~jgHG*i z0C|T@1v&&I@a4wn1_IR;vCeHi>_+{NlexPGQjdYbF+pU7*d~5Qep5hXeGNOj+(0>l z`WpM-3c3Sr5(@r&Ed*pUsq*UByaY`BbQx>7S!ts)YmfBmeAlYzZq2~&jZclk8=mZ$ zgVr^=I0EnV`g#61<@WKiu|uFgE!R>}XwPt@rlP$=Rv-tB8JU z*Z9p@n^GN_drn9@);|r(poIpMh4M>VNsLjn5E==<)a3F$YE9%I$vvrH_9B zv$%f&mYnY}2eZI`DKoAg*xd=oH%RWC`;ITz-TRJz=X>wZ$RAb#ikY}L2gbhupKlJG zpM61q3(*|BWpERdjRgskr8fGSvnH{`(L@*jM1RTP7vS<5q(({=nk_Fv*s|kxM zOL#X;!ft&}GOkesfbo4_9|}7IiG7E{FlvUCTEA>E zJxkV>T(j{~7sJlZobVzazx|wVkRV?qc5jR+q~^R?=KFywx(C!Zf*cq0F%b)b_qhzC zyenldwhuXZek#-Y7+psc2CYd_K+c_Y4lx@rbrPK`PT(89Z05Qn=TK~Rsb*G?hFP{^ ztT+W=nVMuVIKmjo%1^xP-!4JgGGh6o&jYJY=K* zGBYMPGQ$V|M4<9+bAsY?7n2J&c^lN=h#F3)tz)T;3t4BZjYv$R2=(46Psnm*zRvjJ-SnFT z&Q!$5Jh5ZIUk#_AjY?$=SGbbj*Mfo0Gu^I72lD{F$5J2ji7a253THL5LxB@6Srq2> z*OdD}4p62%Kc_tkV%S+Pga)igSkHrJ1s_Ovseh}2;G&E#Jjr}H9!E5^B*PuSq;tfl z?Eo6tJ8M5{lXpbfe#DDK*-db3~oLpeY(9Xv|U4lYkm)(^c*tQw9Q7p+l(0F-PP9 zqdi09y7L9)*y~x#P9zpfKes48wclRab@ZZ5bN=&4L{lc`>?A(5+k)fp$LFB6DSzu} zH^aATdgAgN?J@yG2jRO9QVn?^FW6QR^My@xKgtL(r?J8yIf1)F1y-A8D5^D`qMF?T zyzhGqP`8JwzjpC}GSdJdh8xyVE-6Gr(rPQ+x9>2&6>nLUNj%>NkquRja} zOwLLL4U}$}W4zgC+~uMffWkMm5gby@orl>Z5tvuyDht7N3jvp~KRRdp33{Cm%0b zW*8}%&?#c$w-+WR``U(RSmMx9Di4q66zat~g7@53?@c&D_MfdBO%P;J^(`+9gyAe$&Cd zO-HItsXBYa?)4L{^dR0Uv#Fd2%dq6AK4G>N8`-sWUYY^Jya|XL$ryQdsQSukBD-`O z^8>~p%}`jTDL6`wgqH4Z9Umkk%ioN+RGgO#M1>%TjU|}%F9=(ozMcC&uyy}cra1PL zJ&3DH5sHJt16D0OU2XVLAnQDxM$tupFGss+g`6W-cc=`xd#MR;2Ru1UDI5 zZU`ptwUKa*4u}rj-W%T_ZREcnLWH!BN+3IQb08a_WognJUYOTVqF+M>l08b}bTaUH zv1nJS+CedP1lbD1#GDN|-WT3l2lWkJ%k^AToH`k>AJh}S@Shk0x z3&d{Ccb^o@@FPnDwGz6ttoH&!>B#IaBD?V`MdvQz=_`Y3d{ZkIld!=8E`pl*o>o$| zFN_Z^b9~G(We}>_k{F*r(YGZzwv>Y=D(D{1EzS)UqC4Ct`J)&8KFebh z^96p1~{Oa_5zjLCiUJ9l1@v}A|e$7%R0W4)vfFfy)pmHcq88nLY`SL92Y`3%CNV96E8>oO%Vx&d9Zrg7O)Vj2XEC=)2x99h=g zV7NRw7Heymvfk_^%+CNw62YPk$3fi2k8H)wDX}8cmDj>lM8Pdh z!=fRcUgiLdYUKD{#S{cr<=O?+7ob0<4$5_T1ln-S^Lih=45D@` z_#4GU$6n($NK~|!kG{T;l>Vh76Degb>Ow5y`^wU2=1un0Mnj!xxI2pEYgm!fh^7#j z8^M;yeUIkhT!w1kBT)yLyy;HRG3GR9xRS=W4>+V5Jt9ZF0DYXr$buQ+ zD;(y*d$_EfsMVX3vRw3;c&O&9xP2fcIcR{I;^`)%YD9(AN!$8;j-`e~j>ejP)t&I9QGxuKo&kG4M4o7Lm?UukwN7b->k_?8vAk09 zrfVUaz*w5q<`<54FkK*Fy@eIUlQ#Ea)u$A&n?Zm!E3TPY#KyZ{7jDfX<@y_`YOkrI zzkc&RD)30?Jvd}(GwO-anyt za^siSv#8LpozFb-n@$T53vhB!JgFNF$;%%*YEd(@4yxV7!wj9Vg@zRfHEa(mivb!< z;1NsRVzVR?CX$}5-{>Di`gu0NT5bHV6|3AW!uLjrq#LqvQ9;`VVFpt^3F zeA1GaI;6dccs*bJXdV%fgFZL-2nXy2ti0~~soRKkm zk!`h3Qyz&tTCAw6LE0#<@y7E5AK2BzsNt`}YI5QO@@VSB$wkf* z1j|;7f-hGL)CC)lAths|0_zp{EjH$-hbsxG%{5@{70IWs$5u7Mx=4(p)lL%fIo|*? zhi4nef?*yXXcLAKJnad;-YI^f8flazI4E~a`F%9$!8oJ+y&k583_yd~8f#el4+H5C z#J^G^Wg0Dm5f`10OqD&FpK0FFLynd)vwe!}ntOooxLAu1m~`E{68NZ1%vih|{SPv; zSe5ghyZ9D>J1YFajHI(^~Fw#n% zFAssDGNL1-#EgAUtRLW(%uQlSQ#qwglP5XjJO@->%*TJtu$#SE_QG)?+{vtG3I#a)VQTXF8L~S>yE8(WdNE;; z`B3#LPn3=>KDH3HIaCc{pSY7e;KNzV539(m4k--gx_7STTtB3{1<0ajuGYtqZ~GgJ zc3t@|;@sE4>}P0AA@n{*b!G3zfNxDsbADbph>_2y+3%O$UZg4*y^sKYD+Ky`ioXbg zXlSBt5Ebh&vlxefpQDkq-w(acnClzuJQ}to<9m#kJ|y9F_iA-1GIB{aRK73K8Qdku zw^!g)GmHEZ!zBC#q)#cKE=fGyU-aOxM>kbJ?xI1~wzaaR)M^(-wDfzCu?>~If zyFX0?M%Kzza-rELm-K`Ss2}9LBSLKUmYVBVF;4h!1F9O46x+^|!%lR?J&OcHeNonS zx|}+${2#{7sY$b-&7x)7w)K{cF59+k+tpnRJSU&r zYwZd4V|~WUJvq#%Yf;;bE#J=YcC&l2KQKi8_pcqk64kP!yNC*N><4*1zl6er+#os^ zmieYZ6L-U&jMSHH5KgbBZS$ZxUcV7WdW;kG>bqT5Ig;2se(3Iir*+jxF;ZPK5`%JF zPSCf2+$WS+kJOh0`BPz>;GI8_<$oQVdj}jaI5tO<7+#?>?Yz{WVHfsrY34bx?DMs# zn(O%7sC`rprd6f!YXTOFt`CrmewTlUShq(eo$3tl@NZna-ZM`)c3zxKb{GIun_(;z zo+uM^!K-|~f8EtMLt|9lM_-b#dDvtaV%MB%jVW_{O9WGH#409unP{H1A0XTXm$Yw~ zG6F5GcMkQJ5A+tsOPUr6b?AsR%Z`jt!MA+dK{tuDeG3oa4}YJ}arW76$$;wLYd2w( zOxV^?dDV@eu*hROIQr+;M<^oHb^w5V#A-~%_BPy=>`7k?+lJ*GzpWaPKQ!IN%!M59 z4?X>Esyn~rQ#id25KJX35TIxTuYWLLwV;RMiqIJk!7MB(O=_1tj9PN{D1zR3j0$!^ z<(#Wgrs{3oZSW-!Q4NKqC<*xP5Yy+t3~8lfSaO7$c?OPfRS2h`$ds zZf<2=q-{%#4xLj=o-zLH`ROTDj$k4r#JgXNGg8VR(!6tbhC9W?eFiQcD1FvF*s{jb zcZ`I4^wRKGJVVQTa!NdAz$xq;r=_Qpp|DOV-`x07>MoVbcpDkzeR4T#u zB>>JKp;%-l(MYAm0Z2ApFcNbh)yFbTwm|7JmXE}|>;LrJxa&&n5os-8j0toV%vrUh zM*V#i2fxC9cD8(DP3TboWZ;2AQf~#&zpyJ9n>JfB#UH%4uFCw-R7{GI>o1Qi10Ocu ze;n*t4_9U7mRfAoVu#NZD7`*r*M3Vga^z(d+|nXjUbR(pKdu6G)Vp`@eolNu6dL2a zj7_zVQB<^5Y4UhCtL9^mb{|begYq@fi76H}2z@`dgYvI47kk}bB&AB5Fz>g9&;GJP zP-67Cn_bMVxh0fgjRWW#GFBmbYJEZE=9J>$F$B^fuYDaJB(ODukU7of){LQ4ib5-71fn?CI=*D66m!&D(zAJ?Jp0Bv0)a} zr7tykoV6)n$ZAt>V(JiIvy`08*-Zh{-|@`}So_$IqK>BEaV6R|TX_5oCaW1*pP)kv zx7nq(JFsD?W7yYKrCQQxXTYe%lK1Hfs!0T&cgHQ)#`eA@T+HCe%76fw4$+<=d#f@4 z&2&3Ttzhn!{W~<}vfs4Y;$H3uFdMEB8TlB{3$2wOq8CVL4^$0wE`islV+)_~#pi}UWdNfbAuX8wD^E4{Nx-+ylwYcHi4hXCN z09<8g%t@w0;=gFcq$kJ=6_!p5T=NdtmavLZ+wR|Tv^a= z%uVYu8d8LcbzI>5UM8y~k8S{Uif4Ier4y#lKk>@<)qybb$7iIl$UPC=%=}~9GTTy( zB(1T*2rBEIm|{Dw{WemvUfWi7!W=O?hN=_o^S3(BDjF`m09I>54xGl?m0r}T^F^k}l_mF6P=-#KRi?*{ka2rBH^i;gJv@Et+-@iZA@JEe~ zkF%)QaI=GQ{3S$#qPs6q8;_JmOzn6pdSS%UW$~Tm9U^DYb+#WQWP(HZS#t;Jj1M^M=q?m$gxCn1Vl+WCOn< z*V?cov7d=12(?$DPHep{xa0)OQUT8OcO-WM9% z(gb7>jbq>--Ub}tFNy{)I@et+6;fdt=&{9f!~0CDlYDSLxFW9dZwn`~1=K30msI4Z z;(!R|y1Zs&S#EPdnVD9|AAqq+B~+=}wPFj!*HUwEUWOJ+dv^Rql3`+5vK8|lvp)G4 zBWZE$NvnK#1%Bju?W>Ya(Ri|SywLIFihinTcJeEFiIk&O7b}T_*IciC3aSxWNc*4j z#V+?9$~{RIDo$n+bFR|zJZy8ULN;pO<*QM3lcRczwx1SRnX)2hEjcj#7k8}njH7*u zB6avnMTxArP+f5`DQYcI$RC)sfk#@6O76Imwv0piHFnz=Nvl~eaM8TF>q1d5-$dNa zi0V28L7aDl?aR%J#wDVceXLeQl5MGe z^HXFqUsGT^zh{vVcHzvTtx`X7i)dSc^@nQDBcTLzw8TyB)KHCR0kMl6`f*G!72^KK#cCu7Hud;kw3t zDDu%9AYo{>1)eR7EsGyL6l*Em%G0QC4{&1qj z1+C86^RtDmKPdQ4*p?Ai-Td51y0>lIGoq7Z|Mh#d_koXqy>1goxU4ND>)I>jCO>Z1XQ38hswx5>7)bw;IW5Zk=x_bMDhl1TNE_vxPbjR`!sv zL9q*c8b>*{$u5=E-7sxCG3iCNKRrton|@PiK;?$dT-K7dyt2)-(5U@1E{v`P7UK!P zL+&L$Qk&1sB8CaC$5$9!VEn0Uz`Gs1MQwHbc^8JijhUVkFGJJr9X~XOB~sYeoGT*g zF0{%cY~Od-lJv^E?9{Y!4fF8GMT1tRf?*0!8en`?CN>T&=yV!VLKy?OaAaG{tB&*C zd$Qu)^<^v)^4XVrZgnra4qTubWNMiJ=6jOr`?Z|-*8})!&H(AY1CvGChr8_!s(FOQ z_LynnmEiEisS6^@ph0O<;u0<~C(GV{|E|>98%qbf{Op|LQ7+Nmh~=@W38{)|Jzg6D z?N15HuBImujCS>UM|o2bqUq4(20pR78iazM%aLsP*+N8n^?Exu!hj$^d;70ME)h;7+T4)6AqLrkmt@xP&d_`SD2o{Nwyw3}ce?J$lslsDy0+ z{H6`E+(~GRZ@9c@1jQuzCYCS9tqcQeTUmnYkMXgGpxEuuADM5u0vM1kdpZIAhaxSg z65fPSqb~(_GTZ%i3uPBK&^503#VwcV2?qeApYFE;DS8}p>WaAQ^SlWFr|u{7%*xy% zCx=m1pzw9G+sb9VW|wYzoe@5+exp>@5R3<_{=}jvWrIn+oKGh7MUIhtLVy<-PijAR zp!n}s@~OEMreAoX2Y1`Q8b+rk93l(>p{SdKpQxe_zplyl7BDXafY=9~<9ZZ~8 z23%0HPn6Wcq~abse0bRkSsz?ZuqVP0FAHAY4|NJ0#O&SD$kJ#oiCh=;3U6^1iX1h{ zU3r34W|uhF{hhQUg0iJ4y^-+6sr{(OH22pdquP-BJUij52+ET%UF5gFe*#{oGZl?1 zTgdv^NSdwA%~+;d2DJ^x=+orQ&pOTWXJo+WY>8{<)R4x_lsoFY{EV7711bA*QX(|n zOM-IZrCQU2)RF7gBrw5_{auRPj3w&_=*QU~ zD4nE2Y$F)N(h;L&J{#2$p;Zo(S}ZVcdy;F+$wVMO*=3Iq9Nw}}tTmm^O5J5JI=$?+ zPs5st+EI)<2?EEm%UFF6mY`WEi<c)jf}ijVuI8uXryt@DMG{W;#z~8F7iF;Np;?s^Pct0B|dlS7x4< z`;fVnT4}m|28NU+zR4Z^B->-@G2A0iIQv_465Q{qLbv*-*jMIZ&|??jj-(_Q$(ST! zx}yp9rDV&M^nF;jIey$T&1m~vN#3dpaz9;$$v3Zb>UCS3Z4XiNT5M~ky3fx(oEBP| z$887x=+01{C5u231d)(MteVUpwcXk&Ht{akMm{b$vouZ})XY4H!O_b4NAxJzuHP~; zkmi$JYX3s6hWZLuFBsZ8qmbQ7&_E(V4!~x_rb56a>pYKKpI{0%d=vMc3|3_oTT%y{ z^Xd2KqAo@;`DPtn3#k_g77kHP@F4d%=!@1FP>xTpg*KsMu%FJLkhXn6B{uAss+DV< za_`+njzeAF_@>!8#Cb^EuyA@xf_@~z2bl5xEH7^;z$$FxRuey{fPTAg+kl3X!gSv6 zJP&4HkzG;CZa13jEw8$yH{{ioJs<%t$Ymq}3VB@Zk(#&J2Ws-w&$jaFuNaTVtW3vR zp5EYSvvP0_+^>&8F6oVW!v~_N5QG;a7K|hQ9h!#Q3aq&fv26UJyB{$uo@5V1r58}) zKUth!BK6wi8I{CQX(fJ|@l|?T?ru?n^;9GYyCvG=A}9V->Xes0FttSM;*D8jiD3vU z7wZPRpwRuf!lH59LwM1%OS7^mAa8CY^*50qT_qY63KqXF14&T(re(ITa?dGjk8=)pB2#26~-& ze^@KD)Zo5WPlsA%!Ys6uVqy8t8XT3ul=8Vn%X^goOQw?b;0lvvaq~cSpLJ1Aa1E!z z>j5#UasF(hfh-p3*hpaE)w8B**%`N;(*0iHsIANwhu*Ecgqy0Zlc8y1(#N^`g36>ZyU!hjb>YYfO<^Kn9!a z2Ccw^3Ng#4x#V3=1@M>$OU_(fWH+^Pf9kuJC@xUF&6C zS6ZJ>Soa?5hWamGHJ2l$Dd~K1yF9_TTYEYwvAF!-oue2QsG;ve630ZUfD=Pu5;xQFN10D?F?Kz^4afADGfj4%p zeT3wT-|UVIUX(DP1?dA>8lZQB@)u#c7?m+REag#EPNWY2zvaKHNAbL*g!{o3LNk33 z#ykxa0_%>*F4+1pH3?>L%31_k1d7Ue>Noy&RvUJ?74Uqg_>X#!*vmm~#MLTmw%|RP zaey})f}SvV<@J@FH}AF<&8e%KrLI-fA%9RsDjL+4@LWc&hSJ8Z*gOqx1Q87ZLnV?Q zg^zNZs*n!eN&I#C?918j&H?x?NFL6-tz}Hpz7{F=m-&);7}^dEdx~7NeYS)|8o@&# z@}n&?gd;uAxK={Z60<#}Fo2dOSv*owYje5%ULT-fp=!9BR);_o&`doJ$y3orbzU&B zO*k7c*m{>h_tjfhBM@*L9R^zCtL8a*3VHCkVxN$#!(D(L>%i%Eoo|aQR$N)Gw5TX% z(XC(h>2ljq8slAX`;!CZREq8#lH`)r0oqCH2zb56y@M74gRuMbL=u3LS)v9oEHHVx z%KDitZj9Q_;b|2!i5(3?f!#*ejn9#^j??~D63Fbjm{25cL|TfLcF2!+(U|mR|AXI^ z4sn_jPzhX6M3PQ$5n{Vv_7nNs-Rn8v9YSv)Ep{jZI?8Q&Pld>Sl%nP37s9tPeJIt*tDD zV6)eduC$HJ_=%@XQ=K{_uJ zI4hwuqX-7raf;Vk3G8I|eNvaAAG{eKaBhKKRsKn5ZxIa}&3}D@>*S2k$5IYMCMrzV4`}19i#L+%6q1;auG^jsn^f?+D%Vopj3bSni=!4@7fdIvxzD~lpjoGO5he3~ z`<(ZsVy^QhqbDy8{Cz9uM)G;AaYL78jNAA(q~`=Bw5}gqunA5v4Kr0;+Og(?s3KX6 zYHFolt?x_C0aNK0&sLylbO?3<7FTSG-xnuYrXB=@EStk{$$aoLrt)QEf%F(4dm0>J8``g7M_D-@jS+pD*Dt^&(VSV^blV1HiEpc*c*c-%*Q#=>vObZhiTX(&| zSv&X?W-5mSSV+CG7)~m+J?3%%KbfYrc_i+6ys$k`&Q8=<&UU!(>z_CC8z0uS7Mvrc-pc*8*}Lu_Zp-X`LX{&| zUm7qSNnT-bjImde(WSX)yBMpBnpOGkB7h$nj+VOm=1>#V@6L+ti8ya}e95YQr4!im zmIFNudUb{$*&3+A-zOvQJ=T+pdkhCE-qp7(|+%2mvCLBL%8?i1N*!Gr1 z3_y%z*CI?&yp)!WAbmO28cpVD7EKj@y;eyAxcBeUaDu^d^uLSV$VsO4o4?bMb?(y( zw{}gO9iSzJ22#urGrCGbHD^6|nCtZ1lA2*Zr`WA>O{RcEFpi})C2N8y7z>OWLYIAu z=p!`FZElb6@*4JYwzCjudWvKO^F&7sTilh7~C>0`2Heol)NTaGUi|FjLr(TXfd?0uqx(0A&Olgb~w{aFZE*%Or zF7=2A7j+FAq~8@w0GOo;{R>69XP@Pn#CSv6$TcU@eF>h%?^2F18XAeCM%zY0h6< zyV9l3&NB7#_spBw*=A^V2-|F=^0&&-tul>2eM$SLyN<>7JLSLe-jlt&{Jt+zp^65= z&k*)xD&Q%tII{}&NtY3T8g4{l_dl~*qqYGyO!~KlUc};w%!>br4{%F(^i)?@3zO<@ zhm!y84=O;bufBfVtFM}BKKoA0O&z^Pp_kw0){uO;#19DU9q^%;n3&8Oo3J}Xz!fI7 z368K0M}dsEV#lhFaa5CC6|yL)A)h~F7ps*P+9^Ik8I^}cF(t@;C91<}X(eB<40y zbCgrEF9fMoL2lehvH{&<4Pmu{;l05= zCcB#mlworYRzj&)Eoc@=84SxTPOd*iBrv;41iNk2N?(gqudCL1bfgn~wCWG#Fp^E? z2Eh?`;35PINr-p5Hn&FnUSe_;*>EUirH*6HqX~(WbzHCJ2OORtN^g}{%}dWfS$fC= z0o+*G@V?Nral@44xE{!zk9CHGas^sqBFOtHXl%%U!50O=mbXoeShkJ4jI#xZO-*$< z&wx7WNNFC6>oz@iqN_i+xDegNs5UGpUu`N`5f@Q<3L)nS*;IO5_9j))?pl<;aXbkR z=K)#Vhm*JwZK8rNrUFM5B9&+#_2&%w(_84&dg7kbiJWOK9^ceDhXkoacl$~6I|1RF zs_D3W2ypb^#Q(CT656q2kEWn|UpA7py431>^KTI87w4g{Q^w#pTYWCfG{OoQ0nx&H z&fhG#PqPMBgOBLMgX((t$za60R)J3bOVwzXq3b_r9#E&H5V9 zXt5sxl?zXjm?fgXd!sTs8a962SoA#={=s<%HX}cFI$C4kyMCZd)dV)h6#x+lSxvI+ zaSGD6&GOT??eTxEPpKT@+z3M{eDss>$~oIb^<1yR(+BirSF^ymPFVhA6X#k=Q}zaS zgn3H3)tl|hKG}VsMDOW$02y58#e3&?1tRJ{tf$g6t>hG!c3~!{aPszEZtj!ku( z!|E_#|C~ms;^6uC9xBQ0yJ1u|4V`}R6M7++RCYi|OkHTP1q4ezyEkaq5%f|a5dX`J zK#2VsL?s^joY)|AX3CI%_goxia~DIu#fH&6?zvq#vArOm_cjxlw?gwf?G z<09=*t;cDXrt-DB$rFzo=5V?2oSU&oo4!N!YYIA{XZU%EudM0^EBi1En;TJNMA#Bf z`dQb=8L-{3l=~3o)a*#m%6zIuauZ8PV{_WAR|B}T-Xenpk%FllN|Jb)H`MQ4Ghc;u zs+d{0g2y3?2|A)lIXKH*jc4@ zhU%7~9IIM^u3Ac?$4aQV{je6;q_p#tmfkZ7r^3ldc+~5}Z^P^E?WP8At{duTHS=bH zUY(nrG~!+5^%UVae-Ap&qzh!i(P}-!;7J9Q^vJ$kd^3y^*U=#a*_V{8lV<8<2~{a-xRhl zp;S;ejF}~FV4xx^V`EYV{HoD>BT3G}bBF16C^c{xRmP#ibx7$%QgjD64HFxBL?$|h3l@+wQabn_N6!py3!>jXl2n; zX5&m?`PoD@Y5JCi4a1WMWx)?3-5r;GQi@W#NJ{BhnSK-p67Rm$LJPZNn8{$}5SoX4 znlH|b+A}B@EU4CuTdPrmvZcX;G1~>~w76MlFy|F+Pj9Z&VvD+K*hY28U?sUJIr>6* zsP7_=)f>cxg&Q7^H?hvMT2V_ouPNHk2(^ir0ZlLju-s~DG`pP6r4q*wQlq>kv+XsgUV`{*__?R=?4i%<4PXt^S zCpEkUZc(BNwUb5%yW99LR5U-|ko{XMpaqA8%coVTCT2{67-K~tc7LyuVmqv2cN14B zD9({;CNW0BZ>p5KUE(uu>-+TgK+G}E%}HvQ)HJl|t>4Z2FGBtWE*9{|$&M!ZsY552 ztOM74&d1B=E`7Sw{b8SYsUCG(c$ zyZ)u=v^4PEl$eB69awtqg+%zXEN5&S6!&&02uc^~dt_Z81e-NWk8AWlXRe!95joRd zLw!0NvH5hH6t+4)FAiT-?wZzw^ci7BSQ z+bXo|>bL|RGnGS#n54$o!FJI$rbh5BuW8hz!cQs4q|+2`qhhF-5LeCcz2yzvvf!DR zxl9m{YPi?-*5GB~8Sz9zF&AxqL~um^%4S=cXWFfr{Gy9rYq9zYFCeFjNzK+nIv`y@ zo(Tus3^$Is_eXE;rRrJNF3e1@zQ1EO)rPwodyn2GL^8)xawWj4G7rX_s2KUPpFG=5 z*#TgO5=b+{sDy$22V>dEbB%+Ct{>JNt_6 zg$UM=#tPANl277<^5|XBD~;w-E#ixUwy0HxH9Fpv+=op`*_m~F;->WM`|A25=2v| z$iVBEZ}Zym06*?XP}l7{~S&Y9XDP z!=^c^fDT%aK1!fHRE$$pWXNFPFN3SY=n4Wq3pdCB(z_!2Oz;DweC%!L_iQ0)|^YjkNV_mq)bT3lz66)b-zjTfbdOa|525gc0gdJkF-cZ4r2PJ!dpZRU_%$&d#~ff zK&D)LKu4K-`cHqVv-hwt&GpPV4=_dNYMEDCt3nzSe~~6ABuBB#*FI7YWaq7{uHHcZ ztDc2K+rU5m#;p5YXk+7_Q0F)t5Ut=Ku3naTpijI?QQ&XmrhplMgawCjj0y7Jo@_*G ztTS~_VR^Wx)}-6C_sqar4u}}wHNB*Oj{)2KRRNKm86*y>zTt87i_7obSbtIye*OUX ztqpJk@aEvc@Sk!&+t7`l{?%#sAa9_YfZFC!NT9zTU*@K6^Z;B|nEiM8x7(kfqvw=m zS-AH9>7LaixCXvE*~bLFyMqk`_W2qp07|(0ecL zzy63t|3)2OZjFCm{`zkrk>TyXtM@f0>+05w3c>pF;g$V`XAAwoHl;6v-$H-y)nmgP zd-fR1zp5dh8KfM8#rQG~vuxyyQc2KvTiIhWq<`pkp4`|M##n zhub>rQhoTn!?0I(?lS-5wMUA|x@o%h{16ib;@6))L^&d>-@Rf&K=wVCOwEB_Un?9y zLs3GVI;B80Tpu7d^Kv4+8#ELkK!Sc5KSYW^V;6*E5I~xLA@2i!0};LX3mO8A{q*j+ z5{LN{?KZC-b9}8jR_kW}sR?^;t*B}Lit+EoQz(O6%CxY;v!zEi(#Kx#P+}0jooQt5 z14wK%V|xBF_)?8nxz5sy4>~&U`6akiq;q*@wRApk?fRpx?urms){k)V$Zx55u%x^k z)7GLkxy2vcT0FCo&8GXV&ZebBpbe8}b5+)Q`P{jUXd=#O(T4A?KEmu@Cb3fs;PZps z9PwA^?3Z?OCZd4(TT@mBG(H_q(LPn8^bXUWFmJ}je#*BVIDPt>?Ek04_2mJU-c=UU zc{c!1GGAMrV8n{RyjrB(+X}mAseu3@7NEbGa`O{yjL2;P2W`^obi)#_wC+@uPUFgi z=|NsX^{AU=IWBO0gF1a=BxQ84`rKnTC86`|kz~i!T~G0MhAt3$XQa8q_Ni z{o<~qRm+@#g$20FnprD-gk;E;{c7qo;}+uR*%H9%kEGb^Q|-tIVL9-Cb}%I1UR>cf z1N7&(4=2F-+JDV~95zGTz)|R2c$h`qM0Tr}mr^jRFztEla(@Tw@(Wf@>kdfZj#3YR z?J?liE=~@*f@DRnG7iKipwRhJntfKKOhk={rQZ@!9sR+x9j;4Gy)KX$0pdfWem6un zR&hHToEgBbq?S?5@2+-kAhjOqKje_Vj*WaPlJ!{sVU3riFMiqNCNbeLa3m?lR$wXy z^SLvUqE(>Fao2R@yH`YyTZ#X*eJ=a>D{&|Iz7Ob;H~Kf~0<>BM$nIF84pZSoZeH($ z|75|PVujA!<>JEFdmMPhJ&WD@Uaih(Og;j9;xw5_*KGg z>s2l>r1BvreP*zWe-Y`Hme8t6aB?DABg2TL!M+w7on%x&l^ z{$&nZBp#5M_0!&N!{)20*q2;gUoz@q2Vce@f0SiKv^0{u>wKei0j@%;aXGvjy93o> zQP=0_hNY=uH9i26uE4y1+$z`VB%vY{X`D`m!b`-j|%X3JYuUqj3Hxs5&o zNI;5dy|ZS(?k4el@F;SkkAl4C%l%aQfTH8mzUWF}SR8KXv6<(y=8D}&7yD9iHA6;d z!$%_6>eXjl>;!^=^Gaapig54i5^&asVs1A?$y#fiydgVV zTb?ALpQ#t)J%zvK2*}D3X|VLydMbo+38#h(t%|-Inm(n8;VqrZ7t*fk4bg|;=}@C4NB4> z|ELv4x?)1=URt8hW}A{}Cw}ue)E5AUQa+pU_n*=cB(rA%8_8*(^>tH@S5*4jZW*IN zlGNwE@<&_OYInsX1o$P2%gikhonqPWr82}4Od<4<;>Kt(cQ6|(pNq=kgp9o6g_Z%` z)bmsJQ2TdFIk$pPHxwM_3PSy|?TKOjgbzGHN+Q_vMK3V5vag4YJjU z&|o~5%Op^DU;fHnnCr*6cQj!_vY0-IIyv}{eQ7arLE>AF$4e=S1@~7$=gI3e6ONQZ zUd$9b=rd~Nx9>VC)um|(Uq@1{D*brex(Cncyy}n&A3FhDzL_vJmSdRwA}V)KbzYi3 z|CCnuudn`>EX8Z9(|gubXXC%v&zj$he^2It$Q%FqO!$3r*2z2!+1!aW<(WAzy4+wm zYeILp-*XWtF(@l|Rob9C3zG@jr&4OX6S8?9=@GvI_-0lCTw|W^2;Dq=_pLhk1mW^l z{vLGuYX~i`=WvREJ__dFJKrm`_2UYJvs(N|uWN=#zs>I|f%^m|{aw3|_))*2|1|Cxj8a&ID zH%CnUxTb?Xv>V>X%qwtZ&pn?exoHA(kMc}hC_x5plrZ0W?iTeJA8zzg3f}4HDz(w&#}k&1Ut*1uKN6N~HjYz+pV zJXU~jpYSgPpp_N`S-7{ezO;5}hUe4DFBZcC=AGx54u2kjLZ^7o76R0Z4`ZBh77FJd|=fD~mv#MqKkL#Aj2f^DTqqsn^^3*BG<{8T)rRq66EiX(!A3GD} zSN#`PZ>_|m5noSrF`qNh%vJ+=V=mW~iPn$XOa63D_4agyx({kDSsf@F9vqa16SxrJ z1v>d6jA?6^l2n-V$`NP*i>0NM3fsk%59}qf&934{nofKFo~`)k_s0 zcGiNcA%fwrS=2>td!98`5(icNI1Q+DfR7Tqh?jTtoE^?sgs)S8SiqEKxsjImDs#`{6yPZwyOZ?N>&5YmDSeW>bbe@HUj~J1cd<~gtMVSTU zIBa-munAB7%g)O#59a810Lo5}N|j8_Y{l_jp5V(>VTQ>73iM*cf*^_B=Px{>dc50; zElUb4AQjRic>ThSJi3;HC4q!=lobuQ&Bg;hOMVz+85?C?ik%ZCU)_Yrrd4M>! z)ke0r0DQ@!s1$pWf8H;uaXg#7S!Og4f^?tdqPpr3-ek+`R)7;!n%f^$y_xvRXX z{O5OTyWDDg?9uwpC>C`sP$RI8nps}BRb`~3-Groifo0_CDbZC`h@NF`i;W}$~p$OUW+rl zxJc(qizX@SlBs3NCw*+mN>{*PT(Fh3)J_Ta6{HOS5)Z*~%~!EKc+n+%1N&kR#lBW{ ze=y`5^%IFK$1O8T<16 zcwQw%&2hcHXyJ4F!pFR7tKDNN9zNw@1&`u4=?>4iiI_x6ThFRzj&aohdneAj#kF66 z7Y4p_CBJ*);Ia!O&o&NHg{^OY{Tca5VMpYr$hGkiim}0*H33ykl>X0VN+8rIym~Ii zE|=)y$iuAoK~$o?YFtR&UHDVTMm)>90Op`Y?s&?*zF>GxJ#XXYfyZ}4$vM#%LFI74 zjBQqO856fd@t3okDl$z$e4I!#H>@p2Oi_*xW{$L%QwOqr(RoT&=#bs&!v(!`cfrd+ zof<<9N6~`78AnOvRm9o2EL$>nHsTyPNVp<4Izk&^YYG#cBC?WyX{1JC{qC>=f(ox@ z?Msd(9lr6Xzv4$XO*mF0YT^3Q{ON1gF}gbBkHMV|MsP~5P{RdkiF~o@PFWqAW)gS9>0I+94Q7&!=ln=3f~$V^)pP}-QY;W3hGu&%#&l+L6hFJVYyQ{?Wwgu zl2wbW`<@C{pM=}|3K}AaI~1a_OhpTWMd%~9&d|5q5k)u(ZxadDcV~j2U??kYrkDOZ z*={9?i<~OhPK&(XzkSJWz0xLw03r_eYO8nxJJrw=@1#NM-(!!RqdA@D6vh5cY`8<{ zDrDOA?D14-nkXW~pv>(8x0R!FTyg&Zb3~YcY0AmaY-v?bT&k-_IC}r(1g(HI8B)H- za$W~gy4`QkJUkTl`I^32-ICP*uADtM0WeEXSR&vzPHgGT>f zoZWEO*hzz-#Fj8>4aZGruR6qkC8XuG5KkUlR$J19_!GA&-j>7S(?z)Cx?;6cUSOfk zcQeA+5r>LB1vq_`aqj&@Nt_`On`l_$?^&P&NlgQDHgBF}>E$V(Ow*gqY2*Av8Zi%b zCNEfH&J*Y^c%Jn$Bv~4+e6SP|Kl-^ApM8b(tjZXl8WNtbC3($wiTOLC_v=<)!Z(kK zh1;-e5?M-;y;M#)IcyE!BbMZFKF;{JiThk>h{%Yevz3jTG6laU@-AXHB5Ez0XXgvf zB@ZpwWpC)aONVlb&IVrSIDWJa*I%g{RHl6GIkT2-XZP(N_oG}BYX-94cW2UQ7aTP0 zG0FB3LcJ$;RAoORU1%un<4+~fI?`Ea{#~XAn)G!hPM?6R7yjH!Z!Ek?W0$}o6VMX{ z^Wh808;%cN-or`;UG;Uq=DOr0y}((5T8jCSr{awt6AT|RYE$xZXT9$%Fhy{Y+eR@h zZetb1pD*Fws#%akNK`(zc+jgY$~PZi_7Z-uqC{bJ_%$>$`=MJJck8$;V`FJHaiO*g zR%p*=y;(lB*{F#Uw+7=V##0r%#^M66cwxE8q2+H*N;pRa`4*gzJV!5hMtNem1e=tz zX~;YGBCeVV-QyE!mkg<3zDfs;PRUA<1{rMO0J}W1(92*uxpc-yDIyWYwnLemch~_E}lY zMc^;wxGtN;$?vUYwzgqXS?MRmzw&@hS~jDq$w0Ur{JG@X@{&3Llw|z-`p~@6mCCie zN^D=p<2ux=X|YY2F`eAsWCUWCUD9TGn@1|iIFc2QlVA&hS6Y9Q3D6JQLt_l0Jk#el z92=I4-6b)Rl12;~=^FA69J_-jto}8@K`>@#`I z3!Z9s9`JRXgm+$bwD~mo4I%zHEQF}1h1?Yus~P>>myhk%bEOoi?XIku*TE7 zjuYTp3~6<7);@$hcaeoeSUi(wRpE%$0E4N6eRbyoF8hqytN|O~CtW4LT?l1Yb9rS0 zfj-vzbC+JTui5cF8oct)694ER_J00G`t;HuVZvBQd{|i%@~*)?YDb<}W7w6uwT`ET z5}yDW*5qDDE1IR)Jw`QA7Ro)7Q%N{!T_rNcr8P1LsPoXNd~Cvi40hd#uGO>BP$w!s zdObm+tlbcjZZH{v-QVIExQ8pG`h6Yyu4WbWGQ_|TN>gt9oeAqhCTlzcB6{oxqJIST zWE-Jsc^7UkM{?2aWKos*I9%~mVl4^27fR8BU$N?;qaNs`wrR^>iL`& z2`K_oQMUP%8fyQhw{yg=9zN>0&JhTR0d7rh3Swm0 zJL^_~@D^q@Pl45a(sBai4}Uswu2OUnnJ$nwE&W=kMJ2tN1Q+u9TIE5drN(p7zS%QC z#zBoayOfL3*ibn-#^3jXZXl~NNyL-GwXVKCPvjm)<0N5sZ8NVj2pjA8wo+Dfb zh{Z2z+gsafL4`z%fYF#F!^eBph>SD3V%H_YFC#->rH6}SzV)xds$L5SM4y{X8P{&{ zOo~&5F*!C1xF8AKo+3-u%G*q)FphtCppyBUP%C2RD7qU(==dB{h$8kE`SN{e6p847 z*T&C!<26efiKTvhGM@7{oW9(@-n+Lj!S_-^`fBo@}C`qH09 zAf_0ULXQr|fUpxlU&9*DblOqoc5GWF+mDB2+W(qkjI%VR1V- zk-s?%_F+-?^m@TIb0*?Z_aSrhdBQ?sm9i;wxb*X|o3Oq=n13elg)$n$xtF@CkK zQIQV=(cZYRoXL~zySjdg;$5y7xZFK&{c~veXEW7kyV(g+CbQwmUc(boh#iW^ z8vZ?FWlEGo%i+PTZy2=?4RPM%qDn<<>c=w(WAX&NCGZ1(w9|V`9{B3en zzT1WRI1<`H$XTsp%Bm9B=z8JV0aP5@ocW3^mG*YxnV#TKhhfEw+^Ng>C<%H5%ekQb z=gx4?v#h8`Gl9Ob;;N+a<22RpcWfa>i5Xr$CQI6^?xS3am@eXSC>G^tX?Z%U5FnyO zm;(}J2Pv$l^akD%5CWS(foJj3J_Q%-QU+NmYiF!mT>IeN!;C_f4j#@w<8XC^dfK;# z+d|27n5?V~UbFFQ95xq;n#)%?R8ZgNmI|QQ-CI({i7nX`Z=;z%-4rs6>s>sT>Ge1{ zf2bgIPUZ|h5d0e<*e0fFGx1H~EAjkrZxxW%M0wL}?J9vQeonkig%c$fJ*yEM{Gh7v zjos>f{hY8_2v_&XSE==1jGa@AE-;ve$F^B4p!%9!?f ztom!T<#aS;*?opB;wVR2E^`sH{BfK*2}4){iFum_09bNanTU8iwsbk3diOHy16Sxg z*r=i8F1sm`rJ*^HMTOUP&_90Y8V6o0KsP+ZAFb*?S&%k3ibj2upouR870(1Zf+Qxs z0G=0Cp`Q_?Kw|nmGc})If~O%Mr(>514j)pL?Z*9Tm*chBkyD_++m3r`EQmqBdN=8} z3-~g4sZ4SYt`_Vu(#U1@zHz#=u_;Sb3iafdE6$Q_-p9>-J0DYKsUAqkbGSM2cGQDz zN*HbPv@nlGmC)2suXFN%j#JPg~>|o8MQwjYr+^a*z=tqd{$g zLkU#=B(f(4>_jYq-`r6G?_s0~LrNSacX&$lzXYfam_B@F=L-s2zqWyTST|Mvct<{; z>tZZJ?z%rC;w6HU#MwnEk<%-Y@f5I`_y=-m>NaFiJ(;PDrseuLP;XTS;i!4PswMQ( z+J3^zr#(Q?%ebA(TJrx{8SkvA?G{S3T1$5V{4%fl+}I`3Atfbj zW2BVviqLKpxdd$xT~0d!EaT=}^Pf+S{j8DposVs!bgwAfG4nOB`=IE9v({5$SX9%4 z-=H4vL8xnnvTotl`1Qp8CEatDMmc*Qt<1=D8M4SP1zLQk#{UajORu zsbn5>cT(Mk*(>`&wbZFb@XIMY7}AUSw!u@&^iYVQJ5tfN>q022|7047kkqoPBIv`A z_LbkY-sCy3>2$}6YpV?}%_%b^Qj9ZjEea%xeTn-iDDm%(xOvjLpC3eq@x|gu1nqMo zz^fcgKqOd()ybFz6lnohb8}njU?y~6-3o17xORVJfgJnL=q&M?E@)~bDy3nxD?T?N zGR)PwbL(q)y30nbz1!VJliw~YI8U_P&RP-w>UgI42M7;QcG9|YMt#CIaG zfMrMFHe=8&!m%I2&g-n9hWXd4{|V({Ve$F$<{G|NHp5F^MM_7LpXV#GkI&M98%my{{g)!5JaQ+>qw=%MSUmB<5=I8tp z_+|QWy4K#Q_qGr5!f9ax1`;((1`dq`LK-t#1#yUTBVMB2ct0W?p@vS47lm&`m5iJa zBW2oT(RFP8D4`(4j$6TNGmUGrGfY&A`D9$pG7jq8H_)B{^vHM={ziw#>NJ_HN#Az# z4{Y?I0gybl%*A1q<_+AB;y+9Yl-rOM9ms> zWITt#@Mo^M`Ni=)u2YD!C-NIKitPPyx3w&lk?fsH&~xX6Dw&hK^+FS14K?QQiUI4@ zg=c?FoxA&g4H&H><2J059V-~?c!oLWaUtnL074lrERs&#mL<|GH%vAV(}>{BteA+W zKB4^$6Q)rz+l7bg9PXa$6rE5fNuX#*&(ZXy)*{23a-UKL2nnyfx7I2*Dnuc$%?^fB zy*&?btw&OulnKZL1%lD;2P==-qPRH7S;~1^`nMAfZg|3dZ<0`E#Y=hqSc9ypP6wCR z5t03wI4;nKa%kzk#GFUlEdl^w!FCg6E^uABuc?Wluqy7TO;To&?}0o&@GYG$4^ob% zyIQz%^bs!X2ry!Z!fxqcsct!jdN!)q62tW}J-Wm7@#SsC_4CbJjyi~E#x>C9^-F}b zjeq6E4Ur?2G8h3WpE~W#FDDo*(n8@mXZ6bZKEW8Hs2=+Gz0tQ$wDa_@Kf)YJe?egV zpaE1*urS{oH%rlUL6E0HIAR&i+lqP+*4_I|Hd2)DxT<>fLUSL2tzI)T&Ecp5=;cHb zS?CLV{stAB=sFMlm|KFBW=P|U;M~jWgufO`S?oJ}#s<>Gw%~2NQu5;Fq%*&5v&v?Q zj(nb$t>JuR_jGVNUk_i&yeR_J{Xyk_Bz@t6YpZ7XcHeNAZtI66YoZlqNd zs|Vgf#Ne8s_5Rrd+??*kR9n4h$pNRL@SH(@&bCJ9HYM`IM%kgvUyC1)MAF>9j}lHL z@v*R%D+#oOJQHRW?{#*x8e+}bu-IUo7?zJw51X_Q$`q)3aikvdcj>i*@vkq4*;{(i zn)n+cwyZrp6{VEqQ@|VZy*@ELK(j>ag3g{uR3R~}8hL2w3oK}I6eU=O1%?452AHTn z=yGej9blKmV;7Z-VILu`ox{;egs6`BK<~ga_`7nsddq<12vsE!j%m@%jh+XyAHDx3 zyI>x}VbP;Y*it3oP~TpPC7@x))<%j>bE-LimhnZ*;DhdiFsI(}(V!K3Vhe{0n<&kd zPRuwJ#N9gnL?3gvd)|6E^BSgHom8+qd%1{9-qM1doN~ATInR}E{ti>EfFJH z1P;a%h1`pMkcGX4Tp|@3G7(i48)EAgv%j-izq-#>z9?Bd?OHopzq@s zRE9eWk~<0)2dIVQCRGUM;q(X)Qe9@SbNGJ16tt3u)IT^lF!=Q35?n-pf=J6)2St<9 zsq}ZTL!Oee0X|1KCd!RG`Dx8XZ**~RI5abGaCJ3fZ~Dil0BJ$b{Q}t(Vps-Z%Vj~j zglGi%RACkzTSR!hnNN)`1;SY-I`O4m#HZ8Qlk2;7Gf{8l zt~Xx~%+&U;NBOVB_jnCp9U$$>%F0f>OQ2j-pi=|ese3gb_}>z{JJQWPgLZ7M9z5Kf zAapz9K<@!`{&oVA+tbCif_|{8=%*K7zlVNMP;ha3L5#0Km_RlCFXO-6d{IH^e}?Q% z5Fy-w9yNB>W8r(>S5A6<;C8qt`}?++A7bBjBqsCe=*y_fhHq~Yek#yV0k=SIEDj*4 zt6ZEw+IYM`w*0n!H$NV4c3(ebUv^~?)TcXbUjsRnT}7aNH+tlqS6ja0_8+c#v)`WP zr$9frLSuVX8U8@)0#kOq<3pC;&qL2Y?qJ`#_dhicKlk@P>z_Xyq||C!8$C~rKg_Q` za~bRY)_gxUcgs`N40efmr?>2c&p#{5xUV%1s$iOa+E@Pq-zg$N?Pq4N-Hv%sGX%MD!d#-VTP;qH5e&)KOGv7v9c!u7tYQI&1cPP$% zNu}2_c+@}HJTA32fs~k57g58Xs(M!2T7kB$?N}^z%+JtA{oL*0Psr2loZ?|s8x=(EQO4Iyhwzw%n#&V9pBd-Lx?xAU$3m7Hq+kaxG7 z7XKUBzV@%s_FHe?VR@ATk{KaN3rpn(XqS8 z{OZgc{0u<+^xjj}X15D~wM5Uu}BtzovHDce&^2#@g!K`U^3T<1fQc zF9+<3K*vw>`_0MN+9vSlOyxF=>jz}F$<;UH+78UiD`dCI=^MxQ%wTFqK%ZUg*v{Ye z4bHF7AD=cqLBw3H`4=%rfIm{kdt8lcQ@-f6Y=;uzaj8qw!dYr(PauyD;q0!`sbzg2 zdoM>mb%FPdsw2DjNx;2dpN0g*TJuK6#l@Xj*cWJe@Ck^zqxHm&V3uO)IQ-kdIa6E1y8#R zp2?=`yQa@Oi?7D+mDKJdc9MDaY0Jpf^g%#tB4aZN-rWt~HbD+aMy2C8_l-}+8R`gE zEFa?2be{AWiyAB0Ykm^kqpP}D+7z#H0rZNqdL~2|n-{(*QW!*+(|Z9Jtzx=BY8Jzb zF6ZwD%Ex*4Bf_rDt?&$9o5T_shn%4jYIzFz~Bws#nT-7veVb)7(#k2lBCCq zhBEu1Z1EAFCCMjftum9*zZ_UT=~0-Y@gRXPibI4VSA z5nCjWe6IJ*fCorZ(iyCB&g>>#i!Ae*E()6NA7)+FnmNQP7S}6)-4v__whQUOF=t#9 zL4&MLlF4##7uv&BF_^`<_KOa`j2#9d+(qr#+(gyT36oW3Nz%X#SN01`hOq<d1KYV*5@f2AjrCyLLU{0e2P4OP=-0+$l_7WelTYqA%Uy=;>(fQXjVBrH zbz9GKa@#Llo=Z%RFMUjZ%5Uy%T%72fii$+=13VHz|h!(ZKD4f+@ad(DOE=joXSvTrc zi2}Hlko-o(XZ6$>O$sS8#~-K>QxZBiRby=9 z$87>N32F$7btPD=2Sc55G*dZP7^*=E$oK-BEY>AxY-3wV3Man=RyUmL>|7ao>C=q} z2Rj<_26?yS@a(}-kH&FA%p{&YnwK9&m$oKzns&VC-s6FeuicW)T{UE@>!;Wz5G0h8#jH@_^1g^mR_XmL#jo?nzS3FpWj##@iRO{?iT;><696nHNu(Qtwv*3*#q*h-~!virsFV z^PcsiTtp_8a$z#!x-}K*m~ZI_JXS?1+LyF?Ppsdb{HK=akTnvL2H| zCl~h_0=|pYjsz#w&caIfBZOS}R&1S=Uq1V)ZD|*6>mjfSl%*Zt zr0k~ko^#5iV=Jrv?#e0~RfBw4z|xwwT%OGG;(<5WuXqsLO&zvo7HtwmY}A;g>S;!8 z%M&oC+UX)4JABG5#e?8aH*J|QURZ~!Midhvm2aNcJw}~ohlaWsLuJPv2ruF`=UzN36w>RHj&@9NZ>ue7z6+ z7lTfjE9KrDV2hY0L_ybLGgjg*k7&d&AGX!nd2{tUJ`FUg2Ov$~Y|~~wIXtzTiKS#> zn+iNG)dblYs1+tH{oLXKI^Uzem!(Z9r4@34fu5Mx?(?F_M=-5bD=6}7fG6{P4$-OD z(6-4nFV-2f4*zC2BW`v2+#7!u^pIHITxq6D47!Jl_Bt*V3Y6)OWBRZ+^!A(n_xNy7 zFC9y|4t0^Yw!wwVgi6q&yCz0cIOR$}8_f6U)1G-4w+zP*nCSb~7mf8MWDVR8AT`5H zE(vDVN&=?XmhX60l*Ua9K{u_lp}1L6IT=zy2lq|a)NNOkP&}fgvb+x&}IUvOMp)mr^}sn3nNf zbClaX)Iwfobs(}oPdA39S-ERp=hW&7MK&8$S<6o`0S#NqDDK=%wRN-w&hq-s3%*qD-)Dd8wEZ zrsPehJP!R%{F=H=Mq;J^v%2?OC4IWXT)djk@*>l?5=x`DJJH=^S(TquLfh8=>$a;p z7jUmH>MmXIZ%gR1w$4of&wqXrRaEwjwkhDEdcmgrP)@t(Lh=kpzXFeJJOvL+sB+%2 zi%7));Zt-CpA0&938pHxS0vJt*mL$2o|&n~yyM5WOi~YLTkqHRj@?`EO5skZKrZfG zbY;C1(e=j%WY)*%UQcD5OVM?}Ed=eur|L@HkMHQ+C_@#_j~SBCdZ<@I)25~ zd`YwACE_{4i?rcQ$C|N^pR_JenHa}Yvx~J;m59TRRm~I%`Ho9v* z+}P`ECqCQl!zeXPZ5FEsis&89=YLQ=4`n&n`j%RL`LA+W>{*%nQyLxB<_CChzDZh<^= zfPGgp9BGt7>nP|wJxv0AqX<}&U2C|)gb?3n;S}$2P_HrK5b`n9TUSmx8Yj>prCPkj zd$i2ZHiV}Y^avFxpmT9Mt9@ehKh>Zxb3fkeYu~X;XR>mDnb`n%yey!tEIXzNHEJB= zrRLSqeY15z3aMbd0P6^>hyVD4XKNeeNc%rP1rTn&wU-vv`GvreTk!AmdXP$63lez- z{K~wo>YSLnrr{zq?r9vZ#wq*|4pJX-?~E@^$3VammkMML7|DaFaq&DMrqjBtTcn>I z3&rdC(dgL1nXhn?Gk?gnt8obrCE0xVlqttVcLncL&TN}@*INv|GoF3QjbKE7JYM|% z{gLOssJM4ZxMcQI`a^Rv7uVmx%3LD;X%vY))9X1o=zOI@NEr}TS@y`WWPmGSC%UOb z^*g5zWR;&vRw}0Q?3CQ{U2PbUt^71n?r{jQs;4u~{x9k?NRM6h84G8x$v+5oCvyTF zvvEHEl;(O~sm6n2kM@wkxrt$2p4E zj%$-fdW%=a1UQGwG7+ri+WSyu3Az2*^5}10DCM0lR^DbolyE8-rjQfOIEQUGk51ho zY;ME1rY!=tJB3KMDd(B<65o4(&*J_Xj~2|-)d^OlRN%P0`aQxRQG|RmXc_s!o|`8w zb4U&v@)nz2!*9-o6g3E}1`Z+ey><#*o5x-g5uFgMlAQ=>u}Auxuk~<`PSp+Y6+Te5 zm%*O!prSL35ac6itmas|)ixi5jD4R+6@Icf<7FnR`2ltFhlxR^V2UGY1t zX)nRg@QHmVY4{CSO40<=DAacxB*|gO&j&OiY}f<>O*yY|tcn+)P&)NltUu8Hgz7S! z5gZ~B-S8Z^El`shlQ0{JMzTU|NW;U}DI&R6)#0kkyg}LuVSyNTl53y)*!~H2z70W_ z36YTSshXcWo6V%?xMifhW3gW9mA-t5k?d}-zrBAKdI?01(gC#OpPg9Jpc>!O5DEpf ztmDLWNQvE*W{glEGboKChtr6pHKRIk;A}raRN{;#7Alh((ssB@yHh>&*H(^M#DLY5 zFv4I)k8wvkm(pImpo|qu+jj^T`={>KWXedvl7PKn=%8D4jeXd%X|KZnk+@pZ7R&^O zmSGFQctE5fDpflfC*+3iBx6i_*txvS2VwSwl2l!x!h^>$op@EQpnO_d4sHS3){Au- zaQ&;h8J)>;#vmwt8Klvx2&1b_pbIJK+;t3Mkmymblgdik$Z77~>)WMH+Ns ztK2Rc=&kBqdfT@=v`Q`hEe0lbs46d_v2Q%3b(G>X*`s}$gvHWI)^OCY5YCYAZkM!` zb(0FoxO7aeoZ?QobN^>^xYJ(vL<@^3AgY=qy1TLjk%t*GS6^ZDOo=pE(f0g6^3UP@PR&!lj1> za0@xaZPo86$js0@)~e^+$;Zc9F3Ew^j&&#Z{yjwaErakmPuD81WkGJU$T7RRt9Fp* z2xW#w)YHZP+i#_#>?0SK=2y0;!%DhrIKA~+zesv>Lfc;CTuLd+_re~LVa@?{hG~Wn zDcb1(;Og&%!wBV4aw`-^3YcV{i.@81wtMCu|$chqhANO5E#_u$U00h2G8l)mHO zt)yueZ>%qd1Bwx`r!#Q@B!B%d`$ikkT99I&GIT^hg7EnBp>-9t+A}%UZzs+NnT`HA z?uxiVoqTFmmDh?)-?y;F`@jAMf^fE3Uhm=B3?wXR2lu0Kt#|MPgTU$;x6K&lCOGGs z!_ko-9^Ux!eAG*zx>ZEXx1o;XxAk6F5AXYNY8NaqapkhsXSSkDdP#o85Tbx1t`T~= zK~0K!i+}=Hpd!(oj+5J72sO6n1k-L4cp@2$s36CWa?orl+jW0-651-Y~n@-f&;D!iYz zP&gomJ`nSK=A*d|4f$evy(f50amxTtlQ~YOD`NiCLq6r%Ed$_=6nwuOwk6{-|D~4K zr^pby>mY-Qq)45DyAo?W!v)Z9?t8NrG^STug`~ka$^2>3I__?(txMjQVBiY{4rRN{88m5w?`ueLH<tb_c7<2*cXM8z+IIUyH?34NgNP-1h10ZTF(@f|mjnz7eG zil|qaJsD;-1v%_!lp3CPLojsSK(Zb!R>easF({`C?IHKJAJqhlaLDT3Mh59hsX+XH zp!XsY)A7oiJ6CYp1I4IRn1kP+8K0=a9=b@Q8b+K~n}FulX-o69y*jWH+Fj72@OAGA zE8B$$%Oy~2IR^O0X1ty@IdBQ7IC7o@MMG49&{nrjzx$3~956z@oAD3|2Hl8T4|~Po zfLGG(RYb&y1N`_Yj>T>m&*$nKna{gOF5g4Tv)|UtOqf`q>G;VC?VHNO4fww}K4KUU zW}eb#c$eIMD$&p;9eLVxY_@u{ZZ$vg8D9N(p&in=@2l+L1MEQHT4Hw4B;#!`4(Bs} zrO2PTzg8Lk(z^iDFU^YBY2oByRBmk^fXNDUxcXhJNS3miFZVm2lAk*Xy(|+@NPy+% zHo0z(RjZE^x?QTh6p)2=zbnQ3nH z5x%Q0Bc>}7B<3f6%6R#Po75Y?9SY#FlA_P zX3~w1Ap+DpSB&uY1kde0;`|G^u_6H<6n+0B7W?td#Cp5;o$}k)*BFV1d=47-D0sn^ z)$mtIZxmaQ`!7AqsXT-T?i=XhmlLqY;F)$6$4o+p%nb%}sy;XkhP0VIPhKZtCtR0B z1(GWIjDTdSK)mvWD!lmiSq#JG2qofLHf0 zt7;pltNQso1)9+eb7}qdI<9rzTF5Z4r#`=ioMa}moO`I4tAmv&=FAO=H$e0}TGz)L zSt5j1tyx$eg`3&(po=z`TH_8OhdIxW;GyK>l_zHFi5X`V**ounkZypZWtx}J6LZEd zCNH&%?UyVpwq3IQR^Lv4hc+!|2g-JZjvktF5Jz52_HIRxj7L};f_ND?oDX*aqk3iB&zVpY@})RA-1_8^t#$uK94={ z)S0^4*gVU!qW@BcOIe0$qmi2R;uFZ_C%V*Z5Z_CU@j|f1LR_W!%IPVh8y$_EiG()flcbzOx+Zp3mbWQ>duUH|Mnn6)aGJ}kUE zhhJ(;eX^!fDJ1L25h{0^BvQQ|y|zzdGZOZ#HmJTsGup;8)j9~ zP=w!W`EngoLfH$3=k-#WYwWtS+WQoIA2c(F#S0&$66>}LEue6)5BEkEWRGQ62(Z?L zj@#s$+rSyVExg2!gqKpFmqk^QLTDbG=|s@63o>GNs;w!%QM^8@%t}M-#FqEZbxM|t zOp^sN>4U=7g0WXsP|m>_m~zhPIpD8|3Vu7nWf*Kb+Ru~ZPeEInp7Xs&9;Q4L8dn50 zj8amj%SH=z&;UF?m@kDo2249WY*kiY!8MjG0(eR~XKy>9^3iGJoz&4_VAY@2Uzs`s zu!>^~J#VTuDHoQD@yS_fHOF-U#q~1`v^%2m3Nfy)0m$xN(UuF%+6A2M*A!ZefrfRGj^>#NunR}N6 z?AE>hW@_Z2m`m4YgBU=4YcM!w9Wya>9r1lQKD)5^1tMaGdVhDeB*Is#1Y<9{gL8;m z*!2^MZ8lBANXfag*`J6Qinh#bXP_L+n&Q{~A4x_^m)*))+W=_9*CCbspbaZ_Mdh~% zB1`ioVWMc(w@KBJ_;b?;K_UdTsXHX_&&dLsOKp51A-vUR(D%%?-gVmbzvf(vH9go$ zq3$}QSktaIk9(s_befXb#vUH-ABBm)sIwj-geNdF^%ct=tX8)QQr=l?8z2(0%n+>i9sq(R=^6O1(gwJEzDYssxk4VF( z)bMWDr;c8Pp19KLs2xiB?{k{`8jEfUXiC4n;c)Wgw^%-#9H?dr6=454J1I5sjPo2k z^1*I;<;}|#)SByQDS~<0^Ra*}KjVl7B(Gp=O~S-NW@95&Lz@Cpzm%g*o`b<4DKr`n zt5CdiYWkgBl%8}H0_1Wo2v!g3eL_k^q-bKxzl|s0G?eV7b*=;^C-$r43)qb|r(w1X zgM#)26F%J%_#xo>_S8eqLG7NznH~s>Hg!G*VV#aM?h?STWu8$A!5wmBUWG(m)=f+B zk5+jkn>71Mec7F0`)l{z?6NW8zii(Pf&G}rXCooG_sXd}LfL_}Li1S-qRq3w%``mp zYKxaBv$4k|NEYb|a&S^X$MaLo0gFOw$}g{M%4ge=n_3cV&yPw{Em;7IJ!;V%!U8sR zFE$Wd<83pb`}2FT*9Eze&H-4QO9c?FVHFp8>+H@QbTcA z^H3e89jn{l(OxCtB<3g=cb*Kw@x*n|@^p$%Zod=X5>uvt`!Rc0F)?)x5gWo(&t$)m za_~jxNffo>$6z696)K76G8yub$qDsnP$Z$FR$rX9x&~Xt*_8EPoomwDI52L04axhS z9ua**^r0dzFkMU1x0pvMvSi*bsr=E&$efPvvNQZh12QXxk785fg8YrdGP@~rFeC(s zjfnRRW~li~sD8S#EgJ=WXG@O}*0ndKKL#qxErSdW5?oLJIQDFbL_NYg2ph1)EFfemlD)4E;UaFeHVrJ{2z$ZtE?pv zNc`mKW942lL8ydNTCo`))UKO7w(GCU)lQYb1e*NoW*_tqmH-qu4YiGsJiS|^=A*iD zt%KN}+}c9^bKhNB(L%Xf0!f|9uneS9n?9r)Z6CruImnG4Ey5D(=`2iWS{KcS4cjzR zt3xsQH;HlxbhRZaFZ|?; z)VCfOq+!%3*3XGEN42kP|MIrnq5FMlyV}$bFDqo;8BusL2|niaWeF2r8T8CK&&mjm zaB9G6J0T7apTcmDlXFr>Xw9r)Jf?k?|AoP@$Y91_5+b`ibT*|?Jx_aHgjp)S3o6@p zqZHu75G6F<+CnK9N!oiNHttWZt-*0S)o7ifTX71>&8L z5kg~>-X>{PdgE=BP7!^5PU;0JzW9Yx;})bRt$gxh zM$kN;I5I|a^ki+=QEJ}F0gSpeLNyB*9d8bgqJ+rcU z>eRY)lOQ~2f?`BoP@!rD&Z9cU=>F4{DZ|j($t&>e9r8h4`*QX`kRF(es87~LH!qt{?ua8l%kxeQ6eE z1_bMs!(DKb1ZNarm6-Gcj}38}?X=bnSU}4} zvp0~D%gYpJc58|5c}wH@a+qD&)fWPRV)F-H8=p<^Zr3inm${@LmB}gt1Iw4YC3RXf327dHjEv8f4K^*Z=VN^D;vVKbf2J|g=T@1bDYPTQ9t0CB9I-1( zN3(czTJ!5F1Ucaf#`h0db6;XF2r+YEV_L~D3QhSKbIVFjrjl01+r+V4)m%MG-Q?Y# zsJkRT1h|7X^AL19Z8jnx4X+KQazdL;_n$wCsx4EX7`}m|bmnLHe8MBMXRU)oa1LYH zscw5Jp^wJH%OQcth=06XvwiAMe zL2;UISgVR~!|=!@f@NAwFkm;V3l+?uokD1XZHouaQLqyt&p#pyYz1Dm_x$2cCj#-+ zpAuSB7+BQbeAx)}B4W6C)II`m9X;7-OGZp42&6SezlG^zSef`DvzJY2nBjZZE%N{) zjUP44Qu>}Sr?czcl{u%#dnc{A9syg?llh9;L-y{hGf7{o=D@a2UBJB}5 zMoLM*2E~;r0X|Xm>e!0S!SQdPMRda{ zsV1)<6SC$`@@aQtP^8|yFD14Co`AYId`tIG6;>@?x1*(bTwnI&BAgM;Z2p=v&Gk90D)W2dQ^~8ZZDC)4su#RIn zq-!m;7Ts2dxxH<&+eP4SOJ11`>~-W3tWmdYp59Wt4>cE9_39C0JZrH&L8TECYv-=Q zWNNa4l^rMT^J76;{HdO)X=u}2bvj_~frSCtNcnZILar;dVkN0IVr$p^oD~$U0v=L^ zI?j2*J~pE=be_#)KeD2-)2N{VA*o2i3DJ&T5@YGFZ);W{2Nokgl!VXiT~7+lcv$!R z=Dt#K(Tz+)=)Y^oyLy0CEHXc@b$VlxJ3)>X9!z>S-dfm!g=`0N!)ZKkhJ~n+v|ehQ z`QWSUtx?0e!iuCx1D~`Y+!Y9CBIuD0_;a8w-$tjDYI!R zyiea8wUpRVW@(B%8MOZsaqIlHKK#6I8`=#|R3n}B**C#5vix`+vf;`S9H_V8Vd(XshLw6~15}ic1(S8Ul zw|3Muk0HHW^hE8Nm{%ZDTe3=;7b%?lQ5(DM5t|CUt}OwLz(<=)J#4&20V$@SCPDosUQTQwV5N;!%jAN6E8?B*Fpah%&{qvDqWnP; z3lxQ3cT|VJq5Kip2At)jcU*Q6!&Ygnh?+o^V>-C%i&cVo}a_=vRnxIREi_~AkkmA^cq&(-ugI^kg{NA z2`{^8(+@v)xA`#12rKwuObjV|*fo+ia8`^{tvimL1aS5Rv{+xpeO-6iV-ulNK0P&x zZA_jq(aK>^fakBrRo)*7OR`>(;s%HqTGN4jP*@JnJj2a`s@*6mJ@+n^qsgkdHR^S@m7D6@N9^SAtjxQZ%ktn`256I_C!86zgCq> zx8CNPo9YPVFD*}bB+<|iWHetrTK~OtYjBoje1&jY-*@THhH?79K1DfQ@fhL>Fdka5YjZv)5pHnFF57Sm$=**^3XyFV1h@}Heq z4?1kS7NrRAR_CqQGyL`UX!Gaxq<4=zAO)Kcpp}(AHxr-4qj(G zcFDK^l!WijGNSXWl0%I?7Iow4aM+`rvT(_Xcz;?XMB17vMOW4U`lda1o#^3(W;a96 z3k??-+OWBo{_1sUD+>QLb7U04*|E5?E*|Ub6tPpqrOidR0p80K9cY`I`dg{87x+h8Y$Dn>~{HdhERZU5D^U z^u>|E!(I(8VQKN}NxgblN}Zj&?0bIq7x>hX3sqQa)t45z;-TsU%G}G%D%Kn^YDE2O zO(^c+O`KU8&!CxbCrKl0e7P(SS9r=$;XZk`9!{io4`ta)pVs?NUELR5baPU*yx<7Z`r!!z`LbBeU$!1W$%0l3<(PS@E&F*j&zCVxtP(K3R-ipE> zc|pd|56^`%L}FPg&T~^@Gym}yP;0VpklJaLR}QpvgBxEaxH3gK!+7{b0-5Qrgjci> zGOs*gWVa5Fa;rv2;Td8_bCAL^>poX`sV7uziId%{NBH%(EL<2Vw1J$~D|-{|MS~82 zab8t~K=$O2`zH!V%T;KLD9ozK3b))Afa-NDt1pcYI9d;q+Md`pDLl zUSAy4OH{g$MCp=uT_S@Tny>TPEzt5G8Dv-auw}T2sr%^A#+MWyFQ_}J>6;o`QSr3| z2A4xK4B0T(un4M!8=BX~@Xza?!(CjxKOZJRJoy@%OYA=NfDQE5+ zwEP_=fk)4PGPv}Rs3>)H`fSptyt#ZSYeWHFM8E=Gi(V}uoH!b8diXCH=fx#18B?Rg z(`+PjF!q_+5YG4XC>7<((~Ftwr`gNo`z8D;#r5%c!9Ytr{Gi^thrTNZMO zMMN+_eUTU)V+Y68MLSn_+6oL<%GNEsr9sRWj5YF@hTh&cQtgxXY8%B2=G>TC0WM#DKZk)`J-JTPkJU;8PJz6+nlfgN*Bb}nwjw_FR^!S3?D><`QQE1v0;1xkRt$ii$fZWBK$v7VSZLFCxz z4$u^n$yJR@L;E{qZ8j-6Z%*>luYU8)+?YVv2;wqOH&S=*40hOBYT3-u5Y?mDA=haI&ZoVwPvWB-r(=s8`Vb?@zxa8DACk$ zMjbJfNI6Kah|Ry^oe5*r_jmE;_p{2wn}{4uPplGn@+^)^`|Uf^pBf7-r_@@Fv)NK+ zXRKU(!A3KYq&YCrSg!^k>`4O ziB9x9sNp7;+42pCJOsQnIximKALz_@Bqim-5w)RUu| zD=l3z2BpK&?;J(}$`%N*I)W*n{$B-)(siA3X2$*OEVrKt3xQ*<2(Mq`z>H_#w%Z=t zb5;zhFP`AF{86hOK^+XV3;e5cB-(Ak1yRJi1(hfLAML6)5XMX@^d+YncNjTNOsj8d#Z){U2x~WN3ldpi z2&Ct8w)cmJSMfl1T1rlcm~ltyUX=T?Z4|*1?xDnkbr8N9JlHo_7mj>+bifqS^5IQO z3di3E3Zr1E^NDG60<#axJt`tTVdpsHJo7KAm~JK2?IkL2LUwtaHu+`Cj+*M+{@r!R zz!PxX>wRq2I@MRYr+khl4@x~I$05!rxo>y(>U^Kf{IkpHt*R(H3UZiFp=d+|^%A~d zeCJbw?Ma16mSD=x&F7YNsFM9sRtkTY=4hkWQ{sQM&aaqEIw$!3S_n_ulfqq4@?Ji# zGj)PW(v~X^=9vFQaR=!}FCcV=o@{Ng#z)yhxr8~ez^UW}#yo`N?b)YqQ(50x=zNYn zgW5cM6Nq>>mzM*_?*Iu~4&Se`RXf6(A{9_zSVE`KmH1-8`8T}$;n?Qa0NL_Iy`g5- zqYp(;_WWQ`?{NE=J9X}^S|KRmjzf*b29&wdbnc5ms+Mn3R(w#XVONuo(Bw)cs_fV* z-*#mFVJRP$^S@Wx4BN#In09!K+k~ilklv=ev50D`O_|mOTe7enLnRFN8g3%*^ zYF=?kEq7-w-eIS#F(+NZv;&sse*Uy3qVf!}vC{_2zJWS?S?dWw7eZw4g+| zq!c~P;Z@z?qkI+fuwEV)d?|MWPONUWcUrNP>*na{B6#X4)bkkn*hL4AWpGNHsK$DE z^Tz74Tw%qBD!%Q|y4j^kg@vh;aL1q6!yx5@H|v)QG`_vleTrW9^?NuiFKFV&f!JQZ z;y6MF^(Y19dvNRvOwf4*yU%OO8)2Va+_sxEi@@=NUW{QGIpW4k(i0ZJWMc|IVemS| zM2#!8YPsPD%9>7VWs zKb=EUTH#~!=+EA~QI+`=j9e9W=OokAKdxEk?uOrc{H4GhN&ODhV|yu!RnHcV_++BFoQ!a$jF$`&_!2fRz60RmSVX85(&BFO!)1?^Ccl2s0}mJjI+g zFlQ~i^s?D*4TzIlHJhK4nQ|^s1}{N*e*3oUkG;+Qd~ijqnBS|B1JM4?%iIh$B4c+| zn|zVXDv2&I0=EfV5>=PqU-j`fBi9csegZf9UYKzF5~(+ERmY{SG64lSIX*G-ZrX!_&1{5L_p;e``oBfmXfA)J~vDnG}E>Z8|u}!Crt!iGo zdwP!5l2Q2xVjl3>^yZR~mB747y8C-?-AWBm+->&1r6uI2UXmi88wT>LRRh7`rgPxt z!ZPoTU&{&jOP?Tz`VVktmqh5(qSSYJJik)FiQ(#lu_znR#~{s?>#16PLdQpfp!KoQ zOY%C7yom!GLh1+VeOc4-b3-OkK|eu=EKeGHS_sQvPjc#$l8KE&qm(Eo--?3z z<{G*=+a@eZT$rJyQr+K&;8nM4gAX@DA<|vGlq&QFdY1xmY1)60ZRFXJ&KqrKVdVY1k9;uD}Rglu1gvy%!|A zcuIjhNHKg}n701y{u(?>Zwk6A z(L3e=G|H5wKfMS(mlAvozAz)ZLJF^m`VCqY-%wf1b-Buwq=y^1-OIQ)b25-;xxTFhgt~X(Pg^gl)g_b%b{wAJzBvM8j2%Fh|+I!c0Qk6viBxhXCmh4Jd|!L3}LY zN@1txB7rzLh|S|SJ%JDk=$(`l6w>9ne<-v>P&fz%0~vu_KJ-R{L_Pp{xd?s%KnR^^2`3(E3IGq`FeC%`Il&At37}OlAaWq|TTBLu7)HH);MwjK zdAad$k^nH^l0ZN>fs8owmI0Ck@Z3p1qz`fb5^8WCD7FuDJOJAbSikhXU-IU-9yQ3o zd(EqEI&iq(4B?3J@d;7wQbTI|2dJ03fUeKPTYaG6x)j zLLm0jnF!WVYJ)WreNAOvocE1yj`7}C7e>!@#5HM7ifun#)` zW}xH|D-wyDdNnCbM@P`d1~y?iNhgqTGRPTtg5VSQp)|R>KY)-E__w#8%U3LeJC8tMIK&b|8 zC?l#)th+wpntr<|>wk@5w=_SmXGEY*9ISfc<1tntXWemVk_*55bM$cV`aOCD zxPBpiLOj?|zkmgRm1pqe6mdi@n+y8mJ9E1YdIVbWUr;IljaQd9Y=c7Xm{308e^gJq zLvB4kCxJO=62lGc3Xzm}Cs0Dv$5&Pm9@5XOVw3gDGNRHp&FAww4;Vc71tr}#ak89y zy`qzA0HcB|D-kZQ=Yl3y_}O>o)pw9kCV4N#5z|KDy5V=zTH+{TXJWT=z@ZDvtR^Og zi3GFm;jfI-<`3+7UL@P3@7u(%Cl&aVquFgItXbk;07;Gnr5-~@U zTGQUqtTxpTp(o1c(uVe)PGM+B7y6Q8&kO#ogg=3N*pR{lXFfDl}*Er)=9ass; z18W!6b{@~lY?#!xCV{ZFr6VVP@i|kqTPJMyvytjOrO7Jpb^C=DmMYt)GChx(AmHS; z^p4uaBka1?cJVt&D%Uq3@d^ZloHhDx4Bl4z!%WCde5JqwR|MboAKs$Gv6KI)WZgM0migw4=iv|K7~s43wgBSTn>RR3EhQ5)L5>`9BDpccqvlStK} zbDPwojh5N-OC4?drm1H;nZEk4&NpFyORL$=@aH{Mt+X^Ho>TiQ*`O!OMnwbr&k1AR zjlkym!%E-1g`JQO`wn@f5TE%0Mc&!$&qF*_R|$`01NyRo9P$R*IP7Kv4n+elx?%-K zICVv5(U-N{0CRK3%;rq`g`+gLPPoR&%CLdCt*nu>v6hbr&B>-d@#C0kTJz*yx-tEy zx=cWZ@}b`|$obDQjus!8*C@X4URy@Y@lm<$Xnt3NltqBexs4*?J1|XI1ZTUvC6%b? zVV;gwjrs!^i`nn~2R9MPuXNJ|)Aiq{J-`m`CRcgw-=h1yg@2m`DR6lcUi%g;xZsnI zEwcyhePW-xzaQ0=J4g*ZkU5`km8wBInycAlMm|=J)fA@Zfyl(qqYk#AP@?Zjg7f-v zSh_Ns-TGOwo~5GMjD2KYx?_t)iT#Q;+q-3X!y6bgqH=jX)(VH%e0Xj3Lc?2fI+0#R zh}PRU&D5I|SLs%gmpIhfiB~&Ef0Xs7p7y2UaB4R%0UkA{nDE6>U1N}%R$a;*y_MR( zsY|q>=tV%Y7yS^lut?Zfw%a>5khk(WtdMY@|Z@maEJKY@h zFVApJSsus2FqNB&nWUzXk$2`2I8s^Mf*;&Rh#5krrZ#0_DjKY=HatQl*y5tlRx8La zq6lA&eOT8ImA^bBWiu^xqd}GBX4}bPl0~g6jSy{?(m}^4dgZ-%9)c zW(}C3PwhzOU~e#f+{qZE&lSOedL_`})P?*kkqtxhta1P59rt0V`U`e{`PYBB7Yw@N zUp|LNj>9999*rnnW`QyCmW)X3#yEB9QG{N5c(_-pRcJMRJZ%v;+rDtoQX(|-ZlhPz z7562gyc}B>C}#Yf`qp!zf2kmy@ZLh)NEv0Ht|P&{;}TeB6ZxnHrMp~ftb8oe5Fa`; zeWhP+dESxNl#%E#`8`n(pH*s6y_39*7aG~W0nGZVJbBf4TrsRTsI4PoNHx7R-lYj_ zU|GAfF}}zny}z#K7s%PqI2W2d+00oa!_cHxXbUB&7Lo0z0`!#L|7 zxSz&okhQ)5pTXPc@1d@^T1j&=q!}>_CwC9~@4m>TL`MyM`}c^wIQP(lsB-9cKPc{D za9Ttn+q2t9UT>(LF?$|jciF}pX9Dl4M!n_$zPFX_cUufHx|Mn<$GgeqJNGHw%E*Hb z@1^u*&@u;(9VxxrRzz%$b_%9-Jpw|Hhf!<2pRu+6tN)^{2!kU!3E{-*lb)MZTzz!w zbcML-g)~rYfXT#kdQixTXwUNg7wjNB>a8NwX(k@3SkBiSmOc51xC7l z#ndps>g5ocI9g+re3eTcyB{F7k~8xNw4rExC}jEn-Ex&I%uuGjjs=M7}L|n(Iqgr1f|121fpbY)D0wOYut8cr>b_SHPYX_ zG)~WyK3YRc!pVmrVnV{W_Un{=rRg2ka}3iegiDf!Q|F$=jO|!ZFyRrLTI6u%S@H{4 zjw)f{yC~gmJd70NzwinwP=ln3a$7h$ws|@1DCi2S* zd!$C7r<%eqX=32IP`4e(4Hj++PK-JAv-iK^AXq(`&o?{=TAgVkc}vDeQ6kt;yUjNY zx(67@+-%Qmc#Fr&Kj0>KNf-KTUwoY{KX~d(+Kdg-&79v=T*$%2dzQStVbH9TOF-c8u6d9}CxyI=7Dm)+VaMBthfDtaHF*`5EDup} z*|VlzctJ_U*xX8?I>VM0Sw1RUW_TePSV`!b;2!+A3xP($wpnsB)Vq>-xiR5f7Rx!D zv(%>stx^>(bK}?8FKRh53!ZN7$0E!}P1fbQRtkcr9og=Uf;|kcH3zHwMjc-&WNMIM zK{3@T3&g~ud9%ESKV27FOv^;XGa4aUTiUgKUHrApqnnB*zX={mvokU|TT)%QhjpLv zu}HTLCp%1pd@H>jU6k&Wb}AQhi{J7?*gH;d{O#PT0nTld(yny5o%zQ7cO_X% zgD>C*&@lw=4ZZzFWT>VIz!wp64&dT&B$zPM;0?i}*12Ox&3MtEWNC zyuszsm`R3kN?oYCYI#7)ZEQYSp0>|_6^a$3(2O1jv`Hw*k@bWuImNoP;QLPZssq4kfG#<$V6N3)F<&zy=Hc` z8tsL3$0SbPh7aQvwnJx}{Y*c%&PI=afu!c`>Hm|`<@irZmzjh8zqBnA0UImpe`DAF zr_yC-;b8q=56iiNsw96evTes8DM_=_P0=bIImq5n=qWi{&ASFSG?rfn9Qtb1G;1C#E1|%Q> zLO@DGON<8t0vr^`U(y!aPv9e-Ih8wpLv5@52YwQQHC_ zq@;xG-Q5QO6{kQl1q}sm9-z=JKfI1n`vdL|I0ywM>hVJjnpRBOOfZlwo!4DudwD}GVZ>YeJAOIU z2KM34^jHY$`Lh7!VJS6xb&Tzs_HuA_OEL{{7Vo0Mg~KFmiYD zFWSsYA90V@UkMEG{*-rWzCr+db$@r|Puie@2=?G|fBXI7G!#T7cgKh0U*#wLxKU9N z@c`^30s6|{YIHFw4xMy}@-=eVa5MFM#t{o8;L(U5`Np||NUK`!pKvj7AEIe=WS zf$SYc-+`(TB?9${5s|%mS{G8r?Kt4Ng-{C+(bX3P>(W%40pjBM_f>A7r`H8_`6@TEFFS&M}jizylZImRcsF%Er`^!$*z3Y!3ht^LO{drB1J-fiXTAQj!BJ}8vJG{~|#b?G2LI(2BW#`mF z+R64^?m7I56@xVe_DQ^AO-4~*q2VI)0OP_A#)F(6o~#3jtd2q@iBr@1UkQ{*b~lYx zIW7z*ttyrj)=Gj>V^)Gg0UwhM?W2dZ9mpkvJV(1I{2IJgisnaZL(FTT;@Q&<)LI{z zO6b>Tn0R0^%@2@WBybu+8+6$}ka9HOIEzDXlpZ=>b;5iwi1K=!Gj1xCQM{>r3$a(4tnxwcrnj(L;Fg9%aBRqWT(lx{^lw)K% zsRgWelU(5eSCKs;Ca)-8-_dy|X3XN4l%h#LS$uE9&Xp8hDgmV$=-oN*S*2Id3C|CzIf zvGYd{{V-iaR&%U|%zesx1S9+yF5XzMG2U8xf@{q-Cb2$Q+;JJ$#K{2M_u_LCTjt_` zlx8+Jze|I)x0<&{Akr_{@v$@x;!#l4Q=-VK1xVp1=@=f)3zMOC83VrL~uHWl{*oM3%@ zK6ffcr;)kplQ1Wc>OIq1iJ%IW7j~yr3dwRk)Wz^G#&;!fja1Gq8c8t_s!e7{7gpT) z^)EuCj)H-sX~HInyXF^aB=Xlo8A>uVi>zXaB!R6WerHT`$Q*TVMk7=f4$rzJS2vV@ zILp7qan7rUR6a~xt|YpHQ_y6~-?nkL!@x?6A$3=$J1Wt^SgwQF$X!4`y0X~G7%eud zb2^)_39oo?e&aRE;45#3i{6V+LmNR8h269ExcA9vGHkmdjg>}a=q#j@p;Z!M+Y0nG#9F~9eh$AN>9#L1UwF`!JE|_)6)5_p__bv$ zrCbL75*vMnK55bdE~0g20rvW%?&%Kg$C}CVJmcgB@XJZDVJ+JyZF)&=aPA5(PDTa0 zHm)lxHK7@G!#`O~5}K1y?&y)lA1W#!Z)6L*Ffy%;#d$I8wU}Qx!(QEV#izbn8cqyY zA~#AF#MvaV$WpUbCs*Cg)Q2qe{>$$`d5^KdrVg@To+ys02Ow-7bf}+zmtl#zoDo7< zVfgUMDg^-WE&>lx6dQ90wn3PPH;1;CbOW;I4uuUd)y=r?3mlW!IiiwQ!ix;a=F~)S zq_P=}O92BlnOqzpBx=le$+~!B2erFxsO#-@JG#L(7P#7&)}&~S9W4YS*#++(NErRQ z$F!4^t9?6`s(e=DQnBrg=3eHw3%o}ZG3@W4s_$1yX{#~+y}`upMxy?DhoyyB%6KBS zJtGVnuGErs|5!qB>m}zh%{~xw48p3dkM(M%4B*c?6X`^|;+cwO+r!GMNV+#ket^Om@PYT;(tWZV5Lfj>{l z)=ODwl^5GL6&Brh^he;e3(4KmB7tJ{eOlxMn?i#B8{FaEg@iR!_mI(+^_%xWYT{+T zo_rxsl0=XWWxT4=DbVQty{?JWXOk=+9@FZ=1Nf!PbHI?Cb)AVv?$ff#;xsR_D9&k* zk`k4Z$lKcz2Rdwb^tQ4PRdms9h91?x&-Qh=ZO%uC5{jy>w8vb`gU+$~^kJ$4Ckre) zJ(jB4vw^b&6ITq~I)!iE_TY4+xT7~zUI57f6UGuTrGWI4TPsgbyPTb^=~J4al=oE0 zmL*qn5wlzEr43;?&bQxNJmI4^fL4x9`qmRXl4XNmzaV1D#~k$W`Y6H(Ep{C{D=XS? zvP|+@ZvvOHGpgb^pwYzg08w^ask!dL!sxAY6wOsG(K6G$cP#(hUJnxYTw{P5B3IlP zw?VexY_KqfWV{h$BX4q8#iQc&3w-663q4djLDI3v((O#u3vC7fysn|(5S?E2cmk)b z9G4&Sr_Hb-bIKkv&jYC2arZ|jef zYZ@Y8CI<_N&!|VO^!sc7>-ypQuImWXp+>ByIv$ewJ?(1D=Fg$g`qg-u9#?*j`TDCp zkzFRC6V6&I+94UbuGRPedfb8kiz|t}@gX@}KFMeQAQJD~$bh>1_l0=nP#nF8q=$@j z-Gz1b4i=Tfvbtnqn;AQPs8^l2k-nC@FVGfzvpksA=v{0n(L*O1PA&K~9HG0+4;N__ zd3OIgaBHvl!i(eIvsQNEV^(>O+b9Jg@<+g<5w*1dknsGU3T62axXScTM>ZhY<6YnJ zf&Cso`@`k_0VncO!3$VkEMSVrH>|I=*vr91vry{F|_>vFB zwUu)l;SpGETb>bF{R}rD?$8}K*q;FEzV8tTwf73>$PJ#@RFo*9MzY;AnmYJ-CgKH0 zDSAUZ!u@)xu{F=D~pEj8O)1x3J1aA^nfS zBGP0&ihS#k4vk}`|DdwVbQkImY%bV@vG4YSDn?oX5v}*Dr*(bC%3u26g{&G=Bj)7J z40MUf@+0@61=1Hxv?S*dqyV{WV6m%u4M2xrFT+Fz z;1qt84DZ4T8F-QkK%Of#18=d*;B@p_)N*;fb7|IGSV=Z5bc2aZa$bHwsc?#YK)_Xm zTsGkxWX0F2Z&G|pX%^$p9;cBnn$e8R!`e#i@=SFlvy%os%cR^Y=G%p&AxFElvQ-(z zZxl1zh9N)Ju7<*ndD~MVY-760em+6nO1(*FGLCaCdM7sJLm&HZYGF^i6Y&x`GXyo! zp%=re;IuuwuVu9ShMr!@PTrezJF{BgL+^x9W+*IAPRYL=R(KgagA@l@1Qrm2Xye18 z=eXNfZ!%W4}BCYhMoCUtCb9};NZ}1est=Nj(#2lXH-n* zo->mw8Y}qBxJIjO-TC}=vgGsSHi(woRI}D8tLSV%a3DVCfn3h-vCD>{jQ<{944p`5 z8J5OKKdI;3G$sSBkvvVZW3pd! zZd}xHyyydWfc8p(R<=Y!*6(dtWFKF%pVoh_Bc4^>vOn3ylQSnAeb2D9k$INUJsIQq zVTp@aF-DubIv4iB9#XY5y50k0@Amby8Tc0$Y5>Iw5kAaZ6VPv=zI%rz%o_S*gL=65 zm!Y+y{s^+LTSoXT(V5gw+G-!b$3Lno^l9LTl~;5~B1XdX3XVoJaE9v0d(vQii4gLF zo*T;rq4U{jXLPLK2DI&kT4JH*kLftJ(b$VSyOw zeG=es8R_LMa>pD`l(<3CL_Ut2y5tyc=vI#WFYma#u17hVS9`wT1l@3PVqVJdIJJsR zG2~}&E8k$X}= zjIaJi=K3Qff|_Y$!CZtazq^VVpW>ypzn-SBc|6oB(wO{V?}w5ZBn}P3>$NZc^Mz=` zE}6QwNYn3>!QkeCh`nV1LI&&7|lX^pfJ<*>J z29u!72Z>=Y3qs;c)Am2+g8}aQ;uD08Bmr9+tm~RtG@Cikpk_!1XDxc>-pnRTFzZ>% zXa<+u(Zu)y&q?Z%>0p}0{DR5#RkBx~tk~17f9t@m2Sw#Xi6LjiM0RdzLnz{DU@Bu! z2aR#{QykZa^Dx?zU34NFuX`%8e5V+2T=HnOHq11OS~mb-oR?~7aY1c(rEjj^!|~Pg zEK@=a?PTBBMjB-!Z5|kWw5^Yl05#*VhX9fh$7u8o4gW7ibf#D;SL%2qA|2c+onhk38Io2I1ywOoyi_+AJaCkIR6!xpS5c0vnUC#87_&&Ug8|E&e!+@paGACqg0AkZAu9~~yQW@kKs&nu zpDc&Sh5>Do!c0dQn&DHWVXm$7DjMdoBfCe$l%UiY#ZJ$(G-DVW!DSv19yk}pSBCuK zBQsrHIR~KNp0Xqs{9*E~AbCwi^plnC;$T!2EruzG*Uj0iymk z(i~oFOf}d!{MK;$8b_fHvmU?8%Oc>JIYj2rs^XaFhMV#uTv8b76!9@6 zbH>>63UEP?Rv3+Ic9jGg^$|LWzBdJYZ9eoNTbygMS_dJpje4{Jnp{+u5*fb@7B(?i zoQ`+){ye>&qLkH_AZ z_jF5NLr^%&=G2~Wns7Zg2d*F-D>>gNU{Qs>ibJlua{T%5P;v1_aKijOtd;PFDih3u z8w8Ycq}@tzM|1F+PzW7s6iS55#P^o&cDk2!QK~)M!p1tx)J=wucFdS|l}RA&XHYHD zyZeix+4p-kZJ&e(Dup*WOG_tEsDtUJ$+W`Z|HUQ5b%H))k_)g8@ZXFekgTiA(1P5A&Yt zU6xM?S~3!Z>WD=m{zPOv0$)j&mqy|SD_g!EQpn=IelD1aFb zRhaSmTv>RbjNQ$W2jK`025}kFe3Q?eb%Y96ee3^Vev8l_vZa=+k^h$VelB zyLgm=eKr~EMV3`V08^s5pifN-qy>0B=d=}&0 zj6b?_r)l7b8wRcWjvagPg}j=SvrMV4;>W5~$loZEV8gvGZg@ZbecWnWV_u_&5GW&C z#W80$g;K2NHYd>7kR9JMap>US((_%g3Ko=9s(iwk^|1Df&GXC)*2p4PbZ#((x~hLdG1LRYX*p#{3{8WH$Fe~b%v$pRf{NBS%MX`K1lw^I3^o`^vxgx z$9F*J5Od+#PNu-Zn_dBZ&_by|M=@|VTFQr8th=HRJSrR09BKA|RTOi=HamcWKq6Pe z32Sv36I)m^)*4*;_rA*&?Xa`_g!${rkEbUWYp5qYUXc?Y;frw3JGxduL(dF@cXmcd z3WJobU2{h>LxLTb4hvRyzjU8&?wQ142>N}Z(-KWQRb^CuE~z5lBPQq@IcucO{B$Am)HfvRGw5v6@5}OjO^(}5heEMUvX`*5%faqns)AE|_NeXfrq(mY zPl1zN+dg&Cq4h+*?Rp5(U~lT{&KcdaxM~ey!ZMJ+Om#8#mSM=IdFBGjBe`+@>cu+W zjwNzZyM5zBmP9rEbsGgTf(=Pz8`qGdz<1c|WWOQ6cIJLuHy%C!_;rZkA~z^2QotFL zSs1GNwr(AdH%kKgN@1IvTSYuwe7fnKareh$He?kaPMk+M$z;a;RD^9_{g*eU5PODY zM&!tmpKt=JrW~+-ygScIQKO)rUj_Ieo;PAUz> z$RNM*;e*#T48#ld-@rZYpe}lu)n4h>E4mXz#e4g7`@ExN|8tPxKIC8<|)!khhb#nPo`Z=a}K6t0>+NLW~wK?rx#8f4I8t`YR)q!WE)TrVay~Vo&SFm0Db3f;37dwT(3lUq;BLda(`f9?`mwCUR zl!%$&{#gGQj1sngxOb+`ss!qc3*e*d3IldV#}_5A_a$xA#IgMG8EqXdDW73Xs%Bl{ zR~5-SnezhfZvjZ$6P?NFmD=mce6)QSLQVeoy_>AY zAGK{#GX95FQ;qluT}ei=6%W`c{{^aNl7!BBCJRAo_MqA^*?p}{dr@9obX;tW?9V3G z7CPXmma-B?Bax5V;i)FEoTN6BcZBBUD3auJU}bUaQY{@%J6Acvp)aWHC`gw^T|ro{ z#mSjpz;`nh&;MZBvNQZg)0XMK=dk{nwv22X|7GF+f2J)1JKO)-v~>b!$+lW;#RDUr zk6;Q%vk48ynh!!SNsbSO3C+M@o{rvuB$9#!km=vFfA$xs#P94Np~Q9Mce7Wi;oG7*3&qRt&7VkN^@efK>RWp2I(F z6(K@=;5QJkd(@r=E<$kXhdvMr4Q@#PPbI?_JsueBf}>CX0TRKutY&yJ4F(Jnc#z4D z@bDiK!Ab_RVpa)pl;RMfSIslcBfP)H5PKmsNvrNO>`-0~NDngys( zu=D;qh<}-#STzO|h{y(^!F$`^M1*+py?eMuLqj?`xif zSeH=kAYV+d?V$CcUk+r@yFeI3i7kAb$cBNg{(Ad4P=6tnL?RazTcvvJ*@bgNmr~}>m zK?0184|K%PK?Ax6gINX=C{qu?Hy=j~30+BikS>O|G~R4fv~&Nlh=cfYeY6qZ2^|$p zSeu%_hPJSxdyf9P#|okb`>LqMu88jrO>UM^(ChovL9mF{)_0S^jS0bNh!|(*Kh z(GGur-#@MPJQ7GWgm9q(0`}qvTgy;{FVZ`6Gk`zbZ`i%|d&m3!4gl*q>Hc1XHhbv! z{@`#YFyQ+Qa`yCbzqoI&Q1%7?7GVd2X!ctrSoZLrp)qV9&3qi*HHxXv0N)B<2?*}$ zPH+3f(XUNn1dFzQ3VwU_8F7Knc#X>E@W=edl2aIK3E;y~B#y{La6l4}`rHL=rGmPD zXdm4Ge~f%H?~%dsIr;A9Q(8DX4Nj$58wkRDK-|5)bd@zWB)e4)#HOdE>YK#8N%b#M5ZOKMQta~D;J9r#4M`I zfldX|Ya8Lz4&@6Q%k&VlRtobW{`hGi_m9^C+;j;;NNf8!KEtzXd%iB7z~89y-=|%k z09ff!>RmpJef?}BHhqsn9kxN#y%m+&7N~S_39=>897HMI`~c~A`qD;Y-W4p+YhH=d zmRdY=(mN_0hvGw2f%%!|Wb)4usDZ7@@=1hHz7^)jOu6T4F6#T3FnZXBEka->+ zRlwev51FqW8NDN&^-Sb~Wc)J1*lc=z5q)i{LHwFBn8NpzL_IeCkMlRU3a4p&*Epl9 zA_E%BsXOmgdJ7`0%i$Ku(-tSgwylQCtv2pmNqo*(344rxkz{7ivsNqP4CFDq@#NFc zx9j|C#JV<+r!DA+;{GupF}2L{1;7JH`+~V;1G~g3F>IAhxxh8wEC^0<05YNi0mBR7 z5~a3K*kP)e4FeW56>J*Ta6EOe8==Fy6Jrm^E!@GD;8oO1>@N9tNt(?PQ@tQ5Zn-q7 zaX5r%EQW)i%dfpvgJ@!uah8=FI4xjPOgab?70-gffn((Z+vXnBW zq>?Yv`^9oY(k6Gm*Y2&h|I1-_0zp{-WUlk&c%#IbTjueCA{4Zq0g$JI?9S1o*>FilJ$gs}r(9Kq z|H29AvngCpcB8xg{h$lUNCVIHCG$GTC(2Xxt&D}^(UE{VOTlSAfYUgwKNG@RI7cR3#}R7AF-i2MWn%20 zY0c;ODlY3O@?Q#ub%Bi;tWglNxl;$cBE;ZwnU^ij);RN=$7mumD}_6i24mKR$Oj1&l;>Q1p z17S%?%taF#qc_U(X1I6kSbbKRQO+=C=|u^`I=%F{DbK1Eq$spGT}3m{@_KZ6B`f6g z6wmiE)qp4iIFC_bW5jezP1!># z>JF5k29j&jq_-^)>Fj<8MJMwZ!b3uDr6bBelv>Qg3Hoq*)e87K$B8k8-15u>AH;yWxY;CKuSvqtEa;g@*j{1sN^U`(REo6!PwQ&dU z=UlJ3rV~ZBpH^R^(YA5ARlagb`6>@L`qyxApPEd4HBB?A`Es>6S$YSll}u6Px>;JJ zrGBDO`P*Yt?$h;aLGcD@2Xv#f3OIMgFN-KEX+49+SNt}0H$7`LMP;_BU3l;vev8CxmvLN9=vq^fY?b0g2Kg3 z?1Gp~QqI>)(07Ka6!H$+sTMK_&Ommy^F|LfR{fz664aEQXd83`_Kn&HDE!=j7h{>n z$Saxv1)o9+I9a$1Zu2kiJ0NY{hEZ-n%(B;bJ92&hf0X^%6hdp#=^U6%Z{WWNLfHBi zw$FJH$6ReLxp9a{%j0{ER(ikTI<0O(A3Sgj<}}Xa<`7s3=G)c(AmwYB@@^1cn7X{F zUdXL_DDvFaHK)K-DKvevImIaDPRD>1637*^Pw*GdTi0o2xDtkr6_*!b15^Y_qzjvlEPjBSbi~2gh26>dG9}GI4n-PTfqjl(L@4 zOye709={d=FcDOCkISQSdKW}X;60=pJIHQ+fgSaDydxQm`UUl`Cyw8$oV>}9d3YxG zuQ5P_G#9Z=W`^WMR8yBo6-clN#Gd5eFm_K3ivtE_hSp`KUQox9o!MErap<-dHK$;i zIR&`QmMk`I;C3q{zA(F8tC+?{A_VozQt^+iS^$>uAny$_eEd`@pcLjQRFU6g?=N%u zeDCW$8-I+HqOo_0UNOq#Ha@6ZK?+b7%rhFhN}g(^n6pZ386ic|^Z1c4gVi`Fa(LYQ z)icRnQnKo=kY42GeeRZL`tinsUP?}+S29t}f_gJlgNbBl>VgN)2E+TPR$RA<5aijo za^gQkgj%A#1Qe<}i_@PCDQ=w5O?;W6A)AbQ!Jt@DCPB*4i2@zx&3jxw=-431Ll1`QPm!vMp3SI9^G=ngrJuYk5%zcFSx-_+ zf$pJte-cpmo2{I$sC%W-G;YL{!IP^e^luv;#8QeOA)xEc-bMdvb}xO3e6RZmj?5Xm zdw4@*1?0^S;<<=ZKag%sX2Kim!UO9(psXlhmhODU8(HPFf`$ubmrf<$!c>|9RGBJG zZgg)0Y>DdF1r*@Wi+mo2w~@;T$zNWKmClYU@7BY|@1p-v=k_Tb>_cO(p);)6(i=Aq z5E#P3J2`L#X*i868jJ-pYAko%! zo3?G+wr$(CZQHhO+qP|1W>(tPU$1k=_r|!5+lY4bVxQRa%(d9BF`6w&k=zDV!YbK~ zSvze=VNq~UvF2$m{pb2iu9C3-8G(Fwp8uLh_{i=OHOi*Z^eqJ@{?g&sF3U_!r;&cM za8LnA<3Z416wFv@_x5shm7dG{X;uVyGdK$!@b#)TMXS_^T0p`7Q)?4Zc*ry>?V4x@ z`*0Vgcg8`xX+H6?EGVnfE(r|^h7RmAY@T9iwu^#{oo5*erUs>Rit-1f+Ar7Kla8Fu zXEdv>!?f9loHLP!I5i@oS3B{yF}$L%dc)C9F`;-dE)NcEsnsEO_*SJRJJ>DJMpBKS zV4PS;8pSOfOyI#t$Ul>(`#uv|&KA$-rDQ}G_lx8JQ4I3AEf;?}U9BjZB?_l*Gpmm;&=a|VV z6xyv+ZNsDAL-W-C@%5XIJa6UC|5Y4R+hyB_T~baiwma=`m%jj{z2`KeRmjqI`f<{Y@Ts}Hw)0SA7lEXS@l zSKCVzB8t~P;g4!^UH#t5(7pc>WS7y3hA*xDc_31kIzyq}jF=k=tzF|V6 z)ZOv(xQCQYMz}@ss8tey)Uw%A51cTGb|Zm=k<& z@C)zwrKr`_y(y+V5;u#ZX!oSIMTd+}d6Uh>c!)>un$Z7+ z$b9zEZ1FvyXQ8OQRlmvj6q>F-m0j^YjSgz|!1%84oGokCtb1Ercam!H(ePJd z!S*{&fEH9b0pxlKY^GZMdVAreu*tA3agXM<=M@grPz(;S;#vm$znUBpOLq)0NCVDr^=Ek zbW&t~4_}~OVbx^9!Rz1|U(9L2^S=Cb3S5_?Gaj8IFFnQ5KJ%{gh3Pe1PoewL`fd&4 zWY*MV6*p9jJjw8tpVeM5^Ng4~{Diln zBBnK>Q(;I{KwDaNw4w>csyX4^4h^4#S#i*x_buvw!d<(3&-KZ#dD@b55IC(J72KH$ z)c&ORpYNW`m=&2RS5_QrRZM#eiHizsR@#_(fcVU*ZV|VPX{CAQ6gqE`b3{gGQf{E^ zoqY)^r1fqiGV5@07umW22NeqV_O`BkR8dG=n69#tPbJBY()e-r8$192;MH;E#I#NjGAZiO|7?grSw%BZCoB5_7KaPLt1&$%$;<&&L1J*keUQA zIt7GFzYKzb)1)VNj00N(I6DtQ*Qk|wfFtduo^lG2dd)fw8J$GfSetbGd{L$ybcGeX zksK$0M?~%jt@27J@kOaLEVIYS#z3DqyowujgTNJW((DWB+6SxliIs0^-(>M^@)=h= z!c?PM);=IuTiU*nYPIWY)B$(&GSb`+Crc$0mF_0{Gj1AcTkAq<3~)^`+smH4;7oL4 ziVn0Q6MmQQ7!O)YDXq90!CsE6cUE3L{ThC{&RaNOZA~LQ4FfoBFJD5$>+%7mI+|QY!6g8#iHSw9@dnfQ$*>S1%F_Iv(N-|CHql{ayhj6Z|9>!fdRs%4E z_H2xpJT5i8FQHqRl_l*NT-b-4ShG_alatVjgd4Ph@Y}M@bw!0~i1*!vk1S=h#JnfCzPYhn z-MnAp4-h;0ay69YnhjBwZl2E5*nQ90RopOvb|jqK&Bnk+=Aog!v54%g`Zr8g+My6h zxg{`>Z^I;5Pfs7@-mw0R17X?mWYmFP!> z_oAZ;_?OOM`=fMj%Yn&=ucWfZu^&3_AF(xS6;k=66Z5XZs}8m$Y)L+6_hwD2#@x=~ zM&6t+7n{Wp*~;t;6~Y(gAVf6k_$xWzVbyNMye^`;2PM7aex=ueU!U=4ov5MLZ2gow zZXg36JLf~Zp398TtG(!{=Tm?zLRqrl?p$yYsl?}`He~qFWMMQVH}@%-GL$}WgqMvp z|2Pm4HNF9Un5GO6FQNJdJ5PaQd3>*53;K0dM!IsRv;L~$DyMdF;Rco*zYH(++RAUf z1Kab z2JH*SyDP6m-SyN9$&+)j=M1dwt6*+6&rMy-A8gaiZ>(@!#0B2z@SusgzVq?qPM{M? zFjU5rI+AqE8>CV`uo(RF5tv&yJGKy^{3C1SZYdY}g6Nr4TfQ+n_fm|E+kAl1(FILA zAvh-mZlPY!BVet>`@f*n=@PZa=_SVtADrwHI1xC~f|E{&$a6PZN z@DtWdI3p|;)+N>S=3IXpuLhpe0Y*7I%DOBoAwl(Q3o z;#1M!qh+^zWu7DOovB`itT8a*`gxgM-T0Jm7Did*8>RWDNc0a9OQ_DyGH4&E^Vf#^ z3kd%dbu7I$k(_UON;$-{n)6|nkWGc{RJSgv z>B@5a;l~D!vK~#Y4SwGx^RD+r0S-{Am-lE@CVr}trr*wu_qbYjQ+RJ&4Y#O%7TmwbQ5f)^JzZN^C8Y+ z;}JZC>HAX?t0+jzJ;3NnME$pe^V24=v+wUz%-IFcR=ZqJ^)GlPLwoOkV}nfp3mg28 z-ueG$gKV7tGaGdOCv;k`vysv&Eln)!<}Q)$O2Ewk2+s`6EbK-=NU;~C1h|ApNwfnk zNw`a|hkNZg_dWjnYW?<`)n=Oi1A?D@^|&_V8^ zCGMi7?(P9W-rh!jg+m5O0ip!pAs`ASffd392O)IKKr^b@ag1&QQUJcbAq<*L!SAA@ zqn*Ctz$ZEb4iU5oPzoSLxB_%<a1tccA@%g+<>m1Tpo74{ z+S3isfINf}-~f0TfM8w$f&uzLfLj9S4)~`$95MmH;1EXeb@0u?pFoBN1Gon;jiAGb zZisdY2^er3+&KjFWq}K>p~8L$t-lBz0Dr1r1M_&f)Pv$XYn^*X959DIdp&?b#%Zd0N?}%_lEx4U$?LAp_4Q40D?A&0N4#YpwVygPh6O` zPvd=7e7Jj{jQibLJpO>&^|M>@=2JkMT$Sz7G!!^a1q& z90A%I8UO?IBy->gXJ^O&Z@>S1PSCgbxBUt@gopK$x1Y%hu-0Hekzb1r>OFrKk1tj< z8~<7u?t^`Di@_T+Oc;Yt^QYPOkawHgzPI0g^aJ;aU)vjh(|7;aAAfy`&E3uS_U!BS zf4N4$x&(83{t!|(a|Unz$T5TdXd1{cK^@&+?dq_QJ=##56}^xDEJ%VBLOp{7I1tOr zJ98($_F(sfMrX4u8AG!qWYis8DbdY>2OTtSSPcJ4F*L1`4XrLV_Zjp7TYvL6N1`p+p=lE>7yn zWdEp{%zyjBPTelEh^+gEkxTPiK`pIEVjPhP>RGIDOowI-Tmc3}yEn^Y`PrPFGgYEu zzcOQZqA0y4H_Pb-OUAz^^?lJZXrIRYeeKIr0Jy!eR9;A7zNhZ5!x-=mmg|pz$+#EM zxV9rJSyj;b`OzQG{dy8o;oYRy*I;_7hopJS5WXVMGZIjwqAqgi2F=tmE*L4K`wG0W zq|XK?kP|_3lC)s_k<((DXlLVvHd!rse+#bs7HBv*;LPw1-@-Ux~Uk^?=e%nozzX3!QPXeLEW8NdoeN zCYA3V@L6~0qdIt{BGK|6iSWL|n=i&zUr<-dAk>&XpYJ=)G@xddXX|>l@l4n0EvlY% z-!{a`N^>F8uq9oDR#?6v@!o}0i2Bi&N4AmZC!Fxxn=bRTp)D5*@PYMu`aUaO+TqC> zP$(1`i(iF)eZJRC)>tjk#Nb(><%dFd(mCq=u5mdGvTyml*RQ)Ii+}I(_GK+9jTs~9 z`bEH9ds{BP#?YX=$c+CH<5(B`*e>X1lSir*PsnB zyqxC2M{xt^usXE?!UGCsU;O}b!{o<7%BQOkGQNhTeRITPoKH_hHunN(68Pl+CIH=){wuKmBV@9$rgy zLpH?z*sD)bEFS^C*s|Z$k@+GKvk!xe?YUfa!5OY^+ht>&uC(dbNhP8?u}c8V`5N=M z(ShE%Y!&IM{(KC{E1Z*W($b}I!y2I?&y8Nre4)(VGYdRXrYwV}*LEypIhpvofrZCG zSMs`k3)-3x80`-+t%E%qc2DWZ0{PcFyT?HQ1((Vj&n80-oGj(?JM(spc{%1h=kSF`aKOY`+qqhfG_VxLd9;p|aMyG89RxQvju zBeytXn`KrUj_{f(doT^KVouN*BRD|x7HuV!m}}SMm5R|~UZa*9+2t3*oy`}JN>0~g zY~v_A{+~Uv0-~lBg)4JcKJT57$gXl1zHA^&OK%kR^x8 zGRu=-Bk1I82)m|=jnxkc@0PXQjc=Hbm4FtQUPgg#11R-Phx+KkwjXi2vU?UOpK5|K z9zrc^MO;L4#?rWUGl-j zl`e8ca&iP!d}ze4g-~&HaS`mc(LZmtb|H|DdE7EVYKPDMMEze_l_t{wWLdGPYmA9#j9syU4}_-HoQunTJER3A$Knt)@{=XoHPqzrp}VBM#DvK>%xBN z)L1zMhK04Txzt`p@_^!eWe&~6D~7`Yv3b8f^^#Vj(0zy(HTSgWkVfMK{JtFLhKv!J zCxsJHM`DaocAa!EI^zrMiwh%lYZ>PS2$i)4y#SO+X{?pU7okyDo!=9K7g_Z5*adPG z*PV9J$npK~+J^(}zB+oaszF$XZ}ajTojQiH^=d}zH2OhA!|CXUVzm+ zO%cqKS=&Lq_I9m7W_}k({rt%2Si1b2aJmcpFo`{MDqoL<{2~s_TG*{-XPM^aBA6l+s>pY&IA|=dEn(&fkmkyMm&l zCsmjn+D=I?eEH>3SHI*rVYX;n#WC#9WzyLR%o}E@<8*r&|1RXqNhSi{KcDxrghTi= zUX_!6Vpg4d8S!Ul%4e?Csa? zcYB40VnO?O5BhrQx8i`S&j@}u#yGrCbhO8@Y%rEE^fJkANViP!xyI4PF3zt`JK2=4 zS9AJAHC;Lq3Idfe9VM6qkOBN7RwI9)%sq;OV@gYYv&!?mh4jO!g}uoh3n<|w)LrAq zXJ#@OR2(=;rw9b#%Wk~IbaP^dTAB&2*5G)Zd?RA`(yTQw&M?$D@K3)RHZ^EjMGAzhX6+5b`^douIj#f7 zO|?C}3`T5$sOyv}L39Q^CeQwWvQA_v89m*Z-(TkaJTRiGat#P;8n?l@t`l`oN?*ib?hN@(? zXC*M$dqcu4;iTTf;i3`C*SFc>ha&k1Uyqw1V;bqyTC)gNSgCs?2~Cso;Zk-x{XA zZ()?RTW=zb7GQFy0uzB1wnHN8u^BBdS3w2Bm?q`O*5IrtMS9~H3}rYThY{hw%Og;o zbfNBk>N9eGoY^u_>ewhlE?Gid_Bo!pWYORHYre{8a-7P-fyYv~c454kl&f#b2)U18 zxr89>N&(@4T+NNT_db>g_N1jh{wqZuh)`S@y zhu2O|nwJ}u*p1yq38Y9adx!pG?Qsd}s5Rh~gOU7aDj=a8n|X`v0S`^O6MvVO2gtB* zx=ZlWnRdp#9^#=9?Ht3fUc~5cWci`!lhxPzeMI|p{JURQV7cZRNQcpk2mLf3R?LSw z?xO+79QWtV&!UyiGHOYmmKmjToh}I)Ags|Q3%6?&<#p&e?_I;XdklugG$5Rwa17u(cC#d>fnbPHslj8 zZ`+aZZdR;2_`P01=z}auBq+q=L^~=-98^>C6x7Z(TcV)Jmw% zlaXSh50g<5y99{{aQ3sP`g{W^mTkFxwQ58P?)q**vCT(DSq=g&Ee{zZ6K^=~KTjX( z{xodp-6eRp8gvY5=!_fdXrHh%Jt7pQBW9Qham}jl;pTmsUYb4<<-eq+zJ;K(d)%(m zZkV;lp5rrZFWaU%gg=a`OMCLE8Tr31AEWd~T@SG)m<5@gl^&Hy);arEyH5g|9@o}F zoQ_^+;Z}~n$I%@sWRft6mw3-Ie=vI;xdzrxX0S=OZuXKtBj>+e(%?M3;sei*2ARaPq&JWEC%I zm6-5^cA%{oMjgF~Lz+gQzO%birBkSlaMs)TD{O=r?Ym`3T$Nc6(wdRjWqmB5&8e|| zaACEXp=_r&4qjIoxH+;;b;~hCCh`@Ugw-JunSp@8h4>v5MN1eKGh+gaMGTdq$tNO|PuVP}b=!853 z9N^RA`scDJzDuV1mBHlg$OfEloT+siZ$L3tI_*n&tskJc=Y>9NwX~bR%s@8>F9k$H zulI+`C2Xs+G&Rvm!|K|U)lVI>PvxDd%cjUloHm35ib>turoPj)pckzOGla9K({%LP zg{sh}Kq!B+l)~{Y5$7SgtGzxqbw5?p;6yrwTq!MD56>zur~PpGb4zI2MxpbF}u-Gj3=A3z_=_i}mRM0{1&9HmWe z+qGmMagxu9Gup7_K3sO#IxJ+Q^q!Mn{JEOKF$Q^CILg;r3e%%o2RQQT*r_>sCbM<= zOo`TLxuvIoFR#M*o6L4z41R$wZ5mYFk&hXg-^&8ux1fT8s;yg4#?C`Q;i{lx6-S<_ z>wW1HtGTE0T4oH%pXQ|C;V8WM-WRq9E!zCL46S>7`P@5_UOoqKA_igc(`HBY1bBY` zoDEVC?wkwHZ}(bQhOR1_7A|TGp)Ty9w5tOG@f7#|Bd{0a56lE2d#kiXe+~n^#g5FA8*S1jPl25LZw2DJ?zX}91nYr`mPzIUnN@n5y9kt{4a7Am|Eyvt z#NZTd+?r&B4yPwW}%M~>P)&}|N4)F9#E}H7hhm|xlRR=@CC@! z5(xEPd0kUU7n{Y`@`KBk@|Qq4Md|mA;6cXwQdTqwQ7zOkAl+tPe0VG(&YgG#9iGSR z^G}TH>FOF9#CL>bl_AA>m34Yn8Vv|9#x;)%T?MIXWi|tbQTgtt-WOn}`4p~bx^rnqm7ve+@Alem-ETy@)#kx&pXb6>NYjs#0gh`# zgxp{0-6D2{%sGt7J6@|mYIc$%_ZxZ6%&X>2zn*AE$1d3gORV)x2dEDJKC_r8T?|*X zF^%F)*0v1yl&{>1IY_b_6Kqe>zHqR#h%kpN75&jv9kqkdUOT z|J3)VMBan7Fylq(2R8zQI@sss&x77$;2$1PLOm1#?t#H-wmNV#6G0q zDW_2p@mcVLmK;TKke8~y^&hu@14~i3YLT1(RQ=A-9{G*-&P19?c7Bfz7~wYUH)?7s z5c`+um44NV1t`%Q&!15kr5)&V^RDu?5VW4X7t~D3i+@ z&LkgxEeqzg1**%|kfKDZ(^bts1=eoEg=e&5MCf|H%_*%JtSoe#$g^$_G{p|zyFHIN z6CB@czMs@ZRVA=Z%O;tZmJHCv=LW1Q?mdKhg%4l5bWIpGFO6;-q&ySndz(%IE3}@I zww~C>v4_=nCxNya!mq7e#0@{t8HjEeq(|YWfsU6i#d>RhkJINkbg?vm+XOZU5O3s{ zszb%BAI!|iL)R_~!{1cdL4)>{@My%SY9~2iTiE(nqj9tI&$Exn?uWIdykV_QVm~5D zAo77NEf%foXd062Y-D{br;%G#26trT`f)cBo8-*3QD|Pr>Y_6pWS<}z+}=r=YIWO; z2BZ!D#7||+4rHcsJOUJ_*Hl*?)P8Jja6H3Lb0Ch203fLy+2+mn#%V*cQcCvO;RP(fKunBYIndM~qu{#-o2-Km@vYl= zi9)`kDh`j-sf9Ig)9TTs!xV0;B=pwuEuL(^%8 zGYJRHKGB!ZH@I9N(2h;jiZrAy{KAIiQ*?7()j(?AB*SeR!2Q!pL zmlDDX+!yOd<$=d&@YxWLM?A9L1<2i>kl*q&6{t0}&`HYl zr=1J9;^6Y-u+6BXNzffbu&Zp`x}odqpq}j-?B!0trjY0sd*-l=ttpfV!-cA87A zaA%DsOS3*)fQZlbP0)L+`Oe(VC>{GOCBfI*?**rDWU=^OCI4r?!OGtypd6nTuL2T*E@(PNI&5CVh;!<2eGqzh9!MU&Y|1eSe`Da+^zSd3{ zyMLfc39~%pVlLL&@SXCgqmH?IT6S6`_o~TiX<3R6{uMB-((!Q(U)>?=T2gC{t>uzC zkYJuHPZQY(?zNPT-k9z){03EL9wD?J z3nTz9$L^NOaCyhkC^Yw6$8VI8e3fO9)HRPdUp}&k2Tppzl0!sM<4w+V9_Fc@n@1oX zKgtlxOe1iF?pX`VNwKCISzpPsF0xnLie#m5r^&18Fu7aIn2rR%3Hl z4dqE|*6e4oAVx(NQM*{&w1WRzasJh*)E9NfYE~k|)nL&5(jf=mRA%pCt|H~GI%kco+z;eUpL%FrAtpJ?<>7EN=5#; zI4F-Sda(It1oL32|Ne+Gd9P-!c+Fl6j3mVS{x~GZspo8;la)LvJ>B*2l2SsZN-62} zQpUr%$E%<3-FClb-)=wt)<0`ofBRd1r|n76+Z$`+p+Ph=qOg}GR;CT?ZqMb4fvQji z%akrjdU^3d&;^iRlk~YH&254jF|&7Y^VK z1sf77CPG67u#brv=&;d-0#aj)i>9GSd3bPOB1uhTa7=71K!gx`FdPgZY2bi81_UwP z1%%vz{KMw(Zy>};j^XTM1LND>T0cu>IzfG83G zV|j3ZZP#D`h%n@Dk{w1OA<`2_A_WH$iY0_wR}l|ajD-kdj*yb~eBdH5&XIl76v)G{ zf{hL=P7h<^3V8a0!Q`llK8hqNP~99d1`x>S)wB>}fXPz@ni%D27A>!dcLNZ- z!vhD^U+s#SDs=zq8~3Fd&>r?%>L(ufPkz6nHhGTS!cr$yooKl`CdOre)ENrmMaMUW+L{L)V6Rk=QAHNUujl z(E`GxpqIS2r8pD!%$E&1L@NIMj2pY6BVUs*70s6i=~rFl-7xI^$Zq&HlEUzjHvn^MQM`JLT2f+BnkB za^i;RRM|wFM|=B>_ku{1S!+sQ9s$8EeS_{Uh6_R~q$+A|(puV6Ia4o_Ef?WiQR&2_NcuiN2R zlW^wQK67}ydumlKvADhFBL4m&e(IUBasQ*%Wukl6%nMStM2k1YP7+U#r!Lrdy`9|Z z-CTDYmv%$3>7yDmwpm4^hNU@Jj{h_qH%g)(WhNq4%n8$U(6ZQ<_WYNlT-S8MBKJJC zw&(5wX#IP&PMls>6YoLR(q4Bh;Kc)c4(nA2EFJg5ef$=nC95WRXZ@+t5ww0B91RGO zT&mdf4c1!kZvFJOyse6VPKgX>)4C*eW&ZO-{ipp!kMCT+KaJOq)BC6sTtWQ{<zc_07ztec9a3ubZSx#Z!K+w|nR z$J?0~sokO2{q~sd(;B&nZ9T7^iI#$l-J=eJI!fI)%3Q! zl-f8)&fzL0wtjExe^Dh18|&)D^b$h5NO{`dJ*_ljYirD{?e@BS6}ksxokwr%I$fJ) zr=FgE8oKP{z&phli0CEuzl|+k^2uk8&%1r~X?gA%m;7gm>yz9Q6JC9ToB7Oh!En^l z%~|G+JelMd;rN+#9By1f!0Op)6*xN&qT-EXL>2UdCnKf`^SKzLd28k8qyL#Qbe^JY zsnMl!c>Ml+r$AXhM{RzEyLrBl)#fjl`RFElj87#KHc`A9nN4AeElUK3abl2r9g1@~ z`80pATbii&T4-y?9E`Wdc4F`udLMd-x601ta-ixmQIVRLE=Y(^Gw6mVOKAwh=+^uK zCXc^E$a*cqgKkW$%TO}@(m-^QFfE4hpR0>_kB^?y%seyf`**9daxPGlk#?3v6*9Su zhfv+4wksv>1c1M}HTN}qUz9FaH zodlydZvof5oYrIUY}s%aHyp_xK(@MPE7|>&DqUqSKS~zw+9&p&$;mX|o%8gwSAW6t zNvatYW!04aO6chHl%ENeZ^j)e=XCE-WaE}6Kl6{i^=;bMk?3=;e`6_wys9a)+(P4H|MA5zdtw?NGo575+P4aG5GNoNjSvA81_-La2(my!vqM55WCU^-msmjrnRGaamH-F_G?+*P zyKh42BBg$RHkMFd>MxHCz@P=O*s z8E~gUh5XAiEg49I5OH6G0Ez!*z(IfUIp+rwdA~5(wvSQaJqQsGU=7LQMb6r7vbs{h zHXup?qKrYgDiWm>;*)**={Xf5#4jS^nzQ-WpAZ3&Oy$czhCLF3F%KG#QUs7Ccc>&U z1Lx$^n1mh*0-+Ekcg}v`y+S17u!5g(lq?@wV;JE{mzD$SSoF9;1xn+W&Q_#69F{}` z;s=*E>al-arq)BMv9?@(0L&e}+TJab%KLyPDE=@pV6X`|LL`X7A_cl40@TPbK#}SX zK&o<=t*t{)NgY6AObj@XkWe-YU^1u;CH)#vsTV3|q7llZd5jK*oJPxN==m0SBk4x)n8Z zBS7&UsOSkr{L2I9;3uP_x7_v}p}|2QXOW*E%aCB3V#js3CJU~SBw?B=c6 z{+(l|b-Pd6m#I88FXxdfeiNHdaW6_>4@$aq?n?936&5?sexByd_E#Ng`>~VkUAsTn z)nz2A>pM@u`etd}i&#TWt?Abx-c3p*zt;@BfG!{9_QT_drO(*7f^?EBi z?RI+t_43R$>fV3vDp8TTMKy%U+WTvKLmQ5cuoIGcH*O@o{6=Zz{AD0}PIVNIBipE$ z`Aa0dC0Q+BEEs$;cDR-t&Hd64#oa9T0Qirx7BAtmRg3q*cP5pu_FM#ayQUuOmsWZT z3*cn6bDc-a(_AZg+Rn&oM7}P8_$-cn%5&CWZKnI6AL_fF9?UyE36YFZHF8$*RR6S) zyj&>sH!iNFCFyb)+M;`#t)F#v+Y4oedf7smSzNwktsT~FN2;+T@99wVx>FPume2dR zU2J7+5f9TF%ZlByb+u-{keWYdp`#a3jfH~+7;Y{C4gNg1ds}K6*-Zb5(&_wR@b>g`)r=4MrfP zw0`CLnu=~E$LH~tKK^4Qe@(Vq3asYXrk1ZY`ql0gy`r7635J zgJE66-DSLbAN4wJP559`aeU+FoF=@N<$Kyk0)V+D8zkcd6ZbTZh>ku;-^|%^{ zK)Etd9SA!a#*2ub)MVAo{e`dP!8M7N+!l?EJ>#ZddfwZmQF+(S2Uh;(9oXi@2^;Gq zsu<;HlkTawEdFzK!`L?4;_MCOAKB~1lOmxH#{{4-y>1VOa-Vs0aP`>2tgmugyfAdPiz_4T zl(>1`v(xRh&OaLH98Bh#W3j*G%l=+PxoTH!7YErUdlzMpnu$wovqP1dI#}|6ft7ld}r}2m60E zAOx)J42=KlB)`_Nv_EcJ`^nQUjDHnnM0^FMpkv4+X(nwp$*j$QmlI2VTZ>fQwk&^L z?>8@`nMyKPj|PjSxapM3F+Hx)6#K0@t=s+(0NSbr3|`LL>YT z$|e#j4kS-;35^R~A+o_#mN*tRbRn!o54{h4+Cv*dW#Z7+z|hQ4(8vM7Yb#UO8f2X@ z!;w>=KrhIrPkD8mw#>joJ5VVsRSFHRY=H|6HpR4w4|Q9>3|rV684~{e>wAbw18e7{ zj)AHhD7`>vZVcT+yt>ekD&@+NCqS;P?y@!VE|R#fSYF4Lgyf#kp&}~ z(x5`wM)VZzfJo~%22|!GG~la|lmf&+l>=CGh~@)?0kn<-z)IMNR8Ry(PkTVlqLQ

    f0v7?FU42BG5J6Q%{wQX(>^g@ZmKhy^(TG@dve&^oeMD|7?Qv4jQheDKJ2 zfQx{6o}g5DxNn(2327j87GQyaYBhMEn}QVE6hiEYtq@hP3!Vj;2N6U9od+=mAVQ%& z2rz||K^F}EBN?D61}H=>m_;%WN*(lTktmfyLFhm>pamIv%$X#1Kv@H8g;ydGWI~Au zya0GqWpF3~%mX+wNP(A^z=Ew%Z!(f7*p>nWptw|6rl{U92`G%~`zK9$UGUsdG8-civuWqy3A>B^gphLv(>QO#3TcDz05$qE`<5;lCX?a;vdqxeNs zFbHVxtD@h2a1Y4?uAGFfs|uZ!QdM~8N*v+2iz-5) z3P?Z$ad zfvRt<#3iU?g-A-u7ED=8K-`C%qlYq3c5WKr3?Rs7Wiyae$;mB1b#c=GqbgrDfE6a| zu;c_;-hn80378a^m7EcnY?y1DESOdd6>#q5Kp=YwM}z(DO<`t-$ZU%T*^I`K8D;v` zszMn|s6MAN$E4xx!o)Bry!JT!hs$L`ldd*<$UIF%Zd_b>){a7(!?eVt!R+oN;baU- zrdv@O=ve{fiU>-KKMCO(bDIx|dDkLwqr4?n=QL<7*pXNi9+Zj(@I(!0iU&-AGqh9a z#b9kI6X%!?`By;TD#^O}h#stD8{%xE21F=c;3SUd)iW01B&<5{q415?GH=x%+K*bp z9%4cVe2ABg2Anm#CYumGl%8(z?APsn+QEvmb0_DyAlDEWZDY23fKQf=dxEFJ0@T!b z{9QmJS2JX_vLAPi2gf3_K?jZb+O}f>-R+Nq{grU8{?H5`l9_K(vfq^z*&P`7bBGP$6xm4 zakSW75EtXNsM;x!KYAxV6a>Elk+CLA9~sGKR-*rg3AIS{A! zjMj-8Ca~T~CY)8CUyH;-yo653Uc4w-r4y_*Xq{sB3f{Y0^DGo5C~Y=M?HR3qip|G+ z8+S%Xb)%h#9h}^kG7HY-%4<+yYYMVq72JUzq$8}j{dPY@qYBztRg3n+M!_3n$!S~& zLm##a8H8+)J>z#?Dr>w=+hf(YsaD@#lpvcyD%*+Q1OR(|9JW1{P!2iehrKG>Y!PdA z*g#)dhU|)u-5l64V83ze+9L=DbZ?Mj0)Kdb)`9cLBq4j3adzURC=DgHt(@qFgtd$; zX^|Rq&Xy!|c7mpx5X0T46!=31t#qoGSLD812qY@vi@VdddIg>SHH?-ccHF#C;xV%o zJ7RXoF9Q`|5hH3DgaHG9yf7gGrg<<(ELZ{okB~@6>!fXaxQrzzp2M_=#LhqgVAX73 z+qAo3%TEEU3jk~28&psR=&JFF{xGM6t~jR?L=sB5g!%rKa0nb(B-Ic|8TQuEGeXIeaT%ex@Du2l&b9AC#X$?d|--GiIt)hs5br(_ybbm zDNXu%NLECY(J>Qw+)yN@?^z{D{=deqJE*B|TT2xYL5hGhL$4tOLTCX&AoL!3GeGFQ zNe4mc0V#q=7Z8yqReDECq&G!+=pr4ZbMt$*%$<36-hDIYkF(cV`|NM_?6YRhx7K`1 zjwu@8rCI&p?l*E+l_DYV7}7?>sMK<3Bd1bS1SOSW`yNa3TQE#T!MKO^l}j|YwDCi` z=X_*F2L3Awg(-0zAAQh4%;SV~@+m zR;TWK);cP;~47FRM@hzp=^g<{pL?C?qJ7 z9W;>P6;KN5D`3hW9NY{i1=Su!OV??u)6jgUb;MPDR{t8iwSO-sOl`M^dgG*}IO&6t z*?XDq<}Nz)M`KXlqdJd_Xv$ir{AANNeiT)$WdrNw_%C4g_eCGxLdPmg`*ip^+0W#? zf^Ur0Dv{DPYB6NMm3?AAWvIZ^-lnTY!%?MpSgCn@>&AufSYl14uiL;~y+AcSrrl;L z*jLH4qO!+-z~lD`uvzFcbFS#0h`8A9wU2Z{YiYH<}UiDqyv>aZ+;(PBZj@ zD2U zS15B!(GnE_%E|u*BbUW){=nfPY0x>zLGKY*$a7l9UWN5j@h1%rrntzv^MGRF^<~aP zEDaI=DV)0}vH?V0xJ{32j>eEA*WAmo(lW`BGyFy4@Uh2;mpDh2d+{T$$v#k5YLHA= zJ|lLm8g5CgVD_=Ilo88qZwRa8&?Sr-cb;;pVyzzsWvA+SpK!)m$ZuK!Bf^N)*fOR> z`FmP!KTa~y7a`^*O7*Xo0? zQ@AvKCzA+Qi8ID-V+;L$-C-h~XLxeLmMd{rXK$z{#;{62lNtVUf-;_=IF%XuMq`0cVb##ssla<_HL*+2n5A_*nD3M?@1{TEmBT?PiEjcQ5b?atO zXHx%{RsPjmLq%MJ5KclT{dXHB!&}xBdNKKTU6AEivU0ao_|y6x`@&g;W06RaUW1AH zMb>Eu%eu3i{5zG_1AZ1Est|6g%pXF+%b(_}pRikH8ED7CeZAAErWKI(jEMON=fCsGL0=RZhJ>8>A~tt+$i)ZM^oElA9)@UF?#P=ey!x zP$hr$lum*N<7$k0f{bH@sdjnZgxu#6`IS7tD# z0|`av1#TI~WIF=kuUA3|6KO7t7+SUQZZ#HeP^&3ZhG`3{6MH|Nvhen_u6VhVog6RM zZZW|RO@*{^bEamEeSWp$ zx}viOi!QT=cAxZ($y=4r?ad_wAvsT4p}0Ili%)s3Z|VogD&pR<+?DocymXt^?=Hz} z%JpNhzVVF+yN6$`Ct+*zhr!GYkytUg`FA%l-Uu$m^$ofy{{g%;@)eM;>`jkIs6H%Z zKtb{n0PFW~FWF*3FwQzlDmMPur9zjj5%~|A9p3p^xfkJ=zm___Icbrop@IfX#Ls2^ z)TmrNuV(p9ax^>7Z&swvZp+V3+EMfYu_8LL&2C#lot;XjX!oKRY4aODrKTKq7ys;>7Wn)9=e;bx=1Wt*EoMYr~O7o>HQg}ujz4-A&0_g9K)SMwn=*qnQD zjigh*8MIDL$g)pa-Q;QgBHK57v4-_hBWW0>Pimjjw7xjMlT}_KDh)YE#6Wz#5~*Xa z+osBOr%O9;YF&$UxfUjs@m{}SD_a}NJV!jx@;7<|Iq3pWj`n~mak78`WI+7fo$UZv zh%maGaD!pHs){bSSij-yB|2Zxy?NSfS?FuR`?MNLQ^skl7fhQB`NcRk=G0<{F!uEa znf54CyNK4h4tenkEbEmmXJSfv4*3V6w3?DtTAS$iJP%XA-Y-Z!h`5}2R3F4H26r@1 z>P;jyE_c%|{PMpqdCcwo7_F*R9FSM=fOpe{GWW3O#4l-OzNJ?(KHiHX?Wh0UMCTW3 zed0dm{;HF9!Q(Y^nu1UyR(~++3rmt+%UQ$4L``?LmTm`nY{|-mez!{AO;ft6!tdRvi<;diGIX9V zS99dxiZ{9&_ahXMNjJ5>;u&cdXUeG=@h3;Q<;)XGe{Uq$!ZQ9Ne&pjEeZxniNiMH* z$K{ulknxyK!bOjBLkXUd!J}%v(w}Y-Td1>ErnG{?CZ_ZhPm|%nA2-;dUld5$j5gjM z0b*sjldawJh9ik@5L5CW;kpNkx0xSBAt(b?f=zZ)M+WCTD}yZB1T52UuOZLg2bs3< zCk|o{3ol=FoJP7Y-NI$J_Vmw!5h0HjH3#Dkt6MIQ)~lO{3p{iqe z3*~cVM&#t~{tA{MLXcbjc1Sl6<>Q)T_dFL&3Jj-TxI2``6z?jSbXnsFy+tV0J(udQ^nUu+ocBapN&ixY&SRC>)W<-D<#pD6@o}PWr z8gb@%(+6~|A27$1wMhqrTrSi1OK($qusc%HF@oJIE(9wIFGesM95W!#qX2z#vSgq* z*YgICo?4q06%0H2PDw3J^n&fMN``mBOON|w*v6Ti9t|%-e{(Mo&-U5^QIJoKJ8Y4J1 zS1@H#^G3<~;AHBxL%lS_GTEvp*QLKcADckW{5Eb)GQ`wL z)0P=H0C(f=^s17PU-4!0_lbIW#iZK;?_M3OjqTPDaE$n*6gwW;OeV6m%l%2d4XINx z#+>K0Nrp7W4X=Mt;?w^n4K@iO)4d$b+J+#}s)8aOK=#`9KS7~;%(^TA$74fSjRW!2 zW{bf;{Y6=|S-`0DC1UX|=M_w|dLVP)byZ%wt+aLBv;FPv+a2qtc_X}1qUmvHg-aDP zIiVcE9_$&^4$NX1|K&(p-P3V%ke0x!Chhsfq2tE!5)j{e?yh$1_a6Bmi}v%D#N&`%YP<(>EeFpw_w80;Z9mMZ$w-er$<80|!Jdk}R>~dX zWQ^{#5x&O$_|DV35@Mu=o_NTEIi4x)+^L2!s`G@GuU84UO%2xk82b?3;e#;m^klVV z);tLGmXEfKni1-#l`I~mdKStwo$!UO`>1m>09IOxRq+>X$Qb^zHno55YhodfKvPsj zRu8h#PZgdMA8by!6P9MoYgVv2G9SdcRWFBQxNd!wNX?I57;UlXE)=p$iy0Vp`F4t6H z3vl{fzh!}8$lYo8yE!Hr4Ia-E)hzbHPia--u2k3ovR%h4WKuv(^ zb0+J48}>I-8`NE^ZT*^!fl%Yk00RtDW8gT6x|`HIc3O=NwkS0(FXrVro(a0u1Zf-H zc}|s{#EFU%Xvs<`N)52D5Az~2=l#Y7UB2?UeY0_Kng9%HHFfI~{5-RmhduMt^$BqK zoJIumJNZ4opcY=!=Txv_50mSfKsSKjK8xuWDCvI%%{N|}9tJhm#jh;X6ik4)A2YK& zmfoR!qYVQmgap5~u$pdU`;Y~9>b;6tlY&9~EQMpzropuR)6JPQ`tpVAQ_%63yMstPN#@1L` zCWM(DN%nAz|NMLFR_UXke~Oy}A8XhdMhxTzr!Ga_e_|Q8CyJ-fYRIEqnMLbn`kmR` zL;Co`_2vAZPBQ8@E*}E~2+5uWLJQQKUwHTuPsD~aAh$Sbi14r8h+J{>T)PWrFYhQ4 zR>9~C?>4mShcJa?nrm(qm(1jZ9C&+p1T>4cPL^+>M1n8ugbg!8wk};fLfXY2zeh-I zB!*mV(NQ$f+9j$@VuE~^MYcCuZbE5-2IT$|X$}6jnmuh#Hya;olqZ14-NqJyG6I4H zAwq&+2rnr}-V=rNcEdfvng2O-aC22adZPe53X;M?V2F?eSR4!$m4HBiLJ)2tA#R+X zhMUcQb3u3_-Q7_(01zDM?1dr)X(JSk1mQl;&Q?fQ*T1kJ>>a!Sxa;qj1ONsoPcPik z01+HAu&9JE6euhx`cJ6;0}!C@;EMv_Fp2O2oZOM#_FgC?!1o{1pn_mQFfXZ$3;^Y7 z<7VYZ3Ksjnn0t|b5%QM%w+H-1>pOenaDw2@xXn;NS-aVwaBnB|^2TkM z3#s31cDkC|iqQSOy)zoGJ-qg8WqnSTJC*yY_`tH?9j-cYwao}wimTsJzD@TT(p}l~ z>zJjEj?}M3pk@SkU!Du!VR%yrcUC{H?TNtf+jE(yHlhiPR}YpZh}<*#d|R`~fj z);?;T^@O4P1Zi!X2X=a9&^@gY2-#K}sn~TUfBff1I@UEYM2Ad2eB|>*chyzPLIJx4 zyG1(%kB$X4j(pKZxuH-p1h%@<6bAiU>W5LX7=AblwPcr&E_N$ zCCkrfd<)zizqLh}Q)MOCsuF z5h|S(`x!GoHWJuSu{ucjhDlzpz2R+zSNO0*Mxbmq)rya1;>_|}u#JY8}1?8_5B2cymSDmWQ;U-)q#VbGL3fsxxD4RGyWrMQN4eU0+XF;}{?Qxd{}DSl$A;YEb!dq9 zkLLcg6}|H?k!Dv~6V1eBG%OxeFk!slC!l$x+zJw(;Z`I;7D{{>rsh z_<|;dke3b5V>_ne<2u-U?dgE-$!YC?@lN(rK6YN+UJG?t8Jm4W_*aw`H`S-F{8s?g z?^wZnlC*3qP&}m|P4cJpsBMP|!f9}U^^wswTKAKgCVNnZHZkL6K4p1lRMag-|4Iwa zjP9HdFS7lMYi27+ee-pSDk>w*d7VwVJ!MLsn`4|fCI~@}yHCa9^aZ)%o<6H} zHF~oBH1Ps4ol^9vWTweN48(r#)8%cn05`vKS{X-azhiY|87I0hri}gP0P(oGNk6@ApyLxNly$ro(L^nZi^8SGw!;?2aRFk$FcS zMzwi)w)l0xGJJ&pq|F_NjW(c Iwcwk literal 0 HcmV?d00001 diff --git a/docs/ghci/ghci.tex b/docs/ghci/ghci.tex new file mode 100644 index 00000000..c4638a67 --- /dev/null +++ b/docs/ghci/ghci.tex @@ -0,0 +1,1598 @@ +% +% (c) The OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE Project, +% Glasgow University, 1990-2000 +% + +% \documentstyle[preprint]{acmconf} +\documentclass[11pt]{article} +\oddsidemargin 0.1 in % Note that \oddsidemargin = \evensidemargin +\evensidemargin 0.1 in +\marginparwidth 0.85in % Narrow margins require narrower marginal notes +\marginparsep 0 in +\sloppy + +%\usepackage{epsfig} +\usepackage{shortvrb} +\MakeShortVerb{\@} + +%\newcommand{\note}[1]{{\em Note: #1}} +\newcommand{\note}[1]{{{\bf Note:}\sl #1}} +\newcommand{\ToDo}[1]{{{\bf ToDo:}\sl #1}} +\newcommand{\Arg}[1]{\mbox{${\tt arg}_{#1}$}} +\newcommand{\bottom}{\perp} + +\newcommand{\secref}[1]{Section~\ref{sec:#1}} +\newcommand{\figref}[1]{Figure~\ref{fig:#1}} +\newcommand{\Section}[2]{\section{#1}\label{sec:#2}} +\newcommand{\Subsection}[2]{\subsection{#1}\label{sec:#2}} +\newcommand{\Subsubsection}[2]{\subsubsection{#1}\label{sec:#2}} + +% DIMENSION OF TEXT: +\textheight 8.5 in +\textwidth 6.25 in + +\topmargin 0 in +\headheight 0 in +\headsep .25 in + + +\setlength{\parskip}{0.15cm} +\setlength{\parsep}{0.15cm} +\setlength{\topsep}{0cm} % Reduces space before and after verbatim, + % which is implemented using trivlist +\setlength{\parindent}{0cm} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + +\begin{document} + +\title{The GHCi Draft Design, round 2} +\author{MSR Cambridge Haskell Crew \\ + Microsoft Research Ltd., Cambridge} + +\maketitle + +%%%\tableofcontents +%%%\newpage + +%%-----------------------------------------------------------------%% +\section{Details} + +\subsection{Outline of the design} +\label{sec:details-intro} + +The design falls into three major parts: +\begin{itemize} +\item The compilation manager (CM), which coordinates the + system and supplies a HEP-like interface to clients. +\item The module compiler (@compile@), which translates individual + modules to interpretable or machine code. +\item The linker (@link@), + which maintains the executable image in interpreted mode. +\end{itemize} + +There are also three auxiliary parts: the finder, which locates +source, object and interface files, the summariser, which quickly +finds dependency information for modules, and the static info +(compiler flags and package details), which is unchanged over the +course of a session. + +This section continues with an overview of the session-lifetime data +structures. Then follows the finder (section~\ref{sec:finder}), +summariser (section~\ref{sec:summariser}), +static info (section~\ref{sec:staticinfo}), +and finally the three big sections +(\ref{sec:manager},~\ref{sec:compiler},~\ref{sec:linker}) +on the compilation manager, compiler and linker respectively. + +\subsubsection*{Some terminology} + +Lifetimes: the phrase {\bf session lifetime} covers a complete run of +GHCI, encompassing multiple recompilation runs. {\bf Module lifetime} +is a lot shorter, being that of data needed to translate a single +module, but then discarded, for example Core, AbstractC, Stix trees. + +Data structures with module lifetime are well documented and understood. +This document is mostly concerned with session-lifetime data. +Most of these structures are ``owned'' by CM, since that's +the only major component of GHCI which deals with session-lifetime +issues. + +Modules and packages: {\bf home} refers to modules in this package, +precisely the ones tracked and updated by the compilation manager. +{\bf Package} refers to all other packages, which are assumed static. + +\subsubsection*{A summary of all session-lifetime data structures} + +These structures have session lifetime but not necessarily global +visibility. Subsequent sections elaborate who can see what. +\begin{itemize} +\item {\bf Home Symbol Table (HST)} (owner: CM) holds the post-renaming + environments created by compiling each home module. +\item {\bf Home Interface Table (HIT)} (owner: CM) holds in-memory + representations of the interface file created by compiling + each home module. +\item {\bf Unlinked Images (UI)} (owner: CM) are executable but as-yet + unlinked translations of home modules only. +\item {\bf Module Graph (MG)} (owner: CM) is the current module graph. +\item {\bf Static Info (SI)} (owner: CM) is the package configuration + information (PCI) and compiler flags (FLAGS). +\item {\bf Persistent Compiler State (PCS)} (owner: @compile@) + is @compile@'s private cache of information about package + modules. +\item {\bf Persistent Linker State (PLS)} (owner: @link@) is + @link@'s private information concerning the the current + state of the (in-memory) executable image. +\end{itemize} + + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{The finder (\mbox{\tt type Finder})} +\label{sec:finder} + +@Path@ could be an indication of a location in a filesystem, or it +could be some more generic kind of resource identifier, a URL for +example. +\begin{verbatim} + data Path = ... +\end{verbatim} + +And some names. @Module@s are now used as primary keys for various +maps, so they are given a @Unique@. +\begin{verbatim} + type ModName = String -- a module name + type PkgName = String -- a package name + type Module = -- contains ModName and a Unique, at least +\end{verbatim} + +A @ModLocation@ says where a module is, what it's called and in what +form it is. +\begin{verbatim} + data ModLocation = SourceOnly Module Path -- .hs + | ObjectCode Module Path Path -- .o, .hi + | InPackage Module PkgName + -- examine PCI to determine package Path +\end{verbatim} + +The module finder generates @ModLocation@s from @ModName@s. We expect +it will assume packages to be static, but we want to be able to track +changes in home modules during the session. Specifically, we want to +be able to notice that a module's object and interface have been +updated, presumably by a compile run outside of the GHCI session. +Hence the two-stage type: +\begin{verbatim} + type Finder = ModName -> IO ModLocation + newFinder :: PCI -> IO Finder +\end{verbatim} +@newFinder@ examines the package information right at the start, but +returns an @IO@-typed function which can inspect home module changes +later in the session. + + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{The summariser (\mbox{\tt summarise})} +\label{sec:summariser} + +A @ModSummary@ records the minimum information needed to establish the +module graph and determine whose source has changed. @ModSummary@s +can be created quickly. +\begin{verbatim} + data ModSummary = ModSummary + ModLocation -- location and kind + (Maybe (String, Fingerprint)) + -- source and fingerprint if .hs + (Maybe [ModName]) -- imports if .hs or .hi + + type Fingerprint = ... -- file timestamp, or source checksum? + + summarise :: ModLocation -> IO ModSummary +\end{verbatim} + +The summary contains the location and source text, and the location +contains the name. We would like to remove the assumption that +sources live on disk, but I'm not sure this is good enough yet. + +\ToDo{Should @ModSummary@ contain source text for interface files too?} +\ToDo{Also say that @ModIFace@ contains its module's @ModSummary@ (why?).} + + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{Static information (SI)} +\label{sec:staticinfo} + +PCI, the package configuration information, is a list of @PkgInfo@, +each containing at least the following: +\begin{verbatim} + data PkgInfo + = PkgInfo PkgName -- my name + Path -- path to my base location + [PkgName] -- who I depend on + [ModName] -- modules I supply + [Unlinked] -- paths to my object files + + type PCI = [PkgInfo] +\end{verbatim} +The @Path@s in it, including those in the @Unlinked@s, are set up +when GHCI starts. + +FLAGS is a bunch of compiler options. We haven't figured out yet how +to partition them into those for the whole session vs those for +specific source files, so currently the best we can do is: +\begin{verbatim} + data FLAGS = ... +\end{verbatim} + +The static information (SI) is the both of these: +\begin{verbatim} + data SI = SI PCI + FLAGS +\end{verbatim} + + + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{The Compilation Manager (CM)} +\label{sec:manager} + +\subsubsection{Data structures owned by CM} + +CM maintains two maps (HST, HIT) and a set (UI). It's important to +realise that CM only knows about the map/set-ness, and has no idea +what a @ModDetails@, @ModIFace@ or @Linkable@ is. Only @compile@ and +@link@ know that, and CM passes these types around without +inspecting them. + +\begin{itemize} +\item + {\bf Home Symbol Table (HST)} @:: FiniteMap Module ModDetails@ + + The @ModDetails@ (a couple of layers down) contain tycons, classes, + instances, etc, collectively known as ``entities''. Referrals from + other modules to these entities is direct, with no intervening + indirections of any kind; conversely, these entities refer directly + to other entities, regardless of module boundaries. HST only holds + information for home modules; the corresponding wired-up details + for package (non-home) modules are created on demand in the package + symbol table (PST) inside the persistent compiler's state (PCS). + + CM maintains the HST, which is passed to, but not modified by, + @compile@. If compilation of a module is successful, @compile@ + returns the resulting @ModDetails@ (inside the @CompResult@) which + CM then adds to HST. + + CM throws away arbitrarily large parts of HST at the start of a + rebuild, and uses @compile@ to incrementally reconstruct it. + +\item + {\bf Home Interface Table (HIT)} @:: FiniteMap Module ModIFace@ + + (Completely private to CM; nobody else sees this). + + Compilation of a module always creates a @ModIFace@, which contains + the unlinked symbol table entries. CM maintains this @FiniteMap@ + @ModName@ @ModIFace@, with session lifetime. CM never throws away + @ModIFace@s, but it does update them, by passing old ones to + @compile@ if they exist, and getting new ones back. + + CM acquires @ModuleIFace@s from @compile@, which it only applies + to modules in the home package. As a result, HIT only contains + @ModuleIFace@s for modules in the home package. Those from other + packages reside in the package interface table (PIT) which is a + component of PCS. + +\item + {\bf Unlinked Images (UI)} @:: Set Linkable@ + + The @Linkable@s in UI represent executable but as-yet unlinked + module translations. A @Linkable@ can contain the name of an + object, archive or DLL file. In interactive mode, it may also be + the STG trees derived from translating a module. So @compile@ + returns a @Linkable@ from each successful run, namely that of + translating the module at hand. + + At link-time, CM supplies @Linkable@s for the upwards closure of + all packages which have changed, to @link@. It also examines the + @ModSummary@s for all home modules, and by examining their imports + and the SI.PCI (package configuration info) it can determine the + @Linkable@s from all required imported packages too. + + @Linkable@s and @ModIFace@s have a close relationship. Each + translated module has a corresponding @Linkable@ somewhere. + However, there may be @Linkable@s with no corresponding modules + (the RTS, for example). Conversely, multiple modules may share a + single @Linkable@ -- as is the case for any module from a + multi-module package. For these reasons it seems appropriate to + keep the two concepts distinct. @Linkable@s also provide + information about the sequence in which individual package + components should be linked, and that isn't the business of any + specific module to know. + + CM passes @compile@ a module's old @ModIFace@, if it has one, in + the hope that the module won't need recompiling. If so, @compile@ + can just return the new @ModDetails@ created from it, and CM will + re-use the old @ModIFace@. If the module {\em is} recompiled (or + scheduled to be loaded from disk), @compile@ returns both the + new @ModIFace@ and new @Linkable@. + +\item + {\bf Module Graph (MG)} @:: known-only-to-CM@ + + Records, for CM's purposes, the current module graph, + up-to-dateness and summaries. More details when I get to them. + Only contains home modules. +\end{itemize} +Probably all this stuff is rolled together into the Persistent CM +State (PCMS): +\begin{verbatim} + data PCMS = PCMS HST HIT UI MG + emptyPCMS :: IO PCMS +\end{verbatim} + +\subsubsection{What CM implements} +It pretty much implements the HEP interface. First, though, define a +containing structure for the state of the entire CM system and its +subsystems @compile@ and @link@: +\begin{verbatim} + data CmState + = CmState PCMS -- CM's stuff + PCS -- compile's stuff + PLS -- link's stuff + SI -- the static info, never changes + Finder -- the finder +\end{verbatim} + +The @CmState@ is threaded through the HEP interface. In reality +this might be done using @IORef@s, but for clarity: +\begin{verbatim} + type ModHandle = ... (opaque to CM/HEP clients) ... + type HValue = ... (opaque to CM/HEP clients) ... + + cmInit :: FLAGS + -> [PkgInfo] + -> IO CmState + + cmLoadModule :: CmState + -> ModName + -> IO (CmState, Either [SDoc] ModHandle) + + cmGetExpr :: ModHandle + -> CmState + -> String -> IO (CmState, Either [SDoc] HValue) + + cmRunExpr :: HValue -> IO () -- don't need CmState here +\end{verbatim} +Almost all the huff and puff in this document pertains to @cmLoadModule@. + + +\subsubsection{Implementing \mbox{\tt cmInit}} +@cmInit@ creates an empty @CmState@ using @emptyPCMS@, @emptyPCS@, +@emptyPLS@, making SI from the supplied flags and package info, and +by supplying the package info the @newFinder@. + + +\subsubsection{Implementing \mbox{\tt cmLoadModule}} + +\begin{enumerate} +\item {\bf Downsweep:} using @finder@ and @summarise@, chase from + the given module to + establish the new home module graph (MG). Do not chase into + package modules. +\item Remove from HIT, HST, UI any modules in the old MG which are + not in the new one. The old MG is then replaced by the new one. +\item Topologically sort MG to generate a bottom-to-top traversal + order, giving a worklist. +\item {\bf Upsweep:} call @compile@ on each module in the worklist in + turn, passing it + the ``correct'' HST, PCS, the old @ModIFace@ if + available, and the summary. ``Correct'' HST in the sense that + HST contains only the modules in the this module's downward + closure, so that @compile@ can construct the correct instance + and rule environments simply as the union of those in + the module's downward closure. + + If @compile@ doesn't return a new interface/linkable pair, + compilation wasn't necessary. Either way, update HST with + the new @ModDetails@, and UI and HIT respectively if a + compilation {\em did} occur. + + Keep going until the root module is successfully done, or + compilation fails. + +\item If the previous step terminated because compilation failed, + define the successful set as those modules in successfully + completed SCCs, i.e. all @Linkable@s returned by @compile@ excluding + those from modules in any cycle which includes the module which failed. + Remove from HST, HIT, UI and MG all modules mentioned in MG which + are not in the successful set. Call @link@ with the successful + set, + which should succeed. The net effect is to back off to a point + in which those modules which are still aboard are correctly + compiled and linked. + + If the previous step terminated successfully, + call @link@ passing it the @Linkable@s in the upward closure of + all those modules for which @compile@ produced a new @Linkable@. +\end{enumerate} +As a small optimisation, do this: +\begin{enumerate} +\item[3a.] Remove from the worklist any module M where M's source + hasn't changed and neither has the source of any module in M's + downward closure. This has the effect of not starting the upsweep + right at the bottom of the graph when that's not needed. + Source-change checking can be done quickly by CM by comparing + summaries of modules in MG against corresponding + summaries from the old MG. +\end{enumerate} + + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{The compiler (\mbox{\tt compile})} +\label{sec:compiler} + +\subsubsection{Data structures owned by \mbox{\tt compile}} + +{\bf Persistent Compiler State (PCS)} @:: known-only-to-compile@ + +This contains info about foreign packages only, acting as a cache, +which is private to @compile@. The cache never becomes out of +date. There are three parts to it: + + \begin{itemize} + \item + {\bf Package Interface Table (PIT)} @:: FiniteMap Module ModIFace@ + + @compile@ reads interfaces from modules in foreign packages, and + caches them in the PIT. Subsequent imports of the same module get + them directly out of the PIT, avoiding slow lexing/parsing phases. + Because foreign packages are assumed never to become out of date, + all contents of PIT remain valid forever. @compile@ of course + tries to find package interfaces in PIT in preference to reading + them from files. + + Both successful and failed runs of @compile@ can add arbitrary + numbers of new interfaces to the PIT. The failed runs don't matter + because we assume that packages are static, so the data cached even + by a failed run is valid forever (ie for the rest of the session). + + \item + {\bf Package Symbol Table (PST)} @:: FiniteMap Module ModDetails@ + + Adding an package interface to PIT doesn't make it directly usable + to @compile@, because it first needs to be wired (renamed + + typechecked) into the sphagetti of the HST. On the other hand, + most modules only use a few entities from any imported interface, + so wiring-in the interface at PIT-entry time might be a big time + waster. Also, wiring in an interface could mean reading other + interfaces, and we don't want to do that unnecessarily. + + The PST avoids these problems by allowing incremental wiring-in to + happen. Pieces of foreign interfaces are copied out of the holding + pen (HP), renamed, typechecked, and placed in the PST, but only as + @compile@ discovers it needs them. In the process of incremental + renaming/typechecking, @compile@ may need to read more package + interfaces, which are added to the PIT and hence to + HP.~\ToDo{How? When?} + + CM passes the PST to @compile@ and is returned an updated version + on both success and failure. + + \item + {\bf Holding Pen (HP)} @:: HoldingPen@ + + HP holds parsed but not-yet renamed-or-typechecked fragments of + package interfaces. As typechecking of other modules progresses, + fragments are removed (``slurped'') from HP, renamed and + typechecked, and placed in PCS.PST (see above). Slurping a + fragment may require new interfaces to be read into HP. The hope + is, though, that many fragments will never get slurped, reducing + the total number of interfaces read (as compared to eager slurping). + + \end{itemize} + + PCS is opaque to CM; only @compile@ knows what's in it, and how to + update it. Because packages are assumed static, PCS never becomes + out of date. So CM only needs to be able to create an empty PCS, + with @emptyPCS@, and thence just passes it through @compile@ with + no further ado. + + In return, @compile@ must promise not to store in PCS any + information pertaining to the home modules. If it did so, CM would + need to have a way to remove this information prior to commencing a + rebuild, which conflicts with PCS's opaqueness to CM. + + + + +\subsubsection{What {\tt compile} does} +@compile@ is necessarily somewhat complex. We've decided to do away +with private global variables -- they make the design specification +less clear, although the implementation might use them. Without +further ado: +\begin{verbatim} + compile :: SI -- obvious + -> Finder -- to find modules + -> ModSummary -- summary, including source + -> Maybe ModIFace + -- former summary, if avail + -> HST -- for home module ModDetails + -> PCS -- IN: the persistent compiler state + + -> IO CompResult + + data CompResult + = CompOK ModDetails -- new details (== HST additions) + (Maybe (ModIFace, Linkable)) + -- summary and code; Nothing => compilation + -- not needed (old summary and code are still valid) + PCS -- updated PCS + [SDoc] -- warnings + + | CompErrs PCS -- updated PCS + [SDoc] -- warnings and errors + + data PCS + = MkPCS PIT -- package interfaces + PST -- post slurping global symtab contribs + HoldingPen -- pre slurping interface bits and pieces + + emptyPCS :: IO PCS -- since CM has no other way to make one +\end{verbatim} +Although @compile@ is passed three of the global structures (FLAGS, +HST and PCS), it only modifies PCS. The rest are modified by CM as it +sees fit, from the stuff returned in the @CompResult@. + +@compile@ is allowed to return an updated PCS even if compilation +errors occur, since the information in it pertains only to foreign +packages and is assumed to be always-correct. + +What @compile@ does: \ToDo{A bit vague ... needs refining. How does + @finder@ come into the game?} +\begin{itemize} +\item Figure out if this module needs recompilation. + \begin{itemize} + \item If there's no old @ModIFace@, it does. Else: + \item Compare the @ModSummary@ supplied with that in the + old @ModIFace@. If the source has changed, recompilation + is needed. Else: + \item Compare the usage version numbers in the old @ModIFace@ with + those in the imported @ModIFace@s. All needed interfaces + for this should be in either HIT or PIT. If any version + numbers differ, recompilation is needed. + \item Otherwise it isn't needed. + \end{itemize} + +\item + If recompilation is not needed, create a new @ModDetails@ from the + old @ModIFace@, looking up information in HST and PCS.PST as + necessary. Return the new details, a @Nothing@ denoting + compilation was not needed, the PCS \ToDo{I don't think the PCS + should be updated, but who knows?}, and an empty warning list. + +\item + Otherwise, compilation is needed. + + If the module is only available in object+interface form, read the + interface, make up details, create a linkable pointing at the + object code. \ToDo{Does this involve reading any more interfaces? Does + it involve updating PST?} + + Otherwise, translate from source, then create and return: an + details, interface, linkable, updated PST, and warnings. + + When looking for a new interface, search HST, then PCS.PIT, and only + then read from disk. In which case add the new interface(s) to + PCS.PIT. + + \ToDo{If compiling a module with a boot-interface file, check the + boot interface against the inferred interface.} +\end{itemize} + + +\subsubsection{Contents of \mbox{\tt ModDetails}, + \mbox{\tt ModIFace} and \mbox{\tt HoldingPen}} +Only @compile@ can see inside these three types -- they are opaque to +everyone else. @ModDetails@ holds the post-renaming, +post-typechecking environment created by compiling a module. + +\begin{verbatim} + data ModDetails + = ModDetails { + moduleExports :: Avails + moduleEnv :: GlobalRdrEnv -- == FM RdrName [Name] + typeEnv :: FM Name TyThing -- TyThing is in TcEnv.lhs + instEnv :: InstEnv + fixityEnv :: FM Name Fixity + ruleEnv :: FM Id [Rule] + } +\end{verbatim} + +@ModIFace@ is nearly the same as @ParsedIFace@ from @RnMonad.lhs@: +\begin{verbatim} + type ModIFace = ParsedIFace -- not really, but ... + data ParsedIface + = ParsedIface { + pi_mod :: Module, -- Complete with package info + pi_vers :: Version, -- Module version number + pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + pi_usages :: [ImportVersion OccName], -- Usages + pi_exports :: [ExportItem], -- Exports + pi_insts :: [RdrNameInstDecl], -- Local instance declarations + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, + -- with their version + pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version + pi_deprecs :: [RdrNameDeprecation] -- Deprecations + } +\end{verbatim} + +@HoldingPen@ is a cleaned-up version of that found in @RnMonad.lhs@, +retaining just the 3 pieces actually comprising the holding pen: +\begin{verbatim} + data HoldingPen + = HoldingPen { + iDecls :: DeclsMap, -- A single, global map of Names to decls + + iInsts :: IfaceInsts, + -- The as-yet un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + -- Each is 'gated' by the names that must be available before + -- this instance decl is needed. + + iRules :: IfaceRules + -- Similar to instance decls, only for rules + } +\end{verbatim} + +%%-- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --%% +\subsection{The linker (\mbox{\tt link})} +\label{sec:linker} + +\subsubsection{Data structures owned by the linker} + +In the same way that @compile@ has a persistent compiler state (PCS), +the linker has a persistent (session-lifetime) state, PLS, the +Linker's Persistent State. In batch mode PLS is entirely irrelevant, +because there is only a single link step, and can be a unit value +ignored by everybody. In interactive mode PLS is composed of the +following three parts: + +\begin{itemize} +\item +\textbf{The Source Symbol Table (SST)}@ :: FiniteMap RdrName HValue@ + The source symbol table is used when linking interpreted code. + Unlinked interpreted code consists of an STG tree where + the leaves are @RdrNames@. The linker's job is to resolve these to + actual addresses (the alternative is to resolve these lazily when + the code is run, but this requires passing the full symbol table + through the interpreter and the repeated lookups will probably be + expensive). + + The source symbol table therefore maps @RdrName@s to @HValue@s, for + every @RdrName@ that currently \emph{has} an @HValue@, including all + exported functions from object code modules that are currently + linked in. Linking therefore turns a @StgTree RdrName@ into an + @StgTree HValue@. + + It is important that we can prune this symbol table by throwing away + the mappings for an entire module, whenever we recompile/relink a + given module. The representation is therefore probably a two-level + mapping, from module names, to function/constructor names, to + @HValue@s. + +\item \textbf{The Object Symbol Table (OST)}@ :: FiniteMap String Addr@ + This is a lower level symbol table, mapping symbol names in object + modules to their addresses in memory. It is used only when + resolving the external references in an object module, and contains + only entries that are defined in object modules. + + Why have two symbol tables? Well, there is a clear distinction + between the two: the source symbol table maps Haskell symbols to + Haskell values, and the object symbol table maps object symbols to + addresses. There is some overlap, in that Haskell symbols certainly + have addresses, and we could look up a Haskell symbol's address by + manufacturing the right object symbol and looking that up in the + object symbol table, but this is likely to be slow and would force + us to extend the object symbol table with all the symbols + ``exported'' by interpreted code. Doing it this way enables us to + decouple the object management subsystem from the rest of the linker + with a minimal interface; something like + + \begin{verbatim} + loadObject :: Unlinked -> IO Object + unloadModule :: Unlinked -> IO () + lookupSymbol :: String -> IO Addr + \end{verbatim} + + Rather unfortunately we need @lookupSymbol@ in order to populate the + source symbol table when linking in a new compiled module. Our + object management subsystem is currently written in C, so decoupling + this interface as much as possible is highly desirable. + +\item + {\bf Linked Image (LI)} @:: no-explicit-representation@ + + LI isn't explicitly represented in the system, but we record it + here for completeness anyway. LI is the current set of + linked-together module, package and other library fragments + constituting the current executable mass. LI comprises: + \begin{itemize} + \item Machine code (@.o@, @.a@, @.DLL@ file images) in memory. + These are loaded from disk when needed, and stored in + @malloc@ville. To simplify storage management, they are + never freed or reused, since this creates serious + complications for storage management. When no longer needed, + they are simply abandoned. New linkings of the same object + code produces new copies in memory. We hope this not to be + too much of a space leak. + \item STG trees, which live in the GHCI heap and are managed by the + storage manager in the usual way. They are held alive (are + reachable) via the @HValue@s in the OST. Such @HValue@s are + applications of the interpreter function to the trees + themselves. Linking a tree comprises travelling over the + tree, replacing all the @Id@s with pointers directly to the + relevant @_closure@ labels, as determined by searching the + OST. Once the leaves are linked, trees are wrapped with the + interpreter function. The resulting @HValue@s then behave + indistinguishably from compiled versions of the same code. + \end{itemize} + Because object code is outside the heap and never deallocated, + whilst interpreted code is held alive via the HST, there's no need + to have a data structure which ``is'' the linked image. + + For batch compilation, LI doesn't exist because OST doesn't exist, + and because @link@ doesn't load code into memory, instead just + invokes the system linker. + + \ToDo{Do we need to say anything about CAFs and SRTs? Probably ...} +\end{itemize} +As with PCS, CM has no way to create an initial PLS, so we supply +@emptyPLS@ for that purpose. + +\subsubsection{The linker's interface} + +In practice, the PLS might be hidden in the I/O monad rather +than passed around explicitly. (The same might be true for PCS). +Anyway: + +\begin{verbatim} + data PLS -- as described above; opaque to everybody except the linker + + link :: PCI -> ??? -> [[Linkable]] -> PLS -> IO LinkResult + + data LinkResult = LinkOK PLS + | LinkErrs PLS [SDoc] + + emptyPLS :: IO PLS -- since CM has no other way to make one +\end{verbatim} + +CM uses @link@ as follows: + +After repeatedly using @compile@ to compile all modules which are +out-of-date, the @link@ is invoked. The @[[Linkable]]@ argument to +@link@ represents the list of (recursive groups of) home modules which +have been newly compiled, along with @Linkable@s for each of +the packages in use (the compilation manager knows which external +packages are referenced by the home package). The order of the list +is important: it is sorted in such a way that linking any prefix of +the list will result in an image with no unresolved references. Note +that for batch linking there may be further restrictions; for example +it may not be possible to link recursive groups containing libraries. + +@link@ does the following: + +\begin{itemize} + \item + In batch mode, do nothing. In interactive mode, + examine the supplied @[[Linkable]]@ to determine which home + module @Unlinked@s are new. Remove precisely these @Linkable@s + from PLS. (In fact we really need to remove their upwards + transitive closure, but I think it is an invariant that CM will + supply an upwards transitive closure of new modules). + See below for descriptions of @Linkable@ and @Unlinked@. + + \item + Batch system: invoke the external linker to link everything in one go. + Interactive: bind the @Unlinked@s for the newly compiled modules, + plus those for any newly required packages, into PLS. + + Note that it is the linker's responsibility to remember which + objects and packages have already been linked. By comparing this + with the @Linkable@s supplied to @link@, it can determine which + of the linkables in LI are out of date +\end{itemize} + +If linking in of a group should fail for some reason, @link@ should +not modify its PLS at all. In other words, linking each group +is atomic; it either succeeds or fails. + +\subsubsection*{\mbox{\tt Unlinked} and \mbox{\tt Linkable}} + +Two important types: @Unlinked@ and @Linkable@. The latter is a +higher-level representation involving multiple of the former. +An @Unlinked@ is a reference to unlinked executable code, something +a linker could take as input: + +\begin{verbatim} + data Unlinked = DotO Path + | DotA Path + | DotDLL Path + | Trees [StgTree RdrName] +\end{verbatim} + +The first three describe the location of a file (presumably) +containing the code to link. @Trees@, which only exists in +interactive mode, gives a list of @StgTrees@, in which the unresolved +references are @RdrNames@ -- hence it's non-linkedness. Once linked, +those @RdrNames@ are replaced with pointers to the machine code +implementing them. + +A @Linkable@ gathers together several @Unlinked@s and associates them +with either a module or package: + +\begin{verbatim} + data Linkable = LM Module [Unlinked] -- a module + | LP PkgName -- a package +\end{verbatim} + +The order of the @Unlinked@s in the list is important, as +they are linked in left-to-right order. The @Unlinked@ objects for a +particular package can be obtained from the package configuration (see +Section \ref{sec:staticinfo}). + +\ToDo{When adding @Addr@s from an object module to SST, we need to + somehow find out the @RdrName@s of the symbols exported by that + module. + So we'd need to pass in the @ModDetails@ or @ModIFace@ or some such?} + + + +%%-----------------------------------------------------------------%% +\section{Background ideas} +\subsubsection*{Out of date, but correct in spirit} + +\subsection{Restructuring the system} + +At the moment @hsc@ compiles one source module into C or assembly. +This functionality is pushed inside a function called @compile@, +introduced shortly. The main new chunk of code is CM, the compilation manager, +which supervises multiple runs of @compile@ so as to create up-to-date +translations of a whole bunch of modules, as quickly as possible. +CM also employs some minor helper functions, @finder@, @summarise@ and +@link@, to do its work. + +Our intent is to allow CM to be used as the basis either of a +multi-module, batch mode compilation system, or to supply an +interactive environment similar to that of Hugs. +Only minor modifications to the behaviour of @compile@ and @link@ +are needed to give these different behaviours. + +CM and @compile@, and, for interactive use, an interpreter, are the +main code components. The most important data structure is the global +symbol table; much design effort has been expended thereupon. + + +\subsection{How the global symbol table is implemented} + +The top level symbol table is a @FiniteMap@ @ModuleName@ +@ModuleDetails@. @ModuleDetails@ contains essentially the environment +created by compiling a module. CM manages this finite map, adding and +deleting module entries as required. + +The @ModuleDetails@ for a module @M@ contains descriptions of all +tycons, classes, instances, values, unfoldings, etc (henceforth +referred to as ``entities''), available from @M@. These are just +trees in the GHCI heap. References from other modules to these +entities is direct -- when you have a @TyCon@ in your hand, you really +have a pointer directly to the @TyCon@ structure in the defining module, +rather than some kind of index into a global symbol table. So there +is a global symbol table, but it has a distributed (sphagetti-like?) +nature. + +This gives fast and convenient access to tycon, class, instance, +etc, information. But because there are no levels of indirection, +there's a problem when we replace @M@ with an updated version of @M@. +We then need to find all references to entities in the old @M@'s +sphagetti, and replace them with pointers to the new @M@'s sphagetti. +This problem motivates a large part of the design. + + + +\subsection{Implementing incremental recompilation -- simple version} +Given the following module graph +\begin{verbatim} + D + / \ + / \ + B C + \ / + \ / + A +\end{verbatim} +(@D@ imports @B@ and @C@, @B@ imports @A@, @C@ imports @A@) the aim is to do the +least possible amount of compilation to bring @D@ back up to date. The +simplest scheme we can think of is: +\begin{itemize} +\item {\bf Downsweep}: + starting with @D@, re-establish what the current module graph is + (it might have changed since last time). This means getting a + @ModuleSummary@ of @D@. The summary can be quickly generated, + contains @D@'s import lists, and gives some way of knowing whether + @D@'s source has changed since the last time it was summarised. + + Transitively follow summaries from @D@, thereby establishing the + module graph. +\item + Remove from the global symbol table (the @FiniteMap@ @ModuleName@ + @ModuleDetails@) the upwards closure of all modules in this package + which are out-of-date with respect to their previous versions. Also + remove all modules no longer reachable from @D@. +\item {\bf Upsweep}: + Starting at the lowest point in the still-in-date module graph, + start compiling upwards, towards @D@. At each module, call + @compile@, passing it a @FiniteMap@ @ModuleName@ @ModuleDetails@, + and getting a new @ModuleDetails@ for the module, which is added to + the map. + + When compiling a module, the compiler must be able to know which + entries in the map are for modules in its strict downwards closure, + and which aren't, so that it can manufacture the instance + environment correctly (as union of instances in its downwards + closure). +\item + Once @D@ has been compiled, invoke some kind of linking phase + if batch compilation. For interactive use, can either do it all + at the end, or as you go along. +\end{itemize} +In this simple world, recompilation visits the upwards closure of +all changed modules. That means when a module @M@ is recompiled, +we can be sure no-one has any references to entities in the old @M@, +because modules importing @M@ will have already been removed from the +top-level finite map in the second step above. + +The upshot is that we don't need to worry about updating links to @M@ in +the global symbol table -- there shouldn't be any to update. +\ToDo{What about mutually recursive modules?} + +CM will happily chase through module interfaces in other packages in +the downsweep. But it will only process modules in this package +during the upsweep. So it assumes that modules in other packages +never become out of date. This is a design decision -- we could have +decided otherwise. + +In fact we go further, and require other packages to be compiled, +i.e. to consist of a collection of interface files, and one or more +source files. CM will never apply @compile@ to a foreign package +module, so there's no way a package can be built on the fly from source. + +We require @compile@ to cache foreign package interfaces it reads, so +that subsequent uses don't have to re-read them. The cache never +becomes out of date, since we've assumed that the source of foreign +packages doesn't change during the course of a session (run of GHCI). +As well as caching interfaces, @compile@ must cache, in some sense, +the linkable code for modules. In batch compilation this might simply +mean remembering the names of object files to link, whereas in +interactive mode @compile@ probably needs to load object code into +memory in preparation for in-memory linking. + +Important signatures for this simple scheme are: +\begin{verbatim} + finder :: ModuleName -> ModLocation + + summarise :: ModLocation -> IO ModSummary + + compile :: ModSummary + -> FM ModName ModDetails + -> IO CompileResult + + data CompileResult = CompOK ModDetails + | CompErr [ErrMsg] + + link :: [ModLocation] -> [PackageLocation] -> IO Bool -- linked ok? +\end{verbatim} + + +\subsection{Implementing incremental recompilation -- clever version} + +So far, our upsweep, which is the computationally expensive bit, +recompiles a module if either its source is out of date, or it +imports a module which has been recompiled. Sometimes we know +we can do better than this: +\begin{verbatim} + module B where module A + import A ( f ) {-# NOINLINE f #-} + ... f ... f x = x + 42 +\end{verbatim} +If the definition of @f@ is changed to @f x = x + 43@, the simple +upsweep would recompile @B@ unnecessarily. We would like to detect +this situation and avoid propagating recompilation all the way to the +top. There are two parts to this: detecting when a module doesn't +need recompilation, and managing inter-module references in the +global symbol table. + +\subsubsection*{Detecting when a module doesn't need recompilation} + +To do this, we introduce a new concept: the @ModuleIFace@. This is +effectively an in-memory interface file. References to entities in +other modules are done via strings, rather than being pointers +directly to those entities. Recall that, by comparison, +@ModuleDetails@ do contain pointers directly to the entities they +refer to. So a @ModuleIFace@ is not part of the global symbol table. + +As before, compiling a module produces a @ModuleDetails@ (inside the +@CompileResult@), but it also produces a @ModuleIFace@. The latter +records, amongst things, the version numbers of all imported entities +needed for the compilation of that module. @compile@ optionally also +takes the old @ModuleIFace@ as input during compilation: +\begin{verbatim} + data CompileResult = CompOK ModDetails ModIFace + | CompErr [ErrMsg] + + compile :: ModSummary + -> FM ModName ModDetails + -> Maybe ModuleIFace + -> IO CompileResult +\end{verbatim} +Now, if the @ModuleSummary@ indicates this module's source hasn't +changed, we only need to recompile it if something it depends on has +changed. @compile@ can detect this by inspecting the imported entity +version numbers in the module's old @ModuleIFace@, and comparing them +with the version numbers from the entities in the modules being +imported. If they are all the same, nothing it depends on has +changed, so there's no point in recompiling. + +\subsubsection*{Managing inter-module references in the global symbol table} + +In the above example with @A@, @B@ and @f@, the specified change to @f@ would +require @A@ but not @B@ to be recompiled. That generates a new +@ModuleDetails@ for @A@. Problem is, if we leave @B@'s @ModuleDetails@ +unchanged, they continue to refer (directly) to the @f@ in @A@'s old +@ModuleDetails@. This is not good, especially if equality between +entities is implemented using pointer equality. + +One solution is to throw away @B@'s @ModuleDetails@ and recompile @B@. +But this is precisely what we're trying to avoid, as it's expensive. +Instead, a cheaper mechanism achieves the same thing: recreate @B@'s +details directly from the old @ModuleIFace@. The @ModuleIFace@ will +(textually) mention @f@; @compile@ can then find a pointer to the +up-to-date global symbol table entry for @f@, and place that pointer +in @B@'s @ModuleDetails@. The @ModuleDetails@ are, therefore, +regenerated just by a quick lookup pass over the module's former +@ModuleIFace@. All this applies, of course, only when @compile@ has +concluded it doesn't need to recompile @B@. + +Now @compile@'s signature becomes a little clearer. @compile@ has to +recompile the module, generating a fresh @ModuleDetails@ and +@ModuleIFace@, if any of the following hold: +\begin{itemize} +\item + The old @ModuleIFace@ wasn't supplied, for some reason (perhaps + we've never compiled this module before?) +\item + The module's source has changed. +\item + The module's source hasn't changed, but inspection of @ModuleIFaces@ + for this and its imports indicates that an imported entity has + changed. +\end{itemize} +If none of those are true, we're in luck: quickly knock up a new +@ModuleDetails@ from the old @ModuleIFace@, and return them both. + +As a result, the upsweep still visits all modules in the upwards +closure of those whose sources have changed. However, at some point +we hopefully make a transition from generating new @ModuleDetails@ the +expensive way (recompilation) to a cheap way (recycling old +@ModuleIFaces@). Either way, all modules still get new +@ModuleDetails@, so the global symbol table is correctly +reconstructed. + + +\subsection{How linking works, roughly} + +When @compile@ translates a module, it produces a @ModuleDetails@, +@ModuleIFace@ and a @Linkable@. The @Linkable@ contains the +translated but un-linked code for the module. And when @compile@ +ventures into an interface in package it hasn't seen so far, it +copies the package's object code into memory, producing one or more +@Linkable@s. CM keeps track of these linkables. + +Once all modules have been @compile@d, CM invokes @link@, supplying +the all the @Linkable@s it knows about. If @compile@ had also been +linking incrementally as it went along, @link@ doesn't have to do +anything. On the other hand, @compile@ could choose not to be +incremental, and leave @link@ to do all the work. + +@Linkable@s are opaque to CM. For batch compilation, a @Linkable@ +can record just the name of an object file, DLL, archive, or whatever, +in which case the CM's call to @link@ supplies exactly the set of +file names to be linked. @link@ can pass these verbatim to the +standard system linker. + + + + +%%-----------------------------------------------------------------%% +\section{Ancient stuff} +\subsubsection*{Should be selectively merged into ``Background ideas''} + +\subsection{Overall} +Top level structure is: +\begin{itemize} +\item The Compilation Manager (CM) calculates and maintains module + dependencies, and knows how create up-to-date object or bytecode + for a given module. In doing so it may need to recompile + arbitrary other modules, based on its knowledge of the module + dependencies. +\item On top of the CM are the ``user-level'' services. We envisage + both a HEP-like interface, for interactive use, and an + @hmake@ style batch compiler facility. +\item The CM only deals with inter-module issues. It knows nothing + about how to recompile an individual module, nor where the compiled + result for a module lives, nor how to tell if + a module is up to date, nor how to find the dependencies of a module. + Instead, these services are supplied abstractly to CM via a + @Compiler@ record. To a first approximation, a @Compiler@ + contains + the same functionality as @hsc@ has had until now -- the ability to + translate a single Haskell module to C/assembly/object/bytecode. + + Different clients of CM (HEP vs @hmake@) may supply different + @Compiler@s, since they need slightly different behaviours. + Specifically, HEP needs a @Compiler@ which creates bytecode + in memory, and knows how to link it, whereas @hmake@ wants + the traditional behaviour of emitting assembly code to disk, + and making no attempt at linkage. +\end{itemize} + +\subsection{Open questions} +\begin{itemize} +\item + Error reporting from @open@ and @compile@. +\item + Instance environment management +\item + We probably need to make interface files say what + packages they depend on (so that we can figure out + which packages to load/link). +\item + CM is parameterised both by the client uses and the @Compiler@ + supplied. But it doesn't make sense to have a HEP-style client + attached to a @hmake@-style @Compiler@. So, really, the + parameterising entity should contain both aspects, not just the + current @Compiler@ contents. +\end{itemize} + +\subsection{Assumptions} + +\begin{itemize} +\item Packages other than the "current" one are assumed to be + already compiled. +\item + The "current" package is usually "MAIN", + but we can set it with a command-line flag. + One invocation of ghci has only one "current" package. +\item + Packages are not mutually recursive +\item + All the object code for a package P is in libP.a or libP.dll +\end{itemize} + +\subsection{Stuff we need to be able to do} +\begin{itemize} +\item Create the environment in which a module has been translated, + so that interactive queries can be satisfied as if ``in'' that + module. +\end{itemize} + +%%-----------------------------------------------------------------%% +\section{The Compilation Manager} + +CM (@compilationManager@) is a functor, thus: +\begin{verbatim} +compilationManager :: Compiler -> IO HEP -- IO so that it can create + -- global vars (IORefs) + +data HEP = HEP { + load :: ModuleName -> IO (), + compileString :: ModuleName -> String -> IO HValue, + .... + } + +newCompiler :: IO Compiler -- ??? this is a peer of compilationManager? + +run :: HValue -> IO () -- Run an HValue of type IO () + -- In HEP? +\end{verbatim} + +@load@ is the central action of CM: its job is to bring a module and +all its descendents into an executable state, by doing the following: +\begin{enumerate} +\item + Use @summarise@ to descend the module hierarchy, starting from the + nominated root, creating @ModuleSummary@s, and + building a map @ModuleName@ @->@ @ModuleSummary@. @summarise@ + expects to be passed absolute paths to files. Use @finder@ to + convert module names to file paths. +\item + Topologically sort the map, + using dependency info in the @ModuleSummary@s. +\item + Clean up the symbol table by deleting the upward closure of + changed modules. +\item + Working bottom to top, call @compile@ on the upward closure of + all modules whose source has changed. A module's source has + changed when @sourceHasChanged@ indicates there is a difference + between old and new summaries for the module. Update the running + @FiniteMap@ @ModuleName@ @ModuleDetails@ with the new details + for this module. Ditto for the running + @FiniteMap@ @ModuleName@ @ModuleIFace@. +\item + Call @compileDone@ to signify that we've reached the top, so + that the batch system can now link. +\end{enumerate} + + +%%-----------------------------------------------------------------%% +\section{A compiler} + +Most of the system's complexity is hidden inside the functions +supplied in the @Compiler@ record: +\begin{verbatim} +data Compiler = Compiler { + + finder :: PackageConf -> [Path] -> IO (ModuleName -> ModuleLocation) + + summarise :: ModuleLocation -> IO ModuleSummary + + compile :: ModuleSummary + -> Maybe ModuleIFace + -> FiniteMap ModuleName ModuleDetails + -> IO CompileResult + + compileDone :: IO () + compileStarting :: IO () -- still needed? I don't think so. + } + +type ModuleName = String (or some such) +type Path = String -- an absolute file name +\end{verbatim} + +\subsection{The module \mbox{\tt finder}} +The @finder@, given a package configuration file and a list of +directories to look in, will map module names to @ModuleLocation@s, +in which the @Path@s are filenames, probably with an absolute path +to them. +\begin{verbatim} +data ModuleLocation = SourceOnly Path -- .hs + | ObjectCode Path Path -- .o & .hi + | InPackage Path -- .hi +\end{verbatim} +@SourceOnly@ and @ObjectCode@ are unremarkable. For sanity, +we require that a module's object and interface be in the same +directory. @InPackage@ indicates that the module is in a +different package. + +@Module@ values -- perhaps all @Name@ish things -- contain the name of +their package. That's so that +\begin{itemize} +\item Correct code can be generated for in-DLL vs out-of-DLL refs. +\item We don't have version number dependencies for symbols + imported from different packages. +\end{itemize} + +Somehow or other, it will be possible to know all the packages +required, so that the for the linker can load them. +We could detect package dependencies by recording them in the +@compile@r's @ModuleIFace@ cache, and with that and the +package config info, figure out the complete set of packages +to link. Or look at the command line args on startup. + +\ToDo{Need some way to tell incremental linkers about packages, + since in general we'll need to load and link them before + linking any modules in the current package.} + + +\subsection{The module \mbox{\tt summarise}r} +Given a filename of a module (\ToDo{presumably source or iface}), +create a summary of it. A @ModuleSummary@ should contain only enough +information for CM to construct an up-to-date picture of the +dependency graph. Rather than expose CM to details of timestamps, +etc, @summarise@ merely provides an up-to-date summary of any module. +CM can extract the list of dependencies from a @ModuleSummary@, but +other than that has no idea what's inside it. +\begin{verbatim} +data ModuleSummary = ... (abstract) ... + +depsFromSummary :: ModuleSummary -> [ModuleName] -- module names imported +sourceHasChanged :: ModuleSummary -> ModuleSummary -> Bool +\end{verbatim} +@summarise@ is intended to be fast -- a @stat@ of the source or +interface to see if it has changed, and, if so, a quick semi-parse to +determine the new imports. + +\subsection{The module \mbox{\tt compile}r} +@compile@ traffics in @ModuleIFace@s and @ModuleDetails@. + +A @ModuleIFace@ is an in-memory representation of the contents of an +interface file, including version numbers, unfoldings and pragmas, and +the linkable code for the module. @ModuleIFace@s are un-renamed, +using @HsSym@/@RdrNames@ rather than (globally distinct) @Names@. + +@ModuleDetails@, by contrast, is an in-memory representation of the +static environment created by compiling a module. It is phrased in +terms of post-renaming @Names@, @TyCon@s, etc, so it's basically a +renamed-to-global-uniqueness rendition of a @ModuleIFace@. + +In an interactive session, we'll want to be able to evaluate +expressions as if they had been compiled in the scope of some +specified module. This means that the @ModuleDetails@ must contain +the type of everything defined in the module, rather than just the +types of exported stuff. As a consequence, @ModuleIFace@ must also +contain the type of everything, because it should always be possible +to generate a module's @ModuleDetails@ from its @ModuleIFace@. + +CM maintains two mappings, one from @ModuleName@s to @ModuleIFace@s, +the other from @ModuleName@s to @ModuleDetail@s. It passes the former +to each call of @compile@. This is used to supply information about +modules compiled prior to this one (lower down in the graph). The +returned @CompileResult@ supplies a new @ModuleDetails@ for the module +if compilation succeeded, and CM adds this to the mapping. The +@CompileResult@ also supplies a new @ModuleIFace@, which is either the +same as that supplied to @compile@, if @compile@ decided not to +retranslate the module, or is the result of a fresh translation (from +source). So these mappings are an explicitly-passed-around part of +the global system state. + +@compile@ may also {\em optionally} also accumulate @ModuleIFace@s for +modules in different packages -- that is, interfaces which we read, +but never attempt to recompile source for. Such interfaces, being +from foreign packages, never change, so @compile@ can accumulate them +in perpetuity in a private global variable. Indeed, a major motivator +of this design is to facilitate this caching of interface files, +reading of which is a serious bottleneck for the current compiler. + +When CM restarts compilation down at the bottom of the module graph, +it first needs to throw away all \ToDo{all?} @ModuleDetails@ in the +upward closure of the out-of-date modules. So @ModuleDetails@ don't +persist across recompilations. But @ModuleIFace@s do, since they +are conceptually equivalent to interface files. + + +\subsubsection*{What @compile@ returns} +@compile@ returns a @CompileResult@ to CM. +Note that the @compile@'s foreign-package interface cache can +become augmented even as a result of reading interfaces for a +compilation attempt which ultimately fails, although it will not be +augmented with a new @ModuleIFace@ for the failed module. +\begin{verbatim} +-- CompileResult is not abstract to the Compilation Manager +data CompileResult + = CompOK ModuleIFace + ModuleDetails -- compiled ok, here are new details + -- and new iface + + | CompErr [SDoc] -- compilation gave errors + + | NoChange -- no change required, meaning: + -- exports, unfoldings, strictness, etc, + -- unchanged, and executable code unchanged +\end{verbatim} + + + +\subsubsection*{Re-establishing local-to-global name mappings} +Consider +\begin{verbatim} +module Upper where module Lower ( f ) where +import Lower ( f ) f = ... +g = ... f ... +\end{verbatim} +When @Lower@ is first compiled, @f@ is allocated a @Unique@ +(presumably inside an @Id@ or @Name@?). When @Upper@ is then +compiled, its reference to @f@ is attached directly to the +@Id@ created when compiling @Lower@. + +If the definition of @f@ is now changed, but not the type, +unfolding, strictness, or any other thing which affects the way +it should be called, we will have to recompile @Lower@, but not +@Upper@. This creates a problem -- @g@ will then refer to the +the old @Id@ for @f@, not the new one. This may or may not +matter, but it seems safer to ensure that all @Unique@-based +references into child modules are always up to date. + +So @compile@ recreates the @ModuleDetails@ for @Upper@ from +the @ModuleIFace@ of @Upper@ and the @ModuleDetails@ of @Lower@. + +The rule is: if a module is up to date with respect to its +source, but a child @C@ has changed, then either: +\begin{itemize} +\item On examination of the version numbers in @C@'s + interface/@ModuleIFace@ that we used last time, we discover that + an @Id@/@TyCon@/class/instance we depend on has changed. So + we need to retranslate the module from its source, generating + a new @ModuleIFace@ and @ModuleDetails@. +\item Or: there's nothing in @C@'s interface that we depend on. + So we quickly recreate a new @ModuleDetails@ from the existing + @ModuleIFace@, creating fresh links to the new @Unique@-world + entities in @C@'s new @ModuleDetails@. +\end{itemize} + +Upshot: we need to redo @compile@ on all modules all the way up, +rather than just the ones that need retranslation. However, we hope +that most modules won't need retranslation -- just regeneration of the +@ModuleDetails@ from the @ModuleIFace@. In effect, the @ModuleIFace@ +is a quickly-compilable representation of the module's contents, just +enough to create the @ModuleDetails@. + +\ToDo{Is there anything in @ModuleDetails@ which can't be + recreated from @ModuleIFace@ ?} + +So the @ModuleIFace@s persist across calls to @HEP.load@, whereas +@ModuleDetails@ are reconstructed on every compilation pass. This +means that @ModuleIFace@s have the same lifetime as the byte/object +code, and so should somehow contain their code. + +The behind-the-scenes @ModuleIFace@ cache has some kind of holding-pen +arrangement, to lazify the copying-out of stuff from it, and thus to +minimise redundant interface reading. \ToDo{Burble burble. More +details.}. + +When CM starts working back up the module graph with @compile@, it +needs to remove from the travelling @FiniteMap@ @ModuleName@ +@ModuleDetails@ the details for all modules in the upward closure of +the compilation start points. However, since we're going to visit +precisely those modules and no others on the way back up, we might as +well just zap them the old @ModuleDetails@ incrementally. This does +mean that the @FiniteMap@ @ModuleName@ @ModuleDetails@ will be +inconsistent until we reach the top. + +In interactive mode, each @compile@ call on a module for which no +object code is available, or for which it is out of date wrt source, +emit bytecode into memory, update the resulting @ModuleIFace@ with the +address of the bytecode image, and link the image. + +In batch mode, emit assembly or object code onto disk. Record +somewhere \ToDo{where?} that this object file needs to go into the +final link. + +When we reach the top, @compileDone@ is called, to signify that batch +linking can now proceed, if need be. + +Modules in other packages never get a @ModuleIFace@ or @ModuleDetails@ +entry in CM's maps -- those maps are only for modules in this package. +As previously mentioned, @compile@ may optionally cache @ModuleIFace@s +for foreign package modules. When reading such an interface, we don't +need to read the version info for individual symbols, since foreign +packages are assumed static. + +\subsubsection*{What's in a \mbox{\tt ModuleIFace}?} + +Current interface file contents? + + +\subsubsection*{What's in a \mbox{\tt ModuleDetails}?} + +There is no global symbol table @:: Name -> ???@. To look up a +@Name@, first extract the @ModuleName@ from it, look that up in +the passed-in @FiniteMap@ @ModuleName@ @ModuleDetails@, +and finally look in the relevant @Env@. + +\ToDo{Do we still have the @HoldingPen@, or is it now composed from +per-module bits too?} +\begin{verbatim} +data ModuleDetails = ModuleDetails { + + moduleExports :: what it exports (Names) + -- roughly a subset of the .hi file contents + + moduleEnv :: RdrName -> Name + -- maps top-level entities in this module to + -- globally distinct (Uniq-ified) Names + + moduleDefs :: Bag Name -- All the things in the global symbol table + -- defined by this module + + package :: Package -- what package am I in? + + lastCompile :: Date -- of last compilation + + instEnv :: InstEnv -- local inst env + typeEnv :: Name -> TyThing -- local tycon env? + } + +-- A (globally unique) symbol table entry. Note that Ids contain +-- unfoldings. +data TyThing = AClass Class + | ATyCon TyCon + | AnId Id +\end{verbatim} +What's the stuff in @ModuleDetails@ used for? +\begin{itemize} +\item @moduleExports@ so that the stuff which is visible from outside + the module can be calculated. +\item @moduleEnv@: \ToDo{umm err} +\item @moduleDefs@: one reason we want this is so that we can nuke the + global symbol table contribs from this module when it leaves the + system. \ToDo{except ... we don't have a global symbol table any + more.} +\item @package@: we will need to chase arbitrarily deep into the + interfaces of other packages. Of course we don't want to + recompile those, but as we've read their interfaces, we may + as well cache that info. So @package@ indicates whether this + module is in the default package, or, if not, which it is in. + + Also, when we come to linking, we'll need to know which + packages are demanded, so we know to load their objects. + +\item @lastCompile@: When the module was last compiled. If the + source is older than that, then a recompilation can only be + required if children have changed. +\item @typeEnv@: obvious?? +\item @instEnv@: the instances contributed by this module only. The + Report allegedly says that when a module is translated, the + available + instance env is all the instances in the downward closure of + itself in the module graph. + + We choose to use this simple representation -- each module + holds just its own instances -- and do the naive thing when + creating an inst env for compilation with. If this turns out + to be a performance problem we'll revisit the design. +\end{itemize} + + + +%%-----------------------------------------------------------------%% +\section{Misc text looking for a home} + +\subsection*{Linking} + +\ToDo{All this linking stuff is now bogus.} + +There's an abstract @LinkState@, which is threaded through the linkery +bits. CM can call @addpkgs@ to notify the linker of packages +required, and it can call @addmods@ to announce modules which need to +be linked. Finally, CM calls @endlink@, after which an executable +image should be ready. The linker may link incrementally, during each +call of @addpkgs@ and @addmods@, or it can just store up names and do +all the linking when @endlink@ is called. + +In order that incremental linking is possible, CM should specify +packages and module groups in dependency order, ie, from the bottom up. + +\subsection*{In-memory linking of bytecode} +When being HEP-like, @compile@ will translate sources to bytecodes +in memory, with all the bytecode for a module as a contiguous lump +outside the heap. It needs to communicate the addresses of these +lumps to the linker. The linker also needs to know whether a +given module is available as in-memory bytecode, or whether it +needs to load machine code from a file. + +I guess @LinkState@ needs to map module names to base addresses +of their loaded images, + the nature of the image, + whether or not +the image has been linked. + +\subsection*{On disk linking of object code, to give an executable} +The @LinkState@ in this case is just a list of module and package +names, which @addpkgs@ and @addmods@ add to. The final @endlink@ +call can invoke the system linker. + +\subsection{Finding out about packages, dependencies, and auxiliary + objects} + +Ask the @packages.conf@ file that lives with the driver at the mo. + +\ToDo{policy about upward closure?} + + + +\ToDo{record story about how in memory linking is done.} + +\ToDo{linker start/stop/initialisation/persistence. Need to + say more about @LinkState@.} + + +\end{document} + + diff --git a/docs/hep/hep.tex b/docs/hep/hep.tex new file mode 100644 index 00000000..772aee5d --- /dev/null +++ b/docs/hep/hep.tex @@ -0,0 +1,1299 @@ +\documentstyle[11pt]{article} + +% copied from the Haskore tutorial +\textheight=8.5in +\textwidth=6.5in +\topmargin=-.3in +\oddsidemargin=0in +\evensidemargin=0in +\parskip=6pt plus2pt minus2pt + +% and some of my own personal preferences +\parindent=0in + +\newcommand{\var}[1]{{\tt #1\/}} % variables +\newcommand{\fun}[1]{{\tt #1\/}} % functions +\newcommand{\expr}[1]{{\tt #1\/}} % expressions +\newcommand{\type}[1]{{\tt #1\/}} % types +\newcommand{\class}[1]{{\tt #1\/}} % classes +\newcommand{\module}[1]{{\tt #1\/}} % modules + +\newcommand{\tva}{$\alpha$} % type variables +\newcommand{\tvb}{$\beta $} +\newcommand{\tvc}{$\gamma$} + +\newcommand{\arrow}{$\enspace\to\enspace$} % type constructors + +\newcommand{\Hugs}{{\bf Hugs\/}} +\newcommand{\GHC}{{\bf GHC\/}} +\newcommand{\Haskell}{{\bf Haskell\/}} + +\newcommand{\cexpr}[1]{{\tt #1\/}} % C expressions +\newcommand{\ctype}[1]{{\tt #1\/}} % C types +\newcommand{\cvar}[1]{{\tt #1\/}} % C variables +\newcommand{\cfun}[1]{{\tt #1\/}} % C functions +\newcommand{\cfile}[1]{{\tt #1\/}} % C files (.c, .h, etc) + +\newenvironment{aside}{% + \medbreak + \noindent + {\bf Aside: } + \begingroup + \sl + \begin{indent} % why doesn't this do what I expect? +}{% + \end{indent} + \endgroup + \par + {\bf End aside.} + \medbreak +} + +\newenvironment{note}{% + \medbreak + \noindent + {\bf Note: } + \begingroup + \sl + \begin{indent} % why doesn't this do what I expect? +}{% + \end{indent} + \endgroup + \par + {\bf End note.} + \medbreak +} + +\newcommand{\Portability}[1]{\par{{\bf Portability Note:} \sl #1}\par} +\newcommand{\Warning}[1]{\par{{\bf Warning:} \sl #1}\par} + +% These are used for reminders, communication between authors, etc. +% There should be no calls to these guys in the final document. + +%\newcommand{\ToDo}[1]{\par{{\bf ToDo:} \sl #1}\par} +\newcommand{\ToDo}[1]{{{\bf ToDo:} \sl #1}} + +\newenvironment{outline}{% + \medbreak + \noindent + {\bf Outline: } + \begingroup + \nobreak + \sl +}{% + \endgroup + \nobreak + {\bf End outline.} + \medbreak +} + +% Here's how you create figures +% +% \begin{figure*} +% \centerline{ +% Foo +% } +% \caption{...} +% \label{...} +% \end{figure*} + +\begin{document} + +\title{% + Architecture of the Haskell Execution Platform (HEP)\\ + Version 6 +} + +\author{Julian Seward, Simon Marlow, Andy Gill, Sigbjorn Finne, Simon + Peyton Jones \\ +Microsoft Research, Cambridge, UK\\ +{\tt \{v-julsew,simonmar,v-sfinne,simonpj\}@microsoft.com}, {\tt andy@cse.ogi.edu}} +\date{29 July 1999} +\maketitle + + + +\section{What this document is for} +As the combined GHC--Hugs system comes ever closer to running compiled +code, it becomes clearer than an architectural overhaul is +needed. We at MSRC, together with Andy Gill, have been discussing +this at length. + +Those wishing to go directly to the all-important HEP +interface will find it in section 6.1. + +\section{Names} +One frequent point of confusion in our discussions so far has +been what the names mean. Here's some defns: + +\begin{itemize} +\item ``GHC'' is the standalone native-code compiler. +\item ``Hugs'' + denotes the version built from sources in the Glasgow tree, + using an STG back end and GHC runtime support. On supported + architectures, Hugs will be able to load binaries compiled by GHC. +\item ``Hugs98'' is the current public distribution. This document is not + concerned with it. Further changes to + Hugs98 will be bugfixes/maintenance, and we expect that Hugs will + supercede Hugs98 at some point. +\end{itemize} + + +\section{Rationale and motivation} +As of 10 June, Hugs is able to load and run +extremely simple functions compiled by GHC. To get to this stage has +required drastic changes to the original Hugs98 from which it was +derived: +\begin{itemize} +\item dumping the original back end and runtime support, and using + an STG-based code generator and GHC's RTS instead. +\item adding a new parser to read GHC's interface files (easy) and + a significant amount of code to manufacture appropriate + symbol table entries (not so easy). +\item modifying the import chasing mechanism to follow dependencies + through both source and interface files. +\end{itemize} + +These changes, particularly the latter two, are inelegantly integrated +into the original structure. It is clear that whatever Hugs +emerges as a result of my current hackery will be more a +proof-of-concept vehicle than as something which we can carry +forwards. Some of the design decisions I made on the way are, in +hindsight, bad. A decent system will need a cleaned-up +architecture. + +Hugs is becoming more complex as more parties modify it for their own +diverse purposes. There are now various user interfaces (WinHugs, the +``standard'' text UI, the HaskellScript stuff, and RunHugs). Not far +ahead will come the further complexity of supporting multiple code +generators. We already have the original and STG codegens, and +further codegens are proposed for Hugs and GHC. + +A powerful motivating factor for redoing the architecture is to try +and modularise Hugs so that +\begin{itemize} +\item supporting these various extensions is simpler. +\item supporting different platforms is simpler. Hugs is not too + bad, but GHC is very Unix oriented. +\item new extensions don't involve grappling with so many + parts of the system. +\item building customised variants is simpler. +\end{itemize} + +Finally, it would be nice to at least review, and possibly redo, some +aspects of the existing code base: +\begin{itemize} +\item The conservative garbage collector (now reduced to compile-time only + duty in Hugs) has been much discussed. Perhaps we could + do away with it and use the GHC heap instead. + +\item Symbol table (names, classes, values, instances, modules) management + in Hugs is too inflexible to support loading and unloading of + arbitrary mixtures of compiled and interpreted code in arbitrary + orders. It needs redoing. + +\item The import chasing mechanism is hard to understand, and has proven + difficult to adapt for use in Hugs. Redesign is unavoidable. +\end{itemize} + + + +\section{Issues} +Here are the major architectural difficulties which have been encountered. + +\begin{itemize} +\item + What mixtures of compiled and interpreted code should be supported? + Currently there are at three proposals, in increasing order of + complexity to implement: + \begin{itemize} + \item ``Downward closure'': if module M is compiled, then all modules + reachable from M, including Prelude, must be too. + \item ``Prelude + any'': arbitrary mixtures are allowed, with the proviso + that if any module is compiled, then the Prelude must be compiled + too. + \item ``Any'': any mixture at all. + \end{itemize} + Underlying problems are: + \begin{itemize} + \item + Run-time linking of object files. Use of the Unix \cfun{dlopen} + facility mandates a downward closure approach, since there is + no way to resolve references to interpreted code from compiled + code. How the windows DLL loaders would behave I don't know. + To be more flexible seems to require writing one's own linkers. + \item + Primops. Operations on, and assumptions about representation of + primops have to be compatible in compiled and interpreted code. + One possibility is to ensure that Hugs's and GHC's primops + exactly correspond. That seems wasteful, and difficult and + bug-prone to maintain. Another approach it to route all + primop calls to GHC, probably by routing them all via a + GHC-compiled Prelude. + \item + Interface files. All but the downward closure option require + Hugs to generate interface files for interpreted modules + so GHC can compile against them. + \end{itemize} + +\item + When the user asks ``:reload'', how should Hugs go about bringing + the execution environment up-to-date? How intelligent should it be? + (how accurately do we track changes in the module dependencies?) + Where do we put the intelligence? Is Hugs allowed to invoke GHC, + or must the user do it? Do the different user interfaces require + different levels of sophistication? + +\item + For platforms on which GHC is not supported, + we still desire to build a standalone Hugs without object loading + facilities. + The main trickyness is that a standalone Hugs will have to supply + its own implementation of primops, since it can't rely on use of + primop facilities in a GHC-compiled prelude. +\end{itemize} + +Some less troublesome issues are + +\begin{itemize} +\item + We might want a form of BCO which can be dumped + into a file and reloaded/linked later. One use would be to + give an architecture-neutral way to distribute libraries + in binary form. Another is for shipping code across a network. + Finally, for platforms on which GHC is not supported, it offers + the possibility of fast startup, by loading \cfun{Prelude.bco} and + reading \cfun{Prelude.hi}. One consequence of doing dumpable + BCOs is that Hugs would need to create interface files. +\item + Multiple code generators. If Hugs is to acquire other code + generators, it may be desirable to create an interface at the + boundary between STGland and the code generators. + + Since GHC may also want to target new platforms, work on new + code generators should aim to maximise compatibility between + Hugs and GHC. +\item + Loading object files. + Hugs is fairly platform independent, except + for its need to load object files. We can + create an object file loading/linking generic API, and hook + specific loaders, for example ELF and Win32 DLL, under that. + However, as mentioned above, use of the native facilities may be + too inflexible, and so necessitate writing our own linkers. +\item + Object vs source-level symbol tables. + For each function \cfun{f} that GHC compiles, a whole + bunch of symbols are spewed into the object code: \cfun{f\_closure}, + \cfun{f\_entry}, \cfun{f\_info} and \cfun{f\_fastk}, at the very + least. + + On the one hand, you need to remember all these names because other + object modules will reference them. On the other hand, the bytecode + compiler is only interested in source-level facts about \cfun{f}, such as + its type, and not about the addresses of its derivative symbols. + We propose to have a + separate symbol table for object code symbols, with only minimal + connection to the source-level symbol table (a pointer to + \cfun{f\_closure} ?) +\item + Replacement of the conservative garbage collector. It doesn't + make much sense to have two heaps, allocators and GCs in the new Hugs. + Either we can move compile-time allocation into the + execution heap, or move to an arena-based allocator. Hugs allocates + heap when compiling so slowly that the latter possibility is quite + practical. Either way, the main criteria is to reimplement the \cfun{fst}, + \cfun{snd}, \cfun{pair}, \&c, macros, so that client code doesn't have to be + changed. + + Changing the heap representation would require a new scheme + for dealing with Hugs' symbol tables, since pointers to places + outside the (Hugs) heap are interpreted in various ways, including + as symbol table references. + + It's also unclear what the consequences would be of any client + code which dynamically changes the type of a (eg) pair field + from pointer to non-pointer, or vice versa. +\item + Dictionary layouts. Hugs and GHC need to agree on the order + in which dictionary arguments are passed, and on the order of + methods within a dictionary. We also need to make GHC regard + selector functions as possibly overloaded, if necessary, + and pass dictionaries appropriately. +\item + Currently GHC, and therefore Hugs, is very Unix oriented. This + is not acceptable for a standalone Hugs. The main blocking points for + development on WinNT are the GHC driver (Perl) and the + build environment (GNU Make). +\item + Profiling. If Hugs is to be able to do profiling, + it needs to be able to handle scc annotations and probably implement + auto-sccification. Will it be difficult to make sure the + implemented cost semantics are the same as that of GHC ? +\item + Type system extensions. If Hugs is to implement them, Hugs and + GHC must agree on them. Currently: multiparam type classes, + local universal quantification, existential quantification. +\item + Issues to do with startup and loading the Prelude, so as + to minimise code duplication and complexity in Hugs. + Interacts with the primops issue. +\item + Andy is interested in looking into some hooks for debugging. +\end{itemize} + + +\section{Proposed structure} +\begin{verbatim} + TextUI WinUI HaskellScript etcUI VisualStudio + | | | | | + +--------+----+----+----------+ ..........+ + | + ..... HEP interface + /~ | + | Session ((Compile-time + | Manager storage mgr)) + | | + HEP -+ +----------+----+----+----------+---------+ + | | | | | | | + | Bytecode Source | Object Object IFace + | Compiler SymTab | Loader SymTab Reader + \_ | + StorMgr + & Eval +\end{verbatim} +This crude picture depicts the main blocks, with lines indicating flow +of control, not data. Underlying all components is the compile-time +storage manager. The session manager is central to the design, so +I'll start there. + +The parts from the Session Manager on downwards, including the +compile-time storage manager, are collectively known as the +Haskell Execution Platform (HEP). HEP has to support a diversity +of clients, both those which offer human user interfaces (TextUI, +WinUI, etc) or those offering higher level programmatic interfaces +(HaskellScript, VisualStudio). Because of this, the HEP interface +is critical. It is described in detail in Section 6.1. +\begin{itemize} +\item + Session manager (SM): Responsible for building an up-to-date + executable image (mixture of byte and native code) when the user + interfaces request a particular Haskell module to be made available + for execution. Responsible for arranging + evaluation of Haskell expressions passed from the user interfaces. + + To build an up-to-date image, SM needs to keep track of module + dependencies and source/object in-or-out-of-dateness, so as to + determine when to reload/recompile modules. + It's fair to say that SM will have to + incorporate the functionality of (\cfun{hbc|nhc|}$\epsilon$)\cfun{make}. + + The RTS can support multiple Haskell threads running concurrently, + so SM offers that service too. This might be useful for a GUI based + Hugs in which there are multiple read-eval windows. Further, SM + needs to offer GUIs a way to check their own event queues whilst the + evaluator or compiler is running. We have devised what we hope is a + flexible scheme to support this. The same mechanism allows UIs to + interrupt compilation or evaluation in a portable manner. +\item + Bytecode Compiler (BC): the previous core of Hugs. Reads Haskell + source and translates it via STG code to bytecode, which it places + in the (runtime) heap. Updates the Source SymTab (SSym) entry for + this module and references SSym entries for other modules. + Optionally emits a simple, GHC-readable interface file for the + module. + + In order that SM can determine the dependencies of a given source + file without attempting full compilation, BC has a facility to parse + a file and return the import list, but do nothing more. + +\item + IFace Reader (RdIF): reads GHC created interface files and + manufactures symbol table entries in SSym for the specified module. + + Analogously to BC, has a submode for finding just the dependencies + of an interface file. + + When called upon to load an interface, RdIF must engage Object + Loader (OLoad) to load the corresponding object file. It is OLoad's + responsibility to relocate and link this file, since that's platform + dependent. However, RdIF must add some minimal info about the + object code to this module's SSym entry, namely the address of the + \cfun{\_closure} entry points. + +\item + Source Symbol Table (SSym): is the global source-level symbol + table, containing info on modules (imports, exports), classes + (types, members, etc), instances, tycons and functions. This is + what BC will have to consult and update in order to static-check and + typecheck source files. SSym only contains enough info about object + files to be able to create calls to GHC compiled functions. At the + moment this would appear to be the \cfun{f\_closure} addresses. + + SSym must be designed so that modules can be thrown out of the + system in any order, rather than just the stack-like order in the + current Hugs. Fixed limits on table sizes should also be avoided. + + SSym must be designed so client code doesn't have to change. + I think most accesses go via the \cfun{name}, \cfun{isName}, + \cfun{findName}, \cfun{newName} macros (ditto \cfun{module}, + \cfun{cclass}, \cfun{inst}, \cfun{tycon}), so it's ok. + +\item + Object Symbol Table (OSym): global object-level symbol table. + Contains a binding for every symbol in every object currently + loaded. New objects can be linked merely by querying OSym; + no reference to SSym is needed. As motivation, GHC compiled + functions have dozens of symbols not referred to at the source + level but which are referred to from other objects, and also + internally between code and data sections, so we need + to record their addresses. + + +\item + Object Loader (OLoad) has two duties: (1) bring an object file into + memory and create OSym entries for it. (2) resolve references in an + object file in memory by consulting OSym (and possibly SSym?). + + OLoad is obviously object-format dependent. It should be structured + so that it has a + format independent interface, and implementations of (1) and (2) for + each format (ELF, DLL, COFF, etc). The ELF implementation is + already done and takes only about 300 lines of C. + + Extra complication: object files can refer to symbols in the RTS, + and to symbols like \cfun{printf}. These symbols will be bound into the + executable Hugs image at the time that is built. So we need a + way to find the addresses of symbols ``in this process image''. On + one hand, logically it is up to OSym to supply these addresses. But + this is also object/executable format dependent, so OLoad needs to + be involved. Blargh. Possibly have an OLoad call to preload + OSym with these symbols at Hugs startup time. + + +\item + Storage Manager and Evaluator (RTS): This is the GHC RTS, + along with the bytecode interpreter already in StgHugs. Executes the + native/bytecode mixture. (Not sure what else to say. This is + what Simon and Alastair created. It works and is more or less in + the required form). + + +\item + The user interfaces, TextUI, WinUI, RunHugsUI, etc. These wrap up + the services of SM and present them to the end-user, either human + or programmatic, in some + appropriate way. The pictures show multiple interfaces built into + the system, but in practice we expect only one to be linked in to + any particular system. The requests that they can pass to SM are: + \begin{itemize} + \item Initialise system, shut down. + \item Change system settings (implements :set in Hugs) + \item Prepare a module for use, returning a module handle. + \item Translate expressions in the context of a given module. + \item Evaluate a translated expression. + \item Query SSym (so that :info, :type, etc can be implemented) + \end{itemize} + +\item + Underlying everything is the compile-time storage manager. + Details currently hazy. +\end{itemize} + +\subsubsection*{Possible variant 1: multiple code generators} +Chop up BC, so it becomes a single source-to-STGcode converter +plus some number of STGcode-to-whatever code generators. +Hopefully the code generators would all have the same interface. +\begin{verbatim} + TextUI WinUI RunHugsUI etcUI VisualStudio + | | | | | + +--------+----+----+--------+ ..........+ + | + Session ((Compile-time + Manager storage mgr)) + | + +----------+----+----+----------+---------+--------+----------+ + | | | | | | | | + Haskell Source | Object Object IFace STG to STG to + to STG SymTab | Loader SymTab Reader Bytecode OTHER + | + StorMgr + & Eval +\end{verbatim} + +\subsubsection*{Possible variant 2: dumpable BCOs} +If BCOs are dumpable to file, they can be regarded as just another +flavour of object format. Then the Haskell to BCO (BC) component can +be factored off into another process. Loading of BCOs would be done +via OLoad, with RdIF reading the interface files which would have +to be created by BC. It also means BC would have to read +interface files. + +This scheme has overheads in both compile speed and +implementational complexity. The point of mentioning it is to +emphasise the idea that there's no particularly fundamental reason why +the BC component should be compiled into SystemC whilst GHC remains a +separate entity. If we need to do this, it's not difficult. +However, nor is it at present of the highest priority. + + +\section{The component interfaces} + +Many of the calls can fail. It would be good to think about a +consistent error-recovery strategy. I've ignored any error cases +in the signatures below. I'm working with Variant 1 (multiple code +generators) above. + + + +\subsection{Session manager (SM)} +These interfaces are presented in IDLishly, with +Haskell types. Regard the return types as really being \verb@IO@ +types. +\begin{verbatim} +interface IUnknown { + addRef, release :: () +} +\end{verbatim} +All interfaces inherit reference counting methods in \verb@IUnknown@. +When a client copies a pointer, it should \verb@addRef@ it, and +conversely \verb@release@ it when done. +Once a pointer is \verb@release@d, the thing it points at may or +may not still be alive, but in any case the owner of the +pointer must assume it is dead. \ToDo{Are these the COM semantics?} + +\subsubsection{Servers} +\begin{verbatim} +getServer :: HsServer + +interface HsServer : IUnknown { + loadModule :: LoadHooks -> String -> Maybe HsModule + + setOptions :: [(String,String)] -> () + getOptions :: [(String,String)] + canUseObject :: Bool +} +\end{verbatim} +For simplicity, we assume there is only one server, obtained +via \verb@getServer@. In practice they might be manufactured +by a class factory (???), but that's too COM specific here. + +A client can ask a \verb@HsServer@ object whether it is +capable of loading object code with \verb@canUseObject@. +HEPs hosted on non-GHC-supporting platforms will return +\verb@False@ here. The HEP will still work but must +interpret everything. + +Clients can query and set options for this server using +\verb@getOptions@ and \verb@setOptions@. \verb@getOptions@ +returns all the available options and their current values. +\verb@setOptions@ can supply new values for any subset, or all, of +them. + +\verb@HsServer@'s main purpose is to supply \verb@loadModule@. +Clients supply a string such as ``\verb@List@'', indicating a +module name, with no filename extension or directory. +HEP tries to return a \verb@HsModule@ handle reflecting +the current state of the source/object code base. In doing so, +it may need to load and/or compile arbitrary numbers of +subsidiary modules. This operation may fail, hence the \verb@Maybe@ +return type. + +Once a \verb@HsModule@ handle has been successfully acquired, +that handle remains valid until the client calls \verb@release@ +on it. What the handle refers to is the state of the object/source +code base at the time the handle was created. Subsequent changes +to the code base have no effect on the handle; the executable images +to which it refers are unchanged. + +For example, assuming \verb@s :: HsServer@ and \verb@h :: LoadHooks@, +then given the following sequence of events +\begin{enumerate} +\item \verb@m1 = s.loadModule("M", h)@, and this call succeeds +\item The source/object for \verb@M@ changes +\item \verb@m2 = s.loadModule("M", h)@ +\end{enumerate} +\verb@m1@ will continue to be valid and will refer to the original +version of \verb@M@, whilst \verb@m2@ refers to the new version. +Furthermore, if \verb@M@ depends on some other +modules, \verb@m1@ will still be based on the +original version of those modules, even if their sources/objects +change. In short, once a \verb@HsModule@ comes into existence, +its meaning never changes. + +\subsubsection{Load-time hooks} + +HEP decides for itself what modules it needs to load, when, and +in what order. It is up to the client to supply the +actual source/object code for modules. To facilitate this, +clients must pass a \verb@LoadHooks@ object to \verb@loadModule@: +\begin{verbatim} +interface LoadHooks : IUnknown { + findModule :: String + -> (Maybe InStream, Maybe (InStream, InStream)) + -- .hs file, (.hi file, .o file) + + setProgress :: String -> Float -> Bool + -- True <=> abandon compilation please + + error :: Error -> () +} +\end{verbatim} +When HEP needs a module, it calls \verb@findModule@, passing it +the unadorned module name, unadorned in the same way as names +passed to \verb@loadModule@. The client should attempt to locate +source, interface and object streams for the module in any way +it pleases. The returned pair is a possible stream for the +source text, and a possible pair of streams for the interface +and object text. This latter pairing exists because there's +no point in producing an object stream without the corresponding +interface stream, or vice versa. + +An \verb@InStream@ is an abstract handle with which to read a finite stream. +\verb@getChar@ reads the next character or returns an end-of-file +marker. \verb@fprint@ returns a fingerprint, perhaps a checksum, +or a file timestamp, +which characterises the stream's contents. \verb@eqFPrint@ compares +this stream's fingerprint against a supplied one. The fingerprinting +semantics requires that two identical streams have identical +fingerprints. \ToDo{Do we care that this isn't implementable, +strictly speaking?} The intention is to provide HEP with a +way to determine to whether a given stream has changed since it was +last looked at. \verb@FPrint@ is regarded as an abstract type +supplied by the client. +\begin{verbatim} +interface InStream : IUnknown { + getChar :: Int + fprint :: FPrint + eqFPrint :: FPrint -> Bool +} +\end{verbatim} + +HEP notifies the client of compilation/loading progress by calling +\verb@setProgress@, giving the name of a goal, eg ``Typechecking'', +and a value, increasing monotonically over a sequence of such calls, +from $0.0$ to $1.0$, indicating progress towards that goal. +If the client returns \verb@True@ to such a call, HEP abandons +compilation as soon as possible. In this way, clients can +interrupt compilation in a portable manner. + +If a compilation error occurs, HEP creates a \verb@Error@ object +and passes it to the client with \verb@error@. For the moment, +the error object only contains the source coordinates of the +error, the \verb@InStream@ from which the source originated, +and a method \verb@show@ which produces the text of the error message. +Later versions may contain more information. +\begin{verbatim} +interface Showable : IUnknown { + show :: String +} + +interface Error : Showable { + source :: InStream + line, col :: Int +} +\end{verbatim} + +\subsubsection{Modules} +Once a client has obtained a \verb@HsModule@ handle, it can +translate and run expressions in the context of that module. +Translated values are \verb@HsVal@ objects. +\begin{verbatim} +interface HsModule : IUnknown { + exprVal :: String -> Bool -> Maybe HsVal + -- A Haskell expression, treated as if + -- it was written in the module + -- Bool==True <=> wrap in `print' if not :: IO t + + idVal :: String -> Maybe HsVal + -- The name of a top-level value in + -- scope in the module + + -- takes a regexp, gives list of things + -- defined in (Bool==True) or in scope in (Bool==False) this mod + getNames :: Bool -> String -> [Name] + getTypes :: Bool -> String -> [Type] + getTycons :: Bool -> String -> [Tycon] + getClasses :: Bool -> String -> [Class] + getInstances :: Bool -> String -> [Instance] + + -- query a specific thing. String is a name. Bool as above. + findName :: Bool -> String -> Maybe Name + findType :: Bool -> String -> Maybe Type + findTycon :: Bool -> String -> Maybe Tycon + findClass :: Bool -> String -> Maybe Class + findInstance :: Bool -> String -> String -> Maybe Instance +} +\end{verbatim} +The two important methods are \verb@exprVal@ and +\verb@idVal@. \verb@exprVal@ takes an arbitrary Haskell +expression and tries to return a translation of it in the +context of that module. The caller can optionally ask to +have the value wrapped in \verb@print@, since that is often +convenient. + +\verb@idVal@ is simpler. It simply regards the supplied string +as the name of a top-level function in scope in the module, and +returns a \verb@HsVal@ referring to that name. It's conceivable +that a skeletal HEP which just loaded object files could implement +\verb@idVal@ but not \verb@exprVal@. Such a HEP would not need +a bytecode compiler or interpreter. + +The \verb@get*@ and \verb@find*@ methods allow clients to consult +the HEP's symbol tables. In all cases, the \verb@Bool@ +parameter facilitates choosing between ``defined in this module'' +and ``in scope in this module'' interpretation of queries. + +\verb@getNames@ returns the names of all top-level values +matching the wildcard in the supplied string, defined in or +in scope in this module. \verb@findName@ returns the +corresponding information for a specific name; the supplied +string must be a real name and not a wildcard. The \verb@Type@, +\verb@Tycon@, \verb@Class@ and \verb@Instance@ calls function +analogously for types, type constructors, classes and instances. + +As with error messages, currently the only possible action with +a name, type, tycon, class or instance is to print it. This +may change later. +\begin{verbatim} +interface Class : Showable { } +interface Type : Showable { } +interface Instance : Showable { } +interface Tycon : Showable { } +interface Name : Showable { } +\end{verbatim} + +\subsubsection{Values} +A Haskell value is represented by a \verb@HsVal@ object. +\verb@HsVal@s carry their type, which is obtained with +\verb@type@. + +New values can be created by application of +a value to a list of argument values; \verb@apply@ does this. +The application is typechecked, and will fail if it is type-incorrect. +\ToDo{Say more about the rules and extent of this}. + +For convenience, new values can be manufactured from integers, +using \verb@mkIntValue@. The inverse operation is \verb@intValueOf@, +which will fail if the type is wrong. Such mistakes can be avoided +by first testing with \verb@isIntValue@. \ToDo{What does +\verb@intValueOf@ do if the arg is not in whnf?} Similar functions +exist for other primitive types. +\begin{verbatim} +interface HsVal : IUnknown { + type :: Type + + apply :: [HsVal] -> Maybe HsVal + -- can fail because of type error + + eval :: RunHooks -> WhyIStopped + -- To WHNF + evalIO :: RunHooks -> Maybe WhyIStopped + -- Runs a value of type IO t, returning the t + -- the result may or may not be evaluated + + mkIntValue :: Int -> HsVal + isIntValue :: Bool + intValueOf :: Maybe Int + -- ditto Bool Char Word Float Double +} +\end{verbatim} +The main purpose of \verb@HsVal@ is to supply \verb@eval@ and +\verb@evalIO@. \verb@eval@ evaluates a value, which may be of +any type, to WHNF. The client must supply a \verb@RunHooks@ object +to be used during evaluation. \verb@evalIO@ is similar, except +that the supplied value must have type \verb@IO t@. The +possibly unevaluated \verb@t@ is then returned. +\begin{verbatim} +data WhyIStopped = Done + | DoneIO HsVal + | YouAskedMeToStop + | NoThreadsToRun + +interface RunHooks : IUnknown { + continue :: Bool + stdout, stderr :: Char -> () + stdin :: Char + -- if the last three block, the entire HEP does +} +\end{verbatim} +A \verb@RunHooks@ object allows the client to capture \verb@stdout@ +and \verb@stderr@ from the evaluated expression, and supply a +\verb@stdin@ stream for it. If any of these calls blocks, the +entire HEP will too. \ToDo{Are we sure?} + +When running an expression, HEP will call \verb@continue@ on a +fairly regular basis, to find out if the client wants to interrupt +evaluation. If the client returns \verb@True@, +\verb@eval@/\verb@evalIO@ then will return with the value +\verb@YouAskedMeToStop@. The client can resume execution later +by calling \verb@eval@/\verb@evalIO@ again on that value. + +\verb@eval@/\verb@evalIO@ may also return bearing \verb@Done@ +or \verb@DoneIO@ respectively, indicating that the value has +reached WHNF. Lastly, a return value of \verb@NoThreadsToRun@ +indicates that the RTS's scheduler could not find any Haskell +threads to run. This could indicate deadlock. + +\subsubsection{Threading issues for the HEP} +There are two kinds of threads to consider: Haskell threads, +managed and scheduled by the RTS's scheduler, and operating-system +threads. + +Haskell threads are easy. An \verb@eval@/\verb@evalIO@ call +starts a single ``main'' thread, and that can create new +threads using the Haskell primitive \verb@forkIO@. + +The complication lies in OS threads. Rather than attempt +to design a multithreaded HEP, we place a mutex around the +entire HEP, and allow only one OS thread in at a time. +To try and create some fairness, the HEP can, at times convenient +to it, check whether any other OS threads are waiting to enter, +in which case it may yield, so as to let others enter. + +Unfortunately this will cause deadlocks for Haskell programs +using callbacks. Typically, a callback function will be +supplied to some other subsystem (eg, graphics) using a +\verb@ccall@ to that subsystem, bearing the \verb@HsVal@ of the +callback. To run the callback, the subsystem will later +call \verb@eval@ on the callback. But if the same OS thread is +still ``inside'' the HEP, this call will block. + +A solution is to release the lock when an OS thread \verb@ccall@s +out of the HEP. This allows other threads, or callbacks in the +same thread, to successfully enter the HEP -- not necessarily +immediately, but eventually, assume the OSs thread scheduling +is fair. + + +\subsection{Haskell to STG compiler (Hs2Stg)} +\begin{verbatim} +-- look at text of module and get import list +getImportList :: ModuleName -> [ModuleName] + +-- convert .hs to stg trees +compileModule :: ModuleName -> [STG] +\end{verbatim} + + + +\subsection{Interface reader (RdIF)} +Loading of mutually recursive groups of objects is allowed even +though Hugs can't handle that at the source level. Internally, +\cfun{loadObjectGroup} has to make two passes through the +interface files, the first to create partially-filled entries in SSym, and the +second to complete those entries. +\begin{verbatim} +-- look at interface file for module and get import list +getImportList :: ModuleName -> [ModuleName] + +-- load a group of modules, resolving references between them +-- update OSym and SSym +loadObjectGroup :: [ModuleName] -> () +\end{verbatim} + + + +\subsection{Source symbol table (SSym)} +\begin{verbatim} +-- create/delete entries for a new module +newModule :: ModuleName -> () +delModule :: ModuleName -> () + +-- various functions for adding/querying vars, tycons, classes, instances +-- and in particular +setClosureOf :: Name -> Pointer -> () +getClosureOf :: Name -> Pointer +\end{verbatim} + + +\subsection{Object symbol table (OSym)} +\begin{verbatim} +-- add, delete module-level entries +addOMod :: ModuleName -> () +delOMod :: ModuleName -> () +-- add, find symbols +addOSym :: ModuleName -> Name -> Pointer -> () +findOSym :: ModuleName -> Name -> Pointer +\end{verbatim} + + + +\subsection{Object loader (OLoad)} +\begin{verbatim} +-- check object for correct format, etc +validateObject :: ModuleName -> Bool +-- get object into memory and update OSym, but don't link it +loadObject :: ModuleName -> () +-- resolve refs in previously loaded object +linkObject :: ModuleName -> () +-- remove object from memory +delObject :: ModuleName -> () +\end{verbatim} + + +\subsection{Storage manager and evaluator (RTS)} +\begin{verbatim} +-- eval this ptr to WHNF +enter :: Pointer -> () +\end{verbatim} + + + +\subsection{Code generators, STG to bytecode (Stg2BC) and STG to OTHER + (Stg2Com)} +\begin{verbatim} +stg2BC, stg2OTHER :: [STG] -> () +\end{verbatim} + + +\subsection{The user interfaces} +... don't have a programmatic interface. + + + + +\section{Tentative design details looking for a home} + +These sections record how the various bits of the new system +should work. In may places it merely records what the existing +system does. + +\subsection{Compile-time storage management} +{\bf ToDo}: draw some pictures of how the tables interrelate. + +Relevant structures are +\begin{itemize} +\item compile-time heap +\item Source symbol table, comprising: name table, tycon table, +class table, instance table, module table +\item Text table (not sure where this logically belongs) +\item Object symbol table +\end{itemize} +Needs to be redone. Design goals are: +\begin{itemize} +\item Should be able to delete an arbitrary module from the system + and scrub all references to it. The current Hugs scheme only + allows deleting of modules in a LIFO fashion. +\item No fixed table sizes for anything! + Everything to by dynamically resizable on-the-go. + This is a long-overdue change. +\item No changes to the client code. No way do we want to rewrite + the typechecker, static analyser, etc. That means that + any reimplementation will have to supply suitable versions + of the many macros used to access storage in current Hugs. + Indeed, the viability of this enterprise depends on + the observation that the current Hugs consistently uses these + macros/functions and does not go directly to the structures. +\end{itemize} + +For the time being, it seems best not to mix the compile-time +and run-time heaps. It might be possible, but there are a bunch +of unknown factors, and fixing them seems to have a low +brownie-points/effort ratio: +\begin{itemize} +\item Hugs assumes the existence of a ``generic'' pointer-ish entity. + This might point into the heap, but if it doesn't, then it can + be a reference to a symbol table, an integer, a piece of text, + or various other things. This simplifies the typechecker and + static analysis. (I guess you could say it's a union type). + + Let's call these values ``compile-time pointers''. + + GHC's storage manager would need to be modified to + deal with fields which might or not might be pointers. + +\item Assignment. Hugs frequently (?) mutates heap objects. I'm + unsure what effect this would have on the RTS if a pointer field + is changed to a non-pointer one, or vice versa. + + Also, when doing assignments, the old-to-new pointer tables + would need to be checked and updated. Changes to + client code at assignment points seem unavoidable. +\end{itemize} +\subsubsection*{Name, tycon, class and instance tables} +Each name table entry describes a top-level value in a Haskell module. +It holds a pointer to the textual name, the type, pointers to the +STG trees and compiled bytecode, and various other things. A +compile-time pointer can point directly at a name table entry. + +Like existing Hugs, we continue to organise the name table as an +array of name table entries. Unlike existing Hugs, the name +entries for a given module do not occupy a contiguous range +of the name table. To do so makes it impossible to delete +modules, since deletion of a module would create a large hole +in the table. To fill this hole, we'd have to slide other entries +around, but then we'd need to find and change all +compile-time pointers to the moved entries (viz, the usual +compacting-GC problem). The latter could be +very difficult. + +Instead, each name table entry has a link field, which is used to +chain together all entries for a given module. For unused entries, +the link fields implement a standard freelist. Allocation of new +entries consults the freelist. If that's empty, the table is +expanded as follows: a bigger array, perhaps twice the size, is +malloc'd. The existing name table is copied into it, and the +new entries are put on the free list. + +When a module is deleted, all its name table entries are put back on +the free list. + +The tycon, instance and class tables function in exactly the same way. +The module table is different. + +\subsubsection*{Notion of the ``current module's scope''} +When translating a module, Hugs needs to have a way, given the text +of a symbol, to (a) find out if it is in scope in this module, and +(b) if so, what value/type it is bound to. Because a module can +import symbols from other modules, the current scope is not just +the contents of the current module. + +To support this, name table entries have a second link field. +This field is used to chain together all entries in the current +scope. Unlike the module-link fields, this chain necessarily +visits entries from many different modules. + +Because each name table only has one scope-link field, only +one current scope can be supported at any time. When Hugs +starts processing a new module, the current scope chain has to +be rebuilt for that module, by processing its import declarations, +and recursing down through other modules as necessary. This operation +is expensive and should be done infrequently. + +Having a single chain for the current scope makes +name lookup terribly inefficient. The current Hugs uses a small +256 entry hash table to help. Each hash table entry points to a +chain of name-table entries with the same hash value, chained as +described above through the current-scope field. In other words, +there are 256 current-scope chains, not just one, and they all +begin at the hash table. So, when changing current module, +Hugs has to rebuild the hash table as well as the chains. + +Tycons, classes and instances use exactly the same scheme. + + +\subsubsection*{The module table} + +Unlike the name, tycon, class and instance table, this one +has exactly one entry per module. Each entry contains +pointers to: the textual name of the module, +an import list, an export list, +the start of the name-table chain +for this module, ditto for tycons, classes and instances, +and perhaps a pointer to a list of STG trees denoting the +code generated for the module. When a module is deleted, +its module table entry is marked as unused. This table can +be resized by copying it into a larger array if needed, in the +usual way. + +\subsubsection*{The text table} + +This remains pretty much the same as before, with the proviso +that entries in it cannot be ejected when a module is deleted. +If it gets full, we expand it by copying it onto a bigger +array in the usual way. In practice this is unlikely to be +a problem, since loading a revised version of a recently-deleted +module is very likely to present almost the same set of strings +as the old version, thereby not increasing the size of the +table very much. + +One final detail: the current hashing scheme to find stuff in +the table will need to be carefully revised so that it can +still work when the table size is, say, doubled. Apparently +\verb@rts/Hash.c@ contains a suitable algorithm. + +\subsubsection*{The object symbol table} + +We may as well make the object symbol table work in the same way as +the name, tycon, class and instance tables. That is, an array of +symbol records, with each record having a link field to chain together +entries in the same module, and another field linking together entries +with the same hash values. The table can expand dynamically, and +modules can be thrown out of the table in any order. There is a +top-level hash table holding the start point of the hash chains. + +Unlike the name, class, tycon and instance tables, the hash table +and chains for the object symbol table reflects all the available +symbols, not just those regarded as in scope for the current module +being translated. + +\subsubsection*{Dividing up the compile-time-pointer space} + +Hugs has always had the notion of a pointer which {\em might} +point into the compile-time heap, or it might not, denoting a +name, piece of text, etc. This is a great idea, but needs redoing. + +Problem is that the address spaces for the various kinds of +entities are arranged contiguously, with no gaps in between. This +make it impossible to expand the address range for some particular +kind of entity without disturbing the other address ranges. + +We propose instead to use a tag-and-value scheme. A +compile-time-pointer +is still a 32-bit integer, but divided up thusly: +\begin{verbatim} + <-1-> <--7--> <--24--> + 0 tag value +\end{verbatim} +The tag space is arranged like this (pretty arbitrary; requires a +trawl through existing storage.h to pick up all stuff): +\begin{verbatim} + 000 0000 is an illegal tag + 0xx xxxx denotes a heap number. value field is address in that heap. + 100 0000 Text + 100 0001 Name + 100 0010 Class + 100 0011 Instance + 100 0100 an integer; 24-bit value field gives value + 100 0101 Object symbol table entry + 100 0110 Tuple constructor; value field gives tuple number + 100 0111 Offset; value in value field + ........ + 101 0000 ``Box cell tag'' (TAGMIN .. BCSTAG); + actual value is in value & 0xff + 101 0001 ``Constructor tag'' (LETREC .. SPECMIN-1); + value is in value & 0xff + 101 0010 ``Special tag'' (SPECMIN .. PREDEFINED); + value is in value & 0xff +\end{verbatim} +\verb@000 0000@ is an illegal tag so that we can continue the +convention +that a 32-bit zero word means NIL. We could have redefined NIL, but +it is frequently tested for, and tests against zero are fast on most +(RISC) architectures. + +There are up to 63 possible heaps, each with up to 16 M entries. +This facilitates a dynamically expanding heap. The idea is to start +off with a single small heap of say 20000 cells. When this fills, +a new lump of memory can be malloc'd and used as a second heap, of +perhaps 40000 cells, giving 60000 in total. Hugs needs to know the +size of each heap for GC purposes, but there are no required size +relationships between them. + +In principle, if Hugs can guarantee that there are no references +to a given heap, it can return that memory to the operating system +(or at least \verb@free@ it). + +This is a tradeoff. The \verb@fst@ and \verb@snd@ macros +take more instructions: +\begin{verbatim} + #define fst(p) heap[p >> 24][p & 0xffffff].fst + #define snd(p) heap[p >> 24][p & 0xffffff].snd +\end{verbatim} +Each of these translate to 5 Intel x86 insns; I have measured it. +In the current Hugs, \verb@fst@ and \verb@snd@ are just array +references, possibly just 1 x86 insn. +On the other hand, if \verb@fst(p)@ is referenced close in time +to \verb@snd(p)@, for the same \verb@p@, it's likely that the +second reference will still be in the CPU's data cache. The original +Hugs has separate arrays for \verb@fst@ and \verb@snd@. + +Further compensation is that the ubiquitous \verb@whatIs@ call +is a lot cheaper this way, since we just shift out the tag: +\begin{verbatim} + #define whatIs(x) ((x) >> 24) +\end{verbatim} +which is just a single instruction, instead of a whole sequence +implementing a binary search tree, as at present. + +Texts, names, classes, and other entities with only one tag value, +can have up to 16 M entries, since the value field is 24 bits long. +After some discussion, we feel that (eg) 16 M names is enough for +programs at least ten times the size of GHC, around half a million +lines of code. + +I'm going to call these entities \verb@HugsPtr@ in pseudocode bits. + +\subsection{The code generator interface} +More details on how this hangs together. +\begin{verbatim} +stg2BC, stg2OTHER :: [(Name, STG_TREE)] -> () +markRTSobjects_BC, +markRTSobjects_OTHER :: Name -> () +\end{verbatim} +The result of translating a Haskell module to STG trees is a +{\em code list}: a list of pairs \verb@(Name, STG_TREE)@. +Each tree represents a function or CAF, either written by +the programmer in the source module, or generated automatically, +by desugaring, \verb@deriving@ clauses, or lambda lifting. + +The \verb@Name@ component of the pairs points to a name +table entry for the tree. And that name table entry points +back at the pair. In previous hacking, I often needed to +get a name table entry from a tree, and vice versa. Without a +bidirectional link, this requires a search of all the name tables +or all the trees, which is inefficient. + +So each tree has a name table entry, even if it isn't part of +the source given by the user. That makes life simpler and more +uniform, even if it wastes a little space in the name table. + +When the bytecode compiler translates source to trees, it +generates a code list, and sets up the links from the code +list to the name table and back. + +To generate bytecode objects in the GHC-RTS- or OTHER-managed +heap, \verb@stg2BC@ or \verb@stg2OTHER@ is passed the code list. +A simple interface, but what goes on inside could be quite complex. +\begin{itemize} +\item For one thing, each STG tree can turn into multiple + BCOs (I guess I should be more general and say ``code blocks''), + because of the STG way of translating \verb@case@ expressions. + At GC time, all of these need to be found and kept alive. + + I propose that each name table entry include the following + fields: + \begin{verbatim} + code_list_entry :: HugsPtr + rts_primary :: HugsPtr + rts_secondaries :: [HugsPtr] + \end{verbatim} + \verb@code_list_entry@ is a pointer to the relevant + code list pair. The STG tree lives, of course, in the + compile-time heap. + + After code generation, \verb@rts_primary@ and + \verb@rts_secondaries@ hold pointers into the code blocks + in the {\em runtime} heap. (NB -- these pointers are + \verb@HugsPtr@s pointing to boxed pointers in the compile-time + heap, as at present.) \verb@rts_primary@ holds the address + of the code-block (or whatever one enters) generated from + the tree as a whole. \verb@rts_secondaries@ is a list of + pointers to subsidiary code blocks, such as \verb@case@ + return continuations. + + Only the specific code generators needs to understand the + precise meaning and layout of what \verb@rts_primary@ and + \verb@rts_secondaries@ point at. Each code generator + must also supply a \verb@markRTSobjects@ function, which + examines and marks the \verb@rts_@ entries in the specified + name table entry. + +\item Linking. + Code generators will have to traverse the code list twice, + once to generate code, and once to fix inter-tree + references. ((Blargh -- unresolved details ahead)) + The first pass translates each tree into a collection + of BCOs. Each BCO has unresolved references to other + BCOs, but how are they recorded? Erk. But I don't + think this is v. important? + + In the second pass, the unresolved refs are fixed. + + It seems that the BCOs can't be constructed directly in the + heap, because the intermediate BCOs need a fixup table which + the final ones don't. Current StgHugs has \verb@AsmBCO@s for + the intermediaries, living in mallocville, and \verb@StgBCOs@ + for the Real Thing in the RTS heap. The \verb@AsmBCO@s are + freed at the end of code generation for a module. Because + Hugs doesn't support mutually recursive modules, the entire + codegen-resolve cycle can happen on a per-module basis. + +\end{itemize} + +\section{\ToDo{}} +Clarify how mutually recursive object modules are loaded. + + +\end{document} \ No newline at end of file diff --git a/docs/index.html.in b/docs/index.html.in new file mode 100644 index 00000000..4c1be827 --- /dev/null +++ b/docs/index.html.in @@ -0,0 +1,58 @@ + + + + GHC Documentation + + + + +

    GHC Documentation

    + +

    + Welcome to GHC! +

    + +

    + This is the top of the GHC documentation tree, where you will find + links to all the supplied documentation about GHC and its libraries. +

    + +
      +
    • +

      + The User's Guide +

      +

      + The User's Guide has all you need to know about using GHC: + command line options, language extensions, GHCi, etc. +

      +
      • + +
    • +

      + Libraries +

      +

      + Documentation for the libraries that come with GHC. +

      +
      • + +
    • +

      + GHC API +

      +

      + Documentation for the GHC API. +

      +
      • +
    + +

    For more information, see the following:

    + + + + diff --git a/docs/man/gen_flags.xsl.sh b/docs/man/gen_flags.xsl.sh new file mode 100644 index 00000000..fed694f1 --- /dev/null +++ b/docs/man/gen_flags.xsl.sh @@ -0,0 +1,290 @@ +#!/bin/sh + +if [ "$#" -ne 2 ] +then + echo "Usage: $0 " + exit 1 +fi + +GHC_COMMANDS="$1" +LIBDIR="$2" + +cat <<'EOF' + + + + + + + +.\" +.\" This is a generated file. Changes might get clobbered. Edit at own's risk. +.\" +.TH GHC 1 "2002-10-25" "Glasgow FP Suite" "Glasgow Haskell Compiler" +.SH NAME +GHC \- the Glasgow Haskell Compiler + + +.SH SYNOPSIS +EOF + +STARTED=0 + +for GHC_COMMAND in $GHC_COMMANDS +do + if [ "$STARTED" -ne 0 ] + then + echo ".br" + fi + STARTED=1 + cat < + + + + +.SH FILES +EOF + +echo ".I $LIBDIR" +cat <<'EOF' + +.SH COPYRIGHT + +Copyright 2002, The University Court of the University of Glasgow. +.br +All rights reserved. + + +.SH AUTHOR + +This manual page was generated from the XML documentation of GHC with blood, +sweat, tears and a breaks-if-you-look-at-it-the-wrong-way XSL +stylesheet originally written by Michael Weber <michaelw@debian.org> +for the Debian GNU/Linux system (but may be used by others). + +.\" End + + + + + + +.SS + + +.SS + + +.nh + +.hy + + + + + + + +.SH + + + + +.SH + + + + + + + + + + + + + + +.TP + + + + + + +.rj +[] + + + + + + + + + + + + + + + + + + + + + + + + \fB + + \fP + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \fI + + \fP + + + + + \f(CR + + \fP + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + diff --git a/docs/man/ghc.mk b/docs/man/ghc.mk new file mode 100644 index 00000000..0c1014b4 --- /dev/null +++ b/docs/man/ghc.mk @@ -0,0 +1,58 @@ + +ifeq "$(BUILD_MAN)" "" +ifeq "$(strip $(XSLTPROC))" "" +BUILD_MAN = NO +else +BUILD_MAN = YES +endif +endif + +# The commands which should be mentioned in the man page +MAN_GHC_COMMANDS = ghc ghci + +# The man page we are generating +MAN_PAGE = ghc + +# The manual section +MAN_SECTION = 1 + +MAN_PATH = docs/man/$(MAN_PAGE).$(MAN_SECTION) + +ifneq "$(BINDIST)" "YES" +$(MAN_PATH): docs/man/flags.xsl docs/man/flags.xml + $(XSLTPROC) $(XSLTPROC_OPTS) $^ > $@ +endif + +# Insert the commands and the library directory into the man page +docs/man/flags.xsl: docs/man/gen_flags.xsl.sh + $(SHELL) $< "$(MAN_GHC_COMMANDS)" "$(libdir)" > $@ + +# Re-use the flags documentation from the user's guide by injecting some +# entities after the XML declaration to make it a stand-alone document. +docs/man/flags.xml: docs/users_guide/flags.xml + $(call removeFiles,$@) + head -n 1 $< >> $@ + echo " \ + \ + ]>" >> $@ +# "sed 1d" == "tail -n +2", but Solaris apparently rejects the latter + sed 1d $< >> $@ + +ifeq "$(BUILD_MAN)" "YES" +ifeq "$(phase)" "final" +$(eval $(call all-target,docs/man,$(MAN_PATH))) +endif + +INSTALL_MANPAGES += $(MAN_PATH) + +install: install_man + +.PHONY: install_man +install_man: $(MAN_PATH) + $(call INSTALL_DIR,"$(DESTDIR)$(mandir)") + $(call INSTALL_DIR,"$(DESTDIR)$(mandir)/man$(MAN_SECTION)") + $(call INSTALL_MAN,$(INSTALL_OPTS),$(MAN_PATH),"$(DESTDIR)$(mandir)/man$(MAN_SECTION)") +endif + +$(eval $(call clean-target,docs/man,,$(MAN_PATH) docs/man/flags.xsl docs/man/flags.xml)) + diff --git a/docs/ndp/haskell.sty b/docs/ndp/haskell.sty new file mode 100644 index 00000000..3e4d478b --- /dev/null +++ b/docs/ndp/haskell.sty @@ -0,0 +1,496 @@ +%%% This is a LaTeX2e style file. +%%% +%%% It supports setting functional languages, such as Haskell. +%%% +%%% Manuel M. T. Chakravarty [1998..2002] +%%% +%%% $Id: haskell.sty,v 1.2 2004/04/02 08:47:53 simonmar Exp $ +%%% +%%% This file is free software; you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation; either version 2 of the License, or +%%% (at your option) any later version. +%%% +%%% This file is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% Acknowledegments ========================================================== +%%% +%%% Thanks to Gabriele Keller for beta testing and +%%% code contributions. Thanks to the LaTeX3 project for improving the LaTeX +%%% sources (which helped me writing this code). Furthermore, I am grateful +%%% to Martin Erwig and Bernard J. Pope +%%% for feedback and suggestions, and to Conal Elliott +%%% and Marc van Dongen for pointing +%%% out a tricky bug. +%%% +%%% TODO ====================================================================== +%%% +%%% B ~ bug; F ~ feature +%%% +%%% * B: Consider to use the following alternative definition for \<..\>: +%%% +%%% \def\<{\bgroup\@hsSpaceToApp\endhs} +%%% \def\endhs#1\>{\(\mathit{#1}\)\egroup} +%%% +%%% It completely avoids the problem that \mathit\bgroup..\egroup isn't +%%% guaranteed to work and seems more elegant, anyway. +%%% +%%% * F: Along the lines of the discussion with Martin Erwig add support for +%%% keywords etc (see the emails) +%%% +%%% * B: If we have as input +%%% +%%% \ +%%% +%%% there won't be a `\hsap' inserted!! (Can this be solved by using +%%% \obeylines in \<...\>?) +%%% +%%% * B: A \relax is needed after a & if it immediately followed by a \hsbody{} +%%% (See TeXbook, S.240) +%%% +%%% * F: Implement a \hstext{...} as \(\text{...}\). +%%% +%%% * F: Star-form of \hscom that uses "---" instead of "-\hskip0pt-" +%%% +%%% * We would like hswhere* etc that are like haskell* (\hsalign already +%%% supports this, ie, there is a \hsalign*). +%%% +%%% * Star-Versions of if, let etc that use a single line layout (maybe not +%%% with star, because of the above). +%%% +%%% * Support for enforcing and prohibiting breaks in `haskell' displays. +%%% +%%% * Comments in a let-in should be aligned in the same way for the bindings +%%% and the body. +%%% +%%% * It would be nice to have different styles (indentation after in of +%%% let-in or not) etc; either to be set with a package option or in the +%%% preamble (the latter probably makes more sense). +%%% +%%% * Literate programming facility: Variant of the `haskell' env (maybe +%%% `hschunk', which is named and can be used in other chunks). But maybe +%%% it is not necessary to provide a chunk-based reordering mechanism, +%%% because most of the Haskell stuff can be in any order anyway... +%%% Important is to provide a way to define visually pleasing layout +%%% together with the raw Haskell form for program output. (Maybe `haskell*' +%%% as Haskell env that outputs its contents?) +%%% + +%% Initialization +%% ============== + +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{haskell}[2002/02/08 v1.1a Chilli's Haskell Style] + +% NOTE: The sole purpose of the following is to work around what I believe is +% a bug in LaTeX. If the first occurrence of \mathit in a document uses +% \bgroup and \egroup to enclose the argument (instead of { and }), +% \mathit does *not* apply to the argument. (I guess, some font +% initialisation stuff is getting in the way of parsing the argument.) +% +% The following forces a \mathit right after \begin{document}. +% +% UPDATE: The LaTeX project people say that it isn't really a bug; more +% like a not supported form. See alternative definition in the +% bug list above. +% +\AtBeginDocument{\setbox0=\hbox{\(\mathit\relax\)}} + + +%% Parameters +%% ========== + +\newskip\hsmargin +\hsmargin\leftmargini + + +%% Main macros and environments +%% ============================ + +% applications +% +\newcommand{\hsap}{% % application by juxtaposition + \unskip\mskip 4mu plus 1mu} % only the last \hsap counts + +% commands to start and stop setting spaces as \hsap +% +{\obeyspaces\gdef\@hsSpaceToApp{\obeyspaces\let =\hsap}} % spaces matter!!! +{\obeyspaces\gdef\@hsNormalSpace{\let =\space}} + +% commands to start and stop treating numbers specially, ie, we don't want +% them to be affected by font changing commands in Haskell contexts as this +% would give italic numerals; the trick is to redefine their math code such +% that they go into math class 0 and thus don't change families (cf. `The +% TeXbook', Chapter 17, pp152) +% +\newcommand{\@hsRmNumbers}{% + \mathcode`0="0030 + \mathcode`1="0031 + \mathcode`2="0032 + \mathcode`3="0033 + \mathcode`4="0034 + \mathcode`5="0035 + \mathcode`6="0036 + \mathcode`7="0037 + \mathcode`8="0038 + \mathcode`9="0039 + } +\newcommand{\@hsNormalNumbers}{% + \mathcode`0="7030 + \mathcode`1="7031 + \mathcode`2="7032 + \mathcode`3="7033 + \mathcode`4="7034 + \mathcode`5="7035 + \mathcode`6="7036 + \mathcode`7="7037 + \mathcode`8="7038 + \mathcode`9="7039 + } + +% Save the bindings of the standard math commands +% +% This is somewhat subtle as we want to able to enter the original math mode +% within Haskell mode and we have to ensure that the different opening +% commands are matched by the correct versions of the closing commands. +% +\let\@hsmathorg=\( +\let\@hsmathendorg=\) +\let\hs@crorg=\\ +\newcommand{\@hsmath}{% + \relax\hbox\bgroup + \@hsNormalSpace + \@hsNormalNumbers + \let\(=\@hsmathorgx + \let\)=\@hsmathend + \def\\{\hs@crorg}% + \@hsmathorg + } +\newcommand{\@hsmathend}{% + \@hsmathendorg + \egroup + } +\newcommand{\@hsmathorgx}{% + \relax\@hsmathorg + \let\)=\@hsmathendorg + } + +%% Typesetting of Haskell +%% ====================== + +% Inline Haskell phrases are delimited by `\<' and `\>'. +% +% Note: `\>' is only locally redefined. +% +\newcommand{\<}{% + \@hsmathorg + \mathit\bgroup + \@hsSpaceToApp + \@hsRmNumbers + \let\>=\@endhs + \let\(=\@hsmath + \def\\{\cr} % for Haskell alignments + } +\newcommand{\@endhs}{% + \egroup + \@hsmathendorg + } + +% Displayed Haskell (environment `haskell' and `haskell*') +% +% There are two kind of preambles for \halign: \hs@preambleNorm is for +% `amsmath' style alignments and \hs@preambleStar for `equation' style +% alignments (but with an unbound number of columns to its right) +% +% We need #### to get a ## in the \edef building the \halign command. +% +% first the preambles (also used in \hs@align below): +% +\def\hs@preambleNorm{% + \noexpand\<####\unskip\noexpand\>\hfil&&\noexpand% + \<{}####\unskip\noexpand\>\hfil} +\def\hs@preambleStar{% + \noexpand\<####\unskip\noexpand\>\hfil&\hfil\noexpand% + \<{}####\unskip{}\noexpand\>\hfil&&\noexpand\<{}####\noexpand\>\hfil} +% +% the environments: +% +\newenvironment{haskell}{% + \@haskell\hs@preambleNorm}{% + \@endhaskell + } +\newenvironment{haskell*}{% + \@haskell\hs@preambleStar}{% + \@endhaskell + } +% +% auxiliary definition getting the preamble as its first argument and starting +% the environment: +% +\def\@haskell#1{% + \bgroup + \vspace\abovedisplayskip + \let\(=\@hsmath % Important when `\(' occurs after `&'! + \edef\@preamble{% + \halign\bgroup\hskip\hsmargin#1\cr} + \@preamble + } +% +% Auxiliary definition ending environment: +% +\def\@endhaskell{% + \crcr\egroup +% \vspace\belowdisplayskip + \egroup\noindent\ignorespaces\global\@ignoretrue% + } + +% single line comment and keyword style +% +\newcommand{\hscom}[1]{% + \relax\(\quad\textnormal{-\hskip0pt- #1}\)} +% \relax\(\quad\textnormal{--- #1}\)} +\newcommand{\hskwd}[1]{% + \mathbf{#1}} + +% informal description +% +\newcommand{\hsinf}[1]{% + \(\langle\textnormal{#1}\rangle\)} + +% literals and some special symbols +% +\newcommand{\hschar}[1]{\textrm{'#1'}} % character literals +\newcommand{\hsstr}[1]{\textrm{``#1''}} % strings literals +\newcommand{\hsfrom}{\leftarrow} % <- + +% aligned subphrases +% +% check for an optional star and combine prefix (in #1) with one of the two +% preambles (with star means to center the material between the first and +% second &) +% +\def\hs@align#1{% + \@ifstar + {\hs@align@pre{#1\hs@preambleStar}}% + {\hs@align@pre{#1\hs@preambleNorm}}% + } +% +% test for optional argument; #1: preamble +% +\def\hs@align@pre#1{% + \@testopt{\hs@align@prealign#1}t} +% +% got all arguments, now for the real code; #1: preamble; #2: alignment; +% #3: body (the material set by the \halign) +% +\def\hs@align@prealign#1[#2]#3{% + \relax\( + \edef\@preamble{% + \halign\bgroup#1\cr} + \if #2t\vtop \else \if#2b\vbox \else \vcenter \fi\fi + \bgroup% + \@preamble + #3% + \crcr\egroup% + \egroup\) + } +% +% user-level command: alignment without a prefix +% +\newcommand{\hsalign}{% + \relax + \hs@align\relax% + } + +% subphrase breaking the surrounding alignment being flushed left +% +\newcommand{\hsnoalign}[1]{% + \noalign{% + \hs@align{\hskip\hsmargin}{#1}% + }% + } + +% body expression breaking the surrounding alignment +% +% * setting \hsmargin to 0pt within the preamble (and _after_ it is used in +% the preamble) is crucial, as we want \hsmargin only to be applied in +% _outermost_ alignments +% +\newcommand{\hsbody}[1]{% + {}\\ + \noalign{% + \hs@align{\hskip\hsmargin\quad\hsmargin0pt}{#1}% + }% + } + + +%% Defining commands for use in the Haskell mode +%% ============================================= +%% +%% We use some of the low-level machinery defined in LaTeX's source file +%% `ltdefns.dtx'. +%% +%% \hscommand is similar to \newcommand, but there is no *-version. +%% +%% We use our own definitions here to insert a strategic `\relax' (see below) +%% and to obey spaces within the bodies of Haskell definitions. + +\newcommand{\hscommand}[1]{\@testopt{\hs@newcommand#1}0} +\def\hs@newcommand#1[#2]{% + \obeyspaces % spaces count in Haskell macros + \@ifnextchar [{\hs@xargdef#1[#2]}% + {\hs@argdef#1[#2]}} + +% All this trouble only to be able to add the `\relax' into the expansion +% process. If we don't that, commands without optional arguments when +% invoked after an alignment character & don't work properly (actually, the +% \obeyspaces doesn't work). I am sure that has to do with the scanning for +% \omit etc in \halign (TeXbook, p240), but I don't understand yet why it +% is problematic in this case. +% +% Furthermore, we switch off \obeyspaces in the end. +% +\long\def\hs@argdef#1[#2]#3{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \relax % in order to stop token expansion after & + \csname\string#1\expandafter\endcsname}% + \expandafter\@yargdef + \csname\string#1\endcsname + \@ne + {#2}% + {#3}}% + \catcode`\ =10% % stop obeying spaces now + } + +% Switch off \obeyspaces in the end. +% +\long\def\hs@xargdef#1[#2][#3]#4{% + \@ifdefinable#1{% + \expandafter\def\expandafter#1\expandafter{% + \expandafter + \@protected@testopt + \expandafter + #1% + \csname\string#1\expandafter\endcsname + {#3}}% + \expandafter\@yargdef + \csname\string#1\endcsname + \tw@ + {#2}% + {#4}}% + \catcode`\ =10% % stop obeying spaces now + } + + +%% Abbreviations +%% ============= + +% infix operators +% +\newcommand{\hsapp}{\mathbin{+\mkern-7mu+}} +\newcommand{\hsifix}[1]{\mathbin{\string`#1\string`}} + +% let expression +% +\hscommand{\hslet}[3][t]{% + \hsalign[#1]{% + \hskwd{let}\\ + \quad\hsalign{#2}\\ + \hskwd{in}\\ + #3 + }% + } + +% if expression +% +\hscommand{\hsif}[4][t]{% + \hsalign[#1]{% + \hskwd{if} #2 \hskwd{then}\\ + \quad\hsalign{#3}\\ + \hskwd{else}\\ + \quad\hsalign{#4}% + }% + } + +% case expression +% +\hscommand{\hscase}[3][t]{% + \hsalign[#1]{% + \hskwd{case} #2 \hskwd{of}\\ + \quad\hsalign{#3}% + }% + } + +% where clause +% +% * it is important to take the \quad into the preamble, so that nested +% \noaligns can break it +% +\hscommand{\hswhere}[1]{% + \hsbody{% + \hskwd{where}\\ + \hs@align{\quad}{#1}% + }% + } + +% do expression +% +\hscommand{\hsdo}[2][t]{% + \hsalign[#1]{% + \hskwd{do}\\ + \quad\hsalign{#2}\\ + }% +} + +% class declaration +% +\hscommand{\hsclass}[2]{% + \hskwd{class} #1 \hskwd{where} + \hsbody{% + #2 + }% +} + +% instance declaration +% +\hscommand{\hsinstance}[2]{% + \hskwd{instance} #1 \hskwd{where} + \hsbody{% + #2 + }% +} + + +%% Extensions for Distributed Haskell (Goffin) +%% =========================================== +%% +%% These definitions may change in the future. + +\hscommand{\hsunif}{\mathbin{:=:}} +\hscommand{\hsalias}{\mathrel{\sim}} +\hscommand{\hsoutof}{\twoheadleftarrow} +\hscommand{\hsinto}{\twoheadrightarrow} +\hscommand{\hsparc}{\binampersand} +\hscommand{\hsseq}{\Longrightarrow} +\hscommand{\hsex}[2]{{\hskwd{ex} #1 \hskwd{in} #2}} + +\hscommand{\hsexin}[3][t]{% + \hsalign[#1]{% + \hskwd{ex} #2 \hskwd{in}\\ + \quad\hsalign{#3}\\ + }% + } + +\hscommand{\hschoice}[2][t]{% + \hsalign[#1]{% + \hskwd{choice}\\ + \quad\hsalign{#2}\\ + }% + } + + diff --git a/docs/ndp/vect.tex b/docs/ndp/vect.tex new file mode 100644 index 00000000..cf6ee77e --- /dev/null +++ b/docs/ndp/vect.tex @@ -0,0 +1,363 @@ +\documentclass{article} +\usepackage{haskell} + +\hscommand{\vect}[1]{(#1)_v} +\hscommand{\lift}[2]{(#1)^{\uparrow#2}} +\hscommand{\liftn}[1]{(#1)^{\uparrow{n}}} + +\hscommand{\patype}[1]{\mathsf{patype}\langle#1\rangle} +\hscommand{\pa}[1]{\mathsf{pa}\langle#1\rangle} + +\hscommand{\capp}{\mathbin{{\$}{:}}} +\hscommand{\cappP}{\mathbin{{\$}{:}^\uparrow}} + +\hscommand{\parr}[1]{[{:}{:}#1{:}{:}]} +\hscommand{\pparr}[1]{[{:}#1{:}]} + +\hscommand{\Data}{\hskwd{data}} +\hscommand{\DataF}{\hskwd{data~family}} +\hscommand{\DataI}{\hskwd{data~instance}} +\hscommand{\NewtypeI}{\hskwd{newtype~instance}} + +\setlength{\parindent}{0cm} + +\begin{document} + +\section*{Library} + +\subsection*{Parallel arrays} + +We distinguish between user-visible, parametric arrays (\<\pparr{\cdot}\>) and +flattened parallel arrays (\<\parr{\cdot}\>) which are internal to our +implementation. Operations on the former have purely sequential semantics. +During vectorisation, they are replaced by parallel arrays and operations. + +\begin{haskell} +\Data \pparr{\alpha} = Array Int \alpha \hscom{or similar} \\ +\DataF \parr{\alpha} +\end{haskell} + +\subsection*{\ dictionaries} + +To avoid problems with using typeclasses in Core, we use explicit records for +representing dictionaries of type-dependent operations on parallel arrays: + +\begin{haskell} +\Data PA \alpha = & PA \{ + \hsbody{lengthP & :: \parr{\alpha}\to{Int} \\ + replicateP & :: Int\to\alpha\to\parr{\alpha} \\ + \ldots \\ \}} +\end{haskell} + +In vectorised code, polymorphic functions must be supplied with a \ +dictionary for each type variable. For instance, \<\Lambda\alpha.e\> turns +into \<\Lambda\alpha.\lambda{dPA_\alpha}::PA \alpha.e'\>. + +For higher-kinded type variables, we expect a function of appropriate type +which computes the dictionary for a saturated application of the type +variable from the dictionaries of the arguments. For instance, +\<\Lambda{m}::{*}\to{*}.e\> turns into +\<\Lambda{m}::{*}\to{*}.\lambda{dPA_m}::(\forall\alpha::{*}.PA \alpha\to{PA} +(m a)).e'\>. +In general, the type of the \ argument for a type \<\sigma::\kappa\> is +given by + +\begin{haskell} +\patype{\sigma:{*}} & = PA \sigma \\ +\patype{\sigma:\kappa_1\to\kappa_2} & = +\forall\alpha:\kappa_1.\patype{\alpha:\kappa_1}\to\patype{\sigma \alpha:\kappa_2} +\end{haskell} + +For each user-defined or built-in type constructor \ we +automatically define its dictionary \. Moreover, for every +in-scope type variable \<\alpha\> we have its dictionary +\. This allows us to compute the dictionary for +an arbitrary type as follows: + +\begin{haskell} +\pa{T} & = dPA_T \\ +\pa{\alpha} & = dPA_{\alpha} \\ +\pa{\sigma \phi} & = \pa{\sigma}[\phi] \pa{\phi} \\ +\pa{\forall\alpha::\kappa.\sigma} & = +\Lambda\alpha::\kappa.\lambda{dPA_{\alpha}}::\patype{\alpha::\kappa}.\pa{\sigma} +\end{haskell} + +\subsection*{Closures} + +Closures are represented as follows: + +\begin{haskell} +\Data & Clo \alpha \beta & = \exists\gamma. Clo & (PA \gamma) \gamma + & (\gamma\to\alpha\to\beta) (\parr{\gamma}\to\parr{\alpha}\to\parr{\beta}) \\ +\DataI & \parr{Clo \alpha \beta} & = \exists\gamma. AClo & (PA \gamma) + \parr{\gamma} + & (\gamma\to\alpha\to\beta) (\parr{\gamma}\to\parr{\alpha}\to\parr{\beta}) +\end{haskell} + +Closure application is implemented by the following two operators: + +\begin{haskell} +({\capp}) & :: Clo \alpha \beta \to \alpha \to \beta \\ +({\cappP}) & :: \parr{Clo \alpha \beta} \to \parr{\alpha} \to \parr{\beta} +\end{haskell} + +Note that \<({\cappP})\> is effectively the lifted version of \<({\capp})\>. + +\subsection*{Flat array representation} + +Some important instances of the \<\parr{\cdot}\> family: + +\begin{haskell} +\hskwd{data} & \hskwd{instance} \parr{(\alpha_1,\ldots,\alpha_n)} + & = ATup_n !Int \parr{\alpha_1} \ldots \parr{\alpha_n} \\ +\hskwd{newtype}~ & \hskwd{instance} \parr{\alpha\to\beta} + & = AFn (\parr{\alpha}\to\parr{\beta}) \\ +\hskwd{newtype} & \hskwd{instance} \parr{PA \alpha} + & = APA (PA \alpha) +\end{haskell} + +The last two definitions are discussed later. + +\section*{Vectorisation} + +\subsection*{Types} + +We assume that for each type constructor \, there exists a vectorised +version \ (which can be the same as \). In particular, we have +\begin{haskell} +({\to}_v) & = Clo \\ +\pparr{\cdot}_v & = \parr{\cdot} +\end{haskell} + +Vectorisation of types is defined as follows: + +\begin{haskell} +\vect{T} & = T_v \\ +\vect{\alpha} & = \alpha \\ +\vect{\sigma \phi} & = \vect{\sigma} \vect{\phi} \\ +\vect{\forall\alpha:\kappa.\sigma} & = \forall\alpha:\kappa.\patype{\alpha:\kappa}\to\vect{\sigma} +\end{haskell} + +\subsection*{Data type declarations} + +\begin{haskell} +\vect{\hskwd{data} T = \overline{C t_1 \ldots t_n}} = \hskwd{data} T_v = +\overline{C_v \vect{t_1} \ldots \vect{t_n}} +\end{haskell} + +\subsection*{Terms} + +We distinguish between local variables (\) and global variables and +literals \. We assume that we have the following typing judgement: + +\begin{haskell} +\Delta,\Gamma\vdash{e}:\sigma +\end{haskell} + +Here, \<\Delta\> assigns types to globals and \<\Gamma\> to locals. Moreover, +we assume that for each global variable \, there exists a +vectorised version \, i.e., + +\begin{haskell} +c:\sigma\in\Delta \Longrightarrow c_v:\vect{\sigma}\in\Delta +\end{haskell} + +\subsubsection*{Vectorisation} + +\begin{haskell} +\vect{c} & = c_v & c is global \\ +\vect{x} & = x & x is local \\ +\vect{\Lambda\alpha:\kappa.e} & = +\Lambda\alpha:\kappa.\lambda{dPA_{\alpha}}:\patype{\alpha:\kappa}.\vect{e} \\ +\vect{e[\sigma]} & = \vect{e}[\vect{\sigma}] \pa{\vect{\sigma}} \\ +\vect{e_1 e_2} & = \vect{e_1}\capp\vect{e_2} \\ +\vect{\lambda{x}:\sigma.e} & = Clo \vect{\sigma} \vect{\phi} \tau \pa{\tau} + (y_1,\dots,y_n) \\ + & +\quad\quad(\lambda{ys}:\tau. + \lambda{x}:\vect{\sigma}. + \hskwd{case} ys \hskwd{of} (y_1,\dots,y_n) \to \vect{e}) \\ + & +\quad\quad(\lambda{ys}:\parr{\tau}. + \lambda{x}:\parr{\vect{\sigma}}. + \hskwd{case} ys \hskwd{of} ATup_n l y_1 \dots y_n \to \lift{e}{l}) +\\ + \hswhere{e has type \phi \\ + \{y_1:\tau_1,\dots,y_n:\tau_n\} & = FVS(e)\setminus{x} \\ + \tau & = (\vect{\tau_1},\dots,\vect{\tau_n})} +% \\ +% e has type \phi} +\end{haskell} + +Vectorisation maintains the following invariant: + +\begin{haskell} +\Delta,\Gamma\vdash{e}:\sigma \Longrightarrow + \Delta,\Gamma_v\vdash\vect{e}:\vect{\sigma} +\end{haskell} + +where \<\Gamma_v\> is defined by + +\begin{haskell} +x:\sigma\in\Gamma \Longleftrightarrow x:\vect{\sigma}\in\Gamma_v +\end{haskell} + +\subsubsection*{Lifting} +\begin{haskell} +\liftn{c:\sigma} & = replicateP \pa{\vect{\sigma}} n c_v \\ +\liftn{x} & = x \\ +\liftn{\Lambda\alpha:\kappa.e} & = +\Lambda\alpha:\kappa.\lambda{dPA_{\alpha}}:\patype{\alpha:\kappa}.\liftn{e} \\ +\liftn{e[\sigma]} & = \liftn{e}[\vect{\sigma}] \pa{\vect{\sigma}} \\ +\liftn{e_1 e_2} & = \liftn{e_1} \cappP \liftn{e_2} \\ +\liftn{\lambda{x}:\sigma.e} & = AClo \vect{\sigma} \vect{\phi} \vect{\tau} + \pa{\vect{\tau}} + (ATup_n y_1 \dots y_n) \\ + & +\quad\quad(\lambda{ys}:\vect{\tau}. + \lambda{x}:\vect{\sigma}. + \hskwd{case} ys \hskwd{of} (y_1,\dots,y_n) \to \vect{e}) \\ + & +\quad\quad(\lambda{ys}:\parr{\vect{\tau}}. + \lambda{x}:\parr{\vect{\sigma}}. + \hskwd{case} ys \hskwd{of} ATup_n l y_1 \dots y_n \to \lift{e}{l}) + \hswhere{e has type \phi \\ + \{y_1:\tau_1,\dots,y_n:\tau_n\} & = FVS(e)\setminus{x} \\ + \tau & = (\tau_1,\dots,\tau_n)} +\end{haskell} + +Lifting maintains the following invariant: + +\begin{haskell} +\Delta,\Gamma\vdash{e}:\sigma \Longrightarrow + \Delta,\Gamma^\uparrow\vdash\liftn{e} : \parr{\sigma_v} +\end{haskell} + +where + +\begin{haskell} +x:\sigma\in\Gamma \Longleftrightarrow x:\parr{\vect{\sigma}}\in\Gamma^\uparrow +\end{haskell} + +Note that this is precisely the reason for the \<\parr{\cdot}\> instances for +\<\alpha\to\beta\> and \. A term of type \<\forall\alpha.\sigma\> +will be lifted to a term of type +\<\parr{\forall\alpha.PA \alpha\to\vect{\sigma}}\> which requires the +instances. Apart from closures, these are the only occurrences of \<({\to})\> in +the transformed program, however. + + +\section*{What to vectorise?} + +An expression is vectorisable if it only mentions globals and type constructors +which have a vectorised form. When vectorising, we look for maximal +vectorisable subexpressions and transform those. For instance, assuming that +\ hasn't been vectorised, in + +\begin{haskell} +main = \hsdo{ + print (sumP \pparr{\ldots}) \\ + print (mapP \ldots \pparr{\ldots})} +\end{haskell} + +we would vectorise the arguments to \. Note that this implies that we +never call non-vectorised code from vectorised code (is that a problem?). + +Whenever we come out of a vectorised ``bubble'', we have to convert between +vectorised and unvectorised data types. The examples above would roughly +translate to + +\begin{haskell} +main = \hsdo{ + print (unvect (sumP_v \parr{\ldots})) \\ + print (unvect (mapP_v \ldots \parr{\ldots}))} +\end{haskell} + +For this, we have to have the following functions: + +\begin{haskell} +vect_\sigma & :: \sigma\to\vect{\sigma} \\ +unvect_\sigma & :: \vect{\sigma}\to\sigma +\end{haskell} + +It is sufficient to have these functions only for a restricted set of types as +we can always vectorise less if the conversions becomes too complex. + +Sometimes, it doesn't make sense to vectorise things. For instance, in + +\begin{haskell} +foo f xs = print (f xs) +\end{haskell} + +we wouldn't vectorise \. Unfortunately, this means that +\ will be purely sequential. + +For each expression, the vectoriser gives one of the following answers. + +\begin{tabular}{lp{10cm}} +\textbf{Yes} & +the expression can be (and has been) vectorised \\ +\textbf{Maybe} & +the expression can be vectorised but it doesn't make sense to do so +unless it is used in a vectrorisable context (e.g., for \ in \) +\\ +\textbf{No} & +the expression can't be vectorised (although parts of it can, so we +still get back a transformed expression) +\end{tabular} + +\subsection*{Top-level definitions} + +For a top-level definition of the form + +\begin{haskell} +f :: \sigma = e +\end{haskell} + +vectorisation proceeds as follows. + +\begin{itemize} +\item If \ can be fully vectorised, we generate +\begin{haskell} +f_v :: \vect{\sigma} = \vect{e} +\end{haskell} + +\item If it doesn't always make sense to vectorise \, i.e., the vectoriser +returned \textbf{Maybe}, we leave the definition of \ unchanged. Thus, we +would not change +\begin{haskell} +({\$}) = \lambda{f}.\lambda{x}.f x +\end{haskell} +but would additionaly generate +\begin{haskell} +({\$}_v) = Clo \ldots +\end{haskell} + +\item Otherwise (if the vectoriser said \textbf{Yes}) and we have +\, we change the definition of \ to +\begin{haskell} +f :: \sigma = unconv_\sigma f_v +\end{haskell} + +\item Otherwise (the vectoriser said \textbf{Yes} but we do not have +\ or if \ couldn't be fully vectorised), we change the +definition of \ to +\begin{haskell} +f :: \sigma = e' +\end{haskell} +where \ is obtaining by vectorising \ as much as possible without +changing its type. For instance, for +\begin{haskell} +f = \lambda{g}.\lambda{x}.mapP (\ldots) (g x) +\end{haskell} +we would generate +\begin{haskell} +f & = \lambda{g}.\lambda{x}.unvect (mapP_v (\ldots) (vect (g x))) \\ +f_v & = Clo \ldots +\end{haskell} +assuming we have the necessary conversions but cannot convert functions (i.e., +\). +\end{itemize} + +\end{document} + diff --git a/docs/rts/closure.ps b/docs/rts/closure.ps new file mode 100644 index 00000000..241bf9b4 --- /dev/null +++ b/docs/rts/closure.ps @@ -0,0 +1,129 @@ +%! +%%Title: closure.fig +%%Creator: fig2dev +%%CreationDate: Wed May 28 08:22:23 1997 +%%For: sigbjorn@lassi (Sigbjorn Finne,,,) +%%Pages: 0 +%%BoundingBox: 0 0 259 171 +%%EndComments +/$F2psDict 32 dict def +$F2psDict begin + $F2psDict /mtrx matrix put + + /DrawEllipse { + /endangle exch def + /startangle exch def + /yrad exch def + /xrad exch def + /y exch def + /x exch def + /savematrix mtrx currentmatrix def + x y translate xrad yrad scale 0 0 1 startangle endangle arc + savematrix setmatrix + } def newpath 0 0 0 0 0 1 DrawEllipse stroke + + end + /$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def + /$F2psEnd {$F2psEnteredState restore end} def + %%EndProlog + +$F2psBegin +1 setlinecap 1 setlinejoin +-18 18 translate +0.000000 171.000000 translate 0.900 -0.900 scale +1.000 setlinewidth +% Ellipse +newpath 57 47 3 3 0 360 DrawEllipse gsave 0.000 setgray fill grestore stroke +% Polyline +newpath 57 48 moveto 57 92 lineto 88 92 lineto stroke +newpath 80.000 90.000 moveto 88.000 92.000 lineto 80.000 94.000 lineto stroke +% Polyline +newpath 184 31 moveto 184 57 lineto stroke +% Polyline +newpath 260 31 moveto 298 31 lineto 298 57 lineto 260 57 lineto stroke + [1 3.000000] 0 setdash +% Polyline +newpath 209 31 moveto 260 31 lineto stroke + [] 0 setdash + [1 3.000000] 0 setdash +% Polyline +newpath 209 57 moveto 260 57 lineto stroke + [] 0 setdash +% Polyline +newpath 158 57 moveto 209 57 lineto stroke +% Polyline +newpath 158 31 moveto 209 31 lineto stroke + [1 3.000000] 0 setdash +% Polyline +newpath 107 57 moveto 158 57 lineto stroke + [] 0 setdash + [1 3.000000] 0 setdash +% Polyline +newpath 107 31 moveto 158 31 lineto stroke + [] 0 setdash +% Polyline +newpath 107 31 moveto 31 31 lineto 31 57 lineto 107 57 lineto stroke +% Polyline +newpath 95 31 moveto 95 57 lineto stroke +% Polyline +newpath 19 19 moveto 307 19 lineto 307 209 lineto 19 209 lineto closepath stroke +% Polyline +newpath 91 98 moveto 156 98 lineto stroke +% Polyline +newpath 91 113 moveto 156 113 lineto stroke +% Polyline +newpath 92 129 moveto 156 129 lineto stroke +% Polyline +newpath 124 105 moveto 206 105 lineto stroke +newpath 198.000 103.000 moveto 206.000 105.000 lineto 198.000 107.000 lineto stroke +% Polyline +newpath 91 82 moveto 155 82 lineto 155 147 lineto 91 147 lineto closepath stroke +% Polyline +newpath 124 88 moveto 206 88 lineto stroke +newpath 198.000 86.000 moveto 206.000 88.000 lineto 198.000 90.000 lineto stroke +% Polyline +newpath 282 167 moveto 282 112 lineto 211 112 lineto 211 167 lineto closepath stroke +% Polyline +newpath 125 138 moveto 125 188 lineto 153 188 lineto stroke +newpath 145.000 186.000 moveto 153.000 188.000 lineto 145.000 190.000 lineto stroke +/Times-Roman findfont 8.000 scalefont setfont +107 77 moveto +1 -1 scale +(Info table) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +104 48 moveto +1 -1 scale +(Pointer words) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +209 48 moveto +1 -1 scale +(Non-pointer words) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +37 41 moveto +1 -1 scale +(Info pointer) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +99 124 moveto +1 -1 scale +(Constructor tag) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +215 154 moveto +1 -1 scale +(Size and shape info) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +232 163 moveto +1 -1 scale +(for GC) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +156 191 moveto +1 -1 scale +(Update code) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +213 108 moveto +1 -1 scale +(Representation table) gsave 0.000 rotate show grestore 1 -1 scale +/Times-Roman findfont 8.000 scalefont setfont +213 91 moveto +1 -1 scale +(Entry code) gsave 0.000 rotate show grestore 1 -1 scale +$F2psEnd diff --git a/docs/rts/closure.tex b/docs/rts/closure.tex new file mode 100644 index 00000000..572a8516 --- /dev/null +++ b/docs/rts/closure.tex @@ -0,0 +1,7 @@ +\makebox[3.597in][l]{ + \vbox to 2.375in{ + \vfill + \special{psfile=closure.ps} + } + \vspace{-\baselineskip} +} diff --git a/docs/rts/hugs_ret.pstex b/docs/rts/hugs_ret.pstex new file mode 100644 index 00000000..9a7ed984 --- /dev/null +++ b/docs/rts/hugs_ret.pstex @@ -0,0 +1,145 @@ +%!PS-Adobe-2.0 EPSF-2.0 +%%Title: /tmp/xfig-fig007314 +%%Creator: fig2dev Version 3.1 Patchlevel 2 +%%CreationDate: Wed Oct 15 13:06:42 1997 +%%For: simonm@solander.dcs.gla.ac.uk (Simon Marlow,SM,,,,OCT99, ) +%%Orientation: Portrait +%%BoundingBox: 0 0 204 214 +%%Pages: 0 +%%BeginSetup +%%IncludeFeature: *PageSize Letter +%%EndSetup +%Magnification: 0.80 +%%EndComments +/$F2psDict 200 dict def +$F2psDict begin +$F2psDict /mtrx matrix put +/col-1 {0 setgray} bind def +/col0 {0.000 0.000 0.000 srgb} bind def +/col1 {0.000 0.000 1.000 srgb} bind def +/col2 {0.000 1.000 0.000 srgb} bind def +/col3 {0.000 1.000 1.000 srgb} bind def +/col4 {1.000 0.000 0.000 srgb} bind def +/col5 {1.000 0.000 1.000 srgb} bind def +/col6 {1.000 1.000 0.000 srgb} bind def +/col7 {1.000 1.000 1.000 srgb} bind def +/col8 {0.000 0.000 0.560 srgb} bind def +/col9 {0.000 0.000 0.690 srgb} bind def +/col10 {0.000 0.000 0.820 srgb} bind def +/col11 {0.530 0.810 1.000 srgb} bind def +/col12 {0.000 0.560 0.000 srgb} bind def +/col13 {0.000 0.690 0.000 srgb} bind def +/col14 {0.000 0.820 0.000 srgb} bind def +/col15 {0.000 0.560 0.560 srgb} bind def +/col16 {0.000 0.690 0.690 srgb} bind def +/col17 {0.000 0.820 0.820 srgb} bind def +/col18 {0.560 0.000 0.000 srgb} bind def +/col19 {0.690 0.000 0.000 srgb} bind def +/col20 {0.820 0.000 0.000 srgb} bind def +/col21 {0.560 0.000 0.560 srgb} bind def +/col22 {0.690 0.000 0.690 srgb} bind def +/col23 {0.820 0.000 0.820 srgb} bind def +/col24 {0.500 0.190 0.000 srgb} bind def +/col25 {0.630 0.250 0.000 srgb} bind def +/col26 {0.750 0.380 0.000 srgb} bind def +/col27 {1.000 0.500 0.500 srgb} bind def +/col28 {1.000 0.630 0.630 srgb} bind def +/col29 {1.000 0.750 0.750 srgb} bind def +/col30 {1.000 0.880 0.880 srgb} bind def +/col31 {1.000 0.840 0.000 srgb} bind def + +end +save +-42.0 271.0 translate +1 -1 scale + +/cp {closepath} bind def +/ef {eofill} bind def +/gr {grestore} bind def +/gs {gsave} bind def +/sa {save} bind def +/rs {restore} bind def +/l {lineto} bind def +/m {moveto} bind def +/rm {rmoveto} bind def +/n {newpath} bind def +/s {stroke} bind def +/sh {show} bind def +/slc {setlinecap} bind def +/slj {setlinejoin} bind def +/slw {setlinewidth} bind def +/srgb {setrgbcolor} bind def +/rot {rotate} bind def +/sc {scale} bind def +/sd {setdash} bind def +/ff {findfont} bind def +/sf {setfont} bind def +/scf {scalefont} bind def +/sw {stringwidth} bind def +/tr {translate} bind def +/tnt {dup dup currentrgbcolor + 4 -2 roll dup 1 exch sub 3 -1 roll mul add + 4 -2 roll dup 1 exch sub 3 -1 roll mul add + 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb} + bind def +/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul + 4 -2 roll mul srgb} bind def +/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def +/$F2psEnd {$F2psEnteredState restore end} def +%%EndProlog + +$F2psBegin +10 setmiterlimit +n 0 792 m 0 0 l 612 0 l 612 792 l cp clip + 0.04800 0.04800 sc +/Helvetica ff 180.00 scf sf +3405 3885 m +gs 1 -1 sc (Info) col-1 sh gr +7.500 slw +% Polyline +n 900 3000 m 2100 3000 l gs col-1 s gr +% Polyline +n 900 2700 m 2100 2700 l gs col-1 s gr +% Polyline +gs clippath +3003 4545 m 3123 4575 l 3003 4605 l 3165 4605 l 3165 4545 l cp clip +n 1425 3150 m 2550 3150 l 2550 4575 l 3150 4575 l gs col-1 s gr gr + +% arrowhead +n 3003 4545 m 3123 4575 l 3003 4605 l col-1 s +% Polyline + [15 50.0] 50.0 sd +n 3150 4575 m 3150 5625 l gs col-1 s gr [] 0 sd +% Polyline +n 3150 4575 m 3975 4575 l 3975 3600 l 3150 3600 l cp gs col-1 s gr +% Polyline + [15 50.0] 50.0 sd +n 3975 4575 m 3975 5625 l gs col-1 s gr [] 0 sd +% Polyline +gs clippath +3003 2820 m 3123 2850 l 3003 2880 l 3165 2880 l 3165 2820 l cp clip +n 1425 2850 m 3150 2850 l gs col-1 s gr gr + +% arrowhead +n 3003 2820 m 3123 2850 l 3003 2880 l col-1 s +% Polyline +n 3150 2700 m 4500 2700 l 4500 3075 l 3150 3075 l cp gs col-1 s gr +/Helvetica ff 180.00 scf sf +3585 2955 m +gs 1 -1 sc (BCO) col-1 sh gr +/Helvetica ff 180.00 scf sf +1170 1530 m +gs 1 -1 sc (Stack) col-1 sh gr +/Helvetica ff 180.00 scf sf +3300 4125 m +gs 1 -1 sc (Table) col-1 sh gr +/Helvetica ff 180.00 scf sf +3315 5070 m +gs 1 -1 sc (Code) col-1 sh gr +/Helvetica ff 180.00 scf sf +4140 4650 m +gs 1 -1 sc (HUGS_RET) col-1 sh gr +% Polyline +n 900 1200 m 900 3300 l 2100 3300 l 2100 1200 l gs col-1 s gr +$F2psEnd +rs diff --git a/docs/rts/hugs_ret.pstex_t b/docs/rts/hugs_ret.pstex_t new file mode 100644 index 00000000..3b844da3 --- /dev/null +++ b/docs/rts/hugs_ret.pstex_t @@ -0,0 +1,13 @@ +\begin{picture}(0,0)% +\epsfig{file=hugs_ret.pstex}% +\end{picture}% +\setlength{\unitlength}{0.00066700in}% +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +\begin{picture}(3624,4449)(889,-4798) +\end{picture} diff --git a/docs/rts/hugs_ret2.pstex b/docs/rts/hugs_ret2.pstex new file mode 100644 index 00000000..74d081c4 --- /dev/null +++ b/docs/rts/hugs_ret2.pstex @@ -0,0 +1,130 @@ +%!PS-Adobe-2.0 EPSF-2.0 +%%Title: /tmp/xfig-fig007314 +%%Creator: fig2dev Version 3.1 Patchlevel 2 +%%CreationDate: Wed Oct 15 13:18:31 1997 +%%For: simonm@solander.dcs.gla.ac.uk (Simon Marlow,SM,,,,OCT99, ) +%%Orientation: Portrait +%%BoundingBox: 0 0 185 139 +%%Pages: 0 +%%BeginSetup +%%IncludeFeature: *PageSize Letter +%%EndSetup +%Magnification: 0.80 +%%EndComments +/$F2psDict 200 dict def +$F2psDict begin +$F2psDict /mtrx matrix put +/col-1 {0 setgray} bind def +/col0 {0.000 0.000 0.000 srgb} bind def +/col1 {0.000 0.000 1.000 srgb} bind def +/col2 {0.000 1.000 0.000 srgb} bind def +/col3 {0.000 1.000 1.000 srgb} bind def +/col4 {1.000 0.000 0.000 srgb} bind def +/col5 {1.000 0.000 1.000 srgb} bind def +/col6 {1.000 1.000 0.000 srgb} bind def +/col7 {1.000 1.000 1.000 srgb} bind def +/col8 {0.000 0.000 0.560 srgb} bind def +/col9 {0.000 0.000 0.690 srgb} bind def +/col10 {0.000 0.000 0.820 srgb} bind def +/col11 {0.530 0.810 1.000 srgb} bind def +/col12 {0.000 0.560 0.000 srgb} bind def +/col13 {0.000 0.690 0.000 srgb} bind def +/col14 {0.000 0.820 0.000 srgb} bind def +/col15 {0.000 0.560 0.560 srgb} bind def +/col16 {0.000 0.690 0.690 srgb} bind def +/col17 {0.000 0.820 0.820 srgb} bind def +/col18 {0.560 0.000 0.000 srgb} bind def +/col19 {0.690 0.000 0.000 srgb} bind def +/col20 {0.820 0.000 0.000 srgb} bind def +/col21 {0.560 0.000 0.560 srgb} bind def +/col22 {0.690 0.000 0.690 srgb} bind def +/col23 {0.820 0.000 0.820 srgb} bind def +/col24 {0.500 0.190 0.000 srgb} bind def +/col25 {0.630 0.250 0.000 srgb} bind def +/col26 {0.750 0.380 0.000 srgb} bind def +/col27 {1.000 0.500 0.500 srgb} bind def +/col28 {1.000 0.630 0.630 srgb} bind def +/col29 {1.000 0.750 0.750 srgb} bind def +/col30 {1.000 0.880 0.880 srgb} bind def +/col31 {1.000 0.840 0.000 srgb} bind def + +end +save +-28.0 181.0 translate +1 -1 scale + +/cp {closepath} bind def +/ef {eofill} bind def +/gr {grestore} bind def +/gs {gsave} bind def +/sa {save} bind def +/rs {restore} bind def +/l {lineto} bind def +/m {moveto} bind def +/rm {rmoveto} bind def +/n {newpath} bind def +/s {stroke} bind def +/sh {show} bind def +/slc {setlinecap} bind def +/slj {setlinejoin} bind def +/slw {setlinewidth} bind def +/srgb {setrgbcolor} bind def +/rot {rotate} bind def +/sc {scale} bind def +/sd {setdash} bind def +/ff {findfont} bind def +/sf {setfont} bind def +/scf {scalefont} bind def +/sw {stringwidth} bind def +/tr {translate} bind def +/tnt {dup dup currentrgbcolor + 4 -2 roll dup 1 exch sub 3 -1 roll mul add + 4 -2 roll dup 1 exch sub 3 -1 roll mul add + 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb} + bind def +/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul + 4 -2 roll mul srgb} bind def +/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def +/$F2psEnd {$F2psEnteredState restore end} def +%%EndProlog + +$F2psBegin +10 setmiterlimit +n 0 792 m 0 0 l 612 0 l 612 792 l cp clip + 0.04800 0.04800 sc +/Helvetica ff 180.00 scf sf +975 1350 m +gs 1 -1 sc (Stack) col-1 sh gr +7.500 slw +% Polyline +n 600 3000 m 1800 3000 l gs col-1 s gr +% Polyline +n 600 2700 m 1800 2700 l gs col-1 s gr +% Polyline +gs clippath +2928 3495 m 3048 3525 l 2928 3555 l 3090 3555 l 3090 3495 l cp clip +n 1200 3150 m 2400 3150 l 2400 3525 l 3075 3525 l gs col-1 s gr gr + +% arrowhead +n 2928 3495 m 3048 3525 l 2928 3555 l col-1 s +% Polyline +gs clippath +2928 2820 m 3048 2850 l 2928 2880 l 3090 2880 l 3090 2820 l cp clip +n 1200 2850 m 3075 2850 l gs col-1 s gr gr + +% arrowhead +n 2928 2820 m 3048 2850 l 2928 2880 l col-1 s +% Polyline +n 3075 2700 m 4425 2700 l 4425 3075 l 3075 3075 l cp gs col-1 s gr +% Polyline +n 3075 3375 m 4425 3375 l 4425 3750 l 3075 3750 l cp gs col-1 s gr +/Helvetica ff 180.00 scf sf +3555 2955 m +gs 1 -1 sc (BCO) col-1 sh gr +/Helvetica ff 180.00 scf sf +3195 3630 m +gs 1 -1 sc (Return Value) col-1 sh gr +% Polyline +n 600 900 m 600 3300 l 1800 3300 l 1800 900 l gs col-1 s gr +$F2psEnd +rs diff --git a/docs/rts/hugs_ret2.pstex_t b/docs/rts/hugs_ret2.pstex_t new file mode 100644 index 00000000..13208a3d --- /dev/null +++ b/docs/rts/hugs_ret2.pstex_t @@ -0,0 +1,13 @@ +\begin{picture}(0,0)% +\epsfig{file=hugs_ret2.pstex}% +\end{picture}% +\setlength{\unitlength}{0.00066700in}% +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +\begin{picture}(3849,2874)(589,-2923) +\end{picture} diff --git a/docs/rts/rts.tex b/docs/rts/rts.tex new file mode 100644 index 00000000..158ae7e7 --- /dev/null +++ b/docs/rts/rts.tex @@ -0,0 +1,4683 @@ +% +% (c) The OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE Project, +% Glasgow University, 1990-1994 +% + +% TODO: +% +% o I (ADR) think it would be worth making the connection with CPS explicit. +% Now that we have explicit activation records (on the stack), we can +% explain the whole system in terms of CPS and tail calls --- with the +% one requirement that we carefuly distinguish stack-allocated objects +% from heap-allocated objects. + +% \documentstyle[preprint]{acmconf} +\documentclass[11pt]{article} +\oddsidemargin 0.1 in % Note that \oddsidemargin = \evensidemargin +\evensidemargin 0.1 in +\marginparwidth 0.85in % Narrow margins require narrower marginal notes +\marginparsep 0 in +\sloppy + +%\usepackage{epsfig} +\usepackage{shortvrb} +\MakeShortVerb{\@} + +%\newcommand{\note}[1]{{\em Note: #1}} +\newcommand{\note}[1]{{{\bf Note:}\sl #1}} +\newcommand{\ToDo}[1]{{{\bf ToDo:}\sl #1}} +\newcommand{\Arg}[1]{\mbox{${\tt arg}_{#1}$}} +\newcommand{\bottom}{\perp} + +\newcommand{\secref}[1]{Section~\ref{sec:#1}} +\newcommand{\figref}[1]{Figure~\ref{fig:#1}} +\newcommand{\Section}[2]{\section{#1}\label{sec:#2}} +\newcommand{\Subsection}[2]{\subsection{#1}\label{sec:#2}} +\newcommand{\Subsubsection}[2]{\subsubsection{#1}\label{sec:#2}} + +% DIMENSION OF TEXT: +\textheight 8.5 in +\textwidth 6.25 in + +\topmargin 0 in +\headheight 0 in +\headsep .25 in + + +\setlength{\parskip}{0.15cm} +\setlength{\parsep}{0.15cm} +\setlength{\topsep}{0cm} % Reduces space before and after verbatim, + % which is implemented using trivlist +\setlength{\parindent}{0cm} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + +\begin{document} + +\title{The STG runtime system (revised)} +\author{Simon Peyton Jones \\ Microsoft Research Ltd., Cambridge \and +Simon Marlow \\ Microsoft Research Ltd., Cambridge \and +Alastair Reid \\ Yale University} + +\maketitle + +\tableofcontents +\newpage + +\part{Introduction} +\Section{Overview}{overview} + +This document describes the GHC/Hugs run-time system. It serves as +a Glasgow/Yale/Nottingham ``contract'' about what the RTS does. + +\Subsection{New features compared to GHC 3.xx}{new-features} + +\begin{itemize} +\item The RTS supports mixed compiled/interpreted execution, so +that a program can consist of a mixture of GHC-compiled and Hugs-interpreted +code. + +\item The RTS supports concurrency by default. +This has some costs (eg we can't do hardware stack checks) but +reduces the number of different configurations we need to support. + +\item CAFs are only retained if they are +reachable. Since they are referred to by implicit references buried +in code, this means that the garbage collector must traverse the whole +accessible code tree. This feature eliminates a whole class of painful +space leaks. + +\item A running thread has only one stack, which contains a mixture of +pointers and non-pointers. \secref{TSO} describes how we find out +which is which. (GHC has used two stacks for some while. Using one +stack instead of two reduces register pressure, reduces the size of +update frames, and eliminates ``stack-stubbing'' instructions.) + +\item The ``return in registers'' return convention has been dropped +because it was complicated and doesn't work well on register-poor +architectures. It has been partly replaced by unboxed tuples +(\secref{unboxed-tuples}) which allow the programmer to +explicitly state where results should be returned in registers (or on +the stack) instead of on the heap. + +\item Exceptions are supported by the RTS. + +\item Weak Pointers generalise the previously available Foreign Object +interface. + +\item The garbage collector supports a number of new features, +including a dynamically resizable heap and multiple generations with +aging within a generation. + +\end{itemize} + +\Subsection{Wish list}{wish-list} + +Here's a list of things we'd like to support in the future. +\begin{itemize} +\item Interrupts, speculative computation. + +\item +The SM could tune the size of the allocation arena, the number of +generations, etc taking into account residency, GC rate and page fault +rate. + +\item +We could trigger a GC when all threads are blocked waiting for IO if +the allocation arena (or some of the generations) are nearly full. + +\end{itemize} + +\Subsection{Configuration}{configuration} + +Some of the above features are expensive or less portable, so we +envision building a number of different configurations supporting +different subsets of the above features. + +You can make the following choices: +\begin{itemize} +\item +Support for parallelism. There are three mutually-exclusive choices. + +\begin{description} +\item[@SEQUENTIAL@] Support for concurrency but not for parallelism. +\item[@GRANSIM@] Concurrency support and simulated parallelism. +\item[@PARALLEL@] Concurrency support and real parallelism. +\end{description} + +\item @PROFILING@ adds cost-centre profiling. + +\item @TICKY@ gathers internal statistics (often known as ``ticky-ticky'' code). + +\item @DEBUG@ does internal consistency checks. + +\item Persistence. (well, not yet). + +\item +Which garbage collector to use. At the moment we +only anticipate one, however. +\end{itemize} + +\Subsection{Glossary}{glossary} + +\ToDo{This terminology is not used consistently within the document. +If you find something which disagrees with this terminology, fix the +usage.} + +In the type system, we have boxed and unboxed types. + +\begin{itemize} + +\item A \emph{pointed} type is one that contains $\bot$. Variables with +pointed types are the only things which can be lazily evaluated. In +the STG machine, this means that they are the only things that can be +\emph{entered} or \emph{updated} and it requires that they be boxed. + +\item An \emph{unpointed} type is one that does not contain $\bot$. +Variables with unpointed types are never delayed --- they are always +evaluated when they are constructed. In the STG machine, this means +that they cannot be \emph{entered} or \emph{updated}. Unpointed objects +may be boxed (like @Array#@) or unboxed (like @Int#@). + +\end{itemize} + +In the implementation, we have different kinds of objects: + +\begin{itemize} + +\item \emph{boxed} objects are heap objects used by the evaluators + +\item \emph{unboxed} objects are not heap allocated + +\item \emph{stack} objects are allocated on the stack + +\item \emph{closures} are objects which can be \emph{entered}. +They are always boxed and always have boxed types. +They may be in WHNF or they may be unevaluated. + +\item A \emph{thunk} is a (representation of) a value of a \emph{pointed} +type which is \emph{not} in WHNF. + +\item A \emph{value} is an object in WHNF. It can be pointed or unpointed. + +\end{itemize} + + + +At the hardware level, we have \emph{word}s and \emph{pointer}s. + +\begin{itemize} + +\item A \emph{word} is (at least) 32 bits and can hold either a signed +or an unsigned int. + +\item A \emph{pointer} is (at least) 32 bits and big enough to hold a +function pointer or a data pointer. + +\end{itemize} + +Occasionally, a field of a data structure must hold either a word or a +pointer. In such circumstances, it is \emph{not safe} to assume that +words and pointers are the same size. \ToDo{GHC currently makes words +the same size as pointers to reduce complexity in the code +generator/RTS. It would be useful to relax this restriction, and have +eg. 32-bit Ints on a 64-bit machine.} + +% should define terms like SRT, CAF, PAP, etc. here? --KSW 1999-03 + +\subsection{Subtle Dependencies} + +Some decisions have very subtle consequences which should be written +down in case we want to change our minds. + +\begin{itemize} + +\item + +If the garbage collector is allowed to shrink the stack of a thread, +we cannot omit the stack check in return continuations +(\secref{heap-and-stack-checks}). + +\item + +When we return to the scheduler, the top object on the stack is a closure. +The scheduler restarts the thread by entering the closure. + +\secref{hugs-return-convention} discusses how Hugs returns an +unboxed value to GHC and how GHC returns an unboxed value to Hugs. + +\item + +When we return to the scheduler, we need a few empty words on the stack +to store a closure to reenter. \secref{heap-and-stack-checks} +discusses who does the stack check and how much space they need. + +\item + +Heap objects never contain slop --- this is required if we want to +support mostly-copying garbage collection. + +This is a big problem when updating since the updatee is usually +bigger than an indirection object. The fix is to overwrite the end of +the updatee with ``slop objects'' (described in +\secref{slop-objects}). This is hard to arrange if we do +\emph{lazy} blackholing (\secref{lazy-black-holing}) so we +currently plan to blackhole an object when we push the update frame. + +% Idea: have specialised update code for various common sizes of +% updatee, the update frame hence encodes the length of the object. +% Specialised indirections will also encode the length of the object. A +% generic version of the update code will overwrite the slop with a slop +% object. We can do the same thing for blackhole objects, or just have +% a generic version that is the same size as an indirection and +% overwrite the slop with a slop object when blackholing. So: does this +% avoid the need to do eager black holing? + +\item + +Info tables for constructors contain enough information to decide which +return convention they use. This allows Hugs to use a single piece of +entry code for all constructors and insulates Hugs from changes in the +choice of return convention. + +\end{itemize} + +\Section{Source Language}{source-language} + +\Subsection{Explicit Allocation}{explicit-allocation} + +As in the original STG machine, (almost) all heap allocation is caused +by executing a let(rec). Since we no longer support the return in +registers convention for data constructors, constructors now cause heap +allocation and so they should be let-bound. + +For example, we now write +\begin{verbatim} +> cons = \ x xs -> let r = (:) x xs in r +@ +instead of +\begin{verbatim} +> cons = \ x xs -> (:) x xs +\end{verbatim} + +\note{For historical reasons, GHC doesn't use this syntax --- but it should.} + +\Subsection{Unboxed tuples}{unboxed-tuples} + +Functions can take multiple arguments as easily as they can take one +argument: there's no cost for adding another argument. But functions +can only return one result: the cost of adding a second ``result'' is +that the function must construct a tuple of ``results'' on the heap. +The assymetry is rather galling and can make certain programming +styles quite expensive. For example, consider a simple state transformer +monad: +\begin{verbatim} +> type S a = State -> (a,State) +> bindS m k s0 = case m s0 of { (a,s1) -> k a s1 } +> returnS a s = (a,s) +> getS s = (s,s) +> setS s _ = ((),s) +\end{verbatim} +Here, every use of @returnS@, @getS@ or @setS@ constructs a new tuple +in the heap which is instantly taken apart (and becomes garbage) by +the case analysis in @bind@. Even a short state-transformer program +will construct a lot of these temporary tuples. + +Unboxed tuples provide a way for the programmer to indicate that they +do not expect a tuple to be shared and that they do not expect it to +be allocated in the heap. Syntactically, unboxed tuples are just like +single constructor datatypes except for the annotation @unboxed@. +\begin{verbatim} +> data unboxed AAndState# a = AnS a State +> type S a = State -> AAndState# a +> bindS m k s0 = case m s0 of { AnS a s1 -> k a s1 } +> returnS a s = AnS a s +> getS s = AnS s s +> setS s _ = AnS () s +\end{verbatim} +Semantically, unboxed tuples are just unlifted tuples and are subject +to the same restrictions as other unpointed types. + +Operationally, unboxed tuples are never built on the heap. When +an unboxed tuple is returned, it is returned in multiple registers +or multiple stack slots. At first sight, this seems a little strange +but it's no different from passing double precision floats in two +registers. + +Notes: +\begin{itemize} +\item +Unboxed tuples can only have one constructor and that +thunks never have unboxed types --- so we'll never try to update an +unboxed constructor. The restriction to a single constructor is +largely to avoid garbage collection complications. + +\item +The core syntax does not allow variables to be bound to +unboxed tuples (ie in default case alternatives or as function arguments) +and does not allow unboxed tuples to be fields of other constructors. +However, there's no harm in allowing it in the source syntax as a +convenient, but easily removed, syntactic sugar. + +\item +The compiler generates a closure of the form +\begin{verbatim} +> c = \ x y z -> C x y z +\end{verbatim} +for every constructor (whether boxed or unboxed). + +This closure is normally used during desugaring to ensure that +constructors are saturated and to apply any strictness annotations. +They are also used when returning unboxed constructors to the machine +code evaluator from the bytecode evaluator and when a heap check fails +in a return continuation for an unboxed-tuple scrutinee. + +\end{itemize} + +\Subsection{STG Syntax}{stg-syntax} + + +\ToDo{Insert STG syntax with appropriate changes.} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\part{System Overview} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +This part is concerned with defining the external interfaces of the +major components of the system; the next part is concerned with their +inner workings. + +The major components of the system are: +\begin{itemize} + +\item + +The evaluators (\secref{sm-overview}) are responsible for +evaluating heap objects. The system supports two evaluators: the +machine code evaluator; and the bytecode evaluator. + +\item + +The scheduler (\secref{scheduler-overview}) acts as the +coordinator for the whole system. It is responsible for switching +between evaluators, switching between threads, garbage collection, +communication between multiple processors, etc. + +\item + +The storage manager (\secref{evaluators-overview}) is +responsible for allocating blocks of contiguous memory and for garbage +collection. + +\item + +The loader (\secref{loader-overview}) is responsible for +loading machine code and bytecode files from the file system and for +resolving references between separately compiled modules. + +\item + +The compilers (\secref{compilers-overview}) generate machine +code and bytecode files which can be loaded by the loader. + +\end{itemize} + +\ToDo{Insert diagram showing all components underneath the scheduler +and communicating only with the scheduler} + + +\Section{The Evaluators}{evaluators-overview} + +There are two evaluators: a machine code evaluator and a bytecode +evaluator. The evaluators task is to evaluate code within a thread +until one of the following happens: + +\begin{itemize} +\item heap overflow +\item stack overflow +\item it is preempted +\item it blocks in one of the concurrency primitives +\item it performs a safe ccall +\item it needs to switch to the other evaluator. +\end{itemize} + +The evaluators expect to find a closure on top of the thread's stack +and terminate with a closure on top of the thread's stack. + +\Subsection{Evaluation Model}{evaluation-model} + +Whilst the evaluators differ internally, they share a common +evaluation model and many object representations. + +\Subsubsection{Heap objects}{heap-objects-overview} + +The choice of heap and stack objects used by the evaluators is tightly +bound to the evaluation model. This section provides an overview of +the most important heap and stack objects; further details are given +later. + +All heap objects look like this: + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Header} & \emph{Payload} \\ \hline +\end{tabular} +\end{center} + +The headers vary between different kinds of object but they all start +with a pointer to a pair consisting of an \emph{info table} and some +\emph{entry code}. The info table is used both by the evaluators and +by the storage manager and contains a @type@ field which identifies +which kind of heap object uses it and determines the interpretation of +the payload and of the other fields of the info table. The entry code +is some machine code used by the machine code evaluator to evaluate +closures and raises an error for other kinds of objects. + +The major kinds of heap object used are as follows. (For simplicity, +this description omits certain optimisations and extra fields required +by the garbage collector.) + +\begin{description} + +\item[Constructors] are used to represent data constructors. Their +payload consists of the fields of the constructor; the tag of the +constructor is stored in the info table. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@CONSTR@ & \emph{Fields} \\ \hline +\end{tabular} +\end{center} + +\item[Primitive objects] are used to represent objects with unlifted +types which are too large to fit in a register (or stack slot) or for +which sharing must be preserved. Primitive objects include large +objects such as multiple precision integers and immutable arrays and +mutable objects such as mutable arrays, mutable variables, MVar's, +IVar's and foreign object pointers. Since primitive objects are not +lifted, they cannot be entered. Their payload varies according to the +kind of object. + +\item[Function closures] are used to represent functions. Their +payload (if any) consists of the free variables of the function. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@FUN@ & \emph{Free Variables} \\ \hline +\end{tabular} +\end{center} + +Function closures are only generated by the machine code compiler. + +\item[Thunks] are used to represent unevaluated expressions which will +be updated with their result. Their payload (if any) consists of the +free variables of the function. The entry code for a thunk starts by +pushing an \emph{update frame} onto the stack. When evaluation of the +thunk completes, the update frame will cause the thunk to be +overwritten again with an \emph{indirection} to the result of the +thunk, which is always a constructor or a partial application. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@THUNK@ & \emph{Free Variables} \\ \hline +\end{tabular} +\end{center} + +Thunks are only generated by the machine code evaluator. + +\item[Byte-code Objects (@BCO@s)] are generated by the bytecode +compiler. In conjunction with \emph{updatable applications} and +\emph{non-updatable applications} they are used to represent +functions, unevaluated expressions and return addresses. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@BCO@ & \emph{Constant Pool} & \emph{Bytecodes} \\ \hline +\end{tabular} +\end{center} + +\item[Non-updatable (Partial) Applications] are used to represent the +application of a function to an insufficient number of arguments. +Their payload consists of the function and the arguments received so far. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@PAP@ & \emph{Function Closure} & \emph{Arguments} \\ \hline +\end{tabular} +\end{center} + +@PAP@s are used when a function is applied to too few arguments and by +code generated by the lambda-lifting phase of the bytecode compiler. + +\item[Updatable Applications] are used to represent the application of +a function to a sufficient number of arguments. Their payload +consists of the function and its arguments. + +Updateable applications are like thunks: on entering an updateable +application, the evaluators push an \emph{update frame} onto the stack +and overwrite the application with a \emph{black hole}; when +evaluation completes, the evaluators overwrite the application with an +\emph{indirection} to the result of the application. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@AP@ & \emph{Function Closure} & \emph{Arguments} \\ \hline +\end{tabular} +\end{center} + +@AP@s are only generated by the bytecode compiler. + +\item[Black holes] are used to mark updateable closures which are +currently being evaluated. ``Black holing'' an object cures a +potential space leak and detects certain classes of infinite loops. +More imporantly, black holes act as synchronisation objects between +separate threads: if a second thread tries to enter an updateable +closure which is already being evaluated, the second thread is added +to a list of blocked threads and the thread is suspended. + +When evaluation of the black-holed closure completes, the black hole +is overwritten with an indirection to the result of the closure and +any blocked threads are restored to the runnable queue. + +Closures are overwritten by black-holes during a ``lazy black-holing'' +phase which runs on each thread when it returns to the scheduler. +\ToDo{section describing lazy black-holing}. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@BLACKHOLE@ & \emph{Blocked threads} \\ \hline +\end{tabular} +\end{center} + +\ToDo{In a single threaded system, it's trivial to detect infinite +loops: reentering a BLACKHOLE is always an error. How easy is it in a +multi-threaded system?} + +\item[Indirections] are used to update an unevaluated closure with its +(usually fully evaluated) result in situations where it isn't possible +to perform an update in place. (In the current system, we always +update with an indirection to avoid duplicating the result when doing +an update in place.) + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@IND@ & \emph{Closure} \\ \hline +\end{tabular} +\end{center} + +Indirections needn't always point to a closure in WHNF. They can +point to a chain of indirections which point to an evaluated closure. + +\item[Thread State Objects (@TSO@s)] represent Haskell threads. Their +payload consists of some per-thread information such as the Thread ID +and the status of the thread (runnable, blocked etc.), and the +thread's stack. See @TSO.h@ for the full story. @TSO@s may be +resized by the scheduler if its stack is too small or too large. + +The thread stack grows downwards from higher to lower addresses. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@TSO@ & \emph{Thread info} & \emph{Stack} \\ \hline +\end{tabular} +\end{center} + +\end{description} + +\Subsubsection{Stack objects}{stack-objects-overview} + +The stack contains a mixture of \emph{pending arguments} and +\emph{stack objects}. + +Pending arguments are arguments to curried functions which have not +yet been incorporated into an activation frame. For example, when +evaluating @let { g x y = x + y; f x = g{x} } in f{3,4}@, the +evaluator pushes both arguments onto the stack and enters @f@. @f@ +only requires one argument so it leaves the second argument as a +\emph{pending argument}. The pending argument remains on the stack +until @f@ calls @g@ which requires two arguments: the argument passed +to it by @f@ and the pending argument which was passed to @f@. + +Unboxed pending arguments are always preceeded by a ``tag'' which says +how large the argument is. This allows the garbage collector to +locate pointers within the stack. + +There are three kinds of stack object: return addresses, update frames +and seq frames. All stack objects look like this + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Header} & \emph{Payload} \\ \hline +\end{tabular} +\end{center} + +As with heap objects, the header starts with a pointer to a pair +consisting of an \emph{info table} and some \emph{entry code}. + +\begin{description} + +\item[Return addresses] are used to cause selection and execution of +case alternatives when a constructor is returned. Return addresses +generated by the machine code compiler look like this: + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@RET_XXX@ & \emph{Free Variables of the case alternatives} \\ \hline +\end{tabular} +\end{center} + +The free variables are a mixture of pointers and non-pointers whose +layout is described by a bitmask in the info table. + +There are several kinds of @RET_XXX@ return address - see +\secref{activation-records} for the details. + +Return addresses generated by the bytecode compiler look like this: +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@BCO_RET@ & \emph{BCO} & \emph{Free Variables of the case alternatives} \\ \hline +\end{tabular} +\end{center} + +There is just one @BCO_RET@ info pointer. We avoid needing different +@BCO_RET@s for each stack layout by tagging unboxed free variables as +though they were pending arguments. + +\item[Update frames] are used to trigger updates. When an update +frame is entered, it overwrites the updatee with an indirection to the +result, restarts any threads blocked on the @BLACKHOLE@ and returns to +the stack object underneath the update frame. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@UPDATE_FRAME@ & \emph{Next Update Frame} & \emph{Updatee} \\ \hline +\end{tabular} +\end{center} + +\item[Seq frames] are used to implement the polymorphic @seq@ +primitive. They are a special kind of update frame, and are linked on +the update frame list. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@SEQ_FRAME@ & \emph{Next Update Frame} \\ \hline +\end{tabular} +\end{center} + +\item[Stop frames] are put on the bottom of each thread's stack, and +act as sentinels for the update frame list (i.e. the last update frame +points to the stop frame). Returning to a stop frame terminates the +thread. Stop frames have no payload: + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +@SEQ_FRAME@ \\ \hline +\end{tabular} +\end{center} + +\end{description} + +\Subsubsection{Case expressions}{case-expr-overview} + +In the STG language, all evaluation is triggered by evaluating a case +expression. When evaluating a case expression @case e of alts@, the +evaluators pushes a return address onto the stack and evaluate the +expression @e@. When @e@ eventually reduces to a constructor, the +return address on the stack is entered. The details of how the +constructor is passed to the return address and how the appropriate +case alternative is selected vary between evaluators. + +Case expressions for unboxed data types are essentially the same: the +case expression pushes a return address onto the stack before +evaluating the scrutinee; when a function returns an unboxed value, it +enters the return address on top of the stack. + + +\Subsubsection{Function applications}{fun-app-overview} + +In the STG language, all function calls are tail calls. The arguments +are pushed onto the stack and the function closure is entered. If any +arguments are unboxed, they must be tagged as unboxed pending +arguments. Entering a closure is just a special case of calling a +function with no arguments. + + +\Subsubsection{Let expressions}{let-expr-overview} + +In the STG language, almost all heap allocation is caused by let +expressions. Filling in the contents of a set of mutually recursive +heap objects is simple enough; the only difficulty is that once the +heap space has been allocated, the thread must not return to the +scheduler until after the objects are filled in. + + +\Subsubsection{Primitive operations}{primop-overview} + +\ToDo{} + +Most primops are simple, some aren't. + + + + + + +\Section{Scheduler}{scheduler-overview} + +The Scheduler is the heart of the run-time system. A running program +consists of a single running thread, and a list of runnable and +blocked threads. A thread is represented by a \emph{Thread Status +Object} (TSO), which contains a few words status information and a +stack. Except for the running thread, all threads have a closure on +top of their stack; the scheduler restarts a thread by entering an +evaluator which performs some reduction and returns to the scheduler. + +\Subsection{The scheduler's main loop}{scheduler-main-loop} + +The scheduler consists of a loop which chooses a runnable thread and +invokes one of the evaluators which performs some reduction and +returns. + +The scheduler also takes care of system-wide issues such as heap +overflow or communication with other processors (in the parallel +system) and thread-specific problems such as stack overflow. + +\Subsection{Creating a thread}{create-thread} + +Threads are created: + +\begin{itemize} + +\item + +When the scheduler is first invoked. + +\item + +When a message is received from another processor (I think). (Parallel +system only.) + +\item + +When a C program calls some Haskell code. + +\item + +By @forkIO@, @takeMVar@ and (maybe) other Concurrent Haskell primitives. + +\end{itemize} + + +\Subsection{Restarting a thread}{thread-restart} + +When the scheduler decides to run a thread, it has to decide which +evaluator to use. It does this by looking at the type of the closure +on top of the stack. +\begin{itemize} +\item @BCO@ $\Rightarrow$ bytecode evaluator +\item @FUN@ or @THUNK@ $\Rightarrow$ machine code evaluator +\item @CONSTR@ $\Rightarrow$ machine code evaluator +\item other $\Rightarrow$ either evaluator. +\end{itemize} + +The only surprise in the above is that the scheduler must enter the +machine code evaluator if there's a constructor on top of the stack. +This allows the bytecode evaluator to return a constructor to a +machine code return address by pushing the constructor on top of the +stack and returning to the scheduler. If the return address under the +constructor is @HUGS_RET@, the entry code for @HUGS_RET@ will +rearrange the stack so that the return @BCO@ is on top of the stack +and return to the scheduler which will then call the bytecode +evaluator. There is little point in trying to shorten this slightly +indirect route since it is will happen very rarely if at all. + +\note{As an optimisation, we could store the choice of evaluator in +the TSO status whenever we leave the evaluator. This is required for +any thread, no matter what state it is in (blocked, stack overflow, +etc). It isn't clear whether this would accomplish anything.} + +\Subsection{Returning from a thread}{thread-return} + +The evaluators return to the scheduler when any of the following +conditions arise: + +\begin{itemize} +\item A heap check fails, and a garbage collection is required. + +\item A stack check fails, and the scheduler must either enlarge the +current thread's stack, or flag an out of memory condition. + +\item A thread enters a closure built by the other evaluator. That +is, when the bytecode interpreter enters a closure compiled by GHC or +when the machine code evaluator enters a BCO. + +\item A thread returns to a return continuation built by the other +evaluator. That is, when the machine code evaluator returns to a +continuation built by Hugs or when the bytecode evaluator returns to a +continuation built by GHC. + +\item The evaluator needs to perform a ``safe'' C call +(\secref{c-calls}). + +\item The thread becomes blocked. This happens when a thread requires +the result of a computation currently being performed by another +thread, or it reads a synchronisation variable that is currently empty +(\secref{MVAR}). + +\item The thread is preempted (the preemption mechanism is described +in \secref{thread-preemption}). + +\item The thread terminates. +\end{itemize} + +Except when the thread terminates, the thread always terminates with a +closure on the top of the stack. The mechanism used to trigger the +world switch and the choice of closure left on top of the stack varies +according to which world is being left and what is being returned. + +\Subsubsection{Leaving the bytecode evaluator}{hugs-to-ghc-switch} + +\paragraph{Entering a machine code closure} + +When it enters a closure, the bytecode evaluator performs a switch +based on the type of closure (@AP@, @PAP@, @Ind@, etc). On entering a +machine code closure, it returns to the scheduler with the closure on +top of the stack. + +\paragraph{Returning a constructor} + +When it enters a constructor, the bytecode evaluator tests the return +continuation on top of the stack. If it is a machine code +continuation, it returns to the scheduler with the constructor on top +of the stack. + +\note{This is why the scheduler must enter the machine code evaluator +if it finds a constructor on top of the stack.} + +\paragraph{Returning an unboxed value} + +\note{Hugs doesn't support unboxed values in source programs but they +are used for a few complex primops.} + +When it returns an unboxed value, the bytecode evaluator tests the +return continuation on top of the stack. If it is a machine code +continuation, it returns to the scheduler with the tagged unboxed +value and a special closure on top of the stack. When the closure is +entered (by the machine code evaluator), it returns the unboxed value +on top of the stack to the return continuation under it. + +The runtime library for GHC provides one of these closures for each unboxed +type. Hugs cannot generate them itself since the entry code is really +very tricky. + +\paragraph{Heap/Stack overflow and preemption} + +The bytecode evaluator tests for heap/stack overflow and preemption +when entering a BCO and simply returns with the BCO on top of the +stack. + +\Subsubsection{Leaving the machine code evaluator}{ghc-to-hugs-switch} + +\paragraph{Entering a BCO} + +The entry code for a BCO pushes the BCO onto the stack and returns to +the scheduler. + +\paragraph{Returning a constructor} + +We avoid the need to test return addresses in the machine code +evaluator by pushing a special return address on top of a pointer to +the bytecode return continuation. \figref{hugs-return-stack1} +shows the state of the stack just before evaluating the scrutinee. + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| bco |--> BCO ++----------+ +| HUGS_RET | ++----------+ +\end{verbatim} +%\input{hugs_return1.pstex_t} +\end{center} +\caption{Stack layout for evaluating a scrutinee} +\label{fig:hugs-return-stack1} +\end{figure} + +This return address rearranges the stack so that the bco pointer is +above the constructor on the stack (as shown in +\figref{hugs-boxed-return}) and returns to the scheduler. + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| con |--> Constructor ++----------+ +| bco |--> BCO ++----------+ +\end{verbatim} +%\input{hugs_return2.pstex_t} +\end{center} +\caption{Stack layout for entering a Hugs return address} +\label{fig:hugs-boxed-return} +\end{figure} + +\paragraph{Returning an unboxed value} + +We avoid the need to test return addresses in the machine code +evaluator by pushing a special return address on top of a pointer to +the bytecode return continuation. This return address rearranges the +stack so that the bco pointer is above the tagged unboxed value (as +shown in \figref{hugs-entering-unboxed-return}) and returns to the +scheduler. + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| 1# | ++----------+ +| I# | ++----------+ +| bco |--> BCO ++----------+ +\end{verbatim} +%\input{hugs_return2.pstex_t} +\end{center} +\caption{Stack layout for returning an unboxed value} +\label{fig:hugs-entering-unboxed-return} +\end{figure} + +\paragraph{Heap/Stack overflow and preemption} + +\ToDo{} + + +\Subsection{Preempting a thread}{thread-preemption} + +Strictly speaking, threads cannot be preempted --- the scheduler +merely sets a preemption request flag which the thread must arrange to +test on a regular basis. When an evaluator finds that the preemption +request flag is set, it pushes an appropriate closure onto the stack +and returns to the scheduler. + +In the bytecode interpreter, the flag is tested whenever we enter a +closure. If the preemption flag is set, it leaves the closure on top +of the stack and returns to the scheduler. + +In the machine code evaluator, the flag is only tested when a heap or +stack check fails. This is less expensive than testing the flag on +entering every closure but runs the risk that a thread will enter an +infinite loop which does not allocate any space. If the flag is set, +the evaluator returns to the scheduler exactly as if a heap check had +failed. + +\Subsection{``Safe'' and ``unsafe'' C calls}{c-calls} + +There are two ways of calling C: + +\begin{description} + +\item[``Unsafe'' C calls] are used if the programer is certain that +the C function will not do anything dangerous. Unsafe C calls are +faster but must be hand-checked by the programmer. + +Dangerous things include: + +\begin{itemize} + +\item + +Call a system function such as @getchar@ which might block +indefinitely. This is dangerous because we don't want the entire +runtime system to block just because one thread blocks. + +\item + +Call an RTS function which will block on the RTS access semaphore. +This would lead to deadlock. + +\item + +Call a Haskell function. This is just a special case of calling an +RTS function. + +\end{itemize} + +Unsafe C calls are performed by pushing the arguments onto the C stack +and jumping to the C function's entry point. On exit, the result of +the function is in a register which is returned to the Haskell code as +an unboxed value. + +\item[``Safe'' C calls] are used if the programmer suspects that the +thread may do something dangerous. Safe C calls are relatively slow +but are less problematic. + +Safe C calls are performed by pushing the arguments onto the Haskell +stack, pushing a return continuation and returning a \emph{C function +descriptor} to the scheduler. The scheduler suspends the Haskell thread, +spawns a new operating system thread which pops the arguments off the +Haskell stack onto the C stack, calls the C function, pushes the +function result onto the Haskell stack and informs the scheduler that +the C function has completed and the Haskell thread is now runnable. + +\end{description} + +The bytecode evaluator will probably treat all C calls as being safe. + +\ToDo{It might be good for the programmer to indicate how the program +is unsafe. For example, if we distinguish between C functions which +might call Haskell functions and those which might block, we could +perform an unsafe call for blocking functions in a single-threaded +system or, perhaps, in a multi-threaded system which only happens to +have a single thread at the moment.} + + + +\Section{The Storage Manager}{sm-overview} + +The storage manager is responsible for managing the heap and all +objects stored in it. It provides special support for lazy evaluation +and for foreign function calls. + +\Subsection{SM support for lazy evaluation}{sm-lazy-evaluation} + +\begin{itemize} +\item + +Indirections are shorted out. + +\item + +Update frames pointing to unreachable objects are squeezed out. + +\ToDo{Part IV suggests this doesn't happen.} + +\item + +Adjacent update frames (for different closures) are compressed to a +single update frame pointing to a single black hole. + +\end{itemize} + + +\Subsection{SM support for foreign function calls}{sm-foreign-calls} + +\begin{itemize} + +\item + +Stable pointers allow other languages to access Haskell objects. + +\item + +Weak pointers and foreign objects provide finalisation support for +Haskell references to external objects. + +\end{itemize} + +\Subsection{Misc}{sm-misc} + +\begin{itemize} + +\item + +If the stack contains a large amount of free space, the storage +manager may shrink the stack. If it shrinks the stack, it guarantees +never to leave less than @MIN_SIZE_SHRUNKEN_STACK@ empty words on the +stack when it does so. + +\item + +For efficiency reasons, very large objects (eg large arrays and TSOs) +are not moved if possible. + +\end{itemize} + + +\Section{The Compilers}{compilers-overview} + +Need to describe interface files, format of bytecode files, symbols +defined by machine code files. + +\Subsection{Interface Files}{interface-files} + +Here's an example - but I don't know the grammar - ADR. +\begin{verbatim} +_interface_ Main 1 +_exports_ +Main main ; +_declarations_ +1 main _:_ IOBase.IO PrelBase.();; +\end{verbatim} + +\Subsection{Bytecode files}{bytecode-files} + +(All that matters here is what the loader sees.) + +\Subsection{Machine code files}{asm-files} + +(Again, all that matters is what the loader sees.) + +\Section{The Loader}{loader-overview} + +In a batch mode system, we can statically link all the modules +together. In an interactive system we need a loader which will +explicitly load and unload individual modules (or, perhaps, blocks of +mutually dependent modules) and resolve references between modules. + +While many operating systems provide support for dynamic loading and +will automatically resolve cross-module references for us, we generally +cannot rely on being able to load mutually dependent modules. + +A portable solution is to perform some of the linking ourselves. Each module +should provide three global symbols: +\begin{itemize} +\item +An initialisation routine. (Might also be used for finalisation.) +\item +A table of symbols it exports. +Entries in this table consist of the symbol name and the address of the +name's value. +\item +A table of symbols it imports. +Entries in this table consist of the symbol name and a list of references +to that symbol. +\end{itemize} + +On loading a group of modules, the loader adds the contents of the +export lists to a symbol table and then fills in all the references in the +import lists. + +References in import lists are of two types: +\begin{description} +\item[ References in machine code ] + +The most efficient approach is to patch the machine code directly, but +this will be a lot of work, very painful to port and rather fragile. + +Alternatively, the loader could store the value of each symbol in the +import table for each module and the compiled code can access all +external objects through the import table. This requires that the +import table be writable but does not require that the machine code or +info tables be writable. + +\item[ References in data structures (SRTs and static data constructors) ] + +Either we patch the SRTs and constructors directly or we somehow use +indirections through the symbol table. Patching the SRTs requires +that we make them writable and prevents us from making effective use +of virtual memories that use copy-on-write policies (this only makes a +difference if we want to run several copies of the same program +simultaneously). Using an indirection is possible but tricky. + +Note: We could avoid patching machine code if all references to +external references went through the SRT --- then we just have one +thing to patch. But the SRT always contains a pointer to the closure +rather than the fast entry point (say), so we'd take a big performance +hit for doing this. + +\end{description} + +Using the above scheme, all accesses to ``external'' objects involve a +layer of indirection. To avoid this overhead, the machine code +compiler might provide a way for the programmer to specify which +modules will be statically linked and which will be dynamically linked +--- the idea being that statically linked code and data will be +accessed directly. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\part{Internal details} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +This part is concerned with the internal details of the components +described in the previous part. + +The major components of the system are: +\begin{itemize} +\item The scheduler (\secref{scheduler-internals}) +\item The storage manager (\secref{storage-manager-internals}) +\item The evaluators +\item The loader +\item The compilers +\end{itemize} + +\Section{The Scheduler}{scheduler-internals} + +\ToDo{Detailed description of scheduler} + +Many heap objects contain fields allowing them to be inserted onto lists +during evaluation or during garbage collection. The lists required by +the evaluator and storage manager are as follows. + +\begin{itemize} + +\item 4 lists of threads: runnable threads, sleeping threads, threads +waiting for timeout and threads waiting for I/O. + +\item The \emph{mutables list} is a list of all objects in the old +generation which might contain pointers into the new generation. Most +of the objects on this list are indirections (\secref{IND}) +or ``mutable.'' (\secref{mutables}.) + +\item The \emph{Foreign Object list} is a list of all foreign objects + which have not yet been deallocated. (\secref{FOREIGN}.) + +\item The \emph{Spark pool} is a doubly(?) linked list of Spark objects +maintained by the parallel system. (\secref{SPARK}.) + +\item The \emph{Blocked Fetch list} (or +lists?). (\secref{BLOCKED_FETCH}.) + +\item For each thread, there is a list of all update frames on the +stack. (\secref{data-updates}.) + +\item The Stable Pointer Table is a table of pointers to objects which +are known to the outside world and must be retained by the garbage +collector even if they are not accessible from within the heap. + +\end{itemize} + +\ToDo{The links for these fields are usually inserted immediately +after the fixed header except ...} + + + +\Section{The Storage Manager}{storage-manager-internals} + +\subsection{Misc Text looking for a home} + +A \emph{value} may be: +\begin{itemize} +\item \emph{Boxed}, i.e.~represented indirectly by a pointer to a heap object (e.g.~foreign objects, arrays); or +\item \emph{Unboxed}, i.e.~represented directly by a bit-pattern in one or more registers (e.g.~@Int#@ and @Float#@). +\end{itemize} +All \emph{pointed} values are \emph{boxed}. + + +\Subsection{Heap Objects}{heap-objects} +\label{sec:fixed-header} + +\begin{figure} +\begin{center} +\input{closure} +\end{center} +\ToDo{Fix this picture} +\caption{A closure} +\label{fig:closure} +\end{figure} + +Every \emph{heap object} is a contiguous block of memory, consisting +of a fixed-format \emph{header} followed by zero or more \emph{data +words}. + +The header consists of the following fields: +\begin{itemize} +\item A one-word \emph{info pointer}, which points to +the object's static \emph{info table}. +\item Zero or more \emph{admin words} that support +\begin{itemize} +\item Profiling (notably a \emph{cost centre} word). + \note{We could possibly omit the cost centre word from some + administrative objects.} +\item Parallelism (e.g. GranSim keeps the object's global address here, +though GUM keeps a separate hash table). +\item Statistics (e.g. a word to track how many times a thunk is entered.). + +We add a Ticky word to the fixed-header part of closures. This is +used to indicate if a closure has been updated but not yet entered. It +is set when the closure is updated and cleared when subsequently +entered. \footnote{% NB: It is \emph{not} an ``entry count'', it is +an ``entries-after-update count.'' The commoning up of @CONST@, +@CHARLIKE@ and @INTLIKE@ closures is turned off(?) if this is +required. This has only been done for 2s collection. } + +\end{itemize} +\end{itemize} + +Most of the RTS is completely insensitive to the number of admin +words. The total size of the fixed header is given by +@sizeof(StgHeader)@. + +\Subsection{Info Tables}{info-tables} + +An \emph{info table} is a contiguous block of memory, laid out as follows: + +\begin{center} +\begin{tabular}{|r|l|} + \hline Parallelism Info & variable +\\ \hline Profile Info & variable +\\ \hline Debug Info & variable +\\ \hline Static reference table & pointer word (optional) +\\ \hline Storage manager layout info & pointer word +\\ \hline Closure flags & 8 bits +\\ \hline Closure type & 8 bits +\\ \hline Constructor Tag / SRT length & 16 bits +\\ \hline entry code +\\ \vdots +\end{tabular} +\end{center} + +On a 64-bit machine the tag, type and flags fields will all be doubled +in size, so the info table is a multiple of 64 bits. + +An info table has the following contents (working backwards in memory +addresses): + +\begin{itemize} + +\item The \emph{entry code} for the closure. This code appears +literally as the (large) last entry in the info table, immediately +preceded by the rest of the info table. An \emph{info pointer} always +points to the first byte of the entry code. + +\item A 16-bit constructor tag / SRT length. For a constructor info +table this field contains the tag of the constructor, in the range +$0..n-1$ where $n$ is the number of constructors in the datatype. +Otherwise, it contains the number of entries in this closure's Static +Reference Table (\secref{srt}). + +\item An 8-bit {\em closure type field}, which identifies what kind of +closure the object is. The various types of closure are described in +\secref{closures}. + +\item an 8-bit flags field, which holds various flags pertaining to +the closure type. + +\item A single pointer or word --- the {\em storage manager info +field}, contains auxiliary information describing the closure's +precise layout, for the benefit of the garbage collector and the code +that stuffs graph into packets for transmission over the network. +There are three kinds of layout information: + +\begin{itemize} +\item Standard layout information is for closures which place pointers +before non-pointers in instances of the closure (this applies to most +heap-based and static closures, but not activation records). The +layout information for standard closures is + + \begin{itemize} + \item Number of pointer fields (16 bits). + \item Number of non-pointer fields (16 bits). + \end{itemize} + +\item Activation records don't have pointers before non-pointers, +since stack-stubbing requires that the record has holes in it. The +layout is therefore represented by a bitmap in which each '1' bit +represents a non-pointer word. This kind of layout info is used for +@RET_SMALL@ and @RET_VEC_SMALL@ closures. + +\item If an activation record is longer than 32 words, then the layout +field contains a pointer to a bitmap record, consisting of a length +field followed by two or more bitmap words. This layout information +is used for @RET_BIG@ and @RET_VEC_BIG@ closures. + +\item Selector Thunks (\secref{THUNK_SELECTOR}) use the closure +layout field to hold the selector index, since the layout is always +known (the closure contains a single pointer field). +\end{itemize} + +\item A one-word {\em Static Reference Table} field. This field +points to the static reference table for the closure (\secref{srt}), +and is only present for the following closure types: + + \begin{itemize} + \item @FUN_*@ + \item @THUNK_*@ + \item @RET_*@ + \end{itemize} + +\ToDo{Expand the following explanation.} + +An SRT is basically a vector of pointers to static closures. A +top-level function or thunk will have an SRT (which might be empty), +which points to all the static closures referenced by that function or +thunk. Every non-top-level thunk or function also has an SRT, but +it'll be a sub-sequence of the top-level SRT, so we just store a +pointer and a length in the info table - the pointer points into the +middle of the larger SRT. + +At GC time, the garbage collector traverses the transitive closure of +all the SRTs reachable from the roots, and thereby discovers which +CAFs are live. + +\item \emph{Profiling info\/} + +\ToDo{The profiling info is completely bogus. I've not deleted it +from the document but I've commented it all out.} + +% change to \iftrue to uncomment this section +\iffalse + +Closure category records are attached to the info table of the +closure. They are declared with the info table. We put pointers to +these ClCat things in info tables. We need these ClCat things because +they are mutable, whereas info tables are immutable. Hashing will map +similar categories to the same hash value allowing statistics to be +grouped by closure category. + +Cost Centres and Closure Categories are hashed to provide indexes +against which arbitrary information can be stored. These indexes are +memoised in the appropriate cost centre or category record and +subsequent hashes avoided by the index routine (it simply returns the +memoised index). + +There are different features which can be hashed allowing information +to be stored for different groupings. Cost centres have the cost +centre recorded (using the pointer), module and group. Closure +categories have the closure description and the type +description. Records with the same feature will be hashed to the same +index value. + +The initialisation routines, @init_index_@, allocate a hash +table in which the cost centre / category records are stored. The +lower bound for the table size is taken from @max__no@. They +return the actual table size used (the next power of 2). Unused +locations in the hash table are indicated by a 0 entry. Successive +@init_index_@ calls just return the actual table size. + +Calls to @index_@ will insert the cost centre / category +record in the @@ hash table, if not already inserted. The hash +index is memoised in the record and returned. + +CURRENTLY ONLY ONE MEMOISATION SLOT IS AVILABLE IN EACH RECORD SO +HASHING CAN ONLY BE DONE ON ONE FEATURE FOR EACH RECORD. This can be +easily relaxed at the expense of extra memoisation space or continued +rehashing. + +The initialisation routines must be called before initialisation of +the stacks and heap as they require to allocate storage. It is also +expected that the caller may want to allocate additional storage in +which to store profiling information based on the return table size +value(s). + +\begin{center} +\begin{tabular}{|l|} + \hline Hash Index +\\ \hline Selected +\\ \hline Kind +\\ \hline Description String +\\ \hline Type String +\\ \hline +\end{tabular} +\end{center} + +\begin{description} +\item[Hash Index] Memoised copy +\item[Selected] + Is this category selected (-1 == not memoised, selected? 0 or 1) +\item[Kind] +One of the following values (defined in CostCentre.lh): + +\begin{description} +\item[@CON_K@] +A constructor. +\item[@FN_K@] +A literal function. +\item[@PAP_K@] +A partial application. +\item[@THK_K@] +A thunk, or suspension. +\item[@BH_K@] +A black hole. +\item[@ARR_K@] +An array. +\item[@ForeignObj_K@] +A Foreign object (non-Haskell heap resident). +\item[@SPT_K@] +The Stable Pointer table. (There should only be one of these but it +represents a form of weak space leak since it can't shrink to meet +non-demand so it may be worth watching separately? ADR) +\item[@INTERNAL_KIND@] +Something internal to the runtime system. +\end{description} + + +\item[Description] Source derived string detailing closure description. +\item[Type] Source derived string detailing closure type. +\end{description} + +\fi % end of commented out stuff + +\item \emph{Parallelism info\/} +\ToDo{} + +\item \emph{Debugging info\/} +\ToDo{} + +\end{itemize} + + +%----------------------------------------------------------------------------- +\Subsection{Kinds of Heap Object}{closures} + +Heap objects can be classified in several ways, but one useful one is +this: +\begin{itemize} +\item +\emph{Static closures} occupy fixed, statically-allocated memory +locations, with globally known addresses. + +\item +\emph{Dynamic closures} are individually allocated in the heap. + +\item +\emph{Stack closures} are closures allocated within a thread's stack +(which is itself a heap object). Unlike other closures, there are +never any pointers to stack closures. Stack closures are discussed in +\secref{TSO}. + +\end{itemize} +A second useful classification is this: +\begin{itemize} + +\item \emph{Executive objects}, such as thunks and data constructors, +participate directly in a program's execution. They can be subdivided +into three kinds of objects according to their type: \begin{itemize} + +\item \emph{Pointed objects}, represent values of a \emph{pointed} +type (<.pointed types launchbury.>) --i.e.~a type that includes +$\bottom$ such as @Int@ or @Int# -> Int#@. + +\item \emph{Unpointed objects}, represent values of a \emph{unpointed} +type --i.e.~a type that does not include $\bottom$ such as @Int#@ or +@Array#@. + +\item \emph{Activation frames}, represent ``continuations''. They are +always stored on the stack and are never pointed to by heap objects or +passed as arguments. \note{It's not clear if this will still be true +once we support speculative evaluation.} + +\end{itemize} + +\item \emph{Administrative objects}, such as stack objects and thread +state objects, do not represent values in the original program. +\end{itemize} + +Only pointed objects can be entered. If an unpointed object is +entered the program will usually terminate with a fatal error. + +This section enumerates all the kinds of heap objects in the system. +Each is identified by a distinct closure type field in its info table. + +\begin{tabular}{|l|l|l|l|l|l|l|l|l|l|l|} +\hline + +closure type & Section \\ + +\hline +\emph{Pointed} \\ +\hline + +@CONSTR@ & \ref{sec:CONSTR} \\ +@CONSTR_p_n@ & \ref{sec:CONSTR} \\ +@CONSTR_STATIC@ & \ref{sec:CONSTR} \\ +@CONSTR_NOCAF_STATIC@ & \ref{sec:CONSTR} \\ + +@FUN@ & \ref{sec:FUN} \\ +@FUN_p_n@ & \ref{sec:FUN} \\ +@FUN_STATIC@ & \ref{sec:FUN} \\ + +@THUNK@ & \ref{sec:THUNK} \\ +@THUNK_p_n@ & \ref{sec:THUNK} \\ +@THUNK_STATIC@ & \ref{sec:THUNK} \\ +@THUNK_SELECTOR@ & \ref{sec:THUNK_SELECTOR} \\ + +@BCO@ & \ref{sec:BCO} \\ + +@AP_UPD@ & \ref{sec:AP_UPD} \\ +@PAP@ & \ref{sec:PAP} \\ + +@IND@ & \ref{sec:IND} \\ +@IND_OLDGEN@ & \ref{sec:IND} \\ +@IND_PERM@ & \ref{sec:IND} \\ +@IND_OLDGEN_PERM@ & \ref{sec:IND} \\ +@IND_STATIC@ & \ref{sec:IND} \\ + +@CAF_UNENTERED@ & \ref{sec:CAF} \\ +@CAF_ENTERED@ & \ref{sec:CAF} \\ +@CAF_BLACKHOLE@ & \ref{sec:CAF} \\ + +\hline +\emph{Unpointed} \\ +\hline + +@BLACKHOLE@ & \ref{sec:BLACKHOLE} \\ +@BLACKHOLE_BQ@ & \ref{sec:BLACKHOLE_BQ} \\ + +@MVAR@ & \ref{sec:MVAR} \\ + +@ARR_WORDS@ & \ref{sec:ARR_WORDS} \\ + +@MUTARR_PTRS@ & \ref{sec:MUT_ARR_PTRS} \\ +@MUTARR_PTRS_FROZEN@ & \ref{sec:MUT_ARR_PTRS_FROZEN} \\ + +@MUT_VAR@ & \ref{sec:MUT_VAR} \\ + +@WEAK@ & \ref{sec:WEAK} \\ +@FOREIGN@ & \ref{sec:FOREIGN} \\ +@STABLE_NAME@ & \ref{sec:STABLE_NAME} \\ +\hline +\end{tabular} + +Activation frames do not live (directly) on the heap --- but they have +a similar organisation. + +\begin{tabular}{|l|l|}\hline +closure type & Section \\ \hline +@RET_SMALL@ & \ref{sec:activation-records} \\ +@RET_VEC_SMALL@ & \ref{sec:activation-records} \\ +@RET_BIG@ & \ref{sec:activation-records} \\ +@RET_VEC_BIG@ & \ref{sec:activation-records} \\ +@UPDATE_FRAME@ & \ref{sec:activation-records} \\ +@CATCH_FRAME@ & \ref{sec:activation-records} \\ +@SEQ_FRAME@ & \ref{sec:activation-records} \\ +@STOP_FRAME@ & \ref{sec:activation-records} \\ +\hline +\end{tabular} + +There are also a number of administrative objects. It is an error to +enter one of these objects. + +\begin{tabular}{|l|l|}\hline +closure type & Section \\ \hline +@TSO@ & \ref{sec:TSO} \\ +@SPARK_OBJECT@ & \ref{sec:SPARK} \\ +@BLOCKED_FETCH@ & \ref{sec:BLOCKED_FETCH} \\ +@FETCHME@ & \ref{sec:FETCHME} \\ +\hline +\end{tabular} + +\Subsection{Predicates}{closure-predicates} + +The runtime system sometimes needs to be able to distinguish objects +according to their properties: is the object updateable? is it in weak +head normal form? etc. These questions can be answered by examining +the closure type field of the object's info table. + +We define the following predicates to detect families of related +info types. They are mutually exclusive and exhaustive. + +\begin{itemize} +\item @isCONSTR@ is true for @CONSTR@s. +\item @isFUN@ is true for @FUN@s. +\item @isTHUNK@ is true for @THUNK@s. +\item @isBCO@ is true for @BCO@s. +\item @isAP@ is true for @AP@s. +\item @isPAP@ is true for @PAP@s. +\item @isINDIRECTION@ is true for indirection objects. +\item @isBH@ is true for black holes. +\item @isFOREIGN_OBJECT@ is true for foreign objects. +\item @isARRAY@ is true for array objects. +\item @isMVAR@ is true for @MVAR@s. +\item @isIVAR@ is true for @IVAR@s. +\item @isFETCHME@ is true for @FETCHME@s. +\item @isSLOP@ is true for slop objects. +\item @isRET_ADDR@ is true for return addresses. +\item @isUPD_ADDR@ is true for update frames. +\item @isTSO@ is true for @TSO@s. +\item @isSTABLE_PTR_TABLE@ is true for the stable pointer table. +\item @isSPARK_OBJECT@ is true for spark objects. +\item @isBLOCKED_FETCH@ is true for blocked fetch objects. +\item @isINVALID_INFOTYPE@ is true for all other info types. + +\end{itemize} + +The following predicates detect other interesting properties: + +\begin{itemize} + +\item @isPOINTED@ is true if an object has a pointed type. + +If an object is pointed, the following predicates may be true +(otherwise they are false). @isWHNF@ and @isUPDATEABLE@ are +mutually exclusive. + +\begin{itemize} +\item @isWHNF@ is true if the object is in Weak Head Normal Form. +Note that unpointed objects are (arbitrarily) not considered to be in WHNF. + +@isWHNF@ is true for @PAP@s, @CONSTR@s, @FUN@s and all @BCO@s. + +\ToDo{Need to distinguish between whnf BCOs and non-whnf BCOs in their +closure type} + +\item @isUPDATEABLE@ is true if the object may be overwritten with an + indirection object. + +@isUPDATEABLE@ is true for @THUNK@s, @AP@s and @BH@s. + +\end{itemize} + +It is possible for a pointed object to be neither updatable nor in +WHNF. For example, indirections. + +\item @isUNPOINTED@ is true if an object has an unpointed type. +All such objects are boxed since only boxed objects have info pointers. + +It is true for @ARR_WORDS@, @ARR_PTRS@, @MUTVAR@, @MUTARR_PTRS@, +@MUTARR_PTRS_FROZEN@, @FOREIGN@ objects, @MVAR@s and @IVAR@s. + +\item @isACTIVATION_FRAME@ is true for activation frames of all sorts. + +It is true for return addresses and update frames. +\begin{itemize} +\item @isVECTORED_RETADDR@ is true for vectored return addresses. +\item @isDIRECT_RETADDR@ is true for direct return addresses. +\end{itemize} + +\item @isADMINISTRATIVE@ is true for administrative objects: +@TSO@s, the stable pointer table, spark objects and blocked fetches. + +\item @hasSRT@ is true if the info table for the object contains an +SRT pointer. + +@hasSRT@ is true for @THUNK@s, @FUN@s, and @RET@s. + +\end{itemize} + +\begin{itemize} + +\item @isSTATIC@ is true for any statically allocated closure. + +\item @isMUTABLE@ is true for objects with mutable pointer fields: + @MUT_ARR@s, @MUTVAR@s, @MVAR@s and @IVAR@s. + +\item @isSparkable@ is true if the object can (and should) be sparked. +It is true of updateable objects which are not in WHNF with the +exception of @THUNK_SELECTOR@s and black holes. + +\end{itemize} + +As a minor optimisation, we might use the top bits of the @INFO_TYPE@ +field to ``cache'' the answers to some of these predicates. + +An indirection either points to HNF (post update); or is result of +overwriting a FetchMe, in which case the thing fetched is either under +evaluation (BLACKHOLE), or by now an HNF. Thus, indirections get +NoSpark flag. + +\subsection{Closures (aka Pointed Objects)} + +An object can be entered iff it is a closure. + +\Subsubsection{Function closures}{FUN} + +Function closures represent lambda abstractions. For example, +consider the top-level declaration: +\begin{verbatim} + f = \x -> let g = \y -> x+y + in g x +\end{verbatim} +Both @f@ and @g@ are represented by function closures. The closure +for @f@ is \emph{static} while that for @g@ is \emph{dynamic}. + +The layout of a function closure is as follows: +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Pointers} & \emph{Non-pointers} \\ \hline +\end{tabular} +\end{center} + +The data words (pointers and non-pointers) are the free variables of +the function closure. The number of pointers and number of +non-pointers are stored in @info->layout.ptrs@ and +@info->layout.nptrs@ respecively. + +There are several different sorts of function closure, distinguished +by their closure type field: + +\begin{itemize} + +\item @FUN@: a vanilla, dynamically allocated on the heap. + +\item $@FUN_@p@_@np$: to speed up garbage collection a number of +specialised forms of @FUN@ are provided, for particular $(p,np)$ +pairs, where $p$ is the number of pointers and $np$ the number of +non-pointers. + +\item @FUN_STATIC@. Top-level, static, function closures (such as @f@ +above) have a different layout than dynamic ones: + +\begin{center} +\begin{tabular}{|l|l|l|}\hline +\emph{Fixed header} & \emph{Static object link} \\ \hline +\end{tabular} +\end{center} + +Static function closures have no free variables. (However they may +refer to other static closures; these references are recorded in the +function closure's SRT.) They have one field that is not present in +dynamic closures, the \emph{static object link} field. This is used +by the garbage collector in the same way that to-space is, to gather +closures that have been determined to be live but that have not yet +been scavenged. + +\note{Static function closures that have no static references, and +hence a null SRT pointer, don't need the static object link field. We +don't take advantage of this at the moment, but we could. See +@CONSTR\_NOCAF\_STATIC@.} +\end{itemize} + +Each lambda abstraction, $f$, in the STG program has its own private +info table. The following labels are relevant: + +\begin{itemize} + +\item $f$@_info@ is $f$'s info table. + +\item $f$@_entry@ is $f$'s slow entry point (i.e. the entry code of +its info table; so it will label the same byte as $f$@_info@). + +\item $f@_fast_@k$ is $f$'s fast entry point. $k$ is the number of +arguments $f$ takes; encoding this number in the fast-entry label +occasionally catches some nasty code-generation errors. + +\end{itemize} + +\Subsubsection{Data constructors}{CONSTR} + +Data-constructor closures represent values constructed with algebraic +data type constructors. The general layout of data constructors is +the same as that for function closures. That is + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Pointers} & \emph{Non-pointers} \\ \hline +\end{tabular} +\end{center} + +There are several different sorts of constructor: + +\begin{itemize} + +\item @CONSTR@: a vanilla, dynamically allocated constructor. + +\item @CONSTR_@$p$@_@$np$: just like $@FUN_@p@_@np$. + +\item @CONSTR_INTLIKE@. A dynamically-allocated heap object that +looks just like an @Int@. The garbage collector checks to see if it +can common it up with one of a fixed set of static int-like closures, +thus getting it out of the dynamic heap altogether. + +\item @CONSTR_CHARLIKE@: same deal, but for @Char@. + +\item @CONSTR_STATIC@ is similar to @FUN_STATIC@, with the +complication that the layout of the constructor must mimic that of a +dynamic constructor, because a static constructor might be returned to +some code that unpacks it. So its layout is like this: + +\begin{center} +\begin{tabular}{|l|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Pointers} & \emph{Non-pointers} & \emph{Static object link}\\ \hline +\end{tabular} +\end{center} + +The static object link, at the end of the closure, serves the same purpose +as that for @FUN_STATIC@. The pointers in the static constructor can point +only to other static closures. + +The static object link occurs last in the closure so that static +constructors can store their data fields in exactly the same place as +dynamic constructors. + +\item @CONSTR_NOCAF_STATIC@. A statically allocated data constructor +that guarantees not to point (directly or indirectly) to any CAF +(\secref{CAF}). This means it does not need a static object +link field. Since we expect that there might be quite a lot of static +constructors this optimisation makes sense. Furthermore, the @NOCAF@ +tag allows the compiler to indicate that no CAFs can be reached +anywhere \emph{even indirectly}. + +\end{itemize} + +For each data constructor $Con$, two info tables are generated: + +\begin{itemize} +\item $Con$@_con_info@ labels $Con$'s dynamic info table, +shared by all dynamic instances of the constructor. +\item $Con$@_static@ labels $Con$'s static info table, +shared by all static instances of the constructor. +\end{itemize} + +Each constructor also has a \emph{constructor function}, which is a +curried function which builds an instance of the constructor. The +constructor function has an info table labelled as @$Con$_info@, and +entry code pointed to by @$Con$_entry@. + +Nullary constructors are represented by a single static info table, +which everyone points to. Thus for a nullary constructor we can omit +the dynamic info table and the constructor function. + +\subsubsection{Thunks} +\label{sec:THUNK} +\label{sec:THUNK_SELECTOR} + +A thunk represents an expression that is not obviously in head normal +form. For example, consider the following top-level definitions: +\begin{verbatim} + range = between 1 10 + f = \x -> let ys = take x range + in sum ys +\end{verbatim} +Here the right-hand sides of @range@ and @ys@ are both thunks; the former +is static while the latter is dynamic. + +The layout of a thunk is the same as that for a function closure. +However, thunks must have a payload of at least @MIN_UPD_SIZE@ +words to allow it to be overwritten with a black hole and an +indirection. The compiler may have to add extra non-pointer fields to +satisfy this constraint. + +\begin{center} +\begin{tabular}{|l|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Pointers} & \emph{Non-pointers} \\ \hline +\end{tabular} +\end{center} + +The layout word in the info table contains the same information as for +function closures; that is, number of pointers and number of +non-pointers. + +A thunk differs from a function closure in that it can be updated. + +There are several forms of thunk: + +\begin{itemize} + +\item @THUNK@ and $@THUNK_@p@_@np$: vanilla, dynamically allocated +thunks. Dynamic thunks are overwritten with normal indirections +(@IND@), or old generation indirections (@IND_OLDGEN@): see +\secref{IND}. + +\item @THUNK_STATIC@. A static thunk is also known as a +\emph{constant applicative form}, or \emph{CAF}. Static thunks are +overwritten with static indirections. + +\begin{center} +\begin{tabular}{|l|l|}\hline +\emph{Fixed header} & \emph{Static object link}\\ \hline +\end{tabular} +\end{center} + +\item @THUNK_SELECTOR@ is a (dynamically allocated) thunk whose entry +code performs a simple selection operation from a data constructor +drawn from a single-constructor type. For example, the thunk +\begin{verbatim} + x = case y of (a,b) -> a +\end{verbatim} +is a selector thunk. A selector thunk is laid out like this: + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Selectee pointer} \\ \hline +\end{tabular} +\end{center} + +The layout word contains the byte offset of the desired word in the +selectee. Note that this is different from all other thunks. + +The garbage collector ``peeks'' at the selectee's tag (in its info +table). If it is evaluated, then it goes ahead and does the +selection, and then behaves just as if the selector thunk was an +indirection to the selected field. If it is not evaluated, it treats +the selector thunk like any other thunk of that shape. +[Implementation notes. Copying: only the evacuate routine needs to be +special. Compacting: only the PRStart (marking) routine needs to be +special.] + +There is a fixed set of pre-compiled selector thunks built into the +RTS, representing offsets from 0 to @MAX_SPEC_SELECTOR_THUNK@. The +info tables are labelled @__sel_$n$_upd_info@ where $n$ is the offset. +Non-updating versions are also built in, with info tables labelled +@__sel_$n$_noupd_info@. + +\end{itemize} + +The only label associated with a thunk is its info table: + +\begin{description} +\item[$f$@\_info@] is $f$'s info table. +\end{description} + + +\Subsubsection{Byte-code objects}{BCO} + +A Byte-Code Object (BCO) is a container for a a chunk of byte-code, +which can be executed by Hugs. The byte-code represents a +supercombinator in the program: when Hugs compiles a module, it +performs lambda lifting and each resulting supercombinator becomes a +byte-code object in the heap. + +BCOs are not updateable; the bytecode compiler represents updatable +thunks using a combination of @AP@s and @BCO@s. + +The semantics of BCOs are described in \secref{hugs-heap-objects}. A +BCO has the following structure: + +\begin{center} +\begin{tabular}{|l|l|l|l|l|l|} +\hline +\emph{Fixed Header} & \emph{Layout} & \emph{Offset} & \emph{Size} & +\emph{Literals} & \emph{Byte code} \\ +\hline +\end{tabular} +\end{center} + +\noindent where: +\begin{itemize} +\item The entry code is a static code fragment/info table that returns +to the scheduler to invoke Hugs (\secref{ghc-to-hugs-switch}). +\item \emph{Layout} contains the number of pointer literals in the +\emph{Literals} field. +\item \emph{Offset} is the offset to the byte code from the start of +the object. +\item \emph{Size} is the number of words of byte code in the object. +\item \emph{Literals} contains any pointer and non-pointer literals used in +the byte-codes (including jump addresses), pointers first. +\item \emph{Byte code} contains \emph{Size} words of non-pointer byte +code. +\end{itemize} + + +\Subsubsection{Partial applications}{PAP} + +A partial application (PAP) represents a function applied to too few +arguments. It is only built as a result of updating after an +argument-satisfaction check failure. A PAP has the following shape: + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\emph{Fixed header} & \emph{No of words of stack} & \emph{Function closure} & \emph{Stack chunk ...} \\ \hline +\end{tabular} +\end{center} + +The ``Stack chunk'' is a copy of the chunk of stack above the update +frame; ``No of words of stack'' tells how many words it consists of. +The function closure is (a pointer to) the closure for the function +whose argument-satisfaction check failed. + +In the normal case where a PAP is built as a result of an argument +satisfaction check failure, the stack chunk will just contain +``pending arguments'', ie. pointers and tagged non-pointers. It may +in fact also contain activation records, but not update frames, seq +frames, or catch frames. The reason is the garbage collector uses the +same code to scavenge a stack as it does to scavenge the payload of a +PAP, but an update frame contains a link to the next update frame in +the chain and this link would need to be relocated during garbage +collection. Revertible black holes and asynchronous exceptions use +the more general form of PAPs (see Section \ref{revertible-bh}). + +There is just one standard form of PAP. There is just one info table +too, called @PAP_info@. Its entry code simply copies the arg stack +chunk back on top of the stack and enters the function closure. (It +has to do a stack overflow test first.) + +There is just one way to build a PAP: by calling @stg_update_PAP@ with +the function closure in register @R1@ and the pending arguments on the +stack. The @stg_update_PAP@ function will build the PAP, perform the +update, and return to the next activation record on the stack. If +there are \emph{no} pending arguments on the stack, then no PAP need +be built: in this case @stg_update_PAP@ just overwrites the updatee +with an indirection to the function closure. + +PAPs are also used to implement Hugs functions (where the arguments +are free variables). PAPs generated by Hugs can be static so we need +both @PAP@ and @PAP_STATIC@. + +\Subsubsection{\texttt{AP\_UPD} objects}{AP_UPD} + +@AP_UPD@ objects are used to represent thunks built by Hugs, and to +save the currently-active computations when performing @raiseAsync()@. +The only +distinction between an @AP_UPD@ and a @PAP@ is that an @AP_UPD@ is +updateable. + +\begin{center} +\begin{tabular}{|l|l|l|l|} +\hline +\emph{Fixed Header} & \emph{No of stack words} & \emph{Function closure} & \emph{Stack chunk} \\ +\hline +\end{tabular} +\end{center} + +The entry code pushes an update frame, copies the arg stack chunk on +top of the stack, and enters the function closure. (It has to do a +stack overflow test first.) + +The ``stack chunk'' is a block of stack not containing update frames, +seq frames or catch frames (just like a PAP). In the case of Hugs, +the stack chunk will contain the free variables of the thunk, and the +function closure is (a pointer to) the closure for the thunk. The +argument stack may be empty if the thunk has no free variables. + +\note{Since @AP\_UPD@s are updateable, the @MIN\_UPD\_SIZE@ constraint applies here too.} + +\Subsubsection{Indirections}{IND} + +Indirection closures just point to other closures. They are introduced +when a thunk is updated to point to its value. The entry code for all +indirections simply enters the closure it points to. + +There are several forms of indirection: + +\begin{description} +\item[@IND@] is the vanilla, dynamically-allocated indirection. +It is removed by the garbage collector. It has the following +shape: +\begin{center} +\begin{tabular}{|l|l|l|}\hline +\emph{Fixed header} & \emph{Target closure} \\ \hline +\end{tabular} +\end{center} + +An @IND@ only exists in the youngest generation. In older +generations, we have @IND_OLDGEN@s. The update code +(@Upd_frame_$n$_entry@) checks whether the updatee is in the youngest +generation before deciding which kind of indirection to use. + +\item[@IND\_OLDGEN@] is the vanilla, dynamically-allocated indirection. +It is removed by the garbage collector. It has the following +shape: +\begin{center} +\begin{tabular}{|l|l|l|}\hline +\emph{Fixed header} & \emph{Target closure} & \emph{Mutable link field} \\ \hline +\end{tabular} +\end{center} +It contains a \emph{mutable link field} that is used to string together +mutable objects in each old generation. + +\item[@IND\_PERM@] +For lexical profiling, it is necessary to maintain cost centre +information in an indirection, so ``permanent indirections'' are +retained forever. Otherwise they are just like vanilla indirections. +\note{If a permanent indirection points to another permanent +indirection or a @CONST@ closure, it is possible to elide the indirection +since it will have no effect on the profiler.} + +\note{Do we still need @IND@ in the profiling build, or do we just +need @IND@ but its behaviour changes when profiling is on?} + +\item[@IND\_OLDGEN\_PERM@] +Just like an @IND_OLDGEN@, but sticks around like an @IND_PERM@. + +\item[@IND\_STATIC@] is used for overwriting CAFs when they have been +evaluated. Static indirections are not removed by the garbage +collector; and are statically allocated outside the heap (and should +stay there). Their static object link field is used just as for +@FUN_STATIC@ closures. + +\begin{center} +\begin{tabular}{|l|l|l|} +\hline +\emph{Fixed header} & \emph{Target closure} & \emph{Static link field} \\ +\hline +\end{tabular} +\end{center} + +\end{description} + +\subsubsection{Black holes and blocking queues} +\label{sec:BLACKHOLE} +\label{sec:BLACKHOLE_BQ} + +Black hole closures are used to overwrite closures currently being +evaluated. They inform the garbage collector that there are no live +roots in the closure, thus removing a potential space leak. + +Black holes also become synchronization points in the concurrent +world. When a thread attempts to enter a blackhole, it must wait for +the result of the computation, which is presumably in progress in +another thread. + +\note{In a single-threaded system, entering a black hole indicates an +infinite loop. In a concurrent system, entering a black hole +indicates an infinite loop only if the hole is being entered by the +same thread that originally entered the closure. It could also bring +about a deadlock situation where several threads are waiting +circularly on computations in progress.} + +There are two types of black hole: + +\begin{description} + +\item[@BLACKHOLE@] +A straightforward blackhole just consists of an info pointer and some +padding to allow updating with an @IND_OLDGEN@ if necessary. This +type of blackhole has no waiting threads. + +\begin{center} +\begin{tabular}{|l|l|l|} +\hline +\emph{Fixed header} & \emph{Padding} & \emph{Padding} \\ +\hline +\end{tabular} +\end{center} + +If we're doing \emph{eager blackholing} then a thunk's info pointer is +overwritten with @BLACKHOLE_info@ at the time of entry; hence the need +for blackholes to be small, otherwise we'd be overwriting part of the +thunk itself. + +\item[@BLACKHOLE\_BQ@] +When a thread enters a @BLACKHOLE@, it is turned into a @BLACKHOLE_BQ@ +(blocking queue), which contains a linked list of blocked threads in +addition to the info pointer. + +\begin{center} +\begin{tabular}{|l|l|l|} +\hline +\emph{Fixed header} & \emph{Blocked thread link} & \emph{Mutable link field} \\ +\hline +\end{tabular} +\end{center} + +The \emph{Blocked thread link} points to the TSO of the first thread +waiting for the value of this thunk. All subsequent TSOs in the list +are linked together using their @tso->link@ field, ending in +@END_TSO_QUEUE_closure@. + +Because new threads can be added to the \emph{Blocked thread link}, a +blocking queue is \emph{mutable}, so we need a mutable link field in +order to chain it on to a mutable list for the generational garbage +collector. + +\end{description} + +\Subsubsection{FetchMes}{FETCHME} + +In the parallel systems, FetchMes are used to represent pointers into +the global heap. When evaluated, the value they point to is read from +the global heap. + +\ToDo{Describe layout} + +Because there may be offsets into these arrays, a primitive array +cannot be handled as a FetchMe in the parallel system, but must be +shipped in its entirety if its parent closure is shipped. + + + +\Subsection{Unpointed Objects}{unpointed-objects} + +A variable of unpointed type is always bound to a \emph{value}, never +to a \emph{thunk}. For this reason, unpointed objects cannot be +entered. + +\subsubsection{Immutable objects} +\label{sec:ARR_WORDS} + +\begin{description} +\item[@ARR\_WORDS@] is a variable-sized object consisting solely of +non-pointers. It is used for arrays of all sorts of things (bytes, +words, floats, doubles... it doesn't matter). + +Strictly speaking, an @ARR_WORDS@ could be mutable, but because it +only contains non-pointers we don't need to track this fact. + +\begin{center} +\begin{tabular}{|c|c|c|c|} +\hline +\emph{Fixed Hdr} & \emph{No of non-pointers} & \emph{Non-pointers\ldots} \\ \hline +\end{tabular} +\end{center} +\end{description} + +\subsubsection{Mutable objects} +\label{sec:mutables} +\label{sec:MUT_VAR} +\label{sec:MUT_ARR_PTRS} +\label{sec:MUT_ARR_PTRS_FROZEN} +\label{sec:MVAR} + +Some of these objects are \emph{mutable}; they represent objects which +are explicitly mutated by Haskell code through the @ST@ or @IO@ +monads. They're not used for thunks which are updated precisely once. +Depending on the garbage collector, mutable closures may contain extra +header information which allows a generational collector to implement +the ``write barrier.'' + +Notice that mutable objects all have the same general layout: there is +a mutable link field as the second word after the header. This is so +that code to process old-generation mutable lists doesn't need to look +at the type of the object to determine where its link field is. + +\begin{description} + +\item[@MUT\_VAR@] is a mutable variable. +\begin{center} +\begin{tabular}{|c|c|c|} +\hline +\emph{Fixed Hdr} \emph{Pointer} & \emph{Mutable link} & \\ \hline +\end{tabular} +\end{center} + +\item[@MUT\_ARR\_PTRS@] is a mutable array of pointers. Such an array +may be \emph{frozen}, becoming an @MUT_ARR_PTRS_FROZEN@, with a +different info-table. + +\begin{center} +\begin{tabular}{|c|c|c|c|} +\hline +\emph{Fixed Hdr} & \emph{No of ptrs} & \emph{Mutable link} & \emph{Pointers\ldots} \\ \hline +\end{tabular} +\end{center} + +\item[@MUT\_ARR\_PTRS\_FROZEN@] This is the immutable version of +@MUT_ARR_PTRS@. It still has a mutable link field for two reasons: we +need to keep it on the mutable list for an old generation at least +until the next garbage collection, and it may become mutable again via +@thawArray@. + +\begin{center} +\begin{tabular}{|c|c|c|c|} +\hline +\emph{Fixed Hdr} & \emph{No of ptrs} & \emph{Mutable link} & \emph{Pointers\ldots} \\ \hline +\end{tabular} +\end{center} + +\item[@MVAR@] + +\begin{center} +\begin{tabular}{|l|l|l|l|l|} +\hline +\emph{Fixed header} & \emph{Head} & \emph{Mutable link} & \emph{Tail} +& \emph{Value}\\ +\hline +\end{tabular} +\end{center} + +\ToDo{MVars} + +\end{description} + + +\Subsubsection{Foreign objects}{FOREIGN} + +Here's what a ForeignObj looks like: + +\begin{center} +\begin{tabular}{|l|l|l|l|} +\hline +\emph{Fixed header} & \emph{Data} \\ +\hline +\end{tabular} +\end{center} + +A foreign object is simple a boxed pointer to an address outside the +Haskell heap, possible to @malloc@ed data. The only reason foreign +objects exist is so that we can track the lifetime of one using weak +pointers (see \secref{WEAK}) and run a finaliser when the foreign +object is unreachable. + +\subsubsection{Weak pointers} +\label{sec:WEAK} + +\begin{center} +\begin{tabular}{|l|l|l|l|l|} +\hline +\emph{Fixed header} & \emph{Key} & \emph{Value} & \emph{Finaliser} +& \emph{Link}\\ +\hline +\end{tabular} +\end{center} + +\ToDo{Weak poitners} + +\subsubsection{Stable names} +\label{sec:STABLE_NAME} + +\begin{center} +\begin{tabular}{|l|l|l|l|} +\hline +\emph{Fixed header} & \emph{Index} \\ +\hline +\end{tabular} +\end{center} + +\ToDo{Stable names} + +The remaining objects types are all administrative --- none of them +may be entered. + +\subsection{Other weird objects} +\label{sec:SPARK} +\label{sec:BLOCKED_FETCH} + +\begin{description} +\item[@BlockedFetch@ heap objects (`closures')] (parallel only) + +@BlockedFetch@s are inbound fetch messages blocked on local closures. +They arise as entries in a local blocking queue when a fetch has been +received for a local black hole. When awakened, we look at their +contents to figure out where to send a resume. + +A @BlockedFetch@ closure has the form: +\begin{center} +\begin{tabular}{|l|l|l|l|l|l|}\hline +\emph{Fixed header} & link & node & gtid & slot & weight \\ \hline +\end{tabular} +\end{center} + +\item[Spark Closures] (parallel only) + +Spark closures are used to link together all closures in the spark pool. When +the current processor is idle, it may choose to speculatively evaluate some of +the closures in the pool. It may also choose to delete sparks from the pool. +\begin{center} +\begin{tabular}{|l|l|l|l|l|l|}\hline +\emph{Fixed header} & \emph{Spark pool link} & \emph{Sparked closure} \\ \hline +\end{tabular} +\end{center} + +\item[Slop Objects]\label{sec:slop-objects} + +Slop objects are used to overwrite the end of an updatee if it is +larger than an indirection. Normal slop objects consist of an info +pointer a size word and a number of slop words. + +\begin{center} +\begin{tabular}{|l|l|l|l|l|l|}\hline +\emph{Info Pointer} & \emph{Size} & \emph{Slop Words} \\ \hline +\end{tabular} +\end{center} + +This is too large for single word slop objects which consist of a +single info table. + +Note that slop objects only contain an info pointer, not a standard +fixed header. This doesn't cause problems because slop objects are +always unreachable --- they can only be accessed by linearly scanning +the heap. + +\note{Currently we don't use slop objects because the storage manager +isn't reliant on objects being adjacent, but if we move to a ``mostly +copying'' style collector, this will become an issue.} + +\end{description} + +\Subsection{Thread State Objects (TSOs)}{TSO} + +In the multi-threaded system, the state of a suspended thread is +packed up into a Thread State Object (TSO) which contains all the +information needed to restart the thread and for the garbage collector +to find all reachable objects. When a thread is running, it may be +``unpacked'' into machine registers and various other memory locations +to provide faster access. + +Single-threaded systems don't really \emph{need\/} TSOs --- but they do +need some way to tell the storage manager about live roots so it is +convenient to use a single TSO to store the mutator state even in +single-threaded systems. + +Rather than manage TSOs' alloc/dealloc, etc., in some \emph{ad hoc} +way, we instead alloc/dealloc/etc them in the heap; then we can use +all the standard garbage-collection/fetching/flushing/etc machinery on +them. So that's why TSOs are ``heap objects,'' albeit very special +ones. +\begin{center} +\begin{tabular}{|l|l|} + \hline \emph{Fixed header} +\\ \hline \emph{Link field} +\\ \hline \emph{Mutable link field} +\\ \hline \emph{What next} +\\ \hline \emph{State} +\\ \hline \emph{Thread Id} +\\ \hline \emph{Exception Handlers} +\\ \hline \emph{Ticky Info} +\\ \hline \emph{Profiling Info} +\\ \hline \emph{Parallel Info} +\\ \hline \emph{GranSim Info} +\\ \hline \emph{Stack size} +\\ \hline \emph{Max Stack size} +\\ \hline \emph{Sp} +\\ \hline \emph{Su} +\\ \hline \emph{SpLim} +\\ \hline +\\ + \emph{Stack} +\\ +\\ \hline +\end{tabular} +\end{center} +The contents of a TSO are: +\begin{description} + +\item[\emph{Link field}] This is a pointer used to maintain a list of +threads with a similar state (e.g.~all runnable, all sleeping, all +blocked on the same black hole, all blocked on the same MVar, +etc.) + +\item[\emph{Mutable link field}] Because the stack is mutable by +definition, the generational collector needs to track TSOs in older +generations that may point into younger ones (which is just about any +TSO for a thread that has run recently). Hence the need for a mutable +link field (see \secref{mutables}). + +\item[\emph{What next}] +This field has five values: +\begin{description} +\item[@ThreadEnterGHC@] The thread can be started by entering the +closure pointed to by the word on the top of the stack. +\item[@ThreadRunGHC@] The thread can be started by jumping to the +address on the top of the stack. +\item[@ThreadEnterHugs@] The stack has a pointer to a Hugs-built +closure on top of the stack: enter the closure to run the thread. +\item[@ThreadKilled@] The thread has been killed (by @killThread#@). +It is probably still around because it is on some queue somewhere and +hasn't been garbage collected yet. +\item[@ThreadComplete@] The thread has finished. Its @TSO@ hasn't +been garbage collected yet. +\end{description} + +\item[\emph{Thread Id}] +This field contains a (not necessarily unique) integer that identifies +the thread. It can be used eg. for hashing. + +\item[\emph{Ticky Info}] Optional information for ``Ticky Ticky'' +statistics: @TSO_STK_HWM@ is the maximum number of words allocated to +this thread. + +\item[\emph{Profiling Info}] Optional information for profiling: +@TSO_CCC@ is the current cost centre. + +\item[\emph{Parallel Info}] +Optional information for parallel execution. + +% \begin{itemize} +% +% \item The types of threads (@TSO_TYPE@): +% \begin{description} +% \item[@T_MAIN@] Must be executed locally. +% \item[@T_REQUIRED@] A required thread -- may be exported. +% \item[@T_ADVISORY@] An advisory thread -- may be exported. +% \item[@T_FAIL@] A failure thread -- may be exported. +% \end{description} +% +% \item I've no idea what else +% +% \end{itemize} + +\item[\emph{GranSim Info}] +Optional information for gransim execution. + +% \item Optional information for GranSim execution: +% \begin{itemize} +% \item locked +% \item sparkname +% \item started at +% \item exported +% \item basic blocks +% \item allocs +% \item exectime +% \item fetchtime +% \item fetchcount +% \item blocktime +% \item blockcount +% \item global sparks +% \item local sparks +% \item queue +% \item priority +% \item clock (gransim light only) +% \end{itemize} +% +% +% Here are the various queues for GrAnSim-type events. +% +% Q_RUNNING +% Q_RUNNABLE +% Q_BLOCKED +% Q_FETCHING +% Q_MIGRATING +% + +\item[\emph{Stack Info}] Various fields contain information on the +stack: its current size, its maximum size (to avoid infinite loops +overflowing the memory), the current stack pointer (\emph{Sp}), the +current stack update frame pointer (\emph{Su}), and the stack limit +(\emph{SpLim}). The latter three fields are loaded into the relevant +registers when the thread is run. + +\item[\emph{Stack}] This is the actual stack for the thread, +\emph{Stack size} words long. It grows downwards from higher +addresses to lower addresses. When the stack overflows, it will +generally be relocated into larger premises unless \emph{Max stack +size} is reached. + +\end{description} + +The garbage collector needs to be able to find all the +pointers in a stack. How does it do this? + +\begin{itemize} + +\item Within the stack there are return addresses, pushed +by @case@ expressions. Below a return address (i.e. at higher +memory addresses, since the stack grows downwards) is a chunk +of stack that the return address ``knows about'', namely the +activation record of the currently running function. + +\item Below each such activation record is a \emph{pending-argument +section}, a chunk of +zero or more words that are the arguments to which the result +of the function should be applied. The return address does not +statically +``know'' how many pending arguments there are, or their types. +(For example, the function might return a result of type $\alpha$.) + +\item Below each pending-argument section is another return address, +and so on. Actually, there might be an update frame instead, but we +can consider update frames as a special case of a return address with +a well-defined activation record. + +\end{itemize} + +The game plan is this. The garbage collector walks the stack from the +top, traversing pending-argument sections and activation records +alternately. Next we discuss how it finds the pointers in each of +these two stack regions. + + +\Subsubsection{Activation records}{activation-records} + +An \emph{activation record} is a contiguous chunk of stack, +with a return address as its first word, followed by as many +data words as the return address ``knows about''. The return +address is actually a fully-fledged info pointer. It points +to an info table, replete with: + +\begin{itemize} +\item entry code (i.e. the code to return to). + +\item closure type is either @RET_SMALL/RET_VEC_SMALL@ or +@RET_BIG/RET_VEC_BIG@, depending on whether the activation record has +more than 32 data words (\note{64 for 8-byte-word architectures}) and +on whether to use a direct or a vectored return. + +\item the layout info for @RET_SMALL@ is a bitmap telling the layout +of the activation record, one bit per word. The least-significant bit +describes the first data word of the record (adjacent to the fixed +header) and so on. A ``@1@'' indicates a non-pointer, a ``@0@'' +indicates a pointer. We don't need to indicate exactly how many words +there are, because when we get to all zeros we can treat the rest of +the activation record as part of the next pending-argument region. + +For @RET_BIG@ the layout field points to a block of bitmap words, +starting with a word that tells how many words are in the block. + +\item the info table contains a Static Reference Table pointer for the +return address (\secref{srt}). +\end{itemize} + +The activation record is a fully fledged closure too. As well as an +info pointer, it has all the other attributes of a fixed header +(\secref{fixed-header}) including a saved cost centre which +is reloaded when the return address is entered. + +In other words, all the attributes of closures are needed for +activation records, so it's very convenient to make them look alike. + + +\Subsubsection{Pending arguments}{pending-args} + +So that the garbage collector can correctly identify pointers in +pending-argument sections we explicitly tag all non-pointers. Every +non-pointer in a pending-argument section is preceded (at the next +lower memory word) by a one-word byte count that says how many bytes +to skip over (excluding the tag word). + +The garbage collector traverses a pending argument section from the +top (i.e. lowest memory address). It looks at each word in turn: + +\begin{itemize} +\item If it is less than or equal to a small constant @ARGTAG_MAX@ +then it treats it as a tag heralding zero or more words of +non-pointers, so it just skips over them. + +\item If it points to the code segment, it must be a return +address, so we have come to the end of the pending-argument section. + +\item Otherwise it must be a bona fide heap pointer. +\end{itemize} + + +\Subsection{The Stable Pointer Table}{STABLEPTR_TABLE} + +A stable pointer is a name for a Haskell object which can be passed to +the external world. It is ``stable'' in the sense that the name does +not change when the Haskell garbage collector runs---in contrast to +the address of the object which may well change. + +A stable pointer is represented by an index into the +@StablePointerTable@. The Haskell garbage collector treats the +@StablePointerTable@ as a source of roots for GC. + +In order to provide efficient access to stable pointers and to be able +to cope with any number of stable pointers (eg $0 \ldots 100000$), the +table of stable pointers is an array stored on the heap and can grow +when it overflows. (Since we cannot compact the table by moving +stable pointers about, it seems unlikely that a half-empty table can +be reduced in size---this could be fixed if necessary by using a +hash table of some sort.) + +In general a stable pointer table closure looks like this: + +\begin{center} +\begin{tabular}{|l|l|l|l|l|l|l|l|l|l|l|} +\hline +\emph{Fixed header} & \emph{No of pointers} & \emph{Free} & $SP_0$ & \ldots & $SP_{n-1}$ +\\\hline +\end{tabular} +\end{center} + +The fields are: +\begin{description} + +\item[@NPtrs@:] number of (stable) pointers. + +\item[@Free@:] the byte offset (from the first byte of the object) of the first free stable pointer. + +\item[$SP_i$:] A stable pointer slot. If this entry is in use, it is +an ``unstable'' pointer to a closure. If this entry is not in use, it +is a byte offset of the next free stable pointer slot. + +\end{description} + +When a stable pointer table is evacuated +\begin{enumerate} +\item the free list entries are all set to @NULL@ so that the evacuation + code knows they're not pointers; + +\item The stable pointer slots are scanned linearly: non-@NULL@ slots +are evacuated and @NULL@-values are chained together to form a new free list. +\end{enumerate} + +There's no need to link the stable pointer table onto the mutable +list because we always treat it as a root. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Subsection{Garbage Collecting CAFs}{CAF} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% begin{direct quote from current paper} +A CAF (constant applicative form) is a top-level expression with no +arguments. The expression may need a large, even unbounded, amount of +storage when it is fully evaluated. + +CAFs are represented by closures in static memory that are updated +with indirections to objects in the heap space once the expression is +evaluated. Previous version of GHC maintained a list of all evaluated +CAFs and traversed them during GC, the result being that the storage +allocated by a CAF would reside in the heap until the program ended. +% end{direct quote from current paper} + +% begin{elaboration on why CAFs are very very bad} +Treating CAFs this way has two problems: +\begin{itemize} +\item +It can cause a very large space leak. For example, this program +should run in constant space but, instead, will run out of memory. +\begin{verbatim} +> main :: IO () +> main = print nats +> +> nats :: [Int] +> nats = [0..maxInt] +\end{verbatim} + +\item +Expressions with no arguments have very different space behaviour +depending on whether or not they occur at the top level. For example, +if we make \verb+nats+ a local definition, the space leak goes away +and the resulting program runs in constant space, as expected. +\begin{verbatim} +> main :: IO () +> main = print nats +> where +> nats :: [Int] +> nats = [0..maxInt] +\end{verbatim} + +This huge change in the operational behaviour of the program +is a problem for optimising compilers and for programmers. +For example, GHC will normally flatten a set of let bindings using +this transformation: +\begin{verbatim} +let x1 = let x2 = e2 in e1 ==> let x2 = e2 in let x1 = e1 +\end{verbatim} +but it does not do so if this would raise \verb+x2+ to the top level +since that may create a CAF. Many Haskell programmers avoid creating +large CAFs by adding a dummy argument to a CAF or by moving a CAF away +from the top level. + +\end{itemize} +% end{elaboration on why CAFs are very very bad} + +Solving the CAF problem requires different treatment in interactive +systems such as Hugs than in batch-mode systems such as GHC +\begin{itemize} +\item +In a batch-mode the program the runtime system is terminated +after every execution of the runtime system. In such systems, +the garbage collector can completely ``destroy'' a CAF when it +is no longer live --- in much the same way as it ``destroys'' +normal closures when they are no longer live. + +\item +In an interactive system, many expressions are evaluated without +restarting the runtime system between each evaluation. In such +systems, the garbage collector cannot completely ``destroy'' a CAF +when it is no longer live because, whilst it might not be required in +the evaluation of the current expression, it might be required in the +next evaluation. + +There are two possible behaviours we might want: +\begin{enumerate} +\item +When a CAF is no longer required for the current evaluation, the CAF +should be reverted to its original form. This behaviour ensures that +the operational behaviour of the interactive system is a reasonable +predictor of the operational behaviour of the batch-mode system. This +allows us to use Hugs for performance debugging (in particular, trying +to understand and reduce the heap usage of a program) --- an area of +increasing importance as Haskell is used more and more to solve ``real +problems'' in ``real problem domains''. + +\item +Even if a CAF is no longer required for the current evaluation, we might +choose to hang onto it by collecting it in the normal way. This keeps +the space leak but might be useful in a teaching environment when +trying to teach the difference between call by name evaluation (which +doesn't share work) and lazy evaluation (which does share work). + +\end{enumerate} + +It turns out that it is easy to support both styles of use, so the +runtime system provides a switch which lets us turn this on and off +during execution. \ToDo{What is this switch called?} It would also +be easy to provide a function \verb+RevertCAF+ to let the interpreter +revert any CAF it wanted between (but not during) executions, if we so +desired. Running \verb+RevertCAF+ during execution would lose some sharing +but is otherwise harmless. + +\end{itemize} + +% % begin{even more pointless observation?} +% The simplest fix would be to remove the special treatment of +% top level variables. This works but is very inefficient. +% ToDo: say why. +% (Note: delete this paragraph from final version.) +% % end{even more pointless observation?} + +% begin{pointless observation?} +An easy but inefficient fix to the CAF problem would be to make a +complete copy of the heap before every evaluation and discard the copy +after evaluation. This works but is inefficient. +% end{pointless observation?} + +An efficient way to achieve a similar effect is to revert all +updatable thunks to their original form as they become unnecessary for +the current evaluation. To do this, we modify the compiler to ensure +that the only updatable thunks generated by the compiler are CAFs and +we modify the garbage collector to revert entered CAFs to unentered +CAFs as their value becomes unnecessary. + + +\subsubsection{New Heap Objects} + +We add three new kinds of heap object: unentered CAF closures, entered +CAF objects and CAF blackholes. We first describe how they are +evaluated and then how they are garbage collected. +\begin{itemize} +\item +Unentered CAF closures contain a pointer to closure representing the +body of the CAF. The ``body closure'' is not updatable. + +Unentered CAF closures contain two unused fields to make them the same +size as entered CAF closures --- which allows us to perform an inplace +update. \ToDo{Do we have to add another kind of inplace update operation +to the storage manager interface or do we consider this to be internal +to the SM?} +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\verb+CAF_unentered+ & \emph{body closure} & \emph{unused} & \emph{unused} \\ \hline +\end{tabular} +\end{center} +When an unentered CAF is entered, we do the following: +\begin{itemize} +\item +allocate a CAF black hole; + +\item +push an update frame (to update the CAF black hole) onto the stack; + +\item +overwrite the CAF with an entered CAF object (see below) with the same +body and whose value field points to the black hole; + +\item +add the CAF to a list of all entered CAFs (called ``the CAF list''); +and + +\item +the closure representing the value of the CAF is entered. + +\end{itemize} + +When evaluation of the CAF body returns a value, the update frame +causes the CAF black hole to be updated with the value in the normal +way. + +\ToDo{Add a picture} + +\item +Entered CAF closures contain two pointers: a pointer to the CAF body +(the same as for unentered CAF closures); a pointer to the CAF value +(this is initialised with a CAF blackhole, as previously described); +and a link to the next CAF in the CAF list + +\ToDo{How is the end of the list marked? Null pointer or sentinel value?}. + +\begin{center} +\begin{tabular}{|l|l|l|l|}\hline +\verb+CAF_entered+ & \emph{body closure} & \emph{value} & \emph{link} \\ \hline +\end{tabular} +\end{center} +When an entered CAF is entered, it enters its value closure. + +\item +CAF blackholes are identical to normal blackholes except that they +have a different infotable. The only reason for having CAF blackholes +is to allow an optimisation of lazy blackholing where we stop scanning +the stack when we see the first {\em normal blackhole} but not +when we see a {\em CAF blackhole.} +\ToDo{The optimisation we want to allow should be described elsewhere +so that all we have to do here is describe the difference.} + +Instead of allocating a blackhole to update with the value of the CAF, +it might seem simpler to update the CAF directly. This would require +a new kind of update frame which would update the value field of the +CAF with a pointer to the value and wouldn't catch blackholes caused +by CAFs that depend on themselves so we chose not to do so. + +\end{itemize} + +\subsubsection{Garbage Collection} + +To avoid the space leak, each run of the garbage collector must revert +the entered CAFs which are not required to complete the current +evaluation (that is all the closures reachable from the set of +runnable threads and the stable pointer table). + +It does this by performing garbage collection in three phases: +\begin{enumerate} +\item +During the first phase, we ``mark'' all closures reachable from the +scheduler state. + +How we ``mark'' closures depends on the garbage collector. For +example, in a 2-space collector, closures are ``marked'' by copying +them into ``to-space'', overwriting them with a forwarding node and +``marking'' all the closures reachable from the copy. The only +requirements are that we can test whether a closure is marked and if a +closure is marked then so are all closures reachable from it. + +\ToDo{At present we say that the scheduler state includes any state +that Hugs may have. This is not true anymore.} + +Performing this phase first provides us with a cheap test for +execution closures: at this stage in execution, the execution closures +are precisely the marked closures. + +\item +During the second phase, we revert all unmarked CAFs on the CAF list +and remove them from the CAF list. + +Since the CAF list is exactly the set of all entered CAFs, this reverts +all entered CAFs which are not execution closures. + +\item +During the third phase, we mark all top level objects (including CAFs) +by calling \verb+MarkHugsRoots+ which will call \verb+MarkRoot+ for +each top level object known to Hugs. + +\end{enumerate} + +To implement the second style of interactive behaviour (where we +deliberately keep the CAF-related space leak), we simply omit the +second phase. Omitting the second phase causes the third phase to +mark any unmarked CAF value closures. + +So far, we have been describing a pure Hugs system which contains no +machine generated code. The main difference in a hybrid system is +that GHC-generated code is statically allocated in memory instead of +being dynamically allocated on the heap. We split both +\verb+CAF_unentered+ and \verb+CAF_entered+ into two versions: a +static and a dynamic version. The static and dynamic versions of each +CAF differ only in whether they are moved during garbage collection. +When reverting CAFs, we revert dynamic entered CAFs to dynamic +unentered CAFs and static entered CAFs to static unentered CAFs. + + + + +\Section{The Bytecode Evaluator}{bytecode-evaluator} + +This section describes how the Hugs interpreter interprets code in the +same environment as compiled code executes. Both evaluation models +use a common garbage collector, so they must agree on the form of +objects in the heap. + +Hugs interprets code by converting it to byte-code and applying a +byte-code interpreter to it. Wherever possible, we try to ensure that +the byte-code is all that is required to interpret a section of code. +This means not dynamically generating info tables, and hence we can +only have a small number of possible heap objects each with a statically +compiled info table. Similarly for stack objects: in fact we only +have one Hugs stack object, in which all information is tagged for the +garbage collector. + +There is, however, one exception to this rule. Hugs must generate +info tables for any constructors it is asked to compile, since the +alternative is to force a context-switch each time compiled code +enters a Hugs-built constructor, which would be prohibitively +expensive. + +We achieve this simplicity by forgoing some of the optimisations used +by compiled code: +\begin{itemize} +\item + +Whereas compiled code has five different ways of entering a closure +(\secref{ghc-fun-call}), interpreted code has only one. +The entry point for interpreted code behaves like slow entry points for +compiled code. + +\item + +We use just one info table for \emph{all\/} direct returns. +This introduces two problems: +\begin{enumerate} +\item How does the interpreter know what code to execute? + +Instead of pushing just a return address, we push a return BCO and a +trivial return address which just enters the return BCO. + +(In a purely interpreted system, we could avoid pushing the trivial +return address.) + +\item How can the garbage collector follow pointers within the +activation record? + +We could push a third word ---a bitmask describing the location of any +pointers within the record--- but, since we're already tagging unboxed +function arguments on the stack, we use the same mechanism for unboxed +values within the activation record. + +\ToDo{Do we have to stub out dead variables in the activation frame?} + +\end{enumerate} + +\item + +We trivially support vectored returns by pushing a return vector whose +entries are all the same. + +\item + +We avoid the need to build SRTs by putting bytecode objects on the +heap and restricting BCOs to a single basic block. + +\end{itemize} + +\Subsection{Hugs Info Tables}{hugs-info-tables} + +Hugs requires the following info tables and closures: +\begin{description} +\item [@HUGS\_RET@]. + +Contains both a vectored return table and a direct entry point. All +entry points are the same: they rearrange the stack to match the Hugs +return convention (\secref{hugs-return-convention}) and return to the +scheduler. When the scheduler restarts the thread, it will find a BCO +on top of the stack and will enter the Hugs interpreter. + +\item [@UPD\_RET@]. + +This is just the standard info table for an update frame. + +\item [Constructors]. + +The entry code for a constructor jumps to a generic entry point in the +runtime system which decides whether to do a vectored or unvectored +return depending on the shape of the constructor/type. This implies that +info tables must have enough info to make that decision. + +\item [@AP@ and @PAP@]. + +\item [Indirections]. + +\item [Selectors]. + +Hugs doesn't generate them itself but it ought to recognise them + +\item [Complex primops]. + +Some of the primops are too complex for GHC to generate inline. +Instead, these primops are hand-written and called as normal functions. +Hugs only needs to know their names and types but doesn't care whether +they are generated by GHC or by hand. Two things to watch: + +\begin{enumerate} +\item +Hugs must be able to enter these primops even if it is working on a +standalone system that does not support genuine GHC generated code. + +\item The complex primops often involve unboxed tuple types (which +Hugs does not support at the source level) so we cannot specify their +types in a Haskell source file. + +\end{enumerate} + +\end{description} + +\Subsection{Hugs Heap Objects}{hugs-heap-objects} + +\subsubsection{Byte-code objects} + +Compiled byte code lives on the global heap, in objects called +Byte-Code Objects (or BCOs). The layout of BCOs is described in +detail in \secref{BCO}, in this section we will describe +their semantics. + +Since byte-code lives on the heap, it can be garbage collected just +like any other heap-resident data. Hugs arranges that any BCO's +referred to by the Hugs symbol tables are treated as live objects by +the garbage collector. When a module is unloaded, the pointers to its +BCOs are removed from the symbol table, and the code will be garbage +collected some time later. + +A BCO represents a basic block of code --- the (only) entry points is +at the beginning of a BCO, and it is impossible to jump into the +middle of one. A BCO represents not only the code for a function, but +also its closure; a BCO can be entered just like any other closure. +Hugs performs lambda-lifting during compilation to byte-code, and each +top-level combinator becomes a BCO in the heap. + + +\subsubsection{Thunks and partial applications} + +A thunk consists of a code pointer, and values for the free variables +of that code. Since Hugs byte-code is lambda-lifted, free variables +become arguments and are expected to be on the stack by the called +function. + +Hugs represents updateable thunks with @AP_UPD@ objects applying a closure +to a list of arguments. (As for @PAP@s, unboxed arguments should be +preceded by a tag.) When it is entered, it pushes an update frame +followed by its payload on the stack, and enters the first word (which +will be a pointer to a BCO). The layout of @AP_UPD@ objects is described +in more detail in \secref{AP_UPD}. + +Partial applications are represented by @PAP@ objects, which are +non-updatable. + +\ToDo{Hugs Constructors}. + +\Subsection{Calling conventions}{hugs-calling-conventions} + +The calling convention for any byte-code function is straightforward: +\begin{itemize} +\item Push any arguments on the stack. +\item Push a pointer to the BCO. +\item Begin interpreting the byte code. +\end{itemize} + +In a system containing both GHC and Hugs, the bytecode interpreter +only has to be able to enter BCOs: everything else can be handled by +returning to the compiled world (as described in +\secref{hugs-to-ghc-switch}) and entering the closure +there. + +This would work but it would obviously be very inefficient if we +entered a @AP@ by switching worlds, entering the @AP@, pushing the +arguments and function onto the stack, and entering the function +which, likely as not, will be a byte-code object which we will enter +by \emph{returning} to the byte-code interpreter. To avoid such +gratuitious world switching, we choose to recognise certain closure +types as being ``standard'' --- and duplicate the entry code for the +``standard closures'' in the bytecode interpreter. + +A closure is said to be ``standard'' if its entry code is entirely +determined by its info table. \emph{Standard Closures} have the +desirable property that the byte-code interpreter can enter the +closure by simply ``interpreting'' the info table instead of switching +to the compiled world. The standard closures include: + +\begin{description} +\item[Constructor] To enter a constructor, we simply return (see +\secref{hugs-return-convention}). + +\item[Indirection] +To enter an indirection, we simply enter the object it points to +after possibly adjusting the current cost centre. + +\item[@AP@] + +To enter an @AP@, we push an update frame, push the +arguments, push the function and enter the function. +(Not forgetting a stack check at the start.) + +\item[@PAP@] + +To enter a @PAP@, we push the arguments, push the function and enter +the function. (Not forgetting a stack check at the start.) + +\item[Selector] + +To enter a selector (\secref{THUNK_SELECTOR}), we test whether the +selectee is a value. If so, we simply select the appropriate +component; if not, it's simplest to treat it as a GHC-built closure +--- though we could interpret it if we wanted. + +\end{description} + +The most obvious omissions from the above list are @BCO@s (which we +dealt with above) and GHC-built closures (which are covered in +\secref{hugs-to-ghc-switch}). + + +\Subsection{Return convention}{hugs-return-convention} + +When Hugs pushes a return address, it pushes both a pointer to the BCO +to return to, and a pointer to a static code fragment @HUGS_RET@ (this +is described in \secref{ghc-to-hugs-switch}). The +stack layout is shown in \figref{hugs-return-stack}. + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| bco |--> BCO ++----------+ +| HUGS_RET | ++----------+ +\end{verbatim} +%\input{hugs_ret.pstex_t} +\end{center} +\caption{Stack layout for a Hugs return address} +\label{fig:hugs-return-stack} +% this figure apparently duplicates {fig:hugs-return-stack1} earlier. +\end{figure} + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| con |--> CON ++----------+ +\end{verbatim} +%\input{hugs_ret2.pstex_t} +\end{center} +\caption{Stack layout on enterings a Hugs return address} +\label{fig:hugs-return2} +\end{figure} + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| 3# | ++----------+ +| I# | ++----------+ +\end{verbatim} +%\input{hugs_ret2.pstex_t} +\end{center} +\caption{Stack layout on entering a Hugs return address with an unboxed value} +\label{fig:hugs-return-int1} +\end{figure} + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| ghc_ret | ++----------+ +| con |--> CON ++----------+ +\end{verbatim} +%\input{hugs_ret3.pstex_t} +\end{center} +\caption{Stack layout on enterings a GHC return address} +\label{fig:hugs-return3} +\end{figure} + +\begin{figure}[ht] +\begin{center} +\begin{verbatim} +| stack | ++----------+ +| ghc_ret | ++----------+ +| 3# | ++----------+ +| I# | ++----------+ +| restart |--> id_Int#_closure ++----------+ +\end{verbatim} +%\input{hugs_ret2.pstex_t} +\end{center} +\caption{Stack layout on enterings a GHC return address with an unboxed value} +\label{fig:hugs-return-int} +\end{figure} + +When a Hugs byte-code sequence enters a closure, it examines the +return address on top of the stack. + +\begin{itemize} + +\item If the return address is @HUGS_RET@, pop the @HUGS_RET@ and the +bco for the continuation off the stack, push a pointer to the constructor onto +the stack and enter the BCO with the current object pointer set to the BCO +(\figref{hugs-return2}). + +\item If the top of the stack is not @HUGS_RET@, we need to do a world +switch as described in \secref{hugs-to-ghc-switch}. + +\end{itemize} + +\ToDo{This duplicates what we say about switching worlds +(\secref{switching-worlds}) - kill one or t'other.} + + +\ToDo{This was in the evaluation model part but it really belongs in +this part which is about the internal details of each of the major +sections.} + +\Subsection{Addressing Modes}{hugs-addressing-modes} + +To avoid potential alignment problems and simplify garbage collection, +all literal constants are stored in two tables (one boxed, the other +unboxed) within each BCO and are referred to by offsets into the tables. +Slots in the constant tables are word aligned. + +\ToDo{How big can the offsets be? Is the offset specified in the +address field or in the instruction?} + +Literals can have the following types: char, int, nat, float, double, +and pointer to boxed object. There is no real difference between +char, int, nat and float since they all occupy 32 bits --- but it +costs almost nothing to distinguish them and may improve portability +and simplify debugging. + +\Subsection{Compilation}{hugs-compilation} + + +\def\is{\mbox{\it is}} +\def\ts{\mbox{\it ts}} +\def\as{\mbox{\it as}} +\def\bs{\mbox{\it bs}} +\def\cs{\mbox{\it cs}} +\def\rs{\mbox{\it rs}} +\def\us{\mbox{\it us}} +\def\vs{\mbox{\it vs}} +\def\ws{\mbox{\it ws}} +\def\xs{\mbox{\it xs}} + +\def\e{\mbox{\it e}} +\def\alts{\mbox{\it alts}} +\def\fail{\mbox{\it fail}} +\def\panic{\mbox{\it panic}} +\def\ua{\mbox{\it ua}} +\def\obj{\mbox{\it obj}} +\def\bco{\mbox{\it bco}} +\def\tag{\mbox{\it tag}} +\def\entry{\mbox{\it entry}} +\def\su{\mbox{\it su}} + +\def\Ind#1{{\mbox{\it Ind}\ {#1}}} +\def\update#1{{\mbox{\it update}\ {#1}}} + +\def\next{$\Longrightarrow$} +\def\append{\mathrel{+\mkern-6mu+}} +\def\reverse{\mbox{\it reverse}} +\def\size#1{{\vert {#1} \vert}} +\def\arity#1{{\mbox{\it arity}{#1}}} + +\def\AP{\mbox{\it AP}} +\def\PAP{\mbox{\it PAP}} +\def\GHCRET{\mbox{\it GHCRET}} +\def\GHCOBJ{\mbox{\it GHCOBJ}} + +To make sense of the instructions, we need a sense of how they will be +used. Here is a small compiler for the STG language. + +\begin{verbatim} +> cg (f{a1, ... am}) = do +> pushAtom am; ... pushAtom a1 +> pushVar f +> SLIDE (m+1) |env| +> ENTER +> cg (let {x1=rhs1; ... xm=rhsm} in e) = do +> ALLOC x1 |rhs1|, ... ALLOC xm |rhsm| +> build x1 rhs1, ... build xm rhsm +> cg e +> cg (case e of alts) = do +> PUSHALTS (cgAlts alts) +> cg e + +> cgAlts { alt1; ... altm } = cgAlt alt1 $ ... $ cgAlt altm pmFail +> +> cgAlt (x@C{xs} -> e) fail = do +> TEST C fail +> HEAPCHECK (heapUse e) +> UNPACK xs +> cg e + +> build x (C{a1, ... am}) = do +> pushUntaggedAtom am; ... pushUntaggedAtom a1 +> PACK x C +> -- A useful optimisation +> build x ({v1, ... vm} \ {}. f{a1, ... am}) = do +> pushVar am; ... pushVar a1 +> pushVar f +> MKAP x m +> build x ({v1, ... vm} \ {}. e) = do +> pushVar vm; ... pushVar v1 +> PUSHBCO (cgRhs ({v1, ... vm} \ {}. e)) +> MKAP x m +> build x ({v1, ... vm} \ {x1, ... xm}. e) = do +> pushVar vm; ... pushVar v1 +> PUSHBCO (cgRhs ({v1, ... vm} \ {x1, ... xm}. e)) +> MKPAP x m + +> cgRhs (vs \ xs. e) = do +> ARGCHECK (xs ++ vs) -- can be omitted if xs == {} +> STACKCHECK min(stackUse e,heapOverflowSlop) +> HEAPCHECK (heapUse e) +> cg e + +> pushAtom x = pushVar x +> pushAtom i# = PUSHINT i# + +> pushVar x = if isGlobalVar x then PUSHGLOBAL x else PUSHLOCAL x + +> pushUntaggedAtom x = pushVar x +> pushUntaggedAtom i# = PUSHUNTAGGEDINT i# + +> pushVar x = if isGlobalVar x then PUSHGLOBAL x else PUSHLOCAL x +\end{verbatim} + +\ToDo{Is there an easy way to add semi-tagging? Would it be that different?} + +\ToDo{Optimise thunks of the form @f{x1,...xm}@ so that we build an AP directly} + +\Subsection{Instructions}{hugs-instructions} + +We specify the semantics of instructions using transition rules of +the form: + +\begin{tabular}{|llrrrrr|} +\hline + & $\is$ & $s$ & $\su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is'$ & $s'$ & $\su'$ & $h'$ & $hp'$ & $\sigma$ \\ +\hline +\end{tabular} + +where $\is$ is an instruction stream, $s$ is the stack, $\su$ is the +update frame pointer and $h$ is the heap. + + +\Subsection{Stack manipulation}{hugs-stack-manipulation} + +\begin{description} + +\item[ Push a global variable ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHGLOBAL $o$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $\sigma!o:s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[ Push a local variable ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHLOCAL $o$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s!o : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[ Push an unboxed int ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHINT $o$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $I\# : \sigma!o : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +The $I\#$ is a tag included for the benefit of the garbage collector. +Similar rules exist for floats, doubles, chars, etc. + +\item[ Push an unboxed int ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHUNTAGGEDINT $o$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $\sigma!o : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +Similar rules exist for floats, doubles, chars, etc. + +\item[ Delete environment from stack --- ready for tail call ]. + +\begin{tabular}{|llrrrrr|} +\hline + & SLIDE $m$ $n$ : $\is$ & $\as \append \bs \append \cs$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $\as \append \cs$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $\size{\as} = m$ and $\size{\bs} = n$. + + +\item[ Push a return address ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHALTS $o$:$\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $@HUGS_RET@:\sigma!o:s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[ Push a BCO ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PUSHBCO $o$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $\sigma!o : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\end{description} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Subsection{Heap manipulation}{hugs-heap-manipulation} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{description} + +\item[ Allocate a heap object ]. + +\begin{tabular}{|llrrrrr|} +\hline + & ALLOC $m$ : $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $hp:s$ & $su$ & $h$ & $hp+m$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[ Build a constructor ]. + +\begin{tabular}{|llrrrrr|} +\hline + & PACK $o$ $o'$ : $\is$ & $\ws \append s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s$ & $su$ & $h[s!o \mapsto Pack C\{\ws\}]$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $C = \sigma!o'$ and $\size{\ws} = \arity{C}$. + +\item[ Build an AP or PAP ]. + +\begin{tabular}{|llrrrrr|} +\hline + & MKAP $o$ $m$:$\is$ & $f : \ws \append s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s$ & $su$ & $h[s!o \mapsto \AP(f,\ws)]$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $\size{\ws} = m$. + +\begin{tabular}{|llrrrrr|} +\hline + & MKPAP $o$ $m$:$\is$ & $f : \ws \append s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s$ & $su$ & $h[s!o \mapsto \PAP(f,\ws)]$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $\size{\ws} = m$. + +\item[ Unpacking a constructor ]. + +\begin{tabular}{|llrrrrr|} +\hline + & UNPACK : $is$ & $a : s$ & $su$ & $h[a \mapsto C\ \ws]$ & $hp$ & $\sigma$ \\ +\next & $is'$ & $(\reverse\ \ws) \append a : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +The $\reverse\ \ws$ looks expensive but, since the stack grows down +and the heap grows up, that's actually the cheap way of copying from +heap to stack. Looking at the compilation rules, you'll see that we +always push the args in reverse order. + +\end{description} + + +\Subsection{Entering a closure}{hugs-entering} + +\begin{description} + +\item[ Enter a BCO ]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : s$ & $su$ & $h[a \mapsto BCO\{\is\} ]$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $a : s$ & $su$ & $h$ & $hp$ & $a$ \\ +\hline +\end{tabular} + +\item[ Enter a PAP closure ]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : s$ & $su$ & $h[a \mapsto \PAP(f,\ws)]$ & $hp$ & $\sigma$ \\ +\next & [ENTER] & $f : \ws \append s$ & $su$ & $h$ & $hp$ & $???$ \\ +\hline +\end{tabular} + +\item[ Entering an AP closure ]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : s$ & $su$ & $h[a \mapsto \AP(f,ws)]$ & $hp$ & $\sigma$ \\ +\next & [ENTER] & $f : \ws \append @UPD_RET@:\su:a:s$ & $su'$ & $h$ & $hp$ & $???$ \\ +\hline +\end{tabular} + +Optimisations: +\begin{itemize} +\item Instead of blindly pushing an update frame for $a$, we can first test whether there's already + an update frame there. If so, overwrite the existing updatee with an indirection to $a$ and + overwrite the updatee field with $a$. (Overwriting $a$ with an indirection to the updatee also + works.) This results in update chains of maximum length 2. +\end{itemize} + + +\item[ Returning a constructor ]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : @HUGS_RET@ : \alts : s$ & $su$ & $h[a \mapsto C\{\ws\}]$ & $hp$ & $\sigma$ \\ +\next & $\alts.\entry$ & $a:s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + + +\item[ Entering an indirection node ]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : s$ & $su$ & $h[a \mapsto \Ind{a'}]$ & $hp$ & $\sigma$ \\ +\next & [ENTER] & $a' : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[Entering GHC closure]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : s$ & $su$ & $h[a \mapsto \GHCOBJ]$ & $hp$ & $\sigma$ \\ +\next & [ENTERGHC] & $a : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[Returning a constructor to GHC]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : \GHCRET : s$ & $su$ & $h[a \mapsto C \ws]$ & $hp$ & $\sigma$ \\ +\next & [ENTERGHC] & $a : \GHCRET : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\end{description} + + +\Subsection{Updates}{hugs-updates} + +\begin{description} + +\item[ Updating with a constructor]. + +\begin{tabular}{|llrrrrr|} +\hline + & [ENTER] & $a : @UPD_RET@ : ua : s$ & $su$ & $h[a \mapsto C\{\ws\}]$ & $hp$ & $\sigma$ \\ +\next & [ENTER] & $a \append s$ & $su$ & $h[au \mapsto \Ind{a}$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} + +\item[ Argument checks]. + +\begin{tabular}{|llrrrrr|} +\hline + & ARGCHECK $m$:$\is$ & $a : \as \append s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $a : \as \append s$ & $su$ & $h'$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $m \ge (su - sp)$ + +\begin{tabular}{|llrrrrr|} +\hline + & ARGCHECK $m$:$\is$ & $a : \as \append @UPD_RET@:su:ua:s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $a : \as \append s$ & $su$ & $h'$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $m < (su - sp)$ and + $h' = h[ua \mapsto \Ind{a'}, a' \mapsto \PAP(a,\reverse\ \as) ]$ + +Again, we reverse the list of values as we transfer them from the +stack to the heap --- reflecting the fact that the stack and heap grow +in different directions. + +\end{description} + +\Subsection{Branches}{hugs-branches} + +\begin{description} + +\item[ Testing a constructor ]. + +\begin{tabular}{|llrrrrr|} +\hline + & TEST $tag$ $is'$ : $is$ & $a : s$ & $su$ & $h[a \mapsto C\ \ws]$ & $hp$ & $\sigma$ \\ +\next & $is$ & $a : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $C.\tag = tag$ + +\begin{tabular}{|llrrrrr|} +\hline + & TEST $tag$ $is'$ : $is$ & $a : s$ & $su$ & $h[a \mapsto C\ \ws]$ & $hp$ & $\sigma$ \\ +\next & $is'$ & $a : s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +where $C.\tag \neq tag$ + +\end{description} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Subsection{Heap and stack checks}{hugs-heap-stack-checks} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{tabular}{|llrrrrr|} +\hline + & STACKCHECK $stk$:$\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +if $s$ has $stk$ free slots. + +\begin{tabular}{|llrrrrr|} +\hline + & HEAPCHECK $hp$:$\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\next & $\is$ & $s$ & $su$ & $h$ & $hp$ & $\sigma$ \\ +\hline +\end{tabular} +\\ +if $h$ has $hp$ free slots. + +If either check fails, we push the current bco ($\sigma$) onto the +stack and return to the scheduler. When the scheduler has fixed the +problem, it pops the top object off the stack and reenters it. + + +Optimisations: +\begin{itemize} +\item The bytecode CHECK1000 conservatively checks for 1000 words of heap space and 1000 words of stack space. + We use it to reduce code space and instruction decoding time. +\item The bytecode HEAPCHECK1000 conservatively checks for 1000 words of heap space. + It is used in case alternatives. +\end{itemize} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Subsection{Primops}{hugs-primops} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\ToDo{primops take m words and return n words. The expect boxed arguments on the stack.} + + +\Section{The Machine Code Evaluator}{asm-evaluator} + +This section describes the framework in which compiled code evaluates +expressions. Only at certain points will compiled code need to be +able to talk to the interpreted world; these are discussed in +\secref{switching-worlds}. + +\Subsection{Calling conventions}{ghc-calling-conventions} + +\Subsubsection{The call/return registers}{ghc-regs} + +One of the problems in designing a virtual machine is that we want it +abstract away from tedious machine details but still reveal enough of +the underlying hardware that we can make sensible decisions about code +generation. A major problem area is the use of registers in +call/return conventions. On a machine with lots of registers, it's +cheaper to pass arguments and results in registers than to pass them +on the stack. On a machine with very few registers, it's cheaper to +pass arguments and results on the stack than to use ``virtual +registers'' in memory. We therefore use a hybrid system: the first +$n$ arguments or results are passed in registers; and the remaining +arguments or results are passed on the stack. For register-poor +architectures, it is important that we allow $n=0$. + +We'll label the arguments and results \Arg{1} \ldots \Arg{m} --- with +the understanding that \Arg{1} \ldots \Arg{n} are in registers and +\Arg{n+1} \ldots \Arg{m} are on top of the stack. + +Note that the mapping of arguments \Arg{1} \ldots \Arg{n} to machine +registers depends on the \emph{kinds} of the arguments. For example, +if the first argument is a Float, we might pass it in a different +register from if it is an Int. In fact, we might find that a given +architecture lets us pass varying numbers of arguments according to +their types. For example, if a CPU has 2 Int registers and 2 Float +registers then we could pass between 2 and 4 arguments in machine +registers --- depending on whether they all have the same kind or they +have different kinds. + +\Subsubsection{Entering closures}{entering-closures} + +To evaluate a closure we jump to the entry code for the closure +passing a pointer to the closure in \Arg{1} so that the entry code can +access its environment. + +\Subsubsection{Function call}{ghc-fun-call} + +The function-call mechanism is obviously crucial. There are five different +cases to consider: +\begin{enumerate} + +\item \emph{Known combinator (function with no free variables) and +enough arguments.} + +A fast call can be made: push excess arguments onto stack and jump to +function's \emph{fast entry point} passing arguments in \Arg{1} \ldots +\Arg{m}. + +The \emph{fast entry point} is only called with exactly the right +number of arguments (in \Arg{1} \ldots \Arg{m}) so it can instantly +start doing useful work without first testing whether it has enough +registers or having to pop them off the stack first. + +\item \emph{Known combinator and insufficient arguments.} + +A slow call can be made: push all arguments onto stack and jump to +function's \emph{slow entry point}. + +Any unpointed arguments which are pushed on the stack must be tagged. +This means pushing an extra word on the stack below the unpointed +words, containing the number of unpointed words above it. + +%Todo: forward ref about tagging? +%Todo: picture? + +The \emph{slow entry point} might be called with insufficient arguments +and so it must test whether there are enough arguments on the stack. +This \emph{argument satisfaction check} consists of checking that +@Su-Sp@ is big enough to hold all the arguments (including any tags). + +\begin{itemize} + +\item If the argument satisfaction check fails, it is because there is +one or more update frames on the stack before the rest of the +arguments that the function needs. In this case, we construct a PAP +(partial application, \secref{PAP}) containing the arguments +which are on the stack. The PAP construction code will return to the +update frame with the address of the PAP in \Arg{1}. + +\item If the argument satisfaction check succeeds, we jump to the fast +entry point with the arguments in \Arg{1} \ldots \Arg{arity}. + +If the fast entry point expects to receive some of \Arg{i} on the +stack, we can reduce the amount of movement required by making the +stack layout for the fast entry point look like the stack layout for +the slow entry point. Since the slow entry point is entered with the +first argument on the top of the stack and with tags in front of any +unpointed arguments, this means that if \Arg{i} is unpointed, there +should be space below it for a tag and that the highest numbered +argument should be passed on the top of the stack. + +We usually arrange that the fast entry point is placed immediately +after the slow entry point --- so we can just ``fall through'' to the +fast entry point without performing a jump. + +\end{itemize} + + +\item \emph{Known function closure (function with free variables) and +enough arguments.} + +A fast call can be made: push excess arguments onto stack and jump to +function's \emph{fast entry point} passing a pointer to closure in +\Arg{1} and arguments in \Arg{2} \ldots \Arg{m+1}. + +Like the fast entry point for a combinator, the fast entry point for a +closure is only called with appropriate values in \Arg{1} \ldots +\Arg{m+1} so we can start work straight away. The pointer to the +closure is used to access the free variables of the closure. + + +\item \emph{Known function closure and insufficient arguments.} + +A slow call can be made: push all arguments onto stack and jump to the +closure's slow entry point passing a pointer to the closure in \Arg{1}. + +Again, the slow entry point performs an argument satisfaction check +and either builds a PAP or pops the arguments off the stack into +\Arg{2} \ldots \Arg{m+1} and jumps to the fast entry point. + + +\item \emph{Unknown function closure, thunk or constructor.} + +Sometimes, the function being called is not statically identifiable. +Consider, for example, the @compose@ function: +\begin{verbatim} + compose f g x = f (g x) +\end{verbatim} +Since @f@ and @g@ are passed as arguments to @compose@, the latter has +to make a heap call. In a heap call the arguments are pushed onto the +stack, and the closure bound to the function is entered. In the +example, a thunk for @(g x)@ will be allocated, (a pointer to it) +pushed on the stack, and the closure bound to @f@ will be +entered. That is, we will jump to @f@s entry point passing @f@ in +\Arg{1}. If \Arg{1} is passed on the stack, it is pushed on top of +the thunk for @(g x)@. + +The \emph{entry code} for an updateable thunk (which must have arity 0) +pushes an update frame on the stack and starts executing the body of +the closure --- using \Arg{1} to access any free variables. This is +described in more detail in \secref{data-updates}. + +The \emph{entry code} for a non-updateable closure is just the +closure's slow entry point. + +\end{enumerate} + +In addition to the above considerations, if there are \emph{too many} +arguments then the extra arguments are simply pushed on the stack with +appropriate tags. + +To summarise, a closure's standard (slow) entry point performs the +following: + +\begin{description} +\item[Argument satisfaction check.] (function closure only) +\item[Stack overflow check.] +\item[Heap overflow check.] +\item[Copy free variables out of closure.] %Todo: why? +\item[Eager black holing.] (updateable thunk only) %Todo: forward ref. +\item[Push update frame.] +\item[Evaluate body of closure.] +\end{description} + + +\Subsection{Case expressions and return conventions}{return-conventions} + +The \emph{evaluation} of a thunk is always initiated by +a @case@ expression. For example: +\begin{verbatim} + case x of (a,b) -> E +\end{verbatim} + +The code for a @case@ expression looks like this: + +\begin{itemize} +\item Push the free variables of the branches on the stack (fv(@E@) in +this case). +\item Push a \emph{return address} on the stack. +\item Evaluate the scrutinee (@x@ in this case). +\end{itemize} + +Once evaluation of the scrutinee is complete, execution resumes at the +return address, which points to the code for the expression @E@. + +When execution resumes at the return point, there must be some {\em +return convention} that defines where the components of the pair, @a@ +and @b@, can be found. The return convention varies according to the +type of the scrutinee @x@: + +\begin{itemize} + +\item + +(A space for) the return address is left on the top of the stack. +Leaving the return address on the stack ensures that the top of the +stack contains a valid activation record +(\secref{activation-records}) --- should a garbage +collection be required. + +\item If @x@ has a boxed type (e.g.~a data constructor or a function), +a pointer to @x@ is returned in \Arg{1}. + +\ToDo{Warn that components of E should be extracted as soon as +possible to avoid a space leak.} + +\item If @x@ is an unboxed type (e.g.~@Int#@ or @Float#@), @x@ is +returned in \Arg{1} + +\item If @x@ is an unboxed tuple constructor, the components of @x@ +are returned in \Arg{1} \ldots \Arg{n} but no object is constructed in +the heap. + +When passing an unboxed tuple to a function, the components are +flattened out and passed in \Arg{1} \ldots \Arg{n} as usual. + +\end{itemize} + +\Subsection{Vectored Returns}{vectored-returns} + +Many algebraic data types have more than one constructor. For +example, the @Maybe@ type is defined like this: +\begin{verbatim} + data Maybe a = Nothing | Just a +\end{verbatim} +How does the return convention encode which of the two constructors is +being returned? A @case@ expression scrutinising a value of @Maybe@ +type would look like this: +\begin{verbatim} + case E of + Nothing -> ... + Just a -> ... +\end{verbatim} +Rather than pushing a return address before evaluating the scrutinee, +@E@, the @case@ expression pushes (a pointer to) a \emph{return +vector}, a static table consisting of two code pointers: one for the +@Just@ alternative, and one for the @Nothing@ alternative. + +\begin{itemize} + +\item + +The constructor @Nothing@ returns by jumping to the first item in the +return vector with a pointer to a (statically built) Nothing closure +in \Arg{1}. + +It might seem that we could avoid loading \Arg{1} in this case since the +first item in the return vector will know that @Nothing@ was returned +(and can easily access the Nothing closure in the (unlikely) event +that it needs it. The only reason we load \Arg{1} is in case we have to +perform an update (\secref{data-updates}). + +\item + +The constructor @Just@ returns by jumping to the second element of the +return vector with a pointer to the closure in \Arg{1}. + +\end{itemize} + +In this way no test need be made to see which constructor returns; +instead, execution resumes immediately in the appropriate branch of +the @case@. + +\Subsection{Direct Returns}{direct-returns} + +When a datatype has a large number of constructors, it may be +inappropriate to use vectored returns. The vector tables may be +large and sparse, and it may be better to identify the constructor +using a test-and-branch sequence on the tag. For this reason, we +provide an alternative return convention, called a \emph{direct +return}. + +In a direct return, the return address pushed on the stack really is a +code pointer. The returning code loads a pointer to the closure being +returned in \Arg{1} as usual, and also loads the tag into \Arg{2}. +The code at the return address will test the tag and jump to the +appropriate code for the case branch. If \Arg{2} isn't mapped to a +real machine register on this architecture, then we don't load it on a +return, instead using the tag directly from the info table. + +The choice of whether to use a vectored return or a direct return is +made on a type-by-type basis --- up to a certain maximum number of +constructors imposed by the update mechanism +(\secref{data-updates}). + +Single-constructor data types also use direct returns, although in +that case there is no need to return a tag in \Arg{2}. + +\ToDo{for a nullary constructor we needn't return a pointer to the +constructor in \Arg{1}.} + +\Subsection{Updates}{data-updates} + +The entry code for an updatable thunk (which must be of arity 0): + +\begin{itemize} +\item copies the free variables out of the thunk into registers or + onto the stack. +\item pushes an \emph{update frame} onto the stack. + +An update frame is a small activation record consisting of +\begin{center} +\begin{tabular}{|l|l|l|} +\hline +\emph{Fixed header} & \emph{Update Frame link} & \emph{Updatee} \\ +\hline +\end{tabular} +\end{center} + +\note{In the semantics part of the STG paper (section 5.6), an update +frame consists of everything down to the last update frame on the +stack. This would make sense too --- and would fit in nicely with +what we're going to do when we add support for speculative +evaluation.} +\ToDo{I think update frames contain cost centres sometimes} + +\item If we are doing ``eager blackholing,'' we then overwrite the +thunk with a black hole (\secref{BLACKHOLE}). Otherwise, we leave it +to the garbage collector to black hole the thunk. + +\item +Start evaluating the body of the expression. + +\end{itemize} + +When the expression finishes evaluation, it will enter the update +frame on the top of the stack. Since the returner doesn't know +whether it is entering a normal return address/vector or an update +frame, we follow exactly the same conventions as return addresses and +return vectors. That is, on entering the update frame: + +\begin{itemize} +\item The value of the thunk is in \Arg{1}. (Recall that only thunks +are updateable and that thunks return just one value.) + +\item If the data type is a direct-return type rather than a +vectored-return type, then the tag is in \Arg{2}. + +\item The update frame is still on the stack. +\end{itemize} + +We can safely share a single statically-compiled update function +between all types. However, the code must be able to handle both +vectored and direct-return datatypes. This is done by arranging that +the update code looks like this: + +\begin{verbatim} + | ^ | + | return vector | + |---------------| + | fixed-size | + | info table | + |---------------| <- update code pointer + | update code | + | v | +\end{verbatim} + +Each entry in the return vector (which is large enough to cover the +largest vectored-return type) points to the update code. + +The update code: +\begin{itemize} +\item overwrites the \emph{updatee} with an indirection to \Arg{1}; +\item loads @Su@ from the Update Frame link; +\item removes the update frame from the stack; and +\item enters \Arg{1}. +\end{itemize} + +We enter \Arg{1} again, having probably just come from there, because +it knows whether to perform a direct or vectored return. This could +be optimised by compiling special update code for each slot in the +return vector, which performs the correct return. + +\Subsection{Semi-tagging}{semi-tagging} + +When a @case@ expression evaluates a variable that might be bound +to a thunk it is often the case that the scrutinee is already evaluated. +In this case we have paid the penalty of (a) pushing the return address (or +return vector address) on the stack, (b) jumping through the info pointer +of the scrutinee, and (c) returning by an indirect jump through the +return address on the stack. + +If we knew that the scrutinee was already evaluated we could generate +(better) code which simply jumps to the appropriate branch of the +@case@ with a pointer to the scrutinee in \Arg{1}. (For direct +returns to multiconstructor datatypes, we might also load the tag into +\Arg{2}). + +An obvious idea, therefore, is to test dynamically whether the heap +closure is a value (using the tag in the info table). If not, we +enter the closure as usual; if so, we jump straight to the appropriate +alternative. Here, for example, is pseudo-code for the expression +@(case x of { (a,_,c) -> E }@: +\begin{verbatim} + \Arg{1} = ; + tag = \Arg{1}->entry->tag; + if (isWHNF(tag)) { + Sp--; \\ insert space for return address + goto ret; + } + push(ret); + goto \Arg{1}->entry; + + +ret: a = \Arg{1}->data1; \\ suck out a and c to avoid space leak + c = \Arg{1}->data3; + +\end{verbatim} +and here is the code for the expression @(case x of { [] -> E1; x:xs -> E2 }@: +\begin{verbatim} + \Arg{1} = ; + tag = \Arg{1}->entry->tag; + if (isWHNF(tag)) { + Sp--; \\ insert space for return address + goto retvec[tag]; + } + push(retinfo); + goto \Arg{1}->entry; + + .addr ret2 + .addr ret1 +retvec: \\ reversed return vector + +retinfo: + panic("Direct return into vectored case"); + +ret1: + +ret2: x = \Arg{1}->head; + xs = \Arg{1}->tail; + +\end{verbatim} +There is an obvious cost in compiled code size (but none in the size +of the bytecodes). There is also a cost in execution time if we enter +more thunks than data constructors. + +Both the direct and vectored returns are easily modified to chase chains +of indirections too. In the vectored case, this is most easily done by +making sure that @IND = TAG_1 - 1@, and adding an extra field to every +return vector. In the above example, the indirection code would be +\begin{verbatim} +ind: \Arg{1} = \Arg{1}->next; + goto ind_loop; +\end{verbatim} +where @ind_loop@ is the second line of code. + +Note that we have to leave space for a return address since the return +address expects to find one. If the body of the expression requires a +heap check, we will actually have to write the return address before +entering the garbage collector. + + +\Subsection{Heap and Stack Checks}{heap-and-stack-checks} + +The storage manager detects that it needs to garbage collect the old +generation when the evaluator requests a garbage collection without +having moved the heap pointer since the last garbage collection. It +is therefore important that the GC routines \emph{not} move the heap +pointer unless the heap check fails. This is different from what +happens in the current STG implementation. + +Assuming that the stack can never shrink, we perform a stack check +when we enter a closure but not when we return to a return +continuation. This doesn't work for heap checks because we cannot +predict what will happen to the heap if we call a function. + +If we wish to allow the stack to shrink, we need to perform a stack +check whenever we enter a return continuation. Most of these checks +could be eliminated if the storage manager guaranteed that a stack +would always have 1000 words (say) of space after it was shrunk. Then +we can omit stack checks for less than 1000 words in return +continuations. + +When an argument satisfaction check fails, we need to push the closure +(in R1) onto the stack - so we need to perform a stack check. The +problem is that the argument satisfaction check occurs \emph{before} +the stack check. The solution is that the caller of a slow entry +point or closure will guarantee that there is at least one word free +on the stack for the callee to use. + +Similarily, if a heap or stack check fails, we need to push the arguments +and closure onto the stack. If we just came from the slow entry point, +there's certainly enough space and it is the responsibility of anyone +using the fast entry point to guarantee that there is enough space. + +\ToDo{Be more precise about how much space is required - document it +in the calling convention section.} + +\Subsection{Handling interrupts/signals}{signals} + +\begin{verbatim} +May have to keep C stack pointer in register to placate OS? +May have to revert black holes - ouch! +\end{verbatim} + + + +\section{The Loader} +\section{The Compilers} + +\iffalse +\part{Old stuff - needs to be mined for useful info} + +\section{The Scheduler} + +The Scheduler is the heart of the run-time system. A running program +consists of a single running thread, and a list of runnable and +blocked threads. The running thread returns to the scheduler when any +of the following conditions arises: + +\begin{itemize} +\item A heap check fails, and a garbage collection is required +\item Compiled code needs to switch to interpreted code, and vice +versa. +\item The thread becomes blocked. +\item The thread is preempted. +\end{itemize} + +A running system has a global state, consisting of + +\begin{itemize} +\item @Hp@, the current heap pointer, which points to the next +available address in the Heap. +\item @HpLim@, the heap limit pointer, which points to the end of the +heap. +\item The Thread Preemption Flag, which is set whenever the currently +running thread should be preempted at the next opportunity. +\item A list of runnable threads. +\item A list of blocked threads. +\end{itemize} + +Each thread is represented by a Thread State Object (TSO), which is +described in detail in \secref{TSO}. + +The following is pseudo-code for the inner loop of the scheduler +itself. + +\begin{verbatim} +while (threads_exist) { + // handle global problems: GC, parallelism, etc + if (need_gc) gc(); + if (external_message) service_message(); + // deal with other urgent stuff + + pick a runnable thread; + do { + // enter object on top of stack + // if the top object is a BCO, we must enter it + // otherwise appply any heuristic we wish. + if (thread->stack[thread->sp]->info.type == BCO) { + status = runHugs(thread,&smInfo); + } else { + status = runGHC(thread,&smInfo); + } + switch (status) { // handle local problems + case (StackOverflow): enlargeStack; break; + case (Error e) : error(thread,e); break; + case (ExitWith e) : exit(e); break; + case (Yield) : break; + } + } while (thread_runnable); +} +\end{verbatim} + +\Subsection{Invoking the garbage collector}{ghc-invoking-gc} + +\Subsection{Putting the thread to sleep}{ghc-thread-sleeps} + +\Subsection{Calling C from Haskell}{ghc-ccall} + +We distinguish between "safe calls" where the programmer guarantees +that the C function will not call a Haskell function or, in a +multithreaded system, block for a long period of time and "unsafe +calls" where the programmer cannot make that guarantee. + +Safe calls are performed without returning to the scheduler and are +discussed elsewhere (\ToDo{discuss elsewhere}). + +Unsafe calls are performed by returning an array (outside the Haskell +heap) of arguments and a C function pointer to the scheduler. The +scheduler allocates a new thread from the operating system +(multithreaded system only), spawns a call to the function and +continues executing another thread. When the ccall completes, the +thread informs the scheduler and the scheduler adds the thread to the +runnable threads list. + +\ToDo{Describe this in more detail.} + + +\Subsection{Calling Haskell from C}{ghc-c-calls-haskell} + +When C calls a Haskell closure, it sends a message to the scheduler +thread. On receiving the message, the scheduler creates a new Haskell +thread, pushes the arguments to the C function onto the thread's stack +(with tags for unboxed arguments) pushes the Haskell closure and adds +the thread to the runnable list so that it can be entered in the +normal way. + +When the closure returns, the scheduler sends back a message which +awakens the (C) thread. + +\ToDo{Do we need to worry about the garbage collector deallocating the +thread if it gets blocked?} + +\Subsection{Switching Worlds}{switching-worlds} + +\ToDo{This has all changed: we always leave a closure on top of the +stack if we mean to continue executing it. The scheduler examines the +top of the stack and tries to guess which world we want to be in. If +it finds a @BCO@, it certainly enters Hugs, if it finds a @GHC@ +closure, it certainly enters GHC and if it finds a standard closure, +it is free to choose either one but it's probably best to enter GHC +for everything except @BCO@s and perhaps @AP@s.} + +Because this is a combined compiled/interpreted system, the +interpreter will sometimes encounter compiled code, and vice-versa. + +All world-switches go via the scheduler, ensuring that the world is in +a known state ready to enter either compiled code or the interpreter. +When a thread is run from the scheduler, the @whatNext@ field in the +TSO (\secref{TSO}) is checked to find out how to execute the +thread. + +\begin{itemize} +\item If @whatNext@ is set to @ReturnGHC@, we load up the required +registers from the TSO and jump to the address at the top of the user +stack. +\item If @whatNext@ is set to @EnterGHC@, we load up the required +registers from the TSO and enter the closure pointed to by the top +word of the stack. +\item If @whatNext@ is set to @EnterHugs@, we enter the top thing on +the stack, using the interpreter. +\end{itemize} + +There are four cases we need to consider: + +\begin{enumerate} +\item A GHC thread enters a Hugs-built closure. +\item A GHC thread returns to a Hugs-compiled return address. +\item A Hugs thread enters a GHC-built closure. +\item A Hugs thread returns to a Hugs-compiled return address. +\end{enumerate} + +GHC-compiled modules cannot call functions in a Hugs-compiled module +directly, because the compiler has no information about arities in the +external module. Therefore it must assume any top-level objects are +CAFs, and enter their closures. + +\ToDo{Hugs-built constructors?} + +We now examine the various cases one by one and describe how the +switch happens in each situation. + +\subsection{A GHC thread enters a Hugs-built closure} +\label{sec:ghc-to-hugs-switch} + +There is three possibilities: GHC has entered a @PAP@, or it has +entered a @AP@, or it has entered the BCO directly (for a top-level +function closure). @AP@s and @PAP@s are ``standard closures'' and +so do not require us to enter the bytecode interpreter. + +The entry code for a BCO does the following: + +\begin{itemize} +\item Push the address of the object entered on the stack. +\item Save the current state of the thread in its TSO. +\item Return to the scheduler, setting @whatNext@ to @EnterHugs@. +\end{itemize} + +BCO's for thunks and functions have the same entry conventions as +slow entry points: they expect to find their arguments on the stac +with unboxed arguments preceded by appropriate tags. + +\subsection{A GHC thread returns to a Hugs-compiled return address} +\label{sec:ghc-to-hugs-switch} + +Hugs return addresses are laid out as in \figref{hugs-return-stack}. +If GHC is returning, it will return to the address at the top of the +stack, namely @HUGS_RET@. The code at @HUGS_RET@ performs the +following: + +\begin{itemize} +\item pushes \Arg{1} (the return value) on the stack. +\item saves the thread state in the TSO +\item returns to the scheduler with @whatNext@ set to @EnterHugs@. +\end{itemize} + +\noindent When Hugs runs, it will enter the return value, which will +return using the correct Hugs convention +(\secref{hugs-return-convention}) to the return address underneath it +on the stack. + +\subsection{A Hugs thread enters a GHC-compiled closure} +\label{sec:hugs-to-ghc-switch} + +Hugs can recognise a GHC-built closure as not being one of the +following types of object: + +\begin{itemize} +\item A @BCO@, +\item A @AP@, +\item A @PAP@, +\item An indirection, or +\item A constructor. +\end{itemize} + +When Hugs is called on to enter a GHC closure, it executes the +following sequence of instructions: + +\begin{itemize} +\item Push the address of the closure on the stack. +\item Save the current state of the thread in the TSO. +\item Return to the scheduler, with the @whatNext@ field set to +@EnterGHC@. +\end{itemize} + +\subsection{A Hugs thread returns to a GHC-compiled return address} +\label{sec:hugs-to-ghc-switch} + +When Hugs encounters a return address on the stack that is not +@HUGS_RET@, it knows that a world-switch is required. At this point +the stack contains a pointer to the return value, followed by the GHC +return address. The following sequence is then performed: + +\begin{itemize} +\item save the state of the thread in the TSO. +\item return to the scheduler, setting @whatNext@ to @EnterGHC@. +\end{itemize} + +The first thing that GHC will do is enter the object on the top of the +stack, which is a pointer to the return value. This value will then +return itself to the return address using the GHC return convention. + + +\fi + + +\part{History} + +We're nuking the following: + +\begin{itemize} +\item + Two stacks + +\item + Return in registers. + This lets us remove update code pointers from info tables, + removes the need for phantom info tables, simplifies + semi-tagging, etc. + +\item + Threaded GC. + Careful analysis suggests that it doesn't buy us very much + and it is hard to work with. + + Eliminating threaded GCs eliminates the desire to share SMReps + so they are (once more) part of the Info table. + +\item + RetReg. + Doesn't buy us anything on a register-poor architecture and + isn't so important if we have semi-tagging. + +\begin{verbatim} + - Probably bad on register poor architecture + - Can avoid need to write return address to stack on reg rich arch. + - when a function does a small amount of work, doesn't + enter any other thunks and then returns. + eg entering a known constructor (but semitagging will catch this) + - Adds complications +\end{verbatim} + +\item + Update in place + + This lets us drop CONST closures and CHARLIKE closures (assuming we + don't support Unicode). The only point of these closures was to + avoid updating with an indirection. + + We also drop @MIN_UPD_SIZE@ --- all we need is space to insert an + indirection or a black hole. + +\item + STATIC SMReps are now called CONST + +\item + @MUTVAR@ is new + +\item The profiling ``kind'' field is now encoded in the @INFO_TYPE@ field. +This identifies the general sort of the closure for profiling purposes. + +\item Various papers describe deleting update frames for unreachable objects. + This has never been implemented and we don't plan to anytime soon. + +\end{itemize} + + +\end{document} + + diff --git a/docs/stg-spec/fast-curry.rkt b/docs/stg-spec/fast-curry.rkt new file mode 100644 index 00000000..df4d3abc --- /dev/null +++ b/docs/stg-spec/fast-curry.rkt @@ -0,0 +1,247 @@ +#lang racket +(require redex) + +; An STG-like language as described in +; "Making a Fast Curry: Push/Enter vs. Eval/Apply for Higher-order Languages" +; Only lightly-tested. + +; A list of differences from STG proper: +; * Right-hand sides of let-bindings have different syntax +; * Let-binding is not recursive +; * Missing semantics for top-level bindings +; * Missing semantics for primops, e.g. +; * Exceptions +; * Concurrency +; * STM +; * Missing let-no-escape +; * Missing IND (for heap indirections after thunk evaluation) + +; Some other things that these semantics might want to capture +; * Selector thunks +; * Pointer tagging +; * Stack chunks / STACK_AP +; * CAFs + +; Useful sanity checks: +; * Formalize Core (with typing), define translation to STG, test for +; progress given that Core type-checks + +(define-language L + ((x y z f g h) variable-not-otherwise-mentioned) + (C variable-not-otherwise-mentioned) + (n integer) + (lit integer + real) + ((a v) x + lit) + (k • ; unknown arity + n) + (e a + (f k a ...) + (⊕ a ...) ; saturated + (let (x obj) e) + (case e alt ...) + ) + (alt ((C x ...) e) + ((x) e)) + (obj val + (THUNK e) + BLACKHOLE) + (val (FUN (x ...) e) + (PAP f a ...) + (CON C a ...)) ; saturated + ) + +(define-extended-language Ev L + (p (e s H)) + (H ((x_!_ obj) ...)) + (κ (case • alt ...) + (upd x •) + (• a ...)) + (s (κ ...)) + ) + +; use the tutorial substitution +(require redex/tut-subst) +(define-metafunction Ev + subst : (x v) ... e -> e + [(subst (x v) ... e) + ,(subst/proc x? + (term (x ...)) + (term (v ...)) + (term e))]) +(define x? (redex-match Ev x)) + +; We need to do some negative matches, a metafunction will be easiest +(define-metafunction Ev [(lit? e) ,(redex-match? Ev lit (term e))]) +(define-metafunction + Ev + [(heapval? e H) + ,(redex-match Ev + (x_i ((x_0 obj_0) ... (x_i val_i) (x_i+1 obj_i+1) ...)) + (term (e H))) + ]) + +; eval/apply reduction semantics +(define red + (reduction-relation + Ev + #:domain p + (--> ((let (x obj) e) s ((x_1 obj_1) ...)) + ((subst (x x_0) e) s ((x_0 obj) (x_1 obj_1) ...)) + (fresh x_0) + "Let") + (--> ((case x_i alt_0 ... ((C_i y_i ..._i_) e_i) alt_i+1 ...) s H) + ((subst (y_i a_i) ... e_i) s H) + (where ((x_0 obj_0) ... (x_i (CON C_i a_i ..._i_)) (x_i+1 obj_i+1) ...) H) + "CaseCon") + (--> ((case x_i alt ... ((x) e)) s H) + ((subst (x x_i) e) s H) + (where ((x_0 obj_0) ... (x_i val_i) (x_i+1 obj_i+1) ...) H) + (side-condition ; this terri-bad side condition + (not (redex-match ; NB: not redex-match? which is buggy + Ev + ((CON C_i a_i ...) alt_0 ... ((C_i y_i ...) e_i) alt_i+1 ...) + (term (val_i alt ...))))) + "CaseAnyHeap") + (--> ((case lit alt ... ((x) e)) s H) + ((subst (x lit) e) s H) + "CaseAnyLit") + ; I kind of like the original presentation, where we have an execution + ; code that tells us whether or not we need to enter the scrutinee + (--> ((case e alt ...) (κ ...) H) + (e ((case • alt ...) κ ...) H) + (where #f (lit? e)) + (where #f (heapval? e H)) + "Case") + (--> (lit ((case • alt ...) κ ...) H) + ((case lit alt ...) (κ ...) H) + "RetLit") + (--> (x_i ((case • alt ...) κ ...) H) + ((case x_i alt ...) (κ ...) H) + (where ((x_0 obj_0) ... (x_i val_i) (x_i+1 obj_i+1) ...) H) + "Ret") + (--> (x_i s + ((x_0 obj_0) ... (x_i (THUNK e)) (x_i+1 obj_i+1) ...)) + (e ((upd x_i •) ,@(term s)) ; nifty idiom for splicing in + ((x_0 obj_0) ... (x_i BLACKHOLE) (x_i+1 obj_i+1) ...)) + "Thunk") + (--> (y_j ((upd x_i •) κ ...) H) + (y_j (κ ...) ((x_0 obj_x0) ... (x_i val_j) (x_i+1 obj_i+1) ...)) + (where ((x_0 obj_x0) ... (x_i BLACKHOLE) (x_i+1 obj_i+1) ...) H) + (where ((y_0 obj_y0) ... (y_j val_j) (y_j+1 obj_j+1) ...) H) + "Update") + (--> ((f_i n a ..._n_) s H) + ((subst (x a) ... e) s H) + (where ((f_0 obj_0) ... (f_i (FUN (x ..._n_) e)) (f_i+1 obj_i+1) ...) H) + (side-condition (= (length (term (a ...))) (length (term (x ...))) (term n))) + "KnownCall") + ; Primop rule is omitted + ; n.b. named ellipses do not carry over + (--> ((f_i • a ...) s H) + ((subst (x a) ... e) s H) + (where ((f_0 obj_0) ... (f_i (FUN (x ...) e)) (f_i+1 obj_i+1) ...) H) + (side-condition (= (length (term (a ...))) (length (term (x ...))))) + "Exact") + (--> ((f_i k a_1→n ..._1→n a_n+1→m ...) + (κ ...) + (name H ((f_0 obj_0) ... (f_i (FUN (x ..._1→n) e)) (f_i+1 obj_i+1) ...))) + ((subst (x a_1→n) ... e) ((• a_n+1→m ...) κ ...) H) + (side-condition (> (length (term (a_n+1→m ...))) 0)) + "CallK") + (--> ((f_i k a ..._1→m) + s + (name H ((f_1 obj_1) ... (f_i (FUN (x_1→m ..._1→m x_m+1→n ...) e)) (f_i+1 obj_i+1) ...))) + (f_0 s ((f_0 (PAP f_i a ...)) ,@(term H))) + (fresh f_0) + (side-condition (> (length (term (x_m+1→n ...))) 0)) + "PAP") + (--> ((f_i • a ...) (κ ...) H) + (f_i ((• a ...) κ ...) H) + (where ((f_0 obj_0) ... (f_i (THUNK e)) (f_i+1 obj_i+1) ...) H) + "TCall") + (--> ((f_i k a_m ...) s H) + ((g • a_n ... a_m ...) s H) + (where ((f_0 obj_0) ... (f_i (PAP g a_n ...)) (f_i+1 obj_i+1) ...) H) + "PCall") + (--> (f_i ((• a ...) κ ...) H) + ((f_i • a ...) (κ ...) H) + ; technically CON should not be allowed, but we'll get stuck one step later + (where ((f_0 obj_0) ... (f_i val) (f_i+1 obj_i+1) ...) H) + "RetFun") + )) + +(define dH (term ((f (FUN (x y z) (⊕ x y z))) (g (THUNK f)) (h (PAP f 0)) (y (THUNK z)) (z (CON C_I 0))))) + +; XXX these tests are pretty fragile + +(define dHc (term ((f (FUN (x y z) (⊕ x y z))) (g (THUNK f)) (h (PAP f 0)) (y (CON C_I 0)) (z (CON C_I 0))))) + +; Case +(test-->> red + (term ((case z ((C_I x) (⊕ x 1)) ((x) x)) () ,dH)) + (term ((⊕ 0 1) () ,dH))) +(test-->> red + (term ((case y ((C_I x) (⊕ x 1)) ((x) x)) () ,dH)) + (term ((⊕ 0 1) () ,dHc))) +(test-->> red + (term ((case z ((C_J x) (⊕ x 1)) ((x) x)) () ,dH)) + (term (z () ,dH))) +(test-->> red + (term ((case y ((C_J x) (⊕ x 1)) ((x) x)) () ,dH)) + (term (z () ,dHc))) +(test-->> red + (term ((case 0 ((C_J x) (⊕ x 1)) ((x) x)) () ,dH)) + (term (0 () ,dH))) + +; KnownCall/Exact/CallK/PAP +(test-->> red + (term ((f • 0) () ,dH)) + (term (f_0 () ((f_0 (PAP f 0)) ,@dH)))) +(test-->> red + (term ((f 3 0) () ,dH)) + (term (f_0 () ((f_0 (PAP f 0)) ,@dH)))) +(test-->> red + (term ((f • 0 1 2 3) () ,dH)) + (term ((⊕ 0 1 2) ((• 3)) ,dH))) +(test-->> red + (term ((f 3 0 1 2 3) () ,dH)) + (term ((⊕ 0 1 2) ((• 3)) ,dH))) +(test-->> red + (term ((f • 0 1 2) () ,dH)) + (term ((⊕ 0 1 2) () ,dH))) +(test-->> red + (term ((f 3 0 1 2) () ,dH)) + (term ((⊕ 0 1 2) () ,dH))) + +; TCall/Thunk/Update +(define dHe (term ((f (FUN (x y z) (⊕ x y z))) (g (FUN (x y z) (⊕ x y z))) (h (PAP f 0)) (y (THUNK z)) (z (CON C_I 0))))) +(test-->> red + (term ((g • 0) () ,dH)) + (term (f_0 () ((f_0 (PAP f 0)) ,@dHe)))) +(test-->> red + (term ((g • 0 1 2 3) () ,dH)) + (term ((⊕ 0 1 2) ((• 3)) ,dHe))) +(test-->> red + (term ((g • 0 1 2) () ,dH)) + (term ((⊕ 0 1 2) () ,dHe))) + +; PCall +(test-->> red + (term ((h • 1) () ,dH)) + (term (f_0 () ((f_0 (PAP f 0 1)) ,@dH)))) +(test-->> red + (term ((h 2 1) () ,dH)) + (term (f_0 () ((f_0 (PAP f 0 1)) ,@dH)))) +(test-->> red + (term ((h • 1 2 3) () ,dH)) + (term ((⊕ 0 1 2) ((• 3)) ,dH))) +(test-->> red + (term ((h 3 1 2 3) () ,dH)) + (term ((⊕ 0 1 2) ((• 3)) ,dH))) +(test-->> red + (term ((h • 1 2) () ,dH)) + (term ((⊕ 0 1 2) () ,dH))) +(test-->> red + (term ((h 3 1 2) () ,dH)) + (term ((⊕ 0 1 2) () ,dH))) \ No newline at end of file diff --git a/docs/storage-mgt/Makefile b/docs/storage-mgt/Makefile new file mode 100644 index 00000000..c9126929 --- /dev/null +++ b/docs/storage-mgt/Makefile @@ -0,0 +1,42 @@ +TOP = ../.. +include $(TOP)/mk/boilerplate.mk + +# General makefile for Latex stuff + +dvi: sm.dvi rp.dvi ldv.dvi +ps: sm.ps rp.ps ldv.ps + +######## General rules +.SUFFIXES: +.PRECIOUS: %.tex %.ps %.bbl + +#%.dvi: %.tex $(addsuffix .tex, $(basename $(wildcard *.verb *.fig))) $(wildcard *.bib) +%.dvi: %.tex $(addsuffix .tex, $(basename $(wildcard *.verb))) $(wildcard *.bib) + latex $< + @if grep -s "\citation" $*.aux; then bibtex $*; fi + latex $< + latex $< + +%.ps: %.dvi + dvips -f < $< > $@ + +clean: + $(RM) *.aux *.log + +distclean: clean + $(RM) *.dvi *.ps *.bbl *.blg *.gz + +maintainer-clean: distclean + +include $(TOP)/mk/bindist.mk + +# dummy targets +all: +boot: +install: +install-docs: +html: +chm: +HxS: + +# End of file diff --git a/docs/storage-mgt/architecture.eepic b/docs/storage-mgt/architecture.eepic new file mode 100644 index 00000000..57ffd8fc --- /dev/null +++ b/docs/storage-mgt/architecture.eepic @@ -0,0 +1,55 @@ +\setlength{\unitlength}{0.00054167in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(5787,4014)(0,-10) +\path(2700,912)(5325,912)(5325,1212) + (2700,1212)(2700,912) +\path(2850,12)(5100,12)(5100,312) + (2850,312)(2850,12) +\path(2700,1812)(5325,1812)(5325,2112) + (2700,2112)(2700,1812) +\path(3825,2712)(5700,2712)(5700,3012) + (3825,3012)(3825,2712) +\path(3825,3687)(5625,3687)(5625,3987) + (3825,3987)(3825,3687) +\path(2625,3687)(3825,3687)(3825,3987) + (2625,3987)(2625,3687) +\path(3795.000,3357.000)(3825.000,3237.000)(3855.000,3357.000) +\path(3825,3237)(3825,3687) +\path(3855.000,3567.000)(3825.000,3687.000)(3795.000,3567.000) +\path(3795.000,1332.000)(3825.000,1212.000)(3855.000,1332.000) +\path(3825,1212)(3825,1812) +\path(3855.000,1692.000)(3825.000,1812.000)(3795.000,1692.000) +\path(1875,3237)(5775,3237)(5775,762) + (1875,762)(1875,3237) +\path(3855.000,642.000)(3825.000,762.000)(3795.000,642.000) +\path(3825,762)(3825,312) +\path(3795.000,432.000)(3825.000,312.000)(3855.000,432.000) +\path(2025,2712)(3525,2712)(3525,3012) + (2025,3012)(2025,2712) +\path(3195.000,2232.000)(3225.000,2112.000)(3255.000,2232.000) +\path(3225,2112)(3225,2712) +\path(3255.000,2592.000)(3225.000,2712.000)(3195.000,2592.000) +\path(4320.000,2232.000)(4350.000,2112.000)(4380.000,2232.000) +\path(4350,2112)(4350,2712) +\path(4380.000,2592.000)(4350.000,2712.000)(4320.000,2592.000) +\path(3525,2937)(3825,2937) +\path(3705.000,2907.000)(3825.000,2937.000)(3705.000,2967.000) +\path(3825,2787)(3525,2787) +\path(3645.000,2817.000)(3525.000,2787.000)(3645.000,2757.000) +\put(3225,1887){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}block allocator}}}}} +\put(3000,987){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}megablock allocator}}}}} +\put(3150,87){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}operating system}}}}} +\put(2700,3762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}mutatator}}}}} +\put(3900,3762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}runtime system}}}}} +\put(2100,2787){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}heap allocator}}}}} +\put(3975,2787){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}garbage collector}}}}} +\put(0,1962){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}storage manager}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/architecture.fig b/docs/storage-mgt/architecture.fig new file mode 100644 index 00000000..563da78a --- /dev/null +++ b/docs/storage-mgt/architecture.fig @@ -0,0 +1,59 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +65.00 +Single +-2 +1200 2 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2400 4200 5025 4200 5025 3900 2400 3900 2400 4200 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2550 5100 4800 5100 4800 4800 2550 4800 2550 5100 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2400 3300 5025 3300 5025 3000 2400 3000 2400 3300 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 3525 2400 5400 2400 5400 2100 3525 2100 3525 2400 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 3525 1425 5325 1425 5325 1125 3525 1125 3525 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2325 1425 3525 1425 3525 1125 2325 1125 2325 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3525 1875 3525 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3525 3900 3525 3300 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 1575 1875 5475 1875 5475 4350 1575 4350 1575 1875 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3525 4350 3525 4800 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 1725 2400 3225 2400 3225 2100 1725 2100 1725 2400 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2925 3000 2925 2400 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4050 3000 4050 2400 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3225 2175 3525 2175 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3525 2325 3225 2325 +4 0 0 50 0 0 12 0.0000 4 135 1110 2925 3225 block allocator\001 +4 0 0 50 0 0 12 0.0000 4 180 1515 2700 4125 megablock allocator\001 +4 0 0 50 0 0 12 0.0000 4 180 1305 2850 5025 operating system\001 +4 0 0 50 0 0 12 0.0000 4 105 735 2400 1350 mutatator\001 +4 0 0 50 0 0 12 0.0000 4 180 1170 3600 1350 runtime system\001 +4 0 0 50 0 0 12 0.0000 4 180 1065 1800 2325 heap allocator\001 +4 0 0 50 0 0 12 0.0000 4 180 1305 3675 2325 garbage collector\001 +4 0 0 50 0 0 12 0.0000 4 150 1260 -300 3150 storage manager\001 diff --git a/docs/storage-mgt/cacheprof_p.eps b/docs/storage-mgt/cacheprof_p.eps new file mode 100644 index 00000000..94d3a5d0 --- /dev/null +++ b/docs/storage-mgt/cacheprof_p.eps @@ -0,0 +1,2083 @@ +%!PS-Adobe-2.0 EPSF-1.2 +%%Title: cacheprof_p -ghc-timing +RTS -H10m -K10m -p -hR -i1.0 -sstderr +%%Creator: Ghostscript ps2epsi from cacheprof_p.ps +%%CreationDate: Aug 23 18:51 +%%For:t-spark t-spark +%%Pages: 1 +%%DocumentFonts: Helvetica +%%BoundingBox: 72 107 505 756 +%%BeginPreview: 433 649 1 649 +% ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff80 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 8000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001ffffffffff080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000108000000084000000022000000022000000008000000000000000010000100001080 +% 800000000000000000000000100000000100000001cc0000000e600000006300000006300000000e000000000000000010420103c01080 +% 800000000000000000000000100000000100000001440000000a200000004900000004900000000b000000000000000010738106601080 +% 800000000000000000000003f80000003f800000012400000009200000004900000004900000003f800000000000000010588104201080 +% 8000000000000000000000000000000000000000011800000008c00000003e00000003e000000008000000000000000010488104201080 +% 800000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000104c8106601080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010478102401080 +% 800000000000000000000006000000006000000003000000001800000000c00000000c0000000060000000000000000010000100001080 +% 800000000000002c00000001e00000001600000000f000000005800000003c00000002c00000001e000000000000000010420107201080 +% 800000000000006f000000031800000037800000018c0000000de00000006300000006f000000031800000000000000010738105a01080 +% 8000000000000045000000020800000022800000010400000008a000000041000000045000000020800000000000000010588105a01080 +% 8000000000000045000000021800000022800000010c00000008a000000043000000045000000021800000000000000010488104a01080 +% 800000000000003900000001f00000001c80000000f800000007200000003e00000003900000001f0000000000000000104c8107e01080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010478104001080 +% 800000000000003c00000001e00000001e00000000f000000007800000003c00000003c00000001e000000000000000010000103c01080 +% 8000000000000063000000031800000031800000018c0000000c6000000063000000063000000031800000000000000011c00106601080 +% 80000000000000410000000208000000208000000104000000082000000041000000041000000020800000000000000010800104201080 +% 8000000000000043000000021800000021800000010c000000086000000043000000043000000021800000000000000010000104201080 +% 800000000000003e00000001f00000001f00000000f800000007c00000003e00000003e00000001f000000000000000010000106601080 +% 800007800000003c00000001e00000001e00000000f000000007800000003c00000003c00000001e000000000000000010010102401080 +% 80000c6000000063000000031800000031800000018c0000000c6000000063000000063000000031800000000000000010010100001080 +% 800008200000004100000002080000002080000001040000000820000000410000000410000000208000000000000000107f8107fc1080 +% 8000086000000043000000021800000021800000010c000000086000000043000000043000000021800000000000000010000100201080 +% 800007c00000003e00000001f00000001f00000000f800000007c00000003e00000003e00000001f000000000200200010000100201080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000200200010070100201080 +% 80000fe00000007f00000003f80000003f80000001fc0000000fe00000007f00000007f00000003f8000000003c8ff7c106d8107e01080 +% 800003000000001800000000c00000000c000000006000000003000000001800000001800000000c000000000225396010488101801080 +% 800003000000001800000000c00000000c000000006000000003000000001800000001800000000c0000000002253f3810488103c01080 +% 83c006800000003400000001a00000001a00000000d000000006800000003400000003400000001a0000000003273944106d8104a01080 +% 863008000000004000000002000000002000000001000000000800000000400000000400000000200000000003c23f78103f0104a01080 +% 84100000000000000000000000000000000000000000000000000000000000000000000000000000000000000002000010000104e01080 +% 8430080000000080000000040000000020000000010000000010000000008000000004000000002000000000000c000010000102c01080 +% 83e00800000000800000000400000000200000000100000000100000000080000000040000000020000000000000000010010100001080 +% 80000800000000800000000400000000200000000100000000100000000080000000040000000020000000000000000010010100001080 +% 800008000000008000000004000000002000000001000000001000000000800000000400000000200000000000000000107f813fe01080 +% 8400fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe10000106601080 +% 83c00f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000104201080 +% 86300e80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000106601080 +% 84100f60000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000103c01080 +% 84300f98000000000000000000000000000000000000000000000000000000000000000000000000000000000000000011c00100001080 +% 83e00fd6000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010800100001080 +% 80000f61800000000000000000000000000000000000000000000000000000000000000000000000000000000000000010180107e01080 +% 80000ff14000000000000000000000000000000000000000000000000000000000000000000000000000000000000000101c0100201080 +% 80000f68300000000000000000000000000000000000000000000000000000000000000000000000000000000000000010120100201080 +% 80000fd55c0000000000000000000000000000000000000000000000000000000000000000000000000000000000000010118103c01080 +% 80000baa0300000000000000000000000000000000000000000000000000000000000000000000000000000000000000107fc106601080 +% 80000b7591c000000000000000000000000000000000000000000000000000000000000000000000000000000000000010100104201080 +% 80000fd2c02000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000104201080 +% 80000ff7755800000000000000000000000000000000000000000000000000000000000000000000000000000000000010180106601080 +% 80000da9b006000000000000000000000000000000000000000000000000000000000000000000000000000000000000101c0103c01080 +% 80000dd5d95180000000000000000000000000000000000000000000000000000000000000000000000000000000000010120100201080 +% 80000df46c0040000000000000000000000000000000000000000000000000000000000000000000000000000000000010118107fc1080 +% 80000ddb7755700000000000000000000000000000000000000000000000000000000000000000000000000000000000107fc100241080 +% 80000dea2b000c000000000000000000000000000000000000000000000000000000000000000000000000000000000010100100001080 +% 80000df5559113000000000000000000000000000000000000000000000000000000000000000000000000000000000010180110001080 +% 80000cfcaac000c000000000000000000000000000000000000000000000000000000000000000000000000000000000101c0110001080 +% 80000dd4d57555600000000000000000000000000000000000000000000000000000000000000000000000000000000010120110001080 +% 80000cbe42b000180000000000000000000000000000000000000000000000000000000000000000000000000000000010118110001080 +% 80000d765759511600000000000000000000000000000000000000000000000000000000000000000000000000000000107fc110001080 +% 80000c7b21ac00018000000000000000000000000000000000000000000000000000000000000000000000000000000010100110001080 +% 80000f5d15d755556000000000000000000000000000000000000000000000000000000000000000000000000000000010000110001080 +% 80000e7a906b0000100000000000000000000000000000000000000000000000000000000000000000000000000000001000013fe01080 +% 80000f558d7591111c00000000000000000000000000000000000000000000000000000000000000000000000000000010000106601080 +% 80000e3fca2ac0000300000000000000000000000000000000000000000000000000000000000000000000000000000010000104201080 +% 80000f7d4555755555c0000000000000000000000000000000000000000000000000000000000000000000000000000010000106601080 +% 80000e2ee20ab00000300000000000000000000000000000000000000000000000000000000000000000000000000000107fc103c01080 +% 80000f7f635559515158000000000000000000000000000000000000000000000000000000000000000000000000000010660100001080 +% 80000e27b122ac000006000000000000000000000000000000000000000000000000000000000000000000000000000010420100001080 +% 80000f55515757555555800000000000000000000000000000000000000000000000000000000000000000000000000010660100001080 +% 80000e1ff081ab0000006000000000000000000000000000000000000000000000000000000000000000000000000000103c0100001080 +% 80000f155855d5d11111180000000000000000000000000000000000000000000000000000000000000000000000000010000100801080 +% 80000e13b8626aa00000040000000000000000000000000000000000000000000000000000000000000000000000000010020100801080 +% 80000f5fd435755555555700000000000000000000000000000000000000000000000000000000000000000000000000121e0100801080 +% 80000f0bac201aa8000000c000000000000000000000000000000000000000000000000000000000000000000000000011f00100001080 +% 80000f1f561555555111513000000000000000000000000000000000000000000000000000000000000000000000000010700103c01080 +% 80001f0bfa122aaa0000000c000000000000000000000000000000000000000000000000000000000000000000000000101e0136601080 +% 80002d5d550d55555555555600000000000000000000000000000000000000000000000000000000000000000000000010020124201080 +% 80004d05eb0402aa8000000180000000000000000000000000000000000000000000000000000000000000000000000010020124201080 +% 80008d15f585555511111111600000000000000000000000000000000000000000000000000000000000000000000000107f813fe01080 +% 80008d07bb8223aaa00000001000000000000000000000000000000000000000000000000000000000000000000000001042011fe01080 +% 80004f55758355557555555558000000000000000000000000000000000000000000000000000000000000000000000010180100001080 +% 80002f0bee8200aab0000000060000000000000000000000000000000000000000000000000000000000000000000000103c0100001080 +% 80001f5d758355d559515151510000000000000000000000000000000000000000000000000000000000000000000000104a0107fc1080 +% 80000f0bfb81206aa8000000008000000000000000000000000000000000000000000000000000000000000000000000104a0100201080 +% 80000f5d7581555555555555556000000000000000000000000000000000000000000000000000000000000000000000104e0100201080 +% 80000f09ea81002aaa000000001000000000000000000000000000000000000000000000000000000000000000000000102c0100201080 +% 80000f1d758155755711111111180000000000000000000000000000000000000000000000000000000000000000000010000107e01080 +% 80000f0bbb80a23aab00000000060000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f5d7580d55555d55555555500000000000000000000000000000000000000000000000000000000000000000000106e0103c01080 +% 80000f19eec0801aaa8000000000c0000000000000000000000000000000000000000000000000000000000000000000104a0106601080 +% 80000f157540d55d55515111511160000000000000000000000000000000000000000000000000000000000000000000105a0104201080 +% 80000f13fbc0602aaaa0000000001000000000000000000000000000000000000000000000000000000000000000000010720104201080 +% 80000f57754055555575555555555c00000000000000000000000000000000000000000000000000000000000000000010000106601080 +% 80000f1beac04006aab0000000000200000000000000000000000000000000000000000000000000000000000000000010000102401080 +% 80000f17554055575559111111111100000000000000000000000000000000000000000000000000000000000000000010000100801080 +% 80000f93fbc02222aaa80000000000c0000000000000000000000000000000000000000000000000000000000000000010000100801080 +% 80000fd7554035555555555555555560000000000000000000000000000000000000000000000000000000000000000010400100801080 +% 80000fabeec02001aaaa000000000010000000000000000000000000000000000000000000000000000000000000000010660100001080 +% 80000ff755403555555551515151515c0000000000000000000000000000000000000000000000000000000000000000101c0100201080 +% 80000fa3fbc01020aaab0000000000020000000000000000000000000000000000000000000000000000000000000000103c0107f81080 +% 80000ff755401555d555d55555555555000000000000000000000000000000000000000000000000000000000000000010660104201080 +% 80000fabeac010006aaac00000000000c00000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fb5556015555555511111111111200000000000000000000000000000000000000000000000000000000000000010000107e41080 +% 80000fa7fba00a222aaaa00000000000100000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000ff555600d5575555555555555555c0000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fcfeee008001aaab00000000000020000000000000000000000000000000000000000000000000000000000000010000107e01080 +% 80000fd555600d555555591151115111510000000000000000000000000000000000000000000000000000000000000010000100201080 +% 80000fe7fba004223aaaac000000000000c0000000000000000000000000000000000000000000000000000000000000106e0100201080 +% 80000fd5556005555d555555555555555560000000000000000000000000000000000000000000000000000000000000104a0107e01080 +% 80000fefeae004000aaaaa00000000000010000000000000000000000000000000000000000000000000000000000000105a0100201080 +% 80000fd5556005555555551111111111111c00000000000000000000000000000000000000000000000000000000000010720100201080 +% 80001fe7fba0022226aaab0000000000000200000000000000000000000000000000000000000000000000000000000010000100201080 +% 80002ed555600355575555d555555555555500000000000000000000000000000000000000000000000000000000000010180107e01080 +% 80004e8feea0020002aaaac0000000000000c00000000000000000000000000000000000000000000000000000000000103c0100001080 +% 80008edd5560035557555551515151515151600000000000000000000000000000000000000000000000000000000000104a0100001080 +% 80008eabfbb0012021aaaaa0000000000000100000000000000000000000000000000000000000000000000000000000104a0107e41080 +% 80004edd5550015555d555555555555555555c0000000000000000000000000000000000000000000000000000000000104e0100001080 +% 80002eafeaf0008000aaaaa8000000000000020000000000000000000000000000000000000000000000000000000000102c0107e01080 +% 80001fdd555000d555555559111111111111118000000000000000000000000000000000000000000000000000000000103c0100201080 +% 84200fabfbb00062226aaaac00000000000000400000000000000000000000000000000000000000000000000000000010660100201080 +% 87300fdd555800555575555755555555555555600000000000000000000000000000000000000000000000000000000010420100201080 +% 85100f8feee80040001aaaab00000000000000180000000000000000000000000000000000000000000000000000000010420107e01080 +% 84900fd5555800355555555551115111511151140000000000000000000000000000000000000000000000000000000010660100001080 +% 84600fa7fbb80022202aaaaa80000000000000020000000000000000000000000000000000000000000000000000000010240103c01080 +% 80000fd55558001555555555555555555555555580000000000000000000000000000000000000000000000000000000103c0136601080 +% 8400ffafeae800100006aaaaa0000000000000004000000000000000000000000000000000000000000000000000000010660124201080 +% 80000fd57554000d5557555551111111111111113000000000000000000000000000000000000000000000000000000010420124201080 +% 83c00fa7bbbc000a2222aaaab000000000000000080000000000000000000000000000000000000000000000000000001042013fe01080 +% 86300fd57554000d555555555d55555555555555540000000000000000000000000000000000000000000000000000001066011fe01080 +% 84100f8feeac00040000aaaaac0000000000000003000000000000000000000000000000000000000000000000000000103c0100001080 +% 84300fd5755400055555d55557515151515151515180000000000000000000000000000000000000000000000000000010000100001080 +% 83e00fa7fbba000220206aaaaa000000000000000040000000000000000000000000000000000000000000000000000010000100001080 +% 80000fd57556000355557555555555555555555555700000000000000000000000000000000000000000000000000000107e0100001080 +% 80000fafeaea000100002aaaaa800000000000000008000000000000000000000000000000000000000000000000000010020101001080 +% 80000fd5755600015555555555511111111111111116000000000000000000000000000000000000000000000000000010020101001080 +% 80000fa7bbba000122223aaaaac00000000000000001000000000000000000000000000000000000000000000000000010020101001080 +% 80000fd575550000d5555d55557555555555555555558000000000000000000000000000000000000000000000000000107e0107e01080 +% 80000f8feeef0000800006aaaab00000000000000000600000000000000000000000000000000000000000000000000010000101001080 +% 80000fd57555000055555555555951115111511151115000000000000000000000000000000000000000000000000000103c0101001080 +% 80000fa7fbbb0000602222aaaaa80000000000000000080000000000000000000000000000000000000000000000000010660101001080 +% 80000fd5555500003555555555555555555555555555560000000000000000000000000000000000000000000000000010420100001080 +% 80000daffaeb0000200001aaaaaa0000000000000000010000000000000000000000000000000000000000000000000010420107fc1080 +% 80000dd555558000155555d55555111111111111111111c000000000000000000000000000000000000000000000000010660100441080 +% 80000da7bbbb8000122222aaaaab00000000000000000020000000000000000000000000000000000000000000000000107fc100441080 +% 80000dd555558000155555555555d555555555555555555000000000000000000000000000000000000000000000000010000100441080 +% 80000d8ffeae80000800002aaaaac000000000000000000c000000000000000000000000000000000000000000000000106e0100441080 +% 80000dd5555580000d555575555571515151515151515152000000000000000000000000000000000000000000000000104a0103cc1080 +% 80001da7fbbbc0000420203aaaaaa0000000000000000001000000000000000000000000000000000000000000000000105a0107b81080 +% 80002dd55555400005555555555555555555555555555555c0000000000000000000000000000000000000000000000010720100001080 +% 80004faffaeac0000200000aaaaaa800000000000000000020000000000000000000000000000000000000000000000010000100041080 +% 80008fd5555540000355555555555511111111111111111118000000000000000000000000000000000000000000000010000100041080 +% 80008fa3bbbba00001222222aaaaaa00000000000000000004000000000000000000000000000000000000000000000010000100041080 +% 80004d575d5560000155555755555555555555555555555557000000000000000000000000000000000000000000000010000107fc1080 +% 80002d4bfeeea00000800001aaaaab00000000000000000000800000000000000000000000000000000000000000000010000100041080 +% 80001d575555500000555555d5555591511151115111511151600000000000000000000000000000000000000000000010000100041080 +% 80000d63ffbbb000006220226aaaaac00000000000000000001800000000000000000000000000000000000000000000107f0100041080 +% 80000d7555555800003555557555557555555555555555555554000000000000000000000000000000000000000000001183c101001080 +% 80000f29feeae800001000002aaaaab0000000000000000000030000000000000000000000000000000000000000000010000103381080 +% 80000f35d755540000155555555555591111111111111111111180000000000000000000000000000000000000000000100001046c1080 +% 80000fa2bbbbbc00000a22222aaaaaac0000000000000000000060000000000000000000000000000000000000000000107fc104441080 +% 80000fd5d5555400000555555555555755555555555555555555580000000000000000000000000000000000000000001003c104441080 +% 80000f9affaeee000004000002aaaaab0000000000000000000004000000000000000000000000000000000000000000101e0104cc1080 +% 80000fd5555556000003555557555555d15151515151515151515300000000000000000000000000000000000000000010700107981080 +% 80000f927bbbbb000001202021aaaaaac00000000000000000000080000000000000000000000000000000000000000010700100001080 +% 80000fdd55d555000001555555d555557555555555555555555555600000000000000000000000000000000000000000101e0100001080 +% 80000f88bfeaea8000008000006aaaaab0000000000000000000001800000000000000000000000000000000000000001003c100001080 +% 80000f9d75d5558000005555557555555911111111111111111111140000000000000000000000000000000000000000107fc100001080 +% 80000f8a3bfbbb8000006222223aaaaaa80000000000000000000003000000000000000000000000000000000000000010000100801080 +% 80000fd5555555400000355555555555555555555555555555555555800000000000000000000000000000000000000010000100801080 +% 80000f849feeaec000001000000aaaaaaa00000000000000000000006000000000000000000000000000000000000000103fc100801080 +% 80000f95557555600000155555555555551151115111511151115111580000000000000000000000000000000000000010600100001080 +% 80000f863bbbbba0000008222022aaaaaa8000000000000000000000040000000000000000000000000000000000000010400100001080 +% 80000fd75d7555500000055555555555555555555555555555555555570000000000000000000000000000000000000010400107fc1080 +% 80000f82affaeaf0000004000001aaaaaaa000000000000000000000008000000000000000000000000000000000000010400100401080 +% 80000f935d555550000003555555d555555111111111111111111111116000000000000000000000000000000000000010600100401080 +% 80000e8227bbbbb80000012222226aaaaaa8000000000000000000000018000000000000000000000000000000000000103fc100401080 +% 80000ed5555d55580000015555557555555555555555555555555555555400000000000000000000000000000000000010004100401080 +% 80000ec18ffeeeac0000008000001aaaaaaa00000000000000000000000300000000000000000000000000000000000010004100401080 +% 80001ed1555d55540000005555555555555551515151515151515151515180000000000000000000000000000000000010004107fc1080 +% 80002ec123ffbbbc0000006020202aaaaaaa800000000000000000000000600000000000000000000000000000000000107fc100001080 +% 80004dd5d75555560000003555555555555555555555555555555555555558000000000000000000000000000000000010004100001080 +% 80008dc0abfeeaea00000010000002aaaaaac0000000000000000000000004000000000000000000000000000000000010004100101080 +% 80008dd1d75555550000001555555555555571111111111111111111111112000000000000000000000000000000000010004100101080 +% 80004fc0a3bfbbbb0000000a222223aaaaaab0000000000000000000000001000000000000000000000000000000000010000107f81080 +% 80002dd5d75555550000000d555555d555555d555555555555555555555555c00000000000000000000000000000000010000100001080 +% 80001fc08bfeaeef00000008000000aaaaaaa8000000000000000000000000200000000000000000000000000000000011c3c100001080 +% 80000dd15755555500000005555555555555551151115111511151115111511000000000000000000000000000000000107f0100001080 +% 80000fc123bfbbbb000000062022206aaaaaaa000000000000000000000000080000000000000000000000000000000010000100001080 +% 80000dd5575555550000000555555575555557555555555555555555555555540000000000000000000000000000000010000103f81080 +% 80000dc1abfeeaeb000000020000002aaaaaab000000000000000000000000020000000000000000000000000000000010000106181080 +% 80000dd1575555550000000355555555555555911111111111111111111111118000000000000000000000000000000010000104081080 +% 80000fc123bfbbbb000000022222223aaaaaaa800000000000000000000000004000000000000000000000000000000010000106181080 +% 80000dd557555555000000015555555d555555555555555555555555555555556000000000000000000000000000000010000103f01080 +% 80000dc18bfeeeae800000010000000aaaaaaac00000000000000000000000001000000000000000000000000000000010000100001080 +% 80000dd1575555558000000155555555555555715151515151515151515151515800000000000000000000000000000010000107e01080 +% 80000fc223ffbbbb80000000a0202026aaaaaab00000000000000000000000000400000000000000000000000000000010000100201080 +% 80000dd75755555580000000d5555557555555555555555555555555555555555700000000000000000000000000000010000100201080 +% 80000dc2abfeeaea8000000080000002aaaaaaa80000000000000000000000000080000000000000000000000000000010000107e01080 +% 80000dd3575555558000000055555555555555551111111111111111111111111140000000000000000000000000000010000100201080 +% 80000fc223bfbbbb8000000062222223aaaaaaac0000000000000000000000000020000000000000000000000000000010000100201080 +% 80000dd7575555558000000055555555d55555575555555555555555555555555550000000000000000000000000000010000100201080 +% 80000fc28bfeaeee8000000020000000aaaaaaab0000000000000000000000000008000000000000000000000000000010000107e01080 +% 80000dd3575555558000000035555555555555555111511151115111511151115116000000000000000000000000000010000100001080 +% 80000fc223bfbbbb80000000202220226aaaaaaa8000000000000000000000000001000000000000000000000000000010000100001080 +% 80000dd5575555554000000035555555755555555555555555555555555555555555800000000000000000000000000010000100001080 +% 80000dc4abfeeaeac0000000100000002aaaaaaac000000000000000000000000000400000000000000000000000000010000100001080 +% 80000dd5575555554000000015555555555555557111111111111111111111111111200000000000000000000000000010000100001080 +% 80000fc627bfbbbbc0000000122222223aaaaaaab000000000000000000000000000180000000000000000000000000010000100801080 +% 80001dd555555555400000000d5555555d5555555555555555555555555555555555540000000000000000000000000010000100801080 +% 81002dc68ffeeeaec0000000080000000aaaaaaaa800000000000000000000000000020000000000000000000000000010000100801080 +% 81c04dd555555555400000000d555555555555555551515151515151515151515151510000000000000000000000000010000100001080 +% 81608fc627ffbbbbc00000000420202026aaaaaaac00000000000000000000000000008000000000000000000000000010000100001080 +% 87f08dd5555555554000000005555555575555555755555555555555555555555555554000000000000000000000000010000107fc1080 +% 81004dc4affeeaeac00000000400000002aaaaaaab00000000000000000000000000003000000000000000000000000010000100401080 +% 80002dd5555555556000000003555555555555555511111111111111111111111111111800000000000000000000000010000100601080 +% 80001fca27bfbbbba00000000222222223aaaaaaaa80000000000000000000000000000400000000000000000000000010000100f01080 +% 8400fddd55555555600000000155555555d555555555555555555555555555555555555600000000000000000000000010000103981080 +% 80000fc88ffeaeeea00000000100000000aaaaaaaac0000000000000000000000000000180000000000000000000000010000106041080 +% 83c00ddd555555556000000001555555555555555571511151115111511151115111511140000000000000000000000010000104001080 +% 86300fca27bfbbbba000000000a22022206aaaaaaab0000000000000000000000000000020000000000000000000000010000100001080 +% 84100ddd555555556000000000d55555557555555555555555555555555555555555555550000000000000000000000010000100101080 +% 84300dc8affeeaeae000000000800000002aaaaaaaa800000000000000000000000000000c000000000000000000000010000100101080 +% 83e00ddd555555555000000000555555555555555555111111111111111111111111111112000000000000000000000010000107f81080 +% 80000fca27bfbbbbb000000000622222223aaaaaaaaa000000000000000000000000000001000000000000000000000010000100001080 +% 80000ddd555555555000000000555555555d55555557555555555555555555555555555555800000000000000000000010000100001080 +% 80000dca8ffeeeaef000000000200000000aaaaaaaab000000000000000000000000000000600000000000000000000010000100001080 +% 80000ddd555555555000000000355555555555555555d15151515151515151515151515151500000000000000000000010000103f81080 +% 80000fd227ffbbbbb0000000002020202022aaaaaaaa800000000000000000000000000000080000000000000000000010000106181080 +% 80000dd5555555555000000000155555555755555555555555555555555555555555555555540000000000000000000010000104081080 +% 80000dd8affeeaeae8000000001000000001aaaaaaaaa00000000000000000000000000000030000000000000000000010000106181080 +% 80000dd5555555555800000000155555555555555555711111111111111111111111111111118000000000000000000010000103f01080 +% 80000fd227bfbbbbb8000000000a22222222aaaaaaaab00000000000000000000000000000004000000000000000000010000100001080 +% 80000dd55555555558000000000d55555555d55555555d5555555555555555555555555555556000000000000000000010000100001080 +% 80000fd88ffeaeeea80000000004000000006aaaaaaaa80000000000000000000000000000001800000000000000000010000107e01080 +% 80000dd5555755555800000000055555555555555555551151115111511151115111511151115400000000000000000010000100201080 +% 80000fd227bbbbbbb80000000006202220222aaaaaaaaa0000000000000000000000000000000200000000000000000010000100201080 +% 80001dd5555755555800000000035555555575555555575555555555555555555555555555555500000000000000000010000107e01080 +% 80002db8affeeaeaec0000000002000000001aaaaaaaab00000000000000000000000000000000c0000000000000000010000100201080 +% 80004df5555755555400000000035555555555555555559111111111111111111111111111111120000000000000000010000100201080 +% 80008fb227bbbbbbbc0000000001222222222aaaaaaaaac000000000000000000000000000000010000000000000000010000100201080 +% 80008df557575555540000000001555555555555555555555555555555555555555555555555555c000000000000000010000107e01080 +% 80004dba8bfeeeaeee00000000008000000002aaaaaaaaa000000000000000000000000000000002000000000000000010000100001080 +% 80002df5575555555600000000005555555557555555555151515151515151515151515151515151800000000000000010000100001080 +% 80001fb223fbbbbbba00000000006020202021aaaaaaaaa800000000000000000000000000000000400000000000000010000100001080 +% 80000dfd555555555500000000003555555555d55555555555555555555555555555555555555555600000000000000010000100001080 +% 80000da8a9ffeaeaeb000000000010000000006aaaaaaaaa00000000000000000000000000000000180000000000000010000100801080 +% 80000dfd5555d5555580000000001555555555755555555511111111111111111111111111111111140000000000000010000100801080 +% 80000faa23bbbbbbbb80000000000a222222223aaaaaaaaa80000000000000000000000000000000030000000000000010000100801080 +% 80000df555d5d5555580000000000555555555555555555555555555555555555555555555555555558000000000000010000100001080 +% 80000fa48affeeeeaec00000000004000000000aaaaaaaaaa0000000000000000000000000000000006000000000000010000100001080 +% 80000df555d55555554000000000035555555555555555555111511151115111511151115111511151100000000000001000013fe01080 +% 80000fa622bbfbbbbba000000000012220222022aaaaaaaaa8000000000000000000000000000000000c00000000000010000106601080 +% 80000df5555555555560000000000155555555555555555555555555555555555555555555555555555600000000000010000104201080 +% 80000da2a8ffeaeaeae000000000008000000000aaaaaaaaaa000000000000000000000000000000000180000000000010000106601080 +% 80000df355557555555000000000005555555555d555555555111111111111111111111111111111111140000000000010000103c01080 +% 80000fa2227bbbbbbbb0000000000022222222226aaaaaaaaa800000000000000000000000000000000030000000000010000100001080 +% 80000df7557555555558000000000035555555557555555555555555555555555555555555555555555558000000000010000100001080 +% 80000da188bffeaeeea8000000000010000000001aaaaaaaaaa00000000000000000000000000000000004000000000010000100001080 +% 80000df155755555555800000000000d555555555d55555555515151515151515151515151515151515153000000000010000100001080 +% 80000fa1223bfbbbbbbc0000000000082020202026aaaaaaaaa80000000000000000000000000000000000800000000010000100801080 +% 80000df555555d555554000000000005555555555555555555555555555555555555555555555555555555600000000010000100801080 +% 80001da1a8bffaeaeaea0000000000020000000002aaaaaaaaaa0000000000000000000000000000000000100000000010000100801080 +% 80002df1d5555d5555560000000000035555555555555555555511111111111111111111111111111111111c0000000010000100001080 +% 80004fa0a22bbfbbbbba0000000000012222222222aaaaaaaaaa8000000000000000000000000000000000020000000010000100001080 +% 80008df5d55d55555555000000000000d55555555555555555555555555555555555555555555555555555558000000010000107fc1080 +% 80008fa08a8ffeeeaeef00000000000080000000002aaaaaaaaaa000000000000000000000000000000000004000000010000100201080 +% 80004df1d55d55555555000000000000555555555575555555555111511151115111511151115111511151116000000010000100201080 +% 80002fa0a22bffbbbbbb00000000000060222022203aaaaaaaaab000000000000000000000000000000000001800000010000100201080 +% 80001df5d55d57555555800000000000355555555555555555555d55555555555555555555555555555555555400000010000107e01080 +% 80000da0a8affeeaeaea80000000000020000000000aaaaaaaaaac00000000000000000000000000000000000200000010000100001080 +% 80000df1d55d5755555580000000000035555555555d555555555511111111111111111111111111111111111100000010000100001080 +% 80000fa0a22bbbbbbbbb800000000000122222222226aaaaaaaaaa00000000000000000000000000000000000080000010000107fc1080 +% 80000df5d55d57555555800000000000155555555555555555555555555555555555555555555555555555555560000010000100441080 +% 80000da0888ffeaeeeae800000000000080000000002aaaaaaaaaa80000000000000000000000000000000000010000010000100441080 +% 80000df1d55d575555554000000000000d55555555575555555555d1515151515151515151515151515151515158000010000100441080 +% 80000fa0a22bfbbbbbbbc00000000000082020202021aaaaaaaaaac0000000000000000000000000000000000004000010000100441080 +% 80000df5d55d57555555400000000000055555555555d55555555575555555555555555555555555555555555557000010000103cc1080 +% 80000da0a8affeeaeaeac00000000000040000000000aaaaaaaaaaa0000000000000000000000000000000000000800010000107b81080 +% 80000df1d55557555555400000000000035555555555555555555551111111111111111111111111111111111111400010000100001080 +% 80000fa0a227bbbbbbbbc000000000000222222222226aaaaaaaaaa8000000000000000000000000000000000000200010000100001080 +% 80000df5d5555755555560000000000003555555555575555555555d555555555555555555555555555555555555580010000100001080 +% 80000fa08a8ffeeeaeeea000000000000100000000002aaaaaaaaaac000000000000000000000000000000000000040010000100001080 +% 80000df1d55555555555600000000000015555555555555555555557511151115111511151115111511151115111520010000100801080 +% 80000fa0a227fbbbbbbba0000000000000a2202220223aaaaaaaaaab000000000000000000000000000000000000010010000100801080 +% 80000df5d5555555555560000000000000d5555555555d555555555555555555555555555555555555555555555555c010000100801080 +% 80001da0a8afffeaeaeae000000000000080000000000aaaaaaaaaaa800000000000000000000000000000000000002010000100001080 +% 80002df1d55555555555500000000000005555555555555555555555511111111111111111111111111111111111111010000100001080 +% 80004fa0a227bbbbbbbbb0000000000000622222222222aaaaaaaaaac00000000000000000000000000000000000000810000107e41080 +% 80008df5d55555d555555800000000000035555555555755555555557d5555555555555555555555555555555555555410000100001080 +% 80008fd0688bff7eeeaeee000000000000400000000002aaaaaaaaaaabf000000000000000000000000000000000001810000100001080 +% 80004fb97d55559d555555800000000000d555555555555555555555555ff1515151515151515151515151515151516010000100101080 +% 80002ee43e22fbc3bbbbbbf0000000000120202020202aaaaaaaaaaaaaaabf800000000000000000000000000000018010000100101080 +% 80001ff57dd555407555555c000000000155555555555d55555555555555557f5555555555555555555555555555560010000107f81080 +% 80000ffa1fe8bfe00eeaeaeb000000000200000000001aaaaaaaaaaaaaaaaaaafc00000000000000000000000000080010000100001080 +% 80000fdd1f7d5d7111d55555e00000000555555555555555555555555555555557f9111111111111111111111111300010000100001080 +% 80000ffe8ffe27b0003bbbbbb80000000622222222222aaaaaaaaaaaaaaaaaaaaaafe00000000000000000000000c00010000100001080 +% 80000fd55ff7575404075555570000000d55555555557555555555555555555555555fd555555555555555555557000010000104001080 +% 80000fff27ffcbf80000eeeeaec000001000000000006aaaaaaaaaaaaaaaaaaaaaaaaabf0000000000000000000c000010000100001080 +% 80000ff5f7ff75d911113d5555700000155555555555d555555555555555555555555555ff115111511151115130000010000100001080 +% 80000ffbf3fffe7c000007bbbbbe0000202220222022aaaaaaaaaaaaaaaaaaaaaaaaaaaaabf800000000000000c0000010000100001080 +% 83c00ff57fff5776404040f55555800055555555555555555555555555555555555555555557f555555555555700000010000103f81080 +% 86f00ffff5ffffbe0000001eeaeae000800000000001aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafc0000000000c00000010000106181080 +% 84501ff56ffff77d11111113d5555c00d5555555555755555555555555555555555555555555557f111111113000000010000104081080 +% 84502ffbbbfffffb000000007bbbbb01222222222222aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafe0000004000000010000106181080 +% 83a04ffd5dfff557c40444044d5555e355555555555555555555555555555555555555555555555555fd55558000000010000103f01080 +% 80008ffffeffffff8000000003aeeeba00000000000aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaff0060000000010000100001080 +% 80008ffd577ffd75d11111111155555d555555555575555555555555555555555555555555555555555ff9780000000010000100001080 +% 8400cffbfdffffff80000000007bbbb02020202021eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabffe007800000000010000100001080 +% 80002ff55ffff5574040404040d555d555555555575555555555555555555555555555555555fffd5555f8000000000010000100001080 +% 83c01ffff7fffffe0000000001eaeb00000000003aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabfff0000000f00000000000010000100801080 +% 86300ff5fffff77f1111111111555d5555555555d55555555555555555555555555557fff111111111f000000000000010000100801080 +% 84100ffbbffffffc0000000003bbb2222222222eaaaaaaaaaaaaaaaaaaaaaaaaaafff800000000001f0000000000000010000100801080 +% 84300fd77ffd555c040404040555d5555555557555555555555555555555555fff55555555555555e00000000000000010000100001080 +% 83e00ffefffffff80000000006ef0000000001aaaaaaaaaaaaaaaaaaaaafffe0000000000000001e000000000000000010000100001080 +% 80000fddfff77751111111111d5d555555555f555555555555555555fff9511151115111511153e0000000000000000010000106e01080 +% 80000fb7ffffffa0000000000bb2202220227aaaaaaaaaaaaaaabfff000000000000000000003c00000000000000000010000104a01080 +% 80001f7fffd55d404040404055d555555557d5555555555557ffd55555555555555555555557c000000000000000000010000105a01080 +% 80002fdfffffffc0000000002b000000001eaaaaaaaaaafff80000000000000000000000007c0000000000000000000010000107201080 +% 80004fffff777591111111113d55555555755555557fff1111111111111111111111111117800000000000000000000010000100001080 +% 80008fbfffffbb00000000007222222223aaaaafffc0000000000000000000000000000078000000000000000000000010000100001080 +% 80008d7ff555550444044404d55555555d5555fd5555555555555555555555555555555780000000000000000000000010000106e01080 +% 80004dfffffffe0000000000800000001aaaab000000000000000000000000000000001800000000000000000000000010000104a01080 +% 80002d7ff5755711111111115555555575555751515151515151515151515151515151e000000000000000000000000010000105a01080 +% 80001dfffffffa0000000003202020206aaaac000000000000000000000000000000070000000000000000000000000010000107201080 +% 80000d7ff55556404040404755555555d5555d555555555555555555555555555555780000000000000000000000000010000100001080 +% 80000dbffffffc000000000400000003aaaaa0000000000000000000000000000000c00000000000000000000000000010000100201080 +% 80000d7fff7755111111111d55555555555551111111111111111111111111111117000000000000000000000000000010000107f81080 +% 80000fbfffffbc000000001a2222222aaaaa80000000000000000000000000000038000000000000000000000000000010000104201080 +% 80000d7ffd57540404040415555555555555555555555555555555555555555555c0000000000000000000000000000010000103c01080 +% 80000dbffffff800000000300000002aaaaa00000000000000000000000000000600000000000000000000000000000010000106601080 +% 80000d7ffd7759111111117555555555555551115111511151115111511151117800000000000000000000000000000010000104201080 +% 80000dbffffff800000000e2202220aaaab80000000000000000000000000001c000000000000000000000000000000010000104201080 +% 80000d7ffd575840404040d555555755557555555555555555555555555555560000000000000000000000000000000010000106601080 +% 80000dbffffff80000000180000006aaaac000000000000000000000000000380000000000000000000000000000000010000107fc1080 +% 80000d7fff7751111111135555555d55559111111111111111111111111111c00000000000000000000000000000000010000100001080 +% 80000fbfffffb0000000032222223aaaab000000000000000000000000000e000000000000000000000000000000000010000101801080 +% 80000d5ffd5554044404475555557555575555555555555555555555555570000000000000000000000000000000000010000103c01080 +% 80000dbffffff00000000c0000006aaaac00000000000000000000000001c0000000000000000000000000000000000010000104a01080 +% 80000d5ffd757111111115555555d555595151515151515151515151515e00000000000000000000000000000000000010000104a01080 +% 80000dbfffffe000000018202022aaaaa00000000000000000000000007000000000000000000000000000000000000010000104e01080 +% 80000d5ffd5560404040755555555555555555555555555555555555558000000000000000000000000000000000000010000102c01080 +% 80000dbfffffe00000006000000aaaaa8000000000000000000000000e0000000000000000000000000000000000000010000100001080 +% 80001d5fff7551111111755555555555111111111111111111111111700000000000000000000000000000000000000010000107e01080 +% 80002fbfffffc0000000e222222aaaaa000000000000000000000003800000000000000000000000000000000000000010000100201080 +% 80004f5ffd5d44040405d5555555555d55555555555555555555555c000000000000000000000000000000000000000010000100201080 +% 80008eafffffc0000002800001aaaab0000000000000000000000070000000000000000000000000000000000000000010000100001080 +% 80008f5ffd7d91111113555557555571511151115111511151115380000000000000000000000000000000000000000010000107e01080 +% 80004eaffffb80000006202226aaaac0000000000000000000000c00000000000000000000000000000000000000000010000100201080 +% 80002f5ffd5dc040404b55555d5555d5555555555555555555557000000000000000000000000000000000000000000010000100201080 +% 80001eafffff8000000c00001aaaab00000000000000000000018000000000000000000000000000000000000000000010000100001080 +% 80000f5fff7d1111111d5555755557111111111111111111111e0000000000000000000000000000000000000000000010000100001080 +% 80000eaffffb0000002a22226aaaac00000000000000000000300000000000000000000000000000000000000000000010000100001080 +% 80000f5ffd55440444355555d5555d55555555555555555555c00000000000000000000000000000000000000000000010000100001080 +% 80000eafffff000000600001aaaab000000000000000000006000000000000000000000000000000000000000000000010000100001080 +% 80000f5ff577111111d5555755557151515151515151515158000000000000000000000000000000000000000000000010000100001080 +% 80000eaffffa000001602026aaaac0000000000000000000e0000000000000000000000000000000000000000000000010000100001080 +% 80000f57f576404041d5555d55555555555555555555555700000000000000000000000000000000000000000000000010000100001080 +% 80000eaffffe00000300002aaaaa0000000000000000001c00000000000000000000000000000000000000000000000010000100001080 +% 80000f57f77711111555555555551111111111111111116000000000000000000000000000000000000000000000000010000100001080 +% 80000eaffffc0000062222aaaaa80000000000000000038000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f57404040d555555555555555555555555555c0000000000000000000000000000000000000000000000000010000100001080 +% 80000eaffffc0000180002aaaaa00000000000000000700000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f55511111d55555555515111511151115111800000000000000000000000000000000000000000000000000010000100001080 +% 80000eaffff8000030222aaaaa80000000000000000e000000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f55840407555555555555555555555555570000000000000000000000000000000000000000000000000000010000100001080 +% 80000eabfff80000a0002aaaae0000000000000001c0000000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f7591111d555555559111111111111111600000000000000000000000000000000000000000000000000000010000100001080 +% 80000eabfff00001a223aaaab0000000000000003800000000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f5d44406d55755557555555555555555c000000000000000000000000000000000000000000000000000000010000100001080 +% 80000eabfff000030006aaaac0000000000000070000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f5d11117555d5555d1515151515151580000000000000000000000000000000000000000000000000000000010000100001080 +% 80000eabffe0000c203aaaab00000000000000e00000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f57f5e0404d5575555755555555555557000000000000000000000000000000000000000000000000000000000010000100001080 +% 80001eabffe00018006aaaac0000000000001c000000000000000000000000000000000000000000000000000000000010000100001080 +% 80002f55f771113555d5555911111111111160000000000000000000000000000000000000000000000000000000000010000100001080 +% 80004eabffa0005223aaaab000000000000380000000000000000000000000000000000000000000000000000000000010000100001080 +% 80008f55f54404755755557555555555555c00000000000000000000000000000000000000000000000000000000000010000100001080 +% 80008eabffc000a006aaaac000000000003000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80004f55f55111d55d5555915111511151c000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80002faaffc001623aaaab0000000000070000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80001fd5f54041d57555575555555555580000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000faaffc001802aaaaa0000000000600000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fd57f5113555555551111111111800000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000feaffc00322aaaaa8000000000e000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f757dc447555555555555555570000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000efabfc00602aaaab000000000c0000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f757dd11d575555715151515300000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fbabfc00c26aaaac00000000c00000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f5d5dc04d5d5555d55555557000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000feebfc0181aaaaa800000018000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f5f5fd11d755555111111160000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fbeafc0322aaaaa000000180000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fd75fe435555555555555e00000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fefafe060aaaaac000003000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fd5dff17555555951115c000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000ffbafa061aaaab0000030000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fd5d760d75555755555c0000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000feaefe086aaaaa0000700000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86c00fd57771dd555551111800000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85c00ffbbbe13aaaaa80006000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400ff577e755555555558000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400feefbe22aaaab00060000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 82400ff55df355555751780000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83800ffbbfe6aaaaac00c00000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87c00ff557e555555d57000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400ffaeeedaaaab00c000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400ff557ff55555170000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87c01ffbbbfeaaaaa180000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80002ffd55fd55555600000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83804ffeaefaaaaa9800000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86408ffd55f55555e000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84408ffbbbeaaaab8000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84404ffd557555550000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 82c02ffaeaeaaaaa0000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83801ffd55d555560000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86400ff7bbeaaaaa0000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84400ff555d555540000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84400ff6efaaaaac0000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83800ff555d555540000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000ff7bbaaaaac0000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87c00fe5555555580000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80400fe6ebaaaaa80000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80400ff5575555580000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87c00fe7baaaaab00000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000fe5575555500000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83800fc6aeaaaab00000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86400fd5575555600000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84400fc7beaaaaa00000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84400fc55d5555600000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87f00f86eeaaaac00000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86c00f955d5555400000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85c00f87baaaaac00000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400f875d5555800000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 85400f82faaaaa800000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 82400f13555555800000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f03baaaab000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f43755555000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f02faaaab000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000f13755555000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8fe00e03eaaaaa000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 98300e07755556000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000e02eaaaaa000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87f00f13d55554000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80600c03eaaaac000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87800c43d55554000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 86000c02aaaaa8000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 81c01d13d55558000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80702c03aaaaa8000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87f04c07555550000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80008801aaaab0000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80008913555560000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83f04806aaab80000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 84002845555600000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8400180aaab800000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8400091d556000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 83f0081aab8000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000c35560000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8010086aac0000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80100955700000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 801008aac00000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87f009d7000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 801009ac000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80100b70000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 90100ec0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 98700d00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 87c00e00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000800000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000003fff9fffcfffe7fff1fffcfffe7fff3fff8fffe7fff3fff9fffc7fff3fff9fffcfffe3fff9fffcfffe7fff00010000100001080 +% 80000003fff95554d556555514044d556400135558d55655553fff955545555355590404d556200095554d556555500010000100001080 +% 80000003fff9fffc8a8a7fff10004eeea400120008aaaa40013fff9fffc48a93fff90004aeee200090004aaaa400100010000100001080 +% 80000003fff97574d556555511114d556400135558d55651513fff977545555355591114d556200095554d556511500010000100001080 +% 80000003fff9fffca2227bbb10004bbba400122228aaaa40013fff9fffc62233fbb90004bbba200090224aaaa400100010000100001080 +% 80000003fff95554d556555510404d556400135558d55655553fff955545555355594044d556200095554d556555500010000100001080 +% 80000003fff9fffca8aa7fff10004aeae400120008aaaa40013fff9fffc4a8b3fff90004eaea200090004aaaa400100010000100001080 +% 80000003fff97774d556555511114d556400135558d55651113fff977745555355591114d556200095554d556511100010000100001080 +% 80000003fff9fffca2227bbb10004bbba400122228aaaa40013fff9fffc62233bbb90004bbba200092224aaaa400100010000100001080 +% 80000003fff95554d556555514044d556400135558d55655553fff955545555355594404d556200095554d556555500010000100001080 +% 80000003fff9fffc888a7fff10004eaee400120008aaaa40013fff9fffc68893fff90004eeae200090004aaaa400100010000100001080 +% 80000003fff97574d556555511114d556400135558d55651513fff957545555355591114d556200095554d556551500010000100001080 +% 80000003fff9fffca2227bfb10004bbba400122028aaaa40013fff9fffc62233fbf90004bbba200090204aaaa400100010000100001080 +% 80000003fff95554d556555510404d556400135558d55655553fff955545555355594044d556200095554d556555500010000100001080 +% 80000003fff9fffcfffe7fff1fffcfffe7fff3fff8fffe7fff3fff9fffc7fff3fff9fffcfffe3fff9fffcfffe7fff00010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000380000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 800000004400fe003f801fc00fe007f001fc00fe007f003f800fe007f003f801fc007f003f801fc00fe003f801fc000010000100001080 +% 800000008201830060c0306018300c180306018300c18060c018300c18060c030600c18060c030601830060c0306000010000100001080 +% 80000000820000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8000000082002c00000001c0000000000084002c00000010800000000000b000580000000f000200010000000020000010000100001080 +% 80000000c6006f0000800f200020001000e6006f0001001cc00020001001bc00de0001001bc0038001c000080038000010000100001080 +% 800000007c00450000800a200020001000a200450001001440002000100114008a000100114002c001600008002c000010000100001080 +% 80000000000045001fc00f2007f003f800920045003f80124007f003f80114008a003f8011400fe007f001fc00fe000010000100001080 +% 8000000002003900000007c000000000008c003900000011800000000000e400720000000e800200010000000020000010000100001080 +% 80000000020001000b00058003c00110001c002c0000000040000000000038008400000010800440030004040058000010000100001080 +% 80000000020041001bc00de006f0031800f2006f00010010400020001001e400e60001001cc00c6004f0061c00de000010000100001080 +% 80000000fe007900114008a00450024800a200450001001e4000200010014400a200010014400920049001f0008a000010000100001080 +% 8000000002000d00114008a00450024800f20045003f80034007f003f801e40092003f801240092004900000008a000010004100001080 +% 80000000020003000e40072003a001f0007c003900000000c00000000000f8008c000000118007c003e000800072000010004100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000001980000000010004100001080 +% 80000000fe01010040402020010001100202010100000040400010008004040202002100404020201010013402020000107fc100001080 +% 800000001001870061c030e001c00318030e018700010061c0041000e0061c030e00398061c030e018700124030e000010004100001080 +% 8000000010007c001f000f800160024800f8007c0001001f00079000b001f000f80028801f000f8007c0012400f8000010004100001080 +% 8000000010006c00ff00040007f0024800000064003f80ff0000d003f8019000d800248008000c80000001c800d8000010004100001080 +% 80000000fe005c001b000cc0010001f000f80054000000190000300080015000b800230019800a8007c0000400b8000010000100001080 +% 8000000000005400110009a01010080800080054008080110010100808015000a800808013400a800400000c00a80000107fc100001080 +% 80000000000054001100092018700c380008005400c380110018700c38015000a800c38012400a800400003000a8000010020100001080 +% 80000000fe0024001f00092007c003e000f8007c003e000e0007c003e001f00048003e0012400f8007c001e00048000010020100001080 +% 800000009201040000000e400000000000080000000000000000000000000002080000001c800000000000380208000010020100001080 +% 800000009201380019000000000000000008000000360000000000036000e002700036000000070006c0000c02700000107e0100001080 +% 800000009200e0001500002007c003e000f8007c002e001f0007c002e0019001c0002e0000400c8005c0000001c0000010000100001080 +% 8000000092003800150000600400002000c80004002a000100040002a001100070002a0000c00880054000800070000010000100001080 +% 8000000000000400150001800400002000a80004002a000e00040002a001100008002a00030008800540019800080000107e0100001080 +% 80000000000000001f000f0007c003e000a8007c0012001f0007c0012001fc00000012001e000fe0024001340000000010400100001080 +% 80000000fe007c00000001c006c0002000a80000008200150006c0082000e000f8008200038007000380012400f8000010400100001080 +% 80000000120004001f00006005c0002000f8007c009c00150005c009c001900008009c0000c00c8007c001240008000010600100001080 +% 800000001200040001000400054003e0000000040070001f00054007000110000800700008000880054001c800080000107e0100001080 +% 8000000012007c0000000cc00540032000000004001c000000054001c0011000f8001c00198008800540000000f8000010000100001080 +% 80000000f20000001b0009a0024002a000fa007c000200ff000240002001fc000000020013400fe007c000040000000010000100001080 +% 80000000ee00040017000920038002a0000000000000001900038000000000000800000012400000100000040008000010000100001080 +% 8000000000007f001500092007c002a000f80038003e00110007c003e0007000fe003e00124003801000000400fe000010000100001080 +% 800000000000440015000e40054003e000080064000200110005400020008800880002001c800440100001fc0088000010400100001080 +% 8000000000007f000900000005400000000800440002000e0005400020010400fe000200000008201000000400fe000010780100001080 +% 80000000000004000e00002007c003f800f80044003e00190007c003e001040008003e00004008201000000400080000100f0100001080 +% 80000000000004001f000020000000c000000038000200150000000020010400080002000040082010000000000800001009c100001080 +% 8000000000007c001500002001c000c000000004003f801500100003f8018c00f8003f8000400c6007f001fc00f800001009c100001080 +% 800000000000000015000fe0022001a00000007f00220015001000022000c800000022001fc006400640012400000000100f0100001080 +% 80000000000100001f00002004100200000000440000001f00100000000070020000000000400380044001240200000010780100001080 +% 800000000001000000000020041001c000000064003f800000100003f800880200003f8000400440044001240200000010400100001080 +% 800000000001000000000000041003e0000000540002000000100000200104020000020000000820038001240200000010000100001080 +% 800000000001000000000fe0063002a0000000540002001f0017f00020010402000002001fc0082007f0000002000000107e0100001080 +% 800000000001000000000920032002a000000054003e000100064003e001040200003e0012400820064001fc0200000010400100001080 +% 80000000000100000000092001c003e00000007c0000001b0004400000018c020000000012400c60044000180200000010400100001080 +% 800000000000420000000920022000e00000000000800017000440080000c8008400000012400640044001e00084000010600100001080 +% 800000000000730000000920041001100000000400800015000380080001b000e6003f8012400d800380018000e60000107e0100001080 +% 800000000000510000000000041002080000007f008000150000000800017000a200200000000b800000007000a20000103c0100001080 +% 800000000000490000000000041002080000007c008000090007f008000150009200200000000a800000001c0092000013660100001080 +% 800000000000460000000fe0063002080000007c0080000e00064008000150008c0020001fc00a80000001fc008c000012420100001080 +% 8000000000000000000000c0032003180000005400a1001f0004400a100090000000000001800480000000000000000012420100001080 +% 800000000000c00000000f00038001900000005400398015000440039804000180003e801e002000000000000000000013fe0100001080 +% 800000000000000000000c00064000e00000007c0028801500038002880400000000000018002000000000000000000011fe0100001080 +% 80000000000064000000038004400110000000000024801f000000024804000000003e0007002000000000000000000010000100001080 +% 8000000000005400000000e0044002080000010000230000000c000230040000f800020001c02000000000000000000010000100001080 +% 800000000000540000000fe007f0020800000100000000000000000000040000800002001fc02000000000000000000010000100001080 +% 8000000000005400000000000000020800000100000000000006c0000004000080003e0000002000000000000000000010000100001080 +% 8000000000007c00000018000380031800000100006000000005c00600003000f800000030000180000000000000000010420100001080 +% 80000000000038000000000007c001900000010000000000000540000001e000d8001c0000000f00000000000000000010738100001080 +% 8000000000006400000000000540000000000100003e000000054003e001c000b8003e001b000e00000000000000000010588100001080 +% 800000000000440000000f80054001c000000000000200000002400020003000a8002a0017000180000000000000000010488100001080 +% 80000000000044000000080007c003200000007d00020000001040002001e000a8002a0015000f000000000000000000104c8100001080 +% 8000000000007f000000080006c0022000000000003e000000138003e001c00048003e0015000e00000000000000000010478100001080 +% 800000000000000000000f8005c002200000007c00020000000e0000200030007000000009000180000000000000000010000100001080 +% 800000000000380000000000054003f800000004000200000003800020000000f800000041000000000000000000000010210100001080 +% 800000000000640000000d80054001c000000004003e000000004003e001f000a80000004e000f80000000000000000010718100001080 +% 800000000000440000000b80024003e00000007c000000000000000000001000a800000038000080000000000000000010408100001080 +% 800000000000440000000a80038002a00000006c003200000007c0032001fc00f80000000e000fe0000000000000000010448100001080 +% 8000000000007f0000000a80064002a00000005c002a000000004002a000600000000000010003000000000000000000104c8100001080 +% 800000000000000000000480044003e000000054002a000000004002a000600200000000000003000000000000000000103b0100001080 +% 8000000000001c00000007000440000000000054002a00000007c002a000d002000000001f000680000000000000000010000100001080 +% 800000000000220000000f8002c0036000000024003e000000000003e00100020000000001000800000000000000000010000100001080 +% 800000000000410000000a80000002e000000000003f800000004003f80000020000000001000000000000000000000010000100001080 +% 800000000000410000000a8007c002a00000007c000c00000007f000c0030002000000001f000000000000000000000010000100001080 +% 800000000000410000000f80004002a000000004000c000000044000c00000020000000000000000000000000000000010000100001080 +% 8000000000006300000020000000012000000004001a000000000001a0000000fe00000001000000000000000000000010010100001080 +% 800000000000320000002000000001c00000007c002000000007f0020001f000c80000001fc00000000000000000000010010100001080 +% 8000000000001c000000200007d0032000000000001c000000004001c001000088000000110000000000000000000000107f8100001080 +% 8000000000002200000020003fc0022000000000003e000000004003e0010000880000001fc00000000000000000000010000100001080 +% 8000000000004100000020000640022000000000002a00000007c002a001f0007000000001000000000000000000000010000100001080 +% 8000000000004100000020000440016000000000002a000000000002a0000000fe00000001000000000000000000000010000100001080 +% 800000000000410000000fe00440000000000000003e00000007f003e001b000c80000001f000000000000000000000010008100001080 +% 800000000000630000000c80038003e0000000000000000000040000000170008800000000000000000000000000000010008100001080 +% 8000000000003200000008800040002000000000000e000000040000e00150008800000040000000000000000000000010708100001080 +% 8000000000006c000000088007f000000000000000110000000400011001500070000000400000000000000000000000101c8100001080 +% 8000000000005c0000000700044003e8000000000020800000000002080090000000000040000000000000000000000010028100001080 +% 800000000000540000000fe003801fe00000000000208000000000020800e0000000000040000000000000000000000010018100001080 +% 800000000000540000000c800640032000000000002080000007d0020801f0000000000040000000000000000000000010000100001080 +% 80000000000024000000088004400220000000000031800000000003180150000000000050800000000000000000000010420100001080 +% 8000000000010000000008800440022000000000001900000007c00190015000000000001cc00000000000000000000010000100001080 +% 800000000001000000000700038001c000000000000e000000004000e001f0000000000014400000000000000000000010000100001080 +% 80000000000100000000000000000000000000000011000000004001100400000000000012400000000000000000000010210100001080 +% 8000000000010000000000000000002000000000002080000007c002080400000000000011800000000000000000000010718100001080 +% 80000000000100000000000007c003f8000000000020800000038002080400000000000000000000000000000000000010408100001080 +% 8000000000010000000000000040022000000000002080000007c002080400000000000000000000000000000000000010448100001080 +% 8000000000000c000000000006c001c00000000000318000000540031804000000000000000000000000000000000000104c8100001080 +% 80000000000078000000000005c003200000000000190000000540019004000000000000000000000000000000000000103b0100001080 +% 8000000000007000000000000540022000000000001c00000007c001c001fc000000000000000000000000000000000010008100001080 +% 8000000000000c000000000005400220000000000032000000000003200190000000000000000000000000000000000010008100001080 +% 800000000000780000000000024001c0000000000022000000000002200110000000000000000000000000000000000010708100001080 +% 800000000000700000000000000000000000000000220000000000022001100000000000000000000000000000000000101c8100001080 +% 8000000000000c0000000000000003e000000000003f800000000003f800e0000000000000000000000000000000000010028100001080 +% 800000000000000000000000000000200000000000000000000000000001fc000000000000000000000000000000000010018100001080 +% 8000000000007c00000000000000036000000000001c000000000001c00190000000000000000000000000000000000010000100001080 +% 800000000000040000000000000002e000000000003e000000000003e00110000000000000000000000000000000000010000100001080 +% 8000000000007f0000000000000002a000000000002a000000000002a00110000000000000000000000000000000000010000100001080 +% 800000000000180000000000000002a000000000002a000000000002a000e0000000000000000000000000000000000010000100001080 +% 8000000000001800000000000000012000000000003e000000000003e00000000000000000000000000000000000000010420100001080 +% 80000000000034000000000000000000000000000036000000000003600000000000000000000000000000000000000010738100001080 +% 8000000000004000000000000000000000000000002e000000000002e00000000000000000000000000000000000000010588100001080 +% 8000000000000000000000000000000000000000002a000000000002a00000000000000000000000000000000000000010488100001080 +% 8000000000000000000000000000000000000000002a000000000002a000000000000000000000000000000000000000104c8100001080 +% 80000000000000000000000000000000000000000012000000000001200000000000000000000000000000000000000010478100001080 +% 8000000000000000000000000000000000000000001c000000000001c00000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000032000000000003200000000000000000000000000000000000000010000100001080 +% 800000000000000000000000000000000000000000220000000000022000000000000000000000000000000000000000103f8100001080 +% 80000000000000000000000000000000000000000022000000000002200000000000000000000000000000000000000010618100001080 +% 80000000000000000000000000000000000000000016000000000001600000000000000000000000000000000000000010408100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010618100001080 +% 8000000000000000000000000000000000000000003e000000000003e000000000000000000000000000000000000000103f0100001080 +% 80000000000000000000000000000000000000000002000000000000200000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 800000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000103f8100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010618100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010408100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010618100001080 +% 800000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000103f0100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010010100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010010100001080 +% 800000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000107f8100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000100001080 +% 8000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001ffffffffff080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% 80000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000080 +% ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff80 +%%EndImage +%%EndPreview +save +countdictstack +mark +newpath +/showpage {} def +/setpagedevice {pop} def +%%EndProlog +%%Page 1 1 + +-90 rotate +-756.000000 72.000000 translate +/HE10 /Helvetica findfont 10 scalefont def +/HE12 /Helvetica findfont 12 scalefont def +newpath +0 0 moveto +0 432.000000 rlineto +648.000000 0 rlineto +0 -432.000000 rlineto +closepath +0.500000 setlinewidth +stroke +newpath +5.000000 387.000000 moveto +0 40.000000 rlineto +638.000000 0 rlineto +0 -40.000000 rlineto +closepath +0.500000 setlinewidth +stroke +5.000000 407.000000 moveto +638.000000 0 rlineto +stroke +HE12 setfont +11.000000 413.000000 moveto +(cacheprof_p -ghc-timing +RTS -H10m -K10m -p -hR -i1.0 -sstderr +) show +HE12 setfont +11.000000 393.000000 moveto +(22,191,444 bytes x seconds (MUT)) +show +HE12 setfont +(Thu Aug 23 17:37 2001) +dup stringwidth pop +637.000000 +exch sub +393.000000 moveto +show +45.000000 20.000000 moveto +431.338567 0 rlineto +0.500000 setlinewidth +stroke +HE10 setfont +(seconds (MUT)) +dup stringwidth pop +476.338567 +exch sub +5.000000 moveto +show +45.000000 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(0.0) +dup stringwidth pop +2 div +45.000000 exch sub +5.000000 moveto +show +135.712632 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(2.0) +dup stringwidth pop +2 div +135.712632 exch sub +5.000000 moveto +show +226.425265 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(4.0) +dup stringwidth pop +2 div +226.425265 exch sub +5.000000 moveto +show +317.137897 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(6.0) +dup stringwidth pop +2 div +317.137897 exch sub +5.000000 moveto +show +45.000000 20.000000 moveto +0 362.000000 rlineto +0.500000 setlinewidth +stroke +gsave +HE10 setfont +(bytes) +dup stringwidth pop +382.000000 +exch sub +40.000000 exch +translate +90 rotate +0 0 moveto +show +grestore +45.000000 20.000000 moveto +-4 0 rlineto +stroke +HE10 setfont +(0k) +dup stringwidth +2 div +20.000000 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 56.751299 moveto +-4 0 rlineto +stroke +HE10 setfont +(500k) +dup stringwidth +2 div +56.751299 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 93.502598 moveto +-4 0 rlineto +stroke +HE10 setfont +(1,000k) +dup stringwidth +2 div +93.502598 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 130.253897 moveto +-4 0 rlineto +stroke +HE10 setfont +(1,500k) +dup stringwidth +2 div +130.253897 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 167.005196 moveto +-4 0 rlineto +stroke +HE10 setfont +(2,000k) +dup stringwidth +2 div +167.005196 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 203.756494 moveto +-4 0 rlineto +stroke +HE10 setfont +(2,500k) +dup stringwidth +2 div +203.756494 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 240.507793 moveto +-4 0 rlineto +stroke +HE10 setfont +(3,000k) +dup stringwidth +2 div +240.507793 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 277.259092 moveto +-4 0 rlineto +stroke +HE10 setfont +(3,500k) +dup stringwidth +2 div +277.259092 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 314.010391 moveto +-4 0 rlineto +stroke +HE10 setfont +(4,000k) +dup stringwidth +2 div +314.010391 exch sub +exch +40.000000 exch sub +exch +moveto +show +481.338567 30.238095 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 32.238095 moveto +(OTHER) show +481.338567 47.476190 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 49.476190 moveto +((57)synth_2,addCCs_wrk) show +481.338567 64.714286 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.600000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 66.714286 moveto +((15)parse) show +481.338567 81.952381 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.300000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 83.952381 moveto +((95)SYSTEM,use_bb) show +481.338567 99.190476 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.900000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 101.190476 moveto +((164)useCCdescriptors) show +481.338567 116.428571 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.400000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 118.428571 moveto +((133)makeCCdescriptors) show +481.338567 133.666667 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +1.000000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 135.666667 moveto +((29)main) show +481.338567 150.904762 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.700000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 152.904762 moveto +((55)annotate_insn) show +481.338567 168.142857 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.500000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 170.142857 moveto +((111)synth_2,makeCCdescr) show +481.338567 185.380952 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.800000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 187.380952 moveto +((27)preparse) show +481.338567 202.619048 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 204.619048 moveto +((117)use_bb,synthLine) show +481.338567 219.857143 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 221.857143 moveto +((114)synth_2,makeCCdescr) show +481.338567 237.095238 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.600000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 239.095238 moveto +((59)addCCs_wrk,use_bb) show +481.338567 254.333333 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.300000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 256.333333 moveto +((52)synth_2,use_bb) show +481.338567 271.571429 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.900000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 273.571429 moveto +((112)synthLine) show +481.338567 288.809524 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.400000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 290.809524 moveto +((62)SYSTEM,synth_2) show +481.338567 306.047619 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +1.000000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 308.047619 moveto +((43)addCCs_wrk) show +481.338567 323.285714 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.700000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 325.285714 moveto +((48)use_bb) show +481.338567 340.523810 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.500000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 342.523810 moveto +((1)SYSTEM) show +481.338567 357.761905 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.800000 setgray +fill +grestore +stroke +HE10 setfont +500.338567 359.761905 moveto +((45)synth_2) show +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 20.000000 lineto +125.280680 20.000000 lineto +160.658606 20.000000 lineto +191.954465 20.000000 lineto +221.889633 20.000000 lineto +249.556986 20.000000 lineto +275.410086 20.000000 lineto +298.541808 20.000000 lineto +316.230771 20.000000 lineto +330.291229 20.000000 lineto +356.144329 20.000000 lineto +386.533061 20.000000 lineto +421.457425 20.000000 lineto +459.556730 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 20.618304 lineto +421.457425 28.827368 lineto +386.533061 20.618304 lineto +356.144329 20.618304 lineto +330.291229 20.618304 lineto +316.230771 28.577459 lineto +298.541808 20.618304 lineto +275.410086 20.618304 lineto +249.556986 20.618304 lineto +221.889633 20.618304 lineto +191.954465 20.618304 lineto +160.658606 20.618304 lineto +125.280680 20.618304 lineto +88.542064 20.618304 lineto +45.000000 20.000000 lineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 20.618304 lineto +125.280680 20.618304 lineto +160.658606 20.618304 lineto +191.954465 20.618304 lineto +221.889633 20.618304 lineto +249.556986 20.618304 lineto +275.410086 20.618304 lineto +298.541808 20.618304 lineto +316.230771 28.577459 lineto +330.291229 20.618304 lineto +356.144329 20.618304 lineto +386.533061 20.618304 lineto +421.457425 28.827368 lineto +459.556730 20.618304 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 20.618304 lineto +421.457425 28.827368 lineto +386.533061 20.618304 lineto +356.144329 20.654467 lineto +330.291229 21.323929 lineto +316.230771 28.577459 lineto +298.541808 21.736719 lineto +275.410086 21.736719 lineto +249.556986 21.736719 lineto +221.889633 21.736719 lineto +191.954465 21.736719 lineto +160.658606 21.700556 lineto +125.280680 21.571780 lineto +88.542064 20.955240 lineto +45.000000 20.000000 lineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 20.955240 lineto +125.280680 21.571780 lineto +160.658606 21.700556 lineto +191.954465 21.736719 lineto +221.889633 21.736719 lineto +249.556986 21.736719 lineto +275.410086 21.736719 lineto +298.541808 21.736719 lineto +316.230771 28.577459 lineto +330.291229 21.323929 lineto +356.144329 20.654467 lineto +386.533061 20.618304 lineto +421.457425 28.827368 lineto +459.556730 20.618304 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 20.618304 lineto +421.457425 28.827368 lineto +386.533061 20.618304 lineto +356.144329 20.654467 lineto +330.291229 21.323929 lineto +316.230771 28.577459 lineto +298.541808 23.214416 lineto +275.410086 23.213534 lineto +249.556986 23.213534 lineto +221.889633 23.074761 lineto +191.954465 23.074761 lineto +160.658606 21.700556 lineto +125.280680 22.833966 lineto +88.542064 21.955757 lineto +45.000000 20.000000 lineto +closepath +gsave +0.600000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 21.955757 lineto +125.280680 22.833966 lineto +160.658606 21.700556 lineto +191.954465 23.074761 lineto +221.889633 23.074761 lineto +249.556986 23.213534 lineto +275.410086 23.213534 lineto +298.541808 23.214416 lineto +316.230771 28.577459 lineto +330.291229 21.323929 lineto +356.144329 20.654467 lineto +386.533061 20.618304 lineto +421.457425 28.827368 lineto +459.556730 20.618304 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 20.618304 lineto +421.457425 28.827368 lineto +386.533061 20.618304 lineto +356.144329 20.654467 lineto +330.291229 21.323929 lineto +316.230771 38.031951 lineto +298.541808 23.214416 lineto +275.410086 23.213534 lineto +249.556986 23.213534 lineto +221.889633 23.074761 lineto +191.954465 23.074761 lineto +160.658606 21.700556 lineto +125.280680 22.833966 lineto +88.542064 21.955757 lineto +45.000000 20.000000 lineto +closepath +gsave +0.300000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 21.955757 lineto +125.280680 22.833966 lineto +160.658606 21.700556 lineto +191.954465 23.074761 lineto +221.889633 23.074761 lineto +249.556986 23.213534 lineto +275.410086 23.213534 lineto +298.541808 23.214416 lineto +316.230771 38.031951 lineto +330.291229 21.323929 lineto +356.144329 20.654467 lineto +386.533061 20.618304 lineto +421.457425 28.827368 lineto +459.556730 20.618304 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.040972 lineto +421.457425 28.827368 lineto +386.533061 20.618304 lineto +356.144329 20.654467 lineto +330.291229 21.323929 lineto +316.230771 38.031951 lineto +298.541808 23.214416 lineto +275.410086 23.213534 lineto +249.556986 23.213534 lineto +221.889633 23.074761 lineto +191.954465 23.074761 lineto +160.658606 21.700556 lineto +125.280680 22.833966 lineto +88.542064 21.955757 lineto +45.000000 20.000000 lineto +closepath +gsave +0.900000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 21.955757 lineto +125.280680 22.833966 lineto +160.658606 21.700556 lineto +191.954465 23.074761 lineto +221.889633 23.074761 lineto +249.556986 23.213534 lineto +275.410086 23.213534 lineto +298.541808 23.214416 lineto +316.230771 38.031951 lineto +330.291229 21.323929 lineto +356.144329 20.654467 lineto +386.533061 20.618304 lineto +421.457425 28.827368 lineto +459.556730 31.040972 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.040972 lineto +421.457425 41.485985 lineto +386.533061 20.620068 lineto +356.144329 20.656231 lineto +330.291229 21.325693 lineto +316.230771 38.031951 lineto +298.541808 23.214416 lineto +275.410086 23.213534 lineto +249.556986 23.213534 lineto +221.889633 23.074761 lineto +191.954465 23.074761 lineto +160.658606 21.700556 lineto +125.280680 22.833966 lineto +88.542064 21.955757 lineto +45.000000 20.000000 lineto +closepath +gsave +0.400000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 21.955757 lineto +125.280680 22.833966 lineto +160.658606 21.700556 lineto +191.954465 23.074761 lineto +221.889633 23.074761 lineto +249.556986 23.213534 lineto +275.410086 23.213534 lineto +298.541808 23.214416 lineto +316.230771 38.031951 lineto +330.291229 21.325693 lineto +356.144329 20.656231 lineto +386.533061 20.620068 lineto +421.457425 41.485985 lineto +459.556730 31.040972 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.124282 lineto +386.533061 21.258364 lineto +356.144329 21.294528 lineto +330.291229 21.963989 lineto +316.230771 39.278849 lineto +298.541808 24.455433 lineto +275.410086 24.454551 lineto +249.556986 24.454551 lineto +221.889633 24.315779 lineto +191.954465 24.315779 lineto +160.658606 22.941574 lineto +125.280680 24.074984 lineto +88.542064 23.196775 lineto +45.000000 20.000000 lineto +closepath +gsave +1.000000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 23.196775 lineto +125.280680 24.074984 lineto +160.658606 22.941574 lineto +191.954465 24.315779 lineto +221.889633 24.315779 lineto +249.556986 24.454551 lineto +275.410086 24.454551 lineto +298.541808 24.455433 lineto +316.230771 39.278849 lineto +330.291229 21.963989 lineto +356.144329 21.294528 lineto +386.533061 21.258364 lineto +421.457425 42.124282 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.124282 lineto +386.533061 22.023968 lineto +356.144329 22.922757 lineto +330.291229 23.872705 lineto +316.230771 41.524501 lineto +298.541808 26.559960 lineto +275.410086 26.340334 lineto +249.556986 26.038679 lineto +221.889633 25.642353 lineto +191.954465 25.245439 lineto +160.658606 23.546647 lineto +125.280680 24.593618 lineto +88.542064 23.493137 lineto +45.000000 20.000000 lineto +closepath +gsave +0.700000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 23.493137 lineto +125.280680 24.593618 lineto +160.658606 23.546647 lineto +191.954465 25.245439 lineto +221.889633 25.642353 lineto +249.556986 26.038679 lineto +275.410086 26.340334 lineto +298.541808 26.559960 lineto +316.230771 41.524501 lineto +330.291229 23.872705 lineto +356.144329 22.922757 lineto +386.533061 22.023968 lineto +421.457425 42.124282 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 31.368500 lineto +356.144329 28.080582 lineto +330.291229 25.593548 lineto +316.230771 41.524501 lineto +298.541808 26.559960 lineto +275.410086 26.340334 lineto +249.556986 26.038679 lineto +221.889633 25.642353 lineto +191.954465 25.245439 lineto +160.658606 23.546647 lineto +125.280680 24.593618 lineto +88.542064 23.493137 lineto +45.000000 20.000000 lineto +closepath +gsave +0.500000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 23.493137 lineto +125.280680 24.593618 lineto +160.658606 23.546647 lineto +191.954465 25.245439 lineto +221.889633 25.642353 lineto +249.556986 26.038679 lineto +275.410086 26.340334 lineto +298.541808 26.559960 lineto +316.230771 41.524501 lineto +330.291229 25.593548 lineto +356.144329 28.080582 lineto +386.533061 31.368500 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 31.368500 lineto +356.144329 28.080582 lineto +330.291229 25.593548 lineto +316.230771 41.524501 lineto +298.541808 32.677140 lineto +275.410086 32.867659 lineto +249.556986 27.036551 lineto +221.889633 29.209581 lineto +191.954465 32.384894 lineto +160.658606 24.587738 lineto +125.280680 24.605379 lineto +88.542064 29.373933 lineto +45.000000 20.000000 lineto +closepath +gsave +0.800000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 29.373933 lineto +125.280680 24.605379 lineto +160.658606 24.587738 lineto +191.954465 32.384894 lineto +221.889633 29.209581 lineto +249.556986 27.036551 lineto +275.410086 32.867659 lineto +298.541808 32.677140 lineto +316.230771 41.524501 lineto +330.291229 25.593548 lineto +356.144329 28.080582 lineto +386.533061 31.368500 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 35.123306 lineto +356.144329 36.264949 lineto +330.291229 35.930071 lineto +316.230771 53.392818 lineto +298.541808 32.677140 lineto +275.410086 32.867659 lineto +249.556986 27.036551 lineto +221.889633 29.209581 lineto +191.954465 32.384894 lineto +160.658606 24.587738 lineto +125.280680 24.605379 lineto +88.542064 29.373933 lineto +45.000000 20.000000 lineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 29.373933 lineto +125.280680 24.605379 lineto +160.658606 24.587738 lineto +191.954465 32.384894 lineto +221.889633 29.209581 lineto +249.556986 27.036551 lineto +275.410086 32.867659 lineto +298.541808 32.677140 lineto +316.230771 53.392818 lineto +330.291229 35.930071 lineto +356.144329 36.264949 lineto +386.533061 35.123306 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 39.445259 lineto +356.144329 44.770669 lineto +330.291229 47.872773 lineto +316.230771 65.212036 lineto +298.541808 32.677140 lineto +275.410086 32.867659 lineto +249.556986 27.036551 lineto +221.889633 29.209581 lineto +191.954465 32.384894 lineto +160.658606 24.587738 lineto +125.280680 24.605379 lineto +88.542064 29.373933 lineto +45.000000 20.000000 lineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 29.373933 lineto +125.280680 24.605379 lineto +160.658606 24.587738 lineto +191.954465 32.384894 lineto +221.889633 29.209581 lineto +249.556986 27.036551 lineto +275.410086 32.867659 lineto +298.541808 32.677140 lineto +316.230771 65.212036 lineto +330.291229 47.872773 lineto +356.144329 44.770669 lineto +386.533061 39.445259 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 39.445259 lineto +356.144329 44.770669 lineto +330.291229 47.872773 lineto +316.230771 65.212036 lineto +298.541808 45.475412 lineto +275.410086 44.560452 lineto +249.556986 37.761462 lineto +221.889633 37.820558 lineto +191.954465 38.949558 lineto +160.658606 29.876397 lineto +125.280680 28.824428 lineto +88.542064 32.072361 lineto +45.000000 20.000000 lineto +closepath +gsave +0.600000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 32.072361 lineto +125.280680 28.824428 lineto +160.658606 29.876397 lineto +191.954465 38.949558 lineto +221.889633 37.820558 lineto +249.556986 37.761462 lineto +275.410086 44.560452 lineto +298.541808 45.475412 lineto +316.230771 65.212036 lineto +330.291229 47.872773 lineto +356.144329 44.770669 lineto +386.533061 39.445259 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 41.769117 lineto +356.144329 48.957965 lineto +330.291229 55.205392 lineto +316.230771 65.212036 lineto +298.541808 55.455301 lineto +275.410086 53.812665 lineto +249.556986 46.138112 lineto +221.889633 45.465122 lineto +191.954465 45.850276 lineto +160.658606 35.922721 lineto +125.280680 33.236054 lineto +88.542064 34.512353 lineto +45.000000 20.000000 lineto +closepath +gsave +0.300000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 34.512353 lineto +125.280680 33.236054 lineto +160.658606 35.922721 lineto +191.954465 45.850276 lineto +221.889633 45.465122 lineto +249.556986 46.138112 lineto +275.410086 53.812665 lineto +298.541808 55.455301 lineto +316.230771 65.212036 lineto +330.291229 55.205392 lineto +356.144329 48.957965 lineto +386.533061 41.769117 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.278637 lineto +386.533061 57.202311 lineto +356.144329 78.538645 lineto +330.291229 96.945459 lineto +316.230771 105.991277 lineto +298.541808 55.455301 lineto +275.410086 53.812665 lineto +249.556986 46.138112 lineto +221.889633 45.465122 lineto +191.954465 45.850276 lineto +160.658606 35.922721 lineto +125.280680 33.236054 lineto +88.542064 34.512353 lineto +45.000000 20.000000 lineto +closepath +gsave +0.900000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 34.512353 lineto +125.280680 33.236054 lineto +160.658606 35.922721 lineto +191.954465 45.850276 lineto +221.889633 45.465122 lineto +249.556986 46.138112 lineto +275.410086 53.812665 lineto +298.541808 55.455301 lineto +316.230771 105.991277 lineto +330.291229 96.945459 lineto +356.144329 78.538645 lineto +386.533061 57.202311 lineto +421.457425 42.278637 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.279519 lineto +386.533061 57.202311 lineto +356.144329 78.538645 lineto +330.291229 96.945459 lineto +316.230771 125.536500 lineto +298.541808 83.504186 lineto +275.410086 79.552981 lineto +249.556986 69.332298 lineto +221.889633 65.722732 lineto +191.954465 63.020776 lineto +160.658606 49.723863 lineto +125.280680 43.050415 lineto +88.542064 40.162351 lineto +45.000000 20.000000 lineto +closepath +gsave +0.400000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 40.162351 lineto +125.280680 43.050415 lineto +160.658606 49.723863 lineto +191.954465 63.020776 lineto +221.889633 65.722732 lineto +249.556986 69.332298 lineto +275.410086 79.552981 lineto +298.541808 83.504186 lineto +316.230771 125.536500 lineto +330.291229 96.945459 lineto +356.144329 78.538645 lineto +386.533061 57.202311 lineto +421.457425 42.279519 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.353610 lineto +386.533061 58.459793 lineto +356.144329 79.759964 lineto +330.291229 97.497317 lineto +316.230771 125.675567 lineto +298.541808 138.035176 lineto +275.410086 128.812658 lineto +249.556986 111.126757 lineto +221.889633 101.413535 lineto +191.954465 91.637396 lineto +160.658606 70.610949 lineto +125.280680 55.169523 lineto +88.542064 45.801764 lineto +45.000000 20.000000 lineto +closepath +gsave +1.000000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 45.801764 lineto +125.280680 55.169523 lineto +160.658606 70.610949 lineto +191.954465 91.637396 lineto +221.889633 101.413535 lineto +249.556986 111.126757 lineto +275.410086 128.812658 lineto +298.541808 138.035176 lineto +316.230771 125.675567 lineto +330.291229 97.497317 lineto +356.144329 79.759964 lineto +386.533061 58.459793 lineto +421.457425 42.353610 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 31.679269 lineto +421.457425 42.353610 lineto +386.533061 70.083200 lineto +356.144329 103.293144 lineto +330.291229 132.934977 lineto +316.230771 172.460852 lineto +298.541808 182.646548 lineto +275.410086 169.982933 lineto +249.556986 148.411390 lineto +221.889633 133.790548 lineto +191.954465 118.811600 lineto +160.658606 93.317371 lineto +125.280680 71.339506 lineto +88.542064 55.072500 lineto +45.000000 20.000000 lineto +closepath +gsave +0.700000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 55.072500 lineto +125.280680 71.339506 lineto +160.658606 93.317371 lineto +191.954465 118.811600 lineto +221.889633 133.790548 lineto +249.556986 148.411390 lineto +275.410086 169.982933 lineto +298.541808 182.646548 lineto +316.230771 172.460852 lineto +330.291229 132.934977 lineto +356.144329 103.293144 lineto +386.533061 70.083200 lineto +421.457425 42.353610 lineto +459.556730 31.679269 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 51.559663 lineto +421.457425 63.454442 lineto +386.533061 89.964183 lineto +356.144329 123.181477 lineto +330.291229 152.819782 lineto +316.230771 341.486250 lineto +298.541808 226.567291 lineto +275.410086 210.440821 lineto +249.556986 185.053905 lineto +221.889633 166.048486 lineto +191.954465 146.420940 lineto +160.658606 117.332434 lineto +125.280680 90.502222 lineto +88.542064 65.399909 lineto +45.000000 20.000000 lineto +closepath +gsave +0.500000 setgray +fill +grestore +stroke +45.000000 20.000000 moveto +45.000000 20.000000 lineto +88.542064 65.399909 lineto +125.280680 90.502222 lineto +160.658606 117.332434 lineto +191.954465 146.420940 lineto +221.889633 166.048486 lineto +249.556986 185.053905 lineto +275.410086 210.440821 lineto +298.541808 226.567291 lineto +316.230771 341.486250 lineto +330.291229 152.819782 lineto +356.144329 123.181477 lineto +386.533061 89.964183 lineto +421.457425 63.454442 lineto +459.556730 51.559663 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +476.338567 20.000000 lineto +459.556730 51.559663 lineto +421.457425 63.528532 lineto +386.533061 140.979690 lineto +356.144329 216.546240 lineto +330.291229 287.298665 lineto +316.230771 348.276126 lineto +298.541808 382.000000 lineto +275.410086 353.331635 lineto +249.556986 315.505140 lineto +221.889633 281.057412 lineto +191.954465 246.046949 lineto +160.658606 196.150446 lineto +125.280680 147.445272 lineto +88.542064 98.116209 lineto +45.000000 20.000000 lineto +closepath +gsave +0.800000 setgray +fill +grestore +stroke +84.542064 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +121.280680 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +156.658606 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +187.954465 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +217.889633 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +245.556986 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +271.410086 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +294.541808 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +312.230771 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +326.291229 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +352.144329 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +382.533061 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +417.457425 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +455.556730 20.000000 moveto +4.000000 -4.000000 rlineto +4.000000 4.000000 rlineto +closepath +gsave +1.0 setgray +fill +grestore +stroke +showpage +%%Trailer +cleartomark +countdictstack exch sub { end } repeat +restore +%%EOF diff --git a/docs/storage-mgt/code.sty b/docs/storage-mgt/code.sty new file mode 100644 index 00000000..f5ec2f59 --- /dev/null +++ b/docs/storage-mgt/code.sty @@ -0,0 +1,83 @@ + +% I have enclosed code.sty, which achieves 99% of what you want without +% the need for a separate preprocessor. At the start of your document +% you write "\makeatactive". From then on, inline code is written as @\x +% -> x_1 & y@. The only difference with what you are used to, is that +% instead of +% +% @ +% foo :: Int -> Int +% foo = \n -> n+1 +% @ +% +% you have to write +% +% \begin{code} +% foo :: Int -> Int +% foo = \n -> n+1 +% \end{code} +% +% and that you cannot use @ in \section{} and \caption{}. For the paper that occured twice, in which case I had to replace @...@ b y \texttt{...}. +% +% +% code.sty --- nice verbatim mode for code + +\def\icode{% + \relax\ifmmode\hbox\else\leavevmode\null\fi + \bgroup + %\begingroup + \@noligs + \verbatim@font + \verb@eol@error + \let\do\@makeother \dospecials + \@vobeyspaces + \frenchspacing + \@icode} +\def\@icode#1{% + \catcode`#1\active + \lccode`\~`#1% + \lowercase{\let~\icode@egroup}} +\def\icode@egroup{% + %\endgroup} + \egroup} + +% The \makeatactive command: +% makes @ active, in such a way that @...@ behaves as \icode@...@: +{ +\catcode`@=\active +\gdef\makeatactive{ + \catcode`@=\active \def@{\icode@} + % Since @ becomes active, it has to be taken care of in verbatim-modes: + \let\olddospecials\dospecials \def\dospecials{\do\@\olddospecials}} +} +% \gdef\makeatother{\g@remfrom@specials{\@}\@makeother\@} +\gdef\makeatother{\@makeother\@} + +\newcommand\codetabwidth{42pt} +{\catcode`\^^I=\active% +\gdef\@vobeytab{\catcode`\^^I\active\let^^I\@xobeytab}} +\def\@xobeytab{\leavevmode\penalty10000\hskip\codetabwidth} + +\begingroup \catcode `|=0 \catcode `[= 1 +\catcode`]=2 \catcode `\{=12 \catcode `\}=12 +\catcode`\\=12 |gdef|@xcode#1\end{code}[#1|end[code]] +|endgroup +\def\@code{\trivlist \item\relax + \if@minipage\else\vskip\parskip\fi + \leftskip\@totalleftmargin\rightskip\z@skip + \parindent\z@\parfillskip\@flushglue\parskip\z@skip + \@@par + \@tempswafalse + \def\par{% + \if@tempswa + \leavevmode \null \@@par\penalty\interlinepenalty + \else + \@tempswatrue + \ifhmode\@@par\penalty\interlinepenalty\fi + \fi}% + \obeylines \verbatim@font \@noligs + \let\do\@makeother \dospecials + \everypar \expandafter{\the\everypar \unpenalty}% +} +\def\code{\@code \frenchspacing\@vobeytab\@vobeyspaces \@xcode} +\def\endcode{\if@newlist \leavevmode\fi\endtrivlist} diff --git a/docs/storage-mgt/freelist.eepic b/docs/storage-mgt/freelist.eepic new file mode 100644 index 00000000..f87d9396 --- /dev/null +++ b/docs/storage-mgt/freelist.eepic @@ -0,0 +1,104 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(9912,7369)(0,-10) +\path(1125,6067)(2100,6067) +\path(1980.000,6037.000)(2100.000,6067.000)(1980.000,6097.000) +\path(5025,6367)(6000,6367)(6000,5167) + (5025,5167)(5025,6367) +\path(4650,6367)(5025,6367)(5025,5167) + (4650,5167)(4650,6367) +\path(3675,6367)(4650,6367)(4650,5167) + (3675,5167)(3675,6367) +\path(6600,6367)(7575,6367)(7575,5167) + (6600,5167)(6600,6367) +\path(8925,6367)(9900,6367)(9900,5167) + (8925,5167)(8925,6367) +\path(7575,6367)(8550,6367)(8550,5167) + (7575,5167)(7575,6367) +\path(8550,6367)(8925,6367)(8925,5167) + (8550,5167)(8550,6367) +\path(2100,6367)(3675,6367)(3675,5167) + (2100,5167)(2100,6367) +\path(2850,6217)(2850,6667)(6600,6667)(6600,6367) +\path(6570.000,6487.000)(6600.000,6367.000)(6630.000,6487.000) +\path(4425,6217)(4425,6967)(7575,6967)(7575,6367) +\path(7545.000,6487.000)(7575.000,6367.000)(7605.000,6487.000) +\path(5700,6217)(5700,7342)(8925,7342)(8925,6367) +\path(8895.000,6487.000)(8925.000,6367.000)(8955.000,6487.000) +\path(4350,5317)(4350,4792)(2100,4792)(2100,5167) +\path(2130.000,5047.000)(2100.000,5167.000)(2070.000,5047.000) +\path(5625,5317)(5625,4492)(2100,4492)(2100,5167) +\path(2130.000,5047.000)(2100.000,5167.000)(2070.000,5047.000) +\path(3000,5917)(3000,6667) +\path(5025,2842)(6000,2842)(6000,1642) + (5025,1642)(5025,2842) +\path(4650,2842)(5025,2842)(5025,1642) + (4650,1642)(4650,2842) +\path(3675,2842)(4650,2842)(4650,1642) + (3675,1642)(3675,2842) +\path(6600,2842)(7575,2842)(7575,1642) + (6600,1642)(6600,2842) +\path(8925,2842)(9900,2842)(9900,1642) + (8925,1642)(8925,2842) +\path(7575,2842)(8550,2842)(8550,1642) + (7575,1642)(7575,2842) +\path(8550,2842)(8925,2842)(8925,1642) + (8550,1642)(8550,2842) +\path(2100,2842)(3675,2842)(3675,1642) + (2100,1642)(2100,2842) +\path(2850,2692)(2850,3142)(6600,3142)(6600,2842) +\path(6570.000,2962.000)(6600.000,2842.000)(6630.000,2962.000) +\path(4425,2692)(4425,3442)(7575,3442)(7575,2842) +\path(7545.000,2962.000)(7575.000,2842.000)(7605.000,2962.000) +\path(5700,2692)(5700,3817)(8925,3817)(8925,2842) +\path(8895.000,2962.000)(8925.000,2842.000)(8955.000,2962.000) +\path(4350,1792)(4350,1267)(2100,1267)(2100,1642) +\path(2130.000,1522.000)(2100.000,1642.000)(2070.000,1522.000) +\path(5625,1792)(5625,967)(2100,967)(2100,1642) +\path(2130.000,1522.000)(2100.000,1642.000)(2070.000,1522.000) +\path(3000,2392)(3000,3142) +\path(2250,5317)(1650,5317)(1650,2542)(2100,2542) +\path(1980.000,2512.000)(2100.000,2542.000)(1980.000,2572.000) +\path(2250,1792)(1650,1792)(1650,142)(2325,142) +\path(2205.000,112.000)(2325.000,142.000)(2205.000,172.000) +\put(0,5992){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free\_list}}}}} +\put(8625,5917){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(4725,5767){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(3750,5242){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(5100,5242){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(2175,6142){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(2175,5842){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3750,6142){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(5100,6142){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(7800,6442){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(6825,6442){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(9150,6442){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(2175,5542){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_1$}}}}} +\put(3750,5842){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free=0}}}}} +\put(5100,5842){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free=0}}}}} +\put(8625,2392){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(4725,2242){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(3750,1717){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(5100,1717){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(2175,2617){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(2175,2317){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3750,2617){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(5100,2617){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(7800,2917){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(6825,2917){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(9150,2917){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(3750,2317){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free=0}}}}} +\put(5100,2317){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free=0}}}}} +\put(2325,5242){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(2325,1717){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(2475,67){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}next block group}}}}} +\put(2175,2017){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_2$}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/freelist.fig b/docs/storage-mgt/freelist.fig new file mode 100644 index 00000000..d8debffd --- /dev/null +++ b/docs/storage-mgt/freelist.fig @@ -0,0 +1,116 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 5325 1725 6300 1725 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9225 1425 10200 1425 10200 2625 9225 2625 9225 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8850 1425 9225 1425 9225 2625 8850 2625 8850 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 1425 8850 1425 8850 2625 7875 2625 7875 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 10800 1425 11775 1425 11775 2625 10800 2625 10800 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 13125 1425 14100 1425 14100 2625 13125 2625 13125 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 11775 1425 12750 1425 12750 2625 11775 2625 11775 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 12750 1425 13125 1425 13125 2625 12750 2625 12750 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 1425 7875 1425 7875 2625 6300 2625 6300 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 1575 7050 1125 10800 1125 10800 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 8625 1575 8625 825 11775 825 11775 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 9900 1575 9900 450 13125 450 13125 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 8550 2475 8550 3000 6300 3000 6300 2625 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 9825 2475 9825 3300 6300 3300 6300 2625 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 1875 7200 1125 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9225 4950 10200 4950 10200 6150 9225 6150 9225 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8850 4950 9225 4950 9225 6150 8850 6150 8850 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 4950 8850 4950 8850 6150 7875 6150 7875 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 10800 4950 11775 4950 11775 6150 10800 6150 10800 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 13125 4950 14100 4950 14100 6150 13125 6150 13125 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 11775 4950 12750 4950 12750 6150 11775 6150 11775 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 12750 4950 13125 4950 13125 6150 12750 6150 12750 4950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 4950 7875 4950 7875 6150 6300 6150 6300 4950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 5100 7050 4650 10800 4650 10800 4950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 8625 5100 8625 4350 11775 4350 11775 4950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 9900 5100 9900 3975 13125 3975 13125 4950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 8550 6000 8550 6525 6300 6525 6300 6150 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 9825 6000 9825 6825 6300 6825 6300 6150 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 5400 7200 4650 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 6450 2475 5850 2475 5850 5250 6300 5250 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 6450 6000 5850 6000 5850 7650 6525 7650 +4 0 0 50 0 0 17 0.0000 4 195 825 4200 1800 free_list\001 +4 0 0 50 0 0 17 0.0000 4 30 180 12825 1875 ...\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8925 2025 ...\001 +4 0 0 50 0 0 17 0.0000 4 165 390 7950 2550 link\001 +4 0 0 50 0 0 17 0.0000 4 165 390 9300 2550 link\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 1650 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 1950 free\001 +4 0 0 50 0 0 17 0.0000 4 150 435 7950 1650 start\001 +4 0 0 50 0 0 17 0.0000 4 150 435 9300 1650 start\001 +4 0 0 50 0 0 17 0.0000 4 165 540 12000 1350 block\001 +4 0 0 50 0 0 17 0.0000 4 165 540 11025 1350 block\001 +4 0 0 50 0 0 17 0.0000 4 165 540 13350 1350 block\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 2250 blocks=n_1\001 +4 0 0 50 0 0 17 0.0000 4 165 645 7950 1950 free=0\001 +4 0 0 50 0 0 17 0.0000 4 165 645 9300 1950 free=0\001 +4 0 0 50 0 0 17 0.0000 4 30 180 12825 5400 ...\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8925 5550 ...\001 +4 0 0 50 0 0 17 0.0000 4 165 390 7950 6075 link\001 +4 0 0 50 0 0 17 0.0000 4 165 390 9300 6075 link\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 5175 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 5475 free\001 +4 0 0 50 0 0 17 0.0000 4 150 435 7950 5175 start\001 +4 0 0 50 0 0 17 0.0000 4 150 435 9300 5175 start\001 +4 0 0 50 0 0 17 0.0000 4 165 540 12000 4875 block\001 +4 0 0 50 0 0 17 0.0000 4 165 540 11025 4875 block\001 +4 0 0 50 0 0 17 0.0000 4 165 540 13350 4875 block\001 +4 0 0 50 0 0 17 0.0000 4 165 645 7950 5475 free=0\001 +4 0 0 50 0 0 17 0.0000 4 165 645 9300 5475 free=0\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 2550 link\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 6075 link\001 +4 0 0 50 0 0 17 0.0000 4 225 1650 6675 7725 next block group\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 5775 blocks=n_2\001 diff --git a/docs/storage-mgt/gen.eepic b/docs/storage-mgt/gen.eepic new file mode 100644 index 00000000..b50d6913 --- /dev/null +++ b/docs/storage-mgt/gen.eepic @@ -0,0 +1,57 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(9849,5907)(0,-10) +\path(3237,5562)(4212,5562)(4212,4062) + (3237,4062)(3237,5562) +\path(4212,5562)(5187,5562)(5187,4062) + (4212,4062)(4212,5562) +\path(5187,5562)(6162,5562)(6162,4062) + (5187,4062)(5187,5562) +\path(6162,5562)(7137,5562)(7137,4062) + (6162,4062)(6162,5562) +\put(5487,4737){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(4812,5712){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step[]}}}}} +\path(7812,2712)(9837,2712)(9837,2112) + (7812,2112)(7812,2712) +\put(7887,2862){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}END\_MUT\_LIST}}}}} +\path(6687,312)(7812,2412) +\path(7781.778,2292.056)(7812.000,2412.000)(7728.889,2320.389) +\path(6687,2412)(7812,2412) +\path(7692.000,2382.000)(7812.000,2412.000)(7692.000,2442.000) +\put(6012,312){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(6012,2412){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\path(4662,312)(5787,312) +\path(5667.000,282.000)(5787.000,312.000)(5667.000,342.000) +\path(3237,612)(5262,612)(5262,12) + (3237,12)(3237,612) +\path(4662,2412)(5787,2412) +\path(5667.000,2382.000)(5787.000,2412.000)(5667.000,2442.000) +\path(3237,2712)(5262,2712)(5262,2112) + (3237,2112)(3237,2712) +\put(3387,237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}mut\_link}}}}} +\put(3312,762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}StgMutClosure}}}}} +\put(3387,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}mut\_link}}}}} +\put(3312,2862){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}StgMutClosure}}}}} +\path(912,3012)(2487,3012)(2487,4887)(3237,4887) +\path(3117.000,4857.000)(3237.000,4887.000)(3117.000,4917.000) +\path(1212,2412)(3237,2412) +\path(3117.000,2382.000)(3237.000,2412.000)(3117.000,2442.000) +\path(1737,2112)(2487,2112)(2487,312)(3237,312) +\path(3117.000,282.000)(3237.000,312.000)(3117.000,342.000) +\path(12,3462)(1887,3462)(1887,1962) + (12,1962)(12,3462) +\put(87,3237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}no}}}}} +\put(237,3612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}generation}}}}} +\put(87,2937){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}steps}}}}} +\put(87,2637){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}n\_steps}}}}} +\put(87,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}mut\_list}}}}} +\put(87,2052){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}mut\_once\_list}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/gen.fig b/docs/storage-mgt/gen.fig new file mode 100644 index 00000000..086a3358 --- /dev/null +++ b/docs/storage-mgt/gen.fig @@ -0,0 +1,71 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +6 5250 900 9150 2775 +6 5250 1275 9150 2775 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 5250 1275 6225 1275 6225 2775 5250 2775 5250 1275 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6225 1275 7200 1275 7200 2775 6225 2775 6225 1275 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7200 1275 8175 1275 8175 2775 7200 2775 7200 1275 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8175 1275 9150 1275 9150 2775 8175 2775 8175 1275 +4 0 0 50 0 0 17 0.0000 4 30 360 7500 2100 ......\001 +-6 +4 0 0 50 0 0 17 0.0000 4 225 540 6825 1125 step[]\001 +-6 +6 5250 3750 11850 6825 +6 8025 3750 11850 6525 +6 9825 3750 11850 4725 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9825 4125 11850 4125 11850 4725 9825 4725 9825 4125 +4 0 0 50 0 0 17 0.0000 4 195 1815 9900 3975 END_MUT_LIST\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8700 6525 9825 4425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8700 4425 9825 4425 +4 0 0 50 0 0 17 0.0000 4 30 360 8025 6525 ......\001 +4 0 0 50 0 0 17 0.0000 4 30 360 8025 4425 ......\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6675 6525 7800 6525 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 5250 6225 7275 6225 7275 6825 5250 6825 5250 6225 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6675 4425 7800 4425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 5250 4125 7275 4125 7275 4725 5250 4725 5250 4125 +4 0 0 50 0 0 17 0.0000 4 195 900 5400 6600 mut_link\001 +4 0 0 50 0 0 17 0.0000 4 225 1515 5325 6075 StgMutClosure\001 +4 0 0 50 0 0 17 0.0000 4 195 900 5400 4500 mut_link\001 +4 0 0 50 0 0 17 0.0000 4 225 1515 5325 3975 StgMutClosure\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 2925 3825 4500 3825 4500 1950 5250 1950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3225 4425 5250 4425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 3750 4725 4500 4725 4500 6525 5250 6525 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2025 3375 3900 3375 3900 4875 2025 4875 2025 3375 +4 0 0 50 0 0 17 0.0000 4 120 240 2100 3600 no\001 +4 0 0 50 0 0 17 0.0000 4 225 1035 2250 3225 generation\001 +4 0 0 50 0 0 17 0.0000 4 210 480 2100 3900 steps\001 +4 0 0 50 0 0 17 0.0000 4 210 720 2100 4200 n_steps\001 +4 0 0 50 0 0 17 0.0000 4 195 825 2100 4500 mut_list\001 +4 0 0 50 0 0 17 0.0000 4 195 1395 2100 4785 mut_once_list\001 diff --git a/docs/storage-mgt/generation.eepic b/docs/storage-mgt/generation.eepic new file mode 100644 index 00000000..bea5a8c6 --- /dev/null +++ b/docs/storage-mgt/generation.eepic @@ -0,0 +1,62 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(8153,4017)(0,-10) +\path(5025,3687)(6375,3687) +\path(6255.000,3657.000)(6375.000,3687.000)(6255.000,3717.000) +\path(2775,3687)(4125,3687) +\path(4005.000,3657.000)(4125.000,3687.000)(4005.000,3717.000) +\path(1875,3912)(2775,3912)(2775,3462) + (1875,3462)(1875,3912) +\path(4125,3912)(5025,3912)(5025,3462) + (4125,3462)(4125,3912) +\path(6375,3912)(7275,3912)(7275,3462) + (6375,3462)(6375,3912) +\path(5025,2187)(6375,2187) +\path(6255.000,2157.000)(6375.000,2187.000)(6255.000,2217.000) +\path(2775,2187)(4125,2187) +\path(4005.000,2157.000)(4125.000,2187.000)(4005.000,2217.000) +\path(4125,2412)(5025,2412)(5025,1962) + (4125,1962)(4125,2412) +\path(6375,2412)(7275,2412)(7275,1962) + (6375,1962)(6375,2412) +\path(1875,2412)(2775,2412)(2775,1962) + (1875,1962)(1875,2412) +\path(1875,912)(2775,912)(2775,462) + (1875,462)(1875,912) +\path(7275,3687)(8025,3687)(8025,3012) + (2325,3012)(2325,2412) +\path(2295.000,2532.000)(2325.000,2412.000)(2355.000,2532.000) +\path(7275,2187)(8025,2187)(8025,1512)(5025,1512) +\path(5145.000,1542.000)(5025.000,1512.000)(5145.000,1482.000) +\path(4125,1512)(2325,1512)(2325,912) +\path(2295.000,1032.000)(2325.000,912.000)(2355.000,1032.000) +\path(2895.000,717.000)(2775.000,687.000)(2895.000,657.000) +\path(2775,687)(3525,687)(3525,12) + (2325,12)(2325,462) +\put(5550,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{7}{8.4}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3225,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}GC}}}}} +\put(1950,3612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step 0}}}}} +\put(4200,3612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step 1}}}}} +\put(6450,3612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step $S$}}}}} +\put(5550,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{7}{8.4}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3225,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}GC}}}}} +\put(4200,2112){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step 1}}}}} +\put(6450,2112){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step $S$}}}}} +\put(1950,2112){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step 0}}}}} +\put(1950,612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step 0}}}}} +\put(7800,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}GC}}}}} +\put(3225,837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}GC}}}}} +\put(4500,1512){\makebox(0,0)[lb]{\smash{{{\SetFigFont{7}{8.4}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(0,3612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}generation 0}}}}} +\put(0,2112){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}generation 1}}}}} +\put(0,612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}generation $G$}}}}} +\put(450,1512){\makebox(0,0)[lb]{\smash{{{\SetFigFont{7}{8.4}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/generation.fig b/docs/storage-mgt/generation.fig new file mode 100644 index 00000000..e91ed6d4 --- /dev/null +++ b/docs/storage-mgt/generation.fig @@ -0,0 +1,65 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9150 3150 10500 3150 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6900 3150 8250 3150 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6000 2925 6900 2925 6900 3375 6000 3375 6000 2925 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8250 2925 9150 2925 9150 3375 8250 3375 8250 2925 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 10500 2925 11400 2925 11400 3375 10500 3375 10500 2925 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9150 4650 10500 4650 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6900 4650 8250 4650 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8250 4425 9150 4425 9150 4875 8250 4875 8250 4425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 10500 4425 11400 4425 11400 4875 10500 4875 10500 4425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6000 4425 6900 4425 6900 4875 6000 4875 6000 4425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6000 5925 6900 5925 6900 6375 6000 6375 6000 5925 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 5 + 0 0 1.00 60.00 120.00 + 11400 3150 12150 3150 12150 3825 6450 3825 6450 4425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 11400 4650 12150 4650 12150 5325 9150 5325 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 8250 5325 6450 5325 6450 5925 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 0 1 5 + 0 0 1.00 60.00 120.00 + 6900 6150 7650 6150 7650 6825 6450 6825 6450 6375 +4 0 0 50 0 0 12 0.0000 4 15 270 9675 3000 ......\001 +4 0 0 50 0 0 17 0.0000 4 165 345 7350 3000 GC\001 +4 0 0 50 0 0 17 0.0000 4 225 570 6075 3225 step 0\001 +4 0 0 50 0 0 17 0.0000 4 225 570 8325 3225 step 1\001 +4 0 0 50 0 0 17 0.0000 4 225 585 10575 3225 step S\001 +4 0 0 50 0 0 12 0.0000 4 15 270 9675 4500 ......\001 +4 0 0 50 0 0 17 0.0000 4 165 345 7350 4500 GC\001 +4 0 0 50 0 0 17 0.0000 4 225 570 8325 4725 step 1\001 +4 0 0 50 0 0 17 0.0000 4 225 585 10575 4725 step S\001 +4 0 0 50 0 0 17 0.0000 4 225 570 6075 4725 step 0\001 +4 0 0 50 0 0 17 0.0000 4 225 570 6075 6225 step 0\001 +4 0 0 50 0 0 17 0.0000 4 165 345 11925 3000 GC\001 +4 0 0 50 0 0 17 0.0000 4 165 345 7350 6000 GC\001 +4 0 0 50 0 0 12 0.0000 4 15 270 8625 5325 ......\001 +4 0 0 50 0 0 17 0.0000 4 225 1215 4125 3225 generation 0\001 +4 0 0 50 0 0 17 0.0000 4 225 1215 4125 4725 generation 1\001 +4 0 0 50 0 0 17 0.0000 4 225 1275 4125 6225 generation G\001 +4 0 0 50 0 0 12 0.0000 4 15 270 4575 5325 ......\001 diff --git a/docs/storage-mgt/largeobjectpool.eepic b/docs/storage-mgt/largeobjectpool.eepic new file mode 100644 index 00000000..9c198fd2 --- /dev/null +++ b/docs/storage-mgt/largeobjectpool.eepic @@ -0,0 +1,70 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(10212,4689)(0,-10) +\path(6900,4362)(10200,4362)(10200,3162) + (6900,3162)(6900,4362) +\path(7020.000,3792.000)(6900.000,3762.000)(7020.000,3732.000) +\path(6900,3762)(10050,3762) +\path(9930.000,3732.000)(10050.000,3762.000)(9930.000,3792.000) +\path(10050,4362)(10050,3162) +\put(8100,4437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\put(7875,3912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single object}}}}} +\path(6900,2262)(10200,2262)(10200,1062) + (6900,1062)(6900,2262) +\path(7020.000,1692.000)(6900.000,1662.000)(7020.000,1632.000) +\path(6900,1662)(10050,1662) +\path(9930.000,1632.000)(10050.000,1662.000)(9930.000,1692.000) +\path(10050,2262)(10050,1062) +\put(8100,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\put(7875,1812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single object}}}}} +\path(2550,4062)(3375,4062) +\path(3255.000,4032.000)(3375.000,4062.000)(3255.000,4092.000) +\path(3405.000,1182.000)(3525.000,1212.000)(3405.000,1242.000) +\path(3525,1212)(2925,1212)(2925,12)(3375,12) +\path(3255.000,-18.000)(3375.000,12.000)(3255.000,42.000) +\path(3405.000,3282.000)(3525.000,3312.000)(3405.000,3342.000) +\path(3525,3312)(2925,3312)(2925,2112)(3375,2112) +\path(3255.000,2082.000)(3375.000,2112.000)(3255.000,2142.000) +\path(3375,4362)(4950,4362)(4950,3162) + (3375,3162)(3375,4362) +\path(4275,3912)(4275,4662) +\path(4950,4362)(5400,4362)(5400,3162) + (4950,3162)(4950,4362) +\path(5400,4362)(5850,4362)(5850,3162) + (5400,3162)(5400,4362) +\path(5850,4362)(6300,4362)(6300,3162) + (5850,3162)(5850,4362) +\path(3375,2262)(4950,2262)(4950,1062) + (3375,1062)(3375,2262) +\path(4125,2112)(4125,2562)(6900,2562)(6900,2262) +\path(6870.000,2382.000)(6900.000,2262.000)(6930.000,2382.000) +\path(4275,1812)(4275,2562) +\path(4950,2262)(5400,2262)(5400,1062) + (4950,1062)(4950,2262) +\path(5400,2262)(5850,2262)(5850,1062) + (5400,1062)(5400,2262) +\path(5850,2262)(6300,2262)(6300,1062) + (5850,1062)(5850,2262) +\path(4125,4212)(4125,4662)(6900,4662)(6900,4362) +\path(6870.000,4482.000)(6900.000,4362.000)(6930.000,4482.000) +\put(3600,12){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3450,4137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3450,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3450,3537){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_1$}}}}} +\put(3600,3237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(5550,3762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(3450,2037){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3450,1737){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3600,1137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(5550,1662){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(3450,1437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_2$}}}}} +\put(0,3987){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}g0s0-$>$large\_objects}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/largeobjectpool.fig b/docs/storage-mgt/largeobjectpool.fig new file mode 100644 index 00000000..6c49ff03 --- /dev/null +++ b/docs/storage-mgt/largeobjectpool.fig @@ -0,0 +1,82 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +6 9825 1125 13125 2625 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9825 1425 13125 1425 13125 2625 9825 2625 9825 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9825 2025 12975 2025 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12975 1425 12975 2625 +4 0 0 50 0 0 17 0.0000 4 165 630 11025 1350 blocks\001 +4 0 0 50 0 0 17 0.0000 4 225 1230 10800 1875 single object\001 +-6 +6 9825 3225 13125 4725 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9825 3525 13125 3525 13125 4725 9825 4725 9825 3525 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9825 4125 12975 4125 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12975 3525 12975 4725 +4 0 0 50 0 0 17 0.0000 4 165 630 11025 3450 blocks\001 +4 0 0 50 0 0 17 0.0000 4 225 1230 10800 3975 single object\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 5475 1725 6300 1725 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6450 4575 5850 4575 5850 5775 6300 5775 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6450 2475 5850 2475 5850 3675 6300 3675 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 1425 7875 1425 7875 2625 6300 2625 6300 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 1875 7200 1125 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 1425 8325 1425 8325 2625 7875 2625 7875 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8325 1425 8775 1425 8775 2625 8325 2625 8325 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8775 1425 9225 1425 9225 2625 8775 2625 8775 1425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 3525 7875 3525 7875 4725 6300 4725 6300 3525 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 3675 7050 3225 9825 3225 9825 3525 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 3975 7200 3225 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 3525 8325 3525 8325 4725 7875 4725 7875 3525 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8325 3525 8775 3525 8775 4725 8325 4725 8325 3525 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8775 3525 9225 3525 9225 4725 8775 4725 8775 3525 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 1575 7050 1125 9825 1125 9825 1425 +4 0 0 50 0 0 17 0.0000 4 30 360 6525 5775 ......\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 1650 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 1950 free\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 2250 blocks=n_1\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 2550 link\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8475 2025 ...\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 3750 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 4050 free\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 4650 link\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8475 4125 ...\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 4350 blocks=n_2\001 +4 0 0 50 0 0 17 0.0000 4 225 2010 2925 1800 g0s0->large_objects\001 diff --git a/docs/storage-mgt/ldv.eepic b/docs/storage-mgt/ldv.eepic new file mode 100644 index 00000000..aa41327a --- /dev/null +++ b/docs/storage-mgt/ldv.eepic @@ -0,0 +1,41 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(6036,3169)(0,-10) +\path(1692,3142)(1692,2692)(3342,2692) +\path(1692,2317)(1692,2692) +\path(1722.000,2572.000)(1692.000,2692.000)(1662.000,2572.000) +\path(4992,2317)(4992,2692) +\path(5022.000,2572.000)(4992.000,2692.000)(4962.000,2572.000) +\path(4992,2692)(4992,3142) +\path(3342,3142)(3342,2692)(4992,2692) +\path(3342,2317)(3342,2692) +\path(3372.000,2572.000)(3342.000,2692.000)(3312.000,2572.000) +\path(42,3142)(42,2692)(1692,2692) +\path(42,2317)(42,2692) +\path(72.000,2572.000)(42.000,2692.000)(12.000,2572.000) +\put(1992,2767){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}use}}}}} +\put(342,2767){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}lag}}}}} +\put(117,2092){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}created}}}}} +\put(3642,2767){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}drag}}}}} +\put(1767,2092){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}first used}}}}} +\put(3417,2092){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}last used}}}}} +\put(5067,2092){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}destroyed}}}}} +\path(4992,292)(4992,667) +\path(5022.000,547.000)(4992.000,667.000)(4962.000,547.000) +\path(4992,667)(4992,1117) +\path(1692,667)(3342,667)(4992,667) +\path(42,1117)(42,667)(1692,667) +\path(42,292)(42,667) +\path(72.000,547.000)(42.000,667.000)(12.000,547.000) +\put(117,67){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}created}}}}} +\put(5067,67){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}destroyed}}}}} +\put(1992,742){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}void}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/ldv.fig b/docs/storage-mgt/ldv.fig new file mode 100644 index 00000000..772411c2 --- /dev/null +++ b/docs/storage-mgt/ldv.fig @@ -0,0 +1,53 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +6 3600 3375 9675 4500 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 3 + 5325 3375 5325 3825 6975 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 5325 4200 5325 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8625 4200 8625 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 0 0 2 + 8625 3825 8625 3375 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 3 + 6975 3375 6975 3825 8625 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6975 4200 6975 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 3 + 3675 3375 3675 3825 5325 3825 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3675 4200 3675 3825 +4 0 0 50 0 0 17 0.0000 4 120 315 5625 3750 use\001 +4 0 0 50 0 0 17 0.0000 4 225 300 3975 3750 lag\001 +4 0 0 50 0 0 17 0.0000 4 165 705 3750 4425 created\001 +4 0 0 50 0 0 17 0.0000 4 225 435 7275 3750 drag\001 +4 0 0 50 0 0 17 0.0000 4 165 915 5400 4425 first used\001 +4 0 0 50 0 0 17 0.0000 4 165 840 7050 4425 last used\001 +4 0 0 50 0 0 17 0.0000 4 225 945 8700 4425 destroyed\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8625 6225 8625 5850 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 0 0 2 + 8625 5850 8625 5400 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 3 + 5325 5850 6975 5850 8625 5850 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 3 + 3675 5400 3675 5850 5325 5850 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3675 6225 3675 5850 +4 0 0 50 0 0 17 0.0000 4 165 705 3750 6450 created\001 +4 0 0 50 0 0 17 0.0000 4 225 945 8700 6450 destroyed\001 +4 0 0 50 0 0 17 0.0000 4 165 435 5625 5775 void\001 diff --git a/docs/storage-mgt/ldv.tex b/docs/storage-mgt/ldv.tex new file mode 100644 index 00000000..79f0f232 --- /dev/null +++ b/docs/storage-mgt/ldv.tex @@ -0,0 +1,695 @@ +\documentclass{article} +\usepackage{code,a4wide} + +\usepackage{graphics,epsfig,epic,eepic,epsfig} + +\setlength{\parskip}{0.25cm} +\setlength{\parsep}{0.25cm} +\setlength{\topsep}{0cm} +\setlength{\parindent}{0cm} +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + + +% Terminology +\newcommand{\block}{block} +\newcommand{\Block}{Block} +\newcommand{\segment}{segment} +\newcommand{\Segment}{Segment} +\newcommand{\step}{step} +\newcommand{\Step}{Step} + +\newcommand{\note}[1]{{\em $\spadesuit$ #1}} + +\begin{document} +\title{Implementation of Lag/Drag/Void/Use Profiling} +\author{Sungwoo Park \\ Simon Marlow} + +\makeatactive +\maketitle + +\section{Lag/Drag/Void/Use Profiling} + +\emph{Lag/Drag/Void/Use} (LDVU) profiling~\cite{RR} is a profiling technique +which yields a summary of the biography of all the dynamic closures created +during program execution. +In this profiling scheme, +the biography of a closure is determined by four important events associated +with the closure: \emph{creation}, \emph{first use}, +\emph{last use}, and \emph{destruction} (see Figure~\ref{fig-ldv}). +The intervals between these successive events correspond to three phases +for the closure: \emph{lag} (between creation and first use), +\emph{use} (between first use and last use), and +\emph{drag} (between last use and destruction). +If the closure is never used, it is considered to remain in the \emph{void} +phase all its lifetime. + +\begin{figure}[ht] +\begin{center} +\input{ldv.eepic} +\caption{The biography of a closure} +\label{fig-ldv} +\end{center} +\end{figure} + +The LDVU profiler regularly performs heap censuses during program execution. +Each time a heap census is performed, the LDVU profiler increments a global +time, which is used for timing all the events (such as creation and destruction +of a closure) occurring during program execution. +Hence, for instance, all closures creating between two successive heap censuses +have the same creation time and belong to the same \emph{generation}.\footnote{In +this document, a generation is related with heap censuses, not garbage collections +as in other profiling schemes.} +After the program terminates, it yields a post-mortem report on how much +of the \emph{live} graph is in one of the four phases at the moment of each +heap census. + +It must be emphasized that the LDVU profiler considers only live closures; +it should not take into consideration dead closures which do not constitute +the graph. Therefore, the result of LDVU profiling does not depend on the +frequency of garbage collections. + +This document describes the implementation of LDVU profiling on the Glasgow +Haskell Compiler runtime system.\footnote{Unless otherwise noted, all identifiers +are defined in @LdvProfile.c@}. + +\section{An Overview of the Implementation} + +Every closure is augmented with an additional word in its profiling header +to accommodate three additional pieces of information: +1) state flag indicating whether the closure has been used at least once or not. +2) creation time; 3) time of most recent use if any so far. +We refer to such a word as an LDV word. + +The LDVU profiler maintains a global time, stored in @ldvTime@. +It is incremented each time a heap census is performed. +During a heap census, the profiler scans all live closures and computes the +following: +1) the total size of all closures which have never been used; +2) the total size of all closures which have been used at least once +in the past.\footnote{There is another category of closures, namely, +\emph{inherently used} closures. We will explain +in Section~\ref{sec-heap-censuses}.} +It is not until the whole program execution finishes that the profiler +can actually decide the total size corresponding to each of the four phases for +a particular heap census. It is only when a closure is destroyed that the profiler +can determine how long the closure has been in a specific phase. +Therefore, it is not sufficient to perform heap censuses periodically in order to +compute the profiling statistics: the runtime system needs to intercept +all events associated with any closures and update necessary information. + +All events associated with closures are handled by one of the three +macros defined +in @includes/StgLdv.h@: @LDV_recordCreate()@, @LDV_recordUse()@, and +@LDV_recordDead()@. + +\begin{itemize} +\item{@LDV_recordCreate()@} is called when a closure is created and updates its +creation time field. + +\item{@LDV_recordUse()@} is called when a closure is used and updates its most recent +use time field. + +\item{@LDV_recordDead()@} is called when a closure @c@ is removed from the graph. +It does not update its LDV word (because @c@ is about to be destroyed). +Instead, it updates the statistics on LDVU profiling according to the following +observation: +if @c@ has never been used (which is indicated by the state flag in its LDV +word), +@c@ contributes to the void phase from its creation time to the last census +time; if @c@ was used at least once (which is also indicated by the state flag), +@c@ contributes to the @drag@ phase after its last use time. +\end{itemize} + +At the end of the program execution, the profiler performs a last census during +which all closures in the heap are declared to be dead and @LDV_recordDead()@ +is invoked on each of them. +Then, the profiler computes the final statistics. + +\section{LDV Words} + +We choose to share the LDV word for both retainer profiling and LDVU +profiling, which cannot take place simultaneously. +This is the reason why there is a +union structure inside the @StgProHeader@ structure. +The field @hp.ldvw@ in the @StgProfHeader@ structure corresponds to the LDV +word: +\begin{code} +typedef struct { + ... + union { + retainerSet *rs; // Retainer Set + StgWord ldvw; // Lag/Drag/Void Word + } hp; +} StgProfHeader; +\end{code} +For instance, the LDV word of a closure @c@ can now be accessed with +@c->header.prof.hp.ldvw@ (or by @LDVW(c)@ where @LDVW()@ is a macro in +@includes/StgLdvProf.h@). + +An LDV word is divided into three fields, whose position is specified +by three constants in @includes/StgLdvProf.h@: +\begin{itemize} +\item{@LDV_STATE_MASK@} corresponds to the state flag. +\item{@LDV_CREATE_MASK@} corresponds to the creation time. +\item{@LDV_LAST_MASK@} corresponds to the most recent use time. +\end{itemize} +The constant @LDV_SHIFT@ specifies how many bits are allocated for +creation time or most recent use time. +For instance, the creation time of a closure @c@ can be obtained by +@(LDVW(c) & LDV_CREATE_MASK) >> LDV_SHIFT@. + +The creation time field and the most recent use time field can be set only by the +macros @LDV_recordCreate()@ and @LDV_recordUse()@. +@LDV_recordCreate()@ must be called whenever a new dynamic closure is created, +and this is handily accomplished by rewriting the macro @SET_PROF_HDR()@ +(in @includes/ClosureMacros.h@) (we do not need to change @SET_STATIC_PROF_HDR()@ +because static closures are not involved in LDVU profiling at all): + +\begin{code} +#define SET_PROF_HDR(c,ccs_) \ + ((c)->header.prof.ccs = ccs_, \ + LDV_recordCreate((c))) +\end{code} + +There are a few cases in which the info table of a closure changes through +an explicit invocation of @SET_INFO()@ or a direct assignment to its @header.info@ +field: 1) an indirection closure is replaced by an old-generation +indirection closure; 2) a thunk is replaced by a blackhole; 3) a thunk is replaced +by an indirection closure when its evaluation result becomes available. + +\emph{We regard such a situation as +the destruction of an old closure followed by the creation of a new closure +at the same memory address.}\footnote{This would be unnecessary if the two closures +are of the same size, but it is not always the case. We choose to distinguish +the two closures for the sake of consistency.} +For instance, when an @IND_PERM@ closure is replaced by an @IND_OLDGEN_PERM@ +closures (during scavenging in @GC.c@), we wrap the invocation of @SET_INFO()@ with +the invocations of @LDV_recordDead()@ and @LDV_recordCreate()@ as follows +(@LDV_recordDead()@ requires the actual size of the closures being destroyed): + +\begin{code} + LDV_recordDead((StgClosure *)p, sizeofW(StgInd) - sizeofW(StgProfHeader)); + SET_INFO(((StgClosure *)p), &stg_IND_OLDGEN_PERM_info); + LDV_recordCreate((StgClosure *)p); +\end{code} + +\textbf{To do:} +A direct assignment to the @header.info@ field implies that its cost centre +field is not initialized. This is no problem in the case of @EVACUATED@ closures +because they will +not be used again after a garbage collection. However, I am not sure if this is safe +for @BLACKHOLE_BQ@ closures (in @StgMiscClosures.hc@) when retainer profiling, +which employs cost centre stacks, is going on. +If it is safe, please leave a comment there. + +@LDV_recordUse()@ is called on a closure whenever it is used, or \emph{entered}. +Its state flag changes if necessary to indicate that it has been used, and +the current global time is stored in its last use time field. + +\section{Global Time \texttt{ldvTime} and Retainer Profiling} + +The global time, stored in @ldvTime@, records the current time period. +It is initialized to $1$ and incremented after each time a heap census +is completed through an invocation of @LdvCensus()@. Note that each +value of @ldvTime@ represents a time \emph{period}, not a point in +time. + +All closures created between two successive invocations of +@LdvCensus()@ have the same creation time. If a closure is used at +least once between two successive heap censuses, we consider the +closure to be in the use phase during the corresponding time period +(because we just set its last use time field to the current value of +@ldvTime@ whenever it is used). Notice that a closure with a creation +time $t_c$ may be destroyed before the actual heap census for time +$t_c$ and thus may \emph{not} be observed during the heap census for +time $t_c$. Such a closure does not show up in the profile at all. + +In addition, the value of @ldvTime@ indicates which of LDVU profiling +and retainer profiling is currently active: during LDVU profiling, it +is initialized to $1$ in @initLdvProfiling()@ and then increments as +LDVU profiling proceeds; during retainer profiling, however, it is +always fixed to $0$. Thus, wherever a piece of code shared by both +retainer profiling and LDVU profiling comes to play, we usually need +to first examine the value of @ldvTime@ if necessary. For instance, +consider the macro @LDV_recordUse()@: + +\begin{code} +#define LDV_recordUse(c) \ + if (ldvTime > 0) \ + LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | ldvTime | LDV_STATE_USE; +\end{code} + +If retainer profiling is being performed, @ldvTime@ is equal to $0$, +and @LDV_recordUse()@ causes no side effect.\footnote{Due to this +interference with LDVU profiling, retainer profiling slows down a bit; +for instance, checking @ldvTime@ against $0$ in the above example +would always evaluate to @rtsFalse@ during retainer profiling. +However, this is the price to be paid for our decision not to employ a +separate field for LDVU profiling.} + +As another example, consider @LDV_recordCreate()@: + +\begin{code} +#define LDV_recordCreate(c) \ + LDVW((c)) = (ldvTime << LDV_SHIFT) | LDV_STATE_CREATE +\end{code} + +The above definition of @LDV_recordCreate()@ works without any problem +even for retainer profiling: during retainer profiling, +a retainer set field (@hp.ldvw@) must be initialized to a null pointer. +Since @ldvTime@ is fixed to $0$, @LDV_recordCreate()@ initializes +retainer set fields correctly. + +\section{Heap Censuses} +\label{sec-heap-censuses} + +The LDVU profiler performs heap censuses periodically by invoking the +function @LdvCensus()@. Because we need to know exactly which +closures in the heap are live at census time, we always precede the +census with a major garbage collection. + +During a census, we examine each closure one by one and compute the +following three quantities: + +\begin{enumerate} +\item the total size of all \emph{inherently used} closures. +\item the total size of all closures which have not been used (yet). +\item the total size of all closures which have been used at least once. +\end{enumerate} + +For most closures, a \emph{use} consists of entering the closure. For +unlifted objects which are never entered (eg. @ARR_WORDS@), it would +be difficult to determine their points of use because such points are +scattered around the implementation in various primitive operations. +For this reason we consider all unlifted objects as ``inherently +used''. The following types of closures are considered to be +inherently used: @TSO@, @MVAR@, @MUT_ARR_PTRS@, @MUT_ARR_PTRS_FROZEN@, +@ARR_WORDS@, @WEAK@, @MUT_VAR@, @MUT_CONS@, @FOREIGN@, @BCO@, and +@STABLE_NAME@. + +The three quantities are stored in an @LdvGenInfo@ array @gi[]@. +@gi[]@ is indexed by time period. For instance, @gi[ldvTime]@ stores +the three quantaties for the current global time period. The +structure @LdvGenInfo@ is defined as follows: + +\begin{code} +typedef struct { + ... + int inherentlyUsed; // total size of 'inherently used' closures + int notUsed; // total size of 'not used yet' closures + int used; // total size of 'used at least once' closures + ... +} LdvGenInfo; +\end{code} + +The above three quantities account for mutually exclusive sets of closures. +In other words, if a closure is not inherently used, it belongs to +either the second or the third. + +\subsection{Taking a Census of the Live Heap} + +During a heap census, we need to visit every live closure once, so we +perform a linear scan of the live heap after a major GC. We can take +advantage of the following facts to implement a linear scan for heap +censuses: + +\begin{itemize} +\item The nursery is empty. The small object pool and the large object pool, + however, may \emph{not} be empty. This is because the garbage collector + invokes @scheduleFinalizer()@ after removing dead closures, and + @scheduleFinalizer()@ may create new closures through @allocate()@. +\item @IND@, @IND_OLDGEN@, and @EVACUATED@ closures do not appear in +the live heap. +\end{itemize} + +There is one small complication when traversing the live heap: the +garbage collector may have replaced @WEAK@ objects with @DEAD_WEAK@ +objects, which have a smaller size and hence leave some space before +the next object. To avoid this problem we change the size of +@DEAD_WEAK@ objects to match that of @WEAK@ objects when profiling is +enabled (see @StgMiscClosures.hc@). + +\section{Destruction of Closures} + +In order to compute the total size of closures for each of the four +phases, we must report the destruction of every closure (except +inherently used closures) to the LDVU profiler by invoking +@LDV_recordDead()@. @LDV_recordDead()@ must not be called on any +inherently used closure because any invocation of @LDV_recordDead()@ +affects the statistics regarding void and drag phases, which no +inherently used closure can be in. + +@LDV_recordDead()@ updates two fields @voidNew@ and @dragNew@ in the +@LdvGenInfo@ array @gi[]@: + +\begin{code} +typedef struct { + ... + int voidNew; + int dragnew; + ... +} LdvGenInfo; +\end{code} + +@gi[ldvTime].voidNew@ accumulates the size of all closures satisfying +the following two conditions: 1) observed during the heap census at +time @ldvTime@; 2) now known to have been in the void phase at time +@ldvTime@. It is updated when a closure which has never been used is +destroyed. Suppose that a closure @c@ which has never been used is +about to be destroyed. If its creation time is $t_c$, we judge that +@c@ has been in the void phase all its lifetime, namely, from time +$t_c$ to @ldvTime@. Since @c@ will not be observed during the next +heap census, which corresponds to time @ldvTime@, @c@ contributes to +the void phase of times $t_c$ through @ldvTime@ - 1. Therefore, we +increase the @voidNew@ field of @gi[@$t_c$@]@ through @gi[ldvTime - 1]@ + by the size of @c@.\footnote{In the actual implementation, we +update @gi[$t_c$]@ and @gi[ldvTime]@ (not @gi[ldvTime@$ - $1@]@) only: +@gi[$t_c$]@ and @gi[ldvTime]@ are increased and decreased by the size +of @c@, respectively. After finishing the program execution, we can +correctly adjust all the fields as follows: @gi[$t_c$]@ is computed as +$\sum_{i=0}^{t_c}$@gi[$i$]@. } + +@gi[ldvTime].dragNew@ accumulates the size of all closures satisfying the following +two conditions: 1) observed during the heap census at time @ldvTime@; +2) now known to have been in the drag phase at time @ldvTime@. +It is updated when a closure which has been used at least once is destroyed. +Suppose that a closure @c@ which has been used last at time $t_l$ is about to +be destroyed. +We judge that @c@ has been in the drag phase from time $t_l + 1$ to +time @ldvTime@$ - 1$ (if $t_l + 1 > $@ldvTime@$ - 1$, nothing happens). +Therefore, we increase the @dragNew@ field of @gi[@$t_l + 1$@]@ through +@gi[ldvTime@$ - 1$@]@ +by the size of @c@.\footnote{As in the case of @voidNew@, we update +@gi[@$t_l + 1$@]@ and @gi[ldvTime]@ only.} + +Now we need to find out all the cases of closure destruction. +There are four cases in which a closure is destroyed: + +\begin{enumerate} +\item A closure is overwritten with a blackhole: + @UPD_BH_UPDATABLE()@ in @includes/StgMacros.h@, + @threadLazyBlackHole()@ and @threadSqueezeStack()@ in @GC.c@, + the entry code for @BLACKHOLE@ closures in @StgMiscClosures.hc@ (a + @BLACKHOLE@ closure is changed into a @BLACKHOLE_BQ@ closure). + We call either @LDV_recordDead()@ or @LDV_recordDead_FILL_SLOP_DYNAMIC()@. + +\item A weak pointer is overwritten with a dead weak pointer: + @finalizzeWeakzh_fast()@ in @PrimOps.hc@, + @finalizeWeakPointersNow()@ and @scheduleFinalizers()@ in @Weak.c@. + Since a weak pointer is inherently used, we do not call @LDV_recordDead()@. + +\item A closure is overwritten with an indirection closure: + @updateWithIndirection()@ and @updateWithPermIndirection()@ in @Storage.h@, + @scavenge()@ in @GC.c@, in which an @IND_PERM@ closure is explicitly replaced + with an @IND_OLDGEN_PERM@ closure during scavenging. + We call either @LDV_recordDead()@ or @LDV_recordDead_FILL_SLOP_DYNAMIC()@. + +\item Closures are removed permanently from the graph during garbage +collections. We locate and dispose of all dead closures by linearly +scanning the from-space right before tidying up. This is feasible +because any closures which is about to be removed from the graph still +remains in the from-space until tidying up is completed. The next +subsection explains how to implement this idea. +\end{enumerate} + +\subsection{Linear scan of the from-space during garbage collections} + +In order to implement linear scan of the from-space during a garbage collection +(before tidying up), +we need to take into consideration the following facts: + +\begin{itemize} +\item The pointer @free@ of a block in the nursery may incorrectly point to +a byte past its actual boundary. +This happens because +the Haskell mutator first increases @hpLim@ without comparing it with the +actual boundary when allocating fresh memory for a new closure. +@hpLim@ is later assigned to the pointer @free@ of the corresponding memory +block, which means that during a heap census, the pointer @hpLim@ may not +be trusted. +Notice that @hpLim@ is not available during LDVU profiling; it is valid +only during the Haskell mutator time. + +\item The from-space may well contain a good number of @EVACUATED@ closures, +and they must be skipped over. + +\item The from-space includes the nursery. +Furthermore, a closure in the nursery may not necessarily be adjacent to the next +closure because slop words may lie between the two closures; +the Haskell mutator may allocate more space than actually needed in the +nursery when creating a closure, potentially leaving slop words. +\end{itemize} + +The first problem is easily solved by limiting the scan up to the +actual block boundary for each nursery block (see +@processNurseryForDead()@). In other words, for a nursery block +descriptor @bd@, whichever of @bd->start@$ + $@BLOCK_SIZE_W@ and +@bd->free@ is smaller is used as the actual boundary. + +We solve the second problem by exploiting LDV words of @EVACUATED@ +closures: we store the size of an evacuated closure, which now resides +in the to-space, in the LDV word of the new @EVACUATED@ closure +occupying its memory. This is easily implemented by inserting a call +to the macro @SET_EVACUAEE_FOR_LDV()@ in @copy()@ and @copyPart()@ (in +@GC.c@). Thus, when we encounter an @EVACUATED@ closure while +linearly scanning the nursery, we can skip a correct number of words +by referring to its LDV word. + +The third problem could be partially solved by always monitoring @Hp@ +during the Haskell mutator time: whenever @Hp@ is increased, we fill +with zeroes as many words as the change of @HP@. Then, we could skip +any trailing zero words when linearly scanning the nursery. +Alternatively we could initialize the entire nursery with zeroes after +each garbage collection and not worry about any change made to @Hp@ +during the Haskell mutator time. The number of zero words to be +written to the nursery could be reduced in the first approach, for we +do not have to fill the header for a new closure. Nevertheless we +choose to employ the second approach because it simplifies the +implementation code significantly (see @resetNurseries()@ in +@Storage.c@). Moreover, the second approach compensates for its +redundant initialization cost by providing faster execution (due to a +single memory write loop in contrast to frequent memory write loops in +the first approach). Also, we attribute the initialization cost to +the runtime system and thus the Haskell mutator behavior is little +affected. + +There is further complication though: occasionally a closure is +overwritten with a closure of a smaller size, leaving some slop +between itself and the next closure in the heap. There are two cases: + +\begin{enumerate} +\item A closure is overwritten with a blackhole. +\item A closure is overwritten with an indirection closure. +\end{enumerate} + +In either case, an existing closure is destroyed after being replaced +with a new closure. If the two closures are of the same size, no slop +words are introduced and we only need to invoke @LDV_recordDead()@ on +the existing closure, which cannot be an inherently used closure. If +not, that is, the new closure is smaller than the existing closure +(the opposite cannot happen), we need to fill one or more slop words +with zeroes as well as invoke @LDV_recordDead()@ on the existing +closure. The macro @LDV_recordDead_FILL_SLOP_DYNAMIC()@ accomplishes +these two tasks: it determines the size of the existing closure, +invokes @LDV_recordDead()@, and fills the slop words with zeroes. +After excluding all cases in which the two closures are of the same +size, we invoke @LDV_recordDead_FILL_SLOP_DYNAMIC()@ only from: + +\begin{enumerate} +\item @threadLazyBlackHole()@ and @threadSqueezeStack()@ in @GC.c@ +(for lazy blackholing), +\item @UPD_BH_UPDATABLE()@ in +@includes/StgMacros.h@ (for eager blackholing, which isn't the +default), +\item @updateWithIndirection()@ and @updateWithPermIndirection()@ +in @Storage.h@.\footnote{Actually slop words created in +@updateWithIndirection()@ cannot survive major garbage collections. +Still we invoke @LDV\_recordDead\_FILL\_SLOP\_DYNAMIC()@ to support linear +scan of the heap during a garbage collection, which is discussed in the next +section.} +\end{enumerate} + +The linear scan of the from-space is initiated by the garbage +collector. From the function @LdvCensusForDead()@, every dead closure +in the from-space is visited through an invocation of +@processHeapClosureForDead()@. + +\subsection{Final scan of the heap} + +Since a closure surviving the final garbage collection is implicitly destroyed +when the runtime system shuts down, we must invoke @processHeapClosureForDead@ +on \emph{every} closure in the heap once more after the final garbage collection. +The function @LdvCensusKillAll()@, which is invoked from @shutdownHaskell()@ +in @RtsStartup.c@, traverses the entire heap and visits each closure. +It also stops LDVU profiling by resetting @ldvTime@ to $0$. + +It may be that after LDVU profiling stops, new closures may be created +and even garbage collections may be performed. +We choose to ignore these closures because they are all concerned about +finalizing weak pointers (in @finalizeWeakPointersNow()@). +It can be catastrophic to invoke @LdvCensusKillAll()@ after finishing +@finalizeWeakPointersNow()@: @finalizeWeakPointersNow()@ calls +@rts_evalIO()@, which is essentially initiating a new program execution, +and no assumptions made upon LDVU profiling hold any longer. + +\section{Time of Use} + +In order to yield correct LDVU profiling results, we must make sure +that @LDV_recordUse()@ be called on a closure whenever it is used; +otherwise, most of closures would be reported to be in the void phase. +@includes/StgLdvProf.h@ provides an entry macro @LDV_ENTER@ which +expands to @LDV_recordUse()@. The compiler arranges to invoke +@LDV_ENTER@ in the entry code for every dynamic closure it generates +code for (constructors, thunks and functions). We also have to add +@LDV_ENTER@ calls to the closures statically compiled into the RTS: +@PAP@s, @AP_UPD@s, standard thunk forms (in @StgStdThunks.hc@, and +several others in @StgMiscClosures.hc@. + +\section{Computing Final Statistics} + +After the final scan of the heap, we can accurately determine the total +size of closures in one of the four phases at the moment of each heap census. +The structure @LdvGenInfo@ is augmented with two additional fields +@voidTotal@ and @dragTotal@: + +\begin{code} +typedef struct { + ... + int voidTotal; + int dragTotal; + ... +} LdvGenInfo; +\end{code} + +@gi[@$i$@].voidTotal@ and @gi[@$i$@].dragTotal@ are computed +from @gi[@$i$@].voidNew@ and @gi[@$i$@].dragNew@, respectively.\footnote{Due +to a slight optimization described before, @gi[@$i$@].voidTotal@ is actually +computed as $\sum_{1 \leq j \leq i}$@gi[@$j$@].voidNew@. +@gi[@$i$@].dragTotal@ is computed in a similar way.} +Then, the total size of closures in the lag phase @gi[@$i$@].lagTotal@ is computed +as @gi[@$i$@].notUsed@$-$@gi[@$i$@].voidTotal@ (because any unused closure +is either in the void phase or in the lag phase). +Similarly, +the total size of closures in the use phase @gi[@$i$@].useTotal@ is computed +as @gi[@$i$@].used@$-$@gi[@$i$@].dragTotal@ (because any used closure +is either in the use phase or in the drag phase). +@endLdvProfiling()@, called from @endHeapProfiling@ in @ProfHeap.c@, computes these +final statistics. + +\section{Usage} + +The runtime system option @-hL@ tells the executable program to +perform LDVU profiling and produce a @.hp@ file: + +\begin{code} +$ Foo.out +RTS -hL +\end{code} + +The option @-i@ can be used to +specify a desired interval at which LDVU profiling is performed. +The default and minimum value is half a second: + +\begin{code} +$ Foo.out +RTS -hL -i2.5 -RTS +\end{code} + +The @.hp@ file can be supplied to the @hp2ps@ program to create a postscript +file showing the progress of LDVU profiling in a graph: + +\begin{code} +$ hp2ps Foo.hs +$ gv Foo.ps +\end{code} + +The horizontal axis of the graph is in the Haskell mutator time, which excludes +the runtime system time such as garbage collection time and LDVU profiling +time. +The Haskell mutator runs a bit slower than it would without performing +LDVU profiling, but the difference is minute. +Also, the timer employed to periodically perform retainer profiling +is not perfectly accurate. Therefore, the result may slightly vary for each +execution of retainer profiling. + +\textbf{To do:} Currently the LDVU profiling is not supported with @-G1@ option. + +\textbf{To do:} When we perform LDVU profiling, the Haskell mutator time seems to +be affected by @-S@ or @-s@ runtime option. For instance, the following +two options should result in nearly same profiling outputs, but +the second run (without @-Sstderr@ option) spends almost twice as +long in the Haskell mutator as the first run: +1) @+RTS -Sstderr -hL -RTS@; 2) @+RTS -hL -RTS@. +This is quite a subtle bug because this wierd phenomenon is not +observed in retainer profiling, yet the implementation of +@mut_user_time_during_LDV()@ is completely analogous to that of +@mut_user_time_during_RP()@. The overall shapes of the resultant graphs +are almost the same, though. + +\section{Files} + +This section gives a summary of changes made to the GHC in +implementing LDVU profiling. +Only three files (@includes/StgLdvProf.h@, @LdvProfile.c@, and +@LdvProfile.h@) are new, and all others exist in the GHC. + +@\includes@ directory: + +\begin{description} +\item[StgLdvProf.h] defines type @LdvGenInfo@, constants, and macros related +with LDVU profiling. +\item[ClosureMacros.h] changes macro @SET_PROF_HDR()@. +\item[Stg.h] includes th header file @StgLdvProf.h@. +\item[StgMacros.h] changes macros @UPD_BH_UPDATABLE()@. +\end{description} + +@\rts@ directory: + +\begin{description} +\item[GC.c] invokes @LdvCensusForDead()@ before tidying up, sets @hasBeenAnyGC@ to + @rtsTrue@, and changes @copy()@ and @copyPart()@. + Invokes @LDV_recordDead()@ and @LDV_recordDead_FILL_SLOP_DYNAMIC()@. +\item[Itimer.c] changes @handle_tick()@. +\item[LdvProfile.c] implements the LDVU profiling engine. +\item[LdvProfile.h] is the header for @LdvProfile.c@. +\item[PrimOps.hc] changes @finalizzeWeakzh_fast()@. +\item[ProfHeap.c] changes @initHeapProfiling()@ and @endHeapProfiling()@. +\item[Profiling.c] changes @initProfilingLogFile@ and @report_ccs_profiling()@. +\item[Proftimer.c] declares @ticks_to_retainer_ldv_profiling@, + @performRetainerLdvProfiling@, and @doContextSwitch@. +\item[Proftimer.h] is the header for @Proftimer.c@. Defines @PROFILING_MIN_PERIOD@, + which specifies the minimum profiling period and the default profiling period. +%\item[RtsAPI.c] implements @setProfileHeader()@. +\item[RtsFlags.c] + sets @RtsFlags.ProfFlags.doHeapProfile@, + adds a string to @usage_text[]@ in @setupRtsFlags()@. +\item[RtsFlags.h] defines constants @HEAP_BY_LDV@ and @LDVchar@. +\item[RtsStartup.c] changes @shutDownHaskell()@. +\item[Schedule.c] changes @schedule()@. +\item[Stats.c] + declares @LDV_start_time@, @LDV_tot_time@, @LDVe_start_time@, + @LDVe_tot_time@. + Changes @mut_user_time_during_GC()@, @mut_user_time()@, + @stat_startExit()@, + @stat_endExit()@, and + @stat_exit()@. + Defines + @mut_user_time_during_LDV()@, + @stat_startLDV()@, and + @stat_endLDV()@. +\item[Stats.h] is hte header for @Stats.c@. +\item[StgMiscClosures.hc] inserts entry macros in + @stg_IND_entry()@, @stg_IND_PERM_entry()@, @stg_IND_OLDGEN_entry()@, + @stg_IND_OLDGEN_PERM_entry()@, @stg_BLACKHOLE_entry()@, @stg_BLACKHOLE_BQ_entry()@, + and @stg_CAF_BLACKHOLE_entry()@. + Invokes @LDV_recordDead()@ in @stg_BLACKHOLE_entry@. + Redefines @stg_DEAD_WEAK_info@. +\item[Storage.c] changes @initStorage()@, @resetNurseries()@, and @allocNursery()@. +\item[Storage.h] changes @updateWithIndirection()@ and @updateWithPermIndirection()@. +\item[Updates.hc] inserts entry macros in @stg_PAP_entry()@ and @stg_AP_UPD_entry()@. +\item[Weak.c] changes @scheduleFinalizers()@. +\end{description} + +\bibliographystyle{plain} +\bibliography{reference} + +\end{document} diff --git a/docs/storage-mgt/megablock.eepic b/docs/storage-mgt/megablock.eepic new file mode 100644 index 00000000..92222694 --- /dev/null +++ b/docs/storage-mgt/megablock.eepic @@ -0,0 +1,35 @@ +\setlength{\unitlength}{0.00054167in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(6849,1539)(0,-10) +\put(687,1062){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(687,837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}descriptor}}}}} +\path(612,1512)(1737,1512)(1737,462) + (612,462)(612,1512) +\path(4062,1512)(5187,1512)(5187,462) + (4062,462)(4062,1512) +\path(12,1512)(6837,1512)(6837,462) + (12,462)(12,1512) +\path(2337,1512)(2337,462) +\path(132.000,192.000)(12.000,162.000)(132.000,132.000) +\path(12,162)(2337,162) +\path(2217.000,132.000)(2337.000,162.000)(2217.000,192.000) +\path(2457.000,192.000)(2337.000,162.000)(2457.000,132.000) +\path(2337,162)(6837,162) +\path(6717.000,132.000)(6837.000,162.000)(6717.000,192.000) +\path(2337,12)(2337,312) +\put(237,912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(1962,912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(2862,912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(5637,912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(4362,912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}block}}}}} +\put(312,237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}block descriptors}}}}} +\put(4212,237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{8}{9.6}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/megablock.fig b/docs/storage-mgt/megablock.fig new file mode 100644 index 00000000..8116c841 --- /dev/null +++ b/docs/storage-mgt/megablock.fig @@ -0,0 +1,40 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +65.00 +Single +-2 +1200 2 +6 3000 3675 4125 4725 +6 3075 3975 3900 4425 +4 0 0 50 0 0 12 0.0000 4 135 405 3075 4125 block\001 +4 0 0 50 0 0 12 0.0000 4 180 765 3075 4350 descriptor\001 +-6 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 3000 3675 4125 3675 4125 4725 3000 4725 3000 3675 +-6 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6450 3675 7575 3675 7575 4725 6450 4725 6450 3675 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2400 3675 9225 3675 9225 4725 2400 4725 2400 3675 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 4725 3675 4725 4725 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2400 5025 4725 5025 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4725 5025 9225 5025 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 4725 5175 4725 4875 +4 0 0 50 0 0 12 0.0000 4 15 135 2625 4275 ...\001 +4 0 0 50 0 0 12 0.0000 4 15 135 4350 4275 ...\001 +4 0 0 50 0 0 12 0.0000 4 15 270 5250 4275 ......\001 +4 0 0 50 0 0 12 0.0000 4 15 270 8025 4275 ......\001 +4 0 0 50 0 0 12 0.0000 4 135 405 6750 4275 block\001 +4 0 0 50 0 0 12 0.0000 4 180 1305 2700 4950 block descriptors\001 +4 0 0 50 0 0 12 0.0000 4 135 495 6600 4950 blocks\001 diff --git a/docs/storage-mgt/nursery.eepic b/docs/storage-mgt/nursery.eepic new file mode 100644 index 00000000..9b06c6e0 --- /dev/null +++ b/docs/storage-mgt/nursery.eepic @@ -0,0 +1,89 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(11262,7914)(0,-10) +\path(4575,7137)(6150,7137)(6150,5937) + (4575,5937)(4575,7137) +\path(5325,6987)(5325,7437)(7950,7437)(7950,7137) +\path(7920.000,7257.000)(7950.000,7137.000)(7980.000,7257.000) +\path(11025,7137)(11025,5937) +\path(5475,6687)(5475,7437) +\path(7950,7137)(11250,7137)(11250,5937) + (7950,5937)(7950,7137) +\path(5475,6687)(5475,7887)(11025,7887)(11025,7137) +\path(10995.000,7257.000)(11025.000,7137.000)(11055.000,7257.000) +\path(4725,6087)(4125,6087)(4125,5562) +\path(4095.000,5682.000)(4125.000,5562.000)(4155.000,5682.000) +\path(8070.000,6567.000)(7950.000,6537.000)(8070.000,6507.000) +\path(7950,6537)(11025,6537) +\path(10905.000,6507.000)(11025.000,6537.000)(10905.000,6567.000) +\path(4125,5112)(4125,4587)(4500,4587) +\path(4380.000,4557.000)(4500.000,4587.000)(4380.000,4617.000) +\path(4500,4662)(6075,4662)(6075,3462) + (4500,3462)(4500,4662) +\path(5250,4512)(5250,4962)(7875,4962)(7875,4662) +\path(7845.000,4782.000)(7875.000,4662.000)(7905.000,4782.000) +\path(5400,4212)(5400,4962) +\path(7875,4662)(11175,4662)(11175,3462) + (7875,3462)(7875,4662) +\path(4650,3612)(4050,3612)(4050,2112) +\path(4020.000,2232.000)(4050.000,2112.000)(4080.000,2232.000) +\path(5400,4212)(5400,5412)(7875,5412)(7875,4662) +\path(7845.000,4782.000)(7875.000,4662.000)(7905.000,4782.000) +\path(7995.000,4092.000)(7875.000,4062.000)(7995.000,4032.000) +\path(7875,4062)(9750,4062) +\path(9630.000,4032.000)(9750.000,4062.000)(9630.000,4092.000) +\path(9750,4662)(9750,3462) +\path(9150,2787)(9750,2787)(9750,3462) +\path(9780.000,3342.000)(9750.000,3462.000)(9720.000,3342.000) +\path(9525,2337)(11175,2337)(11175,3462) +\path(11205.000,3342.000)(11175.000,3462.000)(11145.000,3342.000) +\path(3300,4737)(3300,4362)(4500,4362) +\path(4380.000,4332.000)(4500.000,4362.000)(4380.000,4392.000) +\path(3375,7212)(3375,6837)(4575,6837) +\path(4455.000,6807.000)(4575.000,6837.000)(4455.000,6867.000) +\path(4050,1662)(4050,1137)(4425,1137) +\path(4305.000,1107.000)(4425.000,1137.000)(4305.000,1167.000) +\path(4425,1212)(6000,1212)(6000,12) + (4425,12)(4425,1212) +\path(5175,1062)(5175,1512)(7800,1512)(7800,1212) +\path(7770.000,1332.000)(7800.000,1212.000)(7830.000,1332.000) +\path(5325,762)(5325,1512) +\path(7800,1212)(11100,1212)(11100,12) + (7800,12)(7800,1212) +\path(5325,762)(5325,1962)(7800,1962)(7800,1212) +\path(7770.000,1332.000)(7800.000,1212.000)(7830.000,1332.000) +\put(4650,6912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(4650,6612){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(4800,6012){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(4650,6312){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(8625,7287){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(8625,6687){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\put(3900,5337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(4575,4437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(4575,4137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(4725,3537){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(4575,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(8550,4812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(8025,4212){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\put(9975,4212){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(9975,3927){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}memory}}}}} +\put(8625,2712){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}Hp}}}}} +\put(8625,2262){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}HpLim}}}}} +\put(0,4887){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}MainRegTable.rCurrentNursery}}}}} +\put(750,7362){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}MainRegTable.rNursery}}}}} +\put(3825,1887){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(4500,987){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(4500,687){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(4500,387){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(8475,1362){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(8775,762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free memory}}}}} +\put(4500,87){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link=NULL}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/nursery.fig b/docs/storage-mgt/nursery.fig new file mode 100644 index 00000000..6a4b60fb --- /dev/null +++ b/docs/storage-mgt/nursery.fig @@ -0,0 +1,107 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 1425 7875 1425 7875 2625 6300 2625 6300 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 1575 7050 1125 9675 1125 9675 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12750 1425 12750 2625 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 1875 7200 1125 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9675 1425 12975 1425 12975 2625 9675 2625 9675 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7200 1875 7200 675 12750 675 12750 1425 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 6450 2475 5850 2475 5850 3000 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9675 2025 12750 2025 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 5850 3450 5850 3975 6225 3975 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6225 3900 7800 3900 7800 5100 6225 5100 6225 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 6975 4050 6975 3600 9600 3600 9600 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7125 4350 7125 3600 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9600 3900 12900 3900 12900 5100 9600 5100 9600 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 6375 4950 5775 4950 5775 6450 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7125 4350 7125 3150 9600 3150 9600 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9600 4500 11475 4500 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 11475 3900 11475 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 10875 5775 11475 5775 11475 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 11250 6225 12900 6225 12900 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 5025 3825 5025 4200 6225 4200 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 5100 1350 5100 1725 6300 1725 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 5775 6900 5775 7425 6150 7425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6150 7350 7725 7350 7725 8550 6150 8550 6150 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 6900 7500 6900 7050 9525 7050 9525 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7050 7800 7050 7050 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9525 7350 12825 7350 12825 8550 9525 8550 9525 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 7800 7050 6600 9525 6600 9525 7350 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 1650 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 1950 free\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 2550 link\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6375 2250 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10350 1275 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 10350 1875 used memory\001 +4 0 0 50 0 0 17 0.0000 4 30 360 5625 3225 ......\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6300 4125 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6300 4425 free\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6450 5025 link\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6300 4725 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10275 3750 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 9750 4350 used memory\001 +4 0 0 50 0 0 17 0.0000 4 165 390 11700 4350 free\001 +4 0 0 50 0 0 17 0.0000 4 180 825 11700 4635 memory\001 +4 0 0 50 0 0 17 0.0000 4 225 300 10350 5850 Hp\001 +4 0 0 50 0 0 17 0.0000 4 225 720 10350 6300 HpLim\001 +4 0 0 50 0 0 17 0.0000 4 225 3180 1725 3675 MainRegTable.rCurrentNursery\001 +4 0 0 50 0 0 17 0.0000 4 225 2415 2475 1200 MainRegTable.rNursery\001 +4 0 0 50 0 0 17 0.0000 4 30 360 5550 6675 ......\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6225 7575 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6225 7875 free\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6225 8175 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10200 7200 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1275 10500 7800 free memory\001 +4 0 0 50 0 0 17 0.0000 4 165 1185 6225 8475 link=NULL\001 diff --git a/docs/storage-mgt/reference.bib b/docs/storage-mgt/reference.bib new file mode 100644 index 00000000..48fa520b --- /dev/null +++ b/docs/storage-mgt/reference.bib @@ -0,0 +1,14 @@ +@inproceedings {CN, + author = {Colin Runciman and Niklas Rojemo}, + title = {New Dimensions in heap profiling}, + booktitle = "", + pages = "", + year = "1994" } + +@inproceedings {RR, + author = {Niklas Rojemo and Colin Runciman}, + title = {Lag, drag, void and use - heap profiling and space-efficient compilation revisited}, + booktitle = "", + pages = "", + year = "1996" } + diff --git a/docs/storage-mgt/rp.tex b/docs/storage-mgt/rp.tex new file mode 100644 index 00000000..0d841b9d --- /dev/null +++ b/docs/storage-mgt/rp.tex @@ -0,0 +1,1102 @@ +\documentclass{article} +\usepackage{code,a4wide} + +\usepackage{graphics,epsfig,epic,eepic,epsfig} + +\setlength{\parskip}{0.25cm} +\setlength{\parsep}{0.25cm} +\setlength{\topsep}{0cm} +\setlength{\parindent}{0cm} +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + + +% Terminology +\newcommand{\block}{block} +\newcommand{\Block}{Block} +\newcommand{\segment}{segment} +\newcommand{\Segment}{Segment} +\newcommand{\step}{step} +\newcommand{\Step}{Step} + +\newcommand{\note}[1]{{\em $\spadesuit$ #1}} + +\begin{document} +\title{Implementation of Retainer Profiling} +\author{Sungwoo Park and Simon Peyton-Jones} + +\makeatactive +\maketitle + +\section{Retainer Profiling} + +Retainer profiling~\cite{CN} is a profiling technique which is based upon a +special view of production and consumption of heap objects at runtime: +while producers build heap objects to form new pieces of graph, +consumers hold pointers to these heap objects, or \emph{retain} them, so +that they are not freed during garbage collections. +On this basis, we refereed to such consumers as \emph{retainers}. +Notice that an object can have more than one retainer because it can +be pointed to by multiple objects. + +For each live object in the heap, retainer profiling computes +all its retainers, or its \emph{retainer set}. +A naive implementation of retainer profiling could consider every +immediate ancestor of an object as its retainer. +Although this approach appears to provide an accurate report on the +relationship between retainers and retainees, the result can hardly be useful. +For instance, it is pointless to scrutinize a list and treat each cons +cell as a retainer of the following cons cell. +This observation suggests that we need to have a way of designating only +certain types of objects as candidates for retainers. +In other words, we need to employ an oracle which tells whether a given +object can be a retainer or not. + +Since no retainer of a particular object needs to be using the +object actively, we can find all its retainers simply by traversing +the graph. In other words, we do not have to distinguish those retainers +actively exploiting it from other retainers just holding pointers +to it (either directly or indirectly). +Thus, retainer profiling can be accomplished simply by traversing the +graph. + +Figure~\ref{fig-retaineralgorithm} shows the algorithm for retainer +profiling. The traversal begins at every root, and proceeds +in a depth first manner (or a breadth first manner). +The function @R()@ returns the \emph{identity} of a given retainer such +as its information table address or +the name of the module which creates it. +Notice that the retainer identity function does not need to be a +one-to-one mapping: +multiple objects can share the same identity. +Such a retainer identity function reduces the cost of traversal. +For instance, when an object +is reached from several retainers which share the same identity, we need to +consider only the first visit to the object. +In other words, whichever retainer (among those sharing the same identity) +leads to the object for the first time affects the retainer set of the object +in consideration +and all the other retainers can be ignored. +Thus, the more coarse the function @R()@ is, the less +it costs to traverse the graph for retainer profiling. +The function @isRetainer()@ tells whether a given object is a retainer or not. +Hence, the behavior of the retainer profiling algorithm is parameterized +over: 1) the set of roots; 2) the function @R()@; 3) the function +@isRetainer()@. + +One important invariant on the function @R()@ is that its return value +must be consistent for a given retainer. In other words, @R()@ must return +the same value for a given retainer no matter it is invoked. +For this reason, the memory address of a retainer, for instance, cannot be used as +its retainer identity because its location may change during garbage collections. + +\begin{figure}[ht] +\begin{center} +\begin{code} +for every root r + retain(r, r) + +R(r) = + the identity of r + +isRetainer(c) = + if c is a retainer then + true + else + false + +retain(c, r) = + if R(r) is a member of c.retainerSet then + return + add R(r) to c.retainerSet + if isRetainer(c) then + r' := c + else + r' := r + for every successor c' of c + retain(c', r') +\end{code} +\caption{Retainer profiling algorithm} +\label{fig-retaineralgorithm} +\end{center} +\end{figure} + +Another way of formulating retainer profiling is in terms of fixed point +equations on retainer sets. +To be specific, given the two functions @isRetainer()@ and @R()@, +the retainer set of every object is computed as the least fixed point +solution of the following equations: +\begin{itemize} +\item For every root @r@, +\begin{center} + @R(r)@ $\in$ @r.retainerSet@. +\end{center} +\item For every reachable object @c@, +\begin{center} +$\bigcup_{\mathit{each\ ancestor\ @a@\ of\ @c@}}$ @from(a)@ $\subseteq$ +@c.retainerSet@ +\end{center} +where @from(a)@ returns retainer(s) obtainable from @a@: +\begin{center} +@from(a)@ = if @isRetainer(a)@ then $\{@a@\}$ else @a.retainerSet@. +\end{center} +\end{itemize} + +This document describes the implementation of retainer profiling on +the Glasgow Haskell Compiler runtime system. +It explains every detail of the development so that it can be (hopefully) +a complete maintenance guide. +A secondary goal is to help (hopefully) those who wish to extend the system +to implement another profiling scheme.\footnote{Unless otherwise mentioned, +all identifiers are defined in @RetainerProfile.c@ or @RetainerSet.c@.} + +\section{Installing the GHC} + +Installing the GHC is done as follows: + +\begin{enumerate} +\item Get the source code from the CVS repository. +\begin{code} +./ cvs checkout fpconfig +./fptools/ cvs update -d CONTRIB common-rts distrib docs ghc glafp-utils + hslibs literate mhms mk nofib testsuite +\end{code} + +\item Set up the basic configuration. +\begin{code} +./fptools/ autoconf +./fptools/ghc/ autoconf +./fptools/ configure +\end{code} + +\item Set up the configuration for development and debugging. +\begin{code} +./fptools/mk vi build.mk + GhcHcOpts = -O -fasm -Rghc-timing + SplitObjs = NO + GhcRtsHcOpts = + GhcRtsCcOpts = -g + STRIP_CMD =: +\end{code} +@GhcLibWays@ tells the compiler to build the code for profiling as well. +@GhcRtsHcOpts@ has additional flags for @gcc@ when compiling @.hc@ files. +@GhcRtsCcOpts@ has additional flags for @gcc@ when compiling @.c@ files. +Since we will implement retainer profiling in @.c@ files, we turn on the +debugging flag @-g@. +The empty setting for @STRIP_CMD@ tells the compiler not to remove source code +information (generated due to the @-g@ option) from executable files so that +they can be examined with @gdb@. + +\item Remove unnecessary files if needed and build everything. +\begin{code} +./fptools/ make +\end{code} +\end{enumerate} + +\section{Adding Retainer Set Fields} + +Since every Haskell closure now needs to store its retainer set at runtime, +it must be augmented with a new field, +namely, a \emph{retainer set field}. +This section explains how to add such a field to Haskell closures. +It should be clear how to generalize the idea for adding +any number of new fields.\footnote{The GHC provides two +ways of building executable programs from +source files: normal way and profiling way. +We are concerned only about profiling way, and all the pieces of code +implementing profiling way are wrapped by the @PROFILING@ +pre-processing directive (as in @\#ifdef PROFILING@). +Therefore, all the additions and changes that we make to the source code +are assumed to be wrapped by the @PROFILING@ pre-processing +directive as well unless otherwise mentioned.} + +\subsection{Adding a new field to Haskell closures} + +We want to add a retainer set field of type @retainerSet@ to every +closure, so we create a new file @includes/StgRetainerProf.h@ where +we define the type @retainerSet@. +The actual definition of @retainerSet@ will be given later. + +\begin{code} +/* includes/StgRetainerProf.h */ +typedef ... retainerSet; +\end{code} + +We make type @retainerSet@ to be publicly available by including +@includes/StgRetainerProf.h@ itself to @includes/Stg.h@ (not wrapped +by @PROFILING@). + +\begin{code} +/* includes/Stg.h */ +#include "StgRetainerProf.h" +\end{code} + +Then we add a retainer set field @rs@ to the @StgProfHeader@ structure. + +\begin{code} +/* include/Closures.h */ +typedef struct { + CostCentreStack *ccs; + retainerSet *rs; +} StgProfHeader; +\end{code} + +Now every closure @c@ (including static closures) has a retainer set field, +which can be accessed with @c->header.prof.rs@ (where @c@ denotes the +address of the closure). + +\subsection{Changing constants} + +We are ready to reflect the new size of Haskell closures to other part +of the source code. +This is accomplished by changing a few constants which specify the size +of certain types of closures and their layout. + +When building the runtime system, the @gcc@ compiler correctly figures out +the size of every structure on its own. +However, +GHC simply reads @includes/Constants.h@ to determine the size of +closures assumed by the runtime system. +Thus, we must change the constants used by the GHC itself (as opposed to +the runtime system). They are all found in @includes/Constants.h@. +We increase each of them by 1 to reflect the retainer set field which is one +word long: +\begin{code} +/* includes/Constants.h */ +#define PROF_HDR_SIZE 2 +#define SCC_UF_SIZE 5 +#define SCC_SEQ_FRAME_SIZE 4 +\end{code} +@PROF_HDR_SIZE@ denotes the size of the structure @StgProfHeader@, which +is now two words long. +@SCC_UF_SIZE@ and @SCC_SEQ_FRAME_SIZE@ denote the size of the structures +@StgUpdateFrame@ and @StgSeqFrame@ (in @includes/Closures.h@) in +words. + +Now we must rebuild the GHC so that, when executed, the code generated by +the GHC must now allocate one more word for the retainer set field than before. + +\begin{code} +./fptools/ghc/ make boot +./fptools/ghc/ make +\end{code} + +The second command @make boot@ instructs the build system to analyze +the source code dependency so that the next execution of @make@ correctly +finds all required files. + +Next we change four bitmap constants which specify the layout of +certain types of closures. +As an example, let us consider @RET_BITMAP@, which specifies the layout +of thunk selectors (corresponding to closure type @THUNK_SELECTOR@). +Without a retainer set field, there is only one non-pointer (represented +by $1$) followed by one or more pointers (represented by $0$) in the closure +body and the bitmap representation is $0b1$, or $1$. +With a retainer set field, which is not a pointer to another closure and thus +represented by $1$, there are two non-pointers, and the bitmap representation +is $0b11$, or $3$. Notice that the bitmap is interpreted in reverse order: +the least significant bit corresponds to the first word in the closure body, +and the second least significant bit to the second word, and so forth. +The same rule applies to the other three bitmap constants: +@CATCH_FRAME_BITMAP@ (for closure type @CATCH_FRAME@ and structure +@StgCatchFrame@), +@STOP_THREAD_BITMAP@ (for closure type @STOP_FRAME@ and structure +@StgStopFrame@), and +@UPD_FRAME_BITMAP@ (for closure type @UPDATE_FRAME@ and structure +@StgUpdateFrame@). + +\begin{code} +/* rts/StgStdThunks.hc */ +#define RET_BITMAP 3 +/* rts/Exception.hc */ +#define CATCH_FRAME_BITMAP 15 +/* rts/StgStartup.hc */ +#define STOP_THREAD_BITMAP 3 +/* rts/updates.hc */ +#define UPD_FRAME_BITMAP 7 +\end{code} + +For most closure types, the new definition of @StgProfHeader@ is +automatically propagated to their corresponding structures. +However, there are six closures types which are not affected by +@StgProfHeader@. They are all stack closures: +@RET_DYN@, @RET_BCO@, @RET_SMALL@, @RET_VEC_SMALL@, @RET_BIG@, and +@RET_VEC_BIG@. +If you want a new field to be added to these closures, you may +have to modify their corresponding structures. + +\textbf{To do:} Presently the above changes introduce two bug in the +runtime system. +First, @nofib/real/symalg@ ends up with a division-by-zero +exception if we add a new field. +Second, the runtime system option @-auto-all@ clashes in some test files +in the @nofib@ testing suite (e.g., @spectral/expert@). + +\subsection{Initialization code} + +When a new closure is allocated, its retainer set field may have to be +initialized according to the way that retainer profiling is implemented. +For instance, we could use as an initial value a pointer to an empty retainer +set. +Alternatively we could assign a null pointer to indicate that its retainer +set has not been computed yet, which we adopt in our implementation. +In either case, we have to visit the new closure and execute some initialization +code on it so that its retainer set field is set to an appropriate value. + +There are three parts in the source code which need to be modified. +dynamic closure initialization, static closure initialization, +and update frame initialization. +The first is accomplished by modifying the macro @SET_PROF_HDR()@ (in +@include/ClosureMacros.h@). When a closure @c@ is created at runtime, +@SET_PROF_HDR()@ is invoked immediately with @c@ as its first argument. +Thus, the following code initializes the retainer set field of every +dynamic closure to a null pointer. + +\begin{code} +/* include/ClosureMacros.h */ +#define SET_PROF_HDR(c,ccs_) \ + ((c)->header.prof.ccs = ccs_, (c)->header.prof.rs = NULL) +\end{code} + +Similarly, the macro @SET_STATIC_PROF_HDR()@ (in the +same file) specifies how the retainer set field of every static closure +is initialized, which is rewritten as follows: + +\begin{code} +/* include/ClosureMacros.h */ +#define SET_STATIC_PROF_HDR(ccs_) \ + prof : { ccs : ccs_, rs : NULL }, +\end{code} + +\textbf{Obsolete:} Dynamic closures created through explicit C function invocations +(in @RtsAPI.c@) are now initialized by @SET_HDR()@. + +%There is another way of creating dynamic closures through explicit C +%function invocations at runtime. +%Such functions are all defined in @RtsAPI.c@: @rts_mkChar()@, @rts_mkInt()@, +%@rts_mkWord()@, and so forth. +%Each function allocates memory for a new closure, +%initializes it, and returns its address. +%Therefore, we can simply insert in each function another initialization code +%for retainer set fields. +%To this end, we define a macro @setRetainerField()@ and insert it +%in each function: +% +%\begin{code} +%#define setRetainerField(p) \ +% (p)->header.prof.rs = NULL +%\end{code} +% +%For instance, @rts_mkChar()@ is now defined as follows: +% +%\begin{code} +%/* RtsAPI.c */ +%HaskellObj +%rts_mkChar (HsChar c) +%{ +% StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1)); +% ... +% setRetainerField(p); +% return p; +%} +%\end{code} + +Finally we may need to initialize the retainer set field of an update frame +(stack closure) when it is pushed onto the stack for the first time. +For instance, if we want to initialize the retainer set field of update +frames to a null pointer, we can rewrite the macro @PUSH_STD_CCCS()@ +(in @includes/Updates.h@) as follows: + +\begin{code} +/* includes/Updates.h */ +#define PUSH_STD_CCCS(frame) \ + (frame->header.prof.ccs = CCCS, frame->header.prof.rs = NULL) +\end{code} + +In our implementation of retainer profiling, however, the retainer set field is not +used for any stack closure. +Hence, the above modification is entirely unnecessary. +Also, update frames are the only exception to the standard way of creating +stack closures: all the other types of stack closures with a retainer set +field are eventually initialized by +the macro @SET\_HDR()@ (in @includes/ClosureMacros.h@), which in turn +invokes @SET\_PROF\_HDR()@. This is not the case for update frames. +Compare @PUSH\_UPD\_FRAME()@ (in @includes/Updates.h@) and +@PUSH\_SEQ\_FRAME()@ (in @includes/StgMacros.h@) for clarification. + +\section{Retainer Sets} + +At the end of retainer profiling, every live closure (except stack +closures, for which we do not compute retainer sets) is associated with +a retainer set; there can be no closure without an associated retainer set +because every live closure is visited during traversal. +Since many closures may well be associated with a common retainer set, +we want to avoid creating any particular retainer set more than once. +This section presents the details of manipulating retainer sets in our +implementation. + +\subsection{Identity of a retainer} + +The function @R()@ in Figure~\ref{fig-retaineralgorithm} returns +the identity of a retainer. In order to implement it, we need +a type for retainer identity. +The type @retainer@ (in @includes/StgRetainerProf.h@) is introduced for +this purpose. + +There are various ways of defining the type @retainer@. +For instance, we can designate the information table address of a retainer as +its identity as follows: + +\begin{code} +struct _StgInfoTable; +typedef struct _StgInfoTable *retainer; +\end{code} + +We can also use the cost centre stack associated with the retainer: + +\begin{code} +typedef CostCentreStack *retainer; +\end{code} + +The function @R()@ is embodied as the function @getRetainerFrom()@ in the +implementation, whose type is @(StgClosure *)@ $\rightarrow$ @retainer@. +It is straightforward to define @getRetainerFrom()@ according to the definition +of @retainer@, as illustrated below: + +\begin{code} +retainer getRetainerFrom(StgClosure *c) { return get_itbl(c); } +retainer getRetainerFrom(StgClosure *c) { return c->header.prof.ccs; } +\end{code} + +\subsection{Retainer sets and the cost function} + +A retainer set is stored in the structure @retainerSet@ +(in @includes/StgRetainerProf.h@): + +\begin{code} +typedef struct _retainerSet { + nat num; + nat cost; + ... + int id; + retainer element[0]; +} retainerSet; +\end{code} + +The field @num@ gives the number of retainers in the retainer set, which +are all stored in the array @element[]@. Thus, the size of @element[]@ +is assumed to be @num@. +The field @cost@ gives the sum of the \emph{costs} of those closures +associated with the retainer set: if a closure @c@ is +associated with the retainer set, that is, if @c@ is retained by each +retainer in the retainer set and none else, +the cost of @c@ is added to the field @cost@. +The field @id@ gives a unique identification number for the retainer set. + +The interface to @retainerSet@ is as follows +(see @RetainerSet.h@): + +\begin{description} +\item[@void initializeAllRetainerSet(void)@] initializes the store for retainer sets. +\item[@void refreshAllRetainerSet(void)@] refreshes each retainer set by setting +its @cost@ field to zero. This function does destroy any retainer set. +\item[@void closeAllRetainerSet(void)@] destroys all retainer sets and closes +the store for retainer sets. +\item[@retainerSet *singleton(retainer r)@] returns a singleton retainer set +consisting of @r@ alone. If such a retainer set already exists, no new retainer +set is created. Otherwise, a new retainer set is created. +\item[@retainerSet *addElement(retainer r, retainerSet *rs)@] returns a retainer set +@rs@ augmented with @r@. If such a retainer set already exists, no new retainer set +is created. Otherwise, a new retainer set is created. +\item[@rtsBool isMember(retainer r, retainerSet *rs)@] returns a boolean value +indicating whether @r@ is a member of @rs@. +\item[@void traverseAllRetainerSet(void (*f)(retainerSet *))@] invokes the function +@f@ on every retainer set created. +\item[@void printRetainerSetShort(FILE *, retainerSet *)@] prints a single retainer +set. +\item[@void outputRetainerSet(FILE *, nat *allCost, nat *numSet)@] prints all +retainer sets. Stores the sum of all their costs in @*allCost@ and the number +of them in @*numSet@. +\item[@void outputAllRetainerSet(FILE *)@] prints all retainer sets. +\end{description} + +We also define a \emph{cost function}, which returns the cost of a given closure, +in order to compute the field @cost@. +The cost function can be defined in several ways. +A typical definition is on the size of a closure, which results in +the field @cost@ accumulating the size of all the closures retained by a +retainer set. +If we just want to count the number of closures retained by the +retainer set, we can simply set the cost of every closure to one regardless +of its closure type. +Furthermore, we can define the cost function flexibly according to +the closure type. +For instance, we can set the size of any static closure to zero so that +it is not taken into account at all in computing the field @cost@. +Notice that static closures are also visited during traversal because they +may lead to other dynamic closures (e.g., static indirection closures of +closure type @IND_STATIC@). +This is especially desirable because we usually focus on the heap use. +We can also selectively choose certain dynamic closure types not to contribute +to the field @cost@. + +In our implementation, there are two functions related with the cost function: +@cost()@ and @costPure()@. +@cost()@ returns the size of the entire memory allocated for a given closure +(even including the two fields in the structure @StgProfHeader@). +It returns zero for static closures. +@costPure()@ returns the size of the memory which would be allocated for +a given closure with no profiling. +It is defined in terms of @cost()@, and it suffices to change only @cost()@ +when a new scheme for the cost function is desired. +@costPure()@ is put to actual use in computing the field @cost@ because it +effectively hides the memory overhead incurred by profiling. + +\subsection{Implementation} + +The algorithm for retainer profiling in Figure~\ref{fig-retaineralgorithm} +adds at most one retainer to an existing retainer set (or an empty retainer set) +at any moment; it does not require a retainer set union operation. +This observation simplifies the implementation, and +we employ the following two functions for creating new retainer sets: +@singleton()@, which creates a singleton retainer set, and +@addElement()@, which adds an element to an existing retainer set. + +It is a frequent operation during retainer profiling to search for a retainer +set, which may or may not exist, built from a given retainer set and a +particular retainer. +To efficiently implement this operation, +we choose to store all retainer sets in a hash table and +the structure @retainerSet@ is now extended with two new fields +@hashKey@ and @link@. +The field @hashKey@ stores the hash key which is obtained +from the retainers in a retainer set. +The field @link@ points to the next retainer set in the same bucket: + +\begin{code} +typedef struct _retainerSet { + ... + StgWord hashKey; + struct _retainerSet *link; + ... +} retainerSet; +\end{code} + +The hashing function must be defined in such a way that a retainer set +can have only one unique hash key regardless of the order its elements +are stored, i.e., the hashing function must be additive. + +It is often observed that two successive executions of retainer profiling share +a number of retainer sets in common, especially if the two executions are +close in time. +This also implies that the number of all retainer sets which can be created +at any moment does not grow indefinitely regardless of the interval at which +retainer profiling is performed; it does not grow commensurately with the +number of times retainer profiling is executed. +This observation eliminates the need to free the memory allocated for +retainer sets; we can simply set the @cost@ field of every retainer set +to zero after each retainer profiling and reuse it during the next time. + +\section{Graph Traversal} + +At the heart of retainer profiling lies \emph{graph traversal}; +the algorithm in Figure~\ref{fig-retaineralgorithm} is supposed to visit +every closure in the graph at least once and yield statistics on the heap use. +Since only live closures are reachable from the root, the algorithm +does not deal with dead closures. + +This section presents details on how to achieve an efficient implementation of +graph traversal without incurring extra memory overhead and compromising speed. + +\subsection{Goal} + +Traversing a graph itself can be done in a straightforward way; +we choose either depth first search or breadth first search, and traverse +the graph starting from a given set of roots. +After a complete traversal, each live closure @c@ (including static closures) +has an associated retainer set, whose address is stored in the field +@c->header.prof.rs@. + +A real complication arises when retainer profiling is performed once again: +all live closures which have survived all garbage collections since +the previous retainer profiling +still have an associated retainer set (indicated by +a non-null pointer in their retainer set field), which is no longer +valid. Any new closure created since then has +a null pointer in its retainer set field at the beginning of retainer +profiling and will become associated with a retainer set. +Thus, we can no longer distinguish valid retainer set fields +from invalid ones. + +A simple remedy is to linearly scan the heap at the beginning of each +retainer profiling and set all retainer set fields to a null pointer. +It resets the retainer set field of each dynamic closure, whether it is +live or not with respect to the given set of root. +This is feasible because any closure in the heap directly adjoins the +next closure, if any. +The problem is that we have no way of visiting all live static closures, +for which we compute retainer sets. + +A moment of thought, however, reveals that we can completely avoid computing +retainer sets for static closures. This is because retainer profiling is +concerned only about the heap, which consists of dynamic closures and no +static closures. In other words, we can treat every static closure as +a bridge connecting two dynamic closures. +For instance, if a dynamic closure @c@$_1$ has a pointer to a static +closure @s@ and @c@ has a pointer to another dynamic closure @c@$_2$, +we can think of the pointer in @c@$_1$ as a direct pointer to @c@$_2$. +The big problem is that if the graph has a cycle containing static closures, +an infinite loop occurs. In other words, we have no way of telling whether +a static closure has been visited or not and are forced to compute +retainer sets for static closures as well.\footnote{For instance, +a static closure is allowed to have a self-reference in its SRT, which +is also followed during retainer profiling.} + +Another remedy is to stores in every closure a time stamp for the +retainer set field. The time stamp indicates whether the retainer +set field is valid or no longer valid (i.e., it is for the previous +retainer profiling). +At the cost of one extra field in each closure, we can achieve an +elegant implementation with little complication. +However, it turns out that the memory overhead is too big.\footnote{A typical +dynamic closure is only two or three words long.} +Thus, our goal is to stick to the definition of the structure @StgProfHeader@ +given earlier and yet to achieve an elegant solution. + +\subsection{Basic plan} + +Since we visit every live object and update its retainer set field, +any retainer set field can either be valid (the corresponding retainer +set is valid) or point to a retainer set created during the previous +retainer profiling. +In order to distinguish valid retainer set fields +from invalid ones, we exploit the least significant bit of the retainer +set field: we maintain a one bit mark which flips over every time +retainer profiling is performed, and judge that a retainer set field is +valid only if its least significant bit matches the mark. +The variable @flip@ serves for this purpose. +The macros @isRetainerSetFieldValid()@ tests if the retainer set field +of a give closure @c@ is valid: + +\begin{code} +#define isRetainerSetFieldValid(c) \ + ((((StgWord)(c)->header.prof.rs & 1) ^ flip) == 0) +\end{code} + +As an example, a retainer set field can be set to a null value conforming +the current value of @flip@ by the macro @setRetainerSetToNull()@: + +\begin{code} +#define setRetainerSetToNull(c) \ + (c)->header.prof.rs = (retainerSet *)((StgWord)NULL | flip) +\end{code} + +Now, when a dynamic closure @c@ is created, its retainer set field is +initialized to a null value conforming to the current value of +@flip@:\footnote{Actually this is not mandatory: even when the null +value does not conform to the current value of @flip@, it will be replaced +by a correct null value when @c@ is visited later.} + +\begin{code} +extern StgWord flip; +#define SET_PROF_HDR(c,ccs_) \ + ((c)->header.prof.ccs = ccs_, (c)->header.prof.rs = (retainerSet *)((StgWord)NULL | flip)) +\end{code} + +We do not need to revise @SET_STATIC_PROF_HDR()@ if the initial value of +@flip@ is set to $0$.\footnote{For the same reason, an initial value $1$ +does not compromise the correctness of the implementation.} + +\subsection{Set of roots} + +The set of roots consists of all thread closures (running, sleeping, or +blocked) existing at the beginning of a retainer profiling. +It is handily obtained in an indirect way by invoking the function +@GetRoots()@ (in @Schedule.c@) with an appropriate argument, which must be +a function: +@GetRoots()@ invokes on each root known to the runtime system its argument. +Thus, we implement a function @retainClosure()@, which initiates traversal +from a given root and updates the retainer set of every closure reachable +from the root, +and invokes @GetRoots()@ with @retainClosure@ as an argument. + +In addition to the thread closures, weak pointers are also considered +as roots; they may not be reachable from any thread closure yet are still +being in used. +A weak pointer has three pointer fields: @key@, @value@, and +@finalizer@ (see the structure @StgWeak@ in @includes/Closures.h@). +It turns out that these pointers may not be valid all the time: +at a certain point during execution, for instance, the pointer @key@ may point +to a dead closure. +However, right after a major garbage collection, all the three pointers are +guaranteed to be valid, i.e., they all point to live closures. +This facilitates the handling of weak pointers if we choose to +perform retainer profiling immediately after a major garbage collection. +All weak pointers are found in the linked list @weak_ptr_list@ +(in @Weak.c@). + +See the function @computeRetainerSet()@ for details. + +\subsection{Static closures} + +When a live dynamic closure @c@ is visited for the first time during traversal, +its retainer set field is checked against the current value of @flip@. +If it was created at some point since the previous retainer profiling, +its retainer set field is already set to a correct null value. +Otherwise, it must have been visited +during the previous retainer profiling and thus its retainer set field is +invalid and will be set to a correct null value. +Therefore it is unnecessary to visit all dynamic closures and set their +retainer set field to a correct null value at the beginning of each retainer +profiling. + +However, this operation is required for static closures. +The reason is that a static closure, which is never garbage collected, +may appear alternately in the set of live closures. +In other words, a currently live static closure may become dead and +be resuscitated again. +Therefore, for a static closure, it does not help to check if its +retainer set field conforms to the current value of @flip@. +For instance, +if a static closure happens to belong to the set of live closures every other +retainer profiling, its retainer set field will never set to a null value, +which is disastrous. +Therefore, we choose to visit all live static closures at the beginning +of each retainer profiling and set their retainer set field to a +correct null value. + +In order to find all live static closures, we have each retainer +profiling preceded by a major garbage collection, which knows all live +static closures.\footnote{This is a heavy +restriction on retainer profiling, which makes retainer profiling partially +dependent on garbage collection. +However, it does not affect any retainer profiling result because +retainer profiling considers only live closures, which survive any +garbage collection.} +To be specific, the garbage collector builds a linked list +@scavenged_static_objects@ (in @GC.c@) during a major garbage collection, +which stores all live static closures of our interest. +\footnote{ +A static closure of closure type @IND\_STATIC@ may be put in the +list @mut\_once\_list@ of the oldest generation, instead of the list +@scavenged\_static\_objects@. +In our implementation, such a closure is just skipped over because it +contains only a pointer to a dynamic closure, and we do not compute +its retainer set. +Thus, there is no need to traverse the list @mut\_once\_list@ of the oldest +generation.} +Since it destroys the linked list after finishing the major garbage collection +(by invoking the function @zero_static_object_list()@ with +@scavenged_static_objects@ as its argument), +we traverse the linked list to set the retainer set field of each +live static closure to a correct null value before its destruction. +This is done by invoking the function +@resetStaticObjectForRetainerProfiling()@. + +\textbf{To do:} In the current implementation, if a static closure has no child +(e.g., @CONSTR_NOCAF_STATIC@, @THUNK_STATIC@ with an empty SRT, and +@FUN_STATIC@ with an empty SRT), we do not compute its retainer set (because +there is no need to do). This slight optimization allows us to render +retainer profiling no longer dependent on garbage collection due to the +following propoerty: + +\begin{center} +A static closure can alternately appear and disappear in the set of live +closures across multiple executions of retainer profiling if and only if +it has an empty SRT and no child. +\end{center} + +Then we can completely eliminate the function +@resetStaticObjectForRetainerProfiling()@. + +\subsection{Traversal} + +The traversal proceeds in a depth first manner and is implemented +with two mutually recursive functions: @retainStack()@ and @retainerClosure()@. +@retainerStack()@ can be invoked on dynamic closures holding a stack chunk: +closure types @TSO@, @PAP@, and @AP_UPD@. +It in turn invokes @retainerClosure()@ on each closure reachable from +stack closures in the stack chunk. Notice that it does not invoke +@retainerClosure()@ on those stack closures because we do not compute +retainer sets for stack closures. +@retainerClosure()@ iteratively traverses all live closures reachable +from a given closure. +It maintains its own stack to record the next scan position in every closure +currently under consideration.\footnote{A recursive version of +@retainerClosure()@ could be implemented easily. +@retainerClosure()@ in our implementation is an iterative version.} +When it encounters a closure holding a stack chunk, it invokes @retainerStack()@ +on that closure. +Hence, +the traversal is triggered simply by invoking @retainerClosure()@ on every root. + +\textbf{To do:} +The correctness of retainer profiling is subject to the correctness +of the two macros @IS_ARG_TAG()@ and @LOOKS_LIKE_GHC_INFO()@ +(see @retainStack()@). Since +@LOOKS_LIKE_GHC_INFO()@ is a bit precarious macro, so I believe that +the current implementation may not be quite safe. Also, @scavenge_stack()@ +in @GC.c@ also exploits this macro in order to identify shallow pointers. +This can be a serious problem if a stack chunk contains some +word which looks like a pointer but is actually not a pointer. + +\subsection{Sanity check} + +Since we assume that a retainer profiling is preceded by a major garbage +collection, +we expect that the size of all the dynamic closures visited during +any retainer profiling adds up exactly to the total size of the heap. +In fact, this is not the case; there can be closures not reachable from +the set of roots yet residing in the heap even after a major garbage +collection. + +First, a dead weak pointer remains in the heap until its finalizer +finishes. Although its finalizer thread closure is part of the set of roots, +the dead weak pointer itself is not reachable from any root. +Since it cannot be visited during retainer profiling anyhow, we do not +need to located it and set its retainer set field +appropriately.\footnote{Dead weak pointers are identified with their +information table @stg\_DEAD\_WEAK\_info@ (in @StgMiscClosures.hc@). +Notice that their closure type is @CONSTR@, \emph{not} @WEAK@; +their information table is replaced by @stg\_DEAD\_WEAK\_info@ in the +function @scheduleFinalizers()@ (in @GC.c@).} + +Second, +mutable variables (of closure type @MUT_VAR@) may remain in the heap +even when they are not reachable from the set of roots while +dynamic closures pointed to by them must be live.\footnote{I do not +understand clearly why this happens :(} +Since such mutable variables may become live again (in the sense that +they become reachable from the set of roots), we must locate them +and set their retainer set field appropriately after each retainer +profiling. This is handily accomplished by traversing the list +@mut_once_list@ in every generation. + +\section{Retainer Profiling Schemes} + +A retainer profiling scheme specifies \emph{what} retainer profiling +yields (as opposed to \emph{how} retainer profiling computes the retainer +set for every live object). +It is determined primarily by the meaning of retainer identity, +that is, the type @retainer@ (in @includes/StgRetainerProf.h@). +The function @getRetainerFrom()@ must be defined according to the +definition of the type @retainer@. + +In order for a new retain profiling scheme to fully work, we need to follow +four steps: + +\begin{enumerate} +\item Define the type @retainer@ as desired. +\item Write @getRetainerFrom()@. +\item Write two hashing functions @hashkeySingletone()@ and + @hashKeyAddElement()@, which return the hash key from a single + retainer and a retainer set with another retainer, respectively. +\item Write two printing functions @printRetainer()@ and + @printRetainerSetShort()@. + These functions are employed when a retainer or a retainer set is + printed in the output file. +\end{enumerate} + +In our implementation, we use cost centre stacks for retainer identity: + +\begin{code} +typedef CostCentreStack *retainer; +\end{code} +\begin{code} +retainer getRetainerFrom(StgClosure *c) { return c->header.prof.ccs; } +\end{code} +\begin{code} +void printRetainer(FILE *f, retainer cc) +{ + fprintf(f,"%s[%s]", cc->label, cc->module); +} +\end{code} + +\textbf{To do:} All the closures created by @rts_mk...()@ in @RtsAPI.c@ are given +@CCS_SYSTEM@ as their cost centre stacks. This may not be accurate indeed, +and, for instance, @CCCS@ may be a better choice than @CCS_SYSTEM@. + +\section{Usage} + +Since cost centre stacks are used as retainer identity, a source program +must be given proper cost centre annotations by programmers. +Alternatively, +we can ask the compiler to automatically insert cost centre annotations. +For instance, the compiler option @-auto-all@ inserts a cost centre +annotation around every top-level function as shown below +(the @-p@ option is a must +because we must build the executable file in a profiling way): + +\begin{code} +$ ghc-inplace -o Foo.out -p -auto-all Foo.hs +\end{code} + +The runtime system option @-hR@ tells the executable program to +gather profiling statistics and report them in a @.prof@ file: + +\begin{code} +$ Foo.out +RTS -hR -RTS +\end{code} + +The option @-i@ can be used to +specify a desired interval at which retainer profiling is performed. +The default and minimum value is half a second: + +\begin{code} +$ Foo.out +RTS -hR -i2.5 -RTS +\end{code} + +Then, two text files are generated: a @.prof@ file and a @.hp@ file. +The @.prof@ file records the progress of retainer profiling: +for each retainer profiling performed during program execution, +it shows +the Haskell mutator time (as opposed to the user time) at which +the retainer profiling starts, +the average number of times a closure is visited, +the sum of costs assigned to all retainer sets (obtained from the field +@cost@ in each retainer set), +and the number of all retainer sets created \emph{since} the beginning +of program execution. +A typical entry in a @.prof@ file looks like: + +\begin{code} +Retainer Profiling: 3, at 3.530000 seconds + Average number of visits per object = 1.687765 + Current total costs = 801844 + Number of retainer sets = 118 +\end{code} + +The sum of costs assigned to all retainer sets may \emph{not} be equal to the +size of the heap. +The discrepancy is attributed to those live object which are not reachable +from the set of roots. +Still it is a good estimate of the size of the heap at the moment when +the retainer profiling was performed. + +The @.prof@ file also shows the contents of every retainer set which +has been assigned a positive cost (i.e., the field @cost@) at least once; +not every retainer set created is assigned a positive cost because quite +a few retainer sets are created as intermediate retainer sets before +creating a real retainer set. This results from the restriction on the way +retainer sets are created (only one retainer can be added to an existing +retainer set at a time). + +An example of the contents of a retainer set is: + +\begin{code} +SET 71 = {, } +\end{code} + +The retainer set has an identification number $71$. +It is associated with two retainers, whose retainer identities are shown +inside angle brackets @<...>@. +For instance, the first retainer is created when the cost centre stack +is @doFile[Main],main[Main],MAIN[MAIN]@, shown from the top to the bottom. +Each entry in angle brackets consists of a cost centre name (e.g., @doFile@) +and its module name (e.g., @Main@). + +The @.hp@ file can be supplied to the @hp2ps@ program to create a postscript +file showing the progress of retainer profiling in a graph: + +\begin{code} +$ hp2ps Foo.hs +$ gv Foo.ps +\end{code} + +An example of such a graph is shown in Figure~\ref{fig-cacheprof}. +It shows the cost assigned to each retainer set at the point +when a retainer profiling is performed (marked by a corresponding inverted +triangles on the horizontal axis). +The abbreviated contents of each retainer set is displayed in the right column. +Due to the space limitation, +it shows only topmost cost centres (without module names) +instead of printing the full contents. +For instance, @(71)doFile,synth_2@ corresponds to a retainer set shown above +(@71@ is its identification number). +The contents may be truncated if it is too long. + +Notice that the time is in the Haskell mutator time, which excludes +the runtime system time such as garbage collection time and retainer profiling +time. Thus, the actual execution takes longer than indicated in the +graph. Also, the timer employed to periodically perform retainer profiling +is not perfectly accurate. Therefore, the result may slightly vary for each +execution of retainer profiling. + +\begin{figure}[ht] +\centering +\epsfig{file=cacheprof_p.eps,width=5in} +\caption{A graph showing the progress of retainer profiling} +\label{fig-cacheprof} +\end{figure} + +\section{Comparison with nhc} + +\section{Files} + +This section gives a summary of changes made to the GHC in +implementing retainer profiling. +Only three files (@includes/StgRetainerProf.h@, @RetainerProfile.c@, and +@RetainerProfile.h@) are new, and all others exist in the GHC. + +@\includes@ directory: + +\begin{description} +\item[StgRetainerProf.h] defines types @retainer@ and @retainerSet@. +\item[Stg.h] includes the header file @StgRetainerProf.h@. +\item[Closures.h] changes structure @StgProfHeader@. +\item[Constants.h] changes constants @PROF_HDR_SIZE@, @SCC_UF_SIZE@, and + @SCC_SEQ_FRAME_SIZE@. +\item[ClosureMacros.h] changes macros @SET_PROF_HDR()@ and + @SET_STATIC_PROF_HDR()@. +\item[Updates.h] changes macro @PUSH_STD_CCCS()@. +\end{description} + +@\rts@ directory: + +\begin{description} +\item[Exception.hc] changes constant @CATCH_FRAME_BITMAP@, +\item[StgStartup.hc] changes constant @STOP_THREAD_BITMAP@. +\item[StgStdThunks.hc] changes constant @RET_BITMAP@. +\item[Updates.hc] changes constant @UPD_FRAME_BITMAP@. +\item[RetainerProfile.c] implements the retainer profiling engine. +\item[RetainerProfile.h] is the header for @RetainerProfile.c@. +\item[RetainerSet.c] implements the abstract datatype @retainerSet@. +\item[RetainerSet.h] defines the interface for @retainerSet@. +\item[GC.c] invokes @resetStaticObjectForRetainerProfiling()@ in + @GarbageCollect()@. +\item[Itimer.c] changes @handle_tick()@. +\item[ProfHeap.c] changes @initHeapProfiling()@ and @endHeapProfiling()@. +\item[Profiling.c] changes @initProfilingLogFile()@ and + @report_ccs_profiling()@. +\item[Proftimer.c] declares @ticks_to_retainer_profiling@, + @performRetainerProfiling@, and @doContextSwitch@. +\item[Proftimer.h] is the header for @Proftimer.c@. Defines @PROFILING_MIN_PERIOD@, + which specifies the minimum profiling period and the default profiling period. +%\item[RtsAPI.c] implements @setRetainerField()@. +\item[RtsFlags.c] + sets @RtsFlags.ProfFlags.doHeapProfile@ and + adds a string to @usage_text[]@ in @setupRtsFlags()@. +\item[RtsFlags.h] defines constants @HEAP_BY_RETAINER@ and @RETAINERchar@. +\item[RtsStartup.c] includes the header file @RetainerProfile.h@. + Changes @shutdownHaskell()@. +\item[Schedule.c] changes @schedule()@. +\item[Stats.c] + declares @RP_start_time@, @RP_tot_time@, @RPe_start_time@, + @RPe_tot_time@. + Changes @mut_user_time_during_GC()@, @mut_user_time()@, + @stat_startExit()@, + @stat_endExit()@, and + @stat_exit()@. + Defines + @mut_user_time_during_RP()@, + @stat_startRP()@, and + @stat_endRP()@. +\item[Stats.h] is the header for @Stats.c@. +\item[StgMiscClosures.hc] redefines @stg_DEAD_WEAK_info@. +\item[Storage.c] changes @initStorage()@, @memInventory()@. +\end{description} + +\bibliographystyle{plain} +\bibliography{reference} + +\end{document} diff --git a/docs/storage-mgt/sm.tex b/docs/storage-mgt/sm.tex new file mode 100644 index 00000000..9dee565c --- /dev/null +++ b/docs/storage-mgt/sm.tex @@ -0,0 +1,995 @@ +\documentclass{article} +\usepackage{code,a4wide} + +\usepackage{graphics,epsfig,epic,eepic} + +\setlength{\parskip}{0.25cm} +\setlength{\parsep}{0.25cm} +\setlength{\topsep}{0cm} +\setlength{\parindent}{0cm} +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + + +% Terminology +\newcommand{\block}{block} +\newcommand{\Block}{Block} +\newcommand{\segment}{segment} +\newcommand{\Segment}{Segment} +\newcommand{\step}{step} +\newcommand{\Step}{Step} + +\newcommand{\note}[1]{{\em $\spadesuit$ #1}} + +\begin{document} +\title{The GHC Storage Manager} +\author{Simon Peyton-Jones and Sungwoo Park} + +\makeatactive +\maketitle +\section{Introduction} + +This document describes the details of the GHC storage manager, including +the interface and implementation of each of its components. + +\section{Goals} + +Storage management goals are: +\begin{itemize} +\item Generational collection, supporting multiple generations. +\item The ability to pin the allocation +area into a few pages that we hope will fit entirely in the cache. +\item Allows objects to age within a generation before getting promoted. +\item Heap can grow as needed, rather than having to be pre-sized + by the programmer. +\item We support mark/sweep/compact collection for older generations. +This is a Good Thing when the live memory approaches the available +physical memory, because it reduces paging. +\item Little OS support needed. No @mmap()@ etc. All that we require is + the ability to call @malloc()@ to allocate a new chunk of memory. + There can be intervening ``sandbars'' allocated by other programs + (e.g. DLLs or other @malloc()@'d structures) between chunks of heap. +\end{itemize} + +Language-support goals are: +\begin{itemize} +\item The garbage collector ``shorts out'' indirection objects introduced +by the mutator (notably when overwriting a thunk with an indirection). +\item The garbage collector executes selector thunks. +For example, a thunk for +@(fst x)@ where @x@ is a pointer to a pair @(a,b)@ would be +evaluated by the garbage collector to just @a@. This is an important +strategy for plugging space leaks. +\item The garbage collector traversese the code tree, as well as +the heap data structures, to find which CAFs are live. This is a royal pain. +\item The garbage collector finalises some objects (typically a tiny minority). +At the moment ``finalisation'' means ``call a C routine when this thing +dies'' but it would be more general to schedule a call to a Haskell +procedure. +\end{itemize} + +Instrumentation goals are: +\begin{itemize} +\item The garbage collector can gather heap-census information for profiling. +To this end we can force GC to happen more often than it otherwise would, +and the collector can gather information about the type and cost-centre +associated with each heap object. +\end{itemize} + +\section{The architecture of the storage manager} + +The storage manager is a component of the GHC system which is responsible +for allocating fresh memory for new objects and reclaiming memory +that is no longer used. +It is built on a layered architecture and consists of four main parts: +\emph{megablock allocator}, \emph{block allocator}, \emph{heap allocator}, +and \emph{garbage collector} (Figure~\ref{fig-architecture}). +The megablock allocator communicates directly with the underlying +operating system and forms the lowest level of the storage manager. +The heap allocator and garbage collector lie in the topmost level of +the storage manager and process requests from +the mutator (the Haskell realm at the runtime) and the runtime system. +The block allocator lies between the two levels. + +\begin{figure}[ht] +\begin{center} +\input{architecture.eepic} +\caption{The overall architecture of the storage manager} +\label{fig-architecture} +\end{center} +\end{figure} + +\section{The megablock allocator} + +% need more elaboration - Sung +The megablock allocator implements a direct interface to the underlying +operating system. +It can request a chunk of physical memory of a fixed size, +which is called a \emph{megablock}, from the operating system and returns it +to the block allocator. A new megablock is not initialized by the +megablock allocator; it is later initialized by the block allocator. + +\subsection{Interface} + +\begin{description} +\item[@void *getMBlock()@] allocates a single megablock and returns its +starting address. +\item[@void *getMBlocks(nat n)@] allocates @n@ contiguous megablocks +and returns their starting address. +\end{description} + +\subsection{Implementation} + +Since the megablock allocator communicates directly with the underlying +operating system, its implementation relies on memory allocation functions +provided by the operating system; thus, the implementation varies between +platforms. +However, every megablock is always of a fixed size $2^M$ and aligned on a +$2^M$ boundary, regardless of the platform +(@MBLOCK_SIZE@ in @include/Constants.h@ defines the size of megablocks). +@mblocks_allocated@ in @MBlock.c@ stores the number of megablocks allocated. + +For implementation details, see @MBlock.c@, @MBlock.h@, @include/Block.h@. + +\section{The block allocator} + +The block allocator divides a megablock returned by the megablock allocator +into a contiguous group of \emph{block descriptors} followed by another +contiguous group of \emph{blocks}. + +A block is a contiguous chunk of $2^K$ bytes, starting on +a $2^K$-byte boundary (@BLOCK_SIZE@ in +@include/Constants.h@ defines the size of blocks). +Each block has its own associated block descriptor, which records the +current state of the block. + +Figure~\ref{fig-megablock} shows a megablock after initialization by the +megablock allocator. +Block descriptors occupy the lower address space and blocks the higher address +space in the megablock. +A block is the unit of allocation for the block allocator. +That is, the block allocator hands over store to the heap allocator in multiples of +one block, where multiple heap objects may be allocated. +A contiguous group of blocks, which is called a \emph{block group}, can be +directly handed over to the heap allocator to reduce inter-block +linkage costs. +The first block of a block group is called the \emph{group head}.\footnote{ +An alternative design has the block descriptor at the start of each block. +This makes it easy to locate the block descriptor corresponding to a particular +block, but is pessimistic for cache locality when fiddling with block descriptors. +It also means that only the first block in a contiguous chunk of blocks can +have a block descriptor. This in turn makes it difficult to achieve an +efficient mostly-copying conservative (MCC) garbage collector.} +Since block descriptors are ordered linearly, we can always locate a block +descriptor corresponding to a particular block from the starting address +of the block. + +\begin{figure}[ht] +\begin{center} +\input{megablock.eepic} +\caption{A megablock after initialization} +\label{fig-megablock} +\end{center} +\end{figure} + +\subsection{Interface} + +\begin{description} +\item[@typedef struct bdescr@] is the type of block descriptors. +\item[@void initBlockAllocator(void)@] initializes the block allocator. +\item[@bdescr *allocBlock(void)@] requests a single block and returns +the address of its block descriptor. +\item[@bdescr *allocGroup(nat n)@] allocates a block group of size @n@ +and returns the address of the block descriptor for the group head. +\item[@void freeGroup(bdescr *p)@] frees the block group where @p@ points +to the block descriptor of the group head, and places it in a pool of +free block groups. +\item[@bdescr *Bdescr(StgPtr p)@] takes a pointer @p@ to any byte within +a block and returns a pointer to its block descriptor. It is implemented as +an @inline@ procedure. +\end{description} + +\subsection{Block descriptors} + +A block descriptor has the following structure, defined in +@include/Blocks.h@: + +\begin{code} +typedef struct _bdescr { + StgPtr start; + StgPtr free; + StgWord32 blocks; + struct _bdescr *link; + /* additional fields */ +} bdescr; +\end{code} + +The fields of a block descriptor have the following purposes: + +\begin{description} +\item[@start@] points to the first byte of the corresponding block. +\item[@free@] For a group head, @free@ points to the first free byte in +the block group. For a non-group head, @free@ is set to zero to identify +the corresponding block as a non-group head. +\item[@blocks@] For a group head, @blocks@ stores the number of blocks +in the block group. It is not used for non-group heads. +\item[@link@] For a group head, @link@ is used to chain all individual +blocks or block groups together. For a non-group head, @link@ points +to the block descriptor of the group head. +\end{description} + +\subsection{Implementation} + +The block allocator maintains a linked list of free block groups, whose head +is stored in @free_list@ in @BlockAlloc.c@ (Figure~\ref{fig-freelist}). +When @allocBlock()@ or @allocGroup()@ is called, the block allocator +scans the linked list from @free_list@ and finds the first block group +which can handle the request. +If such a block group exists, it takes off the requested number of blocks +from the block group, creates a new block group from them, +initializes it if needed, and returns it to the caller. +The rest of the old block group, if any, is linked back to the list of free block +groups as another block group. +If such a block group does not exist, the block allocator requests a megablock +from the megablock allocator and processes the request using the new megablock. + +For implementation details, see @BlockAlloc.c@ and @include/Block.h@. + +\begin{figure}[ht] +\begin{center} +\input{freelist.eepic} +\caption{Linked list of free block groups} +\label{fig-freelist} +\end{center} +\end{figure} + +\section{Heap allocator} + +The role of the heap allocator in the storage manager is to allocate fresh +memory upon requests from the mutator and the runtime system. +Memory allocation takes place frequently during the execution of Haskell +programs, and hence its efficiency is crucial to the overall performance. +To handle requests from the mutator and the runtime system efficiently, +the heap allocator maintains three different memory stores, +each of which has its own purpose. + +The first store is the \emph{nursery}, where typical Haskell +objects are born. +The mutator itself can allocate fresh memory directly in the nursery +without invoking an interface function: +the configuration of the nursery is always revealed to the mutator and can even +be changed by the mutator when it allocates fresh memory from the nursery +on its own. +Thus, although the small overhead in manipulating the nursery results in fast +memory allocation, it is up to the mutator to keep the nursery in an +uncorrupted state. + +The second and the third are the \emph{small object pool} and the +\emph{large object pool}. +The heap allocator provides a common interface function to be shared by both stores: +the size of fresh memory requested, which is passed as an argument to the +interface function, determines which of the two stores to be used. +The interface function can be called by both the mutator and the runtime system. + +\subsection{Interface} + +\begin{description} +\item[@void initStorage(void)@] initializes the storage manager. @Storage.c@. +\item[@void allocNurseries(void)@] creates and initializes the nursery. +@Storage.c@. +\item[@void resetNurseries(void)@] re-initializes the nursery. @Storage.c@. +\item[@OpenNursery(hp, hplim)@] opens an allocation area in the nursery and sets +@hp@ and @hplim@ appropriately. +Then the caller can freely use the memory from @hp@ to @hpLim@. +A macro in @include/StgStorage.h@. +\item[@CloseNursery(hp)@] closes the current allocation area beginning at @hp@ +and returns it to the storage manager. +A macro in @include/StgStorage.h@. +\item[@ExtendNursery(hp, hplim)@] closes the current allocation area and +tries to find a new allocation area in the nursery. +If it succeeds, it sets @hp@ and @hplim@ appropriately and returns @rtsTrue@; +otherwise, it returns @rtsFalse@, +which means that the nursery has been exhausted. +The new allocation area is not necessarily contiguous with the old one. +A macro in @Storage.h@. +\item[@StgPtr allocate(nat n)@] allocates @n@ words from either the small +object pool or the large object pool, depending on the argument @n@, +and returns a pointer to the first byte. It \emph{always} succeeds. +@Storage.c@. +\end{description} + +\subsection{Implementation} + +The nursery is implemented with a fixed number of blocks (@nursery_blocks@ +in @Storage.c@ specifies the number of blocks). +Each of these blocks forms its own block group, and they are all linked together +by @allocNurseries()@. +The blocks in the nursery are carefully allocated in a contiguous address +range so that they fit next to each other in the cache. +They are never freed. + +A single block called the \emph{active block} provides the allocation area for +the mutator at any moment. +When the free space left in the active block is not enough for the request from +the mutator, the heap allocator sets the @free@ field in the corresponding +block descriptor to the first free byte in the block and moves the allocation +area to the next block. + +Figure~\ref{fig-nursery} shows the configuration of the nursery during +the mutator time. +The head of the linked list is stored in @MainRegTable.rNursery@, and +the address of the block descriptor of the active block is stored +in @MainRegTable.rCurrentNursery@. +@Hp@, defined as @MainRegTable.rHp@, points to the byte before the first byte of +the current allocation area in the active block. +@HpLim@, defines as @MainRegTable.rHpLim@, marks the boundary of the current +allocation area: +it points to the last byte in the current allocation area, and thus +all the bytes of memory addresses from @Hp@$ + 1$ to @HpLim@ are free. +The mutator can obtain fresh memory simply by adjusting @Hp@ as long as the new +value of @Hp@ does not exceed @HpLim@. For instance, if the mutator +increases @Hp@ by @n@, it can now store an object of size up to @n@ at the +address pointed to by the old value of @Hp@$ + 1$. + +When the runtime system runs, none of the above four pointers +(@MainRegTable.rNursery@, @MainRegTable.rCurrentNursery@, @Hp@ and @HpLim@) are +valid; they are simply aliases to registers. +Instead @g0s0->blocks@\footnote{@g0s0->blocks@ is valid all the time, even during +the mutator time. The meaning of @g0s0@ is explained in the next section.} +can be used to retrieve the head of the linked list, and +the @free@ field in each block descriptor points to the first free byte +in its corresponding block.\footnote{To be precise, this is \emph{not} the +case: a @free@ field may point to a byte past its actual boundary. +This happens because +the mutator first increases @hpLim@ without comparing it with the +actual boundary when allocating fresh memory, +and later assigns @hpLim@ to the @free@ of the corresponding block.} +@Hp@ and @HpLim@ are not saved because they can be inferred from @free@ fields +of the blocks descriptors in the nursery. + +\begin{figure}[ht] +\begin{center} +\input{nursery.eepic} +\caption{Nursery during the mutator time} +\label{fig-nursery} +\end{center} +\end{figure} + +The small object pool is implemented with a linked list of block groups, +each of which consists of a single block (Figure~\ref{fig-smallobjectpool}). +The head of the linked list is stored in @small_alloc_list@ in @Storage.c@. + +\begin{figure}[ht] +\begin{center} +\input{smallobjectpool.eepic} +\caption{Small object pool} +\label{fig-smallobjectpool} +\end{center} +\end{figure} + +The allocation in the small object pool is done in the same way as in the +nursery; @alloc_Hp@ and @alloc_HpLim@ (both defined in @Storage.c@) +point to the first free byte and the boundary of the small object pool, +respectively. +Thus, when @allocate()@ is called and the heap allocator decides to +allocate fresh memory in the small object pool, it simply increases @alloc_Hp@ +by the size of memory requested. +If the allocation cannot be done in the current small object pool, the +heap allocator calls @allocBlock()@ to obtain a new block from the block +allocator, puts it to the head of the linked list, and +sets @alloc_Hp@ and @alloc_HpLim@ appropriately. + +The large object pool is also implemented with a (doubly) linked list of block +groups (Figure~\ref{fig-largeobjectpool}). +The difference from the small object pool is that each block group stores only +a single object: each time the argument to @allocate()@ is +greater than a threshold value (computed from @LARGE_OBJECT_THRESHOLD@ +in @include/Constants.h@), a new block group accommodating the requested size +is created to store a single object. +The new block group is put to the head of the list. +The head of the linked list is available as @g0s0->large_objects@. + +\begin{figure}[ht] +\begin{center} +\input{largeobjectpool.eepic} +\caption{Large object pool} +\label{fig-largeobjectpool} +\end{center} +\end{figure} + +For implementation details, see @Storage.c@ and @include/StgStorage.h@. + +\section{Garbage collector} + +The garbage collector finds all the objects unreachable from a given set of +roots and frees the memory allocated to them. By invoking the +garbage collector regularly, the storage manager prevents the heap from +growing indefinitely and allows Haskell programs to be executed at a +reasonable memory cost. + +The garbage collector in the storage manager is based upon the generational +garbage collection algorithm. +The storage manager records the age for every object in the heap. +An object surviving one garbage collection grows old by one \emph{step}, +and an object surviving a certain number of garbage collections +is promoted to the next \emph{generation}. +That is, a step can be defined as a collection of objects which have survived +the same number of garbage collections (or a collection of objects which are +born at some point between two particular successive garbage collections), +and a generation as a group of steps belonging to a certain range of ages. +Notice that the unit of garbage collections is not step but generation: +a garbage collection applies to all the steps in a generation, and we cannot +perform a garbage collection just on part of a generation. +Furthermore, if a particular generation is garbage collected, so are +all the younger generations.\footnote{Some +authors define a generation as the set of +all the objects created between two particular garbage collection and +an object cannot change its generation (e.g., 1960's, 1970's, and so on). +In this document, +an object can change its generation as it survives garbage collections +(e.g., teenagers, 20's, and so on).} + +Figure~\ref{fig-generation} illustrates how an object grows old. +Every object is created in step $0$ of generation $0$. +As it survives garbage collections, it is moved to the next step of the +same generation until it is finally promoted to +step $0$ of the next generation: +during a garbage collection of generation $g < G$, live objects from +step $s < S_g$ are moved to step $s + 1$, and live objects from +the last step $S_g$ are promoted to step $0$ in generation $g + 1$. +Live objects in step $0$ of generation $G$ stay in the same step; +the oldest generation maintains only one step because there is no point +in aging objects in the oldest generation. +In this way, objects are given a decent chance of dying before being +promoted to the next generation. + +\begin{figure}[ht] +\begin{center} +\input{generation.eepic} +\caption{Evolution of objects through garbage collections} +\label{fig-generation} +\end{center} +\end{figure} + +The main reason that we separate steps from generations is to +reduce the cost of maintaining \emph{backward inter-generational pointers}, +that is, pointers from older generations to younger generations. +Suppose that a garbage collection applies to all generations $0$ +through $g$. If an object @O@ in one of these generations is pointed to +by another object in generation $g' > g$, we cannot free the object @O@ +even though generation $g'$ is out of consideration. Consequently +we have to track backward inter-generational pointers to perform garbage +collections correctly. +Since maintaining backward pointers is costly, we +choose to track backward inter-generational pointers only; +we do not track backward inter-step pointers. + +By grouping all the objects created between two garbage collections +and grouping multiple age groups into one generation, the garbage +collector makes an efficient use of heap memory. + +\subsection{Interface} + +\begin{description} +%\item[@StgClosure *MarkRoot(StgClosure *root)@] informs the garbage collector +%that @root@ is an object in the root set. It returns the new location of +%the object. @GC.c@. +\item[@void *mark\_root(StgClosure **root)@] informs the garbage collector +that @*root@ is an object in the root set. It replaces @*root@ by +the new location of the object. @GC.c@. +\item[@void GarbageCollect(void (*get\_roots)(evac\_fn), rtsBool force\_major\_gc)@] +performs a garbage collection. +@get_roots()@ is a function which is called by the garbage collector when +it wishes to find all the objects in the root set (other than those +it can find itself). +Therefore it is incumbent on the caller to find the root set. +@force_major_gc@ specifies whether a major garbage collection is required +or not. If a major garbage collection is not required, the garbage collector +decides an oldest generation $g$ to garbage collect on its own. +@GC.c@. +\item[@rtsBool doYouWantToGC(void)@] returns @rtsTrue@ if the garbage +collector is ready to perform a garbage collection. Specifically, it returns +@rtsTrue@ if the number of allocated blocks since the last garbage collection +(@alloc_blocks@ in @Storage.c@) exceeds an approximate limit +(@alloc_blocks_lim@ in @Storage.c@). +@Storage.h@. +\item[@void recordMutable(StgMutClosure *p)@] informs the garbage collector +that a previously immutable object @p@ has become mutable. +The garbage collector then puts the object @p@ in the list @mut_list@ of the +generation to which it belongs.\footnote{It is easy to +locate the generation to which a dynamic object belongs from its address: +we can identify the block in which the object resides from its address, +and the corresponding block descriptor stores pointers +to the step and the generation (@gen@ and @step@ fields in the @bdescr@ +structure) to which it belongs.} +It suffices to call @RecordMutable()@ only once for any object. + +For an object which is genuinely mutable (e.g., mutable arrays), +it is permanently recorded as mutable. +On the other hand, +an object which is temporarily mutable (e.g., frozen arrays), +can be dropped from the list @mut_list@ once its pointer has been dealt with +during garbage collections. @Storage.h@. +\item[@void recordOldToNewPtrs(StgMutClosure *p)@] puts the object @p@ in the +list @mut_once_list@ of the generation to which it belongs. +\item[@void newCAF(StgClosure *caf)@] puts the CAF @caf@ either +in the list @caf_list@ or +in the list @mut_once_list@ of the oldest generation, +depending on whether it is dynamically loaded or not. +\end{description} + +\subsection{Steps} + +A step has the following structure, defined in +@include/StgStorage.h@: + +\begin{code} +typedef struct _step { + unsigned int no; + bdescr *blocks; + unsigned int n_blocks; + bdescr *large_objects; + /* additional fields */ +} step; +\end{code} + +The fields of a step have the following purposes (Figure~\ref{fig-step}): + +\begin{description} +\item[@no@] indicates the age within its generation. +$0$ indicates the youngest step in a generation. +\item[@blocks@] is a linked list of all the blocks in this step +which contain small objects. +Each block forms its own block group. +\item[@n\_blocks@] is the number of blocks in the linked list @blocks@. +\item[@large\_objects@] is a (doubly) linked list of all the block groups +in this step which contain large objects. +Each block group stores only a single object. +\end{description} + +\begin{figure}[ht] +\begin{center} +\input{step.eepic} +\caption{Memory layout of a step} +\label{fig-step} +\end{center} +\end{figure} + +The linked list @blocks@ of step $s$ in generation $g$ is created +during a garbage collection +from live small objects of step $s - 1$ in the same generation +(or the last step in the previous generation if $s = 0$). +The @free@ field in every block descriptor never changes because +no objects are added after the garbage collection; new objects are created +only in step $0$ in generation $0$. +Likewise, the linked list @large_objects@ is created during a +garbage collection from live large objects of the previous step. + +There are three exceptions to the above rules. +First, both @blocks@ and @large_objects@ of +step $0$ in generation $0$ are not filled with new objects during a garbage +collection. +They are simply re-initialized by the garbage collector and +grow during during the execution of a program as new objects are +created. +Step $0$ in generation $0$ is accessible via a global variable @g0s0@, +and this is the reason why the large object pool (described in the previous +section) is indeed stored in @g0s0->large_objects@. +For the same reason, @MainRegTable.rNursery@ holds the same address as +@g0s0->blocks@ during the mutator time. +Second, @blocks@ of step $1$ in generation $0$ is created not only from +the nursery (@blocks@ of step $0$ in the same generation) but also from the +small object pool. In other words, all the live small objects created since +the previous garbage collection, either directly by the mutator or indirectly +through @allocate()@, are gathered together in the same linked list. +Finally, step $0$ of the oldest generation serves the source for itself during +any garbage collection, i.e., $S_G = 1$, because there exists no older step. + +\subsection{Generations} + +A generation has the following structure, defined in +@include/StgStorage.h@: + +\begin{code} +typedef struct _generation { + unsigned int no; + step *steps; + unsigned int n_steps; + unsigned int max_blocks; + StgMutClosure *mut_list; + StgMutClosure *mut_once_list; + /* additional fields */ +} generation; +\end{code} + +The fields of a generation have the following purposes (Figure~\ref{fig-gen}): + +\begin{description} +\item[@no@] is the generation number. +\item[@steps@] points to an array of @step@ structures. @steps[@$i$@]@ +corresponds to step $i$ in this generation, i.e., +@steps[@$i$@].no@ is equal to $i$. +\item[@n\_steps@] is the number of @step@ structures in the array pointed to +by @steps@. +\item[@max\_blocks@] is the maximum number of blocks allowed in step $0$ of +this generation. If the number of blocks allocated +in step @0@ exceeds @max_blocks@, +this generation is garbage collected during the next garbage collection. +\item[@mut\_list@] links all mutable objects in this generation, that is, +objects whose contents can be updated and hence may contain pointers to +younger generations. +Every object in this linked list is a dynamic object residing in the heap +and has a structure compatible with @StgMutClosure@. +The structure @StgMutClosure@ (@includes/Closures.h@) has a field +@mut_link@ (called a mutable link field) of type @StgMutClosure *@, which +points to the next object in this linked list. +The end mark of this linked list is a pointer to a statically allocated object +@END_MUT_LIST@ (@StoragePriv.h@). +\item[@mut\_once\_list@] links objects in this generation whose contents +cannot be updated any more but may already have pointers to younger generations. +As with @mut_list@, it links only those objects whose structure is compatible +with @StgMutClosure@ and ends with @END_MUT_LIST@. +\end{description} + +\begin{figure}[ht] +\begin{center} +\input{gen.eepic} +\caption{Memory layout of a generation} +\label{fig-gen} +\end{center} +\end{figure} + +The garbage collector maintains an array @generations@ of @generation@ structure +(defined in @Storage.c@), whose size is stored in a runtime system flag +(@RtsFlags.GcFlags.generations@). +The generation number of each generation coincides with its index into +the array @generations@, i.e., @generations[@$i$@].no@ is equal to $i$. + +As mentioned before, lists of objects which may have pointers to younger +generations are kept per generation, not per step. The youngest generation, +accessible via a global variable @g0@, does not keep such a list because it +does not have younger generations. + +The oldest generation, accessible via a global variable @oldest_gen@, may +contain static objects (as opposed to dynamic objects residing in the heap) +in its list @mut_once_list@. This happens when a static +thunk, also known as a \emph{constant applicative form} (CAF), is entered. +When a CAF (corresponding to closure type @THUNK_STATIC@, defined +in @includes/ClosureTypes.h@) is entered, +it is first put in the list @mut_once_list@ of the oldest generation +and then overwritten with an appropriate static indirection object +(corresponding to closure type @IND_STATIC@).\footnote{Actually a static +indirection object does not have a @mut\_link@ field. +We use its @static\_link@ field as a substitute for @mut\_link@. +See the structure @StgIndStatic@ in @include/Closures.h@.}\footnote{For +details of this operation, see the macro @UPD\_CAF()@ in @includes/Updates.h@} +If the CAF is dynamically loaded (e.g., in an interactive environment), it is +instead put in a separate linked list @caf_list@ +(declared in @Storage.c@). + +The evaluation result of the +CAF is stored in a separate dynamic object in the heap and the static +indirection object has a pointer to the dynamic object. +Thus, the new static indirection object is put in the list +@mut_once_list@ of the oldest generation (or the list @caf_list@) so that the +dynamic object is not removed during the next garbage collection. +Once it is created, the static indirection object remains unaltered, which +is the reason why it is put in the @mut_once_list@ list, not in the +@mut_list@ list. +Since the static indirection object survives any garbage collection (because +it comes from a static object) and would be eventually moved to the oldest +generation, +we put it in the @mut_once_list@ of the oldest generation as soon +as it is created. + +\subsection{Implementation} + +The overall structure of a garbage collection is as follows: + +\begin{enumerate} +\item[(1)] Initialize. +\item[(2)] Scavenge lists @mut_once_list@ and @mut_list@ if necessary. +\item[(3)] Scavenge CAFs. +\item[(4)] Evacuate roots. +\item[(5)] Scavenge objects. +\item[(6)] Tidy up. +\end{enumerate} + +\subsubsection{(1) Initialization} + +During initialization, the garbage collector first decides which generation +to garbage collect. +Specifically, +if the argument @force_major_gc@ to @GarbageCollect()@ is @rtsFalse@, +it decides the greatest generation number $N$ such +that the number of blocks allocated in step $0$ of generation $N$ exceeds +@generations[@$N$@].max_blocks@. +If the argument @force_major_gc@ to @GarbageCollect()@ is @rtsTrue@, +$N$ is set to the greatest generation number, namely, +$@RtsFlags.GcFlags.generations@ - 1$. +The garbage collector considers up to generation $N$ for garbage collection. +A major garbage collection takes place if $N$ is set to +$@RtsFlags.GcFlags.generations@ - 1$ during this process. + +Then, the garbage collector initialize the \emph{to-space} (as opposed to +\emph{from-space}) for each step of +each generation, which is complete with an \emph{allocation pointer} and +an \emph{sweep pointer}. +The to-space of a step is the memory to which any object belonging to the +step can be copied when it survives a garbage collection. +For instance, a live object in step $s$ of generation $g$ can first be copied +to the to-space associated with step $s$, which eventually becomes +associated with the next step $s + 1$ (or step $0$ of the next generation) +during tidying up. +This operation effectively moves an object to the next step if it survives +a garbage collection. +The allocation pointer points to the next free in the to-space while +the sweep pointer points to the next object considered for scavenging. + +During major garbage collections, +the static link field of every static object indicates whether it has +been visited by the garbage collector or not. +Therefore, the static link field of every static object must have +a null value before a major garbage collection starts. +The list @mut_once_list@ of the oldest generation may contain static +indirection objects, and thus +the garbage collector invokes @zero_mutable_list()@ on the list, +Although this breaks up the list, it does not cause any problem because +the list is not employed during major garbage collections. + +\subsubsection{\tt evacuate()} + +The function @evacuate()@ (defined in @GC.c@), which +is called eventually for every live object +(including even static objects reachable from roots), +moves an object to +a safe place so as not to be garbage collected. +Before invoking the function @evacuate()@ on an object @o@, the caller specifies +a \emph{desired generation} for @o@ in a variable @evac_gen@ +(declared in @GC.c@). +The desired generation is the youngest generation to which the caller wishes +@o@ to be evacuated; the garbage collector should evacuate @o@ to a +generation no younger than the desired generation. + +Depending on @evac_gen@ and the generation $M$ where @o@ currently resides, +@evacuate()@ behaves itself as follows: +\begin{itemize} +\item If @evac_gen@ $\leq M$ and $N < M$, it does nothing because @o@ is already + in a generation no younger than @evac_gen@. +\item If @evac_gen@ $\leq M \leq N$, it evacuates @o@ to the to-space of the +step to which @o@ currently belongs. @o@ will be moved to the next step later. +@recordMutable()@ may be invoked on @o@ depending on its type (e.g., @MVAR@). +\item If $M <$ @evac_gen@, @o@ is evacuated to the to-space of step $0$ + of generation @even_gen@, which accomplishes the request. + This happens even when $N \leq$ @evac_gen@. Therefore, those generations + which are not considered for garbage collection may still be augmented + with new objects during garbage collection. + @recordMutable()@ may be invoked on @o@ depending on its type. +\end{itemize} +If @o@ has already been evacuated, @evacuate()@ either does nothing (when +@even_gen@ $\leq M$) or reports +a failure to evacuate @o@ by setting the flag @failed_to_evac@ (declared +in @GC.c@). + +Evacuating a large object is handled by @evacuate_large()@. +Since it is costly to allocate new memory blocks and copy all the contents +of the object, the garbage collector simply removes the object form +the list @large_alloc_list@ of its step and links it to another list, +from which it will be scavenged later. + +\subsubsection{Set of roots for garbage collection} +Part of the set of roots for garbage collection is obtained indirectly by +invoking the function +@get_roots()@, an argument to @GarbageCollect()@: the garbage collector +invokes @get_roots()@ with @mark_root()@ as an argument, and @get_roots()@ +in turn invokes @mark_root()@ on each of known roots. +The rest of the set of roots is obtained from the lists @mut_list@ and +@mut_once_list@ of generation $N + 1$ through the oldest generation: +any objects in these lists may have pointers to objects in generations +$0$ to $N$, and thus must be considered as a root. +If a major garbage collection takes place, no @mut_list@ and @mut_once_list@ +lists are consider for scavenging and step (2) is skipped. +The entire set of roots is now specified by @get_roots()@ alone. + +\subsubsection{(2) Scavenging lists {\tt mut\_once\_list} and {\tt mut\_list}} + +Since the roots obtained from the lists @mut_list@ and @mut_once_list@ are +already in generations $N' > N$, we only have to scavenge them. +That is, it suffices to invoke @evacuate()@ once on each object +which is currently pointed to by an object in these lists. + +When scavenging an object @r@ in the list @mut_once_list@ of generation $M$, +the desired generation is set to $M$ for each object @o@ pointed +to by @r@ before invoking @evacuate()@. +The rationale is that the contents of @r@ cannot be updated any more, +and thus @r@ is always survived by @o@; @o@ is live as long as @r@ is. +Therefore, we wish @r@ to be evacuated to the same generation $M$ as @r@ +currently resides (not to its next step). +If the evacuation succeeds (indicated by a @rtsFalse@ value of a variable +@failed_to_evac@, declared in @GC.c@) for every object @o@, @r@ is removed +from the list @mut_once_list@ because it does not hold any backward +inter-generational pointers.\footnote{It turns out that @r@ can have only +one such object @o@. The type of @r@ is one of the following: +@IND\_OLDGEN@, @IND\_OLDGEN\_PERM@, @IND\_STATIC@, and @MUT\_VAR@.} + +Scavenging a list @mut_list@ is similar to the case of @mut_once_list@. +When scavenging an object @r@ in the list @mut_list@ of generation $M$, +the desired generation is set to $M$ for each object pointed to by @r@ +if @r@ is known to be immutable (e.g., @MUT_ARR_PTRS_FROZEN@, +@IND_OLDGEN@) +or to $0$ if @r@ is still mutable (e.g., @MUT_ARR_PTRS@, @MUT_VAR@). +The list @mut_once_list@ is also adjusted if it is safe to remove @r@ from +@mut_list@. + +\subsubsection{(3) Scavenging CAFs} + +When a dynamically loaded CAF is entered, it it first put to the list +@caf_list@ and then overwritten with a static indirection object. +The evaluation result of the CAF is stored in a dynamic object in the heap +and the static indirection object stores a pointer to the dynamic object. +Although the static indirection object (or the CAF) itself is never freed, +it may be removed later from the @caf_list@ when it is reverted to the +original CAF, and the dynamic object may not be live afterwards. +Hence, we treat the dynamic object just as normal dynamic objects and +set the desired generation to $0$. + +\subsubsection{(4) Evacuating roots} + +Evacuating roots (other than those in the lists @mut_once_list@ and +@mut_list@) is simply done by invoking @get_roots()@ with @mark_root()@ +as an argument. +Since these roots are normal dynamic objects, we set the desired generation +to $0$. + +\subsubsection{(5) Scavenging} + +The garbage collector scavenges all the objects in the to-space of +each step (by invoking @evacuate()@ on each object reachable from them) +until every sweep pointer has reached its corresponding +allocation pointer. +It repeatedly examines all the to-spaces because not only sweep pointers +but also allocation pointers change during scavenging: +when an object @r@ is scavenged, each object reachable from +@r@ is evacuated to a certain to-space, which increases the corresponding +allocation pointer, and +the sweep pointer of the to-space which currently contains @r@ +increases as well upon finishing scavenging the object @r@. +Thus, the garbage collector cannot anticipate in advance how many times +it needs to scan through all the to-spaces; it keeps scavenging until +no objects are left to be scavenged. + +\subsubsection{Scavenging static objects} + +Since it is possible for dynamic objects to point to static objects, +the garbage collector may invoke @evacuate()@ on static objects +while scavenging dynamic objects in to-spaces. +This complicates the garbage collector because +static objects cannot be evacuated in general yet +they may have pointers to dynamic objects, which must be evacuated. +Thus the garbage collector needs to at least scavenge live static objects +(as opposed to those static objects currently not reachable from roots). + +When a minor garbage collection is performed, any invocation of +@evacuate()@ on static objects is simply ignored. +Furthermore, no static object is considered for scavenging +(except those in the list @mut_once_list@ of the oldest generation during). +Still all dynamic objects which are marked as live due to static objects +are safely evacuated. +The reason is that we can reach all such dynamic objects from +indirection static objects stored in the list +@mut_once_list@ of the oldest generation, which is scavenged during step (2), +and the list @caf_list@. +In other words, in order to evacuate all such dynamic objects, it is +sufficient to evacuate all dynamic objects reachable from +static indirection objects in +the list @mut_once_list@ of the oldest generation and the list @caf_list@. +However, the garbage collector may unnecessarily scavenge certain static +indirection objects which are no longer used. +They are not scavenged during a major garbage collection, however. + +During a major garbage collection, +if an invocation of @evacuate()@ on a static object @r@ is made, +the garbage collector first checks whether @r@ needs to be scavenged or not. +If its SRT (Static Reference Table) is empty and it has no other pointers, +no dynamic objects are reachable from @r@ and it is ignored.\footnote{If +no dynamic objects are reachable from a static object @r@ (even indirectly +via multiple static objects), +@r@ is not stored in \emph{any} SRT table because it would be no use attempting +to follow any pointers in @r@.} +Otherwise, it is put in the list @static_objects@. +At the beginning of each scavenging loop in step (5), +the garbage collector invokes @scavenge_static()@ if the list @static_objects@ +is not empty. +@scavenge_static()@ scavenges the static objects in the list @static_objects@ +by invoking @evacuate()@ on every object reachable from them. +The desired generation is set to the oldest generation (because any +dynamic object directly pointed to by a static object lives +forever). +These static objects are then put in another list @scavenged_static_objects@ +and removed from the list @static_objects@. +For a static indirection object, if the evacuation +fails, it is put back to the list @mut_once_list@ of the oldest generation; +it can be thought of as a CAF just entered. + +After a major garbage collection, therefore, the list @scavenged_static_objects@ +links all live static objects except for static indirection objects put back +to the list @mut_once_list@ of the oldest generation. +Dynamically loaded CAFs are found in the list @caf_list@. + +\subsubsection{(6) Tidying up} + +The garbage collector tidies up the heap by +moving the to-space of each step to the next step. +It also re-initialize the small object pool (which now does not contain +any live objects), frees any large objects which have not been scavenged, +and invokes @resetNurseries()@. +If a major garbage collection has been performed, it +invokes @zero_static_object_list()@ on the list @scavenged_static_objects@ +so that all static objects +(other than those in the list @mut_once_list@ of the oldest generation) +have a null static link field again. + +At this point, both the small allocation pool and the large object pool are +empty. Upon the exit from @GarbageCollect()@, however, they may not +be empty any more because the garbage collector invokes @scheduleFinalizer()@ +before exiting, which tries to run pending finalizers on dead weak pointers and +may create new objects through @allocate()@. +The nursery still remains intact. + +The heap may contain extra objects which are not reachable from the roots +used during the garbage collection: 1) weak head pointers; 2) dead +weak head pointers. Weak head pointers can be tracked from +the list @weak_ptr_list@ (declared in @Weak.c@). However, there is no way +of reaching dead weak pointers; they will be garbage collected during the +next garbage collection. + +For implementation details, see @GC.c@. + +\section{State of the heap allocator and the garbage collector} + +The state of the heap allocator and the garbage collector is fully specified by the +following variables: + +\begin{description} +\item[@small\_alloc\_list@] is the header of the small object pool. +\item[@alloc\_Hp@] points to the first free byte in the small object pool. +\item[@alloc\_HpLim@] points to the boundary of the small object pool. +\item[@generations@] is the array of @generation@ structures. +\item[@RtsFlags.GcFlags.generations@] specifies the number of elements in +the array @generations@. +\item[@caf\_list@] links dynamically loaded CAFs. +\end{description} + +\textbf{To do:} check if this is a complete list. + +The following variables are derivable, but they are given special purposes: + +\begin{description} +\item[@g0s0@] points to step 0 of the youngest generation. +\item[@oldest\_gen@] points to the oldest generation. +\item[@g0s0->blocks@] is the header of the nursery. +\item[@g0s0->large\_blocks@] is the header of the large object pool. +\end{description} + +\section{Miscellaneous notes} + +\begin{itemize} +\item To see how to add new fields to Haskell closures, +see the document on the implementation of retainer profiling +(section `Adding Retainer Set Fields'). + +\item To see how to traverse the graph and visit every live closure, +see the document on the implementation of retainer profiling +(section `Graph Traversal'). + +\item To see how to linearly scan the heap at any random moment during +program execution, see the document on the implementation of LDVU profiling +(section `Heap Censuses'). + +\item To see how to linearly scan the from-space during garbage collections, +see the document on the implementation of LDVU profiling +(section `Destruction of Closures'). + +\end{itemize} + +\end{document} diff --git a/docs/storage-mgt/smallobjectpool.eepic b/docs/storage-mgt/smallobjectpool.eepic new file mode 100644 index 00000000..0ccf61c3 --- /dev/null +++ b/docs/storage-mgt/smallobjectpool.eepic @@ -0,0 +1,65 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(10062,5607)(0,-10) +\path(3375,5262)(4950,5262)(4950,4062) + (3375,4062)(3375,5262) +\path(4125,5112)(4125,5562)(6750,5562)(6750,5262) +\path(6720.000,5382.000)(6750.000,5262.000)(6780.000,5382.000) +\path(6750,5262)(10050,5262)(10050,4062) + (6750,4062)(6750,5262) +\path(6870.000,4692.000)(6750.000,4662.000)(6870.000,4632.000) +\path(6750,4662)(8625,4662) +\path(8505.000,4632.000)(8625.000,4662.000)(8505.000,4692.000) +\path(8625,5262)(8625,4062) +\path(8025,3387)(8625,3387)(8625,4062) +\path(8655.000,3942.000)(8625.000,4062.000)(8595.000,3942.000) +\path(8400,2937)(10050,2937)(10050,4062) +\path(10080.000,3942.000)(10050.000,4062.000)(10020.000,3942.000) +\path(3525,4212)(2925,4212)(2925,2712) +\path(2895.000,2832.000)(2925.000,2712.000)(2955.000,2832.000) +\path(1950,4962)(3375,4962) +\path(3255.000,4932.000)(3375.000,4962.000)(3255.000,4992.000) +\path(2925,2262)(2925,1737)(3300,1737) +\path(3180.000,1707.000)(3300.000,1737.000)(3180.000,1767.000) +\path(3300,1812)(4875,1812)(4875,612) + (3300,612)(3300,1812) +\path(4050,1662)(4050,2112)(6675,2112)(6675,1812) +\path(6645.000,1932.000)(6675.000,1812.000)(6705.000,1932.000) +\path(9750,1812)(9750,612) +\path(6675,1812)(9975,1812)(9975,612) + (6675,612)(6675,1812) +\path(3450,762)(2850,762)(2850,237) +\path(2820.000,357.000)(2850.000,237.000)(2880.000,357.000) +\path(6795.000,1242.000)(6675.000,1212.000)(6795.000,1182.000) +\path(6675,1212)(9750,1212) +\path(9630.000,1182.000)(9750.000,1212.000)(9630.000,1242.000) +\path(3900,1362)(5850,1362)(5850,12) + (9750,12)(9750,612) +\path(9780.000,492.000)(9750.000,612.000)(9720.000,492.000) +\put(3450,5037){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3600,4137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(3450,4437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(7425,5412){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(6900,4812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\put(8850,4812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(8850,4527){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}memory}}}}} +\put(2700,2487){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(0,4887){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}small\_alloc\_list}}}}} +\put(6825,3312){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}alloc\_Hp}}}}} +\put(6600,2862){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}alloc\_HpLim}}}}} +\put(3375,1587){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3525,687){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(3375,987){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(7350,1962){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(7350,1362){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\put(2625,12){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3375,1302){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/smallobjectpool.fig b/docs/storage-mgt/smallobjectpool.fig new file mode 100644 index 00000000..afcfe986 --- /dev/null +++ b/docs/storage-mgt/smallobjectpool.fig @@ -0,0 +1,74 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6225 3900 7800 3900 7800 5100 6225 5100 6225 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 6975 4050 6975 3600 9600 3600 9600 3900 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9600 3900 12900 3900 12900 5100 9600 5100 9600 3900 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9600 4500 11475 4500 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 11475 3900 11475 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 10875 5775 11475 5775 11475 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 11250 6225 12900 6225 12900 5100 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 6375 4950 5775 4950 5775 6450 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4800 4200 6225 4200 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 5775 6900 5775 7425 6150 7425 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6150 7350 7725 7350 7725 8550 6150 8550 6150 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 6900 7500 6900 7050 9525 7050 9525 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12600 7350 12600 8550 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9525 7350 12825 7350 12825 8550 9525 8550 9525 7350 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 6300 8400 5700 8400 5700 8925 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9525 7950 12600 7950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 5 + 0 0 1.00 60.00 120.00 + 6750 7800 8700 7800 8700 9150 12600 9150 12600 8550 +4 0 0 50 0 0 17 0.0000 4 150 435 6300 4125 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6450 5025 link\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6300 4725 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10275 3750 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 9750 4350 used memory\001 +4 0 0 50 0 0 17 0.0000 4 165 390 11700 4350 free\001 +4 0 0 50 0 0 17 0.0000 4 180 825 11700 4635 memory\001 +4 0 0 50 0 0 17 0.0000 4 30 360 5550 6675 ......\001 +4 0 0 50 0 0 17 0.0000 4 195 1575 2850 4275 small_alloc_list\001 +4 0 0 50 0 0 17 0.0000 4 225 900 9675 5850 alloc_Hp\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 9450 6300 alloc_HpLim\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6225 7575 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 8475 link\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6225 8175 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10200 7200 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 10200 7800 used memory\001 +4 0 0 50 0 0 17 0.0000 4 30 360 5475 9150 ......\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6225 7860 free\001 diff --git a/docs/storage-mgt/step.eepic b/docs/storage-mgt/step.eepic new file mode 100644 index 00000000..d5af2b7b --- /dev/null +++ b/docs/storage-mgt/step.eepic @@ -0,0 +1,121 @@ +\setlength{\unitlength}{0.00050000in} +% +\begingroup\makeatletter\ifx\SetFigFont\undefined% +\gdef\SetFigFont#1#2#3#4#5{% + \reset@font\fontsize{#1}{#2pt}% + \fontfamily{#3}\fontseries{#4}\fontshape{#5}% + \selectfont}% +\fi\endgroup% +{\renewcommand{\dashlinestretch}{30} +\begin{picture}(10749,10689)(0,-10) +\path(7437,4362)(10737,4362)(10737,3162) + (7437,3162)(7437,4362) +\path(7557.000,3792.000)(7437.000,3762.000)(7557.000,3732.000) +\path(7437,3762)(10587,3762) +\path(10467.000,3732.000)(10587.000,3762.000)(10467.000,3792.000) +\path(10587,4362)(10587,3162) +\put(8637,4437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\put(8412,3912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single object}}}}} +\path(7437,2262)(10737,2262)(10737,1062) + (7437,1062)(7437,2262) +\path(7557.000,1692.000)(7437.000,1662.000)(7557.000,1632.000) +\path(7437,1662)(10587,1662) +\path(10467.000,1632.000)(10587.000,1662.000)(10467.000,1692.000) +\path(10587,2262)(10587,1062) +\put(8637,2337){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\put(8412,1812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single object}}}}} +\path(3912,2262)(5487,2262)(5487,1062) + (3912,1062)(3912,2262) +\path(4662,2112)(4662,2562)(7437,2562)(7437,2262) +\path(7407.000,2382.000)(7437.000,2262.000)(7467.000,2382.000) +\path(4812,1812)(4812,2562) +\path(5487,2262)(5937,2262)(5937,1062) + (5487,1062)(5487,2262) +\path(5937,2262)(6387,2262)(6387,1062) + (5937,1062)(5937,2262) +\path(6387,2262)(6837,2262)(6837,1062) + (6387,1062)(6387,2262) +\put(3987,2037){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3987,1737){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(4137,1137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(6087,1662){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(3987,1437){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_2$}}}}} +\path(3912,9912)(5487,9912)(5487,8712) + (3912,8712)(3912,9912) +\path(4662,9762)(4662,10212)(7287,10212)(7287,9912) +\path(7257.000,10032.000)(7287.000,9912.000)(7317.000,10032.000) +\path(10362,9912)(10362,8712) +\path(4812,9462)(4812,10212) +\path(7287,9912)(10587,9912)(10587,8712) + (7287,8712)(7287,9912) +\path(4812,9462)(4812,10662)(10362,10662)(10362,9912) +\path(10332.000,10032.000)(10362.000,9912.000)(10392.000,10032.000) +\path(7407.000,9342.000)(7287.000,9312.000)(7407.000,9282.000) +\path(7287,9312)(10362,9312) +\path(10242.000,9282.000)(10362.000,9312.000)(10242.000,9342.000) +\put(3987,9687){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3987,9387){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(4137,8787){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(3987,9087){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(7962,10062){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(7962,9462){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\path(3462,7587)(3462,7062)(3837,7062) +\path(3717.000,7032.000)(3837.000,7062.000)(3717.000,7092.000) +\path(3912,7362)(5487,7362)(5487,6162) + (3912,6162)(3912,7362) +\path(4662,7212)(4662,7662)(7287,7662)(7287,7362) +\path(7257.000,7482.000)(7287.000,7362.000)(7317.000,7482.000) +\path(10362,7362)(10362,6162) +\path(4812,6912)(4812,7662) +\path(7287,7362)(10587,7362)(10587,6162) + (7287,6162)(7287,7362) +\path(4812,6912)(4812,8112)(10362,8112)(10362,7362) +\path(10332.000,7482.000)(10362.000,7362.000)(10392.000,7482.000) +\path(7407.000,6792.000)(7287.000,6762.000)(7407.000,6732.000) +\path(7287,6762)(10362,6762) +\path(10242.000,6732.000)(10362.000,6762.000)(10242.000,6792.000) +\put(3237,7812){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3987,7137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3987,6837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3987,6537){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=1}}}}} +\put(7962,7512){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}single block}}}}} +\put(7962,6912){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}used memory}}}}} +\put(3987,6237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link=NULL}}}}} +\path(4062,8862)(3462,8862)(3462,8112) +\path(3432.000,8232.000)(3462.000,8112.000)(3492.000,8232.000) +\path(3942.000,1182.000)(4062.000,1212.000)(3942.000,1242.000) +\path(4062,1212)(3462,1212)(3462,12)(3912,12) +\path(3792.000,-18.000)(3912.000,12.000)(3792.000,42.000) +\path(3942.000,3282.000)(4062.000,3312.000)(3942.000,3342.000) +\path(4062,3312)(3462,3312)(3462,2112)(3912,2112) +\path(3792.000,2082.000)(3912.000,2112.000)(3792.000,2142.000) +\path(3912,4362)(5487,4362)(5487,3162) + (3912,3162)(3912,4362) +\path(4812,3912)(4812,4662) +\path(5487,4362)(5937,4362)(5937,3162) + (5487,3162)(5487,4362) +\path(5937,4362)(6387,4362)(6387,3162) + (5937,3162)(5937,4362) +\path(6387,4362)(6837,4362)(6837,3162) + (6387,3162)(6387,4362) +\path(4662,4212)(4662,4662)(7437,4662)(7437,4362) +\path(7407.000,4482.000)(7437.000,4362.000)(7467.000,4482.000) +\path(12,6087)(1737,6087)(1737,4887) + (12,4887)(12,6087) +\path(987,5637)(2637,5637)(2637,9612)(3912,9612) +\path(3792.000,9582.000)(3912.000,9612.000)(3792.000,9642.000) +\path(1587,5037)(2637,5037)(2637,4062)(3912,4062) +\path(3792.000,4032.000)(3912.000,4062.000)(3792.000,4092.000) +\put(4137,12){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}......}}}}} +\put(3987,4137){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}start}}}}} +\put(3987,3837){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}free}}}}} +\put(3987,3537){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks=$n_1$}}}}} +\put(4137,3237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}link}}}}} +\put(6087,3762){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}...}}}}} +\put(462,6237){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}step}}}}} +\put(87,5562){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}blocks}}}}} +\put(87,5862){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}no}}}}} +\put(87,5262){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}n\_blocks}}}}} +\put(87,4962){\makebox(0,0)[lb]{\smash{{{\SetFigFont{10}{12.0}{\rmdefault}{\mddefault}{\updefault}large\_object}}}}} +\end{picture} +} diff --git a/docs/storage-mgt/step.fig b/docs/storage-mgt/step.fig new file mode 100644 index 00000000..af9661f2 --- /dev/null +++ b/docs/storage-mgt/step.fig @@ -0,0 +1,154 @@ +#FIG 3.2 +Landscape +Center +Inches +Letter +60.00 +Single +-2 +1200 2 +6 9825 1650 13125 3150 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9825 1950 13125 1950 13125 3150 9825 3150 9825 1950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9825 2550 12975 2550 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12975 1950 12975 3150 +4 0 0 50 0 0 17 0.0000 4 165 630 11025 1875 blocks\001 +4 0 0 50 0 0 17 0.0000 4 225 1230 10800 2400 single object\001 +-6 +6 6300 3750 13125 5250 +6 9825 3750 13125 5250 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9825 4050 13125 4050 13125 5250 9825 5250 9825 4050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9825 4650 12975 4650 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12975 4050 12975 5250 +4 0 0 50 0 0 17 0.0000 4 165 630 11025 3975 blocks\001 +4 0 0 50 0 0 17 0.0000 4 225 1230 10800 4500 single object\001 +-6 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 4050 7875 4050 7875 5250 6300 5250 6300 4050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 4200 7050 3750 9825 3750 9825 4050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 4500 7200 3750 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 4050 8325 4050 8325 5250 7875 5250 7875 4050 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8325 4050 8775 4050 8775 5250 8325 5250 8325 4050 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8775 4050 9225 4050 9225 5250 8775 5250 8775 4050 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 4275 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 4575 free\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 5175 link\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8475 4650 ...\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 4875 blocks=n_2\001 +-6 +6 5625 -4350 12975 150 +6 6300 -4350 12975 -2400 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 -3600 7875 -3600 7875 -2400 6300 -2400 6300 -3600 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 -3450 7050 -3900 9675 -3900 9675 -3600 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12750 -3600 12750 -2400 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 -3150 7200 -3900 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9675 -3600 12975 -3600 12975 -2400 9675 -2400 9675 -3600 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7200 -3150 7200 -4350 12750 -4350 12750 -3600 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9675 -3000 12750 -3000 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 -3375 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 -3075 free\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 -2475 link\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6375 -2775 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10350 -3750 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 10350 -3150 used memory\001 +-6 +6 5625 -1800 12975 150 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 5850 -1275 5850 -750 6225 -750 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 -1050 7875 -1050 7875 150 6300 150 6300 -1050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 -900 7050 -1350 9675 -1350 9675 -1050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 12750 -1050 12750 150 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 -600 7200 -1350 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 9675 -1050 12975 -1050 12975 150 9675 150 9675 -1050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7200 -600 7200 -1800 12750 -1800 12750 -1050 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 9675 -450 12750 -450 +4 0 0 50 0 0 17 0.0000 4 30 360 5625 -1500 ......\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 -825 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 -525 free\001 +4 0 0 50 0 0 17 0.0000 4 165 885 6375 -225 blocks=1\001 +4 0 0 50 0 0 17 0.0000 4 225 1185 10350 -1200 single block\001 +4 0 0 50 0 0 17 0.0000 4 225 1320 10350 -600 used memory\001 +4 0 0 50 0 0 17 0.0000 4 165 1185 6375 75 link=NULL\001 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 3 + 0 0 1.00 60.00 120.00 + 6450 -2550 5850 -2550 5850 -1800 +-6 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6450 5100 5850 5100 5850 6300 6300 6300 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6450 3000 5850 3000 5850 4200 6300 4200 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 6300 1950 7875 1950 7875 3150 6300 3150 6300 1950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 + 7200 2400 7200 1650 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 7875 1950 8325 1950 8325 3150 7875 3150 7875 1950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8325 1950 8775 1950 8775 3150 8325 3150 8325 1950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 8775 1950 9225 1950 9225 3150 8775 3150 8775 1950 +2 1 0 1 0 7 50 0 -1 0.000 0 0 7 1 0 4 + 0 0 1.00 60.00 120.00 + 7050 2100 7050 1650 9825 1650 9825 1950 +2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 + 2400 225 4125 225 4125 1425 2400 1425 2400 225 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 3375 675 5025 675 5025 -3300 6300 -3300 +2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 1 0 4 + 0 0 1.00 60.00 120.00 + 3975 1275 5025 1275 5025 2250 6300 2250 +4 0 0 50 0 0 17 0.0000 4 30 360 6525 6300 ......\001 +4 0 0 50 0 0 17 0.0000 4 150 435 6375 2175 start\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6375 2475 free\001 +4 0 0 50 0 0 17 0.0000 4 195 1125 6375 2775 blocks=n_1\001 +4 0 0 50 0 0 17 0.0000 4 165 390 6525 3075 link\001 +4 0 0 50 0 0 17 0.0000 4 30 180 8475 2550 ...\001 +4 0 0 50 0 0 17 0.0000 4 210 390 2850 75 step\001 +4 0 0 50 0 0 17 0.0000 4 165 630 2475 750 blocks\001 +4 0 0 50 0 0 17 0.0000 4 120 240 2475 450 no\001 +4 0 0 50 0 0 17 0.0000 4 195 870 2475 1050 n_blocks\001 +4 0 0 50 0 0 17 0.0000 4 225 1200 2475 1350 large_object\001 diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml new file mode 100644 index 00000000..b7c8f416 --- /dev/null +++ b/docs/users_guide/7.10.1-notes.xml @@ -0,0 +1,975 @@ + + + Release notes for version 7.10.1 + + + The significant changes to the various parts of the compiler are listed + in the following sections. There have also been numerous bug fixes and + performance improvements over the 7.8 branch. + + + + Highlights + + + The highlights, since the 7.8 branch, are: + + + + + + GHC has implemented "The Applicative Monad Proposal", + meaning the Applicative typeclass + is now a superclass of Monad. This + is a breaking change and your programs will need to be + updated. + Please see the GHC + 7.10 Migration Guide on the GHC wiki. + + + + + GHC has implemented the "Burning Bridges Proposal", + meaning that many of the combinators in + Prelude are now re-exported from + more generic modules (such as + Data.Traversable), rather than exporting + custom, less-generic versions. This is a change that + may require updates to your program. + Please see the GHC + 7.10 Migration Guide on the GHC wiki. + + + + + GHC now has support for 'partial type signatures', + which give you the ability to add 'holes' to a type + signature that the compiler can later infer. For more, + see . + + + + + The integer-gmp package has been + completely rewritten from the ground up. The primary + change in this rewrite is that GHC-compiled programs + that link to GMP no longer 'hook' GMP allocation + routines, to create an Integer on + the raw Haskell heap. Instead, + integer-gmp now allocates all + memory in Haskell code, and talks to GMP via normal + FFI imports like other C code. + + + The practical side effect of this is that C libraries + which bind to GMP (such as MPFR or FLINT) no longer + need careful (or impossible) hacks to be used inside a + GHC-compiled program via the FFI; GMP is treated just + like any other C library, with no special + accomodations. + + + + + GHC now has support for plugins which modify the type + checker. This allows external users to interface with + GHC and write type-checking plugins to solve + constraints and equalities generated by the + typechecker. + + + This feature is experimental and will likely change in + the future. + + + + + GHC now has support for a new extension, + -XStaticPointers, that allows you + to (de)reference and serialize pointers to known, + closed expressions. This is primarily aimed at making + distributed programming (via interfaces like Cloud + Haskell) easier. For more, see . + + + This feature is experimental and will likely change in + the future. + + + + + GHC now has preliminary support for DWARF-based + debugging, when compiling programs with the new + -g option. This will embed DWARF + information into the module object files, which can + then be read by tools like GDB for backtraces or + single-stepping. + + + This feature is highly + experimental and will likely change in the future, but + should still be useful today. + + + + + + + Full details + + Language + + + + Implicit parameters of the new base type + GHC.Stack.CallStack are treated + specially, and automatically solved for the current source + location. For example + + f = print (?stk :: CallStack) + + will print the singleton stack containing the occurrence of + ?stk. If there is another + CallStack implicit in-scope, the new location + will be appended to the existing stack, e.g. + + f :: (?stk :: CallStack) => IO () + f = print (?stk :: CallStack) + + will print the occurrence of ?stk and the + call-site of f. The name of the implicit + parameter does not matter. + + + See the release notes for base for a description of the + CallStack type. + + + + + There is a new extension, + StaticPointers, + which allows you to create pointers to expressions which + remain valid across processes. This is useful for + referencing higher-order values in distributed + systems. The pointers are created with a new keyword + static as in + x = static ("abc" ++ "123") :: StaticPtr String. + All processes which dereference x get the + same result, that is, the body of the static form. + + + + + Added support for binary integer literals + + + + + Simplified rules for implicit quantification. In previous versions of GHC, + it was possible to use the => arrow + to quantify over type variables in data and + type declarations without a + forall quantifier. For example, + data Fun = Fun (Ord a => a -> b) was identical to + data Fun = Fun (forall a b. Ord a => a -> b), while + data Fun = Fun (a -> b) caused a not-in-scope error. + This implicit quantification is now deprecated, and variables + in higher-rank constructors should be quantified with forall + regardless of whether a class context is present or not. + GHC 7.10 raises a warning (controlled by + , enabled by default) + and GHC 7.12 will raise an error. See examples + in GHC documentation. + + + The change also applies to Template Haskell splices such as + [t|Ord a => a|], which should be written as + [t|forall a. Ord a => a|]. + + + + + + Instance contexts inferred while processing deriving + directives attached to data and newtype + declarations now forbid equality constraints. This is a regression in + obscure cases, but it will yield better error messages in more common + cases. Users caught by the regression can simply use standalone-deriving, + where you specify the context yourself. + + + + + + + Compiler + + + + GHC now checks that all the language extensions required for + the inferred type signatures are explicitly enabled. This + means that if any of the type signatures inferred in your + program requires some language extension you will need to + enable it. The motivation is that adding a missing type + signature inferred by GHC should yield a program that + typechecks. Previously this was not the case. + + + This is a breaking change. Code that used to compile in the + past might fail with an error message requiring some + particular language extension (most likely + , or + ). + + + + + The solvers for both type family reductions and + Coercible instances have been improved. + This should lead to faster compilation of type-family-heavy + code and more Coercible instances to be + found. However, some bugs remain: see 'Known Bugs' below. + + + + + warning flag is turned on by + default with this release of GHC. It can be suppressed + either by using GHC_OPTIONS pragma or by + specifying flag. + + + + + The new flag turns + typed hole errors into typed hole warnings that produce + runtime errors when evaluated. + + The flag was + repurposed to silence the warnings produced when + is used. As a result, + it is no longer possible to disable typed holes like it was + in GHC 7.8. This only turned a self-explanatory error into + a cryptic parse error and was thus not very useful. + + For more details, consult and + . + + + + + A new warning flag, + has been added and is turned on with + . It warns when a module that is + compiled with is actually + infered as an module. This lets the + module author know that they can tighten their Safe Haskell + bounds if desired. + + + + + The and + that warn if a module was + infered as Safe or Unsafe have been improved to work with + all Safe Haskell module types. Previously, they only worked + for unmarked modules where the compiler was infering the + modules Safe Haskell type. They now work even for modules + marked as or + . This is useful either to have + GHC check your assumptions, or to generate a list of + reasons easily why a module is regarded as Unsafe. + + + For many use cases, the new + flag is better + suited than either of these two. + + + + + and + flags have been removed. + + + + + Many more options have learned to respect the . + For example you can use with + to produce a + for each file that uses Template Haskell. + This should be much easier to understand on a larger project + than having everything being dumped to stdout. + + + + + Compiler plugins (with the + flag) may now modify the behaviour of the constraint + solver, to add new functionality to GHC's + typechecker. See + for more details. + + + + + A new warning flag, + has been added. The behavior is similar to + but GHC will only + flag exported values. This flag takes precedence over + so it can be used + in conjunction with . + + + + + A new warning flag, + has been added. This flag causes GHC to warn when you use a promoted constructor without using a "tick" preceding its name. + + For example: + + +data Nat = Succ Nat | Zero + +data Vec n s where + Nil :: Vec Zero a + Cons :: a -> Vec n a -> Vec (Succ n) a + + Will raise two warnings because Zero + and Succ are not written as 'Zero and + 'Succ. + + This warning is enabled by default in -Wall mode. + + + + Added the option . + + This dumps out a .th.hs file of all Template Haskell + declarations in a corresponding .hs file. The idea is + that application developers can check this into their + repository so that they can grep for identifiers used + elsewhere that were defined in Template Haskell. This + is similar to using + with but it always + generates a file instead of being coupled to + and only outputs code + that does not exist in the .hs file and a comment for + the splice location in the original fi + + + + + + + GHCi + + + + It's now possible to use :set + -l{foo} in GHCi to link against a + foreign library after startup. + + + + + Pattern synonyms are now supported in GHCi. + + + + + + + Template Haskell + + + + Added support for generating LINE pragma declarations + (). + + + + + + The type Pred (which stores a type + constraint) is now a synonym for Type, + in order to work with the ConstraintKinds + extension. This is a breaking change and may require + some rewriting of Template Haskell code. + + + + + + Pattern splices now work. + + + + + + reifyInstances now treats unbound type + variables as univerally quantified, allowing lookup of, say, + the instance for Eq [a]. + + + + + + More kind annotations appear in reified types, in order to + disambiguate types that would otherwise be ambiguous in the + presence of PolyKinds. In particular, all + reified TyVarBndrs are now + KindedTVs. (This does not affect Template + Haskell quotations, just calls to reify.) + + + + + + Various features unsupported in quotations were previously + silently ignored. These now cause errors. + + + + + + Lift instances were added for + many more types: all of the IntXX + and WordXX types, Ratio a, + (), Float, and + Double. + + + + + + All Template Haskell datatypes now have + Generic and Ord instances. + + + + + + Ppr instances were added for Lit + and Loc. + + + + + + Two new declaration forms are now supported: + standalone-deriving declarations and generic method + signatures (written using default in + a class). This means an expansion to the Dec + type. + + + + + + Template Haskell is now more pedantic about splicing in + bogus variable names, like those containing whitespace. If you + use bogus names in your Template Haskell code, this may break + your program. + + + + + + + Runtime system + + + + The linker API is now thread-safe. The main + user-facing impact of this change is that you must + now call initLinker before + calling loadObj or any of the + other linker APIs. + + + + + + + Build system + + + + ghc-pkg now respects + and when modifying packages (e.g. + changing exposed/trust flag or unregistering). Previously, + ghc-pkg would ignore these flags and modify + whichever package it found first on the database stack. To + recover the old behavior, simply omit these flags. + + + + + ghc-pkg accepts a + flag which allows a user to override the location of the user package + database. Unlike databases specified using , + a user package database configured this way respects + the flag. + + + + + + + Package system + + + + ghc-pkg (and ghc) have dropped support for single-file style + package databases. Since version 6.12, ghc-pkg has defaulted + to a new database format (using a directory of files, one per + package plus a binary cache). + + + This change will not affect programs and scripts that use + ghc-pkg init to create package databases. + + + This will affect scripts that create package databases + using tricks like + +echo "[]" > package.conf + + Such scripts will need to be modified to use + ghc-pkg init, and to delete databases + by directory removal, rather than simple file delete. + + + + + + + + Libraries + + + array + + + + Version number 0.5.1.0 (was 0.5.0.0) + + + + + + + base + + + + Version number 4.8.0.0 (was 4.7.0.0) + + + + + A new module GHC.SrcLoc was added, + exporting a new type SrcLoc. A + SrcLoc contains package, module, + and file names, as well as start and end positions. + + + + + A new type CallStack was added for use + with the new implicit callstack parameters. A + CallStack is a + [(String, SrcLoc)], sorted by most-recent + call. + + + + + GHC has had its internal Unicode database for + parsing updated to the Unicode 7.0 standard. + + + + + Attempting to access a portion of the result of + System.IO.hGetContents that was not yet + read when the handle was closed now throws an exception. + Previously, a lazy read from a closed handle would simply + end the result string, leading to silent or delayed + failures. + + + + + + + bin-package-db + + + + This is an internal package, and should not be used. + + + + + + + binary + + + + Version number 0.7.3.0 (was 0.7.1.0) + + + + + + + bytestring + + + + Version number 0.10.6.0 (was 0.10.4.0) + + + + + + + Cabal + + + + Version number 1.22.1.0 (was 1.18.1.3) + + + + + + + containers + + + + Version number 0.5.6.2 (was 0.5.4.0) + + + + + + + deepseq + + + + Version number 1.4.1.1 (was 1.3.0.2) + + + + + + + directory + + + + Version number 1.2.2.0 (was 1.2.0.2) + + + + + + + filepath + + + + Version number 1.4.0.0 (was 1.3.0.2) + + + + + + + ghc + + + + Many internal functions in GHC related to package IDs have been + renamed to refer to package keys, e.g. PackageId + is now PackageKey, the wired-in names + such as primPackageId are now + primPackageKey, etc. This reflects a distinction + that we are now making: a package ID is, as before, the user-visible + ID from Cabal foo-1.0; a package key is now + a compiler-internal entity used for generating linking symbols, and + may not correspond at all to the package ID. In + particular, there may be multiple package keys per + package ID. + + + + + The ghc library no longer depends on the Cabal library. This means + that users of the ghc library are no longer forced to use the same + version of Cabal as ghc did. It also means that Cabal is freed up + to be able to depend on packages that ghc does not want to depend + on (which for example may enable improvements to Cabal's parsing + infrastructure). + + + + + + + ghc-prim + + + + Version number 0.4.0.0 (was 0.3.1.0) + + + + + The low-level prefetch API exported by + GHC.Prim (added in GHC 7.8) has + been overhauled to use State# + parameters to serialize and thread state around. + + + This API is still considered experimental, and + will be prone to change. + + + + + + + haskeline + + + + Version number 0.7.2.1 (was 0.7.1.2) + + + + + + + hoopl + + + + Version number 3.10.0.2 (was 3.10.0.0) + + + + + + + hpc + + + + Version number 0.6.0.2 (was 0.6.0.1) + + + + + The hpc command supports a new + flag, --verbosity=n, which + controls the verbosity level of subcommands. + + + + + + + integer-gmp + + + + Version number 1.0.0.0 (was 0.5.1.0) + + + + + The integer-gmp package has + been completely rewritten to be more efficient and + interoperate more sanely with the GMP + library. Specifically, GHC no longer needs to + 'hook' the GMP memory allocators to make + allocations exist on the Haskell heap, a + complication which makes GMP-dependent C libraries + difficult. This means external libraries that use + GMP (such as MPFR or FLINT) can now be trivially + FFI'd to without any complication. + + + + + + + pretty + + + + Version number 1.1.2.0 (was 1.1.1.1) + + + + + + + process + + + + Version number 1.2.3.0 (was 1.2.0.0) + + + + + + + template-haskell + + + + Version number 2.10.0.0 (was 2.9.0.0) + + + + + + + terminfo + + + + Version number 0.4.0.1 (was 0.4.0.0) + + + + + + + time + + + + Version number 1.5.0.1 (was 1.4.2) + + + + + + + transformers + + + + Version number 0.4.2.0 (was 0.3.0.0) + + + + + + + unix + + + + Version number 2.7.1.0 (was 2.7.0.0) + + + + + + + Win32 + + + + Version number 2.3.1.0 (was 2.3.0.1) + + + + + + + xhtml + + + + Version number remained at 3000.2.1 + + + + + + + + Known bugs + + + + For issues dealing with language changes, please see + the GHC + 7.10 Migration Guide on the GHC wiki. + + + + + GHC's LLVM backend does not support LLVM 3.4 (issue #9929) + + + + + On Mac OS X, the -threaded Garbage + Collector currently suffers from a large performance + penalty due to a lack of system-specific optimization + (issue #7602). + + + + + GHC's LLVM backend is currently incompatible with LLVM + 3.4 (issue #9929). + + + + + GHCi fails to appropriately load + .dyn_o files (issue #8736). + + + + + Not all cases of non-terminating type-level computation (with both + recursive type families and recursive newtypes) are caught. This + means that GHC might hang, but it should do so only when the program + is ill-typed (due to non-terminating type-level features). The bugs + are reported as #7788 + and #10139. + There also remain certain obscure scenarios where the solver for + Coercible instances is known to be still + incomplete. See comments in #10079. + + + + + diff --git a/docs/users_guide/7.10.2-notes.xml b/docs/users_guide/7.10.2-notes.xml new file mode 100644 index 00000000..27d0ad65 --- /dev/null +++ b/docs/users_guide/7.10.2-notes.xml @@ -0,0 +1,340 @@ + + + Release notes for version 7.10.2 + + + The 7.10.2 release is a bugfix release, with over 70+ bug fixes + relative to 7.10.1. The major fixes are listed below. For the full + list with more detail, see the GHC 7.10.2 + milestone on our bug tracker. + + + + GHC + + + + + The source location of a function's caller can now be made + available to the callee as an implicit parameter. This will + enable better location information in runtime errors (e.g. from + error and partial functions like + head). For more details see + . + + + + + A bug in the typechecker which could result in strange, + inconsistent reduction of type families has been fixed + (issue #10488). + + + + + A variety of fixes of the new API annotations support. + + + + + A bug which caused GHC to generate bad DWARF unwinding + information has been fixed (issue #10236). + + + + + DWARF support should now work on Windows/MinGW (#10468). + + + + + A bug which caused GHC's libffi.so + library to be built with executable stacks on some + platforms has been fixed (issue #10208). + + + + + A bus error on SPARC machines caused by misaligned data + accesses in the RTS has been fixed. + + + + + A bug which caused the simplifier to produce code which + segfaulted at runtime has been fixed (issue #10538). + + + + + A type-system bug which could allow a user to write + unsafeCoerce has been fixed (issue + #9858). + + + + + A bug which caused GHC to generate incorrect hyperlinks to + documentation in Haddock has been fixed (#10206). + + + + + A bug in the typechecker which allowed erroneous programs + using Coercible to typecheck has been + fixed (issue #10285). + + + + + An issue which could cause the "Call Arity" analysis to + perform poorly in general has been fixed (issue #10293). + + + + + Several dozen bugs in the new API annotations work have + been fixed (issues #10395, #10363, #10358, #10357, #10315, + #10314, #10312, and many more). + + + + + A regression which could cause the typechecker fail to + properly simplify type-level terms has been fixed (issue + #10321). + + + + + A bug which caused programs compiled with + -flate-dmd-anal to crash at runtime has + been fixed (issue #10288). + + + + + A bug which caused ARM/Linux binaries to be built with + executable stacks has been fixed (issue #10369). + + + + + Several bugs in GHC's cross compilation support using LLVM + have been fixed (#10275). + + + + + Several bugs in GHC's support for AArch64 have been fixed + (such as issue #10264). + + + + + The SMP runtime and GHCi are now enabled on AArch64 (issue #10525). + + + + + A bug in the code which caused GHC to emit invalid C code + when porting to a new platform has been fixed (issue + #10518). + + + + + A bug which could cause GHC to generate incorrect code at + runtime (generating an infinite loop exception) has been + fixed (issue #10218). + + + + + Several performance-related issues inside GHC have been + fixed. As a result, you should see improved compilation + times and memory usage (issues #10397, #10370, #10422). + + + + + A bug which could cause GHCi to crash if exceptions were + raised in the :cmd command has been + fixed. + + + + + A bug in the event manager which could cause 'multi-shot' + event registrations to only fire once has been fixed + (issue #10317). + + + + + Support for PowerPC relocations has been added (issue + #10402). + + + + + A lurking bug in the code generator which could cause + incorrect assembly code to be generated due to register + aliasing issues has been fixed (issue #10521). + + + + + A bug in the runtime system which could cause a deadlock + when scheduling garbage collections has been fixed (issue + #10545). + + + + + A bug which could cause compiled programs to loop forever + when glibc's iconv implementation (gconv) wasn't available + has been fixed, so these programs will now terminate with + an error. As a result of this change, however, GHC + compiled programs now also specifically recognize ASCII + encodings, and can function without iconv in these cases. This + allows statically compiled programs to exist inside an + initramfs, for example (issues #10298, #7695). + + + + + + + Libraries + + + base + + + + Version number 4.8.1.0 (was 4.8.0.0) + + + + + The Lifetime datatype (and its + constructors) are now exported from + GHC.Event. + + + + + + + binary + + + + Version number 0.7.5.0 (was 0.7.3.0) + + + + + + + Cabal + + + + Version number 1.22.4.0 (was 1.22.2.0). + + + + + + + ghc + + + + Several new constructors have been added to the + AnnKeywordId datatype, in order + to fix several problem with GHC's new support for + API annotations (this should not regress or effect + any clients of the GHC API not using these new + features). + + + + + The source location functionality above required an breaking change + to the GHC API. Namely, the SrcSpans of + CtLoc and TcLclEnv are now + RealSrcSpans. While usually API changes like this + are avoided in bugfix releases, it was decided that the benefits + offered by the source location functionality outweighed the cost of + a small change to this rarely-used interface. + + + + + + + + Known bugs + + + + For issues dealing with language changes, please see + the GHC + 7.10 Migration Guide on the GHC wiki. + + + + + A bug in the simplifier which can cause it to totally + fail to compile certain programs that get 'very large' + at compile time is known (issue + #10527). + + + + + GHC's LLVM backend does not support LLVM 3.4 (issue #9929). + + + + + On Mac OS X, the -threaded Garbage + Collector currently suffers from a large performance + penalty due to a lack of system-specific optimization + (issue #7602). + + + + + GHCi fails to appropriately load + .dyn_o files (issue #8736). + + + + + Not all cases of non-terminating type-level computation (with both + recursive type families and recursive newtypes) are caught. This + means that GHC might hang, but it should do so only when the program + is ill-typed (due to non-terminating type-level features). The bugs + are reported as #7788 + and #10139. + There also remain certain obscure scenarios where the solver for + Coercible instances is known to be still + incomplete. See comments in #10079. + + + + + diff --git a/docs/users_guide/7.10.3-notes.xml b/docs/users_guide/7.10.3-notes.xml new file mode 100644 index 00000000..120299a9 --- /dev/null +++ b/docs/users_guide/7.10.3-notes.xml @@ -0,0 +1,176 @@ + + + Release notes for version 7.10.3 + + + The 7.10.3 release is a bugfix release, with over fifty bug fixes + relative to 7.10.2. The major fixes are listed below. For the full + list with more detail, see the GHC 7.10.3 + milestone on our bug tracker. + + + + GHC + + + + The simplifier no longer simplifies rewrite rules. + + Starting with 7.10.2 GHC would simplify both the left- and + right-hand-sides of rewrite rules, causing a variety of unexpected behavior. + Simplification of the LHS resulted in various rules to fail to fire (Trac #10528, in + particular affecting the widely used text library) + whereas rewrites of the RHS broke some of the more exotic uses of rewrite rules + (e.g. HERMIT, Trac + #10829). + + + + + + A bug in the simplifier's treatment of phantom type variables in rules + resulting in a compiler-crash has been fixed. (Trac #10689). + + + + + + A simplifier bug resulting in incorrect results when comparing against + -0.0 has been fixed (Trac #9238). + + + + + + The compiler is now better able to work around platform limits on + command-line length on Windows thanks to support for response files + (Trac + #10375) and an upgrade to the GCC toolchain (Trac + #10726) + + + + + + The linker is now far less verbose when faced with certain warning conditions on Windows. + (Trac + #9297). + + + + + + Framework flags are now included in the linker command line on Mac OS X + (Trac + #10568). + + + + + + Compiler error messages containing Unicode characters no longer crash + the compiler on platforms without Unicode support. + (Trac + #6037). + + + + + + ARM support should be substantially more reliable as the compiler now + takes precautions to avoid linking against Thumb code (Trac #10375). + Unfortunately the fix involved breaking some configurations. See the + entry in the "Known Bugs" section below. + + + + + + A bug in the typechecker's treatment of + PartialTypeSignatures which previously resulted in + a compile-time crash has been fixed. (Trac #10438). + + + + + A typechecker bug leading to the compiler crashing has been resolved + (Trac + #10489). + + + + + + Due to a + security issue + , Safe Haskell now forbids annotations in programs marked as + -XSafe + + + + + + The template Haskell getQ and + putQ functions are fixed (having been broken since GHC + 7.10.1, (Trac + #10596). + + + + + + + + Libraries + + + base + + + + Version number 4.8.2.0 (was 4.8.1.0) + + + + + The GiveGCStats, + DoCostCentres, DoHeapProfile, + DoTrace, Time, and Nat + datatypes are now exported from + GHC.RTS.Flags. + + + + + + + + Known bugs + + + + At the time of release there is a fix + in the Cabal upstream respository, although it is not yet + present in a release. + + + + + Unfortunately the fix for + Trac #10375 + required that support for the ARM Thumb instruction set be disabled. + See Trac + #11058 for details. + + + + + diff --git a/docs/users_guide/Makefile b/docs/users_guide/Makefile new file mode 100644 index 00000000..603a6706 --- /dev/null +++ b/docs/users_guide/Makefile @@ -0,0 +1,3 @@ +dir = docs/users_guide +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk diff --git a/docs/users_guide/bugs.xml b/docs/users_guide/bugs.xml new file mode 100644 index 00000000..858291ff --- /dev/null +++ b/docs/users_guide/bugs.xml @@ -0,0 +1,620 @@ + + + Known bugs and infelicities + + + Haskell standards vs. Glasgow Haskell: language non-compliance + + + GHC vs the Haskell standards + Haskell standards vs GHC + + + This section lists Glasgow Haskell infelicities in its + implementation of Haskell 98 and Haskell 2010. + See also the “when things go wrong” section + () for information about crashes, + space leaks, and other undesirable phenomena. + + + + The limitations here are listed in Haskell Report order + (roughly). + + + + Divergence from Haskell 98 and Haskell 2010 + + + By default, GHC mainly aims to behave (mostly) like a Haskell 2010 + compiler, although you can tell it to try to behave like a + particular version of the language with the + -XHaskell98 and + -XHaskell2010 flags. The known deviations + from the standards are described below. Unless otherwise stated, + the deviation applies in Haskell 98, Haskell 2010 and + the default modes. + + + + Lexical syntax + + + + Certain lexical rules regarding qualified identifiers + are slightly different in GHC compared to the Haskell + report. When you have + module.reservedop, + such as M.\, GHC will interpret it as a + single qualified operator rather than the two lexemes + M and .\. + + + + + + Context-free syntax + + + + In Haskell 98 mode and by default (but not in + Haskell 2010 mode), GHC is a little less strict about the + layout rule when used + in do expressions. Specifically, the + restriction that "a nested context must be indented further to + the right than the enclosing context" is relaxed to allow the + nested context to be at the same level as the enclosing context, + if the enclosing context is a do + expression. + + For example, the following code is accepted by GHC: + + +main = do args <- getArgs + if null args then return [] else do + ps <- mapM process args + mapM print ps + + This behaviour is controlled by the + NondecreasingIndentation extension. + + + + + GHC doesn't do the fixity resolution in expressions during + parsing as required by Haskell 98 (but not by Haskell 2010). + For example, according to the Haskell 98 report, the + following expression is legal: + + let x = 42 in x == 42 == True + and parses as: + + (let x = 42 in x == 42) == True + + because according to the report, the let + expression extends as far to the right as + possible. Since it can't extend past the second + equals sign without causing a parse error + (== is non-fix), the + let-expression must terminate there. GHC + simply gobbles up the whole expression, parsing like this: + + (let x = 42 in x == 42 == True) + + + + The Haskell Report allows you to put a unary + - preceding certain expressions headed by + keywords, allowing constructs like - case x of + ... or - do { ... }. GHC does + not allow this. Instead, unary - is + allowed before only expressions that could potentially + be applied as a function. + + + + + + + + Expressions and patterns + + In its default mode, GHC makes some programs slightly more defined + than they should be. For example, consider + +f :: [a] -> b -> b +f [] = error "urk" +f (x:xs) = \v -> v + +main = print (f [] `seq` True) + +This should call error but actually prints True. +Reason: GHC eta-expands f to + +f :: [a] -> b -> b +f [] v = error "urk" +f (x:xs) v = v + +This improves efficiency slightly but significantly for most programs, and +is bad for only a few. To suppress this bogus "optimisation" use . + + + + + + Declarations and bindings + + In its default mode, GHC does not accept datatype contexts, + as it has been decided to remove them from the next version of the + language standard. This behaviour can be controlled with the + extension. + See . + + + + Module system and interface files + + GHC requires the use of hs-boot + files to cut the recursive loops among mutually recursive modules + as described in . This more of an infelicity + than a bug: the Haskell Report says + (Section 5.7) "Depending on the Haskell + implementation used, separate compilation of mutually + recursive modules may require that imported modules contain + additional information so that they may be referenced before + they are compiled. Explicit type signatures for all exported + values may be necessary to deal with mutual recursion. The + precise details of separate compilation are not defined by + this Report." + + + + + + + Numbers, basic types, and built-in classes + + + + Num superclasses + + + The Num class does not have + Show or Eq + superclasses. + + + + You can make code that works with both + Haskell98/Haskell2010 and GHC by: + + + + Whenever you make a Num instance + of a type, also make Show and + Eq instances, and + + + + + Whenever you give a function, instance or class a + Num t constraint, also give it + Show t and + Eq t constraints. + + + + + + + + + Bits superclasses + + + The Bits class does not have + a Num superclasses. It therefore + does not have default methods for the + bit, + testBit and + popCount methods. + + + + You can make code that works with both + Haskell2010 and GHC by: + + + + Whenever you make a Bits instance + of a type, also make a Num + instance, and + + + + + Whenever you give a function, instance or class a + Bits t constraint, also give it + a Num t constraint, and + + + + + Always define the bit, + testBit and + popCount methods in + Bits instances. + + + + + + + + + Extra instances + + + The following extra instances are defined: + + +instance Functor ((->) r) +instance Monad ((->) r) +instance Functor ((,) a) +instance Functor (Either a) +instance Monad (Either e) + + + + + + Multiply-defined array elements—not checked: + + This code fragment should + elicit a fatal error, but it does not: + + +main = print (array (1,1) [(1,2), (1,3)]) +GHC's implementation of array takes the value of an +array slot from the last (index,value) pair in the list, and does no +checking for duplicates. The reason for this is efficiency, pure and simple. + + + + + + + + + In <literal>Prelude</literal> support + + + + Arbitrary-sized tuples + + Tuples are currently limited to size 100. HOWEVER: + standard instances for tuples (Eq, + Ord, Bounded, + Ix Read, and + Show) are available + only up to 16-tuples. + + This limitation is easily subvertible, so please ask + if you get stuck on it. + + + + splitAt semantics + Data.List.splitAt is stricter than specified in the + Report. Specifically, the Report specifies that +splitAt n xs = (take n xs, drop n xs) + which implies that +splitAt undefined undefined = (undefined, undefined) + but GHC's implementation is strict in its first argument, so +splitAt undefined [] = undefined + + + + Reading integers + + GHC's implementation of the + Read class for integral types accepts + hexadecimal and octal literals (the code in the Haskell + 98 report doesn't). So, for example, +read "0xf00" :: Int + works in GHC. + A possible reason for this is that readLitChar accepts hex and + octal escapes, so it seems inconsistent not to do so for integers too. + + + + + isAlpha + + The Haskell 98 definition of isAlpha + is: + +isAlpha c = isUpper c || isLower c + + GHC's implementation diverges from the Haskell 98 + definition in the sense that Unicode alphabetic characters which + are neither upper nor lower case will still be identified as + alphabetic by isAlpha. + + + + + hGetContents + + + Lazy I/O throws an exception if an error is + encountered, in contrast to the Haskell 98 spec which + requires that errors are discarded (see Section 21.2.2 + of the Haskell 98 report). The exception thrown is + the usual IO exception that would be thrown if the + failing IO operation was performed in the IO monad, and can + be caught by System.IO.Error.catch + or Control.Exception.catch. + + + + + + + + The Foreign Function Interface + + + hs_init() not allowed + after hs_exit() + + The FFI spec requires the implementation to support + re-initialising itself after being shut down + with hs_exit(), but GHC does not + currently support that. + + + + + + + + + GHC's interpretation of undefined behaviour in + Haskell 98 and Haskell 2010 + + This section documents GHC's take on various issues that are + left undefined or implementation specific in Haskell 98. + + + + + The Char type + Charsize of + + + Following the ISO-10646 standard, + maxBound :: Char in GHC is + 0x10FFFF. + + + + + + Sized integral types + Intsize of + + + In GHC the Int type follows the + size of an address on the host architecture; in other words + it holds 32 bits on a 32-bit machine, and 64-bits on a + 64-bit machine. + + Arithmetic on Int is unchecked for + overflowoverflowInt + , so all operations on Int happen + modulo + 2n + where n is the size in bits of + the Int type. + + The fromIntegerfromInteger + function (and hence + also fromIntegralfromIntegral + ) is a special case when + converting to Int. The value of + fromIntegral x :: Int is given by taking + the lower n bits of (abs + x), multiplied by the sign of x + (in 2's complement n-bit + arithmetic). This behaviour was chosen so that for example + writing 0xffffffff :: Int preserves the + bit-pattern in the resulting Int. + + + Negative literals, such as -3, are + specified by (a careful reading of) the Haskell Report as + meaning Prelude.negate (Prelude.fromInteger 3). + So -2147483648 means negate (fromInteger 2147483648). + Since fromInteger takes the lower 32 bits of the representation, + fromInteger (2147483648::Integer), computed at type Int is + -2147483648::Int. The negate operation then + overflows, but it is unchecked, so negate (-2147483648::Int) is just + -2147483648. In short, one can write minBound::Int as + a literal with the expected meaning (but that is not in general guaranteed). + + + The fromIntegral function also + preserves bit-patterns when converting between the sized + integral types (Int8, + Int16, Int32, + Int64 and the unsigned + Word variants), see the modules + Data.Int and Data.Word + in the library documentation. + + + + + Unchecked float arithmetic + + Operations on Float and + Double numbers are + unchecked for overflow, underflow, and + other sad occurrences. (note, however, that some + architectures trap floating-point overflow and + loss-of-precision and report a floating-point exception, + probably terminating the + program)floating-point + exceptions. + + + + + + + + + + Known bugs or infelicities + + The bug tracker lists bugs that have been reported in GHC but not + yet fixed: see the GHC Trac. In addition to those, GHC also has the following known bugs + or infelicities. These bugs are more permanent; it is unlikely that + any of them will be fixed in the short term. + + + Bugs in GHC + + + + GHC can warn about non-exhaustive or overlapping + patterns (see ), and usually + does so correctly. But not always. It gets confused by + string patterns, and by guards, and can then emit bogus + warnings. The entire overlap-check code needs an overhaul + really. + + + + GHC does not allow you to have a data type with a context + that mentions type variables that are not data type parameters. + For example: + + data C a b => T a = MkT a + + so that MkT's type is + + MkT :: forall a b. C a b => a -> T a + + In principle, with a suitable class declaration with a functional dependency, + it's possible that this type is not ambiguous; but GHC nevertheless rejects + it. The type variables mentioned in the context of the data type declaration must + be among the type parameters of the data type. + + + + GHC's inliner can be persuaded into non-termination + using the standard way to encode recursion via a data type: + + data U = MkU (U -> Bool) + + russel :: U -> Bool + russel u@(MkU p) = not $ p u + + x :: Bool + x = russel (MkU russel) + + + We have never found another class of programs, other + than this contrived one, that makes GHC diverge, and fixing + the problem would impose an extra overhead on every + compilation. So the bug remains un-fixed. There is more + background in + Secrets of the GHC inliner. + + + + On 32-bit x86 platforms when using the native code + generator, the + option + is always on. This means that floating-point calculations are + non-deterministic, because depending on how the program is + compiled (optimisation settings, for example), certain + calculations might be done at 80-bit precision instead of the + intended 32-bit or 64-bit precision. Floating-point results + may differ when optimisation is turned on. In the worst case, + referential transparency is violated, because for example + let x = E1 in E2 can evaluate to a + different value than E2[E1/x]. + + + One workaround is to use the + + option (see , which + generates code to use the SSE2 instruction set instead of + the x87 instruction set. SSE2 code uses the correct + precision for all floating-point operations, and so gives + deterministic results. However, note that this only works + with processors that support SSE2 (Intel Pentium 4 or AMD + Athlon 64 and later), which is why the option is not enabled + by default. The libraries that come with GHC are probably + built without this option, unless you built GHC yourself. + + + + + There is known to be maleficent interactions between weak + references and laziness. Particularly, it has been observed that placing a thunk + containing a reference to a weak reference inside of another weak reference may + cause runtime crashes. See Trac #11108 + for details. + + + + + + Bugs in GHCi (the interactive GHC) + + + GHCi does not respect the default + declaration in the module whose scope you are in. Instead, + for expressions typed at the command line, you always get the + default default-type behaviour; that is, + default(Int,Double). + + It would be better for GHCi to record what the default + settings in each module are, and use those of the 'current' + module (whatever that is). + + + + On Windows, there's a GNU ld/BFD bug + whereby it emits bogus PE object files that have more than + 0xffff relocations. When GHCi tries to load a package affected by this + bug, you get an error message of the form + +Loading package javavm ... linking ... WARNING: Overflown relocation field (# relocs found: 30765) + + The last time we looked, this bug still + wasn't fixed in the BFD codebase, and there wasn't any + noticeable interest in fixing it when we reported the bug + back in 2001 or so. + + The workaround is to split up the .o files that make up + your package into two or more .o's, along the lines of + how the "base" package does it. + + + + + + + + diff --git a/docs/users_guide/codegens.xml b/docs/users_guide/codegens.xml new file mode 100644 index 00000000..b54d7bee --- /dev/null +++ b/docs/users_guide/codegens.xml @@ -0,0 +1,125 @@ + + + GHC Backends + ghc backends + ghc code generators + + GHC supports multiple backend code generators. This is the part + of the compiler responsible for taking the last intermediate + representation that GHC uses (a form called Cmm that is a simple, C like + language) and compiling it to executable code. The backends that GHC + support are described below. + + + + Native code Generator (<option>-fasm</option>) + native code generator + + The default backend for GHC. It is a native code generator, compiling Cmm + all the way to assembly code. It is the fastest backend and generally + produces good performance code. It has the best support for compiling + shared libraries. Select it with the flag. + + + + LLVM Code Generator (<option>-fllvm</option>) + LLVM code generator + + This is an alternative backend that uses the + LLVM compiler to produce + executable code. It generally produces code as with performance as + good as the native code generator but for some cases can produce + much faster code. This is especially true for numeric, array heavy + code using packages like vector. The penalty is a significant increase in + compilation times. Select the LLVM backend with the + flag. Currently only LLVM 3.5 + is supported. + + + You must install and have LLVM available on your PATH for the LLVM + code generator to work. Specifically GHC needs to be able to call the + opt and llc tools. Secondly, if you + are running Mac OS X with LLVM 3.5 or greater then + you also need the Clang c + compiler compiler available on your PATH. + + + To install LLVM and Clang: + + Linux: Use your package management tool. + + Mac OS X: Clang is included by + default on recent OS X machines when XCode is installed (from + 10.6 and later). LLVM is not included. In + order to use the LLVM based code generator, you should install + the Homebrew + package manager for OS X and then install LLVM 3.5. Alternatively you can download + binaries for LLVM and Clang from here. + + + Windows: You should download binaries for + LLVM and clang from + here. + + + + + + + C Code Generator (<option>-fvia-C</option>) + C code generator + -fvia-C + + This is the oldest code generator in GHC and is generally not included + any more having been deprecated around GHC 7.0. Select it with the + flag. + + + The C code generator is only supported when GHC is built in + unregisterised mode, a mode where GHC produces 'portable' C code as + output to facilitate porting GHC itself to a new platform. This mode + produces much slower code though so it's unlikely your version of + GHC was built this way. If it has then the native code generator + probably won't be available. You can check this information by calling + ghc --info. + + + + + Unregisterised compilation + unregisterised compilation + + The term "unregisterised" really means "compile via vanilla C", + disabling some of the platform-specific tricks that GHC normally uses to + make programs go faster. When compiling unregisterised, GHC simply + generates a C file which is compiled via gcc. + + When GHC is build in unregisterised mode only the LLVM and C code + generators will be available. The native code generator won't be. LLVM + usually offers a substantial performance benefit over the C backend in + unregisterised mode. + + Unregisterised compilation can be useful when porting GHC to a new + machine, since it reduces the prerequisite tools to + gcc, as, and ld + and nothing more, and furthermore the amount of platform-specific code + that needs to be written in order to get + unregisterised compilation going is usually fairly small. + + Unregisterised compilation cannot be selected at compile-time; you + have to build GHC with the appropriate options set. Consult the GHC + Building Guide for details. + + You can check if your GHC is unregisterised by calling + ghc --info. + + + + + diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml new file mode 100644 index 00000000..aebb928a --- /dev/null +++ b/docs/users_guide/debugging.xml @@ -0,0 +1,777 @@ + + + Debugging the compiler + + debugging options (for GHC) + + HACKER TERRITORY. HACKER TERRITORY. (You were warned.) + + + Dumping out compiler intermediate structures + + dumping GHC intermediates + intermediate passes, output + + + + + pass + options + + + Make a debugging dump after pass + <pass> (may be common enough to need + a short form…). You can get all of these at once + (lots of output) by using + , or most of them with + . You can prevent them from clogging up + your standard output by passing . + Some of the most useful ones are: + + + + + : + + + + parser output + + + + + + : + + + + renamer output + + + + + + : + + + + typechecker output + + + + + + : + + + + Dump Template Haskell expressions that we splice in, + and what Haskell code the expression evaluates to. + + + + + + : + + + + Dump a type signature for each value defined at + the top level of the module. The list is sorted + alphabetically. Using + dumps a type signature for all the imported and + system-defined things as well; useful for debugging the + compiler. + + + + + + : + + + + derived instances + + + + + + : + + + + desugarer output + + + + + + : + + + + output of specialisation pass + + + + + + : + + + + dumps all rewrite rules specified in this module; + see . + + + + + + + : + + + + dumps the names of all rules that fired in this module + + + + + + : + + + + dumps detailed information about all rules that fired in + this module + + + + + + + : + + + + dumps the output of the vectoriser. + + + + + + + : + + + + simplifier output (Core-to-Core passes) + + + + + + : + + + + inlining info from the simplifier + + + + + + : + + + + strictness analyser output + + + + + + : + + + + strictness signatures + + + + + + : + + + + CSE pass output + + + + + + : + + + + worker/wrapper split output + + + + + + : + + + + `occurrence analysis' output + + + + + + : + + + + output of core preparation pass + + + + + + : + + + + output of STG-to-STG passes + + + + + + : + + + + Print the C-- code out. + + + + + + : + + + + Dump the results of C-- to C-- optimising passes. + + + + + + : + + + + assembly language from the + native code generator + + + + + + : + + + + LLVM code from the LLVM code + generator + + + + + + : + + + + byte code compiler output + + + + + + : + + + + dump foreign export stubs + + + + + + + + + : + + + + Show the output of each iteration + of the simplifier (each run of the simplifier has a maximum + number of iterations, normally 4). This outputs even more information + than . + + + + + + + + + + Dump statistics about how many of each kind of + transformation too place. If you add + you get more detailed + information. + + + + + + + + + + Make the interface loader be *real* chatty about what it is + up to. + + + + + + + + + + Make the type checker be *real* chatty about what it is + up to. + + + + + + + + + + Make the vectoriser be *real* chatty about what it is + up to. + + + + + + + + + + Make the renamer be *real* chatty about what it is + up to. + + + + + + + + + + Print out summary of what kind of information the renamer + had to bring in. + + + + + + + + + + + + + + Show the output of the intermediate Core-to-Core and + STG-to-STG passes, respectively. (Lots + of output!) So: when we're really desperate: + + +% ghc -noC -O -ddump-simpl -dverbose-core2core -dcore-lint Foo.hs + + + + + + + + + + + + Print out each pass name as it happens. + + + + + + + + + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline. + + + + + + + + + + Show statistics for the usage of fast strings by the + compiler. + + + + + + + + + + Debugging output is in one of several + “styles.” Take the printing of types, for + example. In the “user” style (the default), the + compiler's internal ideas about types are presented in + Haskell source-level syntax, insofar as possible. In the + “debug” style (which is the default for + debugging output), the types are printed in with explicit + foralls, and variables have their unique-id attached (so you + can check for things that look the same but aren't). This + flag makes debugging output appear in the more verbose debug + style. + + + + + + + Formatting dumps + + formatting dumps + + + + + + + + + In error messages, expressions are printed to a + certain “depth”, with subexpressions beyond the + depth replaced by ellipses. This flag sets the + depth. Its default value is 5. + + + + + + + + + + Set the width of debugging output. Use this if your code is wrapping too much. + For example: . + + + + + + + + + + Print single alternative case expressions as though they were strict + let expressions. This is helpful when your code does a lot of unboxing. + + + + + + + + + + Suppress any unsolicited debugging output. When GHC + has been built with the DEBUG option it + occasionally emits debug output of interest to developers. + The extra output can confuse the testing framework and + cause bogus test failures, so this flag is provided to + turn it off. + + + + + + + + Suppressing unwanted information + + suppression + + Core dumps contain a large amount of information. Depending on what you are doing, not all of it will be useful. + Use these flags to suppress the parts that you are not interested in. + + + + + + + + + Suppress everything that can be suppressed, except for unique ids as this often + makes the printout ambiguous. If you just want to see the overall structure of + the code, then start here. + + + + + + + + + + Suppress the printing of uniques. This may make + the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but + it makes the output of two compiler runs have many fewer gratuitous differences, + so you can realistically apply diff. Once diff + has shown you where to look, you can try again without + + + + + + + + + + Suppress extended information about identifiers where they are bound. This includes + strictness information and inliner templates. Using this flag can cut the size + of the core dump in half, due to the lack of inliner templates + + + + + + + + + + Suppress the printing of module qualification prefixes. + This is the Data.List in Data.List.length. + + + + + + + + + + Suppress the printing of type signatures. + + + + + + + + + + Suppress the printing of type applications. + + + + + + + + + + Suppress the printing of type coercions. + + + + + + + Checking for consistency + + consistency checks + lint + + + + + + + + + + Turn on heavyweight intra-pass sanity-checking within + GHC, at Core level. (It checks GHC's sanity, not yours.) + + + + + + : + + + + Ditto for STG level. (NOTE: currently doesn't work). + + + + + + : + + + + Ditto for C-- level. + + + + + + + + How to read Core syntax (from some <option>-ddump</option> + flags) + + reading Core syntax + Core syntax, how to read + + Let's do this by commenting an example. It's from doing + on this code: + + +skip2 m = m : skip2 (m+2) + + + Before we jump in, a word about names of things. Within GHC, + variables, type constructors, etc., are identified by their + “Uniques.” These are of the form `letter' plus + `number' (both loosely interpreted). The `letter' gives some idea + of where the Unique came from; e.g., _ + means “built-in type variable”; t + means “from the typechecker”; s + means “from the simplifier”; and so on. The `number' + is printed fairly compactly in a `base-62' format, which everyone + hates except me (WDP). + + Remember, everything has a “Unique” and it is + usually printed out when debugging, in some form or another. So + here we go… + + +Desugared: +Main.skip2{-r1L6-} :: _forall_ a$_4 =>{{Num a$_4}} -> a$_4 -> [a$_4] + +--# `r1L6' is the Unique for Main.skip2; +--# `_4' is the Unique for the type-variable (template) `a' +--# `{{Num a$_4}}' is a dictionary argument + +_NI_ + +--# `_NI_' means "no (pragmatic) information" yet; it will later +--# evolve into the GHC_PRAGMA info that goes into interface files. + +Main.skip2{-r1L6-} = + /\ _4 -> \ d.Num.t4Gt -> + let { + {- CoRec -} + +.t4Hg :: _4 -> _4 -> _4 + _NI_ + +.t4Hg = (+{-r3JH-} _4) d.Num.t4Gt + + fromInt.t4GS :: Int{-2i-} -> _4 + _NI_ + fromInt.t4GS = (fromInt{-r3JX-} _4) d.Num.t4Gt + +--# The `+' class method (Unique: r3JH) selects the addition code +--# from a `Num' dictionary (now an explicit lambda'd argument). +--# Because Core is 2nd-order lambda-calculus, type applications +--# and lambdas (/\) are explicit. So `+' is first applied to a +--# type (`_4'), then to a dictionary, yielding the actual addition +--# function that we will use subsequently... + +--# We play the exact same game with the (non-standard) class method +--# `fromInt'. Unsurprisingly, the type `Int' is wired into the +--# compiler. + + lit.t4Hb :: _4 + _NI_ + lit.t4Hb = + let { + ds.d4Qz :: Int{-2i-} + _NI_ + ds.d4Qz = I#! 2# + } in fromInt.t4GS ds.d4Qz + +--# `I# 2#' is just the literal Int `2'; it reflects the fact that +--# GHC defines `data Int = I# Int#', where Int# is the primitive +--# unboxed type. (see relevant info about unboxed types elsewhere...) + +--# The `!' after `I#' indicates that this is a *saturated* +--# application of the `I#' data constructor (i.e., not partially +--# applied). + + skip2.t3Ja :: _4 -> [_4] + _NI_ + skip2.t3Ja = + \ m.r1H4 -> + let { ds.d4QQ :: [_4] + _NI_ + ds.d4QQ = + let { + ds.d4QY :: _4 + _NI_ + ds.d4QY = +.t4Hg m.r1H4 lit.t4Hb + } in skip2.t3Ja ds.d4QY + } in + :! _4 m.r1H4 ds.d4QQ + + {- end CoRec -} + } in skip2.t3Ja + + + (“It's just a simple functional language” is an + unregisterised trademark of Peyton Jones Enterprises, plc.) + + + + + + diff --git a/docs/users_guide/extending_ghc.xml b/docs/users_guide/extending_ghc.xml new file mode 100644 index 00000000..90e091a5 --- /dev/null +++ b/docs/users_guide/extending_ghc.xml @@ -0,0 +1,349 @@ + + + Extending and using GHC as a Library + + GHC exposes its internal APIs to users through the built-in ghc package. It allows you to write programs that leverage GHC's entire compilation driver, in order to analyze or compile Haskell code programmatically. Furthermore, GHC gives users the ability to load compiler plugins during compilation - modules which are allowed to view and change GHC's internal intermediate representation, Core. Plugins are suitable for things like experimental optimizations or analysis, and offer a lower barrier of entry to compiler development for many common cases. + + Furthermore, GHC offers a lightweight annotation mechanism that you can use to annotate your source code with metadata, which you can later inspect with either the compiler API or a compiler plugin. + + + Source annotations + + Annotations are small pragmas that allow you to attach data to identifiers in source code, which are persisted when compiled. These pieces of data can then inspected and utilized when using GHC as a library or writing a compiler plugin. + + + Annotating values + + ANN + + Any expression that has both Typeable and Data instances may be attached to a top-level value + binding using an ANN pragma. In particular, this means you can use ANN + to annotate data constructors (e.g. Just) as well as normal values (e.g. take). + By way of example, to annotate the function foo with the annotation Just "Hello" + you would do this: + + +{-# ANN foo (Just "Hello") #-} +foo = ... + + + + A number of restrictions apply to use of annotations: + + The binder being annotated must be at the top level (i.e. no nested binders) + The binder being annotated must be declared in the current module + The expression you are annotating with must have a type with Typeable and Data instances + The Template Haskell staging restrictions apply to the + expression being annotated with, so for example you cannot run a function from the module being compiled. + + To be precise, the annotation {-# ANN x e #-} is well staged if and only if $(e) would be + (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - $([|1|]) is fine as an annotation, albeit redundant). + + + If you feel strongly that any of these restrictions are too onerous, + please give the GHC team a shout. + + + However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! + Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine: + + +{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} +f = ... + + + + + Annotating types + + ANN type + ANN + + You can annotate types with the ANN pragma by using the type keyword. For example: + + +{-# ANN type Foo (Just "A `Maybe String' annotation") #-} +data Foo = ... + + + + + Annotating modules + + ANN module + ANN + + You can annotate modules with the ANN pragma by using the module keyword. For example: + + +{-# ANN module (Just "A `Maybe String' annotation") #-} + + + + + + + Using GHC as a Library + + The ghc package exposes most of GHC's frontend to users, and thus allows you to write programs that leverage it. This library is actually the same library used by GHC's internal, frontend compilation driver, and thus allows you to write tools that programmatically compile source code and inspect it. Such functionality is useful in order to write things like IDE or refactoring tools. As a simple example, here's a program which compiles a module, much like ghc itself does by default when invoked: + + +import GHC +import GHC.Paths ( libdir ) +import DynFlags ( defaultLogAction ) + +main = + defaultErrorHandler defaultLogAction $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + target <- guessTarget "test_main.hs" Nothing + setTargets [target] + load LoadAllTargets + + + The argument to runGhc is a bit tricky. GHC needs this to find its libraries, so the argument must refer to the directory that is printed by ghc --print-libdir for the same version of GHC that the program is being compiled with. Above we therefore use the ghc-paths package which provides this for us. + + Compiling it results in: + + +$ cat test_main.hs +main = putStrLn "hi" +$ ghc -package ghc simple_ghc_api.hs +[1 of 1] Compiling Main ( simple_ghc_api.hs, simple_ghc_api.o ) +Linking simple_ghc_api ... +$ ./simple_ghc_api +$ ./test_main +hi +$ + + + For more information on using the API, as well as more samples and references, please see this Haskell.org wiki page. + + + + Compiler Plugins + + GHC has the ability to load compiler plugins at compile time. The feature is similar to the one provided by GCC, and allows users to write plugins that can adjust the behaviour of the constraint solver, inspect and modify the compilation pipeline, as well as transform and inspect GHC's intermediate language, Core. Plugins are suitable for experimental analysis or optimization, and require no changes to GHC's source code to use. + + Plugins cannot optimize/inspect C--, nor can they implement things like parser/front-end modifications like GCC, apart from limited changes to the constraint solver. If you feel strongly that any of these restrictions are too onerous, please give the GHC team a shout. + + + Using compiler plugins + + Plugins can be specified on the command line with the option -fplugin=module where module is a module in a registered package that exports a plugin. Arguments can be given to plugins with the command line option -fplugin-opt=module:args, where args are arguments interpreted by the plugin provided by module. + + As an example, in order to load the plugin exported by Foo.Plugin in the package foo-ghc-plugin, and give it the parameter "baz", we would invoke GHC like this: + + +$ ghc -fplugin Foo.Plugin -fplugin-opt Foo.Plugin:baz Test.hs +[1 of 1] Compiling Main ( Test.hs, Test.o ) +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +Loading package foo-ghc-plugin-0.1 ... linking ... done. +... +Linking Test ... +$ + + + Since plugins are exported by registered packages, it's safe to put dependencies on them in cabal for example, and specify plugin arguments to GHC through the ghc-options field. + + + + Writing compiler plugins + + Plugins are modules that export at least a single identifier, plugin, of type GhcPlugins.Plugin. All plugins should import GhcPlugins as it defines the interface to the compilation pipeline. + + A Plugin effectively holds a function which installs a compilation pass into the compiler pipeline. By default there is the empty plugin which does nothing, GhcPlugins.defaultPlugin, which you should override with record syntax to specify your installation function. Since the exact fields of the Plugin type are open to change, this is the best way to ensure your plugins will continue to work in the future with minimal interface impact. + + Plugin exports a field, installCoreToDos which is a function of type [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]. A CommandLineOption is effectively just String, and a CoreToDo is basically a function of type Core -> Core. A CoreToDo gives your pass a name and runs it over every compiled module when you invoke GHC. + + As a quick example, here is a simple plugin that just does nothing and just returns the original compilation pipeline, unmodified, and says 'Hello': + + +module DoNothing.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + putMsgS "Hello!" + return todo + + + Provided you compiled this plugin and registered it in a package (with cabal for instance,) you can then use it by just specifying -fplugin=DoNothing.Plugin on the command line, and during the compilation you should see GHC say 'Hello'. + + Note carefully the reinitializeGlobals call at the beginning of the installation function. Due to bugs in the windows linker dealing with libghc, this call is necessary to properly ensure compiler plugins have the same global state as GHC at the time of invocation. Without reinitializeGlobals, compiler plugins can crash at runtime because they may require state that hasn't otherwise been initialized. + + In the future, when the linking bugs are fixed, reinitializeGlobals will be deprecated with a warning, and changed to do nothing. + + + + Core plugins in more detail + + CoreToDo is effectively a data type that describes all the kinds of optimization passes GHC does on Core. There are passes for simplification, CSE, vectorisation, etc. There is a specific case for plugins, CoreDoPluginPass :: String -> PluginPass -> CoreToDo which should be what you always use when inserting your own pass into the pipeline. The first parameter is the name of the plugin, and the second is the pass you wish to insert. + + CoreM is a monad that all of the Core optimizations live and operate inside of. + + A plugin's installation function (install in the above example) takes a list of CoreToDos and returns a list of CoreToDo. Before GHC begins compiling modules, it enumerates all the needed plugins you tell it to load, and runs all of their installation functions, initially on a list of passes that GHC specifies itself. After doing this for every plugin, the final list of passes is given to the optimizer, and are run by simply going over the list in order. + + You should be careful with your installation function, because the list of passes you give back isn't questioned or double checked by GHC at the time of this writing. An installation function like the following: + + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ _ = return [] + + + is certainly valid, but also certainly not what anyone really wants. + + + Manipulating bindings + + In the last section we saw that besides a name, a CoreDoPluginPass takes a pass of type PluginPass. A PluginPass is a synonym for (ModGuts -> CoreM ModGuts). ModGuts is a type that represents the one module being compiled by GHC at any given time. + + A ModGuts holds all of the module's top level bindings which we can examine. These bindings are of type CoreBind and effectively represent the binding of a name to body of code. Top-level module bindings are part of a ModGuts in the field mg_binds. Implementing a pass that manipulates the top level bindings merely needs to iterate over this field, and return a new ModGuts with an updated mg_binds field. Because this is such a common case, there is a function provided named bindsOnlyPass which lifts a function of type ([CoreBind] -> CoreM [CoreBind]) to type (ModGuts -> CoreM ModGuts). + + Continuing with our example from the last section, we can write a simple plugin that just prints out the name of all the non-recursive bindings in a module it compiles: + + +module SayNames.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass guts = do dflags <- getDynFlags + bindsOnlyPass (mapM (printBind dflags)) guts + where printBind :: DynFlags -> CoreBind -> CoreM CoreBind + printBind dflags bndr@(NonRec b _) = do + putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b) + return bndr + printBind _ bndr = return bndr + + + + + Using Annotations + + Previously we discussed annotation pragmas (), which we mentioned could be used to give compiler plugins extra guidance or information. Annotations for a module can be retrieved by a plugin, but you must go through the modules ModGuts in order to get it. Because annotations can be arbitrary instances of Data and Typeable, you need to give a type annotation specifying the proper type of data to retrieve from the interface file, and you need to make sure the annotation type used by your users is the same one your plugin uses. For this reason, we advise distributing annotations as part of the package which also provides compiler plugins if possible. + + To get the annotations of a single binder, you can use `getAnnotations` and specify the proper type. Here's an example that will print out the name of any top-level non-recursive binding with the SomeAnn annotation: + + +{-# LANGUAGE DeriveDataTypeable #-} +module SayAnnNames.Plugin (plugin, SomeAnn(..)) where +import GhcPlugins +import Control.Monad (unless) +import Data.Data + +data SomeAnn = SomeAnn deriving (Data, Typeable) + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass g = do + dflags <- getDynFlags + mapM_ (printAnn dflags g) (mg_binds g) >> return g + where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind + printAnn dflags guts bndr@(NonRec b _) = do + anns <- annotationsOn guts b :: CoreM [SomeAnn] + unless (null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc dflags (ppr b) + return bndr + printAnn _ _ bndr = return bndr + +annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + anns <- getAnnotations deserializeWithData guts + return $ lookupWithDefaultUFM anns [] (varUnique bndr) + + + Please see the GHC API documentation for more about how to use internal APIs, etc. + + + + + Typechecker plugins + + In addition to Core plugins, GHC has experimental support for typechecker plugins, which allow the behaviour of the constraint solver to be modified. For example, they make it possible to interface the compiler to an SMT solver, in order to support a richer theory of type-level arithmetic expressions than the theory built into GHC (see ). + + The Plugin type has a field tcPlugin of type [CommandLineOption] -> Maybe TcPlugin, where the TcPlugin type is defined thus: + + +data TcPlugin = forall s . TcPlugin + { tcPluginInit :: TcPluginM s + , tcPluginSolve :: s -> TcPluginSolver + , tcPluginStop :: s -> TcPluginM () + } + +type TcPluginSolver = [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult + +data TcPluginResult = TcPluginContradiction [Ct] | TcPluginOk [(EvTerm,Ct)] [Ct] + + + (The details of this representation are subject to change as we gain more experience writing typechecker plugins. It should not be assumed to be stable between GHC releases.) + + The basic idea is as follows: + + When type checking a module, GHC calls tcPluginInit once before constraint solving starts. This allows the plugin to look things up in the context, initialise mutable state or open a connection to an external process (e.g. an external SMT solver). The plugin can return a result of any type it likes, and the result will be passed to the other two fields. + During constraint solving, GHC repeatedly calls tcPluginSolve. This function is provided with the current set of constraints, and should return a TcPluginResult that indicates whether a contradiction was found or progress was made. If the plugin solver makes progress, GHC will re-start the constraint solving pipeline, looping until a fixed point is reached. + Finally, GHC calls tcPluginStop after constraint solving is finished, allowing the plugin to dispose of any resources it has allocated (e.g. terminating the SMT solver process). + + + + Plugin code runs in the TcPluginM monad, which provides a restricted interface to GHC API functionality that is relevant for typechecker plugins, including IO and reading the environment. If you need functionality that is not exposed in the TcPluginM module, you can use unsafeTcPluginTcM :: TcM a -> TcPluginM a, but are encouraged to contact the GHC team to suggest additions to the interface. Note that TcPluginM can perform arbitrary IO via tcPluginIO :: IO a -> TcPluginM a, although some care must be taken with side effects (particularly in tcPluginSolve). In general, it is up to the plugin author to make sure that any IO they do is safe. + + + + Constraint solving with plugins + + The key component of a typechecker plugin is a function of type TcPluginSolver, like this: + + +solve :: [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult +solve givens deriveds wanteds = ... + + + This function will be invoked at two points in the constraint solving process: after simplification of given constraints, and after unflattening of wanted constraints. The two phases can be distinguished because the deriveds and wanteds will be empty in the first case. In each case, the plugin should either + + return TcPluginContradiction with a list of impossible constraints (which must be a subset of those passed in), so they can be turned into errors; or + return TcPluginOk with lists of solved and new constraints (the former must be a subset of those passed in and must be supplied with corresponding evidence terms). + + If the plugin cannot make any progress, it should return TcPluginOk [] []. Otherwise, if there were any new constraints, the main constraint solver will be re-invoked to simplify them, then the plugin will be invoked again. The plugin is responsible for making sure that this process eventually terminates. + + Plugins are provided with all available constraints (including equalities and typeclass constraints), but it is easy for them to discard those that are not relevant to their domain, because they need return only those constraints for which they have made progress (either by solving or contradicting them). + + Constraints that have been solved by the plugin must be provided with evidence in the form of an EvTerm of the type of the constraint. This evidence is ignored for given and derived constraints, which GHC "solves" simply by discarding them; typically this is used when they are uninformative (e.g. reflexive equations). For wanted constraints, the evidence will form part of the Core term that is generated after typechecking, and can be checked by . It is possible for the plugin to create equality axioms for use in evidence terms, but GHC does not check their consistency, and inconsistent axiom sets may lead to segfaults or other runtime misbehaviour. + + + + + + + diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml new file mode 100644 index 00000000..ab099b29 --- /dev/null +++ b/docs/users_guide/ffi-chap.xml @@ -0,0 +1,824 @@ + + + + + +Foreign function interface (FFI) + + + GHC (mostly) conforms to the Haskell Foreign Function Interface, + whose definition is part of the Haskell Report on http://www.haskell.org/. + + FFI support is enabled by default, but can be enabled or disabled explicitly with the + flag. + + GHC implements a number of GHC-specific extensions to the FFI + Addendum. These extensions are described in , but please note that programs using + these features are not portable. Hence, these features should be + avoided where possible. + + The FFI libraries are documented in the accompanying library + documentation; see for example the + Foreign module. + + + GHC extensions to the FFI Addendum + + The FFI features that are described in this section are specific to + GHC. Your code will not be portable to other compilers if you use them. + + + Unboxed types + + The following unboxed types may be used as basic foreign types + (see FFI Addendum, Section 3.2): Int#, + Word#, Char#, + Float#, Double#, + Addr#, StablePtr# a, + MutableByteArray#, ForeignObj#, + and ByteArray#. + + + + Newtype wrapping of the IO monad + The FFI spec requires the IO monad to appear in various places, + but it can sometimes be convenient to wrap the IO monad in a + newtype, thus: + + newtype MyIO a = MIO (IO a) + + (A reason for doing so might be to prevent the programmer from + calling arbitrary IO procedures in some part of the program.) + +The Haskell FFI already specifies that arguments and results of +foreign imports and exports will be automatically unwrapped if they are +newtypes (Section 3.2 of the FFI addendum). GHC extends the FFI by automatically unwrapping any newtypes that +wrap the IO monad itself. +More precisely, wherever the FFI specification requires an IO type, GHC will +accept any newtype-wrapping of an IO type. For example, these declarations are +OK: + + foreign import foo :: Int -> MyIO Int + foreign import "dynamic" baz :: (Int -> MyIO Int) -> CInt -> MyIO Int + + + + + + Primitive imports + + GHC extends the FFI with an additional calling convention + prim, e.g.: + + foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) + + This is used to import functions written in Cmm code that follow an + internal GHC calling convention. This feature is not intended for + use outside of the core libraries that come with GHC. For more + details see the + GHC developer wiki. + + + + + Interruptible foreign calls + + This concerns the interaction of foreign calls + with Control.Concurrent.throwTo. + Normally when the target of a throwTo is + involved in a foreign call, the exception is not raised + until the call returns, and in the meantime the caller is + blocked. This can result in unresponsiveness, which is + particularly undesirable in the case of user interrupt + (e.g. Control-C). The default behaviour when a Control-C + signal is received (SIGINT on Unix) is to raise + the UserInterrupt exception in the main + thread; if the main thread is blocked in a foreign call at + the time, then the program will not respond to the user + interrupt. + + + + The problem is that it is not possible in general to + interrupt a foreign call safely. However, GHC does provide + a way to interrupt blocking system calls which works for + most system calls on both Unix and Windows. When the + InterruptibleFFI extension is enabled, + a foreign call + can be annotated with interruptible instead + of safe or unsafe: + + +foreign import ccall interruptible + "sleep" sleepBlock :: CUint -> IO CUint + + + interruptible behaves exactly as + safe, except that when + a throwTo is directed at a thread in an + interruptible foreign call, an OS-specific mechanism will be + used to attempt to cause the foreign call to return: + + + + Unix systems + + + The thread making the foreign call is sent + a SIGPIPE signal + using pthread_kill(). This is + usually enough to cause a blocking system call to + return with EINTR (GHC by default + installs an empty signal handler + for SIGPIPE, to override the + default behaviour which is to terminate the process + immediately). + + + + + Windows systems + + + [Vista and later only] The RTS calls the Win32 + function CancelSynchronousIO, + which will cause a blocking I/O operation to return + with the + error ERROR_OPERATION_ABORTED. + + + + + + If the system call is successfully interrupted, it will + return to Haskell whereupon the exception can be raised. Be + especially careful when + using interruptible that the caller of + the foreign function is prepared to deal with the + consequences of the call being interrupted; on Unix it is + good practice to check for EINTR always, + but on Windows it is not typically necessary to + handle ERROR_OPERATION_ABORTED. + + + + + The CAPI calling convention + + The CApiFFI extension allows a calling + convention of capi to be used in foreign + declarations, e.g. + + +foreign import capi "header.h f" f :: CInt -> IO CInt + + + Rather than generating code to call f + according to the platform's ABI, we instead call + f using the C API defined in the header + header.h. Thus f can be + called even if it may be defined as a CPP + #define rather than a proper function. + + + + When using capi, it is also possible to + import values, rather than functions. For example, + + +foreign import capi "pi.h value pi" c_pi :: CDouble + + + will work regardless of whether pi is + defined as + +const double pi = 3.14; + + or with + +#define pi 3.14 + + + + + In order to tell GHC the C type that a Haskell type + corresponds to when it is used with the CAPI, a + CTYPE pragma can be used on the type + definition. The header which defines the type can optionally + also be specified. The syntax looks like: + + +data {-# CTYPE "unistd.h" "useconds_t" #-} T = ... +newtype {-# CTYPE "useconds_t" #-} T = ... + + + + + + <literal>hs_thread_done()</literal> + + +void hs_thread_done(void); + + + + GHC allocates a small amount of thread-local memory when a + thread calls a Haskell function via a foreign + export. This memory is not normally freed until + hs_exit(); the memory is cached so that + subsequent calls into Haskell are fast. However, if your + application is long-running and repeatedly creates new + threads that call into Haskell, you probably want to arrange + that this memory is freed in those threads that have + finished calling Haskell functions. To do this, call + hs_thread_done() from the thread whose + memory you want to free. + + + + Calling hs_thread_done() is entirely + optional. You can call it as often or as little as you + like. It is safe to call it from a thread that has never + called any Haskell functions, or one that never will. If + you forget to call it, the worst that can happen is that + some memory remains allocated until + hs_exit() is called. If you call it too + often, the worst that can happen is that the next call to a + Haskell function incurs some extra overhead. + + + + + + Using the FFI with GHC + + The following sections also give some hints and tips on the + use of the foreign function interface in GHC. + + + Using <literal>foreign export</literal> and <literal>foreign import ccall "wrapper"</literal> with GHC + + foreign export + with GHC + + + When GHC compiles a module (say M.hs) + which uses foreign export or + foreign import "wrapper", it generates two + additional files, M_stub.c and + M_stub.h. GHC will automatically compile + M_stub.c to generate + M_stub.o at the same time. + + For a plain foreign export, the file + M_stub.h contains a C prototype for the + foreign exported function, and M_stub.c + contains its definition. For example, if we compile the + following module: + + +module Foo where + +foreign export ccall foo :: Int -> IO Int + +foo :: Int -> IO Int +foo n = return (length (f n)) + +f :: Int -> [Int] +f 0 = [] +f n = n:(f (n-1)) + + Then Foo_stub.h will contain + something like this: + + +#include "HsFFI.h" +extern HsInt foo(HsInt a0); + + and Foo_stub.c contains the + compiler-generated definition of foo(). To + invoke foo() from C, just #include + "Foo_stub.h" and call foo(). + + The foo_stub.c and + foo_stub.h files can be redirected using the + option; see . + + When linking the program, remember to include + M_stub.o in the final link command line, or + you'll get link errors for the missing function(s) (this isn't + necessary when building your program with ghc + --make, as GHC will automatically link in the + correct bits). + + + Using your own <literal>main()</literal> + + Normally, GHC's runtime system provides a + main(), which arranges to invoke + Main.main in the Haskell program. However, + you might want to link some Haskell code into a program which + has a main function written in another language, say C. In + order to do this, you have to initialize the Haskell runtime + system explicitly. + + Let's take the example from above, and invoke it from a + standalone C program. Here's the C code: + + +#include <stdio.h> +#include "HsFFI.h" + +#ifdef __GLASGOW_HASKELL__ +#include "foo_stub.h" +#endif + +int main(int argc, char *argv[]) +{ + int i; + + hs_init(&argc, &argv); + + for (i = 0; i < 5; i++) { + printf("%d\n", foo(2500)); + } + + hs_exit(); + return 0; +} + + We've surrounded the GHC-specific bits with + #ifdef __GLASGOW_HASKELL__; the rest of the + code should be portable across Haskell implementations that + support the FFI standard. + + The call to hs_init() + initializes GHC's runtime system. Do NOT try to invoke any + Haskell functions before calling + hs_init(): bad things will + undoubtedly happen. + + We pass references to argc and + argv to hs_init() + so that it can separate out any arguments for the RTS + (i.e. those arguments between + +RTS...-RTS). + + After we've finished invoking our Haskell functions, we + can call hs_exit(), which terminates the + RTS. + + There can be multiple calls to + hs_init(), but each one should be matched + by one (and only one) call to + hs_exit()The outermost + hs_exit() will actually de-initialise the + system. NOTE that currently GHC's runtime cannot reliably + re-initialise after this has happened, + see . + . + + NOTE: when linking the final program, it is normally + easiest to do the link using GHC, although this isn't + essential. If you do use GHC, then don't forget the flag + + , otherwise GHC will try to link + to the Main Haskell module. + + To use +RTS flags + with hs_init(), we have to modify the + example slightly. By default, GHC's RTS will only accept + "safe" + +RTS flags (see + ), and + the link-time flag overrides this. + However, has no effect + when is in use (and the same + goes for ). To set these + options we have to call a GHC-specific API instead + of : + + +#include <stdio.h> +#include "HsFFI.h" + +#ifdef __GLASGOW_HASKELL__ +#include "foo_stub.h" +#include "Rts.h" +#endif + +int main(int argc, char *argv[]) +{ + int i; + +#if __GLASGOW_HASKELL__ >= 703 + { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + } +#else + hs_init(&argc, &argv); +#endif + + for (i = 0; i < 5; i++) { + printf("%d\n", foo(2500)); + } + + hs_exit(); + return 0; +} + + Note two changes: we included Rts.h, + which defines the GHC-specific external RTS interface, and we + called hs_init_ghc() instead + of hs_init(), passing an argument of + type RtsConfig. + RtsConfig is a struct with various fields + that affect the behaviour of the runtime system. Its + definition is: + + +typedef struct { + RtsOptsEnabledEnum rts_opts_enabled; + const char *rts_opts; +} RtsConfig; + +extern const RtsConfig defaultRtsConfig; + +typedef enum { + RtsOptsNone, // +RTS causes an error + RtsOptsSafeOnly, // safe RTS options allowed; others cause an error + RtsOptsAll // all RTS options allowed + } RtsOptsEnabledEnum; + + + There is a default + value defaultRtsConfig that should be used + to initialise variables of type RtsConfig. + More fields will undoubtedly be added + to RtsConfig in the future, so in order to + keep your code forwards-compatible it is best to initialise + with defaultRtsConfig and then modify the + required fields, as in the code sample above. + + + + + + Making a Haskell library that can be called from foreign + code + + The scenario here is much like in , except that the aim is not to link a complete program, but to + make a library from Haskell code that can be deployed in the same + way that you would deploy a library of C code. + + The main requirement here is that the runtime needs to be + initialized before any Haskell code can be called, so your library + should provide initialisation and deinitialisation entry points, + implemented in C or C++. For example: + + +#include <stdlib.h> +#include "HsFFI.h" + +HsBool mylib_init(void){ + int argc = 2; + char *argv[] = { "+RTS", "-A32m", NULL }; + char **pargv = argv; + + // Initialize Haskell runtime + hs_init(&argc, &pargv); + + // do any other initialization here and + // return false if there was a problem + return HS_BOOL_TRUE; +} + +void mylib_end(void){ + hs_exit(); +} + + + The initialisation routine, mylib_init, calls + hs_init() as + normal to initialise the Haskell runtime, and the corresponding + deinitialisation function mylib_end() calls + hs_exit() to shut down the runtime. + + + + + + Using header files + + C calls, function headers + + C functions are normally declared using prototypes in a C + header file. Earlier versions of GHC (6.8.3 and + earlier) #included the header file in + the C source file generated from the Haskell code, and the C + compiler could therefore check that the C function being + called via the FFI was being called at the right type. + + GHC no longer includes external header files when + compiling via C, so this checking is not performed. The + change was made for compatibility with the + native code generator + (-fasm) and to comply strictly with the FFI + specification, which requires that FFI calls are not subject + to macro expansion and other CPP conversions that may be + applied when using C header files. This approach also + simplifies the inlining of foreign calls across module and + package boundaries: there's no need for the header file to be + available when compiling an inlined version of a foreign call, + so the compiler is free to inline foreign calls in any + context. + + The -#include option is now + deprecated, and the include-files field + in a Cabal package specification is ignored. + + + + + Memory Allocation + + The FFI libraries provide several ways to allocate memory + for use with the FFI, and it isn't always clear which way is the + best. This decision may be affected by how efficient a + particular kind of allocation is on a given compiler/platform, + so this section aims to shed some light on how the different + kinds of allocation perform with GHC. + + + + alloca and friends + + Useful for short-term allocation when the allocation + is intended to scope over a given IO + computation. This kind of allocation is commonly used + when marshalling data to and from FFI functions. + + In GHC, alloca is implemented + using MutableByteArray#, so allocation + and deallocation are fast: much faster than C's + malloc/free, but not quite as fast as + stack allocation in C. Use alloca + whenever you can. + + + + + mallocForeignPtr + + Useful for longer-term allocation which requires + garbage collection. If you intend to store the pointer to + the memory in a foreign data structure, then + mallocForeignPtr is + not a good choice, however. + + In GHC, mallocForeignPtr is also + implemented using MutableByteArray#. + Although the memory is pointed to by a + ForeignPtr, there are no actual + finalizers involved (unless you add one with + addForeignPtrFinalizer), and the + deallocation is done using GC, so + mallocForeignPtr is normally very + cheap. + + + + + malloc/free + + If all else fails, then you need to resort to + Foreign.malloc and + Foreign.free. These are just wrappers + around the C functions of the same name, and their + efficiency will depend ultimately on the implementations + of these functions in your platform's C library. We + usually find malloc and + free to be significantly slower than + the other forms of allocation above. + + + + + Foreign.Marshal.Pool + + Pools are currently implemented using + malloc/free, so while they might be a + more convenient way to structure your memory allocation + than using one of the other forms of allocation, they + won't be any more efficient. We do plan to provide an + improved-performance implementation of Pools in the + future, however. + + + + + + + Multi-threading and the FFI + + In order to use the FFI in a multi-threaded setting, you must + use the option + (see ). + + + Foreign imports and multi-threading + + When you call a foreign imported + function that is annotated as safe (the + default), and the program was linked + using , then the call will run + concurrently with other running Haskell threads. If the + program was linked without , + then the other Haskell threads will be blocked until the + call returns. + + This means that if you need to make a foreign call to + a function that takes a long time or blocks indefinitely, + then you should mark it safe and + use . Some library functions + make such calls internally; their documentation should + indicate when this is the case. + + If you are making foreign calls from multiple Haskell + threads and using , make sure that + the foreign code you are calling is thread-safe. In + particularly, some GUI libraries are not thread-safe and + require that the caller only invokes GUI methods from a + single thread. If this is the case, you may need to + restrict your GUI operations to a single Haskell thread, + and possibly also use a bound thread (see + ). + + Note that foreign calls made by different Haskell + threads may execute in parallel, even + when the +RTS -N flag is not being used + (). The +RTS + -N flag controls parallel execution of Haskell + threads, but there may be an arbitrary number of foreign + calls in progress at any one time, regardless of + the +RTS -N value. + + If a call is annotated as interruptible + and the program was multithreaded, the call may be + interrupted in the event that the Haskell thread receives an + exception. The mechanism by which the interrupt occurs + is platform dependent, but is intended to cause blocking + system calls to return immediately with an interrupted error + code. The underlying operating system thread is not to be + destroyed. See for more details. + + + + The relationship between Haskell threads and OS + threads + + Normally there is no fixed relationship between Haskell + threads and OS threads. This means that when you make a + foreign call, that call may take place in an unspecified OS + thread. Furthermore, there is no guarantee that multiple + calls made by one Haskell thread will be made by the same OS + thread. + + This usually isn't a problem, and it allows the GHC + runtime system to make efficient use of OS thread resources. + However, there are cases where it is useful to have more + control over which OS thread is used, for example when + calling foreign code that makes use of thread-local state. + For cases like this, we provide bound + threads, which are Haskell threads tied to a + particular OS thread. For information on bound threads, see + the documentation + for the Control.Concurrent + module. + + + + Foreign exports and multi-threading + + When the program is linked + with , then you may + invoke foreign exported functions from + multiple OS threads concurrently. The runtime system must + be initialised as usual by + calling hs_init(), and this call must + complete before invoking any foreign + exported functions. + + + + On the use of <literal>hs_exit()</literal> + + hs_exit() normally causes the termination of + any running Haskell threads in the system, and when + hs_exit() returns, there will be no more Haskell + threads running. The runtime will then shut down the system in an + orderly way, generating profiling + output and statistics if necessary, and freeing all the memory it + owns. + + It isn't always possible to terminate a Haskell thread forcibly: + for example, the thread might be currently executing a foreign call, + and we have no way to force the foreign call to complete. What's + more, the runtime must + assume that in the worst case the Haskell code and runtime are about + to be removed from memory (e.g. if this is a Windows DLL, + hs_exit() is normally called before unloading the + DLL). So hs_exit() must wait + until all outstanding foreign calls return before it can return + itself. + + The upshot of this is that if you have Haskell threads that are + blocked in foreign calls, then hs_exit() may hang + (or possibly busy-wait) until the calls return. Therefore it's a + good idea to make sure you don't have any such threads in the system + when calling hs_exit(). This includes any threads + doing I/O, because I/O may (or may not, depending on the + type of I/O and the platform) be implemented using blocking foreign + calls. + + The GHC runtime treats program exit as a special case, to avoid + the need to wait for blocked threads when a standalone + executable exits. Since the program and all its threads are about to + terminate at the same time that the code is removed from memory, it + isn't necessary to ensure that the threads have exited first. + (Unofficially, if you want to use this fast and loose version of + hs_exit(), then call + shutdownHaskellAndExit() instead). + + + + + Floating point and the FFI + + + The standard C99 fenv.h header + provides operations for inspecting and modifying the state of + the floating point unit. In particular, the rounding mode + used by floating point operations can be changed, and the + exception flags can be tested. + + + + In Haskell, floating-point operations have pure types, and the + evaluation order is unspecified. So strictly speaking, since + the fenv.h functions let you change the + results of, or observe the effects of floating point + operations, use of fenv.h renders the + behaviour of floating-point operations anywhere in the program + undefined. + + + + Having said that, we can document exactly + what GHC does with respect to the floating point state, so + that if you really need to use fenv.h then + you can do so with full knowledge of the pitfalls: + + + + GHC completely ignores the floating-point + environment, the runtime neither modifies nor reads it. + + + + + The floating-point environment is not saved over a + normal thread context-switch. So if you modify the + floating-point state in one thread, those changes may be + visible in other threads. Furthermore, testing the + exception state is not reliable, because a context + switch may change it. If you need to modify or test the + floating point state and use threads, then you must use + bound threads + (Control.Concurrent.forkOS), because + a bound thread has its own OS thread, and OS threads do + save and restore the floating-point state. + + + + + It is safe to modify the floating-point unit state + temporarily during a foreign call, because foreign calls + are never pre-empted by GHC. + + + + + + + + + diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml new file mode 100644 index 00000000..b4a76ffb --- /dev/null +++ b/docs/users_guide/flags.xml @@ -0,0 +1,3363 @@ + + + Flag reference + + This section is a quick-reference for GHC's command-line + flags. For each flag, we also list its static/dynamic status (see + ), and the flag's opposite + (if available). + + + Verbosity options + + More details in + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + verbose mode (equivalent to ) + dynamic + - + + + n + set verbosity level + dynamic + - + + + + print explicit forall quantification in types + dynamic + -fno-print-explicit-foralls + + + + print explicit kind foralls and kind arguments in types + dynamic + -fno-print-explicit-kinds + + + + output full span in error messages + dynamic + - + + + size + Set the minimum heap size to size + dynamic + - + + + + Summarise timing stats for GHC (same as +RTS -tstderr) + dynamic + - + + + + + + + + Alternative modes of operation + + More details in + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + , + Disply help + mode + - + + + + + Interactive mode - normally used by just running ghci; + see for details. + mode + - + + + + Build a multi-module Haskell program, automatically figuring out dependencies. Likely to be much easier, and faster, than using make; + see for details.. + mode + - + + + + Evaluate expr; + see for details. + mode + - + + + + + Display the contents of an interface file. + mode + - + + + + + Generate dependency information suitable for use in a Makefile; + see for details. + mode + - + + + + + , + display the supported language extensions + mode + - + + + + display the supported command line options + mode + - + + + + display information about the compiler + mode + - + + + + display GHC version + mode + - + + + + display GHC version (numeric only) + mode + - + + + + display GHC library directory + mode + - + + + + + + + + + Which phases to run + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Stop after preprocessing (.hspp file) + mode + - + + + + Stop after generating C (.hc file) + mode + - + + + + Stop after generating assembly (.s file) + mode + - + + + + Stop after generating object (.o) file + mode + - + + + suffix + Override default behaviour for source files + dynamic + - + + + + + + + + Redirecting output + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + suffix + set the suffix to use for intermediate C files + dynamic + - + + + dir + set directory for interface files + dynamic + - + + + suffix + set the suffix to use for interface files + dynamic + - + + + filename + set output filename + dynamic + - + + + dir + set directory for object files + dynamic + - + + + filename + set the filename in which to put the interface + dynamic + + + + suffix + set the output file suffix + dynamic + - + + + dir + redirect FFI stub files + dynamic + - + + + dir + redirect dump files + dynamic + - + + + dir + set output directory + dynamic + - + + + + + + + + Keeping intermediate files + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + or + + retain intermediate .hc files + dynamic + - + + + or + + retain intermediate LLVM .ll files + dynamic + - + + + or + + retain intermediate .s files + dynamic + - + + + + retain all intermediate temporary files + dynamic + - + + + + + + + + Temporary files + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + set the directory for temporary files + dynamic + - + + + + + + + + Finding imports + + + + + + + + Flag + + Description + Static/Dynamic + Reverse + + + + + dir1:dir2:... + add dir, + dir2, etc. to import path + dynamic/:set + - + + + + Empty the import directory list + dynamic/:set + - + + + + + + + + Interface file options + + + + + + + + Flag + + Description + Static/Dynamic + Reverse + + + + + + Dump the new interface to stdout + dynamic + - + + + + Show the differences vs. the old interface + dynamic + - + + + + Dump a minimal set of imports + dynamic + - + + + file + See . + + + + + + + + Recompilation checking + + + + + + + + Flag + + Description + Static/Dynamic + Reverse + + + + + + Turn off recompilation checking. This is implied by any + option when compiling a single + file (i.e. when using -c). + dynamic + + + + + + + + + Interactive-mode options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Disable reading of .ghci files + dynamic + - + + + + Read additional .ghci files + dynamic + - + + + + Break on uncaught exceptions and errors + dynamic + + + + + Break on any exception thrown + dynamic + + + + + Set the number of entries GHCi keeps for :history + dynamic + + + + + Enable usage of Show instances in :print + dynamic + + + + + Turn on printing of binding results in GHCi + dynamic + + + + + Turn off printing of binding contents in GHCi + dynamic + - + + + + Turn off + implicit qualified import of everything in GHCi + dynamic + - + + + + Select the function + to use for printing evaluated expressions in GHCi + dynamic + - + + + + + + + + + Packages + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + P + Compile to be part of package P + dynamic + - + + + P + Expose package P + dynamic/:set + - + + + + Hide all packages by default + dynamic + - + + + name + Hide package P + dynamic/:set + - + + + name + Ignore package P + dynamic/:set + - + + + file + Add file to the package db stack. + dynamic + - + + + + Clear the package db stack. + dynamic + - + + + + Remove the global package db from the stack. + dynamic + - + + + + Add the global package db to the stack. + dynamic + - + + + + Remove the user's package db from the stack. + dynamic + - + + + + Add the user's package db to the stack. + dynamic + - + + + + Don't automatically link in the base and rts packages. + dynamic + - + + + P + Expose package P and set it to be + trusted + dynamic/:set + - + + + P + Expose package P and set it to be + distrusted + dynamic/:set + - + + + + Distrust all packages by default + dynamic/:set + - + + + + + + + + Language options + + Language options can be enabled either by a command-line option + , or by a {-# LANGUAGE blah #-} + pragma in the file itself. See . Some + options are enabled using flags. + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + n + set the limit for type-class context reduction. Default is 100. + dynamic + + + + + Deprecated. Enable most language extensions; see for exactly which ones. + dynamic + + + + + Make tuple pattern matching irrefutable + dynamic + + + + + Enable Safe Haskell trusted package requirement for trustworthy modules. + dynamic + + + + n + set the limit for type function reductions. Default is 200. + dynamic + + + + + Allow the user to write ambiguous types, + and the type inference engine to infer them. + + dynamic + + + + + Enable arrow + notation extension + dynamic + + + + + As of GHC 7.10, this option is not needed, and should + not be used. Automatically derive Typeable instances for every datatype and type class declaration. + Implies . + dynamic + + + + + Enable bang patterns. + dynamic + + + + + Enable support for binary literals. + dynamic + + + + + Enable the CAPI calling convention. + dynamic + + + + + Enable constrained class methods. + dynamic + + + + + Enable a kind of constraints. + dynamic + + + + + Enable the C preprocessor. + dynamic + + + + + Enable datatype promotion. + dynamic + + + + + Enable default signatures. + dynamic + + + + + Enable deriving for any + class. + dynamic + + + + + Enable deriving for the Data class. + Implied by . + dynamic + + + + + Enable deriving for the Functor class. + Implied by . + dynamic + + + + + Enable deriving for the Foldable class. + Implied by . + dynamic + + + + + Enable deriving for the Generic class. + dynamic + + + + + Enable deriving for the Traversable class. + Implies and . + dynamic + + + + + Enable record field disambiguation. + Implied by . + dynamic + + + + + Allow empty case alternatives. + dynamic + + + + + Enable empty data declarations. + dynamic + + + + + Enable existential quantification. + dynamic + + + + + Enable explicit universal quantification. + Implied by , + , + and + . + + dynamic + + + + + Enable using the keyword type to specify the namespace of + entries in imports and exports (). + Implied by and . + dynamic + + + + + Use GHCi's extended default rules in a normal module. + dynamic + + + + + Enable flexible contexts. + Implied by . + dynamic + + + + + Enable flexible instances. + Implies . Implied by . + dynamic + + + + + Enable foreign function interface. + dynamic + + + + + Enable functional dependencies. + Implies . + dynamic + + + + + Enable generalised algebraic data types. + Implies and . + dynamic + + + + + Enable generalised algebraic data type syntax. + + dynamic + + + + + Enable newtype deriving. + dynamic + + + + + Deprecated, does nothing. No longer enables generic classes. + See also GHC's support for + generic programming. + dynamic + + + + + Enable Implicit Parameters. + Implies and . + dynamic + + + + + Don't implicitly import Prelude. + Implied by . + dynamic + + + + + Enable impredicative types. + Implies . + dynamic + + + + + Enable incoherent instances. + Implies . + dynamic + + + + + Enable instance signatures. + dynamic + + + + + Enable interruptible FFI. + dynamic + + + + + Enable kind signatures. + Implied by and . + dynamic + + + + + Enable lambda-case expressions. + dynamic + + + + + Enable liberalised type synonyms. + dynamic + + + + + Allow "#" as a postfix modifier on identifiers. + dynamic + + + + + Enable monad comprehensions. + dynamic + + + + + Enable do not generalise local bindings. + Implied by and . + + dynamic + + + + + Disable the monomorphism restriction. + dynamic + + + + + Enable multi parameter type classes. + Implied by . + dynamic + + + + + Enable multi-way if-expressions. + dynamic + + + + + Enable record puns. + dynamic + + + + + Enable named wildcards. + dynamic + + + + + Enable support for negative literals. + dynamic + + + + + Disable support for n+k patterns. + dynamic + + + + + Deprecated, does nothing. nullary (no parameter) type classes are now enabled using . + dynamic + + + + + Enable support for 'fractional' integer literals. + dynamic + + + + + Enable overlapping instances. + dynamic + + + + + Enable overloaded lists. + + dynamic + + + + + Enable overloaded string literals. + + dynamic + + + + + Enable package-qualified imports. + dynamic + + + + + Enable parallel arrays. + Implies . + dynamic + + + + + Enable parallel list comprehensions. + Implied by . + dynamic + + + + + Enable partial type signatures. + dynamic + + + + + Enable pattern guards. + dynamic + + + + + Enable pattern synonyms. + dynamic + + + + + Enable kind polymorphism. + Implies . + dynamic + + + + + Enable polymorphic components for data constructors. + dynamic, synonym for + + + + + Enable postfix operators. + dynamic + + + + + Enable quasiquotation. + dynamic + + + + + Enable rank-2 types. + dynamic, synonym for + + + + + Enable rank-N types. + Implied by . + dynamic + + + + + Employ rebindable syntax. + Implies . + dynamic + + + + + Enable record wildcards. + Implies . + dynamic + + + + + Enable recursive do (mdo) notation. + dynamic + + + + + (deprecated) Relaxed checking for + mutually-recursive polymorphic functions. + dynamic + + + + + Enable role annotations. + dynamic + + + + + Enable the Safe Haskell Safe mode. + dynamic + + + + + Enable lexically-scoped type variables. + + dynamic + + + + + Enable standalone deriving. + dynamic + + + + + Enable Template Haskell. + dynamic + + + + + Disable support for traditional record syntax (as supported by Haskell 98) C {f = x} + dynamic + + + + + Enable generalised list comprehensions. + dynamic + + + + + Enable the Safe Haskell Trustworthy mode. + dynamic + + + + + Enable tuple sections. + dynamic + + + + + Enable type families. + Implies , + and . + dynamic + + + + + Enable type operators. + Implies . + dynamic + + + + + Enable type synonyms in instance heads. + Implied by . + dynamic + + + + + Enable unboxed tuples. + dynamic + + + + + Enable undecidable instances. + dynamic + + + + + Enable unicode syntax. + dynamic + + + + + Enable unlifted FFI types. + dynamic + + + + + Enable Safe Haskell Unsafe mode. + dynamic + + + + + Enable view patterns. + dynamic + + + + + + + + + Warnings + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + enable normal warnings + dynamic + + + + + disable all warnings + dynamic + - + + + + enable almost all warnings (details in ) + dynamic + + + + + make warnings fatal + dynamic + -Wwarn + + + + make warnings non-fatal + dynamic + -Werror + + + + + + Turn type errors into warnings, + deferring the error until runtime. Implies + . + + dynamic + + + + + + + Convert typed hole errors + into warnings, deferring the + error until runtime. Implied by + . See also + . + + dynamic + + + + + + Make suggestions for mis-spelled names. + dynamic + + + + + + warn about uses of commandline flags that are deprecated + dynamic + + + + + + warn when a constraint appears duplicated in a type signature + dynamic + + + + + + warn when an entity is exported multiple times + dynamic + + + + + + warn when a .hi file in the + current directory shadows a library + dynamic + + + + + + warn about uses of Prelude numeric conversions that are probably + the identity (and hence could be omitted) + dynamic + + + + + + warn when the Prelude is implicitly imported + dynamic + + + + + + warn when a pattern match could fail + dynamic + + + + + + warn when a pattern match in a lambda expression or pattern binding could fail + dynamic + + + + + + warn when a record update could fail + dynamic + + + + + + (deprecated) warn when a pattern binding looks lazy but must be strict + dynamic + + + + + + warn when fields of a record are uninitialised + dynamic + + + + + + warn when an import declaration does not explicitly + list all the names brought into scope + dynamic + + + + + + warn when class methods are undefined + dynamic + + + + + + warn about top-level functions without signatures + dynamic + + + + + + warn about top-level functions without signatures, only if they are exported. takes precedence over -fwarn-missing-signatures + dynamic + + + + + + warn about polymorphic local bindings without signatures + dynamic + + + + + + warn when the Monomorphism Restriction is applied + dynamic + + + + + + warn when names are shadowed + dynamic + + + + + + warn when the module contains orphan instance declarations + or rewrite rules + dynamic + + + + + + warn about overlapping patterns + dynamic + + + + + + warn if there are tabs in the source file + dynamic + + + + + + warn when defaulting happens + dynamic + + + + + + warn about uses of pragmas that GHC doesn't recognise + dynamic + + + + + + warn if promoted constructors are not ticked + dynamic + + + + + + warn about bindings that are unused + dynamic + + + + + + warn about unnecessary imports + dynamic + + + + + + warn about variables in patterns that aren't used + dynamic + + + + + + warn about do bindings that appear to throw away values of types other than () + dynamic + + + + + + warn about do bindings that appear to throw away monadic values that you should have bound instead + dynamic + + + + + + warn if the module being compiled is regarded to be unsafe. + Should be used to check the safety status of modules when using safe + inference. Works on all module types, even those using explicit + Safe Haskell modes (such as + ) and so can be used to have the + compiler check any assumptions made. + dynamic + + + + + + warn if the module being compiled is regarded to be safe. + Should be used to check the safety status of modules when using safe + inference. Works on all module types, even those using explicit + Safe Haskell modes (such as + ) and so can be used to have the + compiler check any assumptions made. + dynamic + + + + + + warn if the module being compiled is marked as + but it could instead be marked as + , a more informative bound. Can be used to + detect once a Safe Haskell bound can be improved as dependencies + are updated. + dynamic + + + + + + warn about uses of functions & types that have warnings or deprecated pragmas + dynamic + + + + + + (deprecated) warn on definitions conflicting with the Applicative-Monad Proposal (AMP) + dynamic + + + + + + + Report warnings when typed hole + errors are deferred until + runtime. See . + + dynamic + + + + + + + warn about holes in partial type signatures when + is enabled. Not + applicable when is not + enabled, in which case errors are generated for such holes. + See . + + dynamic + + + + + + + warn when encountering a request to derive an instance of + class Typeable. As of GHC 7.10, such + declarations are unnecessary and are ignored by the compiler + because GHC has a custom solver for discharging this type of + constraint. + + dynamic + + + + + + + + + + + Optimisation levels + + These options are described in more detail in + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Disable optimisations (default) + dynamic + + + + or + Enable level 1 optimisations + dynamic + + + + + Enable level 2 optimisations + dynamic + + + + + Enable level 2 optimisations, set + and . + dynamic + - + + + + + + See for a list of optimisations enabled on level 1 and level 2. + + + + Individual optimisations + + These options are described in more detail in . + If a flag is implied by then it is also implied by + (unless flag description explicitly says otherwise). + If a flag is implied by only then the flag is not + implied by and . + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Enable call-arity optimisation. Implied by . + dynamic + + + + + + Enable case-merging. Implied by . + dynamic + + + + + + Enable Cmm common block elimination. Implied by . + dynamic + + + + + + Enable Cmm sinking. Implied by . + dynamic + + + + + + Switch off CPR analysis in the demand analyser. + static + - + + + + + Enable common sub-expression elimination. Implied by . + dynamic + + + + + + Make dictionary-valued expressions seem cheap to the optimiser. + dynamic + + + + + + Make dictionaries strict + dynamic + + + + + + + Use a special demand transformer for dictionary selectors. + Always enabled by default. + + dynamic + + + + + + Enable eta-reduction. Implied by . + dynamic + + + + + + Enable lambda eta-expansion. Always enabled by default. + dynamic + + + + + + Turn on eager blackholing + dynamic + - + + + + + Switch on all rewrite rules (including rules + generated by automatic specialisation of overloaded functions). + Implied by . + dynamic + + + + + + Enable excess intermediate precision + dynamic + + + + + + Expose all unfoldings, even for very large or recursive functions. + dynamic + + + + + + Turn on the float-in transformation. Implied by . + dynamic + + + + + + Turn on full laziness (floating bindings outwards). Implied by . + dynamic + + + + + + Allow worker-wrapper to convert a function closure into a + thunk if the function does not use any of its arguments. Off by + default. + dynamic + + + + + + Ignore assertions in the source. Implied by . + dynamic + + + + + + Ignore pragmas in interface files. Implied by only. + dynamic + + + + + + Run demand analysis again, at the end of the simplification + pipeline + dynamic + + + + + + Turn on the liberate-case transformation. Implied by . + dynamic + -fno-liberate-case + + + + =n + Set the size threshold for the liberate-case transformation to n (default: 2000) + dynamis + + + + + + Turn saturated self-recursive tail-calls into local jumps in the generated assembly. + Implied by . + dynamic + + + + + =n + Set the maximum size of inline array allocations to + n bytes (default: 128). GHC + will allocate non-pinned arrays of statically known size + in the current nursery block if they're no bigger than + n bytes, ignoring GC overheap. + This value should be quite a bit smaller than the block + size (typically: 4096). + dynamic + - + + + + + =n + + Inline memcpy calls if they would generate no more + than n pseudo instructions + (default: 32). + + dynamic + - + + + + + =n + + Inline memset calls if they would generate no more + than n pseudo instructions + (default: 32). + + dynamic + - + + + + + Set the maximum number of bindings to display in type error messages (default 6). + dynamic + + + + + + Set the max iterations for the simplifier (default 4). + dynamic + - + + + + + If a worker has that many arguments, none will be + unpacked anymore (default: 10) + dynamic + - + + + + + Turn off the coercion optimiser + static + - + + + + + Turn off pre-inlining + dynamic + - + + + + + Turn off the "state hack" whereby any lambda with a real-world state token + as argument is considered to be single-entry. Hence OK to inline things inside it. + static + - + + + + + Don't generate interface pragmas. Implied by only. + dynamic + + + + + + Omit heap checks when no allocation is being performed. + dynamic + + + + + + Make GHC be more precise about its treatment of bottom (but see also + ). In particular, GHC will not + eta-expand through a case expression. + dynamic + + + + + + Use the graph colouring register allocator for register allocation + in the native code generator. Implied by . + dynamic + + + + + + Use the iterative coalescing graph colouring register allocator + in the native code generator. + dynamic + + + + + + Set the number of phases for the simplifier (default 2). + Ignored with . + dynamic + - + + + + + Set the percentage factor for simplifier ticks (default 100) + dynamic + - + + + + + Turn on the SpecConstr transformation. Implied by . + dynamic + + + + + =n + Set to n (default: 3) the maximum number of + specialisations that will be created for any one function + by the SpecConstr transformation + dynamic + + + + + =n + Set the size threshold for the SpecConstr transformation + to n (default: 2000) + dynamic + + + + + + Turn on specialisation of overloaded functions. Implied by . + dynamic + + + + + + Turn on the static argument transformation. + dynamic + + + + + + Turn on strictness analysis. Implied by . + dynamic + + + + + =n + Run an additional strictness analysis before simplifier + phase n + dynamic + - + + + + + Flatten strict constructor fields with a + pointer-sized representation. Implied by . + dynamic + + + + + + Flatten strict constructor fields + dynamic + + + + + + Tweak unfolding settings. Default: 750 + dynamic + - + + + + + Tweak unfolding settings. Default: 30 + dynamic + - + + + + + Tweak unfolding settings. Default: 60 + dynamic + - + + + + + Tweak unfolding settings. Default: 1.5 + dynamic + - + + + + + Tweak unfolding settings. Default: 60 + dynamic + - + + + + + Enable vectorisation avoidance. Always enabled by default. + dynamic + + + + + + Enable vectorisation of nested data parallelism + dynamic + + + + + + + + + + Profiling options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Turn on profiling + dynamic + - + + + + Auto-add SCCs to all bindings + not marked INLINE + dynamic + + + + + Auto-add SCCs to all top-level + bindings not marked INLINE + dynamic + + + + + Auto-add SCCs to all exported + bindings not marked INLINE + dynamic + + + + + Auto-add SCCs to all CAFs + dynamic + + + + + Do not collect entry counts + dynamic + + + + + Turn on ticky-ticky profiling + dynamic + - + + + + + + + + Program coverage options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Turn on Haskell program coverage instrumentation + dynamic + + + + + Directory to deposit .mix files during compilation (default is .hpc) + dynamic + + + + + + + + + Haskell pre-processor options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + + Enable the use of a pre-processor + (set with ) + + dynamic + - + + + + + + + + C pre-processor options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Run the C pre-processor on Haskell source files + dynamic + - + + + symbol=value + Define a symbol in the C pre-processor + dynamic + symbol + + + symbol + Undefine a symbol in the C pre-processor + dynamic + - + + + dir + Add dir to the + directory search list for #include files + dynamic + - + + + + + + + + Code generation options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Use the native code + generator + dynamic + -fllvm + + + + Compile using the LLVM code + generator + dynamic + -fasm + + + + Omit code generation + dynamic + - + + + + Always write interface files + dynamic + - + + + + Generate byte-code + dynamic + - + + + + Generate object code + dynamic + - + + + + + + + + Linking options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Generate a shared library (as opposed to an executable) + dynamic + - + + + + On Darwin/OS X/iOS only, generate a standalone static library + (as opposed to an executable). + This is the usual way to compile for iOS. + + dynamic + - + + + + Generate position-independent code (where available) + dynamic + - + + + + Use dynamic Haskell libraries (if available) + dynamic + - + + + + Build dynamic object files as well as static object files during compilation + dynamic + - + + + + Set the output path for the dynamically linked objects + dynamic + - + + + + Set the output suffix for dynamic object files + dynamic + - + + + + Selects one of a number of modes for finding shared + libraries at runtime. + dynamic + - + + + name + On Darwin/OS X/iOS only, link in the framework name. + This option corresponds to the option for Apple's Linker. + dynamic + - + + + name + On Darwin/OS X/iOS only, add dir to the list of + directories searched for frameworks. + This option corresponds to the option for Apple's Linker. + dynamic + - + + + lib + Link in library lib + dynamic + - + + + dir + Add dir to the list of + directories searched for libraries + dynamic + - + + + + Set main module and function + dynamic + - + + + + DLL-creation mode (Windows only) + dynamic + - + + + + Don't assume this program contains main + dynamic + - + + + , + Control whether the RTS behaviour can be tweaked via command-line + flags and the GHCRTS environment + variable. Using none means no RTS flags can be given; some means only a minimum of safe options can be given (the default), and all (or no argument at all) means that all RTS flags are permitted. + dynamic + - + + + + Set the default RTS options to + opts. + dynamic + - + + + + Omit linking + dynamic + - + + + + Split objects (for libraries) + dynamic + - + + + + Use static Haskell libraries + dynamic + - + + + + Use the threaded runtime + dynamic + - + + + + Use the debugging runtime + dynamic + - + + + + For linking, this simply implies ; + see . + dynamic + - + + + + Enable runtime event tracing + dynamic + - + + + + Do not generate a manifest file (Windows only) + dynamic + - + + + + Do not embed the manifest in the executable (Windows only) + dynamic + - + + + + Don't generate an import library for a DLL (Windows only) + dynamic + - + + + path + Set the install name (via -install_name passed to Apple's + linker), specifying the full install path of the library file. Any libraries + or executables that link with it later will pick up that path as their + runtime search location for it. (Darwin/OS X only) + dynamic + - + + + + This instructs the linker to add all symbols, not only used ones, to the + dynamic symbol table. Currently Linux and Windows/MinGW32 only. + This is equivalent to using -optl -rdynamic on Linux, + and -optl -export-all-symbols on Windows. + dynamic + - + + + + + + + + Plugin options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + =module + Load a plugin exported by a given module + dynamic + - + + + =module:args + Give arguments to a plugin module; module must be specified with + dynamic + - + + + + + + + + + Replacing phases + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + cmd + Use cmd as the literate pre-processor + dynamic + - + + + cmd + Use cmd as the C + pre-processor (with only) + dynamic + - + + + cmd + Use cmd as the C compiler + dynamic + - + + + cmd + Use cmd as the LLVM optimiser + dynamic + - + + + cmd + Use cmd as the LLVM compiler + dynamic + - + + + cmd + Use cmd as the splitter + dynamic + - + + + cmd + Use cmd as the assembler + dynamic + - + + + cmd + Use cmd as the linker + dynamic + - + + + cmd + Use cmd as the DLL generator + dynamic + - + + + cmd + Use cmd as the pre-processor + (with only) + dynamic + - + + + cmd + Use cmd as the program for + embedding manifests on Windows. + dynamic + - + + + cmd + Use cmd as the command for libtool + (with only). + dynamic + - + + + cmd + Use cmd as the command for readelf + (part of Unix binutils) + dynamic + - + + + + + + + + + + + + + + + + + + Forcing options to particular phases + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + option + pass option to the literate pre-processor + dynamic + - + + + option + pass option to cpp (with + only) + dynamic + - + + + option + pass option to the + custom pre-processor + dynamic + - + + + option + pass option to the C compiler + dynamic + - + + + option + pass option to the LLVM optimiser + dynamic + - + + + option + pass option to the LLVM compiler + dynamic + - + + + option + pass option to the assembler + dynamic + - + + + option + pass option to the linker + dynamic + - + + + option + pass option to the DLL generator + dynamic + - + + + option + pass option to windres. + dynamic + - + + + + + + + + Platform-specific options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + (x86 only) Use SSE2 for floating point + dynamic + - + + + + + + + + + Compiler debugging options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + Turn on internal sanity checking + dynamic + - + + + + Dump to files instead of stdout + dynamic + - + + + + Dump assembly + dynamic + - + + + + Dump interpreter byte code + dynamic + - + + + + Dump C-- output + dynamic + - + + + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline + dynamic + - + + + + Dump CSE output + dynamic + - + + + + Dump deriving output + dynamic + - + + + + Dump desugarer output + dynamic + - + + + + Dump foreign export stubs + dynamic + - + + + + Dump after instrumentation for program coverage + dynamic + - + + + + Dump inlining info + dynamic + - + + + + Dump LLVM intermediate code + dynamic + - + + + + Dump occurrence analysis output + dynamic + - + + + + Dump the results of C-- to C-- optimising passes + dynamic + - + + + + Dump parse tree + dynamic + - + + + + Dump prepared core + dynamic + - + + + + Dump renamer output + dynamic + - + + + + Dump rule firing info + dynamic + - + + + + Dump detailed rule firing info + dynamic + - + + + + Dump rules + dynamic + - + + + + Dump vectoriser input and output + dynamic + - + + + + Dump final simplifier output + dynamic + - + + + + Dump output from each simplifier iteration + dynamic + - + + + + Dump specialiser output + dynamic + - + + + + Dump TH spliced expressions, and what they evaluate to + dynamic + - + + + + Dump final STG + dynamic + - + + + + Dump strictness analyser output + dynamic + - + + + + Dump strictness signatures + dynamic + - + + + + Dump typechecker output + dynamic + - + + + + Show evaluated TH declarations in a .th.hs file + dynamic + - + + + + Dump type signatures + dynamic + - + + + + Dump worker-wrapper output + dynamic + - + + + + Trace interface files + dynamic + - + + + + Trace typechecker + dynamic + - + + + + Trace vectoriser + dynamic + - + + + + Trace renamer + dynamic + - + + + + Renamer stats + dynamic + - + + + + Dump simplifier stats + dynamic + - + + + + Suppress unsolicited debugging output + static + - + + + + Turn on debug printing (more verbose) + static + - + + + + Set the depth for printing expressions in error msgs + dynamic + - + + + + Set the width of debugging output. For example + dynamic + - + + + + Print single alternative case expressions as strict lets. + dynamic + - + + + + In core dumps, suppress everything (except for uniques) that is suppressible. + dynamic + - + + + + Suppress the printing of uniques in debug output (easier to use diff) + dynamic + - + + + + Suppress extended information about identifiers where they are bound + dynamic + - + + + + Suppress the printing of module qualification prefixes + dynamic + - + + + + Suppress type signatures + dynamic + - + + + + Suppress type applications + dynamic + - + + + + Suppress the printing of coercions in Core dumps to make them shorter + dynamic + - + + + + Dump haskell source stats + dynamic + - + + + + C-- pass sanity checking + dynamic + - + + + + STG pass sanity checking + dynamic + - + + + + Dump STG stats + dynamic + - + + + + Show output from each core-to-core pass + dynamic + - + + + + Show output from each STG-to-STG pass + dynamic + - + + + + Print out each pass name as it happens + dynamic + - + + + + Show statistics for fast string usage when finished + dynamic + - + + + + Report sites with rules that could have fired but didn't. + Takes a string argument. + dynamic + - + + + + + + + + Misc compiler options + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + + When compiling with --make, compile N modules in parallel. + dynamic + - + + + + Don't complain about .hi file mismatches + dynamic + - + + + + Set simplification history size + dynamic + - + + + + Do not use the load/store the GHCi command history from/to ghci_history. + dynamic + - + + + + Turn off the GHCi sandbox. Means computations are run in the main thread, rather than a forked thread. + dynamic + - + + + + + + + + + + + diff --git a/docs/users_guide/ghc.mk b/docs/users_guide/ghc.mk new file mode 100644 index 00000000..eb7eb6a6 --- /dev/null +++ b/docs/users_guide/ghc.mk @@ -0,0 +1,37 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +docs/users_guide_GENERATED_DOCBOOK_SOURCES := \ + docs/users_guide/users_guide.xml \ + docs/users_guide/what_glasgow_exts_does.gen.xml + +# sort remove duplicates +docs/users_guide_DOCBOOK_SOURCES := \ + $(sort $(docs/users_guide_GENERATED_DOCBOOK_SOURCES) \ + $(wildcard docs/users_guide/*.xml) \ + $(basename $(wildcard docs/users_guide/*.xml.in))) + +$(docs/users_guide_GENERATED_DOCBOOK_SOURCES): %.xml: $(mkUserGuidePart_INPLACE) + $(mkUserGuidePart_INPLACE) $@ + +$(eval $(call docbook,docs/users_guide,users_guide)) + +$(eval $(call clean-target,docs/users_guide,gen,$(docs/users_guide_GENERATED_DOCBOOK_SOURCES))) + +html_docs/users_guide : docs/users_guide/users_guide/prof_scc.eps + +docs/users_guide/users_guide/prof_scc.eps : \ + docs/users_guide/prof_scc.eps \ + docs/users_guide/users_guide/index.html + $(CP) $< $@ +# dep. on d/u/u/index.html is to make sure that the d/u/u dir is created first + diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml new file mode 100644 index 00000000..6e09f3a1 --- /dev/null +++ b/docs/users_guide/ghci.xml @@ -0,0 +1,3672 @@ + + + Using GHCi + GHCi + interpreterGHCi + interactiveGHCi + + GHCi + The ‘i’ stands for “Interactive” + + is GHC's interactive environment, in which Haskell expressions can + be interactively evaluated and programs can be interpreted. If + you're familiar with HugsHugs + , then you'll be right at home with GHCi. However, GHCi + also has support for interactively loading compiled code, as well as + supporting allexcept foreign export, at the moment + the language extensions that GHC provides. + FFIGHCi support + Foreign Function + InterfaceGHCi support + GHCi also includes an interactive debugger (see ). + + + Introduction to GHCi + + Let's start with an example GHCi session. You can fire up + GHCi with the command ghci: + + +$ ghci +GHCi, version 6.12.1: http://www.haskell.org/ghc/ :? for help +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +Prelude> + + + There may be a short pause while GHCi loads the prelude and + standard libraries, after which the prompt is shown. As the banner + says, you can type :? to see the list of + commands available, and a half line description of each of them. + We'll explain most of these commands as we go along, and there is + complete documentation for all the commands in + . + + Haskell expressions can be typed at the prompt: + promptGHCi + + + +Prelude> 1+2 +3 +Prelude> let x = 42 in x / 9 +4.666666666666667 +Prelude> + + + GHCi interprets the whole line as an expression to evaluate. + The expression may not span several lines - as soon as you press enter, + GHCi will attempt to evaluate it. + + In Haskell, a let expression is followed + by in. However, in GHCi, since the expression + can also be interpreted in the IO monad, + a let binding with no accompanying + in statement can be signalled by an empty line, + as in the above example. + + + + Loading source files + + Suppose we have the following Haskell source code, which we + place in a file Main.hs: + + +main = print (fac 20) + +fac 0 = 1 +fac n = n * fac (n-1) + + + You can save Main.hs anywhere you like, + but if you save it somewhere other than the current + directoryIf you started up GHCi from the command + line then GHCi's current directory is the same as the current + directory of the shell from which it was started. If you started + GHCi from the “Start” menu in Windows, then the + current directory is probably something like + C:\Documents and Settings\user + name. then we will + need to change to the right directory in GHCi: + + +Prelude> :cd dir + + + where dir is the directory (or + folder) in which you saved Main.hs. + + To load a Haskell source file into GHCi, use the + :load command: + :load + + +Prelude> :load Main +Compiling Main ( Main.hs, interpreted ) +Ok, modules loaded: Main. +*Main> + + + GHCi has loaded the Main module, and the + prompt has changed to “*Main>” to + indicate that the current context for expressions typed at the + prompt is the Main module we just loaded (we'll + explain what the * means later in ). So we can now type expressions involving + the functions from Main.hs: + + +*Main> fac 17 +355687428096000 + + + Loading a multi-module program is just as straightforward; + just give the name of the “topmost” module to the + :load command (hint: :load + can be abbreviated to :l). The topmost module + will normally be Main, but it doesn't have to + be. GHCi will discover which modules are required, directly or + indirectly, by the topmost module, and load them all in dependency + order. + + + Modules vs. filenames + modulesand filenames + filenamesof modules + + Question: How does GHC find the filename which contains + module M? Answer: it looks for the + file M.hs, or + M.lhs. This means + that for most modules, the module name must match the filename. + If it doesn't, GHCi won't be able to find it. + + There is one exception to this general rule: when you load + a program with :load, or specify it when you + invoke ghci, you can give a filename rather + than a module name. This filename is loaded if it exists, and + it may contain any module you like. This is particularly + convenient if you have several Main modules + in the same directory and you can't call them all + Main.hs. + + The search path for finding source files is specified with + the option on the GHCi command line, like + so: +ghci -idir1:...:dirn + + or it can be set using the :set command + from within GHCi (see )Note that in + GHCi, and mode, the + option is used to specify the search path for + source files, whereas in standard + batch-compilation mode the option is used to + specify the search path for interface files, see . + + One consequence of the way that GHCi follows dependencies + to find modules to load is that every module must have a source + file. The only exception to the rule is modules that come from + a package, including the Prelude and standard + libraries such as IO and + Complex. If you attempt to load a module for + which GHCi can't find a source file, even if there are object + and interface files for the module, you'll get an error + message. + + + + Making changes and recompilation + :reload + + If you make some changes to the source code and want GHCi + to recompile the program, give the :reload + command. The program will be recompiled as necessary, with GHCi + doing its best to avoid actually recompiling modules if their + external dependencies haven't changed. This is the same + mechanism we use to avoid re-compiling modules in the batch + compilation setting (see ). + + + + + Loading compiled code + compiled codein GHCi + + When you load a Haskell source module into GHCi, it is + normally converted to byte-code and run using the interpreter. + However, interpreted code can also run alongside compiled code in + GHCi; indeed, normally when GHCi starts, it loads up a compiled + copy of the base package, which contains the + Prelude. + + Why should we want to run compiled code? Well, compiled + code is roughly 10x faster than interpreted code, but takes about + 2x longer to produce (perhaps longer if optimisation is on). So + it pays to compile the parts of a program that aren't changing + very often, and use the interpreter for the code being actively + developed. + + When loading up source modules with :load, + GHCi normally looks for any corresponding compiled object files, + and will use one in preference to interpreting the source if + possible. For example, suppose we have a 4-module program + consisting of modules A, B, C, and D. Modules B and C both import + D only, and A imports both B & C: + + A + / \ + B C + \ / + D + + We can compile D, then load the whole program, like this: + +Prelude> :! ghc -c -dynamic D.hs +Prelude> :load A +Compiling B ( B.hs, interpreted ) +Compiling C ( C.hs, interpreted ) +Compiling A ( A.hs, interpreted ) +Ok, modules loaded: A, B, C, D. +*Main> + + + In the messages from the compiler, we see that there is no line + for D. This is because + it isn't necessary to compile D, + because the source and everything it depends on + is unchanged since the last compilation. + + Note the -dynamic flag to GHC: GHCi uses + dynamically-linked object code (if you are on a platform that + supports it), and so in order to use compiled code with GHCi it + must be compiled for dynamic linking. + + At any time you can use the command + :show modules + to get a list of the modules currently loaded + into GHCi: + + +*Main> :show modules +D ( D.hs, D.o ) +C ( C.hs, interpreted ) +B ( B.hs, interpreted ) +A ( A.hs, interpreted ) +*Main> + + If we now modify the source of D (or pretend to: using the Unix + command touch on the source file is handy for + this), the compiler will no longer be able to use the object file, + because it might be out of date: + + +*Main> :! touch D.hs +*Main> :reload +Compiling D ( D.hs, interpreted ) +Ok, modules loaded: A, B, C, D. +*Main> + + + Note that module D was compiled, but in this instance + because its source hadn't really changed, its interface remained + the same, and the recompilation checker determined that A, B and C + didn't need to be recompiled. + + So let's try compiling one of the other modules: + + +*Main> :! ghc -c C.hs +*Main> :load A +Compiling D ( D.hs, interpreted ) +Compiling B ( B.hs, interpreted ) +Compiling C ( C.hs, interpreted ) +Compiling A ( A.hs, interpreted ) +Ok, modules loaded: A, B, C, D. + + + We didn't get the compiled version of C! What happened? + Well, in GHCi a compiled module may only depend on other compiled + modules, and in this case C depends on D, which doesn't have an + object file, so GHCi also rejected C's object file. Ok, so let's + also compile D: + + +*Main> :! ghc -c D.hs +*Main> :reload +Ok, modules loaded: A, B, C, D. + + + Nothing happened! Here's another lesson: newly compiled + modules aren't picked up by :reload, only + :load: + + +*Main> :load A +Compiling B ( B.hs, interpreted ) +Compiling A ( A.hs, interpreted ) +Ok, modules loaded: A, B, C, D. + + + The automatic loading of object files can sometimes lead to + confusion, because non-exported top-level definitions of a module + are only available for use in expressions at the prompt when the + module is interpreted (see ). For + this reason, you might sometimes want to force GHCi to load a + module using the interpreter. This can be done by prefixing + a * to the module name or filename when + using :load, for example + + +Prelude> :load *A +Compiling A ( A.hs, interpreted ) +*A> + + +When the * is used, GHCi ignores any + pre-compiled object code and interprets the module. If you have + already loaded a number of modules as object code and decide that + you wanted to interpret one of them, instead of re-loading the whole + set you can use :add *M to specify that you want + M to be interpreted (note that this might cause + other modules to be interpreted too, because compiled modules cannot + depend on interpreted ones). + +To always compile everything to object code and never use the + interpreter, use the -fobject-code option (see + ). + + HINT: since GHCi will only use a compiled object file if it + can be sure that the compiled version is up-to-date, a good technique + when working on a large program is to occasionally run + ghc --make to compile the whole project (say + before you go for lunch :-), then continue working in the + interpreter. As you modify code, the changed modules will be + interpreted, but the rest of the project will remain + compiled. + + + + Interactive evaluation at the prompt + + When you type an expression at the prompt, GHCi immediately + evaluates and prints the result: + +Prelude> reverse "hello" +"olleh" +Prelude> 5+5 +10 + + + +I/O actions at the prompt + +GHCi does more than simple expression evaluation at the prompt. +If you enter an expression of type IO a for some + a, then GHCi executes it + as an IO-computation. + +Prelude> "hello" +"hello" +Prelude> putStrLn "hello" +hello + +This works even if the type of the expression is more general, +provided it can be instantiated to IO a. For example + +Prelude> return True +True + +Furthermore, GHCi will print the result of the I/O action if (and only +if): + + The result type is an instance of Show. + The result type is not + (). + +For example, remembering that putStrLn :: String -> IO (): + +Prelude> putStrLn "hello" +hello +Prelude> do { putStrLn "hello"; return "yes" } +hello +"yes" + + + + + Using <literal>do-</literal>notation at the prompt + do-notationin GHCi + statementsin GHCi + + GHCi actually accepts statements + rather than just expressions at the prompt. This means you can + bind values and functions to names, and use them in future + expressions or statements. + + The syntax of a statement accepted at the GHCi prompt is + exactly the same as the syntax of a statement in a Haskell + do expression. However, there's no monad + overloading here: statements typed at the prompt must be in the + IO monad. + +Prelude> x <- return 42 +Prelude> print x +42 +Prelude> + + The statement x <- return 42 means + “execute return 42 in the + IO monad, and bind the result to + x”. We can then use + x in future statements, for example to print + it as we did above. + + If is set then + GHCi will print the result of a statement if and only if: + + + The statement is not a binding, or it is a monadic binding + (p <- e) that binds exactly one + variable. + + + The variable's type is not polymorphic, is not + (), and is an instance of + Show + + + . + + + Of course, you can also bind normal non-IO expressions + using the let-statement: + +Prelude> let x = 42 +Prelude> x +42 +Prelude> + + Another important difference between the two types of binding + is that the monadic bind (p <- e) is + strict (it evaluates e), + whereas with the let form, the expression + isn't evaluated immediately: + +Prelude> let x = error "help!" +Prelude> print x +*** Exception: help! +Prelude> + + + Note that let bindings do not automatically + print the value bound, unlike monadic bindings. + + Hint: you can also use let-statements + to define functions at the prompt: + +Prelude> let add a b = a + b +Prelude> add 1 2 +3 +Prelude> + + However, this quickly gets tedious when defining functions + with multiple clauses, or groups of mutually recursive functions, + because the complete definition has to be given on a single line, + using explicit braces and semicolons instead of layout: + +Prelude> let { f op n [] = n ; f op n (h:t) = h `op` f op n t } +Prelude> f (+) 0 [1..3] +6 +Prelude> + + To alleviate this issue, GHCi commands can be split over + multiple lines, by wrapping them in :{ and + :} (each on a single line of its own): + +Prelude> :{ +Prelude| let { g op n [] = n +Prelude| ; g op n (h:t) = h `op` g op n t +Prelude| } +Prelude| :} +Prelude> g (*) 1 [1..3] +6 + + Such multiline commands can be used with any GHCi command, + and the lines between :{ and + :} are simply merged into a single line for + interpretation. That implies that each such group must form a single + valid command when merged, and that no layout rule is used. + The main purpose of multiline commands is not to replace module + loading but to make definitions in .ghci-files (see ) more readable and maintainable. + + Any exceptions raised during the evaluation or execution + of the statement are caught and printed by the GHCi command line + interface (for more information on exceptions, see the module + Control.Exception in the libraries + documentation). + + Every new binding shadows any existing bindings of the + same name, including entities that are in scope in the current + module context. + + WARNING: temporary bindings introduced at the prompt only + last until the next :load or + :reload command, at which time they will be + simply lost. However, they do survive a change of context with + :module: the temporary bindings just move to + the new location. + + HINT: To get a list of the bindings currently in scope, use the + :show bindings command: + + +Prelude> :show bindings +x :: Int +Prelude> + + HINT: if you turn on the +t option, + GHCi will show the type of each variable bound by a statement. + For example: + +t + +Prelude> :set +t +Prelude> let (x:xs) = [1..] +x :: Integer +xs :: [Integer] + + + + + + Multiline input + + Apart from the :{ ... :} syntax for + multi-line input mentioned above, GHCi also has a multiline + mode, enabled by :set +m, + :set +m + in which GHCi detects automatically when the current statement + is unfinished and allows further lines to be added. A + multi-line input is terminated with an empty line. For example: + + +Prelude> :set +m +Prelude> let x = 42 +Prelude| + + + Further bindings can be added to + this let statement, so GHCi indicates that + the next line continues the previous one by changing the + prompt. Note that layout is in effect, so to add more bindings + to this let we have to line them up: + + +Prelude> :set +m +Prelude> let x = 42 +Prelude| y = 3 +Prelude| +Prelude> + + + Explicit braces and semicolons can be used instead of + layout, as usual: + + +Prelude> do { +Prelude| putStrLn "hello" +Prelude| ;putStrLn "world" +Prelude| } +hello +world +Prelude> + + + Note that after the closing brace, GHCi knows that the + current statement is finished, so no empty line is required. + + Multiline mode is useful when entering monadic + do statements: + + +Control.Monad.State> flip evalStateT 0 $ do +Control.Monad.State| i <- get +Control.Monad.State| lift $ do +Control.Monad.State| putStrLn "Hello World!" +Control.Monad.State| print i +Control.Monad.State| +"Hello World!" +0 +Control.Monad.State> + + + During a multiline interaction, the user can interrupt and + return to the top-level prompt. + + +Prelude> do +Prelude| putStrLn "Hello, World!" +Prelude| ^C +Prelude> + + + + + Type, class and other declarations + + At the GHCi + prompt you can also enter any top-level Haskell declaration, + including data, type, newtype, class, instance, deriving, + and foreign declarations. For + example: + + +Prelude> data T = A | B | C deriving (Eq, Ord, Show, Enum) +Prelude> [A ..] +[A,B,C] +Prelude> :i T +data T = A | B | C -- Defined at <interactive>:2:6 +instance Enum T -- Defined at <interactive>:2:45 +instance Eq T -- Defined at <interactive>:2:30 +instance Ord T -- Defined at <interactive>:2:34 +instance Show T -- Defined at <interactive>:2:39 + + + As with ordinary variable bindings, later definitions shadow + earlier ones, so you can re-enter a declaration to fix a problem + with it or extend it. But there's a gotcha: when a new type + declaration shadows an older one, there might be other + declarations that refer to the old type. The thing to remember is + that the old type still exists, and these other declarations still + refer to the old type. However, while the old and the new type + have the same name, GHCi will treat them as distinct. For + example: + + +Prelude> data T = A | B +Prelude> let f A = True; f B = False +Prelude> data T = A | B | C +Prelude> f A + +<interactive>:2:3: + Couldn't match expected type `main::Interactive.T' + with actual type `T' + In the first argument of `f', namely `A' + In the expression: f A + In an equation for `it': it = f A +Prelude> + + + The old, shadowed, version of T is + displayed as main::Interactive.T by GHCi in + an attempt to distinguish it from the new T, + which is displayed as simply T. + + Class and type-family instance declarations are simply added to the list of available instances, + with one exception. Since you might want to re-define one, + a class or type-family instance replaces any earlier instance with + an identical head or left hand side (respectively). + (See .) + + + + What's really in scope at the prompt? + + When you type an expression at the prompt, what + identifiers and types are in scope? + GHCi provides a flexible + way to control exactly how the context for an expression is + constructed: + + + The :load, :add, + and :reload commands (). + + + The import declaration (). + + + The :module command (). + + + + The command :show imports will show a summary of which modules + contribute to the top-level scope. + + Hint: GHCi will tab-complete names that are in scope; for + example, if you run GHCi and type J<tab> + then GHCi will expand it to “Just ”. + + + + The effect of <literal>:load</literal> on what is in scope + + The :load, :add, and :reload + commands ( + and ) affect the top-level scope. + Let's start with the simple cases; when you start + GHCi the prompt looks like this: + +Prelude> + + which indicates that everything from the module + Prelude is currently in scope; the visible + identifiers are exactly those that would be visible in a Haskell + source file with no import + declarations. + + If we now load a file into GHCi, the prompt will change: + + +Prelude> :load Main.hs +Compiling Main ( Main.hs, interpreted ) +*Main> + + + The new prompt is *Main, which + indicates that we are typing expressions in the context of the + top-level of the Main module. Everything + that is in scope at the top-level in the module + Main we just loaded is also in scope at the + prompt (probably including Prelude, as long + as Main doesn't explicitly hide it). + + The syntax in the prompt + *module indicates + that it is the full top-level scope of + module that is contributing to the + scope for expressions typed at the prompt. Without the + *, just the exports of the module are + visible. + + NOTE: for technical reasons, GHCi can only support the + *-form for modules that are interpreted. + Compiled modules and package modules can only contribute their + exports to the current scope. To ensure that GHCi loads the + interpreted version of a module, add the * + when loading the module, e.g. :load *M. + + In general, after a :load command, an automatic + import is added to the scope for the most recently loaded + "target" module, in a *-form if possible. + For example, if you say :load foo.hs bar.hs + and bar.hs contains module + Bar, then the scope will be set to + *Bar if Bar is + interpreted, or if Bar is compiled it will be + set to Prelude Bar (GHCi automatically adds + Prelude if it isn't present and there aren't + any *-form modules). These + automatically-added imports can be seen with + :show imports: + + +Prelude> :load hello.hs +[1 of 1] Compiling Main ( hello.hs, interpreted ) +Ok, modules loaded: Main. +*Main> :show imports +:module +*Main -- added automatically +*Main> + + + and the automatically-added import is replaced the next time you + use :load, :add, or + :reload. It can also be removed by + :module as with normal imports. + + + + Controlling what is in scope with <literal>import</literal> + + We are not limited to a single module: GHCi can combine + scopes from multiple modules, in any mixture of + * and non-* forms. GHCi + combines the scopes from all of these modules to form the scope + that is in effect at the prompt. + + To add modules to the scope, use ordinary Haskell + import syntax: + + +Prelude> import System.IO +Prelude System.IO> hPutStrLn stdout "hello\n" +hello +Prelude System.IO> + + + The full Haskell import syntax is supported, including + hiding and as clauses. + The prompt shows the modules that are currently imported, but it + omits details about hiding, + as, and so on. To see the full story, use + :show imports: + + +Prelude> import System.IO +Prelude System.IO> import Data.Map as Map +Prelude System.IO Map> :show imports +import Prelude -- implicit +import System.IO +import Data.Map as Map +Prelude System.IO Map> + + + Note that the Prelude import is marked + as implicit. It can be overridden with an explicit + Prelude import, just like in a Haskell + module. + + With multiple modules in scope, especially multiple + *-form modules, it is likely that name + clashes will occur. Haskell specifies that name clashes are + only reported when an ambiguous identifier is used, and GHCi + behaves in the same way for expressions typed at the + prompt. + + + + + Controlling what is in scope with the <literal>:module</literal> command + + Another way to manipulate the scope is to use the + :module command, whose syntax is this: + + +:module +|- *mod1 ... *modn + + + Using the + form of the + module commands adds modules to the current + scope, and - removes them. Without either + + or -, the current scope + is replaced by the set of modules specified. Note that if you + use this form and leave out Prelude, an + implicit Prelude import will be added + automatically. + + The :module command provides a way to do + two things that cannot be done with ordinary + import declarations: + + + :module supports the + * modifier on modules, which opens the + full top-level scope of a module, rather than just its + exports. + + + Imports can be removed from the + context, using the syntax :module -M. + The import syntax is cumulative (as in a + Haskell module), so this is the only way to subtract from + the scope. + + + + + + + Qualified names + + To make life slightly easier, the GHCi prompt also + behaves as if there is an implicit import + qualified declaration for every module in every + package, and every module currently loaded into GHCi. This + behaviour can be disabled with the flag . + + + + <literal>:module</literal> and + <literal>:load</literal> + + It might seem that :module/import and + :load/:add/:reload + do similar things: you can use both + to bring a module into scope. However, there is a very important + difference. GHCi is concerned with two sets of modules: + + + + The set of modules that are currently + loaded. This set is modified by + :load, :add and + :reload, and can be shown with + :show modules. + + + + The set of modules that are currently in + scope at the prompt. This set is modified by + import and :module, and + it is also modified automatically after + :load, :add, and + :reload, as described above. + The set of modules in scope can be shown with + :show imports. + + + + You can add a module to the scope (via :module + or import) + only if either (a) it is loaded, or + (b) it is a module from a package that GHCi knows about. + Using :module or import + to try bring into scope a non-loaded module may result + in the message “module M is not + loaded”. + + + + + The <literal>:main</literal> and <literal>:run</literal> commands + + + When a program is compiled and executed, it can use the + getArgs function to access the + command-line arguments. + However, we cannot simply pass the arguments to the + main function while we are testing in ghci, + as the main function doesn't take its + directly. + + + + Instead, we can use the :main command. + This runs whatever main is in scope, with + any arguments being treated the same as command-line arguments, + e.g.: + + + +Prelude> let main = System.Environment.getArgs >>= print +Prelude> :main foo bar +["foo","bar"] + + + + We can also quote arguments which contains characters like + spaces, and they are treated like Haskell strings, or we can + just use Haskell list syntax: + + + +Prelude> :main foo "bar baz" +["foo","bar baz"] +Prelude> :main ["foo", "bar baz"] +["foo","bar baz"] + + + + Finally, other functions can be called, either with the + -main-is flag or the :run + command: + + + +Prelude> let foo = putStrLn "foo" >> System.Environment.getArgs >>= print +Prelude> let bar = putStrLn "bar" >> System.Environment.getArgs >>= print +Prelude> :set -main-is foo +Prelude> :main foo "bar baz" +foo +["foo","bar baz"] +Prelude> :run bar ["foo", "bar baz"] +bar +["foo","bar baz"] + + + + + + The <literal>it</literal> variable + it + + + Whenever an expression (or a non-binding statement, to be + precise) is typed at the prompt, GHCi implicitly binds its value + to the variable it. For example: + +Prelude> 1+2 +3 +Prelude> it * 2 +6 + + What actually happens is that GHCi typechecks the + expression, and if it doesn't have an IO type, + then it transforms it as follows: an expression + e turns into + +let it = e; +print it + + which is then run as an IO-action. + + Hence, the original expression must have a type which is an + instance of the Show class, or GHCi will + complain: + + +Prelude> id + +<interactive>:1:0: + No instance for (Show (a -> a)) + arising from use of `print' at <interactive>:1:0-1 + Possible fix: add an instance declaration for (Show (a -> a)) + In the expression: print it + In a 'do' expression: print it + + + The error message contains some clues as to the + transformation happening internally. + + If the expression was instead of type IO a for + some a, then it will be + bound to the result of the IO computation, + which is of type a. eg.: + +Prelude> Time.getClockTime +Wed Mar 14 12:23:13 GMT 2001 +Prelude> print it +Wed Mar 14 12:23:13 GMT 2001 + + + The corresponding translation for an IO-typed + e is + +it <- e + + + + Note that it is shadowed by the new + value each time you evaluate a new expression, and the old value + of it is lost. + + + + + Type defaulting in GHCi + Type default + Show class + + Consider this GHCi session: + + ghci> reverse [] + + What should GHCi do? Strictly speaking, the program is ambiguous. show (reverse []) + (which is what GHCi computes here) has type Show a => String and how that displays depends + on the type a. For example: + + ghci> reverse ([] :: String) + "" + ghci> reverse ([] :: [Int]) + [] + + However, it is tiresome for the user to have to specify the type, so GHCi extends Haskell's type-defaulting + rules (Section 4.3.4 of the Haskell 2010 Report) as follows. The + standard rules take each group of constraints (C1 a, C2 a, ..., Cn + a) for each type variable a, and defaults the + type variable if + + + + The type variable a appears in no + other constraints + + + + + All the classes Ci are standard. + + + + + At least one of the classes Ci is + numeric. + + + + At the GHCi prompt, or with GHC if the + -XExtendedDefaultRules flag is given, + the following additional differences apply: + + + + Rule 2 above is relaxed thus: + All of the classes + Ci are single-parameter type classes. + + + + + Rule 3 above is relaxed this: + At least one of the classes Ci is + numeric, or is Show, + Eq, or + Ord. + + + + + The unit type () is added to the + start of the standard list of types which are tried when + doing type defaulting. + + + + The last point means that, for example, this program: + +main :: IO () +main = print def + +instance Num () + +def :: (Num a, Enum a) => a +def = toEnum 0 + + prints () rather than 0 as the + type is defaulted to () rather than + Integer. + + + The motivation for the change is that it means IO a + actions default to IO (), which in turn means that + ghci won't try to print a result when running them. This is + particularly important for printf, which has an + instance that returns IO a. + However, it is only able to return + undefined + (the reason for the instance having this type is so that printf + doesn't require extensions to the class system), so if the type defaults to + Integer then ghci gives an error when running a + printf. + + See also for how the monad of a computational + expression defaults to IO if possible. + + + + + Using a custom interactive printing function + [New in version 7.6.1] + By default, GHCi prints the result of expressions typed at the prompt + using the function System.IO.print. Its type + signature is Show a => a -> IO (), and it works by + converting the value to String using + show. + + + This is not ideal in certain cases, like when the output is long, or + contains strings with non-ascii characters. + + + The -interactive-print flag allows to specify any + function of type C a => a -> IO (), for some + constraint C, as the function for printing evaluated + expressions. The function can reside in any loaded module or any + registered package. + + + As an example, suppose we have following special printing module: + + module SpecPrinter where + import System.IO + + sprint a = putStrLn $ show a ++ "!" + + The sprint function adds an exclamation mark at the + end of any printed value. Running GHCi with the command: + + ghci -interactive-print=SpecPrinter.sprinter SpecPrinter + + will start an interactive session where values with be printed using + sprint: + + *SpecPrinter> [1,2,3] + [1,2,3]! + *SpecPrinter> 42 + 42! + + + + A custom pretty printing function can be used, for example, to format + tree-like and nested structures in a more readable way. + + + The -interactive-print flag can also be used when + running GHC in -e mode: + + % ghc -e "[1,2,3]" -interactive-print=SpecPrinter.sprint SpecPrinter + [1,2,3]! + + + + + + + The GHCi Debugger + debuggerin GHCi + + + GHCi contains a simple imperative-style debugger in which you can + stop a running computation in order to examine the values of + variables. The debugger is integrated into GHCi, and is turned on by + default: no flags are required to enable the debugging + facilities. There is one major restriction: breakpoints and + single-stepping are only available in interpreted modules; + compiled code is invisible to the debuggerNote that packages + only contain compiled code, so debugging a package requires + finding its source and loading that directly.. + + The debugger provides the following: + + + The ability to set a breakpoint on a + function definition or expression in the program. When the function + is called, or the expression evaluated, GHCi suspends + execution and returns to the prompt, where you can inspect the + values of local variables before continuing with the + execution. + + + Execution can be single-stepped: the + evaluator will suspend execution approximately after every + reduction, allowing local variables to be inspected. This is + equivalent to setting a breakpoint at every point in the + program. + + + Execution can take place in tracing + mode, in which the evaluator remembers each + evaluation step as it happens, but doesn't suspend execution until + an actual breakpoint is reached. When this happens, the history of + evaluation steps can be inspected. + + + Exceptions (e.g. pattern matching failure and + error) can be treated as breakpoints, to help + locate the source of an exception in the program. + + + + + There is currently no support for obtaining a “stack + trace”, but the tracing and history features provide a + useful second-best, which will often be enough to establish the + context of an error. For instance, it is possible to break + automatically when an exception is thrown, even if it is thrown + from within compiled code (see ). + + + Breakpoints and inspecting variables + + Let's use quicksort as a running example. Here's the code: + + +qsort [] = [] +qsort (a:as) = qsort left ++ [a] ++ qsort right + where (left,right) = (filter (<=a) as, filter (>a) as) + +main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18]) + + + First, load the module into GHCi: + + +Prelude> :l qsort.hs +[1 of 1] Compiling Main ( qsort.hs, interpreted ) +Ok, modules loaded: Main. +*Main> + + + Now, let's set a breakpoint on the right-hand-side of the second + equation of qsort: + + +*Main> :break 2 +Breakpoint 0 activated at qsort.hs:2:15-46 +*Main> + + + The command :break 2 sets a breakpoint on line + 2 of the most recently-loaded module, in this case + qsort.hs. Specifically, it picks the + leftmost complete subexpression on that line on which to set the + breakpoint, which in this case is the expression + (qsort left ++ [a] ++ qsort right). + + Now, we run the program: + + +*Main> main +Stopped at qsort.hs:2:15-46 +_result :: [a] +a :: a +left :: [a] +right :: [a] +[qsort.hs:2:15-46] *Main> + + + Execution has stopped at the breakpoint. The prompt has changed to + indicate that we are currently stopped at a breakpoint, and the location: + [qsort.hs:2:15-46]. To further clarify the + location, we can use the :list command: + + +[qsort.hs:2:15-46] *Main> :list +1 qsort [] = [] +2 qsort (a:as) = qsort left ++ [a] ++ qsort right +3 where (left,right) = (filter (<=a) as, filter (>a) as) + + + The :list command lists the source code around + the current breakpoint. If your output device supports it, then GHCi + will highlight the active subexpression in bold. + + GHCi has provided bindings for the free variablesWe + originally provided bindings for all variables in scope, rather + than just + the free variables of the expression, but found that this affected + performance considerably, hence the current restriction to just the + free variables. + of the expression + on which the + breakpoint was placed (a, left, + right), and additionally a binding for the result of + the expression (_result). These variables are just + like other variables that you might define in GHCi; you + can use them in expressions that you type at the prompt, you can ask + for their types with :type, and so on. There is one + important difference though: these variables may only have partial + types. For example, if we try to display the value of + left: + + +[qsort.hs:2:15-46] *Main> left + +<interactive>:1:0: + Ambiguous type variable `a' in the constraint: + `Show a' arising from a use of `print' at <interactive>:1:0-3 + Cannot resolve unknown runtime types: a + Use :print or :force to determine these types + + + This is because qsort is a polymorphic function, + and because GHCi does not carry type information at runtime, it cannot + determine the runtime types of free variables that involve type + variables. Hence, when you ask to display left at + the prompt, GHCi can't figure out which instance of + Show to use, so it emits the type error above. + + Fortunately, the debugger includes a generic printing command, + :print, which can inspect the actual runtime value of a + variable and attempt to reconstruct its type. If we try it on + left: + + +[qsort.hs:2:15-46] *Main> :set -fprint-evld-with-show +[qsort.hs:2:15-46] *Main> :print left +left = (_t1::[a]) + + + This isn't particularly enlightening. What happened is that + left is bound to an unevaluated computation (a + suspension, or thunk), and + :print does not force any evaluation. The idea is + that :print can be used to inspect values at a + breakpoint without any unfortunate side effects. It won't force any + evaluation, which could cause the program to give a different answer + than it would normally, and hence it won't cause any exceptions to be + raised, infinite loops, or further breakpoints to be triggered (see + ). + Rather than forcing thunks, :print + binds each thunk to a fresh variable beginning with an + underscore, in this case + _t1. + + The flag -fprint-evld-with-show instructs + :print to reuse + available Show instances when possible. This happens + only when the contents of the variable being inspected + are completely evaluated. + + + If we aren't concerned about preserving the evaluatedness of a + variable, we can use :force instead of + :print. The :force command + behaves exactly like :print, except that it forces + the evaluation of any thunks it encounters: + + +[qsort.hs:2:15-46] *Main> :force left +left = [4,0,3,1] + + + Now, since :force has inspected the runtime + value of left, it has reconstructed its type. We + can see the results of this type reconstruction: + + +[qsort.hs:2:15-46] *Main> :show bindings +_result :: [Integer] +a :: Integer +left :: [Integer] +right :: [Integer] +_t1 :: [Integer] + + + Not only do we now know the type of left, but + all the other partial types have also been resolved. So we can ask + for the value of a, for example: + + +[qsort.hs:2:15-46] *Main> a +8 + + + You might find it useful to use Haskell's + seq function to evaluate individual thunks rather + than evaluating the whole expression with :force. + For example: + + +[qsort.hs:2:15-46] *Main> :print right +right = (_t1::[Integer]) +[qsort.hs:2:15-46] *Main> seq _t1 () +() +[qsort.hs:2:15-46] *Main> :print right +right = 23 : (_t2::[Integer]) + + + We evaluated only the _t1 thunk, revealing the + head of the list, and the tail is another thunk now bound to + _t2. The seq function is a + little inconvenient to use here, so you might want to use + :def to make a nicer interface (left as an exercise + for the reader!). + + Finally, we can continue the current execution: + + +[qsort.hs:2:15-46] *Main> :continue +Stopped at qsort.hs:2:15-46 +_result :: [a] +a :: a +left :: [a] +right :: [a] +[qsort.hs:2:15-46] *Main> + + + The execution continued at the point it previously stopped, and has + now stopped at the breakpoint for a second time. + + + + Setting breakpoints + + Breakpoints can be set in various ways. Perhaps the easiest way to + set a breakpoint is to name a top-level function: + + + :break identifier + + + Where identifier names any top-level + function in an interpreted module currently loaded into GHCi (qualified + names may be used). The breakpoint will be set on the body of the + function, when it is fully applied but before any pattern matching has + taken place. + + Breakpoints can also be set by line (and optionally column) + number: + + + :break line + :break line column + :break module line + :break module line column + + + When a breakpoint is set on a particular line, GHCi sets the + breakpoint on the + leftmost subexpression that begins and ends on that line. If two + complete subexpressions start at the same + column, the longest one is picked. If there is no complete + subexpression on the line, then the leftmost expression starting on + the line is picked, and failing that the rightmost expression that + partially or completely covers the line. + + When a breakpoint is set on a particular line and column, GHCi + picks the smallest subexpression that encloses that location on which + to set the breakpoint. Note: GHC considers the TAB character to have a + width of 1, wherever it occurs; in other words it counts + characters, rather than columns. This matches what some editors do, + and doesn't match others. The best advice is to avoid tab + characters in your source code altogether (see + in ). + + If the module is omitted, then the most recently-loaded module is + used. + + Not all subexpressions are potential breakpoint locations. Single + variables are typically not considered to be breakpoint locations + (unless the variable is the right-hand-side of a function definition, + lambda, or case alternative). The rule of thumb is that all redexes + are breakpoint locations, together with the bodies of functions, + lambdas, case alternatives and binding statements. There is normally + no breakpoint on a let expression, but there will always be a + breakpoint on its body, because we are usually interested in inspecting + the values of the variables bound by the let. + + + + Listing and deleting breakpoints + + The list of breakpoints currently enabled can be displayed using + :show breaks: + +*Main> :show breaks +[0] Main qsort.hs:1:11-12 +[1] Main qsort.hs:2:15-46 + + + To delete a breakpoint, use the :delete + command with the number given in the output from :show breaks: + + +*Main> :delete 0 +*Main> :show breaks +[1] Main qsort.hs:2:15-46 + + + To delete all breakpoints at once, use :delete *. + + + + + + Single-stepping + + Single-stepping is a great way to visualise the execution of your + program, and it is also a useful tool for identifying the source of a + bug. GHCi offers two variants of stepping. Use + :step to enable all the + breakpoints in the program, and execute until the next breakpoint is + reached. Use :steplocal to limit the set + of enabled breakpoints to those in the current top level function. + Similarly, use :stepmodule to single step only on + breakpoints contained in the current module. + For example: + + +*Main> :step main +Stopped at qsort.hs:5:7-47 +_result :: IO () + + + The command :step + expr begins the evaluation of + expr in single-stepping mode. If + expr is omitted, then it single-steps from + the current breakpoint. :steplocal and + :stepmodule work similarly. + + The :list command is particularly useful when + single-stepping, to see where you currently are: + + +[qsort.hs:5:7-47] *Main> :list +4 +5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18]) +6 +[qsort.hs:5:7-47] *Main> + + + In fact, GHCi provides a way to run a command when a breakpoint is + hit, so we can make it automatically do + :list: + + +[qsort.hs:5:7-47] *Main> :set stop :list +[qsort.hs:5:7-47] *Main> :step +Stopped at qsort.hs:5:14-46 +_result :: [Integer] +4 +5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18]) +6 +[qsort.hs:5:14-46] *Main> + + + + + Nested breakpoints + When GHCi is stopped at a breakpoint, and an expression entered at + the prompt triggers a + second breakpoint, the new breakpoint becomes the “current” + one, and the old one is saved on a stack. An arbitrary number of + breakpoint contexts can be built up in this way. For example: + + +[qsort.hs:2:15-46] *Main> :st qsort [1,3] +Stopped at qsort.hs:(1,0)-(3,55) +_result :: [a] +... [qsort.hs:(1,0)-(3,55)] *Main> + + + While stopped at the breakpoint on line 2 that we set earlier, we + started a new evaluation with :step qsort [1,3]. + This new evaluation stopped after one step (at the definition of + qsort). The prompt has changed, now prefixed with + ..., to indicate that there are saved breakpoints + beyond the current one. To see the stack of contexts, use + :show context: + + +... [qsort.hs:(1,0)-(3,55)] *Main> :show context +--> main + Stopped at qsort.hs:2:15-46 +--> qsort [1,3] + Stopped at qsort.hs:(1,0)-(3,55) +... [qsort.hs:(1,0)-(3,55)] *Main> + + + To abandon the current evaluation, use + :abandon: + + +... [qsort.hs:(1,0)-(3,55)] *Main> :abandon +[qsort.hs:2:15-46] *Main> :abandon +*Main> + + + + + The <literal>_result</literal> variable + When stopped at a breakpoint or single-step, GHCi binds the + variable _result to the value of the currently + active expression. The value of _result is + presumably not available yet, because we stopped its evaluation, but it + can be forced: if the type is known and showable, then just entering + _result at the prompt will show it. However, + there's one caveat to doing this: evaluating _result + will be likely to trigger further breakpoints, starting with the + breakpoint we are currently stopped at (if we stopped at a real + breakpoint, rather than due to :step). So it will + probably be necessary to issue a :continue + immediately when evaluating _result. Alternatively, + you can use :force which ignores breakpoints. + + + + Tracing and history + + A question that we often want to ask when debugging a program is + “how did I get here?”. Traditional imperative debuggers + usually provide some kind of stack-tracing feature that lets you see + the stack of active function calls (sometimes called the “lexical + call stack”), describing a path through the code + to the current location. Unfortunately this is hard to provide in + Haskell, because execution proceeds on a demand-driven basis, rather + than a depth-first basis as in strict languages. The + “stack“ in GHC's execution engine bears little + resemblance to the lexical call stack. Ideally GHCi would maintain a + separate lexical call stack in addition to the dynamic call stack, and + in fact this is exactly + what our profiling system does (), and what + some other Haskell debuggers do. For the time being, however, GHCi + doesn't maintain a lexical call stack (there are some technical + challenges to be overcome). Instead, we provide a way to backtrack from a + breakpoint to previous evaluation steps: essentially this is like + single-stepping backwards, and should in many cases provide enough + information to answer the “how did I get here?” + question. + + To use tracing, evaluate an expression with the + :trace command. For example, if we set a breakpoint + on the base case of qsort: + + +*Main> :list qsort +1 qsort [] = [] +2 qsort (a:as) = qsort left ++ [a] ++ qsort right +3 where (left,right) = (filter (<=a) as, filter (>a) as) +4 +*Main> :b 1 +Breakpoint 1 activated at qsort.hs:1:11-12 +*Main> + + + and then run a small qsort with + tracing: + + +*Main> :trace qsort [3,2,1] +Stopped at qsort.hs:1:11-12 +_result :: [a] +[qsort.hs:1:11-12] *Main> + + + We can now inspect the history of evaluation steps: + + +[qsort.hs:1:11-12] *Main> :hist +-1 : qsort.hs:3:24-38 +-2 : qsort.hs:3:23-55 +-3 : qsort.hs:(1,0)-(3,55) +-4 : qsort.hs:2:15-24 +-5 : qsort.hs:2:15-46 +-6 : qsort.hs:3:24-38 +-7 : qsort.hs:3:23-55 +-8 : qsort.hs:(1,0)-(3,55) +-9 : qsort.hs:2:15-24 +-10 : qsort.hs:2:15-46 +-11 : qsort.hs:3:24-38 +-12 : qsort.hs:3:23-55 +-13 : qsort.hs:(1,0)-(3,55) +-14 : qsort.hs:2:15-24 +-15 : qsort.hs:2:15-46 +-16 : qsort.hs:(1,0)-(3,55) +<end of history> + + + To examine one of the steps in the history, use + :back: + + +[qsort.hs:1:11-12] *Main> :back +Logged breakpoint at qsort.hs:3:24-38 +_result :: [a] +as :: [a] +a :: a +[-1: qsort.hs:3:24-38] *Main> + + + Note that the local variables at each step in the history have been + preserved, and can be examined as usual. Also note that the prompt has + changed to indicate that we're currently examining the first step in + the history: -1. The command + :forward can be used to traverse forward in the + history. + + The :trace command can be used with or without + an expression. When used without an expression, tracing begins from + the current breakpoint, just like :step. + + The history is only available when + using :trace; the reason for this is we found that + logging each breakpoint in the history cuts performance by a factor of + 2 or more. By default, GHCi remembers the last 50 steps in the history, but this can be changed with the option). + + + + Debugging exceptions + Another common question that comes up when debugging is + “where did this exception come from?”. Exceptions such as + those raised by error or head [] + have no context information attached to them. Finding which + particular call to head in your program resulted in + the error can be a painstaking process, usually involving + Debug.Trace.trace, or compiling with + profiling and using Debug.Trace.traceStack + or +RTS -xc (see ). + + The GHCi debugger offers a way to hopefully shed some light on + these errors quickly and without modifying or recompiling the source + code. One way would be to set a breakpoint on the location in the + source code that throws the exception, and then use + :trace and :history to establish + the context. However, head is in a library and + we can't set a breakpoint on it directly. For this reason, GHCi + provides the flags -fbreak-on-exception which causes + the evaluator to stop when an exception is thrown, and + -fbreak-on-error, which works similarly but stops only on + uncaught exceptions. When stopping at an exception, GHCi will act + just as it does when a breakpoint is hit, with the deviation that it + will not show you any source code location. Due to this, these + commands are only really useful in conjunction with + :trace, in order to log the steps leading up to the + exception. For example: + + +*Main> :set -fbreak-on-exception +*Main> :trace qsort ("abc" ++ undefined) +“Stopped at <exception thrown> +_exception :: e +[<exception thrown>] *Main> :hist +-1 : qsort.hs:3:24-38 +-2 : qsort.hs:3:23-55 +-3 : qsort.hs:(1,0)-(3,55) +-4 : qsort.hs:2:15-24 +-5 : qsort.hs:2:15-46 +-6 : qsort.hs:(1,0)-(3,55) +<end of history> +[<exception thrown>] *Main> :back +Logged breakpoint at qsort.hs:3:24-38 +_result :: [a] +as :: [a] +a :: a +[-1: qsort.hs:3:24-38] *Main> :force as +*** Exception: Prelude.undefined +[-1: qsort.hs:3:24-38] *Main> :print as +as = 'b' : 'c' : (_t1::[Char]) + + + The exception itself is bound to a new variable, + _exception. + + Breaking on exceptions is particularly useful for finding out what + your program was doing when it was in an infinite loop. Just hit + Control-C, and examine the history to find out what was going + on. + + + Example: inspecting functions + + It is possible to use the debugger to examine function values. + When we are at a breakpoint and a function is in scope, the debugger + cannot show + you the source code for it; however, it is possible to get some + information by applying it to some arguments and observing the result. + + + + The process is slightly complicated when the binding is polymorphic. + We show the process by means of an example. + To keep things simple, we will use the well known map function: + +import Prelude hiding (map) + +map :: (a->b) -> [a] -> [b] +map f [] = [] +map f (x:xs) = f x : map f xs + + + + + We set a breakpoint on map, and call it. + +*Main> :break 5 +Breakpoint 0 activated at map.hs:5:15-28 +*Main> map Just [1..5] +Stopped at map.hs:(4,0)-(5,12) +_result :: [b] +x :: a +f :: a -> b +xs :: [a] + + GHCi tells us that, among other bindings, f is in scope. + However, its type is not fully known yet, + and thus it is not possible to apply it to any + arguments. Nevertheless, observe that the type of its first argument is the + same as the type of x, and its result type is shared + with _result. + + + + As we demonstrated earlier (), the + debugger has some intelligence built-in to update the type of + f whenever the types of x or + _result are discovered. So what we do in this + scenario is + force x a bit, in order to recover both its type + and the argument part of f. + +*Main> seq x () +*Main> :print x +x = 1 + + + + We can check now that as expected, the type of x + has been reconstructed, and with it the + type of f has been too: + +*Main> :t x +x :: Integer +*Main> :t f +f :: Integer -> b + + + From here, we can apply f to any argument of type Integer and observe + the results. + let b = f 10 +*Main> :t b +b :: b +*Main> b +:1:0: + Ambiguous type variable `b' in the constraint: + `Show b' arising from a use of `print' at :1:0 +*Main> :p b +b = (_t2::a) +*Main> seq b () +() +*Main> :t b +b :: a +*Main> :p b +b = Just 10 +*Main> :t b +b :: Maybe Integer +*Main> :t f +f :: Integer -> Maybe Integer +*Main> f 20 +Just 20 +*Main> map f [1..5] +[Just 1, Just 2, Just 3, Just 4, Just 5] +]]> + In the first application of f, we had to do + some more type reconstruction + in order to recover the result type of f. + But after that, we are free to use + f normally. + + + + Limitations + + + When stopped at a breakpoint, if you try to evaluate a variable + that is already under evaluation, the second evaluation will hang. + The reason is + that GHC knows the variable is under evaluation, so the new + evaluation just waits for the result before continuing, but of + course this isn't going to happen because the first evaluation is + stopped at a breakpoint. Control-C can interrupt the hung + evaluation and return to the prompt. + The most common way this can happen is when you're evaluating a + CAF (e.g. main), stop at a breakpoint, and ask for the value of the + CAF at the prompt again. + + + Implicit parameters (see ) are only available + at the scope of a breakpoint if there is an explicit type signature. + + + + + + + + Invoking GHCi + invokingGHCi + + + GHCi is invoked with the command ghci or + ghc --interactive. One or more modules or + filenames can also be specified on the command line; this + instructs GHCi to load the specified modules or filenames (and all + the modules they depend on), just as if you had said + :load modules at the + GHCi prompt (see ). For example, to + start GHCi and load the program whose topmost module is in the + file Main.hs, we could say: + + +$ ghci Main.hs + + + Most of the command-line options accepted by GHC (see ) also make sense in interactive mode. The ones + that don't make sense are mostly obvious. + + + Packages + packageswith GHCi + + Most packages (see ) are + available without needing to specify any extra flags at all: + they will be automatically loaded the first time they are + needed. + + For hidden packages, however, you need to request the + package be loaded by using the -package flag: + + +$ ghci -package readline +GHCi, version 6.8.1: http://www.haskell.org/ghc/ :? for help +Loading package base ... linking ... done. +Loading package readline-1.0 ... linking ... done. +Prelude> + + + The following command works to load new packages into a + running GHCi: + + +Prelude> :set -package name + + + But note that doing this will cause all currently loaded + modules to be unloaded, and you'll be dumped back into the + Prelude. + + + + Extra libraries + librarieswith GHCi + + Extra libraries may be specified on the command line using + the normal -llib + option. (The term library here refers to + libraries of foreign object code; for using libraries of Haskell + source code, see .) For + example, to load the “m” library: + + +$ ghci -lm + + + On systems with .so-style shared + libraries, the actual library loaded will the + liblib.so. GHCi + searches the following places for libraries, in this order: + + + + Paths specified using the + -Lpath + command-line option, + + + the standard library search path for your system, + which on some systems may be overridden by setting the + LD_LIBRARY_PATH environment + variable. + + + + On systems with .dll-style shared + libraries, the actual library loaded will be + lib.dll. Again, + GHCi will signal an error if it can't find the library. + + GHCi can also load plain object files + (.o or .obj depending on + your platform) from the command-line. Just add the name the + object file to the command line. + + Ordering of options matters: a library + should be mentioned before the libraries it + depends on (see ). + + + + + + GHCi commands + + GHCi commands all begin with + ‘:’ and consist of a single command + name followed by zero or more parameters. The command name may be + abbreviated, with ambiguities being resolved in favour of the more + commonly used commands. + + + + + :abandon + :abandon + + + Abandons the current evaluation (only available when stopped at + a breakpoint). + + + + + + :add *module ... + :add + + + Add module(s) to the + current target set, and perform a + reload. Normally pre-compiled code for the module will be + loaded if available, or otherwise the module will be + compiled to byte-code. Using the * + prefix forces the module to be loaded as byte-code. + + + + + + :back + :back + + + Travel back one step in the history. See . See also: + :trace, :history, + :forward. + + + + + + :break [identifier | + [module] line + [column]] + + :break + + Set a breakpoint on the specified function or line and + column. See . + + + + + + :browse! *module ... + :browse + + + Displays the identifiers exported by the module + module, which must be either + loaded into GHCi or be a member of a package. If + module is omitted, the most + recently-loaded module is used. + + Like all other GHCi commands, the output is always + displayed in the current GHCi scope (). + + There are two variants of the browse command: + + + If the * symbol is placed before + the module name, then all the + identifiers in scope in module + (rather that just its exports) are shown. + + The *-form is only available for modules + which are interpreted; for compiled modules (including + modules from packages) only the non-* + form of :browse is available. + + + Data constructors and class methods are usually + displayed in the context of their data type or class declaration. + However, if the ! symbol is appended to the + command, thus :browse!, + they are listed individually. + The !-form also annotates the listing + with comments giving possible imports for each group of + entries. Here is an example: + +Prelude> :browse! Data.Maybe +-- not currently imported +Data.Maybe.catMaybes :: [Maybe a] -> [a] +Data.Maybe.fromJust :: Maybe a -> a +Data.Maybe.fromMaybe :: a -> Maybe a -> a +Data.Maybe.isJust :: Maybe a -> Bool +Data.Maybe.isNothing :: Maybe a -> Bool +Data.Maybe.listToMaybe :: [a] -> Maybe a +Data.Maybe.mapMaybe :: (a -> Maybe b) -> [a] -> [b] +Data.Maybe.maybeToList :: Maybe a -> [a] +-- imported via Prelude +Just :: a -> Maybe a +data Maybe a = Nothing | Just a +Nothing :: Maybe a +maybe :: b -> (a -> b) -> Maybe a -> b + + This output shows that, in the context of the current session (ie in the scope + of Prelude), the first group of items from + Data.Maybe are not in scope (althought they are available in + fully qualified form in the GHCi session - see ), whereas the second group of items are in scope + (via Prelude) and are therefore available either + unqualified, or with a Prelude. qualifier. + + + + + + + + + + :cd dir + :cd + + + Changes the current working directory to + dir. A + ‘˜’ symbol at the + beginning of dir will be replaced + by the contents of the environment variable + HOME. + See also the :show paths command for + showing the current working directory. + + NOTE: changing directories causes all currently loaded + modules to be unloaded. This is because the search path is + usually expressed using relative directories, and changing + the search path in the middle of a session is not + supported. + + + + + + :cmd expr + :cmd + + + Executes expr as a computation of + type IO String, and then executes the resulting + string as a list of GHCi commands. Multiple commands are separated + by newlines. The :cmd command is useful with + :def and :set stop. + + + + + + :complete type + n-m + string-literal + :complete + + + This command allows to request command completions + from GHCi even when interacting over a pipe instead of a + proper terminal and is designed for integrating GHCi's + completion with text editors and IDEs. + + When called, :complete prints the + nth to + mth + completion candidates for the partial input + string-literal for the completion + domain denoted by + type. Currently, only the + repl domain is supported which denotes + the kind of completion that would be provided interactively + by GHCi at the input prompt. + + If omitted, n and + m default to the first or last + available completion candidate respectively. If there are + less candidates than requested via the range argument, + n and + m are implicitly capped to the + number of available completition candidates. + + The output of :complete begins with + a header line containing three space-delimited fields: + + + An integer denoting the number + l of printed + completions, + + an integer denoting the total number of + completions available, and finally + + a string literal denoting a common + prefix to be added to the returned completion + candidates. + + + The header line is followed by l + lines each containing one completion candidate encoded as + (quoted) string literal. Here are some example invocations + showing the various cases: + + +Prelude> :complete repl 0 "" +0 470 "" +Prelude> :complete repl 5 "import For" +5 21 "import " +"Foreign" +"Foreign.C" +"Foreign.C.Error" +"Foreign.C.String" +"Foreign.C.Types" +Prelude> :complete repl 5-10 "import For" +6 21 "import " +"Foreign.C.Types" +"Foreign.Concurrent" +"Foreign.ForeignPtr" +"Foreign.ForeignPtr.Safe" +"Foreign.ForeignPtr.Unsafe" +"Foreign.Marshal" +Prelude> :complete repl 20- "import For" +2 21 "import " +"Foreign.StablePtr" +"Foreign.Storable" +Prelude> :complete repl "map" +3 3 "" +"map" +"mapM" +"mapM_" +Prelude> :complete repl 5-10 "map" +0 3 "" + + + + + + + + :continue + :continue + + Continue the current evaluation, when stopped at a + breakpoint. + + + + + + :ctags filename + :etags filename + :etags + + :etags + + + + Generates a “tags” file for Vi-style editors + (:ctags) or + Emacs-style editors (:etags). If + no filename is specified, the default tags or + TAGS is + used, respectively. Tags for all the functions, constructors and + types in the currently loaded modules are created. All modules must + be interpreted for these commands to work. + + + + + + :def! name expr + :def + + + :def is used to define new + commands, or macros, in GHCi. The command + :def name + expr defines a new GHCi command + :name, + implemented by the Haskell expression + expr, which must have type + String -> IO String. When + :name + args is typed at the + prompt, GHCi will run the expression + (name + args), take the + resulting String, and feed it back into + GHCi as a new sequence of commands. Separate commands in + the result must be separated by + ‘\n’. + + That's all a little confusing, so here's a few + examples. To start with, here's a new GHCi command which + doesn't take any arguments or produce any results, it just + outputs the current date & time: + + +Prelude> let date _ = Time.getClockTime >>= print >> return "" +Prelude> :def date date +Prelude> :date +Fri Mar 23 15:16:40 GMT 2001 + + + Here's an example of a command that takes an argument. + It's a re-implementation of :cd: + + +Prelude> let mycd d = Directory.setCurrentDirectory d >> return "" +Prelude> :def mycd mycd +Prelude> :mycd .. + + + Or I could define a simple way to invoke + “ghc --make Main” in the + current directory: + + +Prelude> :def make (\_ -> return ":! ghc --make Main") + + + We can define a command that reads GHCi input from a + file. This might be useful for creating a set of bindings + that we want to repeatedly load into the GHCi session: + + +Prelude> :def . readFile +Prelude> :. cmds.ghci + + + Notice that we named the command + :., by analogy with the + ‘.’ Unix shell command that + does the same thing. + + Typing :def on its own lists the + currently-defined macros. Attempting to redefine an + existing command name results in an error unless the + :def! form is used, in which case the old + command with that name is silently overwritten. + + + + + + :delete * | num ... + :delete + + + Delete one or more breakpoints by number (use :show + breaks to see the number of each breakpoint). The + * form deletes all the breakpoints. + + + + + + :edit file + :edit + + + Opens an editor to edit the file + file, or the most recently loaded + module if file is omitted. + If there were errors during the last loading, + the cursor will be positioned at the line of the first error. The + editor to invoke is taken from the EDITOR + environment variable, or a default editor on your system if + EDITOR is not set. You can change the + editor using :set editor. + + + + + + :etags + + + See :ctags. + + + + + + :force identifier ... + :force + + + Prints the value of identifier in + the same way as :print. Unlike + :print, :force evaluates each + thunk that it encounters while traversing the value. This may + cause exceptions or infinite loops, or further breakpoints (which + are ignored, but displayed). + + + + + + :forward + :forward + + + Move forward in the history. See . See also: + :trace, :history, + :back. + + + + + + :help + :help + + + :? + :? + + + Displays a list of the available commands. + + + + + + : + : + + + Repeat the previous command. + + + + + + + :history [num] + :history + + + Display the history of evaluation steps. With a + number, displays that many steps (default: 20). For use + with :trace; see . To set the number of history entries stored by GHCi, + use + . + + + + + + :info!name ... + :info + + + Displays information about the given name(s). For + example, if name is a class, then + the class methods and their types will be printed; if + name is a type constructor, then + its definition will be printed; if + name is a function, then its type + will be printed. If name has + been loaded from a source file, then GHCi will also display + the location of its definition in the source. + For types and classes, GHCi also summarises instances that + mention them. To avoid showing irrelevant information, an instance + is shown only if (a) its head mentions name, + and (b) all the other things mentioned in the instance + are in scope (either qualified or otherwise) as a result of + a :load or :module commands. + + The command :info! works in a similar fashion + but it removes restriction (b), showing all instances that are in + scope and mention name in their head. + + + + + + + :issafemodule + :issafe + + + Displays Safe Haskell information about the given + module (or the current module if omitted). This includes the trust + type of the module and its containing package. + + + + + + :kind! + type + :kind + + + Infers and prints the kind of + type. The latter can be an arbitrary + type expression, including a partial application of a type constructor, + such as Either Int. In fact, :kind + even allows you to write a partial application of a type synonym (usually disallowed), + so that this works: + +ghci> type T a b = (a,b,a) +ghci> :k T Int Bool +T Int Bool :: * +ghci> :k T +T :: * -> * -> * +ghci> :k T Int +T Int :: * -> * + + + + If you specify the + optional "!", GHC will in addition normalise the type + by expanding out type synonyms and evaluating type-function applications, + and display the normalised result. + + + + + + :list identifier + :list + + + Lists the source code around the definition of + identifier or the current + breakpoint if not given. This requires that the identifier be + defined in an interpreted module. If your output device + supports it, then GHCi will highlight the active + subexpression in bold. + + + + + + :list module line + :list + + + Lists the source code around the given line number of + module. This requires that the module be + interpreted. If your output device supports it, then GHCi will + highlight the active subexpression in bold. + + + + + + :load *module ... + :load + + + Recursively loads the specified + modules, and all the modules they + depend on. Here, each module + must be a module name or filename, but may not be the name + of a module in a package. + + All previously loaded modules, except package modules, + are forgotten. The new set of modules is known as the + target set. Note that + :load can be used without any arguments + to unload all the currently loaded modules and + bindings. + + Normally pre-compiled code for a module will be loaded + if available, or otherwise the module will be compiled to + byte-code. Using the * prefix forces a + module to be loaded as byte-code. + + After a :load command, the current + context is set to: + + + + module, if it was loaded + successfully, or + + + the most recently successfully loaded module, if + any other modules were loaded as a result of the current + :load, or + + + Prelude otherwise. + + + + + + + + :main arg1 ... argn + :main + + + + When a program is compiled and executed, it can use the + getArgs function to access the + command-line arguments. + However, we cannot simply pass the arguments to the + main function while we are testing in ghci, + as the main function doesn't take its + arguments directly. + + + + Instead, we can use the :main command. + This runs whatever main is in scope, with + any arguments being treated the same as command-line arguments, + e.g.: + + + +Prelude> let main = System.Environment.getArgs >>= print +Prelude> :main foo bar +["foo","bar"] + + + + We can also quote arguments which contains characters like + spaces, and they are treated like Haskell strings, or we can + just use Haskell list syntax: + + + +Prelude> :main foo "bar baz" +["foo","bar baz"] +Prelude> :main ["foo", "bar baz"] +["foo","bar baz"] + + + + Finally, other functions can be called, either with the + -main-is flag or the :run + command: + + + +Prelude> let foo = putStrLn "foo" >> System.Environment.getArgs >>= print +Prelude> let bar = putStrLn "bar" >> System.Environment.getArgs >>= print +Prelude> :set -main-is foo +Prelude> :main foo "bar baz" +foo +["foo","bar baz"] +Prelude> :run bar ["foo", "bar baz"] +bar +["foo","bar baz"] + + + + + + + + :module +|- *mod1 ... *modn + :module + + + import mod + + + Sets or modifies the current context for statements + typed at the prompt. The form import + mod is equivalent to + :module +mod. + See for + more details. + + + + + + :print names ... + :print + + + Prints a value without forcing its evaluation. + :print may be used on values whose types are + unknown or partially known, which might be the case for local + variables with polymorphic types at a breakpoint. While inspecting + the runtime value, :print attempts to + reconstruct the type of the value, and will elaborate the type in + GHCi's environment if possible. If any unevaluated components + (thunks) are encountered, then :print binds + a fresh variable with a name beginning with _t + to each thunk. See for more + information. See also the :sprint command, + which works like :print but does not bind new + variables. + + + + + + :quit + :quit + + + Quits GHCi. You can also quit by typing control-D + at the prompt. + + + + + + :reload + :reload + + + Attempts to reload the current target set (see + :load) if any of the modules in the set, + or any dependent module, has changed. Note that this may + entail loading new modules, or dropping modules which are no + longer indirectly required by the target. + + + + + + :run + :run + + + See :main. + + + + + + :script n + filename + :script + + + Executes the lines of a file as a series of GHCi commands. This command + is compatible with multiline statements as set by :set +m + + + + + + + :set option... + :set + + + Sets various options. See for a list of + available options and for a + list of GHCi-specific flags. The :set command by + itself shows which options are currently set. It also lists the current + dynamic flag settings, with GHCi-specific flags listed separately. + + + + + + :set args arg ... + :set args + + + Sets the list of arguments which are returned when the + program calls System.getArgsgetArgs + . + + + + + + :set editor cmd + + + Sets the command used by :edit to + cmd. + + + + + + :set prog prog + :set prog + + + Sets the string to be returned when the program calls + System.getProgNamegetProgName + . + + + + + + :set prompt prompt + + + Sets the string to be used as the prompt in GHCi. + Inside prompt, the sequence + %s is replaced by the names of the + modules currently in scope, %l is replaced + by the line number (as referenced in compiler messages) of the + current prompt, and %% is replaced by + %. If prompt + starts with " then it is parsed as a Haskell String; + otherwise it is treated as a literal string. + + + + + + :set prompt2 prompt + + + Sets the string to be used as the continuation prompt + (used when using the :{ command) in GHCi. + + + + + + :set stop + [num] cmd + + + Set a command to be executed when a breakpoint is hit, or a new + item in the history is selected. The most common use of + :set stop is to display the source code at the + current location, e.g. :set stop :list. + + If a number is given before the command, then the commands are + run when the specified breakpoint (only) is hit. This can be quite + useful: for example, :set stop 1 :continue + effectively disables breakpoint 1, by running + :continue whenever it is hit (although GHCi will + still emit a message to say the breakpoint was hit). What's more, + with cunning use of :def and + :cmd you can use :set stop to + implement conditional breakpoints: + +*Main> :def cond \expr -> return (":cmd if (" ++ expr ++ ") then return \"\" else return \":continue\"") +*Main> :set stop 0 :cond (x < 3) + + Ignoring breakpoints for a specified number of iterations is + also possible using similar techniques. + + + + + + :seti option... + :seti + + + + Like :set, but options set with + :seti affect only expressions and + commands typed at the prompt, and not modules loaded with + :load (in contrast, options set with + :set apply everywhere). See . + + + Without any arguments, displays the current set of options + that are applied to expressions and commands typed at the + prompt. + + + + + + + :show bindings + :show bindings + + + Show the bindings made at the prompt and their + types. + + + + + + :show breaks + :show breaks + + + List the active breakpoints. + + + + + + :show context + :show context + + + List the active evaluations that are stopped at breakpoints. + + + + + + :show imports + :show imports + + + Show the imports that are currently in force, as + created by import and + :module commands. + + + + + + :show modules + :show modules + + + Show the list of modules currently loaded. + + + + + + :show packages + :show packages + + + Show the currently active package flags, as well as the list of + packages currently loaded. + + + + + + :show paths + :show paths + + + Show the current working directory (as set via + :cd command), as well as the list of + directories searched for source files (as set by the + option). + + + + + + :show language + :show language + + + Show the currently active language flags for source files. + + + + + + :showi language + :showi language + + + Show the currently active language flags for + expressions typed at the prompt (see also :seti). + + + + + + + :show [args|prog|prompt|editor|stop] + :show + + + Displays the specified setting (see + :set). + + + + + + :sprint + :sprint + + + Prints a value without forcing its evaluation. + :sprint is similar to :print, + with the difference that unevaluated subterms are not bound to new + variables, they are simply denoted by ‘_’. + + + + + + :step expr + :step + + + Enable all breakpoints and begin evaluating an + expression in single-stepping mode. In this + mode evaluation will be stopped after every reduction, + allowing local variables to be inspected. + + If expr is not given, evaluation will + resume at the last breakpoint. + + See . + + + + + + :steplocal + :steplocal + + + Enable only breakpoints in the current top-level + binding and resume evaluation at the last breakpoint. + + + + + + :stepmodule + :stepmodule + + + Enable only breakpoints in the current module and + resume evaluation at the last breakpoint. + + + + + + :trace expr + :trace + + + Evaluates the given expression (or from the last breakpoint if + no expression is given), and additionally logs the evaluation + steps for later inspection using :history. See + . + + + + + + :type expression + :type + + + Infers and prints the type of + expression, including explicit + forall quantifiers for polymorphic types. The monomorphism + restriction is not applied to the + expression during type inference. + + + + + + :undef name + :undef + + + Undefines the user-defined command + name (see :def + above). + + + + + + :unset option... + :unset + + + Unsets certain options. See + for a list of available options. + + + + + + :! command... + :! + shell commandsin GHCi + + + Executes the shell command + command. + + + + + + + + The <literal>:set</literal> and <literal>:seti</literal> commands + :set + :seti + + The :set command sets two types of + options: GHCi options, which begin with + ‘+’, and “command-line” + options, which begin with ‘-’. + + NOTE: at the moment, the :set command + doesn't support any kind of quoting in its arguments: quotes will + not be removed and cannot be used to group words together. For + example, :set -DFOO='BAR BAZ' will not do what + you expect. + + + GHCi options + optionsGHCi + + + GHCi options may be set using :set and + unset using :unset. + + The available GHCi options are: + + + + + +m + +m + + + Enable parsing of multiline commands. A multiline command + is prompted for when the current input line contains open layout + contexts (see ). + + + + + + +r + +r + CAFsin GHCi + Constant Applicative FormCAFs + + + Normally, any evaluation of top-level expressions + (otherwise known as CAFs or Constant Applicative Forms) in + loaded modules is retained between evaluations. Turning + on +r causes all evaluation of + top-level expressions to be discarded after each + evaluation (they are still retained + during a single evaluation). + + This option may help if the evaluated top-level + expressions are consuming large amounts of space, or if + you need repeatable performance measurements. + + + + + + +s + +s + + + Display some stats after evaluating each expression, + including the elapsed time and number of bytes allocated. + NOTE: the allocation figure is only accurate to the size + of the storage manager's allocation area, because it is + calculated at every GC. Hence, you might see values of + zero if no GC has occurred. + + + + + + +t + +t + + + Display the type of each variable bound after a + statement is entered at the prompt. If the statement is a + single expression, then the only variable binding will be + for the variable + ‘it’. + + + + + + + Setting GHC command-line options in GHCi + + Normal GHC command-line options may also be set using + :set. For example, to turn on + , you would say: + + +Prelude> :set -fwarn-missing-signatures + + + Any GHC command-line option that is designated as + dynamic (see the table in ), may be set using + :set. To unset an option, you can set the + reverse option: + dynamicoptions + + +Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses + + + lists the reverse for each + option where applicable. + + Certain static options (, + , , and + in particular) will also work, but some may + not take effect until the next reload. + staticoptions + + + + Setting options for interactive evaluation only + + + GHCi actually maintains two sets of options: + + + The loading options apply when loading modules + + + The interactive options apply when evaluating expressions and commands typed at the GHCi prompt. + + +The :set command modifies both, but there is + also a :seti command (for "set + interactive") that affects only the interactive options set. + + + + It is often useful to change the interactive options, + without having that option apply to loaded modules + too. For example + +:seti -XMonoLocalBinds + + It would be undesirable if were to + apply to loaded modules too: that might cause a compilation error, but + more commonly it will cause extra recompilation, because GHC will think + that it needs to recompile the module because the flags have changed. + + + + If you are setting language options in your .ghci file, it is good practice + to use :seti rather than :set, + unless you really do want them to apply to all modules you + load in GHCi. + + + + The two sets of options can be inspected using the + :set and :seti commands + respectively, with no arguments. For example, in a clean GHCi + session we might see something like this: + +Prelude> :seti +base language is: Haskell2010 +with the following modifiers: + -XNoMonomorphismRestriction + -XNoDatatypeContexts + -XNondecreasingIndentation + -XExtendedDefaultRules +GHCi-specific dynamic flag settings: +other dynamic, non-language, flag settings: + -fimplicit-import-qualified +warning settings: + + + +The two sets of options are initialised as follows. First, both sets of options +are initialised as described in . +Then the interactive options are modified as follows: + + + The option + is enabled, in order to apply special defaulting rules to + expressions typed at the prompt (see ). + + + + The Monomorphism Restriction is disabled (see ). + + + + + + + + The <filename>.ghci</filename> file + .ghcifile + + startupfiles, GHCi + + + When it starts, unless the -ignore-dot-ghci + flag is given, GHCi reads and executes commands from the following + files, in this order, if they exist: + + + + ./.ghci + + + appdata/ghc/ghci.conf, + where appdata depends on your system, + but is usually something like C:/Documents and Settings/user/Application Data + + + On Unix: $HOME/.ghc/ghci.conf + + + $HOME/.ghci + + + + The ghci.conf file is most useful for + turning on favourite options (eg. :set +s), and + defining useful macros. Note: when setting language options in + this file it is usually desirable to use :seti + rather than :set (see ). + + + + Placing a .ghci file + in a directory with a Haskell project is a useful way to set + certain project-wide options so you don't have to type them + every time you start GHCi: eg. if your project uses multi-parameter + type classes, scoped type variables, + and CPP, and has source files in three subdirectories A, B and C, + you might put the following lines in + .ghci: + + +:set -XMultiParamTypeClasses -XScopedTypeVariables -cpp +:set -iA:B:C + + + (Note that strictly speaking the flag is + a static one, but in fact it works to set it using + :set like this. The changes won't take effect + until the next :load, though.) + + Once you have a library of GHCi macros, you may want + to source them from separate files, or you may want to source + your .ghci file into your running GHCi + session while debugging it + + +:def source readFile + + + With this macro defined in your .ghci + file, you can use :source file to read GHCi + commands from file. You can find (and contribute!-) + other suggestions for .ghci files on this Haskell + wiki page: GHC/GHCi + + Additionally, any files specified with + -ghci-script flags will be read after the + standard files, allowing the use of custom .ghci files. + + Two command-line options control whether the + startup files files are read: + + + + + + + + + Don't read either ./.ghci or the + other startup files when starting up. + + + + + + + + + Read a specific file after the usual startup files. + Maybe be specified repeatedly for multiple inputs. + + + + + + When defining GHCi macros, there is some important behavior you + should be aware of when names may conflict with built-in + commands, especially regarding tab completion. + + + For example, consider if you had a macro named + :time and in the shell, typed :t + 3 - what should happen? The current algorithm we use + for completing commands is: + + + + First, look up an exact match on the name from the defined macros. + + + Look for the exact match on the name in the built-in command list. + + + Do a prefix lookup on the list of built-in commands - + if a built-in command matches, but a macro is defined with + the same name as the built-in defined, pick the + macro. + + + Do a prefix lookup on the list of built-in commands. + + + Do a prefix lookup on the list of defined macros. + + + + + + Here are some examples: + + + + You have a macro :time and enter :t 3 + You get :type 3 + + + + You have a macro :type and enter :t 3 + You get :type 3 with your defined macro, not the builtin. + + + + You have a macro :time and a macro + :type, and enter :t + 3 + You get :type 3 with your defined macro. + + + + + + + Compiling to object code inside GHCi + + By default, GHCi compiles Haskell source code into byte-code + that is interpreted by the runtime system. GHCi can also compile + Haskell code to object code: to turn on this feature, use the + flag either on the command line or + with :set (the option + restores byte-code compilation + again). Compiling to object code takes longer, but typically the + code will execute 10-20 times faster than byte-code. + + Compiling to object code inside GHCi is particularly useful + if you are developing a compiled application, because the + :reload command typically runs much faster than + restarting GHC with from the command-line, + because all the interface files are already cached in + memory. + + There are disadvantages to compiling to object-code: you + can't set breakpoints in object-code modules, for example. Only + the exports of an object-code module will be visible in GHCi, + rather than all top-level bindings as in interpreted + modules. + + + + FAQ and Things To Watch Out For + + + + The interpreter can't load modules with foreign export + declarations! + + Unfortunately not. We haven't implemented it yet. + Please compile any offending modules by hand before loading + them into GHCi. + + + + + + -O doesn't work with GHCi! + + + + For technical reasons, the bytecode compiler doesn't + interact well with one of the optimisation passes, so we + have disabled optimisation when using the interpreter. This + isn't a great loss: you'll get a much bigger win by + compiling the bits of your code that need to go fast, rather + than interpreting them with optimisation turned on. + + + + + Unboxed tuples don't work with GHCi + + That's right. You can always compile a module that + uses unboxed tuples and load it into GHCi, however. + (Incidentally the previous point, namely that + -O is incompatible with GHCi, is because + the bytecode compiler can't deal with unboxed + tuples). + + + + + Concurrent threads don't carry on running when GHCi is + waiting for input. + + This should work, as long as your GHCi was built with + the switch, which is the default. + Consult whoever supplied your GHCi installation. + + + + + After using getContents, I can't use + stdin again until I do + :load or :reload. + + + This is the defined behaviour of + getContents: it puts the stdin Handle in + a state known as semi-closed, wherein + any further I/O operations on it are forbidden. Because I/O + state is retained between computations, the semi-closed + state persists until the next :load or + :reload command. + + You can make stdin reset itself + after every evaluation by giving GHCi the command + :set +r. This works because + stdin is just a top-level expression that + can be reverted to its unevaluated state in the same way as + any other top-level expression (CAF). + + + + + I can't use Control-C to interrupt computations in + GHCi on Windows. + + See . + + + + + The default buffering mode is different in GHCi to GHC. + + + In GHC, the stdout handle is line-buffered by default. + However, in GHCi we turn off the buffering on stdout, + because this is normally what you want in an interpreter: + output appears as it is generated. + + + If you want line-buffered behaviour, as in GHC, you can + start your program thus: + + main = do { hSetBuffering stdout LineBuffering; ... } + + + + + + + + + + diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml new file mode 100644 index 00000000..3dfd40ab --- /dev/null +++ b/docs/users_guide/glasgow_exts.xml @@ -0,0 +1,12720 @@ + + +language, GHC +extensions, GHC +As with all known Haskell systems, GHC implements some extensions to +the language. They can all be enabled or disabled by command line flags +or language pragmas. By default GHC understands the most recent Haskell +version it supports, plus a handful of extensions. + + + +Some of the Glasgow extensions serve to give you access to the +underlying facilities with which we implement Haskell. Thus, you can +get at the Raw Iron, if you are willing to write some non-portable +code at a more primitive level. You need not be “stuck” +on performance because of the implementation costs of Haskell's +“high-level” features—you can always code +“under” them. In an extreme case, you can write all your +time-critical code in C, and then just glue it together with Haskell! + + + +Before you get too carried away working at the lowest level (e.g., +sloshing MutableByteArray#s around your +program), you may wish to check if there are libraries that provide a +“Haskellised veneer” over the features you want. The +separate libraries +documentation describes all the libraries that come with GHC. + + + + + Language options + + languageoption + + optionslanguage + + extensionsoptions controlling + + + The language option flags control what variation of the language are + permitted. + + Language options can be controlled in two ways: + + Every language option can switched on by a command-line flag "" + (e.g. ), and switched off by the flag ""; + (e.g. ). + + Language options recognised by Cabal can also be enabled using the LANGUAGE pragma, + thus {-# LANGUAGE TemplateHaskell #-} (see ). + + + + The flag + + is equivalent to enabling the following extensions: + &what_glasgow_exts_does; + Enabling these options is the only + effect of . + We are trying to move away from this portmanteau flag, + and towards enabling features individually. + + + + + + Unboxed types and primitive operations + +GHC is built on a raft of primitive data types and operations; +"primitive" in the sense that they cannot be defined in Haskell itself. +While you really can use this stuff to write fast code, +we generally find it a lot less painful, and more satisfying in the +long run, to use higher-level language features and libraries. With +any luck, the code you write will be optimised to the efficient +unboxed version in any case. And if it isn't, we'd like to know +about it. + +All these primitive data types and operations are exported by the +library GHC.Prim, for which there is +detailed online documentation. +(This documentation is generated from the file compiler/prelude/primops.txt.pp.) + + + +If you want to mention any of the primitive data types or operations in your +program, you must first import GHC.Prim to bring them +into scope. Many of them have names ending in "#", and to mention such +names you need the extension (). + + +The primops make extensive use of unboxed types +and unboxed tuples, which +we briefly summarise here. + + +Unboxed types + + +Unboxed types (Glasgow extension) + + +Most types in GHC are boxed, which means +that values of that type are represented by a pointer to a heap +object. The representation of a Haskell Int, for +example, is a two-word heap object. An unboxed +type, however, is represented by the value itself, no pointers or heap +allocation are involved. + + + +Unboxed types correspond to the “raw machine” types you +would use in C: Int# (long int), +Double# (double), Addr# +(void *), etc. The primitive operations +(PrimOps) on these types are what you might expect; e.g., +(+#) is addition on +Int#s, and is the machine-addition that we all +know and love—usually one instruction. + + + +Primitive (unboxed) types cannot be defined in Haskell, and are +therefore built into the language and compiler. Primitive types are +always unlifted; that is, a value of a primitive type cannot be +bottom. We use the convention (but it is only a convention) +that primitive types, values, and +operations have a # suffix (see ). +For some primitive types we have special syntax for literals, also +described in the same section. + + + +Primitive values are often represented by a simple bit-pattern, such +as Int#, Float#, +Double#. But this is not necessarily the case: +a primitive value might be represented by a pointer to a +heap-allocated object. Examples include +Array#, the type of primitive arrays. A +primitive array is heap-allocated because it is too big a value to fit +in a register, and would be too expensive to copy around; in a sense, +it is accidental that it is represented by a pointer. If a pointer +represents a primitive value, then it really does point to that value: +no unevaluated thunks, no indirections…nothing can be at the +other end of the pointer than the primitive value. +A numerically-intensive program using unboxed types can +go a lot faster than its “standard” +counterpart—we saw a threefold speedup on one example. + + + +There are some restrictions on the use of primitive types: + +The main restriction +is that you can't pass a primitive value to a polymorphic +function or store one in a polymorphic data type. This rules out +things like [Int#] (i.e. lists of primitive +integers). The reason for this restriction is that polymorphic +arguments and constructor fields are assumed to be pointers: if an +unboxed integer is stored in one of these, the garbage collector would +attempt to follow it, leading to unpredictable space leaks. Or a +seq operation on the polymorphic component may +attempt to dereference the pointer, with disastrous results. Even +worse, the unboxed value might be larger than a pointer +(Double# for instance). + + + You cannot define a newtype whose representation type +(the argument type of the data constructor) is an unboxed type. Thus, +this is illegal: + + newtype A = MkA Int# + + + You cannot bind a variable with an unboxed type +in a top-level binding. + + You cannot bind a variable with an unboxed type +in a recursive binding. + + You may bind unboxed variables in a (non-recursive, +non-top-level) pattern binding, but you must make any such pattern-match +strict. For example, rather than: + + data Foo = Foo Int Int# + + f x = let (Foo a b, w) = ..rhs.. in ..body.. + +you must write: + + data Foo = Foo Int Int# + + f x = let !(Foo a b, w) = ..rhs.. in ..body.. + +since b has type Int#. + + + + + + + + +Unboxed tuples + + +Unboxed tuples aren't really exported by GHC.Exts; +they are a syntactic extension enabled by the language flag . An +unboxed tuple looks like this: + + + + + +(# e_1, ..., e_n #) + + + + + +where e_1..e_n are expressions of any +type (primitive or non-primitive). The type of an unboxed tuple looks +the same. + + + +Note that when unboxed tuples are enabled, +(# is a single lexeme, so for example when using +operators like # and #- you need +to write ( # ) and ( #- ) rather than +(#) and (#-). + + + +Unboxed tuples are used for functions that need to return multiple +values, but they avoid the heap allocation normally associated with +using fully-fledged tuples. When an unboxed tuple is returned, the +components are put directly into registers or on the stack; the +unboxed tuple itself does not have a composite representation. Many +of the primitive operations listed in primops.txt.pp return unboxed +tuples. +In particular, the IO and ST monads use unboxed +tuples to avoid unnecessary allocation during sequences of operations. + + + +There are some restrictions on the use of unboxed tuples: + + + + +Values of unboxed tuple types are subject to the same restrictions as +other unboxed types; i.e. they may not be stored in polymorphic data +structures or passed to polymorphic functions. + + + + + +The typical use of unboxed tuples is simply to return multiple values, +binding those multiple results with a case expression, thus: + + f x y = (# x+1, y-1 #) + g x = case f x x of { (# a, b #) -> a + b } + +You can have an unboxed tuple in a pattern binding, thus + + f x = let (# p,q #) = h x in ..body.. + +If the types of p and q are not unboxed, +the resulting binding is lazy like any other Haskell pattern binding. The +above example desugars like this: + + f x = let t = case h x of { (# p,q #) -> (p,q) } + p = fst t + q = snd t + in ..body.. + +Indeed, the bindings can even be recursive. + + + + + + + + + + + + + +Syntactic extensions + + + Unicode syntax + The language + extension + enables Unicode characters to be used to stand for certain ASCII + character sequences. The following alternatives are provided: + + + + + + ASCII + Unicode alternative + Code point + Name + + + + + + + + :: + :: + 0x2237 + PROPORTION + + + + + => + ⇒ + 0x21D2 + RIGHTWARDS DOUBLE ARROW + + + + + forall + ∀ + 0x2200 + FOR ALL + + + + + -> + → + 0x2192 + RIGHTWARDS ARROW + + + + + <- + ← + 0x2190 + LEFTWARDS ARROW + + + + + + -< + ↢ + 0x2919 + LEFTWARDS ARROW-TAIL + + + + + + >- + ↣ + 0x291A + RIGHTWARDS ARROW-TAIL + + + + + + -<< + + 0x291B + LEFTWARDS DOUBLE ARROW-TAIL + + + + + + >>- + + 0x291C + RIGHTWARDS DOUBLE ARROW-TAIL + + + + + + * + ★ + 0x2605 + BLACK STAR + + + + + + + + + The magic hash + The language extension allows "#" as a + postfix modifier to identifiers. Thus, "x#" is a valid variable, and "T#" is + a valid type constructor or data constructor. + + The hash sign does not change semantics at all. We tend to use variable + names ending in "#" for unboxed values or types (e.g. Int#), + but there is no requirement to do so; they are just plain ordinary variables. + Nor does the extension bring anything into scope. + For example, to bring Int# into scope you must + import GHC.Prim (see ); + the extension + then allows you to refer to the Int# + that is now in scope. Note that with this option, the meaning of x#y = 0 + is changed: it defines a function x# taking a single argument y; + to define the operator #, put a space: x # y = 0. + + + The also enables some new forms of literals (see ): + + 'x'# has type Char# + "foo"# has type Addr# + 3# has type Int#. In general, + any Haskell integer lexeme followed by a # is an Int# literal, e.g. + -0x3A# as well as 32#. + 3## has type Word#. In general, + any non-negative Haskell integer lexeme followed by ## + is a Word#. + 3.2# has type Float#. + 3.2## has type Double# + + + + + + Negative literals + + The literal -123 is, according to + Haskell98 and Haskell 2010, desugared as + negate (fromInteger 123). + The language extension + means that it is instead desugared as + fromInteger (-123). + + + + This can make a difference when the positive and negative range of + a numeric data type don't match up. For example, + in 8-bit arithmetic -128 is representable, but +128 is not. + So negate (fromInteger 128) will elicit an + unexpected integer-literal-overflow message. + + + + + Fractional looking integer literals + + Haskell 2010 and Haskell 98 define floating literals with + the syntax 1.2e6. These literals have the + type Fractional a => a. + + + + The language extension allows + you to also use the floating literal syntax for instances of + Integral, and have values like + (1.2e6 :: Num a => a) + + + + + Binary integer literals + + Haskell 2010 and Haskell 98 allows for integer literals to + be given in decimal, octal (prefixed by + 0o or 0O), or + hexadecimal notation (prefixed by 0x or + 0X). + + + + The language extension + adds support for expressing integer literals in binary + notation with the prefix 0b or + 0B. For instance, the binary integer + literal 0b11001001 will be desugared into + fromInteger 201 when + is enabled. + + + + + + + + Hierarchical Modules + + GHC supports a small extension to the syntax of module + names: a module name is allowed to contain a dot + ‘.’. This is also known as the + “hierarchical module namespace” extension, because + it extends the normally flat Haskell module namespace into a + more flexible hierarchy of modules. + + This extension has very little impact on the language + itself; modules names are always fully + qualified, so you can just think of the fully qualified module + name as the module name. In particular, this + means that the full module name must be given after the + module keyword at the beginning of the + module; for example, the module A.B.C must + begin + +module A.B.C + + + It is a common strategy to use the as + keyword to save some typing when using qualified names with + hierarchical modules. For example: + + +import qualified Control.Monad.ST.Strict as ST + + + For details on how GHC searches for source and interface + files in the presence of hierarchical modules, see . + + GHC comes with a large collection of libraries arranged + hierarchically; see the accompanying library + documentation. More libraries to install are available + from HackageDB. + + + + + +Pattern guards + + +Pattern guards (Glasgow extension) +The discussion that follows is an abbreviated version of Simon Peyton Jones's original proposal. (Note that the proposal was written before pattern guards were implemented, so refers to them as unimplemented.) + + + +Suppose we have an abstract data type of finite maps, with a +lookup operation: + + +lookup :: FiniteMap -> Int -> Maybe Int + + +The lookup returns Nothing if the supplied key is not in the domain of the mapping, and (Just v) otherwise, +where v is the value that the key maps to. Now consider the following definition: + + + +clunky env var1 var2 | ok1 && ok2 = val1 + val2 +| otherwise = var1 + var2 +where + m1 = lookup env var1 + m2 = lookup env var2 + ok1 = maybeToBool m1 + ok2 = maybeToBool m2 + val1 = expectJust m1 + val2 = expectJust m2 + + + +The auxiliary functions are + + + +maybeToBool :: Maybe a -> Bool +maybeToBool (Just x) = True +maybeToBool Nothing = False + +expectJust :: Maybe a -> a +expectJust (Just x) = x +expectJust Nothing = error "Unexpected Nothing" + + + +What is clunky doing? The guard ok1 && +ok2 checks that both lookups succeed, using +maybeToBool to convert the Maybe +types to booleans. The (lazily evaluated) expectJust +calls extract the values from the results of the lookups, and binds the +returned values to val1 and val2 +respectively. If either lookup fails, then clunky takes the +otherwise case and returns the sum of its arguments. + + + +This is certainly legal Haskell, but it is a tremendously verbose and +un-obvious way to achieve the desired effect. Arguably, a more direct way +to write clunky would be to use case expressions: + + + +clunky env var1 var2 = case lookup env var1 of + Nothing -> fail + Just val1 -> case lookup env var2 of + Nothing -> fail + Just val2 -> val1 + val2 +where + fail = var1 + var2 + + + +This is a bit shorter, but hardly better. Of course, we can rewrite any set +of pattern-matching, guarded equations as case expressions; that is +precisely what the compiler does when compiling equations! The reason that +Haskell provides guarded equations is because they allow us to write down +the cases we want to consider, one at a time, independently of each other. +This structure is hidden in the case version. Two of the right-hand sides +are really the same (fail), and the whole expression +tends to become more and more indented. + + + +Here is how I would write clunky: + + + +clunky env var1 var2 + | Just val1 <- lookup env var1 + , Just val2 <- lookup env var2 + = val1 + val2 +...other equations for clunky... + + + +The semantics should be clear enough. The qualifiers are matched in order. +For a <- qualifier, which I call a pattern guard, the +right hand side is evaluated and matched against the pattern on the left. +If the match fails then the whole guard fails and the next equation is +tried. If it succeeds, then the appropriate binding takes place, and the +next qualifier is matched, in the augmented environment. Unlike list +comprehensions, however, the type of the expression to the right of the +<- is the same as the type of the pattern to its +left. The bindings introduced by pattern guards scope over all the +remaining guard qualifiers, and over the right hand side of the equation. + + + +Just as with list comprehensions, boolean expressions can be freely mixed +with among the pattern guards. For example: + + + +f x | [y] <- x + , y > 3 + , Just z <- h y + = ... + + + +Haskell's current guards therefore emerge as a special case, in which the +qualifier list has just one element, a boolean expression. + + + + + + +View patterns + + + +View patterns are enabled by the flag -XViewPatterns. +More information and examples of view patterns can be found on the +Wiki +page. + + + +View patterns are somewhat like pattern guards that can be nested inside +of other patterns. They are a convenient way of pattern-matching +against values of abstract types. For example, in a programming language +implementation, we might represent the syntax of the types of the +language as follows: + + +type Typ + +data TypView = Unit + | Arrow Typ Typ + +view :: Typ -> TypView + +-- additional operations for constructing Typ's ... + + +The representation of Typ is held abstract, permitting implementations +to use a fancy representation (e.g., hash-consing to manage sharing). + +Without view patterns, using this signature a little inconvenient: + +size :: Typ -> Integer +size t = case view t of + Unit -> 1 + Arrow t1 t2 -> size t1 + size t2 + + +It is necessary to iterate the case, rather than using an equational +function definition. And the situation is even worse when the matching +against t is buried deep inside another pattern. + + + +View patterns permit calling the view function inside the pattern and +matching against the result: + +size (view -> Unit) = 1 +size (view -> Arrow t1 t2) = size t1 + size t2 + + +That is, we add a new form of pattern, written +expression -> +pattern that means "apply the expression to +whatever we're trying to match against, and then match the result of +that application against the pattern". The expression can be any Haskell +expression of function type, and view patterns can be used wherever +patterns are used. + + + +The semantics of a pattern ( +exp -> +pat ) are as follows: + + + + Scoping: + +The variables bound by the view pattern are the variables bound by +pat. + + + +Any variables in exp are bound occurrences, +but variables bound "to the left" in a pattern are in scope. This +feature permits, for example, one argument to a function to be used in +the view of another argument. For example, the function +clunky from can be +written using view patterns as follows: + + +clunky env (lookup env -> Just val1) (lookup env -> Just val2) = val1 + val2 +...other equations for clunky... + + + + +More precisely, the scoping rules are: + + + +In a single pattern, variables bound by patterns to the left of a view +pattern expression are in scope. For example: + +example :: Maybe ((String -> Integer,Integer), String) -> Bool +example Just ((f,_), f -> 4) = True + + +Additionally, in function definitions, variables bound by matching earlier curried +arguments may be used in view pattern expressions in later arguments: + +example :: (String -> Integer) -> String -> Bool +example f (f -> 4) = True + +That is, the scoping is the same as it would be if the curried arguments +were collected into a tuple. + + + + + +In mutually recursive bindings, such as let, +where, or the top level, view patterns in one +declaration may not mention variables bound by other declarations. That +is, each declaration must be self-contained. For example, the following +program is not allowed: + +let {(x -> y) = e1 ; + (y -> x) = e2 } in x + + +(For some amplification on this design choice see +Trac #4061.) + + + + + + + + + Typing: If exp has type +T1 -> +T2 and pat matches +a T2, then the whole view pattern matches a +T1. + + + Matching: To the equations in Section 3.17.3 of the +Haskell 98 +Report, add the following: + +case v of { (e -> p) -> e1 ; _ -> e2 } + = +case (e v) of { p -> e1 ; _ -> e2 } + +That is, to match a variable v against a pattern +( exp +-> pat +), evaluate ( +exp v +) and match the result against +pat. + + + Efficiency: When the same view function is applied in +multiple branches of a function definition or a case expression (e.g., +in size above), GHC makes an attempt to collect these +applications into a single nested case expression, so that the view +function is only applied once. Pattern compilation in GHC follows the +matrix algorithm described in Chapter 4 of The +Implementation of Functional Programming Languages. When the +top rows of the first column of a matrix are all view patterns with the +"same" expression, these patterns are transformed into a single nested +case. This includes, for example, adjacent view patterns that line up +in a tuple, as in + +f ((view -> A, p1), p2) = e1 +f ((view -> B, p3), p4) = e2 + + + + The current notion of when two view pattern expressions are "the +same" is very restricted: it is not even full syntactic equality. +However, it does include variables, literals, applications, and tuples; +e.g., two instances of view ("hi", "there") will be +collected. However, the current implementation does not compare up to +alpha-equivalence, so two instances of (x, view x -> +y) will not be coalesced. + + + + + + + + + + + + +Pattern synonyms + + + +Pattern synonyms are enabled by the flag +-XPatternSynonyms, which is required for defining +them, but not for using them. More information +and examples of view patterns can be found on the Wiki +page. + + + +Pattern synonyms enable giving names to parametrized pattern +schemes. They can also be thought of as abstract constructors that +don't have a bearing on data representation. For example, in a +programming language implementation, we might represent types of the +language as follows: + + + +data Type = App String [Type] + + + +Here are some examples of using said representation. +Consider a few types of the Type universe encoded +like this: + + + + App "->" [t1, t2] -- t1 -> t2 + App "Int" [] -- Int + App "Maybe" [App "Int" []] -- Maybe Int + + + +This representation is very generic in that no types are given special +treatment. However, some functions might need to handle some known +types specially, for example the following two functions collect all +argument types of (nested) arrow types, and recognize the +Int type, respectively: + + + + collectArgs :: Type -> [Type] + collectArgs (App "->" [t1, t2]) = t1 : collectArgs t2 + collectArgs _ = [] + + isInt :: Type -> Bool + isInt (App "Int" []) = True + isInt _ = False + + + +Matching on App directly is both hard to read and +error prone to write. And the situation is even worse when the +matching is nested: + + + + isIntEndo :: Type -> Bool + isIntEndo (App "->" [App "Int" [], App "Int" []]) = True + isIntEndo _ = False + + + +Pattern synonyms permit abstracting from the representation to expose +matchers that behave in a constructor-like manner with respect to +pattern matching. We can create pattern synonyms for the known types +we care about, without committing the representation to them (note +that these don't have to be defined in the same module as the +Type type): + + + + pattern Arrow t1 t2 = App "->" [t1, t2] + pattern Int = App "Int" [] + pattern Maybe t = App "Maybe" [t] + + + +Which enables us to rewrite our functions in a much cleaner style: + + + + collectArgs :: Type -> [Type] + collectArgs (Arrow t1 t2) = t1 : collectArgs t2 + collectArgs _ = [] + + isInt :: Type -> Bool + isInt Int = True + isInt _ = False + + isIntEndo :: Type -> Bool + isIntEndo (Arrow Int Int) = True + isIntEndo _ = False + + + + Note that in this example, the pattern synonyms + Int and Arrow can also be used + as expressions (they are bidirectional). This + is not necessarily the case: unidirectional + pattern synonyms can also be declared with the following syntax: + + + + pattern Head x <- x:xs + + + +In this case, Head x +cannot be used in expressions, only patterns, since it wouldn't +specify a value for the xs on the +right-hand side. We can give an explicit inversion of a pattern +synonym using the following syntax: + + + + pattern Head x <- x:xs where + Head x = [x] + + + +The syntax and semantics of pattern synonyms are elaborated in the +following subsections. +See the Wiki +page for more details. + + + Syntax and scoping of pattern synonyms + +A pattern synonym declaration can be either unidirectional or +bidirectional. The syntax for unidirectional pattern synonyms is: + + pattern Name args <- pat + + and the syntax for bidirectional pattern synonyms is: + + pattern Name args = pat + or + + pattern Name args <- pat where + Name args = expr + + Either prefix or infix syntax can be + used. + + + Pattern synonym declarations can only occur in the top level of a + module. In particular, they are not allowed as local + definitions. + + + The variables in the left-hand side of the definition are bound by + the pattern on the right-hand side. For implicitly bidirectional + pattern synonyms, all the variables of the right-hand side must also + occur on the left-hand side; also, wildcard patterns and view + patterns are not allowed. For unidirectional and + explicitly-bidirectional pattern synonyms, there is no restriction + on the right-hand side pattern. + + + + Pattern synonyms cannot be defined recursively. + + + + Import and export of pattern synonyms + + + The name of the pattern synonym itself is in the same namespace as + proper data constructors. In an export or import specification, + you must prefix pattern + names with the pattern keyword, e.g.: + + module Example (pattern Single) where + pattern Single x = [x] + +Without the pattern prefix, Single would +be interpreted as a type constructor in the export list. + + +You may also use the pattern keyword in an import/export +specification to import or export an ordinary data constructor. For example: + + import Data.Maybe( pattern Just ) + +would bring into scope the data constructor Just from the +Maybe type, without also bringing the type constructor +Maybe into scope. + + + + Typing of pattern synonyms + + + Given a pattern synonym definition of the form + + pattern P var1 var2 ... varN <- pat + + it is assigned a pattern type of the form + + pattern P :: CProv => CReq => t1 -> t2 -> ... -> tN -> t + + where CProv and + CReq are type contexts, and + t1, t2, ..., + tN and t are + types. +Notice the unusual form of the type, with two contexts CProv and CReq: + +CReq are the constraints required to match the pattern. +CProv are the constraints made available (provided) +by a successful pattern match. + +For example, consider + +data T a where + MkT :: (Show b) => a -> b -> T a + +f1 :: (Eq a, Num a) => MkT a -> String +f1 (MkT 42 x) = show x + +pattern ExNumPat :: (Show b) => (Num a, Eq a) => b -> T a +pattern ExNumPat x = MkT 42 x + +f2 :: (Eq a, Num a) => MkT a -> String +f2 (ExNumPat x) = show x + +Here f1 does not use pattern synonyms. To match against the +numeric pattern 42 requires the caller to +satisfy the constraints (Num a, Eq a), +so they appear in f1's type. The call to show generates a (Show b) +constraint, where b is an existentially type variable bound by the pattern match +on MkT. But the same pattern match also provides the constraint +(Show b) (see MkT's type), and so all is well. + + +Exactly the same reasoning applies to ExNumPat: +matching against ExNumPat requires +the constraints (Num a, Eq a), and provides +the constraint (Show b). + + +Note also the following points + + +In the common case where CReq is empty, + (), it can be omitted altogether. + + + +You may specify an explicit pattern signature, as +we did for ExNumPat above, to specify the type of a pattern, +just as you can for a function. As usual, the type signature can be less polymorphic +than the inferred type. For example + + -- Inferred type would be 'a -> [a]' + pattern SinglePair :: (a, a) -> [(a, a)] + pattern SinglePair x = [x] + + + + +The GHCi :info command shows pattern types in this format. + + + +For a bidirectional pattern synonym, a use of the pattern synonym as an expression has the type + + (CProv, CReq) => t1 -> t2 -> ... -> tN -> t + + So in the previous example, when used in an expression, ExNumPat has type + + ExNumPat :: (Show b, Num a, Eq a) => b -> T t + +Notice that this is a tiny bit more restrictive than the expression MkT 42 x +which would not require (Eq a). + + + +Consider these two pattern synonyms: + +data S a where + S1 :: Bool -> S Bool + +pattern P1 b = Just b -- P1 :: Bool -> Maybe Bool +pattern P2 b = S1 b -- P2 :: (b~Bool) => Bool -> S b + +f :: Maybe a -> String +f (P1 x) = "no no no" -- Type-incorrect + +g :: S a -> String +g (P2 b) = "yes yes yes" -- Fine + +Pattern P1 can only match against a value of type Maybe Bool, +so function f is rejected because the type signature is Maybe a. +(To see this, imagine expanding the pattern synonym.) + + +On the other hand, function g works fine, becuase matching against P2 +(which wraps the GADT S) provides the local equality (a~Bool). +If you were to give an explicit pattern signature P2 :: Bool -> S Bool, then P2 +would become less polymorphic, and would behave exactly like P1 so that g +would then be rejected. + + +In short, if you want GADT-like behaviour for pattern synonyms, +then (unlike unlike concrete data constructors like S1) +you must write its type with explicit provided equalities. +For a concrete data construoctr like S1 you can write +its type signature as eigher S1 :: Bool -> S Bool or +S1 :: (b~Bool) => Bool -> S b; the two are equivalent. +Not so for pattern synonyms: the two forms are different, in order to +distinguish the two cases above. (See Trac #9953 for +discussion of this choice.) + + + + + +Matching of pattern synonyms + + +A pattern synonym occurrence in a pattern is evaluated by first +matching against the pattern synonym itself, and then on the argument +patterns. For example, in the following program, f +and f' are equivalent: + + + +pattern Pair x y <- [x, y] + +f (Pair True True) = True +f _ = False + +f' [x, y] | True <- x, True <- y = True +f' _ = False + + + + Note that the strictness of f differs from that + of g defined below: + +g [True, True] = True +g _ = False + +*Main> f (False:undefined) +*** Exception: Prelude.undefined +*Main> g (False:undefined) +False + + + + + + + + + +n+k patterns + + + +n+k pattern support is disabled by default. To enable +it, you can use the flag. + + + + + + + +Traditional record syntax + + + +Traditional record syntax, such as C {f = x}, is enabled by default. +To disable it, you can use the flag. + + + + + + + +The recursive do-notation + + + + The do-notation of Haskell 98 does not allow recursive bindings, + that is, the variables bound in a do-expression are visible only in the textually following + code block. Compare this to a let-expression, where bound variables are visible in the entire binding + group. + + + + It turns out that such recursive bindings do indeed make sense for a variety of monads, but + not all. In particular, recursion in this sense requires a fixed-point operator for the underlying + monad, captured by the mfix method of the MonadFix class, defined in Control.Monad.Fix as follows: + +class Monad m => MonadFix m where + mfix :: (a -> m a) -> m a + + Haskell's + Maybe, [] (list), ST (both strict and lazy versions), + IO, and many other monads have MonadFix instances. On the negative + side, the continuation monad, with the signature (a -> r) -> r, does not. + + + + For monads that do belong to the MonadFix class, GHC provides + an extended version of the do-notation that allows recursive bindings. + The (language pragma: RecursiveDo) + provides the necessary syntactic support, introducing the keywords mdo and + rec for higher and lower levels of the notation respectively. Unlike + bindings in a do expression, those introduced by mdo and rec + are recursively defined, much like in an ordinary let-expression. Due to the new + keyword mdo, we also call this notation the mdo-notation. + + + + Here is a simple (albeit contrived) example: + +{-# LANGUAGE RecursiveDo #-} +justOnes = mdo { xs <- Just (1:xs) + ; return (map negate xs) } + +or equivalently + +{-# LANGUAGE RecursiveDo #-} +justOnes = do { rec { xs <- Just (1:xs) } + ; return (map negate xs) } + +As you can guess justOnes will evaluate to Just [-1,-1,-1,.... + + + + GHC's implementation the mdo-notation closely follows the original translation as described in the paper + A recursive do for Haskell, which + in turn is based on the work Value Recursion + in Monadic Computations. Furthermore, GHC extends the syntax described in the former paper + with a lower level syntax flagged by the rec keyword, as we describe next. + + + +Recursive binding groups + + + The flag also introduces a new keyword rec, which wraps a + mutually-recursive group of monadic statements inside a do expression, producing a single statement. + Similar to a let statement inside a do, variables bound in + the rec are visible throughout the rec group, and below it. For example, compare + + do { a <- getChar do { a <- getChar + ; let { r1 = f a r2 ; rec { r1 <- f a r2 + ; ; r2 = g r1 } ; ; r2 <- g r1 } + ; return (r1 ++ r2) } ; return (r1 ++ r2) } + + In both cases, r1 and r2 are available both throughout + the let or rec block, and in the statements that follow it. + The difference is that let is non-monadic, while rec is monadic. + (In Haskell let is really letrec, of course.) + + + + The semantics of rec is fairly straightforward. Whenever GHC finds a rec + group, it will compute its set of bound variables, and will introduce an appropriate call + to the underlying monadic value-recursion operator mfix, belonging to the + MonadFix class. Here is an example: + +rec { b <- f a c ===> (b,c) <- mfix (\ ~(b,c) -> do { b <- f a c + ; c <- f b a } ; c <- f b a + ; return (b,c) }) + + As usual, the meta-variables b, c etc., can be arbitrary patterns. + In general, the statement rec ss is desugared to the statement + +vs <- mfix (\ ~vs -> do { ss; return vs }) + + where vs is a tuple of the variables bound by ss. + + + + Note in particular that the translation for a rec block only involves wrapping a call + to mfix: it performs no other analysis on the bindings. The latter is the task + for the mdo notation, which is described next. + + + + +The <literal>mdo</literal> notation + + + A rec-block tells the compiler where precisely the recursive knot should be tied. It turns out that + the placement of the recursive knots can be rather delicate: in particular, we would like the knots to be wrapped + around as minimal groups as possible. This process is known as segmentation, and is described + in detail in Secton 3.2 of A recursive do for + Haskell. Segmentation improves polymorphism and reduces the size of the recursive knot. Most importantly, it avoids + unnecessary interference caused by a fundamental issue with the so-called right-shrinking + axiom for monadic recursion. In brief, most monads of interest (IO, strict state, etc.) do not + have recursion operators that satisfy this axiom, and thus not performing segmentation can cause unnecessary + interference, changing the termination behavior of the resulting translation. + (Details can be found in Sections 3.1 and 7.2.2 of + Value Recursion in Monadic Computations.) + + + + The mdo notation removes the burden of placing + explicit rec blocks in the code. Unlike an + ordinary do expression, in which variables bound by + statements are only in scope for later statements, variables bound in + an mdo expression are in scope for all statements + of the expression. The compiler then automatically identifies minimal + mutually recursively dependent segments of statements, treating them as + if the user had wrapped a rec qualifier around them. + + + + The definition is syntactic: + + + + + A generator g + depends on a textually following generator + g', if + + + + + g' defines a variable that + is used by g, or + + + + + g' textually appears between + g and + g'', where g + depends on g''. + + + + + + + A segment of a given + mdo-expression is a minimal sequence of generators + such that no generator of the sequence depends on an outside + generator. As a special case, although it is not a generator, + the final expression in an mdo-expression is + considered to form a segment by itself. + + + + + Segments in this sense are + related to strongly-connected components analysis, + with the exception that bindings in a segment cannot be reordered and + must be contiguous. + + + + Here is an example mdo-expression, and its translation to rec blocks: + +mdo { a <- getChar ===> do { a <- getChar + ; b <- f a c ; rec { b <- f a c + ; c <- f b a ; ; c <- f b a } + ; z <- h a b ; z <- h a b + ; d <- g d e ; rec { d <- g d e + ; e <- g a z ; ; e <- g a z } + ; putChar c } ; putChar c } + +Note that a given mdo expression can cause the creation of multiple rec blocks. +If there are no recursive dependencies, mdo will introduce no rec blocks. In this +latter case an mdo expression is precisely the same as a do expression, as one +would expect. + + + + In summary, given an mdo expression, GHC first performs segmentation, introducing + rec blocks to wrap over minimal recursive groups. Then, each resulting + rec is desugared, using a call to Control.Monad.Fix.mfix as described + in the previous section. The original mdo-expression typechecks exactly when the desugared + version would do so. + + + +Here are some other important points in using the recursive-do notation: + + + + + It is enabled with the flag -XRecursiveDo, or the LANGUAGE RecursiveDo + pragma. (The same flag enables both mdo-notation, and the use of rec + blocks inside do expressions.) + + + + + rec blocks can also be used inside mdo-expressions, which will be + treated as a single statement. However, it is good style to either use mdo or + rec blocks in a single expression. + + + + + If recursive bindings are required for a monad, then that monad must be declared an instance of + the MonadFix class. + + + + + The following instances of MonadFix are automatically provided: List, Maybe, IO. + Furthermore, the Control.Monad.ST and Control.Monad.ST.Lazy + modules provide the instances of the MonadFix class for Haskell's internal + state monad (strict and lazy, respectively). + + + + + Like let and where bindings, name shadowing is not allowed within + an mdo-expression or a rec-block; that is, all the names bound in + a single rec must be distinct. (GHC will complain if this is not the case.) + + + + + + + + + + + + + + Parallel List Comprehensions + list comprehensionsparallel + + parallel list comprehensions + + + Parallel list comprehensions are a natural extension to list + comprehensions. List comprehensions can be thought of as a nice + syntax for writing maps and filters. Parallel comprehensions + extend this to include the zipWith family. + + A parallel list comprehension has multiple independent + branches of qualifier lists, each separated by a `|' symbol. For + example, the following zips together two lists: + + + [ (x, y) | x <- xs | y <- ys ] + + + The behaviour of parallel list comprehensions follows that of + zip, in that the resulting list will have the same length as the + shortest branch. + + We can define parallel list comprehensions by translation to + regular comprehensions. Here's the basic idea: + + Given a parallel comprehension of the form: + + + [ e | p1 <- e11, p2 <- e12, ... + | q1 <- e21, q2 <- e22, ... + ... + ] + + + This will be translated to: + + + [ e | ((p1,p2), (q1,q2), ...) <- zipN [(p1,p2) | p1 <- e11, p2 <- e12, ...] + [(q1,q2) | q1 <- e21, q2 <- e22, ...] + ... + ] + + + where `zipN' is the appropriate zip for the given number of + branches. + + + + + + + Generalised (SQL-Like) List Comprehensions + list comprehensionsgeneralised + + extended list comprehensions + + group + sql + + + Generalised list comprehensions are a further enhancement to the + list comprehension syntactic sugar to allow operations such as sorting + and grouping which are familiar from SQL. They are fully described in the + paper + Comprehensive comprehensions: comprehensions with "order by" and "group by", + except that the syntax we use differs slightly from the paper. +The extension is enabled with the flag . +Here is an example: + +employees = [ ("Simon", "MS", 80) +, ("Erik", "MS", 100) +, ("Phil", "Ed", 40) +, ("Gordon", "Ed", 45) +, ("Paul", "Yale", 60)] + +output = [ (the dept, sum salary) +| (name, dept, salary) <- employees +, then group by dept using groupWith +, then sortWith by (sum salary) +, then take 5 ] + +In this example, the list output would take on + the value: + + +[("Yale", 60), ("Ed", 85), ("MS", 180)] + + +There are three new keywords: group, by, and using. +(The functions sortWith and groupWith are not keywords; they are ordinary +functions that are exported by GHC.Exts.) + +There are five new forms of comprehension qualifier, +all introduced by the (existing) keyword then: + + + + +then f + + + This statement requires that f have the type + forall a. [a] -> [a]. You can see an example of its use in the + motivating example, as this form is used to apply take 5. + + + + + + + +then f by e + + + This form is similar to the previous one, but allows you to create a function + which will be passed as the first argument to f. As a consequence f must have + the type forall a. (a -> t) -> [a] -> [a]. As you can see + from the type, this function lets f "project out" some information + from the elements of the list it is transforming. + + An example is shown in the opening example, where sortWith + is supplied with a function that lets it find out the sum salary + for any item in the list comprehension it transforms. + + + + + + + +then group by e using f + + + This is the most general of the grouping-type statements. In this form, + f is required to have type forall a. (a -> t) -> [a] -> [[a]]. + As with the then f by e case above, the first argument + is a function supplied to f by the compiler which lets it compute e on every + element of the list being transformed. However, unlike the non-grouping case, + f additionally partitions the list into a number of sublists: this means that + at every point after this statement, binders occurring before it in the comprehension + refer to lists of possible values, not single values. To help understand + this, let's look at an example: + + +-- This works similarly to groupWith in GHC.Exts, but doesn't sort its input first +groupRuns :: Eq b => (a -> b) -> [a] -> [[a]] +groupRuns f = groupBy (\x y -> f x == f y) + +output = [ (the x, y) +| x <- ([1..3] ++ [1..2]) +, y <- [4..6] +, then group by x using groupRuns ] + + + This results in the variable output taking on the value below: + + +[(1, [4, 5, 6]), (2, [4, 5, 6]), (3, [4, 5, 6]), (1, [4, 5, 6]), (2, [4, 5, 6])] + + + Note that we have used the the function to change the type + of x from a list to its original numeric type. The variable y, in contrast, is left + unchanged from the list form introduced by the grouping. + + + + + + +then group using f + + + With this form of the group statement, f is required to simply have the type + forall a. [a] -> [[a]], which will be used to group up the + comprehension so far directly. An example of this form is as follows: + + +output = [ x +| y <- [1..5] +, x <- "hello" +, then group using inits] + + + This will yield a list containing every prefix of the word "hello" written out 5 times: + + +["","h","he","hel","hell","hello","helloh","hellohe","hellohel","hellohell","hellohello","hellohelloh",...] + + + + + + + + + + + Monad comprehensions + monad comprehensions + + + Monad comprehensions generalise the list comprehension notation, + including parallel comprehensions + () and + transform comprehensions () + to work for any monad. + + + Monad comprehensions support: + + + + + Bindings: + + + +[ x + y | x <- Just 1, y <- Just 2 ] + + + + Bindings are translated with the (>>=) and + return functions to the usual do-notation: + + + +do x <- Just 1 + y <- Just 2 + return (x+y) + + + + + + Guards: + + + +[ x | x <- [1..10], x <= 5 ] + + + + Guards are translated with the guard function, + which requires a MonadPlus instance: + + + +do x <- [1..10] + guard (x <= 5) + return x + + + + + + Transform statements (as with -XTransformListComp): + + + +[ x+y | x <- [1..10], y <- [1..x], then take 2 ] + + + + This translates to: + + + +do (x,y) <- take 2 (do x <- [1..10] + y <- [1..x] + return (x,y)) + return (x+y) + + + + + + Group statements (as with -XTransformListComp): + + + +[ x | x <- [1,1,2,2,3], then group by x using GHC.Exts.groupWith ] +[ x | x <- [1,1,2,2,3], then group using myGroup ] + + + + + + Parallel statements (as with -XParallelListComp): + + + +[ (x+y) | x <- [1..10] + | y <- [11..20] + ] + + + + Parallel statements are translated using the + mzip function, which requires a + MonadZip instance defined in + Control.Monad.Zip: + + + +do (x,y) <- mzip (do x <- [1..10] + return x) + (do y <- [11..20] + return y) + return (x+y) + + + + + + + All these features are enabled by default if the + MonadComprehensions extension is enabled. The types + and more detailed examples on how to use comprehensions are explained + in the previous chapters and . In general you just have + to replace the type [a] with the type + Monad m => m a for monad comprehensions. + + + + Note: Even though most of these examples are using the list monad, + monad comprehensions work for any monad. + The base package offers all necessary instances for + lists, which make MonadComprehensions backward + compatible to built-in, transform and parallel list comprehensions. + + More formally, the desugaring is as follows. We write D[ e | Q] +to mean the desugaring of the monad comprehension [ e | Q]: + +Expressions: e +Declarations: d +Lists of qualifiers: Q,R,S + +-- Basic forms +D[ e | ] = return e +D[ e | p <- e, Q ] = e >>= \p -> D[ e | Q ] +D[ e | e, Q ] = guard e >> \p -> D[ e | Q ] +D[ e | let d, Q ] = let d in D[ e | Q ] + +-- Parallel comprehensions (iterate for multiple parallel branches) +D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D[ e | S ] + +-- Transform comprehensions +D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then f by b, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +D[ e | Q then group by b using f, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +where Qv is the tuple of variables bound by Q (and used subsequently) + selQvi is a selector mapping Qv to the ith component of Qv + +Operator Standard binding Expected type +-------------------------------------------------------------------- +return GHC.Base t1 -> m t2 +(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3 +(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3 +guard Control.Monad t1 -> m t2 +fmap GHC.Base forall a b. (a->b) -> n a -> n b +mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b) + +The comprehension should typecheck when its desugaring would typecheck. + + +Monad comprehensions support rebindable syntax (). +Without rebindable +syntax, the operators from the "standard binding" module are used; with +rebindable syntax, the operators are looked up in the current lexical scope. +For example, parallel comprehensions will be typechecked and desugared +using whatever "mzip" is in scope. + + +The rebindable operators must have the "Expected type" given in the +table above. These types are surprisingly general. For example, you can +use a bind operator with the type + +(>>=) :: T x y a -> (a -> T y z b) -> T x z b + +In the case of transform comprehensions, notice that the groups are +parameterised over some arbitrary type n (provided it +has an fmap, as well as +the comprehension being over an arbitrary monad. + + + + + + +Rebindable syntax and the implicit Prelude import + + -XNoImplicitPrelude + option GHC normally imports + Prelude.hi files for you. If you'd + rather it didn't, then give it a + option. The idea is + that you can then import a Prelude of your own. (But don't + call it Prelude; the Haskell module + namespace is flat, and you must not conflict with any + Prelude module.) + + Suppose you are importing a Prelude of your own + in order to define your own numeric class + hierarchy. It completely defeats that purpose if the + literal "1" means "Prelude.fromInteger + 1", which is what the Haskell Report specifies. + So the + flag causes + the following pieces of built-in syntax to refer to + whatever is in scope, not the Prelude + versions: + + + An integer literal 368 means + "fromInteger (368::Integer)", rather than + "Prelude.fromInteger (368::Integer)". + + + Fractional literals are handed in just the same way, + except that the translation is + fromRational (3.68::Rational). + + + The equality test in an overloaded numeric pattern + uses whatever (==) is in scope. + + + The subtraction operation, and the + greater-than-or-equal test, in n+k patterns + use whatever (-) and (>=) are in scope. + + + + Negation (e.g. "- (f x)") + means "negate (f x)", both in numeric + patterns, and expressions. + + + + Conditionals (e.g. "if e1 then e2 else e3") + means "ifThenElse e1 e2 e3". However case expressions are unaffected. + + + + "Do" notation is translated using whatever + functions (>>=), + (>>), and fail, + are in scope (not the Prelude + versions). List comprehensions, mdo + (), and parallel array + comprehensions, are unaffected. + + + Arrow + notation (see ) + uses whatever arr, + (>>>), first, + app, (|||) and + loop functions are in scope. But unlike the + other constructs, the types of these functions must match the + Prelude types very closely. Details are in flux; if you want + to use this, ask! + + + implies . + + +In all cases (apart from arrow notation), the static semantics should be that of the desugared form, +even if that is a little unexpected. For example, the +static semantics of the literal 368 +is exactly that of fromInteger (368::Integer); it's fine for +fromInteger to have any of the types: + +fromInteger :: Integer -> Integer +fromInteger :: forall a. Foo a => Integer -> a +fromInteger :: Num a => a -> Integer +fromInteger :: Integer -> Bool -> Bool + + + + Be warned: this is an experimental facility, with + fewer checks than usual. Use -dcore-lint + to typecheck the desugared program. If Core Lint is happy + you should be all right. + + + + +Postfix operators + + + The flag enables a small +extension to the syntax of left operator sections, which allows you to +define postfix operators. The extension is this: the left section + + (e !) + +is equivalent (from the point of view of both type checking and execution) to the expression + + ((!) e) + +(for any expression e and operator (!). +The strict Haskell 98 interpretation is that the section is equivalent to + + (\y -> (!) e y) + +That is, the operator must be a function of two arguments. GHC allows it to +take only one argument, and that in turn allows you to write the function +postfix. + +The extension does not extend to the left-hand side of function +definitions; you must define such a function in prefix form. + + + + +Tuple sections + + + The flag enables Python-style partially applied + tuple constructors. For example, the following program + + (, True) + + is considered to be an alternative notation for the more unwieldy alternative + + \x -> (x, True) + +You can omit any combination of arguments to the tuple, as in the following + + (, "I", , , "Love", , 1337) + +which translates to + + \a b c d -> (a, "I", b, c, "Love", d, 1337) + + + + + If you have unboxed tuples enabled, tuple sections + will also be available for them, like so + + (# , True #) + +Because there is no unboxed unit tuple, the following expression + + (# #) + +continues to stand for the unboxed singleton tuple data constructor. + + + + + +Lambda-case + +The flag enables expressions of the form + + \case { p1 -> e1; ...; pN -> eN } + +which is equivalent to + + \freshName -> case freshName of { p1 -> e1; ...; pN -> eN } + +Note that \case starts a layout, so you can write + + \case + p1 -> e1 + ... + pN -> eN + + + + + +Empty case alternatives + +The flag enables +case expressions, or lambda-case expressions, that have no alternatives, +thus: + + case e of { } -- No alternatives +or + \case { } -- -XLambdaCase is also required + +This can be useful when you know that the expression being scrutinised +has no non-bottom values. For example: + + data Void + f :: Void -> Int + f x = case x of { } + +With dependently-typed features it is more useful +(see Trac). +For example, consider these two candidate definitions of absurd: + +data a :==: b where + Refl :: a :==: a + +absurd :: True :~: False -> a +absurd x = error "absurd" -- (A) +absurd x = case x of {} -- (B) + +We much prefer (B). Why? Because GHC can figure out that (True :~: False) +is an empty type. So (B) has no partiality and GHC should be able to compile with +. (Though the pattern match checking is not +yet clever enough to do that.) +On the other hand (A) looks dangerous, and GHC doesn't check to make +sure that, in fact, the function can never get called. + + + + +Multi-way if-expressions + +With flag GHC accepts conditional expressions +with multiple branches: + + if | guard1 -> expr1 + | ... + | guardN -> exprN + +which is roughly equivalent to + + case () of + _ | guard1 -> expr1 + ... + _ | guardN -> exprN + + + +Multi-way if expressions introduce a new layout context. So the +example above is equivalent to: + + if { | guard1 -> expr1 + ; | ... + ; | guardN -> exprN + } + +The following behaves as expected: + + if | guard1 -> if | guard2 -> expr2 + | guard3 -> expr3 + | guard4 -> expr4 + +because layout translates it as + + if { | guard1 -> if { | guard2 -> expr2 + ; | guard3 -> expr3 + } + ; | guard4 -> expr4 + } + +Layout with multi-way if works in the same way as other layout +contexts, except that the semi-colons between guards in a multi-way if +are optional. So it is not necessary to line up all the guards at the +same column; this is consistent with the way guards work in function +definitions and case expressions. + + + + +Record field disambiguation + +In record construction and record pattern matching +it is entirely unambiguous which field is referred to, even if there are two different +data types in scope with a common field name. For example: + +module M where + data S = MkS { x :: Int, y :: Bool } + +module Foo where + import M + + data T = MkT { x :: Int } + + ok1 (MkS { x = n }) = n+1 -- Unambiguous + ok2 n = MkT { x = n+1 } -- Unambiguous + + bad1 k = k { x = 3 } -- Ambiguous + bad2 k = x k -- Ambiguous + +Even though there are two x's in scope, +it is clear that the x in the pattern in the +definition of ok1 can only mean the field +x from type S. Similarly for +the function ok2. However, in the record update +in bad1 and the record selection in bad2 +it is not clear which of the two types is intended. + + +Haskell 98 regards all four as ambiguous, but with the + flag, GHC will accept +the former two. The rules are precisely the same as those for instance +declarations in Haskell 98, where the method names on the left-hand side +of the method bindings in an instance declaration refer unambiguously +to the method of that class (provided they are in scope at all), even +if there are other variables in scope with the same name. +This reduces the clutter of qualified names when you import two +records from different modules that use the same field name. + + +Some details: + + +Field disambiguation can be combined with punning (see ). For example: + +module Foo where + import M + x=True + ok3 (MkS { x }) = x+1 -- Uses both disambiguation and punning + + + + +With you can use unqualified +field names even if the corresponding selector is only in scope qualified +For example, assuming the same module M as in our earlier example, this is legal: + +module Foo where + import qualified M -- Note qualified + + ok4 (M.MkS { x = n }) = n+1 -- Unambiguous + +Since the constructor MkS is only in scope qualified, you must +name it M.MkS, but the field x does not need +to be qualified even though M.x is in scope but x +is not. (In effect, it is qualified by the constructor.) + + + + + + + + + +Record puns + + + +Record puns are enabled by the flag -XNamedFieldPuns. + + + +When using records, it is common to write a pattern that binds a +variable with the same name as a record field, such as: + + +data C = C {a :: Int} +f (C {a = a}) = a + + + + +Record punning permits the variable name to be elided, so one can simply +write + + +f (C {a}) = a + + +to mean the same pattern as above. That is, in a record pattern, the +pattern a expands into the pattern a = +a for the same name a. + + + +Note that: + + +Record punning can also be used in an expression, writing, for example, + +let a = 1 in C {a} + +instead of + +let a = 1 in C {a = a} + +The expansion is purely syntactic, so the expanded right-hand side +expression refers to the nearest enclosing variable that is spelled the +same as the field name. + + + +Puns and other patterns can be mixed in the same record: + +data C = C {a :: Int, b :: Int} +f (C {a, b = 4}) = a + + + + +Puns can be used wherever record patterns occur (e.g. in +let bindings or at the top-level). + + + +A pun on a qualified field name is expanded by stripping off the module qualifier. +For example: + +f (C {M.a}) = a + +means + +f (M.C {M.a = a}) = a + +(This is useful if the field selector a for constructor M.C +is only in scope in qualified form.) + + + + + + + + + + +Record wildcards + + + +Record wildcards are enabled by the flag -XRecordWildCards. +This flag implies -XDisambiguateRecordFields. + + + +For records with many fields, it can be tiresome to write out each field +individually in a record pattern, as in + +data C = C {a :: Int, b :: Int, c :: Int, d :: Int} +f (C {a = 1, b = b, c = c, d = d}) = b + c + d + + + + +Record wildcard syntax permits a ".." in a record +pattern, where each elided field f is replaced by the +pattern f = f. For example, the above pattern can be +written as + +f (C {a = 1, ..}) = b + c + d + + + + +More details: + + +Record wildcards in patterns can be mixed with other patterns, including puns +(); for example, in a pattern (C {a += 1, b, ..}). Additionally, record wildcards can be used +wherever record patterns occur, including in let +bindings and at the top-level. For example, the top-level binding + +C {a = 1, ..} = e + +defines b, c, and +d. + + + +Record wildcards can also be used in an expression, when constructing a record. For example, + +let {a = 1; b = 2; c = 3; d = 4} in C {..} + +in place of + +let {a = 1; b = 2; c = 3; d = 4} in C {a=a, b=b, c=c, d=d} + +The expansion is purely syntactic, so the record wildcard +expression refers to the nearest enclosing variables that are spelled +the same as the omitted field names. + + + +Record wildcards may not be used in record updates. For example this +is illegal: + +f r = r { x = 3, .. } + + + + +For both pattern and expression wildcards, the ".." expands to the missing +in-scope record fields. +Specifically the expansion of "C {..}" includes +f if and only if: + + +f is a record field of constructor C. + + +The record field f is in scope somehow (either qualified or unqualified). + + +In the case of expressions (but not patterns), +the variable f is in scope unqualified, +apart from the binding of the record selector itself. + + +These rules restrict record wildcards to the situations in which the user +could have written the expanded version. +For example + +module M where + data R = R { a,b,c :: Int } +module X where + import M( R(a,c) ) + f b = R { .. } + +The R{..} expands to R{M.a=a}, +omitting b since the record field is not in scope, +and omitting c since the variable c +is not in scope (apart from the binding of the +record selector c, of course). + + + +Record wildcards cannot be used (a) in a record update construct, and (b) for data +constructors that are not declared with record fields. For example: + +f x = x { v=True, .. } -- Illegal (a) + +data T = MkT Int Bool +g = MkT { .. } -- Illegal (b) +h (MkT { .. }) = True -- Illegal (b) + + + + + + + + + + +Local Fixity Declarations + + +A careful reading of the Haskell 98 Report reveals that fixity +declarations (infix, infixl, and +infixr) are permitted to appear inside local bindings +such those introduced by let and +where. However, the Haskell Report does not specify +the semantics of such bindings very precisely. + + +In GHC, a fixity declaration may accompany a local binding: + +let f = ... + infixr 3 `f` +in + ... + +and the fixity declaration applies wherever the binding is in scope. +For example, in a let, it applies in the right-hand +sides of other let-bindings and the body of the +letC. Or, in recursive do +expressions (), the local fixity +declarations of a let statement scope over other +statements in the group, just as the bound name does. + + + +Moreover, a local fixity declaration *must* accompany a local binding of +that name: it is not possible to revise the fixity of name bound +elsewhere, as in + +let infixr 9 $ in ... + + +Because local fixity declarations are technically Haskell 98, no flag is +necessary to enable them. + + + + +Import and export extensions + + + Hiding things the imported module doesn't export + + +Technically in Haskell 2010 this is illegal: + +module A( f ) where + f = True + +module B where + import A hiding( g ) -- A does not export g + g = f + +The import A hiding( g ) in module B +is technically an error (Haskell Report, 5.3.1) +because A does not export g. +However GHC allows it, in the interests of supporting backward compatibility; for example, a newer version of +A might export g, and you want B to work +in either case. + + +The warning -fwarn-dodgy-imports, which is off by default but included with -W, +warns if you hide something that the imported module does not export. + + + + + Package-qualified imports + + With the flag, GHC allows + import declarations to be qualified by the package name that the + module is intended to be imported from. For example: + + +import "network" Network.Socket + + + would import the module Network.Socket from + the package network (any version). This may + be used to disambiguate an import when the same module is + available from multiple packages, or is present in both the + current package being built and an external package. + + The special package name this can be used to + refer to the current package being built. + + Note: you probably don't need to use this feature, it was + added mainly so that we can build backwards-compatible versions of + packages when APIs change. It can lead to fragile dependencies in + the common case: modules occasionally move from one package to + another, rendering any package-qualified imports broken. + See also for + an alternative way of disambiguating between module names. + + + + Safe imports + + With the , + and language flags, GHC extends + the import declaration syntax to take an optional safe + keyword after the import keyword. This feature + is part of the Safe Haskell GHC extension. For example: + + +import safe qualified Network.Socket as NS + + + would import the module Network.Socket + with compilation only succeeding if Network.Socket can be + safely imported. For a description of when a import is + considered safe see + + + + +Explicit namespaces in import/export + + In an import or export list, such as + + module M( f, (++) ) where ... + import N( f, (++) ) + ... + +the entities f and (++) are values. +However, with type operators () it becomes possible +to declare (++) as a type constructor. In that +case, how would you export or import it? + + +The extension allows you to prefix the name of +a type constructor in an import or export list with "type" to +disambiguate this case, thus: + + module M( f, type (++) ) where ... + import N( f, type (++) ) + ... + module N( f, type (++) ) where + data family a ++ b = L a | R b + +The extension +is implied by and (for some reason) by . + + +In addition, with you can prefix the name of +a data constructor in an import or export list with the keyword pattern, +to allow the import or export of a data constructor without its parent type constructor +(see ). + + + + + + +Summary of stolen syntax + + Turning on an option that enables special syntax + might cause working Haskell 98 code to fail + to compile, perhaps because it uses a variable name which has + become a reserved word. This section lists the syntax that is + "stolen" by language extensions. + We use + notation and nonterminal names from the Haskell 98 lexical syntax + (see the Haskell 98 Report). + We only list syntax changes here that might affect + existing working programs (i.e. "stolen" syntax). Many of these + extensions will also enable new context-free syntax, but in all + cases programs written to use the new syntax would not be + compilable without the option enabled. + +There are two classes of special + syntax: + + + + New reserved words and symbols: character sequences + which are no longer available for use as identifiers in the + program. + + + Other special syntax: sequences of characters that have + a different meaning when this particular option is turned + on. + + + +The following syntax is stolen: + + + + + forall + forall + + + Stolen (in types) by: , and hence by + , + , + , + + + + + + + mdo + mdo + + + Stolen by: + + + + + + foreign + foreign + + + Stolen by: + + + + + + rec, + proc, -<, + >-, -<<, + >>-, and (|, + |) brackets + proc + + + Stolen by: + + + + + + ?varid + implicit parameters + + + Stolen by: + + + + + + [|, + [e|, [p|, + [d|, [t|, + $(, + $$(, + [||, + [e||, + $varid, + $$varid + Template Haskell + + + Stolen by: + + + + + + [varid| + quasi-quotation + + + Stolen by: + + + + + + varid{#}, + char#, + string#, + integer#, + float#, + float## + + + Stolen by: + + + + + + (#, #) + + + Stolen by: + + + + + + varid!varid + + + Stolen by: + + + + + + pattern + + + Stolen by: + + + + + + + + + + +Extensions to data types and type synonyms + + +Data types with no constructors + +With the flag (or equivalent LANGUAGE pragma), +GHC lets you declare a data type with no constructors. For example: + + + data S -- S :: * + data T a -- T :: * -> * + + +Syntactically, the declaration lacks the "= constrs" part. The +type can be parameterised over types of any kind, but if the kind is +not * then an explicit kind annotation must be used +(see ). + +Such data types have only one value, namely bottom. +Nevertheless, they can be useful when defining "phantom types". + + + +Data type contexts + +Haskell allows datatypes to be given contexts, e.g. + + +data Eq a => Set a = NilSet | ConsSet a (Set a) + + +give constructors with types: + + +NilSet :: Set a +ConsSet :: Eq a => a -> Set a -> Set a + + +This is widely considered a misfeature, and is going to be removed from +the language. In GHC, it is controlled by the deprecated extension +DatatypeContexts. + + + +Infix type constructors, classes, and type variables + + +GHC allows type constructors, classes, and type variables to be operators, and +to be written infix, very much like expressions. More specifically: + + + A type constructor or class can be any non-reserved operator. + Symbols used in types are always like capitalized identifiers; they + are never variables. Note that this is different from the lexical + syntax of data constructors, which are required to begin with a + :. + + + Data type and type-synonym declarations can be written infix, parenthesised + if you want further arguments. E.g. + + data a :*: b = Foo a b + type a :+: b = Either a b + class a :=: b where ... + + data (a :**: b) x = Baz a b x + type (a :++: b) y = Either (a,b) y + + + + Types, and class constraints, can be written infix. For example + + x :: Int :*: Bool + f :: (a :=: b) => a -> b + + + + Back-quotes work + as for expressions, both for type constructors and type variables; e.g. Int `Either` Bool, or + Int `a` Bool. Similarly, parentheses work the same; e.g. (:*:) Int Bool. + + + Fixities may be declared for type constructors, or classes, just as for data constructors. However, + one cannot distinguish between the two in a fixity declaration; a fixity declaration + sets the fixity for a data constructor and the corresponding type constructor. For example: + + infixl 7 T, :*: + + sets the fixity for both type constructor T and data constructor T, + and similarly for :*:. + Int `a` Bool. + + + Function arrow is infixr with fixity 0. (This might change; I'm not sure what it should be.) + + + + + + + +Type operators + +In types, an operator symbol like (+) is normally treated as a type +variable, just like a. Thus in Haskell 98 you can say + +type T (+) = ((+), (+)) +-- Just like: type T a = (a,a) + +f :: T Int -> Int +f (x,y)= x + +As you can see, using operators in this way is not very useful, and Haskell 98 does not even +allow you to write them infix. + + +The language changes this behaviour: + + +Operator symbols become type constructors rather than +type variables. + + +Operator symbols in types can be written infix, both in definitions and uses. +for example: + +data a + b = Plus a b +type Foo = Int + Bool + + + +There is now some potential ambiguity in import and export lists; for example +if you write import M( (+) ) do you mean the +function (+) or the +type constructor (+)? +The default is the former, but with (which is implied +by ) GHC allows you to specify the latter +by preceding it with the keyword type, thus: + +import M( type (+) ) + +See . + + +The fixity of a type operator may be set using the usual fixity declarations +but, as in , the function and type constructor share +a single fixity. + + + + + + +Liberalised type synonyms + + +Type synonyms are like macros at the type level, but Haskell 98 imposes many rules +on individual synonym declarations. +With the extension, +GHC does validity checking on types only after expanding type synonyms. +That means that GHC can be very much more liberal about type synonyms than Haskell 98. + + + You can write a forall (including overloading) +in a type synonym, thus: + + type Discard a = forall b. Show b => a -> b -> (a, String) + + f :: Discard a + f x y = (x, show y) + + g :: Discard Int -> (Int,String) -- A rank-2 type + g f = f 3 True + + + + + +If you also use , +you can write an unboxed tuple in a type synonym: + + type Pr = (# Int, Int #) + + h :: Int -> Pr + h x = (# x, x #) + + + + +You can apply a type synonym to a forall type: + + type Foo a = a -> a -> Bool + + f :: Foo (forall b. b->b) + +After expanding the synonym, f has the legal (in GHC) type: + + f :: (forall b. b->b) -> (forall b. b->b) -> Bool + + + + +You can apply a type synonym to a partially applied type synonym: + + type Generic i o = forall x. i x -> o x + type Id x = x + + foo :: Generic Id [] + +After expanding the synonym, foo has the legal (in GHC) type: + + foo :: forall x. x -> [x] + + + + + + + +GHC currently does kind checking before expanding synonyms (though even that +could be changed.) + + +After expanding type synonyms, GHC does validity checking on types, looking for +the following mal-formedness which isn't detected simply by kind checking: + + +Type constructor applied to a type involving for-alls (if XImpredicativeTypes +is off) + + +Partially-applied type synonym. + + +So, for example, this will be rejected: + + type Pr = forall a. a + + h :: [Pr] + h = ... + +because GHC does not allow type constructors applied to for-all types. + + + + + +Existentially quantified data constructors + + + +The idea of using existential quantification in data type declarations +was suggested by Perry, and implemented in Hope+ (Nigel Perry, The Implementation +of Practical Functional Programming Languages, PhD Thesis, University of +London, 1991). It was later formalised by Laufer and Odersky +(Polymorphic type inference and abstract data types, +TOPLAS, 16(5), pp1411-1430, 1994). +It's been in Lennart +Augustsson's hbc Haskell compiler for several years, and +proved very useful. Here's the idea. Consider the declaration: + + + + + + data Foo = forall a. MkFoo a (a -> Bool) + | Nil + + + + + +The data type Foo has two constructors with types: + + + + + + MkFoo :: forall a. a -> (a -> Bool) -> Foo + Nil :: Foo + + + + + +Notice that the type variable a in the type of MkFoo +does not appear in the data type itself, which is plain Foo. +For example, the following expression is fine: + + + + + + [MkFoo 3 even, MkFoo 'c' isUpper] :: [Foo] + + + + + +Here, (MkFoo 3 even) packages an integer with a function +even that maps an integer to Bool; and MkFoo 'c' +isUpper packages a character with a compatible function. These +two things are each of type Foo and can be put in a list. + + + +What can we do with a value of type Foo?. In particular, +what happens when we pattern-match on MkFoo? + + + + + + f (MkFoo val fn) = ??? + + + + + +Since all we know about val and fn is that they +are compatible, the only (useful) thing we can do with them is to +apply fn to val to get a boolean. For example: + + + + + + f :: Foo -> Bool + f (MkFoo val fn) = fn val + + + + + +What this allows us to do is to package heterogeneous values +together with a bunch of functions that manipulate them, and then treat +that collection of packages in a uniform manner. You can express +quite a bit of object-oriented-like programming this way. + + + +Why existential? + + + +What has this to do with existential quantification? +Simply that MkFoo has the (nearly) isomorphic type + + + + + + MkFoo :: (exists a . (a, a -> Bool)) -> Foo + + + + + +But Haskell programmers can safely think of the ordinary +universally quantified type given above, thereby avoiding +adding a new existential quantification construct. + + + + + +Existentials and type classes + + +An easy extension is to allow +arbitrary contexts before the constructor. For example: + + + + + +data Baz = forall a. Eq a => Baz1 a a + | forall b. Show b => Baz2 b (b -> b) + + + + + +The two constructors have the types you'd expect: + + + + + +Baz1 :: forall a. Eq a => a -> a -> Baz +Baz2 :: forall b. Show b => b -> (b -> b) -> Baz + + + + + +But when pattern matching on Baz1 the matched values can be compared +for equality, and when pattern matching on Baz2 the first matched +value can be converted to a string (as well as applying the function to it). +So this program is legal: + + + + + + f :: Baz -> String + f (Baz1 p q) | p == q = "Yes" + | otherwise = "No" + f (Baz2 v fn) = show (fn v) + + + + + +Operationally, in a dictionary-passing implementation, the +constructors Baz1 and Baz2 must store the +dictionaries for Eq and Show respectively, and +extract it on pattern matching. + + + + + +Record Constructors + + +GHC allows existentials to be used with records syntax as well. For example: + + +data Counter a = forall self. NewCounter + { _this :: self + , _inc :: self -> self + , _display :: self -> IO () + , tag :: a + } + +Here tag is a public field, with a well-typed selector +function tag :: Counter a -> a. The self +type is hidden from the outside; any attempt to apply _this, +_inc or _display as functions will raise a +compile-time error. In other words, GHC defines a record selector function +only for fields whose type does not mention the existentially-quantified variables. +(This example used an underscore in the fields for which record selectors +will not be defined, but that is only programming style; GHC ignores them.) + + + +To make use of these hidden fields, we need to create some helper functions: + + +inc :: Counter a -> Counter a +inc (NewCounter x i d t) = NewCounter + { _this = i x, _inc = i, _display = d, tag = t } + +display :: Counter a -> IO () +display NewCounter{ _this = x, _display = d } = d x + + +Now we can define counters with different underlying implementations: + + +counterA :: Counter String +counterA = NewCounter + { _this = 0, _inc = (1+), _display = print, tag = "A" } + +counterB :: Counter String +counterB = NewCounter + { _this = "", _inc = ('#':), _display = putStrLn, tag = "B" } + +main = do + display (inc counterA) -- prints "1" + display (inc (inc counterB)) -- prints "##" + + +Record update syntax is supported for existentials (and GADTs): + +setTag :: Counter a -> a -> Counter a +setTag obj t = obj{ tag = t } + +The rule for record update is this: +the types of the updated fields may +mention only the universally-quantified type variables +of the data constructor. For GADTs, the field may mention only types +that appear as a simple type-variable argument in the constructor's result +type. For example: + +data T a b where { T1 { f1::a, f2::b, f3::(b,c) } :: T a b } -- c is existential +upd1 t x = t { f1=x } -- OK: upd1 :: T a b -> a' -> T a' b +upd2 t x = t { f3=x } -- BAD (f3's type mentions c, which is + -- existentially quantified) + +data G a b where { G1 { g1::a, g2::c } :: G a [c] } +upd3 g x = g { g1=x } -- OK: upd3 :: G a b -> c -> G c b +upd4 g x = g { g2=x } -- BAD (f2's type mentions c, which is not a simple + -- type-variable argument in G1's result type) + + + + + + + +Restrictions + + +There are several restrictions on the ways in which existentially-quantified +constructors can be use. + + + + + + + + + When pattern matching, each pattern match introduces a new, +distinct, type for each existential type variable. These types cannot +be unified with any other type, nor can they escape from the scope of +the pattern match. For example, these fragments are incorrect: + + + +f1 (MkFoo a f) = a + + + +Here, the type bound by MkFoo "escapes", because a +is the result of f1. One way to see why this is wrong is to +ask what type f1 has: + + + + f1 :: Foo -> a -- Weird! + + + +What is this "a" in the result type? Clearly we don't mean +this: + + + + f1 :: forall a. Foo -> a -- Wrong! + + + +The original program is just plain wrong. Here's another sort of error + + + + f2 (Baz1 a b) (Baz1 p q) = a==q + + + +It's ok to say a==b or p==q, but +a==q is wrong because it equates the two distinct types arising +from the two Baz1 constructors. + + + + + + + +You can't pattern-match on an existentially quantified +constructor in a let or where group of +bindings. So this is illegal: + + + + f3 x = a==b where { Baz1 a b = x } + + +Instead, use a case expression: + + + f3 x = case x of Baz1 a b -> a==b + + +In general, you can only pattern-match +on an existentially-quantified constructor in a case expression or +in the patterns of a function definition. + +The reason for this restriction is really an implementation one. +Type-checking binding groups is already a nightmare without +existentials complicating the picture. Also an existential pattern +binding at the top level of a module doesn't make sense, because it's +not clear how to prevent the existentially-quantified type "escaping". +So for now, there's a simple-to-state restriction. We'll see how +annoying it is. + + + + + + +You can't use existential quantification for newtype +declarations. So this is illegal: + + + + newtype T = forall a. Ord a => MkT a + + + +Reason: a value of type T must be represented as a +pair of a dictionary for Ord t and a value of type +t. That contradicts the idea that +newtype should have no concrete representation. +You can get just the same efficiency and effect by using +data instead of newtype. If +there is no overloading involved, then there is more of a case for +allowing an existentially-quantified newtype, +because the data version does carry an +implementation cost, but single-field existentially quantified +constructors aren't much use. So the simple restriction (no +existential stuff on newtype) stands, unless there +are convincing reasons to change it. + + + + + + + + You can't use deriving to define instances of a +data type with existentially quantified data constructors. + +Reason: in most cases it would not make sense. For example:; + + +data T = forall a. MkT [a] deriving( Eq ) + + +To derive Eq in the standard way we would need to have equality +between the single component of two MkT constructors: + + +instance Eq T where + (MkT a) == (MkT b) = ??? + + +But a and b have distinct types, and so can't be compared. +It's just about possible to imagine examples in which the derived instance +would make sense, but it seems altogether simpler simply to prohibit such +declarations. Define your own instances! + + + + + + + + + + + + + +Declaring data types with explicit constructor signatures + +When the GADTSyntax extension is enabled, +GHC allows you to declare an algebraic data type by +giving the type signatures of constructors explicitly. For example: + + data Maybe a where + Nothing :: Maybe a + Just :: a -> Maybe a + +The form is called a "GADT-style declaration" +because Generalised Algebraic Data Types, described in , +can only be declared using this form. +Notice that GADT-style syntax generalises existential types (). +For example, these two declarations are equivalent: + + data Foo = forall a. MkFoo a (a -> Bool) + data Foo' where { MKFoo :: a -> (a->Bool) -> Foo' } + + +Any data type that can be declared in standard Haskell-98 syntax +can also be declared using GADT-style syntax. +The choice is largely stylistic, but GADT-style declarations differ in one important respect: +they treat class constraints on the data constructors differently. +Specifically, if the constructor is given a type-class context, that +context is made available by pattern matching. For example: + + data Set a where + MkSet :: Eq a => [a] -> Set a + + makeSet :: Eq a => [a] -> Set a + makeSet xs = MkSet (nub xs) + + insert :: a -> Set a -> Set a + insert a (MkSet as) | a `elem` as = MkSet as + | otherwise = MkSet (a:as) + +A use of MkSet as a constructor (e.g. in the definition of makeSet) +gives rise to a (Eq a) +constraint, as you would expect. The new feature is that pattern-matching on MkSet +(as in the definition of insert) makes available an (Eq a) +context. In implementation terms, the MkSet constructor has a hidden field that stores +the (Eq a) dictionary that is passed to MkSet; so +when pattern-matching that dictionary becomes available for the right-hand side of the match. +In the example, the equality dictionary is used to satisfy the equality constraint +generated by the call to elem, so that the type of +insert itself has no Eq constraint. + + +For example, one possible application is to reify dictionaries: + + data NumInst a where + MkNumInst :: Num a => NumInst a + + intInst :: NumInst Int + intInst = MkNumInst + + plus :: NumInst a -> a -> a -> a + plus MkNumInst p q = p + q + +Here, a value of type NumInst a is equivalent +to an explicit (Num a) dictionary. + + +All this applies to constructors declared using the syntax of . +For example, the NumInst data type above could equivalently be declared +like this: + + data NumInst a + = Num a => MkNumInst (NumInst a) + +Notice that, unlike the situation when declaring an existential, there is +no forall, because the Num constrains the +data type's universally quantified type variable a. +A constructor may have both universal and existential type variables: for example, +the following two declarations are equivalent: + + data T1 a + = forall b. (Num a, Eq b) => MkT1 a b + data T2 a where + MkT2 :: (Num a, Eq b) => a -> b -> T2 a + + +All this behaviour contrasts with Haskell 98's peculiar treatment of +contexts on a data type declaration (Section 4.2.1 of the Haskell 98 Report). +In Haskell 98 the definition + + data Eq a => Set' a = MkSet' [a] + +gives MkSet' the same type as MkSet above. But instead of +making available an (Eq a) constraint, pattern-matching +on MkSet' requires an (Eq a) constraint! +GHC faithfully implements this behaviour, odd though it is. But for GADT-style declarations, +GHC's behaviour is much more useful, as well as much more intuitive. + + + +The rest of this section gives further details about GADT-style data +type declarations. + + + +The result type of each data constructor must begin with the type constructor being defined. +If the result type of all constructors +has the form T a1 ... an, where a1 ... an +are distinct type variables, then the data type is ordinary; +otherwise is a generalised data type (). + + + +As with other type signatures, you can give a single signature for several data constructors. +In this example we give a single signature for T1 and T2: + + data T a where + T1,T2 :: a -> T a + T3 :: T a + + + + +The type signature of +each constructor is independent, and is implicitly universally quantified as usual. +In particular, the type variable(s) in the "data T a where" header +have no scope, and different constructors may have different universally-quantified type variables: + + data T a where -- The 'a' has no scope + T1,T2 :: b -> T b -- Means forall b. b -> T b + T3 :: T a -- Means forall a. T a + + + + +A constructor signature may mention type class constraints, which can differ for +different constructors. For example, this is fine: + + data T a where + T1 :: Eq b => b -> b -> T b + T2 :: (Show c, Ix c) => c -> [c] -> T c + +When pattern matching, these constraints are made available to discharge constraints +in the body of the match. For example: + + f :: T a -> String + f (T1 x y) | x==y = "yes" + | otherwise = "no" + f (T2 a b) = show a + +Note that f is not overloaded; the Eq constraint arising +from the use of == is discharged by the pattern match on T1 +and similarly the Show constraint arising from the use of show. + + + +Unlike a Haskell-98-style +data type declaration, the type variable(s) in the "data Set a where" header +have no scope. Indeed, one can write a kind signature instead: + + data Set :: * -> * where ... + +or even a mixture of the two: + + data Bar a :: (* -> *) -> * where ... + +The type variables (if given) may be explicitly kinded, so we could also write the header for Foo +like this: + + data Bar a (b :: * -> *) where ... + + + + + +You can use strictness annotations, in the obvious places +in the constructor type: + + data Term a where + Lit :: !Int -> Term Int + If :: Term Bool -> !(Term a) -> !(Term a) -> Term a + Pair :: Term a -> Term b -> Term (a,b) + + + + +You can use a deriving clause on a GADT-style data type +declaration. For example, these two declarations are equivalent + + data Maybe1 a where { + Nothing1 :: Maybe1 a ; + Just1 :: a -> Maybe1 a + } deriving( Eq, Ord ) + + data Maybe2 a = Nothing2 | Just2 a + deriving( Eq, Ord ) + + + + +The type signature may have quantified type variables that do not appear +in the result type: + + data Foo where + MkFoo :: a -> (a->Bool) -> Foo + Nil :: Foo + +Here the type variable a does not appear in the result type +of either constructor. +Although it is universally quantified in the type of the constructor, such +a type variable is often called "existential". +Indeed, the above declaration declares precisely the same type as +the data Foo in . + +The type may contain a class context too, of course: + + data Showable where + MkShowable :: Show a => a -> Showable + + + + +You can use record syntax on a GADT-style data type declaration: + + + data Person where + Adult :: { name :: String, children :: [Person] } -> Person + Child :: Show a => { name :: !String, funny :: a } -> Person + +As usual, for every constructor that has a field f, the type of +field f must be the same (modulo alpha conversion). +The Child constructor above shows that the signature +may have a context, existentially-quantified variables, and strictness annotations, +just as in the non-record case. (NB: the "type" that follows the double-colon +is not really a type, because of the record syntax and strictness annotations. +A "type" of this form can appear only in a constructor signature.) + + + +Record updates are allowed with GADT-style declarations, +only fields that have the following property: the type of the field +mentions no existential type variables. + + + +As in the case of existentials declared using the Haskell-98-like record syntax +(), +record-selector functions are generated only for those fields that have well-typed +selectors. +Here is the example of that section, in GADT-style syntax: + +data Counter a where + NewCounter :: { _this :: self + , _inc :: self -> self + , _display :: self -> IO () + , tag :: a + } -> Counter a + +As before, only one selector function is generated here, that for tag. +Nevertheless, you can still use all the field names in pattern matching and record construction. + + + +In a GADT-style data type declaration there is no obvious way to specify that a data constructor +should be infix, which makes a difference if you derive Show for the type. +(Data constructors declared infix are displayed infix by the derived show.) +So GHC implements the following design: a data constructor declared in a GADT-style data type +declaration is displayed infix by Show iff (a) it is an operator symbol, +(b) it has two arguments, (c) it has a programmer-supplied fixity declaration. For example + + infix 6 (:--:) + data T a where + (:--:) :: Int -> Bool -> T Int + + + + + + +Generalised Algebraic Data Types (GADTs) + +Generalised Algebraic Data Types generalise ordinary algebraic data types +by allowing constructors to have richer return types. Here is an example: + + data Term a where + Lit :: Int -> Term Int + Succ :: Term Int -> Term Int + IsZero :: Term Int -> Term Bool + If :: Term Bool -> Term a -> Term a -> Term a + Pair :: Term a -> Term b -> Term (a,b) + +Notice that the return type of the constructors is not always Term a, as is the +case with ordinary data types. This generality allows us to +write a well-typed eval function +for these Terms: + + eval :: Term a -> a + eval (Lit i) = i + eval (Succ t) = 1 + eval t + eval (IsZero t) = eval t == 0 + eval (If b e1 e2) = if eval b then eval e1 else eval e2 + eval (Pair e1 e2) = (eval e1, eval e2) + +The key point about GADTs is that pattern matching causes type refinement. +For example, in the right hand side of the equation + + eval :: Term a -> a + eval (Lit i) = ... + +the type a is refined to Int. That's the whole point! +A precise specification of the type rules is beyond what this user manual aspires to, +but the design closely follows that described in +the paper Simple +unification-based type inference for GADTs, +(ICFP 2006). +The general principle is this: type refinement is only carried out +based on user-supplied type annotations. +So if no type signature is supplied for eval, no type refinement happens, +and lots of obscure error messages will +occur. However, the refinement is quite general. For example, if we had: + + eval :: Term a -> a -> a + eval (Lit i) j = i+j + +the pattern match causes the type a to be refined to Int (because of the type +of the constructor Lit), and that refinement also applies to the type of j, and +the result type of the case expression. Hence the addition i+j is legal. + + +These and many other examples are given in papers by Hongwei Xi, and +Tim Sheard. There is a longer introduction +on the wiki, +and Ralf Hinze's +Fun with phantom types also has a number of examples. Note that papers +may use different notation to that implemented in GHC. + + +The rest of this section outlines the extensions to GHC that support GADTs. The extension is enabled with +. The flag also sets +and . + + +A GADT can only be declared using GADT-style syntax (); +the old Haskell-98 syntax for data declarations always declares an ordinary data type. +The result type of each constructor must begin with the type constructor being defined, +but for a GADT the arguments to the type constructor can be arbitrary monotypes. +For example, in the Term data +type above, the type of each constructor must end with Term ty, but +the ty need not be a type variable (e.g. the Lit +constructor). + + + +It is permitted to declare an ordinary algebraic data type using GADT-style syntax. +What makes a GADT into a GADT is not the syntax, but rather the presence of data constructors +whose result type is not just T a b. + + + +You cannot use a deriving clause for a GADT; only for +an ordinary data type. + + + +As mentioned in , record syntax is supported. +For example: + + data Term a where + Lit :: { val :: Int } -> Term Int + Succ :: { num :: Term Int } -> Term Int + Pred :: { num :: Term Int } -> Term Int + IsZero :: { arg :: Term Int } -> Term Bool + Pair :: { arg1 :: Term a + , arg2 :: Term b + } -> Term (a,b) + If :: { cnd :: Term Bool + , tru :: Term a + , fls :: Term a + } -> Term a + +However, for GADTs there is the following additional constraint: +every constructor that has a field f must have +the same result type (modulo alpha conversion) +Hence, in the above example, we cannot merge the num +and arg fields above into a +single name. Although their field types are both Term Int, +their selector functions actually have different types: + + + num :: Term Int -> Term Int + arg :: Term Bool -> Term Int + + + + +When pattern-matching against data constructors drawn from a GADT, +for example in a case expression, the following rules apply: + +The type of the scrutinee must be rigid. +The type of the entire case expression must be rigid. +The type of any free variable mentioned in any of +the case alternatives must be rigid. + +A type is "rigid" if it is completely known to the compiler at its binding site. The easiest +way to ensure that a variable a rigid type is to give it a type signature. +For more precise details see +Simple unification-based type inference for GADTs +. The criteria implemented by GHC are given in the Appendix. + + + + + + + + + + + + +Extensions to the "deriving" mechanism + + +Inferred context for deriving clauses + + +The Haskell Report is vague about exactly when a deriving clause is +legal. For example: + + data T0 f a = MkT0 a deriving( Eq ) + data T1 f a = MkT1 (f a) deriving( Eq ) + data T2 f a = MkT2 (f (f a)) deriving( Eq ) + +The natural generated Eq code would result in these instance declarations: + + instance Eq a => Eq (T0 f a) where ... + instance Eq (f a) => Eq (T1 f a) where ... + instance Eq (f (f a)) => Eq (T2 f a) where ... + +The first of these is obviously fine. The second is still fine, although less obviously. +The third is not Haskell 98, and risks losing termination of instances. + + +GHC takes a conservative position: it accepts the first two, but not the third. The rule is this: +each constraint in the inferred instance context must consist only of type variables, +with no repetitions. + + +This rule is applied regardless of flags. If you want a more exotic context, you can write +it yourself, using the standalone deriving mechanism. + + + + +Stand-alone deriving declarations + + +GHC now allows stand-alone deriving declarations, enabled by -XStandaloneDeriving: + + data Foo a = Bar a | Baz String + + deriving instance Eq a => Eq (Foo a) + +The syntax is identical to that of an ordinary instance declaration apart from (a) the keyword +deriving, and (b) the absence of the where part. + + +However, standalone deriving differs from a deriving clause in a number +of important ways: + +The standalone deriving declaration does not need to be in the +same module as the data type declaration. (But be aware of the dangers of +orphan instances (). + + + +You must supply an explicit context (in the example the context is (Eq a)), +exactly as you would in an ordinary instance declaration. +(In contrast, in a deriving clause +attached to a data type declaration, the context is inferred.) + + + +Unlike a deriving +declaration attached to a data declaration, the instance can be more specific +than the data type (assuming you also use +-XFlexibleInstances, ). Consider +for example + + data Foo a = Bar a | Baz String + + deriving instance Eq a => Eq (Foo [a]) + deriving instance Eq a => Eq (Foo (Maybe a)) + +This will generate a derived instance for (Foo [a]) and (Foo (Maybe a)), +but other types such as (Foo (Int,Bool)) will not be an instance of Eq. + + + +Unlike a deriving +declaration attached to a data declaration, +GHC does not restrict the form of the data type. Instead, GHC simply generates the appropriate +boilerplate code for the specified class, and typechecks it. If there is a type error, it is +your problem. (GHC will show you the offending code if it has a type error.) + + +The merit of this is that you can derive instances for GADTs and other exotic +data types, providing only that the boilerplate code does indeed typecheck. For example: + + data T a where + T1 :: T Int + T2 :: T Bool + + deriving instance Show (T a) + +In this example, you cannot say ... deriving( Show ) on the +data type declaration for T, +because T is a GADT, but you can generate +the instance declaration using stand-alone deriving. + + +The down-side is that, +if the boilerplate code fails to typecheck, you will get an error message about that +code, which you did not write. Whereas, with a deriving clause +the side-conditions are necessarily more conservative, but any error message +may be more comprehensible. + + + + + +In other ways, however, a standalone deriving obeys the same rules as ordinary deriving: + + +A deriving instance declaration +must obey the same rules concerning form and termination as ordinary instance declarations, +controlled by the same flags; see . + + + +The stand-alone syntax is generalised for newtypes in exactly the same +way that ordinary deriving clauses are generalised (). +For example: + + newtype Foo a = MkFoo (State Int a) + + deriving instance MonadState Int Foo + +GHC always treats the last parameter of the instance +(Foo in this example) as the type whose instance is being derived. + + + + + + +Deriving instances of extra classes (<literal>Data</literal>, etc) + + +Haskell 98 allows the programmer to add "deriving( Eq, Ord )" to a data type +declaration, to generate a standard instance declaration for classes specified in the deriving clause. +In Haskell 98, the only classes that may appear in the deriving clause are the standard +classes Eq, Ord, +Enum, Ix, Bounded, Read, and Show. + + +GHC extends this list with several more classes that may be automatically derived: + + With , you can derive +instances of the classes Generic and +Generic1, defined in GHC.Generics. +You can use these to define generic functions, +as described in . + + + With , you can derive instances of +the class Functor, +defined in GHC.Base. + + + With , you can derive instances of +the class Data, +defined in Data.Data. See for +deriving Typeable. + + + With , you can derive instances of +the class Foldable, +defined in Data.Foldable. + + + With , you can derive instances of +the class Traversable, +defined in Data.Traversable. Since the Traversable +instance dictates the instances of Functor and +Foldable, you'll probably want to derive them too, so + implies + and . + + +You can also use a standalone deriving declaration instead +(see ). + + +In each case the appropriate class must be in scope before it +can be mentioned in the deriving clause. + + + + +Deriving <literal>Typeable</literal> instances + +The class Typeable is very special: + + +Typeable is kind-polymorphic (see +). + + + +GHC has a custom solver for discharging constraints that involve +class Typeable, and handwritten instances are forbidden. +This ensures that the programmer cannot subert the type system by +writing bogus instances. + + + +Derived instances of Typeable are ignored, +and may be reported as an error in a later version of the compiler. + + + +The rules for solving `Typeable` constraints are as follows: + +A concrete type constructor applied to some types. + +instance (Typeable t1, .., Typeable t_n) => + Typeable (T t1 .. t_n) + +This rule works for any concrete type constructor, including type +constructors with polymorhic kinds. The only restriction is that +if the type constructor has a polymorhic kind, then it has to be applied +to all of its kinds parameters, and these kinds need to be concrete +(i.e., they cannot mention kind variables). + + + +A type variable applied to some types. +instance (Typeable f, Typeable t1, .., Typeable t_n) => + Typeable (f t1 .. t_n) + + + + +A concrete type literal. +instance Typeable 0 -- Type natural literals +instance Typeable "Hello" -- Type-level symbols + + + + + + + + + + + + + +Generalised derived instances for newtypes + + +When you define an abstract type using newtype, you may want +the new type to inherit some instances from its representation. In +Haskell 98, you can inherit instances of Eq, Ord, +Enum and Bounded by deriving them, but for any +other classes you have to write an explicit instance declaration. For +example, if you define + + + newtype Dollars = Dollars Int + + +and you want to use arithmetic on Dollars, you have to +explicitly define an instance of Num: + + + instance Num Dollars where + Dollars a + Dollars b = Dollars (a+b) + ... + +All the instance does is apply and remove the newtype +constructor. It is particularly galling that, since the constructor +doesn't appear at run-time, this instance declaration defines a +dictionary which is wholly equivalent to the Int +dictionary, only slower! + + + + Generalising the deriving clause + +GHC now permits such instances to be derived instead, +using the flag , +so one can write + + newtype Dollars = Dollars Int deriving (Eq,Show,Num) + + +and the implementation uses the same Num dictionary +for Dollars as for Int. Notionally, the compiler +derives an instance declaration of the form + + + instance Num Int => Num Dollars + + +which just adds or removes the newtype constructor according to the type. + + + +We can also derive instances of constructor classes in a similar +way. For example, suppose we have implemented state and failure monad +transformers, such that + + + instance Monad m => Monad (State s m) + instance Monad m => Monad (Failure m) + +In Haskell 98, we can define a parsing monad by + + type Parser tok m a = State [tok] (Failure m) a + + +which is automatically a monad thanks to the instance declarations +above. With the extension, we can make the parser type abstract, +without needing to write an instance of class Monad, via + + + newtype Parser tok m a = Parser (State [tok] (Failure m) a) + deriving Monad + +In this case the derived instance declaration is of the form + + instance Monad (State [tok] (Failure m)) => Monad (Parser tok m) + + +Notice that, since Monad is a constructor class, the +instance is a partial application of the new type, not the +entire left hand side. We can imagine that the type declaration is +"eta-converted" to generate the context of the instance +declaration. + + + +We can even derive instances of multi-parameter classes, provided the +newtype is the last class parameter. In this case, a ``partial +application'' of the class appears in the deriving +clause. For example, given the class + + + class StateMonad s m | m -> s where ... + instance Monad m => StateMonad s (State s m) where ... + +then we can derive an instance of StateMonad for Parsers by + + newtype Parser tok m a = Parser (State [tok] (Failure m) a) + deriving (Monad, StateMonad [tok]) + + +The derived instance is obtained by completing the application of the +class to the new type: + + + instance StateMonad [tok] (State [tok] (Failure m)) => + StateMonad [tok] (Parser tok m) + + + + +As a result of this extension, all derived instances in newtype + declarations are treated uniformly (and implemented just by reusing +the dictionary for the representation type), except +Show and Read, which really behave differently for +the newtype and its representation. + + + + A more precise specification + +A derived instance is derived only for declarations of these forms (after expansion of any type synonyms) + + + newtype T v1..vn = MkT (t vk+1..vn) deriving (C t1..tj) + newtype instance T s1..sk vk+1..vn = MkT (t vk+1..vn) deriving (C t1..tj) + +where + + +v1..vn are type variables, and t, +s1..sk, t1..tj are types. + + + The (C t1..tj) is a partial applications of the class C, + where the arity of C + is exactly j+1. That is, C lacks exactly one type argument. + + + k is chosen so that C t1..tj (T v1...vk) is well-kinded. +(Or, in the case of a data instance, so that C t1..tj (T s1..sk) is +well kinded.) + + + The type t is an arbitrary type. + + + The type variables vk+1...vn do not occur in the types t, + s1..sk, or t1..tj. + + + C is not Read, Show, + Typeable, or Data. These classes + should not "look through" the type or its constructor. You can still + derive these classes for a newtype, but it happens in the usual way, not + via this new mechanism. + + + It is safe to coerce each of the methods of C. That is, + the missing last argument to C is not used + at a nominal role in any of the C's methods. + (See .) + +Then the derived instance is of form +declaration is: + + instance C t1..tj t => C t1..tj (T v1...vk) + +As an example which does not work, consider + + newtype NonMonad m s = NonMonad (State s m s) deriving Monad + +Here we cannot derive the instance + + instance Monad (State s m) => Monad (NonMonad m) + + +because the type variable s occurs in State s m, +and so cannot be "eta-converted" away. It is a good thing that this +deriving clause is rejected, because NonMonad m is +not, in fact, a monad --- for the same reason. Try defining +>>= with the correct type: you won't be able to. + + + +Notice also that the order of class parameters becomes +important, since we can only derive instances for the last one. If the +StateMonad class above were instead defined as + + + class StateMonad m s | m -> s where ... + + +then we would not have been able to derive an instance for the +Parser type above. We hypothesise that multi-parameter +classes usually have one "main" parameter for which deriving new +instances is most interesting. + +Lastly, all of this applies only for classes other than +Read, Show, Typeable, +and Data, for which the built-in derivation applies (section +4.3.3. of the Haskell Report). +(For the standard classes Eq, Ord, +Ix, and Bounded it is immaterial whether +the standard method is used or the one described here.) + + + + + +Deriving any other class + + +With you can derive any other class. The +compiler will simply generate an empty instance. The instance context will be +generated according to the same rules used when deriving Eq. +This is mostly useful in classes whose minimal +set is empty, and especially when writing +generic functions. + +In case you try to derive some class on a newtype, and + is also on, + takes precedence. + + + + + + + + + +Class and instances declarations + + +Class declarations + + +This section, and the next one, documents GHC's type-class extensions. +There's lots of background in the paper Type +classes: exploring the design space (Simon Peyton Jones, Mark +Jones, Erik Meijer). + + + +Multi-parameter type classes + +Multi-parameter type classes are permitted, with flag . +For example: + + + + class Collection c a where + union :: c a -> c a -> c a + ...etc. + + + + + + +The superclasses of a class declaration + + +In Haskell 98 the context of a class declaration (which introduces superclasses) +must be simple; that is, each predicate must consist of a class applied to +type variables. The flag +() +lifts this restriction, +so that the only restriction on the context in a class declaration is +that the class hierarchy must be acyclic. So these class declarations are OK: + + + + class Functor (m k) => FiniteMap m k where + ... + + class (Monad m, Monad (t m)) => Transform t m where + lift :: m a -> (t m) a + + + + + +As in Haskell 98, The class hierarchy must be acyclic. However, the definition +of "acyclic" involves only the superclass relationships. For example, +this is OK: + + + + class C a where { + op :: D b => a -> b -> b + } + + class C a => D a where { ... } + + + +Here, C is a superclass of D, but it's OK for a +class operation op of C to mention D. (It +would not be OK for D to be a superclass of C.) + + +With the extension that adds a kind of constraints, +you can write more exotic superclass definitions. The superclass cycle check is even more +liberal in these case. For example, this is OK: + + + class A cls c where + meth :: cls c => c -> c + + class A B c => B c where + + +A superclass context for a class C is allowed if, after expanding +type synonyms to their right-hand-sides, and uses of classes (other than C) +to their superclasses, C does not occur syntactically in the context. + + + + + + + +Class method types + + +Haskell 98 prohibits class method types to mention constraints on the +class type variable, thus: + + class Seq s a where + fromList :: [a] -> s a + elem :: Eq a => a -> s a -> Bool + +The type of elem is illegal in Haskell 98, because it +contains the constraint Eq a, constrains only the +class type variable (in this case a). +GHC lifts this restriction (flag ). + + + + + + + +Default method signatures + + +Haskell 98 allows you to define a default implementation when declaring a class: + + class Enum a where + enum :: [a] + enum = [] + +The type of the enum method is [a], and +this is also the type of the default method. You can lift this restriction +and give another type to the default method using the flag +. For instance, if you have written a +generic implementation of enumeration in a class GEnum +with method genum in terms of GHC.Generics, +you can specify a default method that uses that generic implementation: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + +We reuse the keyword default to signal that a signature +applies to the default method only; when defining instances of the +Enum class, the original type [a] of +enum still applies. When giving an empty instance, however, +the default implementation map to genum is filled-in, +and type-checked with the type +(Generic a, GEnum (Rep a)) => [a]. + + + +We use default signatures to simplify generic programming in GHC +(). + + + + + + +Nullary type classes +Nullary (no parameter) type classes are enabled with +; historically, they were enabled with the +(now deprecated) . +Since there are no available parameters, there can be at most one instance +of a nullary class. A nullary type class might be used to document some assumption +in a type signature (such as reliance on the Riemann hypothesis) or add some +globally configurable settings in a program. For example, + + + class RiemannHypothesis where + assumeRH :: a -> a + + -- Deterministic version of the Miller test + -- correctness depends on the generalized Riemann hypothesis + isPrime :: RiemannHypothesis => Integer -> Bool + isPrime n = assumeRH (...) + + +The type signature of isPrime informs users that its correctness +depends on an unproven conjecture. If the function is used, the user has +to acknowledge the dependence with: + + + instance RiemannHypothesis where + assumeRH = id + + + + + + +Functional dependencies + + + Functional dependencies are implemented as described by Mark Jones +in “Type Classes with Functional Dependencies”, Mark P. Jones, +In Proceedings of the 9th European Symposium on Programming, +ESOP 2000, Berlin, Germany, March 2000, Springer-Verlag LNCS 1782, +. + + +Functional dependencies are introduced by a vertical bar in the syntax of a +class declaration; e.g. + + class (Monad m) => MonadState s m | m -> s where ... + + class Foo a b c | a b -> c where ... + +There should be more documentation, but there isn't (yet). Yell if you need it. + + +Rules for functional dependencies + +In a class declaration, all of the class type variables must be reachable (in the sense +mentioned in ) +from the free variables of each method type. +For example: + + + class Coll s a where + empty :: s + insert :: s -> a -> s + + +is not OK, because the type of empty doesn't mention +a. Functional dependencies can make the type variable +reachable: + + class Coll s a | s -> a where + empty :: s + insert :: s -> a -> s + + +Alternatively Coll might be rewritten + + + class Coll s a where + empty :: s a + insert :: s a -> a -> s a + + + +which makes the connection between the type of a collection of +a's (namely (s a)) and the element type a. +Occasionally this really doesn't work, in which case you can split the +class like this: + + + + class CollE s where + empty :: s + + class CollE s => Coll s a where + insert :: s -> a -> s + + + + + + +Background on functional dependencies + +The following description of the motivation and use of functional dependencies is taken +from the Hugs user manual, reproduced here (with minor changes) by kind +permission of Mark Jones. + + +Consider the following class, intended as part of a +library for collection types: + + class Collects e ce where + empty :: ce + insert :: e -> ce -> ce + member :: e -> ce -> Bool + +The type variable e used here represents the element type, while ce is the type +of the container itself. Within this framework, we might want to define +instances of this class for lists or characteristic functions (both of which +can be used to represent collections of any equality type), bit sets (which can +be used to represent collections of characters), or hash tables (which can be +used to represent any collection whose elements have a hash function). Omitting +standard implementation details, this would lead to the following declarations: + + instance Eq e => Collects e [e] where ... + instance Eq e => Collects e (e -> Bool) where ... + instance Collects Char BitSet where ... + instance (Hashable e, Collects a ce) + => Collects e (Array Int ce) where ... + +All this looks quite promising; we have a class and a range of interesting +implementations. Unfortunately, there are some serious problems with the class +declaration. First, the empty function has an ambiguous type: + + empty :: Collects e ce => ce + +By "ambiguous" we mean that there is a type variable e that appears on the left +of the => symbol, but not on the right. The problem with +this is that, according to the theoretical foundations of Haskell overloading, +we cannot guarantee a well-defined semantics for any term with an ambiguous +type. + + +We can sidestep this specific problem by removing the empty member from the +class declaration. However, although the remaining members, insert and member, +do not have ambiguous types, we still run into problems when we try to use +them. For example, consider the following two functions: + + f x y = insert x . insert y + g = f True 'a' + +for which GHC infers the following types: + + f :: (Collects a c, Collects b c) => a -> b -> c -> c + g :: (Collects Bool c, Collects Char c) => c -> c + +Notice that the type for f allows the two parameters x and y to be assigned +different types, even though it attempts to insert each of the two values, one +after the other, into the same collection. If we're trying to model collections +that contain only one type of value, then this is clearly an inaccurate +type. Worse still, the definition for g is accepted, without causing a type +error. As a result, the error in this code will not be flagged at the point +where it appears. Instead, it will show up only when we try to use g, which +might even be in a different module. + + +An attempt to use constructor classes + + +Faced with the problems described above, some Haskell programmers might be +tempted to use something like the following version of the class declaration: + + class Collects e c where + empty :: c e + insert :: e -> c e -> c e + member :: e -> c e -> Bool + +The key difference here is that we abstract over the type constructor c that is +used to form the collection type c e, and not over that collection type itself, +represented by ce in the original class declaration. This avoids the immediate +problems that we mentioned above: empty has type Collects e c => c +e, which is not ambiguous. + + +The function f from the previous section has a more accurate type: + + f :: (Collects e c) => e -> e -> c e -> c e + +The function g from the previous section is now rejected with a type error as +we would hope because the type of f does not allow the two arguments to have +different types. +This, then, is an example of a multiple parameter class that does actually work +quite well in practice, without ambiguity problems. +There is, however, a catch. This version of the Collects class is nowhere near +as general as the original class seemed to be: only one of the four instances +for Collects +given above can be used with this version of Collects because only one of +them---the instance for lists---has a collection type that can be written in +the form c e, for some type constructor c, and element type e. + + + +Adding functional dependencies + + +To get a more useful version of the Collects class, Hugs provides a mechanism +that allows programmers to specify dependencies between the parameters of a +multiple parameter class (For readers with an interest in theoretical +foundations and previous work: The use of dependency information can be seen +both as a generalization of the proposal for `parametric type classes' that was +put forward by Chen, Hudak, and Odersky, or as a special case of Mark Jones's +later framework for "improvement" of qualified types. The +underlying ideas are also discussed in a more theoretical and abstract setting +in a manuscript [implparam], where they are identified as one point in a +general design space for systems of implicit parameterization.). + +To start with an abstract example, consider a declaration such as: + + class C a b where ... + +which tells us simply that C can be thought of as a binary relation on types +(or type constructors, depending on the kinds of a and b). Extra clauses can be +included in the definition of classes to add information about dependencies +between parameters, as in the following examples: + + class D a b | a -> b where ... + class E a b | a -> b, b -> a where ... + +The notation a -> b used here between the | and where +symbols --- not to be +confused with a function type --- indicates that the a parameter uniquely +determines the b parameter, and might be read as "a determines b." Thus D is +not just a relation, but actually a (partial) function. Similarly, from the two +dependencies that are included in the definition of E, we can see that E +represents a (partial) one-one mapping between types. + + +More generally, dependencies take the form x1 ... xn -> y1 ... ym, +where x1, ..., xn, and y1, ..., yn are type variables with n>0 and +m>=0, meaning that the y parameters are uniquely determined by the x +parameters. Spaces can be used as separators if more than one variable appears +on any single side of a dependency, as in t -> a b. Note that a class may be +annotated with multiple dependencies using commas as separators, as in the +definition of E above. Some dependencies that we can write in this notation are +redundant, and will be rejected because they don't serve any useful +purpose, and may instead indicate an error in the program. Examples of +dependencies like this include a -> a , +a -> a a , +a -> , etc. There can also be +some redundancy if multiple dependencies are given, as in +a->b, + b->c , a->c , and +in which some subset implies the remaining dependencies. Examples like this are +not treated as errors. Note that dependencies appear only in class +declarations, and not in any other part of the language. In particular, the +syntax for instance declarations, class constraints, and types is completely +unchanged. + + +By including dependencies in a class declaration, we provide a mechanism for +the programmer to specify each multiple parameter class more precisely. The +compiler, on the other hand, is responsible for ensuring that the set of +instances that are in scope at any given point in the program is consistent +with any declared dependencies. For example, the following pair of instance +declarations cannot appear together in the same scope because they violate the +dependency for D, even though either one on its own would be acceptable: + + instance D Bool Int where ... + instance D Bool Char where ... + +Note also that the following declaration is not allowed, even by itself: + + instance D [a] b where ... + +The problem here is that this instance would allow one particular choice of [a] +to be associated with more than one choice for b, which contradicts the +dependency specified in the definition of D. More generally, this means that, +in any instance of the form: + + instance D t s where ... + +for some particular types t and s, the only variables that can appear in s are +the ones that appear in t, and hence, if the type t is known, then s will be +uniquely determined. + + +The benefit of including dependency information is that it allows us to define +more general multiple parameter classes, without ambiguity problems, and with +the benefit of more accurate types. To illustrate this, we return to the +collection class example, and annotate the original definition of Collects +with a simple dependency: + + class Collects e ce | ce -> e where + empty :: ce + insert :: e -> ce -> ce + member :: e -> ce -> Bool + +The dependency ce -> e here specifies that the type e of elements is uniquely +determined by the type of the collection ce. Note that both parameters of +Collects are of kind *; there are no constructor classes here. Note too that +all of the instances of Collects that we gave earlier can be used +together with this new definition. + + +What about the ambiguity problems that we encountered with the original +definition? The empty function still has type Collects e ce => ce, but it is no +longer necessary to regard that as an ambiguous type: Although the variable e +does not appear on the right of the => symbol, the dependency for class +Collects tells us that it is uniquely determined by ce, which does appear on +the right of the => symbol. Hence the context in which empty is used can still +give enough information to determine types for both ce and e, without +ambiguity. More generally, we need only regard a type as ambiguous if it +contains a variable on the left of the => that is not uniquely determined +(either directly or indirectly) by the variables on the right. + + +Dependencies also help to produce more accurate types for user defined +functions, and hence to provide earlier detection of errors, and less cluttered +types for programmers to work with. Recall the previous definition for a +function f: + + f x y = insert x y = insert x . insert y + +for which we originally obtained a type: + + f :: (Collects a c, Collects b c) => a -> b -> c -> c + +Given the dependency information that we have for Collects, however, we can +deduce that a and b must be equal because they both appear as the second +parameter in a Collects constraint with the same first parameter c. Hence we +can infer a shorter and more accurate type for f: + + f :: (Collects a c) => a -> a -> c -> c + +In a similar way, the earlier definition of g will now be flagged as a type error. + + +Although we have given only a few examples here, it should be clear that the +addition of dependency information can help to make multiple parameter classes +more useful in practice, avoiding ambiguity problems, and allowing more general +sets of instance declarations. + + + + + + +Instance declarations + +An instance declaration has the form + + instance ( assertion1, ..., assertionn) => class type1 ... typem where ... + +The part before the "=>" is the +context, while the part after the +"=>" is the head of the instance declaration. + + + +Instance resolution + + +When GHC tries to resolve, say, the constraint C Int Bool, +it tries to match every instance declaration against the +constraint, +by instantiating the head of the instance declaration. Consider +these declarations: + + instance context1 => C Int a where ... -- (A) + instance context2 => C a Bool where ... -- (B) + +GHC's default behaviour is that exactly one instance must match the +constraint it is trying to resolve. +For example, the constraint C Int Bool matches instances (A) and (B), +and hence would be rejected; while C Int Char matches only (A) +and hence (A) is chosen. + + +Notice that + + +When matching, GHC takes +no account of the context of the instance declaration +(context1 etc). + + +It is fine for there to be a potential of overlap (by +including both declarations (A) and (B), say); an error is only reported if a +particular constraint matches more than one. + + +See also for flags that loosen the +instance resolution rules. + + + + + +Relaxed rules for the instance head + + +In Haskell 98 the head of an instance declaration +must be of the form C (T a1 ... an), where +C is the class, T is a data type constructor, +and the a1 ... an are distinct type variables. +In the case of multi-parameter type classes, this rule applies to each parameter of +the instance head. (Arguably it should be OK if just one has this form and the others +are type variables, but that's the rules at the moment.) + +GHC relaxes this rule in two ways. + + +With the flag, instance heads may use type +synonyms. As always, using a type synonym is just shorthand for +writing the RHS of the type synonym definition. For example: + + type Point a = (a,a) + instance C (Point a) where ... + +is legal. The instance declaration is equivalent to + + instance C (a,a) where ... + +As always, type synonyms +must be fully applied. You cannot, for example, write: + + instance Monad Point where ... + + + + + +The flag allows the head of the instance +declaration to mention arbitrary nested types. +For example, this becomes a legal instance declaration + + instance C (Maybe Int) where ... + +See also the rules on overlap. + + +The flag implies . + + + + + + +Relaxed rules for instance contexts + +In Haskell 98, the assertions in the context of the instance declaration +must be of the form C a where a +is a type variable that occurs in the head. + + + +The flag relaxes this rule, as well +as the corresponding rule for type signatures (see ). +With this flag the context of the instance declaration can each consist of arbitrary +(well-kinded) assertions (C t1 ... tn) subject only to the +following rules: + + +The Paterson Conditions: for each assertion in the context + +No type variable has more occurrences in the assertion than in the head +The assertion has fewer constructors and variables (taken together + and counting repetitions) than the head + + + +The Coverage Condition. For each functional dependency, +tvsleft -> +tvsright, of the class, +every type variable in +S(tvsright) must appear in +S(tvsleft), where S is the +substitution mapping each type variable in the class declaration to the +corresponding type in the instance declaration. + + +These restrictions ensure that context reduction terminates: each reduction +step makes the problem smaller by at least one +constructor. Both the Paterson Conditions and the Coverage Condition are lifted +if you give the +flag (). +You can find lots of background material about the reason for these +restrictions in the paper +Understanding functional dependencies via Constraint Handling Rules. + + +For example, these are OK: + + instance C Int [a] -- Multiple parameters + instance Eq (S [a]) -- Structured type in head + + -- Repeated type variable in head + instance C4 a a => C4 [a] [a] + instance Stateful (ST s) (MutVar s) + + -- Head can consist of type variables only + instance C a + instance (Eq a, Show b) => C2 a b + + -- Non-type variables in context + instance Show (s a) => Show (Sized s a) + instance C2 Int a => C3 Bool [a] + instance C2 Int a => C3 [a] b + +But these are not: + + -- Context assertion no smaller than head + instance C a => C a where ... + -- (C b b) has more occurrences of b than the head + instance C b b => Foo [b] where ... + + + + +The same restrictions apply to instances generated by +deriving clauses. Thus the following is accepted: + + data MinHeap h a = H a (h a) + deriving (Show) + +because the derived instance + + instance (Show a, Show (h a)) => Show (MinHeap h a) + +conforms to the above rules. + + + +A useful idiom permitted by the above rules is as follows. +If one allows overlapping instance declarations then it's quite +convenient to have a "default instance" declaration that applies if +something more specific does not: + + instance C a where + op = ... -- Default + + + + + +Undecidable instances + + +Sometimes even the rules of are too onerous. +For example, sometimes you might want to use the following to get the +effect of a "class synonym": + + class (C1 a, C2 a, C3 a) => C a where { } + + instance (C1 a, C2 a, C3 a) => C a where { } + +This allows you to write shorter signatures: + + f :: C a => ... + +instead of + + f :: (C1 a, C2 a, C3 a) => ... + +The restrictions on functional dependencies () are particularly troublesome. +It is tempting to introduce type variables in the context that do not appear in +the head, something that is excluded by the normal rules. For example: + + class HasConverter a b | a -> b where + convert :: a -> b + + data Foo a = MkFoo a + + instance (HasConverter a b,Show b) => Show (Foo a) where + show (MkFoo value) = show (convert value) + +This is dangerous territory, however. Here, for example, is a program that would make the +typechecker loop: + + class D a + class F a b | a->b + instance F [a] [[a]] + instance (D c, F a c) => D [a] -- 'c' is not mentioned in the head + +Similarly, it can be tempting to lift the coverage condition: + + class Mul a b c | a b -> c where + (.*.) :: a -> b -> c + + instance Mul Int Int Int where (.*.) = (*) + instance Mul Int Float Float where x .*. y = fromIntegral x * y + instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v + +The third instance declaration does not obey the coverage condition; +and indeed the (somewhat strange) definition: + + f = \ b x y -> if b then x .*. [y] else y + +makes instance inference go into a loop, because it requires the constraint +(Mul a [b] b). + + +Nevertheless, GHC allows you to experiment with more liberal rules. If you use +the experimental flag +-XUndecidableInstances, +both the Paterson Conditions and the Coverage Condition +(described in ) are lifted. Termination is ensured by having a +fixed-depth recursion stack. If you exceed the stack depth you get a +sort of backtrace, and the opportunity to increase the stack depth +with N. + + + +The flag is also used to lift some of the +restricitions imposed on type family instances. See . + + + + + + +Overlapping instances + + +In general, as discussed in , +GHC requires that it be unambiguous which instance +declaration +should be used to resolve a type-class constraint. +GHC also provides a way to to loosen +the instance resolution, by +allowing more than one instance to match, provided there is a most +specific one. Moreover, it can be loosened further, by allowing more than one instance to match +irespective of whether there is a most specific one. +This section gives the details. + + +To control the choice of instance, it is possible to specify the overlap behavior for individual +instances with a pragma, written immediately after the +instance keyword. The pragma may be one of: +{-# OVERLAPPING #-}, +{-# OVERLAPPABLE #-}, +{-# OVERLAPS #-}, +or {-# INCOHERENT #-}. + + +The matching behaviour is also influenced by two module-level language extension flags: +-XOverlappingInstances + +and +-XIncoherentInstances +. These flags are now deprecated (since GHC 7.10) in favour of +the fine-grained per-instance pragmas. + + + +A more precise specification is as follows. +The willingness to be overlapped or incoherent is a property of +the instance declaration itself, controlled as follows: + +An instance is incoherent if: it has an INCOHERENT pragma; or if the instance has no pragma and it appears in a module compiled with -XIncoherentInstances. + +An instance is overlappable if: it has an OVERLAPPABLE or OVERLAPS pragma; or if the instance has no pragma and it appears in a module compiled with -XOverlappingInstances; or if the instance is incoherent. + +An instance is overlapping if: it has an OVERLAPPING or OVERLAPS pragma; or if the instance has no pragma and it appears in a module compiled with -XOverlappingInstances; or if the instance is incoherent. + + + + + +Now suppose that, in some client module, we are searching for an instance of the +target constraint (C ty1 .. tyn). +The search works like this. + + +Find all instances I that match the target constraint; +that is, the target constraint is a substitution instance of I. These +instance declarations are the candidates. + + + +Eliminate any candidate IX for which both of the following hold: + + + There is another candidate IY that is strictly more specific; + that is, IY is a substitution instance of IX but not vice versa. + + + Either IX is overlappable, or IY is + overlapping. (This "either/or" design, rather than a "both/and" design, + allow a client to deliberately override an instance from a library, without requiring a change to the library.) + + + + + + +If exactly one non-incoherent candidate remains, select it. If all +remaining candidates are incoherent, select an arbitary +one. Otherwise the search fails (i.e. when more than one surviving candidate is not incoherent). + + + +If the selected candidate (from the previous step) is incoherent, the search succeeds, returning that candidate. + + + +If not, find all instances that unify with the target +constraint, but do not match it. +Such non-candidate instances might match when the target constraint is further +instantiated. If all of them are incoherent, the search succeeds, returning the selected candidate; +if not, the search fails. + + + +Notice that these rules are not influenced by flag settings in the client module, where +the instances are used. +These rules make it possible for a library author to design a library that relies on +overlapping instances without the client having to know. + + +Errors are reported lazily (when attempting to solve a constraint), rather than eagerly +(when the instances themselves are defined). Consider, for example + + instance C Int b where .. + instance C a Bool where .. + +These potentially overlap, but GHC will not complain about the instance declarations +themselves, regardless of flag settings. If we later try to solve the constraint +(C Int Char) then only the first instance matches, and all is well. +Similarly with (C Bool Bool). But if we try to solve (C Int Bool), +both instances match and an error is reported. + + + +As a more substantial example of the rules in action, consider + + instance {-# OVERLAPPABLE #-} context1 => C Int b where ... -- (A) + instance {-# OVERLAPPABLE #-} context2 => C a Bool where ... -- (B) + instance {-# OVERLAPPABLE #-} context3 => C a [b] where ... -- (C) + instance {-# OVERLAPPING #-} context4 => C Int [Int] where ... -- (D) + +Now suppose that the type inference +engine needs to solve the constraint +C Int [Int]. This constraint matches instances (A), (C) and (D), but the last +is more specific, and hence is chosen. + +If (D) did not exist then (A) and (C) would still be matched, but neither is +most specific. In that case, the program would be rejected, unless + is enabled, in which case it would be accepted and (A) or +(C) would be chosen arbitrarily. + + +An instance declaration is more specific than another iff +the head of former is a substitution instance of the latter. For example +(D) is "more specific" than (C) because you can get from (C) to (D) by +substituting a:=Int. + + +GHC is conservative about committing to an overlapping instance. For example: + + f :: [b] -> [b] + f x = ... + +Suppose that from the RHS of f we get the constraint +C b [b]. But +GHC does not commit to instance (C), because in a particular +call of f, b might be instantiate +to Int, in which case instance (D) would be more specific still. +So GHC rejects the program. + +If, however, you add the flag when +compiling the module that contians (D), GHC will instead pick (C), without +complaining about the problem of subsequent instantiations. + + +Notice that we gave a type signature to f, so GHC had to +check that f has the specified type. +Suppose instead we do not give a type signature, asking GHC to infer +it instead. In this case, GHC will refrain from +simplifying the constraint C Int [b] (for the same reason +as before) but, rather than rejecting the program, it will infer the type + + f :: C b [b] => [b] -> [b] + +That postpones the question of which instance to pick to the +call site for f +by which time more is known about the type b. +You can write this type signature yourself if you use the + +flag. + + +Exactly the same situation can arise in instance declarations themselves. Suppose we have + + class Foo a where + f :: a -> a + instance Foo [b] where + f x = ... + +and, as before, the constraint C Int [b] arises from f's +right hand side. GHC will reject the instance, complaining as before that it does not know how to resolve +the constraint C Int [b], because it matches more than one instance +declaration. The solution is to postpone the choice by adding the constraint to the context +of the instance declaration, thus: + + instance C Int [b] => Foo [b] where + f x = ... + +(You need to do this.) + + +Warning: overlapping instances must be used with care. They +can give rise to incoherence (i.e. different instance choices are made +in different parts of the program) even without . Consider: + +{-# LANGUAGE OverlappingInstances #-} +module Help where + + class MyShow a where + myshow :: a -> String + + instance MyShow a => MyShow [a] where + myshow xs = concatMap myshow xs + + showHelp :: MyShow a => [a] -> String + showHelp xs = myshow xs + +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +module Main where + import Help + + data T = MkT + + instance MyShow T where + myshow x = "Used generic instance" + + instance MyShow [T] where + myshow xs = "Used more specific instance" + + main = do { print (myshow [MkT]); print (showHelp [MkT]) } + +In function showHelp GHC sees no overlapping +instances, and so uses the MyShow [a] instance +without complaint. In the call to myshow in main, +GHC resolves the MyShow [T] constraint using the overlapping +instance declaration in module Main. As a result, +the program prints + + "Used more specific instance" + "Used generic instance" + +(An alternative possible behaviour, not currently implemented, +would be to reject module Help +on the grounds that a later instance declaration might overlap the local one.) + + + + +Instance signatures: type signatures in instance declarations +In Haskell, you can't write a type signature in an instance declaration, but it +is sometimes convenient to do so, and the language extension +allows you to do so. For example: + + data T a = MkT a a + instance Eq a => Eq (T a) where + (==) :: T a -> T a -> Bool -- The signature + (==) (MkT x1 x2) (MkTy y1 y2) = x1==y1 && x2==y2 + + +Some details + + +The type signature in the instance declaration must be more polymorphic than (or the same as) +the one in the class declaration, instantiated with the instance type. +For example, this is fine: + + instance Eq a => Eq (T a) where + (==) :: forall b. b -> b -> Bool + (==) x y = True + +Here the signature in the instance declaration is more polymorphic than that +required by the instantiated class method. + + + + +The code for the method in the instance declaration is typechecked against the type signature +supplied in the instance declaration, as you would expect. So if the instance signature +is more polymorphic than required, the code must be too. + + + +One stylistic reason for wanting to write a type signature is simple documentation. Another +is that you may want to bring scoped type variables into scope. For example: + +class C a where + foo :: b -> a -> (a, [b]) + +instance C a => C (T a) where + foo :: forall b. b -> T a -> (T a, [b]) + foo x (T y) = (T y, xs) + where + xs :: [b] + xs = [x,x,x] + +Provided that you also specify +(), +the forall b scopes over the definition of foo, +and in particular over the type signature for xs. + + + + + + + +Overloaded string literals + + + +GHC supports overloaded string literals. Normally a +string literal has type String, but with overloaded string +literals enabled (with -XOverloadedStrings) + a string literal has type (IsString a) => a. + + + This means that the usual string syntax can be used, e.g., + for ByteString, Text, +and other variations of string like types. String literals behave very much +like integer literals, i.e., they can be used in both expressions and patterns. +If used in a pattern the literal with be replaced by an equality test, in the same +way as an integer literal is. + + +The class IsString is defined as: + +class IsString a where + fromString :: String -> a + +The only predefined instance is the obvious one to make strings work as usual: + +instance IsString [Char] where + fromString cs = cs + +The class IsString is not in scope by default. If you want to mention +it explicitly (for example, to give an instance declaration for it), you can import it +from module GHC.Exts. + + +Haskell's defaulting mechanism (Haskell Report, Section 4.3.4) +is extended to cover string literals, when is specified. +Specifically: + + +Each type in a default declaration must be an +instance of Num or of IsString. + + + +If no default declaration is given, then it is just as if the module +contained the declaration default( Integer, Double, String). + + + +The standard defaulting rule +is extended thus: defaulting applies when all the unresolved constraints involve standard classes +or IsString; and at least one is a numeric class +or IsString. + + +So, for example, the expression length "foo" will give rise +to an ambiguous use of IsString a0 which, because of the above +rules, will default to String. + + +A small example: + +module Main where + +import GHC.Exts( IsString(..) ) + +newtype MyString = MyString String deriving (Eq, Show) +instance IsString MyString where + fromString = MyString + +greet :: MyString -> MyString +greet "hello" = "world" +greet other = other + +main = do + print $ greet "hello" + print $ greet "fool" + + + +Note that deriving Eq is necessary for the pattern matching +to work since it gets translated into an equality comparison. + + + + +Overloaded lists + + GHC supports overloading of the list notation. +Let us recap the notation for +constructing lists. In Haskell, the list notation can be be used in the +following seven ways: + + +[] -- Empty list +[x] -- x : [] +[x,y,z] -- x : y : z : [] +[x .. ] -- enumFrom x +[x,y ..] -- enumFromThen x y +[x .. y] -- enumFromTo x y +[x,y .. z] -- enumFromThenTo x y z + + +When the extension is turned on, the +aforementioned seven notations are desugared as follows: + + +[] -- fromListN 0 [] +[x] -- fromListN 1 (x : []) +[x,y,z] -- fromListN 3 (x : y : z : []) +[x .. ] -- fromList (enumFrom x) +[x,y ..] -- fromList (enumFromThen x y) +[x .. y] -- fromList (enumFromTo x y) +[x,y .. z] -- fromList (enumFromThenTo x y z) + + + This extension allows programmers to use the list notation for +construction of structures like: Set, +Map, IntMap, Vector, +Text and Array. The following code +listing gives a few examples: + + +['0' .. '9'] :: Set Char +[1 .. 10] :: Vector Int +[("default",0), (k1,v1)] :: Map String Int +['a' .. 'z'] :: Text + + +List patterns are also overloaded. When the +extension is turned on, these definitions are desugared as follows + +f [] = ... -- f (toList -> []) = ... +g [x,y,z] = ... -- g (toList -> [x,y,z]) = ... + +(Here we are using view-pattern syntax for the translation, see .) + + + +The <literal>IsList</literal> class + +In the above desugarings, the functions toList, +fromList and fromListN are all +methods of +the IsList class, which is itself exported from +the GHC.Exts module. +The type class is defined as follows: + + +class IsList l where + type Item l + + fromList :: [Item l] -> l + toList :: l -> [Item l] + + fromListN :: Int -> [Item l] -> l + fromListN _ = fromList + + +The IsList class and its methods are intended to be +used in conjunction with the extension. + + The type function +Item returns the type of items of the +structure l. + + +The function fromList +constructs the structure l from the given list of +Item l. + + +The function fromListN takes the +input list's length as a hint. Its behaviour should be equivalent to +fromList. The hint can be used for more efficient +construction of the structure l compared to +fromList. If the given hint is not equal to the input +list's length the behaviour of fromListN is not +specified. + + +The function toList should be +the inverse of fromList. + + + +It is perfectly fine to declare new instances +of IsList, so that list notation becomes +useful for completely new data types. +Here are several example instances: + +instance IsList [a] where + type Item [a] = a + fromList = id + toList = id + +instance (Ord a) => IsList (Set a) where + type Item (Set a) = a + fromList = Set.fromList + toList = Set.toList + +instance (Ord k) => IsList (Map k v) where + type Item (Map k v) = (k,v) + fromList = Map.fromList + toList = Map.toList + +instance IsList (IntMap v) where + type Item (IntMap v) = (Int,v) + fromList = IntMap.fromList + toList = IntMap.toList + +instance IsList Text where + type Item Text = Char + fromList = Text.pack + toList = Text.unpack + +instance IsList (Vector a) where + type Item (Vector a) = a + fromList = Vector.fromList + fromListN = Vector.fromListN + toList = Vector.toList + + + + + +Rebindable syntax + + When desugaring list notation with +GHC uses the fromList (etc) methods from module GHC.Exts. +You do not need to import GHC.Exts for this to happen. + + However if you use , then +GHC instead uses whatever is in +scope with the names of toList, fromList and +fromListN. That is, these functions are rebindable; +c.f. . + + + +Defaulting + +Currently, the IsList class is not accompanied with +defaulting rules. Although feasible, not much thought has gone into how to +specify the meaning of the default declarations like: + + +default ([a]) + + + + +Speculation about the future + + +The current implementation of the +extension can be improved by handling the lists that are only populated with +literals in a special way. More specifically, the compiler could allocate such +lists statically using a compact representation and allow +IsList instances to take advantage of the compact +representation. Equipped with this capability the + extension will be in a good position to +subsume the extension (currently, as a +special case, string literals benefit from statically allocated compact +representation). + + + + + + +Type families + + + Indexed type families form an extension to + facilitate type-level + programming. Type families are a generalisation of associated + data types + (“Associated + Types with Class”, M. Chakravarty, G. Keller, S. Peyton Jones, + and S. Marlow. In Proceedings of “The 32nd Annual ACM SIGPLAN-SIGACT + Symposium on Principles of Programming Languages (POPL'05)”, pages + 1-13, ACM Press, 2005) and associated type synonyms + (“Type + Associated Type Synonyms”. M. Chakravarty, G. Keller, and + S. Peyton Jones. + In Proceedings of “The Tenth ACM SIGPLAN International Conference on + Functional Programming”, ACM Press, pages 241-253, 2005). Type families + themselves are described in the paper “Type + Checking with Open Type Functions”, T. Schrijvers, + S. Peyton-Jones, + M. Chakravarty, and M. Sulzmann, in Proceedings of “ICFP 2008: The + 13th ACM SIGPLAN International Conference on Functional + Programming”, ACM Press, pages 51-62, 2008. Type families + essentially provide type-indexed data types and named functions on types, + which are useful for generic programming and highly parameterised library + interfaces as well as interfaces with enhanced static information, much like + dependent types. They might also be regarded as an alternative to functional + dependencies, but provide a more functional style of type-level programming + than the relational style of functional dependencies. + + + Indexed type families, or type families for short, are type constructors that + represent sets of types. Set members are denoted by supplying the type family + constructor with type parameters, which are called type + indices. The + difference between vanilla parametrised type constructors and family + constructors is much like between parametrically polymorphic functions and + (ad-hoc polymorphic) methods of type classes. Parametric polymorphic functions + behave the same at all type instances, whereas class methods can change their + behaviour in dependence on the class type parameters. Similarly, vanilla type + constructors imply the same data representation for all type instances, but + family constructors can have varying representation types for varying type + indices. + + + Indexed type families come in three flavours: data + families, open type synonym families, and + closed type synonym families. They are the indexed + family variants of algebraic data types and type synonyms, respectively. The + instances of data families can be data types and newtypes. + + + Type families are enabled by the flag . + Additional information on the use of type families in GHC is available on + the + Haskell wiki page on type families. + + + + Data families + + + Data families appear in two flavours: (1) they can be defined on the + toplevel + or (2) they can appear inside type classes (in which case they are known as + associated types). The former is the more general variant, as it lacks the + requirement for the type-indexes to coincide with the class + parameters. However, the latter can lead to more clearly structured code and + compiler warnings if some type instances were - possibly accidentally - + omitted. In the following, we always discuss the general toplevel form first + and then cover the additional constraints placed on associated types. + + + + Data family declarations + + + Indexed data families are introduced by a signature, such as + +data family GMap k :: * -> * + + The special family distinguishes family from standard + data declarations. The result kind annotation is optional and, as + usual, defaults to * if omitted. An example is + +data family Array e + + Named arguments can also be given explicit kind signatures if needed. + Just as with + [http://www.haskell.org/ghc/docs/latest/html/users_guide/gadt.html GADT + declarations] named arguments are entirely optional, so that we can + declare Array alternatively with + +data family Array :: * -> * + + + + + + Data instance declarations + + + Instance declarations of data and newtype families are very similar to + standard data and newtype declarations. The only two differences are + that the keyword data or newtype + is followed by instance and that some or all of the + type arguments can be non-variable types, but may not contain forall + types or type synonym families. However, data families are generally + allowed in type parameters, and type synonyms are allowed as long as + they are fully applied and expand to a type that is itself admissible - + exactly as this is required for occurrences of type synonyms in class + instance parameters. For example, the Either + instance for GMap is + +data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + + In this example, the declaration has only one variant. In general, it + can be any number. + + + Data and newtype instance declarations are only permitted when an + appropriate family declaration is in scope - just as a class instance declaration + requires the class declaration to be visible. Moreover, each instance + declaration has to conform to the kind determined by its family + declaration. This implies that the number of parameters of an instance + declaration matches the arity determined by the kind of the family. + + + A data family instance declaration can use the full expressiveness of + ordinary data or newtype declarations: + + Although, a data family is introduced with + the keyword "data", a data family instance can + use either data or newtype. For example: + +data family T a +data instance T Int = T1 Int | T2 Bool +newtype instance T Char = TC Bool + + + A data instance can use GADT syntax for the data constructors, + and indeed can define a GADT. For example: + +data family G a b +data instance G [a] b where + G1 :: c -> G [Int] b + G2 :: G [a] Bool + + + You can use a deriving clause on a + data instance or newtype instance + declaration. + + + + + + Even if data families are defined as toplevel declarations, functions + that perform different computations for different family instances may still + need to be defined as methods of type classes. In particular, the + following is not possible: + +data family T a +data instance T Int = A +data instance T Char = B +foo :: T a -> Int +foo A = 1 -- WRONG: These two equations together... +foo B = 2 -- ...will produce a type error. + +Instead, you would have to write foo as a class operation, thus: + +class Foo a where + foo :: T a -> Int +instance Foo Int where + foo A = 1 +instance Foo Char where + foo B = 2 + + (Given the functionality provided by GADTs (Generalised Algebraic Data + Types), it might seem as if a definition, such as the above, should be + feasible. However, type families are - in contrast to GADTs - are + open; i.e., new instances can always be added, + possibly in other + modules. Supporting pattern matching across different data instances + would require a form of extensible case construct.) + + + + + Overlap of data instances + + The instance declarations of a data family used in a single program + may not overlap at all, independent of whether they are associated or + not. In contrast to type class instances, this is not only a matter + of consistency, but one of type safety. + + + + + + Synonym families + + + Type families appear in three flavours: (1) they can be defined as open + families on the toplevel, (2) they can be defined as closed families on + the toplevel, or (3) they can appear inside type classes (in which case + they are known as associated type synonyms). Toplevel families are more + general, as they lack the requirement for the type-indexes to coincide + with the class parameters. However, associated type synonyms can lead to + more clearly structured code and compiler warnings if some type instances + were - possibly accidentally - omitted. In the following, we always + discuss the general toplevel forms first and then cover the additional + constraints placed on associated types. Note that closed associated type + synonyms do not exist. + + + + Type family declarations + + + Open indexed type families are introduced by a signature, such as + +type family Elem c :: * + + The special family distinguishes family from standard + type declarations. The result kind annotation is optional and, as + usual, defaults to * if omitted. An example is + +type family Elem c + + Parameters can also be given explicit kind signatures if needed. We + call the number of parameters in a type family declaration, the family's + arity, and all applications of a type family must be fully saturated + w.r.t. to that arity. This requirement is unlike ordinary type synonyms + and it implies that the kind of a type family is not sufficient to + determine a family's arity, and hence in general, also insufficient to + determine whether a type family application is well formed. As an + example, consider the following declaration: + +type family F a b :: * -> * -- F's arity is 2, + -- although its overall kind is * -> * -> * -> * + + Given this declaration the following are examples of well-formed and + malformed types: + +F Char [Int] -- OK! Kind: * -> * +F Char [Int] Bool -- OK! Kind: * +F IO Bool -- WRONG: kind mismatch in the first argument +F Bool -- WRONG: unsaturated application + + + + + + Type instance declarations + + Instance declarations of type families are very similar to + standard type synonym declarations. The only two differences are that + the keyword type is followed by + instance and that some or all of the type arguments + can be non-variable types, but may not contain forall types or type + synonym families. However, data families are generally allowed, and type + synonyms are allowed as long as they are fully applied and expand to a + type that is admissible - these are the exact same requirements as for + data instances. For example, the [e] instance for + Elem is + +type instance Elem [e] = e + + + + + Type family instance declarations are only legitimate when an + appropriate family declaration is in scope - just like class instances + require the class declaration to be visible. Moreover, each instance + declaration has to conform to the kind determined by its family + declaration, and the number of type parameters in an instance + declaration must match the number of type parameters in the family + declaration. Finally, the right-hand side of a type instance must be a + monotype (i.e., it may not include foralls) and after the expansion of + all saturated vanilla type synonyms, no synonyms, except family synonyms + may remain. + + + + + Closed type families + + A type family can also be declared with a where clause, + defining the full set of equations for that family. For example: + +type family F a where + F Int = Double + F Bool = Char + F a = String + + A closed type family's equations are tried in order, from top to bottom, + when simplifying a type family application. In this example, we declare + an instance for F such that F Int + simplifies to Double, F Bool + simplifies to Char, and for any other type + a that is known not to be Int or + Bool, F a simplifies to + String. Note that GHC must be sure that + a cannot unify with Int or + Bool in that last case; if a programmer specifies + just F a in their code, GHC will not be able to + simplify the type. After all, a might later be + instantiated with Int. + + + + A closed type family's equations have the same restrictions as the + equations for an open type family instances. + + + + + Type family examples + +Here are some examples of admissible and illegal type + instances: + +type family F a :: * +type instance F [Int] = Int -- OK! +type instance F String = Char -- OK! +type instance F (F a) = a -- WRONG: type parameter mentions a type family +type instance F (forall a. (a, b)) = b -- WRONG: a forall type appears in a type parameter +type instance F Float = forall a.a -- WRONG: right-hand side may not be a forall type +type family H a where -- OK! + H Int = Int + H Bool = Bool + H a = String +type instance H Char = Char -- WRONG: cannot have instances of closed family + +type family G a b :: * -> * +type instance G Int = (,) -- WRONG: must be two type parameters +type instance G Int Char Float = Double -- WRONG: must be two type parameters + + + + + Compatibility and apartness of type family equations + + There must be some restrictions on the equations of type families, lest + we define an ambiguous rewrite system. So, equations of open type families + are restricted to be compatible. Two type patterns + are compatible if + +all corresponding types in the patterns are apart, or +the two patterns unify producing a substitution, and the right-hand sides are equal under that substitution. + + Two types are considered apart if, for all possible + substitutions, the types cannot reduce to a common reduct. + + + + The first clause of "compatible" is the more straightforward one. It says + that the patterns of two distinct type family instances cannot overlap. + For example, the following is disallowed: + +type instance F Int = Bool +type instance F Int = Char + + The second clause is a little more interesting. It says that two + overlapping type family instances are allowed if the right-hand + sides coincide in the region of overlap. Some examples help here: + +type instance F (a, Int) = [a] +type instance F (Int, b) = [b] -- overlap permitted + +type instance G (a, Int) = [a] +type instance G (Char, a) = [a] -- ILLEGAL overlap, as [Char] /= [Int] + + Note that this compatibility condition is independent of whether the type family + is associated or not, and it is not only a matter of consistency, but + one of type safety. + + + The definition for "compatible" uses a notion of "apart", whose definition + in turn relies on type family reduction. This condition of "apartness", as + stated, is impossible to check, so we use this conservative approximation: + two types are considered to be apart when the two types cannot be unified, + even by a potentially infinite unifier. Allowing the unifier to be infinite + disallows the following pair of instances: + +type instance H x x = Int +type instance H [x] x = Bool + + The type patterns in this pair equal if x is replaced + by an infinite nesting of lists. Rejecting instances such as these is + necessary for type soundness. + + + + Compatibility also affects closed type families. When simplifying an + application of a closed type family, GHC will select an equation only + when it is sure that no incompatible previous equation will ever apply. + Here are some examples: + +type family F a where + F Int = Bool + F a = Char + +type family G a where + G Int = Int + G a = a + + In the definition for F, the two equations are + incompatible -- their patterns are not apart, and yet their + right-hand sides do not coincide. Thus, before GHC selects the + second equation, it must be sure that the first can never apply. So, + the type F a does not simplify; only a type such + as F Double will simplify to + Char. In G, on the other hand, + the two equations are compatible. Thus, GHC can ignore the first + equation when looking at the second. So, G a will + simplify to a. + + However see for the overlap rules in GHCi. + + + + Decidability of type synonym instances + + In order to guarantee that type inference in the presence of type + families decidable, we need to place a number of additional + restrictions on the formation of type instance declarations (c.f., + Definition 5 (Relaxed Conditions) of “Type + Checking with Open Type Functions”). Instance + declarations have the general form + +type instance F t1 .. tn = t + + where we require that for every type family application (G s1 + .. sm) in t, + + + s1 .. sm do not contain any type family + constructors, + + + the total number of symbols (data type constructors and type + variables) in s1 .. sm is strictly smaller than + in t1 .. tn, and + + + for every type + variable a, a occurs + in s1 .. sm at most as often as in t1 + .. tn. + + + These restrictions are easily verified and ensure termination of type + inference. However, they are not sufficient to guarantee completeness + of type inference in the presence of, so called, ''loopy equalities'', + such as a ~ [F a], where a recursive occurrence of + a type variable is underneath a family application and data + constructor application - see the above mentioned paper for details. + + + If the option is passed to the + compiler, the above restrictions are not enforced and it is on the + programmer to ensure termination of the normalisation of type families + during type inference. + + + + + + +Associated data and type families + +A data or type synonym family can be declared as part of a type class, thus: + +class GMapKey k where + data GMap k :: * -> * + ... + +class Collects ce where + type Elem ce :: * + ... + +When doing so, we (optionally) may drop the "family" keyword. + + + The type parameters must all be type variables, of course, + and some (but not necessarily all) of then can be the class + parameters. Each class parameter may + only be used at most once per associated type, but some may be omitted + and they may be in an order other than in the class head. Hence, the + following contrived example is admissible: + + class C a b c where + type T c a x :: * + + Here c and a are class parameters, + but the type is also indexed on a third parameter x. + + + + Associated instances + + When an associated data or type synonym family instance is declared within a type + class instance, we (optionally) may drop the instance keyword in the + family instance: + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + ... + +instance Eq (Elem [e]) => Collects [e] where + type Elem [e] = e + ... + +Note the following points: + + + The type indexes corresponding to class parameters must have precisely the same shape + the type given in the instance head. To have the same "shape" means that + the two types are identical modulo renaming of type variables. For example: + +instance Eq (Elem [e]) => Collects [e] where + -- Choose one of the following alternatives: + type Elem [e] = e -- OK + type Elem [x] = x -- OK + type Elem x = x -- BAD; shape of 'x' is different to '[e]' + type Elem [Maybe x] = x -- BAD: shape of '[Maybe x]' is different to '[e]' + + + + An instances for an associated family can only appear as part of + an instance declarations of the class in which the family was declared, + just as with the equations of the methods of a class. + + + The instance for an associated type can be omitted in class instances. In that case, + unless there is a default instance (see ), + the corresponding instance type is not inhabited; + i.e., only diverging expressions, such + as undefined, can assume the type. + + + Although it is unusual, there (currently) can be multiple + instances for an associated family in a single instance declaration. + For example, this is legitimate: + +instance GMapKey Flob where + data GMap Flob [v] = G1 v + data GMap Flob Int = G2 Int + ... + + Here we give two data instance declarations, one in which the last + parameter is [v], and one for which it is Int. + Since you cannot give any subsequent instances for + (GMap Flob ...), this facility is most useful when + the free indexed parameter is of a kind with a finite number of alternatives + (unlike *). WARNING: this facility may be withdrawn in the future. + + + + + + + Associated type synonym defaults + + It is possible for the class defining the associated type to specify a + default for associated type instances. So for example, this is OK: + +class IsBoolMap v where + type Key v + type instance Key v = Int + + lookupKey :: Key v -> v -> Maybe Bool + +instance IsBoolMap [(Int, Bool)] where + lookupKey = lookup + +In an instance declaration for the class, if no explicit +type instance declaration is given for the associated type, the default declaration +is used instead, just as with default class methods. + + +Note the following points: + + + The instance keyword is optional. + + + There can be at most one default declaration for an associated type synonym. + + + A default declaration is not permitted for an associated + data type. + + + The default declaration must mention only type variables on the left hand side, + and the right hand side must mention only type varaibels bound on the left hand side. + However, unlike the associated type family declaration itself, + the type variables of the default instance are independent of those of the parent class. + + +Here are some examples: + + class C a where + type F1 a :: * + type instance F1 a = [a] -- OK + type instance F1 a = a->a -- BAD; only one default instance is allowed + + type F2 b a -- OK; note the family has more type + -- variables than the class + type instance F2 c d = c->d -- OK; you don't have to use 'a' in the type instance + + type F3 a + type F3 [b] = b -- BAD; only type variables allowed on the LHS + + type F4 a + type F4 b = a -- BAD; 'a' is not in scope in the RHS + + + + + + + Scoping of class parameters + + The visibility of class + parameters in the right-hand side of associated family instances + depends solely on the parameters of the + family. As an example, consider the simple class declaration + +class C a b where + data T a + + Only one of the two class parameters is a parameter to the data + family. Hence, the following instance declaration is invalid: + +instance C [c] d where + data T [c] = MkT (c, d) -- WRONG!! 'd' is not in scope + + Here, the right-hand side of the data instance mentions the type + variable d that does not occur in its left-hand + side. We cannot admit such data instances as they would compromise + type safety. + + + + Instance contexts and associated type and data instances + Associated type and data instance declarations do not inherit any + context specified on the enclosing instance. For type instance declarations, + it is unclear what the context would mean. For data instance declarations, + it is unlikely a user would want the context repeated for every data constructor. + The only place where the context might likely be useful is in a + deriving clause of an associated data instance. However, + even here, the role of the outer instance context is murky. So, for + clarity, we just stick to the rule above: the enclosing instance context + is ignored. If you need to use + a non-trivial context on a derived instance, + use a standalone + deriving clause (at the top level). + + + + + + + Import and export + + +The rules for export lists +(Haskell Report + Section 5.2) +needs adjustment for type families: + + + The form T(..), where T + is a data family, names the family T and all the in-scope + constructors (whether in scope qualified or unqualified) that are data + instances of T. + + + The form T(.., ci, .., fj, ..), where T is + a data family, names T and the specified constructors ci + and fields fj as usual. The constructors and field names must + belong to some data instance of T, but are not required to belong + to the same instance. + + + The form C(..), where C + is a class, names the class C and all its methods + and associated types. + + + The form C(.., mi, .., type Tj, ..), where C is a class, + names the class C, and the specified methods mi + and associated types Tj. The types need a keyword "type" + to distinguish them from data constructors. + + + + + + Examples + + Recall our running GMapKey class example: + +class GMapKey k where + data GMap k :: * -> * + insert :: GMap k v -> k -> v -> GMap k v + lookup :: GMap k v -> k -> Maybe v + empty :: GMap k v + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + ...method declarations... + +Here are some export lists and their meaning: + + + module GMap( GMapKey ): Exports + just the class name. + + + module GMap( GMapKey(..) ): + Exports the class, the associated type GMap + and the member + functions empty, lookup, + and insert. The data constructors of GMap + (in this case GMapEither) are not exported. + + + module GMap( GMapKey( type GMap, empty, lookup, insert ) ): + Same as the previous item. Note the "type" keyword. + + + module GMap( GMapKey(..), GMap(..) ): + Same as previous item, but also exports all the data + constructors for GMap, namely GMapEither. + + + + module GMap ( GMapKey( empty, lookup, insert), GMap(..) ): + Same as previous item. + + + module GMap ( GMapKey, empty, lookup, insert, GMap(..) ): + Same as previous item. + + + + +Two things to watch out for: + + + You cannot write GMapKey(type GMap(..)) — i.e., + sub-component specifications cannot be nested. To + specify GMap's data constructors, you have to list + it separately. + + + Consider this example: + + module X where + data family D + + module Y where + import X + data instance D Int = D1 | D2 + + Module Y exports all the entities defined in Y, namely the data constructors D1 + and D2, but not the data family D. + That (annoyingly) means that you cannot selectively import Y selectively, + thus "import Y( D(D1,D2) )", because Y does not export D. + Instead you should list the exports explicitly, thus: + + module Y( D(..) ) where ... +or module Y( module Y, D ) where ... + + + + + + + + Instances + + Family instances are implicitly exported, just like class instances. + However, this applies only to the heads of instances, not to the data + constructors an instance defines. + + + + + + + Type families and instance declarations + + Type families require us to extend the rules for + the form of instance heads, which are given + in . + Specifically: + + Data type families may appear in an instance head + Type synonym families may not appear (at all) in an instance head + +The reason for the latter restriction is that there is no way to check for instance +matching. Consider + + type family F a + type instance F Bool = Int + + class C a + + instance C Int + instance C (F a) + +Now a constraint (C (F Bool)) would match both instances. +The situation is especially bad because the type instance for F Bool +might be in another module, or even in a module that is not yet written. + + +However, type class instances of instances of data families can be defined +much like any other data type. For example, we can say + +data instance T Int = T1 Int | T2 Bool +instance Eq (T Int) where + (T1 i) == (T1 j) = i==j + (T2 i) == (T2 j) = i==j + _ == _ = False + + Note that class instances are always for + particular instances of a data family and never + for an entire family as a whole. This is for essentially the same + reasons that we cannot define a toplevel function that performs + pattern matching on the data constructors + of different instances of a single type family. + It would require a form of extensible case construct. + + +Data instance declarations can also + have deriving clauses. For example, we can write + +data GMap () v = GMapUnit (Maybe v) + deriving Show + + which implicitly defines an instance of the form + +instance Show v => Show (GMap () v) where ... + + + + + + + + + +Kind polymorphism + +This section describes kind polymorphism, and extension +enabled by . +It is described in more detail in the paper +Giving Haskell a +Promotion, which appeared at TLDI 2012. + + + Overview of kind polymorphism + + +Currently there is a lot of code duplication in the way Typeable is implemented +(): + +class Typeable (t :: *) where + typeOf :: t -> TypeRep + +class Typeable1 (t :: * -> *) where + typeOf1 :: t a -> TypeRep + +class Typeable2 (t :: * -> * -> *) where + typeOf2 :: t a b -> TypeRep + + + + +Kind polymorphism (with ) +allows us to merge all these classes into one: + +data Proxy t = Proxy + +class Typeable t where + typeOf :: Proxy t -> TypeRep + +instance Typeable Int where typeOf _ = TypeRep +instance Typeable [] where typeOf _ = TypeRep + +Note that the datatype Proxy has kind +forall k. k -> * (inferred by GHC), and the new +Typeable class has kind +forall k. k -> Constraint. + + + + Overview + + +Generally speaking, with , GHC will infer a polymorphic +kind for un-decorated declarations, whenever possible. For example: + +data T m a = MkT (m a) +-- GHC infers kind T :: forall k. (k -> *) -> k -> * + +Just as in the world of terms, you can restrict polymorphism using a +kind signature (sometimes called a kind annotation) +( implies ): + +data T m (a :: *) = MkT (m a) +-- GHC now infers kind T :: (* -> *) -> * -> * + +There is no "forall" for kind variables. Instead, when binding a type variable, +you can simply mention a kind +variable in a kind annotation for that type-variable binding, thus: + +data T (m :: k -> *) a = MkT (m a) +-- GHC now infers kind T :: forall k. (k -> *) -> k -> * + +The kind "forall" is placed +just outside the outermost type-variable binding whose kind annotation mentions +the kind variable. For example + +f1 :: (forall a m. m a -> Int) -> Int + -- f1 :: forall (k:BOX). + -- (forall (a:k) (m:k->*). m a -> Int) + -- -> Int + +f2 :: (forall (a::k) m. m a -> Int) -> Int + -- f2 :: (forall (k:BOX) (a:k) (m:k->*). m a -> Int) + -- -> Int + +Here in f1 there is no kind annotation mentioning the polymorphic +kind variable, so k is generalised at the top +level of the signature for f1, +making the signature for f1 is as polymorphic as possible. +But in the case of of f2 we give a kind annotation in the forall (a:k) +binding, and GHC therefore puts the kind forall right there too. + + +(Note: These rules are a bit indirect and clumsy. Perhaps GHC should allow explicit kind quantification. +But the implicit quantification (e.g. in the declaration for data type T above) is certainly +very convenient, and it is not clear what the syntax for explicit quantification should be.) + + + + Polymorphic kind recursion and complete kind signatures + + +Just as in type inference, kind inference for recursive types can only use monomorphic recursion. +Consider this (contrived) example: + +data T m a = MkT (m a) (T Maybe (m a)) +-- GHC infers kind T :: (* -> *) -> * -> * + +The recursive use of T forced the second argument to have kind *. +However, just as in type inference, you can achieve polymorphic recursion by giving a +complete kind signature for T. A complete +kind signature is present when all argument kinds and the result kind are known, without +any need for inference. For example: + +data T (m :: k -> *) :: k -> * where + MkT :: m a -> T Maybe (m a) -> T m a + +The complete user-supplied kind signature specifies the polymorphic kind for T, +and this signature is used for all the calls to T including the recursive ones. +In particular, the recursive use of T is at kind *. + + + +What exactly is considered to be a "complete user-supplied kind signature" for a type constructor? +These are the forms: + +For a datatype, every type variable must be annotated with a kind. In a +GADT-style declaration, there may also be a kind signature (with a top-level +:: in the header), but the presence or absence of this annotation +does not affect whether or not the declaration has a complete signature. + +data T1 :: (k -> *) -> k -> * where ... -- Yes T1 :: forall k. (k->*) -> k -> * +data T2 (a :: k -> *) :: k -> * where ... -- Yes T2 :: forall k. (k->*) -> k -> * +data T3 (a :: k -> *) (b :: k) :: * where ... -- Yes T3 :: forall k. (k->*) -> k -> * +data T4 (a :: k -> *) (b :: k) where ... -- Yes T4 :: forall k. (k->*) -> k -> * + +data T5 a (b :: k) :: * where ... -- NO kind is inferred +data T6 a b where ... -- NO kind is inferred + + + + +For a class, every type variable must be annotated with a kind. + + + +For a type synonym, every type variable and the result type must all be annotated +with kinds. + +type S1 (a :: k) = (a :: k) -- Yes S1 :: forall k. k -> k +type S2 (a :: k) = a -- No kind is inferred +type S3 (a :: k) = Proxy a -- No kind is inferred + +Note that in S2 and S3, the kind of the +right-hand side is rather apparent, but it is still not considered to have a complete +signature -- no inference can be done before detecting the signature. + + +An open type or data family declaration always has a +complete user-specified kind signature; un-annotated type variables default to +kind *. + +data family D1 a -- D1 :: * -> * +data family D2 (a :: k) -- D2 :: forall k. k -> * +data family D3 (a :: k) :: * -- D3 :: forall k. k -> * +type family S1 a :: k -> * -- S1 :: forall k. * -> k -> * + +class C a where -- C :: k -> Constraint + type AT a b -- AT :: k -> * -> * + +In the last example, the variable a has an implicit kind +variable annotation from the class declaration. It keeps its polymorphic kind +in the associated type declaration. The variable b, however, +gets defaulted to *. + + + +A closed type familey has a complete signature when all of its type variables +are annotated and a return kind (with a top-level ::) is supplied. + + + + + + +Kind inference in closed type families + +Although all open type families are considered to have a complete +user-specified kind signature, we can relax this condition for closed type +families, where we have equations on which to perform kind inference. GHC will +infer kinds for the arguments and result types of a closed type family. + +GHC supports kind-indexed type families, where the +family matches both on the kind and type. GHC will not infer +this behaviour without a complete user-supplied kind signature, as doing so would +sometimes infer non-principal types. + +For example: + +type family F1 a where + F1 True = False + F1 False = True + F1 x = x +-- F1 fails to compile: kind-indexing is not inferred + +type family F2 (a :: k) where + F2 True = False + F2 False = True + F2 x = x +-- F2 fails to compile: no complete signature + +type family F3 (a :: k) :: k where + F3 True = False + F3 False = True + F3 x = x +-- OK + + + + +Kind inference in class instance declarations + +Consider the following example of a poly-kinded class and an instance for it: + + +class C a where + type F a + +instance C b where + type F b = b -> b + + +In the class declaration, nothing constrains the kind of the type +a, so it becomes a poly-kinded type variable (a :: k). +Yet, in the instance declaration, the right-hand side of the associated type instance +b -> b says that b must be of kind *. GHC could theoretically propagate this information back into the instance head, and +make that instance declaration apply only to type of kind *, as opposed +to types of any kind. However, GHC does not do this. + +In short: GHC does not propagate kind information from +the members of a class instance declaration into the instance declaration head. + +This lack of kind inference is simply an engineering problem within GHC, but +getting it to work would make a substantial change to the inference infrastructure, +and it's not clear the payoff is worth it. If you want to restrict b's +kind in the instance above, just use a kind signature in the instance head. + + + + + +Datatype promotion + + +This section describes data type promotion, an extension +to the kind system that complements kind polymorphism. It is enabled by , +and described in more detail in the paper +Giving Haskell a +Promotion, which appeared at TLDI 2012. + + + Motivation + + +Standard Haskell has a rich type language. Types classify terms and serve to +avoid many common programming mistakes. The kind language, however, is +relatively simple, distinguishing only lifted types (kind *), +type constructors (eg. kind * -> * -> *), and unlifted +types (). In particular when using advanced +type system features, such as type families () +or GADTs (), this simple kind system is insufficient, +and fails to prevent simple errors. Consider the example of type-level natural +numbers, and length-indexed vectors: + +data Ze +data Su n + +data Vec :: * -> * -> * where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) + +The kind of Vec is * -> * -> *. This means +that eg. Vec Int Char is a well-kinded type, even though this +is not what we intend when defining length-indexed vectors. + + + +With , the example above can then be +rewritten to: + +data Nat = Ze | Su Nat + +data Vec :: * -> Nat -> * where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) + +With the improved kind of Vec, things like +Vec Int Char are now ill-kinded, and GHC will report an +error. + + + +Overview + +With , GHC automatically promotes every suitable +datatype to be a kind, and its (value) constructors to be type constructors. +The following types + +data Nat = Ze | Su Nat + +data List a = Nil | Cons a (List a) + +data Pair a b = Pair a b + +data Sum a b = L a | R b + +give rise to the following kinds and type constructors: + +Nat :: BOX +Ze :: Nat +Su :: Nat -> Nat + +List k :: BOX +Nil :: List k +Cons :: k -> List k -> List k + +Pair k1 k2 :: BOX +Pair :: k1 -> k2 -> Pair k1 k2 + +Sum k1 k2 :: BOX +L :: k1 -> Sum k1 k2 +R :: k2 -> Sum k1 k2 + +where BOX is the (unique) sort that classifies kinds. +Note that List, for instance, does not get sort +BOX -> BOX, because we do not further classify kinds; all +kinds have sort BOX. + + + +The following restrictions apply to promotion: + + We promote data types and newtypes, + but not type synonyms, or type/data families (). + + We only promote types whose kinds are of the form + * -> ... -> * -> *. In particular, we do not promote + higher-kinded datatypes such as data Fix f = In (f (Fix f)), + or datatypes whose kinds involve promoted types such as + Vec :: * -> Nat -> *. + We do not promote data constructors that are kind + polymorphic, involve constraints, mention type or data families, or involve types that + are not promotable. + + + + + + +Distinguishing between types and constructors + +Since constructors and types share the same namespace, with promotion you can +get ambiguous type names: + +data P -- 1 + +data Prom = P -- 2 + +type T = P -- 1 or promoted 2? + +In these cases, if you want to refer to the promoted constructor, you should +prefix its name with a quote: + +type T1 = P -- 1 + +type T2 = 'P -- promoted 2 + +Note that promoted datatypes give rise to named kinds. Since these can never be +ambiguous, we do not allow quotes in kind names. + +Just as in the case of Template Haskell (), there is +no way to quote a data constructor or type constructor whose second character +is a single quote. + + + + + +Promoting existential data constructors + +Note that we do promote existential data constructors that are otherwise suitable. +For example, consider the following: + +data Ex :: * where + MkEx :: forall a. a -> Ex + +Both the type Ex and the data constructor MkEx +get promoted, with the polymorphic kind 'MkEx :: forall k. k -> Ex. +Somewhat surprisingly, you can write a type family to extract the member +of a type-level existential: + +type family UnEx (ex :: Ex) :: k +type instance UnEx (MkEx x) = x + +At first blush, UnEx seems poorly-kinded. The return kind +k is not mentioned in the arguments, and thus it would seem +that an instance would have to return a member of k +for any k. However, this is not the +case. The type family UnEx is a kind-indexed type family. +The return kind k is an implicit parameter to UnEx. +The elaborated definitions are as follows: + +type family UnEx (k :: BOX) (ex :: Ex) :: k +type instance UnEx k (MkEx k x) = x + +Thus, the instance triggers only when the implicit parameter to UnEx +matches the implicit parameter to MkEx. Because k +is actually a parameter to UnEx, the kind is not escaping the +existential, and the above code is valid. + + + +See also Trac #7347. + + + + +Promoting type operators + +Type operators are not promoted to the kind level. Why not? Because +* is a kind, parsed the way identifiers are. Thus, if a programmer +tried to write Either * Bool, would it be Either +applied to * and Bool? Or would it be +* applied to Either and Bool. +To avoid this quagmire, we simply forbid promoting type operators to the kind level. + + + + + + + +Type-Level Literals + +GHC supports numeric and string literals at the type level, giving convenient +access to a large number of predefined type-level constants. +Numeric literals are of kind Nat, while string literals +are of kind Symbol. +This feature is enabled by the XDataKinds +language extension. + + + +The kinds of the literals and all other low-level operations for this feature +are defined in module GHC.TypeLits. Note that the module +defines some type-level operators that clash with their value-level +counterparts (e.g. (+)). Import and export declarations +referring to these operators require an explicit namespace +annotation (see ). + + + +Here is an exampe of using type-level numeric literals to provide a safe +interface to a low-level function: + +import GHC.TypeLits +import Data.Word +import Foreign + +newtype ArrPtr (n :: Nat) a = ArrPtr (Ptr a) + +clearPage :: ArrPtr 4096 Word8 -> IO () +clearPage (ArrPtr p) = ... + + + + +Here is an example of using type-level string literals to simulate +simple record operations: + +data Label (l :: Symbol) = Get + +class Has a l b | a l -> b where + from :: a -> Label l -> b + +data Point = Point Int Int deriving Show + +instance Has Point "x" Int where from (Point x _) _ = x +instance Has Point "y" Int where from (Point _ y) _ = y + +example = from (Point 1 2) (Get :: Label "x") + + + + +Runtime Values for Type-Level Literals + +Sometimes it is useful to access the value-level literal assocaited with +a type-level literal. This is done with the functions +natVal and symbolVal. For example: + +GHC.TypeLits> natVal (Proxy :: Proxy 2) +2 + +These functions are overloaded because they need to return a different +result, depending on the type at which they are instantiated. + +natVal :: KnownNat n => proxy n -> Integer + +-- instance KnownNat 0 +-- instance KnownNat 1 +-- instance KnownNat 2 +-- ... + +GHC discharges the constraint as soon as it knows what concrete +type-level literal is being used in the program. Note that this works +only for literals and not arbitrary type expressions. +For example, a constraint of the form KnownNat (a + b) +will not be simplified to +(KnownNat a, KnownNat b); instead, GHC will keep the +constraint as is, until it can simplify a + b to +a constant value. + + + + +It is also possible to convert a run-time integer or string value to +the corresponding type-level literal. Of course, the resulting type +literal will be unknown at compile-time, so it is hidden in an existential +type. The conversion may be performed using someNatVal +for integers and someSymbolVal for strings: + +someNatVal :: Integer -> Maybe SomeNat +SomeNat :: KnownNat n => Proxy n -> SomeNat + +The operations on strings are similar. + + + +Computing With Type-Level Naturals + +GHC 7.8 can evaluate arithmetic expressions involving type-level natural +numbers. Such expressions may be constructed using the type-families +(+), (*), (^) for addition, multiplication, +and exponentiation. Numbers may be compared using (<=?), +which returns a promoted boolean value, or (<=), which +compares numbers as a constraint. For example: + +GHC.TypeLits> natVal (Proxy :: Proxy (2 + 3)) +5 + + + +At present, GHC is quite limited in its reasoning about arithmetic: +it will only evalute the arithmetic type functions and compare the results--- +in the same way that it does for any other type function. In particular, +it does not know more general facts about arithmetic, such as the commutativity +and associativity of (+), for example. + + + +However, it is possible to perform a bit of "backwards" evaluation. +For example, here is how we could get GHC to compute arbitrary logarithms +at the type level: + +lg :: Proxy base -> Proxy (base ^ pow) -> Proxy pow +lg _ _ = Proxy + +GHC.TypeLits> natVal (lg (Proxy :: Proxy 2) (Proxy :: Proxy 8)) +3 + + + + + + + + + + Equality constraints + + A type context can include equality constraints of the form t1 ~ + t2, which denote that the types t1 + and t2 need to be the same. In the presence of type + families, whether two types are equal cannot generally be decided + locally. Hence, the contexts of function signatures may include + equality constraints, as in the following example: + +sumCollects :: (Collects c1, Collects c2, Elem c1 ~ Elem c2) => c1 -> c2 -> c2 + + where we require that the element type of c1 + and c2 are the same. In general, the + types t1 and t2 of an equality + constraint may be arbitrary monotypes; i.e., they may not contain any + quantifiers, independent of whether higher-rank types are otherwise + enabled. + + + Equality constraints can also appear in class and instance contexts. + The former enable a simple translation of programs using functional + dependencies into programs using family synonyms instead. The general + idea is to rewrite a class declaration of the form + +class C a b | a -> b + + to + +class (F a ~ b) => C a b where + type F a + + That is, we represent every functional dependency (FD) a1 .. an + -> b by an FD type family F a1 .. an and a + superclass context equality F a1 .. an ~ b, + essentially giving a name to the functional dependency. In class + instances, we define the type instances of FD families in accordance + with the class head. Method signatures are not affected by that + process. + + + + The <literal>Coercible</literal> constraint + + The constraint Coercible t1 t2 is similar to t1 ~ + t2, but denotes representational equality between + t1 and t2 in the sense of Roles + (). It is exported by + Data.Coerce, + which also contains the documentation. More details and discussion can be found in + the paper + Safe Coercions". + + + + + + +The <literal>Constraint</literal> kind + + + Normally, constraints (which appear in types to the left of the + => arrow) have a very restricted syntax. They can only be: + + + Class constraints, e.g. Show a + + + Implicit parameter constraints, + e.g. ?x::Int (with the flag) + + + Equality constraints, + e.g. a ~ Int (with the or + flag) + + + + + + With the flag, GHC becomes more liberal in + what it accepts as constraints in your program. To be precise, with this flag any + type of the new kind Constraint can be used as a constraint. + The following things have kind Constraint: + + + + Anything which is already valid as a constraint without the flag: saturated applications to type classes, + implicit parameter and equality constraints. + + + Tuples, all of whose component types have kind Constraint. So for example the + type (Show a, Ord a) is of kind Constraint. + + + Anything whose form is not yet known, but the user has declared to have kind Constraint + (for which they need to import it from GHC.Exts). So for example + type Foo (f :: * -> Constraint) = forall b. f b => b -> b is allowed, as well as + examples involving type families: + +type family Typ a b :: Constraint +type instance Typ Int b = Show b +type instance Typ Bool b = Num b + +func :: Typ a b => a -> b -> b +func = ... + + + + + + + Note that because constraints are just handled as types of a particular kind, this extension allows type + constraint synonyms: + + + +type Stringy a = (Read a, Show a) +foo :: Stringy a => a -> (String, String -> a) +foo x = (show x, read) + + + + Presently, only standard constraints, tuples and type synonyms for those two sorts of constraint are + permitted in instance contexts and superclasses (without extra flags). The reason is that permitting more general + constraints can cause type checking to loop, as it would with these two programs: + + + +type family Clsish u a +type instance Clsish () a = Cls a +class Clsish () a => Cls a where + + + +class OkCls a where + +type family OkClsish u a +type instance OkClsish () a = OkCls a +instance OkClsish () a => OkCls a where + + + + You may write programs that use exotic sorts of constraints in instance contexts and superclasses, but + to do so you must use to signal that you don't mind if the type checker + fails to terminate. + + + + + +Other type system extensions + +Explicit universal quantification (forall) + +Haskell type signatures are implicitly quantified. When the language option +is used, the keyword forall +allows us to say exactly what this means. For example: + + + + g :: b -> b + +means this: + + g :: forall b. (b -> b) + +The two are treated identically. + + +Of course forall becomes a keyword; you can't use forall as +a type variable any more! + + + + +The context of a type signature + +The flag lifts the Haskell 98 restriction +that the type-class constraints in a type signature must have the +form (class type-variable) or +(class (type-variable type1 type2 ... typen)). +With +these type signatures are perfectly OK + + g :: Eq [a] => ... + g :: Ord (T a ()) => ... + +The flag also lifts the corresponding +restriction on class declarations () and instance declarations +(). + + + +Ambiguous types and the ambiguity check + + +Each user-written type signature is subjected to an +ambiguity check. +The ambiguity check rejects functions that can never be called; for example: + + f :: C a => Int + +The idea is there can be no legal calls to f because every call will +give rise to an ambiguous constraint. +Indeed, the only purpose of the +ambiguity check is to report functions that cannot possibly be called. +We could soundly omit the +ambiguity check on type signatures entirely, at the expense of +delaying ambiguity errors to call sites. Indeed, the language extension + switches off the ambiguity check. + + +Ambiguity can be subtle. Consider this example which uses functional dependencies: + + class D a b | a -> b where .. + h :: D Int b => Int + +The Int may well fix b at the call site, so that signature should +not be rejected. Moreover, the dependencies might be hidden. Consider + + class X a b where ... + class D a b | a -> b where ... + instance D a b => X [a] b where... + h :: X a b => a -> a + +Here h's type looks ambiguous in b, but here's a legal call: + + ...(h [True])... + +That gives rise to a (X [Bool] beta) constraint, and using the +instance means we need (D Bool beta) and that +fixes beta via D's +fundep! + + +Behind all these special cases there is a simple guiding principle. +Consider + + f :: type + f = ...blah... + + g :: type + g = f + +You would think that the definition of g would surely typecheck! +After all f has exactly the same type, and g=f. +But in fact f's type +is instantiated and the instantiated constraints are solved against +the constraints bound by g's signature. So, in the case an ambiguous type, solving will fail. +For example, consider the earlier definition f :: C a => Int: + + f :: C a => Int + f = ...blah... + + g :: C a => Int + g = f + +In g's definition, +we'll instantiate to (C alpha) and try to +deduce (C alpha) from (C a), +and fail. + + +So in fact we use this as our definition of ambiguity: a type +ty is +ambiguious if and only if ((undefined :: ty) +:: ty) would fail to typecheck. We use a +very similar test for inferred types, to ensure that they too are +unambiguous. + +Switching off the ambiguity check. +Even if a function is has an ambiguous type according the "guiding principle", +it is possible that the function is callable. For example: + + class D a b where ... + instance D Bool b where ... + + strange :: D a b => a -> a + strange = ...blah... + + foo = strange True + +Here strange's type is ambiguous, but the call in foo +is OK because it gives rise to a constraint (D Bool beta), which is +soluble by the (D Bool b) instance. So the language extension + allows you to switch off the ambiguity check. +But even with ambiguity checking switched off, GHC will complain about a function +that can never be called, such as this one: + + f :: (Int ~ Bool) => a -> a + + + + +A historical note. +GHC used to impose some more restrictive and less principled conditions +on type signatures. For type type +forall tv1..tvn (c1, ...,cn) => type +GHC used to require (a) that each universally quantified type variable +tvi must be "reachable" from type, +and (b) that every constraint ci mentions at least one of the +universally quantified type variables tvi. +These ad-hoc restrictions are completely subsumed by the new ambiguity check. +End of historical note. + + + + + +Implicit parameters + + Implicit parameters are implemented as described in +"Implicit parameters: dynamic scoping with static types", +J Lewis, MB Shields, E Meijer, J Launchbury, +27th ACM Symposium on Principles of Programming Languages (POPL'00), +Boston, Jan 2000. +(Most of the following, still rather incomplete, documentation is +due to Jeff Lewis.) + +Implicit parameter support is enabled with the option +. + + +A variable is called dynamically bound when it is bound by the calling +context of a function and statically bound when bound by the callee's +context. In Haskell, all variables are statically bound. Dynamic +binding of variables is a notion that goes back to Lisp, but was later +discarded in more modern incarnations, such as Scheme. Dynamic binding +can be very confusing in an untyped language, and unfortunately, typed +languages, in particular Hindley-Milner typed languages like Haskell, +only support static scoping of variables. + + +However, by a simple extension to the type class system of Haskell, we +can support dynamic binding. Basically, we express the use of a +dynamically bound variable as a constraint on the type. These +constraints lead to types of the form (?x::t') => t, which says "this +function uses a dynamically-bound variable ?x +of type t'". For +example, the following expresses the type of a sort function, +implicitly parameterized by a comparison function named cmp. + + sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] + +The dynamic binding constraints are just a new form of predicate in the type class system. + + +An implicit parameter occurs in an expression using the special form ?x, +where x is +any valid identifier (e.g. ord ?x is a valid expression). +Use of this construct also introduces a new +dynamic-binding constraint in the type of the expression. +For example, the following definition +shows how we can define an implicitly parameterized sort function in +terms of an explicitly parameterized sortBy function: + + sortBy :: (a -> a -> Bool) -> [a] -> [a] + + sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] + sort = sortBy ?cmp + + + + +Implicit-parameter type constraints + +Dynamic binding constraints behave just like other type class +constraints in that they are automatically propagated. Thus, when a +function is used, its implicit parameters are inherited by the +function that called it. For example, our sort function might be used +to pick out the least value in a list: + + least :: (?cmp :: a -> a -> Bool) => [a] -> a + least xs = head (sort xs) + +Without lifting a finger, the ?cmp parameter is +propagated to become a parameter of least as well. With explicit +parameters, the default is that parameters must always be explicit +propagated. With implicit parameters, the default is to always +propagate them. + + +An implicit-parameter type constraint differs from other type class constraints in the +following way: All uses of a particular implicit parameter must have +the same type. This means that the type of (?x, ?x) +is (?x::a) => (a,a), and not +(?x::a, ?x::b) => (a, b), as would be the case for type +class constraints. + + + You can't have an implicit parameter in the context of a class or instance +declaration. For example, both these declarations are illegal: + + class (?x::Int) => C a where ... + instance (?x::a) => Foo [a] where ... + +Reason: exactly which implicit parameter you pick up depends on exactly where +you invoke a function. But the ``invocation'' of instance declarations is done +behind the scenes by the compiler, so it's hard to figure out exactly where it is done. +Easiest thing is to outlaw the offending types. + +Implicit-parameter constraints do not cause ambiguity. For example, consider: + + f :: (?x :: [a]) => Int -> Int + f n = n + length ?x + + g :: (Read a, Show a) => String -> String + g s = show (read s) + +Here, g has an ambiguous type, and is rejected, but f +is fine. The binding for ?x at f's call site is +quite unambiguous, and fixes the type a. + + + + +Implicit-parameter bindings + + +An implicit parameter is bound using the standard +let or where binding forms. +For example, we define the min function by binding +cmp. + + min :: [a] -> a + min = let ?cmp = (<=) in least + + + +A group of implicit-parameter bindings may occur anywhere a normal group of Haskell +bindings can occur, except at top level. That is, they can occur in a let +(including in a list comprehension, or do-notation, or pattern guards), +or a where clause. +Note the following points: + + +An implicit-parameter binding group must be a +collection of simple bindings to implicit-style variables (no +function-style bindings, and no type signatures); these bindings are +neither polymorphic or recursive. + + +You may not mix implicit-parameter bindings with ordinary bindings in a +single let +expression; use two nested lets instead. +(In the case of where you are stuck, since you can't nest where clauses.) + + + +You may put multiple implicit-parameter bindings in a +single binding group; but they are not treated +as a mutually recursive group (as ordinary let bindings are). +Instead they are treated as a non-recursive group, simultaneously binding all the implicit +parameter. The bindings are not nested, and may be re-ordered without changing +the meaning of the program. +For example, consider: + + f t = let { ?x = t; ?y = ?x+(1::Int) } in ?x + ?y + +The use of ?x in the binding for ?y does not "see" +the binding for ?x, so the type of f is + + f :: (?x::Int) => Int -> Int + + + + + + + +Implicit parameters and polymorphic recursion + + +Consider these two definitions: + + len1 :: [a] -> Int + len1 xs = let ?acc = 0 in len_acc1 xs + + len_acc1 [] = ?acc + len_acc1 (x:xs) = let ?acc = ?acc + (1::Int) in len_acc1 xs + + ------------ + + len2 :: [a] -> Int + len2 xs = let ?acc = 0 in len_acc2 xs + + len_acc2 :: (?acc :: Int) => [a] -> Int + len_acc2 [] = ?acc + len_acc2 (x:xs) = let ?acc = ?acc + (1::Int) in len_acc2 xs + +The only difference between the two groups is that in the second group +len_acc is given a type signature. +In the former case, len_acc1 is monomorphic in its own +right-hand side, so the implicit parameter ?acc is not +passed to the recursive call. In the latter case, because len_acc2 +has a type signature, the recursive call is made to the +polymorphic version, which takes ?acc +as an implicit parameter. So we get the following results in GHCi: + + Prog> len1 "hello" + 0 + Prog> len2 "hello" + 5 + +Adding a type signature dramatically changes the result! This is a rather +counter-intuitive phenomenon, worth watching out for. + + + +Implicit parameters and monomorphism + +GHC applies the dreaded Monomorphism Restriction (section 4.5.5 of the +Haskell Report) to implicit parameters. For example, consider: + + f :: Int -> Int + f v = let ?x = 0 in + let y = ?x + v in + let ?x = 5 in + y + +Since the binding for y falls under the Monomorphism +Restriction it is not generalised, so the type of y is +simply Int, not (?x::Int) => Int. +Hence, (f 9) returns result 9. +If you add a type signature for y, then y +will get type (?x::Int) => Int, so the occurrence of +y in the body of the let will see the +inner binding of ?x, so (f 9) will return +14. + + + + +Special implicit parameters + +GHC treats implicit parameters of type GHC.Stack.CallStack +specially, by resolving them to the current location in the program. Consider: + + f :: String + f = show (?loc :: CallStack) + +GHC will automatically resolve ?loc to its source +location. If another implicit parameter with type CallStack is +in scope, GHC will append the two locations, creating an explicit call-stack. For example: + + f :: (?stk :: CallStack) => String + f = show (?stk :: CallStack) + +will produce the location of ?stk, followed by +f's call-site. Note that the name of the implicit parameter does not +matter (we used ?loc above), GHC will solve any implicit parameter +with the right type. The name does, however, matter when pushing new locations onto +existing stacks. Consider: + + f :: (?stk :: CallStack) => String + f = show (?loc :: CallStack) + +When we call f, the stack will include the use of ?loc, +but not the call to f; in this case the names must match. + + +CallStack is kept abstract, but +GHC provides a function + + getCallStack :: CallStack -> [(String, SrcLoc)] + +to access the individual call-sites in the stack. The String +is the name of the function that was called, and the SrcLoc +provides the package, module, and file name, as well as the line and column +numbers. The stack will never be empty, as the first call-site +will be the location at which the implicit parameter was used. GHC will also +never infer ?loc :: CallStack as a type constraint, which +means that functions must explicitly ask to be told about their call-sites. + + +A potential "gotcha" when using implicit CallStacks is that +the :type command in GHCi will not report the +?loc :: CallStack constraint, as the typechecker will +immediately solve it. Use :info instead to print the +unsolved type. + + + + + +Explicitly-kinded quantification + + +Haskell infers the kind of each type variable. Sometimes it is nice to be able +to give the kind explicitly as (machine-checked) documentation, +just as it is nice to give a type signature for a function. On some occasions, +it is essential to do so. For example, in his paper "Restricted Data Types in Haskell" (Haskell Workshop 1999) +John Hughes had to define the data type: + + data Set cxt a = Set [a] + | Unused (cxt a -> ()) + +The only use for the Unused constructor was to force the correct +kind for the type variable cxt. + + +GHC now instead allows you to specify the kind of a type variable directly, wherever +a type variable is explicitly bound, with the flag . + + +This flag enables kind signatures in the following places: + +data declarations: + + data Set (cxt :: * -> *) a = Set [a] + +type declarations: + + type T (f :: * -> *) = f Int + +class declarations: + + class (Eq a) => C (f :: * -> *) a where ... + +forall's in type signatures: + + f :: forall (cxt :: * -> *). Set cxt Int + + + + + +The parentheses are required. Some of the spaces are required too, to +separate the lexemes. If you write (f::*->*) you +will get a parse error, because "::*->*" is a +single lexeme in Haskell. + + + +As part of the same extension, you can put kind annotations in types +as well. Thus: + + f :: (Int :: *) -> Int + g :: forall a. a -> (a :: *) + +The syntax is + + atype ::= '(' ctype '::' kind ') + +The parentheses are required. + + + + + +Arbitrary-rank polymorphism + + + +GHC's type system supports arbitrary-rank +explicit universal quantification in +types. +For example, all the following types are legal: + + f1 :: forall a b. a -> b -> a + g1 :: forall a b. (Ord a, Eq b) => a -> b -> a + + f2 :: (forall a. a->a) -> Int -> Int + g2 :: (forall a. Eq a => [a] -> a -> Bool) -> Int -> Int + + f3 :: ((forall a. a->a) -> Int) -> Bool -> Bool + + f4 :: Int -> (forall a. a -> a) + +Here, f1 and g1 are rank-1 types, and +can be written in standard Haskell (e.g. f1 :: a->b->a). +The forall makes explicit the universal quantification that +is implicitly added by Haskell. + + +The functions f2 and g2 have rank-2 types; +the forall is on the left of a function arrow. As g2 +shows, the polymorphic type on the left of the function arrow can be overloaded. + + +The function f3 has a rank-3 type; +it has rank-2 types on the left of a function arrow. + + +The language option (which implies , ) +enables higher-rank types. +That is, you can nest foralls +arbitrarily deep in function arrows. +For example, a forall-type (also called a "type scheme"), +including a type-class context, is legal: + + On the left or right (see f4, for example) +of a function arrow + As the argument of a constructor, or type of a field, in a data type declaration. For +example, any of the f1,f2,f3,g1,g2 above would be valid +field type signatures. + As the type of an implicit parameter + In a pattern type signature (see ) + +The option is also required for any +type with a forall or +context to the right of an arrow (e.g. f :: Int -> forall a. a->a, or +g :: Int -> Ord a => a -> a). Such types are technically rank 1, but +are clearly not Haskell-98, and an extra flag did not seem worth the bother. + + + +The obselete language options and +are synonyms for . They used to specify finer distinctions that +GHC no longer makes. (They should really elicit a deprecation warning, but they don't, purely +to avoid the need to library authors to change their old flags specifciations.) + + + +Examples + + + +In a data or newtype declaration one can quantify +the types of the constructor arguments. Here are several examples: + + + + + +data T a = T1 (forall b. b -> b -> b) a + +data MonadT m = MkMonad { return :: forall a. a -> m a, + bind :: forall a b. m a -> (a -> m b) -> m b + } + +newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a]) + + + + + +The constructors have rank-2 types: + + + + + +T1 :: forall a. (forall b. b -> b -> b) -> a -> T a +MkMonad :: forall m. (forall a. a -> m a) + -> (forall a b. m a -> (a -> m b) -> m b) + -> MonadT m +MkSwizzle :: (forall a. Ord a => [a] -> [a]) -> Swizzle + + + + + +In earlier versions of GHC, it was possible to omit the forall +in the type of the constructor if there was an explicit context. For example: + + +newtype Swizzle' = MkSwizzle' (Ord a => [a] -> [a]) + + +As of GHC 7.10, this is deprecated. The -fwarn-context-quantification +flag detects this situation and issues a warning. In GHC 7.12, declarations +such as MkSwizzle' will cause an out-of-scope error. + + + +As for type signatures, implicit quantification happens for non-overloaded +types too. So if you write this: + + + f :: (a -> a) -> a + + +it's just as if you had written this: + + + f :: forall a. (a -> a) -> a + + +That is, since the type variable a isn't in scope, it's +implicitly universally quantified. + + + +You construct values of types T1, MonadT, Swizzle by applying +the constructor to suitable values, just as usual. For example, + + + + + + a1 :: T Int + a1 = T1 (\xy->x) 3 + + a2, a3 :: Swizzle + a2 = MkSwizzle sort + a3 = MkSwizzle reverse + + a4 :: MonadT Maybe + a4 = let r x = Just x + b m k = case m of + Just y -> k y + Nothing -> Nothing + in + MkMonad r b + + mkTs :: (forall b. b -> b -> b) -> a -> [T a] + mkTs f x y = [T1 f x, T1 f y] + + + + + +The type of the argument can, as usual, be more general than the type +required, as (MkSwizzle reverse) shows. (reverse +does not need the Ord constraint.) + + + +When you use pattern matching, the bound variables may now have +polymorphic types. For example: + + + + + + f :: T a -> a -> (a, Char) + f (T1 w k) x = (w k x, w 'c' 'd') + + g :: (Ord a, Ord b) => Swizzle -> [a] -> (a -> b) -> [b] + g (MkSwizzle s) xs f = s (map f (s xs)) + + h :: MonadT m -> [m a] -> m [a] + h m [] = return m [] + h m (x:xs) = bind m x $ \y -> + bind m (h m xs) $ \ys -> + return m (y:ys) + + + + + +In the function h we use the record selectors return +and bind to extract the polymorphic bind and return functions +from the MonadT data structure, rather than using pattern +matching. + + + + +Type inference + + +In general, type inference for arbitrary-rank types is undecidable. +GHC uses an algorithm proposed by Odersky and Laufer ("Putting type annotations to work", POPL'96) +to get a decidable algorithm by requiring some help from the programmer. +We do not yet have a formal specification of "some help" but the rule is this: + + +For a lambda-bound or case-bound variable, x, either the programmer +provides an explicit polymorphic type for x, or GHC's type inference will assume +that x's type has no foralls in it. + + +What does it mean to "provide" an explicit type for x? You can do that by +giving a type signature for x directly, using a pattern type signature +(), thus: + + \ f :: (forall a. a->a) -> (f True, f 'c') + +Alternatively, you can give a type signature to the enclosing +context, which GHC can "push down" to find the type for the variable: + + (\ f -> (f True, f 'c')) :: (forall a. a->a) -> (Bool,Char) + +Here the type signature on the expression can be pushed inwards +to give a type signature for f. Similarly, and more commonly, +one can give a type signature for the function itself: + + h :: (forall a. a->a) -> (Bool,Char) + h f = (f True, f 'c') + +You don't need to give a type signature if the lambda bound variable +is a constructor argument. Here is an example we saw earlier: + + f :: T a -> a -> (a, Char) + f (T1 w k) x = (w k x, w 'c' 'd') + +Here we do not need to give a type signature to w, because +it is an argument of constructor T1 and that tells GHC all +it needs to know. + + + + + + +Implicit quantification + + +GHC performs implicit quantification as follows. At the top level (only) of +user-written types, if and only if there is no explicit forall, +GHC finds all the type variables mentioned in the type that are not already +in scope, and universally quantifies them. For example, the following pairs are +equivalent: + + f :: a -> a + f :: forall a. a -> a + + g (x::a) = let + h :: a -> b -> b + h x y = y + in ... + g (x::a) = let + h :: forall b. a -> b -> b + h x y = y + in ... + + + +Notice that GHC does not find the innermost possible quantification +point. For example: + + f :: (a -> a) -> Int + -- MEANS + f :: forall a. (a -> a) -> Int + -- NOT + f :: (forall a. a -> a) -> Int + + + g :: (Ord a => a -> a) -> Int + -- MEANS the illegal type + g :: forall a. (Ord a => a -> a) -> Int + -- NOT + g :: (forall a. Ord a => a -> a) -> Int + +The latter produces an illegal type, which you might think is silly, +but at least the rule is simple. If you want the latter type, you +can write your for-alls explicitly. Indeed, doing so is strongly advised +for rank-2 types. + + + + + + +Impredicative polymorphism + +GHC supports impredicative polymorphism, +enabled with . +This means +that you can call a polymorphic function at a polymorphic type, and +parameterise data structures over polymorphic types. For example: + + f :: Maybe (forall a. [a] -> [a]) -> Maybe ([Int], [Char]) + f (Just g) = Just (g [3], g "hello") + f Nothing = Nothing + +Notice here that the Maybe type is parameterised by the +polymorphic type (forall a. [a] -> +[a]). + +The technical details of this extension are described in the paper +Boxy types: +type inference for higher-rank types and impredicativity, +which appeared at ICFP 2006. + + + + +Lexically scoped type variables + + + +GHC supports lexically scoped type variables, without +which some type signatures are simply impossible to write. For example: + +f :: forall a. [a] -> [a] +f xs = ys ++ ys + where + ys :: [a] + ys = reverse xs + +The type signature for f brings the type variable a into scope, +because of the explicit forall (). +The type variables bound by a forall scope over +the entire definition of the accompanying value declaration. +In this example, the type variable a scopes over the whole +definition of f, including over +the type signature for ys. +In Haskell 98 it is not possible to declare +a type for ys; a major benefit of scoped type variables is that +it becomes possible to do so. + +Lexically-scoped type variables are enabled by +. This flag implies . + + + +Overview + +The design follows the following principles + +A scoped type variable stands for a type variable, and not for +a type. (This is a change from GHC's earlier +design.) +Furthermore, distinct lexical type variables stand for distinct +type variables. This means that every programmer-written type signature +(including one that contains free scoped type variables) denotes a +rigid type; that is, the type is fully known to the type +checker, and no inference is involved. +Lexical type variables may be alpha-renamed freely, without +changing the program. + + + +A lexically scoped type variable can be bound by: + +A declaration type signature () +An expression type signature () +A pattern type signature () +Class and instance declarations () + + + +In Haskell, a programmer-written type signature is implicitly quantified over +its free type variables (Section +4.1.2 +of the Haskell Report). +Lexically scoped type variables affect this implicit quantification rules +as follows: any type variable that is in scope is not universally +quantified. For example, if type variable a is in scope, +then + + (e :: a -> a) means (e :: a -> a) + (e :: b -> b) means (e :: forall b. b->b) + (e :: a -> b) means (e :: forall b. a->b) + + + + + + + + +Declaration type signatures +A declaration type signature that has explicit +quantification (using forall) brings into scope the +explicitly-quantified +type variables, in the definition of the named function. For example: + + f :: forall a. [a] -> [a] + f (x:xs) = xs ++ [ x :: a ] + +The "forall a" brings "a" into scope in +the definition of "f". + +This only happens if: + + The quantification in f's type +signature is explicit. For example: + + g :: [a] -> [a] + g (x:xs) = xs ++ [ x :: a ] + +This program will be rejected, because "a" does not scope +over the definition of "g", so "x::a" +means "x::forall a. a" by Haskell's usual implicit +quantification rules. + + The signature gives a type for a function binding or a bare variable binding, +not a pattern binding. +For example: + + f1 :: forall a. [a] -> [a] + f1 (x:xs) = xs ++ [ x :: a ] -- OK + + f2 :: forall a. [a] -> [a] + f2 = \(x:xs) -> xs ++ [ x :: a ] -- OK + + f3 :: forall a. [a] -> [a] + Just f3 = Just (\(x:xs) -> xs ++ [ x :: a ]) -- Not OK! + +The binding for f3 is a pattern binding, and so its type signature +does not bring a into scope. However f1 is a +function binding, and f2 binds a bare variable; in both cases +the type signature brings a into scope. + + + + + + +Expression type signatures + +An expression type signature that has explicit +quantification (using forall) brings into scope the +explicitly-quantified +type variables, in the annotated expression. For example: + + f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool ) + +Here, the type signature forall s. ST s Bool brings the +type variable s into scope, in the annotated expression +(op >>= \(x :: STRef s Int) -> g x). + + + + + +Pattern type signatures + +A type signature may occur in any pattern; this is a pattern type +signature. +For example: + + -- f and g assume that 'a' is already in scope + f = \(x::Int, y::a) -> x + g (x::a) = x + h ((x,y) :: (Int,Bool)) = (y,x) + +In the case where all the type variables in the pattern type signature are +already in scope (i.e. bound by the enclosing context), matters are simple: the +signature simply constrains the type of the pattern in the obvious way. + + +Unlike expression and declaration type signatures, pattern type signatures are not implicitly generalised. +The pattern in a pattern binding may only mention type variables +that are already in scope. For example: + + f :: forall a. [a] -> (Int, [a]) + f xs = (n, zs) + where + (ys::[a], n) = (reverse xs, length xs) -- OK + zs::[a] = xs ++ ys -- OK + + Just (v::b) = ... -- Not OK; b is not in scope + +Here, the pattern signatures for ys and zs +are fine, but the one for v is not because b is +not in scope. + + +However, in all patterns other than pattern bindings, a pattern +type signature may mention a type variable that is not in scope; in this case, +the signature brings that type variable into scope. +This is particularly important for existential data constructors. For example: + + data T = forall a. MkT [a] + + k :: T -> T + k (MkT [t::a]) = MkT t3 + where + t3::[a] = [t,t,t] + +Here, the pattern type signature (t::a) mentions a lexical type +variable that is not already in scope. Indeed, it cannot already be in scope, +because it is bound by the pattern match. GHC's rule is that in this situation +(and only then), a pattern type signature can mention a type variable that is +not already in scope; the effect is to bring it into scope, standing for the +existentially-bound type variable. + + +When a pattern type signature binds a type variable in this way, GHC insists that the +type variable is bound to a rigid, or fully-known, type variable. +This means that any user-written type signature always stands for a completely known type. + + +If all this seems a little odd, we think so too. But we must have +some way to bring such type variables into scope, else we +could not name existentially-bound type variables in subsequent type signatures. + + +This is (now) the only situation in which a pattern type +signature is allowed to mention a lexical variable that is not already in +scope. +For example, both f and g would be +illegal if a was not already in scope. + + + + + + + + +Class and instance declarations + + +The type variables in the head of a class or instance declaration +scope over the methods defined in the where part. For example: + + + + class C a where + op :: [a] -> a + + op xs = let ys::[a] + ys = reverse xs + in + head ys + + + + + + + +Bindings and generalisation + + +Switching off the dreaded Monomorphism Restriction + + +Haskell's monomorphism restriction (see +Section +4.5.5 +of the Haskell Report) +can be completely switched off by +. Since GHC 7.8.1, the monomorphism +restriction is switched off by default in GHCi's interactive options (see ). + + + + + +Generalised typing of mutually recursive bindings + + +The Haskell Report specifies that a group of bindings (at top level, or in a +let or where) should be sorted into +strongly-connected components, and then type-checked in dependency order +(Haskell +Report, Section 4.5.1). +As each group is type-checked, any binders of the group that +have +an explicit type signature are put in the type environment with the specified +polymorphic type, +and all others are monomorphic until the group is generalised +(Haskell Report, Section 4.5.2). + + +Following a suggestion of Mark Jones, in his paper +Typing Haskell in +Haskell, +GHC implements a more general scheme. If is +specified: +the dependency analysis ignores references to variables that have an explicit +type signature. +As a result of this refined dependency analysis, the dependency groups are smaller, and more bindings will +typecheck. For example, consider: + + f :: Eq a => a -> Bool + f x = (x == x) || g True || g "Yes" + + g y = (y <= y) || f True + +This is rejected by Haskell 98, but under Jones's scheme the definition for +g is typechecked first, separately from that for +f, +because the reference to f in g's right +hand side is ignored by the dependency analysis. Then g's +type is generalised, to get + + g :: Ord a => a -> Bool + +Now, the definition for f is typechecked, with this type for +g in the type environment. + + + +The same refined dependency analysis also allows the type signatures of +mutually-recursive functions to have different contexts, something that is illegal in +Haskell 98 (Section 4.5.2, last sentence). With + +GHC only insists that the type signatures of a refined group have identical +type signatures; in practice this means that only variables bound by the same +pattern binding must have the same context. For example, this is fine: + + f :: Eq a => a -> Bool + f x = (x == x) || g True + + g :: Ord a => a -> Bool + g y = (y <= y) || f True + + + + + +Let-generalisation + +An ML-style language usually generalises the type of any let-bound or where-bound variable, +so that it is as polymorphic as possible. +With the flag GHC implements a slightly more conservative policy, +using the following rules: + + + A variable is closed if and only if + + the variable is let-bound + one of the following holds: + + the variable has an explicit type signature that has no free type variables, or + its binding group is fully generalised (see next bullet) + + + + + + + A binding group is fully generalised if and only if + + each of its free variables is either imported or closed, and + the binding is not affected by the monomorphism restriction + (Haskell Report, Section 4.5.5) + + + +For example, consider + +f x = x + 1 +g x = let h y = f y * 2 + k z = z+x + in h x + k x + +Here f is generalised because it has no free variables; and its binding group +is unaffected by the monomorphism restriction; and hence f is closed. +The same reasoning applies to g, except that it has one closed free variable, namely f. +Similarly h is closed, even though it is not bound at top level, +because its only free variable f is closed. +But k is not closed, because it mentions x which is not closed (because it is not let-bound). + + +Notice that a top-level binding that is affected by the monomorphism restriction is not closed, and hence may +in turn prevent generalisation of bindings that mention it. + + +The rationale for this more conservative strategy is given in +the papers "Let should not be generalised" and "Modular type inference with local assumptions", and +a related blog post. + +The flag is implied by and . You can switch it off again +with but type inference becomes less predicatable if you do so. (Read the papers!) + + + + + + + + +Typed Holes + + +Typed holes are a feature of GHC that allows special placeholders written with +a leading underscore (e.g., "_", "_foo", +"_bar"), to be used as expressions. During compilation these +holes will generate an error message that describes which type is expected at +the hole's location, information about the origin of any free type variables, +and a list of local bindings that might help fill the hole with actual code. +Typed holes are always enabled in GHC. + + + +The goal of typed holes is to help with writing Haskell code rather than to +change the type system. Typed holes can be used to obtain extra information +from the type checker, which might otherwise be hard to get. Normally, using +GHCi, users can inspect the (inferred) type signatures of all top-level +bindings. However, this method is less convenient with terms that are not +defined on top-level or inside complex expressions. Holes allow the user to +check the type of the term they are about to write. + + + +To run and test a piece of code containing holes, use the +-fdefer-typed-holes flag. This flag defers errors +produced by typed holes and converts them into warnings. The result is that +typed hole errors are converted into warnings (controlled by +-fwarn-typed-holes). The result is that a hole will behave +like undefined, but with the added benefits that it shows a +warning at compile time and will show another warning message if it gets +evaluated. This behaviour follows that of the +-fdefer-type-errors option, which implies +-fdefer-typed-holes. See . + + + +For example, compiling the following module with GHC: + +f :: a -> a +f x = _ + +will fail with the following error: + +hole.hs:2:7: + Found hole `_' with type: a + Where: `a' is a rigid type variable bound by + the type signature for f :: a -> a at hole.hs:1:6 + Relevant bindings include + f :: a -> a (bound at hole.hs:2:1) + x :: a (bound at hole.hs:2:3) + In the expression: _ + In an equation for `f': f x = _ + + + + +Multiple typed holes can be used to find common type variables between expressions. For example: + +sum :: [Int] -> Int +sum xs = foldr _f _z xs + +Shows: + +holes.hs:2:15: + Found hole `_f' with type: Int -> Int -> Int + In the first argument of `foldr', namely `_' + In the expression: foldr _a _b _c + In an equation for `sum': sum x = foldr _a _b _c + +holes.hs:2:17: + Found hole `_z' with type: Int + In the second argument of `foldr', namely `_' + In the expression: foldr _a _b _c + In an equation for `sum': sum x = foldr _a _b _c + + + + +Unbound identifiers with the same name are never unified, even within the same function, but always printed individually. +For example: + +cons = _x : _x + +results in the following errors: + +unbound.hs:1:8: + Found hole '_x' with type: a + Where: `a' is a rigid type variable bound by + the inferred type of cons :: [a] at unbound.hs:1:1 + Relevant bindings include cons :: [a] (bound at unbound.hs:1:1) + In the first argument of `(:)', namely `_x' + In the expression: _x : _x + In an equation for `cons': cons = _x : _x + +unbound.hs:1:13: + Found hole '_x' with type: [a] + Arising from: an undeclared identifier `_x' at unbound.hs:1:13-14 + Where: `a' is a rigid type variable bound by + the inferred type of cons :: [a] at unbound.hs:1:1 + Relevant bindings include cons :: [a] (bound at unbound.hs:1:1) + In the second argument of `(:)', namely `_x' + In the expression: _x : _x + In an equation for `cons': cons = _x : _x + +This ensures that an unbound identifier is never reported with a too polymorphic type, like +forall a. a, when used multiple times for types that can not be unified. + + + + + + +Partial Type Signatures + + +A partial type signature is a type signature containing special placeholders +written with a leading underscore (e.g., "_", +"_foo", "_bar") called +wildcards. Partial type signatures are to type signatures +what are to expressions. During compilation these +wildcards or holes will generate an error message that describes which type +was inferred at the hole's location, and information about the origin of any +free type variables. GHC reports such error messages by default. + + +Unlike , which make the program incomplete and +will generate errors when they are evaluated, this needn't be the case for +holes in type signatures. The type checker is capable (in most cases) of +type-checking a binding with or without a type signature. A partial type +signature bridges the gap between the two extremes, the programmer can choose +which parts of a type to annotate and which to leave over to the type-checker +to infer. + + + +By default, the type-checker will report an error message for each hole in a +partial type signature, informing the programmer of the inferred type. When +the flag is enabled, the type-checker +will accept the inferred type for each hole, generating warnings instead of +errors. Additionally, these warnings can be silenced with the + flag. + + + +Syntax + + +A (partial) type signature has the following form: forall a b .. . +(C1, C2, ..) => tau. It consists of three parts: + + + + The type variables: a b .. + The constraints: (C1, C2, ..) + The (mono)type: tau + + + +We distinguish three kinds of wildcards. + + + +Type Wildcards + +Wildcards occurring within the monotype (tau) part of the type signature are +type wildcards ("type" is often omitted as this is the +default kind of wildcard). Type wildcards can be instantiated to any monotype +like Bool or Maybe [Bool], including +functions and higher-kinded types like (Int -> Bool) or +Maybe. + + +not' :: Bool -> _ +not' x = not x +-- Inferred: Bool -> Bool + +maybools :: _ +maybools = Just [True] +-- Inferred: Maybe [Bool] + +just1 :: _ Int +just1 = Just 1 +-- Inferred: Maybe Int + +filterInt :: _ -> _ -> [Int] +filterInt = filter -- has type forall a. (a -> Bool) -> [a] -> [a] +-- Inferred: (Int -> Bool) -> [Int] -> [Int] + + + +For instance, the first wildcard in the type signature not' +would produce the following error message: + + +Test.hs:4:17: + Found hole ‘_’ with type: Bool + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘not'’: Bool -> _ + + + +When a wildcard is not instantiated to a monotype, it will be generalised +over, i.e. replaced by a fresh type variable (of which the name will often +start with w_), e.g. + + +foo :: _ -> _ +foo x = x +-- Inferred: forall w_. w_ -> w_ + +filter' :: _ +filter' = filter -- has type forall a. (a -> Bool) -> [a] -> [a] +-- Inferred: (a -> Bool) -> [a] -> [a] + + + + +Named Wildcards + +Type wildcards can also be named by giving the underscore an identifier as +suffix, i.e. _a. These are called named +wildcards. All occurrences of the same named wildcard within one +type signature will unify to the same type. For example: + + +f :: _x -> _x +f ('c', y) = ('d', error "Urk") +-- Inferred: forall t. (Char, t) -> (Char, t) + + + +The named wildcard forces the argument and result types to be the same. +Lacking a signature, GHC would have inferred forall a b. (Char, a) -> +(Char, b). A named wildcard can be mentioned in constraints, +provided it also occurs in the monotype part of the type signature to make +sure that it unifies with something: + + + +somethingShowable :: Show _x => _x -> _ +somethingShowable x = show x +-- Inferred type: Show w_x => w_x -> String + +somethingShowable' :: Show _x => _x -> _ +somethingShowable' x = show (not x) +-- Inferred type: Bool -> String + + + +Besides an extra-constraints wildcard (see ), only named wildcards can occur in the +constraints, e.g. the _x in Show _x. + + + +Named wildcards should not be confused with type +variables. Even though syntactically similar, named wildcards can +unify with monotypes as well as be generalised over (and behave as type +variables). + + +In the first example above, _x is generalised over (and is +effectively replaced by a fresh type variable w_x). In the +second example, _x is unified with the +Bool type, and as Bool implements the +Show type class, the constraint Show +Bool can be simplified away. + + + +By default, GHC (as the Haskell 2010 standard prescribes) parses identifiers +starting with an underscore in a type as type variables. To treat them as +named wildcards, the flag should be enabled. +The example below demonstrated the effect. + + + +foo :: _a -> _a +foo _ = False + + + +Compiling this program without enabling +produces the following error message complaining about the type variable +_a no matching the actual type Bool. + + + +Test.hs:5:9: + Couldn't match expected type ‘_a’ with actual type ‘Bool’ + ‘_a’ is a rigid type variable bound by + the type signature for foo :: _a -> _a at Test.hs:4:8 + Relevant bindings include foo :: _a -> _a (bound at Test.hs:4:1) + In the expression: False + In an equation for ‘foo’: foo _ = False + + + +Compiling this program with enabled produces +the following error message reporting the inferred type of the named wildcard +_a. + + + +Test.hs:4:8: Warning: + Found hole ‘_a’ with type: Bool + In the type signature for ‘foo’: _a -> _a + + + + +Extra-Constraints Wildcard + + +The third kind of wildcard is the extra-constraints +wildcard. The presence of an extra-constraints wildcard indicates +that an arbitrary number of extra constraints may be inferred during type +checking and will be added to the type signature. In the example below, the +extra-constraints wildcard is used to infer three extra constraints. + + + +arbitCs :: _ => a -> String +arbitCs x = show (succ x) ++ show (x == x) +-- Inferred: +-- forall a. (Enum a, Eq a, Show a) => a -> String +-- Error: +Test.hs:5:12: + Found hole ‘_’ with inferred constraints: (Enum a, Eq a, Show a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘arbitCs’: _ => a -> String + + + +An extra-constraints wildcard shouldn't prevent the programmer from already +listing the constraints he knows or wants to annotate, e.g. + + + +-- Also a correct partial type signature: +arbitCs' :: (Enum a, _) => a -> String +arbitCs' x = arbitCs x +-- Inferred: +-- forall a. (Enum a, Show a, Eq a) => a -> String +-- Error: +Test.hs:9:22: + Found hole ‘_’ with inferred constraints: (Eq a, Show a) + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘arbitCs'’: (Enum a, _) => a -> String + + + +An extra-constraints wildcard can also lead to zero extra constraints to be +inferred, e.g. + + + +noCs :: _ => String +noCs = "noCs" +-- Inferred: String +-- Error: +Test.hs:13:9: + Found hole ‘_’ with inferred constraints: () + To use the inferred type, enable PartialTypeSignatures + In the type signature for ‘noCs’: _ => String + + + +As a single extra-constraints wildcard is enough to infer any number of +constraints, only one is allowed in a type signature and it should come last +in the list of constraints. + + + +Extra-constraints wildcards cannot be named. + + + + + + +Where can they occur? + + +Partial type signatures are allowed for bindings, pattern and expression signatures. +In all other contexts, e.g. type class or type family declarations, they are disallowed. +In the following example a wildcard is used in each of the three possible contexts. + + +{-# LANGUAGE ScopedTypeVariables #-} +foo :: _ +foo (x :: _) = (x :: _) +-- Inferred: forall w_. w_ -> w_ + + + + + + +Deferring type errors to runtime + + While developing, sometimes it is desirable to allow compilation to succeed + even if there are type errors in the code. Consider the following case: + +module Main where + +a :: Int +a = 'a' + +main = print "b" + + Even though a is ill-typed, it is not used in the end, so if + all that we're interested in is main it can be useful to be + able to ignore the problems in a. + + + For more motivation and details please refer to the HaskellWiki + page or the original + paper. + + +Enabling deferring of type errors + + The flag -fdefer-type-errors controls whether type + errors are deferred to runtime. Type errors will still be emitted as + warnings, but will not prevent compilation. + + + This flag implies the -fdefer-typed-holes flag, + which enables this behaviour for typed holes + . Should you so wish, it is possible to enable + -fdefer-type-errors without enabling + -fdefer-typed-holes, by explicitly specifying + -fno-defer-typed-holes on the commandline after the + -fdefer-type-errors flag. + + + At runtime, whenever a term containing a type error would need to be + evaluated, the error is converted into a runtime exception. + Note that type errors are deferred as much as possible during runtime, but + invalid coercions are never performed, even when they would ultimately + result in a value of the correct type. For example, given the following + code: + +x :: Int +x = 0 + +y :: Char +y = x + +z :: Int +z = y + + evaluating z will result in a runtime type error. + + +Deferred type errors in GHCi + + The flag -fdefer-type-errors works in GHCi as well, with + one exception: for "naked" expressions typed at the prompt, type + errors don't get delayed, so for example: + +Prelude> fst (True, 1 == 'a') + +<interactive>:2:12: + No instance for (Num Char) arising from the literal `1' + Possible fix: add an instance declaration for (Num Char) + In the first argument of `(==)', namely `1' + In the expression: 1 == 'a' + In the first argument of `fst', namely `(True, 1 == 'a')' + +Otherwise, in the common case of a simple type error such as +typing reverse True at the prompt, you would get a warning and then +an immediately-following type error when the expression is evaluated. + + + This exception doesn't apply to statements, as the following example demonstrates: + +Prelude> let x = (True, 1 == 'a') + +<interactive>:3:16: Warning: + No instance for (Num Char) arising from the literal `1' + Possible fix: add an instance declaration for (Num Char) + In the first argument of `(==)', namely `1' + In the expression: 1 == 'a' + In the expression: (True, 1 == 'a') +Prelude> fst x +True + + + + + + + + +Template Haskell + +Template Haskell allows you to do compile-time meta-programming in +Haskell. +The background to +the main technical innovations is discussed in " +Template Meta-programming for Haskell" (Proc Haskell Workshop 2002). + + +There is a Wiki page about +Template Haskell at +http://www.haskell.org/haskellwiki/Template_Haskell, and that is the best place to look for +further details. +You may also +consult the online +Haskell library reference material +(look for module Language.Haskell.TH). +Many changes to the original design are described in + +Notes on Template Haskell version 2. +Not all of these changes are in GHC, however. + + + The first example from that paper is set out below () +as a worked example to help get you started. + + + +The documentation here describes the realisation of Template Haskell in GHC. It is not detailed enough to +understand Template Haskell; see the +Wiki page. + + + + Syntax + + Template Haskell has the following new syntactic + constructions. You need to use the flag + + + to switch these syntactic extensions on. + + + + A splice is written $x, where x is an + identifier, or $(...), where the "..." is an arbitrary expression. + There must be no space between the "$" and the identifier or parenthesis. This use + of "$" overrides its meaning as an infix operator, just as "M.x" overrides the meaning + of "." as an infix operator. If you want the infix operator, put spaces around it. + + A splice can occur in place of + + an expression; the spliced expression must + have type Q Exp + a pattern; the spliced pattern must + have type Q Pat + a type; the spliced expression must + have type Q Type + a list of declarations at top level; the spliced expression + must have type Q [Dec] + + Inside a splice you can only call functions defined in imported modules, + not functions defined elsewhere in the same module. Note that + declaration splices are not allowed anywhere except at top level + (outside any other declarations). + + + A expression quotation is written in Oxford brackets, thus: + + [| ... |], or [e| ... |], + where the "..." is an expression; + the quotation has type Q Exp. + [d| ... |], where the "..." is a list of top-level declarations; + the quotation has type Q [Dec]. + [t| ... |], where the "..." is a type; + the quotation has type Q Type. + [p| ... |], where the "..." is a pattern; + the quotation has type Q Pat. + + + + + A typed expression splice is written + $$x, where x is an + identifier, or $$(...), where the "..." is + an arbitrary expression. + + + A typed expression splice can occur in place of an + expression; the spliced expression must have type Q + (TExp a) + + + + + + A typed expression quotation is written + as [|| ... ||], or [e|| + ... ||], where the "..." is an expression; if the + "..." expression has type a, then the + quotation has type Q (TExp a). + + + + Values of type TExp a may be converted to + values of type Exp using the function + unType :: TExp a -> Exp. + + + + + A quasi-quotation can appear in either a pattern context or an + expression context and is also written in Oxford brackets: + + [varid| ... |], + where the "..." is an arbitrary string; a full description of the + quasi-quotation facility is given in . + + + + A name can be quoted with either one or two prefix single quotes: + + 'f has type Name, and names the function f. + Similarly 'C has type Name and names the data constructor C. + In general 'thing + interprets thing in an expression context. + A name whose second character is a single + quote (sadly) cannot be quoted in this way, + because it will be parsed instead as a quoted + character. For example, if the function is called + f'7 (which is a legal Haskell + identifier), an attempt to quote it as + 'f'7 would be parsed as the + character literal 'f' followed + by the numeric literal 7. There + is no current escape mechanism in this (unusual) + situation. + + ''T has type Name, and names the type constructor T. + That is, ''thing interprets thing in a type context. + + + These Names can be used to construct Template Haskell expressions, patterns, declarations etc. They + may also be given as an argument to the reify function. + + + + You may omit the $(...) in a top-level declaration splice. + Simply writing an expression (rather than a declaration) implies a splice. For example, you can write + +module Foo where +import Bar + +f x = x + +$(deriveStuff 'f) -- Uses the $(...) notation + +g y = y+1 + +deriveStuff 'g -- Omits the $(...) + +h z = z-1 + + This abbreviation makes top-level declaration slices quieter and less intimidating. + + + + + Outermost pattern splices may bind variables. By "outermost" here, we refer to + a pattern splice that occurs outside of any quotation brackets. For example, + + +mkPat :: Bool -> Q Pat +mkPat True = [p| (x, y) |] +mkPat False = [p| (y, x) |] + +-- in another module: +foo :: (Char, String) -> String +foo $(mkPat True) = x : y + +bar :: (String, Char) -> String +bar $(mkPat False) = x : y + + + + + + + + Nested pattern splices do not bind variables. + By "nested" here, we refer to a pattern splice occurring within a + quotation bracket. Continuing the example from the last bullet: + + +baz :: Bool -> Q Exp +baz b = [| quux $(mkPat b) = x + y |] + + + would fail with x and y + being out of scope. + + + + The difference in treatment of outermost and nested pattern splices is + because outermost splices are run at compile time. GHC can then use + the result of running the splice when analyzing the expressions within + the pattern's scope. Nested splices, on the other hand, are not + run at compile time; they are run when the bracket is spliced in, sometime later. + Since nested pattern splices may refer to local variables, there is no way for GHC + to know, at splice compile time, what variables are bound, so it binds none. + + + + + + A pattern quasiquoter may + generate binders that scope over the right-hand side of a + definition because these binders are in scope lexically. For + example, given a quasiquoter haskell that + parses Haskell, in the following code, the y + in the right-hand side of f refers to the + y bound by the haskell + pattern quasiquoter, not the top-level + y = 7. + +y :: Int +y = 7 + +f :: Int -> Int -> Int +f n = \ [haskell|y|] -> y+n + + + + + + Top-level declaration splices break up a source file into + delcaration groups. A + declaration group is the group of + declarations created by a top-level declaration splice, plus + those following it, down to but not including the next + top-level declaration splice. The first declaration group in a + module includes all top-level definitions down to but not + including the first top-level declaration splice. + + + + Each declaration group is mutually recursive only within + the group. Declaration groups can refer to definitions within + previous groups, but not later ones. + + + + Accordingly, the type environment seen by + reify includes all the top-level + declarations up to the end of the immediately preceding + declaration group, but no more. + + + + Concretely, consider the following code + +module M where + import ... + f x = x + $(th1 4) + h y = k y y $(blah1) + $(th2 10) + w z = $(blah2) + + + In this example + + + + The body of h would be unable to refer + to the function w. + + + + A reify inside the splice $(th1 + ..) would see the definition of + f. + + + + + A reify inside the splice + $(blah1) would see the definition of + f, but would not see the definition of + h. + + + + + A reify inside the splice + $(th2..) would see the definition of + f, all the bindings created by + $(th1..), and the definition of + h. + + + + + A reify inside the splice + $(blah2) would see the same definitions + as the splice $(th2...). + + + + + + + + +(Compared to the original paper, there are many differences of detail. +The syntax for a declaration splice uses "$" not "splice". +The type of the enclosed expression must be Q [Dec], not [Q Dec]. +Typed expression splices and quotations are supported.) + + + + Using Template Haskell + + + + The data types and monadic constructor functions for Template Haskell are in the library + Language.Haskell.THSyntax. + + + + You can only run a function at compile time if it is imported from another module. That is, + you can't define a function in a module, and call it from within a splice in the same module. + (It would make sense to do so, but it's hard to implement.) + + + + You can only run a function at compile time if it is imported + from another module that is not part of a mutually-recursive group of modules + that includes the module currently being compiled. Furthermore, all of the modules of + the mutually-recursive group must be reachable by non-SOURCE imports from the module where the + splice is to be run. + + For example, when compiling module A, + you can only run Template Haskell functions imported from B if B does not import A (directly or indirectly). + The reason should be clear: to run B we must compile and run A, but we are currently type-checking A. + + + + If you are building GHC from source, you need at least a stage-2 bootstrap compiler to + run Template Haskell. A stage-1 compiler will reject the TH constructs. Reason: TH + compiles and runs a program, and then looks at the result. So it's important that + the program it compiles produces results whose representations are identical to + those of the compiler itself. + + + + Template Haskell works in any mode (--make, --interactive, + or file-at-a-time). There used to be a restriction to the former two, but that restriction + has been lifted. + + + + Viewing Template Haskell generated code + + The flag -ddump-splices shows the expansion of all top-level declaration splices, both typed and untyped, as they happen. + As with all dump flags, the default is for this output to be sent to stdout. + For a non-trivial program, you may be interested in combining this with the -ddump-to-file flag (see . + For each file using Template Haskell, this will show the output in a .dump-splices file. + + + + The flag -dth-dec-file shows the expansions of all top-level TH declaration splices, both typed and untyped, in the file M.th.hs where M is the name of the module being compiled. + Note that other types of splices (expressions, types, and patterns) are not shown. + Application developers can check this into their repository so that they can grep for identifiers that were defined in Template Haskell. + This is similar to using with but it always generates a file instead of being coupled to . The format is also different: it does not show code from the original file, instead it only shows generated code and has a comment for the splice location of the original file. + + + + Below is a sample output of -ddump-splices + + + +TH_pragma.hs:(6,4)-(8,26): Splicing declarations + [d| foo :: Int -> Int + foo x = x + 1 |] +======> + foo :: Int -> Int + foo x = (x + 1) + + + + Below is the output of the same sample using -dth-dec-file + + + +-- TH_pragma.hs:(6,4)-(8,26): Splicing declarations +foo :: Int -> Int +foo x = (x + 1) + + + + A Template Haskell Worked Example +To help you get over the confidence barrier, try out this skeletal worked example. + First cut and paste the two modules below into "Main.hs" and "Printf.hs": + + + +{- Main.hs -} +module Main where + +-- Import our template "pr" +import Printf ( pr ) + +-- The splice operator $ takes the Haskell source code +-- generated at compile time by "pr" and splices it into +-- the argument of "putStrLn". +main = putStrLn ( $(pr "Hello") ) + + +{- Printf.hs -} +module Printf where + +-- Skeletal printf from the paper. +-- It needs to be in a separate module to the one where +-- you intend to use it. + +-- Import some Template Haskell syntax +import Language.Haskell.TH + +-- Describe a format string +data Format = D | S | L String + +-- Parse a format string. This is left largely to you +-- as we are here interested in building our first ever +-- Template Haskell program and not in building printf. +parse :: String -> [Format] +parse s = [ L s ] + +-- Generate Haskell source code from a parsed representation +-- of the format string. This code will be spliced into +-- the module which calls "pr", at compile time. +gen :: [Format] -> Q Exp +gen [D] = [| \n -> show n |] +gen [S] = [| \s -> s |] +gen [L s] = stringE s + +-- Here we generate the Haskell code for the splice +-- from an input format string. +pr :: String -> Q Exp +pr s = gen (parse s) + + +Now run the compiler (here we are a Cygwin prompt on Windows): + + +$ ghc --make -XTemplateHaskell main.hs -o main.exe + + +Run "main.exe" and here is your output: + + +$ ./main +Hello + + + + + +Using Template Haskell with Profiling +profilingwith Template Haskell + +Template Haskell relies on GHC's built-in bytecode compiler and +interpreter to run the splice expressions. The bytecode interpreter +runs the compiled expression on top of the same runtime on which GHC +itself is running; this means that the compiled code referred to by +the interpreted expression must be compatible with this runtime, and +in particular this means that object code that is compiled for +profiling cannot be loaded and used by a splice +expression, because profiled object code is only compatible with the +profiling version of the runtime. + +This causes difficulties if you have a multi-module program +containing Template Haskell code and you need to compile it for +profiling, because GHC cannot load the profiled object code and use it +when executing the splices. Fortunately GHC provides a workaround. +The basic idea is to compile the program twice: + + + + Compile the program or library first the normal way, without + . + + + Then compile it again with , and + additionally use + to name the object files differently (you can choose any suffix + that isn't the normal object suffix here). GHC will automatically + load the object files built in the first step when executing splice + expressions. If you omit the flag when + building with and Template Haskell is used, + GHC will emit an error message. + + + + + Template Haskell Quasi-quotation +Quasi-quotation allows patterns and expressions to be written using +programmer-defined concrete syntax; the motivation behind the extension and +several examples are documented in +"Why It's +Nice to be Quoted: Quasiquoting for Haskell" (Proc Haskell Workshop +2007). The example below shows how to write a quasiquoter for a simple +expression language. + +Here are the salient features + + +A quasi-quote has the form +[quoter| string |]. + + +The quoter must be the name of an imported quoter, +either qualified or unqualified; it cannot be an arbitrary expression. + + +The quoter cannot be "e", +"t", "d", or "p", since +those overlap with Template Haskell quotations. + + +There must be no spaces in the token +[quoter|. + + +The quoted string +can be arbitrary, and may contain newlines. + + +The quoted string +finishes at the first occurrence of the two-character sequence "|]". +Absolutely no escaping is performed. If you want to embed that character +sequence in the string, you must invent your own escape convention (such +as, say, using the string "|~]" instead), and make your +quoter function interpret "|~]" as "|]". +One way to implement this is to compose your quoter with a pre-processing pass to +perform your escape conversion. See the + +discussion in Trac for details. + + + + + +A quasiquote may appear in place of + +An expression +A pattern +A type +A top-level declaration + +(Only the first two are described in the paper.) + + + +A quoter is a value of type Language.Haskell.TH.Quote.QuasiQuoter, +which is defined thus: + +data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp, + quotePat :: String -> Q Pat, + quoteType :: String -> Q Type, + quoteDec :: String -> Q [Dec] } + +That is, a quoter is a tuple of four parsers, one for each of the contexts +in which a quasi-quote can occur. + + +A quasi-quote is expanded by applying the appropriate parser to the string +enclosed by the Oxford brackets. The context of the quasi-quote (expression, pattern, +type, declaration) determines which of the parsers is called. + + + + +The example below shows quasi-quotation in action. The quoter expr +is bound to a value of type QuasiQuoter defined in module Expr. +The example makes use of an antiquoted +variable n, indicated by the syntax 'int:n +(this syntax for anti-quotation was defined by the parser's +author, not by GHC). This binds n to the +integer value argument of the constructor IntExpr when +pattern matching. Please see the referenced paper for further details regarding +anti-quotation as well as the description of a technique that uses SYB to +leverage a single parser of type String -> a to generate both +an expression parser that returns a value of type Q Exp and a +pattern parser that returns a value of type Q Pat. + + + +Quasiquoters must obey the same stage restrictions as Template Haskell, e.g., in +the example, expr cannot be defined +in Main.hs where it is used, but must be imported. + + + +{- ------------- file Main.hs --------------- -} +module Main where + +import Expr + +main :: IO () +main = do { print $ eval [expr|1 + 2|] + ; case IntExpr 1 of + { [expr|'int:n|] -> print n + ; _ -> return () + } + } + + +{- ------------- file Expr.hs --------------- -} +module Expr where + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote + +data Expr = IntExpr Integer + | AntiIntExpr String + | BinopExpr BinOp Expr Expr + | AntiExpr String + deriving(Show, Typeable, Data) + +data BinOp = AddOp + | SubOp + | MulOp + | DivOp + deriving(Show, Typeable, Data) + +eval :: Expr -> Integer +eval (IntExpr n) = n +eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) + where + opToFun AddOp = (+) + opToFun SubOp = (-) + opToFun MulOp = (*) + opToFun DivOp = div + +expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat } + +-- Parse an Expr, returning its representation as +-- either a Q Exp or a Q Pat. See the referenced paper +-- for how to use SYB to do this by writing a single +-- parser of type String -> Expr instead of two +-- separate parsers. + +parseExprExp :: String -> Q Exp +parseExprExp ... + +parseExprPat :: String -> Q Pat +parseExprPat ... + + +Now run the compiler: + +$ ghc --make -XQuasiQuotes Main.hs -o main + + + +Run "main" and here is your output: + +$ ./main +3 +1 + + + + + + + + + +Arrow notation + + +Arrows are a generalization of monads introduced by John Hughes. +For more details, see + + + + +“Generalising Monads to Arrows”, +John Hughes, in Science of Computer Programming 37, +pp67–111, May 2000. +The paper that introduced arrows: a friendly introduction, motivated with +programming examples. + + + + + +“A New Notation for Arrows”, +Ross Paterson, in ICFP, Sep 2001. +Introduced the notation described here. + + + + + +“Arrows and Computation”, +Ross Paterson, in The Fun of Programming, +Palgrave, 2003. + + + + + +“Programming with Arrows”, +John Hughes, in 5th International Summer School on +Advanced Functional Programming, +Lecture Notes in Computer Science vol. 3622, +Springer, 2004. +This paper includes another introduction to the notation, +with practical examples. + + + + + +“Type and Translation Rules for Arrow Notation in GHC”, +Ross Paterson and Simon Peyton Jones, September 16, 2004. +A terse enumeration of the formal rules used +(extracted from comments in the source code). + + + + + +The arrows web page at +http://www.haskell.org/arrows/. + + + + +With the flag, GHC supports the arrow +notation described in the second of these papers, +translating it using combinators from the +Control.Arrow +module. +What follows is a brief introduction to the notation; +it won't make much sense unless you've read Hughes's paper. + + +The extension adds a new kind of expression for defining arrows: + +exp10 ::= ... + | proc apat -> cmd + +where proc is a new keyword. +The variables of the pattern are bound in the body of the +proc-expression, +which is a new sort of thing called a command. +The syntax of commands is as follows: + +cmd ::= exp10 -< exp + | exp10 -<< exp + | cmd0 + +with cmd0 up to +cmd9 defined using +infix operators as for expressions, and + +cmd10 ::= \ apat ... apat -> cmd + | let decls in cmd + | if exp then cmd else cmd + | case exp of { calts } + | do { cstmt ; ... cstmt ; cmd } + | fcmd + +fcmd ::= fcmd aexp + | ( cmd ) + | (| aexp cmd ... cmd |) + +cstmt ::= let decls + | pat <- cmd + | rec { cstmt ; ... cstmt [;] } + | cmd + +where calts are like alts +except that the bodies are commands instead of expressions. + + + +Commands produce values, but (like monadic computations) +may yield more than one value, +or none, and may do other things as well. +For the most part, familiarity with monadic notation is a good guide to +using commands. +However the values of expressions, even monadic ones, +are determined by the values of the variables they contain; +this is not necessarily the case for commands. + + + +A simple example of the new notation is the expression + +proc x -> f -< x+1 + +We call this a procedure or +arrow abstraction. +As with a lambda expression, the variable x +is a new variable bound within the proc-expression. +It refers to the input to the arrow. +In the above example, -< is not an identifier but an +new reserved symbol used for building commands from an expression of arrow +type and an expression to be fed as input to that arrow. +(The weird look will make more sense later.) +It may be read as analogue of application for arrows. +The above example is equivalent to the Haskell expression + +arr (\ x -> x+1) >>> f + +That would make no sense if the expression to the left of +-< involves the bound variable x. +More generally, the expression to the left of -< +may not involve any local variable, +i.e. a variable bound in the current arrow abstraction. +For such a situation there is a variant -<<, as in + +proc x -> f x -<< x+1 + +which is equivalent to + +arr (\ x -> (f x, x+1)) >>> app + +so in this case the arrow must belong to the ArrowApply +class. +Such an arrow is equivalent to a monad, so if you're using this form +you may find a monadic formulation more convenient. + + + +do-notation for commands + + +Another form of command is a form of do-notation. +For example, you can write + +proc x -> do + y <- f -< x+1 + g -< 2*y + let z = x+y + t <- h -< x*z + returnA -< t+z + +You can read this much like ordinary do-notation, +but with commands in place of monadic expressions. +The first line sends the value of x+1 as an input to +the arrow f, and matches its output against +y. +In the next line, the output is discarded. +The arrow returnA is defined in the +Control.Arrow +module as arr id. +The above example is treated as an abbreviation for + +arr (\ x -> (x, x)) >>> + first (arr (\ x -> x+1) >>> f) >>> + arr (\ (y, x) -> (y, (x, y))) >>> + first (arr (\ y -> 2*y) >>> g) >>> + arr snd >>> + arr (\ (x, y) -> let z = x+y in ((x, z), z)) >>> + first (arr (\ (x, z) -> x*z) >>> h) >>> + arr (\ (t, z) -> t+z) >>> + returnA + +Note that variables not used later in the composition are projected out. +After simplification using rewrite rules (see ) +defined in the +Control.Arrow +module, this reduces to + +arr (\ x -> (x+1, x)) >>> + first f >>> + arr (\ (y, x) -> (2*y, (x, y))) >>> + first g >>> + arr (\ (_, (x, y)) -> let z = x+y in (x*z, z)) >>> + first h >>> + arr (\ (t, z) -> t+z) + +which is what you might have written by hand. +With arrow notation, GHC keeps track of all those tuples of variables for you. + + + +Note that although the above translation suggests that +let-bound variables like z must be +monomorphic, the actual translation produces Core, +so polymorphic variables are allowed. + + + +It's also possible to have mutually recursive bindings, +using the new rec keyword, as in the following example: + +counter :: ArrowCircuit a => a Bool Int +counter = proc reset -> do + rec output <- returnA -< if reset then 0 else next + next <- delay 0 -< output+1 + returnA -< output + +The translation of such forms uses the loop combinator, +so the arrow concerned must belong to the ArrowLoop class. + + + + + +Conditional commands + + +In the previous example, we used a conditional expression to construct the +input for an arrow. +Sometimes we want to conditionally execute different commands, as in + +proc (x,y) -> + if f x y + then g -< x+1 + else h -< y+2 + +which is translated to + +arr (\ (x,y) -> if f x y then Left x else Right y) >>> + (arr (\x -> x+1) >>> g) ||| (arr (\y -> y+2) >>> h) + +Since the translation uses |||, +the arrow concerned must belong to the ArrowChoice class. + + + +There are also case commands, like + +case input of + [] -> f -< () + [x] -> g -< x+1 + x1:x2:xs -> do + y <- h -< (x1, x2) + ys <- k -< xs + returnA -< y:ys + +The syntax is the same as for case expressions, +except that the bodies of the alternatives are commands rather than expressions. +The translation is similar to that of if commands. + + + + + +Defining your own control structures + + +As we're seen, arrow notation provides constructs, +modelled on those for expressions, +for sequencing, value recursion and conditionals. +But suitable combinators, +which you can define in ordinary Haskell, +may also be used to build new commands out of existing ones. +The basic idea is that a command defines an arrow from environments to values. +These environments assign values to the free local variables of the command. +Thus combinators that produce arrows from arrows +may also be used to build commands from commands. +For example, the ArrowPlus class includes a combinator + +ArrowPlus a => (<+>) :: a b c -> a b c -> a b c + +so we can use it to build commands: + +expr' = proc x -> do + returnA -< x + <+> do + symbol Plus -< () + y <- term -< () + expr' -< x + y + <+> do + symbol Minus -< () + y <- term -< () + expr' -< x - y + +(The do on the first line is needed to prevent the first +<+> ... from being interpreted as part of the +expression on the previous line.) +This is equivalent to + +expr' = (proc x -> returnA -< x) + <+> (proc x -> do + symbol Plus -< () + y <- term -< () + expr' -< x + y) + <+> (proc x -> do + symbol Minus -< () + y <- term -< () + expr' -< x - y) + +We are actually using <+> here with the more specific type + +ArrowPlus a => (<+>) :: a (e,()) c -> a (e,()) c -> a (e,()) c + +It is essential that this operator be polymorphic in e +(representing the environment input to the command +and thence to its subcommands) +and satisfy the corresponding naturality property + +arr (first k) >>> (f <+> g) = (arr (first k) >>> f) <+> (arr (first k) >>> g) + +at least for strict k. +(This should be automatic if you're not using seq.) +This ensures that environments seen by the subcommands are environments +of the whole command, +and also allows the translation to safely trim these environments. +(The second component of the input pairs can contain unnamed input values, +as described in the next section.) +The operator must also not use any variable defined within the current +arrow abstraction. + + + +We could define our own operator + +untilA :: ArrowChoice a => a (e,s) () -> a (e,s) Bool -> a (e,s) () +untilA body cond = proc x -> + b <- cond -< x + if b then returnA -< () + else do + body -< x + untilA body cond -< x + +and use it in the same way. +Of course this infix syntax only makes sense for binary operators; +there is also a more general syntax involving special brackets: + +proc x -> do + y <- f -< x+1 + (|untilA (increment -< x+y) (within 0.5 -< x)|) + + + + + + +Primitive constructs + + +Some operators will need to pass additional inputs to their subcommands. +For example, in an arrow type supporting exceptions, +the operator that attaches an exception handler will wish to pass the +exception that occurred to the handler. +Such an operator might have a type + +handleA :: ... => a (e,s) c -> a (e,(Ex,s)) c -> a (e,s) c + +where Ex is the type of exceptions handled. +You could then use this with arrow notation by writing a command + +body `handleA` \ ex -> handler + +so that if an exception is raised in the command body, +the variable ex is bound to the value of the exception +and the command handler, +which typically refers to ex, is entered. +Though the syntax here looks like a functional lambda, +we are talking about commands, and something different is going on. +The input to the arrow represented by a command consists of values for +the free local variables in the command, plus a stack of anonymous values. +In all the prior examples, we made no assumptions about this stack. +In the second argument to handleA, +the value of the exception has been added to the stack input to the handler. +The command form of lambda merely gives this value a name. + + + +More concretely, +the input to a command consists of a pair of an environment and a stack. +Each value on the stack is paired with the remainder of the stack, +with an empty stack being (). +So operators like handleA that pass +extra inputs to their subcommands can be designed for use with the notation +by placing the values on the stack paired with the environment in this way. +More precisely, the type of each argument of the operator (and its result) +should have the form + +a (e, (t1, ... (tn, ())...)) t + +where e is a polymorphic variable +(representing the environment) +and ti are the types of the values on the stack, +with t1 being the top. +The polymorphic variable e must not occur in +a, ti or +t. +However the arrows involved need not be the same. +Here are some more examples of suitable operators: + +bracketA :: ... => a (e,s) b -> a (e,(b,s)) c -> a (e,(c,s)) d -> a (e,s) d +runReader :: ... => a (e,s) c -> a' (e,(State,s)) c +runState :: ... => a (e,s) c -> a' (e,(State,s)) (c,State) + +We can supply the extra input required by commands built with the last two +by applying them to ordinary expressions, as in + +proc x -> do + s <- ... + (|runReader (do { ... })|) s + +which adds s to the stack of inputs to the command +built using runReader. + + + +The command versions of lambda abstraction and application are analogous to +the expression versions. +In particular, the beta and eta rules describe equivalences of commands. +These three features (operators, lambda abstraction and application) +are the core of the notation; everything else can be built using them, +though the results would be somewhat clumsy. +For example, we could simulate do-notation by defining + +bind :: Arrow a => a (e,s) b -> a (e,(b,s)) c -> a (e,s) c +u `bind` f = returnA &&& u >>> f + +bind_ :: Arrow a => a (e,s) b -> a (e,s) c -> a (e,s) c +u `bind_` f = u `bind` (arr fst >>> f) + +We could simulate if by defining + +cond :: ArrowChoice a => a (e,s) b -> a (e,s) b -> a (e,(Bool,s)) b +cond f g = arr (\ (e,(b,s)) -> if b then Left (e,s) else Right (e,s)) >>> f ||| g + + + + + + +Differences with the paper + + + + +Instead of a single form of arrow application (arrow tail) with two +translations, the implementation provides two forms +-< (first-order) +and -<< (higher-order). + + + + +User-defined operators are flagged with banana brackets instead of +a new form keyword. + + + + +In the paper and the previous implementation, +values on the stack were paired to the right of the environment +in a single argument, +but now the environment and stack are separate arguments. + + + + + + + + +Portability + + +Although only GHC implements arrow notation directly, +there is also a preprocessor +(available from the +arrows web page) +that translates arrow notation into Haskell 98 +for use with other Haskell systems. +You would still want to check arrow programs with GHC; +tracing type errors in the preprocessor output is not easy. +Modules intended for both GHC and the preprocessor must observe some +additional restrictions: + + + + +The module must import +Control.Arrow. + + + + + +The preprocessor cannot cope with other Haskell extensions. +These would have to go in separate modules. + + + + + +Because the preprocessor targets Haskell (rather than Core), +let-bound variables are monomorphic. + + + + + + + + + + + + + +Bang patterns +<indexterm><primary>Bang patterns</primary></indexterm> + +GHC supports an extension of pattern matching called bang +patterns, written !pat. +Bang patterns are under consideration for Haskell Prime. +The Haskell +prime feature description contains more discussion and examples +than the material below. + + +The key change is the addition of a new rule to the +semantics of pattern matching in the Haskell 98 report. +Add new bullet 10, saying: Matching the pattern !pat +against a value v behaves as follows: + +if v is bottom, the match diverges +otherwise, pat is matched against v + + + +Bang patterns are enabled by the flag . + + + +Informal description of bang patterns + + +The main idea is to add a single new production to the syntax of patterns: + + pat ::= !pat + +Matching an expression e against a pattern !p is done by first +evaluating e (to WHNF) and then matching the result against p. +Example: + +f1 !x = True + +This definition makes f1 is strict in x, +whereas without the bang it would be lazy. +Bang patterns can be nested of course: + +f2 (!x, y) = [x,y] + +Here, f2 is strict in x but not in +y. +A bang only really has an effect if it precedes a variable or wild-card pattern: + +f3 !(x,y) = [x,y] +f4 (x,y) = [x,y] + +Here, f3 and f4 are identical; +putting a bang before a pattern that +forces evaluation anyway does nothing. + + +There is one (apparent) exception to this general rule that a bang only +makes a difference when it precedes a variable or wild-card: a bang at the +top level of a let or where +binding makes the binding strict, regardless of the pattern. +(We say "apparent" exception because the Right Way to think of it is that the bang +at the top of a binding is not part of the pattern; rather it +is part of the syntax of the binding, +creating a "bang-pattern binding".) +For example: + +let ![x,y] = e in b + +is a bang-pattern binding. Operationally, it behaves just like a case expression: + +case e of [x,y] -> b + +Like a case expression, a bang-pattern binding must be non-recursive, and +is monomorphic. + +However, nested bangs in a pattern binding behave uniformly with all other forms of +pattern matching. For example + +let (!x,[y]) = e in b + +is equivalent to this: + +let { t = case e of (x,[y]) -> x `seq` (x,y) + x = fst t + y = snd t } +in b + +The binding is lazy, but when either x or y is +evaluated by b the entire pattern is matched, including forcing the +evaluation of x. + + +Bang patterns work in case expressions too, of course: + +g5 x = let y = f x in body +g6 x = case f x of { y -> body } +g7 x = case f x of { !y -> body } + +The functions g5 and g6 mean exactly the same thing. +But g7 evaluates (f x), binds y to the +result, and then evaluates body. + + + + + +Syntax and semantics + + + +We add a single new production to the syntax of patterns: + + pat ::= !pat + +There is one problem with syntactic ambiguity. Consider: + +f !x = 3 + +Is this a definition of the infix function "(!)", +or of the "f" with a bang pattern? GHC resolves this +ambiguity in favour of the latter. If you want to define +(!) with bang-patterns enabled, you have to do so using +prefix notation: + +(!) f x = 3 + +The semantics of Haskell pattern matching is described in +Section 3.17.2 of the Haskell Report. To this description add +one extra item 10, saying: +Matching +the pattern !pat against a value v behaves as follows: +if v is bottom, the match diverges + otherwise, pat is matched against + v + + +Similarly, in Figure 4 of +Section 3.17.3, add a new case (t): + +case v of { !pat -> e; _ -> e' } + = v `seq` case v of { pat -> e; _ -> e' } + + +That leaves let expressions, whose translation is given in +Section +3.12 +of the Haskell Report. +In the translation box, first apply +the following transformation: for each pattern pi that is of +form !qi = ei, transform it to (xi,!qi) = ((),ei), and replace e0 +by (xi `seq` e0). Then, when none of the left-hand-side patterns +have a bang at the top, apply the rules in the existing box. + +The effect of the let rule is to force complete matching of the pattern +qi before evaluation of the body is begun. The bang is +retained in the translated form in case qi is a variable, +thus: + + let !y = f x in b + + + + +The let-binding can be recursive. However, it is much more common for +the let-binding to be non-recursive, in which case the following law holds: +(let !p = rhs in body) + is equivalent to +(case rhs of !p -> body) + + +A pattern with a bang at the outermost level is not allowed at the top level of +a module. + + + + + + + +Assertions +<indexterm><primary>Assertions</primary></indexterm> + + + +If you want to make use of assertions in your standard Haskell code, you +could define a function like the following: + + + + + +assert :: Bool -> a -> a +assert False x = error "assertion failed!" +assert _ x = x + + + + + +which works, but gives you back a less than useful error message -- +an assertion failed, but which and where? + + + +One way out is to define an extended assert function which also +takes a descriptive string to include in the error message and +perhaps combine this with the use of a pre-processor which inserts +the source location where assert was used. + + + +Ghc offers a helping hand here, doing all of this for you. For every +use of assert in the user's source: + + + + + +kelvinToC :: Double -> Double +kelvinToC k = assert (k >= 0.0) (k+273.15) + + + + + +Ghc will rewrite this to also include the source location where the +assertion was made, + + + + + +assert pred val ==> assertError "Main.hs|15" pred val + + + + + +The rewrite is only performed by the compiler when it spots +applications of Control.Exception.assert, so you +can still define and use your own versions of +assert, should you so wish. If not, import +Control.Exception to make use +assert in your code. + + + +GHC ignores assertions when optimisation is turned on with the + flag. That is, expressions of the form +assert pred e will be rewritten to +e. You can also disable assertions using the + + option + . The option allows +enabling assertions even when optimisation is turned on. + + + +Assertion failures can be caught, see the documentation for the +Control.Exception library for the details. + + + + + + + +Static pointers +<indexterm><primary>Static pointers</primary></indexterm> + + + +The language extension -XStaticPointers adds a new +syntactic form static e, +which stands for a reference to the closed expression +e. This reference is stable and portable, +in the sense that it remains valid across different processes on +possibly different machines. Thus, a process can create a reference +and send it to another process that can resolve it to +e. + + +With this extension turned on, static is no longer +a valid identifier. + + +Static pointers were first proposed in the paper +Towards Haskell in the cloud, Jeff Epstein, Andrew P. Black and Simon +Peyton-Jones, Proceedings of the 4th ACM Symposium on Haskell, pp. +118-129, ACM, 2011. + + + +Using static pointers + + +Each reference is given a key which can be used to locate it at runtime with +unsafeLookupStaticPtr +which uses a global and immutable table called the Static Pointer Table. +The compiler includes entries in this table for all static forms found in +the linked modules. The value can be obtained from the reference via +deRefStaticPtr + + + +The body e of a static +e expression must be a closed expression. That is, there can +be no free variables occurring in e, i.e. lambda- +or let-bound variables bound locally in the context of the expression. + + + +All of the following are permissible: + +inc :: Int -> Int +inc x = x + 1 + +ref1 = static 1 +ref2 = static inc +ref3 = static (inc 1) +ref4 = static ((\x -> x + 1) (1 :: Int)) +ref5 y = static (let x = 1 in x) + +While the following definitions are rejected: + +ref6 = let x = 1 in static x +ref7 y = static (let x = 1 in y) + + + + + +Static semantics of static pointers + + + +Informally, if we have a closed expression + +e :: forall a_1 ... a_n . t + +the static form is of type + +static e :: (Typeable a_1, ... , Typeable a_n) => StaticPtr t + +Furthermore, type t is constrained to have a +Typeable instance. + +The following are therefore illegal: + +static show -- No Typeable instance for (Show a => a -> String) +static Control.Monad.ST.runST -- No Typeable instance for ((forall s. ST s a) -> a) + + +That being said, with the appropriate use of wrapper datatypes, the +above limitations induce no loss of generality: + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StaticPointers #-} + +import Control.Monad.ST +import Data.Typeable +import GHC.StaticPtr + +data Dict c = c => Dict + deriving Typeable + +g1 :: Typeable a => StaticPtr (Dict (Show a) -> a -> String) +g1 = static (\Dict -> show) + +data Rank2Wrapper f = R2W (forall s. f s) + deriving Typeable +newtype Flip f a s = Flip { unFlip :: f s a } + deriving Typeable + +g2 :: Typeable a => StaticPtr (Rank2Wrapper (Flip ST a) -> a) +g2 = static (\(R2W f) -> runST (unFlip f)) + + + + + + + + + + + Pragmas + + pragma + + GHC supports several pragmas, or instructions to the + compiler placed in the source code. Pragmas don't normally affect + the meaning of the program, but they might affect the efficiency + of the generated code. + + Pragmas all take the form + +{-# word ... #-} + + where word indicates the type of + pragma, and is followed optionally by information specific to that + type of pragma. Case is ignored in + word. The various values for + word that GHC understands are described + in the following sections; any pragma encountered with an + unrecognised word is + ignored. The layout rule applies in pragmas, so the closing #-} + should start in a column to the right of the opening {-#. + + Certain pragmas are file-header pragmas: + + + A file-header + pragma must precede the module keyword in the file. + + + There can be as many file-header pragmas as you please, and they can be + preceded or followed by comments. + + + File-header pragmas are read once only, before + pre-processing the file (e.g. with cpp). + + + The file-header pragmas are: {-# LANGUAGE #-}, + {-# OPTIONS_GHC #-}, and + {-# INCLUDE #-}. + + + + + + LANGUAGE pragma + + LANGUAGEpragma + pragmaLANGUAGE + + The LANGUAGE pragma allows language extensions to be enabled + in a portable way. + It is the intention that all Haskell compilers support the + LANGUAGE pragma with the same syntax, although not + all extensions are supported by all compilers, of + course. The LANGUAGE pragma should be used instead + of OPTIONS_GHC, if possible. + + For example, to enable the FFI and preprocessing with CPP: + +{-# LANGUAGE ForeignFunctionInterface, CPP #-} + + LANGUAGE is a file-header pragma (see ). + + Every language extension can also be turned into a command-line flag + by prefixing it with "-X"; for example . + (Similarly, all "-X" flags can be written as LANGUAGE pragmas.) + + + A list of all supported language extensions can be obtained by invoking + ghc --supported-extensions (see ). + + Any extension from the Extension type defined in + Language.Haskell.Extension + may be used. GHC will report an error if any of the requested extensions are not supported. + + + + + OPTIONS_GHC pragma + OPTIONS_GHC + + pragmaOPTIONS_GHC + + + The OPTIONS_GHC pragma is used to specify + additional options that are given to the compiler when compiling + this source file. See for + details. + + Previous versions of GHC accepted OPTIONS rather + than OPTIONS_GHC, but that is now deprecated. + + + OPTIONS_GHC is a file-header pragma (see ). + + + INCLUDE pragma + + The INCLUDE used to be necessary for + specifying header files to be included when using the FFI and + compiling via C. It is no longer required for GHC, but is + accepted (and ignored) for compatibility with other + compilers. + + + + WARNING and DEPRECATED pragmas + WARNING + DEPRECATED + + The WARNING pragma allows you to attach an arbitrary warning + to a particular function, class, or type. + A DEPRECATED pragma lets you specify that + a particular function, class, or type is deprecated. + There are two ways of using these pragmas. + + + + You can work on an entire module thus: + + module Wibble {-# DEPRECATED "Use Wobble instead" #-} where + ... + + Or: + + module Wibble {-# WARNING "This is an unstable interface." #-} where + ... + + When you compile any module that import + Wibble, GHC will print the specified + message. + + + + You can attach a warning to a function, class, type, or data constructor, with the + following top-level declarations: + + {-# DEPRECATED f, C, T "Don't use these" #-} + {-# WARNING unsafePerformIO "This is unsafe; I hope you know what you're doing" #-} + + When you compile any module that imports and uses any + of the specified entities, GHC will print the specified + message. + You can only attach to entities declared at top level in the module + being compiled, and you can only use unqualified names in the list of + entities. A capitalised name, such as T + refers to either the type constructor T + or the data constructor T, or both if + both are in scope. If both are in scope, there is currently no way to + specify one without the other (c.f. fixities + ). + + + Warnings and deprecations are not reported for + (a) uses within the defining module, + (b) defining a method in a class instance, and + (c) uses in an export list. + The latter reduces spurious complaints within a library + in which one module gathers together and re-exports + the exports of several others. + + You can suppress the warnings with the flag + . + + + + MINIMAL pragma + MINIMAL + The MINIMAL pragma is used to specify the minimal complete definition of a class. I.e. specify which methods must be implemented by all instances. If an instance does not satisfy the minimal complete definition, then a warning is generated. + This can be useful when a class has methods with circular defaults. For example + + +class Eq a where + (==) :: a -> a -> Bool + (/=) :: a -> a -> Bool + x == y = not (x /= y) + x /= y = not (x == y) + {-# MINIMAL (==) | (/=) #-} + + Without the MINIMAL pragma no warning would be generated for an instance that implements neither method. + + The syntax for minimal complete definition is: + +mindef ::= name + | '(' mindef ')' + | mindef '|' mindef + | mindef ',' mindef + + A vertical bar denotes disjunction, i.e. one of the two sides is required. + A comma denotes conjunction, i.e. both sides are required. + Conjunction binds stronger than disjunction. + + If no MINIMAL pragma is given in the class declaration, it is just as if + a pragma {-# MINIMAL op1, op2, ..., opn #-} was given, where + the opi are the methods + (a) that lack a default method in the class declaration, and + (b) whose name that does not start with an underscore + (c.f. , ). + + This warning can be turned off with the flag . + + + + INLINE and NOINLINE pragmas + + These pragmas control the inlining of function + definitions. + + + INLINE pragma + INLINE + + + GHC (with , as always) tries to inline + (or “unfold”) functions/values that are + “small enough,” thus avoiding the call overhead + and possibly exposing other more-wonderful optimisations. + GHC has a set of heuristics, tuned over a long period of + time using many benchmarks, that decide when it is + beneficial to inline a function at its call site. The + heuristics are designed to inline functions when it appears + to be beneficial to do so, but without incurring excessive + code bloat. If a function looks too big, it won't be + inlined, and functions larger than a certain size will not + even have their definition exported in the interface file. + Some of the thresholds that govern these heuristic decisions + can be changed using flags, see . + + + + Normally GHC will do a reasonable job of deciding by itself + when it is a good idea to inline a function. However, + sometimes you might want to override the default behaviour. + For example, if you have a key function that is important to + inline because it leads to further optimisations, but GHC + judges it to be too big to inline. + + + The sledgehammer you can bring to bear is the + INLINEINLINE + pragma pragma, used thusly: + + +key_function :: Int -> String -> (Bool, Double) +{-# INLINE key_function #-} + + + The major effect of an INLINE pragma + is to declare a function's “cost” to be very low. + The normal unfolding machinery will then be very keen to + inline it. However, an INLINE pragma for a + function "f" has a number of other effects: + + +While GHC is keen to inline the function, it does not do so +blindly. For example, if you write + +map key_function xs + +there really isn't any point in inlining key_function to get + +map (\x -> body) xs + +In general, GHC only inlines the function if there is some reason (no matter +how slight) to suppose that it is useful to do so. + + + +Moreover, GHC will only inline the function if it is fully applied, +where "fully applied" +means applied to as many arguments as appear (syntactically) +on the LHS of the function +definition. For example: + +comp1 :: (b -> c) -> (a -> b) -> a -> c +{-# INLINE comp1 #-} +comp1 f g = \x -> f (g x) + +comp2 :: (b -> c) -> (a -> b) -> a -> c +{-# INLINE comp2 #-} +comp2 f g x = f (g x) + +The two functions comp1 and comp2 have the +same semantics, but comp1 will be inlined when applied +to two arguments, while comp2 requires +three. This might make a big difference if you say + +map (not `comp1` not) xs + +which will optimise better than the corresponding use of `comp2`. + + + +It is useful for GHC to optimise the definition of an +INLINE function f just like any other non-INLINE function, +in case the non-inlined version of f is +ultimately called. But we don't want to inline +the optimised version +of f; +a major reason for INLINE pragmas is to expose functions +in f's RHS that have +rewrite rules, and it's no good if those functions have been optimised +away. + + +So GHC guarantees to inline precisely the code that you wrote, no more +and no less. It does this by capturing a copy of the definition of the function to use +for inlining (we call this the "inline-RHS"), which it leaves untouched, +while optimising the ordinarily RHS as usual. For externally-visible functions +the inline-RHS (not the optimised RHS) is recorded in the interface file. + + +An INLINE function is not worker/wrappered by strictness analysis. +It's going to be inlined wholesale instead. + + + +GHC ensures that inlining cannot go on forever: every mutually-recursive +group is cut by one or more loop breakers that is never inlined +(see +Secrets of the GHC inliner, JFP 12(4) July 2002). +GHC tries not to select a function with an INLINE pragma as a loop breaker, but +when there is no choice even an INLINE function can be selected, in which case +the INLINE pragma is ignored. +For example, for a self-recursive function, the loop breaker can only be the function +itself, so an INLINE pragma is always ignored. + + Syntactically, an INLINE pragma for a + function can be put anywhere its type signature could be + put. + + INLINE pragmas are a particularly + good idea for the + then/return (or + bind/unit) functions in + a monad. For example, in GHC's own + UniqueSupply monad code, we have: + + +{-# INLINE thenUs #-} +{-# INLINE returnUs #-} + + + See also the NOINLINE () + and INLINABLE () + pragmas. + + + + + INLINABLE pragma + +An {-# INLINABLE f #-} pragma on a +function f has the following behaviour: + + +While INLINE says "please inline me", the INLINABLE +says "feel free to inline me; use your +discretion". In other words the choice is left to GHC, which uses the same +rules as for pragma-free functions. Unlike INLINE, that decision is made at +the call site, and +will therefore be affected by the inlining threshold, optimisation level etc. + + +Like INLINE, the INLINABLE pragma retains a +copy of the original RHS for +inlining purposes, and persists it in the interface file, regardless of +the size of the RHS. + + + +One way to use INLINABLE is in conjunction with +the special function inline (). +The call inline f tries very hard to inline f. +To make sure that f can be inlined, +it is a good idea to mark the definition +of f as INLINABLE, +so that GHC guarantees to expose an unfolding regardless of how big it is. +Moreover, by annotating f as INLINABLE, +you ensure that f's original RHS is inlined, rather than +whatever random optimised version of f GHC's optimiser +has produced. + + + +The INLINABLE pragma also works with SPECIALISE: +if you mark function f as INLINABLE, then +you can subsequently SPECIALISE in another module +(see ). + + +Unlike INLINE, it is OK to use +an INLINABLE pragma on a recursive function. +The principal reason do to so to allow later use of SPECIALISE + + + + + + + + NOINLINE pragma + + NOINLINE + NOTINLINE + + The NOINLINE pragma does exactly what + you'd expect: it stops the named function from being inlined + by the compiler. You shouldn't ever need to do this, unless + you're very cautious about code size. + + NOTINLINE is a synonym for + NOINLINE (NOINLINE is + specified by Haskell 98 as the standard way to disable + inlining, so it should be used if you want your code to be + portable). + + + + CONLIKE modifier + CONLIKE + An INLINE or NOINLINE pragma may have a CONLIKE modifier, + which affects matching in RULEs (only). See . + + + + + Phase control + + Sometimes you want to control exactly when in GHC's + pipeline the INLINE pragma is switched on. Inlining happens + only during runs of the simplifier. Each + run of the simplifier has a different phase + number; the phase number decreases towards zero. + If you use you'll see the + sequence of phase numbers for successive runs of the + simplifier. In an INLINE pragma you can optionally specify a + phase number, thus: + + + "INLINE[k] f" means: do not inline + f + until phase k, but from phase + k onwards be very keen to inline it. + + + "INLINE[~k] f" means: be very keen to inline + f + until phase k, but from phase + k onwards do not inline it. + + + "NOINLINE[k] f" means: do not inline + f + until phase k, but from phase + k onwards be willing to inline it (as if + there was no pragma). + + + "NOINLINE[~k] f" means: be willing to inline + f + until phase k, but from phase + k onwards do not inline it. + + +The same information is summarised here: + + -- Before phase 2 Phase 2 and later + {-# INLINE [2] f #-} -- No Yes + {-# INLINE [~2] f #-} -- Yes No + {-# NOINLINE [2] f #-} -- No Maybe + {-# NOINLINE [~2] f #-} -- Maybe No + + {-# INLINE f #-} -- Yes Yes + {-# NOINLINE f #-} -- No No + +By "Maybe" we mean that the usual heuristic inlining rules apply (if the +function body is small, or it is applied to interesting-looking arguments etc). +Another way to understand the semantics is this: + +For both INLINE and NOINLINE, the phase number says +when inlining is allowed at all. +The INLINE pragma has the additional effect of making the +function body look small, so that when inlining is allowed it is very likely to +happen. + + + +The same phase-numbering control is available for RULES + (). + + + + + + LINE pragma + + LINEpragma + pragmaLINE + This pragma is similar to C's #line + pragma, and is mainly for use in automatically generated Haskell + code. It lets you specify the line number and filename of the + original code; for example + +{-# LINE 42 "Foo.vhs" #-} + + if you'd generated the current file from something called + Foo.vhs and this line corresponds to line + 42 in the original. GHC will adjust its error messages to refer + to the line/file named in the LINE + pragma. + + LINE pragmas generated from Template Haskell set + the file and line position for the duration of the splice and are limited + to the splice. Note that because Template Haskell splices abstract syntax, + the file positions are not automatically advanced. + + + + RULES pragma + + The RULES pragma lets you specify rewrite rules. It is + described in . + + + + SPECIALIZE pragma + + SPECIALIZE pragma + pragma, SPECIALIZE + overloading, death to + + (UK spelling also accepted.) For key overloaded + functions, you can create extra versions (NB: more code space) + specialised to particular types. Thus, if you have an + overloaded function: + + + hammeredLookup :: Ord key => [(key, value)] -> key -> value + + + If it is heavily used on lists with + Widget keys, you could specialise it as + follows: + + + {-# SPECIALIZE hammeredLookup :: [(Widget, value)] -> Widget -> value #-} + + + + + A SPECIALIZE pragma for a function can + be put anywhere its type signature could be put. Moreover, you + can also SPECIALIZE an imported + function provided it was given an INLINABLE pragma at + its definition site (). + + + + A SPECIALIZE has the effect of generating + (a) a specialised version of the function and (b) a rewrite rule + (see ) that rewrites a call to + the un-specialised function into a call to the specialised one. + Moreover, given a SPECIALIZE pragma for a + function f, GHC will automatically create + specialisations for any type-class-overloaded functions called + by f, if they are in the same module as + the SPECIALIZE pragma, or if they are + INLINABLE; and so on, transitively. + + + + You can add phase control () + to the RULE generated by a SPECIALIZE pragma, + just as you can if you write a RULE directly. For example: + + {-# SPECIALIZE [0] hammeredLookup :: [(Widget, value)] -> Widget -> value #-} + + generates a specialisation rule that only fires in Phase 0 (the final phase). + If you do not specify any phase control in the SPECIALIZE pragma, + the phase control is inherited from the inline pragma (if any) of the function. + For example: + + foo :: Num a => a -> a + foo = ...blah... + {-# NOINLINE [0] foo #-} + {-# SPECIALIZE foo :: Int -> Int #-} + + The NOINLINE pragma tells GHC not to inline foo + until Phase 0; and this property is inherited by the specialisation RULE, which will + therefore only fire in Phase 0. + The main reason for using phase control on specialisations is so that you can + write optimisation RULES that fire early in the compilation pipeline, and only + then specialise the calls to the function. If specialisation is + done too early, the optimisation rules might fail to fire. + + + + + The type in a SPECIALIZE pragma can be any type that is less + polymorphic than the type of the original function. In concrete terms, + if the original function is f then the pragma + + {-# SPECIALIZE f :: <type> #-} + + is valid if and only if the definition + + f_spec :: <type> + f_spec = f + + is valid. Here are some examples (where we only give the type signature + for the original function, not its code): + + f :: Eq a => a -> b -> b + {-# SPECIALISE f :: Int -> b -> b #-} + + g :: (Eq a, Ix b) => a -> b -> b + {-# SPECIALISE g :: (Eq a) => a -> Int -> Int #-} + + h :: Eq a => a -> a -> a + {-# SPECIALISE h :: (Eq a) => [a] -> [a] -> [a] #-} + +The last of these examples will generate a +RULE with a somewhat-complex left-hand side (try it yourself), so it might not fire very +well. If you use this kind of specialisation, let us know how well it works. + + + + + + SPECIALIZE INLINE + +A SPECIALIZE pragma can optionally be followed with a +INLINE or NOINLINE pragma, optionally +followed by a phase, as described in . +The INLINE pragma affects the specialised version of the +function (only), and applies even if the function is recursive. The motivating +example is this: + +-- A GADT for arrays with type-indexed representation +data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + +(!:) :: Arr e -> Int -> e +{-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} +{-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} +(ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) +(ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +Here, (!:) is a recursive function that indexes arrays +of type Arr e. Consider a call to (!:) +at type (Int,Int). The second specialisation will fire, and +the specialised function will be inlined. It has two calls to +(!:), +both at type Int. Both these calls fire the first +specialisation, whose body is also inlined. The result is a type-based +unrolling of the indexing function. +You can add explicit phase control () +to SPECIALISE INLINE pragma, +just like on an INLINE pragma; if you do so, the same phase +is used for the rewrite rule and the INLINE control of the specialised function. + +Warning: you can make GHC diverge by using SPECIALISE INLINE +on an ordinarily-recursive function. + + +SPECIALIZE for imported functions + + +Generally, you can only give a SPECIALIZE pragma +for a function defined in the same module. +However if a function f is given an INLINABLE +pragma at its definition site, then it can subsequently be specialised by +importing modules (see ). +For example + +module Map( lookup, blah blah ) where + lookup :: Ord key => [(key,a)] -> key -> Maybe a + lookup = ... + {-# INLINABLE lookup #-} + +module Client where + import Map( lookup ) + + data T = T1 | T2 deriving( Eq, Ord ) + {-# SPECIALISE lookup :: [(T,a)] -> T -> Maybe a + +Here, lookup is declared INLINABLE, but +it cannot be specialised for type T at its definition site, +because that type does not exist yet. Instead a client module can define T +and then specialise lookup at that type. + + +Moreover, every module that imports Client (or imports a module +that imports Client, transitively) will "see", and make use of, +the specialised version of lookup. You don't need to put +a SPECIALIZE pragma in every module. + + +Moreover you often don't even need the SPECIALIZE pragma in the +first place. When compiling a module M, +GHC's optimiser (with -O) automatically considers each top-level +overloaded function declared in M, and specialises it +for the different types at which it is called in M. The optimiser +also considers each imported +INLINABLE overloaded function, and specialises it +for the different types at which it is called in M. +So in our example, it would be enough for lookup to +be called at type T: + +module Client where + import Map( lookup ) + + data T = T1 | T2 deriving( Eq, Ord ) + + findT1 :: [(T,a)] -> Maybe a + findT1 m = lookup m T1 -- A call of lookup at type T + +However, sometimes there are no such calls, in which case the +pragma can be useful. + + + +Obsolete SPECIALIZE syntax + + Note: In earlier versions of GHC, it was possible to provide your own + specialised function for a given type: + + +{-# SPECIALIZE hammeredLookup :: [(Int, value)] -> Int -> value = intLookup #-} + + + This feature has been removed, as it is now subsumed by the + RULES pragma (see ). + + + + + +SPECIALIZE instance pragma + + + +SPECIALIZE pragma +overloading, death to +Same idea, except for instance declarations. For example: + + +instance (Eq a) => Eq (Foo a) where { + {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-} + ... usual stuff ... + } + +The pragma must occur inside the where part +of the instance declaration. + + + + + + UNPACK pragma + + UNPACK + + The UNPACK indicates to the compiler + that it should unpack the contents of a constructor field into + the constructor itself, removing a level of indirection. For + example: + + +data T = T {-# UNPACK #-} !Float + {-# UNPACK #-} !Float + + + will create a constructor T containing + two unboxed floats. This may not always be an optimisation: if + the T constructor is scrutinised and the + floats passed to a non-strict function for example, they will + have to be reboxed (this is done automatically by the + compiler). + + Unpacking constructor fields should only be used in + conjunction with in fact, UNPACK + has no effect without , for technical + reasons + (see tick + 5252), in order to expose + unfoldings to the compiler so the reboxing can be removed as + often as possible. For example: + + +f :: T -> Float +f (T f1 f2) = f1 + f2 + + + The compiler will avoid reboxing f1 + and f2 by inlining + + on floats, but only when is on. + + Any single-constructor data is eligible for unpacking; for + example + + +data T = T {-# UNPACK #-} !(Int,Int) + + + will store the two Ints directly in the + T constructor, by flattening the pair. + Multi-level unpacking is also supported: + + +data T = T {-# UNPACK #-} !S +data S = S {-# UNPACK #-} !Int {-# UNPACK #-} !Int + + + will store two unboxed Int#s + directly in the T constructor. The + unpacker can see through newtypes, too. + + See also the flag, + which essentially has the effect of adding + {-# UNPACK #-} to every strict + constructor field. + + + + NOUNPACK pragma + + NOUNPACK + + The NOUNPACK pragma indicates to the compiler + that it should not unpack the contents of a constructor field. + Example: + + +data T = T {-# NOUNPACK #-} !(Int,Int) + + + Even with the flags + and , + the field of the constructor T is not + unpacked. + + + + + SOURCE pragma + + SOURCE + The {-# SOURCE #-} pragma is used only in import declarations, + to break a module loop. It is described in detail in . + + + + +OVERLAPPING, OVERLAPPABLE, OVERLAPS, and INCOHERENT pragmas + +The pragmas + OVERLAPPING, + OVERLAPPABLE, + OVERLAPS, + INCOHERENT are used to specify the overlap +behavior for individual instances, as described in Section +. The pragmas are written immediately +after the instance keyword, like this: + + +instance {-# OVERLAPPING #-} C t where ... + + + + + + + + +Rewrite rules + +<indexterm><primary>RULES pragma</primary></indexterm> +<indexterm><primary>pragma, RULES</primary></indexterm> +<indexterm><primary>rewrite rules</primary></indexterm> + + +The programmer can specify rewrite rules as part of the source program +(in a pragma). +Here is an example: + + + {-# RULES + "map/map" forall f g xs. map f (map g xs) = map (f.g) xs + #-} + + + +Use the debug flag to see what rules fired. +If you need more information, then shows you +each individual rule firing and also shows what the code looks like before and after the rewrite. + + + +Syntax + + +From a syntactic point of view: + + + + + + There may be zero or more rules in a RULES pragma, separated by semicolons (which + may be generated by the layout rule). + + + + + +The layout rule applies in a pragma. +Currently no new indentation level +is set, so if you put several rules in single RULES pragma and wish to use layout to separate them, +you must lay out the starting in the same column as the enclosing definitions. + + {-# RULES + "map/map" forall f g xs. map f (map g xs) = map (f.g) xs + "map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys + #-} + +Furthermore, the closing #-} +should start in a column to the right of the opening {-#. + + + + + + Each rule has a name, enclosed in double quotes. The name itself has +no significance at all. It is only used when reporting how many times the rule fired. + + + + + +A rule may optionally have a phase-control number (see ), +immediately after the name of the rule. Thus: + + {-# RULES + "map/map" [2] forall f g xs. map f (map g xs) = map (f.g) xs + #-} + +The "[2]" means that the rule is active in Phase 2 and subsequent phases. The inverse +notation "[~2]" is also accepted, meaning that the rule is active up to, but not including, +Phase 2. + + +Rules support the special phase-control notation "[~]", which means the rule is never active. +This feature supports plugins (see ), by making it possible +to define a RULE that is never run by GHC, but is nevertheless parsed, typechecked etc, so that +it is available to the plugin. + + + + + + + + Each variable mentioned in a rule must either be in scope (e.g. map), +or bound by the forall (e.g. f, g, xs). The variables bound by +the forall are called the pattern variables. They are separated +by spaces, just like in a type forall. + + + + + + A pattern variable may optionally have a type signature. +If the type of the pattern variable is polymorphic, it must have a type signature. +For example, here is the foldr/build rule: + + +"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . + foldr k z (build g) = g k z + + +Since g has a polymorphic type, it must have a type signature. + + + + + + +The left hand side of a rule must consist of a top-level variable applied +to arbitrary expressions. For example, this is not OK: + + +"wrong1" forall e1 e2. case True of { True -> e1; False -> e2 } = e1 +"wrong2" forall f. f True = True + + +In "wrong1", the LHS is not an application; in "wrong2", the LHS has a pattern variable +in the head. + + + + + + A rule does not need to be in the same module as (any of) the +variables it mentions, though of course they need to be in scope. + + + + + + All rules are implicitly exported from the module, and are therefore +in force in any module that imports the module that defined the rule, directly +or indirectly. (That is, if A imports B, which imports C, then C's rules are +in force when compiling A.) The situation is very similar to that for instance +declarations. + + + + + + +Inside a RULE "forall" is treated as a keyword, regardless of +any other flag settings. Furthermore, inside a RULE, the language extension + is automatically enabled; see +. + + + + + +Like other pragmas, RULE pragmas are always checked for scope errors, and +are typechecked. Typechecking means that the LHS and RHS of a rule are typechecked, +and must have the same type. However, rules are only enabled +if the flag is +on (see ). + + + + + + + + + +Semantics + + +From a semantic point of view: + + + + +Rules are enabled (that is, used during optimisation) +by the flag. +This flag is implied by , and may be switched +off (as usual) by . +(NB: enabling without +may not do what you expect, though, because without GHC +ignores all optimisation information in interface files; +see , .) +Note that is an optimisation flag, and +has no effect on parsing or typechecking. + + + + + + Rules are regarded as left-to-right rewrite rules. +When GHC finds an expression that is a substitution instance of the LHS +of a rule, it replaces the expression by the (appropriately-substituted) RHS. +By "a substitution instance" we mean that the LHS can be made equal to the +expression by substituting for the pattern variables. + + + + + + + GHC makes absolutely no attempt to verify that the LHS and RHS +of a rule have the same meaning. That is undecidable in general, and +infeasible in most interesting cases. The responsibility is entirely the programmer's! + + + + + + + GHC makes no attempt to make sure that the rules are confluent or +terminating. For example: + + + "loop" forall x y. f x y = f y x + + +This rule will cause the compiler to go into an infinite loop. + + + + + + + If more than one rule matches a call, GHC will choose one arbitrarily to apply. + + + + + + GHC currently uses a very simple, syntactic, matching algorithm +for matching a rule LHS with an expression. It seeks a substitution +which makes the LHS and expression syntactically equal modulo alpha +conversion. The pattern (rule), but not the expression, is eta-expanded if +necessary. (Eta-expanding the expression can lead to laziness bugs.) +But not beta conversion (that's called higher-order matching). + + + +Matching is carried out on GHC's intermediate language, which includes +type abstractions and applications. So a rule only matches if the +types match too. See below. + + + + + + GHC keeps trying to apply the rules as it optimises the program. +For example, consider: + + + let s = map f + t = map g + in + s (t xs) + + +The expression s (t xs) does not match the rule "map/map", but GHC +will substitute for s and t, giving an expression which does match. +If s or t was (a) used more than once, and (b) large or a redex, then it would +not be substituted, and the rule would not fire. + + + + + + + + + + +How rules interact with INLINE/NOINLINE pragmas + + +Ordinary inlining happens at the same time as rule rewriting, which may lead to unexpected +results. Consider this (artificial) example + +f x = x +g y = f y +h z = g True + +{-# RULES "f" f True = False #-} + +Since f's right-hand side is small, it is inlined into g, +to give + +g y = y + +Now g is inlined into h, but f's RULE has +no chance to fire. +If instead GHC had first inlined g into h then there +would have been a better chance that f's RULE might fire. + + +The way to get predictable behaviour is to use a NOINLINE +pragma, or an INLINE[phase] pragma, on f, to ensure +that it is not inlined until its RULEs have had a chance to fire. +The warning flag (see ) +warns about this situation. + + + + +How rules interact with CONLIKE pragmas + + +GHC is very cautious about duplicating work. For example, consider + +f k z xs = let xs = build g + in ...(foldr k z xs)...sum xs... +{-# RULES "foldr/build" forall k z g. foldr k z (build g) = g k z #-} + +Since xs is used twice, GHC does not fire the foldr/build rule. Rightly +so, because it might take a lot of work to compute xs, which would be +duplicated if the rule fired. + + +Sometimes, however, this approach is over-cautious, and we do want the +rule to fire, even though doing so would duplicate redex. There is no way that GHC can work out +when this is a good idea, so we provide the CONLIKE pragma to declare it, thus: + +{-# INLINE CONLIKE [1] f #-} +f x = blah + +CONLIKE is a modifier to an INLINE or NOINLINE pragma. It specifies that an application +of f to one argument (in general, the number of arguments to the left of the '=' sign) +should be considered cheap enough to duplicate, if such a duplication would make rule +fire. (The name "CONLIKE" is short for "constructor-like", because constructors certainly +have such a property.) +The CONLIKE pragma is a modifier to INLINE/NOINLINE because it really only makes sense to match +f on the LHS of a rule if you are sure that f is +not going to be inlined before the rule has a chance to fire. + + + + +List fusion + + +The RULES mechanism is used to implement fusion (deforestation) of common list functions. +If a "good consumer" consumes an intermediate list constructed by a "good producer", the +intermediate list should be eliminated entirely. + + + +The following are good producers: + + + + + + List comprehensions + + + + + + Enumerations of Int, Integer and Char (e.g. ['a'..'z']). + + + + + + Explicit lists (e.g. [True, False]) + + + + + + The cons constructor (e.g 3:4:[]) + + + + + + ++ + + + + + + map + + + + + +take, filter + + + + + + iterate, repeat + + + + + + zip, zipWith + + + + + + + + +The following are good consumers: + + + + + + List comprehensions + + + + + + array (on its second argument) + + + + + + ++ (on its first argument) + + + + + + foldr + + + + + + map + + + + + +take, filter + + + + + + concat + + + + + + unzip, unzip2, unzip3, unzip4 + + + + + + zip, zipWith (but on one argument only; if both are good producers, zip +will fuse with one but not the other) + + + + + + partition + + + + + + head + + + + + + and, or, any, all + + + + + + sequence_ + + + + + + msum + + + + + + + + +So, for example, the following should generate no intermediate lists: + + +array (1,10) [(i,i*i) | i <- map (+ 1) [0..9]] + + + + + +This list could readily be extended; if there are Prelude functions that you use +a lot which are not included, please tell us. + + + +If you want to write your own good consumers or producers, look at the +Prelude definitions of the above functions to see how to do so. + + + + + +Specialisation + + + +Rewrite rules can be used to get the same effect as a feature +present in earlier versions of GHC. +For example, suppose that: + + +genericLookup :: Ord a => Table a b -> a -> b +intLookup :: Table Int b -> Int -> b + + +where intLookup is an implementation of +genericLookup that works very fast for +keys of type Int. You might wish +to tell GHC to use intLookup instead of +genericLookup whenever the latter was called with +type Table Int b -> Int -> b. +It used to be possible to write + + +{-# SPECIALIZE genericLookup :: Table Int b -> Int -> b = intLookup #-} + + +This feature is no longer in GHC, but rewrite rules let you do the same thing: + + +{-# RULES "genericLookup/Int" genericLookup = intLookup #-} + + +This slightly odd-looking rule instructs GHC to replace +genericLookup by intLookup +whenever the types match. +What is more, this rule does not need to be in the same +file as genericLookup, unlike the +SPECIALIZE pragmas which currently do (so that they +have an original definition available to specialise). + + +It is Your Responsibility to make sure that +intLookup really behaves as a specialised version +of genericLookup!!! + +An example in which using RULES for +specialisation will Win Big: + + +toDouble :: Real a => a -> Double +toDouble = fromRational . toRational + +{-# RULES "toDouble/Int" toDouble = i2d #-} +i2d (I# i) = D# (int2Double# i) -- uses Glasgow prim-op directly + + +The i2d function is virtually one machine +instruction; the default conversion—via an intermediate +Rational—is obscenely expensive by +comparison. + + + + + +Controlling what's going on in rewrite rules + + + + + + + +Use to see the rules that are defined +in this module. +This includes rules generated by the specialisation pass, but excludes +rules imported from other modules. + + + + + + Use to see what rules are being fired. +If you add you get a more detailed listing. + + + + + + Use or +to see in great detail what rules are being fired. +If you add you get a still more detailed listing. + + + + + + The definition of (say) build in GHC/Base.lhs looks like this: + + + build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] + {-# INLINE build #-} + build g = g (:) [] + + +Notice the INLINE! That prevents (:) from being inlined when compiling +PrelBase, so that an importing module will “see” the (:), and can +match it on the LHS of a rule. INLINE prevents any inlining happening +in the RHS of the INLINE thing. I regret the delicacy of this. + + + + + + + In libraries/base/GHC/Base.lhs look at the rules for map to +see how to write rules that will do fusion and yet give an efficient +program even if fusion doesn't happen. More rules in GHC/List.lhs. + + + + + + + + + + + + +Special built-in functions +GHC has a few built-in functions with special behaviour. +In particular: + + +inline +allows control over inlining on a per-call-site basis. + + +lazy +restrains the strictness analyser. + + +oneShot +gives a hint to the compiler about how often a function is being called. + + + + + + + +Generic classes + + +GHC used to have an implementation of generic classes as defined in the paper +"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop, +Montreal Sept 2000, pp94-105. These have been removed and replaced by the more +general support for generic programming. + + + + + + +Generic programming + + +Using a combination of +(), + (), +and (), +you can easily do datatype-generic +programming using the GHC.Generics framework. This section +gives a very brief overview of how to do it. + + + +Generic programming support in GHC allows defining classes with methods that +do not need a user specification when instantiating: the method body is +automatically derived by GHC. This is similar to what happens for standard +classes such as Read and Show, for +instance, but now for user-defined classes. + + + +Deriving representations + + +The first thing we need is generic representations. The +GHC.Generics module defines a couple of primitive types +that are used to represent Haskell datatypes: + + +-- | Unit: used for constructors without arguments +data U1 p = U1 + +-- | Constants, additional parameters and recursion of kind * +newtype K1 i c p = K1 { unK1 :: c } + +-- | Meta-information (constructor names, etc.) +newtype M1 i c f p = M1 { unM1 :: f p } + +-- | Sums: encode choice between constructors +infixr 5 :+: +data (:+:) f g p = L1 (f p) | R1 (g p) + +-- | Products: encode multiple arguments to constructors +infixr 6 :*: +data (:*:) f g p = f p :*: g p + + + + +The Generic and Generic1 classes mediate +between user-defined datatypes and their internal representation as a +sum-of-products: + + +class Generic a where + -- Encode the representation of a user datatype + type Rep a :: * -> * + -- Convert from the datatype to its representation + from :: a -> (Rep a) x + -- Convert from the representation to the datatype + to :: (Rep a) x -> a + +class Generic1 f where + type Rep1 f :: * -> * + + from1 :: f a -> Rep1 f a + to1 :: Rep1 f a -> f a + + +Generic1 is used for functions that can only be defined over +type containers, such as map. +Instances of these classes can be derived by GHC with the + (), and are +necessary to be able to define generic instances automatically. + + + +For example, a user-defined datatype of trees data UserTree a = Node a +(UserTree a) (UserTree a) | Leaf gets the following representation: + + +instance Generic (UserTree a) where + -- Representation type + type Rep (UserTree a) = + M1 D D1UserTree ( + M1 C C1_0UserTree ( + M1 S NoSelector (K1 R a) + :*: M1 S NoSelector (K1 R (UserTree a)) + :*: M1 S NoSelector (K1 R (UserTree a))) + :+: M1 C C1_1UserTree U1) + + -- Conversion functions + from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r)))) + from Leaf = M1 (R1 (M1 U1)) + to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r + to (M1 (R1 (M1 U1))) = Leaf + +-- Meta-information +data D1UserTree +data C1_0UserTree +data C1_1UserTree + +instance Datatype D1UserTree where + datatypeName _ = "UserTree" + moduleName _ = "Main" + +instance Constructor C1_0UserTree where + conName _ = "Node" + +instance Constructor C1_1UserTree where + conName _ = "Leaf" + + +This representation is generated automatically if a +deriving Generic clause is attached to the datatype. +Standalone deriving can also be +used. + + + + + +Writing generic functions + + +A generic function is defined by creating a class and giving instances for +each of the representation types of GHC.Generics. As an +example we show generic serialization: + +data Bin = O | I + +class GSerialize f where + gput :: f a -> [Bin] + +instance GSerialize U1 where + gput U1 = [] + +instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where + gput (x :*: y) = gput x ++ gput y + +instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where + gput (L1 x) = O : gput x + gput (R1 x) = I : gput x + +instance (GSerialize a) => GSerialize (M1 i c a) where + gput (M1 x) = gput x + +instance (Serialize a) => GSerialize (K1 i a) where + gput (K1 x) = put x + + +Typically this class will not be exported, as it only makes sense to have +instances for the representation types. + + + + +Generic defaults + + +The only thing left to do now is to define a "front-end" class, which is +exposed to the user: + +class Serialize a where + put :: a -> [Bin] + + default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit] + put = gput . from + +Here we use a default signature +to specify that the user does not have to provide an implementation for +put, as long as there is a Generic +instance for the type to instantiate. For the UserTree type, +for instance, the user can just write: + + +instance (Serialize a) => Serialize (UserTree a) + + +The default method for put is then used, corresponding to the +generic implementation of serialization. + +If you are using , the same instance is +generated by simply attaching a deriving Serialize clause +to the UserTree datatype declaration. + +For more examples of generic functions please refer to the +generic-deriving +package on Hackage. + + + + +More information + + +For more details please refer to the +HaskellWiki +page or the original paper: + + + + + +Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. + + A generic deriving mechanism for Haskell. +Proceedings of the third ACM Haskell symposium on Haskell +(Haskell'2010), pp. 37-48, ACM, 2010. + + + + + + + + + +Roles +<indexterm><primary>roles</primary></indexterm> + + + +Using (), a programmer can take existing +instances of classes and "lift" these into instances of that class for a +newtype. However, this is not always safe. For example, consider the following: + + + + newtype Age = MkAge { unAge :: Int } + + type family Inspect x + type instance Inspect Age = Int + type instance Inspect Int = Bool + + class BadIdea a where + bad :: a -> Inspect a + + instance BadIdea Int where + bad = (> 0) + + deriving instance BadIdea Age -- not allowed! + + + +If the derived instance were allowed, what would the type of its method +bad be? It would seem to be Age -> Inspect +Age, which is equivalent to Age -> Int, according +to the type family Inspect. Yet, if we simply adapt the +implementation from the instance for Int, the implementation +for bad produces a Bool, and we have trouble. + + + +The way to identify such situations is to have roles assigned +to type variables of datatypes, classes, and type synonyms. + + +Roles as implemented in GHC are a from a simplified version of the work +described in Generative +type abstraction and type-level computation, published at POPL 2011. + + +Nominal, Representational, and Phantom + +The goal of the roles system is to track when two types have the same +underlying representation. In the example above, Age and +Int have the same representation. But, the corresponding +instances of BadIdea would not have +the same representation, because the types of the implementations of +bad would be different. + +Suppose we have two uses of a type constructor, each applied to the same +parameters except for one difference. (For example, T Age Bool +c and T Int Bool c for some type +T.) The role of a type parameter says what we need to +know about the two differing type arguments in order to know that the two +outer types have the same representation (in the example, what must be true +about Age and Int in order to show that +T Age Bool c has the same representation as +T Int Bool c). + +GHC supports three different roles for type parameters: nominal, +representational, and phantom. If a type parameter has a nominal role, then +the two types that differ must not actually differ at all: they must be +identical (after type family reduction). If a type parameter has a +representational role, then the two types must have the same representation. +(If T's first parameter's role is representational, then +T Age Bool c and T Int Bool c would have +the same representation, because Age and +Int have the same representation.) If a type parameter has +a phantom role, then we need no further information. + +Here are some examples: + + + data Simple a = MkSimple a -- a has role representational + + type family F + type instance F Int = Bool + type instance F Age = Char + + data Complex a = MkComplex (F a) -- a has role nominal + + data Phant a = MkPhant Bool -- a has role phantom + + +The type Simple has its parameter at role +representational, which is generally the most common case. Simple +Age would have the same representation as Simple +Int. The type Complex, on the other hand, has its +parameter at role nominal, because Simple Age and +Simple Int are not the same. Lastly, +Phant Age and Phant Bool have the same +representation, even though Age and Bool +are unrelated. + + + + +Role inference + + +What role should a given type parameter should have? GHC performs role +inference to determine the correct role for every parameter. It starts with a +few base facts: (->) has two representational parameters; +(~) has two nominal parameters; all type families' +parameters are nominal; and all GADT-like parameters are nominal. Then, these +facts are propagated to all places where these types are used. The default +role for datatypes and synonyms is phantom; the default role for classes is +nominal. Thus, for datatypes and synonyms, any parameters unused in the +right-hand side (or used only in other types in phantom positions) will be +phantom. Whenever a parameter is used in a representational position (that is, +used as a type argument to a constructor whose corresponding variable is at +role representational), we raise its role from phantom to representational. +Similarly, when a parameter is used in a nominal position, its role is +upgraded to nominal. We never downgrade a role from nominal to phantom or +representational, or from representational to phantom. In this way, we infer +the most-general role for each parameter. + + + +Classes have their roles default to nominal to promote coherence of class +instances. If a C Int were stored in a datatype, it would +be quite bad if that were somehow changed into a C Age +somewhere, especially if another C Age had been declared! + + +There is one particularly tricky case that should be explained: + + + data Tricky a b = MkTricky (a b) + + +What should Tricky's roles be? At first blush, it +would seem that both a and b should be +at role representational, since both are used in the right-hand side and +neither is involved in a type family. However, this would be wrong, as the +following example shows: + + + data Nom a = MkNom (F a) -- type family F from example above + + +Is Tricky Nom Age representationally equal to +Tricky Nom Int? No! The former stores a +Char and the latter stores a Bool. The +solution to this is to require all parameters to type variables to have role +nominal. Thus, GHC would infer role representational for a +but role nominal for b. + + + + +Role annotations +<indexterm><primary>-XRoleAnnotations</primary></indexterm> + + + +Sometimes the programmer wants to constrain the inference process. For +example, the base library contains the following definition: + + + + data Ptr a = Ptr Addr# + + + +The idea is that a should really be a representational +parameter, but role inference assigns it to phantom. This makes some level of +sense: a pointer to an Int really is representationally the +same as a pointer to a Bool. But, that's not at all how we +want to use Ptrs! So, we want to be able to say + + + type role Ptr representational + data Ptr a = Ptr Addr# + + + +The type role (enabled with +) declaration forces the parameter +a to be at role representational, not role phantom. GHC +then checks the user-supplied roles to make sure they don't break any +promises. It would be bad, for example, if the user could make +BadIdea's role be representational. + + +As another example, we can consider a type Set a that +represents a set of data, ordered according to a's +Ord instance. While it would generally be type-safe to +consider a to be at role representational, it is possible +that a newtype and its base type have +different orderings encoded in their respective +Ord instances. This would lead to misbehavior at runtime. +So, the author of the Set datatype would like its parameter +to be at role nominal. This would be done with a declaration + + + type role Set nominal + + +Role annotations can also be used should a programmer wish to write +a class with a representational (or phantom) role. However, as a class +with non-nominal roles can quickly lead to class instance incoherence, +it is necessary to also specify +to allow non-nominal roles for classes. + +The other place where role annotations may be necessary are in +hs-boot files (), where +the right-hand sides of definitions can be omitted. As usual, the +types/classes declared in an hs-boot file must match up +with the definitions in the hs file, including down to the +roles. The default role for datatypes +is representational in hs-boot files, +corresponding to the common use case. + + +Role annotations are allowed on data, newtype, and class declarations. A role +annotation declaration starts with type role and is +followed by one role listing for each parameter of the type. (This parameter +count includes parameters implicitly specified by a kind signature in a +GADT-style data or newtype declaration.) Each role listing is a role +(nominal, representational, or +phantom) or a _. Using a +_ says that GHC should infer that role. The role annotation +may go anywhere in the same module as the datatype or class definition +(much like a value-level type signature). +Here are some examples: + + + type role T1 _ phantom + data T1 a b = MkT1 a -- b is not used; annotation is fine but unnecessary + + type role T2 _ phantom + data T2 a b = MkT2 b -- ERROR: b is used and cannot be phantom + + type role T3 _ nominal + data T3 a b = MkT3 a -- OK: nominal is higher than necessary, but safe + + type role T4 nominal + data T4 a = MkT4 (a Int) -- OK, but nominal is higher than necessary + + type role C representational _ -- OK, with -XIncoherentInstances + class C a b where ... -- OK, b will get a nominal role + + type role X nominal + type X a = ... -- ERROR: role annotations not allowed for type synonyms + + + + + + + + diff --git a/docs/users_guide/gone_wrong.xml b/docs/users_guide/gone_wrong.xml new file mode 100644 index 00000000..bb5fcb0d --- /dev/null +++ b/docs/users_guide/gone_wrong.xml @@ -0,0 +1,212 @@ + + + What to do when something goes wrong + + problems + + If you still have a problem after consulting this section, + then you may have found a bug—please + report it! See for details on how to + report a bug and a list of things we'd like to know about your bug. + If in doubt, send a report—we love mail from irate users + :-! + + (, which describes Glasgow + Haskell's shortcomings vs. the Haskell language definition, may + also be of interest.) + + + When the compiler “does the wrong thing” + + compiler problems + problems with the compiler + + + + “Help! The compiler crashed (or `panic'd)!” + + These events are always bugs in + the GHC system—please report them. + + + + + “This is a terrible error message.” + + If you think that GHC could have produced a better + error message, please report it as a bug. + + + + + “What about this warning from the C + compiler?” + + For example: “…warning: `Foo' declared + `static' but never defined.” Unsightly, but shouldn't + be a problem. + + + + + Sensitivity to .hi interface files: + + GHC is very sensitive about interface files. For + example, if it picks up a non-standard + Prelude.hi file, pretty terrible things + will happen. If you turn on + -XNoImplicitPrelude + option, the compiler will almost + surely die, unless you know what you are doing. + + Furthermore, as sketched below, you may have big + problems running programs compiled using unstable + interfaces. + + + + + “I think GHC is producing incorrect code”: + + Unlikely :-) A useful be-more-paranoid option to give + to GHC is + -dcore-lint + option; this causes a + “lint” pass to check for errors (notably type + errors) after each Core-to-Core transformation pass. We run + with on all the time; it costs + about 5% in compile time. + + + + + “Why did I get a link error?” + + If the linker complains about not finding + _<something>_fast, + then something is inconsistent: you probably didn't compile + modules in the proper dependency order. + + + + + “Is this line number right?” + + On this score, GHC usually does pretty well, + especially if you “allow” it to be off by one or + two. In the case of an instance or class declaration, the + line number may only point you to the declaration, not to a + specific method. + + Please report line-number errors that you find + particularly unhelpful. + + + + + + + When your program “does the wrong thing” + + problems running your program + + (For advice about overly slow or memory-hungry Haskell + programs, please see ). + + + + + “Help! My program crashed!” + + (e.g., a `segmentation fault' or `core dumped') + segmentation + fault + + If your program has no foreign calls in it, and no + calls to known-unsafe functions (such as + unsafePerformIO) then a crash is always a + BUG in the GHC system, except in one case: If your program + is made of several modules, each module must have been + compiled after any modules on which it depends (unless you + use .hi-boot files, in which case these + must be correct with respect to the + module source). + + For example, if an interface is lying about the type + of an imported value then GHC may well generate duff code + for the importing module. This applies to pragmas + inside interfaces too! If the pragma is lying + (e.g., about the “arity” of a value), then duff + code may result. Furthermore, arities may change even if + types do not. + + In short, if you compile a module and its interface + changes, then all the modules that import that interface + must be re-compiled. + + A useful option to alert you when interfaces change is + -ddump-hi-diffs + option. It will run + diff on the changed interface file, + before and after, when applicable. + + If you are using make, GHC can + automatically generate the dependencies required in order to + make sure that every module is + up-to-date with respect to its imported interfaces. Please + see . + + If you are down to your + last-compile-before-a-bug-report, we would recommend that + you add a option (for extra + checking) to your compilation options. + + So, before you report a bug because of a core dump, + you should probably: + + +% rm *.o # scrub your object files +% make my_prog # re-make your program; use -ddump-hi-diffs to highlight changes; + # as mentioned above, use -dcore-lint to be more paranoid +% ./my_prog ... # retry... + + + Of course, if you have foreign calls in your program + then all bets are off, because you can trash the heap, the + stack, or whatever. + + + + + “My program entered an `absent' argument.” + + This is definitely caused by a bug in GHC. Please + report it (see ). + + + + + “What's with this `arithmetic (or `floating') + exception' ”? + + Int, Float, and + Double arithmetic is + unchecked. Overflows, underflows and + loss of precision are either silent or reported as an + exception by the operating system (depending on the + platform). Divide-by-zero may cause an + untrapped exception (please report it if it does). + + + + + + + + + diff --git a/docs/users_guide/images/Recip.png b/docs/users_guide/images/Recip.png new file mode 100644 index 0000000000000000000000000000000000000000..f85846faa0b12d596f00621ecb1903e8837b3c55 GIT binary patch literal 72701 zcmV)wK$O3UP)QqKE|)d#|w@ORUk@h|w4|_SjpDEzv|{kH!*v1q4BgNU;GT zz1Lk}``-KffvAaKi};PdXWuV;$qv)!?wPq~X3ilfih>?Jdi3b|G@<>kE1*Y@9zA;A zAH5LQqeqXPPZ&nse`#rHNl8f`x$Nf6n|pY8eAqk{(z5h?S@UKNbQxYJmL?P8G&-qKsWb$G@oq&>6s03c09v)OvP$-R+f`8`tEjBf zk}tMlNv)=`vO=ZSXmwhuKCPW++Y@Uiv03zIaY!9Sfg;JeJnI8VlA-{rMph+Ps-Kms z)5@x&BDPV8JD3W@IX|krOI5{Qx_Mos3OANHJ7eze7a9zE|%QwecWDNRX9 zk=8W2{Ar8>OGh*4^zYYg2y!=<7>bWvPNa15V?Ql-ZxuLUc>fN)Cp^e51yGn4H=>)r zm#e3_Er-qa%akesgdJZi78{LOeORp_0m!nGTDzGI`Fw)Et1*Lax_rkUwOU=}(|i7| zMqYgR!^}##x-d0%bgy>(hL33F;=Fw4pK^^3I{C?6Yi!KzyibDPe6`?;BU9KC+8PS6kpK_dtPZ`9t9SAXC7*{De=c@@utqy_0A0Ay0cUp;)B`4-Lk z_323G`b0k|c*}N~JNQhVGHp=T4!wqsoHA*&g^{ozJ;sktcl7e}^YU&P*z0aaF{!RT z_4`lzPhCBVjmVA zips7m$?Fy9{_xI~1;=wj!$J?8x;TG`+MHROpB5DzWY4Ti8$4oR z(c>6H>e=#1Waqtm=Y~q1;Alifd0|{-*p@S)4-6cAqhn%?iW1D*j;&P4ADmt)V#?Rf zpVf8Nj+>V*#i!gUxwP>@RNAAs8$Vu2jY@lxm0!4b$s!tb01PahR{VT)%bFk7Zk%#H z{Pt@kZ$pr&abbTR-IrPT;>}%FUL1b$#Fd!)>bJ;>tbZ$U^Y0ombJ(n9+aG15g#;T$ z-OHx2MV)&N3ToM`bN?YDMvUki*osYWcv4ZyW#uoZ(CBmoo$1lC{i+@N53HZGeeu}7 zGgeg8G$zM&@u4>Y`~yVXXIm+jj^1$xzU}+jh!q=mb4+c-0*3(cpST(I zASE&_Dzdy%E-QMvZTs&_4qPjL65Xeb*OvXe+B#dlb%+16-z;7H7Owwh>{rW^pQLY| z+TnWiV;X}S(5X+Cb}a*Y4Hz+E67Z@oQ+R!vZg#Ghc~NRTPBS#ar8fzaGfh;*Cizg8u60& zA_&^(p~Ial3<($x8#C%=PL7Uh0RpD&#*FFRfx}|h*>JU$naM>)vpY1W(+Iwy)u7>h zGRmsT8Cjis_ja(55Cn!yUD89PV-mRb$BtFU?vESQS6)%gWC-7}Rg5X?e;@d*!qUR@ zd611)yGx0=ETOTG^G*Xn&}f9Ct389kcJ}s4rzp@^wvJ9VW@0;g$7aoJUz76M-lhF# zZ+-sp{JrcxKDIUG1=la1+q8C9(AaOr3>|1FU^bkXRF+oOi1>o%Ge4bUa^ULis-nW& zr;k_8{(AksJmA_G5~Sy&dG2uf=Ogs=VOoue*LOR%q}{sY+^fBvqf90*;+Ho>g2~S(N$5p%Yf7 z=5&H0DQHRZdHxKMk&i{i_3%U;NmZBUoH%w;Vk|MXun#?dHM^*a)Tv^_E?tO-*HW6h zw{C_kTRv|1KxaD(Qui!5MUiCPzc*Z)(jD9Qovl}w$kgKJK_yR;hIICux#^%>{hF0{ zU2AkNWlw2IimKBrlO**_-A^#N>>62(POE;H5cBA1VS{<~n6g^-5tX*Yz@krY|qZ}ls5g27=`ORIG{ZN`Ip_a0_F@8fEPoWp5k zKGUP;KSNUqaiOKl;31zmTZ!F#Iu7g+^tK27bX60*T>DR2*RP!ejYhj1mkYqNeXr3i z8Q#rX1T^#LG-!6AOb(i0{^nn!_J&wkTbQ|bt(7<#u;|sfDSmEdCe7Mh|7|gk!|XVH zgHod-0874Ze6O|=i`M*hlZN#0NeMk+ZR~n>=RyIOwXKtyY6d1*LmwiG&+LE=hN%w9g5V} z)X3Rf9*fziE+X#wfn=HM7lYe^qF(<-K#{tdnp!%G!{e}?2db5Fl@Tsf1ACr5J0W8 zQb%VKI+c!Mio}8!Gc`r2R4O`?&1gh5{|->3La73&KJnwyD(7LdhPDInIO^o6m6uK* z+-7Gicw+`{1F6$$v?PngdOi+0_rt&X;pCoO8!g0*&J%j{{1^DoZEQ9MhbIsUUr2BO z1dSmSiC!bYW!Xv7zWjR9*lq^aoik<1#-i2dMi+`iFH3OLty=}Wm!&_4$LGDD1P4IS zn6K29&SZTk2@ZhHV6vM`f&(yjYB6nyM`+yBx{rLZp-8|JiVY161b=(iA_z8z^8q9{ zP+OKeeV{i_V0}4HG9cKiE>K`-zhTiFn-3(x0nq3SHkJHl_un7JT=-`F0ag8d zK}H=-DZw+6W6z&IfAL!6Ywl9M6QovMR9HokAJw{~s$5YVU#675#pRZN8~}Ptbk(cB z8nx@s*cTzB_R0N(8#h8T@=9NdRko$iqtN#$5dct}_2~Th^XD&KFRrYu3n|ZkuwdcJ+|oB(0j(%}wBXz2*(J3vs;1Rw zb)V3Uqj$TIrRRgtR6^X=&98I&Rt7>*3;!VBX0{(qj+f>>ip(f^%|77==W+D8xwEJD znYv4+dfhddk5A2$^2cX$s!JQ*;e46AKOY=zefiR`xa!IeGYGiOvsv5P8i&y7BKNgJ!ohtU$&7|~Pp^*`kwO)b!n%f#?KaQ`YJB0KS z*Il1f%SvuW#Ha|SR#sYGt83XVxMedtjjSXrGDb-=^lfGo84;~v84nuLTL5)TM0i?u zA;A{54eI16LJ;u*<$^^sC&6nl!?5d}>v?9!G}R7He^X6BWPOs#{1gG@v`P-OPw z#9Mdn>6jcbpTRb5-oc3<8j~!sarZQ*N5tKi*t&P{b*;=xkGT7gC$Y7YXe003lh}Cl z?%shfG9NbDf5z-3XO3>SZ2aJmo)1e?3GuRmEC68eEiH|u#c6NvdE#O8xheCum20$a zo<3!14<>CpY|Shk*s+^+&xwJ}1XKHeHEQkAl~a44+_d2H1>1&9o~g>dd**7?+1pQ> z+Zq<6#jjYrArl3%yHh7Ex|tl~XCVD$^NQ0q<4N#+ zeH@Y!D}3|rMebTMWA)Epd^IOK>iD=R7I*GlaO0GY=-oF?XEnZu@1p$&OnS^4*sVjt z%_HBgkNA4du(&h(_TS07y6qeOvr9T}XkKAP{G?IS%jD)mhBUu&?$XY4Nn^UVc<+Uu zBDX3!BuOKuTXq)|hgNELcXSVK;B+9**0AHwV6WuT)FY{X1>Lus;_5fmO<>r-h%+S| zfhC8|eO;kNPZO4Xzny$O53nuw{JzVhVIfY%T=^qH>ANAQ#Y+;F*5mVO&p%Yl$}{hm zjo#MD)ZC$Wm*B5XXVz9L#YQ}U)@}5ZH}*imlccfUZAyDhx%K-N8)IJM5oy80zIbD9 z0IlO^0f$$Hr=gFYiW915fM}uT3eR0ZOykg zv&<4ATU!_jK&sCl+&FO3y3a-q&V3jWlax7S@#Z$|TFJ|Ee_Z?Rji*NO5v?qZg``rp zd+p4{TQ2}Ox$pbnQIn7E-7V2o{j}oC@KV>W#s(e#X`|z3E8bp+SLCHGo--pQD_<bNe=d?aaB%z}|z%d2P=} zOq$Zi|1B$~=U>v4H#TYPfWQuXRL3NzzrA*2@T@iQ*RDLW9l3Age7;Tr4nOkb`q>YsNlm_*k|H~+B8P|N|)w*R!Bx!mCCp>;x4Xyrb4 z-qi37nFkN-wpZ|@Yzugl;O z-4025&ssDlVA`-j6(wa9-fV28F^t++Id#sU{9OEpn?}yPr6^T5mK#B*32jBDenvUh z%k!@0dyIB!P>8<`Vl&5KBZfcM2QWB75tr3)R8om5-_4O3drO23uQ4?>6_?H*>oalb-k%od#hq<8 z=*PNntLB}K96!{#)z@{8rMgBMb@SrrX-oF}G{5Y@^|oDCO#OTWpANoz(2+k5ck!83 z7mdad&sp{>Pp~+y+;#KvaU3?+fJ@WV0t8}j{&7-Fc?J*Z)c$QHH~^P+eK#&mpS>sS z@R9xAR(yq)sLhMry6w({oz0{-rX3EBf=%Qs03;a2PxDk-owTe3BI0>&cJ^-0b|y3io=>JUI!$P5 z@wBR12YfOI!ai}DN{D;;wXu{4OY(Ev{5lxYHGL=mWS;YD`mpTXa>J*T1_v-j@UuDVD2XyM{;M?QK zuJ1&q4r2!Nn>J^7PD)sA^q(=M_S=I4T-c61ytee{*>_^Uw%3jvG8{br>b7Yl6G`zg z=l{f+y~iGCxQ8zV4{K#Iea2TQsZT4?v%7Xr8$4m*!ij@fuROeQSB@XL6h?o{BdP)p zT)ZXD-O{U|QEVgBSwH7z5}p|g>J(La^!)oG;#>FN$Y2U+4--8>H^hu9Vc9C9(?Tt?7}@pSybwYCt7zoIW4-+sM*Wr3^lZFK5tUb4LjBoRm1b{Ub$0k)p_vP z;I93CSURxxfXd)z#)tMEn6mTSx@kS_Y+M)aT=!Y_`3o0r7`W=j_V%m3e{o94>YU1& zE^Y619Xfr@{84pJy+*CbzJK3x$d`Hv{?TZvbK*9R&7Qw?Dx_uUS^2NZ@P^Kb>*8`rB^($K`RU5EB&h60f4yHOGM({pGXelyQjex44LQW|yiHy} zM?}XxFVxhwnV*;Qs|(Pgrzv+IW>a*Yy_F~@r--C;+jj~yY(yQAlM*@QhYQDkS#Hpf zuHaGa{pAU>i&JG3ohdeF$?|I{I>Vxk8HfAcCpxI|q*7Vgvp(nB8k)EWHooSZ_*?M! z&bhw57w*4(xr2M7yM^jn>5XfbvWjGmo~?red|0oUW?n%fufBaNR41_R(AKvxdyS2e zpO$)kK^CZ>*e$DR3 z-6^c7sf)l7O4_y!;IoLzlKkA_DrITfXG1rhiaO!vWPC3!x}dy1n!qriU0VT*Ca)?A z54&BdP#as?2l)H(2zA(%^HmypjZDT88n^ElY-cJ0P@Eal-tDs=u3i|{sYQbo1E}28 zo;#e?N1m z-g4MS<3DMN_5)#R<+@_?VUnU~be@3u$%qn-PA98YQlIjr34+BRKYNwi-3QQ-de!Kw z@Wm!yt=X7gE@SfyeEr*4|2qi|z_Z(!lR-Mc|5SnlAW3b3Khz>c*zn z#3r~~&q0F*_3PEm#;nopay_p?yx-cDLgZE4OMMY=_X;=!*8PePxTMcW!0>M&t@&^{ z>d~X;-_cY;+}Om7O(`=nvS~cAr<>cqKUAmZA1LLJ$?(EYGKI5;a3ku4$hL2eew{%h zP%VZ0B^!a#IT0$&_PkUUCgI0mxcH(+8 z&K|+CWjJsaDjke0;B1BYU%jsHXp001BWNklS^l>mW#N;I?D!}C4pqpdqGPJORfeCKjM@c4Tj)hPRkpNS^L4GCV zWtiFrbTcen1|NGEnBZD+Q;m@xJs*uG)QO9&90UBlXaq{iOWyw4y`DFc9EC5ZR=S2pR!U0D&%}u;NRsnvaM`1UO^Q8pO*HlZ4t#%$fwZ z=9ttA)8^vAc*LaQ=i?|XhMNQO^3k?Cj_-k?0|pI7fe~7{fGfw*Uoq|b7gh$I#3MWx zN6$i}L24y<9ArJhoCz4W4FlWZ_*P6?f{0_VHu`51j4a(l=FEQn7D4BVEDRdh+{;bJ zoUs_b5hpt0)K8ec7~#j^5ricZv2q_a?7_J~AS5s_!nj#T7=`czY&nR^VmKJ!mkqd? ziz~OmuEhLl_{j>(rsMNjxH}SIaoG4fq{VPCZ?ZwsqvvDMghE`J`}ka0UfYgcY@D3$ zrswN)dO`kSD1HJN52FXd)(9iVVsmd)koasA;;zE1Gp3KPf4$NH6uNdno3`+B0Z3?S zkeY|6TbPsv78^V_Ftwnu;o%7hAK(9g0EcG@+xZ|b6;ZK}GzTitZV=2xAVlzM0r5+g zV%*xHzYj(Z0D#uLFmM1W^YNe>>sR3qF~EegHOPjR;)PG+M~@xW023}&phy^5p_wzr&BxR)Agq6Wn>B}t2=mvVOLG8FmLoqCy*eYf9T*C9 z?Tfs8sOf0t0TVGo)}ou&hZqSxdj116l@NFHX(J*O#pN;%llGBKWB;GW+!=;){C)xh z+TizJVcH5NJb(mAB0dpeVMx4<<~`8b5?KWhrQ>M^atl!P1PTV+t0+F}iQiLX+dk zju!2)Yd3a(ixw>rR)C{>U?~9@=-M5jzo1Jn&fSBt7*7*%`UZa9g)@KQ>~;LS2ia0g z`40Xf1hqnomN*dyb7K_eVo3;6Yw_g>jGBvzY5;Kbg&62N1|!=6u5dJgQi^TgCkeB!*%} zLwn!WuGn%AXEwpz4L!$zW(W=oSO3Hh`*H0!dUwH}S3m+4#aJ;1_oN6Jk6|-VR1O*o zlS0tT3B5a^>mc}#$BYT6F2#zuxLbvJU*NOpC}>CtuSd@(M-$%IWOD^PHbY)ptmy+03t^Y5EB_03WK6{-KCZhG{5OgsR`2LI5sLR?~MBN5PYvUAjWo%mZLHnr|* z`g#j+9p5+aBv4p04XpO4je<=-OlZV#DFB@YpyO}$x+$nNV7>FA_)x<}0vgPX#Nl0F zHp8$k?^;R&=ro{cXvF$=9jAa(AE2anhtz^3USGE+fWqbD$e?4!(2rCgsYPN83MwIx zAgJ9tZ^2O{G9KV@Ht0;W=>W;QSRH<2&dIUJt3b;DSTx`l>tmx*;L&}s&ERhPEF}6Y zdhEoxudw72ZtVncp)n!egx>B6mat7gYhOQqJIQMuf9d&{5HJ+O&Pk5ROFO@yb?(*!cJoHWNiEe?{VcXCjlpL1rcdLYNvuB}aY%s`HSY2~rLV zOK_L~g@^YLmjsG|R_)+ni`$W?tVUHOI07hZAhts1*0>joN);$2N~+-QivVAcD&*&* zx&YakpebQ)2`&qi26tlM*A3=Ybr+RTo{!t{U~wQVfrgFVy&(}mt3>oIJkEl|983}h z=4jgn%ztcLQYbA(c_m7<$jk(v4|7uxKy?|y!ci`R*bJRI!myE*okEJRo5(GPu?Z9! z^y~=<7mpHgHw7deo__Fg#oZVbmZL@rItMx>SQ2y(#KXHNsRf}yQ5l??qeC0i6d*DI z=8kX_AvzJ}PVo0cc_~WEQCf@4OmMldGzS5wYH=$J*#$5#M{qEV8gdz;QzJeKMb&8T ziN|+QSdH#|VP}l2G(_HknnH6wwDtlGP}d;*CNhg*WD1oMoqNDch{Ob#d&1cmBtQcy z@(_6!1QRu-P%#kL8BP|c$VFrV_(rfXKx7PzZPBY6bTWj6qNp4^2|5PDObk%SNkw=x zbW9isz%WMN4k*mTt!Pw8A&{V3cbFT3!9mDo*t+6C>}y?LQOJCV+wsr=j?K}o73e@= zHZI?Qxhp12frlfSJ2j9_CBxM)5De&QP^v)pUa&DnN-Q$V(5eke(~(nwR&7z0jkG+d zYM};LfRaG}{unn0bN3=K7DbO?VvT@SpaY}^kzq*70?z=Qy1-I`ni7OYgD!xFEy5ze zkzmk3G`PjCQ6Tar*8hN;_poL+NF_oeL95@SA_&;K!PcySgochtO~taVe_KphC1C@M8I^^XtAxoc5sQkRmLqSKKHq30Tm^Web)O3z0nk)rUAA8j?J z48g>?`0ZzS+Tg%7Xr%aJ@QWv8^mmY{5qIftkImKlpeWop0uv*AzZTzo38oQl+`)Gf z0TKH40}JTc3x<}6zlYg_0U)3=#tj94!`E@|`rmT9kO+!`PLA~pU@F1lEznY+D5S^0 z$p`=j4uUBk8xMoj;^1Zg82LH8-2hF+_coYU}VCfz_2!%BV-|vA|j^#67)UE4S6w9HIVc{6~cf+>r z=ox_C6H!*%K;2Z;SUU@KFScGj-~va(ksJyOKISaO%7x(aar7osHCQ?x93xDbiMHM_ z_QiuNkZK&*2zx7xnhgyFio%m<*mD73%tQow!J{Ld6eB$vEgS$qWB?Br1P;K{LQEeB zp&7oK0}nI!^+Ik1Qlnr7wCswnrU1Z~YeA~9YZ-bD#lgeq>4&-7>#I%T#7^`b5A`d} zdH$1d4FCfBV#;WMj!j2FkvO&IMK4WQ*>FN>9{lYApjUsm7-86V(5SI@0eCiuO2(cA z;929&1Dx0n(9wG!1VE==aA4tVB&xCifW<>_dw_urN1@YT>s;7+VcSj&?*aRE$gM)* zeYA1|0457Qp0IX9PR&27LF#b(9NIO5sT;N*KtTm43d&M+3P6Vr^*@0)cC*nQAa$70 z65Ic5Gy+9kXzW|vR4Z|JPfwasMzZ+?0UKBE(&~7rQg1=!zX-v?XQOd75;1omS3oTX zLxe5AK+FZF1?Efumj@ve-klM169b0g{4Lm-!N35d9DiMejUUVmKr!LYKtvn{kHqm3 zgv>)yGQOXO#h*hX#1}KLCm9ERhaDG8H6kL>X941GVZcC~3WK8s3=9E)#>F>3fK;KT zUWwz}3RA`*ON@>4v0)y{3Q${x$S}x4Pb!tTC&BDfCL8x%;3WiO?&s)J( z!gwk!Uq{GrSjFP&1xSm*qIuXh844yopN=1{V*ep{nZt-c_zjF&hpDrnrJ-2>rcQ$f zpmPzj53v z$wz5j^;p<{8pDIJDFnZ5!tg+>+JX*KAYh?oOB~;b#QW&m9=kT7>m;1Lfgo2@DCtnW;}D4ED}S=1ziXuW0dAWp@FFZ3=P2IKx_mN57{}eHUR*Z z0M>R8vN3NZEWE*}21tN{7NF|Px6nXRP}V?J12qG+a+or~WGSc&Qy6z8K_i^iTTp$H-#WI{+xP*s3JH9!Dt)T#O3 zY?F-y0I@kn4uqHw5C9FRTQq6^7DrqED?taThFT7(3|eEzYQQoCod5}x=0K%^tQ=ed z00csa1z-ab6I2%?|Cwt%h>hW34;w3(xx=av51@4wY3U0N0}z7J004sv3u~D2F=H8Y z#`WK79RTo+Fk%QKFCVq6?_LVfk&sEDRG~%=FrJx-rvdhkaI{682jp@BU_9$*@?|Z) z4j@6$;OP%Z4QeVdD-hnRF>M5nYf$lznf3KsxHN$ItcaI~hDLy(fndDGEjLJjFM@~( z4i5w!bw-2arI1#ln)}Qx`m@$jF9wT72aN!Y1|AO}z~O*xTbLBe*&| z>vLlhc({OIK-7?$i$=$n>(FZgP98=3RtO$~Mc*LM12hI0Z)XXbsvEBN+URa7As!cg z#oEck&C!<4W~mfPt^Rb%e-;8H6Sr^T$#q-_M+(r=?f43sj&4<=+YJIS7Gmdcv;~1K8)LfL4gSQ0<*>;_7Vyb z@R*IOCs3Y($up6fhDseeCSlUI7#9ox=YNA|B&yTVZ9H1L;o31wn}-}Jy0k-&;aK%G z%v>;Y049&d%|WB;Fn|1KIl9!yeI7B z7!!j0EELMnE)5~eF*5j{jiRy8xd%cvp#NYrs#P1@_oAAb_k-4q4nIQmB z+O&rc721Ewas7?Wk4_Tc^N%1(hqy>Q%7l>xBwSP}&^{1i9;%8Eej9QPEbI~B2M!aI z4)^XLH5+UJeEi^O1yFdLi1=ja2-vxxjW-hGQ7(g#31sEqi=nIm-vsPR^jUykR)R%` zlLwrvpOu>wi$|GY^U=Z&&ekZ+L2UAig|)jM3@O}607-+L4f3*~qoGxMn2S+Xh=MXm zb1-xgLStT>%K8V@WeAUeObIg^1hfX9jhb@Yx`pB@7+E4H5Di&Q1OR0wXdM7k1IQ~87LFW)iD}Q`7~3Gg8vs<*xD|%HQix0t)Db2kfI|LLL_|YD!rBgP+d#lZ zdNQID!56{C9Ho`;ZViD3kqIyA@6rNp4GtEC?8k_ThmwMuC)%_G9msry2N}=)Zs~%S zZVh!vHEx7MN5IAoMOn}gaP@(!C7z@pIuRxoAXQ)qVIf9l9z@2_R)OS#twXIAMj{lK zg8)iPVQP!c9l@c4)F3(>X*pnW;O+xI50qphHsx7yLQ{0~Z}^${Hx%a}uHGs#je~Ao z8@#f20qEUe^8d?@lJ&eo146v1$$5-%!x5H@z;5{ISG4%oKG4f@FnJIvct}lwV^93K z8x{s1qN4wr(j1Kc3>V`N&a1l4#idA3gPDu^Z$kf2f!0y`gfQ}f}p|D@PA#K zx4_LCyY>Nq!0?qbntDDR^eb^adi3b|glVdkxU**)2a9JGqP4YUx9%kBn%JuN&7PXUtp3XDFC(A(rUTlc{Ev7RrO2J^ytx}=f6)A z?q!gqMy^oF<<*ZKrIR0W8Lr#Sbr_;q*q>-J(aN>Zr1`>&_ zfBy&hQUHbN@#Fe;FfcR}@{Pa$@rYcbtIW9D+QoqG)NA#!xt1mpk!j$g((0m&yAuX= z6dM|f_{NL39;(&o?S%P1k&&^ZlWS0iHq6%?)_-T{{m0I5v=C11 z?Y(B<>;k1_4`1h5%hols6o5egY0Kgw&YMbOqT?P@TIs6UQwxmSB|S>Jcxd%6-;TZz zl`gPwUbJYXN&c0jLW7fM&;Pb#z9~nwCS*pgxOL*gv`a_U99aDMxrj9VdR&hlJ)ZwwM6MK2N3z*H8ul~l}mp{vKf2)1trrdVZ;`?a{e1q>ZBVNg@h*Nz6c?8YK^Ax1phfm z@&mhU%z2z}{`~p#m&2-RpIN-leH=Z1`H$t*s@EsXON*JmY-^cJ_4mM}^XJc>zZ6Ai^u1C**m!=cq%$Dtfy9Bm%wzoAmH(@l55LZb{7EbPeE%Akb zR#p^kU%p`QfPT@*S#<|ubP8$sjf*nn8w8wAA&U&Z@^Z9nO^L16u7P;QCol4Mm8Ycho=eQ^Cph$H+gGi&9i&0RVA4>?&rR7ms(nqbv-5LABGmPk|MvEG^*dE zO=U9q2diQ|cTVpxFt%vhepG5f#cLx{*A8y)-MjC?4ZqaZwSrXqx@}4CzP(recu4tS zci;8s`6x7%PTbnf)6vQ}^M2gj$5~WU-JH=L+WK9j!e^1kGv}jadFe6tb7rqtUNdJ- z-K0UPs%}K2OqjRQR!pbrU3_Gu#6-j-(}hNcT$YYv2KDGHCTed+CXbo*y`90cX!7cc zg2Ezcc79e?mQ=vEwzg!_X-Zl7&Fk0l%4)=7ftqDJtZ!#F^Q~q+|Drv;+=o(Vs?QR|$6)lIT|KL6nE@$BQ;r#|rw!eJ7gGa;mUMa0S zJ~pma^TK7VskKuxC+k-ySW2f#xf@$8a$B@|;mqZ+brFiQA3QDRd^<9jNv8m4YO8MF zj*`kXmi8{Btf;6$W@POg;OAM9`|wFAYvJgwO#1WO)DP~(RdO8`uUR~E@vXYtYO9LE z!fq9mRh!y42M4tkaU0m0F3(T99sh{M;Yv&LHEiSFy}L>T+yVr3Q9psD$MgRdnj&ZF|2yVZj~6MD3Y_JAV7~%GN{S-pyqYmz#eec@Izof1Mdv<(FA+D;fIJ9HU;R{hZ@O*uok`qfjvyuw0 z>>mI9iLd8REsnf6>Fcf0x6in8%fA>r=w_v8TyOtBj~?c?pBn6CeQ3?McO<>9ts8rA zB9tnYES2_N?E3=9U&*A0OxYiN$Ui$!#6YoV)}2cd^?4$Ay-QCi5Dq7^SX0 z`TNeO2L<&3y1wJ*J3Csx;woNq=I6D;r!Vtu*E%yfPHHfqF1R8uZT-rSs7jxwciI^W zI2wiQY( z?ONxh#8nFW0H`U;`g+{(435`;j&2+0jXTx%>z|fQ7qb89&ZIK`QOLwm8Rde3gW5!0 zJy-m5XvnBe4ZhO}3{4&EEJflsj|B}7iHyxmB=sFc7#NwDNkq`AVf1{OG?hAq!D0Yp zUUr5|LAti^7PH>VdE9Hs%grn-H1YCws{2;Q-Z+t%?|k#dt+0rMAopiWQM%B2_n{+0 z{k@)hG)a!UlvUpT=!t{Jjvg7%rrCE37ukw9G@;dw-w%y!@AurVOyJ=8H%{*oSPV|h z$}KIc@Us>J01c>!+_&!-!^~~|$j+R%Zj{i{b@}SG9%A0n8_{ub36-*^J`(M*(-+(V ze2fG5*ZhlP$7HT#=#5#!88bL=^2)ou285OtOmj0wCU7q*mFjV_I9&*RVJz` z@=u>THEHqA(6Fde2X}Gm!`<5t+P`nNZM|Ddp0VwcjXS!ynY+1rcse`xpRsDzgh4C< zZfyq~`1NP|dh;`?s-m;!PmW!%H7qph^wE8FzI1X@;|^Vn^=#qB7f4!ryZnCOa$%YD z)e1Ye>M~{AXJ0N~arnso>Ej2M6_n}~9(wfrgQi-ElUkBeOA`{4otksK+$@?vhC`*6 zt8@}>eby?q5&{DbtWfpL001BWNklP~xA}>vH{QY#@WHPtF016y3QMF? zP=6N-#IsZ^4$sg)$lw5+Kx4ns#YRQ~D4u5LJJ?w{c?B+BWom24`0K=h)vJE-&VAr( zZ3v(+GbQ@&W4mUpTYB0zru!!V0?sWw?dc4LP{<%_ssONrCN_2sTo=d1KS*4BooIO( zfDj}Fz|6sOR4)@YlTLyDI5AtP(MZcHL8E~n>T`4S_Hp|2B(+-g|6}hgb!Dc<5xq-b#| zZlwg*7$F8kNr(`4zplIQhlF4^5K7X*+xz_Zz}=kPJ!`XP=giEX$z)?FiN;`%NEp05 zr9na)S2D148a86!_GLft`K9X*Ue#id-f0E^062~-6><)PgJC2ZgN~8V*E^+Y>6utr z8kvrsYw2I9!&RSPg#+lYwP_RzgUXSAV#tBu@HeGqHE8&DX)PmOR8(lLXWzL~AdRD| z5LfeCxEL(}fDYG4oA$J@gm2B!0|1|n11!ix2Miu;jFj9<%t>9bx_j5ZQqOJJbnrrS zLi&S+lmFOdy7l;Zzn)_UIiGE7XHvhBdhyjeN7ruHe>Nr|?bfR)XZD(HK607%6CYmPaUyl=in)G%-nZh?nDqLyM}(cJ$?S#;d{ONcm@vg)9&AIz@z~k zBd%PacAt57{|a3b8=Hdf$Bz}fhM?Hdti05lX)zB3`89{m|Fw8*=L!8h5AEH~@7E>q{^cUmKEs29KkP|H?A_hJ zpXBSlGNkA1JaA5FnLlJ`ppS*Y`|WVq*?pV$oezo3&np=-a^$3W3#X5yX`*K}{5NPt zWgl}p7gIg1QX$DqPpc8Ai7NX-Wgn%mbV9Enn{iuKPaS}v2mriFj){8qg08L4CW9QO z1$GUpd6k%wUGn+`g8FpqV#KA%#I>2(c~nfXX#ChdOAk*Q)}bK%S#nl!V>9m#osD^P zLMeF?7M5F9#o*|)Y3FCE$4!d3@v>Yh6$+FH*`sYoPX}`p0bEu-dEfw@?sGT%Fp7ey zH{*iJ!l<}Jg^Bts)(iA&Q}5Ujm1U0`**9?d@81V^ zB7IpjkU}De3VWDSUT0`%gezp)CU!nfCb3VV8>0hRy2gHOyr?9EkPGkKy~Va@&wm3F>3GYO;U=Z!yjgq)EF2U5(+ub$fm8Albl}`9vWF(#b@*MeA>0Q zHqrgC8`Z^`(a&DuDAmGDw=l0rg;LuD_#3Jjv#Zjd$7K~&*8k8kwQJ|;(1Z1a_Q*4y=0eud$%rQYmB&tZ;fx;hyy_Svq(hG)xqpD zWcuIfh4gV)w3TODV;5{st7rABb?#}NAjJF&TL3PTDmjs#R=ITtRV1UchQ&MUgvSA4=14{>MW3@Y%32Rd_ z^W8k$Dd;;}OHO@>keRM-F7(!jd;$OfetB+Y1?uBsUjMVaAS>p15}*t!gW0xiJ06Q7 z7YmYKWVv{IeR2}DuBvFs+%?<&IBaj)e7|3FkqRmkQ!?=Sm>-m6@8qh(QJ)f3lAR`? z>Dj+M{XnQ*BtGYvI~r@VTD)T#{ux>=PMk!lE-!rf@@2I^NmO`_AS~SjE^nMnCe=T&1g>fjJH~OmQ8bw#2n$!gi<_oU-+8bJC9wBByfem$gS?Id zmxu(_HMNSCRQ`NJO=UrHa?+8_OU~X5PfE;?D^)-cIF19Zs;jM$y-_$)+&Z*5Ilty} zw}0=%x{*^ChsGq!KbrrJD5^ z*Tk~V3&NIE=1m#iYx{vSd1aqIgyL6mYquUQD63YgZ~(xSvR7GYagQG^U$yp0Tw;Df zIq|x0N|~g#PSDu5y7Gd<$1d^v zR2AadJ!@7M2^%T|lxD?GojSWxjPQ$JELpO(q*?#~!kW^<2aeT<-sxNY-H5A{b+xsP zMVQ&zCchotY^Kj{Xhh&DoKPvGwYB`WixUt8uEKEu!12#eQIQBMlai8doY}wi=;h?3 z7XqQAVG9Hy7SxHvjddgNkvY$@u<3}NphD}+VUeoZ1K0LFY!_^tL@l5?wQIHgFr_aDJ{bvP5GrPCP zFl^e^lL{3PdVUj^t21`}X}O}|;VH{Wm^v_sN+J!JxFD%i1OT8CUp}zGtxdqhkpnyQ z8lUv4wCTR6ZXVe>Y|PXbCAE!6`MVpE4V_z-iNF^z!!@G-l$o$-_Bx z%8Mr<78qvl-lmO*r(eG@uPTMOxZ?2ct>^DQJG67-nl)>FzjRmH?4<8*W0$O)-v7?g zjok)L`s-elP^$j|+G=*noTkF!)g}FD0Pp^r)R!)9)<491q5$CQws1bgwDo#Oq zbhJRPowH5-Pku$NaoZ82M+_b_Y37b~GdK)NX;$p7zizvE@6p!vt5>i2B{U@u0OCUq zVHh@k{)(9+yYRHM7H>MM0?13aWk6?knXrUj5 zIYvetJh!0PgH5Gi?Tpa@Gk3@o@`Xb?Ry5Qog05p$l%_pls~VC8&D?{IAKE&0%?4Lv z;~zKw(r@<0UGvA1F{E?wPo?QGTEy#-ky5yM{#5UY>m_pe($U>&MM@wbJ^tZOr!sEc ze|Y-Jjpd_Ve%yUl(xmt&@gn-}hrUyZ0T^(bKluz~RBc!F>a~n+i{qi1<}+s8*`e7trC^fM37&M@tr?2nO z5u-*Q}0HHI?(f6ZB5QTO8MkD`Jiuj!&e&0 z7&Uut508M052I3(BQv5Rt7^o$rp|)~4)F5v9x`I|s8PW#raH~vvP>d;`@G2%NAa^p)rFsbf|h6A7x9OzVRISa|j>t|}RB%OL8% zoDk~3Nizp~`Wz2=nD!!8l=8T^Oen4?*|&Yi)NL2*ic^BS_%8o#cTZ27&p(+BZ&58{ z$5n?n4II1RS!UKB>&AvWN`e^9I{>>A!LH zciFRsKRA78(x{D%PGX?qslDdjV_ipamvfHWe!r?8Y$;LgMVact>1WUXYvh z+uG&S?FYKJTiM!L8|i7;+1VMf-^#8+VZ_AQf$lZ{zM$u( zYkLy_LN1p|DMlWy4s-^oW0#I;QJ;0JYCurL&e@hhAzL^&K#?2}%)r#b($qktW$xhc z&SgR{s->}2a>2)|KWg}TY1NT9+04wSthk{0z7#T7*IgBJ<57|dSH|4C^`uNh009l& zQe3IR38LQn4HTZ`_j5b`_VdrD@@>1cv2JjkzuSz&)pkTvZ#+y;s+92$?>^42B>)&S zj+bxuT}Mt`xpH~Wuj_|(ZPRodi|XWth34+vqO&U-7nNo_>)X-ehn;7oijR!M>-VoB zh{i1wN)-?|-q6X0GlG&CR3TreQpi%`pS;X1Q@gExv$yfzqMNf({LQ2OU5Dl?buWd5 z|GZ$DgL#v(&IExIK&W1yGyuQ}LZ!k12%^CS4FG^*B(XrKR4VH#io+wK#Zom@)Y-;% z$M5GgcH{iUMGRTR+V6uG?zj*za?Zn$KZf=SWK%z`vGhUT>ihS42~OZjW&OaMz*PBDK@OO9_b**!!UQbJiJy&jSUp?Q$-n_}X zA0e|D?6*cZcy!3IooB<%9bALDb?@S9RV$GJ0D@vlnM5X&i)t&PA|BTWrS+c{jgvHQ z9V)I=sc?d*zw`tUN+sTK25=QY5DX?yk5qB$%*D94$bGvHyxFl_xO>?|uRde)swAH{ znea~NfC?vYRpb3uf3G4WD!HzPkK?Mmm&q{+8LwByMG_Ic^(Xu_v=Xgo#OVg++Ehhe zVO8^2K`6Rw_V3<3qcaI3uQ+gxoOy29p3Bv_iLO>U`c8hK$ClBlI7eI%&)C`?!jKcKc`PJo`Nl{=@@*2co2P2j!6S1NV0&71an>F8tu032WGjy5*V9v35$luF6*wF?~D5BYg|FBC=BAA0}*azW*f z_JTEASc1%RSMKTC zxHR@dB&dyhbYsxaF=jgI15N;-BrQ}I#k~4X`eC3yViXXQUR+(2vTDlGt(&&QK7YA# z%D5fNm)%Lo20+~Wf?^IVG&a^9G;L{KwXlA5l}wzLn&52zvClybUo)*4Cyt;LGAeI6 z5}>I#aiv@;mMK{*)+a-~`8Cyao)-C|k>e_bOe|F}Sgw>U-wj2nZwy zxlD$VsiZg4286IIckzmy%QkE<(^FqL>kFwVPMJp7@0!-*DW{zAPAL4YrPC93YDGzh2k=_LfKB}}J!w2bX$P3dvx@r(MOG!|Ej!(?%IT3VcU zPZC0*(psb&(z=S}oRv(;1|stYWPeD90&9tO#LNr947#4wKr2!JAHT3Rl_$% zD_%U7mVvX2i>-yp-x#*0Ka042{rdGgk+RqR=+q}6i?^PXe=4x=Ma+%GTTaN{opsDe zh`N6L`t>^z(q_lWd}R>QnhHs?=kz{;qON%Fj_uDg@;`na6{5PZ`**Hizn<_S?{gEP zQp5i|bT*_`{HH|zn;8VLJ&%&5`E8tRG_)SAWyIMA);+rTahY^mw>E)3&Yx??6YpP`J8n?_Ime{0jd*#%i^s1jK6%qr z6r@FFm%kPA0058@`scjyL;8PzSgiQZ=cSPu))qP&=1f?<^9;WU0U!X7i>l8Z*b*E( z{6<*v=ZfiY4K4VYVMB&|7y2~wUw_DzQsMDmm+ZS5{d&RIB9u%hWm##lMYV5YPRa|O zc{%h-%z7vLj8Mt5(_#y2J{FqtFQK|~a_6dD=RTUEpy8jOwc^Beb#=t$1u=0?b*!cS zcDg8nsEv8}5JDk|ejLeg?z?COW!{0>dgGs)7FS2Io!_&e?u4wi>|tcAT#4H_yH;es zC)u=1W zeef`%N}|-);|OuyklvjTSzYM;`}q}hTrOKq)*jZc>lc*)!R1LYkKUW3LI7njmrACa)S_)%y?X|>SM!oG80dlr?<)VJDy?oa(0-yv^l z{|IY}Lqj7!e${f(I7nkvV%p#$ZCO(a;mEetA z);2VEacHXgARc+`*p{0m*UvS2?OIGIxjZK|Iw>0^lWWV1aGG|fuHDS_ID|@(o){aS zl!;?x7jHjr7i$!tG$-v*c(e#dnN(EYu3cAOdqO398Xs@zGmvMbg9D%d3Yn;|pg>ev zm7kl-CCT&*jaW1ap^`m|k2CY??`oinzaDUjYfD2PMU>YHSURRbojU3=vBdbOyfP7; zjOQ1YTD!Il^7BxC8xgA9w1n`O1cE~6Fff{-Yi~anb;0A#C_v*j1N4L|~7E}BAea4B?(9*QlNW7}5lCEpw+t%h;b+OdqlQj7+5h0GXg-$I7{b1`m3Y zlyQ8^qCtZPKYdw902F7$|FUAnh-IgwN>%;V4*fFEKd9T5t*hrR*-}63tjOgkjRV=+W8e=frkD|1N)p#oau2WMuHTl&tcPv_?>piK!`tgaQD+ENkYlKKm{_l8P$VeILAF z({WKlPY6KXoEbrR_V*+E?>_rbDyrHzZ_NA+$8s{BPai&L)1Je>ZCti`^WLMIH=Mlu zsPU4~IXZ^AO%{6+Rpu@nH+b}-jY-MRSInQY@?eNaqIiDyWS8KdRTM^UV#J!mHw0oe zF_(lwbnDX5l`9%qcJbEZrb6~bl?8ts-#>E12n&5qYItG3+9d; zGmA5i-$(cUY3@pHf@J^5plJxOPjstZ^wq- z7&0XIUUa6~X6aGa+B*B}I(IWZ{ML{m!MC4eC?)&@>t}5{8Lp*8yLxojji`oafunCZ zar)RJ`;L_eHKXx=lhzuEBR~L(Q79A&i6lXqTmDL1oWAGWwblEste7$I>b_+oeru@X z5in@>0Xn_YoXGm095dGgM-FuA9Bl9CEO2(5*k$pg0Ub~PzX3B2(&?RNJ*xMnh)Xh$ zT>5L-Zx>d7Kjg;YUxsbX1%Q;e`{6H(mrb)}YEk_?^?%)UZRwQ$I*j-02)6Ata#)8G z=A&0E9qBc$Z{Oe&7!V+_vskdk)`PHgg11|9$(L^CITLy=Sx5j%IRrz8==QkKFok?7AUC zJ9>;-T6*sw%_-Qh^j>^zxm*RLW_(WMy^Qug94-$45DIJZ;*AI(k6-6n6sN@;xlwo} z{MO)(t|peIm(L=hPz3P4J_(@^KYVb*vd@@Hrw^O5 z(ZM}Cr4ed0ObCVK(Sz%zJx5$VcfyQ~4e8Z6Nv;h5fFg;HFP+oFTssU1=;Yea8l`wR zd8F+-P+rbAV*R^{DF10%%ZM8pnh1;Yp2R%kSvUnb>7z(`bKEIPl}d%HSS$_#D1*sF z$W`w=p5!;*4OSij!9AVVE}R}0^WtXA0rK0Xv)&v4sBo1^rDC$!2!b(KOoZGh_{-Ea zG_x{f8qM9}S*m0<;U`f67_hh`DxE{2f7GYXMsNZEjBMOT^){k3X~Q_s(9CUAZv!eB zwQ})Wv385O4)x}hQybPFbjwNcwNxWf_8F)!AON8)N%AlZqILqOHxPk`cBxkH?|q=jR!lThhqyHv<#_ zGFm@I!SOfaUlmhVk3q+1Y~6Q7t=|VH0Rad`c5mOsP};QolZpa3fnX%JcAfRa6qHQ$ z4IKQl{UExe{KT<6_v5qO&mS>hpa8(&u;c=XRQ7)`iTw@JT1K2N6tc`soE#msjLhY- z+E1?l0010g`%yjo7L6bD?0(;?7cQ%$%H!8ZPiSW_<-1wQFQOzx)Nb7~JCB^RZst%j z#vD0y`hmXVyUg9~Yoh}I!s4`PlV>NSJQfyGdi2QZG<^2D>Ai<^4ftvDu*A@QxBvW8 zA(S7#7Cg?cdsoLDyMNn0q>K0cvxm^GOQ)%m4t{d|)P>NPzlyf1Dtyj7io090tyfPU zOYZxkInF+v`*`i>-Mjzf0sarppW*ahaCh%gGWPyib@B@8@5|}ixBuh;9YQajWA>hN zXWz2q@EhBY#cp0cuf3o5^(geU?DF3MW$KL>*nil>#Y6LwjiLJ7mFq_zq*^vn%IZCA zT>XQ)I{v_qKb*Ef`liPm?3)x$pnK^9U#x`#5l%B&jjhxM|$m9t#FFvk36VjU^ z;orZwH<=zZeRwA?cY6g(i$X?TM*cZ-;o7wH=R(vhcF7t-hTeUN{^WywJl!`{LdW zFREgBI=Z%Zm@AexZGrDx|zv-7DeFs(r+H0Raa&p#z8|!UN-a8zG zOz+&S|Ay6r`V6e;?5KO{@QG>rLe`G!@aWRMyF&N*6Z`vmJHG;5Dy5;$MOjg?o*|FJ zVS|Q$kJgJ5M=c#(jCI&bx#VSPN}WWFe^YIoxJ+36@ZP;Lfx^_-P$rX_*t)x#vmb>$ zk-ZKs)H1R4^K?WJz@;^puU>a**UQyP4**n>+DG9}8iNRV#x{OlPAXB&qX+j(>ZB&d zMsk_d$lA@z$%0>=_bBX1wLrqtHS!AxFw#+T3l?W3K2I+oFovZGCojL0z!)97bmXe5 z4Z^R?4-I`%DUfRG8~gbO7-*?iM-x;QgoZ^`@Fm)M#_jzB47Hi5QMXfzg>tb_L6F^i z1H7Cpo2X+50E#{H#&CPD9M{XOsTM#eQlG{=OUWY0G+QSRUk?Xzv%`&rHO1kfk4tNW z94&p{_I?&d+WBeElCq0m|DD{XLq|g%LsVN59{RYXTEN!Q^KIwHR8_<#W>Hye8Ylz` zOpAt83KVSv0`xz4)u}~XR~8-`SzImPY8&{r_cJ%(WhaEkWt8DEiByF+c(iTn;XwYf zDI1lHzjOKQ1j1wQ#s!=PQHf>=B@;@)_7!tugmwpi{jsT{V7R3Emn9QQ*?mWKvjr;G z$H$XJBLl8@nHU$JoT)@9?mq23oUCvO|KXjRd?hB}^JyIY4ndvF^w_nfIZ^ScuRZyQ zjawTh3j@HF=?Sq3FLOyWrn5&ICuti43N|komcbc#V8g6W%3^3}Jv7Na-vrGt z;u_RZni)54+?*eF{n59r9RM^_C|OcfwCKALeODgu<7=mWySVi9-t}{ruftf5ljkp5 zxo|S$KWD{=7ZH~S{c!Bc)swDfpHU)MLyOb8rD!#@5QIQRFl9}Kbt@tw2)>}HzqTIa zz(9okRm*xA+W8(oeYjZC=$S$N22I%NSH0N|?SM|*2M-?Hr$-k9jRxx%gSNH^Q!}W>6>DU5e$v`a z3P~OO>&ckSr6?N`)kpaQE`^_G17ZTnx&LUF)FLd0&5Oaq9Tu*G($}E?Y0n_D=wI!Y zhOeI1vJ9?XzQ)>&oa`)|%5CrKMfwM;2>oZl0SEvbpcaUa)jR)NC;{It7v3W92^e-! zDL$l-eG>^DWmzz39F*|iED;Hyjt>$sh-HA1p;K?*VSp>4wic9crCZ6Rz~@6_jdvUe z{PheYfkUIH+=r-CP*VePCEzM(z8nfJha=ly|9zM=9iooGFTa7D0059w!pL!u@ev_d z4gYys%ZStHG^L~_IVGjIw2s2j;eBD8frd|UTOr^{s;0>V)1)=#lImr0@rNZ}aln_# zYP-qmdcOX*OCfuvk_1X?8<+Hz2{H*a8IYB@G7j*$WY!Eadj>|jiOcK$jj=c`tzJ7n z*e{@CBfsoAD{CTS6PLr8gP`vR{_YJwPwfC54)D0ZV8ZT;02tWVfqnsa+JTl9Ok55% z62KL3`#gBq0GA8)9&qs<+&B&x2Ik%1RVkF_fe#Nb3{E~$v&X_0Fsd79YlDe1SeU}- zIUs0W9%X-ZwTHr^!qOkBAiS8OLS1|v8FA%7SSi2%}*ME87S4hUdkFw!r1S@YeyD_&r?S31fPL zRse+k1rjO*PX?oM2y}mccZ3X19f2GaLSvyI3dXI3VFQ8QygOeefz&J*YY%{csS(ui zK`93Sps=8OH<)@9=1c}#gU>u!8vYx!mJv^W7E2=BIdqa-siLD2fo34l%IG5`8w8nw zQOA;LO{L=DK%7&E&%QO#{vMZZg}vL4-fvtob=eMIZx^)@ei9L6=7Wtz!%rF)x($Ze3*qVs04i+W2c3KXZ~$ZI z)fu$qV50;8sLF+63XB~L&bB}s2g`N=W&|DD!-HJ7_ZX__V8I0MK=?4bRxX8#LTKXy z{=QJj1M{_DZ3&HmD@p|r2sDu$3}hNunm~Rj0DwRMWGW!9LuE|Op{x)@LI8~s*PxEp zGUB*g_&h$&+}71cSHCC0QV9tQrRBuQcAqx0X-= zr~r8+`rGeVt~&dyjgagR^ny~R1NaGC*%_s=TTb4n`Cv@FpLbqbw&jgOod+cp-K*XF=Xd}n3-k8Cn%U|- zm`oOU^?(Zp!G#A$PC+|2FnIlv5b=S<1)4_3SVI%EmJxSr-__Af8-OS;$clcJ*4zqM z8vZVSDMSZw96)|uF5gLJe@CLIHL+}U23o5b+ovPgLNa}(LflU-3q;A&njY`BG6;*! zZDzC+hX*eH5c34OdjJMN;2^7k?*;(?Fb!bOA>g3!AOtGv;QTq@;ZPxhtM{SnYB+om z=Ffwj%fZSOj_n60ODL=beSp5B!LR_%Jpo%obv+}&xY1B3tonGWAA{)~9-7Qv@KD3w4EfFOWj002D( z{;drmFmg5k`u3<_ogYWTf18#v;;5FMfsr2PReFZ>^%KL^F)}yOk&9}xbBl0|Q~ZlS zxKxDFblUyjK$KZ^dwzP46YbbKYDzPz2Pf(>YK7Gbjt!4(@Rd)rX#wcLN4uKcke8p;~Lt{1jEl%Kh7hYWJ6MAp#Kn8os?ZDj55BE-4^Dx02eAhhEsfc=K`5H<2#< zPth_X@t28lB1>y0E2G!rZPdxd0aHoC9)?+Z_*od+nsCw!>NGC$Rz&c!sv=L!vfx3T zup(Qi?O|x>%x>zhA@vHj}B7`c;Ku=pK$KBfdS?jYCp2Zrv_OjJAsBflJ zhzkn}L^U-9xw-mug|5C4n?Y46WbqOAlQN6wYz~e?kA8y{(P;QLW0^ z%_%D(x}aL#rEfo5LtbHaN?6o0sSySDMaOQvtFq$r zs^z|I{Yx`qi)xj={z3X|Qo@r*1vN@1H9$Ow(c?g&2X6P_>A&wSkqczvY}~D* z0bQSI*})(-OrR8hiL&$Gq+Tfb=98?~3-HcEXWH9Yeelu&cq5d&xn3w)R$H=V*|b+= z|8f1@kMG#hakhD&r!^orR+W6>_(fZN$;xB*BQ71#$I54p8Sx-bHL|zgjZ>5D2Q3@l zjyHSW65F0L_h@OOMCFb(v%(9ge}vq8--zS#8^^Z}oW42uyDTFv8Jxhmo5Sh(15qN0;)%F^>na_-y-N!8(c`**O=e_xwPTwD0# z#F57yXM0-n9>>0%xS(787Ly{bui3djXwE1Rk{&xF5b2e;U%`Hq_ zcPiF1pl7p7JdCw(IsIJg>4#(71s=EHtN8_n5h4*Oib7UF^3n zoUr0l)c6TwGNW%N)al%J4|sa{z>>cT@Beu&{?C0&ua<`13ejWGqi>yDvhlPCFjr6a zoP^Y^ArI}1bs5^Gljlrdv19+>p8lq6&6FNMt4(ZTC<=0=3gDlfQ~J+hJiy*9sVu94 z)%6z-29+Q%tSPswyo8^2t=RF$4pasT08~AuWq;GgzakVeS)EJ^uEKEzN}?hFfFS?c zMg1b7WCQ?(M>o!JsnWK6#&q_zX=ulE-*x=3nJmet$9AbqlArzf?1S3dakqQ6u^ZpZ z*SGKHC9}^hnl+qn>i6d#Yiel${RWJ%!#oDGb9irea$)V`@SEdi|GaWyM*_FqnJ25A_c^P||v0_ARI=R~* z0OJ>|Ls9frPD3+e=WbakVg1_9-gfJcw$7$(E)M_*1VC2s$I;`xdju|+KE~9bxg|(R zG}e@5zr}=HG@JIv>e(X+shCW~PHvm8GB>rcFk+*;4pwDXEKFzwEr)(pb@WEZv_AVTqKqeJY5|ciW=(bAP7hVpYYacXc6>Wwdow} z<0T_YBXgz3hNkWfqI3iSDE7uGBTWeHQkXQFFJgpx^A zc89LRt%BI{vh1Trwx(9d4sBZv1Pa=Ex^xPK%+;^=PM|1Iu=+b$rBVO@LgP4C*#CI? zu&#nHBjttiYiDm6{^65@VHkzU5z2*fg_Q&;is$;rv6#vJgFU>)i69|+vvF1d|I4^X3VncZ}4nod~pb);t{{yQ4b33Uzn`^ z5}{Gf*+Y9W3LgBndk;sE@v`E>xX@0>r@XXAJ%OkTf!!TSbGc71q8T9heZ ze%xt`&`1>YT}>bq$ZQ6JG#v$C>eyyvJLQDnAwk||7cSjo>c)>5+s#t^V%oelFJC^Z zBTTZNUYfdmYp`Fyx=C#(4d^%t0073$8vp>WVsB2Jv+`xevl^9gP~w#-OSgR2(+5Fm zJT!Ue=;3Cnsw}Ew-ZVa{J!X`+ga=aQLu`Dg2ug#~rY<-M06DuS0!! zB~eyX!qsJSc^Y-*23jOzlVtDWOn-el)|3|HmsJBGmJY7QI&76foR*Tzm#FcdYBDyP z%_lN8Hx{mnj(=EJ*)TTIa?t0Qs`q2or4)y5$m_P>m&yI?_qR$cF9YEIobvkTvS;rfg6o-dBF0B!28(Ri-^ye|Dg3A0Gx5M27doTsL5h3%(n3<5CG-%PgR+eQemHS}6_yD2dXheV{&%1^_C#WXF%gqZFM_|F)3cLUEkm zIvSzmZ-P%7@eD;uv$jMKxRO9ysJ#1EZp1;2Q1U-Pdf1g2OMVKA%?;}R-J$&(?M#|e zoTg>LAD-SneZvt$hB7ifZNne8mX7WACEra7QSC3&`Z#>IcWgJW7VG2Rfyj!z-f8@= zA-6AiS?c|(J^6~zOz(ah;3{aDI*{fW6g0 z-8yvtb-j^7No=xoXyfJbg_oSn+bAm zV5l!F$&P&X;vWb}dw6zpkI_qi|1)~>pmzU%Lrn_xV`E7l_P?OJu0ex_uYs2FjcOSf zG8r@yiQJg@M`7`_cx)P-iefGAu^|Wo$8q9y{1&dlaU6GU8`R#;7)1$wO^rnUrv5E~ ztLkcNg<>i3W(kht1OSKxbpo-Zu^GR%R`6Cc4H`6P`1)xXBc2=`nwnGew)qoRB~oZg zGicDD;oG1E^EE#7VYHH00~;`YwzUy^dLNICKg}za8u#?Fox5hUqcIB*7%*c^T*P(# zx|k<%>4dUw-Ms0=y8el288=U@KeTkrji^kPk?r#3YxRomB$n_l{dN7=-X;1p*~SI4 z3%I@sFEVbO*?3~bxR8hp&3Igc1`Xc?E$r*~XPnVCKK=pLrum6+7tfw7Cv&T66(c%# zY5qq(=Y^MYuVdcWM${8TCk)zNz1>D?acM77c5===lS1ra*%Cy#$|=+MK!gV=`XXL zh|-$cjP#ePz79SndMuBi^^2!bq*V`YgcukZh^x!u7I*|bej-TV=GH4%@rodG~ zp$It;1p%|N^z9!sz%~;K8ra^-S4PO)gLN!qh z8Z>Co&{DLN5l6N3jGUbvXm9eu5q)EGXBQVcYcuTIbWaetih!>o)KDoGrzbyso}Tlj zdDTEb=c5RPMebrKZ z)1cwMKx+vlJ9-BO1+;TJRZ$7KrsHnO_%pQaADm(VIQuNiT7#?Sb|h;t4v}P@5$YK^s5M%;e`n;B@eI zNO&42M%h6D?U^)EZE4P<@aQ^`RNL58eRFgrPt@&=olHEz1QXkKGO=yjwr$(CZFAyG zY}|LTL=ZT0;MMY6nQ#p8d@95x=W<>+0ji)*T zKu?{k?u2x8<@j1pNjA9nm}cpaBBmi^WhKlenDhSNY*Rb=!xK|=BzbOOQAXV&r8dFZ za=uF8Cu8b*&R1f&z4I>tg;V(R4^)2A5VyOQ3RNj#!$*RJ>Nesf_b+B%0fcX34N-Ee z9bv5#H~{BzoNzyya|G$~2PkD@jt!TW&*CjPX)riIoq1Az_cr$NL~E|R;|Vu`O> zs>~Gg9`NNW{jMuk`rYX0uzzeCt>fA^*qy#KRnYB4ov+8epuV-WvO zVQ-j?``O1ehK7Z!1b3GMv1qIAvkM|L!0!xbQwB?GPg(Rin@P_&Tlaaq5T6$fK>>mV>KdA-=Zvtrwq-3X1@w|#O`f7WhJzrRU@F4B2@(hJtcxRs zpMEu@qjVcLI=soZb7?Z*BY%{xDIXzB3Nv^AI4}V^|qF zo@K7Pb7){PAxu(BIW@ZlD&5l z&SiVLhDpl(8Om{HU4#ID4@XI5c)=h`h@UJH@mcd7A8iWf>U2C={TXWC#CXGw$3*zn z)?fezQjbwk%sJlImAB@F%d^2+eB$SFnuH}SIGu4CygDel zI97^1XSbZahmDzej1sM@u zl`fJJ#aab=3}rt70r|FFWYFo$bL)?xQ0XY)Spp?2_bW`fp`yksB%3^EMU_U#g;Jfg zceghKK4~7VwvESC>F7k*JsV*1fv2CP|-|kw8$~&KRIXZx@56Z*QOe%{^H%MsZM^Bh~KV)NJx?$4Y4Ca~i#`XAiZ>#ntGlwh+z?f?6afeXQ}*!t(n zTyBKqeopt!*%_uX>`jVG>DYlmx{xVUk$!Ec<#1+E(X%p32C{ zaxW7w@&%^B0M=eS&FN?;ccced<9R^PK)sk0v%EY23UqL*P2)$A`7vM3P9(Y(CxW+U zSk=G}K+yQvk}18qEEHhUs(TvmdulRHQ;EX3=QWDojvruo0v=ju3nbmX;hrCbj*Rd% zx800>cxy}J)c6=zg(zOVZCtent<$R^cVVU8f zLH+uYA9GcpLr0D0%PCofG*wF*$aO0g7LN%4V;8xuPtF4(F=>ejsvFaDAb>HcUy6>B zh*KWBYdmi@F~s&(fhY_B5I-;&>lWD{fZT1AlNnk5?({fUdXaSWMwHO!T+;;c`#ev3 z%sQyUPp$68!~&~oE1DhS3H51iaQR8^bW>HXXzNVhNkh+63(W*S{6b$St{uG=3Prr! z-nu$#pYM-!UBfm58^dCL+he)E{*3KzjEdcRdwa26qQP-xGx$NsZ|4eqRXhtiOhF?| zIlEWP9-Q)9I0B=zO)`#{-w#?mtaIJO+tnlo6NYe>7+h@a&iCkj7sB&-I-AM0!SpK2 z^Wf$z)OBz<7yjHNrNenU+`#@~r}4cvht+JWY4^?9_u+iqcR4KG6QP~;;$PtVw^qkJ zkgPm3kuK=kvBbUI)Q87Nb6S?mV^5+_bsxf3;V`MfYq!(CFRD&D-Bo0InSn(Fqs>Y_09IOclu@8kX=pBHOh!GW~8 z&D!9YTTYw?tM|y5F%%g*>~FvK;}%z(_H+FK65I2PYE;1M!BzDnit#X1t)EK`UBvI4 zH|MXe{f0Qj%&If%^zy(ks`vMp6}QtEh=JXNT{&7 zzKPk3qIU4#5USJJ^6GrQQd+tWr&|M;_pFu7!2i0d&r_@wsm2yjn&+iVJa22%CGCOW}-<*-(ZQo1QN`)|p&huN&qV z;xewt%w$aT2>2z zl@XG%_UBOSrjfpzEw3{DXY`>ho;mA3&$m-gGdg_xJTo2?F1ci#Cd4J>e_#pzEPY_3_O<$ejk?a z4Z1=LzE;{+gyppYU9idmZ+j3-uDHGA%y(+dhtKu>)jz2qzy_iEL#u~ChJ-f=Co?@( zaFo3k#$jtVdP?UK028goP;8!x*&^Z%FQ7IwElF#C#XVCrMywYnyGtH#xe6%gdQjt6 zYNYf0o|o>rKs3CcRmvKDsc;Hi%S|d3Q#KJ{C=|^=2D;TNO|DuHsPVwSg!XUxsct>^ zNqIdS-HB4)on%Bit+49$&2HJGS-*21@JxvBJ(+cRii+ zyx9R3gnO)LE}2Bx0QT^Z7x|HE=r~y%6TtyF14UrI>m% zm=A5HWmTkfHJOslY%ZK^;ZA&Q^JDs)o5++`fQWW=Sz-zN2)dt5`WVNOiD2iuJJ+2! zu(gAd^6|1C`k*1Hb?L1CCJP{d9tD8`>XZL^naNX~5E2?R8XtkyB{0O>k{y3drHkAB zMvqn|U!B}YkgZHi_^0-Jumle;8qEdY_1dV_AFcw*ERqJd^j1W>mkqvmIR1*=o@oKeI0oLc)W z8`-pueBNwVw3f4&6x$`U)67zGh(|&hJDs#K!Hgsm4t|Z!Q&_bBaA-5$tRcWetsrx#h<+VhX>I2He94&R}l_LW|sV#b7k9IK>`!6HW6*8p2mAGX%;Vl+TG?Pm8C z7ZY5icp_ zjMdHUgv$-X)xFv*YUyGOYof-;d&OKCoYjfhF*Qn7?K+cIpjNle>vE0rRSU+5NC+;f zPG4IwR=q4#ll?8$o3zH{{+B?^)?hDfyrmJ=OhBO3YK(R&ZO*ZYwT0Q%o4f}|-xcc( zk7flv@R;WNN@`hD2R$hMj%Cg=O{Jp%83mt z1!wcHo6Vj?BB4;mP|l1#D-yB<_%pbLs5RmzA%?d0DZv^Fg$=2><`oc4)B+_bB7>|w z>6j(r?I1&X=fZ*$5UjN|T48@Ugf$d=gv?}u5{vS7ywdk*mbRdO1@ERJPNsD_{B7Y= zrOmP&tAt2z=!{ELn%vlSK|+4gl9)ozIS`E;TFFj8xBBBo(* zNbj-o1Asy`%1{{U4{8=Rd1>m^JlTA5G)TO3RcQKT^SLxF2Fh=B%9!Uk>Wx{uXhKfV zw$~FlDx1mJoZSD%#F}6p$!dZz{!Lrg%|?nC+DM0(Ev$>A)f8oZO$>Un=zYR=CFquQP{^WNAGEtSRh zNr*!Lpv7DcwRE!kz{J`b{=t+(V?J#2gxMS+IG}B@{u7Cr$>mk9K2!54tJ@u?UREUx z2^kVngbYWLYCM!pF=;hlp4nZwUKm8(kRRwBG2sxo=>No;EYAQVdsR+MG=g+(J3!0R z<}Ew?7rKVM&X|geXurbom~=>CFHa|1Bh7I`v#q18g9X`f75vYXW>W(jYq+Ln8 z$Diq#^(+d-l8i7ao~Msaqzktf2fJq(04Kt`!@`aYh874QqvU~;r~k-qg@q4|Lol#p zsw?W{DpGa&xseq-k4ijxYP{$3;Ix!MUkgtvqs8!i@%3~jaWRHS1jj*Ym>z6$l6hKsOXMSN_>;Oo44dMSpx;Q=PV!oH+@z^d>8Qd1)hA*Mr z;k&%nT{=*q(WB8#m6zVRqs&7~M=2o|gU#usn48118O73@{oZZx6jg-_>ir3itZ^GZ zh3b6G<@8cV1Y}rI9Ocb^Ts>%+%B%wjNrv+C@d<5|pOlbOh>LkJ*3DG-bbEMc%4y2l z81i%H0yZ55if)>s!?S*<&3^{0RW`f*q-1rlwDxlDICw4z}^j}Gx;6P&meGRS-V}GILDU;v`QFa$$1WFre6Es8t0Ozjv)7EOfH9J0>NU7yt=mxJ%+whS?961*4|gE&;A7))57gemg>XCK`(!s!!Px!Jiner) zVV>_irEdIPf&nU%A#LZ;`Z#Odr~AyX^P<(PSH1s^ElOk*d^PSyZIIUK52NRsTE*bA ztfB>KPgI|WeX=>(-{VRUNP^esooz2~ZZ}0sL?Vcn%pZ>ap0%NsoOUp?9?A#%WDK(S z$>nf(L0eSL_P6#d%?=N3KF=1ZPt)<3vWMl4KuR)hYpo9iaG@hQ+^u4F8Nr9@QVs(F zgq};|V7DBQVhnL{F{!`+k#gLUgyl|iG-G5WJoGWNcqF0My8wVMpS^YX40OvM0;S}# z2Q&oMevAn1Us|rXZEo$Fp`lekadzGna3b)ZFp^-QApOuUk{{@C5b=t@9Bm+A=d z+vhU82Ea*qVUr)RfI;g0b-3Z)tChu`w{-F+f_M=dA(pPJF41gJqOP5@If9rS(m-DL zj6~Vzqi=^dw~CvkLvw24rX!D{T?;XQ3InbZh2xZ&vRH%;CA^((Y1yM&rI18eP=E7p zP6D0|9=*|53+H|KGQL8se1)??eA*-F^6zGa{v){d=ClNzs1oIhrr-5x+Sbg#eoE#q zg2=rs3$f8VWVCcrnLIvWqhrdt(dW0n>A;JX$i)JPFksY_6{Y4myK@E)QTU5<*%69C zi9zbi7|GHkU|69n(AmAhz{_q>>BM}v3$DYkfO1~v3soieO!Un3(P?aAg$b!iDXb;A zEXRebRBLefq1@FDS0>`{Ma~v>fQ8GzUZ?AS?awzeozd?lzL>q7N@$T&7~y}EQ*3hh zhxQ$YAr;F1C_NgIxrHPiRb6jSpKEuK!=w!HQ^t1{WVd_e=P&qa(qx1T?uHB7&hF#^ zGa=Wyb=H<~reJ1v04v08{@?C}kWd6a!q1m>04umT{{BIqXJ)u~x)$Ws+JS7aC`_Z* zs-GV_Bd=8fm^iWElEe)3Kj73COVbG2lCirgAb!KZ50!O5=R(6rM9tR1~$i13}QOsVy z_WvuqlFw%E%Arucomxs3pBlA&^6n3!X&(1FN4-gPCRQD%_ zt8(3Up3u;yJ|D^8V}Cnhyz1 zong|AQU5po<(++$H`?Zp5G)uN*xu-PUXG$0AMFDp-=O)XlW={TP8zPR^7ex^UUm=IMu2s*j_B*o34+K zF0JbMe-1wj{~JNbaF(Aogjr15-9W;9_*+-dA^~OoVRDP~zjOPu^b*`Wx9V@(n&#G4 zN=AWEGymO+9FdeBDDeCs)Z}*tifS^t2(KjRwo#vaGP*FYq=z9JB+!ZbW=AlTsc&+1 zc5YzXv!v7M)s@E?9-3}$Pn8Uoln`-n(o&GwBw|J@XVBmG@p1FLb{)XPDlQbdR(o$| zMelJaKCMUMUA6n3-V*-Z-U%BYS6sB)pN+bjj=N zo}B8L3vLVV1a#9eF|yT3(Np*4Yf_XI9N~g%jivOi4$QVgoSX3Q-<$}ID5j08jO`gS z-s)$PR(gH^$`cY2f$bhv;+zjnIG!0Hqd@E|xgpX**j>E5N<)h8fm7PvK3t?!*^)AH z;UDwmO4HPwa^g!@#ejJS>N&=caj(K#WQnhTtI^un1XwVpbHLW|*41Xuiwam0ARJWw5AtZWP{Gxdtso#o8DOQW(fp}MO|skof7 zzOeW4_z5cfwKhuRd?Esl_Db9LY5M+6vXXW>i=ksCL-)D#0Bv!zv5T3Gk@D{3X|eay zosg1Ir+i6eTtv}9y<9XAZ_=iv@EF z>eSS{*7eG#pzNBPGJhn7gTyExt~{BKLw0y)m!|`Oc;`0<~j(#QP5FdhyMYU}Z z=6!xZG)_jrlU8q*l9&V7zO{_a%s5?!L8@aw`6(S*tF+xeTsD@RCot)By6zvUBX9w& zu{A6S8Byv_p&F{?n+|(}d}s5lZUj*znb*d_~ zEzb6G9tTIfFtU{u7L_v4zlYm)EuXR%7jl?Kip}5uCYC-~W76Lg-X@a8(4*b%4@`43 zu1b4pg1^1Cp0aUL^kykw014iXZVsWiSgSR<+-{c&Qy1ReGWx z6;rQMD$mJPrR`vRo_Rkr+SOIPTAraZxZN%6N>x5ZqqDiqlggEnJ|05YGB2;zf6p%0 zD#sGeG)Ry;|MmZc^OOs>+GsqLKoZ%C`y#2skPA*%=iM43@MW7kA**N5`nJrIQ?e%h z=`pGMV(%!$Ym$hI z*Yyz(S?$GohyLG$VH{U{n)$9%aiCA7|4)t8K3PMuZZ%K;dZ|k2+~o0t1Ba7syVKDc znS|$+zLK7b`hBB;iO?RIu=G1jE;J-qy9=+wN^7U8cs+@ek>f~bd*-O-$8#4AMi-pql(iA&2D1RyPy+aOP9YL9dt5}28 z;>S#<@7Kg5944Mf@R6>X=hfDINp?W*OWFBHuFDV^U+%0FDqgmF=Yo>eO7niGOUcoA zMTU{EJKHpV=TE%C`EGUBSvnm$Zq4U6hqXAm)Gw6GkB@toy?5Dpbx`xxoO^)CFg(A_2SGdG`3(qs*B@e|U!^(Rpe-D@m zSX~$aeOs>c!Na37FX_7Ik2l_@*6_H$v0s>1#kWJWZoP5P>U;FhoH8HhV1Dgk9oe3O?2l$35F-2B%gVm6ywoSCuuBz~yP! zlcro<99vmZ**n`jJUrIaGnBlAe*96c!R)SLXIyS_^u%Y4{DHHMh__nXR)Qu>fkBi%;xbZJ%6?scAaVe<2Cz#yRVK-(MISxnjOd z&IimzSd?XJ*uW#D+uYe5Ik=Zic=O2X+MZ-+pO!{qWTx@(@M2n09(CO(92HBUJe9(^ z&dwKyB@#-UVB+&Ddp<2DPKWqrHh=yr|7t&i!HBfGciMGypWe~|UWL6SW*U*z1TjVi zc$Mj=rDpE;pFersu*Jer!3BPR>!ft1{!CZ43Qo_!R@A8O*+R}lv)dWljT!)&*n>e| z+!m(RCPy=e-HYH26q3AN_t$`xk*o;=o*vhV&C<#UiSdX8yp50Z6opzSIsN9vM08;` zDw6$(*EuGJ zuM;an(co&iw(wV~l8gf!{q;uYGy7G|FItYT!|~pep+Pv472#}4O0ZKpLIN88!Ic@K z&MKhgyGv@wc%F0Wz~<8Da#bMl*Dr3v?z9PtnXt2k=JWj_K|sMK9G8@~_v@hd`EiRGS6Sf04NRH=hA$@k^; z^4GicA|S03Vrs-V)QZO4#eH)LHKka`rSW|-vzcDXvEBJ%j@0B|3|J`AuVqgY`x@KU zdPxjl-F-7||FGwZ=Lk!^S{yi(ks3KHK!>l;bGK_m&}q9!@d?QIu=V|DeG z+UceHNjZjfND^3IKz&VrJ)3Lf;Y^BeXU+x9bG(!$xAmKDI`6ObY-opi#EZ4_!utJG zsYw^>Mc+B3$Za2N;DP{P*K^~@lB3+PQwD3PM!NoqK3u)h-H6Y-|7LF^G0P}RVU;XY zD05C4;vXP|26$wL?ASR|vJCHqS!g#X3!XI*Pwg$LPsEpqwQKbs!ECW>Ajl=f6t&fI zLML$2^zX7N9nmS2F3y9;j#{Ht0@Pc~?y5i{ms*?}+(HW}x@ANIMr&ztoXw9Li1)YV zLm^qx;;zAqmrunqMvobm&_ceIvF%$$D;37ajhfAGuqh@0Psj_g5;h^NT@yo`|qQ@siQk=dRL;%iG8*N zNGN_g>PxAkSRDHUiw7>;sXe>bMHcqzt!|6mv(MII$mru09bGkC+T6Jv`0x3TV_1^& zM-L#GAL9FE3pmypLc8lBx6gTaVaMCT%i~(rA;Vf2B=3gPBCcOQAxo(v& zrSdGS)7^C8oG-WOdoQq+L6?DFJK=M9jMYY`NArul+Mpz67pzFXOY!$$&8XOAz&fXD zGqm)t&kY(O+wC#xxJCONOSAF2n&6;wHEwTpo%jfgxf)G=RL=l@owG(9SG;m(531u5 zZBEELb!uhv{zWR)2Faum5fqwj2c_?6T-JDu=enRv?$TKO;!>jOnQ^gH3guPvataDk z1w%L{A{f7>7g1rmw0TvDF1H|gPGhyP>SJ>b@a;V5(P*FvZGlKJs7K?7jS#DYzYJ=Chgj#=Lp6KS8R$Y~E)Vy5 z$onI#0%K}$y0d@!@yr6JYtf^(i5yFcgKyTCHjTym2fKoN=sY;Vx{5~N-;{=nRYfA7 z&(9pyf~pyM4fX!D+L28+oi*1XBcJ|F3RKK3pQqXIsO#C{-o9#WTfRc;L^3J0df$0f z!|6*6?vK$lp>;kauFp{t?+JZxPKT9?i({lzTCIn)E7gCUg?@ue=wt}^XkOpuORHFe zy$~i=D~(_Gx7-*GsJ~NaG=2&^(Vi{Jj~NF75rPL3SX3>tX|KX--F&06Er{M;F>ZKo ze@|v47h48HJhH#f_i7{=h&mU3cqSzN;MISaG)R7|%jd=X>Ztn^Tu8H#w#+O%C-aeI zINv533k2>K*aA8F501NmDZ6j>-^^5^U7t4$z$Z2vF{SI(^D?&Ty<9Nr@(5Dh?fkWa zbnY6R$w*6jrf(6l(<&rdy(;Wz>SeXVRw7Gv9zBsFvx)Ze#0H{ovG&o=ro}TR%kpc} z^!Jr#m*HvoLobTKH+9Mj&i%vPSfnr*YqMNwDz`=|zv}S)P0(fPYtct?(tQ;rA&50w zUAU&D{=ynrFig;l)kK=~Dl2}cIx~~EtN0eWMroUygKP5vjnb%qA_j{+#)q{EH0$#8 z-_^AN0M>UEF!o3IV|aM8U)N3@5EB_i?|N&#y74^_{r+f=&Q@p3d7WvF33Lg@~e?XJVRig#rA#=NeDRmHZ)}(LY zQcyqjl#Q~ALQC=aUe!kCf-UcJ!PziSGmQ9O#O!(ASFSZCOs7nbg1v&W&Rsr}Y47IC z@t*o%vU={*>HPV4^-V1w7Dv^mPACIhFCNy7eXq~(t1z>LT6yychu5D}ZamIV?N>72n?+`Ef4f+inW=^Y3LrFNtJ@~t zC!NZoq3oD?H_yz~oj+|nz6s#%a4?N5jgDvJLk9oiYzVEyU+}!BO5tTiHzjBj`IW); zxu+2zQH*ZCJ;?N@@AhMi=T*z;n8sRdwf)$n_{*+ z&maCX(uB6Or?F4kjRwH*|z9$h)r_~`G*nV`VZiS;4}eZ3bw zGipqsh$Ty7;nP))8AT>`TZijPL~;4MhTp*ol}Z!LoY`>`L@U%{?0IH>q>st#_IM!L zm^E5_1+wQimZPIku~AfVUAO@gKKVB4BBUY)c&cXP3`|TE)8cgUW);q!_Ltxw0eK*^ zc@#XtDmF+7e#Jv^gP0QT1DvcTl^s}i!qh64wFgNuB@0;4KtYTjaz!0lLMa90yga3K zFTp-W>YZ**mmA|^zui`)YnD-i^v1M$&N9m)BRx zl@Q_dwMpXKy?SA2_8kI2ZFvH9;i=#Jevn}nG}Hxq45F444Ou1>av2q~r(fCKg4oQ^ z7^SeRIAubisAy_>%MVE=dM`8cYQYIij168HP4H$%M2xMf6tLShG7fjAekoJzr>BQG zn{Q55Bs9AmaL*5Cd_|$5{W(HprZqf9L&DN-PB#hG32V;$fWU^Ve z#BVj+iOY?q2FJThDYE#}VB7qYnNP1npO$}~2XpY+6Ia%S*&Z9QkmFsAv9ff!6F8AF zTfE-#>cIj_eHa*d&P+x=_w^xUGCP}m>}Iw$Yx{adtwOZf z-CoAC_y1a!@1?xcZ8J@4Zg;A}rK%=a_WBv_n2>bGXVokwaP#6cSv;yHVp?tVS`5E& zvAI58&KDjkJ{LT=jY3u)%V(Ee%aY%y{-@8zu9aJTqCVxIf^BXC!e;>#J`R zXB`>hdTHsfMTxy}_AV7j(e$ui)l_M%d8AvP6s$PfH|U&a4nB1cxkIUGiC_B{p3gTD z@K|hJv@hfH(5f^z>=mefcD1xODjPlgU(W(^&+UikJp~CnDJgjKC5*b-^cW26$x=guKs|-ae ziVqiQ(9WZN__1bxY*q;;aIt8*U6x$7CbnU_1+o)e&uY1wgifN-mBr z-z!o#wboud>&czn#xC0ytYXC0I=sm+H5;>rN@MpK&05C(s$`_(NHz-p>Tsby=&iwZ zO!!S?FkcCzv?vagr+GyEU2}2GWw2jdn)-<=1)!v)Ca%ug*jlY7X49_u*YVbLyhM{goPk z${Uk>b2I9VQS`~=sBp|?h5vklKwZ7;P5X%}x4&#TpQ6+0Do{KNH$~i}P_1$n%qo(i z1No?4dS-lLE+`Sx|iKxgtWe_=pPHKI8`KLd(I#7iWqdX$Py2ZK z@q%)%apgm!acHvn7c{j6K|LkA`gaYMxF5*HHZ7_u<4uQik53VR_S#9WFi)9?0t>O` z$Nl+5iGaet%ue723K-3|HP#p3Kl(~-F4Gyr>`nwcTq_NAzTm|Ip;SCN=m!_Wmd|g+ zx~;#+h3uH6(|I4ky6nY$nE3v7A_`Mj)7uad!MZBD3)zr3H&dnyd($k`Z?L&^!F$p& zJRB5dB-x&Wak*gvigDV?MoA({KW&2dn=xAlh~cw>CI>{4f_A|Q^po1^i<8xeckJ5e ze!s1VkdijZ6e^v=BSgP^e6tLWeM6a{IA9%&r(ze8BQf!b?nXju1;pm`$Jz0p$tgsf z*+g?9NJ!o`WHBN{fJ+Ddme&BKfr$`Q7Kh4!6wV*;4d2o4Gi$o7poKzXO!}Lr#9!>~ z9;OAEj(dGAQLakF3L1|juM)xbA~)A&2mLSoA(F>U#`ai2L78Hp-`t#&~~KANVzk%qf?bur`w&2ks%T?J2!iH zV-G2^%1sIv5lrZ37{fc%K`IdmET65259QKV(6Hn!H5@pUG`C&`G!j(WPs5SeI7sn0OloMFjkyT)4aSNj=Vyh zHtgQz3fA)27aCxwLO-ztsry?J0dg6U*CqXZKSChWdVajJ6g%fJlTaPUn9tV;q4Qa- z)Yga}-WR=C;f)}83~LhgJLb4E zAPx%wOc6dK?4WA=KE-7JygW{fkfkrpTcBtbP@9E~YG$Nr_&yB1M~}36{dE)uEb^%VQ67CO*zli-*2vj!AuvW}+}L)}ALDQx z66JuM13l4`2`0F6a`c&-+&~4xPX}(5T@`lPU&D{pE6(sc{X;)-`zGO!j>?=`hyi*N z`nX@{>n;Sf;N|r%dx}xIQ7`OKmj30DaoRy9+P71q>`z=7PeZz*42~crzL1IhD{!}m zpl&Rok!YwPgR?(!r-p{|%QW;VC6FDkz{qx|wLcmVd!zxdP%S$O*n)Vw((&m4%`{UOzc^L;p(wd4*hLt7(7%yhz%46D1m#7f0u(?f9rX3HqlwoTU|RaR>4 zh8JoV9KkTCyJoKiR0!<(s$>LEE*^d&_811^^&T8CKS8zHR{aa~Y(hzE(wd-iy+Ijp z01Acr-EgtBhWi>}sr)OrG?@XT!L4)~*7D6Q7}$l!dXpKkg9r}Bv&J}V7wVN|PoMf#@SP7XiA@1*>XyEQXOkjOlFJil~*cgkWpmfh~E1anuz^m4XJ#_t{0xkB#)8>C~r{>s{baakqw&;b25wV-Qia`>=)mb z0;vGaMg|T&*GvS9x2Iq-l}h?!a1+Ld+UYW^VDyEm{>VlPkMpsAAQ?I*O8uO^4RggW znymzWC^Zq#H;tqnsBft?@xZ{$h)^)3j#y)}R3ZWn&9zMW$3?^^9M>yy* z`wc6nRH#r$3|gyOPh$T_+KM}XfQA(_CW{`o=i!rd$u4JwTM4Mw~-2> zQDt)e%+&5&Ad=BM;eq%POker?Q&l0vV+9H-{u#<+$NLN=U__s~K*kSlb3;45c_Ad{ z$aobPf)xJ!g;ldDa%On5LEpo+SBQ)s`}ce0qqiajLcDTARjSb7ObZ6Pvj$yRT zpWGwH6m6g|Z%S}x%PlQT1sYoell|Bp`tuyRM~<6k1ya zvN8P2zaM310$;8Ju(<}>mnwO43S9>x$pwEF4HHO6Kg>qex3s$flZ3JRB2UgJM>&|T z`C^X9dewhXTW1FgUZU270!sVE9kd7q*!l3O+Ki^-^Y_Qv$jEOb6G0Sy5oqHQ8W=5n zKj8&O&rF4C**oERu=g*4#(#zagd_N5LY6}tnh<)zcr=0dv3}Oom_}m?h{3~?u=w0l z3b&_WM}<+O7uL`?8t?vV9KM5;Ef%F6rSz`k`HJ7IFJ7?!^Ju`vHKGz4$<% z(z<2FK7QW$zyqAHqF8t5EAIA*P;bKl6nRC~_1W*Z{wOrT4}?6PIK%d2*PW4_D6@CL zNVU6?93ns{`Bw_cmv!pg29-;t&2*ic7fkMA7uAvi{hYjo1-{9Y(s#4kA(vwyV zF6GV^6H&wK`V=nw0d>h9@#sd>-~kWlV07~jkpSTV34g&K z-xH3Pv+OU(pA)bGAi_oEzVr$cLB7X%Y}Hh!D_pbkT@FhlFf0k48&=N8*mvd@?h z9X>MC21EG~4)7a&*YxyGS^cIaX;0&WA?YgvX+sIWn$q!kTnnn>_~8KHSBur>(6ZY~ z^9k^~$<6+Of%BUX@bNxe_q~0;9kF8cBC5x7%@Sg*Dq6!!wKK^_CIfae?P)QB;8wg; z6Sf#w0s{I?R|(Y5<0EzVD3CuCu0rQahfHc}Fn5{shwWi{D!_pj)os#Q{WVz#YL z!|77l6v{F0n~!*+H%fj`=k!~0bLxg}o?c?3)mfDdho}rrL4ip;15!`#^j~4Ot&B)X zeq&~J`|hRa%uk+aAOd1`hgqsl)@bE%etDp>6D1=(o${V(0FT=XEz`)zWTc{y84-w& z02}Q52aJCsBVdE2Gaw-26yQ1=28=S)Lz(F5>6t;JlQSX!2pE~8`?u`4KcZkw_4M@2 z(6E8Nx8~}2o&?f1zQ7F3{va#{r{pV!_?GFM-d5i}(No|$1 zxaLZG`-)-0o+{1k8xGiLXSEt#4vNY)Hbzp_2A4Qn2&YTw9NOxp#n}6%DnzU23hw+GRXsYUZ(?pO~Bo>}ymY$o;$oAj;_5aWs zogH)jQ%6ad=xC`aM@N`xX&Fn~vfR6K!!ACT$8>4NzmuhOeECJ^0R6jY(zpwS!M(o6 z`il1l8UXeBXHh3h2D62eBN^I>)?5_~G8gl!aebUEuN0&c-;XA;%t2l+zFOJqoN6v7 ztk1bNbgI;&tuF1VIe#U*?Un}hNSE9w+?Af^wy^^(Kzlec{MzTv3|F1s`vX9kn=RyPW#$7EZ5YJzcR z;gF9N5r>I_vazkDPz`iHzmV_M=^>0YyVHx)T_Th~Hh@x>*~G8BGBh`~H#2#-gpcl& zoS3_#>FZdRE{o%F|897jPUnlba0x_L$Y}R&;=1z}I7wlri$>d9>q=7A8oY3Dd$>UN zC;~n%xBi=I4&<3X&X$s~Z>AH51Ug<$XEuDmrsjiubwefZKiXPPcT)w;Paz-QwZ@ zO?KZ41GlKFV(qjDU%UI4{B1>t@hx_k^hKaJ0e}D?{zpJbX;C8AnErJg!uqo_8_65@ z^99IEPUuj)v__&QXUF%QmzPf@5{t$2Z%R;OpMbfXih_dH!@o*P01UE(HE>j>8^dP; z`F4wzb@Xaz(XFaF@_RE|_Yt4h&2DNW$ZR|bU3WL%dw1o zxGKvvDG+Fo?lD-Rh`9Sq-fjq1*1NudIE zcGe?PFh@-q$R4aF3>zo2Kw~%ChfUd$wn0 z9KZTMG<{QGBwZJ62b0Xiwr$(CZQHi(Ozeqm+qUgwVomJi_V?d=ANr}Qx~i-8*=L=# z*IBzLG909LWz<2_>|-=|GuK<^bqa&!xwL!o1j}Kpt<><{-L5l7F1rn7fq1NW#CTmO z`cwTT?bxK0eDssya1wSD4uVUwt({9tGrhf&oe@oKvTb639NC=Bz4eEJYH9$%&w~_q z`czS5bZF#qLQ_L?WAIEhDik4ZdwO^A`rq5-+V9w&_N=79`HcD|A^B60$wP~iq>w;2r zv0-3|81jpSk(tr;sVSQOc{_jMD%ywd4`Z*W05lv(6xlQ`ZYM zjBI6<%rv*lJw|M3YBySYOwV8Okgj*R-CudD< zy}nddmb$@Tuj>s|Iu53G-Ho1iqZ8};esn%uF3-y)leLOBZw387ly z0@aNIiYkxb<}9L$OV;;d30_cnf`tQNb|zMV4?wr!Y*_g2+sR{GSDBx{8um6z43hnJ z^KKtrH3!lpp>P$|{ckr(1*Z3v2+^7qdW8nO1BE9PuIiMXrTWT8{v$f6Yi*fyn%u*-@ zk><5)cQ1QF*520A@ioIn;>IB2e;%undV@2(_g=U8F(N#1$!b+B9>5JqOG;tRZETja zkJ!ybcF~$;@&BL9xDy+#N^r> zz82G)Su+^xX`_0#Y(H=T)$}h*hrIlp_iNn?+o_>xai0uzotM!PS8jHCemByCmzCHH zf2|I))n5Z+ZsX^EKzsHqyhYZffFwAu12+@i0!WT|S9@>l0YqRG;#w(nm`GaR-kyJjsrqTSg|?i9H(bafCkXdSfLyY zwg){70da7C9&b<&TLj^1@$YUbeZBEmE@x?Vt;SiX{w@}M;P_7Oc^v43U(yeP0IpA9 z0RsysU}Hgq8VwT@6AMFHn;l5-0xAfUy$dM*W-|?_9qZe-su6WKDY@Y%0Lr-Kv8+k; z@U3(rztiR~9svRfI3=k@!UD=DqQTQ<17VmLJ2?X|-~`Dv~3 zN!733beju@L^C>qjZ z{;uoK{K-lt2kS$_c)(`!+p5D0>R@}&D`lYOBN0?QY$5z_S>PWSrf|TLk%9KiLnS9J z0SR+$XgVZMrJ~8r4c#PqVi&&V*=%usiIuCSAWtu>YWbBisqQS5@;~K8MUBy_1Y8a zC9x7SIXJW4Y`NX{&FrGiQuCPW#Uc9E#xzq)zw>5n_vp!GH#^x*H;ZxeMgc3lo%Tl# zK2;;5fd#7W%_r+)lguxkf`Eqiie8X@P=KxH{`7AJRF0ymI)!{_i*3%i&DR?=ODXD3 z&x;zJ!GlCo%pZ3vIbJNzt>5pB;VYB_LiiSCX}cPnZ9tr52t~li0NkAhd&?wkZA4`3 z%3^zTFjcr5$^;7l%P(pw3Mo1rI6#UE2=}5cW#&eM&2C>D8+iE22(FCVt#!yS3*PB^ zSbfi59fiMkyVgUZc%0ppyO}He&MBSm{pJ{+E_^QLHl*&sVz-!!DO)?4JvflZUjuHZ z-D{kG6|4pe@ewBH=BDPRhU+_Wj9MfPce8Q-=M?o0QyJ3Ld4SG{0jVC*D9IHxi+JKA5} zU_GDOX^N_mVWEosOf32tGz=*XvYapR>r`neJvdA%JP?}m1N&yVmtfYpXMN{0W)H*%QHg5 zY^%L9USC18cu;oCP0oflH{bi_xSf%)pSFK=GygZMeaOu<|7?uj$7IV*iPPgz)@l_K zBNC{^y88iKLfOU8Ju1+yn#XK9!^u(ep{KhSi((P#{Tb?)_uTOAZF7Wd%aGZ|C8oH& zLT5Z)qA1QK%VSCA5?HPG27->_JKkqja@Rj6!}_kRbW;xCaM1pbG8mYz)Rn$j8vAE% znbKk(t4GX;hzxFMLXq#%@s^ds3+7Fub7o4PABVeDZ?k?wdzb5ti3~6#Wi^N%I`#p9 z7BFSufek2mU=anWYkpSb)BUhUdiB4|arHqF#~wAepZ%mmcXyYUh(N#z>f}aQ1zL~D zB`8IqS~y0byT?+8a5%d2uWtK(|5W%Zl&`ZR)VT}q?=X0Id5QBpbvbpvt> z$U8b0DFTGlTS*J>boiV+WW2H!m@oi903icYE1MC!I5 zvc=CW^5#4VE~r>urb(olkZcqxBuJXjoT&=~P%)SxMn-YLi!J&zg&bsv5FkL>#qr+? zJKWpzVd7#qKxuIl_g7b;BW!^6e!88OZ&P0*sHLfVa5z6bIU8YZE~k?f=jXcQd!0Gk zUd{5;Vx})Ed>)*lf`Em*lwtQv0V0(_>V|BIoesvB*E1jW?;mDzM zy~bSW&(<&vKtumk^2N05G8FM@UFr{Sg38@;og5Hj9r?Ixuf=S!R24{d`SRAko$cZ6 zzr$KoIXl?ci_}4z%V)TktQb5(lfL}>JDHf0+yB1*D8%SbiPd!sr(`)Jt*OJ!zXLg8 zbDKZh5CDLbz5D5@WM!pw{bgIN_1ybe7oy|Q_0?wPz0woz!?d4Mc|FnR-&jZJ(Fe~` zvcL&!MzgyUcs@9|8Gjtym&l|HA9Cz_bw^qaOFOk_P!PaR8QV+RSe1p6r3W36O(~tq z+?Pi2v}kRH42=+^vK>J~JU6l!rtu}3dBSQMO3i~&C&6NikC?izY?}tSp?=)zDSsQ zBxz2dVz?n7u`lWY6;iS>va^(d6fWZI`ugnJc}SvS!;^ZXSw|S!?hkH}pT?U*pT*)U zFv1FZ2S?^5v!37i3@IF3RB}ZM*y-uxndc->DfQKrt&ObLlHtL@i+FqeeE8CC3)7Cq zV*K z-V+EJ+^ndiTmD6|FfK4PKa@3zMOD8pg~LRXBkq4Z@*L-c{qq!rZhBBhV2^ZL*un)f zl>?EjZDOnHPHUV&c3Qp?_h85bVweD zsPh%#37f$I=q#2G@`vOnC;-6{2Y)xlt&pBk zXMYm*TTWPd_+~;uWSghw`T?0W2o!)teW!NadwU={)q(uHjQ=p53VpGtkJ5u%5`t=0 zvJ&|>cWL$I0+Iru=|pDeTVG0v&~9dI#`~SIeqn2>f@~bJR`{?6H+p8Q$HmFsNbk}7 z8C1H%_ig;X%K8LuxToyHVLB=Z{pis?62IJ}AZ7|(3ietwKDh7)E`}r0>d^Rx%#O|` zff9x$2Zz=j0ANCvHfpM9i2}OC7wsD{bjVo7;_FNnO72lEua^2JJtgItr32u($x^8$ z1%J)iZt~{vpH*C*5{4HKS{jW*(}6#SySSm)68nW*7ioJy1bh{+`*e9KLoT}_wdwRU zEmW}(NvZ*0%@e`}-XV-YhQ=m=@;m0UA0bwQBykL-dRtWSp_u_Y%#b3=U_+Og5nL1` zOiF}S=~cgsOcjM>TE|m?!m|*IinrT)`zn14UKavU6NW36j-iO*u_*_rEJjEeHkiZk zfc!)VkV2t!ER>c4y z$N&Ii=hFDRQNPPJ?H@(5oA!Z|_SM#BDX)x1wW#h0jRuc%5aHE!g=Bo~C@~*chgWNd zPZsAZo)-J~IK9X6P+$>TLxmAV#XJF1yGCUG&#;K5NnC&<4+C_4*P;&Q>K!H zqa(D1_BXv5Hv!tpD$h^4t)6*mGB!8>pr-JCbND8cM?}lp;(5PV+K|$-*8tM!-tv{>?Z^xOp|s@p=eE=sx`zVv-M-ft12p{q-A$YY@4BPTMzyC= zx%RmEL$4^PRIHFE{RDslK)cCl_1Rf%&bsW44jOr4bJ*$LYa-5((wv$oxsATE*CB$O zkxS$#+N$@;oY87JcDud(2dS5p!(0jzc5*CmeYoMT4mM3TOsDs&FVd!C<0c;(*}eSP z;yCVwR~@OfzwL%LVFTQ^7Qy)GbG^O{*#Lm-E?%$z(oK0AEvCSNt7xQjO%MP;yYnYG z06;YF{eXXhMC1F2xz^Uv#gA2enxO#-0F0JYub{}HLYKgC`8)!fwOsP{da$H7KlL%t z&)JS$u0XAXi31!WC%xz9_1=qug70@l*u8OK{uq|d8E{p3Vd3wRe3}sc#0~0xyU$!& z>ui;RT?vQuO-vMA8yj9XRAx%7rG4-Id+@{w12H(W@pr5}97=WZ4s%hs^mC5AFUsDc zX4%Zs?PB-!ayyWh8w?;6PKUwRmW2olfO)u{ALO5#9GpNiD66WkFDP;OTeS?bWA_{P zedvt%(Mhzm4lf29J?TdO%hMgn`;)=X0-awx>$!7!k)4%&?)hqkm7}RJK1W*H%O3Yl zc5((QIrr6Jzvr(qzu)9ZolTWYD{fbZ+D@16Bhn<^y||m>@lTm1t$*<#sz2$ocYIHE z9xf6+v*6x5xaPlBHgQwTo4i)re_(6F+2~8(V=%YJ!$;efjRrI{4opBFn%j2yzLctt zfTpGlmyXLE?tNU$2O^d_!wzzVGK__sH&}W1GWg9mCSNjfi5u9N2!s-*4?EX2(ooPW zV%-!f&uuN4&n`3!orfhCX{>E;PNc_|YsFoEdtO&Gqjf#AY4ZKdvL8Ce9=BEo_X%w* zWDXVs2dr^$fXXHjMw^J@|2prt@7w52e zYx?Hr=Vkg{vf+TwjvDyvPOz~S$H4&s^`WqUJVYRvi)^nBZ~OrWs4(B_KU_*vWhvkA z6h=n8(PMqyyCMPfMd)p}=5~Hxjo|@#NOgRpXE-;~FIr4y>TtNqQmv$&tvP}QaylKd zy4CMKRjkm7KnTE<+d<95?EnduAhzO%*`a5;Wn?P;7d&;nktpe zY2DPB;Ks_0Og+om$oarN#08kbVR9rJzPo29B|yu1Uv1|5m5#?}gJfjzYL?MAWO+5P zj}w;q3Il`_`grx4`l!YIq9wlr3Yfx(lp;}xluwt^ zIzIm}rv5#$4XM8#jRoP@h=ewr+Mb-+q5-^WfW8nJE+wkoQ}{UlW)-rPWfSgUsY7TK1m1*@@Lo zK}p#zNn?(w5&qKN*Rd0aU@U=EkuOk(9{3WN(jrz&^jjiCotttw6qAx(YWk9w7pGaG z*_W#q#6gP`gz;9O1iXZ;Z_*V1!BI?y);2O${x=27aSL$!8d~lyrbsm?10q?IZ(byo z^1(snkcNYWI9}4*I=c;WtWNfCgk2)lUoyB{9^9uKwj?DyEuNla>x+s>8x~9k!$mc= zs@(0i%gj^j!M}A$f9f+gciMT+Llq?Q%SM!=Q?9?M5rWu#8w5=qR}8ErqX!7wJwUU3 zJ7BDq5+kR=I$kh8|NZmntZvuiwmBLH59m_>N7%VrON^!t<8sY)eMmoA37rfKKPRd)U*%yQ8bO+VOg&JCp+e#JC)bp$Tzpd1;;P1|1AJ7H?8Oe%S~a4sSEjR>C$JZ{7e{TY z$m*tg1L^sn#7WRD94X}@drNc-P7EH&{}M8Ri=VtimOrni?`4XEHzMZe1dsr#9S;AG zIOAu&Ih2ajZLZGJ?zpm$ zyO~D#W;jGn8i?IKfG}gtmo~RS3Vq^;e3rTvy><178Pfwy3Mh7D4ooJFnD9TUrOKdpE(PMXzTmAT%yeoZGvrnsJe z`q$NNAe`C(0*o=1r;i9qg+2OTL-ILewPuQ+3`+`s&~vgkDS5Id4}lvVT{Nhy zn9Zs-tVX<8;SJAY%xCfVB+ps>rvA?F%h~O?*tSEYU|_{kqy+4N4F1AOfg*Ycr(7?S zx)-xZWDFeZ`^^L6%{z<;_zR1SZ}C?WVIMOzr#3-$VN4u>5_hK;q@=ut#y&x!a#AWf zT2=!mkT3UW)p@P$A2a5eBY7Ok!ejN@)AbYyGDwM>bd>Bk4S~XXV7?(7S{SS7nIz^g z3s!YcMNA*t&1x%kbb)XCt`ZoMQh!;fK*5)SL`qxv-FVXJhFN(+it(x(2nD!>D$- z&((~xMSV4A2W13V*|r@c;ji!wVO3Ahb=0>N`_%E_W_Y7}G71)3U2wo}=!-+7L|@3+ zbRm*e5CF)WLMC!r<|I=cliAo|;sUHKkCz*)3bZwGuE;7|G=|UOjIPk5MTohhVhRy! z3`OMyHVtm~V9;mT%`icpm8q1ENvHyB;l%j{1hjbVO#hdbZV@01<)oye~bHL(-45bEgXc=hKJ5E&CY~Gtl2YH)+$Whf#0tO@7}(r~>iU zDC~?Vs={~($&rS347VX-iVtF&g9aVc0&K(+>{TH9KLZoO^MikyI7jq_j?-bO{)+0c zA6lj@-i^Wcqo#uA!R-9f{x=N|`Am}`_X7jOp!bTSDg(voaKQ7m*c^Fq+wQBwbYUYp zx;IM^+u3{LVEeXSeg7c&%-DQM5;h#pvDg3pX~%k&{Nc&#`($1LbOauPQprFPVqBBJ zA?Aq?Y5DIo4rkRc3rSb-aG0jGo$OZAMWdT-G|XEN5NbKJ(asfDgk|+OSq*)+)16p4{ty|($nsweWNB5g(RxwBs1bCxO5U z+4P>%aOKrr?A5CrNKw{_GHGx0n{La)t#-@m zBQ)dJ4|g1tdLHy~o@Q?6QsY-TM*vkMCowC+r}gKGIB@;AH;0=Z`uw4klj!{O&%Y%% z2@0GZr=w($A~q)NdV&K8BwAV0O&PQ2;7Fx_d61P1fjghU8cw0#eBki?61CA10RmtG zQ6OyKh(KOZAfSmKG1A=kEuI^CG|myL$!DU@fGb!ulrR7Q=-UwXR*Sn8w}K9djg2UJ z+Dg%m3)J(H;o2NuKA1>JUyFG)hK&8iKX}UJdo}dC-8hVOh0S0CEd|qY?`*kP^Z#oB z?5I4n0NL#Z8)a7*t(FTWzN24nGaohg)4|!Mdp!1H>^YE6>OK&D6VJ58>!Tj+H1SVkw>^elZVBi)mFlZ%;J{ z;!29BxCqPA(Xv{~keKMLCl9sw=GIckN$9fXk5CC>Zcsa?2V!st3-$x8J{9_gd*NW7 z*ciUHQ$K8#!U=h4sfp@|DQW~o2}GC3X732fNd_*Wg5vVFmL4KHvWbA%=7)d2yAkSU zq?es)UYvJ+{QUR$sdBcuo*ZE?TlHlAKcpNgS7Nj($z@^`K9@lYtoy|5D0{-k~u2v9|NfId|7;Lu3S zBO)S6s#dr0F_LvCOHFFJ4A7?*D!4eTf9j9E!2^2I9emQJT_^l<Jz9ZY?>iN{5yp|hudM}@1gl9XJh7s zlD;oDI6%N*m5y}0^s9~C?CW#~cvcyYud+3@aUbr9AAhn5Z%BLD%$77=RMDn)|| z6opK5bE|5h3?x*vP|1)eQmoK&oE{275mvqg#grpUghrdk z@Ph_Na{bq28XWkxVA%gjw#qvh-kSQ|HY&f6orbC2==JGluf6k*?uWq@o}WO48r3_t z`?@O#DYmt?Gd&Kp@+V+$W~d99bV^xb1D8=tRwsEkIKGxYTFGDD z^m`}X_mo>Ipd@$8`trCdsAX($IB5G+&viO9WAOgn?3wME^nL1-5VH1 zjsyxMZs${os>JnTY4D)8wYfU~Tt5a3Hq>R?-UzS3Z^(hcz)9~0*r)4$;sG4E>+R(= zYL45Lb+lE-!x1=tAE(g`eL6D}6M^R>`dqhN_lIQS^0Sc)-`^)~irZb;S5xaYaFNCQ zMf$yq#^^aFgKrkw8N2jX9dBK+H-QqR3#m2Q4|`irrS+1XH6%~XKPV&-pI;0$O+I5G zGbE$%xxH;W?k>KNlK7te)?57VKZ+a4e`WdWFi@Eo@z?4<-yl6+WIp|imulo26mNc& zb2Rv5cb~DTot(|BbBZsFOx4iTe$I1Pr8O3Vd#pFq>3K@G)?+o1kO-)L`mF*=z-(#1 zi4!A0oQRT}tbJmtjiMarr>K^pQDx%H@5+u=fHWS`y7~bwU^L&1J)}03{UHWnK^BLF zbZqRmzhE1-ceYk>D>DTRP=>Fw%1!DQbT#fJwj6RD< z0yVw27B$tkAXwrUbE($0K9dyuF+#r~mw&pZq9mf`YF7|i$oZt|d z^z7Kkr985dx~9f9L8GgiVIokmoi3G_q5SYA_2Ep!Cf$&0hPvEkm9V#3o`nbx-qhSw{pj+G-3TA6;fSJg?=`^W$97~rDTJn{fAd4TdFz# zBvrpbW-(=JR~1&MrC^Tmi`GJE4E-!GZW4F|OX@h*vhL1_^pUVm3Ml+`SA4stVnjpP z)BK&FMV@$;vF7&A4Vc#piHs_+L}_Yz>;>{-%Tv{jRkS)?t~I92WWEWU(`TOVZ;OBg8^M(?xs^OE4-F$|+FJA#JpkRp$@KG)QHb|JI{WO-2TKWDNC=PR)zgS6WG*b3L;g zgPkj9jDhvdNm<=){32fJ+Vr& zUmHQ`nESMzcdi2!vgo^C23W(z`mNbsaQN?@DR@_tusPP{(-}N%-^(vf-@mW zb-m>b6n%G!1V3wrQeJHxlfOOsY8`y7 z1w;JgdgOMa!T{#o=65D_U4#TKj|r#7zbC)3e(2Z5GlkB4A9r3ID#8Rsqz17SI*qaH zG~Kks3N!p9(mK1~>db)aQ^?%U;Xc`Ng#Lo~u1ZxtgY(UHY*$)oNW5YCnPDfQ*0#$QA0z@z!^tpmnGXZ-v6pwJ!ptxh$y0p zX>f)>4`*;tGAp~($}brD0R@q@g*&Yn3_w6WMHFyqE7zb%9oJV!Zf=U$Ed!Q1gYS

    Y( z?G_9MR7nv6^0>awhCm2)@ZyINszcOXtBi4{Y9-sb`i^wvv0jJU{o2@)E>=@h>u$J_{6Zpo1nn_`Zo3TysZXF+ zkJlIMiYG<}B&tH|{Ezy|D0xm+I?}JCz!dwRg4F~IoY&VgGKq_C)6zLVTmS(b^#t7w zd_+$lMN1axFjHMYzcPFI7KZx!`(KeP=<`j)YXNK|wYDgV`k~+FNJR8wvvw=TH@&(& z=M%5N!^3m&Ph`!goGH_^ubl0nGa9na(t2`q3#;?1D!FHvEuLpC4F$LJ)!1PpVGSi4 zrSi-qR`ZK5>1fKz{`BZb>bsLF_-=4p4K8G&%MULrvc|@P^s~g6kdTn#&|GVBp2`#% z?^HX1K%#h^69W9Dah!mi8-CexiWdNWvNuBlfRIb)Y%j$Ahh;EcXg0DHJ6^eUd)QvN zT03;CcDd%-q$a7~{9ISg&>kG#s2=`XT+~SzubYM5@Aly4d|4G4;vuu`AVQ@aguxux zfKfwI8H^{V`y&`1B?9)PjRgz%237^R-y)SQWVk{plA=*@jD7@K=1&>?Z@Pxo&2Vu)*TJdqKWD3r4HYEAx^iO3rXlUPNNq=d9*ca!mno}F6> z0$^BEzVJYqkSu;SkAQ-*NxZCK|1c!6d0t01`*$Y$_2v=MQP^y@foft&`kDvhz&{r@ z$+-9=gG-R$_tW`Z)G}bCzE)TQ0~Kp_YF>(;op*D1`_VRo88;7Q^+u2H(NE3yrOvYH zxCnDmP27Ymw7sYDZx9t0{AX8pk>Fc}0JGb^8aDGFTef^1`}?}iAI1uK{*K+b8oUpC zar*1dkAEeSxU;xxcbm;?ziU31S%2|wPs($&_b`$d$nO&Jl>RY`8Ifi$r0Me7b!OFI za$OStN$TCR8~t{W%m@~4LV<}kl==6vL@tTnI(ca!HM;lu<0}3qY#xwwG%a4?_*)9O zd1lb~6Zpm_^SeV5bGEmBLLo{S3Lr4J|EoghN2PK}{T*U@+~Ki4)uww?Dvy`Pa)jc3 zjg^v(bYOHB*M}xz^mNJJCR*Y3njzrOz%)n1Qx#if9*=LHTAgk&xwjC+6YGA}UGK9I zz!`n~g$Rq^>Cr-YrgFl`C-JI9)L~I&fU^I_ihzPglThDiLwd@}aV}bf)Rl zm@qhgyW?d0V_%Ub!yq%j2A&((LJ1=oK>*Bc#xgv_OjXNjkU6t^FO_AOAVB~s?13^W5*E4?Z~{P?441)AYpl$* zrHzeLGnipMNs3oo6)V&{XG;{Q$f6P@iac9?*9d_ECGA}3;zS922b=JK=F%+I1PPOR z2M`3{oe^G+D2!2Q= z_nw|wbFKMxxGp|US-u)Ig1>#@b@{=`-fP#r<-gH-Qkt*pi?7Q8I*=-Zr_pi|UOlk& z;0x)ibdzIUGsfp?z13z%Ebf&H>(*jndvbK}S{RbZz1B?*dbW}u9^e0!FC4zsP|SW! zzD>Wg#J#mE`K^27+R-yyB|7P*n`RcsVV#vvEysQI~a$rVLs-m503>5nTwK~ zkVH}dfR`AWSr`uhFv#q>v}qSh6B>V(ug>ul@^D!eNP%d3f5E=+O?`0nv+}VMJ*<>Z z&a=yTWl1dSxs(*qDb$!j#Q?VA#B9tj8{?=~vbC_Hvn)%XS|)R|)00!f%3$cN3xTm# zo6W}Jx-VTf?m*yEqR1#AooJ#t@sx4GiYy+@M^dFIH`XY_J5)AZ(kHU4h?AF5Bm&Ov zQz#)2uZv^)B_o)?T)KNwnQSf{|7twdR|6;^z3m z%=|0f?LYAp|ERj_LdG@L=)B^y*WW({LQOe@)R&J>ZXfcBo#cH(42^4UuZpB#&Je$-+kOTVK_CSYTT$Mw84LtO7%8+E ztS@>Ec1FAUmCTbQLiH+P-CeXqNIjJ^RmqZCAw=Mc(t4`F6xqKT)jZZtzt^=<1{Fk> z7HE{qzGy@gV8AE}?Ck8+i0Se536mm4h*0lNEDR`!Y%EhLlc_>g$_2G*Q=&v+V`H6; zq<5XMW*x>;!3qb1f5T72wm_*7W0^WfBfJ)Y0H4-8;(x;!AfVVRQO_qzu(i8mU<<8or10o(P3$BA5@29t~*6{jD zg&4aF7oF|<&}x@8X%w3s4Erk}y>Pg~`t!6tQkv11pH>4457&BOb*}NT7iij;=k>5b z3zeDYQVV9Wm&5yaYcSoW+;Nd8R(T1!{BMQbdR$ZSm#DiLi!Pq!J}cNiax zoE0lF`zw98LGY5uSiE@pI(Uxne;E)zTKzQPkoP0+)nqWXGGQaSxqIMPPV|COV#-T%#DQCaV@Jrg0zDx^o?aJ|gXQ2+x3lvlyw zf?dhN?E0tjkLoM&+RLD)o1a;lPnjL z{5QQWdrMFI#;7pRY1u{Ejb=4^PA>y{aV?|%8f->SB@f*EUtfdI>=TsF#)+O1R}00_ z3NXM@QSR>@aUY0{Ghu6VS-(HJXWv{b-@(c}fg|`FHh*tU)TUmJV0syywr1T^<*;X1 z4*V9z{u9lT0i!WH1t}*hh-w)tS8l&0%!e#tu4>_ysajHFvFINwyC)`eQZ5#`d0aY2 z7e2lnr}N887BfVFA~6O*f`qN@RMrNUcGj&rPCB!lg#H3{sx-kIdO8N{DyvbS(nWJ< zhWv=E2lMp^b1C6c!d(q6`GSVs^^8u`X9w-BCzdk+aDJSKo}#K)Zkg1GBx%y;4jslC z)zQ#J6nYdf|Ctl(=_cLsP-S5GiI4f!+0o3S7+WE$pLCkC%6Q3xzj$<&v91 z#lnW>>WUWj#2%a7^TB`$C^LSJ*Rjig#N#e2P2n?N3NhsNx~izE@lsS|G?-iZ9p}da z%HiFQXpG6KivHc;YTU9>mei`~mvTZTq$$?7Mgk>8hLlqH!l4k_3vg#3%S|9q?Yyc#&5nUpBR4%?1nWQ)a&(l<$N{nZNYH;3)q(g~|*WFl;t_ z34$H7vdH*;A_ht7#GyeVX*z#4mY&f{-8P13l!vzWmQqJnpO{%KRN;4+4(pH+MRj>k zt}Ts892yAI@_HXYmHP__YHi`mhkCQqDzK(@jrl98C=*YPN5qwIcX&e+0011`$8DH} zuOs#RRX`%7o+1>pynUE8WdU7L5fN_YkD3?{u{JsHYgiKc4a~WP^ZBW$FTTIBF|s*x zqc3_*sQW(_GYh+He$!p|Kk%I&no4IQouj^M(?^<;?Zcu>#p2SUetw#gf~vHkk339K zCufJ1qdx4PgkcnSP)=A`R#10$tg5d<3ff9~z%Uwg6$3)$+@>T2rv9ykjrHN`;9mIX zm?JYYN`&oPuZ(mpEUcB{VzibS`2KFP>a0!Yk-nNjbbDe@lhKvkb5kpTfTNzCoZb4w zt1;#VEeD|N;bkUel!$reQg650I<2fUw3a+OapAIyC@`hD=Ls5wAj#6pzVD>r*T!AC z3L3BW*HwX&==2hy?G%C%M(_tU#&Ye!Y7#c5SYB*X^?V z?eE<_Zg+=UJ9v1PS_USDynef55%*T9b)LI`gc9!Z z;L2RzREv1q;?PcDuvrbE!sF8om&yjoxQ|o0^JE~`sIWf?I4+byZcq9 zNV3ywJpYVd+m=#>3oVggWUk%8-iN!$Ape)3Bo&Ivdkd&?NT zm$k#yo%GB2gPjsVN`FPn9TjcQxO^HxXz!z?ht;&J>Iur?ZH+rUS6(ZqTqMLv}TN#2qPg zSf}}4AOI3@)*IOmEYDI&k>zya)xMY6P$Q*)U;1nP?}R!H8Lr1iS;O=(qk0GExZr!% zJJn-3PiPoXkbGXF$c^g#*&l-n;DR6kaEz4>@BiqOT|xF8N`_E7TT8hxK~2Z}zp%HE zEr04W5cO$oDJiOL=x2XK%*jEIxmmwB2NHnRf9k9t5CHBUvzne1tkF20C#3r^g zINPEeD`erN>};xO1|MdjQZ&|7b=8yPO!!bWqXmMQ{@1(z)Rc9x+;5!)PLv6@YmKu2 zZ4g+1f}Wn_9;Rn!rx%CDWU&)ZIRqRWoSb)FG)-7p0|$NYvVMCb20Hl}>sil;>y;pBnenVM)!|DCze;4exgyt~=|L^%wA6K#+ zWPVgVcqJUvQUg`?dmqyCk%-|o+dl8G7#tpR0DbhVm1#$1>{b5IL~gHEaX2Iq6-M8w zfT3)yoYs%b)WjwNa}aRBUY&@3_D3MZ>=6LIAH%q;U`stIAs45(;^?$r(J%l4q)1s; z)b{pvS)(5bfWUa3wIK#@QB|o>jS2wk5*tek8 zO5lI7-#S12ha;>YKmZozPL)kfE%J-SmZYVg5u28BwE(&hRlXKM+IM7Um)@nBdAsBJ z88h%H!_yN`;)>02yoAqAY=@I(wmm}!1i1(pV!b##7*^(YTA&M+%DoKY%%wGhxjbz} z^pa8XGs|3#>6?&r+3ePD)Fpn*$>Pfg1xa@=1KB?=)Gs-^ZMU6xsZap{V-@Q3Ix6G$ zvNF?MZa#-MSv{QYo2#Mv+8fSe|!|$b4sbzfX1R4fL z<2s8Kw-y+P>8$~&3VG#<<&@BjtTehGafDxNOJbB8Tvr0f__fji0Jh10z5pa)x&8r| z;rAOc=h&K9&Kx=3uJACf53FpX2v_XW^4<)70~_p6UC^0>HtjcY!iHW2>5MK15q@tb z<0*^g41gk7SX5V3V=~+OdzT+855nU9w3Rg?3<2aQeZaeg1com;r27>SfwfVg(IZWE z1gfWO!%Ff2iL>+J26{bydm1R9td=6_=h1LzF;-|tTa`)}1vRwvokwyP*TctSPRT+{ zxciMc8p;z~T^YS+f_|d<4zMQq%A+NJc(5p_tgf-Km7SHMz6Y+#(u{&~JjsfCD)N$} z?Sj?NmT&lU5s#2CWW2a@6B(I=t=Mrp@u|Vx#&jzh=Vu4EQrTJ@xLz)8{-Fa~p?t&d zpULi!j~S!w035CUC_sf&YJDhUIEY}L^o<`NpcGcLS}fblqQA6EnF@=)r#$9F@hEnI z-)_f5$t0Xk_om+n@BQpD=JYDxF8M2v&Mq*=mR5${euv-E!eVO~j2I1H03rr)rO~uiGFYGhA=WPd*};zPc#aGGezbpS#G>N$ETSu zTBtB(B=(zp`8N_4C`E#kEtZ)qToAzs7AaARlrWSfe;dpHFWD~sdHuntQoJxdj-Mc5 z);P{(d9F;rkbdbNMSx+}0CWNSFY-$Jp27Y*y2r?+5s7>;Jr&K&1f!yc!V+m*8~QcO zObj$mjFOg)O4a{k-;6sc7cW=QVnd&SN>W+ICsC%HvDxw2seVXa!_na@ z>(qc$E)Vko?&j)f|N7v3rCJ;wnGO|TaCETStSk=6%?)q=t;Z`|t{+3JcYFvP{QfLY zZ#C!GS;lo?`H-+n7llHF+qwlorFdAbdm#pQ{Y^pGT2ExYvbO*E_6U8${xYM?<4gkF zJoXc}YKRbHgyrrff^1-Kho5f#UzP^_5Xkec$_+ z5JeiK96@pF$o9K@bL{%aQ)g=lk-%{`z=#T zeRbB}`|Rg=_QnjkGjH#IB-UCw-*k>5W+c&8C5=9hb@(;0ASb(zP1)a2>1X=US4Yh{ zDAM>%e8HZVT8JED3KJ)ov|fSl7e*Lqh*cHz)p02wzc@;0LS8&VhLA2@ugF6A~i%@e+~#E+&%`+bOds1U?M# zJ#71!m>sL9WxKmsR643W$?AEs$k(-|Hly*tKvz^LYiW11+MxMVID*N(G9oI9xvC;e zA!>7C&CpJT27uTo5r1%%XE%8J-Z2pP&UNMOc2e(gb^c}J0qS^nj+bA=z{6D$tCY{D zlY&vC*eSlYSpWFgf{u!9w|N-!-xNw64LY9yr%ouUCescJAgQVyotB|pT+R71jDuX@ zS<=r{HL0XLa}nJf|4gz4*VyLM>FmKm#X;sPuNh-n;#U(nyr-P6d&77v=G%(!Fzj@A`=eAoR`ZTd_0Y7hK--)_7k=> zQw~)X+iafjy;^JEp9x~XYBSXHv(ge}W;qyCMqfkL$WHiI+3`s?B}bve0Zi= z))z?ou8n%5gRwnUw4!q(R0B|t?4CwPGq1Z29 zJdsS1%N%O_=dlzB+Amf!64w1|tqI&FSKId$DW< zK@|F@-%;0<1DVL2yxU;L4KTx6f)MrnwGSG$RK(n+yu1T=_bs((Mz<-Jclycg&hGhs z5PPPu8WkiVIaSLrj&-ZWoGG2i^VWgo!n)fRR%y2UBiFI%D;n@e+4ZYF%|@&r2^Lb) zcfc-n-F`puy(-@o1<*`1*nORnOLFoeP+#&#MuW5Ae&ijbFqfJHFtITWWd3uq-kK7p zFNdJ`Q&(>%^BJE4Nd3Z?qVj#}8v3Eko(_<-Dz8XU{H>JsLUQV$wBlBf36|%NRO{3WgaGQPMmjYx5Js?(QO%e=KEpuRu@8-= zQJ9HXI~9L7%C8cQ(zVsVm4rSIxgqARIl4fpuEaaC(fN~9U>d^}&WdgwxoHiBSKl2M z?&{5G!t$0oy^q$&w`x%HqNoH337-Lh|EoS*X+4jVK~vIy7wICGD zZsu*yM>P-SzqJ*)DFf_!2e-y|XrNL3iyL3c~f z6If4=7A{XfIQCgN-ed189LHi~c*yOeiRSsgDU*V|pM z^cb)M(@Pw$H!SjU$L6fp?UXE=NpEzew(1^>b6A??&30yweL7q1TNhXyrF~e)o)yTa zUKezIQ2T7-QPNp;_0x;Tp&ua;718YS_cBcrhIyRDHZ?=K@kkM8G)N0STD@AS%ey)4 zzQ0VH>*U(}4}fD64qt@sQ!b@ac07FiA6W#AbAGr#Vlt2ZrM9Atm!Iqa?{7qIRm5H{5Jo4)5J{Rdd^>3W5?R@F!N~IKEiIBMXIkRVt(hv1NM-Nif z;#Z<2@paLzhy{A_-1$_*A|2Lx1-0lTwM!yu_JtS&6zbfa2`*id`L+8PVOAQbQmQG) z9sit`$h|dDmWMcB`M?-IG6*LB)Kv@!Xs)5-rmIwA+BwC;2n-ybums(Xkx*P~lj+9=3RIeAX0=LY7hfpY@*{GisgC#YKGu07Bn!TC*j7DVP;SG^;ww6ViHeT9<<%~G{ zu$jjpN}{n!y;RKeE@L8YB0{vTcbQ&hgS{;%a;ez3LNPK%^FxaPR<;81Q+aaM|DO!l zVf_L8+1uF^P3afrjgNoV`0>dX6deIA$zX=du61IV39_1-_?sA zcsAEaa;;uaYm{E~+4A+fAS}G*mq}430B~KhmSLVlYI3rQjtT}JYBbmq;G{5B(2Nih z6O$k+g=pV$uh4O~jHs6VtBZzA{ZQ{Y8z_-iYt$-HnsmOqOBNzcORUTZ*og^W;(G)= zOZ|7WP~9}2_Wp(MeE>yhE>m6{znz|dz>lOZ`~|do%~7LWQVnJ(JG(ThwoeRtM`Ws8 zr;@A1T%d$Ev;4KjHwdiJ~{gI3lSL%H< zgppWz-o_$QA=spAn8VKGjXbU-in>vf8*TdIBf|?tXw|5ZKhEdWh*ihyf8@#aipdU@*BXBId}r$>FHw z_Usu}Y2-PvrYm9$a(eNr4u*8B<(wLXHr)E(aq+W0_C#PDEL4d3aOeaDCg&l#Cq6G0 z!He8C(kb^)@PR&NB|&x{=CTX5r8eI4TKgl#xx%a$baseM(}GDJ|2PzDd#a+kb9lpeg8*dsDvQBnqM)4>h~W!)2jC7csdQD_^alUM(Te zZ(XBH_&+R?_@sdVEe0?*UaR|&C9LEr@a6k#yJus_cDZ7Z6bABgyHB2+KlMwSffpc=KL$n*tYIoHq< zn&7KVrdd305rXT~z{R8x3E{Lq&dfr%xXy$LGZj}Y>B6-h4+u6kn2J|p6xBL> z>gt+&54aZxDsIy@`0MyMwr%!ricn4au;~7-y9$_{7?nrd?F{wb{y|blNp2Io;*Vz~ zo>+9*y38(o8naPiOV;|-{q>7OOu&g?pNnY>+oWrC+1@JkqV_exBo*BAZ|!RV)z=wu zC@~)z&^0%EF_d=DD>{^ba9}De6>dRi;%3tQamKInacFq^ z*610sZPoK6I+73&ly2Ieb{_N}bI=6Y{jKb&?jGjH))2|Ho$FJ0Yt1q;s%bqAI4SE$ z%1eF5UxVff26w=rqsrj;{uJ-XBlAr2-k?;7NL-kve9Fl1nl4Sf0LA57KeI1W)PTZ7 ztcBv}qtEH)Zy}r-V07yHa0Y?6jFI~rpR1^%vB)F1$pGXptgFyTaD&OaDP%K3))sdfG!w0?c zPl?y@<+;Tj;h-(B>Q2rG(};M3t30*;wy5dv-x?c4R2F=|7|{nL2)2x<_(u-J~(G zPCazRa-lzKe+C7%w`v`cVMaYwkCLkmRW3ju4yNSVmQwsW%R(sq83xa#oqxz-QN_M zc9c%06u&jVp%yM>imvTHreF0&nQKBs!32IGn6zd^KIO^aLiZ zit1$Qag%}T5!u!-ZeZx!sx!4XV_I2SFMh=80`j|@t2rekaNj9xixgO3C-%Z6Qu6lu z=P9=ripQ0)zVvss)kjc8%g`_%Ej%hmAh7IluvI@uTIOLQKF&bxJT$tF{+@J4;BAs8 zPUhO3sOVp)9}hj-;`qe*k#1NUtisPDul}P)d%-{Nn2vTDi6%`tJls<>z_(lAHbynB zR@l`A%Iw-$<9DX_{C#L?`d2k=WmWBl!j_*P$N{O6;*bXQWKA=ZMA!x$E0bmD94~Y1 zhw1JzTh5Yb;lfPYW9=UqHnuD;ci6R;^xjK-)2)3Qu(;CSKQGTK>K5p;EK*Ww=epiv z_h!=6QnjgEV_`bKMK5u3FYX&Yc1K17+^vi%7#+Meu>FeD?o{d-Z7>TfE6-CFq+Al| znxURuT#rsD2cfJ+qdz2u+V^6vf@N$t=i0dPkAC?uP}?96iw7Gg<5Xy#S>6z zw``fxOW~2KY_g@RL7b|^21AIstKPa*%u`DfM#qQ4uqZbaAx^HixVRSRa{eqUe?s4A zCzhPOMR{SSAJcJyAbDM|daoU6{7|h48xv`W#0GkX_xG!ufiBv%0__T>Nqv4+RG*CI zk`v$M5+04^xF%sP7kH zsThD$X!yqCR{ez4zD8oD{)5&=-kI`3@g)^TE4x(Lma3UYfl42olkR5TvcEE`JmHYbc=6CC z!M|pEUhE0}tpGSAEaum`ZFrLnpD;M%wvNmzp<5CydfajvC?`u;Frl^9Y43(kl2oT6 ziC4k-U!?EVeO_td2_VM4`J3K0;g|m(?m`Vy(<5%~bM9*EAT?$sG7v&RU)$oGu=&+^p!_=Hswt%O{xxT#G zIPS$YYNAecXS&pqhyT?fVwxxZ3I*f2iy;`=q%=7UT=up8#MPR=u0*)ztcptRG@O`A zZ)czZfmOr)uh_lE8tyvDx$j`xWr_ZGIFl+CVxO5PL+_(;M`-W^*vOs(R+v)Dji)5h$>y$;~WOLe0)sFk4M~)&X_d%N{h@tIOlrZHt8K+Gm z(urV8m-`8ZO#bY?oACYP*G(u$6Fxp+6>tOux^Q?=JHODLXY zBNG?Hp?Pt?v!Wz#dS?~<`t?Mk?f3-U#*fqY4AEGC8L~8UHG{xy_x=l$FEYec&o6@G zk-5yAB2-ML@!8hUN58V>ikfa~nW>Nd%sI-A@DF}y^ok=+w1_|kLFvO|z9{3|J^p1A zc9ayWiixGtt~T`&g0WZ=2eC~{;&R^^Ovp?;KJ?oOJEmIrgODdjb@?|?UR?bZe5;T42>D$*%}#W zu70=FEG2a{b8+Cs0JyEy{90`HXJkVx&O6LASX@)sQ$gfS=dI-lljB)8Ye_aB2i#uH zLjudX)jXs8Yty1vaQo1Vk;aRxZr$SLU+M(JtrnE}jlS_|#s<#E#=~JAUTyxHtOG3)BWn@zY3@6W zP2QJt95EoLtmd}!5+9EaL`m%YEsY_hbL>2S> zj7>?N#NfWv2(E?3uUjK>GA@k0|M1SqWL)x#WX_&m;t^1Un)?5gT0RUir3gjaJV8OH vxS+Y4sy@`os_uSf9DzFHcxHm(|63k0SV(hYqWCBC0hB4qs>xJJn*{zJh9)q! literal 0 HcmV?d00001 diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml new file mode 100644 index 00000000..3292334a --- /dev/null +++ b/docs/users_guide/intro.xml @@ -0,0 +1,319 @@ + + + Introduction to GHC + + This is a guide to using the Glasgow Haskell Compiler (GHC): + an interactive and batch compilation system for the Haskell 98 + language. + + GHC has two main components: an interactive Haskell + interpreter (also known as GHCi), described in , and a batch compiler, described throughout . In fact, GHC consists of a single program + which is just run with different options to provide either the + interactive or the batch system. + + The batch compiler can be used alongside GHCi: compiled + modules can be loaded into an interactive session and used in the + same way as interpreted code, and in fact when using GHCi most of + the library code will be pre-compiled. This means you get the best + of both worlds: fast pre-compiled library code, and fast compile + turnaround for the parts of your program being actively + developed. + + GHC supports numerous language extensions, including + concurrency, a foreign function interface, exceptions, type system + extensions such as multi-parameter type classes, local universal and + existential quantification, functional dependencies, scoped type + variables and explicit unboxed types. These are all described in + . + + GHC has a comprehensive optimiser, so when you want to Really + Go For It (and you've got time to spare) GHC can produce pretty fast + code. Alternatively, the default option is to compile as fast as + possible while not making too much effort to optimise the generated + code (although GHC probably isn't what you'd describe as a fast + compiler :-). + + GHC's profiling system supports “cost centre + stacks”: a way of seeing the profile of a Haskell program in a + call-graph like structure. See for more + details. + + GHC comes with a number of libraries. These are + described in separate documentation. + + + Obtaining GHC + + Go to the GHC home + page and follow the "download" link to download GHC + for your platform. + + Alternatively, if you want to build GHC yourself, head on + over to the + GHC + Building Guide to find out how to get the sources, and + build it on your system. Note that GHC itself is written in + Haskell, so you will still need to install GHC in order to + build it. + + + + Meta-information: Web sites, mailing lists, etc. + + mailing lists, Glasgow Haskell + Glasgow Haskell mailing lists + + On the World-Wide Web, there are several URLs of likely + interest: + + + + GHC home + page + + + + GHC + Developers Home (developer documentation, wiki, and + bug tracker) + + + + We run the following mailing lists about GHC. + We encourage you to join, as you feel is appropriate. + + + + glasgow-haskell-users: + + This list is for GHC users to chat among themselves. + If you have a specific question about GHC, please check the + FAQ + first. + + + + list email address: + + glasgow-haskell-users@haskell.org + + + + + subscribe at: + + http://www.haskell.org/mailman/listinfo/glasgow-haskell-users. + + + + + admin email address: + + glasgow-haskell-users-admin@haskell.org + + + + + list archives: + + http://www.haskell.org/pipermail/glasgow-haskell-users/ + + + + + + + + ghc-devs: + + The hardcore GHC developers hang out here. + + + + list email address: + + ghc-devs@haskell.org + + + + + subscribe at: + + http://www.haskell.org/mailman/listinfo/ghc-devs. + + + + + admin email address: + + ghc-devs-admin@haskell.org + + + + + list archives: + + http://www.haskell.org/pipermail/ghc-devs/ + + + + + + + + There are several other haskell and GHC-related mailing + lists served by www.haskell.org. Go to http://www.haskell.org/mailman/listinfo/ + for the full list. + + Some Haskell-related discussion also takes place in the + Usenet newsgroup comp.lang.functional. + + + + + Reporting bugs in GHC + bugsreporting + + reporting bugs + + + + Glasgow Haskell is a changing system so there are sure to be + bugs in it. If you find one, please see + this wiki page + for information on how to report it. + + + + + + GHC version numbering policy + version, of ghc + + As of GHC version 6.8, we have adopted the following policy + for numbering GHC versions: + + + + Stable Releases + + Stable branches are numbered x.y, where + y is even. + Releases on the stable branch x.y are numbered x.y.z, where + z (>= 1) is the patchlevel number. + Patchlevels are bug-fix releases only, and never + change the programmer interface to any system-supplied code. + However, if you install a new patchlevel over an old one you + will need to recompile any code that was compiled against the + old libraries. + + The value of __GLASGOW_HASKELL__ + (see ) for a major release + x.y.z + is the integer xyy (if + y is a single digit, then a leading zero + is added, so for example in version 6.8.2 of GHC we would have + __GLASGOW_HASKELL__==608). + + __GLASGOW_HASKELL__ + + + + + + Stable snapshots + + + We may make snapshot releases of the current stable branch available for + download, and the latest sources are available from the git + repositories. + + + Stable snapshot releases are named + x.y.z.YYYYMMDD. + where YYYYMMDD is the date of the sources + from which the snapshot was built, and x.y.z+1 is the next release to be made on that branch. + For example, 6.8.1.20040225 would be a + snapshot of the 6.8 branch during the development + of 6.8.2. + + The value of __GLASGOW_HASKELL__ + for a snapshot release is the integer + xyy. You should never write any + conditional code which tests for this value, however: since + interfaces change on a day-to-day basis, and we don't have + finer granularity in the values of + __GLASGOW_HASKELL__, you should only + conditionally compile using predicates which test whether + __GLASGOW_HASKELL__ is equal to, later + than, or earlier than a given major release. + + __GLASGOW_HASKELL__ + + + + + + Unstable snapshots + + + We may make snapshot releases of the HEAD available for + download, and the latest sources are available from the git + repositories. + + + Unstable snapshot releases are named + x.y.YYYYMMDD. + where YYYYMMDD is the date of the sources + from which the snapshot was built. + For example, 6.7.20040225 would be a + snapshot of the HEAD before the creation of the + 6.8 branch. + + The value of __GLASGOW_HASKELL__ + for a snapshot release is the integer + xyy. You should never write any + conditional code which tests for this value, however: since + interfaces change on a day-to-day basis, and we don't have + finer granularity in the values of + __GLASGOW_HASKELL__, you should only + conditionally compile using predicates which test whether + __GLASGOW_HASKELL__ is equal to, later + than, or earlier than a given major release. + + __GLASGOW_HASKELL__ + + + + + + The version number of your copy of GHC can be found by + invoking ghc with the + --version flag (see ). + + + +&relnotes1; +&relnotes2; + + + + diff --git a/docs/users_guide/lang.xml b/docs/users_guide/lang.xml new file mode 100644 index 00000000..95f70894 --- /dev/null +++ b/docs/users_guide/lang.xml @@ -0,0 +1,15 @@ + + +GHC Language Features + +&glasgowexts; +∥ +&safehaskell; + + + + diff --git a/docs/users_guide/license.xml b/docs/users_guide/license.xml new file mode 100644 index 00000000..19f928dd --- /dev/null +++ b/docs/users_guide/license.xml @@ -0,0 +1,65 @@ + + +The Glasgow Haskell Compiler License + + +Copyright 2002 - 2007, The University Court of the University of Glasgow. +All rights reserved. + + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + + + + + + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + + + + + +Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + + + + + +Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + + + + + + + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + + + + + diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml new file mode 100644 index 00000000..1c92defc --- /dev/null +++ b/docs/users_guide/packages.xml @@ -0,0 +1,1907 @@ + + + +Packages + + packages + + A package is a library of Haskell modules known to the + compiler. GHC comes with several packages: see the accompanying + library + documentation. More packages to install can be obtained + from HackageDB. + + Using a package couldn't be simpler: if you're using + or GHCi, then most of the installed packages will be + automatically available to your program without any further options. The + exceptions to this rule are covered below in . + + Building your own packages is also quite straightforward: we provide + the Cabal infrastructure which + automates the process of configuring, building, installing and distributing + a package. All you need to do is write a simple configuration file, put a + few files in the right places, and you have a package. See the + Cabal documentation + for details, and also the Cabal libraries (Distribution.Simple, + for example). + + + Using Packages + + packages + using + + GHC only knows about packages that are + installed. To see which packages are installed, use + the ghc-pkg list command: + + +$ ghc-pkg list +/usr/lib/ghc-6.12.1/package.conf.d: + Cabal-1.7.4 + array-0.2.0.1 + base-3.0.3.0 + base-4.2.0.0 + bin-package-db-0.0.0.0 + binary-0.5.0.1 + bytestring-0.9.1.4 + containers-0.2.0.1 + directory-1.0.0.2 + (dph-base-0.4.0) + (dph-par-0.4.0) + (dph-prim-interface-0.4.0) + (dph-prim-par-0.4.0) + (dph-prim-seq-0.4.0) + (dph-seq-0.4.0) + extensible-exceptions-0.1.1.0 + ffi-1.0 + filepath-1.1.0.1 + (ghc-6.12.1) + ghc-prim-0.1.0.0 + haskeline-0.6.2 + haskell98-1.0.1.0 + hpc-0.5.0.2 + integer-gmp-0.1.0.0 + mtl-1.1.0.2 + old-locale-1.0.0.1 + old-time-1.0.0.1 + pretty-1.0.1.0 + process-1.0.1.1 + random-1.0.0.1 + rts-1.0 + syb-0.1.0.0 + template-haskell-2.4.0.0 + terminfo-0.3.1 + time-1.1.4 + unix-2.3.1.0 + utf8-string-0.3.4 + + + An installed package is either exposed + or hidden by default. Packages hidden by + default are listed in parentheses + (eg. (lang-1.0)), or possibly in blue if your + terminal supports colour, in the output of ghc-pkg + list. Command-line flags, described below, allow you + to expose a hidden package or hide an exposed one. Only modules + from exposed packages may be imported by your Haskell code; if + you try to import a module from a hidden package, GHC will emit + an error message. If there are a multiple exposed versions of a package, + GHC will prefer the latest one. Additionally, some packages may be + broken: that is, they are missing from the package database, or one of + their dependencies are broken; in this case; these packages are excluded + from the default set of packages. + + + + Note: if you're using Cabal, then the exposed or hidden status + of a package is irrelevant: the available packages are instead + determined by the dependencies listed in + your .cabal specification. The + exposed/hidden status of packages is only relevant when + using ghc or ghci + directly. + + + Similar to a package's hidden status is a package's trusted + status. A package can be either trusted or not trusted (distrusted). + By default packages are distrusted. This property of a package only + plays a role when compiling code using GHC's Safe Haskell feature + (see ) with the + flag enabled. + + + To see which modules are provided by a package use the + ghc-pkg command (see ): + + +$ ghc-pkg field network exposed-modules +exposed-modules: Network.BSD, + Network.CGI, + Network.Socket, + Network.URI, + Network + + + The GHC command line options that control packages are: + + + + + + + + + This option causes the installed + package P to be exposed. The + package P can be specified in + full with its version number + (e.g. network-1.0) or the version + number can be omitted if there is only one version of the + package installed. If there are multiple versions + of P installed and + was not specified, then all + other versions will become hidden. + supports thinning and renaming described in . + + The + option also causes package P to + be linked into the resulting executable or shared + object. Whether a packages' library is linked statically + or dynamically is controlled by the flag + pair /. + + In mode + and mode (see + ), the compiler normally + determines which packages are required by the current + Haskell modules, and links only those. In batch mode + however, the dependency information isn't available, and + explicit + options must be given when linking. The one other time you might need to use + to force linking a package is + when the package does not contain any Haskell modules (it + might contain a C library only, for example). In that + case, GHC will never discover a dependency on it, so it + has to be mentioned explicitly. + + For example, to link a program consisting of objects + Foo.o and Main.o, where + we made use of the network package, we need to + give GHC the -package flag thus: + +$ ghc -o myprog Foo.o Main.o -package network + + The same flag is necessary even if we compiled the modules from + source, because GHC still reckons it's in batch mode: + +$ ghc -o myprog Foo.hs Main.hs -package network + + + + + + + + + + + Exposes a package like , but the + package is named by its installed package ID rather than by name. This is a + more robust way to name packages, and can be used to + select packages that would otherwise be shadowed. Cabal + passes flags to GHC. + supports thinning and renaming + described in . + + + + + + + + + + Ignore the exposed flag on installed packages, and hide them + all by default. If you use + this flag, then any packages you require (including + base) need to be explicitly exposed using + options. + + This is a good way to insulate your program from + differences in the globally exposed packages, and being + explicit about package dependencies is a Good Thing. + Cabal always passes the + flag to GHC, for + exactly this reason. + + + + + P + + + + This option does the opposite of : it + causes the specified package to be hidden, + which means that none of its modules will be available for import + by Haskell import directives. + + Note that the package might still end up being linked into the + final program, if it is a dependency (direct or indirect) of + another exposed package. + + + + + P + + + + Causes the compiler to behave as if package + P, and any packages that depend on + P, are not installed at all. + + Saying -ignore-package P is the same as + giving -hide-package flags for + P and all the packages that depend on + P. Sometimes we don't know ahead of time which + packages will be installed that depend on P, + which is when the -ignore-package flag can be + useful. + + + + + + + + + By default, GHC will automatically link in the + base and rts packages. + This flag disables that behaviour. + + + + + foo + + + + Tells GHC the the module being compiled forms part of + package key foo; internally, these + keys are used to determine type equality and linker symbols. + If this flag is omitted (a very common case) then the + default package main is assumed. + + + + + P + + + + This option causes the install package P + to be both exposed and trusted by GHC. This + command functions in the in a very similar way to the command but in addition sets the selected + packaged to be trusted by GHC, regardless of the contents of + the package database. (see ). + + + + + + P + + + + This option causes the install package P + to be both exposed and distrusted by GHC. This + command functions in the in a very similar way to the command but in addition sets the selected + packaged to be distrusted by GHC, regardless of the contents of + the package database. (see ). + + + + + + + + + + Ignore the trusted flag on installed packages, and distrust + them by default. If you use this flag and Safe Haskell then any + packages you require to be trusted (including base + ) need to be explicitly trusted using options. This option does not change the exposed/hidden + status of a package, so it isn't equivalent to applying to all packages on the system. (see + ). + + + + + + + + The main package + + Every complete Haskell program must define main in + module Main + in package main. (Omitting the flag compiles + code for package main.) Failure to do so leads to a somewhat obscure + link-time error of the form: + +/usr/bin/ld: Undefined symbols: +_ZCMain_main_closure + + + + + + + Consequences of packages for the Haskell language + + It is possible that by using packages you might end up with + a program that contains two modules with the same name: perhaps + you used a package P that has a hidden module + M, and there is also a module M in your program. Or perhaps the + dependencies of packages that you used contain some overlapping + modules. Perhaps the program even contains multiple versions of a + certain package, due to dependencies from other packages. + + None of these scenarios gives rise to an error on its + ownit used to in GHC 6.4, but not since + 6.6, but they may have some interesting + consequences. For instance, if you have a type + M.T from version 1 of package + P, then this is not the + same as the type M.T from version 2 of package + P, and GHC will report an error if you try to + use one where the other is expected. + + Formally speaking, in Haskell 98, an entity (function, type + or class) in a program is uniquely identified by the pair of the + module name in which it is defined and its name. In GHC, an + entity is uniquely defined by a triple: package, module, and + name. + + + + Thinning and renaming modules + + When incorporating packages from multiple sources, you may end up + in a situation where multiple packages publish modules with the same name. + Previously, the only way to distinguish between these modules was to + use . However, since GHC 7.10, + the flags (and their variants) have been extended + to allow a user to explicitly control what modules a package brings into + scope, by analogy to the import lists that users can attach to module imports. + + + + The basic syntax is that instead of specifying a package name P to the package + flag -package, instead we specify both a package name and a + parenthesized, comma-separated list of module names to import. For example, + -package "base (Data.List, Data.Bool)" makes only + Data.List and Data.Bool visible from + package base. We also support renaming of modules, in case + you need to refer to both modules simultaneously; this is supporting by + writing OldModName as NewModName, e.g. -package + "base (Data.Bool as Bool). You can also write -package + "base with (Data.Bool as Bool) to include all of the original + bindings (e.g. the renaming is strictly additive). It's important to specify + quotes so that your shell passes the package name and thinning/renaming list + as a single argument to GHC. + + Package imports with thinning/renaming do not hide other versions of the + package: e.g. if containers-0.9 is already exposed, -package + "containers-0.8 (Data.List as ListV8)" will only add an additional + binding to the environment. Similarly, -package "base (Data.Bool as + Bool)" -package "base (Data.List as List)" is equivalent to + -package "base (Data.Bool as Bool, Data.List as List)". + Literal names must refer to modules defined by the original package, so for + example -package "base (Data.Bool as Bool, Bool as Baz)" is + invalid unless there was a Bool module defined in the + original package. Hiding a package also clears all of its renamings. + + + You can use renaming to provide an alternate prelude, e.g. + -hide-all-packages -package "basic-prelude (BasicPrelude as + Prelude)", in lieu of the NoImplicitPrelude extension. + + + + + + Package Databases + + + A package database is where the details about installed packages + are stored. It is a directory, usually + called package.conf.d, that contains a file + for each package, together with a binary cache of the package + data in the file package.cache. Normally + you won't need to look at or modify the contents of a package + database directly; all management of package databases can be + done through the ghc-pkg tool (see + ). + + + + GHC knows about two package databases in particular: + + + + + The global package database, which comes with your GHC + installation, + e.g. /usr/lib/ghc-6.12.1/package.conf.d. + + + A package database private to each user. On Unix + systems this will be + $HOME/.ghc/arch-os-version/package.conf.d, and on + Windows it will be something like + C:\Documents And Settings\user\ghc\package.conf.d. + The ghc-pkg tool knows where this file should be + located, and will create it if it doesn't exist (see ). + + + + When GHC starts up, it reads the contents of these two package + databases, and builds up a list of the packages it knows about. You can + see GHC's package table by running GHC with the + flag. + + Package databases may overlap, and they are arranged in a stack + structure. Packages closer to the top of the stack will override + (shadow) those below them. By default, the stack + contains just the global and the user's package databases, in that + order. + + You can control GHC's package database stack using the following + options: + + + + + + + + + Add the package database file on top + of the current stack. Packages in additional databases read this + way will override those in the initial stack and those in + previously specified databases. + + + + + + + + + + Remove the global package database from the package database + stack. + + + + + + + + + + Prevent loading of the user's local package database in the + initial stack. + + + + + + + + + + Reset the current package database stack. This option removes + every previously specified package database (including those + read from the GHC_PACKAGE_PATH environment + variable) from the package database stack. + + + + + + + + + + Add the global package database on top of the current stack. + This option can be used after + -no-global-package-db to specify the position in + the stack where the global package database should be + loaded. + + + + + + + + + + Add the user's package database on top of the current stack. + This option can be used after + -no-user-package-db to specify the position in + the stack where the user's package database should be + loaded. + + + + + + The <literal>GHC_PACKAGE_PATH</literal> environment variable + Environment variableGHC_PACKAGE_PATH + + GHC_PACKAGE_PATH + The GHC_PACKAGE_PATH environment variable may be + set to a :-separated (;-separated + on Windows) list of files containing package databases. This list of + package databases is used by GHC and ghc-pkg, with earlier databases in + the list overriding later ones. This order was chosen to match the + behaviour of the PATH environment variable; think of + it as a list of package databases that are searched left-to-right for + packages. + + If GHC_PACKAGE_PATH ends in a separator, then + the default package database stack (i.e. the user and global + package databases, in that order) is appended. For example, to augment + the usual set of packages with a database of your own, you could say + (on Unix): + + $ export GHC_PACKAGE_PATH=$HOME/.my-ghc-packages.conf: + + (use ; instead of : on + Windows). + + To check whether your GHC_PACKAGE_PATH setting + is doing the right thing, ghc-pkg list will list all + the databases in use, in the reverse order they are searched. + + + + + + Installed package IDs, dependencies, and broken packages + + Each installed package has a unique identifier (the + “installed package ID”), which distinguishes it from all other + installed packages on the system. To see the installed package IDs + associated with each installed package, use ghc-pkg + list -v: + + +$ ghc-pkg list -v +using cache: /usr/lib/ghc-6.12.1/package.conf.d/package.cache +/usr/lib/ghc-6.12.1/package.conf.d + Cabal-1.7.4 (Cabal-1.7.4-48f5247e06853af93593883240e11238) + array-0.2.0.1 (array-0.2.0.1-9cbf76a576b6ee9c1f880cf171a0928d) + base-3.0.3.0 (base-3.0.3.0-6cbb157b9ae852096266e113b8fac4a2) + base-4.2.0.0 (base-4.2.0.0-247bb20cde37c3ef4093ee124e04bc1c) + ... + + + + The string in parentheses after the package name is the installed package + ID: it normally begins with the package name and version, and + ends in a hash string derived from the compiled package. + Dependencies between packages are expressed in terms of installed package + IDs, rather than just packages and versions. For example, take + a look at the dependencies of the haskell98 + package: + + + +$ ghc-pkg field haskell98 depends +depends: array-0.2.0.1-9cbf76a576b6ee9c1f880cf171a0928d + base-4.2.0.0-247bb20cde37c3ef4093ee124e04bc1c + directory-1.0.0.2-f51711bc872c35ce4a453aa19c799008 + old-locale-1.0.0.1-d17c9777c8ee53a0d459734e27f2b8e9 + old-time-1.0.0.1-1c0d8ea38056e5087ef1e75cb0d139d1 + process-1.0.1.1-d8fc6d3baf44678a29b9d59ca0ad5780 + random-1.0.0.1-423d08c90f004795fd10e60384ce6561 + + + + The purpose of the installed package ID is to detect problems caused by + re-installing a package without also recompiling the packages + that depend on it. Recompiling dependencies is necessary, + because the newly compiled package may have a different ABI + (Application Binary Interface) than the previous version, even + if both packages were built from the same source code using the + same compiler. With installed package IDs, a recompiled + package will have a different installed package ID from the previous + version, so packages that depended on the previous version are + now orphaned - one of their dependencies is not satisfied. + Packages that are broken in this way are shown in + the ghc-pkg list output either in red (if + possible) or otherwise surrounded by braces. In the following + example, we have recompiled and reinstalled + the filepath package, and this has caused + various dependencies including Cabal to + break: + + +$ ghc-pkg list +WARNING: there are broken packages. Run 'ghc-pkg check' for more details. +/usr/lib/ghc-6.12.1/package.conf.d: + {Cabal-1.7.4} + array-0.2.0.1 + base-3.0.3.0 + ... etc ... + + + + Additionally, ghc-pkg list reminds you that + there are broken packages and suggests ghc-pkg + check, which displays more information about the + nature of the failure: + + + +$ ghc-pkg check +There are problems in package ghc-6.12.1: + dependency "filepath-1.1.0.1-87511764eb0af2bce4db05e702750e63" doesn't exist +There are problems in package haskeline-0.6.2: + dependency "filepath-1.1.0.1-87511764eb0af2bce4db05e702750e63" doesn't exist +There are problems in package Cabal-1.7.4: + dependency "filepath-1.1.0.1-87511764eb0af2bce4db05e702750e63" doesn't exist +There are problems in package process-1.0.1.1: + dependency "filepath-1.1.0.1-87511764eb0af2bce4db05e702750e63" doesn't exist +There are problems in package directory-1.0.0.2: + dependency "filepath-1.1.0.1-87511764eb0af2bce4db05e702750e63" doesn't exist + +The following packages are broken, either because they have a problem +listed above, or because they depend on a broken package. +ghc-6.12.1 +haskeline-0.6.2 +Cabal-1.7.4 +process-1.0.1.1 +directory-1.0.0.2 +bin-package-db-0.0.0.0 +hpc-0.5.0.2 +haskell98-1.0.1.0 + + + + To fix the problem, you need to recompile the broken packages + against the new dependencies. The easiest way to do this is to + use cabal-install, or download the packages + from HackageDB + and build and install them as normal. + + Be careful not to recompile any packages that GHC itself + depends on, as this may render the ghc + package itself broken, and ghc cannot be + simply recompiled. The only way to recover from this would be + to re-install GHC. + + + + Package management (the <literal>ghc-pkg</literal> command) + packages + management + + The ghc-pkg tool is for querying and + modifying package databases. To see what package databases are + in use, use + ghc-pkg list. The stack of databases that + ghc-pkg knows about can be modified using the + GHC_PACKAGE_PATH environment variable (see , and using + --package-db options on the + ghc-pkg command line. + + When asked to modify a database, ghc-pkg modifies + the global database by default. Specifying + causes it to act on the user database, or + can be used to act on another database entirely. When multiple of these + options are given, the rightmost one is used as the database to act + upon. + + Commands that query the package database (list, latest, + describe, field, dot) operate on the list of databases specified by + the flags , , and + . If none of these flags are + given, the default is + . + + If the environment variable GHC_PACKAGE_PATH is + set, and its value does not end in a separator (: on + Unix, ; on Windows), then the last database is + considered to be the global database, and will be modified by default by + ghc-pkg. The intention here is that + GHC_PACKAGE_PATH can be used to create a virtual + package environment into which Cabal packages can be installed without + setting anything other than GHC_PACKAGE_PATH. + + The ghc-pkg program may be run in the ways listed + below. Where a package name is required, the package can be named in + full including the version number + (e.g. network-1.0), or without the version number. + Naming a package without the version number matches all versions of the + package; the specified action will be applied to all the matching + packages. A package specifier that matches all version of the package + can also be written pkg-*, + to make it clearer that multiple packages are being matched. To match + against the installed package ID instead of just package name and version, + pass the flag. + + + + ghc-pkg init path + + Creates a new, empty, package database + at path, which must not already + exist. + + + + + ghc-pkg register file + + Reads a package specification from + file (which may be “-” + to indicate standard input), + and adds it to the database of installed packages. The syntax of + file is given in . + + The package specification must be a package that isn't already + installed. + + + + + ghc-pkg update file + + The same as register, except that if a + package of the same name is already installed, it is + replaced by the new one. + + + + + ghc-pkg unregister P + + Remove the specified package from the database. + + + + + ghc-pkg check + + Check consistency of dependencies in the package + database, and report packages that have missing + dependencies. + + + + + ghc-pkg expose P + + Sets the exposed flag for package + P to True. + + + + + ghc-pkg hide P + + Sets the exposed flag for package + P to False. + + + + + ghc-pkg trust P + + Sets the trusted flag for package + P to True. + + + + + ghc-pkg distrust P + + Sets the trusted flag for package + P to False. + + + + + ghc-pkg list [P] [] + + This option displays the currently installed + packages, for each of the databases known to + ghc-pkg. That includes the global database, the + user's local database, and any further files specified using the + option on the command line. + + Hidden packages (those for which the exposed + flag is False) are shown in parentheses in the + list of packages. + + If an optional package identifier P + is given, then only packages matching that identifier are + shown. + + If the option is given, then + the packages are listed on a single line separated by spaces, and + the database names are not included. This is intended to make it + easier to parse the output of ghc-pkg list using + a script. + + + + + ghc-pkg find-module M [] + + This option lists registered packages exposing module + M. Examples: + +$ ghc-pkg find-module Var +c:/fptools/validate/ghc/driver/package.conf.inplace: + (ghc-6.9.20080428) + +$ ghc-pkg find-module Data.Sequence +c:/fptools/validate/ghc/driver/package.conf.inplace: + containers-0.1 + + Otherwise, it behaves like ghc-pkg list, + including options. + + + + + + ghc-pkg latest P + + Prints the latest available version of package + P. + + + + + ghc-pkg describe P + + Emit the full description of the specified package. The + description is in the form of an + InstalledPackageInfo, the same as the input file + format for ghc-pkg register. See for details. + + If the pattern matches multiple packages, the + description for each package is emitted, separated by the + string --- on a line by itself. + + + + + ghc-pkg field P field[,field]* + + Show just a single field of the installed package description + for P. Multiple fields can be selected by separating + them with commas + + + + + ghc-pkg dot + + + Generate a graph of the package dependencies in a form + suitable for input for the graphviz tools. For example, + to generate a PDF of the dependency graph: + +ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf + + + + + + ghc-pkg dump + + Emit the full description of every package, in the + form of an InstalledPackageInfo. + Multiple package descriptions are separated by the + string --- on a line by itself. + + This is almost the same as ghc-pkg describe '*', except that ghc-pkg dump + is intended for use by tools that parse the results, so + for example where ghc-pkg describe '*' + will emit an error if it can't find any packages that + match the pattern, ghc-pkg dump will + simply emit nothing. + + + + + ghc-pkg recache + + + Re-creates the binary cache + file package.cache for the selected + database. This may be necessary if the cache has somehow + become out-of-sync with the contents of the database + (ghc-pkg will warn you if this might be + the case). + + + The other time when ghc-pkg recache is + useful is for registering packages manually: it is + possible to register a package by simply putting the + appropriate file in the package database directory and + invoking ghc-pkg recache to update the + cache. This method of registering packages may be more + convenient for automated packaging systems. + + + + + + + Substring matching is supported for M in + find-module and for P in + list, describe, and + field, where a '*' indicates open + substring ends (prefix*, *suffix, + *infix*). Examples (output omitted): + + + -- list all regex-related packages + ghc-pkg list '*regex*' --ignore-case + -- list all string-related packages + ghc-pkg list '*string*' --ignore-case + -- list OpenGL-related packages + ghc-pkg list '*gl*' --ignore-case + -- list packages exporting modules in the Data hierarchy + ghc-pkg find-module 'Data.*' + -- list packages exporting Monad modules + ghc-pkg find-module '*Monad*' + -- list names and maintainers for all packages + ghc-pkg field '*' name,maintainer + -- list location of haddock htmls for all packages + ghc-pkg field '*' haddock-html + -- dump the whole database + ghc-pkg describe '*' + + + Additionally, the following flags are accepted by + ghc-pkg: + + + + + file + + + + + file + + + + + Adds file to the stack of package + databases. Additionally, file will + also be the database modified by a register, + unregister, expose or + hide command, unless it is overridden by a later + , or + option. + + + + + + + + + + + + Causes ghc-pkg to ignore missing + dependencies, directories and libraries when registering a package, + and just go ahead and add it anyway. This might be useful if your + package installation system needs to add the package to + GHC before building and installing the files. + + + + + + + + + + Operate on the global package database (this is the default). + This flag affects the register, + update, unregister, + expose, and hide + commands. + + + + + + + + + + + + + + Outputs the command-line syntax. + + + + + + + + + + Operate on the current user's local package database. + This flag affects the register, + update, unregister, + expose, and hide + commands. + + + + + + nghc-pkg + option + + + =nghc-pkg option + + + + Control verbosity. Verbosity levels range from 0-2, where + the default is 1, and alone selects + level 2. + + + + + + + + + + + + + + + Output the ghc-pkg version number. + + + + + + + + + + + + Causes ghc-pkg to interpret arguments + as installed package IDs (e.g., an identifier like + unix-2.3.1.0-de7803f1a8cd88d2161b29b083c94240 + ). This is useful if providing just the package + name and version are ambiguous (in old versions of GHC, this + was guaranteed to be unique, but this invariant no longer + necessarily holds). + + + + + + + Building a package from Haskell source + packages + building + + We don't recommend building packages the hard way. Instead, use the + Cabal infrastructure + if possible. If your package is particularly complicated or requires a + lot of configuration, then you might have to fall back to the low-level + mechanisms, so a few hints for those brave souls follow. + + You need to build an "installed package info" file for + passing to ghc-pkg when installing your + package. The contents of this file are described in + . + + The Haskell code in a package may be built into one or more + archive libraries (e.g. libHSfoo.a), or a + single shared object + (e.g. libHSfoo.dll/.so/.dylib). The + restriction to a single shared object is because the package + system is used to tell the compiler when it should make an + inter-shared-object call rather than an intra-shared-object-call + call (inter-shared-object calls require an extra + indirection). + + Building a static library is done by using the + ar tool, like so: + +ar cqs libHSfoo-1.0.a A.o B.o C.o ... + + where A.o, + B.o and so on are the compiled Haskell + modules, and libHSfoo.a is the library you + wish to create. The syntax may differ slightly on your system, + so check the documentation if you run into difficulties. + + + To load a package foo, GHCi can load + its libHSfoo.a library directly, but it + can also load a package in the form of a + single HSfoo.o file that has been + pre-linked. Loading the .o file is + slightly quicker, but at the expense of having another copy + of the compiled package. The rule of thumb is that if the + modules of the package were compiled + with then building + the HSfoo.o is worthwhile because it + saves time when loading the package into GHCi. + Without , there is not much + difference in load time between the .o + and .a libraries, so it is better to save + the disk space and only keep the .a + around. In a GHC distribution we + provide .o files for most packages except + the GHC package itself. + + + The HSfoo.o file is built by Cabal + automatically; + use to disable + it. To build one manually, the following + GNU ld command can be used: + +ld -r --whole-archive -o HSfoo.o libHSfoo.a + + (replace + --whole-archive with + -all_load on MacOS X) + + + When building the package as shared library, GHC can be used to + perform the link step. This hides some of the details + out the underlying linker and provides a common + interface to all shared object variants that are supported + by GHC (DLLs, ELF DSOs, and Mac OS dylibs). The shared + object must be named in specific way for two reasons: (1) + the name must contain the GHC compiler version, so that two + library variants don't collide that are compiled by + different versions of GHC and that therefore are most likely + incompatible with respect to calling conventions, (2) it + must be different from the static name otherwise we would + not be able to control the linker as precisely as necessary + to make + the / flags + work, see . + +ghc -shared libHSfoo-1.0-ghcGHCVersion.so A.o B.o C.o + Using GHC's version number in the shared object name + allows different library versions compiled by different GHC + versions to be installed in standard system locations, + e.g. under *nix /usr/lib. To obtain the version number of + GHC invoke ghc --numeric-version and use + its output in place + of GHCVersion. See also + on how object files must + be prepared for shared object linking. + + + + To compile a module which is to be part of a new package, + use the -this-package-key option (). + Failure to use the -this-package-key option + when compiling a package will probably result in disaster, but + you will only discover later when you attempt to import modules + from the package. At this point GHC will complain that the + package name it was expecting the module to come from is not the + same as the package name stored in the .hi + file. + + It is worth noting with shared objects, when each package + is built as a single shared object file, since a reference to a shared object costs an extra + indirection, intra-package references are cheaper than + inter-package references. Of course, this applies to the + main package as well. + + + + + <literal>InstalledPackageInfo</literal>: a package specification + + + A package specification is a Haskell record; in particular, it is the + record InstalledPackageInfo in the module Distribution.InstalledPackageInfo, which is part of the Cabal package distributed with GHC. + + An InstalledPackageInfo has a human + readable/writable syntax. The functions + parseInstalledPackageInfo and + showInstalledPackageInfo read and write this syntax + respectively. Here's an example of the + InstalledPackageInfo for the unix package: + + +$ ghc-pkg describe unix +name: unix +version: 2.3.1.0 +id: unix-2.3.1.0-de7803f1a8cd88d2161b29b083c94240 +license: BSD3 +copyright: +maintainer: libraries@haskell.org +stability: +homepage: +package-url: +description: This package gives you access to the set of operating system + services standardised by POSIX 1003.1b (or the IEEE Portable + Operating System Interface for Computing Environments - + IEEE Std. 1003.1). + . + The package is not supported under Windows (except under Cygwin). +category: System +author: +exposed: True +exposed-modules: System.Posix System.Posix.DynamicLinker.Module + System.Posix.DynamicLinker.Prim System.Posix.Directory + System.Posix.DynamicLinker System.Posix.Env System.Posix.Error + System.Posix.Files System.Posix.IO System.Posix.Process + System.Posix.Process.Internals System.Posix.Resource + System.Posix.Temp System.Posix.Terminal System.Posix.Time + System.Posix.Unistd System.Posix.User System.Posix.Signals + System.Posix.Signals.Exts System.Posix.Semaphore + System.Posix.SharedMem +hidden-modules: +trusted: False +import-dirs: /usr/lib/ghc-6.12.1/unix-2.3.1.0 +library-dirs: /usr/lib/ghc-6.12.1/unix-2.3.1.0 +hs-libraries: HSunix-2.3.1.0 +extra-libraries: rt util dl +extra-ghci-libraries: +include-dirs: /usr/lib/ghc-6.12.1/unix-2.3.1.0/include +includes: HsUnix.h execvpe.h +depends: base-4.2.0.0-247bb20cde37c3ef4093ee124e04bc1c +hugs-options: +cc-options: +ld-options: +framework-dirs: +frameworks: +haddock-interfaces: /usr/share/doc/ghc/html/libraries/unix/unix.haddock +haddock-html: /usr/share/doc/ghc/html/libraries/unix + + + Here is a brief description of the syntax of this file: + + A package description consists of a number of field/value pairs. A + field starts with the field name in the left-hand column followed by a + “:”, and the value continues until the next line that begins in the + left-hand column, or the end of file. + + The syntax of the value depends on the field. The various field + types are: + + + + freeform + + Any arbitrary string, no interpretation or parsing is + done. + + + + string + + A sequence of non-space characters, or a sequence of arbitrary + characters surrounded by quotes "....". + + + + string list + + A sequence of strings, separated by commas. The sequence may + be empty. + + + + + In addition, there are some fields with special syntax (e.g. package + names, version, dependencies). + + The allowed fields, with their types, are: + + + + + name + namepackage specification + + + The package's name (without the version). + + + + + + id + idpackage specification + + + The installed package ID. It is up to you to choose a suitable + one. + + + + + + version + versionpackage specification + + + The package's version, usually in the form + A.B (any number of components are allowed). + + + + + + license + autopackage specification + + + (string) The type of license under which this package is distributed. + This field is a value of the License type. + + + + + + license-file + license-filepackage specification + + + (optional string) The name of a file giving detailed license + information for this package. + + + + + + copyright + copyrightpackage specification + + + (optional freeform) The copyright string. + + + + + + maintainer + maintainerpackage specification + + + (optional freeform) The email address of the package's maintainer. + + + + + + stability + stabilitypackage specification + + + (optional freeform) A string describing the stability of the package + (eg. stable, provisional or experimental). + + + + + + homepage + homepagepackage specification + + + (optional freeform) URL of the package's home page. + + + + + + package-url + package-urlpackage specification + + + (optional freeform) URL of a downloadable distribution for this + package. The distribution should be a Cabal package. + + + + + + description + descriptionpackage specification + + + (optional freeform) Description of the package. + + + + + + category + categorypackage specification + + + (optional freeform) Which category the package belongs to. This field + is for use in conjunction with a future centralised package + distribution framework, tentatively titled Hackage. + + + + + + author + authorpackage specification + + + (optional freeform) Author of the package. + + + + + + exposed + exposedpackage specification + + + (bool) Whether the package is exposed or not. + + + + + + exposed-modules + exposed-modulespackage specification + + + (string list) modules exposed by this package. + + + + + + hidden-modules + hidden-modulespackage specification + + + (string list) modules provided by this package, + but not exposed to the programmer. These modules cannot be + imported, but they are still subject to the overlapping constraint: + no other package in the same program may provide a module of the + same name. + + + + + + reexported-modules + reexported-modulesreexport specification + + + Modules reexported by this package. This list takes + the form of pkg:OldName as NewName + (A@orig-pkg-0.1-HASH): the first portion of the + string is the user-written reexport specification (possibly + omitting the package qualifier and the renaming), while the + parenthetical is the original package which exposed the + module under are particular name. Reexported modules have + a relaxed overlap constraint: it's permissible for two + packages to reexport the same module as the same name if the + reexported moduleis identical. + + + + + + trusted + trustedpackage specification + + + (bool) Whether the package is trusted or not. + + + + + + import-dirs + import-dirspackage specification + + + (string list) A list of directories containing interface files + (.hi files) for this package. + + If the package contains profiling libraries, then + the interface files for those library modules should have + the suffix .p_hi. So the package can + contain both normal and profiling versions of the same + library without conflict (see also + library_dirs below). + + + + + + library-dirs + library-dirspackage specification + + + (string list) A list of directories containing libraries for this + package. + + + + + + hs-libraries + hs-librariespackage specification + + + (string list) A list of libraries containing Haskell code for this + package, with the .a or + .dll suffix omitted. When packages are + built as libraries, the + lib prefix is also omitted. + + For use with GHCi, each library should have an + object file too. The name of the object file does + not have a lib + prefix, and has the normal object suffix for your + platform. + + For example, if we specify a Haskell library as + HSfoo in the package spec, then the + various flavours of library that GHC actually uses will be + called: + + + libHSfoo.a + + The name of the library on Unix and Windows + (mingw) systems. Note that we don't support + building dynamic libraries of Haskell code on Unix + systems. + + + + HSfoo.dll + + The name of the dynamic library on Windows + systems (optional). + + + + HSfoo.o + HSfoo.obj + + The object version of the library used by + GHCi. + + + + + + + + + extra-libraries + extra-librariespackage specification + + + (string list) A list of extra libraries for this package. The + difference between hs-libraries and + extra-libraries is that + hs-libraries normally have several + versions, to support profiling, parallel and other build + options. The various versions are given different + suffixes to distinguish them, for example the profiling + version of the standard prelude library is named + libHSbase_p.a, with the + _p indicating that this is a profiling + version. The suffix is added automatically by GHC for + hs-libraries only, no suffix is added + for libraries in + extra-libraries. + + The libraries listed in + extra-libraries may be any libraries + supported by your system's linker, including dynamic + libraries (.so on Unix, + .DLL on Windows). + + Also, extra-libraries are placed + on the linker command line after the + hs-libraries for the same package. If + your package has dependencies in the other direction (i.e. + extra-libraries depends on + hs-libraries), and the libraries are + static, you might need to make two separate + packages. + + + + + + include-dirs + include-dirspackage specification + + + (string list) A list of directories containing C includes for this + package. + + + + + + includes + includespackage specification + + + (string list) A list of files to include for via-C compilations + using this package. Typically the include file(s) will + contain function prototypes for any C functions used in + the package, in case they end up being called as a result + of Haskell functions from the package being + inlined. + + + + + + depends + dependspackage specification + + + (package id list) Packages on which this package + depends. + + + + + + hugs-options + hugs-optionspackage specification + + + (string list) Options to pass to Hugs for this package. + + + + + + cc-options + cc-optionspackage specification + + + (string list) Extra arguments to be added to the gcc command line + when this package is being used (only for via-C + compilations). + + + + + + ld-options + ld-optionspackage specification + + + (string list) Extra arguments to be added to the + gcc command line (for linking) when + this package is being used. + + + + + + framework-dirs + framework-dirspackage specification + + + (string list) On Darwin/MacOS X, a list of directories containing + frameworks for this package. This corresponds to the + option. It is ignored on all other + platforms. + + + + + + frameworks + frameworkspackage specification + + + (string list) On Darwin/MacOS X, a list of frameworks to link to. This + corresponds to the option. Take a look + at Apple's developer documentation to find out what frameworks + actually are. This entry is ignored on all other platforms. + + + + + + haddock-interfaces + haddock-interfacespackage specification + + + (string list) A list of filenames containing Haddock interface + files (.haddock files) for this package. + + + + + + haddock-html + haddock-htmlpackage specification + + + (optional string) The directory containing the Haddock-generated HTML + for this package. + + + + + + + + + package environments + + Package environments + + + A package environment is a file that tells + ghc precisely which packages should be visible. It + contains package IDs, one per line: + + +package_id_1 +package_id_2 +... +package_id_n + + + If a package environment is found, it is equivalent to passing these + command line arguments to ghc: + + +-hide-all-packages +-package-id package_id_1 +-package-id package_id_2 +... +-package-id package_id_n + + + In order, ghc will look for the package environment + in the following locations: + + + + + File + file + if you pass the option + . + + + + + File + $HOME/.ghc/arch-os-version/environments/name + if you pass the option + . + + + + + File + file + if the environment variable GHC_ENVIRONMENT + is set to file. + + + + + File + $HOME/.ghc/arch-os-version/environments/name + if the environment variable GHC_ENVIRONMENT + is set to name. + + + + + File ./.ghc.environment if it exists. + + + + + File + $HOME/.ghc/arch-os-version/environments/default + if it exists. + + + + + Package environments can be modified by further command line arguments; + for example, if you specify + + on the command line, then package foo will be + visible even if it's not listed in the currently active package + environment. + + + + + diff --git a/docs/users_guide/parallel.xml b/docs/users_guide/parallel.xml new file mode 100644 index 00000000..266a93ff --- /dev/null +++ b/docs/users_guide/parallel.xml @@ -0,0 +1,202 @@ + + + Concurrent and Parallel Haskell + parallelism + + + GHC implements some major extensions to Haskell to support + concurrent and parallel programming. Let us first establish terminology: + + Parallelism means running + a Haskell program on multiple processors, with the goal of improving + performance. Ideally, this should be done invisibly, and with no + semantic changes. + + Concurrency means implementing + a program by using multiple I/O-performing threads. While a + concurrent Haskell program can run on a + parallel machine, the primary goal of using concurrency is not to gain + performance, but rather because that is the simplest and most + direct way to write the program. Since the threads perform I/O, + the semantics of the program is necessarily non-deterministic. + + + GHC supports both concurrency and parallelism. + + + + Concurrent Haskell + + Concurrent Haskell is the name given to GHC's concurrency extension. + It is enabled by default, so no special flags are required. + The + Concurrent Haskell paper is still an excellent + resource, as is Tackling + the awkward squad. + + To the programmer, Concurrent Haskell introduces no new language constructs; + rather, it appears simply as a library, + Control.Concurrent. The functions exported by this + library include: + +Forking and killing threads. +Sleeping. +Synchronised mutable variables, called MVars +Support for bound threads; see the paper Extending +the FFI with concurrency. + + + + + Software Transactional Memory + + GHC now supports a new way to coordinate the activities of Concurrent + Haskell threads, called Software Transactional Memory (STM). The + STM + papers are an excellent introduction to what STM is, and how to use + it. + + The main library you need to use is the + stm library. The main features supported are these: + +Atomic blocks. +Transactional variables. +Operations for composing transactions: +retry, and orElse. +Data invariants. + +All these features are described in the papers mentioned earlier. + + + +Parallel Haskell + + GHC includes support for running Haskell programs in parallel + on symmetric, shared-memory multi-processor + (SMP)SMP. + By default GHC runs your program on one processor; if you + want it to run in parallel you must link your program + with the , and run it with the RTS + option; see ). + The runtime will + schedule the running Haskell threads among the available OS + threads, running as many in parallel as you specified with the + RTS option. + + GHC only supports parallelism on a shared-memory multiprocessor. + Glasgow Parallel HaskellGlasgow Parallel Haskell + (GPH) supports running Parallel Haskell + programs on both clusters of machines, and single multiprocessors. GPH is + developed and distributed + separately from GHC (see The + GPH Page). However, the current version of GPH is based on a much older + version of GHC (4.06). + + + + Annotating pure code for parallelism + + Ordinary single-threaded Haskell programs will not benefit from + enabling SMP parallelism alone: you must expose parallelism to the + compiler. + + One way to do so is forking threads using Concurrent Haskell (), but the simplest mechanism for extracting parallelism from pure code is + to use the par combinator, which is closely related to (and often used + with) seq. Both of these are available from the parallel library: + + +infixr 0 `par` +infixr 1 `pseq` + +par :: a -> b -> b +pseq :: a -> b -> b + + The expression (x `par` y) + sparks the evaluation of x + (to weak head normal form) and returns y. Sparks are + queued for execution in FIFO order, but are not executed immediately. If + the runtime detects that there is an idle CPU, then it may convert a + spark into a real thread, and run the new thread on the idle CPU. In + this way the available parallelism is spread amongst the real + CPUs. + + For example, consider the following parallel version of our old + nemesis, nfib: + + +import Control.Parallel + +nfib :: Int -> Int +nfib n | n <= 1 = 1 + | otherwise = par n1 (pseq n2 (n1 + n2 + 1)) + where n1 = nfib (n-1) + n2 = nfib (n-2) + + For values of n greater than 1, we use + par to spark a thread to evaluate nfib (n-1), + and then we use pseq to force the + parent thread to evaluate nfib (n-2) before going on + to add together these two subexpressions. In this divide-and-conquer + approach, we only spark a new thread for one branch of the computation + (leaving the parent to evaluate the other branch). Also, we must use + pseq to ensure that the parent will evaluate + n2 before n1 + in the expression (n1 + n2 + 1). It is not sufficient + to reorder the expression as (n2 + n1 + 1), because + the compiler may not generate code to evaluate the addends from left to + right. + + + Note that we use pseq rather + than seq. The two are almost equivalent, but + differ in their runtime behaviour in a subtle + way: seq can evaluate its arguments in either + order, but pseq is required to evaluate its + first argument before its second, which makes it more suitable + for controlling the evaluation order in conjunction + with par. + + + When using par, the general rule of thumb is that + the sparked computation should be required at a later time, but not too + soon. Also, the sparked computation should not be too small, otherwise + the cost of forking it in parallel will be too large relative to the + amount of parallelism gained. Getting these factors right is tricky in + practice. + + It is possible to glean a little information about how + well par is working from the runtime + statistics; see . + + More sophisticated combinators for expressing parallelism are + available from the Control.Parallel.Strategies + module in the parallel package. + This module builds functionality around par, + expressing more elaborate patterns of parallel computation, such as + parallel map. + + +Data Parallel Haskell + GHC includes experimental support for Data Parallel Haskell (DPH). This code + is highly unstable and is only provided as a technology preview. More + information can be found on the corresponding DPH + wiki page. + + + + + diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml new file mode 100644 index 00000000..3b7403b9 --- /dev/null +++ b/docs/users_guide/phases.xml @@ -0,0 +1,1362 @@ + + + Options related to a particular phase + + + Replacing the program for one or more phases + phases, changing + + You may specify that a different program be used for one + of the phases of the compilation system, in place of whatever + the ghc has wired into it. For example, you + might want to try a different assembler. The following options + allow you to change the external program used for a given + compilation phase: + + + + + cmd + + + + Use cmd as the literate + pre-processor. + + + + + + cmd + + + + Use cmd as the C + pre-processor (with only). + + + + + + cmd + + + + Use cmd as the C + compiler. + + + + + + cmd + + + + Use cmd as the LLVM + optimiser. + + + + + + cmd + + + + Use cmd as the LLVM + compiler. + + + + + + cmd + + + + Use cmd as the + splitter. + + + + + + cmd + + + + Use cmd as the + assembler. + + + + + + cmd + + + + Use cmd as the + linker. + + + + + + cmd + + + + Use cmd as the DLL + generator. + + + + + + cmd + + + + Use cmd as the + pre-processor (with only). + + + + + + cmd + + + + Use cmd as the + program to use for embedding manifests on Windows. Normally this + is the program windres, which is supplied with a + GHC installation. See in . + + + + + + cmd + + + + Use cmd as the libtool command + (when using only). + + + + + + cmd + + + + Use cmd as the readelf command + (part of Unix binutils). + + + + + + + Forcing options to a particular phase + forcing GHC-phase options + + Options can be forced through to a particular compilation + phase, using the following flags: + + + + + option + + + + Pass option to the + literate pre-processor + + + + + option + + + + Pass option to CPP (makes + sense only if is also on). + + + + + option + + + + Pass option to the + custom pre-processor (see ). + + + + + option + + + + Pass option to the C compiler. + + + + + option + + + + Pass option to the LLVM optimiser. + + + + + option + + + + Pass option to the LLVM compiler. + + + + + option + + + + Pass option to the assembler. + + + + + option + + + + Pass option to the linker. + + + + + option + + + + Pass option to the DLL generator. + + + + + option + + + + Pass option to + windres when embedding manifests on Windows. + See in . + + + + + So, for example, to force an + option to the assembler, you would tell the driver + (the dash before the E is + required). + + GHC is itself a Haskell program, so if you need to pass + options directly to GHC's runtime system you can enclose them in + +RTS ... -RTS (see ). + + + + + Options affecting the C pre-processor + + pre-processing: cpp + C pre-processor options + cpp, pre-processing with + + + + + + + + + + The C pre-processor cpp is run + over your Haskell code only if the + option -cpp + option is given. Unless you are + building a large system with significant doses of + conditional compilation, you really shouldn't need + it. + + + + + + symbol=value + + + + Define macro symbol in the + usual way. NB: does not affect + macros passed to the C compiler + when compiling via C! For those, use the + hack… (see ). + + + + + + symbol + + + + Undefine macro symbol in the + usual way. + + + + + + dir + + + + Specify a directory in which to look for + #include files, in the usual C + way. + + + + + The GHC driver pre-defines several macros when processing + Haskell source code (.hs or + .lhs files). + + The symbols defined by GHC are listed below. To check which + symbols are defined by your local GHC installation, the following + trick is useful: + +$ ghc -E -optP-dM -cpp foo.hs +$ cat foo.hspp + + (you need a file foo.hs, but it isn't + actually used). + + + + + __GLASGOW_HASKELL__ + __GLASGOW_HASKELL__ + + + For version + x.y.z + of GHC, the value of + __GLASGOW_HASKELL__ + is the integer xyy (if + y is a single digit, then a leading zero + is added, so for example in version 6.2 of GHC, + __GLASGOW_HASKELL__==602). More + information in . + + With any luck, + __GLASGOW_HASKELL__ + will be undefined in all other implementations that + support C-style pre-processing. + + (For reference: the comparable symbols for other + systems are: + __HUGS__ + for Hugs, + __NHC__ + for nhc98, and + __HBC__ + for hbc.) + + NB. This macro is set when pre-processing both + Haskell source and C source, including the C source + generated from a Haskell module + (i.e. .hs, .lhs, + .c and .hc + files). + + + + + + __GLASGOW_HASKELL_PATCHLEVEL1__ + __GLASGOW_HASKELL_PATCHLEVEL1__ + + + __GLASGOW_HASKELL_PATCHLEVEL2__ + __GLASGOW_HASKELL_PATCHLEVEL2__ + + + These macros are available starting with GHC 7.10.1. + + For three-part GHC version numbers + x.y.z, + the value of + __GLASGOW_HASKELL_PATCHLEVEL1__ + is the integer z. + + For four-part GHC version numbers + x.y.z.z', + the value of + __GLASGOW_HASKELL_PATCHLEVEL1__ + is the integer z while the value of + __GLASGOW_HASKELL_PATCHLEVEL2__ + is set to the integer z'. + + These macros are provided for allowing finer + granularity than is provided by + __GLASGOW_HASKELL__. Usually, this should + not be necessary as it's expected for most APIs to remain + stable between patchlevel releases, but occasionally + internal API changes are necessary to fix bugs. Also + conditional compilation on the patchlevel can be useful for + working around bugs in older releases. + + NB. These macros are set when pre-processing both + Haskell source and C source, including the C source + generated from a Haskell module + (i.e. .hs, .lhs, + .c and .hc + files). + + + + + + MIN_VERSION_GLASGOW_HASKELL(x,y,z,z') + MIN_VERSION_GLASGOW_HASKELL + + + This macro is available starting with GHC 7.10.1. + + This macro is provided for convenience to write CPP + conditionals testing whether the GHC version used is version + x.y.z.z' + or later. + + If compatibility with Haskell compilers (including GHC + prior to version 7.10.1) which do not define + MIN_VERSION_GLASGOW_HASKELL is required, + the presence of the + MIN_VERSION_GLASGOW_HASKELL macro needs + to be ensured before it is called, e.g.: + +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) +/* code that applies only to GHC 7.10.2 or later */ +#endif +#endif + + NB. This macro is set when pre-processing both + Haskell source and C source, including the C source + generated from a Haskell module + (i.e. .hs, .lhs, + .c and .hc + files). + + + + + + __GLASGOW_HASKELL_TH__ + __GLASGOW_HASKELL_TH__ + + + + This is set to YES when the compiler supports Template Haskell, and to + NO when not. The latter is the case for a stage-1 compiler during bootstrapping, or + on architectures where the interpreter is not available. + + + + + + + + __GLASGOW_HASKELL_LLVM__ + __GLASGOW_HASKELL_LLVM__ + + + Only defined when is specified. When GHC + is using version + x.y.z + of LLVM, the value of + __GLASGOW_HASKELL_LLVM__ + is the integer xy. + + + + + + __PARALLEL_HASKELL__ + __PARALLEL_HASKELL__ + + + Only defined when is in + use! This symbol is defined when pre-processing Haskell + (input) and pre-processing C (GHC output). + + + + + + os_HOST_OS=1 + + + This define allows conditional compilation based on + the Operating System, whereos is + the name of the current Operating System + (eg. linux, mingw32 + for Windows, solaris, etc.). + + + + + + arch_HOST_ARCH=1 + + + This define allows conditional compilation based on + the host architecture, wherearch + is the name of the current architecture + (eg. i386, x86_64, + powerpc, sparc, + etc.). + + + + + + CPP and string gaps + + A small word of warning: is not + friendly to “string gaps”.-cpp + vs string gapsstring + gaps vs -cpp. In other words, strings + such as the following: + +strmod = "\ +\ p \ +\ " + + don't work with ; + /usr/bin/cpp elides the backslash-newline + pairs. + + However, it appears that if you add a space at the end + of the line, then cpp (at least GNU + cpp and possibly other + cpps) leaves the backslash-space pairs + alone and the string gap works as expected. + + + + + Options affecting a Haskell pre-processor + + pre-processing: custom + Pre-processor options + + + + + + + + + A custom pre-processor is run over your Haskell + source file only if the option + -F is + given. + + Running a custom pre-processor at compile-time is in + some settings appropriate and useful. The + option lets you run a pre-processor as + part of the overall GHC compilation pipeline, which has + the advantage over running a Haskell pre-processor + separately in that it works in interpreted mode and you + can continue to take reap the benefits of GHC's + recompilation checker. + + The pre-processor is run just before the Haskell + compiler proper processes the Haskell input, but after the + literate markup has been stripped away and (possibly) the + C pre-processor has washed the Haskell input. + + Use + + to select the program to use as the preprocessor. When + invoked, the cmd pre-processor + is given at least three arguments on its command-line: the + first argument is the name of the original source file, + the second is the name of the file holding the input, and + the third is the name of the file where + cmd should write its output + to. + + Additional arguments to the pre-processor can be + passed in using the option. These + are fed to cmd on the command + line after the three standard input and output + arguments. + + + An example of a pre-processor is to convert your source files to the + input encoding that GHC expects, i.e. create a script + convert.sh containing the lines: + + +#!/bin/sh +( echo "{-# LINE 1 \"$2\" #-}" ; iconv -f l1 -t utf-8 $2 ) > $3 + + and pass -F -pgmF convert.sh to GHC. + The -f l1 option tells iconv to convert your + Latin-1 file, supplied in argument $2, while + the "-t utf-8" options tell iconv to return a UTF-8 encoded file. + The result is redirected into argument $3. + The echo "{-# LINE 1 \"$2\" #-}" + just makes sure that your error positions are reported as + in the original source file. + + + + + + + Options affecting code generation + + + + + + + + + Use GHC's native code generator + rather than compiling via LLVM. + is the default. + + + + + + + + + + Compile via LLVMinstead + of using the native code generator. This will generally take slightly + longer than the native code generator to compile. Produced code is + generally the same speed or faster than the other two code + generators. Compiling via LLVM requires LLVM to be on the + path. + + + + + + + + + + Omit code generation (and all later phases) + altogether. This is useful if you're only interested in + type checking code. + + + + + + + + + + Always write interface files. GHC will normally write + interface files automatically, but this flag is useful with + , which normally suppresses generation + of interface files. This is useful if you want to type check + over multiple runs of GHC without compiling dependencies. + + + + + + + + + + Generate object code. This is the default outside of + GHCi, and can be used with GHCi to cause object code to be + generated in preference to bytecode. + + + + + + + + + + Generate byte-code instead of object-code. This is + the default in GHCi. Byte-code can currently only be used + in the interactive interpreter, not saved to disk. This + option is only useful for reversing the effect of + . + + + + + + + + + + Generate position-independent code (code that can be put into + shared libraries). This currently works on Linux x86 and x86-64. On + Windows, position-independent code is never used so the flag is a + no-op on that platform. + + + + + + + + + When generating code, assume that entities imported from a + different package will reside in a different shared library or + binary. + Note that using this option when linking causes GHC to link + against shared libraries. + + + + + + + Options affecting linking + + linker options + ld options + + + GHC has to link your code with various libraries, possibly + including: user-supplied, GHC-supplied, and system-supplied + ( math library, for example). + + + + + + lib + + + + Link in the lib library. + On Unix systems, this will be in a file called + liblib.a + or + liblib.so + which resides somewhere on the library directories path. + + Because of the sad state of most UNIX linkers, the + order of such options does matter. If library + foo requires library + bar, then in general + foo should + come before + bar on the + command line. + + There's one other gotcha to bear in mind when using + external libraries: if the library contains a + main() function, then this will be + linked in preference to GHC's own + main() function + (eg. libf2c and libl + have their own main()s). This is + because GHC's main() comes from the + HSrts library, which is normally + included after all the other + libraries on the linker's command line. To force GHC's + main() to be used in preference to any + other main()s from external libraries, + just add the option before any + other libraries on the command line. + + + + + + + + + + Omits the link step. This option can be used with + to avoid the automatic linking + that takes place if the program contains a Main + module. + + + + + + name + + + + If you are using a Haskell “package” + (see ), don't forget to add the + relevant option when linking the + program too: it will cause the appropriate libraries to be + linked in with the program. Forgetting the + option will likely result in + several pages of link errors. + + + + + + name + + + + On Darwin/OS X/iOS only, link in the framework name. + This option corresponds to the option for Apple's Linker. + Please note that frameworks and packages are two different things - frameworks don't + contain any haskell code. Rather, they are Apple's way of packaging shared libraries. + To link to Apple's “Carbon” API, for example, you'd use + . + + + + + + + + + + + On Darwin/OS X/iOS only, link all passed files into a static library suitable + for linking into an iOS (when using a cross-compiler) or Mac Xcode project. To control + the name, use the name option as usual. + The default name is liba.a. + This should nearly always be passed when compiling for iOS with a cross-compiler. + + + + + + + dir + + + + Where to find user-supplied libraries… + Prepend the directory dir to + the library directories path. + + + + + + dir + + + + On Darwin/OS X/iOS only, prepend the directory dir to + the framework directories path. This option corresponds to the + option for Apple's Linker ( already means something else for GHC). + + + + + + + + + + Tell the linker to split the single object file that + would normally be generated into multiple object files, + one per top-level Haskell function or type in the module. + This only makes sense for libraries, where it means that + executables linked against the library are smaller as they only + link against the object files that they need. However, assembling + all the sections separately is expensive, so this is slower than + compiling normally. Additionally, the size of the library itself + (the .a file) can be a factor of 2 to 2.5 + larger. + We use this feature for building GHC's libraries. + + + + + + + + + + Tell the linker to avoid shared Haskell libraries, + if possible. This is the default. + + + + + + + + + + This flag tells GHC to link against shared Haskell libraries. + This flag only affects the selection of dependent libraries, not + the form of the current target (see -shared). + See on how to + create them. + + Note that this option also has an effect on + code generation (see above). + + + + + + + + + + Instead of creating an executable, GHC produces a + shared object with this linker flag. Depending on the + operating system target, this might be an ELF DSO, a Windows + DLL, or a Mac OS dylib. GHC hides the operating system + details beneath this uniform flag. + + The flags / control whether the + resulting shared object links statically or dynamically to + Haskell package libraries given as option. Non-Haskell + libraries are linked as gcc would regularly link it on your + system, e.g. on most ELF system the linker uses the dynamic + libraries when found. + + Object files linked into shared objects must be + compiled with , see + + When creating shared objects for Haskell packages, the + shared object must be named properly, so that GHC recognizes + the shared object when linked against this package. See + shared object name mangling. + + + + + + + + + + + This flag selects one of a number of modes for finding shared + libraries at runtime. See for + a description of each mode. + + + + + + + + + specifying your own main function + + + The normal rule in Haskell is that your program must supply a main + function in module Main. When testing, it is often convenient + to change which function is the "main" one, and the flag + allows you to do so. The thing can be one of: + + A lower-case identifier foo. GHC assumes that the main function is Main.foo. + A module name A. GHC assumes that the main function is A.main. + A qualified name A.foo. GHC assumes that the main function is A.foo. + + Strictly speaking, is not a link-phase flag at all; it has no effect on the link step. + The flag must be specified when compiling the module containing the specified main function (e.g. module A + in the latter two items above). It has no effect for other modules, + and hence can safely be given to ghc --make. + However, if all the modules are otherwise up to date, you may need to force + recompilation both of the module where the new "main" is, and of the + module where the "main" function used to be; + ghc is not clever + enough to figure out that they both need recompiling. You can + force recompilation by removing the object file, or by using the + flag. + + + + + + + + + linking Haskell libraries with foreign code + + + In the event you want to include ghc-compiled code + as part of another (non-Haskell) program, the RTS will not + be supplying its definition of main() + at link-time, you will have to. To signal that to the + compiler when linking, use + . See also . + + Notice that since the command-line passed to the + linker is rather involved, you probably want to use + ghc to do the final link of your + `mixed-language' application. This is not a requirement + though, just try linking once with on + to see what options the driver passes through to the + linker. + + The flag can also be + used to persuade the compiler to do the link step in + mode when there is no Haskell + Main module present (normally the + compiler will not attempt linking when there is no + Main). + + The flags + and have no effect when + used with , because they are + implemented by changing the definition + of main that GHC generates. See + for how to get the + effect of + and when using your + own main. + + + + + + + + + + + + Link the program with a debugging version of the + runtime system. The debugging runtime turns on numerous + assertions and sanity checks, and provides extra options + for producing debugging output at runtime (run the program + with +RTS -? to see a list). + + + + + + + + + + Link the program with the "threaded" version of the + runtime system. The threaded runtime system is so-called + because it manages multiple OS threads, as opposed to the + default runtime system which is purely + single-threaded. + + Note that you do not need + in order to use concurrency; the + single-threaded runtime supports concurrency between Haskell + threads just fine. + + The threaded runtime system provides the following + benefits: + + + + It enables the RTS option RTS option to be + used, which allows threads to run in + parallelparallelism + on a + multiprocessormultiprocessorSMP + or + multicoremulticore + machine. See . + + + If a thread makes a foreign call (and the call is + not marked unsafe), then other + Haskell threads in the program will continue to run + while the foreign call is in progress. + Additionally, foreign exported + Haskell functions may be called from multiple OS + threads simultaneously. See + . + + + + + + + + + + + + + Link the program with the "eventlog" version of the + runtime system. A program linked in this way can generate + a runtime trace of events (such as thread start/stop) to a + binary file + program.eventlog, + which can then be interpreted later by various tools. See + for more information. + + + can be used + with . It is implied + by . + + + + + + + + + + + + This option affects the processing of RTS control options given either + on the command line or via the GHCRTS environment variable. + There are three possibilities: + + + + + + + Disable all processing of RTS options. + If appears anywhere on the command + line, then the program will abort with an error message. + If the GHCRTS environment variable is + set, then the program will emit a warning message, + GHCRTS will be ignored, and the program + will run as normal. + + + + + + + [this is the default setting] Enable + only the "safe" RTS options: (Currently + only + and .) Any other RTS options + on the command line or in the GHCRTS + environment variable causes the program with to abort + with an error message. + + + + + , or + just + + + Enable all RTS option + processing, both on the command line and through + the GHCRTS environment variable. + + + + + + In GHC 6.12.3 and earlier, the default was to process all + RTS options. However, since RTS options can be used to + write logging data to arbitrary files under the security + context of the running program, there is a potential + security problem. For this reason, GHC 7.0.1 and later + default to . + + + + Note that has no effect when + used with ; see + for details. + + + + + + + + + + + + This option allows you to set the default RTS options at link-time. For example, + sets the default heap size to 128MB. + This will always be the default heap size for this program, unless the user overrides it. + (Depending on the setting of the option, the user might + not have the ability to change RTS options at run-time, in which case + would be the only way to set + them.) + + + + Note that has no effect when + used with ; see + for details. + + + + + + + + + + + + On Windows, GHC normally generates a + manifestmanifest + file when linking a binary. The + manifest is placed in the file + prog.exe.manifest + where prog.exe is the name of the + executable. The manifest file currently serves just one purpose: + it disables the "installer detection"installer detection + in Windows Vista that + attempts to elevate privileges for executables with certain names + (e.g. names containing "install", "setup" or "patch"). Without the + manifest file to turn off installer detection, attempting to run an + executable that Windows deems to be an installer will return a + permission error code to the invoker. Depending on the invoker, + the result might be a dialog box asking the user for elevated + permissions, or it might simply be a permission denied + error. + + Installer detection can be also turned off globally for the + system using the security control panel, but GHC by default + generates binaries that don't depend on the user having disabled + installer detection. + + The disables generation of + the manifest file. One reason to do this would be if you had + a manifest file of your own, for example. + + In the future, GHC might use the manifest file for more things, + such as supplying the location of dependent DLLs. + + also implies + , see below. + + + + + + + + + + + The manifest file that GHC generates when linking a binary on + Windows is also embedded in the executable itself, by default. + This means that the binary can be distributed without having to + supply the manifest file too. The embedding is done by running + windreswindres + ; to see exactly what GHC does to embed the manifest, + use the flag. A GHC installation comes with + its own copy of windres for this reason. + + See also () and + (). + + + + + + + + + + + DLLs on Windows are typically linked to by linking to a corresponding + .lib or .dll.a - the so-called import library. + GHC will typically generate such a file for every DLL you create by compiling in + -shared mode. However, sometimes you don't want to pay the + disk-space cost of creating this import library, which can be substantial - it + might require as much space as the code itself, as Haskell DLLs tend to export + lots of symbols. + + As long as you are happy to only be able to link to the DLL using + GetProcAddress and friends, you can supply the + flag to disable the creation of the import + library entirely. + + + + + + + + + + + On Darwin/OS X, dynamic libraries are stamped at build time with an + "install name", which is the ultimate install path of the library file. + Any libraries or executables that subsequently link against it will pick + up that path as their runtime search location for it. By default, ghc sets + the install name to the location where the library is built. This option + allows you to override it with the specified file path. (It passes + -install_name to Apple's linker.) Ignored on other + platforms. + + + + + + + + + + + + This instructs the linker to add all symbols, not only used ones, to the + dynamic symbol table. Currently Linux and Windows/MinGW32 only. + This is equivalent to using -optl -rdynamic on Linux, + and -optl -export-all-symbols on Windows. + + + + + + + + diff --git a/docs/users_guide/prof_scc.eps b/docs/users_guide/prof_scc.eps new file mode 100644 index 0000000000000000000000000000000000000000..beac36f498a037284f4dd04fb787c2ba793cf82f GIT binary patch literal 17580 zcmd^nc|4Wf+b>ULic$(;vnf=DjZAIIJe4VA9x`n6Y@3CUl-iUcWEPpH%u^EEkPw-N zvdK)yJe_rK>Uo~`_q^{pzxRCJ^Uv}5#J=yf*0rv64c}|H?;R_%sydg1nS%+6>k2my zTt-!07WzQO$|~iIGDbT%BjE~m#ug|gV+$)&8@M315VsH*)UZO^qL6S$X9sg57gJMi zl%vb9B~}jh(#B{o$j8Ggz{MlT#dB4IhX=_oh~($v;t@ddK*S{-T@6f6Jdp4! zLU3MQ9=M<|A6(#yFc_7$QbW1?*HaXY?JZmZUy3L_lX9@L zL)oJtwj@y&R`#mS4z>;!WC%%5G)f%}&Soc#GIcOR$y(W>QO;!EWN3-EYWahAk$yBB(2acswih*AC3<8z(U}{ zzea%B8ml|FIs={@tvpb+MlN_e`8BNMYKyjVv_<_n%>{05Z0myhHQ~@v(9TvKaJ@rD z!0CAK+r#Zq7Ka}Vel0kZo*oY{l*4}qV|c~i1=Ic}6e%U0oB!WPCMuwd%y>lA@0NL}C!ndnDgU42!*A-4Q5+J5Oac0LV8MT<^1q+|7kk!& zBNXh-P#!3=U#k3lJ{N#9F0LlO4+}T=f2QF-LH4(L`2+<1hZX!!9SKko`0E!R^4d|5p(bGDCdo^M4W|@c@5dE_nY1zy1c) zQnpr(c!836-~F9?xH#Gxdmi2eB1RlSu>ddM-(8s%uHkHK?*bAU5M=&s{Py^bpy962G)br8t!7{g@PM{oXOk)q$AMP{~QnhR%CK?umTx0#NDsF z_%A2HM<4ttAlW-Y!02dMu)@_X9o!xNI|0?j@n4DIt>7T7`|nBk zm$Ck0^Y6Nb63lxR?mI;58(=Thm+r?kW{&V?xm{R<51#kFoIQvz> z9q8(pbnP9`5G#NMZ}@)*F@MEnkaU6~3ZI2SX@&Pcgpj{RE;vBN1J!#2xCJYrB=aD@ zguouK;(c(1XX-G42F~UUcR6&`18)BU%=l9Lu=GBt&_RKYFVUfD{l6;l5r2x{5Yb&- zP|jvhAT)vM`CoNC6p@fneAq^=CP3yfFdwJlfa{CSd#Iq*@8l|~naPnG-*@ei{nmR|UehzV z&gz#EZ;2Bq2|giwb)UePn#S;`Bz13e+>69gQ~xO?i(9nf?+6SpaM=GOeCx<#<9jT* zmasNpLC>c(UHc5H`swC+vGzbF@<&^yyUgt=E6Y=k1q25_{_8=;!o&mw{-;lEvY|OS z40?-qtH97efVI00wv~gBfFKdB))tBZA6kyWjt~%N6XSoUTf#(`x)#^(jz+Bp*1gk_ z>}f5o|E7v)dB4n4^dWH2cb}joku}!qrlGlk{M+`=mgysG1?DM&Rs3mP(>=YBvZP3i z5!#@%cQ&W|p3j(btjtf-tR)Z51oJgwV(kVqzG*aaAa#o7y-c@#Q_n??i9DSQPCtY0 z)e0T%QJKhI+b0>lY?>|SXT@IBwsL7lDpeC!N*ytjjA&YRYKniMU381SX76d#djD;a zuQ8RJ$#<1{^0wq2+TgbLmb3I$vm@O{CSKUkF}yZ|A@X$mcvrXkV!+0->j7{Q>dq0f z8p;;?*MsFd21TXHEFTMfzpab5i(>S<7sO|V)$e08mm=K}&nT_yeP7Lb3#`Q79xa&p!m9ghV#H~zOJ{FxyzYwc zIiB_lt2X5REV1fUv?#%HPGlsEr=}q$h0Dq8yndI6a;AS0hvc}<$?Va$tKP+L znFk1Uh8E|(dza}%Z=66Z`s+kY-M!h$mdEip{QifLQXlLDvCv)WB6hZz6)W6%A8%oCB*PZ2y?Uz(tcK=eeFfL+Z#%?@mc6~=e8sb5+32*8@*Ov8&k~=! zV9q9@^MfyRdfLn$qY-Wm%i(^QP;}V#q1kZ=gpa1R;_LkjVNnX zREL-Hx226JuH{V(-x#H4E;ePXHJu5>(i7ix{S3#(9?#L{Ud(?O8y%Iu*DrbXg092) z`yT5So_b1l^;&ij=2?d7U6{q9R*|oP?mE8lE3cdLJ{DiTad&+6#oC7=UEenoFHQ;y z_q%eQJe~K*qSt9Bc~iM~hG?l>LofbAAolq2Sv?+q;X;MkQm3wlF4XYn(;|5+u{I{v zo4#2o@Kj@kVb&MjHd@0I60q5T{#A4s#=Cz=)-X-9wC-cNa)$GJ;cXP}+djvT%XnK8K>+CZon`#I8?qb%9dK@0KEDQbEC`GA@E6+=C zer^n$#=P>1A`bmhamVf2d~;(~j}t7thQX7o)yS!>zD4ZIv(+t;wCf&KPT`Yzt{VpE zDoA*?>9}q|pD*S`-<=}Y`x`!=csap6Yt$NJqwe}@3sHC`tB4;+swy-4`PaHni(3|~ z`!Y2@Vrk;n&+bt@dtJn7El$ot@IW{FEd8XqY|`zUSB$s z?(1U6Jv*&Rt>d6ev|`CJ<)Nc(&o=sGbu80#sA80Be|AEITWn(t*C-)UlJ)4z!`^r= zlDRsI;}iLD81=y)-EHPd1xVKfgY02Ktzp!rXYM7<))I@F=QEAb6Go{ERS#ceP$&n? z2RqLvn@(THjy{?&#V#emY%nJ{J9y3N847thlk>8dxRhQ~GX;fb%BYavQFxO;Im%@$)iF{eg1> zJuwcovNpq^J7V0{Hcq&DEO#qi_4?qn$8GwWs{ZV&l&>nEW}@~8xDu$SigCN`z%r*_FaI|+fRLF(?#a%)|z5N?=>OcxXH zc0=W6wa<+cXmW!5M^n1md#hMVnpeN3f(Yi=`|h-uer3 zkK*lapgE0Jwsw7YE`x>PEkdJ;3D@XDLj(|ps@cH?(aPy2<8Ttu_M4Ao#jykgt@?(_ zYwPTd4X3Bs27T33y;E&O8N-U*U%k8sMUoFsWtZFNr_ZS1xFgY(XR?g7Qf=lca(7;g z@M1x@(PZXca3jXx*!4L*_k7+5J<30y`E|qS2#|>C!op4jm6KEc+}K4b-J5-|j>32Df_d{73b6Dp>lnFjhqsI|aVYydOkWhTpMgZGt-7f zDj66ini5!E3#{8{j+mC>_D#oihIH!Zvqm(3_!;`bFps8|5J}|Ub2`|#Rt(L62n=N< zLa@90P1Nu5^HXA2{F2 z4vy>SVwhdTM87yrpxZE?(>qOGN?X?O_Di_PmRE< zHv>s4DHDi-)a41pZ*FYOF4f(OO$Z%ri%5FiCJ=K>QCYMfNv5aDYK#n3M!0WpcfC-{@*&w6k_%vu z{MO+(KW7&16Sg-6y}y^1#?O~h#1H`=3JvK+#u=lC!9jUf%ns%@e0kyRp*=0p%>mG; z2?oe%zWE9)DiFi$4i4~Kkv4dDufs`nR&yAss7Fx_xqxD(=r(Gt%BNW&4sHQWY8;L; znm9Q2!K(VUC!c(EylF(hl4Fptj#~4AB@9d_?P^mx_`#YpH*$b+(|uwg#FG@B5d`Br zb^_z%z(@it8{so&ovf}h8$nYgu0htJtK3H}S5se}TQ1CSf;cdY=qRwvrZ|V1=pL7~ zRtmI_>%_vItc2+l8W|YUJU%>~?^-^(xLuPcLLVaZFOssX*M8ihFu5w2p??aOlb-qCdDYqH)#Khx@**V`4~wj%*f zGWQ8+#%Cx95>=7B_+_td;bQly5NX@XeL(rkuN5FW?a~Z1=8K-HGnrq>MY>gmv~;sr za_IoDXnGpl2Fwj%=%~i-p<;5;b*9PsMc$+*#>eH!)~5<{=XOhefQR`oV2}x-R^1RD z>0E#tO~H=5qi*WmM$|G0e;TTww!3eYg%_;tjT9i*n3NO+%A+M>WR@oY6M`m!u}q95 zHo&bMsY#otfI;+cey4{?+Zo)y9U_M#y&8ZagrA>(xy$GMT}ViMFoBex7)&~OI`~_x z(C16`)9{(wkkd4s0(WOg0}==AI_ILIsgh0ccWlZkS5l(ioGW|rEc7^<9DoYpowK8N zdm9hUM-GT7)fuRA9(bt1%Mv&W2^9Oh-w$0KtjKugDpjO@<=7=>mydS2}xP3Y6qgI#&O8&n1E*ai0^ z+>g(*j{_I6m+}R99T^Nw<{Dq?nMDVaCy!j4qFw$2 zcI54oEROXb;S$}OK|rdA4qovr;EO&kZh~)jpGrzWOPI;)ef_3{<6Z9yTmt@pr%O;| zMEx9R`sm9K#?8jT*;RCT*EBf`Tg19i9|P9Opm)ean4zV3sWQdXztP2g^2#>K7@4L` zv3P3b(S4eyQB;{{KXmW<8b#e6nxaj-Jv1~m7gbgk4u#ZjFcY<|Z(mTxqKvURZN)_l zNAGc}q^mm#fzzG*=&OSspI^N@x;9B3`H;x`r&7AMEeCgGXtEYgUnhK3H!sqrp%sv% z00haCxv#&H`D5fo#+Ra2ftfPQlj36QCm2GylSM|6v@xpMmJ>Q1r}XzX6ZSI%s7yy1 zs(rAyrOWPs=ioZ{%rjTKM`lP|QLS&eevw*JBG&Yr*NaKdWZP?rj{%v-bKkL8u*q#m z+Lb)z7W{Nc;J81w1a`*?0shbc!{rYi)C+U!o|tTlEtpqfj3EH0AX-ORZ+ltm35OmX z2To{7L_(yjR(L^=TXiG;ugTDnV?$Bs2vHxZ)ARo&n7h+Z}3FD@3nd!vBP86;!f zah>v84KA~q)^?B`5rR80{kFbn>F5FT@!j5)KM3Xk;Wvo&2xGOh5_(`d3_y{q_xW4} z#yTIp2O#Soyu#qrRNzORELvY$CuT%8shCJPAP?8i~*F2&;Phv z+jVZhjdC*_viwTmN7lrsnM~k~`0?tp3g=7eT3iStJ{7h(GC=Q?1f{6AV2M4`GZK&? z3`<}M1jgoU<)bSC0QC0(tX8GT%^MCp(p%xx-H)!OWDpVM6ur6SGGT5ryb zQvkVWFtl{L%75z86jAPp2;>p7FmPnRx*E7R0SqQ$qG*!C65Rg2)-yOd`Bv#mSQrM_ zx^jBT@xTz@S^&L<97yV8vGlE6oxI`(0LYFECNopN4Z+NY^l9#J90#x)V>ohAdz^zT zGEO)0T6>B+x$1etTE-ittreE?k*^X?y6=CWm@0EqWTSeTO{ck+>2~bw+gye)Y}d3# zq${MifPP!$=nC1ZB3a=W8Hx%3=T&V{t0oT&^U~XD^cjY5()FFv7b`|Y-?J=-bOz=6 z{ot|Osj)Fk+qxNAv9y0NBxk&~X{9$*cR*mgs%ZXkmDtwK6HL@7p-zW#0cWdR;<5P; zfj~r=%#}0Kmr^ojpZlcejL2YF_=+>%?kpX7UTFB@+jh+q+?PgOU*N@UmyWKXn~QJa zM9M3te>Rs~rYTiTeZ%g{c{_5ou8k_hkK;{Z0B%Z%j7zR{R4dQ$^%`b1=gL`Ipv$}5 z+-%P?X3uVJJ;xE{hhlITy$=IEIu6KKC$rb(t^6jZqP0X>lsjv^a++>M6^CYqrPcH- zXHU=270mcCg<+QwAEceWwX|%kkb>rgXvmI$5&h*{+=t5QnZAM=>y~xzR1sVqM^x@{w)78#AG2OGDm(s0@CS~nlX6rX?9;WU<9I3yw%me=4|Ucfok8(8rZ z<9=_1SNwH&&ljifJrk0GZF_qcu!ef4kdb?7Gs3xd)HRi=y?u1-&F8FUa?|Lu;w0vO zHh9P^=FmQbXD3KaNKrFL_VyzAGfs2bTp88MD;g7xOX*y#P9p5c zqKB(vN-I*jTt>5jtwuU|M#`GgeNWRFuLYEcPM60T9f`Im+lft-g*>LdzdxMM)h@z9 zuL7uMxKHU6du|0H?IIn}+$kVX(UsWP>4n&Pg`t>+^oOHA%*|#+B)NgeFMr+MOHWvq z!s$Y6?96CIJl<>`0cz&^1)zl_JCGUby-ElTJu-Wm*%ML>{uYP6Q6({Pu4`a8!^+NP(CGa8 z9>DZ+lHzd3_*FZBw-n%f*YgaYTv8X}RgY2cgU-w6FzWR@gFa?+KF7j)JD>u{r{w~9 zeYy&9Nsh!LD7VBD;q%<}ni8(Dvk4CXxg~xjU1{mao^KD;rU>++^Y}+OEQf3f}N{C=b&M46av$H?X&^rZ?HV2H$ zT%l8_^{^j4lNto&mk#!K2sc}! zopL#wymGW!i^otvb|>83ucKzx?o$_k2{BWW(S10peUz(rW_05=K>Uj#MMVIJ*HFG7 z0jgONuMWSS$D8p+(6Ca_O>+~2HJz5WVLAsp^8DSz>z|?52Cd-}Sc~|N)GW(q=Vv;N z+gHYDzO;sVZ?+W2Da)O_2m*2PQ&>I-I%|IvfJ}~__b|r#81uWvy7+!l2{Wb#L3aE& zY9ah%bY{ z@SK@R0&u3X>QLx|6jtu&%gucvyV75~y|Yt#l9i~B1WleVA|%umc%-FU8swyR0HJr7 zAY=LHm=BUEWP`xy-NwIU@uI9x_u@-1P14mPup@Kt=W|MH+pS`oTy7(r^@#lnqkxpr*b(;$f2>MROt=V6zv_6i|P@#p#wmRjv3R&$MeO+ zq=LE(zld62U-6DiP zvY!$0dJaDnUH~_dt|{ps(MU1};+i`&qwzXWyx4-`rRfC9`Wct{!0o;>Ky;^Cx-Ym` zY8e9>;?zE)VxkO#_Tvf$&{n)twD9B4Gn&~*J9sbrHLC8yPr#0dHcd=?a1tHl63tNW zaLOX7cckouI`1m_-Gd<*nY!=XamoNVY=h>M;!dm>KWhUdb4>W6E!(xEIX}6cr@l37 ze1>!R?6FzIS5YXi=3la~kZS2R>uNGL^=>_OJVXVHEAZ&q`Js<&s(^D$WKN?mw^jg6 z6uLk-!lnoES-p^-Pra)R-xrzdP`_2@Y<0fEWr%i9t_F zV@5Sj=7NcO9dLtlSH);(he=?EzV|J$EH7r7Vng33atU=j698g*zgq0= z_*K{8i-J-2Up+lFoZvFv#uL^#PG)5F>hpB3&F)r#@X z^N3Reqve!}j+tYKN;@kEvhWKY+dV0YN^U2VIBY>09|Gkw*3UvQdAUQwLh_a;fvA;h z5!`EbrQ@lDpo5TqZi@DuqxbCmqKd5$E|pmVn}2GGR{SAIQD*IgtrS1CZ%*^tf@D(_ zLL=*ErXbg}J&GivG%vaeE*(JD2yGi=?BUg7Y5mN_u!?qY*nuDpY%>6A>fwcVPLi`qLRN<3Hin@3Ds_580Y=DC)@o*KZ*#*za+fo)@F`tU z>Ct1kS+af!Y=`crPr=VK6rM)=tq*svnV%>ogh`12j^pRQ$M8diHoZS4>HbE|==2XM zQ#CYbQ$VXEX_b^(nj4NGgR>J&E$O4800{-Cb8rF~476BRWMMj+!*8WvSYrliHZpLt z&eB@V9Pn-idN|%?HEu8q>*|MW^Q54I;nuZ*}x7J}HStvw| z1R30T-kS_%ZE{JSu1}CBPPurJBj<^5@A~eNu;(kuaZoCa6BTl{MAAd2!N(=4n@RWV zV9BPN9mOkI);+5O>eNoHg=N~0A7hekSKS3Vb{SwZQ36FqKVtx#_QV60A-IXts7{ZK zOpS?Nc^ylphRt0OUw1S)1>0ryleR)lsclQ0PB+8j^VULXId_{i)|AgDpTmhKO}z(puR z%wF5r5^2TW>v;%#Kz;~=vmDjwRa`jtM0Scch8QUQ>8m&j_tE$yiVl%rS!XBSBt@l6 zN`R-2!7&+&`d{%0WXLP4Ov9wuI(YdX^N?2#6QMFuN^IkYKHe}+!>&>Ktg z14}pu6n_CUb30D~(n)iRDj)lF{RP0Z(?I*H??F?5YKoTb2pDYcXq1FV27=Dr4@cX| zZ>$$&uv%IR3wpx*p!d<{4>q=jjNuQM)Dh5(62@3meqp@;ir+$DZ3~dKk>?1N2W7WF zedbaZOVKIX8GwLlOHlXV4`i_J0h*izZ4D{v4&Lr4I7$39Q+|OAFMOVIG7ytg1I`X( z&mZYKU3gt30W|y`NMKdf4=Nk4n>U*RA#(+!kf#p{8-;7jJDV5Cr3OVPG=QJDj_*L? zxdnWZkq9O=e*gv6XT!{?8IQuGs!8g@!LS~_P%|LT1a|M$xd`yS_;{CQeSM!=DsMCimY4M@VryGI8tpC93|6v@A3+N4%scoM?Vh;< z%QHF&! zHmFt-lZ;w5pYn)atli&R!lj2Xx=zEjsQS?=D!?19Un#Y-+{4VuP$sp`=v-L}y_KJR zMqsv0dUVVNU8R`rl1#tW?zeY*u>F`CXcYJ^4S9v$XzJ-l4_Kr1<)n*Q^l#Y>K`^h# zu3P;WL$$Nu?zb@>kzQfU#2{L&fK`|d}}Xsvo=oIg7Q3;nhh}?_Y{-Ag}%M0 zjhJ~lF(H&bf$ZUPwe9j<8yww>oo7GB6h2>qPq?bDvYJKNdQm?#K+nlcIVT@yYf)W~ zHWw=}7xmpQmhkqhXnd)~sHD}hFYrK`W<6K&E;DI!W9MYrfZ8+`bs-F4^RYHJEdaOZ zxkI6F%`F=tF{0wxzG^3dbyAETaP-(HhjycV0ulvtvm&c3_f9AM45wQ&OD!_vB)r3! z0-4TEuQ6m84k`QW;oCZw!m`U#HG6-cOpj5=Fh*Yy&BYOVPBSMJlid>q zcZjOuzdMU=+lhCm-7P6bVxlrA!Wi#<^3Q$b2=xotlpgBEfb!w3jH221{IoJD*ZeA3 zTN|=r79%J7p_kt;SBFktpACFd_eDZBJMHG1>R}HH&nLzc=3AE)t1HHkBgfEH8fkk3 zM=CDAhYAt_s~dt@QVYqrpz<-Phi`G_m*2G7jFr-CKEkwhMaDL`+O`z2=(zCkuO`F{ zUa&6#6v(r^!2x|zU1&IZ5}6_x0si;5`FJD@dU zFUXBRL@n0DVFuFzGdnZa#coCqydyWzyaO1t1{gp$Ae)8uL3g(q{$V1nwF#aOV6GI8 z*q&CCR#p+3f=L~>3d5xEt*Quh7OadnKb*H1W(j}`Urz&@!~zE?!l1);ow3jU0_i0MEPY!9sa;APa->{wmyig3_QPy1c+_Yo^epIk1SPDVjxHNF z+}ce9M(UvSUaVkP^0b=aNY%N)k@>_5{@d8{=NYCvi5wPyUFx(!6dR?s!g<$Mra;pE zxjyA(FICgn>>%u>qszcC;3-Ws*$RSGNtYH)ZetmbS>aaq^CvVYrwsnq-0a^a_>?*r zNA{p5LhQijG#-wNw#(eS63(S zB-+>j{(CG29UhSSAEGMu9rCa!)ilAK9}f}~REE|# za+#iIkOFQRQ-aTCWyZV~u~l}?xi&HVbJ$AyLxaiq_i63%jj2wjtK677;=PUfhBs>a ziiS_0Hn~QKv=_AQgPWY9c*%Rry8MPMN8FT*Mn+^-Ogip!OLy?@E@qy_fPK8xIQ`1o zVe->z4-;|bplfYTQtgz>9TM_7Fk8+3C1(F;`hMTwwn8+wTQZ@6-|noDUG2{S@#q*z zP!ob3w0m7$k7`vN&pwV@D(juKYOYW~Vr13bZ@3k__s@L{+yoqe*K_k(1XAFfK(?;O zCMX!_KClvX))eJN4_%>qGLwZ%*x#XH1$at6)gnoGv_1Ywj*x$l20KW1vfel>_T7j^ z5*?{v{0=opW5PW^HlTS+9j3>rPX98==2~y>Lft)^>ech9YFDo_4vYvSC3kCJsqxm6 z!%Xsrm0PyZ-5?Dv&}7iOB?lWku%N61$BVr#nMnhZF|>6$?(*{t3Swd-px@}&*h?sD zNzD&AS`o)z-x7goB`Lyi>O^Q(e8$0?rC!8Fb0ftNnX4Q<@B{L8_t(0>cFpX*LkX4$ z9e)_zbeS5;x}H5@=Q*JP=yW^yC3Fd%Dr5s(e9m}^;m}Omd)JjdSuz@XgYrcNamgT3 zG81HF8Qn72v*2K~9j_0HUoSm5`38JF&wO8Zsw@UILrXrTi|>O6nSuU>zlL=Zt_9!# z7gNXC;BQbLleGB^IFUwX9_})bDY);7Pdeort32w!W4-&2X3LgQGbi7=iT56QgnSQ3 z>EvIJA#;7B2Rc3x8W_{MRUT0ul$M8{+oh_ZV74B+=(sqFOX^gGo>kT*6?dYnXUgos z=00ov(epxi7eJ+6Xor8;Y(+R4kQE&!85%^++!T-n#w;`@DRLMN7;$AshO ziJpYhO^$&q_t}kUVew0*(4^=ghAcUIY)I(GVx{H;YwHADab|1NExZ3Xmwi)i+PeOwj~A z9P1E3XlnBcP5R zlJ9w(-IFESP9*}BIv*D|*9IN9?9V>oRL5@IIzoi5#s`!Oi+zZjk}_{XFtNI6f}*}V zLu+!?RLf@h6kGbU1o>&!|S?FN|Nal-4tjs}QCI2<95!ko4w^$C&KbMC*EDVTTO#`U#w05TxeM>j5Z};MU z=zP1UDZbK|eAL>nv(o;7jQ&;)USC_|5$(1dg&NjEi8lB)QECUU_6rw{u-@JYgFUAG z-8SMh00wSAPxu3#xiSD*73atu@3s{0wY;!9R=(Q!DBOH<j{yEJ>EJ29b}v-roJIaMEhzqwq!xKR=T+m806v-{6Xh zwB~`=XNo0;f|abnpkXKXJOx*~x0)Bm2;y%OHaLg|$Wxy)fq!p=B)cj`Z<%HaC$_HdDqC1qTCt?M zN?<9$yPxW5%D{4?=i5a|0e%!bgSu_&zHcb+&%ESYyH$7ynYx$up^@ zE#0$E*RgBtwNL{BTRg&Y>hl0#FGM{Eb4gt+WR=iBf|7yhN=yu8EI8@m?Is-dLGAW1 z6Q}RO_)@3wh!(Rd!9jXt9DRO$LUK?t#S1UqEB}Nj_iVEWTAKnfVknz_onO6R>tn zqlr#|*N3vF*S8sZ`)UY~SLwIPCB z3cPBdVy_wwO|Ba;O#et|fbVYZG6%g3nksu5a=UniW7zmsQEqqqG8*{;`u*2{b!KF05jLdclJ@%WyQcv~@J|K+RNPa0y$ybrFw-~U!$XEX)DikfG**#|`TEHHo-25syzX_4 zOJ_0{C`UvM#O=^fQegO(X+N=a%6GqS#bRhW;oMeh#fP1{6azGHhA_M1ISZm3Xef+; z6ir?LFmR{uwL2K{vmQh#eZ`9HB^Vu~fuJ!W z^pk_`s|yKp2GnBe)5Y%Zv>V+@`}CBB2;Fwj$Pd!E3UYzPer4?E7lVVd{es#l7ftX6 zd6|g@7FZaEIeEg@T+gWO{3IUAGNhKp8o0WjbD@V8_dy4orO8RW7rdY0AzU*2iBgi0 z9Hf}uf{@O~zzF2y)~A^OoeZEZnj73lD!38s7+k--83}WA07jx;9tbhie4WssX3-t_ z@qvQ8owM)txATN=j`jnWsyO2Y>u_}wOa(G{!m^!hcT$|S2@>VRkA4fW!L6<;d^AwY z1L$(`9JGL+@!FP8C1mKpN>kmgUVH6MzSxuumawj@Bt>oaIO=#enf1DErE zCIdLQY3{IS+10+ZHE>PXF-M3qC|n6hJW=!wSSRQK71?@gCwZZUeM@&xH{bR)mCFr% z%PX^B#{udG4-zc)DIxox1kUDx^#ayYBC|$lfPdgan&ARmWuyR~wr1ENilaD>RJ`Yb zPSkd#wmf=3ld#X?1?IKQ+Ek~C9eu_ZvvVC^7DGet4n84eHjBbjybLJj5}YKTs;FKC z?+KRZotA9M1>INeBwSt%ooZU{A2vj28Pv?ZRr4UqLT{)lfT-$VJ1wn!`!z_{)@rl` z5^Z>BK`otnZrUxH^r#woCxt0)poG!~?)uBhOrZw5_U9!nBML^b>u+=58}I7siay9u zA0|Im%24-d_+sh{MrrUm-W6=<+sWM7m_hOfQsojmhE5Qd7utPSV#9vho;V4!Cx}M$ z!5~O0iz5cUyx1i%pf+kl}*$yHE6AaWzskcBj9?Tqn_S;M$z7az#0dED5 zn0%^l02P6LK?iGsL#c@4s}8SO36f^s_5>BhSqcjHf=&_Vag%T04rAPvpK=I@OCRTc;!1TqUhiK%9 zLUaU;6>=}#Z%Yhp*B2+ywXG0WYbbnpq+g(*l7J`<0ciY5Q zvVL5@2xcgOmtp_*BYrAX`D~&2U3Hy(FYsI=eye3AMoi_?R;gs}JQ`V&kTS6jUaD%^ zGR*4@KBZ(c@?aXBsa2fx@M6q|xsVP?HTKW?MKu}Op4HzU(|cXNG1%VyU9TX7j-oSs ze$sN~ZpTXE^p;@NS(_5#Vc5sH_59;i55m1-9tzCHw#4+(OaIX1Og2n%3$YcGi(L%7 zs4yC|1r!I4sta{&i6=h}*S#HXCtJc)UKx*o`-0Rh z!oz0}LDRyvdf~B6WNb@dp4Qq4y9ah+>NXAyKG&lf%{npj#szNfJapDl-z>ju!x5up zDHPicENgAj2AoEcZ|xH`Uxa%7kjz~bRdJ)Prp?Q2_C727QhoC!cwR&m=CC~>+20}Z zY1s=U7xBVQShY;MQelb^Z6`$MSLWEZeFqt6w_#qGb|Z06{N{-EYd082jyRV z*eBq_%OVsO~#Wk>kar`^MCY>?doe z(5mHqPvUVdJ_CcztQ!UkFn08-DHuEB=vwRjLWOJZzDZ9Snwb?>oeb^EpP4|sdt$bk z)3ILH5iDffww*ZZ8ezGToAkipXJ+IX%=koXnz*6!PTvw5+2%YaoP^u3^Qtx+Te7Rw v|BDUex9<}#qEtu@{;v+`J3M6ITUFo+`dSe9GA8)qyfe7^^OKB + + Profiling + profiling + + cost-centre profiling + + GHC comes with a time and space profiling system, so that you + can answer questions like "why is my program so slow?", or "why is + my program using so much memory?". + + Profiling a program is a three-step process: + + + + Re-compile your program for profiling with the + -prof option, and probably one of the options + for adding automatic annotations: + -fprof-auto is the most common was known as -auto-all + prior to GHC 7.4.1.. + -fprof-auto + + + If you are using external packages with + cabal, you may need to reinstall these + packages with profiling support; typically this is done with + cabal install -p package + --reinstall. + + + + Having compiled the program for profiling, you now need to + run it to generate the profile. For example, a simple time + profile can be generated by running the program with + RTS + option, which generates a file named + prog.prof where + prog is the name of your program + (without the .exe extension, if you are on + Windows). + + There are many different kinds of profile that can be + generated, selected by different RTS options. We will be + describing the various kinds of profile throughout the rest of + this chapter. Some profiles require further processing using + additional tools after running the program. + + + + Examine the generated profiling information, use the + information to optimise your program, and repeat as + necessary. + + + + + + Cost centres and cost-centre stacks + + GHC's profiling system assigns costs + to cost centres. A cost is simply the time + or space (memory) required to evaluate an expression. Cost centres are + program annotations around expressions; all costs incurred by the + annotated expression are assigned to the enclosing cost centre. + Furthermore, GHC will remember the stack of enclosing cost centres + for any given expression at run-time and generate a call-tree of + cost attributions. + + Let's take a look at an example: + + +main = print (fib 30) +fib n = if n < 2 then 1 else fib (n-1) + fib (n-2) + + + Compile and run this program as follows: + + +$ ghc -prof -fprof-auto -rtsopts Main.hs +$ ./Main +RTS -p +121393 +$ + + + When a GHC-compiled program is run with the + RTS option, it generates a file called + prog.prof. In this case, the file + will contain something like this: + + + Wed Oct 12 16:14 2011 Time and Allocation Profiling Report (Final) + + Main +RTS -p -RTS + + total time = 0.68 secs (34 ticks @ 20 ms) + total alloc = 204,677,844 bytes (excludes profiling overheads) + +COST CENTRE MODULE %time %alloc + +fib Main 100.0 100.0 + + + individual inherited +COST CENTRE MODULE no. entries %time %alloc %time %alloc + +MAIN MAIN 102 0 0.0 0.0 100.0 100.0 + CAF GHC.IO.Handle.FD 128 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Encoding.Iconv 120 0 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 110 0 0.0 0.0 0.0 0.0 + CAF Main 108 0 0.0 0.0 100.0 100.0 + main Main 204 1 0.0 0.0 100.0 100.0 + fib Main 205 2692537 100.0 100.0 100.0 100.0 + + + The first part of the file gives the program name and + options, and the total time and total memory allocation measured + during the run of the program (note that the total memory + allocation figure isn't the same as the amount of + live memory needed by the program at any one + time; the latter can be determined using heap profiling, which we + will describe later in ). + + The second part of the file is a break-down by cost centre + of the most costly functions in the program. In this case, there + was only one significant function in the program, namely + fib, and it was responsible for 100% + of both the time and allocation costs of the program. + + The third and final section of the file gives a profile + break-down by cost-centre stack. This is roughly a call-tree + profile of the program. In the example above, it is clear that + the costly call to fib came from + main. + + The time and allocation incurred by a given part of the + program is displayed in two ways: “individual”, which + are the costs incurred by the code covered by this cost centre + stack alone, and “inherited”, which includes the costs + incurred by all the children of this node. + + The usefulness of cost-centre stacks is better demonstrated + by modifying the example slightly: + + +main = print (f 30 + g 30) + where + f n = fib n + g n = fib (n `div` 2) + +fib n = if n < 2 then 1 else fib (n-1) + fib (n-2) + + + Compile and run this program as before, and take a look at + the new profiling results: + + +COST CENTRE MODULE no. entries %time %alloc %time %alloc + +MAIN MAIN 102 0 0.0 0.0 100.0 100.0 + CAF GHC.IO.Handle.FD 128 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Encoding.Iconv 120 0 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 110 0 0.0 0.0 0.0 0.0 + CAF Main 108 0 0.0 0.0 100.0 100.0 + main Main 204 1 0.0 0.0 100.0 100.0 + main.g Main 207 1 0.0 0.0 0.0 0.1 + fib Main 208 1973 0.0 0.1 0.0 0.1 + main.f Main 205 1 0.0 0.0 100.0 99.9 + fib Main 206 2692537 100.0 99.9 100.0 99.9 + + + Now although we had two calls to fib in + the program, it is immediately clear that it was the call from + f which took all the time. The functions + f and g which are defined in + the where clause in main are + given their own cost centres, main.f and + main.g respectively. + + The actual meaning of the various columns in the output is: + + + + entries + + The number of times this particular point in the call + tree was entered. + + + + + individual %time + + The percentage of the total run time of the program + spent at this point in the call tree. + + + + + individual %alloc + + The percentage of the total memory allocations + (excluding profiling overheads) of the program made by this + call. + + + + + inherited %time + + The percentage of the total run time of the program + spent below this point in the call tree. + + + + + inherited %alloc + + The percentage of the total memory allocations + (excluding profiling overheads) of the program made by this + call and all of its sub-calls. + + + + + In addition you can use the RTS option + to + get the following additional information: + + + + ticks + + The raw number of time “ticks” which were + attributed to this cost-centre; from this, we get the + %time figure mentioned + above. + + + + + bytes + + Number of bytes allocated in the heap while in this + cost-centre; again, this is the raw number from which we get + the %alloc figure mentioned + above. + + + + + What about recursive functions, and mutually recursive + groups of functions? Where are the costs attributed? Well, + although GHC does keep information about which groups of functions + called each other recursively, this information isn't displayed in + the basic time and allocation profile, instead the call-graph is + flattened into a tree as follows: a call to a function that occurs + elsewhere on the current stack does not push another entry on the + stack, instead the costs for this call are aggregated into the + callerNote that this policy has changed slightly + in GHC 7.4.1 relative to earlier versions, and may yet change + further, feedback is welcome.. + + Inserting cost centres by hand + + Cost centres are just program annotations. When you say + to the compiler, it automatically + inserts a cost centre annotation around every binding not marked + INLINE in your program, but you are entirely free to add cost + centre annotations yourself. + + The syntax of a cost centre annotation is + + + {-# SCC "name" #-} <expression> + + + where "name" is an arbitrary string, + that will become the name of your cost centre as it appears + in the profiling output, and + <expression> is any Haskell + expression. An SCC annotation extends as + far to the right as possible when parsing. (SCC stands for "Set + Cost Centre"). The double quotes can be omitted + if name is a Haskell identifier, for example: + + + {-# SCC my_function #-} <expression> + + + Here is an example of a program with a couple of SCCs: + + +main :: IO () +main = do let xs = [1..1000000] + let ys = [1..2000000] + print $ {-# SCC last_xs #-} last xs + print $ {-# SCC last_init_xs #-} last $ init xs + print $ {-# SCC last_ys #-} last ys + print $ {-# SCC last_init_ys #-}last $ init ys + + + which gives this profile when run: + + +COST CENTRE MODULE no. entries %time %alloc %time %alloc + +MAIN MAIN 102 0 0.0 0.0 100.0 100.0 + CAF GHC.IO.Handle.FD 130 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Encoding.Iconv 122 0 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 111 0 0.0 0.0 0.0 0.0 + CAF Main 108 0 0.0 0.0 100.0 100.0 + main Main 204 1 0.0 0.0 100.0 100.0 + last_init_ys Main 210 1 25.0 27.4 25.0 27.4 + main.ys Main 209 1 25.0 39.2 25.0 39.2 + last_ys Main 208 1 12.5 0.0 12.5 0.0 + last_init_xs Main 207 1 12.5 13.7 12.5 13.7 + main.xs Main 206 1 18.8 19.6 18.8 19.6 + last_xs Main 205 1 6.2 0.0 6.2 0.0 + + + + + + Rules for attributing costs + + While running a program with profiling turned on, GHC + maintains a cost-centre stack behind the scenes, and attributes + any costs (memory allocation and time) to whatever the current + cost-centre stack is at the time the cost is incurred. + + The mechanism is simple: whenever the program evaluates an + expression with an SCC annotation, {-# SCC c -#} + E, the cost centre c is pushed on + the current stack, and the entry count for this stack is + incremented by one. The stack also sometimes has to be saved + and restored; in particular when the program creates a + thunk (a lazy suspension), the current + cost-centre stack is stored in the thunk, and restored when the + thunk is evaluated. In this way, the cost-centre stack is + independent of the actual evaluation order used by GHC at + runtime. + + At a function call, GHC takes the stack stored in the + function being called (which for a top-level function will be + empty), and appends it to the current + stack, ignoring any prefix that is identical to a prefix of the + current stack. + + We mentioned earlier that lazy computations, i.e. thunks, + capture the current stack when they are created, and restore + this stack when they are evaluated. What about top-level + thunks? They are "created" when the program is compiled, so + what stack should we give them? The technical name for a + top-level thunk is a CAF ("Constant Applicative Form"). GHC + assigns every CAF in a module a stack consisting of the single + cost centre M.CAF, where M + is the name of the module. It is also possible to give each CAF + a different stack, using the option + . + This is especially useful when compiling with + (as is default with + and higher), as constants in function bodies + will be lifted to the top-level and become CAFs. You will probably + need to consult the Core () in order + to determine what these CAFs correspond to. + + + + + Compiler options for profiling + + profilingoptions + optionsfor profiling + + + + + : + + + + To make use of the profiling system + all modules must be compiled and linked + with the option. Any + SCC annotations you've put in your source + will spring to life. + + Without a option, your + SCCs are ignored; so you can compile + SCC-laden code without changing + it. + + + + + There are a few other profiling-related compilation options. + Use them in addition to + . These do not have to be used consistently + for all modules in a program. + + + + + : + + + + All bindings not marked INLINE, + whether exported or not, top level or nested, will be given + automatic SCC annotations. Functions + marked INLINE must be given a cost centre manually. + + + + + + : + + cost centresautomatically inserting + + + GHC will automatically add SCC + annotations for all top-level bindings not marked INLINE. If + you want a cost centre on an INLINE function, you have to + add it manually. + + + + + + : + + cost centresautomatically inserting + + + GHC will automatically add SCC + annotations for all exported functions not marked + INLINE. If you want a cost centre on an INLINE function, you + have to add it manually. + + + + + + : + + + + Adds an automatic SCC annotation to + all call sites. This is particularly + useful when using profiling for the purposes of generating + stack traces; see the + function traceStack in the + module Debug.Trace, or + the -xc RTS flag + () for more + details. + + + + + + : + + + + The costs of all CAFs in a module are usually + attributed to one “big” CAF cost-centre. With + this option, all CAFs get their own cost-centre. An + “if all else fails” option… + + + + + + : + + + + Disables any previous , + , or + options. + + + + + + + : + + + + Disables any previous option. + + + + + + + : + + + + Tells GHC not to collect information about how often + functions are entered at runtime (the "entries" column of + the time profile), for this module. This tends to make the + profiled code run faster, and hence closer to the speed of + the unprofiled code, because GHC is able to optimise more + aggressively if it doesn't have to maintain correct entry + counts. This option can be useful if you aren't interested + in the entry counts (for example, if you only intend to do + heap profiling). + + + + + + + + + Time and allocation profiling + + To generate a time and allocation profile, give one of the + following RTS options to the compiled program when you run it (RTS + options should be enclosed between +RTS...-RTS + as usual): + + + + + or or : + + + + time profile + + + The option produces a standard + time profile report. It is written + into the file + program.prof. + + The option produces a more + detailed report containing the actual time and allocation + data as well. (Not used much.) + + The option produces the most detailed + report containing all cost centres in addition to the actual time + and allocation data. + + + + + + RTS + option + + Sets the interval that the RTS clock ticks at, which is + also the sampling interval of the time and allocation profile. + The default is 0.02 seconds. + + + + + + + RTS option + + + This option causes the runtime to print out the + current cost-centre stack whenever an exception is raised. + This can be particularly useful for debugging the location + of exceptions, such as the notorious Prelude.head: + empty list error. See . + + + + + + + + Profiling memory usage + + In addition to profiling the time and allocation behaviour + of your program, you can also generate a graph of its memory usage + over time. This is useful for detecting the causes of + space leaks, when your program holds on to + more memory at run-time that it needs to. Space leaks lead to + slower execution due to heavy garbage collector activity, and may + even cause the program to run out of memory altogether. + + To generate a heap profile from your program: + + + + Compile the program for profiling (). + + + Run it with one of the heap profiling options described + below (eg. for a basic producer profile). + This generates the file + prog.hp. + + + Run hp2ps to produce a Postscript + file, + prog.ps. The + hp2ps utility is described in detail in + . + + + Display the heap profile using a postscript viewer such + as Ghostview, or print it out on a + Postscript-capable printer. + + + + For example, here is a heap profile produced for the program given above in : + + + + + You might also want to take a look + at hp2any, + a more advanced suite of tools (not distributed with GHC) for + displaying heap profiles. + + + RTS options for heap profiling + + There are several different kinds of heap profile that can + be generated. All the different profile types yield a graph of + live heap against time, but they differ in how the live heap is + broken down into bands. The following RTS options select which + break-down to use: + + + + + + RTS option + + + (can be shortened to ). Breaks down the graph by the cost-centre stack which + produced the data. + + + + + + + RTS option + + + Break down the live heap by the module containing + the code which produced the data. + + + + + + + RTS option + + + Breaks down the graph by closure + description. For actual data, the description + is just the constructor name, for other closures it is a + compiler-generated string identifying the closure. + + + + + + + RTS option + + + Breaks down the graph by + type. For closures which have + function type or unknown/polymorphic type, the string will + represent an approximation to the actual type. + + + + + + + RTS option + + + Break down the graph by retainer + set. Retainer profiling is described in more + detail below (). + + + + + + + RTS option + + + Break down the graph by + biography. Biographical profiling + is described in more detail below (). + + + + + In addition, the profile can be restricted to heap data + which satisfies certain criteria - for example, you might want + to display a profile by type but only for data produced by a + certain module, or a profile by retainer for a certain type of + data. Restrictions are specified as follows: + + + + + name,... + RTS option + + + Restrict the profile to closures produced by + cost-centre stacks with one of the specified cost centres + at the top. + + + + + + name,... + RTS option + + + Restrict the profile to closures produced by + cost-centre stacks with one of the specified cost centres + anywhere in the stack. + + + + + + module,... + RTS option + + + Restrict the profile to closures produced by the + specified modules. + + + + + + desc,... + RTS option + + + Restrict the profile to closures with the specified + description strings. + + + + + + type,... + RTS option + + + Restrict the profile to closures with the specified + types. + + + + + + cc,... + RTS option + + + Restrict the profile to closures with retainer sets + containing cost-centre stacks with one of the specified + cost centres at the top. + + + + + + bio,... + RTS option + + + Restrict the profile to closures with one of the + specified biographies, where + bio is one of + lag, drag, + void, or use. + + + + + For example, the following options will generate a + retainer profile restricted to Branch and + Leaf constructors: + + +prog +RTS -hr -hdBranch,Leaf + + + There can only be one "break-down" option + (eg. in the example above), but there is no + limit on the number of further restrictions that may be applied. + All the options may be combined, with one exception: GHC doesn't + currently support mixing the and + options. + + There are three more options which relate to heap + profiling: + + + + + : + + + + Set the profiling (sampling) interval to + secs seconds (the default is + 0.1 second). Fractions are allowed: for example + will get 5 samples per second. + This only affects heap profiling; time profiles are always + sampled with the frequency of the RTS clock. See + for changing that. + + + + + + + RTS option + + + Include the memory occupied by threads in a heap + profile. Each thread takes up a small area for its thread + state in addition to the space allocated for its stack + (stacks normally start small and then grow as + necessary). + + This includes the main thread, so using + is a good way to see how much stack + space the program is using. + + Memory occupied by threads and their stacks is + labelled as “TSO” and “STACK” + respectively when displaying the profile by closure + description or type description. + + + + + + + RTS option + + + + Sets the maximum length of a cost-centre stack name in a + heap profile. Defaults to 25. + + + + + + + + + Retainer Profiling + + Retainer profiling is designed to help answer questions + like why is this data being retained?. We start + by defining what we mean by a retainer: + +

    + A retainer is either the system stack, an unevaluated + closure (thunk), or an explicitly mutable object. +
    + + In particular, constructors are not + retainers. + + An object B retains object A if (i) B is a retainer object and + (ii) object A can be reached by recursively following pointers + starting from object B, but not meeting any other retainer + objects on the way. Each live object is retained by one or more + retainer objects, collectively called its retainer set, or its + retainer set, or its + retainers. + + When retainer profiling is requested by giving the program + the option, a graph is generated which is + broken down by retainer set. A retainer set is displayed as a + set of cost-centre stacks; because this is usually too large to + fit on the profile graph, each retainer set is numbered and + shown abbreviated on the graph along with its number, and the + full list of retainer sets is dumped into the file + prog.prof. + + Retainer profiling requires multiple passes over the live + heap in order to discover the full retainer set for each + object, which can be quite slow. So we set a limit on the + maximum size of a retainer set, where all retainer sets larger + than the maximum retainer set size are replaced by the special + set MANY. The maximum set size defaults to 8 + and can be altered with the RTS + option: + + + + size + + Restrict the number of elements in a retainer set to + size (default 8). + + + + + + Hints for using retainer profiling + + The definition of retainers is designed to reflect a + common cause of space leaks: a large structure is retained by + an unevaluated computation, and will be released once the + computation is forced. A good example is looking up a value in + a finite map, where unless the lookup is forced in a timely + manner the unevaluated lookup will cause the whole mapping to + be retained. These kind of space leaks can often be + eliminated by forcing the relevant computations to be + performed eagerly, using seq or strictness + annotations on data constructor fields. + + Often a particular data structure is being retained by a + chain of unevaluated closures, only the nearest of which will + be reported by retainer profiling - for example A retains B, B + retains C, and C retains a large structure. There might be a + large number of Bs but only a single A, so A is really the one + we're interested in eliminating. However, retainer profiling + will in this case report B as the retainer of the large + structure. To move further up the chain of retainers, we can + ask for another retainer profile but this time restrict the + profile to B objects, so we get a profile of the retainers of + B: + + +prog +RTS -hr -hcB + + + This trick isn't foolproof, because there might be other + B closures in the heap which aren't the retainers we are + interested in, but we've found this to be a useful technique + in most cases. + + + + + Biographical Profiling + + A typical heap object may be in one of the following four + states at each point in its lifetime: + + + + The lag stage, which is the + time between creation and the first use of the + object, + + + the use stage, which lasts from + the first use until the last use of the object, and + + + The drag stage, which lasts + from the final use until the last reference to the object + is dropped. + + + An object which is never used is said to be in the + void state for its whole + lifetime. + + + + A biographical heap profile displays the portion of the + live heap in each of the four states listed above. Usually the + most interesting states are the void and drag states: live heap + in these states is more likely to be wasted space than heap in + the lag or use states. + + It is also possible to break down the heap in one or more + of these states by a different criteria, by restricting a + profile by biography. For example, to show the portion of the + heap in the drag or void state by producer: + + +prog +RTS -hc -hbdrag,void + + + Once you know the producer or the type of the heap in the + drag or void states, the next step is usually to find the + retainer(s): + + +prog +RTS -hr -hccc... + + + NOTE: this two stage process is required because GHC + cannot currently profile using both biographical and retainer + information simultaneously. + + + + Actual memory residency + + How does the heap residency reported by the heap profiler relate to + the actual memory residency of your program when you run it? You might + see a large discrepancy between the residency reported by the heap + profiler, and the residency reported by tools on your system + (eg. ps or top on Unix, or the + Task Manager on Windows). There are several reasons for this: + + + + There is an overhead of profiling itself, which is subtracted + from the residency figures by the profiler. This overhead goes + away when compiling without profiling support, of course. The + space overhead is currently 2 extra + words per heap object, which probably results in + about a 30% overhead. + + + + Garbage collection requires more memory than the actual + residency. The factor depends on the kind of garbage collection + algorithm in use: a major GC in the standard + generation copying collector will usually require 3L bytes of + memory, where L is the amount of live data. This is because by + default (see the option) we allow the old + generation to grow to twice its size (2L) before collecting it, and + we require additionally L bytes to copy the live data into. When + using compacting collection (see the + option), this is reduced to 2L, and can further be reduced by + tweaking the option. Also add the size of the + allocation area (currently a fixed 512Kb). + + + + The stack isn't counted in the heap profile by default. See the + option. + + + + The program text itself, the C stack, any non-heap data (eg. data + allocated by foreign libraries, and data allocated by the RTS), and + mmap()'d memory are not counted in the heap profile. + + + + + + + + <command>hp2ps</command>--heap profile to PostScript + + hp2ps + heap profiles + postscript, from heap profiles + + + Usage: + + +hp2ps [flags] [<file>[.hp]] + + + The program + hp2pshp2ps + program converts a heap profile as produced + by the runtime option into a + PostScript graph of the heap profile. By convention, the file to + be processed by hp2ps has a + .hp extension. The PostScript output is + written to <file>@.ps. If + <file> is omitted entirely, then the + program behaves as a filter. + + hp2ps is distributed in + ghc/utils/hp2ps in a GHC source + distribution. It was originally developed by Dave Wakeling as part + of the HBC/LML heap profiler. + + The flags are: + + + + + + + In order to make graphs more readable, + hp2ps sorts the shaded bands for each + identifier. The default sort ordering is for the bands with + the largest area to be stacked on top of the smaller ones. + The option causes rougher bands (those + representing series of values with the largest standard + deviations) to be stacked on top of smoother ones. + + + + + + + Normally, hp2ps puts the title of + the graph in a small box at the top of the page. However, if + the JOB string is too long to fit in a small box (more than + 35 characters), then hp2ps will choose to + use a big box instead. The option + forces hp2ps to use a big box. + + + + + + + Generate encapsulated PostScript suitable for + inclusion in LaTeX documents. Usually, the PostScript graph + is drawn in landscape mode in an area 9 inches wide by 6 + inches high, and hp2ps arranges for this + area to be approximately centred on a sheet of a4 paper. + This format is convenient of studying the graph in detail, + but it is unsuitable for inclusion in LaTeX documents. The + option causes the graph to be drawn in + portrait mode, with float specifying the width in inches, + millimetres or points (the default). The resulting + PostScript file conforms to the Encapsulated PostScript + (EPS) convention, and it can be included in a LaTeX document + using Rokicki's dvi-to-PostScript converter + dvips. + + + + + + + Create output suitable for the gs + PostScript previewer (or similar). In this case the graph is + printed in portrait mode without scaling. The output is + unsuitable for a laser printer. + + + + + + + Normally a profile is limited to 20 bands with + additional identifiers being grouped into an + OTHER band. The flag + removes this 20 band and limit, producing as many bands as + necessary. No key is produced as it won't fit!. It is useful + for creation time profiles with many bands. + + + + + + + Normally a profile is limited to 20 bands with + additional identifiers being grouped into an + OTHER band. The flag + specifies an alternative band limit (the maximum is + 20). + + requests the band limit to be + removed. As many bands as necessary are produced. However no + key is produced as it won't fit! It is useful for displaying + creation time profiles with many bands. + + + + + + + Use previous parameters. By default, the PostScript + graph is automatically scaled both horizontally and + vertically so that it fills the page. However, when + preparing a series of graphs for use in a presentation, it + is often useful to draw a new graph using the same scale, + shading and ordering as a previous one. The + flag causes the graph to be drawn using + the parameters determined by a previous run of + hp2ps on file. These + are extracted from file@.aux. + + + + + + + Use a small box for the title. + + + + + + + Normally trace elements which sum to a total of less + than 1% of the profile are removed from the + profile. The option allows this + percentage to be modified (maximum 5%). + + requests no trace elements to be + removed from the profile, ensuring that all the data will be + displayed. + + + + + + + Generate colour output. + + + + + + + Ignore marks. + + + + + + + Print out usage information. + + + + + + + Manipulating the hp file + +(Notes kindly offered by Jan-Willem Maessen.) + + +The FOO.hp file produced when you ask for the +heap profile of a program FOO is a text file with a particularly +simple structure. Here's a representative example, with much of the +actual data omitted: + +JOB "FOO -hC" +DATE "Thu Dec 26 18:17 2002" +SAMPLE_UNIT "seconds" +VALUE_UNIT "bytes" +BEGIN_SAMPLE 0.00 +END_SAMPLE 0.00 +BEGIN_SAMPLE 15.07 + ... sample data ... +END_SAMPLE 15.07 +BEGIN_SAMPLE 30.23 + ... sample data ... +END_SAMPLE 30.23 +... etc. +BEGIN_SAMPLE 11695.47 +END_SAMPLE 11695.47 + +The first four lines (JOB, DATE, SAMPLE_UNIT, VALUE_UNIT) form a +header. Each block of lines starting with BEGIN_SAMPLE and ending +with END_SAMPLE forms a single sample (you can think of this as a +vertical slice of your heap profile). The hp2ps utility should accept +any input with a properly-formatted header followed by a series of +*complete* samples. + + + + + Zooming in on regions of your profile + + +You can look at particular regions of your profile simply by loading a +copy of the .hp file into a text editor and deleting the unwanted +samples. The resulting .hp file can be run through hp2ps and viewed +or printed. + + + + + Viewing the heap profile of a running program + + +The .hp file is generated incrementally as your +program runs. In principle, running hp2ps on the incomplete file +should produce a snapshot of your program's heap usage. However, the +last sample in the file may be incomplete, causing hp2ps to fail. If +you are using a machine with UNIX utilities installed, it's not too +hard to work around this problem (though the resulting command line +looks rather Byzantine): + + head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \ + | hp2ps > FOO.ps + + +The command fgrep -n END_SAMPLE FOO.hp finds the +end of every complete sample in FOO.hp, and labels each sample with +its ending line number. We then select the line number of the last +complete sample using tail and cut. This is used as a +parameter to head; the result is as if we deleted the final +incomplete sample from FOO.hp. This results in a properly-formatted +.hp file which we feed directly to hp2ps. + + + + Viewing a heap profile in real time + + +The gv and ghostview programs +have a "watch file" option can be used to view an up-to-date heap +profile of your program as it runs. Simply generate an incremental +heap profile as described in the previous section. Run gv on your +profile: + + gv -watch -seascape FOO.ps + +If you forget the -watch flag you can still select +"Watch file" from the "State" menu. Now each time you generate a new +profile FOO.ps the view will update automatically. + + + +This can all be encapsulated in a little script: + + #!/bin/sh + head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \ + | hp2ps > FOO.ps + gv -watch -seascape FOO.ps & + while [ 1 ] ; do + sleep 10 # We generate a new profile every 10 seconds. + head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \ + | hp2ps > FOO.ps + done + +Occasionally gv will choke as it tries to read an incomplete copy of +FOO.ps (because hp2ps is still running as an update +occurs). A slightly more complicated script works around this +problem, by using the fact that sending a SIGHUP to gv will cause it +to re-read its input file: + + #!/bin/sh + head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \ + | hp2ps > FOO.ps + gv FOO.ps & + gvpsnum=$! + while [ 1 ] ; do + sleep 10 + head -`fgrep -n END_SAMPLE FOO.hp | tail -1 | cut -d : -f 1` FOO.hp \ + | hp2ps > FOO.ps + kill -HUP $gvpsnum + done + + + + + + + Profiling Parallel and Concurrent Programs + + Combining + and is perfectly fine, and indeed it is + possible to profile a program running on multiple processors + with the option.This feature + was added in GHC 7.4.1. + + + + Some caveats apply, however. In the current implementation, a + profiled program is likely to scale much less well than the + unprofiled program, because the profiling implementation uses + some shared data structures which require locking in the runtime + system. Furthermore, the memory allocation statistics collected + by the profiled program are stored in shared memory + but not locked (for speed), which means + that these figures might be inaccurate for parallel programs. + + + + We strongly recommend that you + use when compiling a + program to be profiled on multiple cores, because the entry + counts are also stored in shared memory, and continuously + updating them on multiple cores is extremely slow. + + + + We also recommend + using ThreadScope + for profiling parallel programs; it offers a GUI for visualising + parallel execution, and is complementary to the time and space + profiling features provided with GHC. + + + + + Observing Code Coverage + code coverage + Haskell Program Coverage + hpc + + + Code coverage tools allow a programmer to determine what parts + of their code have been actually executed, and which parts have + never actually been invoked. GHC has an option for generating + instrumented code that records code coverage as part of the + Haskell Program Coverage (HPC) toolkit, which is included with + GHC. HPC tools can be used to render the generated code coverage + information into human understandable format. + + + Correctly instrumented code provides coverage information of two + kinds: source coverage and boolean-control coverage. Source + coverage is the extent to which every part of the program was + used, measured at three different levels: declarations (both + top-level and local), alternatives (among several equations or + case branches) and expressions (at every level). Boolean + coverage is the extent to which each of the values True and + False is obtained in every syntactic boolean context (ie. guard, + condition, qualifier). + + + HPC displays both kinds of information in two primary ways: + textual reports with summary statistics (hpc report) and sources + with color mark-up (hpc markup). For boolean coverage, there + are four possible outcomes for each guard, condition or + qualifier: both True and False values occur; only True; only + False; never evaluated. In hpc-markup output, highlighting with + a yellow background indicates a part of the program that was + never evaluated; a green background indicates an always-True + expression and a red background indicates an always-False one. + + + A small example: Reciprocation + + + For an example we have a program, called Recip.hs, which computes exact decimal + representations of reciprocals, with recurring parts indicated in + brackets. + + +reciprocal :: Int -> (String, Int) +reciprocal n | n > 1 = ('0' : '.' : digits, recur) + | otherwise = error + "attempting to compute reciprocal of number <= 1" + where + (digits, recur) = divide n 1 [] +divide :: Int -> Int -> [Int] -> (String, Int) +divide n c cs | c `elem` cs = ([], position c cs) + | r == 0 = (show q, 0) + | r /= 0 = (show q ++ digits, recur) + where + (q, r) = (c*10) `quotRem` n + (digits, recur) = divide n r (c:cs) + +position :: Int -> [Int] -> Int +position n (x:xs) | n==x = 1 + | otherwise = 1 + position n xs + +showRecip :: Int -> String +showRecip n = + "1/" ++ show n ++ " = " ++ + if r==0 then d else take p d ++ "(" ++ drop p d ++ ")" + where + p = length d - r + (d, r) = reciprocal n + +main = do + number <- readLn + putStrLn (showRecip number) + main + + + HPC instrumentation is enabled with the -fhpc flag: + + + +$ ghc -fhpc Recip.hs + + GHC creates a subdirectory .hpc in the + current directory, and puts HPC index (.mix) + files in there, one for each module compiled. You don't need to + worry about these files: they contain information needed by the + hpc tool to generate the coverage data for + compiled modules after the program is run. + +$ ./Recip +1/3 += 0.(3) + + Running the program generates a file with the + .tix suffix, in this case + Recip.tix, which contains the coverage data + for this run of the program. The program may be run multiple + times (e.g. with different test data), and the coverage data from + the separate runs is accumulated in the .tix + file. To reset the coverage data and start again, just remove the + .tix file. + + + Having run the program, we can generate a textual summary of + coverage: + +$ hpc report Recip + 80% expressions used (81/101) + 12% boolean coverage (1/8) + 14% guards (1/7), 3 always True, + 1 always False, + 2 unevaluated + 0% 'if' conditions (0/1), 1 always False + 100% qualifiers (0/0) + 55% alternatives used (5/9) +100% local declarations used (9/9) +100% top-level declarations used (5/5) + + We can also generate a marked-up version of the source. + +$ hpc markup Recip +writing Recip.hs.html + + + This generates one file per Haskell module, and 4 index files, + hpc_index.html, hpc_index_alt.html, hpc_index_exp.html, + hpc_index_fun.html. + + + + Options for instrumenting code for coverage + + + + + + + Enable code coverage for the current module or modules + being compiled. + + Modules compiled with this option can be freely mixed + with modules compiled without it; indeed, most libraries + will typically be compiled without . + When the program is run, coverage data will only be + generated for those modules that were compiled with + , and the hpc tool + will only show information about those modules. + + + + + + + + The hpc toolkit + + The hpc command has several sub-commands: + +$ hpc +Usage: hpc COMMAND ... + +Commands: + help Display help for hpc or a single command +Reporting Coverage: + report Output textual report about program coverage + markup Markup Haskell source with program coverage +Processing Coverage files: + sum Sum multiple .tix files in a single .tix file + combine Combine two .tix files in a single .tix file + map Map a function over a single .tix file +Coverage Overlays: + overlay Generate a .tix file from an overlay file + draft Generate draft overlay that provides 100% coverage +Others: + show Show .tix file in readable, verbose format + version Display version for hpc + + + In general, these options act on a + .tix file after an instrumented binary has + generated it. + + + + The hpc tool assumes you are in the top-level directory of + the location where you built your application, and the .tix + file is in the same top-level directory. You can use the + flag to use hpc for any other directory, and use + multiple times to analyse programs compiled from + difference locations, as is typical for packages. + + + + We now explain in more details the major modes of hpc. + + + hpc report + hpc report gives a textual report of coverage. By default, + all modules and packages are considered in generating report, + unless include or exclude are used. The report is a summary + unless the flag is used. The option + allows for tools to use hpc to glean coverage. + + +$ hpc help report +Usage: hpc report [OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]] + +Options: + + --per-module show module level detail + --decl-list show unused decls + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --srcdir=DIR path to source directory of .hs files + multi-use of srcdir possible + --hpcdir=DIR append sub-directory that contains .mix files + default .hpc [rarely used] + --reset-hpcdirs empty the list of hpcdir's + [rarely used] + --xml-output show output in XML + + + hpc markup + hpc markup marks up source files into colored html. + + +$ hpc help markup +Usage: hpc markup [OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]] + +Options: + + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --srcdir=DIR path to source directory of .hs files + multi-use of srcdir possible + --hpcdir=DIR append sub-directory that contains .mix files + default .hpc [rarely used] + --reset-hpcdirs empty the list of hpcdir's + [rarely used] + --fun-entry-count show top-level function entry counts + --highlight-covered highlight covered code, rather that code gaps + --destdir=DIR path to write output to + + + + hpc sum + hpc sum adds together any number of .tix files into a single + .tix file. hpc sum does not change the original .tix file; it generates a new .tix file. + + +$ hpc help sum +Usage: hpc sum [OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]] +Sum multiple .tix files in a single .tix file + +Options: + + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --output=FILE output FILE + --union use the union of the module namespace (default is intersection) + + + hpc combine + hpc combine is the swiss army knife of hpc. It can be + used to take the difference between .tix files, to subtract one + .tix file from another, or to add two .tix files. hpc combine does not + change the original .tix file; it generates a new .tix file. + + +$ hpc help combine +Usage: hpc combine [OPTION] .. <TIX_FILE> <TIX_FILE> +Combine two .tix files in a single .tix file + +Options: + + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --output=FILE output FILE + --function=FUNCTION combine .tix files with join function, default = ADD + FUNCTION = ADD | DIFF | SUB + --union use the union of the module namespace (default is intersection) + + + hpc map + hpc map inverts or zeros a .tix file. hpc map does not + change the original .tix file; it generates a new .tix file. + + +$ hpc help map +Usage: hpc map [OPTION] .. <TIX_FILE> +Map a function over a single .tix file + +Options: + + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --output=FILE output FILE + --function=FUNCTION apply function to .tix files, default = ID + FUNCTION = ID | INV | ZERO + --union use the union of the module namespace (default is intersection) + + + hpc overlay and hpc draft + + Overlays are an experimental feature of HPC, a textual description + of coverage. hpc draft is used to generate a draft overlay from a .tix file, + and hpc overlay generates a .tix files from an overlay. + + +% hpc help overlay +Usage: hpc overlay [OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]] + +Options: + + --srcdir=DIR path to source directory of .hs files + multi-use of srcdir possible + --hpcdir=DIR append sub-directory that contains .mix files + default .hpc [rarely used] + --reset-hpcdirs empty the list of hpcdir's + [rarely used] + --output=FILE output FILE +% hpc help draft +Usage: hpc draft [OPTION] .. <TIX_FILE> + +Options: + + --exclude=[PACKAGE:][MODULE] exclude MODULE and/or PACKAGE + --include=[PACKAGE:][MODULE] include MODULE and/or PACKAGE + --srcdir=DIR path to source directory of .hs files + multi-use of srcdir possible + --hpcdir=DIR append sub-directory that contains .mix files + default .hpc [rarely used] + --reset-hpcdirs empty the list of hpcdir's + [rarely used] + --output=FILE output FILE + + + + Caveats and Shortcomings of Haskell Program Coverage + + HPC does not attempt to lock the .tix file, so multiple concurrently running + binaries in the same directory will exhibit a race condition. There is no way + to change the name of the .tix file generated, apart from renaming the binary. + HPC does not work with GHCi. + + + + + + Using “ticky-ticky” profiling (for implementors) + ticky-ticky profiling + + Because ticky-ticky profiling requires a certain familiarity + with GHC internals, we have moved the documentation to the + GHC developers wiki. Take a look at its overview + of the profiling options, which includeds a link to the + ticky-ticky profiling page. + + + + + diff --git a/docs/users_guide/runghc.xml b/docs/users_guide/runghc.xml new file mode 100644 index 00000000..7d61f83e --- /dev/null +++ b/docs/users_guide/runghc.xml @@ -0,0 +1,46 @@ + + + Using runghc + runghc + + runghc allows you to run Haskell programs without first having + to compile them. + + + Flags + + The runghc commandline looks like: + +runghc [runghc flags] [GHC flags] module [program args] + + The runghc flags are + -f /path/to/ghc, + which tells runghc which GHC to use to run the program, + and --help, which prints usage information. If it is + not given then runghc will search for GHC in the directories in the + system search path. + + runghc will try to work out where the boundaries between + [runghc flags] and + [GHC flags], and + [program args] and + module are, but you can use a + -- flag if it doesn't get it right. For example, + runghc -- -fwarn-unused-bindings Foo means runghc + won't try to use warn-unused-bindings as the path to GHC, + but instead will pass the flag to GHC. If a GHC flag doesn't start + with a dash then you need to prefix it with + --ghc-arg= or runghc will think that it is the + program to run, e.g. + runghc -package-db --ghc-arg=foo.conf Main.hs. + + + + + + + diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml new file mode 100644 index 00000000..a55a1fe5 --- /dev/null +++ b/docs/users_guide/runtime_control.xml @@ -0,0 +1,1589 @@ + + + Running a compiled program + + runtime control of Haskell programs + running, compiled program + RTS options + + To make an executable program, the GHC system compiles your + code and then links it with a non-trivial runtime system (RTS), + which handles storage management, thread scheduling, profiling, and + so on. + + + The RTS has a lot of options to control its behaviour. For + example, you can change the context-switch interval, the default + size of the heap, and enable heap profiling. These options can be + passed to the runtime system in a variety of different ways; the + next section () describes + the various methods, and the following sections describe the RTS + options themselves. + + + + Setting RTS options + RTS options, setting + + + There are four ways to set RTS options: + + + + + on the command line between +RTS ... -RTS, when running the program + () + + + + at compile-time, using + () + + + + with the environment variable GHCRTS + () + + + + by overriding “hooks” in the runtime system + () + + + + + + + Setting RTS options on the command line + + + If you set the -rtsopts flag appropriately + when linking (see ), you can + give RTS options on the command line when running your + program. + + + + When your Haskell program starts up, the RTS extracts + command-line arguments bracketed between + + and + + as its own. For example: + + + +$ ghc prog.hs -rtsopts +[1 of 1] Compiling Main ( prog.hs, prog.o ) +Linking prog ... +$ ./prog -f +RTS -H32m -S -RTS -h foo bar + + + + The RTS will + snaffle for itself, + and the remaining arguments -f -h foo bar + will be available to your program if/when it calls + System.Environment.getArgs. + + + + No option is required if the + runtime-system options extend to the end of the command line, as in + this example: + + + +% hls -ltr /usr/etc +RTS -A5m + + + + If you absolutely positively want all the rest of the options + in a command line to go to the program (and not the RTS), use a + . + + + + As always, for RTS options that take + sizes: If the last character of + size is a K or k, multiply by 1000; if an + M or m, by 1,000,000; if a G or G, by 1,000,000,000. (And any + wraparound in the counters is your + fault!) + + + + Giving a +RTS -? + RTS option option + will print out the RTS options actually available in your program + (which vary, depending on how you compiled). + + + NOTE: since GHC is itself compiled by GHC, you can change RTS + options in the compiler using the normal + +RTS ... -RTS + combination. eg. to set the maximum heap + size for a compilation to 128M, you would add + +RTS -M128m -RTS + to the command line. + + + + + Setting RTS options at compile time + + + GHC lets you change the default RTS options for a program at + compile time, using the -with-rtsopts + flag (). A common use for this is + to give your program a default heap and/or stack size that is + greater than the default. For example, to set -H128m + -K64m, link + with -with-rtsopts="-H128m -K64m". + + + + + Setting RTS options with the <envar>GHCRTS</envar> + environment variable + + RTS optionsfrom the environment + environment variablefor + setting RTS options + + + If the -rtsopts flag is set to + something other than none when linking, + RTS options are also taken from the environment variable + GHCRTSGHCRTS + . For example, to set the maximum heap size + to 2G for all GHC-compiled programs (using an + sh-like shell): + + + + GHCRTS='-M2G' + export GHCRTS + + + + RTS options taken from the GHCRTS environment + variable can be overridden by options given on the command + line. + + + + Tip: setting something like GHCRTS=-M2G + in your environment is a handy way to avoid Haskell programs + growing beyond the real memory in your machine, which is + easy to do by accident and can cause the machine to slow to + a crawl until the OS decides to kill the process (and you + hope it kills the right one). + + + + + “Hooks” to change RTS behaviour + + hooksRTS + RTS hooks + RTS behaviour, changing + + GHC lets you exercise rudimentary control over certain RTS + settings for any given program, by compiling in a + “hook” that is called by the run-time system. The RTS + contains stub definitions for these hooks, but by writing your + own version and linking it on the GHC command line, you can + override the defaults. + + Owing to the vagaries of DLL linking, these hooks don't work + under Windows when the program is built dynamically. + + You can change the messages printed when the runtime + system “blows up,” e.g., on stack overflow. The hooks + for these are as follows: + + + + + + void OutOfHeapHook (unsigned long, unsigned long) + OutOfHeapHook + + + The heap-overflow message. + + + + + + void StackOverflowHook (long int) + StackOverflowHook + + + The stack-overflow message. + + + + + + void MallocFailHook (long int) + MallocFailHook + + + The message printed if malloc + fails. + + + + + + + + + Miscellaneous RTS options + + + + + RTS + option + + Sets the interval that the RTS clock ticks at. The + runtime uses a single timer signal to count ticks; this timer + signal is used to control the context switch timer () and the heap profiling + timer . Also, the + time profiler uses the RTS timer signal directly to record + time profiling samples. + + Normally, setting the option + directly is not necessary: the resolution of the RTS timer is + adjusted automatically if a short interval is requested with + the or options. + However, setting is required in order to + increase the resolution of the time profiler. + + Using a value of zero disables the RTS clock + completely, and has the effect of disabling timers that + depend on it: the context switch timer and the heap profiling + timer. Context switches will still happen, but + deterministically and at a rate much faster than normal. + Disabling the interval timer is useful for debugging, because + it eliminates a source of non-determinism at runtime. + + + + + + RTS + option + + If yes (the default), the RTS installs signal handlers to catch + things like ctrl-C. This option is primarily useful for when + you are using the Haskell code as a DLL, and want to set your + own signal handlers. + + Note that even + with , the RTS + interval timer signal is still enabled. The timer signal + is either SIGVTALRM or SIGALRM, depending on the RTS + configuration and OS capabilities. To disable the timer + signal, use the -V0 RTS option (see + above). + + + + + + + RTS + option + + + WARNING: this option is for working around memory + allocation problems only. Do not use unless GHCi fails + with a message like “failed to mmap() memory below 2Gb”. If you need to use this option to get GHCi working + on your machine, please file a bug. + + + + On 64-bit machines, the RTS needs to allocate memory in the + low 2Gb of the address space. Support for this across + different operating systems is patchy, and sometimes fails. + This option is there to give the RTS a hint about where it + should be able to allocate memory in the low 2Gb of the + address space. For example, +RTS -xm20000000 + -RTS would hint that the RTS should allocate + starting at the 0.5Gb mark. The default is to use the OS's + built-in support for allocating memory in the low 2Gb if + available (e.g. mmap + with MAP_32BIT on Linux), or + otherwise -xm40000000. + + + + + + + RTS + option + + + [Default: 100k] This option relates to allocation + limits; for more about this see enableAllocationLimit. + When a thread hits its allocation limit, the RTS throws an + exception to the thread, and the thread gets an additional + quota of allocation before the exception is raised again, + the idea being so that the thread can execute its exception + handlers. The controls the size of + this additional quota. + + + + + + + + + RTS options to control the garbage collector + + garbage collectoroptions + RTS optionsgarbage collection + + There are several options to give you precise control over + garbage collection. Hopefully, you won't need any of these in + normal operation, but there are several things that can be tweaked + for maximum performance. + + + + + + size + RTS option + allocation area, size + + + [Default: 512k] Set the allocation area size + used by the garbage collector. The allocation area + (actually generation 0 step 0) is fixed and is never resized + (unless you use , below). + + Increasing the allocation area size may or may not + give better performance (a bigger allocation area means + worse cache behaviour but fewer garbage collections and less + promotion). + + With only 1 generation () the + option specifies the minimum allocation + area, since the actual size of the allocation area will be + resized according to the amount of data in the heap (see + , below). + + + + + + size + RTS option + allocation area, chunk size + + + [Default: 0, Example: + -n4m] When set to a non-zero value, + this option divides the allocation area ( + value) into chunks of the specified size. During execution, + when a processor exhausts its current chunk, it is given + another chunk from the pool until the pool is exhausted, at + which point a collection is triggered. + + This option is only useful when running in parallel + ( or greater). It allows the processor + cores to make better use of the available allocation area, + even when cores are allocating at different rates. Without + , each core gets a fixed-size allocation + area specified by the , and the first + core to exhaust its allocation area triggers a GC across all + the cores. This can result in a collection happening when + the allocation areas of some cores are only partially full, + so the purpose of the is to allow cores + that are allocating faster to get more of the allocation + area. This means less frequent GC, leading a lower GC + overhead for the same heap size. + + This is particularly useful in conjunction with larger + values, for example is a useful combination on larger core counts + (8+). + + + + + + + RTS option + garbage collectioncompacting + compacting garbage collection + + + Use a compacting algorithm for collecting the oldest + generation. By default, the oldest generation is collected + using a copying algorithm; this option causes it to be + compacted in-place instead. The compaction algorithm is + slower than the copying algorithm, but the savings in memory + use can be considerable. + + For a given heap size (using the + option), compaction can in fact reduce the GC cost by + allowing fewer GCs to be performed. This is more likely + when the ratio of live data to heap size is high, say + >30%. + + NOTE: compaction doesn't currently work when a single + generation is requested using the + option. + + + + + n + + + [Default: 30] Automatically enable + compacting collection when the live data exceeds + n% of the maximum heap size + (see the option). Note that the maximum + heap size is unlimited by default, so this option has no + effect unless the maximum heap size is set with + size. + + + + + + factor + RTS option + heap size, factor + + + + [Default: 2] This option controls the amount + of memory reserved for the older generations (and in the + case of a two space collector the size of the allocation + area) as a factor of the amount of live data. For example, + if there was 2M of live data in the oldest generation when + we last collected it, then by default we'll wait until it + grows to 4M before collecting it again. + + The default seems to work well here. If you have + plenty of memory, it is usually better to use + size than to + increase + factor. + + The setting will be automatically + reduced by the garbage collector when the maximum heap size + (the size + setting) is approaching. + + + + + + generations + RTS option + generations, number of + + + [Default: 2] Set the number of generations + used by the garbage collector. The default of 2 seems to be + good, but the garbage collector can support any number of + generations. Anything larger than about 4 is probably not a + good idea unless your program runs for a + long time, because the oldest + generation will hardly ever get collected. + + Specifying 1 generation with + gives you a simple 2-space collector, as you would expect. + In a 2-space collector, the option (see + above) specifies the minimum allocation + area size, since the allocation area will grow with the + amount of live data in the heap. In a multi-generational + collector the allocation area is a fixed size (unless you + use the option, see below). + + + + + + + RTS + option + + + [New in GHC 6.12.1] [Default: 0] + Use parallel GC in + generation gen and higher. + Omitting gen turns off the + parallel GC completely, reverting to sequential GC. + + The default parallel GC settings are usually suitable + for parallel programs (i.e. those + using par, Strategies, or with multiple + threads). However, it is sometimes beneficial to enable + the parallel GC for a single-threaded sequential program + too, especially if the program has a large amount of heap + data and GC is a significant fraction of runtime. To use + the parallel GC in a sequential program, enable the + parallel runtime with a suitable -N + option, and additionally it might be beneficial to + restrict parallel GC to the old generation + with -qg1. + + + + + + + RTS + option + + + + [New in GHC 6.12.1] [Default: 1] Use + load-balancing in the parallel GC in + generation gen and higher. + Omitting gen disables + load-balancing entirely. + + + Load-balancing shares out the work of GC between the + available cores. This is a good idea when the heap is + large and we need to parallelise the GC work, however it + is also pessimal for the short young-generation + collections in a parallel program, because it can harm + locality by moving data from the cache of the CPU where is + it being used to the cache of another CPU. Hence the + default is to do load-balancing only in the + old-generation. In fact, for a parallel program it is + sometimes beneficial to disable load-balancing entirely + with -qb. + + + + + + + size + RTS option + heap size, suggested + + + [Default: 0] This option provides a + “suggested heap size” for the garbage + collector. Think + of as a + variable option. It says: I want to + use at least size bytes, so use + whatever is left over to increase the + value. + + This option does not put + a limit on the heap size: the heap + may grow beyond the given size as usual. + + If size is omitted, then + the garbage collector will take the size of the heap at + the previous GC as the size. + This has the effect of allowing for a + larger value but without increasing + the overall memory requirements of the program. It can be + useful when the default small value is + suboptimal, as it can be in programs that create large + amounts of long-lived data. + + + + + + seconds + + RTS option + + idle GC + + + + (default: 0.3) In the threaded and SMP versions of the RTS (see + , ), a + major GC is automatically performed if the runtime has been idle + (no Haskell computation has been running) for a period of time. + The amount of idle time which must pass before a GC is performed is + set by the seconds + option. Specifying disables the idle GC. + + For an interactive application, it is probably a good idea to + use the idle GC, because this will allow finalizers to run and + deadlocked threads to be detected in the idle time when no Haskell + computation is happening. Also, it will mean that a GC is less + likely to happen when the application is busy, and so + responsiveness may be improved. However, if the amount of live data in + the heap is particularly large, then the idle GC can cause a + significant delay, and too small an interval could adversely affect + interactive responsiveness. + + This is an experimental feature, please let us know if it + causes problems and/or could benefit from further tuning. + + + + + + size + RTS option + stack, initial size + + + + [Default: 1k] Set the initial stack size for new + threads. (Note: this flag used to be + simply , but was renamed + to in GHC 7.2.1. The old name is + still accepted for backwards compatibility, but that may + be removed in a future version). + + + + Thread stacks (including the main thread's stack) live on + the heap. As the stack grows, new stack chunks are added + as required; if the stack shrinks again, these extra stack + chunks are reclaimed by the garbage collector. The + default initial stack size is deliberately small, in order + to keep the time and space overhead for thread creation to + a minimum, and to make it practical to spawn threads for + even tiny pieces of work. + + + + + + + size + RTS + option + stackchunk size + + + + [Default: 32k] Set the size of “stack + chunks”. When a thread's current stack overflows, a + new stack chunk is created and added to the thread's + stack, until the limit set by is + reached. + + + + The advantage of smaller stack chunks is that the garbage + collector can avoid traversing stack chunks if they are + known to be unmodified since the last collection, so + reducing the chunk size means that the garbage collector + can identify more stack as unmodified, and the GC overhead + might be reduced. On the other hand, making stack chunks + too small adds some overhead as there will be more + overflow/underflow between chunks. The default setting of + 32k appears to be a reasonable compromise in most cases. + + + + + + + size + RTS + option + stackchunk buffer size + + + + [Default: 1k] Sets the stack chunk buffer size. + When a stack chunk overflows and a new stack chunk is + created, some of the data from the previous stack chunk is + moved into the new chunk, to avoid an immediate underflow + and repeated overflow/underflow at the boundary. The + amount of stack moved is set by the + option. + + + Note that to avoid wasting space, this value should + typically be less than 10% of the size of a stack + chunk (), because in a chain of stack + chunks, each chunk will have a gap of unused space of this + size. + + + + + + + size + RTS option + stack, maximum size + + + [Default: 80% physical memory size] Set the + maximum stack size for an individual thread to + size bytes. If the thread + attempts to exceed this limit, it will be sent the + StackOverflow exception. The + limit can be disabled entirely by specifying a size of zero. + + + This option is there mainly to stop the program eating up + all the available memory in the machine if it gets into an + infinite loop. + + + + + + + n + RTS option + heap, minimum free + + + Minimum % n of heap + which must be available for allocation. The default is + 3%. + + + + + + size + RTS option + heap size, maximum + + + [Default: unlimited] Set the maximum heap size to + size bytes. The heap normally + grows and shrinks according to the memory requirements of + the program. The only reason for having this option is to + stop the heap growing without bound and filling up all the + available swap space, which at the least will result in the + program being summarily killed by the operating + system. + + The maximum heap size also affects other garbage + collection parameters: when the amount of live data in the + heap exceeds a certain fraction of the maximum heap size, + compacting collection will be automatically enabled for the + oldest generation, and the parameter + will be reduced in order to avoid exceeding the maximum heap + size. + + + + + + + RTS option + + + file + RTS option + + + file + RTS option + + + file + RTS option + + + + RTS option + + + These options produce runtime-system statistics, such + as the amount of time spent executing the program and in the + garbage collector, the amount of memory allocated, the + maximum size of the heap, and so on. The three + variants give different levels of detail: + collects the data but produces no output + produces a single line of output in the + same format as GHC's option, + produces a more detailed summary at the + end of the program, and additionally + produces information about each and every garbage + collection. + + The output is placed in + file. If + file is omitted, then the output + is sent to stderr. + + + If you use the -T flag then, you should + access the statistics using + GHC.Stats. + + + + If you use the -t flag then, when your + program finishes, you will see something like this: + + + +<<ghc: 36169392 bytes, 69 GCs, 603392/1065272 avg/max bytes residency (2 samples), 3M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.02 elapsed), 0.07 GC (0.07 elapsed) :ghc>> + + + + This tells you: + + + + + + The total number of bytes allocated by the program over the + whole run. + + + + + The total number of garbage collections performed. + + + + + The average and maximum "residency", which is the amount of + live data in bytes. The runtime can only determine the + amount of live data during a major GC, which is why the + number of samples corresponds to the number of major GCs + (and is usually relatively small). To get a better picture + of the heap profile of your program, use + the RTS option + (). + + + + + The peak memory the RTS has allocated from the OS. + + + + + The amount of CPU time and elapsed wall clock time while + initialising the runtime system (INIT), running the program + itself (MUT, the mutator), and garbage collecting (GC). + + + + + + You can also get this in a more future-proof, machine readable + format, with -t --machine-readable: + + + + [("bytes allocated", "36169392") + ,("num_GCs", "69") + ,("average_bytes_used", "603392") + ,("max_bytes_used", "1065272") + ,("num_byte_usage_samples", "2") + ,("peak_megabytes_allocated", "3") + ,("init_cpu_seconds", "0.00") + ,("init_wall_seconds", "0.00") + ,("mutator_cpu_seconds", "0.02") + ,("mutator_wall_seconds", "0.02") + ,("GC_cpu_seconds", "0.07") + ,("GC_wall_seconds", "0.07") + ] + + + + If you use the -s flag then, when your + program finishes, you will see something like this (the exact + details will vary depending on what sort of RTS you have, e.g. + you will only see profiling data if your RTS is compiled for + profiling): + + + + 36,169,392 bytes allocated in the heap + 4,057,632 bytes copied during GC + 1,065,272 bytes maximum residency (2 sample(s)) + 54,312 bytes maximum slop + 3 MB total memory in use (0 MB lost due to fragmentation) + + Generation 0: 67 collections, 0 parallel, 0.04s, 0.03s elapsed + Generation 1: 2 collections, 0 parallel, 0.03s, 0.04s elapsed + + SPARKS: 359207 (557 converted, 149591 pruned) + + INIT time 0.00s ( 0.00s elapsed) + MUT time 0.01s ( 0.02s elapsed) + GC time 0.07s ( 0.07s elapsed) + EXIT time 0.00s ( 0.00s elapsed) + Total time 0.08s ( 0.09s elapsed) + + %GC time 89.5% (75.3% elapsed) + + Alloc rate 4,520,608,923 bytes per MUT second + + Productivity 10.5% of total user, 9.1% of total elapsed + + + + + + The "bytes allocated in the heap" is the total bytes allocated + by the program over the whole run. + + + + + GHC uses a copying garbage collector by default. "bytes copied + during GC" tells you how many bytes it had to copy during + garbage collection. + + + + + The maximum space actually used by your program is the + "bytes maximum residency" figure. This is only checked during + major garbage collections, so it is only an approximation; + the number of samples tells you how many times it is checked. + + + + + The "bytes maximum slop" tells you the most space that is ever + wasted due to the way GHC allocates memory in blocks. Slop is + memory at the end of a block that was wasted. There's no way + to control this; we just like to see how much memory is being + lost this way. + + + + + The "total memory in use" tells you the peak memory the RTS has + allocated from the OS. + + + + + Next there is information about the garbage collections done. + For each generation it says how many garbage collections were + done, how many of those collections were done in parallel, + the total CPU time used for garbage collecting that generation, + and the total wall clock time elapsed while garbage collecting + that generation. + + + + The SPARKS statistic refers to the + use of Control.Parallel.par and related + functionality in the program. Each spark represents a call + to par; a spark is "converted" when it is + executed in parallel; and a spark is "pruned" when it is + found to be already evaluated and is discarded from the pool + by the garbage collector. Any remaining sparks are + discarded at the end of execution, so "converted" plus + "pruned" does not necessarily add up to the total. + + + + Next there is the CPU time and wall clock time elapsed broken + down by what the runtime system was doing at the time. + INIT is the runtime system initialisation. + MUT is the mutator time, i.e. the time spent actually running + your code. + GC is the time spent doing garbage collection. + RP is the time spent doing retainer profiling. + PROF is the time spent doing other profiling. + EXIT is the runtime system shutdown time. + And finally, Total is, of course, the total. + + + %GC time tells you what percentage GC is of Total. + "Alloc rate" tells you the "bytes allocated in the heap" divided + by the MUT CPU time. + "Productivity" tells you what percentage of the Total CPU and wall + clock elapsed times are spent in the mutator (MUT). + + + + + + The -S flag, as well as giving the same + output as the -s flag, prints information + about each GC as it happens: + + + + Alloc Copied Live GC GC TOT TOT Page Flts + bytes bytes bytes user elap user elap + 528496 47728 141512 0.01 0.02 0.02 0.02 0 0 (Gen: 1) +[...] + 524944 175944 1726384 0.00 0.00 0.08 0.11 0 0 (Gen: 0) + + + + For each garbage collection, we print: + + + + + + How many bytes we allocated this garbage collection. + + + + + How many bytes we copied this garbage collection. + + + + + How many bytes are currently live. + + + + + How long this garbage collection took (CPU time and elapsed + wall clock time). + + + + + How long the program has been running (CPU time and elapsed + wall clock time). + + + + + How many page faults occurred this garbage collection. + + + + + How many page faults occurred since the end of the last garbage + collection. + + + + + Which generation is being garbage collected. + + + + + + + + + + + + RTS options for concurrency and parallelism + + The RTS options related to concurrency are described in + , and those for parallelism in + . + + + + RTS options for profiling + + Most profiling runtime options are only available when you + compile your program for profiling (see + , and + for the runtime options). + However, there is one profiling option that is available + for ordinary non-profiled executables: + + + + + + RTS + option + + + (can be shortened to .) Generates a basic heap profile, in the + file prog.hp. + To produce the heap profile graph, + use hp2ps (see ). The basic heap profile is broken down by data + constructor, with other types of closures (functions, thunks, + etc.) grouped into broad categories + (e.g. FUN, THUNK). To + get a more detailed profile, use the full profiling + support (). + + + + + + + Tracing + + tracing + events + eventlog files + + + When the program is linked with the + option (), runtime events can + be logged in two ways: + + + + + + In binary format to a file for later analysis by a + variety of tools. One such tool + is ThreadScopeThreadScope, + which interprets the event log to produce a visual parallel + execution profile of the program. + + + + + As text to standard output, for debugging purposes. + + + + + + + + + RTS option + + + + Log events in binary format to the + file program.eventlog. + Without any flags specified, this logs a + default set of events, suitable for use with tools like ThreadScope. + + + + For some special use cases you may want more control over which + events are included. The flags is a + sequence of zero or more characters indicating which classes of + events to log. Currently these the classes of events that can + be enabled/disabled: + + + — scheduler events, including Haskell + thread creation and start/stop events. Enabled by default. + + + — GC events, including GC start/stop. + Enabled by default. + + + — parallel sparks (sampled). + Enabled by default. + + + — parallel sparks (fully accurate). + Disabled by default. + + + — user events. These are events emitted + from Haskell code using functions such as + Debug.Trace.traceEvent. Enabled by default. + + + + + + You can disable specific classes, or enable/disable all classes at + once: + + + — enable all event classes listed above + + + — disable the + given class of events, for any event class listed above or + for all classes + + + For example, would disable all event classes + () except for GC events (). + + + + For spark events there are two modes: sampled and fully accurate. + There are various events in the life cycle of each spark, usually + just creating and running, but there are some more exceptional + possibilities. In the sampled mode the number of occurrences of each + kind of spark event is sampled at frequent intervals. In the fully + accurate mode every spark event is logged individually. The latter + has a higher runtime overhead and is not enabled by default. + + + + The format of the log file is described by the header + EventLogFormat.h that comes with + GHC, and it can be parsed in Haskell using + the ghc-events + library. To dump the contents of + a .eventlog file as text, use the + tool ghc-events show that comes with + the ghc-events + package. + + + + + + + flags + RTS option + + + + Log events as text to standard output, instead of to + the .eventlog file. + The flags are the same as + for , with the additional + option t which indicates that the + each event printed should be preceded by a timestamp value + (in the binary .eventlog file, all + events are automatically associated with a timestamp). + + + + + + + + The debugging + options also + generate events which are logged using the tracing framework. + By default those events are dumped as text to stdout + ( + implies ), but they may instead be stored in + the binary eventlog file by using the + option. + + + + + RTS options for hackers, debuggers, and over-interested + souls + + RTS options, hacking/debugging + + These RTS options might be used (a) to avoid a GHC bug, + (b) to see “what's really happening”, or + (c) because you feel like it. Not recommended for everyday + use! + + + + + + + RTS option + + + Sound the bell at the start of each (major) garbage + collection. + + Oddly enough, people really do use this option! Our + pal in Durham (England), Paul Callaghan, writes: “Some + people here use it for a variety of + purposes—honestly!—e.g., confirmation that the + code/machine is doing something, infinite loop detection, + gauging cost of recently added code. Certain people can even + tell what stage [the program] is in by the beep + pattern. But the major use is for annoying others in the + same office…” + + + + + + x + -DRTS option + + + + An RTS debugging flag; only available if the program was + linked with the option. Various + values of x are provided to + enable debug messages and additional runtime sanity checks + in different subsystems in the RTS, for + example +RTS -Ds -RTS enables debug + messages from the scheduler. + Use +RTS -? to find out which + debug flags are supported. + + + + Debug messages will be sent to the binary event log file + instead of stdout if the option is + added. This might be useful for reducing the overhead of + debug tracing. + + + + + + + file + RTS option + ticky ticky profiling + profilingticky ticky + + + Produce “ticky-ticky” statistics at the + end of the program run (only available if the program was + linked with ). + The file business works just like + on the RTS option, above. + + For more information on ticky-ticky profiling, see + . + + + + + + + RTS option + + + (Only available when the program is compiled for + profiling.) When an exception is raised in the program, + this option causes a stack trace to be + dumped to stderr. + + This can be particularly useful for debugging: if your + program is complaining about a head [] + error and you haven't got a clue which bit of code is + causing it, compiling with -prof + -fprof-auto and running with +RTS -xc + -RTS will tell you exactly the call stack at the + point the error was raised. + + The output contains one report for each exception + raised in the program (the program might raise and catch + several exceptions during its execution), where each report + looks something like this: + + + +*** Exception raised (reporting due to +RTS -xc), stack trace: + GHC.List.CAF + --> evaluated by: Main.polynomial.table_search, + called from Main.polynomial.theta_index, + called from Main.polynomial, + called from Main.zonal_pressure, + called from Main.make_pressure.p, + called from Main.make_pressure, + called from Main.compute_initial_state.p, + called from Main.compute_initial_state, + called from Main.CAF + ... + + The stack trace may often begin with something + uninformative like GHC.List.CAF; this is + an artifact of GHC's optimiser, which lifts out exceptions + to the top-level where the profiling system assigns them to + the cost centre "CAF". However, +RTS -xc + doesn't just print the current stack, it looks deeper and + reports the stack at the time the CAF was evaluated, and it + may report further stacks until a non-CAF stack is found. In + the example above, the next stack (after --> + evaluated by) contains plenty of information about + what the program was doing when it evaluated head + []. + + Implementation details aside, the function names in + the stack should hopefully give you enough clues to track + down the bug. + + + See also the function traceStack in the + module Debug.Trace for another way to + view call stacks. + + + + + + + + RTS option + + + Turn off “update-frame + squeezing” at garbage-collection time. (There's no + particularly good reason to turn it off, except to ensure + the accuracy of certain data collected regarding thunk entry + counts.) + + + + + + + + Getting information about the RTS + + RTS + + It is possible to ask the RTS to give some information about + itself. To do this, use the flag, e.g. + +$ ./a.out +RTS --info + [("GHC RTS", "YES") + ,("GHC version", "6.7") + ,("RTS way", "rts_p") + ,("Host platform", "x86_64-unknown-linux") + ,("Host architecture", "x86_64") + ,("Host OS", "linux") + ,("Host vendor", "unknown") + ,("Build platform", "x86_64-unknown-linux") + ,("Build architecture", "x86_64") + ,("Build OS", "linux") + ,("Build vendor", "unknown") + ,("Target platform", "x86_64-unknown-linux") + ,("Target architecture", "x86_64") + ,("Target OS", "linux") + ,("Target vendor", "unknown") + ,("Word size", "64") + ,("Compiler unregisterised", "NO") + ,("Tables next to code", "YES") + ] + + The information is formatted such that it can be read as a + of type [(String, String)]. Currently the following + fields are present: + + + + + GHC RTS + + Is this program linked against the GHC RTS? (always + "YES"). + + + + + GHC version + + The version of GHC used to compile this program. + + + + + RTS way + + The variant (“way”) of the runtime. The + most common values are rts_v (vanilla), + rts_thr (threaded runtime, i.e. linked using the + -threaded option) and rts_p + (profiling runtime, i.e. linked using the -prof + option). Other variants include debug + (linked using -debug), and + dyn (the RTS is + linked in dynamically, i.e. a shared library, rather than statically + linked into the executable itself). These can be combined, + e.g. you might have rts_thr_debug_p. + + + + + + Target platform, + Target architecture, + Target OS, + Target vendor + + + These are the platform the program is compiled to run on. + + + + + + Build platform, + Build architecture, + Build OS, + Build vendor + + + These are the platform where the program was built + on. (That is, the target platform of GHC itself.) Ordinarily + this is identical to the target platform. (It could potentially + be different if cross-compiling.) + + + + + + Host platform, + Host architecture + Host OS + Host vendor + + + These are the platform where GHC itself was compiled. + Again, this would normally be identical to the build and + target platforms. + + + + + Word size + + Either "32" or "64", + reflecting the word size of the target platform. + + + + + Compiler unregistered + + Was this program compiled with an + “unregistered” + version of GHC? (I.e., a version of GHC that has no platform-specific + optimisations compiled in, usually because this is a currently + unsupported platform.) This value will usually be no, unless you're + using an experimental build of GHC. + + + + + Tables next to code + + Putting info tables directly next to entry code is a useful + performance optimisation that is not available on all platforms. + This field tells you whether the program has been compiled with + this optimisation. (Usually yes, except on unusual platforms.) + + + + + + + + + diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml new file mode 100644 index 00000000..16f2bbd7 --- /dev/null +++ b/docs/users_guide/safe_haskell.xml @@ -0,0 +1,793 @@ + + + Safe Haskell + safe haskell + + + Safe Haskell is an extension to the Haskell language that is implemented in + GHC as of version 7.2. It allows for unsafe code to be securely included in a + trusted code base by restricting the features of GHC Haskell the code is + allowed to use. Put simply, it makes the types of programs trustable. Safe + Haskell is aimed to be as minimal as possible while still providing strong + enough guarantees about compiled Haskell code for more advance secure systems + to be built on top of it. + + + + While this is the use case that Safe Haskell was motivated by it is important + to understand that what Safe Haskell is tracking and enforcing is a stricter + form of type safety than is usually guaranteed in Haskell. As part of this, + Safe Haskell is run during every compilation of GHC, tracking safety and + inferring it even for modules that don't explicitly use Safe Haskell. Please + refer to section for more details of this. + This also means that there are some design choices that from a security point + of view may seem strange but when thought of from the angle of tracking type + safety are logical. Feedback on the current design and this tension between + the security and type safety view points is welcome. + + + + The design of Safe Haskell covers the following aspects: + + + A safe language dialect of + Haskell that provides guarantees about the code. It allows types and + module boundaries to be trusted. + + A safe import extension that specifies that + the module being imported must be trusted. + + A definition of trust (or safety) and how it + operates, along with ways of defining and changing the trust of modules + and packages. + + + + + + Safe Haskell, however, does not offer compilation + safety. During compilation time it is possible for arbitrary processes to be + launched, using for example the custom + pre-processor flag. This can be manipulated to either compromise a + users system at compilation time, or to modify the source code just before + compilation to try to alter set Safe Haskell flags. This is discussed further + in section . + + + + Uses of Safe Haskell + safe haskell uses + + + Safe Haskell has been designed with two use cases in mind: + + + Enforcing strict type safety at compile time + Compiling and executing untrusted code + + + + + Strict type-safety (good style) + + Haskell offers a powerful type system and separation of pure and + effectual functions through the IO monad. There are + several loop holes in the type system though, the most obvious offender + being the unsafePerformIO :: IO a -> a function. The + safe language dialect of Safe Haskell disallows the use of such + functions. This can be useful for a variety of purposes as it makes + Haskell code easier to analyse and reason about. It also codifies an + existing culture in the Haskell community of trying to avoid using such + unsafe functions unless absolutely necessary. As such using the safe + language (through the flag) can be thought of as + a way of enforcing good style, similar to the function of + . + + + + Building secure systems (restricted IO Monads) + secure haskell + + + Systems such as information flow control security, capability based + security systems and DSLs for working with encrypted data.. etc can be + built in the Haskell language simply as a library. However they require + guarantees about the properties of the Haskell language that aren't true + in the general case where uses of functions like unsafePerformIO + are allowed. Safe Haskell is designed to give users enough + guarantees about the safety properties of compiled code so that such + secure systems can be built. + + + + As an example lets define an interface for a plugin system where the + plugin authors are untrusted, possibly malicious third-parties. We do + this by restricting the plugin interface to pure functions or to a + restricted IO monad that we have defined that only + allows a safe subset of IO actions to be executed. We + define the plugin interface here so that it requires the plugin module, + Danger, to export a single computation, + Danger.runMe, of type RIO (), where + RIO is a new monad defined as follows: + + + + -- Either of the following Safe Haskell pragmas would do + {-# LANGUAGE Trustworthy #-} + {-# LANGUAGE Safe #-} + + module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where + + -- Notice that symbol UnsafeRIO is not exported from this module! + newtype RIO a = UnsafeRIO { runRIO :: IO a } + + instance Monad RIO where + return = UnsafeRIO . return + (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k + + -- Returns True iff access is allowed to file name + pathOK :: FilePath -> IO Bool + pathOK file = {- Implement some policy based on file name -} + + rioReadFile :: FilePath -> RIO String + rioReadFile file = UnsafeRIO $ do + ok <- pathOK file + if ok then readFile file else return "" + + rioWriteFile :: FilePath -> String -> RIO () + rioWriteFile file contents = UnsafeRIO $ do + ok <- pathOK file + if ok then writeFile file contents else return () + + + We compile Danger using the new Safe Haskell flag: + + + {-# LANGUAGE Safe #-} + module Danger ( runMe ) where + + runMe :: RIO () + runMe = ... + + + + Before going into the Safe Haskell details, lets point out some of + the reasons this design would fail without Safe Haskell: + + + + The design attempts to restrict the operations that Danger + can perform by using types, specifically the RIO + type wrapper around IO. The author of Danger can + subvert this though by simply writing arbitrary + IO actions and using unsafePerformIO :: + IO a -> a to execute them as pure functions. + + The design also relies on the Danger module not being able + to access the UnsafeRIO constructor. + Unfortunately Template Haskell can be used to subvert module + boundaries and so could be used to gain access to this constructor. + + There is no way to place restrictions on the modules that + the untrusted Danger module can import. This gives the author of + Danger a very large attack surface, essentially any package + currently installed on the system. Should any of these packages + have a vulnerability then the Danger module can exploit this. The + only way to stop this would be to patch or remove packages with + known vulnerabilities even if they should only be used by + trusted code such as the RIO module. + + + + + To stop these attacks Safe Haskell can be used. This is done by compiling + the RIO module with the flag and compiling + the Danger module with the flag. + + + + The use of the flag to compile the + Danger module restricts the features of Haskell that can be used + to a safe subset. This + includes disallowing unsafePerformIO, + Template Haskell, pure FFI functions, RULES and restricting the + operation of Overlapping Instances. The + flag also restricts the modules can be imported by Danger to + only those that are considered trusted. Trusted modules are + those compiled with , where GHC provides + a mechanical guarantee that the code is safe. Or those modules + compiled with , where the module + author claims that the module is Safe. + + + + This is why the RIO module is compiled with + , to allow the Danger module to import it. + The flag doesn't place any restrictions on + the module like does. Instead the module author + claims that while code may use unsafe features internally, it only + exposes an API that can used in a safe manner. The use of + by itself marks the module as trusted. + There is an issue here as may be used by + an arbitrary module and module author. To control the use of trustworthy + modules it is recommended to use the + flag. This flag adds an extra requirement to the trust check for + trustworthy modules, such that for trustworthy modules to be considered + trusted, and allowed to be used in compiled + code, the client C compiling the code must tell GHC that they trust the + package the trustworthy module resides in. This is essentially a way of + for C to say, while this package contains trustworthy modules that can be + used by untrusted modules compiled with , I trust + the author(s) of this package and trust the modules only expose a safe + API. The trust of a package can be changed at any time, so if a + vulnerability found in a package, C can declare that package untrusted so + that any future compilation against that package would fail. For a more + detailed overview of this mechanism see . + + + + In the example, Danger can import module RIO because RIO is marked + trustworthy. Thus, Danger can make use of the rioReadFile and + rioWriteFile functions to access permitted file names. The main + application then imports both RIO and Danger. To run the plugin, it calls + RIO.runRIO Danger.runMe within the IO monad. The application is safe in + the knowledge that the only IO to ensue will be to files whose paths were + approved by the pathOK test. + + + + + + Safe Language + safe language + + The Safe Haskell safe language guarantees the + following properties: + + + Referential transparency — Functions + in the safe language are deterministic, evaluating them will not + cause any side effects. Functions in the IO monad + are still allowed and behave as usual. Any pure function though, as + according to its type, is guaranteed to indeed be pure. This property + allows a user of the safe language to trust the types. This means, + for example, that the unsafePerformIO :: IO a -> a + function is disallowed in the safe language. + + + Module boundary control — Haskell + code compiled using the safe language is guaranteed to only access + symbols that are publicly available to it through other modules export + lists. An important part of this is that safe compiled code is not + able to examine or create data values using data constructors + that it cannot import. If a module M establishes some invariants + through careful use of its export list then code compiled using the + safe language that imports M is guaranteed to respect those invariants. + Because of this, Template + Haskell is disabled in the safe language as it can be + used to violate this property. + + Semantic consistency — The safe + language is strictly a subset of Haskell as implemented by GHC. Any + expression that compiles in the safe language has the same meaning as + it does when compiled in normal Haskell. In addition, in any module + that imports a safe language module, expressions that compile both + with and without the safe import have the same meaning in both cases. + That is, importing a module using the safe language cannot change the + meaning of existing code that isn't dependent on that module. So for + example, there are some restrictions placed on the + Overlapping Instances + extension as it can violate this property. + + + + + These three properties guarantee that in the safe language you can trust + the types, can trust that module export lists are respected and can trust + that code that successfully compiles has the same meaning as it normally + would. + + + Lets now look at the details of the safe language. In the safe language + dialect (enabled by ) we disable completely the + following features: + + + TemplateHaskell — Is particularly + dangerous, as it can cause side effects even at compilation time and + can be used to access constructors of abstract data types. + + + In the safe language dialect we restrict the following features: + + ForeignFunctionInterface — This is + mostly safe, but foreign import declarations that import a function + with a non-IO type are disallowed. All FFI imports must reside in the + IO Monad. + RULES — As they can change the + behaviour of trusted code in unanticipated ways, violating semantic + consistency, they are restricted in function. Specifically any RULES + defined in a module M compiled with are + dropped. RULES defined in trustworthy modules that M imports are still + valid and will fire as usual. + OverlappingInstances — This + extension can be used to violate semantic consistency, because + malicious code could redefine a type instance (by containing a more + specific instance definition) in a way that changes the behaviour of + code importing the untrusted module. The extension is not disabled for + a module M compiled with but restricted. While M + can define overlapping instance declarations, they can only overlap + other instance declaration defined in M. If in a module N that imports + M, at a call site that uses a type-class function there is a choice of + which instance to use (i.e. an overlap) and the most specific instances + is from M, then all the other choices must also be from M. If not, a + compilation error will occur. A simple way to think of this is a + same origin policy for overlapping instances + defined in Safe compiled modules. + Data.Typeable — We restrict Typeable + instances to only derived ones (offered by GHC through the + + extension). Hand crafted instances of the Typeable type class + are not allowed in Safe Haskell as this can easily be abused to + unsafely coerce between types. + + + + + Safe Imports + safe imports + + Safe Haskell enables a small extension to the usual import syntax of + Haskell, adding a safe keyword: + + impdecl -> import [safe] [qualified] modid [as modid] [impspec] + + + When used, the module being imported with the safe keyword must be a + trusted module, otherwise a compilation error will occur. The safe import + extension is enabled by either of the , + , or + flags and corresponding PRAGMA's. When the flag + is used, the safe keyword is allowed but meaningless, every import + is required to be safe regardless. + + + + Trust and Safe Haskell Modes + safe haskell trust + trust + + The Safe Haskell extension introduces the following three language flags: + + + -XSafe — Enables the safe language + dialect, asking GHC to guarantee trust. The safe language dialect + requires that all imports be trusted or a compilation error will + occur. + -XTrustworthy — Means that while + this module may invoke unsafe functions internally, the module's author + claims that it exports an API that can't be used in an unsafe way. This + doesn't enable the safe language or place any restrictions on the + allowed Haskell code. The trust guarantee is provided by the module + author, not GHC. An import statement with the safe keyword results in a + compilation error if the imported module is not trusted. An import + statement without the keyword behaves as usual and can import any + module whether trusted or not. + -XUnsafe — Marks the module being + compiled as unsafe so that modules compiled using + can't import it. + + + + + The procedure to check if a module is trusted or not depends on if the + flag is present. The check is very similar + in both cases with the presence of the + flag simply enabling an extra requirement for trustworthy modules to be + regarded as trusted. + + + + Trust check (<option>-fpackage-trust</option> disabled) + trust check + + + A module M in a package P is trusted by a client C + if and only if: + + + Both of these hold: + + The module was compiled with + + All of M's direct imports are trusted by C + + + OR all of these hold: + + The module was compiled with + + All of M's direct safe imports are trusted by C + + + + + + + The above definition of trust has an issue. Any module can be compiled + with -XTrustworthy and it will be trusted regardless of what it does. To + control this there is an additional definition of package trust (enabled + with the flag). The point of package + trusts is to require that the client C explicitly say which packages are + allowed to contain trustworthy modules. That is, C establishes that it + trusts a package P and its author and so trust the modules in P that use + . When package trust is enabled, any + modules that are considered trustworthy but reside in a package that + isn't trusted are not considered trusted. A more formal definition is + given in the next section. + + + + + Trust check (<option>-fpackage-trust</option> enabled) + trust check + -fpackage-trust + + + When the flag is enabled, whether or not + a module is trusted depends on a notion of trust for packages, which is + determined by the client C invoking GHC (i.e. you). A package P + is trusted when one of these hold: + + C's package database records that P is trusted (and no + command-line arguments override this) + C's command-line flags say to trust P regardless of what is + recorded in the package database. + + + + + In either case, C is the only authority on package trust. It is up to the + client to decide which packages they + trust. + + + + When the flag is used a module M from + package P is trusted by a client C if and only if: + + + Both of these hold: + + The module was compiled with + + All of M's direct imports are trusted by C + + + OR all of these hold: + + The module was compiled with + + All of M's direct safe imports are trusted by C + Package P is trusted by C + + + + + + + For the first trust definition the trust guarantee is provided by GHC + through the restrictions imposed by the safe language. For the second + definition of trust, the guarantee is provided initially by the + module author. The client C then establishes that they trust the + module author by indicating they trust the package the module resides + in. This trust chain is required as GHC provides no guarantee for + -XTrustworthy compiled modules. + + + + The reason there are two modes of checking trust is that the extra + requirement enabled by causes the design + of Safe Haskell to be invasive. Packages using Safe Haskell when the flag + is enabled may or may not compile depending on the state of trusted + packages on a users machine. A maintainer of a package + foo that uses Safe Haskell so that security conscious + Haskellers can use foo now may have other users of + foo who don't know or care about Safe Haskell + complaining about compilation problems they are having with + foobecause a package barthat foo + requires, isn't trusted on their machine. In this sense, the + flag can be thought of as a flag to + properly turn on Safe Haskell while without it, it's operating in a + covert fashion. + + + + Having the flag also nicely unifies the + semantics of how Safe Haskell works when used explicitly and how modules + are inferred as safe. + + + + + Example + + + Package Wuggle: + {-# LANGUAGE Safe #-} + module Buggle where + import Prelude + f x = ...blah... + + Package P: + {-# LANGUAGE Trustworthy #-} + module M where + import System.IO.Unsafe + import safe Buggle + + + + Suppose a client C decides to trust package P. Then does C trust module + M? To decide, GHC must check M's imports — M imports + System.IO.Unsafe. M was compiled with , so + P's author takes responsibility for that import. C trusts P's author, so + C trusts M to only use its unsafe imports in a safe and consistent + manner with respect to the API M exposes. M also has a safe import of + Buggle, so for this import P's author takes no responsibility for the + safety, so GHC must check whether Buggle is trusted by C. Is it? Well, + it is compiled with , so the code in Buggle + itself is machine-checked to be OK, but again under the assumption that + all of Buggle's imports are trusted by C. Prelude comes from base, which + C trusts, and is compiled with (While + Prelude is typically imported implicitly, it still obeys the same rules + outlined here). So Buggle is considered trusted. + + + + Notice that C didn't need to trust package Wuggle; the machine checking + is enough. C only needs to trust packages that contain + modules. + + + + + Trustworthy Requirements + trustworthy + + Module authors using the language + extension for a module M should ensure that M's public API (the symbols + exposed by its export list) can't be used in an unsafe manner. This mean + that symbols exported should respect type safety and referential + transparency. + + + + Package Trust + package trust + + Safe Haskell gives packages a new Boolean property, that of trust. + Several new options are available at the GHC command-line to specify the + trust property of packages: + + + -trust P — Exposes package P if it + was hidden and considers it a trusted package regardless of the + package database. + -distrust P — Exposes package P if + it was hidden and considers it an untrusted package regardless of the + package database. + -distrust-all-packages — Considers + all packages distrusted unless they are explicitly set to be trusted + by subsequent command-line options. + + + To set a package's trust property in the package database please refer to + . + + + + + + Safe Haskell Inference + safe inference + + + In the case where a module is compiled without one of + , or + being used, GHC will try to figure out itself if + the module can be considered safe. This safety inference will never mark a + module as trustworthy, only as either unsafe or as safe. GHC uses a simple + method to determine this for a module M: If M would compile without error + under the flag, then M is marked as safe. If M + would fail to compile under the flag, then it is + marked as unsafe. + + + + When should you use Safe Haskell inference and when should you use an + explicit flag? The later case should be used when + you have a hard requirement that the module be safe. That is, the + use cases outlined and the purpose + for which Safe Haskell is intended: compiling untrusted code. Safe + inference is meant to be used by ordinary Haskell programmers. Users who + probably don't care about Safe Haskell. + + + + Say you are writing a Haskell library. Then you probably just want to use + Safe inference. Assuming you avoid any unsafe features of the language then + your modules will be marked safe. This is a benefit as now a user of your + library who may want to use it as part of an API exposed to untrusted code + can use the library without change. If there wasn't safety inference then + either the writer of the library would have to explicitly use Safe Haskell, + which is an unreasonable expectation of the whole Haskell community. Or the + user of the library would have to wrap it in a shim that simply re-exported + your API through a trustworthy module, an annoying practice. + + + + + Safe Haskell Flag Summary + safe haskell flags + + In summary, Safe Haskell consists of the following three language flags: + + + + -XSafe + -XSafe + To be trusted, all of the module's direct imports must be + trusted, but the module itself need not reside in a trusted + package, because the compiler vouches for its trustworthiness. The + "safe" keyword is allowed but meaningless in import statements, + every import is required to be safe regardless. + + Module Trusted — Yes + Haskell Language — Restricted to Safe + Language + Imported Modules — All forced to be + safe imports, all must be trusted. + + + + + + -XTrustworthy + -XTrustworthy + This establishes that the module is trusted, but the + guarantee is provided by the module's author. A client of this + module then specifies that they trust the module author by + specifying they trust the package containing the module. + has no effect on the accepted range + of Haskell programs or their semantics, except that they allow the + safe import keyword. + + Module Trusted — Yes. + Module Trusted ( + enabled) — Yes but only if the package the module + resides in is also trusted. + Haskell Language — Unrestricted + + Imported Modules — Under control of + module author which ones must be trusted. + + + + + + -XUnsafe + -XUnsafe + Mark a module as unsafe so that it can't be imported by code + compiled with . Also enable the Safe Import + extension so that a module can require a dependency to be trusted. + + Module Trusted — No + Haskell Language — + Unrestricted + Imported Modules — Under control of + module author which ones must be trusted. + + + + + + + And one general flag: + + + + -fpackage-trust + -fpackage-trust + When enabled turn on an extra check for a trustworthy module + M, requiring that the package M resides in is considered trusted for + the M to be considered trusted. + + + + + And three warning flags: + + + + -fwarn-unsafe + -fwarn-unsafe + Issue a warning if the module being compiled is regarded + to be unsafe. Should be used to check the safety status of modules + when using safe inference. + + + + -fwarn-safe + -fwarn-safe + Issue a warning if the module being compiled is regarded + to be safe. Should be used to check the safety status of modules + when using safe inference. + + + + -fwarn-trustworthy-safe + -fwarn-trustworthy-safe + Issue a warning if the module being compiled is marked as + but it could instead be marked as + , a more informative bound. Can be used to + detect once a Safe Haskell bound can be improved as dependencies are + updated. + + + + + + Safe Compilation + safe compilation + + + GHC includes a variety of flags that allow arbitrary processes to be run at + compilation time. One such example is the custom pre-processor flag. Another is the + ability of Template Haskell to execute Haskell code at compilation time, + including IO actions. Safe Haskell does not address this + danger (although, Template Haskell is a disallowed feature). + + + + Due to this, it is suggested that when compiling untrusted source code that + has had no manual inspection done, the following precautions be taken: + + Compile in a sandbox, such as a chroot or similar container + technology. Or simply as a user with very reduced system + access. + Compile untrusted code with the flag + being specified on the command line. This will ensure that modifications + to the source being compiled can't disable the use of the Safe Language + as the command line flag takes precedence over a source level + pragma. + Ensure that all untrusted code is imported as a + safe import and + that the + flag is used with packages from untrusted sources being marked as + untrusted. + + + + + There is a more detailed discussion of the issues involved in compilation + safety and some potential solutions on the GHC + Wiki. + + + + Additionally, the use of annotations + is forbidden, as that would allow bypassing Safe Haskell restrictions. + See ticket #10826. + + + + + + + diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml new file mode 100644 index 00000000..b30eff86 --- /dev/null +++ b/docs/users_guide/separate_compilation.xml @@ -0,0 +1,1350 @@ + + + Filenames and separate compilation + + separate compilation + recompilation checker + make and recompilation + + This section describes what files GHC expects to find, what + files it creates, where these files are stored, and what options + affect this behaviour. + + Note that this section is written with + hierarchical modules in mind (see ); hierarchical modules are an + extension to Haskell 98 which extends the lexical syntax of + module names to include a dot ‘.’. Non-hierarchical + modules are thus a special case in which none of the module names + contain dots. + + Pathname conventions vary from system to system. In + particular, the directory separator is + ‘/’ on Unix systems and + ‘\’ on Windows systems. In the + sections that follow, we shall consistently use + ‘/’ as the directory separator; + substitute this for the appropriate character for your + system. + + + Haskell source files + + filenames + + Each Haskell source module should be placed in a file on + its own. + + Usually, the file should be named after the module name, + replacing dots in the module name by directory separators. For + example, on a Unix system, the module A.B.C + should be placed in the file A/B/C.hs, + relative to some base directory. If the module is not going to + be imported by another module (Main, for + example), then you are free to use any filename for it. + + unicode + + GHC assumes that source files are + ASCIIASCII or + UTF-8UTF-8 only, other + encodingsencoding are + not recognised. However, invalid UTF-8 sequences will be + ignored in comments, so it is possible to use other encodings + such as + Latin-1Latin-1, as + long as the non-comment source code is ASCII only. + + + + Output files + + interface files + .hi files + object files + .o files + + When asked to compile a source file, GHC normally + generates two files: an object file, and + an interface file. + + The object file, which normally ends in a + .o suffix, contains the compiled code for the + module. + + The interface file, + which normally ends in a .hi suffix, contains + the information that GHC needs in order to compile further + modules that depend on this module. It contains things like the + types of exported functions, definitions of data types, and so + on. It is stored in a binary format, so don't try to read one; + use the option instead (see ). + + You should think of the object file and the interface file as a + pair, since the interface file is in a sense a compiler-readable + description of the contents of the object file. If the + interface file and object file get out of sync for any reason, + then the compiler may end up making assumptions about the object + file that aren't true; trouble will almost certainly follow. + For this reason, we recommend keeping object files and interface + files in the same place (GHC does this by default, but it is + possible to override the defaults as we'll explain + shortly). + + Every module has a module name + defined in its source code (module A.B.C where + ...). + + The name of the object file generated by GHC is derived + according to the following rules, where + osuf is the object-file suffix (this + can be changed with the option). + + + + If there is no option (the + default), then the object filename is derived from the + source filename (ignoring the module name) by replacing the + suffix with osuf. + + + If +  dir + has been specified, then the object filename is + dir/mod.osuf, + where mod is the module name with + dots replaced by slashes. GHC will silently create the necessary directory + structure underneath dir, if it does not + already exist. + + + + The name of the interface file is derived using the same + rules, except that the suffix is + hisuf (.hi by + default) instead of osuf, and the + relevant options are and + instead of and + respectively. + + For example, if GHC compiles the module + A.B.C in the file + src/A/B/C.hs, with no + -odir or -hidir flags, the + interface file will be put in src/A/B/C.hi + and the object file in src/A/B/C.o. + + For any module that is imported, GHC requires that the + name of the module in the import statement exactly matches the + name of the module in the interface file (or source file) found + using the strategy specified in . + This means that for most modules, the source file name should + match the module name. + + However, note that it is reasonable to have a module + Main in a file named + foo.hs, but this only works because GHC + never needs to search for the interface for module + Main (because it is never imported). It is + therefore possible to have several Main + modules in separate source files in the same directory, and GHC + will not get confused. + + In batch compilation mode, the name of the object file can + also be overridden using the option, and the + name of the interface file can be specified directly using the + option. + + + + The search path + + search path + + interface files, finding them + finding interface files + + In your program, you import a module + Foo by saying import Foo. + In mode or GHCi, GHC will look for a + source file for Foo and arrange to compile it + first. Without , GHC will look for the + interface file for Foo, which should have + been created by an earlier compilation of + Foo. GHC uses the same strategy in each of + these cases for finding the appropriate file. + + This strategy is as follows: GHC keeps a list of + directories called the search path. For + each of these directories, it tries appending + basename.extension + to the directory, and checks whether the file exists. The value + of basename is the module name with + dots replaced by the directory separator ('/' or '\', depending + on the system), and extension is a + source extension (hs, lhs) + if we are in mode or GHCi, or + hisuf otherwise. + + For example, suppose the search path contains directories + d1, d2, and + d3, and we are in --make + mode looking for the source file for a module + A.B.C. GHC will look in + d1/A/B/C.hs, d1/A/B/C.lhs, + d2/A/B/C.hs, and so on. + + The search path by default contains a single directory: + . (i.e. the current directory). The following + options can be used to add to or change the contents of the + search path: + + + + + + + This flag appends a colon-separated + list of dirs to the search path. + + + + + + + resets the search path back to nothing. + + + + + This isn't the whole story: GHC also looks for modules in + pre-compiled libraries, known as packages. See the section on + packages () for details. + + + + Redirecting the compilation output(s) + + output-directing options + redirecting compilation output + + + + + file + + + + GHC's compiled output normally goes into a + .hc, .o, etc., + file, depending on the last-run compilation phase. The + option + re-directs the output of that last-run phase to + file. + + Note: this “feature” can be + counterintuitive: ghc -C -o foo.o + foo.hs will put the intermediate C code in the + file foo.o, name + notwithstanding! + + This option is most often used when creating an + executable file, to set the filename of the executable. + For example: + ghc -o prog --make Main + + will compile the program starting with module + Main and put the executable in the + file prog. + + Note: on Windows, if the result is an executable + file, the extension ".exe" is added + if the specified filename does not already have an + extension. Thus + + ghc -o foo Main.hs + + will compile and link the module + Main.hs, and put the resulting + executable in foo.exe (not + foo). + + If you use ghc --make and you don't + use the , the name GHC will choose + for the executable will be based on the name of the file + containing the module Main. + Note that with GHC the Main module doesn't + have to be put in file Main.hs. + Thus both + + ghc --make Prog + + and + + ghc --make Prog.hs + + will produce Prog (or + Prog.exe if you are on Windows). + + + + + + dir + + + + Redirects object files to directory + dir. For example: + + +$ ghc -c parse/Foo.hs parse/Bar.hs gurgle/Bumble.hs -odir `uname -m` + + + The object files, Foo.o, + Bar.o, and + Bumble.o would be put into a + subdirectory named after the architecture of the executing + machine (x86, + mips, etc). + + Note that the option does + not affect where the interface files + are put; use the option for that. + In the above example, they would still be put in + parse/Foo.hi, + parse/Bar.hi, and + gurgle/Bumble.hi. + + + + + + file + + + + The interface output may be directed to another file + bar2/Wurble.iface with the option + (not + recommended). + + WARNING: if you redirect the interface file + somewhere that GHC can't find it, then the recompilation + checker may get confused (at the least, you won't get any + recompilation avoidance). We recommend using a + combination of and + options instead, if + possible. + + To avoid generating an interface at all, you could + use this option to redirect the interface into the bit + bucket: -ohi /dev/null, for + example. + + + + + + dir + + + + Redirects all generated interface files into + dir, instead of the + default. + + + + + + dir + + + + Redirects all generated FFI stub files into + dir. Stub files are generated when the + Haskell source contains a foreign export or + foreign import "&wrapper" declaration (see ). The + option behaves in exactly the same way as + and with respect to hierarchical + modules. + + + + + + dir + + + + Redirects all dump files into + dir. Dump files are generated when + -ddump-to-file is used with other + -ddump-* flags. + + + + + + dir + + + + The option is shorthand for + the combination + of , , + and . + + + + + + + suffix + + + + suffix + + + + suffix + + + + The + suffix will change the + .o file suffix for object files to + whatever you specify. We use this when compiling + libraries, so that objects for the profiling versions of + the libraries don't clobber the normal ones. + + Similarly, the + suffix will change the + .hi file suffix for non-system + interface files (see ). + + Finally, the option + suffix will change the + .hc file suffix for compiler-generated + intermediate C files. + + The / + game is particularly useful if you want to compile a + program both with and without profiling, in the same + directory. You can say: + + ghc ... + to get the ordinary version, and + + ghc ... -osuf prof.o -hisuf prof.hi -prof -auto-all + to get the profiled version. + + + + + + + Keeping Intermediate Files + intermediate files, saving + + .hc files, saving + + .ll files, saving + + .s files, saving + + + The following options are useful for keeping certain + intermediate files around, when normally GHC would throw these + away after compilation: + + + + + , + + + + + + Keep intermediate .hc files when + doing .hs-to-.o + compilations via C (NOTE: + .hc files are only generated by + unregisterised compilers). + + + + + + , + + + + + + Keep intermediate .ll files when + doing .hs-to-.o + compilations via LLVM + (NOTE: .ll files aren't generated when using the + native code generator, you may need to use to + force them to be produced). + + + + + + , + + + + + + Keep intermediate .s files. + + + + + + + + temporary fileskeeping + + + Instructs the GHC driver not to delete any of its + temporary files, which it normally keeps in + /tmp (or possibly elsewhere; see ). Running GHC with + will show you what temporary files + were generated along the way. + + + + + + + Redirecting temporary files + + + temporary files + redirecting + + + + + + + + + + If you have trouble because of running out of space + in /tmp (or wherever your + installation thinks temporary files should go), you may + use the -tmpdir + <dir> option option to specify + an alternate directory. For example, says to put temporary files in the current + working directory. + + Alternatively, use your TMPDIR + environment variable.TMPDIR + environment variable Set it to the + name of the directory where temporary files should be put. + GCC and other programs will honour the + TMPDIR variable as well. + + Even better idea: Set the + DEFAULT_TMPDIR make variable when + building GHC, and never worry about + TMPDIR again. (see the build + documentation). + + + + + + + Other options related to interface files + interface files, options + + + + + + + + + Dumps the new interface to standard output. + + + + + + + + + + The compiler does not overwrite an existing + .hi interface file if the new one is + the same as the old one; this is friendly to + make. When an interface does change, + it is often enlightening to be informed. The + option will make GHC + report the differences between the old and + new .hi files. + + + + + + + + + + Dump to the file + M.imports + (where M is the name of the + module being compiled) a "minimal" set of import + declarations. The directory where the + .imports files are created can be + controlled via the + option. You can safely replace all the import + declarations in + M.hs with + those found in its respective .imports + file. Why would you want to do that? Because the + "minimal" imports (a) import everything explicitly, by + name, and (b) import nothing that is not required. It can + be quite painful to maintain this property by hand, so + this flag is intended to reduce the labour. + + + + + + file + + + + where file is the name of + an interface file, dumps the contents of that interface in + a human-readable (ish) format. See . + + + + + + + The recompilation checker + + recompilation checker + + + + + + + + + + Turn off recompilation checking (which is on by + default). Recompilation checking normally stops + compilation early, leaving an existing + .o file in place, if it can be + determined that the module does not need to be + recompiled. + + + + + In the olden days, GHC compared the newly-generated + .hi file with the previous version; if they + were identical, it left the old one alone and didn't change its + modification date. In consequence, importers of a module with + an unchanged output .hi file were not + recompiled. + + This doesn't work any more. Suppose module + C imports module B, and + B imports module A. So + changes to module A might require module + C to be recompiled, and hence when + A.hi changes we should check whether + C should be recompiled. However, the + dependencies of C will only list + B.hi, not A.hi, and some + changes to A (changing the definition of a + function that appears in an inlining of a function exported by + B, say) may conceivably not change + B.hi one jot. So now… + + GHC calculates a fingerprint (in fact an MD5 hash) of each + interface file, and of each declaration within the interface + file. It also keeps in every interface file a list of the + fingerprints of everything it used when it last compiled the + file. If the source file's modification date is earlier than + the .o file's date (i.e. the source hasn't + changed since the file was last compiled), and the recompilation + checking is on, GHC will be clever. It compares the fingerprints + on the things it needs this time with the fingerprints + on the things it needed last time (gleaned from the + interface file of the module being compiled); if they are all + the same it stops compiling early in the process saying + “Compilation IS NOT required”. What a beautiful + sight! + + You can read + about how + all this works in the GHC commentary. + + + + + How to compile mutually recursive modules + + module system, recursion + recursion, between modules + + GHC supports the compilation of mutually recursive modules. + This section explains how. + + Every cycle in the module import graph must be broken by a hs-boot file. + Suppose that modules A.hs and B.hs are Haskell source files, + thus: + +module A where + import B( TB(..) ) + + newtype TA = MkTA Int + + f :: TB -> TA + f (MkTB x) = MkTA x + +module B where + import {-# SOURCE #-} A( TA(..) ) + + data TB = MkTB !Int + + g :: TA -> TB + g (MkTA x) = MkTB x + +hs-boot + files importing, + hi-boot files +Here A imports B, but B imports +A with a {-# SOURCE #-} pragma, which breaks the +circular dependency. Every loop in the module import graph must be broken by a {-# SOURCE #-} import; +or, equivalently, the module import graph must be acyclic if {-# SOURCE #-} imports are ignored. + +For every module A.hs that is {-# SOURCE #-}-imported +in this way there must exist a source file A.hs-boot. This file contains an abbreviated +version of A.hs, thus: + +module A where + newtype TA = MkTA Int + + +To compile these three files, issue the following commands: + + ghc -c A.hs-boot -- Produces A.hi-boot, A.o-boot + ghc -c B.hs -- Consumes A.hi-boot, produces B.hi, B.o + ghc -c A.hs -- Consumes B.hi, produces A.hi, A.o + ghc -o foo A.o B.o -- Linking the program + + +There are several points to note here: + + + The file A.hs-boot is a programmer-written source file. + It must live in the same directory as its parent source file A.hs. + Currently, if you use a literate source file A.lhs you must + also use a literate boot file, A.lhs-boot; and vice versa. + + + + A hs-boot file is compiled by GHC, just like a hs file: + + ghc -c A.hs-boot + +When a hs-boot file A.hs-boot + is compiled, it is checked for scope and type errors. + When its parent module A.hs is compiled, the two are compared, and + an error is reported if the two are inconsistent. + + + + Just as compiling A.hs produces an + interface file A.hi, and an object file + A.o, so compiling + A.hs-boot produces an interface file + A.hi-boot, and an pseudo-object file + A.o-boot: + + + + The pseudo-object file A.o-boot is + empty (don't link it!), but it is very useful when using a + Makefile, to record when the A.hi-boot was + last brought up to date (see ). + + + + The hi-boot generated by compiling a + hs-boot file is in the same + machine-generated binary format as any other GHC-generated + interface file (e.g. B.hi). You can + display its contents with ghc + --show-iface. If you specify a directory for + interface files, the flag, then that + affects hi-boot files + too. + + + + + If hs-boot files are considered distinct from their parent source + files, and if a {-# SOURCE #-} import is considered to refer to the + hs-boot file, then the module import graph must have no cycles. The command + ghc -M will report an error if a cycle is found. + + + A module M that is + {-# SOURCE #-}-imported in a program will usually also be + ordinarily imported elsewhere. If not, ghc --make + automatically adds M to the set of modules it tries to + compile and link, to ensure that M's implementation is included in + the final program. + + + + +A hs-boot file need only contain the bare + minimum of information needed to get the bootstrapping process + started. For example, it doesn't need to contain declarations + for everything that module + A exports, only the things required by the + module(s) that import A recursively. +A hs-boot file is written in a subset of Haskell: + + The module header (including the export list), and import statements, are exactly as in +Haskell, and so are the scoping rules. + Hence, to mention a non-Prelude type or class, you must import it. + + There must be no value declarations, but there can be type signatures for +values. For example: + + double :: Int -> Int + + + Fixity declarations are exactly as in Haskell. + Vanilla type synonym declarations are exactly as in Haskell. + Open type and data family declarations are exactly as in Haskell. + A closed type family may optionally omit its equations, as in the following example: + + type family ClosedFam a where .. + +The .. is meant literally -- you should write two dots in your file. Note that the where clause is still necessary to distinguish closed families from open ones. If you give any equations of a closed family, you must give all of them, in the same order as they appear in the accompanying Haskell file. + A data type declaration can either be given in full, exactly as in Haskell, or it +can be given abstractly, by omitting the '=' sign and everything that follows. For example: + + data T a b + + In a source program + this would declare TA to have no constructors (a GHC extension: see ), + but in an hi-boot file it means "I don't know or care what the constructors are". + This is the most common form of data type declaration, because it's easy to get right. + You can also write out the constructors but, if you do so, you must write + it out precisely as in its real definition. + + If you do not write out the constructors, you may need to give a kind + annotation (), to tell + GHC the kind of the type variable, if it is not "*". (In source files, this is worked out + from the way the type variable is used in the constructors.) For example: + + data R (x :: * -> *) y + +You cannot use deriving on a data type declaration; write an +instance declaration instead. + + Class declarations is exactly as in Haskell, except that you may not put +default method declarations. You can also omit all the superclasses and class +methods entirely; but you must either omit them all or put them all in. + + You can include instance declarations just as in Haskell; but omit the "where" part. + +The default role for class and datatype parameters is now representational. To get another role, use a role annotation. (See .) + + + + + + Module signatures + GHC supports the specification of module signatures, which + both implementations and users can typecheck against separately. + This functionality should be considered experimental for now; some + details, especially for type classes and type families, may change. + This system was originally described in Backpack: Retrofitting Haskell with + Interfaces. Signature files are somewhat similar to + hs-boot files, but have the hsig + extension and behave slightly differently. + + + Suppose that I have modules String.hs and + A.hs, thus: + + +module Text where + data Text = Text String + + empty :: Text + empty = Text "" + + toString :: Text -> String + toString (Text s) = s + +module A where + import Text + z = toString empty + + + Presently, module A depends explicitly on + a concrete implementation of Text. What if we wanted + to a signature Text, so we could vary the + implementation with other possibilities (e.g. packed UTF-8 encoded + bytestrings)? To do this, we can write a signature + TextSig.hsig, and modify A + to include the signature instead: + + + +module TextSig where + data Text + empty :: Text + toString :: Text -> String + +module A where + import TextSig + z = toString empty + + + To compile these two files, we need to specify what module we + would like to use to implement the signature. This can be done by + compiling the implementation, and then using the -sig-of + flag to specify the implementation backing a signature: + + +ghc -c Text.hs +ghc -c TextSig.hsig -sig-of main:Text +ghc -c A.hs + + + Signature files can also be compiled as part of + --make, in which case the syntax is extended + to support specifying implementations of multiple signatures + as FooSig is main:Foo, BarSig is main:Bar. + At the moment, you must specify the full module name (package key, + colon, and then module name), although in the future we may support + more user-friendly syntax. + + To just type-check an interface file, no -sig-of + is necessary; instead, just pass the options + -fno-code -fwrite-interface. hsig + files will generate normal interface files which other files can + also use to type-check against. However, at the moment, we always + assume that an entity defined in a signature is a unique identifier + (even though we may happen to know it is type equal with another + identifier). In the future, we will support passing shaping information + to the compiler in order to let it know about these type + equalities. + + Just like hs-boot files, when an + hsig file is compiled it is checked for type + consistency against the backing implementation. Signature files are also + written in a subset of Haskell essentially identical to that of + hs-boot files. + + There is one important gotcha with the current implementation: + currently, instances from backing implementations will "leak" code that + uses signatures, and explicit instance declarations in signatures are + forbidden. This behavior will be subject to change. + + + + + + Using <command>make</command> + + make + + It is reasonably straightforward to set up a + Makefile to use with GHC, assuming you name + your source files the same as your modules. Thus: + + +HC = ghc +HC_OPTS = -cpp $(EXTRA_HC_OPTS) + +SRCS = Main.lhs Foo.lhs Bar.lhs +OBJS = Main.o Foo.o Bar.o + +.SUFFIXES : .o .hs .hi .lhs .hc .s + +cool_pgm : $(OBJS) + rm -f $@ + $(HC) -o $@ $(HC_OPTS) $(OBJS) + +# Standard suffix rules +.o.hi: + @: + +.lhs.o: + $(HC) -c $< $(HC_OPTS) + +.hs.o: + $(HC) -c $< $(HC_OPTS) + +.o-boot.hi-boot: + @: + +.lhs-boot.o-boot: + $(HC) -c $< $(HC_OPTS) + +.hs-boot.o-boot: + $(HC) -c $< $(HC_OPTS) + +# Inter-module dependencies +Foo.o Foo.hc Foo.s : Baz.hi # Foo imports Baz +Main.o Main.hc Main.s : Foo.hi Baz.hi # Main imports Foo and Baz + + + (Sophisticated make variants may + achieve some of the above more elegantly. Notably, + gmake's pattern rules let you write the more + comprehensible: + + +%.o : %.lhs + $(HC) -c $< $(HC_OPTS) + + + What we've shown should work with any + make.) + + Note the cheesy .o.hi rule: It records + the dependency of the interface (.hi) file + on the source. The rule says a .hi file + can be made from a .o file by + doing…nothing. Which is true. + Note that the suffix rules are all repeated twice, once + for normal Haskell source files, and once for hs-boot + files (see ). + + Note also the inter-module dependencies at the end of the + Makefile, which take the form + + +Foo.o Foo.hc Foo.s : Baz.hi # Foo imports Baz + + + They tell make that if any of + Foo.o, Foo.hc or + Foo.s have an earlier modification date than + Baz.hi, then the out-of-date file must be + brought up to date. To bring it up to date, + make looks for a rule to do so; one of the + preceding suffix rules does the job nicely. These dependencies + can be generated automatically by ghc; see + + + + + + Dependency generation + dependencies in Makefiles + Makefile dependencies + + Putting inter-dependencies of the form Foo.o : + Bar.hi into your Makefile by + hand is rather error-prone. Don't worry, GHC has support for + automatically generating the required dependencies. Add the + following to your Makefile: + + +depend : + ghc -M $(HC_OPTS) $(SRCS) + + + Now, before you start compiling, and any time you change + the imports in your program, do + make depend before you do make + cool_pgm. The command ghc -M will + append the needed dependencies to your + Makefile. + + In general, ghc -M Foo does the following. + For each module M in the set + Foo plus all its imports (transitively), + it adds to the Makefile: + + A line recording the dependence of the object file on the source file. + +M.o : M.hs + +(or M.lhs if that is the filename you used). + + For each import declaration import X in M, + a line recording the dependence of M on X: + +M.o : X.hi + + For each import declaration import {-# SOURCE #-} X in M, + a line recording the dependence of M on X: + +M.o : X.hi-boot + + (See for details of + hi-boot style interface files.) + + + If M imports multiple modules, then there will + be multiple lines with M.o as the + target. + There is no need to list all of the source files as arguments to the ghc -M command; + ghc traces the dependencies, just like ghc --make + (a new feature in GHC 6.4). + + Note that ghc -M needs to find a source + file for each module in the dependency graph, so that it can + parse the import declarations and follow dependencies. Any pre-compiled + modules without source files must therefore belong to a + packageThis is a change in behaviour relative to 6.2 and + earlier. + . + + By default, ghc -M generates all the + dependencies, and then concatenates them onto the end of + makefile (or + Makefile if makefile + doesn't exist) bracketed by the lines "# DO NOT + DELETE: Beginning of Haskell dependencies" and + "# DO NOT DELETE: End of Haskell + dependencies". If these lines already exist in the + makefile, then the old dependencies are + deleted first. + + Don't forget to use the same + options on the ghc -M command line as you + would when compiling; this enables the dependency generator to + locate any imported modules that come from packages. The + package modules won't be included in the dependencies + generated, though (but see the + option below). + + The dependency generation phase of GHC can take some + additional options, which you may find useful. + + The options which affect dependency generation are: + + + + + + Display a list of the cycles in the module graph. This is + useful when trying to eliminate such cycles. + + + + + + + Print a full list of the module dependencies to stdout. + (This is the standard verbosity flag, so the list will + also be displayed with and + ; + .) + + + + + file + + Use file as the makefile, + rather than makefile or + Makefile. If + file doesn't exist, + mkdependHS creates it. We often use + to put the dependencies in + .depend and then + include the file + .depend into + Makefile. + + + + + + + Make extra dependencies that declare that files + with suffix + .<suf>_<osuf> + depend on interface files with suffix + .<suf>_hi, or (for + {-# SOURCE #-} + imports) on .hi-boot. Multiple + flags are permitted. For example, + + will make dependencies + for .hs on + .hi, + .a_hs on + .a_hi, and + .b_hs on + .b_hi. (Useful in + conjunction with NoFib "ways".) + + + + + + + Regard <file> as + "stable"; i.e., exclude it from having dependencies on + it. + + + + + + + Regard modules imported from packages as unstable, + i.e., generate dependencies on any imported package modules + (including Prelude, and all other + standard Haskell libraries). Dependencies are not traced + recursively into packages; dependencies are only generated for + home-package modules on external-package modules directly imported + by the home package module. + This option is normally + only used by the various system libraries. + + + + + + + + Orphan modules and instance declarations + + Haskell specifies that when compiling module M, any instance +declaration in any module "below" M is visible. (Module A is "below" +M if A is imported directly by M, or if A is below a module that M imports directly.) +In principle, GHC must therefore read the interface files of every module below M, +just in case they contain an instance declaration that matters to M. This would +be a disaster in practice, so GHC tries to be clever. + +In particular, if an instance declaration is in the same module as the definition +of any type or class mentioned in the head of the instance declaration +(the part after the “=>”; see ), then +GHC has to visit that interface file anyway. Example: + + module A where + instance C a => D (T a) where ... + data T a = ... + + The instance declaration is only relevant if the type T is in use, and if +so, GHC will have visited A's interface file to find T's definition. + + The only problem comes when a module contains an instance declaration +and GHC has no other reason for visiting the module. Example: + + module Orphan where + instance C a => D (T a) where ... + class C a where ... + +Here, neither D nor T is declared in module Orphan. +We call such modules “orphan modules”. +GHC identifies orphan modules, and visits the interface file of +every orphan module below the module being compiled. This is usually +wasted work, but there is no avoiding it. You should therefore do +your best to have as few orphan modules as possible. + + +Functional dependencies complicate matters. Suppose we have: + + module B where + instance E T Int where ... + data T = ... + +Is this an orphan module? Apparently not, because T +is declared in the same module. But suppose class E had a +functional dependency: + + module Lib where + class E x y | y -> x where ... + +Then in some importing module M, the constraint (E a Int) should be "improved" by setting +a = T, even though there is no explicit mention +of T in M. + +These considerations lead to the following definition of an orphan module: + + An orphan module + orphan module + contains at least one orphan instance or at + least one orphan rule. + + An instance declaration in a module M is an orphan instance if + orphan instance + + + The class of the instance declaration is not declared in M, and + + + Either the class has no functional dependencies, and none of the type constructors + in the instance head is declared in M; or there + is a functional dependency for which none of the type constructors mentioned + in the non-determined part of the instance head is defined in M. + + + + Only the instance head + counts. In the example above, it is not good enough for C's declaration + to be in module A; it must be the declaration of D or T. + + + A rewrite rule in a module M is an orphan rule + orphan rule + if none of the variables, type constructors, + or classes that are free in the left hand side of the rule are declared in M. + + + + + +If you use the flag , GHC will warn you +if you are creating an orphan module. +Like any warning, you can switch the warning off with , +and +will make the compilation fail if the warning is issued. + + +You can identify an orphan module by looking in its interface +file, M.hi, using the + mode. If there is a [orphan module] on the +first line, GHC considers it an orphan module. + + + + + + diff --git a/docs/users_guide/shared_libs.xml b/docs/users_guide/shared_libs.xml new file mode 100644 index 00000000..5c258d4b --- /dev/null +++ b/docs/users_guide/shared_libs.xml @@ -0,0 +1,262 @@ + + + Using shared libraries + Shared librariesusing + Dynamic librariesusing + + + On some platforms GHC supports building Haskell code into shared + libraries. Shared libraries are also sometimes known as dynamic + libraries, in particular on Windows they are referred to as dynamic link + libraries (DLLs). + + + + Shared libraries allow a single instance of some pre-compiled code to be + shared between several programs. In contrast, with static linking the + code is copied into each program. Using shared libraries can thus save + disk space. They also allow a single copy of code to be shared in memory + between several programs that use it. Shared libraries are often used as + a way of structuring large projects, especially where different parts are + written in different programming languages. Shared libraries are also + commonly used as a plugin mechanism by various applications. This is + particularly common on Windows using COM. + + + + In GHC version 6.12 building shared libraries is supported for Linux (on + x86 and x86-64 architectures). GHC version 7.0 adds support on Windows + (see ), FreeBSD and OpenBSD (x86 and x86-64), + Solaris (x86) and Mac OS X (x86 and PowerPC). + + + + Building and using shared libraries is slightly more complicated than + building and using static libraries. When using Cabal much of the detail + is hidden, just use --enable-shared when configuring a + package to build it into a shared library, or to link it against other + packages built as shared libraries. The additional complexity when + building code is to distinguish whether the code will be used in a shared + library or will use shared library versions of other packages it depends + on. There is additional complexity when installing and distributing + shared libraries or programs that use shared libraries, to ensure that + all shared libraries that are required at runtime are present in suitable + locations. + + + + Building programs that use shared libraries + + To build a simple program and have it use shared libraries for the + runtime system and the base libraries use the + -dynamic flag: + +ghc --make -dynamic Main.hs + + This has two effects. The first is to compile the code in such a way + that it can be linked against shared library versions of Haskell + packages (such as base). The second is when linking, to link against + the shared versions of the packages' libraries rather than the static + versions. Obviously this requires that the packages were built with + shared libraries. On supported platforms GHC comes with shared + libraries for all the core packages, but if you install extra packages + (e.g. with Cabal) then they would also have to be built with shared + libraries (--enable-shared for Cabal). + + + + + Shared libraries for Haskell packages + + You can build Haskell code into a shared library and make a package to be + used by other Haskell programs. The easiest way is using Cabal, simply + configure the Cabal package with the --enable-shared + flag. + + + If you want to do the steps manually or are writing your own build + system then there are certain conventions that must be followed. Building + a shared library that exports Haskell code, to be used by other Haskell + code is a bit more complicated than it is for one that exports a C API + and will be used by C code. If you get it wrong you will usually end up + with linker errors. + + + In particular Haskell shared libraries must be + made into packages. You cannot freely assign which modules go in which + shared libraries. The Haskell shared libraries must match the package + boundaries. The reason for this is that + GHC handles references to symbols within the same + shared library (or main executable binary) differently from references + to symbols between different shared libraries. GHC + needs to know for each imported module if that module lives locally in + the same shared lib or in a separate shared lib. The way it does this + is by using packages. When using -dynamic, a module + from a separate package is assumed to come from a separate shared lib, + while modules from the same package (or the default "main" package) are + assumed to be within the same shared lib (or main executable binary). + + + Most of the conventions GHC expects when using packages are described + in . In addition note that GHC + expects the .hi files to use the extension + .dyn_hi. The other requirements are the same as for + C libraries and are described below, in particular the use of the flags + -dynamic, -fPIC and + -shared. + + + + + Shared libraries that export a C API + + Building Haskell code into a shared library is a good way to include + Haskell code in a larger mixed-language project. While with static + linking it is recommended to use GHC to perform the final link step, + with shared libraries a Haskell library can be treated just like any + other shared library. The linking can be done using the normal system C + compiler or linker. + + + It is possible to load shared libraries generated by GHC in other + programs not written in Haskell, so they are suitable for using as + plugins. Of course to construct a plugin you will have to use the FFI + to export C functions and follow the rules about initialising the RTS. + See . In particular you will probably want + to export a C function from your shared library to initialise the + plugin before any Haskell functions are called. + + + To build Haskell modules that export a C API into a shared library use + the -dynamic, -fPIC and + -shared flags: + +ghc --make -dynamic -shared -fPIC Foo.hs -o libfoo.so + + As before, the -dynamic flag specifies that this + library links against the shared library versions of the rts and base + package. The -fPIC flag is required for all code + that will end up in a shared library. The -shared + flag specifies to make a shared library rather than a program. To make + this clearer we can break this down into separate compilation and link + steps: + +ghc -dynamic -fPIC -c Foo.hs +ghc -dynamic -shared Foo.o -o libfoo.so + + In principle you can use -shared without + -dynamic in the link step. That means to + statically link the rts all the base libraries into your new shared + library. This would make a very big, but standalone shared library. + On most platforms however that would require all the static libraries + to have been built with -fPIC so that the code is + suitable to include into a shared library and we do not do that at the + moment. + + + Warning: if your shared library exports a Haskell + API then you cannot directly link it into another Haskell program and + use that Haskell API. You will get linker errors. You must instead make + it into a package as described in the section above. + + + + + Finding shared libraries at runtime + + The primary difficulty with managing shared libraries is arranging + things such that programs can find the libraries they need at runtime. + The details of how this works varies between platforms, in particular + the three major systems: Unix ELF platforms, Windows and Mac OS X. + + + Unix + + On Unix there are two mechanisms. Shared libraries can be installed + into standard locations that the dynamic linker knows about. For + example /usr/lib or + /usr/local/lib on most systems. The other mechanism + is to use a "runtime path" or "rpath" embedded into programs and + libraries themselves. These paths can either be absolute paths or on at + least Linux and Solaris they can be paths relative to the program or + library itself. In principle this makes it possible to construct fully + relocatable sets of programs and libraries. + + + GHC has a -dynload linking flag to select the method + that is used to find shared libraries at runtime. There are currently + two modes: + + + sysdep + + + A system-dependent mode. This is also the default mode. On Unix + ELF systems this embeds + RPATH/RUNPATH entries into the + shared library or executable. In particular it uses absolute paths to + where the shared libraries for the rts and each package can be found. + This means the program can immediately be run and it will be able to + find the libraries it needs. However it may not be suitable for + deployment if the libraries are installed in a different location on + another machine. + + + + + deploy + + + This does not embed any runtime paths. It relies on the shared + libraries being available in a standard location or in a + directory given by the LD_LIBRARY_PATH + environment variable. + + + + + To use relative paths for dependent libraries on Linux and Solaris you + can pass a suitable -rpath flag to the linker: + +ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN' + + This assumes that the library libfoo.so is in the + current directory and will be able to be found in the same directory as + the executable main once the program is deployed. + Similarly it would be possible to use a subdirectory relative to the + executable e.g. -optl-Wl,-rpath,'$ORIGIN/lib'. + + + This relative path technique can be used with either of the two + -dynload modes, though it makes most sense with the + deploy mode. The difference is that with the + deploy mode, the above example will end up with an ELF + RUNPATH of just $ORIGIN while with + the sysdep mode the RUNPATH will be + $ORIGIN followed by all the library directories of all + the packages that the program depends on (e.g. base + and rts packages etc.) which are typically absolute + paths. The unix tool readelf --dynamic is handy for + inspecting the RPATH/RUNPATH + entries in ELF shared libraries and executables. + + + + Mac OS X + + The standard assumption on Darwin/Mac OS X is that dynamic libraries will + be stamped at build time with an "install name", which is the full + ultimate install path of the library file. Any libraries or executables + that subsequently link against it (even if it hasn't been installed yet) + will pick up that path as their runtime search location for it. When + compiling with ghc directly, the install name is set by default to the + location where it is built. You can override this with the + -dylib-install-name option (which passes + -install_name to the Apple linker). Cabal does this + for you. It automatically sets the install name for dynamic libraries to + the absolute path of the ultimate install location. + + + + + diff --git a/docs/users_guide/sooner.xml b/docs/users_guide/sooner.xml new file mode 100644 index 00000000..68bcc61b --- /dev/null +++ b/docs/users_guide/sooner.xml @@ -0,0 +1,544 @@ + + +Advice on: sooner, faster, smaller, thriftier + +Please advise us of other “helpful hints” that +should go here! + + +Sooner: producing a program more quickly + + +compiling faster +faster compiling + + + + Don't use or (especially) : + + By using them, you are telling GHC that you are + willing to suffer longer compilation times for + better-quality code. + + GHC is surprisingly zippy for normal compilations + without ! + + + + + Use more memory: + + Within reason, more memory for heap space means less + garbage collection for GHC, which means less compilation + time. If you use the option, + you'll get a garbage-collector report. (Again, you can use + the cheap-and-nasty + option to send the GC stats straight to standard + error.) + + If it says you're using more than 20% of total + time in garbage collecting, then more memory might + help: use the + + option. Increasing the default allocation area size used by + the compiler's RTS might also help: use the + -A<size> + RTS option option. + + If GHC persists in being a bad memory citizen, please + report it as a bug. + + + + + Don't use too much memory! + + As soon as GHC plus its “fellow citizens” + (other processes on your machine) start using more than the + real memory on your machine, and the + machine starts “thrashing,” the party + is over. Compile times will be worse than + terrible! Use something like the csh-builtin + time command to get a report on how many + page faults you're getting. + + If you don't know what virtual memory, thrashing, and + page faults are, or you don't know the memory configuration + of your machine, don't try to be clever + about memory use: you'll just make your life a misery (and + for other people, too, probably). + + + + + Try to use local disks when linking: + + Because Haskell objects and libraries tend to be + large, it can take many real seconds to slurp the bits + to/from a remote filesystem. + + It would be quite sensible to + compile on a fast machine using + remotely-mounted disks; then link on a + slow machine that had your disks directly mounted. + + + + + Don't derive/use Read unnecessarily: + + It's ugly and slow. + + + + + GHC compiles some program constructs slowly: + + We'd rather you reported such behaviour as a bug, so + that we can try to correct it. + + To figure out which part of the compiler is badly + behaved, the + + option is your friend. + + + + + + + Faster: producing a program that runs quicker + + faster programs, how to produce + + The key tool to use in making your Haskell program run + faster are GHC's profiling facilities, described separately in + . There is no + substitute for finding where your program's time/space + is really going, as opposed to where you + imagine it is going. + + Another point to bear in mind: By far the best way to + improve a program's performance dramatically + is to use better algorithms. Once profiling has thrown the + spotlight on the guilty time-consumer(s), it may be better to + re-think your program than to try all the tweaks listed below. + + Another extremely efficient way to make your program snappy + is to use library code that has been Seriously Tuned By Someone + Else. You might be able to write a better + quicksort than the one in Data.List, but it + will take you much longer than typing import + Data.List. + + Please report any overly-slow GHC-compiled programs. Since + GHC doesn't have any credible competition in the performance + department these days it's hard to say what overly-slow means, so + just use your judgement! Of course, if a GHC compiled program + runs slower than the same program compiled with NHC or Hugs, then + it's definitely a bug. + + + + Optimise, using or : + + This is the most basic way to make your program go + faster. Compilation time will be slower, especially with + . + + At present, is nearly + indistinguishable from . + + + + + Compile via LLVM: + + The LLVM code generator can + sometimes do a far better job at producing fast code than the native code generator. This is not + universal and depends on the code. Numeric heavy code seems to show + the best improvement when compiled via LLVM. You can also experiment + with passing specific flags to LLVM with the + and flags. Be careful though as setting these + flags stops GHC from setting its usual flags for the LLVM optimiser + and compiler. + + + + + Overloaded functions are not your friend: + + Haskell's overloading (using type classes) is elegant, + neat, etc., etc., but it is death to performance if left to + linger in an inner loop. How can you squash it? + + + + Give explicit type signatures: + + Signatures are the basic trick; putting them on + exported, top-level functions is good + software-engineering practice, anyway. (Tip: using + -fwarn-missing-signatures + option can help enforce good + signature-practice). + + The automatic specialisation of overloaded + functions (with ) should take care + of overloaded local and/or unexported functions. + + + + + Use SPECIALIZE pragmas: + + SPECIALIZE pragma + overloading, death to + + Specialize the overloading on key functions in + your program. See + and . + + + + + “But how do I know where overloading is creeping in?”: + + A low-tech way: grep (search) your interface + files for overloaded type signatures. You can view + interface files using the + option (see ). + + +% ghc --show-iface Foo.hi | egrep '^[a-z].*::.*=>' + + + + + + + + + + Strict functions are your dear friends: + + and, among other things, lazy pattern-matching is your + enemy. + + (If you don't know what a “strict + function” is, please consult a functional-programming + textbook. A sentence or two of explanation here probably + would not do much good.) + + Consider these two code fragments: + + +f (Wibble x y) = ... # strict + +f arg = let { (Wibble x y) = arg } in ... # lazy + + + The former will result in far better code. + + A less contrived example shows the use of + cases instead of lets + to get stricter code (a good thing): + + +f (Wibble x y) # beautiful but slow + = let + (a1, b1, c1) = unpackFoo x + (a2, b2, c2) = unpackFoo y + in ... + +f (Wibble x y) # ugly, and proud of it + = case (unpackFoo x) of { (a1, b1, c1) -> + case (unpackFoo y) of { (a2, b2, c2) -> + ... + }} + + + + + + + + GHC loves single-constructor data-types: + + It's all the better if a function is strict in a + single-constructor type (a type with only one + data-constructor; for example, tuples are single-constructor + types). + + + + + Newtypes are better than datatypes: + + If your datatype has a single constructor with a + single field, use a newtype declaration + instead of a data declaration. The + newtype will be optimised away in most + cases. + + + + + “How do I find out a function's strictness?” + + Don't guess—look it up. + + Look for your function in the interface file, then for + the third field in the pragma; it should say + Strictness: <string>. The + <string> gives the strictness of + the function's arguments: see + the GHC Commentary for a description of the strictness notation. + + + For an “unpackable” + U(...) argument, the info inside tells + the strictness of its components. So, if the argument is a + pair, and it says U(AU(LSS)), that + means “the first component of the pair isn't used; the + second component is itself unpackable, with three components + (lazy in the first, strict in the second \& + third).” + + If the function isn't exported, just compile with the + extra flag ; next to the + signature for any binder, it will print the self-same + pragmatic information as would be put in an interface file. + (Besides, Core syntax is fun to look at!) + + + + + Force key functions to be INLINEd (esp. monads): + + Placing INLINE pragmas on certain + functions that are used a lot can have a dramatic effect. + See . + + + + + Explicit export list: + + If you do not have an explicit export list in a + module, GHC must assume that everything in that module will + be exported. This has various pessimising effects. For + example, if a bit of code is actually + unused (perhaps because of unfolding + effects), GHC will not be able to throw it away, because it + is exported and some other module may be relying on its + existence. + + GHC can be quite a bit more aggressive with pieces of + code if it knows they are not exported. + + + + + Look at the Core syntax! + + (The form in which GHC manipulates your code.) Just + run your compilation with + (don't forget the ). + + If profiling has pointed the finger at particular + functions, look at their Core code. lets + are bad, cases are good, dictionaries + (d.<Class>.<Unique>) [or + anything overloading-ish] are bad, nested lambdas are + bad, explicit data constructors are good, primitive + operations (e.g., eqInt#) are + good,… + + + + + Use strictness annotations: + + Putting a strictness annotation ('!') on a constructor + field helps in two ways: it adds strictness to the program, + which gives the strictness analyser more to work with, and + it might help to reduce space leaks. + + It can also help in a third way: when used with + (see ), a strict field can be unpacked or + unboxed in the constructor, and one or more levels of + indirection may be removed. Unpacking only happens for + single-constructor datatypes (Int is a + good candidate, for example). + + Using is only + really a good idea in conjunction with , + because otherwise the extra packing and unpacking won't be + optimised away. In fact, it is possible that + may worsen + performance even with + , but this is unlikely (let us know if it + happens to you). + + + + + Use unboxed types (a GHC extension): + + When you are really desperate for + speed, and you want to get right down to the “raw + bits.” Please see for + some information about using unboxed types. + + Before resorting to explicit unboxed types, try using + strict constructor fields and + first (see above). + That way, your code stays portable. + + + + + Use foreign import (a GHC extension) to plug into fast libraries: + + This may take real work, but… There exist piles + of massively-tuned library code, and the best thing is not + to compete with it, but link with it. + + describes the foreign function + interface. + + + + + Don't use Floats: + + If you're using Complex, definitely + use Complex Double rather than + Complex Float (the former is specialised + heavily, but the latter isn't). + + Floats (probably 32-bits) are + almost always a bad idea, anyway, unless you Really Know + What You Are Doing. Use Doubles. + There's rarely a speed disadvantage—modern machines + will use the same floating-point unit for both. With + Doubles, you are much less likely to hang + yourself with numerical errors. + + One time when Float might be a good + idea is if you have a lot of them, say + a giant array of Floats. They take up + half the space in the heap compared to + Doubles. However, this isn't true on a + 64-bit machine. + + + + + Use unboxed arrays (UArray) + + GHC supports arrays of unboxed elements, for several + basic arithmetic element types including + Int and Char: see the + Data.Array.Unboxed library for details. + These arrays are likely to be much faster than using + standard Haskell 98 arrays from the + Data.Array library. + + + + + Use a bigger heap! + + If your program's GC stats + (-S RTS + option RTS option) indicate that it's + doing lots of garbage-collection (say, more than 20% + of execution time), more memory might help—with the + -M<size> + RTS option or + -A<size> + RTS option RTS options (see ). + + + + + + + +Smaller: producing a program that is smaller + + + +smaller programs, how to produce + + + +Decrease the “go-for-it” threshold for unfolding smallish +expressions. Give a +-funfolding-use-threshold0 +option option for the extreme case. (“Only unfoldings with +zero cost should proceed.”) Warning: except in certain specialised +cases (like Happy parsers) this is likely to actually +increase the size of your program, because unfolding +generally enables extra simplifying optimisations to be performed. + + + +Avoid Read. + + + +Use strip on your executables. + + + + + +Thriftier: producing a program that gobbles less heap space + + + +memory, using less heap +space-leaks, avoiding +heap space, using less + + + +“I think I have a space leak…” Re-run your program +with , and remove all doubt! (You'll +see the heap usage get bigger and bigger…) +[Hmmm…this might be even easier with the + RTS option; so… ./a.out +RTS +-S -G1...] +-G RTS option +-S RTS option + + + +Once again, the profiling facilities () are +the basic tool for demystifying the space behaviour of your program. + + + +Strict functions are good for space usage, as they are for time, as +discussed in the previous section. Strict functions get right down to +business, rather than filling up the heap with closures (the system's +notes to itself about how to evaluate something, should it eventually +be required). + + + + + + + diff --git a/docs/users_guide/ug-book.xml.in b/docs/users_guide/ug-book.xml.in new file mode 100644 index 00000000..b87563ac --- /dev/null +++ b/docs/users_guide/ug-book.xml.in @@ -0,0 +1,31 @@ + + +@ProjectName@ User's Guide, Version @ProjectVersion@ +The GHC Team +
    +glasgow-haskell-users-request@haskell.org +
    +     + +&license; +&intro; +&ghci; +&runghc; +&using; +&prof; +&sooner; +&lang-features; +&ffi-chap; +&extending-ghc; +&wrong; +&utils; +&win32-dll; +&bugs; + + + diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in new file mode 100644 index 00000000..b696aad5 --- /dev/null +++ b/docs/users_guide/ug-ent.xml.in @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml new file mode 100644 index 00000000..98c17fcf --- /dev/null +++ b/docs/users_guide/using.xml @@ -0,0 +1,3446 @@ + + + Using GHC + + GHC, using + using GHC + + + Getting started: compiling programs + + + In this chapter you'll find a complete reference to the GHC + command-line syntax, including all 400+ flags. It's a large and + complex system, and there are lots of details, so it can be + quite hard to figure out how to get started. With that in mind, + this introductory section provides a quick introduction to the + basic usage of GHC for compiling a Haskell program, before the + following sections dive into the full syntax. + + + + Let's create a Hello World program, and compile and run it. + First, create a file hello.hs containing + the Haskell code: + + + +main = putStrLn "Hello, World!" + + + To compile the program, use GHC like this: + + +$ ghc hello.hs + + + (where $ represents the prompt: don't + type it). GHC will compile the source + file hello.hs, producing + an object + file hello.o and + an interface + file hello.hi, and then it + will link the object file to the libraries that come with GHC + to produce an executable called hello on + Unix/Linux/Mac, or hello.exe on + Windows. + + + By default GHC will be very quiet about what it is doing, only + printing error messages. If you want to see in more detail + what's going on behind the scenes, add to + the command line. + + + + Then we can run the program like this: + + + +$ ./hello +Hello World! + + + + If your program contains multiple modules, then you only need to + tell GHC the name of the source file containing + the Main module, and GHC will examine + the import declarations to find the other + modules that make up the program and find their source files. + This means that, with the exception of + the Main module, every source file should be + named after the module name that it contains (with dots replaced + by directory separators). For example, the + module Data.Person would be in the + file Data/Person.hs on Unix/Linux/Mac, + or Data\Person.hs on Windows. + + + + + Options overview + + GHC's behaviour is controlled by + options, which for historical reasons are + also sometimes referred to as command-line flags or arguments. + Options can be specified in three ways: + + + Command-line arguments + + structure, command-line + command-linearguments + argumentscommand-line + + An invocation of GHC takes the following form: + + +ghc [argument...] + + + Command-line arguments are either options or file names. + + Command-line options begin with -. + They may not be grouped: + is different from . + Options need not precede filenames: e.g., ghc *.o -o + foo. All options are processed and then applied to + all files; you cannot, for example, invoke ghc -c -O1 + Foo.hs -O2 Bar.hs to apply different optimisation + levels to the files Foo.hs and + Bar.hs. + + + + Command line options in source files + + source-file options + + Sometimes it is useful to make the connection between a + source file and the command-line options it requires quite + tight. For instance, if a Haskell source file deliberately + uses name shadowing, it should be compiled with the + option. Rather than maintaining + the list of per-file options in a Makefile, + it is possible to do this directly in the source file using the + OPTIONS_GHC pragma OPTIONS_GHC + pragma: + + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module X where +... + + + OPTIONS_GHC is a file-header pragma + (see ). + + Only dynamic flags can be used in an OPTIONS_GHC pragma + (see ). + + Note that your command shell does not + get to the source file options, they are just included literally + in the array of command-line arguments the compiler + maintains internally, so you'll be desperately disappointed if + you try to glob etc. inside OPTIONS_GHC. + + NOTE: the contents of OPTIONS_GHC are appended to the + command-line options, so options given in the source file + override those given on the command-line. + + It is not recommended to move all the contents of your + Makefiles into your source files, but in some circumstances, the + OPTIONS_GHC pragma is the Right Thing. (If you + use and have OPTION flags in + your module, the OPTIONS_GHC will get put into the generated .hc + file). + + + + Setting options in GHCi + + Options may also be modified from within GHCi, using the + :set command. See + for more details. + + + + + Static, Dynamic, and Mode options + staticoptions + + dynamicoptions + + modeoptions + + + Each of GHC's command line options is classified as + static, dynamic or + mode: + + + + Mode flags + + For example, or . + There may only be a single mode flag on the command line. The + available modes are listed in . + + + + Dynamic Flags + + Most non-mode flags fall into this category. A dynamic flag + may be used on the command line, in a + OPTIONS_GHC pragma in a source file, or set + using :set in GHCi. + + + + Static Flags + + A few flags are "static", which means they can only be used on + the command-line, and remain in force over the entire GHC/GHCi + run. + + + + + The flag reference tables () lists the status of each flag. + + There are a few flags that are static except that they can + also be used with GHCi's :set command; these + are listed as “static/:set” in the + table. + + + + Meaningful file suffixes + + suffixes, file + file suffixes for GHC + + File names with “meaningful” suffixes (e.g., + .lhs or .o) cause the + “right thing” to happen to those files. + + + + + .hs + + A Haskell module. + + + + + + .lhs + lhs suffix + + + A “literate Haskell” module. + + + + + .hspp + + A file created by the preprocessor. + + + + + .hi + + A Haskell interface file, probably + compiler-generated. + + + + + .hc + + Intermediate C file produced by the Haskell + compiler. + + + + + .c + + A C file not produced by the Haskell + compiler. + + + + + .ll + + An llvm-intermediate-language source file, usually + produced by the compiler. + + + + + .bc + + An llvm-intermediate-language bitcode file, usually + produced by the compiler. + + + + + .s + + An assembly-language source file, usually produced by + the compiler. + + + + + .o + + An object file, produced by an assembler. + + + + + Files with other suffixes (or without suffixes) are passed + straight to the linker. + + + + + Modes of operation + help options + + + GHC's behaviour is firstly controlled by a mode flag. Only one + of these flags may be given, but it does not necessarily need to + be the first option on the command-line. + + + + If no mode flag is present, then GHC will enter make mode + () if there are any Haskell source + files given on the command line, or else it will link the + objects named on the command line to produce an executable. + + + The available mode flags are: + + + + + ghc --interactive + + interactive mode + ghci + + + Interactive mode, which is also available as + ghci. Interactive mode is described in + more detail in . + + + + + + ghc --make + + make mode + + + + In this mode, GHC will build a multi-module Haskell + program automatically, figuring out dependencies for itself. + If you have a straightforward Haskell program, this is + likely to be much easier, and faster, than using + make. Make mode is described in . + + + This mode is the default if there are any Haskell + source files mentioned on the command line, and in this case + the option can be omitted. + + + + + + + ghc -e + expr + + eval mode + + + Expression-evaluation mode. This is very similar to + interactive mode, except that there is a single expression + to evaluate (expr) which is given + on the command line. See for + more details. + + + + + + + ghc -E + ghc -C + ghc -S + ghc -c + + + + + + + + This is the traditional batch-compiler mode, in which + GHC can compile source files one at a time, or link objects + together into an executable. See . + + + + + + + ghc -M + + dependency-generation mode + + + Dependency-generation mode. In this mode, GHC can be + used to generate dependency information suitable for use in + a Makefile. See . + + + + + + + ghc --mk-dll + + DLL-creation mode + + + DLL-creation mode (Windows only). See . + + + + + + + ghc --help ghc -? + + + + + Cause GHC to spew a long usage message to standard + output and then exit. + + + + + + + ghc --show-iface file + + + + + Read the interface in + file and dump it as text to + stdout. For example ghc --show-iface M.hi. + + + + + + + ghc --supported-extensions + ghc --supported-languages + + + + + Print the supported language extensions. + + + + + + + ghc --show-options + + + + + Print the supported command line options. This flag can be used for autocompletion in a shell. + + + + + + + ghc --info + + + + + Print information about the compiler. + + + + + + + ghc --version + ghc -V + + + + + + Print a one-line string including GHC's version number. + + + + + + + ghc --numeric-version + + + + + Print GHC's numeric version number only. + + + + + + + ghc --print-libdir + + + + + Print the path to GHC's library directory. This is + the top of the directory tree containing GHC's libraries, + interfaces, and include files (usually something like + /usr/local/lib/ghc-5.04 on Unix). This + is the value of + $libdirlibdir + in the package configuration file + (see ). + + + + + + + Using <command>ghc</command> <option>--make</option> + + separate compilation + + In this mode, GHC will build a multi-module Haskell program by following + dependencies from one or more root modules (usually just + Main). For example, if your + Main module is in a file called + Main.hs, you could compile and link the + program like this: + + +ghc --make Main.hs + + + + In fact, GHC enters make mode automatically if there are any + Haskell source files on the command line and no other mode is + specified, so in this case we could just type + + + +ghc Main.hs + + + Any number of source file names or module names may be + specified; GHC will figure out all the modules in the program by + following the imports from these initial modules. It will then + attempt to compile each module which is out of date, and + finally, if there is a Main module, the + program will also be linked into an executable. + + The main advantages to using ghc + --make over traditional + Makefiles are: + + + + GHC doesn't have to be restarted for each compilation, + which means it can cache information between compilations. + Compiling a multi-module program with ghc + --make can be up to twice as fast as + running ghc individually on each source + file. + + + You don't have to write a Makefile. + Makefilesavoiding + + + GHC re-calculates the dependencies each time it is + invoked, so the dependencies never get out of sync with the + source. + + + Using the -j flag, you can compile + modules in parallel. Specify -jN to + compile N jobs in parallel. + + + + Any of the command-line options described in the rest of + this chapter can be used with + , but note that any options + you give on the command line will apply to all the source files + compiled, so if you want any options to apply to a single source + file only, you'll need to use an OPTIONS_GHC + pragma (see ). + + If the program needs to be linked with additional objects + (say, some auxiliary C code), then the object files can be + given on the command line and GHC will include them when linking + the executable. + + For backward compatibility with existing make scripts, when + used in combination with , the linking phase + is omitted (same as + ). + + Note that GHC can only follow dependencies if it has the + source file available, so if your program includes a module for + which there is no source file, even if you have an object and an + interface file for the module, then GHC will complain. The + exception to this rule is for package modules, which may or may + not have source files. + + The source files for the program don't all need to be in + the same directory; the option can be used + to add directories to the search path (see ). + + + + Expression evaluation mode + + This mode is very similar to interactive mode, except that + there is a single expression to evaluate which is specified on + the command line as an argument to the + option: + + +ghc -e expr + + + Haskell source files may be named on the command line, and + they will be loaded exactly as in interactive mode. The + expression is evaluated in the context of the loaded + modules. + + For example, to load and run a Haskell program containing + a module Main, we might say + + +ghc -e Main.main Main.hs + + + or we can just use this mode to evaluate expressions in + the context of the Prelude: + + +$ ghc -e "interact (unlines.map reverse.lines)" +hello +olleh + + + + + Batch compiler mode + + In batch mode, GHC will compile one or more source files + given on the command line. + + The first phase to run is determined by each input-file + suffix, and the last phase is determined by a flag. If no + relevant flag is present, then go all the way through to linking. + This table summarises: + + + + + + + + + + + Phase of the compilation system + Suffix saying “start here” + Flag saying “stop after” + (suffix of) output file + + + + + literate pre-processor + .lhs + - + .hs + + + + C pre-processor (opt.) + .hs (with + ) + + .hspp + + + + Haskell compiler + .hs + , + .hc, .s + + + + C compiler (opt.) + .hc or .c + + .s + + + + assembler + .s + + .o + + + + linker + other + - + a.out + + + + + + + + + + + Thus, a common invocation would be: + + +ghc -c Foo.hs + + + to compile the Haskell source file + Foo.hs to an object file + Foo.o. + + Note: What the Haskell compiler proper produces depends on what + backend code generator is used. See + for more details. + + Note: C pre-processing is optional, the + + flag turns it on. See for more + details. + + Note: The option -E + option runs just the pre-processing passes + of the compiler, dumping the result in a file. + + Note: The option is only available when + GHC is built in unregisterised mode. See + for more details. + + + Overriding the default behaviour for a file + + As described above, the way in which a file is processed by GHC + depends on its suffix. This behaviour can be overridden using the + option: + + + + suffix + + + + Causes all files following this option on the command + line to be processed as if they had the suffix + suffix. For example, to compile a + Haskell module in the file M.my-hs, + use ghc -c -x hs M.my-hs. + + + + + + + + + + Verbosity options + + verbosity options + + See also the , , , + and modes in . + + + + + + + + The option makes GHC + verbose: it reports its version number + and shows (on stderr) exactly how it invokes each phase of + the compilation system. Moreover, it passes the + flag to most phases; each reports its + version number (and possibly some other information). + + Please, oh please, use the option + when reporting bugs! Knowing that you ran the right bits in + the right order is always the first thing we want to + verify. + + + + + + n + + + + To provide more control over the compiler's verbosity, + the flag takes an optional numeric + argument. Specifying on its own is + equivalent to , and the other levels + have the following meanings: + + + + + + Disable all non-essential messages (this is the + default). + + + + + + + Minimal verbosity: print one line per + compilation (this is the default when + or + is on). + + + + + + + Print the name of each compilation phase as it + is executed. (equivalent to + ). + + + + + + + The same as , except that in + addition the full command line (if appropriate) for + each compilation phase is also printed. + + + + + + + The same as except that the + intermediate program representation after each + compilation phase is also printed (excluding + preprocessed and C/assembly files). + + + + + + + + + + + + + + These two flags control the way in which GHC displays types, in error messages and in GHCi. + Using makes GHC print explicit forall + quantification at the top level of a type; normally this is suppressed. For example, in GHCi: + +ghci> let f x = x +ghci> :t f +f :: a -> a +ghci> :set -fprint-explicit-foralls +ghci> :t f +f :: forall a. a -> a + +However, regardless of the flag setting, the quantifiers are printed under these circumstances: + +For nested foralls, e.g. + +ghci> :t GHC.ST.runST +GHC.ST.runST :: (forall s. GHC.ST.ST s a) -> a + + +If any of the quantified type variables has a kind +that mentions a kind variable, e.g. + +ghci> :i Data.Type.Equality.sym +Data.Type.Equality.sym :: + forall (k :: BOX) (a :: k) (b :: k). + (a Data.Type.Equality.:~: b) -> b Data.Type.Equality.:~: a + -- Defined in Data.Type.Equality + + + + + + Using makes GHC print kind arguments + in types, which are normally suppressed. This can be important when you are using kind polymorphism. + For example: + +ghci> :set -XPolyKinds +ghci> data T a = MkT +ghci> :t MkT +MkT :: forall (k :: BOX) (a :: k). T a +ghci> :set -fprint-explicit-foralls +ghci> :t MkT +MkT :: forall (k :: BOX) (a :: k). T k a + + + + + + + + + + + + Causes GHC to emit the full source span of the + syntactic entity relating to an error message. Normally, GHC + emits the source location of the start of the syntactic + entity only. + + For example: + + +test.hs:3:6: parse error on input `where' + + + becomes: + + +test296.hs:3:6-10: parse error on input `where' + + + And multi-line spans are possible too: + + +test.hs:(5,4)-(6,7): + Conflicting definitions for `a' + Bound at: test.hs:5:4 + test.hs:6:7 + In the binding group for: a, b, a + + + Note that line numbers start counting at one, but + column numbers start at zero. This choice was made to + follow existing convention (i.e. this is how Emacs does + it). + + + + + size + + + + Set the minimum size of the heap to + size. + This option is equivalent to + +RTS -Hsize, + see . + + + + + + + + + + Prints a one-line summary of timing statistics for the + GHC run. This option is equivalent to + +RTS -tstderr, see . + + + + + + + &separate; + + + Warnings and sanity-checking + + sanity-checking options + warnings + + + GHC has a number of options that select which types of + non-fatal error messages, otherwise known as warnings, can be + generated during compilation. By default, you get a standard set + of warnings which are generally likely to indicate bugs in your + program. These are: + , + , + , + , + , + , + , + , + , + , + , + , + , + , + , + , + , and + . + The following flags are simple ways to select standard + “packages” of warnings: + + + + + + : + + -W option + Provides the standard warnings plus + , + , + , + , + , and + . + + + + + : + + + Turns on all warning options that indicate potentially + suspicious code. The warnings that are + not enabled by + are + , + , + , + , + , + , + , + and + . + + + + + : + + + Turns off all warnings, including the standard ones and + those that -Wall doesn't enable. + + + + + : + + + Makes any warning into a fatal error. Useful so that you don't + miss warnings when doing batch compilation. + + + + + : + + + Warnings are treated only as warnings, not as errors. This is + the default, but can be useful to negate a + flag. + + + + + + The full set of warning options is described below. To turn + off any warning, simply give the corresponding + option on the command line. + + + + + : + + + + warnings + + Determines whether the compiler reports typed holes warnings. Has + no effect unless typed holes errors are deferred until runtime. + See and + + + This warning is on by default. + + + + + + : + + + + warnings + Defer as many type errors as possible until runtime. + At compile time you get a warning (instead of an error). At + runtime, if you use a value that depends on a type error, you + get a runtime error; but you can run any type-correct parts of your code + just fine. See + + + + + : + + + + warnings + + Defer typed holes errors until runtime. This will turn the errors + produced by typed holes into + warnings. Using a value that depends on a typed hole produces a + runtime error, the same as + (which implies this option). See + and . + + + Implied by . See also + . + + + + + + : + + + + warnings + + Determines whether the compiler reports holes in partial type + signatures as warnings. Has no effect unless + is enabled, which + controls whether errors should be generated for holes in types + or not. See . + + + This warning is on by default. + + + + + : + + + + warnings + When a name or package is not found in scope, make + suggestions for the name or package you might have meant instead. + This option is on by default. + + + + + : + + + + warnings + pragmas + Causes a warning to be emitted when a + pragma that GHC doesn't recognise is used. As well as pragmas + that GHC itself uses, GHC also recognises pragmas known to be used + by other tools, e.g. OPTIONS_HUGS and + DERIVE. + + This option is on by default. + + + + + : + + + + warnings + pragmas + Causes a warning to be emitted when GHC detects that a + module contains a pragma that has no effect. + + This option is on by default. + + + + + : + + + + warnings + deprecations + Causes a warning to be emitted when a + module, function or type with a WARNING or DEPRECATED pragma + is used. See for more + details on the pragmas. + + This option is on by default. + + + + + : + + + + amp + applicative-monad proposal + Causes a warning to be emitted when a definition + is in conflict with the AMP (Applicative-Monad proosal), + namely: + 1. Instance of Monad without Applicative; + 2. Instance of MonadPlus without Alternative; + 3. Custom definitions of join/pure/<*> + + This option is on by default. + + + + + : + + + + deprecated-flags + Causes a warning to be emitted when a deprecated + commandline flag is used. + + This option is on by default. + + + + + : + + + + Causes a warning to be emitted for foreign declarations + that use unsupported calling conventions. In particular, + if the stdcall calling convention is used + on an architecture other than i386 then it will be treated + as ccall. + + + + + : + + + + Causes a warning to be emitted for foreign imports of + the following form: + + +foreign import "f" f :: FunPtr t + + + on the grounds that it probably should be + + +foreign import "&f" f :: FunPtr t + + + The first form declares that `f` is a (pure) C + function that takes no arguments and returns a pointer to a + C function with type `t`, whereas the second form declares + that `f` itself is a C function with type `t`. The first + declaration is usually a mistake, and one that is hard to + debug because it results in a crash, hence this + warning. + + + + + : + + + + Causes a warning to be emitted when a datatype + T is exported + with all constructors, i.e. T(..), but is it + just a type synonym. + Also causes a warning to be emitted when a module is + re-exported, but that module exports nothing. + + + + + : + + + + Causes a warning to be emitted in the following cases: + + + When a datatype T is imported with all + constructors, i.e. T(..), but has been + exported abstractly, i.e. T. + + + + When an import statement hides an + entity that is not exported. + + + + + + + : + + + + + Causes a warning to be emitted if a literal will overflow, + e.g. 300 :: Word8. + + + + + + : + + + + + Causes a warning to be emitted if an enumeration is + empty, e.g. [5 .. 3]. + + + + + + : + + + + This flag is a no-op, and will be removed in GHC 7.10. + + + + + : + + + duplicate constraints, warning + + Have the compiler warn about duplicate constraints in a type signature. For + example + + f :: (Eq a, Show a, Eq a) => a -> a + + The warning will indicate the duplicated Eq a constraint. + + + This option is on by default. + + + + + : + + + duplicate exports, warning + export lists, duplicates + + Have the compiler warn about duplicate entries in + export lists. This is useful information if you maintain + large export lists, and want to avoid the continued export + of a definition after you've deleted (one) mention of it in + the export list. + + This option is on by default. + + + + + : + + + shadowing + interface files + + Causes the compiler to emit a warning when a module or + interface file in the current directory is shadowing one + with the same module name in a library or other + directory. + + + + + : + + + Causes the compiler to emit a warning when a Prelude numeric + conversion converts a type T to the same type T; such calls + are probably no-ops and can be omitted. The functions checked for + are: toInteger, + toRational, + fromIntegral, + and realToFrac. + + + + + + : + + + implicit prelude, warning + Have the compiler warn if the Prelude is implicitly + imported. This happens unless either the Prelude module is + explicitly imported with an import ... Prelude ... + line, or this implicit import is disabled (either by + or a + LANGUAGE NoImplicitPrelude pragma). + + Note that no warning is given for syntax that implicitly + refers to the Prelude, even if + would change whether it refers to the Prelude. + For example, no warning is given when + 368 means + Prelude.fromInteger (368::Prelude.Integer) + (where Prelude refers to the actual Prelude module, + regardless of the imports of the module being compiled). + + This warning is off by default. + + + + + , + : + + + + + incomplete patterns, warning + patterns, incomplete + + The option warns + about places where + a pattern-match might fail at runtime. + The function + g below will fail when applied to + non-empty lists, so the compiler will emit a warning about + this when is + enabled. + + +g [] = 2 + + + This option isn't enabled by default because it can be + a bit noisy, and it doesn't always indicate a bug in the + program. However, it's generally considered good practice + to cover all the cases in your functions, and it is switched + on by . + + The flag is + similar, except that it + applies only to lambda-expressions and pattern bindings, constructs + that only allow a single pattern: + + +h = \[] -> 2 +Just k = f y + + + + + + + + : + + + incomplete record updates, warning + record updates, incomplete + + The function + f below will fail when applied to + Bar, so the compiler will emit a warning about + this when is + enabled. + + +data Foo = Foo { x :: Int } + | Bar + +f :: Foo -> Foo +f foo = foo { x = 6 } + + + This option isn't enabled by default because it can be + very noisy, and it often doesn't indicate a bug in the + program. + + + + + + : + + missing fields, warning + fields, missing + + + + This option is on by default, and warns you whenever + the construction of a labelled field constructor isn't + complete, missing initializers for one or more fields. While + not an error (the missing fields are initialised with + bottoms), it is often an indication of a programmer error. + + + + + + : + + missing import lists, warning + import lists, missing + + + + This flag warns if you use an unqualified + import declaration + that does not explicitly list the entities brought into scope. For + example + + + +module M where + import X( f ) + import Y + import qualified Z + p x = f x x + + + + The flag will warn about the import + of Y but not X + If module Y is later changed to export (say) f, + then the reference to f in M will become + ambiguous. No warning is produced for the import of Z + because extending Z's exports would be unlikely to produce + ambiguity in M. + + + + + + : + + + missing methods, warning + methods, missing + + This option is on by default, and warns you whenever + an instance declaration is missing one or more methods, and + the corresponding class declaration has no default + declaration for them. + The warning is suppressed if the method name + begins with an underscore. Here's an example where this is useful: + + class C a where + _simpleFn :: a -> String + complexFn :: a -> a -> String + complexFn x y = ... _simpleFn ... + + The idea is that: (a) users of the class will only call complexFn; + never _simpleFn; and (b) + instance declarations can define either complexFn or _simpleFn. + + The MINIMAL pragma can be used to change which combination of methods will be required for instances of a particular class. See . + + + + + : + + + type signatures, missing + + If you would like GHC to check that every top-level + function/value has a type signature, use the + option. As part of + the warning GHC also reports the inferred type. The + option is off by default. + + + + + : + + + type signatures, missing + + If you would like GHC to check that every exported top-level + function/value has a type signature, but not check unexported values, use the + option. This option + takes precedence over . + As part of the warning GHC also reports the inferred type. The + option is off by default. + + + + + : + + + type signatures, missing + + If you use the + flag GHC will warn + you about any polymorphic local bindings. As part of + the warning GHC also reports the inferred type. The + option is off by default. + + + + + : + + + shadowing, warning + + This option causes a warning to be emitted whenever an + inner-scope value has the same name as an outer-scope value, + i.e. the inner value shadows the outer one. This can catch + typographical errors that turn into hard-to-find bugs, e.g., + in the inadvertent capture of what would be a recursive call in + f = ... let f = id in ... f .... + The warning is suppressed for names beginning with an underscore. For example + + f x = do { _ignore <- this; _ignore <- that; return (the other) } + + + + + + + : + + + + orphan instances, warning + orphan rules, warning + + These flags cause a warning to be emitted whenever the + module contains an "orphan" instance declaration or rewrite rule. + An instance declaration is an orphan if it appears in a module in + which neither the class nor the type being instanced are declared + in the same module. A rule is an orphan if it is a rule for a + function declared in another module. A module containing any + orphans is called an orphan module. + The trouble with orphans is that GHC must pro-actively read the interface + files for all orphan modules, just in case their instances or rules + play a role, whether or not the module's interface would otherwise + be of any use. See for details. + + The flag warns about user-written + orphan rules or instances. The flag + warns about automatically-generated orphan rules, notably as a result of + specialising functions, for type classes (Specialise) + or argument values (-fspec-constr). + + + + + + : + + overlapping patterns, warning + patterns, overlapping + + + By default, the compiler will warn you if a set of + patterns are overlapping, e.g., + + +f :: String -> Int +f [] = 0 +f (_:xs) = 1 +f "2" = 2 + + + where the last pattern match in f + won't ever be reached, as the second pattern overlaps + it. More often than not, redundant patterns is a programmer + mistake/error, so this option is enabled by default. + + + + + : + + + tabs, warning + Have the compiler warn if there are tabs in your source + file. + + + + + : + + + defaulting mechanism, warning + Have the compiler warn/inform you where in your source + the Haskell defaulting mechanism for numeric types kicks + in. This is useful information when converting code from a + context that assumed one default into one with another, + e.g., the ‘default default’ for Haskell 1.4 caused the + otherwise unconstrained value 1 to be + given the type Int, whereas Haskell 98 + and later + defaults it to Integer. This may lead to + differences in performance and behaviour, hence the + usefulness of being non-silent about this. + + This warning is off by default. + + + + + : + + + monomorphism restriction, warning + Have the compiler warn/inform you where in your source + the Haskell Monomorphism Restriction is applied. If applied silently + the MR can give rise to unexpected behaviour, so it can be helpful + to have an explicit warning that it is being applied. + + This warning is off by default. + + + + + : + + + promoted constructor, warning + Warn if a promoted data constructor is used without a tick preceding it's name. + + For example: + + +data Nat = Succ Nat | Zero + +data Vec n s where + Nil :: Vec Zero a + Cons :: a -> Vec n a -> Vec (Succ n) a + + Will raise two warnings because Zero + and Succ are not written as 'Zero and + 'Succ. + + This warning is enabled by default in -Wall mode. + + + + + : + + + unused binds, warning + binds, unused + Report any function definitions (and local bindings) + which are unused. More precisely: + + + Warn if a binding brings into scope a variable that is not used, + except if the variable's name starts with an underscore. The "starts-with-underscore" + condition provides a way to selectively disable the warning. + + + A variable is regarded as "used" if + + It is exported, or + It appears in the right hand side of a binding that binds at + least one used variable that is used + + For example + +module A (f) where +f = let (p,q) = rhs1 in t p -- Warning about unused q +t = rhs3 -- No warning: f is used, and hence so is t +g = h x -- Warning: g unused +h = rhs2 -- Warning: h is only used in the right-hand side of another unused binding +_w = True -- No warning: _w starts with an underscore + + + + + Warn if a pattern binding binds no variables at all, unless it is a lone, possibly-banged, wild-card pattern. + For example: + +Just _ = rhs3 -- Warning: unused pattern binding +(_, _) = rhs4 -- Warning: unused pattern binding +_ = rhs3 -- No warning: lone wild-card pattern +!_ = rhs4 -- No warning: banged wild-card pattern; behaves like seq + + The motivation for allowing lone wild-card patterns is they + are not very different from _v = rhs3, + which elicits no warning; and they can be useful to add a type + constraint, e.g. _ = x::Int. A lone + banged wild-card pattern is is useful as an alternative + (to seq) way to force evaluation. + + + + + + + + + : + + + unused imports, warning + imports, unused + + Report any modules that are explicitly imported but + never used. However, the form import M() is + never reported as an unused import, because it is a useful idiom + for importing instance declarations, which are anonymous in Haskell. + + + + + : + + + unused matches, warning + matches, unused + + Report all unused variables which arise from pattern + matches, including patterns consisting of a single variable. + For instance f x y = [] would report + x and y as unused. The + warning is suppressed if the variable name begins with an underscore, thus: + + f _x = True + + + + + + + : + + + unused do binding, warning + do binding, unused + + Report expressions occurring in do and mdo blocks + that appear to silently throw information away. + For instance do { mapM popInt xs ; return 10 } would report + the first statement in the do block as suspicious, + as it has the type StackM [Int] and not StackM (), but that + [Int] value is not bound to anything. The warning is suppressed by + explicitly mentioning in the source code that your program is throwing something away: + + do { _ <- mapM popInt xs ; return 10 } + + Of course, in this particular situation you can do even better: + + do { mapM_ popInt xs ; return 10 } + + + + + + + : + + + implicit context quantification, warning + context, implicit quantification + + Report if a variable is quantified only due to its presence + in a context (see ). For example, + + type T a = Monad m => a -> f a + + It is recommended to write this polymorphic type as + + type T a = forall m. Monad m => a -> f a + + instead. + + + + + + : + + + apparently erroneous do binding, warning + do binding, apparently erroneous + + Report expressions occurring in do and mdo blocks + that appear to lack a binding. + For instance do { return (popInt 10) ; return 10 } would report + the first statement in the do block as suspicious, + as it has the type StackM (StackM Int) (which consists of two nested applications + of the same monad constructor), but which is not then "unpacked" by binding the result. + The warning is suppressed by explicitly mentioning in the source code that your program is throwing something away: + + do { _ <- return (popInt 10) ; return 10 } + + For almost all sensible programs this will indicate a bug, and you probably intended to write: + + do { popInt 10 ; return 10 } + + + + + + + : + + + Warn if a rewrite RULE might fail to fire because the function might be + inlined before the rule has a chance to fire. See . + + + + + + + If you're feeling really paranoid, the + + option + is a good choice. It turns on heavyweight intra-pass + sanity-checking within GHC. (It checks GHC's sanity, not + yours.) + + + + &packages; + + + Optimisation (code improvement) + + optimisation + improvement, code + + The options specify convenient + “packages” of optimisation flags; the + options described later on specify + individual optimisations to be turned on/off; + the options specify + machine-specific optimisations to be turned + on/off. + + + <option>-O*</option>: convenient “packages” of optimisation flags. + + There are many options that affect + the quality of code produced by GHC. Most people only have a + general goal, something like “Compile quickly” or + “Make my program run like greased lightning.” The + following “packages” of optimisations (or lack + thereof) should suffice. + + Note that higher optimisation levels cause more + cross-module optimisation to be performed, which can have an + impact on how much of your program needs to be recompiled when + you change something. This is one reason to stick to + no-optimisation when developing code. + + + + + + No -type option specified: + -O* not specified + + + This is taken to mean: “Please compile + quickly; I'm not over-bothered about compiled-code + quality.” So, for example: ghc -c + Foo.hs + + + + + + : + + + + Means “turn off all optimisation”, + reverting to the same settings as if no + options had been specified. Saying + can be useful if + eg. make has inserted a + on the command line already. + + + + + + or : + -O option + -O1 option + optimisenormally + + + Means: “Generate good-quality code without + taking too long about it.” Thus, for example: + ghc -c -O Main.lhs + + + + + + : + -O2 option + optimiseaggressively + + + Means: “Apply every non-dangerous + optimisation, even if it means significantly longer + compile times.” + + The avoided “dangerous” optimisations + are those that can make runtime or space + worse if you're unlucky. They are + normally turned on or off individually. + + At the moment, is + unlikely to produce better code than + . + + + + + + : + -Odph + optimiseDPH + + + Enables all optimisation, sets + + and . Designed for use with + Data Parallel Haskell (DPH). + + + + + + We don't use a flag for day-to-day + work. We use to get respectable speed; + e.g., when we want to measure something. When we want to go for + broke, we tend to use (and we go for + lots of coffee breaks). + + The easiest way to see what (etc.) + “really mean” is to run with , + then stand back in amazement. + + + + <option>-f*</option>: platform-independent flags + + -f* options (GHC) + -fno-* options (GHC) + + These flags turn on and off individual optimisations. + Flags marked as Enabled by default are + enabled by , and as such you shouldn't + need to set any of them explicitly. A flag + can be negated by saying . + See for a compact list. + + + + + + + + + + On by default. + Merge immediately-nested case expressions that scrutinse the same variable. Example + + case x of + Red -> e1 + _ -> case x of + Blue -> e2 + Green -> e3 +==> + case x of + Red -> e1 + Blue -> e2 + Green -> e2 + + + + + + + + + + + + On by default.. + + + + + + + + + + + On by default.. Enables the common block + elimination optimisation in the code generator. This optimisation + attempts to find identical Cmm blocks and eliminate the duplicates. + + + + + + + + + + + On by default.. Enables the sinking pass + in the code generator. This optimisation + attempts to find identical Cmm blocks and eliminate the duplicates + attempts to move variable bindings closer to their usage sites. It + also inlines simple expressions like literals or registers. + + + + + + + + + + + Switch off CPR analysis in the demand analyser. + + + + + + + + + + + On by default.. Enables the common-sub-expression + elimination optimisation. + Switching this off can be useful if you have some unsafePerformIO + expressions that you don't want commoned-up. + + + + + + + + + + A very experimental flag that makes dictionary-valued + expressions seem cheap to the optimiser. + + + + + + + + + + + Make dictionaries strict. + + + + + + + + + + + On by default for , , + . + + Use a special demand transformer for dictionary selectors. + + + + + + + + + + + On by default. + Eta-reduce lambda expressions, if doing so gets rid of a whole + group of lambdas. + + + + + + + + + + + On by default. + Eta-expand let-bindings to increase their arity. + + + + + + + + + + + Usually GHC black-holes a thunk only when it switches + threads. This flag makes it do so as soon as the thunk is + entered. See + Haskell on a shared-memory multiprocessor. + + + + + + + + + + + When this option is given, intermediate floating + point values can have a greater + precision/range than the final type. Generally this is a + good thing, but some programs may rely on the exact + precision/range of + Float/Double values + and should not use this option for their compilation. + + + Note that the 32-bit x86 native code generator only + supports excess-precision mode, so neither + nor + has any effect. + This is a known bug, see . + + + + + + + + + + + An experimental flag to expose all unfoldings, even for very + large or recursive functions. This allows for all functions to be + inlined while usually GHC would avoid inlining larger functions. + + + + + + + + + + + On by default. + Float let-bindings inwards, nearer their binding site. See + + Let-floating: moving bindings to give faster programs (ICFP'96). + + + This optimisation moves let bindings closer to their use + site. The benefit here is that this may avoid unnecessary + allocation if the branch the let is now on is never executed. It + also enables other optimisation passes to work more effectively + as they have more information locally. + + + This optimisation isn't always beneficial though (so GHC + applies some heuristics to decide when to apply it). The details + get complicated but a simple example is that it is often beneficial + to move let bindings outwards so that multiple let bindings can be + grouped into a larger single let binding, effectively batching + their allocation and helping the garbage collector and allocator. + + + + + + + + + + + On by default. + Run the full laziness optimisation (also known as let-floating), + which floats let-bindings outside enclosing lambdas, in the hope + they will be thereby be computed less often. See + Let-floating: + moving bindings to give faster programs (ICFP'96). + Full laziness increases sharing, which can lead to increased memory + residency. + + + NOTE: GHC doesn't implement complete full-laziness. + When optimisation in on, and + is not given, some transformations that increase sharing are + performed, such as extracting repeated computations from a loop. + These are the same transformations that a fully lazy + implementation would do, the difference is that GHC doesn't + consistently apply full-laziness, so don't rely on it. + + + + + + + + + + + Worker-wrapper removes unused arguments, but usually we do + not remove them all, lest it turn a function closure into a thunk, + thereby perhaps creating a space leak and/or disrupting inlining. + This flag allows worker/wrapper to remove all + value lambdas. Off by default. + + + + + + + + + + + On by default.. + Causes GHC to ignore uses of the function + Exception.assert in source code (in + other words, rewriting Exception.assert p + e to e (see ). + + + + + + + + + + + Tells GHC to ignore all inessential information when reading interface files. + That is, even if M.hi contains unfolding or strictness information + for a function, GHC will ignore that information. + + + + + + + + + + Run demand analysis + again, at the end of the simplification pipeline. We found some opportunities + for discovering strictness that were not visible earlier; and optimisations like + -fspec-constr can create functions with unused arguments which + are eliminated by late demand analysis. Improvements are modest, but so is the + cost. See notes on the Trac wiki page. + + + + + + + + + + + Off by default, but enabled by -O2. + Turn on the liberate-case transformation. This unrolls recursive + function once in its own RHS, to avoid repeated case analysis of + free variables. It's a bit like the call-pattern specialiser + () but for free variables rather than + arguments. + + + + + + + + + + + Set the size threshold for the liberate-case transformation. Default: 2000 + + + + + + + + + + + On by default. + + When this optimisation is enabled the code generator will turn + all self-recursive saturated tail calls into local jumps rather + than function calls. + + + + + + + + + + + Set the maximum size of inline array allocations to n bytes + (default: 128). GHC will allocate non-pinned arrays of statically + known size in the current nursery block if they're no bigger + than n bytes, ignoring GC overheap. This value should be quite + a bit smaller than the block size (typically: 4096). + + + + + + + + + + + Inline memcpy calls if they would generate no more than n pseudo instructions (default: 32). + + + + + + + + + + + Inline memset calls if they would generate no more than n pseudo instructions (default: 32). + + + + + + + + + + + The type checker sometimes displays a fragment of the type environment + in error messages, but only up to some maximum number, set by this flag. + The default is 6. Turning it off with + gives an unlimited number. Syntactically top-level bindings are also + usually excluded (since they may be numerous), but + includes them too. + + + + + + + + + + + Sets the maximal number of iterations for the simplifier. Defult: 4. + + + + + + + + + + + If a worker has that many arguments, none will be unpacked anymore (default: 10) + + + + + + + + + + + Turn off the coercion optimiser. + + + + + + + + + + + Turn off pre-inlining. + + + + + + + + + + + Turn off the "state hack" whereby any lambda with a + State# token as argument is considered to be + single-entry, hence it is considered OK to inline things inside + it. This can improve performance of IO and ST monad code, but it + runs the risk of reducing sharing. + + + + + + + + + + + Tells GHC to omit all inessential information from the + interface file generated for the module being compiled (say M). + This means that a module importing M will see only the + types of the functions that M exports, but + not their unfoldings, strictness info, etc. Hence, for example, + no function exported by M will be inlined into an importing module. + The benefit is that modules that import M will need to be + recompiled less often (only when M's exports change their type, not + when they change their implementation). + + + + + + + + + + On by default. Tells GHC to omit + heap checks when no allocation is being performed. While this improves + binary sizes by about 5%, it also means that threads run in + tight non-allocating loops will not get preempted in a timely + fashion. If it is important to always be able to interrupt such + threads, you should turn this optimization off. Consider also + recompiling all libraries with this optimization turned off, if you + need to guarantee interruptibility. + + + + + + + + + + + Make GHC be more precise about its treatment of bottom (but see also + ). In particular, stop GHC + eta-expanding through a case expression, which is good for + performance, but bad if you are using seq on + partial applications. + + + + + + + + + + + Off by default due to a performance regression bug. + Only applies in combination with the native code generator. + Use the graph colouring register allocator for register allocation + in the native code generator. By default, GHC uses a simpler, + faster linear register allocator. The downside being that the + linear register allocator usually generates worse code. + + + + + + + + + + + Off by default, only applies in combination with + the native code generator. + Use the iterative coalescing graph colouring register allocator for + register allocation in the native code generator. This is the same + register allocator as the one but also + enables iterative coalescing during register allocation. + + + + + + + + + + + Set the number of phases for the simplifier (default 2). Ignored with -O0. + + + + + + + + + + + GHC's optimiser can diverge if you write rewrite rules ( + ) that don't terminate, or (less + satisfactorily) if you code up recursion through data types + (). To avoid making the compiler fall + into an infinite loop, the optimiser carries a "tick count" and + stops inlining and applying rewrite rules when this count is + exceeded. The limit is set as a multiple of the program size, so + bigger programs get more ticks. The + flag lets you change the + multiplier. The default is 100; numbers larger than 100 give more + ticks, and numbers smaller than 100 give fewer. + + + If the tick-count expires, GHC summarises what simplifier + steps it has done; you can use + to generate a much more + detailed list. Usually that identifies the loop quite + accurately, because some numbers are very large. + + + + + + + + + + + Off by default, but enabled by -O2. + Turn on call-pattern specialisation; see + + Call-pattern specialisation for Haskell programs. + + + This optimisation specializes recursive functions according to + their argument "shapes". This is best explained by example so + consider: + +last :: [a] -> a +last [] = error "last" +last (x : []) = x +last (x : xs) = last xs + + In this code, once we pass the initial check for an empty list we + know that in the recursive case this pattern match is redundant. As + such will transform the above code + to: + +last :: [a] -> a +last [] = error "last" +last (x : xs) = last' x xs + where + last' x [] = x + last' x (y : ys) = last' y ys + + + + As well avoid unnecessary pattern matching it also helps avoid + unnecessary allocation. This applies when a argument is strict in + the recursive call to itself but not on the initial entry. As + strict recursive branch of the function is created similar to the + above example. + + + It is also possible for library writers to instruct + GHC to perform call-pattern specialisation extremely + aggressively. This is necessary for some highly optimized + libraries, where we may want to specialize regardless of + the number of specialisations, or the size of the code. As + an example, consider a simplified use-case from the + vector library: + +import GHC.Types (SPEC(..)) + +foldl :: (a -> b -> a) -> a -> Stream b -> a +{-# INLINE foldl #-} +foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + + + Here, after GHC inlines the body of + foldl to a call site, it will perform + call-pattern specialization very aggressively on + foldl_loop due to the use of + SPEC in the argument of the loop + body. SPEC from + GHC.Types is specifically recognized by + the compiler. + + (NB: it is extremely important you use + seq or a bang pattern on the + SPEC argument!) + + In particular, after inlining this will + expose f to the loop body directly, + allowing heavy specialisation over the recursive + cases. + + + + + + + + + + Set the maximum number of specialisations + that will be created for any one function by the SpecConstr + transformation (default: 3). + + + + + + + + + + + Set the size threshold for the SpecConstr transformation (default: 2000). + + + + + + + + + + + On by default. + Specialise each type-class-overloaded function defined in this + module for the types at which it is called in this module. Also + specialise imported functions that have an INLINABLE pragma + () for the types at which they + are called in this module. + + + + + + + + + + + Turn on the static argument transformation, which turns a + recursive function into a non-recursive one with a local + recursive loop. See Chapter 7 of + + Andre Santos's PhD thesis + + + + + + + + + + + On by default.. + Switch on the strictness analyser. There is a very old paper about GHC's + strictness analyser, + Measuring the effectiveness of a simple strictness analyser, + but the current one is quite a bit different. + + + The strictness analyser figures out when arguments and + variables in a function can be treated 'strictly' (that is they + are always evaluated in the function at some point). This allow + GHC to apply certain optimisations such as unboxing that + otherwise don't apply as they change the semantics of the program + when applied to lazy arguments. + + + + + + + + + + + Run an additional strictness analysis before simplifier phase n. + + + + + + + : + + strict constructor fields + constructor fields, strict + + + On by default.. This option + causes all constructor fields which are marked strict + (i.e. “!”) and which representation is smaller + or equal to the size of a pointer to be unpacked, if + possible. It is equivalent to adding an + UNPACK pragma (see ) to every strict constructor + field that fulfils the size restriction. + + + For example, the constructor fields in the following + data types + +data A = A !Int +data B = B !A +newtype C = C B +data D = D !C + + would all be represented by a single + Int# (see ) + value with + enabled. + + + This option is less of a sledgehammer than + : it should rarely make things + worse. If you use + to turn on unboxing by default you can disable it for certain + constructor fields using the NOUNPACK pragma (see + ). + + + Note that for consistency Double, + Word64, and Int64 constructor + fields are unpacked on 32-bit platforms, even though they are + technically larger than a pointer on those platforms. + + + + + + + : + + strict constructor fields + constructor fields, strict + + + This option causes all constructor fields which are marked + strict (i.e. “!”) to be unpacked if possible. It is + equivalent to adding an UNPACK pragma to every + strict constructor field (see ). + + + This option is a bit of a sledgehammer: it might sometimes + make things worse. Selectively unboxing fields by using + UNPACK pragmas might be better. An alternative + is to use to turn on + unboxing by default but disable it for certain constructor + fields using the NOUNPACK pragma (see + ). + + + + + + : + + inlining, controlling + unfolding, controlling + + + (Default: 750) Governs the maximum size that GHC will allow a + function unfolding to be. (An unfolding has a “size” + that reflects the cost in terms of “code bloat” of + expanding (aka inlining) that unfolding at a call site. A bigger + function would be assigned a bigger cost.) + + + Consequences: (a) nothing larger than this will be inlined + (unless it has an INLINE pragma); (b) nothing larger than this + will be spewed into an interface file. + + + Increasing this figure is more likely to result in longer + compile times than faster code. The + is more useful. + + + + + + + : + + inlining, controlling + unfolding, controlling + + + Default: 30 + + + + + + + : + + inlining, controlling + unfolding, controlling + + + Default: 60 + + + + + + + : + + inlining, controlling + unfolding, controlling + + + Default: 1.5 + + + + + + + + + inlining, controlling + unfolding, controlling + + + (Default: 60) This is the magic cut-off figure for unfolding + (aka inlining): below this size, a function definition will be + unfolded at the call-site, any bigger and it won't. The size + computed for a function depends on two things: the actual size of + the expression minus any discounts that apply depending on the + context into which the expression is to be inlined. + + + The difference between this and + is that this one + determines if a function definition will be inlined at + a call site. The other option determines if a + function definition will be kept around at all for potential + inlining. + + + + + + + + + + + Part of Data Parallel Haskell + (DPH). + + On by default. Enable the + vectorisation avoidance optimisation. This + optimisation only works when used in combination with the + transformation. + + While vectorisation of code using DPH is often a big win, it + can also produce worse results for some kinds of code. This + optimisation modifies the vectorisation transformation to try to + determine if a function would be better of unvectorised and if + so, do just that. + + + + + + + + + + Part of Data Parallel Haskell + (DPH). + + Off by default. Enable the + vectorisation optimisation transformation. This + optimisation transforms the nested data parallelism code of programs + using DPH into flat data parallelism. Flat data parallel programs + should have better load balancing, enable SIMD parallelism and + friendlier cache behaviour. + + + + + + + + + + &code-gens; + + &phases; + + &shared_libs; + + + Using Concurrent Haskell + Concurrent Haskellusing + + GHC supports Concurrent Haskell by default, without requiring a + special option or libraries compiled in a certain way. To get access to + the support libraries for Concurrent Haskell, just import + Control.Concurrent. More information on Concurrent Haskell is provided in the documentation for that module. + + + Optionally, the program may be linked with + the option (see + . This provides two benefits: + + + + It enables the RTS option RTS option to be + used, which allows threads to run in + parallelparallelism + on a + multiprocessormultiprocessorSMP + or + multicoremulticore + machine. See . + + + If a thread makes a foreign call (and the call is + not marked unsafe), then other + Haskell threads in the program will continue to run + while the foreign call is in progress. + Additionally, foreign exported + Haskell functions may be called from multiple OS + threads simultaneously. See + . + + + + + The following RTS option(s) affect the behaviour of Concurrent + Haskell programs:RTS options, concurrent + + + + + + RTS option + Sets the context switch interval to s + seconds. A context switch will occur at the next heap block + allocation after the timer expires (a heap block allocation occurs + every 4k of allocation). With or + , context switches will occur as often as + possible (at every heap block allocation). By default, context + switches occur every 20ms. + + + + + + + Using SMP parallelism + parallelism + + SMP + + + GHC supports running Haskell programs in parallel on an SMP + (symmetric multiprocessor). + + There's a fine distinction between + concurrency and parallelism: + parallelism is all about making your program run + faster by making use of multiple processors + simultaneously. Concurrency, on the other hand, is a means of + abstraction: it is a convenient way to structure a program that must + respond to multiple asynchronous events. + + However, the two terms are certainly related. By making use of + multiple CPUs it is possible to run concurrent threads in parallel, + and this is exactly what GHC's SMP parallelism support does. But it + is also possible to obtain performance improvements with parallelism + on programs that do not use concurrency. This section describes how to + use GHC to compile and run parallel programs, in we describe the language features that affect + parallelism. + + + Compile-time options for SMP parallelism + + In order to make use of multiple CPUs, your program must be + linked with the option (see ). Additionally, the following + compiler options affect parallelism: + + + + + + + + Blackholing is the act of marking a thunk (lazy + computuation) as being under evaluation. It is useful for + three reasons: firstly it lets us detect certain kinds of + infinite loop (the NonTermination + exception), secondly it avoids certain kinds of space + leak, and thirdly it avoids repeating a computation in a + parallel program, because we can tell when a computation + is already in progress. + + + The option causes + each thunk to be blackholed as soon as evaluation begins. + The default is "lazy blackholing", whereby thunks are only + marked as being under evaluation when a thread is paused + for some reason. Lazy blackholing is typically more + efficient (by 1-2% or so), because most thunks don't + need to be blackholed. However, eager blackholing can + avoid more repeated computation in a parallel program, and + this often turns out to be important for parallelism. + + + + We recommend compiling any code that is intended to be run + in parallel with the + flag. + + + + + + + + RTS options for SMP parallelism + + There are two ways to run a program on multiple + processors: + call Control.Concurrent.setNumCapabilities from your + program, or use the RTS option. + + + + + + RTS option + Use x simultaneous threads when + running the program. + + The runtime manages a set of virtual processors, + which we call capabilities, the + number of which is determined by the + option. Each capability can run one Haskell thread at a + time, so the number of capabilities is equal to the + number of Haskell threads that can run physically in + parallel. A capability is animated by one or more OS + threads; the runtime manages a pool of OS threads for + each capability, so that if a Haskell thread makes a + foreign call (see ) + another OS thread can take over that capability. + + + Normally x should be + chosen to match the number of CPU cores on the + machineWhether hyperthreading cores + should be counted or not is an open question; please + feel free to experiment and let us know what results you + find.. For example, on a dual-core + machine we would probably use +RTS -N2 + -RTS. + + Omitting x, + i.e. +RTS -N -RTS, lets the runtime + choose the value of x itself + based on how many processors are in your machine. + + Be careful when using all the processors in your + machine: if some of your processors are in use by other + programs, this can actually harm performance rather than + improve it. + + Setting also has the effect of + enabling the parallel garbage collector (see + ). + + The current value of the option + is available to the Haskell program via + Control.Concurrent.getNumCapabilities, + and it may be changed while the program is running by + calling + Control.Concurrent.setNumCapabilities. + + + + + The following options affect the way the runtime schedules + threads on CPUs: + + + + + RTS + option + + Use the OS's affinity facilities to try to pin OS + threads to CPU cores. + + When this option is enabled, the OS threads for a + capability i are bound to the CPU + core i using the API provided by the + OS for setting thread affinity. e.g. on Linux + GHC uses sched_setaffinity(). + + Depending on your workload and the other activity on + the machine, this may or may not result in a performance + improvement. We recommend trying it out and measuring the + difference. + + + + + RTS + option + + Disable automatic migration for load balancing. + Normally the runtime will automatically try to schedule + threads across the available CPUs to make use of idle + CPUs; this option disables that behaviour. Note that + migration only applies to threads; sparks created + by par are load-balanced separately + by work-stealing. + + + This option is probably only of use for concurrent + programs that explicitly schedule threads onto CPUs + with Control.Concurrent.forkOn. + + + + + + + + Hints for using SMP parallelism + + Add the -s RTS option when + running the program to see timing stats, which will help to tell you + whether your program got faster by using more CPUs or not. If the user + time is greater than + the elapsed time, then the program used more than one CPU. You should + also run the program without -N for + comparison. + + The output of +RTS -s tells you how + many “sparks” were created and executed during the + run of the program (see ), which + will give you an idea how well your par + annotations are working. + + GHC's parallelism support has improved in 6.12.1 as a + result of much experimentation and tuning in the runtime + system. We'd still be interested to hear how well it works + for you, and we're also interested in collecting parallel + programs to add to our benchmarking suite. + + + + + Platform-specific Flags + + -m* options + platform-specific options + machine-specific options + + Some flags only make sense for particular target + platforms. + + + + + : + + + (x86 only, added in GHC 7.0.1) Use the SSE2 registers and + instruction set to implement floating point operations when using + the native code generator. + This gives a substantial performance improvement for floating + point, but the resulting compiled code + will only run on processors that support SSE2 (Intel Pentium 4 and + later, or AMD Athlon 64 and later). The + LLVM backend will also use SSE2 + if your processor supports it but detects this automatically so no + flag is required. + + + SSE2 is unconditionally used on x86-64 platforms. + + + + + + : + + + (x86 only, added in GHC 7.4.1) Use the SSE4.2 instruction set to + implement some floating point and bit operations when using the + native code generator. The + resulting compiled code will only run on processors that + support SSE4.2 (Intel Core i7 and later). The + LLVM backend will also use + SSE4.2 if your processor supports it but detects this automatically + so no flag is required. + + + + + + + + +&runtime; +&debug; +&flags; + + + + diff --git a/docs/users_guide/utils.xml b/docs/users_guide/utils.xml new file mode 100644 index 00000000..005f2eda --- /dev/null +++ b/docs/users_guide/utils.xml @@ -0,0 +1,606 @@ + + + Other Haskell utility programs + utilities, Haskell + + This section describes other program(s) which we distribute, + that help with the Great Haskell Programming Task. + + + + + + “Yacc for Haskell”: <command>happy</command> + + Happy + Yacc for Haskell + parser generator for Haskell + + Andy Gill and Simon Marlow have written a parser-generator + for Haskell, called + happy.happy parser + generator Happy is to + Haskell what Yacc is to C. + + You can get happy from the Happy + Homepage. + + Happy is at its shining best when + compiled by GHC. + + + + + + + Writing Haskell interfaces to C code: + <command>hsc2hs</command> + hsc2hs + + + The hsc2hs command can be used to automate + some parts of the process of writing Haskell bindings to C code. + It reads an almost-Haskell source with embedded special + constructs, and outputs a real Haskell file with these constructs + processed, based on information taken from some C headers. The + extra constructs deal with accessing C data from Haskell. + + It may also output a C file which contains additional C + functions to be linked into the program, together with a C header + that gets included into the C code to which the Haskell module + will be compiled (when compiled via C) and into the C file. These + two files are created when the #def construct + is used (see below). + + Actually hsc2hs does not output the Haskell + file directly. It creates a C program that includes the headers, + gets automatically compiled and run. That program outputs the + Haskell code. + + In the following, “Haskell file” is the main + output (usually a .hs file), “compiled + Haskell file” is the Haskell file after + ghc has compiled it to C (i.e. a + .hc file), “C program” is the + program that outputs the Haskell file, “C file” is the + optionally generated C file, and “C header” is its + header file. + + + command line syntax + + hsc2hs takes input files as arguments, + and flags that modify its behavior: + + + + -o FILE or + --output=FILE + + Name of the Haskell file. + + + + + -t FILE or + --template=FILE + + The template file (see below). + + + + + -c PROG or + --cc=PROG + + The C compiler to use (default: + gcc) + + + + + -l PROG or + --ld=PROG + + The linker to use (default: + gcc). + + + + + -C FLAG or + --cflag=FLAG + + An extra flag to pass to the C compiler. + + + + + -I DIR + + Passed to the C compiler. + + + + + -L FLAG or + --lflag=FLAG + + An extra flag to pass to the linker. + + + + + -i FILE or + --include=FILE + + As if the appropriate #include + directive was placed in the source. + + + + + -D NAME[=VALUE] or + --define=NAME[=VALUE] + + As if the appropriate #define + directive was placed in the source. + + + + + --no-compile + + Stop after writing out the intermediate C program to disk. + The file name for the intermediate C program is the input file name + with .hsc replaced with _hsc_make.c. + + + + + -k or + --keep-files + + Proceed as normal, but do not delete any intermediate files. + + + + + -x or + --cross-compile + + Activate cross-compilation mode (see ). + + + + + --cross-safe + + Restrict the .hsc directives to those supported by the + --cross-compile mode (see ). + This should be useful if your .hsc files + must be safely cross-compiled and you wish to keep + non-cross-compilable constructs from creeping into them. + + + + + + -? or --help + + Display a summary of the available flags and exit successfully. + + + + + -V or --version + + Output version information and exit successfully. + + + + + The input file should end with .hsc (it should be plain + Haskell source only; literate Haskell is not supported at the + moment). Output files by default get names with the + .hsc suffix replaced: + + + + + + .hs + Haskell file + + + _hsc.h + C header + + + _hsc.c + C file + + + + + + The C program is compiled using the Haskell compiler. This + provides the include path to HsFFI.h which + is automatically included into the C program. + + + Input syntax + + All special processing is triggered by + the # operator. To output + a literal #, write it twice: + ##. Inside string literals and comments + # characters are not processed. + + A # is followed by optional + spaces and tabs, an alphanumeric keyword that describes + the kind of processing, and its arguments. Arguments look + like C expressions separated by commas (they are not + written inside parens). They extend up to the nearest + unmatched ), ] or + }, or to the end of line if it occurs outside + any () [] {} '' "" /**/ and is not preceded + by a backslash. Backslash-newline pairs are stripped. + + In addition #{stuff} is equivalent + to #stuff except that it's self-delimited + and thus needs not to be placed at the end of line or in some + brackets. + + Meanings of specific keywords: + + + + + #include <file.h> + #include "file.h" + + The specified file gets included into the C program, + the compiled Haskell file, and the C header. + <HsFFI.h> is included + automatically. + + + + + #define name + #define name value + #undef name + + Similar to #include. Note that + #includes and + #defines may be put in the same file + twice so they should not assume otherwise. + + + + + #let name parameters = "definition" + + Defines a macro to be applied to the Haskell + source. Parameter names are comma-separated, not + inside parens. Such macro is invoked as other + #-constructs, starting with + #name. The definition will be + put in the C program inside parens as arguments of + printf. To refer to a parameter, + close the quote, put a parameter name and open the + quote again, to let C string literals concatenate. + Or use printf's format directives. + Values of arguments must be given as strings, unless the + macro stringifies them itself using the C preprocessor's + #parameter syntax. + + + + + #def C_definition + + The definition (of a function, variable, struct or + typedef) is written to the C file, and its prototype or + extern declaration to the C header. Inline functions are + handled correctly. struct definitions and typedefs are + written to the C program too. The + inline, struct or + typedef keyword must come just after + def. + + + + + #if condition + #ifdef name + #ifndef name + #elif condition + #else + #endif + #error message + #warning message + + Conditional compilation directives are passed + unmodified to the C program, C file, and C header. Putting + them in the C program means that appropriate parts of the + Haskell file will be skipped. + + + + + #const C_expression + + The expression must be convertible to + long or unsigned + long. Its value (literal or negated literal) + will be output. + + + + + #const_str C_expression + + The expression must be convertible to const char + pointer. Its value (string literal) will be output. + + + + + #type C_type + + A Haskell equivalent of the C numeric type will be + output. It will be one of + {Int,Word}{8,16,32,64}, + Float, Double, + LDouble. + + + + + #peek struct_type, field + + A function that peeks a field of a C struct will be + output. It will have the type + Storable b => Ptr a -> IO b. + + The intention is that #peek and + #poke can be used for implementing the + operations of class Storable for a + given C struct (see the + Foreign.Storable module in the library + documentation). + + + + + #poke struct_type, field + + Similarly for poke. It will have the type + Storable b => Ptr a -> b -> IO (). + + + + + #ptr struct_type, field + + Makes a pointer to a field struct. It will have the type + Ptr a -> Ptr b. + + + + + #offset struct_type, field + + Computes the offset, in bytes, of + field in + struct_type. It will have type + Int. + + + + + #size struct_type + + Computes the size, in bytes, of + struct_type. It will have type + Int. + + + + + #enum type, constructor, value, value, ... + + A shortcut for multiple definitions which use + #const. Each value + is a name of a C integer constant, e.g. enumeration value. + The name will be translated to Haskell by making each + letter following an underscore uppercase, making all the rest + lowercase, and removing underscores. You can supply a different + translation by writing hs_name = c_value + instead of a value, in which case + c_value may be an arbitrary expression. + The hs_name will be defined as having the + specified type. Its definition is the specified + constructor (which in fact may be an expression + or be empty) applied to the appropriate integer value. You can + have multiple #enum definitions with the same + type; this construct does not emit the type + definition itself. + + + + + + + + Custom constructs + + #const, #type, + #peek, #poke and + #ptr are not hardwired into the + hsc2hs, but are defined in a C template that is + included in the C program: template-hsc.h. + Custom constructs and templates can be used too. Any + #-construct with unknown key is expected to + be handled by a C template. + + A C template should define a macro or function with name + prefixed by hsc_ that handles the construct + by emitting the expansion to stdout. See + template-hsc.h for examples. + + Such macros can also be defined directly in the + source. They are useful for making a #let-like + macro whose expansion uses other #let macros. + Plain #let prepends hsc_ + to the macro name and wraps the definition in a + printf call. + + + + + Cross-compilation + + hsc2hs normally operates by creating, compiling, + and running a C program. That approach doesn't work when cross-compiling -- + in this case, the C compiler's generates code for the target machine, + not the host machine. For this situation, there's + a special mode hsc2hs --cross-compile which can generate + the .hs by extracting information from compilations only -- specifically, + whether or not compilation fails. + + + Only a subset of .hsc syntax is supported by + --cross-compile. The following are unsupported: + + #{const_str} + #{let} + #{def} + Custom constructs + + + + + + + + + diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml new file mode 100644 index 00000000..f9a399c4 --- /dev/null +++ b/docs/users_guide/win32-dlls.xml @@ -0,0 +1,574 @@ + + +Running GHC on Win32 systems + + + +Starting GHC on Windows platforms + + +The installer that installs GHC on Win32 also sets up the file-suffix associations +for ".hs" and ".lhs" files so that double-clicking them starts ghci. + + +Be aware of that ghc and ghci do +require filenames containing spaces to be escaped using quotes: + + c:\ghc\bin\ghci "c:\\Program Files\\Haskell\\Project.hs" + +If the quotes are left off in the above command, ghci will +interpret the filename as two, "c:\\Program" and "Files\\Haskell\\Project.hs". + + + + + + + +Running GHCi on Windows + + We recommend running GHCi in a standard Windows console: + select the GHCi option from the start menu item + added by the GHC installer, or use + Start->Run->cmd to get a Windows console and + invoke ghci from there (as long as it's in your + PATH). + + If you run GHCi in a Cygwin or MSYS shell, then the Control-C + behaviour is adversely affected. In one of these environments you + should use the ghcii.sh script to start GHCi, + otherwise when you hit Control-C you'll be returned to the shell + prompt but the GHCi process will still be running. However, even + using the ghcii.sh script, if you hit Control-C + then the GHCi process will be killed immediately, rather than + letting you interrupt a running program inside GHCi as it should. + This problem is caused by the fact that the Cygwin and MSYS shell + environments don't pass Control-C events to non-Cygwin child + processes, because in order to do that there needs to be a Windows + console. + + There's an exception: you can use a Cygwin shell if the + CYGWIN environment variable does + not contain tty. In this + mode, the Cygwin shell behaves like a Windows console shell and + console events are propagated to child processes. Note that the + CYGWIN environment variable must be set + before starting the Cygwin shell; changing it + afterwards has no effect on the shell. + + This problem doesn't just affect GHCi, it affects any + GHC-compiled program that wants to catch console events. See the + GHC.ConsoleHandler + module. + + + + +Interacting with the terminal + +By default GHC builds applications that open a console window when they start. +If you want to build a GUI-only application, with no console window, use the flag +-optl-mwindows in the link step. + + + Warning: Windows GUI-only programs have no + stdin, stdout or stderr so using the ordinary Haskell + input/output functions will cause your program to fail with an + IO exception, such as: + + Fail: <stdout>: hPutChar: failed (Bad file descriptor) + + However using Debug.Trace.trace is alright because it uses + Windows debugging output support rather than stderr. + +For some reason, Mingw ships with the readline library, +but not with the readline headers. As a result, GHC (like Hugs) does not +use readline for interactive input on Windows. +You can get a close simulation by using an emacs shell buffer! + + + + + + +Differences in library behaviour + + +Some of the standard Haskell libraries behave slightly differently on Windows. + + + +On Windows, the '^Z' character is interpreted as an +end-of-file character, so if you read a file containing this character +the file will appear to end just before it. To avoid this, +use IOExts.openFileEx to open a file in binary +(untranslated) mode or change an already opened file handle into +binary mode using IOExts.hSetBinaryMode. The +IOExts module is part of the +lang package. + + + + + + + + +Using GHC (and other GHC-compiled executables) with cygwin + + +Background The cygwin tools aim to provide a +unix-style API on top of the windows libraries, to facilitate ports of +unix software to windows. To this end, they introduce a unix-style +directory hierarchy under some root directory (typically +/ is C:\cygwin\). Moreover, +everything built against the cygwin API (including the cygwin tools +and programs compiled with cygwin's ghc) will see / as the root of +their file system, happily pretending to work in a typical unix +environment, and finding things like /bin and /usr/include without +ever explicitly bothering with their actual location on the windows +system (probably C:\cygwin\bin and C:\cygwin\usr\include). + + + +The problem +GHC, by default, no longer depends on cygwin, but is a native +windows program. It is built using mingw, and it uses mingw's ghc +while compiling your Haskell sources (even if you call it from +cygwin's bash), but what matters here is that - just like any other +normal windows program - neither GHC nor the executables it produces +are aware of cygwin's pretended unix hierarchy. GHC will happily +accept either '/' or '\' as path separators, but it won't know where +to find /home/joe/Main.hs or /bin/bash +or the like. This causes all +kinds of fun when GHC is used from within cygwin's bash, or in +make-sessions running under cygwin. + + + +Things to do + + + Don't use absolute paths in make, configure & co if there is any chance + that those might be passed to GHC (or to GHC-compiled programs). Relative + paths are fine because cygwin tools are happy with them and GHC accepts + '/' as path-separator. And relative paths don't depend on where cygwin's + root directory is located, or on which partition or network drive your source + tree happens to reside, as long as you 'cd' there first. + + + + If you have to use absolute paths (beware of the innocent-looking + ROOT=`pwd` in makefile hierarchies or configure scripts), cygwin provides + a tool called cygpath that can convert cygwin's unix-style paths to their + actual windows-style counterparts. Many cygwin tools actually accept + absolute windows-style paths (remember, though, that you either need + to escape '\' or convert '\' to '/'), so you should be fine just using those + everywhere. If you need to use tools that do some kind of path-mangling + that depends on unix-style paths (one fun example is trying to interpret ':' + as a separator in path lists..), you can still try to convert paths using + cygpath just before they are passed to GHC and friends. + + + + If you don't have cygpath, you probably don't have cygwin and hence + no problems with it... unless you want to write one build process for several + platforms. Again, relative paths are your friend, but if you have to use + absolute paths, and don't want to use different tools on different platforms, + you can simply write a short Haskell program to print the current directory + (thanks to George Russell for this idea): compiled with GHC, this will give + you the view of the file system that GHC depends on (which will differ + depending on whether GHC is compiled with cygwin's gcc or mingw's + gcc or on a real unix system..) - that little program can also deal with + escaping '\' in paths. Apart from the banner and the startup time, + something like this would also do: + + $ echo "Directory.getCurrentDirectory >>= putStrLn . init . tail . show " | ghci + + + + + + + + +Building and using Win32 DLLs + + + +Dynamic link libraries, Win32 +DLLs, Win32 +On Win32 platforms, the compiler is capable of both producing and using +dynamic link libraries (DLLs) containing ghc-compiled code. This +section shows you how to make use of this facility. + + + +There are two distinct ways in which DLLs can be used: + + + + You can turn each Haskell package into a DLL, so that multiple + Haskell executables using the same packages can share the DLL files. + (As opposed to linking the libraries statically, which in effect + creates a new copy of the RTS and all libraries for each executable + produced.) + + + That is the same as the dynamic linking on other platforms, and it + is described in . + + + + + You can package up a complete Haskell program as a DLL, to be called + by some external (usually non-Haskell) program. This is usually used + to implement plugins and the like, and is described below. + + + + + + + + +Creating a DLL + + +Creating a Win32 DLL +-shared +Sealing up your Haskell library inside a DLL is straightforward; +compile up the object files that make up the library, and then build +the DLL by issuing a command of the form: + + + + +ghc -shared -o foo.dll bar.o baz.o wibble.a -lfooble + + + + +By feeding the ghc compiler driver the option , it +will build a DLL rather than produce an executable. The DLL will +consist of all the object files and archives given on the command +line. + + + + + +A couple of things to notice: + + + + + + + + + +By default, the entry points of all the object files will be exported from +the DLL when using . Should you want to constrain +this, you can specify the module definition file to use +on the command line as follows: + + +ghc -shared -o .... MyDef.def + + +See Microsoft documentation for details, but a module definition file +simply lists what entry points you want to export. Here's one that's +suitable when building a Haskell COM server DLL: + + +EXPORTS + DllCanUnloadNow = DllCanUnloadNow@0 + DllGetClassObject = DllGetClassObject@12 + DllRegisterServer = DllRegisterServer@0 + DllUnregisterServer = DllUnregisterServer@0 + + + + + + +In addition to creating a DLL, the option also +creates an import library. The import library name is derived from the +name of the DLL, as follows: + + +DLL: HScool.dll ==> import lib: libHScool.dll.a + + +The naming scheme may look a bit weird, but it has the purpose of allowing +the co-existence of import libraries with ordinary static libraries (e.g., +libHSfoo.a and +libHSfoo.dll.a. + +Additionally, when the compiler driver is linking in non-static mode, it +will rewrite occurrence of on the command line to +. By doing this for you, switching from +non-static to static linking is simply a question of adding + to your command line. + + + + + + + + + + +Making DLLs to be called from other languages + + + This section describes how to create DLLs to be called from other languages, + such as Visual Basic or C++. This is a special case of + ; we'll deal with the DLL-specific issues that + arise below. Here's an example: + + + Use foreign export declarations to export the Haskell functions you want to + call from the outside. For example: + + +-- Adder.hs +{-# LANGUAGE ForeignFunctionInterface #-} +module Adder where + +adder :: Int -> Int -> IO Int -- gratuitous use of IO +adder x y = return (x+y) + +foreign export stdcall adder :: Int -> Int -> IO Int + + + Add some helper code that starts up and shuts down the Haskell RTS: + + +// StartEnd.c +#include <Rts.h> + +void HsStart() +{ + int argc = 1; + char* argv[] = {"ghcDll", NULL}; // argv must end with NULL + + // Initialize Haskell runtime + char** args = argv; + hs_init(&argc, &args); +} + +void HsEnd() +{ + hs_exit(); +} + + + Here, Adder is the name of the root module in the module + tree (as mentioned above, there must be a single root module, and hence a + single module tree in the DLL). Compile everything up: + + +ghc -c Adder.hs +ghc -c StartEnd.c +ghc -shared -o Adder.dll Adder.o Adder_stub.o StartEnd.o + + + Now the file Adder.dll can be used from other + programming languages. Before calling any functions in Adder it is necessary + to call HsStart, and at the very end call + HsEnd. + + + Warning: It may appear tempting to use + DllMain to call + hs_init/hs_exit, but this won't work + (particularly if you compile with -threaded). There are + severe restrictions on which actions can be performed during + DllMain, and hs_init violates these + restrictions, which can lead to your dll freezing during startup (see + bug + #3605). + + + +Using from VBA + + + An example of using Adder.dll from VBA is: + + +Private Declare Function Adder Lib "Adder.dll" Alias "adder@8" _ + (ByVal x As Long, ByVal y As Long) As Long + +Private Declare Sub HsStart Lib "Adder.dll" () +Private Declare Sub HsEnd Lib "Adder.dll" () + +Private Sub Document_Close() +HsEnd +End Sub + +Private Sub Document_Open() +HsStart +End Sub + +Public Sub Test() +MsgBox "12 + 5 = " & Adder(12, 5) +End Sub + + + This example uses the + Document_Open/Close functions of + Microsoft Word, but provided HsStart is called before the + first function, and HsEnd after the last, then it will + work fine. + + + + +Using from C++ + + + An example of using Adder.dll from C++ is: + + + +// Tester.cpp +#include "HsFFI.h" +#include "Adder_stub.h" +#include <stdio.h> + +extern "C" { + void HsStart(); + void HsEnd(); +} + +int main() +{ + HsStart(); + // can now safely call functions from the DLL + printf("12 + 5 = %i\n", adder(12,5)) ; + HsEnd(); + return 0; +} + + + This can be compiled and run with: + + +$ ghc -o tester Tester.cpp Adder.dll.a +$ tester +12 + 5 = 17 + + + + + + + + + + diff --git a/driver/Makefile b/driver/Makefile new file mode 100644 index 00000000..a719b818 --- /dev/null +++ b/driver/Makefile @@ -0,0 +1,15 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +dir = driver +TOP = .. +include $(TOP)/mk/sub-makefile.mk diff --git a/driver/gcc/gcc.c b/driver/gcc/gcc.c new file mode 100644 index 00000000..517b008a --- /dev/null +++ b/driver/gcc/gcc.c @@ -0,0 +1,59 @@ + +/* gcc on mingw is hardcoded to use /mingw (which is c:/mingw) to + find various files. If this is a different version of mingw to the + one that we have in the GHC tree then things can go wrong. We + therefore need to add various -B flags to the gcc commandline, + so that it uses our in-tree mingw. Hence this wrapper. */ + +#include "cwrapper.h" +#include "getLocation.h" + +#include +#include + +int main(int argc, char** argv) { + char *binDir; + char *exePath; + char *preArgv[4]; + char *oldPath; + char *newPath; + int n; + + binDir = getExecutablePath(); + exePath = mkString("%s/realgcc.exe", binDir); + + /* We need programs like + inplace/mingw/libexec/gcc/mingw32/4.5.0/cc1.exe + to be able to find the DLLs in inplace/mingw/bin, so we need to + add it to $PATH */ + oldPath = getenv("PATH"); + if (!oldPath) { + die("Couldn't read PATH\n"); + } + n = snprintf(NULL, 0, "PATH=%s;%s", binDir, oldPath); + n++; + newPath = malloc(n); + if (!newPath) { + die("Couldn't allocate space for PATH\n"); + } + snprintf(newPath, n, "PATH=%s;%s", binDir, oldPath); + n = putenv(newPath); + if (n) { + die("putenv failed\n"); + } + + /* Without these -B args, gcc will still work. However, if you + have a mingw installation in c:/mingw then it will use files + from that in preference to the in-tree files. */ + preArgv[0] = mkString("-B%s", binDir); + preArgv[1] = mkString("-B%s/../lib", binDir); +#ifdef __MINGW64__ + preArgv[2] = mkString("-B%s/../lib/gcc/x86_64-w64-mingw32/5.2.0", binDir); + preArgv[3] = mkString("-B%s/../libexec/gcc/x86_64-w64-mingw32/5.2.0", binDir); +#else + preArgv[2] = mkString("-B%s/../lib/gcc/i686-w64-mingw32/5.2.0", binDir); + preArgv[3] = mkString("-B%s/../libexec/gcc/i686-w64-mingw32/5.2.0", binDir); +#endif + run(exePath, 4, preArgv, argc - 1, argv + 1); +} + diff --git a/driver/ghc-usage.txt b/driver/ghc-usage.txt new file mode 100644 index 00000000..0b56db74 --- /dev/null +++ b/driver/ghc-usage.txt @@ -0,0 +1,81 @@ +Usage: + + $$ [command-line-options-and-input-files] + +To compile and link a complete Haskell program, run the compiler like +so: + + $$ Main + +where the module Main is in a file named Main.hs (or Main.lhs) in the +current directory. The other modules in the program will be located +and compiled automatically, and the linked program will be placed in +the file `Main' (or `Main.exe' on Windows). + +Alternatively, $$ can be used to compile files individually. Each +input file is guided through (some of the) possible phases of a +compilation: + + - unlit: extract code from a "literate program" + - hscpp: run code through the C pre-processor (if -cpp flag given) + - hsc: run the Haskell compiler proper + - gcc: run the C compiler (if compiling via C) + - as: run the assembler + - ld: run the linker + +For each input file, the phase to START with is determined by the +file's suffix: + + - .lhs literate Haskell unlit + - .hs plain Haskell ghc + - .hc C from the Haskell compiler gcc + - .c C not from the Haskell compiler gcc + - .s assembly language as + - other passed directly to the linker ld + +The phase at which to STOP processing is determined by a command-line +option: + + -E stop after generating preprocessed, de-litted Haskell + (used in conjunction with -cpp) + -C stop after generating C (.hc output) + -S stop after generating assembler (.s output) + -c stop after generating object files (.o output) + +Other commonly-used options are: + + -v[n] Control verbosity (n is 0--5, normal verbosity level is 1, + -v alone is equivalent to -v3) + + -O An `optimising' package of compiler flags, for faster code + + -prof Compile for cost-centre profiling + (add -auto-all for automagic cost-centres on all + top-level functions) + + -H14m Increase compiler's heap size (might make compilation + faster, especially on large source files). + + -M Output Makefile rules recording the + dependencies of a list of Haskell files. + +Given the above, here are some TYPICAL invocations of $$: + + # compile a Haskell module to a .o file, optimising: + % $$ -c -O Foo.hs + # link three .o files into an executable called "test": + % $$ -o test Foo.o Bar.o Baz.o + # compile a Haskell module to C (a .hc file), using a bigger heap: + % $$ -C -H16m Foo.hs + # compile Haskell-produced C (.hc) to assembly language: + % $$ -S Foo.hc + +The User's Guide has more information about GHC's *many* options. An +online copy can be found here: + + http://www.haskell.org/ghc/docs/latest/html/users_guide/ + +If you *really* want to see every option, then you can pass +'--show-options' to the compiler. + +------------------------------------------------------------------------ diff --git a/driver/ghc.mk b/driver/ghc.mk new file mode 100644 index 00000000..11db9f73 --- /dev/null +++ b/driver/ghc.mk @@ -0,0 +1,22 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +$(eval $(call all-target,driver,$(INPLACE_LIB)/ghc-usage.txt $(INPLACE_LIB)/ghci-usage.txt)) + +$(INPLACE_LIB)/ghc-usage.txt: driver/ghc-usage.txt + cp $< $@ + +$(INPLACE_LIB)/ghci-usage.txt: driver/ghci-usage.txt + cp $< $@ + +INSTALL_LIBS += driver/ghc-usage.txt driver/ghci-usage.txt + diff --git a/driver/ghc/Makefile b/driver/ghc/Makefile new file mode 100644 index 00000000..f01f986f --- /dev/null +++ b/driver/ghc/Makefile @@ -0,0 +1,3 @@ +dir=driver/ghc +TOP=../.. +include $(TOP)/mk/sub-makefile.mk diff --git a/driver/ghc/ghc.c b/driver/ghc/ghc.c new file mode 100644 index 00000000..67f8f268 --- /dev/null +++ b/driver/ghc/ghc.c @@ -0,0 +1,14 @@ + +#include "cwrapper.h" +#include "getLocation.h" +#include + +int main(int argc, char** argv) { + char *binDir; + char *exePath; + + binDir = getExecutablePath(); + exePath = mkString("%s/ghc.exe", binDir); + + run(exePath, 0, NULL, argc - 1, argv + 1); +} diff --git a/driver/ghc/ghc.mk b/driver/ghc/ghc.mk new file mode 100644 index 00000000..431dbc81 --- /dev/null +++ b/driver/ghc/ghc.mk @@ -0,0 +1,24 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +ifeq "$(Windows_Host)" "YES" + +driver/ghc_dist_C_SRCS = ghc.c ../utils/cwrapper.c ../utils/getLocation.c +driver/ghc_dist_CC_OPTS += -I driver/utils +driver/ghc_dist_PROGNAME = ghc-$(ProjectVersion) +driver/ghc_dist_INSTALL = YES +driver/ghc_dist_INSTALL_INPLACE = NO + +$(eval $(call build-prog,driver/ghc,dist,0)) + +endif + diff --git a/driver/ghci-usage.txt b/driver/ghci-usage.txt new file mode 100644 index 00000000..5b85dacf --- /dev/null +++ b/driver/ghci-usage.txt @@ -0,0 +1,27 @@ +Usage: + + ghci [command-line-options-and-input-files] + +The kinds of input files that can be given on the command-line +include: + + - Haskell source files (.hs or .lhs suffix) + - Object files (.o suffix, or .obj on Windows) + - Dynamic libraries (.so suffix, or .dll on Windows) + +In addition, ghci accepts most of the command-line options that plain +GHC does. Some of the options that are commonly used are: + + -i     Search for imported modules in the directory . + + -H32m Increase GHC's default heap size to 32m + + -cpp Enable CPP processing of source files + +Full details can be found in the User's Guide, an online copy of which +can be found here: + + http://www.haskell.org/ghc/docs/latest/html/users_guide/ + +If you *really* want to see every option, then you can pass +'--show-options' to ghci. diff --git a/driver/ghci/Makefile b/driver/ghci/Makefile new file mode 100644 index 00000000..3a1b4930 --- /dev/null +++ b/driver/ghci/Makefile @@ -0,0 +1,15 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +dir = driver/ghci +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk new file mode 100644 index 00000000..ba6984c3 --- /dev/null +++ b/driver/ghci/ghc.mk @@ -0,0 +1,67 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +ifeq "$(GhcWithInterpreter)" "YES" +ifneq "$(Windows_Host)" "YES" + +install: install_driver_ghci + +.PHONY: install_driver_ghci +install_driver_ghci: WRAPPER=$(DESTDIR)$(bindir)/ghci-$(ProjectVersion) +install_driver_ghci: + $(call INSTALL_DIR,"$(DESTDIR)$(bindir)") + $(call removeFiles, "$(WRAPPER)") + $(CREATE_SCRIPT) "$(WRAPPER)" + echo '#!$(SHELL)' >> "$(WRAPPER)" + echo 'exec "$(bindir)/ghc-$(ProjectVersion)" --interactive "$$@"' >> "$(WRAPPER)" + $(EXECUTABLE_FILE) "$(WRAPPER)" + $(call removeFiles,"$(DESTDIR)$(bindir)/ghci") + $(LN_S) ghci-$(ProjectVersion) "$(DESTDIR)$(bindir)/ghci" + +else # Windows_Host... + +driver/ghci_dist_C_SRCS = ghci.c ../utils/cwrapper.c ../utils/getLocation.c +driver/ghci_dist_CC_OPTS += -I driver/utils +driver/ghci_dist_PROGNAME = ghci +driver/ghci_dist_INSTALL = YES +driver/ghci_dist_INSTALL_INPLACE = YES +driver/ghci_dist_OTHER_OBJS = driver/ghci/ghci.res + +$(eval $(call build-prog,driver/ghci,dist,1)) + +driver/ghci_dist_PROG_VER = ghci-$(ProjectVersion)$(exeext1) + +INSTALL_BINS += driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) + +driver/ghci/ghci.res : driver/ghci/ghci.rc driver/ghci/ghci.ico + "$(WINDRES)" --preprocessor="$(CPP) -xc -DRC_INVOKED" -o driver/ghci/ghci.res -i driver/ghci/ghci.rc -O coff + +driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) : driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG) + "$(CP)" $< $@ + +install : install_driver_ghcii + +.PHONY: install_driver_ghcii +install_driver_ghcii: GHCII_SCRIPT=$(DESTDIR)$(bindir)/ghcii.sh +install_driver_ghcii: GHCII_SCRIPT_VERSIONED = $(DESTDIR)$(bindir)/ghcii-$(ProjectVersion).sh +install_driver_ghcii: + $(call INSTALL_DIR,$(DESTDIR)$(bindir)) + $(call removeFiles,"$(GHCII_SCRIPT)") + echo "#!$(SHELL)" >> $(GHCII_SCRIPT) + echo 'exec "$$(dirname "$$0")"/ghc --interactive "$$@"' >> $(GHCII_SCRIPT) + $(EXECUTABLE_FILE) $(GHCII_SCRIPT) + cp $(GHCII_SCRIPT) $(GHCII_SCRIPT_VERSIONED) + $(EXECUTABLE_FILE) $(GHCII_SCRIPT_VERSIONED) + +endif +endif + diff --git a/driver/ghci/ghci.c b/driver/ghci/ghci.c new file mode 100644 index 00000000..414521f9 --- /dev/null +++ b/driver/ghci/ghci.c @@ -0,0 +1,24 @@ + +#include "cwrapper.h" +#include "getLocation.h" +#include +#include + +int main(int argc, char** argv) { + char *binDir; + char *exePath; + char *preArgv[1]; + + if (getenv("_")) { + printf("WARNING: GHCi invoked via 'ghci.exe' in *nix-like shells (cygwin-bash, in particular)\n"); + printf(" doesn't handle Ctrl-C well; use the 'ghcii.sh' shell wrapper instead\n"); + fflush(stdout); + } + + binDir = getExecutablePath(); + exePath = mkString("%s/ghc.exe", binDir); + preArgv[0] = "--interactive"; + + run(exePath, 1, preArgv, argc - 1, argv + 1); +} + diff --git a/driver/ghci/ghci.ico b/driver/ghci/ghci.ico new file mode 100644 index 0000000000000000000000000000000000000000..a31ca5260c82ed5e871b5cf61ea9792f069ffee6 GIT binary patch literal 2734 zcmeHJy^h;33}%``(;-0e2pK!x)b%>`F^Y~Iy(L?;UAMfF9>73e;l_^M&|h1HoQxYkJ!%r0ctuFKgDlc5mw7s1ea0$z66CbN zU&~WIa86gro0DxT+ZNGPXycX%W5n7pJ(1$Tj3>)`OS+Q_nQ~S&I`OSJcZF6#MmO5y zX>x6laS)Y;K?(sbhe0O2(lD4V6B;LCF#xU)gLAr*<4m3e9tl~$_mC=WC!EM}dQzjD zu@Lfp?ff{E4lb^AGo=w)cJFc|(lT1?9W{CM*?zc$^K^e_sWwi_dRQrp9OCw-UbFI| zp7R2Wz}7B`tWmBN7Zm;}gzP86Cw=ptKVyBvD)&4*fyl52=5h#VD!ifp4dIDbn+2Q+ zNQ?bA1n%a+Jn(wmm)Mr3ZE1lij#OvHXE0cwfQ=r=g*$Pm=zxB)dPu%sP+%`;8~x%m zxso0D+zDT19W>S0M0Qi*!T5c40COF$OyMJ1-l)XJoAHA=?%ANcl2zXwm7q=tl1(z53oCZwaD)6&~fHY@&-=IwWo067k9LVHRp#1{H}&I*T;vgz|8(5 zey!H+d5V?a^Ldi7TBANsK2~ewzk)wGem(yW@av_*dpSSGt$j4WGAMjp*k;VK>05uX zh-22+M|lp0NpWF`{dlFtI`Fgk_^7Y(0bGCxe+z7m*Chd%10^puZ*kK_-bimSyNLO} g0x_m + +int main(int argc, char** argv) { + char *binDir; + char *exePath; + + binDir = getExecutablePath(); + exePath = mkString("%s/haddock.exe", binDir); + + run(exePath, 0, NULL, argc - 1, argv + 1); +} diff --git a/driver/split/Makefile b/driver/split/Makefile new file mode 100644 index 00000000..93e9b127 --- /dev/null +++ b/driver/split/Makefile @@ -0,0 +1,15 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +dir = driver/split +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk diff --git a/driver/split/ghc-split.lprl b/driver/split/ghc-split.lprl new file mode 100644 index 00000000..dd12a8ae --- /dev/null +++ b/driver/split/ghc-split.lprl @@ -0,0 +1,434 @@ +%************************************************************************ +%* * +\section[Driver-obj-splitting]{Splitting into many \tr{.o} files (for libraries)} +%* * +%************************************************************************ + +\begin{code} +$TargetPlatform = $TARGETPLATFORM; + +($Pgm = $0) =~ s|.*/||; +$ifile = $ARGV[0]; +$Tmp_prefix = $ARGV[1]; +$Output = $ARGV[2]; + +&split_asm_file($ifile); + +open(OUTPUT, "> $Output") || &tidy_up_and_die(1,"$Pgm: failed to open `$Output' (to write)\n"); +print OUTPUT "$NoOfSplitFiles\n"; +close(OUTPUT); + +exit(0); + + +sub split_asm_file { + local($asm_file) = @_; + my @pieces = (); + + open(TMPI, "< $asm_file") || &tidy_up_and_die(1,"$Pgm: failed to open `$asm_file' (to read)\n"); + + &collectExports_hppa() if $TargetPlatform =~ /^hppa/; + &collectExports_mips() if $TargetPlatform =~ /^mips/; + &collectDyldStuff_darwin() if $TargetPlatform =~ /-apple-darwin/; + + $octr = 0; # output file counter + + %LocalConstant = (); # we have to subvert C compiler's commoning-up of constants... + + $s_stuff = &ReadTMPIUpToAMarker( '', $octr ); + # that first stuff is a prologue for all .s outputs + $prologue_stuff = &process_asm_block ( $s_stuff ); + # $_ already has some of the next stuff in it... + +# &tidy_up_and_die(1,"$Pgm: no split markers in .s file!\n") +# if $prologue_stuff eq $s_stuff; + + # lie about where this stuff came from + # Note the \Q: this ignores regex meta-chars in $Tmp_prefix. + $prologue_stuff =~ s/\Q"$Tmp_prefix.c"/"$ifile_root.hc"/gm; + + while ( $_ ne '' ) { # not EOF + $octr++; + + # grab and de-mangle a section of the .s file... + $s_stuff = &ReadTMPIUpToAMarker ( $_, $octr ); + $pieces[$octr] = &process_asm_block ( $s_stuff ); + } + + # Make sure that we still have some output when the input file is empty + if ($octr == 0) { + $octr = 1; + $pieces[$octr] = ''; + } + + $NoOfSplitFiles = $octr; + + if ($pieces[$NoOfSplitFiles] =~ /(\n[ \t]*\.section[ \t]+\.note\.GNU-stack,[^\n]*\n)/m) { + $note_gnu_stack = $1; + for $octr (1..($NoOfSplitFiles - 1)) { + $pieces[$octr] .= $note_gnu_stack; + } + } + + for $octr (1..$NoOfSplitFiles) { + # output to a file of its own + # open a new output file... + $ofname = "${Tmp_prefix}__${octr}.s"; + open(OUTF, "> $ofname") || die "$Pgm: can't open output file: $ofname\n"; + + print OUTF $prologue_stuff; + print OUTF $pieces[$octr]; + + close(OUTF) + || &tidy_up_and_die(1,"$Pgm:Failed writing ${Tmp_prefix}__${octr}.s\n"); + } + + close(TMPI) || &tidy_up_and_die(1,"Failed reading $asm_file\n"); +} + +sub collectExports_hppa { # Note: HP-PA only + + %LocalExport = (); # NB: global table + + while() { + if (/^\s+\.EXPORT\s+([^,]+),.*\n/m) { + local($label) = $1; + local($body) = "\t.IMPORT $label"; + if (/,DATA/m) { + $body .= ",DATA\n"; + } else { + $body .= ",CODE\n"; + } + $label =~ s/\$/\\\$/gm; + $LocalExport{$label} = $body; + } + } + + seek(TMPI, 0, 0); +} + +sub collectExports_mips { # Note: MIPS only + # (not really sure this is necessary [WDP 95/05]) + + $UNDEFINED_FUNS = ''; # NB: global table + + while() { + $UNDEFINED_FUNS .= $_ if /^\t\.globl\s+\S+ \.\S+\n/m; + # just save 'em all + } + + seek(TMPI, 0, 0); +} + +sub collectDyldStuff_darwin { + local($chunk_label,$label,$cur_section,$section,$chunk,$alignment,$cur_alignment); + + %DyldChunks = (); # NB: global table + %DyldChunksDefined = (); # NB: global table + + $cur_section = ''; + $section = ''; + $label = ''; + $chunk = ''; + $alignment = ''; + $cur_alignment = ''; + + while ( 1 ) { + $_ = ; + if ( $_ eq '' || (/^L(_.+)\$.+:/m && !(/^L(.*)\$stub_binder:/m))) { + if ( $label ne '' ) { + $DyldChunksDefined{$label} .= $section . $alignment . $chunk_label . $ chunk; + if( $section =~ s/\.data/\.non_lazy_symbol_pointer/m ) { + $chunk = "\t.indirect_symbol $label\n\t.long 0\n"; + } + $DyldChunks{$label} .= $section . $alignment . $chunk_label . $chunk; + print STDERR "### dyld chunk: $label\n$section$alignment$chunk\n###\n" if $Dump_asm_splitting_info; + } + last if ($_ eq ''); + + $chunk = ''; + $chunk_label = $_; + $label = $1; + $section = $cur_section; + $alignment = $cur_alignment; + print STDERR "label: $label\n" if $Dump_asm_splitting_info; + } elsif ( /^\s*\.(symbol_stub|picsymbol_stub|lazy_symbol_pointer|non_lazy_symbol_pointer|data|section __IMPORT,.*|section __DATA, __la_sym_ptr(2|3),lazy_symbol_pointers)/m ) { + $cur_section = $_; + printf STDERR "section: $cur_section\n" if $Dump_asm_splitting_info; + $cur_alignment = '' + } elsif ( /^\s*\.section\s+__TEXT,__symbol_stub1,symbol_stubs,pure_instructions,\d+/m ) { + $cur_section = $_; + printf STDERR "section: $cur_section\n" if $Dump_asm_splitting_info; + # always make sure we align things + $cur_alignment = '\t.align 2' + } elsif ( /^\s*\.align.*/m ) { + $cur_alignment = $_; + printf STDERR "alignment: $cur_alignment\n" if $Dump_asm_splitting_info; + } else { + $chunk .= $_; + } + } + + seek(TMPI, 0, 0); +} + +sub ReadTMPIUpToAMarker { + local($str, $count) = @_; # already read bits + + + for ( $_ = ; $_ ne '' && ! /_?__stg_split_marker/m; $_ = ) { + $str .= $_; + } + # if not EOF, then creep forward until next "real" line + # (throwing everything away). + # that first "real" line will stay in $_. + + # This loop is intended to pick up the body of the split_marker function + # Note that the assembler mangler will already have eliminated this code + # if it's been invoked (which it probably has). + + while ($_ ne '' && (/_?__stg_split_marker/m + || /^L[^C].*:$/m + || /^\.stab/m + || /\t\.proc/m + || /\t\.stabd/m + || /\t\.even/m + || /\tunlk a6/m + || /^\t!#PROLOGUE/m + || /\t\.prologue/m + || /\t\.frame/m + # || /\t\.end/ NOT! Let the split_marker regexp catch it + # || /\t\.ent/ NOT! Let the split_marker regexp catch it + || /^\s+(save|retl?|restore|nop)/m)) { + $_ = ; + } + + print STDERR "### BLOCK:$count:\n$str" if $Dump_asm_splitting_info; + + # return str + $str =~ tr/\r//d if $TargetPlatform =~ /-mingw32$/m; # in case Perl doesn't convert line endings + $str; +} +\end{code} + +We must (a)~strip the marker off the block, (b)~record any literal C +constants that are defined here, and (c)~inject copies of any C constants +that are used-but-not-defined here. + +\begin{code} +sub process_asm_block { + local($str) = @_; + + return(&process_asm_block_darwin($str)) + if $TargetPlatform =~ /-apple-darwin/m; + return(&process_asm_block_sparc($str)) if $TargetPlatform =~ /^sparc-/m; + return(&process_asm_block_iX86($str)) if $TargetPlatform =~ /^i[34]86-/m; + return(&process_asm_block_x86_64($str)) if $TargetPlatform =~ /^x86_64-/m; + return(&process_asm_block_powerpc_linux($str)) + if $TargetPlatform =~ /^powerpc-[^-]+-linux/m; + + # otherwise... + &tidy_up_and_die(1,"$Pgm: no process_asm_block for $TargetPlatform\n"); +} + +sub process_asm_block_sparc { + local($str) = @_; + + # strip the marker + if ( $OptimiseC ) { + $str =~ s/_?__stg_split_marker.*:\n//m; + } else { + $str =~ s/(\.text\n\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/m; + $str =~ s/(\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/m; + } + + # make sure the *.hc filename gets saved; not just ghc*.c (temp name) + $str =~ s/^\.stabs "(ghc\d+\.c)"/.stabs "$ifile_root.hc"/gm; # HACK HACK + + # remove/record any literal constants defined here + while ( $str =~ /(\t\.align .\n\.?(L?LC\d+):\n(\t\.asci[iz].*\n)+)/m ) { + local($label) = $2; + local($body) = $1; + + &tidy_up_and_die(1,"Local constant label $label already defined!\n") + if $LocalConstant{$label}; + + $LocalConstant{$label} = $body; + + $str =~ s/\t\.align .\n\.?LL?C\d+:\n(\t\.asci[iz].*\n)+//m; + } + + # inject definitions for any local constants now used herein + foreach $k (keys %LocalConstant) { + if ( $str =~ /\b$k\b/m ) { + $str = $LocalConstant{$k} . $str; + } + } + + print STDERR "### STRIPPED BLOCK (sparc):\n$str" if $Dump_asm_splitting_info; + + $str; +} + +sub process_asm_block_iX86 { + local($str) = @_; + + # strip the marker + + $str =~ s/(\.text\n\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/m; + $str =~ s/(\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/m; + + # it seems prudent to stick on one of these: + $str = "\.text\n\t.align 4\n" . $str; + + # remove/record any literal constants defined here + # [perl made uglier to work around the perl 5.7/5.8 bug documented at + # http://bugs6.perl.org/rt2/Ticket/Display.html?id=1760 and illustrated + # by the seg fault of perl -e '("x\n" x 5000) =~ /(.*\n)+/' + # -- ccshan 2002-09-05] + while ( ($str =~ /((?:^|\.)(LC\d+):\n(\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/m )) { + local($label) = $2; + local($body) = $1; + local($prefix, $suffix) = ($`, $'); + + &tidy_up_and_die(1,"Local constant label $label already defined!\n") + if $LocalConstant{$label}; + + while ( $suffix =~ /^((\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/ ) { + $body .= $1; + $suffix = $'; + } + $LocalConstant{$label} = $body; + $str = $prefix . $suffix; + } + + # inject definitions for any local constants now used herein + foreach $k (keys %LocalConstant) { + if ( $str =~ /\b$k\b/m ) { + $str = $LocalConstant{$k} . $str; + } + } + + print STDERR "### STRIPPED BLOCK (iX86):\n$str" if $Dump_asm_splitting_info; + + $str; +} + +sub process_asm_block_x86_64 { + local($str) = @_; + + # remove/record any literal constants defined here + # [perl made uglier to work around the perl 5.7/5.8 bug documented at + # http://bugs6.perl.org/rt2/Ticket/Display.html?id=1760 and illustrated + # by the seg fault of perl -e '("x\n" x 5000) =~ /(.*\n)+/' + # -- ccshan 2002-09-05] + while ( ($str =~ /((?:^|\.)(LC\d+):\n(\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/m )) { + local($label) = $2; + local($body) = $1; + local($prefix, $suffix) = ($`, $'); + + &tidy_up_and_die(1,"Local constant label $label already defined!\n") + if $LocalConstant{$label}; + + while ( $suffix =~ /^((\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/ ) { + $body .= $1; + $suffix = $'; + } + $LocalConstant{$label} = $body; + $str = $prefix . $suffix; + } + + # inject definitions for any local constants now used herein + foreach $k (keys %LocalConstant) { + if ( $str =~ /\b$k\b/m ) { + $str = $LocalConstant{$k} . $str; + } + } + + print STDERR "### STRIPPED BLOCK (x86_64):\n$str" if $Dump_asm_splitting_info; + + $str; +} + +# The logic for both Darwin/PowerPC and Darwin/x86 ends up being the same. + +sub process_asm_block_darwin { + local($str) = @_; + local($dyld_stuff) = ''; + + # strip the marker + $str =~ s/___stg_split_marker.*\n//m; + + $str =~ s/L_.*\$.*:\n(.|\n)*//m; + + # remove/record any literal constants defined here + while ( $str =~ s/^(\s+.const.*\n\s+\.align.*\n(LC\d+):\n(\s\.(byte|short|long|fill|space|ascii).*\n)+)//m ) { + local($label) = $2; + local($body) = $1; + + &tidy_up_and_die(1,"Local constant label $label already defined!\n") + if $LocalConstant{$label}; + + $LocalConstant{$label} = $body; + } + + # inject definitions for any local constants now used herein + foreach $k (keys %LocalConstant) { + if ( $str =~ /\b$k(\b|\[)/m ) { + $str = $LocalConstant{$k} . $str; + } + } + + foreach $k (keys %DyldChunks) { + if ( $str =~ /\bL$k\$/m ) { + if ( $str =~ /^$k:$/m ) { + $dyld_stuff .= $DyldChunksDefined{$k}; + } else { + $dyld_stuff .= $DyldChunks{$k}; + } + } + } + + $str .= "\n" . $dyld_stuff; + + print STDERR "### STRIPPED BLOCK (darwin):\n$str" if $Dump_asm_splitting_info; + + $str; +} + +sub process_asm_block_powerpc_linux { + local($str) = @_; + + # strip the marker + $str =~ s/__stg_split_marker.*\n//m; + + # remove/record any literal constants defined here + while ( $str =~ s/^(\s+.section\s+\.rodata\n\s+\.align.*\n(\.LC\d+):\n(\s\.(byte|short|long|quad|2byte|4byte|8byte|fill|space|ascii|string).*\n)+)//m ) { + local($label) = $2; + local($body) = $1; + + &tidy_up_and_die(1,"Local constant label $label already defined!\n") + if $LocalConstant{$label}; + + $LocalConstant{$label} = $body; + } + + # inject definitions for any local constants now used herein + foreach $k (keys %LocalConstant) { + if ( $str =~ /[\s,]$k\b/m ) { + $str = $LocalConstant{$k} . $str; + } + } + + print STDERR "### STRIPPED BLOCK (powerpc linux):\n$str" if $Dump_asm_splitting_info; + + $str; +} + +sub tidy_up_and_die { + local($return_val, $msg) = @_; + print STDERR $msg; + exit (($return_val == 0) ? 0 : 1); +} +\end{code} + diff --git a/driver/split/ghc.mk b/driver/split/ghc.mk new file mode 100644 index 00000000..20b244d9 --- /dev/null +++ b/driver/split/ghc.mk @@ -0,0 +1,20 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +driver/split_PERL_SRC = ghc-split.lprl +driver/split_dist_PROGNAME = ghc-split +driver/split_dist_TOPDIR = YES +driver/split_dist_INSTALL = YES +driver/split_dist_INSTALL_INPLACE = YES + +$(eval $(call build-perl,driver/split,dist)) + diff --git a/driver/utils/cwrapper.c b/driver/utils/cwrapper.c new file mode 100644 index 00000000..5105924b --- /dev/null +++ b/driver/utils/cwrapper.c @@ -0,0 +1,156 @@ + +/* gcc on mingw is hardcoded to use /mingw (which is c:/mingw) to + find various files. If this is a different version of mingw to the + one that we have in the GHC tree then things can go wrong. We + therefore need to add various -B flags to the gcc commandline, + so that it uses our in-tree mingw. Hence this wrapper. */ + +#include "cwrapper.h" +#include +#include +#include +#include +#include + +void die(const char *fmt, ...) { + va_list argp; + + va_start(argp, fmt); + vfprintf(stderr, fmt, argp); + va_end(argp); + exit(1); +} + +char *mkString(const char *fmt, ...) { + char *p; + int i, j; + va_list argp; + + va_start(argp, fmt); + i = vsnprintf(NULL, 0, fmt, argp); + va_end(argp); + + if (i < 0) { + die("vsnprintf 0 failed: errno %d: %s\n", errno, strerror(errno)); + } + + p = malloc(i + 1); + if (p == NULL) { + die("malloc failed: errno %d: %s\n", errno, strerror(errno)); + } + + va_start(argp, fmt); + j = vsnprintf(p, i + 1, fmt, argp); + va_end(argp); + if (j < 0) { + die("vsnprintf with %d failed: errno %d: %s\n", + i + 1, errno, strerror(errno)); + } + + return p; +} + +char *flattenAndQuoteArgs(char *ptr, int argc, char *argv[]) +{ + int i; + char *src; + + for (i = 0; i < argc; i++) { + *ptr++ = '"'; + src = argv[i]; + while(*src) { + if (*src == '"') { + *ptr++ = '\\'; + } + *ptr++ = *src++; + } + *ptr++ = '"'; + *ptr++ = ' '; + } + return ptr; +} + +__attribute__((noreturn)) int run (char *exePath, + int numArgs1, char **args1, + int numArgs2, char **args2) +{ + int i, cmdline_len; + char *new_cmdline, *ptr; + + STARTUPINFO si; + PROCESS_INFORMATION pi; + + ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); + ZeroMemory(&si, sizeof(STARTUPINFO)); + si.cb = sizeof(STARTUPINFO); + + /* Compute length of the flattened 'argv'. for each arg: + * + 1 for the space + * + chars * 2 (accounting for possible escaping) + * + 2 for quotes + */ + cmdline_len = 1 + strlen(exePath)*2 + 2; + for (i=0; i < numArgs1; i++) { + cmdline_len += 1 + strlen(args1[i])*2 + 2; + } + for (i=0; i < numArgs2; i++) { + cmdline_len += 1 + strlen(args2[i])*2 + 2; + } + + new_cmdline = (char*)malloc(sizeof(char) * (cmdline_len + 1)); + if (!new_cmdline) { + die("failed to start up %s; insufficient memory", exePath); + } + + ptr = flattenAndQuoteArgs(new_cmdline, 1, &exePath); + ptr = flattenAndQuoteArgs(ptr, numArgs1, args1); + ptr = flattenAndQuoteArgs(ptr, numArgs2, args2); + *--ptr = '\0'; // replace the final space with \0 + + /* Note: Used to use _spawnv(_P_WAIT, ...) here, but it suffered + from the parent intercepting console events such as Ctrl-C, + which it shouldn't. Installing an ignore-all console handler + didn't do the trick either. + + Irrespective of this issue, using CreateProcess() is preferable, + as it makes this wrapper work on both mingw and cygwin. + */ +#if 0 + fprintf(stderr, "Invoking %s\n", new_cmdline); fflush(stderr); +#endif + if (!CreateProcess(exePath, + new_cmdline, + NULL, + NULL, + TRUE, + 0, /* dwCreationFlags */ + NULL, /* lpEnvironment */ + NULL, /* lpCurrentDirectory */ + &si, /* lpStartupInfo */ + &pi) ) { + die("Unable to start %s (error code: %lu)\n", exePath, GetLastError()); + } + /* Disable handling of console events in the parent by dropping its + * connection to the console. This has the (minor) downside of not being + * able to subsequently emit any error messages to the console. + */ + FreeConsole(); + + switch (WaitForSingleObject(pi.hProcess, INFINITE) ) { + case WAIT_OBJECT_0: + { + DWORD pExitCode; + if (GetExitCodeProcess(pi.hProcess, &pExitCode) == 0) { + exit(1); + } + exit(pExitCode); + } + case WAIT_ABANDONED: + case WAIT_FAILED: + /* in the event we get any hard errors, bring the child to a halt. */ + TerminateProcess(pi.hProcess,1); + exit(1); + default: + exit(1); + } +} diff --git a/driver/utils/cwrapper.h b/driver/utils/cwrapper.h new file mode 100644 index 00000000..324470e5 --- /dev/null +++ b/driver/utils/cwrapper.h @@ -0,0 +1,5 @@ + +void die(const char *fmt, ...); +char *mkString(const char *fmt, ...); +__attribute__((noreturn)) int run(char *exePath, int numArgs1, char **args1, int numArgs2, char **args2); + diff --git a/driver/utils/dynwrapper.c b/driver/utils/dynwrapper.c new file mode 100644 index 00000000..a9250f58 --- /dev/null +++ b/driver/utils/dynwrapper.c @@ -0,0 +1,197 @@ + +/* +Need to concatenate this file with something that defines: +LPTSTR path_dirs[]; +LPTSTR progDll; +LPTSTR rtsDll; +int rtsOpts; +*/ + +#include +#include +#include +#include + +#include "Rts.h" + +void die(char *fmt, ...) { + va_list argp; + + fprintf(stderr, "error: "); + va_start(argp, fmt); + vfprintf(stderr, fmt, argp); + va_end(argp); + fprintf(stderr, "\n"); + + exit(1); +} + +LPTSTR getModuleFileName(void) { + HMODULE hExe; + LPTSTR exePath; + DWORD exePathSize; + DWORD res; + + hExe = GetModuleHandle(NULL); + if (hExe == NULL) { + die("GetModuleHandle failed"); + } + + // 300 chars ought to be enough, but there are various cases where + // it might not be (e.g. unicode paths, or \\server\foo\... paths. + // So we start off with 300 and grow if necessary. + exePathSize = 300; + exePath = malloc(exePathSize); + if (exePath == NULL) { + die("Mallocing %d for GetModuleFileName failed", exePathSize); + } + + while ((res = GetModuleFileName(hExe, exePath, exePathSize)) && + (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { + exePathSize *= 2; + exePath = realloc(exePath, exePathSize); + if (exePath == NULL) { + die("Reallocing %d for GetModuleFileName failed", exePathSize); + } + } + + if (!res) { + die("GetModuleFileName failed"); + } + return exePath; +} + +void setPath(void) { + LPTSTR *dir; + LPTSTR path; + int n; + int len = 0; + LPTSTR exePath, s; + + exePath = getModuleFileName(); + for(s = exePath; *s != '\0'; s++) { + if (*s == '\\') { + *s = '/'; + } + } + s = StrRChr(exePath, NULL, '/'); + if (s == NULL) { + die("No directory separator in executable path: %s", exePath); + } + s[0] = '\0'; + n = s - exePath; + + for (dir = path_dirs; *dir != NULL; dir++) { + len += n + lstrlen(*dir) + 1/* semicolon */; + } + len++; // NUL + + path = malloc(len); + if (path == NULL) { + die("Mallocing %d for PATH failed", len); + } + s = path; + for (dir = path_dirs; *dir != NULL; dir++) { + StrCpy(s, exePath); + s += n; + StrCpy(s, *dir); + s += lstrlen(*dir); + s[0] = ';'; + s++; + } + s[0] = '\0'; + free(exePath); + + if (! SetEnvironmentVariable(TEXT("PATH"), path)) { + printf("SetEnvironmentVariable failed (%d)\n", GetLastError()); + } + free(path); +} + +HINSTANCE loadDll(LPTSTR dll) { + HINSTANCE h; + DWORD dw; + LPVOID lpMsgBuf; + + h = LoadLibrary(dll); + + if (h == NULL) { + dw = GetLastError(); + FormatMessage( + FORMAT_MESSAGE_ALLOCATE_BUFFER | + FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + dw, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &lpMsgBuf, + 0, NULL ); + die("loadDll %s failed: %d: %s\n", dll, dw, lpMsgBuf); + } + + return h; +} + +void *GetNonNullProcAddress(HINSTANCE h, char *sym) { + void *p; + + p = GetProcAddress(h, sym); + if (p == NULL) { + die("Failed to find address for %s", sym); + } + return p; +} + +HINSTANCE GetNonNullModuleHandle(LPTSTR dll) { + HINSTANCE h; + + h = GetModuleHandle(dll); + if (h == NULL) { + die("Failed to get module handle for %s", dll); + } + return h; +} + +typedef int (*hs_main_t)(int , char **, StgClosure *, RtsConfig); + +int main(int argc, char *argv[]) { + void *p; + HINSTANCE hRtsDll, hProgDll; + LPTSTR oldPath; + + StgClosure *main_p; + RtsConfig rts_config; + hs_main_t hs_main_p; + + // MSDN says: An environment variable has a maximum size limit of + // 32,767 characters, including the null-terminating character. + oldPath = malloc(32767); + if (oldPath == NULL) { + die("Mallocing 32767 for oldPath failed"); + } + + if (!GetEnvironmentVariable(TEXT("PATH"), oldPath, 32767)) { + if (GetLastError() == ERROR_ENVVAR_NOT_FOUND) { + oldPath[0] = '\0'; + } + else { + die("Looking up PATH env var failed"); + } + } + setPath(); + hProgDll = loadDll(progDll); + if (! SetEnvironmentVariable(TEXT("PATH"), oldPath)) { + printf("SetEnvironmentVariable failed (%d)\n", GetLastError()); + } + free(oldPath); + + hRtsDll = GetNonNullModuleHandle(rtsDll); + + hs_main_p = GetNonNullProcAddress(hRtsDll, "hs_main"); + main_p = GetNonNullProcAddress(hProgDll, "ZCMain_main_closure"); + rts_config.rts_opts_enabled = rtsOpts; + rts_config.rts_opts = NULL; + + return hs_main_p(argc, argv, main_p, rts_config); +} + diff --git a/driver/utils/getLocation.c b/driver/utils/getLocation.c new file mode 100644 index 00000000..fcbe1b94 --- /dev/null +++ b/driver/utils/getLocation.c @@ -0,0 +1,40 @@ + +#include "getLocation.h" +#include +#include + +static void die(char *msg) { + fprintf(stderr, "%s", msg); + exit(1); +} + +char *getExecutable(void) { + char *p; + int i; + int r; + + i = 2048; /* plenty, PATH_MAX is 512 under Win32 */ + p = malloc(i); + if (p == NULL) { + die("Malloc failed\n"); + } + r = GetModuleFileNameA(NULL, p, i); + if (r == 0) { + die("getModuleFileName failed\n"); + } + return p; +} + +char *getExecutablePath(void) { + char *p; + char *f; + + p = getExecutable(); + f = strrchr(p, '\\'); + if (f == NULL) { + die("No '\\' in executable location\n"); + } + f[0] = '\0'; + return p; +} + diff --git a/driver/utils/getLocation.h b/driver/utils/getLocation.h new file mode 100644 index 00000000..689a4427 --- /dev/null +++ b/driver/utils/getLocation.h @@ -0,0 +1,4 @@ + +char *getExecutable(void); +char *getExecutablePath(void); + diff --git a/ghc.mk b/ghc.mk new file mode 100644 index 00000000..9aa0dc35 --- /dev/null +++ b/ghc.mk @@ -0,0 +1,1427 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009-2013 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +# ToDo List. +# +# * remove old Makefiles, add new stubs for building in subdirs +# * docs/Makefile +# * docs/docbook-cheat-sheet/Makefile +# * docs/man/Makefile +# * docs/storage-mgmt/Makefile +# * docs/vh/Makefile +# * rts/dotnet/Makefile +# * utils/Makefile +# * add Makefiles for the rest of the utils/ programs that aren't built +# by default (need to exclude them from 'make all' too) + +# Possible cleanups: +# +# * per-source-file dependencies instead of one .depend file? +# * eliminate undefined variables, and use --warn-undefined-variables? +# * put outputs from different ways in different subdirs of distdir/build, +# then we don't have to use -osuf/-hisuf. We would have to install +# them in different places too, so we'd need ghc-pkg support for packages +# of different ways. +# * make PACKAGES_STAGE1 generated by './configure' or './boot'? +# * we should use a directory of package.conf files rather than a single +# file for the inplace package database, so that we can express +# dependencies more accurately. Otherwise it's possible to get into +# a state where the package database is out of date, and the build +# system doesn't know. + +# Approximate build order. +# +# The actual build order is defined by dependencies, and the phase +# ordering used to ensure correct ordering of makefile-generation; see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture/Idiom/PhaseOrdering +# +# * With bootstrapping compiler: +# o Build utils/ghc-cabal +# o Build utils/ghc-pkg +# o Build utils/hsc2hs +# * For each package: +# o configure, generate package-data.mk and inplace-pkg-info +# o register each package into inplace/lib/package.conf +# * build libffi (if not disabled by --with-system-libffi) +# * With bootstrapping compiler: +# o Build libraries/{filepath,hpc,Cabal} +# o Build compiler (stage 1) +# * With stage 1: +# o Build libraries/* +# o Build rts +# o Build utils/* (except haddock) +# o Build compiler (stage 2) +# * With stage 2: +# o Build utils/haddock +# o Build compiler (stage 3) (optional) +# * With haddock: +# o libraries/* +# o compiler + +.PHONY: default all haddock + +# We need second expansion for the way we handle directories, so that +# | $$$$(dir $$$$@)/. +# expands to the directory of a rule that uses a % pattern. +.SECONDEXPANSION: + +default : all + + +################################################## +# Check that we have a new enough 'make' + +HAVE_EVAL := NO +$(eval HAVE_EVAL := YES) + +ifeq "$(HAVE_EVAL)" "NO" +$(error Your make does not support eval. You need GNU make >= 3.81) +endif + +ifeq "$(abspath /)" "" +$(error Your make does not support abspath. You need GNU make >= 3.81) +endif +################################################## + + +# Catch make if it runs away into an infinite loop +ifeq "$(MAKE_RESTARTS)" "" +else ifeq "$(MAKE_RESTARTS)" "1" +else +$(error Make has restarted itself $(MAKE_RESTARTS) times; is there a makefile bug? See http://ghc.haskell.org/trac/ghc/wiki/Building/Troubleshooting#Makehasrestarteditself3timesisthereamakefilebug for details) +endif + +ifneq "$(CLEANING)" "YES" +CLEANING = NO +endif + +# ----------------------------------------------------------------------------- +# Misc GNU make utils + +nothing= +space=$(nothing) $(nothing) +comma=, + +# Cancel all suffix rules. Ideally we'd like to have 'make -r' turned on +# by default, because that disables all the implicit rules, but there doesn't +# seem to be a good way to do that. This turns off all the old-style suffix +# rules, which does half the job and speeds up make quite a bit: +.SUFFIXES: + +# ----------------------------------------------------------------------------- +# Makefile debugging +# +# to see the effective value used for a Makefile variable, do +# make show VALUE=MY_VALUE +# + +show: + @echo '$(VALUE)="$($(VALUE))"' + +# echo is used by the nightly builders to query the build system for +# information. +# Using printf means that we don't get a trailing newline. We escape +# backslashes and double quotes in the string to protect them from the +# shell, and percent signs to protect them from printf. +echo: + @printf "$(subst %,%%,$(subst ",\",$(subst \,\\\\,$($(VALUE)))))" + +# ----------------------------------------------------------------------------- +# Include subsidiary build-system bits + +include mk/tree.mk + +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +include mk/config.mk +ifeq "$(ProjectVersion)" "" +$(error Please run ./configure first) +endif +endif + +include mk/ways.mk + +# (Optional) build-specific configuration +include mk/custom-settings.mk + +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" +ifeq "$(findstring dyn,$(GhcLibWays))" "" +$(error dyn is not in $$(GhcLibWays), but $$(DYNAMIC_GHC_PROGRAMS) is YES) +endif +else +ifeq "$(findstring v,$(GhcLibWays))" "" +$(error v is not in $$(GhcLibWays), and $$(DYNAMIC_GHC_PROGRAMS) is not YES) +endif +endif +ifeq "$(GhcProfiled)" "YES" +ifeq "$(findstring p,$(GhcLibWays))" "" +$(error p is not in $$(GhcLibWays), and $$(GhcProfiled) is YES) +endif +endif +endif + +ifeq "$(phase)" "" +phase = final +endif + +# ----------------------------------------------------------------------------- +# Utility definitions + +include rules/prof.mk +include rules/trace.mk +include rules/library-path.mk +include rules/add-dependency.mk +include rules/make-command.mk +include rules/pretty_commands.mk + +# ----------------------------------------------------------------------------- +# Macros for standard targets + +include rules/all-target.mk +include rules/clean-target.mk + +# ----------------------------------------------------------------------------- +# The inplace tree + +$(eval $(call clean-target,root,inplace,inplace/bin inplace/lib)) + +# ----------------------------------------------------------------------------- +# Whether to build dependencies or not + +# When we're just doing 'make clean' or 'make show', then we don't need +# to build dependencies. + +ifneq "$(findstring clean,$(MAKECMDGOALS))" "" +NO_INCLUDE_DEPS = YES +NO_INCLUDE_PKGDATA = YES +endif +ifneq "$(findstring bootstrapping-files,$(MAKECMDGOALS))" "" +NO_INCLUDE_DEPS = YES +NO_INCLUDE_PKGDATA = YES +endif +ifeq "$(findstring show,$(MAKECMDGOALS))" "show" +NO_INCLUDE_DEPS = YES +# We want package-data.mk for show +endif + +# ----------------------------------------------------------------------------- +# Ways + +include rules/way-prelims.mk + +$(foreach way,$(ALL_WAYS),\ + $(eval $(call way-prelims,$(way)))) + +ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" +GHCI_WAY = dyn +HADDOCK_WAY = dyn +else +GHCI_WAY = v +HADDOCK_WAY = v +endif + +WINDOWS_DYN_PROG_RTS := rts +ifeq "$(GhcThreaded)" "YES" +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_thr +endif +ifeq "$(GhcDebugged)" "YES" +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_debug +endif +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_dyn_LIB_NAME + +# ----------------------------------------------------------------------------- +# Compilation Flags + +include rules/distdir-opts.mk +include rules/distdir-way-opts.mk + +# ----------------------------------------------------------------------------- +# Finding source files and object files + +include rules/hs-sources.mk +include rules/c-sources.mk +include rules/includes-sources.mk +include rules/hs-objs.mk +include rules/c-objs.mk +include rules/cmm-objs.mk + +# ----------------------------------------------------------------------------- +# Suffix rules + +# Suffix rules cause "make clean" to fail on Windows (trac #3233) +# so we don't make any when cleaning. +ifneq "$(CLEANING)" "YES" + +include rules/hs-suffix-rules-srcdir.mk +include rules/hs-suffix-way-rules-srcdir.mk +include rules/hs-suffix-way-rules.mk +include rules/hi-rule.mk +include rules/c-suffix-rules.mk +include rules/cmm-suffix-rules.mk + +endif # CLEANING=YES + +# ----------------------------------------------------------------------------- +# Building package-data.mk files from .cabal files + +include rules/package-config.mk + +# ----------------------------------------------------------------------------- +# Building dependencies + +include rules/dependencies.mk +include rules/build-dependencies.mk +include rules/include-dependencies.mk + +# ----------------------------------------------------------------------------- +# Build package-data.mk files + +include rules/build-package-data.mk + +# ----------------------------------------------------------------------------- +# Build and install a program + +include rules/build-prog.mk +include rules/shell-wrapper.mk + +# ----------------------------------------------------------------------------- +# Build a perl script + +include rules/build-perl.mk + +# ----------------------------------------------------------------------------- +# Build a package + +include rules/build-package.mk +include rules/build-package-way.mk +include rules/haddock.mk +include rules/tags-package.mk +include rules/foreachLibrary.mk + +# ----------------------------------------------------------------------------- +# Registering hand-written package descriptions (used in rts) + +include rules/manual-package-config.mk + +# ----------------------------------------------------------------------------- +# Docs + +include rules/docbook.mk + +# ----------------------------------------------------------------------------- +# Making bindists + +include rules/bindist.mk + +# ----------------------------------------------------------------------------- +# Directories + +# Don't try to delete directories: +.PRECIOUS: %/. + +# Create build directories on demand. NB. the | below: this indicates +# that $(MKDIRHIER) is an order-only dependency, which means that this +# rule fires after building mkdirhier, but we won't try to recreate +# directories if mkdirhier changes. +%/. : | $(MKDIRHIER) + "$(MKDIRHIER)" $@ + +# ----------------------------------------------------------------------------- +# Lax dependencies + +ifeq "$(LAX_DEPENDENCIES)" "YES" +LAX_DEPS_FOLLOW = | +else +LAX_DEPS_FOLLOW = +endif + +# This is a bit of a hack. When LAX_DEPS_FOLLOW is | some rules end up +# looking like +# target: a | b | c +# The first | signals the start of the order-only dependencies, but make +# treats the second | as a dependency. So we need to tell make how to +# build that dependency. + +.PHONY: | +| : + @: + +# ----------------------------------------------------------------------------- +# Packages to build +# The lists of packages that we *actually* going to build in each stage: +# +# $(PACKAGES_STAGE0) +# $(PACKAGES_STAGE1) +# $(PACKAGES_STAGE2) +# +# Note that we need to add them to these variables in dependency +# order, as this is the order that they get configured in. + +ifeq "$(CLEANING)" "YES" + +define addLibraryForCleaning +# We just add all packages to both the stage 0 and stage 1 lists. +# Stage 2 gets cleaned in the same way as stage 1, so no need to +# add it there. +PACKAGES_STAGE0 += $1 +PACKAGES_STAGE1 += $1 +endef +$(eval $(call foreachLibrary,addLibraryForCleaning)) + +else + +# Packages that are built by stage0. These packages are dependencies of +# programs such as GHC and ghc-pkg, that we do not assume the stage0 +# compiler already has installed (or up-to-date enough). + +PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers +ifeq "$(Windows_Host)" "NO" +ifneq "$(HostOS_CPP)" "ios" +PACKAGES_STAGE0 += terminfo +endif +endif + +PACKAGES_STAGE1 += ghc-prim +PACKAGES_STAGE1 += $(INTEGER_LIBRARY) +PACKAGES_STAGE1 += base +PACKAGES_STAGE1 += filepath +PACKAGES_STAGE1 += array +PACKAGES_STAGE1 += deepseq +PACKAGES_STAGE1 += bytestring +PACKAGES_STAGE1 += containers + +ifeq "$(Windows_Host)" "YES" +PACKAGES_STAGE1 += Win32 +endif +PACKAGES_STAGE1 += time +ifeq "$(Windows_Host)" "NO" +PACKAGES_STAGE1 += unix +endif + +PACKAGES_STAGE1 += directory +PACKAGES_STAGE1 += process +PACKAGES_STAGE1 += hpc +PACKAGES_STAGE1 += pretty +PACKAGES_STAGE1 += template-haskell +PACKAGES_STAGE1 += binary +PACKAGES_STAGE1 += Cabal/Cabal +PACKAGES_STAGE1 += bin-package-db +PACKAGES_STAGE1 += hoopl +PACKAGES_STAGE1 += transformers + +ifeq "$(HADDOCK_DOCS)" "YES" +PACKAGES_STAGE1 += xhtml +endif + +ifeq "$(Windows_Target)" "NO" +ifneq "$(TargetOS_CPP)" "ios" +PACKAGES_STAGE1 += terminfo +endif +endif +PACKAGES_STAGE1 += haskeline + +# We normally install only the packages down to this point +REGULAR_INSTALL_PACKAGES := $(addprefix libraries/,$(PACKAGES_STAGE1)) +ifneq "$(Stage1Only)" "YES" +REGULAR_INSTALL_PACKAGES += compiler +endif +REGULAR_INSTALL_PACKAGES += $(addprefix libraries/,$(PACKAGES_STAGE2)) + +# If we have built the programs with dynamic libraries, then +# ghc will be dynamically linked against haskeline.so etc, so +# we need the dynamic libraries of everything down to here +REGULAR_INSTALL_DYNLIBS := $(addprefix libraries/,$(PACKAGES_STAGE1)) +REGULAR_INSTALL_DYNLIBS += $(addprefix libraries/,$(PACKAGES_STAGE2)) +REGULAR_INSTALL_DYNLIBS := $(filter-out $(REGULAR_INSTALL_PACKAGES),\ + $(REGULAR_INSTALL_DYNLIBS)) + +ifneq "$(CrossCompiling)" "YES" +define addExtraPackage +ifeq "$2" "-" +# Do nothing; this package is already handled above +else ifeq "$2" "dph" +## DPH-specific clause +ifeq "$$(GhcProfiled)" "YES" +# Ignore package: The DPH packages need TH, which is incompatible with +# a profiled GHC +else ifneq "$$(BUILD_DPH)" "YES" +# Ignore package: DPH was disabled +else +PACKAGES_STAGE2 += $1 +endif +## end of DPH-specific clause +else +PACKAGES_STAGE2 += $1 +endif +endef +$(eval $(call foreachLibrary,addExtraPackage)) +endif + +# If we want to just install everything, then we want all the packages +SUPERSIZE_INSTALL_PACKAGES := $(addprefix libraries/,$(PACKAGES_STAGE1)) +ifneq "$(Stage1Only)" "YES" +SUPERSIZE_INSTALL_PACKAGES += compiler +endif +SUPERSIZE_INSTALL_PACKAGES += $(addprefix libraries/,$(PACKAGES_STAGE2)) + +INSTALL_DYNLIBS := +ifeq "$(InstallExtraPackages)" "NO" +INSTALL_PACKAGES := $(REGULAR_INSTALL_PACKAGES) +ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" +INSTALL_DYNLIBS := $(REGULAR_INSTALL_DYNLIBS) +endif +else +INSTALL_PACKAGES := $(SUPERSIZE_INSTALL_PACKAGES) +endif + +endif + +# ------------------------------------------- +# Dependencies between package-data.mk files + +# We cannot run ghc-cabal to configure a package until we have +# configured and registered all of its dependencies. So the following +# hack forces all the configure steps to happen in exactly the following order: +# +# $(PACKAGES_STAGE1) ghc(stage2) $(PACKAGES_STAGE2) +# +# Ideally we should use the correct dependencies here to allow more +# parallelism, but we don't know the dependencies until we've +# generated the package-data.mk files. +define fixed_pkg_dep +libraries/$1/$2/package-data.mk : $$(fixed_pkg_prev) +fixed_pkg_prev:=libraries/$1/$2/package-data.mk +endef + +ifneq "$(BINDIST)" "YES" +fixed_pkg_prev= +$(foreach pkg,$(PACKAGES_STAGE1),$(eval $(call fixed_pkg_dep,$(pkg),dist-install))) + +# the GHC package doesn't live in libraries/, so we add its dependency manually: +compiler/stage2/package-data.mk: $(fixed_pkg_prev) +fixed_pkg_prev:=compiler/stage2/package-data.mk + +# and continue with PACKAGES_STAGE2, which depend on GHC: +$(foreach pkg,$(PACKAGES_STAGE2),$(eval $(call fixed_pkg_dep,$(pkg),dist-install))) + +ghc/stage1/package-data.mk: compiler/stage1/package-data.mk +ghc/stage2/package-data.mk: compiler/stage2/package-data.mk +# haddock depends on ghc and some libraries, but depending on GHC's +# package-data.mk is sufficient, as that in turn depends on all the +# libraries +utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk +utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk + +utils/ghctags/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/dll-split/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/hpc/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/compare_sizes/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/mkUserGuidePart/dist/package-data.mk: compiler/stage2/package-data.mk + +# add the final package.conf dependency: ghc-prim depends on RTS +libraries/ghc-prim/dist-install/package-data.mk : rts/dist/package.conf.inplace +endif + +# -------------------------------- +# Misc package-related settings + +# Run Haddock for the packages that will be installed. We need to handle +# compiler specially due to the different dist directory name. +$(foreach p,$(INSTALL_PACKAGES),$(eval $p_dist-install_DO_HADDOCK = YES)) +compiler_stage2_DO_HADDOCK = YES + +BOOT_PKG_CONSTRAINTS := \ + $(foreach d,$(PACKAGES_STAGE0),\ + $(foreach p,$(basename $(notdir $(wildcard libraries/$d/*.cabal))),\ + --constraint "$p == $(shell grep -i "^Version:" libraries/$d/$p.cabal | sed "s/[^0-9.]//g")")) + +# The actual .a and .so/.dll files: needed for dependencies. +ALL_STAGE1_LIBS = $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_v_LIB)) +ifeq "$(BuildSharedLibs)" "YES" +ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_dyn_LIB)) +endif +BOOT_LIBS = $(foreach lib,$(PACKAGES_STAGE0),$(libraries/$(lib)_dist-boot_v_LIB)) + +# ---------------------------------------- +# Special magic for the ghc-prim package + +# We want the ghc-prim package to include the GHC.Prim module when it +# is registered, but not when it is built, because GHC.Prim is not a +# real source module, it is built-in to GHC. The old build system did +# this using Setup.hs, but we can't do that here, so we have a flag to +# enable GHC.Prim in the .cabal file (so that the ghc-prim package +# remains compatible with the old build system for the time being). +# GHC.Prim module in the ghc-prim package with a flag: +# +libraries/ghc-prim_CONFIGURE_OPTS += --flag=include-ghc-prim + +# And then we strip it out again before building the package: +define libraries/ghc-prim_PACKAGE_MAGIC +libraries/ghc-prim_dist-install_MODULES := $$(filter-out GHC.Prim,$$(libraries/ghc-prim_dist-install_MODULES)) +endef + +PRIMOPS_TXT_STAGE1 = compiler/stage1/build/primops.txt + +libraries/ghc-prim/dist-install/build/GHC/PrimopWrappers.hs : $$(genprimopcode_INPLACE) $(PRIMOPS_TXT_STAGE1) | $$(dir $$@)/. + "$(genprimopcode_INPLACE)" --make-haskell-wrappers < $(PRIMOPS_TXT_STAGE1) >$@ + +# Required so that Haddock documents the primops. +libraries/ghc-prim_dist-install_EXTRA_HADDOCK_SRCS = libraries/ghc-prim/dist-install/build/autogen/GHC/Prim.hs + +# ---------------------------------------- +# Special magic for the integer package + +ifneq "$(CLEANING)" "YES" +ifeq "$(INTEGER_LIBRARY)" "integer-gmp" +libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-gmp +else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" +libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-gmp2 +else ifeq "$(INTEGER_LIBRARY)" "integer-simple" +libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-simple +else +$(error Unknown integer library: $(INTEGER_LIBRARY)) +endif +endif + +# ----------------------------------------------------------------------------- +# Include build instructions from all subdirs + +ifneq "$(BINDIST)" "YES" +BUILD_DIRS += utils/mkdirhier +endif + +ifeq "$(Windows_Host)" "YES" +BUILD_DIRS += utils/touchy +endif + +BUILD_DIRS += utils/unlit +BUILD_DIRS += utils/hp2ps + +ifneq "$(GhcUnregisterised)" "YES" +BUILD_DIRS += driver/split +endif + +ifneq "$(BINDIST)" "YES" +BUILD_DIRS += utils/genprimopcode +endif + +BUILD_DIRS += driver +BUILD_DIRS += driver/ghci +BUILD_DIRS += driver/ghc +BUILD_DIRS += driver/haddock +BUILD_DIRS += libffi +BUILD_DIRS += utils/deriveConstants +BUILD_DIRS += includes +BUILD_DIRS += rts + +ifneq "$(BINDIST)" "YES" +BUILD_DIRS += bindisttest +BUILD_DIRS += utils/genapply +endif + +ifneq "$(CLEANING)" "YES" +# These are deliberately in reverse order, so as to ensure that +# there is no need to have them in dependency order. That's important +# because it's tricky to ensure that they are in dependency order when +# cross-compiling, as some packages may only be in PACKAGES_STAGE0 +# or PACKAGES_STAGE1. +BUILD_DIRS += $(patsubst %, libraries/%, $(PACKAGES_STAGE2)) +BUILD_DIRS += $(patsubst %, libraries/%, $(PACKAGES_STAGE1)) +BUILD_DIRS += $(patsubst %, libraries/%, $(filter-out $(PACKAGES_STAGE1),$(PACKAGES_STAGE0))) +ifeq "$(BUILD_DPH)" "YES" +BUILD_DIRS += $(wildcard libraries/dph) +endif +endif + + +ifeq "$(INTEGER_LIBRARY)" "integer-gmp" +BUILD_DIRS += libraries/integer-gmp/gmp +BUILD_DIRS += libraries/integer-gmp/mkGmpDerivedConstants +else ifneq "$(findstring clean,$(MAKECMDGOALS))" "" +BUILD_DIRS += libraries/integer-gmp/gmp +BUILD_DIRS += libraries/integer-gmp/mkGmpDerivedConstants +endif + +ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" +BUILD_DIRS += libraries/integer-gmp2/gmp +else ifneq "$(findstring clean,$(MAKECMDGOALS))" "" +BUILD_DIRS += libraries/integer-gmp2/gmp +endif + +ifeq "$(HADDOCK_DOCS)" "YES" +BUILD_DIRS += utils/haddock +BUILD_DIRS += utils/haddock/doc +endif + +BUILD_DIRS += compiler +BUILD_DIRS += utils/hsc2hs +BUILD_DIRS += utils/ghc-pkg +BUILD_DIRS += utils/testremove +ifneq "$(Stage1Only)" "YES" +BUILD_DIRS += utils/ghctags +endif +BUILD_DIRS += utils/dll-split +BUILD_DIRS += utils/ghc-pwd +BUILD_DIRS += utils/ghc-cabal +BUILD_DIRS += utils/hpc +BUILD_DIRS += utils/runghc +BUILD_DIRS += ghc + +ifneq "$(BINDIST)" "YES" +ifneq "$(CrossCompiling)-$(phase)" "YES-final" +BUILD_DIRS += utils/mkUserGuidePart +endif +endif + +BUILD_DIRS += docs/users_guide +BUILD_DIRS += docs/man +BUILD_DIRS += utils/count_lines +BUILD_DIRS += utils/compare_sizes + +# ---------------------------------------------- +# Actually include all the sub-ghc.mk's + +include $(patsubst %, %/ghc.mk, $(BUILD_DIRS)) + +# A useful pseudo-target (must be after the include above, because it needs +# the value of things like $(libraries/base_dist-install_v_LIB). +.PHONY: stage1_libs +stage1_libs : $(ALL_STAGE1_LIBS) + +# ---------------------------------------------- +# Per-package compiler flags +# +# If you want to add per-package compiler flags, this +# is the place to do it. Do it like this for package +# +# libraries/_dist-boot_HC_OPTS += -Wwarn +# libraries/_dist-install_HC_OPTS += -Wwarn + +# Add $(GhcLibHcOpts) to all package builds +$(foreach pkg,$(PACKAGES_STAGE1) $(PACKAGES_STAGE2),$(eval libraries/$(pkg)_dist-install_HC_OPTS += $$(GhcLibHcOpts))) + +# Add $(GhcBootLibHcOpts) to all stage0 package builds +$(foreach pkg,$(PACKAGES_STAGE0),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBootLibHcOpts))) + +# ----------------------------------------------------------------------------- +# Bootstrapping libraries + +# We need to build a few libraries with the installed GHC, since GHC itself +# and some of the tools depend on them: + +ifneq "$(BINDIST)" "YES" + +ifneq "$(BOOTSTRAPPING_CONF)" "" +ifeq "$(wildcard $(BOOTSTRAPPING_CONF))" "" +$(shell $(GHC_PKG) init $(BOOTSTRAPPING_CONF)) +endif +endif + +$(eval $(call clean-target,root,bootstrapping_conf,$(BOOTSTRAPPING_CONF))) + +# register the boot packages in strict sequence, because running +# multiple ghc-pkgs in parallel doesn't work (registrations may get +# lost). +fixed_pkg_prev= +$(foreach pkg,$(PACKAGES_STAGE0),$(eval $(call fixed_pkg_dep,$(pkg),dist-boot))) +utils/ghc-pkg/dist/package-data.mk: $(fixed_pkg_prev) +compiler/stage1/package-data.mk: $(fixed_pkg_prev) +endif + +ifneq "$(BINDIST)" "YES" +# Make sure we have all the GHCi libs by the time we've built +# ghc-stage2. DPH includes a bit of Template Haskell which needs the +# GHCi libs, and we don't have a better way to express that dependency. +# +GHCI_LIBS = $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-install_GHCI_LIB)) \ + $(compiler_stage2_GHCI_LIB) + +ifeq "$(UseArchivesForGhci)" "NO" +ghc/stage2/build/tmp/$(ghc_stage2_PROG) : $(GHCI_LIBS) +endif + +ifeq "$(UseArchivesForGhci)" "YES" +GHCI_lib_way = v +else +GHCI_lib_way = GHCI +endif + +# Deps for TH uses in libraries +$(foreach way, $(GhcLibWays),$(eval \ +libraries/vector/dist-install/build/Data/Vector/Fusion/Stream/Monadic.$($(way)_osuf): \ + $(libraries/primitive_dist-install_$(GHCI_lib_way)_LIB) \ + )) +endif + +# ----------------------------------------------- +# Haddock-related bits + +# Build the Haddock contents and index +ifeq "$(HADDOCK_DOCS)" "YES" +libraries/dist-haddock/index.html: $(haddock_INPLACE) $(ALL_HADDOCK_FILES) + cd libraries && sh gen_contents_index --intree +ifeq "$(phase)" "final" +$(eval $(call all-target,library_doc_index,libraries/dist-haddock/index.html)) +endif +INSTALL_LIBRARY_DOCS += libraries/dist-haddock/* +endif + +# ----------------------------------------------------------------------------- +# Creating a local mingw copy on Windows + +ifeq "$(Windows_Host)" "YES" + +install : install_mingw +.PHONY: install_mingw +install_mingw : $(INPLACE_MINGW) + "$(CP)" -Rp $(INPLACE_MINGW) $(prefix) + +install : install_perl +.PHONY: install_perl +install_perl : $(INPLACE_PERL) + "$(CP)" -Rp $(INPLACE_PERL) $(prefix) + +endif # Windows_Host + +ifneq "$(BINDIST)" "YES" +$(ghc-prim-$(libraries/ghc-prim_dist-install_VERSION)_HADDOCK_FILE): \ + libraries/ghc-prim/dist-install/build/autogen/GHC/Prim.hs +endif # BINDIST + +libraries/ghc-prim/dist-install/build/autogen/GHC/Prim.hs: \ + $(PRIMOPS_TXT_STAGE1) $$(genprimopcode_INPLACE) \ + | $$(dir $$@)/. + "$(genprimopcode_INPLACE)" --make-haskell-source < $< > $@ + +.PHONY: tags +tags: tags_compiler + +.PHONY: TAGS +TAGS: TAGS_compiler + +# ----------------------------------------------------------------------------- +# Installation + +install: install_libs install_packages install_libexecs \ + install_bins install_topdirs +ifeq "$(HADDOCK_DOCS)" "YES" +install: install_docs +endif + +define installLibsTo +# $1 = libraries to install +# $2 = directory to install to + $(call INSTALL_DIR,$2) + for i in $1; do \ + case $$i in \ + *.a) \ + $(call INSTALL_DATA,$(INSTALL_OPTS),$$i,$2); \ + $(RANLIB_CMD) $2/`basename $$i` ;; \ + *.dll) \ + $(call INSTALL_PROGRAM,$(INSTALL_OPTS),$$i,$2) ; \ + $(STRIP_CMD) $2/`basename $$i` ;; \ + *.so) \ + $(call INSTALL_SHLIB,$(INSTALL_OPTS),$$i,$2) ;; \ + *.dylib) \ + $(call INSTALL_SHLIB,$(INSTALL_OPTS),$$i,$2);; \ + *) \ + $(call INSTALL_DATA,$(INSTALL_OPTS),$$i,$2); \ + esac; \ + done +endef + +install_bins: $(INSTALL_BINS) + $(call INSTALL_DIR,"$(DESTDIR)$(bindir)") + for i in $(INSTALL_BINS); do \ + $(call INSTALL_PROGRAM,$(INSTALL_BIN_OPTS),$$i,"$(DESTDIR)$(bindir)") ; \ + done + +install_libs: $(INSTALL_LIBS) + $(call installLibsTo, $(INSTALL_LIBS), "$(DESTDIR)$(ghclibdir)") + +install_libexecs: $(INSTALL_LIBEXECS) +ifeq "$(INSTALL_LIBEXECS)" "" + @: +else + $(call INSTALL_DIR,"$(DESTDIR)$(ghclibexecdir)/bin") + for i in $(INSTALL_LIBEXECS); do \ + $(call INSTALL_PROGRAM,$(INSTALL_BIN_OPTS),$$i,"$(DESTDIR)$(ghclibexecdir)/bin"); \ + done +# We rename ghc-stage2, so that the right program name is used in error +# messages etc. + "$(MV)" "$(DESTDIR)$(ghclibexecdir)/bin/ghc-stage$(INSTALL_GHC_STAGE)" "$(DESTDIR)$(ghclibexecdir)/bin/ghc" +endif + +install_topdirs: $(INSTALL_TOPDIRS) + $(call INSTALL_DIR,"$(DESTDIR)$(topdir)") + for i in $(INSTALL_TOPDIRS); do \ + $(call INSTALL_PROGRAM,$(INSTALL_BIN_OPTS),$$i,"$(DESTDIR)$(topdir)"); \ + done + +install_docs: $(INSTALL_DOCS) + $(call INSTALL_DIR,"$(DESTDIR)$(docdir)") +ifneq "$(INSTALL_DOCS)" "" + for i in $(INSTALL_DOCS); do \ + $(call INSTALL_DOC,$(INSTALL_OPTS),$$i,"$(DESTDIR)$(docdir)"); \ + done +endif + $(call INSTALL_DIR,"$(DESTDIR)$(docdir)/html") + $(call INSTALL_DOC,$(INSTALL_OPTS),docs/index.html,"$(DESTDIR)$(docdir)/html") +ifneq "$(INSTALL_LIBRARY_DOCS)" "" + $(call INSTALL_DIR,"$(DESTDIR)$(docdir)/html/libraries") + for i in $(INSTALL_LIBRARY_DOCS); do \ + $(call INSTALL_DOC,$(INSTALL_OPTS),$$i,"$(DESTDIR)$(docdir)/html/libraries/"); \ + done + $(call INSTALL_DATA,$(INSTALL_OPTS),libraries/prologue.txt,"$(DESTDIR)$(docdir)/html/libraries/") + $(call INSTALL_SCRIPT,$(INSTALL_OPTS),libraries/gen_contents_index,"$(DESTDIR)$(docdir)/html/libraries/") +endif +ifneq "$(INSTALL_HTML_DOC_DIRS)" "" + for i in $(INSTALL_HTML_DOC_DIRS); do \ + $(call INSTALL_DIR,"$(DESTDIR)$(docdir)/html/`basename $$i`"); \ + $(call INSTALL_DOC,$(INSTALL_OPTS),$$i/*,"$(DESTDIR)$(docdir)/html/`basename $$i`"); \ + done +endif + +INSTALLED_PACKAGE_CONF=$(DESTDIR)$(topdir)/package.conf.d + +# Install packages in the right order, so that ghc-pkg doesn't complain. +# Also, install ghc-pkg first. +ifeq "$(Windows_Host)" "NO" +INSTALLED_GHC_REAL=$(DESTDIR)$(ghclibexecdir)/bin/ghc +INSTALLED_GHC_PKG_REAL=$(DESTDIR)$(ghclibexecdir)/bin/ghc-pkg +else +INSTALLED_GHC_REAL=$(DESTDIR)$(bindir)/ghc.exe +INSTALLED_GHC_PKG_REAL=$(DESTDIR)$(bindir)/ghc-pkg.exe +endif + +# Set the INSTALL_DISTDIR_p for each package; compiler is special +$(foreach p,$(filter-out compiler,$(INSTALL_PACKAGES)),\ + $(eval INSTALL_DISTDIR_$p = dist-install)) +INSTALL_DISTDIR_compiler = stage2 + +# Now we can do the installation +install_packages: install_libexecs +install_packages: rts/dist/package.conf.install + $(call INSTALL_DIR,"$(DESTDIR)$(topdir)") + $(call removeTrees,"$(INSTALLED_PACKAGE_CONF)") + $(call INSTALL_DIR,"$(INSTALLED_PACKAGE_CONF)") + $(call INSTALL_DIR,"$(DESTDIR)$(topdir)/rts") + $(call installLibsTo, $(RTS_INSTALL_LIBS), "$(DESTDIR)$(topdir)/rts") + $(foreach p, $(INSTALL_DYNLIBS), \ + $(call installLibsTo, $(wildcard $p/dist-install/build/*.so $p/dist-install/build/*.dll $p/dist-install/build/*.dylib), "$(DESTDIR)$(topdir)/$($p_dist-install_PACKAGE_KEY)")) + $(foreach p, $(INSTALL_PACKAGES), \ + $(call make-command, \ + "$(ghc-cabal_INPLACE)" copy \ + $p $(INSTALL_DISTDIR_$p) \ + "$(STRIP_CMD)" \ + '$(DESTDIR)' \ + '$(prefix)' \ + '$(ghclibdir)' \ + '$(docdir)/html/libraries' \ + '$(GhcLibWays)')) + "$(INSTALLED_GHC_PKG_REAL)" --force --global-package-db "$(INSTALLED_PACKAGE_CONF)" update rts/dist/package.conf.install + $(foreach p, $(INSTALL_PACKAGES), \ + $(call make-command, \ + "$(ghc-cabal_INPLACE)" register \ + $p $(INSTALL_DISTDIR_$p) \ + "$(INSTALLED_GHC_REAL)" \ + "$(INSTALLED_GHC_PKG_REAL)" \ + "$(DESTDIR)$(topdir)" \ + '$(DESTDIR)' \ + '$(prefix)' \ + '$(ghclibdir)' \ + '$(docdir)/html/libraries' \ + $(RelocatableBuild))) +# when we install the packages above, ghc-pkg obeys umask when creating +# the package.conf files, but for everything else we specify the +# permissions. We therefore now fix the permissions of package.cache. +# This means "sudo make install" does the right thing even if it runs +# with an 077 umask. + for f in '$(INSTALLED_PACKAGE_CONF)'/*; do $(CREATE_DATA) "$$f"; done + +# ----------------------------------------------------------------------------- +# Binary distributions + +ifneq "$(CLEANING)" "YES" +# This rule seems to hold some files open on Windows which prevents +# cleaning, perhaps due to the $(wildcard). + +$(eval $(call bindist,.,\ + LICENSE \ + README \ + INSTALL \ + configure config.sub config.guess install-sh \ + settings.in \ + packages \ + Makefile \ + mk/config.mk.in \ + $(INPLACE_BIN)/mkdirhier \ + utils/ghc-cabal/dist-install/build/tmp/ghc-cabal \ + utils/ghc-pwd/dist-install/build/tmp/ghc-pwd \ + $(BINDIST_WRAPPERS) \ + $(BINDIST_PERL_SOURCES) \ + $(BINDIST_LIBS) \ + $(BINDIST_HI) \ + $(BINDIST_EXTRAS) \ + $(includes_H_FILES) \ + $(includes_DERIVEDCONSTANTS) \ + $(includes_GHCCONSTANTS) \ + $(libffi_HEADERS) \ + $(INSTALL_LIBEXECS) \ + $(INSTALL_LIBEXEC_SCRIPTS) \ + $(INSTALL_TOPDIRS) \ + $(INSTALL_BINS) \ + $(INSTALL_MANPAGES) \ + $(INSTALL_DOCS) \ + $(INSTALL_LIBRARY_DOCS) \ + $(addsuffix /*,$(INSTALL_HTML_DOC_DIRS)) \ + docs/index.html \ + compiler/stage2/doc \ + $(wildcard libraries/*/dist-install/doc/) \ + $(wildcard libraries/*/*/dist-install/doc/) \ + $(filter-out settings,$(INSTALL_LIBS)) \ + $(RTS_INSTALL_LIBS) \ + $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \ + mk/project.mk \ + mk/install.mk.in \ + bindist.mk \ + libraries/gen_contents_index \ + libraries/prologue.txt \ + $(wildcard libraries/dph/LICENSE \ + libraries/dph/ghc-packages \ + libraries/dph/ghc-packages2 \ + libraries/dph/ghc-stage2-package) \ + )) +endif +# mk/project.mk gets an absolute path, so we manually include it in +# the bindist with a relative path + +BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk + +unix-binary-dist-prep: + $(call removeTrees,bindistprep/) + "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR) + set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done + echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK) + echo "BUILD_DOCBOOK_HTML = $(BUILD_DOCBOOK_HTML)" >> $(BIN_DIST_MK) + echo "BUILD_DOCBOOK_PS = $(BUILD_DOCBOOK_PS)" >> $(BIN_DIST_MK) + echo "BUILD_DOCBOOK_PDF = $(BUILD_DOCBOOK_PDF)" >> $(BIN_DIST_MK) + echo "BUILD_MAN = $(BUILD_MAN)" >> $(BIN_DIST_MK) + echo "override ghc-cabal_INPLACE = utils/ghc-cabal/dist-install/build/tmp/ghc-cabal-bindist" >> $(BIN_DIST_MK) + echo "UseSystemLibFFI = $(UseSystemLibFFI)" >> $(BIN_DIST_MK) + cd $(BIN_DIST_PREP_DIR) && autoreconf + $(call removeFiles,$(BIN_DIST_PREP_TAR)) +# h means "follow symlinks", e.g. if aclocal.m4 is a symlink to a source +# tree then we want to include the real file, not a symlink to it + cd bindistprep && "$(TAR_CMD)" hcf - -T ../bindist-list | $(TAR_COMP_CMD) -c > ../$(BIN_DIST_PREP_TAR_COMP) + +windows-binary-dist-prep: + $(call removeTrees,bindistprep/) + $(MAKE) prefix=$(TOP)/$(BIN_DIST_PREP_DIR) install + cd bindistprep && "$(TAR_CMD)" cf - $(BIN_DIST_NAME) | $(TAR_COMP_CMD) -c > ../$(BIN_DIST_PREP_TAR_COMP) + +# tryTimes tries to run its third argument multiple times, until it +# succeeds. Don't call it directly; call try10Times instead. +# The first and second argument to tryTimes are lists of values. +# The length of the first argument is the number of times we have +# already tried. The length of the second argument is the number more +# times we will try. +tryTimes = $(if $2, \ + { echo 'Try $(words x $1): $3' ; $3 ; } || \ + $(call tryTimes,x $1,$(wordlist 2,$(words $2),$2),$3), \ + ) + +# Try to run the argument 10 times. If all 10 fail, fail. +try10Times = $(call tryTimes,,x x x x x x x x x x,$1) { echo Failed; false; } + +.PHONY: publish-binary-dist +publish-binary-dist: + $(call try10Times,$(PublishCp) $(BIN_DIST_TAR_COMP) $(PublishLocation)/dist) + +ifeq "$(mingw32_TARGET_OS)" "1" +DOCDIR_TO_PUBLISH = $(BIN_DIST_INST_DIR)/doc +else +DOCDIR_TO_PUBLISH = $(BIN_DIST_INST_DIR)/share/doc/ghc +endif + +.PHONY: publish-docs +publish-docs: + $(call try10Times,$(PublishCp) -r $(DOCDIR_TO_PUBLISH)/* $(PublishLocation)/docs) + +# ----------------------------------------------------------------------------- +# Source distributions + +# Do it like this: +# +# $ make +# $ make sdist +# + +# A source dist is built from a complete build tree, because we +# require some extra files not contained in a git checkout: the +# output from Happy and Alex, for example. +# +# The steps performed by 'make dist' are as follows: +# - create a complete link-tree of the current build tree in /tmp +# - run 'make distclean' on that tree +# - remove a bunch of other files that we know shouldn't be in the dist +# - tar up first the extralibs package, then the main source package + +# +# Directory in which we're going to build the src dist +# +SRC_DIST_ROOT = sdistprep +SRC_DIST_BASE_NAME = ghc-$(ProjectVersion) + +SRC_DIST_GHC_NAME = ghc-$(ProjectVersion)-src +SRC_DIST_GHC_ROOT = $(SRC_DIST_ROOT)/ghc +SRC_DIST_GHC_DIR = $(SRC_DIST_GHC_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_GHC_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_GHC_NAME).tar.$(TAR_COMP_EXT) + +SRC_DIST_WINDOWS_TARBALLS_NAME = ghc-$(ProjectVersion)-windows-extra-src +SRC_DIST_WINDOWS_TARBALLS_ROOT = $(SRC_DIST_ROOT)/windows-tarballs +SRC_DIST_WINDOWS_TARBALLS_DIR = $(SRC_DIST_WINDOWS_TARBALLS_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_WINDOWS_TARBALLS_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_WINDOWS_TARBALLS_NAME).tar.$(TAR_COMP_EXT) + +SRC_DIST_TESTSUITE_NAME = ghc-$(ProjectVersion)-testsuite +SRC_DIST_TESTSUITE_ROOT = $(SRC_DIST_ROOT)/testsuite-ghc +SRC_DIST_TESTSUITE_DIR = $(SRC_DIST_TESTSUITE_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_TESTSUITE_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_TESTSUITE_NAME).tar.$(TAR_COMP_EXT) + +# +# Files to include in source distributions +# +SRC_DIST_GHC_DIRS = mk rules docs distrib bindisttest libffi includes \ + utils docs rts compiler ghc driver libraries libffi-tarballs +SRC_DIST_GHC_FILES += \ + configure.ac config.guess config.sub configure \ + aclocal.m4 README.md ANNOUNCE HACKING.md INSTALL.md LICENSE Makefile \ + install-sh settings.in VERSION GIT_COMMIT_ID \ + boot packages ghc.mk MAKEHELP.md + +.PHONY: VERSION +VERSION: + @if test -f $@ && test "`cat $@`" = "$(ProjectVersion)"; \ + then echo "$@ needs no update"; \ + else echo "update $@ ($(ProjectVersion))"; echo "$(ProjectVersion)" > $@; fi + +.PHONY: GIT_COMMIT_ID +GIT_COMMIT_ID: + @if test -d .git && test "`git rev-parse HEAD`" != "$(ProjectGitCommitId)"; then \ + echo "******************************************************************************"; \ + echo "Stale ProjectGitCommitId (=$(ProjectGitCommitId)) detected!"; \ + echo "'git rev-parse HEAD' says: `git rev-parse HEAD`"; \ + echo "Please re-run './configure' before creating source-distribution"; \ + echo "******************************************************************************"; \ + exit 1; \ + fi + @if test -f $@ && test "`cat $@`" = "$(ProjectGitCommitId)"; \ + then echo "$@ needs no update"; \ + else echo "update $@ ($(ProjectGitCommitId))"; echo -n "$(ProjectGitCommitId)" > $@; fi + +sdist-ghc-prep : VERSION GIT_COMMIT_ID + +# Use: +# $(call sdist_ghc_file,compiler,stage2,cmm,Foo/Bar,CmmLex,x) +# to copy the generated file that replaces compiler/cmm/Foo/Bar/CmmLex.x, where +# "stage2" is the dist dir. +define sdist_ghc_file + "$(CP)" $1/$2/build/$4/$5.hs $(SRC_DIST_GHC_DIR)/$1/$3/$4 + mv $(SRC_DIST_GHC_DIR)/$1/$3/$4/$5.$6 $(SRC_DIST_GHC_DIR)/$1/$3/$4/$5.$6.source +endef + +# Extra packages which shouldn't be in the source distribution: see #8801 +EXTRA_PACKAGES=parallel stm random primitive vector dph + +.PHONY: sdist-ghc-prep +sdist-ghc-prep : + $(call removeTrees,$(SRC_DIST_GHC_ROOT)) + $(call removeFiles,$(SRC_DIST_GHC_TARBALL)) + mkdir -p $(SRC_DIST_ROOT) + mkdir -p $(SRC_DIST_GHC_ROOT) + mkdir -p $(SRC_DIST_GHC_DIR) + cd $(SRC_DIST_GHC_DIR) && for i in $(SRC_DIST_GHC_DIRS); do mkdir -p $$i; ( cd $$i && lndir $(TOP)/$$i ); done + cd $(SRC_DIST_GHC_DIR) && for i in $(SRC_DIST_GHC_FILES); do $(LN_S) $(TOP)/$$i .; done + cd $(SRC_DIST_GHC_DIR) && $(MAKE) distclean + $(call removeTrees,$(SRC_DIST_GHC_DIR)/libraries/tarballs/) + $(call removeTrees,$(SRC_DIST_GHC_DIR)/libraries/stamp/) + $(call removeTrees,$(SRC_DIST_GHC_DIR)/compiler/stage[123]) + $(call removeFiles,$(SRC_DIST_GHC_DIR)/mk/build.mk) + for i in $(EXTRA_PACKAGES); do $(RM) $(RM_OPTS_REC) $(SRC_DIST_GHC_DIR)/libraries/$$i/; done + $(call sdist_ghc_file,compiler,stage2,cmm,,CmmLex,x) + $(call sdist_ghc_file,compiler,stage2,cmm,,CmmParse,y) + $(call sdist_ghc_file,compiler,stage2,parser,,Lexer,x) + $(call sdist_ghc_file,compiler,stage2,parser,,Parser,y) + $(call sdist_ghc_file,utils/hpc,dist-install,,,HpcParser,y) + $(call sdist_ghc_file,utils/genprimopcode,dist,,,Lexer,x) + $(call sdist_ghc_file,utils/genprimopcode,dist,,,Parser,y) + cd $(SRC_DIST_GHC_DIR) && "$(FIND)" $(SRC_DIST_GHC_DIRS) \( -name .git -o -name "autom4te*" -o -name "*~" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC) + +.PHONY: sdist-windows-tarballs-prep +sdist-windows-tarballs-prep : + $(call removeTrees,$(SRC_DIST_WINDOWS_TARBALLS_ROOT)) + $(call removeFiles,$(SRC_DIST_WINDOWS_TARBALLS_TARBALL)) + mkdir -p $(SRC_DIST_ROOT) + mkdir -p $(SRC_DIST_WINDOWS_TARBALLS_ROOT) + mkdir -p $(SRC_DIST_WINDOWS_TARBALLS_DIR) + mkdir -p $(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs + cd $(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs && lndir $(TOP)/ghc-tarballs + $(call removeTrees,$(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs/.git) + +.PHONY: sdist-testsuite-prep +sdist-testsuite-prep : + $(call removeTrees,$(SRC_DIST_TESTSUITE_ROOT)) + $(call removeFiles,$(SRC_DIST_TESTSUITE_TARBALL)) + mkdir -p $(SRC_DIST_ROOT) + mkdir -p $(SRC_DIST_TESTSUITE_ROOT) + mkdir -p $(SRC_DIST_TESTSUITE_DIR) + mkdir -p $(SRC_DIST_TESTSUITE_DIR)/testsuite + cd $(SRC_DIST_TESTSUITE_DIR)/testsuite && lndir $(TOP)/testsuite + cd $(SRC_DIST_TESTSUITE_DIR)/testsuite && $(MAKE) distclean + +.PHONY: sdist-ghc +sdist-ghc: sdist-ghc-prep + cd $(SRC_DIST_GHC_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | $(TAR_COMP_CMD) -c > $(TOP)/$(SRC_DIST_GHC_TARBALL) + +.PHONY: sdist-windows-tarballs +sdist-windows-tarballs: sdist-windows-tarballs-prep + cd $(SRC_DIST_WINDOWS_TARBALLS_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> windows_extra_src_ghc_log | $(TAR_COMP_CMD) -c > $(TOP)/$(SRC_DIST_WINDOWS_TARBALLS_TARBALL) + +.PHONY: sdist-testsuite +sdist-testsuite: sdist-testsuite-prep + cd $(SRC_DIST_TESTSUITE_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> testsuite_log | $(TAR_COMP_CMD) -c > $(TOP)/$(SRC_DIST_TESTSUITE_TARBALL) + + +.PHONY: sdist +sdist : sdist-ghc sdist-windows-tarballs sdist-testsuite + +sdist-manifest : $(SRC_DIST_GHC_TARBALL) + tar tjf $(SRC_DIST_GHC_TARBALL) | sed "s|^ghc-$(ProjectVersion)/||" | sort >sdist-manifest + +# Upload the distribution(s) +# Retrying is to work around buggy firewalls that corrupt large file transfers +# over SSH. +ifneq "$(PublishLocation)" "" +publish-sdist : + $(call try10Times,$(PublishCp) $(SRC_DIST_GHC_TARBALL) $(PublishLocation)/dist) + $(call try10Times,$(PublishCp) $(SRC_DIST_TESTSUITE_TARBALL) $(PublishLocation)/dist) +endif + +# ----------------------------------------------------------------------------- +# sdisting libraries + +# Use manually, with e.g.: +# make sdist_directory + +sdist_%: + inplace/bin/ghc-cabal sdist libraries/$* dist-install + +# ----------------------------------------------------------------------------- +# Cleaning + +.PHONY: clean + +CLEAN_FILES += libraries/integer-gmp/cbits/GmpDerivedConstants.h +CLEAN_FILES += libraries/integer-gmp/include/HsIntegerGmp.h +CLEAN_FILES += libraries/integer-gmp2/include/HsIntegerGmp.h +CLEAN_FILES += libraries/base/include/EventConfig.h +CLEAN_FILES += mk/config.mk.old +CLEAN_FILES += mk/project.mk.old +CLEAN_FILES += compiler/ghc.cabal.old + +# These are no longer generated, but we still clean them for a while +# as they may still be in old GHC trees: +CLEAN_FILES += includes/GHCConstants.h +CLEAN_FILES += includes/DerivedConstants.h +CLEAN_FILES += includes/ghcautoconf.h +CLEAN_FILES += includes/ghcplatform.h +CLEAN_FILES += includes/ghcversion.h +CLEAN_FILES += utils/ghc-pkg/Version.hs +CLEAN_FILES += compiler/prelude/primops.txt +CLEAN_FILES += $(wildcard compiler/primop*incl) + +clean : clean_files clean_libraries + +.PHONY: clean_files +clean_files : + $(call removeFiles,$(CLEAN_FILES)) +# this is here since CLEAN_FILES can't handle folders + $(call removeTrees,includes/dist-derivedconstants) + $(call removeTrees,inplace/bin) + $(call removeTrees,inplace/lib) + $(call removeTrees,libraries/bootstrapping.conf) + +.PHONY: clean_libraries +clean_libraries: $(patsubst %,clean_libraries/%_dist-install,$(PACKAGES_STAGE1) $(PACKAGES_STAGE2)) +clean_libraries: $(patsubst %,clean_libraries/%_dist-boot,$(PACKAGES_STAGE0)) + +clean_libraries: + $(call removeTrees,$(patsubst %, libraries/%/dist, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,$(wildcard $(patsubst %.in, %, $(wildcard $(patsubst %, libraries/%/*.buildinfo.in, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))))) + $(call removeFiles,$(patsubst %, libraries/%/config.log, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,$(patsubst %, libraries/%/config.status, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,$(wildcard $(patsubst %, libraries/%/include/Hs*Config.h, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))) + +# We have to define a clean target for each library manually, because the +# libraries/*/ghc.mk files are not included when we're cleaning. +ifeq "$(CLEANING)" "YES" +$(foreach lib,$(PACKAGES_STAGE0),\ + $(eval $(call clean-target,libraries/$(lib),dist-boot,libraries/$(lib)/dist-boot))) +$(foreach lib,$(PACKAGES_STAGE1) $(PACKAGES_STAGE2),\ + $(eval $(call clean-target,libraries/$(lib),dist-install,libraries/$(lib)/dist-install))) +endif + +clean : clean_haddock_index +.PHONY: clean_haddock_index +clean_haddock_index: + $(call removeTrees,libraries/dist-haddock) + +clean : clean_bindistprep +.PHONY: clean_bindistprep +clean_bindistprep: + $(call removeTrees,bindistprep/) + +distclean : clean +# Clean the files that ./validate creates. + $(call removeFiles,mk/are-validating.mk) + +# Clean the files that we ask ./configure to create. + $(call removeFiles,mk/config.mk) + $(call removeFiles,mk/install.mk) + $(call removeFiles,mk/project.mk) + $(call removeFiles,compiler/ghc.cabal) + $(call removeFiles,ghc/ghc-bin.cabal) + $(call removeFiles,utils/runghc/runghc.cabal) + $(call removeFiles,settings) + $(call removeFiles,docs/users_guide/ug-book.xml) + $(call removeFiles,docs/users_guide/ug-ent.xml) + $(call removeFiles,docs/index.html) + $(call removeFiles,libraries/prologue.txt) + $(call removeFiles,distrib/configure.ac) + $(call removeFiles,ch01.html ch02.html index.html) + +# ./configure also makes these. + $(call removeFiles,mk/config.h) + +# Internal files generated by ./configure for itself. + $(call removeFiles,config.cache config.status config.log) + +# ./configure build ghc-pwd in utils/ghc-pwd/dist-boot, so clean it up. + $(call removeTrees,utils/ghc-pwd/dist-boot) + +# The root Makefile makes .old versions of some files that configure +# generates, so we clean those too. + $(call removeFiles,mk/config.mk.old) + $(call removeFiles,mk/project.mk.old) + $(call removeFiles,compiler/ghc.cabal.old) + +# Clean the *Config.h files generated by library configure scripts + $(call removeFiles,libraries/base/include/HsBaseConfig.h) + $(call removeFiles,libraries/base/include/EventConfig.h) + $(call removeFiles,libraries/directory/include/HsDirectoryConfig.h) + $(call removeFiles,libraries/process/include/HsProcessConfig.h) + $(call removeFiles,libraries/unix/include/HsUnixConfig.h) + $(call removeFiles,libraries/time/include/HsTimeConfig.h) + +# The library configure scripts also like creating autom4te.cache +# directories, so clean them all up. + $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + +# We make these when making or testing bindists + $(call removeFiles,bindist-list) + $(call removeTrees,bindisttest/a) + +# Not sure why this is being cleaned here. + $(call removeTrees,includes/dist-derivedconstants) + +# Finally, clean the inplace tree. + $(call removeTrees,inplace) + +maintainer-clean : distclean + $(call removeFiles,configure mk/config.h.in) + $(call removeTrees,autom4te.cache $(wildcard libraries/*/autom4te.cache)) + $(call removeFiles,$(patsubst %, libraries/%/GNUmakefile, \ + $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,$(patsubst %, libraries/%/ghc.mk, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,$(patsubst %, libraries/%/configure, \ + $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + $(call removeFiles,libraries/base/include/HsBaseConfig.h.in) + $(call removeFiles,libraries/directory/include/HsDirectoryConfig.h.in) + $(call removeFiles,libraries/process/include/HsProcessConfig.h.in) + $(call removeFiles,libraries/unix/include/HsUnixConfig.h.in) + $(call removeFiles,libraries/time/include/HsTimeConfig.h.in) + +.PHONY: all_libraries + +.PHONY: bootstrapping-files +bootstrapping-files: $(includes_H_CONFIG) +bootstrapping-files: $(includes_DERIVEDCONSTANTS) +bootstrapping-files: $(includes_GHCCONSTANTS) +bootstrapping-files: $(libffi_HEADERS) + +.DELETE_ON_ERROR: + +# ----------------------------------------------------------------------------- + +ifeq "$(HADDOCK_DOCS)" "YES" +BINDIST_HADDOCK_FLAG = --with-haddock="$(BINDIST_PREFIX)/bin/haddock" +endif +ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" +BINDIST_LIBRARY_FLAGS = --enable-shared --disable-library-vanilla +else +BINDIST_LIBRARY_FLAGS = --enable-library-vanilla --disable-shared +endif +BINDIST_LIBRARY_FLAGS += --disable-library-prof + +.PHONY: validate_build_xhtml +validate_build_xhtml: + cd libraries/xhtml && "$(BINDIST_PREFIX)/bin/ghc" --make Setup + cd libraries/xhtml && ./Setup configure --with-ghc="$(BINDIST_PREFIX)/bin/ghc" $(BINDIST_HADDOCK_FLAG) $(BINDIST_LIBRARY_FLAGS) --global --builddir=dist-bindist --prefix="$(BINDIST_PREFIX)" + cd libraries/xhtml && ./Setup build --builddir=dist-bindist +ifeq "$(HADDOCK_DOCS)" "YES" + cd libraries/xhtml && ./Setup haddock --ghc-options=-optP-P --builddir=dist-bindist +endif + cd libraries/xhtml && ./Setup install --builddir=dist-bindist + cd libraries/xhtml && ./Setup clean --builddir=dist-bindist + cd libraries/xhtml && rm -f Setup Setup.exe Setup.hi Setup.o + +# ----------------------------------------------------------------------------- +# Numbered phase targets + +# In phase 1, we'll be building dependency files for most things +# built by the bootstrapping compiler while make is 'include'ing +# makefiles. But in order to build dependency files, we'll need to +# build any automatically generated .hs files, which means that +# we'll need to be able to build any tools that generate .hs files +# etc. But in order to do that, we need to already know the +# dependencies for those tools, so we build their dependency files +# here. +.PHONY: phase_0_builds +# hsc2hs is needed, e.g. to make the .hs files for hpc. +phase_0_builds: $(utils/hsc2hs_dist_depfile_haskell) +phase_0_builds: $(utils/hsc2hs_dist_depfile_c_asm) +# genprimopcode is needed to make the .hs-incl files that are in the +# ghc package. +phase_0_builds: $(utils/genprimopcode_dist_depfile_haskell) +phase_0_builds: $(utils/genprimopcode_dist_depfile_c_asm) +# deriveConstants is used to create header files included in the +# ghc package. +phase_0_builds: $(utils/deriveConstants_dist_depfile_haskell) +phase_0_builds: $(utils/deriveConstants_dist_depfile_c_asm) + +.PHONY: phase_1_builds +phase_1_builds: $(PACKAGE_DATA_MKS) + diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs new file mode 100644 index 00000000..f57fbba1 --- /dev/null +++ b/ghc/GhciMonad.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- Monadery code used in InteractiveUI +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GhciMonad ( + GHCi(..), startGHCi, + GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState, + GHCiOption(..), isOptionSet, setOption, unsetOption, + Command, + BreakLocation(..), + TickArray, + getDynFlags, + + runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, + + printForUser, printForUserPartWay, prettyLocations, + initInterpBuffering, turnOffBuffering, flushInterpBuffers, + ) where + +#include "HsVersions.h" + +import qualified GHC +import GhcMonad hiding (liftIO) +import Outputable hiding (printForUser, printForUserPartWay) +import qualified Outputable +import Util +import DynFlags +import FastString +import HscTypes +import SrcLoc +import Module +import ObjLink +import Linker + +import Exception +import Numeric +import Data.Array +import Data.Int ( Int64 ) +import Data.IORef +import System.CPUTime +import System.Environment +import System.IO +import Control.Monad +import GHC.Exts + +import System.Console.Haskeline (CompletionFunc, InputT) +import qualified System.Console.Haskeline as Haskeline +import Control.Monad.Trans.Class +import Control.Monad.IO.Class + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif + +----------------------------------------------------------------------------- +-- GHCi monad + +-- the Bool means: True = we should exit GHCi (:quit) +type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) + +data GHCiState = GHCiState + { + progname :: String, + args :: [String], + prompt :: String, + prompt2 :: String, + editor :: String, + stop :: String, + options :: [GHCiOption], + line_number :: !Int, -- input line + break_ctr :: !Int, + breaks :: ![(Int, BreakLocation)], + tickarrays :: ModuleEnv TickArray, + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. + -- available ghci commands + ghci_commands :: [Command], + -- ":" at the GHCi prompt repeats the last command, so we + -- remember is here: + last_command :: Maybe Command, + cmdqueue :: [String], + + remembered_ctx :: [InteractiveImport], + -- the imports that the user has asked for, via import + -- declarations and :module commands. This list is + -- persistent over :reloads (but any imports for modules + -- that are not loaded are temporarily ignored). After a + -- :load, all the home-package imports are stripped from + -- this list. + + -- See bugs #2049, #1873, #1360 + + transient_ctx :: [InteractiveImport], + -- An import added automatically after a :load, usually of + -- the most recently compiled module. May be empty if + -- there are no modules loaded. This list is replaced by + -- :load, :reload, and :add. In between it may be modified + -- by :module. + + ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc) + + -- help text to display to a user + short_help :: String, + long_help :: String, + lastErrorLocations :: IORef [(FastString, Int)] + } + +type TickArray = Array Int [(BreakIndex,SrcSpan)] + +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation + | Multiline -- use multiline commands + deriving Eq + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + , onBreakCmd :: String + } + +instance Eq BreakLocation where + loc1 == loc2 = breakModule loc1 == breakModule loc2 && + breakTick loc1 == breakTick loc2 + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +instance Outputable BreakLocation where + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> + if null (onBreakCmd loc) + then Outputable.empty + else doubleQuotes (text (onBreakCmd loc)) + +recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) +recordBreak brkLoc = do + st <- getGHCiState + let oldActiveBreaks = breaks st + -- don't store the same break point twice + case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = break_ctr st + newCounter = oldCounter + 1 + setGHCiState $ st { break_ctr = newCounter, + breaks = (oldCounter, brkLoc) : oldActiveBreaks + } + return (False, oldCounter) + +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } + +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref + +instance Functor GHCi where + fmap = liftM + +instance Applicative GHCi where + pure = return + (<*>) = ap + +instance Monad GHCi where + (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s + return a = GHCi $ \_ -> return a + +getGHCiState :: GHCi GHCiState +getGHCiState = GHCi $ \r -> liftIO $ readIORef r +setGHCiState :: GHCiState -> GHCi () +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s +modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi () +modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f + +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadIO GHCi where + liftIO = liftGhc . liftIO + +instance HasDynFlags GHCi where + getDynFlags = getSessionDynFlags + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance HasDynFlags (InputT GHCi) where + getDynFlags = lift getDynFlags + +instance GhcMonad (InputT GHCi) where + setSession = lift . setSession + getSession = lift getSession + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gmask f = + GHCi $ \s -> gmask $ \io_restore -> + let + g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') + in + unGHCi (f g_restore) s + +instance Haskeline.MonadException Ghc where + controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s) + in fmap (flip unGhc s) $ f run' + +instance Haskeline.MonadException GHCi where + controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s) + in fmap (flip unGHCi s) $ f run' + +instance ExceptionMonad (InputT GHCi) where + gcatch = Haskeline.catch + gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) + +isOptionSet :: GHCiOption -> GHCi Bool +isOptionSet opt + = do st <- getGHCiState + return (opt `elem` options st) + +setOption :: GHCiOption -> GHCi () +setOption opt + = do st <- getGHCiState + setGHCiState (st{ options = opt : filter (/= opt) (options st) }) + +unsetOption :: GHCiOption -> GHCi () +unsetOption opt + = do st <- getGHCiState + setGHCiState (st{ options = filter (/= opt) (options st) }) + +printForUser :: GhcMonad m => SDoc -> m () +printForUser doc = do + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + liftIO $ Outputable.printForUser dflags stdout unqual doc + +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc + +-- | Run a single Haskell expression +runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printException e; + return Nothing) $ do + r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step + return (Just r) + +runDecls :: String -> GHCi [GHC.Name] +runDecls decls = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do + GHC.runDeclsWithLocation (progname st) (line_number st) decls + +resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult +resume canLogSpan step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.resume canLogSpan step + +-- -------------------------------------------------------------------------- +-- timing & statistics + +timeIt :: InputT GHCi a -> InputT GHCi a +timeIt action + = do b <- lift $ isOptionSet ShowTiming + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + dflags <- getDynFlags + liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a + +foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 + -- defined in ghc/rts/Stats.c + +printTimes :: DynFlags -> Integer -> Integer -> IO () +printTimes dflags allocs psecs + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc dflags ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (separateThousands allocs) <+> text "bytes"))) + where + separateThousands n = reverse . sep . reverse . show $ n + where sep n' + | length n' <= 3 = n' + | otherwise = take 3 n' ++ "," ++ sep (drop 3 n') + +----------------------------------------------------------------------------- +-- reverting CAFs + +revertCAFs :: GHCi () +revertCAFs = do + liftIO rts_revertCAFs + s <- getGHCiState + when (not (ghc_e s)) $ liftIO turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. + +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) +GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) +GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) + +-- After various attempts, I believe this is the least bad way to do +-- what we want. We know look up the address of the static stdin, +-- stdout, and stderr closures in the loaded base package, and each +-- time we need to refer to them we cast the pointer to a Handle. +-- This avoids any problems with the CAF having been reverted, because +-- we'll always get the current value. +-- +-- The previous attempt that didn't work was to compile an expression +-- like "hSetBuffering stdout NoBuffering" into an expression of type +-- IO () and run this expression each time we needed it, but the +-- problem is that evaluating the expression might cache the contents +-- of the Handle rather than referring to it from its static address +-- each time. There's no safe workaround for this. + +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do + initDynLinker dflags + + -- ToDo: we should really look up these names properly, but + -- it's a fiddle and not all the bits are exposed via the GHC + -- interface. + mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure" + mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure" + mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure" + + let f ref (Just ptr) = writeIORef ref ptr + f _ Nothing = panic "interactiveUI:setBuffering2" + zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = liftIO $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush + +turnOffBuffering :: IO () +turnOffBuffering + = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] + mapM_ (\h -> hSetBuffering h NoBuffering) hdls + +getHandle :: IORef (Ptr ()) -> IO Handle +getHandle ref = do + (Ptr addr) <- readIORef ref + case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) + diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs new file mode 100644 index 00000000..b250637b --- /dev/null +++ b/ghc/GhciTags.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- +-- GHCi's :ctags and :etags commands +-- +-- (c) The GHC Team 2005-2007 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module GhciTags ( + createCTagsWithLineNumbersCmd, + createCTagsWithRegExesCmd, + createETagsFileCmd +) where + +import Exception +import GHC +import GhciMonad +import Outputable + +-- ToDo: figure out whether we need these, and put something appropriate +-- into the GHC API instead +import Name (nameOccName) +import OccName (pprOccName) +import ConLike +import MonadUtils + +import Data.Function +import Data.Maybe +import Data.Ord +import Panic +import Data.List +import Control.Monad +import System.IO +import System.IO.Error + +----------------------------------------------------------------------------- +-- create tags file for currently loaded modules. + +createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd, + createETagsFileCmd :: String -> GHCi () + +createCTagsWithLineNumbersCmd "" = + ghciCreateTagsFile CTagsWithLineNumbers "tags" +createCTagsWithLineNumbersCmd file = + ghciCreateTagsFile CTagsWithLineNumbers file + +createCTagsWithRegExesCmd "" = + ghciCreateTagsFile CTagsWithRegExes "tags" +createCTagsWithRegExesCmd file = + ghciCreateTagsFile CTagsWithRegExes file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file + +data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes + +ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () +ghciCreateTagsFile kind file = do + createTagsFile kind file + +-- ToDo: +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. +-- +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). +-- +createTagsFile :: TagsKind -> FilePath -> GHCi () +createTagsFile tagskind tagsFile = do + graph <- GHC.getModuleGraph + mtags <- mapM listModuleTags (map GHC.ms_mod graph) + either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags + case either_res of + Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e + Right _ -> return () + + +listModuleTags :: GHC.Module -> GHCi [TagInfo] +listModuleTags m = do + is_interpreted <- GHC.moduleIsInterpreted m + -- should we just skip these? + when (not is_interpreted) $ + let mName = GHC.moduleNameString (GHC.moduleName m) in + throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) + mbModInfo <- GHC.getModuleInfo m + case mbModInfo of + Nothing -> return [] + Just mInfo -> do + dflags <- getDynFlags + mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo + let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual + let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo + let localNames = filter ((m==) . nameModule) names + mbTyThings <- mapM GHC.lookupName localNames + return $! [ tagInfo dflags unqual exported kind name realLoc + | tyThing <- catMaybes mbTyThings + , let name = getName tyThing + , let exported = GHC.modInfoIsExportedName mInfo name + , let kind = tyThing2TagKind tyThing + , let loc = srcSpanStart (nameSrcSpan name) + , RealSrcLoc realLoc <- [loc] + ] + + where + tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (AConLike RealDataCon{}) = 'd' + tyThing2TagKind (AConLike PatSynCon{}) = 'p' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (ACoAxiom _) = 'x' + + +data TagInfo = TagInfo + { tagExported :: Bool -- is tag exported + , tagKind :: Char -- tag kind + , tagName :: String -- tag name + , tagFile :: String -- file name + , tagLine :: Int -- line number + , tagCol :: Int -- column number + , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset + } + + +-- get tag info, for later translation into Vim or Emacs style +tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc + -> TagInfo +tagInfo dflags unqual exported kind name loc + = TagInfo exported kind + (showSDocForUser dflags unqual $ pprOccName (nameOccName name)) + (showSDocForUser dflags unqual $ ftext (srcLocFile loc)) + (srcLocLine loc) (srcLocCol loc) Nothing + + +collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) +-- ctags style with the Ex exresion being just the line number, Vim et al +collateAndWriteTags CTagsWithLineNumbers file tagInfos = do + let tags = unlines $ sort $ map showCTag tagInfos + tryIO (writeFile file tags) + +-- ctags style with the Ex exresion being a regex searching the line, Vim et al +collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al + tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos + let tags = unlines $ sort $ map showCTag $concat tagInfoGroups + tryIO (writeFile file tags) + +collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs + tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos + let tagGroups = map processGroup tagInfoGroups + tryIO (writeFile file $ concat tagGroups) + + where + processGroup [] = throwGhcException (CmdLineError "empty tag file group??") + processGroup group@(tagInfo:_) = + let tags = unlines $ map showETag group in + "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags + + +makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]] +makeTagGroupsWithSrcInfo tagInfos = do + let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos + mapM addTagSrcInfo groups + + where + addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??") + addTagSrcInfo group@(tagInfo:_) = do + file <- readFile $tagFile tagInfo + let sortedGroup = sortBy (comparing tagLine) group + return $ perFile sortedGroup 1 0 $ lines file + + perFile allTags@(tag:tags) cnt pos allLs@(l:ls) + | tagLine tag > cnt = + perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls + | tagLine tag == cnt = + tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs + perFile _ _ _ _ = [] + + +-- ctags format, for Vim et al +showCTag :: TagInfo -> String +showCTag ti = + tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++ + tagKind ti : ( if tagExported ti then "" else "\tfile:" ) + + where + tagCmd = + case tagSrcInfo ti of + Nothing -> show $tagLine ti + Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/" + + where + escapeSlashes '/' r = '\\' : '/' : r + escapeSlashes '\\' r = '\\' : '\\' : r + escapeSlashes c r = c : r + + +-- etags format, for Emacs/XEmacs +showETag :: TagInfo -> String +showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo, + tagSrcInfo = Just (srcLine,charPos) } + = take (colNo - 1) srcLine ++ tag + ++ "\x7f" ++ tag + ++ "\x01" ++ show lineNo + ++ "," ++ show charPos +showETag _ = throwGhcException (CmdLineError "missing source file info in showETag") + diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs new file mode 100644 index 00000000..4b50b01d --- /dev/null +++ b/ghc/InteractiveUI.hs @@ -0,0 +1,3232 @@ +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections #-} +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module InteractiveUI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg + ) where + +#include "HsVersions.h" + +-- GHCi +import qualified GhciMonad ( args, runStmt ) +import GhciMonad hiding ( args, runStmt ) +import GhciTags +import Debugger + +-- The GHC interface +import DynFlags +import ErrUtils +import GhcMonad ( modifySession ) +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), + TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + handleSourceError ) +import HsImpExp +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, + setInteractivePrintName ) +import Module +import Name +import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) +import PprTyThing +import RdrName ( getGRE_NameQualifier_maybes ) +import SrcLoc +import qualified Lexer + +import StringBuffer +import Outputable hiding ( printForUser, printForUserPartWay, bold ) + +-- Other random utilities +import BasicTypes hiding ( isTopLevel ) +import Config +import Digraph +import Encoding +import FastString +import Linker +import Maybes ( orElse, expectJust ) +import NameSet +import Panic hiding ( showException ) +import Util + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.DeepSeq (deepseq) +import Control.Monad as Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, + partition, sort, sortBy ) +import Data.Maybe + +import Exception hiding (catch) + +import Foreign.C +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) + +#ifndef mingw32_HOST_OS +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.Exts ( unsafeCoerce# ) +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + shortHelpText :: String, + fullHelpText :: String, + defPrompt :: String, + defPrompt2 :: String + } + +defaultGhciSettings :: GhciSettings +defaultGhciSettings = + GhciSettings { + availableCommands = ghciCommands, + shortHelpText = defShortHelpText, + fullHelpText = defFullHelpText, + defPrompt = default_prompt, + defPrompt2 = default_prompt2 + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" + +cmdName :: Command -> String +cmdName (n,_,_) = n + +GLOBAL_VAR(macros_ref, [], [Command]) + +ghciCommands :: [Command] +ghciCommands = [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("complete", keepGoing completeCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), + ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("edit", keepGoing' editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing moduleCmd, completeSetModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions) + ] + + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingPaths a str + = do case toArgs str of + Left err -> liftIO $ hPutStrLn stderr err + Right args -> a args + return False + +defShortHelpText :: String +defShortHelpText = "use :? for help.\n" + +defFullHelpText :: String +defFullHelpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :complete [] list completions for partial input string\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ + " :def define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ + " :help, :? display this list of commands\n" ++ + " :info[!] [ ...] display information about the given names\n" ++ + " (!: do not filter instances)\n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :undef undefine user-defined command :\n" ++ + " :! run the shell command \n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back go back in the history (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the specified breakpoint\n" ++ + " :delete * delete all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward go forward in the history (after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \n"++ + " :steplocal single-step within the current top-level binding\n"++ + " :stepmodule single-step restricted to the current module\n"++ + " :trace trace after stopping at a breakpoint\n"++ + " :trace evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set

    -X&0_5bO3~y?L(R z#;7iZ)L1VBXV0PRYfGYDr!e&&I8cX<&rz^zEXJGD?u|Qc3lc#B*_1|64d>B|7pJ?J z`1$^B>w|jQdePY1Id9dLis!jh>m&=HNa`#nMEJaMrD-9eKG4wTtJ`_WYpK9k)otQH zG0<(_K{gb3CE6%qF(@;VZ>b=ihLxvOnGs;CA~TB7&~-)_LBx5h15GGP4l=1HDU*uj zB~!?PWIEJByHHFhs{!JUwgPA!Dd1uLr+iICc`<^N>fixI$W?@CN`gSgPSD8ZiQg6LUrOOo`i2W}o4N?DTr{ zASxpz0J3Qpl_@=I_tNg0sT85uI()sq-`YDs8zi8{r`soc$7e?;ACixdEKCPRdvG#{ zQMq9B>%UOs7=BBfpVyH#(l?Aw{fnSb)b-{Hg~6#mlYzY8aSO4bTSg*!Dt|>8 z>c8x9xt(WN*VZ0}4~}Y@g9^_w?u}xjb^cW9iU;_BK3e!J7Gy zc+&E4F%St)$_+9v>VJjvOE!+0Do@zq*dI8fYl`b-pKxTW*}@2yM7*QW9Eo)3>D01o zGh{1fQa0Q&I-mZYr!q5H6gb3nJ7J4&Bk46-M)EB@)D%Z6y#q2@DtjZDR_Z%JmZvr6 zFUFZbS39U2A;`Uc#NNldsMB#+`k4~7oXarijYsa3)X-gQK?#E4#Kb_U z$6;%KO8wzA6sp!Wrycv+(9O=|`M`#Fqt+19rGd_84>2XMPrdjSKD!9u^8J+UN&nHk`sjg&5Qy6)r|y15RZt-9<)(nU7$jcBhj z?Y(r(5Dx>V?N;UN8f+rl`z$f}STc(v`*0()7nT&CvlN<7MZ``6vRTIFP~2wM$HF^7xLn!-&oz}jFELWaSF$;nr zw+AvnO^DM_6JnPQoHs<#`Ec3(P+RK2q0g1c23P_5ijJ)DvR$lDaZbpg+MJLK7FE#t zYYwS{@e&|chx}L{_OfDlR;Fe{LAN8`IXzFu#pVzc714(qj&N!LnK>^SqVtk-Sw=@I zG$Z#(PRU`ArDL3@?vEjPTcLi4Og+6Wm18UrgcG@io!RzA6hDN5u(#a~jQFXCV8DJOB$ql=p?^ftFX6H+4ucV_V2p3I(vN)|RmkF#t-=DBbqVdwxsBZPrnwWO*tT(*{tc#HSQZ|$1MRz zFTK&wyIM+SkWGvDwAe}1;j>NdVJx1O*byw50GsFxVXwejyi)@urs$d4BHHz718Z}9 zAD+L{_Gi4QXyj4eAkF)OZdXp1kwXW0Vfipz_G=u^3O1V*GLfQB!M+F@P=#!qq^?(ywM%mo2K?0$i%DQ26uJ^2`j$8afUMT z4E^L<2)MTwwBKS_a~NaD5R${{r3=I0iq+c6*R{tOuM7@B+!JulqDZ=p!V(S^Ea88X zSO;(@0rNs}%K{c&Mq`Xrucplz_jfRGBFaJ(6xvc#G)vILrg#qA(a7tC&2m$c!t1NGtm`*$L#$Zaard&qbOEt5?yc6>!G_fhmC!+v6D*awpm{$(G?1W-}r$Re- zdmF>vzitnB+Dw%$kONgKt-&qVQMk>qoWa+Gh>uhm>`X=zFP#HZ;- ztQD0A5NJF=>IF=+i@n36tAcGDy7I=3r7(FLlSD_R_J}!`=WBwD2Gsu=Wj;e{iKlc$ zMGnXE8QmpKBN!2HJVow;F_oeYbR^J7{FCQ6q=c*Boz%z#fPK;H1=DHZrn7j2eR7clG(g!K)Uql^p7-@p8P2Sa* z!#ye=^jZ{DJHu-30A)a$zfVPo-JWOGJ8CrA=Z>C~%xclvu)nS$9^wTgfZbFv9xph28B}M=sW)nhW9DqWcSBCE@J4u^Nagl79!GJGd6lT?C)Kbl_8b*kVY<<1=1kWGq?2F;I>7A?-?=ic2fR@@0$M;i zYQa(kyU7{5-w&9oJ<#?~LTMxpv<%ufqr@Z@BxmwsBl(%KVKOX6E4nC0dER5#Rv@7+ zj*}oJ9FL-%{rxb-5n}Eoem@2tnqAFS(ap99Q?gCgEXA8Uqps&J4Q}Kgz3N{_uQ~%k zG~oEMuW=8{Qy}@U&#gj4V_+lrCQhJpzV+{0g5MNFiBZZBR92||SF9S|o2dceEUMIB#WJ^bhy1$(*bJzP_ zf45dbX5K${k$mc@WkWIk;oSCAb!tSGr+^5~q{Gfin4%e;n0}f7tnx|6=WgWL_{wR& z-5}J+2qBTRBc!cTCefrOQ$U5lemM#x5%`W2jKoyYqSRF3?a~*t3)fGXE2o zce*es?ktneLm@79q>b$zT`+qd4!(|7<%kdte3mfu-F`5P3WL<)xX-}69nl>+S9nLn z-|A`#Tw@@dcY(*ytTYA#ul*KE9YUUs}{is~PQUfya9GH*d4VryCp#C)>q9R7xViA_I>E0s#_hCRXPtRR{nX0 zOc5$XV*=hp!#9lv-RUS!ikzY0e#di15gk%;I4ZA-?=XU81UDFjS{|1LQjeKP;HgUo z^7`!A!eYEo)?2W5f;7z+r7!R`3gydEc@sNQ(mAu;x$df>3GIZ-I`tIpGuS)TScMkJ zeZ;3ur$bH|#c1Ue`3)~9ei;E0CB~(aBD<2PH{}KRmyDcc#m$;kHqVzLOU{3Rw==vp zpfb_CKQ!}An8!}QLx9d-%{;wt=5b)i<|j&x{wT3W6`2|f@!e;lJNDZxWTWtK70L9? z`~~lWq$*;8*J1iFvleegWT1uA(S)o_@V{P;AcFq42Ub)M`~V}~7FkIOE3rZ-euz4z zf0P$=pu5O53n3NZWwP+9r`QcyXxA*1pv>aM#?iKBDI8@nP*^K!z1KC-(r5*w7oSpW zyevj6<7Je9HJfM6sJbi?p=g8&wW1KnM8-eDC3|snA|BTs8JCYl*@!@96u)4`ZkrIv zP1x{D3TvsT$wSZ~w}MjT$4fH?fWu@Pr8A(o~K zk>SFOFj8{aXF&|jJ*e@~c_wBX=IU?8D1Z3y*B<4>Qhr&qK&PTHHBhxCW#lQF&V(14 z+lY$D^8>kY^2JZT_i9QJw_V9n59bq-m6>>Q5}f4UOJ}Q%6h)EJA=RL+-z`-}n*4-U zchv<(zuqj>SUmZxo~F6UE|?pIcg5a@Sb8QtKASK9=ba;bD#yJVwujzeL~pYjm((4i zSyBf34b<8I*+aq~q3v}Q6q%&>Ce)rH{OZOZS8IpD8->6}&qY}#8K+F&!S^!+T9|qb z#@j=-e2L{=N~EUdEWW=M=HFQhf5@i#jN9tdH3~CsW5w_ni$1v!u5VEFzk4 z8qFsDf7r^2IwVCklq9x0V)QkM;uM2XQzD3WF~!jH7dv9LS$jH7FMc2ECA2-(s_)g> z)7p}<)ivyMB=J_pNmRlF1Eo{$mx>odI`g=t5|uHlwbD7!ZHcQ@$(o){Il~?ci#OKOd4n{9bCXp}%MmUE6=lk8mCR+>ZXX3%DI?2m zGo10bkexHMm8Z^+U|W)E$i0P@v7Z-ZitKcScs@o@II1Av5+tBX7&TI9^w9A{#;6?K zcyJvz6=?(5!Zpe2J`@#v5M%#^KUj-AJL~=s)!v7GE-2zTm7SFg@%?a4v$#`48Xu0t zU_5lIBlmV>@vE|t)A&|(2v|((G<|!jJ=IJK_XK?7KS%vv{;0Qo7t{q@D)2JPvPD}l z(24oz(Y%Hh_x7$y2Bqtwr9B6;a`^&`XI{|dqmhsFq7G75!g~Pwbd)E0Zlr?$KD^Cj z>OP&YN^v7*n=?(j0AKEIB$nUVnFuc2iBgQ)`SYWzZdZgPn2ZNUIei z12YkA3W!gF$=ct0PUkk;s|+L9bM~^clH)S)x*j|HSNA8`(`Fcar-e_~YVPW9?75f* zp=SgTJaj!`#JFXucgP?3!7#3@_dG z0TE>=+=_|GhcTFt4v^W6?hK5&v^FAu1%+>hgpwiM; zmPcnTEJ9p?EvYAX&WjRgwI8%xe>A+~Hx^C&B-piuhrnE0_!Pi3%pFTK3)d%>a9cE-eAwu@ajZFImB`&&v^)F$GswuWPu) zs+Yr2k3&xO-5d690E)dsrvY02VOAZ}B2Xcnbs0(n6P>9@qt?)={n7dP2jhEf=>t)( z$C7#>3l0tJ@xe+ORaq@+LFI+3M5OJOTL~k3Taf8Vu_|Ap(m$D?Y+kl9MpZk>U&6+G z8;QwL3u}qX6GZGXgNR|k*MNQ-f>eFr5&T9ES!e6+8u>9wTwj`8isQ-Tr`JIVhc1RF zF(RY%Fu*m*ITSnugRB5UgkUt#j*#6a)rxSGYkU-*5G5+X)zImqD1e;mVJhcnL7_ij3-Yth_=U!I0a+>K&?~3bI%e0o8>5f)>klR!$4AF`>` zje8ho8%gns(L!LRxTK(4Ddr~dLbl;za^EhmtVSD`e$*KF<0n{G7!k(SzkR8T}KKMfwSnKJePf&Ey3gs(ij|l<24sR5+vSn zgy=SxCEfh>5vWlVYBWtgHNuD*?U_lndRwV>x7 zsaRoZa7IPy0M7UCX zd(rG&;LvrKMF}NhugVlK6vhfjI71#_4Z0}e806i`xzj;Lw0n&5FQ3sly2uroaXNQg z7}P%Dz!}lKCGBF30KRzV^u~y^g_MDj(0rp10vIy5FFVfX>CdOFgQK0-`@0Mj5BrNS z(NiOg&LXzIl+D|aBy6L|^CTbVb8{J*(IGgGMChhhELaR`F(K2uuwtL2O^94UF{{Kp ziZ?To`G}%PK`o*=okq?*B_~471qI52?;CZcKA34~=BvK} zk$~r6KEu!|F?0DQPMz7yd~vRsEJ6t|-qu{^i)jMt)HzZ4C(c7&Q~6KYYYVBnY+=g& zT6plC#oX5{Bu^x1UWKzi0JXCg2+Ut9u@ihs4dLuTnm6l8)cItl86f@^w9qT$20#LZbHbmjfRd2`2+JnflPA!<&h!olMF{((pO2OjAkc%(lT9x3d2jmFyJ zbl?BU7q9A2zPLYj&!?dkPsS@|Icmo6W?})E7(lw1DOf-gVgOSd6Vx}dp%!8or>hAw z=3f-=12r}KJ#%52yz%=YYbB698leNBjuBVGO@Vnr273i6Pru+agE#K&XcIm%Gk4&b znK=w}?(ljDxfxI!(_tAB7+VRikW<5f4uyhi0=~>ajNL@R2r%m&>T{e&mQukI2w*!duh%C z_qFiQahewXO3+~yLIRT--gpUdKrsF`BPbZm(GJ-tkb>9oiD<@VZ2(NK6!n{ZZ(sL= zj#yt?gT2w~B&_2w7pa?!EWMFjl}Kzi^WPu6K0AJW_PxCrM=fLd%7hq4v6YsZ4?nA1 z)2^Is4`G|QAC_vnZ+6S3Pq<~5Xw+_0Y!{5>B$LM*TSz`j$!N6$IU}=E>YBa57`;|B zNyFBt%eF>FJ$>LLy6`TaLYVDhL{+8bLgFpfC5b9OMcvhS*mgJ4l9RUFz4b<7#U5W| z`m-Bp5zb-^Kz>ndG53XBiwx5;`~$d`|D)`NZ5tey(Z)ru^7P5u0jor{*Df$+xe)T; zgeLz!<@`uLJM@UA9v$-^9MP~b*niJu%Pk;mLuvMRr<9S(Bq6&ZlV~AQ8_=E&N#^ha zM-e}j9{m#zu1WW!jx&^Znc=lF2!qa@bx+#aI{9huP{p!+vAcEl`egUCgmKDaZ{>sxfZbM zY(z125U>o^5L$?;_@&zS=EZn~v8XkMy|PKLmNbiLDF79RDALu)^0eBI%z(6YBYUEt zAv_B3u7D~+d35hAISSgFReGr08;yF(Seb(VFeq7>Z-HItK3t}u_w!8i{O$unsWj@U zi}#uKlNqM{Vf_yl#cLmtYsS7aa&g9B?*duS^9p0ER}fAzP8Qpv;%s+a2bV!?s6X#W zKg`%cYQt?zdhu?Q{(fu>G|{0q!R9< z$U*ksO{%9jkBj|;zTG>880?KSL+AK4LztrJTR%OE%r2X=9E>o|JM*VzYt% z8!C{7iu1_wOVr6m;GT49hPDD2p+}|5jpWsaI<(P!N!&azt>z|NSx(!973m2D8?lnA z0KJ!A8cf}F%;zh6FV02mX4)=tPee>##`c)w;4-l!O%JjuLpJ{+UzlfoFU+#E7v?g| zU6^~RE!<<%EX=oG7UtM0Ng!!l{44ib{7E(G!u4R_EFmJ{45&fo=7?{JIaa*r< zTIg$(rE&jB_{4=eYYQIoAUiK}t$$*#%PAZ5uX(UeBpDx4w{aG>|H3?Xr!2CXeYnr* zce8L0UXr)={Ac{UT=5+K5Lt^zhhi9dw}j_|UkJ{}N4Z!qFeHbca2I`0K!l6Po)~E_ zdEJm+Bxylh4c(D~38W&T3=DBP9(0_M+Zwu8UPxwX36#h%XsHP>u|O8Z86=mkkvJ;W-HBRLc^k>bw)8ue%Q&7R;Hp)_Z*9WVO#(b;6j z1OG(%qUXbD;*DAyYbjfZH)}|#KMyf>)@ubJ)6`({=M~Vຯ(yw9v#U}`r{{#hy z@7{z#xc(>Vt7q@eAH7}XLtXPn0l{bf>PJkxdWq4Bq#Ewh10r>mVDqb8t?ornt9q|f z3xi2F%bDb;8P~Y^?qs@&zlr?Cj2rwS-KFnys2LYNi6@!4qAX;%O47{lQ)A!V=N6oX zsPp+p`#zn^W|C&c#tp*NiSY|R#RO)$itD~uaw)UH4lL4jMtk3gy~Dk;y~ES9t;6lz zNm%*N0_6mwENapJrI}YLn)!)v_L!eGG@885lrS$&_YPm~?~22t!_!w=C%ZedRiGo0 zPD$Iph22b~1h^J3HChA|XgV4`89U$vU)s zdmCxNHPQob1-{z#?&jJ_Y8%;m=yMSLDbzY1t7aAi4!Ei!q)TxIg3aLUNH~i3HYbDX zNDV?j@f2YBzJ?h0j;5vdL3*q#<;Ip4EKB9g3WYU!hfNuX1AB|zduU>dKVdy%29%U> zB=agXXDA-mmh-H%ma{!;P_>uo1mr#fu!TipdEGjXF$FlKmYx%MO>Ybw^iJ{mZF(c|-Ta>2D9)s_rDRCaYd zBWE9FFvekf$#)JOUZSEF&(onB4AI_9YTMbiAk?Ozrj=I_sGhONi!~wOfWde}ZRi`~ z0BNKtTHU%3L}~&W+8y^4ST5QiP-r2loU98@H9}|Tp|7(Fakg4p7p1;)cZm^*9@kdB zOVR6^=iHnKPm+)$;wU;mwMPk%Cz(Rp&B#>gg2*W`HGdNs)$lQH7oQdCqTLLIcH6ATUP#n-qRVTxg@$T5?#Ze_lTxOCeN8mf5cST;n*IL{|cZs|-` z3$PG!N@Z&lc3ky*Z$xXa2K(8=NKMTDp;5|guBR{62|GXen^QfO79NN33GQpT{?KyV zKh19o1GlZEAX)J$BHkqQz4ELa$OAANSz{s=DJ&V9FG)i=bnpG{yYDz`Sm?QZ*Jpdz z#YF+F!5ASOT-LZ?(KGsZf9qg>@3~9?OYpzrFnarP7=+1sk;Edh9Umu4qLjEOo zgz0EhkZG{g;*92z286&uKY%+5P~Sg&>ij?~9>~VPVEc%L6gqbyISnw3;T@5(5FaDe zx&u1prqfL`dQfqH2LrPaoMZ7Jwn6RDpXmubshP7Y*rFIGDIHuoI8Lf^JFLp}-S!;D z4fk9vb7+0dnKmXmx1ckcDdIZim~w7{M+*D2$~JP^lig_PyJmfc1G&laVMJ zjg{r|b2G5z6EpT@Z5b1;uBBs_Wr+cZOR3=TRGdd@k+w!=T2t9u>0xbp@rl*A&GDc_*({3aGw!$FWT~N>l_B$N;w3BiVV}&AJ%8R9#)G>dA^5 zuHf*Mm~Dh@(V*{i-9qdo2a#QzcX!om2cw)u9Shai)*gz&WUCiAALCB{F|=u3T zyS3V?!TsSSK=FOCXyUVMb&9YBDPTzy({3;{$MEO8oZH%N9h|;wo$Q{z-ajifvg4;h z+S%f)qB5`T_$|WAk{DAIzReVFMXrF{ZqqrCQ||0;@0ZAxmGR5)+cN$+LKH4udmEPq>= zXBS-#9ud1q*Y`+#9?zCJ`33W0s1) z7Y$ZV!l@xk2RC*dozsPzJ+W>5ac|^RJa@B6(`xeq;RQ#w6wSv=bA!AA+cxd?9$}K^H zH!eE-LIo5`ZuVK#A#7(=}{I>b8712~y z?#(fhw*qC%m03C;Cqr9g4ntwmkVl#vRBM_`SFC*d zug9#3iEW$n@;sNB!aUte;acS35099Mk;U-Y#z!`+GlEZ*CE>xAR)ai{`M~>05*muQ zO8PiOrYPtkmP_H1V}NVWcdG$Brm6wBKU2{uRjt!;ET=TGQN6weuSJ8&w`HE?YbC>f(Kr0bB<3FYj15rBW7u@aY0C3gEIVuCN(;g zIieiUhEE-_6e4aF|AMv?%Kao>Yn+5}MY;qty5XgaVVqWRLOPaFtLw`kqkfRAB(31g zdvi(!frbE4Hj5lZ$`O~Ik1M@19x8xm3U-Zo3A&+=0!v1IfZHyv1yz6%LJ}@Ev$Rml z!m{R-Zaxk&*%+ff&sLUsrgSv=@Q%x%<#sj3s74cOW-4SI4yP`i2zlTL^4K4irS9yV zpnD+(`cZMEP;+mOiylRm%t0O=MkI?IQyLTTkj~I7?N9h;v`@;p%@^u|3>>oyE6{J> zso*bp)zW-Lcr_O#zvI>fbCB8Hxzw`Z*4~#1Zk5A#HZe7a_Kdmb$Z1B1o>7@fF znBw6u3xS`h6>PMK%0TlmBQ1$!(i#z$$ft6bl6z$mNnC-WBh0Hl;`m^wJ7Y^_^2B^h zrGzP(IH7JlSRfvbLzoXBF`WrqtQkXOqDYIxR`FWW3$~)2SVaC*9hMYpkp&clL+-`` zbPw1LWpYgtM16WqG&PY{PW2+K%mD}Yp1>#hE*#Gxu6(@esO>9fJQO80=X!$6(q#(x z$sW+T)UH^;NoJ`R&ELXnlYpoeq!n++va$zCMk2r@B*KTQDmrjuk?a6MMtD$a$L}c_ z9O8!E!3rd~51ziTr}1^7;?Xq&f!&Mq*!x=}zw&dZA?xFC_%(_Ahm zpAr&MYy0T%#oo(O1DXR_7DYAVAH3T2Lj={QrNUPmzw2F%hm3Kiu%|)>s}kGM)ranh zV-IQD9h4)vwHoqFZs;00IiaGD9EP-mCnYwRTZ;X@0gC757UTCTvo(;aC@D^{mg}zp zY3h#sQX|oG7~clGmLz}^;JmbUQ98p?ZYA2--rg*1Z|4+@)bZ=nSEX$fMvGI5vBF_7 zfYE>pD>ecLVp}RgC_z}uv2<^hj?zL@rL$dEZh~NPGml_bD7XGQ}lV@XonSrXvz#ImP1_Am?PM;jXJD78m=2J#2YOSJIX@> zxMjgj3!@#1yI?Hd`oRq>T8Es$pr{+93itvCxD(*Ds8-8aF~rpfMp_PQG!BniCue7S zG7O6K>UeKE?eTW&DDCkJ_}kh)+Wz6xcxw?s<2gp2-uW3W3VYi!O)}G~t&^SYqa7%e zc~hA}<=#I!-aTxcGF}h0=uIiH-(IF@&Q#76@Ua9TihjU5#_3 zvp@|bX)N{*UlJ&+;-REdUYI60)H${8GOl$*{aH%+TDPNQ8>xkx%FcMfq~o-NkEGxv z#9beQ8&{HI0@6Y0aCGvaf@UP_LyAy@F;i%(QfauxkXNL!Vj&AG5xj?|cy~D7tuh_8 zEH`Y;o7r?~j?!*hOPFK0+A3^QTD6%km_L7Ss;I9`iX)(758Hv+Fz!JV9JZJ<>(25J#{eBoIo&AjSj zi{YF#u?OhaK>UZq)U*mmx@ENziQ^qBH79ir!=G85V>613ha01SNq=R2O!q&HBSVt@`v0@{?hk1kUE}!kEBqBx zlc$0K0%%OCwQq@H;`KxmP5Z8G6n5u+ zX3jZtu4e~_Ek%7>%$d#O+@kMEvS20D<8sy^hoR86FX(ebCrm!3U0)CddUpZKYP=J_ z;Dhp&Fg1DPMp}fe#x-?4-Dt5GCS-+8baHx3%dvZMl9y>v+o;`grWcnJS|@ir_Svc$ zwq1lBee|f9UsON1n0|Ayw7`+((k!*|37nRtNJ(mKwrx*-0pE*-qm-qTO*Xd5FK)@0 zpX)7@(sP2TmKhobPr$gizhxxgA`yNIg=i{z9 zhT7S9lAqgxfrTN5G=>Wi z_T9TMur=Px#fMeyPi9E;rPWFATu+`l)-gpN{$X^5+&zPVTfVzv@46KIKj1{UvKgRbbQ|`D9K1nkeu2YJbXx$v z)4BrAGTV!^ts~>$Smg`8v}$no9D)m7qZ&d5f!U$vxB&}c_#JP*;#Y_?*+w}q|d_-hj zNpUGjNC-0{Vt&L6!idDG;!Y3!VA3UTgAsgpM{Q+vl;C}Uq6w?WLeUo^;ry0}qWhN& zHzoY;%z*q!Q~Q_*a?AQD$q;8{S;iR91GJPjcLVZl0bo8(TE4qm;&?cwrSo7kxiuPi z1B}`MGEV5)M`b(CkP7xa;OZQyaqLezy)uvmb__pIruRletogoz-RxZ;(Z(ngG6yn7 zs}=))>{dkK)vGYMgc+;HXvrCNJk&_bgVXi8h$D40vNAE{Wo2jvECn!v6 z8MqaqWL1}m4MBHkVAy4P*H!F@$r=U*_hCdTV9=OQX|T@G<3Mp&F8YTsQ>O56#7v@t zW`c-`!#0%X0dkEB_Ywz*(jye#UbA*%!WbDJ!w!T=8Eq(RY#0{uMq$@aWo}dA%YfqZ z`2ZNrpt@*G0RWK^oFJ#_bgzI8I~T4>+QfY;0}7c^8ZR0~JEV%2Hx3-Qh327XWeEiS zN$_Ai-fBn(4dVsk)%A@H&P#XNp)Bg>KEQ=-@0p&Vl049DkX~a&hEfbgwPg#wIh?k#1Bkdg?#etvSB6UkUv25E>*(@OVC8>yCAWY> zfitkRqF=B4Ts~Zp7|A#*z=(t=B=OkDLt`%U1A!5%(IB9Q*H91dm|ZvMjJ=Tx40{XL zbmepK zf`dsxea8OC9n1MBe=-_M(uqiOFBDzUMuhMk~bW_ECw23ZVoW zej7;Q_?C;L(S-EAtdWyHmz3h59$`#uuFQ)TTMIH3Mh8HvjmE(n!4}`j6c({>`FuR- z(@ozWxDuHURR$?wMqH~6<-gbU4d(*Gt~NPp8_sg0^7d_g{oT7ijn9>}KWU3Rkz0gZ zU&sJS2DO8#Di;~XgjKn)xc#t@dcH=JQ4P&lUgK{OnJ2nrhF7uBiB|zw3JbLsP{Q+SZL(OOelG7l9<^@KS3yLejVf0{UqWdcw+tFN0 zJb)kjrSkc?cftLu?On+)Na|N-UMP|yjxCu1bAcO6YP^M|A}&~kZ5uk{2Gc7U4F22; z{;We^t<}R*PhTo)MGL9?=(32CWGakYh!gb53_)yE>cow}c0w+aHUx?TtTy-(Pkvfs z|2@fJ`h8gGx=QlPhW;F|Z=#41Qs->8HApVn)hP+yRVh zyqU|TQ5xMJykP3|8$g|aX)K8!WXSU;l_zu*@$^19q>l%UGO}^c-H9XC#i`qO9p1Qb z#k}<2(;bb`^ot4wY7GtI`WTuOL#A@XAlml!6234=Yu$+;W!!ISDvgtELzUmPOKENqiF8yRBJxz(3#M^T%|<#+LbP~79HHHtl@ zpSAN-GtOiKx(VeE?oUw(ifBmoP|C+E`8(y4ji**pqT#q~<+{K6&|2C{~za`BC-YwBtXXzy~-YYE#o69dw9wIICT zRUTi-T8@fpXsPJyGZYT=I<9Mo@g@&MGwL=c^+Tg6G4JH;7!e;>aTJyxxiQX=2g)rR z4@9%)57;pqrBU9%>pR4LT*Ac;ImyY`;oMwoe2@0W0XZP@TvQACZc_P-$cgrul;tGq zHP4&T7VF?L06{lS+bj)9NgRmgamYU>q!#26uBI}ehLlTwK6ic0v4a7ODD+*Z zY14Ps)h!WT!6qn;ngm;wHQ08&Bz;@%4p}qlCh*@r+@vnylF$J>aqe_3#kaqX&)2^{ zN4)?n>USLNnu2`FB_Nkryt+^W;aSxERiv|j*A3h;Y;LX{sy$&pK@k#!FPMDP+0EL>9o-%jymv64wi&$T31_R zl(!dfcf;_1Ks7I}@x$nPok9b4TmTo2iU<>XX5&AlD6F7zl2m(aX#lu`zNx5OXl@FBW;B3VR?P+i-)O;zO}K+4txczd zJjf=HgOE@zaSjFRy>vS7D+`{!1(0&|6zVi?C|&^YmdXdO(A#TkLnvLHaFd&jI!Q=mVTqgdn%(;HI9^+&2Z7d<8G9H66h37pFpFRv_b7VRi247atWX~ey z+e17R5_x)D5;7f`qc7NAupI^sC}B(*jNT)dcDFDLz{0oYkKuA+0pC+uoVnZxu{?78 z=}bnfB@S;IV^S7xAdyRnZ>-eTzWhBGik0Tw2wB{tGe(Bt+PltJUIfRN&M5G^w+1n# z&C@vj@!&}L{_Hm!XRlA29P`1r^>#0&H;dnS-Oi&&$_i+?oA3OYM#%BSW#=aB>c!Y~ zhvFqLdTbV`f&hJ%p?sDZr`-2@F!A%CTd!E=h1g{*hQ!!af+X_h>N(yRxnPzJb3Aa= zDF#3%I%Ltqp*ohcKeUHccKf}^wp%>mN2i5EW8F>L3=x}USbF}-mjsr+Bs`?PE1-cc7?84Y#@ zk^N{2{=an9TDeK?U~d9S;DW?2rxe0SKvN91{U=jkmVw^IEI!o<#R?O zmvuwr4t(v9Z#lpMk*3nssqlMae-LRbk~)H{z{!~3o=;$9EJ3@z5jmenTGQHJxr%|W z!@S%|XVD9cD#&piO%piFsFoYku{6Cf$HyFh3JSppK->AHpf>UxuZkjGr<$ST#4p{>O8cGnUU(2Hn`MXn1Ma5N2i`1{KCwpi0I@k>GpqQPd?Ei?cq8G0bw|9u1ZKA^<`&^MkwvIg*Z!oxwFK`H8BZ%& zzyDDTMQ%A>BH2Q^Gnz()ke8#8v$nah_9vSA#3YUp8DQw+aAzJRpwn5yA1Pl zmkIZid%(V{N$x`O0DR;i@c|jvA=KF){S%M-e#V?i0YBNuL-(wY<8^cQ!Q|%VakpF` zG;{hWel~YMjBM^+IM`eg>zex%JnI+EvZjmVW-zI_CHR&!YMhIc<6=Iy1oNB7;g)+R z2fLpMi`p0|37g(sv19V-e+jCMPwq2J?DOH{==4Io9GZdJ2CB=k6pJtws-O8c2XBZD z`ZsUit}CbG1-R7Q;;d=zE+J>aq}#cr`T5)f@zUwM-y&amo}5^(+@R|=8varYaT&o5 z&$G%EPuabs)SZ%VLOTZ>pd%^p^O()RF*nf!9Zg7^L}BMWU8E z6^=}mb4&Ob=+;E#Zzr8)fc~2lqh#O?{4uoy1%v5;=qZxjv2%ej-eg_~OdNs6oxX6c ze6LGnk|qu30@Ia@p^iT&VLSCFo8mv-^Rmn$G5B+La*aBh>dg~12kfhQv$?;& z%U?MG3buo~YUuKnPXVN+Bc`0j^qqd-s~lSxJx2uRI6lml zO`5+@+gJJp_R&~8{NuE7w0Hcf{P5ui@o%wF{bo}<7IpFSny7EqYa1Klk*KY2)N4F|1Sxc3c&Xj#6-y19-JP$v4U_bBXUpQ7Q)0e6EkWi(OW=K)Spg{L+Den&)N`! zxoF#6WNyG+hBI6i%0Hf#%2Spx_NApkzl&h~Y>en#klAMl7`N!&q}t~8geJ@#itl5a z6v`~JPjgWpvi}3?6`j1|$r4XNv3&@GOlW@H>ckU^x$lor);@r*TlU?ND?j*lc8v zOdf6>l^!+{4~`i&B^E%WswEF7Yat7Ul}g~Rhyq-~;ZuKwuH!FH%CFzBFZq~(MvT^fF1&sFKZRno{7s|$ z|D5vge|&iN?&sp;pYf;m_yP<4vdtLWJ6G-DF$^18fmR;M9)GS>)*i!3JVwa`hsykT znj0m$aKL_+LXPuoRO;w&=D}NtUHiYYP-*c)OA#hDeL*wn;@?)fNE>X1WU-7XAkWof z^B7oG$1A}6z;+!E&?Y{)!j~wIyp#WUR3333!Ef)EX@AbfL68j>93~5D1GUN_cb%%q~YPL*r#U|7Bx8Mn7GaFQL7vb2V>#T?G3XgMABvJ z>jMV^>~>=q6dR4=%o2K0!+{@*rrTMT~3^=+QNezxcw`A=x7^r zsH`7kwj3k=-inF<^t7_Fq*_UHzMnekbuPDfb`*wwbgz}g zF{KL|jM^TY#hsZNgq)JNhvipA*;5C775mJYlHDbMy1MdEHHrZ{KH6=1X#n2O06q>_ z;o2=~e*A@C@7(7KVqpm^Mi+3$L9g+P&S(^~Gd+P3_Q{rd>`zA)#*d?^5JRnDt3Qjk zZ)@cz7={qqU!x9;XGw-NX8vTwK#%&c!aHYD#8ZJU{~LAOLw;f013rMt#$MCt%BpRJ zILhTvh6INiH4&->@sPJ|)YnzrqGLU%_cDn0j?QYKo`_#4w4Z99LLQ2r*D5}&On`wD zfCD-@thY{nSy@e3mlRsM$lAao8GWGHQg>~1KK80-c9 zaDH*q50T%&^H<`{AGQfbfav2ZihF1aJTeox!D%(VJCxU&)$E+3~pvmS4#w$wXT$(z+o`= ziKE-ZfH`z0Xs~7Z6%$X;ZZ{A2+im1EaqBciS##Oy)pv8^At&rYjCS^%4m{=J`Y7_j zL7WWICUYF-K7uYR;zyfX#(|fD8b1&}`s4S`*atGoVVR{r0?fKxt2_}H1F&-mhzVN1 z-+Yp>x2CnyR=I!C>4?+1ig*i|Xb6U99|)ezGsd z?nu4)Wo1r~!OtwDUBIXZ_#H=nyjP9rJZz(jk#O!bU)~=w_v6j#W?0UJrb33D7agPGeOT35VF(s&a8^4Oj~*V~Q}gJa zI-Es>=3B39RBE3k)`h_&&sf!D`>Hu9ZUCDjwVn=TcF8V2{dsNm4#rx^l8t*-s(h^H z$;UgA>j6lHwviIsl` z;@`o~KMz-g6u-j~azU~3^Fxp2zc2(!S3pvyxX4!tj>}RlW>iTk{MSJbx3V`x_CjuD z9HK}E>ci&l%j5e7X5x}y95y+gyPeXQjx@KN0YauT&2*+xXR5zIY52Z%A4=3OREHXk zVUtVr87@h$U`pDQ?izfLoJ%676z7%h7((T9@H$_ZV{*<8)^gWHO!QFxl*>6#!5aP! z>uOM%`?4Uo3(dM0s&!9vYXQnN1DW3mg(KGfpIs>8T}-heBCM?yJCK;VyMH+Wibla* zwMcgik{?Xr1aI6iK#5fFZB%YP%N@GUsROyE!)eFs{^L_Cs6YYBzz2;vro&`F)l1?@ z<%SOHu8Z-a`k2=k4L}!&NT!{XtauGen}B?g1|WB~T2eQ>WQ!zIY8f?2QZ>`ejZ*H8 zvla+R$Sdns_bHa_f9-qP@`kLZ^W~nY`YOwT(GLv9P@a`~Q5ZP4a6zkAo>Xf8RkVE_XPe_dkFX(t2#%f3#L~LJ8yS&J zzMUCNb)hgVbM9V=7AN=S0Df0%lfOD@(`-8vJFU>-S%p5k#r|cYy{I8|uz;Z9N&Fxz zyVQE!brl~T?n(Af7Fad})&rf4M-P$oU+NU{vAu_@@62@ezl(=|T=zd%W|5fpj{L;b z1;t=wSO2H}bLDAj%DXQnywv3^$ELp%jZJr%GuA9dYtxqCQ<2Et(IS`ilgH*_#h(*prZf^OU(w5T=e|$pt96ie32c# z`G@aCcG^DuX?yXB4qDH9$RJh}> zSL#{7@2)h0w1ZK3JoU zd2TwZDIKJ_icmk#8EbCE(%yc=7{V;pOK^UlWzI%tpJ?K-qhrX+@Nk$LUw(dag+Z8e z#i67yb(l|oejxhrGiX33looiPNyo<{TJP3dXDCvml*RG6`g^eHz<$FUJ_dKF$ zLi6mL!4;h0t%^Iqn46TK=;HyT0~_Ha+H^V6`Y#m}9TSTO;#a&pIp=`CF(9v!F;XYk z07dkop>+H)8tnFO;nI76p}|&xTwp{mx<2ciqpq4Qo@febe(6syE>)+fEJnvV_{jFy zj*dGlsYh>c+v70uk%7M0-Ie|oFW$U~zC7HM?+*94;sdy!HhyR}&P4Oo$=UJgmU_z8 zU|xU&gWHQU3Z{KdAc$Oy6l?c7+tdp{jDULEYpQb`qGHct0;kN285T%@{G#_0WM|KNqJ*YnW&UR$pye6@nb zcXxLl_5tZRfGc-*@d4e@jfeCdUL5Z2zIj7i06&KX=)nuKofp)Q8JJeTG9E$^c-pyY z6B8j@x1K~xgw4bXjQtDQZ0F`iHxoWhDw#a0aIr8P#aDE?u&M(L?4%8YY`f#JkBbKf z_ONmEqJ46Fl7Clxz`(%=Scn0T&*%C1{_CUNcI)i)-~`~>Z0{cJ!;5m_54<477FjnU zJ!p4^Jv5>0c{hM+diVz)Lpe5pJUMLwilWOw>-9c<^m{!F^^09qpjf;BX-ha~6RF5Z z4tLH6O^n?O7kUD=&vW`v9Zn^R8{9F*_jQ6xlpX;J?4U(w;9U&iD{}3sY3EkA>WIGU zbWySP08ZRQ6yOULTw`x!_)N_pse+ z?g46#zB)NQe$hs|==Spl;E=;c>m`&**dc{t{*Sz5C%$j}`F)-F2$W1kO2Z{^+DD63 zHn+yY>xMb$zyAlH)c*bNZ4vw%U8bnDpCA7F-z&cm)xvndAJJsAIU<1{MAEj`=PKd+ z$di?TxZeWV!eX#aX@|@{Z~FvalwU?grMH$bFkh{ud=pQG63I#tEXqu02uk53I^%$q zlF_PoIHg>V-fJB))Y8$ljZA67(20r!=9_A&Z2#Mt97e@PrcepyF|Lkt%?fAD=EOF#G ztoPAiw z?@om4bS|mV#JP|$+@bE!y~aWQ7yPgkJ{%uh*1fPRlD1&;gnbDk;slT}g0159fDNs^ zD~Y%G57jc?8G?JKL%x^aev8Z5Jl@a4yo9rzr!;vz-xme^R1|-}fObT6TYSi?lGq$K z45V_QwmW?XSi61S2OKw=p7*^DvYh*gy^O}*l{0a%fE?0??S!uPpFUlvYh}K84qWC0 z*B9odlCKTeYXLwubdAi97w&j%Lpbt@vr|=KXLm9ktIHkifuvFGe!@ZBZAdS6|9hb^ zFcnKen^Jdi{r&c;&k3)?nPV_Br5o!fPENS z5SV4;>ri?In8Di^D-Ivw=u?)Sq5>!x>d$WvLmyR^k!A3(3KHixC~KhxgXA)1TVS z9~y@RfQ0O&DD6flj`|&jfb|v|0u^mh#!k1d?SJ08?nq$6?~y4~fs-(A0bo~5X)#t* zDzAK#)rK-vqZQi162bHHHtiR5Z;|(CMB^j!{&TM!bO1=vgRYP#U_O-jpj*^KtjYJb z@*(OF%BS?ZABrGgb|@uRYZpiwOUXWUX3>@MABUyW4=Ykf;0mN-m9U9ZSKXIYmQZ15 z;=3syk|<$>p|K3nk9>J5Uutt89Q@A15qv`G<_)I`*N{S1_uIS~sSyRY!Ptk@2k5vs ze+hWx2Jkh<0`UpVXc;$-4H2Vg(4wvA&1K2ZMwa9Zma~|2lUgkwu8P%FIUAZr`4B$r zJWS+iEkPInC#B8PSevJdw%Jc>vma}-zhIlDC=I}ox=K4KUGJDZ^F5h?H@9!I=SY&r z)N>SWs_PMBxJ5?SW#9I(S?Z-|0&;oChemyYi6l!rcaV zf-N^)p}0fg^v7^ry|wGB+E{@keSMF4`hdL)LwT2SOO#oINjAmS5!MD?l>4+z{ubt0 zC03zoh7Hof^;aJLv1r*33Wc%IUs@fI=$|b#SIYerhAAs7honiQ<&`&t=)Hid^4)+U zjIhta|QQYp=(P$k5uq#Q_BI}Yiy^Mt3t&nP&yE#|l*Lui5dD%61^BV)0Iz4#6;?#49JBv$ zdaeU89fh@hv_FwT+X(57A!ni-aLl8YJr>1Cp`+~LF@ugQk4aLuK>U)KwhF zn4KBk(Z=4*+qdiGZ>05QpOMowJnTp!>PokvmwHrt&B z)m1$%TD7 z?M|j6ygplkY>&~5aRN1KAk{E|;_jYQHcLct#L2;~&h|(`bU^ezspYT{LMF3yO4yI2iSW=)&V+R?k1knz{a8YYl-N`(59`4dg z*sZwx?9 z+2zrs4tmCWxkpnAq(L*b?AkJh%FykcC3BvfU`({T7OQq;&#J=Emr ze7Y=R2wbBHlsp3V3IOH0!--P6z-okc8+i(#c|GVYRymjG#Iusn=yl>$%jX9A+?s@@E20I`kgN*f}rm_p!;o7Cpez|R%=Os3m zX7iU{*u*tIFY>Y7_4`=r5Oeg*TqhuzP@`i9*@FwkX zC=0R+4E*l2@1`uPd^vOJlWmZvLt;7da}8u4Mjz+ncBtVFdT2b!&oY61XgtZ!H!9CB z>e^#%x*;7G8M2nljW}Fs8(4~oH*mxKoJVp0bPObeBr|X~b%$izf~cnl7>5pKKt+J{ zVcpkG59=Kp5*@pqL?GRS2KfHFV?mmqsa59-avrTu0ih2A5(z28JiJd%2*Y8sfl3%I zC8=Gwr6M2hvfo0U6)pQF-ehBcH1R}>Ji)q-5L?2gc@MKO*AJ07BGJxtJZ22a0xlB1 zIwQ&Cc_lIRUP$PhCjPZ;h z$Q45qwo8UazBWICg=9+t)gG@RTdSqn80@V49M}I&()772`8hq4V@JGO+ioE2Qwmdb zhejX$$pEdslr2F(&Xu_RCeFo$+qJ0|iO<8}2w2oZ9&KU>9kdZ8w~z7|aqWz8;{}h; zeO!MEqCj^Po(+KlN1TtCVLm^`KPQKcvu55hq%>bpHw~mpaMjdN4AqqB9!fVwXM6!0 zZaAU4M`%8|^N=hb4Liu4hcB#05e+ljU;Y8Rq`U%0bLE3!fVr=VsI4YjPvEZQN!71+ zciYb!ttQ&)6y9okPqG{4F+F{nH?$I#QK)f4k`~FkFPppnIXD7V3TkMBH<_a=b~lvP z$x&WmYf zv$?_ek(Q$~n$qMjBJ>9N-XtCqc+#0 zDpm(*iC_&Ek>9N=Wf`;P39Pw2PbK6@n-GPw3$Pn#KP=)}%kd7JpGI{}khQ zlbe}g_a0t1Be(J0#V_M`zKeg^7xCRW_i%u-eGA`>U&41&?%=!G6+F9wXIJpgbp`Jv z-@qUK0Uvsub^uRrCgt9TMQ`MtFW^GH`+w#>zMEagv+MZ0>-a9*#=m)D-^O=SuH)1y z+C5+4>DL;Pi{Ui?k(c%Cik@B3vnzUbMMrFrj9@Z1{r@X&`k(MlzdQ3vzngfYf3f@D zpH9Dy?=h0pe>+!>jzX--u4Fd9towbq9`b^(y=RpNH#*TN*IKI5f`d8xra|*hyleal zZx*~>Bs8+b1!GYLc_w>oI0SxJncb?v{HC(LtCpXkcG~(wc@|1!O_qDe02f-6dFAcf zckhrZ-h=8|vcU2CsGM5;K z!t;ieg~elEh8!dxr{4EPx$lu`r&8=WR~Ku)A04+(&(01c9ZVtQDP(*$5ljGnD5sEQi^PVsBSK@3KRt`jxJzkco!juzf>V>}` zMU6G^x#_9$Zb#C^8TOdYVGxA-A+WPL$mr%B=;rY*(#_6=Z&J?V&qX->jBaLh^PfjI zj}yt}>8DdRaAo{7{h!~+;|5}cxnmh42hGC`>?CM=Kkv= zTPnq2;k+K;jsoI{@P)9y!i3C{@7}($%i0gv83-Dnlhi&tK0YkKi;}qL{900q6-ET^ zgrw+yC|SZIc=Cb7=<3PNO8G*RkLybR0nN5vKX08CRDt3<`0wpIL}kqM9Amf%*nwO5 z#_M+D@SxG6Sx4q)N#`i+k<+2{G38oiL!1L2e2osJLV1dMeQ$ERMFp+Jj5LcwFd=bl z0U`+w#}YxCi*>w($shE$nc)B~UML_Ja7Ehr;d3I!zbJyu~*IXu~7Wc49+^C$A z4u9Fi+%7R{4G$>MfQ$rkiRg?2+_^){DIgltiH``9lD=K~zElRD13qI$g_z7CDN@EK{v@WT!bR&~by zcHANP*1=Jt>4XY@Y__-+3muG(NVC#3=aq{WOF7oJsHgfU8ji?2c9LbPccta?{dB3$It(J z@Aa#D-V~T%dpfwseIZ8~KX39yNp)EgJ*OYIMPm!dBD4$S=N&ab8#KC?5Rx*23!CE! ztV6H~msQnKhg}bO@9+>un7|u{EU_%38CT6_BrJg}8(#wX0xnYhKC-C^OCXET63EXx zvUFq#bT4uV;JftN1s+qL3v2$WLTvu6=3Zp($mCtRo%hnJv^VYdZ_6tBFrEP5!(M(kq`x`Eqa;#y)DU|vVU95~c) zvEUmm6#U(Rmhx}l*UpOap{@mw|L4u)$19O_qZaj!;G%T+Uy{`N8KfSuvr zm7k*>DstbFc4ctJ`y;f>fHQ`A7^l;r=*{H#3%CT>T0$u3GG3?^RhC;p#%1N9;pwZv z#X(et7MCI?2AAo(|DYM&@mX_=LnYC@AER6Yu5gElzXsl9B4f2umR7pZP-FrjurdKv z;~S`G3=SawBYHJ+Fc^()5V6S04qPPrE}66$F|2iSVX)V+ir)tfsmeT9w26^%X3-qP zb@0wP^XI|GEts)sEkMwowQVu@Fa>H?%-Cs&HX2Z|jbS8>sPE7+Gz^@N?~kC7F`;(@ zE0b$EMHs|0g8gA{_}~IQR49%(KwzrEjbnm5y85`?RXU}B?#WGG*Oy}hP{7?*1_3(Q z2NoQDZ43H@qyR>C(l~7Z&z`4Q255kckfpbI3iL>YjW+VaF!AOZbej3&PDKWjgz3Yj z8qX+QG+myH4jxI};icQTpCi3ndopWpqa?J_Y zUtzc@W0^Q5M;Pl2quJ_gyJlQlvPH9}EW=+>l=b$JSgF?P>l;rtpFaDBAMLJ)@9g>} zSySYPtmpvkbS65I4K9}?NwiI@@rJ2_DJIjm#&G{+rgRmWPRbfAH;i$ZcfyA0?K#lz z_j$P=t}jW1GoHFeq|}MIBG%_{s*?dnts5AbCE;0QEupnha$~@jljRvM?swlsABRKc z$Rv-QhmRkx!a5iQjlp2ZGPt{{nL)2Gl5%LOKn2XIR^bOIf2vlAmmmb?4KY$~;9_jC z0f$k;py9;mhNft>swnp-8g8^@8u4E_7ulI4?mCYKL z8)lGOFPn#l?fqus>@`edhMbx*6d?ZM6azA<8?pv296>m_&;98bZY^-c-?R=y7}g4{ z>isdXGn8nL!)O961ojpfR%Zfyek^l9(%_J|!?q}h!mGx?;m&4tTTF*2x52MPGI+f4 zCPndGh#3%7=q&=kr1CrTTZQt|Pw7se0{w*irh1Q`tN1HEd2|mMQ{b;atWe<os~HeQG~D3yFX)^FzuW_o{V{_t&{rE;m#`b`Ezxn3cqUgRep1HSZ|%k zH?=4Df{Nh3RgNr$krW@OxkN^0Hx0-G#u;yT41>p)_;1w+R~4=}H6oW?f2KPFx-f9m z=zuw2xM@pa11@#g1obDI(4WI5R5fmd8{{Swx1V@0)Ttq^Yxnr*hvsSP;P{A=Qk=nu z*1Rkql%_)Zy|C7e^b;hYrcAp`+|+GP#}N*b#HgG+6TeNS(Nww52h(YUEgAtMTBe5RB=POJYI=r}!9@o@WNsv_SHja*u z4t5)d?U%=`vqWiCSmgQZgTp;t#^&oU{c94f(Bc8l$A;E=Rf(Y{BXXSQz)4~7&DBKR ztrZnh27D~9m1){*qG*`wbAQ@c-zR3lodZLXT$I*nhelS|T*N~{gNo8>!$N+~^Q6MN3*6Pwd#TxIU~-WPfZ z_r=e&zR5F)EHQOF9kRf-i*Z{g0bvlaGQ=a&Us0!=Ry`=@?>1c{3}LL=!{p{-yi{^A zOB@t?$w)t`S}F8dVJf}^)*woLC+vgbLtvr3;XDk41x*a}KyC?t-1UYS!;Y{swHK5q zfrJ4jQfMZ$lLn#Bf!^i~WCnUO_pGst>=qv;_msYitYXn!WWO|bQRK}6yC?~tjo%ecPdA(A5JlJ^LpGXOAWw3F7ec(NKb7KSl)}B78nt$P^{`BdS^?%js z>+72v)hG4!r~g7}$kW=t#NTQmc`{Y~_iys^K)iJOm;E7SE*iF!W8Tv(G53m)My{)KxzG&1nJ zUe9C6bAX%)YjvG~h5m5u^g1*`xOWEb_zI=lXyD_HJ*N*BPV)@r)vP?iiKvZHLJXKF z=i@85>rlc7rCsJiEUkqY0fmQOCh(gH8!6Zp>bg5k$G0vQl+$L!h=DwPegR zj+IGa3HQ;(_&?}|iG zwIz^IRPL0pWXZ~jJ-Zb4E)CTRZ(nmn5=`MB*KqY=ebqMdk#IZMp93~P2m581DD(y& zj*idp%e&?FU$X5eXNi@~BmB5msVS#^Wq0A7BL)IJe#;VTCIIlyI(^x&w(#qt!)B`` zE3}f<58XHBV{pjNbN2sp}2R-su2@BU5Ixp<#hu7<)Eybufyy)4Ajl z$J7HX1iT1FeQ#2L4}6{Seuq|Qvz9mm()^_jTf{m!$!r>fdRT3fj^v$TZ5A5D>9>p) zRp1({8UZe!u!+NSmiJwR5sYNuZkYDvIUoj&={V|}(;leifU|G`nyMqx7ZGT_8*!<3$~oKP0&b0(0a z^_6%*A_dML=*5gujOBbs>f;a@2l+ehBH9fRLJ`|I2vQ^43#tJQjtbQw*}>RnR`SS45n04#2^@I0`=3NFsn6kWF!N3J-JXiX!eHx{eX7rv|>;vh$G4v^Mft7u1jCh4& zmnny~05D{f3A=A%OE5+0QR6w_r`F5HDQThRx5i%2x-||d5oztLadxn~NNXdnQzmot zp&fq%7l;=wX=;-$^8Ej&Q%x!WLklhlkXO8S_6p(|L08nTrJl zTK8a>59D%*52mdm0x?M@@FZGH7MC zrU&K*A$1$kf1x}{Whg4b(Hf0XWi$+34Jxx?W{{nHoa~S{hAmk&l?Q*C@>BjYx?ZoV z&mH%o)1gRDw&iN0h4*4@uNr-wYS$*1whgChVvjB!B~=ZrHO?yS#o zY;|v+{p1=;W?7-(+mzDK_3ZE{>afd%FKcHX59^({41RGp7@9{zFC*!@rAMYAj`e=w9yJQB=YE)`BV zr$}f%j2tC(L_@zAi`%E(>415$z66VY)U=j7E^e8i_JpAv-z|6_o2euq0gLbXwnyKB6tB<9fUV(*}}a39fW6{Ec7tLTVDY!-!w-{YjMO3^Wh_`qbfI}?$Fkx8>it5AF- zL}ns%hHjwuLTC8C8>2Il%+T97nURk_FPY(6cRHD&_je^T@}57B%uumZG82ucno4G@ zq24E%(Qz`9$czdW8YMF+QCI(oR3?lgdQVh_8%zgo3YGDh(pVHmi<;(8n0Of0D21UB z%%d>rlC5Pa%&e9cr!e|>-5nB-O{GF+sXNl5h;Vl{MKTLV=@Qk% zwHbK7yPR~v3D~<4O0!TRjYK8Q;~ohW4x}vyl0vSmBI$RdNU?t|?TRkhJy9^L*?Bvl zm^UO+W=(^RMIRG26A9#O_Rh5J4HL#RhrZdTC{;VMB&}Px)nvN&I!^bZXyvZd&l=gM z6T*qnbdrzb>E+~b);cJ1wD>|KL*sMIIhhQ7CK+VnhM7&`6Ur(&uXK=wx37-(nyHjM zftI5!0%|kU2)I&ut}^Ln)#oZJ%cA5O`@SQsKKCb=abm4it1Qw+x{8kqZ%4DPcWO%U zo84qgS$B|FkRlhFevJ8YPS6=nrkyuwC>F$#*`yK>@*HZ3Bd}@ZpGXT~Ozi>1K2rsv zWKfrojeao%5a%pupd9-G6p$-PB8XoMI;dxQ55!Nm#oGrLPGMI0mC?7Ye^IrxBju0e z=zcq*C~#^!sGFKi!PLf_L$=i6iJA&5NT-tR43fyvRL>Tu&p)9Cr^pXT!**3#>ICeYJao}CKZ20ju zwKc13aemtiH@sAU!F_lcmF1iz1JCG`9N{^eI6 z)2(2zKj2?$C@MUCQLj`g^W|^w{$%WTr!Y&bN{ks*3r~!Ys@1s$|HH5Ccg2TQ z$@QVh@}<`!`#=8h@cUws?9(kelr$V}xgHr%O1Cu}++zL8&Cqei1!cF6U%TPg2;^Tm zLvJ*tpu~Vake3f+;4ZyWW$=WK8w7ZijRQg%LxTza#^4IL>E*2s14JntQ?ESvriAf@ zI+x=meV=X{K!XPV!BchM#D6w;!t0cvupm!BHEC8laZ^%_)Fq+(AFA7PsBN$@%88|8tEhV5NxXLM% z1axTPym#^9uh!0(6%ZnlW%3F~H$SgzL{or=p8RMGf0vph1n_N0UyEq0i@)m<56F}6 z56-a>A`B;|z@5HPen?0AnC7$fdLRDc{^w7Nk&H#@iGwo-Feoyu{9X{Tqptvk@WBzv zfGhCIWw{Z4#)iTnGwGJ&)!_*F`w+ODrUUpz*2ac#_hEm~%B2&?924V#Y;r*JSGDI; zD!Gut>2^5|owYM!NQ_H|$O?X=JRgyk_)e^ob#=|gIHPHBNx*F%PB7(p2w{0oP){}3 zCAK8QL{{2wBVJmQHXM|mcOy-@r8ky{l?tXkDg}3wcNXr8V!;&BQ!KtkxtAQG+>h_{ zIE{hOHnm>JzKiNVwR63mJPm+jz27Wk`a|QCKN#2)zPvs<`2X-Py2H`uk99MQMm@IB zkdCK$>rzBHiYBB-hVmzgCy~i3=pz6PVW_GQ%k_w40zT;$rArm!41p6U2@KXH)O@0w z%w8comb}6l;r0Xm)4eHJ%dgM|S^7V$Kjdv$uE|SkNXbI40O=I)a6^`P_=JdQPRuKA zK(_03plG*S*gMz-MD(BLPYBY(*YjN+A`74zis8$`!+KHm9q$*m-1&R=*6hCZ`uP&W zSZq|Xo20>QJzOtFTu4>Lo;!h4X$f{-Fc8VX+Rd~N~*lOO-3639|gk>q%0Elg2h8AKu*z!^!{BSc4 zKCeG<$8wsn8Cv*?7vbZ{Z7SGlC?>!BB)nGS`M}bp5nhJ~U(2;Ohzl=?ciI6n40a>A z-a@j|ra@g0!NVCSsXNJAMK^|p4PcqSr+uZ}ePg>txp>M(LU53*nw|>UZgl<8j=lfa z;=f2P^fShPsn*tOM*NqJD#d?Uf0D`nK9~G2ggHt8RT#zLbZ`zIbGh8YfnHJtdvk-j zv^xG|BL17Aex165p);KPQ-pipt3Z%$n?eA8Z%F($s_V}z07NG{a>jH4!I00=!9O2y z$&^Z6Q>s_5Y*gT1?U^lOFbbbGe>g}gZAlANa4p?3pntsRw&i$tR&~|YJio!abnKN@ zVwQwepCv9ok}yYx&&Rn+5j1W`yq{y}&i^vQjj2{tU(ihP{{pK1EcpL_l?wG9DZm{4 z&-&A+8&UlKG}HflKKyUO94Ua(GX#L@g5E8KN{}U34CYCH`(y>soDg92`y*q3rIL%v zKSmk!Bm$VcmZWp?S9dt^NTvkC>Y>I?L5<|1=e|FI;lU-^ql{9FQE71whBCZHFfmc> zC5b})D-UH-QdocGIodKo6fpL-G}$O(L~@qGQ_?1s`Hwl(3a3~l`MoARJZF~pqJ~OQ zHFyT?xHl-}hboPe1B%RvHXGD{W;(EI_)O^%uQ~4&Hh1pgiYl06#sPoI8IDSNIVfh% zxreqKUgtg9bWK)K)8NW1QT?u-BHEe_Ip8rzv285-VF_AI^d(tKT&q|CJxh9_KFrI(qYAhlAYwQTt)wUoPocPpNzk_I`&A@V3A z2Rx_w1Q@~$Q?c}~o!fwxveTd9W^#JCIb0z6w-bskgpw$VrtRr17lhkaE){BhBwR?h zc@1YAzCCld_xb_hg)U$mJd^j4=$|s zIV>d%^je}C+SjCmW^*-t7_g8&4LUEXHtLc2GPU*3ChyS(3<{GqUvomu?$`lv42@R9 zHcR0ygM;97yDH-vj^-yfkjbkCt}_gHZFyVys8k@G0Z&Nj(x5dID$>~@xilVNmk^$q zj*>>N^%3VTUcp7J0;t=W$UQKE+x~>xP+h!t-4Pop@=9|IUoMUbkVv=33A84Dn*#kP+R_u7rq-IoVHG*kC>v|I`(PJfcoW7@6e;eO(5qGi&@Mxfu_#cbxO z<1)+4o+TzSrz6T4(3Oi@;!LAu(_6-vCkLkqaJS#5Y@5{D#>+YD12BoEXiuG5YK7S= z2cO9p{bc6u2umekK0N-f8ZXfBJ%;(hcPS_nM*QOFbqdauFVm}@HV=;*du_}g92?Or)LtAOKX2g2SI@~< zn5{lj!Iw~c(b1oT4x@8Mev$~}==N;A#Fd? zknY&)^y-u#Dy=eQp^D>FBZqkcdN4=wKCzB~YqkD(@yGO}H(=0IilDqw@aKr!y+!+ZmN9$$DyKO68sk86I3)uVf0p zZk3v~2#GBvmY6rDH*XdjRakB|aORIJwWVmE0FQ;nW|W%^`?+IFZz0%r0bdjBQI)AI3F0j`UQAqrK@<8?hc@qZ;)N+D)yLjMw!ml{lQBhVmrTh5AlmybY z`aMc}ec_f!c`>|2HEIAA{BtyIMzxH?x>QmEVwx4Dj74>o;Q-e4JLG4>>RC<>S3vF1 zFTW`L?docgy6L(UzJL^FTDPnGb;d3#Ydfq_X3Z3iLcJz!FZY4fX*B{FccDZhEwMTm z|GG4>(e%9U1(&6Ks0S{I03UYTA*G~bHF1FHjiCjM$0t1r)aW>N#l+8(l6fK*iTb_1 z^au7#PzN_151~uewsd`1H0qIJFheWsmC*0|*QjLc_`@#i>9_KERE|35=nCJ_z?S-F z_Pj$)TnJbBD!6n=C6?E!Jj~)@OlK@8Xgz=)HP)!bRh}2-&|%M{wuzvZ;e6)Z5R$YM$=Cgs+X~ z2Zsk|Kb6G(!PybExetvt1TckX2fMEi8>iyr_36oRs|nrj2@FGhw2uxp%~#E%vr7Kp z2%d@N5Aa2_Uc&8~x@x?J(Vx=zc8^bfIz4#t@=UxuKHO`9%FL@gUs#z2Xn-~I1;t|1Ik!Fv&<$G zf|G-J=4G*?_8W@ha@u?$o*7SnFrLQR+}}Uo@E1RbLQQ=8ZNiK8^8*ZMH67xSYj^X1 z2^B=bJdB8K%&V*bM+vJ&dGchaOh_|W}7&46O9k#-i z;KLtec&&O9U20Z{58}$K_XF3%?jlRv={v&nMEm{=>K-%VM6qn9+|zTMl4qu0CCYP*f$S0>)D-L?lV+r`0dtF7pc z$ACsxULocMtSxJjQBQvwTvA9f1Rz3+-VSjSB=r#7p$8K#u>QQ+n$O$qq`t49?@IS=?Oi2+ zUuvP!3s$jU_1*T&b?JV#Q7r!wdN>=4fIQb4{O-56%VB(LNDHyvKzy-NuF_gq1J}YXxjg8Cc z=?Mgv6uJxEl*G(AEANiz)B|ASU;+hfg2Ph%5k|H`e2WoL+WUvcjk7K3eIi%O+|YVu z5g)~??;XDe0-jL6n^Yh7PNb^%YA1YjczpDNA18DbzD(%uDzQ7>PVuIYG(6i%c+pCG zfi-HIX;qTnFr`YXll%r=Bt1Skh8NA#v|cth(t1&Eti`%n47NWUAM8bHAH6<2V|A)yJXk-F&jONU(6-W>)E`nW}lGdI;(BY>usqMq>kKjgIKT6 z8pQpb%GmB%`ixam4;Z!`UJ^d?cu`~bc(T%0{hxB~Qcu!M>JzKgO08ucy!4Yan{Xv| zmr~C>ddq-s&cRF_MoM!F9=`OAvgFZh-OJH5uY+`jLzb@fQ|kxgP!-mSi*mVq`$86w zctC6&qoK4ra0u3Hr(*n>%|}KG+l|HBBK#10OuTJjtv4*vjkJgh7Mpb6576e$4I>W%Dh^m|+t}Wd9e22ngk%2WVEIEfr0jQ0))Y{~|pslJA?wWzNB%lawiJhGY zrV@YtDPnIV3V~%$dK==AqPlE^Qxcc{z`t;ZE@p>ikiguNXTd`yENs-0^TCy)PivD~ zo(Mn+CQ<$_HlWto>FeDyyz=8~6#>RX(Z&VB+m1fr1?xC~?ob#&z2=9dT2pUH!nvFVSTX< zttTb69ZYe>y&=bLG8Y{is>o0+2R-%~=wTstSDKE)smdGJwabaT(OO?tG#X^s<-+wh zrj`l}*-R8BR3!vZjv*w=#@1p10C)(19AhAiTaVZ9Ijts6K{sNpzQgI7&DAKW^Awq| zwMzD0LJDn{M>W zX2P9_dIcfZj>rxM6$`hv%=c?;{D2GMroI*IPN&508Phk!hWA@Ycwz~S;Ia2P*a@O_-;qku*aeJc1LW?*$*%=V2AXC363G1 zqUT-M#{OuG%4gB(Lnn+H zfo~xk=v+A-g=!`>FnQl%qX+x@SUIt6s;{cCx2PQvU%DM~o_cJ?kf#=cVu%m9FLPn& z0nE1R!upd|_}n$tBV02Q;bKSZor%SG;cfA)#HoCx4gg>Xh=k@imRL1$ud34Ruyn%K z4X@9|Q7tV`irp1!@^%<0N_a;V zMf9YQ7a|aSf%?O^N`>vICyIX19#bfeq%q$KxTq(#f{4TSMIUWWD&j|Zq~P+@cRDg^ zD{N#!;OtP#T968QjobG+RpwRWr|?wTXoj7T@ep4*{i#a_%WhJcbv3MrFHI?k~p`VXk=lwGB2w6e%#)|-7K%l=+84U;^FL39E zK9UHJBd*-e#2@F42`A#gs|7Kk99oppi(>*vWg~AU3DHLEoox6X6r7IK@^@c3Ty> zR3x5(jw$V=ODhqw6c^*+b~MsFOy&rsILMfcoql;V9gonu9RCYY%7@27K1XS z32C1&3>;@W9{6505s-BHw|AmNeY z@S_=vAj>8!0apz*n1QP0xTnpKN% z=bba;;NFKE$RYobHsm06$iYHG?tcCucRzB-SD$~#R|^dp&R#=~6G=L0#_^urhr6HT zSr|`q^d4&6Vh6oR40A?z7}ZZlqS`2}^Il_At)Z8eEAnxOUAdA%h5m3`%JEJyA{B;Z z!I2-e8VwvH#UMupm(a>HWK)>n!gL(TIfga?lF};#vl>{kIvZiLfLT;N)N}jVCsPakJ(bIE~58%-SP zQmxvG`ShW#*OzE?A+7z487$S=!aDu*$!%^d35RH-iL+R$Rnu;6$vgUoMAQlQS0uK; z3b*~SqPdJWSz;p%0L*K&d^FE;)Ks^!F#!{6t9CNy64TWr%e#@dMVNGK0vH^sXUoqC z%e!M%D|$mibo_&P6WE`QDWy*M&>%lSK1bCtgN@7XSDIl!(M9*yDd`&u=eHt(mnouT zL1n|#cS=`60QLF_>h4~t~emC#`4)DD7nI-^@yo+OTnFQLpip@<`7n}m`S z6;-+sp|=5l)dfP0f|hfsrADnynxcP>ayh2ZN2Q#nAZqFId6xo|piqQqHuz)Q5TrSa zaSBkgq-Mw50F{#vc*J9j*{7+3A1s@=Cg)*tOrF?KZ0N1jlRTsbKI?wrDHF1xKXh#c zM#*SYvQNZiCo$GiImV{1TnUzai=o#W^RIC*^R)iZhg;ci2xbBQ)$srC2Dl zi`^Q`tAetC5@)=Z55;Vr;yA*O-Dt^eDIuVyk ztgTTtDYHYYE%7k*7015JeBB-I&ceBK@GT>Mnq925DEf`jOeBzV$c71P63y_UQ=`O1 zsIG+~y1eYKq-fouj{)ZwMLSK~Fca6;7SiMTtK}kFs`$!>l3fnEfO*YE$m$1TIjdN` z-Z5KN)H_OB5yb?>;6cBMaSwF`U(018c}f9WDSt=5$h5wMdRVp(j`2ld(IL)6vPdR7 zX7cXHONTYEf0AjSouoRHF+%}lx00?Qx%e^6h1ZfC+wnzNUCZe$_EOVOI(Ni#E^_u} zAG};5anF6U5kqdS1w$^8VB`|1MJ}0CQ1lWTmZOjPGjvU|l(0Kb zI{+B^+YdZx0IY3_q^Oy4pVl@JxyZ90H(|nf@ErR;a&aUxQmh*7Ra<7@&D0dcV?kUc zi7Cx>TOOu4@pW`zi>25eOI}J#J1Ey2jo9MG3wK;+b@7%?OSnqX_VC&tcLQb8O2)ec zgcP+RR(unR43gjzUg=?-eNzt^sjTgm)wTK8ZS{>1{jZGZe+5JzUk7+jw_(K3x#TOq z$$QB)l|=vRLctJfMS=GA*LSL5#JL55m-{f==oBz}+jE@|O?>8c%92 zc_wWJ_{~rmX-hKbu!fc|Cc_{Zr(w^#al6QGC}~Xks)R2SZd&2nWc!2~jn=q=nbt)K z1MBr2;DL~(B!MfmJPqh0v3gLnJ#adgU3Vm%gOF#_ESpvYhWblX3Hq2-1Xk4>^<8yg z57MKiNNbjmdlNe}@`CZ?ktig^LMe+H?9{Kt|E9lI8cV}m1#O{e-WAN6!3PbF51T%F zGTzhf!9E+LPW&mx9$-L6>~Ttz(bng58Bo?8Dmx0|hXZnlf%WP84xJj72ws|2L4Xf^ zb@mOjJTl4-HDu>5F!q23y8T<(2-*_Hh?YsvTZCy(%=wCe3ez2ZUBu;Ipan{_i|DsaxKv&>_bK6{ z@TH+Jfmk>L(iZ{FmNHqCg{urY#6<8FlLNKknvyx5EQf^xiLGjz(#c(!x**Sh7Z|n? z==kF?28D|Wc6;79fG->}4)`CJ@@{#2wPpVZ>I+y%X`ale-r=m`lmbnYjS4a$#?+Pl zMIj<7z$F15Bydr%p!vUQN%L~@S+Tes#Xt+8%Ou1T@i>l2SV|%s$=5DzSYsw7(HjfLl)NE^m1g=umLOV*!U#G>caDwdKS8_%a+A6RH(a4Jx$3=N7C#$RiCHBkQl*Te>}{)b|UNJs{Z>H8fkUd)=1 zA4-WBP7cTGtqD4+$z{})43c@Jz@J@fWO5hQLm+)shSwew=h_N?7J8q6-L8=b84^2mO(e{Q{{(CoiH7B1_ z*@+5!prQwHzG14?#Z1uXbcxBDNmLvJ?%*6dxyJm@Y=;$Hp+b>-UsVw;q-KXl3h~W% zU3Qrp&K&)n*jJRaJJMebIzZ_;%(lpC30D1Z zucX5uU(|q}js3n9@I@!m_J%`uTqx>@0GwqR6G)rtcT>rvMk0l#d_(8p4)J9Y*O+;h zSDK-4JTxRC(5)1r#Fkx!9U0~woOpt-aDHp z%#G`k3orbZvHREB+I<)*fzvf@xf$!RxNiz$WYbAOwX)EBTKi*un*)a4N|l{Lap zFp3iV80LTPIqxZ#Jg0V%HMD|K4XEz`mPNTZG|xJ2SyBqE`y7>nTkAMO6n9U2S_EGT zrBwwvlhC z>n=lJbF=jq_HaXUx`Z)bEih)OoHT^7Q8Jse1Y4?9jJ>jJ=ai{T%yMZVE51`Uo)f#a zK^dwQvDO82G6^mBWbh;GRGxFod?(&{gztjls^2%$@T$++LQtG=CB{5M7G?=A}4R|sFpbjskF4wYgfvxk+ z94!FsR&diImDQDOOLPNDI>3P(s67-z@M5}n>1(fbTQ<}^T0&ni1z$xfSQ1*vDF4RA zXT@z}Vacf_w!IRC4QK$yHp$X*n86lK3MePXGhkBAF^zF!SsrY2)%T&EWwy#bsu-H7 z9iOfAo~_EBqoAIxnx3hUpRHz}q0gSJSD)pmHOI{1-V7Y(`#@-9eFw$6u(j>lG~Lws zvYK6;hXi$df?Ckh@6J=Wr>olSP}i3E_T9DZDdCD|s@s!I#%+DOY5g!))gIBbr@2q7 zRW~%~i|X1nCw6ZN_NXrUj!JbA)fy+MfGst;sQ`}bx9Id{4tSPM`$Ilex1FFPPj4ww z_d~iRt7cS_>Au zf6nqhXZfGA{Lfkb=Pxz?b8iT=9)|p!xK&_+nrH2o+T1DnJX+zUPJVmRcai6X9gXr{ zl^EI}L89xie3h?=w+jn=C?@>=*vbF>uOO$OQ8 z)~};41A41pyTj>#E1i2fw=#CIe{kA5LlYL{drSH;S*7T2hYcs zXO_Keo30#X_z`=!&V0m)*OshHKyMfNiJ7PE9v-(|!#TrL*~a6D5tCTov|b-I&JKQP zwoe;Bwi_o0q8bkI0OgHCzztz(}qT3gTfzl{IO_`i(*%lN-9 zl>f8&Jmjq&DBkT`R8;#wXfG<4-`S7x0dfJzMZIhQ+wiKf`w}?|XaIRaT^3zgq5a2B zFrY@5RCC348%BBxeAM&iVH-Ba{=u7eTaO54y4yIb6`YbdFUoIq{uU`Cp9)7jcp%P+ zZ$Wla;{c5D0NetxR~LQ%9Cmr%Ifs$(8tBH38n2p#8`W10Ih%w5mc&gl!gA=EH;PI} z8H*0Ge-!N41NDq|Xb}1iq=qVHpi*EMoH9U?<#n@4XzgQW44**lQ zdmPEkA5HsKpwOg9W-@h>9-A`2wo{*>^)p%?E2D7rHX0u-Tp|7gtb{+*IVFvXsvpye znlqM?(KlHw+t%bT)?=*{)M=J%02o?GJyh7+aNgO}SJ?uQK~a)55drUH>`#2$j$3)z z1!e=*ao*x?SJETnj#-fBB|%;`5Ays}$e|iT?M=2@AZ7*pdyvwD@7XTSH&-hj) zEajEEsTy079@Mly8hx#^QyP66SM5Ditm*!qTV~ z;SJz+wHX3CJ*YqrMLA{s^Mmj8ov$p~Zf)20eoGXd!KHGeXrS*7dohhC7*Hdhgod|_ zUZF@VQ$TM-QI0M4tXV_D&l0O7jAR{0vY|!- zOFg6Ab@WqMaxBnvePi}u!d1s*sUAiNdZGqgKvx}1P1P;YW#UM8KyNlV8-YHYdd}5pSmc= z6>P+4^mE=HtA4CWpP>2gm<^&hvXr(0vKKEpP_q%kxXq(<-ZBz4$Dg8Pj&|^=2w*1X zzlUuc8;jEG-ego6F38%C1?41RxJ%6}LnW!%StKB@4q0|S?Eux1@zu#5Pg=lf$1|;Qh z6z6yj2Oskf=j<8E{rs#%fAu<=J%^j##&Ru3Zuq4ZRU`fMMGfgf>Z0l*>5Hn1%wAMV zTRik96f_N(u->#U$d#buW12|mVhAhrl`t$X|GERKSAEF?tCl1Az$UEz{PU_y&ONWX z&M<(!5b4e?ImK?2E-vKA~WKo+N%_NH#I31MHFXG!l1 zLj!E4cDSC};YI>qLZr6-O&T{Cj1mWFFtP9G2&J;Hg1$=(1UCCv0MmP}5ubz{o+CKEh>b`kXd&&+G0f*F-EL7MQ$2fp; zn?``+zJGoWS68~rW9t-LG9vOANq$B8i~s1FIa4gtW)i0;l#`BYN^-)X%RiQ-#V33uIV&mUsY%3~cOsQ_OPh%21l2iF#b9bIy3eAD9mPwiraMu_*+hSb+(i z?wWUvEWB8gqJretdCOi=IX@YVZ%1FsP^@UlxBW#*2!@! z<`lcM>Dw1`3CU+Qr7>hNYfqCoETnVMETwm2Z$B${n|5QkcImEwB1|R~7v7aSq#FVu zQq#pp-XJ2^1z6jp>jH9m_sJLQTS=AXRYy+oU7TyK-hpY3fpPXo{#Hyg9VIi+P-X72 z8Z$6uA|^g3>x;o?Dy3Q4bIT6vZAPdeWsc?4B~1PYqt&qf#2y}Ox$s;Nz5#C4xPg(&98`UT4)u;ce)@mD1>;Do@GW*ZJ2L5QK)w$oLNw@#4ZEnE3i2d*SMm4kl{Y>`1 z<@@=O(w$02lw&5vwYm_E;pEaE-ijAvxE`78t6jME%{R}`=D13h$JM9w`P!h4PggNAP&_neio8{b##j=b#^f5-u(8T@NEu#+l9!!_f zTleFwm(hOgUJRI}KrzLJSsKUP-Hcgz7LgqCu9nO=ijOvChDPqeo*7!XlSwmHj9N7d zvA9_?)=#x;7V|BeNhm(gxLM3IZYDwV9Q$T5%f1;KNHuZBm-mDhrQ1`)1loGg?)Za& zKeV3*lP(ZvGMB~+w?FPAMz)X{Vc>xG0I{)zU>FUXv90tKJ(<~##NC8+@K^$dQqgLA zVH~(x{aN|kn;6-^4d<;wo5mp9Z$nw~;u2=a4r7pC?T8I{E7;>NsRZIOIBpoJ2MQ`% zXtI@t8y{X)lHz_m5T@T)q{$7f(K3_}p&ro>dTfBXR=k$kxpl%%ot^OYL0xn z9dBP=j#L*#tMuG#aLLKw8gxT6Gr0kvbaXt7wgiLfsJ%rl;F{z_s}q*RJ4Re<71>%@@Q_ONI*bB2z_^Y6&^3>Mii^eZ zpvBi;TZ2X2h&Q5rIk;xWwfmrL-WN^e;SAld8m;kf%BY~f+$tR#A<5%xWq6B zmLl7OQF$LXqK8_iD_mfjYZ858jBV)Z(IY$S8i%;Xaa;}6G2<}TGGaCXHx|^I>Rw+W zO)6k`Y^ZHVce4ZO6vBN{q0<){ z+oMO@VSrJK?Uqb{nI0jeH(^jNN-y;xf9F&=D%Px>97jD(Oot;lAC8a-afHf zm8fv3Y8GGD1L;*aYCS4G^hY^41cQTIyulEoUEd9msl==37zIVFiS-8OVlV`@e&}^d7^)PSXG^S+ z(^uhaDJl)drNgk^=lW|d*e*77K}!3fOb#Txi5f!n=Gi9Vqm#yA8+(E)gfXgb zSy&GpRW85NJYO(?t=M-a#6PX5p-@vRVvGJ;;d{tRF(qG7p0HC&W)}d2v@cA~>tf#r zBFsNxnRqgnSoW4#7XjnGKuCv^E+wagagz9OI|Gc|dD1Zv+tW$A%{aB}Jh~bf(ctB} z>C1$#Z8Ow3)O8!nF@dE$s4ZEIXt!as+68&(SHoLp-iivY4tO$ex}v`qP6<55NNr@W1!_K7;96wSDWyW9I~vKQ^>H$J00g^ zx3AJtYNj8uX|w3gsFF^My>vt-b>LTcJtj9@d_e#Cp9X9@aNYq6*IkPVk3NWmF{{n9Q)x4^MVLLaBI+y|dVf`t*f55H-=oX7U ztGv2}k&hXL05cXtO8_G;ajq}tfg?q$a(FPwJ?tesc}k;~Pq32pfQrZo8D;DzR7lRi zC}cmuLO84Sx>+dlgbKlWZB(s7#uHqSy>QD}(Z%#ikSzpOc5)BVTz})4s{Cs(W(cyN z6SqXadohA%-_Xj`H@S->WwlDR2nPi9$t4+F28fzft`eDl?MZam!Y67k!2{YJD04V> zW#xxM;G!nbCXJ{y@srYe$&`lVWHk0Mbv2p%z@2q4a%G>UH39BL=ws;ezJ#`5Qpu%B z)PUPimalVpy7DL2;9D^s7FlJTt4PU$apLvdw$$3lQ-n)H{_?8qMqUnbOP-Y~FWEOx zaOjT~t4?F41_Ib&cWHsAKut^*Z33`L6AnCKvaXHEqHgx6SgBMh?EZ1;c3e+oYFAQP zy}1F}4{H@M6NiSanrPH~8pWjHJB3WcCk8&n(^T7Bdltc{Il`w^#;5q6Flv1(db*w> zlANCZW;Fzul{WvAEgQq)iKQ2t7SgO4$H72}8Y3nkL|n5grwuH&7Go(uB1YU;QwUE! z0~Giq`V2<88GQz`dK!6#2<=()8Jx6ljAs%x*Q$|c&~2?2d4?#X9(e}c*4FK3*llei z@(jAI>3QIy?K*MEip=!R>_0IK)Bbz4s2F9SVv?~xvm#ou8n8*a>?(@4{@DI zKtH}NOEf~dmDpHkH-ems>;}>2qnBgm9hLn(>9O_(xZ#f*zK>^ zMTiFgU0InYV};i1W)Wb5t|q%M%yzD5wZ z<1iS2pdBTJXdbaD!R@faVLwRT5a#U3$&54M)<6@KdM@{KKKJLJN%=O{WAE5>5ners zy=tjfn~Ak*oA~Z&Vl{sEEU_M}3B3Czu^zvxRg>y%ZqU10Qa$;u9(za7pm*!hcM=Hn zawGZ@)B5lmo!W>6;?lPv0uw7uk%>yQQ^V^93^bRkY@oEq@O9X0wwp)0$0$?;uDN!O z<}{-YY#k9Gw%H(Gjacbs;Z0GtCEk=Pc8SJmJ(N?!b1qD;7 zqkK}uQBq;FOFR$!K8C%RF;Z@L9UA^^3LM;<)B%ShPz96MHK%YiVD!s2hi-4aZ10~o zUg1$_yl9oa2WIf%+?xa`v(Hrso$JA=E0buyI6QvdIBd7~+twv5<+;vB+m_uwZ@xG< zYPW$Z@VY)cZ0;U3YvqTBE&PjYtUJ7btpodLm%N3=+)^ylh|dfS*@Xx&Go^0e=s*Xqv% zeBGw9yBM~up^}!1eFp<@gq5B?!&-r?Rer{m_RumWtx|ncjpMWd&G)B+nS(F~ODbY!e(SIxdUG!TL8f~;%4l|dY;#$J&y-9k7) z-!&81_#J@VpcgqgI0kuMJvPeogK}i|$ZEJy+A&z6vh0D)lliPFSsL zE{lu-Vy}y__jn7*&9@%eeCulSttW53_2}kXUw-q|m)Lyua-_!R+k8*B>#&v^2Yg#i zQSYy62~klv7WlVp$D0h_C(Ca8+GfJ`g3AnTUV8(qZ&?}mLb4`lD11UH&Zw-3QFeMj zFHizD=&^-m)Y)nWyPYiS>%{6F#gB=Wq+QZ|9P`s zi{^iRvXR;U{B7)i*2=r^PsabyIa`;E0+JF7WV2j{9g-0KdW&pM*79GX7ufNf!U_uY&(QNB^4}|8HZnR*%~M!xqT+ z|9?>YKj7e7w?lsv+y>0Ti^BEwbtRC`Djk1N)Gh$0yP5HS#?t?-SbD|J6Ic5AS^9XE za*@Q*pEjW-n9x~s_vO*?;qi-~7GdCNPD^JePhjBra4(afJcWS|NA%?d@Jo!~XFUV1 zJX-KJcucVefNNI)|ByTFdy`4urC@l@5bn3}v0&srWSAPR-T6sEOaZ%?Rv zQGENYsBIR-p9!zN`wm|fqnWlTs0aDxdn$(kdJK?Pc@VgRbGXoq0X^aXe4Gpklk++X zR)WKUilwD|6IO$0-pw%BS=fDHMt)4;>WF++APx`RS}8xnU}S_dpcbzv76rAbf}R<{ z4Mu!{!cZ9$;G?=7iQJ__hPdR58g)pW8zCSPr3;$nhQ>P7f*Jp1!|>1L(d!CM7}^UL zw&3YEVFZB^SF+z&5d`R`Kygp1#cko0%d*a+M~Q&|e%HRkXq2xM#5xLqvMC5(AtBlb zL+XXkcW^KAdKY0(`gvK@aHFmlF{7N>FsY+)>4$E|4dDKIYsTtBkQ5@Vd>zJT;nhZy zMj0N6cR-Q-riF~+qw5!S$G=lhGc`;Oc@XyayZBanal?ufIo1K!GM}R-w;2IVwI|~v z7@q!VQP6nr*uiGhT*9YCBQ%;C_Ek~4=WDO>cu%h*Jw*fCsJ_hSMI&z7a=jU`)0UeU zML%19W>#OzOzjT+8POmpO9h3AQaemGREq4Wl!i^`e<93xQGx?T$%qOcU0lWdYsp0%SBk)R#UB4t&6PYGUThQZk5KnX~YQLaV5HaE^aJCMZ! z9jLkRI~5BdM83Zp$d@hEDIO1I;gT^6FhDF4z^*$&sx+i}SME1Iw-1}8PpvHjkx{L43w-tQ8|6K*UXr)B6L8tg3LxXWI~k% z;>=n@b14E8K7|hzD^?gi2_r*=OwC>5%kuI&c8z7?%SHms7SWcXun3Q5GfOn7NZ47C z6n9pI{v}KouW5vDwNATp?j@db*g(gxP8#89Oxju&dtDM=y98q+_+Oq9)SD3ijZw)k zfOCT%M@dz}!GL3co{FX^KY0>G2dkr+iR7?mJl;_M0R?etybsmZ1f~~#NK4i=zzlnq z5U?z~C72we3e6S0HB8i{!&AY_sK+oE7}hnnf*txy*s;%G`^x}ymtMDv_bBB9_fc`l zBG-?F?i*?*_FbbYFA9@*WHN!F#Oyd`VPs0Kq(5DK&Wpz6Z*tR^M6McZ8WvVuxmgTL z!Hn2cjD~E|ry(t9lNoPG=ITwNTJqRN2p2Z7OpH+TWZR@CDLSY@o+1eW*7S!NAwm;F zgG!Nz3=2w}i+)7VjfM3regsxFaii>TN2mcQpc*kl4FL}z)0=v=>ePB2z^W>O==d3& zrcU43q(&IgSZ%1^dnRlDD&BGk$HCxTw01pKI}zrKP=ll}s(P#5XAn_b_Rgi-qbQ;U zxu&Hg6>v#B-)-!^Y^H?W{9^Qf@Q>H|zG8sQ(f?JSJbeHq$I`afgqBx?a% zx5JUYpb}6b_)Ha;sRA=qV5SQEa#Vq_s9y^Q{gMueFB?BJ+pmBZK-K{2qjjGyDn)#c zonSy!Y|R_x-@Pe{8~q4idioPSlAegF$S3Ac( z(^|chwhTt^3AOpPszV<`ABw4?%2{SJc7wGZE`Gf=N4zu#2vH7D{aUy8@vctu6GmFJHcmy2<}H9T9Hi6j#!g7BF7ip|5nuL3>RWi^{gK{$ z>*oH@n5ASXjZAD|RIM9TEdj5JiiaoOlB7p=-^WDMvli=o?EWT~3-=Z5N_XT@Xt1P# z6Z*DkBe#4&o)cEPK#;=?X$Q^Y;mE)%VHFLw_!xqTeR9TieLC}btGTVYLr`(`mg*#_ zOpVHv;27jpTVe0NYV0N6(z3lvLN}VwVj~6xj|qAbsZ~``t99e3M@JYzB9 zLL_iMXHGpgHHj9hY| zePr}CJG$>rhg}XtH!B#?Gb?jhBqkB_D6eMND`fYN?EaAjBg%pi{pD%PKFXIF?+Sq9 zU<(3raXWq3ia`b2MdMqzI-vRVRc}O=*=^}-#9E=^wkkswv3&>bCzCdoWxrc(Ws4S) z*o>urZMS}E{V-1nTat-}*RWOc3x>AhP5rQca;KKm_^~dlhsmtE5Vg!N8J7Ioy((_x ztuoEZ+*8sJ-7+MP`>SqCWBjn#w_*cjU~B|z)+Xcn4>}C?j|WHV_4bdu%~%WH&1->g zDGQsT>!y+{(i05QRbukR9Qzh&eM7dY4Q<(c{euRfTx{AGunXaJAtB{_$#CaTK&35% zP|az`@qVzqw!^p4-C^W4H;Y+5<6Opkt=tq6-Ggn{VCjG<{TOqhZ?JR?&gIe^gPHMB zo)L+z!HPRtz=bw+4KAz+?b2x|VU=r+p)N{v5)S)Z$eA>B625D{%3XNr$&&l-$IRC5 zb&2VIRL{0crE+GS>p~pqLVk~!;+yUVhG*6X%NH%`L>$?|b1(yWP8QKED@-S^)+&5r zE>14TzP?yviA5&=5b8y?}io&%I916ymb}9RYsxIg)HaK#~XPOPy<;aQ^98`e0@^GdwZCxCD#YObCSdy%!#onaRiOOH8h8 z*SuG!xRnV=&~VX2cF^|*Kgyex%-gn(kk%L zmA%sAu0M3!C|_vP;Wb}*L0erklm{yz95PSbz{G=HxHS)rT*ACi@;uX)3kVC)oZ zHpYt0vgb4qa-+x4I_(cbYRKn+4s73_7}t|RNa!9#o5$AQUU`omy)&39F$>wK4y^JW ze+U#h4C4OFMYQYtl$Xyjfs`%U*wY=EipZMKI zL<%y~4S(^{`(JR%w*;31oH%m2dCN*{_tJ$!&*zYZe!TvDx2H26tBh1e258_n;Eav> zlDE;^IG4A);?)mqn~B5$Jh~l)BZ`)h%O4Sw7r98P?hJrWV(Uh%b`(1nxWyfl8X0Ty zShzz)HM(&8QIC8*_9iYXj4e#*L@FB;g*y2*rIYwBGiDsE3m>Y{NvMq>)XCNd@MKKeY76q%#1y!tsq$PLW z3?|8!1nS$nfyh7`&k;%ps*(X7gqK`!i@xd=OkRow_^jnQExDb#o=)a&;dY|;nv4@i z7D2vPVA(iJc9bQN6lJMk#`<8sjRFKBfkN}uZ65h4s-BD`#6-n#62t&*(B7y|+Ms8G zoHr_XVZykN0fwK!s4}p;ylU>1JHEZfvs4o2n9iNf1SUZ82QH$r2~I0uH3_`z`fk86 zY+$m^@OE-3FG50GW7Ha|ANHcG+zm&P9T|gwzdaI9Q4sjQPZcAU7E9{mBT1#kOjCz$k-AySbc)6&+*I3MvSbJ2iCNP{+DDoL|I($+^UD&E|I z=icB$gy(`crDCXM6t|QCB}Lm}(NR*T2_2SjJ+3c(m;w#C;|yVFw20@3U?!*|#KEv& z8d$VjbQ&UVg#)|l+kwEV0jspt4MD={EzRWJf>U9jED%Lw>9}L$z&E0Vr+oS)Q$@@a z(~eLSqxh|hK&tf5;u02I52<~^ikmoOEp0H9{3|bj1!O9dtCjzW)jYs zfW?|AK`jpEh1iZ6M7E2=A!2M@%lofbiNryQT&1bQm`V##e{#5wrKk;GSI3^yMdcIB zC0Kv}wV{SZgg7)Cj?=p74|^Cjn67Fm1t$K)>4y=nVB`p;$bg*AWJ;TN%50rL5g1Cy z=B!&Td`b_onz>|&w3XLYuHx8-0pewnT}G9>QeBXP5+_6st|~1YOJXEE8f+nqJEy|V zEfDZ7Tr5;vCbo{tbsvrAt!8cDig^2XjG2cp4+c1H8TM``HS`yt0-*yR0RdVha-E7= zMpxK*9Yl$X?Cj4!#rz6VvQBfdHuS{hD9xWfKA;W_n4?1gO)M575ETKB^D|-uO8h$~ zB-{KTf%9Sn(g4iOP)vv#__bP4T_c38Jp@>QLnM*Ggt;78JgM8b5gVoiB5A1W^^Xf+ zD3Z8KJovHTg^Ue)!=zw^X>kgRGg&#c;7-b`wxzyB+PBFvZ7ptSpvi#z;&H zktk9C{ztq8x#nNVUAdjN?7YNsym6z&Q0{n1#&%Lz4WECV4n~aaq=qr#ylJ6oa)3D4+iM=h!*)jc z(-HlcM(CvoMkBQ_ybAnTF=<+*g3c1i)A&=w%dp58$-s!&DW!mtOi&|QG`MDktPD$w zgdm?fPA9!BFn|__)QN#QwQ_;X3n_N)wb$>fe9CygXq>(P{L*ZoH6x%u(kHmUHnAqb z?Yk^78%j;XcckQmi!L$<7lo%Po|JR67;GDCb6EzAIVaC0QM3vQxwP;v;Vic^v_;))5 zG1dFu=?r{sz5EOXe2U6Gs+Tu7w`3!P&ZybacgAt^ginc4CW@dFG}ynJ?*JCC=GQJS$jFfa zu=@DH(#w`?dnS^cp!^=|+3iIZ^4#tD(&tHSRH}rGtJ6cghU2mo^)%A&7SYc`VFLsa z9qJ#k=oQX6;P66`_TV+T`uNj+R}4`%7g+&!*j4U4Y6;@8FpOD~%TmvnHwv9(a5>=Q zr-2)({vn^BSPrpXQZcP))R@{Gu#PDnoNW?95DN#y%+v zFf!t$f2{?8j&UWHfdi#j*b+)O)Wfm0C(d~v$eMHE8V>zZa7x@qq-f&9?L}&~0lSZH zXS^cuN_xjq$w7PbVv6zrw2`4#h-us#w=?ChI2##->uS)J7uB|kLn9{}d1rJd7lVW8 zq3dVg3#dTny)-i5Q~|Y3bX9=@?T$ZX7oZvQUZaxO)WQYZBj4{ctCO@KYrsTbZKu8+ z0{CGc&t6s8XP6?Tuof067K-!68g>GUbqqLl>~&p*5{F%MM{~xVOK;+`@W7BNk=_*+ z6ENwUH*dt*@!qj0i+%4V|6odSDiUHh%uME9t4q)A!E?MC%kRqCHd zW6vKeQA=2R71$A)C<{a|Luc{;Fh9cK@h<#5+CO-qG7c0)A!Ki5&dq0>OhT6^(=du! zE~iXoYnyUtk|gmwXm7K{>=3apMpnevxAK|X(0o!ARW?=wt5;^u1IOP!X}oB*kN5Xm z%`+GXj||m~VmL(^ER9Jw8nDo+=aB#lNRZi~+>A3ie0_8VYePK}7|Zj=R1}Ysc0f_f zXC<<152h3MrXAb*u<-AJM4X(xJZ(1i+OJ-pHQ%%kjtK<ip@&&a?qBU%K%Y}w7>p0R8+ ztKbYkOsc(zWem^z4pN4CZ@+Nnv;&(ab{e2_@&{|}%K z@>pZHMjdGI;8*20^CZla32oe#`fRrW=uIQ z8S9o0?sye-ujvkeR$S4tb$3_6QmF|h1jZ3(q`#)(VkM1>%Et!qrtn2$tQdEo7Wh{+ z&-xuhKhv&+jY3j4Z}kR$;?}Roq-0oFHgDC;A0I};K3wSxR-Vy^^nlmcBbGj(d6UJeHW+XWlpeMPMKSRKG18Vi`W1x4$xR!! zkh==-J~|4B56@@V8Dnu%sf|Swf*@O7X52Eqo@yJ8SD5ZGrGPWBW#yJ-_QvNhzCI{z zLm+S>G4#o98%)2gHKcBL8YG48J8x-q{<2$_Gz$p0Ya)kW^Po1TJMCF zKbPg2#GfL^7zkulBdcrw#-rNyI(ht#q%Olk6p)rn!#3~JQWcl#22TG>}0lN zVIgEnQy6st7vj&AecFh4e?ARQDyEwHSAzeywOdRZz#ygmO7*8TE_r-sZ%Ex*)7@;| z%|o5Ev2g2(Ya3rk<9?QJnl1zxse=JO$z=!b64*3z)1BpXGi9Q%r*7JFTqg(auw1eOWv8^ae{=x{ z3Jlo3&}+3_u?bDKCv_2Dj4dPRGp)Cv_Y2y1H}w7;+W~xc#8$OKtHvTWVOFWw&GG?( z^ug=V3Kh!i~8xI_`yiqX}e@|A`GDryAmT9 zN*X`0n(whG;)m3InPwFx94 zjyqp3A_Yums<0Qs4|QVfWKKh7UIQNQDU3fj;!7F2Himz*#H36R;1(mSz|kkWJ1dad zAJsLe5GFDFB>S2eA;fgnGKNhov)pjtxP&j$N00(%8*xRD=0z?}irl8-HUaO*-09VR zF(phom^Q%#HxEDruD`NU1ioM|HAB$d6Hl+J%ejiA0F?Ki&9J!E;H^ZCFo#)(DGDPo z20Nll?&t*2l=Yf5DIqOm@f6NR4M?bF$JTK3Ftw%4X%#WcI*NE*=Rabq>tUQy&C0jH zSPtuP3P=ja6Q?5bjo6fAVLv%4?6+Fj@O?68!nwUr;$@9-|J;Cnb=IK`{`@N%9DF`I z_K|i(Zi8#W@L9<_Q7?q{G^*nzo&Wn*H=Nt(Gi2N$lc{5L5A8%NI7c)0vE0nMH9@dA z8`V6urOKf6`0GDW_FcO2ny$rj{@?~Xvjm7#mazcZQ%2lM`O(93uv)nat!j5k2*>%L zZ0^X#d5q03KL@@l)4HDF6aE{6LaY4FRBNmCH<_{Imi#hZAn&-+Siz7X*-tZmrYhOR zN%6jFV?@&|x*sG20jk1k!O%*nNmiZ@#ZO9+{Ah~ApzgEW#BAXaqBDUW4zwy08-UKy zDbC&ajg8iZ_)$SNXMGUA3R?$2a*X39mpgSuQu&Vs>{{Nok7}-P7;Yni;`fRcnf&Wo z`W1RP5zMHuR4-NoYT6}NVoS@v)`MXco>q{-FcG(L6LhM6)p#_DlGQxsl8j)!T5R>M zJ<2J7fF}Ib14Sa!euHJbs?{EaP|D@zJ*#ki_TGY`+}HGgAD^m_df=rbaTcuZF~JyP zysl65*o}z0BhDla^QC`au?r z8*@NL{?-|;d>)T7w0?V0cOHvF6K!q&l+92~?$dSFs!Gu0C(~3B@Wi+A8~zFwPew!Q z&2Z=X%{3voJZ4CP7TVI0&#w#^Df!DDpV>h!jg4@k_hV$P{r)ePefb1qyq{Jl(g807 zJ$eWZR2DHUIN=3hB*F^UKQ#0*E^^IKW z>si!SGRZC{bg~_WCm&XgI!Bk2T-274B!_$8#ID|JuX$@eORL^t{ZeKCj)5B6+_T?? zznvqLb|p)H8mW&)?^U;LZmWUn4L-L8n+wFg`YYCH3(ykc>4aFtLOLAB7^u6(|6y@$hmfPfj z=H&6b9Dk#VX`wn^AIYdS`r;miKl%bQtlzs(%$YS5oa<>Q2N^1EihL{B(Kg=KlCi-Z zPCa0lRg>72qH5e*Z6mL1pBAXj?@1ZapZ159bV`MXr^NdnA_0`p4PfcFs7i>UHTPlP z%p7UQ``hI z)4Tvh3xw~4d^?~1Dk=Z$8K4DJ&ur{_!XW_%ft3Q3_@D#y;YfiuOUmwaIoxr+ZY*MT zY=twZD2Xxy!1vGBG$i}!Iztb4M7ebQW3?2oncmg@_SbX8Z{TrDU7Qdpt&5EwrpV$I zzj=go3Ge?&T$xf=&S<#EX8G|P!{A|XwNl8)I2%~|w8f3mh)h)YNt^5c(JT%AVXFvh zc%Nih^J+Q_x0=?BD>(~vUsp5Ym6bJZytO#C%4SW;npU*rT&}orLHI031trAlK=TWB zIQh!J)-SaK6`Jo8FXg0O&xsmV6f`-}fJQu4ER zJOFuy#@}FG9uGwim&FD5$#|Yu10Z|9tCb8JceZDIpge zu7mdlaj6Yb^dNZGb;*=6qZ**uinYm)r!xa=!(2b`IIhPYye3K1(VKVK!@F+XGVQlV z1(W43nNh;{w}SS4&|#g^HxD;5rgCxcMhd13@ZHA;m`XG!U~Mq46B$}NL1dST5I zjsEa+vFU};nAGs~EGg+7X>#L_;ij*t6k<_6uJnS$B zsXg3vAU%+chgOLN894+?glN4fENF1xuv9;DtbLM4P&)BfwfV#!bOaW$%Tyc-wGb47 z*IuNo7spAfVJ0b*GDudiBz0RSBpOVq*6P+!?$F`^s%QW6_|^Oms`Wv+7H;#+t48)@K&T-v*vgXSm+ zT3*7k=*D8L5i=?bt!jIWwF4tG1ctTbhNjjQo1K>+be~6F7x=bzYd4N}e8ugerZSKt z&}NqiV zbxw6InO8!2SCnnF#x0L(&w8{9mab$A%{hvUQ;oB)#}k;1!J!68P=7CnMs6I zr6@{doG#MiMv3+qRY!MDl4L)E5wXG&XQ7z>m^pPQx&9nFyX}z*YYQ9m?Bi$Ldu+oJ zJwJ6l)G>7%`vP>U!-1vxXfEc#q;xU+ zgm4j|elb=@fz)+uVb8Tzq{?>C)7o`N+VbE1@!Q(m(Th=UsVUNkUn$X{hs;%>cV%u< zZz;s}kog`qwRqzgqP9w?&SA(fJV$}AZV%e;)BZu|N|*1kb19;C6y7RPnUq9sP8a$* z(N0I`N-~&A{3CH>sw0z{{PfR+BA?_AVNRJ)E^#*`TZ9&KraaCPhPU;B<=9-CS53BU zMGr7SW)Ap5r=bn8YZc)S_kl^n>{9VmrpWpesRNTZjrHcceMZq1W`0W4;qpoq5cL3aVSqq)9b)Ce-Q3U?#)8qNw1TEsfQSIQ^7H)R2vph+~ZP zk9C#7clSo1M5htM)egBzWT>3WX7WHzwDtdw`atRoZBiTRhIlPkJr2$?N*@%6;ac(r z_H60-qK7xU&An+k)=E2Wnz1S1NVyK(0h93^K;3JE$EQ9F;Z)!)W|?tQ8pizwYhVMG zl-`CFGnSn?sEyozK|+mvtV20nNt(1+XYrKZ1>i8!ER$Xf0p4+ix0}fN4Ci8A+4%KR zOJ880KM_9#Ke%;yRkyG;aIkFIo0HGVRPEbk(Zy?#iSs#YmBZ>|#U=wM#PUPpaQia- zqpQcw)5@Y8;Cc9y!|NU2|Fcs5L}vf(`(Qr&;~Sj=uFJ#w5)u-GZvI#}1& zPWSUYQ2mqh?|nD=Gq|hCsyjN~R2^R{TJ%?+HpeqK-dG*qtJv>Fm)#{iZ?d5;eT1Q} zoh^(fFFe*EXgG;0E@1+GIvm&uY#i#P#>+4Ps^=DrJ6fWh;qrN=Z;61sMJUowtAE8l zHt;cKe_Ke1@uwEN{k)r=v;LZrT_P7dqGCAm{1FI#!Ze8iaZiAuRo>~+2%Nr<_RaW( z3=R`NZ9WmMDsMmOmEL;+cw`udPdjayVCuD%QqS6;LdUlrbCUfc@EXYlgMJiwZb_V{ zo@ZU9&@A-{J`~oO3(jyBjdY+G~`=TY4TSva9w^~H+^pq8s!WE37Icqms-D_cRG zo0$nnx%D>^j!SA7M2aN1GMfRUst_;c?21K($Df#?fl&zo)yxNFWTjih7RR%QB=CLV zhf?=-{z<>T7kYZ0BSCcOp5UfbD&jJ=G8E)l0FZR?A^;q-y`dJm=`1Sjv6H}e2djY? zgi-obnE5aP;E6ZveGjK7*arlv)TqkyE2^MKUeW!%8IwL>1}{GOaX5sv}mJWWf!c z!wX!{3wU4|8;Koi!O+6VdHl9WP2+X_ry&ynkz7L8wc<&c_H%zJN1Q2x!05efW``)+ zvAPWRZBp|rh72%SO>^i15UB0|hfF~_PCt?wF*S!H93w%}$_)KD2vayZEYZj>D%_7k zZG4FEKmY0l@CG}qbJ_F*kUa-dX(Wor1nm##+>^}Iq=}(%pE(YFMXvXjyTXPQo_?^N z$YjgsUUe_9nxwv8+z)-3=rG^XS|ULF?Z0!J)JLnKel{xvT;xY-q3$Ap>Ym)ECQi^y zb|0Yat}q5Zg_$NXoET4yX2)_9{*ndCfMvmO{%_%b_v3$$!~b@}|Ff6D&&2H8%FgSr zX&tzC{32=nKyTCiQY&iZBIc$ohVt{*)dTYXi`JKZ%`Q(*Pg7Cn2~Xz>zRH$OPf_nZ zg9$wg0_9<)J-()|0|^o*J}D-Sjzpl}7fb62nEgH7Z-viJz`UxK&Tc<+cQr8IIiDwY z>Et^z@PuOP?D^C#UvpQh9j%%F1b)vD>~e$6V8~LwZ&fzFKE79j zVmbJcM%vWff|RN5zL2g=qn9q%Qf1=ba%BTchga_qw4cwadFbGoDFc#2vEEJ4(WqNG zH;H9AYnQ+aMT)NS5lRnd6Z>q}F66izsVRkZgIo6V=tDOq0ycBO>M^o! z$D_Y$*M$0Nr|+40Y`+9dAh9ky)doJCfnG-UfIu&2M2F7SZ4|i!Z|p0U^t5M%S^YzY>DhUyiAw|qz4l;l z(u)9aFXjk}-ewW>1u{IYLnuK4()_J?;iL|>QLW5e87S87Ml&=qL>VWie7AcIXbLcH4WaCvAa1txXo@-g#{LD4Xk*Ai_#4`mU=jOk;1|2;AH-t zFdbQ}u)4~He0r`+Ql0vBjNKOAeeT}wUY5kK^09OEo4n+0g|M4vX5(CT^IBzwC#;l^ zjZ~4s7{F8E;^5(6U*!ns{#P6n?l--cXZ8)SBXnVWa2xAk)fwWRIZyBUf5kyC7d`(q z2R;0ngA5Pe^b+fFj=}DoZ|DUOzJ57Z zlx+-xJ*P(rn$-nAP2CUPZ2d7owv2gr19!Lyvqcow@iFBybN%e=#oKp05T-u^@@|G6 zV47*clim}PZhvMXL+6IeIRTvFJ8kFD8`K}3(e244=!5OWfgeh`aR!Y7oEGf(m7atG z@laNxK>tG;(h%31Bf!pd8Mz2+GI#{+6Oal8+|@(FcosJwZfP2oET`_cgpFAA{Dt7+ z<#a0VA_(`n0THcFpG>j(o5BaM>SC>b*GjJtl{2>C{B{4-p8WaC6t-(`$?l;>PX?%qQ0QF_1Npn*ry zS`4Y#gAsN5K9c7#v_W{N@*#m;*#Ogp3H^I z6dkffW|)B9EgV8LNN=-4Liy4B3^#%MD>-UZWeiDhiaO^C&J`$xa9x=;_HV0wHR57t z3 zv&?YKv9Nw1I>x+ls~e-8quAunH1{=lVX_0ynzIJnpo3hK693eZ+N}P>yesy)>%I6} z;Z-IdIhO6o+ttc{=Wj&MoMtNUZG=VPk|;MI4skcM0+oUq(Yi%6=)fFu_5ww9;Op9g zfH2B|>Wf>Q2p|do`V?75#3)gt+4bi7v=$}bKn#VdCwN`_y6mYcWuoJzvh3~)BgSGL zU;d)^NIu`w(u{b+EySYo0`Ir;w~3__eW>Xk~BK%xQ1BMUu7PJj~VtEfdztu zIdsaK8e@jQupnO=ZkLO>aT*oIl45qUKbH-yEYYWR-^bDy2130YkfOa)q~iApuY~oV zXmeNtLDZin1Q#WFtmsrB75Tn6hHjn!E@Z3fA8*Y1xsTqPeJ4LFPqztwch1?8ifg4x z^#KZ4;Tgd1b@|BVwKcVRtx+B9olNY3isLhf0j(N3`pK?? zl^OU9^MhZ89af1)!>JxC8!F%*d)T-TqK*1yYX+_`*I+v$R8uXc$t#KdFk9DnwJVaB z+%aC#C%GO?_~Y!1m7(FScC{M1?V*Ma=ejn;8-ux!{M8}i>#{4Ft>ij3!^+_i=I1^n zhrN94pHO1$RA-gTaKk^@r1q}UT|)WM`;WJotKk5Wm+HTL%El&p zd=kSx30575P{nXX|9HPYb*phheJmPP$7kw!8d4mob`WuSkDUFe3myZ}d;q*rVAGCu zLCyD%WBTdw>Y~xyVQ9+qF=8%~h-YQW%zt+)c1R?Bo-Wi0cg6D3>UR(IM}qrZ+ogkB z0opb^JDiEN*?EHx-8s@4c#WyOQA1wc5#1Y-OLzF@yL`hO*)4f4dwzYi*ep~~;W;{$ zpI2zqD$z6}d@8-%mc_b-rS8jqd=azikT(i&``WVe{YYk-aY?xWY|8Vm4Y^vJA+j); zDQ?_1 z+(;&k6(-f17TYI2$3j_kyFnZGC1&_qOcXL)B^2nMK~BoGH}tPB^c`Ggui^oPWGmFk`Yb8Sc9XGH~mkKGE|6QN09@@bRsY(_)M{ zsJ5P!xIAudgK0aT5GT7J;gM0X<;Tq%oCC7tTk2JpVyla)L+)AC=32VdRYAM2Znx(z z#8WVuJV0UH(H-jeSMrkOX@04Y=%+)FD4IzGq?uIp6ZaxSoy0^wf zQ_%#;sL;Q;A86eRk^(~8igP4A9ECZXflULA+Wr-JO ziYf#VO}$MmIaZ`Ryk4zQ(4eKiLXHR7uI)`aD6_md7jw+5*Z}O=Nh3||gm7n7R(4c8 zEh}XzmhDMCEe=uqRZD;z&fCkZJ5#pjX*TEFb!F@O(o5&d?x5MIg0OMXBj5*npB`1pSkAv7AwM9eP9`j%BwOMbpJP%*)W^pI2 zkCRU)eIh1pk6vKDxX;IN)6AjZGwPC0vRud}yXH<8mh>eIHW#~0*%|f=NbfYLRh`l*tgCs&xJ=%|7 z4?aSQEOz@rQ2UlA$>|txe^Ty5Z@01X z=&6c@88s_ZpX^-hL7I2|De)p1MR+hbVp!1c)?GN+f`+pmV)4vjMl&(Gcc%1Ro*Bpp zV0)pad*>Nw$z&RG$7Yfj>30SF3*qP<_`~3^+rK+6C4H2J>)OK=`yld`6cl3-CZco- z8<8(prW7th((YtGv($2taWijXcMfOAOiU+`gTHvWH?@2VT<=$YJoq8TCdhz0%tBZt zB~{dnz~;MO3)HSDjQKij)>~UBnD@6c&bBm8qcYC4PDG7b1c}-e+x8TLt?|vK*g2>& zdJr9Sm&8aD;FzDX$|28vpWG^&?dNUvD@x`zkLxmo>-E>zCR!H5VF){;-wsIj3 zJ6<9QXQ)$UN|8heytAohw3~q?Ue%{qrGDFPrp07Onl&+dsLTq@?YXl`)!y8HVqx1= z)h&3a5W&0chDNw`*qn%CTv_!VDKUpm$QDL2% z!vp=|ry+@SHW$DfQB?=>Zyf`%DH~S)|YflDM$gHl| zpcG_X11M)`J%WJQj4nJC6?1S?Vg~7gI%v|sdZ-qIxtW{x;_(QhWL*=n*sm?%ykpdG zz1DBmq_N0OU9HTfIY~==kFk`wORI6dp?3OB!1+`Vh&LgWCS(R#Gu!WDu}wss6FK65 z8@j-((Ug!t$sW2}#ThV;1^#8jx-kdlzvPkPt>mZxT8jWSJ=+6(mr2q2>(0v;=}k6x6UjimwUpH z&*f!BMV3e@wZv$$phF~hNBZRIFcaco(>vGyJd%lXma8&{fL2B!pfJo31y@3q(9c!=55&B&&%01E(eWS&63@ILs2l!7A@!Tch@@nkBzfNfFk_)C{@RXn z_x%KSjlv-11H7b)iJ62jf%7ePRqXApw(n-?rR&(|;3=;>U*d$XG`VG9Y%F+~af+>W zY`p{gV^;r{IgSDuZMfa~VC1nzWXUlIA*Ml0hNU(RXyy8H+xmnV&7##eH8Q(akzlxL zc3S@SlWyR>;NiW<&h?w6;CqfWC8f zeP{M`Pu6^`D*3!IV}3Md{)<&nJ^cK*hOIT~ef}yTgrn>|3|IAA{L~*o+~GVoKI-Da zY0rAOenA5sxd3+Md#z5Kxr1lCo^HH}_;ce5E|&A^5~NE-^lhO;VDQy>)YoY*#(=0w29zVyFGK_o@f~x?HF_JW(X8421s+OoZt&{6UN_|C8&`AEJgju5N>!deJ#Ty<%08c z{U|>8OgQ>u>rvxP92o&Gl~*xhLr)~2Sk8rRrZ`A5sUwD^QMn!}r5WT3tX^tW zr(O+&mQ#?Zsp~lcClN1iR&geAe$>mvjjc)RDf5%l;dd-V^sAZlx($Ki#nUvHhj(51tC*-Q8-WL%XWl!Jp#6UYC#php{15r39s1iWymOn$46nTCQ_lObQU~5 zxGbqPhiS)M9oIAGj%#}6My&9JbHXoSnaxn--eF+F;=yi)a(PXAJ}O}Ed1i!*y(fuu zNry_O=)9nsF(Fb4Vy@#$r@(wwy*|KaGV0R*qd2hsDanTy>@bI(0Mb0=l8O793BC{@5UUBIm;* zF>X?pns^+ivG7_aJgzI?g(GtHWY37OdVLzL*cB5uZit4mJ%l7%_Rv>Oi&ps$jk;CTj+eS%ysni4rg;A2!=n=cji$D z^d?4dmFAsHF1eh1E^e^~#Fe5*dD1YA2Gy@9!FEuFED?jZLn=Js3;;{j@#8`PBvi3O zg3v<-qe242C3V7KO!cmaGiOf%zvaX8NOfTY*`1TlcmtV|nnDa$%+XK`cTVSQXd3H% z1chR2&#MD^ot+VSgUkdRbgXw)Aj6GNtGsQb0h^iL&oNjE2w#MB#0U}vde^h~idG$2 zE#b9{Ih*_Xpu7Gh_A3NVq=<8JA*lt%hF;{a9q;s?sivO_Ymu*>l@+G1ogJkgwwdpn zX^mc~qLi{n#w4BM`Hv4`uTS=e?wH!936jK*3hS%Goymj!iIbmej?WqHkDBuY4eFnl z_l3!ygB;|a6GPbE<1&1vhT6!`Nw?9+(9e>)SUg0NU%}`o1OV2X*Y%wSZ>Xt0^+H+Y zqZT;PVKq5(z#tx6;tqHw>A{D==++!EN=QDeX&yK_)8hPZ5)X?%L(PuGuffyO(!Q0- zi=>IoTCztt6dp(A5(0uF(>>Y%r8ljxMy{+_WML9(tEmV&bl$#NEH7n=Z)};F4;-;HbqHC^ z$e=JO1+&xu<56ia6W;Le2$Y%)RWp?0)WJjcbX9y?j~UEMJjDO8-YzPAi$DRK!5-Z2 zEc4D99cfgI`Y*1~KS1CUs5pjeh;-T9=Cxj&*Mkka)RHN*Dmhl~d!b7&G7V;eA{)9> znj)4V5$AG*erB&ae>%NAbz9_V*PlYIn*Q>v%8VF`jN4LYLZ}eJKLzY)RRYfH5NLfK zir&M3a#OcUrGK*irMr1jX5A{UMK#ttlWTgW%HHG!TsG*UXDnoOt#?ah&EUwC-#e#s@T^bYM)R!re5|Y? z+VJ{O{M`95!WWVc{8Y(O*#)Ar@{cI#AI`ryVM$wkfp$^D_WmMhEo9a@wNhlth#prn zqFk7~I<+}jl6g4|n|F3gonM<5+*dgrjWY#aTo3(G`b$IDy6SIK{w!hh{$Sbq0FJD+PZwMGd9j9wtdAQYZ>SW^_REx=D<-0ZG z6$$R~SmYOy-~L59(`6;hmfhc*bdrDjV|TNsu8i<@vr;3|A9pfvSIFkbUIU5g-1vPk zvTunIJ6}EpArMzu*gT8Q#EDt}s_iks4!QhI$X#`dy}%!p{Rrvl9VCPjk=0~JGgeRE zZ>lmb@6)&s*YR)m{s-nw*YpxpH|XbPIAQYVWbpdv%*G|X%hAg1{O9&CZ2ScWXS z{*GJ2BSnG_<%7I#$zjNQlH#T|=uvM~A7ktK>@U?HXj6l|o&+_uu^{pKx1r%ITbxc# zUL?7*(;loJb)j#`1$E9*uYk`KBnfI1BVOTetmspwbp+~5G-^7!s)pff-}TgP*n@Fo zn{c3z_x)14fxk?@#5mq=y7R%YybLYgNr07Qw)hl<+F_jot?c|6Qk zGccA5A=?;lY1PPYn|S0&5{x1<`j&0XE76&IYyP<2pMK?stNfb8>SiYnJ(78~^-I$j zX-dYHGs%`$>I#-7(5Ss7+j%=2xXtKtn?Rbi6-H@`wdydU)GvvUv=ZJ}*SM7^YtqXr zqIWElMQNia42#l(QoPLZXrM_uTi7J9nlvg7Vd^>{&qxv*KiE98*T8LyU3wp{5NRhI zWCZl4(EGTPB<&OXjMRtl`8@86yVYhKk3t4Govd7`fI;Z!0^k|K9ST0Q6Vf4>63J=O zt3&q-X$$JDfDWwsW)l7Qtt zxvW0eY|<{keGCoeuzPzTUWnb>7(QdMl&0DJn-w}Gy#OFFk5pXX$i$OjPb;EA?uH^$ zMgH~OL+v>Yx~67xX$-i*8xdw2W?}_3ebO4tK}}-velOP>8skcoG;SdpHBb^lX56(E z_kjV@kL2n`73DB|!DgsV?=4vmVUe`gS!((TyHC_2X7pqZnX6YUeFM@$e9l|Y94e;< zH>VT|ZC9zlS*qQY?~BKxeD<%JS!OTB(;7w57`aT;f)1^C0pyZ7Bb@S*K+V%}O|xeB z)ST1YgsEwG9`{`4H?r=SlZqwCUh@v`itY@%V?cw7VoIN)ySHW9&>B^@y1beYS!oa` z(B@07s>*j1c~`3uY! z*cOgFq+(1B43edDq6#~4S`bkRWbZ;@Mrr016bqe;oaNdxNk)|jEo$qn7B-rRyThHK zhcy%Dgv2H8=O}5B{LRA``n%6HXT$Y}!q=)rf1qhYRcANL)7#b|0$xSUvZp`A)atKk zVZ^*?#~0|n6fsErC>dzHSTs?dSwJ`ufjH^jFu7I&LRgg5RV=a<8X|l~{!Fg@gAA+* zVuW#=lggwSYFrlrq!z(|IyxdPv9E>I*kdm0aCM~BDY2~hxFaBAY%zwohlxk99KONO-H*&`@6?$6(n-`u-Zf=TPFjGcNlohVe z$YUDxXz%QGK(F5bOryCD&92_2=LS~(k_lb^wxZ?cUed-MeZ;;d6cTjopQXwHc~&>6 zCLcL_dVH4hcB8G*mEg$iX!le3<Nw;FkkE7mYoV1MG{_}RUyH4~UOYblQvh(wl;pvyq}2HB?R z#h_dBTeU!VQZJ*XqZ=m#yeQ^vl!&1(vj}VoK(8}-KtyB`Em4b`(FjY>pHr7&H=sPG zqQ$z%4gszzM`VxGVGTof+@it_mx2M^x5O)LIRXAmAvwkdlqw1chHcaRVym7+l-fdf zVVz)nWU6s!VkrQLJ4v-sxpA=otfg?T9`jC9lg)D(?E$4k;zAZ~0VGvn8}s8TQcC^F z3FdM(D@bmqE!yoTAfljBL;*^K3@qcx*&$NT&c*)XDAG5E;X)fZOG=L*BUMPliw+W> z)Aw33{WiCBOq=|j6Ozhu`5Vt>9z3{ZXL_Jm>^jVxvYwdFhEby_ z^NW@LakjPSn@c(3Tp4;)i9IekLHwBG8_ag{hz&gbZEc{0UJe7&T3tDDiP5fYjEyu- ztHFKez!4t+$W66QTV!vpAR{zv3kk-*XYL8YKXCM!6?eoj(RJURjO@n0#IZ+6Wl&0w zLPq#t`DRi(-`g6k{7t!}h5dIyjdx3Iel{FO4LP=E40;VgDjw}6y>I-PvA)}J-<$MAktkN~JpS77!Skg1!DO0Ve+3Rg zHwMqmYN?$HH++%p@EyY-c4brmB;@GkFEXd-Ajd%^fhDdl5gX#ycU?lE3U?Ny+>}33 zhnK(5-Mzs!{O#RMl3l|`Lo@V${*4sbr6%@%DceIN83&$##c;&a1t~&qN;EPZ0gdh# z$c~^uf%rWGK4&{2L|gN0j(041^lkmoMh+|xqb}HON%`&=#gvSbIlYtk>+M>Z==R^# z-F?wPm}G7M#O`llvusoGROk7`DfeaV1brrubh0kHn(VWm{FKX%HqaZZ&HnM9}dm$O{|4!ij{QV%+ZJ2$k^gpk&+CW3=P1A8(wIK5lDR zeXrO_6Pazl57@p!w~Jxt&eZ=ny=ABtyz#)RV7qC9{%GM@|G@pB7PiCkXIHvI8;Na* z+he3)!I!tCizfOfkRf)9Ku4K^hE@{0<}UFUy@7UJqe_cc7_e~mY8bEIyEZr;#a6qK z0np5ruTq8E?SByrZ{`GGX3T<6lSv>V55~;dPql7h+@;oMp@c&Bx9y)MH;0|-VpcWz z#8Pu%O4p~(4r7x4{T?Uxr8}Ae89#jBT)}yA8Md4(Tl2T?^LAHH7||LY?@zRjFgQe9 zBsFt9H8fZ4g`e~*4*09y=ryl8E{~zPktLDjcw~@0l26T7nWV0%hf^JngZfb>DD#%K z_f2(q^*gG^FqW;oXh>t+IN}-r*zdUulwZ0C{9kYppy3Vou2S+ve=murn{e_&{Uh60 zD(!KfwF0o5+t&g)_hioARr=HgcMsa@qOrvKZoxG4qm#wE2vaoAEH3kow1({t4d4Rk z%WA2TsftD16W0uJuh5i`A`mB4!bTLz1~C%-E{pRYI2N$NPbaV7r1JnV zd}%9AEh2sZ3g+@zAky47B>3`IM*6$R@k~{509a(*fw+UnUYwX*0V(7Y+L_?8z>o4SWOVLZVX!%$w<%^3ZIE|wB-@B4OFo*vH=hEHgbD0F_)&7rkh zVC)Q)8a*yx($W&>pp^ zjHXBGzN}K7g&s!A1)Qa~prA3_UEN3Iy!9h=XSc6c3I{&p7U%3oPLm#-W@|-OW!aP^ zVEDdtqCJ06xG9s6!+36%8(!Ki&TW#FF1pkyWO>Ly=w#CNq$9^$H!UtwVcjBkK^KAH z;Ekrs!gU;5H;WU>nvQe&E?-QFwP?6p%mDi>DcPfZk=FmV*+r%t8wny%kx@yve?i_J z+q=d)-Q@-1memWd;T~!T%c{^>s0{t|eH8@I_FXb#3G{sQie-stlt>CgiC?E-2+%n? zH{X^n=;z8~kh=Y|r%Mt+%l^OPD`#*^c}kw zJ8@o?|5;W3@hdp^$z=eL_l%hY$7#VB2(z%}3N!)%;=-AI$4T8DBnrwG%ct_PZ~I3V z*MkA;E5sZHBD;Y(vA$Ts;PB7tczhP6VXRQ&lNn~D;3W)L+)fbp%v7)a@=P3*vT%D% zk2szBf%`1d9AJWaO-`U_-a-L&_1!~Q3!gNJ6fFPw-=*BpSyDWyydf3Jc6^dzr^bR31k>INaHb%gk!SEx& zEa82Ox&l(A%q}PL@ll6cIgQVTV^n8U#jpkwQa^prsL?xwyJDxk2aUmY8IvpTP2#l2 zS8%u|w-aOvPam}0i&<}~`h)lO$A<4?Gxre}f96&%p!g{N4X#}M4KC%Myh`2cGYhxm1^U3yM+_JFu(g$QmHm&p+6h`!{?0u(5mk? zv+*BVjrvCa|7X$vZ*4z?|E(DRVGR5M@D$IJI3DMb3Uj~_?d?Xr-oz-IeerEHlUNO? znx%RKBVf+?AmlTc&mg=AYMVEK&6~gm$9IF{yEcyRA1xRJKjG&3L&Tqu_ndf!i4Sz1jYLfxVd62!|Wta3dUUgu~xI zP~gfSe>x$Z_2K5Gk8py!CN4uAZ$)~PM#>dAfkOe=`UyU{u`L9-)nJeCap5$M$ClfU zvU*XEUtgt`pB1*8ZT{CYav`@44V9kK+z zMDZLK9 za)BR!#IA28s4fGQcC9)!ZrYliBrvlDH3r39bgEmUk1JPcL+QD273F%x52%v`O>tpK%B$^qwW zhYotFla>Wt+0P*!NjxbF3I#g7zXsUOAuvz!U|NK>BN$jGgSI2T`p|aV6qDB=<4~;{ zOGmfJ8QiKque0ScDH>eI{d$WaJ9M403%L(OB9ca~BrjZ|iXEMQ$x2=sxCM010|_pq zZ6u|cy)x6hKr7jQD^ky*S&UoNi+#(M| z*jC*-j;@qv2iIZbrvBt|%oBj-OvCYf0#{V;d_MjWH41Fiq?)K#lY{#31IEbX-6)qX zuUJ~Ba#`|f#6>7Ru?%x705J>DU6z2l*yuGH947~3Bc;G=Bf6}B;Gzz;Ji3V&4O=q4 zMeJ|}VFeaJ)4`Z6U}+0k&pf@x5_%LID^Jh!Swa#P;KCHtV9>zxa4jGQWlP%(t~&Ve zY8{KtHbp?QP;r*y-FUEib>dACVSqYe!mNV`uve6Jg8H5=fM9`3rYUU+=sTYU%IrXqiSlt6?IFzQd8E&P z#BsqPlSeS#C(S$hZuf!Ih+N_7VnCG~H)M_8fgCdbh)KQ=9f)#%R95ER7- zJ$FFT+Y@(^JEAQ6UeWVgROpdis9cuPt}6aR_`XuHIKIz?ccaj4pZyOn9Y6k4-T+7&>1eF%Gjb^2*yU{OayCFt z*8y@eW;q)ar)#4)1+D=Odzj_ya>({ZAqF|G9rOUAv6zC|v_ZjPM9ayppGp+Ckn^!B zjLUf`xQkLVNWa3Zh!Y-Bg2Yk64`F>zxIjwuHKg(uk`jGI%q15}i9RTcM&t2 zzjgGt?Uw%d$b2+8!@BtzHq7VH`rJ038|HJPZaz1y&n-lug1)k*T6UGknEFciD9##? z-2w3|Fs;UNEqe+`7U;OyI;>am3*3;iAD|Q=qo1xVw^w`JRafFB#%rn40#xa^PM9CEuln8EL z=_O7J8Wy^Wk|j8f8zD~P16qub)l~F+p3LN>O}DI4Sk8tQk`Wm43t{T&@7!e~M?en1 zI~6j;Go5l6?46uWoylxvmohbn9eG_fs?`MC6}$*O&r0RizRdW$(?`)Q2U=(lH;Rq!q6s&>Y-mO{>B5-yO^r8=PqoHVXs#wG^YUnRmGqN zwc`fS7UEy1sg-ZQ@r85p(J4nGaJTNBa{LjGK3Ee$?YLP2f_sInjm#^8r-j?0ZeskC z-NdGB;>(F_VI*3FVB&c&@HQDp?8zB>6Q_F4q~R&9ZYGplPkbiq;3xTomknM~>cqSY zHyf^0RHo2M*{RY(ksv*ptJ=co;S0U=r1Yei`C}E9p=x*}cRiw9H}-^Q1tcs3KSqu!5E(#Oz1QxMR+*~8HP#{A---P!;_Y{bNk zn79!W|GGdB&bQOaWR#(R{_t+$J9yi7>FJ_&euraM)7Bl9DU`^^*2k~kzJZKRSoU%m>ncBcp@Xo0$57G33mF7lp2)VM@1jD*f2e49)8_d$_||^DtorLEQN_+uQ)Dk911hRX{s0tVMtKy_=dxDKFJ}HAz}`m zJ$qAi9beFMiRTFChVEiYRbH5I35nywmkhq|Mw=gw$%m5{Y6%70XxxpsCg~f8<_c8> z`Z0>f=m((X`fpx5?;gH<_Tu2Bw7b_94ro8z0X7Ru>}%U;D}&Zlu;V;GX?}lj{O%Cj zjonntgmRJWP3M_K4;vFEj#ji>^Q?E*ks26nUMi9(R)l`UrNG~Mu}_j8Sv`W6X;aWi zBpDPrmgH`zm=&^yfqnS_9a7Z( z&@z1txsT8*E<=61xFb6(`}oF$fU#pkJ>@C0m|L7m{sSG=(7}jC0sV}zkEi4vuZp8~ z2w8M?YWw!+pez0BGy93RN$GqLk>h5Unow5jhh1otcPD@Gc&xh>Nta0Fk;YDO?7T{= zRQePZl;#LN{^A;0W?ELro6w@^r(2?w481{ReBd=eO!@5{2>e!tYhC9)ivhP zOWQ&kT9f$k3e@#nFRWno6~HGw>Hm2hq@QUCupLI(H|bU3tc;tlfnQ1i&p01g`)JU? z$DYvVo~#SfGRp%oFH|uLE`r@cS6nF20J$tyY=OIouGfU)TpP^dS+Nfxt@_7x6d-=B6+4f#A2Q^s!qDxfa=L zSpf=oRG<@4gI5fiBw zPiM@T(jPcpDDoxJa8YhiwK@?c0EZdhT7R0u$qGkUZ3G$FQn(K0 zD7C;739sNjuVYzTN?yj04PE*QGcdr%KB6?BS6`sf>u}Yk^V67r(V9;`eZ9K0-MV8g_CPZBLa1Vn!oKS$sDYH8d(4}-M&wy zwLsCxjMeWLzZez`@pDi`q#=7)g0(QrW)p3Q;DRQQ0!JR`T5G_tIoxO3gSZpoek>I) zAb6iyX3|Q{DzTAZ6AUlN>Y2B&q;nRJ;{=XBs<1!o+W~ty$RRf@iGP|8$+#9VCntRY zqT>AQTxDlsstLWx#T1w#gEM1w`N3m}HUyk{RxMK18jbpUx+OJ`2ba~jklBJ23tLX1 z!xd#!vvCs7Y@1y6B!TIwNf%rX3?2TtpN05JR=Kvk$Ln#7N1!JUvYi)kL@Yq&Ts5a3 zp0KERf&&tRwYi5ZQi#wBdYi(~sfp1B$BU27FYxHBAeYEv;2xJJ-yIwu%X3itD#~G7 zeEl^c@2z`wD!UY^#v!rP2mB{QfSXA%%icrKl&TV7Y$?Eg=^|hF&MpQ%^u^k43YQqqTVWbJSNp zHXXFL4EmxuxC*fp>3nnapt;S4(1)aGt||-=jbO-XNQHn{DnLNYBOkhmhaRNEd>bSl zu>_YHB3#TEj~WS-IpBX}z`P_7a>+)@GoXIzPJH+B#Xt3lLU2mV*Ni7{ZcaENY2+B@ zS2f0=jaKAB8zR?|!!OFOV7mIeaAJ7~!;%ZpV+Cl(J4H2xKV^u~fy$kfV}|QvYGFbn z9MxFu+_6GxG9U&9?KuOBM&JfemcR^(fSrplehVSTWIwi_sM|y~`@sW7;8K9T8bfOV zjMuvrX}(*7riIVDyrG1UyJ|~UqWW$fsv0P5m9`R2?y7BFiR!y`sB(mEFQ^-RUZpY+ z844=Pl70OOvLC)#N>`Gtl<6R>SWwt2Rb#N{@SIQ^5RQ91BnIZEyfrK>*?rk6^};mJ zt+I7~x)FSR$QwzH`|M&WuRBIJ2BPq(YS8DZN`jL!RZ-XDq7hM4KP~9CVwP^b-&&QF z>A3D-Vap4<4YOKVG=(bt z8V?H^(dED-1DM6@x3jQAxSfZ-Sc2zLPLWG0F44up75pHKjF{>bPll`)KjWx76Q~(B zYYt7x#Vn{)A_TH~m|2d(0{&CwmawgK2kVb8Rrpmp4ot&M)NE2I6rA*S(|yL$999_T(wwo z4dwn+8OkRyNP8(t=#iL4Lo&!f7-EVCVLvIWM|llZnNBWZLZT9gM1}99%KV;RTM<^1 zUOSSQ3PL?Z)k4}VF-&DaCDJFF%1p#?Mk_@h4()RQT&r=4?P>`Y|IUNBj zixOBh*I%;ck47-*{VSS=G&c_@o?Es(JVFuLXBcZA)X-{ z)*QGnMmG}`J(c8H~6hh9rGBaD$rukKO5FEuXQ7c&BxqRONQ#gNO?!3q_y;3=Se zKbAI)h`NaqRx*qwc(q>I%7&8cJe8kwZ<3&!k30UT;md^xu&jA#?|w#bOvc8P(3m$t z#*|h}(tgQ37y5D9ONLVz89D==<`*~4)aXiB80e(4G$shCB{~|hdw|Cb%WsmW#x^Ou z?|nOgBM~vuwj_arKxE94lmN90siF~0#coN&(*4{himgF^zhvt{QT6bJrFtl3)ZgD6JVPfeDx_gh zS7<=RMMfp@y>FG(4XP+?^6dDUDz~55^Mbm9zWZt41(x&o9nm`Fu!vC}|)n*zhLl-~(VpCkz%O+Ac!2 zI7R)Gx-1B>IfwZzHJAlx-zIQJXR$`>chg?20+{cZL@pFr!^*9p>aSjDqjCf2{p(iR zs@zC5WLH{T&4MayebDuK;KY}!+@exQ2ac15MACGnSUa$9o**1MA!)~A^^R?3WkTM1 zM%m7&&|q5Ylrf(11d&^N49yyFbt$)`VY>bxW^J8rJc>q#wcaom4czL3_L)^#*B^6_ zZP$&5-O-ob{>X3iW`9h*nc~^xlq=Rq>V+UVzob5gs!dvqYK@xmZ{WgO!B(_c-v1VQ zHuwvt&gmRCU#Z;OM(Th@?)HETy6P&2&ZEiPwp4^lqZgPkjQI^-yzPDqeV!v#$oMKN z1}Kq?vteL22=J>mA{G1&7x7bqWq_}gg*db+1}SHgH#mXdu9mg|QWvX0hzO%dVL6aZ z6MEYvk%H6dD<69_Y(zK7&UQ1j3y7#Uo5S+AkzJ&7z3jsYg@V?05~=Ou|5DoK4aYeb z&NL4O?Dqo;%I1X*_;c|9-{P?1ZzmTMbn%?bQ*k7H;n~V zeWU;V6Y_t&a*6?9J9#~Bf$H~mnZ?)1@FGgCmhy_nlSztLhKL|IVyuRzS7+mS%BH#~ z=M&-_LLJV~?LOUTm^VD;hR59Sn7==G>L@q&dI#sKb-dse$Ye=exZ$z%+sohW>vubtV<`;DrO2PY@-P9 zpOF6)(@!V;D+-erBw<@H-qCPe=Kzn8u|Z}>{4?pmkKq`|?C*1+J_4tkPi>qp4bYNd z%>xZlIY2T$Kqc>?p$$9X5hg%8WWxTwofy`OiiP3Aa*e`r&4uM!h2?fkxkgKs>jZGO zT5W_?tiD?9!>?BUhBtq+Fn`ONf2S~iTjkeZc2!<8i_hZ724K)gJsid{i6b_I_kuIf z!bqpIFzTh%0)ckqT7!l)pvfK6V)Cn?&rJ9fvnAN4)1*fGFP+YQtX&|tb&6ws+P1ne zOs5fAwF9Sc4!dsT4LwPLOR*YU+@;{>kF!uVXE<(hOE3#>CeBu;4KjjkxN`qKnoS0S zkLB8NI_u8R=?&vgPIV`0v{fi8jC1Eb2FFx6Wv}W?mp4+7o{xC{b-1&%ec_iGmL%L& z)G&JzKvTKFdi0pWE>YOEid&<&i=!B*5u--ofxJh93nS%>EoGuSb2zTi)SpL++9+wK zvrYh$6~33>7LrLNne=94ur=fa0L^LKusK90y%`;B5BUc`ds;Va579|)MhD1{=fGNp z$bOg#4N_fdu&flDdvme=>cvKOxp<{=a)?k{C0)bzc*WDfvrQO%Q;Jht8_j|#{G8$z z!)Us=r`7je`JL}LE1@G3FtE8k17x~uc-Ql795A3OSEhd+k8B;F|LRR3(Kkp zLE~Gsc+7awD2Dm@utztu)bJdWBZc4PPz@f@`Ieo(PQmnHKz3Du98$Xyj9=VQ!)n)p z@!hRz9u+MUB*5#WZddduS5bp23hTL=nodpa?7GYLw9&CEYUe6y+5Oa&>@3?!IBj|t zI_um!Zyk5u`p&$;<*ZuPcP0*R?Q88k)up~WbyQI&TM^EkU6Y!;W}|5GTAs=4yOT#% z$=U0>vuD?(*LBfBv(wH`U*9`@{dK2rFj%NmAcLu2{IfJn~gLYkNfF8Art_t@|Y3J%{ z*_~Z!3bpVWkNZyi~k7_>K*Zf^ugI7R&?D+3L`rVY^bw`4YRb zb4Cnp)t8E)9g;*_EQU&X*0e#bTfDip&1d9X8(y*1ky=$_=3~@6^DSiwtTIK3w=$-@ zgkn&B(Hbd(BFmGTynIBG@j58Z4YhOHQnz)TS$+OSS0wH&_{1?g?2BFI%j6=XtBkyJ zHhs@+JRx`_OPHQc(sW3WBSliRz5C@{=D8J_fbVZ@n@>@JG4#Ua)4)yHwT}Zi$W7V5 z0y1*5`{=0MUR1JCT(Y^iWUIL3j*-)AzzWr*BT${zCa_o;S|G{tL2qa7_8>8WcwSR5>N}bO4+p+Ld7uifsXUOC;6bQ4`9g()6gU^E z6I@0^t+OHpLr@zjE8-3Wu6PzELL?33B!|fC>Ut=MvE`4UDsemGW6Rjf2B%dpI8JAs zrK$yQ{%-ZwFL?XL5-)8@UXBftGJ~VVZkZ5zD|u8fV~*6Vt9hiUHQZ{D>6a-@Z$0hI z3h>F?x*9z&{2Cyq+VpYf_UC%Z9$a}R$jR-OCp}!tm zR``uE9@MTKqug4bfz0=;wPkZc6yB6~r6kGq}{sQ*=_8onC!B#M`Y^bDtFE_AD&6?p>9%M4*z{h1*Yy z`Kzc>eq&-^b(%LaReH>Ri%MpfpU?QWsH|SQ-m=mLSf20&n^uZLt87}9cUIW3N>W*A z$7&&CwH<2&gw=Pfx8eT%>dktxde(xiT1a-)yak)IknXB^3-)IrU4P!ycc+(d;oi&$ zX6x=vTW(ozZ#rD?ntRjbrk3r^yTgHC-FRPgyNAa|-7W$hnNK71NbYvctsK6o4nn*Q~moinVg~jg;MVRvHU+TnvLY)Z($n0ySr25|4HWZVWZh>x9U61`tJYK z!!X>f|Bu+&*#G}7^N&`cz5n@K{vTmuH_ZC~HtNlAPz>ZF0n56_sQsr5@uIzi6F36UK4XFrg^8`CU?>#c^c;@YQ}QX6 z2HGYNsA_>svV!z79KBVK2Bqg->qLcyZ)3D)iy6pvE5!h}tLw8&!4&Eh zLZ-zA&@Y`l+}&05^X3hZ(;14sxNdJuEo*dV?V2o%>Efj#SBq~s!ttym9c4@eqT;)<}pR)62#z_9h6InFlih9Q)s7ih^ zLFEmWv+5a|4Ke0DocIPEuiZKw${6E8whjJem#K~Z;tUe4UR_N;ThPuVKCz9Gio&*f z?09V4`my5|#wV8nm(~tKjv8+j``HQhY+XLSaOdj;_10lnY&PNR$B4-hICa|Eb$xT` zP3a@iDI~#)Mu$o!>&<#7qlDyB-W8^}!QK})ds+Q5+J`5C_kt1ig!o<*%-cjgLtXUA zzfQg{>xkXVfn?d)O7??9YF8s&_52H|WZjfi2yk(GA;6t>#T4%dzrsIiPM|3IVqzX? z9@U9%l#OW=sqjuHMqkF#dH914U#4(pU z|5V@E-D%|TpLSXs{r{g&|IaJO{{Z0E|8G?K8rN2?>{{dC{IY6Z~@RZ0U@Y{p$ z54+zTJpC4-+o3#y`0K1v=6)EZ7gU7URyd9S`Okk!_|DNJWym>-bgmKSV2OQoA!LAQ z3&is2%Y*L@%O5M^qy7Zz;LX4A6M2JnH~sJ6hQ5R-@t)}I=Civ1;ySbuL4mEoC^`sDX?`T*$LOp{4y?E$+?^Ab=nXcS@6 z6i#T0$BswS95ofK}-M z@Bzw@@h(yR4uzp)0%s=9n&p={jxSLqqbh?_DoCLm5T$ajDKNQ}Kl2uZk*w39g^2_8 zjuI$e59r@XoehX-7IYZ*G?q#wN;rU{wPz5c{xiZ(a;xzu<`C;G1e=X6FcLjgYeuQ2 z(Riq~znAOP6xI9qJH+2D^Sgn+JM>%04EVW;pTh=yr;33n-MJJF)4&Cpny`;ZX<$+6 zT}+3RaF<|ydI1;j@=F+$GO2dTo+iNN*Hxjqui=MsxI?o31~-6*EKuIT7ZVw#onPKy z4dSY>9^9Ycd|ELOsTfmKjW@*)%k5g&Trb zT7`2n;nNYQHo-X~F!sW~ry+ zn3{!2OkG;^p~EMyxTF!FiF_288l0Sac7?2yLXN-~n-;b}SqIvU(3QCL;}5yq6ObB9 zDjQTjolNOWpua=;cSHW&lK%G?JmS**(*$ z`I6hde5JMQzdmRDw`RMMkN?)HZ{)xK`uJ}}hGQ!QfJ3QrgU-7V9XF!mMs!>zI{r6C zdsBhTp2P79M+|d{eJiTjjk;VMJZ`nPajS=nE2%ddZ`e4YUvbPYJNR2s_%|#8$({gk z-iU2MP+t_YEoiiyZmbt5oNT9;qR_CQ(EH{+m`QJO_FE_+$!q}S@Y$xu|-QkZpWZ7OI%`vxrO9E$RH>% zu?e<7CYvgQ9qbaC{@lob-&pVCwz#GN|5jmQ+yEbJKo87H}y&TXm3wEOTSsPMi ztl%3N<7HRhC#|p-7(3s!EvYlK?Um>;wpZ|}o}L;D`>b`9U@LoVu;#JV|KwQc(mG$z zfl{#0u||0zNLzK;74oL}S?(lk0{P99f36BEAGbv|#@K(m-bp{_?Pl{Q^(Q0NK7Dc2 zJvu&keu6JEK@fTpo>5A}lOn?=wtR&+%wflqq(UHuZBL?voCun}`gnL?1YWA?BrLlk{9cl$=|w>eEp`T@bM@n-s6Y*`$fKX);{-^4&R$A z_?K+vTw^n~j(S1cK3h4HVA`70wa|NrIaTGBjdk)Y%oy6|jPgmMS{r+-)M85Inn+Zd z+7N?(w-!+)oB3rFcQX__izq(JkPPgTGdo#UwomK$0~FRyd6uu(1#Sx211L)jQC-R& z_7eH34E>6yW>a9VfUC`p(Ou0k7PjLI_3bZ==%gwD9ZLn3HQcy0^0p>)ZLkP&qzqvQaHGM%cZXhLPL9>D{h?MnQ zUyzcPxmJ+T{Fz;k?KQkZ7W;*id>$cdIfRI^#|6al{ZPJxMJ^yK+5U@S+*0-LrX>XmJ8?*t}C>LUrE zL0Qz85yFLiXpY&WS4+HdU>TKR!J$&-&8q0r!N-Nlx($Ol-gR_Da=)zHD$hKP6Vjw} zVR`wOB~JIMSHzMdi?L9&|8rM3thl4F7n~ysSjZ`=FR+Ywx|CE1KG9|Wji?a!6 zbP28DDbpJjt`)^vvRNJ$uvmw04xZsFH1*!n@1*CG1T{Q*pk_(L$S5Bh_1)fn$p$Sc zXL8|Df{TG0wC|^!FVwCO{Z>49v{ZF_6Q%81>RQs*<~6m8I^U^e;(1u_1P)`c77;F; zeAE~D9H?Q7)TU?8hPVA#c81^*3(;-d&+sOf25evd!`(FO~ ze>VU9Ht+wR*Z(uz*=c+HKR56Hf42AkV4(+S*Z_ts8jEiy^JI7)jipZC%@#g-)TzqM zV~{eVRGjqAFQZdmW&(+HF(SRWfY@8On<7bEPeFayyKG&t7$3y*AHYD2u#>35VtQv|I^-T8{;+ zWQI>$PQF)1M<<7G%Sn7zoeTyQ&dLG$0{PL&|LpJxYCXslfDGN|_ws2Ot#ZcEMO+bGardrJKeMgPXSZ^4Re^G| zWnbOEl*zcTlIw0!a`o@ZPDqD>X_ZO^nfFRTb{qo`PJRr&989Zs>zpb_Gi+725$wbs zMEHiE&=s;a3cl<&s@vr+$qm#h2p>aql?#4d!9SLKV}VxKC_@`6)i24l_E&b&bnKgS zwH?l>YM#bX(BgmN)6N$Lp8xfWr}zZ+pEPj?Pm`>u7r)aqsf`LU{r&av+t*L^3c+YT zKSAcZ9c*hrjeQLly6e(O%5|w=g+>9Bkbj!fqgbzg8HHAWSo#{NuX3^cn)h4PnHw!R zcu}3ZTZVt}46Nw4O5O5I138(l;jn6&R98(3T|!weRiTT7ZCRw>pdvT%QN{9bDIV^L zSIp~N^x7R@(t(RgX9Dhf;7ir3hVpqvqUdsw&Zl^($NieKpg zT15$MZ^C5M9}JTiC4UM?bs5}+c3VpXx4Z33zy4}{r+ZE%m4X3PpW<<*T9nyVee+!nUAA@FyO^8T%#Y&Do7i8Wi4UC7T-IvS zF5U8$+j6;gZqn?J*K76z=gL^t6WLDPjUBfee7J@S&r@#$qvcaCY3r)nzN#CNi7P&QTRBFo|}7#e5>Lck6PB=@gkly5E^&>sbFb zDb`lqUW=v6KeH|3?ee)ZOdj->O3}54Jk>Z3LOd~gy`Xm78>L+X7xAlWETTKHt$8V+ z;1=4$Qoyp9f?L`3gJ;ml8XM;AWUCt4R;994uu{A7YW_82nPaV4;0+&C?bS}7;7bU! zU;|}(m?6D)v#VLw1=mRCd{&Jx``gnN8kQ9XVWhxBe$Cl~-R#<4-29?pUC^UkoA+*Z zL9gAw2R!kaHaBi#7SvVk%z}<6=hhh2UD=1IE*dU#SIgVjET9{;neXLa^Ol?XvR+(K zhSZ*Cf&VvN)&*1YYtHJ=H(u5S?V*#oYyFq4b022!Tjx4meC1kC$%}7ZJL5VRuwCw! z^)-dJu-X5to5$SEWA5fLcm2oQ|3+Y_-wnx$?DoAVPBw;97Qtx& zev=2iNugdnvw*Jfx{xg3+Nf7PFsN`56qK;MTs=@w1_`S4yYPRVKMMX+YlHvvd(Hpn z#eZrvcXmAZPrDob|MT$wC9##~)SKeF;iR8LXX1O{k0L}8|M~*H{CzTw$ERt(Hc8H& zKuIioOMLa#&H3uB+v2OYZilblx)r{9>$dpntp$8FB;x;WjkVsoE^DnCa&zu_>sGky zty=?G-CBdWF6OLhyDnv}mvh!M$V-^(rJOYqS;Sl~GLuC1iBBKAbQWU8ZSm5?B@Vk? zM6+3ZG39MIO(q|PeU6@h3kg^%;3;Rx6&nYouv3P;bJ2@1n!#uoosO=M7_QZeDT7gv zf1Y?+ll8nB1Izphj=676p3!|sSYGoafvk|C74iFG0u?4EFo!6obEpbYytcIZ;j2`f zT&3R=p$cq<`KXVTYbpk?-|WlTWgPuTdlD&a!!8?d%LWN{{YmloL93UN5JVgl@;H21*SveiIl*IWHNBG168(}`vSDUoe<~t49 z8@OoQTg_Z(hEV2WtC0f{ybbm)-!iRAW#Up_SecskDH; zg;07EbkYT_*VJ!@NLo+>>d&xT;3T@u1@f1&@=%#xXU1gCbE959XsPGju4i zn>z+oSRmYwP-RH>z$spKaM*#A3QVBF9>f18Vy(%#=Ufy$j@7wFW@z28T3<>*l$(H7sQ| z;(azRx>GI1_~W@+x8XJ%xYt_1A($o5@@Gy-*KPi;zP- zWYvNVcW5IZGV0-P2X`o6uB4ts>leHzh)T;scx9Gm#$C|{1u-wOle)zyTlo0CCP3oq zqQ6H%zcFy)UrX{u#VqN8HnQ(V_T9+7*Oq;K!9B3PnFEBa*VF>^&TLSIipxwDqjoM3 zPJVaMB>s3F&C^*Q1S`B+V&IEaXx72FH+&HlwG}QRN+m!(P#E603n3JIJ84eg|V{ z&;5euIfp;a=j1FbeN2+tTzr{?2)%*f;J-W{hV3#6K(uG6=Refn6JY92zeOfs;#WjB zbrfG%;K>saw&_r`=r$d?vIP$DP!W#|afi0rd>Q(>)%53Rl5ciHQhwBm7Bu@lWEsGJ zit>LhrnNDVwP`h()&NGJ*Q!TOE2xk3C$+-Y$(CwL)L-05t2OGtaGyN0v)X3Ln6eWWhFiQuj*1?6e*L|0bAAgiEp%Op<_E zM)^l60G13sg~|=ySC6QHyzFb6Gc;1SYX*hYyMY;!ypyyMXozEme>NK^_Ts0y`qYwN;GgnKoe&Y{ zPOc{75}rg7P;tN@mTYeZ0{vHT_|fx1G(bI-V{?XB1?dcN-;$Q1*O9fh)rYW66&y$d zH-nsswGA&2bP-O^q_Leml9$D~YbFPIk$^&V6y;=s2EBAWLsfcc-J7g&g4~+Q67JAr?TT^QNjEfHV##HzTBWG`JZ^!Qw! zXVlkA1ry|~9mUEh*NlK#99V|tUiZFSr*YN^dQp@cZh~GM<(8Y!(Ftvtpcbs27de@X zraAsF`7zGmhaz|fo*#@9iol*~J&h-qtQglXZ2WMhRu+up1?0{yhPvJ*jv7CjS@RO5 zS))xCL6nAfNAHP70MrsY&1@h{q7w%(FMH#D5dTEG6-qzCwQ03@K_07%_FqF5 zfjxhk1Xz#|0HJJHQ1+QDZ00mu{L!AXPUMk7Uz}ryglay+MQ;9ZvDqiPI_#`7T^)+{ zX>MsVyh=K{#=?d7m_@=lZ>{e(rcE}@ckCjv&$W(SxxWmSu>GdPHui7;^gY{-jv!uK zNI|Zl0GdE$zg)}AnWs0OncD1rHHUb1!^)JlNolz$9h1`bZcH^%W`ojMwWCj;dVuRt zxpU9}=m9e=;#}^aq-J1EE4bgZznmR7F{i%NQ*piAJnyNUR}lM-?|d%%9KZgNq4#;C zV4siN!&jb*-tFEf+U~g{JWu7(p65Wsg@5Ct0Et*ffxQoF+qo_4ISni==nW4Ai<0kb zu#$_82rJ7U=pi(kN?#99q_-x*3Jh1 zYoq_&=zll*-;MrvqyH_?|K1Qes~E;=A$rw~AghR(D1@l8Qx%|FrhcYk!&%yt$0?Lbh zSzB`Ohz&qzJ;9+sYS8T|mK$ytjrS%9Mw<8i?#0V;R6VVr-E345UyJf-r6T?&@W&qg zuvPFkMZO_-CsLQJgnYx&Qx12?m?BvA_eJP8fmV@cecen-#^=o>*uHP(tH;+Zu$@!z zH~J&fBedi6i7ygp5-zfsGd`Q}3VIPS;qAwwh5kNU(&*oK_`8@i=o1qZA;6hln!wA?9A-r6+w`(Nj#h$6=!a zpO2my6iv+Ub`t~{_b2wS={|e)kC$cZpNvf4aqEM7vQ?ovTpuHL%%S8}KGVIVqItwY0ftkVes(O9P! zriL}T;j5(ptOEXHw2CZPg}VfEEj8E`@SpJvVeATW(+fV4y9POg2+Nt#UP){9s@cf( zN>)L%{N4DuBE1Gb@o}J_5-dke+e4LDDuc~599uYp`Ud-sN{KPmb&k{HZX>Q035UZ&eB#1hl4VK%*HwVvXZ9Y3ZQfHhRfJmg# zcsRR~-guJ#*2g9`riyGXa;EGN#TnU_j|}io=?0VWGoAj78(^>7?)NY$Tt7EdAG7^F z%O^1JgoT+qaH(^ucV@n&qa%$ZbybZi&%SiQ&z0kfIqw6N*&aJSpVe|c9MeNHURKO< zAjpDtOr|yJ+6_{hy-n#<yyu zL8K9j3aiLaSWtt$A#h2c(2vgbX^z8Fn7t@@e*IXv(wnW31Jr;_E!q%3_YD!^34T_8 z6W7sNsM#O~Yr{Vl_Qr;s!k*~+CSU6lG!pXyd_a3Tm0W|U_CBsb>N2-5gckn#hT6GW zyLie~(_|goF-aC~7`V75YBevV$kSp^n{^YfI83VKr&5rIl0lgQ=hne?#rPa$%jg^b zSt*8hwg1I|F$wTgidBanC0;S~{owVB8ti(F0FCKLZ2O7!E1rrg)5V9@{7phds{~$c$iJBKBGNj^sGU`jLW1{B>ZO(udBJik@ zTLQup_%L_^a%H%{`H<$(kMZUy5UF6UDd=cXIxo#iep3`3-*}{EL4bk+44^>HI-(x) zfeXyj%~64r&_u+FK!GsvVTrG$3@DJWdRruf(ox`p?C~M?m=njImpq00JP_&>C_wiK za^ODBeS@12ce%SO2V)n=N8W%1pgxs?lOxB$n=^t(GTT1|ai^9r^{^^DW5m4dG#P$C zw+JYAiW@Bh{$rTd;kY-sfL+G!{Mbb$%j$h%{=sZ4dB+P1aLngS4&|B2WZ|8$UC$<@ z1!S~vX*Dm^z4T3CoBN(rp%3!3%qeW>Wu{AR(vuPJ?mvX}_xtEv9o8v^6AmMtDH3EE zHai|izER>sv&+QxgrS)|pg0>Gk9#@Q6esm&ANR6_h{d~1qUn@QQp|WTlPcZ`!A~1+ z`NvE{eBmB=$Xi=oHKH3&n{0UoQGyzp`v%l$&8yX=%lgJtfrgZQiF91K;w4Cz_a(s} zTIBst6)w)#;(X*Lj+ZyZHMm4y8FI&x!iAntL7rN4mv_6T^Wg|apW4=7AFj)OS<|k+ zuY!!Qze3K|uFML1iIxi)nZmZbn5S@Rj$p6$uSjf#9TXv3feU9HL<$1}Vz!ioq*w!s zA`3#HzE~&}ikxZ)-sTkt8>3>dqzwaUK~2c$y@5?33kHFC%yF9$G7r9aL1L|E=|X0A z`EFJ2Ys3IOYfdf;=YX2xNtL}P+)*31KwYBCPzwSFv_N4NczCyxTA-Rof`9*Kelg`6 zQtGX(69kq?A;!Il>Z{>W7$b#2Qs7?sFkq#0r4;y<(!QF0LX?^6pQI{KKNO99rIRpF zGC>|mCh!5t1lPimVHg?3nb4>acp~j>tuBbg!JFsZgExl<_<%+}VsJymutBL<%rQy$ zNf8pFB#Cq^li7s#=_JAa;}hHXj7ssvZ`-%;6YDb^IPU_I^qsQmSrbP_dAa*Oe~@^G`MAk%9%6Zkeap%(nu?A%0d(JdR)%ONX;;Ez*-RB@P;H()W5Ib;=nXo&TLC1DIw;GcZ_Y&TEd5!dF0@DYE~$O$UIb@xR&r%eMdD zf#i+-&tEP6cd;FiIG*)a3+oLFbQ8^c6U}=Q&3hBgdlSw3uMy4LAH91u*NEyL(>J2k z`6C7SUYGw%uhI{<2mrVQ|F6B%%=&*ecG{cx&wnoaZ{q)W;arFHql<5eA^3*v+pvAN z$@XpdzW)-w@3z^#92DWoNQ4q6n)s}*UOqi|8$re1VNLicX;=1X8bQy*&8tu>4U~72@-nr+roNv7)+>E%{M#LMjE8?3;gK z3S-Uaocn^nW%Tc=_)@90_w~m;o9*TCIy^qIM(FtDU*8e&kC_Ik1l^uejkFG=!tW;W znfUlv!AJ(RQ;tW`Dg_sl4`{_RdtDX({)q4G(Nz6@{j^jAS{J3#7Ys`00h*DOoZxx@ zDdEIdMHsr_4KuWwQ!+&FP z#n5MCE-N+!Mt-nD%0Pw>@Hw^y2!nn^b`#!!C}@VRN*CkfY@Y>o`V2cwAFASq?QQD) zd);YHwujZum2Glv$zd~i#YsA5VK}wvRJEx5scJ!b+JLi7boYY6n0{bgdjZ*)sKn-; zWm%~*wV=fCOuj#;oI88AwF^Dtf<`|IuGA7HxIoUBkfB6m)O1WuwEMAZVZ2@in zYp{_@f!UjwZyaCp4xz2DhW`NmdQEssBpK6B{Ca|ua<@(;Un@IqTrQJQ-`!}k9$FZ8 zo`tm?+%dJCJ5q+78Fl`3z|o@H=ZQP?H1M zPWcy~98QbvdhQFHMD9Dak`EgC5ULL$mmftkn2O}RGVV`kaF-4l&Wg*^;-hvDfu~s3 z^;VJ(bNAUbNuTnsUp$3VKENqWgxU>!D>&u<{`&Z>x{H?Qt{5n)FEk?Nz}N}$+M|Ic znMHbP0WUv7b;;yM;OGg!Ye=j2pZFjD`A_jRaue2@9WH?{#L@U5IeV!AF4czz4fT)E z`q)zcXyV5j{0Dziqi6^TwbOk$9t@KdL^6s!gG-@emiz-a^|F($x8rYiM3`m5O?KL; z+ZLUH+~!-WcN;B%QxMI*Lch3P1cDMC0HaBSJ{4^`W5q|&Vz&xA;8UABn-jx>V4HZvSEXI0sfu zEj&rrHm{;}mzssQhigJDi84r1G1!1rnD~1pRQ}V+;Ri zatacXpBwl`Xg>3hB9Ht8GT^y5dmYf$QdzJd9uahK1gaFa>U1E?p2G&wx*p5FwnJT9 zerU+Qn>wME`42kr^<#T_YyvI88>eYELX@Y;hc0s%R=EmiZO9@ajn6r-$Z}Zaq@m$4 zrlu1y#I>kAGvPZX;n+O5yIueIRP9iH2u(VS*%$t6%Hx}I%SRV+t*%KRS@w&z~ z3|)9k&B|#nQF&V7a;ov&sohF}##AqNs2AspkGbJROyPJr9O$@G!^%`U`NRWG&RKTU zoNZiObR)}6Np{qHoxkPHHOu=j}xXY<#%g7t6MQrVirwR%mn%BT7H_gMHQ=)^eukNrP)RZ^s?@gU_f|^QgPZ2cf zsud7#!GLo}BUK5X#JZBO&6WIvSsymuqpn2B%y#R_+De<1SVsPU+z~2dm7dRvc?-;~ z(YUTE88EnYGF9|0rfOL3A}VtHQ$W(zaXcN4CTD1$jpxaU9ghWrf6xe((b|^1a$m!ReA_ zLcyALn!!G1+k0ZDkD${o{VI>PO_L4i3y7&imV|)Rn^4MCHnB{Lc^77^Z}q*Q7QMWy zSnxNOl-i9*gCRrF?5c*VObu!xd7_qJDP^W3-PvaJlMl4e!nX7RjLz|i%4V0HJ00;k zwUFfS!hs{S;69+f|Dae66vi$7o0xN!$pa&kmuk*k+64|z1)dcI3krW5UQp+&RP*Jw zefh{}5{=ljYrof;SQ?Wpv?<@JlyZdZ%oW?m60UxFQ+)C4+2Kpae$s1rY1v&?lnX%K z+%ju#=@?w1F3c}kS@o)Oi4O;|X{3EXrwrdzmgBnQtL)bBhNfjlCW`Y^lF{K8Wg&fg z)GXd8v&Llv(TnNqikUDa8VzT7lvpPxE@H&A7id>lGeWG+Mq5k8X2^tH$ee(<&@+p? zLnj&4GMurq8fGBcoa2h*6Zoa*%t(^=Nz~b!9fUX!t zIAW431$p2D$pf;1r0`sy=jx}MAZEc5+Rdrfs z?i9F^MC}+zpudSW9m+Ahcq=OZiE3XVlf7m8X!TixO)RthyH))IaF z)bL)k`f;g9W9fnST;`ia3%N)JMB}@i_ekjf%r6LOBY(zGq1R8X5@F;0p8@wU`~E-d zC6m)p^mF|1cAv)A!~bjSG+P_|zu$NMZw~};3I1Q$+RfpAx9S`F-#?-KM(+q1t0n{2D^+Ji<{kO+7bkBI z-*AbtE-bc0yW-Mhm#B}GAdvs6nz{%&@y57`xDu3(dqvzt$06OkKhm@b4_e}u&}fM{ zPe0|cw%YkbY$V z_dCpC-|=aEn8as0xTs+b!OTZWxl?0BN?vEJwLkcRvQwjyh>1gf*rX>>gDl5ac#VTh{UZFn>-|sIQUkb3xC|q4xvvmqch!0*X&}-Pomy@J# z!QMGhyl6VJvtU!l8cPODQb9=mvL3>t?1~rQ5zlfBgt8di(GO6mi0APsS0ud<)p0@7 z!}c0&F94=2Z2aoPB`nz8Au18SdGWk^`109{gO{jFBzPidb0?5QLh zwvjFor8mH6l){L7oB~&FC@Un&-j8U^FiQ}jhCGVQ`*OBYHmx#)4CR%b1@1zlFR zt4$RN(^NS9R9mU*^0=Rjp%Eyq0n0yU{rTzeOch6MZ#2%g%a$?d7Qq)jA)ojpjcqPW zHB^n^29sbR1kV(>1QDGhN?jxbHU?zG1-M4=XvXJxy>1?hCgTUn4mz_&*lP@QM3`_k zOA{yz+dv2fOhX&#fv^~*ZH_Wt6%uX0LQNII>?XJ$q(5fg#W!CL0?Qmvc58h& zFMg0aFId}_SOC_hFy`bhg(g=7*0wrQ+QS>cqT!%vNI~_KRD_JCaUwFXXlr1=5ht`V zI+_K~>xVoeZplCC%V5uJK7Sbk8ZBk31#q~Gt2wkyFM8R!Xlb83=wq%txuuV9+4ih3 zLCv+_m4$}iaaJN`b7V@9a5pj^sV8!~DNfa}ua>7Jn+qvm7_}qvcsrJWq*>WK_J_h- z-c}MEz0GPVj%{M;!Wvt~<$YYIa4P{9$p$_@#_^QEY%XB%hug$nG9+XQ+@|cs8HF5yU`eH8M*@<8SQtcrqheN&M4%C{aE6>Ct&=QU;gi66Pde^>^m$_w6rgK*m=nk{n^bN*!oZUif$7W>C$hXg2KqG@^qyC6`pi?vn!KR+A$q+1EXVI>rVt#SJGwPTIG*F#vwR+lzc3fQ`uK ztlH;+Rfh%rY$1))EkS3tycV<_MWg}3gA6XNtsYqC@XxNTt+K-0V%Y2;zy;=!t|=D7 zbdKfA9| z%ESJXzeS4$Avf;GvUYvSY;6sVP)1L%LA59@|$x$ePL_xY@oU_@rzF8s!&LAUZ}djx=HB3&78H8Z^sKIgWzXFnVaKM zDkr~_uQ z#gLSa-iy9h?w51uo0a`cX=rwuE2=;@bD0NY4r`J7>~iY}jgTkmW$Ks1dRnNROR+vz z7l+1++ozg_s}^nfMG}Uhj3~_&wrL-*^hjF%iwpQ!p5q3r@K=NSE9xIlrJ02I6<7!; z_vDEP+lZi7|2TmE)aJkt89!n@uuAJFW0i?{b|{8Su^F~CMIdNVa$4MQT8tBIHyM6= z+T8H88A~o{bb}j>H1n-)s#bS2O(a>+?4~=;zD1K6`uyVabgbo_49~h<+|#C-9Z#kC zp6|$>*X{Z8)S0b}wX_faBW>`MYQpl7!R0s@JC(J$vPYeIX9q@_-dcbV($e{?En$Y-0enF#y{bfc>`u|7cuzIG&IR zE+;z`fjqqP>Y#Ikn4?WO_#r~4G%#hCQmnTLo!rFaj!9O}6*9Sn$&V=6e!bA?JD48U zQHDgA2l*AasB%i8l1EC`xpp~ME0+u9Y^kbNKr4*xlR@ENfFI{$Rs3B;xHt)Wtp3A* z8T=AYE{YQ3Tr%KQ`rme=P9hNec*I}o$ORq|`o?Q3>Kx^1)HzQJ^SplX)PVMwERt|% zL6!z*0dWJB7Wlx1x=2(MONoQCHD$JTQ8re3L=rV5+1ZB4adhb!TbOLusT;5s6OJm7 zPR;v7`=g4B#t#v?RXcK&IoEWn=}oq< zpgE#@ItvNnq+E-70EM7wPG1iOU<`9)rt!9?V@M0;rK_hwd6`? z%p8h1nM9+$EZi&w?ER|JLMv_8I=SR!qSHF| zktMGZo%qN;sN_XrMpf@|mAYe=h6aofexBh}a7!uQgrM5Gx1|tdj_9pUH?`f2Ku|8Ew9y`muXM^{qF4&plOW{RB#PK^bo`vyaYF%=!0 zha5%dUsz0o7I4QQ6Sj-!G?vf-#=<7lY!ne{Eg{rwIE31*B0`-dgxW18^laEiYpRO~ zb?wpk%8dSLGV~3rm)4#<3USFia!x|BQvuG0xsU8K5EW{1p;op~tDw;84WnnlYc*{3 zIu^WEr{|{ThN<~H8V$A=Rxh8k?eg{Y%JZx4>b)p707y?wBbufW^l-YY{iojcFDbf4 z)5*zSUDt7}t{v-kafBxqBh(yp3x%iAa^Y#@3Qw8y6NQS*?NKjToS0;e=cn7s52#Gc zx4HiLP)=s48-R?#CkRN9V73tAr=lHLtbg#yBvR%+Ezj+dWgJS#m9nb0rqn!31qxBj=E+r zfzc9vku3jNVD4&>xjR$7Li@v=gWFDgCh(XFKg-#T+Reh7~Hk8KkftEzf zGW#RQ&fM0uB&Hl*jFgSLJR5tifWga754j^=u(YOzI@7Wa%NE<&B}5iOW}eq&t`+7P zYh-LA(^=tJ9 zvVr`mnif*-+ickaCVzB3Hx0fHm+ug`7MowVkI9&pFe8grCiXc{%@<5wf}0h!wvq|pA-LUQT*Q` zBe11Gf3=ZVZDR_yF$LS0f^AH}et#^mzfS01=^S1Z^H(M>4)q&&BK-y?ly6{1@|8dR zVSfwa`4)!qT`@qfCj#$+@V({MR;Qwa^!``zf7A5gZ^0U^hyNQkcXl@TzrWY~-yZVs zD*Qjpdb6I5|J(?h8~*<c$+*E?{JM<0fL_;Vaz6=w|} zJ!+#wQQxIMJ5^cJ8@RZ>jbbH0zS``F|Et^k|ALBQ~Y>}V7d-3ws8_fGyG%FP(A%tX> zVOYA|Z{EE)e*5BOw+qbn;lZ2k(}SllA|Ym!v79pkNO39IKBnG>2E3Za<8Mx$b-S`& z6BQdclXeTeQlq4IP6HzZhj4cCL57FD2tnXxBb6)LC~Ol;Am6-u4mm7I0I!Me$=g@2 zyD;&G<%(d)gUPguw?SFQv0hjP4y<23Q9Q`FT(9_QrXnw!4I_oT_$LNEc`g23varD5 zo|z)f;C(Wu_<5^4JAyEm z5O8AH6CN;Tyokk?^fV|Dtc!!3wVf?EOk-Qb>{Le zM4=LDgEF5eevu64mg=b3s;F-0z6%=`dS8~HOb;Gs$4MotUB$mY;V2a0dJAzwz-Qs2 zJ=^_~pwB<6W;uAl5mk==!TLQQ{8Jd1af|^ZBgDSrl|;RDP@y$Gvm#3e6g17d$W-}) zk+MhtjcpMk^h5@kghrc@O!O*~2SPv>malxfl`n4rjJOG(@E`Ptr~L)3*AR5} zDJ6G-1P_M~Wffq+h7|P^e7BI`yF~l=It))4`j+-NKBFRv9Jz5r==| z{Fmo3hGjKqqVg0a2U-4iO(BV`+HHjrSUCQk5)vLSvkD(di1D68=>`sQIz_NyG*n?L zK{QlJ`Q}-?lc6=ENi?(WYx8B{R)9u)8;xPuq=_d!EI1WfdspFC)7>K3#A@aisbqIQ z;aM{&9=Ts~%i$F+2L(%*CI7P-bA2SZaARmK_1JqyiU)Ytdy4d;siz3Dln;c&UFCwd zeJtKcgfd1j=>x(`N6Sme$V%HJ;`nQ7{M7K`Vjke1{YjjTznbwNb1sUN0lmPu?a@>p z-^BwGnBmkXeFlV0s%Hd|L^js#EHm|mlPXKoY`T1`$o%)S*nX_C?`P>r2*`4#a=Bza zRA8`GP1PJ_RY4_tUC0fkzVY8o@xg;ENBVOS5BkZ^Z^Y6Ypo^@#!xpMa@?+AN~%Uvbga%$UFeQPibhmFbcgu>=WCpr{a;c# z5BcVZTEnw=94E>-8-pSwlW8&}M*H*tG?Ncvjx(!1;dTGFz!9euKF|4W;8;FukXhn`Ku$qvY={1;b?xlRal{=89+ZN_rj9s8E!I!p*@s*VrQ~t^D)?HTSl}|J}jyF^m2C zp1q*`6Bx}wu>wF4H7|G=QV<1vXZaD8UXZQE<9?uHSRvm+j0^&CqiXANl0CTSKuo2S zOX04tPClyc4eB5_!(nr8&~QZWignCMMUMiFO@TE@aXK$1=}d%;4%_cXN$iqtaJe#R z+lC3`m0k!HI^OOz5n){_qN(vrRf%MGD*F;hKAWQbLm;9 z&lS(H;v6OW)={yn7appVvY4ob!K5kD`V6 z#EpZwB;P}ODE)$O?Ta~NIMp7p6y_dyjLV3ZU!WJ6Y@|Lyv$vgR40w@|iou+s`shUh zUr4<%lgtfA?$oo)m|n-p05%F5x1OVpoHado0HeMd7z*5Q(u--u;5TAR2EP#&;+MSc zeL@CJ!imJu=FEDZliCq7SuLsYv%xD@OM@2>G4aIGoipfC+`}hPIuNi61aae@d<20) zg&(SolGD(Bk=M||lFDjLICb!j%<)dBI}M$F9T`9xw;u9sm}PXv?uisfjMxagH2#^-SZ&Mt*G+GfaV(xt|{ zI!qaJ=QT_E)s@P1&mj5>1~#J>HoC_htLU81;?- z|H-JRt!-rcjM9rlW_`O0*HNfCs(Blz+u9R`-84+EJ7C|xdhu+pAWa2jFf67!oVgu{ zys9&du-6+7kE--11r^GW1^(1`3scq17d19RX7#o@FAD`rQ6=hSv9uM?h;^Hw){t|p zSkjYRB(Q{>CV!r_v2a+{o2lP*w1zR$(uESNExnprD(Yp-CH0s%7JZW|#rQ=Wjiu_1U;L$1insP@Oso|%!BMKU zt&un%_WNjMVZ~$NR5R0|WGwu1xtp8IU8M}pzrQ~gU)1;IE0$5n`tsHH9gU@>(J07G zsZs?+E#2Nm-VRwp)s?T6&`4vaUOclr0xPTBz%I5R@E3VR%(b3cUc}Qb;AovgEu)q$ zFC1Mu^cJYP>~)Bms=#v$W}9~W>gDtNg=1SO%(D7Dd##(uLh!qqIe~evLH#p)nTS%B zJp2ENdbo3#9k!o?GD}C;&kw3fxCa{U+~l7s+!4m3%d0h9G?IZmjJHnEeOqv^=wLaQ zDdgqh)@Q2-0}t2WRhL@_DTR;ho$Exs*W$?t9UhS2)I*?B@SCDqk{%Y*eS>W-+1XBsrJD!$?v&khqQ zq_9}mTY*-#S=XyI<-;(7Tm2%IdQ>EO5%)k|9i|udBd?#Uk}3foW7RQ_WNu++=&)o9 zqrK&eSN5%LnFy>72k7Ii35;gh;OT*Lxm=f?G~(H_LPi#HJ6gr zyncZAfDY4@BgCs6BAjPIU$}U=oL37R%+lkEQR6K+(;qZmUhla$iOL|{|BPZC(XY_J zFZ;#1suf%8Y^CJ^=UJa&#c>gtkn>uOktf1pt&!Edm$?SN^fcHcD$Sbx#nV5dg2au7 zu6HJ^b6ti7r>~R207JQ23IXM4!TG!7KIsIhF&S4>+URE^Yc+_k^)qy~#Y+7;N$jV8 zde$TB$q3ODCFbKLA>y8%LIMYc&)RJb(cyy-)O7F_ylKC~T_Jr#(}~$(l313CM)*xs z@Oc4eUpnl^%HL3K*Ha9noaQB9cQEA+fdO#E9Cw~VJ5k=f%ZFU+-*oKnLfxCv()rof zBHM0XS47#|>)Afsb==Bu7aV@m?UL`C{>)!176rX7TgGJ77J;3+Wa$R>Tl3lb+3Jqy4ZxTK`&QqknJ~? zqtR|Hs37AUQ(S>$&T}1q$sI3T!G%*pKD?fBsxWglnh%Az*Vw6^56{k3P+TFL7|hLH z_(+HSRST@5gE8+jrAZ&*sI>o|RaW?-LmE9`PIGIDdLv!EGP@6-}PYs+?v++117b%_r* zBQ~2esQc=szR66<0NpfQt(|qh7DsaSA}o@PBTB9aW&-Yqy#m-%$Cs zO?%amg4&jhRN)HVU2C8+(Y==qRA=3RdbD_;yk|>&!Qr9@Dc9<%`hK3Up31BY5L#BtZxCVf)L&A>3lev4abneOaP%GlwF1Z z!_zwq!UG>3nsvYtk--Q9bmT~RN>;@SYEZ?x1bynMl0b+z9Kuw^N|Q#R2(n|vL1CW} zay>fL2+iy#i!`La{J|R)|0EN~)`R3Q)=~L|2GZ&;YwCZ8I_Nd@4P0b*?JE zU?}s(ZEfCYh(stRjz*Q5IC}ktl`EOXM8H6!dtMS}>?EBAsKf)bR3hRZ=%LbV7NX^evDPsZ=HxU z>G@a+3tX{^v82!mQ-Ls&jP!!c5z201zHTT=B<##!`r2E`hc@0%#qi$SEriy_>* zjcJ$I;7QZTkEiZLT9a8r2>REjkz#!(9W-Jx{eIvEp4aQZ?I(f#|VUMOoi zKMda&=~jT@Cq2cIyz;qXwan&Gi4FAE)R{=%jipVO3KqGVAR|tUmP7Bu9)WM@2B{Ym zy+Q5k$7Q35$x_J>+0XmgdfRFIo}jTE<+8x?N?56AqkyrrgHW2`d~a8D(|1~ZpMP-3md6|6O1gSFX!b^L|aa-`+;z_vs(>j;}7>c zW2Gpps(n=TaGRC=&uhG%F*9~JMD-ZDzp@o_wy-j#TVTK|i)35AlEwDIvRW^i)8UY+ z#)h^kktJ#J4@ztTy;%;9a@Tm$(GfLaKu(K zCb@>Uk!(sln$bUzXW+q5USRv`hAf**?gFyBF=YmH&DEK6ctsQSMUK?e{jCtY%$LD* zs;w&~+A2^Df~v^pjBExA_wYn)%V|*Q`q^NzpV{wL$%jR7M^+xEz?X&SK^eRwI8WgA z#40sS=&PFnn)3wjy1xmXS?obJtE4PCqsilt3=eciZC6D-Qbp_sF*zBha>mqBjB#bg z_#FB-O^(OUSw42mrd5SzVXs`%6#25@P6+x(J30Il>d&KBo`a|GTg<9HDt>=KxWutY z=kmq!c172X$f_MfWyXbq=*wFWMD5f2Gf1N9o7wy>K?YnY5>Xvrk0p=DE4?6pPPsQH z$mTp6D#o0|JaO4CT&sw#q=-}R4Eni0S4!u$P+~r_yt|5Mh#WJ_;z~m8YI!Z0w&XMN zP*H>`Xl3~h_z+<)iwkj6dVFAg? zexAZOYwiANE&1OajFmJP?6Whr9d=}E{F(tmc=V_ROhH>aP)yLKm*wd*+=e~Un$eW3 zXugjQn&ToZ!;@kdOlxE6dE~>?ODV^0xR8=^bw_5={yun>HS=o1%D$&)R&!)X5wf;A zblpp(5Na@UFA)h4C|JXO^kLRZCqFPAP2H-OdtqxnmU7MI)o0wgjm|cI?m|bqr z--DCy0yk_IM>fwz^P-4d3a}5&HRUQNP-@`IE*U4YH@TP&HKgL0c(-8TyRvE!K2w|` zo_kc+-^ev75Rr*JMI0o2Y3eTtx^)tB+%mbwivQj*6-e`hqc;cN9R_8JD&$%%h)O;t zSx^IM1e=y>%bps(j3M*Uf`8BAk2B1KO0S>+|2i8@PDg?5dj%ii2zEc&KlXxB?fB@M z<{o4mB+*42+#3KtZ8sO#?FdpYqV&h0{;? zOTo#zZ{7v>(hU6|fJ{eNH%SZ7o~K7I>d>G!htInw`S!rI+1PR`F9XpEP&vV8H0p*@ z*(oYXlp_)@A|eF`>9xyk3ZYFGaO`rEAUA(*s?RgHq}4(KI(kj%cdbmDr1NUNGlOYG z+~xJB@=7df!K_`dEvWR16larHf~q(>2!AUDeOTwic`yTJ8tHA9^SLUp zphmNwDbEPnl*BMjYH30D>31JLwS4&(?l z^awOOBT!gam&^}AOZ9io-1Uq^N zc05B+SXh_L55dkghhV3g=Tve-&|W?S?c5OT`YEd+XzL+pdxoH}ur8S&g7!6sKo?y! z1iQ=eifYCs`<3_RWpiczH}=fgn(lq2wsiJWAZ;7(?Oi6Et9UT-lT-wawE(0s9hgq;gA zQ5JeoD{mkS26@szJoZ%V7Guv(_K z7syp=SIP!aRI7Zj?5|aCe^I@PqPJ!l*5jF7_uzKw4y?)tiz+{II=*Jt(^abPFX_G8 z{TmGc|AsZ*Sv(+1h9om4gBy$q|ArQ|mW zFcnT*DO=6nf^j0tEqAQeZCStI@Nx%-8nS47axLj!W0WpeXp5q|c#nAo=7vLqzrq!E z+VY|Djn&|0V}-xM6*k@SkvsB?T>pk6ce&EYEuYq-{In7_-1UcTl{uv<7B!2oRCA4L z+!7O!Yf58jTN+klZqf?*Vc7^ldlVCgO|x}@hbp@&hZ$JWP0G!|G*As&Ss5?xiZ?Mi zpZN6g$1CgOg+(Z%lV>%Z=Q%+sPf=&-s5hb8P;m)gJPzr_BL;!Pc^bh-rVQ*ld*Ieq9#}6GcbG5 zq@vjKMfu%O=01Bw$-);k61ivyM$y$|4%bvEXw+e_;UkBVoklo4*n%p;yPOTj(MX`y zH++Ql3DSK>2`AAmIVeGD$Cuhxsk^?^9hKVlrM6V+jxV*TQd_>%hDvSvQbU#6@TJyO zYUoJ?nGRCw-jq%$5RbemyO7fHrnDht*PF6qtnb?13@wvk$D5&PGPJxIFm5&ukRvT3 zf|MwK2=VbBm>snLZe;U}CYO+<&RGafAIB<*3rYoiD)h&_r0Eo#zJy$4)laABKQ2Y%2xN1D|qKO z7nS|gZ+*@D-lO;ahV|Z`y+9l8ga0G_;9quf!Jd~rtN7pk3!eKM{A#{~E$B^CIA^Bx z&L;a`6}fJi7kpXa(wBO~y|~L)FWEOuCuurF_vt7b+&QgD9a{D=6A29P(b&49t9;4A zA6FbU!0{%QuEeUn_;M%rDz#UC2To0Hb@w}TU7i%~_hwZcH12oc5#>4Me&4C8W6u2! zjHo;%-S4|qb;$Dff}tZF*+c1uZiY{Z$@nCwHkhQJ>X$OLLEQw@%7!gZ!cJ8m5N-nU z(qY?^uv^s!l$+40>I2SAcvRH~r0KSPH7{^7W_vx>d;*(vIZ1H7j}J&oTU^e5-VYlA zu%@qFFLA4=dfyMFRe?NZ)aQo$eBgd=%Fk*Bh`~>g!^dvDvHYoNmBXU`P&evMlqPZ- z+1@DavZl2Zj94K1-dWD40cJ5O5mR8VfHbLbWj0pjN@-wa;#ozlLtZLsWmcuE9VxBO zN)@;&S%X&buTfEdNssbf zTF|MH(!6~iuG7~gz4df=P}tp((nzk=g#O|tJUhydLVv+1q}LjSg%fdNJSF7H(TK20WPr^6X?CiFQpZd$b#MLrO<eh%*R77$3EiZ;HdAF71jO?MV=;Y|xp?}ga0VeH$ za_C8`mDDF+Ax_y=i-D)GD-~2VT>vt5VY$BPe)F%lhbLI@=$j_@aEQkF8clX#k;CRT z7rd+XLpO=WXK~Fl(k*+WqyC3z+#~S+mZuYFpu4S`1WXKn@=%RE^Ctm*^0VZs@vzPR znWr@gsa(Ven z;l2vo-4T!w?B7qGtcQ(lE|A+t0gY3zXz)!NQS9B;HLEe-F+>*amcYAB8cX-dx-D$; zve>bk*fvxi^$K>w*;JJ8H98fmp*e+tl<_MMTNc5>odEQj;X-;!0YUUwJ>p$nuu_Z% zue!m>IV4b?71#0qoP1XQ&qiyf+1U7h{w4fBCoB1XZoEA=-kuw8&yBa|#@lnbx94P` zwGK*gPj$Zr9Y%i>bIiq};u;6J)`I#&E!f-s8 zP`BC4yDohVTIgROEWb;9&BPF*Su1xu2`n{Y%j-8P#WD2cgs~XMmo%p((#ifzJwf}Q zF3Z(4IWR9j&4;+C;3T6Lmj&K`avx9~XE0^wF^mItNe#$C*Ev~wfFpt)jkSedX11!< z>w~40!MOE@vr>t>rp#fb0vd9j;G+g54io!jP0}Ci6b?6=B4B&-3YNk;nHq6k7Wz`zFtRREtgbh$Q>m=WqQtTIBN?$ z1~Z+VT~6ezrJgw{niVrGgBwkYaf=LBXeUiedh7F|XJt?@D@S@(`Zt`Fbj4Yb&;EGI zxNC8(9mUHGj#ufCG{cyWc)}8{_ynymkgGc#j#;+5z$5NdnjT04N8Zrlu4fU@v#G4{ zW{aSI-C-%o`uA3M?#eKNzp<}Zn5%H1>sRQwerflphQ~JxWBcL%tjpV6-K*8<*f!Vm z9v7;LJvM59p}r!uMZ2|qN~St9WQ929MS_xWP3|7My&UGmawofSd)cPHzCs6berAnj zerDHenC;0@U+Q<(@EAGhS-(jm`bCY%*`g=cHb!@agQYg-8M$Ch)A9v2iC9%3rN(R9*^DHfUYjq#WjgY|2+KD1W65%1eQ5QC@6LPA0|LKAVh(wLLc332Xan zvJ;l}))`~-ZO5Q^8;K02>K9gUFKml)TCb>YXyJ?x`!s##j337MQ&2Op7ev zb*5Ia0en?iZqsEp<>hUeZwE#8+ly_QwS~0%bhB9DVGO3Tr5Y>QPiISoE16SgOVyXE zSMsH{7uI$3x~SBmex1~dN;Ow9C(f2yG+*C`MWuFDvV_i-T4X(cbkGgEvc6ow-DL&q z1qC~c3)Ty3e6*}!QH@@+`6Y@pa}#*1wqIqewo#)-3bin!P%A=gQx@E5JPYumog{s{ zsA|0_^1O7_QkqUFveahdDZV1*f@1Yp%V_A(DEFl9+G3HqEv1L^9)C2x`gh`XK;x74Z#NmhTww&L-0X?A-EC>NW{Q6 z6!Ca|f$AnT>c>1YjXE(6sJI*sw79^pO)1A?syPKPe;e~-^a*^v8YUowUBrmfh0s-_ zA>>2wBSP)tP>0M%QgKcj;L!g#oT^J4wf6b2h|KU^)70GTNQd1dqjGaTa9YUX*dpuh zSB`bJH0&NliwwJ8t!vl~>vqnD-2>aOn?E)Li}8Pj2KhRT^Rnj(N* zf^W2XBx`ENbbxq+r}U8}1APDL#WRNLpd61hyn44k8OPUI1L_R%FN1swR9$TF?~QaiAod>HYSoPy z*F7@3tZ&~Vv)4K{`8tWT)r$YRO2ptU>ac$?+Q{S7+PqiRGqyFvOj8YiewBh1OaLt%6)f7nn`h zqH({Q4&3^vU3BUgTWz|kax#cti+im~X))hpCR9}#`YH_}tgwlem= z%@%yx*#G`X?0>hmpThr29Bo*woSYSKqaHSdI2g~)C*v#eJVC>rT>P-S;qZ2&UT=CV zhTn34a<;XbC-P-A>Lrtu%uUcfuC_55-k1z;Oolfm!)u!i-@484a4<$UTWK@=7I>D! zx7}~Ew#52-wgBXelLXf3o!4kx8RPbW^{v*lbMW?u3GArR6>H0`==}@+=*2M2?^4PO zxrXC(7DxTs9mTIGPvFsTJpWj_t4V(yr56v=vmvCVWYZjvoG{VJEWSv)-Ad^p2DBF^ z^HbD>fLK5;vT`4PKy?M|$!*?peYQ){R7*HWYAkeUbPSB%Yy?5*NqWg?4S%V2D+rph zrC*q)zM974Z%&?JW3B!Y#ouzR!AwlRE#GeCinm+Y1{W26 z<*EFYQ+cLtvK0TqiPw$Uu*W1UKg7wExJ)MSYkQmH%X1qwcB58?E0Z#XLFaqiBX&I2s2kpe98A!`&%PU1-=3O=Keql8S-Xz&C5 zL>*=A>B;jKU!@o{7iD+kjpB>bQH++kKh1{;nO#IPd{erZk7mOu`a@ia7Kr*}E61Dw z%nchkk7D=((lg;rAG%Fo6G9z_1lw(uzf7i@8>zr}kNFU^Wojld(2LCdT-}%#BQpbUvQyB^iqz z7K*hzdeQi+87%N|e-zUmt=0UEQQ#}0Tz2NHBEJ4wv?_MTIWN{%#*LIt#AI9{s%nqb zYBl(JN$xYf`3RqsU>T<9Izw&wVqqI3wqaP9<49r`?kwsD{@2)P787AA;qHPgl1g*8 zxFSiV^QbTjO`Q;rnu~KZL|A`BtBLGtWLP?si1?MWit0N-D1(jvx3zEp>B)@8s2LWw z{m9N&4;Kuk$+%O0v|vO{zE)#FK8s#!!LU5D=`EOS(+il0cJ@j!K4qG~hdRDy>R+L_ zXBrVfnu*XCL7J&JYKVJn^Q$TDnZb=(;$Fw{{)%?Qy+`)%wzwD8?GL-~A+$cspk}l4 zXHc^l!dU}Lo1aZAYks!qQQ0E3gHNmGC)VAvlCf&jtyu?#!}NLf2!8HZfeR6EB?$a? z^j&qw@q6Ov(*1H0q}CTQ9s#j%Za%SxPrq+{LdTpm8JQ2qFM`pK4;S>x|H5tn-_dRx z`nfjrGi~U58qv?UqMvDo2>RF%A1?)*n8hm`ABg@avOc(21EOj36)qS{t%I6Vf10c<2&Xrp^9o3iCE%~kw9*1 zcDmg;BsCk|nd;ZRm1ZZUl%|A{YY!(^*lrb8sFO^Es`nm1kCHA-_E1FfbSQo)F)w!X z;?2oh+#KSus8{7jGmp2vWX0^o|by}E(w0b+--s;t`AbauhU8B}a@0Zo;DjXc) z?2}p|`>v35_|La*4!TcY9Kn(~Jbrd!wtb>t_D0c}eY(15Xh}X7h-XNXb+g3%N%NUh ztgRL+aB8<({q*?N$-6gjIb^s#xKUoeI)3r;kmOa-s5^(?LztGDbK_=d`IpOr8g?3L zsV!@UH5oXJxjV`#|MKANi|-Fn%Nz;pYAK&xij+3&(x= zeabJtXtEtPJ@3Etj)kjk1O2pl$KAZ+Zr*YK(9lm=JSXQvw@0Sjg!5z)(peuaSq1*& z#IDE9)MLNJQx01%b>UYcfkOc~#L2j)fM^(J26}WJrLYfTTKWXK!x~uIBmb+^@}b3+ zf0zvWV#}$$j7O!|l0LNBC=VTKwqp3RQbPGsc~`g^0uU^$BqqK^WIs45Tm^idI-ju} z6kSyoauSh#Z!(8JL7Lsiy~>2)CpK&QNkq;dSOy8hXX*mwL}eFeqCXO>WcvwK_4sjC z7t0Q-zep>jt+MP!MUiDfiLMR*qofCqMTE(NIsRCaG{Ff?rAj)4|e{ z0S(3$G%4_njGpS?lWGEK-LSHs#n*}k%w)ww8b1@^6mGxXdA5BRh>5yPfA!GX!F@y8 zD+OxGtR-n$XML?~m8l4%mbc_O;=1v_(K`vTwJJKK75zk)25`P)mT(dE&hb*{$5TA3@tj2O$7Irr8Mp;bdeSKZ zCpk~eT?4tgSQg5a>7K$PUZ3zd&MTjml#!9i9*gY|`zf_lnKYZCK9J}mLAXHUFErfy>I)Zy zkLIF;|A%$tgW5qW7-<7Q-1jBgmhm$@FzAuY9KgyV5?o06W{}%3lo-b>3=rzuWE`tt zm4bK=c?l)5S&s?Rr-Ifza^I}9{M?I>I-2N?5+hX3uDOcZhSnl=3#!Y#WG*AVq)&$x zVO6M)Ok8s+{(-v?9p0)c?#HwS?A2Z3VKLjJYPSYN*s*2-usb0?EixFI1I?FH zOL((oL$Z+@{s6HmohWSFDJT^|iI0c}#kle;O=Gs+JW23ka2#lJo#CUB@~Bt>c6SET zI~CPj%kx{G6AlKKq|Jwxd_~avOCHa3J%@^9TOxzP5fUdKr1YZOMuHInscV2EpO1e;bpdb# zljKVE&AgIGI#l-$?f2p_pAm9H@jjyMBR3205!@Q$)4p!ML#8{OB{))?RB`K|A+v84 zTui*INSsh>P6|_6won(aBWyVLias^vi8tmaOq>0O)>KTR7dKNVv5*ITD(6U;$ahz(VO2 zq}GNO{_6W;2%?V}O!%D>-{c*mr{#y?doA<;8|oK!ibN8gNFV{VQ@2HvSZT$57l;*w z?0=qKV+lP(aPiRde5NC*~-EbeCyDp+2;_|4I2i743K@rTKe@(SVeMUi&JgVpz=v+&FM&;q8Q zLKLdPxh$%3+^gn%o5K;(?MJi7$H)C*##&=flZH&|!W=diSzF{m94(nWdI-SCf4B-C zZ_Dqm+-6u#=>^=W7n2VH*@UY2vi|R}81-u-_>Dl#__acxCiIP97wO|25DfRko#c)v z%L*$Mi^(&RUdc#$lHY>?5oL=R*-|Yue4V^iw(!Ik@lcL%pB^wG(DfdLf<0Z&k@{Z0v!E%R4LOBbvmJSKANn-7|Y^6D>;TYpSw3o zO?KHVtv6JRKi)lx)vw4~M9ZV!96Uoq0lt^VPP>a50XbFs@tXKp4`aA1VBL=TLz?m3 zD%v2|cr9|)@I77hsd(~4gzbI(y`jF}2SNk*&m=XOdKlH2`hPB_QI2j4GeNsEWOw9e zLlv)mi_b6;roA1o(0uHC)r$bq^uPT={r_zK`{Ta<-=+ij;`jf0v)yQC{lDAwjsN#w z(Eq#83Sg->H?GT#6~M*{U}FWau>$z>d2=hX*^?^}$}T`oLA~#==bm>f8PEFaM{l8= z9Y68A`oEkJx;K}wEYh!Gaehdq;6?VzcB(QQmq~W!2O_l1mz6E-Z5tjhH!sfH<)ZFD zYpPjA8#cE2ISU68Hr`1b3!gB?lI9|_;W7w(zXNuVm;Xb#LH~?%-$+I9rY!{ z)?JIILqZN)cU_*&wCK+f)Kg;MyT+Zw@K}KP(*{S1Z#mhu{Qzb}Rl4)BD*mo?)r5+D zFR6m>&OXw4fV^55ln7>$1f1Tc7-u8akc&POwGIv)(;MCA)eM=Xh-MDnShH7%+#&eqYr(Ali+%uk`Q za#|Yh%Zaftwy1F|OU(EWM907hnp{i;oZ<=12@llg=|?TySg41U+neB0qj0`$$ymOZ%6 zOA+=5=K>MgQFqVt!YXt8uN3qyrfL>;8HYWIXZ+6P7HZ}4o?+mMSpx>8gzE}2mSJ`9 z+J~AircppKuEref3Ns>_doHKm5%N<=*|`mSB}rnByZeT8@|jVG6}jD#nDFY`E(TN0 ze1n#6hYCDCA(UJ+9>|_xwe8F~w^986arOV>;UsPR0sKE(&E1Xv=kGTEpVj}f(b(D9 z$@zb7ptew3IXDMu&8jD0lKMmCky7~dc+ zp$aI*2b(e6#tkNo@gNh(nvsQ~h~~t6h_N6+=D3rA+Hb}L@G|DyTr}=WV|b2C7Ph6F zYSo3Nf-R<#Oy+0j0@-r5bi05W`yfeWYy&;?CfHi7R6t@8SsH$bl3`>AlFL`Uo$RWk zGezt2%jk+n=8a`($9tGM4MHHCJRPeeYy%|eF|Jb5gmxZHl9I8rl61~MoFvP0G?kQ8 zxWD8~kg&nO@`05m+jxDcp_Z~V)`Hz|%z1gmWe2?7UvqOisw(C(ovmEE+*J}0*XrDs58TxUT`<4e`q~T(i4nWvmr2$ zlw5TqgsdFk*&0`MZK^fWi2zSlvjW*Sf<~O~(GkD(8OkF55RYlyva~x)V3ow9eyW^) zRMW;05R68eiZp!2S1!_$J%9e@@cF@8iR&gGpJ^v!2(7p`ijvs%YaT`8vw3tDi*wk7 zQr=hIT^z#N$dBn&`ayaSl(#CP(7}tnvqa9tOMlP0b~!#-LOXNioXq6=ooNSpMdbbQ zwu}7nWcQZ1Y9;;lU5o|FyDBzYvOJGF)wsx{yeA5UWAaJ9c!cO=RRuP_a!&yl> z3}3)%l`Dnf^=^+~_D5_CYpFMAoh9UP;!tHWiZm=x-qn$U?j>%nC7T2Z%JQGfH5(Md zTrVDV!8@_0bC$+T>}%+%<#edr2H9@WbvjgOcJT+ISrPZe|7{ky6kf+0A03f^lT8P< z(u$6oiPf!nst$kIK|NQbn2eGH4^A}Pn9QU0RIHK+jN>~DPXMGiMWIf%g; zz2Jk?wba%wTd8};>a$v$5Bq%;JcK))b;?)^20+?r-@h;NMQFu85uJ=Rd&VQaaviV$ z=`WJS4Dfi3a9!GM#|A<8VfcRE@Y7C=S=WWKsb^b+xOKH@wH)PApq#vw6OwcxW~XgkzGAlu#a5^C zs=Sm5{a)S5%&<5&a#RY)1&!n@{2PZO+h`g*g?Atv7j-$Vc9H{n5Sc}JtB41}KptoZ z;MI`;)&@He2JK+Y>ek0O5EjtEHTt$b%7L(84hkyt_RKga;eQM*pqHs~9dZ1WeMGMd zn!qdXaduU%*JlDvusp~OT!OzlmcO+*_{?eYNnN@0!gBP|z9iwAi7?*u(-%juzutU* zaQyC&uL0sH_*Kea-JD)224BhnK8GLHmmDxHcJ`usm*gLL5|oUCaGJgQh&{^q^XGWR zYQ}*-=eY0p+!u<|WdTK9i7y6tcg~QG#$7YJ`DRfzRZQ$?1YP6fZPHPMWs{(M=Bd)jAD&wQ($CLa|;>YbNW)zyDYF! z5@gASE=fncTNI>^MP*yMEFG0@*=A#5*^VxYaORn^?N(7)b0MfRSe-n|U;926tP0Q4 zb7_5&*fKe!h9P-^%JpFRgW4z!FwvZi)sJL9OFDAH;<3btfjMBhUq=b_8h?Pu(F10R z&i;v28u-+~kQN*hHs7Ib@^D5Odf1bPXUUe(&*RY)_OZFhv?!7)XG9+|1B)$7-0Sl+ z@y=8pvJUWGZm@G4+3LHfqVd~%03_@dm=nVRJGQ`pT@li7AyjwkwL3?{o<*9 zOeFO%Lw)4Neuer5nKO=APgwA=Hv4f zfiht30=R_}r5My!VJ${WGW3rJEu8u)E(H=&#;!zhQA|0^%JEs7;yXXpDkJhjUSt1Ob4Lnf?Eu z4@%CWogUuINExFDelo}PHFj{rBs_y2m!w^C@d)J7$N~~jiyDx>6$A!&g1)wp5`BfT z7M=voMFNE=2^N}yZO~Ri3O$1w@Om=EAQL_Vb7ckOcFu7@qV1$j<`ZS{r;U#??>fdp zT|*LFQb*(z)6X5f0_bO3uMhgUOUMuO+gWH~c0f^At4FhnF+h6f=wX4+Q$w?Z<|~J?>=OP=F3T?6RPNa%U#4le zh%vCP6=#u~$t8{^Q!>Pc5$unZohIQLg*t%c^7c-h4LJG%aMYn}SrEmi*? zH0(ll+7`Y1(_o^L&!SANx*2gh8#y9<2WOvjM{0n8zc@z|M9{@KT4KAoIL8jk{|j@p z#rDqP9J^w>y*NilZ14K)8@&AgZGt~8<^Nl|Vc5*@|6#k;-thl_zW5Kcc7XGj{C-%> z?sJZMC&SnWCaEoskTur~cg^n4CC$JeuHp8oXr zetbHN#h(tEu?9oiu3#hhguPG87I=v&f2Vk2H`#EXr1 zu@NuU7B6mHy0{5!rt@t$;e3*pc=PJr%V*tpugf1`LskSjiLpm=rTn2H9*8o0l-|Mr zx2%3tO!@C#yaWd1;OYM|=Ox+}tHa#+o9Eq=V_1yhkxqGb_|3cL-D6lS$1qTJLv1kX zUzYKu0^d`U_^cxS4MW-OM(IVj>-zZgFWFV7D!%;kj<`$N#hqgvQklr0s}Ls{XShK+ zyDZbUs^C0DbwEa!c$KTn)KRgU-(R))eNXdOXnKFuruSECx~2`c=lrZZ`Y@`BkF{E@ zf(Ps`iCtu|;|1$_JGvy!8&S@tXF7_oq+vl)LO@wt0_Dyg(Vls9CR^j3{?%^7oPXZ~r z718NUPUnrPXwe1Hf$NSeAP_l2xohHOl0fz;UN#DG3}5mHaEvZyhX1=FvuQ5IbkHDT zk?pi}TZU1A;SY13$_CO)q0Xr6j~|PMKf5FSc#1Wb7i)TowU!rad5Y~UFSg?;)?Qw$ z?J2gqyx4BG7z})8d9luZ271EHNqHz_H|D9L@f5+;0?XqpNSJblYymFx91$I04_=Oe zbLa!R$t;ZoXq3h*+8LdA7iMx^(aUKm_(6Pcy}_sAJz4C%Mo-b!R(bs3QKcd@00QIR zy~HfA_c`bGP9v+l*Ew5A|7iG;O+Pg8?N+C-NK<8L6=rFuEcL=Hq0G{37iOtb+t7GI zTtvx_uod6C{c7aMzj>`{&b?Q_@%dpmnWvDdc}O;s8lc`y8#ZCp8M73|Lnf@$KIv4@ zS}ucaM!+qssAJo~vv?d6iZGlvgV7`+dmV%8nZ#r~qj_CVOVZJV4v?47n4{NzwC8j( zibq$Hk+rL}?X!vsLy^|B*8Ne_HaYcJ6thjHLo4Z$2Rv}_xQE9h8UKrZ>Sq|vV8 zpF8v?pT6*qX3Z+zZWR^RW-`+V#-}RC(niWX6G9@H!1X(xU!2BhZK|`Ehc%cFsPzHV z&jt*QCj7fqp?aMrdxvF^w2o0C+@U|)$2=~{?y)Lw+FVe6M-{2*)nW7dGS?2L?zlASGPTXAElFeNP02;pg`_uf)Y@-ojK(p>uR?ny z+IFUYG{G#lPC!_dya55j*>flxU9smNon_4-oyl`XPOUeDbf$Auqxk0Le;l(kdm7s) z-U#oGXq+nhTXMuYpI}d75ad>bpUH^QF(acyj@o;5v?P|_xf21iiOq}(4++tk42ra@Uje{xHN~BOxRS5Xp zokq=u#FPdleoY#Ojs3nzD)PzQh6-CoL1T7ng6Mv#J`;Xdwiz~($mqqmn8Rh zyH#z}%$?^x6KQH|0p#+&O8<}nZ{EKq9`sNmb|JIIqf}u?HH~Z}H-ErJiWU=ck;->pN`0tsH;R045axviS)vc|4Q zwuzvU`A&E~zkUVZ58qHLcx^UeZ6Z_|?tIy*FXy;hY0=9iX*XCk3f)qu(fg})$t}IC zOYN4oOZ3@-nxjVIdY1Q?L6t+;YfOBAc+U8b`=~Seo4}x@4Xeq7hFQ>LPFtnPN5`)Y z-m0cCR$_~f(6fo+!+<<-UaEOT<6owexRRZN8;-TwpG0yybC$Vi;H!5*VvE-ISWjj* z2KmiaWnY72ThOWg%sal!je^W=U*={(=G{!@PYWjU*{gTo93S4^BJ)pjyH#d>uYw%e zqFG*Zd9E?b);u@ddETKxvnJV@x&G3bbEc!e-gIQ_8#1$V{OaX%cZQD9P{Zb(U6{6< zETVL2vZYchXX97velOZ)3USwaIH;HYzz@+bTh3qy29pxjSNzi)0|Q`VTHaVp7>PBI zSftFk)QahJyd-9qlMD&y@i7mBrD`lvQIeCEK>o&I1z0~CuzC;^za|x&yWSL^WWjf4 z2KE8;dz+aj2gtsxidJ<=Iq+4?U9ne^R+h z^?%aL8PIz0K;erLoy^Y<>bHU#{Vw_uwh!vJL9*))`xualxcd2&9cOyU@Dz1mK>gYw~-Z1IJGnze|7|M;0l3?}Zbt#Oe`dm23<(A} zP!ONtB8}y#zWzlckMp1~;084yiaid5yvP;{L4 zXWW)D+=kkjGB7$uXX3zEZA(~>6=FLvD_1kucdw)%jW1(X^ju65R{!f??ncJ#MQ;wi zuvqR(D^JL9td<`>R1pn-+$>;T9+k2Zks*<5BU28{kc2wwt@+zJK-N z*`DXSls)nZY5_~03@gI=QyZ$O>L*qhdQv z%)VB+%~Cv8aU>kWANEXHjaQN_OzKX{3pg6e@)2{CjwEBDQO#$ibe<Wx za5+hSWHntDUOqP+*%x!OY%19m;}3;|=eR#2lS(OC09@Kvi)MZn6^GK9vi50uJn#K@ zCFU?53Q$?Dfcbd%(>zx8cbE7gr2-yI<}wDsBq4tNRV>VD4sf&_(${q^Dn>yS6?GWfe4;Npkv}+5CQL>_h@$IkDu+!N zq3*?5=zCPxW37RI{N=n#7c~EitES|^82%zo!V>_=96D9I@g_hHMM$zj7U+$ZfB*1R zph6K8)??AX(J}Ff?s~^jLW3gVGaoRA+mmE_M6rw!Ug$%d@Nuc5mu+wBo7H~9RgYWp zRY&d^wFL%4#vr)hH>-#^Fk@b2u=Euf2S=sG4TO%2Mppun>Syx#5-noW3%$uumerOH zlZ)w)!f;Ju3bowFw=!5EsoBc$$7$S~dHFx(&Ob!Gk|nTZV*ONw^PH6r{bNP*F;VaA zLrn$j0UB_m{Lpw$OtyweKruj`OHvXb1!d~kpGnwr&+8ZKCuSE@Elpx zwXxB`Aur#7e<*-+PkmpQU`*#XG(2V>|;#DSRzPMkW5}3;m|Pp`-ia-w8tuFlX|VozSDW0<8TUo z%NIER6I#I=Siu|CN{>zNmcK#ikg|(3ZLUa&z8-nK# z=eld==1)#a_40zlZd%ZMiv!rHD9iG1Z|pipJIok^Jth2UNE46>c3Qn$70Te3IRx161pVwX9A|+w0&_%z> z^qr$JUA?NJoa{~aSZ;&m%3N31PbMB(6_K=7&<0x%7J@By)+?XW@INDgop{hF6Oz4; zI(N7j+~BZF=-VzydrLAjmu1j1HRCvu9C}jEMRwZut=t$%7P4g3W-5!cIFJ;fKvl`F z-eAn@bbDu6uiDEp>@Lfo&mXu59d!eAp@FK7Qh>iE1JoEGn&TUCk48w*;owT0;S$sl z&u;=W_MEYS%Pki4mjHDii>8NBEEoV;qOod;T~#7FUx_|DuP@ zg&Iu0*Xww%W1JT$FPfR&6JPf6_O|AJe`V#T?}@~U$sC!GxUW0`B5-!Loq6WC;~X zZ(KXlG3hvPft)7M7*3s;^)d*eQGev9sSyY3_0#PnMxW>p`b9{;8hWsztmvopk8u7`QL!*Vo%(+I!I9i_VIATL0K@NA<85#zdhXPls@rG{b5` zQ`r|6QTih~QhyMnN497*m_{p#!g{^YAsXoN-l&(ccm;?^8stqf9Yv?{$R^Na0?qd6 zPIE8_C4q_9?q~wkihX)$)mYsyN;Z`iQ>phF^|1b^t($?ZU>XfM7&g4HoD7T3jvCZn zy{8BD!@l42WXH<0OPHjH*Fc1SUGnqPAKcDU*=tTXVCAlfBwJ6|DN5k zK7JYIz78qtmnkaGJZV_Mo0wjWd-m_~WcpkFlt1?5UxYbOc5vY;eB8i*H$!u9VLmuc zVDJ%HrjJ%l6-~oLb1g(@yU{Mbm2F(OkDJy$?kw8Jx3rOOZ6|xSa=p<5LZ>ZBD8=iE z_A-*Hn;wyKpnz20KCXwYu+!k#xtOI>oQ!%ER&QO+4!u$GhwLVX*=_W!*^RL;kh5xz z6yI@T)9GCEJh5p!y43?^c8+jT+0$h8gMt>W@E`wt_>Xe!XavaB z5gCI;sF15*G;W|6H&Bd!G$=-e!$`nOf7noyZw`SHbm;Bj({EqCI)3&1U#kEwQlHii zF6jYYL_+HYmn;BYG%fmkz>6+?J7SzW(2ES6o=wA%5}H{o8%wIzm9G7uC$HxDMTvJSpGeB5qTpTd$qsh%7l#`tUg`{Z>McEg*0 zb)Ua^j6oyeL{F|LY8ObH9B2$gN95I6UP+o&_#=e6pB}vkLv$kM1dLS$sWPFl$J2O% zPL(z~&BQ!|>pmm?7!Kt>;7W+bGbel=Z>edMScO4 z_|(KeZXF`6n}t#u4lM1YeQleEF;Sx#YaUJHH{Ca~<={H`;irO{0DN{rcVD~~b%wBv z`LLL}P1*PI66>*o)}6=Jy2%7k zMSae8v#mP7%auO1>ek0leQa4D8|q`n`q<>249EPgW}{n?7utkuR3=J_wk)lwAC~zh zI;`PRi8vxAenQwQWAI{kVTTtruGe^0_Z|Y!Do%v0B5kZq@wP7BXo%wCkO-yic$s7@ zD_73Fd;P019|b@yETrQP!pgx_TVP3rMqJdI4>W za_bQ9pN?G8=S8F;X8~chgvk&l+hm(G8kq)PqG@rKGG#5GO-3>q(xXv^?j_MZ&JiAs z77RtZl_8s6q_c*1;ylwDR!JFc*GA}5? z;J=R_uT)rX;5L)FYH|ZELta4CmD99(5e4`QZeL$-3Re=fYK7i3J-umBZ}^( zN-T?~Vcg$S=D_;C#r;ShclKy={Oxa1Bu-Czy?#HAC9A0V#siffjd0E34%Z#-@Vdht z`iHx{!f>}e!@Wzx-M)?CZu4+Q(dnt+!5$2*cO?A<=Vy0?`Puc%Plx7b_crEd7v~3O zr`HoaJ7;H~>5%;kPH1O^3AK1PrU_Hoxs9pp>8qKr3zlOcHyo8qV& zEn*&xW8QV#qjj`NWE77Lsd%)q+(h@-)VfEX@{!b4jryKf3)u+wyh_LhHYl$QW3hTZ zbASOH2yL8V676&2Bw0kI_JX}d`V-Ws>5pNR^(W59MwRs^&PPjYrq!r)bV*gr>8NO? z1SzGgu^=^#Zz+41XGZaZr-Zd;8#jA|_35Esa@?A^*Emi_g1+^mV6t_-&UK z0SJ-@&rhm>MZ7>fEj-^7@isbxY;+x9w$RS@eVpKv8a_p&z2Q*Y z`FH(}oqjMs(=VQoX+DZi!$wC@k(r(%PWyolU2_!mW|IU*NamJtG-U2)XnW$xtsB^| zbH6zN@}v31*v`>YIiCHa`}F9b+m8p`-XL-t7&|}f)@zF#@;w~Iqi2Vi*}yL_8wZr6 zEd%cg_$gsQ)1v_sHP9Ws{}%3??j#2lbDgW?)KkoAJFF=Kw7abE9e&R_NBsWxM)a zDjn>zdOT?$^6n2wvksf|y+g2JEt~C~Yj>)#Ejwou==)bqS3in87Kz)v=CvEplnrQD z=Cf92tw_Y1+y*3uE*G7K5Hr8CPjaAocV_Rh}Sg+R`*ak1xhF!eV z^sT$wTC)IiK#ae?!SZa#<=ME6<>{^xnBq0)@S`5|J{q@ z;}=g~Jv&4y@4f*-!9C1-PcaO^U()6*aP7uO(^AFZ!$7s9Z((gv;IVn3(K3Vn_VAx? z@9EJK_b}NRz2kc*H8~aLbwR=P?9c*_9a^9@K*#r_Xv3eC0*F61Hb!W_rx99^GeQd- zBQ&0*raO1a1}(_hpauIzl`E;aO0*!@w@l7*7H79)Zg!jYX2Ak`v%q6-7X0Dt&7!r; z%>tjfS>Q7_3w-8g!5_ffEXbIf;iAi!mZ^NUT^VQdn~>2;$k>lze!r=hIRSqgJF&pE z6T^nsCSmzOXw*56Jp$LV`@(f~F-aL%5>MOFmBgcvYZ7*l4D2h{@$o%nbG6h+%w#1a zvEzHiMq*CZr8Z(FH`|CA%BKq`W8UQ^Vluxp5i^v}izrjhBvx;qO!xoQr=pXI&8m3`Zv5jfi=b4_}H7vudVjIh_Kj?gR z)-ViHBsYd(e=@@`YvKy+!UAO%1|o@L{Kaxh-tsGO%w?cd*2YT;JXr&;V2Od(@x7zN z@RsenltxYzYUGOSzp~oD>YKMOzdtyB{QS*Qt1ziKRZpv^>TBdozi!X+YXx;*!>{h+ z)s$5`-Hy3e;4}9MeCA$(&)h5Un|lQrbFW~zxfg1fjK!B{1$&okM)jf$zN|Hz(ZlfJ z=3CQj?dJm@AF;Es|NFh>AMH8z(O-s)>SyRt>L3b9q~Md#w78T_}`d<;jxJ+?xxpIHc$fF z_qRk<_N8~ozVwd!q1z*^QU1GR3NV3!Qh$r;ON^2zEh@U-!+^jnV~m!AK0X)d2*+In zvgXK%tVkq1FuqNE`{LQN!^dN?kZAv} z{&D!`_0x7shFUiCyW}X)ZizC|-^U^{>~JPudX;{#GZDb`UHP|0yv7d0;f+c*aS`>- z(aN_UPf-LM&nRFFX$>i^NG5W%ZwR137s&t#QMN-<(@5m|Ce{8-+gjC5Zh%6qrlBzmjf$8S=Fu;*zB=&C}@(j z+BLm(2&wQ3Xl{)!^lYf^Zl<{JOac!ij-eSsXJnj-b|cceLHj7Y?PE`@LKwa=j$aoB z>+M^(x({DIgR8sSHSrtqP}0YdJRxkmVPrbdm0+Ty4a1><)Il^F#e>=QH0t-&NyOU< zZ}D+<+9>il_SKFAtb*sM!Bj!??2d~E6o`?^RrxO+MvmrB-P6HZz3Jq7Bl7)uh%f8R z%g5#%QisXt%2Yw+mse9XWPvj@9Hw~1!Rh1&C*X0>@v^g&ECTL`e!`1yt(bLiAr{1} z(=0+RW}U@FsH;+6nd%?cie0w~+hF=(F;B7!6lD*s&Z{Og3JR@U!2%}2A}X1Ql_^Sg z<9FBp8Mgno)&JGojdoW5*J|x<^nZU&{hwJjE9n8RqYu1>Uho?F!5iuc7gO4(4L54T zjoNUdHvChl4de0rLRcybbcwt;1!k9ZU1&^*>j~t)_+tcXo}?lrP;(hbJDZS~VzSHM zbJA__ScKy1uSK~TZezeZEcp)A7AQEO)R@ye=sFx)u)w~>Q5H76dZn7pcl25w%T~U| zqkO)0>zfyEPcr#BkWY1v+$@=+?OWir^A*Cb;$44?D`a+S{Q>us7@&8^m#mjTS@la zkpPVl=c?1VJ3*j_)sv;DW44B;a1e<`_9xYuYe{}Q7frBMEvYc>OU7PHl4}jWQ%cRi z>g6&D`KqH7l0zTZ-wHadz1OiR3x^to?QuF=X`SdH^e+`|o)GzovQ`UJv@zNGT=G9@ z@O!r;8W+p|?GVAC!(cOU%vZJiGWsm z$4Ni(q%XEv!Z+3x?Td_c6Ftkpwz{U3lPj4iQzvNxfM4#5vQ~Kfs&yYu^TS4`Qc>^e znCdd<02PiWQdno3VW=Ik7&$?W)jM55ZtkP>a7MG8Ot1bnetDH%L zDI`Y#7MGmR!bwB|(x!vyWh>Kfg3bcb^za;D_#xXoL54VLzq& z%X7O52((-K>y6~%x=iVU`d|#*b?O}@U_9-Sw?}>9P%W&UEm*Ai;YL`1Uiabjz0IwMmc7jo120?U6e1$Ggr&1pZ@X+Jn$oC0i^^w=_e zagtdn+eNOXE6)PAyd1x*Rgg=h$a2M~pXDHK569LpMx)+*#2h5D!P-yE zkH-3Ij=E!z0@w%MDlI|PsIn6cFi9L8x;rw6AX-VFJ}QpCO2zRTV-XUi7w}~kUrZ4$ zQ0u3;C67h9As+Z{xr*4Ljzi1Ktd{XL04_fRLgG~nbAeHPaaIiFj+oIXnJ_TO64A~%iTET@ApTY6#gAoBX^=z6n_f_E&W7!BT z)8;?2FVQHS6qiNN(BUjs-MDYtOPN3}&IBlT(Ag_<4$81Pa2P~K@ruZzZQFik?;D(gA~SqwHl z$OdQ-I)uWw2}mBn)Jm3)T=+n&3V$?cdXLEzl%+oUfR?ca42)L5RrULkgLQeKXTjj|c1?hcr@T?1rvvcXdDUig`kNYK0 z)$)qG`Kb9xw_AIjloKmuwSg?|0AI3uu6^Q-jHZL@TTDY)W#E@Fm)2usTk>XEHR=kE z0JCby9@-Xuzo2QJf3)y{lyGw7Kn0&vW!8oL;K6>;kULLeYtHlcuUSM`JWUpl12Hy6b&hL2ENnCbE5?duQPMPWrtDT zq4`m~#X9t5$uo0cZ&2Lpn30|_EvcKFThI+h zE)!UHnDWaQ4>sKIkAlwPQ|hym~0l*+fm9du-Ddjj!;;cXuUyMVhkQX`J1cC7E(C!gm5%BfU7m=NJ?A zU>d=lL+j`?X1-&9$W~MidpMN6=RZ(og_!zmDuZGu8uB-*Nvl$Yf9zC~HrmQ_1f^uR znsn&zKS(N#>AFJ82b=zjFbBYldin6-)_=5;{D!?lK-}=X+?A3w?gD88(fdUOM2T)Nl z4csAp{R;Nc;hWs{g0FkNok-zp^E=V=nIYP}xjml=E8d$~pS6b{;zSN8EAdi?(~(Hk zgocE#UZ@PI%KdGP{e++4hO;yt4Fs(fi$@yH%<|7KR=q4W%L*SkV9&|no42A|uV}uT zxX$cVYqYN}muwrrDNjH5utvMIe7TIpn<|=HO-1#(rh0yz(vhuGsv>>l3l%@HsE>}~ z>1cuCNiwgxeiOUJt|T)c1vimXv0G-lpiE8$wla^DtQl5arHSpqHL6NYH&3N{l0pKcTWm>B(}9=ISpcVVG&8oBlWS+I$uk_`dDd}OAgcZ z>VNlF^d`^P9BN&5kr?gM-77m>f-uE5`ebq;CKN5BPf<0L5P`!yjxR~VXO){RS6ZD_ zn}|(w_cH>9Y8DIa_JQH!JFSC{$x%NjyY8QP$g^MkjK*NWJ7B@3Dyw?_^y$jgtwop^ z;Vf0}yJhC_MZ4=Qc-mZ{YKsS7sTCH>etT`x_dzj`fPAcBGy#4Naw8s5L*?Q%A%wKC zH!uJ*d^4J$i@SA#P`u3umEG~!I!*L*g)}4jDm6TFO&g#vol$f}j`uR$7e@F>oe*C% z5JJ5dC?H1KU9O9Ciw=R{*Wi43hAg+t$`A#=u49AntEyB77CVKe_Rf)GmUns33VxMF zR@@JD$D^KT{R+Q+Aini{@=f?$?LJXpgC2w{DZG&k=PT$wBQ0P87 zPdXxLZUc`V1fAQi#<}IiAlx2wM0qmBQ64mIO*T(C4ynZV(JuWfBVBeKK13~J8|9KjnIN6vzXmpnpePpmgNmbF~5w_ zig2DJD0_G}!S=(TKTo7B-I|pOTJ-J`E1?WgXuDz#tFkA|qvf{hL_mSXH}esl~pn!@-RW7%xd-;C~vXI#m_K_Y#u6;hFbK79NEC=7enQDNH#nYLLB zb_PM?D`rZu>aS#NbQnYw;cz;49)4i-Nz!|v;`o)+RdEFzH4BoC+Eg~j)S)M63=19C z{a3n+R+Uq8`lu=mF;$XC(ZKI}>@)nsuRM_GukP$(YQ6TkYh7X_eAu^EzFPWn;meO{ zc0-buS9X78H<;RCbg)nlQ0VB+JaULt9js@ArK2`f zt%ppXM#G@P^ntN>QG1{^N2nZCW)4D}&*E^qNVh3G)-nDGR13S-hg@goM}gExD`T3o zyD{sL`&V{=fo!cpMf}aw*%N!FP8*~mL(k-~mX}(#W~g8w8~YBB4PCXd(bqt>1kVTF zQt~Njq@P4>6-v46c=uGYlXhQ#C@TfL{bgmH{;XBfS~m;J@kO;Li_?ZDkIne?wBY{? zP2(x7i3^lP!$@W&6ulNWeWkZdV#Ed-y9$ylDwOl0>q^60X2CyrfGekH(D_z17*s_M z%IcBz<>XS!7e=U%jpTh?`=D>@NYk}m5v_|n^Ok6(@Qb4IsNjc1{Y$?uR&|wyZ;i^l z^Lj6hc3ZvgjdDm}k?`H9DfDeXrv)#QxwB&(yu-!MmFD)~p7T)kD?ilV@0YwUg+;2o zZ4pWp|1at(VCDBFlBX9u8lw8dr;ZKmqlmwJQk8G%6g*z-TT*7Q4l(`cU~V4Ikc98| zZ%CXPN9U|NP+R6Ipsna3xKgW@k@-~0yo{R0*~eA!4Pq-bG=5g$L$=fAE#2nz7S>;3 zQDx?R$voxX|JR?K;&*ZXqzv|NGACwO5Zka!2V-UV@Pzui=b`2I7&T^a@W7^rb?A5M zdoarw0Fb6^GMGsg7L~?iC~2GRpk1-0Gy{RiPM5=AUbE1qGiwy^99sjeg9~#wir9(d zK)*ju2BIO!I2FtHVndg03p~aJEviA$hzB!zxOR;jbOYT7?v_Vf3iSGL?pgSswIbZ4 zq5Qg*okB&eA>7WnlEu~v!OF%80Wl`SA#vQ$N+8<8zmcB^xSQ%}J9|FQhm{|O!}t3# z$CiDtKt3}Vfn4r--P6m74?4=4nk(;@D#8CeJ}GYP>aDyxtJdl0WN2$oa!AYMz57Xxa&GCR{GvEb>P zyi(zuN)mihCm|0j)=h+S30sM$#aN_24yV-4@oYGfIx(^+%$3t;$Tj9ms0p*zxjSJx zWi+BKke{+oH?d6d__!>w!QomwI|@rXOr0km0{2rzi}7erB++@grMdrOQFz0#77`qPC%Qf6f_}SsR;`xr0Mcu zxVg2Bw&N-6$PlaL2JBtu1kK)GM$P7OYMBeh$yRJrV_VI*Y9!=T_|XQTrIWdBcUSXi zkQORj+^m+`@9X7yzskM~aF(F0?Fgj%VM+o%S)-pzB{+!ir+ftF%*jP`mc$C0ozy;7 zfdOJh5D)0V(=X$h{O#ltRco#%UP&>L!*MT(u^Nn&3+FCoC3WZ$1|QyVD!5Iafp&Z1pbgN4)_<`T%Ou_^t;_Cz36tK0qEHXJbwAk zum^lcz4~Q+|BkrR@0||tN4S4STRrT-|J_OMh%z+?F0&zU4D^9pOJ6V#d%fJDO|wQt z;!b)s?&04<{)ent)~l_T zh(# z%etz}=Da!h?)58kg0bzPT8K_$4gD2*gf@xuvGY~$F-X(@F0f97E_@TEQf!h6e7PQB zH+-1ZjdV^(qp(-uG^U0{6^23ORz-$fm#_-joakcdZ_`nR(ME{C)A+{fPp5~dCCI$pbpyS0POYW_YhmLgyIfe-G zT@M)&2DQyYR^-el67$%Y2f-+*G0#T8q1RB$uv{MV`hod~JXZDFBS$xy3}!Th566=+ zyD-y=Nmg>KOq`cal-SVWMj~avn)xcVBAYndM;(4D3Y2vMmMm9xUa)jZ_lKxo!t-}x z)lf6ho;0T;-D~HgnX6AH?``CdjOQ!Q3+l9>F-$7!25!Htn^DQ3yBHv!FRtU%?Y>JJ zg^jwZ@k~=s+v79izzv_B$M>N!3W2TV`rVeS{h0I8RrB{eiB9dy$pGOQxs|MXGdGDE zq|0;S>yhz<22^B+3SD}2{XY!fJJ0RXu`9az|Ji%fhBl6DVR*huzoKJ5aU>9my0su6 z&J4lea0eT|U?($AZXR7BwLoJbY1EQ2naTa_?^$Z^YAt}bj64$?s%t%U>eQ*TlG6ij zIYl2qEel**!Z3oPx(F9o6(sDgUco8NyOg{8=~HI#223XO2Hni2vmuNN2+JcIfjb1f zZYNSlLvL2$jgcbZ6ehcn^wF%F6gDUY>7ZzYnh`sKRF~SrK*A2ZXygY1+WFlaJ)V#{ zBZ>riAFlwKs1 zG^~9=j?wUD6pEjJ7pamo^sL6oRJKT_TF(iM%#a6JVMSKhvU|;#9A`x8Gh~H;TGf;; z4GL5zbC(vmOIyV>#RmqrJ?S}e2Wm0tmkBHa~dRHT@E}Mxd?J&)OLf_r=(f^fbHU@a0WDLOVJMPPhTwG>p zO_jRU2k=V;@XLt>giHO~is#1Y0^qn=Tjm%EWk42G;Zt^Uy9LY7TDmfnqm>6$HEVqi zFPEbnx+esH>PaJ>fkt!CM`|N7QLFLcp%6V76ry`T0ktGqP{{hG-J$OW2z?Unuy*SV zq?YSnr_?)=+boCWGNK+_V75VJDf-$FJ>2vMgP=Vg#{g~gmZoumkRY+?6ZbqC#*zc% zfHzIop!2TCVso~4#uVMn9pGk#pUSXcz^IHqT{?rfGrArR;`eTZ2g}|jnf0egk6o>O zG6R0I&1{s=#pCNksN(s@MrndcSm+qXwhqx4@kHCzH`!YN9O6pu_&tx}{fm|mm>iDfm zzZFdRYEfj-mU%+k;@`BiRr|SPu=Uhq=L*fFM;M@&;-DHKQt?S}J)%hE;?e&@+-c7Q zU!xxXX8Kku!c{^KZIx72NEt{ZAoCuhWMST{rT{Y%Ra}=b;kC$FJ-WU?IWP`}8c3e3 zdiFD+d9ik$H?uuh^oUZAh zvN#YmlJT^BC6Z;2CSA(Vys}i|E`jPCtx^U&;HV0X-JTY{%Q@}okk9KJET3uq7m-!y z{wZMQ=YOd;qDm_NYc*WwfB8c5zbLd>=YL&igjr{VS!aYe*ml4?w7rr#K?<45B-;d zC$fj4;UXrxfKKzd+`s=F6x4#?Fsh&71ai%ylBfs(%DEVD;F_Y`gvjPowF+YjW{vMD zI=gp(c%Vg+YCDa#@J+OkQ*lHuPJDFTeG1_pHjRu-8TowNgM;S3mT7*1rX^|#IOE*b&J=N%ib;Iv6oB9(z6ed zl$?i+m2h#9A4#1`etXtROqwzPmZ6z^aGUk-v|+Eo=v&zy6b$tUF1OeY;_Wv>D(E~ebE5}kF-a>8n1Oa#nH3fV$oSIpFf>1W9)^`RawXdF`DS+b zn5h}8SHhy?3|_vC2yI4a2m*T1HyH~sna{UXc7OG35Z)(R>Sg|+(=>eeoC=oscyU?< z77QDk#%xrt|32=L^O5awVk5;@j1(&MvW~<5G!?U7?%J|>8=jF<#B_ufb8FGoC>{LJE(2@2Y!5m$l7mqF z2g?w`bDS+s3ZfDfj6Xt(5S@YIAyb5u*lh&ki@0gutKYH3o;Tse z(g{SW50*g0VoXRX=oj-j?BSrlDSNN49d$#*PfF%6FMEUd)exa8?_oLn_aUw@*Pp&yJtBS~x^l zX%xM+7i4&_W7gk8;XNm>pXWj;#GK?g%)>L%ZqhYyQ!!484%qQmEt z@Z_`JuB_ZDOKsbn#4MlV_PGWdb8gL#X10+s&QKs3Ytsx}mNLxvDApGA;H2;d{MdX) z2~3ojB9}9S6f%rKzz_1AirYxcr93I`EC9Gxb9B!1E!G{0OXpuITC{!s2p467hLtW) z)-ZW*(A?bIK=#eH#DU8B@3@|ME_yVs)fJtIo^I}*3wc0uDpKCo7CQrc#g7zqr5lL# zB&gcA`M(}!dcS)veX)6Rg!IOB^*Zj!^DL3D%t(T>IQv%41CXu>kggup>V=@vl|6X2 z3;~s~T}#*-kq9Zsw!kvB(j>6o+wuqiq4{-Fbo;%-aPh_ou_FiU(Evb4Yn=vx*CrE+ z=yEHa2z61ks}j7-YA_qBXJ;RQ!OYfr015JrTE#}tl(qLfNXd&5!SE?G;ZtiJ^CDU0 zgt>|e0-{4_P?!yP_YZ@ZJZV{IpyMV^8KL}Jjczav?{Zb zzNigwQtf#;T--EkQlcg6%&vIZKwcU3OlT1wHs|_|E6|n)H{; zowK|lp*Ba%SO;Q-ksc-`#Ih5)EWo|_Ors~~%d*KfB!NJWzigr@(?6OuzH`OAwW6>) z@bG5q#2ueo;tnaV^Li^9Njq%2wv4+GKW1#zF z|B&fC;+;mPQVE-T7&xu6n;Ud%p`hM6Pdf%05Pm5~@rVTK<2BcX&0^RDtc$hdu|phbfcZ3tzF@aE%?DL>4k&#nQPf((2bSvetGwiw~2w!kZ#u zoHjpVbxFaO%7U!+6BR2o8I0h!i(B8`7MIR)5mx7k>Y!75VJ-5Ic9D?&c%UZ=X68+3@AagKb-jQ;u0W-NzWuK^@U3O@|grZ&{QFG5s-^~ z#y9EIF*z%9Oa|^RiRkv}5Ge)FauO&ju-5pb!AH(el~|cs=sdi@xS#zgh3zy`Icl8* zDaiQF+elw}YEfodAmdD=5kW86i7x+Ob~MoH)J{quI9lw=NSGxJO<~LI3h0M%KDS~k)j!K)W++mWGV|7uMF%e}KciZ=X z7M_kr{r42&-iWZGS8S)wvJz{3NJuU4$ImO{Q1uS{5D5w-pq9%~kcta8=gs?7>dm{L z+0iTc_RJYlsh=WGc>T>(!by~`@8vZyTQnHQJW{mQGoYZzKc2ogeQx&btxSk+*8N?} z*3#K7*Wv#^>-hhe9ld=1fT8iTp-i{%02wA3G6I@jpdKd~E1O#h)J&pQd?m`s(jz$IpKx@&1pe zC(khR))K+;Q<3tq{au3P+mZ4q;{Dx%<#V6d!N&`hFN{l0j(=d5_Jt0D{~cVlfa$&d zW%=rRyVx#}*Kj+z#t%wRp#$#c%9n%D#lViKL8+MXu&-x-FDN%|EGy>ACr3YoB9$QJ z#Jb|ZCbpY7JSz5IiO0e9B=_~CS^9bs=Are$(Q$>F?~AY-hN6N+f;Tb6ND|GH>CNmt z^bnT#znUIfKi}BHR}R=4;E+4i7Ji7DrLC}0fJqd20yuy1X$L+<#-~Vqs#Z$DR@3-Y z)t^H6R5L!+)Tf;ipn>_R4s=LOSZiodBuuI@m6w>nRK*q6u|9FyCF4s4zBF=5rE7eG zMSMNkrbdp+-K>N=(8Nlk*@QL+KG6&tVulCpfe#JL>D6c#a~FeLy53)KHwWAmdMD~w z(gV>2LLr`FUfIqhWFgoEijQks+bV}7u3C;b?M!;P%KI9wyc$yb=ke6kec`3R5qVIt zeDL~AH=QzMsMX1+-DSDR)hN-s;5vin1~T}in+(><{nV;*%XNDKmshf3bsV*Ak z=W6Qnw)r_qeQuhcL;YF2Gb3?aUbNrFE{3C}kv;+?X4F(ZKU2}};CLk@97nN2XR<9i zn{MTR9-I^?JXDJn_ATzDMV%Byr3zH)j)t-G(YxK)00_oOp*MD`3u&C7aivNDsScs+ zW)8@QcMMUxR;tO`YDtl?q=rPKT(q6t5y=JcI5lNw+UuHD z*e=5pH-_YGX@H8uTCuhU)^(T75hq*i%tg*y(>oWs9easAnT!sk`g$JP)4t|&0Y_Op z;Gk;l!A<)%QNg@0$f%4vuqEZgBI@V`JO(>4b#O83_1K)~x-CL?X~QS#7o!?rl<6^L z-1#p`YCGvqNhD2OOjs~KsY$WB?h_|-LuF!;P)6bMB{n8gOu{bMoB&T^iI zqjeE@L54ipA<*~3m(N^oO~~5HNlbh}?om0uYLPj}qtfAzt)sL37btMse|}#23qb1< z?_=nWYJ@TXcezGT!=FwL4~`GRt@6n^{!3!e;3OVi0)>Mc{D9Im!TTEJp8UW(q-b8m zYEYAOpMZ=?Mjb$v;21Ml^m}~(;p_IL4q{i9EucwgH~9%pG>#?$jWXxl4O(Z1C#MJd zuj#e%?|6!fjV#dD8Q*_ks0KGESoyeA3H9gofw7r_s$N*L?w1zv|hY<&}>$`%>zYuHj zBt^F80yjch#R4}t_m>umC8gUwh+N00XG=hnf|ehX&U>h#*i zQ0C-3Wfir5WCs%E1xD{8e!{%`IFBCy=l7|G%EBm@BJiJZd_S`j{<0;{R;m}=nNhEo z0E2tCZ864z7ur@?cikWMNk&10(TB`-Q*&1Srsn>bZE1a?2i=F{)hF%YWqf~}tK_or zEfaNWDb#6q-?iZqKyQGWfj`D_@TJP@@pRbD!o`+K;_gMtO7r1nSKs1E`sicm_Q<%^ zQqk3to_~V1Fim!R0NCmIM?e805f_+5Z^6MdyNefh7yG-5eBE^ych~iISM_z*S=?PG z1D+4J-wodH`U9e4*zpiVCSmq5Ma#BU3l+_}h@5EfO`+I}@^Cbb%gCq#D ztq_NEt*-k|(*MaM&gUOP|5vNlUHxCJUR~?|zEJ(&RZ9OCRVvlszuIqS7r}qUfLig} z;Jbg|uYZ}u-K+Mr+!Ye6edC;93W`)&Z_{fPWMnU^=ySu6)(+ zcH?0>FtgABraw4Q<=C^Kj2^Lhx9)B}2M@h|f)dVB@bx5wzss*r56W9^&A(i=xvs35 zU2_1Vky?p^!n@z09mWMo&zfz^45`;>+^p;l2Jgx{D~6)e58r5+eT$3v?3 zpguDw$Z==l>WqzZDiPZGCh{`-mPL~YnRx7|eg<7pic5-iilPJxnpQy=3Y@_r72xs% zsI3FiTi-=-9Y(7uuIX^lxpEY;UEVGFuovRXj>*F@qhCLRx%EYq})>!)=ca zT6}7F^v~i`-J^RJpVCTg3B53_(AMxvYqLWMk1!37Py!@O10<9XF#xip>YEZJU8ACm zd2&@X=wDyQU3~2fZYgs>FdN=r+Hy|$H%lnccAriM5S1>f*zovIBAu)!p>!}n6@h-v zA$)@jx;L0d_Ey%}^8wFYOi@uEluta$O8#2GuPN0XeZ$+MeBvl~)rDv11G6;Wo{sON z_-3L?G_@%JB`;TfRQ2s`D#0uAt96eL(%1MPb&He2JGFkL+eXl&6v~EfJE(Z<4uTBb zwto+lZaXlP+rFBM03c~CF-;`($5U>e>{Ay|_p^DVH8121^e}sdmy4935z1n^~qnhecDfiPOrZlF; zifUNFrK zo1!kM!(|Ouqixoc`fFL&(p=l?S^&_IbL^eyROx)YP9RjZP&3^Ya^djYmz(TGK$Tj z?;X3Ot~2;gQ+CeR|4AR&`{@Da>;IytR*xM0Up=bS*ZRM;{%@`STkHSU`oFdQ@5|Ev z-ADZg&oH1MxksrB_>oUFsAH5`fk<^Obm=DO3wW_mO=wqNpeeK~FHjabm3{g`H(;z% z8KxFtYYnA=u19$o1XcgS<|q)!h_CFMkzb1#ctM@5O7u*H*JEyNdH&w|J{!|tZt`S{ z>z};RF=q9ap=k82&6XYbFc4~0BZ{aMB;&Y)6dE2=I!Z0Zajfz8aeH!Ygs+8``r9O) zzJsQs1xnvByQbC61cM9U+@BefN(=$prOQia^ zX^CiRO%WPw!AcVEQo@G#=vfPYSbascif=`==E4>6h6(L(w(K6Mf+x^5N{z!}F8A09 zjB9F{g-2B+r zEB%hT=y#M3iCo5JKeJ=A^b8{B=Meyk<5U5_F-viO%2Ab*1TzsJSA2MqQ(f76UMKEm6Hxa*|JT5t|QwtN~GA;C~8QJj4s+1(q^NmDfKhD zXh+DJjUv=~)n)&}lXGs&92=$>A~XSZRaBk*K@JSxcKAQ{E45gXAwH ztt0+WHT5c6VWqZN5c<*3(y#ERF!iY_KSileHTkKU`c#*nYN<~R`Kg}zv@Jh1QlFag z({}39j{MY2eIi{lecMTYQ}77W00}ij(jW;HOhOHm1zXCRUfdBYOrPA^h9q{-?V_&W zJv>1x7O3pfK_&v0~u9<8{Xc3;GKHzL?!m1JaGRD;pzEkYe% z#=*3GF_2Ym;@~ZICZgeKwR+s{TybB#Yuui8jr?^vd$bVX?) z%IcX_%jXTSAh&3T#Qf>>_!-+E1a#dBkV?ZojRb6FKoKO|K8|0$rgN7OzISlbX5cej z*sM6_B+loWZB?@T+}vqV5Ja@aNdmft?BVa;uZ*ud=ye~qV;!P*na;UJq-rQ@5VUsa zqqHwI0ObvsyHyvz&D|>J^Y%k+)%gdW7~Cq!1=XO#tmnA^SoCzup48R+NjaYzSZ#E^*qTgJuht-CE^r5CcsAr{n zC)8CH^}OT{4ZTKt7TfxRJ&mUNAm5dXcENznu7shUa~OH%oLF-<)|*&!j_eKFP6L8J z=s8EtW#>%H>h4^kz}T669e0TdbvAP$%1W`xzQ`sO&`e~Gk9N?-JhUj(VD^`DbCEX# z@Wy0A58Nl-X)yJ;%t}b$Q4=z{!uWqDs9T+g-p#xSloUZ%r5=Vl5)bDhaWY$>6vYgi z53iBI0Qg%L>2a|bhn_vRG~O(k!J2N3xGN!$9ys1E2gS z7z1Y5|Bc6;hq3)zBL2sASZ_G?f3;d;9sgr(|F^*YZ*Bdzw*FgN|E;b6{xH^m*$DvH zED+7wteg3fFExOf06;uo>>L0XnxCG1TX50Zs!^#rt5^~DNjVovF%2+AH$b)E{E&ue z)*q1m7DWf}R!>yy17!}8$gGI`+E-fP!o>()I!?y^JTUYEDKX?Kr9YFUOOh zisRxBVMSzyWhzrs;i&25YFI~bSxxv3nq_tEYplu|(gw*WQ|2y4Srf|KF?O_%vMLKJ zB?)JLaPLf;hNiW?rclfWEZZ|IGPo>~hBZbRz@brd$^Z`Aky8e6XjYsufJ4(A1K_aZ zjsb88D^en@?KFhxi{5XE7!$b5@PtsNa(ET8q^3KHS#5nYn!LS(ie9K%goYl~xGP!~ z1R_yFDGZ}!`d~wcOViN75YSLZjph6C8%z*3Vpp~1GF_>3i$xnKsm4GB1R8Y@zbc7`%L)Q;=XykcHc}ZFAbTZQHhO+qP}nJ=3;r z+uHv3VIMalPsFXP_ZyK}ncw*^0B5s?OU?CP)HcvyVxd$jxz2)vu1}fkSP?WR!1ZUy z8Eb_E@U75%*%4%(U=(v-)u1s7inj=^p9LFWLOqar1OU+Z6XSZ!ybjL_YoPq+=eDk~ z6#PQE;+iMNK_lj$;AWa*Ocl8y?{?k=Xb#_nqqY}Y1+7nOVsnOp;3X7K<^I-}l)4@jA)dzXxdVW2uydK&PuA$9k$SzOKM z#L$%dL=H`5INhD-&AD3MS#uSPD=1LsY4kNNN^7QwoJ|?>~;NT?eJv-5*_Y-1%md-p# zsCE^s$Fc5lfmuY6=L!cnNYL@^Es6=sA8NI=f|idN!2Y#IIO~#0g`19)=}=NHnB_m} zk%mklfdK)jn2cOnPI_(q&CYj)cM4oe?Fu{_5J^1?7!NB>^Ol1SJ~h%Js0M3XS6qfd zl8Ih-I*00CN@cQdzd$p?5NiKWeb^9QjE3A^qX-nAvIGucbeRQKR|sZJtZ5pne&{p* zfS>2$DYh8K`G}KbspNRZpL4BgZ2ft?zvP3kQ9Q=qo0esA#{+iB9Bv!XGg5r1f#p~Z z#nDS73~Sye& z5p+d{j64Wtx2Fq%DRG*Y(gGI9R+oZGeyS{9+Il}yQCoC1lwX+f$rdq?8<_QG*!OjBxJ5W zkRR`0p{VF#Xoc1jzI7GEpsF>EK_A0YRQNAqoO;LW#F6>G2E*siq3@L}^g3N&W;i`` zkWAE#~H#=OZgGF;hdl zOpfF9wwUeXLaFANha!OtOPe`H;KYAOdAY*|YgpF4I~eoBgfE4Yx~Q?ZZz6YBVgk>} zU#{fC8_QNc-B10B{}^h!8zz$`4|(ZF&E@v}^rbcN26)r^`5HR()fN0!t6Qw3eA8?1 zN&WE&xaSkb&igW+gShkWvI$Ox0;aEEnrlp_bYWdQd78 zhQQWDBlKFO3b1&rQw3Rk+m)b}UY^ipVcEi$timD_>N<3#Uytou0G zbDH5b_kS07H=v)PXaGqD`ei3QYP$EJlU;v<`_i@}Vl#Z|K$#8&=WL4yiojng@}gUZk43yk`*IN-G^w-_I`UxKnC}jX+Nsl^ z@Ek#ji&zO_i;iIfJ^34e9E^9bWs7P3P&Jx64e&S` zD}m`ud&P(*Qyce$R`QLZ^h@~=3dP4bGQ=({=HNy@>Pr^HDd z>pHU}r&NbRx6VArznFbf2{Q^e@Kwq)k|R-M{|s4a+tetPt|+*XO5z=i0`1QCbiN2z zbmM{4u@Uals*}{?%{wBmM+w3d>eljku{@OQ$G?%+bC9FXO>1XGK0G@te$0px2|SvK z>KR;`C9$fi3mge-nk6x+=JZLT7eF%oYaN6=#yN~wy(Ra|6Y`JQ>gvY3R|@O4eC8dj z3)~5HD_V10>61p*F~@dwNB{KBtWtIbPYDIX3ajc^^em9);;T;CsIsuY-!M_##{^M5dII1s% zw)co2Z>@o7)+*{?s^CVS(=v>!sr?r7W&Lw`a*&p5*7~~J+uX70YwfhAcwfdjMNK24h#D~hLmlNjVnuqZ3E8a*RF~497xfcfqO2s_9HMH)ea&oHqpGmv z?eKnC?{a%^b~j+K=R?^}3)U7Jq1`$9k-W9-(&YsD)5@tv%>SCb1|qsyt3pMJg}F`R zHNa$>6#b`G4{4^esAdjh3xl1Cm{ZC6DQwFiha}G2~o- zq5>0gBzNY0>ooxeOaM$nE5*D@ks4e4^S;i${qN<1u6T_yQ!0$G>5m9>>_V?f6;=wu zo-wWT)_b*!BN;bCb>)=eYW|4A;=&!p*~19rDtr3u{c4_>q(oqm;R4<2vs z8lc7I_3))5D75kbWQqDz?l@w9o^%3(TJ>jeNb`Cr6%gas@nOrVO!QubclGW)uJfI$ z2X-8#F$wq4n5Jcd{;IUB7Vyq3Eh$E!>^kZBf7FqO<+Z(sgNGFioeonOG`{SG?!dsh z=g?6p#xWh)h`vlTJu)Y`z6`Bc9RX3;hbJ17q^rLmxZ~zZh_+qBV6v413;Nt8?4^o7 zu^D|6pDkc|ZQ>JjQ0Mag&pkp|*p=y}p!&&VB+7J=P%>qKEy5ZW z;M4=)kH6L>ch(1#v80FmHH*NX!QGSb>(`3;>jdKkHPgkE`htjq;~Q|1L74T#z@$9X zM{6WmJj3JgfD5Tf;b{lfim&Q;TElLsKpv40(69dn^*S0|3rpT8EG<*X40J>NTCt2ySI$BZg}P-{sbo zHY78r#*Qk_uX183NhFmN&ADU(ZOJgfW@pA@d?d39qexrI8%h$)V#advLeLz+ox6hh z2!kxfK%z>DH~M~_K*rsMXD(fwohx|K zD?f>LdM+vDppq6&xpvCfOe0J=KfPz4bDf>Xa4Zc;{;lcFsjYpq80V$0P%;ue3jc=m z;%Xz+L0@mtpD?u(Un2APBX)3Hf&F%&>f<8hx0P9EORBQ6xLkq_!u36k-Paq2=;2E;I1 z#<(Py`$sHi+S4@QM(JQMwk9q-h#eUSrDz`@vS%aP}2M zsJCyVLWsd70O!zoI1atLR^gsQGLctOzD`u>0MKL$**hoM#>N`8E=gYwH2Rb|kldcw z#wg#b9cnkmv+)Oq_2wz7Dea^tt*p*Zm{86Opy`|dIB}e$7yx?ru8oYr@vD0M$pX~i z`6NKrqgA%Y*>-AEDO^Ws%=?Dmj4^>7xQ0&%qcI~~pl zVPcbdcwYez;@^Z|Rn{-wDv}oEz)bN-&lPXTy;^WDeN>Y){LUn~lTe2r~SChX~OI}CTb1oeCz_qP$ zx7g_D$~uy$;xYAUiT0a9#CrAlMjWyx!AQ7gZ5XyhKILqq_{*^_DhryxN9#&<&R-FD zDiVo!Rt$F`3j^fOW2^N!$lM;y0D2q_uZ8&&%CBB23r1|7!bIteO{&{~7D{Ny)Al;s z?-Q-j)pSE{_R*vmb+tVtrlY9o|9UzcskqbIHjo^UwwiI&N-68c9wDWu?Y0R=9i`Kv zK_KL{lpPujgnEXkQFCOeE=H(MjtH^?io4x+yc9vsTfX;^Y)U2Y<5da>P1yk$In3jC zs`*8c6LY&^=#%9pQ^qOCirenxo**yn8!czX#slTwX~Y{e4Fevp4M)Rf>$hK64)3=U z9+9NM!0YyABf(Y_=WCnf@Qm<+~3h; zMvFVqN>Cnd)7B@;#wBOk91GutX4nO*YH)Y1KujU@K!wJgS8$jkWzw)k$6aiuxQ3tM zI&mBnsd+f0``eJaN(FC%if-SBQG+Lz>~kFDXAm~@&{*}Cke?d`{T0399yfF7zi3!0N-rz>Eu91t6sKFdnQd}8a0#g_gpJ$MFH!t&0G3O4x?uOK z2=HFOi=-kE*o-bB!dSOZyd5N=WF9T#r2VTBHrXHN7+BAQ9X1H0UMFwPX*ycI&yzf= z>Vg;N;gXxYAw^{AlArx+k_GaWr+PA@x1YM)Z9|z>kq5C=_ar(hnMY9S6aJB?2@Lnf zCPslx2_a#Z@DtcvTFpe?lnv_U!DRvWtCy*U{E^9(}o%f%vgZg?|fF zJ-y%B)k)Q)!d&W|N3ZvDxbE9pumkPytQEU6+fxF3J8S;Ea%to^?Tga-YaIjdcZxjIozzGP@GJ<^Sn*=KlFz@E8{P zBp`A&vjzs>f!V;PgsmA{cc0t1)eU!7rvP3~HTH%+_hGXMIU*@C>qmUdr-p?1gQ^MU zWjp+nT~9e~!E&Uk@t6rUV<%g!S-AVznK6f|hS0N$_z?o==#Nkw)&siG@u9hpbv!)2 z(o~tkPSnRjYosVT`DF_Qu9-NB?X}&^*3+@>d`=p>K|l12{mcH%hY$iA=@$P!rgSKL zukvj*x)#gn7H8W$JIV%}RYi!yl+AA&23(CedD6dBHh$8dF5s#QtF2XU@hr#UaXx;U zZD<<vuOSs3#{5>#r$XMZT-{B=DUaWM>or_&d9&!e}gs>kW2|fcLX>; zRqoa+`l8R_2ksDoLvyV@1v)II@0&Q2W^!i{8C<5ks^D|Hg!4& zL1!&hQ7tRAbXun^RaJE8Q$v?ntJT<)#WgefMl8UMn;Q(8!c{G9 zmdeo8bsceOZ`)7odC!O0yaYv(mUbg>M{pw~gG^{LLHH7kIPMkmc}KxvegNbYCJV4x zo^xFp7WM|iK7n>-!5Rm1x1e6vio%u7hKYMaY{9GC5jyfM4u@5K6wvW5Zo$~UlSBh*-m*!m0IfHqAN#y~#Whyy9 zOn0P&Y4>jv#VXMT^qltzr{Na`zLZ_{-jx8K79{9D4TW_vv(6;hkQ3Vu#m2R#fSMwLrugp$v7##}Mi1%;n} z<;flal*zn`4-cYP{F4QB_H~z_QEUc5DG1U)3Ro-sOP%Zn-g>}B-@Z6_MgfbO>#4$r z=bFC|xD{#f{tnKdO;44CmhB+-<>c`tTLwX|mUN>9b_e_;;*F32GGglsBPSFKu|y{C z=xLwB&($^LtS3fZ_EFfTJIDq?O3rR zCNB5%1(r`CD6R8Z+TZRomXS-pgdP8O7}(I)Ir({r*)^}jdP%1O-&HlG^0Ya9?s0Z) zU$`V5O3}q8n47h=h2Q7k+7HTDq1dBx&CmgU86%x@BLJbBGw2OBbIqPd8btaX)>m&k z3{720xTCG~xfkPZVBm3@y3)bzIDxHQD|D|xUyXe?I7r3PW|1^;VfzM`#|QtN!#^P5efy%+zEz(m&UPOG@{8dlpLad;s~-EH&!OKmh4+5$>54p!0`o>vrG$B**oa-QDJ*A|H(Vx( z4@>Ht$v8WOu_c7VLmozZ%spkDZrc(0A0^rmnF?IQyjjPe+hvf?@o+wH>s`-jjRuV` z6nVohVY~Uj2~3>hmU;9_o4t6$2*l0tl%8<=U(aQod^yG8^7_qgPp-(h+C5f?=2=ec z{(B2MbD6U;M}(}`70P({=gm-c9b(ai>8;Xd!7F*Y)N#j$KMrEu`=#d61+`=SLH}Ct z`y%qLc;H882Sg_5lL}0xeR4vJwwcv;CHmSL)w!Wi@;G zvGJU^Lze(JY@KoY1-Pnpo4(P(NY=v&Ha3LbwVzb@z=UhMQmnmZ{ehUJ@P_kl{vfDz zrW3Vo=o3+VaZSC0qv8Gq(_9~x2AH62uWnNa1b!HGo)=#B~O1tZ* zaO5?r!|Q$7LDNE-yF#1pC4RH)jFz9(m$SPooSOc{$lb(mvHtUN{0c+11BAg1scMPn z4d10(p{7sl7aO2QG@#8rHzz&%B^$q~s~7zTWa2VVHY3~$LdNaU_S@dk-f{c=?)EU{ z*7Y$md}(_D7-wt1Z=KHr_~wiN)ef+}-Nj*IdbOqj@YxA!bGWd{sR+07;Zh&=Z7lqd zhX4#9;$g+k*S=QKXqtR2>6@?pmV=2;o?_QB=@6Nn$sG%DUe^F1Q^lU2m` zgZ)`|xu2q1JfA0sJsP#aADM~WVwWXnpleSnpGLpaonPhnbJ+oBApKQ6Xdocxc)3yr zE;mz{&+ofy#&~HOfY=0qst?4W@e^xQZu{j|7z2)Rpe<5IHf8k5Ct>fHI>946Q+ygA z^@Q#&S+HCsH3U%l`R~Ecp8?JkS=m%6n6X{$gUX$eUjIUC7_t18kJ0cJ7wp59>Gitn z=5_@Cmow{58u>NQmEPP%l;#BBHq~a&uw`cO6IG{yvOMsRL?;%>g-dav;l9Bz)s|rt|?V`gRJx zFL4HhPoJcBrIgi`9c`PqxixwjYa7~;*9dplGh=V-Uq~b2b8u*sZDDCQ1}O%j{a$|3 z*%W~wUBm9|56(Tt5c6;;AA;1hNvxLo3c(kVR`W18^-&b1{!OSGccJ<(I$WrH195|6 zjjD>CDXMi7UP*e`ndr{Unm_D|;IXOa-Zh~KAYz@xsN}QuA zU0gw*e}TWUJ2)g+aoh+)b%oP1mjxvf$)4Z4h@rc7!#Vg)LNrlhUww5D*kFF>msXL1 zPf<(w)E_7;XiTil8CodKaP#dy&xmDG`Cf{K$i8$DRcQy3pwQFM?zvRn+tcnjRlcpQ z-D9h~qoLhnpgcC43|(o5O~%DH#tTf@449vP%da%z#?<8xqpx0%C#SJNN{q4I!Up_g zD!WoUT?Ol9vQj%$r_*A!a*?770emCn|p=od2RB%*`GTllZmY76~935T${>BMck2_4y21AEby*`*nfEP!^HMuK2z!zhckT6L;w zyq(5y_e|kaKvR$$uLy_%mms@Nb=RiMkQ7Pv?$8ejs$~tob!rovrVCxcsRRA=73gZ* zQ`G#%L)A0t^5LF{e#-EGnyQoI|}ID2xq`!67e>@GxNHE39Q zv;7{UW=B9Wc_r9MIy*-bfHEE8`TrC}iTYE7ch){evA~W6eJ>_yYoRBBl5h7J6}ElK$pj@GY@W-il{^xqj=gm>xv_<^K5nnEfp4%k7%v{pcFP8-1on`C zxP`VI!x_uC&0GG_*=qE!9FvR-4IYE_fB-1OPH(lr=IQgQ&Z>Fi>cupJO0y?5sV8zI zE9RaaGmUc%pJg|upgnlHa3EWy6Qaa2imFIP#AVkCm7FqgJMR8nW9V@+X9)-hEMa12$oS)^hUL$5w|=uM zd-zO%ANtTr^PljTH$~$jhZqFk&~2m{&ZusS%v^EvIlyYXh8Bjq%r=ENwxU~(ymD1Y z@s_Xc&Tk-0i}#JKCFbdn3*ZY@A+S7|NzXMhbwlm6|^)C;s%> zrIpkqX^BeSBJYK({cDe?=kplc8T%Jr#U%E(o=H{j2&Z7$M)Sha5%|~&lm>X@a~TV<%dDpIC>UQx*>EA^OK9*V!x4 zzWymnONp1bepD8XLCjs?Bbv+>gpkr3H4MIY&QX{uypgcFJS~%>wtnD@@>OaH)kq%| zxbMjnW8fWIB&Uq=P#5;_6#J3oz}-}mjKV@>x`8$y@RmCYP`MBz7k@(1Jl2E|DG9w8 z!nW?T_slZYh1DYPSRhGQpqo0Ze5V-#I9_h>><2J8H)eu}ep(+j;zl1e;8z~Ma`=_S zuMB>r@hgR2N&HISR~)}$xY1Xkq`xSk2*IL?GDRlLV{RhBgy{5YvkJcE+yMVLTAFZpGaG6UpAQfiA zK5pMd)zXz9T5Hs_nx6DBs0fZBLC>(1P3~R8k|o_>Y%VV^6xaB`;nGf=Br zS(_wVoh0j>UyQ6lhQN6etnv)NL5@bAGyXM~B&*!i#Ep>wz3uCMaMYjGE1uU1D~4MiT*19+X0GRaAl$ z$0U%^N^kR8*!AL--g3sdQ(rmDc{qtvIX%;TUs?MfE>iMn**; zuMLiR)I@(1zjh!qqvno+_C!J(zCTUewNXAX6jCr0bWn-89~fKfJGnV&mgaOE3}jEL zgnsG$+;Bj?P!Z^JdCPuiBYyl?Q~dO9cqGh%rk`PdV5kj-rhbrFmf!q(`(NS7*5jKJ z5Wn{FF@m|crglAGv=2#oVZX7G4!Lz`fvO?Ct(;k4d~sw#?RK7$D%z0563u6KHnJ7N z4E;(P(C$%vOT1~2PVz1*tq#=+Ds4yPEuB6V;@#AH7 znFhi^L$a#e&B`%V2+{CxG=W2(Yyae690M-->$gp8^BUiq zD+{-RM_2$1M$$1(luR4Y*~gpE-+ee_b#EtZH>K*Nn>IGD^2uIXAb{=oprcgosj`4{ zPV@s4=)}gOIFoJkF583nfebfjszsJ~LlKz9n3L-SEjVelWXey}jLx=I+D!Zf!l0Y; z&oQMgT#h_GJ$kvny*o^-GYg}KhpX{yG5mhvL3+Q@+vN#mA0`69iDgsT z>s-l0?6gX~*Vs<~ql(%m2};9x+?MNv5&{N0)dOzd3Gz5O+Oqq?6Ff#@X)9A%p!{oG zgd?}lK;|w-fdRU1M?KQY89fhd5KMMi?QbB%=o!+A+#X}t=`YVs6`xVdi}-SY&1~O6 zLPn%uJ*my+fXT+Spz}HDszHnnPVU2ySMPUHOS9sz*WI2dmhbo{Z}{fDNF(vcIeo%j zP21wnGySy3XB3athqA3X!XhiwA4o^L8IJh&xT?z;apjUVaK}V`hz)a}t-Nh0KlTN& z^lBKP@t@GvTAHlSlh-dZPbB)=pCA9+;hk!oh?`x>OFXg5 za7-Fn4qun|hrP8bUSh+}iz;zLUOMoW?`ETp!QUVrcyGU@Xw^Xt*F=RGM+r@@>^b&OP zEyltG*4nauFN-p9LO_hpscvn+u8Cl5Xwe}@fQNI2^8ejYYp=5V$ zJG1AdMR#n``Vs``Qx3;HL>>Ls`T}n4_`#c50s#Y$HLC<>e(`(98IPk$Xri^wW{Kqw za4dqp$jB^^rbh0JKzPl_$2x0dQPr(DZJqoE={TTd>hUHc`T55^M_u!g@|Qgv_8+sZ z$Br;^ahRXC%;m}Yx%GOT{51#*_yo^BMaOY>3kJ(Z`t&e=>X7VZWKS|2F`KZ9;44U`18*32qj#&p`atC1PYea^%Y!Is-QJ0Z(u2*sg>W3Z6?n(xhd$vd8B@}P5t;6sVerQ?8o?Ru?# zkjiUKMDq<#;fa$4!O_cStop5xw8fcp<&0)Lmcbk>(PloXFLr_JH7pEV5(yPcYN2kF~a-Q09I~;^2z|8k1pl~e=%E% z1#-c~S3*6H!}3+!!}3>@^?+aI=@bm~K}O;=Qy*F+FNSP6esF^ff_Zc5JCg=ZEg-cA*jRB*6{*CV`T&q z>}?nTrD608*F#kqUAEHhN{gFrBzF{RGA21w9BNV<0=LgvFL0i2DLxxm6aFsvaOW(gmb zJ2~5iGUN;H=`*4j+~Y~mz|(|kBL#8%sD1hrJ-*#Jh{kC!SH_o^rrrAZaOX2%p_V52 zDMNygpFMt0Yj4erVR6qRC(SLFs2P!lI8RADwLHY*(JN#}j?CEGLm`_Bye6#TxU9M= zRPhFNtLY2Hj;zd{hurigAo$fxr}rf9t;VmMkB=@RyURdcGta-M=k;pYd39qYA5t#j zo#5y4e7YoZk)&SG#q?yl?a?fg!INFkiG8UoQkD=o*f|z6+HbHdR2H^6)ruY+m~nUw z>4_g9x*4;N5e~&BCFF^MDS_mUr6LEj<7xP{O0ojWLgVvCKATLr)GOsES>neUUQsQe zCd91X6fBGU%A!pZ)DB(~@~Nq874q>h!W8haH-kPl1vImr!=%wAFErY=pVR$rIYUzr zL^Tfl*4Y7&CHWC{1JcW*rJ(|Vq&$H(NZf2T4E-Pm<@SOBOKlB?ydx-Il;at;U>hU5 z8~GMn52r}vs7c3Jp#+dzn>YCmAnRtIeq#dSj7^HS2M!1guhk^2yPxdk4iX9Y?fV_u zvIrovD>n8)f^TQ2y-np~jnq;+M8~(aO|Rq85;42 z3MhiMg~ygsf>90$d!P3DwM6MwUX)4QmoE^rR5u~2F^rJu>^V|Nb!?bh9b-Cf<2(w` zT4ebmqGw~7-O~UU8%+bwD>NTDc#nN$BRr=en>U5njGPK`ret+GsrSI#=uyZkJy6B{&2a?f=&>tv3BgxxiOsOO1?U8$aKiC7dw;}#HBRrb7H&MZF z9urwD3wZNYA)9`oyU`c03z5Ihg8XVToxnRe%f+bEnW z&w<1FH(z=QyS?5{j*aM#Isr+!P>_Q)re3k~me&7@0tu2#{?J|0KtxLc*0{!9Oei6P zti_pCs_PS2=rVQH%+X1m8b6_zzBA3V(2V6ho`DUcV#gs8XkWM%CVtAxY1)S;EwgWs z?u3D55+A~?X`NVJW&UF-J!w z7Du>g1_&33SPU4|Ni$%mT2Nwa;1pcS&;g!so%Nd-vnV~Ois@yaC}u&LSDO<4(bOIc zKnV-0DrAS79)Rxk<9s>G#u^No#1fTX-9*-&Ma+84$?5g@F50DMoS6oeqkx7vF8JgJ zULVWIxW|UM@Q`9`xbr8nfw6-$Cmq_hZWl4G8V2KLyJI7o2G7bT6ort`MlLz(SCZX^ zLd&J6ZolyIS@1>3#GucIMQwID}C3fiLF#+_Z9*aqcf9*v5%fSQY`>{7Xm>+uZDr{Wu(Esq4lk%>ddAr8g{}gbUQ^Lf?Bour%(y6>FpAEeseb69ilcLC8gU zmCBQ4msC3d(N{QQAO@>DmbX zhQ{_98q%e$^7Oqq>-h+!f8#$ibbCTfkWPpcQy9t0lcc2bRNFZ$ueJj{?R%$M$v9i9 zb8$mV-s2gyqtex^$P5XE1#dbQqEUG8_}7)8zB|zo{z_%I?V*b!Lc!pwhCoM&r%hfZO|Qh>%#QcRKvO3!xqq4J{p!$szM# z5>`4^ctWLC;m&HFDa7ACArEXfq!OEP6s?S*9Bf3(Yu?~nl>#c4-+e!{k-3G|@D5QO z1VZT-^r%V9sLRfhk*sTD<7@kYYNq|fviTbGjVB<072ZJagZkigV&;rrVCwkM-*A&a zp?XXSE5YtZu$x?kn)dQw;YKEf=Gci)z+5phaUWQb)iQ}lUe5U@3O=Yh`}7; z&=TBRpe+Ztl-Xw9mU((;Kzv~CQJciSG$pjLGlN1 zGm1i1xTSw*Wtd2`;M(|L(uR7gt8nFpg&xH4eH*Fk#ieA)Mqu|yB|=70P9D$FN$v;^ z-7wDaoA)Xk5`t;jd8Tw@xgT@olL~>W{<2^L-F?{ z<;N7rsF!(IEJ+#ni+PcJnLaWL2COnyEFEr7R6p*KUK#bl&d##kNoX}!2=MMHMFkw0 z;C_g9KKDC(^`3$X#nRnjR>+};`PL3mPIz*MLXObQa+G)wV(YjNA9w7Nn+WKf+pgXgUAn_SLLr&>F~gIt(00@dG@PUL2* zX6hUYiOFmP86URtMRgS^gAeB+VbI1=oN1h8#$+rS0oD!Y%0GT9(d!0@KLs%T`Q*=F zKT17QdfNmeQ) z>#EKH4(slT!?llfu0IOucq89M@#PMECXSZn>oyD9$5bV3yl?>5o@n6KPo7yCn5l#W za?llOgNuxqK#7Rwr6s_!E?AZTWayzNl@!Cns&0->wk+|Q zyVj~u6p*v$E5L^tTsHS4!re1~f$j1>d${d4k|FUH!3EKE9ZSx_vd(b~648e`IXqWY zeN=E#XX$MCTF##YbMdBw%(%SBxwNz zbAOD<1X^9edw71#d?&qGAEIK#e$6o##5pWc^hdL*q)YYKlC{Mo>I8b;ox&f{i(H3^ zqpu)*xUgmIYdDiS>(WvrG@W)#vmsu^v{~7SPXHQtqI}jr4DOofzC%Bn9aW~F?%pw~ zqD=-&rIueeR1v1^EHinGK}35*BjzwY!;l3~tP}a?YY|(@!p^p&NbSDs>S!O+ErWr> zK9N$`X5olK-~jY%^#Q6=HM6t~`z#{qJMkmka?>k z0yl|d`D{;TNR^8t?=e7G-9!|;KHs;$W&)?)pu+n1+WQ*ie{ZIE=tUcmL>JLIagj*Us5OlRI2!o zW3J)e^NfAb2wlVC2(%3CgBx1Y-l-sYa02x#*~Da8c7xJ1%<)xOX0WHp23)`~B|15~ zk3R$E^)=N{dNV)dEUFAQGGr;J7Fl}{5(C)R#dm&8sVco#HQ~W{7ALfmWo2TSPfabc z-y_Q-BN3XcqY)KJU?cYgc3UG~tBRd9>w&)aIo);=<+1Q1U!>oOJJkcaF#xO>wrgcU zwDr}ntfpD0eT>YRoUZ%Dq$iIR%s&}1LYbY>+tMQdTuMS-F;(H%fFa6VDdcPS6n77P zA>9`69@^%brsjB@s9|5j{vwrBlaZwQJfTQ{g-Ok34lih8=~q4TMx*yycbQprS`d4BOTuaX0Yoa7^s6Lo}VUx9!zbocW4r^G+!-+WO4S z>I4gD3zp+|h%6qa$r3K(x_P>ioSL>ox>JY0YwAl811ofgEo)Ef&RL?STDT3QtpuL0 zwCzz%EKkJsTe7#7Zwh|ml5x5nXH)UA#!2lMk$Vl4oWOU zk~j`XL*-2+1W97R*~GCI+j(Sn`C^fJN$?jRabX9hA6>L4tn@6s0}D9Kzh0sAeYY{y z!ENki7tba%3on+Dbj-7d_f4pq+D`##NU`q`P<>9+j6ix2rD^kZNX{Ud4U>PBzdNfS zVS;9qNtg~=M#e*m*R;+~RTR|S841@W+rL`U)y0WhN(3bfb3o%fCORH)q5MtLIf%5xUREgY zTM*M0mzDXEGSw(6dq+ce`F*mHi&{pwcSa-B8jH#Dps;!l5rHqzpCyW;DERyAxJxst z;whS5=JHueh?NdQmb=%pH`WN#nz*zvAU>}Wagv1%8Rt~7STygF@gKmO&=i;*=h9eA z%tG2wKNhs>O}WQ;7eSqe!uzIJ=Md{f{gYm74}syO!zHD>;v!QP+qg@RhM=2CiQey5 zg~wo!K^RZQ*)#((<%_ehp`rmfaMxT`dBkwrppEg5PnGZWnPUT2&ZgZxt2HPpuz!IJ zd)(S@DxVSj%T7z`WZj=YxSt%}Yya4&F9Jh{_Hqo7gW;uwj41At*I_Ip*4*M!Ke~uR zn2IQ0xL;-4x%DuBGnrVW+P846Ju zb>|$+*z~o_@0TzM{mYAOFR5n3fpq62@`E&GLyj13ckHe_1U&1rd+H3#Bcs_%itOMr zab>~Xa^*Y+xI&I`A3Z$x_>@r_e#TFb2uoFLnARW%?w23x_l02T9w$*O9lt7$2+Vca z8@vR{&;WgIk%8m_Pnj?w@Ma8tjZ-BH_^H-^tO6_Oo56s`clkCF&d}q`=H7=;ekC(t zrr$C6Ba4KHAwjf>!Zqp(XaeQSj|7p9#d_V;{ll{FHV`jpST-{DPO^#U`tUp8Ie}U5 zc|LeP`lZmVNtYLby6+w>^Z_nOa3^Kv%ya!atpNF;IGUul0!hOA1A-))_~?yyV_Y{- zSPqI)u-nq1PmI84E-Plgk3GI|s`xiy#-B8eB^^HPXWTDJwg|Spn4DHR@yM6I7J%%~ zyqbfh_}tEFsI2A>7NytB0&_= zxpdV}F-$WBe`I#oYQZ}f^l>K>k!EuDzO4#oYK5)_u^Yr)wLckjnGP!IvBN1swc1gx zo+*;*X({xaLA0FpDT+2lOl#Z2lR*QfM?R}CP~-*)UHW5!m^d0a=t3G)q88zlF4&%u z8_21kvkUjVB@DFfDu*!G>_erQdsB9Xkp>lil~ANv@wJ+uAwSwRDi#YPLwVrB$LQM>#6v)R z24jl!qH@hYrzuM(5upT`on7Nt?Be$I737lHuD_CxBxxji=tosLAO672PFZR`n*G?u0Ddxcci# zcp+jmOX6inOmra(gQBh3&@5EM9X_d_kwl^u8$M2n%J37m9GngZx3=Sua5m(rTd!H3 zYl%f3XZtT+ot_-OJfuuRM1#GSVv#3bV=+t*cz7`|jQ?>Q->htWh^TpV1=S#+( zFErvYq@F+QKWpv(aO@R=_{5{8!;(iTf+PUh2)Js8D2_llLqDxnJGpMPpc%Rk4C0^w z9LS??=b{%>N?%w0d-w={|LQ4) zp|yA3rmTiYS4a{Y4ts!0U{)b`as0BS5I(3zX6OLd%%Ake@YCi~yP4D+8StVJH~WO! zo)6g5R#+sMOWDqB2(*QGH1?40nMsRKfJ3>oF9tn~#H)Q+^5*&A{Pr>fqsf5=8&aGr zg~`rUSJM5H_$$x4=zfQC?;v&2hZ#WhZuAzI8Ru-Wt=5RdwDdAA(Yo84k+8PeyxqtrCG^p(U?h`NSE@y({qa;L z8lR1gtXpkMCS6M9&6Ud*)@VAnG{arr5NsEBJxWx-2zU{RTo`xRJNbIB<@5fH9A8eX zy&U%@%3W%rgzc30Olwdz3~Z_VQ0|e+M#`iF2J!TALxO=xb!!5=3FYpA?G#r0Y555B z(#!6p7jE^!>ik}mh+m!|aa;!7i~cl$o1F+G9V{rD<>i}%zXyX0riErEkUDKO`YFGnrd!y{WjkjC+jUe_rJWr}I;qL2-W<_bfN81)3J|a$Lq5ogyQx zW@66U&xQ#(FL7@0%-P zBJj$E3HTG7nf`OxMyN9JhBv(j;#h{wALBQ=NgGKSkmhX$+opL^cD1T$q$am6+gwd1 z;P7YqxZ6w{%gr=ed8QN^-ybpmZZoZ^nPz8pF`E+xuQF+$HK2__OWFkDd>7^;p&Qul z-bqN}W@A9dZ8@bBzqshlKOBWTk6y zv$d#)xhG|d50-O)_*vv(nUhW>%Q-%mI>Cr~n)aC)R;=`O%fV;$1S;o#OZYd2CA@cM zSD?*4qHLam6O|0C?-3;E;|Q@{0nSJ4&vwPz4gtmdaW zy@}aMz}O(8bMB5b#hQO_8r~)ZIk5x>bhuyShx8$#_aQ*wOMj<0V$qF8vwOMn%+2cQ zv)C5!*aZ4@7nqm{PO`w_gSouk`BwL&&`aOyzb}6`Mgp)Lj!Ujrpa5Z*`4o51tT&oX zIGZpz1On0>JrL487?5EJKgOIJfJ4+%u&L>cgQ~Dx1FgHpDr9GDu2^(UNfDI9V>}6~ zD)>Hy4dCX;CJX=(ySKJakm%%Rw%Te7=?BGIW@AYU#%TH_7pUN(L%#{&z>Ssx9VJ^K zg4G&miYDXFJ`o?vgA3q4N&zue(sr2SFva5BMj8>t(+va916bqrWE{q{QAe!H?ISzbGHBT_1}ZjqhSB#--Ev% zzkEh;Km6OPv%~ZA;Pfmwe(~z$`0yEE_sfHmH_wh=J`a9?rY}!l2Pelbj$cF1uTN=I z(cAGMv^&CHUL2ks{0JrcKOCPNzy5nEI68j)61zQue)oe{`)99@58j;Yp9QbpoV_|d zKZHpj9W?&GtHMuZg}oa`UJCz|L$4@<%R+3`6-=jiP81@(duhDN8<4>Wyw$Q>c{ z?QMc8`1_mlL)9mC@a%B^1bRHj_GW$F=>OLt0R2lyP$W13feM&z>K?ZvCh%9o%xa z0o05q6Ts6)uh3%x{jVt4oJ=EalJagJ1Lh8HS#@@cFEf=9;Y~ty%jnk%@2z&X{K$-s zPV+s#O)yb`$N|!^scaIgu;f(433Tn!g{_ugU>dbntBBT8gZ^;#o_Tf&0R8fourf-d zP;KBDOUn4%A&ucwVw@Gnv#Tm4gxkXSFn6M4-)_&60)&ZK!sk1Hg!j}zBUJ8dlNM8Y zp#G3`7$yQyZcV;gTrc62IkILvoLzJKi$3WD$zkmH?EE#_IZ=dGKU&C`pTaty@VeRPG7v*e{F^aBz+BV8>2y&tk2*C zo>T5&X5@ioxmAATZM>;aumImCXc=ha(o1Gzyp*UP(LJ&`XjD&`#JLCbT!2G*(I51u zxANtvC)PUu`}t2LyXg7Bfv*^-;u}CZU#YLGg@ltOxwykYMywefMg5{r(H(Buw+Y(& z;B`EVZwN#s4z?l!tc#Dxk@02BD@8b@A)*u_khQ1OiTcrJg zzQdCB6~&f9q=}*KphDzF>w;>dLsGP4=fE_);1OCa>8tSXj5!#34c(734Sz3ACEbyz zTXYW`E;mBlGLPNI#v~DTjWFrkw6kk!bT~djV;*7+~k+1sDM6qH`kf5gC9Y`xZ%!!I;$Bgcyso$NQ&P7 zmJh>!|2s{^kIoJce>i_ex8+wxXF$)LzKXtysT%IY0BfK9aMF4Kymaf?@$*)Ta%of= zo=zOd-sK4Rc3`O!P>t{aSQq^7^1|Iq@o~=(KKy=SFEbWACc%oVtKcyRRZmXO-@wBq z2(99m`>&6GI&7Wo|J>StbsSVOc)xi&3JWtj6nyactHXoiqvM0tPr&={KRZ6aam{*% ze}m^j3+e!yad`6V+>B1ze;;?zEXsrnhVC)nQ=+MJneGv}DgpM*lf?5S@4Ack|-7yqp;(Wk50y9gMlk^CLp{$R70dGNZa?)c(Jk}e* z<{X|Jy^Cl_c>a$rG4XJ+%y2(NhAz1Eo)tr)XE9ZBDtVaaYt_sjKs6J59=e&} zL6kF6Gei1?kFT6bX=bpedAgZpR4}v_M+I#M%VuA>K9S^&(t&?kLIN}})Wf)=Ie8DhCvHJNsSFR^PwS%1V8 zv!)ju4k>%C0@~u~eUwdPxyb`;V(>{e5vTN`{l0%ayAFmk>B7LKneW>DK^rX#$)8px zPeR*6ndvXkzSsMI!)Q+XXK*&_8ND7Y->VdjA^im~*{9;fjh#xkCuwD$F1pf>FP=CiFpq~`~0>d%H>lj76<#QQ} zKWKN`W8fmba^)AWBor!AvX5M@;`<~d4WaKFNj-9r?-R>5a#i0qa_Y*}GCnnGIoh?k zM^9qP8Hr5PvFa7&XhD(w)n#XSxOOLC{y^OtW9 zTCL!Fc0Vhq0@yq9XAuQ2j$fXhQN5^`Z?)P}!7)Nnq42Js2wh-Mcy!h8cH`kA3>YmA zlE=NBgoJKjf>bC1@@%(DTS)kw{1qE&ol83s(w?6V6?u}}UJF75I z#3pb;9CM+FaaLT2uA;uvrxnG*jbQAJxhyb{CP=mRmf#umCVeJ6!_t4aqn8-$f>R3; z5U%3RTj?2zXQ6z5=3~VfsTVrxji&fe8_t?=xp~84qJjQ8}JX z#^|LdGgGA9KFS|(X%9`?VcvP~rkSb2f#h>s5Ap@%$TsZOEWMenXxl=pebr6^N`#Jn zD8ezcL?L;D_LP;F1z*jN(pP+ae-pBo}P(jJ4#EAoY$Df~OmJ#O>eD&#-TOy`CTOXx&WD~UX=w%?)7Nx+jKFe%L) zC5cbQD3oBg#cx@qM)!)FTa%*?IwOK!vQL+R^;lVZ*MD9-YGXH_Oet zXo%R{E~&yEXBMPL6rLfgkv(K{?vT>4ID1U4v0%_fO%1ADYCI|CP6;;?vE#Ia0xXYX3jFZCtG42V)O_o>f=tJBSuV6O3lPbcK3}#D|Nz^QV z;2GI$c0b{0x}=ZhWZN7XNu~z|+S;-6V91V;`d-B3(k~NZs65|dE#D+MN=o^I1N%d~ zO7inxB_ctY&Fi5Zu!>UUW)YET?|XfMI&uZVDIaj7olrp8S7%x-APISpQ0@q*!?ED6 zFn~N}M3!M`iuv60`3>_qbS4~;v81@>SZJKjjo!tR9@%2Z=4vGMr-0Ft?Gf|RJrk|P zW@AU_EvQtYqALc$xYZj^b}wF#n zYFJ@w)I*2)m>d>$qKQ3Gqo-=fx|@c)CMcM~CmFIT;H(uz5jHIS{G`1|2Y?Yz(E=mw zrX0JtmrqA$!_D!9kWq~bvx zi4p#6JT+2HY|xp1r?y20Op`$s6;G;yRv~tnPXL+E1I4>KH|v|& zNF>h@1^bDaqSZ(aW1x`8Ec7%jSYtkhp!^E~XLHjR`<45eSov;V!ZDI$-lXkBIIX;` z#!Q^-t;QD>iHlu`DV3}GO=Wb2e`qh<+^)P)%r=YdGV%|zbFfae$9}-8ri72SDwf=+Asch1J;P+SMaJDP|~kpJVDKL|6NQkC9z)dVxo|?*0aeB>_(y70s-#K za3msSI#I3fOeua*1ExnOwI@&NhM#B$F<024EQHo`0m5WV zW-ChGx6El-vJIY>h5P)WPiF>FP&CE+ZguKZ-S04ZrV2C7K;HW-;7-$D zeeyDp=Dp#ZT%nKL9U$##m_6O|drtR`lU+DfKVX{=09P3gbXBmX+s%h+^WH#Rai&Yn z(+m}4$4{&jo$BJx?>dv=f1-dA-a)PFcIT=akISD{Kq*2i;baiRFd>v`0cAQkKEfbN zn1h3DRK5f$o;RnJhP9PG)>c08Gf3#5=1CEHD~T0^*nr>BT5D(psi$X$wgYnWQ5gZp z?Uyk0_!B;c;Vl@qlUwsKViOKDy1{UnX6j+bCTGu1l;XxH)uITck6>#F`4r3^T*WTV z8eTqsbAnoNo|~UVLR?hyq3q8L0B4OU<{cOlKe9EbhO@a^14pI{D%tav509*AOMR0K zwu}c~Rwqh(i_g?q7jgp zYDfiw#w5jTpvy;w7m-xh*Nk-uUEACpQExKeM`97Prd5ryr9^SeAj)v&*|n-hNKwTLIBHHw(ddM;in6Lq1_>XrWDx@akhBfA9hec!QG=>WfbJIGok@I+UJspQ z72%_K*>BDlJ1#9ETv;?I^n|P(FwJ-!`yX`(1Z*xxNP5w%xFm9ZpfQZpc9{u-gpS~T zVn`uP^E?%Z^8xTl)f3}6M)S6mQF{+5;hR4j^}%@VpplwlYNp1(?$f z<#jP*YM@7#=mh1`m`w%R$cU1*R zr_DVC%)dn|yGs%FH?jAT^!Ko5=I~+wiX24N43r}QcT%3CB;z2-n=M#jc}t_K`!*KF z1fywtV3`xN6F``M&iWI99w|k>h;>9xWsdfrY!t}=Kxq)Q>N&7!A;I5OEeD$>`Q$r4 zm51*?&guv+rShFR`Vf!$12Qk-*c#HN=i`eR9_&%CY;q9F))OAdvui=E%5;`FsoZC6 zKEM0fv{rC0f^j597tf((+Y@unFf4|j%2)({R5DB|)cM4e!2p%3>{Yfxo!O%<5qhFR zZsNWh@%lv@F$}db8mi<{NONSjPlK0lPEH(77Qd^7c?|(__S~!-XhvQy#i%pkGN6?b z9uUC_R!F6dw(RiHZt4E4a%v29pu^O&^08s0?X$)aa` z!6+k8%UH}_?;?A#boxbGv$TYXm?O2ZhIhp`>AjdM$H6@%OEJGdryEb=o)lB)tl5>d zz1XJ``b=VxG7ivGJ&UK4ek@R3ZqlHw<@-yCbTYO&bVN8JK$Z30r=7vKunL%w;6UrWKK6dc`U^3t^M ziKP_Zv}XydN$peFPMM3ciSjZ#LKQ!jb(D9ifD>~CKz=kb#6rs%Dfumb4AZ51m<0Kd z#j?D}MwgF(bHWDa9>zI$SYPxI>x-5*+_}4v%pDdNKE&d}2Qr~C6tyC#7v)|R7q8(x zXewQVTmial1AhQl%B^_?x2HahKF1|a->?8lwfGIeA#M~U>n|qB45E@rrFmW&CY3wP zU|&lx!~<&k9aZcHGKS#Gv$EK> zTD%*idG%685=Q4)w(e4lmR{y(X{wOE)|tRmG7OgG^2DudR4!yy7WTbdHC#~DH0-^z zmBgDn8azmfy&MSU&M(tY<9vak#yn$;)ZCVv*;<^qiru4-b`3_IPi*%n9J4KnV)=_z zk$CMMHLSBGiiZ4M>r`@vr(I!#?_*V^Bm>w;L7)7g=(OBWceDEeqfx`Ggd(Pw&a#eD zP$7TPs>L7npJ9yuy}U=a9pG^lX5UZL%}znF13u1`_myr~+2hONqMb~FuP0%t!qk0E z81gi1sw=rD zpu0D(!7pK?8$5A?4DG4RJs%jV@r41^O9j@jwkllXCE;4B)E3li-fahd2^%Z!KvY|> z1C*ziv{ojosuhoE9vHr-gVaUi@zn-qIHUJS+6~qS)W%b@1*t@D^`R59+6h=WV~r8>nvTZrqe(0ClZq73Np~CvEGDV`_8@r}G6Bdo$ zLAxRHPVfsSm`f6%Yl)1iGDDZP;If^R^SScnV01CaStdwOirw3VrLU#TGH;dd=F2BX zKZLvaTr$1ReLZO)4_hxq#KhK%IheyaYT{LRKB#|ibX>tGaKJG`i?CX%U|u(<$T5{J zP&lFD#FS6)cc?y~$|3b{R_|eG87a5r-f22iy$;o*e6D@f=ijz=8e6p{HCJX7WL+xy zZ$kZsm<>+bf-QBq12uN?xqgR!E}u-%5PFMeS)kQ?J%M#U4o*hxZV-?AgVCilgn&Vy z)pluzo=#zr#-V!3utC*Kro7yW1f&U|&f9?U4yl!eCAqA#bQCOtNrZv625qPuiScEp zI$BnaS3ao%iG_mhZE!Ujbdx~fq};F?EU`v4Nv>@pDGYK=gCH(c+;tlE{DW@p>t3Z) zjkt~|h)T7JDroa)6$#g!qJ)BA;uW+maAMm${c^cXw+h9XQ&mm z-GWy(f(kWsIok}il&-mDUlMuy@-Uw7*8O3WyH|+uiEoie-6CNmcX|Fb60UNObi_rX z@vTv6rU{`UQ1WOs#9by!qSAIGOZZYs-AU}QKsS?p`G{$U;v~R2VP0(gxFu#t#11cz z=g=2_(o~EG#JP*L9xxOIv8?ifcs=O0AlsWHL< zzcUYq)5&dKRMx#z-dAwPj^Rm!u@CyaK49GI_NAmTmG`0e{u68lVPUzQbo%|^(Qjw} zU3nxv?$0jO;~8qq2Jr=^AJwf7M!*~I<93jx>QTEh9Ze7fqUKgjRD6cgJWoY2n^;sk z+lMX(v+ML|=2Xc3z*x!!9)M?u0F2Ivf9wtKde(1^ibS;>qS_%t7(fj}*&Buhuwnc3Ma+eFEiX&W`dqRl_g*x><&S#3B%T^o zfeqg(iwcz27aqjK;_`;5YSbN67FDH@?gUesSc|I62W3qIsNH?n9(G9EQZt4^MxV#h zt(raEjF*7Y4&25RP-cu$x6IA{8Pq;+AgKO&!*j zy7@D1_^Wl?Tm0u*~ z>thL_)Pg}$QYrs1i{(;FEk+5Z{G-elO)a+)C7bdOahWlO6iO{I$XY7(#Y?3wB~gNH z7U;1+E+rZJd zd`ZmRBVZC2L0ZCextxe;(oO~p`wW3iTHGY|3P#>kTcxf7Dvb=bAxq|TDetk(P>ZeF z3^#SViDMqtK7zDpEiSUeMa?f)T-4Ugdvh%=dLVI8{Z6mL#+_b=+jn{$Ht!@Z+PRas zsC_4K(Z!v_MV&iIi@J9b7R7%!Sy9g+25VW-L&%EmO$|P<{3fiWx19wz>;jM8acp|j z4O*?klcQD(6KU$AL4P3toAVv)o93Q}MiPIM0RbkWm zLpW!*qZwc~{MA8+-8TuH$zzmH^(KKW|Z!NBuaKt@XGak;ax&1|-;#uI3 zN5^O9uhEYd-5g7zkc4pJXLvKwclrCX!=wE-C$fpGo&R0-tV32QU_C>CGM(de*DS*fCI_1))od*X^_WQ3|Z-f=+{TDXY@4qk6|Ceyb=l&bvGp=lB8#>sR0U)wh22tzUhg+!NUK@3jhA9nzo+zhC(wnReky=0d??zkGgn z_#7UFLCt)k!3*vD#~QuQWW6I%ujzZzLH!?(U+*9Mcx<*|d!W`&`zLP>Tl>$RA$qnD zk}d2gbY2AWYgf!?;Bn6h?S0iwf;dTHI&APbZ4coM*Z=1%4&p(KgtH_~Dlm-|KFTtlto@LIy=5SBGmfhcU(H)$ z?oHMiq;O2OwJ&lVXyFG32zWkLRl@nL+QR<2t77y^ zi@$FYZH7lAo+7kagNvxPtWdR6<7~t#kFH8#W<>(+@0p({-v0G?FSC04-O&1IrjmGP zec?GlvE7@QH$n!X#f~qb25_G6_n!aC;cCD{UosNwFzhg4iPtzBA|^sYkuQt%#pGq6 zBgz)Nq4mv!qr>LP?zxYN%BMl8yztZJ)1anO7w}By-(Pw@S^`&ep)Yr9QTG<|9f2K~$oo@^KhFsALd(KuW$NWC;3{ z-a+Mgpsw9i4Pb9sGoA+}sSlf2vp%L1ci1 zhf_w&$Z`Kh4;E$8<1Ry^nu<=SaHArCu0RH(w75~ACh)beAwVHRLmSaWvuK_uPW9siM3;Wu^Z z8;sv?NP1j6_tHLr{5IxVgo`df8<)9FPal{gbzpM(wCK4q+ik?_xBBrOJa0eu2Dc5g zjLX1+Ijc=*`3%OwQ(E$tBMhW9Wu+38l&`p<2zaEivO# ztbVw{>W2<*nqq?O`;D?Esl1-f)s}$~Dc0bRaM69YzUS8W-1?qd`kwplVXnFF{y4YX zckU&p);s5dQ=g5zKhE_i;P449Ki@r8a|TnW z_YgNHzip*R;#E9B*C?4B16DLfQ2>A!WdY;Ks1qmT@D7)%4oGhV|L^x&*cRGZS$uUu z-hL_ghkUZ*tV)5DXVNB?f@||Zzw%Sw%y=l?z5=iX`x(FB0Utbhf-s!>_%7<#cP2|A zxrBevbch!)l2AT*0w2B$!ibmyn-h>(3vG6y_)Gs+EdpLfuBjzk>Qpbmw~EB&1~@kn zgjtg*Vj7qN$`Aj+$oCJ?fw~Pcv(gb^(iG&Oc+~zeR6a&x#g((WvYlq6#swIVxSpt?rnf+u?oPHLa|JD2LhC+HXH z7Ep*T;#}D7{RNS8r6`2%uDreI7I1QBB}FfJep0Dg3LCv)kw&0=#@6W8g`BQmvXVfT z?4-|pe_Qj4MUD#Il3+T~Z)1w`VkNSm5}lV>3BL0>wVjjX*i3VWCKESkK0N$p$~lwU zqH>N-1$4oUq^BPAHZ&690Xy>+)hDsaDQ_lAc5x-m4Twz#BA3ZRWa%}HfH#=ra;jzi znk$!|fdIWZIYHJ#=CNO9a*meH9+0&{RyRmTiynP}-O$)gi{`X1`o+LUY&evJk!wid zyQOI=aRi)FpkpI29yHN zp7_Xy5gdUNbY}_g%$BWIztiduVWfT+V=@T^)Bsu(HMhJ8rEUUbw&ao{>yf+`XzQj(!5ACGiAqyo+ zzlv)g;b8~xz8k%blXN&1x>H9O*lr_;F$78pW0i4?GBQ38H>t2Il-cvJ`hJgsqD@B= z6a?_aEfmR|UA8lt4Z48nNzzC21?0vt$_+Ffx6wzRYmU&+Q6#V>ryn-GQUQE83oGC> znUQW#cptQSAnvg(DNjOXH=_SL@LhSf( zwiMX_mY`Awi=WIyLe+f|gyOpf#nQ4~A5`IAS>capG~wG?_*Ygi6g+pbeE5v1@^@bV zQ3m$u6A)!<)CVET$@IQNIhlTXqWsZR`aalc2z;>``ix~gIC=ei)$-ObV(Ii@YbAaC z96&lmyI{&3iu7_Q1@d{jnB{zdXbaFw~c-Dr^V8Z70{%gcw2~*?;@n z-w=a=?E;=8)()!UL3@h)NCH^*&2>O}2Arsz=fTVU7l(!S#o)av0>n7`I~H*o1XX1( zp!5gocb)cNPnGR{YDaS;H+EK1BAvFVv76HgjkcjWYRU1JWV~6~4RoR+_`S9p^oIE* z5*0D{EG>O8?@RK)xrnYu@5+PRq*?mQ)+DU!j6=Frl7*EXdIycB+h5}AW0EO^4_P-vfW}`G|iXXR2lO2E&kXR~)PIK*UH}`le6u)7u z$Nvk}D)434%}pv)E}GY<{2$3A_ZR#jP!p-i8aq%O`o9`XnmNp&?fFRz;yl4im|UrI zJ^nWSXKoVVG;&bhLKWP~oN6x!mI# zR*sC{s`>m$3pI7SJijp_15NIP5vV_viw_mp9#`>4(XiFsRZDy9ylANf^+h#%va71@ zihG?VQ`!uyK1I0j#)UXRHF>}-tbk)(B~-nN)xS-0RfGm^L6pM{x_~W&AxGm@7s`jD zaUKzodW^UcK#=DI-x)=kh(>wQYS*4;w<{+{Kk8DzES?i|*vk>p;Aoke#as_JC=naf zn*d5qFn>zml-E)yoeZ~21uQ=bG?CCCxfPEhV9=|lu&!(=An=blAi_ov{ zLBD7r`t>FHMa!d~ShRZ&c}nZv(uTKm8>b|ou!}5;on}r5_!cP4#nn_P1rudt!M9)# z{G|{zk&7tOtqu1&is1f&KhvsUbW9K_iGBL+@?F{7W-!Q0#s&tdsX-PJen6EH&48d? zqlxi`aUMkE_X1V7LUnCYEK8T`Arw7G+~mopR?J4(z7-<|hKkp4Y_;cs2!_-Aq5-5x zafG;z$TNA#FqZyOz!8da-o4bc1wqfAMBl$n3qdYM?59Sg6YL*P^|s`Y1{7#O`H7Cg zS$vJ+2QsQ4!zf_%$1@UX$Ph66rhsZ_DiYQNBRl9Og!**E#uI%O1WQ;;l|-qMid(W{ zonKYll&JYB`0(n-=EIj~!3ZuC3)RtmQ7Sr7pD0YwiQ`1l2W9@EP+2cfamF&NbbC@N2ri{58$g zX7wA^JL5m@9ZLwzsb;;IW~IG6rRSu`#Uu{3Wq`iSv%Y%yyeIvvVWpfmC5(mwx~Njk z3ZQSBa=mR`-Z0CXy1Z_d@91(%Zn&Q%Q2Ze+P|WAhdxK0;2kqO@Y`U8xwf+0|0f}9M zf(#^M*simQK-iE~RA@T4N>GzkFok&6POt8-VyD{XI@L(lq2$#l#`O$Y3eJDrss*Fr z;8t|q)Dui*gQ+{eH)$0(xTccU!?QzLBdJIpNXaj(~ZPC2$p2N0SbMV0J9d zP9ZDw^2{g8J>1RD6Xu5epkW52x$KjQh0$h7=$16yf*rS@;TCMW1vR&TQ8x8JOOKwO z;m*PdZZDi*J!68#l}A$BZ3DOs0o-~6e>VAd^J`S&ul#Hj*Gom-FF=z6!8qAFMjNJv z1?I7`o42aX!K&@3q(RC1Un$v(5!Vgkl0=JF#|QG$N$YYnl@n;oUk&~+)HRu&>8~V& zwwQObj+}z?BB}C&1i2+*i>R<-&VZ7pJEKtlH`q@}H41BzOA`#1gl3dST@2?~3?g&U zv^@NVP93?{^OMsb_D@=;M@Q#}uUoHCQ`*YQHK=MCB>gYXPhUez0f1#&NwA1zQhI2L z4vY+361Uz3TS4UlX|Ux+PF`$w&3?KjI%T7p(2Fm2>t4DwF&v(Oy6LLS*DY7~|mj)4CmMRhi$)6e9Am+g&^iV`N@|RkQ6lre{d?m8hs}*x#L3v7#&fa}JQqo26PZ z9)_NtFJ#Yob&T%Pv(=S5PW*m4D_;bB4ajk>mK-Kpuz;J?0`Ana)m4sWd?Q6I=wFL( z^Xb)OG`qYa1eUXy%RYLzN1J)%_f^h$UgeC}6+e{Brj*!OzK)Dn$>Il+`GhHX+izvm z{$Lr7jp~oe@l}hS7LQ7g+Bat9R_o{t=GFS)@cA+9qLpU*;FxmWpX0x{Q=DQO&CCuc z$3t*DM5`P&=Q~6f;edF5YM^_*0nNg8@H)DZn~bh=FGv3oYZ^N>R{B3gMH+huyJtI?o3A$ zYtq{tY?z3KTQzR?41GQ4whPs2&-P&$O2O@}*O(4gP9+hyJEWyzD)Pf&XM|Rl@OtY^ z;z7~3T$;6=n%nBFXM>|>eXQ6YEBuiYct?4GHZpH}=;mz?W#0BsPFP?SVa|T44VP>= zXe!(49PTOb>5T3$q^$3zbT@IvXfVIJfThj_A8v80Ks2+m!Oz*(O6I=08&)$m%uK@0 zus8CsbEf#vOv0Yp>XwF>J%FBBE&Xws(M1yY%F4qxA7uDQ2 z4>Ep@$FHtF{=@8koyV`OKK|V8-wBOgxHVde6U{_QYE^F7JvD4Bi|6%Z6V$rhQQhvS zGq0o0@+Yg=p4X90l&f|}RlB2|c^&OobtAi@$nK~)ucK!A$~La4yP-{k(Wb7Oc0FjL z#F^$8u|0t}brtb#BJQH9dlyyZT~y7yi>j%+sCuuvC|dO{idMXfqAhOq8QewNJe5y$ z7d08Jwm;Ebw8O(UKha&Z&%^J0s=Me19)JH+-9-mH{tpj)7cD*hGamn7+3_<(l+-q= zZPu(=Q9MPu+jd>k4R=82O=XJFG0dCYo zM!shs=thM*@ypErJVlquY5D4-`2SX_ji~1M|5hv8)wTccm*W4sv2_6diTuwJcRWtO zVHE5Sr&pulZSZ^&$3rvwvo8m9xU z9fjA9!fQw2wWILLj=~S03%WPN=cMoye!YM8{O~pU`r01Es@!b=HRH(y@buBEL5x9% z;P?Q3OPsbSuZo^Xu|RJ}GxQFgO*$AQ@J&K>p;mtgOijC6eq^R?rujaPhcOTxj%Gsh z<3kwSYsvfPFY?$U7TGZ})gRRPP#{cM&s&S@B~($>jEA#pZhz6IfLS=?(ec^&Ym7xq zp|?aK#cUNnpX~E@`TMiOqy0B0vWcvn|6TU1gL=t*!#W2ir{{0rG@~1{Q4EOu;??O1 z`gNZl|KGzPY*?RP?!P|%>9BRS|8r~q)p1bCtG+)e|JSH}`yp7P?d^IN|3~Z+@PE}t ztx^Zh5BR?@+z$T~)YtsqC)t0b51o$||0ilx>J>NsPbJ!3^Z#F7{2#&`U-+MN;GgXh zzX?9F%+CxrE(0NOV2?9#u!NOECmOFJxTD0$;syLQpHd{<37ttoQ zR^p$`F2cr~KElRwom8Vaom8XcI%(AAbkeBpITr`Q zR;+SVD#5v(P-ZXllSq4@K8lnHoQ%`@!sBCFPOCVbQXwD6T(C4*mC43B6h^Y?>@=2E zC}tx+is+vE&^f6n0I*0K>Y#yN{YQ`86r9L{gPoXTF6}n zae`mZPpEtU?AEC>H8(J}!Z$P+7TEgq;cyY!?`G|8HCkbJDLHkJ33=ZbIw`IDML0WT zhCx>|Tad|o5w18(9&J=s^?S^`?-^^`y>J&JpwpdE=gwv=Rl_}gd-47LsE*=1x zMK)ZPThF|p-{wS&xZkRyyJfR>=kY}(wAN{l)X(E~e*zHO3axzAE2M&xiKyw8*2x^q ze5R4g^)o+}??=f*ed%PFX7}SXh5^3F5^{Ym?q%h%Cd|r8FhcPCj*#DujxPYun~@O{ zUndC2nQgX0C(U%Ube?G^*Ybkg*y&s^bmo`NnC;}(UXUxmP6lv~#ian}bhca?>N_Xj z##Qr!CjFk#(^-IbnQ6Qik+Ws9yX2P3O|9|}JhjseXyD!{8+f#OI`EI2qx$Kb^aG!F zKI*5byt1ohpSCw<`LxsDZv17d8+QgX)MEYx_5%yz_b3v)ird|If@Sx~P0h)up;vgX zLtk#L>L5E=H7P{#uaet`nZ}yGd6HQ}^{4L2p1Lb@GG0R!b>ZVcb_VRcld@K4!j@n3 z6x{@i>buqdI%oDeXZ9z^nQf4CnL61_qrFa`?IzG(K3DciNwRf9RyRpDQ=CtnB>N-g z!|tOL*Mtm`rXjy(q5X)IW+j&3_WD-F;)Ib!h>6?O?)=Bj=z84lpzUNAErQPbmse%3 zsK1Td6N$|jTqXERAuNqM#nJ@WAfR#q#Sz~N{sD{m3;r-1jrU|9tctaJ=)=LG02-pkY9Wsk#dVC67w^x${!# z84y(QuladQ!TT`2)tC%41S2%hmBIO1Q2vZVhg*oFT+ znmmFBIxc`H3;e3Gj2HLT`NcnWe(^h``j$dEE7`X!q%7a+m!A2{JyUvLQc7014wj_g29o;0jR(%^LZSCRcS7#AG@6<%Xo2y`>C>D@F~ zOKGXh)TDRK)@q0+g+v$owB)$ovlc_P_rXN#cPI-qQvjhrUcaV2&6ArVT)9LgP7@tx zZ;)Sjyv#fbVetQ`eo^hH)0wQWWQSZ;?ypCVt5)~BgfyqD%3hq4SXvw{J>QJ^6m(t0 z!_dY$BgyVuyk9W*9C*wdUuheD|4=#2v*vBdX#bUw1RfEC)fvF17U%0Byi2*S;%(0C zO}X+Hm!3BNr}dvdiUz_uPbaVc- zLI2vIf1LyPemQ_M0^W*YPLIyv$@)51akBl&@|q_iD`ogCm&J`xjY^N&?;ml--^iEo zw`ykmt(h5r>qf?3%mvI!KA8+yXaAiv;oDNVe`UOv`l?xg+ud%TqU+a70j75dtX#m! zwER#0R>Pb+)yOQWVlsegXck2^EUK7AVFQ!#?3hJ3O4OthF)}s_tr8qgW{wc^l%FPz zs_`*`UFRVCHTenqrV>>d$ET8pEUC)S{M)KTTCddUilnpjdG|pA`r*{u}%Z~i8zByKZg}6#?PVn zc`L+PRT>S33VS#dMgkwkeHwbFUl;xhi05>o`!H`XwgfEmrqWks?Rx#J;WflSz?PN9H2Mlm$O zp%JK0Lq?1OCi*~U`LfQXX3eBEy%>nuT*lMsM2s)?Y@qv$oviS7|P;5?1`Ml_`cF6i<2&k0%*;(R1*kXW#{u z*TtzzVTo8oR28&~Dv9JKlA2Wm6Pv0Un=F*Q3wG5N$Z-Op=-Hxwa^%P!`p$^lGY~mp zkPGer-*Xx0oURxyTQOR;Vs+VywPh>Tm#x@Xw&M1(6`RXe+*umn%WqAXea8E{-ZR~_ zPeUd1NcTS!>DMGD(3`YR7}V*2950I>h5`3etS+ZC#dD%2KLs4uF}SX5zq zQHAEB3On8n$xdjwGPlOGc1N?0f-QzNkz$JL#&%UB&s{()rbG`)+UW3OoPg5d$0#$V zp!sGQ&AzJ3WR^uNu9=+MPMR~TWPE1r&%7EU8K%SCxqZy9A+mb%lDst(hgfwW_D>JQ zu6V3D(`hbRGd`58(^b=GBr}ut;DH1iUJcVsl~bEi?(maK)HV;IQ@JO)PPnrFnseIx zll#9|rvEFhd$Ua4{;qrm8g(BBM{UfqTE1%{Pd+>~nGQ5ZX>M}&%mV6_C3y3FTEc^{+AyRC)m`&7 zPpq*0z;6neJ3@eno7Z+zZ)N%5M^@0E-m_dT)4z?{!W^Ep<}%4Qm&>>b3riQ((nXP5 zL?&qn>IIoO<*`TnMGT{JZFRP!EinIFePfgyvl{ zOX!T&tyYA&4L7r7KUXLeP{BQDU&MpJn`v>YP(FEea9-Ie7nMQklb}(rSL;PaXX$1^ zw!*p9I<$M@54%7hCh_3g8J3x>X`wJD$>Xb&*LHWB7p!paK%d^1#Va)wFEvSuco<=> zLDyc!P_m*(Pv-I+@`c7MY^Y#Erq$@=VS=YD(o6c_>VTD+`dWIM;6iWEkdIbrO$6=9 z$;OX(UkL;$zQP1&d`HXr1Rzmg8H%Gd7MX$vfu`Cj5t+>BSvIm~-i#()Jw&h-q}P&> zP19=GU))k;*K`{87B@6j zk+Sj6mSIqPa|s)YS=qb}{|3m~IygRpkq%Fuo$C;Nfp9c%LHo>rCSF)V zI=M1vS5HJ%jXuLfWa~elh5zrk4S#?7{BQNJzRv&l$@c$U^C8{87rg(%Mz!8>{lCL% zZTFFMu>%!<)y5I!DR{5`z(KG~B=8Re6qX zwVSmfH9lo!0N}V1MFWnv@n~>tNAvyGYCV7X=AhNe<=HXYHQ;IHg$Fr4l6n|#v&FGC zWqB+0A@7##=2Mk+bC$8-*P}`a{tEH0NGe=tp^aKDAEIkFM*4(mtOKI5zFEi`7u8p@ zMCG~8^;mXJmNL^IyvXN&`6C|L+=G9`c4w7@LO za(Ux70bTW5`9%1nC+&A}?(1Y+3br(c0VI+!))B7h7ez5FcRZ&=HP?d2^rt!pgQdvR3I-Onf6ZA z<93)6WH88m-LHsdeL|cNniab7pnY2;w}jj;(BCGWj$f@_dxEXdK162S%^KAXozmv7 z0*9>9FrwnBTil@Hno}HAsJO1?UpJRcfEV+ZQ5s?4V#R=y1UO-*$C178E|seQAiwR8 zgD{e^9|X5Bxd(83<&B9i%;WJ6$4K!d5gGw*SgRf|b<<=D6Gj)Z-*Vm2kY|*q0|w<) z+b;>-b4qPd4;$hM`~{l-YHd-vEt$urTK7cj&B~(oY~!jr0KRACF34O}^pF5_(0U#> z3zvX4?~F+EdU#{>FuPL^Y`SVp0)J6`pxxhcvrv7^?$!qzl!`u3@`eA|J8A48| zz+;pN52WL4v0;$+)GZ{+OKznt^S*%Vo)Uu?6k2i*IbD28{qxq@;q&A3*N11V zSLcUso}IQ%U%|Y~5)e5Uu@pQ`I+Hd~W_gp-Ws5#sU%`}L6PfWk0! zw9dr_MmiCmIjr>>!-BVi<`!8yT#R7b+LPO|xJWLeO^@^!FO^GqUtNZLfnfoi_DlBT zrvkdEvB0{i@yl2E4~F(vz8geoDwFk&T$ z3&imk3dWNW23be#Ntre!j=eeilyfKT0E$WgGcgJh z-2@{yObp%wbSsB>UlnohiyFCr(6Kk(BF?E_@wRdA`&7H0znyc>%Z6@CvwG-*MK%{**IUWFQvEZ}fYqBNTe@(ksz9OsLD&2CCgPR6V`!d4z0Q$& z{ALEv&ha;8T^YRt0_#SK)QzMlY5G!9pGuypTP|I;-+Ss^`}4Vx3VldUDev)bRW@sL z>8vfvtr%p`yyi3~_9fj~G`3=%(WP*9+B*D^Ef+I<03OpzNf{<)S1CQdne?Zzac|IP zGT`PJVbP;f!0=`Pw`rAzn-d%qKYwchNvULBkro)|q{Kvy0wfFMD` zzgp4tg{W6j^=0aw_C*5IoW@0u_rO<9 ztDvoxnkx@gQ?kStCpTE8FMAgpfclWeFctmEXDMneg zqEy7&5ZwW#A{V6=^!33}N}zP~he0Xi89tD2-rC+{IsO06$JPHgJo^8}TL1qA>i>8A z(cdc`UH%+ZextSpr*^H;Uu*Q&8vV6K|BtKDw*3rwwEv7y%MbZu$uaW8+M)M3BiDK4Fg0|8hYnL?Z}Zq;YValx9;Fv8 zR-GDrhX;>RgNGF!JxYxpvSC3lN(~>f5kU__!iT##YwLuO0;z)Dr_B)}x18b5)(h`b zaA)&{_bIsB_6q?W7{pEs$>$m~+}|33P4nKUTB_0X-#OJc^M*aH*j7uo+=SV-%6&VQQ5$C>~IS@G?87D zS=i2HVPv8^msRxHX^OI)hAIjfK3h#O0&!}1*NWnbUCis=+K%kv1{XJKc5#!7>kX?o z5<}MPAtNzl%^ormLssn}BQa!T4;hIeLwm@oT;;=<1B9+QfIew3a>X?b&|fzxPU{j@ z0z0OafZ02@|KtV(_Wd^3azIx_HsCUzEHW8z`)1n#+SJOD#sj`CQhhw68G$(@s-xLB z&OflSHTWuh-xFtswd=&J^+ThmMtogAGK#9i0`{wdowSD0MfJ#H+;v}yXV-lJyPg;O zv}+8+y`mw4v^#J(gcX2kz-QMxOS@~sB+Fx^u#;`2uv79>-EuFgwPC;qFbvpknpOeL zwNb!gqkvwo|ELP+aQ~BOC4S2t_nZepLU@1MWz^E_ZGGKL#id>9Z zTLwHVMn#@nqiZ{W51{{l-~e!o;=f_c2PghpeY>*O|F7e}-6#GVUI6Q$Z)-b&wVlA) zPGBAMZIz&J=eO|XI!MNtNWI^&Y3x$*$>fry!DgY=LfeBzt<@?9|Ngg8Obo}nouXQ= z>(`-v=Sdn2;O7`o?x&{y>D9@bbM@O!I?kM9{*e`S?x!8`?8vOplu$8((|x*VbDnT= zevchrXu7E8_~rO2g$<1c>qvDUhW{^jK9>D&EsAO`{~uKw;hO*d^6Y;JaeSOVCL+f$ zV43W{F9;ZN{#(joczbJ++3?z4c>NAozXR6qfX~@p*fj#S3R)e~&I#jS`5~Eh;g+UC zX>UWSb~51sOh=VJ93`M-lzKTy;_C}w{-x39Xo$E^Ca7eQic3Oc(hH!#!dP``q;8hB zo8Kfx915KJyHUSu4~{W7kXi;CENKnm_fz1<;x1YN1RMBzDCUt}Mw=AiNrQm;*w~=v z@34TI!*65!4ST0Z)1t~Ao-<54OtFd@Xf4rA)J%n06AGW%NEl`r;H1aE81sTR(Gm(} z=c8T$CQ+0flBrn&baT)J_#m)=_`*LIF=_UJY5{C+s9Pg=Qd@*F0lvA!ch}YECVm%B zfFw@=UcEM%Tm55}Oa);BT8PvIXFKg*$CxV_!O;r}0YYc%d-`jFYu@^vR{r#9D$8P# z7q)>b2sVmxg#~=L6uFxT8EDAW?E?)A30MkNdgiuqqye+dr-2PA!M4A_v(^H-aeVZ5 z?*G+n0@nze>WwF(i}r=ES|7j_i4+xIoGu=g;9WLA^~X)ju=_2Zi~_v5h+JRC*Q3d8 zS!9JQ;2buJIIrR_m0$6NwdWRx{^H1AT=f^%{Ka)qET0!}vk}TdDFeK%0gfOp^wk&o zivppPxRLz@3JArMJvb3Te``zB+T1J>SpFrLBHW7BH24jM$T7wg_)HWt5oIOI6CMSg z;&Zw+Y*D1Pikpd?+W(TjZxqy<+rd%mEnX~a2si?IiKf2=4%$)q@Awbv+N^=Fww^Gy zQyn3Qeha=cJA-NFplQxG3KR-MV+XKB`bJ~Yzi71N#QWM6pK#&cWp5Nj8e4nCqR|Bq zo45K`?>KMVaWVkBQFwFDkvMwTl1su2x%XO=J<{AoEgDPw4kW5Q8%%Y#EDkz9JbPWJ zs8)bbx!)zKFk%VR0K(H5-xhG_QXp=oQt%tK{N2Dt{<67A2qy{VZ+m&JK+h1Stb6(2 z$=1oeD|c47D@)jyq)b>cy&m87{)DF7(*xe6D!IWYzbDj8e78mFV>s_)H1A_|-pAU! zkE`4zNW_+B44ym@mqoe>`D1+_R3rOV*{}&R|CLFuZQeq}U$t2U6A`!qqgyBshIv6& z7T$T_hOq%G>uhfM(cmFFs5Hh;K&8TqVH( zg$H=1+Cw~L6i^d6$#EMkKjL0IiH9VJM<<56Y>Fg^>f)QTBRRDtf^Oj-i;xkO9>HsO zIE&4@7Z(O^zt=yWoxXYgBTd!@4;j|(x~0r5?5<`5YxSTj?;1=8Q^Rl%=k;?eId`Bb z*Q067YL25Qu=GOG*Y#2>u?AUUDR&qKXIG6@SxYs#(^{-SmRQRjhLOikjzW$f z*l~f$Ku{}E_f*gAA5YI23Cr+_idVBHLi6CKDIxxu!!UWe((IX^J5vZvTyMOjl|KY<_ZN#-FS=~E36S&Rv^9|VAD`80$4;! z(`kD;OT4Zi1rlx{qigZG#Dmi9EO;Mg2rl~aqWEdYzUgHH062FU`p7!9TeVYWABNFmlknjB@{z`D9 z@?J^tZ(pVOH$W4r#XJIRhXoF?GE&G1?`m?ihZX*F)}P?8aPozZdEyB28sy(sf@Q_; zV3BA|vbOWT6KX4Q(h9-irUL2aY4S+l4AlneEHNT{s6 zd)NHzSJ>QWxa)%=F7+2 z1e)21gO{R>JtX6lV&7|=CJYdv=pioyh1IU@|-gy=1Q3lVYBD`yxUwvE6*;rI`M32X-{wiH9Q< zd^1j*lKTNj+*L?YD=)+BYt_L(q<&8&^}|ah<5`!phPPm}XI)+XdOZ3Pvt({FlMT&g z9kcnpc`MFb7_^YWyy#4oxvtv#4$q@KYPxVYzYP zf@Nby2dX|!*W%05t78e75XFm#jny^Ix!VDHHi?hgvv zmKxI+^ac4qnNR{bryEk(0>?)jeOpw{5rY9;a3kq>H5FQ2$=zQge>fV(YBvP0Lz9}w zNoo0~m#=^7;p<)cmb${fd&+mX0Fek8)unfDXEtqPXb+tlq(3d|9tPWZ7Vw=@ zN})7GTA@^&-BFx~_fYWlU|WP+$!WU7nm3|cVvYu;nLh0_xk5E6Nz$@Wd}1^!D%3O! z9XW_C66>X9+r6O{O6zWfO6Pq$4$*S7w+H7HAOLp`2I1&$W0bV*oFU6H+p@;z{ROqH zIBiGRwx8LS6+-VTRW|7i{ta{f{`(-T?5VeFJiY1%UtjeLKr<=JNmgI1KYG8@>r@)t zR{?pR%KK`s$C9~!VDh=kaP#ZINc1+^&giTrCKmF<#G*Lqm(j#eddLGDwcKWpq@;4| z?oqdd*;cbBsim1P0)a8rXbrpNL~d+#uk`($$m z``s2G7*98S)$U|mwI)yNS{7tZ$DN9pi0_IeHp3A&WHLB8?_)_fEupSg*gF&@49wr* zH}luxrockY00=v_cWAl$E}kUqIc$R;rp`;+Y2|r6XFn=5)2suX5r^zN1=97Jx*qf2 zT2h|Zl5$ZS@Bf0)d_%hFXyg(M`v&flE|rY?3^;dLgV}ZYkNmgjG}-{xVA8@UCGH30 z+F(M==G*+jbke@IRnx+N=ZTmvpbl0cAwcThhf6+%;V7@f7NY@b8YIIG91ajmz{}~# zjv~k3ft>;FbBZhvg+Z9MF9r6Hy>^=f^pm(d>#%Tjsz;!!@ZwgcycE*lc`67)u=2zH zGjzWqi<@DZi*XPIt4V0^Wmm0*HM%76s_W*y9(R~^pgC|=!M1eT^=1PuRjSJ2HGxCm z2%VR8vq7XTQr$PDWrAvEy{dars~cJvnL3I~+*EE^`xRA-w0q*1+BG}V_a0aXEZWP0 zZu5T7ZKj}Wa%)4uuI2o!S{mM!x@wHe@wJ9>Y99HauerOSX79viAcLYAJkPE)Yhk4= z+T-}D185K20ky|C!_Wav1AEX`Me68T4{TKmv;ntoHnd9B>4$IXXZZj>Vr~RZ&M`3# zWz`T*rZ_rMoxoNWF3*)Z=nfAs6hxtznvE$r>y+}Uc3 znebxe6?j-PLGaPo$g~;r%60SE=>W}Z1ZcUuMgm8o;~e(O@g!9ya#(7quap-#7Khr7 zOB*V-wd{n=8llo~Pw0~nNe!IcV}nEPL%v3=PTM}&1{sNIWjGI9R5~d1E91KZy(A{z zBxy@{dD|o-acStAhHn$D$AL`gtSAR-c`s4ld;$zQmliFoEU8c$%2mV_!bY2>EV{>qC z5W<_AzxwQ57A@Yk?O$S9GQH%|4Olf+R4ri9FlV|AI0vnD8OT~Fz$3)@I*5w62NeTo z6uHlz$5wVCC=lQ95=Ou7nV&-Q(`LvYO%RKUW}{$>tz-mNJ2o@MOHiK^ay8r%)>C>b zMRV2z*&sx+lu`=?-#R6!>8jUJ@I)=R7;FXU&TV-vip_`bMsH)2ipj%PFqwfO5h?vb zZOa#XiZ#$)Q?W0;EjmFVAsh>HAyeDW7MeP%gu2Jl`r1V|+Ri<0G!6?IZ1l#Hhr7n$ zEj?}}gVD5g-G2Wce5XlliiRa(niOQ2sIPP{5ug^{P4h%_FycwvOOr_{zDUW9%$1a65c-Px$wLZP{MJ(> zbkDcMC-$A9Q04w4JxjJI4RJrnRg%6~!-nr>U5!av0!NKLyjQ*iEGqT2z!^Kn6Ji`l zxeKC~d1HzI-%D|El7m}e-FM^;b3$X7I!r#C%(~Xi!}Xue8>|EMe4O|{D8cylLxjfJ z-mYiG|DTuu@Ouf8E|*$A9_* z#ea%|*MM1*Hhh_kMfjX!j24p_vS}T$X&td?9kFR0vFVG6*yIb?WR>-YQ@d;iM{3%& z%P>spx9y9*r<7Gho)4ojYFSl)C_HPu{v??OVa3P*h9{Yly&^x3-soD8fk)6Zvt@m_ z48i&G%?o^3w$2U#++oG^4Mc0)N&7|xjbb-0GJ?d@ciBhZEUUed)>Vw27fw(lNa2vP zXj9o``T=K}r7L>21$e&!oiEZPQ-&94B7~NOdN`xWMm0Q9RC%cI!p_1Ef6EcGlG+? z3ga4P&TUU7?OWmYCdH`sQ4q$tmVqtK%rzO2o`V*)Z@A)`yfP4zzI1cz+m5le6WFo? z&2jxwlF>O{M!Y>QM{q?ms&q$X>$z^Ir1QA#{SJxV^FU&NvujO9EfINHpU4ehf221- ze^@fk8w=sdgv@hn$Y&VyUtzC+5sW?3hJ6_qLc^UcplMiv82Upgbrx$2y{=<#yq&yR zt&?-h8P1vt#W+}DE}m}Qtk{i=k&qqOKs%nCyuvu%o~o}-q3+?C<0i@2BOGzbSy!oO zsu86L|K|+3w<)r7cuC<$9ghxc)(^F;Jc)ULU#hE;V-d-T4om8W};CF1Z zXVivY%RO413;>}QXDlA8VF&7qC5m=5+2-_hzY>bRaeiMGvljbVW_rQh3FR378#QD8 zsvw00Ldhmn+dg^vBHvvRtbvFck~7QO#u}?&Q1DG>AaZtGZg}koO_=sV_;O}Ik$&eN&XY{v4&pvQc{YI7(T&o*S={qAkc=L-;I`gsnn6R| zkDoiV8;YncPNza)Y|J)W&C7L2B|V&7%fam^SM;@SU-?-kM7I7AsSR=T!BxN8jdjQX zq06;Hegdnd-GnH3g+BQx8xhtK+VM!KgJbNFlSQXI^F$a1gI>=jLW!*0kUAuCxxh0i zoSDRVMF4MZqHY7`J)TZl)1ov@|FhH(?`FER70qxGFM&tH2~z%W$SKJ1#EcA0b8~- z0vflmb3FkBo{_Z!w%n3QB?T)>;Abuy@691?+7>MA0yatIYEwHnZuimoc_Qp5tR6)` z;Q^)~=}~w-a(Girx&kj@H79a=s+aUcl0q|ZPRe=Oj#fiejY958f6&H~@}6G848gtm z1c~6M91cQ1_J=JF=JC|xO7Be0ZM8qG!+ANV*naYlUa)6c_G_SMHT{><5vqof{2(%5 z1{pk6H+)Fo$PZ14fqa$YUYBitMQzMegP!hL6@E9@Y6Uc6?Dt-j)`q+5%wS}ED^-1@ zULp1rEZYOvF?R?R?4>iEQHbcSHjfb?vBeJZJ}CwBqz1+la4RUxf657`oxJ6-W5rTP zFH+vKdN!7GPLZE$q_@RzoYPo1>FUfd=G&hSgB4l0nODtlknueh5V*%Dhg;9zGnz0X9FQx7`1wkjlo4i278QtT zWbHm~|U zv@)7u#9Dmr$%`MlK_R}%In8h_^vi%|!;uoM#P7$0ey7i=t6&qRz|UM>1(>;0Szjq% z{sRL6k@N_n5fC`)q$p0T2uf1upod37_9^1wT~uWl8vDxgU6k=Ai0Dgu zIx*7etMfv;6kL=T7{%bf$+%(?<7qj*z789$zf}r_b`iTNaGfH$n^-l%LgB)yQ4}yg zL}d*w2_tR{`eHqZGQ>V*oz2RxFa%DmQwpwNYRo?)gOi{YEPA-YB|@x@DB$%i>^Mw! zoPRtc)&xrP%gil8V|3{dAr1|^oq1)}nV_>m$cfTR;ivLJPD#K6%smfCxb-QLZca<@ zhS>1`I_>pNfJMSR=P_Z|tCs7>13UKghj2IayEr&&6bkn0wWB6NX)AEPdP(ACJRP?$ zW4x>jf*tor2c;l8J7>ksq&*%3FKT8eD{~_xC8R1C4CJv!7QY;v!hy#O_FB#l@Vy!h zx`~#y2%)*;Y&Zo*mjy|t@cf3N#-fc>mpWEK5k=3T*|W(o%TdTTNJ*M4Q`(?#joN9L zJCGlEUtPB;-^68masi-Y(nJ@FzDDzYvHVImXOPx|M87Vn3h`+`90O{>8~9D1#VcRF zc~&xYw(Yv_^5)Kz5Ae&&K$rQonOGP&;8d5<*ZKWkQk;4z7<%9Na11aDV_V4l07))q zZL(<~qd3HW{VM9I=a-=MN>C^#0RK6%3u*7(-IMfl)~KNrQKAwB`4o7eQY_QNq z3k8pcu53kvH=uY2gY@agaBEJh4RI{yNH~^$JKyQuycT&ZBl6I=;iwk> z{cnTHFDZ6dMdpyH2RUc;9LeCA!en_+I3k9*;sxUjnA0$y@AX8&#ElKu$xzm;0J-Ei!GtF>sI|MiQp|J~R+fd7R3ugXHc*a{deGO4zmVH^X_ zPevSa0fhnOwJGr06nJe4yfy{?^rpc40y#PUfmktMIuBpBepIqwx7=+2HRH(y(Dc!( zL5v0+aC%S!C#`u+>ZxA8l-%eRmFWrmMUJ{CJs@Lb3Q+@0b@@>$KCl>a|NKQh!@4++ zd>mGt!4PQ4)M67n${Q!Y=}$`Fu%}zb@Q&g(7ky$xamb_Nv-8&|X{C%`q7Wsr^5>I% z{w{xic6hY^=0rA;we!Erp7k?FTvov|gm+&D=8>YpV5R+(+lC_^oSdG&fwLThd5<#3 zvQH)3X%VV|ADJa#{4fl*uB#CeY8KW!4vZ0u7j6^2IF?P11G6rio)@o90jUqESx{)g z^SfRoCchqB%-9Z?Mqo>>#jUH{y6Utxq7h}ywq}2Edv9X5q3AZy5vfe*zTAI({L^9U zZ2#xh{;T7ll9!d%{P*X`|Knff^N;5Lw;k0Y*Z;3tudn(4FVFvvF~`UHhaLw&E|B^@ zWd5YWeC-yvehaMM0_(THXZ#khd4A-xEyqBXXr%lFiSb4&RaQU%I6l$tnK2 z6pb<&vw|$)FEk2vL)wrVq`;Ubj}na~W6ZQ?*axdV)k{5Jg~tf*}y9vg2N=D>yEgES-EFhpG=_5@>sKIYhsyvR>)W(g;QvzG!D&p^`6| zb~LE+tZYqo5QkM4z-7Se?^gO`A+ce(g@T>sMlfMpzxFktRoTd!83g4d=Ap~e`2DnO z;Z-Sk)PDb{6#NCq(j{8+=~k?3g?F_oxg3lx299a2`l=0V3RZ<;-uiWy5d3)98C_di z%M^L06*_+=6;%befYTRnDYcB9pemt0cg{|#ULtK+2v>FM=;i*iXJ__6Rb|IJnzVs* zd&tHSyx9ejvfGAwmakvD@*b2)7@Bn=e;s3 zWlL5y>eThR(%=wv8U{{v*bsR##rw>srA8$+rjK%i3Yywzpp0bjIW7eQ!(McUll>qJ1vbsB^OsqWZ`Q6QCIq=`J;7N zZU);aV}5s2&S+vra7DG?Hn19lX@5MRhhCGG4Ns<|cZ+4}9(e)VK zPJ*XV;8e$4_)z(`E)siJP^;buqT<4Jo-e=+fqR4-@X?Qb@F5FpFb^wiFUpWDUdA2; zEsF8%)M*vYAaLMXonE`8EegzeAgW_%bSn;~**Cn!eC%^Aab2*Vq`5BXM~UBEe<${W$M_mO5r z7Go5HN@8NLKenlj)xIiH5esejUWvoLEq4Xc2MBxDMfqmi$VO` zG)U8#@(J`5w+t4KhcQil$|qcA)Y{FM^U0`f07KsHY?7o~+fzF+;NrQ~Q>f#qQ}P$4 zP&E_OH;uOciV`2LgJAc(Eh3^F~Km zxU-wj05h4iwv&F>=DauBoeJ*nh9u6wcvASda0X#+k*?I@y({YXCDe};S<-ioCFCR;RE zhJTstgP4r07wnlI#j0ts^q0D1|JyfjHR>cRS)eL}q(A>8d4qF$q3%L})0ORb%N#v(fY=%B6lemLtFkr%?E?MH& z;EIjglR@7-kS2q`43i_YS;&%#xeF#hQG*_Fa7c)C^egQ=lJJ|^yGrMs;}BqX$qwY^ zJ|i+X!pwbnH5zAgaDtQ}+vD!Z*}_>#B7+k$m-l<#cmbcD9WF;D#O)<%z`dx1Hpw@G zOi5vf=__EZNY9qZuC;|lU$t<#YSD7ls>@ZYEmy6+T(!n>)wY+b)?BXIj;ERrfB!KV zGtKbrGCg79Vb>A>l<6_)h?vS-w#W!YE2*Go<#L%Pp@oD%0JVJF^e7t-W-3({E7(xz z;tH+X+=nKk5*YM26g$E9o;}d}m>w(MP7d&!|((loOHs!IY@r z8ZG&|ey~gEm3X`Pk!`+EC6yCqMlC}iS17pd|EBQ35t|fIZc+@M1Y6Bw$~n+{=wwB& zLJ~e*Qj+!93a*eLB|~XHqBNi+T~THjLg~&~%oL@GvtZ1CdvA3{gW2`a^Ib|i!U|8( zPR3*iaOC_@@@$HbvIGZ%J_|&p2*bJ^NE5`_p#zr>67CCmi3&#?#5pJc2{4 zrP^F0gQU=F5djH(>?XrI^iU#s%AG)0vhxv{pp=6j;!axx2DQCS6)gk=OPFPE2an(( zle$IV5)wQ<2bpNIpO@7QE1cm11U8`14#rob;jK$2X{Lx|bUPapvZM9j#S8B&)YVTj zgz*R!q|jT{b(_p3i}N3vX*-JSw{lon zbVeLLZ^0$#C~UI$6yIfNzpE_tlQz@*Vi!Av!4OD747Z3iD=n^YX|E;V$@mgweyL`D zsbzktXMSm9e%a3a(#-s_GnX3UGo7sJ7GL4>Zt%N4n9@fAUQNJwq_}T-JN=AL1h)TU zvll*(GU$|*Vwav1>VtLPc@RuW|0NZ<`mb6-@cGV3@@E4F_GR{?+ zVBELFyiB|C81F}DDNJW1CFJ|M5GUg@+F|u(19~PX?+yDR`d5%#4Z;TCssxjO)t>!< z2^4-Xh&t=uqD^v>FfH-o$!@UqeK79Ob6`?3HQW^#9(w=BgkDy^JNyrH^bOulH`_7vGfK85hqdWSYTQpy1DCE>v$)Nw3j=ulkiLBD;0-X0r-s=#T+NJdx! zc_3!Abh@tv`Mz{+FRlDJK58AE>_0zm0Xm)Ka$!z92}IhV(Qt5UDT`G7bHI<+xm>h# zgX5P_z2^DwjJ`A_Wxf8&XhY$@M7UvROc;tQ>L8iw zrRb^42@c>ZuU55gi`HgXKw|@QZhO%6dvxxV$UTU(-`8&^<73H(jD-28@t z78%GznY~(vwfimjPJ{?0_ae-#O^MWH?kC-n^FNsx>Ae}Caxznlfe?V0VgrrRqLCje zP*z4g)B%+!sWUTLKA%xqJexc^)_gxGJB&Ec{jqjCwp5nHz+LwBn9Z2*cluXoNDW zQHnhMzA!Ui;7`qm#^in>>O-n_983soT3|Y8y6*Bax>$_e4}GX z-%KKlAue-4;B6NED(Q+lubi5c-VJYFzNZ?K@Fqb*W%Xq<0ec3PE$lD30;YLRhr}hU z)T5xJ8U0cEza@H$RQTpaJw9`~bSirH-$_s9oy2!{T+&h#6_arfm=W0AN`w_;X2Jrl zXNfde79SH+AZ;v#AIetzcPh~#we=N_ZeqQ3ekS&%X2ubpa*kt$RXH!UNg~xkJWQp) z91TT?Q#&omQ|2->C$kdUV+V8=8ZcVu#Eu=F#(|>6{Mc;hwTpw@iaJ7=1 zeHcD=LrsU*W@ar*a}HYnVz3TDig)nv4S{4FGPnjF-QpVnyG$78m)w74Ln^3Rj7n!? z`c2)ocGn&6~P8x6i09i%HU`GzqqyTpMfWXKfAO`lLA7P#BTqJ7ZCIvHIb5Ydf zb?N$95t{`G)x;p1=~|cv$;o&mpU|EhN9HjUK$1TcorXqcqjU}<`Sc~#8$w*1=|JT+ zk-hXd@V`m5R0bA7-kF3J<%Pr|nd^4)RwS&^?*rm$Ft|RCy9s0;S%LQ`L>Ji-u1D_% z!D9uPNrgM12ERnVQuQuX=AtSWH3^4OPZTv!t(bnO7}=1xuO|0ZuXs~2FMi0oPxv0j zgnyDrj;&iPT~}6OxcuXK3~+&31~_(jzTviBLRjIlcmX`ZFbxpsd=nVFEx;qhB>N*b z+zNK!zsBAYscJHk()g3v_*kvAzV_qj{~k2__oDdU)v%U||BWiawf=9d|6A+-*80D- z{_j6s|Mvi~w=qDU3V3aW3`@nlc0b-Z=ruFJ*?~`5a=E7eGb@F1xiGT6TWUb~ z+DLyTogo@Z<#JI)e*PBLLaswOXU@1rU{KxS(qClg2&h0_NVzEQ)Y*kknA0$aLf1|% z_c%x>ew_#)Sq1n#4)#gvK9vz6k}=wd$*8UrY%7QKEfR1j1z#s)YDj*VmaSGkH=ZR| zgB;cnKML69a8^m~|3oFH1$Oj2p6WOl!jmWe|Fiezdu<%sqVV}wdWw!SNmyV>$QVPM zvoT{0y#NS)h{v-uc-#K2rilWI zjN+a;DL3Hg;}q_|XZ4$=(1FxZ@F@j)Ocf-`P-@AzP-xk^rj{4=`X-gZ@MPina}-U2 zvqoe6tf_#wu|+j>Qyf%&uje3=^)B+zO5$~c6%6>RpFgWR5P!k<*h+EgHinaF(n1Jx zU?4~xH{R0w=LR=KSjSV zY-FLJS(d8^hal(|!3zg)jBu!BmmvXnz*ipB+xC=77p+2tX_t7lwW<7mx=}RJ<{@wd(u&Rl4nn=0c~z9M9w2&;!-wM~ z!8z;%KE-DK4RiW)o-yZ3Ehv1-oOZQHhO+qTV#F|m`0ZQD-X_>FCwf4+0Rv;Ld2Rz0h$p1ry*x~uEr>0NvK z^UGB4&8eMjlJvsfe%Z2WWpcjQpAmj-=`(!gg5t^}^uDTH!-V!}nY_TU;_VpYRgtznX?h`ao1YgutNmKkdT1x4=A!T&>1G6c84nJKeOPC2X_SE6< zC{BVzV~rsESRC?#kIGuHCBcf>No9D>=H_xuAOc%h%!+n+fT%)Dub7SAeoeY{YY!x0 zZl*Rb`G(>g4?^0%QaO3Y^`xL8R0o%ufby}Q$&~u=CTvik8%8-n8CrTvU9i_7K_N=X zrNr0|TZpy>50P0|F{@6-UjK0@Q}jkPGeiH(-S~DttZjCIhY2~ zUp_+YfjEwDhN{wsU-Tj%O)HdrY|gU%p*=|}V4k^!$Sit{1il_SAG%|;9xGc^YI9e+wh_kOA%81$M8lz}YKV#;_2t2D;=aV41Na5~1+0oqm;X%y}R+a&APX2PeXo z^>4<6E!F1sumX$C_?xW{FX6LeR8Rv_$|2aHdfOAU{!m z0gk#rw?exsU(m|fAv)w^$EdSB_LpIVyzdWHG+%(m98agpMY1r1~>>oDbc51 z@G0hn%s?P42u}9c`5#Q!aKF?qNViBBqO)Z>ui=22?y$85WM@rV-kd(W&;yJ4A&FQs z0LR<+xJXoX6@fMB8>i3r`%Ntea4Ai^<{Xa4GqyvWY_{^)I3;yW1_Um3GchbJs=#Hd z=HpU_%BjP0sP)IDATjMK2w~8Ndac6dn%~mmM@>eEH;Z9j-Y~|X@M8;Liuz#@3hbib zGnY_7S-5R84qyYIJzvw@lKX;-%RH=80B#m@kHnptx{s->$F>AjfQzB>*KDS2Rbu^S zfvH$=N>|@~DyeuO*t%vtlOc|#rq=7b8As(z#k7X->67mR?f#ENy7?0mtqkX4@B;3j z+2y%fLB%9Wevu2kpc@s=CilmOLUV{?1Eo_%F2)Z%=?LK5bH=LEisZIW6Z$hNL-VL1 z@z9LrRPml8Lsp-}e(k@)ls(u_)6-)RE3PXf2z1($h~wli@OW5W`!ZffuSd2Ba|y7# z$(*~Q>zjmiiZPEoB+#_g!eoJnFL;?ArdCmL7ukMY(%*=2bMBlQMyWzlSN-~m+cBQ` zHX39YYE*Tl{Jt6QWT%N?UMlH{ua$lP0#^SJ6%E94P|kl6>)pBwr4`Zz+HAbEZCYE^ zOH`F;T%z#dLJN60M3tH{1I@|58)tvAWSnKfllQUq=7Se5b|MRrg}$3YkjzIkuHG;5 z=>(#j79d)K{MaITny&z-#mKM{bszxEXPBGXDca2Y7O;FNUuhy_%#qMgY!-VykKe** zLu(Vrm`xaG^5>Of*nWe~Yr!X{5Pr2}%R1)q#)-!RyKwH*u{w8~XeR2wkwhneIMMj? z&A`EXG8_m)UJ2E3Han#2d9y=a5fTRQr zcl9isYvga73@>KBRldtVfa@~lv*9%6H*RN`!B2Ke*gje_G%N0sPju>@Bb^R@i{%)0%Y<**JQK2%hP$oeU)1(C8j%Hy#_GU4-9r*MH01;b=tr~lhu!x+gx{^_jRH2p zu1#|1@O%sF%XZ|!*Aw0iJ7VSx*{*f7{gI@yN#099LuAPnO_WYBPuO2~zwgpjKUS)P z-GmG)(`*ji5lyMEU-{YLw_9`NgyIH9269WwBs0V$OM_rMo0~z_-JUUG;FF<%#*`Oq zo;JWByJyD}QBr!>Z{Jx>{{Cm~T0Ww>XgP)d=ikY#cn?EOAA25*5M-Hd7vA9~ZXBKP zmNKH9G#Pv_Pe@+mi#S@@+XWV(MLZ>k=ae2KBHqZbO6w|0CjJ$&R|AaDfE!1cEIc9r zgfqIv2d6q}Kk6NB2>T{kbNmdaDXopJy+)12milYz0XGglG~YrLG$=*( zv((80w?!+*iDj_Hdz?KGcl|cGB_P_0g%>}kK(o?*pZ0n77XAZ{l1W&G)1<1n)S+p{ zeVpq>y2RP<`NOjc5LwM7vasN_=kV)aSE)XB3^%~>iqUGE92X&QQPMvAWKS@-iyMJ*mOpi(^wNw`bm`@+XLZ*sXl0)`MBG9f4toARn0%o`e>Fq%tyF2X7kI{ zaDs7ml5TNpq>&G0@Q=YcDub$n=|$K~bD1d>?Q%=o4k!%zA)8IwQ1(TiKr)6?Uvkz7 zGWyxc&0?RS1IKAhWMQR@mm~|c5{g@6x!eQZBHwd$!=Iqg6op;S*w!rc5Qs}(Gv((_*^x5=pGWMM6sxo9t8$5PG;3%X3NlG>T z)tq{hF2t`@3Ta;9liRB^tX)+^kLY^qg$eqGT7991lUFgxTo}&=V6ISbQ z%}-pX&tF zjX_20rK4!?j2rAWzFzmL60Z`0x~$7fx}64~4#$m`n*5m0sot>@I(S0AL6yjKIb>9#5943N=hUC^%=?w20m&(1UZ{=uZLwl4hk#Bj-= zMT>4fF#wbq zHLpj5udnX~Pd+=A{>h%hFE01~a%cPc<_S;xihcjofTjI(H1!6n3!0(8iSq%zzn1wc zqV-JluYPPG3m&;8i`L4;Gt%*zn+JCUO!;L4^A9;JjXKdwxZNlQ`sShFyT0$1JM{v> z-4-{>>F&bU8>aacY!Eujxzf$xHI0<-T>GKBj--=9kZo3i z6{r@$A1ja-KZYryYl9ZH)jV~el2_vrJ$=%xv@aH9EApUfG!ibX1^L9{v#kwZ#85nS zwX2SpagXKOlA&IsGV5i~kCcf@)6%vEUT#lLz#&PRElH%q^@j+XoYDUhlVgO73&qi*uu zY`bRsp1)bHy>E_+MOi1SRx-XkJIdKY-<+7`DmBY~c?_)MICKlA&>)wJbwC3s_43J| zaUNFaaz*29)bo4IeS_31>{E)Wp};ub+)-NQP)`Mm=w|Z)%{$y1S)EC49$QuZ%O$O3TjuDJlFM)Wr}N-0WYkNgARfkj z2t=7yoBWi-Ynz8CYjg6Xgp0jHvQKrl(O17Bhh)-jv7H!%Bz@4=`Lel9eYT=K>Rws- zYhj+>R{iA95se0)=MJ;Hrk`A~>|tz%w-tW=TKy#6xmNC!Ysy|N1JBnBZDxq|^!sS* z2tT5n{?UZq5%#EV_V))-vnK~jC$(ykd&{4-)%g=gw^pN~RAR~vNk~A+Nmj< z)AWw{MchxFr{3HE?`eZKx?-Mt({L==>Be|jhvjiy)c=0e2Ew&OwUF$vP+j*sqxzk( z3mWhw2AWpHq>b?vf2R5HsUb0;Gn+UJ>dwi4#t@XQ-H(zj@mh5`c`)HTM~jc6KmtgPf}>i93F&>z!{@M&1aG~nzU;yjgHp(_|fDv z6{TakqGi7gS86)4d6-caFhk6sDHBHOJa!aOsJB~=>qNn?Wno;xFGGPb)N_ALWmBzPyOfXxX76 z&ag|DNB^e$@OAUjLyN9ZCPbTVSf|${rNxtwe$Ypyb`ZcK#E>;zbft$O8vJtP=$IeH zN9&6NPN4g1F#-f^1Gp2B^9E@(c}R(H#3?trRYeD2gQmwYi$g%5db8#Z6& z$07*&OG?-viBiETqksnUagzk*-mBa*k@@JKX!E4F)BIO8W)|$veIu&+_>3pyEO5BWPgvgcZp6vY3y+)-R7|-R?K?&JWzVlHnW1kg7i+44yCcGdd;KA) zn;P7c`=JbJ!{3RL>*hy$L7|JV+!>m*VQhkYlX$tk1G;{GP4;j~eywqqfAL+9hppXr zC>fV192*DOhqLuZ3IgD?oMlVWsh5;?VUe{LFT}-$;CCd{AevUcfz-An!7ASZh$%UJ zMq{FWHEgzwRXN3?;XRh_kBA6Qak>d1{$W}LHh0q9nvu)#4q9-9mwx8X z%}JAJc!N5Bjzww+WGG|swnNwTtO0Xs7 zvXkKX)?c%qk9$WCb#KGsmy?sJ(VJFk&dyD(W2fnG?uR&v^TyvlIM}jyMpgRZtFrC| z71Yjkrc=LtpGb;0GUAUNaQh!5P1{T4mx>aY)=3er*Af*%_{CA^2A)P>TIH!PwYqVlS?zCC>>%Pk9txujW8h02E&c=cSO>svXhQFZ}kN%iLm_;uet(VF` zqiB~>RXf&}t;0Oq)+fkD^D#}ZC&{Z9d!e$p9G2+ERBVpmR92}-)j<>Z9m+p^6{S)k zW>!k~7^JpD^&`>-CGJ}2*2Hg- z@@kjpRCb~g*8}kBhL5Ur;ZANpBgg%Qp^gqO^kz8Ua&Ju8X1}Ght?VX@pp)6?v4D+e zC`Gd>ii6rpW+k)*V#*lzJpNAj=tR36jO=AaTWhoHAl$>r#lgYjcpG^AEGLF)n3aVK zyG{$FR(p!t_)x z?DlQ&5Btu)szmgtCB!5>wWKQ2cc208|D$dOy@AU1g`wq#?no zr#KbPicAyZ8)r~?+d`R#U$k%#071f- zC2v6U%ai8Y+xa^)+NZ{E+qa62uOAhD(%J2QbbD+QHBE-Du-?Du$Uf2uQ8D^H3R;*OoAW$+x4D`E z0`>}%gmaWbVXSI4vlkv`dTP2>t-rdk-rZmD4`sKl=T3gTnPLOLZ61esdr3d9>XB>- zdY}Y>Ul)@*fT)mbv+ z@m`;B&JNBB+8{BZ!nR|T&FC|y>67Csswg?t^)adz-uFJo>43~B$%AD&y9}MOwT3`oX)h} zX|#LrOHMuJ3X-@za9FNg^&ZvSTB5484%N7Nd1q&FX<;|y4~lZ>@$92Uf)6Z9w?(m9 z)53{o9=icZEpX)`Zwdb4#CE*P;+5L9tGXovW)@2r_xW1+P2TMM*S$lJW(}(Lw(joI zLF`ny;#_96SAz{7jo{Yz&AH3oigB-!<{JX@L`6xaT)*!@kUjP6S+%{G($wn_ZpOh*%po+xaFcs*g-AItYZ#zg%qCW;CI+wfca z^=#$lZV~Qa*oCd7;a?VN%Z3_oj|I$(3G+Ls1>@2=MnFS+J*n7rWfZUIQUUt zOci^9=JI)udo#bHszEnc=$zBAKHnWEI#>ANx3-a{vTB(Pme9G8Mg9%W@r`O&n>h7) z-v`^ko&>6$f#&~H1MlO7WD|EcK&N|=h$tq1d;RL*`SM>{_V+$m=10_*K}*y?)_B^1 z%dUfzM0vEI3xp$e(l7ADiT54e7=%7cj__o-CvJF8(RXjnk(GJaB&RvSZ< z0^K^F*6`xMrSz4@(DhgDUS_2BDr$~PP7ydyUuYINiR8DjDB>7|>|dF&bhiy2PWex^ z!rp<&{_IUYh4Ft8sPrxRYTGfTF(7;r07`Uo64Mo8&dbUJ)S;E|C+sA}4lc+KW`KwW z*r>DtRC=?PpP|#$zor}Z|DwN%s*y9dG)q9BXk1#|gq_juG!1GpI2WcpRpqG=!Pe6I zlskU7KCEJ5=X&R6pS}{CksJH%@24>My!0Cr)Ts;vv3lyL!l0kLmc5?{081n9t)c-6 zdfq0QwdMab++OIP5V*YQ<0j{lbY|69A%~~AYNmqhU(HJ(yRzsNa$C-xz!`2BgOlQo z!pV1BYo8t|;)@XaZb6r7fl10nefeNtur{l=Y3eIfI?qV-Z&>sm38pKe_O~!s^-s14 z$zj!_^xy$CqyE;hH4(%CM{he|WJ|Pr9Zb@R79or`tDSn;w)9dI#Je*$rSf55)y(`h z@fw8J=|$uBpwRcLdGdm|;mB%&4S}FsR`UJew2-R%T$hHwV(H9xOpA6`7D+1k$`i_J zNM23Rl&kR^tJtRp>i5!4a$;y2GX?x*Fqa&vksn2d1LnjUvefOW*he8wL!Si>9APs> z(K08!h$PQ9>)KFl#&mq}S!lfOSy^bJaCG5HC*NQQfq8uNrJDd@tEkJAtR_Dxcwf`D z(gPppPY@p~?0+e^QTkcePIE|q>ATC#L@g>->y{U&Fk=S(9mghtLmYaDs&+~s#W|zc zw8AQzrEl*_8Nn|!#F(e5v;G0;Knv+QflI3f=9MU|S!@4_d?KuK+7Q5SI1mycSP2bT zx3gh66N?Hzk&3j21z3O?2!`g-SikqQS0u8)FVO{rUD8}@z~}&A|BVWXmMp&0pRV4c zJ07-?)8}|!CkVD`?vpF)4c&k4y_>w>6kP6dCh4yPKTUqOt6g4Wy;pC?q8qoCMEMx7 zH-EhztP5E?4pHiS=$ve8x99l5J-<8uqL!2Jm`D7SZ_49lB|GyAe+E2-*XY+x>cm%H zUXnD(d?h;@CvU&IMWlW;I!)1(4|F8G2 zx3*Qbpl}y##1l5Wd0U<$;4^X&kicy?o>dIr-{(HDtcabIT^lm<>LAfVp#W~WOfSVH z6k)C;sTG3ut>f^GrK&}6!99hx@Rvu<_{uovw8jU>ixC==;xv~gB!(dB&w8ze_z{4^bGuhOMijej~qIHt)1Y1#9-bU z<89Xxlr-J9TweL{!hM^c=O~vij^iol8lSo}TOPYewBw^oA}S2C(v-Rj6J8H66j?dB zWEDJUAv9@|H?ic=(bK}N)QpcV(d$Y*E%4L5e zPw}f<{~9_RzaYWG{)DED>{He48cQnmI-SVw*QJcl*bIvJ5us9xg<+`4Ni&5V}OtAC8?R10dFK!WDD9^)2w`)N9KVENVMrNe=pQ zL3R>EcHx7J15rErZpZ-c=a$tLvz8-vHzP5WrQa62F)^f5eji&rAd%KY}Bxuu4mB+1hag|zAr7N5I4O~R zGDFprfpQ66LnvF=2#UbK3VX2?0#2t`qG@(bcS@^lwl>w~_cvbw@+o?sj=y zHWbqA2$ov33EIS;*=+jeMjTh|Rs3$HL!azF9z~EBaa5aK<&~LYW-jzr<|GKVf9&Q( z@woJXJ!ikW&hEOqYbZ>;nnqOQsJWHsciF_d0JD~Ev>xmENOyIeN@0%RL!NH|PqsIP z(s!>Owvjt&m_FMBqI%|C$>|zpji@| z?#Ruz;-kfpdhXL@DbCP2sBCebAT7na`dbUP7y#Rec};M>niKP}S-C{Q*h}?A`n1xk znmQ4zqQ%?yH1vf?3}W3o62m8xOEVjnzz$Cuxx9C2p|1ILBWdV z4vh{7B(RrP5!ct#yEm1?ttsT9KG%ZT;vX{43Hay@j^*u+Tfdd6_T9AI*by^y;a)Ar zyc%J#Ep8#T;8Ls@Ycpk1t%JOe^x;sOY`%(KbWhCv`}q0?M6Ou64el|#a|UA`*6&VQ znn@x>!AJAhvGbrIB-1SRoPbirfn`&Q=CC(M@E#-#{SCP~qXUk@^segH4tf_~O zPR@NRn>eQipAmom*w<^Z>+7=QN(uJFDZ2M8$WTM@IwRf=ONw)Vc!@Vw(dq|fC_@J6 z{gLy%S9D#guZ^fzMonu6-Yd9Q5uIL^sbWT$Pyy#rwhmL;ofcMlCQv&!`*&-A!WHl(#Vyca! z(b?MtF5FpQen~0@a3WO*2uCw;9P5VG?GH@2OmzZE0+rLI#j+8wA~i+v6Vc=i8`?HQ zZ%`=#BvOzJ7FYz3vIT;_V!ZacMGWB#Krk@Kg>qmNP#~sa$X27MVs(tD`sbBQCfN%r zrbUqu3a3^1cS7Ozu+zd$IY^6rFytta^l7LPDh^NuNT8`kc#@#hzxt2>N-PjT-b zuaJH!!DuS4*wJE(X;}(iQq*5Ek_kNQMe+r1&$36T3hLqS zRtukOlEbMWkdz?YsumWgbHg_~pL2%BzI&}PUx~H!Si1d$vGhS7Hx3fbO#384Yl8!G z$zTbRU>k}bVTTB&eZLRuqv&@jeok}d>R5uQR(K$kPq!!vL1M^A6v{~0e&OAFFL(m^ zeB2$@IDM@}#E3XnpaFU~P;q{|Z&$CxiyNEg^JxH#v50c+mSQecL<$gO=n*D+CJQVu zcPO(42fFf8B;|YyL&+cLiEyfUs5SeME(M~$r@QSYAr)KZ))BU!bg>NaS)0AN2TCI19{FACseemTUvKO6V;uu?J88WF8UaPS7-U88~BIroYiWaawWmul=hdTnE61Y zP8ao{Ac@zeb2O=$)vQBnfIzjQy{IUbjDk=UTEy-{!&Nk>hPX{ zzraGoqIND0m8aOtCB5dK=#>?36>Hm|*DSOjX`xi3IECd_(jf~0^ASI1Pk!quJ}Gn+ zl~d3B2?_c;&AH)aMt%xWlF2)k(zI&$1=gOQ?{7Sjj;>F^+D z>k;5-{;^O7oV;I{99Td)>xCaaNK5gZ5ps!F^o}S=|H(52iVX$_rp*jyBMV_OC1hZ2 z7Fgv;ZeUFZYa`1AILt*{F){M@Gys|ySZ|`&CcN8NruPWPn#nn=qVnva+GusOa@wP_ zXN!iUi-sU5w4y@=Y|-QIpEahp$z`5$*`n!{Or5)~bpl-1bRM~EkrwPeU#gX($RAUC z3lp+7|I)MMdah~XZpgw#p#fT%4_@Nk9lpFIy77QDna<- zdH#Aoc=rc)c}L&{^}Gi^o)`9KKe;;6RL650o#gtph%I>C^L?yo+Z4QJ&qGC}>gPsi zVeYQwHCdLP=(6a8!Ah_Lig@rg_q{~Fg75*UPDJZ;Fzj4UAgto`(KR6qURK0+y9}_J za~;}aY3!VdueuBKRl&MyzuP%LJPNm+kQ2N^vtN75wl^Fqew1qW55No>o}yyV%LHm4 z#IW~5;Tn$$ag=^IyyeJMoGqUQX!S29>IWU03d!2^gbLg-XH+`X&`q1it35J25Z<&ua-{grUT&J~S=@wPJknTYH6if~Phi*G#dbz3o4);rD zTMcuMMC8>(+{)V?2(gJ+_fIbQxW|PzXPNnzmHxO7QZ)iKU;hP|m6(lUnj1wu4rx>P z=MlL({~9h?VBmdR_9JQz=aK0 zU#t+CnCpoh2MQ3)vwOY2U1bfdF@CX9gs96Gm#MrZ5*;cH<^yj2d9K_io=TBs@2Z$k zid8p}+k8^=6>_T>G^7ekN+hrScKdt@r6hYo)YkA%4}DPAE6@}7i=>EVnh=&e_#{j> zOo32Jh8AgaFnYyICOyOGOT#VpmVT&g^fiqGFE;fMlyMlU55OFt()ok+eu&gqN+> z{;&hI!|RdR@$ICo70Gesrs_16aAqC&^aJ_Je(*UjR^wDFj}FG`1)F99aSV&Wh$tKI z-wutfBY!jD0EhDMY4%HRyG&M5E)V@{)?(uJcB-e{=E5m2n8Olv=R&IS(R~?y)}8LG5wuA6iM@ghk{V@fn|%Ios7%#so?Yb z_>}FzA08@pPJe&En%dlW`!3yoMd|h)z4)P%s?=HdV^qP1c-b(69-B-Jz8#{SZT`4L z`}}>fIs(!0z$d?#SlDzLz$jH6d~UVXfop+obtzWrFoYiu);It~U?}r#{RYXWEB0lt1{oV=h7X)^`qjyF^gn+kcO#lR-Ks$iugooK<8=HT zx@gnxRBpzU7rV^!iHjV7sxL?FA$3z=ojy<8@O47(~bD0 z1)4ez+}NS_TmQtRJpS<3v$x2OPkfQ}hby7)5crP&^u@kI?!W#2H~vrV{}&SL5B!O( zXZ|FP%le_M)Y=TbP)JqwJw+dJgmbsN8|fl<@~3hnTHO_YC0Ok5yh-P7iPu9#CZ3$g zk!ZK3vLzd3)IE`8*}}7=+T}dH{mfG}=A9`|ww`5t*Rz9oYxakH&tkkDy3Stvn8#SB zy?DFytt6HsPrIzCXKdM~!hWj-^UiM)<($$kXW>rchxuMprZGB)(j!2F7P)yd3Y~7xdr8WKL8EF#5w-rJ?^by z2gO(}d>{8@$iZytBjC4(aGHU77bSh1uWt47V&(H6lN2D!rWT&uHZGhFKY04d-mQmN zFUy6#P@bFirwOzt^vb7abcP6EsMe(Z0XS{hxpB{b|B=FNiQ1SKTf$~aymR#)r|!AnWKa5Jib;|p zV4>m26%`&}aZOmiKFX&{My~xRwrZ)C^|GESoZ($kxoVzluSBtb>BHLa9B8ZT=m|fZ=VgKQvY_1%K06rKE_P*JK^h1#68W0RSOU{b zBv=w^C_`JjJL-@LS9_8G88_y%|4YK9qliX4 za@KzPUluR7bSfhD)|n>!^)T`6WkP72(3CvK8$}AoJ|=O)Q@?%1(pbJjihC0@d{M3= zn&M^SiX2yhj{^je4hlMNw#31Ey?+^UVM<@CG>)Bj8T7u5D`O)#)Urn6iyg|4Ra^A@ zr}&u@0Imp8(5?zMw3$C53Dtk#Og_yTK13E}>jcUDYuzEk>AT>hMsWQBGqb}ca!RxO z`b@K1f;=IdQSU@V??#c4OsGdue`Lxj5LvjU>#bFS+?|t*7o-@jI6q(K&Kbv zE_V?@w=}};n~YG_l+b!BHpX>VCo;~cYUe=RKIdKB<3HW3pf*21eet(mg>PqbYg?+2eFVEJ;=TVB*sS@mtAgJkJcTT7jVTk{!h7yc?-*SiZ~m z#%ugdEMkN!W~NMSnygE9V>;~dLNZHz(TNXDrz^N6W7|Z1U5OBS#`rm$9g0F`|HRu1 z7=fX_H*u?!y`79aPE)7X#*-XYOCZ@xCr5vN{3_Mih5>Q^+-L~e>fs=wOc5u+3>2wP z6d`i-sA{uyR-?g87pc!sAR3b*O++0+l9Z!MSQlhSFd;!6vnq%rARDMB= zIb1G_D;Q?iS({EhrO~Y`R#Yb>tX-X;U6j0}>tr&QZ$5-gEi9`x?AU^!<<843JsZy` zKw(Z1m+e%XiTe+Usi=zKcGPET?*tXq?)i0Tnke`BpJ!?!1MNRfD|NLSx_?Hhs{Cpb z;~zfB1**mM$~hG^W?xAqc+&@-zmMiiw;GU^Om!*szUuidH7`jjntTtGEBqfQPcBTM&SOr8-&fnF(+3K!~MfFqtK1P zlxmn%XeauCHF=ICt<-}Bw=zxDl|%Q$SlgGtyj z7E|hK9PS_I_aq6JuK)(7liNSbEYgU@)TMf`*!1~6*+931*QVN=9}qT%9h_7v{cLy1 zwV^SG<%Ut(8=}9peHtf9jnEtIHh(jvD2&iqX!jNrX`+$p3a(P{E4{*eDgqK9cHk!m z|L)mPVo&s{%=P=RI|Kruywp=>lhP^ysO5?~`jSn^zfFfwwe3W+d4s893zY5(DkB6# zWdjskU^BR3`g)zZIztX8axRmdv*L(M*ykgV-QBsw?Kg9BvX{9~0wU|oXuELTMuHI% z8!TyKAklHiJ`6P#1p{BMoPsyR+@ zZ`41l@4Z*16Q%RcU(q(NR5Np`LhZJ**EV)K zCY~ghe*@JA1szNx$eL%tgNiYLZ{|Scd7QphUjl0x|1rfK;SH?CMabH_0zY~VUZV$f z1wE2MrqfVw5pU{qPHvT@JFAvMx+XW5P%H$MaywC2vOIj`SN*>1T=-{neaQQd0KZ&@fL{yFZ@Keb zp0DUVA2Xh)Ujw56F8$^s|MAp^GVd|2|5Gl~EY<&v3+JEs!W`U)it_MvF1#U;^^yn4 z=Q{}>bLCmH*aBj>J~uQi_WNVcsHSwekS>LCJQ|4f*Iv{Vp0y5@krp4;{$&J>c{|2xn`|6$a z>4ybw{!A1aa1krk72`B^YS8mXwK;fO6-iXk+lR4BY$8J)W%hSnNMj#muQnupB6Qsl z_0M5weNa)|kgkaG&X`2Qti)$Vxf9dlO~}-13fV$G+SXo15b}rW{(Yu$#m3P&+Tl={ z{JvIh_#I9hT_bTqg2ORdDCE!_CDyw5dxMkKaH?9rS^Oun!;AI^C`BxlVs(_BgRgh| zrY!oN%6S9d`=mdszXa(~g$JU|j~~I)7%y)!_7v?I&L(tJVgz}jO-XLs`*BH*$~3VS zExMZm{%u^_i%@?nXa{q2mCyYg<`8ga3w2`Yi1eO=#_mtd$@7$9!7w0qOfJVLw~A$L zPQx&!M_%74JI9Ri^JT?rmkxsONFyc2NF(NZ9H|XtIhI$nr@~dViMcUg=oYIpvxmdT z)q{xjbVSe}xO^5CIWsc&E>}9z&oe4|Qu(ahQg#X5#oCd)p)2AjtX$7(X$9R$l;jVB z^rG2xY`fjz7i*gYP<^H>fzgln@Kjo_n4j$+-KCX+oxOm-nbBXgn8bitR6_zZUn>m2w?@#jS9iNb)#XhRR!`WlkFJs90$XjA71SVLIzrmZ zoK`d=t@$$9J4mz>zj**!36x>DpLDNCv)2b2 zjZ4Qm*z$`Lg$oN#NLDYFle)e#9)_25gJ^7Q^BCnVeuPm5U~)1QN& z?~;Gua<}e-!>irgHkyKDV4qqKkF2y_kGwT`Wuw0>up;jVSXO|)AE0#y^xQ@NX#2}< zbETs#V5g39o9fUl7vnCqj zBN}!CD>inM4@o7+8 zEq)-QFI_r){J>_P1G<<|T*+IF?nri*1I<)Wcln2%T?=M#OWOt&H|rO2lL?9R(SeiE zT58sHqh^S9bIhjS3?|&+R4)SeTgS8!mpvMi)}wo70C~Jc8An(pGb=Lx<5QL{nV!v! zNJh_{2os|rEW%kFZ+X3K74%;F;h)I_3~kW~2}Pr3qW=M_Kvcg%%S3f8nQ*S;N2Q`s zZa9nt8|*2%sMN9?p8`+BNQXJGz9|00DqG39N7I_nG{`*99^f}<@SP$g$GT)8I z=S$;vq7m~>o50kMLF7bC<9ANd)3~%+EklLXvgB2bDEAEQRLjyuwJgnJ(eTz3nXu8b zyo^fq3vZ=uyN$_x; zuc5-%^V>G(v~7CYQmf)7cL>IGmmp^=$2eO(#MvDpoZVx9v)n1J5a29#iYo*-%S9W#xel=h;2Z8Yvo$Gyj>6P|QXl@a%F*!1xr{t$K2*#uRi z<->0}%EbtMk*1~N&*1OR>NW8%Vz(n@UL+sO$2kWg%he;}2IPLx4mpe8xg znR2yk|CG%5B*<@;m0O8dZ?+L#m2)LKW#fQiwxdxKHxzL#ardK9&bpu|4-~z-8Rrr1 zJmBWdn&l3n8^8YiKBSN8|7{P z>|Tyyn@8B>qsR=gz1&e0Qt0zY)7&9hALO7mGk2z56R#8TB*|QwdO7QIqC8H#N41$b zsz#$``G2?@(P%7jSdC^a<9lKE(7c!9YRKiZTpjE|HVY5T--E$;1UrZ*cOT4-`J zd;Xi+0Mj*Y-~Nt+JDx!9_&B=kUx2gqooaw zN@a9w2BH85jH(s1_zc!+ zqMnWV9b(9^GMxGmF4g%0&N{+J~>v z^sijr-Q5jx4T9^KjV5tGn6J`Sr6xsM8o&#(L(Ngc9^SAfi_Aa2l+M1?pBoJ{=R{-L zGzbIC&pr%O%#0pRgLHx$iiViiS8?x3EVxut&b4+io+ZH~#3!D{M&lo1MbUUucxh-r zjgFx68MGOqsVJ$~OuI>#rm&uPWUYfU7Q~5|b1Ao%8g<5L-u)Y@6?I{6ItvHE^*H&t zh6N*StVLS9bT*i7P;ce@PQN`n-49-!?Y%iHmvB5ZG4`gRBLyK$uv`Lgo0ecpYe9o! zZO|TdVt{Mhk`jmc`QP82o*e{l&(DG%lXUWU`+Y4)RGv9t2FIg**=;8b^Q7- z%Vlo2V^5*UQ{XQP=Fr%}Nhof6dKD-Aa;9P7B&aRSqERkWLuV2#o&;89ewwOxXmY<|apn@sUyYk-zs(bA;gc8O#Zr&roF=9H9JM5=4s zN*P&}i(U6i2(fB)V!)`H@$CdW5Hb?+B5UW*ZXpi1Ml(w^rNm??C|<%eDs|6A$GtC? zGf$Is`}I&6B;eltdB8Le+UMTJIp{)z&f9nGZ_W;12Z>5=><^hU2!@l`)l&)R8IayXWgdre!|av=i5m9@0rc4;pzO zqR1@(U_!1)@?7B(t3fl@002cb*j5P8YS73v*w*!N3m9oz4eHqjx_a+My)@ZPP)mo~ z)lqqsKLhNC0`!u5_(UqoX%vOagNBH#O>fQaXJzlfFr8@~+<`Uq-VKbQrRLZh5_F%H z%TC94on|vX&BoHx%+7M|BpY|1WW$~$SsgArL%gKU3|XnOaF$~Y_TDBw$XOP8LiwWl|WrrQ1n9e+GKyV``? z*$LyCH=C>P?cF9Uqpi5Zm{7~v;iV_cJSt8&`iL!FZN}~FjERz3X2QMxFVUSQ$s?>V zM^f|36ituJE<&Gyp+Wsqr3z{4p#1PgaYI4zOl61_rpmhF++0(#^IdwbS%zV$$;ueW zO007DTP?C< z#fJ~YOUcNoUBGTsVR9cMuK9GHu;$adifTSxO;GbGG`Ke*&8PP$qWLt?NgFWJoaQ)K z$u;+Qs^$5gDQfJ}!ky0=wa=4=NOv}lz4D#U>6UF*K2K6(5g~$|Y!f3+_?+o))vTGxO1Uv)h_Ix4E~~-R z5bB!x2XMATW^67u?J;kFYzvBwWJlt)SQ zveE+)u7TZ8vn%_=)T+C;oVhwA-<-s<>Q|&`x$Jhev)Gp+JEPo$&>>^Nj4~4ntO=FM zZeKf#JwxWqh-5H}r!y#=PTA^br^tYJ-j>J&tRNKhuV*e+m0!ERD9=}Q&wjyAeAnhr zHT6%my>O~5URimr=|{{}d+>Vp6>;T)jlIKcf4%-i`3c`?XMMA6FP<$6R#xBJkC-hF z>EBy4V_&ehcbM&frWP3|>{T}xryKZo*Eiol2wp8BM(Id3#%eR$j?OCkq1SF{qyF+@{vVzv6!m`lS##QI|z!b|8ujk zr^8(ZMTZnv)Px*QZX)V&z+XhDqKFnPR-u>P&ctM&n=4{tpA- zb<_U+SpY7u|J!=nXlCvIo;Di~_J4o9_>UTN?jr!Cynk*#90&5{PygTlOGd%p|G)n? ziZA&&ogep+q<$DZ@@4zrAqM0_49JHVkPk5+SB?RBPl)o5i2k@J_@f*9Q41@{F&Oc< z{kirxEsibUdyL56Asi(1Na?t!3zltvqIu@^@ad$E3V!GBaxn0tyT`G*IQ z+0a?5HE6Gy6A#nk@HeS7e$Jkn-;n#Oyt~D&UZO`2>6%2f58bjen_W~n>3retxpr(h-TZR}FBeN+~a zo()?EufpDRoH%oT)}xlGv|Mj-!vlN_<~H0`Q#;#(VJP$QoLteK`FV3in+9E#kNR-b z8>8(+P?_|SXb`0MP_?SQUFhX=A3L44GP7u{@O688Udrd~JV4m1&1FZHV5P@yFwqT( zJt~RA8-+Q>8`&J=jm0^}-E*;Hl&+LPyfMFaHo3S2JN@00i?5nF+XPWvoG$$S@`5i+ z0ls<$a1*L^nFQbq6MkoNcxxzaW}vjGptM;CrOhmqHt!6j%@v`v=>bIv*7~OdMH58! zuMLV;sM>o0MPh)L7E*rkMUazGuDXI}yaFp&>-OfnUEFjQ5oQ(J*s`KS%rTe`~Qo0tF_VlqvHRz z;Lm0*{_oR=_`iQe`+o+Vob`XR-q>VQ?eCI!I*mrbcjKflhW?H-ey&|32=+$PtMTYI zc%4MiXnyrNxfe9*S!aUzjo1(2SrEJ&!z9N^3KRUQJN{cbOQVf`^fg)O!PQvbYR&O6 zcAhBClXQt_h5S>esz z_np^o&pKy^u(U0wxZOVF;_b3+6;kP-qT}$mvw!;L?a}e!S=9{s=w>*KM}Q?@f{%1( zq{aYZuG1O9KPsY@(_{PH3EYj&e$`&UY&4Aeao9n9OG=CLb{J=3beXSc^4Q$&OckxD zNXFR+?|e7D#2Ov?t^5x-N3qO}H=Dci8@w3sB&y%A*BJiVE&sM#F0-0f$8=#|4eW+o z0aTzD@`;duI}`{DuobIj^az)e7(k+I|XJ+~`pG zYdAM6qCJ_+7KFJkmDqKU8z#t~Sz+z**D7^dwVI|FhG;gLR(B~}{~n;rB)Wjt6L+$p2V9#*y3Lsy^Y{t9IOGpUc+Y? zdB*X`Jc8K882tr!i_6wg@Ywj)_32RLEP~4z-3+!`7#M9L5t1mtm>k-MJSP-;Z33?> z9;8}FnCd5-5(iMrx9tEBSWTP#l_}vsFPhNP3*E!{wO`fnpMzJbs~QJn!{@IXrnn`8 zTdcv~35WfJ@zr2gI653GBxt|F_vql&5O<9tuVFT_DD2}X2S-$lL<%{Hler$NHqZ|O zp1)Bzn8KUJZ&e$pgF%?wq8r6z5CYi~4lynqE&?z7Ye3>h9l+V}W-!eF2M~quhz9K= zJ%N-6j;m-CeSi;>G3;@75CxUl1S`Vx3b%d?-AY6{*zrD+DOEnNXfzuJf}{XuI<$7^ z@gGD1e$O9HPI(qJyHI9W{6)>(`GyzCTiSl*FFzV;=9Rk}YyIO{8{ z?oB+L3?fat!uhp`jQRu-5}F1v(hq+Sot`31png9ia9Pm)xMP=*K2q zd|VV(mWA=v&a4f)=Hz;TAApIN?kJp5@mAuAG-|<|ug$7{UuJNrK5guv7giS#orN$40L& zbvJ#ZLIvjJG?tz>o6K#`Pm3OD-KM!zo6J%+=PZS9oV^fJI(NqQRYeQg-1O`U&J;c0 z-TAiW%vbPScEVC@&p1EjEPe-^kejuI6;-G?SX_Sdi~4F5^yS-uOdq>NTkT+dz1MSA zW+q-V?>Xm|>1)o!eP{P{&e;LZuLbll)bK&Ko&xLn4+QwI0a7t@fl$99nH6X1C{#bE zR_HaSSAhX!D1 zUPP}2(LQfZ5118HFR_Z?dl6Fv-^|lx6Qk&Oi@(tGcMVULekTD`fNFv$TCmOSh_CW7%ajizl#EIDwBF1%Kr56YayZ z^Pp14EOhkeH_z#l-KIKwoZlxE`@lbk?XO~(xcvTDPq-R@hcBq?Ry7BdpA%bos!0`e zckrsHLli9eJkCFPkq^$F8{5>MH@<$9b~BY4ZYA~3WhM#dC6Xx5MI|Q@>o)cqo2U ztgDu6ai8yZoyZU(AA<*Afa(%-a|}npW>X2C=+TSeLA64Ch|w}aqP2{#p%q;h*}ysu zgfB)Vh6UGmgE;t#*AG8FeoR%>{9@}!)YByM{4ey|<~J=&lJJ&=`!wrWBD|DpLcuch z_^5*5=j3t}4seS6o(i=Vq&n&ZtS?NR7u8zgCp70pn8?i9hub&=3o@9j5s9NgpZHn5 z5E+p63l0}L=B$S#8JcK zoYSPb{&lD3N&Uwg9@_Hfs@y;Ay-S? zoXI%NJakX!Vrf(s!$pEha3(}WWY~G@GQ{rJz;CTWEPzfKt6% z_Ad5NmAWb41_3;EWEO0Hl7AUI2bnp^hWDOldyg}{8(~(dNHAGf-%rJ4ZZwRK zK#+g=`4Zau>=6!^O7j6_1pu*`Yud_6;a(cf`c7MEjkI7ZGnknuRr*Ul@U_xJD*e!p zF2dPhs^}oov!-W%D_f9{2XI0YOpuFK96q!0hd1F61>z1DkIbnwM>K3WYt5l2(J!+& z;RC=Bh{ z@E)MS$P~zc(d8u3KSNVtj^+I)F&xr`wSX&P6_UG*{4YAsO+V*+bo6@5+nqsQ0rd-g zVaJ4b%bu5fH+cLw=C+D$H+P|`DQBU~k-GM=bUVcr6qmJAF5!G0KL*I{0$}~T>uIBr z!jAu=Vv-6zAG|VS!4l?=r6|FIzSMo(nbU>7^*jELrjPvRoJ?*<-(d|&bnVr^`WBbM z?l=K}s5;l2;SG-){@LXMK6njS(&)QTU629RVDsL+b3BR&3W0=)(^q8}e(cF~^B7fBkmL zjt~lN#fTQFhJ?kdG5G@E4ZvaWhQ$}_UnfRHrEU{{xA|KP8)pl!_=e`ui0RR~rj1(g z1+Vf8!U4OMctBm;5)nW0Ryd(+;?(zW?b)GkP|+=Kfv`=YrQ%0NE8YV%BtY|Wz}p5d zBR+_y`Y}`+M>mJbV*raWzPeZ8he*uFfYRmX6^*&lVJ7O1?o92pvyss6ZfsqH!{*gt4wnAbrk$Cc&@~%)TW}&xRJ3^8 zG^7oQpRjMJ_z5^uf8J2$6DwoszqUg=Wc_A^&9nFdxvmGfK!c_p&8qv z1H-#oeb|?Pg=x@bQ=idqq6T<94#r3ipyi&)%Z9IhAKz(B5C9pB|K8>vZZSFqsxF>> zNx?xa7-SPdv0*VGDPzDBgJ{Z@9MDrb-hd9cqtO^XVrV()j%F?)}@sN`*7AZ#^DJ!L5g1*|5rHT5C9fbNT7M;{p8hp9V)g z=6CvQ$9haEY3%iwU-7RUTQYS&$N-6L`eiNld@Qj6Gc~vluKkq=gah4ro2#gevV;+7 zjVm$ubA`v=;e_@6%@Jh&!$vRIke?|iG;35(m4-fj&Db8Q?16t0deS5my3y|lm8z9g zlzCOvT@%Vd%+rVn==AUOK9ZG>G5~YmHp_xbTW^VhmjqAc-_}C@1@>tO$^XR zIB|eAhOY&a!7L40A`QpqBpOb*w%P#3w`M>bWQ>>A15H&xW7eg79JJQ9X?+UFa0C5d zSmlARGF}EG>}cS}!Q25CQiH{Cm*+U~y|LpChN-egROwx@{L;!@Y8w^!PD_@({xuq{ z8rti>H-*tb?ge0?H^cVP1E(23^}s3Cw5HURKD<7c1YYtT%oD-C z^P@QTJ;cbf1WXob1H{N0i}lt5AU_6C2*VK~fmG|;0NaS{z~og~A0lKeJ>gzf0Z zs+j@P#?aYMyl?`%pBV6dVtK<)j~~O7acbKFXzMTZzWqaqwX(v9pWdU)8D(m7gb?13 zmHA`EA5tbOkDa|T*n+`Jc1-e(VOy5%D>IMr7&3?I%&bAjNwY8-} zGYc6vSgWY8)zvTj=!uXMSE@qwio^y77$Es1cOw#$q5&y%@<)w`LBdxWl9JSY)Q}i6 ze9n+YJfk%UMLpL|7wRGx%>!QhL)0vK)4JHv-g?8b$vf2oXY0Y_V2r2E5 zA9G0uv2ijaS}jo2{l%zeJ88gxd9M+PxWvOVldxMLLX)aMKRI#ubWF9Hh8AH$C_0-d zRm{i?xDi!@SrGM)`nQ^Cw5B7{Wj~-rIZTLImk;AXIE@F9<)U(h63De_5)LPdj%tUa zczTO&4DghS83J-lfV>nP#DoSu55xupiX&ip0N>GfC&x#BKRo^+sC)vr3@Uw1*Z9@Z zS^K<$Xb|XLEdGj$0kEjFTCKW9A^7p--T{8Yz6m5~vi!IfETPG+Eb1%HVykc#0t5PdBlZaDg$b}a$mpT6#!0_2Bcu7zE#3}`aNx5!7Yq8{pvR^m zJ$yhfBT|{07nBHTqO(MN_0v#uTe5F#*k$uh6%hth0Y%ntTF)<@1Cpd4wygtfGG zwPM&A08&QGiV7xnVIC8gkl{>`Kp(%(7w4}gnz1>hKS~d9iNv3y0!TQ-i{ja3dxd&- z+5(Y!IS%@<5TISjr$h$PNqk8b8~9WzH@}i4M$n8%jvXyxUGG6}z{j~zYe3a_e=92L-_YVvGPmF!qa*rCGEKJ4s?$z~c6 zl9C%YwyIg#kprN+i=|1~T`fF;pXdZiT8LIF+H`o&YQ|Dlt)QS`<{`8i{+89J9*sVX zd9&2Rt@gLm%{OJP)X@*oU8O}T+encZ~K0-0iO+I0SefzRK4 zSLb{fzmzJUC!9$RCD}Uhqfn>94+@V33^mp7V`|xi^U5UQjrbw;DVXv=83Y<%K^g{H zQO3T664;RT;zPve>sIS=wjH+~owi#K(^6qJcDLeq(C4#LMk8*cM!iNUDRrZ>NY2H( zU};6EW?{gR_P9c&puJiek{jXXHg?RaV{2>MY(!;VXe*=w;O=n49(7xE90d)hND54Y zi;q#7(ycJsi6;iHgSwib5;lnRvL9W^?ocx+omj4Wppg6;*Av2 zwo7486>c_7;kJ~u>Za^@xdaGdidk!{e7~b#OB=@nm~{s@FU<22O*?20*HL9Vys!gv z?PRNQeX`RAq8rbw`KA+YyRTB+BhzPJev_jKPbW7}s)SNB%x)e^*u$yJfDYwyWl@*Bi1*_If?iYWeH+ zSgU2Q*Q3onvs@bc<&L`TZMJeY`=wg7y{%TyXus58R#tl*ufAEp5~3L$K9;$ckzO1iqm@R}ddo>Pi{^RP%;Up`0voNZ)vtj|R#7gllNcL~$H8z0 zBazJjY~@(L?q8;k{1c3k2Uwe4B@qvg86LFNVj4|%;jhSRC9gHSlW>amQRem42gNkyg-K35le*j`jQNVq>s8Lt9MYn8vT5`3%U9DAEEp&<+4*jSBK1FD= zc#3T)BWR%$Xf)S18#+eoLKiI*>5)GLZ8m+i4_6?Cy6D3ifd02g!SpJDMKzjgMQ|Vi zVKa3jNE<%74W=>0qh*B~g|rQj=%NUrqg$6aN9`ptku;$r^teJh)a!9Fg*l_Ip!6Hh59x!n(zjxOXdGj=})qj56hbV~KUl6a(IE)m8CN zJ(d^2O9bynmQ_?`J7q^Wz?`kc7V76pSEDq^gqN6ct8bfXgwv2YEHXFy+uP&w0-ljM zuP96gx4Sv#7fAFKUzJ)u4&u)ry+rc{OOHc`mEf0#*%L4Hh*k;M90w+jAzFXVezAX&1C1erw)9 z8GdVtR_&rza}UeIq%F~^UDS#gpm}3uxUD5xwY{x0k5+KX9u{qhv5HtUxhOjx8eCvt zM_=f5g-sQ!l4S(cSt_1t=_ZB~TC#!RW$XrtYLIQ=vNLuQraL@?WH_3o+W2xz^Lyf( zlxA=kB-2<=g3BPtUgC|7P(zDE;ghc0WNH?(_p*J23!U-B_ zU61jhm-tsgKQfPiVbq~#Vmz>=vGBHxE}^?u+6HvUTH~7HF@kL(B!*E4ZvsvsxQwQ0 zwhLx$u=;bZDpWI&tgr-c6I=S|oVAt%uQ#l>w(l!tA~MUQI1B@AtLn2assuUdERUkO z^c?JEx-;NN@^rBw8V@-P6DfKPS-i_D$9H@%zKnYqC1aqD-$zt$BVlJq5k;vA9JFjo zNtMG3y4CWO0|&BQ_mpn}JG$j5Zvn;CXnH<8g%3^N$XoEC6V2j~RgO@dfAHPj*{fhSx{k@W@M28aJA&>k9uRA#F99@0 z8Ni@-6)F>B)ib4F-D`Kmhw9zQcSk1&oi;0K3H5r@wm%9V)&9mK>(rqIwRDQ+kiQa-OJ)6puI?6y0NXV%Z#R(8<(+2acMCb{DD%Aqkql-#l{RLJgG zFoR(2Doj;ICkc0-2;T-AU3!awdbkHPrb>HB+@;{U#!VTP3G0QfMcia*9O1>D&PKo} z4sQ9ahKA^zjLiFx0N=gNkH599gtNoyIeHh z8#8GN>%H4_H)*=omUMkXI6Gn?K1N=DXnOGZi0|pji0^3u;(JaT^YmYW__la#J0Eyy zK}K*5-1Y6>6}+F()VA(2we7o%w@u?cyE}ZEeBErH&x9zAQfRktXNZJPhsUp={EIKF zqCq^G-B5~nO*Q5-eCJ5Ve|P(T_?<1AHm?2%`~Uj0XZ5X&{r_g8vH4*C|5vg9Ut8aY z|0Vyo0v(?VKyz*`?|f?R#`EV}sN~pOBB^(#^}g~Tc!h@h+PwVLcsA;XY$#8Ckf}D? z@v$lGEMdey4139#v#-LXV3`g%5^Owp3p{uWJa`K{cnhrTE$}6v%Gp7RBo+{6#?#-=$P{<4PqD z-gu-lWy|{#v~S_dPy%_yJr~)g!Lmz6G9D&O$zM51B!>6Ki~TbYfM)eQqE9*Wu}_ z4jco}vpUIm`>^x!-O=&+(Mjjkt9DRF0v31w7M>!V8dst*0^+(}XC+s5V_##$HrP<| zaizZFrMI*gmiF3jJZlm$@SFC2=UV`F91;t(uSkcLN`Z;o1mLr)>$#ux9|{mf6`8He zb!%ezc)N8!d%Kn7?U}UkHoxHT1xLqkH=CCCP2nM0AO6?gw|kwlz3+mc^?R(Kcw?OE zPPg7#-i=|9Qtc?r1@+dADfWdMjtYZFi}N*s5BgCK=*oQ;k2afu3t27{Z8oL5_7ClE zYwG9ogMD}$)UW5?9JTG=U+uNe?cd+DJNpNR`}%hk5v!I1Q2u^!_-gOnv6{QxgY0Wj zHJqcl;nBcAPDNjesm8Z{R+ zYIz!MdKv+si=hMm$u$D_^*@9dQp9=*6`pioNUVIY2b9!FH8c3x-kZ0lKn5KWdJLNG zgLtxce)R1jV$06n+oPavP_v6F=5_hB>1~yHdUF$bzF;Eu$5Z{Gp~jlib)%kvQuUgZ$?Ym;dqk->(R8f&6dtX)7oHd$zUpApiTflmBf7 z=Kx;uAnt`mgttig_Wk+cNqg@>>h>UYdyu+4NZtMnF*^SALN|{v$16K1%@Y}vjGSO4 z$v~bBk1AkY=Zgh@byvq{O}AY=d;)C($>F%=bOtfc$l6)zsk6f{@dvNQSsjz zjm<_j{@c@5{ek}b>&1T~xLJwBLU$JckPy^%PxJnZZ1;b!p9KlOes z*;m+SL>Jn*VzYhm#*Z`kLw=XNr;r!?)aik&DDBPl@Y&L9To0D|?|%2b9H{pK<3Dtx z0mgO4=nAxl6P>hsx;$ojt&kEPn_G zaqKa!d@gbJ*Fh^-3tCm3AA>sAJ(;v3F^2cK0K$FL;~1SL6ZS4CsX0SLYNL>fCYNCp zo+sYw$#@zum1pBz<=$2`GhVPOCAXT+?YynF={NTX%1*w!J3y6+gMWq=s8;OJ*@UAS zUCiJmZdqCC$#*gMX+}9#>G-+J%5@}){aDg~qlM7;LprH$u>aI`cw6Hv;TZiC`VNLL z>v%FiMu|JwwzgDK80+^z$K|(kNmE9RiYY>W(|Kv64GzK}vlSb;1#1xn`PUc_S+_Ob z4n|D+3uZ>3Olhvk%Nn|IWD+<{rU^}FHp0h_AyN`PeUKYO2^iLT{F^m46sA(@%n8b8 zZf!}Lww9)u>gvNR`vF(5wkFx$tfXXXgTb!k_8x~=<$`}@-*@=EPe2pU{(Vr%4!(^N zPJ;4GO~q z!Or8y`P^^ZI?*fr&B+U7^*!RS$pCO}xsyVSu_laNH@~f~Q!C8gp?3K3V>2_A&a{HC zTvdro?fgT9FS5HZxD4FAg6hmuGUo*^=xDZFM{Va__fIKZdP)m=nl0CpO9wcgV2qu@ z(J`1t(He`sNqCUC(~g&#wM}!(qdMl(9ejtfx1O%>7x->}LMhk+n~g~@ovNO`C!gY4 zRZxIl5n{3u6-w&m@r9>dHF%z zlm!wyzOB+lI0a8aN$Pq%@FHF_W63?PM$JqaQ0gINr?yC{A<_jG@zhO8Whgh|v^B|P zQAN0Zn(J2{tqPKJ4j%_wL6tditYjw5x5@5|=Y^1Tw9r#Q7uJF~*-(X2ZLjej)&d1? zJ)QB}84+NwLUTk*IDoZQ!9Dv;4U-|}?3c1qm)?J)cL0;!I$U7INlKgN?OguQNju2| zjzbPbk{;3p+eBa@`<$s%lMcf~znB!46xIyBoxD3frftO`Hk{m^RALfR%B#okw{bte zprobxHRl9nh1>$~|5q>c<1S!v9huZwVK9w`lW`JaKGoU91%_P*dKd{>NioF<#&6L9 zT{+@YzQ(egnic+$b4G?KYX-E#yu@W!zP>{eGt%=@&FrC;_YSm;6Fc!V zR$`iMLjk``&`v3hsibX2;tOoRJ#k7vT<0gee%v9Mrj+m`1ViXNVc13n4^!- zSnr zp%cy$?xO_Phbudw_^e-MMN?m@$o2f_$U(U|rfZoasrmHh1kn}+0-df^E7@$-+wZH+ zV*|CS*(otzdlDRs5fyPLV>_S7fAZ%}2V)iicIkAWc@!oL7Bu%L(NlMRmFFxwb$ux` zSY2fYRGco@)d~Yu2 zBvqb|tbDoADI08bsZ%La;$~(mixVo(VLJ=uVjA0OL@V3GxEd$H)b?)$%L^7Hu3a^y zv?tN6l_fWbZEloMu|NGQ?!z{{U9^v11Pzy!Pz$49;bNsf#}i9>-`J{!4VG_RkCUHk z_)r^pK*h+wgnrj*tcDaq)=78D;PoT6es6$`Xyc-V$P%cxij7sOtEJ*p z$u#-a{PypiHS^y${s-HCrMKya`%3^i-~Ox7eD<`Nwf}nd>>>Z>U(o)G;bv*m|D|le z96xN-w3v*b&JTQbBmY?Phi#e~D%PiP6yN9H?*R3wA739xKq3}HWk`^p9| z)G{uG+cnpKf^(YOY{Qql^zPHFu>~=1Voy;neH!2=e7@nu#$c}QQaAuDo1ttOD-diq z(u#mDX?kC>r9l#f{aa;mpr?%6y|vZ~>ap|%jnmV{7#!fDnlv3n$QmpDUou~ zA|O8}N8Nz6Nk4(Xa^hY*y%lR2O2w2}NyQl4u*nQ1ctQuPsRF5#V&sm-Kz^kZkQY5r z)1XTco^naEPN$YXstNp<6Y$Rm*C%ZCa&f)0?#E zx>BQ=tF_6s8k9j1zwBUofoq+#bVtnsmk9r_yH6l=ei`xCXR2@5+4PEZK_fKF39iD) zBpRtr*}}_+@lElxQUQGF9Plmve$(QsfF)blo5>LwJPzXiO|XW``st=b$1ZuUw#!z( zJ9xe_!*tu-X-5e-!VulW>28O65J6uE_{F)BMmtLtuD zl2yc4`bP%SrhPT|R|NcSIln+_6d_0KWMwI{QhlX&W!&RF)TVxRrU0jv0@Xf#5>rvc zOFstn_W;YK=EWjIaICxeULR^JSf;_&d)zb0(XdpD?f2#84kF=%k#M6szd@r3bLzn5 z4g`(Y7u0|HUQl%%2Ut9#2Fxf}`42Q~Hs0&wc8-eS*;3(D5J0gktnX;W5yl>BP+_CB zlZ`503F`vX7T{WHBFX=VFV%<*b1|s?FrH3hx)Lb+r=a{4;Q7-)qCWeEAyELme~L)K z_gLnL!kvbOe!AcA|9Z0_L>WEKEgAx~BG*Dkv}_LuH{WQgJ5%pC8Ny%>m^;Noh-gh{ zMOikGT{AC|sL-myH$(|Qp9TYMs*;u}X{i#8ww_7}(hFR&rAoF`$ulV-dcmO^^V&N_ z6Vq%gYO+*J0MuH8|>3Wqp2L7#foy)nD{9k#E+@tsRLiztzi{n4p^8Y4Oe~|zG z<>dbce0(|pLRE`{faha?*YNLcY+Zkr4Fdk49C%O;JSYbqlmmYi4{=kTPW$lsir2XK zg)wR6#v9&n7|Hhe-u~aQm}*pRs^Xe;Q_D1C9uH6>M#aW}YFEVMjr!39g|cW|#hG>D zUm3f=T?j8PljsudbWsmM8eIw4&2hSUDrf{5_X5k|RQD8hbQcw4=mmJ!*n(yJwa{+n z-O2IM-w%&}Kv|Wtd`0;?{JQ>i#F4O5$0Rmq*@eW?!Qm^h?z$8Umly1QLj{)kk{Eum z2hSH3XP6)B@2mNVQB^c?S~&Ri6+8#ZiN`fs{fA{LqN>&%6K|4MzD39h|vqtmisR1w2coZ2APuO?Bm?=E)KXaJox8v(5dAq+Q zDwt!;PDEjwIkhXjhA81i7r=CguNx0Ta&hBQD~VB#v;*iUiu$PPfk$uz!cq5eu z46sdeO)M0}RfZV7bT*)^3dKNwJcaj~jsaS1IxUo=Y7YDY8~$8Ss46Fi(-BZ7L**=x z*60Lqvl-9Ixmo8(cEjPw@;l}k8Yt^Vw`1|`eKZ2Rn1q8zbmWrdknULw`z)x2=P&V# z>7KoQeRlYI@BFYs%fN?Q5K+Nbfd9<$%HC^J(A)%C)Ao`M9-4>hv_pZ<16T#1>vZrmk}&{+F-c;&p|)Lj zN;CwgOa$tEhS4I-!I)mznqA#$Ni#9;;Z!EgtXGqCLQ~9oi*gklRJAf~61ZkivSFvO z7>!39u)UAZshTyQ6kRA62x!|nP7}KxUBow0AGJC!UX18^kcNlQ8Fs4Ml2)MR@2x?L zHeJy+V~OsN)RbY0`ID3JBtgb!!)m||Xp#jRI{f-YgH~pTp)e-pZbXXSIEkEa6g3@F z5dN2d8Cd{mK$pKKYO{>me9@@W%1n5rR(coAWDMy-CayKdj-3o^GrsG}bH2Xo^=S8y zLY8L@?u?=xcHK{vPs~vDhS=c#deb+>OPe zSw(TI&b6%9ruZ)cisTq%jMlMSTd!Nz>h`?!CuNl{M#be!$OWY0bS}x`)05ZYHVcHx z+0h>1P7QZFIIgm4V?DTtN1DX4Q>oI((Dx|nMQIw^KI!>D7=$g0=`~Z|q1hHuk_#y| zd#V{E`pgQjbs2=2E2EN}@tqWAgT+&6JQb8!DOSCn_Vr zo2~7?<38vD$+qK^wQ(@J;O!pI>P-lQ5Rb0{_{b8?BjGp~WuuZ5Soo_awhip^epx%V z=G;cUeU8`3Jy^?eWNs&H`nsT-t!%54qtkYCexq&O zhH5dSDSVV+AT1{m@)0q2gIq%T7h0qH9D)X*l4CLcmo$D`yaW`N2Eed;9E-uNGmA z65pkg2GKpEaia|9WOI^E1~Kv=)9WZ=ScT4zJRL@4uvW4|@7W=UB(=9a&lkRl>~fvo z{8-H0jTdAJ_Qe;=t{ZA+P6bK~GAii}d@;8tnBs3X>ieynjbp@Sikas%Ppva`KSt0( zICI%FiS6Bfd$@n}>S&+Ijf10od66vgOye70M79o8V;?JvN_ELIgN*0&Q(^b%->gK) z=*zBnFCxneg2Ti-3Na>{?B#P{UzCJlZPDRNe!xm3xmyBP2lq4Yu7|Df!DQ1(A4`~T(2en6Vv#C?_* zcEi+{efc7h8*>$feGKOcc!M+-q*l5n?17Fh3h!avA)CjBY48Z{N;-Wc3L@9<@Ed^6 z&da?vFdoQpw^xf!ADnvxEV;PY2Zyi7udpU!j<{bfmHxXdsy_awLyU3f(@)9i@E;|t zAVF4pyQPx+P8)Nhe*cYsfS+iAhNM+LsP0~1huB_Z10=ny>0Vif2<62yss%UD04vAv zETAA=&7qvh@_7QV);=#>_q{HA{(^tM6{Av{MQ?pu@deO!fkIb=I|`?E%X%H;A5rH- z65gVtBJ%tNSv53>$8chD^9*3=<+2S`GhmOlYwV|zwciE8+^(8()pn+8+fx;LZEV%V zX(eZg>**M4wX?O`zS`LLX0s-aE48ensi$wO)y~##`)bc9A$m=mS87>@Q%~PmtDUXg zR<)h#A}ZGr!?IyYv-K$waV?O4+yJVXnQ)ZiTA=>T#4WWXWgP&~$yLZI;KL8m2t_2< z(U$;u2xKbjqYx1sl97UwH@7J&HQ64hVOX;YtAhW7ZafMl-X0K4-FQGAfPg&LhuCPH z8?8e}glM}IHJhjfvO~BHrtvUh42zMK;a2oX0F5|1O#15>4Xuyidb;Q%i6;Gmjsqv{ zwXJu8u_Q&ZM;?m8&la=}*nQYnLwtyF9#D}P)S}ymYm{Koa0fA{68+!edxsVnoUy!M zCYclCRTV1Iyol1wpynQvXGoM~u}Iejqt$z`vmZYM@40{eKMAip;UvCa3BUsT|IMwf zEdSqZG@m{2|9?IHUxSZN0`Qy+__uuq{ChKCf0Lcy@5mv;8}auf>;gG5PG*zftDoVQ zzg>=I8{_2i>jx3Qg9zY31n?jN_!Ec#$ovO|u`?x}5)m&c?|o^WsG2gZ6@xUfL(9ZtoqB?d+Cf8&&BuC!tUg|7 zvyX6UtUm17vZX=Wwn~6;s&m3|mSm=nwKcEG8z9P|tb*KYGLY*;hGnB*Zx6rOaV)9% zu8#e#cX>MQOr}YgB;jq~QJ>=ZuEAd>>^o|5Gg)mi_J7lfZ`*MbzdJoUXm?&7y*@lS z0786;0Iu)?P4I6l&<9cqBzn4)V`MtfDMrw|!kZDKeE*Qc>9tOTzM~9@FZ_g z@|(JNpW@|3(}fJkt59UYCvOklirEHPTC+hnP)pP4AR@*Pn0&Iay6X*DgthdI@nfxj z%sHCh3XPhw2eHJqy4cXptD-EZGTW*nmQDH-wNog3NoNxzjH3P{%XH+E05+O;U6*;z zZZMX zH}4D*^iQX;wfuat9XS&!?5F^B7UIpKnQk_hpJ}!uXQo9RDeULF&c!&@zOXn1+o7+7 zQ?p&H@qJvw3^tkGT$Cz_PbwA;SpS+$R-{NSkA()R_lSIdvo~w+{OH?5Lt|<}7bB)= z0@vt|D8;OhM(A)t9I(h*5pNQgycS@_7K~|cuj9AoW3IBV>Jlf{ZN9M8rK zsrq7bcOa1`vnez3oC;?c0zt@~q%K!GlZ-Kj@V}0M8I_JG>Shv-(t!vN0O?*)lpWx4 zDf(VGn~sO*REsflm^aX&r_|1R(dwMELwQW=WLVH|4uU6H`v<=40fDg$4+1X@%u(Wz z;*|_XyH-jV`HU%F+(7bvQ?n8V5JGP`1t|g`sj}TlZ3kri0IAK5DE^`U{gL6tx7OK; zn%~mQ-aysHP^OsRVy!t@>Iz_q-?^c!i2&(V*ePWha>a{ zZis$51pH=)=KsxazGuzEB(Jfj2OWvMr)yzZT42YgcFD5jD|zzJSfx(d8Ozj@|Dny1 zk{1PLe~t}eRn5Gl><;0lFY;ib>hS39Z&j7|Lk+B52;6*(d=6rtsk5-CPlZWXTvk)9 z^EaF1vTp@xoeY7NN7I@}cFi`?Qv5QE;qH-LLCm?b6%PLpC8>qLvrtiE$4Nv}gv;U) z%oF|v+L6?X!>EtK(csb5tow*@u7%<-mVgeHg|-k1`HE6EBcT^AjMO&V4I^=Iei& z^;RpZ|JiIbn-BV*zn=cb1)pLi(6eGy(EeadR-kA| zTdn`Ejo{@tx*7&wU3Kx_zgGWq&Iw^fq zNVsjCz;>%e_EMUeB_FiWQ~{qb!y6?wcRHHth#17(K7#L$j8kD3D43tqU@#v4%;9Np z9QGDW(Gxb5Ze&nl-r@ZBOoUYIRt&Ew&TF5e)Sy4zKs*nn7jZlvjG-CX1f|NdEUgCP zUT+5263w_^DEQKyaU2jy4V$D>JsGM&R*hkAI-~frD2Lc!>&uT1(`EbSR)8q`Uwhx~ zDax#B`{Y(!s;%ni>hvS|=TX?%qES|q1?yi29I?PF8pRyrC4cJil0TC66^@ zKasL-{*h*InE~f}#AFM!cFu8oPsnPhg3qyMy=<&+b(H%E5u1N>bJ!n$)UIg4x6LY? z#UG_(q{*$SXmqgdAE<4-6HfKvbc7hKHB%VQtAgZ1SWaE36wr&bmW4BFduG&LJfmXG z=fWAOcVXpCa`l-Db}3tViEWxYsiJ*aG^sfn*`;<0^`hanf zZID7a_Ao>v26{qi3Ct{IorWCe$11?@i^5SLvy5UqtApfjNE0{rc~aRl{^7d}%5}&x zvJjd^y(QUjXZDNZeOCM*5N-Lt;5FsvOFZ=#QW>b+X3P$q%w2Ovr7Y^OF zhIYTehq=(#^0d+5Zihh=EV0~zG~7F%ocKq-6#)UWgEGXw9T0r|^}h-TicYb3M$4Vz zgNe((*u+I&n>*OKpx(ZK*1s2f7r%t(&PFeGr|x56nR48#aSV<1`&r01`>yOjetwLT=l5Vzdf!-FRl*3eX!P`MNOJfY5aU6D2s4<>I36b!&F_MtWD#<62vuJ7~ zzYe3}I3Xl#mi}NY^k6LXU@Y`tEcCC>NTyvk#_UXH`{X-oR z%_<8TmM_)Hj_PmT?7i(Aet)>%`R?rKoW{jsDuMle^Y#?B;jnYQr=t&bI+vrFZ=#h> z2Vm&z^yr||scLD>Fzh8`Ov{7G>EJ?<9TFyAMs(bb`+bapK8CUh+|=>tb~pycff2Ss zWTK~6MXhFXT_VlvD79x!LPJ*$aBvWFuI@H zhj8KEeNVf|k=f*`(e5Bvt9BTEP4ZbFWdjW<6CDB*461%bX=#t>C3@7yqc5i#^5K0t zr&0e&KjF*{H6UX6HI$-;Y$QlQ-RNEIg}9d?&>L`-F{uLp?0f){HO<)`;|)VlRE&bk zPo5yvw$AzBGP2oS&Zaj5q!)z=K!Mmc!W{+bgHEzbuRiLybP9&+ad6sx5+=Q?7(oho zZMRz_7BMWE|0oqV>Yc9>wiDi%&hhE~-`ltmR@uRE2cG;_N3=oe)B(Zo!=bAbZCLN+ zyQAatqm$07S8b=gRc;;wwZjNCB57vQFBrlJ*VyW#oBZqsFXfwkdUm)E{|9x|yoV~n znxGuG2{mOf5)6}wx+7#c4X&{wf>?KkMx9760~S^Z+uTvk4q+qB7<9`=JVh3qqi{V1 z^oJiP2_T8ZiM9u1;C6X(+Ia({36L(Qum|?4NtQD(c#}o+F+#=VY!D(Pdr9IOz?z5_ zuVV}ZBgi%-c{%2lVS2AOP5_}ykoqJl6z9|LLs9BZ=iu>ozy)kZ~|cxk6}}Yn;ZjeJet9~ zJ-F37jR=GiMPj%3o7-`BriUahA&e8EspT`{Z^?rP?7&Zy#V&$&}7y-Y?Er{Ayyd2def~=hrkJs zre+R^?d;c|GOpOGCo5lfVw33=AmF}=Yz+63U!iNXd&f3_kbo-H7n4~r$)>mw9wRCv^Z%0 z0Sqxc)Ix{^FM{>Pu3e*?snOxLo7H7(QLcgpWYkBs;0x%nO19-zUNSo&N)^Z4xag?pDfOF+=g)c<7u&se zP8z%h>03~8Kc2w2FbF2$c><(6pivm;QSwNu0xonyXuAipm6sgMaMcEQOqDNSWiU%v zN-enHiDncBw0^Vzgq`YLB|(K+d>MSHgG=F%6L-jrN*SyHo%eLjQw{JHuvHQ>y(ziknpocA`33(C%8oJfijco%Rtp0!P)GKVZ|9gH~Te?pkC@O*)yiu+m%@4U^ygjgFOu%jL|L_{#ehh)_ zFyUm2b@Y9;T=1OYwcEeFypBnfLfqv#Qd>;TAwL1^HihPfOK3j3CBOmv83oMI|U`bo@3 z=5dK;9RlVWNUZE!R{s@+s+k)@aBBZGzPPZjuk1aIlD%xU!_FVNAC44?wu0AY%6M1Q z#H|>X)lQv{A9e*B*PJaXxL?2x!qr1>k@ zn_>KMY{^2@>2zoDU>c7)%5qcMKGp`ZJY3c6)+egHL--T;7~c+6r-mC*lNr$*vNd2R z{#uij)%-)tIK`)~r?u26>GN@qEgF4@;ohSl7gwjQ`cj7oZQVnJ0_Z^4GOJu!C<9YO zZKR&rVeuEpZ||H&!d3zF$Y+Ql2P^73v1NnZ_m1E z^vjHLDwBRwM?z2WjJPs(@^chTfX^pw$>@^bRx^y&N>VH7`z_f&V{J+`g>u?7I|Z`K z5lvkV9~GV3a5Qz#jXNy5e`|vIX*lI)`HFV&gw4JGCGN~LBQe<@o!@N6&^tr zy=uf2C3mi>%d0Sjrocx874G9vGJZs9%7Jdke;kbwf^-F;5-RX<1OD$2Li-MFmZ65I zHX=P9y+(z%*y^L|Owl}4CF@O6-fM-TbqWD9;tf~2D+>04#}pa`KYEIc2mL&LP>Nd# z@Pevc#sJtsq?GCI<4>dM=a+1UdsXL}@snf~gvq55NKGPiPWjEdOK=V;J%HH#KY{{e z42N|7=Iz1J*`r!e4}Pl^)}^z0^kh1mELjt<^$NB7(T6AL)o@X5p7A%QZw^&W4+<}8 z%rN;Rn)aRy0c)e+c-~l2-4(Y}i$Wm!jcK?2S(4y|MP~Gd?MjMHC`W4+RqVw58$%tQ z0kbtlOGp`MI0FJ@y{9B4HHk6N{}7IPQL0SgN6`(CnxiQYTnMR0D(zf2rO${WYQg1L z8{Ft{LZV-!+cX-FevOhbnK&3Fu6)EVOT8zwB$|&Umc{E^2+H#|=KTiW1;(X!>;g9~ zs1W)igfg!-N2r)LU#ulq36QGJ*HKiRP^1Z4zgAeU>b@6?!NsT8uzfq~iWEHK-@`?` z6rS-qPPA_bBQgZCOrQM5SIa<#0}t{TmeH8TS$5&uu;e+HOLqk{z`yQ$^T|g+th|i4 z9(lAV2f|#);%if_vX8flsbUmWqE66#`uVdr;e_qxdRMa%8C@vT?L6Cx6Hte}qLG}K zY}m$f4xm7R%Y$zO0*Oqas`g?OqT7mfaE*1>Wg?cw3EM(QYFLHBTtgC@+vh$6|CNPe zMDvTj4iblyI??j9O&-xzndLj^k@GVOQ@9kWBwFH#%-iMkilkWRqR8^B;9?M>2R})* zWXiUeCdD-pETbe4h67&>0l?`ew;imj9DlV;!+QrE1+6={qN?7!+B>pIUfJ^(T9#o% z2SDbG$m&MAs;SD4WoN1meJnjAiHtiGeDNaqzZKLJygfVmcJKT!_-BB>?VX&S{P5=V zU7J-)RP~=P=u`Wfy)zPr1_4KOAVD1A_L@G73Z6vpMeu)(L0%QQ)(Xp7S%ppJb8_dd zb$m3y3!ZeIVfjRzE8lC;e{okFui;KRcHDb zg++p^;jyo)U!=QoU<7%OUr3u>*N-xp<`8hv!94w+d{w0y-+Qb#4@0QRg2m`I2);tQk=+85JwP9*!UBkVq)c_;#6JHu{_oKv3;2}H zS{_~EKps^nz1}uZ+gQqTVKkN^yrfQ|7`*8W9AQLuQlI3N!z)k9#+BYV*+xFl*C%qH zk>IJ2RUQ@{zCAp9gHtjkd;9x`ZKQ9Iml}@;XhEyZYS9duMP`Z&(N?7l=p}m-WD3aK zUj%Fh+c|jm7PacphbTd4PR9LN4~^hRsxHRJXx$Ddnbj{P9pQebndY9b->*!e*Rr03f}ji@Eiv#s z2$jOS%t!GqY*MR;PG)G?dQ~XMnl@?`k*Gr!dh|f-kn&}!;Vj3#C>`EBG|H&aw#DqS zM@T}d^l^B5Fg08P3>XNy6n$kpd5REh~OTu36 zMNcNWnV{d_MIsVu?a4`W@#ywCMCA-g3W9zNm*QIHL1yZKSW~kjjW7U2L3VHHS)*An z70z|Kk!*HgIgRq&BYPY5o|&FdE=V5#@YIej)dGH)^?p`2XDIg{ff{}!0WKAEP*R6I zRxXD%etZdnO=O295Wm^Z1$ZBaMk`OURDXeB*HQCuC<_H8(PfovyLetXDKOhwDFDMx zbL0+=nh<(GO4W*fbt0^;DO(Sr)wSV6;A@8YSPs=-JN@FVEkX#y$sjt&-(6aT`^4qX%%D*^ zz1)To0w;#Sch!*;QZn8AtEto(A|KI*Ez!1Yb*MC;<}l=`k`32%YZkF-YI~r3Br+USWBtKo#mvo{xnP!&hHNZ8%PcPi94^yQ%cP3Vc^kd!p*vvT>cq94{M6pw-ikAI}&wbL^^A9n&hWP!~ z6dvJm&|ULZ=8L$Y*sYp82FYCv4gHn%k>7&7DeXnOEg11~-ZiIgWx zlB?--vh(B#N4@wEaYT_6bGSW`072;!?u7e5(=z1tNnwQ=xf+>{48`FZ<8@&7`12%6 zC?wvf7X=(KE}HgOZv3|%43S<(m*b77KP#8lf^TI5nj702o3Jr67-kYQn?a+o)7aW+ zJjEbXPp#Dkl|DxN2reV^g~m8H<7u>mMzcwz0+ImHH=Fc{Vz6QcPC1GR?Ig#1;+JP? zyYyVpwm|0_&Qx(Po($u(_e9-S(`cVudAiXBdVNdKK_DzX!R7t$S={@Xc;m7McTbk?t|pKex}H4fvI;Shj!I>TUGYDN^0 z=@kb28jpbXk0T1{LNOhg5Mb+Ts?f*iAS#}(MP-C4BJq-^yH3!!aaHC;^~JHC5?ryQ z82jJ2;<3fK{}yWYTyG-S{&HaZ6hR#oBiNZgZXcR`t1eM21@M{L%uRIDi;{^1r!-dY z5>!CWCcAh5oV}CwQLz7H|M6qgo++v#2V@4cdC!#$-jqdeGCW#*7D3qfR&T3b1BY_P9o|28u}pF)HfHJmA3*LW&13E+*5FD@doYNLs$E+|-sno3QBEXBtG^cj6X zq@`nPxQ~hIqY`agZootKY@=CKVO2y>o< zr2=w^m~s@M=`Dg=Wj3L3M$K)SIX+5Lk>yN~sKBk`v!xg*WVb^Y{teu_;cTd38mS0N z_C!*t9R+@7V_@(W{zx#8R?ETCf3~rs#+KF5wx^>**h4vHH4C&v2B5g&h-b>2N6%Y{ z>aZWx3&|`wl5#xaaKUU{gh3_y9RCn5W-l41={kD`W53o8zdAiV$6$OW^qI43W}|S} zouIW&YXP1!g-z3|L?G1>CiRr(?b^1}(Pnc&M|#^x$fxX^2tZK;s5g5f+E7x9O1)YY zPCI2&KMN}m`2Yx)LJui4GISSB1PY0g&Fw%+@WzFw>kv-hGE#$&X2Who)`!u}GzndN zX10@{{TfM2W2+UbhpURmL2o}*L(KonEF5T@GIplRG6;OdC%hxlV~Sb^Qca@TGbQ_P zW$qnFESxk-KEw!tAL5YeR;n0VCrbGBppZVC!9guEHqSNv(MLBK%u+EvL%JTXG!Yb` zj&e`Cq-So{L%Mo+@2AyW#IKxLAZXQ}Z_$&`crHT_WVRzfL-F)>N4zuE)9@nN6;gs4 z5(0pRxPkV`JxZnNBf|#4WG^t^q-<%}jRz>pXn&}@}I1sox(`zR{6Q_36cgd&fz6pW@viB#Z;cE{tN(NW1d8FEw-%6^K$G4uhAlVmoTvV@VSG-iH= zQ8-Fvhc!kO${IPZFeN25x>^e01?%hLaZI>4MZxh1%>zV8$>~x?R3z)hcUPHDDRzs9 zWZ6268IOFp+)b!4{z#>-aNo&JUhQV`reM5#HyE{dBm-XgG>D}IYHk_j?p;u`0u>E}r%%_B2j zQjZ#RTG0%T>PCSV^FAq)ZkQfMj)vHSH|@83`-klf^JKp?>=DB>`eHJssr<`a)+p937xJbh^Pega=kfXo~Pr(LY$gMJ@Aj0^0L`<-RBvs&{x6{wOKBwkF05T&|7z+xzc zBl$2JjG}}Ik~qrEKR7yRAMU?9BSVEoO=Ap-6Tkw23O;Bm&Uw|!Uqvww9cii{3}hfT zSe}TY4I-_O(!y}!Q&Xe_QzlxeJU40<6ol4%HSbZ4pCAz;lTeG)#f;POqUn{OXqR|V z*b$5)A!Y({yrHt?ljsiQ?RXuJHk*dfip9QkGp?g4FHJ-PEK(b*jn>pH6T4&xDDjAiUK=TP+Hy=!RbYH` zTKd+8X`G5z<`mF3$zJpYFrp1b!jO-Q9z@?<2EiIRXA;}3a3;5&Ox0m9B+>ek_=CiS z&?HxZ_A8DRhfEcRzTt|(~@`K;-H9Z*o{ZpDnJLAm0SX-%6#(X z-3k2Th$>{YN~8iz#0|x)C4hi#qv1@_@Bmx+VT=Zvv`{0SiGuyT<6{%imZFhY)wsx- zJP}j0Y?oR*Gjyldt4S?DV}YcEzTV@5J(}{PPpw3Cu&4l>5!vhnN61sefYM2ykg|>^4oP$-c3f?a1^W)Spe;G?+)dBG z8EzITnX0IZfN8eBJvw;u{oB_y5mVQc9dj4Cv75lPC2UOe&<&tz3QU8y zbGi=H2C?PqM6dzp62UAgEFhhtVf7_~(FmVVk~*N0l2j|mE?*?!rAY``H4;%rJ|hwe z67n>kZjq3Ku4X^_5K}G$VyE_GS-j0cu44iK9Yl5-?t zpM|JW!vFMt3VZxM5Hk`^IZ%?yOQ|K)Of%?hw2acBcXH-rtcqKk-%&j5!VN`0i$+%= z8;j$CD;W#`uq2P+;jLiKu%|?D;Y49$;m|PLyWU#N6ZrKD+|<8!Ed@=Lb~i!nlakJb zpCchO#bO#&prP&%j?OG0KN3ET}YHb&4F-=dx<1rtiHBZa~lBSnXIP*j(SpuOKHM%qaU(wlZMemQ#V;g-7-A82!%%VrC*{z?MjLgSX-In`R{kfe?nu_!aJ?6)dPI>+If zj66ux7}r48;gO<%8fQZMAFA<0PKB42M?*@!OybSUt0^#HUUh`6hG5cEYaN7i0=#r- ztZ#^rK;2prUy^VDUqb<4wH%%V$NbY~iZK}iS*;k(@Led*wMIN@&NgXYqRjG3bZZ3C zdPe4UVoRfMvSr)`6boh=MvaOPUmP0*-nB9V=>{_Agupb*4-_b}JgOhP*>(bUmIh&B zLbCBAa0jBj7n5{G1a%~OB}u@|1htyTEcB3{#FvsJVm=kU(9Ao=&g>#!UoT7Ecc6sn z{DB;(W)szx7yqVh%edHU(zY4VJ~yTrPL>SMkgYG5bA}_iIjR80+aznC=PAu7^~FNQ zVo$$RO0blrc|)ZBx-4{?0LR9p@%5M~mnk!b!L}$j$0K72gMCU$8tj@}&Gd+=JYiy2 zL$VYxC{nBd&>eE5BN950j!Ddm#O^}R z4L4VwxMBdP2bBxJ%H+)e7aK;4EHlxOPW6PlV4)Xh*9{();40XiiU=40IG9f z5SX0v2roZ5>fD;4U{6JDFgv5tJ6Wb|MrggvUhIb~Lt`40h1s@%TSzXIYRDC3m$g4S zvPXPnH4;&cN=h!jsw1j4C>ODbg@W9cU*Mx>A3RtHzb0}d{ zUXjHQtb6YzW=>t^EeO*ZKnu z6;2!qhh%v~W>AQC$0mn-ENo8MuOWh&v=e^nBbc0%GAg9V&M3c;o&QeVqo!rV= zU)`S(`mn8mXmTm;H9WLos+Gj@bXG<)Ov*U!o7 ziHJPTehS>DS_;|KV9I6XIUs@p%808shXQ2uI>OOVKtA|4rL*+rEp*)t;VMkaQ%2_beppvF>o%gI*7!eI!SGn7Az zwLS?0#G(yfCf1=7)MJ)fWDEoc5R|h~4JnJP_7kKSbr4yxte~yPoll0)HvyEDS(uVw zieU`&*RkYG{qHiR=+`iPVw<3r>HRZi11BAW!cAtWsv_ejyHEO(fA*GdYMq^AQS z=#=bALWPTA3S%t3&j5J`hcDl~o{I)u^pB!KZlhQL!p-rBSTv^3+0G&wqy7Gr<;B|Y zP6>Tza!{=whX61sDNSJ8hAF=T+U^^}3SC<+GG)u;TCyiA10C9SqCe>J#pxJ*XxR8f zHjs7$1)n4YzyT5z^A00}xG8f0pejZB9WH&4fAp&J!r}hgTVWz?n%x5}U4(!V?L^fEx zz<8zh+U-O52_sK2!Q;buji7>*4!^H%QGQ1%UiUFYGg#600;d8^AMgOlt88*5D+7+(qR_ z!461LVFQJFb$BSG9^xk`^Ni2ZnJDOfMtD@agh7m=#PF6fj573bZaZ)b$keD@GIg#*PwPN77c2Sn*59K*Z z%Li+4lk$2omI4(e6QCL68f*>=SCFv97a=5}6opGmEz=6ivSNI}@3nXQ%tk_c*(J*C zp!|2Bcs-ro4wUf2=A0B`#ZqZPD`m@C0__0UL>Uq6HEZiiEzWCm|}=@rf4#Wb41Dv&E$qNay^-HKpZ7wI2tKKS&Wt? z3^WP&#Vo_nImR>LDjX=M&tZ7Of-2@e)HXPIddY4@3=CMEtQ#vtDQ${^4~!ouA{+KnCbv9>5*HDwv$ue|vwwPWe)Rg?>AQB( z4YN5=R>1v!IlA9d;$A8fN>&^jC0%rTvUYDmI%< z`EMAJ3(kpb@Rga=hJp*C*slOl!yLv8A%uwV0gPGrAaT_stedvH8c!5QYw2R?3`vWl z=pj@#V~~$)ou57?33f(-is(`xiq#m6r5rwJiddDrcJnw!zYr)}D@4u~{LXy@hT0e|_XrT=Bb&%9koznt z(h@H+bM?Hjogj^m zgfh>%%Pbs|@N9)BGy$DF68gmcbR&!W6gyDNtuT=RQnv5G4RSoRwPHZo0cl8~_@Bj) zG8PZy8i($&q;87utyEd1&v8X7Rn{f0>+QF9UciM_83FQniKYSlO+pmr;VXZa4^2qWGcGrXMDKMxN}lMjK5@Kq!L*%MD+? zJ32l;I_bQ6)h-esi>Kh2jjb$6vZ1h*085g11s4}7?4h~%W8onpW&6L8x8gwX0H_~d zaJE=)Lm(m0%>eo~l6$!>SR(!GIsvYl(ji93Bi7=D2CTz=4Kj5Nc z!1WB!3|`E;t)*J)tCq{2U{@Y_6B9~j^bfZ)`;gpz!@3Slf9RWq# zKA;O{i71c_d4$c;A{(X9EM`P-9Vbf9F}SswXwHVYGiE9jsh~(DrUl-$&pJmZ`^WDN z4m-lff1~IOOd(J{JLJ;;Iy^h=y!_$(uuZWR+s@ia<6sH%5aTez(v6q`z95MPKh!#A z5+07_d@fDOfdrmpc8v%K)f9z78;qruB=AbY>TqiZ7-=6yJy+GE9oq5g|1yiTL%Y#x zSL#(lvP9P#L3Cw;CM^IC$9wyKZ+G6E9JS96I^Wa+{{7Yd$@#JQwf#f8^LFoS?~Pjo zukT6c8|k7AkiY)2N-aoWR?pv@5pz}VmSLZrpkeIwFI2t5)RzuJ3ueBOBt zc1y{zX;1bm6UQXdHKHeHf=4En8JBvK z<4A?2ViP)IyCX%dFv4OL@CPfzj780wNKUpel_?%FM6TIRX~c*Lp`KDOA`3BUn-yiA z!V!N6);OKDe0MBbHVkVHGpH*Gulrgv2`4*afEP_&NO;KB)+*YvGC~|_rvW2OvFuR! zk;QF>`A3|JcxrSu^p@~;K=ViEr*8ob9XzU<8-_f52NNr|zd1cVa4uN$&C8{r*zLjs zWEI@QWJ#WlgoB){6NoDIYs`60S-49`b|7K#DUycCtWLQU(c%xKaC^#hE5J`fM^nTs zrj&DPi6KxUHn)ekgv6XdtIyT<2V%}oJ0*=Ef zOMk>|mEH2y{xcSsQ9J=HCEmjqlLN((2#^h6C2$t!+zMrCoa~6DJIH-fzk-n zbetDa7>4D*I31&o?GoR_$(41UX+)ds9FznY5P3p5a05ZcBXZl)vM2b0lsMTv(Tjq) zC#K_sY%wP6{DA9-Z`{=(8JLh%;xG7Jmhq{c^qUL7I81wBH z0p9E~vJIN>SX6*$ba0zmM?~QqXOo&FZMJld7(XTX5V`(JH6^#esGCCL7=yBir_8b{!1kvt@kaS*bDlb>$=eJP~uc4HxB73_&mSBEk( zaS8b;w`6=0)rjCv_7oJO4S@)efl!yJTD<0CWb$3V0)m8)GnoGY$rv@1iEZ3KI2FKHgKS`~hi1Y%aC1{LK3Z{b*zR(OmR zwfVFsQ+;Z?wvYow8RUzV;%%N_YIC{J1mNvc|Sa(v#|KRWi z<3UWJcxwi;Drvt$02D9Qf)ZLeuR67tZLGjafv+aRmx*tlj)TZ?cV@7yNV(W^XPx3B zx{Z(Y-l4RENeQhURaFqmKcE6gbfQM3d~O*hp|F$;T85K25vzX{ltFk6+%r_JidSyz z+F9y|Io9Jx_Z59{3>RR%b>%XL#J?C}mTKmhxOvJW zrOUV*PcNP0!@ZNv-pN7d4g6pQeBEM>2)LD&8nNr5ob-63=$P`<04$l`6 zcVs?@l*3!x_Vyz}kjxh)3i;FxkLg;Xn6H-Nqb^&ze<+f26_hMRgS}AV$%*(8l^#W> zp-+`l^XS1)sMa|+ZCj@>PMaTh0``Vl(843D$>{t)2YY8QOE)EulyMr$UU1s}9@f}H z3)l}R#gJfj@z5iOcr*fcwe*_XW?cYZgqFNdESA2r#!G> z5>VWxPuS!2>T7C`&TwMv;dY$sMJ3CynOSY@C0#JipkSj&x=^sTh~g{GrV!--I$AN7+kiT#+i; z_2^yI=`>r>>RlW#bf?N8!1|Wm3 zy(rx2!Tyk&0jc5@q9(0-WjrX~zFSehwcW_Q?Yv8$) zYWO;|D=gjv8rP!%q5YXRAD`BwQm@iLb;WPkrVb>b?hGj{K*}@I8(K8?d1EQuz14ab ztZ66GM!ng}AoGR$;_KeCJFe*2b7;m;EjROwN9aT~#5kx;^eDiB3MSY#H9Sh_%6ikT z;gQ)^);FufI}`>;c%zIz97T9xb;Z$rV#Ae5Q)Ss%%T{O$Qwh|~N2gC#*`A<0N4W=} z;KP_iuu+PgZiPL5IcoTn!&~>2Um9g9A)`;*Je?CrJ840PRl;=Gvov`kT$+ymW5Nl` z=xUl9N~K6@9Ba!|Vx2hknbhdm@LKL(>E5nmSS^%?OO8XVPYT6z>0oU4pp*QBL3cLl zQPd|fOC7B$XohhE9Fq~QlZz+MNBGeXM!wZW6`6!b*yk8 z#amaR$&&#K%IM4Gd3HTHn;ey2XwKnq!W-IAG1DV&N^=$%TaI>3Zls)?m@%_NUYhoI z+1NF-0#+JZLw&|3Wsq!{(pPa)0(!Z;I<*}|H(6s)k45zajF z!r3FCFBEN1I1pBNyZ-Kb(vfnSQMl+j#Fs(^V(El3#drJX=ApGB`&+b2wpzKIK}8h# z$oHDfJ5(_*#hcxobB=`AblFBpzJ1hKL&^OgGl%o+r_b`PF{$J*-4Z)-RM*zB} zrB%gH7mi4vfPM)MY>EXV)n`I-%%NWlovi|b=!@4Mhy#K9hYPJ*wENjVlvcph8Txt} zW_ub&LkivF){;W2o-$H({z#!!?SpU757}B1U$sfDn#MNS6%f&uSt-!)`ISzlxeZ~3 zVrE0AFkh9OxieL%Fkg2@u-y?W|9oM-1=@>q3=yk$U6`*Ac*1JqE412JQIk3vrt*bF zEyg+!Ouo>%KWwKkD1p(b>s!v z_Ne%E+Hsi-U0AhDJ|!$FWPcCiXpIVSm26ULG|OyhuLEY(^7hdZ_>24`WTG5ySbY&Y zbL>JVG7}mq*lc#=scR*t6J0@_tyVX-2rV?zFxEk`jik19Lzvc-&rzx(Kv}^Fr6WeeSKu1oMp}aPKKuVHqjo5UNgC=uO5X%>ygWRH@8rfCR(erC&0&!_A z^+<@eG^3u@2K;EIL~j3VAZXlzr}%Fc7}TTO9rxT}#dO(k>7oXeb!VjQw{4bld}X|jc0s&FVpIGwuOJ)RZY zz|7EY?FfIn4%r4>XZj-}X|no}mGwFNYh_XuQzDZt$AmFbJ}KEWIePa3d1ZK?^w#y< zi`|JhnlU<^bCDEuB=vm3y*CYmHK&QX>+B#7v)7h4;yVnD*)`5OWoJ@qCVI-sTR{$7 z&vYJE(m+6S8fo`x=7Kf1g|YJR*i#m|aH~ncnI-L5fzVTBR0}3wvTaz^pfoyL_KotQ zG#xowbMI=RXzMZNf5e={_7Rz|ouiI>LRNvCnvT69DT0+Y?9djuBg>1-nDY~EihxHQ z-=-dOYemhGRAHS-L&PH^Ntt?_PB1jS zxX{5`C<39{%#FZx^9fbfO&uNrwvl{)DoIpTc%_8i{iH+I6DO?ho^!i$cTW+L3SsCdk=8BTy#sNeX#(ny zoeM{pND=eO>1cQ+LZ@1n-nslIOB$5*Y&gn9@*vp^L8VhsK?q7jrrMa8YiPH>AQv!` zeE3xYMS?XkA=9a7;CUDSE4Iz;itU|>Jfui?72wW>scn_Gl9rCSNHAG}ifE#nQkD$L zE`>IXP@2Je>ZBHLL z7`p`k2*z`-akfvr?bh@^cxeJ~=740ST}m`Zm4i{FI{AvpEKU%{A=o6A zpPhWEqARYe?oA1I4Fz$sVJRmNFH_7Qw)?|yXHhyC3l>+cb<$CF{^IF)p&X&b36{Kq z>>QTbBhpB2t2MFU<%`+itQBM@O9t=*(puClMadJQsOM-)ym}Hls3Cfp#L)$s_-oWiZc-Ww$mt;!^-CI5 zL^zoXN&HAs)IO4!+41EpQP#$s;%e9(4;)sRw)0bM6t6M?Uq@=IIl?o_WqjJ5^#=Ua zTtiJJ{Y5!XZ&77q8ET1PCuNxSYJk?8G8yG4!M$jd*u-?f`YZL~(Gsn1a&OJ2Tba4Q z*3^YABGssDa}_T$UP#UOfUCHnXWjmOeQx8^I*zuJ?~CP{vs&!(yBhw%)CwA zTdlHFFDK<+a5FE9s*a9l14Fb^Rx2$~XD4gzSugV?7iCKBE_MqX4H7db2?IE?eEu$o zg(G`SiU&A~F{OcUGic^4LG$n}qU_hO#S%0li7cAWio9q~N_)YoK$mj&R7NMAAdpB4 zqJ+_?nozJj33&+!kq_C^b3_~Y6IA@*@+Wz2ZN7H1aGZV=TV%v6@r7|ZRf5tor|l&E zPn(b<0Jwvp7f<+eF~}J0+Y&%i1Ts3k$6}x<1Q})=mjfCP%#?$>Kur#2gr-^yH7;Bz z$nh(NjV{cBo=W$Y(h60*8eR;`Mv&cSq&Q9?-dtNspWddI2q^oX^|Yc0q>X=qPy zu7W~EY;dnr&Q;vGUfdCSAuERuyiYphD#D|gfwgv=n%O+Jx2!UwB2={GT%2&sj|Hl^xlaJC{I<#Iz$Uxg{cMij)8r z$tI!mY6kxipZO!3 zYZvN194JOe;v2C9NhNM$|5?iFX;NSciO%LfoQ+08Y*O2)Euf=Q$FoHT%rqJR1#vqH zhvI1EM)eh;g9@(9aw8JM#ahmwQjW2ePd>bmaG!70tNdp;#Ld=5RERUS1LH2 znAyZ5BR8?3RTxh8W|K^t62O5|ntN_jqNz0KUkP+*eijqYwfTH>gi0_zEf&_RuXyu3KkS;CtMmwIH+2b>Z zNB(|%d~EFUrAa`hP>dB^o1?x{m}ns6B)t|Q9iF90u^j0f46^r>SSCdck2yy8XRJ66 zNpdwdTckIG{EMx0^%C_`yRftSWgdr^4ypy{mBLZQ7h*1lVcnuWW%Y5>AxcmW%2x1m zjH!tUb&dxrn~oKR+)igfF~=wx9A;1>*JY8+TX}56W{bj+3?#~72+)r~1S|>+e-~Nn zXpBMFB}U7hhohvwX2 zfUQU_GR$!{3cjKQXDaeEf5GmckBT!$wc>fTNBl~UFYLNilNb%h;NEDMejKUMpF9D~ zaT!wFK?3Ix{Y)@NHm=iT%(J%PB2M6nzM$#-Sbxv`puD9LQ+~G~4!#OT>y6#u@#DBE z1Q%6~->-j-yQ><B+F&Zn%OLn+}uKol)OB#pJqO!N{p7deHbbs1l{w2eGW zgmq~wm4!`NIm0VW<&SvJHgHdlG%}|!A$}5y>07fP4i$2tRsSY1L5|#6k=S9f*pNG` z5<7VD^W@H|#15-BI2q-A5Ib1{MgkVN6wIph3vX5N6SxfhLfe(2U{<7GDD<}jEKAcb zWBxO1dZ%}uP0fEtxe)D z4q<^*7iD-d@Ty{QQGyFQdK15-gsaBgpCbH`AjX6&vG9NjM?tm+NCj;KMI_BPc+hurZ-Npljr+IQgbH=t#(TGWT*(@Vv#su_P&aA5H#8O#QojkFl*sb> z-uNv9RopN(c~VK}QNzel4n=O{PzOx%Qf5o}&Rm9Oyst&o&3UR+I5%}?bOiK>GH4iw zAD#7pRpeUdEpfC8uZfDds3XLQbE6B%K$oafl-!z42{I`-S*(PY8p^(eLO|nW*D2mxWmK)!lK(vFtJsZ!uUE;=a!)n0N!VwC^XS5|Ji@#OI;^@UIRaUb=aV9^NelWk zSLJa|#3+D}p!6rQU8{6_C-TK(C6_$#Hlo)8qxk%;i9A z3iwqtdSgw9wg6+wQZJ#N`m6jqd7TcO6V(p&^s7Yq;7^V{Ll?llOt>KycfT3hb$sm*qpOr-=v#qa$ zb$8PH>H*Brq3a#x4AN5cOtxGV@ea2rx|m{!ztK9Ae%dZqMbA_r@$G(fY`6SsR0OJv z8IFXBmpOr-m7SglM3nskiNR3FDH2qoBY(VH-2OMtMq4Hy7*Pjf zzGTR>OvEtit$;47+s>O5~uaZ5V18a+@p4L1QALLMM~ zP`Gl%bF7mp8hb^sSlV=mrD8~5G$?mmXkF+%2g&dpVf?HVrpL! zTc@a#ENiV~YO^d74d{fKVSHDJX&uosl*l9M zi#=-~zPqJjM!717nn#TIya!b9h2^BlE6p-r+_dVj#Y9{B+S@-T>GRWiXW36*kp#4W$ByKHQ92t-?Hru z;M`1Yb)hx4*(f(0s>OKG;W~_Y`zRPsLd-Tm?z~xXheh)e4Rom-tNAe`pBSAyiV8bJ zb75%K*f09o@%zG+v=ajXQAei3zom}3BbgpM%2^egRg0LIoDqcr>>PZLrz9RCnQy)3 zp=2GQ#L}NacakPCUSHPOwOZ( zLR&Nzq}bY6p9AAio?|qnMw?+yl`3n~*0&~1?PW5)#wWy<4{AxbMYK4Fq(vQ;jhfr5no37p@HVnQsb}Axzlc`HR@n=iW6JB;)|n$cARF;>{>E42~zyo3D`E5 zpvwUr0VKuI7*L4yLFnhLk9Hg5TLpXaE8}j4C^00Ux0vHKbNFu76|j30Ke`M zH6`(33Y9mcszA$j?a&G3tk+F(IOcBTvL;A3^qgX5DQzKFw_|Z^RDEJ7mZ65G z3}#pGc5+PGzRGK!<;Dsv9x0&-ZMqH^Z(Uwv*T|yUzLhuKHc}LOD$AS2kR;jNFT5S* zG==2vlJtFv1aJSv^-?d5j2_i=ZkS9m81Ozk?pX=%42`?5;e z-LI>18uCmo?^ou%!X8D9HN*T@nk#vQII}ID>ss+h3-)wjZl&C&`}FpOiyaT=FLyk= z&jpW%_p{_+2~!0JMH_DcONG0Hvxf-^gb%%WC~fj3H-?9R(J#wQ;at2v0Ut9VcQAKS zMON|V0VIpu%$v%-D0oeoOHS>0XXA^4%bGRw%?#qsY=OnE^Fj;bn|t`V+?goL!^~6* z0oOOeoC76MPksVeyvmhfrKRrCcRxfQLWA!iy&s2;!(6r>p9_@P+zdaSjf(Rd2M-bz zh!rEp39pk4l0$QQaZi6x95d!@YnW4%^xKp;J^q!`3aG$qR;IlgRH0CF$t`X*B`5EW zKZx)Zld;!=3ER4lIbfUWr4~f}m{betES@r#r6X~XllxetUTFTsJxMlbMwupE6-gm1 ziLVOcaBmx<;*IG*VLCRLoWlCtKSoFKsg6`PKdvG{$D8(k=i9@x@~0DY01kuekl4tI z&hxMnv>L6gpvnQhf=4PI$s<)Y%|MUzD5L0*^wWMkrf~Fu1l>X)CmbdsK;B2IL3gkE=X|hko;$aDPuO)gSEaix6vORnXAB9* z?whsFcWE+V92~xU_nOwQC`h}=?{83BTKNS2t*U_VD)`*o2<>Xp+zsV&(6gJ@kR#_( zcw3mM9e7Sp$m+>d%50uWnqh4o<_OMi9?*?wofu7f{#*yrk2?2UKwZzMZO^c&8drwJ zblBeWk`COD{)oJGu;N^r2bKB4$?`B9h9jAXTE5Cnk)4R{BEPqiy4C9YqBoij+!J=H zx+7%c*XQG|TZ5TADtffpD29uW*-+BnXz@G=JN}uDc+t}P)U@!m%gTY`96EIFJ8c-62=BtCz5EYAbrKuJ; zw-b<9F^0usl+TPqPx%Dml|P~F5pil@tA`tJw$WQVQap)n@sEEzdTN7q!d^P!$WgF? zW-Yu2Kup+-sjp#?>odBs7c{tUwoeSI#{SC4I3jE*6!5Om?|1>4UU})h#m{t{Q{li&P}&%y zsZ4s~t_={YVVbG9b<2L+b}kFD5Ggl8%_}HU0Ig~B*-oME&-T0RaL%V;TT;cx*TCO@ zb@)cVwLRI~4O^VtY93J7;N<#M1Q0!vc54ABe`tze+wN@M3g^w~I5Xs;IhY2&td8NK zloIb^jGA#xh%*e9(VSzPmD5@demGo3Bj~^I9@Rt0V7!0I!gCtE5E<2)i)M8+ER};L z)e(p2!7J^~NM&kOIg?~)I9Nv0>uK`c&(nN8F?05*h|z*#{rFsZ%kh04wplsnkp zj`HP}bLCEcIw&Zo;>JUPrW(OxDyLq2_niXz`rz~^EbSLw(HOkTL(V~X93oIt30-zy zH-o%YIy}l^v~pT=^wL4iNA|&_{PhC#P%6BF+)dKb=G)W#ANUhAc>II36jZ3I!IyT2 z9NZ^vw}-fZV~#7|Y9#}Xjp!&}wbsd+5;Uv2QL|HH=B5fSK`4rD18e zg{<+(9!pR%W>jeVp~ZZB*W}{R;QI<=bc=nfk;$!#f_4nChK>qN=1$tWEA3+qzY&acu#1 zFEzW={Nd5Ti8s6WqItBvvGs|5{dBZ*f@o`8u-?Z0!T!&C2dBq`Q}{(SqRZL|k(XNa zDX)}b#H;FK{d#xf&9TOsyR!4+#>w_4AHB(>fyeFY5)I6P8;}Ln%0g6MMweGN^M03T zSI2d`ZxY0IO{xN$KGx=U@v2&@1e@^%!I1qs`f71(ABqKx7os-mu05j=7ZR5sVh}SA zQLRG8W-YqDZzoqxv^Z*>qfZMu*g_vS(V?-;+SqoIwT7JmMi|2Ny$BT+DYT8ZE9%j$ zRyEM?&^h?e(R+P?RP|d0L9bt(vykT&qJ!qq)=x(;DPFai=1YObiK|7c_W-1TRPFpv zW*mBCh<~V)v0cH)+7FHwSD2-vdFfV~ZJ-#x#~Bx7!dStPW-HVOb=}5}R$`t#8m@7` z)T)9~{Tkjci2K^XtG_@We*Odpj^^gU-rmj${p58IKX}>0(w2cMgEP6l=Qm9Zbj=#k zF_xd*;6bN26?l{S*5~mvUF{p;O^2znR)uWqj{9aSjk^h&02%KOHF!wv2#*<}9V^en zn#b|_5(&TRUPRI9?!o?>Xxu%<)5SWKUGqM??#34xxvE>2GZ?l1H%^8(IBL|;*Ib`| zQ2AQ)mGU=}k%2X6K~xRkuW77bZ5(g2Y!!X_6nx`(uwO073(ntj|H_*JY*95P$WFuz zzN3R0d;UF&V8z4#P%NMa{QB55t6cn|`ntSj_xVUgCQyV>$fzyJPucC<{N^{j!sQu| zovcyj^e#;@K6Ls|)cX9fGenaWS{1nkdW~hLEKwLh4Feexuc^K5Jy=M`+ebgbUIxE; zUTLjuH&It}da_L`jTf0(QaEosZGXlVR?V9GOdUWUKJF^@Vu3VX*ucrbVRP%?r+xBm zLB|OR+mH;6`(9!HykWbqZhq1TO|&_<>u}temGC4_XC~02gQK5u>F#Vc@#6ewZ-Z{N zdU(;kRxzHUEgmi5-UTcO7paUTv6X6znM#i>07NrEPc`3>wP3YVvBoQq9X90j2O~u& zeEP(gH8!jjJQh>m?X+;Y;}IGq!e=*)4#*LigU`l+q;trHq;E@xPIk8~=PLm~xIJFa zHS6=AqOZ5(L~3nM;YFH2X5>csg{37A%a119OQ<&>n0pz7JzVKs6;J*Pzytre5cTn| z-c>E?4HL!~z9G`^760k;KTx8k?gYzP%gcu44a)hfpig<2MfX!)GxD~2%tNZ4b6D#n zwi96#;-_jOJLzS#3P=IT>FJb#3F2^jL4y#W^b0vJp zwb3s%!B#-G-<@n9?R)1;6u>cC`4m-3J=#S-gV}T`c5+<4Zax^1!L*B5t0In~?*s*i z<^&AaX>`#|&*CnZCLgv(Ilat+9n5BLJW4*Ins`JJ4@?dNI(8Yyo{A=d2KmX8UWGF# zWH+c@Gfoa23Ose4ni%fvxk5282#mx#rJa$yRmHrO+d8`upQ6zv#%IbJlIKzdhKLNZ zQG9`^DMn^Lwr)t4szPWM0;`AEbOwgW93t5bB^#loIBAv0J7mDl%4g{Nea$|FlxQLH zw)X~)G?_*;Il(fGY|_tMEH25p++YI=)IOOY+z}=XyN zcK${Ctc3VgdC_VHv%Sp98c#r6T2nj!X-0WiFwhB!>?W%yWksCc zMpYtrU|XU(U$(!BTQ)>6wUY*i<8G1+qAEw(`;79aI(x|wi*tY35UaLKBN2@c0#yQT z;W~T-zt)!~FSh(dPvvuY#H;`6RaGEKd$Jc*3Vl~zu*@Mr~`P;@J+zI0kE8}Y!V z%!2hLDJKVqGOw8&^MT>ghuFMQ?iJrL;3as*j>gKVsc1N!)4Ysh)Vb z>8+7+7b7KsV2764XgKw8(2e^76@=K$vum(nVb*4L>(62hK>oyKIHa!mgkVT z;cV5OV-kX+;kAkBkwkp{C%Ypa4~f{oF>5&Sp3dec?wwc_Lt8~pmZ?9+4aW7@_>YTA z1soSBx|)Q}941%fPej9ixU)~D$*>2Zl0ZPYRm+GmAR31ad4;{0&t!x^tV=&+6flww z;asNvee}3~$Ny=4?k6HSiWMtKIRzJVT|R_E$8v3=uh}OJ>>e?@BcSNhp~B2{lH*!Z z2WS1W{3#O5fYsdZ@PCT#_UDrxuRB5dzmL^w9xK*HM}aM&iy1PAZ@Ou064Ml7wR-ol za?ARE<_z8wwcmL`FI%kKawd;6;aB<8uFOY6{w2%#z7{hfwb5^L;J0}b;-E89{F~TL z$i(k$wy{fapdMO!t-3hH91{wL8u0HwmWkivSlxl%|EDtXrD;rjHqKSMXC{8%txn zDbhLZ4JjcC)81Eg8jT1Jb{)K!9Kk;w$r4~=R2ZTVC^b>|V8lh27hqNYDlQGOC&X6c<7=*G$aSllCIP*`xo?gS$)ok=_jBnoQQykQcj4e1wKAH}& zLQoP(A;?0fy{eu&VfIsY^-qu7$bo1$VY(WAQqi%?(?E;-~tX7eYvPe-x_ud#W zl_E{wh>ub`1vy?aXS7-~lbR;BQyawMqntZr zlfmoJ%)G2eGS%^;LsGt48%Y`!tYm~C39CO)=eu1mjJRd96egc1cAlb7lg^Ryvz=2q z0JG>{kB5ji1{v1-&fxMUldzzsgK?j&P||)PiK7!4-NeqlsLk0~0TUQgI8p36D;^nn z9x6j8W)G2pNF;lltiFo3!BV$S#W`;{L`Z!)=((tZdH5YeVjZc}-`{?BVg^GgsXLee zChO4lO2I$luEZxbo_UnKl^ijIlMz=!UwBsg6Or-~<#6t-?!|7#?RX%;pV2A+uWNaFdO@_;pD~NP40oX}8;9O}}m}rl$goxo#MDuZ?Dc(;-wdpw7MK$u4e2hW)#cdQRW_g)OO9`hE@Z2pcPJ2TjRTcpuO&FVKNB`B{lIRD;<243S$}>M zjR$RtRE=Vi%_V@0m~Q}B#?;Y<@#tcqC`&`9&evxbO8eAKKH}XLG~%*Rs9BZxsm!ia zE^NFwfo&3PvN1Fc$9f>zCeH34aCl;hnJ^@&&aMaxoR@=$Nbu)L!wGg?Z1r9|Fj)b( z1C(A3IhzxdY|B;O?XG5wBRQ_4Tm5{0#N^dZNmrL84ve}yv6a=mQ^QNxeB%cyw?JTh z)z5C~$S;{y(uUKDhd`ZlyK~(SG4gWR@*fgJjg&-JU9@)DVOJf>QRI=ml=cwLoNd9d zRgiAq=%J*j`lv2(u`Lf~Q=|(aqO6-ku?C)_ppsh%opKN@+;| z2!SooY%n@|FZ_GO#uN1a*x}=FXcKOcaGSz)Plh#xuyB6YTr?JfMcjurDZGzsNbNj^ zkD_y1mumA_fHGa;jk?G92$xB)&OWSFFgvJ;gkCfxQIGyzn^fqL6e2f*iRCh2&{&Fa zC-#KF-O)q5!>)_6N2~DcCR!&kljdkG7)=cS5uWwX9{Z^m#+BgtsEI|V4OHfZ z6FB&B`{?cV#+KA9h;v|!ZFG3DNg!19T5)tUawp%T)o!Mma^1#qM&N@VjHbyAK^fmd zKhvP`0@R@ytVpBkf?^NwH=b_D65it)c)BL`nDc4H{pZkhu^>Q%i|{~6z3_xXyQmm8 zx*TYfgoX)7j#OE$6{+-16tPr>=hJiMqEbDOK=ySaY)Z!y^ z63?;}M8c7=hc_c@!b)u9gGt00b0H3D;k65I9{V9DT(>uB693^9o@XdZiex9i+#FW> zPRrOQ)s1(}qwW89x_zv??W=WviYc0l3QB@sbCvumFfzdc$OrxaO1D_@g@B|)=CnGI zjVmS1LiwhYufo4I_Fk@5`QdTc;H}6|;j+M6uvvp9V^Y<`ikIvvHI157U7^5M7B_?1 zcY4HXe-0K0hrZ8J7#}FD7#B^jRXfSq&%{oSNr&@>P?f|-a;gy_ zv~pJJ$*lnSJvacHN@VnIODH`6r(BRkX68(G9jo}koWFvEUH_oUh+mSqSP)c#G+U|7 zPk_>)Im(HED5qSbUEoub$aN+?i>N+T8KZ8~+nO4n;vf}v3z|?6SckTMm2$^A=7fFw zNhz_2HYfurN9m!R0{vA6X*TlWA-&$--`qYtI6i5r4bZjp$=eGNDr_~BdyC_{2|*EG zCbA(_s>gUq9#mYH7UZB-|DMW!9ci@fI-XYPu%Hre#FCS%sM3F_j*(1ZDx%`H>9?sX zu1Eh>*dA4DO{x}7$qAm2O(gvhdwVa|Z8#y97CGFxni!MVF!cd@N&0(^+ryC2p}S-- zGR+=h>cc1pQ5O)1_2Fp9nJ_<&qIBp^3r6YX3CG^vfmLL;8U(FHA;#WJ>4{Qgfs1?= zaCHG^xk4?fdE~3^FXuC(zdZ9}HxcrRDymhlJB(~CAVzHCO)^@<`J~-R1TywfFrY7z z5uxR#vPgay*qPKlu|Tpf2SO=wWkik>lbG2J!-Cr~6xP@v9b@353=EJH<;XCjf|&5W zW@i(d`lNS6ik!gI!IAO&BY!zim^wW;I3;o+ta2hFCZv3F_y33w z-3B24&$)yAn=}8f<;>{)757Bv^goR=7a;eq!|l+ag}LAXrB1gEGB^J7x20cd{~CIm zirbLvg*@bz3y}M7!3}-d`=i^K2misiopt*5-g`D%=Km&1;NN@qAH8?eZiaiRQ<%a7 zA8+tJh`-_OG{>^>_rgtMvukoHTQ)^j0K*|hSYX2!d*1PnItzUM#a&#i?Jx?3HD;{Z zELLnrg|tCKm5zte>z&sJk+IpSktw5?JBexEi0+o7>Io$rO)%281Y7D*Zt-y^yX2eu zm~0&}eKnZ_(|Q$#j84EiPE&4eaaCX0GWH__CE1`7v8o&M01?JyizEF;V-vD4(lx|E z+FW#zsR|pJelXpk7O!JUPJP~9Jp15E;}(GeQqJCwrq7z8qM`IPhdW;(+}jaNktIX9 z>8(ocK66jsm&0*4 zF;Ub+&X8=+Xvh+xXUvs2ls!_B*aZ&7s!wLXv~o$R3$lUiu=2s0 zybTjh?2=t}DC`(3HX0n@0Q-#H!-AMj4wmBRI!R>i1UTc0cE&Lqc#vFg0XJ%#0{0qU z^-^QJ6lY2XGf@TD#LL)k5{-A#p}Vvhk$L?!$AIR%;)5=!vPLFzdN+yBX-JHX89Tdk zZ_zm(CnOr6QSykEKgR|;OAIXL3;i30BoP=!);`g$4SRYPURjMXxP1?=P|Rf=f5m8H z^>eb%68orhSThEbY={aiUdLUwW`$Y8rIK2*CR0X2#%7uoGB~Bc*mQHs1lXte3Oq<; z9CvNJ-IWlBoX+r%aevh5^3;%BZ-lIHAqwic6%qiTaY82vw+7QbD;5b(4m@=OX9_Lx z$>5kIH;WHeYm|($>9|Q8PWHFGggY9evViUUaQy6a0UsrMvrMOa$VSP4%}d*DcJCk) zWFb!>3Nk-4p`*meOJ$9~Wr@kOFl5}Qqm8azQeZS3YQQX^fu6C^J);Qa-InB2qN6F= zb|TZ0JGbW&0dQp*71GG^o~+nRE|}$gCKnk@N24y<2y`*PN-u5=Q{HM#F{8FO{HRI8RUP4l-KbXo-W&@lyzrkR|J|y7 zhSS-!Fq`#ybZkNl*Qfk(s(iNAWHTa3OdH?Wlwm05DYIY`!WdaymjzYP<+BNrYyuI= zj%|E2={zOmDEol;kyd1jGREheH`n!qY*-CC=M<;hh~7o{iKRN}*bHMK_QrB7x`BA^ z9Ow^$sTJfFqY`=c=aO0$jWX9pE_z$=Ws4{WwKYzIrJ<-M+8l<2*U!v^~E-_TtV1p}q@ zF0>Dkfe!w_3mb_pCmtgs_EZTS3YDNPlh|;9Pyx)aM<)nJBXlrf1MST7vLJlLsm>&} zW=}MBIuM66X?%fWSF^axQ3Qv45epI!>j|u5MFWK{ma4BWZya{i8#*2XxtSfO%Ly@P zP{>+`_ES24Sz~)lC6-7wZVv2r!&t_7V)B z*U5TtTmTY-EsQ8`bQQqjM2^&2*XBH#)A}`z%rl))TLB+*yV!VQ_d2P z23cE2M@gIT2Acq}R?gF8`$7PmkpX!FA`N{+nkQ>ULFv;}jjP@wn2l~i# zZ)gZL8KCP0Ncb6#t5qGzo>vi-J`D028vrKAz55ac#u3*@yqz+2%Pt!+!LWk0MTa#T z`wjx4&VtBuuwda$v?aXIu^~U3)Vcw?!Nnj5A5s?gPc~G{-ex zfcTnGX+U{{w6G)C4T&K6yWTTdGQcv!RQok9l3(~@J8`doQo5ZMNDZqdGPsIuPG*rK zVR!9Lo5;rOv9fbNX_ol)lPQz$hOpG6s$oV{jtcB%$OLj=08KjKN-qFcv zoRm_ueH4rm#mhG#h%bus;PqyR@i zxWC?~00F&T(uM)9`(8}EJ965BhQXyTp0461?gm>U8h^XK?=Arr$7k1~3O}p;rr;$r^L^{1K0m z0flv(d}j>2!-JOK@Q4(@Yg}uf%oGidCdK{h9ZnfX`Fb(ii94;5C@i_{IYn41-eY8l zBM}@J|I}z@lh%0TT=-0D!YIg}QhY;6AHsIqxX>|nFMCy0{$z8`qBjqMG`5*%3uv18 z$mQTh7lpIh<7!r`i(`yS&t0R?pct3e1gVFG#7oZ-E%VpTFv!+f(hcEdK&>d}lWIWX zdNSq~aWaB8Q_-Y0tH%q3J=w?QItHCsK)XZCMN&P6bDsKGQzHVyZNcjLgN5T-6j(Oq zz*s2R_-r;P^&(^}eUPe$#vsa=BMX}VivI)*H#OIPbkLD8s*Ogd!{9wvS<}SaB_aC*j?hoM1G;CdVFv2_<7gi*S_s9wv&c!D&YCU&IMba{^ zmv*6ZPIudTiH9 z7}~TvqzTI#+?qD2N7cfP=FDp~7;ejhQVPb&MYS@eoMHDMlku;$$ps(Tf~1n0rqZ&t zDJt%aDy?Y4uf|dpYD0`mOPYQ#Y8Z)XOll*n%Ymgas)&RM9heGLvvGiw@@C-a2r6_69?V~>g z?87MeUOIFG)@#zzT9AkqqL&)+m8oPsk^m5Rk!)aN79>9HY$d2RkQe|k6TPU~zN*RG zv6e`jq~NSHw6R!74T2h!7M<1Uc36ZJd%GNIPM3Vdv-Uapc8fm5>H}05oI#gj~`9?k9_?WYw?g@Ys*Cq>4*~^Hu zMLD(-!HS@jCDS}Ijo|puyje?)(KQb*@s^XLZJ?~TJFia=1NZcJ`ME5eIOEGj*(CZm zqf5gl*$#qw2)zR$7-VJ(-~cLQ*U-V$HDLZhtC#Sq&d~#WnPX)cmSwx!$YEcd!=F&7 zW-Mh96^b%|niYgi446WV^#&swJuYIG6P^@XjEW$cAj@&CuQ8w8`Zg4ZqaSDvb(lO(u$|H@j=1jE*Dshu8B^Q$ILB>l~bc!ZF zS4Jg?i<9qc$<%OpZA@S@9gVZVkX_Yb4%VP^ywXr-F)epb&Z1@3L``V52d?)#il zi^VR?ARt-=+WgIhh!wafNMaLD3F6W$n>YtgG#UvCA7wR1at)#sN6<^Y9@~JP!cw6^ ziA3s<*m0QzJF`G>tKvm#?=slAiIrj1ai2D`o&DqO%~QH`GD*y8a#exalu>*kgV`FU zSytz6a$i(_KpTS)w@%vJ*k>6g)JvR4kSS?1L48HWPBh*+cLhg-kQ*vWzeTr3>OR*d z0>Vkh+lOq_X)#RVMl9!{sGPa`N^_w{aR=GE--OX(>SFz&nFkESl$!$bgGecC0F~a+ zX^PwsvZiv5lHkm7jxh?;MppuDnKzE^#S$T@0ErM#@qE^Wp{Hw5mF}=7L?^fS$l3A4 zf+yKd8&?;}#3ZJu8~pv_y^Y=7S1`@io%+d&O31X2dyD=Yd^go)GotTBpMTofI(ZxT z$74JRzrL#|%{s80l2gZ?P~ue{u2;Y21-hUnUA+L5AD|*%&qTba2B7M>I1{ubGjgnS_<(s|dUUz3In2iF=8fHMsym z(1TIK35|GB-M{FvAqi~mAa)3EUm)ufm+6$;4loCpu>OMk2SHf{IkS`|&x80PX$Hi9 z0YU|uvvx)|>Mbc1F^g!1BcMJIReK+ViX@q8(@+vlq-4)4L{mDlX2UC86wIBym`A>i zg6|x2>^Vtq>oW8eF^T3yujw+bUG#EhX4S8;h^G=`EUJ4o8z^Is)bja~YIdkNmaKn| zdJW1CKSiBoc1ba|N=D;BG)0_G=g7?J9eC16evLN>M_9 zcPVotV#l!Vb&;y&PkKkE0izNB|47-yRz+M^QvIqyMKO)#HU| zLxxc<2RCZb_v_KI+-qS}5BK3a`~EThqG{HVGzLy$`y1EKwFW@;U-tk9lq|d~!6q>;9V4MD*}(OM-hJm@J*J=B4=)#QMj{^rs#0TE z5bxQ|$cL$WCHZbXtcV#DT}5XiQ`-p(GAWmYZbw z@SS`An0^+F&hi%y4v3(Al>TheRt|$tv6mfz(h<3d(g?6Sj`9P4e;@HCY(;OKWVZ;Q zNA!7^OI|RQlKK)LPG7>1L8L^Zbonb;RccIzln6;O4Osxj)&@t#)g||w@MebWU)|*m zs|J&6vPA3`m}xshERr4VnNg!nYrG^*;!>^lSO?qla}@dd9w-`wL99$SSjSAVZz(Lm z>;~(HN81~lCp!oGMrT6lN=RM6S}&$8vN#=6vIbUp!w~&58De4%Tmo^YJ05aSJxse` z?nzi^@3LlMfj*&tKTKrkSZ8OfT#dGv%Arq@guU|)R5%FR6n&p{Fk(dR#C$a~Z*~t} z!9nonrsQ{qVXW4Q_7q%AxIFdwpsKekJ4zy*6hr>>NsEuQKL@#tStg(i#L=qWwJ=DY z1OGcMcnv7XXRP3?!GbTy_$BOG(Ez6PX{DemZo{S{RFaUDPA?LbnL9R zo#q)h^f6Hnf$*4_49q;%qzKKrN zg@gFf6}MVha*^Svoz#v7?f9zY4^wUJcCaVNP0^NP24?D17&I<;7;~C9I+}eS-dn*b z(%p5a@U2+CNh4{Y5QG8{MU^;`cn1||@YkgKGCZU3ZPd>G*7iHeu%Ma`4l%68P-)aC zjs+A%cNdVr&dBxs4DBHdaRl}>`m`w}n(+u2Pt;+XR7s#=!_<-SRIw z`mc~L1L{b;WvOUyi#op;^fNSx<0t^^8b#JBc#t?oF^xRt&~<9ZI0=aKS8X=m?4NEn zn-s>?yzD%A@mw*@v^N0Jp8cqK438J0o!a}#@9*6m!n3#qGXbuiHbL+#osQLq*bLNJ4)gQ_QrI#_YNk%X8~E*Yt-ef3 zM);e-e12b1Cm$SDZ_oapKZrl0K3Tu1y<00NwvWZCKSy;AfkRAS`8f{7i=yH`P;n^# z-FJXX%~aF%o=Uy_=<&LpN`BClf8feb{mLs+9*ZtNg%bNTYqkm&e5NP*mXoXJ)^J=i zxoloA^37k2#RR-byI01o$HqfJ{(%OsnmEon7$bV9iKAoEIdpK&)f~bZ-rVqG#Blfp z?=X}AaYpPd_RO~$sAIMY3Os$;IVbnVRw1V3wUt9O&d5(Uj2Mm~4>E*Tih2?5OMt34 zRfOG8N^Xj2KDj?NmBYnl&kVz(m?#F=88T00?&ytv4_GNKztV2_1{D(!1Dg31MWJFJ zi+}B_@F##PQ`Bq0z2TYIFHQ;VOq1w4M#1*L+Ik)uH87p_#}z1F?F4ZHt5su; zQNv`w*qM$@$6h@Au((O#%gM-(#=Hc456U);k%!ymBDFiBeIVYFIZVQg1o`?wb-d^+ zs%{E2(enZ@!3*DoPAykG@>}<@7h4pCeB`!htUd+%eEpz$8TL{jL_SwN#2%)I=b?lK zWQ~8Rhyc}BpuOrlwY7P>!C#1-s%`qbaGU;%-KOm>O|08)(Fo^rrC_^7l^;c>Ki%0q zfd%#Y_3>mZ3Gn%O1`XAhE57Pd0V&$cr}h?i)OWa=*K(h5yZV_npXKNEr?l5R&zHiz z_6O@!gyqc!X}3oP@}m9(VZatVvDnl43Ke@gx!4MBDNt->auU$ZoWrtN6<&hI8PiI$>G*q*$msZXCw zpC;@T(GkWQ>m|`98KoYx?QJx}Rm^MhnQ4vj8k$Wt$#bgHHz7DWMios5;6+pvEMn^0 zzSxeV(Q(2d#UeS~TK8f}5^eLXH6=cQ7~FDkXS~HnU-qe>z06>!B?r2T3IkzNcuYD)k!KkS_4Hi=8&Y zhTomDF~wS;p|>t-s4X|qFNfl)IWqoIJTlho8k09zpK$cBv|c!pC7bV?5T^m^3rxDG znA~gHB70uPH|8=@LiePc%L|1kc9=;=%YJ1G6^(! z!o*!A!y7ap1N0S@tT4{IL}zzaQ)jcjUyNe_I!f#fDiI&kfCPc)TJt+5JdQ9rid!QW zs4|j~OX6Oajg=+2o`{R_U@%P45W4MBO5Q|2bpUwWi;mK>WH`#`LJ?CI(QU}wkr}2f zy2KG^ZnW6aU$aadW5eCftc>^-n6A2}c-<#%;PlH_>P#<(sC%$pg^j@aRw zyDT=m8*!HJYE9eAS8HxG@g`Y90+As(nnKoKyZnf;*BjH zZdDV}9A^a0Cl-)_)FjI|-fw3(iV`IWK*j^ZE71m*qxfK-E)#X#_LcEbz`cNZJ-jvi zHm2n;GAl^A;NMd)aqBGzAbUwqg}iASSaRk~^Jcb*&JE^jyc7?;}Ep zgz1{No#!+Ed}v}dOj6XZ@n-Ad8GL8Wl=?Nl)d5X9u7{ROdFAh`0NGDzW}iwR4JJVH zbE?@VB~#i7nmn@0wOrTFY}fsdK|(hF;~@XhidY^hL_Jl*=RwN1U;S~Y;@SElY1a&g z>CwP&SSWH3LRT1edhvTmU+i6r*dkKt^>yF#MH}}Nqcj<`*UNGMBrn0Xf6;0!kP}U_ zc{c8JN1cAtMY*#3V+T-djW{YaZMkyPa4W9#z+@h9kvy?@ADwKz-QN76n$)6P%T*8> zmTTpzL|qsDDv+Be6P#Cn0#T6oir!4@$BfD6y=_~f9SyC&Aa7HdyNES8jQvA1Uqn$( zw7rGFLgsR!sdb7wkX~#a=LoW)F_|;0d_K0ayk(yVq(ZKYk)spjsxGwgJo?~=@h>elq6dH!{BG(+M%-5bq8gS6C$=(&XU)>0Ag zn<5b@X$Xa&oC+#Ok78VWoBV=S*#~^+?*T(oN+S%z!RWXwb~sV=s#e~nXiRm|&j5!B zjo$MT`69AfAgyTea2KI^57hrEWi=AwU%vqM>e_1uzRjJCF4Z=CL)uy4l6+oSE{ zw+FjhYhESaWl2>+172N;(luHmU+ZS!0rTCQ0GM`;_@v!L)(TCJEmU@Y`x3yP3LQb# z3N4kr<|fH*h|2HQT6Jst$L7(-{?@@>#RTLYNqlhc)()2n9M{hOW~_mkwf$lWQfl8D z<9xi>POcWme8^nj%f)ljb&)f1-#F&td07TW%*W4h*3v=Jug+;0a|_Wy^Jwc}fA{Aa zoh;A{R^@rYBOKJl1LZlZU;st<&5jY?^Y6AA4*es;q@zbQtXx~OpIhA&_{@3RzWOZx zQq(D5Y3WAM^@kg)HEq2NmJ!_^c z-|3B6oyE&`t>Q?+m^~NtiA7#>2KZ@b|H%p+0KRg^f`j7~I2CvtLUBr?Hv}O8-x`-r zS62H3;jV31-W#CD)7_1uos*y0P4Ul_2}zTRYOUt+ArqsnJJm!AeqdhHwEcb8YJS#h>c6|)lJKKjnF)~S{D&pQ`mz7}4ssHmgp{VQoHET1R!AfDpd z6o10z+q)SgHia1FeKa+#^606AaWbXIyM$xShDBf4LK~*g0-mc?dL{PWz~SVZe1bt+ zNWwvXh^ehGAel~fK=Sq{Bz<|q!XA1**oDAR3g`|#`YsA=z#^}t06_y7DEc(`il$`; zn;hL>Z+jo1IUepenJ*jRm2B>H-LnmVKeUJgP!3(Yk`a`9or4mUfGQ%#V$VY#!>ylQD2(foeB zfag%sb^Q7@6(V~j+CTFfsLysR3ZYLQZ*U~>65)k>M0pcwB@ zI@c(-fT?$x?p(uKOfRK~zFIIbb{dDj~^h{=08d0OhFw)&e7k#_tD|f=LTeue74rv6kug;gq5v(zZ+*RuJX#Y;f5!s02CkKLqCeDa^DHW_G* z)7Q~|g+ZAg)3p(g!XeCw>aUA$8w`Yv649&uOX=V%XVv~szh&(5^i6C%AY4MSIp~fv z7kV2;wpNPh^tz9wK_VyzXK5m_cpCaL5}ED`LIhI8;ua!r3Ac)fJ4f3js$zNopqqhH zDO2E5riz6y$unLo9sFSKO-bx4A|<2-ch3b6)HdTvv?@P&#u#xjHBT^4s;CFmB`*vmT+;*SVNtY5}UUrA#9zhyC$1`0HkjR3X2=?n6}N zu{J$Is*_=(NC-JN_3zKyuzh@R6zG3F`+z0%S0{^c9C0-9lvKT9a)8kq$-Tp|2&eS$ zHZRRYbg+sdQa0{dhMdLjhK`0VBaJOpx&z(D>&q#Rlb)P0m;%)DK;=l%TM=+cPloCC z>!r*eZov-y>{O?Oh8z(Wl*r^I482&mS=MI)K>JaX)rqgixjD%EgCaGUxh`Xg&?KHq zaYqi^o$@3gd0LSnQ??&YUn}`9iY3N!e>|Ey_d;$xNWyn-$MDKe7CB<8WO!ZwUh+h` z=wzZ~aT3a?=2h;rsd#~l&4~32P(ZUY)7X0M1GOZx=|UkE7Af-@0EoUE)BYHGL68K) zfW9k(gY_Px7Xa&v+iCPWQjYNnv=&PsfOa?%Zrn@ioWh#3l?#OwGktwKHm>>PI+iIw zw0Wrf?`|H(v>rxQjLvN%A!u(SDQMU6$#L$RT*cIh|u zcg24LfJz9%`Jh2rkH2qfsfOGR%z!KQ2mr5@9~9SE_(59IL9v$eNCPStvAKpFPY=!|u7BMx|u2hg7L zYJs!a@+o>9b>tXkWX_R_K_z{q`c^3YiXSV5Gdr4PIE>Hkgz=c{Le6r&M1IBL&@RJv zJbcmT44L0r=o_MkM!74MjLiU_&ZduzkS0eEW4Zlojj$j=)se1|y~4fO3AnBkzp1M` zisdgkFS~K4mx-|souVwWEIc?ZDCv3ekpRI&^!IQivdVC{I$Ig{39kV7GyMu>!Y z*BS2fy5GS(5}iy^!rP$f+8W8?^c#$nKA(EL_BRn=zshL}^4utpU4K*CmXYmVL!YCM zF6T#dnsLNgzH*cJwKl7Lr3MzT?qn<5eJ z%NI#zdjzVv)#_ckq*n;SU2zl~U? z=bfu++eP=Wa`#_yhx^6t!nPXvbT1ceyQAF3T5#GZm~q*(Ny%$#)V%4>6M!ZGyXn^4 zKI?DHMYmcfMvPb7kh0UVrS)jd)EK3sxT_-~PY(^^t<7;SQky^!;J9Z=$kXoou_Pk` z@>r|P(O+3BySbQ*NEXb5+64eG$03X};aw7MvS7==v@O3G-1ADA-)bRA`q51@WQxAw z5bj=h20P(zIa!)m6NeUE zD_Tl0Ext~cT=NQ)S?q?_n4+r+L-&|m1R}O+Z3M1J(P;B>rIa`{IwUo9h-#yb7YS!A zdi=N(2%b(*G-6+_zEK(!Rkw0C*EUKtBm`QdvJ4%bKp>txQmh#u0RG|I!SnwzTl~q2e#-0_nE>J}~!Q zFJ#xAQi;laN6XkIbI=9!dnxB7exRev7es`rvzIL;g^6Z}&q^k4`v*-VYc!!M2-J`E zOze%?kGoCtCfuHa@_pQqm)?03^x7sMbY^(GY^2Ix*-B7cCt_4!qS0y`X zB!ir*6aiQ4>w)yQoe8^)E|%MAWbxvkey@RwqZog$^PXcrq{H@E_d|vsJS5=LC49JS zQyp*R)&mgZtY<)kD_WN_E#;u~f_BeU$>0;FctW>sk5tXhO8=Z=s%a2y5sl# zxdj#53^hizD$S|c?{lC$FueZDK}~?up{$HE!og9i8Cobvqu90sGiN+$cP-*a1?0 zQBVkv^XEETh>mLWkC8!0d1ngHRDUcF}JsyrRax7X&0zP;jjPUvGp0LNC>Zp7Ivo4!XG!MG_bF4J*T;uv!m{hayScLJnBaYCnITJNos2tWd=y=V(5x(_#@=-e2dO7#?44$@h z$FDY|ksL9Dorv;OJLKQFL9|z^ZvzHKk7Yq;>Em1fF4j@xJ8S^pZ^uT}DI-Dg?@?}YZ>71O@c{-5BDh^Z|!_XCC5 zopkA8adWAZ-mB{d#|KVG?|-bmtHvKin|PF{p4bbJA7;AwFpYCuTfX#o?s;MyTj}Y|8WBMnS z>AQg}9-0&K+$`tBGT??E7mmQYfLq(QRQ9BFl$ZY7$MLh?9x9R9mf<`!$X4-evP@}} zK60{CvUn1!vjy3Z(b1E3Z89iymTBkhMd&@2;2hL)>6KzQJS++y$&gB-Ey>=22Uzs} zTajk3V@VE<4u))a#c|L00u>JnXjvYk3*x!p)nVU6ZuQJ=OA;$j6^*K7m7Y+pTip4$ zK%ZRIC354C!3;53PHllA1;rmQfZ0%@jS*krC~8=S&Qus-F6p;plXhK&V3muDE;-d> zfE5fIiHD${C>kDhmH_oogW~`(9E=yqWn1KN%hvTba?y_+<1rb@i7JURYDlvEngsVQ zEFdM)f&Hw7hpt|VUS<>%^PJkxi14m4+bw%;W+^8SXDFP&o=$Z(yd#EDqTpyYs$bij z@GzWPe;!6GO$RVTtxGdQ5~{Huq3RrcLt~yEYn6mu>0_W_9G$atG)j9&Bu^Y|(ubI% z?FgMl)lMU6ENBBgqQ)8>EBoxI9DSU(UztFGcf%8o4SrH&8C79_=#N3<=^**^lbVEM z^X1cU12?<3Wl!%8nUiv>YyQV07XY5P2XOv(wfs)^nn73=cVw8ek%VRvGM!j?WLd;f zz{-SA_zY+&^Z7h^rv^dvP+?lF9#PPSqeI$4-)ZYN=ZpGYIinVrUvlMDAN3Y}X!~g{ z^&eF?8Oo7vwV+XMIbVF~mx4BVMg+snL&uXpYtf>3hK>&H(VRAFg5h?Ga4VQ$BlsLn z3enf0FLOKbGAAq=DY2&JjPesadK(B!Rg&+H)}uflHlF|czmHJz1@&AUU7e7PUK zx$HaLtp8DwIki(%ZdsR8NX<<8guFkr6K6XRHQXBCTmrdG3xh{Wa(H(b2shQuB`vU{ zMQMP;WIQ&PaxxFKs77zo7gt~`mJ~)u-p9}SL66@pq?gZO510KT$!&YMJgJ8?@7{0| zp3DE59(q#kE!Otu;B?=`%S+tvaTAKJGC8B8CM9*pRxjZXA3J@O+WXL`56;+=RHcs5 z>(khwf2^wl8!S2Ho)8pFCmHUhGvGBrH8?w7#hdrZAtU7vuDSGbp>%a*Vv>a=pzZ>? zGI6eJbSpR4>KO2-xp#cHvAKP$Cc?W)Lra4*48Dn}WxaR#8s}oxjNVeFhP-13DjO$7 zw`>Ai&V&djy67Q;z3A2c9JRah^$f%J-x^B-M`j-a5diXc#Fyu6Vn=izCJvxNbjrXf z40I?i)sTG|4&$VonrN#tOj@HlIc=e;O>E4k-qdhCjF0U5g5wQ~gy^*A751D(trF%% z8O7#$gd%B6^>@shISg?Ozkwy{|`^Q=94 zJ<(t063$oqXPCHs$ArM4e~#f*&cV?b*$Axfxea6O&ZcT2P)uJI5~itT90SjBMO z_8uCzn1G90J4f4_9Li5%)^z+Y^7!1`d%dxhp=47SgYVENKu7hq#t8Z~4Y+n?@a@$eoB6<0?m5df4buBkVo))w zr}qR`e$T2~*It`ww0)FJSgekeXu%E>wka&|o&e4=C|kj3q!GGPVEMd91yrojii}Zv zl3fl_>qa;+OV7wL=2~Pu0xFAC2i*YxKP1V3Zh7Py;vD$ah2f1xl{QLKdQBh@4}<9U z>yfY)#}KV~i7i#9etx%J7-WjGvDGwg*yT0fgCgV!SY%=}63?hZ^=c<#U@A-cU*{|WFt%2jCo0!mY?`Rv@sJy}vupDk-hBoaWEVyoAq;bcNTZ1BY ztYb`Ehl~=czuDkKF26PTUi zgu@F=Uvn9?I>Q$7bG`xKjJeikjz+|H0Ga09VRkCxx7g|DJQt1QDZCJsI{hMbJN)wE z;2jaF`B5>)XC`>G5N+m38pALX+-* zguIRtXEke5IAN}!ba;UWG0KgMQicSBrJ?Jo{KjH)ELn?>Y6=`J!Z|X$OQN|ZI`P9W86=ce2~UgdgwtkN z;}4Vlh=Mj}Ie(=`rhe`y$g%>g6Rc()Vad_sB&i^fK>f2&U|uZX1K)ILh0U~b<)wWc zNY2czlU}&43!>)(|E(;TRsT$b{Y|q=5;W=K^a%ZY(js6gT1$Z3_XfG&3Ih6>QeM25 z-%6dI#AOUb^R(L`-WQO9HhIJ3fEYX($zKcIGTvb@tsqj4wliPnA(F_+W^srs-fxz% zj|%q|BO!QBRliy90DCbLV20jY9%5~Wn5_96UbI#Pt&-_ezJ|XoFiam67g@}hrMo%G z`TGfh*f`Y8~V$wye@`W*GX~6T|eLx{6d`g5^Mme`A3?K-1IJ z;GK%?k}Ethiza-djrub2Hc%Qg+`#)FW2F62=VFXT=Av>8 z_A8Ktn^HT++(yjWG?6bv7@ECl!w1^!9dq&xdz7YA;%T!T2IXob{T(*~05IL-01X;w zOi9QTIY?M&lh=x{0A4$5K`c}}O_qd16$mtR4kqpadED*U{S#Dx7%3q+~)D+GJVFz(k8b2|^qk~;h{x&%>t|=%{ z^@*Y~dlIxFFLnY}1TF;@yqTlh&ln}=@o*Tn>kDkui@eY_G9=Ddg1Ouh)?CF&Dck*)xJ5NYC_9>plXzovkYQXSL2oAqc8 z>I3nDl9ROxzRfmzvbmY4l|o=3U98l?L7Y&Y+2|234UxLZWxI+OfWQ#yaC$n2gDqX|5d_k|sn@VHl3|U* z(l0ln4Z6ptTT3%xq<_F`ynZ@lYepy3zyqve+-MmaoAjdE?oeXfHroe|3bQz&2_bxX zyYb_8Q_+WkVe;GX-qEpfLnG3VxUk7i#3J0!fh#7$X;!=*A=$ajD2F2B0flO|8~dqI zz>MjdeW4Vd`EszoqW<;u}hj5)2H+>Y}!I#GgzgKx}TD zjlY-#Jvu}B;B+#$0*j~pOm2}S^~MQJcoc6xI_3_ ztofQsFJ*AHiI{9$u*?JnCEoU$&S;d0%tTKG0zest98qm#2k8)VSMUBsTB z*nQnpX?g-T^(v8=5v}|QiP^A#OiUSl?Wb;bN+Xln_cA?krjj)||MSmfpRfWGX_<9WG6_)d7=Pqq#F_aSx=ARU8_)Tl!oG1$we}2!rUUWZ0Ko)R z*R&ntO^??{!2YXzWtZJ>QHF>tsA!0;6B@^hWb}n(Y>G|e07Y?Ck}u^aKuEEteKJTV z#Yl$%SePZU>Y|V%COPN=zu#6P9H^r$7fSpE=oXxQWBCru%NlSMnxkQYf?N=sj0lqs zm_CyAxB$y2zjYOblKEW19wyPzskrV;qMTdOzIR59BH7xT-o{Ml^sN+!3P(waO6Z$o zjQq~WBefi4P1*E@;hw63ayfAgB!i*_C@aXEZWR3j_lwr2QNFk54@)T?V5y_S(6d&< z%^sFJenC66%owWq2{px9ZIEMNXk;BODJl=S#iH5A=!u?fUpw61aF zJ$8mKpul(d){7YFt8ZETs@FHmriNg1p@52Imtm3Ql1-CbED??JQfj5t;AAw-z+|d< zNkz+|xtL2xu5^b{Cu!V%kIhZCZAGaRL!+6I7UxRTjBY2GqH3gfwKd&6&N}O5p|zyp zT?o5Lg}z>N)3dls-E{N)MVj8isGn$OZtS`T7-~A{oh9uy2-Q01mEK^KVPfBpxui0x z=s=+w+g^Xcr8O2BdThwU-rV;3@KB7tC$WV>w8&Y#1l3H&Y~2deM!D_CAxuG65+`q9 zgA-e#FG}C$)+^oL4E#7#v_>r?we*mnQ7Rnv?R`}?pqN?@jIPnp8Fh^A5A;+A@wciM zIm#q>QJ7q9eO+xI9*7{u*T5<`WvQXIsP7%S%plmsUNZdzX2Cy%j65Ogb1|JdmQ!j3 z7foK#QQ;gH&9a@`uLOieQjby5Bu|*;DHHugQ~iaL?QaO4fk)&>+Y7O1MkF_;6Q|y4 zTmxGZ+bLsK;?%bJ5XD-{pzn13ktyQ3xzio&jo;}^jZDqfwuVmDsK-o)a+FQl>fjwl z>Kx{cBkJp7FH(?h%HH<+--hYZpXr1y$X<@PBo;uw$5zyd95(VF)2ENDXkzb$h=>M=P# z*I~fPN_bpZ(uBas%hL;nH-H8CK==S3QF?g9OWQlq)&-*Ss6&oyyz`qBk+3Q}wV^if z;eIHK+kr8_GW&gzbXAxqfUbm<59lD5C@8OLp69F*y_ddrdrIv0 z0@qaJu!BOjjQH>=h&=GB&YY$eWX)nuAjJNdvpEEas`#_{@0{BX7ioHyrQKviE{4uX zz}t;+S%f>2(6GNrhvR_F;FS(3U!im6PNXj`IZ6eU_bjGi3S9+?mA$; zNzP*#SXLdh6s&-^z{n3{T%sDmI(Ho-sdmtq)QhFH$iV9*X0Te@`iP3Il^r!^xT&i6 z7ci69>Lj+D53#EiZb471FbDjOhbLF$t4m*0-5Vu7h0& zMx5I96{lz?L^tbE4{cmwxt&wQfw;x~y9F!NgmX}SPG%Qeu&pf^3>J`S!S*S-j9iAh z$Y*%!_-6qS+QR=rb$6s!WI_KXD~6R_tbf&-n^~SRn7f=B4dq<2i$wh;ts#4<77UwR z6*(Be1%RgS8Psj~=l5_{_iUIex;Q$w#ur&c0ijUIO;Nc}L($RKT*2X`IYFDZR4ceh zFm;O0^11mFE6Aifsi8X4K<+}on$+J4OHo8~lb(`LAblqtujPnUQJeI$E|q4XyQ!K? zy}MOBRJqkK(zsjP>uPf=lL7K2rl=6=wu-`V`jN&v9;$P}O~f*M{!Adm=kZXhmeXQR z>0!XIbyU0c%@yK;xps--@hHU|9+_G!ZZ`wI?Plv6bIZa(K@>i2#+AKO=u71mv%P>3 zkt3M9KS#^a>MV|U=!(Zq%qC!Vefj~+1V+Fpd1Mi0auCx2oPw;;Q-|%btVfGY9+|Uo z8;P=#z?Iv%Inmro%)wc{4##(<1u-pPE@_m=O17UdVQ~M7NDnGb%Y7YCtALDRr6ITu<2#VQGz#B0DXh z$qePJ5peH52NE<{o=ww%sjLTZ6v$yvuNS0awvIO{YaK=p7>3;W%Fo3{BWxxU>(smj z;TgheJ~s5y%DGf=_mFLlR;SBv$3K;4EsyWeQxuPK$0#b3jn<5JCRy*W3~WZ;IAyYD z!uN^}O1oW@2hYFd;k;ge_mwq$(ijZURUWo&I%f6Lew~wus&y*fiDbq}geR1UKb!a) ziEagcaHeY*I+vN%X&h`te{1pmDTAh9Y|iK;z&c@U!hmsVEm^Vfas}G2npz7grDxHC z4Ru*w8bf;_g+_SDnZ%5mW(m(q{!*D~6_l?5P3;C{wJLb3M>67QyV@jbmYnBe1RG(D z%k~u;Ii4jW47GWV!(eoA7z>Sm9DA#2nW2~iRb(xfv7lj2J!-jz z<4V=S)$a=&e>@Yid&;CmU%BlvpLLPXvc#t?@L87kZ5Ma2w7+a&f6=m5c@&D4^ykWy zo&&vFS2MY#HLA7g@`-}(3XnvO5Ayq6Yk`9Ib z7OkGW9+eyu>7Ws9Q!qsu_^rRpGf0EN$et&+WSvEhFVc;aZTOTWS?**L4@k${0*^fhgNIIue#Pp7770 zI>^;ph=z$|6>_9}fB^rN$gxx#BVfHWCQ*UZU>Vu;61IgRQNqxea`!dGOD|8<;4-!A z)N(HRmUqiw_HL_b+-4UVL$L+p@08I+FxLu-yAUI$u0Lnqax1&x&rwn^oCV(*nzaQ` zn0(6H1E?SkTrm9Lx{&K?0nwE@F`OQ6yx9(RfQ888Z3QXlLLOR{J<{25AWHrz&}qIy z#bYi8D=TQjJ+3fmc2UeKN44r}!B{Xq#V}hWP89`>&2b$`Qc$y3aNz3qM2{GEvbxl4`h4i`i|oH)HfJ5i2JLlc-tguM97wPwsI zF2+4M#prO04p_+YO>?TfuT|r|ic08AMJ$U3={0N%>3Osg8hA(f;h`vtJoj?Uh@p43 zu^LoTN+peSY-FVgk{9}yI8aVuVAh9NsN;FBL+L*HNrKi|=od+f^UNk~jIQG$WgoK~ ze}XvoIUoIHCLtp4kKlS7hN6JJ@x#H7+egmrU%Uqr73{WvuzW9tJj39{0aV00yfyxi z120B4@IM4rYR-f=>G^lizEJD)Y?EQb>3k9_^q+bXm1eBh$;6XTZ^Pn>EjdF_c?K)b zl*--BG4@X@~;=V?=5u|Jl1>z^!%o*tSq2 z5C$PXBOin&K%#9SNlL&lzX zHI=0$y2i}Tt}W~mh3u6=3kEYnM#oF08(N@LXw*OgKrHWANCvB*VmutiH@1C=p2inO zrs^Q2Wxz$bK2NC}qt^m!HRJve#TOStGz>|!YlxDh*L*smFr6khqr0055cc_+L^#G* zSc4BqeA1#@(UCpU$m-xY=FpKf-L7bE=XmhvIQEb90#Q|6clh(r(c@aACXWcWthxk- z!t-F9H4}=}(>B#Xx-~XVJ!`7zx*h~7#Fgjbo6`N5wA4-d7o$re7&-B|aAWM4p&1>i zRV*LyEI~9|%V@0oDG1G&q#97QPTf4Bc2kwZtfee-kP42B01cN5nL+@~E${(98+GW? z(lv~CFc{IVPm{^z)rij0fhx~_(NWRtKei7`1?YPxTGiB}$b^QZ1|$#0=U`HJB}yfw zr64^xa-y%JrH{*23Er*S)UBq6noor2JR)9X;*M%QfFhN~)#Enad{D#fHU>AO@JE-4 z*vAyNzf|0qy!L}Wf2EO7VV}e5kArS8hwc30M$`yyel^X(RH!oNuZEp*oXDJtIVzD^ zZS5d0R3UX`j*MI!a}DOT^Mn&GM82MyV1QQXpU@=Rr#;-g4o z66M8aUm$nk7XyLbHfUGQO3g+r0WwZ0oH|G8>Y6;Y{_aO3g~GPTsC0k_P7n&s&aXif zQjXNTb-u#^zC?~`FE|?vO6%oqpK*p3Pe1?zP7D@?gEVX?Z*-vdo2EM{s<&ka3U9^K za@8DH2|Di!6+V|V95qt%y@FY*O$;d=2>GhwLJqTks9sEc^X22CtXb5Ku~hb+HZA&fhe@x_^8IBjA3DiSsghb%aoV%R|wmleKy z0TU<%NBbWj_VjH&OdJdH8evQQgu=w4uPRB#daP~FpX3IS89WK8#%|b!08|EzFn(Gk zk;PXi+d2Ik6l!1DcAie@y3K}UYdoVGw&?{5GFA|Rn4IWIc;uQ&FU#q6JpT?&J#@cQ z($O<^8I<&#NCxNR{Ta4qb}8wZwOXdr6yCt7Np)vtIyxc^#VV#LQ%4a9ovKxW$KG|;xGE}+#uotjA|0jk83%e4M_(F$jDap` zfznoMJj9Eo6#a0!U5WvhHN2>=$^h=dS-{z#&3-~WWn0RN`a5w{!fV>l5-;y_;~D)6 za~av26uPxFa7pKF0RB0=lw0-kA_Vps?T;q)lJ)CxkqS(s7y`|tDZ(lG{(DAJUy-`P zDBwRi_3lM|HhA6{$zjT{%;GRiXA6-w2?JE&#Q9&kq2;wm2lLGMmJuzYarHn2Ry}BM zks#C5MbEe~>1&NM%sG_{YT)V6*S%rm9iJRM)KS^x=it>7{zyn@U7&Xl?8C@jDGj^+Yrs>FY%1lBCRIJ5fWl+veHqJTbcL7{#} zW}#58f-&VR0Gzu&qd?Ll=D8Ah;w%XSDIk@n$dP>Al_Mj4mWiXT?+m}#hs85^zbJNM@tvS2v5H$Ui&A!>7=~gQ7tTY(I#scbDsWi2 z;D&0s%f0)q3yUN>`jI|`??~=(#f9>IDMeP`PH_YRYoP!!v=C=ngcmxx zP_V6h(c=6fw&BMKq^mC0aRl8o3FEFZZ*WVxvlPDf-%a9|03(N7ISZMY#0m*a$G^0J z?JjbW?T-04>1nC*)HXx#x{FEC>n{G);p_6mFm0S&7znI;F-vT_+s*}};F9fJ^jtDX zS7kM{ZNKQ%JVzp(o5r)OplA^7E}3iCla#OQ*;J_@v78N7$8qaX7r|M3hnyUgpUx;# zjj=dTnVdKQ3mjZ;SUv-AG@@vyPg(Llk}UvU0aHMNLDIrV`IzE_)8SI& zj`r0;&d7|9q?m((vc(4H$zB_38>$oH=r)QXJ91{1BvX7D#Fh=E2O8rW8gY|PM5&{#Msv%xT}K-HGZhc?Yi zKam6bH5`SD1EWhpb46=wJT6WpUmW?)#tE!j0A?6+fhTBng~4tH`Ah|+;+QX<7RcXf zT>vt6mPnner%5oaO&N;dGe_9F$`42x-9cgN$*JJZ$HaEO4Mhn9%crNQVVE zRL^-QDCv+tUfzaDj%2bM0Y#Zj=$K|rKjslQ*YZNa^pz%?8`xxX#( za??=M)gb@!xtD;sbP{N2a&s{KurSbBneWoIl5XU4HWx0sw{9Y$KGyi>6Z-csD4X%bAVxs?6fFTqKTZq0OAK+F%DR zRpOIw{p;wzjM@9r$8-4OIp|~VoMMK$wa__ffZFMGKf}asJ*y1DyQZsT zc-~E~dB6B<4Z-ZixABJ4hXmZJcwn1o2hk*3sj7cQ5R}AN%GpT$=3VLIIIGz*aV2Jn zCc$6xR%I4*qqYLdL1F=+pL`Pkx_xxeeD(9m_Hpy|(f0PS=OU?1r{pB)Iq3SaC>-&X z0q0>A{zxQTbZnwi6O2UB!6q!`AFgr{E(#A@Q_fm>FXYf&y!1R3y64)!AkHb;X%9c^ zskT1Fvv?Bcynsz*Q~{`(rY+MBHl)1(X6FVA(|z5FToa6&&_5%!Iwhjq@Cpbl&Z6bI zHGFc0$fk!%v!Ss2I{W8B^kl&pB~9pH+MCuzHU|1-VHRh;qApIxlwCb=spoJ7RIkd6 zX>5?~izNH!T0yGgNWQ74)076&a96kZ4QX)sJWW8E!G8xH!eJg80AAc{;{HV+7;!ww z8otKjXc(2eL#f@-Q$=r8#a05goE2_K-4~nKu6f;=7dag(bKGT1w8)DgY;~jsR;E}b2|l^ zbY-F;RC$|#D9re4!)f^@0CSxkv-veg)ABWq)0A;V=FsAuVYNU-4j9%~)r)H}C=Lau z=xs2n;uFz&vp?>gp?@I0fi*Nvya8=p#(h`{ye_JK4KB@-W{1}^xig__>l3Z@poc@) z4^58e8SMJ3MW1-O$!1Cm8==W|T2&d^7rc|O#~FG?@>lm`;>Dq8&m{HY?O3Pt3ZAoq z933N@q(kld;*zI5B6}u-g^{s{?e?sMzq7w{va_+vfu%9mNpCz#J_=yv8ca1*RGZL8 zc*c}&emXZ#3AbL9e9k5^nv}T>zfsO5^-+?TH~E8hXYf;MR`N;TrlwQ-!bEBXiQpy& z$2RgWEeIy(s6|PaoBU)Ld@F{h&gh2M91zxrM7WqD4jpFsO9(XBs zMLE7un00id!Iq?L6x}g7*aU3H%RT1Z&=qGs3{>;F22uz4Dl?T7`Vd!{ylUl?$La;d zO137CBmOU<$M2(JBDAOK`=Z>!c@;w8!80vs$Cl#h-F^qht9>=KB@%b3Mz!io;?Q)ug}BI24jI@7~~X8*skil%k+;oj9M8mZ#nR?&Z?RW#A(zuqcZQRx32tLV~|bRSmH0{p+(DjKo) zBdnr}nZ+%wqLEw7WEG9A-Nq{V3$Xj&Xcaxf_?hfUx3P-8=@oHD|y0rDn{*(Jip`y|Y2H zcXlf~>UmA-RdD+gUVib+c*0X_YU--WTR=}VcFv|)JDXW`X_RujWup1>zkqL)T3BP} zCR$ia=L*cMC$rG$_QyG!?E5vj{uhp_(#*_e)m=2GY43i9H3}`k3y1Z;eRPT~$?@nd zgG17D!C*|ViT(l;mvXa$B13A@5L!d(Vujls3_+CfwN}e{Hpii<&zJPM(3n}FGdt?e zBFXGS*2cTUCdu^ii!iq{f~rY_-sa%fMbml@BM8qD<@q5RNf~YQF`$qeVcHhuBEs9S|&m zBszmGTZ9=aN(uqus`W6$xT(`iLH?G=mShVi_nt|+5mgU{QF4{^DG{65anN>*B4%D= z4u)|yrns&`(iF!;0^*BsPjO>)>v)BRMhFfCZv7g=p9JtQ5LYtianB! zP$eXDjR9W=n03x%c@o_wc3wy8MCD^A9h>ZJ{j`sO>AcXGFwm$LOIl-^bu5cfa$QF_ z6ik|RMlM&LLEI*Gu}c7_owC9Rin!;&w%=*RCP3=Q+B4$Hyo@mpD~yFRcBkOem@FFR zhOpkou^L@c=DNwaQd&P8bhAh-P=mO_YGku$9{iy4l+3#*H~<>3bkt_|$qQNz9l{EY zj3`{qHJP4J^qY1H9UBY~?GzhucmyEd2N!I%AtG>=|tmxMo9`C4P}k! z=X6YIi7?R-ku+uX8MiKFc8RWOaZ(uBA!oLUC_IjhKxFZ2Zf@-FADlE#j&}AIkhg4L z7d-Rg%Pq1ve<8~rZ zm9m6`8IK2SFbflt!mbT041H55E)fjYS$dVM8jZaPS7hlr&GvxdZo+?9|wF)<0@~%m<<{(YG zYoZd19;M@jdJ<868bmh*UD?v^^ z(X{B?3(it4-$|vi7o}`rF@1@<3F{5WXZs^D+_b+7>#$p;d#Mj6arS|p6`qe(WNJNjLqrK)K3R9djb;-LjrrPSB(y5en;-ctLjk#TDBC@!MLCq6HBIBf{ zz=v@`oSD#O?J;o=p(Cm0&7_`eOn?EftO2z8^!Tw&7(qR@h^bV6_^GCPyti@u1L+*S z7uHzA%`{!(A~1yg*h^|5<6yB049R5n1G<25xkhCqvW*r`C@>$BS1!ARG5G*vbQy!> zFsw`+aMz~SiqtUu@RCvx4rcXYaCDcBR@fblzLeu7PrC;RJjC#ma}?i@Z4hT7-q9Wc z8z0)GmS&sW#9q>4=h$GKJ)&`QS($k5^!%^Un12_2J!N@gvB!^Vigpopo^EL=Y$c|< zTuNOS_)Fi87x^Si^BkT1Pvva~cD3ORUmg6o(s4{Ww%QCMq3;hT{V&+3c;R<$hbkQUcF_vZ}d3bgi1ASuKl1AJihz9A&$3eH#>aeq! z^ZBB_Hf+gP?6qQ2JEAm(Ym3jA=dhcC;O^YWn2rWf> zFbaDh*gsi{mY=RJeY?6e+bTplLd#q}X|tG(Zo!TqguRPrxmVGy2$-I6AE^c@tB$nZ zX5#3@19>#*A8ZDr1+^*nQpzDhM;OE->6uLDX`geM4B#1$nY{Wi3l%oy=yr=;pJC%Z zPewO<#p;kfknCjhWp9A8}E?BWp*$HVlZPLzEP;u-5+GMA9Xp%f7OLbRE}0*(&5 z*#Gg{;iPLX_(+CbC7#cfMhPgKj%%!Ac_nR}C)HR{EE5H(GfH z2Z+^YFIJbH%+w&t$k)+m+!y}-dgti)quNiTu0l5P(Z#O1b^b~57gAfNkGu3@AqcR=lnuF0GfiU@zB z-$vC>v^P#bf*T^?BSriKJN_k;@K0&?9M5cTy6J^U3yHYg3}Q^-lv1{Mqg6u|o08z} z`g4+c3!~x99Tt_5OyLxX!nEHB;|fMeZMYRhesKqBOJXt5X34xz=hdNpt~`7GgWodo z%VE+biB^OYZxVLLXK4n1_u~(ZK;#+RpbBA_g6s(=a;U$%vH1h+wVV4VyUn*6$bQ13 zdEQC7Z8ej_xZk?0Qw(Ng0U$rOgbnA|tm{?Ktv(PU_sbFX5^ctNa28o!#@z`wDB3QU zrx7-A+hN)sQ@H2+eIFr^zg;aNsl5&`+N2vD0%J^huj{3w&Q)wl7DWj+7JKoB#OAz= z8kZmnq0+}>HwsqX_tDCmS4It-;hyyb-S1@2Q%tU(Tt`3c?1O}iyB9~I#ss~6`j^Bw z+E+*>`tB!EGQE70>?g-JSv_gAlkan#BRxod(L~?Hjh_6B`5FLi6rPaMNn! zt5x2J-7Pw5@@y$FB3P9ZrzE1vE<5KVqg6FFx0y*Fiw#*6Ff%=2$SQl_7$mOnoTFb8 z?hvB>;r+RtCK^Dpc&WeyiX_n?Re^{ya%ab{XjF?S8sW+{=1EpkY~&#^7LQ<|tf-kwvigv_=bRe`Qp1)gCMvZ5U z<(gUmecY=0CB3%+TF6VU~#iVi35S*;E zUej%fRwY6cWy*BdMY4r4r@K6CF{oWsnfRj>EP=1Xj+X*Q__2fcYIrVk=V$!UjXQ1x zU6+vvw|1L{N87J=-pwOGSgEZKT~;YwL)ALv9Y`oCH43ft=mdS^BizFQ*wJ=EV00h(R57m>-7|X-2N`|&+3GWp(U)=2y_i8p z#|sb1K4CROG}CA4xZjS4H+A5oJ>0}pi%&$Bxq()qr5CHq-+-KsEk2(?-vup7fW-x5 z@xz2~Rq*}UP4u?$mqxVP83#3a?_g1zyGlBxUYvbktqLE^ zS}`5Ru3>{hvW(Adu6Ne3Ca8-+bUjWO!D)C5z=q^jYzD^3PjCN1qv_^uB{~@=mPJ2b zeYUdt>>1A8vl-;j_9GZ8tm=^+AY*Jt|D{1R`mB>Ca(Q<$qsx zhyQHA_FD&04rKGB58_*`;mHfA+irTvSBZ6yB;rbf-1~v_IrQm^gCSnS6m%VhU zEoxG}U!Xusc>4^Twp}MNG-+#10xTNT8zWWHoe0h&%*V(ZhvQdAKQvGGcTP07V^)`q zhl61!<6BNqS}AcCnDZ6hs-{|*!isUW`&o#@m`9)AidP#Nn)8R3F!M<_X^h56qu;Gr zO_tL}`HlTLh}-kdf&^Mn@l-kQPC95pA%hHC6(ye51urKl%}+cQ#*hv@YX+V{8;*(i zJe`7^kAFHI!g1jS$MlQV19Ln+1!Ekv#scr=bOoJ}jLbZv+c|6b>yMf5II3R$qxGm2wunp=mPwbFGB!WHd0(>ne;})Wmf34y9C?POkCzDse`O7dZ}~T zpvdNflBv_G#!ys1lEg!(v87OfXw+YA*5(WoC7Tdy~sMVhu%8YW_(bSgAQFNgbn8ewW**3TKi7{@oF zb*G%}gd0(BY}@@*x*}W-aOshm4+(O3Sqao9_DY$Ex3mG#3DX6TV2dg=OUMr|GDNa_ zLdJ*vxk5D(E6$y*51LQW$l?(bh65O7z>%3&>AT(}EE7}|wL}!PpI$}LQ#@KMJzHIQ zG9yJXEwI`k`j5Askg2Y4o0u zD6laYMk~)z*GgAJh~Cp8^lGZ+imeGk1XNpDT79}Sp=M5-A$pADQf z$(qITikqNir?-EKXM(3NL9|+)Or9WAkH8RfCo$v|GtIA~47Te_WFGC#Io+31oVLEc z^XZ`$nOUymQGD@`ipk|rtEBk?u%gb+A}^8JxogQE&s0seZv5K3BLcwCy$ z{H+ebJar!iS1-{3EgrTm8}Vp_+6XsucHW|INP)7v`s~}%d26KEb#jsV`}0uP-5^DF z--%hDlD3_dYusv4@UA{_Xm-EMRW}Od772gq{L{E}Gv3KsRvX5;F-%7|;(glc=DdS~ ztsDb#w(cs7dH(_}Rq!H8w1*_YAeXp`VTtjkfTurL@~}Sf62$@=k?ApF3WPF*1KZ`G z{>{?T0!rKUUT1*bf7$b;r6n~R#859$cKR7^ukO4mDy-r^B@2I^WXXhrv3c9Q-9J}Ud)EAMOrA0*8R2tOK0i% z^QZXl@;A?x^uPG$>B=|D|FOLCWaas@hD3pZ`bnziJ?*Gxp#AC4cVG zwhi+dG5JLGXfqw$3~}3!s;wHU_l|(!yp2Z-cul~fb3^P4Lz9j55=IdKxPiR@4o{z4{k{)-JEK6G*I`Q~gCsd!q zCJzh^LHzpbvDBKMuTf)dyyfk1q+;{UD)EPCuGJ9(ZnoJLTuccRNTel%K!d@CJ`}b) zCEJV?xFOkSP!9*=Gmz~r=|JD^WMbvM04D@^-%9#e5xTU9)^`bsN`sCI#B6YsOuuv# z8Q=(yWX!1b>r0R$ye`3jorA0b4f8=2j;UEnjs63#~GPyZ@)V{+CDyx4vwOoy~Ev|?JXeK{mtFet)2Zh(JQFBe{d4*?(FTH0OXScYE_`2 zjr+lCgtE7NwD}g^Y`ogp-8uPrA$q-YvX5Y21Kf@1aO3D?XY+J-<0v{jJvux%-UcML zu;Tu~{?7jEBWP@7rF8+#jXwyEL)06L;#j3n0o>FqYXg;qfZ;fq5Y zBfK#@g2x5u^3jQ{{nO6z_CmCAv~!H3^ZMvukD%ZPL!|?P16B9884!-XKTS{spHGjs zEldQkwY{+m5Rb9GE>Fk*dtz9U#zpQdzk_YCarwRf0xczaa4z@WXQMXknz?tK6knmS z@EedXhor3)RfJR8*-SqOJVUJ@ay_w;=4{{`J>8h{;_9TsC~%GQao1OI0K*s#Ql}M> zyY1)<&Lbb_!UH8cuPJeY!WDSlL8zyXwrB!Pzhx?tj;fm3+9?sOmg@}J6JC@WBFjPDm=VaH6=^Wtj4khOpGLn+q zZLdcEnW2>XpV{hvw%_;X79xhp&e!f#DHM^tUeNAaYNxlw9voK#~BC$fLKyBpx0FIfMcfPc46A5MNg+-~k} z9G~R+TU>2jRr~Q^XDj;jDT+A>0y?qW4T@9B&kpJ<1?u?Z=ydZ$fayptMFaEs-v@_# zm;cdZ3rD%p>HiDm|COiT!2eMGfAak4(zBJPPf`AVzVhtf^8df$&z~YS?a>A8TqC|t zkH@35hh}`sjpZker^Y-+O2@rM(Xa6yQvwJe;MGG$vDZNEMNO8II?0w}aAPEB zCtydN(E?Ou%j%&O;7K^|$Tbbw8+6GMC}Vk6gjkepQ6)FL!i!JS2jdgj$y7USbDFqJ z2Xb!$vN`#*pCz)vBO<6WF>)$OZbnw6Qwh19qdCAxgnOB-ZhXCFPzM+Z`)MZ;T@;gT zzz`2sbVv%MQ|z=SpF;h-gbJN|dAxnn+}rqJ8>YGPoKi8tQHT(3a7A39AG@6?PeAQ_k>EauouV7be z&sjL;&m6aGJaFdoxXef5p^!lJ@4sGI(=gCeHd+?^k}PiVugf^Y`s@9apFt2w2wTcO zwEplR4dU*`n`8doIgcJzgHf;13Nho5hoGvHvm%$10k!b;NIrW1{%`N2_YZ!7L3DjM z%hun&*PRNQ`jsWOX#PL5_x<^3P679a^HYS1$hmCs;lr~G|N9&M72#jdb z-B6u(WQaa=1{9Li4H_)AL31>WJ9N=rWu$)>2UOpu(RY6;|=V9^}g$OayyS1oj{V+s&8hP6XR60^8MK z>wjx+Z}onul>_atQExtV5*!*GR z4X}JDVH7n|$UO$-K&mul_-Fom@-bby_R%q% z03SC#Kdj=1=J7UK-JTpA)#fN9W4l7GlihAJyKHW4oNNfP=3OnSx1xG4dj9mOE_rx# z@aAY^ub{9lb-a1Bb9hozXlMWU1Y>}|-QL*RKB5xl6(Uiq;N4S3hfMq?B0|%?ZQ}J+ zt+Ib`w70R_l&Vm4wQ_j0?LQwJpLj2%&gp(wD|mzT{8#7%Mj?d<-300KCB1lAxlFT> zevQvBD?(Q4J->Nbd5Pz^t?gH*Z<=t9+kT0YM^RVW&1H;Y=I$0MFZXs1k8`C~q!eDb zEut=_=_H$sK2$-|;PG5nc$LuD%!iw)+JkQm8D)m0Tc&@79 z6W6kj*Bxmdp`ah`tK+R4v}dKzP?|l<+GPOAurvqmc`3NC^7E&;%HK??{QRk@ytQ%k zQ^9z?D6QR&hX6oz1U>_}ut3;?>E5J9zg3Oe9v;IY-^>%&l9Z*pTZJM&U%e0n z%21OUJrg9T`TWHX`I?4ed(U5d&GTfjC*Oiu)lL~oL>>khA#V^G+WUF z$1h~$4iA3XJ~}L*8be`&^g0<1G~K8-O#+*LO(u|*)Xf)#gLyR=ptVVgAsB)$21Mao zSI6~WW9MC-WiI7=(UfKB;}#~K1#LYC*LmRcYM18z*pTMJxfj8Yzn6Q z$+Ew_dHWYKZo5Rw>33dstNSnX7p@7=N_FmaBTQQ$Sr$40Vk<-Gu& z>1VMgWbqrb_idkS~ie8}< zEanX8vyGluR>GBlDQLdc zsyK=yH4|+foirwi(NB@i>sz)!B^%2jt5Mn70l|LrU~lhWpUxJnlB;Qze$m^w2Zz%K z536`FW)E9$+D>8U z*<1{*qdUPTav`fbf+H3K4%}=F#+`OqIiSE%n$o!Bzl|iUNonO#Hol05C6x`e zmR9~RkfKvKASZbM=&eOclfv3|OdD~ll3#s9as{MVgV&n}`>%K2pttwd_Tl#a*7pA9 z&i1jaS4ZTmFyg{ZWE-2i+Z+2$RLvh_#v55Uqj)s7%cvE%F6{#ArWdHua+o6f>!*HA zd0FXwkmU!x%knytc0~}eDig&}%r_rF%UJx+bQxg^Q5UZU@#wM{xBt=1lF@j;Odrue z<;D81d>vp}jZy#3XP+AIzl-@_*L)~AHmn;QIL)BrRF7)Wxdr-g;Izq~{{HZxYIyO} zC#BD(T2Nfy1W>cA?PTt5;9|=RwVoiJe{VbjXa-R;uD~~-&eJ7&*-z0wPoSA$ASL-s zL$Ua`UmAY{{NKNS^y!zy_weWIMHrbJXaP#GSXn!c9txxrcO$Y!+ECX67@FM3XvpN` zVCX&Hk=okyHY2ZH>Nn3x6toh4)o_TU-3w-xq&* z^zh-r`{jjs0S3$Jrypw3{HyIZJNwb^Y)|;NxyBrZtDKvQKHGN>AFkj#^)Ltjd-!nK z5CX<6eEhgC1x>HjoYvgk%kL2f`-8Fz3glX3sz*y}e!GOrX8{1L0rA49i%4G`v4gA$ zRCs5g!p~o#&wL@Lr^F28{KJP|?XOM#D_eZuUyOii)C9~=EJ)2^zzps?q0+>wXIT!v zJAHcnpLBVHCCr`Dr%zCTK7Ix41wTWrIeXg(FVBl!4$aFoJ5B_NNhzvEEkYYg(9Pwr z2XJr#*@SeiHs@XMiQv?(>87ZTsba5uKI_FROcIvj*7otq*3MB4cL&%=J|-Jwzh=F z(h36c%&t=m7=u>}?Q~Q#AF-sXfAH!r+nXoH=EN~f2F+II9Cj5xIou4A%sdR^Ymk>Z z_z1njH~)yQ;--2{$4WlfW358zIVCIBEYLz@VP6ex%H{OX(vDR`6FRE$15YoFfPKZZ z0i4rJ3t*?3#=4$v+Efjd(^Au(LK!7n^?|QDHDGhP76blSIe4S4b}e{NN?HoE*ruK5 z+`Xx|INhua8x(-LoJp8@S+@m=&f8oHH-(oiXc}l*Yrdsx4|Z_oDm(QzEjLg9Z7b&$;AX)Y z4LDWyRN%I9P6ux4S|vDDeop-4^6$a!@h6zXMXDQNWIf|sYnomO9~b*Gh8 z?aWe6!7Wk2+wEe44&HCfR(}v`=4UKdh*TMKnWVAz+siS!K$U;1(uFvdZajrre!so^ zb~A;}$}8NeuuohCmj<>Eg|`NVeX45%f>OlVOD+x!2+Qq*s{>m-cXwcG_VP7nxjnFu zORf(Hpnrd0s}x)y7GnWV??de+tTQ_%&AXUvh0&TM1MS_*k z@;3=)k2O~bW}7dfgo4WiB`L^lf)g+dhzFA;JO6^gwiVtm7(_2!9}CH~;F7^sRfL+q zX0QNq_Y8)2$GWzE(_ky-uNv~T{mTYhHGkV+4h`nIfhH%oZ?M&iE*#8gyBi1EvHdFt z3!&i7!EE{V(gEvxw+^;;!L@_bHunxtx1XZ5aN%)@4_J0*t_3evMAPTB85VjPzIawp z>v>q{oAAYpf?D5(g_f6cZH9~$sl0$yw+oGAz4gQlH@=pp$CO7y`a>zd^qM9eU!GDrN z{z(zxJo#3u7Xo_EeGmX;>!eoM*lYgS>^jZi6+ARw;@g+3`lc88&s*ECH%@m?{9<(D zR?mRH^hfS3vUyJ4N=w;kY23VA_x2H=r zAF<_`IAD(b<*2QQ1LoLYu2vBT%(1^bqbcNodG?pDSjYkM>@Q!jkOSt~U%p}?2h6j- zJclaefO+y%t zrWz9q74p-PqRd+l74JL@IO}0E_c6~`4~eaw$C$Rtyjdn&WP<-@dtU*8r=SgdQ&1q^ z4t~LwUWyVwLdfL216*-U6(W94ZO3}wh{Js&_V$gqY~P4^-+1XBsR2`vV+oKNzP{6V z$?iMD*2{{qlE5a8-)`^j)`F{JDZrZdWWYBgz4+z~U9HRu_6NAaM88*2{k*byc(`%A zd9Zf~LN$Tj+}xmD0`M{adU(~yY~B3k+hf>&4iDW9q<-Tk0O-Eihsy3ruI-{7@>Uz8 zG4=?%K{Y1#WI{J=Crf%lxKd}-{L^zlA^fheP@Ycsn@6GChEJhfj7Z3z#@Qz^=sI;b zoWxMR!0DSZb6+Og=qbGS3C#6^r*2bE$!0ido6Y>^g6Y}}=4vy_aT6%R69s~snWf5q zr+kPoO9ew28$s3dV0SAwKJcojNYNOk=U_7?CY|kdCcr*4>R*tV`fV_ z%ucr7?X18+s^-kA05ki#tY{uH``N?Hyw#Z5k^yFiTd%|B;8hW3_`0lU31;{?j~Tqp zVTL6gW@3`5T9Y>cUgm8{!8}&xD;>gr3tsx|x05SM{^5g`w*`2ZFB2*h<6}x7PTxl$ zkzFm~b3qA0kO+TkTlj&tY85j!>>Vbp@i3zhoM`B(pR-mv zNYH9Yy@XAn1$%C$UIBddgjlLaoFc!vu_#6tS+AhH_MoZqXjxNGK4?!>2%0vpVZ4jW z53+*Nxi{e`IRI#}qdxfUc)-yV+aE(~vE|;e0c+exhht;nB&1$j*>3V` z0phpzmHkis^wU1j4xJXY*<@9Z5s;Rc(H+4WjJq~>x#OJHhK6j{Z+@neKZhAV$?^Vl8dCx zR(#YLTl$hTr35R4%+|YB>^(lL`Q8PUKSf8FFCvzB_L%qe8t)_PS%T>lFb)dZb7H0~ z3ROd~)kiUAqQS^3gE2*Up)8_g>X^i>O9>>{i&7Bg7HsI3_88N~0>}&l@L^SnAKu9T z#G`&XdZeSih{@t_!MF-PE{q5nyB{bGt zUel$PO({0pL_1OQwPwsXJGfv7hB4yokbNOmoUd?zpNP^x{JUpsGNHl>vImO9tHb3qlk`}?I7-9pd2et+YHSB zh2q!QFyJPE0d77+D20*iSiONBH#DXp3E^O1AJ*rYa`orhJTG_d(E6{~SSPR!wg$Is zLQ3YKojHk`B8Jv5eiR&qAMM6XA57#Cu_|UH{K>EVTG>9~Z4EC5v&yDCwfO0H^WYGV z)x3`6>~Z=ESRXG)`OT*iWB3loW9Q^kGmm-=$##yvx8I!{ZIF3?tzwobf{@q>wfe)V zL{X?!P{pLn$nTo)D2(W>zDwL09y~O#wdLo$$TJvt-TNBVDdJlj&22GoQB+@9T8d~> zgpC`HwbA(Tb@cn^Xnt+p8qRQZq`kbLG-MothKbI30=kcqmB(y&ido` z&M-s$+6)B7X}`iqc{~X4WoiA_!F5}L#AHN-LnO>>;qULOWHA1|w%9OMAf{TxgZMrFNeTj?GgjZr4fiK1?;_eqx z!ZfP^$AQol?Om=5Oer~n|;x!FnFmM*3O;8NfCst&n$_lVlW&MKw{=TvJ3B$I)-t@7y z_z7JaE{4E*>Q@-T%$VXY!e0*`&R48JI4i#5qlHIs`T4R!X*@UR75ze`9Sjh?z#pW< zvq#nKqgMyV7|)G90J}g$zvtgm>D?1i14=3TOka;q_fNKA(@_QVD=5Q_W6P%}2k3)E z&+?n!T5qnG?uozP0nfbWIC3B((Tksccv&Gm?aR$g{6)I5%mRFZma|+1*7=FumfR@b38Mz0;E&eks4YpHb#N-c!gu*n%^x?8b~g4;ib|VrFDowk(M$Ph-H|D<>31wR>jk)QbP z@PJ<&9>CLnlgq=uFWE)N!aT81_cnHTNa@GRic&1UG{5of{?6-d0*#C4H&Ei}WNT-G5#*mQD@PmqFvIwYf4!_6Zxg}6Klq#DeDVtu^OJ6+ z=@tHfXCzp9#vd;$ymjLX{$<_>BeM@LE2=-XAMsgceZ=vDe&(-y4m00u*irb6XPB_A ze&hRdM_kIs>F=PukMk*DgQb1UA^Km zzm3z8txXRvMb$DiZ{g=lQA(({^Z@U39{Ej_aIjF}mzR|@kXLxj_}5F08mFSgaTK|@ z+le##mLJWx)?neG;L-{rRe5s-r@@w-%wt-TZf6*HknenB2f-e|xz%*$erXR&G2PB*JoqQt`78CahfzJ zvb(dny??wNZBkCt-SnbywX7a6g<9($4<0;tUwM#^8Wz6cVQyR&gdB4K%0m(AW=ts` zq!$h`2ukMaa;czZ&#P%dlBpKCgkQ@=2+M^KQ#DN~uda&?7KRRUHBA|>Vo|_FRmN7P z5BL|wzsYoMj?Wmx9(B#Sh@*w^NL{!oH6iw`hig7ol?$S%>YA5+T@_!^Lp9e^7dUca zTuEEcRV3uG!SQ|QrVx-1$|^X3s)!2z=s$bIsiQ`^x|3rK%5Q3~pvKf- zk@;E$p$ctW$bv?4(ILx&9OmlASx>rN9um@oZp>HKu_7l1b}Sy5!a$LQ6yZYlO^oPQ zQ1Mb%D~P)1O}`7MrvMbk-1F<%n6j#68(7wN&o8JLtaLv{?!+jAekBQsTONs5K>D@v zk%!9y9tQP-z6|1$S00Jyf)IL<1#L{nAXc-jZ(e!Ls36Wkph(xSK=$gjyOPkf6@({r z)yzAuo{noM;lzxgfvahw2I?mdj1DxYhSoYAdWCiL!+d~5s_h9JP%!eNo#i5sahqY- zGe62%5ZCO1s-vQvnXUgK>61HfBfHd*y`x@s)oQ^@s%&z})R{c%d|_ONGeG?k&a?ov zF}N|TTa1rBw$gS2!umfJ@h=eE8iTWs__HvIsjW&g({0n%o*N#_ZB(IiQFDUDQ{_+5 zPwDVO1gAt0%%f{e&Vs@E;$bE!)8gpO{%J&+O)y;JB}aa|h-_X90C5#}$4M6P^);t^ zNrt_Q6IVk;dlOFSWI7p#kwilnysF;ZMC$~+Bp-G__?B$**9m2smo#hEvH|8Y>Lyo7 z*X7GGwpB*Lh0&ScIBL@4`opUES(~RXo14wo2S?3Ur#rh_>u5~u9!&{TbJMFQnrwV8 zKfUrk)ZkUVBx{BIqWn(Eih6Y2M$`A-la6*h2(|B*5S6MbByWOptf^JS_=S}E%jUA_ zxA`ewL@B%OEUe}I&MP~F_ILQrAB3XUQUhmpoek>L8>HuTZD!|w>*fx32rQJ8U;cX^ ziTq0`t*?ThoPLxNq#0Z{4lMjm=}zE_dXn#=r&xD)X#Ad!kn1*u1ixh^0=(rP^45a) zAa5KI*_$U?1djZP=p9irJ=-az*_5Y!q@8_3F03%c{?iY6E1|d6T@bGM3UZZWj?y|D zgDkY)1T!h4KT*(LdvY)jL zI~L8EyN8aTE#(K=!VW*suAuzYa|3PpUZAZ?MTaEwQiIqJ72h(?3-?&&3gBX5N@(|* z|EwJ>O$gwi$kX8YS-#5ipvX7D^NW0yZ-XMv9n>Zq$X9ai@HRm}_~L0nt!H7O5MR#| z-p0@m3xz0qZtyk~d{`(%+4F(7!O_D)A5alODL=g`3 zlMv-61$6Nw9Ox$@%1;VNL;1WH`;wHnpj2jYW|8=QC5|%{egFTknq6WZ=@N&-P_lCS z8(EWXIxt?CYA;-%ZL8i->!|W%$;imjY`^=fwWIj^`#;V5VWhRx{VSqyqCA?k{Q~3U zF7WF+4fxORkZT3L|{4$`vjAw|&$^ z69f)JQWE*QIKDT4=M=*nRrSweHTFR4wdV^f&9lk&1Id*I?S+L7QRW!76#Kvb%|2QD?&17o=KKqIH270tUS0SmFi8T z42Rp%L{xcDoxqZqGT0yw_V5QG{-bosE_}7Td9Gk-P9)~!X zXw$#r*U!R63toP%80&z#I#KEoofH=O!Am$6d+7@G_?1)F6;v_2V%OrK{grlz>4mIgOF0r?g3O-#j| zL!+*iqGf^*&I*rnINTq+{{6wD3-0MdipA7G7S+<=W}hp+LcWQqxa+wpLd%TBtnehr z?!5p+TZZXF0HsvF3+gCXvk$CSJ_mmq)_PP6FfwB>8!&H3?+nf4t+*#}F5Sre;YUHY z?+Kg@iGN@Hl_=r&ir#%eWTU0*TCQ5V+pAkMyUf*J*_Oz(kSK83iMA(KDbm)4QXLL58~_-7t|fQ!&FgE1>S$@OzD0Lf5!2JsS#X`!;9mIikVxz($XZ(=I$-bP!5 zmlX_W1n3FEcZ7$=+%t>;6w^H~sHMT(VsO0*`6i~~?u|tOT6QdEgy&Dz9Ra?WZE#=s zgZrXva9`YZa9@-S?u*%Q_XhXHgt3?rUaCd9y8Z}bqAU}*;F)_|MdoZdThm(cGIXyA`S-A^m`2Q=`9j!Ql};vY1-fu7}F z;m7KXa^Hae*pc}oM=G9BJ+HF#zEyBXA2K|0LUGQ8|y%mmUK-Mazn&D8&%*X!N{ShpF~ zUdgETX29Af-8@Qe3}%7m59l3%d1*%P117~Am|;M%oF2%cdLG1EOqO4xpq1%8@TaT@ zIXfmZ!}KQZt{^Eq!}PJhVrl@2YH4t@53*k&-^5hhy%8?L%Z$dX0QKA=_|vfVloACfnL(HhnjX?S0i#F)Gh9DGF@5J$P)mcm#l4nSA>YJQ z+&yY7!pmM5%?QxDCA%9uFWvEdTtr^ZGNPAy6fesG-C~k1i>K&vI==q&T$T>z44}M; zxh%8*ngPsA;&sf5w9V$l-o8fK*%jwIIqIw?0Tim<&H40jp-UI&{qzE~C12QvA@ABrZATdy$Kb11rxU2?$3o4LBR#^@C7*ruU zqp~XUF|2~tGo@AdV_4#CvZ(k3GR+E^2V2aR))^G? z0+NKw>d42S3T}mEHTYXl0Tmx*75H0Nfn~+gI_5J}Qx4n(e0&t2VL+yr8+)+7us^vM zi(bc;_dSfPL(^e5)dA?g02Dhm-5rkSs&#j8)_v{npzaSTc8L2@IQdIL6w2-o8j1B^ z3@$LVz7uKzEVTCiVp!e;xO>R^fp@1~dY4}J2kCCp=z&tVcwY=KxO2KwKLc2I>S^F= zb{D(?Pu%#!WK?`7?1}*15ye4vZ^(I|&`b56K&5v9 z6&T*%i64f*?lN4V4fK7&x)VtZ?n^fG0Lf+3y};tTv@Zsgv!IMS_YBP%b>1ITu|&OZ zfPVm{cOsc0Xw7@?yEbRPU#NFmc{z~xk7Q_2et(d)q5b_qz0-gOmNR#u%mCEg(7L=Y zq%Q9drF)alvwKukgueH8!YhDv_2T|Oef!0r0t0}%bT9x#HVt12%fDrmtIqoYc9$;t zmTPz17m9%0f!F%r?yr{|vE-g$Nwk;yfp({*?Sm5I#rpxqA#&~w)?M%lZB6b(79p^r z@vk(F8|i9=UY*C;sGSTjvO0sem)VDh8^<;HbQWjH`mY?6?`8DK1mQD5_gqt7e_G2v zy>Fx#iEsYbwfE%>5bVu^y~CYdjKIBjf{^QbTkzi@{P#MdXyw>&<7ALV^;T4;#vgtc zef{+WxcI(zRST-Sr^7Tqk{ZtIjossL1UNy``uxN1<|9s93BO;?n*>Me{WM~juQoP+ zINseje*1E!MtIcL?eJj)Yxpc_>hTdOpnAJj0DlI=sZ1XeH@&RoM%)c36T{g*{y1_t z`^O(g5WhmzpWjes?Vm96>v!|N{+mMXl|l+em`JAk$1#xZ3>;+lU(Nx#_e%k{7(Esg!z*}K3ZDuJ(UrI>MUMr==!)7EqsO9Rcx9}L z;bT#;7k;r9CB^7QRh6UXqJr*nQXN$#5NsDdenC%b__332==C|glEf>icmOrW}Q@eHafg!|EKj54~%5`WMZ1I;zFJhwx`k zvYSzwq3ibguY>FMubi=`FkRGpPBb*cTm}|Ae&~I`AHho~-8qk{I;CyhZ{&J~2f)q37 z(q!)nA2jl7kr~L|)moTgCW>6fIr~Mr+iGK82pLVzq|rH#{G7g$(8{It&E@%x>N`jU z_>VXF)Vl1XMf8I-!8t1INDf=;OKUoji8rOL6Q=M(OcPjE+@->MDC46CZShgW653p2 z@!`w4yp)FW7^PZaB=dx{##wU!daF`V{c2xzZnG>3SDaZYm^XZ7>&KlMB@jP6Jvlb3 zLo$lvzfI1LLelE-_Tk3S#>oM^cxda)VFzr^=K1@Y;CaqNXmN}LY3voyH7*~@t5xT; z$w2NfH0zDg3e1wB3tItJ7cMUH@A}nH{d_Qt^OUQIGW|JB=6}tlR97zs?eqJcjl-?i z|Kn!^ahyIIFf=$DgMZ;{T#kC(dz%iokI34@PGJk{@V6=#k7^!Udwa6C8;mu+`cn4h zw;J7XxI&I7U3D0; zx1jVg{D=ALp3Ie$sqY=^pS&$CwY{}-vU9KxsQkEnbPT_0xgzpG7XfK2g28W$dIL-= z+Z#mn%)FSyEQmy4V5$uMbO7B3335V}IhC-tHJG6dbbONRn+n5;SYg&ktwunyvckFn zQt8E={s{g{hILh}n2Js15~7_XgX0$57-XxKIl{($czh2V+QTYC%5OVXm*P_A0TT7N zH$7DzfDH5ELDhT9hgXo$PQZJK>?2sXxs0lJ;Ahn1h5umcvPpixZfO(`%M8%#G`i(GhjrPTib`nHc2y` zzu-V#G&Inyq>CR#9}DLld{XlM-y4q>t*~!1NzX;PgCILmKat~>^aGPD_tLARxSxx7 z1|dA=9n0yQmo_q21Z2)NGB>#q*9MK>s_d{XbMdtLIw$C)gXC254rgo9T-|b}qRT0OmRp*Ji}5Egc^85u(@wg&v~LYCJg27vcVMV)Qod(^P-XQ5{&%{;0_ z>S}F{OPcoQfI&Qbs4xXyG5715IXGl-Ypo!0GeVGs+(v<$2)nJtYRmqxsAe|0@hP0f z=X&i$>7)B;SEm0WeCyU`@MenY5Sk9Sm14FZ2SdkfSMg_i@qM-N=zVSOS0x@Ba43Vp ztQBk+Q1k(a!u5ePSyI$(w56I#rbjI_$2}rUrz6*An3cBwI53xTu9nS%>nrLaUsL2g zW>KKHAURj^1N#`<7E*z@Z&5AYI+21pg=xq&Np@zWM~{C%HT=(#V8^Gujw8BG(S~y; zAa1rTU;S{whiW)pZXhGFFPivfTI%c;%VghH6knAIDXVm-;puDN4`KT2ydBeri% zYO{GhOnW2*R4RXpPA)qcYJif~C>`F+XHhmjGmjk@%6OPW%s>Ijb}~rduRfr8la67Z z?Sq^OK!69ONItzN?zba2eMR%V_(L)uU3W&8>39@fq^Lg`T@KUn#U=a;ZSFw<#HWEs zq*3cK?q4JbB)W>bV`w=&H&CwPVJAKV)K}@CgQNr>lXi!+G6qn#0FbK7HKJ?+!?hx4 z3>8E$#`AKQ38OI@XY&gLBYX=`@J|&8w{;0U=ysu_MIG7ZIqQVmivoaoL zovWldiia1;D5LAw^SIMpcb9Htj{_i@AChE1DOOpP2KV|(gp%I!WWs7x->Ea@jDv4xsctK_aGI#U*2wehf}@)qog3tG z^0J$@;;zgWa8zjowrK;~jeJ>QQ_^zas=B2VgjoMktQv-HE4VeQ-b{e-kY)0OTW08O zW60;FTh!-%>UFxTNw1>?8a=_+g+kGd9gmyAq=1v$5q<#K$da8(i;x_ffnfWk` zO+MGm58ZkH#b!b0Ef=Z0p-!0vuT4Yn?v8H3je!VR5D|pHj7Z(`+3y!PK2aSnSl%cE z=9uc|Dy^)Q4iXqm`nN$NAie(zudwuc-Ra}agF`etJ&WqUNpI#lx;_B}x6Gh-ts zUqQv*GkGZK2f$WUkaEaCD(>g1daa2^y=9^)pbx{Ya-Zh4eBqQyM$Guz`}d2#poH<~ zRsLCvGSQ6NvPz=J+Y0B7+G>AzprV`ub^*>L=ASV1!eN z!rSYe-R)z$#`)@@X*4=!S+}*Chj=Sn*Xg%2s}L9e_Dkb$e}DM!{rgA1EWU?7UoRSk zA`Dp}47E^af}^EV?x49xLUfzzcvo;wAtyXmsL3IZ>dHy4NC~+%nsW@=mhro@_$j0b ztfoY8ytp^m*){SAHKIz%VD&(*>>MNb;6cPV&M&@ST>PrN1~`0D+PP0_*}|e&zAY@w z>q_YmCVBj8(Lz!xP1|7MiV}Sw(1tY+(Mri_npbsC!64p&$%s$-DMsEs^+kl^b3W@!nU{g|}iblgkZ(fIN3`eXF_=ji>K zZQFLv@1E7%$dDO}8t8ZQ)w;HY^pQio>-pd)4?rPI#vh?n{|EQY;$`P;28?nNX-@6T z$Vm~XZq&|2jT993T2stfn;v+F*ZY*Q)lt7aycv%BN`6x-#P5NDs!RIn#VLh@DTnXN z>!#!yKCY}60$KCX9wyy*)Vb>XGpX4x{p8y03hSiiCyThZ);Yb@J_qQnK1= z&vdrduwc>x@N-e{&AxyCelBbh|K#__^;LSAedr9D-K2jpx@@*Clhz0Q9@bAn=eyM? zKNcm*0w?O1^vo8Brgl;lE$uIC1BIP4ABsBYeN&yxw^u8tQEypJ?5y8SpR`oRl#pV# zdp5kFUzch6!Cn-R7C6_1nz;cA*<}%*eD;jSA;&8hF4D(C;h1O~MYw#G2k`Xi)2QC< z^gm?Lvd3}b$HN(F2W)z_O4uY-Lc0Z4J!hBf5!W*y7z&RA!>%9EH&5WBA-(u#XJAR2 zw2myL+sU_QF8GAk4sZUta|qw@pXT=dkF^LPVDsO*N)0I6xcH}$N(U)O9-(N;&7VQ# zm0Pv{3L0Jk-ts&BsMo*!91)Nr6wdy+G6N3X+YUijdJIVH;xHT>o)8{k^W9lS;Nw4U z)%Lr;VsqGk{#CChpQDfeEb9HoS(=A}f4vm~=*c-uvaG1Zzs}HLb{P*UfoF^-3Ef0W?e%Vj*W zkcOSJF&5@~p6+=aK+sh}J370GdaT`#`*Z^XkN^w5cB1n!?le5~azHX7+s4u6+npcr zR42!zN5U{3$!<|X0_|3m<1zMbl*Ryc2^Jo#egjZAL>>T?nE;_{G3u5e(4B<9M_U~i zXuk5tNtOR<>W=$*$%QMf1cI!OTMekxiBR)O%Ti!LQHP7aENGQbF+6m_G~3Ole(kLu zv$^_j#mCQyw0yYs-ry!@>W5I>kt~E@Bo%g5YqyNaYLktVv=-5CN)(RX!SwHc`}->D zw^+-yun6ZNXjd8Qke+? z`?T+9f-|iQagC{^q>Hnbn+>SF%b(s6m?2x5fH#Ez%7)*_(|#@6khgA1!9c<4?+PLw zq<|=Z0^rNI7iS-$rEk7*&a(_i$a78~J0|o^EFRYV%KnIdA&g*vzYvNV(c)26b73px zODWCDXJi+@JL7s?bIqQ3K05+0EIAX^gdoBlaV8+7c@7B3a}##g(1iO$QR2bNs!`Kg zAq=Bgbgn=cK+~cd(yM4`U^OyFU{4d{w)J9LI8n@YSSwo#)UwN$^mn${SX^Jcpx*=f z`y+AThYtty^5f%tB|n{LtzpiE^W2p@Rn+Errk#bt{Pxk&!OqcW;Qk&`Qio<+RD$!D5Ueb0;iB{VVs%!J9T!6K4vRB}*38Hcckawh>I;q}Fvg ze>kZq-8!P}U)-z6u=0C%N6BATt^Jp0*^cQaPj+`+9c>)R1vi@`o}YKbwCvK@rQ$`+ zYNQ@i8~QEz1Taq{MX_hm7-R&UEAu*;U{uGq~CI&kdye?%mM1?-zDxYF`USq#h`L}$kyxB@mC=+D3o2Bf8 z5;ONQp4L+@{oC}C6TSzz+GZ(RULwe_Hbc?!0zq1|8H$z{@N=0>FIoOQNI*72(eeU8 z*033hPAK4~`kJBWgaR*ShxK9_tSM>Wi^@(YQIrE~<_eRF4YHXb4kpuDm?vtMvgIYh z>`t?kEiW;cm6;7DbFzG@mf1>|mkCm=%usYffy-GTT~7Ht^IFfQ?IdB=kXg!>mk6?b z%uuwvfS;gaddc$de)5FrB`16jvmMM-IEdeu^U`pF(@Q?c(T$JsUFo2S*$6#`+N5l8 z)yaKkoF#L%A{@%vNjCv0Nlt-u$J2}9Fq-@}hBIK44U$$T?nZd}q58vwPKb>;mh6lL zsx~YYmq_!8og*U;_s9!>NQQFsqMxErsm^s$P#wPXN2urfnJW2G9kdm8?w$`vS)@JE zZ2JPG3g+md*A@zAMFLh{Ov;NpMPf^V@KGQ`69I%a|*{EVBx=m!_*Wh6s;|5Rw6Ys#!(P8|6 z0+rw>zZwP6WTHZ+PE`+4*TIAebPQovCi@M~9BJroe!>ECs)w*{`~R$OaDFgm@Cwe2 zjOPy==!_hZ6mx$^EllTL^rixu%G3R1s`MqdW#R08u_zXOH&7OS@* zx#GwsZ8X1XlMi)h`id`h$>#DZb?Xp{zI*qFuKEHJonhJM=~b`$wdiw2Zy~{kQm~SX zH>Tp%d|%OT)Z%x#{(D^fHq_L##qYIVy!gvvbcr*H`CJsDr#yz&mxbuLg`-Fq59}7f z!01xhkI^H+v&>H~Mo$<%D=-`&cSKXpkJ=N4)QU>O_H>Hk_SjG_MX_|EvS2!Y@R}~5 zycyPXo(ySCizCLv>fyohNz)G|c!yAd(^udBkVt~l0|@$8HnRo~oF(Sp>RM5xKO!s3 zI(u+1c8rwbYwNIY1w*T*j>B$YoECG7Lk#Wn{ zMafgdkrmR0aX80FdDAFkwqSa9q>F4evdI2_Ko!{+5JfhHCamQ~UM;zr4=3}*YBxVl zcRU`Yy{Dt3(Tbt{e=Fzyt(?2Ha;_j^pVkk@y{IInAE}s26!1||*l#cL;cBGS(~5!m zT5G?UG^}44)nTCTws_?8oJB#<@=AsF`e2U__x1|1e4o|(EMA3d!?$5j@F*8UJIV!{ z#!iH>W}}iwa8VGl)vsHo7HXg^&1zH@z6*_)BG-$^GctnOhi?z|f1Xf%lVdl~-}D#4 z6Ihhr2m?Kz50mUtY}O6aWTkM?t%$_$u-72Pwtu+)^`uO2)}pJ3pfe);T)W_QjG41HpC=Zv&s8$lGt)6q+fP0G1yIGo{qTD z_u4~hlOkL0rWfQ9nZQ^|NVqKe+mpt#Zx^04o=&(kCC$mYkTn z4S|W_G7n5J$taGpn{1Ty;MCFsbgGEU@lEz)6a#KajB-3)p`QWXA6rS%PTGx1WB*|L z-QmH}$!g_4{tx`&aLDy1jpaofQZ(+}ZyQVS=lS!e`0w&J&zAJR@MmRd1->n>JbCiu zo24humsb8`X?gkCH!J@U{jVBG?#z9Hy;=f~s~haf-onnyjQ29A8H+ za%-d0uT(ZpPYzHtL+|vRgZ<-Z9hY&^x#&x9mO7^%&YA0!?eT}}QEwwt&$(k*bQ zpk~jj*)wRVTD^QNI^L>!^qi|{N_lnZ%9 z9vnFP>yKhasK@mr_Z#5a9;)#a_C)~br z{lKS?M)4igunfonQ7;6fU+a9BByLqoOGudZ898A=y`V3Hxa5^b;xUt}p_h2^axngA zu||ca>nABe{pm2Tyk_X7nj?h5EYUSAkiB~CZV$xov?a}vRxrTVyz}bOOZ*GklLMHE z1np{~LeX_ao;)!4F6o}r*sGysC1Y6Fy*3lWFO*>52^>%m1erxauhDx-Pow_=2ArZL zF1+D3=`}}Y&TO%4d=U@rlSvMURa_nS)^7c9LLCj`-k_1m04HbT3&6LRUA0>9k}8{+ z`gJDHdX|odt)w3J+x5#NZUfZD;Ks0S$%pc>m9~??F#X3O{sppIV{rBnf7+(0-IN0A zAKR)lGu<|A?YZH>Qw19znnZ>u?&T8Gf(ZJjJN`i+2#4&aGr(Q~+OXO52ac4}8+U=E zI%n{v-3NiUQK5>_PwDVO6c5vJACnNk(Jvkhl6Yux6vXae31b~WAKP6@oM8O?0EFZq z;P}gJymA^P!yYAJpo;eVxe&z}B8Jg-$cO_m+}uR`0L=NYll0per$V?+D0@T;77!YM zqdzg$0!o6j=~dEIDIm1hA&fB0&HTm@hxAx~ST#Ru|9ZPWt7J zH;;BO;8xXtA*KGZxorAve#)2KE%QNsnfE)d>=4@D;WvK}ie5_%oY{5pFm-PzYqg)W z+E19wMGtofER>XA{(B#Z{7Wf)bh>}CeSBj2q#vaO<+@!rIdAzLYM7c5w&r0~J;`@5 zepuI57xLI z$mM8bAEpWWPe0_X31Q-HU+0mj9CN71;kZjNHo7;MpyXkd=lJBHdANbMFy3Rd9y$A%{i~!8T&9&^(Tcq8#?9k{)1yr) zN@Bw>88lm+bF*>Z43exts@DhjJdCfK@xW}9|A?>RrvFOhQm9j@XxDk_qs;4~{ZR4K z0J+`_pn5;0u*L!5dR~|^^QT`145exx*w)6;PczI<9$HS=52bi_r10CCaUlGzTbz#%H;y)^0#N6i;J_4| zl^o!W-NUyVQvpv3~WVFAC6$ zSpbzPVicf*cRSnDAvw)dPW_}{?Q9+$yxQIP>kI&AQuR2{`#T56)9F>KaYF5ngLQcD z)ArHfbmE@l)3 zg;KuxS@(=v&*ro_Q!EPukj=nqe5HQ=MnFNFfwu-4d|$_}LG8@|s^=kP^!-MX*?zaZ z**t+G%HhH8&i*!t;jebLXM(Da=iwHz@#E19dyu|12=5gfED$OYQ8*z@7oF5?LU7sO z;JrTjaVi|AZt`_lYLk5O?b7r;vP7w=0pYGayR1>D#G5FVDU{z%N4P+p>h*e-wNR#C z^%(U=6Ugm!2BwzNF6JSb{&tQ0={# z@@x9Go4ayy_f-zoj~mlRN-Hsay{9?JGZIg zU7~e{(E$W@BcZO)=}Z6)rrHuX{*mra(JPK(M@P44i}Y*myGi;f5fhO4MOjL*4;EO7 zMj;MRTZi}B0B-O2$IS%{hmFDdFsy$RU&Is?m{W?PhHvxeq@hrPX{c{Gl>9M=;c!EM z7BAzzQ34u;H5+vOdI2YDco)t8{r#Wjm8({u-u{)N;ce-pYwnqc>hRFrr8nR|f23{h z#2xp`F9H7&oXw46H+u?j?SHr-(0}~<&mUp`V`mUt!Sn3{9A%5muEn8PywnOC1j`vyqE4=zPlWa2CIvUz!)ya zXANNPi}489XVRB@qs2~^0fygGZK%JQ4sM2>i_1||-K<5+-+sGNhrgaL;LjKJm8IpC z=rvT2j??qeHQuSb#=9O$k+2Z$^jijwMBg#-*E0}T2P3*h!rGbCCXQDM5WrkeT;*|} zj0#~KFsln-j8{@xLC__H3fU@`3>w#cqauMGyf;z3$DGV*(IRd8Fk`r=bw`0 zfj^bi!c7#-Tmj8j>3G7cU!TW+=PQ(EHw7ZtKWM($J$Qww z$c|4cxPw*13;Wk9X5y`N;obt)~&a#9V${#(af0 z70R-3-lzo>gQNuiw1zQ=U>Q(l7glK&eG@H? zvmveS0oFKgAV}PJ*XQ5=YyQmJ79YxwY5(53f~`p8bDj)gR6gMCI7y=@|G`j2=@owH z1C5W8VL$FhJRdJ}^@}gJF)~-+yM8jf$5L z`PGJ77Z24M!SJpU3BSq->fZfI2t@TEtlP-+;a5r${?0tkc{IgK2np6qq5?7R-Z%U1 zOP@X^T}-m=HGCfZXLhG%5y1O?QM34E-YgNDk?-BFRiegm>uix^KVT&Af77PFdKe$| zdCp?t+B-|zH|z71g*^v(?&0!7S}nAOJsiWbSU`|1gbizNh=a2{7p=m-@84G&kKVtp zg@9ERUdmBCyjXv@ye3Z^u>sy$&VYX&%?X;1YLy43B`D;#C1uts4-n?BVY$X5E?`mn zb()0tg5ASq_u{vSbwi@j)O% z#0@&Zuy;db^Kth&zR4om_uVpty@^8o9&aCR9BrH&9Le_d)jG0XOGSPe+I_0{4#)%8 zw^tnW6x#`86E7&%7J_DcX6BrY1in zQ9ns=FN|BsLNtocNP_4m*La?VH$Y#5Vbbbkcetdn6PCrp-& zdn6RTLeVa1ci`-mv84%$2wgZB(=Ky{e306!LvtwPRd>##=EiZ85dLXn_lM{@akeUC zLk`$tlA&Zo$L;HMOu^`R3&zbHpt$WEL`5h`Kd~NQMM)W06m8Th@N#`FnwxuI2o!3+ z?vTAsDuy!9zg_fa>##}y1e{CcKG#Vk39X`js-od%$sh(XH67BX*t@~hSL+pCrAxd< zX=|1Q*tN)&g737z9?{DzzDk;i-$VFoEuvrkJXUbifRZL@DSoZAQ-DB)6^x3GC(kuV zvf`iXjfzXfI!%{e)<)td-Gs#Z)1OJ9utoBStw(^C#FmYlx?cc$=FIwm0H0c zAKISaKJZa*Kz0UjO_&;Au^+#yWosB_qQ9<2$#9qsZNd%eC4X9rh6#4ZBnFAmk`G06 z3P#e8d&wMSJuq1ige#pQm8+8xtvTp&o86FTwZ=rNJRrcq_^eY+8W#;11%LsI5YFIB z(dkb+`zXHDfSg~!suLKh5@vQl0c54I#8P!MXM-Qi;i4K3D3cf+(Qcx-uIDU#-r=GJz$Ei~(5c1&L9p3`1_xMtSO4W2LeDv|)%Dx{KdP z;@RH+F~a}$Hg=Hc*1rJ|@xydsh^H5bsKkl}iT zDPl^6$ouekd42vNY+Z-PE9>*$(~qa?^N%C4$=TmMj{0NZLH!n~8G8Io)`(tv<*bgt57WooiGCUw)i`BNretA%` zy!&D@>dyn20&C?H4yJ}77f_&Fbe8F+>0p7FT&F)y#~CIdNyzJT%ts}&f*VR6`v@Cl z6NZms_#{}EH_4B{Bu%nwScwwffi$}OT?t}-{q=rokC6Ts7C?x#$eO!JPz=b%JsgpC z(!$P@yuN_yTj=v8uqWP|(yLAzO2PQ`lQEp@%&C{R23AsF&CCkyH12Dh8}X6^g$xe| z*CfA-nWt2tl`1&#boGIXKEm1D({(iXYypA?U{${&(DjdqA1=RP0y||Z>Df*+DrQxz zTdJt|PeMJW+ywg33rx1BI&Du;waPox)uWG(K!St6uVkNs18cTkzxpWKRPb8fe)Qg& zvg)1P6gU;FCIwn~Sjc0$?nDmbwbAau-k!9(Hw!!s@c-Y)xeNE*e%finTz6n0l7A+S zL&^z1#Wt z1smQOX>6KKW3xV|G%@ez-sg2O@BcfLG4FBi|3CKLy`ha8YaITY`4n2?t+9)3AZfNG zb-M&e%9ez@fwbupr)IFnFdN(Bdh7t3_%sTj0|T{E1~gb9r^s5836UJ>em2v3k_l2=XjwRz#ero*@vwEM@84KUwT=By>aQph#1-b| z;dNNcwiypX(+cZ61cVH!^Sd*v0d~GjBkT^(YKWcBZ4Amt2n%2VW-Gij+u{Xk*aIT2 z!$K>YrKE8$Q!OGCZdfRD0?OA9#^}GDSZ5?x$cT4ph*p|U(h!gotXUEMc+p>|y0Z8^ z!o+w23>)lOfQs~v=fFYKT5l8{I$w+STM_k3o*m4{QLth8ji!|F>^e4Xv5pO=4&oh4 z)ahmchQ(@2iQa%y2ZDf1N$UHC^Zl!@^r;H7vG8OHH1)MwZyq-bYBtD{H7VxAHjNk; z-`he#O`rh)i-2~we>(VV(%8=?^ff(e7V&4=-$nCTxk;W&3916mO5dB!}f@ z;Z@TTdkRoJ(XZsapqfqD%e6P7{- zo8q5t>f-E4!any}2^1%5C2?fnWS}?L3OSZ~8*8bAf)y8r1Q?4Vz$+Bm)0TsLVU_lJ z%f$g+eG~-301T$NVc??V_ss}HEI8)+&O(oH)$aNt(S#REgT`VARa|WL0_oYTV04{J zP(@P&*k23Kc>I2IYWuA6!!1&f(SJB+Lto-H5Z<(PSOHHSp zSGW|evy-wr!X8g7+nEGDow|*kP7Y|Em#tkV16RdCnB^bRqs%K z_LRS*H`v%>G_+TH@$neF5q^JqL%Zqch)Ck6mLX5{Z!AyhyUds-x9I z)iHdX`mW| z$0L<`JR&~G($Y*5|Kz9etfH1HZ{^joLeODjvaSgw?*) z-R3Fh&K^DA)Q^(2g&7A^+*)}$wkeFu7r6C6EaMNgCd^&M@$6};@rcBwm!*oIt`)75 z9`hCq+?eOr>GZMrZ;zaO-~N0Aw}|LNf*UWI#=94=Aav89zm|!_s=nku6*yDU$M-6o zUFn;jCAtnqa41H!2`60a_5e7)#xxP?+RVAYHPw)YG?YD1MWD4IrjVc&W{i4>O-BlM zo4{dVvwNlstHo9bSswhN3daK@+_8b;W|WL9(calc{pky7IFhO`qnt3@biG`m)D;&R zFts~?EWz60KAOKBJRIX+4?7OLz)PtUfT#hna4*O%25f}+QX1T|VN1}SfxVm3c(1mg zR{Y1=h`F+$G(j}*^R7-v3#t2Y46!Gir+;62(4+dlfe6t=`&zPM3LIBp<%^Jedi}`= zoh`2vJ0vdV-QHCw3w>`kLdnQ zW$JOEat%R+1OEr}*73L}QKdSbZG9l%Hy$DCE#m$T9D}~Zw98zMg#!%bv>zDtn3gUp zyy`ZG6DbH=?)O}Px@w)rE!W9)TgF^*x7|x5IUrJad=x87!H!y5v6wqBvR_VgFMdYymUp=-G5<92Y4A51+(3vk?vf^1Cm-F6$4M(pcC(;w)l#JP=JK_%HeM z;dE#rtQ--=Fc!vPfQxPiyIa1_{iWX;pWB>A$Gr(>^l0V=C@(cyjKZEMj-mbKiW#T^ zIC#Q#wErc+;sX9!o1!y&&tI}~#`q=#Xr`T+$UP`;C?ZY%Xb8$IUzK=C2L>~e?f#tu zc@!wmP--r(Ej#uOi72wA(?Wm4b zPM@af*2I% zcwNk()HNS88`a3Jgz`J1qNZcGQmuvb;SQMWcHZ5Ff0y|^kr8LM&uXn7j6)%(qR~iJQ5w{GY3_3@WA+bx31<33-OKGyFJ)^9X#}vOmOynJ~4Y9)CV*? znt7T&-zMfheLdcP&6`3_e|KYsiqZSNJ}%mRo7TZB6evl|`jcpI?V7WPye%*Nx!U|b z>gDVDlm)%@43y9fTyf>MBSKMIe_j!h3A=nh`8YrMv2=1(I9E(W6dz%zZ(k?SY`iw< zdrR3Q!eUAjJNWP9jKjLXv$4vFZz^^6E?j82--^q*N6NRerncC| z8%1eT*O4=FU7YwfQ7Agg0E>jFP-Z6MUIs2!bp)h}wuYBq-x9u2*VM*@=z~Uvg4P|H-$!>^Ng;Y+uZrq4k)fOo#h38N$w-+J zU?$3g#t>q(PKmLUoP``XF`P)05LY9!rWR@8tfna8ZUKhDJ(~A)GJ~OE#@c9?OM8 z&nih?fxMdz+M>hX z$mtc5e`s+#8N7S5r(WtjOBp^AHR(jlp+O?%B>GHDV-6L?>bXs@cZh{UC}x!5=la@H zVgpJ}%tI04#BI?S+Ar$ALT|uN_pM`}KGMzSy83gA`u=)*PMPHIc=bHLE-C6$(K48z zzBn2%EnD*XeBQNF&91M$=cccX*?wJ~+Jc4dgy!1g>-x5k@y?azA>;L{M@ugpi3wdF z)j$J$@_pXPvinuR`Mi>|sQwP^?r2e4S65M}4*Z9H_I?skM&l~mk|$T7v{D>kG%jdq zvVuSXh6vb-?_6S!(8FD$)mGYf8&rmwJla?kSmj}#m9P5tH$`p`b;?4@Qw0}9JImYr zN>Egzw|M9I5Rb3dJfJENxW2e+#LN+<_{PYt`s@^gjQw(k$|RF)(Znr+Ek zI#g$ZpLQFwj`JqHvSrv9@<~gvN`nfd_bvILe%MDYu%}GReU;({1gqpNWy=o^bq4-8c^M6 zs^@cL=?AEDu!Qa%P%H^;Q?hg#U%noDK4haVPWkv1(izF~S$~4?yj<2eKdj$x_Akj9 zm6zP>4DFp@-q+^>oEXvMjHQVF8N=e?Us^T$tZlCK3gv4XZ1@x9eaI3g=@W{V?j)+* z&m!!AFJ>Z&o=uuF%V0FORD2bCGq1`B6_m}FP0VkWK+^k2EiNIxourNYo3w$MT58Y- zkQWYTNJ`_JcAAQD+@m54F_#>hL5>wwobs1Zf$Q+D2Qu0Cj{!L#(LN})yq}dmx>V6aqW8}D9p&rNGjmqZJ97HPe-Z4{jyOpEv zO8i9n%r%kLe#>Rk*lu_)OO@dVE0-rGf0h+HNERd_$B2~uP1{pF_bQe2HTPIZEwLO2a=quDonXY6i#3`{fi*mx6t%TM zmW*$#nM05P?fy?;-C;45-X#kR@h1#7TjyQ^Bya=dZqj$RdlR#&1d_{SPN^))gWiwH zhUd0Pw-dxq(aeJ=0wQ*I*yaKu4xp_u11_h)Z%Ov%@ruCo3wa?0#dn1o2fxm!Ll7i}%;3{KJTdy&mv zQwa~f2exOE^D%Pl1+~7bSI48nH&pt(*iW$@v2Kp=mpfP$?q5-#$UM8(OG+#Jr|@oe z9Xw{v1&q=Q$Re3HO+KHi^PG5czM@H9SLu3`J>A^P@k-nt_rd@aS%sV!PC)^p^dhEP zqElc*X->F83Yta}kIu{OoEk)Ae3}Pob4aJ#jW8M=>X^u5-G%_*Y`M`{3Kt**D*Rz* z3z1qM56B5=mO0zYU15A4?k7Fox8%PMQSLXrBt2=t1f+=FdgLB+aidPjz&9kv`=;tB zp)@$$d%32>RA2{gUMKc{QDbGLfO#0(S)xvDOCtHQU5UQ*qVztJd#H3Mh;66^bxVS5 zKW4d6HVX9UIAz|2t#l2(v-h~Wj^LBc*YI_~8$$H8C`dZZM>+RmO9CZe<->FI zW$iwkP3%$D1KhnT<{OyAVNLo8v|*xL+Jj@JoQp~2U0|JaWie?q^)$#FU{NwhKG z%P{yhPz1hTjZjHiqh8&}K z^3C0a_yrS(XRwqvNCpWnuh7@wb;x`1$1DC5ZY8ol-0|C{n zmlbki1QqDeNlGB?8+JVQpqclTKe27-hkAM82)gn(HT9f>o0+adc96hXx6BdI^0>R) z!13rctLv@zh?#8!z3;B3KS)kUMN(`^XS5sO+@67dOdGP;_Rud4#dzW1!)-{Q3H1fX zvoh4c3Xda4Mat%B5C@qAmkEc@Ou)mNOfcQ(%!rV^?-)QO(dSv>{4HQS6+)-9$ynNG z7Ax9{CU$ZPoU^mGPH^bjPqcrw!y4p1qX5>t2R91QPb@MXz@atdK%5oM<1z6B%BjzI zvG%uV3S3#LB*8nvBCNN}d9gzO^mnqJyhl!k$xPFXM1RfNJ%T`ErMzOdpXc zm#9^k3EOF36b&vM;cHnhbG^yR!AeL3w|8^!YZ9 zEj9cSB_&?urWRnrSyCbSua{<-8BjJB{LG3~I(lSAO-nbzki|O+o5?zTP5zzLX4pbG z>RU-5CAslB)JWDQ6%WBFf~rJlpr%o=^jeUvyF>+I9Q~(R&O_iwN_K6E;(`e9Y^nOq z1?D-2JBwU2j8KY$2y;kr)j?q{6PMhZfRECpR2t}}xb$peaZaMxy-`Lo(3m;SWt~b} zcE7>APWB%MDHAgF=~00D9OB(LpN(!}l}=j*i%=Ug578q+b=eZfum3CjO#l%v7-J+> zJ9d)$;KijB=D5Hfik281NIk|&5qo8Jn#HZ`abLC~pY`Wmv<&pxQCY-??*hw=% zuf!s0^yTQJa#Hr6tSpZ*ohp3Ez>GM- z9JzO2JzxHv0a>kCZ0LH-%;W|gGA6Oie|*c&!saLs z8$+hTo5J8iHjH+!GwJ<@D_+83>wn|nGa3QrNv>m~T498~Iu{_>c9@Q4Nx&Lj zCVf?LZ_-^zNR~U1sIw_+b}_-71tJ#pnyC9lH7?1+-#yUF?iO~3^5Qo~J~2@df9Tf( zs}%~37L5F}_4T8<^ar~a1T82mSaIJIo?sqnF1sc7~-`$VXeYy!5Q6U@efaF zrUJ2Y^T}(k2+juNiOvOlv_B*U;@ZgK2=DiKGbnh>C1$fYPz8W7N4Y6tk0kg;Y|E2D z1TrWE!y@1}e@6X36a**hYft0&$DYXJ|H;RjS5IYr8c^>)|G;w!*}SbPvf(T>p(Mdd zmL2Ees$2Et81cF4A&dV=sDXYIjS3xGDE;=I;=d7XTGN%kPoR`Vz%TtD$&BXQm{Uzz z!3s%yKYZB`m1MI4jMPzM0KE@-EXl-6x6&ft7SbjDDCa7@iNPz+kCb$u6BudT2Cs$$ z3qekz$Ez+)_93b#)ALnqWNn$LQZs)-%yIAkx~=Rgqi|Xk&!YNwrp)zu(VZEOL8PQX zcic6xPDyDFdQ?7x<>%>tZ)U|az}JZOhvolX4LK?_PP|C}Q+8_gzmFV;mRU%-hG^A*sF__VIPxgv2KQ)a5V#52N1%T=~aLwRlgMFcUte_N)s=Th{P2H)LGR@Tegb zRNz{9?J7rq2sh}#Rxet81Wf?3k$3PkxmQdW+Zs9_TuffLbxF-J`hUUZPJbd(3s6PP z#zCQG<|511%SbP5{U78!?fesoK5@EV_6l>>G={~Vr%IzP)D*OtMzo8htl6|bU~t-+ z+bs?MZ(urkH;znG!=0BT`7$Uz3A;b`V~QRBI>-vF{(rsJJ3|(w%h)uTmK`fhi*H0x zy1ue(TYk!JIqlqpny+>bUt(E5U9C({auQ^6n2P>jZ6C(?0Yf! zGek@~&MZedaPQ;k!~gXwEeM!7;p%^Y&N7ctt0blP{7Ca(CzMpjpvTmD{$BlW z0yzC)a440_1BihbCgJs@Pi+ouVYFO=vLff8{qgv4~VAQcl>1Q~jqK z2@{Z=|1W(@B)sR=h5f4&EEN7nkhL_y{|NFQ1x+RrGV1q-sQZ= z`(UhEi&innH{PFd1Dr3iEt@ z>BB^oUF10*&YJ zL(oF|yM=WN=F{XM__lV&@qxm%Ldq{OmsTC+XqnKY%%`9EAbJ<=hibC;lZig!h<_Dp z@mmKr3KMMpl9OfcL}8Y+YW$CiviOO;(iw4hGEe7MaWJ0fVdSsH7WfoK)d%`sRN@+_ zi(v_FpIG2d*<5Fd_V7w*|4Qb>Ps|zILTxfi;+5(-{@D1(VQ2Iwb9UWIkztiDTP|L2 z$+KrJ`#PRlh$J7+D3%EF2>(?m%X2stP3YeWXPFdpMy{x3a>~f!-tv5Oa#b=Y%Ilq> zJQ2HI;mL`yD!5u)vUs(z{)rKx|Ji(b)=At7fWe@WE6VAjKPIU38(Ba$P5C5AquYwX zUWzhf10WL@3})O%it8$7Y5mS3t{oRnh~~vqymD2%;t}01=zQwp6N|$-mObmO#iegW z8^`{gI^`Js^s}OFzi76YVCce7enM^LV*IS!#rJ$6cXc^oh{57mEBq|l87UpU;XL+p zOE8iLql-|f5n|AUx}N+|QeHoT_BSSidUrG)(R%BE;B*TPg$3vezS2hJld()D@-2*R z9s13I7^$RYoe`D#3g@+qt+|Bdlh*M}(#t?+VKW_YZHp%@rDm_DyXd)eINiUn-x}0m z!6Lq7v!O_VmUWTDZvxpD`9khj|Ar5cPyMiCz3zmH_V9l>FIk}y(9no0lu;yAS-gBynZ22jRf#%U-@%o;2wcFMJ!8 z@e&2eR=0q*D2S&x0GiWj@<-aOhN4TV5?m82L=BkMAz)ydVUN;gNLw-x9JWxgSX;QH zgOVWfoQrpXj-a~>G+PnU&5w7JT(Wt;?Rzys>x73O_n9l^q$9Te4V)I97LlXhReR`5 z5X~b}jU>axQ?G(6QYTi!<1idr)Tb&n*s$pcNUQa+LBsofvZ_~A;|)#7WtMv!^i*H& z3L4QLRoqej_&J`)|E@McJG~WGWns$S4;5szAZ7!xPFtsuiX%HNkh2N-AboApz^gV` zrISCRXnzqsK#NZAks>C-6u^DW60<9}H?wiUdW?6s1sBWnkhj8qHE6b9U@@Ek$MI0& zGE7yNPeg149VYH9G%$XQGx3eAT3V?r>s~oq+&*-X9Guqm&JfHB<|ZPNlMZ@ zk)$WOD(%=qgEcqebXbkOID!&j`ArO+{)Qu}yhN#LdPMeN*w+-q7L82Vm~mdg3W?5f zb&LKR=`8_tnwV`aBw!Ies#&!H-C?P`(%V69(vn{FciG!`i}BfGa8=0k=Szda47eBP z)E?^bWE--a|t| zs_wn9qDlW&y{GX`Nd)!>7BWwjS!)zzuAdruH<<U7_2Ui4qOBNZAvoak|9W{!yyt&PW9#M(M%~xW)OiV9v`dy|2x#ZSrm0k*$$I zq#N;M4~^!<8%Gbb``6Y7wS(gZN2^f4(s0&*eZ)Y{JU11ty4K)x);Edh1t|Var$nA# zzLKNTU+n`k=ZNI`&#Q<$X7IY1;NO7OLTwo6&a~{4ysVp50Tjb|0m=Xq3TPjiia=h@ zdJ)yI0=?%eZ(HyRYq8j)sx+g0(4*LTWs^#K5KDJfvydJcziN!I~3zq zpb+$fvhOR*W_urU@aj?R+t>Tj($iJ1A>vZO6QsQ4U(f++dzeW6&lo;j$9afU7?)F7 z>Dt_tT-(We9Rnr5GHs=54zOb!C-kqk)GADP7{-w597vk{7X!atM6ubtYp|aqV1dhq zrt+rdT|S2_(4w)5x~lo64M?CIe@&$`2B^GoEFC!eTGX2(X_9dGD3t1f9xPW19xkuC z=6=$I*oc&EoTv7JbZA`Bhs--Re!0f2CODK@{7j>zx^l+;*JWtKyx*x4EHkDEcIYvO z?1i);BS4fY;?2UEvrBYejb>Zm@#98b>}k>mb{5}KE6h3v;R#mPPgj;JZZ3ppa3<)uto~e zo0Bh1f^Uu-PjxR3Mon8{s|@ehEidG1Im&jn-~T?sWdMndf&{2wp|4vihHGP|OM*u_ z)8a=eZ!RVB<*OvWL*p&hc#=G7u@H4r2pVv2gJ~S4BkA)80VA?&y5J8a2y+ObB_^q? z;Xq@EqRMsk(B04X&Tpc~Ck)5!2W1V-|1v~-RFzn;P$Dj{PWv+;PmRhM3?%?-S`c+Y zt05l#eM3AJk$_aO%p}6D!@X~BBSHRHgWQA6K)`QBsQ$!{fuwLVPER9J2p$d+tbz~d zR0aSK@#HfQsp#2F*(u9ol-xpTvq2-Nm52d70ubbt5O~yUsGpbk# zUqeNOTcDEMs;z{Ujja;bs9?6h99D%Bh6`4_k2H~DUIWTC7B6s-HE$+GEYZfr3t(&? zl5b$Ggbk5)o{wf4HE zCu~vT!GhH zmkozd+I0_=jvI~dlJ`nj<@IQ7?gk9-q~Bn-)J)oA`Z?q*m!R%+2YDN0-sU18#1@*8 zqEyw1Ck@?y-s(D448Vu_h@$o;@R5d^msK`J``&73H@pj^uhEWWaVW$kTT>iHak67hQ~Vo zLk)V&N(z8`h@J<#pAX#7DC0O#jQ2166V0iey2TYtS@| z6M)j~WcuY)Aak4kDrMLy?~<|KrvcWd+50PKVA*={r7e3Zb1W`ay_#@H$OHuF1q%$A zCY8%ltpemlR(T_*=hg~Id01b!Z9fX%o~asV+SkY7MYLmJ)EY2Jds0JXg5qrNu%1aL z8y<-!_S~hCF9>2J>P!0ar`n0;r#!~0=0i=mq25ODHZ?SH^mI#r>VYDh;Rv7x?^HjQ z3x#XGf(Ke{F!3g;3|)DNg_7RlmE)8bsP|lYtrt!`(I47W<}pO@sz@RHc#qnhE(akD zw&o?&9v5*1B402*F@n$#oOi0P5^CQEaDy~TpDj1WIm0zG9&U@E+&l71XdFco)L<(f(%Y&k4XS=ELGeC#b~Tv={zNy$ts(_6Xj+ILnyhu z^83o{0uAT&Sj86$yI88wEUuElo#|%#RUfgQ6OWu=M&$_@9!~IX3|{Kw(=k4Up_77# z$G*S3tbA|F(IBGOqDt^{F`v=^ z_D+Hu7Lid;XYT0iR8KKDSdWp%9?lCp`qHH?0LVm|*O#ce%nV7xZvgYf^5C;{H58cX zmAG{t&P6b>CJstgRh|D2V73hpO*`eR_c!*jYFwY;nQY^_N@d3_&)26v#T2gt<*Q$G zKPYmgp7Ds!9> zOJe@|y+=UI4B8>AarB&6xN z&H_-M<}*HC21z0?_zOFj(X3HuCIDydJ%?Gx!2Oa6Z@d~8sSTuBRdxOGvbvkR*c)wE zMl$Jaa_c!GJ|4eF)8?%NG*5s%; zIYtW3@WxVf;7CRxehF)Zz7TVb z872BGBtt-SBbY=C#TLQGc^sbg8^=++=GuB?x*>=wdBnRy(-pWY?<^H#uAV)|#_iQ4 z%61d2;$3_5{1!BmM`d$UyPc>r(HvNa*^YjS+=uoi0VVaD73O=iA5t;QQ&18(ixQ$@KyPV zl+R1228s1QM1m7h9}Vj=!79}}eS{fj`?{z@VkThPGpzI@r-}p1RAXNa;6=)e9W$sesYYFhPl}UjIsg zYdAi4oBZpJbP%&zAwn9nnp59VIPoXs23^U>mbx>ekrWt&KbIw=ag2HRiPf)+ur-w4 zozAs3SL~i&=?JMkN;?95L7m&BJTD0JTcN2W31F30sf$BvZy_FVT-}^eZTpUew6Or_ z8f1353Jcqrf9{18@yb7GKG{vQX)vWYEcTV;))3ag_;FZ(d+~{D_?T57M4~_n%@8wXg*OPqdw2Xr6D&H>Y*+!V2Ps)wCQF+815lqwkm4g8sJNS8pAQw&xp^`I0}HX1c4`A zYEU#y$#DIg>FVcr-j}%wT><^n`OZ5lnn(c9Y$+-ZwuuQ*grHqzxRq7{9~4ej|KS5U z73>tfA2jn2EXQvzDC@oFE&q#c5T6nmS%H$ePEKEjv4Nb%1#*9kg2g|=h2n^Zvj6XZ zj$2rVN4eoJzvDP{#FkH~K3LtTjs$W-#e9vk6P$ ztW4*?kaGEvBC*`K5j75hCujf1-D2@MhoCf>XQ57QTA^XnAK)lw4gaxaj63uQdj7B3 zil77~ zIfC>Xk)zKfbp2Y(K)NjeVU;`@Bq|5Ylu|O(#2P-dGY>7(WD!krnX`b<2gONYGiZ@! z)r_{sE{{gu6q}{4rrq&nU5T|(H#dECptkl8@LYlU?V(J>t}-q_>$C1r@RDbJ%eS@O zlRXqVyFXVj*05d(%89+nklKc*l)}qE8G^Im-tu&w0(*44Sj0%#sMsHUK3WXQs%_gw zj3g=Si7wHavUxq%M9QO^@)t9V3}x$Yo11_|V=Yh>abtc^q=^S0a7q3)=;#^hWBfg6 z5&EW+5O}lTkTRvCy^JU`i%sY@`%7t+X!uBx)nIwI#|Xj34pL8e__fYGZ(EJ&#pl6j zf(9oD%~XnJO7UY@RW9TCw$SG{@J*IP_OKBsS=)O+&t`y$^+)lg84hLpHD%Z=;cB2SQm-X@4-A~BzyoF(-C0t>r{=qYKZrqmVwnQrVfS*ArNvw&0hTqw?P1ZGxu&mB;z}vvD;GZ=MNS`v}J^ z!~!}G?*dgCS7{vS%c{MQ&`DG!@>&sG0DI6~lU^4&Mfo+rE#m2@-Yl%`x>ITqe#-tZ zhJ?w_z4&qZAtEGK3t1Bpkwxf+87G5AjTNT~FgzI$0ydS;A_U#gVgm^R%WIa# z((`7550nFHhP5LH4I%-!<*BgDiu5O5UJgtK{i4Y5VXE?DB!);71##vzkCF{&iuIT= ztC(iP^!D8_nN6+{0fW$n)}`t?pi>;MLF zBO)pUFW<0Yh^eM8eYHD7eMBVGGj$E3WC~37T2+VZLCjZ$p!7H5*+C(NzZ0una zm(=%7YJHjiY#&h=xUw@%d}QXaM#@MQ_7yqChve??Z{m2Ihu8n0zx+e?$)4i<#lVQb zFZFdU_I#uGdwPT~VKJ+S9(FTz`z*Ru`*t(?^{45|QygC{ef+dY^kemh<@ghR3X1)_ zUiyiP)$GzMv;u!^=_D@>ePI}&9IGZ%gx zF5CTo>pVmeFe+t(k zV{lndwW$r`(OOjQ+VWih{UWtTFxo<+C}=JMvdb2D&1oh!Tghc%G1V8sCKTly@@9yK z_6;gjbSSM}Y+DI4`18K&HbNeP-Hk8yVr9w*5WZW$!D@@J=7`#6MJ zMUsPcANQ=>wj7CQNW8fm!hx3NWnL9xLfBaw(bD-dQWJ;oW7QIXNn67v`5QVVWsK}3 zU`Sb0v(*yp{!GLHV`~Zfb>Y0I>z z{Tw4sDLr`aV}}MfgNn?Ooy$4Hk?wiWh2OR{*@B)J?KW&kMSWk0eeb*iMX){{Y0Dy`?*db-Xf$!}uIM@AmKbJel4PNq8-Gy*BvoxOgg zr1ebV#8YDwkpZ_2Xp*+&+C-0C=;Bs(h)$B_;bgiU$v+@lidAURsSH^Y<6oh8}YlI=o3xh&elssjN;|0HO%pHi&yjGU!)a)^{LHE*AF zAhA&;cVnL(PR{D~gCAvW{@#+RFmCzPWs=#W98+w)K=yLnJv$*31rl!h4VH6QAT%6T ziqmxY`%{GO_2=*n%~${3Pn*4TnD9@w`9*Kvc8Tv%(%;-Y+o$6O4rr3UDuRmu^?B*d zxeh&GP(i;gyWTv&4HuLI(WBj!lu^B-Ed9lR?z|QY!HUJ?>>$X;0fOAIl-_zI2g3eo zjG_ILu{%@~8OfWD73w^XU1b;d&6g9#!#AMswVV@vTLFtbxWL{aZB|4;0wr#EQHa93 zp_07KoYK0vUWL&N?T89+PV{Q@pB)!fw`*@G*WQ~7)=T4Zkfpgmq8BS*{vF`@=>OXW z$mI3n!+7Xsbu~-igX!The&1esRt)WwiYWZF8rSPs^kcHIm}4=fgKBzIkmRz6!UxJP zu=ge7$3nQ?dm*vhYU4SDnQ^mgH)S;5Y4G*;JoZZYc+$bGJ@GgCbeh)h(44jY6R{$n zBD*Gv7Fa2EJMa1hz9&0q9Oq0kPWdR4M5?rLeFID9dDbPHR*``R`3_x*}qhdg8V zr+o6CrXcO_Z=*rm78ED@9MdPo7&6znGh;y-Y3o;MXt)Q|KwouR(bOu3=yX$$F~4QV z^RPs&6k$CYvi3jBZ6OwH*6x7C-XkHhr#k2UF0cDHEI{nS7cN4gA#1FaN*>}q`(L;?gVuJ*v zP`dP-GQ^4r^F#mKp!$2D88ui=)crXLL2utApnkRS-iapm`q9!29Pd+~zJ}s)8Cfhl zK!*!}0P)_17`j!uZ*8UZNoc)E?^PxYqw%Qxi%ht%#4`gNXyWuoA-W@m9l5@pl<6j9lCQg`o2_r3u!&(oOM#4UG8|?6U z@gqWJAb-re2yr7v(Ep4zl} z=P>4uuy8>^I8)RUFJdlp>{)SN72_7DRnmrfp)X-n_xmT3?F)h7GuFrWT{k(mNtm|S z%+|3`!d>%v1BAQ{j`=vRhpRh;CNtSH?v?S!stq|T0E~K__mir`|8+iZ|MD;@*DHf9 zXnq}YuyaRyW*mp_wPEFjQ84HP_RolU?iWjuzeW%vS`Vlu+WU3D($;>zDDoG#^23AI z`ANyr?$v!2rj{5aJv+B!W%kUxS}ffxRXw=SPp!@?s|}{FgHr`B2MR4PkTqpafGYn8 z(4)F_y2Pj2HYq9ZC74>+5}QrLN(}q(A}w-VVaFQ>RESsnG8>VPHAp05BjPZ?E-ckY z)<|ta;Ce4Q{oiBFM^U(HWc##H8U&Gmbz|}dhefQxK&GQFe?9_3*K%oKGmBM#sJ^hC zR0Q%2hDGHUWB8C&-f^s~VP|hV_^Jkw<2K@u4|>(+#}n2ic>abGjG^OHJd67K-1Vv3 za1ADc|L2u-NGFmgM=5qcS5z!B%!mwQ?UKp3rT%2J)tsj68fVcX#cj(YMo4>bL<{_$ zq4R+)%r$UJ<3Bd6dQv<|RLv3R4k#)j6-bl%qy4}M1nM0%$cNz^oLBDhq-c8klnDJ9 z{SQfjP^!%LA0MGq-vK1}9Ah>u6$5^_4U zNAk&_|HWr3;=_NWChB*}*B;5BGqm_e=So3TrwFHjcB@PzXESBVkLlmY+w313%HiL& zh|6Sxe!Axdwnm4(jl{h^+!*SFKc12;5zIx8RvU#xxqtznH!*(_1F+LMtE#kPz66dU z#kKQAjku)!8(Teqjzu+7iA22}$()6LLT?%hOWi51L1PZdw z;UI~#=o#>diar&Y)nX+o8+IV}5@NnUnE~IDY^cPO2?^~%11{o&brPqkL~!ZKSJH9% zJA$!#u+w8sy7Pc)oH`X`-8*{z3Fyaj?rsWUbg{rsrrI^*FcGdnHb5i8S{T8`Rt>G) zM~=(k%Z!o2nmRZL9?wznjpO#9${`kODq95+QzFVag4iBmhvux<1{Asd>AOrA=wMLj zp~{NwOTqxl`kK=FQZN<_2`i2dQ|maZB7Mhh0O`i92KtJRO>!o>sMz3f4P_~Rm=X-hrn08lOavwSWz;bx`$v!>yrJMQpLC%1U^a=|Q>q^P;g=LbIL zJ2KTq4soFP;$U0)~g8!N(_Y+-=EJb z>ee*LBZD_9c>p&aJ8DbvMytA{T>o6v6wtl66l{#A%Yk(ztdbIvR^N5-kdEjQM*4Af zmgCS0`owX=1X!+NC6pW_yL9Q81vt-GoVT8f-Tm>!81?Dl@iCSlMz{a3#@2f;bQN=G z(@Jv1hlo=gKJ-X*3%FX}D6uxHVsIUas?+@M)a(krvIR~~1U73}<%S6FR_uzEf; zxtun?@~GXm&kz2JPK&RBN27W$=T{Ohy!L_^6>_aDCJt0t=MTV;Z}`w+NlfkO#rWmh z5lM_W`+e5E@7Z1Nq=QQ<{sX zlPBUfKZ(0N5FGUi8AMukv`EX+U_6ak*5_wwj49 zAxs#3g&|8`dxA=B$kIk~nH08f@FN?ub5lL?i&9;;aOSGV09kZ5t-U)uq^_%^gD{ZU9>d?hG7+kHjDSf!Xz!7M_KAKu8v8KmZhdZ2RO{*i+B;Urg zq6-(C?7;qWFnDqXTNV@z0{e^hH{*SDU&$U&5pn5RzBJf{nQ{uXMF(%xTyCYd+pdr@ z{hdTrm})Xuwvq4(M#ILnkkq19i{e#);Ho(|?#-^jj26)~f>?7Wh(7y>mwm zKGKs><;r!e31!l^Vk$_@7$;E>ZG4^ATlz>q9l~$&235R9u$;hIWS;g!ts`pNH=C@4 z*w(GkuRT=c5h)ov{|^9^Kx@Bc_WCA)3uBZNocQsXI!BLnqIPc@W(Z!cK-F``EwQYCq18JMtEZm4(7T4AV1L2Yza9cp~eIg zw#C(c@LJ+Z!!Wx9kHZgED#wA8K&ZsciPCaAG)_6mqcmQnbwr{lz$u#f+h8agx8G;2 zs@^2vdmgF;*kl%cy0Hfdb2^9z@?;v$8+LOJpanZtHoR2omWp`+ z89vKwT+m1p!=+`_3A^ZAXwYU6@A(;QFC_0_j=Y+;z3PB7P!XG!m{hkz3VTiV&0u zQfp=7LI&<497O}tnqlAJ{oyF;hcT~n^l#mn)3R$q%0feAzL z=+Hpc%EGPF!K5KvsGI6}i4K%lSi}uW^+KnqZZ{M{bXMR({^WvG|e6V?RjjQsNf`)3p-MWeJn3V__iq&#_q3Xw#jU|L4@av~WS zV@t!Bp&P%Ps0(w3-cT@j1AD_a_y3c@B%Z+TXsbOYEADg>#JC0zf7;#OSN0ss0;CKD z;u@&wqLVqHVGD_Su;Im%lUdN<^TM!T;AVh=uk#>zTD=oDY!npXXe0Sg8dLM6g2J@M z#*@K)WvLId&cTQ2$cq)s82}p(ui-<0kV3^A)dP(^W>`*T@}`Zb=->~OnlfI`jtT%! z=@!LaXcVm%&pJL@$s|nX3&K?4;~De8sCc{p%>0?5@-iYg6c5#9G*PIkr%1}!y~GO> zcY3VBnb|g)*Hnv+^YLURa-?C1SK<`T0P(t(Ig;*5o=uYdO`J^#Pp`iq(_E=ms>CFF zhTlzk77l<72fo=js)d1%26!o@nKD~`EXJ=qwst*qJC)VGFI7t($~Z2ZMtSjB*c~$z z;Fo~&SeKV~K$j!f(l$8DL&Z7KK)4_DPtdQynC{(1fB=R%VzW`<35dufX0k4N)Wr(Y zeY_4HO5mFamli6P$D2}T1n6H8P5q=3GL$+C67LEs8YxrgSmr?|=)+JcuB&>rep)() zV+jq{bqEF;eJn^X(pjgG3(R*tYGKKg5Qw#S?W;Gb!o`b(-ssQsmt<0hEXOM^$OJ;} zVnjyb2I~=_Pg#!oQ)V^NB;8;!GT@xGXb(9)FS-&bFE1||Em?>3{CSrlRXKANN{(a^ z>LPj#%KPmuK{!F428%AjZ02dpkaOO6Au^chOOd}jnBlBN`96O&+7(@QJ=!on#foJ3 zQ`ThiF|#UV)^4yaHSnC3>COPZExI}-H?KPxJz1gh_IcN+R628&nmoxmO^WH2YEovc zRn}4`Y>^v34tfBGBzEcrZ6A?6S1-iybL=RWsDKK_Z9J;c6*bPSnX2$Vs1law%eV`O zm{5_Liidtt)G)8{q-(#9NB$s2$#M(Zg-ejt2vFey|BF{I;C~F*h1e**w=4fx^*sAM z^|@;8W*CRD+&4HWk^A47m{n8BuMs`sjC6>4hh!y(o^Gbtv7e z*XxDjrm8+V9-eoO@%XL34anRGCw-&#VC`#ig%tQBn3@qO zIngQl%9Tm_VBR)r4md&St@~(efDE_nX@nNE~ zoLf4_q$q32BkJsmr4hl!5XA}>;gf)p{z)A5Fr2~AAD?+J_gY?a+;+2n^_9XgN1540 zi;c6Gcf!ntTEX0kYhNSAgiGh5>%`L#C_>G%#xey64o3}q3b4O9n85~4=Yc}wa9l1UQnWlJ$LfjY z9t%w~(6okf|1Bcu&{F?atyW(3wN^|0pmIK#xY)IEU&EnApUIir*;B}=>GjwUUC~zZ z?2txM0MBX1HJqXt3(CYt2-&dF3RZ>)HBsp(+xo22wA+9uZdi=TtfA>?F%p>@q9lng zq$HH?!Zq1EYRU$b*S2A7^3d~x=PG8ANl*YR&+6~ZT77l(VZ8eK_xhXS>Q{CBT&b_Z z=DT`|ulQy4Vd+?)ECVLfQ3Guu`F^WAiuyu6B-&F?JgZ0|cr)lMFow-zb=TptQCb9!zu93qTeWKCO*8okbRhe}A1|zc_ zH*#@_xR55WA33_4(g<6psDG@uAqT`#ajgUkqLglrBredN zQtrjRQD;=y8qGL-+M3yDQOsU`OssuSB|F5wH`>sMh1crG2l2>I7PAm z{}o6%mK~boy;Kq^jBbb6U>Vw7qoZPH((hj?U6#DtBSbt9UelYKK$z##O|nfBZy>wd z$__&d8hPD#?{r?zg~-RBjLvM?NI7P-rcsyzw4f3z5ISf^I*d43kRvLH@i;<9N+Xdl z`QqTSJE4)o4iXT$;s=l=Hn8H*ebhmWAU+^1?&M}&TV$C`LsLs#Pjk_NoVtLXKfE(Q z<=ejHqiGl8;i#G5jB-ESXR8hCMtiC&9+e7?IkP(jiTN_G)0ovu&dSh;DLLm?>6-UU zY1Y;Cj1tk=l#Zs)G*h$Lj`puyJsvvTnm9%K2hBSU2$6Nj|Y>8zoR!|e59D8^lC+mPp#t{;zsQ5gkj zK*7j#gxMy8gG2seZc%`k$H;tkJ7s|deo@a4H!2L+W?}LZh&m=ctjZl(Ikd~mSaWI zaU-t2W~m9)NUV$g+|xKImalSKu0Qr+g@w>8w!o=flOgccqr;u5g^mJ#4udeQSeju- zi0|IB!=tVJ{X!xDa+nDze@#V)KVd@#6mG-8bHGl|h5<^0P}xVJD+Uv0Den348EZ(A zNoLRs$d69VGmbHEyGzV3Yjt38YIXcuf8E}GQ%9BuWzMwH@g*S$=FNO^lar;Tfe7yu z#T)c1gPvxs4i5RVOquyi&Cp8@ZI%+22*=~#@bNmSUmb2AsDqs&b+5L@W;-yIFzC_w zK&1OPVj5v|z*wUvln@hMBLG&^&%<#-p5pPOi_DE00i6;Uu(agZ@9<2xig18W^~#Cc z5k6{QmcaNrT-MS8OcpjFkI7nc9ga~;8)k)n^%c9YBC$~?9`@tYIbhQYQAss~ut2r- zumjeQnYs#qgmrFp2*M6BP-5zI1*1{NKi4~4^A=bBbNKY0mC0j#+U;! z?9LmNYI{Z#3w(QH!!4MhSJ|ld2p}iAJHeV!%#qeGjK%Vr{wGuEoFrrt8#Bj%R9B@e zbNk}(8Er}UuaVK|yPD*|Tw+Z<7F-Px*p+?i1}n93WiDQ*B|<`-gMenkEU6}}P2@9R zvlt`q9F4}ShIfh4=_R|#)SBu-E!i;A7YKZBjTB5O)lSoVt)prLh^xkp8!;AmjjBl~ zjWuzwaPV!vCC}3oXw5Rk#DTzai9j-pr98Wf>yS2Z*tKGphivBC11j^5FL`U30ZO!* zwOHmFx&oTdNS|=5bRA&`?ML)RuLp!!>-#X?Hvf5o&Q@c-Wqjw4s?ep6$gb^CG>gI8 z*uI6Q=!aASy}HLT2I2+G_79}*sV(lP_58)blNVc0iQP!0HA= zA2~%iX>Q4#t)nfc946SM&=vNB`}a%N(Xi1snyjj5+lYjC?LU~Ma5J~8!*3e?8E>n* zfu&hZQz!RyfSEWY=IR!YC|H-Rv`zS_ki$bo2{w#F&IUGj*b9K07mF7_X8>Qrqh_z$ zD0wAj>xe?L*s22DQ?t-qZWfzgHA`s6gIV7Q)0Do+kcLlhn_@MD97Po7C#8=ws&1<0 z(wyoAh#0VyEJ19xS`S$_RRXG4V%>Mda3)q!;wcyw#mPy)1F!AlC|3#3a@u(>+H^fd zt=}-Spw4 zJ`Ve&XVpREt_wfZIx( zE6CkbvcFYG;Qh)nABNfJgdKgN2jHA|mMXvH0^IV(@_*zEOLqt5{ptuA0hIWGpA?&UuM;ADdtSars zhOROoKRM1oLP19rs0!Uy`B>I~R-zw=N1K$_+EY zpJu0d0};xds}CRaIf55MHTVP9f_=NK&6X^X%j#c~geJ%ZAgl{GaIEu-v*a$>ZJuTf zr?v(^mOWiJ9A)1U=uItP$WTgj-I>UA*tJh4A^9{-O3_p-nu-d?i5l4joUxwn9UksI zdy?n|Uf4$~5uceG0%3WY3I$b_=8|wY0;ExB7T*(<{)qO6NwK;FM?^IcTbh+qE~k`~ z(U(As2z0xR>q(RbskjM?RVWH*Rjr0`wTCXFfk}bCmi1-7B^6*u^hQ!7QO0v~c-M(4 zSP}>&>mFkqMWhj&M2(#5=6G>1X!dRE3gRRuN51RNv26^SOjpUCuf%4xa%Dd zr=t?Oa(rHLj$Gyt3suo=`J^XSo%-&~QcR^rh>p>*rqPyXvKa~$ zB!sbwedKYwhI&Olq%TO>0(wBMHJ{(io`lAl;1p73BuNboonx+gM2*4!ujxYABbASV zUx3mB%g(r&#dO2HS@>{ud7Ge1YL_snpIChW{-m85IGuGdeJoSQ&6`JIu1!$BMEYTM z{}!l-1ud7B*n{onzN0JC>54OIUl=iQmQQ}0z4<6|J<~sfJ2{qr*0)bfYSK>klA3L^ zOr>P{HVgLsj<^DKd7@3j_@F~J)^o&g_hs+u%sexhQ~|MrEWhD>2_O@hBFj0%s$MWZ zQuuWMl9yYjODKS`qG{{VvB%HxRcccVhm336QFF0@spe(`Sof8LlP}}_X*Di**H(!^ zzcYTPO2Tly#jOtKD#YX!nywD>^yi(u7cFaPq!nTa#AjBANoA==!*M}( z!{D(wr5{$HxSrZYB9&WQ?EiEtdJRR*I1p{#cR5i8Nk&!Jjdfc%rZc_=^-7MEVGlx+x^tH;a(?)&{Y= zS)2_HMjhL5?e#n7wiXUSyGJb?&&H=&$yNmg`fJZ#!Ca`0x~evY;jm`UW6ms-Y=~Qj zzS;L!Ep#i7*HoQo+^AXCSI&nP)+!uj8u)b27#yIuiq{bFZ0{JHvqd=<_K;y0dPu{< zr}&)DY+buT3j8paWwrIRwX^$p>*f9t#@BjuaJYB$TVst)Q3uhK@9T*(?Wx}hi}Cgk zsg^^^Za{klo)SN*7z{SX+kNABbrBjo7f22})yH*4OH4|&xKPU!x;Bqx2BUQJ;w9kt z%A>6p#g$*mWe*T_u2T$X@0Z3p*^70eaEyesxPryXUhVl$2hV=nRQg*9_6E~c z3_CYfabbbZk$Ot9B<5xxMBa7T{RO~hMM8^}abz2d6iN|Lh1mW}qlB|l@|1)7n3}g1 zAft>Ml`ZDwNrTGIg#6mm)}yWMpAYx94u8U6mXRQJeF3!-8O zAR8sS!V*ECR%5uPfX<*(J=3`EbyChDSl7p9xl_td>BDkP1rOQ+y3ndop6423}@7>DCatt~1t0yr^AFv3Qu7oK#xA;6Z{i;dE~+B%@!;^7UG z(1uo6!}+C?=#QDGj}irpMZH=tfONw!=;hY-{=xRvKI}O1R4owswv4 zHoW~<_z11rdUXHaU9`k^RD=||eQKj5vE7n106<0bM4u5|(9uGI`^&Tv>xOO_2)S}U8 z9m78YPgFk}_j`3cPW6qo^^NMW4Z>s`iEU-o`4iVX019}d7{up)0VpM3`>Ye+Su@cNRkC8PtHRl{n3^uDPWB?wY(NU+%hT?D(7$Pb1FWI#ahG;=| zis2ZKM;=uTT`s^uS5(Q`d>S8r-7aibt7b#NZ4#|cHKC0dIvLWojZ2u7ElG_NLDL)z6NI9jT)sC;fT4U1?+<;~YV&<`Io+(ugmQBrcomPQrA z4_iaakb;B~J4PKWmf0?({M0U}@qbmG@0M7;JC5&;jL+xz?ijvLu3o^Mn@US&5{K*2 zg1evqi0d_AI;w)2YtnD89Vkd-OfbDdF-c*}42h`mjbjN;X7JNR^-LasbmIYOA9}*Q; z8ID<$C?$%_r#b(V>hgE;$}e4B`Q;Iq|2?6lqhOy@o6@qs6K&qIXj5!UZO@o8?C%$! zWKxgY#089=7GW)&cS@Vn`ZzT+wLk4^3?nL{BT90@~(eK?Ni-YLgmk-gWj7tHq+2#lylb1dEBn zfUP@#+m;Z=Xh_Y0ekK-()px4;i>m%1??M-Gx^VVKmpV9v)LTrzK+Oe-ueq{PT{zh*~R|A`IdYlMAK#o=6j)8XwDq6qLsS|OV=ep`U?=ak3vyb z#GllRewNinVnG53#d{^|cQz;nlA)rOH)qIb5fZY5Szq&;9&Yfc2}5o(#~sKf%Bz4~ z7#*QQ%1}n&zrOZI$pNbDwyXJ{|#Yh|widel8H9E`ob4|ux*^c3kf;thKig{r)d zTKN)Z5Y=NTtQqfvOrny+R31U^BtiK#im-uyYn{X2p28z+!RiDP&?Vf_=+f3U8>obJ zF!4F65p$xesIfZ=PEm)BA+oPy_7N5IhCrGji+?&`SI6YpQsZE}N-9&RIfn#*T7`>u zJP9de-7=yNs~FX8V6=c_$s#PICbxi@LS8Y4aTUcV9lO-A43lqmP-7UfipGc6zpFQu zdcAb4_2-7LbCFMdStc}7n^=WRB2QX^)fb7^Q<*=%g~M-VGRa#hcnE0JXHc3}vM0&` zp*1585k?aZTfVcMiBaDIVpqFpN8K(xjXN>@cIfZ0bHd*dsqo?CM1D@`x9<<>7j_OV zrSnDn_vGI?Pz2Pdh-m6Y(}>E8X*V#Z_n9Zj=VdaLz+$*Qk49Y z5JT&fwoFROh=0|M+WI~5JsZoxiaB)A9JC$99S@>XjkL?f9VVP&O@wv)xSFVZvNJh0 zGDPz*D!=<`clXtiLho@UR@U{&T`l55&DPaL=FlANoc4sMfJqi&e7cknPGp5)PK9{J z21uiEwH=PyK&-emG%mQf41H6R0W0y2BQF`0+SC;Y2RdGa+T5aGP~CAy@u#m+Z%LNv zYyad8QJXS)A2t$w94hTWG}%2?ITSdJbOX+=FlK#V%CTfS7@>RY-X(h~ta(dxjM2oP zR>2A~P9qqUZKkIZ$Io^a?NiWOVkCW-1p2VEHI9Re;m98KO;vjRd+kl7xzeoFD$O!b zY>XzseZ~45>>-1d#2W-TeaD?dBSttD!yN>G-d{H5%#vVC-@jyk${ij>cHv49fzf0U zH^}2Ep!ZVZ3w>4mr&Ce!&`S}Ip*lia9}R^<42Z?XH#IE1i_plc1p3Dh+QbR=qUbHO zW;E%JFE{Ng4!`rxAB_D|T#HnxZf!}Fk=!6s)u}#xq5m+*} zeR+Bw4pu2dL{bAeQd;J)kZe^2+s#T?3u@?y9Aj=G&*wldllO@pSzDcxS0^#BIUe;( z8MZ6`FqIseL{jvn^J2>2tJm8AEJi5jHo^YLUba%gE-hK&!%u2|u=Wl9ejCE7<#5pMP2lA8 zeLU`jQSI!9l=$lL-u|wtbb+{ZVc9}rAqk!~85dSn;k-}=^b+}2muGgRTgHXe<)~Qr zMoK#i3&XO4E~i%G9K@XE%;pZ%r8B{(T^9ZzLyhOW(PV%D5YZS97;O#;Bld=-JldX; zWQ#ntVL_XzzlrGTobCT?co|3gxx%abg1J5>^Bu6eerxV_-A^GtCYib!+ET5aOI1oT z1Anpc#x8tjCg-DdSCPVbj<{uRKxeFt2A;D|0v+!v4M*#2vV7r7+Ah({hB?ug6Kq`b zfVf>o6V(U8IcCAXMZMT{X7jjO#rsoWqOP%h8kN=Sx}?cWLTXfUzR%h#r<{uH?c%c> zj(~l`5QGGA;nR^_Xqp}k=DE0mFS*Zko0Xa#E0ikqAn&{nyMXIQ<4f5M zmc#Ada>PV84H&)I6(mu;w=M^usdVdK$XTeVlh)yeZV*PW_2*_VZ`>Lm-@sW z^E8UuK}As?#p&!cjLjSNMln^9cN4^RK}|vMY^IdoJvT$jF6YViwmnSvDjJqp+Blwh z&kuC>MiBsWywcpj&*b*DD6++>y2yFgEihBRxZQ4@UNcyNbhF($Cj#2)_WV?3JIH!R*9(OU}G3{Wnd^ zO)1%*U0y9dOE;jVX3VA#Qs;Y0X6Dkvbhrvl2wlPm2-OJRVJe6UVdLLj?6SV#QiA2a0;V=$!aMs8GjOj(X5l zvSEF(eW<>v{R90Nj@l$&ti@8hfIXSuF&ni*F7Qk!!h5w+8MR}S-j~&im9w&{tmfb= zlq^5=@GWe^totKX3Dn9EKCstyNvjMWN~CY7DSQaT&(OW$>+lVdJ_iQ6W~B#c$!S@? zNPVjY=qf4_mkAmt#aPWdzlDw|)jN3s$fL1ZdAB;mYX^k~;8SWNe1mbvF9^0Q*>SE` z-jyxV9Ao=%><MXdRzWHs`CBo3{V}CG?Nqze0 zEP&&6hpsx&Ng%S&sIW`Ny9p}jk0%3v9P}<%>CP23*)_{s& zpvWgDxOml>E`izl5g#CqOl(Uf{<(j3sm!4o!-ER#ZM8g>Z6Z(2d5L zw1p!UoIw{Toco!N<**9zw~QCh*auz=h?P;?y^rgi>wV1tRimNS)Q@UiZK~=z;3;Ck z-lL~*{(3-d-P(Ia!;m}eJeeWJAsY649LB!i9z|*h(+RB$MuZPAGh|gU#wZGm3V9RG zG(&utK0Y{DxhUg|QQI$i?FXjqukoW_#-`&y+l|M(v=6M%I$YI}$S-IO^TJ+N@A2bG zrCa7~e)-|Y$@UGotI~ z!`5IW_%M&WE}Gs_bqmXxsnJFTCdzkJm?Jb3wHd$$0IuiBW{+I@Aj`wU$xAGTTr z*89}fb+XYAn*dc8#E|b=93gIB0_Tc+nHKPg?U)0SeVbpPuAFOgHsyL+OsS+}9>+l6 z+HP%cZU3~}`ekchM7p_Ek=XEp_mgWV_zl>jaL~zW`Z=GFk6`g3^y`|nO$Or2K3iMr zQ&OA6ClPaZl`{g@YfIix&SZ2Yhi(}OKvM>UStPj7vAXeyg|=~jWoNWIyU%y_UNqRZ zw;h<|V<#BKY-qt^Q7qR7Qm*w9+(h&Y&G$Z@mmj2qT(q;B{6QO-OI6x^wo`H)6^uw0<`KPJ&QXpoC+UL*}90qBgK%<6%# zS`m+^Hi1y{xU;%unU{i0QNN4BDn<+Fx;w-EVljSiqSi7_={|=m~-)pR=MEB?Vf#z{0_d za>_n*{5HZ)Fg>fgB`^j;HYB1<2>rs{a0>xedvg*cF;i(${v4Q=gh4wtCKybYl z5cn3w_AzgdxAqTr8>M9{IE=}Jsct?-3J;sy7MC;}hDUD=c-m}SC#YT0{)D;}sh%0M zaC)I>fs?kklaUI8IB7T@K5yt~0}U~f(JL4W9KIGdvtMvMf6>zS(XBp(oq>cAL$i9Q~l%_l>G0w8cS*hLp>{BZ zD0`|M*Jq%13N ze8Ff%mNj8}utn{mJD=%hv^&{`{i;JQOfX^wUn%ne*G5OS)Z<1=m>_97kI9%UiDM3^ zF~(czaNrMzy|7KDgVu6DfkT|qF((+L(S9_VJh)$qQEG!t*aH?)IC2Hkg5Zsjy45&9 z37=qCp&@X^@fsrk2Yk%m)6pIDyr%ldVV97HnvBTZT+&_ETBr6oAo|)T9uFNsa3+Nj z0*1~rfx%|3b>?>*e}ySBMw`0hnJ`1>j*;!E4oJaaxzb#DZ314tsWi*wV!gRuAC}bj zs-~&@v9{Fbh$12SVt_4&L#qi#P!JlX3dz2YDm|)-p-!6iQ#l2P#5$t)!MnKVv;aUv z2{y7!b>m^;(CrY;{lg@*Gs%X4O}}(zFp2X_@;+m-Cop>9+kmA}{!sOhKd}*$;^ZJP zX-Bn#2L)DL`BlCJqj@F(BXz zTX>C0T*#ynhbI8SPI$1Y#Lmy?H23{W0fdIKEMlX6v*5YU0n4x~F(cTO=p=4WNUT6- z9MrZCbfeS}9#hU>)doQMv^bB;VZA6tvosp0&?az=fZ0YXw$?U&kV2f%b+w`Hsr%|1 z^}x)f=0TSo9&{X!OU1BMJ3~%17bwSN!>$yZYT;xVLNPIsi&=JPeO<4ev5koaau~tf zLs!?=bimb`)3AC)_J~TolKLaj>)IciFOKJu2%OzlUfBhMrIlXWt&Jzf%fiGyCM zw%MkqRE$(A@*#G#L#6d+XB z8Hi$FU?DRkz@`#GGUSU#Rf=1uERz9AGLg!Z;ZbsOfg#4-i8rUDC0kuGKPKaJ|8y1j zjy4Q@829<22Q#4td1ROD{_j#GVKM;=B%;M9V(7z|A+r3xrYd$Ap45>JBW( zqXUbc+(0g+I>pM<+LxZ?@z(UWAHQq=Lw(@ieta48a~MzjUVAu{FZdxfFP1+KhCb{M@ixE=vc}}8Se(Y=G`0)^G4s+%#^)8xpLC{Su)L|2 zw0MJb7f@T6lZIX=Np=x(HBxj+jr+sgPe<_06fSb$YQsZl_5h`YPUlkeJb|FxP>znc z`>U^Xu2W$6(=awO9%=Y%q?(?Sy zJG%`-UKc3tq0q~^hnp|L0P1U4P;>MIlwnp0`mN9<18bJkbiMi{=N+Y*>o#4F*ca(HJw>KWsy7cauI)NK zhj2MxKELyHhlEY{o{rg4?$dEDyN{V}{c z_QxWsK?`JgOxYlt4EpItcF3<@UDXiTDKXnb4TkEbrpN#yV~p&kX=BP%&K!eeY>u`_ z)}#36+9WTy(3}p~X33@(f39Kj+-}&UA!kPOrW(zYok?2yFPo#kh>h~1({*DzWgNJf z_8U6GG)rZ{mW-{kA(&|rI?Y}gE1GVw%qOIjd9j75S(D`yt;sc7o&$9nNOR8kD;uRG zipe-i|6Pj7uU_40Cf{i$-)ScQPiQ93Tye%$#<&BcdE&Es>ye% z$#<&BcdE&Es>xSWO`d(m_=LL23mk54s+>HtifP)(a|^M0@~c;4g}`>`*pF89IA9xD&fv#! z&_97p>_$b0Lwvuzy>;k>u>@`k)5z1HohiBSO67Dt?>f#3whsUM+!bsc-iZb8#DaHX z!T$}11v6Lsmnav!6XM+o@$Q6pcS5{7A>N%3?@ow!C&arG;@t`H?u2-^=wD#=iQrRu z7+Byea$_F@GwYb@WngY8@iVY>IMvg@Oc1x`YhX@8XL%cdqPhMCAbqyS0bMZ1=YT28 z@;r-yKu4a~lXm;+7H#<Z5gz6{xSP-qY)a87Wn46x)dHX#`Po&iq zEbTK4`Q3!w4h3AgBY>ZU0E(!QL~qMTub6ciM^VjN+H{0)%N999@tBqz&~--@^Uour zgDB_Vm)H<3P(0rftm26a8-hSxZ5F2kN?9je`EUq@(E5%K zhplb-Jy7eA|A&N$ha#Ir@NadfEfk7OBC|Z1rIXK>YYCd>8g`l>FB%BWxgfH zyCpa~Mr>#9U)J1100wHoGXS-#xB-i8L9U-?y5AZ%a^|V8=gAFaGNv8ZF)LeE`w{!X z5FVL?*2blcxl)STqi{H`aS<7eJ(Ojs^HGFG^LR1F{Pgy=WP3D`8*I7or-KKIumZeI zfD-ze0RylPbWlMQY0+p2lr7bR3W8B}901;8y!LYv=AIB6f9Agf4t_F@NMiwcdpr#T zH%>At6deJ5TV+Uie9&!Z6AYXR&JR?nxH680t$5V#grjm@TX;h9_I8z4ct8J>5JH5pY*KbI<3jId=qmF$Nn=y4>u`)Nl*)D(b&2u;rU8H{;6lxvVC zR^B|G>;L51P&XbX!Lr~V1^8>p-BF{oQM+G*|JJ`P$(K>^F3fy#{`JOqIBeL#QaGs= zpOMy)-+mkS{P-;FqM&o^n_z*WPr^Y!@nGgtC@1Pbh-W$u*H@)0yp9eyi0iMz*LtmZ zauSalu-KX_uM5Y;X7f$6TyHj;>-EzT)_sWU85ImpA`B756q|;N$|nmSj+L;~2W`Be zzR22m4qm7JCyic+&w!aq_qy-u&ye;0)v^f3VBXfOtvciM|i zPB>O4ZB|eQ+5|fQU0-^GsD(MKURJPg6{=!)`=^6Osrh;SmAJYh{>}R{=QHQIhT7U0 zMz@O8aD>4m1?y)Bv+}Y#aw|ELaRxe>CCVH6VuL)&p&HQ`Mf6?tq!hz+S<#wa9j^$8 zD#m(3^%UgOlK59BDt!g1z?U}7=^cvMg=kDNr3$YoJ<*BbX|@WMEaPqsva9|cUjrZ( zYYvQ978M-=-f2vrTcj8$Z0nr>?Ghrz;a`a}#C;9(wsaPr-4)y+-t+Y#?(HQMzJ33F zYySvqZ=r~+xb9i6c$E5R8kdDw64r&j(6nQ)HjKPnL$TT3fCA|92(bS@{u~1ffRw)) z2N=1P?uT3$D;$GZNnv2oKg!<63AFd|Xu;Xw%3K_mOz&YyY7$G5(ym{;hEXb$0L|A5>t})#vH$k3qY9a+r=NBwGMZ8t|wql z{^7Zbc+5sz_vinspUnGLXYk_GEUn|D{$Xi3S(S4@T6)IT4|>VFcvUe9MJhRyN(P&d z2q*vDcYj#2@>pLyzPGA;h+$Nb5!ERVMeD%P;e{b~d{pXjZ;{JHW5J93d^Ci7BQ3Qi zCzYjGVF6}=Ny4TT)?gQZ{^H=tv#qDQ)&0H0BZU6vIj+p8ZRxz%IU za9mnqU5;l-T_D#LW&)+)C=Tf`hS)fInWFy}#!RAT8U6w--_W~|1l!A@Db7CB3# zYEC@z;k7cIGAdA#V`4h%v5_j7MVU>YL8c(2j2mn2nq6DpxOe}X2mko?JM}}s;BYv= zfnt@|&BSXq?p98w)SCri%z+S<>c3NNs!CVGdd*Y74tgoyq9syD%w|XrqID;Zi1xi( z#BM5T>$$7?gLVDh3A%Zr{JCu6<0YsXQV-f^^0PDvgJHJU549I@7!jf*~BTBWpW23C5`GW=P#^Mg(z66s%W8eCva<2}`dXR7rIQACI6w`Z4c+wxWS3eI?$P-CnP+Wt=c) zoEU}!W#gB!=0@4mW_DxI2FffJQmbD7|vo{uX2h%zhjsYXXU z#L%{ucyMFzNKOQ|kT{@H-#CK6)O_LgaRW^bx9L;dGFhLANl*q+?628L!cEb0H#!_{ zERCOD!Jh^tt7@Ruh;3SxhB%$A(n^LXJe8xv7R;GmyU%aI zx(C5zSp!V{l6Zqumiiia2Y7Jm`{VXmxmx-Q@f9@ZpPaGC zL%W=%_!r?Vl67>u%!Ruh%;PSIU}o8ixg>ib&VweD_NQCnJ$TtoXFl|I<~|Z^a=u@i zUkGrh=5Pd*XXc*2d!tRC+U%xjaLfF}?kzDCyNh!ayEkJgc5``(-77H_yD9R%>#`NQe{H^EcOk|?#)NYh z|4JOh?&o14@{ufW{ryF_h}}=cM(kdVj|e^~Bf-lsplQb@6he?Sfvc5jA4;B!BJeWxq!;+y?D5E_povg! zGz$IGKrAFz#X-?z2s08Zf}mq=($F2Rkm+G|MA!%d7`icFK}VIEYwO>Xjh`1>t?h52GyW{+~h~?L}U~on-cWKjZ*#f@AWtM zU!~rxHEZ>fq2t^BAR2^izZd?8Jq;pcQnUwtuh+4NFm**V(oFDCU}*8?uoV9tRWkox z|NCj_SjzBzo-SZm;6l-~uaM&f0(gL>RIM6@)LDrCo`8Uw3%cS&gUBM1`+V!UzthlQ zY%e2)f<~J?Vy?P?F7Ya_&>^5oz#f16QGkl}>?!VvDB>$?nHhi;7hV_}w{ikC4$#NH z@nysoc|D@ONOu{sy{5%%oda_vP`jn$6Qet}ZL4G3wr$%sI<{?g(6Q~DsAJoleD~g| znwgqk@$S9wtP@csNbRrtc^V+Ka(f_Arx}^|oe`{aDUb>OD(NUj(6t~cImVL3fxGu% zIBetUYNMa+x~D`Lq~4MR@y|_+b3B*RDg}Xab^Z@@!kHm;dNt%_Ie=)1B~S5CacR&{|ttYlkEOJrpXJL9>T*-siKfD>@q|g^U60f zYQ51MJ#qbh$Ndog@GY#Uj%1)U<3%gTk&L|eAo#UK)%U75k8{60KS6IunC4QCXbQW- zty>=A=#;`qFxH1HxU@)mc{LeZNXI?aSR_rTOM4dJ6wD5^-Z|yn@Kb9s^*>4;F`u>p zZPGLn$j*=wP^YkJRAVg1m>hs*Ey|`%$6~cJ>!|LMDn*E03|Z?!pVH3l3_!~S)*ROA z*(qmhHg>Hd=*<3HI`u|IvXTRp}CPx;{Tacv37Tn#o-U#ILbd9xAn( z%i}0)5PJsuS>v{pXCWkMDO@`svV1zu%Bx?PQEE(wjS4ell+I@KZxJdlA){-+Sj{q6 z9M!s5VYLl^5bfvVZBJQ0eu}mUlvNp@|9s^rp&1SJw7RK<0GOsuI^t=W20?eIyqLDC*vil{Zj1r z#gE%k2 zX0YkBR+4>|WfTm~g7{UZ5(8kq`GWH0bkJ%krXp(snH|^lNVy;6JOpo#6mOGYSK`1P ztBQ2r^k^yh6B$~LPS)97kI(nh;wl60uRBwxyItlSCYG+5J6;Tr*QdCO(VT{PBYXkM2tC92bO0$9z_LKn>d*cOxD`w^X0EPN+-N5k zS3re!e)P$)HQRB>D9~PA-|TP`W}9deOR@%~&6oNVaju}*LNmfV+wkt)??E;n=wN6z zeef(|gT&d?u3SqWILgSVLB^nk86(f+xcea#k!fei1oX0Jchbqh#h#Qz5u*7>#wYtF zEoSUaU=xwn)O^< zJwU7YLXAH+qEAa^(Zc@A`yuOp;CH7Q-CfQ3e3*pM^8M>`;|>F~%?W#CPo^DsVZ*x( zcvs?QTtV!3-;X6P|xAHwEfe_2h`r1067aAzYj^9TVA8ThIEwLZ`M1Amp6 z4n$kbT%)i2tj!z?cbbYzmY)5%O(ys3LQ0b}7A&`2qjoTdVueYOpHVJslq)wbbGIF4 zdF!=3{{S`tAU%rYy=;YUAuwJW&Hthy0ZBxu{TUUz?FQuExyR1?r8;HSw9}m0O={#M zM^i6g_bAk<`iLx&eDi=arpH;`%4xvp0w3JhQTBHB<66JZV&};U&D=_=LTQZKH8d(i z(%-9m?H7rH%TgRQ2MY13t85}^aZ|l|@7W)aD+I0dcSlt}LZMM&<>b1Lb!5YeVVHYVDE!LYVXWBzL3LPLYE(i(x9){P~Gr2nk33bU2=f{eHOMuA8<+l?VN(-n?9ci5b z!{#L27$V}Q?PI89%pZu5gP5a<4MKP~vW1qGs{Bze>_)y4AVi=(a-@yQm({Gx9PB+G zj|G(4cJDGq_OJ|Gu<|p*T1=3B@_?T#r3`a{{JO}WtXQt+i3k}P^97PIGb|U&3k#qz z20CxE!%RE{dC|sN{gm{WWB%B4Y}tIOy5d6$;P>y71S2S6!`X8;r?0|Q?iUjacMbvl zo@$)I;cgD=c0h}JYtHA(!cUi#O9msw7z>q}`2_j(2n43>^0<$-z)L2iQx4R5%Sj?k zS&Lbwq5)_@P(BcSKFn~xI`@h{AJ(i0|i3R>kyG1R9^9}M`e0ccmS@I(uhYf;)3fW1dcg3jU$9_ zF($A5n2Vjy-HxrMyRkipPCC*vn2amc;a|RiF@r8k;@$pZ#wk!ru)#t4Uvr7T*{n>F z2$lwu#rmW8e-Rt;97}Cy+qUJY7Wuh&OB{Z+yD7p~V5AEUVQ zsX}v;W}+M;a_J3Cm{2jM=~*iY?#W^f3LjoRt{3Bt{*2SfaC4?a9(Tpg*rbqD2Z4{9 zKv*op8NS-6{0k5_v#9Xh|F?vtZ5>wsOWpEH68hLH3a)rB-ek%}?33!6rCZwPBra%& z^m1p95OYGA6&~tY!!4L;Sb%Vr-b^G2bok19n-4_Ib1B3EqO+Z#NA&zsPHcF@miW0t z;URq&S8w>jkwF}edb7xwhd(!Q8*D-yTnjuyWAmF0Cw%Pj!K=*?G)yZ0lXAY*^j9i&OwW;=! zK>v?}=q68VeVB!-hvDJZN`Np{{1}=GQtM_c0O#!K>Ss^xOOafb5e{}Jc@@7^D6hZp z)kM={%N0Ja#@n)$AgaB_D#ohynBI&4J0jwlvw8@4yEVvFjMXUxd`Q>Zqiw*Z!i={d zu5yf7PeDv@0Lc#$Zirv`O~LiCs3w0AO8}eKF3hm-Wysg)6&Sq`{P5TFx%GvRm`l61 zNXC9fZzpbl$a6~#<7d6;!#qF@x`=>FBa{l41+}a^aV2`By;{zG|y}oYyEA0Y9=QR3<4NYxYTFC>2CH{n8*78^o(tYw3<6b4au21U9F1I4c zU`v}-wq0+f%sT zYSb(7V}Pjcbz7Iq+z%eSpdxL$)n@jxkP3z z&+IHJEaAr<2dJG;cni9sA0BK~`W+6i!$UP4HGP!d{mUL>{m8OtI#y0Nls=p!L2DZ_ zi{zo#m-hI0L#CXNveCXg2wheiVv1`I?f9M!vOz~qxfC+0=aZwch_NKe-o+w zAv(1$h3$2{Ul+-0OrEXyO|UPh|Sx5hV6MiB9|Xs zLZ0FX`Y{X_E{u8qPl=^&vU=VDOQC{=nkqP?u+ii2sWVgl9yr=m+St?+2{rUecI?PM z3+mk5G2m@?RkdeuEyu$+g@-)?e~o$VI@WGQ1{iw@r6d<;A3sbAJv;j{AVs=~vg+Irbxh*K1aa7UEq!@+#qjyIJzBRZ1#_la-mI_9eTxS5 zb1&?1`O+B9ws!#IL0_pF?l^dX3}-#XT8BY;`rxy{v^yxQ`24&6WYR?MP_V1Jy#&um z?tK=tN+Qd{gKxxL7^uP`DOAsUF9jgzP;9a~+;LjzRiR`k%5^wCPMI(z)Y>a88>55h z!{eboqS~aqnB5!a*e_Ey32ELZzsiiLCf)t)2TZAQjZ>FvUts*LR#{zPO-H!eE z!~%T)?jRcK-C(pFu-~{2e4u$!mCFh;2I+7{(2!5SO3zcFAeE%g-SYjE$6vQM1C&wTsayD!9K=g0u|z7y&`lAb-T6e8C(#F*+~St*0URS?eBL&!OsZ7mZq9 zwrtMZUvmuSROFnCL>#NU9oAlUWl4XYSbMm3tPX)9lz5ikOQ*$=Szi4v>|c0?2(+JCmPFsWo0 z3?b2Csqwcb?1sx4#8SqZcnY0#Y0m3xAPOR=r4ExWv{DM!(}=-!KQL`tlxh5y+W8|e zb=y-}9h|%+OkcL{_LUxdm*Wq2dImKWB25;T&Q^+cSld1BhUqN5<;V(xC@~f|3p)7p z-VE#mQV@y+DV94MMBS%b#86*~RhlbY^D$H?Ld!3bhADC?zDv^xY*I)rnCuhe^jX?ca-su05z0UgCZ+E*PJ^E^tyWV zKQ3brE+{ZaTyuO@_HrN!@jXL{9VvW#zp^^m*6v#Wd}(y+1s~4kNj*TckFLl+ZR7GO z(cEOjuTRqce4XupF#90|(&c1%I$x~Ks^Ui|XyMAwVcsZmc7ye|s;JYG4!u`Aca&{> z@FNKoS?|ggq=pBE$ERX){3m%_<8q|nJ~Poj4E*42h92Mi*>ECQ@c};iQKXdCre6N; zvXihevYexFqxPTi$W*!bpKcod*oe9BmBs_$Ke`ttiw$a)AqYTZ=TCdNf_J{B3jCMd ze*ws0TK-AOW?kYLdPp_qq^QBHn*^MCN(hW{23zZyJ{@ED`A1N56)ODACH91?$&}UC zF|Mv}{!?4J4YIwCt7D1|Khjw3XBJOG)Da|3LII2A&1JzN*cT{%AcZR)1*USH z&N7)=i&|{D&1P}TyhuP64=NBE-g>LWi}IpQRl}cVLH1eW)A6-m@&WQsBBg5l^t&Oh zD}9~BEA7LX2;CnWQ96s3fcX}!<0iCUtCy9Pj@y;|2f#MX`>tQv$62xUVC9&iLrH@ZoMGR#kc?FZWl@2TV|)TW(>Ws5<#JKq;}4wYOxQ(Y zehh@2ypmM7Q#k{vBaBkBQAqQdNIa}6@!n|%UeB-iv;N16urDK)@v1K)astH`$9aXX zVD?ar?rGVX$}H#SpbO08-XJvY3Pjcn<*IScvMy7*dhlG6Qe1ZfZOJr7OKT2J4Lxc= z4dJfBG*`I(Y`r5QxnutJE6TX(ye7`IoRb-Vz_Qh?mfAG^)LC=oV=Mkfo{)U?lsXcZ z+r?H`3*1D09zwX^ftuF4mTFDPE$l7U0fGAB*+-#qmywk!h3djwdsY2& zJUf=W`Rciu-5i`(9P1juQ;B;w6?WIk@o&}%J5?_C4BGi|nKOt@6ojFe0JZYj*CTIW zR4k;CD|6Hqm@>SG-#1*vyCquHs46fwJ5RR~X)045ek6RE(Pj^BzJO~muPeFbzBLj- zqzp-PpNTHjm55O-zkQ;xb*N1fuBZy|&I z#EwiM(q!^i6RLuD=F(Oo4DfXG7W_7S1bF(1tab}xyIZ-4=WT*P0dCa3AbwYvEReIS zvjkdUjn61ND}H2pgzY;u1=VH*Trngh-OXc)O5ZLUmoU)x<-C^V8C-*Knf1;&T(Q3=G8X8 z=*mmw=W3ZQGVFSLHeB%JQB~to;OyuBqSg;YSsa$?BSS<@?AZtWkMKuWP{bDo%2}jUjML+mpNQ*e|fz*+xLFCT+?!6@_p@n;dDnJ zjff|wUHNf+J?t(W*nhq7lNBgb22u|`97@$J)2{59eYiS*#D03e*86Ft8-e#L7UiHR zPil+n(brC($<>9|wH5l3*7vY})xN!n0|0Mr|F%|;q+a?t<6f7N~y*8c6K?d_;$YE80lXT{>JI9yjMQe5n?Nq*fm$2&Fn+mtGC zIN?Kfg7&>IpG32KN2M}cp=ulfeBb)l<>bR;rTG7KnQcd^l_L}m&&*f&m|e@dYEDnO z7WgtR9hbx^AmVKr04y9RZYfc4QRiK-u3ZgTwX{hbpMF>#>Ff*xL*9eZRczBDQa`Iz= z;DGP~0itRQgW5pg=Xb!Tghfo1aCM-jM$h}?07A7!sAhmPmtAVJis;lobaR55o6;g) zmw<9XJcO=;UcO<5PM{Xu2EV30KD^WtQMDGb8nS7P=LTqhX9A^_C(>wRMI#qj^N5&Q z;hJb!Dv{eps*|oa#rmD?ft&r2zI5*?K>NyAMNWw23^sc3FFtu*$=?C1P!hbsYmJYD$O^@} z1mnK%O|Bxtq^OK=3dt5Qk5Gvi^D;%o+!!dU?=7M^QWlgqN@u>^*J+Y}w3;uVV*9@~Tx`j}~c9`{C9>^8eFa`gUk z`qaLUtHFH%Urg*l=t&avHN+W+t}%b}j<++E zHxTFmg8Eyf^SWpKy_fwPvxF-0ZsZ1GX~DGMW>2oA;|n({kzA-Dd7C$4eE9EOL%yK- z`#f~;1-=lUME-(k8@8Ozr<+bFyWO74@SH5gZ)1pUZ-=v#YU+k$Jm|zdLM=@Gd|vaE z(`}h>IkoKC<96w7!fW=wVpg|%gn2y z_^)<orht{W%LW%uJGOuZ&LP*b^=A^;=p|oL=MRdRJa|1m!F6T7kO3Bjs8C#Fm*Wk*GEm! z?}dBv`-zE5v=EW_@qB-qbFUlJW!^h4(u3AFJ0&zZYeef9RbG^SG9&6y(j*7~s zD=eKUzZGm1q{NR8arr+l>`x6}5M~zxc%t4%>gh$~&wYB(yhqanJ3+H1?+X z`dFpt@vm>K`QGkcAIriBb_>`C2;-XGvJ;jR3uji?wShYYK;yyz0t>_Je=ZjA+ogOb zw6wLCzV52NJc|fMT{<=CnL@=6tg%8Wt7BVlP$MI<_dpZSyB98tICl9=iBhkNDWQV= z8{IwbtLXhpH>)jz;^e|&`WRpF8`tUR}!LIS&}D7m~_9SRBcbg8ia> zAYDJ)1lafFk#4d%LzYY?dU6eBwY!Rk2FynY-o~UN2cPtIvFN3ph83e(*kIce0{qLN zFx4NPeyLWKA4(zomTK72sY8;6j4#4aGO;UON7d$NsWb%Q4DPD3fr)gb!8Yr0BuRa8zLswiZp_} z)&CxYo2w_o_(ID0s2E(qf*XdVO5HnP6$X*WJH~kspfJhsjg{kwS3z9|i#8ndYpp}V zuxPml=I-I`a1RJ^ToCH5N@P4t59r3hmU~mP8xf`S3`uRb0OF!sA98@{-#3%Bx2RIn zE_umVZQPAiHDQl4I>^zFzmP=kst!8|AK1bJBPcR&uPsr+Ar~|bfK0YANDw#HxmkVjr_tC;d(it|J83i#@ z1wPS&h1H|Vq=ZZhO+@v&{r5KZPiW{AgiZCD1VTL+Xpnt zmrnaN3u5I)*aFEPUr+uqB#5d{9!8=TXPIB+9aq1NXi?{TJ?00yN%nqLW1dN#{fvX( zQ^UP((DWmq&Y7jH^d=z4+<4gjkHe@I-uuhfrM@n%760ODd0Uu4os#z%OGXCEtwaw* zIgFuhfWz&dFjQqQ{|fa4rqy>Ni<)Kt8L^U4<>1wu+M?}L)_Bu0s1jF;w5qY<^lHzL z0k=-Tctvfm&#I|@jW(s=ry)sh_Tb)}6t743jhSmvc963R7b!@@=)=~L zdu4Q3)y5W@$n-5Ma(f#&;UhX^pzJ5`tLkcA4hmYu(yzRi0Hme0O3_-sDs9HijezC@ zVV)B-POI17V}Vv(Z9K#2YTyzUp%j0lQR?WJJu@`N3>3sj_*1{TW1e=U9O3x@x|cMg zM(|PnYzm1Wvxqy6ne2`8Z^LHG^TTV_m-^So1HZpd5uo%>ROJ1UVJBTmPDHqhh~@}m z##iy!BJwaqAmDfIW&zu^6s$6KuXajFf@=$hZECxXXU(mbWVdCl$z!+~7XOYvT2(G_ z@*wfgTcd8uVmVAbZpvxR;wHX57=%pqO7I3wJQ=NSN0qCT5WU9Ha3LlL9~%nsaSeFL zAC5o%U`0Zfwo&4-{p)VlvKunqd?sLiZ7C<}^xvEl{ykj2J0HNBEY6xAjPz?=&=odGZC!annZN5RU42Dd7qk#Sy;GO6t-Zu5<#$p5 zUiF^Pa;v^Pj>PZPiP06WBW{aRvPtVbz5tZ#@lzYJHP7=7qX!B2Ss&`(*l``l^tZ@n zVDcuv4lhsFoOj10x2$0EJ>RUzRgleJLDWiWOJECZb%q<IsClkz{G*l{xkJDtIrr#Q@24>(fLoEJ(cNeL|*P8={<|xJvB?(awP_?0w zsT5~9F1(}O6VoLe+EYAs@(O93P2_25`{gn1`mCtm6zSGzdNicgKZVyvE|ui4bZVR6 zm^_)ADZ>>Cy5)ZK2jKBZzXv57_~1jJ%0P16YkhrIdIbO7M$ap@HlJK0o=lhZ4S>c1 z{HW1?%H0Gi5b%*w)m&`n3Q%+Z{zw>Kd3E*1z-exBZ6=c`sCVaid&B$`VQO!U|7RgL zdPxMetTmE^yn>etacA>(J_QCjE40EMe2CpD! z^w79 z2htWf3>nHnb#Pgy6b!S87w`D`9Aj;miH#8?+Chy0cSe`Rd4FFck;=h|3Be=75%jKZ zh9cGIBk8?&J?w&{JIhbU@Pg|6jHzcU{Tm9eKF%s_M8W9~g-`xIEn`L*eBb_MT=lRO z^y$bc#&#HpU|gxH%6qA8nU0egSp}9kNKNtm!bQXpeb0JQ-FCcXILv=nHjuXSMbIiH zik4&h$!3L6h#n8*VF})+pUzh#JoFB8`#YTuxoH9HTu@>~lGD(Bw79i|!{m4>iRonTc0n2(E`k0W6H-gh5s$F` ztb&U+H%v4E9yfz%kbu-T%VYz_JEKR0|7mZkxSAczEspCw@h@>NYvZ(-m#fP2PRjsj zg$r~+ws96jEbNQbDvIt2=g!#RdRO7&RKx1p(mYa86{Pru(;;If^^w#I%V~Dg&h)lS zU7f`+OQu?+l#+e17J9cV_#tYMRv5-1rV9h&s*Hwqo&J>;3UgxF!QgY#{Y;X$4yLZV zmAg^ofaQ(2uGhy5hs7`bai{Mx47pfw)0eJ18hWW0s_31}7g<_Sg<*=C3ud_$+RIqw zK3OVmlz~P3jrZhy60QC~&nwCZrXQUx;v`r~w_@`h-(tBTMImWOSojP`3hAvE4^C3! z0UA;oeFaHL+HLZM?NOJxAWx~sPt_!gj9kq-Da6hUNzglgLe`StJ=4N{7ko@!Zd!OzA4tio zDwm|1B8x3-rPK89eH+7RD$EHk7;|UXUotAxL%X~b%AoQ2TqlEU$2i8z$~Y1bE6D+u zX&=h|lQ8WWWSy!cQ?I*Ve6hq`_^6{W57LY7*G6y*`BkZvijA6T@rg8lX)2siX>5M2 z7h%eP&O?^}VXJ{7^9?oxBn;RWp7j(GOg+oIO|B3 ztS(qm0vnDed>;Tliny+Gai!v&6JNQGyQQw_nUeKbFXwiv^v-uN74>a zg1zQ%@EZj@kg#e_tqt*K+Y;U%U1hHZ10cc1N{3QS=>v-~is$Sm=CV;szvIH?@A)G= zDM9~vYmigjv_tY^(S!t&fbIAY4wx}ng^@8)k3FRgYqs5!e?{=;$&T4t(y1TWHr*<% zS**h7iQxVQ@gbnOTCbH6o^Z~~<3nvoTBBZFO9i$}2|IwCak%3FMs6grfmTgL0+og6 zE8n)?q@y^)(yz!!ABt~H-%WHy#~N)N-hNOi2>#$5+ql#Dm7(6I-e z9OUhfTr;2yTaf@@R4e8_NSZ5k3uxg8sc`f|U81Da zq>O!CGcru0CKd8)hcA0&gZxNs3kMOHQk4K_f`Z(EoKUGV$*|e)V<$)|7_GWd*rjHP zAKhhpI9%TMf*}%j0&*+nnHU*#5@I+_(=D;)GFO4~mzGeuw6akG+-zp?eE=<|78fVM z)Rj>o90)LJb;OKu$a^+Z)nBYSg;|t_C8|eorRdgc!Fk5?#(%7I_&Y~9n>xD8@aF_B zdlC-;oJL2q-)cX=t=WCT4H1Y5w{apg_!3&C8Q21(8(->|Sz)O^LMWXhr#bsquSjjj z?_Yb3gdjC0{RsWuT2pCT0+`$%?{>&9Y^Rdy_@)|B0#qFR&0%FaGg%U*WU*;2Y|$=D zqo79fj?q#l(Qb7L4`m2onsC2rFU`@9^oBA_lHFI&^N;E=P8s50I2?*jWCl>>Gc$OJ zNn6R#{jFujE-5<_{gB=X?9V=a?!?LiZCe!IT3cHygBIMXm#wWSdvPJ^>3BtYlA(zj zn?KVO4s3ru4kg{0m}k_R1EF3e5i#cp0&zmS zRSws1F{&OX&-|O7(@E3*wf%@QP_%$CPk@`wj`xJg$0ECTFKTUwL&wAh*H&1Af}wwQ zfG&O^+g5rSLmTHInErId$i5N>HdZ_@deS=6(}98IPdc{u(uIv zQ*6>P5LdRE!Kg2g6Hyy9v&x%Mz4`c&1k=eD>C9ln7unnV`K;zs@-U*Gu3uE9J@bfv zg^%B2N5xwV&al#ym|T=d?|1~X=(I1oA3fMP#@IUJLcETz<1lm6Gg1POW zXFcm(yn^_h(|W7CLh7eqmbs}ay8@3!%_Cs1NZhsIWOiUM!0jyj3aE3ld7HeM62 z#*z5lh$f4|aA3aZoJCsQ8>TYA7A|QA zcb^n8rD*;+lK)mDqd#6uG8NlJws@kQP(Y7@*B;_fO%8woBi~C0Z#6K&qYShOSj;YKY>_PR1wcZHn8)vMx_^9 zGR^JWH!I&dp8S7wyzu|8j_3V<=y*D1|BsH>b@<;p-iyq)j%WHG9goS`Q|7;Py!Vp- z=y;!0o)dbUF?OL%A_DrWeD%Fg?>p$n{6S+SZ_fop+gHc$F5C=zDbZf~@Ev7h=*l&Z zW`zAqW85TCQJ=?y{PDq)yHDw5G3)H{g*s^gK7sedC$BY*vC5X=Y?E?ZJlxFj`uj|8 zjS=D97EUOmyCV5f*4sW%@HB84g6&4m~#&w zw)LS9CvZh~fVSdX4@Om@8vz$T#LE=KquKjlD(?B1Kz;Z?{!vOCe3K1ZNrrKlZtkH4k?*e$Kys_g)!?GVlvqW$=hc3 zd{H`ShP>$oWj@zsClmzxCu9U0CnPfl*hn_N_Jdk@2-0$HuO4d?Z(7L1xV&pL5aQ=@;lQ-aGw8O?BGg~+~fh=2V zei6oGyst=3>55d;M&xX@a&C7i4tW!=DPwqwf1HiIpZL)2=1u#(MDo)WM>jPm{1+^b zj0*P>|7rRwUFNJ=#R*qGXNQWQL|mUi8tz#DN8gSvXA~4B0u9VUrWN$>VTU?Ff6g8i zBXV&)JG9|Vp^@MFGiAYgUMej}Q}C|dtE${Wgh#6Ts@=ni%VN6siFT96+-cWpbBRin zm8PhY5yFnKEuYA`(-gnmZF6wK?7X%AZKqU~S*6qnvvpe?{m=-nkF{UY_pYiCl%Y;A zpjQv=Ene(bEr$OY%aM+rkEAT%!TA!}D7nMJ>*VkgL_4lF$A=3jl+MTEbqcw%3=w=^no2u^OWC3*EM z_RFW7*q?-E&sVV0XCZE81;3TqnQ3^|Z!(&7D(UeI0P$P;Z}#pr_pz`Lvx}I_oo6sjn39Sw@BJTz?m6>5zMy;osW-A zY*x^5wX=lhXD_TGrpcOmw5sH<1}=i8kJ@zXtOa{Uv=}^PW>DjQ;D!(E%F0lbHj-9Q z^VsDqYyhvEx9l9A#L>tsNKLZ!CeykUZFH}@ziHEOg zEm915T|BJ64reun5?mJ?JbBG|S~Dkr{Ebz*=~8E_6Tq4ACScnADHcy>nHPm^WJ+Wq z;5F|Pg@9I%|3ky;Mbw-e3X`Ib5 zSdFGX!Q^}tKmODbXJlj~JzeS}f@FX$0(CqGx!eT;eC|QopB8qKcIh=B!e6YdDEjNC z(;Q4L`aIDzo(b?~O1=sDwgk96Ru|`d+x*WLCznk{%m2NLrb^lK=*Z?c6L(dWYEPh2 z$qT)$#^;dK)%$7pf$)aYJ8m=1g@{b$#e+4UU@RMg2Pg1n*M|65`E_C6}^ zX%04$SYemsicF1`GoU}#L@Dk^r~Hz;QOQYT7K1~E-R*POK3XPb0wK8!yAK2CuG|w8 zrt+XI2_`&HyZah!M1=V=azHCRdh|{1J|;Z`W)4exbn;rI;z2j8j+9zTsE|Q50w=Fh z=#4n21;MWB&U4;QdGD~og5oHP>Ak1IA-QlxZ8cKoETC3+o3aNuoOc4p2#5bv`vo{P zrF+#Gr_l)1<^PHkOJh?vLGt`jUExMLv;*B`vNz4mHJ_$%edD#ky>OFb5yUJ6TNr8A zE$LNUPJwC|P(;?>8GuK0oL+@HiLB%gLg5DYDyTX_q949j0Y=`BvA=TqJnEgrha`Yu z;-NhUgksxHmM+|f8?U7VYu&&g>Ls~xn*GyMHx0%~AH&H=7m5tF*jLX(X~=Ecc2cQ0 z!QmJspEy@=OB`|vR>NmJ=Dh@=&R7tgwsfaB8=7+EZOD&1K=lT|O}zTxL=-djfn#ES z`8PN1Ru!7WTd-F}DPryXm$=Hp0d$Z~t&b<2G=`NG)*#N%K=PR(Rk|Ax6Fd{7E?!l+ zIotr*6(cGj=I&Kw;pBBFF)7u6{Yql7UI{~WZy&=}dDl-1@`FGRarhGw4jXRO;)k$M zTY$GsUPHX+Mz!@;jRdI-ggZW&1`i`^H;fAr7M6WR!u+d=ma`eZLchXIX{gn z2|o65;&hJE3kROFnmH_8>FQlC;z_WcWs%q7lM`14Oj{$7q71r82|BkuPaVr2+36e! zEDl1{v35E`EF&F1*g}9Z&6&T{9s@Nj_ zgvY!XbEGdK;APKp_={_rZZ;Ddov;;yaf=Kp3m*X9I}AUIN5d+8tg)y%0#VgmnQvWl z-yv04mVM<3HJ`lz>kTHsx)Fh@DG`6x}tIb>z2A2`=oIJ!8%*UJp=+V z=>CCq-naP9C27|-|JbipsL=#g_w4?gZhzWLX4yQliE_*X<}03m1%0odCqPk23#Y6o zbR|pbHDw&+wMAtsr+k;5nW4g|6u7&o3=nGsE!?0TH3IQL7)gsM`Oj#wNNH}1o{JXo za#y@NO+ZHaHVkFmgZ1ZpL3V8gdi%q<0}`UovK`t?hu# zbPK-R8zB7D??UJ#5LArbK(yxD7cvxC@tduyHez#t#s7|J#A+!0`M_FaF^**hv>LI| zuOiGVz~LTA`3i&pOD4j>SlfKVz!JOQ0MYc*INlfMndK8`VJ=q=+O~_!Ryb07CT*#2XLNC8=4Pk{2p0kHvyDEk~c6l#)zcRJXb?y13bEv|_!sG_HZq zhGcmT(0&8-UiN5MrY%X0F;raPz~=S7M)~d3+~*~wejM){+#MxtQoj~a+omqAC=hh1 zpn*_V$%ZJf!#lS2kT>#-OQR?o@CyCCk_PY@Me|t9a~{ge6Z=Ueu>T+&OBnaUk2ba4&e(v-JVbGJJkm z876y&T?FIW#fPd54Zp3#=k}rUmR4Bf%mfJ+*H_%4&)L0lf~imiM_+eQ$mjX!YWO>? zR51p{0&5i+m&Sb|4jzT!;3UM)HHlbRKe-Vl2iBXnneMQuukKE}kf-B&DT7F%_ZL^o z7<6G&*nA|Rxzc108G;hjS^x*=}>}&Fle>jXGou*vo}EdI|#ob9b5Vv z(N)i_kh|N?+aUHh$e4HtwxXeQe|c@vv0)0T5z*ESZ z_5F$boyLwe`g`l;UpoB<$m|0lm%{PsHAy|f+GCR+KVx^FhPd4l?3WAA7z!~@w*@AA zg3d05Brg)+iG4>|zKr7Q_fji~ZiQNh3>)7a6D3FPrTl<D-mNN#s&zMls$5kZgnxWIu%L$e`ixM@A6Mix zOA#Px&ggFYrg)EzcBx1VJyHX6VxA2+WyJ;u+|y{P>NwgfG zW#MZJ<$@6yv7n0P^r%z7lN-W%-@uj=#dwz)Exh|Rh>{abtu!i>f)s(MfQ@Dw6gHMX zPDUQSwcmpp@|O=zP6CMW7n+__B9H-HFFkh)Ov*%Tsy_m&xcF>j&x#X7Cde^MQi0K2 z+KFC9?Oce1gr2>aigb94**9Lw^zCdu>po%g$I@7UD*}1i63X_{oGnU*X@Q@j12c?w zd5Sz}D+&sr*!HJO*GIRwg?Hp>;vy=q2}yR%R);^V)~nI~y4>~ocJ3bv!s3I-L-ijHaqgLn(lzeum9w#3OMbPN>`pw7*A-~qPpqQ7>ATMsh+{8gcE}0B|pp$VH{f!ru z#-=o+jYDrmdVF$ki`SZI&Ar4wT;FblZK+Kb=)MCO`h=lQs}D%FMX%&L@_XT|&Z}1k zHp_1FxE8CY0m0OeO+VD1qT>`QE(QY2c~3+s>IaU)hO_iSD3_6)K#RByh>h+JL}I*7 zF9Ix)*U^R;+5KhuQBJ*6to&eFV;-^2bDDpI3XWvAbE*eLyMZk3e4EU`Dv+~xTARGc zT0tK$Qo+FerSMKz0ib5=Z@po`J7ejEbwGC(J!qyL!rrx&UYxgIu?k$e2 zs|~6fSLUGP3f+2Jw`>Yhek+h&k~azISpbcDyIkmF(>65KKHT}7HUA>63Jo2u5eWaW z9HCJ>Z`U>~=r4g&*mF*cIw&0W%+07dXcA{iO`vk%+N9~9+|?FYN=ES9Vnd5$fMnk` zWq!w<9n*hVBAKSHT&-D?@)JFHDdz_YxNZGx|4$3*q&g7^qN!FcNd0^jvL+L|7J?AFL(Qh1}=f~8CM1UxFThm>kjZ`mU@%REVqZC-hH zPg64}5O#!~OH($)9MGV>PzhyE@TO|N4N{0g!-=Z@1!6#*zp`N!oafC(Z+!@%#*|IN zB?c}Js5g}%O?kf|X(c%yY82{|c!XDLsXX*r@QiO8?I}kWe5jS3bJR{_;G%I1yVMBk z$pcbQo63gKT&Y!>WuO5|%37(#yslyvEg(;=N7c;j6tF}|yl3^nqboOkp<7J1yO0wd zno4ZaaYLL4uxJ^$88)s|>py(8;dzxxMg7X|7>(39mo&QDB04S8zmN#WE#wQTRH7 zjVg#&2|}t@tH@h)CT%Dwz7~i()F5FKM-Flnw4>8O_#a>~5XKQy&Kw=;7di#{{v|0J z@li!eWtu`zP#bH~#_L-;=ddS}ZZ{DBU*zv0gri~9HP8(Js+6Dr0^oHpYU8E*t4=0k z&5y;*ZHW5_tXBgiC<$O{25R_0^H2RzhpxDzF6&JSABNg~0T2{uCVpN;gEaz!y+8NS zZVr1-Y?Q^mVd^Cwz~ajob}o#n?ws29%Gz2}=L6@O@?yG{3Q)4kht?>61P-ll7rE+<2<>1kJ3IZ`OJ z6WS(X&8`O6F`l*wVq6Z{*hb@X+#ZF)vFGVY5P{5JTd{pv9l|1L2W(4aT&1!(u80gN z1Dk8`NTA5%l?IN97UWXm&yGJ9RL)!$Z$DH+n! zVbBh{A)1Ae_49VkV=3Qz{Hc;m@MCUi@_?w$(LO5;gl3)qi8%1RenfyQFZ?Lt)aV>4 zm2OY*hfH^HF`Dae)r9eg6tDnND@VJ}BNI1tqDLCQ$f%uwRUzNZ@t_<(rv@Vsr?Ve z^^*wm4AD&q3A}k)#m`J9K%|AelqAqODwAGv!!Ql83OTyQmI^m#FOW*Mt)eZ$$5Q?G zV!iWF)qhu&uj`$Xavcky8wS%)t1FG;w9}nqulVArt;K!Sj=4xZyH}X^CS76){vsW! zj_f{p%dl3re%akRQoB!|1KYicDM#9)C9INQ(DsM0Z7>B#G!`n}jS%4x%~%V46?R;@ z=c&Dd*OR9dvINt}9C8x}y$BtfS@L~e!oZlYzE)mo@vRU{6 zvAYwYVrVVplfekpwR$V+Cg3fDneRbF7a`-2ja?hb$x?emc>*NDY~DsFuSMQ0m>;}r zx8(+YZVe?>ePyUjwF|qkd=_^wSAdf(%vvMH>IRpeKlesz7j`I?qMU!5K zPc7|egbrJJm(r-CWKcr9-|PZmgWa^F-i1EEGmH!D**)+LziXP`?O>XGzLSJPH z6?1ZJmX0w48$EG*n}wz(3rq@}V$A|A?{ZSAV0|s5JoA-h!Qg%HBo?=P)BM%BBuUrZ zEdB_zwrGGDw}ND=g}#K7Z{@_vPApffyiy%84bQV7L*!%|Zy1qhVY`IW0b;hbM8d9e zj`kf5=@1YK&atrbh1#_y=3D`_BYWx@SS)Bi-xThN^sm!c= zitftXGVIMY-y7QO!q)iA-M0zi%q%l@-NePyrZy$g+K(Bi=eY!MAH0YvTO`&a$NCm@8gP!IM}6NES=gK0zt5GkXAox>>^! zx@3W=A()ugA6(*r;uQA(@tFOo*bsZ+TMg^}TB){3|G8c`<^*xrfy(Y}sA}IQy-Q3R z!#+^;@8^t=B~sLrdJ@2l0<{iD;l(%l;Q>AjV116G;p75eqPTlce(%fgHx_2Ygs`AE zIoykwEJnwjfzh$m)%IaP&Jj@i@)SLYqUO%|y$uFUKkeYuoI!Z|L-#VkQej2J8wqMC~KXtXRZ$z>Pt{72HdO-4f+Aak)q(;JAj&ak*wK z>hW3PJ%@UO?t)}L#&ZG;4sdg06gv|VlAxJXKYJaZBA30y$K6V`+6iOQ@%AUAY{3~i;}%0@jU_J0lAo| zO>36kHBybiB`~)w5AIh_0NI{zsh^%#U%uihad7bCy$$@BfRIczMTVwG!=+FT@RNyL zF@$aElb6ubv77T~|4^YZL67)BzG%U{s7EK9+8nBVHXQnu2lw$dZdrZ(e>P-q$xsmd zJd-Lf%_27800>}s@%mo%yEoR5?s2lZSG%C4Q|$u8Isw!+ed;tA1S6Ek@f;HAu2~S` zao~4Wk54Oc5Q|n#hobb{QGn`w3_uV^mnEGOrEnP0g`w;=%MG} zegM=46>KLRpu)h5qnqK(MVN+0YX)zHLG8B)hd$43&$r?j0>_zr$HY8%rkC1&%L1U)F_-LvPl)4jl-(wBlImdl5dGe*|J zHJmvREZ9(dD?F`HzK8w_!sh56z`%SomMD8&Ab{z<2)?no&u(?Pc|B>j_#Rj7R>!%=mN!)pLsf zt(Lqw46noQFFbFv8Q;GO2YPi@5E+{9u!H!pzGj}*7hi%?*`S1(Atpq)qJ$+f@c+Xt-&_gBT}h7V6d$zhbKKQ$8vrky+C$$(7bSbt`Y zb-suvLr;M50X|imNuFRwur%aGNjr`ClkIJbKLxgNea&!=ew!?dr~xP+AWw)!6a@Xj zxrbpGU$bM~8+2^nKMO7mCI7azZt$f0-8a{4kKy=cG|99nS)XQ?S(>uFEX~_jmS$}z zi*Nu*W5$eT%j&UzG75p*KML^f252;HxusYgg)ouZhWY!n6PL7Wc*^)PJnjDDAM)_s zntu339(d%O4f{Ey^^izE0gi2$I1N@S6(G(PA{EaAI4({4bSg6{6*vgIE-~y!Y?MJd zZ~{XH3zc}TiMK=Q+jVyMwzX9+Kpl-Zwl_TU^8~V2ql;EUE_yiRC#U+ii$4GX-U)s7 z9z9jB_5o48t*zBHMz62c)>qZ~dTkw9z30!jY4?28n*>kb+FPwrrg1?Z0 z$soKq2Nb7KYDf2K8=MZ$-@K!f=m8w@UOwA<_2&*Aw6i^H(avqdbdkELVmu3nxevpn zWml)!U{3xPAlbk%f^!(3~1kfix*^~n1=X9R|kH3JOTFpQisP`_O5W}aYJ2T(};ZZ zq!ulz4ZH}fg%PPm*>4q{804R#13YW--)RBgX#wA90pDo>fALzt2?_nI`oE^yMfd6? z_u@LgNil02n4iog-TK^Fz-cX@-M$e7!DBuLI7RWm6to>x&f+x}W0D;OVz#23&Wp%p z-V}BO4iLqhQw94CfDhyTP&j%JPtvJkMvSQaUE%Up{M zRTvktoE8J+hPG734?3-2%$IYzRLJFQGM0f%6qYW6-n}kiZvxe4L(k;3&pOSF9 z6w;-SBbVeYtF0k9SHL?+3hZXY>q)FOb0d=3{MKbVOYa3)OU>*~pt4)RbvFa*>@|u0 z0yt5s)aU|bb-b97N?{&;+r#wz1F@>DEKX! zeYVjP0y!?SeOO-ApJ&_J??j>x!I?=yMvgGIx`Pr>5QM~KsF7PvFx96I=k)xEHz-WPhr`?O{L_W z#?o2Li7Z`nHs@7NW=I2bch>e{{WKzngD zMx#q=V;GVju(*z5V=j%pfXO=udDI__LvkJA8Lw;|ryybyHo*Z_!Blp4Zl~+!Vw#&p z$ak%lL-;@CVH8GsA#OqPF_Un&f8Xujcl-C<{(ZN9-|gRb`}cq4{(a_;IwZ4FP`l^d$Os}5oRf21+)%KiP*ss zZR#bu8>s%fL=IljqvIgao^9miNICROP9IBr<)kQefq?j!kuo!up6fQ;f%@CaJx1Iq>^( z)zCuEnvLX}w2W&l6`wr?3LTz6WigJ_;9W2X@sb{Q`BRE;BqdtIa2S}qzga59^;$*M z>-dP;c!*=9toH|S1Vy*9lF%RI_gm;hqMwB5H0iuS<|elMlQ`;4#zE>UG#oOx-AsQp zG4-5}{ctdeTl*<^@fj2{lMRbPTX#{Ac0j0b+#2C`p;~xf1NhJqf8bDp0z1Jc;1?#n zWX9z+HQ^X@N#g=)oWR7NPyfh;W0PTg28>0gg$vgmf%CHn>M~{RPs>UIKWk|E#6ZR} z6oU|biw^yEP?dp$rJ+qd*{G(%m|n5Lb+nIR&PtGI%$&-&1)^hPS|IWL;4k^tMPTH$ zd`L}6s+Mw|t@;h+&PV=m$h&Y!t^EJ&eQ84*N7C?T=~r|HWreT~E@K-)vKX+pL~w zEm&~)fAs3Z4Mhr)r_aRvrkoJ2Y__D1YSae0`J&q|`nS2mfqStKuOPb?3gSw}8brJ) zJs)=Out(vw0c8dl`ngQ5DnKJK7ir*73jz&pKJ9JYgZEe31&lWY&2*9CLX-El2S-+3 z9-{`$&bi&5~tosTW(6WE0H$p*CoAS z((A=d^W&(K0>DHg3fykWuqYDyVt=PhyL5XS2u%mR8?uDc?E{j~{=+X6U_eGClu0FV zgN2exO622A8DYXK#jq+Otd9SJ^b1aP01K5S0~}a9xDu2x&Ope3jz+_w+<;vPi4|ce z*83b5o8=stny2lsM$N$(EzldLiRPhTf2VQ$=AeOzb7Z8jH1U+;ERX;x;8%ga7mcK& z36eY2sqp8D{9IIX&}+FEx=_wt+ijcin<^EO1S=|^r~@--cQj2WAku(dm>cvP0LdT1uE)#1mA2DaikY_cYQKz|vjV^JLn7}$KnjhNl z@(@GX=i2rhGr(*QEdqK2@KsR2Qqubuqqu0C@cBNp(e3tJNrwWdO1?DU{d1e+Q@_ zcv@Xf0H%7+wz&984?z>AiRLPZVTCloL7bF`oPIXX4A&Hm;RcKx*jw%BXuBM69@YT> zFNaRu%E)a=L7cuzjN%lC3xHU;i4rCSt(JpWpQAo!>%k{xc4fAam*-7{BJ+6kl#M); zc1ie^JTOM?JQ}agmNXzvTGn}A06qtDBm?_sWldy}+N;z;is>RDrF6tGUW>T_%mhR- zojV9&%<>4#a&>tTFU#yE5LLQ1g99<{qpuK)Ay@yXudfhctC|9FF0ARO=hyvHC0&XtQaY%(ZY#{&M> zQ1-uWQ?KbCh2yOQ41b0%{+MsIBfuzOUI0&2R+dZQ1NXJT|IhQC{-t>Cw17Z2ZD5o?{AbWy`DYU^ z24Fk=x3$CEg8F}^!{ z9#ffn+MY6mpUF^CXw!sR1f)Yox}j7&DGSa%q#O(kSKG1%WUJ6)oQ}qKa6%|6B{71X z{e2xjc^ZVAOw5IDRSeZJ5uC9$)0x>eioYroQ`Mx)nlG;{%YL%)K8wO{uTQX77}-`YEU ztKm+endh-aRFUr+A08!YBaIJ@_b*r>NiQ!^8~uK(@^8EHJBYmSrqS+nKF8j`Arp3k zJPl@(6(ins`XS_QoD?@@n3@-YoeK!rGXr1S7fuCZUI-l?wNin~*hQrA`Ymts937m= zHiyw#hfG9kAiIO=`&-u2RspT)HD^C_L5T3NzUyxUfln}NCg+{x7>Xw-o97bwJ4~uH z8`#->f#>`)#=;)WmqbQDviCW}CdL%wOYPVC{062kT|f(u$VVT)${y4|OCDV>0g?hR zSqWOL_05XEu}Mf6`OYj6^?VSmeza7|`rwoWF@H?&2W6@w`xuuy5+ShdPqghHC#!t! z{-J+|@GrIQUyGX4a-eYV^9Pq)V;5@yQO*q8op_fR`VhY1i+|5h*_5YZWxGLepjUS5 z<2prE4`Pa!rR4_O0kVA{Ubv{x-XO@>Dy%qg_=Kq9iOMc{=Yi*_o*<+UgcS3OH%p8B zpJ?7{U{V2BB8|I>QQnr;VYhUY>bR|;3VBJS%Exqzbaw7KU2hNogVO$}%h@H`;(TCV z;Ase-)gcVzFXict>VBGozT5f;PzO-Q>jvV-^5Zq}FZVe}0`5f*yA+J2=?t&&K4kIc zu^JLKxOlVn;>9*U4he%aFp91&#B1*gdjm&ra_={$#O}ZuO=Ec;*`y{diys5MN&%b_de753bE`?Argg@?atOEzHKou*j5YNkO{9&d@ zkr5093-X4J9Xsrwj}IZM$PGGmwq3`dGfIO*@GAHX+H3^@!972cjyw`XD<=e2B1N5s z4#aO`BR3ZX%9?U^okes<+@AjqKckwsl$@+NS=!p2>J%sH&`-md4o9attKzrw81b#$ zZp&1P8gq*Lg%OHB2GLk!^HNUG!pIP#r5yYhiyFFZ1Y=Ft9`k`CqFPi1n&4YG&lSHlaQj30n%=qi z{S%s;qzJk|O^sOONR)%132r%K{mw$Zi~Bb3?c3`*-@;Y1m$yt?Iur4P)tsuYU?>e zJbN0qZZsQ>#_s-$Mgvc4$Ru|~MXSlxryt|@Y;gp9PLo0=1!Lz$kByDELR!Q7Q-)-4 zgJk9Q{WeCsH?EYRA`$G4(6@NV;z-PGb=ba&Tx&dku_Ko2)u)Mfqf=U#pbe+K{#>p; zh4Z?!c{FS&B(YQmBm^PDh~$LFp>hM#y=l~%gkVf+QS#Oiqrrtk#v(&cjQSS?yG=bL zFv?aWY!dSfiTwaYEwU=z>aoF55Kt1sr;!;60SQb=NTO5zvLR~_GeK6!Y8Ai{5VQ_0 z)A5(=OQc;%%z6ao@g6V3zwM;SFCuhQ@Z?C~W~}g7RPbb*U!65#oZTKgKZfVh)LZn} zuuh0<%>KZ|l*AswU#mV_sxDSnlsg35UyV2UI@vz_i+5_!^{;Nf=I9_K#Yv1o?mMl~ zz#XDjiVb+{mt``%OZVcEd{x+rt4%qPp=q25HY#8kcsZlI(a0Qvt(Q^xk}$K}H^Xs= zf$W^3#V`$i2pf*BBb*!P8GETvrNHJHgYkQv+kt2MMBeincRDL z?ZQFSyu9hd=B!E~^1kTTOeW8{2fjy47kclbnOP`ZPLa8oASgx0DbiOY$aR>WXfPE0 z(ZHz;ott4u(vzJSC-EtA91{1UcdEfv?6^zSSXO~=O!H4?nqfQZXru&HH>^a7I6P#b@(WTJi$9>*1;^Vs8jt?SRA$=FJ)SZ2RT;mWK$OGgJdj0 zL{B&17#3zr6R@z27=^U6Dp1?>Ylsoj9b}{*$2kWPougF^ehZw-A4f$Ws8$>TiUEiQH99)S!(NqHWP6uEt1B;B3y*OILO~~Dw_p7Ek$|Oml(JW*O zvx)}!<2ZH$>_ReJ&|QZ)mG&Cs+I;PBx^@I|Xich|XQJL{ebwv2XBSXC#* z^Mve{hM~0T0e3^{vs!(>yz=3*{#9MT-|rtYO+qmfy4GPnNB3Q_LA;}qhk|(`SU221 znA4krEKk>7@*`fZ#tW1}`sU>M)b6ZJ*lr&Kr77N#g_Nf;($q{LO_=K5qh~`crfX+mv)5cS{21E1}V-Iv33|N8WMmceF7z2;ud=H@?K08n; zT(FfBYmieKPyHSotGhBN5v`s@k5HEz&zMg3(EltoehC=hBINh!H4nsD>P6nH#5-Zn_uT zwnETqKJgqd>jUDSRV}r2_!8 z@`x{hxeUs3n|x1BbgqK9RH3)3$eDRbR5=%TZyi)d@rt$}&`(OK68)?g8z86GxuSJw zkj!d?0nG`$)oChde+(S#x6{^r#n0>Jxi=__iPgvCX`Eg;5} z`1NPLW)qLAk7+yL#(BI?KlipOC=)-2gE6pisX#>#txMQ4w9SY%y`-1`Pz6tN*cXiA z!+|;|`009dctskFLddCSDgsPRj;Y#-72uJ*FG zrzyrOC8xl(H7S527x3&682=!EW2j_p|BZ-q*9HU!(hA% zoIV*48fQ_q@d!SB2^2ZT7nK*$c%>rw8L_2}uZ`KlN~>HfFnGUu2@Chb4~?yDycGE{ z7T~$IKykN%;y`{EYWX~{v^?4yiuqFh6YdXGVGW$&XwVaj8~HDJhKMmg0n&M|(Q2S5 zNQ-O9_=1-1HOJ90N9H^2O|@*bJ@PCQFHqlh!tAhC#(=fr6Ykd9uZ!{*?Q3|%TO#F) zCl(5|`ch4O?&FUy67rX#j4NIh-raCZV6z_o2-^)ON62kuvx+tv>K?(&3 zPRI+%(W8?ZPe_<_x4}}{V|ZG}e`FLLrrg;(tdS4s``G)DrmVCsWr6h~6G-{m%4gcP zku*4ss`0v0EQC%`#h9}CER_2+i3qA)7B+0OP;Z@59LWTR3_o|zxDVzLZ@nHpn2Vw* ziiD((@xsQ~DL)o!u0t!#c3Vj_-va#Uc}T1*)3(c839F7vVfNZ8PPH;cfB^FsS{tjF zbd!)c$EtqjyjoiPxf9dMC9cIP8a*0Of|U^oEuz&j%fQ9@Z&$+SBmB-lf7V?qY0Tu!{rk6+RzvgPP4ZL&FW zLE2MQ?bIvWknZ4H_^NN=tG(G|6b^ti+1P;CMh6s4Dnkdo3H)~j6Edwm4kaNR1PiEkqWPdlhUhjC`C zKXe~Ai~n^2gD7N>6+Ps_o7B)d)<%LCUeY`oRe<_i>0v5D5F??8L?{3l%tft2qHTp| zWS!^ohj>U1k=~x!oEdsZ1|I?hOC8MwNM`*rV={2Gv!bEV&k#n2(vXwzPbuzHo{&HS z#PBo9o~tR3j_Lz+hs=wN2zaUaHOiv2SsV^VC{s-s5-t}{)^PA0}0IS&8**)1l z-a9%yJpLSiMJXF{e?>UCGDV4#HZYNzp>T2dcfx>iFvmM&n?=Sic8^FaPIVuoO?m4o zN5^^7)>c;mmpg4%uVE>=z~>@x9%ZaSlDldB^YG2-(VNqMhLL61FwjdDJUu+zZzPpw z78ZhQ`gxE=GN7^Zd7--dZntDc9|&118?74+hXEs;c=2dw3-Nae6+`_%X~rCsI*P7y zT;kVT2YWAePXNoa=Y{f{h`#G`2G8D=lGV#mc9%PXJ5}_h&;U87#NA>iQ+FRk2 zPNLFj6_^s73CXCSi+_xv*U7Y6&tM{{PS1X%NOLePoLHda40WbGX>5F}OgNNLRRpjk zG8h35XvMlDL-+@03I8f1qA6HG)|sPi59EnqaB25_uYC)co6o0cLMF(76{O4JW6xyC zs^VE5T349hfvi>3S|mNE`cU#MuwXBQpW3;D=8(gD`(L3e5aup?Ph2` z^D*@Z>&jGm3EVFA@4UmSU|4?oTEu3C(rVn_7(4xnnPx;T?bAU$* zwRu}*d|=x&v{D-mJIafU^0aXT&l0P*&SCgXzYU|$TDIx^CWX3ttEnMPvW&-R%Q&;6 z<(zoaLmo8h*+U0s9K;)tl=Qm59BB+td5+n22v_Uev2htAQ+2;HHN{xt%HHYme1&l5 zf_&!(C^m9_IdxINcH7B0X5<8*AlDw)7Z?fmc9H`=gs@F;BH5 zyZEv9D3ZjbMTx!cJZjQ4k77zZlUq+n2)Az5IZqYsWN`y$8sy5~q>_g-qXvJGOt< zJ(v>qZI*RuKKPO}A8rlUs^>5!b>gO2TB~7m#Msqd; z)?`>x$n!y>Z%9wgP37W?AJjWby~J_lgBwtQ>SMYPsWw9D(?H^dm!ApdisUZrT-hCg z??_d={G(|QSqknY`~(w7^Fkt|QAWcw>0CMJkpvINK5xKA$|{`Hx!{O)Ef0=_zpJ1O zbK=CqykN+dRKyChw2(Q7{d|bF8vVi!hp$NH#8#iO?O+;rGC-t5a*$)N+VL*5hmNu- z*4Cg)h%oBTgUxbC)gZZQ)5BH6-0M!Df=83ycF~+};9`068kvi1h}y4W;SrV%wP{ZO zaz3~^YP;v>A(&>h<#^yo^D-+5(F_9|#m3BA?{T%b4*!cXb|tW#T`&=~V4^ZvvrfF5 z*|mCI6q5TA-p*PYu>a6Va~9xHFm-{h3{uG~jY{X>d>Y$P0IbAOFEn8{c_2h1oRen)0S#(3?RXrs*E$`4z+d@E2E!$Ib;tg>-!D5E!CP(3Irg-8v!4r zjBs7no_21PpDzwqDbD$B7A>lEDt5vooH_Eoz?*8jcQLXr@MhXaAx!k0K?TDQlBgkI zFSyc~XL{M``qH7!Vxu~gf@JG*P^U3b2mdtMqYYOYMq75Cw_gn@Ce!FkNVg|Tw9!;+ZNVM#Ihq**006OvRDO98=s zKxZ2LU$QW92U#L%Fe&mxT2aEyT(V4&SZA^%2mdvcHrOqaB4!5GjD)7RQ#Q~@DELX| zAUpx)=;K45h{N1N=+eJ>Ea3&5FqC?tl}xcW$%R^SpxH^4*=`RQjXP`*1ml1+K`P2W zFJk|s(mKUwtis}q(+*2ynjEh5CEI^7#SOy)++OvZYv1$N9{Tbt<$dhUhIIDsAP|yma>mRrZ?-^gd5__ zaI3uMJJ#G(Jab~eY4Ll@akJ@Zv&>F%nADMs?tiwX>}-SyPZG=D^Oxh9d#AB?iC?Nr z8qqgATdbXvjw#yXPwXA+o$ei+oNgU#?`Gx3fyR{MowE5ypS!xHO4O~)^fg$YHV7K) zPgKwnCwm7k_jkp?;latPt>fLD$r{iZvB#9{-k^?9TZ19}n0)`F z16J#uVJHkeb$U zR=wadw}qz28B@9}1a+yRRk?KAZKr1$MPr_tnUfBS?)G4;YSHQ9E{55$rI~mUq|9=^ zlm7=9&B@*tDSGyE4-mIS7rCvQo4^D>M?+!M=2JxHHghMaZ4llAGZWQx>KM)CmK0S6 zjy9-WElxlXIi(72>^FDY>JnnU=aSdk2ge z`0MZ%n0YE9$Qd)$F%uBWyu+4C)$EJM)kTZ%2IXp|CHZ`r;<7MdrrP@nnk4 zw4nymJj1Xf%M`kn4Q-^vbMKvIe^Rx<*D(KCgPnT*GdD`co$*Y1zZ4}`V#Xd#iYX)C z;}7JZZoa547(U$WCVWaZI?B?FQ>>GpD!goBU>xK{1IHVnp_;r;e5f8_??l-W5z@flSCC`qN8U_YZwb6CQC@u0$IvXGNtEJ{#~Si zWfmC*mzL~o0#$n?4_Xjx^0yI&uF|1Eq5ZZuFrrDnLCk_BgQ=$*O^&WF>y<^*Y1w#} z@1jT106n7I9_8kcUPM(7fsg|?U)Zygx7%}vgiBS}doJb{WLXIB?UUWKUn=f3Jt-Qa z%1=rF$FVYIHSwNFC-)EzJ(%=!H6gMYuQKszzvq_HxbduvH(^X-juKg-g@v@$L09#k ze)@?MP5Q3Wb$V=gIyWbvb_L$+5DU zKAb7WFmTYj+QdN9L!}@;Ba~u_#gq}ABG>gmR0itw;8Wf6#N2Dy7)(wNqha~>txwkQ z90u~1w!Tl+p0LYrVP8ARbj8ePSKQyh)SC@7sw&QchSik^clk`|M*3wykhd$L!wavE z;@3cJz6RiX=VW(m4R3N8{dTqk&-qiYJxMk#`I@?Z7hP0zh~ z3#|A_m9qT4Ut0WNCJcUJ<`k|jLZRi=4_Svl;+JJ4w8gBmr(V5rtDBCbcQd#{Zd1Ou zGh-CAM7&t8!kL>LW61IHK?d~lA;&UR3hPoNP2*cfY;PSL9G;S;q0~2^qW0PmUH9S= z6Xf|WCVN&A4CUVo<#^J8bTPJzN|uZ<2+2Z_YoUp|8ZYKl=FqP&tWe4+j@5@og@Ha% zr5EO;eZR`#uPgx7qdTmLI`Yc$NxK>f9ayU=}2utiACj11?9v{PjC_+cn0Q2daB z#%guhkV8;hR1yfPCdOr zMe$PMiZDT@;q0+#dVb_1|IOtwav;)kmDy5-0_of`LqLY}6O^M#wr&bZWYfZVzxjM~ ziw=I|rNwsiz}yV0ce~B>JvIJ#II>dNpibpNC=Qsp{Ji)kOoaps#XpJ$_m*+XkW0hy zM5pJ4BO`O-E-Z>$!HC<)j#&-Say0jmD^I)J1WS2HO`~|Na3+1t@TE@4V|9jx z#M!gqELG`XM2t(DeA`;YI-PU0#)i6-suVxl9XRc_Z$%%K3_gAe*f6kp5CS+`FXfDc zHZ=%LMk$NV?o1F~*$B>1==up<2*v|Ra~w!Qq1hYe^nty?LxTDP#iY@u!eR(}!fp&0mZ%C9B7|G+Qs3ROrWf3xtDF~BkFS10`KHMrH!D}%c)-TwD}8rLO@{7DH>ItHllyKk`OJ-l`f3q+%De`F_ zcaSaY*3cQa{?Kjt84N7DVu)$wGtOEmw`($7X^GNLUBiiR04LbmuR0jkdaYdBKdu$k zGG&!4hT>KxHm9>F$m|J3{m`}s$Y#Ic{I*&2KX2CO-)~j^ZC8H(uwE~Ht}lJQh%_Io zQTtreg=F(o4AHK^8JtkaHuEO)#|n^UU*@DQ1Op3S*P3Ijp+yiCH9K*ZH^NRwo8_@D z)HkFcHzy+#Z~_KQ8*aNjUsxL!%MzFyf<;=Ft_qb8r#i$-Ae2t&+VulhU>Tf%?kwSq z#PD@BG4EC#K$dl@Br2ThHLtWE*qYP|p+BfSkn!|5jXeRPQ(dUDs8->uMweQ@1Ks*) zYX{~5$-CYFl{gfM0jt3`m~;e5sejy|?{v;p+Ht(Es;UfE3F{~0C?tFgf++a4jhd)k z6wmUSyvUiK873e>0hJn!lij1O9zJ z>cbwyyOqrv?SaDf(UDBg$H5Ehaqt5ywush0~eXld_j!V1tWH1{!VL4!o>(XHR$^yIz7 z9-@I^K5~7-_$n(#yAak`WFQC!ZcqLwGFxDt-3et0&Fn>D$4RG9&*$!=i&mf^L3_;n z`0bto)sp<6n18NVIzB;W3dBpipkKAm^`5oyMSS8m(4iXMQtWz^cDxZ;A}nsm z6`qHes8l+5u_5T^k0^fPuS%svKsc06fj(k*f40ulk5x+*GYf9w7xPol`lClmbM%Fi zu6{D}NY4kIgkGBU&EWu}<97H}5STv(GHAC_F^c8QzxeN$ylx)bpn;+fIzA7a-`?~4 z577BgQR5SKcnPZzIZ!==(qD>9k+$CcOT~f5TL>V(7`LbAcq6}qSp%IuQKKS=D!?qa z*K2LhuMsPv>bP2fvM@RnTm0&DQp|LWrJgsV`uLw~2~y8lh*}_`1Ld57g~9uS{pFLR zGabPo4U~nRf!ak-{y=jye6;YaA@6i3va~PRj6Bv#O(w?I=X`a1gqMXvSr2?KAIla( zZ$`cFJG86uFT)Rb$V7Oi_SblXWgiUOHuO&3O>B;OAAu$J^3uq;F}&?NaH<0$p%k$! zTyI)IkO_2*wDM}A+MO{|W##!)17!it&fOc`s8&~FhQ)?bL+9sEB?kmFZ&c&g?a@Hx`0SzKQPaHu(eK=rv7!?&rWj3nsIoLdb+SMoox>E0 zz=;cW|KSDS-+NA`1HA9|-iZ}bVuJW8JC0qF7UmS_1ceP5&r483Jz-2Y^&MNvE5*|U z9VIA5KCj}uy3CkJTU_HS-|$4%d8eWBDAIZxk;dl4TNEo%1RV8oT9>N;fIxr0&mLEA$}rQN4$Snj zy5gqz&lq~# z>G$kD9La_hc@ZZExTQzARadHu)qIAbE#NR-W8ojNk}-c*O(UXDtXeG2!S6=n<-wb6 z3}zsfF*5PIegWKi86_F{;`QFa;W3um6wjWN$m~mkA$^7UVh-lRJujkSF~M0JOaCZh zp%d04_Wbdis`$lb=yr|w!91+P5oSpRzMf4{g4B+DisNwVyc5-KSF!RvnJI)Wy>z~G zaRkR+_@yAwc`x2tfGP^JseR?0XLsbCkId)`D2E2eaGE$D1rgn&x*<&73?)@+8-##f zKOv!g4ljV%7$eBr%mrzlaK7O5g@-Q;WH>01r3Rqu4>;T(kCN=_U~Ogtw}=+^T8MzA%O7Z;xd>4-g8s+LQpx0+vJa;*p+$b77PbE7zH zu=C1%RSDRNxmSQtSN46pN?H#heA1N<6838TFGDM$P(fzntUgqOoV(G5ofF&40Slkx zmoJSVLwBYstgez?9!WMyyslC`$+G{eyTs6z4)Gk6k+q{haVSUXY9?GQFY@wRvE(|ScxD<+|9!l6ntC9?mC zC3iy$A$@xTT^LV|G3Tu&zdQT;bk)I{4K{r$%rlmiYSn5D@DDEqqAC%p9?zgzQ6_plI+NvlZ*~Xvsf(C_;?goqB^+LNt3LGT5 z0Yp?`7up~~V)ZllM>foD>4Hkpiyu%;j>$?sQmEm+dZ&u&V8n<4+%4I(Dyg1T4NfR) zKe|aPU?`-q`vtn8ZAm_@J#J^tnX(JzGEmg}FQDzkZ zK&O+oD7XsQ3qVU+;EZVmO8bK%UsMYbJw(UVVLDGs;xSNezrg5hn_f_scoOf6P@*V! z?+7^3vMm}MJ&Hz{lMsF8@LxKv(r2O5#L?Yq4FJ}PXR?%};by*KzxKZRp;o~=y?}Rw z7(!r(nL>^WX`h1JT|i^(zH5aKhf!6po|V^b@8#QIQicOtAI4}NBJ|x>uYQ zSdnIPzF8anVCyiJ5ztHe6J@+>YdoNDpYxuQU+|btBe6^^r z718BT(viTW533XmaQefX*as%Qb9kboL8HZ_%|}?id?8DNOH@ugt*!`vcnf7nO{UbS zy0grQTJq|Tulv)rzK}^PVVT?Ma~=L;0~UT3bvOsvmEX52|Nc;~m)1Xv zTAi(6WNJ;|JH@l`{)toVpy%l0h6vFuvw;bvz4OgCO}q6mR5Fx}i`-pF(SX%>spos1 zv|;$Jgt{oDvs-A z>wY*#^ z8lba_qr5g`Hk7J#V0A=bnHJXV@?MB3Zw$SdG|3$_+0r zu(+Dn{11yDhTNjxZJx!;otf4IiOLW;%=gPH6lN-bhJ!JT(t{6Z%$(rT5JEHwwNlX4 zwEod77wJR=KnFgp4}nPO7g0&Ltlvh_-Vjq%*YC66NnaCt844d2n9+^F?gTuDCPSZu zQ&W?&;tE+%;9ik0U?t_d$pNO?_{7>;Ml+;nW9nr+D7vZxss$xu?^dfz)ul)gcr(7= z5*5aE8#d1zN1Ir!t_jSSh5TL9kb9dR<2LTnc0Z2(67ruaVMrs421a9Y$h!LP$SI=I z!WiVpauU^{sv_N#^wu^@z5z z*CAB!;SkrR#b?uiu<@YMeYEj@t%Eo*LKkVW*pabU>TotPu2*gBy6qaC<-&#?#qY1&UttNqA zTeU*QJn0)VRZ0&iZIIzQ0S`NO#KX=6cnCQ5%DYzQMsmdJwc&_z@(N1*uVU&1_|dnQ z7aIyeS}osvY25>2WMae&%Ra?=Vmv|dh+M`7&Tk`kAmfivppPhG{B71WtT%aeRC)6b zB?(_FaB#{6;di`iIEalHkzN(GCx8q}! zg8>F2Ba2iu@xmT@U9{Bf+@e*k0;fJVu+2>XD48-40cYUeykGgN?C1X$!d6s|w#Tz3 zR;oABxMxYsAMKX;s%3ZoMQI`nrg2hQrZ_b&Q*h#;+9)ETE;;n9ki3 z+Q=XbVQ@G=jK2`tbQ7Z2^lSa6AmropJx6A=hLZlZJ8WH&R4w**7&9s>%byo4_*Yn;7b;ymB>Dp%?Kc;9bzj0cq%EJMf?zSzAR=z;IO) zYpYFT0Q?jO4iy66@StI@t(s#fWe>QAVHhi2jF=cT!I(r_Quw5Sewq5fmo9@8Buo*0 z2uZB!^;iSREST0f%7zg*4Th;*G0;L`pJ<5JX=CIo)C881AGW;n^J<>x%L0AF-NBDo zCV0YvNf!<@N7%Nk)N2nsw;gAQ=(&g&JN%urtQdSt^-z|L`bInqE1ZUvMXhk}$epAa zn@o640nkX@41x*JDJgTP_@Gc?)Z>)loZOt83@~iLz@aSbM0uJVnvR7-GGL|kHUUya z8Q+WyBc#&}i;{FINWrTF7Os|%pINfnp-5^@w~6*4W@a3ZL^clRCY{bOAWU@m;Zrx% zi!mV;8QEzLyQpD@v0Pvrz8Xjn3Y`IUKQ5rUzXB{2A28FX%8(=9!N1>Rx4RpkS9(*~ zpJ$WY0L!6~(GcZzI1!`N-$%mFc#iJJJEs`9RRT3)-(|p`Ed<_Juu5-iW^3P6(Mf_Y zJVl#ws`A=q*ODJ<6dB;Uvst&2;=a{EXsqXRIypSXNK+9|3aLA%Zdp=%;ow{pF!)kb z#1B6-wzhWI? zij6jAlN82|>+i;6Krmo8cf;WWy*tnjNr#AHTM8OpI61U4lu4nfqM^WqdFl{R8`zs? z6dtAaE3l%@2u}Mo@ks_0o%cBl-aL6<0k93)EZ_Sk>RDw`FD#cz8^Zqx0`4aIPJICo z81dsfd{vS*ruD+2E`t&KisFZ855u-8bJc}fZKL+<`<(c&aCzOb`}nKY-tcSh*UPyN zXwU_}H{bud`C*{|Mfo=r7V?u-gFm%j3$=C;Ko19^Snm}D{NLF)1z03>M!}dcOGfRL z&Y=`w9ajP;9oL=|ZR!Y**I#YdC&g4uVdM1(h;)_=qQ1ZWC}q-K;1`McgrfCT945Z& zICv9@E(f&fM9LS^&%8PCKBDg_)@xyM5*-ZFFB1?p2IT%!n6Edz8x&NeJYu#W**(TA zV;6UJG?L!G{NNeuvY`8>rw1^oUCgejf|Ow51U=aR^Fc4prw~uN;oOVSNjz|d&rf#5yj_JO zPbrv5eN*wbQLd(p4DHrB=M5ee-Iv_;3^V2++HLb6ORGv9fZa55HPf++0T zZ@mNqE_nGrW{Net_BM*%oi@y#LH6*3Ck?!sE~@y`DPRUuRO~QqS+wZ!yRgnCq>pFj zy=r`2HKj?g1)}}>fRuDrI(k2w!}FJwlX;T&Q<`sVbWJAoQICWfh~m@XNzF9!O^Xk~ z{XSojiO7wFWC$oMI(q)b*pKM$`(STB!L@^UK74(&x4(PL*45?$P)Kmy3A{V{6yo#<%6$oXnI6s{ z8w@r*rsX(|OKCgl+&c~w4gD+2GK7H-WtcUJvZewv%5*Dcw6%W&TXl63!jUa#WZxIW&2n#MGy zBWaH_5)>kt=yBiXgIKsoO6iVGd#2JY?iCvG$eK8T=qF%q+A?2K5fqgSlJ{EK$m64P zItLk>DG0O*>mZjw0a8I>gRF+?ijAwnYz-?zuhMiX0Sq1UW^OJ#?#BLU<8-dfRaBT5?*(rImrwaS>Mh^pQBW@`i(_a16u%n1XDW0`R6mVW{ zJ!|Ni8!U#pB#fa1VFYE^atD5LYi_sev|W4Xu<#_?R4s<$J=?w8;UzT(+>bJ3$R-J0 zbTQQ^fr+4EwDnO>-{j7gEo8hx3R@ez2KTHep-3JwRo5*dVL501M{C3!BpA z5)#^29d`&$Uob!+ts5GqAp|nWAjynsCPR)=-3l-iE2QLe&FGiTv6R*?kT+427Vv=Z zN#r}D*>(r-Qi5hfuXQGd$omFn#mf9h$qe0=E)z1alE7IKHr}vMnNK$9)=_FBP|zv0 zVYk~2uNV6$0mfca_YDW!yvT~?8EJ4I8r(OCT}p!tHWc|P1cv{NhoExc1=-n7*G*}jiE;o5j3*}!iuSV21K{t z04if%L~Ra(#zV|X$-rGEqa)io0z=8|pb4yu0y$7*6;`H)8R>M|6r*XC{((Fc`h7b1 zLeJ-19EfN%TK&$*$N%Lq+B>vlZCiOxWRR!M$@QBrZA6U!WY3K6ceVyhzy;ck#tKJ2 z1Fd*4(>=zYWW1V$+-<_{5vOyesvbQ8y~9FXNO`}DNJXi!3gpJt_usK01B4?KY0Zy#JqkR zU*YigF)OUfsU0&LeOFKv(Qc0+@v-vRRKBf;^Pq&j{f*L3N9px4rqcRQiF>8?0Zyb5 ze51tQm*%&Pot#1T!^N^Fe|u`ukV5|3#++x6FU4p~;w9gukgjQ1)7{9{H?j1aSo%#Y z{jU^D?}H@xS7Qa4Xz?tvfZrdUFkma+NWHgj3I+SL`tQTh)}_q zi3CEqE178X5>I&GiIpFB;87L69eBPjLLrwigH#wL?)ku@V5c8=bcw(7fkzEu%z?)& zmVMv}N{*u#a_!O%Jah??_D|T*Fnr@0#Pf+>l0>gb!mb_RZ`!v*Uu&2!`EG-MmjVa! z?V}^c})4OmY}g^jzmc1Pa7Z7y!`bI)sxe55U# zOX>|8r^$EATn+E;Mm}MHhLGpL0zbwm3o@Pk(*_dAIm$FGR|KY%jNC^92gtE<# z#wai6PL&HruV*g+kpU!BE&vkhi|k!Cq-aSKmeHvYtaND6l3{4+^%jjPyx6e^{WFdY zxPvR_SFYcLO+CEbymZ@bhpzY0`@U>?i<4ajX8LYA4$4Zf=r&srX>SVWAHuv7= z=pvCUhk%%#LB$Y7+mP&j9-%Vt{S@RUns0Yt9{FS0qHaR(mCbV)peCvtN%?<1<#Pta zdBG4H0mvw{fFN(=156~Vo&E@9WB^1WILr+UG519l0>o-}S{)CH@sKuf;ql8CQ#wfi z5s16o6_R-+O{cDZg8w7d&ukbOKXKx^mBNebB%YvHR<|sSpMmUFh0ct@Dzmb0g6=m#_nV;mP0;-&=zbG)zX`g3V?kFj z^y%f@teTl(uc~-I(r*Cm;e}w?)_7UiC`f{w%$`Dj1J!a!(>x}CC2MYj8-tkMJg(ZN zo-i`N8h!40r6ebUgeofYR=UfOI1o6&otz%;9np0I{}h#^M*?pp z#SGMewF>5B5WvvvSPFcFURByob97;a0E8;1Rvh(MOt7Z8K3042*72jePQIdI3V9a}p5`rUu{hqR{z`NzkI18}7f6)E$jH;@F`WqSu&VO?e37m9;N3MYM(^ zTH>a|m)$cNF0jK7rl3&%Xz^4z85@0)>Y-ge!z>n}uH!Kdl~h0}Yi1{ZaKI#>)6B=% zx{=8+FN5Qwz=Xo4`<@PKe%KRRd+*8#NsW4KsgE&UqUi)3XfUlG1w6oP>}4H-7UN*q z7@Zlhi1Se%?QK_+>4ojytjPTk(zAs949%_^5=?}`9B&-}yAP8X^fPxs4xkWMuwusJ zA9Yy+WLBL9E-7l4Dpt?|M}pnVLwLWc(k%sD!UTfSsaGZzw6wG{Q!2H~ym0&}P*=Idjc8-1JS!bD@6@Qy8{L$+70dGNE7TT(!NbgwzjNi6J zr3GK5hFIHP#1x6p1*%F$KU~jCGUADY()#BZOfs3!khNC&qBq)l;f0tvjs`l_A=lW3DeMoN{=h@G zaBna^c1BvwWO4s@UL6>HKt~PZN4f^#@3Y+rD1X5b29^J9ZuX%)lLxF`+->&UJk8GF_ zYO#nkD&OX$xoGof3pTp~w$O1n!!9hTieP`yYEiyHbuEAsPf2U2z6^hH4)p0V;>$=% zZl5zVaMUXCL&xp9L%(|YBaZ$D+sBgyKDlW6cyhXfDoP-zQsr6Z3_JwEs7i4ieBoR< z81aF!Wdp(EyumtRepLxBh#3dYyVJ60wJ^ppC2iCy+TrB@&nilPPj!oMVzdX)HIBNE z`uhK1wjNa$)&UUfAM-F%O2@ z8#$&CXp;S>8@KM{rTbTzF$f|1cF&>N^kFs*VA~T7(A-@`7(r88#$^u3Dsy?XouSjh z91SS00@1j)CDGH|Y8YL>>7H&*&Dr!vEhJw!YPXj>qk097aD9Qic$jGdPvzBom?W&{ zn{Y7yILjKeF?!e>yai!OFmnWE z6X|0Ll}OWWh9xjIjnp_a3}c@3a3mp=A$DT4dsEVQ5`2VEFJtAxHq1!?W>R)a1``#} zg4e{8zLD>5{zkt4SIBqZ?=&$*B@|yr!dE{dsMqb{dfY36Afy*w-T-3j<3jTF zY2hbfMNbQO`N{OTZpl3XXzLDd8Cmlujsswsj8;3|MUkZSE;_aVf?|2g@Hu~s^c~sM zfAyhTu4e-;n{1%1Lu8&j$0|i#{(t7=n>Tfb4Gx{#!U;jG8zrA>jCztavPTJi%X6&0 zhV(d*Mj*PH1PNc^3qz(_x@9^`k^@z1sA{EouW;2!)J0V(`r2;#UI%SLqTiz-B_mMf zXWs!PY!AIb}p(3;}MLiBBZ;84&uy`lxwGza#%1#cfy`e1^}pK0P4rlT&W0i9<@)Q<{=?eQca0@?F10)#<%Io zA9B9vw@UI1fY7fJ#kd|vs_e)tbsR^D%;w-Nu&VYgasEM1sJ5~fjzFJRK9&g zNdv%PPCdM))bV!3e8>IhgjKkuJYPYyMuP#c`_8Sj+u|gV=#nY3MF!F+a&wXhm8o7C zVPK>tnPn1fx<-AJQJS|HAa^KZL3c&d_9+x7NZA+~Rd!T^uI6K*43ns-8Ax%P1Yc4f zQFcQ#BgAZ(S_0;&ls2LCMG>k7ere!F+O){R3MQ+eCW|a?to)cZf|ysK252J%(2L3t zY#x4;*{gQp{fEF_Y<{tXNhZ0q&X8=zD0=4zB_iZ!WEN*%TsUogb|L!}A5Sw~t)$1I z7y{M-35)-u;ITbVYzIg};tXsd_uR!}38~_?tNHy?)Ea-nKNVp9+t!!F+PDMZG==Ab zC=lWv1W1~id{RFVApKyVTae zTGPYNh>axL$+aOo!ujU|tv4Ft{@qM)wao{%Hfb1QB}meo_O}plM2oE?LaA;kM`)4q zdTxl?uVUd5Ciwi(6dLn{#dx9IZI#KB`mn!)p0UP@mspow*!kzXcg9yE!NaDR?ZGHQ zY!|_@!I6B-N3LF^-97177zBt|AkRpx3#tg(agwr#@79AN($}6j#%G|;^?L0?@Z6%yjo<@6mXwiU8_vqDmj0|C z`=fz-eyiWhM_sL6SA~({MrJs8Iyab68buw7_^sVI zNZ3K@LAo?taZc>Z3Z{k({=iB)Dfv2`+eF_T*kR!d{Fv`e1RyPPk^3j#7o+w_6Tt`> zPLAysNRKegQC~VMIh)cL|#CRbvpW*$zP+6#OBxn`J6i3o=Z0`1O zU^8;J>;Z^?7b>`k%CSD`!;1JEOFFNw8)53s=1JiYpAj|<=VacMwkXyYmmU|-LPl*9 z!Z-^Vr|`gJRYkjiUsC>ep-!rtGl7Go67|8r*FUZEPnF_lzz5vUaI;u@|7-07{%@gH zuhy%zqQ?Af8)S9#F>`-sQznE=Oc;bM8CljCilS2Tg{8y=|NA=p_kHdA3z^bf;LHMf zjaCTEObfbyu&yF(Z9s%P7im?&2nb^U0$R3I!}_Ykq0eSbA3+#YPga_nX)MbMrs9wf>^{5MFMj9BU&Mac0g~r z5-_e}TL8mE?uh5cN<}7?Dr-p1(GZmnwp2;@T8#m+K2jY9#b;!j>0afks;fUoNs7O^ zw7HP&Vs9`pSb!9KJ$Q|s#2Y%e!2+>m*yUr{-zk`IdYr9uVx||6Ip`8m|`p-dOHFu$XG_2AwZmS zZ`30~%=uqKcOChe?7(r(`M50Rp&O-O!(YnR!25AB% z*^EltuJk}CZ)0N00#M$z)0a0kKG}@JZ}=gvAfN=6HH+v|9cv;B z*PRL{_rsqB`Lp5~_UC5bqL&_jT^I4~0PjkB6?xB9p$i5q62AWmMx%$5eg9M>*hrrV zT9AoavW=`8F{)ePA{AN0Xqd!RbD`M=Wq+qkwk6x!a9--bcOyBN)9nv$4FK=ny%T$Q zgMeAHsH`+?aM1Xpho0d`T06tmd8Ku8!}MfNCBZQO5qkFE_%?JeQ1=Ur-iEC(9KtL% z;Q_Cst7883>mZ{kwMSzNjmhq{T(q~48=>vCQHYl}Zg_;pOQ?z*ws3}3VRx$ez+ayo zi>v5MBav_P4}^({l!Hi*AvCm)t5HzS6dYTy1Ve3*;cu zw*)X$xCwRMK$@vePQ+ub$)w30G9{(Vq;%LaU??hz{w$8&4g^h?(mfe%w2fel(7iNCBYSmjLjPIhJ^yw zuiGk4Oq=k2-OysxEBltDHpc#V$@kJ3TSaaZbDHPG(c$sw>)mynhz?Ro8}^9b8n~>d z1?;-@Mgz<)I&`{4pSA&AQsSkf-5SC!18Ujw?-+g)QBz|^SpJ;Fk?}5IBU(QY{Mu|j z!8<`^f=fwyZ8+5N{F0yVx^nXc#O*r+Ig3ntWJh$BaB~Ko)2FnE$6L(nE#&kTBl%?a zxwo~pS~g{Uik(BQ9&R^CzuCN16q7Xb*HWb)f~Ldwcsg?=U*wt`jXIs+Y-f&-kYtUIWYqW^?u1}$ z?Y$HJ@V2ANRgtn+nu8%_-NU1bWE4FWF(F8yDq*N>d~I^JF&i}}Fp6+E%GK)o<&_Vg z^{?sz{(k?Mkt3&^UOH`U;H+%2Slekr4hpIF3p5M`C}U!APv|mIr(j@h&QLDow6-)C z!f9O~9UYqE&;g3{JbEsgl7z7tDaKF-Grj|Gr!^X~84KmBV*f+Qr4S$JhNny`3?dwe zl=%qK!)Au+U0;e1GCw(=={+*(9MWAfG5dgpgp%JfgCA(M79S01eJ$1(oE~nI1aJwkxGOs@KIH?%l}ES*RT+69oOIk!Mb7fMh%VTy zOirFT9ao|UvQ)Hy5?}zwz0MUaTZ2xnM${mHKogqN^Fmu~;9%d$ScxHWfpz>t#6MEr z>qLttVV!9MDFN)six|dznDS9Cnzq{I&C`=Q6a86%pkuPkzKbZur%&d!WP^!zbW+xj z8g42W$b^E<;i9%2UnVieoXg=MnO2{g7LPg6SN8QWJ~w_dVHtfW3u%gFC=oW8lw_En ziur^9j@dr)VeOw?e`I&IF391vEPj@X z$j8;kw6$$HZf2Oy2;^W6O}Gh#ny=SSj(26r(ApahCVL&P1wsxETcv0! ze};Iu)AgAVsS-gbM+T~+_cfghmrYyogk!)Vsz%|z#C)Sf(yBV)4u>3}fOG<=*0E_@ zl4YL+3p_M8C)+Yk!Kt?6ChM4PNkT-Q?F~gm=Xz(fMN;9>`9+I^o=py1d`6uoxvW$U z0fVUns?R2~q5SbAMX=5bqiw3Av#q#9jC?aNu32E|3^3Y;gHDT+bY0ze1XNFTP+ld&O8DErg+<0YNwkCjT;816~ z$+(XsJK>}=lVq5Y-cu<#X87vD9G~yBH`Nl>_PVseUZAGPt2CxsN|o~8<;p3guzY;@Nhtz8HwmrG8apT3*(Yyn`axViiLId7= zZlC)abZz7hFmA#+{v(stFgM8FdsI7b@{NfuADXiIx|CYhi%eI{pD5u(rl=_tD2XZ(IFH%y9b8yKGnA0=vgLx8O zuSafkilS(WNoj)7B;wCROK~jJ8ia5_N(!mG!vcKkc}VIkSu$mrtU6tx8AGy)Q!QH& zAi(5?7S1Xr-J&HffU2K4=~kk6b{A%-AP`Rs@xk0T7WjL&S{q-tv($0C3tw%0ni$(OGbK?Iz-|1gsSPR(GOS6{*iX7S;OT@rZO3;8=o&$_12Y@I8z@58 zq}17D(*ra)umNzwYENgsl~Y?UcF&r_?GP*lNI8R%Z|Lc@i#@xI>_tTM_L)0RMEJFOhecT4fZxYQP<%c`r#wbPY2M3cP0SeGa&ev19af0 z@U~boggEMI0NF2v_Z4zdk=fd9n7P)+YQ|2PfKWzvjM_@1tcE2jSN2{X?e9Hbw+a{x zx)Fk>=pJ?)=gIm*_jI#p_A7S$2BIe24R&^4AO}BFk|6#E(qOS(EP{OfJ_nL@t%gtL zm)fuO`Hd=w+#qqcqaS_zy88~TSx)Moq3_3A$G_A|Af^K_SqWOL_05XE(T@l#II~1d zS4+DNV-rOVff$iKX|Ah)vDQWefV7KAm{Fq=Q1CRE&~^l7@SK*mi z=Q;f$I%H@xz0Giw=k6b&XN7X9qnZHitbb-q3XXbK#0>Q`f~9kGB_pk0NZ!SLsso?| zqKwXoh8tfVrql=MQk8*WW|-5hmp^YE&zm7kP)q}f>Y8>z8L#I{o5kT^#1hzq(MBW@ z!?3693I@#A?n(NCtwm#I^LA@pcD**71y=<|RZ$umEUWC(WI;Hf@I;c+zxB_XE$ zPX8I5zhT3eb6NEC@NmD8TwZ6|2r7gbCNWJ|U+42eb@$zFDQpZPS*nQq7w&5qJii0*C{%7(^$htM%}} zy1-`7;hU96nZkfXMU`eS(UEFcuy5%tUdLmInf0XN99#Rw9g3ys>R_0K^o~ZTMp243 zIVEviJbDz{IjKSc@0?W8g8>=x$6Z8^@WuG#rtQ!xWp{s1!VAlTQxFMx;huVOKtBirdjn zRY8zQu0qyJuQ~7x+WqT;uj_BH?&R9_;X4MkL#3sZHLBGyr`f;1)DsmJ(nX%J(g}$` zvcKs5gpZL|v~EF<%ChnXnYV64uKVKE>(&|B7V2%1IgFwTdy`?x zn96Y|=ou_^BT^!trPOd?Xv2liJ^KQFER=+Tfr)Ko0vj`(UUCTx`VopX5nbAN9dl*V z{3=3on@?n0tVL7~XSiwV$+vy5FDU^H|4W;?u6K1kwu_aVO> z*UaEp^y3>+6+_qpXfwH@OF}j&t3GcKXJyH%U)2ZT<1*eD-;Nr4%6M%m?!0gkn z+)ju6;$Vg(RtLxY(UEaXu%)s!Kc_QOH{E^YVYC~b7HqxhX~!X|c(F?!e^ z-8?gTINo&OQ8O`OK(@ER`V=vLGCk?4L!Z0l5d@h&Eg$|-Jl#p+l zcO{kTcr9Cb&`Q@2wvU*Ul5KBCw4XD$l4kC$7>q@iwAymb731I~ z&N~0z`EdOQ2R^(>ZUCbn!Z*tL`}wozUS-{o6(f^=cPI4wbVZ-kAzhY>)H)^gsPYB_ zY0qIp4vL0*ZBt}!SPLXx%4kLfX&!jp2r$^19k=CTKpxc__7V?|huwyii!0?6rqJCH zXxcJT&Z6(}M8d0E8AtTO8LHeZrbkuCmy&_CNk!*i3=Tg$BdL!182=O(O+`*@j&;{B zpDXjo%9U~EGZgz$J2)>#1hv9K^#3(3cp($8)89!#D|0u$hDKT z4P449rf>GhPM^rNaW;~WpgC5-asIn#MS{L_Mw&f_YKNS$CXwTiZ7(e@e5Suk31I__ zkgsurx~Z9bZajZac9?DTN6{<7%YNTpSX*8AjArYx`@qNzUEr!dmE4d3D>RYDd}nnw ztE;IB(}W^%?PwO)o}eL92Aayj`VK-vnFs4_5bfe_GGy*PgvZ=C zsgVl=w!U|g6La??Am;8xGR!53gt>>11;27pFkPLLA^hd0kQ354WG>DkOZnUwp)yf& ztehY1ZU0FWGE8}rDCKn45~j@imypr;fF5Wte;%!k4k@6yfp0_D(_%XIpC$k(*yAN{ zw}%nZZr-oRh)gMRU@lwu%S{@cvmD6a6G_0iIq}MFeO#xIVBA%)QoX?lRp^6)7Lh7v z3GTdRknU1D{$OMwgtNyn4$E=XFtQ@NAjcG=L-hJ5^9D-YCFU35V8Z{2<}JdJ8=*wJ z4AZ%_IDY3j6MUqWz*UASivpSN_!#(x!aR1Jt~Ve!P|zQBiQ6Gl9M~6_*ax3wPD=Dk z@PvKkxou)%G-$x=j{tB0b-ZpF;VeI16aR9bSL}{^ftk{b&NrRmHQoR$-aJ-gz_u1| z)?U2W=EotiK7@moTF~Tck7DPJ`pnmi;oBYG<12ih^IrPR!N>XKlJNU>3q6v?sDpz| zIgw%*aK$t~2~1APXMj2bQTTMcb+B{zx>6{75#Ni|#b;}xCYD8gK`gH=FRiYMM`CGZ zb$RK@ljWz2XNH4CswEVPBNktpS#fKgbPHs>CA-I=Cd9}sXEuKCGoCP7@JID!xOK7sb{w zioz_7`fa=b9XJ;tx1a-8cximEp$>~?9Ah~dThb$rg0I0UtK>o?5flSU6wyz$(iCX%;4paryMRcf9vbCh3v+1%>j9Q`LJ8(iY?-Lo<&aaYGK5?r;tAW8y<5zbpY9ZleA27Mcxv0^J5LzG=mu%@ z#|6AR#>89r0Fqn zuyuj11js{`3%{vaH zHQ??ioT`T&`T0sYno7+RM2RmT#hnjj-85syG*Iztce~x%GVcdoJ z(qiS=R^{Jz<@ZltKGaJ!%mYqn$J36+9 zu?a#BE*1zTfUX=hB)P)ZsF|BM3`q2hKWpxd`xTa-vpZ6v#0=akEHIB1XC<_3VHW+I zTKyJsWrzN1PKsKLPH-NICa#pFlsNOW%13s)>0Oap1EF&CP7K~jCnd~SE{!Nvd=4$D zbL{YTJ4PK5Xp|n7F<=I4=7D%pUBVK21KWd+OEK8l2esYieJEk!CiR`pmEKS?#SzZd z&$I!~%%I(t3R(K3YE5uqqNUG=PMnj=WyfWE=#I>i9w(PGFP|tptbsWg5#G60_MVhW zuiJ09u+KI#_2D_COAg8xMa5NnxQK1$OkL)f#Vc9`1qj2O-8n+WL<@C4joxihf;q}E z1pSk#YwjWA289mt{R=olVDOKNR=*#!7CeGpb;x3M;EnnrDjX*x0R>q=sCDsvsq*+k zmGYz!c>P9Gls-qJHbvEb2a`sgO7%t+9{z|rRU>a6oCD9Lva!$9n~DOhHh85H=ucqt zQF2QOK@=G6qCp1Kfiu>E`Y!YPZ0hvY>Ww&~7-J~=wG z^szUYpG`6!<0fRL8DVybe^aMHL}MEft4*pp`Ftcaa=dl0zxO;8fFR`r_!rI9cy1Hg zni1BM(uKI5dTcWjPx9UQ@R%T}-&W#*S7Iif7ryKS(IF5;)(jCAZ|ANtS8YgAom}!wa>D0OoI zl&CUHeX*2A8r9MBzg8DIZH#16pBMNO{wbhZd#UzyS=qfS=)S-6W$qhAylyDoBH#l5 zXkOfO0%ErJ{Iz(u&-#R(I6A_7w|IlXeumQ>Uhj{qq>$9#x*z?^0Zh_8Xc>~OpjA@F zhTQ}4P-^Mo32jnoEr;0qBrZB$)9$QW2{C3=kT?Jyml>17%z)U(ZvTXjh>C!H8#OB_ z{!Aut?i^kgch<$ihWN5EJ&b!=1$--Kx5CLj6K=N6oXfC8M8jxDim(v~!xyERW-Y{hAqms{JoMTRh ziWUHvU^ys!w+pWT&b7*k&S|c6-11Z|9-5D$(fzw#2I=ddn-t?IwawFPr|!dgD%E}} z^UCSQ9%NiMCAoBjB55f*eBEPnq~QX#>)5t!+wR!b#I|kQ_Qc5q6Wg|JO>8^aS?g83 zdsppmUEM#RpL*`=K99tW?bzd)w0BO-7FGlx_um4a9y8RTawi%pgRKbo16O0IG|xbe z^hVJO&S4gvsCPbOew!9Q51AHhigp0iRdjUvx(WqBicr;fV-yHoA9>tVl-}*gVrLi5 z;GxmQtu|^)*DOv0yPOWid86HpwMF?5WW2;1RnDW0cSzvmi zMk}0r4fOJGawL5i`-I)jwDNi}S)a>ju4S3+OKDkI8^*QX5IV59d>;=drK1Gjj%gq$ znfRh2dXrx@Vo=jy8tbC9RszLzDU?JFm3-=jJW-DYZa(hOH(_qv)xLZ`rW$W6S#29l za)N4BTW{rCu9K}$uI)xs3@g#F9I(_m8il1B)|o?fvKj(Rmf)p|`i^)xICtu%EIloB zCYF}Y=7V4Ra0?BGW3Vyk*F1j*bdvDmJ(|?taCBEQqEWI%N(tESG`xNOZGLcf_a56C zGZL`bVw;;MtD4ZLrAlS+`gy(GE!kG*DVYe}=ApiYk zBPm8Ni;Ic&({rnbK+Y2!p93LQ#Gdg}*^SZjzN0ONIhlhApu7j8jTr;zX;K;BTJ&Ep&YXnq&Zy$v%j z<$4qLxQ%j~75I6KXp}Y4u(-3w4uJe@6oQ_3QuS-kK=3T)eFXyN^u1x5UluuJjj%6H zCzn|^u=7i+dYf+*yK$h65&P|{{IL1kTEvl7z|k=!%q(mcimwFLEP`u zVA_lAk4!97N(PokVfI_iQJx>o0J5v7GzSc`nw?T5k{avOKI!32Dm%60gnoFO7$UQr ze+c5wqc9Lb8P( zkaW30%Q(`1@axK2u>PF_x2r6`y(cMLYoJj_SJ6g??uMH^=#_ydLAa8pdQZBl)4v@c zhn!sHCfzT8ac$9Q5Nf3R^-r5>O9|1|&h|P&xLIQK#V};x7#dCjlg}aT zZu^LsvxB_Qf|Q%+e}~@-%I1CTDKJZS%d%Co#_bl2EuV`Aq082EYG#@>!@Tn1l~GBX@MASE=T2R3Wb8`& z`Z#lkEE6sJ*2m7L+uXx^Lod4PwS-ZZTN``F+i`-Z_yJ#8q>4tJq|$dVA2*Sz-*aRL zIXmJEF@H5Zwa_5L%WeQXXhol_Rv>afl1DRL!Yw>*GhH9eV@aHA6ZRcvd+tjUkn4&m zaMnhqGmc4xlnge<6e$hV8qRhg*7{>wD*x7)uHh$|9JiKLy%4{bd$e`2bQu@4FbN0< zpK`aegS*_{hO+a#?=hAipkr)L0gs>a`;Z?TK`SdSSuo9=sb_af2WKQ`+IpY)3TxE+ zV6o*f15`(pa-!@~9{vmHl@>2XKV=4@`^g%Fw?AMkc(5w=4~_z0VyG5TzPx>Y(=N9B zX-qE&mk`tgBcs}g92`Y~kT?c#eeg|)g|(4|ch3j3F&J5-mCok6o#4X$=Rj@LJV5ur z^CLO1D{&|7nCSqIJ_EteB9f%}#bb$pU}6EfmY$$&VHcbIw+@KL z7ifVF#uj)y7H4QSaX9o>qEU6;r?CtSYDFH;5d{1<$*~%?_`Tr>pA0*)Z~OCgHFmV= zOg7;>AT|HcKt6v5fc=}d&uPU9eSV5gMCzVnB6p7m_O)46Fg<^cK362;=Q{8>5N|^V zl7^TYm#ZT5L&|zwQL2{p9k67h3*zCB5Nj<|lLRrA>d}P^wu*;jm?&XG3N#|u?GwN| z{EW7&*`q}w?<|LPX-}@)K$K;F4_x8J_WB&pc7M?W+SB`}X^UuWZ+n6uB>eh&x`zXG zjQB#)Ob_*KZ3cPh^L;Z{a@RCSABcwuB-L}5r5AEv?*-3f}9?a5ce5o;UCvVp#)EUIIQ2C2ivpaTRyu=y2%?3R#-H zIP6?)YJd^w>Em0p?;^+PhF>OgpFfzv=fd#SUbIi8@xY0`hu)V;x1g2VCdOYFzGzQb zE=7>W24G|iWKNTDbGqFpA)>WW|FuzCp;taLMR9^S-+No4RG-<+6v$~lWQqwFszya{ z0nXq0<R6}8RH^Vcy9n|k6) znpz+O9kcx5YcF8?zqb;@qFgJdf7RKQ*bKLaIx}eevD0FTZ$u8wpyV1}K_Te5h3yo{ zzDVrRdVwaO+T#v~W%z*qY_B;^H8&)JgW+ z4Wt6G2vDFqmCHB=L_RQ^$yqgC_IY=UDMO%z7wFxH6Tsz$W~i*iMiPl=PxCGs|9+xp ztLeAs<$v*ER)E-Z<2QL3>oP1MZ_Ti=)pc4)&M5=b|YC!MNH7< z>)AM&;=r>k_E20X6;1vxH<@&j!FVBP<}BGKP6Jk z)XX#n0J*jN9slU(sl)1A*4SPj4y|*qDY03T0_e)pC`DGH9}d3T(i#dO=`J zew02F7K@z-o8(d7Q(1myj3T>Tlc*p#1sl{TS1&QX#iDi??ZWJ z)`dDI50VFZg(2AcH+n&|a_Le)j0J{52N36F+@quX3R;_UMtwtIH53RJC$P!b#kB45 z5oOaa51K{70&Lta+ajipD|^M(E@R!2jU#L@RU{!QJ)jAUaL8l3_`T&4l$;_bvNhH^QghVT--1Xn ziMe>P*3vdHLeD#sWQlpB`qR$W$&qSe{W8k&C@XZ#E#>~P6_*P$zh zUZm@4m(wXbPRBU2Nzq=V(NTHcj}7;;7Eh`+gN&n(kuZW&;O zNC~hlQZ(v4q7w3Eg7G{&e4@fNkVGLs^9Na!NsYY~+F4)b)rZBJid`CJM(pfJ*8Z_M z=U3Urhsw5%{6)hzKk0oEmY>B~ilb*7P_zjSX65Z!7fmn#tsnG?bRu16onX!31tVU> z#wa;*y)YjV@kvLeHf|-`r;1o<+$4zY$P%x`g=`b>FfK)d%Gp3B=AMk{r=ZOe3SWIP`>bRU~9=)FXXq#OUy6Ya+{F^zcV>57P4&;lZ}c)*b}1 zr2!|%k^Rpo$3r39hma#C$v{nmSqbb>%`{=wX$?=!mrk*xVxJ|vVb`Jghwb|pgHY+)UvH^ zkTRJseo$XS;)DAmHpOviS1R#7mESLJkh%ju)mnAT=q0J+fDH_EqAMbYr!d-y!ui8@ zPajS&7Tr1xR5R*5nyS;@@o~5k@e1XaInYAEhqoL&MpmOqygCp|5C+=-i=uwk{PDfW z1C0Sb*tHk-e#^Zo&V%N$`s|Plzy(4Nk z@JF&343Y2x$7~W-p*9Jr)LbZF5S=KJb|KTP)yNmxcc7{nG zXzA416Ht~USOhVWL5?A+u_oq0#0VZMEOVK)^vVV6iVPCIq$zGG=qhst9IQf&$Ir!n zGJxg*Zr?0fxG3!vz`{qj-EJ;#mxI(`$dOLk;qOBjo;C3JkRd(;0|GrT z4B&%H!JORt=Jg1N(bxC17+p(((c`e2=fIAU!vd+r+XS^%WICRQh8>S<|2#8E3YBL- zKee~C>KnvrRRu1QG$Bjw(m%9Kkx3kLIv8Rud^`ZJcO)ss7z@(0%{?3Py&p98=e7Tb4U_x}?rdHsR%*g6_-}*z$V4U%vH`ejfJ_ zVX)Q4YWf@4S%ED5NkT(9XW?S2@dYv_DHs3;rP{#~0D8N(=VxqwoiPmY&5OrY*-X{> z_4@eNud6H8zuEZu6k@xpZ>KuDLcfXLRKCJESbEICNQu;)P+9z{8!TqCSXKbb>OIK9 z3=_;)nAwkz-7@f_cqW6YB|}wgXs!j z{0U=-giMx4*c@Q14-m>kzpW@QcY-zR8plPn)tQU3X*86y`B2TeMD+Wlix|~Y-puu& z4m51|i$9~z<7Hi(vr_WG?UVAowTzJ+yvCMd*=h$I$$}-_CD&EnvRs|An)1OZ)F=$j z{1r@^yFc>IBZhdLr1fecs2#M%opBi@;a?qWHT7rtHO|HL$<3wFX95#dSK*+%q3wd) zSU?IQ@7nK~!@=uy<}n})Fr^x1E(R!wmOzuO0rzLJlQTn8V;PV|(&2RmiPnp{+2{Rb zUsgwVx-pzu>E2}vT;i=#C$Y_yT|twH#8n9WwfrP3M=1>Y<@Db}dua){ii%R9g+ z1Pj70CEX_k+_1^t@;rdD6`i{fGFT8lCLlc@G(~-&2v`&1?^(k&ov0XjM?vExXRdAP z`H`>nd$4=}01LFWtYBp`9*y$Xee)rwAPmvX!FN9LXs(#5W)^+4VX zHJ1u)5OZzkY$KI*EG^)?tMXu!7%B%!XP)A*SOY6`6UnHLyz%#PB%)Vc`^1ZH+9-E& zmUko$)n7M!+nXkFAFdBUw)(DGlvg-PWRJ}vHSPzkDQC7?FVBw8OdOfj+Ar}6YIl^-;j+#{j>{jj36g71>6x|S%x^U&$)jd>Cij6hMqn|x7;csARbq)vQ^>fWcEziMP; zWL~*kvQQWS=kY=Vrk)o?ea?lvDn1HcIfuH;)>OGvF>9xdg>ZrzQ|_9|S1xg`KiIZ) zi?2Qw;W`ixhMQ-l*oX107e`hi5Go)bGg$pb=i_i6&PJi_!)KTYA^qphn`e;Vo$m}F z-deSqv@hVsRIVMiCq>k@XzhZad1myoU`^6kNjt%j4m0kY!cTX(zLy~%Fsu!J!iTjn zbqDXq&?^b{5i}sWpCG?9kBDC4DB1<*_=mBKbWcl8occ|qt8q^Qoj;(ub|W+($|8Tv z*P5B82rhjj;Bu<`=J7L9oGcltvsGj_2IL|@g@Qmv(?}*b4;|VPCIsBCD4w_S+zkV* zEJOWHSZSGcQXajy-o!RANNa9&vJEIZ0)DQLYmVnqMrZ;u->~w)cRkBA@L89wiW3{- zvgsO6{wVpftm{<$CRzSgir5d*gmhuZN*#RH9|{L&pLwhxvoI_1AEZG?k*>y^sqOVi zQrK%JgDbFdjc)d&E;q&2r{_95Uvh^CPTJ%s>)5r$6Z~Zwc(<40W-N}@VdH|=dIDb4zb@U zGzLA^#Hl?e3IeIRc@>fkJD9JAYWhcv3744_2zT%}&&K}&D8OZ(Mzik0u(~W{qIePK z@y6QW6us1_yMclYJ6`qBo(_jY=pI;O5i|ywYxeeIm`v*@H~RAxMEZ%PTv2VeCLj1M zRt602Pwd}=r_0IDtdF=vbd?;BBN|s@H3>UW_UE6@R?V;0MU2dTnmMcn&|>M7QzCl! zfMO}%8o}WZb0ciLP&?D9EaJY=L3wJCNmokY(gPKg4z7U_!Mi`$9k*{x$GK#J%p_p106;^B$^hM>`eodd+ zK$4gUXKN@~(OfEujYmW2LIMBkZ3+Hc-1pXX#?TFmnMjsn>?9WP4al=Ov{4|F#4^?L zdl{bZse7=e`^1&`{$C$^LQ0OA6WFPPd<=8|7x)HVWDm*|bWNBAbgya-a1e+Qb*3TK zDe7ogCC6U7<5iME`r-%>15jsRz)M*zJf-VZEpsaubRhwm;JXG=O`PKR*-Ff0Iu6^w z+`ci_N+wrWr@oiF<_l<04hVqr0AQvrrStjnEci3Rct=(V!^!ohhYW0?2x6m`*D7I*#p zbWScw$AFXUQN~p?sqvIyPS0N~m4nrI2M*t8F|}dE^LdOH*C`;-JZIiHb<9^F9F4ZK z)@*2In{cvzH|tQ0b`(6oVPn+(Ce`9Qm%LfA%h6&z>bgixIA6uZw6%ODh0nNVP%xaD z#S97PAu+KG+4h~Afwyf)PPB* z8;+n_$%;{&z36GFqXGUEWpwp_QC-#tFT$gt1~cY+HmgBHOQt2SLE7qbfKmy*oJ?RX zb=Pid^MoM%wJ?~TvGj;iq@{k$cKI_c5;uPTB}Nmrxn$Hq){#?C?w1*`uc!3EsYPaW<1{zqZID(Ok`_YkJsY)#Cp>|}$F)r_Y zVQ);NtOMMM-i+75jY>fVb5|}W+~t@r(2#!z#F>&7MS-h{+8ytv1w0yhc2>P(^*Um6 zw~{Xp_~DMfxWA;YuE`Kz-zk21xCCcbf4+UaK21*?BqLrAh2zXKzx?`LW=v#Ci^}_} z>{k-c_fGhD`xNfC)hoUrTmz7}r{+*8}VbVce46a+WYs2~5UI^{zCG!_r zXj)K{R0&Lkm|KV31sUt7D_5ST)(G0hHUp-?4kvFMp6R9;MV6vi_&e>F65GBb*zF%h zosPyDyeAcqG>MM}*zs>($@HI1bdw3_>H)f*3G%A{M2 zuy3aw(jj1&fgXSi$KhXXJDGKxqy&>gLloGPc$Zs>k_p87YdFxLDCVSBa8wpi%f|DmC3ICj{kM@TW4Jy|2V}v5M3s(QU zNR(HFGecjYPG!-2z+#F-!OKMmy7}w=YR_Rtj(TNzAdoL)$HUxsaEwTu z?FK$;J3ahp|E?llDuSP;r#K?j24OEp+g$9KY7|y>t8fkw_zJf)sjOC&Px$93E=}wQ zQq!2}fWs<24rWk_VgpF3s%O9ub`-a`#0WQG(uJ7g1tccvgY)gZ8Em_=Bd732mlm-j zBbydlIk+gjr)~s&V2tj6YyV;lmxd&jrQU&lBpiB1|3W2uGmL}_;mnW*2RXnkW#E@! zS8q=6N)^kM)o>BX{#*Tz^CaO;Vx;j?mkbJ72)^Lr&adr`TTIXBmDJAcpZpqGs4GkT zL*103f#)9-hm!L1FGMgOyS1??mKgQ0Qjl8A3C%Tp_Ewj8T>KUzG85WAT}S*cMP}rl zXKNov|8*5x>o^yJ?(wI&!kB`&7&FRAxjhcWX0$kBsry&JTc?Y9K-QgyX<>o}oPMWr zjlU0BVJu%nM2K*vSsMEo3r2U^*;qB9H-HP?!&?dpz)|KV>UhPgM6WEif@s<^L_%X{ zmJn@yA_cW6kQX1dWTaKnKlI!Ra~TLYg7g23*hzd)Q%b}#W7{tUX=4q$DD`fjakQB04s=Y+w?hRcJ>Vf z!qwf-c~|g&Fv6#jI(oJ4(7fZ8l^wr*DV5Yb z2H6P65)9ThG1dB=!n|EqR2Ls2Ab2_dbLys6L%p+l=6N%jh|0v8M2zRAs2 zX#;Ocz(_Tsb25{1qPzK2X{Wv3=>_39DF#+^Il_pxkL4Fu(RH9nn@ORZ$vur z)i|+e>7kDoCpqh}5Y=?H;dXNWQdob-OeCr@_U8^%^YGpNelk&c2c*oB)0nmNJuTb= zK_94Qs7#qT*%9$MW!L?96=nZm5)lYU!QYE_k1&125BZar*pRNQ?}^zcDpe#Ofl5TR zXL07Vlm6*Q+oOO`g}aILFb4PtAhwuUBq)gC05M1P=|XA;Ok`K3e?wKV89bRP!7CUs zX|d7n(wpV%aONqX@dyN1RwMo6>XO`_KN3JFPQ{0H`CSd95bVxMdiMwk5b{iNdvw#k zJt6AJH}H{cH^sCVgC|5BN|runBe{HEl@;MQiKkyOxG8EC85w0^{k!SIWBq$egzjuo ztInkIiIRtZ@Q zwc~-11!A?OW5Cz#e^G#mY2a`QjA5;LP>2!AaUh@lTh>2;ikEGQWR4=)GziFKvMGA2 zwTtoY5HAQz>be4YMJxAb*atwXKF%N>s3|nJsr+~Mi8EFue8&a(gO-|DLq#yh!$c4Y zAc?Z6M>17%t;DfqworzwX!hPK0@djSCKk!`PI$Vg2x?i>bKtTUZ|F4^jdP$bhJ5T{ z&7gN34L$MB6zsS@kZKv`bhJwqOWLULKK5d&73Ko-ouB|?(qc>4RW#H-erKOBnHyOktYnRNDw zh#!V`NqZ^5X$c-f#kBefQlfiU0A|*7#Hk7H6VYm%RL}JvB0#@LdS9RMqu5xcL#)dN z*;E}F$c4u;I;b+C3#hS}O=dA&{uuGH7RE=3Ui1M8Un6|%eI&&=f77ooc88-3ADHY( zs*_P9vT(P{*bEr0{8a{xd@W7q5+3^@X|mnAN4fEFBU<}bHZ6&bFNLq-zd*pBAD;+h z8`%iT@>QS2Qctg=E8RXg5e~9hKv?Pcu)Kb7uj7GbQEDI{gypiohXSd*JAr=&gR2HK&*WHb zZBW%Iz}`a=tI!4~WiY^kHc?$t_w(MfL%T33@7O=q>FiF>w5bdc|FB4}fg^D&9zC;J z_S1la<{+!N5OQ5l8}3#IxleNZ=3U#21X0u}6yLLS6;pI0TDGO$GDiwdS%r)kz|#TA zt18!`pJh|3{4Wg970sU~aZZ!+{w-B`|4GAzphal$>UCmN!7 zl!8XI&AF2=p;%s=7;H5+JIMTV*dw1xIXd8`gRdI1U{5liFt+ita2U))*SE_GQ%I_B^?JLZ(4 z5vfS6EsN+DI@X1Xjf{hn2etpj1$clSixzcZSMKMnV>Q5NuT)+Z>|(8QoDkJXO_NhX zK`P#YvXzEwHQVUhVXAgo3gyUG(H!NTiK%Hy_;?{R&IS(uZ#95F{j7zxPj?2)AC{XJ zz!OxK;ZtlvYN;7fpV&&U+jVGAwaC&Tie>@V<&N6H>>1k*Xb&j>atcG zJ3DP_7)o~?nlU`2XjVdoC99U)WY23$TS09=l&oJRU%WZ0=T4rpNGW^9Vb#7u%}bNb{0RL>&3d zPRA_n?f!b`8zXAWkw-kIFC|88Q1avzoXOReL}a+TnG;7HTsL@eHTgMB)&>73OV}{9 z&VA5c2TN=JtkV;{Li&yUN+*`p7EjCB+1i_9rFSn#$A^Uy?$_dp!RXGxk(-Bi^nQrm zY0r_rX8@8o{u0oA2W_TFESjuH3$80y`9A5CD6b0SlE8CAj70spO$nV2`rQt-jtdfY z_U8M-VJ6fAaDQLY20Zr z0zb5?!W_6PKx#-*aw7zvUp;9Ih3>=U=Sbnw9f`PcMqMq2ThqW3ftr#W4rg-oB0t{U zYh7LNaF>D}86A2P&*Ci`CnLoH%R*0ljSUzF;jZAaOD~?Ne)DtZyT$9!FqGeZV0vlu zSiH~KMh__1EUG=ZYNH)+{$_86Z@|i?Vg`#NvFLv|JDKW$z@g>PBfPo@lS^l@Gb?e? z2FQX*8bWitR--rFW&T|2w?cVoQlmBDP3~q^aU}vSfp_Ag+%-Io^H|LULIfVsGn_ZV zRvQgm{<-z9lhYZb{9T#B1MK&3c{mg%lAu1psjvMUfR%~GJW#Jtm&cEo-1wHmwA+%% zo8XuJZxu@{re`WEjGZ853;#bt0305hWKTMVu+W1@vs5aaq~t2kp$@TeiFRm(jct&iR&Cwy>qm9ElkeaW-kXPaK6bni}&Sw zYR|aNr#-Qa7`uTtpS4km7pbjf+Th2WT_&TH+p~TO1q&7qWr=B&%Gz3h3c`{&GV)`< z9^$a67z1exi?`Z&$b6f(2=1vQ21GchC}I6o5q`_7{TQoRxExm3!(yTmd;9Md8zQiBg*XCBmM>RT#0z$4NnR`>Zjrk%C3Y1_O@ILsvtf7mu`Fr>pB;6$tw+5?l# zNvPd*4T0}Od|4eC?WbHexNfz81td5W2nYq@;ue7yg_WBYI?AxAW{ zXybW&yu@dYRA%4G`+__Hrl84mS`lyrwUL(Ubs2cvd;o`x4}L2h)^mQbToGPxvxvTD zsJX{hMQ8QkC2>VoJ*?X84fiB;W`-miATN~(IOGaPDIz%jrjSVIlSm6;{pu}fE&2}+ zkQ5vWsK@-DJitVtEKYGe?Ei-cC`bO`0n+e6+dO(O%Z1K8_^#dLZOb}A=#ZaO10o{a{iii5Z98rjRJEwo}YVPnq-sSu{ zI=b9TI8(>mIo9Br@Nux=mCV9bn5Dmb$-ZLFf9mPZ>s)@$M1eo+50>2>@{D`1_JhR_ zj*rkX3l(`az3egVJHX}UJqJ_2n6d~-oTC!tUR~bI=^_ahs7Tr5*ru@S#CZ0Y{`z#A zeis`0?a$_^`f_UkQ(PPay`Z=`U@k3oUu}1Ro#*>s2bPLwcglANY#5x!E}TSgp62GL z{}`(%TrWt%w0G?Cl$Q7FMnQpJ;DMd03W0RwTS?vxBG5D zEirR`JCXTP6!sm`$E{2R+V$qpH=&EzVGc@kco7SkDCOSEICQR@tVl`{lK8lE2o6M^ z154G#r7{-p-yYnNxy%?idsvrhA#akB*)$GhHogNhbTA6@)e3NQcvlJvR+2l8TFx0N z7QIUi1KE_rdJ2ItMd^D1Ezi7}3tq#Vz+?Ca6{bWwlfiUKttC|BqD733Vla>kJaVR8z8@~ocDk*tsC$A z&zfvP449^@5BSi~50jj}(1rgg@z z-FGS{swnOeCv;IOU_Dvwx)}a$em%O$k}z)QLP-k_T=EbgF%%o^hdl1dBFX}9vY<{$ zS#%Dg0!_X0@B|%|6Q_@bkkpJ7Pf}@nORQH)gB4`lW6t0z6Wq`?c2 z?vsUxto~xCSWZd&$(SB@_7xRwBzNRl4CBdoPd8n^TI*}^rJR-=^Uk2i4}-`e<;h_9 zos(xc_f32=4^*wWwkbVaH5xv_)rXt&TV5@>DDC~02WHJEGzzzzC=`p|33cTl_T^)> z*E%?_pq2|VMY>#pEG}-CpL<`!%j>D)>rC#th5PzD-V=YY3Ss~K^!7|GWz>AP=+K>}(W3oU)wEm8a^wwTHeF{3thacuxF`;;b}{w7Ch#B zl(uXotn_fIe#g1Vd&A?=DD1VK?$5fQpEFWMxW$3lj@W{04_g7f%Stdg&>3g5PyL@q zQBY}9lp$?Cj`05=0;HC);Xl?g6mXNp@=-f~nd$CJSHbb%oj7~8xT-lX=rE8h29V-N zN4Z-+C8-am zbFgu30O{WGSppp{fHJ3gC>O|Ph^h1X9W4S327q?4;+r&SCm2UBHcaYn`Mc9ZNV_2B z0J7lgfw*U2)`+Mx`8?gTO zf3ShH|2H;}B1`maP`Ah&lpmuZzBjHK0=NhuMEI44tmz9wRX}x~g#p|oWChSdiXvo*-i5!t_=Mocf`gbk4rut|K2jy#A*+V4r2iy5xW`crCKq zmLq+hj0iHN?55obSnw-%k?{_t;H~E%uYDMB`7@cW2qsq2w%4UbDNvgY$&ITpLTtgkt-v z6kZKALZGd$z5KlwD-0<}F$>szx2)yFtwVmJDf|b)E4E@s`?Yqpg~0en%D_!ikzHoB zDEdzrH^3T;H`$Bn>~vydO<9c$NNy4{OED~&ww#|-tItgPHDv4j320%QGQl$|7}+k?WeLd*+?FPM^rB zkY&mMG=kk|I^Xl`?`FUK#)fcJxor$*Grg_WgN*4^eGdRyX!OR@pOQ+5Q7_9u4~6Jp z64i&LA>ov5p34};>qM?m6o^8dh-tunYtv>p_C8sf;+ZCcPDi~|S#ya1I8pS&vUlE# z%hLw9ajl=Q+K*6lJ|tuc($3(VCZT5`_j? zA~$Tr#GE!C8CDfLV=$VXqIp(SMyekkm4L)mTCy(Er~1qbeUFIvKlIa{%@kpV2! z3Y}DbTy6Q$ae% z8xM)rC!FDP&BoAUW6a#2P-aNBltAu6lKnAMO)9fZr*Tmey*tV{P(=?Fwg2R0IixV@ zuh*xMKDX$MqX;KD-qGI|%*RCRI}tt^DFt zEFzP;{0EFdzuDwbH&n&TUq9e*p~@V2M<++M-(!4JGzAQKw?rkWFmr5WrihCmL-reE z7tzlkDZKwNDcg9*bCZ@Z_B8t?OJ%!WAuCTBXavX?xf`43-W1KP{+zFH;&eP*Z}*)t zj85NiRa^46r*d|j--HI3woFMYyb>AiJwRPaetNjG56y6tl2XF+2FQ-+e@{6uKNDEcl)*6hcMH7ntgB_p7>>K zr;shN+8fFh<3q68QqLHBc~Gq{^7&!WAuRZfP5>w~jWP7+<*~*Tm-C<+_@2Dh#Y8XL z=C=77K2N?pLF$-x2*5}q^wl|7v3HOEc15w(6+MC2MC9a=q8opYM1#EXuRT;P@VYENwk?7R^jWT#esHWMAEHX1q!CWF z*1k|JbSNX(5B8%RSmX9Y5vMMA&F*aRmG0X&z^5E~m{(K>S!&P#9X_V8UCF~QDif|? z1{Rd_{`>W`6Gus_DJbr00=O_AAXhpV$HVnIpiD$5(-h`(K~0y^pgHhkUC)1H3K*H= z+@8RTeh}+A^G!7T$L-`aE765cFPf@Mf1L-eTA7aTo`Kr6xvx1P;y5i1c;F>wEjtnF z@7jdCI;qJf;r|ZG%|!pS_Jw~hQCEp{!@{Xz^0;&RkULT}jPT{6^R-8h!@G6B>vo^W ztriFsPm#MGLcG^YMJ{cs8@V&Qm*j630c82_Pih76Uf^?BZY_>OIy@LZJsTTJWB`Hr zm_&LhX1V?;;`v0fNA_&mi&IhK_N|Q%xW8aRm*7{RQ+YX836KIWt1mS=esVPSdEjKi zBxG05;?cD|b5xQZXl|I&2$1mKcXWc@EVh7olW=@}Fx!}^!dxX@nz|%!?XH_Y1~G0J zhHA?8S?J2e4rzx$%h+N{#8?VnHBMT%6WgoqGdVb&*Ntevaxa_rRo({S(zj_$MNqlx zq5Zv+9OvK-zSA~*Q?_xQrMO&v^UU(y>R5nZ4-lfn_p(!kG0^@@-T#@Zu#5Vl$T^_UO?!Bd}z*psnC>$+P zY*_Ukf^g+~0{ymuy3HUCe6n)`BN_{*QV=I@&S{9Y_)nXGDNbvMYI_}5!?tD~!YEf| z!M#!#TQeA4om#99$~ONfiu1VR3uMgtwHl+pET3DE*9Pg%PQ3#XbuPu%Lcjky=UwNg zk-fhLT~6hKdy(P$mbmeD;Wi|%zpiF>Gx-s){2#cU?3a$Qo?kB=Lp>WW9lk0ov_||j z`ZQx4(*+X8Cj{WJqrmq%T0pz&G`6**_nuNx5;7Hq53vH_PCGkQmESebRmHcbN80!^ z?ng6A&O}afbiu@RvPnHjEAO(^4ovk8@CBj__e}z)W_xndOSNb%imCm0NY1fhu=^kl zI=lG(4O0Fnk|4u~qiFA0aa*ylfeq(J$-`NN%aT-Lzdm|Cc-UqTb%RjUJ;X|VSjrlm=KXy4jg+jJ6(L3U8P5d$N0Qlf7TInrk;Hcd`PcRA^q)G{ z&QBO#B;G0dDnZZAqbhzq-}>%a`89ARMJq}|L6kDi7Bn3Lv4EO2!D_}%eLbzufLTGt zsxJS#2d(=7g_n?OY{>fYsUAAtK6GH`?mIuz$1%vikDhxzu9l(ixWSHOG@Ot(JuM`t z+X`d+SSqO3$_twYjpdL6U&xnT07g3l>0p z90xP-)3hlYo17Zxg1HInh9dlQlEwALiW#XQ7ZsuznMts=()Py3Sm6borGG=&)EDys z7xNR0wgFnszoyN`eVD5zQ~BU>mlBm$O;Cyx816RD+Xu#9d$0DZxrg*y?kWPM)2~En zZS6x0M;3v}z-$rl{eSu%sHst_+;eA`A+rycFWP`VH)Fppc+<=GaY5klOe^3dM7MdkIYDPCWhGS)@ z7BwRcSdUu4t6k0*65I;=cg2_#T9P7;&mx=XfH%*1XqvG$2+O(cEKFJtuSDGxNYR#V zbDqKDkCY+7D!=2xGr#g&X%DrbEtel}9LIs1?=zi}ewRh?n`y!EUkjH5WyKk+K1^sm z_dqb6PE!gdU&YM1nXldVA${9*=qfC|_!6Lf@?JV@okKsnm4BFYte3O&`EfXqcP1yp zKRVQ?C&(o)sn`1w@PbRdQVr1|PWpgX8 z#F}t2+HRK&3n88T_@DpVCC~mw?qdt@xxM@H&Q(>K;{JD!whMl(sB%c5`xY*-fAY`m<`)$sdMzfZmX`$_!a^2Y zEp_?_$UO84S@(lz8A7wal~+s2v^B-*e&1D>G1=J61mnqNQ#Mqmt~371?yoX})z##n zeYQ1}1~%bowSdcqFE~4IBd>^N=PzM*S8P2#J8*lHw{wBa?!+`ZAdCmVnTtW(E_I-B z_@$efJMGg_Y{sAC+NjKTFloq8m8h^4F0k*ip`oGQ{ceOGU9wV-|OgQ~A-?ze|Z1Mw-U!Us}yj=ALKfC;o;^{H3R8`5dIW^Rs*f ztPi(dc<|reMnWUsP&9a$uDU>8N|sP&va5?Z$yh7cZY{PnC^q+B9G#MUws15Z(P=x2 zplAJkS~;0_xz`U?mUBPa=sTTR_@M?I6s(%Dq(2!?HXiaRRXRhXzMl#I&URX8ApsX* z>1tn%a@m7Fu#LH;x30aHjI(xt>@$3h^bhf|HAZGjf4mfFY8N>;O~kJV-HnsqPG)yY z?&aN5l+m7w;eZ!_o6UfvY{#47Cy7`w%bIkVAg& z2PZ7Uv_YuJ=}W5ZxODF5XvDHKq%Sh!?b;X7F0nXm#mWj^c%#W()_Ab=Jx=MBC-Dl( zZ_QeLV0UPdY0R5c4pvvk=X`OZM7h`UBgR*pxF^{aWAR)*nnaQVjGi<8X){IenG7lx*5oa`QL z9dDf;9%INxS^;cRr*Z0c>>79F_=xoa+u_5O5{;ph!&s3}8GR4Ht>IFfw;RIbYgLQ>rVOyj_&QMp%9Ru_C*6~XTn7%Z`??=$*iVR;1*UgpyB0a(U+} z*792T^OM;3C*cB5BhBF}fyE;2Jd2lmCQ=GNiIsgKGRwz-Kf%I@wJ2dD(a#-k)Q81E;E(j>KOfxJR=Y%JZ; zRDruyaj<9oehd1x0bN|cK8~Rx3r`*|MmGq&5-(TGow4v_b@BaTE; zyMK>0L6%hjl~>a%sbVKs@OsbR+8bg+5bUsub|?~!C+90X1?P?q;MCWt_3!{ zay$k0a5INc;r;`vC>+p%C-o#S%E;pJswxd$$VoZup#04(`I}qvH@D;ma7#{bEXZfHZr|pjzmqK+YfZ>Tm7*kvIdXcL_0<<}gRgm`Z()UXMlw z)pr0100NKlAg!>OMi_MhGA^}>awvUR)Q^RQyT%h$Q6k@N9Utr+yj&MM#ENiKq^+U= zpmGejNEpCfdO3&UL@GFMfKgRzI?kk;2VBOXCxda{VsOiWKon$#wGa$Q%`fV@sMF%!4r%3l$`lcV{@ z@&1Q7o}{4h?f7665A%7^IR*~N5*1k61^5YHudEP-w<`Xyy~Mxqt21bNK$IvI3^oH)aOn9K7yS*h zigm6!o0Q=MivQ*hT3!DFexL$+6B=IcdHw#7{%yg(UekwvTfMe~Ko#lVU95jT>U6Lb z{`zS5q~i`{R~}t2S>cYpYpLH*vwzhZcFI^E+LypD2`fDiVxYjKfDaw#%ISz@`aTEe z$6zCdCtj!oRdUJ=Rdo6L@2d;ta#20OPtrzzt-&-BkuH67)rIc`4)08C+*492I;E$~ zvvsGuiIGvIWKK*d#R;dF+g8(xsq2KQ_wh6QuZ(%jm_AoOS9>1*&v>^`x&w1h?!tYu z{CdhrCz1q`>;5;$2gxHFCpM(a<<}rgq;zeph>=zgwdm?v<-gqV4`nPvdnV(aSa{Zp zr&bFhd^xFLzH-PquCG`*-gm zAKtyQ@|=@(cGU|Uz+{9i9d=MtC%=}3;Y$O*H1JDe z=IfBMJgsU>+cQ4t@~f?%cN-_aoHSm)-a2T!5=%PAGR_XkL~07oN4*wK0JPRm9y*mU z28<>3Q1N4f-o(cee4BX;(Ep=w@455&uXlAiZu9)yjTbc|$EB80i97#<6_9<80Q=SXRzJKsgpxJUZiK*Ei!CVXl;SB>ADftT{x?s+}@q^|5| zXJ9CVR=i&4mNo~n6kGH=ctXP7k$P?tjx`CGw4;A`LS{`rzSV9+oALr`=<$72vtzeD zc3jM7%ts^Ywmr0UPP}4UTsYVVO5SGo`yJP5GaQ__`4V?nRy}XS zVHMS=G@o)rd@-w1`H>Aiu+FZ)^l}UdhWqpDld{Y>H$?f2Bm=I2`TGWK81`U9cc|68 zvL3P6d<0bv>OgkY_0g;y4KLjrbfiwfTx~^^S_bhy5Qpz@5)H#mIf%v!DK4k=@vca%JANxD0`Oql0X;e{LG+^yQ4-D3Fz6&B6e2zucsVyvg_0FQH7wu9 zK?Xz81yPI?NSkiE-pFStSi)(GzI_3O=&q#c!9V10;&nRSHNpaH?mHmWI{rG>TB?dY z-YqzV2e`$2wEV{g7?i7G*8&@bQ$VLoMp=r~&T%ewtZesS6OEd91^}`&yhLRifhbca z7@7>1J3uq8p#}gai;mlJ@t%TU^&L!@NctnZEA@RB_F$EZFNb_BI{Udy2#0!bagiqZQEfO>7;$|g@Zrg%UbnrNcQOAWGz zb0H~|cBrT{MwzdL8$p6YLAdFJviO z2Zsmqzq~$tb5as4`T5G53h6kfRITP`P7e@iV~jaXq;wiBYCEk?LkSzR`b^!YTRTX( zXu9g7YkT-L3%};uQ4dH~8{fgp^BzFd!=_Pd2|V;xKjr73FCa2R^u_2r-vcQ#RB7WL zwaB444~1b)_W~uP|&@@5=>x}HL9I(2R?L#2f?#*48o!|0^)3rY?hy+e0ku;N= zsa<~GoGfEY#tSJC8Co`vzlkDsI7D>-Jf_cRP~;GdW@qR>NVky+UvbsR+t}Itx$*Da zB( zHLXj#cj1t>`^v?`G;;HH1+iWDKq*?6)qE~Gs?8#=RC~S=8Z5NXXq1Y&pMzGkm&e0@t>u}kwF57LdtwQ1Rf#Wp&Hqrt03S-ycs{qV9a>g(r-8@|bAStjOtfH!R zHCS1Wj`Zi_mF3V_v5>0KgqfzxKvn$ti@gK0G!_W@)f%{d7(8b?YHT0xotV|IplaiM za22le;`nE?EPPi*FZ+GMJ;0C=9WnZFqVZdySE@{WHIB9#KtSKTGlBPQf-OPQq~c*E zRBLUu@#-k6T2iI7Drl(o)6=yu2FW+c2=wB3clY_pPSTo6Siq!UT?04)-;ysh=TZ&% zW^qbm<=#Y^eYOpzMG~Z4-C*osQEQ zDn*zFq|P7W$+z9<_^5pYc>|8XL#G1=>0HSDJ<>XQ*^{BH3hNR3j;?Cxf3D2%h1h!C z*guswrklm^3;^-#VJro!FhBIX4#o$7sem^ns|bXWSis~U_!n1|>CQA-$&+|^F?Y6( z--b7C1ceqVzSqIcv|L@1UX%)eE*;^ks6zG5=}%(_Y;`r5iJ)a;Y+(weJDykJ7^m;M zSvA0U{febgq%@Xhyx#0E`WcmESHpZd8D0%w}tl+_U}%#LwnoDhtK!7{=FNjs*7s?-i_--svf@E3)jLjx`H#bFCrCoPq$u% zDqxwQi+#W1U$_+)xZLCF0v+XyS8Mte4q<>N%g{KEPQoMT`;v0XDq8eVAPhd9DFG7& zIdHDGp6`tjbP@8}DoVHGdIjC;xyaw8L=+6Hx^vLt6MfNFQ$3)}N21RSZ{bY`s?=&I$rWZokoCh(s$z&7i>2madP z;-Y+x!`s?>HwiF9JPckY2(=Pwf|NM*lBAp|CY{=(-7}^xMkQN$wkYX4{=5nA>=Srp zR>mT_=B284iBWzd^ylPNsNSXQtAEKHgsMG`)d|yF-#GYkl$c2QqsXC>3aJ`Hx8qQ8 z#SLVw)4lx=b;EMH3|GCfBlGa{RtRa}yOw}3V3r*!{O)x3;3RY)=R#bCZ4L8=zDJh> zMj7>9mBF_L0}QqHld$R*TRV_m5pVvQj?*KC5#cI_K$`Yy-IxI%p&;_`KpiCzGfSefZ$amrPSWsV$YgpeNlt zKgHTL3UPyGx%8I!2q7E72i*=m#F`0;a4SZs3<^#M4@JS@A)w&+5U1d}h@{{_sf-ZEjOi%GPgF>=7qg+Nye2`Nu;Zx8OJ;hrJ3dxp?a_KF}!;Nf-o^(t6 z6l=*S#4VZS(p%CJt!zsP;Hot(kVo4K733DfWyiM3M~6te@GjOizDsRiR|xkZs58DF z5zZ8T9qUaRhf1mz?$d;vDs~2n^eZa3MBk_OEJ1)tuA4#a)s32>_xv1CeEA%w`DQ^$ z^+RPd+B5`FQw&WMLL(yRBmyYij%oO>4fwB<;J*&Te?1;P-$|(!@F{46p5m3mwR)KpEuan*ny7H3k!*AU#{*JY$3vfF@nT*2;9i!FR1RjE; z2|mP6Cc20`m;|M=g|LXY9FeTjWU9C{H36360bh;iRWP1c38Q%x8q2E*KpW#YF}LeU z;$A(8Y}AuUc4=@OsmPUl5zs01B2J(}MI~hlm(FaMFDHX`@!4#ao|9S)3hG9UvRQ5F zTU6bud}Fk$-XydfDy-TLmrrk2V(22$2qP$!-Uz8^WE=2XH-W!n zE$9N=Ku{)Qdr7U1+FtY+Y%hL{Z!e>m++Jo$wkDa)_H^suWKV1h>18&~!!e~snuVNl zy&1M!UxNkeknZ@x=BLB9J-CRz8^Bn@@6J1(JtTY72Ma-9Ojg`<)ckl4hNDsQDg%7P zD-!QMdWR=swR$7e!~`A#X!waHdR?cxP$oy3fjziI6(V9u_5N2-t&B0t^C~(Q`CG@v zDm~7{XGFN&m&dzD!h-I$E(d^VI?ytfS<*`~>D+Tm3;86=yR0eQJJ}Y?)y3+vP&gT% zQdHspDO0L8#oeY9yZhHoD8=4xk(21&z`d!g!sI?ir!Ab*UWG_jivlN8AS+*tdL0aK z%to>lUZpx+g1GeuAyL%F7=_YQ3sz>nD2n1AV)172#fy^I#6)n5%ZsJ_ob*fp+}g*} z&3vmQ=8JYw{IDtT_dotYf8eS3d(kLk5XAp9X^!uIdnz!M*Tj2MI#P5DE={(tr>#qSAQmvk={)}|sa2U@77K#! zf`BIWhM09Uhl~QrYrkX=#7U)cjHZ(zl1FDPE|o8I2XD3;jX=7Q z_}^$qG9|mKMKM|L^~rYQ=iOs?A@nZmQc)5gMHHNZA|x0IC$w1jS|se*IiYK*=C}6V z<;7foU|)1?p#LIrY;><(XcXrz;`wW8I#FB<*xKNRt1J5AnS5WG3A{LeTY@%TGf1>Cv3A` z__V+G{P6kz?d%RM6s9H;Gz?SXwOE4mD0rx3>Rvviq{Jd$1!^ z>-s#TbDElIW@Zz{;2_lcDBAA8A#zD`y**w$%c_zH)uSAzN zbMWZskkZ0OCzYc;JDx@nd1`?0vAcb`cX*K6w5C{m)yeW)%Vt+Ra>hYaVR_LWP)28x zusEQEgC~n^u`NT{LUk#2!TV>+tB+SIi%a5pb!iFze|hD};&im_})(-7OcInaXOG2=hN0It`pC zgD1|b^(zTIb=+d9r1goRp6D?5$%@68qT5JB66hHfs7R2_D<>urm6OnnzpEwRc;hZwnj(1VyWDQ7P+728rI)2D? zLxuAC0y`c;3S174A_X4a9ZazYq@*)){3->XqkP`p`&-8JA1#y|E{g-I2z#$x3w~v;X*q)`dUcBkd)ypTI24_`JV&dI}^$mVggoC@Hl=wKM`Z zy^E1A zGz^59cd8fFvN+*@V5JAy_qtDG_I0GEzz_77pvPb9CTu+XF3g%omV>@+um{^mQmqc^ol=QP^0Tnrq}wZK9gU(Z8Va3C#C?{QDKWRDpD=^ zE!S;yyYD}UP2zW-(Dr$G^;sGJK3RK=f7fZLITn^)bVGytXZ2a~scO8@tp7!$fE!-)Rs;zTa_6;u8T?30l+u+z;YW(6svj z>wgLL%W1aSZY$ccr_Xk1FuNX=uzj+J#QmQBqShXTA>uV z2AFN*yZZ@s4@D8Nk?A|V9oSkYw`HB=QYE*f`D?s&N;dZ-ja6IkCF4#_?*0cXTK)Wy+@YcveJbUOWzLY_jE%4l%Y z>n&~Hce>3E2))(Txhwj0~z0vGU+AHEycZTjO<3g1?6YjmN_GJz0Ut^ z$=51)w52rC@FAWmy6?8&eXOjgaFlNNc7J;svn+0)P`wVkp}!%jnD!C=&*4dtj?=#P?gLolTsFr_W5S3akPEByPqr=DADRp{CVJ9V0NX!tV}w+{ur{LD&7Of z77>JvgAOroBMmxTLUJlpJrY&s9_T@2`%3blr|kO+IMmPit${skU0U~ajvhA?X}dh3 z=wHU{$8;=vmnN4VyHk^@O}bl;cVF(EobDcH3Ip+ET9E)*`bIM`&~55hBOKM;Xo1|f z{)|FHdi61s055;4v>UQ4?jAC9xMbqh!gI;J~}=;-Q7M_C9csA0rTpj_cnfO z?7rLGMiYNVTV;Dtsc?l#-@a)$-O+Ghcl+Yn_9-E6FEAsv3ZJ-S!z}s8cZOeZ(D2tl zBQAMmcQy+Nl{SpavV_lM4Hr0{CQTxS$fb0vIH<<%>o=#zTd$8AM_ccbrcoK%&KB{b zfg1C3_Xh6<rm~YeOmi-m2Ydm_LBTM3-3ERpPu}^`r!SP&9ElPf_k0npAt-vn|u=Bck+b)NmY zl`{WzzPsTW1L6i#L=!Ef)4B1Lz0CQJ%OBdqk-u5^DK92n>3ZQO!M5OB*^=#OqYi$} zVb;DF$Ei7S;9ZNMG{6|xP0mj(*ETP&oqL#|dQ(quud9g3EK_puI$4MI8OWYq>5Gon zv^#3S`)=P6^&e>@)R&~mybrj4>N4nT9TlH%`KSw4f+3rta>m*)xwO$3n(o$vJz<#O zkS##**Q#ik2wpT>i(4BgkAbXhhaA+nGAsH32DjSzWAaSI?A17&?{POzw;eO-I0Y(bkK0Hp&ubxL< zN^F#P=pjx><8+HXfn?Upp*^^8hC!zL1=nQxgbJD>rrE&7a;;C2OvJ0W+ zmoPKiLOA~&K7Ncmt4w(G*l(%ywF{;3LdM(Uz0>qQ(S^7XfIEFyuxd*|)c&+$K`j5& z67dNC*}!Dn|1t2SOVR|9`e!*UV!qebC7x%rPH@z_b}3sehf+Y}@C>PHG5`~(71vf9 zT(Kc5l9T0KPLD*H3~_3y>VqUDPzoXyV!nzbv4d*GJZc>C{{ca}X%F&M)%B`#**FJ^ z=aenmD*u!Fmxm(jc^y4PH59b73{+4xBrW$yY=buD`JPY-Yy9R51ItY~C8RE$!}EmG z^GBFU7|$Ghyih`|XxLDTE{4(ERG#W@$>3B)prYe`Py92yTnO5Cdo7AOr9G+$wz^+- zhjitri$?Q*4ZZV&BF<=P(f$Y?G>QM;6&sYS`6 zZe-#mfaXL8mA!c7Og(SP?B28DH@TJZn&9+$6RC#Ns!yXU1{iM+-tHajG)_1;N8|LD zquq(FOQ1_Hx3}4g$~ZWRJ2+PAy{HL`f9Z`7;T)KLyIsNHtP}WHP6Q{5UJbm40x=_X z$|VBh6QH~ZiO>x(kH1PA`~nD&d;#-GUrQVM@0ZZcNDD#6??%YT0{(SwT27y16I8sQ zmKPG}GA>WxWYQi1)vR2am5ui4E7l5aLN#Ps_RTYrv@1QKS0-HjvuKUrXwhCr<<-(z z2oj0T48^(W5A+5MwICirwLaJLF$^?2;|_1<>(-^)ZaclY zRl)!i*~+NNpk&b^F4hRD1|VmpO-z4KND1{%m>m@JvV+(^gFeA@N|n?Cc&ie%?FTd%m~7 zclt|X>-6+^@A;e4-7M`k|Cg%YZ#x*)CsVOcMJCqhQ|Sa%KE0n%hrhG?{LRaZK}`r< z1i(TEXMU4-P&Nt&2V=9m3jCHbo&InzYQgCJ;% z**-n_TTbo3zOLAPH+yQKPy-50JhifX!qmzy6Ho2&*4xI`(O%Y8Ouu9s4cznFif^Ag zz}B*F*{EoPi%x#cX4Xo&XEVP~uu0#X&?V)Y{DX%Pi4`h__XTMO~5v<){ zkJ?KQmEHgN2OslU%au^zI}Cvv-~*NQypD6@wA$_fB!qeV+29MlQmru0O45eiac#d; z3{?Q$AnO<)N;P<0G!@|y_*|=0yJ)p4@O#oGWVNDFi+6z?x)`9CgIjta-kgQbXZ-<) zUll4=@%)M|c9vJcS>hm+D!5uACnT{&C&l5w=D^=IzDucAYYU}l7YpI%S`u{9^0JeW zoSlqu5(3hVAl@M0#bDR&wf#+bi5PmRG7DIf*YF1|E7SmLpu%P8jRIW*F@P7Udbtjj zYf^=}vv+KM3d5wVh9Q{rM#Fq@W9eZwNFDK{o(&- z?`pr&NV5Lt@K@BdWLu1Ym~1v9+p~j;ksW+l(8QgPKntz*2;GDRUnb-K{@jgpDV zWY57bkLRe+b?a8$dcF5{-Ctobq?3z({ZZ88w9P#s?ggY^u{8;=sp^I1DLm%?Vg-_=bqs33ivd>^%%Tfv)}?F^84xM z$TC_d-~|25hSJHQ081=C%u@w%B{6`JBJX0-$LfT%9CLjl#=!T-%0n4xi4YgR7Y6ni z*eGQDYtI|5Q_8?a#Kl2)Lm{VL&qp66l*nlN2x}*mYFfmG?mY-HCh#U~kdQr{)biZW zjKhx`0q`Nze-FfgsX%*(ln?TaJZw}gJD1qu7(Oq!X_ICiFTks?S6~I9)x5Ec=7VO3 zYL7;wq0)K`Eczk82_37xUzhE)Mp@TX8N^?)aU%&L36yj@QNJJF#?S)=4R<9$F=K*T zXg(M+w9Lesc4FR`S2MKg$mr`JdaL*IGHJuvTo9ibK1jap%d}B&L0*mCZ7H z`Knb0$s&c0j1_BScm@3j{nF1M92tZ_isNQ2_jJF<$4cW6G>$FVEE?BPG1pVoRh={o zxbnw1ZI&POD@NXcz9V59TE4c|gum1#xi}^lezq&k{WdKAA0U}NH;+ymJJp=f7CyrL zC$dmuC6dcLgVpzR1=TlMS-v_=2y1cG!Pxi^KCR1% z)6;1(MIF?TBfgb+VMRr|Xk%vEE?!dXJx&9d2W=F&I|7|4m<&GCcuYTQ!L$I<0)8mA zS|tYF5nR#4ewGV2&t*@6k0X(y6+xrm7piyod$#xoTE+FBzNt-+1**fIMA_iPr8Elrh9 zONwDGg*4y3$DN=SjfL6-Sk(eOx$8(%emMUFKH5y|o0sj#3b86h-7L7ZZE0d|8Bp#1-!VjFbCKdkD3%n792(kr? z!h?cFhd5os{F!%1Xc0b%_gy08HgX5;s1Jr;d+7HPyTOXs_j{hu=S$pk1jiY9G!Bky zyJ~yCb$!&_3^uT3=?x~M7p#R}Z(xt47a{d531>lqRL`o_vy)f^s8O4rX|JyF=#g7D zP0oJZM>!IQG6<9RTjgN4dQ6!ftoYonkwiHkjGCn&Y@nmS!iKpIDsjuAJS~e{rvZ5u zC30dRa~e%x8MtRNcHp@I+gk+aNc3cm`@v0k?U7qSvF+a%5(qaaMN$Y9^uk4pZ@9BF zU6>@vVnQYIKC5tNXWy3&XntJ0v$N;zyh`&4-3LVfLkCuxOBeB=Qae0>-)f_MaI{;U zE@GN!F%eU_moDN-wRzG!-G;4cx^zbRVuHmPm)~u*;~B$|QWoqW$g*?^w)bj>(hCqG)$Qi)95E!p!s4i$&mtDR z*PJaBCoe7%<$ErH-oBYD5G4PQKyTkXi$J@T#>ZKUn32A?NSyH*WtuneG{uj~^-RN$ z3!gUvHN}rg_6*~&Qa|3W%rKHDX+a|i^DJG6T4h$ZP|9K=V3y_UW3M-7XqS|-pgsm! zmM_8EcfZY$08bcEp2Iy;X&lU|{=vf4KUjYCKQv~UlAN@l2$*N-Ley*9cz%DUQJdj% zH3=3I$jG^LvGy7tri+6Ki-`d_mhXLi{qx2Q=PRZx=zE1M&*GGr=Z^RxN5nHMvCaJ% z{jk4iFYG@<-DmYcbMZZ{`5YVEaitBZr?XT@mAaq;BC|b*H2cSMgrUTRWx-s}APNki zdBUjVMa7Z%mj52LR-a)5Q_6zxP9e+ECHPR8(HWSqSp6Z#@;8i=>S1$+vsb1qxM5JH zCCHIhJ?6qqJyuBO15Z6&O_{}K`MOsk)^)1DM%3#<0#d&J7w8AZ=oZ#g9#L(cR8CHt zPNA3x%X+Zzuqp-ev=M30*`PSQK9tNscWt~$hK@5D4^uQUR4;xYvWY^i1&%+CJU%X* z;xOZc@f>nIPYhHE(J0n0NlG}>O~j%8i=tKx`ch`)Cy{OLSL^l6ig>S&P@dllE*~SJ z8j~Q77307(s+7d=nv6zXFxCewUF4NW|Ypf15!KFW~DPAeWd z_&v`p@sRQEC=Qw1h1-rB_HoO$<}~e!$WQqZD=V0E@FuzvwE)Jp+xP$ER+CAyazV3f z!$d)R?d@X|o`+faryWKq9Zl1&!nMNLm*NJ?XGmq@X zAyR9@F!Jx#auR`+X$3vhVGKG|V?=VWG6q&TcE(mCiymaKnf!onX5@QFCDMC$|{kRi-q!{HXu=&>-KWV7iIQh$7fr?p{k8B1`a>xgE=IW#kd%>Ef&6_R@+ zMeoUZku~OsCE)^bl5kkVS%)eh@(BB&_ka!o6r8EAR$@$<`zUv!!NQK8w}Ut(pd_yk zwM-U#AznuRQ?baP6-+A@Q}mH=9YJ;0S*6i9>7Ey9tAd3DAUZ3W9vZ*~*qUh|#hWd7zGI+61=36yAj328~m)1ZWLsDg-di*vKMdjNH+slP#5# zp`oM8WaO(QtBEm8sw5yvmL+M*nHR{jlcp=IF@dgHClUIoKhI*1u`FX4L_MKuLpfN$ zcTNyR*>F;S zqXscJY%Rp$ufJp$rK)9@vF#odc1mrp34cFgfC^p^fYG+=V(gwX@Tqr;pr@$#1Q`0& z^&`6a8-rY6>-0vj1O8_c(o*I}j2|!}y$pzNP!&Unf^Y;&9A1cxDnei3u~O6um6wO& zP)l2_T?jiFeOQ zWeJ|a5qcojc@*{$kBv;2K*CUN(ozOvx+GVnQwqF~AtDs?u?*&>+3M0*1a% zKw&Oi77!z61t($tbzwuCeykm$`jUg;ybZHX@-Q+%qmcr#S=eB$T3BF3aD^LsaB2nC0$Ne}g@ zzZW(Or8fmNm?gpiX*|`#4+4J=Dz!TOkt3WD3K%;HjHWDSqZJuD7F!MVBGih+s)8>d znw-!wOpE_3I`%L0;f-Uzf)60sVZAAW39Lau7bENIJM9XX zb301C=I@z$zq0=0j=Mr|3g}W)kfo}AwIE{FX~6{ z+k3m8Gt+IkX+L=758KIB2S$a5V-(h}jvnMxfE6Q=6cEft7KdY!i^SPUgD|}DdtPrH zHrFUr7C430Ql)_l)2|ECw7sBkz$;O-o7r!m@#1O%el#PXuujyX!C7t%C=rDKDZ zVBIuyhZW6sg=C52oRKKiGm-bciVeByNwSiuZf4)4R7Q5FIHq&O%D%Q9;xyy~)_?kY zHuZoQKGA6-J0ZJ?>qhpCQiLA6YZ8Q;v9IjTH>J)zh{Px|MimS-)im7Hvj-7E+u-E+ z7xt&>7iI0Bl>pW7TI@1)f#qNRgIWVwj*tg3F65EU@K= z0(LkU85UX34Dx_j`Fh+SCs{uvdFAOAGz7?&)WV&pJU)r5&6D;+rSZ7ZXkap0(7n)P zstWu-)|2YMe{@~RoyFNK>+MGF4S12p<}{0zeNo8APPG3jqPKjDF^{sP zS57O7bMhe$be^990g_5G59kOY*~9T*1C0S>t~A~wQsK1T#v$j8U``GM(GEOpD=cNg z`+3M36tIXS4$e3nc?Ry9)UkjO-?St5%szL0vg4`KBL(0FlTQM@kFFzH+|i<)U{9d= zFqlLHW~BhMgiEl9BD=bp%Q2W1*qdf=QOC3(9hU!B@C#&)cw*O3Lm3UtLO94Q3(9$J zTJOxrBhBaRuQ3`5EQPqAlsb<(40-T9CzQ(tyV-87x~-f&WyjAb<=i^sLN?&1gjvAM zUWGn}Y~Ywc;=c#{Q~YvJR!NH~`?Dgs5JSQcOH4lX&2 zz1bsV5`vu>!s4-W1x9ce?~-r0!6hoij3dj_sazVFS6m^8dK*4}x&`brg*! zH@A29f7+6?UOhRfHkyuI+1}Z$?!Diy{rk82!Qs*Ie;Un`(+?ld{`^W9Vig?)G5>e?NKFkS0{u`k)!FYI#p#ftpOV1mIVzF2V2MOQT_+Uj@rIU!_a zY+$Cm2J$j9E(dI@ckjs5g8rz~&cxe7sbgN+pm2`N;wA1We4uJeLG65CD@)#h3d&~X zzk+w?sgG#V#?I@WdJJ<<}*$B;ePwuJs~BI2b#nV0~)nmUS8qcSnLM}s-zFjm57 zxVDFB{R>Tfeq9}V;#}-A?Lu6aD7$nYwTo}FBOI`S*G2Ej=w6uyvH&&?G6uw=^as+* zfIK@B$;(%ii7~vf(9<-o3_3_|q(Y~PfM;6QfhUneUv96kX|^IBPl90MSSTXR%`>HQgJb*N#SLxYFc(yQroIpk(Hp~x)@rA*${>T5I^Q! zys(D*Fzo-uHN7dPbb(|BR0xo2KE*r+-`5+Ax|_O#QC(C9;tD@ahmaZs=J=j&V30qN z@nY(Rh(Xg6W7hCSOMi4s7rVTpcyL?1nV4hZAqFu_O@~M4i`c;{Po2cBf0YLof!Gb8 zmI0W-TxNcl?81Z_nu#4-lj@3SD@0YXP=sU4}mRS4Z@yyb(byi8axTpA&2#(3lpI^<%~XGh04WJeRdQSOc>gguS! zY6b$wHj-7rdC?T!xLZiMp?vgJNpklBji69oJ4XQH>;~<&p>B?qi6QUNWld0%JwBDj zp!xFTn|NI)$@54^n7K3$$Gty16_v?2M4be5#J4{qwtR3Cc3tV7qq_vir$(7!S|((G zA4hiuJ&Gyzs};P!*QAh-Vw!sG@V68fdK6R0H+W5hLOnviHFin%*GwivRB^ljgLY%+ z+6iyVK`y!J(VQrK?PRPN=v`xEr*1G1YgWbrwE^9wcaI40?YVz3E{pVK2-!7l@uWFl zL07|iFpsw+nZjMBnEYoA@p&VB&)07Rlc@hViUv>w`qv7X`S&|mnN+2$$0BH&8TU@; z^tsnqB>HL5`OGIK>A0O^wKA;^PYIi`SA(%nR*%HlLS=x4MjKS6fs8)9I}xC+nnY0{C8bS!DK z8p*)MKCk_$Z&h_q&qW|?Z_b{x>)jw}rn~xHUH38%=(acy#)-TZGCOJ`5hbDFpGj=t zw4JD$YX5I&|8LVCtTSpgF>-Yi+M0i=eindiD~H)tOpUZ`wJrci)-bJsEC-tS0t*8r_FLH{@ma$vCMIdW#0j`p7Ab*8fnTsc&q4_V*{?817c(P*_$au0gCjGpbdls-t8;}ag2;-Bd<=7`6| z%#%XlK<-htFQ5bV!_{OmT5U8gdy}i_d7a8N{0S|6Fl@+W*XTtN-I_nvV|?*o+$h*W zy0TVG#aFg=+--k+85ynaKTji@Y?F>1cG_T`QO5OSuq@HOG{EDHpbOX4|*5nQdm(3d?Hpgrl34lpv zpp38-O;~PfQ7))C58}d1imZuLl7%K{_cL0Z2{$to){whZS%v9T=D#rjA&Z=}Cz^$b zXKTTGtyHwp`s&Gnw9?)HADr7D{vLm|-^>^Nln*-q$9rSdOq#h(KiKc_SNqL;(NFon z-=Doo#?r&ZF2(0!OQ4PE?fb!ewcpGa{gjVcumwsAv|O$q^qcvjpYnmfT?HzBEp`_8 zZu=l#^iw`;A9Qh(xqM^;nEY)j7K}G?vgh*jF4>?-LsBkRGGZD=QZTSbPmPMXm`Yfa z(zz$tqM}!hdr>Z$J&`=)l66?-L~rE}=Bxc?zWk5O&7C7P?A<4fRR&d2#R7kLCD@nVSwl(_RkQVCIu1Pn)!`W+1!#0 zDnWGxH5#4FT^GSMZT+;gB#F(vWy0Cl0JVU?zXY8;2|Xn zeJwS-g@wlR(eoSpR~8S^7kh6Yb3D*ts{^RY7x6NExT#S{l;OAf$;*wLhFiN^M>Q** zS}6E8ZB1XxIb$JRR|>YM6l^hvf1`7(Z}R{^#zoa%?;RfHR#pIb?=`#5a_A%y&gVXdS=Foynk^UzJ`I553P__6+5qp68*;aV=N73XJ_FnJTj^D8FA1*Uas-}jFMi>Jd z4IoNK86=j`;S_e5gha$#n~gex$-}L@X*SxNxUJ1u>%coDpCCyNa@?g#Wgk+(pzq(d zjm{x1n)A3^U_W@f&&qF0FbSdamUs>-1WQEE1&SE1xXl*d8d&21sp)fonHO_HGpWfr zkE;VL@%(|XU<=yGfyK|~gf;4Q+Qk0`4jA+3VZA|0kG7_l%J#{9J11Pd6D%bDJ!f51 zajN2D&YEf8GYcd6Voqqlgpz^UffPS{0F+eyhqNDN8V~1fnXy!60M65gz)3@RP#?l< z2j(6Hm2mgb=Ej`$-b9I``X-wDguXi1+;?i?=e#>NRdw?Lbzi3HzI;I4ZFh>c=bfS5 z9jDgr&b)2ywh!Ib=;z!x`KH|&blXHJClIoIIwu^P=FNc;r+%9g@7)AR0P|tA@HO5A#~oiCm~aaEWF1;B;n;0cqnw_v%eF1 zqQIQc#{qJAw=eqsr32D=`Y<@uaFm6Er*pzVF2Um+cQN$Iob|iGsNXw}+RXM5^D(&! z-MPwpJtt(I*nxjZbU||dlP?|)4bB+(;P7Tnc*r^59)^%hrQoIB%n5H}d;4f_&plT9 zWX}3R%F$f6p}l1-6n-RUZg!zLTWPtpN$X(lTJ4wHtyhPMy7FjV%sK8{^@xyeL*vkf zR>4J~nV0k4&_@Sb?#}1mbJjg*?QU>CS`ezM2=?hJ+W~x-9)+n*kT)&Mq})JL~HXxb^jUYo+(?`a^bYN5g43_06Ms zDY`_rU(MZbxuT-ms4bpn^mTAfm({2@3NklYezDJNiLS>^H|X@|Xw4M;{1$t#c$m!B zq?G*vqinS!58Cxf0L08?wtl9>y!#&t zBwTzhQi&hVz1w!TUTz*9wNun(;`zKZ>fx_D$46TUB2^#F&AD%GY#k-IcRZMvgWuYB z)Fqt&J(XcMS9(a0hpf9_INs+^aepROQfA!c>5f>w)S2WEp^5jOzyUB5ISj7vVg(XqKDCV*oA%Cf zpRjvp?AixHl1|J5=)9d*`WSYn{Y(d)rw@aZ-@WY1dG|67+U0QCPDt9Fr}NGpVw<$5 zLyb9|regA5&wG!Cv%zNG&8y+?$K6iY1p#^vMQq*~o>}G-+pt0N?r6i7d1xD=lg)!H zZ$1rP+XQi&4cHcWXbXeha2mC@^C0W1heC|5XciFz4tO(UZxk8&YrO3lx2u{bNWBi+aILxTSlOUI%dc&V53&O?~jJ?H7% z7)HeRW}eapHM#E}fFow;4?a;Zai>n=ll2jZt`}XU!8uPK1_!R>SvYw5(A&N@oP_Pv zZJK>K?~b_@p==a@i)i!dNN=ARMIP8fw?9W4*+LJdh0^++)SHLN2fF=ml(5W5JpU9} zZ4Pui17KT%BYz^)nf7zpG7sRE;aCO=EyWz0$Mf!jER+XAu#yF5FLIEX9N|N%$ozB= z5u+-zNKr!0iw9t(8Q_v{9@M*Rw;tG^oQ_1Fu>z?pc2<$OZMNF$Z{8&Aw(#KL_AeNBMGsYYfM`C?N1RD1JP_)KYjy3IR^eV$Z5)zBTKK1aGg z3#p{be6E!L4s@6)_a&tL_qCTU`zgErj@|xnh>iq(2H;eQhid^+a8qwSSsRcK_S1Un z$p6#(Kl$b}v;*nsol)ddwFD{fx$i$$Taaqw&T^ltHMpm(M7d9t_RnY`e*2kPgnJrr zi+!RtVO9&y>(A0E%z~dO^vT+VSuG?Ae2SJK1vvBW6SWO#f+pwn=V%==NMc5rPuD)= z6B6kXpQeS#z|Oq=G;Ks?Ek6~mtA0oUO~3jS?L-=6`rRjKDN;bQFF#G1HS^%vx1T9P znMLB|6#FDuN_PEHFF#GDlCy@N2v;O2x!wGP{>|uE^qDJ_gDUSTHfKwP?IT!%m+(=> z54B4#nXj&~dEDT}=F8Uc_7UgbYIzsaA@4+1b+CTy?w+H@ex|!wA3s(zsrS>=m|0*23!Z36gkvu zB&p3bubIYcV1HWrNczCi1I*Vcdpn|#e!kStZM@sv!MEM^A$=J4H2KPYX7tsOHqkHj zd7^K54ombn>2s8P0DEeBlJfhZC+fjN-)1}B(96~V{}G26`kM7;!IhOljJVvYz@D6n$Ygb&y*Gx zGZ?x>a`m9xuGQ|*FIQax5b@Vp7cIR?-jR5ayxnXO=Up@dB{w|s>Nju5f9JEVg&4CMCNgJ=a~@};+xN|>K~Y(-GX%lO`At5_7M&qyNX@l_ z8xqg{X)!=8FfX%FnNTu*pG6XG<(xQ8|7>W)38__fLTZ&IF-D;I(|yVEJ(PSH-ru7u z%{3WJ+_#qJ4P$;_yiFs9=;D35~|3-y|29!lK9eO&%ZY(3685 z`4Mtd@p6ejX)f^ZsCDpa^Jru1V69lP-#;r_ejynk*XGvL4BM&Dj+{6?6YtRtQk+wR zM^n7G=xMmWt70V;Pn1TJ3NY%HHan)sVTXF-xVj0u7uUC$BTQLanJ5CuVlYo_Ti8}7 z9Eu<(bJaFwZDl2j=BjMU+RD+mGgn2FOSjmdd6acfBR1E|-qX8b^KY4JB!iIoKTXHGN3SMRp=Zy6~d+G!CjQ=ovvS-H_%44H3=h z2S2nZgM%1qm~*_K*%|OdCpkftfK61+<^{v|LKhmLhDze<9;XHmhkXDFxgFqix&WwQ zrGQ~m$fMUKGAPk~RXJE*H z;ln%wh@AUmdWH-DgHL9_um~uVz5#b0E|d4PC7hHSag0l>4^?^}412+_6VNJS>(e$d z=`|Qpbu}{lF)NeHGc*I4Klbm0{4( zkwx@8xZnuQ^qkWkA<^eKLTSss54xP2vqVEH*9#>L-~K_etPMtMxZClGpU7=rMu=-o zQomOEGd*6#u8>lzYk>2y$XVr0*3Pa3ZKD^QQh{@1j^k&~y^n}YDyi-r;DxfcY#TLs z*{Dpj>@~d=uld+(J}rEV6JPq?VuV=7K?VIz?I%3pg{&9s$lfka2Y&R3SA0Ba(!5jdMvr)vw{H`vHpaod|k>Y;N->oK|Ye94(aAVwiwPgP`pBS7c_(1Ooh>O}*| z#cDJ`@vw_Ge8+ME@|!qNIWUF{n^>dr>FM~Cv&%}raR2%pPY809c;y$HueNsSu!#<; z=%0?yi{8hw_k$bzH{QN+%Ow{Yr(5^=6nDlS&z-dEZjjYBxV?UUq{GRKaaYa`Y7+gW|Q90!D5I$rrV+P9|4 zTKP|3wZB^M%7%^VBLMG2PPc@>pY_*d$gO(@;UvcMStFA5)j_Sj#q{EYVutPHo|YPK z8idkQD;5v*&0EQdtr;6FJY?&0r_4#iY|^cA{^pW19m!P9pE@izwX<1(qV3C9_M6v^ zAAaQ(CG9g4xo(1Io$gOav?moLAyevT5EBkA9A`T|B|87*!c`$^{MI-;DRNe+uV}v) z&(<1+QQ;CVPJa99Z0V~;qp(UV&@Vu6K_5}09FMVBF46mm$3F_I!#;yNU96w}-hA@i z>BrMboq!@??t~LNH0kY0@$?jVtG;erqSfCT(t3#=4e1q{9~RD~vDJGkX$^GPG|D}q zuB=M0?(WgboxlP5TzawcDZP*$5c5wXZq$-&mkhAca z?StG>58ghqKknW|@gDN{N?v>yFittFc!%v?)Fx{EgdUyIVMH3Gm&l=6{Qrst8Vbh7 zNj>SDG6_bvbar|lEhtp2XMCGP_J+b(@P6hb z2?PIDxwXldCFMe$f|cW&BQn&RW`m4EDpFdMY#SADho#@;$46!lf07?RdBJcp?im(Q z+QKaJTQGISda=q{t`RM=-&OV!0**1Q34V6MJ}3M{qF@L;Og>5?Sy}lj+m?U|bmDbG z@SaSA5}ZZJC`?>1^`4plXFXI3m1|C5qZAPF`(8mw%Fd{gphQj95h6wFE&=#{MC-Fw zCe-)HJ6qx|@V7PoOQ;YCn~)&z>nc9@c}c#np4ur~r6-s2$V{YtWG2%*_-%EGA+9dr zzPjNXLE7Wo?zj$K6%_gM&9`RygYqAlT>ga9L7R197DIABM`eW4pTScph)?0FjC^ng zSEY~*Y0qb#E%QEgn+O29>gS?FrC}6$rpp0USxYCBjfzufgeHCbmb^OSe)4B@jaZFH>5je ze-e||jhJy!x?1|+($TfQE83hC|1os4*(YC^a7J=zmAl4!r0Q*GMlydq_Bm5LCv7oH zOc$Z#H-+E|7`Wei7hLyf2KO;N6UgF3d~pCn=d$~#?@*0jsT@@eICaq;B0 z#md=I<+LJLlCyL+_Ni`@ScKx~O7XO?VSah1kBg1bEMP7Gr^*VdP#^!1y%H5La}}ck z=Y*a-w3m4xsMq{Cyl2fIOdV5M{z$Gv=We#c&P?ZShRNyMx%5qW4aK8|&qy(C;8#uy z#m41)Y{tV`iX@Y;QSmnJViG=r4?3OjmgbK|+0-A{fULsLzH!!T5le(W7VgWS-?X2;0g2RM5o8e};iyk$6qd!eQDqhWNnnBvh zW}udbS%@*1kb<;e)F)`bqAB5V0wi}>fXS&B;$-UDm7*+5v8uh@*9N=|{lZm-!ObK+ zT?^g;vGZtYL8gsq4(M=L>F?QWlEa{b^y=f=D(|4+#vhFOK~;gM!iH7;gxuSl<*a?U zcYLtESykNz0b#p5Hauh+7!ukZJyIZ{=v%z#HeyYo$YX8x!&n{C4LXqb(uFP1kSW@7 ziSY(lLyk-OR*ZQ?m7X@1XsUGXOnIF<8m^Q>0U5vL<~lZjT`XCT6U?_4077M1SZJzOHJP&l@uv z`n=?ncan9|Q?~Hobl37QJsUa=+uW}xoQ^vv9(UO0g=PEN-f%RXM3QJ*7wJN9WT^Yw z0>3b3Ii4qTaj_ON?GwU2MYTm>n}P*z+vq-V>N!L5MQm}?#4a&yx!bg9)qjMk2N85cSGHIb4z)%Q5*^F=z}^Tl1Mo}WK=L8f#0I(y0FdA`sT&qDDF_9i;I91*+K zwHEzrEX53==e<%+oLP$m<4G@<8e-;Ylk4&j*UE7vmh+U~V%?m{T#EHjAAURe zZIvkd4oJsS%>a!lEWM{~9QN>GXqqoGy7r z=E@i`=&~J?PMdoK(zE7$F!fZW$X2^we>h{>oe26ePK9Z;OJwr4$2XN~`+8%U8v4S9BDI?5Y)3*=Ja0Fn zvG>M#zUr0VfDJqOt#L-IScAXdzoo`fsqCG8psqj4snKW<4@brBDRL)>(+a<>yDDzm zQMMOw2T-uf+W5`s@@eDL=`?*WHGXHDOe`A<8u|O*@bM9UxH2k9|LaS07oQVwkeTvllDkf*CscvgFB=hXp3VH)+@RL+R^j^Azqol2}e%i zk|I1y+t|u~>QFlrVb8eVf-xBR-D!#>WyC z?&ndWDAyfbcg?%>^W?Y-3p}5YeqH> z7LQFU{jrjCY*sh)7<<H$$hhvtb6w)HJnbmJIE=OteEP` zEWY9;PWJ*IQ-??7XST-HE^)Wp+fqa688~uGpZ=~ghv~A(!wQXR0y_XvkmD8Fpc27F>I`flp+XScIS+`N!?l7EHRi=yxzKP5i3AVV%HJRe{0Xn1x@(N^Bkb7kz2QY@fAqr+y#35im;&?n zvLG1orz)y!{Zxz^+)kVpEm@;XN0D8tmYkl+VrIs38$`IGY)6+qESY}dtLY}b$GyZa z?Id4rbJNkkv<`N+c3-WgyGu8aF>}8h!XOvhpjLBw3!wlA>sf^Nmw~+U{Np{+sXK*J zIlBlfO!T##-mgpg?dwZ@A#+X7`HOjM=KbrEelsuPMfkd8znho3CSRB2i#~=A+3!xr zK1wI_*VmV2ixOi!ro*9#TAky1yj2`p_SU?&^)e3KAzOiV1RpxA8(r0d-sKg`<=9ui zr)$hPrCqfq5Y0UCwOFEo-xJvb>_+LR64yBn{`~Nz(Br|)3hBpc`a;Qc&b>7wgb*8A| z-c)gYYKyDQ02h+)_EmiC$?N!cqA|Bf{5t_9T`c*`7EO-O{7OJd7IB|s8q5}TpW5Pj zElMfK<=u2zj2S_Ld=Z5QCIUummNnz~(LBbL_Q`B( zp^#8}r@LLsLHKGb{5v*wIF0q|LRnE&M&Vg-^X>Vr{rj2i(<3NRWT43%w>VKqXxZ`L(#o96@NpWdh?jX~MDt1Y%6~wnG5WHMUvpTP2*TS>o zeF{YUI_B^0wQ;-iJO~}S`Z`0Ci~8Uv{qi;pOZDF|)9dm^vn) z=^dqy-Axq_#Tn>n;nC+!9!qU)NB)TY@Ss(%rF%^MrEMP$Mqv8mi6}>+YG;vA(gCtw zX#0bsY%=uf9S2+Zn_URlE_#B;311t;)V#iCaob#P+`Bdf7pRt1dEN z8x*>>9gQy3Un#9E+U0;^EEDW?gW;q{j9WdS+?w4dLITEFbet%bK+ukE+fk>=BZI~Y z55nYdZ8n-LGn(*T1=#(yo(cUC5B;8jr4V3TZdIn7b-^(AnSr`(wwdG9k~wnUwTqN+diYLSdB z29me{Q`kZsDu&4&cVGF=$g7QJRM%!I@5## z)<&+GwPWw8!la0!4os8CNpY|fV1+xLl3r7zH*HNw5i|LMYFq?W&nd@f0cs%Ucv!<{ zZ11=oHyp+%QE}0`-e|<;b6J>P&Fcpj6C&6q;k0u#o4R{2kQ}P-OZ7M=m_D_;DF_Lj zzU^>gJrYYlYf1dIx9k#H{7r)xdBxdPiNNvBb1IkuZxyJyQJAeMmd*{gHWRRmEgv$5 zN3ljRZ`M}58E@*)+W+X44Al;ae|_-IzIf<)6>c$`r7mwm(;|gMz^41FS`5}&iJQ@&zIKdN7VRD zb&yMI1WmuMd3AQvil;+fJHNR|<79R1tnn3Ko}ShLo1Qn$>7y>6t1N$RtWsU}F7q0m z$NmQ%brzCp7FXA(b0W2d(3%E-m)7v`;;s*8512Rt!|+Cu-~ z6-qaHryOjxX4&U1p$aX4dT|@nARcC);J*fd+aKM6Phbgkyxu!JS}UHG7V)KWT9inH z^y;~}T@h0cFXc*Q?8uc$H(qq*<=xT#^alG>B@DbvJt`eTesR3Dy#WA@)W(nqX$E#f@0m+#I zHjMkR%3p`XT{G0@F~z~p5%chGUUAu=36#HcgfswmXcNEJ_iD}jAp-N|F9kz()1D1*WDX}rfujlL_n zQ>jngMHQ)DLKGA6IZD^!q=c7h3RxS;?72-R3{e;1pwi z_ (v8E}u@>${0uA(7&}J(29{P zXixD%brZ)2ts}y-hu+J*1Mg^We|z)i&20~e02ZXHUh&?h7QDzG_9nL;rx(hIFcP?> zJX0j$2t+=084FI*~f6?w5Rbc-nyKyORwyr|zdjq1*4Dv{9=;$kja`M{;R(#|^^OjCaUrDh#|I1sT zukL8;4%{{m9(6=WTzc@14>KZx+C%>^j2xvNxSMYAZy*>W=@c^_9mt*!J%AVOpA+l%ShRSU8{dq9WT%>PM=ljZ0@&@4vsg)P^`#W`QO>jV6P7Ym)3L=Vo5#8@!{2K zyyS6MclOIqk1k!89m(l|E^$TC6g! zr&i}c9O`*J7OoKC%${Sw@ZJvmE(f7Q8~_Py?pZ5P+9akIuZVgpo7g21B0xgiX&kO0 z@~^BWT0=&j+Grdi+=xP9M?t5jylMO{d|-ybwLnDj&TxcD=hEC6&Z0Ev+m+`A!Z2m|B``+Sw+&^cAA>!J2gp zSNAR^3FfR5@5%D=vbC2n7RFKaw}txBrR%Tm>r&U3s&A@nz$}}F`}F2c3rE5UASH9W zdVcE2eGIa#yh>rcQyB7G=y84QfK909(Y--S!LWy$@lo4$OPq>jX9~iP)}Fd4ph) z&H{t=M}+KvvItwT*)W^$*hb*(MR%@5{?xd&(y&2}@EeRc45bP5qUP?N4LE4x(h{5G zE2J~EJ$h(w&G9bxZqHX z8vem^1T>1n8YOGZnAiX`(EKSQU~pUJ7{fW`SX{3k9}Ah>T|^ff`^nEvD<@zclv*xnHOsz8 zcO{mam0QlWi0xclN(`yrIZNC}dCRF)ilu`c@3dIbBBumd(ySCE&5D?rqL3|9G=WSs zdpV@Ouv&5oEPUmaI4Lv8DL1t*w~P)2NcjD$e98Y;+JG&%Juo=Kxe^|ocPy=y=693u@{ zT9ymFUBn0D58{KSf=Gsy`sLjy6|`LWhF~qOx_>%L!hda?4VUbCAZ- zWYrSL{RtdG>(LbrrGQXH>*45j%wDC7#GN(2|NdDOf4}9w-|^q?t3+WgFZ16f|9#AV zpYY$ORfd!NN6(+}+i&^rcl?*(G#O5_>Ai#*_hEQ3xu%_-1L7qlm7GTL}>buRMD zxHloX9+Ukl9MgFsd_MVm@A4f{%iPyzI;NXjw;u?og(k(QXcJyz^cL10=B ze*d<`c{Jz0#b03u?U z26DCGm^sT(W!MOvZis^zxSeEV;llZ_UEsd+#4|Po2+%qvFx(h;jhDoqm|o>>fOt$@ z6Dsa19BI-lT4r;m2>8XckI4Yj^~=`L>%HS6ueJLt{1FdYyGOr1w-`5guUX|lX!Rh9 zKLt) zp{^JF_p~4^PNSO9S{X@zIjt;|<`M#Zd+Wu~-rlwD}Cr z$=%$Ld$a>Z{b3<=#|pcZVzO?zpFc*bB}Q0a^$3ty>m#dwaKi z$W`#go;#5lPdyaq7O4bqpl=_N3W{Q)3*d|u^Zkmyg|;xHT!ctMI` zu~IMKNZ(A@Sxdg6-X?nzu|$4GT~rNj0rW#XKXtBuoX-psUp>B{u0n3;>2W;ZGZe78+ zo}{w}zdOSA+I#Vz8^=2`K>d#LJ2d-YS42s!3c(1xCNbt`Mptha#p?9}mBTI2=Gw$l z0UEcF_o5)q*#k~zEW);bO zN>i8p@I2iXo^jfWyjFxz9){31q2L3WMI@khT$7tkJwvk_+uLy-S4$+*Q&1sXNx!G2 z+mE8Kg9y525%HY86P?RlUeSX#2t7{miyvmjXTLVri$CsM5tT|it|gaQi!ZR3eIlQD zn`y?Cp(%-i?U&oFSBF|$ez>a{Nc6H^U$CV^LdLC`Z*7!lgJWWF*~fZw$?4$aORSN% z6M1-auqDTYzd4f_Sp}IA7#Ic7K@wFu9uM&qL=!Ry`C0(61T~e`!+b^jKJSGsJsr+0 zpM2%s7<#UJm`qB+a*4Nl$WJsB34I|)dBBJlds3OYfkUR{3?o=I4QhC6tDXM?8Dy^Z3a@`&-o z43%}VL&@YtY()slDyJJgqynDY*AFQ*&*)`#p*S7Gig@Jr#(9Hpqf}c<-8&13(x2E1 zL8^p#Oil*QHxUqjdT;;0wAgs759z8?(d8_aev5O^*9*fz+x~Lea33=XteNhC*BFup zM3R`PR>#C=__VaU!+`n1NTRsRQ`0>}P12kgpmPEoWrmh>xmR(Tq%5RT@ueTfkyMO> zImS(J8*vE8Qv5wJEy{1ldK)IcZOo@QZME{HCJ8rD7A*OfPk=mDq>Bt9P~69TvsNTA z5kMWi1bh~G@byX;>rU&{)_Qw=hd2=Xm5HBeG!df&ph|~G2qpI(Fc=^CKNqmO+9)R* zJpRdW{9*3`qAL+t?zDEdUTz*9we5wRc*4_!5zDFWjiwy$QxR>~+xVq*@KO@On`=t? z#zNGNw|D5hq5J;u*PY{|ExqvdhYMOF3VE`t@jz_o4N6G>+uhmR*g8`F17BzK@q(7n zF!ZcKmOiJTZEx)hFN`mM)bDm1h`S&3FNATE1qVOmcdlxC-g$2*E1H0_XXkIv%-d{8 z&z=yJ$z1@w=5qasLVflmhWqRZ^F7WjndM!4FfX+6n0b*;kuEs0mfM_q^@us9=xR(g z;%nUbZ4OPW2nx+DEv8L3Dw)!)z*hqc;e1QS8Nx&BL5oSHqqx1i7o7i6!>nQ7hf!d% ztHoy?Sw~pHYEJ3(7L; znHyT}m-84=4~hoei@>xyrMl*5I#@mRAO*~~qWO!^L39eoisRg01oJ(Ui@sjPr7?z4V5KEQLx@3#7&0FwD#1&IZzcRdQBbQr zoI$=lYW>~T&SpWo&a^<3=xge6e3CJl?j@*Yt0op5VjWImdmHY�rnXb!VbMBe9}+Z0jv3`7vy1EpID88JkF_2+fs!F(F{mLrKG^{vwT>hKVh+0_Z|qZp=@e(0LnVSt2llpz{I@q8VUEgwz{UDq78i%H z#F^^Ii#DVNT-o_;-r4i#{LVe)(xH4IjVs$oh*#W)D(NRedg@#}R#~;KMx7 zD|aFUod`gTlGZ%&`?5pp_DUos>#nebWm}L_hZh&3eTOV~I%MGs&CoDx>(h9a zfca>**nYHAg?J#{E*pg+;Zj04Be_6~DUHD$R>TV}-Ry=&vd46FM}DNX&+qJL)Ue5& zlX~I0pAYW3pF03vK%u`ML^8Yw!tCDCeaPxajB&&%y>2RCf4LZ!qmo z{9zDIqyDY6BC2(myQzgn-Sp>z1=VSX4o{zKhTi3?GGTgN>vxh9eV?LM$XMDW?v6B1 z^V{k6A~7(FVJk~(2v2^(f_$EmdV$L)l*4V_o;s&mFRd}oEt9))(jTJu`oRroI6+Yn zm=(-*TUV49FGl0DUgkDo^QR}36MA#gx(d6byejQI*zwzQo@{u=yM%<*J=`4{jna$Q z`y%_#^q?N^AFN;0mI4XXk$B_gCeJ}%vlu`Zf3bjm7+mLLx5V2-CiGY`lWmsi2x9My zLq{%UmT4x#j^0_~E=-!K_0eH zjDhoBB%2L}gbX`uEs$-6FS#7BnWr(#Fs6P_A)%3^R4h$rVbHDDosQ*x)2m}aY!3%4 z1PsUT!~l%e*4DSy3~X~A)6Mcag*j%v&C};wj-Xf@gF-C|GUGY-jmZe_A@QNBXBxL= zCAp2;w_94Ws368zfDti5A-sy z<}H!3XF&Cr&}B?G1()r#ZP^)!edY|}76vF6hEygBF-k}W*SJbKj67l4dytPURvV{sY z3Egp(T>H0?A^fxq(Y|?)^JL~M7f-igsZ9OtO2jkIxzpyB!xg1c6-^(l{>f@>JQChB z*%aGB8)8PANj%Fm!HXbcWJ%DCVe-|eIsq*8EJ3mi1Gv9pD~r5D4x^PIESi)K2K!tjx5c2a7SYzmU3}`X;!3kDWL9?2dF{SDkrJ>%<4Ur54E&F1~EwHa3&0f z&Z%|}u$n-m9+*vM2A@I(-BrC#O?y;5wB>bNb;FNajV;Ui3(9H zNXlp)ga~Ja`OvuSBsecM0pK0ylHGSsvEarTQ*1CLOuILCH!_CZ>d+KNL08LK2_xY5 zZXPdH9RH`&84ghFC=Lg9W}4YsoDK}_!9f%U1bD?JH2pr!=ZdvWg0Ib(tFq3`k6`*P zPH4v2Y<+KgdvpD$4N~fmi0t>haX4gIv(Xt<6@N*K1n9lbvT(6?nObRFY5$&ppK>@$yjw$51V(4c=X8wiM5dBW7sTgD(vePYu;m-p4T^)$ncgFE_153Kd9WP1 zt(87s7R`|EkVl)AzPwD@Kz@*1+EjX=Y}y&cKUO|%2lbDVQKwe^3&^Qw&dnE*RU7F4 zXnD11=Z}zC&u;5~R&G6WCBLlfdS)|!fc!c=^?!s6+m81SlVhh_{2!NP-**c`|gSQ17+WLcjSLg{ynQ-|LbJnse$~Fa_}^I`XglFv)1hk%EQ|ZFZ^X?;gYt6AME}pq%()wL$jzl( zR(9^zPs-2R2_e`&iwxcLDlJD(OYdTNx{0%9!Z+IZ!?msrFZAJq$ARDM15+s)cQ`Pc zsX)Ku!t}#^(I_3Y4qj~@;o^47IM2B^ZYFJn#-t;R2+A-xDQKQo$WNCG?bbSmKrcDJ z3!k)zCD_hy_HQXjKky21a1g4b*Z0=EWf8Kbv&V874`mPnF%E90v4;BRJJt1OP+JJbkKh;UT(Y;ZMHVGHL8Vm7^ly*wLSFJQOY;ZzYvIN7o5 za9HLW$XBXWri|lXK1YuceMr1X0UlAEZXs#v5U!$Y#Pbd%6f@y92}iVnx;BU#;tvJH z40n(p8KV7u7>Qe8Jd=oRJTXC%tP)^x98@p_ak0m_;)zn;`!+S<9;lHa&Lq=@e&=00 zojmYsklEq~1!p| zP;_dOL%8rIHm(BxFKQU33XT^pd*!@4(W)6mqUa) zY=fF*1_)9E+J&MQ6ol{6t+3t$&Y^jsjya_ zf5bEt{^Q^O{;&Nb%HZOnS9@GK z5cq)&AUMb?hpwU;vBPYL^z?xSaP0DxZ`5Ak%uUV&y6XrjM^@m-SRFEn)_Qwm^X2jG z;t74D&-M1sPHVsYV!O5em+h^?qqAz^1claLZ?6BP{d%*tv3am~65U1(Fmm-PdjIIr ziR|O{6|}+Spi>E|QxqSifW^-lNPM}^YRugA zQ2f(1lPqnaWher^Pv6G{m}aFm^Ip-d-Tr$p4rjdfhr|rhD-*6B18>pLW%!FHCb|?{ z_{GwK7h8gm_BrMiN5l=s?`S3p`CY^F6IK<2VG)Nx6HwRgGBNe=bpI_^S#Q{m=-#P% z`v-eR?E_kA#EslEQmewUCx`smT`zv zf8yJqrsXaSPfP$-BL5IiRN!Ffixm^Uh^t<7**+wYj2k*4>)xz)R2Pl!-xXt2p z2S??lYADYEq2f;2f|t-6VvpYr!f7N>Py)W1{-x0;orh|}brC{Cq{1Fz4JN%HT9sPO zI%2I#1l^Ihiyaj~yn+S<6rBZz1_l&-TFkZy1o}4}qA~&pv&dE>=OT^+gHS^+hQ=H7 z8vBICVF3g;v@tt9sF)enhz2qaU`m8IjDhF_>Qa0q(c{TA3m%a_Msupj&=b2gWr=~rTDyC@i@)yd9UoRC{|C%QEMI!g2?fXX zyyM7WSdtLv5|WM~VpZE9cAifU*XYr~ukH1{o&Bxt&BemWf)U94fLjxRFQWR@kA>u8 zxlG-s(;=O@E}qfD3urrSH@Fvt1sO;3sr^-0fb8L-fcv{gn{Y@>TcYIiv#RA(QzOCb z&VD%zD>~uk$}Qy-^Ah~l9d}_Od&`};kk5O1F=LE4qm55Qh&U0ZEktUToEz>0iXoz? zy|_}nUQgVZA5z6@P28U`a>XT@M436*(%ynGj#QO`0P@en_Y&V?DzTL9=Kn-2QH?Re z;rbpODTE^Vbes@%LPiMPcS~N*f!1Ac=b<-SGJSCpPYkv=wF{FMu9u|cgxV$Me(`nd z=S?AXk*2KbHLH?#<77il6+xYc3ae9B91%rn7Q&jN9~+xLxBt3%u$S8x(}NT#a9{I! z67Opon{;-wv(KG2Pk;Z-%6~5ZZzX4Szw-z3|4&vP(>vn-A3y$fdHLJNPl^9uS*DMF z^Z$RqzwWS)1THN3WQ;5pKPF*hY=dogM*-aO{=w$K=Kot0|9KU zx3=4dzaAcK?i42enD{so9{qRsXUz$_{;^Qd+v9gU{HT}5#rXYFE$Cl}Q^@v)#6Ojc zjwSu6sbY#zz=W|HUOcpP4XelW6fu#@bI!K6DIxOwaAtUe+Bq9Igg(COjIw^81ndm*Y`_c${J zCsZ7V!%K+fhc(zW_o(d}aTQZGD3Hu$P9hJsF)-y=Q6Mz*J;Tr4Ap2fyb1SSwP{q`g%0FZnz55W5NYaDPnhX3 zy0IRTXAH%3QRP|PdZ93Q(w2OfizjV@+B$dz(;;l}^)0$-&Z;Mf{}unPpoWmXGiy*G z^uKLF>S{dQxYP01H*X52lv4$57z@K0tyJQkw|RvZQys0&s)xoo)6}9gR^eU9-Dw@# zukbEt@7a#3lGr(@JFWGDy*6#)#goAkfTfKa$aeFdJ*gquqh^$_^0mXQzi#fmTs(oC zr#<1WyfK{0LHp;;-Hp8iezZ=|-|X!l>0!Vl?rIx4jCN~#+v9{AmW=I8$1sW|Qi-i6 z(S>L_q*Z2hsc{yFMRbU%|GwRcRpjr9TM5T3dn;1S*l8-;bb{zB-oOt7%D3VTEQexe zD_PW{uDw^gu-Sp4B7=Z$&5siGvre48_rnj+R6|Zc!+*JV&=!?9(%r5X<@uX8sTXhF z6br1Pr&Zf&ZS5Y>e>9UjdmEdDwAA!)F=q5qGS9*x_}l#Q*Ut-amW_Ttgz;Sp^*PIYM%{v}O!Y(dh7uzLQr z;&jM7L$Sbw;`ZL|tM=C(_GGC>|07~v;H|Y<2kWn& zJ$dfM@U>v!k=PUX{n3@5uC=}Yx|OJdLeC42h^5=|?@OULL zRunQd&S|FE8`KnkK`e<|8U^Bhb;i9Y37+ub%a>d2^@FWLw;BqXHi!U7)_HmGvs;$l zo1#~v5$`?PAyXDxjp$a6I*CW7Om;Q)TZEo>kKee!M?S+=&^)OSfF)`@d(wWre^<4< zO0%j^o!+0ndzRcm`Xqk?y*$|5d~vvux26hjTT?n}#B{I9pcrZc@$u zvbCGs7~Ckxj=qQu8q!RITbDa5GM1l=0%Jb`zGzI&g*u=ZqRR&nqd7a^`ari;6mgmn zcBl%FM#nWz@V%iA@iJf#P%d6G&WK1>30LDdTDZw@(1nE%XPh04du+`^y+{}=q*{lq z0<+mBe|+XWCy^h9<|?DIgvz&%41HWq&Hy35A&j(&rA3(P!pcKz{wu{YAxajl%@0Dp zNmaTdovpA`Q|WGUF*jNVza$TCY6~sZqOgy{v{G-LoGjPAKRb&-*zzd>2I!OUqAg?! z-R)1}xrp0-?#07PAt`j8o|w>XN};?KT&mn!}2yT2q#Qwdx8yG-ftQl-ChO7}WY@A`ia(jD3&9*79# zziuX~+Ts>Kc+(3~RrlU(C2OIKtq@H7%T$HUqt>fL1(b=qIEre~Wv|ww8}Dg-iDlr< zqi6OJhA@UmJ~58{!{i7?kz!G;V#yE#!nxD$q=p%d>;~7Z7hCrby@34e2`JtBdPUtD z_HfrLbrcU|cWdu3ak+CjQ)v`l2jfwatkP$=C~l+oE~&Hk%jUs;g0$AM*e!#`erJ%Krwzd=a4drYZ zsruee&BV{G#I~XLmJpf*!^lq*esi?BdzfI)rI1unk*g7P(H(toybCFW%Dmh+_V%tg z>b%$!Va-!fgsa5bIegXLJUG}pSUf3;G@I48;&l}aJ@x7$a)z(sdQo&$X}Jh+oJvG) zv`K3329GQ0vfxp3%HnaREU#HkVSb(|O*eKE(4myR5>vDd8RaIuAIVnoGA-} zD{ptw<7`ggSJu*4x#z^Z%+>?Flvf4Mv!y|f<(0GGi%P={mB9|>(4&psS?@UD5BQ9{U~p;HF7ak9-e9)?Btf* z$(DrpFRv_~XG%NLyqr4D+f2=u2S4Z3pr=`kOt*R-LZ-*L$YLg%$eF>z*Ljd%=akEZ zdYHE=Myi;%1@u*39f$|>tKdye4V6OX*3oyFT1RX%lc|8mnX*Jv#agY|0Rr3CG*_jnpmC2icmwRh%m)yYsG8% zqF29))mpW`6WgCAgJX?UhV@!5WK8Jvu0coI%D#QI<}EvRbhg4QdOKYqWAT$y2ev=1 z*$>QEjTgZ{GGQS+5ws^rIB(K6IZP(Z8qW*~ni*-6U&Lm9Glm_Hc;<8@1~#*$yGNZj zTG5K<42lJ0J$8{i=WOdT7rvIUVWf>zu9CsM(8wM?&;9)_bwqh8+8z| zgu~8ogTtU00*N!^{-+1 z|EF=g+lxkzR~D&Og`NXMvGV+^3Xc}HgS%s};)^m*L3U1w$LUN^Vwmm>6?IoRO71&a zfb#n$w(xtD+W53*ctf<0TkZYzgUxL*^n2u`j=qIe3OZQz<{q{t`hdX>w6&V2jq$y^xC_UeA@1!;ebxbk1Y zK>ZOLq?Ko)7``#+ajmXMr0o63_IemcJz~{CX?@+ZD6ZqYrJ~l=+gthZ>t?J+NNw-9 zPqeC{z_@2q*c$g^2+Z)j$iYtWXCVSV>hyYZV*xIGKMF_{o9Fy!B2PN&QqT*JnxZD)tmRcw+`30wm##qbF&XvXPL3N7g~znztZV)^DMR0xo@qt z!*eforYCo|wh3W^Q8}9Z#;S<*q+~q9ACW3Tv~q1y#Hc@L=79^w!ub)37bN9ej$)xGd%!nZ|)o)9kh1# z+xuX4n`UpD`4v69a2nUXBsRUL?>yfZJz@m5k6><1|Lwfk+io8puJ0Xey7rH7aF$?V zY_d9zI>fQ%Y>&9_2GlOB5& zB{qeFr*9A|!E_a8gKK8@^~}P~v^)P!*8L$=0*SRpyd7Q==_TUSuxT^`Q;)GYSvasy zJFDPNGcEn_)+sw zJj`A*8gmpu>UAC*(fnOaU;iW87A7(;>_WTkPl)?CNBHaZ;^O;W)I0C>dz0J6;#IHP z4Ti-^rILdl2(l0ero+v9Y<^{(0+g>&4dg*3qx+))8^NFOH99 zAIQ137RSYuYfzXUd*iiUw_ofX9qsKbo*+60f^*#06;n=?*{#DJ8^Hs=rRE~s2`ip1 zl!sr11wNeFvh!|T6A47&%-xHb4aWc_!iek9C^UH`{a|D3z%9iAE#-m3{C9)%>1DOx z^8EZLrpox|B?sIHyFoq+&t>lC-8VL09KTBNy%{E*D2A~gw^_F=c@E>F;O^>5X1o%6 zD$)@n#}9_APj$rX+sDzT*&Bf0B}8bM@oRlu+ z>G+~h16C2lj_7FFgniR#j-wNp@O2wPBg39%G>b$e-Cb~-isK5r9Rtz6LCnZpCL!>Dbd z&fl)RO)xT}F%d-)ZJ-uLHCybhP3oBiVT643iue4vN6W@672!_0ix4QTE^q6NrAoSs zrR48M9`rZ^re}?D5_4z5Dc&)B*Bm3|NmOuL>XigLT+}FBbVBY6vz~~ZVe3cZ4k*np z6>=T1JRHaD_)YOF(SMjk*v>bIwvtU!zgkTKbYCR^AQn;#V25xli*g)@^()UlwtnMr z$$>wNe+Ye7A9bXSz2l?(DiT20=nbVnD^?VmRf4vDyDQWPD*Y9szk zd%v~*7lLbL?VKp4IbeeIz6Lg_y>4qIn@@Mh@K}p0zpomULW<|bWSAYP3SgUQ2yXO=mUOJBQF2Np3H1qfxKfDp79obo;4 zl;vktkN$qkf4{@uX7fHQ17N?5ae9Ur$k7#{x5zv4hcrD^2FxvfDkc&@)YRMX9c@j_1^oFj5&~gzQ42RP0wISqzo|iM2(-98#1W8e zW0?4%8#+EaT!fva_b)aH*=;VKl$OtQ*gQov>~?8+v9wevoK^B>t03Xi&c}iOP8I;S zh34=y=`bY*6=#`A=q4p2od=G%e=C{%OoAtK?@0Qpjz7gV_dAG}Fr2t4punO=fYuwD zEO@=YBd2SOd-Dg4P)*}tfS|0F1B&{7L>w_HkEYQTBUKg&a2<~xBa0yiWTUC#$bF5a z(piPEFu1No+eEeS=mhW4jPS*DoH>1Ux8G*A%~h*WB7S;!H7Ykon4L?4yQtVk9F?GXP;JZv(rW zLz}fBhpeaz8)C!@;>A+Tc+G~eUy76K zM%a17@Y>FFwnwXl*0GbNC#Owpquikg%0?_!Gh$r^z75+MI28#tsiKEkv;Krr?h)zT zm29N6Xrg0Wm3_H>U&q|*@m_peW0?jaMNPCx)L3?U6=^7y;UL1ZN{T?sPLjy5RdvF9 z%tfRu$R383RD200Kn+F#pNEKADMT-GD#GewvEt2WLiOc|6oIs#GwA`%v)Nd`Xzeg{ z+SkhI3%^_}{q7v4Z%WRO#z*aRr{4FA1pwIC+&^3^DYSyY%WLJ@Rssj7p*CEwAB&Ef z_e5cxRorLVQsyBV6E^lG-G%Y4L-=E2S~-Ca^1#5?XgEo3Mks+$AJb4Q8E8eP1$`S6 zd+FnB2!gHM!=u*rHgt7ggdoshYHaMS1VQ@d`yvE^3EK9>hye~}trP)WtIP{=6OsTI zjTRQ{1q-&kdN<`TlWxF#JcM${r5gyy11X0bx&c5QOgYS?8<q*`YggDF}+E`!$ItMghy(UtOde_R}%C9m48Dgh3;T$TR?ko zmb-kMC81c`cEEUU5gXNlW(7hRnsUtkq}`=ksyERe$VrZO?5kl<=%d=fgs2?M2ufN!8tWh zC274}sD#%`hQX5*4Sa39%>`VxrnxyI(ll0LViEN38$OLbks2$}ThlxA+TORSmCy~x zculRMx~^3s3zrh8N-!a#=p-RRP1uZiK**4gcg_5dd)>e&>tg#WcRJX6h%a7Cb^sG! z^*BeKS*=2r+BU^4rTr;Xa6IirT@*tC7i)c#u#XK@>-=V#w&284U8>|S>gQ4FX0=lt z{4^S!N%Yi^ETNtn+C#~8&r9Y=`R6Czvp1qe^3bW!{d2hAI$D37uUg4UaTAq{44+Pt zz0E)hysek3lC<$!Qka<4cTq}j5(WK>RaI}svTPM&tI!+ZdlycRS&_+-`T((=;SX>t zsSEWA)nqT|Ml?MqqVd1zaxbr15jyJ#oEtX=O-;u&jA+(*B5K+s9}suEBGT6!!G5<7 z$3+(H7u^k2w1Qb$c_KlkYc^2Q!(TgmgEJ9=rIfg#OExu^7!jsCn^0GYB|A6CU>4u2hbVXd-0!(^zwLnv%TBe z*}OyH2M!eJD}|t;de8`fq7(I&1H`)wIRz^9F>d9MaWU;3f`ha>c&l$*Mj)i2C3&wdsE8(_TYSw`ZX{8W8$7)jawaZpx(f9UY8hkiY?FlNZ z-vhJi5bmti6E(TzexL|MXO(f5dvXj<)&;L~6(Y&&c`&&~AW+}lORNw!!K)l?DKx>z zARO2Wm!LSN0?LMibr)7KaoM?meB}_4Ar_(n&c&jHIE?D;-KfVq@lq4L2BKdj5;Rwl zoWs;@9T}{(?~iHZI?Dw5nms zd9{0-JYuFc3k0Mmj`=s6ZYMgEWjENgz?@XE1Yr7~&w**zHj}cffVly~&@2nam6fx; zNv;L4GIOM529>CR0==)he40cw6jrT%Whdms7TDNa-(EBv93kopzZ2MyPpY~o^A-^fTQ4`a4>$7-X}pt}@*-EHl01*f$%u*i z-N#Yc6)w6aRxEd(NJknSIh&jY%f=M$fsEZP-2UXaWnAQyYslWv;@+z39+6bg^oB$r z_w+6{TPvPv?`;-%*)YxuGE)FdJ-hm4rj=%Wo++hbb4_O~+IY}pQoVa8GATNF=tLUx zg&7kGkCmB|h{5XwvJjw}gPE(@RjDT7S4B=xMLzOji2oBuGLzqtzy?W$pfMwIAIfRU z=mw>rE7h|Fld`-=cV3t3%5*!5FHLj|ODU-VbR;sE1w&58_l+VCUDGO(SaR2vV+JKHu}>p^Lwi6^-{L#$Y5FB59%DR>txu7O&Wm zE@7O=8Ias(Z*y=@nF+|ZsUuYOLJg;2sAE+hT=KnZXLYIaDEBgpI}DL&Vt08)Sd=@4 zVr?r2b#ZGfDan&q5W#*Bu$vmFR!|7I_aWcV;qwj6n8GGoy66qNDJ7pK6-5W5x=$H+@_y{ui-EP#Zs?`U&Fv8D=y`ryodXF$HIOZs;pt5)_mO8LYL$V-l^Epb=a^G3CDfyR~B-Mc*Z2rIFE#Ra$KeR{%-FF&=Pla%sZ;tLO zvfny-J+sUPQTs^7FuN2s$j0{eUTb3}kVHhl+)^9`pW6C$=dM!Hp}qahU7DkPpzmz4 z%f5!xKX~<5c`NC!Id7pF!!!3ur=BTS_3}xS(9r!G+b`F5^GhhdyG>UF`jcM>>@Y2$ zP7EIn(H)vJilAw#5b8OuUxH@{I|u%_-!oy{#Zsm#QYV&Dv2_m~$KLBbK&Cph6NjrT zRMRZ-N)}2N9C3a$qMQGs*O9;thHfzy8WXP{_>iwL%FC4=v)xBH?n*Z&;@8u0Bd=BE zu7@I&?L&HFf*9YmnsHk5$g_SAWRr6ojnjniSPXj9>%2n_ckwuK<$DpQ@x}?Hq8Hr! zk!@8ygtM*7$kk1S$<_sjny^_f#kGz{2#c4OTW@wYSIt!pf|rm1k+iW>6r<0>Biqd4 zO8x2gNsL>m&m=r_N2NvHF?;>G>G$f{S$(Ngt(M=4Vo5}Du1e0fV2H3pCUW9hdeNjy ztI4a6#N_;?+sCtk-?^%VjqWY~0{b_duwY7jPgH4?k-@kPNkWbjx*KWR^~N3)J@^De zL7xs7Rgpka)t08rSQ3z;$+(aBhx|FZodE!Eg=@|(u^?3!a|?geKHmL*$9qSc8*Y*6 zNfF_RKx5JOBes3&Tp<*uB`nbjh>*2HKuoh&6#7clRi|7XuiL-|r^VvT9;p|^J)JVX z5+}uy+fcf9^3-;XSv2V$@C!0hu?EF`yW$}9ofJ~5jZT}2GLT*ng`rr%Nr}s9nYFX6dWFH zDg&6z15a)>Hmu3%sug@{7A*IbBY`a~z-27n*3EvV_4byd9f#sE4&>@UChXGXT*t=F6KE1anlYX+4+9&=JC=8`un8btm~JRx<(^j z@Qzj36>B|&nwX5Ifg$1%`9~BUti62NOcgx9CCHGvW(lKuIeh(=)jW z9caSI&oM4F?4iz|oIKHt<9Ajyran^5CXAJsyLOH`qp1mXqv=JBYHlXrVOU6HZPqY0 z`a2N_d%<=G#e6H#zHaMs?C+hPoC0d{UG_GPfnJbcIz&9>wF?`&$*{->tO2*F&7sQ**&YTh)o~zoOk?5 z9J09!_DJC{s=1>7z#N6+cP4VeP)#E~=fw5mfpZWrIX#5U-Uo7`12)qZB$w&+gm`^H zFYKWpP-p;DLNXHhux*z<2qt&&b^QVJJq#w2eR%#VaZ=<5)QK)+Rh?xt-G`FJy=@jP zUr1k`)Nd+c^En+(dLpoa?E#_<1W{E%(EXiUF*ME)S7WW$%YI+T~5^)d8&7VnB2ou>+IB;iMjl*?8`ST%wYLy17ab zD4$?e^GL@f+F(nJ@MdloGkKA9R^hXQCiG}vwdfg>jeItELLYz}{x*Er9g$27F=w6I z=>1d9LEZ@;*H`TKr|+NP+jQ8wK~NQZ-yzD62`yjXTHQNq$qQ zP3;CC;~BkoI;+4yRj)|2Zc%r&bNbS=!N=}X27UOtb+EZH$Do~p*+GwI4>@&ZN7D;- z&e6ejZ(;J1J+;oZzwgApHqt#WPoMMIXVd|odopp`a+o$sXC(z5e% zo6X;SY=W&?&tUkzHx7sFH)&^&>BDX?L6EUwAQapk^Eh*-@-~=ftIFzoxr)UvvRO?7 z$=#YzPR=sa&k^{!D$UQ>vql$etgkIP$lszuSIEouy)Us*=@}dt6VF)`K4aHrfW-SY z3%?+iBN8Fln+3sIfFyE<-_Z~!TFDs*^35r+lgjjohHm(Kv9V?D0je#^ga)a}O#_ zH{b8`wF?HwgkHQz_%WoHm@KiG~>l5j18p z^EnYSiyaOHFd6&E)WB`9KTV|0Gc0oOB)~(wf%A5QqU6{TB)vb9NZ7F$kv);4;+FTD z2kh46{$5KekL`0+>Tb6jhvZ{9y0Z zL2GC6t&l;;bcqjJ~dQrS*8oty%67!FI zgy%GCP+gp4Jy9~T(@ohzIw}PnaP*WuI37j((<>$BAQ6f}jX1h}&S)j^CZwhdx0uM& zaFPJ$U>zb|+nA)aq>%_MylP-`QI4rK7uJb&xf&~%*ZOl-%Ro$>duQ8rW!Jic$UUpM z1Mwa_n9n_e?tm0pYIzu;c8h7#q+}^;tKsUQMJai5(tP^tTUa_(BpfgYyp6TTptI>Z zukH99hydSs&E@)&dV1RtNd!YCIR{XNPDi=>W8>HD`SwNz+?U%VY;na0y1??(^FZ~` zp92(&)b_jGb~w~H5(K$(dkNLE_rZh4`5IrsXaygm>&GJZO}HPzmW!*fHHq?Bo;3$M zi5>c2OD09()_3+LdT)HMZSQTUitO>B4`iQwm%qkyE-}=~1jsslV_iQJS4*#SadU9o z29p5!mTN+}DOqSKH~qbqWLe#A6%F#nNrBavXwkrzy2UIrngFYy^k>Woh$DeOD#om0 z?gc9ixb(7@#Z`R6DnMhc3n!|H&00O``x6+i3%Q&kRIRD7nBl5@tLA%0;G5e)2rCIF z@DN|4C#kw-aB(qZE4NyF0om)#V6I}`GA8Kdy?w)+IyC$}Tq%{>dZFB?YXkndY^a5s zl=URD%FhhSz}ogire-lT^n|gq3FBF93m0dbH2%+7Nm0^n{WJJi&Jk*Q(zCYFT`$3s z#$2efpK<5zEg&3aGVeC~-yojN4?nQ!+}_IqC%hUCB=;?DgT>14AKeVx?z`ujJ#_i` z$ASUCf*{QUy7_Z!dy&Hn@n|XzqrBklBIJdrvoFW~xk^fSw4!{ZibJrQYqq{3A!$L6nO>5gS~Q^uX-qkxJlKun^;dj*IIJm$^t%lUi(Vyc-K zgJ=AE=91QDy@FEKxwHL?To!ZotY<`O58+IcsTl8LPpvd(mTc1mw?x38ZZ~;1sW|}k zUwxvT)?iT3o|;=?_REABjLP40_+&>+Fq2=_NLxVBs_H-7+WaJF)e7?sy!v0?;vQSJ=^gsHMs z_5)3-0AUZTrA4Biaaxz8uTlC6jrY%<-_%JTBcTq)cZ{S0vi$1W_tHn1uB8;0}1;**b-yR!nH%5=`}}3=h-k}`jnD=X_e#r>E)f3YTD1$WrQtxsYs&i^OsDkyC${Bu)Dd;7lxvd``9Bl3$WtRW`Ok%(`Sdv+L zC+|7?i3Ybkkn=z$wreNMrV^v?F$KZiIqCJTC%6AyBT<*B409p6g!jzxxw>((Tavm$@C-6~C2qIZN&#ErIQ_ z;JvuDwgT6IIddk+(t0eoKujGD(WA?8%U;^`!mL051ywKpzP{c%{3Z$}9Pt{Gqz@lF zJXVg zFmUYd959kuA_;`cb4+%e*q0hC5@EAz#)7uf10AU;LpL^wGTqqRUEkU~)Q%@mI3Juh zh)>que6!!$-SFo9_wW55@Bf#q+Yo;&^=FD5+I4;*01J_K%}yGE7f@x068z~6XEC7u zmP--}x0VG1iu~OM~!ct?@eWIlk(Z@J=fz7-sE)lq(9r+v5rPI!ua!hq*W8xUGoWoG_7f-?w0?2aE$#@Q` z?6$yxTv${N2QJVxfr${G0>?9JM#e@{YAG*~#r!UOQ9%VGl7lRz)7u7b`r##Ka%Evp zr0Fo63^9H($}Mql?sz%qt27VTaa{7oJ?&)Sn8m6-s5|iO_?g{21nX-GJNwU%r^jhe z5eUpi{KyH0!+IHRTK9r%K{uxhVd(@Q_B=VK0~e>KA?iqXt(-;<&R^5D*7$L{yQa~U zJ%Sd9dl?UiJpl{T@o}%2jZdY@IGf_3MAI0l8f6^5lfwq(7BQTJf~>J4Y}7NSz#{M_4r1O?)UFL~lUmq*tNDOh6GQ+7#{gdQ*IK8xp=Ztf4VFr)56TbC&yE8HvZdAviR3u zd!y^_+nD@vLPU5E_;)|~)%^bZZ~tZ34>!;TV(wQxKL0iQeD2iU$l5K~g|h~BneX@e zDTX*5G9&$-m(OvzXp1l_ z)I!?2p-Jb+%!ck1y%+zvZa(G7 z@jf0bvR3)(j+AUiarajZYt`oCzv3`e4= zqZrdJ8->CdI`b5%W4~n(u9qEhmaulI_ZMZG*)^g?t3CKW~y_UpiLsRr6M-MW9s$Z@zMVA zQ4Hi)i$-&cvv60#$mJFwK!j*p>wk$uPR7^Y`Z`O@PH2icowZ_#HjHoxX1BH34kp%5 zXtg(Q_|ml1Xg|$S4LgtR3$+^W$ZWOpWvBDlqd(<50Niu}1R8$;5Zd*L&f^r!(fL>F z|Cy*pzw@f)w3`ZAZvf!t%4=6c0J@5J=bT5A+djKkmKaX95h%bq@9A!DyQ0Uq5kyr_ zBvZt#+uD(Ba=htW$B2VZz|am=E+%t-3?%WW2nzUEbw%HWx{;t{La}>sB3g;}5CD^m z7z%;l7&hVMG*Z1`BG`@_n1a)z@)bYkpq2#sWjJOq9I}HmPfz$}A9M6@oM8Z?lPYn< z&^KBZ85<+)Y*&1*I~@#e<<6E|L*;s}vIc`V`0l!=R_F|pha7I>rN zdZxS4>1I3ji(aWJ=+Lk?yxPv@(&!(q%*b%!8a@R>u(1_HV#13VF8}AyAeM> zlC`z#$}m{?b2Oelds2=(T19kWYdyZ!X;}bXRwCIsq_t%jtV<3qF3^GS!VT0cf*-)+ z(VBHljj>>3sZ7Tl*)<+6r(Kf%B|r=etsqk;NpIXmkqtppS11TBxaZ`q4aHR0aoI{C z5a>&a3G=}Wig^nmLT%`sl%vLP3rnYqCw}ekt=eCgYu}$OomMKP#%Z%LDxY~jc=d*E zm$$~S4Epuyum`oT-(S1%g&!~pC7gRjj8d4&D=N04FEk$ui_)*9Q?CX`vs3q5CDi~& z#nZ@d92vy`=8NDT)kdXYe2{|?_M{jWrsmPwe1lM%Oh-5aB7bBOd;l@CyOLHuCB_2= zR%Am+y<@S;_1GT~5j4I`oD6Y)3?ZxPPX|NqyJc^Yn>np8RTGB>bWABUi<@t83y(#} zZ^Sa9j+Wo;sDS###L+UjiaHIN~_+FI9iR^ zVzQ9PO3?IHyvN=X@2U69NhiP-nq}*Z!M2){Xi_fq%Jr*a+50gUC`Wc={98;k8%;_* zs^-ZAD&Oh6ZPu?uo^CCDB}S3gT=p90y(#^R|CX3}ioaUlr9{dvH;RHw1GTni{^=k!&O7T3EKh=aI?DNcxLiKe`%3lP+Q9 zqQbxigutG#<8+LuRntjKi62gf`^28FfAdYejo4})d)Y_<70?wm-RJw*qxOZczm9jT z-ZQ+bh0&|Z?%Ntpg1*AAv9qpxNHxPLYu0!t$~|IrLB=qgW`{8OT4LHtzY`I<`R1q= zezb)Kz2P+CqQzRsm;*nGPBhFIvG7BpOe%H@9Eo|06kv=IvDize1m+{?nnhqTt6Dw2 z7GeyCJApAZwCD&XPTdQVQ8kAlu1C2Y$c;Lqk-ou;)VkPZ5JK#79KOR@kX;Be!spG#(kASJ zP)2j*M;4ATD8CIRB9G^UiM-qzWDU4B7>3i!D?>nB5;YnldM0O}R`TE3;{yedni8>Y zDPd998;typGs$Kr&)mi7eVpDc!=U2v{AR+k!v0hSvu1bsso_%Of=nKuj#5W!=A6XE zsXi{7wG^K6CWBG#t0Q`6E0PBezZk`F;oVo6gxYl zP( zXd^6Yrm3pU8^J=8UKC9cw0MlI86N~T85sEEcagWq0VpM1`Y-I^TtT=;R-MWWO}dzN z6K8dRlq;8k1tp0mpbGO%Czu-)i$PY>a&~Cp7vh6J*BTI#$b@P;`&Ay^xAkSdQNFD= z`M~!j`@%Hp->%w<9*V9K^A=MpW{9iOE?YlHU+AJLKZn|p2s=)~V52EG=mi{`e+g7< z0!?xnJM`$g`tsc^%S5g^?d_M7Lyqz5qWI^e`dIc78{D`N#JjAV0GBLYNgfrmX}s0v zN#~$>cpQT^Y^5AT9*5Ww*0ny1>DJcg=B?NSKB0}-*xc77vnLj@%_C$XC`lC<+a_Q5 z*vTW|lM3Ekcbx>AXS`&jGsStjfLjvsC`}g?+rNtZF%t`A!CSW+Lo%(h@}GAMh1_Z=(G?5talp}RB4|{cDc0~e zp=7elgWv5%cQ+7?*iMN!Q`*=PVvPkkiAWc7Z9RJf#PXvx*Gj}(u^g}hvcwlOg@@a% z!`Ex&)3QnphIDd9Yi0T@vz{<@IJh1rbpCE74r;R9naa_;Vlfcg&zbd8B}7U1N_`-7xhsLJ)1Tict5nrh{=j0`J?+lqa6LzjbFsA!Y0c=|pG!wotdUG**| zD*GB-@D*!BTx@o>^U{PhXW@A)e{mx}^0r2QK`PPKy z7s)~@CkAw>#uhgAH!_M>CF<(2e8NPU9&mhYo@CRZ$O!aJ?RsxmcC%`*cwiKSqdtf! z9uMSH&oN-lfro)3UWw;VEL`TN5y{A;Qy@yIY%)+tb}y#SjE0f9y46H$qcED(M&l4^ z1QiMk)|{U5reWtxZx~z)L_U}!Ogfk5&H(jbpM|;IxxNbffkhAK&Se;O)slCWWoS(3 z!9vdGMyzadAQ=T$mY;lQ*j((kZaL1q!kSm{FPw09jgaoi^73-s@P;aTMpCYY`ck~8 z=eO1vpuSXnQyrD#|SxAkl=Lpe6++<~C3c?y*+x=+`MmQI+Ru&IYygVYBtQ31Da2~J#7La(C4f55?}6-;%m>ed%>d`8xuD_5gL$F_b1p)at?`+xier>N zc9J*CVYM>R1+TOyW3H$yq&HTFRS!pAtpfPqU*lRaLUysok5e?TI|~NukLawi;5rm8 zi*0CaBd|1plB+YB5<(@UIt}6+LVPx1ZWyP<1*$ap`^?-JcV(I)cUpx{=Lv%$t!WY_ zweg!`S@kd859R=z79Kg6^VIgWQMUV`+_)^eNpTl=7kcc!$$Q$;^T7>N2?=o_t9tba zHA)yvb_38r*>ci3U_^U!*)u(4MEf1Kcm4t!&wXN?Vt~k27mLv}1Of!&JoCwhlTvt* zbwkiy%qypoZvOZvK_KrYA(R>TbRr|k^Qe%`2sn*B8PZZhYm9C9zUMo9kwc|1sn}DE zfX(B`bcM~Rl}A7pIH!Wp4oFkM$sUa}g;6u`jZm)dm-Sjuy*eZ^RG+2fJ)0gg^v=U@ zLNuK}O6omtMa(W~YSqCj=9TWIud-%<%t7(#HdYHK#tGiFKLBZ8EJ9L!FA=9cv$pbD z5>m{cB$$<=&7Qmw+FZWk1rm-ey;1*sL*Hlr8iu~kc@U&Y`&oh=g+z%>J69~o8`ylw zY%Y&Yk8OyJctJooq1=dexDUN2YIlOMCOw7BkYK!+P7GlvnQFNu-#hPJ(w2oWupI8B zi?sTzRy}nxB?fbMuO_h+&MJ8|PQ-oh@N91D

    NB These are just suggestions. They're not set in stone. Some of +them are probably misguided. If you disagree with them, feel free to +modify this document (and make your commit message reasonably +informative) or mail someone (eg. The GHC mailing list) + +